From 3af7f749acb7ceae71bb1d463289e86a3f8715ee Mon Sep 17 00:00:00 2001 From: Robert Ryne Date: Wed, 3 Mar 2021 12:48:51 -0700 Subject: [PATCH 1/4] First commit --- OpticsJan2020/MLI_light_optics/00readme | 1 + .../MLI_light_optics/Includes/actpar.inc | 2 + .../MLI_light_optics/Includes/aimdef.inc | 8 + .../MLI_light_optics/Includes/amdiip.inc | 8 + .../MLI_light_optics/Includes/bfield.inc | 4 + .../MLI_light_optics/Includes/buffer.inc | 6 + .../MLI_light_optics/Includes/codes.inc | 35 + .../MLI_light_optics/Includes/combs.inc | 1 + .../MLI_light_optics/Includes/const.inc | 9 + .../Includes/copy_of_stubs.inc | 445 + .../MLI_light_optics/Includes/core.inc | 10 + .../MLI_light_optics/Includes/core_old.inc | 6 + .../MLI_light_optics/Includes/deriv.inc | 8 + .../MLI_light_optics/Includes/dip.inc | 4 + .../MLI_light_optics/Includes/dr.inc | 2 + .../MLI_light_optics/Includes/drl.inc | 2 + .../MLI_light_optics/Includes/ebdata.inc | 32 + .../MLI_light_optics/Includes/expon.inc | 7 + .../MLI_light_optics/Includes/extalk.inc | 1 + .../MLI_light_optics/Includes/files.inc | 8 + .../MLI_light_optics/Includes/fitbuf.inc | 6 + .../MLI_light_optics/Includes/fitdat.inc | 12 + .../MLI_light_optics/Includes/frnt.inc | 3 + .../MLI_light_optics/Includes/gronax.inc | 4 + .../MLI_light_optics/Includes/hmflag.inc | 1 + .../MLI_light_optics/Includes/id.inc | 3 + .../MLI_light_optics/Includes/impli.inc | 1 + .../MLI_light_optics/Includes/incmif.inc | 12 + .../MLI_light_optics/Includes/ind.inc | 1 + .../MLI_light_optics/Includes/ind3.inc | 1 + .../MLI_light_optics/Includes/infin.inc | 2 + .../MLI_light_optics/Includes/iprod.inc | 3 + .../MLI_light_optics/Includes/ja3.inc | 1 + .../MLI_light_optics/Includes/keyset.inc | 7 + .../MLI_light_optics/Includes/labpnt.inc | 5 + .../MLI_light_optics/Includes/len.inc | 1 + .../MLI_light_optics/Includes/len3.inc | 1 + .../MLI_light_optics/Includes/lims.inc | 3 + .../MLI_light_optics/Includes/linbuf.inc | 7 + .../MLI_light_optics/Includes/loop.inc | 5 + .../MLI_light_optics/Includes/map.inc | 3 + .../MLI_light_optics/Includes/maxcat.inc | 5 + .../MLI_light_optics/Includes/merit.inc | 2 + .../MLI_light_optics/Includes/minvar.inc | 5 + .../MLI_light_optics/Includes/mliinc.tar | Bin 0 -> 112640 bytes .../MLI_light_optics/Includes/mpi_stubs.inc | 12 + .../Includes/mpi_stubs_placeholder.inc | 12 + .../MLI_light_optics/Includes/multipole.inc | 14 + .../MLI_light_optics/Includes/nlsvar.inc | 6 + .../MLI_light_optics/Includes/nnprint.inc | 1 + .../MLI_light_optics/Includes/nturn.inc | 2 + .../MLI_light_optics/Includes/order.inc | 3 + .../MLI_light_optics/Includes/param.inc | 6 + .../MLI_light_optics/Includes/parset.inc | 3 + .../MLI_light_optics/Includes/pbkh.inc | 1 + .../MLI_light_optics/Includes/pbkh_bck.inc | 1 + .../MLI_light_optics/Includes/pie.inc | 2 + .../MLI_light_optics/Includes/pq.inc | 1 + .../MLI_light_optics/Includes/previous.inc | 3 + .../MLI_light_optics/Includes/prodex.inc | 3 + .../MLI_light_optics/Includes/psflag.inc | 2 + .../MLI_light_optics/Includes/quadp.inc | 1 + .../MLI_light_optics/Includes/quadpn.inc | 1 + .../MLI_light_optics/Includes/recmul.inc | 1 + .../MLI_light_optics/Includes/setref.inc | 3 + .../MLI_light_optics/Includes/sigbuf.inc | 4 + .../MLI_light_optics/Includes/sincos.inc | 4 + .../MLI_light_optics/Includes/sol.inc | 5 + .../MLI_light_optics/Includes/sr.inc | 2 + .../MLI_light_optics/Includes/srl.inc | 2 + .../MLI_light_optics/Includes/stack.inc | 13 + .../MLI_light_optics/Includes/status.inc | 7 + .../MLI_light_optics/Includes/stmap.inc | 8 + .../MLI_light_optics/Includes/supres.inc | 1 + .../MLI_light_optics/Includes/symp.inc | 3 + .../MLI_light_optics/Includes/talk.inc | 2 + .../MLI_light_optics/Includes/taylor.inc | 5 + .../MLI_light_optics/Includes/time.inc | 2 + .../MLI_light_optics/Includes/usrdat.inc | 1 + .../MLI_light_optics/Includes/vblist.inc | 3 + .../MLI_light_optics/Includes/vecpot.inc | 2 + .../MLI_light_optics/Includes/xvary.inc | 8 + .../MLI_light_optics/Includes/zeroes.inc | 2 + .../MLI_light_optics/Includes/zz.inc | 6 + .../MLI_light_optics/Makedir/makefile | 295 + OpticsJan2020/MLI_light_optics/Src/afro.f | 8787 +++++++++++++++++ .../MLI_light_optics/Src/afro_mod.f90 | 177 + OpticsJan2020/MLI_light_optics/Src/anal.f | 4813 +++++++++ OpticsJan2020/MLI_light_optics/Src/base.f | 1032 ++ OpticsJan2020/MLI_light_optics/Src/bessjm.f | 723 ++ OpticsJan2020/MLI_light_optics/Src/book.f | 1032 ++ OpticsJan2020/MLI_light_optics/Src/boundp3d.f | 72 + OpticsJan2020/MLI_light_optics/Src/cfbdang.f | 177 + OpticsJan2020/MLI_light_optics/Src/cfqd.f | 826 ++ OpticsJan2020/MLI_light_optics/Src/coil.f | 700 ++ OpticsJan2020/MLI_light_optics/Src/comm.f | 932 ++ OpticsJan2020/MLI_light_optics/Src/cons.f | 59 + .../MLI_light_optics/Src/constants_mod.f90 | 151 + .../MLI_light_optics/Src/curve_fit.f90 | 604 ++ .../MLI_light_optics/Src/depositrho.f | 95 + .../MLI_light_optics/Src/diagnostics.f | 905 ++ OpticsJan2020/MLI_light_optics/Src/dist.f | 2255 +++++ OpticsJan2020/MLI_light_optics/Src/dummy.f | 87 + OpticsJan2020/MLI_light_optics/Src/dumpin.f | 4190 ++++++++ .../MLI_light_optics/Src/e_gengrad_mod.f | 1222 +++ OpticsJan2020/MLI_light_optics/Src/ebcomp.f | 1138 +++ OpticsJan2020/MLI_light_optics/Src/elem.f | 2480 +++++ OpticsJan2020/MLI_light_optics/Src/env.f | 844 ++ OpticsJan2020/MLI_light_optics/Src/euclid.f | 114 + OpticsJan2020/MLI_light_optics/Src/fftessl.f | 65 + OpticsJan2020/MLI_light_optics/Src/fftpkgq.f | 372 + .../MLI_light_optics/Src/fftw_dummy.f | 17 + .../MLI_light_optics/Src/fparser.f90 | 737 ++ OpticsJan2020/MLI_light_optics/Src/gendip5.f | 641 ++ .../MLI_light_optics/Src/gengrad_mod.f | 37 + OpticsJan2020/MLI_light_optics/Src/genm.f | 526 + OpticsJan2020/MLI_light_optics/Src/gensol.f | 511 + .../MLI_light_optics/Src/greenfn_mod.f90 | 573 ++ OpticsJan2020/MLI_light_optics/Src/hamdrift.f | 58 + OpticsJan2020/MLI_light_optics/Src/imkmpak.f | 1380 +++ OpticsJan2020/MLI_light_optics/Src/inpu.f | 1857 ++++ OpticsJan2020/MLI_light_optics/Src/integ.f | 803 ++ OpticsJan2020/MLI_light_optics/Src/iron.f | 2264 +++++ OpticsJan2020/MLI_light_optics/Src/liea.f | 1900 ++++ .../MLI_light_optics/Src/liea_mod.f90 | 4 + OpticsJan2020/MLI_light_optics/Src/linpak.f | 1187 +++ .../MLI_light_optics/Src/linpak_all.f | 1615 +++ .../MLI_light_optics/Src/linpak_old.f | 1187 +++ OpticsJan2020/MLI_light_optics/Src/magnet.f | 3985 ++++++++ OpticsJan2020/MLI_light_optics/Src/makeit | 2 + OpticsJan2020/MLI_light_optics/Src/math.f | 2037 ++++ OpticsJan2020/MLI_light_optics/Src/meri.f | 793 ++ OpticsJan2020/MLI_light_optics/Src/mpi.f | 161 + OpticsJan2020/MLI_light_optics/Src/mpif.h | 29 + .../MLI_light_optics/Src/multitrack_mod.f90 | 62 + OpticsJan2020/MLI_light_optics/Src/myblas.f | 932 ++ .../MLI_light_optics/Src/mygenrec5.f | 554 ++ OpticsJan2020/MLI_light_optics/Src/myprot5.f | 83 + OpticsJan2020/MLI_light_optics/Src/opti.f | 1798 ++++ OpticsJan2020/MLI_light_optics/Src/optics.f | 299 + .../MLI_light_optics/Src/parallel_mod.f90 | 57 + .../MLI_light_optics/Src/parameters.f90 | 10 + OpticsJan2020/MLI_light_optics/Src/proc.f | 3328 +++++++ OpticsJan2020/MLI_light_optics/Src/pure.f | 576 ++ OpticsJan2020/MLI_light_optics/Src/rfgap.f | 809 ++ OpticsJan2020/MLI_light_optics/Src/setbound.f | 229 + .../MLI_light_optics/Src/sfft3d_dummy.f | 13 + .../MLI_light_optics/Src/sfft3d_essl.f | 119 + OpticsJan2020/MLI_light_optics/Src/sif.f | 5735 +++++++++++ OpticsJan2020/MLI_light_optics/Src/spch2d.f | 960 ++ OpticsJan2020/MLI_light_optics/Src/spch3d.f | 1274 +++ .../MLI_light_optics/Src/spch3d_chombo.f | 435 + .../Src/spch3d_chombo_dummy.f | 13 + .../MLI_light_optics/Src/spch3d_dummy.f | 29 + .../MLI_light_optics/Src/spch3d_essl.f | 529 + .../MLI_light_optics/Src/spch3d_mod.f90 | 43 + OpticsJan2020/MLI_light_optics/Src/sss.f | 580 ++ .../MLI_light_optics/Src/timer_mod.f90 | 138 + OpticsJan2020/MLI_light_optics/Src/trac.f | 1674 ++++ OpticsJan2020/MLI_light_optics/Src/user.f | 1667 ++++ OpticsJan2020/MLI_light_optics/Src/user7.f | 51 + OpticsJan2020/MLI_light_optics/Src/usubs.f | 1185 +++ OpticsJan2020/MLI_light_optics/Src/wakefld.f | 1732 ++++ OpticsJan2020/MLI_light_optics/Src/xerbla.f | 43 + OpticsJan2020/MLI_light_optics/Src/xtra.f | 95 + .../MLI_light_optics/Src/xtra_notgnu.f | 95 + 166 files changed, 82449 insertions(+) create mode 100644 OpticsJan2020/MLI_light_optics/00readme create mode 100755 OpticsJan2020/MLI_light_optics/Includes/actpar.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/aimdef.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/amdiip.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/bfield.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/buffer.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/codes.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/combs.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/const.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/copy_of_stubs.inc create mode 100644 OpticsJan2020/MLI_light_optics/Includes/core.inc create mode 100644 OpticsJan2020/MLI_light_optics/Includes/core_old.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/deriv.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/dip.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/dr.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/drl.inc create mode 100644 OpticsJan2020/MLI_light_optics/Includes/ebdata.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/expon.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/extalk.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/files.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/fitbuf.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/fitdat.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/frnt.inc create mode 100644 OpticsJan2020/MLI_light_optics/Includes/gronax.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/hmflag.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/id.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/impli.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/incmif.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/ind.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/ind3.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/infin.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/iprod.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/ja3.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/keyset.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/labpnt.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/len.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/len3.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/lims.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/linbuf.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/loop.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/map.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/maxcat.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/merit.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/minvar.inc create mode 100644 OpticsJan2020/MLI_light_optics/Includes/mliinc.tar create mode 100755 OpticsJan2020/MLI_light_optics/Includes/mpi_stubs.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/mpi_stubs_placeholder.inc create mode 100644 OpticsJan2020/MLI_light_optics/Includes/multipole.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/nlsvar.inc create mode 100644 OpticsJan2020/MLI_light_optics/Includes/nnprint.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/nturn.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/order.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/param.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/parset.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/pbkh.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/pbkh_bck.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/pie.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/pq.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/previous.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/prodex.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/psflag.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/quadp.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/quadpn.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/recmul.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/setref.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/sigbuf.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/sincos.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/sol.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/sr.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/srl.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/stack.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/status.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/stmap.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/supres.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/symp.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/talk.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/taylor.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/time.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/usrdat.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/vblist.inc create mode 100644 OpticsJan2020/MLI_light_optics/Includes/vecpot.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/xvary.inc create mode 100755 OpticsJan2020/MLI_light_optics/Includes/zeroes.inc create mode 100644 OpticsJan2020/MLI_light_optics/Includes/zz.inc create mode 100644 OpticsJan2020/MLI_light_optics/Makedir/makefile create mode 100755 OpticsJan2020/MLI_light_optics/Src/afro.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/afro_mod.f90 create mode 100644 OpticsJan2020/MLI_light_optics/Src/anal.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/base.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/bessjm.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/book.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/boundp3d.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/cfbdang.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/cfqd.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/coil.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/comm.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/cons.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/constants_mod.f90 create mode 100644 OpticsJan2020/MLI_light_optics/Src/curve_fit.f90 create mode 100644 OpticsJan2020/MLI_light_optics/Src/depositrho.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/diagnostics.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/dist.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/dummy.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/dumpin.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/e_gengrad_mod.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/ebcomp.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/elem.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/env.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/euclid.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/fftessl.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/fftpkgq.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/fftw_dummy.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/fparser.f90 create mode 100755 OpticsJan2020/MLI_light_optics/Src/gendip5.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/gengrad_mod.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/genm.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/gensol.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/greenfn_mod.f90 create mode 100755 OpticsJan2020/MLI_light_optics/Src/hamdrift.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/imkmpak.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/inpu.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/integ.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/iron.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/liea.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/liea_mod.f90 create mode 100755 OpticsJan2020/MLI_light_optics/Src/linpak.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/linpak_all.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/linpak_old.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/magnet.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/makeit create mode 100644 OpticsJan2020/MLI_light_optics/Src/math.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/meri.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/mpi.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/mpif.h create mode 100644 OpticsJan2020/MLI_light_optics/Src/multitrack_mod.f90 create mode 100644 OpticsJan2020/MLI_light_optics/Src/myblas.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/mygenrec5.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/myprot5.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/opti.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/optics.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/parallel_mod.f90 create mode 100644 OpticsJan2020/MLI_light_optics/Src/parameters.f90 create mode 100755 OpticsJan2020/MLI_light_optics/Src/proc.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/pure.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/rfgap.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/setbound.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/sfft3d_dummy.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/sfft3d_essl.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/sif.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/spch2d.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/spch3d.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/spch3d_chombo.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/spch3d_chombo_dummy.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/spch3d_dummy.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/spch3d_essl.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/spch3d_mod.f90 create mode 100755 OpticsJan2020/MLI_light_optics/Src/sss.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/timer_mod.f90 create mode 100755 OpticsJan2020/MLI_light_optics/Src/trac.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/user.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/user7.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/usubs.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/wakefld.f create mode 100644 OpticsJan2020/MLI_light_optics/Src/xerbla.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/xtra.f create mode 100755 OpticsJan2020/MLI_light_optics/Src/xtra_notgnu.f diff --git a/OpticsJan2020/MLI_light_optics/00readme b/OpticsJan2020/MLI_light_optics/00readme new file mode 100644 index 0000000..11ee904 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/00readme @@ -0,0 +1 @@ +This was copied from ~/IncludesUSPAS/MLIstuff/MLIwithoptics/ diff --git a/OpticsJan2020/MLI_light_optics/Includes/actpar.inc b/OpticsJan2020/MLI_light_optics/Includes/actpar.inc new file mode 100755 index 0000000..8d32961 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/actpar.inc @@ -0,0 +1,2 @@ +c six active parameters for general use + common/actpar/aapar,bbpar,ccpar,ddpar,eepar,ffpar diff --git a/OpticsJan2020/MLI_light_optics/Includes/aimdef.inc b/OpticsJan2020/MLI_light_optics/Includes/aimdef.inc new file mode 100755 index 0000000..30a40c5 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/aimdef.inc @@ -0,0 +1,8 @@ +c------------------------------------------------------------------- +c aim definitions for inner and outer loops +c + parameter (maxa=100) + common/aimdef/maim,nsq(3),ksq(3),lsq(3,3),kyf(maxa,3), + * nsf(maxa,3),idf(maxa,3),jdf(maxa,3),target(maxa,3),wts(maxa,3) + character*8 qname + common/qlabel/qname(maxa,3) diff --git a/OpticsJan2020/MLI_light_optics/Includes/amdiip.inc b/OpticsJan2020/MLI_light_optics/Includes/amdiip.inc new file mode 100755 index 0000000..022c3ba --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/amdiip.inc @@ -0,0 +1,8 @@ +c-------------------------------------------------------------- +c Adaptive Multidimensional Inverse Interpolation (AMDII) Pool +c C. T. Mottershead LANL AT-3 June 93 +c + parameter (maxv=40, mxvp = maxv + 1) + common/amdiip/ic,maxcut,ncut,npts,level,mdii,errtol,antmin,antol, + * delta,slo,fultgt(maxv),partgt(maxv),err(mxvp),xx(maxv,mxvp), + * ff(maxv,mxvp),ga(maxv*mxvp), xbar(maxv), yy(maxv) diff --git a/OpticsJan2020/MLI_light_optics/Includes/bfield.inc b/OpticsJan2020/MLI_light_optics/Includes/bfield.inc new file mode 100755 index 0000000..a5e4e30 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/bfield.inc @@ -0,0 +1,4 @@ +c Magnetic Field and Derivatives ( Tesla/ meter ) for +c general midplane symmetric Dipole. F. Neri June 3 1989. + double precision b(0:6,0:6) + common/bfield/b diff --git a/OpticsJan2020/MLI_light_optics/Includes/buffer.inc b/OpticsJan2020/MLI_light_optics/Includes/buffer.inc new file mode 100755 index 0000000..624692f --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/buffer.inc @@ -0,0 +1,6 @@ + common/buffer/buf1a(monoms),buf2a(monoms),buf3a(monoms), + # buf4a(monoms),buf5a(monoms), + # buf1m(6,6),buf2m(6,6),buf3m(6,6), + # buf4m(6,6),buf5m(6,6) + dimension bfa(monoms,5),bma(6,6,5) + equivalence (bfa,buf1a), (bma,buf1m) diff --git a/OpticsJan2020/MLI_light_optics/Includes/codes.inc b/OpticsJan2020/MLI_light_optics/Includes/codes.inc new file mode 100755 index 0000000..91600bd --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/codes.inc @@ -0,0 +1,35 @@ +c names of components of the Master Input File +c 9 types of input: +c 1=comments, 2=beam, 3=elements, 4=lines, 5=lumps,6=loops, +c 7=labor, 8=include 9=constants +c 10th component will be added shortly (wakes) +c +c Also, kinds of data in the menu, i.e. 9 kinds of "menu elements" +c 1=simple elements (drift, quadrupole,...) +c 2=user-supplied elements (usr1, usr2,...) +c 3=parameter sets (ps1, ps2,...) +c 4=random elements +c 5=random user-supplied elements +c 6=random parameter sets +c 7=simple commands +c 8=advanced commands +c 9=procedures and fitting & optimization +c +c The following is somewhat wasteful of memory (e.g. 75 simple elements +c but far fewer other kinds of data), but I am leaving as-is for simplicity. +c Eventually, instead of ltc(9,nrpmax), there could be 9 1D arrays. + parameter (nintypes=9) + parameter(nrpmax=75) + common/sharp/ling(nintypes) + character*8 ling +c type-codes of menu elements (note: eventually ltc should be char*16) +cryne Dec 1, 2002 character*8 ltc + character*16 ltc + common/monics/ltc(9,nrpmax) +c nrp=number of "real" (i.e. numeric) parameters +c ncp=number of character*16 parameters +c that are associated with elements and commands in monics + integer nrp,ncp,nrpold + common/nparm/nrp(9,nrpmax),ncp(9,nrpmax),nrpold(9,nrpmax) +cryne 7/28/2002 added nrpold for backward compatability w/ original +c MaryLie input parameters diff --git a/OpticsJan2020/MLI_light_optics/Includes/combs.inc b/OpticsJan2020/MLI_light_optics/Includes/combs.inc new file mode 100755 index 0000000..f6c2340 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/combs.inc @@ -0,0 +1 @@ + common/combs/cmp2,qbyp,ptg diff --git a/OpticsJan2020/MLI_light_optics/Includes/const.inc b/OpticsJan2020/MLI_light_optics/Includes/const.inc new file mode 100755 index 0000000..91e1d08 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/const.inc @@ -0,0 +1,9 @@ +cryne 7/7/2002 +cryne this common block is used to store strings that have constant +cryne values assigned to them. +cryne nconst is equal to the number that have been assigned +cryne This info should really be included in elments.inc, but I am +cryne keeping it separate to avoid changes to the existing MaryLie + parameter (nconmax=1000) + character*16 constr + common/conarray/constr(nconmax),conval(nconmax),nconst diff --git a/OpticsJan2020/MLI_light_optics/Includes/copy_of_stubs.inc b/OpticsJan2020/MLI_light_optics/Includes/copy_of_stubs.inc new file mode 100755 index 0000000..4e8efc2 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/copy_of_stubs.inc @@ -0,0 +1,445 @@ + interface MPI_ALLGATHERV + module procedure MPI_ALLGATHERV1,MPI_ALLGATHERV2 + end interface + interface MPI_ALLTOALLV + module procedure MPI_ALLTOALLV1,MPI_ALLTOALLV2,MPI_ALLTOALLV3 + end interface + interface MPI_ALLGATHER + module procedure MPI_ALLGATHER1,MPI_ALLGATHER2,MPI_ALLGATHER3,& + MPI_ALLGATHER4,MPI_ALLGATHER5,MPI_ALLGATHER6 + end interface + interface MPI_GATHER + module procedure MPI_GATHER1,MPI_GATHER2,MPI_GATHER3,MPI_GATHER4 + end interface + interface MPI_ISEND + module procedure MPI_ISEND1,MPI_ISEND2,MPI_ISEND3,MPI_ISEND4 + end interface + interface MPI_SEND + module procedure MPI_SEND1,MPI_SEND2,MPI_SEND3,MPI_SEND4,& + MPI_SEND5,MPI_SEND6,MPI_SEND7,MPI_SEND8 + end interface + interface MPI_IRECV + module procedure MPI_IRECV1,MPI_IRECV2,MPI_IRECV3,MPI_IRECV4,& + MPI_IRECV5,MPI_IRECV6 + end interface + interface MPI_RECV + module procedure MPI_RECV1,MPI_RECV2,MPI_RECV3,MPI_RECV4, & + & MPI_RECV5 + end interface + interface MPI_REDUCE + module procedure MPI_REDUCE1,MPI_REDUCE2,MPI_REDUCE3,MPI_REDUCE4 + end interface + interface MPI_ALLREDUCE + module procedure MPI_ALLREDUCE1,MPI_ALLREDUCE2,MPI_ALLREDUCE3,MPI_ALLREDUCE4,MPI_ALLREDUCE5,MPI_ALLREDUCE6 + end interface + interface MPI_BCAST + module procedure MPI_BCAST1,MPI_BCAST2,MPI_BCAST3,MPI_BCAST4,& + MPI_BCAST5,MPI_BCAST6 + end interface +! +contains +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! HERE ARE THE MPI STUBS +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + !mpi initialization + subroutine MPI_INIT(ierr) + end subroutine MPI_INIT + + !mpi end + subroutine MPI_Finalize(ierr) + end subroutine MPI_Finalize + + !mpi test for initialization + subroutine MPI_INITIALIZED(flag,ierr) + integer ierr + logical flag + end subroutine MPI_INITIALIZED + + !global sum + subroutine MPI_ALLREDUCE1(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& + MPI_SUM,MPI_COMM_WORLD,ierr) + double precision, dimension(:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_ALLREDUCE1 + + subroutine MPI_ALLREDUCE2(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& + MPI_SUM,MPI_COMM_WORLD,ierr) + double precision :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_ALLREDUCE2 + + subroutine MPI_ALLREDUCE3(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& + MPI_SUM,MPI_COMM_WORLD,ierr) + integer, dimension(:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_ALLREDUCE3 + + subroutine MPI_ALLREDUCE4(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& + MPI_SUM,MPI_COMM_WORLD,ierr) + integer :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_ALLREDUCE4 + + subroutine MPI_ALLREDUCE5(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& + MPI_SUM,MPI_COMM_WORLD,ierr) + double precision, dimension(:,:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_ALLREDUCE5 + + subroutine MPI_ALLREDUCE6(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& + MPI_SUM,MPI_COMM_WORLD,ierr) + double precision, dimension(:,:,:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_ALLREDUCE6 + + !synchronize communication + subroutine MPI_BARRIER(comm2d,ierr) + integer :: comm2d + end subroutine MPI_BARRIER + + !processor ID + subroutine MPI_COMM_RANK(MPI_COMM_WORLD,my_rank,ierr) + my_rank = 0 + end subroutine MPI_COMM_RANK + +!ryne 12/29/2004 !mpi timing +!ryne 12/29/2004 double precision function MPI_WTIME() +!ryne 12/29/2004 MPI_WTIME = 0.0 +!ryne 12/29/2004 end function MPI_WTIME + + !mpi broadcast + subroutine MPI_BCAST1(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) + double precision, dimension(:) :: rffile + integer :: comm2d + end subroutine MPI_BCAST1 + + subroutine MPI_BCAST2(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) + double precision :: rffile + integer :: comm2d + end subroutine MPI_BCAST2 + + subroutine MPI_BCAST3(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) + integer, dimension(:) :: rffile + integer :: comm2d + end subroutine MPI_BCAST3 + + subroutine MPI_BCAST4(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) + integer :: rffile + integer :: comm2d + end subroutine MPI_BCAST4 + + subroutine MPI_BCAST5(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) + double precision, dimension(:,:) :: rffile + integer :: comm2d + end subroutine MPI_BCAST5 + + subroutine MPI_BCAST6(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) + double precision, dimension(:,:,:) :: rffile + integer :: comm2d + end subroutine MPI_BCAST6 + + !total number of processors + subroutine MPI_COMM_SIZE(MPI_COMM_WORLD,np,ierr) + np = 1 + end subroutine MPI_COMM_SIZE + + !sum to local processor + subroutine MPI_REDUCE1(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& + MPI_SUM,num2,MPI_COMM_WORLD,ierr) + double precision, dimension(:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_REDUCE1 + + subroutine MPI_REDUCE2(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& + MPI_SUM,num2,MPI_COMM_WORLD,ierr) + double precision :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_REDUCE2 + + subroutine MPI_REDUCE3(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& + MPI_SUM,num2,MPI_COMM_WORLD,ierr) + integer, dimension(:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_REDUCE3 + + subroutine MPI_REDUCE4(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& + MPI_SUM,num2,MPI_COMM_WORLD,ierr) + integer :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_REDUCE4 + + !mpi send command + subroutine MPI_SEND1(tmplc,num,MPI_DOUBLE_PRECISION,& + num1,num2,MPI_COMM_WORLD,ierr) + double precision, dimension(:) :: tmplc + end subroutine MPI_SEND1 + + subroutine MPI_SEND2(tmplc,num,MPI_DOUBLE_PRECISION,& + num1,num2,MPI_COMM_WORLD,ierr) + double precision :: tmplc + end subroutine MPI_SEND2 + + subroutine MPI_SEND3(tmplc,num,MPI_INTEGER,& + num1,num2,MPI_COMM_WORLD,ierr) + integer, dimension(:) :: tmplc + end subroutine MPI_SEND3 + + subroutine MPI_SEND4(tmplc,num,MPI_INTEGER,& + num1,num2,MPI_COMM_WORLD,ierr) + integer :: tmplc + end subroutine MPI_SEND4 + + subroutine MPI_SEND5(tmplc,num,MPI_DOUBLE_COMPLEX,& + num1,num2,MPI_COMM_WORLD,ierr) + double complex, dimension(:,:) :: tmplc + end subroutine MPI_SEND5 + + subroutine MPI_SEND6(tmplc,num,MPI_DOUBLE_COMPLEX,& + num1,num2,MPI_COMM_WORLD,ierr) + double complex, dimension(:,:,:) :: tmplc + end subroutine MPI_SEND6 + + subroutine MPI_SEND7(tmplc,num,MPI_DOUBLE_COMPLEX,& + num1,num2,MPI_COMM_WORLD,ierr) + double precision, dimension(:,:,:) :: tmplc + end subroutine MPI_SEND7 + + subroutine MPI_SEND8(tmplc,num,MPI_DOUBLE_COMPLEX,& + num1,num2,MPI_COMM_WORLD,ierr) + double precision, dimension(:,:) :: tmplc + end subroutine MPI_SEND8 + + !mpi isend command + subroutine MPI_ISEND1(tmplc,num,MPI_DOUBLE_PRECISION,& + num1,num2,MPI_COMM_WORLD,num3,ierr) + double precision, dimension(:) :: tmplc + end subroutine MPI_ISEND1 + + subroutine MPI_ISEND2(tmplc,num,MPI_DOUBLE_PRECISION,& + num1,num2,MPI_COMM_WORLD,num3,ierr) + double precision :: tmplc + end subroutine MPI_ISEND2 + + subroutine MPI_ISEND3(tmplc,num,MPI_INTEGER,& + num1,num2,MPI_COMM_WORLD,num3,ierr) + integer, dimension(:) :: tmplc + end subroutine MPI_ISEND3 + + subroutine MPI_ISEND4(tmplc,num,MPI_INTEGER,& + num1,num2,MPI_COMM_WORLD,num3,ierr) + integer :: tmplc + end subroutine MPI_ISEND4 + + !mpi wait command + subroutine MPI_WAIT(num3,status,ierr) + integer, dimension(:) :: status + end subroutine MPI_WAIT + + !mpi wait all command + subroutine MPI_WAITALL(num3,req,status,ierr) + integer, dimension(:) :: req + integer, dimension(:,:) :: status + end subroutine MPI_WAITALL + + !mpi recv command + subroutine MPI_RECV1(tmplc,num,MPI_DOUBLE_PRECISION,& + num1,num2,MPI_COMM_WORLD,status,ierr) + double precision :: tmplc + integer, dimension(:) :: status + end subroutine MPI_RECV1 + + subroutine MPI_RECV2(tmplc,num,MPI_INTEGER,& + num1,num2,MPI_COMM_WORLD,status,ierr) + integer :: tmplc + integer, dimension(:) :: status + end subroutine MPI_RECV2 + + subroutine MPI_RECV3(tmplc,num,MPI_DOUBLE_PRECISION,& + num1,num2,MPI_COMM_WORLD,status,ierr) + double precision, dimension(:) :: tmplc + integer, dimension(:) :: status + end subroutine MPI_RECV3 + + subroutine MPI_RECV4(tmplc,num,MPI_DOUBLE_PRECISION,& + num1,num2,MPI_COMM_WORLD,status,ierr) + integer, dimension(:) :: tmplc + integer, dimension(:) :: status + end subroutine MPI_RECV4 + + subroutine MPI_RECV5(tmplc,num,MPI_DOUBLE_PRECISION,& + num1,num2,MPI_COMM_WORLD,status,ierr) + double precision, dimension(:,:) :: tmplc + integer, dimension(:) :: status + end subroutine MPI_RECV5 + + + !mpi irecv command + subroutine MPI_IRECV1(tmplc,num,MPI_DOUBLE_PRECISION,& + num1,num2,MPI_COMM_WORLD,msid,ierr) + double precision :: tmplc + end subroutine MPI_IRECV1 + + subroutine MPI_IRECV2(tmplc,num,MPI_INTEGER,& + num1,num2,MPI_COMM_WORLD,msid,ierr) + integer :: tmplc + end subroutine MPI_IRECV2 + + subroutine MPI_IRECV3(tmplc,num,MPI_DOUBLE_COMPLEX,& + num1,num2,MPI_COMM_WORLD,msid,ierr) + double complex, dimension(:,:) :: tmplc + end subroutine MPI_IRECV3 + + subroutine MPI_IRECV4(tmplc,num,MPI_DOUBLE_COMPLEX,& + num1,num2,MPI_COMM_WORLD,msid,ierr) + double complex, dimension(:,:,:) :: tmplc + end subroutine MPI_IRECV4 + + subroutine MPI_IRECV5(tmplc,num,MPI_DOUBLE_PRECISION,& + num1,num2,MPI_COMM_WORLD,msid,ierr) + double precision, dimension(:,:,:) :: tmplc + end subroutine MPI_IRECV5 + + subroutine MPI_IRECV6(tmplc,num,MPI_INTEGER,& + num1,num2,MPI_COMM_WORLD,msid,ierr) + integer, dimension(:) :: tmplc + end subroutine MPI_IRECV6 + + !mpi gather command + subroutine MPI_GATHER1(tmplc,num,MPI_DOUBLE_PRECISION,& + tmpgl,num1,MPI_DOUBLE_PRECISION2,num2,MPI_COMM_WORLD,ierr) + double precision, dimension(:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_GATHER1 + + subroutine MPI_GATHER2(tmplc,num,MPI_DOUBLE_PRECISION,& + tmpgl,num1,MPI_DOUBLE_PRECISION2,num2,MPI_COMM_WORLD,ierr) + double precision :: tmplc + double precision, dimension(:) :: tmpgl + tmpgl = tmplc + end subroutine MPI_GATHER2 + + subroutine MPI_GATHER3(tmplc,num,MPI_INTEGER,& + tmpgl,num1,MPI_INTEGER2,num2,MPI_COMM_WORLD,ierr) + integer, dimension(:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_GATHER3 + + subroutine MPI_GATHER4(tmplc,num,MPI_INTEGER,& + tmpgl,num1,MPI_INTEGER2,num2,MPI_COMM_WORLD,ierr) + integer :: tmplc + integer, dimension(:) :: tmpgl + tmpgl = tmplc + end subroutine MPI_GATHER4 + + !mpi allgather command + subroutine MPI_ALLGATHER1(tmplc,num,MPI_DOUBLE_PRECISION,& + tmpgl,num1,MPI_DOUBLE_PRECISION2,MPI_COMM_WORLD,ierr) + double precision, dimension(:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_ALLGATHER1 + + subroutine MPI_ALLGATHER2(tmplc,num,MPI_DOUBLE_PRECISION,& + tmpgl,num1,MPI_DOUBLE_PRECISION2,MPI_COMM_WORLD,ierr) + double precision :: tmplc + double precision, dimension(:) :: tmpgl + tmpgl = tmplc + end subroutine MPI_ALLGATHER2 + + subroutine MPI_ALLGATHER3(tmplc,num,MPI_INTEGER,& + tmpgl,num1,MPI_INTEGER2,MPI_COMM_WORLD,ierr) + integer, dimension(:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_ALLGATHER3 + + subroutine MPI_ALLGATHER4(tmplc,num,MPI_INTEGER,& + tmpgl,num1,MPI_INTEGER2,MPI_COMM_WORLD,ierr) + integer :: tmplc + integer, dimension(:) :: tmpgl + tmpgl = tmplc + end subroutine MPI_ALLGATHER4 + + subroutine MPI_ALLGATHER5(tmplc,num,MPI_DOUBLE_PRECISION,& + tmpgl,num1,MPI_DOUBLE_PRECISION2,MPI_COMM_WORLD,ierr) + double precision, dimension(:,:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_ALLGATHER5 + + subroutine MPI_ALLGATHER6(tmplc,num,MPI_INTEGER,& + tmpgl,num1,MPI_INTEGER2,MPI_COMM_WORLD,ierr) + integer, dimension(:,:) :: tmplc,tmpgl + tmpgl = tmplc + end subroutine MPI_ALLGATHER6 + + subroutine MPI_CART_CREATE(comm,num1,dims,period,tt, & + comm_2d,ierr) + integer :: comm,comm_2d + integer, dimension(:) :: dims + logical, dimension(:) :: period + logical :: tt + + comm_2d = 1 + + end subroutine MPI_CART_CREATE + + subroutine MPI_CART_COORDS(comm_2d,myrank,num,local,ierr) + integer :: comm_2d + integer, dimension(:) :: local + + local = 0 + end subroutine MPI_CART_COORDS + + subroutine MPI_CART_SUB(comm_2d,remaindims,col_comm,ierr) + integer :: comm_2d,col_comm + logical, dimension(:) :: remaindims + + col_comm = 1 + end subroutine MPI_CART_SUB + + !mpi alltoallv1 command + subroutine MPI_ALLTOALLV1(sendbuf,sendcount,senddisp,MPI_DOUBLE_COMPLEX,& + recvbuf,recvcount,recvdisp,MPI_DOUBLE_COMPLEX2,comm,ierr) + double complex, dimension(:) :: sendbuf,recvbuf + integer, dimension(:) :: sendcount,recvcount,senddisp,recvdisp + integer :: comm + end subroutine MPI_ALLTOALLV1 + + subroutine MPI_ALLTOALLV2(sendbuf,sendcount,senddisp,MPI_DOUBLE_COMPLEX,& + recvbuf,recvcount,recvdisp,MPI_DOUBLE_COMPLEX2,comm,ierr) + double precision, dimension(:) :: sendbuf,recvbuf + integer, dimension(:) :: sendcount,recvcount,senddisp,recvdisp + integer :: comm + end subroutine MPI_ALLTOALLV2 + + subroutine MPI_ALLTOALLV3(sendbuf,sendcount,senddisp,MPI_DOUBLE_COMPLEX,& + recvbuf,recvcount,recvdisp,MPI_DOUBLE_COMPLEX2,comm,ierr) + integer, dimension(:) :: sendbuf,recvbuf + integer, dimension(:) :: sendcount,recvcount,senddisp,recvdisp + integer :: comm + end subroutine MPI_ALLTOALLV3 + + !mpi allgatherv command + subroutine MPI_ALLGATHERV1(rhoz,innz,MPI_DOUBLE_PRECISION,recvrhoz,& + ztable,zdisp,MPI_DOUBLE_PRECISION2,commrow,ierr) + double precision, dimension(:) :: rhoz,recvrhoz + integer, dimension(:) :: ztable,zdisp + integer :: commrow + + end subroutine MPI_ALLGATHERV1 + + subroutine MPI_ALLGATHERV2(rhoz,innz,MPI_INTEGER,recvrhoz,& + ztable,zdisp,MPI_INTEGER2,commrow,ierr) + integer, dimension(:) :: rhoz,recvrhoz + integer, dimension(:) :: ztable,zdisp + integer :: commrow + + end subroutine MPI_ALLGATHERV2 + + subroutine MPI_GET_COUNT(mpistat,mreal,nraysw,ierr) + integer :: mreal,nraysw,ierr + integer, dimension(:) :: mpistat + write(6,*)'(mpi_get_count) code should not get here' + write(6,*)'when running a serial job!!!!!!!!!!!!!!!' + call myexit + end subroutine MPI_GET_COUNT diff --git a/OpticsJan2020/MLI_light_optics/Includes/core.inc b/OpticsJan2020/MLI_light_optics/Includes/core.inc new file mode 100644 index 0000000..f7b2dcb --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/core.inc @@ -0,0 +1,10 @@ +c maxlum = maximum number of lumps in /core/ + parameter (maxlum=20) +c storage for lumps +c common/core/thl(monoms,maxlum),tmhl(6,6,maxlum), +c # dfl(6,monoms,maxlum),rdfl(3,monom1+1,maxlum), +c # rrjacl(3,3,monom2+1,maxlum),inuse(maxlum) +c storage for lumps + common/core/thl(monoms,maxlum),tmhl(6,6,maxlum), + # dfl(6,monoms,maxlum),rdfl(3,monoms,maxlum), + # rrjacl(3,3,monoms,maxlum),inuse(maxlum) diff --git a/OpticsJan2020/MLI_light_optics/Includes/core_old.inc b/OpticsJan2020/MLI_light_optics/Includes/core_old.inc new file mode 100644 index 0000000..bd5b0be --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/core_old.inc @@ -0,0 +1,6 @@ +c maxlum = maximum number of lumps in /core/ + parameter (maxlum=20) +c storage for lumps + common/core/thl(monoms,maxlum),tmhl(6,6,maxlum), + # dfl(6,monom1,maxlum),rdfl(3,monom1+1,maxlum), + # rrjacl(3,3,monom2+1,maxlum),inuse(maxlum) diff --git a/OpticsJan2020/MLI_light_optics/Includes/deriv.inc b/OpticsJan2020/MLI_light_optics/Includes/deriv.inc new file mode 100755 index 0000000..042a362 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/deriv.inc @@ -0,0 +1,8 @@ +c additional characteristics of the current map: + double precision df,rjac,rdf,rrjac + common/deriv/ df(6,monoms) + common/rjacob/rjac(3,3,monoms) +c common/rderiv/rdf(3,84) +c common/rrjac/ rrjac(3,3,28) + common/rderiv/rdf(3,monoms) + common/rrjac/ rrjac(3,3,monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/dip.inc b/OpticsJan2020/MLI_light_optics/Includes/dip.inc new file mode 100755 index 0000000..e4da8ab --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/dip.inc @@ -0,0 +1,4 @@ +c parameters for gendip + double precision By,za,zb,gap + common/dip/ By,za,zb,gap,s + diff --git a/OpticsJan2020/MLI_light_optics/Includes/dr.inc b/OpticsJan2020/MLI_light_optics/Includes/dr.inc new file mode 100755 index 0000000..464b22d --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/dr.inc @@ -0,0 +1,2 @@ + integer drexp + common /dr/drexp(0:3,monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/drl.inc b/OpticsJan2020/MLI_light_optics/Includes/drl.inc new file mode 100755 index 0000000..34cc4ed --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/drl.inc @@ -0,0 +1,2 @@ + character*7 dln + common /drl/dln(monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/ebdata.inc b/OpticsJan2020/MLI_light_optics/Includes/ebdata.inc new file mode 100644 index 0000000..d0acecf --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/ebdata.inc @@ -0,0 +1,32 @@ +c maxm = maximum multipole order +c maxa = maximum number of points around cylinder axis +c maxz = maximum number of points along cylinder axis +c maxz2 = maximum number of points along cylinder axis, +c after making field "symmetric" +c maxk = maximum number of points along k (wave number) axis +c +c Notes: +c 1. The k axis will comprise nfilonK intervals---and thus a total of +c nfilonK+1 points. Hence, in order to use the subroutine filonarr, +c we must make nfilonK even. +c 2. We ought to make maxm a user-definable parameter; or, rather, have +c a variable 'maxnm' added to the harmonics common block to record +c the maximum harmonic desired by the user. +c +c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! + parameter(maxm=0) + parameter(maxa=601) + parameter(maxz=2001) + parameter(maxz2=2*maxz-1) + parameter(maxk=2001) + parameter(nfilonA=500) + parameter(nfilonK=1000) + parameter(nfilonZ=2001) + common/zv/zvec(maxz) + common/fittA/phin(maxa),aia(maxa),bia(maxa),cia(maxa),maxna + common/fittZ/zn(maxz2),aiz(maxz2),biz(maxz2),ciz(maxz2),maxnz + common/harmonics/frfourier(2,0:maxm,maxz), & + & fphifourier(2,0:maxm,maxz), & + & fzfourier(2,0:maxm,maxz) + common/harmonics2/harm1(2,0:maxm,maxz2),harm2(2,0:maxm,maxz2) + common/edata/Ez0j(0:3,maxz2),Er0j(0:2,maxz2) diff --git a/OpticsJan2020/MLI_light_optics/Includes/expon.inc b/OpticsJan2020/MLI_light_optics/Includes/expon.inc new file mode 100755 index 0000000..e98c006 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/expon.inc @@ -0,0 +1,7 @@ +c expon = table of exponents + integer expon(6,0:monoms) + common/expon/expon + integer nxp135(monoms),nxp246(monoms) +cryne Nov 6, 2003: added nxp13 + integer nxp13(monoms),nxp24(monoms),nxp5(monoms),nxp6(monoms) + common/expsum/nxp135,nxp246,nxp13,nxp24,nxp5,nxp6 diff --git a/OpticsJan2020/MLI_light_optics/Includes/extalk.inc b/OpticsJan2020/MLI_light_optics/Includes/extalk.inc new file mode 100755 index 0000000..e06e84f --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/extalk.inc @@ -0,0 +1 @@ + common/extalk/fa(monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/files.inc b/OpticsJan2020/MLI_light_optics/Includes/files.inc new file mode 100755 index 0000000..59a6de2 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/files.inc @@ -0,0 +1,8 @@ +c files: lf = master input file +c jif = terminal input unit number +c jof = terminal output unit number +c jodf= general output disk file unit number +c ibrief = flag to control output level +c iquiet = flag to suppress output from within procedures + integer lf,icf,jfcf,mpi,mpo,jif,jof,jodf,ibrief,iquiet + common/files/lf,icf,jfcf,mpi,mpo,jif,jof,jodf,ibrief,iquiet diff --git a/OpticsJan2020/MLI_light_optics/Includes/fitbuf.inc b/OpticsJan2020/MLI_light_optics/Includes/fitbuf.inc new file mode 100755 index 0000000..d501219 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/fitbuf.inc @@ -0,0 +1,6 @@ +c------------------------------------------------------------------- +c aim, fit and optimization parameters +c + parameter (maxf=100) + common/fitbuf/iter,ier,nfit,kfit,errtol,reach,fval,auxtol, + * aims(maxf),fvzero(maxf),partgt(maxf) diff --git a/OpticsJan2020/MLI_light_optics/Includes/fitdat.inc b/OpticsJan2020/MLI_light_optics/Includes/fitdat.inc new file mode 100755 index 0000000..d4ee88f --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/fitdat.inc @@ -0,0 +1,12 @@ + common/fitdat/dz(4),tux,tuy,tus,cx,cy,qx,qy,hh,vv,tt,hv,ht,vt, + *ax,bx,gx,ay,by,gy,at,bt,gt,ex,ey,et,wex,wey,wet,fx,xb,xa,xu,xd, +c *fy,yb,ya,yu,yd,ft,tb,ta,tu,td +c AJD 6/5/93 + *fy,yb,ya,yu,yd,fte,teb,tea,teu,ted + dimension fitval(47) + equivalence (fitval,dz) +c Note: The quantities ft,ta,tb,tu,td have been changed to fte,tea,teb,teu,ted +c in order to avoid name conflicts with with various "ta" arrays in various +c analysis routines. However, these quantities are still referenced by the keys +c 'ft','tb','ta','tu','td' defined in the include file keyset.inc - AJD +c 6/5/93. diff --git a/OpticsJan2020/MLI_light_optics/Includes/frnt.inc b/OpticsJan2020/MLI_light_optics/Includes/frnt.inc new file mode 100755 index 0000000..8a1984a --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/frnt.inc @@ -0,0 +1,3 @@ +c table of parameters for cfbd fringe fields + common/frnt/ cfbgap, cfblk1, cfbtk1 + diff --git a/OpticsJan2020/MLI_light_optics/Includes/gronax.inc b/OpticsJan2020/MLI_light_optics/Includes/gronax.inc new file mode 100644 index 0000000..bd9b852 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/gronax.inc @@ -0,0 +1,4 @@ +c gradients on axis ( for combined function everything ) +c gn : normal gradients ( sin(mTh) ) gs: skew gradients ( cos(mTh) ) + double precision gn(0:10,0:10), gs(0:10,0:10) + common/gronax/gn,gs diff --git a/OpticsJan2020/MLI_light_optics/Includes/hmflag.inc b/OpticsJan2020/MLI_light_optics/Includes/hmflag.inc new file mode 100755 index 0000000..90d3775 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/hmflag.inc @@ -0,0 +1 @@ + common/hmflag/iflag diff --git a/OpticsJan2020/MLI_light_optics/Includes/id.inc b/OpticsJan2020/MLI_light_optics/Includes/id.inc new file mode 100755 index 0000000..688277e --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/id.inc @@ -0,0 +1,3 @@ +c ident = identity + double precision ident(6,6) + common /id/ident diff --git a/OpticsJan2020/MLI_light_optics/Includes/impli.inc b/OpticsJan2020/MLI_light_optics/Includes/impli.inc new file mode 100755 index 0000000..5d03e89 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/impli.inc @@ -0,0 +1 @@ + implicit double precision (a-h,o-z) diff --git a/OpticsJan2020/MLI_light_optics/Includes/incmif.inc b/OpticsJan2020/MLI_light_optics/Includes/incmif.inc new file mode 100755 index 0000000..7fb1823 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/incmif.inc @@ -0,0 +1,12 @@ +c storage for #include function in main Marylie input file +c na1 = real menu count before the includes +c na2 = real menu count after the includes +c nb1 = real item count before the includes +c nb2 = real item count after the includes +c noble1 = real task count before the includes +c noble2 = real task count after the includes +c ninc = number of include files used +c MIF fragment include file names for #include + character*80 incfil + common/mifrag/incfil(32) + common/mainum/ninc,na1,na2,nb1,nb2,noble1,noble2 diff --git a/OpticsJan2020/MLI_light_optics/Includes/ind.inc b/OpticsJan2020/MLI_light_optics/Includes/ind.inc new file mode 100755 index 0000000..daf9cda --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/ind.inc @@ -0,0 +1 @@ + common /ind/ imaxi,jv(monoms),index1(monoms),index2(monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/ind3.inc b/OpticsJan2020/MLI_light_optics/Includes/ind3.inc new file mode 100755 index 0000000..22436b8 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/ind3.inc @@ -0,0 +1 @@ + common /ind3/ jv3(84),ind31(84),ind32(84) diff --git a/OpticsJan2020/MLI_light_optics/Includes/infin.inc b/OpticsJan2020/MLI_light_optics/Includes/infin.inc new file mode 100755 index 0000000..6131696 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/infin.inc @@ -0,0 +1,2 @@ +c common block for storing various infinities + common/infin/xinf,yinf,tinf,ginf diff --git a/OpticsJan2020/MLI_light_optics/Includes/iprod.inc b/OpticsJan2020/MLI_light_optics/Includes/iprod.inc new file mode 100755 index 0000000..3ed0bde --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/iprod.inc @@ -0,0 +1,3 @@ +c Table of products + integer iprod(0:monom1,0:monom1) + common/iprod/iprod diff --git a/OpticsJan2020/MLI_light_optics/Includes/ja3.inc b/OpticsJan2020/MLI_light_optics/Includes/ja3.inc new file mode 100755 index 0000000..b3a4a0b --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/ja3.inc @@ -0,0 +1 @@ + common /ja3/ ja3(3,84) diff --git a/OpticsJan2020/MLI_light_optics/Includes/keyset.inc b/OpticsJan2020/MLI_light_optics/Includes/keyset.inc new file mode 100755 index 0000000..91ccbe8 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/keyset.inc @@ -0,0 +1,7 @@ +c +c keyword data for aimset +c + parameter (nkeys=57,maxjlen=13) + common/keys/key(nkeys) + character*2 key + common/kasks/kask(nkeys),maxj(maxjlen) diff --git a/OpticsJan2020/MLI_light_optics/Includes/labpnt.inc b/OpticsJan2020/MLI_light_optics/Includes/labpnt.inc new file mode 100755 index 0000000..5460272 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/labpnt.inc @@ -0,0 +1,5 @@ +c labor pointers +c lp is the running index, pointing to the element in latt (labor) +c which is currently being treated +c /labpnt/ is also used in "procedures" to set up do loops in #labor + common/labpnt/lp,jbipnt,jbopnt,jicnt,jocnt,nitms,notms diff --git a/OpticsJan2020/MLI_light_optics/Includes/len.inc b/OpticsJan2020/MLI_light_optics/Includes/len.inc new file mode 100755 index 0000000..d371f24 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/len.inc @@ -0,0 +1 @@ + common /len/ len(16) diff --git a/OpticsJan2020/MLI_light_optics/Includes/len3.inc b/OpticsJan2020/MLI_light_optics/Includes/len3.inc new file mode 100755 index 0000000..36e5b66 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/len3.inc @@ -0,0 +1 @@ + common /len3/ len3(16) diff --git a/OpticsJan2020/MLI_light_optics/Includes/lims.inc b/OpticsJan2020/MLI_light_optics/Includes/lims.inc new file mode 100755 index 0000000..6eb2415 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/lims.inc @@ -0,0 +1,3 @@ +c bottom, top = lowest and highest monomial number for each order + integer bottom(0:12),top(0:12) + common/lims/bottom,top diff --git a/OpticsJan2020/MLI_light_optics/Includes/linbuf.inc b/OpticsJan2020/MLI_light_optics/Includes/linbuf.inc new file mode 100755 index 0000000..57ee727 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/linbuf.inc @@ -0,0 +1,7 @@ + parameter (maxel=400) + common/linbuf/nbgn,nend,npsu,npst,mltyp1(maxel),mltyp2(maxel) + * ,lintyp(maxel),elong(maxel),strong(maxel),pssext(maxel) + * ,psoctu(maxel),radius(maxel),aap(maxel),bbp(maxel),ccp(maxel) + * ,ddp(maxel),eep(maxel),ffp(maxel) + character*8 cname + common/liname/cname(maxel) diff --git a/OpticsJan2020/MLI_light_optics/Includes/loop.inc b/OpticsJan2020/MLI_light_optics/Includes/loop.inc new file mode 100755 index 0000000..3adf841 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/loop.inc @@ -0,0 +1,5 @@ +c mim(i) points to entities (lumps, elements, user routines, etc.) in a loop +c joy is the number of things in mim +c nloop is the index of the actual loop in /items/ + parameter (joymax=1000) + common/loop/mim(joymax),joy,nloop diff --git a/OpticsJan2020/MLI_light_optics/Includes/map.inc b/OpticsJan2020/MLI_light_optics/Includes/map.inc new file mode 100755 index 0000000..5872a1e --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/map.inc @@ -0,0 +1,3 @@ +c total transfer map + real*8 th ,tmh ,reftraj , arclen + common/map/th(monoms),tmh(6,6),reftraj(6), arclen diff --git a/OpticsJan2020/MLI_light_optics/Includes/maxcat.inc b/OpticsJan2020/MLI_light_optics/Includes/maxcat.inc new file mode 100755 index 0000000..70d3ce1 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/maxcat.inc @@ -0,0 +1,5 @@ +c ordlib, toplib, ordcat, topcat +c = highest order & last monomial of library and concatenation + integer ordlib,toplib,ordcat,topcat + common/maxcat/ordcat,topcat + common/maxlib/ordlib,toplib diff --git a/OpticsJan2020/MLI_light_optics/Includes/merit.inc b/OpticsJan2020/MLI_light_optics/Includes/merit.inc new file mode 100755 index 0000000..f48fe5e --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/merit.inc @@ -0,0 +1,2 @@ +c block common for storing value of merit function + common/merit/val(0:5) diff --git a/OpticsJan2020/MLI_light_optics/Includes/minvar.inc b/OpticsJan2020/MLI_light_optics/Includes/minvar.inc new file mode 100755 index 0000000..d9c6ac0 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/minvar.inc @@ -0,0 +1,5 @@ + parameter ( maxdat = 1000) + parameter (maxv = 10, maxq = (maxv+1)*(maxv+2)/2 ) + common /minvar/ jtyp, modu, ntot, nomin, minpt, maxpt, fmin, fmax, + * regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), fdat(maxdat) + save /minvar/ diff --git a/OpticsJan2020/MLI_light_optics/Includes/mliinc.tar b/OpticsJan2020/MLI_light_optics/Includes/mliinc.tar new file mode 100644 index 0000000000000000000000000000000000000000..101504ab801fb9e11b920745b77191b016b34837 GIT binary patch literal 112640 zcmeHQTXWkuvd*)A1(L0rk+X;?Qnw_h{NR~nce6XmY-K!WPwh*Jq9~a*MJgm^OZxTa zYXAf@du0OIX9HzA@>xgie z{KVdZ*-ql!x(x7OPu;|gVm1yVHgN+tvVAs>-4mJC38&LAFpwNc4co>y9}el;ap-$A zqHouw@9`MlCw26sspBCdV0+V%JAPXH?^&P)CH!yq8~lIBeBL*Y^Xl=Rlaz=Mc>q8$ zK$I7Fi5CWvgm?i+2(yC`3+JFK%n!p^eBvl_0sL=6Ryxa2d#ejntct> z&@^5W!LPnObbUj-(K+us2~U{bo{l_k_O$rl?_kX@;eV&y;C~%p@ksm^sDClCXM%J1 zIQJ88KJjd1Y`1e%4uO*DbEE@dENM>$Q|glPAZ$2JE9X5FKeeeI z1XV)!>l}p6cLT>|Eu^L1nl@J87LtmG>FFPu@HpYfjjLV$A|Fa)5a_uGl=zOVc-UdcuKBZa0W4L*FOZac>?ahcd_ojVaakPGk6sL z7IEe|i3BMpXV&@9wWpkQ&RySCaouy@3tYVHo%{3YEav@lAp+pYJ2=M9h&hU~X`z_|Ev7Udm_22_Yu{3JcKix8l5koS=s8}pJVRmc zZvlgI+xM54V?YpXB+&{#aawP95Y4c=LUB}wi+<0+>;jP9F!LR=qsU&yDRY{QVJq+g z0q^H;(j`N`Y{?SO2YNN3v4mhehRA4U0OTh+dz#tFNs}l68coH&5@cA8SPl?bD+m+! zEyE5~^^5vKK(E?P#l1B9r+|7ozhLiNKrV0)CoO7W&)1iv61S`sW}iw_i=k>hy5Kpn zQ5ZF}6TLkT=F=ff)0n-8T-$%aS^||24L097%^e+31}C4PP^TV40!I2I1UWXQ#g609 z@$3YUdFKJ~H7*f6rm#xbEL*8sj!AMSXc*dvojv|Y*f1(~D?p`F18;J$fVBB1kt>T( zgE}y**M=BUNpoc30{n)yb8}}$qGdAx>(KK7itNr{VdPCbh(OT4k9M^D#dFbUBBQyk z*FoR+)qx=$KJohBZgg9p$|u6OwQVU@)BN%;H~%%Nd^~lRq@`dz2CU zz6%kY*3s;~`ZMH_%QXPSQ(Q zOnM4nIH(EsZRlY!zp{e~+OFE<`-gfz`%Y zfY})|^1oWp|CwC>8Sn)={jm)(*vEf=_;T^fFMq$d{Kxyx|Epk@l1;#dwXeInc9~DtE+0Gm zhg?bN80+7{Ky}lG%dEZPV_%nZNIwqigiIxSAj7ixGTadjkm2sVYX9)t`%mw5jx8f7 z63MznP*yF1vStyyU&V*iOKD`a6q2=4NLEUr?*2)mWO9Ni)E6T~p@9y)*8M+ZzCL_@ z|MOmm7m3t}QF=9E6jUQd!2?<^3X;ti!TZ71Ax)(;vZWM~4W*E5CxyD4us~tQ4;mx# z0m2SS+Pl|Ket!S%_n+VEEL)&Yrb?SgInqW_IBh0{?+1aPT!%G4CzNf_kFpv1QMN=s zY8oLc(KJFn-ftd%`uXCw%YEY{63HftplqH9%BG265$0&#M6_(42=-}Wb!A1Aczyy- zC$S-@J9&Qc{3xH3=XpTN!dS`PvkUxTO{3+8{dW2LPrn_lQr*Gl)0u~*4ytdqpGr&9 zR>bpR1obxv!o`C3;nRo9mIsZIR5ZvK4bO&DC&l8CN=KAZ|BWP0-pbuyZkn=GcH+hm z$3m`pcppAo{PN+y@87k?zCGc^{-jbliq%c_!-?mB;ivREa!b!u*||ne{BVfO@qDWD z=Efl9Bovmn5=ihJj_--jv9l0F`rWU;|MbiIFaHLG`S9C^Uq9_8`fBnBw14~kqbT6# zUq62Q@}FNn|MITXUB=2v4V-CZsMgz4_Vz8ywMcgW(obq3l$XR?9lv2vG(j-4G1=OG z>&g3n%pO|@^te-dj}?elH_@E~y4`)MZXa`gy9ac%S9?cyVl+Q4PWKKNf&RBP0!JQ$ zel`Zr<7MDnML3LFk#K1`o#R+aDv)XtnWKGz`?&c0`NR9qElO>T*2r_Z9)S+a6uO)Z zr1mFSR<1qba1_T=I1tZvIi(he#o_bCr+>AmJ-MY~y8MD;-J7*Gsdy0o_O90Ga!*d4 z3;CI88P*$;*>zL?Lhv4RN{ds)ZE4Ej%*OKomwuprN6r1u<%f^&Tc=xdLsc+MMeRLn zZ%s+#xn6W`EQwD7J7kX>oEGbjmj+XCkY+0ykD+=%3%F!RKYY4;|M&NwDZ+xVY~xgy zJGxGwWvRMqDFLA~#KWM2nCQ)mumD7QZ5^fM)Se@>b@TG6+uC_hTeq%$M`-Zog-UeB$6gI zw-OciXf0Ue(;R!#=m_%*vuH|9;C=sM-L7j^&F~{ zX+Mp6y01^$tYmapwEq3e`~N#gLU-`sEB*?23hmxSVPBBn%kG;|(Idlud_bMBZq_59(nY-xxe?5 zhi}C;yy&d)&^xy@hjm&uea8|c5>&ee9n`mjNTO`)zTQ-_7H#ar!xtpclU*F2NKna| zw5unF&q8ix5}0&nLnUkn6GzO}e=cxzC#uIKm1G{T0sPkSl<9Y2Hdl_;-3*TcGjwv>8;%f7d}dZ9MM&>^UlNNpLHGMQQjqRoSH z;E<3?0|W_rgv*N&y)P56qp+V_x~qV+f?n?6v8j_~y7r(GS)kwM?a!9pmM6CW)*IHK zM^E)GqDZ4qrirzT!dAjmJb8X}=W|qb6PRz|_m9MbJOlzZGL(-V2HGTOe3y*cK_pOW zd{s&Vr?IzwKvqVQb=t5&I3OFF>u7n#MS@Bw+s008rEA;TzJpwerf;EFN7?sm?17qw z$81q$!}m?f78>+KJ==(b+a_%Xg%N$Pmc;Cuw#V*SW%Ktu0woOz{ zs30id#1?macd*!k3sgGFkEVe_wJJM1F0ZoIF-53S(@Ycmd+2qk-e&A_nTE;)Wg=Sc z&3;K)CBw14OdNQsH1QukSi4SFgkEkBgN*_KIC8ghylWW{e!lp8`Q_)& z?=LRj3w2Y;VnW?N<}=tr2}eAEt)M-}#>51FSyNP1kWD~O351FxQfcJg3i(vKPNnWy z6oyC0xn%Ro=>&=;83|BL6Ut9I?FJq{Hx60m++c}G6l3-4ubwvQcnA5--Y1zcMR@wq%tGy=%a*Ln0!j@2YvKu1x5*15~oE zWG$mO(XzCOxmhaBrGA4fISx=uXRA@|w^qXlzI!al(b>g7X;0{4yB-8zT+U`9P zpL~<|99Is4re z%-uxu0A>ea<`A}NBHScq*Ws{qJvyHqI_5r`E@7r7yGgSF@boAZEXg=9=2NlxCt?4! zzr+92z*@8a4wEsB{nt7yz&PYF0Y+KDOd{Y-5du%Hj64cst+)%$V52B<4F$3}!$&gj zxdp37FiQ!;Q1*n(g2KZKnR!*V9f{PyDyAqRx$>1^X>!DXRHxXTB94qQrx7w+!Kn0T zOi54*EK=)q5yf_7toc_{$8X3VMc1}NiB)ndm)r|r*^1mPP-`}JL+bb5yBi|g{koBL zPL6dUcexW;;$j!>1vWG*UtlYLBNAGmIEodz&4dot(pSN45ZS_cxv`WC7{gV z(4e1enHC1!37gYIvKZ8XG_Sj~TIb(VW`l{^MH$xXawYlvlA9=}D3_6@s$(vmqK;A3 z&fgBee-n#+5&zA;)%bs`1st55L2|*l!>towLSgTkMI-jplCNyO8uE#)6Qwxr&5Xi( z9-kEUnzeMOspMWGFsj)16E$Yv`VX_OW&H0p>;Ju`@xh730xGPtlI@dGBEMqp{}B8y`+qZ={eMkhBJp1{{x1h?~*C2mQb5ln(?vR`;RZ9Yd{EvA2w$+D)eDDKizdwM_clojU{XXo!x6J_@L0T4Q zfoWMV3D4Sf48R-*MiFDr$g0||`fSI6cU0TimF7EqC**%qmJ|O^$%!+$H-ir&?3b~} zhHTu1p8>KF2Vf?KYbJl`=Bo~z-v z;zqoa&gsB7%_0w8uLIbv3xj_N?ka*yhxpa2SLDVjxte3lU?7SNSA}EMbd~zACX=HI z4|V?_zm(+4Oil%vl)_nsaFmfdF&4GJl|(uQcW`qDsHXmBZ6Ft7PQC#SlJ!{|D7`1|JzXxa5r7a;PTT?AFEsB_;k5Wdze7 zm0LdLIpYc*w}dk>CBRY6MDP~p*MKfn3_1Qlc5(QWW?^tk=|%7xGF*!OQrpn}6Y^KS zc=i0%D-!{P@Ue8LqeERC>giBlhX${nt0hjKWzhl9^jv%ID8$?6{kC=}UU;*@(bu+D z*17c(g|1$0&U&*Ys|16KbNIqcWm8#|3PuW!M#^vhTPRrV%~!X^>eh9rm#ef`^@^PQ zT^O?~4+}gH{gm4tT&9Z9P>0}>O~v6&U>6t!gG%_Xu@d=L78S4(6(Kmxf=(8sGFHVh z(s_@KaWoF+5j5#q7TiH2>6A|PR&d<6<+Ih8{1~0OS6SOjT5T?8OCKzQx?>hQfYG2> zs~lS_!=>fec)x02%l#I5j*Rak@ob5au#UO?!p1HPs$Kr~?*F@;KKB2Ep4A_i0}HYM ztp8>s|Eq0DpZnHAt{Fd0tQ37Oh4vAQ%i4}O71%X zWLo>F{lE4*J?#HG9XNmMTOE=Q!2f%r|8w7|d{BA^`(r@BTjr0&mRmS{m!690h1#Kk zN?d!C0Q+hfn8&tNCV@%*MD31qDZxVIQo`pA`90o}bTmGPPHf;tv=x>qq3wMmTD3Wk zH^kk>Fn`QFXUwn1_=1`*{z8sn;nyMkLGeL0jms*F%#j#n!?3;fx$otfbctEvSHOP$7qo zVk9salU!q6Isy1JpkE)+9S;r(NWyRE3r?ky(8skh+qvRnh}XD1Ur>xJ`z5s`7R8?8 z^~#Mx^?*u~Ng^Nq1RVZuu)s({;_#&SZ^GT{I{r8E|J@UJq_=XF%tV0z24l2pb)lC( zU*KF_S6BS@mTos+-SVr1-zF)-*$X~g@X3PPOFmrk$&%wH&M@H< z;Oc_AOYSE84xu{)?+_j@_+rQxHeby7Vw6g+Uyhf2Ipj;5FXwzY;^TxTL!Q`Z2Tw)} zwC3WU?^xgH8E;@>k3Q=;T%Ned<06xbTyA=IT6<$70!2QSyMvV6zzem97!tU%mVC=c z5S2<<|63vChokBsfvzN6LsP3zIw}#Z%3M`T-_elqhe$*1pf*rjWILRKFkiZx4j^SG zCT8q=4h~a@6_H;gTn}+n@FKBa;EaWCGg0<58f~+|iY;S!!&aUJV>&bl@4x{;P!F*> z4hwRPwuRqr54VLPcZ@qo=&P2m-?&RUviWhG{K$VyhV*6A*POmaKSCUjV*w;b{Uoke zezql>MtNO9L)a^t9h4*I=j=~UUXO&O)fF?2f{LmCe*F)#W0vWE8&|>_{;#@e*Cjid z*jF=SAaA(B<&1}L;uYZt6<50G3^f%8r`p&AItC?!Dk!I4|Hc%*$qhVX=^C2Aw>$z9 zIM}ln)$@P5?tgV~*keLS+!^$76$E!dO{>$f8vL&VZX7m=?2$*OJq&IDNppj>B>sof zp;+>@BR^s*mLw;cFmd%_60o-{2%{-vH(4ny7SmDk<<%)WWo!b`Qhejy6%sfhHfAD$ z+6S&(Cz%8|{xsV-YBJk6`JKeMN0mqMtP+5YNx&y@Lv-#9GFMX)qg9XpgB|z3+d%fR z{HMA9eebD!P=><(PXdGC3E$igDz3@&osEE3>CJCB82iqDO%uAH1^KT@S3(>9zXn*s zIf*x-%bn-)*Grb$)?|^6EH$Ju6S)F2!yDm0%4n9~8Yb+>Rd{fN=2g4=@74cm_tw^b zD2O-sf8?p&Se#t{1r#_qv{_@sTlT9f9=?JkbYu1=@;e^^2y&<1)1LpD?Jntm_PQ_x zF~EPZ|F?P#{?`FoLQf)Zx#=%jv_B7=#Dh!#B7d@U%0Ai=E_jgapY%C0?U2AW!99@0 zH8ypFImCmoe8z?@goyI4f+|tjg9>cA+)++0uWaOw7Shy1T{zBwr+W(@>cVr$w-z4a z>Vhsmv7vXeukn;aSCPxHwF-0|-OcW>=;0-`8@h6#Zb5wf@Ha?X?Foi3DITxT`H&RJ zrgM`@K%h@tpgjS>y{s?~wwcwxIovr3Avc+WA3_=AswA%2JW z6+5m3{?jh=f3W}2$bV~rhde>RPA(W3%!4Y9$FFa-UOipv zTbRX1D}8KeLoM@ERVA3)PSpfppZurYFYEuAgGT;a)r=R*UBmy5!LDyREm+rr{pL}} z)FF#P4Yn7D@4J8UpiueL_y0_6_DcId6C|OL|JDFqj?(5(SF=g+gLZ>-#+&My2@nx# zZ^i9{h&LAa;Y<2T=xc(nhDg*faYw4c!~1nL*!&aatX{?$eelp2OeWr*(v{dbP|xApScuAKeffBu8} ze?|N^dyW2AJ#bRw{{anP|Lu-4uUk(Onp&Q41Tx+I>Kd_c{kOVw|F;YCAFu*Kwm_i& ziDRIK|F3RJbjh%A3!4(6B`*`5))pLBK3O*UQA3kYD&djqmWbB*gV=VqsLsz3=0 ze6>VU{ZgM*SX5ncCvk(57v#aW$|Ops8+uelBXrQSb^L&D4`)^10NIEC9WeXF^&j>> zn*IOrCwoJQ4g&;W(=Tk!xe=YZ`ZES4a5{=j9Z`t`04~#zWI&mBbA4BxR-%w3VJ%S< zsfOQOdCnD;qFe{~OPmLboH+NT`*;pBB;?_^0k-h`SXj0b*UMgHm+)UuO&~;UK7(co z{A7kRaRcrzqM{-VQN{T)em(R6()bC*kLS=sNZ+tl0RKU7!v#O78^+?#7zO%TwfO%4 z{=e-1%k1MyShN1u0FXugAJAYhe6>s{dDc*SQ^iw{04BR~0l>cXzrDWyA2jy=>Vb?k z{D%O5V4|S_^^E^h*WzQRS2Y8$5C5%pS^j6W;S#V}|7!pa?EZ&gl7ukYlY}#9D*7-V z0prnRz30lCz=Q-0Nt3lt@VkwJ1`CO1wIN&QR4N zNyBN>FwtA8fW`JFxBt~^uj_xqBv6C@TjuPT(Gq#J=?7tl%k|G;l1)qQq%N@p6eAeo zrgZ=xVLX5pUHXEzZ9iGgpdV;2T>n%)K|N4BNxXl_II<&An#Lsy{^>&u>wVeNERJE5 zww!$yhfXq2bI^_Txv=d;7238gcR18R$4P^_4Wm&S#a&ki$Ky1Z5-BaJe9atEzE0!y zKp@T#Z_;KSb4Kbdi)1QKz5bK1za;;oEkT3-HGl$qVR+M)cdDFDkiZQW5Tuc-mhj@u znUeFxTzH7kwx;kRan4TZeuyn(bCBv?hfAU;N`9E#dJtA4gzOI0AzeUlr_%}fB3T|M zp(AcI%)x7j1SpzJ|AAXjIG7_;s0uWu;0i(MB2ZR?x+RmGLi)GlqQ-{PD1#Jyx>k+; zd*y$`|C{Yzr)zd$0Y>@xIkpR+wR{Vf-zr1_^ zD>zDsa8Fdo4`9<01-OAQ|Eq{YDke~sV)svVsw(kBHOl(bVlDyH*qs7pPzowame?%x z2SUcwjl8N2K<<!$e%ou#3?DZcPmmkl9B|L0+AY97{NH5%A1Z;({=WuzkZWyjTTPxAp$CYQ02t%f zLcm-CyuTH1IVJsyAW6Y)|7xDTlmYA1uwWoEzlt+##|h4$Tns57GUBEIX92bz_{P~n zfGC)iz!Qq1pRtG=<0-W+4vP_!&>z7Mr8|LD3J$#>7f*6~N@=`N{LY;S7+Zb#Ti{CxfsI8*B3e>U+U{Lk5c?z9{I-+JI+ZT-j6>4csiO9ntJ$nljubMf5QtNNOmIGgg&+AH#s zWX~_gsKs|JvFWsvUhSHey>_ z?f8o9;6o7_UeIK?z~vZJOl*kKFaok{IS`zQj;ij#ptWcC{W?1hEHv(B@B5Z8-mJ?7!9m15*D3x*X^7HU~*?#odnd(ua~4r1BI2FR4;jQI;TH zks5{@H8i4@$vZ+N;$W{r*)KJ5-}>L_uC4!OWB=s{lY2lB(Ep~}T_oXWcY2Ng-$#x4p_zgI(73?)XdbsSL;`H2 z_8_xJl8zzEIdCh#ePD(JCWGN6biHM&2LBG7iYG}o8{S-1y!`K7|4IH=-2a<{M*p)O zaL6ODLBN2o^wI{$74C+UuV)^fsur5^FGJ_1N*b_t{co?`|L8*{q>=yC02KT1pMxCq z)qWqIKgFY1+y!gikcS$ksM0ECo?9jAi?;8>|8}oz{~h+<8vei1c~1)`{|`Z&*n#Hr z)x9eKhB5Q_%rjrNIrj21uVDq!LHh&!&c0TT{s-{?W%<9^1541X|24o_e*MP={wrKK zq|$xveNBT6>enz8Pg2D!a&NtGUghoum-pi+Tec;5aBQ_*MlAA7-p6{ zGSHmejz|F{wE}bE{OjYt-?EF*2&rHLg5I;1PK6lUo(LRx{)KS}*MTpoTfHcEISHLL>uAoR6z>X$!vhw~)z9qYmF)X>`P8j)zBi~V_qdi$1 z;%WK+cE5c72mEjD{~dRtx0F`Ee+dl6I9>!1$9H_g z$8em6aOfZ$`xgE>4XSS$%kME73Z9U>J}v%Rxa_;O{x|afTEI!-zuw`urVD^WS+kdf z^SCf?(=XkIm#Ih{2nL+9h*Lg<$R5w~{i!JX2Pq!-flusd_KKd&+~d$q?Ci0jFtyA* zRT6uXC-?u->8`K;jsKT=K%j*G!j|JKIfvqJfisX`Vgzu}44*Ga%oht7ZM5lYMqkS% zJ<`{VzE&%Gq%T>_OE#kil+tc>dH0k;V;LGDn1w7ET&=_%16XiO^Dh=@jIBd69a=8+ zTOFFEp@y35041E|IANuy|NHO%S?#j^56=G@`TvetJKn2J_`kxvxylyGrgcD^um~dELo!>3+x8y6EFmMHqK%g!HDdsu?OA!&L0Y_ja#i+nZgQCZq(fgGY zhZS%B(VTtqKRW-1{!g!C^-cUkdg%W)=l}Pc$Oon_=>G`o?;%ugLN7hlTeBhf_AMK( z+T8JZ;`5QG*o4$P0N#4xEGbzToWj4mZxr%znXEzl2hQ8Evc**!|3E|c;Xlkim-heA z|83-d$C~1u<;e9vMc+7b7peQF)OcSU86p}E9xQoN9~wP7%WPhLKO+!FPrv@J%m2-O zWB;Qb7*e}@ZP2&RV!!CfjRF0A1F_9zfO@8+)>?4&tJ=%I=*^z>pIkqb)_=?FH}=13 zfdkn85Fh~cU+mw#>3qsY?hO7Oq53OcCwU&7BUNolZYsu z44Wff{GcqjWm9RCH(8|dgj>l}?-+?*peXvIkNAbrK`+6*gb1<+WSEu;Rjy)VKNPCU zC=ZFQ%cZI!MS=Lj|5C9570|jlMRQ9f-k>bmv#izRU6v9fb>z-m@|6q67h~jv;xsz3 zF%K0YYan+Qo0G|YYqpCJ6Q&p;Z=qgubdHPub99i)Cd-*P<)TUILCsgb7=tliG@z73 z6MeHU6EtjHEjafrRRXw3s=fWSm;SfA*82UA#{Nq^P~s4M0|W?%oo*C?hS7z9n8>s1 zO}c$@17wRhq5VBvGK!YTy-6Q_E^s3xa-m1ShD4+3Ej)vZS7Q&Zyy!hdLT7k)fjcA0 zr(hdi1>td+x$qpc6yCw9qVPthx3h$%Oo-gc73|WZU>BamP>S#-F4}@NQ+@1?{Pv8) zIVzOSg~G9PDLxN8@?+|F?VA7o3XZ zFbn}eMm#pt?IDlHRxaGpVVUnQlFd=y@wlts$K#$3Z%jKir3dkNYNdgW3~Wx`O;hzm zK(%}1p+~}5Sv^Poe9|`v|L)?$@~oQX_7&wvZS-Gm)-^ggl;Vvy;Vv z02k!A62Y@+<8 z!;rvWV6l8`u}%K(WCY^nwCd|$`{X}h4|-+!Pa7s-oAtj27{dMU>nTJTSeqhm!Tzb3 z#1Bri}V7(V_Z)gYEi>PRa8Y{`<2>$q-O8q|4q|c!~b@p|5ee97mJ0w^v;Ht z7i_+13y*#CS>T?viPd+(`^FJ`RE`!b^UK#32)Z_8eqtQTnwMzutBvaBt47Rr2q-og>=Vb&+)MRhcqymGMo}z%p$Vk zWHQ!?AQB)~FKKcpjzFGAMTJsRc1BD)HMRP zL*I*^82@qdS6=@+js9mn5CHC9f&l4iku^usO-e00;y~VU=I{?bA(bg{p5@uT;_FkL zahV;`!7cV4<$FW^G~}b6X+5}>Ti2O|HQ;|A23^~2tB;F?kO!K5ob=;ae$1{o|8I8& zNCn4lIREc7_rDIF!bc^P>;Ia#|6+mb9`XPiC*Bv!!qX~yD(>+COpqhYjEe>3!QZOE z_eaf6^_dr-^~-A6|Go16Zh!6k4;R3j{eShd|LmFb>KGp>M3l5da}Q7?AA8WegG>+t zL`5m`dgS)v_S{^%Xf7bqfR10QbIOB}_<4&ZkqlXMW4^&KrpfCGVMjOzBpp0&P*dp`4w*f#Opb7`LRZ9UJmhTGk(lsIA;6d}{q4 z)7-%SH~arO(EnM<{90r zCi&kk{=bXOKJYTTNVlyNgNTYHO z{m{9Q>Ern@LhT;PL=t-(g=gbG(#pRP9Gb{x1ey_OMxYsiW(1lMXhxtJfo24n5okuB z8G&X5nh|J5pc#Q?1ey_OMxYsiW(1lMXhxtJfo24n5okuB8G&X5nh|J5pc#ShYy|!v D?MHi% literal 0 HcmV?d00001 diff --git a/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs.inc b/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs.inc new file mode 100755 index 0000000..e39f94c --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs.inc @@ -0,0 +1,12 @@ +!R. Ryne Jan 5, 2005 +!This is the file mpi_stubs.inc +! +!For the serial version of ML/I, the file copy_of_stubs.inc +!needs to be renamed mpi_stubs.inc +! +!For the parallel version of ML/I, the file mpi_stubs.inc +!needs to contain just one line of code with the word "contains" +!Here it is: +! +contains +! diff --git a/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs_placeholder.inc b/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs_placeholder.inc new file mode 100755 index 0000000..e39f94c --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs_placeholder.inc @@ -0,0 +1,12 @@ +!R. Ryne Jan 5, 2005 +!This is the file mpi_stubs.inc +! +!For the serial version of ML/I, the file copy_of_stubs.inc +!needs to be renamed mpi_stubs.inc +! +!For the parallel version of ML/I, the file mpi_stubs.inc +!needs to contain just one line of code with the word "contains" +!Here it is: +! +contains +! diff --git a/OpticsJan2020/MLI_light_optics/Includes/multipole.inc b/OpticsJan2020/MLI_light_optics/Includes/multipole.inc new file mode 100644 index 0000000..d04a97b --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/multipole.inc @@ -0,0 +1,14 @@ + parameter (maxcoils = 100, maxshape = 6 ) + double precision acoil(maxcoils), alcoil(maxcoils) + double precision zcoil(maxcoils), shape(maxcoils,maxshape) + double precision glprod(maxcoils) + integer itype(maxcoils) + integer ncoil, mcoil(maxcoils) + double precision ashield, permshield + common/coils/mcoil, acoil, alcoil, zcoil, shape, glprod, itype + common/coiln/ztotal, ncoil + common/shield/ashield, permshield, shflag + double precision xldr + common/ldr/ xldr + common/coilbl/lblcoil(maxcoils) + character*8 lblcoil diff --git a/OpticsJan2020/MLI_light_optics/Includes/nlsvar.inc b/OpticsJan2020/MLI_light_optics/Includes/nlsvar.inc new file mode 100755 index 0000000..b473a6e --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/nlsvar.inc @@ -0,0 +1,6 @@ + parameter (maxdat = 1000) + parameter (maxv = 10, maxf = 15, maxq = maxv+1 ) + common /nlsvar/ modu, ntot, nomin, minpt, maxpt, nlsi, fmin, + * fmax, regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), + * fdat(maxf,maxdat), fmdat(maxdat), fvmin(maxf), xcen(maxv) + save /nlsvar/ diff --git a/OpticsJan2020/MLI_light_optics/Includes/nnprint.inc b/OpticsJan2020/MLI_light_optics/Includes/nnprint.inc new file mode 100644 index 0000000..99d4037 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/nnprint.inc @@ -0,0 +1 @@ + common/nnprint/nnprint,lun diff --git a/OpticsJan2020/MLI_light_optics/Includes/nturn.inc b/OpticsJan2020/MLI_light_optics/Includes/nturn.inc new file mode 100755 index 0000000..eadb455 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/nturn.inc @@ -0,0 +1,2 @@ + common/nnturn/ nturn +c Turn number in cqlate diff --git a/OpticsJan2020/MLI_light_optics/Includes/order.inc b/OpticsJan2020/MLI_light_optics/Includes/order.inc new file mode 100755 index 0000000..4022c58 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/order.inc @@ -0,0 +1,3 @@ +c order = order of each monomial + integer order(monoms) + common/order/order diff --git a/OpticsJan2020/MLI_light_optics/Includes/param.inc b/OpticsJan2020/MLI_light_optics/Includes/param.inc new file mode 100755 index 0000000..0618092 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/param.inc @@ -0,0 +1,6 @@ +c monoms = number of monomials used +c monom1 = number of monomials one order less; monom2 two order less + integer monoms,monom1,monom2 + parameter (monoms=923) + parameter (monom1=461) + parameter (monom2=209) diff --git a/OpticsJan2020/MLI_light_optics/Includes/parset.inc b/OpticsJan2020/MLI_light_optics/Includes/parset.inc new file mode 100755 index 0000000..2f16a9e --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/parset.inc @@ -0,0 +1,3 @@ +c maxpst = number of parameter sets + parameter (maxpst=9) + common /parset/ pst(6,maxpst) diff --git a/OpticsJan2020/MLI_light_optics/Includes/pbkh.inc b/OpticsJan2020/MLI_light_optics/Includes/pbkh.inc new file mode 100755 index 0000000..318db48 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/pbkh.inc @@ -0,0 +1 @@ + common/pbkh/pbh(monoms,12) diff --git a/OpticsJan2020/MLI_light_optics/Includes/pbkh_bck.inc b/OpticsJan2020/MLI_light_optics/Includes/pbkh_bck.inc new file mode 100755 index 0000000..9f3b08f --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/pbkh_bck.inc @@ -0,0 +1 @@ + common/pbkh/pbh(monoms,12),pbh6(monoms,6),pbh6t(6,monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/pie.inc b/OpticsJan2020/MLI_light_optics/Includes/pie.inc new file mode 100755 index 0000000..2cda659 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/pie.inc @@ -0,0 +1,2 @@ +c constants + common/pie/pi,pi180,twopi diff --git a/OpticsJan2020/MLI_light_optics/Includes/pq.inc b/OpticsJan2020/MLI_light_optics/Includes/pq.inc new file mode 100755 index 0000000..a55f3a6 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/pq.inc @@ -0,0 +1 @@ + common /pq/ip(monoms),iq(monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/previous.inc b/OpticsJan2020/MLI_light_optics/Includes/previous.inc new file mode 100755 index 0000000..6e0657d --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/previous.inc @@ -0,0 +1,3 @@ +c parameters associated with the previous element +cKMP: Added refprev (previous reference trajectory) - 6 Nov 2006 + common/previous/refprev(6),prevlen,rhoprev,nt2prev diff --git a/OpticsJan2020/MLI_light_optics/Includes/prodex.inc b/OpticsJan2020/MLI_light_optics/Includes/prodex.inc new file mode 100755 index 0000000..6317ee6 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/prodex.inc @@ -0,0 +1,3 @@ +c prodex = index for product of argument-index and single variable + integer prodex(6,0:monoms) + common/prodex/prodex diff --git a/OpticsJan2020/MLI_light_optics/Includes/psflag.inc b/OpticsJan2020/MLI_light_optics/Includes/psflag.inc new file mode 100755 index 0000000..e919f4b --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/psflag.inc @@ -0,0 +1,2 @@ +c common block indicating whether a parameter set has been captured + common/psflag/icapt(maxpst) diff --git a/OpticsJan2020/MLI_light_optics/Includes/quadp.inc b/OpticsJan2020/MLI_light_optics/Includes/quadp.inc new file mode 100755 index 0000000..24cf7f6 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/quadp.inc @@ -0,0 +1 @@ + common/quadp3/g1,g2,g3,zz1,zz2,zz3,hw1,hw2,hw3,r1,r2 diff --git a/OpticsJan2020/MLI_light_optics/Includes/quadpn.inc b/OpticsJan2020/MLI_light_optics/Includes/quadpn.inc new file mode 100755 index 0000000..0344e14 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/quadpn.inc @@ -0,0 +1 @@ + common/quadpn/ga(6),wd(6),ra(6),rb(6),dr(6),di,nr(6),maxq,nqt,ncyc diff --git a/OpticsJan2020/MLI_light_optics/Includes/recmul.inc b/OpticsJan2020/MLI_light_optics/Includes/recmul.inc new file mode 100755 index 0000000..e9e212f --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/recmul.inc @@ -0,0 +1 @@ + common/recmul/fsxnr,fsxsk,focnr,focsk,sl2,sl3 diff --git a/OpticsJan2020/MLI_light_optics/Includes/setref.inc b/OpticsJan2020/MLI_light_optics/Includes/setref.inc new file mode 100755 index 0000000..75992fb --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/setref.inc @@ -0,0 +1,3 @@ + parameter(mxref=9) + common/refdata/refsave(mxref,6),arcsave(mxref),brhosav(mxref) & + &,gamsav(mxref),gam1sav(mxref),betasav(mxref) diff --git a/OpticsJan2020/MLI_light_optics/Includes/sigbuf.inc b/OpticsJan2020/MLI_light_optics/Includes/sigbuf.inc new file mode 100755 index 0000000..e5fa059 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/sigbuf.inc @@ -0,0 +1,4 @@ + parameter (maxpt=2) + common/sigbuf/nask,npts,xxin,axin,pxin,yyin,ayin,pyin,zzin,azin, + * pzin,sig0(4,4),sigf(4,4),dsig(4,4),dsig2(4,4),zz(maxpt), + * xx(maxpt),ax(maxpt),px(maxpt),yy(maxpt),ay(maxpt),py(maxpt) diff --git a/OpticsJan2020/MLI_light_optics/Includes/sincos.inc b/OpticsJan2020/MLI_light_optics/Includes/sincos.inc new file mode 100755 index 0000000..ef06c36 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/sincos.inc @@ -0,0 +1,4 @@ + parameter (maxz=2000) + common/csrays/jp,npos,nang,mu,uwx,uwy,za(maxz),az(maxz), + * cx(maxz),sx(maxz),cy(maxz),sy(maxz) + diff --git a/OpticsJan2020/MLI_light_optics/Includes/sol.inc b/OpticsJan2020/MLI_light_optics/Includes/sol.inc new file mode 100755 index 0000000..ec60bb1 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/sol.inc @@ -0,0 +1,5 @@ +c parameters for solenoid + double precision :: bz0,cl,tl,di + integer :: ioptr + common/mlsol/ bz0,cl,tl,di,ioptr + diff --git a/OpticsJan2020/MLI_light_optics/Includes/sr.inc b/OpticsJan2020/MLI_light_optics/Includes/sr.inc new file mode 100755 index 0000000..3f0a33b --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/sr.inc @@ -0,0 +1,2 @@ + integer srexp + common /sr/srexp(0:2,monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/srl.inc b/OpticsJan2020/MLI_light_optics/Includes/srl.inc new file mode 100755 index 0000000..5b27320 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/srl.inc @@ -0,0 +1,2 @@ + character*6 sln + common /srl/sln(monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/stack.inc b/OpticsJan2020/MLI_light_optics/Includes/stack.inc new file mode 100755 index 0000000..95e1838 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/stack.inc @@ -0,0 +1,13 @@ +c mstack = maximum depth of stack + parameter (mstack=20) +c np = stack pointer +c ntype = type of top stack element +c ith = index of " " " in its array +c mtype = type of actual slot of ith +c jth = index of " " " " in its array +c nslot(k) = actual slot of kth stack element +c loop(k) = repetition factor of kth stack element +c lstac(k) = name of kth stack element + common /stack/ np,ntype,ith,mtype,jth,nslot(mstack),loop(mstack) + common /stac/ lstac(mstack) + character*16 lstac diff --git a/OpticsJan2020/MLI_light_optics/Includes/status.inc b/OpticsJan2020/MLI_light_optics/Includes/status.inc new file mode 100755 index 0000000..44b05d4 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/status.inc @@ -0,0 +1,7 @@ +c status and error flags +c ieig46 is a flag set by eig4 and eig6, and reset by +c eig4, eig6, fit, and opt. +c A value of 0 means everything is ok, and a value of 1 means +c that eigenvalues in eig4 or eig6 were found to be off the unit +c circle. + common /status/ imbad diff --git a/OpticsJan2020/MLI_light_optics/Includes/stmap.inc b/OpticsJan2020/MLI_light_optics/Includes/stmap.inc new file mode 100755 index 0000000..5896d2c --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/stmap.inc @@ -0,0 +1,8 @@ +! 12/15/2004: Original version commented out by RDR +! common/stmap/sf1(monoms),sf2(monoms),sf3(monoms), +! # sf4(monoms),sf5(monoms), +! # sm1(6,6),sm2(6,6),sm3(6,6), +! # sm4(6,6),sm5(6,6) +! dimension sfa(monoms,5), sma(6,6,5) +! equivalence (sfa,sf1), (sma,sm1) + common/stmap/storedpoly(monoms,20),storedmat(6,6,20) diff --git a/OpticsJan2020/MLI_light_optics/Includes/supres.inc b/OpticsJan2020/MLI_light_optics/Includes/supres.inc new file mode 100755 index 0000000..0da7a71 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/supres.inc @@ -0,0 +1 @@ + common/supres/it diff --git a/OpticsJan2020/MLI_light_optics/Includes/symp.inc b/OpticsJan2020/MLI_light_optics/Includes/symp.inc new file mode 100755 index 0000000..081b6c2 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/symp.inc @@ -0,0 +1,3 @@ +c jm = matrix J + double precision jm(6,6) + common/symp/jm diff --git a/OpticsJan2020/MLI_light_optics/Includes/talk.inc b/OpticsJan2020/MLI_light_optics/Includes/talk.inc new file mode 100755 index 0000000..90f8620 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/talk.inc @@ -0,0 +1,2 @@ +c jwarn is set to .ne.0 by evalsr, if ray is lost + common/talk/jwarn diff --git a/OpticsJan2020/MLI_light_optics/Includes/taylor.inc b/OpticsJan2020/MLI_light_optics/Includes/taylor.inc new file mode 100755 index 0000000..7da2cb9 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/taylor.inc @@ -0,0 +1,5 @@ +c +c Storage for Taylor coefficients +ctm 16 Apr 2001 3rd order Taylor expansion matrix +c + common/taylor/tumat(83,6) diff --git a/OpticsJan2020/MLI_light_optics/Includes/time.inc b/OpticsJan2020/MLI_light_optics/Includes/time.inc new file mode 100755 index 0000000..42e7c60 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/time.inc @@ -0,0 +1,2 @@ + real tstart + common /lietime/ tstart diff --git a/OpticsJan2020/MLI_light_optics/Includes/usrdat.inc b/OpticsJan2020/MLI_light_optics/Includes/usrdat.inc new file mode 100755 index 0000000..f4f0bee --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/usrdat.inc @@ -0,0 +1 @@ + common/usrdat/nuvar,kusr,ucalc(250),wa(15) diff --git a/OpticsJan2020/MLI_light_optics/Includes/vblist.inc b/OpticsJan2020/MLI_light_optics/Includes/vblist.inc new file mode 100755 index 0000000..dfc8b37 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/vblist.inc @@ -0,0 +1,3 @@ +c vblist = table of variables occuring in monomial + integer vblist(6,0:monoms) + common/vblist/vblist diff --git a/OpticsJan2020/MLI_light_optics/Includes/vecpot.inc b/OpticsJan2020/MLI_light_optics/Includes/vecpot.inc new file mode 100644 index 0000000..69d6dee --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/vecpot.inc @@ -0,0 +1,2 @@ + double precision Ax(0:monoms), Ay(0:monoms), Az(0:monoms) + common/vectorp/Ax, Ay, Az diff --git a/OpticsJan2020/MLI_light_optics/Includes/xvary.inc b/OpticsJan2020/MLI_light_optics/Includes/xvary.inc new file mode 100755 index 0000000..f0662c4 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/xvary.inc @@ -0,0 +1,8 @@ +c--------------------------------------------------------------------- +c variable definitions +c + parameter (maxv=100) + common/xvary/nva(3),nda(3),ivar,jdep,mm(maxv,3),idx(maxv,3), + * idv(maxv,3),xbase(maxv,3),xslope(maxv,3) + character*12 varnam + common/vnames/varnam(maxv,3) diff --git a/OpticsJan2020/MLI_light_optics/Includes/zeroes.inc b/OpticsJan2020/MLI_light_optics/Includes/zeroes.inc new file mode 100755 index 0000000..f1bfac7 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/zeroes.inc @@ -0,0 +1,2 @@ +c common block for storing various zeroes + common/zeroes/fzer,detz diff --git a/OpticsJan2020/MLI_light_optics/Includes/zz.inc b/OpticsJan2020/MLI_light_optics/Includes/zz.inc new file mode 100644 index 0000000..7e0bc21 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Includes/zz.inc @@ -0,0 +1,6 @@ + double precision zinitial(6),zfinal(6) + common/zz/zinitial, zfinal +cryneneriwalstrom data zinitial/0.,0.,0.,0.,0.,0./ +cryne I commented this out because zinitial appears to be unused. +cryne To put it back, the data needs to be initialized in the +cryne block data subroutine in afro.f diff --git a/OpticsJan2020/MLI_light_optics/Makedir/makefile b/OpticsJan2020/MLI_light_optics/Makedir/makefile new file mode 100644 index 0000000..f03f7ac --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Makedir/makefile @@ -0,0 +1,295 @@ +VPATH=../Src + +.SUFFIXES: +.SUFFIXES: .o .f .f90 + + +# implicit compile rules +.f.o: + $(Fortran) $< + + +.f90.o: + $(FortranFree) $< + +Fortran = gfortran -c -I../Includes +FortranFree = gfortran -c -I../Includes +FortranMain = gfortran -o ../mli.x -I../Includes + +OBJS = afro_mod.o parallel_mod.o constants_mod.o liea_mod.o spch3d_mod.o \ + e_gengrad_mod.o gengrad_mod.o timer_mod.o multitrack_mod.o \ + curve_fit.o greenfn_mod.o \ + afro.o anal.o base.o bessjm.o book.o boundp3d.o \ + cfbdang.o cfqd.o coil.o comm.o cons.o \ + diagnostics.o dist.o dummy.o dumpin.o \ + ebcomp.o elem.o env.o euclid.o fftpkgq.o fparser.o \ + genm.o gensol.o hamdrift.o inpu.o integ.o iron.o \ + liea.o linpak_old.o myblas.o xerbla.o \ + magnet.o math.o meri.o mygenrec5.o opti.o \ + parameters.o proc.o pure.o rfgap.o \ + setbound.o sif.o spch2d.o spch3d.o sss.o trac.o \ + user.o user7.o usubs.o wakefld.o xtra_notgnu.o \ + spch3d_dummy.o spch3d_chombo_dummy.o mpi.o optics.o + +# explicit rule to build executable +../mli.x: $(OBJS) + $(FortranMain) $(OBJS) + +# other targets +.PHONY: clean +clean: + @\rm -f *.o *.mod *.d + + +# module dependencies +afro.o anal.o book.o boundp3d.o cfbdang.o cfqd.o coil.o comm.o diagnostics.o dist.o dumpin.o elem.o env.o gensol.o hamdrift.o inpu.o integ.o liea.o math.o mygenrec5.o proc.o rfgap.o setbound.o sif.o spch2d.o spch3d.o spch3d_essl.o trac.o user.o usubs.o wakefld.o : afro_mod.o + +ebcomp.o e_gengrad_mod.o : constants_mod.o + +afro.o ebcomp.o : e_gengrad_mod.o + +sif.o : fparser.o + +e_gengrad_mod.o : gengrad_mod.o + +afro.o anal.o base.o book.o cfbdang.o comm.o cons.o diagnostics.o dist.o dumpin.o elem.o env.o genm.o gensol.o hamdrift.o inpu.o liea.o math.o mygenrec5.o proc.o pure.o rfgap.o spch3d.o sss.o trac.o user.o user7.o usubs.o : liea_mod.o + +afro.o afro_mod.o anal.o book.o diagnostics.o dist.o dumpin.o env.o fftpkgq.o inpu.o pure.o rfgap.o sif.o spch3d.o spch3d_essl.o timer_mod.o : parallel_mod.o + +fparser.o sif.o : parameters.o + +afro.o spch3d.o : spch3d_mod.o + +afro.o diagnostics.o fftpkgq.o spch3d.o spch3d_essl.o trac.o : timer_mod.o + + +# include file dependencies -- use the following target to regenerate the dependencies +make.depends: + @grep -i '^[ \t]*include[ \t]' ../Src/*.f | grep -v 'mpif.h' | sort | uniq | awk '{sub("../Src/","");sub(".f:",".o:")gsub("'\''","");$$2=""; print $$1,"../Includes/" $$3}' + @grep -i '^[ \t]*include[ \t]' ../Src/*.f90 | grep -v 'mpif.h' | sort | uniq | awk '{sub("../Src/","");sub(".f90:",".o:")gsub("'\''","");$$2=""; print $$1,"../Includes/" $$3}' + +afro.o: ../Includes/codes.inc +afro.o: ../Includes/core.inc +afro.o: ../Includes/deriv.inc +afro.o: ../Includes/expon.inc +afro.o: ../Includes/files.inc +afro.o: ../Includes/fitbuf.inc +afro.o: ../Includes/frnt.inc +afro.o: ../Includes/impli.inc +afro.o: ../Includes/ind.inc +afro.o: ../Includes/infin.inc +afro.o: ../Includes/labpnt.inc +afro.o: ../Includes/lims.inc +afro.o: ../Includes/loop.inc +afro.o: ../Includes/map.inc +afro.o: ../Includes/maxcat.inc +afro.o: ../Includes/nturn.inc +afro.o: ../Includes/parset.inc +afro.o: ../Includes/pie.inc +afro.o: ../Includes/previous.inc +afro.o: ../Includes/setref.inc +afro.o: ../Includes/stack.inc +afro.o: ../Includes/talk.inc +afro.o: ../Includes/time.inc +afro.o: ../Includes/zeroes.inc +anal.o: ../Includes/buffer.inc +anal.o: ../Includes/codes.inc +anal.o: ../Includes/core.inc +anal.o: ../Includes/extalk.inc +anal.o: ../Includes/files.inc +anal.o: ../Includes/fitdat.inc +anal.o: ../Includes/hmflag.inc +anal.o: ../Includes/impli.inc +anal.o: ../Includes/loop.inc +anal.o: ../Includes/param.inc +anal.o: ../Includes/parset.inc +anal.o: ../Includes/pie.inc +anal.o: ../Includes/supres.inc +anal.o: ../Includes/usrdat.inc +book.o: ../Includes/dr.inc +book.o: ../Includes/drl.inc +book.o: ../Includes/expon.inc +book.o: ../Includes/files.inc +book.o: ../Includes/frnt.inc +book.o: ../Includes/id.inc +book.o: ../Includes/impli.inc +book.o: ../Includes/ind.inc +book.o: ../Includes/ind3.inc +book.o: ../Includes/iprod.inc +book.o: ../Includes/ja3.inc +book.o: ../Includes/len.inc +book.o: ../Includes/len3.inc +book.o: ../Includes/lims.inc +book.o: ../Includes/maxcat.inc +book.o: ../Includes/order.inc +book.o: ../Includes/pie.inc +book.o: ../Includes/pq.inc +book.o: ../Includes/prodex.inc +book.o: ../Includes/sr.inc +book.o: ../Includes/srl.inc +book.o: ../Includes/symp.inc +book.o: ../Includes/time.inc +book.o: ../Includes/vblist.inc +cfbdang.o: ../Includes/impli.inc +cfbdang.o: ../Includes/parset.inc +comm.o: ../Includes/expon.inc +comm.o: ../Includes/files.inc +comm.o: ../Includes/impli.inc +comm.o: ../Includes/lims.inc +comm.o: ../Includes/maxcat.inc +comm.o: ../Includes/param.inc +comm.o: ../Includes/stmap.inc +cons.o: ../Includes/impli.inc +cons.o: ../Includes/parset.inc +diagnostics.o: ../Includes/files.inc +diagnostics.o: ../Includes/impli.inc +diagnostics.o: ../Includes/map.inc +dist.o: ../Includes/buffer.inc +dist.o: ../Includes/files.inc +dist.o: ../Includes/impli.inc +dist.o: ../Includes/parset.inc +dumpin.o: ../Includes/codes.inc +dumpin.o: ../Includes/files.inc +dumpin.o: ../Includes/impli.inc +dumpin.o: ../Includes/incmif.inc +ebcomp.o: ../Includes/ebdata.inc +ebcomp.o: ../Includes/impli.inc +elem.o: ../Includes/files.inc +elem.o: ../Includes/impli.inc +elem.o: ../Includes/parset.inc +elem.o: ../Includes/pie.inc +elem.o: ../Includes/symp.inc +env.o: ../Includes/impli.inc +euclid.o: ../Includes/impli.inc +genm.o: ../Includes/hmflag.inc +genm.o: ../Includes/impli.inc +genm.o: ../Includes/lims.inc +gensol.o: ../Includes/combs.inc +gensol.o: ../Includes/files.inc +gensol.o: ../Includes/hmflag.inc +gensol.o: ../Includes/impli.inc +gensol.o: ../Includes/parset.inc +gensol.o: ../Includes/sol.inc +hamdrift.o: ../Includes/impli.inc +inpu.o: ../Includes/buffer.inc +inpu.o: ../Includes/codes.inc +inpu.o: ../Includes/core.inc +inpu.o: ../Includes/drl.inc +inpu.o: ../Includes/expon.inc +inpu.o: ../Includes/files.inc +inpu.o: ../Includes/impli.inc +inpu.o: ../Includes/incmif.inc +inpu.o: ../Includes/loop.inc +inpu.o: ../Includes/parset.inc +inpu.o: ../Includes/pbkh.inc +inpu.o: ../Includes/srl.inc +liea.o: ../Includes/expon.inc +liea.o: ../Includes/impli.inc +liea.o: ../Includes/ind.inc +liea.o: ../Includes/iprod.inc +liea.o: ../Includes/len.inc +liea.o: ../Includes/lims.inc +liea.o: ../Includes/pbkh.inc +liea.o: ../Includes/prodex.inc +liea.o: ../Includes/symp.inc +liea.o: ../Includes/vblist.inc +math.o: ../Includes/buffer.inc +math.o: ../Includes/expon.inc +math.o: ../Includes/id.inc +math.o: ../Includes/impli.inc +math.o: ../Includes/len.inc +math.o: ../Includes/vblist.inc +mygenrec5.o: ../Includes/combs.inc +mygenrec5.o: ../Includes/files.inc +mygenrec5.o: ../Includes/hmflag.inc +mygenrec5.o: ../Includes/impli.inc +mygenrec5.o: ../Includes/parset.inc +mygenrec5.o: ../Includes/quadpn.inc +mygenrec5.o: ../Includes/recmul.inc +myprot5.o: ../Includes/impli.inc +myprot5.o: ../Includes/param.inc +myprot5.o: ../Includes/parm.inc +myprot5.o: ../Includes/pie.inc +opti.o: ../Includes/impli.inc +opti.o: ../Includes/minvar.inc +opti.o: ../Includes/nlsvar.inc +proc.o: ../Includes/aimdef.inc +proc.o: ../Includes/amdiip.inc +proc.o: ../Includes/buffer.inc +proc.o: ../Includes/codes.inc +proc.o: ../Includes/files.inc +proc.o: ../Includes/fitbuf.inc +proc.o: ../Includes/fitdat.inc +proc.o: ../Includes/impli.inc +proc.o: ../Includes/keyset.inc +proc.o: ../Includes/labpnt.inc +proc.o: ../Includes/map.inc +proc.o: ../Includes/merit.inc +proc.o: ../Includes/parset.inc +proc.o: ../Includes/psflag.inc +proc.o: ../Includes/status.inc +proc.o: ../Includes/stmap.inc +proc.o: ../Includes/usrdat.inc +proc.o: ../Includes/xvary.inc +pure.o: ../Includes/dr.inc +pure.o: ../Includes/impli.inc +pure.o: ../Includes/sr.inc +rfgap.o: ../Includes/files.inc +rfgap.o: ../Includes/fitbuf.inc +rfgap.o: ../Includes/impli.inc +rfgap.o: ../Includes/map.inc +rfgap.o: ../Includes/usrdat.inc +setbound.o: ../Includes/impli.inc +sif.o: ../Includes/codes.inc +sif.o: ../Includes/files.inc +sif.o: ../Includes/impli.inc +sif.o: ../Includes/pie.inc +spch3d.o: ../Includes/files.inc +spch3d.o: ../Includes/impli.inc +spch3d.o: ../Includes/map.inc +sss.o: ../Includes/files.inc +trac.o: ../Includes/deriv.inc +trac.o: ../Includes/expon.inc +trac.o: ../Includes/files.inc +trac.o: ../Includes/impli.inc +trac.o: ../Includes/ind.inc +trac.o: ../Includes/ind3.inc +trac.o: ../Includes/ja3.inc +trac.o: ../Includes/len.inc +trac.o: ../Includes/len3.inc +trac.o: ../Includes/lims.inc +trac.o: ../Includes/pbkh.inc +trac.o: ../Includes/talk.inc +trac.o: ../Includes/vblist.inc +user.o: ../Includes/expon.inc +user.o: ../Includes/files.inc +user.o: ../Includes/fitdat.inc +user.o: ../Includes/impli.inc +user.o: ../Includes/linbuf.inc +user.o: ../Includes/map.inc +user.o: ../Includes/parset.inc +user.o: ../Includes/sigbuf.inc +user.o: ../Includes/sincos.inc +user.o: ../Includes/taylor.inc +user.o: ../Includes/usrdat.inc +user7.o: ../Includes/impli.inc +user7.o: ../Includes/ind.inc +user7.o: ../Includes/prodex.inc +usubs.o: ../Includes/actpar.inc +usubs.o: ../Includes/codes.inc +usubs.o: ../Includes/core.inc +usubs.o: ../Includes/expon.inc +usubs.o: ../Includes/files.inc +usubs.o: ../Includes/impli.inc +usubs.o: ../Includes/linbuf.inc +usubs.o: ../Includes/loop.inc +usubs.o: ../Includes/map.inc +usubs.o: ../Includes/parset.inc +usubs.o: ../Includes/pbkh.inc +usubs.o: ../Includes/sigbuf.inc +usubs.o: ../Includes/taylor.inc +usubs.o: ../Includes/usrdat.inc +usubs.o: ../Includes/vblist.inc +xtra_notgnu.o: ../Includes/files.inc +xtra_notgnu.o: ../Includes/impli.inc +xtra_notgnu.o: ../Includes/time.inc diff --git a/OpticsJan2020/MLI_light_optics/Src/afro.f b/OpticsJan2020/MLI_light_optics/Src/afro.f new file mode 100755 index 0000000..5f7144d --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/afro.f @@ -0,0 +1,8787 @@ +************************************************************************ +* header AFRONT * +* Front end of MARYLIE * +************************************************************************ +* +************************************************************************ +* MARYLIE and all its subroutines are copyrighted (1987) by * +* Alex J. Dragt. * +* All rights to MARYLIE and its subroutines are reserved. * +************************************************************************ +* +* Version Date: 5/25/98 +* +*********************************************************************** +* All of MARYLIE 3.0 is believed to conform to Fortran 77 standards. +* In addition, all of MARYLIE 3.0 is self contained save for +* +* 1) the time functions called in the MARYLIE +* subroutine cputim +* +* and +* +* 2) the 'exit' subroutine called (and only called) in the +* MARYLIE subroutine myexit. +* +* The two subroutines cputim and myexit and the subroutine mytime +* (which is the only one that calls cputim) are kept separately +* under the heading "XTRA". +********************************************************************* +c +********************************************************************* +c +* Main program for MARYLIE 3.0 +* Written originally by Rob Ryne ca 1984 and revised by +* Petra Schuett November 1987 +* + program mainmary +c + use rays + use acceldata + use lieaparam, only : monoms + use ml_timer + include 'impli.inc' + include 'files.inc' + include 'time.inc' + include 'ind.inc' + include 'codes.inc' +c + dimension p(6) + common/xtrajunk/jticks1,iprinttimers +c + call init_parallel + call init_ml_timers + call system_clock(count=jticks1) +c +c +c initiate starting time +c nint(p(1)).ne.0 resets a variable called tstart in common/mltime/ +c which is contained in the file time.inc rdr 08/25/2001 + p(1)=1.d0 + p(2)=12.d0 + p(3)=0.d0 + call mytime(p) +c +c write out copyright message at terminal + call cpyrt +c +c initialize commons (other than those in block data's) +c initialize lie algebraic things +c + call new_acceldata +! call new_particledata !do this for now for ML30 compat. RDR 8/10/02 +c + call setup +c +c read master input file +c + call dumpin +c +c======================================================================== +c print debug info on file 79 + write(79,*)'nconst=',nconst + write(79,*)' n constr conval' + do n=1,nconst + write(79,*)n,constr(n),conval(n) +c call flush(79) + enddo +c + write(79,*)' ' + write(79,*)'na=',na + write(79,*)'listing of n,nt1(n),nt2(n) for n=1,...,na' + do n=1,na + k1=nt1(n) + k2=nt2(n) + call lookup(lmnlbl(n),ntype,ith) + nn0=mpp(ith)+1 + nn1=mppc(ith)+1 + write(79,1236)n, & + & nt1(n),nt2(n),ltc(k1,k2),lmnlbl(n),nn0,nn1,nrp(k1,k2),ncp(k1,k2) +c call flush(79) + 1236 format(3(i4,1x),2(a16,1x),2(i5,1x),6x,2(i4,1x)) + enddo +c + write(79,*)' ' + write(79,*)'mpprpoi=',mpprpoi + write(79,*)'listing of n,pmenu(n) for n=1,...,mpprpoi' + do n=1,mpprpoi +c the following loop makes this whole thing very inefficent, +c but I am going to do it anyway in order to make this info +c more readable: +! do mmm=1,na +! k1=nt1(mmm) +! k2=nt2(mmm) +! call lookup(lmnlbl(mmm),ntype,ith) +! nn0=mpp(ith)+1 +! if(nn0.eq.n.and.nrp(k1,k2).ne.0)then +! write(79,*)lmnlbl(mmm),ltc(k1,k2) +! endif +! enddo + write(79,*)n,pmenu(n) +c call flush(79) + enddo + write(79,*)' ' + write(79,*)'mppcpoi=',mppcpoi + write(79,*)'listing of n,cmenu(n) for n=1,...,mppcpoi' + do n=1,mppcpoi + write(79,*)n,cmenu(n) +c call flush(79) + enddo +c======================================================================== + +c +c debug output +c call dump(jodf) +c call dump(jof) +c +c write out status at terminal + if(idproc.eq.0)then + write(jof,100) + 100 format(1h ,'Data input complete; going into #labor.') + endif +c +c begin actual calculations + call tran +c +c the end of the program is reached in MYEXIT +cryne ...but call myexit here in case the user forgot to use an "end" command + call myexit + end +c +*********************************************************************** + block data misc +c----------------------------------------------------------------------- +c initialize miscellaneous common variables +c Written by Petra Schuett, November 1987 based on earlier work of +c Rob Ryne and Liam Healy +c----------------------------------------------------------------------- + use acceldata + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' +c-------------------- + include 'core.inc' + include 'files.inc' + include 'lims.inc' + include 'maxcat.inc' + include 'infin.inc' + include 'zeroes.inc' +c-------------------- + data ordcat/6/,topcat/monoms/ + data ordlib/6/,toplib/monoms/ +c-------------------- + data bottom/0,1, 7,28, 84,210,462, 924,1716,3003,5005, 8008,12376/ + data top /0,6,27,83,209,461,923,1715,3002,5004,8007,12375,18563/ +c-------------------- + data lf,icf,jfcf,mpi,mpo,jif,jof,jodf,ibrief,iquiet/ & + & 11, 13, 14, 15, 16, 5, 6, 12, 2, 0/ +c-------------------- + data inuse/maxlum*0/ +c-------------------- + data xinf, yinf, tinf, ginf/ & + & 1000., 1000., 1000., 1000./ +c-------------------- + data fzer, detz/ & + & 0.d0, 0.d0/ +c +c-------------------- +c +cryne 8/15/2001 initialize parameters for poisson calculation: + common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0 + data nxsave,nysave,nzsave,noresize,nadj0/0,0,0,0,0/ + common/poiblock1/nspchset,nsckick + data nspchset,nsckick/0,-1/ + common/autotrk/lautotrk,ntrktype,ntrkorder + data lautotrk,ntrktype,ntrkorder/0,2,5/ +cryne 8/15/2001 parameters for automatic application of commands + character*16 autostr + common/autopnt/autostr(3) + common/autolog/lautoap1,lautoap2,lautoap3,lrestrictauto + common/autocon/lautocon + data autostr & + &/'xxxxxxxxxxxxxxxx','yyyyyyyyyyyyyyyy','zzzzzzzzzzzzzzzz'/ + data lautoap1,lautoap2,lautoap3/0,0,0/ + data lautocon/1/ +c + common/bfileinfo/ifileinfo + data ifileinfo/0/ +c +cryne 12 Nov 2003 + character*16 cparams + common/scparams/rparams(60),cparams(60) + data rparams/60*-9999999.d0/ + data cparams/60*'xxxxxxxxxxxxxxxx'/ +c + common/accum/at10,at21,at32,at43,at54,at65,at76,at70 + data at10,at21,at32,at43,at54,at65,at76,at70/0.,0.,0.,0.,0.,0.,0.,& + & 0./ + common/ffttime/ft10,ft21,ft32,ft30 + data ft10,ft21,ft32,ft30/0.,0.,0.,0./ +c +cryneneriwalstrom: + parameter(maxcof=35) + common /bicof/ bcoeff(maxcof,maxcof) + data (bcoeff(k,1),k=1,2) /1.d0,1.d0/ + data (bcoeff(k,2),k=1,3) /1.d0,2.d0,1.d0/ + end +c +************************************************************************ +c + block data names +c----------------------------------------------------------------------- +c define type codes allowed in MARYLIE +c Written by Petra Schuett in November 1987 based on earlier +c work of Rob Ryne +c----------------------------------------------------------------------- + include 'impli.inc' +c--------- +c commons +c--------- + include 'codes.inc' +c----------------------------------------------------------------------- +c components of master input file + data ling/'#comment', & + & '#beam ', & + & '#menu ', & + & '#lines ', & + & '#lumps ', & + & '#loops ', & + & '#labor ', & + & '#call ', & + & '#const'/ +c +c menu entries +c +c 1: simple elements +cryne 7/14/2002 added various elements to be compatible w/ MAD input. +cryne Also added some commonly used synonyms (e.g 'kick' for 'kicker') +cryne Need to work on the thin multipole. +c + data (ltc(1,j),j=1,75)/ + & 'drft ','nbnd ','pbnd ','gbnd ','prot ', & + & 'gbdy ','frng ','cfbd ','quad ','sext ', & + & 'octm ','octe ','srfc ','arot ','twsm ', & + & 'thlm ','cplm ','cfqd ','dism ','sol ', & + & 'mark ','jmap ','dp ','recm ','spce ', & + & 'cfrn ','coil ','intg ','rmap ','arc ', & + & 'rfgap ','confoc ','transit ','interface','rootmap', & + & 'optirot ','spare5 ','spare6 ','spare7 ','spare8 ', & + & 'marker ','drift ','rbend ','sbend ','gbend ', & + & 'quadrupole','sextupole','octupole','multipole','solenoid', & + & 'hkicker ','vkicker ','kicker ','rfcavity','elsepararator', & + & 'hmonitor','vmonitor','monitor ','instrument','sparem1 ', & + & 'rcollimator','ecollimator','yrot ','srot ','prot3 ', & + & 'beambeam','matrix ','profile1d','yprofile','tprofile', & + & 'hkick ','vkick ','kick ','hpm ','nlrf '/ + data (nrp(1,j),j=1,75)/ & + & 1,6,4,6,2, & + & 4,5,6,4,2, & + & 2,2,2,1,4, & + & 6,5,4,5,6, & + & 0,0,0,6,1, & + & 4,11,6,6,0, & + & 11,5,3,5,4, & + & 2,0,0,0,0, & + & 0,3,13,21,0, & + & 6,3,3, 6,13, & + & 4,4,5,8,4, & + & 2,2,2,2,0, & + & 3,3,1,1,2, & + & 0,0,7,6,6, & + & 4,4,5,3,7/ + data (ncp(1,j),j=1,75)/ & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 2,0,0,0,1, & + & 0,0,0,0,0, & + & 0,1,0,0,0, & + & 1,1,1,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,3,1,1, & + & 0,0,0,0,2/ + data (nrpold(1,j),j=1,75)/ & + & 1,6,4,6,2, & + & 4,5,6,4,2, & + & 2,2,2,1,4, & + & 6,5,4,5,6, & + & 0,0,0,6,1, & + & 4,11,6,6,0, & + & 7,4,0,0,0, & + & 0,0,0,0,0, & + & 0,2,0,21,0, & + & 5,3,3, 6,2, & + & 3,3,4,8,3, & + & 1,1,1,1,0, & + & 3,3,1,1,0, & + & 0,0,0,0,0, & + & 3,3,4,3,0/ +c +c 2: user-supplied elements +c + data (ltc(2,j),j=1,20)/ & + & 'usr1 ','usr2 ','usr3 ','usr4 ','usr5 ', & + & 'usr6 ','usr7 ','usr8 ','usr9 ','usr10 ', & + & 'usr11 ','usr12 ','usr13 ','usr14 ','usr15 ', & + & 'usr16 ','usr17 ','usr18 ','usr19 ','usr20 '/ + data (nrp(2,j),j=1,20)/20*6/ + data (ncp(2,j),j=1,20)/20*0/ + data (nrpold(2,j),j=1,20)/20*6/ +c +c 3: parameter sets +c + data (ltc(3,j),j=1,9)/ & + & 'ps1 ','ps2 ','ps3 ','ps4 ','ps5 ', & + & 'ps6 ','ps7 ','ps8 ','ps9 '/ + data (nrp(3,i),i=1,9)/9*6/ + data (ncp(3,i),i=1,9)/9*0/ + data (nrpold(3,i),i=1,9)/9*6/ +c +c 4: random elements +c Note: The j indices for these entries must be aligned with +c the j indices for their "simple element" counterparts. +c This is done by using "dummy" entries. +c + data (ltc(4,j),j=1,24)/ & + & 'rdrft ','rnbnd ','rpbnd ','rgbnd ','rprot ', & + & 'rgbdy ','rfrng ','rcfbd ','rquad ','rsext ', & + & 'roctm ','rocte ','rsrfc ','rarot ','rtwsm ', & + & 'rthlm ','rcplm ','rcfqd ','rdism ','rsol ', & + & 'dummark ','dumjmap ','dumdp ','rrecm '/ + data (nrp(4,i),i=1,24)/24*2/ + data (ncp(4,i),i=1,24)/24*0/ + data (nrpold(4,i),i=1,24)/24*2/ +c +c 5: random user-supplied elements +c + data (ltc(5,j),j=1,9)/ & + & 'rusr1 ','rusr2 ','rusr3 ','rusr4 ','rusr5 ', & + & 'rusr6 ','rusr7 ','rusr8 ','rusr9 '/ + data (nrp(5,i),i=1,9)/9*2/ + data (ncp(5,i),i=1,9)/9*0/ + data (nrpold(5,i),i=1,9)/9*2/ +c +c 6: random parameter sets +c + data (ltc(6,j),j=1,9)/ & + & 'rps1 ','rps2 ','rps3 ','rps4 ','rps5 ', & + & 'rps6 ','rps7 ','rps8 ','rps9 '/ + data (nrp(6,i),i=1,9)/9*2/ + data (ncp(6,i),i=1,9)/9*0/ + data (nrpold(6,i),i=1,9)/9*2/ +c +c 7: simple commands +cKMP: Replaced 'sparec5' with 'wrtmap' +cKMP: Replaced 'spacec6' with 'rdmap' +c + data (ltc(7,j),j=1,75)/ & + & 'rt ','sqr ','symp ','tmi ','tmo ', & + & 'pmif ','circ ','stm ','gtm ','end ', & + & 'ptm ','iden ','whst ','inv ','tran ', & + & 'revf ','rev ','mask ','num ','rapt ', & + & 'eapt ','of ','cf ','wnd ','wnda ', & + & 'ftm ','wps ','time ','cdf ','bell ', & + & 'wmrt ','wcl ','paws ','inf ','dims ', & + & 'zer ','sndwch ','tpol ','dpol ','cbm ', & + & 'poisson ','preapply','midapply','autoapply','autoconcat', & + & 'rayscale','beam ','units ','autoslice','verbose ', & + & 'mask6 ','arcreset','symbdef ','particledump','raytrace', & + & 'autotrack','sckick','moments ','maxsize ','reftraj', & + & 'initenv ','envelopes','contractenv','setreftraj','setarclen', & + & 'wakedefault','emittance','matchenv','fileinfo','egengrad', & + & 'wrtmap ','rdmap ','sparec7','sparec8','sparec9'/ + data (nrp(7,i),i=1,75)/ & + & 6,0,2,4,1, & + & 3,6,1,2,0, & + & 5,0,2,0,0, & + & 1,0,6,4,4, & + & 3,6,6,5,6, & + & 4,2,3,1,0, & + & 2,3,0,5,6, & + & 3,1,6,5,3, & + & 12,0,0,0,0, & + & 6,10,5,2,1, & + & 6,0,0,7,12, & + & 0,0,5,6,3, & + & 15,5,0,10,2, & + & 4,3,2,1,10, & + & 0,0,0,0,0/ + data (ncp(7,i),i=1,75)/ & + & 2,0,0,0,0, & + & 1,0,0,0,1, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 17,2,2,2,1, & + & 0,1,2,3,0, & + & 0,0,0,4,5, & + & 4,0,9,9,2, & + & 1,7,0,2,1, & + & 1,6,1,0,7, & + & 3,2,0,0,0/ + data (nrpold(7,i),i=1,75)/ & + & 6,0,2,4,1, & + & 3,6,1,2,0, & + & 5,0,2,0,0, & + & 1,0,6,4,4, & + & 3,6,6,5,6, & + & 4,2,3,1,4, & + & 2,3,0,5,6, & + & 3,1,6,5,3, & + & 6,0,0,0,1, & + & 6,10,4,1,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0/ +c +c 8: advanced commands +c + data (ltc(8,j),j=1,39)/ & + & 'cod ','amap ','dia ','dnor ','exp ', & + & 'pdnf ','psnf ','radm ','rasm ','sia ', & + & 'snor ','tadm ','tasm ','tbas ','gbuf ', & + & 'trsa ','trda ','smul ','padd ','pmul ', & + & 'pb ','pold ','pval ','fasm ','fadm ', & + & 'sq ','wsq ','ctr ','asni ','pnlp ', & + & 'csym ','psp ','mn ','bgen ','tic ', & + & 'ppa ','moma ','geom ','fwa '/ + data (nrp(8,i),i=1,39)/ & + & 6,6,5,5,3, & + & 5,5,5,5,5, & + & 5,4,6,1,2, & + & 6,6,6,3,3, & + & 3,5,3,6,6, & + & 4,6,4,6,4, & + & 1,3,2,12,6, & + & 6,6,6,6/ + data (ncp(8,i),i=1,39)/ & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0,2,0, & + & 0,0,0,0/ + data (nrpold(8,i),i=1,39)/ & + & 6,6,5,5,3, & + & 5,5,5,5,5, & + & 5,4,6,1,2, & + & 6,6,6,3,3, & + & 3,5,3,6,6, & + & 4,6,4,6,4, & + & 1,3,2,6,6, & + & 6,6,6,6/ +c +c 9: procedures and fitting and optimization +c + data (ltc(9,j),j=1,37)/ & + & 'bip ','bop ','tip ','top ', & + & 'aim ','vary ','fit ','opt ', & + & 'con1 ','con2 ','con3 ','con4 ','con5 ', & + & 'mrt0 ', & + & 'mrt1 ','mrt2 ','mrt3 ','mrt4 ','mrt5 ', & + & 'fps ', & + & 'cps1 ','cps2 ','cps3 ','cps4 ','cps5 ', & + & 'cps6 ','cps7 ','cps8 ','cps9 ', & + & 'dapt ','grad ','rset ','flag ','scan ', & + & 'mss ','spare1 ','spare1 '/ + data (nrp(9,i),i=1,37)/ & + & 1,1,1,1, & + & 6,6,6,6, & + & 6,6,6,6,6, & + & 1, & + & 6,6,6,6,6, & + & 1, & + & 6,6,6,6,6, & + & 6,6,6,6, & + & 4,6,5,6,6, & + & 6,6,6/ + data (ncp(9,i),i=1,37)/ & + & 0,1,1,1, & + & 0,0,0,0, & + & 0,0,0,0,0, & + & 0, & + & 0,0,0,0,0, & + & 0, & + & 0,0,0,0,0, & + & 0,0,0,0, & + & 0,0,0,0,0, & + & 0,0,0/ + data (nrpold(9,i),i=1,37)/ & + & 1,1,1,1, & + & 6,6,6,6, & + & 6,6,6,6,6, & + & 1, & + & 6,6,6,6,6, & + & 1, & + & 6,6,6,6,6, & + & 6,6,6,6, & + & 4,6,5,6,6, & + & 6,6,6/ +c + end +c +c********************************************************************** +c + subroutine buffin(th,tmh,thsave,tmhsav,lumpno) +c----------------------------------------------------------------------- +c stores a map and polynomial coeffs into a buffer +c Written by J. Howard, Fall 1986 +c----------------------------------------------------------------------- + use lieaparam, only : monoms + include 'impli.inc' + include 'stack.inc' +c + dimension th(monoms),tmh(6,6) + dimension thsave(monoms,mstack),tmhsav(6,6,mstack) +c + do 100 i = 1,6 + do 100 j = 1,6 + tmhsav(i,j,lumpno) = tmh(i,j) +100 continue +c + do 200 i = 1,monoms + thsave(i,lumpno) = th(i) +200 continue + return + end +************************************************************************ + subroutine bufout(thsave,tmhsav,th,tmh,lumpno) +c----------------------------------------------------------------------- +c reads a map and polynomial coefficients out of a buffer +c Written by J. Howard, Fall 1986 +c----------------------------------------------------------------------- + use lieaparam, only : monoms + include 'impli.inc' + include 'stack.inc' +c + dimension th(monoms),tmh(6,6) + dimension thsave(monoms,mstack),tmhsav(6,6,mstack) +c + do 100 i = 1,6 + do 100 j = 1,6 + tmh(i,j) = tmhsav(i,j,lumpno) +100 continue +c + do 200 i = 1,monoms + th(i) = thsave(i,lumpno) +200 continue +c + return + end +************************************************************************ + subroutine cnumb(string,num,lnum) +c----------------------------------------------------------------------- +c This routine finds out, whether string codes an integer number. +c if so, it converts it to num +c +c Input: string character*16 input string +c Output:num integer correspondent number +c lnum logical =.true. if string is a number +c +c Author: Petra Schuett +c October 19, 1987 +c----------------------------------------------------------------------- + include 'impli.inc' + include 'files.inc' +c +cryne 5/5/2006 declared slen an integer + integer num,slen +cryne 8/5/2004 character string*16 + character (LEN=*) :: string + logical lnum +c + character*10 digits +cryne data digits /'0123456789'/ +cryne save digits + digits='0123456789' +cryne 8/5/2004: + slen = LEN(string) +c----------------- +c The first char may be minus or digit +c write(jodf,*)'cnumb: string= ',string + if(index(digits,string(1:1)).eq.0 .and. string(1:1).ne.'-') then + lnum=.false. +c write(jodf,*)'first char is no digit' + return + endif +c All other characters must be digits... +cryne 8/5/2004 do 1 k=2,16 + do 1 k=2,slen + if(index(digits,string(k:k)).eq.0) then +c ...or trailing blanks +cryne 8/5/2004 if(string(k:16).ne.' ') then + if( string(k:k).ne.' ') then +c write(jodf,*)'string(',k,':16) is not blank' +c write(jodf,*)'string(',k,':slen) is not blank' + lnum=.false. + return + else + goto 11 + endif + endif + 1 continue +c string is a number + 11 read(string,*,err=999) num + lnum=.true. + return +c----------------- +c error exit + 999 write(jof ,99) string + write(jodf,99) string + 99 format(' ---> error in cnumb: string ',a16,' could not be', & + & ' converted to number') + call myexit + end +c +************************************************************************ +c + subroutine comwtm(j,jrep) +c----------------------------------------------------------------------- +c routine to combine the jth lump with the total map n times +c Written by J. Howard, Fall 1986 +c Modified by Alex Dragt, 15 June 1988, to save storage +c----------------------------------------------------------------------- + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' + include 'map.inc' + include 'core.inc' +c---------- +c start +c---------- +c make n positive in case lump has a negative repetition number + n=iabs(jrep) +c + do 100 i=1,n + call concat(th,tmh,thl(1,j),tmhl(1,1,j),th,tmh) + 100 continue + return + end +c +******************************************************************* +c + subroutine cqlate(icfile,norder,ntimes,nwrite,isend) +c +c----------------------------------------------------------------------- +c circulate ntimes times; print every nwrite +c +c input : icfile (integer) = filenumber for reading input rays +c norder (integer) = NOT USED +c ntimes (integer) = number of turns through actual line +c nwrite (integer) = modulo for writing coordinates to jfcf +c isend (integer) = 1 output only to jof +c = 2 output only to jodf +c = 3 both +c in common /files/: jfcf < 0 full precision coordinates +c > 0 standard format coordinates +c +c Written by Rob Ryne ca 1984 +c slightly changed by Petra Schuett (labels, if-then-else ...) +c October 30,1987 +c------------------------------------------------------------------------ + use parallel + use acceldata + use rays + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- + include 'talk.inc' + include 'files.inc' + include 'loop.inc' + include 'map.inc' + include 'deriv.inc' + include 'core.inc' + include 'nturn.inc' +c----------------------------------------------------------------------- +c local variables +c----------------------------------------------------------------------- + character*16 string(5),str,ubuf + logical ljof,ljodf +cryne: +cryne dimension zi(6),zf(6) this is defined in rays.inc +c----------------------------------------------------------------------- +c start routine +c----------------------------------------------------------------------- +c see if a loop exists + if(nloop.le.0) then + write(jof ,*) ' error from cqlate: no loop has been specified' + write(jodf,*) ' error from cqlate: no loop has been specified' + return + endif +c +c read initial conditions, if requested: +c if(icfile.gt.0) call raysin(icfile) + if(icfile.gt.0)then + scaleleni=0.d0 + scalefrqi=0.d0 + scalemomi=0.d0 + call raysin(icfile,scaleleni,scalefrqi,scalemomi,ubuf,jerror) + call rbcast(scaleleni) + call rbcast(scalefrqi) + call rbcast(scalemomi) + endif +c check for initial conditions: + if(nrays.eq.0)then + if(idproc.eq.0)then + write(6,*)'error(cqlate) : nrays=0' + write(6,*)'forgot to generate or read initial conditions?' + endif + call myexit + endif +c-------------------- +c write items in loop, if requested: + ljof = isend.eq.1 .or. isend.eq.3 + ljodf = isend.eq.2 .or. isend.eq.3 + if (ljof .or. ljodf) then +c write loop name + if(ljof ) write(jof ,510) ilbl(nloop) + if(ljodf) write(jodf,510) ilbl(nloop) + 510 format(1h ,'circulating through ',a16,' :') +c write loop contents + do 1 jtot=0,joy,5 + kmax=min(5,joy-jtot) + do 2 k=1,kmax + jk1=jtot+k +c element + if(mim(jk1).lt.0) then + string(k)=lmnlbl(-mim(jk1)) +c user supplied element + else if(mim(jk1).gt.5000) then + string(k)=lmnlbl(mim(jk1)-5000) +c lump + else + string(k)=ilbl(inuse(mim(jk1))) + endif + 2 continue + if(ljof) write(jof ,511)(string(k),k=1,kmax) + if(ljodf) write(jodf,511)(string(k),k=1,kmax) + 511 format(' ',5(1x,a16)) + 1 continue + endif +c-------------------- +c circulation procedure +c +c set up control indices + ibrief=0 + kwrite=nwrite + if(kwrite.eq.0)kwrite=1 +c-------------------- +c circulation through loop + do 1000 nturn=1,ntimes +c---------- +c handle each loop-element + do 100 kk=1,joy +c check to see if all particles lost +c Go at least one turn... + if(nturn.gt.1) then + if(nlost.ge.nraysp) then + write(jof,*) 'all particles lost on processor ',idproc + return + endif + endif +c +c check to see if item is a lump, user routine, or element + ip = mim(kk) + if(ip.gt.5000)then +c procedure for a user routine + nip=ip-5000 + if(nt2(nip).eq.1) call user1(pmenu(1+mpp(nip))) + if(nt2(nip).eq.2) call user2(pmenu(1+mpp(nip))) + if(nt2(nip).eq.3) call user3(pmenu(1+mpp(nip))) + if(nt2(nip).eq.4) call user4(pmenu(1+mpp(nip))) + if(nt2(nip).eq.5) call user5(pmenu(1+mpp(nip))) +c + else if(ip.lt.0) then +c procedure for turtling thru elements (which may be in lines): +cryne 08/15/2001 autoslicing does not apply when cirulating thru a loop +cryne note: this has not been tested as of 8/15/2001: + jslice=1 + nslices=1 + slfrac=1. +c ntrk=0 +c if(nspchset.eq.1)ntrk=1 +c----------------------------------------------------- +c call isthick(kt1,kt2,ithick,thlen,0) +c if(iautosl.lt.0.and.ithick.eq.1)nslices=pmenu(nrp(1,kt2)) +c if(iautosl.gt.0.and.ithick.eq.1)nslices=iautosl +c slfrac=1./nslices +c if(lautoap2.eq.1 .or. nspchset.eq.1)slfrac=slfrac*0.5d0 +c----------------------------------------------------- + narg1=1+mpp(-ip) + narg2=1+mppc(-ip) + call lmnt(nt1(-ip),nt2(-ip),pmenu(narg1),cmenu(narg2), & + & 1,jslice,nslices,slfrac,0) +c + else +c procedure for a lump + do 110 nn=1,nraysp +c check to see if particle has already been lost + if (istat(nn).eq.0) then + do 112 l=1,6 + 112 zi(l)=zblock(l,nn) +c call symplectic tracker + jwarn=0 + call evalsr_old(tmhl(1,1,ip),zi,zf,dfl(1,1,ip), & + & rdfl(1,1,ip),rrjacl(1,1,1,ip)) +c check to see if particle was 'lost' by the symplectic ray tracer + if (jwarn.ne.0) then + istat(nn)=nturn + nlost=nlost + 1 + ihist(1,nlost)=nturn + ihist(2,nlost)=nn + endif +c copy results of ray trace into storage array + do 114 l=1,6 + 114 zblock(l,nn)=zf(l) + endif + 110 continue + endif + 100 continue +c +c end of one turn +c---------- +c check to see if results should be written out + if(mod(nturn,kwrite).eq.0) then + do 200 m1=1,nraysp + if(istat(m1).eq.0) then +c procedure for writing out results of ray trace +c +c procedure for standard format + if(jfcf.gt.0) then + write(jfcf,520)(zblock(m2,m1),m2=1,6) + 520 format(6(1x,1pe12.5)) +c +c procedure for full precision + else if(jfcf.lt.0) then + do 525 m2=1,6 + write(-jfcf,*) zblock(m2,m1) + 525 continue + endif +c + endif + 200 continue + endif +c + 1000 continue +c end of loop thru turns +c----------------------------------------------------------------------- + return + end +c +*********************************************************************** +c + subroutine cread(kbeg,msegm,line,string,lfound) +c----------------------------------------------------------------------- +c This routine searches line(kbeg:) for the next string; strings are +c delimited by ' ','*' or ','. +c +c Input: line character*(*)input line +c kbeg integer line is only searched behind kbeg +c if a string is found, kbeg is set to +c possible start of next string +c msegm integer segment number. for msegm=1 (comment +c section), the length of a string is not +c checked. +c output:string character*(*)found string +c lfound logical =.true. if a string was found +c +c Written by Rob Ryne ca 1984 +c Rewritten by Petra Schuett +c October 19, 1987 +cryne +c Modified by Rob Ryne July 2002 to parse lines (with some exceptions) +c in the Standard Input Format +c Modified by David Serafini to allow lines longer than 80 chars +c----------------------------------------------------------------------- + include 'impli.inc' + include 'files.inc' +c + integer kbeg,msegm + character line*(*), string*(*) + logical lfound + integer llen,slen + + llen = LEN(line) + slen = LEN(string) +c +c look for first character of string +cryne 3/6/2004 but first check for *( +cryne 5/4/2006 but don't do this if in #comment + if(msegm.eq.1)goto 666 +cryne 5/4/2006 and only do this if the word 'line' appears: + if( index(line,'line').eq.0 ) goto 666 +c + do k=kbeg,llen-2 +cryne this version of the parser cannot handle lines defined as +cryne repeated quantities between parenthesese + if( line(k:k+1).eq.'*(' .or. + & line(k:k+2).eq.'* (' )then + write(6,*)'error in cread:' + write(6,*)'this version cannot parse a line of the form:' + write(6,*)'N*(...) or N* (...)' + call myexit + endif + enddo + 666 continue +c + do 1 k=kbeg,llen + if( (line(k:k).ne.' ') + & .and.(line(k:k).ne.'*') +cryne- + & .and.(line(k:k).ne.';') + & .and.(line(k:k).ne.':') + & .and.(line(k:k).ne.'=') + & .and.(line(k:k).ne.'(') + & .and.(line(k:k).ne.')') +cryne- + & .and.(line(k:k).ne.',')) then +c found: + lfound=.true. +c dont run off the end of either char variable + lmax = min(k+slen,llen) +c look for delimiter + do 2 l=k,lmax + if(( line(l:l).eq.' ') + & .or.(line(l:l).eq.'*') +cryne- + & .or.(line(l:l).eq.':') + & .or.(line(l:l).eq.';') + & .or.(line(l:l).eq.'=') + & .or.(line(l:l).eq.'(') + & .or.(line(l:l).eq.')') +cryne- + & .or.(line(l:l).eq.',')) then +c if found, string is known + string=line(k:l-1) + kbeg =l+1 +c done. + return + endif + 2 continue +c no delimiter behind string found... + string=line(k:lmax) +c ...end of line + if(lmax.eq.llen) then + kbeg=llen +c ...or string too long (ignored for comment section) + else if (msegm.ne.1) then + write(jof,99) kbeg + 99 format(' ---> warning from cread:'/, + & ' the following line has a very long string at ', + & 'position ',i2,' :') + write(jof,*) line + kbeg=lmax+1 + endif +c ...anyway, its done. + return + endif + 1 continue +c No string was found after all. + lfound=.false. + return + end +c +************************************************************************ + subroutine dump(iu) +c----------------------------------------------------------------------- +c this subroutine dumps the status of the common-blocks +c as they are filled by dumpin +c input: iu output-file +c +c written by Petra Schuett +c October 26, 1987 +c----------------------------------------------------------------------- + use beamdata + use acceldata + use lieaparam, only : monoms + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- + include 'codes.inc' + include 'files.inc' +c----------------------------------------------------------------------- +c start routine +c----------------------------------------------------------------------- +c comments + if(np.ne.0) then + write(iu,500) ling(1) + write(iu,*) (mline(i),i=1,npcom) + endif +c-------------------- +c beam + write(iu,500) ling(2) + write(iu,*) brho + write(iu,*) gamm1 + write(iu,*) achg + write(iu,*) sl +c-------------------- +c menu + write(iu,500) ling(3) + do 10 k=1,na + write(iu,520) lmnlbl(k),ltc(nt1(k),nt2(k)) + imax=nrp(nt1(k),nt2(k)) + if(imax.ne.0) then + write(iu,522)(pmenu(i+mpp(k)),i=1,imax) + endif + 10 continue +c-------------------- +c lines,lumps,loops + if(nb.ne.0) then + do 40 ii=2,4 + write(iu,500) ling(ii+2) + do 40 k=1,nb + if(ityp(k).eq.ii) then + write(iu,530) ilbl(k) + write(iu,532)(irep(l,k),icon(l,k),l=1,ilen(k)) + endif + 40 continue + endif +c-------------------- +c labor + if(noble.ne.0) then + write(iu,500) ling(7) + do 100 j=1,noble + write(iu,540) num(j),latt(j) + 100 continue + endif + return +c----------------------------------------------------------------------- +c format +c----------------------------------------------------------------------- + 500 format(1h ,a8) +! 510 format(1h ,a80) + 520 format(1h ,1x,a16,1x,a16) + 522 format((1h ,3(1x,1pg22.15))) + 530 format(1h ,1x,a8) + 532 format((1h ,1x,5(i5,'*',a8),1x,:'&')) + 540 format(1h ,1x,i4,'*',a8) + end +************************************************************************ + subroutine initst(string,nrept) +c----------------------------------------------------------------------- +c initialize stack, putting element 'string' with rep. factor nrept +c on top +c +c input: string character*(*) initial stack element (loop,line or lump!) +c nrept integer rep. factor +c +c Petra Schuett, October 30,1987 +c----------------------------------------------------------------------- + use acceldata + use lieaparam, only : monoms + use parallel, only : idproc + include 'impli.inc' +c-------- +c commons +c-------- + include 'stack.inc' + include 'files.inc' +c--------------- +c parameter type +c--------------- + character string*(*) +c------- +c start +c------- + np = 1 + lstac(1) = string + loop (1) = nrept + call lookup(string,ntype,ith) + if(ntype.eq.1 .or. ntype.eq.5) then + if(idproc.eq.0)write(jof,510) string + 510 format(' >>>>warning from initst: stack element',a ,' is an', & + & ' element or an unused label') + else + nslot(1) = newsl(1,ith) + call lookup(icon(nslot(np),ith),mtype,jth) + endif +c----------------------------------------------------------------------- + return + end +************************************************************************ +c + subroutine lmnt(nt1,nt2,prms,crms,ntrk,jslice,jsltot,slfrac,ihalf) +c----------------------------------------------------------------------- +c this routine actually switches to the routines that handle single +c elements, commands, etc. +c +c input: nt1 = group type code of element +c nt2 = index of element in its group +c prms = array of numerical (double) params for this element +c crms = array of character params for this element +c ntrk = 0 if accumulated transfer map is to be constructed +c = 1 if tracking +c Modified by Rob Ryne 08/15/2001 to handle sliced elements +c jslice=present slice number; jsltot=total number of slices, +c slfrac=fraction by which the element length is multiplied for slicing +c ihalf = 1 (first half) or 2 (second half) if a slice is split in half, +c as when performing space-charge kicks or "midapply" operations +c ihalf = 0 if slices are not split in half. +c +cryne: this routine should be cleaned up in order to (among other things) +c have some consistency regarding the units of angles. Most of the +c inconsistency is historical: MaryLie uses degrees in the argument lists +c for most (all?) bending magnet routines, but the arot is in radians. +c MAD uses radians for everything, but, rather than change the MaryLie +c routines, the normal MAD input is converted to degrees. +c +c Written by Rob Ryne ca 1984 +c modified by J. Howard 7-87 +c P. Schuett 11-87 +c A. Dragt 6/15/88 +c----------------------------------------------------------------------- + use beamdata + use acceldata, only : slicetype,sliceprecedence,slicevalue + use rays + use lieaparam, only : monoms + use spchdata + use e_gengrad + use multitrack + include 'impli.inc' +c-------- +c commons +c-------------------- + include 'map.inc' + include 'parset.inc' + include 'files.inc' + include 'codes.inc' + include 'pie.inc' + include 'infin.inc' + include 'zeroes.inc' + include 'frnt.inc' + include 'previous.inc' + include 'setref.inc' + include 'fitbuf.inc' + common/rfxtra/zedge,gaplen,thetastore + common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0 + common/poiblock1/nspchset,nsckick + common/gxyzsave/xmin0,xmax0,ymin0,ymax0,zmin0,zmax0,kfixbdy,madegr + integer idirectfieldcalc,idensityfunction,isolve + & ,anagpatchsize,anagrefratio,anagsmooth + common/newpoisson/idirectfieldcalc,idensityfunction,isolve + & ,anagpatchsize,anagrefratio,anagsmooth + character*256 chombofilename + common/chombochar/chombofilename + common/dirichlet/idirich + common/autotrk/lautotrk,ntrktype,ntrkorder + common/envstuff/nenvtrk + character*16 fname,fname1,fname2,fname3,fname4 + character*16 estrng,autostr,icname,fcname + character*5 anum + common/autopnt/autostr(3) + common/autolog/lautoap1,lautoap2,lautoap3,lrestrictauto + common/autocon/lautocon + common/showme/iverbose + real*8 mhprev + common/prevmap/hprev(monoms),mhprev(6,6) + common/bfileinfo/ifileinfo + common/xtrajunk/jticks1,iprinttimers +cryne + character*3 kynd +c-------------------------------- +c parameter types and dimensions +c-------------------------------- + integer nt1,nt2,ntrk + character*16 crms,cparams + character*5 aseq + dimension prms(*),crms(*) +c----------------- +c local variables +c----------------- +c maps + double precision h(monoms),ht1(monoms),ht2(monoms),ht3(monoms) + double precision mh(6,6),mht1(6,6),mht2(6,6),mht3(6,6) + double precision dreftraj(6) +c +c leading .. and trailing fringe field: lfrn (tfrn) .ne.0, if it is +c to be taken into account + integer lfrn,tfrn +c Input args nt1,nt2,prms must not be changed. work with kt1,kt2,p. +c dimension p(6),ptmp(6) + dimension p(60),ptmp(6) +cryne 7/13/2002 + dimension coefpset(6) +cryne 12 Nov 2003 added common/scparams/ + common/scparams/rparams(60),cparams(60) + equivalence (p1,p(1)),(p2,p(2)),(p3,p(3)),(p4,p(4)),(p5,p(5)), & + & (p6,p(6)) + data imsg1/0/ + save imsg1 + logical, save :: first_entry = .true. +cKMP: 8 Noc 2006 - added clinestrng + character*132 clinestrng +c----------------------------------------------------------------------- +c start +c---------------- + if(iverbose.eq.2.and.idproc.eq.0) & + &write(6,*)'inside LMNT with nt1,nt2=',nt1,nt2 +c write(6,*)'(LMNT) nt1,nt2,ntrk,jslice,jsltot,slfrac,ihalf=' +c write(6,*) nt1,nt2,ntrk,jslice,jsltot,slfrac,ihalf +c write(6,*)'reftraj(5),reftraj(6)=',reftraj(5),reftraj(6) +c----------------------------------------------------------------------- + multitrac=0 !cryne May 21, 2006 +c +c first-entry initializations +c + if (first_entry) then + first_entry = .false. + nullify(eggrdata%zvals) + nullify(eggrdata%G1c); nullify(eggrdata%G1s) + nullify(eggrdata%G2c); nullify(eggrdata%G2s) + nullify(eggrdata%G3c); nullify(eggrdata%G3s) + endif +c +c Preliminary procedure for random elements or commands +c + if(nt1.eq.4 .or. nt1.eq.5 .or. nt1.eq.6) then + nfile = nint(prms(1)) + iecho = nint(prms(2)) + kt1 = nt1 - 3 + kt2 = nt2 + call randin(nfile,kt1,kt2,p) +c +c Echo back if requested + if( iecho.eq.1 .or. iecho.eq.3) then + write(jof, 7005) nfile,kt1,kt2 + write(jof ,*)(p(i),i=1,nrp(kt1,kt2)) + endif + if( iecho.eq.2 .or. iecho.eq.3) then + write(jodf,7005) nfile,kt1,kt2 + write(jodf,*)(p(i),i=1,nrp(kt1,kt2)) + endif + 7005 format(' random lmnt check:nfile,kt1,kt2=',3i5/ + & ' parameters found:') +c +c + else +c +c Preliminary procedure for all other type codes +c +c + kt1 = nt1 + kt2 = nt2 + nparams=nrp(nt1,nt2) + ncparams=ncp(nt1,nt2) +c write(6,*)'nparams=',nparams + if(nparams.gt.0)then + p(1:nparams)=prms(1:nparams) + endif + endif +c +c Select appropriate action depending on value of kt1,kt2 +c + go to (11,12,13,14,15,16,17,18,19), kt1 +c +c 1: simple elements ************************************* +c +11 continue +c 'drft ','nbnd ','pbnd ','gbnd ','prot ', + go to(101, 102, 103, 104, 105, +c 'gbdy ','frng ','cfbd ','quad ','sext ', + & 106, 107, 108, 109, 110, +c 'octm ','octe ','srfc ','arot ','twsm ', + & 111, 112, 113, 114, 115, +c 'thlm ','cplm ','cfqd ','dism ','sol ', + & 116, 117, 118, 119, 120, +c 'mark ','jmap ','dp ','recm ','spce ', + & 121, 122, 123, 124, 125, +c 'cfrn ','coil ','intg ','rmap ','arc ', + & 126, 127, 128, 129, 130, +c 'rfgap ','confoc ','transit','interface','rootmap', + & 1135, 1136, 133, 134, 135, +c 'spare4 ','spare5 ','spare6 ','spare7 ','spare8 ', + & 136, 137, 138, 139, 140, +c 'marker ','drift ','rbend ','sbend ','gbend ', + & 141, 142, 143, 1045, 145, +c 'quadrupo','sextupol','octupole','multipol','solenoid', + & 146, 147, 148, 149, 150, +c 'hkicker ','vkicker ','kicker ','rfcavity','elsepara', + & 151, 152, 153, 154, 155, +c 'hmonitor','vmonitor','monitor ','instrume','sparem1 ', + & 156, 157, 158, 159, 160, +c 'rcollima','ecollima','yrot ','srot ','prot3 ', + & 161, 162, 163, 164, 165, +c 'beambeam','matrix ','profile1d','yprofile','tprofile', + & 166, 167, 168, 169, 170, +c 'hkick ','vkick ','kick ','hpm ','nlrf '/ + & 171, 172, 173, 174, 175),kt2 +c +c 'drft ': drift +c +101 continue + if(slfrac.ne.1.0)p1=p1*slfrac +c write(6,*)'DRFT:jslice,jsltot,slfrac=',jslice,jsltot,slfrac + call drift3(p1,h,mh) +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 +c note: under the assumption that omega*sl/c=1, it follows that omega=c/sl +c therefore, multiplying by c/sl is the correct thing to do +c to make reftraj(5) dimensionless under this assumption. + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +c +c 'nbnd ': normal entry bend +c the map for this element is of the form +c gfrngg*nbend*gfrngg with the leading and trailing fringe field +c maps optional +c +102 continue +c angdeg=p1 + gap=p2 + xk1=p3 + rho=brho/p4 + lfrn=nint(p5) + tfrn=nint(p6) +c compute nbend + if(slfrac.ne.1.0)p1=p1*slfrac + call nbend(rho,p1,h,mh) +c put on leading fringe field +cryne + azero=0. + if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then + if(lfrn.ne.0)then +cryne call gfrngg(0.d0,rho,1,ht1,mht1,gap,xk1) + call gfrngg(azero,rho,1,ht1,mht1,gap,xk1) + call concat(ht1,mht1,h,mh,h,mh) + endif + endif +c put on trailing fringe field + if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then + if(tfrn.ne.0)then +cryne call gfrngg(0.d0,rho,2,ht1,mht1,gap,xk1) + call gfrngg(azero,rho,2,ht1,mht1,gap,xk1) + call concat(h,mh,ht1,mht1,h,mh) + endif + endif +c============== + call set_pscale_mc(h,mh) + arclen=arclen+rho*p1*(pi/180.) + refprev=reftraj + reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) + prevlen=rho*p1*(pi/180.) + nt2prev=nt2 + rhoprev=rho +c============== + goto 2000 +c +c 'pbnd ': +c parallel faced bend, including leading and trailing +c pole face rotations and fringe fields. +c Symmetric bends only are permitted under this option. +c For parallel-faced magnet with asymmetric entry and exit, +c use the general bending magnet. +c The map for the parallel faced bend is of the form +c prot*gfrng*pbend*gfrng*prot +c +103 continue + psideg=p1/2.d0 + gap=p2 + xk1=p3 + rho=brho/p4 +c +cryne Jan 5, 2005 if(jsltot.eq.1)then + if(jsltot.eq.1 .and. ihalf.eq.0)then +c procedure for a complete pbnd (no slices): [Jan 5, 2005 and not split in half] +c +cryne 3/17/2004 +c but it still could be cut in half due to space charge or autoapply. So... +cryne Jan 5, 2005 if(slfrac.ne.1.0)p1=p1*slfrac +c + call pbend(rho,p1,h,mh) +c put on the leading fringe field + call gfrngg(psideg,rho,1,ht1,mht1,gap,xk1) + call concat(ht1,mht1,h,mh,h,mh) +c put on leading prot + call prot(psideg,1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c put on trailing fringe field + call gfrngg(psideg,rho,2,ht1,mht1,gap,xk1) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing prot + call prot(psideg,2,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + else +c +c procedure for a pbnd in slices. +c This follows the approach due to Dragt that is described +c in Exhibit 6.6.3 and section 10.9 of the MaryLie manual. + if(slfrac.ne.1.0)p1=p1*slfrac + azero=0. + call nbend(rho,p1,h,mh) + if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then +c put on the leading gbody + call gbend(rho,azero,psideg,azero,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c put on the leading fringe field + call gfrngg(psideg,rho,1,ht1,mht1,gap,xk1) + call concat(ht1,mht1,h,mh,h,mh) +c put on leading prot + call prot(psideg,1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) + endif + if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then +c put on trailing gbody + call gbend(rho,azero,azero,psideg,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing fringe field + call gfrngg(psideg,rho,2,ht1,mht1,gap,xk1) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing prot + call prot(psideg,2,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + endif + endif +c============== +cryne 08/15/2001 + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+rho*p1*(pi/180.) + reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) + prevlen=rho*p1*(pi/180.) + nt2prev=nt2 + rhoprev=rho +c============== + goto 2000 +c +c 'gbnd ': general bending magnet +c +c The map for the general bend is of the form +c prot*gfrng*gbend*gfrng*prot +c +104 continue + if(jsltot.ne.1)then + write(6,*)'error: gbnd not yet available with slices!' + stop + endif + gap=p4 + xk1=p5 + if(p6.eq.0.d0)then + write(6,*)'Error (gbnd): B field equal zero not allowed' + stop + endif + rho=brho/p6 +c compute gbend + call gbend(rho,p1,p2,p3,h,mh) +c +c put on the leading fringe field + call gfrngg(p2,rho,1,ht1,mht1,gap,xk1) + call concat(ht1,mht1,h,mh,h,mh) +c put on leading prot + call prot(p2,1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c put on trailing fringe field + call gfrngg(p3,rho,2,ht1,mht1,gap,xk1) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing prot + call prot(p3,2,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+rho*p1*(pi/180.) + reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) + prevlen=rho*p1*(pi/180.) + nt2prev=nt2 + rhoprev=rho +c============== + goto 2000 +c +c 'sbend ': MAD sector bend +c similar to MaryLie cfbd, but with arbitrary entrance/exit angles +c +c The map for this element is treated as the following: +c prot*cgfrngg*cgbend*cgfrngg*prot +c where: +c prot is a pole face rotation +c cgfrngg is a fringe field (analgous to that used in cfbd) +c cgbend is a gbend but w/ multipole coefficients +c note that, in analogy with the fact that gbend=hpf1*nbend*hpf2, +c in this case we set cgbend=hpf1*(cfbd w/ no fringe fields)*hpf2, +c i.e. cgbend=hpf1*cfbend*hpf2 +c +1045 continue + bndang=p1 + rho=brho/p2 + psideg=p(3) + phideg=p(4) + lfrn=nint(p5) + tfrn=nint(p6) + gap1=prms(7) + gap2=prms(8) + fint1=prms(9) + fint2=prms(10) + iopt=nint(prms(11)) + ipset=nint(prms(12)) +c + do j=1,6 + coefpset(j)=0.d0 + enddo + if( (ipset.gt.0).and.(ipset.le.maxpst))then + do j=1,6 + coefpset(j)=pst(j,ipset) +c write(6,*)j,coefpset(j) + enddo + else +c write(6,*)'In lmnt at sbend; j,coefpset(j)=' + do j=1,6 + if(prms(j+12).ne.0.d0)coefpset(j)=prms(j+12) +c write(6,*)j,coefpset(j) + enddo + endif +c + tiltang=prms(19) + if(tiltang.ne.0. .and. idproc.eq.0)then + write(6,*)'WARNING(sbend): tilt keyword being tested' + endif + myorder=nint(prms(20)) + if(idproc.eq.0)then + if(myorder.ne.5)write(6,*)'(sbend) order = ',myorder + endif + azero=0.d0 +c---------------- +c compute gbend +c call cgbend(rho,bndang,psideg,phideg,iopt,coefpset,h,mh) + aldeg=bndang-psideg-phideg + ptmp(1)=aldeg+psideg+phideg ! = bndang + if(slfrac.ne.1.0)ptmp(1)=ptmp(1)*slfrac + ptmp(2)=brho/rho + ptmp(3)=0. + ptmp(4)=0. + ptmp(5)=iopt +cryne 1 August 2004 ptmp(6)=0. !not used + ptmp(6)=myorder +c +c ptmp(1)=psideg +c call cfbend(ptmp,coefpset,ht2,mht2) +c ptmp(1)=aldeg +c call cfbend(ptmp,coefpset,ht3,mht3) +c call concat(ht2,mht2,ht3,mht3,ht3,mht3) +c ptmp(1)=phideg +c call cfbend(ptmp,coefpset,ht2,mht2) +c call concat(ht2,mht2,ht3,mht3,ht3,mht3) +c if(idproc.eq.0)then +c write(6,*)'call cfbend:aldeg,slfrac,ptmp(1)=',aldeg,slfrac,ptmp(1) +c endif +c*** +cryne 12/22/2004 mods per Marco Venturini bypass the slow cfbend routines +c if there are no multipole coefficients (note that, at the moment, the +c cfbend routine is only third order) + scpset=0.d0 + do ii=1,6 + scpset=scpset+coefpset(ii) + enddo + if(scpset.eq.0.d0)then ! use nbend if field is pure dipole + slang=bndang + if(slfrac.ne.1.0)slang=slang*slfrac + call nbend(rho,slang,h,mh) + else + call cfbend(ptmp,coefpset,h,mh) + endif +c*** +c---------------- +c + if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then +c put on the leading gbend + call gbend(rho,azero,psideg,azero,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c put on the leading fringe field + call cgfrngg(1,psideg,rho,lfrn,gap1,fint1,iopt,coefpset,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c put on leading prot + call prot(psideg,1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c put on leading arot + call arot(tiltang,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) + endif +c + if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then +c put on the trailing gbend + call gbend(rho,azero,azero,phideg,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing fringe field + call cgfrngg(2,phideg,rho,tfrn,gap2,fint2,iopt,coefpset,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing prot + call prot(phideg,2,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing arot + tiltang=-tiltang + call arot(tiltang,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + endif +c============== +cryne*** 3/16/2004 + if(slfrac.ne.1.0)p1=p1*slfrac +cryne*** + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+rho*p1*(pi/180.) + reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) + prevlen=rho*p1*(pi/180.) + nt2prev=nt2 + rhoprev=rho +c============== + goto 2000 +c +c +c 'prot ': rotation of reference plane +c +105 continue +cryne Aug 5, 2003: now this is the 5th order version: + ijkind=nint(p2) + call prot(p1,ijkind,h,mh) + goto 2000 +cryne 9/25/2007 return +c +c 'gbdy ': body of a general bending magnet +c +106 continue + rho=brho/p4 + call gbend(rho,p1,p2,p3,h,mh) +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+rho*p1*(pi/180.) + reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) + prevlen=rho*p1*(pi/180.) + nt2prev=nt2 + rhoprev=rho +c============== + goto 2000 +c +c 'frng ': hard edge dipole fringe fields +c +107 continue + rho=brho/p4 + iedge=nint(p5) + gap = p2 + xk1 = p3 + call gfrngg(p1,rho,iedge,h,mh,gap,xk1) + goto 2000 +c +c 'cfbdy ': body of a combined function bending magnet +c +1075 continue + write(6,*)'cfbdy not implemented' + return +c +c 'cfbd ': combined function bend (normal entry and exit) +c +c The map for the combined function bend is of the form +c [(arot*frquad*arotinv)frquad*gfrngg]* +c cfbend* +c [gfrngg*frquad*(arot*frquad*arotinv)] +c with the leading and trailing fringe fields optional. +c The gap size cfbgap and normalized leading and trailing +c field integrals cfblk1 and cfbtk1 for the dipole +c are taken from the table in block common frnt. +c These entries are initialized to 0, .5, .5, respectively +c at the beginning of a Marylie run, and can be changed using +c the type code cfrn. +c The factors of the form (arot*frquad*arotinv) give skew +c quad fringe fields. +c +108 continue + if(jsltot.ne.1)then + write(6,*)'error: cfbd not yet available with slices!' + stop + endif + rho=brho/p2 + lfrn=nint(p3) + tfrn=nint(p4) + ijopt=nint(p5) + iopt=mod(ijopt,10) +c write(6,*) 'iopt=',iopt + if ((iopt.lt.1) .or. (iopt.gt.3)) then + write(jof,*) 'WARNING: parameter iopt outside allowed range in', & + & ' element with type code cfbd' + endif + ipset=nint(p6) + do j=1,6 + coefpset(j)=0.d0 + enddo + if( (ipset.gt.0).and.(ipset.le.maxpst))then + do j=1,6 + coefpset(j)=pst(j,ipset) + enddo + endif +c compute cfbend + call cfbend(p,coefpset,h,mh) +c put on leading dipole and quad fringe fields + if(lfrn.ne.0) then +c compute and put on leading dipole fringe field + gap=cfbgap + xk1=cfblk1 + call gfrngg(0.d0,rho,1,ht1,mht1,gap,xk1) +c call nfrng(rho,1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c compute and put on leading quad fringe fields + if((ipset.gt.0) .and. (ipset.le.maxpst)) then + if(iopt.eq.1) then + bqd=coefpset(1) + aqd=coefpset(2) + endif + if(iopt.eq.2) then + bqd=coefpset(1) + aqd=coefpset(2) + endif + if(iopt.eq.3) then + bqd=brho*coefpset(1) + aqd=brho*coefpset(2) + endif +c compute and put on normal quad fringe field + call frquad(bqd,-1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c compute and put on skew quad fringe field + angr=-pi/4.d0 + call arot(angr,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) + call frquad(aqd,-1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) + angr=-angr + call arot(angr,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) + endif + endif +c put on trailing dipole and quad fringe fields + if(tfrn.ne.0) then +c compute and put on trailing dipole fringe field + gap=cfbgap + xk1=cfbtk1 + call gfrngg(0.d0,rho,2,ht1,mht1,gap,xk1) +cryne 7/11/2002 call gfrngg(0.d0,rho,1,ht1,mht1,gap,xk1) + write(6,*)'7/11/2002 fixed 2nd call to gfrngg for cfbd. RDR' +c call nfrng(rho,2,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c compute and put on trailing quad fringe fields + if((ipset.gt.0) .and. (ipset.le.maxpst)) then + if(iopt.eq.1) then + bqd=coefpset(1) + aqd=coefpset(2) + endif + if(iopt.eq.2) then + bqd=coefpset(1) + aqd=coefpset(2) + endif + if(iopt.eq.3) then + bqd=brho*coefpset(1) + aqd=brho*coefpset(2) + endif +c compute and put on normal quad fringe field + call frquad(bqd,1,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c compute and put on skew quad fringe field + angr=pi/4.d0 + call arot(angr,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + call frquad(aqd,1,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + angr=-angr + call arot(angr,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + endif + endif +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+rho*p1*(pi/180.) + reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) + prevlen=rho*p1*(pi/180.) + nt2prev=nt2 + rhoprev=rho +c============== + goto 2000 +c +c 'quad ': quadrupole +c +c the map for this element is of the form +c frquad*quad*frquad +c with the leading and trailing fringe field maps optional +c +109 continue +c write(6,*)'QUAD:jslice,jsltot,slfrac=',jslice,jsltot,slfrac + lfrn=nint(p3) + tfrn=nint(p4) + if(slfrac.ne.1.0)p1=p1*slfrac +c compute the map for the quad + if(p2.lt.0.d0) call dquad3(p1,-p2,h,mh) + if(p2.eq.0.d0) call drift3(p1,h,mh) + if(p2.gt.0.d0) call fquad3(p1,p2,h,mh) +c put on leading fringe field + if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then + if(lfrn.ne.0)then + call frquad(p2,-1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) + endif + endif +c put on trailing fringe field + if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then + if(tfrn.ne.0)then + call frquad(p2,1,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + endif + endif +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +c +c 'sext ': sextupole +c +110 continue + if(slfrac.ne.1.0)p1=p1*slfrac + call sext3(p1,p2,h,mh) +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +c +c 'octm ': mag. octupole +c +111 continue + if(slfrac.ne.1.0)p1=p1*slfrac + call octm3(p1,p2,h,mh) +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +c +c 'octe ': elec. octupole +c +112 continue + if(jsltot.ne.1)then + write(6,*)'error: octe not yet available with slices!' + stop + endif + call octe(p1,p2,h,mh) + goto 2000 +c +c 'srfc ': short rf cavity +c +113 omega=twopi*p2 + call srfc(p1,omega,h,mh) + goto 2000 +c +c 'rfgap ': rf gap +c +1135 continue +c write(6,*)'RFGAP:jslice,jsltot,slfrac=',jslice,jsltot,slfrac +c---------------------------------------------- + if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then + nseq=prms(5) + if(nseq.eq.0 .and. crms(1).eq.' ')then + if(idproc.eq.0)write(6,*)'ERROR(RFGAP):no data file specified' + call myexit + endif + if(crms(1).eq.' ')then + fname1='rfdata' + ndigits=nseq/10+1 + call num2string(nseq,aseq,ndigits) + j=len_trim(fname1) + fname=fname1(1:j)//aseq(1:ndigits) + else + fname=crms(1) + endif + nunit=0 + estrng='rfgap' + call fnamechk(fname,nunit,ierr,estrng) + if(ierr.eq.1)then + write(6,*)'(rfgap)leaving lmnt due to problem w/ fname' + return + endif + call read_RFdata(nunit,numdata,gaplen) +c Set zedge, which defines where the field is located in space: + zedge=arclen +cryne 5/2/2006: +c determine theta for this cavity now, while jslice=1 + if(prms(7).eq.0.d0)then + thetastore=p(4)*asin(1.0d0)/90. + if(idproc.eq.0)then + write(6,*)'found rfgap absolute phase (deg) =',prms(4) + write(6,*)'found rfgap absolute phase (rad) =',thetastore + endif + else + thetastore=prms(7)*asin(1.0d0)/90.d0 - reftraj(5) + if(idproc.eq.0)then + write(6,*)'found rfgap phase entrance argument (deg) =',prms(7) + write(6,*)'=',prms(7)*asin(1.0d0)/90.d0,' rad' + write(6,*)'computed rfgap absolute phase (rad)=',thetastore + write(6,*)'=',thetastore*90./asin(1.0d0),' deg' + endif + endif + endif +c---------------------------------------------- +cryne 8/12/2001 did this in trlmnt zedge=arclen +cryne 8/12/2001 zmap=p(1) +cryne 8/12/2001 also added the following 2 lines: + zedgg=zedge + if(p1.le.0)zmap=gaplen*slfrac + if(p1.gt.0)then + if(p1.lt.gaplen)zmap=p1*slfrac + if(p1.gt.gaplen)write(6,*)'error:integration length > gap length' + if(p1.gt.gaplen)stop + endif + rffreq=p(2)*4.0*asin(1.0d0) + escale=p(3) +cryne 5/2/2006 theta0=p(4)*asin(1.0d0)/90. + theta0=thetastore + itfile=nint(p(5)) + nstep=nint(p(6)) +cryne 8/11/2001 itype not used for now + itype=0 +cryne-abell Mon Nov 24 18:23:05 PST 2003 + if(lflagmagu)then + if(idproc.eq.0)then + write(6,*)'ERROR: The code is being run with static units, but' + write(6,*)'an rf cavity has been encountered. Simulations that' + write(6,*)'include rf cavities must utilize dynamic units.' + write(6,*)'Re-run using dynamic units.' + endif + call myexit + endif +cryne 5/1/2006 useful constants: + gscal=-omegascl*sl*p0sc/pmass + tscal= omegascl*sl/c +cryne 5/1/2006 for future mods, save reference phase and energy at entry: + refentry5=reftraj(5) !common block variable used in trac + refentry6=reftraj(6) !common block variable used in trac +cryne========================== +cryne 5/5/2006 new code for rfgap multiple reference trajectories + multitrac=0 + imap5=prms(9) + jmap6=prms(10) + if(imap5.ne.1 .or. jmap6.ne.1)multitrac=1 !flag for multitrack + if(multitrac.eq.1)then + call multirfsetup(imap5,jmap6) + do i=1,imap5 + do j=1,jmap6 + t00=tlistin(i) + gam00=ptlistin(j)*gscal + sltemp=sl + sl=c/omegascl + call rfgap(zedgg,zmap,nstep,rffreq,escale,theta0,t00,gam00, & + & itype,h,mh) + sl=sltemp +c Ensure rf cavity map is in correct units for ML/I. Then store it. + call set_rfscale(h,mh) + tmhlist(1:6,1:6,i,j)=mh(1:6,1:6) + hlist(1:923,i,j)=h(1:923) ! h irrelevant for rfgap (rfgap is linear) +c Store the final values of t and pt: + tlistfin(i,j)=t00 + ptlistfin(i,j)=gam00/gscal + enddo + enddo + endif +cryne========================== +c If multiple maps are being used, that have now all been computed. +c But, regardless, ML/I needs to compute the evolution of the reference traj: +c +cryne 5/1/2006 rfgap code was originally written assuming omegascl*sl/c=1. +c This is not necessarily the case for ML/I. +c Temporarily set sl to satisfy this, then reset upon return. + t00=refentry5 + gam00=refentry6*gscal + sltemp=sl + sl=c/omegascl + call rfgap(zedgg,zmap,nstep,rffreq,escale,theta0,t00,gam00,itype, & + &h,mh) + sl=sltemp +c-- +cryne 5/1/2006 moved these from rfgap.f ; The philosophy is that rfgap does not +c make global changes, it just computes a map and the ref traj + gamma=gam00 + gamm1=gamma-1.0 + beta=sqrt((gamma+1.0)*(gamma-1.0))/gamma + brho=pmass*gamma*beta/c +c-- + call set_rfscale(h,mh) + refprev=reftraj + reftraj(5)=t00 + reftraj(6)=gam00/gscal + arclen=arclen+zmap + prevlen=zmap + nt2prev=nt2 + goto 2000 +c +c 'confoc ': "constant focusing" element rdr 08/29/2001 +c +1136 continue +c p1 is the length, p2,p3,p4 are the 3 focusing constants +c if(idproc.eq.0)write(6,*)'at confoc with slfrac=',slfrac + if(slfrac.ne.1.0)p1=p1*slfrac + call confoc(p1,p2,p3,p4,h,mh) +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +cryne 5/1/2006 reftraj(5)=reftraj(5)+p1 +c============== + goto 2000 +c +c 'arot ': axial rotation +c +114 p1rad=pi180*p1 + call arot(p1rad,h,mh) + goto 2000 +c +c 'twsm ': linear matrix via twiss parameters +c +115 iplane=nint(p1) + call twsm(iplane,p2,p3,p4,h,mh) + goto 2000 +c +c 'thlm ': thin lens low order multipole +c +116 continue + call thnl(p1,p2,p3,p4,p5,p6,h,mh) + goto 2000 +c +c 'cplm ': "compressed" low order multipole +c +117 call cplm (p,h,mh) +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +c +c 'cfqd ': combined function quadrupole +c +118 continue + if(jsltot.ne.1)then + write(6,*)'error: cfqd not yet available with slices!' + stop + endif +c call cfdrvr(p,h,mh) +c replaced cfdrvr with cfqd in new (this) afro. rdr and ctm 5/22/02 +c***** + call cfqd(p,h,mh) +c quad fringe fields: + eangle=0.d0 !not needed + rho=1.d0 !not needed + gap=0.d0 !not needed + fint=0.d0 !not needed + iopt=1 !standard MaryLie interpretation of multipole coeffs + kfrn=2 !no dipole fringe fields (1=dipole, 2=quad, 3=both) + ipset=nint(p(2)) + coefpset(1:6)=pst(1:6,ipset) +c leading fringe: + ilfrn=nint(p(3)) + if(ilfrn.ne.0)then +c if(idproc.eq.0)write(6,*)'adding leading fringe to cfqd' + iw=1 + call cgfrngg(iw,eangle,rho,kfrn,gap,fint,iopt,coefpset,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) + endif +c trailing fringe: + itfrn=nint(p(4)) + if(itfrn.ne.0)then +c if(idproc.eq.0)write(6,*)'adding trailing fringe to cfqd' + iw=2 + call cgfrngg(iw,eangle,rho,kfrn,gap,fint,iopt,coefpset,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + endif +c***** +c +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +c +c dispersion matrix (dism) +c +119 call dism(p,h,mh) + go to 2000 +c +c 'sol ': solenoid +c +120 continue + write(6,*) ' == afro::lmnt::sol ==' + write(6,*) ' jslice=',jslice + write(6,*) ' jsltot=',jsltot + write(6,*) ' slfrac=',slfrac + if(jsltot.ne.1)then + write(6,*)'error: sol not yet available with slices!' + stop + endif + call gensol(p,h,mh,jslice,jsltot,slfrac) +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p2-p1 + prevlen=p2-p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+(p2-p1)/(beta*c)*(omegascl) +c============== + go to 2000 +c +c 'mark ': MaryLie marker +c +121 continue + return +c +c 'jmap ': j mapping +c +122 call jmap(h,mh) + go to 2000 +c +c 'dp ': data point +c +123 continue + return +c +c REC multiplet (recm) +c +124 continue + if(jsltot.ne.1)then + write(6,*)'error: recm not yet available with slices!' + stop + endif + call gnrec3(p,h,mh) + go to 2000 +c +c 'spce ': space +c +125 continue + return +c +c 'cfrn ': change or write out fringe field parameters +c for combined function dipole +c +126 continue + mode=nint(p1) + if (mode .eq. 0) then +c change fringe field parameters + cfbgap=p2 + cfblk1=p3 + cfbtk1=p4 + return + endif +c write out values of fringe field parameters + isend=mode + if( isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) + & 'values of fringe field parameters gap, ennfi, exnfi are:' + write(jof,*) cfbgap,cfblk1,cfbtk1 + endif + if( isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) + & 'values of fringe field parameters gap, ennfi, exnfi are:' + write(jodf,*) cfbgap,cfblk1,cfbtk1 + endif + return +c +c 'coil' +c +127 continue + if(jsltot.ne.1)then + write(6,*)'error: coil not yet available with slices!' + stop + endif + call coil(prms) + return +c +c 'intg' +c +128 continue + if(jsltot.ne.1)then + write(6,*)'error: intg not yet available with slices!' + stop + endif + call integ(p,h,mh) + go to 2000 +c +c 'rmap' +c +129 continue + call rmap(p,h,mh) + go to 2000 +c +c 'arc' +c +130 continue + write(6,*)'(lmnt) arc: not implemented' + return +c +c 'transit' +133 continue + write(6,*)'(lmnt) transit' + write(6,*)'p1,p2=',p1,p2 + if(slfrac.ne.1.0)p1=p1*slfrac + call transit(p1,p2,h,mh) + arclen=arclen+p1 + goto 2000 +c 'interface' +134 continue + write(6,*)'(lmnt) interface' + write(6,*)'p1,p2,p3,p4,p5=',p1,p2,p3,p4,p5 + call interface(p1,p2,p3,p4,p5,h,mh) + goto 2000 +c 'rootmap' +135 continue + write(6,*)'(lmnt) rootmap' + write(6,*)'p1,p2,p3,p4=',p1,p2,p3,p4 + write(6,*)'crms(1)=',crms(1) + call rootmap(p1,p2,p3,p4,h,mh) + if(crms(1).eq.'true')then + write(6,*)'computing inverse of rootmap' + call inv(h,mh) + endif + goto 2000 +c +c 'optiprot ': rotation of reference plane for optics calculations +136 continue + write(6,*)'(lmnt) optirot' + ijkind=nint(p2) + call optirot(p1,ijkind,h,mh) + goto 2000 +c +c 'spare5' +137 continue + write(6,*)'(lmnt) spare5' + return +c 'spare6' +138 continue + write(6,*)'(lmnt) spare6' + return +c 'spare7' +139 continue + write(6,*)'(lmnt) spare7' + return +c 'spare8' +140 continue + write(6,*)'(lmnt) spare8' + return +c +c +141 continue +c 'marker': MAD marker + write(6,*)'MAD marker not implemented' + return +c +142 continue +c 'drift': MAD drift + if(slfrac.ne.1.0)p1=p1*slfrac +c write(6,*)'DRIFT:jslice,jsltot,slfrac=',jslice,jsltot,slfrac + isssflag=nint(p2) + if(isssflag.eq.1)then + call drift(p1,h,mh) + else + call drift3(p1,h,mh) + endif + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) + goto 2000 +c +143 continue +c 'rbend': MAD rectangular bend +c write(6,*)'computing a MAD rbend' +c write(6,*)'computing a MAD rbend; jslice,jsltot=',jslice,jsltot +c based on a MaryLie gbnd: +c if(jsltot.ne.1 .and. idproc.eq.0)then +c write(6,*)'WARNING: rbend slices being tested' +c endif + if(p2.eq.0.d0)then + write(6,*)'Error (gbnd): B field equal zero not allowed' + stop + endif + rho=brho/p2 +! +cryne Jan 3, 2005 +c p3 and p4 and the pole face rotation angles in MAD notation, e1 and e2: + e1=p(3) + e2=p(4) +cryne Jan 3, 2005 +c The arguments to gbend, gfrngg, and prot are angles between the +c pole face and the reference trajectory , *not* angles between the +c pole face and reference plane (vertical line for rbends, radial line +c for sbends). The latter is the convention used in MAD. +c These angles need to be checked!!! At this point the RBEND +c implemented here is highly dubious!!! + bndang=p1 + psideg=0.5d0*bndang+e1 + phideg=0.5d0*bndang+e2 + if( abs(psideg-phideg).gt.1.d-6 )then + write(6,*)'ERROR (RBEND): The present RBEND impelmentation' + write(6,*)'requires equal entry and exit angles.' + call myexit + endif +c + lfrn=nint(p5) + tfrn=nint(p6) + gap1=prms(7) + gap2=prms(8) + fint1=prms(9) + fint2=prms(10) + tiltang=prms(11) + if(tiltang.ne.0. .and. idproc.eq.0)then + write(6,*)'WARNING(rbend): tilt keyword being tested' + endif +c*********************************************************** +c*********************************************************** + if(jsltot.eq.1 .and. ihalf.eq.0)then +c procedure for a complete pbnd (no slices, no splitting) + call pbend(rho,p1,h,mh) +c put on the leading fringe field + call gfrngg(psideg,rho,1,ht1,mht1,gap1,fint1) + call concat(ht1,mht1,h,mh,h,mh) +c put on leading prot + call prot(psideg,1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c put on leading arot + call arot(tiltang,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c put on trailing fringe field + call gfrngg(psideg,rho,2,ht1,mht1,gap2,fint2) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing prot + call prot(psideg,2,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing arot + tiltang=-tiltang + call arot(tiltang,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + else +c +c procedure for a sliced and/or split pbnd +c This follows the approach due to Dragt that is described +c in Exhibit 6.6.3 and section 10.9 of the MaryLie manual. + if(slfrac.ne.1.0)p1=p1*slfrac + azero=0. + call nbend(rho,p1,h,mh) + if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then +c put on the leading gbody + call gbend(rho,azero,psideg,azero,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c put on the leading fringe field + call gfrngg(psideg,rho,1,ht1,mht1,gap1,fint1) + call concat(ht1,mht1,h,mh,h,mh) +c put on leading prot + call prot(psideg,1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c put on leading arot + call arot(tiltang,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) + endif + if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then +c put on trailing gbody + call gbend(rho,azero,azero,psideg,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing fringe field + call gfrngg(psideg,rho,2,ht1,mht1,gap2,fint2) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing prot + call prot(psideg,2,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c put on trailing arot + tiltang=-tiltang + call arot(tiltang,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + endif + endif +c*********************************************************** +c*********************************************************** +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+rho*p1*(pi/180.) + reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) + prevlen=rho*p1*(pi/180.) + nt2prev=nt2 + rhoprev=rho +c============== + goto 2000 +c +145 continue +c 'gbend ': MAD general bend + write(6,*)'MAD gbend not implemented' + return +c +146 continue +c 'quadrupo': MAD quadrupole +c 7/14/2002: need to modify 'quadrupo' to handle tilt +c write(6,*)'QUADRUPOLE:jslice,jsltot,slfrac=',jslice,jsltot,slfrac + lfrn=nint(p3) + tfrn=nint(p4) + if(slfrac.ne.1.0)p1=p1*slfrac +c compute the map for the quad + isssflag=nint(p5) +! write(6,*)'QUAD: isssflag=',isssflag + if(isssflag.eq.1)then + if(p2.lt.0.d0) call dquad(p1,-p2,h,mh) + if(p2.eq.0.d0) call drift(p1,h,mh) + if(p2.gt.0.d0) call fquad(p1,p2,h,mh) + else + if(p2.lt.0.d0) call dquad3(p1,-p2,h,mh) + if(p2.eq.0.d0) call drift3(p1,h,mh) + if(p2.gt.0.d0) call fquad3(p1,p2,h,mh) + endif +c put on leading fringe field + if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then + if(lfrn.ne.0)then + call frquad(p2,-1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) + endif + endif +c put on trailing fringe field + if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then + if(tfrn.ne.0)then + call frquad(p2,1,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + endif + endif +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +c +147 continue +c 'sextupol': MAD sextupole +c 7/14/2002: need to modify 'sextupol' to handle tilt + goto 110 +c +148 continue +c 'octupole': MAD octupole +c 7/14/2002: need to modify 'octupole' to handle tilt + goto 111 +c +149 continue +c 'multipol': MAD general thin multipole + if(imsg1.eq.0)then + imsg1=1 +c write(6,*)'MULTIPOLE MULTIPLIER CORRECT?' + endif + p1b=p1*brho + p2b=p2*brho + p3b=p3*brho/2.d0 + p4b=p4*brho/2.d0 + p5b=p5*brho/6.d0 + p6b=p6*brho/6.d0 + call thnl(p1b,p2b,p3b,p4b,p5b,p6b,h,mh) +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+0.d0 + prevlen=0.d0 + nt2prev=nt2 + reftraj(5)=reftraj(5)+0.d0/(beta*c)*(omegascl) +c============== + goto 2000 +c +c 'solenoid': MAD solenoid +c +150 continue + write(6,*) ' == afro::lmnt::solenoid ==' + write(6,*) ' jslice=',jslice + write(6,*) ' jsltot=',jsltot + write(6,*) ' slfrac=',slfrac + call gensol(p,h,mh,jslice,jsltot,slfrac) +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + prevlen=(p2-p1)*slfrac + arclen=arclen+prevlen + nt2prev=nt2 + reftraj(5)=reftraj(5)+prevlen/(beta*c)*(omegascl) +c============== + go to 2000 + return +c +151 continue +c 'hkicker': MAD hkicker + if(p2.ne.0.d0)then + write(6,*)'error: hkicker strength, kick = ',p2 + write(6,*)'but hkicker currently implemented only w/ kick=0.' + write(6,*)'kick will be ignored (i.e. treat like a drift)' + endif +c + isssflag=nint(p3) +! write(6,*)'HKICKER: isssflag=',isssflag + if(isssflag.eq.1)then + call drift(p1,h,mh) + else + call drift3(p1,h,mh) + endif +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +c +152 continue +c 'vkicker': MAD vkicker + if(p2.ne.0.d0)then + write(6,*)'error: vkicker strength, kick = ',p2 + write(6,*)'but vkicker currently implemented only w/ kick=0.' + write(6,*)'kick will be ignored (i.e. treat like a drift)' + endif +c + isssflag=nint(p3) +! write(6,*)'VKICKER: isssflag=',isssflag + if(isssflag.eq.1)then + call drift(p1,h,mh) + else + call drift3(p1,h,mh) + endif +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +c +153 continue +c 'kicker': MAD kicker + if(p2.ne.0.d0)then + write(6,*)'error: kicker strength hkick = ',p2 + write(6,*)'but kicker currently implemented only w/ hkick=0.' + write(6,*)'hkick will be ignored (i.e. treat like a drift)' + endif + if(p3.ne.0.d0)then + write(6,*)'error: kicker strength vkick = ',p3 + write(6,*)'but kicker currently implemented only w/ vkick=0.' + write(6,*)'vkick will be ignored (i.e. treat like a drift)' + endif + isssflag=nint(p4) +! write(6,*)'KICKER: isssflag=',isssflag + if(isssflag.eq.1)then + call drift(p1,h,mh) + else + call drift3(p1,h,mh) + endif +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +c +154 continue +c 'rfcavity': MAD RF cavity + write(6,*)'MAD RF cavity commented out' + zlen=p1 + volt=p2 + phlagrad=p3 + nharm=nint(p4) +! call rfcavmad(zlen,volt,phlagrad,nharm,h,mh) + call ident(h,mh) +! call set_pscale_mc(h,mh) +c============== +! call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +c +155 continue +c 'elsepara': MAD electrostatic separator + zlen=p1 + efield=p2 +c tilt is parameter 3; not used for now. + isssflag=nint(p4) + if(efield.ne.0.d0)then + write(6,*)'MAD elec separator: zlen,efield=',zlen,efield + call elsepmad(zlen,efield,h,mh) + else + if(isssflag.eq.1)then + write(6,*)'MAD elsep has zero field; treat as 5th order drift' + call drift(p1,h,mh) + else + write(6,*)'MAD elsep has zero field; treat as 3rd order drift' + call drift3(p1,h,mh) + endif + endif +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +cryne 12/27/02 return +c +156 continue +c 'hmonitor': MAD hmonitor + zlen=p1 + if(zlen.eq.0.d0)return + isssflag=nint(p2) + if(isssflag.eq.1)then + call drift(p1,h,mh) + else + call drift3(p1,h,mh) + endif + call hmonitor +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +cryne 12/27/02 return +c +157 continue +c 'vmonitor': MAD vmonitor + zlen=p1 + if(zlen.eq.0.d0)return + isssflag=nint(p2) + if(isssflag.eq.1)then + call drift(p1,h,mh) + else + call drift3(p1,h,mh) + endif + call vmonitor +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +cryne 12/27/02 return +c +158 continue +c 'monitor': MAD monitor + zlen=p1 + if(zlen.eq.0.d0)return + isssflag=nint(p2) + if(isssflag.eq.1)then + call drift(p1,h,mh) + else + call drift3(p1,h,mh) + endif + call monitor +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +cryne 12/27/02 return +c +159 continue +c 'instrument': MAD instrument + zlen=p1 + if(zlen.eq.0.d0)return + isssflag=nint(p2) + if(isssflag.eq.1)then + call drift(p1,h,mh) + else + call drift3(p1,h,mh) + endif + call instrument +c============== + call set_pscale_mc(h,mh) + refprev=reftraj + arclen=arclen+p1 + prevlen=p1 + nt2prev=nt2 + reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) +c============== + goto 2000 +cryne 12/27/02 return +c +160 continue +c 'sparem1' + write(6,*)'(lmnt) sparem1' + return +c +161 continue +c 'rcollima': MAD rectangular collimator + write(6,*)'MAD rectangular collimator not implemented' + return +c +162 continue +c 'ecollima': elliptic collimator + write(6,*)'MAD elliptic collimator not implemented' + return +c +163 continue +c 'yrot': MAD yrot +cryne 7/14/2002 same as MaryLie prot? Check this. (sign, etc.) + goto 105 +c +164 continue +c 'srot': MAD srot +cryne 7/14/2002 same as MaryLie arot? Check this. (sign, etc.) + goto 114 +c +165 continue +c 'prot3 ': (original 3rd order version of) rotation of reference plane + ijkind=nint(p2) + call prot3(p1,ijkind,h,mh) + goto 2000 +c +166 continue +c 'beambeam:' MAD beam-beam kick + write(6,*)'MAD beambeam element not implemented' + return +c +167 continue +c 'matrix': input a matrix using the MAD syntax + write(6,*)'matrix input (MAD syntax) element not implemented' + return +c +168 continue +c 'profile1d' + ncol=nint(p1) + nbins=nint(p2) +!p3 is the max number of file names in a sequence of output files + nprecision=nint(p4)-1 + nunit=nint(p5) + rwall=prms(7) + if(idproc.eq.0)write(6,*)'(lmnt) profile1d, rwall=',rwall +!p6 is a counter that gets incremented and appended to a sequence of file names + fname1=crms(1) + fname=fname1 + if(p3.ne.0)then + xdigits=log(p3)/log(10.d0) + ndigits=1+int(xdigits) + prms(6)=prms(6)+1.d0 + nseq=nint(prms(6)) !nseq is the counter that gets converted to a string + call num2string(nseq,aseq,ndigits) + j=len_trim(fname1) + fname=fname1(1:j)//aseq(1:ndigits) + endif + if(nunit.eq.0)then + estrng='profile1d' + call fnamechk(fname,nunit,ierr,estrng) + if(ierr.eq.1)then + write(6,*)'(profile1d)leaving lmnt due to problem w/ fname' + return + endif + endif + call ibcast(nunit) + if(nunit.gt.0)prms(5)=nunit +! call pwritez(nunit,idmin,idmax,nprecision) + if(ncol.gt.0)then + call profile1d(ncol,nbins,rwall,arclen,nunit,fname,nprecision) + else + call profilerad(ncol,nbins,rwall,arclen,nunit,fname,nprecision) + endif + if(crms(2).eq.'true' .or. p3.ne.0)then + if(idproc.eq.0)write(6,*)'closing file connected to unit ',nunit + close(nunit) + prms(5)=0.d0 + endif + if(crms(3).eq.'true')then +! if(idproc.eq.0)write(6,*)'flushing file unit ',nunit + call myflush(nunit) + endif + if(idproc.eq.0)then + write(6,*)'s=',arclen,' ;profile1d output to file ',fname + endif + return +c +169 continue +c 'yprofile' + if(idproc.eq.0)write(6,*)'(lmnt) yprofile' + return +c +170 continue +c 'tprofile' + if(idproc.eq.0)write(6,*)'(lmnt) tprofile' + return +c +171 continue +c 'hkick': synonym for MAD hkicker + goto 151 +c +172 continue +c 'vkick': synonym for MAD vkicker + goto 152 +c +173 continue +c 'kick': synonym for MAD kicker + goto 153 +c +174 continue +c 'hpm' + write(6,*)'(hpm) half parallel faced magnet' + write(6,*)'(hpm) b,phideg,iwhich=',p1,p2,p3 + rho=brho/p1 + phideg=p2 + iwhich=p3 + call hpf(rho,iwhich,phideg,h,mh) + goto 2000 +c +175 continue +c 'nlrf': non-linear RF cavity + if (idproc.eq.0) then + write(6,*) '(lmnt) nlrf: ntrk jslice jsltot slfrac ihalf = ', & + & ntrk,jslice,jsltot,slfrac,ihalf + write(6,*)' ...under construction...' + endif + if (jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then + ! for the first slice, read or compute generalized gradients + ! (for now assume pre-computed generalized gradients) + nunit=0 + estrng='nlrf' + call fnamechk(crms(2),nunit,ierr,estrng) + if (ierr.eq.1) then + if (idproc.eq.0) then + write(6,*) '<*** ERROR ***> (lmnt) nlrf: ' + write(6,*) 'leaving because of problems with file ',crms(2) + endif + call myexit() + endif + call read_egengrads(nunit) + ! also record element length and z at entrance of element + gaplen=eggrdata%zmax-eggrdata%zmin + zedge=arclen + endif + if (idproc.eq.0) then + write(6,*) 'zedge, gaplen =',zedge,gaplen; call myflush(6) + end if + ! for all slices: + ! compute and check slice length + zedgg=zedge + zlen=p2-p1 + if (zlen.le.0) then + zmap=gaplen*slfrac + else + if (zlen.le.gaplen) then + zmap=zlen*slfrac + else + if (idproc.eq.0) then + write(6,*) '<*** ERROR ***> (lmnt) nlrf:' + write(6,*) ' Integration length exceeds gap length!' + endif + call myexit() + endif + endif + ! note parameters + zlc=arclen-zedge + rffreq=twopi*p(3) + rf_phase=p(4)*pi180 + rf_escale=p(5) + nstep=nint(p(6)) + !nstep=eggrdata%nz_intrvl + nslices=nint(p(7)) + if(lflagmagu)then + if(idproc.eq.0)then + write(6,*) '<*** ERROR ***> (lmnt) nlrf:' + write(6,*) ' Simulations that contain RF cavities must use' + write(6,*) ' dynamic units! Re-run using dynamic units.' + endif + call myexit + endif + ! note initial time-of flight and initial gamma + t00=reftraj(5) + gam00=(-reftraj(6)*omegascl*sl*p0sc)/pmass + if (idproc.eq.0) then + write(6,*) 'calling subroutine nlrfcav():' + write(6,*) ' zedge =',zedge + write(6,*) ' zedgg, zlc, zmap, nstep =',zedgg,zlc,zmap,nstep + write(6,*) ' rffreq =',rffreq + write(6,*) ' t00, gam00 =',t00,gam00 + write(6,*) ' reftraj(5), reftraj(6) =',reftraj(5),reftraj(6) + endif + call nlrfcav(zedgg,zlc,zmap,nstep,t00,gam00,h,mh) + if (idproc.eq.0) then + write(6,*) 'returned from subroutine nlrfcav():' + write(6,*) ' zedge =',zedge + write(6,*) ' zedgg, zlc, zmap, nstep =',zedgg,zlc,zmap,nstep + write(6,*) ' rffreq =',rffreq + write(6,*) ' t00, gam00 =',t00,gam00 + endif + refprev=reftraj + ! rescale map + !call set_rfscale(h,mh) + ! update reftraj(5:6) and current arc length, + reftraj(5)=t00 + reftraj(6)=-gam00*pmass/(omegascl*sl*p0sc) + if (idproc.eq.0) then + write(6,*) ' reftraj(5), reftraj(6) =',reftraj(5),reftraj(6) + endif + arclen=arclen+zmap + ! and update length and index code of previous element + prevlen=zmap + nt2prev=nt2 + goto 2000 +c + return +c +c +c 2: user-supplied elements ************************************ +c +c 'usr1 ','usr2 ','usr3 ','usr4 ','usr5 ', +12 go to (201, 202, 203, 204, 205, +c 'usr6 ','usr7 ','usr8 ','usr9 ','usr10 ', + & 206, 207, 208, 209, 210, +c 'usr11 ','usr12 ','usr13 ','usr14 ','usr15 ', + & 211, 212, 213, 214, 215, +c 'usr16 ','usr17 ','usr18 ','usr19 ','usr20 ' + & 216, 217, 218, 219, 220),kt2 +c +201 call user1(p) + return +202 call user2(p) + return +203 call user3(p) + return +204 call user4(p) + return +205 call user5(p) + return +206 call user6(p,th,tmh) + return +207 call user7(p,th,tmh) + return +208 call user8(p,th,tmh) + return +209 call user9(p,th,tmh) + return +210 call user10(p,th,tmh) + return +211 call user11(p,th,tmh) + return +212 call user12(p,th,tmh) + return +213 call user13(p,th,tmh) + return +214 call user14(p,th,tmh) + return +215 call user15(p,th,tmh) + return +216 call user16(p,th,tmh) + return +217 call user17(p,th,tmh) + return +218 call user18(p,th,tmh) + return +219 call user19(p,th,tmh) + return +220 call user20(p,th,tmh) + return +c +c +c 3: parameter sets ********************************************** +c +c 'ps1 ','ps2 ','ps3 ','ps4 ','ps5 ', +13 go to (301, 302, 303, 304, 305, & +c 'ps6 ','ps7 ','ps8 ','ps9 '/ + & 306, 307, 308, 309),kt2 +c +301 call pset(p,1) + return +302 call pset(p,2) + return +303 call pset(p,3) + return +304 call pset(p,4) + return +305 call pset(p,5) + return +306 call pset(p,6) + return +307 call pset(p,7) + return +308 call pset(p,8) + return +309 call pset(p,9) + return +c +c 4-6: random elements +c +14 continue +15 continue +16 continue + write(jof ,9014) + write(jodf,9014) + 9014 format(' error in lmnt: random element reached') + call myexit +c +c 7: simple commands ************************************* +c +17 continue +c 'rt ','sqr ','symp ','tmi ','tmo ', + go to (701, 702, 703, 704, 705, +c 'pmif ','circ ','stm ','gtm ','end ', + & 706, 707, 708, 709, 710, +c 'ptm ','iden ','whst ','inv ','tran ', + & 711, 712, 713, 714, 715, +c 'revf ','rev ','mask ','num ','rapt ', + & 716, 717, 718, 719, 720, +c 'eapt ','of ','cf ','wnd ','wnda ', + & 721, 722, 723, 724, 725, +c 'ftm ','wps ','time ','cdf ','bell ', + & 726, 727, 728, 729, 730, +c 'wmrt ','wcl ','paws ','inf ','dims ', + & 731, 732, 733, 734, 735, +c 'zer ','sndwch ','tpol ','dpol ','cbm ', + & 736, 737, 738, 739, 740, +c 'poisson ','preapply','midapply','autoapply','autoconc' + & 741, 742, 743, 744, 745, +c 'rayscale','beam ','units ','autoslic','verbose ' + & 746, 747, 748, 749, 750, +c 'mask6 ','arcreset','symbdef ','particledump','raytrace' + & 751, 752, 753, 754, 755, +c 'autotrack','sckick','moments ','maxsize','reftraj', + & 756, 757, 758, 759, 760, +c 'initenv','envelopes','contractenv','setreftraj','setarclen', + & 761, 762, 763, 764, 765, +c 'wakedefault','emittance','matchenv','fileinfo','egengrad', + & 766, 767, 768, 769, 770, +c 'wrtmap ','rdmap ','sparec7','sparec8','sparec9'/ + & 771, 772, 773, 774, 775),kt2 +c +c 'rt ': ray trace +c +701 continue + icfile=nint(p1) + nfcfle=nint(p2) + norder=nint(p3) + ntrace=nint(p4) + nwrite=nint(p5) + fname1=crms(1) + fname2=crms(2) + iotemp=jof + jfctmp=jfcf + jfcf=nfcfle +cryne 3/27/04 ntaysym=1 for taylor, =2 for symplectic +cryne note: originally MaryLie code did symplectic if norder=5 + ntaysym=1 + if(norder.ge.5)ntaysym=2 + if(p6.lt.0.)jof=jodf + ibrief=iabs(nint(p6)) + estrng='rt' + if(icfile.gt.0)then + if(fname1.ne.' ')then + call fnamechk(fname1,icfile,ierr,estrng) + if(ierr.eq.1)then + write(6,*)'(rt) leaving lmnt due to problem w/ fname1' + return + endif + endif + endif +!bug fix on jan 3 if(jfcfile.gt.0)then + if(nfcfle.gt.0)then + if(fname2.ne.' ')then + call fnamechk(fname2,nfcfle,ierr,estrng) + if(ierr.eq.1)then + write(6,*)'(rt) leaving lmnt due to problem w/ fname2' + return + endif + endif + endif + call trace(icfile,jfcf,ntaysym,norder,ntrace,nwrite,0,0,5,0, & + & th,tmh) + jof=iotemp + jfcf=jfctmp + return +c +c square the existing map: +c +702 call concat(th,tmh,th,tmh,th,tmh) + write(jof,5702) + 5702 format(1h ,'existing map concatenated with itself') + if(ntrk.eq.1)write(jof,9702) + 9702 format(1h ,'warning: map squared in turtle mode') + return +c +c symplectify matrix in transfer map +c +703 continue + iopt=nint(p1) + ijkind=nint(p2) + call sympl(iopt,ijkind,th,tmh) + return +c +c input transfer map from an external file: +c +704 continue + iopt=nint(p1) + ifile=nint(p2) + nopt=nint(p3) + nskp=nint(p4) +c rewind only option + if (nopt.eq.1 .and. nskp.eq.-1) then + rewind ifile + write(jof,5704) ifile + 5704 format(1x,'file unit ',i3,' rewound') + return + endif +c +c other options +c + mpitmp=mpi + mpi=ifile + call mapin(nopt,nskp,h,mh) + mpi=mpitmp +c option when tracking (procedure at end) + if(ntrk.eq.1) goto 2000 +c options when not tracking + if(iopt.eq.1) call concat(th,tmh,h,mh,th,tmh) + if(iopt.eq.2) call mapmap(h,mh,th,tmh) + return +c +c output transfer map to an external file (tmo): +c +705 ifile=nint(p1) + mpotmp=mpo + mpo=ifile + call mapout(0,th,tmh) + mpo=mpotmp + return +c +c print contents of file master input file: +c +706 continue + itype=nint(p1) + ifile=nint(p2) + isend=nint(p3) + fname=crms(1) + if((ifile.eq.5).or.(ifile.eq.11).or.(ifile.eq.13))then + write(6,*)'Error: cannot write to unit 5, 11, or 13 w/ PMIF.' + write(6,*)'PMIF command will be ignored' + return + endif + estrng='PMIF' + if((ifile.ne.6).and.(fname.ne.' ')) & + & call fnamechk(fname,ifile,ierr,estrng) + if(ierr.eq.1)return +c + jtmp=jodf + jodf=ifile + if(isend.eq.1.or.isend.eq.3)call pmif(jof,itype,fname) + if(isend.eq.2.or.isend.eq.3)call pmif(jodf,itype,fname) + jodf=jtmp + return +c +c Note: the program should never get here. +c (cqlate is called directly from tran) +c +707 write(jof ,9707) + write(jodf,9707) + 9707 format(' error: reached element "circ" in routine lmnt') + call myexit +c +c store the existing transfer map +c +708 continue + kynd='stm' + nmap=nint(p1) + if ((nmap.gt.20).or.(nmap.lt.1)) then + write(jof,9708) nmap + 9708 format(1x,'nmap=',i3,1x,'trouble with stm:nmap < 1 or > 20') + call myexit + else + call strget(kynd,nmap,th,tmh) + return + endif +c +c get transfer map from storage +c +709 continue + kynd='gtm' + iopt=nint(p1) + nmap=nint(p2) +c + if ((nmap.gt.20).or.(nmap.lt.1)) then + write(jof,9709) nmap + 9709 format(1x,'nmap=',i3,1x,'trouble with gtm:nmap < 1 or > 20') + call myexit + return + endif +c + call strget(kynd,nmap,h,mh) +cryne--- 08/21/2001 + call mapmap(h,mh,hprev,mhprev) +c option when tracking(procedure at end) + if(ntrk .eq. 1) goto 2000 +c options when not tracking + if(iopt.eq.1) call concat(th,tmh,h,mh,th,tmh) + if(iopt.eq.2) call mapmap(h,mh,th,tmh) + return +c +c end of job: +c +710 continue + if(idproc.eq.0)then + write(jof,5710) + 5710 format(/1x,'end of MARYLIE run') +! write(6,*)'total length=',arclen + endif + iprinttimers=0 + if(crms(1).eq.'true')iprinttimers=1 + call myexit + return +c +c print transfer map: +c +711 continue + n1=nint(p1) + n2=nint(p2) + n3=nint(p3) + n4=nint(p4) + n5=nint(p5) + if(n5.eq.1)then + if(lautotrk.eq.0)then + call pcmap(n1,n2,n3,n4,th,tmh) + else + call pcmap(n1,n2,n3,n4,hprev,mhprev) + endif + endif + if(n5.eq.2)then + if(lautotrk.eq.0)then + call psrmap(n1,n2,th,tmh) + else + call psrmap(n1,n2,hprev,mhprev) + endif + endif + if(n5.eq.3)then + if(lautotrk.eq.0)then + call pdrmap(n1,n2,th,tmh) + else + call pdrmap(n1,n2,hprev,mhprev) + endif + endif + return +c +c identity mapping: +c +712 continue + call ident(th,tmh) +cryne 08/16/2001 + call ident(hprev,mhprev) + return +c +c write history of beam loss +c +713 call whst(p) + goto 2000 +c +c inverse: +c +714 continue + call inv(th,tmh) + return +c +c transpose: +c +715 call mtran(tmh) + return +c +c reverse factorization: +c +716 iord=nint(p1) + call revf(iord,th,tmh) + return +c +c Dragt's reversal +c +717 call rev(th,tmh) + return +c +c mask off selected portions of transfer map: +c +718 call mask(p,th,tmh) + return +c +c number lines in a file +c +719 call numfile(p) + return +c +c aperture particle distribution +c +720 call rapt(p) + return +c +721 continue + mode=nint(p1) + if (mode .eq. 1) call eapt(p) + return +c +c open files +c +722 call of(p) + return +c +c close files +c +723 call cf(p) + return +c +c window particle distribution +c +724 call wnd(p) + return +725 call wnda(p) + return +c +c filter transfer map +c +726 call ftm(p,th,tmh) + return +c +c write parameter set +c +727 ipset = nint(p(1)) + isend = nint(p(2)) + call wps(ipset,isend) + return +c +c write time +c +728 call mytime(p) + return +c +c change output drop file +c +729 jodf = nint(p(1)) + return +c +c ring bell +c +730 continue +cryne call bell + if(idproc.eq.0)write(6,*)'BELL BELL BELL BELL BELL BELL BELL ' + return +c +c write value of merit function +c +731 ifn = nint(p(1)) + isend = nint(p(2)) + call wmrt(ifn,isend) + return +c +c write contents of loop +c +732 call wcl(p) + return +c +c pause (paws) +c +733 continue + write(jof,*) ' press return to continue' + read(5,7330) iwxyz +7330 format(a1) + return +c +c change or write out infinities (inf) +c +734 continue + mode=nint(p1) + if (mode .eq. 0) then +c change infinities + xinf=p2 + yinf=p3 + tinf=p4 + ginf=p5 + return + endif +c write out values of infinities + isend=mode + if( isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) + & 'values of infinities xinf, yinf, tinf, ginf are:', + & xinf,yinf,tinf,ginf + endif + if( isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) + & 'values of infinities xinf, yinf, tinf, ginf are:', + & xinf,yinf,tinf,ginf + endif + return +c +c get dimensions (dims) +c +735 continue + return +c +c change or write out values of zeroes (zer) +c +736 continue + mode=nint(p1) + if (mode .eq. 0) then +c change values of zeroes + fzer=p2 + detz=p3 + return + endif +c write out values of zeroes + isend=mode + if( isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) + & 'values of zeroes fzero, detzero are:', + & fzer,detz + endif + if( isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) + & 'values of zeroes fzero, detzero are:', + & fzer,detz + endif + return +c +c sndwch +c +737 continue + n1=nint(p1) + if(n1.eq.0)then + call sndwch(hprev,mhprev,th,tmh,th,tmh) + else + call sndwchi(hprev,mhprev,th,tmh,th,tmh) + endif + return +c +c twiss polynomial (tpol) +c +738 continue + call tpol(p,th,tmh) + return +c +c dispersion polynomial (dpol) +c +739 continue + call dpol(p,th,tmh) + return +c +c change or write out beam parameters (cbm) +c +740 continue + job=nint(p1) + if (job .eq. -1) then + prms(1)=0.d0 + prms(2)=brho + prms(3)=gamm1 + endif + if (job .eq. 0) then + brho=p2 + gamm1=p3 +c recomputation of relativistic beta and gamma factors: + gamma=gamm1+1.d0 + stuff2=gamm1*(gamma+1.d0) + stuff1=sqrt(stuff2) + beta=stuff1/gamma + endif + if ((job .eq. 1) .or. (job .eq. 3)) then + write(jof,*) ' beam parameters are: ', brho,gamm1 + endif + if ((job .eq. 2) .or. (job .eq. 3)) then + write(jodf,*) ' beam parameters are: ', brho,gamm1 + endif + return +c +c POISSON +c set parameters for poisson solver +c +741 continue +! Here are the real (array p) and character (array cparams) parameters: +! array p and cparam are dimensioned p(60) and cparams(60), but only +! the first few elements (12 and 17, resp) are used in this case. +! Somehow these need to be made available to spch3d. +! For now they are stored in common, then passed to spch3d through +! its argument list: + rparams(1:nparams)=prms(1:nparams) + cparams(1:ncparams)=crms(1:ncparams) +! +! this needs a lot of cleaning up. RDR 12 Nov 2003 +! +! p(1-3)=nx,ny,nz +! p(4-5)=xmin,xmax +! p(6-7)=ymin,ymax +! p(8-9)=zmin,zmax +! p(10-11)=anag_patchsize,anag_refineratio +! cparam(1) : solver [i.e. solver type] +! cparam(2) : geometry [not currently used] +! cparam(3) : gridsize [fixed or variable] +! cparam(4) : [determines whether # of gridpoints is fixed or variable] +! cparam(5-7) : xboundary,yboundary,zboundary [open,dirichlet,periodic] +! cparam(8) : boundary [not currently used; will specify x,y,z together] +! cparam(9) : solving_for [determines whether solving for phi or E] +! cparam(10): densityfunction ["delta" (old method); "linear" (new)] +! cparam(11): chombo_input_file [default: 'undefined'] +! cparam(12): anag_smooth [default: 'none'] +! cparam(13-17)= 5 spares +! + nxsave=nint(prms(1)) + nysave=nint(prms(2)) + nzsave=nint(prms(3)) +c + noresize=1 + if(crms(4).eq.'variable')noresize=0 + nadj0=0 + if(crms(7).eq.'periodic')nadj0=1 +cryne--- Dec 29, 2002 + if(crms(5).eq.'dirichlet' .and. & + & crms(6).eq.'dirichlet' .and. & + & crms(7).eq.'dirichlet')then + idirich=1 + else + idirich=0 + endif +cryne--- + kfixbdy=0 + if(crms(3).eq.'fixed')kfixbdy=1 + xmin0=prms(4) + xmax0=prms(5) + ymin0=prms(6) + ymax0=prms(7) + zmin0=prms(8) + zmax0=prms(9) +c Dec 29, 2002 +c initialize the green function to "not made" + madegr=0 +c--------------------------------------- +cryne Nov 12, 2003 Removed code dealing with ntrkorder and ntrktype +cryne because that has to do with dynamics, and this type code +cryne has to do with the Poisson solver. +cryne The dynamics info should be specified in the autotrack command +c--------------------------------------- +cryne April 23, 2003 + if (crms(9).eq.'e'.or.crms(9).eq.'E') then + idirectfieldcalc=1 + else if (crms(9).eq.'phi'.or.crms(9).eq.'Phi' & + & .or.crms(9).eq.'PHI') then + idirectfieldcalc=0 + else + if (idproc.eq.0) then + write(6,*) ' <*** ERROR ***> unrecognized value ',crms(9) + write(6,*) ' for parameter \"solving_for\" in POISSSON.' + end if + call myexit() + end if + if (crms(10).eq.'delta'.or.crms(9).eq.'Delta') then + idensityfunction=0 + else if (crms(10).eq.'linear'.or.crms(10).eq.'Linear') then + idensityfunction=1 + else + if (idproc.eq.0) then + write(6,*) ' <*** ERROR ***> unrecognized value ',crms(9) + write(6,*) ' for parameter \"densityfunction\" in POISSSON.' + end if + call myexit() + end if + if (idproc.eq.0) then + write(6,*) 'idirectfieldcalc=',idirectfieldcalc + if (idirectfieldcalc.eq.0) then + write(6,*) ' solving for the scalar potential phi' + else + write(6,*) ' solving for the electric field' + end if + write(6,*) 'idensityfunction=',idensityfunction + if (idensityfunction.eq.0) then + write(6,*) ' using delta \"interpolation\" for charges' + else + write(6,*) ' using linear interpolation charge distribution,' + write(6,*) ' (i.e. using integrated Green function technique)' + end if + endif +c +c--------------------------------------- +!dbs Nov03 + if(crms(1).eq.'fft')then + isolve=1 + elseif(crms(1).eq.'fft2')then + if(idirich.eq.0)then + isolve=10 !alternate (ANAG) infinite domain solver + else + isolve=20 !alternate (ANAG) homogenous Dirichlet solver + endif + elseif(crms(1).eq.'chombo')then + if(idirich.eq.0)then + isolve=30 !Chombo infinite domain solver + else + isolve=40 !Chombo homogenous Dirichlet solver + endif + else + if(idproc.eq.0) + & write(6,*) '(poisson) error: solver=' ,TRIM(crms(1)) + & ,' is invalid. Use fft, fft2 or chombo' + call myexit + endif + + ! set extra paramters for ANAG Poisson solver (James algorithm) + if( isolve .NE. 1 )then + ! parameters for James algorithm + if( crms(5).eq.'open' .AND. crms(6).eq.'open' .AND. + & crms(7).eq.'open' )then + ! anag_patchsize: size of grid blocks in FFT2 solver (must be multiple of 4) + ! anag_refineratio: to create MLC global coarse grid from MLI grid + anagpatchsize = prms(10) + anagrefratio = prms(11) + endif + + !mehrstellen smoothing on phi after MLC solve + !anag_smooth= + if( crms(12).eq.' ' .OR. crms(12).eq.'none' .OR. + & crms(12).eq.'off' )then + anagsmooth = 0 + else + anagsmooth = 1 + endif + endif + + !chombo_file= (see spch3d_chombo.f::CH_READINFILE()) + if( crms(11).eq.'undefined')then + chombofilename = ' ' + else + if( LEN_TRIM(crms(11)) .GT. LEN( chombofilename ) )then + if(idproc.eq.0) + & write(6,*)'(poisson) error: chombo_input_file is too long' + call myexit + endif + chombofilename = crms(11) + endif + + if( idproc.eq.0 .and. iverbose.gt.3 )then + write(6,*) 'lmnt: (poisson) input solver ',TRIM(crms(1)) + & ,', isolve = ',isolve + endif +!dbs +c--------------------------------------- +c +c set the flag to indicate that s.c. parameters have been set: +cryne Nov 12, 2003: this was commented out Dec 2, 2002, but +cryne it belongs here so I am putting it back. + nspchset=1 + if(idproc.eq.0)then + write(6,*)'setting poisson parameters:' + write(6,*)'nx,ny,nz=',nxsave,nysave,nzsave + write(6,*)'noresize,nadj=',noresize,nadj0 +cryne Nov 12, 2003: this really *is* wrong, so I am commenting out: +c if(nspchset.eq.1)then +c write(6,*)'autotracking w/ space charge from this point on' +c write(6,*)'order=',ntrkorder +c endif + endif +cryne Dec 29, 2002: added module spchdata + nx=nxsave + ny=nysave + nz=nzsave + n1=2*nx + n2=2*ny + n3=2*nz + nadj=nadj0 + n3a=2*nz-nadj*nz +cryne Dec 29, 2002: for Dirichlet case, double grid in all 3 dimensions + if(idirich.eq.1)n3a=2*nz + call new_spchdata(nx,ny,nz,n1,n2,n3a,isolve) + if(idproc.eq.0)then + write(6,*)'DONE ALLOCATING SPACE CHARGE ARRAYS' + endif + return +c +c preapply commands automatically +c +742 continue +c n1=nint(p1) +c autostr(1)=cmenu(n1) + autostr(1)=crms(1) + if(iverbose.ge.1)write(6,*)'(lmnt)autostr(1)=',autostr(1) + lautoap1=1 + if(autostr(1).eq.'off')then + if(iverbose.ge.1)write(6,*)'turning off pre-autoapply' + lautoap1=0 + endif +c restrict automatic application unless "applyto=all" : + lrestrictauto=1 + if(crms(2).eq.'all')lrestrictauto=0 + return +c +c midapply commands automatically +c +743 continue +c n1=nint(p1) +c autostr(2)=cmenu(n1) + autostr(2)=crms(1) + if(iverbose.ge.1)write(6,*)'(lmnt)autostr(2)=',autostr(2) + lautoap2=1 + if(autostr(2).eq.'off')then + if(iverbose.ge.1)write(6,*)'turning off mid-autoapply' + lautoap2=0 + endif +c restrict automatic application unless "applyto=all" : + lrestrictauto=1 + if(crms(2).eq.'all')lrestrictauto=0 + return +c +c autoapply (actually, this is 'post-apply') commands automatically +c +744 continue +c n1=nint(p1) +c autostr(3)=cmenu(n1) + autostr(3)=crms(1) + if(iverbose.ge.1 .and. idproc.eq.0) & + & write(6,*)'(lmnt/posapply)autostr(3)=',autostr(3) + lautoap3=1 + if(autostr(3).eq.'off')then + if(iverbose.ge.1 .and. idproc.eq.0) & + & write(6,*)'turning off post-autoapply' + lautoap3=0 + endif +c restrict automatic application unless "applyto=all" : + lrestrictauto=1 + if(crms(2).eq.'all')lrestrictauto=0 + return +c +c autoconc ('auto-concatenate') +c +745 continue + if(crms(1).eq.'true')then + lautocon=1 + lautotrk=0 + if(idproc.eq.0)write(6,*)'lautocon=1, lautotrk=0' + elseif(crms(1).eq.'false')then + lautocon=0 + lautotrk=1 + if(idproc.eq.0)write(6,*)'lautocon=0, lautotrk=1' + elseif(crms(1).eq.'sandwich')then + lautocon=2 + lautotrk=0 + if(idproc.eq.0)write(6,*)'lautocon=2, lautotrk=0' + if(idproc.eq.0)write(6,*)'using sndwch instead of concat' + elseif(crms(1).eq.'revsandwich')then + lautocon=-2 + lautotrk=0 + if(idproc.eq.0)write(6,*)'lautocon=-2, lautotrk=0' + if(idproc.eq.0)write(6,*)'using sndwchi instead of concat' + else + if(idproc.eq.0)then + write(6,*)'error(autoconc): do not understand parameter' + endif + call myexit + endif + return +c +c rayscale ('scale zblock array') +c +746 continue +c if(idproc.eq.0.and.iverbose.gt.0)write(6,*)'scaling zblock array' + if(idproc.eq.0)then + write(6,*)'scaling zblock array; p(1)-p(6)=' + write(6,*)p(1),p(2) + write(6,*)p(3),p(4) + write(6,*)p(5),p(6) + endif + do 7462 j=1,nraysp + do 7461 i=1,6 + zblock(i,j)=zblock(i,j)*p(i) + 7461 continue + 7462 continue + + return +c +c spare1c +c +747 continue + write(6,*)'(lmnt) BEAM type code codes here' + return +c +c spare2c +c +748 continue + write(6,*)'(lmnt) UNITS type code codes here' + return +c +c autoslice: +749 continue + if(crms(1).ne.'local' .and. crms(1).ne.'global' .and. & + & crms(1).ne.'none')then + if(idproc.eq.0)then + write(6,*)'Error(autoslice):' + write(6,*)'Invalid slice control (local/global/none):',crms(1) + write(6,*)'This autoslice command will be ignored' + endif + return + endif + if(prms(1).ne.0.d0 .and. prms(2).ne.0.d0)then + if(idproc.eq.0)then + write(6,*)'Error(autoslice): Cannot specify both' + write(6,*)'# of slices and length between slices.' + write(6,*)'Current values are:' + write(6,*)'# of slices= ',prms(1) + write(6,*)'length between slices= ',prms(2) + write(6,*)'This autoslice command will be ignored' + endif + return + endif +! input values are all valid; set autoslice parameters: +! default: + slicetype='slices' +! set parameters: + if(crms(1).eq.'none')then + slicetype='none' + slicevalue=0.d0 + endif + if(prms(1).gt.0.d0)then + slicetype='slices' + slicevalue=prms(1) + endif + if(prms(2).gt.0.d0)then + slicetype='interval' + slicevalue=prms(2) + endif + sliceprecedence=crms(1) +c space charge kick: +c--------------------------------------- +cryne Nov 14, 2003 +cryne should probably get rid of this code eventually. +cryne does not make sense to specify whether or not to sckick +cryne when specifying the autoslice command. +cryne sckick info should be specified in the autotrack command, +cryne and in fact it should be enabled by default if autotracking +cryne is enabled, unless the user explicitly prevents it. +c if(crms(2).eq.'true')nsckick=1 +c inefficient, but works. fix later. rdr dec 9 2002 +c n1=index(crms(2),'1') +c n2=index(crms(2),'2') +c n3=index(crms(2),'3') +c n4=index(crms(2),'4') +c n5=index(crms(2),'5') +c n6=index(crms(2),'6') +c n7=index(crms(2),'7') +c n8=index(crms(2),'8') +c n9=index(crms(2),'9') +c if(n1.ne.0)ntrkorder=1 +c if(n2.ne.0)ntrkorder=2 +c if(n3.ne.0)ntrkorder=3 +c if(n4.ne.0)ntrkorder=4 +c if(n5.ne.0)ntrkorder=5 +c for now 6, 7, 8, or 9 are all the same as order 5: +c if(n6.ne.0)ntrkorder=5 +c if(n7.ne.0)ntrkorder=5 +c if(n8.ne.0)ntrkorder=5 +c if(n9.ne.0)ntrkorder=5 +c ntay=index(crms(2),'tay') +c nsym=index(crms(2),'sym') +c if(ntay.ne.0)ntrktype=1 +c if(nsym.ne.0)ntrktype=2 +c if(n1+n2+n3+n4+n5+n6+n7+n8+n9+ntay+nsym.ne.0)nspchset=1 +c--------------------------------------- + if(idproc.eq.0)then + write(6,*)'autoslice;' + write(6,*)'crms(1)=',crms(1) + write(6,*)'crms(2)=',crms(2) + write(6,*)'crms(3)=',crms(3) + write(6,*)'slicetype=',slicetype + write(6,*)'sliceprecedence=',sliceprecedence + write(6,*)'slicevalue=',slicevalue +c write(6,*)'nsckick=',nsckick +c if(nspchset.ne.0)write(6,*)'ntrktype=',ntrktype +c if(nspchset.ne.0)write(6,*)'ntrkorder=',ntrkorder + endif + return +c +c verbose: +750 continue + iverbose=p(1) + return +c +c mask6: +751 continue + write(6,*)'(LMNT) Performing MASK6 command' + call mask6(p,th,tmh) + return +c +c arcreset: +752 continue + if(idproc.eq.0)write(6,*)'resetting arc length to zero' + arclen=0.d0 + return +c symbdef (="symbolic default"): +c this does not have any meaning in this routine; it only affects +c how the parser interprets in arithmentic expressions +c symbolic names that have not been define. Simply return from here. +753 continue + return +c +c particledump: +754 continue + idmin=nint(p1) + idmax=nint(p2) + if(idmax.eq.0)idmax=maxray + nphysunits=nint(prms(7)) +!p3 is the max number of file names in a sequence of output files + nprecision=nint(p4)-1 + nunit=nint(p5) +!p6 is a counter that gets incremented and appended to a sequence of file names + fname1=crms(1) + fname=fname1 + if(p3.ne.0)then + xdigits=log(p3)/log(10.d0) + ndigits=1+int(xdigits) + prms(6)=prms(6)+1.d0 + nseq=nint(prms(6)) !nseq is the counter that gets converted to a string + call num2string(nseq,aseq,ndigits) + j=len_trim(fname1) + fname=fname1(1:j)//aseq(1:ndigits) + endif + estrng='particledump' + if(nunit.eq.0)then + call fnamechk(fname,nunit,ierr,estrng) + if(ierr.eq.1)then + write(6,*)'(particledump)leaving lmnt due to problem w/ fname' + return + endif + call ibcast(nunit) + prms(5)=nunit + endif + iprintarc=0 + if(crms(4).eq.'true')iprintarc=1 + call pwritez(nunit,idmin,idmax,nprecision,nphysunits,iprintarc) + if(crms(2).eq.'true' .or. p3.ne.0)then + if(idproc.eq.0)write(6,*)'closing file connected to unit ',nunit + close(nunit) + prms(5)=0.d0 + endif + if(crms(3).eq.'true')then +! if(idproc.eq.0)write(6,*)'flushing file unit ',nunit + call myflush(nunit) + endif + if(idproc.eq.0)then + write(6,*)'s=',arclen,' ;particledump to file ',fname + endif + return +c +c raytrace: (has more parameters than original rt command) +755 continue + idmin=nint(p1) + idmax=nint(p2) + if(idmax.eq.0)idmax=maxray +c + if(nint(p3).eq.0 .and. crms(5).eq.'undefined')then +c Since the default value of p(3)=5, the user must have set it to zero. +c In this case, he/she is probably just reading in some rays. + if(idproc.eq.0)then + write(6,*)'Error: you are using old style to specify raytrace' + write(6,*)'order=0. Instead, if you only want to read particles,' + write(6,*)'use type=readonly' + endif + call myexit + endif + if(crms(5).eq.'undefined')then + if(idproc.eq.0)then + write(6,*)'Error: you are using old style method to specify' + write(6,*)'raytrace order.' + write(6,*)'Instead use type=taylorN or type=symplecticN' + endif + call myexit + endif +c + if(crms(5).eq.'readonly' .or. crms(5).eq.'readwrite')then + if(crms(5).eq.'readonly') norder=-1 + if(crms(5).eq.'readwrite') norder=0 + ntaysym=1 !irrelevent in this case +c note: when the user specifies readonly or readwrite, the default +c should be ntrace=0,nwrite=0; this is taken care of in sif.f + else + call getordtyp(crms(5),ntaysym,norder) + endif + ntrace=nint(p4) + nwrite=nint(p5) + ibrief=iabs(nint(p6)) +!prms(7) is the max number of file names in a sequence of output files + nprecision=nint(prms(8))-1 + icunit=nint(prms(9)) !assigned unit number for input file + nunit=nint(prms(10)) !assigned unit number for output file + nraysinp=nint(prms(12)) !# of rays to read from data file (optional) +!p11 is a counter that gets incremented and appended to a sequence of file names + icname=crms(1) + fcname=crms(2) + fname=fcname +c + if(prms(7).ne.0)then + xdigits=log(prms(7))/log(10.d0) + ndigits=1+int(xdigits) + prms(11)=prms(11)+1.d0 + nseq=nint(prms(11)) !nseq is the counter that gets converted to a string + call num2string(nseq,aseq,ndigits) + j=len_trim(fcname) + fname=fcname(1:j)//aseq(1:ndigits) + endif +c + estrng='raytrace' + if(icunit.eq.0 .and. icname.ne.' ')then + call fnamechk(icname,icunit,ierr,estrng) + if(ierr.eq.1)then + if(idproc.eq.0)then + write(6,*)'(rt) leaving lmnt due to problem w/ icunit' + write(6,*)'icunit=',icunit + write(6,*)'icname=',icname + endif + return + endif + call ibcast(icunit) + prms(9)=icunit + endif +! + if(nunit.eq.0 .and. fcname.ne.' ')then + call fnamechk(fname,nunit,ierr,estrng) + if(ierr.eq.1)then + write(6,*)'(rt) leaving lmnt due to problem w/ fcname' + return + endif + call ibcast(nunit) + prms(10)=nunit + endif +! + call trace(icunit,nunit,ntaysym,norder,ntrace,nwrite,idmin,idmax, & + & nprecision,nraysinp,th,tmh) +!close? + if(icunit.ne.0)then + if(idproc.eq.0)then + write(6,*)'closing particle initial condition file connected to',& + & ' unit ',icunit + endif + close(icunit) + prms(9)=0.d0 + endif + if(crms(3).eq.'true' .or. prms(7).ne.0)then + write(6,*)'closing particle final condition file connected to', & + & ' unit ',nunit + close(nunit) + prms(10)=0.d0 + endif +!flush? + if(crms(4).eq.'true')then + if(idproc.eq.0)write(6,*)'flushing file unit ',nunit + call myflush(nunit) + endif + return +c +c autotrack: +756 continue +c--------------------------------------- +cryne 4/14/04 crms(1) is no longer used +c crms(1) is 'set=' +c if(crms(1).eq.'true')then +c lautotrk=1 +c lautocon=0 +c if(idproc.eq.0)write(6,*)'lautotrk=1, lautocon=0' +c elseif(crms(1).eq.'false')then +c lautotrk=0 +c lautocon=1 +c if(idproc.eq.0)write(6,*)'lautotrk=0, lautocon=1' +c else +c if(idproc.eq.0)then +c write(6,*)'error(autotrack): do not understand parameter' +c endif +c call myexit +c endif + if(crms(2).ne.'undefined' .or. crms(4).eq.'true')then + lautotrk=1 + lautocon=0 + else + if(idproc.eq.0)then + write(6,*)'error: autotrack has been invoked, but neither' + write(6,*)'a particle tracking algorithm nor the envelope' + write(6,*)'option have been specified' + endif + call myexit + endif +c +c crms(2) is 'type=' [specifies particle tracking algorithm] + ntrktype=0 + ntrkorder=0 + if(crms(2).ne.'undefined')then + call getordtyp(crms(2),ntrktype,ntrkorder) + endif +c +c crms(4) is 'env=' + if(crms(4).eq.'true')then + nenvtrk=1 + else + nenvtrk=0 + endif +c +c crms(3) is 'sckick=' +c 1 means it has been turned on; 0 means it has been turned off; +c -1 means it has not been set. done this way for future use. + if(crms(3).eq.'true')then + nsckick=1 + elseif(crms(3).eq.'false')then + nsckick=0 + else + nsckick=-1 + endif +c write results of parsing this command for debug: + if(idproc.eq.0)then + if(ntrktype.ne.0)then + write(6,*)'autotracking particles' + if(ntrktype.eq.1)write(6,*)'ntrktype=1 (taylor)' + if(ntrktype.eq.2)write(6,*)'ntrktype=2 (symplectic)' + write(6,*)'ntrkorder=',ntrkorder + write(6,*)'nsckick=',nsckick + endif + if(nenvtrk.eq.1)write(6,*)'autotracking envelopes' + endif + return +c +c sckick: +757 continue + if(idproc.eq.0)write(6,*)'sckick command not implemented yet' + return +c +c moments (write some 2nd order moments): +758 continue + nfile1=nint(prms(1)) !assigned unit number for output xfile + nfile2=nint(prms(2)) !assigned unit number for output yfile + nfile3=nint(prms(3)) !assigned unit number for output tfile + nprecision=nint(prms(4))-1 + nunits=nint(prms(5)) + fname1=crms(1) + fname2=crms(2) + fname3=crms(3) + estrng='moments' +c1: + if(nfile1.eq.0)then + call fnamechk(fname1,nfile1,ierr,estrng) + if(ierr.eq.1)write(6,*)'moments error, problem w/ xfile' + if(ierr.eq.1)return + endif + call ibcast(nfile1) + if(nfile1.gt.0)prms(1)=nfile1 +c2: + if(nfile2.eq.0)then + call fnamechk(fname2,nfile2,ierr,estrng) + if(ierr.eq.1)write(6,*)'moments error, problem w/ yfile' + if(ierr.eq.1)return + endif + call ibcast(nfile2) + if(nfile2.gt.0)prms(2)=nfile2 +c3: + if(nfile3.eq.0)then + call fnamechk(fname3,nfile3,ierr,estrng) + if(ierr.eq.1)write(6,*)'moments error, problem w/ tfile' + if(ierr.eq.1)return + endif + call ibcast(nfile3) + if(nfile3.gt.0)prms(3)=nfile3 +c7: + if(crms(7).eq.'ratio')then + ncorr=1 + else + ncorr=0 + endif +c8: + if(crms(8).eq.'true')then + includepi=1 + else + includepi=0 + endif +c9: + if(crms(9).eq.'remove')then + ncent=0 + elseif(crms(9).eq.'keep')then + ncent=1 + else + if(idproc.eq.0) + & write(6,*) 'error(emittance): centroid=',TRIM(crms(4)), + & ' is invalid. Use keep or remove.' + call myexit() + endif +c=== + call writemom2d(arclen,nfile1,nfile2,nfile3,nprecision,nunits, & + &ncorr,includepi,ncent) +c=== + if(crms(4).eq.'true')call myflush(nfile1) + if(crms(5).eq.'true')call myflush(nfile2) + if(crms(6).eq.'true')call myflush(nfile3) + return +c +c +c maxsize (write max beam sizes) +759 continue + nfile1=nint(prms(1)) !assigned unit number for output file 1 + nfile2=nint(prms(2)) !assigned unit number for output file 2 + nfile3=nint(prms(3)) !assigned unit number for output file 3 + nfile4=nint(prms(4)) !assigned unit number for output file 4 + nprecision=nint(prms(5))-1 + nunits=nint(prms(6)) + if(crms(9).eq.'automatic'.or.crms(9).eq.'auto')then +c if(idproc.eq.0.and.nfile1.eq.0) & +c & write(6,*)'(maxsize) automatic file names' + fname1='xmax.out' + fname2='ymax.out' + fname3='tmax.out' + fname4='zmax.out' + else + fname1=crms(1) + fname2=crms(2) + fname3=crms(3) + fname4=crms(4) + endif + estrng='maxsize' +c1: + if(nfile1.eq.0)then + call fnamechk(fname1,nfile1,ierr,estrng) + if(ierr.eq.1)write(6,*)'maxsize error, problem w/ fname1' + if(ierr.eq.1)return + endif + call ibcast(nfile1) + if(nfile1.gt.0)prms(1)=nfile1 +c2: + if(nfile2.eq.0)then + call fnamechk(fname2,nfile2,ierr,estrng) + if(ierr.eq.1)write(6,*)'maxsize error, problem w/ fname2' + if(ierr.eq.1)return + endif + call ibcast(nfile2) + if(nfile2.gt.0)prms(2)=nfile2 +c3: + if(nfile3.eq.0)then + call fnamechk(fname3,nfile3,ierr,estrng) + if(ierr.eq.1)write(6,*)'maxsize error, problem w/ fname3' + if(ierr.eq.1)return + endif + call ibcast(nfile3) + if(nfile3.gt.0)prms(3)=nfile3 +c4: + if(nfile4.eq.0)then + call fnamechk(fname4,nfile4,ierr,estrng) + if(ierr.eq.1)write(6,*)'maxsize error, problem w/ fname4' + if(ierr.eq.1)return + endif + call ibcast(nfile4) + if(nfile4.gt.0)prms(4)=nfile4 +c=== +!XXX -- nunits arg is not in subroutine WRITEMAXSIZE() + call writemaxsize(arclen,nfile1,nfile2,nfile3,nfile4,nprecision) !XXX, & +!XXX &nunits) +c=== + if(crms(5).eq.'true')call myflush(nfile1) + if(crms(6).eq.'true')call myflush(nfile2) + if(crms(7).eq.'true')call myflush(nfile3) + if(crms(8).eq.'true')call myflush(nfile4) +c if(idproc.eq.0)then +c write(6,*)'s=',arclen,'; maximum beam sizes written' +c endif + return +c +c reftraj: +760 continue + nfile1=nint(prms(1)) !assigned unit number for output file + nprecision=nint(prms(2))-1 + nunits=nint(prms(3)) + fname1=crms(1) + estrng='reftraj' + if(nfile1.eq.0)then + call fnamechk(fname1,nfile1,ierr,estrng) + if(ierr.eq.1)write(6,*)'(reftraj) problem w/ fname1:',fname1 + if(ierr.eq.1)call myexit + endif + call ibcast(nfile1) + prms(1)=nfile1 +c=== + call writereftraj(arclen,nfile1,nprecision,nunits) +c=== + if(crms(2).eq.'true')call myflush(nfile1) + return +c +c initenv: +761 continue + if(crms(1).eq.'ratio')then + ncorr=1 + else + ncorr=0 + endif + call initenv(prms,ncorr) + return +c +c envelopes: (write the envelopes stored in the env array) +762 continue +c write(6,*)'here I am at envelopes' + nfile1=nint(prms(1)) !assigned unit number for output file 1 + nfile2=nint(prms(2)) !assigned unit number for output file 2 + nfile3=nint(prms(3)) !assigned unit number for output file 3 +c write(6,*)'nfile1,nfile2,nfile3=',nfile1,nfile2,nfile3 + nprecision=nint(prms(4))-1 + nunits=nint(prms(5)) + if(crms(7).eq.'ratio')then + ncorr=1 + else + ncorr=0 + endif + fname1=crms(1) + fname2=crms(2) + fname3=crms(3) +c write(6,*)'fname1,fname2,fname3=',fname1,fname2,fname3 + estrng='envelopes' +c1: + if(nfile1.eq.0)then + call fnamechk(fname1,nfile1,ierr,estrng) + if(ierr.eq.1)write(6,*)'envelopes error, problem w/ fname1' + if(ierr.eq.1)return + endif + call ibcast(nfile1) + if(nfile1.gt.0)prms(1)=nfile1 +c2: + if(nfile2.eq.0)then + call fnamechk(fname2,nfile2,ierr,estrng) + if(ierr.eq.1)write(6,*)'envelopes error, problem w/ fname2' + if(ierr.eq.1)return + endif + call ibcast(nfile2) + if(nfile2.gt.0)prms(2)=nfile2 +c3: + if(nfile3.eq.0)then + call fnamechk(fname3,nfile3,ierr,estrng) + if(ierr.eq.1)write(6,*)'envelopes error, problem w/ fname3' + if(ierr.eq.1)return + endif + call ibcast(nfile3) + if(nfile3.gt.0)prms(3)=nfile3 +c write(6,*)'done checking file names' +c=== + call writeenv2d(arclen,nfile1,nfile2,nfile3,nprecision,nunits, & + &ncorr) +c write(6,*)'returned from writeenv2d' +c=== +c=== + if(crms(4).eq.'true')call myflush(nfile1) + if(crms(5).eq.'true')call myflush(nfile2) + if(crms(6).eq.'true')call myflush(nfile3) + return +c contractenv (apply contraction map to envelopes): +763 continue + if(idproc.eq.0)then + write(6,*)'(lmnt) warning: user is calling contractenv directly,' + write(6,*)'but this is normally called by ML/I when the user' + write(6,*)'specifies a matchenv command. Make sure you know' + write(6,*)'what you are doing!' + endif + call contractenv(delta) + return +c +c setreftraj: +764 continue + nsto=nint(p(8)) + nget=nint(p(9)) + nwrt=nint(p(10)) +c reset from initial values? : +c crms(1) corresponds to "restart=' which refers to data in location 9 + if(crms(1).eq.'true')nget=9 +c include arc length? : + includearc=1 ! default is to include arc length + if(crms(2).eq.'false')includearc=0 +c + if(nsto.gt.0. or. nget.gt.0)then + if(nsto.gt.0)then + if(idproc.eq.0)then + if(nwrt.gt.0)then + write(6,*)'storing ref particle data in location',nsto + endif + endif + refsave(nsto,1:6)=reftraj(1:6) + if(includearc.eq.1)arcsave(nsto)=arclen + brhosav(nsto)=brho + gamsav(nsto)=gamma + gam1sav(nsto)=gamm1 + betasav(nsto)=beta + else + if(idproc.eq.0)then + if(nwrt.gt.0)then + write(6,*)'getting ref particle data from location ',nsto + endif + endif + reftraj(1:6)=refsave(nget,1:6) + if(includearc.eq.1)arclen=arcsave(nget) + brho=brhosav(nget) + gamma=gamsav(nget) + gamma1=gam1sav(nget) + beta=betasav(nget) + endif + else + if(idproc.eq.0 .and. nwrt.gt.0)then + write(6,*)'setting ref particle data' + write(6,*)'x,px=',p(1),p(2) + write(6,*)'y,py=',p(3),p(4) + write(6,*)'t,pt=',p(5),p(6) + endif + reftraj(1)=p(1) + reftraj(2)=p(2) + reftraj(3)=p(3) + reftraj(4)=p(4) + reftraj(5)=p(5) + reftraj(6)=p(6) +c only change arc length if the user has provided it (set to -9999 in sif.f): + if(p(7).ne.-9999.d0)arclen=p(7) + gamma=-reftraj(6)/pmass*omegascl*sl*p0sc + gamm1=gamma-1.d0 + gbet=sqrt(gamm1*(gamma+1.d0)) + clite=299792458.d0 + brho=gbet/clite*pmass + beta=gbet/gamma + endif + return +c +c setarclen: +765 continue +c crms(1) corresponds to "restart=' + if(crms(1).eq.'true')then + arclen=0.d0 + else + arclen=p(1) + endif + nwrt=nint(p(2)) + if(nwrt.gt.0 .and. idproc.eq.0)then + write(6,*)'setting arc length to ',arclen + endif + return +c +c wakedefault: (actually, not needed here; dealt with in sif.f) +766 continue + return +c +c emittance (write 2D, 4D, and/or 6D 2nd order moments): +767 continue + nfile=nint(prms(1)) !assigned unit number for output file + nprecision=nint(prms(2))-1 + nunits=nint(prms(3)) + fname=crms(5) + estrng='emittance' +c + if(nfile.eq.0)then + call fnamechk(fname,nfile,ierr,estrng) + if(ierr.eq.1)write(6,*)'error(emittance): problem w/ file' + if(ierr.eq.1)return + endif + call ibcast(nfile) + if(nfile.gt.0)prms(1)=nfile + ne2=1 + if(crms(1).eq.'false')ne2=0 + ne4=1 + if(crms(2).eq.'false')ne4=0 + ne6=1 + if(crms(3).eq.'false')then + ne6=0 + else + write(6,*) 'warning(emittance): 6d=true not yet implemented!' + ne6=0 + endif + if(crms(4).eq.'remove')then + ncent=0 + elseif(crms(4).eq.'keep')then + ncent=1 + else + if(idproc.eq.0) + & write(6,*) 'error(emittance): centroid=',TRIM(crms(4)), + & ' is invalid. Use keep or remove.' + call myexit() + endif +c=== + if(ne2.eq.1.or.ne4.eq.1.or.ne6.eq.1) then + call writeemit(arclen,nfile,nprecision,nunits,ne2,ne4,ne6,ncent) + endif +c=== + if(crms(6).eq.'true')call myflush(nfile) + return +c +c matchenv +768 continue + if(idproc.eq.0)then + write(6,*)'error (lmnt): at matchenv in subroutine lmnt' + write(6,*)'but the code should not get here.' + write(6,*) & + & 'a matchenv command can ONLY be placed under #labor in mli.in' + endif + call myexit +c stop +c +c fileinfo: +769 continue + ifileinfo=nint(p1) + return +c +c egengrad: compute generalized gradients from E-field surface data +770 continue + nfile=nint(prms(1)) !assigned unit number for output file + zst=prms(2) + zen=prms(3) + nz=nint(prms(4)) + f=prms(5) + r=prms(6) + fkmx=prms(7) + nk=nint(prms(8)) + infiles=nint(prms(9)) + nprec=nint(prms(10))-1 + !fnin=crms(1) ! filename for input data (E-field) + !fnout=crms(2) ! filename for output data (genlzd grads) + estrng='egengrad' + kfile=0 + jfile=0 +c + if(nfile.eq.0)then + call fnamechk(crms(2),nfile,ierr,estrng) + if(ierr.eq.1)write(6,*)'error(egengrad): problem w/ input file' + if(ierr.eq.1)return + endif + call ibcast(nfile) + if(nfile.gt.0)prms(1)=nfile + if(crms(5).eq.'true')then + call fnamechk(crms(4),kfile,ierr,estrng) + if(ierr.eq.1)write(6,*)'error(egengrad): problem w/ char file' + if(ierr.eq.1)return + endif + call ibcast(kfile) + if(crms(7).ne.' ')then + call fnamechk(crms(7),jfile,ierr,estrng) + if(ierr.eq.1)write(6,*)'error(egengrad): problem w/ diagn file' + if(ierr.eq.1)return + endif + call ibcast(jfile) + call cegengrad(crms(1),crms(6),infiles,nfile,kfile,jfile, & + & zst,zen,nz,f,r,fkmx,nk,nprec) + if(crms(3).eq.'true')then + call myflush(nfile) + if(kfile.ne.0) call myflush(kfile) + if(jfile.ne.0) call myflush(jfile) + end if + return +c +c wrtmap: Write a map to file +771 continue +c +c crms(1) : filename for write +c crms(2) : kind of map to write ('accumulated', 'lastslice') +c crms(3) : i/o status for write ('overwrite','append') +c + ifile=0 + estrng='wrtmap' + call fnamechk(crms(1),ifile,ierr,estrng) + if(ierr.eq.1)then + if(idproc.eq.0)write(6,*)'error(wrtmap): problem w/ file' + return + endif +c +c If overwriting file, rewind... +c KMP: This is a hack, and this should be passed to the fnamechk routine +c in order to be implemented properly. + if(crms(3).eq.'overwrite')then + close(ifile) + open(unit=ifile, file=crms(1), status='unknown', err=7710) + goto 7711 +7710 if(idproc.eq.0)write(6,*)'error(wrtmap): problem overwriting' + ierr=1 + return +7711 continue + endif +c +c Only write file from processor 0 + if(idproc.eq.0)then + if(crms(2).eq.'accumulated')then +! call wrtmap(ifile,refsave(9,1),reftraj,arclen,th,tmh) + call wrtmap(ifile,refprev,reftraj,arclen,th,tmh) + elseif(crms(2).eq.'lastslice')then + call wrtmap(ifile,refprev,reftraj,prevlen,hprev,mhprev) + else + ierr=1 + write(6,*)'error(wrtmap): invalid kind of map [',crms(2),']' + endif + endif + return +c rdmap: +772 continue +c +c crms(1) : filename to read from +c crms(2) : rewind file or not +c + ifile=0 + estrng='rdmap' + call fnamechk(crms(1),ifile,ierr,estrng) + if(ierr.eq.1)then + if(idproc.eq.0)write(6,*)'error(rdmap): problem w/ file' + return + endif + if(idproc.eq.0)write(6,*)'rdmap: reading map from ',crms(1) + if(crms(2).eq.'true')then + if(idproc.eq.0)write(6,*)' rewinding file before use' + rewind ifile + endif + + mpitmp=mpi + mpi=ifile + call rdmap(ifile,darclen,dreftraj,h,mh) + mpi=mpitmp + + refprev=reftraj + arclen=arclen+darclen + prevlen=darclen + nt2prev=nt2 + reftraj=reftraj+dreftraj + goto 2000 + +c sparec7: +773 continue + return +c sparec8: +774 continue + return +c sparec9: +775 continue + return +c +c +c 8: advanced commands ******************************** +c +c 'cod ','amap ','dia ','dnor ','exp ', +18 go to (801, 802, 803, 804, 805, +c 'pdnf ','psnf ','radm ','rasm ','sia ', + & 806, 807, 808, 809, 810, +c 'snor ','tadm ','tasm ','tbas ','gbuf ', + & 811, 812, 813, 814, 815, +c 'trsa ','trda ','smul ','padd ','pmul ', + & 816, 817, 818, 819, 820, +c 'pb ','pold ','pval ','fasm ','fadm ', + & 821, 822, 823, 824, 825, +c 'sq ','wsq ','ctr ','asni ','pnlp ', + & 826, 827, 828, 829, 830, +c 'csym ','psp ','mn ','bgen ','tic ', + & 831, 832, 833, 834, 835, +c 'ppa ','moma ','geom ','fwa '/ + & 836, 837, 838, 839),kt2 +c +c off-momentum closed orbit analysis +c +801 call cod(p,th,tmh) + return +c +c apply map to a function or moments +c +802 call amap(p,th,tmh) + return +c +c dynamic invariant analysis +c +803 call dia(p,th,tmh) + return +c +c dynamic normal form analysis +c +804 call dnor(p,th,tmh) + return +c +c compute exponential +c +805 call cex(p,th,tmh) + return +c +c compute power of dynamic normal form +c +806 call pdnf(p,th,tmh) + return +c +c compute power of static normal form +c +807 call psnf(p,th,tmh) + return +c +c resonance analyze dynamic map +c +808 call radm(p,th,tmh) + return +c +c resonance analyze static map +c +809 call rasm(p,th,tmh) + return +c +c static invariant ayalysis +c +810 call sia(p,th,tmh) + return +c +c static normal form analysis +c +811 call snor(p,th,tmh) + return +c +c twiss analyze dynamic map +c +812 call tadm(p,th,tmh) + return +c +c twiss analyze static map +c +813 call tasm(p,th,tmh) + return +c +c translate basis +c +814 call tbas(p,th,tmh) + return +c +c get buffer contents +c +815 continue +c +c test control parameters +c + nmap=nint(p2) + if (nmap.gt.5 .or. nmap.lt.1) then + write(jof,9815) nmap + 9815 format(1x,'nmap=',i3,1x,'trouble with gbuf:nmap < 1 or > 5') + call myexit + endif +c option when tracking (procedure at end) + if(ntrk .eq. 1) then +c if(idproc.eq.0)write(6,*)'at gbuf w/ ntrk=',ntrk + p1temp=p(1) + p(1)=2 + call gbuf(p,h,mh) + p(1)=p1temp + goto 2000 + endif +c options when not tracking +c if(idproc.eq.0)write(6,*)'at gbuf w/ ntrk.ne.1, ntrk=',ntrk + call gbuf(p,th,tmh) + return +c +c transport static (script) A +c +816 call trsa(p,th,tmh) + return +c +c transport dynamic script A +c +817 call trda(p,th,tmh) + return +c +c multiply polynomial by a scalar +c +818 call smul(p,th,tmh) + return +c +c add two polynomials +c +819 call padd(p,th,tmh) + return +c +c multiply two polynomials +c +820 call pmul(p,th,tmh) + return +c +c Poisson bracket two polynomials +c +821 call pbpol(p,th,tmh) + return +c +c polar decompose matrix portion of transfer map +c +822 call pold(p,th,tmh) + return +c +c evaluate a polynomial +c +823 call pval(p,th,tmh) + return +c +c fourier analyze static map +c +824 call fasm(p,th,tmh) + return +c +c fourier analyze dynamic map +c +825 call fadm(p,th,tmh) + return +c +c select quantities +c +826 call sq(p) + return +c +c write selected quantities +c +827 call wsq(p) + return +c +c change tune ranges +c +828 continue + call subctr(p) + return +c +c apply script N inverse +c +829 continue + call asni(p) + return +c +c compute power of nonlinear part +c +830 continue + call pnlp(p,th,tmh) + return +c +c check for symplecticity +c +831 continue + isend=nint(p1) + call csym(isend,tmh,ans) + return +c +c (psp) compute scalar product of two polynomials +c +832 call psp(p,th,tmh) + return +c +c (mn) compute matrix norm +c +833 call submn(p,th,tmh) + return +c +c (bgen) generate a beam +c +834 call bgen(p,th,tmh) + return +c +c (tic) translate (move) initial conditions +c +835 call tic(prms) + return +c +c (ppa) principal planes analysis +c +836 call ppa(p,th,tmh) + return +c +c (moma) moment and map analysis +c +837 call moma(p) + return +c +c (geom) compute geometry of a loop +c +838 call geom(p) + return +c +c (fwa) copy file to working array +c +839 call fwa(p) + return +c +c 9: procedures and fitting and optimization ************************* +c +c 'bip ','bop ','tip ','top ', +19 go to (901, 902, 903, 904, +c 'aim ','vary ','fit ','opt ', + & 905, 906, 907, 908, +c 'con1 ','con2 ','con3 ','con4 ','con5 ', + & 909, 910, 911, 912, 913, +c 'mrt0 ', + & 914, +c 'mrt1 ','mrt2 ','mrt3 ','mrt4 ','mrt5 ', + & 915, 916, 917, 918, 919, +c 'fps ', + & 920, +c 'cps1 ','cps2 ','cps3 ','cps4 ','cps5 ', + & 921, 922, 923, 924, 925, +c 'cps6 ','cps7 ','cps8 ','cps9 ', + & 926, 927, 928, 929, +c 'dapt ','grad ','rset ','flag ','scan ', + & 930, 931, 932, 933, 934, +c 'mss ','spare1 ','spare2 '/ + & 935, 936, 937),kt2 +c begin procedures +c +901 continue +cryne make sure that the code knows it has not converged yet +cryne (supresses printing until convergence is achieved) + kfit=0 + call bip(p) + return +902 call bop(p) + return +c +c end procedures +c +903 continue + call subtip(p) + return +904 call subtop(p) + return +c +c specify aims +c +905 call aim(p) + return +c +c specify quantities to be varied +c +906 call vary(p) + return +c +c fit to achieve aims +c +907 continue +cryne +ctm write(6,*)'(lmnt)calling fit; kfit=',kfit + call fit(p) +ctm write(6,*)'(lmnt)back from fit; kfit=',kfit + return +c +c optimize +c +908 call opt(p) + return +c +c constraints +c +909 call con1(p) + return +910 call con2(p) + return +911 call con3(p) + return +912 call con4(p) + return +913 call con5(p) + return +c +c merit functions +c +c least squares merit function +c +914 call mrt0 + return +c +c user supplied merit functions +c +915 call mrt1(p) + return +916 call mrt2(p) + return +917 call mrt3(p) + return +918 call mrt4(p) + return +919 call mrt5(p) + return +c +c free parameter sets +c +920 ipset=nint(p1) + call fps(ipset) + return +c +c capture parameter sets +c +921 ipset=1 + call cps(prms,p,ipset) + return +922 ipset=2 + call cps(prms,p,ipset) + return +923 ipset=3 + call cps(prms,p,ipset) + return +924 ipset=4 + call cps(prms,p,ipset) + return +925 ipset=5 + call cps(prms,p,ipset) + return +926 ipset=6 + call cps(prms,p,ipset) + return +927 ipset=7 + call cps(prms,p,ipset) + return +928 ipset=8 + call cps(prms,p,ipset) + return +929 ipset=9 + call cps(prms,p,ipset) + return +c +c compute dynamic aperture (dapt) +c +930 continue + call dapt(p) + return +c +c gradient (grad) +c +931 continue + call grad(p) + return +c +c rset +c +932 continue + call rset(p) + return +c +c flag +c +933 continue + call flag(p) + return +c +c scan +c +934 continue + call scan(p) + return +c +c mss +c +935 continue + call mss(p) + return +c +c spare1 +c +936 continue + write(6,*) 'spare1 not yet available' + return +c +c spare2 +c +937 continue + write(6,*) 'spare2 not yet available' + return +c +c ......... concatenate or track before exiting ........ +c + 2000 continue +cryne--- 08/16/2001 +cryne This statement has been added because h and mh disappear after +cryne leaving the routine, and there may be times when we would like +cryne to make use of the last map that was constructed. + call mapmap(h,mh,hprev,mhprev) +cryne--- +cryne 08/16/2001 note well: now the user can turn off auto-concatenation +cryne Use with care!!! + if(ntrk.eq.0)then + if(lautocon.eq.0)write(6,*)'WARNING: not concatenating!' + if(lautocon.eq.1)call concat(th,tmh,h,mh,th,tmh) + if(lautocon.eq.2)call sndwchi(h,mh,th,tmh,th,tmh) + if(lautocon.eq.-2)call sndwch(h,mh,th,tmh,th,tmh) + return + else +cryne 3/27/04 ntaysym=1 for taylor, =2 for symplectic + if(ntrktype.ne.0)then + ntaysym=ntrktype + call trace(0,jfcf,ntaysym,ntrkorder,1,0,0,0,5,0,h,mh) + endif + if(nenvtrk.eq.1)then +c write(6,*)'calling envtrace(mh) with mh(1:6,1:6)=' +c write(6,51)mh(1:6,1:6) + 51 format(6(1x,1pe12.5)) + call envtrace(mh) + endif +c write(6,*)'returning from bottom of lmnt' + return + endif + end +c +************************************************************************ +c + subroutine lookup(string,itype,index) +c----------------------------------------------------------------------- +c this subroutine determines whether the input string 'string' +c is an element,line,lump,loop, or unused label. +c +c input: string character*(*) item name +c output: itype integer =1, if string is a menu entry +c =2, .... line +c =3, .... lump +c =4, .... loop +c =5, .... unknown label +c index integer index of 'string' in its array +c +c Written by Rob Ryne ca 1984 +c rewritten by Petra Schuett +c October 30, 1987 +c----------------------------------------------------------------------- + use acceldata + use lieaparam, only : monoms + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- +c parameter types +c----------------------------------------------------------------------- + character string*(*) + integer itype,index +c----------------------------------------------------------------------- +c start routine +c----------------------------------------------------------------------- +c element? + do 10 n=1,na + if(string.eq.lmnlbl(n)) then + itype = 1 + index = n + return + endif + 10 continue +c item? + do 20 n=1,nb + if(string.eq.ilbl(n)) then + itype = ityp(n) + index = n + return + endif + 20 continue +c not found: + itype=5 + return + end +c +*********************************************************************** +c + subroutine low(line) +c Converts all uppercase characters to lowercase. +c Written by Liam Healy, Feb. 28, 1985. +c + character line*(*) +c + character*26 lower,upper + character*1 blank + data lower/'abcdefghijklmnopqrstuvwxyz'/ + data upper/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + data blank/' '/ + save lower,upper,blank +c + lnbc=1 + do 100 i=1,LEN(line) + loc=index(upper,line(i:i)) + if(loc.gt.0) then + line(i:i)=lower(loc:loc) + endif + if (line(i:i).ne.blank) lnbc=i + 100 continue + return + end +c +*********************************************************************** + subroutine lumpit(mth) +c----------------------------------------------------------------------- +c translate map of mth lump to special format and save it in core +c +c input mth (integer) : index of lump in /items/ +c +c Written by Rob Ryne ca 1984 +c changed by Petra Schuett +c October 30,1987 +c----------------------------------------------------------------------- + use acceldata + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- + include 'map.inc' + include 'deriv.inc' + include 'core.inc' + include 'files.inc' +c----------------------------------------------------------------------- +c local variables +c----------------------------------------------------------------------- +c inew keeps track of the lump to be deleted next, if core is full + integer inew + save inew + data inew /0/ +c----------------------------------------------------------------------- +c start routine +c----------------------------------------------------------------------- +c find vacant space in core + icore = 0 + do 1 i=maxlum,1,-1 + if(inuse(i).eq.0) icore=i + 1 continue +c if core is full, destroy oldest lump + if(icore.eq.0) then + inew=inew+1 + if(inew.eq.maxlum)inew=1 + icore=inew + lmade(inuse(icore))=0 + write(jof,510) ilbl(inuse(icore)) + 510 format(1h ,'lump ',a16,' deleted;') + endif +c-------------------- +c calculate rjac,df,.. + call canx(tmh,th,5) +c ..rrjac and rdf + call rearr +c-------------------- +c now store all the info + do 10 n1=1,6 +!!!!! do 10 n2=1,83 + do 10 n2=1,monoms + dfl(n1,n2,icore)=df(n1,n2) + 10 continue + do 20 n1=1,3 +!!!!! do 20 n2=1,84 +!!!!! do 20 n2=1,monom1+1 + do 20 n2=1,monoms + 20 rdfl(n1,n2,icore)=rdf(n1,n2) + do 30 n1=1,3 + do 30 n2=1,3 +!!!!! do 30 n3=1,28 +!!!!! do 30 n3=1,monom2+1 + do 30 n3=1,monoms + 30 rrjacl(n1,n2,n3,icore)=rrjac(n1,n2,n3) + do 40 n1=1,6 + do 40 n2=1,6 + 40 tmhl(n1,n2,icore)=tmh(n1,n2) + do 50 n1=1,monoms + 50 thl(n1,icore)=th(n1) +c-------------------- +c set pointers + inuse(icore) = mth + lmade(mth) = icore +c-------------------- + write(jof,520) ilbl(mth),icore + write(jodf,520) ilbl(mth),icore + 520 format(1h ,'lump ',a16,' constructed and stored.','(',i2,')') +c-------------------- +! ifile=50+icore +! write(ifile,*)'DFL:' +! do n1=1,6 +! do n2=1,monoms +! if(dfl(n1,n2,icore).eq.0.d0)cycle +! write(ifile,*)n1,n2,dfl(n1,n2,icore) +! enddo +! enddo +! write(ifile,*)'RDFL:' +! do n1=1,6 +! do n2=1,monoms +! if(rdfl(n1,n2,icore).eq.0.d0)cycle +! write(ifile,*)n1,n2,rdfl(n1,n2,icore) +! enddo +! enddo +! write(ifile,*)'RRJACL:' +! do n1=1,3 +! do n2=1,3 +! do n3=1,monoms +! if(rrjacl(n1,n2,n3,icore).eq.0.d0)cycle +! write(ifile,*)n1,n2,n3,rrjacl(n1,n2,n3,icore) +! enddo +! enddo +! enddo +! write(ifile,*)'TMHL:' +! do n1=1,6 +! do n2=1,6 +! if(tmhl(n1,n2,icore).eq.0.d0)cycle +! write(ifile,*)n1,n2,tmhl(n1,n2,icore) +! enddo +! enddo +! write(ifile,*)'THL:' +! do n1=1,monoms +! if(thl(n1,icore).eq.0.d0)cycle +! write(ifile,*)n1,thl(n1,icore) +! enddo +c-------------------- + return + end +c +************************************************************************ +c + function newsl(mp,kth) +c----------------------------------------------------------------------- +c newsl is the first icon to be treated. Depending on the sign of the +c repetition factor loop(mp), it is either the first or the last one. +c +c Petra Schuett, November 6,1987 +c----------------------------------------------------------------------- + use acceldata + use lieaparam, only : monoms +c-------- +c commons +c-------- + include 'stack.inc' +c------- +c start +c------- + if(loop(mp).ge.0) then + newsl = 1 + else + newsl = ilen(kth) + endif + return + end +************************************************************************ + function npm1(number) +c Petra Schuett, November 6,1987 +c + if (number .ge. 0) then + npm1 = 1 + else + npm1 = -1 + endif + return + end +************************************************************************ + subroutine pop(lempty) +c----------------------------------------------------------------------- +c pop stack +c +c output: lempty = .true. if stack is empty +c +c Petra Schuett October 30,1987 +c----------------------------------------------------------------------- + use acceldata + use lieaparam, only : monoms + include 'impli.inc' +c-------- +c commons +c-------- + include 'stack.inc' + include 'files.inc' +c--------------- +c parameter type +c--------------- + logical lempty +c------- +c start +c------- + np = np - 1 + if(np .le. 0) then + lempty = .true. + else + lempty = .false. + call lookup(lstac(np),ntype,ith) + call lookup(icon(nslot(np),ith),mtype,jth) + endif + return + end +************************************************************************ + subroutine push +c----------------------------------------------------------------------- +c push stack: add actual icon on top of it +c +c Petra Schuett October 30,1987 +c----------------------------------------------------------------------- + use acceldata + use lieaparam, only : monoms + include 'impli.inc' +c-------- +c commons +c-------- + include 'stack.inc' + include 'files.inc' +c------- +c start +c------- + np = np + 1 + if(np .gt. mstack) then + write(jof ,510) + write(jodf,510) + 510 format(' error in push: stack overflow') + call myexit + else + lstac(np) =icon(nslot(np-1),ith) + loop(np) =irep(nslot(np-1),ith) * npm1(loop(np-1)) + nslot(np) =newsl(np,jth) + nslot(np-1)=nslot(np-1) + npm1(loop(np-1)) + ith = jth + ntype = mtype + call lookup(icon(nslot(np),ith),mtype,jth) + endif + return + end +************************************************************************ + subroutine readin(line,leof) +c----------------------------------------------------------------------- +c Reads a line from file lf, puts it in the character variable 'line'. +c Designed so that filters may put on, such as the routine to convert +c all uppercase characters to lower case. +c Written by Liam Healy, May 1, 1985. +c +c Changed by Petra Schuett, October 19, 1987 : +c use logical: leof=.true. , if end of file is encountered +c----------------------------------------------------------------------- + include 'files.inc' + character line*(*) + logical leof +c----Routine---- + read(lf,800,end=100,err=200) line + 800 format(a) +cryne 9/11/2002 uncommented the following: + call low(line) + return + 100 continue + leof=.true. + return + 200 continue +cryne 08/26/2001 error exit added by ryne + write(6,*)'error reading data in routine readin' + stop + end +c +************************************************************************ +c + subroutine rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +c----------------------------------------------------------------------- +c This routine reads a new line and interprets it partly: +c - if a line starts with '!' (comment line), it is skipped and +c another line is read +c - if a #... code is read, it sets msegm, indicating the start of +c a new input component (segment). +c - lines in the comment component (segment) are not interpreted. +c - all other lines are cut into stings and numbers assuming a form: +c n1*str1 n2*str2 ... n3*str3 n4*str4,n5*str5 (etc) +c the numbers n1,n2,... are optional +c the strings and numbers are separated by blanks and/or commas +c - a line ending with & is continued on the next line (lcont=true) +c - anything after a '!' is ignored +c +c Input: msegm integer input component (segment) currently +c being read +c +c Output:line character*(*)line read +c leof logical =.true. if end of file is encountered +c msegm integer future component (segment) to be read +c strarr(40) character*(*)array of strings str1,str2,... +c narr(40) integer array of numbers n1,n2,... +c itot integer number of strings found +c lcont logical =.true. if line to be continued +c +c Author: Petra Schuett +c October 19, 1987 +c----------------------------------------------------------------------- + include 'impli.inc' +c + include 'files.inc' + include 'codes.inc' +c arguments: + integer msegm,narr(40),itot + character strarr(40)*(*) + character line*(*) + logical leof,lcont,npound +c local variables: + character*16 string + logical lnum,lfound + logical defcon,defelem,defline + external defcon,defelem,defline +cryne 5/4/2006 + logical MAD8,MADX + common/mad8orx/MAD8,MADX +c----------------- +c init + lcont=.false. + npound=.false. +c +ctm 9/01 skip read if coming from #include +c + if(itot.eq.-1) go to 3 +c read new line + 1 call readin(line,leof) +c check for end of file + if (leof) return +c----------------------------------------- +c check for blank lines or comment lines +c find the first nonblank character: + do n=1,LEN(line) + nfirst=n + if(line(n:n).ne.' ')goto 100 + enddo +c blank line: + goto 1 + 100 continue +c is the first character a '!' ? + if(line(nfirst:nfirst).eq.'!')goto 1 + +c----------------------------------------- +c write(6,*)'(rearec got)',line +c skip this check if entering the routine in #comment or #beam +! if((msegm.eq.1).or.(msegm.eq.2))goto 123 +cryne+++ August 5, 2004 : some time ago I commented out the previous line. +cryne However, it should be present for the case msegm.eq.1, so I am +cryne putting it back now. The reason is that the parser could find +cryne symbolic expressions in the comments, and it should not interpret +cryne these as symbolic constants whose values need to be calculated. +cryne Due to the following if test, the only way to get out of +cryne the #comments section is by finding #something (normally #beam) + if(msegm.eq.1)goto 123 +cryne+++ +c + if(msegm.ne.9)then + if(defcon(line))msegm=9 + endif + if(msegm.ne.3)then + if(defelem(line))msegm=3 + endif + if(msegm.ne.4)then + if(defline(line))msegm=4 + endif + 123 continue +c +cryne 5/4/2006 +cryne I am struggling w/ MADX input (originally wrote for MAD8). +cryne Deal with this by deciding here if the line is to be continued, +cryne First blank out everything to the right of and including '!' + lenline=len(line) + n123=index(line,'!') + if(n123.ne.0)line(n123:lenline)=' ' +cryne in MADX style, there could be space between ; and !, so deal with it: + if(MADX)then + if(n123.ne.0)iqtop=n123-1 + if(n123.eq.0)iqtop=lenline + do iq=iqtop,1,-1 + ilast=iq + if(line(ilast:ilast).ne.' ')exit + enddo +c write(6,*)'ilast,line(ilast:ilast)=',ilast,line(ilast:ilast) + if(line(ilast:ilast) .NE. ';' )lcont=.true. + endif +cryne +c +c + 3 continue + itot = 0 +c convert to lower case, except for comment component (segment) + if (msegm.ne.1) call low(line) +c find first string + kbeg=1 + call cread(kbeg,msegm,line,string,lfound) +c empty line is ignored, except in comment component (segment) + if(.not.lfound) then + if(msegm.eq.1) then + return + else +cryne 7/7/2002 write(6,*) msegm,'= segment with blank line' + goto 1 + endif + endif +c new component (segment) starts... + if(string(1:1).eq.'#')then +c in case previous component (segment) was comment, conv to lower case + call low(line) +c ...which one? +cryne do 2 k=1,8 !July 7, 2002 + do 2 k=1,nintypes + if(string(1:8).eq.ling(k)) then + msegm = k + npound=.true. +c write(6,*)'found a ',ling(k) +ctm if(msegm.eq.8)then +ctm call cread(kbeg,msegm,line,string,lfound) +ctm if(.not.lfound)then +ctm not any more-- write(6,*)'error(rearec): file name must follow #include' +ctm endif +ctm strarr(1)=string(1:8) +ctm return +ctm endif +c write(jodf,*) msegm +cryne 5/4/2006 a ";" on the line with #comment means "use MADX style" + if(msegm.eq.1)then + if(index(line,';').ne.0)then + MAD8=.false. + MADX=.true. + endif + endif +c------------------ + return + endif + 2 continue +c ... no match: +c default is #beam after #comment + if(msegm.eq.1) then + msegm = 2 + return + else +c but in all other cases, this should not happen! + write(jof,99) string + 99 format(' ---> warning from rearec:'/ & + & ' user name ',a,' begins with #') + endif + endif +c if #comment line is read, no interpretation + if(msegm.eq.1) return +c comment line + if (string(1:1).eq.'!') goto 1 +c......................................................... +c now interpret line +c first init itot + itot = 0 + do 10 i=1,40 +c end of line + if((.not.lfound).or.(string(1:1).eq.'!')) return +c line to be continued + if((MAD8) .and. string(1:1).eq.'&') then + lcont = .true. + return + endif +ccc if((MADX).and.len_trim(string).eq.1.and.string(1:1).ne.';') then +ccc lcont = .true. +ccc return +ccc endif +c so we found another string + itot=itot+1 +c is it a number? + call cnumb(string,num,lnum) +c write(jodf,*)string,'=',num,'lnum=',lnum + if((.not.lnum).and.(string(1:1).ne.'-')) then +c.. this must be "string" + narr(i)=1 + strarr(i)=string(1:16) + else if(.not.lnum) then +c.. it is "-string" + narr(i)=-1 +cryne rhs should say string(2:29)??? + strarr(i)=string(2:16) + else +c.. it is the number of "n*string" + narr(i)=num + call cread(kbeg,msegm,line,string,lfound) +c write(jodf,*)kbeg,string,lfound +cryne 08/14/2001 normally this would indicate a problem, but due to +cryne changes in the #beam component, it could be ok. So skip warning. + if (.not.lfound .and. msegm.eq.2)return +c.. error + if (.not.lfound) then + write(jof ,98) line + write(jodf,98) + 98 format(' ---> warning from rearec:'/, & + & ' the following line contains a number which is', & + & ' not followed by a string:') + write(jodf,*) ' ',line + call myexit + endif +c.. normal way + strarr(i)=string(1:16) + endif +cryne July 4, 2002 +cryne if using the Standard Input Format to read menu items, +cryne it is only necessary to see if there are at least 3 strings +cryne on this record + if(msegm.eq.3 .and. itot.eq.3)return +cryne July 14/2002 +cryne if reading the definition of a constant (msegm=9), only need one. + if(msegm.eq.9 .and. itot.eq.1)return +c find next string and start over again + call cread(kbeg,msegm,line,string,lfound) +c write(jodf,*)kbeg,string,lfound + 10 continue +c +c more than 40 strings, which are separated by single characters, +c cannot occur in a line of 80 characters. + end +c +c*********************************************************************** +c + subroutine tran +c----------------------------------------------------------------------- +c organizes translation of input into work to be done +c +c Written by Rob Ryne ca 1984 +c adapted to new version 9 Nov 87 by +c Petra Schuett +c Modified 31 Aug 88 by Alex Dragt +c Modified 20 Aug 98 to use a home-made do loop. AJD +c 4/1/00: Home-made loop re-inserted into Mottershead version. RDR +c----------------------------------------------------------------------- + use parallel + use acceldata + use beamdata + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- + include 'map.inc' + include 'core.inc' + include 'loop.inc' + include 'files.inc' + include 'labpnt.inc' + include 'fitbuf.inc' + include 'setref.inc' ! added by RDR, April 18, 2004 + real*8 mhprev + character*16 strng + dimension reftmp(6) + common/prevmap/hprev(monoms),mhprev(6,6) + common/envdata/env(6),envold(6),emap(6,6) + common/envstuff/nenvtrk + common/autotrk/lautotrk,ntrktype,ntrkorder +c +cryne 5/4/2006 added this to allowing printing of messages from #labor: + integer, parameter :: lmaxmsg=1000 + character*256 lattmsg(lmaxmsg) + common/lattmsgb/lattmsg,lmsgpoi + character*80 linestar +c +c----------------------------------------------------------------------- +c local variables +c----------------------------------------------------------------------- + dimension rh(monoms),rmh(6,6) +c----------------------------------------------------------------------- +c start +c----------------------------------------------------------------------- +c initialize + call ident(th,tmh) +cryne 08/17/201: + call ident(hprev,mhprev) +ctm reftraj(1:5)=0. + do k = 1,5 + reftraj(k)=0. + enddo +c +cryne 5/4/2006 + linestar='********************************************************& + &*************************' +c +c if(idproc.eq.0)write(6,*)'setting reference trajectory' +c if(idproc.eq.0)write(6,*)'sl=',sl +c if(idproc.eq.0)write(6,*)'omegascl=',omegascl +c if(idproc.eq.0)write(6,*)'p0sc=',p0sc +c if(idproc.eq.0)write(6,*)'gamma=',gamma +c if(idproc.eq.0)write(6,*)'pmass=',pmass +cryne fixed 4/18/04 : set reftraj(6) correctly for all choices of units: + reftraj(6)=-gamma*pmass/(omegascl*sl*p0sc) +cryne reftraj(6)=-gamma +c if(idproc.eq.0)write(6,*)'reftraj(6)=',reftraj(6) + arclen=0. +c +c save the initial reftraj data in location #9: + refsave(9,1:6)=reftraj(1:6) + arcsave(9)=arclen +cryne +cryne initialize this here because of a test on kfit in eintrp (gapmap) + kfit=0 +cryne + jicnt=0 + jocnt=0 +c main loop through latt (labor) +c +c Program changes made 20 August 98 by AJD. +c Change Fortran do loop into a home-made do loop because +c various other routines change the control index lp. +c +c do 5 lp=1,noble + lp=1 + 4 continue +c write(6,*)'AT START OF MAIN LABOR LOOP; lp=',lp +c For remaining changes, see end of this subroutine +c +cryne 5/4/2006: + strng=latt(lp) + if(strng(1:1).eq.'>')then +ccc msglen=len_trim(lattmsg(num(lp))) +ccc write(6,*)linestar(1:min(msglen,80)) +ccc write(6,*)trim(lattmsg(num(lp))) +ccc write(6,*)linestar(1:min(msglen,80)) +c +c msgout =1 (>), =2 (>>), or =3 (>>>) + msgout=1 + if(strng(1:2).eq.'>>')msgout=2 + if(strng(1:3).eq.'>>>')msgout=3 + msglen=len_trim(lattmsg(num(lp)))-msgout !length w/out > or >> or >>> + if(msgout.eq.1 .or. msgout.eq.3)then +c write to terminal: + if(idproc.eq.0)then + write(jof,*)linestar(1:min(msglen,80)) + write(jof,*)lattmsg(num(lp))(msgout+1:msglen+msgout) + write(jof,*)linestar(1:min(msglen,80)) + endif + endif + if(msgout.eq.2 .or. msgout.eq.3)then +c write to output file: + if(idproc.eq.0)then + write(jodf,*)linestar(1:min(msglen,80)) + write(jodf,*)lattmsg(num(lp))(msgout+1:msglen+msgout) + write(jodf,*)linestar(1:min(msglen,80)) + endif + endif + lp=lp+1 + goto 4 + endif +c + call lookup(latt(lp),ntype,ith) + if (ntype.eq.1) then +c command 'circ' ... + if(nt1(ith).eq.7 .and. nt2(ith).eq.7 ) then + icfile=nint(pmenu(1+mpp(ith))) + nfcfle=nint(pmenu(2+mpp(ith))) + norder=nint(pmenu(3+mpp(ith))) + ntimes=nint(pmenu(4+mpp(ith))) + nwrite=nint(pmenu(5+mpp(ith))) + isend =nint(pmenu(6+mpp(ith))) + jfctmp=jfcf + jfcf =nfcfle + call cqlate(icfile,norder,ntimes,nwrite,isend) + jfcj=jfctmp +c command 'contractenv' + elseif(nt1(ith).eq.7 .and. nt2(ith).eq.68) then + write(6,*)'**********************************************' + write(6,*)'**********************************************' + write(6,*)'*********IN TRAN; found matchenv**************' + write(6,*)'**********************************************' + write(6,*)'**********************************************' + niter=nint(pmenu(1+mpp(ith))) + tolerance=pmenu(2+mpp(ith)) + strng=cmenu(1+mppc(ith)) +c write(6,*)'niter,tolerance,strng=',niter,tolerance,strng +c note: this assumes that env(:) has been set. should check! + envold(:)=env(:) +c check that tracking variables nenvtrk,lautotrk,ntrktype make sense: + nenvtrkold=nenvtrk + lautotrkold=lautotrk + ntrktypeold=ntrktype + if(nenvtrk.ne.1)then + nenvtrk=1 + if(idproc.eq.0)then + write(6,*)'Envelope tracking turned on for rms matching.' + write(6,*)'It will be turned off when finished matching.' + endif + endif + if(lautotrk.ne.1)then + lautotrk=1 !confusing; this really means "don't concatenate" + if(idproc.eq.0)then + write(6,*)'autoconcatenation turned off for rms matching.' + write(6,*)'it will be turned on when finished matching.' + endif + endif + if(ntrktype.ne.0)then + ntrktype=0 !this, plus lautotrk=1, means "don't call trace" + if(idproc.eq.0)then + write(6,*)'particle tracking turned off for rms matching.' + write(6,*)'it will be turned on when finished matching.' + endif + endif +c start of do loop for rms matching: + do iii=1,niter +c store reference energy, etc. + reftmp(1:6)=reftraj(1:6) + arctmp=arclen + brhotmp=brho + gammatmp=gamma + gamm1tmp=gamm1 + betatmp=beta + call trobj(strng,1,0) + call contractenv(delta) +c check for convergence; if converged, break. + if(idproc.eq.0)write(6,*) & + & 'rms matching: iteration,delta=',iii,delta + if(delta.lt.tolerance)then + if(idproc.eq.0)write(6,*)'SEARCH CONVERGED' + exit + endif +c if not converged, restore reference energy, etc. and keep looping + reftraj(1:6)=reftmp(1:6) + arclen=arctmp + brho=brhotmp + gamma=gammatmp + gamm1=gamm1tmp + beta=betatmp + enddo + nenvtrk=nenvtrkold + lautotrk=lautotrkold + ntrktype=ntrktypeold + else +c ... or other element/command + call trlmnt(ith,num(lp)) + endif + else if (ntype.eq.2) then +c line + call trobj(latt(lp),num(lp),0) + else if (ntype.eq.3) then +c lump +c +c ignore or destroy lump with zero repetition number + if( num(lp).eq.0) then +c if lump is unmade, ignore it + if( lmade(ith).eq.0 ) then + write(jof, 510) ilbl(ith) + write(jodf,510) ilbl(ith) + 510 format(1x,'unmade lump ',a16, & + & ' in #labor with rep no. = 0 ignored') + else +c if lump is made, destroy it + do 30 k = 1,maxlum + if(inuse(k).eq.ith) then + inuse(k) = 0 + write(jof, 520) ilbl(ith) + write(jodf,520) ilbl(ith) + 520 format(1x,'lump ',a16, & + & ' in #labor with rep n. = 0 destroyed') + endif + 30 continue + lmade(ith) = 0 + endif + endif +c +c otherwise + if( num(lp).ne.0) then + call trobj(latt(lp),num(lp),0) + endif +c + else if (ntype.eq.4) then +c loop + if( num(lp).ne.0) nloop=ith + call trloop(ilbl(ith),num(lp)) +c store unmade lumps and replace lump-number by number in core + do 40 i=1,joy + if(mim(i).ge.0.and.mim(i).le.5000) then + jth=mim(i) + if(lmade(jth).eq.0) then + call mapmap(th,tmh,rh,rmh) + call ident(th,tmh) + call trobj(ilbl(jth),1,0) +c call lumpit(jth) + call mapmap(rh,rmh,th,tmh) + endif + mim(i)=lmade(jth) + endif + 40 continue + else +c unused label + if(idproc.eq.0)then + write(jof,610) latt(lp) + 610 format(1h ,'warning from tran: ',a16,' not found.') + endif + endif +c +c Further modifications required to produce home-made do loop. +c +c 5 continue +c + lp=lp+1 +c write(6,*)'AT BOTTOM OF MAIN LABOR LOOP; lp=',lp + if(lp .le. noble) go to 4 +c +c End of modifications. AJD 20 August 98 +c write(6,*)'returning from tran' +c + return + end +c +c*********************************************************************** +c + subroutine trlmnt(ith,mrep) +c----------------------------------------------------------------------- +c handle single item (element/command) in the menu +c +c input: ith index of the item in menu +c mrep repetition factor +c +c Petra Schuett, Nov.9,1987 +c----------------------------------------------------------------------- + use acceldata + use lieaparam, only : monoms + use beamdata, only : bcurr + use parallel, only : idproc + use ml_timer + include 'impli.inc' + include 'map.inc' + include 'codes.inc' + include 'previous.inc' + logical ldoit +c + common/rfxtra/zedge,gaplen,thetastore + common/showme/iverbose + common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0 + common/poiblock1/nspchset,nsckick + common/autotrk/lautotrk,ntrktype,ntrkorder + common/envstuff/nenvtrk + common/autolog/lautoap1,lautoap2,lautoap3,lrestrictauto +c +c iverbose=2 +cryne 8/31/2001 + kt1=nt1(ith) + kt2=nt2(ith) +cryne 1/11/2005 new code to only pre/post apply after "physical" elements. +c the following is just a first attempt at this: + ldoit=.false. + if(lrestrictauto.eq.1 .and. & + &(kt1.eq.1 .or. kt1.eq.2 .or. kt1.eq.4 .or. kt1.eq.5))ldoit=.true. +c +c------ Put ith in inmenu common variable ------------ +cryne 8/31/2001 I don't know who put this statement here or +cryne what it is good for: + inmenu = ith +c---------- +cryne 8/31/2001 +c check to see whether or not this is a thick element: +c write(6,*)' === afro::trlmnt(ith,mrep) ===' +c write(6,*)' ith =',ith,' mrep =',mrep +c write(6,*)' calling isthick from trlmnt with kt1,kt2=',kt1,kt2 + call isthick(kt1,kt2,ithick,thlen,ith) +c write(6,*)' done: ithick, thlen=', ithick,thlen + if(iverbose.eq.2)then + if(idproc.eq.0)write(6,*)'lmnlbl(ith)=',lmnlbl(ith) + if(idproc.eq.0)then + write(6,*)'kt1,kt2,ithick,thlen=',kt1,kt2,ithick,thlen + endif + endif +c +cryne 08/25/2001 +c autotrack if the user has so specified (w/ autotrack command) +c also, for now the code is set to autotrack even if the user has NOT +c specified, but if the user HAS in fact set the poisson parameters. +c This is consistent with the code further down in this routine, +c where slices are split in half on the basis of whether or not +c nspchset has been set to 1. +c It would perhaps be better to do on the basis of nsckick, not nspchset. + ntrk=0 + if(lautotrk.eq.1)ntrk=1 + if(nspchset.eq.1 .and. nsckick.ne.0)ntrk=1 !???we should omit this. rdr +cryne 11/15/2003 don't let the user mistakenly autotrack if the +cryne current is nonzero but the poisson params have not been set: +cryne this only applies if the code is about to track through a +cryne "thick" beamline element + if(ntrk.eq.1 .and. ithick.eq.1 .and. ntrktype.ne.0)then + if(bcurr.ne.0 .and. nspchset.eq.0)then + if(idproc.eq.0)then + write(6,*)'error: the code is about to track particles,' + write(6,*)'but the current is nonzero and the Poisson' + write(6,*)'solver has not been specified.' + write(6,*)'Use the poisson type code and re-run' + endif + call myexit + endif + endif +c----------------------------------------------------- + nslices=1 + slfrac=1. +c if autoslicing, get the number of slices: +c THIS ASSUMES THAT, IF THE CODE IS RUNNING IN THE MODE WHERE THE # OF +c SLICES IF EXPLICITLY SPECIFIED FOR EACH THICK ELEMENT, THEN IT IS +c ALWAYS THE LAST PARAMETER IN THE LIST: +c if(idproc.eq.0)write(6,*)'sliceprecedence=',sliceprecedence +c if(idproc.eq.0)write(6,*)'slicetype=',slicetype +c if(idproc.eq.0)write(6,*)'slicevalue=',slicevalue + if(ithick.eq.1 .and. slicetype.ne.'none')then + if(sliceprecedence.eq.'local')then +c if(idproc.eq.0)write(6,*)'determining slices locally' +! determine the number of slices locally: + if(slicetype.eq.'slices')then + nn0=mpp(ith)+nrp(1,kt2) + nslices=pmenu(nn0) +c if(idproc.eq.0)write(6,*)'thlen,nslices=',thlen,nslices + if(nslices.le.0)then + write(6,*)'error: nslices .le. 0; nslices=',nslices + call myexit + endif + else + nn0=mpp(ith)+nrp(1,kt2) + if(pmenu(nn0).le.0)then + write(6,*)'something wrong; slices/meter .le. 0' + write(6,*)'pmenu(nn0)=',pmenu(nn0) + call myexit + endif +!!!!!!!!!!! elementlength=pmenu(mpp(ith)+1) + elementlength=thlen + nslices=nint(elementlength/pmenu(nn0)) +c if(idproc.eq.0)write(6,*)'thlen,nslices=',thlen,nslices + if(nslices.eq.0)then + write(6,*)'computed value of nslices =0; resetting to 1' + nslices=1 + endif +ccc write(6,*)'elementlength,slices/m,nslices=', & +ccc & elementlength,pmenu(nn0),nslices + endif + else +! determine the number of slices from the globally set value: +c if(idproc.eq.0)write(6,*)'determining slices globally' + if(slicetype.eq.'slices')then + nslices=nint(slicevalue) +ccc write(6,*)'global_nslices=',nslices + else +!!!!!!!!!!! elementlength=pmenu(mpp(ith)+1) + elementlength=thlen + nslices=nint(elementlength/slicevalue) + if(nslices.eq.0)then + write(6,*)'computed value of nslices =0; resetting to 1' + nslices=1 + endif +ccc write(6,*)'elementlength,global_slices/m,nslices=', & +ccc & elementlength,slicevalue,nslices + endif + endif + endif + kspchset=0 + if(nspchset.eq.1 .or. nenvtrk.eq.1)kspchset=1 + slfrac=1.d0/nslices + if(lautoap2.eq.1 .or. kspchset.eq.1)slfrac=slfrac*0.5d0 +c----------------------------------------------------- +c this is a repeat counter that is usually equal to one: + do 20 i = 1,iabs(mrep) +c write(6,991)lmnlbl(ith),nslices,slfrac,ntrk,arclen + if(iverbose.eq.1)write(6,991)lmnlbl(ith),nslices,ntrk,arclen + if(iverbose.eq.2)write(6,992) & + & lmnlbl(ith),(pmenu(m),m=1+mpp(ith),nrp(kt1,kt2)+mpp(ith)) +c main loop: "tlmt,spch,lmnt" analogous to "map1,map2,map1" +c------------------ + nn1=1+mpp(ith) + nn2=1+mppc(ith) + do 15 j=1,nslices + call init_step_timer + call increment_timer('step',0) +cryne if(lautoap1.eq.1)call autoapp(1) + if(lautoap1.eq.1 .and. (kt1.ne.7.or.kt2.ne.42) .and. ldoit) & + & call autoapp(1) + if((ithick.eq.1).and.((lautoap2.eq.1).or.(kspchset.eq.1)))then + call lmnt(kt1,kt2,pmenu(nn1),cmenu(nn2),ntrk,j,nslices,slfrac,1) +cryne8/21 if(lautoap2.eq.1)call autoapp(2) + if(lautoap2.eq.1 .and. (kt1.ne.7.or.kt2.ne.43) .and. ldoit) & + & call autoapp(2) + tau=2.d0*prevlen + if(kspchset.eq.1)call autospch(tau,ntrk) + call lmnt(kt1,kt2,pmenu(nn1),cmenu(nn2),ntrk,j,nslices,slfrac,2) + else + call lmnt(kt1,kt2,pmenu(nn1),cmenu(nn2),ntrk,j,nslices,slfrac,0) + endif +cryne821if(lautoap3.eq.1)call autoapp(3) + if(lautoap3.eq.1 .and. (kt1.ne.7.or.kt2.ne.44) .and. ldoit) & + & call autoapp(3) +! Short range wakefield forces + if(cmenu(nn2).eq.'wake')then + if(idproc.eq.0)then + write(6,*)'short-range wakes temporarly commented out' + write(6,*)'for debugging. RDR' + endif +cryne call wkfld_srange(nslices,lmnlbl(ith),tau) + endif + call increment_timer('step',1) + call increment_timer('step',1) + call step_timer(lmnlbl(ith),iverbose) + 15 continue +! Long range wakefield forces + if(cmenu(nn2).eq.'wake')then + if(idproc.eq.0)then + write(6,*)'long-range wakes temporarly commented out' + write(6,*)'for debugging. RDR' + endif +cryne call wkfld_lrange + endif +c------------------ + 20 continue + 991 format(a16,' nslices=',i5,' slfrac=',1pe14.7,' ntrk=',i1, & + & ' arclen_in=',1pe14.7) + 992 format(a16,1x,9(1pe10.3,1x)) + return + end +c + subroutine isthick(kt1,kt2,ithick,thlen,ith) +c This routine determines if an element of type "kt1,kt2" is thick. +c If so, and if ith .ne.0, then it also returns its thickness. +c The routine is used in the autoslicing capability of MaryLie/IMPACT. +c It is necessary to return the length only if the user has requested +c that slicing be done N times per meter, i.e. the code needs to +c determine the number of slices based on the length. +c If the user specifies the number of slices, that all that is +c required is to determine whether the element is thick or not. +c Robert Ryne Nov. 30, 2002. + use beamdata + use acceldata + integer kt1,kt2,ithick,ith + integer itfile,numdata + real*8 thlen,p1,p2,rho,gaplen + character*16 estrng,fname,fname1 + character*5 aseq + ithick=0 + thlen=0. + if(kt1.ne.1)return +c 'drft ','nbnd ','pbnd ','gbnd ','prot ', + go to(101, 102, 103, 104, 105, +c 'gbdy ','frng ','cfbd ','quad ','sext ', + & 106, 107, 108, 109, 110, +c 'octm ','octe ','srfc ','arot ','twsm ', + & 111, 112, 113, 114, 115, +c 'thlm ','cplm ','cfqd ','dism ','sol ', + & 116, 117, 118, 119, 120, +c 'mark ','jmap ','dp ','recm ','spce ', + & 121, 122, 123, 124, 125, +c 'cfrn ','coil ','intg ','rmap ','arc ', + & 126, 127, 128, 129, 130, +c 'rfgap ','confoc ','transit','interface','rootmap', + & 1135, 1136, 133, 134, 135, +c 'optirot ','spare5 ','spare6 ','spare7 ','spare8 ', + & 136, 137, 138, 139, 140, +c 'marker ','drift ','rbend ','sbend ','gbend ', + & 141, 142, 143, 1045, 145, +c 'quadrupo','sextupol','octupole','multipol','solenoid', + & 146, 147, 148, 149, 150, +c 'hkicker ','vkicker ','kicker ','rfcavity','elsepara', + & 151, 152, 153, 154, 155, +c 'hmonitor','vmonitor','monitor ','instrume','sparem1 ', + & 156, 157, 158, 159, 160, +c 'rcollima','ecollima','yrot ','srot ','sparem2 ', + & 161, 162, 163, 164, 165, +c 'beambeam','matrix ','profile1d','yprofile','tprofile', + & 166, 167, 168, 169, 170, +c 'hkick ','vkick ','kick ','hpm ','nlrf '/ + & 171, 172, 173, 174, 175),kt2 + +!drft 1: + 101 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 +! write(6,*)'isthick: drft length=',thlen + return +!nbnd 2: + 102 continue + ithick=1 + if(ith.eq.0)return + rho=brho/pmenu(4+mpp(ith)) + p1=pmenu(1+mpp(ith)) + thlen=p1*rho*asin(1.d0)/90.d0 + return +!pbnd 3: + 103 continue + ithick=1 + if(ith.eq.0)return + rho=brho/pmenu(4+mpp(ith)) + p1=pmenu(1+mpp(ith)) + thlen=p1*rho*asin(1.d0)/90.d0 + return +!gbnd 4: + 104 continue + ithick=1 + if(ith.eq.0)return + rho=brho/pmenu(6+mpp(ith)) + p1=pmenu(1+mpp(ith)) + thlen=p1*rho*asin(1.d0)/90.d0 + return +!prot 5: + 105 continue + return +!gbdy 6: + 106 continue + ithick=1 + if(ith.eq.0)return + rho=brho/pmenu(4+mpp(ith)) + p1=pmenu(1+mpp(ith)) + thlen=p1*rho*asin(1.d0)/90.d0 + return +!frng 7: + 107 continue + return +!cfbd 8: + 108 continue + ithick=1 + if(ith.eq.0)return + rho=brho/pmenu(2+mpp(ith)) + p1=pmenu(1+mpp(ith)) + thlen=p1*rho*asin(1.d0)/90.d0 + return +!quad 9: + 109 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 +! write(6,*)'isthick: quad length=',thlen + return +!sext 10: + 110 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!octm 11: + 111 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!octe 12: + 112 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!srfc 13: + 113 continue + return +!arot 14: + 114 continue + return +!twsm 15: + 115 continue + return +!thlm 16: + 116 continue + return +!cplm 17: + 117 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!cfqd 18: + 118 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!dism 19: + 119 continue + return +!sol 20: + 120 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + p2=pmenu(2+mpp(ith)) + thlen=p2-p1 + return +!mark 21: + 121 continue + return +!jmap 22: + 122 continue + return +!dp 23: + 123 continue + return +!recm 24: + 124 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + p2=pmenu(2+mpp(ith)) + thlen=p2-p1 + return +!spce 25: + 125 continue + return +!cfrn 26: + 126 continue + return +!coil 27: + 127 continue + return +!intg 28: + 128 continue + return +!rmap 29: + 129 continue + return +!arc 30: + 130 continue + return +!rfgap 31: + 1135 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + if(p1.ge.0)then + thlen=p1 + return + endif + if(p1.lt.0)then + nseq=pmenu(5+mpp(ith)) + if(nseq.eq.0 .and. cmenu(1+mppc(ith)).eq.' ')then + if(idproc.eq.0)write(6,*)'ISTHICK ERROR(rfgap):no data file' + call myexit + endif + if(cmenu(1+mppc(ith)).eq.' ')then + fname1='rfdata' + ndigits=nseq/10+1 + call num2string(nseq,aseq,ndigits) + j=len_trim(fname1) + fname=fname1(1:j)//aseq(1:ndigits) + else + fname=cmenu(1+mppc(ith)) + endif + nunit=0 + estrng='rfgap' + call fnamechk(fname,nunit,ierr,estrng) + if(ierr.eq.1)then + write(6,*)'(isthick/rfgap) exiting due to problem w/ fname' + call myexit + endif +c write(6,*)'calling read_RFdata from isthick' + call read_RFdata(nunit,numdata,gaplen) + thlen=gaplen +! write(6,*)'isthick: rf gap length=',thlen + return + endif +! +!confoc 32: + 1136 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!transit: + 133 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!interface: + 134 continue + return +!rootmap: + 135 continue + return +!optirot: + 136 continue + return +!spare5: + 137 continue + return +!spare6: + 138 continue + return +!spare7: + 139 continue + return +!spare8: + 140 continue + return +!marker: + 141 continue + return +! +!drift 42: + 142 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 +! write(6,*)'isthick: drift length=',thlen + return +!rbend 43: + 143 continue +cryne 12/21/2004 + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + p2=pmenu(2+mpp(ith)) + rho=brho/p2 + thlen=p1*rho*asin(1.d0)/90.d0 + return +!sbend: 44 + 1045 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + p2=pmenu(2+mpp(ith)) + rho=brho/p2 + thlen=p1*rho*asin(1.d0)/90.d0 + return +!gbend: 45 + 145 continue + return +!quadrupo 46: + 146 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 +! write(6,*)'isthick: quadrupole length=',thlen + return +!sextupol 47: + 147 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!octupole 48: + 148 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!multipol 49: + 149 continue + return +!solenoid 50: + 150 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + p2=pmenu(2+mpp(ith)) + thlen=p2-p1 + return +!hkicker 51: + 151 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!vkicker 52: + 152 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!kicker 53: + 153 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!rfcavity 54: + 154 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!elsepara 55: + 155 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!hmonitor 56 + 156 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!vmonitor 57 + 157 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!monitor 58 + 158 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!instrume 59 + 159 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!sparem1 60 + 160 continue + return +!rcollima 61 + 161 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!ecollima 62 + 162 continue + ithick=1 + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + thlen=p1 + return +!yrot + 163 continue + return +!srot + 164 continue + return +!sparem2 + 165 continue + return +!beambeam + 166 continue + return +!matrix + 167 continue + return +!profile1d 68 + 168 continue + return +!yprofile 69 + 169 continue + return +!tprofile 70 + 170 continue + return +!hkick 71 + 171 continue + goto 151 +!vkick 72 + 172 continue + goto 152 +!kick 73 + 173 continue + goto 153 +!hpm 74 +!fix hpm later + 174 continue + return +!nlrf 75 + 175 continue + ithick=1 +c write(6,*) " === afro::isthick ===" +c write(6,*) " ith = ",ith +c write(6,*) " ithick = ",ithick + if(ith.eq.0)return + p1=pmenu(1+mpp(ith)) + p2=pmenu(2+mpp(ith)) + thlen=p2-p1 + return + end +c +c*********************************************************************** +c + subroutine trloop(string,nrept) +c----------------------------------------------------------------------- +c interprets loops +c Written by Rob Ryne ca 1984 +c adapted to use of strings and slightly simplified in logic +c by Petra Schuett 11-10-87 +c Fixed by Filippo Neri and Alex Dragt 8-29-88 +c----------------------------------------------------------------------- + use acceldata + use lieaparam, only : monoms + include 'impli.inc' +c-------- +c commons +c-------- + include 'stack.inc' + include 'files.inc' + include 'loop.inc' +c--------------- +c parameter type +c--------------- + character string*(*) +c----------------- +c local variables +c----------------- +c lempty = .true. , when stack is empty + logical lempty + save lempty +c----------------------------------------------------------------------- +c start +c----------------------------------------------------------------------- +c??????????????????????????????????????????????????????????????????????? +c printout counters: prints out first nm icons +c +c nm = 100 +c nc = 0 +c write(jof, 700) +c write(jodf,700) +c 700 format(/' entering trloop:'/) +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c +c procedure when nrept=0 +c + if(nrept.eq.0) then + write(jodf,508) string + write(jof, 508) string + 508 format(1x,'loop ',a16,' with rep no. = 0 has been ignored') + return + endif +c +c procedure when nrept .ne. 0 +c + lnrept=npm1(nrept) + joy=1 +c initialize the stacks + call initst(string,lnrept) +c +c----------------------------------------------------------------------- +c here we start with a stack element, either a new one or one that +c just has been popped +c + 1000 continue +c + if(ntype .eq. 1) then +c menu entry should never occur here ... + write(jodf,910) lstac(np) + write(jof ,910) lstac(np) + 910 format(1x,'error in trloop: menu entry ',a16, + & ' found at start of routine.') + call myexit + else if (ntype.eq.3) then +c ... neither should a lump + write(jodf,920) lstac(np) + write(jof ,920) lstac(np) + 920 format(1x,'error in trloop: lump ',a16, + & ' found at start of routine.') + call myexit + else if (ntype.eq.5) then +c unknown label is ignored + write(jodf,930) lstac(np) + write(jof, 930) lstac(np) + 930 format(1x,'warning from trloop: object ',a16,' not found.') +c +c main part is loops or lines (should be the only part used) +c + else if (ntype.eq.2 .or. ntype.eq.4) then +c +c here we begin a computational loop, handling simple +c entries in lines or loops +c + 2000 continue +c + if((ntype.eq.2 .or. ntype.eq.4) .and. + & (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith))) then +c end of a line or loop + loop(np) = loop(np) - npm1(loop(np)) + if(loop(np).ne.0) then + nslot(np) = newsl(np,ith) + call lookup(icon(nslot(np),ith),mtype,jth) + goto 1000 + endif + else if (mtype.eq.2 .and. irep(nslot(np),ith).eq.0) then +c if a line and rep no. = 0 ignore line + write(jodf,509) icon(nslot(np),ith) + write(jof, 509) icon(nslot(np),ith) + 509 format(1x,'line ',a16,' with rep no. = 0 has been ignored') + nslot(np) = nslot(np) + npm1(loop(np)) + if (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith)) goto 2000 + call lookup(icon(nslot(np),ith),mtype,jth) + goto 2000 + else if (mtype.eq.4 .and. irep(nslot(np),ith).eq.0) then +c if a loop and rep no. = 0 ignore loop + write(jodf,510) icon(nslot(np),ith) + write(jof, 510) icon(nslot(np),ith) + 510 format(1x,'loop ',a16,' with rep no. = 0 has been ignored') + nslot(np) = nslot(np) + npm1(loop(np)) + if (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith)) goto 2000 + call lookup(icon(nslot(np),ith),mtype,jth) + goto 2000 + else if (mtype.eq.5) then +c ignore unknown label + write(jodf,930) icon(nslot(np),ith) + write(jof, 930) icon(nslot(np),ith) + nslot(np) = nslot(np) + npm1(loop(np)) + if (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith)) goto 2000 + call lookup(icon(nslot(np),ith),mtype,jth) + goto 2000 + else if (mtype.eq.1 .or. mtype.eq.3) then +c line or loop points to a menu entry or lump + do 10 i=1,iabs(irep(nslot(np),ith)) + if(mtype.eq.1 .and. nt1(jth).eq.2) then +c user supplied element + if(nt2(jth).gt.5) then + write(jof ,940) icon(nslot(np),ith) + write(jodf,940) icon(nslot(np),ith) + 940 format(/' warning from trloop: ',a16,' is a usern', + & ' with n>5') + endif + mim(joy) = 5000+jth + elseif (mtype.eq.1) then +c other menu entry + mim(joy)=-jth + elseif (mtype.eq.3) then +c lump + mim(joy)=jth + endif + joy=joy+1 + 10 continue + if(joy.gt.joymax)then + write(jodf,950) joymax + write(jof ,950) joymax + 950 format(1x,'error: array length >= joymax (', & + & i6,') in trloop') + call myexit + endif +c - next item: + nslot(np) = nslot(np) + npm1(loop(np)) + if (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith)) goto 2000 + call lookup(icon(nslot(np),ith),mtype,jth) + goto 2000 + else if (mtype.eq.2 .or. mtype.eq.4) then +c line or loop points to line or loop + call push + goto 1000 + endif +c +c end of interpretation of a line/loop +c + endif +c end of main way through stack-element +c----------------------------------------------------------------------- +c pop stack; see what's there. this is the normal way to return +c + call pop(lempty) + if (lempty) then + joy = joy-1 + return + endif + goto 1000 +c + end +c +c*********************************************************************** +c + subroutine trobj(string,nrept,ntrk) +c----------------------------------------------------------------------- +c interprets lines and lumps +c Written by Rob Ryne ca 1984 +c Modified to store unmade lumps (tro5) +c +c New features: +c 1. Stores and retrieves unmade lumps in lines +c 2. Stores and retrieves nested lumps +c 3. Ignores lumps with nrept = 0 +c 4. Ignores lines with nrept = 0 +c +c Jim Howard CDG 7-7-87 +c +c adapted to use of strings and slightly simplified in logic +c Petra Schuett 11-9-87 +c +c modified by Alex Dragt 31 August 1988 +c----------------------------------------------------------------------- + use acceldata + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' +c-------- +c commons +c-------- + include 'stack.inc' + include 'core.inc' + include 'map.inc' + include 'files.inc' +c--------------- +c parameter type +c--------------- + character*16 string +c----------------- +c local variables +c----------------- + dimension thsave(monoms,mstack),tmhsav(6,6,mstack) +c making(np) = 1 while this lump is under construction + dimension making(mstack) +c lempty = .true. , when stack is empty + logical lempty + save thsave,tmhsav,making,lempty +c----------------------------------------------------------------------- +c start +c----------------------------------------------------------------------- +c initialize arrays +c + do 5 k = 1,mstack + making(k) = 0 + 5 continue + call initst(string,nrept) +c??????????????????????????????????????????????????????????????????????? +c printout counters: prints out first nm calls to lmnt +c +c nm = 100 +c nc = 0 +c write(jof, 700) +c write(jodf,700) +c 700 format(/' entering trobj:'/) +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c +c ignore incoming line with zero repetition number +c + if(ntype.eq.2.and.nrept.eq.0) then + write(jof , 510) ilbl(ith) + write(jodf, 510) ilbl(ith) + 510 format(1x,'line ',a16,' with rep no. = 0 has been ignored') + return + endif +c +c----------------------------------------------------------------------- +c here we start with a stack element, either a new one or one that +c just has been popped +c + 1000 continue +c + if(ntype .eq. 1) then +c menu element should never occur here ... + write(jodf,910) lstac(np) + write(jof ,910) lstac(np) + 910 format(1x,'error in trobj: menu element ',a16, & + & ' found at beginning of routine.') + call myexit + else if (ntype.eq.4) then +c ... neither should a loop + write(jodf,920) lstac(np) + write(jof ,920) lstac(np) + 920 format(1x,'error in trobj: loop ',a16, & + & ' found at beginning of routine.') + call myexit + else if (ntype.eq.5) then +c unknown label is ignored + write(jodf,930) lstac(np) + write(jof, 930) lstac(np) + 930 format(1x,'warning from trobj: object ',a16,' not found.') +c +c main part is lumps or lines (should be the only part used) +c + else if (ntype.eq.3 .and. loop(np).eq.0) then +c ignore lump with rep factor 0 + write(jof, 520) ilbl(ith) + write(jodf,520) ilbl(ith) + 520 format(1x,'lump ',a16,' with rep no. = 0 has been ignored') + else if (ntype.eq.3 .and. lmade(ith).ne.0) then +c a lump which is already in the core +c??????????????????????????????????????????????????????????????????????? +c write(jof, 710) ith +c write(jodf,710) ith +c 710 format(/' picking up old lump, no.',i4) +c if(nc.lt.nm) write(jodf,715) jth,lmade(jth),loop(np),np +c if(nc.lt.nm) write(jof, 715) jth,lmade(jth),loop(np),np +c 715 format(/5x,'jth =',i4,' lmade(jth) =',i4, +c & 5x,'lumprep =',i3,' np =',i3/) +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c - combine previously made lump with the total map + call comwtm(lmade(ith),loop(np)) +c + else if (ntype.eq.2 .or. ntype.eq.3) then +c all other lines and lumps +c +c first, lumps need special handling, if they are new + if (ntype.eq.3 .and. making(np).ne.1) then + making(np) = 1 +c??????????????????????????????????????????????????????????????????????? +c write(jodf,720) ith,np,loop(np) +c write(jof, 720) ith,np,loop(np) +c 720 format(/' starting lump no. ',i3, +c 1 ' np =',i3,' loop(np) =',i3/) +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c - save current map and initialize a new lump + call buffin(th,tmh,thsave,tmhsav,np) + call ident(th,tmh) + endif +c +c here we begin a computational loop, handling simple elements +c in lines or lumps +c + 2000 continue +c + if(ntype.eq.2 .and. & + & (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith))) then +c end of a line +c???????????????????????????????????????????????????????????????????????? +c if(nc.lt.nm) write(jodf,730) +c if(nc.lt.nm) write(jof, 730) +c 730 format(/' *********************** end of line') +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + loop(np) = loop(np) - npm1(loop(np)) + if(loop(np).ne.0) then + nslot(np) = newsl(np,ith) + call lookup(icon(nslot(np),ith),mtype,jth) + goto 1000 + endif + else if (ntype.eq.3 .and. & + & (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith))) then +c end of a lump +c???????????????????????????????????????????????????????????????????????? +c if(nc.lt.nm) write(jodf,740) +c if(nc.lt.nm) write(jof, 740) +c 740 format(/' *********************** end of lump') +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c - store lump + call lumpit(ith) +c - recall running total map + call bufout(thsave,tmhsav,th,tmh,np) +c - combine new lump with total map: +c??????????????????????????????????????????????????????????????????????? +c write(jof, 750) loop(np) +c write(jodf,750) loop(np) +c 750 format(/' combine new lump with total map: lumprep =',i3/) +c write(jof, 755) ith,lmade(ith) +c write(jodf,755) ith,lmade(ith) +c 755 format(/' ith =',i3,' lmade =',i3/) +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + call comwtm(lmade(ith),loop(np)) + making(np) = 0 + else if (mtype.eq.4) then +c lump or line points to a loop; error + write(jof, 940) lstac(np),icon(nslot(np),ith) + write(jodf,940) lstac(np),icon(nslot(np),ith) + 940 format(1x,'error in trobj: ',a16, & + & ' contains a loop (',a16,').') + call myexit + else if (mtype.eq.2 .and. irep(nslot(np),ith).eq.0) then +c if rep no. = 0 ignore line + write(jof ,510) icon(nslot(np),ith) + write(jodf,510) icon(nslot(np),ith) + nslot(np) = nslot(np) + npm1(loop(np)) + call lookup(icon(nslot(np),ith),mtype,jth) +c??????????????????????????????????????????????????????????????????????? +c if(nc.lt.nm) write(jodf,760) ith,mtype,jth +c if(nc.lt.nm) write(jof, 760) ith,mtype,jth +c 760 format(/' 0*line: ith, mtype, jth:'/5x,3i7) +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + goto 2000 + else if (mtype.eq.5) then +c ignore unknown label + write(jodf,930) icon(nslot(np),ith) + write(jof, 930) icon(nslot(np),ith) + nslot(np) = nslot(np) + npm1(loop(np)) + call lookup(icon(nslot(np),ith),mtype,jth) +c??????????????????????????????????????????????????????????????????????? +c if(nc.lt.nm) write(jodf,762) ith,mtype,jth +c if(nc.lt.nm) write(jof, 762) ith,mtype,jth +c 762 format(/' unkn. : ith, mtype, jth:'/5x,3i7) +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + goto 2000 + else if (mtype.eq.1) then +c line or lump points to an element +c??????????????????????????????????????????????????????????????????????? +c nc = nc + 1 +c if(nc.lt.nm) write(jodf,770) np +c if(nc.lt.nm) write(jof, 770) np +c 770 format(/' element in line or lump: np =',i3/) +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + call trlmnt(jth,irep(nslot(np),ith)) +c - next element: + nslot(np) = nslot(np) + npm1(loop(np)) +cryne Jan 6, 2005 added "if" test: + if(nslot(np).ge.1)then + call lookup(icon(nslot(np),ith),mtype,jth) + endif +c??????????????????????????????????????????????????????????????????????? +c if(nc.lt.nm) write(jodf,764) ith,mtype,jth +c if(nc.lt.nm) write(jof, 764) ith,mtype,jth +c 764 format(/' next icon: ith, mtype, jth:'/7x,3i7) +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + goto 2000 + else if (mtype.eq.2 .or. mtype.eq.3) then +c line or lump points to line or lump + call push +c??????????????????????????????????????????????????????????????????????? +c if(nc.lt.nm) write(jof, 780) np +c if(nc.lt.nm) write(jodf,780) np +c780 format(/' *********************** pushing stack: new np =',i3) +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + goto 1000 + endif +c +c end of interpretation of a line/lump +c + endif +c end of main way through stack-element +c----------------------------------------------------------------------- +c pop stack; see what's there. this is the normal way to return +c + call pop(lempty) + if (lempty) return +c +c??????????????????????????????????????????????????????????????????????? +c write(jof, 790) np +c write(jodf,790) np +c790 format(/' *************************** popping stack: new np =',i3) +c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c + goto 1000 + end +c +c end of file +c + subroutine old_set_pscale_mc(h,mh) +c scale a map to use mc as the scale momentum (instead of p0) + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'expon.inc' + double precision h(monoms),mh(6,6) +c +c This routine is needed if we want to use "dynamic" units, which +c makes sense, e.g., if the beam is being accelerated. +c It converts maps from the "usual" units (in which MaryLie lets the user +c specify any scale length and assumes a scale momentum p0) +c to units where +c THE REST OF THIS COMMENT IS WRONG. FIX LATER. RDR +cthe new scale length is given by l=c/w (where w is a scale +c frequency = 2pi*the freq specified by the user in the new #beam component) +c and where the new scale momentum is m*c +c +c Skip this routine if we are using magnetostatic units (the "usual" units) +c write(6,*)'****************************************************' +c write(6,*)'**************HERE I AM IN SETPSCALEMC**************' +c write(6,*)'****************************************************' +c +c exit if "magnetic" units (i.e. standard MaryLie units) are being used: + if(lflagmagu)return +c see if "dynamic" units are being used; change only affects the momenta +c since the MaryLie library routines include the effect of sl: + if(lflagdynu)then +c write(6,*)'dynamic units.' + x2ovrx1=1. + p2ovrp1=1./(beta*gamma) + else +c some other units are being used: +c write(6,*)'general units.' + x2ovrx1=1. + p2ovrp1=p0sc/(beta*gamma*pmass/c) + endif + + x1ovrx2=1./x2ovrx1 + p1ovrp2=1./p2ovrp1 +cdebug +c write(6,*)'inside set_pscale' + +c bg=beta*gamma +c bgi=1./bg +c +ctm mh(1,2:6:2)=mh(1,2:6:2)/bg +ctm mh(3,2:6:2)=mh(3,2:6:2)/bg +ctm mh(5,2:6:2)=mh(5,2:6:2)/bg +c +ctm mh(2,1:5:2)=mh(2,1:5:2)*bg +ctm mh(4,1:5:2)=mh(4,1:5:2)*bg +ctm mh(6,1:5:2)=mh(6,1:5:2)*bg +ctm replace f90 array code with f77 do loops: +crdr replace beta*gamma with more general form: + do 100 i = 2, 6, 2 + do 70 j = 1, 5, 2 + mh(j,i) = mh(j,i)*p2ovrp1*x1ovrx2 + mh(i,j) = mh(i,j)*p1ovrp2*x2ovrx1 + 70 continue + 100 continue +c +cryne 08/26/2001 +c now change the units of the nonlinear part of the map: + do 200 i=28,209 +c h(i)=h(i)*bgi**(expon(2,i)+expon(4,i)+expon(6,i)) +c h(i)=h(i)*bgi**exp246(i) + h(i)=h(i)*(p2ovrp1**nxp246(i))*(x2ovrx1**nxp135(i)) + 200 continue + return + end +c + subroutine set_pscale_mc(h,mh) +c scale a map to use mc as the scale momentum (instead of p0) + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'expon.inc' + double precision h(monoms),mh(6,6) +c +c write(6,*)'=== afro::set_pscale_mc() ===' +c write(6,*) 'beta, gamma, pmass, brho = ',beta,gamma,pmass,brho +c write(6,*) 'scale l, p, t, w, f= ',sl,p0sc,ts,omegascl,freqscl +c +cryne Jan 30,2003 +c this routine does 2 things: +c (1) convert from static to dynamic units (if needed), +c (2) convert variables 5 and 6 to take into account the fact that the +c scale varables omega and l are independent and do not need to +c satisfy omega*l/c=1 (as is assumed in the MaryLie library routines) +c + clite=299792458.d0 +c dynamic units: +calsowrong p2ovrp1=1.d0 + p2ovrp1=p0sc/(gamma*beta*pmass/clite) +c write(6,*)'initializing p2ovrp1 to ',p2ovrp1 +c + if(lflagdynu)then + p2ovrp1=1./(beta*gamma) +c write(6,*)'lflagdynu is true; resetting p2ovrp1 to ',p2ovrp1 + endif +cwrong: if(lflagdynu)p2ovrp1=(pmass/clite)/p0sc +cryne the reason this was wrong is that the MaryLie library +cryne routines use brho, the p0sc.In other words, everything +cryne is computed relative to the present momentum. + p1ovrp2=1.d0/p2ovrp1 +c omega*l/c: + scal5=1.d0 + scal6=1.d0 + wlbyc=omegascl*sl/clite +c write(6,*)'initializing wlbyc to ',wlbyc + if(wlbyc.ne.1.d0)then +c write(6,*)'scal5 being set to wlbyc, scal6 set to 1/wlbyc' + scal5=wlbyc + scal6=1.d0/wlbyc + endif +c + mh(1,2)=mh(1,2)*p2ovrp1 + mh(1,4)=mh(1,4)*p2ovrp1 + mh(1,5)=mh(1,5)/wlbyc + mh(1,6)=mh(1,6)*p2ovrp1*wlbyc +c + mh(2,1)=mh(2,1)*p1ovrp2 + mh(2,3)=mh(2,3)*p1ovrp2 + mh(2,5)=mh(2,5)*p1ovrp2/wlbyc + mh(2,6)=mh(2,6)*wlbyc +c + mh(3,2)=mh(3,2)*p2ovrp1 + mh(3,4)=mh(3,4)*p2ovrp1 + mh(3,5)=mh(3,5)/wlbyc + mh(3,6)=mh(3,6)*p2ovrp1*wlbyc +c + mh(4,1)=mh(4,1)*p1ovrp2 + mh(4,3)=mh(4,3)*p1ovrp2 + mh(4,5)=mh(4,5)*p1ovrp2/wlbyc + mh(4,6)=mh(4,6)*wlbyc +c + mh(5,1)=mh(5,1)*wlbyc + mh(5,2)=mh(5,2)*p2ovrp1*wlbyc + mh(5,3)=mh(5,3)*wlbyc + mh(5,4)=mh(5,4)*p2ovrp1*wlbyc + mh(5,6)=mh(5,6)*p2ovrp1*wlbyc**2 +c + mh(6,1)=mh(6,1)*p1ovrp2/wlbyc + mh(6,2)=mh(6,2)/wlbyc + mh(6,3)=mh(6,3)*p1ovrp2/wlbyc + mh(6,4)=mh(6,4)/wlbyc + mh(6,5)=mh(6,5)*p1ovrp2/wlbyc**2 +c +c now change the units of the nonlinear part of the map: +cryne 12/21/2004 changed "i=28,209" to "i=28,monoms" !!!!!!!!!!!!!! +c write(6,*)'modified set_pscale_mc do loop to use monoms=',monoms + do 200 i=28,monoms +ccc h(i)=h(i)*(p2ovrp1**nxp246(i))*(x2ovrx1**nxp135(i)) +!!! h(i)=h(i)*(p2ovrp1**nxp24(i))*(scal5**nxp5(i))*(scal6**nxp6(i)) +cryne 12/21/2004 note that this is a minus 1 only in nxp13 and nxp24 +cryne note that we are assuming that the scale length has been done already +! h(i)=h(i)*(p2ovrp1**(nxp24(i)+nxp6(i)))*(scal5**(nxp5(i)-nxp6(i))) + h(i)=h(i)*(p2ovrp1**(nxp24(i)+nxp6(i)))*(scal5**(nxp6(i)-nxp5(i))) + 200 continue + return + end +c + subroutine set_rfscale(h,mh) +c Nov 5, 2003 +c scale the map produced by subroutine rfgap (if needed) +c note that the rf gap routine returns a map assuming +c dynamic units, with a scale length l=c/omega + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'expon.inc' + double precision h(monoms),mh(6,6) +c +c switch to static units if needed: +c rf gap routine works in "dynamic" units, with p1=mc; +c If MLI is using "static" units, this routine transforms +c to p2=the scale momentum p0sc +c therefore p2ovrp1=p0sc/mc if shifting to static mode + clite=299792458.d0 + p2ovrp1=1.d0 + if(.not.lflagdynu)p2ovrp1=p0sc/(pmass/clite) + p1ovrp2=1.d0/p2ovrp1 +c +c Use this if the rfgap routine works internally assuming q1=c/omega, +c with the scale ang freq (internally) equal to the MLI scale ang freq: +c In this case, q2 is the MLI scale length, therefore q2ovrq1=sl/(c/omega) +cryne 5/1/2006 uncommented these: + q2ovrq1=sl/(clite/omegascl) + q1ovrq2=1.d0/q2ovrq1 + w2ovrw1=1.d0 + w1ovrw2=1.d0/w2ovrw1 +c +c Use this if the rfgap routine works internally assuming a +c scale ang freq given by omega=c/sl, with the scale length +c (internally) equal to the MLI scale length: In this case +c w2 is the MLI scale ang freq, therefore w2ovrw1=omegascl/(c/sl) +cryne 5/1/2006 commented out the following: +c w2ovrw1=omegascl/(clite/sl) +c w1ovrw2=1.d0/w2ovrw1 +c q2ovrq1=1.d0 +c q1ovrq2=1.d0/q2ovrq1 +c +c Scale linear part of the map. + mh(1,2)=mh(1,2)*p2ovrp1*q1ovrq2 + mh(1,4)=mh(1,4)*p2ovrp1*q1ovrq2 + mh(1,5)=mh(1,5)*w1ovrw2*q1ovrq2 + mh(1,6)=mh(1,6)*p2ovrp1*w2ovrw1 +c + mh(2,1)=mh(2,1)*p1ovrp2*q2ovrq1 + mh(2,3)=mh(2,3)*p1ovrp2*q2ovrq1 + mh(2,5)=mh(2,5)*p1ovrp2*w1ovrw2 + mh(2,6)=mh(2,6)*w2ovrw1*q2ovrq1 +c + mh(3,2)=mh(3,2)*p2ovrp1*q1ovrq2 + mh(3,4)=mh(3,4)*p2ovrp1*q1ovrq2 + mh(3,5)=mh(3,5)*w1ovrw2*q1ovrq2 + mh(3,6)=mh(3,6)*p2ovrp1*w2ovrw1 +c + mh(4,1)=mh(4,1)*p1ovrp2*q2ovrq1 + mh(4,3)=mh(4,3)*p1ovrp2*q2ovrq1 + mh(4,5)=mh(4,5)*p1ovrp2*w1ovrw2 + mh(4,6)=mh(4,6)*w2ovrw1*q2ovrq1 +c + mh(5,1)=mh(5,1)*w2ovrw1*q2ovrq1 + mh(5,2)=mh(5,2)*w2ovrw1*p2ovrp1 + mh(5,3)=mh(5,3)*w2ovrw1*q2ovrq1 + mh(5,4)=mh(5,4)*w2ovrw1*p2ovrp1 + mh(5,6)=mh(5,6)*q2ovrq1*p2ovrp1*w2ovrw1**2 +c + mh(6,1)=mh(6,1)*w1ovrw2*p1ovrp2 + mh(6,2)=mh(6,2)*w1ovrw2*q1ovrq2 + mh(6,3)=mh(6,3)*w1ovrw2*p1ovrp2 + mh(6,4)=mh(6,4)*w1ovrw2*q1ovrq2 + mh(6,5)=mh(6,5)*q1ovrq2*p1ovrp2*w1ovrw2**2 +c +cryne 08/26/2001 +cryne 11/06/2003 +c now change the units of the nonlinear part of the map: + scal6=w2ovrw1*q2ovrq1*p2ovrp1 +cryne 12/21/2004 changed "i=28,209" to "i=28,monoms" +cryne (this does not matter now, but will matter when we do nonlinear rf maps) +c write(6,*)'(subroutine set_rfscale): need to fix scaling of the' +c write(6,*)'nonlinear part of rfgap map; it is probably wrong!!' +cabell =Tue Dec 28 08:32:15 PST 2004= Think I've fixed scaling here. +cccryne 22 May 2006 -- Since this is only called by rfgap (i.e. only the linear +ccc map is produced), skip the scaling of the nonlinear part +ccc write(6,*)'(subroutine set_rfscale): still need to verify scaling' +ccc write(6,*)'of nonlinear part of rfcavity!! **********************' +ccc do 200 i=28,monoms +ccc h(i)=h(i)*(q2ovrq1**(nxp13(i)+nxp6(i))) & +ccc & *(p2ovrp1**(nxp24(i)+nxp6(i))) & +ccc & *(w2ovrw1**(nxp6(i)-nxp5(i))) +cabell this is equivalent to above +c h(i)=h(i)*(p2ovrp1**nxp24(i))*(q2ovrq1**nxp13(i)) & +c & *(w1ovrw2**nxp5(i))*(scal6**nxp6(i)) +cabell this is ok if scale lengths are equal +c h(i)=h(i)*(p2ovrp1**(nxp24(i)+nxp6(i))) & +c & *(w2ovrw1**(nxp6(i)-nxp5(i))) +ccc200 continue + return + end +c + +c\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +c============================================================================== +c////////////////////////////////////////////////////////////////////////////// + + subroutine rescale_map(lsold,psold,fsold,h,mh,lsnew,psnew,fsnew) +c------------------------------------------------------------------------------ +c +c rescale_map: Takes given values for the scale factors of a given map +c and rescales the map to the currently defined scale factors. +c Optionally, it can take a list of new scale factors, instead +c of assuming the currently defined scale factors. +c +c input: +c +c lsold - given length scale of map +c psold - given momentum scale of map +c fsold - given frequency scale of map +c h - non-linear coefficients of given map +c mh - matrix part of given map +c +c OPTIONAL input: (all must be present to work!!!) +c +c lsnew - length scale to scale map TO +c psnew - momentum scale to scale map TO +c fsnew - frequency scale to scale map TO +c +c output: +c +c h - rescaled map +c mh - rescaled map +c +c KMP - 15 Dec 2006 +c +c------------------------------------------------------------------------------ + use lieaparam, only : monoms + use beamdata, only : sl,p0sc,freqscl + implicit none + include 'expon.inc' + double precision, intent(in) :: lsold,psold,fsold ! scale factors of given map + double precision, optional, intent(in) :: lsnew,psnew,fsnew ! new scale factors to use in scaling + double precision, intent(inout), dimension(1:6,1:6) :: mh + double precision, intent(inout), dimension(1:monoms) :: h + double precision p2ovrp1,p1ovrp2 + double precision q2ovrq1,q1ovrq2 + double precision w2ovrw1,w1ovrw2 + integer i,j +c + if(psold.eq.0.)then + write(*,*) 'error (rescale_map): zero momentum scale given' + call myexit + elseif(lsold.eq.0.)then + write(*,*) 'error (rescale_map): zero length scale given' + call myexit + elseif(fsold.eq.0.)then + write(*,*) 'error (rescale_map): zero frequency scale given' + call myexit + endif + + if(present(lsnew).and.present(psnew).and.(present(fsnew)))then + if(psnew.eq.0.)then + write(*,*) 'error (rescale_map): zero momentum scale given' + call myexit + elseif(lsnew.eq.0.)then + write(*,*) 'error (rescale_map): zero length scale given' + call myexit + elseif(fsnew.eq.0.)then + write(*,*) 'error (rescale_map): zero frequency scale given' + call myexit + endif + p1ovrp2 = psold / psnew + p2ovrp1 = psnew / psold + q1ovrq2 = lsold / lsnew + q2ovrq1 = lsnew / lsold + w1ovrw2 = fsold / fsnew + w2ovrw1 = fsnew / fsold + else + p1ovrp2 = psold / p0sc + p2ovrp1 = p0sc / psold + q1ovrq2 = lsold / sl + q2ovrq1 = sl / lsold + w1ovrw2 = fsold / freqscl + w2ovrw1 = freqscl / fsold + endif +c + mh(1,2)=mh(1,2)*p2ovrp1*q1ovrq2 + mh(1,4)=mh(1,4)*p2ovrp1*q1ovrq2 + mh(1,5)=mh(1,5)*w1ovrw2*q1ovrq2 + mh(1,6)=mh(1,6)*p2ovrp1*w2ovrw1 +c + mh(2,1)=mh(2,1)*p1ovrp2*q2ovrq1 + mh(2,3)=mh(2,3)*p1ovrp2*q2ovrq1 + mh(2,5)=mh(2,5)*p1ovrp2*w1ovrw2 + mh(2,6)=mh(2,6)*w2ovrw1*q2ovrq1 +c + mh(3,2)=mh(3,2)*p2ovrp1*q1ovrq2 + mh(3,4)=mh(3,4)*p2ovrp1*q1ovrq2 + mh(3,5)=mh(3,5)*w1ovrw2*q1ovrq2 + mh(3,6)=mh(3,6)*p2ovrp1*w2ovrw1 +c + mh(4,1)=mh(4,1)*p1ovrp2*q2ovrq1 + mh(4,3)=mh(4,3)*p1ovrp2*q2ovrq1 + mh(4,5)=mh(4,5)*p1ovrp2*w1ovrw2 + mh(4,6)=mh(4,6)*w2ovrw1*q2ovrq1 +c + mh(5,1)=mh(5,1)*w2ovrw1*q2ovrq1 + mh(5,2)=mh(5,2)*w2ovrw1*p2ovrp1 + mh(5,3)=mh(5,3)*w2ovrw1*q2ovrq1 + mh(5,4)=mh(5,4)*w2ovrw1*p2ovrp1 + mh(5,6)=mh(5,6)*q2ovrq1*p2ovrp1*w2ovrw1**2 +c + mh(6,1)=mh(6,1)*w1ovrw2*p1ovrp2 + mh(6,2)=mh(6,2)*w1ovrw2*q1ovrq2 + mh(6,3)=mh(6,3)*w1ovrw2*p1ovrp2 + mh(6,4)=mh(6,4)*w1ovrw2*q1ovrq2 + mh(6,5)=mh(6,5)*q1ovrq2*p1ovrp2*w1ovrw2**2 +c + do i=28,monoms + h(i)=h(i)*(q2ovrq1**(nxp13(i)+nxp6(i))) + & *(p2ovrp1**(nxp24(i)+nxp6(i))) + & *(w2ovrw1**(nxp6(i)-nxp5(i))) + enddo + return + end + + +************************************************************************ + subroutine mlfinc(incnam) +c----------------------------------------------------------------------- + use beamdata + use acceldata + use lieaparam, only : monoms + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- +c + include 'codes.inc' + include 'files.inc' +c----------------------------------------------------------------------- +c arguments: + character incnam*(*) +c local variables: + character*16 strarr(40),string + character*100 line + integer narr(40) + logical leof,lcont,npound +cryne 8/15/2001 new code to read in a character string instead of numbers: +c----------------------------------------------------------------------- +c start + lfold=lf + lf=98 +cryne----- 15 Sept 2000 modified to check for input file: + open(lf,file=incnam,status='old',err=357) + itot = 0 + leof = .false. + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm write(6,333) line +ctm 333 format(' first line in include file:',/,a) + if(leof)then + write(6,*)'error: empty file:',incnam + stop + endif + goto 4320 +ctm 357 write(6,*)'error: empty file:', incnam +c +ctm error opening include file +c + 357 continue + write(jof,358) incnam + write(jodf,358) incnam + 358 format(' ERROR: cannot open #include file: ',/,a) + call myexit +cryne----- +c----------------------------------------------------------------------- + 4320 continue + leof = .false. + rewind lf + msegm = -1 +c-------------------- +c read first line of master input file (should set msegm) +c + 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 +c-------------------- +c new component (segment) begins, branch to appropriate part of code +c + 1 goto(100,200,300,400,500,600,700,800),msegm +c +c error exit: + write(jof ,99) msegm + write(jodf,99) msegm + 99 format(1x,i6,'=msegm problem at big goto of routine mlfinc') + call myexit +c-------------------- +c #comment +c + 100 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 1) goto 1 +c + npcom=npcom+1 + if(npcom.gt.maxcmt) then + write(jof ,199) maxcmt + write(jodf,199) maxcmt + 199 format(1x,'error in dumpin:', & + & ' too many comment lines (>= maxcmt = ',i6,') in #comment') + call myexit + endif + mline(npcom)=line + goto 100 +c-------------------- +c #beam +c + 200 continue + write(6,*)'error: cannot have #beam when using mlfinc' + stop +c-------------------- +c #menu +c + 300 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 3) goto 1 +c + na=na+1 + if(na.gt.mnumax) then + write(jof ,399) mnumax + write(jodf,399) mnumax + 399 format(1h ,'error in dumpin:', & + & ' too many items (>= mnumax = ',i6,') elements in #menu') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,396) strarr(1) + write(jodf,396) strarr(1) + 396 format(' error detected by dumpin in #menu: name ', & + & a8,' is doubly defined'/ & + & ' the second definition will be ignored') + na = na-1 + goto 300 + endif +c check if element/command name is present ( F. Neri 4/14/89 ): + if ( itot .lt. 2 ) then + write(jof ,1396) strarr(1) + write(jodf ,1396) strarr(1) + 1396 format(' error in #menu: ',a8,' has no type code!') + call myexit + endif + if ( itot .gt. 2 ) then + write(jof ,1397) strarr(1) + write(jodf ,1397) strarr(1) + 1397 format(' error in #menu: ',a8,' has more than one type code!') + call myexit + endif +c new item in menu: + lmnlbl(na)=strarr(1) +c string is name of element/command type, look up element indices + string=strarr(2) + do 325 m = 1,9 +cryne do 325 n = 1,40 +cryne 7/3/02 do 325 n = 1,45 + do 325 n = 1,nrpmax + if(string.eq.ltc(m,n)) then + nt1(na) = m + nt2(na) = n +c read parameters. Number of parameters is given in nrp + imax=nrp(m,n) + if(imax.eq.0)goto 300 + mpp(na) = mpprpoi +cryne---8/15/2001 + if((m.eq.1).and.(n.eq.42.or.n.eq.43.or.n.eq.44))then +c read a character string +cryne 08/24/2001 + mpp1=mppc(na)+1 +cryne read(lf,*,err=390)(cmenu(1+mppc(na))) + read(lf,*,err=390)cmenu(mpp1) + pmenu(1+mpp(na))=1+mpp(na) + mpprpoi=mpprpoi+1 + goto 300 + else +cryne--- + read(lf,*,err=390)(pmenu(i+mpp(na)),i=1,imax) + mpprpoi = mpprpoi + imax + goto 300 + endif +c normal end of a menu element/command + endif + 325 continue +c +c error: unknown element/command name + write(jof ,398)(strarr(j),j=1,2) + write(jodf,398)(strarr(j),j=1,2) + 398 format(1h ,'dumpin error in ',a8,': type code ',a8,' not found.'/ & + & 1h ,'this item will be ignored') + na=na-1 + goto 300 +c +c error in parameter input + 390 write(jof ,397)lmnlbl(na) + write(jodf,397)lmnlbl(na) + 397 format(1h ,'dumpin data input error at item ',a8) + call myexit +c-------------------- +c #lines,#lumps,#loops +c + 400 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 4) goto 1 + goto 410 + 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 5) goto 1 + goto 410 + 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 6) goto 1 +c + 410 nb=nb+1 + if(nb.gt.itmno)then + write(jof ,499) itmno + write(jodf,499) itmno + 499 format(1h ,'error in dumpin:', & + & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,497) ling(msegm),strarr(1) + write(jodf,497) ling(msegm),strarr(1) + 497 format(1x,'dumpin error in ', & + & a8,': name ',a8,' is doubly defined'/ & + & ' the second definition will be ignored') + na = na-1 + if(msegm .eq.4) then + goto 400 + else if(msegm.eq.5) then + goto 500 + else if(msegm.eq.6) then + goto 600 + endif + endif +c new item + ilbl(nb)=strarr(1) +c read components of item + imin=0 +c-- +c repeat... + 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if(imin+itot.gt.itmln)then + write(jof ,498) itmln,ilbl(nb) + write(jodf,498) itmln,ilbl(nb) + 498 format(1h ,'error in dumpin:', & + & ' too many entries (> itmln = ',i6,') in ',a16) + call myexit + endif +c store names and rep rates of components + do 425 i=1,itot + icon(imin+i,nb)=strarr(i) + irep(imin+i,nb)=narr(i) + 425 continue + imin=imin+itot + if(lcont) goto 420 +c ... until no more continuation lines +c-- +c now set length and type of element + ilen(nb)=imin + ityp(nb)=msegm-2 +c go back to appropriate component (segment) + if(msegm .eq.4) then + goto 400 + else if(msegm.eq.5) then + goto 500 + else if(msegm.eq.6) then + goto 600 + endif +c-------------------- +c #labor +c + 700 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 7) goto 1 +c + noble=noble+1 + if(noble.gt.mlabor) then + write(jof ,799) mlabor + write(jodf,799) mlabor + 799 format(1h ,'error in dumpin:', & + & ' too many entries (>= mlabor = ',i6,') in #labor array') + call myexit + endif +c new task + latt(noble)=strarr(1) + num(noble)=narr(1) + goto 700 +c-------------------- +c #include + 800 continue + write(6,*)'error: cannot use #include with mlfinc' + stop +c normal return at end of file + 1000 continue + close(98) + lf=lfold + return + end +c +c*********************************************************************** + subroutine autoapp(n) + use parallel, only : idproc + use acceldata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'map.inc' + character*16 string + character*16 autostr + real*8 thlen + common/autopnt/autostr(3) + common/autolog/lautoap1,lautoap2,lautoap3,lrestrictauto + common/showme/iverbose +c---dummy variables needed in calls to lmnt: + jslice=1 + jsltot=1 + slfrac=1. + ntrk=0 +c--- +c string is the value of parameter "name" in the autoapply command + string=autostr(n) + if(iverbose.eq.2)write(6,*)'(inside autoapp) n,string=',n,string +c this version works only if the object is a either menu element or a line + call lookup(string,itype,ith) + if(iverbose.eq.2)write(6,*)'back from lookup; string,itype,ith=' + if(iverbose.eq.2)write(6,*)string,itype,ith +cryne Oct 30, 2003 + if(itype.eq.5)then + if(idproc.eq.0)then + write(6,*)'error: trying to perform autoapply, but the item' + write(6,*)string(1:16) + write(6,*)'has not been successfuly defined in the menu' + endif + call myexit + endif + mt1=nt1(ith) + mt2=nt2(ith) + l1=1+mpp(ith) + l2=1+mppc(ith) +c element: + if(itype.eq.1)then + if(iverbose.eq.2)write(6,*)'string ',string,' is a menu item' +c don't allow automatic application of thick elements + call isthick(mt1,mt2,ithick,thlen,0) + if(ithick.eq.1)write(6,*)'error: thick element found!:',string + if(ithick.eq.1)return + call lmnt(mt1,mt2,pmenu(l1),cmenu(l2),ntrk,jslice,jsltot,slfrac,0) + if(iverbose.eq.2)write(6,*)'normal return from autoapp' + return + endif +c step through the line: + if(itype.eq.2)then + if(iverbose.eq.2)write(6,*)'string ',string,' is a line' + if(iverbose.eq.2) & + & write(6,*)'ith,ilbl(ith),ilen(ith)=',ith,ilbl(ith),ilen(ith) + do 100 k=1,ilen(ith) + call lookup(icon(k,ith),ktype,kth) + if(ktype.ne.1)then + if(idproc.eq.0)then + write(6,*)'error in autoapp:',string,icon(k,ith) + if(ktype.eq.2)write(6,*)'cannot handle nested lines' + if(ktype.eq.3)write(6,*)'cannot handle lumps' + if(ktype.eq.4)write(6,*)'cannot handle loops' + if(ktype.eq.5)write(6,*)'cannot find entry: ',icon(k,ith) + endif + call myexit + endif + kt1=nt1(kth) + kt2=nt2(kth) + l1=1+mpp(kth) + l2=1+mppc(kth) + call isthick(kt1,kt2,ithick,thlen,0) + if(ithick.eq.1)write(6,*)'error:thick lmnt in line!:',icon(k,2) + if(ithick.eq.1)return + do 99 iii=1,iabs(irep(k,ith)) + if(iverbose.eq.2)write(6,*)'icon(k,ith)=',icon(k,ith) + call lmnt(kt1,kt2,pmenu(l1),cmenu(l2),ntrk,jslice,jsltot,slfrac,0) + 99 continue + 100 continue + if(iverbose.eq.1)write(6,*)'normal return from autoapp' + return + endif +c can autoapply only menu entries or simple lines. +c complain that you cannot autoapply lumps or loops + if(itype.eq.3 .or. itype.eq.4)then + write(6,*)'autoapp: error: lump or loop not allowed:',string + return + endif + if(itype.eq.5)then + write(6,*)'autoapp:string not found:',string + return + endif + end +c +************************************************************************ + subroutine autospch(tau,ntrk) + use beamdata + use rays + use lieaparam, only : monoms + use ml_timer + include 'impli.inc' + include 'map.inc' + include 'files.inc' + logical msk,straight + character*16 cparams +!3/6/03 dimension c4(4,maxray),c6(6,maxray),msk(maxray) +!3/6/03 dimension ex(maxray),ey(maxray),ez(maxray) +!3/6/03 dimension tmp(maxray),tmpr(maxray) + dimension c4(4,maxrayp),c6(6,maxrayp),msk(maxrayp) + dimension ex(maxrayp),ey(maxrayp),ez(maxrayp) + dimension tmp(maxrayp),tmpr(maxrayp) +!hpf$ distribute (*,block) :: c6 +!hpf$ align (*,:) with c6(*,:) :: c4 +!hpf$ align (:) with c6(*,:) :: ex,ey,ez,tmp,tmpr,msk + common/robhack/zlocate + common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0 + common/poiblock1/nspchset,nsckick + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + common/newpoisson/idirectfieldcalc,idensityfunction,idummy(4) + common/scparams/rparams(60),cparams(60) + common/showme/iverbose + common/envstuff/nenvtrk + common/autotrk/lautotrk,ntrktype,ntrkorder +c +c write(6,*)'inside autospch' +cryne-April 8, 2004 new code for integrating envelope equations + if(nenvtrk.eq.1)then +c write(6,*)'calling envkick' + call envkick(tau) +c write(6,*)'returned from envkick' + endif + if(ntrktype.eq.0)return +c write(6,*)'still inside autospch, performing space charge calc' +cryne-Now continue with the usual space-charge calculation +c +c check that space charge parameters have been set: +c note that the elements of rparams are initialized to -9999999. +c + if(rparams(1).lt.-1.d6)then + if(idproc.eq.0)then + write(6,*)'ERROR: ATTEMPT TO TRACK WITH SPACE CHARGE,' + write(6,*)'BUT POISSON SOLVER PARAMETERS HAVE NOT BEEN SET.' + write(6,*)'RERUN WITH INPUT MODIFIED TO INCLUDE POISSON' + endif + call myexit + endif +c +c +c if(curr0.eq.-99999.)then +c write(6,*) & +c & 'error:entered space charge routine but current has not been set' +c stop +c endif +cryne 1/6/03 tau=2.d0*prevlen + curr=bcurr +! if(idproc.eq.0)write(12,*)'[autospch]curr,tau=',curr,tau + if(curr.eq.0.)then + if(iverbose.eq.2)write(6,*)'returning from sc routine (curr=0)' + return + endif +ccc + straight=.true. +c if(nt2prev.eq.2 .or. nt2prev.eq.4)straight=.false. + + nx0=nxsave + ny0=nysave + nz0=nzsave +c write(6,*)'nx0,ny0,nz0=',nx0,ny0,nz0 +c + clite=299792458.d0 + fpei=clite*clite*1.d-7 + vz0=beta*clite + perv=2.d0*curr*fpei/(brho*vz0*vz0*gamma*gamma) +c write(6,*)'perv=',perv +c write(6,*)'curr,brho,gamma=',curr,brho,gamma +c write(6,*)'fpei,beta,vz0=',fpei,beta,vz0 +cryne 11/19/02 if(nraysp.ne.maxrayp)then +cryne 11/19/02 write(6,*)'error:autospch works only w/ nrays=maxrayp' +cryne 11/19/02 write(6,*)'nraysp,maxrayp=',nraysp,maxrayp +cryne 11/19/02 stop +cryne 11/19/02 endif + if(nz0.eq.0)then + do j=1,nraysp + c4(1,j)=sl*zblock(1,j) + c4(2,j)= zblock(2,j) + c4(3,j)=sl*zblock(3,j) + c4(4,j)= zblock(4,j) + enddo +!******************************************************* + do j=1,nraysp + if(istat(j).eq.0)then + msk(j)=.true. + else + msk(j)=.false. + endif + enddo + if(nraysp.lt.maxrayp)then + do j=nraysp+1,maxrayp + msk(j)=.false. + enddo + endif +!******************************************************* + nx=nx0 + ny=ny0 + n1=2*nx + n2=2*ny +! if(idproc.eq.0)then +! write(6,*)'Note: 2D space charge only works in static units' +! endif + if(idirectfieldcalc.eq.0)then +! if(idproc.eq.0)write(6,*)'calling spch2dphi' + call spch2dphi(c4,ex,ey,msk,nraysp,nrays,nx,ny,n1,n2) + else +! if(idproc.eq.0)write(6,*)'calling slic2d' + call spch2ddirect(c4,ex,ey,msk,nraysp,nrays,nx,ny,n1,n2) + endif +!4/28/03 put 1/nrays in spch2d +!4/28/03 also put 1/2pi in spch2d, which means need *2pi here +!4/28/03xycon=perv/nrays + twopi=4.d0*asin(1.d0) + xycon=twopi*perv +c 4/26/03 case of dynamic units not yet tested, but this should work: + if(.not.lflagmagu)then + xycon=xycon*gamma*beta + endif + do i=1,nraysp + ex(i)=ex(i)*xycon + ey(i)=ey(i)*xycon + enddo +c + do j=1,nraysp + zblock(2,j)=zblock(2,j)+tau*ex(j) + zblock(4,j)=zblock(4,j)+tau*ey(j) + enddo + zlocate=zlocate+tau + return + endif +c + if(nz0.ne.0)then + if(iverbose.eq.2.and.idproc.eq.0)write(6,*)'3D spchrg' + do j=1,nraysp + do i=1,6 + c6(i,j)=zblock(i,j) + enddo + enddo +c +c +cryne bbyk=beta*sl !Jan 31, 2003 + bbyk=beta*clite/omegascl +c use ex as a temporary to hold beta of the nth particle: +cryne 3/4/2004 do j=1,nraysp +cryne 3/4/2004 ex(j)=(gamma-c6(6,j))**2-1.-c6(2,j)**2-c6(4,j)**2 +cryne 3/4/2004 ex(j)=sqrt(ex(j))/(gamma-c6(6,j)) +cryne 3/4/2004 enddo +c gamma (not gamma of the nth particle) takes us to the bunch frame: +c this converts phases to z-positions relative to the fiducial ptcl: +c Rob: need to check signs!!! +c Also, convert x and y to their values at the fixed time: +c c6(5,1:nraysp)=c6(5,1:nraysp)*ex(1:nraysp)*sl*gamma +c c6(1,1:nraysp)=(c6(1,1:nraysp)+c6(2,1:nraysp)*c6(5,1:nraysp))*sl +c c6(3,1:nraysp)=(c6(3,1:nraysp)+c6(4,1:nraysp)*c6(5,1:nraysp))*sl +c same formulae as Impact code: +c 09/04/01 commented out code to treat space charge in bending magnets. +c will fix later. rdr and ctm +c if(.not.straight)then +c rho=rhoprev +c theta0=arclen/rho+3.*asin(1.0d0) +c write(6,*)'****************** NT2PREV,RHO=',nt2prev,rho +c 0th order approximation for theta: +c tmp(1:nraysp)=-zblock(5,1:nraysp)*sl*beta/rho +c 1st order approximation for theta: +c tmp(:)=tmp(:)-sl/rho*sin(tmp(:))*c6(1,:) +c tmpr(:)=zblock(1,:)*cos(tmp(:))+ +c & zblock(2,:)*(rho/sl)/(beta*gamma)*sin(tmp(:))- +c & zblock(6,:)*(rho/sl)/(beta*gamma)/beta*(1.-cos(tmp(:))) +c c6(1,:)=(rho/sl+tmpr(:))*sl*sin(theta0+tmp(:)) +c c6(5,:)=(rho/sl+tmpr(:))*sl*cos(theta0+tmp(:)) +c c6(3,1:nraysp)=zblock(3,1:nraysp)*sl +c else + if(nadj0.ne.0)then + toopi=4.d0*asin(1.d0) + do j=1,nraysp + c5j=c6(5,j) + ac5j=abs(c5j) + if(c5j.gt.0.)c6(5,j)=mod(c5j,toopi) + if(c5j.lt.0.)c6(5,j)=toopi-mod(ac5j,toopi) + enddo +c?! endif +c place the value which is in(-pi,pi) back in the zblock array: + do j=1,nraysp + zblock(5,j)=c6(5,j)-0.5d0*toopi + enddo + endif +c convert phase to z (bbyk) and transform to the beam frame (gamma) +c also multiply by scale length (sl) to convert x and y to units of meters + do j=1,nraysp + c6(5,j)=c6(5,j)*gamma*bbyk + c6(1,j)=c6(1,j)*sl + c6(3,j)=c6(3,j)*sl + enddo +c endif +c +cryne Feb 3, 2003: +c this is the "bunch length" in the beam frame when it extends from 0 to 2pi: +c gblam=gamma*beta*4.*asin(1.0d0)*sl + gblam=gamma*beta*299792458.d0/bfreq +c if(idproc.eq.0)write(96,*)'gblam=',gblam +cryne 11/19/02 mask off lost particles + do j=1,nraysp + msk(j)=.true. + enddo + if(nraysp.lt.maxrayp)then + do j=nraysp+1,maxrayp + msk(j)=.false. + enddo + endif +c if(idproc.eq.0)then +c zmintmp=minval(c6(5,:),msk) +c zmaxtmp=maxval(c6(5,:),msk) +c write(6,*)'zmintmp,zmaxtmp=',zmintmp,zmaxtmp +c endif +c write(6,*)'calling setbound' + call setbound(c6,msk,nraysp,gblam,gamma,nx0,ny0,nz0,noresize, & + & nadj0) + gaminv=1.d0/gamma + if(idproc.eq.0)then + write(91,891)arclen,xmin,xmax,hx,nx0 + write(92,891)arclen,ymin,ymax,hy,ny0 +cryne 11/27/03 write(93,891)arclen,zmin*gaminv,zmax*gaminv,hz*gaminv,nz0 + write(93,892)arclen,zmin,zmax,hz,nz0 + 891 format(4(1pe14.7,1x),i5) + 892 format(1x,'(bunch frame) ',4(1pe14.7,1x),i5) + endif +c + nxsave=nx0 + nysave=ny0 + nzsave=nz0 + nx=nx0 + ny=ny0 + nz=nz0 + n1=2*nx + n2=2*ny + n3=2*nz + nadj=nadj0 + n3a=2*nz-nadj*nz + if(perv.ne.0)then + if (iverbose.ge.2) write(6,*) 'calling spch3d' +! rob: this will not work until the units are dealt with + call increment_timer('spch3d',0) + call spch3d(c6,ex,ey,ez,msk,nraysp,nrays, & + & nx,ny,nz,n1,n2,n3,n3a,nadj,rparams,cparams) + call increment_timer('spch3d',1) + if (iverbose.ge.2) write(6,*) 'returned from spch3d' + else +cryne Due to code near the top, the following will never be executed: + write(6,*)'code should not get here' +c ex=0. +c ez=0. +c ey=0. + endif + do j=1,nraysp + ex(j)=ex(j)*gamma + ey(j)=ey(j)*gamma + enddo +c if(idproc.eq.0)then +c write(96,*)'premult: ex(1),ey(1),ez(1)=',ex(1),ey(1),ez(1) +c endif +c + twopi=4.*asin(1.0d0) +c xycon=0.5*perv*gamma*beta*(bbyk*twopi) +cc xycon=0.5*perv*gamma*beta*(beta*sl*twopi) +ccc wrf=twopi*bfreq +cccc xycon=0.5*perv*gamma*beta*(twopi*beta*clite/wrf) +c (bfreq is in module beamdata) +c******** +c 3/21/2003 factor of 1/(4pi) now appears in G, so *4pi is needed here: + fourpi=8.d0*(asin(1.d0)) +c******** +c3/21/03xycon=0.5*perv*gamma*beta*(beta*clite/bfreq) + xycon=fourpi*0.5*perv*gamma*beta*(beta*clite/bfreq) +cryne 11/6/03triedthis,no good:xycon=fourpi*0.5*perv*gamma*beta*(beta*clite/freqscl) + tcon=beta*xycon*gamma**2 +c---------- +cryne Jan 28, 2003 + ratio3=omegascl*sl/299792458.d0 +c if(idproc.eq.0)write(6,*)'ratio3,ratio3inv=',ratio3,1.d0/ratio3 +c if(idproc.eq.0)write(96,*)'ratio3,r3inv=',ratio3,1.d0/ratio3 +ccc xycon=xycon*ratio3 + tcon=tcon/ratio3 +c---------- +c write(6,*),'xycon,tcon,perv=',xycon,tcon,perv +c if(idproc.eq.0)then +c write(96,*)'post:*xytcon=',xycon*ex(1),xycon*ey(1),tcon*ez(1) +c endif + gbi=1./(gamma*beta) +cryne 12/24/2002 + if(lflagmagu)then +c if(idproc.eq.0)write(6,*)'magnetic conversion for sc kick' +c if(idproc.eq.0)write(96,*)'magnetic conversion for sc kick' +c if(idproc.eq.0)write(6,*)'gamma*beta,gbi=',gamma*beta,gbi +c if(idproc.eq.0)write(96,*) & +c & 'post:*con*gbi=',xycon*ex(1)*gbi,xycon*ey(1)*gbi,tcon*ez(1)*gbi +! xycon=xycon*gamma*beta +! tcon= tcon*gamma*beta + xycon=xycon*gbi + tcon=tcon*gbi +! +! if(idproc.eq.0)write(6,*) 'TCON SET TO ZERO!!!!!!!!!!!!!!!!!!!!' +! if(idproc.eq.0)write(96,*)'TCON SET TO ZERO!!!!!!!!!!!!!!!!!!!!' +! tcon=tcon*0.d0 + endif +c +cccc zblock(2,1:nraysp)=zblock(2,1:nraysp)+tau*xycon*ex(1:nraysp)*gbi +cccc zblock(4,1:nraysp)=zblock(4,1:nraysp)+tau*xycon*ey(1:nraysp)*gbi +cccc zblock(6,1:nraysp)=zblock(6,1:nraysp)+tau* tcon*ez(1:nraysp)*gbi +c if(straight)then + do j=1,nraysp + zblock(2,j)=zblock(2,j)+tau*xycon*ex(j) + zblock(4,j)=zblock(4,j)+tau*xycon*ey(j) + zblock(6,j)=zblock(6,j)+tau* tcon*ez(j) + enddo +c else +c zblock(2,1:nraysp)=zblock(2,1:nraysp)+ +c & tau*xycon*sqrt(ex(1:nraysp)**2+ey(1:nraysp)**2) +c zblock(4,1:nraysp)=zblock(4,1:nraysp)-tau*xycon*ey(1:nraysp) +c zblock(6,1:nraysp)=zblock(6,1:nraysp)+tau* tcon*ez(1:nraysp) +c endif + zlocate=zlocate+tau + endif + if(iverbose.eq.2)write(6,*)'returning from space charge routine' + return + end +c + subroutine confoc(l,kx,ky,kz,h,mh) + use beamdata + use lieaparam, only : monoms + double precision kx,ky,kz,l + double precision h,mh,gb + dimension h(monoms),mh(6,6) + call ident(h,mh) + gb=gamma*beta + mh(1,1)=cos(kx*l) + if(kx.ne.0.d0)then + mh(1,2)=1./kx/sl*sin(kx*l) + else + mh(1,2)=l/sl + endif + mh(2,1)=-kx*sl*sin(kx*l) + mh(2,2)=cos(kx*l) + mh(3,3)=cos(ky*l) + if(ky.ne.0.d0)then + mh(3,4)=1./ky/sl*sin(ky*l) + else + mh(3,4)=l/sl + endif + mh(4,3)=-ky*sl*sin(ky*l) + mh(4,4)=cos(ky*l) + mh(5,5)=cos(kz*l) + if(kz.ne.0.d0)then + mh(5,6)=1./kz/sl/gb**2*sin(kz*l) + else + mh(5,6)=l/sl + endif + mh(6,5)=-kz*sl*gb**2*sin(kz*l) + mh(6,6)=cos(kz*l) + return + end +c + logical function defcon(line) +cryne 09/21/02 modified to deal with the issue that a symbol may be +c defined using ":=" or "=" +c The original version of this routine could not handle "=" +c Now it can, and as a result MaryLie/IMPACT can parse both cases. +c (Note, however, that MaryLie/IMPACT treats them identically; +c MAD parses both but treats them differently) + character (len=*) line + character*16 symb(50) + integer istrtsym(50) +c write(6,*)'INSIDE DEFCON; line =' +c write(6,*)line + defcon=.false. +c find the first nonblank character: + do n=1,LEN(line) + nfirst=n + if(line(n:n).ne.' ')goto 100 + enddo +c blank line: + return + 100 continue +c is the first character a "!" ? + if(line(nfirst:nfirst).eq.'!')return +c is the first character a '#' ? + if(line(nfirst:nfirst).eq.'#')return +c now inspect the contents of the line: +c check for ':' and '=' : + n1=index(line,':') + n2=index(line,'=') +c if((n1.eq.0).or.(n2.eq.0))return + if(n2.eq.0)return +c If both are present, there can be nothing in between: + if(n1.ne.0)then + if(n2.ne.n1+1)return + endif +c Set ncheck equal to the starting point of "=" or ":=" + if(n1.ne.0)then + ncheck=n1 + else + ncheck=n2 + endif +c +c there must be at least one symbol, and ":=" or "=" must occur after it: + call getsymb(line,LEN(line),symb,istrtsym,nsymb) + if(nsymb.eq.0)return + m1=istrtsym(1) +c m11=index(line,symb(1)) +c write(6,*)'(defcon) m1,m11=',m1,m11 + m2=len_trim(symb(1)) +c n0=location of last character of first string: + n0=m1+m2-1 +c if(n0.lt.n1)defcon=.true. + if(ncheck.eq.n0+1)defcon=.true. + if(ncheck.gt.n0+1)then + do mmm=n0+1,ncheck-1 + if(line(mmm:mmm).ne.' ')return + enddo + defcon=.true. + endif +c write(6,*)'**FOUND A DEFCON**' +c if(defcon)then +c if(ncheck.eq.n2)then +c write(6,*)'*****FOUND A DEFCON defined with an equal sign in' +c else +c write(6,*)'*****FOUND A DEFCON defined with a := in' +c endif +c write(6,*)line +c endif + return + end +c + logical function defline(line) + character (len=*) line + character*16 symb(50) + integer istrtsym(50) +c write(6,*)'INSIDE DEFLINE; line =' +c write(6,*)line + defline=.false. +c find the first nonblank character: + do n=1,LEN(line) + nfirst=n + if(line(n:n).ne.' ')goto 100 + enddo +c blank line: + return + 100 continue +c is the first character a '!' ? + if(line(nfirst:nfirst).eq.'!')return +c is the first character a '#' ? + if(line(nfirst:nfirst).eq.'#')return +c now check the contents of the line: +c '=' must be present + n1=index(line,'=') + if(n1.eq.0)return +c write(6,*)'n1 (location of equal sign) is',n1 +c and 'line' must be present + call getsymb(line,LEN(line),symb,istrtsym,nsymb) +c write(6,*)'(defline) nsymb=',nsymb +c if(nsymb.gt.0)then +c do ijk=1,nsymb +c write(6,*)'i,symb(i)= ',ijk,symb(ijk) +c enddo +c endif + if(nsymb.lt.2)return + if((trim(symb(2)).ne.'line').and.(trim(symb(2)).ne.'LINE'))return +c and there can only be blanks (or nothing) between 'line' and '=' + m1=istrtsym(2) +c m11=index(line,trim(symb(2))) +c write(6,*)'(defline)m1,m11=',m1,m11 +c write(6,*)'m1 (start of second symbol)=',m1 +c n0=location of last character of second string: + n0=m1+3 +c write(6,*)'n0 (end of second symbol)=',n0 + if(n1.eq.n0+1)then + defline=.true. +c write(6,*)'*****(1)FOUND A DEFLINE*****,line=' +c write(6,*)line + return + endif + do n=n0+1,n1-1 + if(line(n:n).ne.' ')return + enddo + defline=.true. +c write(6,*)'*****(2)FOUND A DEFLINE*****' +c write(6,*)line + return + end +c + logical function defelem(line) + include 'codes.inc' + character (len=*) line + character*16 symb(50) + integer istrtsym(50) + character*16 str + dimension nstrmax(9) + nstrmax(1)=75 + nstrmax(2)=10 + nstrmax(3)=9 + nstrmax(4)=24 + nstrmax(5)=9 + nstrmax(6)=9 + nstrmax(7)=50 + nstrmax(8)=39 + nstrmax(9)=37 +c write(6,*)'INSIDE DEFELEM; line =' +c write(6,*)line + defelem=.false. +c find the first nonblank character: + do n=1,LEN(line) + nfirst=n + if(line(n:n).ne.' ')goto 100 + enddo +c blank line: + return + 100 continue +c is the first character a '!' ? + if(line(nfirst:nfirst).eq.'!')return +c is the first character a '#' ? + if(line(nfirst:nfirst).eq.'#')return +c now check the contents of the line +c first obtain the symbols on the line: + call getsymb(line,LEN(line),symb,istrtsym,nsymb) +c it must contain at least TWO symbols + if(nsymb.lt.2)return +c write(6,*)'symb(1),symb(2) =',symb(1),'----',symb(2),'----' +c check for 'beam' or 'units' + if((trim(symb(1)).eq.'beam').or.(trim(symb(1)).eq.'units').or. & + & (trim(symb(1)).eq.'BEAM').or.(trim(symb(1)).eq.'UNITS'))then +c write(6,*)'FOUND A BEAM OR UNITS DEFELEM' + defelem=.true. + return + endif +c +c a ':' must occur between them + m0=index(line,':') +c write(6,*)'m0=',m0 + if(m0.eq.0)return + ms1=istrtsym(1) +c ms11=index(line,trim(symb(1))) +c write(6,*)'(defelem) ms1,ms11=',ms1,ms11 + ms2=istrtsym(2) +c ms22=index(line,trim(symb(2))) +c write(6,*)'(defelem) ms2,ms22=',ms2,ms22 +c write(6,*)'m0,ms1,ms2 =',m0,ms1,ms2 + if((m0.lt.ms1).or.(m0.gt.ms2))return +c '=' must not occur between them + k0=index(line,'=') +c write(6,*)'k0=',k0 + if(k0.ne.0)then + if((k0.gt.ms1).and.(k0.lt.ms2))return + endif +c the second symbol must match a type code name: + str=symb(2)(1:16) +c write(6,*)'str=',str + do i=1,9 + do j=1,nstrmax(i) + if(str(1:16).eq.ltc(i,j))then + defelem=.true. +c write(6,*)'***FOUND A DEFELEM***; i,j,ltc(i,j)=',i,j,ltc(i,j) + endif + enddo + enddo + return + end +c + subroutine rfcavmad(zlen,volt,phlagrad,nharm,h,mh) +c MAD RF CAVITY routine +c note that the length,zlen, is not used. +c +c trevi is the inverse revolution frequency. +c how/where is this info obtained??? + use lieaparam, only : monoms + use beamdata + include 'impli.inc' + double precision mh + double precision omega + dimension h(monoms),mh(6,6) +c-------- + write(6,*)'Inside routine for MAD RF CAVITY; do not know T_rev.' + write(6,*)'This needs to be fixed. Setting 1./T_rev = 0' + trevi=0.d0 +c-------- + omega=4.d0*asin(1.d0)*nharm*trevi + call ident(h,mh) + mh(6,5)=-omega*volt/brho*cos(phlagrad) + return + end +c + subroutine elsepmad(zlen,efield,h,mh) +c MAD ELECTROSTATIC SEPARATOR routine + use lieaparam, only : monoms + use beamdata + include 'impli.inc' + double precision mh + double precision omega + double precision xk + dimension h(monoms),mh(6,6) + xk=efield/brho + co=cosh(xk*zlen) + si=sinh(xk*zlen) + write(6,*)'in elsepmad w/ zlen,efield,brho=',zlen,efield + write(6,*)'and brho,beta=',brho,beta + write(6,*)'and xk,co,si=',xk,co,si + call ident(h,mh) + mh(1,2)=zlen + mh(3,3)=co-xk*zlen*si/beta**2 + mh(3,4)=si/xk + mh(3,6)=(co-1.d0)/xk - zlen*si/beta**2 + mh(4,3)=xk*(si-xk*zlen*co/beta**2) + mh(4,4)=co + mh(4,6)=si-xk*zlen*co/beta**2 + mh(5,3)=-(si-xk*zlen*co/beta**2) + mh(5,4)=-(co-1.d0)/xk + mh(5,6)=-si/xk + zlen*co/beta**2 + return + end +c + subroutine hmonitor + include 'impli.inc' +c write(6,*)'MAD hmonitor not implemented' + return + end +c + subroutine vmonitor + include 'impli.inc' +c write(6,*)'MAD vmonitor not implemented' + return + end +c + subroutine monitor + include 'impli.inc' +c write(6,*)'MAD monitor not implemented' + return + end +c + subroutine instrument + include 'impli.inc' +c write(6,*)'MAD instrument not implemented' + return + end +c +c*********************************************************************** +c + subroutine sliceml +c the routine augments the nrp ("number of required parameters") values +c of thick elements associated with original MaryLie type codes. +c By putting this in the menu first, users with original MaryLie +c input files can add a parameter to the parameter lists of the +c thick elements in order to do autoslicing. + use parallel + include 'codes.inc' + nrp(1,1)=nrp(1,1)+1 !drft + nrp(1,2)=nrp(1,2)+1 !nbnd + nrp(1,3)=nrp(1,3)+1 !pbnd + nrp(1,4)=nrp(1,4)+1 !gbnd + nrp(1,6)=nrp(1,6)+1 !gbdy + nrp(1,8)=nrp(1,8)+1 !cfbd + nrp(1,9)=nrp(1,9)+1 !quad + nrp(1,10)=nrp(1,10)+1 !sext + nrp(1,11)=nrp(1,11)+1 !octm + nrp(1,12)=nrp(1,12)+1 !octe + nrp(1,18)=nrp(1,18)+1 !cfqd + nrp(1,20)=nrp(1,20)+1 !sol + nrp(1,24)=nrp(1,24)+1 !recm + nrpold(1,1)=nrpold(1,1)+1 !drft + nrpold(1,2)=nrpold(1,2)+1 !nbnd + nrpold(1,3)=nrpold(1,3)+1 !pbnd + nrpold(1,4)=nrpold(1,4)+1 !gbnd + nrpold(1,6)=nrpold(1,6)+1 !gbdy + nrpold(1,8)=nrpold(1,8)+1 !cfbd + nrpold(1,9)=nrpold(1,9)+1 !quad + nrpold(1,10)=nrpold(1,10)+1 !sext + nrpold(1,11)=nrpold(1,11)+1 !octm + nrpold(1,12)=nrpold(1,12)+1 !octe + nrpold(1,18)=nrpold(1,18)+1 !cfqd + nrpold(1,20)=nrpold(1,20)+1 !sol + nrpold(1,24)=nrpold(1,24)+1 !recm + if(idproc.eq.0)then +! write(6,*)'Enabling slicing of original MaryLie thick elements.' +! write(6,*)'For each thick element, the MaryLie parser will' +! write(6,*)'expect 1 more parameter than is shown in the MaryLie' +! write(6,*)'manual. The extra (last) parameter = the # of slices.' + write(12,*)'Enabling slicing of original MaryLie thick elements.' + write(12,*)'For each thick element, the MaryLie parser will' + write(12,*)'expect 1 more parameter than is shown in the MaryLie' + write(12,*)'manual. The extra (last) parameter = the # of slices.' + endif + return + end +c +!*********************************************************************** +! subroutine myflush(nfile) +! integer nfile +! double precision x +! close(nfile) +! open(nfile,position='append') +c open(nfile) +c 100 read(nfile,*,end=123,err=999)x +c goto 100 +c 123 continue +c return +c 999 continue +c if(idproc.eq.0)write(6,*)'trouble in routine myflush' +c call myexit +! return +! end +!*********************************************************************** + subroutine num2string(num,a,ndigits) +c converts an integer "num" with at most "ndigits" digits +c into a character string "a" + integer num,ndigits + character a*(*) + integer n,m,k + m=num + do n=1,ndigits + k=m/10**(ndigits-n) + if(k.eq.0)a(n:n)='0' + if(k.eq.1)a(n:n)='1' + if(k.eq.2)a(n:n)='2' + if(k.eq.3)a(n:n)='3' + if(k.eq.4)a(n:n)='4' + if(k.eq.5)a(n:n)='5' + if(k.eq.6)a(n:n)='6' + if(k.eq.7)a(n:n)='7' + if(k.eq.8)a(n:n)='8' + if(k.eq.9)a(n:n)='9' + m=m-k*10**(ndigits-n) + enddo + return + end +c*********************************************************************** + subroutine ibcast(ival) + use parallel + integer ival + if(idproc.eq.0)then + do l=1,nvp-1 + call MPI_SEND(ival,1,mntgr,l,99,lworld,ierr) +! write(6,*)'processor ',idproc,' sending ival=',ival,' to PE',l + enddo + else + call MPI_RECV(ival,1,mntgr,0,99,lworld,mpistat,ierr) +c? call MPI_GET_COUNT(mpistat,mreal,nraysp,ierr) +! write(6,*)'processor ',idproc,' received ival=',ival + endif + return + end +c*********************************************************************** + subroutine rbcast(rval) + use parallel + real*8 rval + if(idproc.eq.0)then + do l=1,nvp-1 + call MPI_SEND(rval,1,mreal,l,99,lworld,ierr) +! write(6,*)'processor ',idproc,' sending rval=',rval,' to PE',l + enddo + else + call MPI_RECV(rval,1,mreal,0,99,lworld,mpistat,ierr) +c? call MPI_GET_COUNT(mpistat,mreal,nraysp,ierr) +! write(6,*)'processor ',idproc,' received rval=',rval + endif + return + end +*********************************************************************** +c + subroutine myexit +! use parallel + use acceldata + use spchdata + use ml_timer + use rays + common/xtrajunk/jticks1,iprinttimers +c +c Written by Rob Ryne ca 1984 +c +c Exit the program (may be replaced by STOP, if exit is not available). +c This is the only place in MaryLie where exit is called. +c + call system_clock(count=jticks2) + elapsed=(jticks2-jticks1)/hertz + write(6,*)'ELAPSED TIME=',elapsed + if(iprinttimers.eq.1)call end_ml_timers +c write(6,*)'deallocating...' + call del_acceldata + if(allocated(zblock))call del_particledata + if(allocated(grnxtr))call del_spchdata + call end_parallel + stop + end +c +c + subroutine getordtyp(cstring,ntaysym,norder) + use parallel + include 'impli.inc' + character*16 cstring + ntay=index(cstring,'tay') + nsym=index(cstring,'sym') + if(ntay.ne.0)ntaysym=1 + if(nsym.ne.0)ntaysym=2 +c inefficient, but works. fix later. rdr dec 9 2002 & march 27 2004 + n0=index(cstring,'0') + if(n0.ne.0)then + norder=0 + return + endif + n1=index(cstring,'1') + if(n1.ne.0)then + norder=1 + return + endif + n2=index(cstring,'2') + if(n2.ne.0)then + norder=2 + return + endif + n3=index(cstring,'3') + if(n3.ne.0)then + norder=3 + return + endif + n4=index(cstring,'4') + if(n4.ne.0)then + norder=4 + return + endif + n5=index(cstring,'5') + if(n5.ne.0)then + norder=5 + return + endif + n6=index(cstring,'6') + if(n6.ne.0)then + norder=6 + return + endif + n7=index(cstring,'7') + if(n7.ne.0)then + norder=7 + return + endif + n8=index(cstring,'8') + if(n8.ne.0)then + norder=8 + return + endif + n9=index(cstring,'9') + if(n9.ne.0)then + norder=9 + return + endif + if(idproc.eq.0)then + write(6,*)'(GETORDTYP)Unable to determine tracking type & order' + endif + call myexit + end +c diff --git a/OpticsJan2020/MLI_light_optics/Src/afro_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/afro_mod.f90 new file mode 100755 index 0000000..5f8dc44 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/afro_mod.f90 @@ -0,0 +1,177 @@ +module beamdata + implicit none +! beam parameters and scaling parameters + real*8 :: brho,gamma,gamm1,beta,achg,pmass,bfreq,bcurr,c + real*8 :: sl,p0sc,ts,omegascl,freqscl + logical :: lflagmagu=.true.,lflagdynu=.false. + save +end module beamdata + +module acceldata + implicit none + +! lmnlbl(i) = name of ith element (numbered as they occur in #menu) +! p(k,i) = kth parameter of ith element +! nt1(i) = group index of the elements type (see /monics/) +! nt2(i) = type index ..... +! mppr(i) = menu parameters (real data) for ith element +! note: for compatibility w/ existing MaryLie, I call this "mpp" not "mppr" +! mppc(i) = menu parameters (char*16 data) for ith element + character(len=16), dimension(:), allocatable :: lmnlbl,cmenu +! if there are, on average, +! 6 real parameters/element and 1 character parameter/element, +! then this is enough memory to store the parameters of mnumax elements + real*8, dimension(:), allocatable :: pmenu +! atarray added by RDR 9/16/2004: + real*8, dimension(:), allocatable :: atarray +! + integer, dimension(:), allocatable :: mpp,mppc,nt1,nt2 + +! mnumax = maximum number of elements in #menu (default=5000) +! itmno = maximum number of items (default=5000) +! itmnln = maximum number of elements per item (default=100) +! mlabor = maximum number of tasks in #labor (default=1000) +! maxcmt = maximum number of comment lines (default=250) +! nconmax = maximum number of defined constants (default=1000) + integer :: mnumax=5000,itmno=5000,itmln=100 + integer :: mlabor=1000,maxcmt=250,nconmax=1000 +! + integer :: inmenu + +! na = actual number of elements +! nb = actual number of items +! noble = actual number of tasks +! npcom = actual number of comment lines +! mpprpoi = menu parameter pointer to "real" (i.e. numeric) data +! mppcpoi = menu parameter pointer to character*16 data + integer :: na=0,nb=0,noble=0,npcom=0,mpprpoi=0,mppcpoi=0 + + +! lines,lumps and loops +! ilbl(i) = name of ith item +! icon(k,i) = name of kth element/item in ith item +! irep(k,i) = repetition factor of icon(k,i) +! ityp(k,i) = type code = 2,3,4 if item=line,lump,loop resp. +! ilen(i) = number of elements/items in ith item (=max k for ith item) +! lmade(i) = flag, telling whether map of lump is in buffer and where. +! preset to zero + character(len=16), dimension(:), allocatable :: ilbl + character(len=16), dimension(:,:), allocatable :: icon + integer, dimension(:), allocatable :: ityp,ilen,lmade + integer, dimension(:,:), allocatable :: irep + +! latt(i) = the name of the ith task +! num(i) = the repetition factor of this task + character(len=16), dimension(:), allocatable :: latt + integer, dimension(:), allocatable :: num + + character(len=80), dimension(:), allocatable :: mline + +!ryne 7/7/2002 +!ryne this common block is used to store strings that have constant +!ryne values assigned to them. +!ryne nconst is equal to the number that have been assigned +!ryne This info should really be included in elments.inc, but I am +!ryne keeping it separate to avoid changes to the existing MaryLie + character(len=16), dimension(:), allocatable :: constr + real*8, dimension(:), allocatable :: conval + integer :: nconst +! +!11/29/02 autoslicing info: +! defaults: + character*16 :: slicetype='slices',sliceprecedence='local' + real*8 :: slicevalue=1.0 + + save + +contains + subroutine new_acceldata + allocate(lmnlbl(mnumax)) + allocate(pmenu(6*mnumax),cmenu(1*mnumax), & + & mpp(mnumax),mppc(mnumax),nt1(mnumax),nt2(mnumax)) + allocate(atarray(1*mnumax)) +! write (6,*) 'pmenu size=',size(pmenu) +! write (6,*) 'pmenu start,end=',loc(pmenu(1)),loc(pmenu(6*mnumax)) + + allocate(ilbl(itmno),icon(itmln,itmno)) + allocate(irep(itmln,itmno),ityp(itmno),ilen(itmno),lmade(itmno)) + allocate(latt(mlabor),num(mlabor)) + allocate(mline(maxcmt)) + allocate(constr(nconmax),conval(nconmax)) + mpp(:)=0 + mppc(:)=0 + cmenu(:)=' ' + lmade(:)=0 + mline(:)=' ' + latt(:)=' ' + num(:)=1 + atarray(:)=-99999.d0 + end subroutine new_acceldata + + subroutine del_acceldata + deallocate(lmnlbl) + deallocate(pmenu,cmenu,mpp,mppc,nt1,nt2) + deallocate(atarray) + deallocate(ilbl,icon) + deallocate(irep,ityp,ilen,lmade) + deallocate(latt,num) + deallocate(mline) + deallocate(constr,conval) + end subroutine del_acceldata + + +end module acceldata + + +module rays + use parallel + implicit none +! eventually make leading dimension "idimp" instead of 6 +! zblock(k,i) kth coordinate of ray index i +! tblock(k,i) temporary array; might move out of this module later. +! zi (k) initial coordinates +! zf (k) final coordinates +! nrays number of rays +! istat(i) iturn, in which ray index i was lost, 0 otherwise +! ihist(1,j) iturn, in which the jth lost particle was lost +! ihist(2,j) index (i) of jth lost particle +! iturn turn index (not used in cqlate) +! nlost number of rays lost so far + real*8, dimension(:,:), allocatable :: zblock,tblock + real*8, dimension(:,:), allocatable :: pbh6t,uvect,tvect + integer, dimension(:), allocatable :: istat + integer, dimension(:,:), allocatable :: ihist + real*8, dimension(6) :: zi,zf +! maxray is the initial size of the global particle array (default=30000) + integer :: maxray=30000,nrays=0,nlost=0,iturn=0 +! values per processor: + integer, parameter :: nchunk=100 + integer :: maxrayp,nraysp=0 +save + +contains + + subroutine new_particledata +!cryne May 19, 2006 maxrayp=(maxray-1)/nvp + 1 + maxrayp=maxray/nvp + 1 +!cryne May 19, 2006 commented out the following until particle mgr is installed: +! maxrayp=2*maxrayp +! + allocate(zblock(6,maxrayp),tblock(6,maxrayp), & + & pbh6t(6,923),uvect(923,nchunk),tvect(923,nchunk)) +! if(nvp.gt.1)allocate(tblock(6,maxrayp)) + allocate(istat(maxrayp),ihist(2,maxrayp)) + end subroutine new_particledata + + subroutine del_particledata +! print *, 'zblock=',allocated(zblock),size(zblock) +! print *, 'istat=',allocated(istat),size(istat) +! print *, 'ihist=',allocated(ihist),size(ihist) + integer status + deallocate(zblock,tblock,pbh6t,uvect,tvect,stat=status) + if(status.ne.0) print *,'del_particledata: deallocate1 returned ',status +! if(allocated(tblock))deallocate(tblock) + deallocate(istat,ihist,stat=status) + if(status.ne.0) print *,'del_particledata: deallocate2 returned ',status + end subroutine del_particledata +end module rays diff --git a/OpticsJan2020/MLI_light_optics/Src/anal.f b/OpticsJan2020/MLI_light_optics/Src/anal.f new file mode 100644 index 0000000..4387fa2 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/anal.f @@ -0,0 +1,4813 @@ +*********************************************************************** +* header ANALYSIS (advanced commands) * +* Routines for advanced commands and advanced analysis * +*********************************************************************** +c + subroutine amap(p,fa,fm) +c subroutine for applying a map to a function or a set of moments +c Written by Alex Dragt, Fall 1986 + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'usrdat.inc' + character*3 kynd +c + dimension p(6) + dimension fa(monoms),fm(6,6) +c + dimension ga(monoms),gm(6,6) + dimension ha(monoms),hm(6,6) + dimension t1a(monoms) + dimension t2a(monoms) +c +c set up control indices + mode=nint(p(1)) + isend=nint(p(2)) + ifile=nint(p(3)) + nopt=nint(p(4)) + nskip=nint(p(5)) + nmpo=nint(p(6)) +c +c procedure for reading in function or moments when mode = 1, 2, or 3: + if (mode.eq.1 .or. mode.eq.2 .or. mode.eq.3) then +c test for file read or internal map fetch + if(ifile.lt.0) then + nmap=-ifile + kynd='gtm' + call strget(kynd,nmap,ga,gm) + else + mpit=mpi + mpi=ifile + call mapin(nopt,nskip,ga,gm) + mpi=mpit + endif + endif +c +c procedure for reading in moments when mode = 4 or 5: + if (mode.eq.4 .or. mode.eq.5) then +c Filippo provide this procedure + continue + endif +c +c procedure for letting map act on a function: + if(mode.eq.1) then +c let map characterized by fa,fm act on ga +c the result is the array ha +c this amounts to computing ha = (Dtranspose)*ga +c where D = D(fa,fm) + call fxform(fa,fm,ga,ha) + endif +c +c procedure for letting map act on moments: +c letting the map act on moments amounts to computing ha = D*ga +c +c procedure for mode = 2 or 3: + if (mode.eq.2 .or. mode.eq.3) then +c +c clear arrays + do 10 i=1,monoms + t1a(i)=0.d0 + 10 ha(i)=0.d0 +c +c when mode = 3, compute all transformed moments through 4'th moments + imax=209 +c when mode = 2, compute transformed moments only through 2'nd moments + if (mode.eq.2) imax=27 +c +c perform calculation + do 20 i=7,imax + t1a(i)=1.d0 + call fxform(fa,fm,t1a,t2a) + t1a(i)=0.d0 + do 30 j=1,209 + 30 ha(i)=ha(i)+t2a(j)*ga(j) + 20 continue + endif +c +c procedure for mode = 4 or 5: + if (mode.eq.4 .or. mode.eq.5) then +c when mode = 5, compute all transformed moments through 4'th moments + imax=209 +c when mode = 4, compute transformed moments only through 2'nd moments + if (mode.eq.4) imax=27 +c Filippo put in code here for dealing with 6'th order moments: +c clear arrays +c perform calculation + continue + endif +c +c if map has been applied to moments, compute squares of rms emittances: + if (mode.ne.1) then + xemit2=ha(7)*ha(13)-ha(8)*ha(8) + yemit2=ha(18)*ha(22)-ha(19)*ha(19) + if (isend.eq.1.or.isend.eq.3) then + write (jof,*) 'xemit2=',xemit2 + write (jof,*) 'yemit2=',yemit2 + endif + if (isend.eq.2.or.isend.eq.3) then + write (jodf,*) 'xemit2=',xemit2 + write (jodf,*) 'yemit2=',yemit2 + endif + endif +c +c write out result ha if nmpo > 0 + mpot=mpo + mpo=nmpo + if (nmpo.gt.0) call mapout(0,ha,hm) + mpo=mpot +c +c write results into the array ucalc +c first clear the array + do 40 i=1,250 + 40 ucalc(i)=0.d0 +c complete the task + nuvar=211 + do 50 i=1,209 + 50 ucalc(i)=ha(i) + if (mode.ne.1) then + ucalc(210)=xemit2 + ucalc(211)=yemit2 + endif +c + return + end +c +*********************************************************************** +c + subroutine asni(p) + use rays + use lieaparam, only : monoms +c This subroutine applies powers of script N inverse to phase space data. +c It does this using analytic formulas. +c + include 'impli.inc' +c + character*3 kynd +c calling array + dimension p(6) +c +c local array + dimension fa(monoms), fr(monoms) + dimension fm(6,6) +c +c set up control parameters + iopt=nint(p(1)) + nmap=nint(p(2)) + nfcf=nint(p(3)) + istart=nint(p(4)) + igroup=nint(p(5)) + nwrite=nint(p(6)) +c +c begin calculation +c +c get script N from storage + kynd='gtm' + call strget(kynd,nmap,fa,fm) +c +c procedure for a static map +c + if( iopt.eq.1) then +c compute linear phase advances and linear time of flight + cwx=fm(1,1) + swx=fm(1,2) + wx=atan2(swx,cwx) + cwy=fm(3,3) + swy=fm(3,4) + wy=atan2(swy,cwy) + wt=fm(5,6) +c +c transform nonlinear part of map to the static resonance basis + call ctosr(fa,fr) +c +c begin outer loop over the sets of particles + nset=nint(float(nrays)/float(igroup)) + do 10 i=1,nset +c begin inner loop over the particles within a set + do 20 j=1,igroup +c +c get phase-space coordinates + iray=(i-1)*igroup+j + do 30 k=1,6 + 30 zi(k)=zblock(k,iray) +c +c compute emittances + ex2=zi(1)**2 + zi(2)**2 + ey2=zi(3)**2 + zi(4)**2 + pt=zi(6) +c +c compute phase advances and time of flight terms +c incorporate - sign needed for inverse in the definition of an + an=-float(istart+(i-1)*nwrite) +c compute x and y phase advances + phix = wx - 2.*pt*fr(28) - 2.*pt*pt*fr(84) + & - 4.*ex2*fr(87) - 2.*ey2*fr(89) + phiy = wy - 2.*pt*fr(29) - 2.*pt*pt*fr(85) + & - 4.*ey2*fr(88) - 2.*ex2*fr(89) +c compute time-like drift terms + drt = pt*wt - ex2*fr(28) - ey2*fr(29) + & - 2.*pt*ex2*fr(84) -2.*pt*ey2*fr(85) + & - 3.*pt*pt*fr(30) - 4.*pt*pt*pt*fr(86) +c +c set up matrix quantities + cx=cos(an*phix) + sx=sin(an*phix) + cy=cos(an*phiy) + sy=sin(an*phiy) + tof=an*drt +c +c apply matrix to transverse coordinates + zf(1)= cx*zi(1)+sx*zi(2) + zf(2)=-sx*zi(1)+cx*zi(2) + zf(3)= cy*zi(3)+sy*zi(4) + zf(4)=-sy*zi(3)+cy*zi(4) +c transform time deviation and energy deviation + zf(5)= zi(5)+tof + zf(6)= zi(6) +c +c write out results + write (nfcf,100) zf(1),zf(2),zf(3),zf(4),zf(5),zf(6) + 100 format(6(1x,1pe12.5)) +c + 20 continue + 10 continue +c + endif +c +c procedure for a dynamic map +c + if( iopt.eq.2) then +c compute linear phase advances + cwx=fm(1,1) + swx=fm(1,2) + wx=atan2(swx,cwx) + cwy=fm(3,3) + swy=fm(3,4) + wy=atan2(swy,cwy) + cwt=fm(5,5) + swt=fm(5,6) + wt=atan2(swt,cwt) +c +c transform nonlinear part of map to the dynamic resonance basis + call ctodr(fa,fr) +c +c begin outer loop over the sets of particles + nset=nint(float(nrays)/float(igroup)) + do 40 i=1,nset +c begin inner loop over the particles within a set + do 50 j=1,igroup +c +c get phase-space coordinates + iray=(i-1)*igroup+j + do 60 k=1,6 + 60 zi(k)=zblock(k,iray) +c +c compute emittances + ex2=zi(1)**2 + zi(2)**2 + ey2=zi(3)**2 + zi(4)**2 + et2=zi(5)**2 + zi(6)**2 +c +c compute phase advances +c incorporate - sign needed for inverse in the definition of an + an=-float(istart+(i-1)*nwrite) +c this part of code not yet complete + phix=wx + phiy=wy + phit=wt +c +c set up matrix quantities + cx=cos(an*phix) + sx=sin(an*phix) + cy=cos(an*phiy) + sy=sin(an*phiy) + ct=cos(an*phit) + st=sin(an*phit) +c +c apply matrix to coordinates + zf(1)= cx*zi(1)+sx*zi(2) + zf(2)=-sx*zi(1)+cx*zi(2) + zf(3)= cy*zi(3)+sy*zi(4) + zf(4)=-sy*zi(3)+cy*zi(4) + zf(5)= ct*zi(5)+st*zi(6) + zf(6)=-st*zi(5)+ct*zi(6) +c +c write out results + write (nfcf,100) zf(1),zf(2),zf(3),zf(4),zf(5),zf(6) +c + 50 continue + 40 continue +c + endif +c + return + end +c +*********************************************************************** +c + subroutine betmap(ana,anm,ba,bm) +c This is a subroutine for finding the betatron portion of a map. +c The map ana, anm is assumed to be a map about the fixed point. +c Written by Alex Dragt, 4 August 1986 + use lieaparam, only : monoms + include 'impli.inc' +c + dimension ana(monoms),anm(6,6) + dimension ba(monoms),bm(6,6) +c + dimension tempa(monoms),tempm(6,6) + dimension ca(monoms),cm(6,6) +c +c Extraction of betatron term b. +c First pass: terms linear in pt. + call clear(tempa,tempm) + call matmat(anm,tempm) + tempa(33)=ana(33) + tempa(38)=ana(38) + tempa(42)=ana(42) + tempa(45)=ana(45) + tempa(53)=ana(53) + tempa(57)=ana(57) + tempa(60)=ana(60) + tempa(67)=ana(67) + tempa(70)=ana(70) + tempa(76)=ana(76) + call mapmap(tempa,tempm,ba,bm) +c Second pass: terms quadratic in pt. + call inv(ba,bm) + call concat(ba,bm,ana,anm,ca,cm) + tempa(104)=ca(104) + tempa(119)=ca(119) + tempa(129)=ca(129) + tempa(135)=ca(135) + tempa(154)=ca(154) + tempa(164)=ca(164) + tempa(170)=ca(170) + tempa(184)=ca(184) + tempa(190)=ca(190) + tempa(200)=ca(200) + call mapmap(tempa,tempm,ba,bm) + return + end +c +*********************************************************************** +c + subroutine cex(p,ga,gm,myorder) +c this routine computes t=exp(:f) +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' +c + include 'extalk.inc' + include 'hmflag.inc' + include 'buffer.inc' + character*3 kynd +c + dimension p(6),ga(monoms),gm(6,6) +c + dimension ta(monoms) + dimension tm(6,6),em(6,6),fm(6,6) +cryne 3AM 7/11/2002 dimension y(224) + dimension y(monoms+15) + +c-------------------------------------------- +c write(6,*)'inside routine cex' +c write(6,*)'input 6-vector p:' +c do i=1,6 +c write(6,*)p(i) +c enddo +c write(6,*)'input matrix:' +c do i=1,6 +c do j=1,6 +c if(gm(i,j).ne.0.d0)write(69,*)i,j,gm(i,j) +c enddo +c enddo +c +c write(6,*)'input polynomial:' +c do i=1,209 +c if(ga(i).ne.0.d0)write(69,*)i,ga(i) +c enddo +c if(p(1).ne.12345)stop +c-------------------------------------------- +c +c set up power and control indices + power=p(1) + nmapf=nint(p(2)) + nmapg=nint(p(3)) +c +c get map and clear arrays + if (nmapf.eq.0) call mapmap(ga,gm,fa,fm) + if (nmapf.ge.1 .and. nmapf.le.5) then + kynd='gtm' + call strget(kynd,nmapf,fa,fm) + endif + call clear(ta,tm) +c +c perform calculation +c +c set up exponent + call csmul(power,fa,fa) +c +c compute a scaling factor to bring exponent within range of a +c taylor expansion or GENMAP + call matify(em,fa) + call mnorm(em,res) + kmax=1 + scale=.5d0 + 10 continue + test=res*scale + if (test.lt..1d0) goto 20 + kmax=kmax+1 + scale=scale/2.d0 + go to 10 + 20 continue +c +c select procedure + itest=1 + do 30 i=28,monoms + if (fa(i).ne.0.d0) itest=2 + if (itest.ne.1) go to 40 + 30 continue + 40 continue + if (itest.eq.1) go to 50 + if (itest.eq.2) go to 80 +c +c procedure using taylor series + 50 continue + write (12,*) 'exp(:f:) computed using taylor series' +c rescale em + call smmult(scale,em,em) +c compute taylor series result fm=exp(scale*em) + call exptay(em,fm) +c raise the result to the 2**kmax (= 1/scale) power + do 60 i=1,kmax + call mmult(fm,fm,tm) + call matmat(tm,fm) + 60 continue + goto 200 +c +c procedure using genmap + 80 continue + write(12,*) 'exp(:f:) computed using GENMAP' +c rescale fa + call csmul(scale,fa,fa) +c setup and initialize for GENMAP routines + iflag=1 + t=0.d0 + ns=50.d0 + h=.02d0 +cryne 3AM 7/11/2002 ne=224 +cryne 1 August 2004 ne=monoms+15 +cryne 1 August 2004 Initialize: +cryne do 90 i=1,ne + do 90 i=1,monoms+15 + 90 y(i)=0.d0 + do 100 i=1,6 + j=7*i + 100 y(j)=1.d0 +c call GENMAP routines +cryne there is a better way to do this; fix later. +c y(7-42) = matrix +c y(43-98) = f3 +c y(99-224) = f4 +c y(225-476) = f5 +c y(477-938) = f6 + if(myorder.eq.1)ne=42 !36+6 + if(myorder.eq.2)ne=98 !83+15 + if(myorder.eq.3)ne=224 !209+15 + if(myorder.eq.4)ne=476 !461+15 + if(myorder.eq.5)ne=938 !923+15 +c + call adam11(h,ns,'start',t,y,ne) + call putmap(y,fa,fm) +c +c raise the result to the 2**kmax (= 1/scale) power + do 110 i=1,kmax + call concat(fa,fm,fa,fm,ta,tm) + call mapmap(ta,tm,fa,fm) + 110 continue + go to 200 +c +c decide where to put results +c + 200 continue + if (nmapg.ge.1 .and. nmapg.le.5) then + kynd='stm' + call strget(kynd,nmapg,ta,tm) + endif +c + if (nmapg.eq.0) call mapmap(ta,tm,ga,gm) +c + if (nmapg.eq.-1) call mapmap(ta,tm,buf1a,buf1m) + if (nmapg.eq.-2) call mapmap(ta,tm,buf2a,buf2m) + if (nmapg.eq.-3) call mapmap(ta,tm,buf3a,buf3m) + if (nmapg.eq.-4) call mapmap(ta,tm,buf4a,buf4m) + if (nmapg.eq.-5) call mapmap(ta,tm,buf5a,buf5m) +c + return + end +c +******************************************************************************* +c + subroutine chrexp(iopt,delta,ta,tm,am1,am2,am3) +c +c This subroutine computes the chromatic expansion of the map ta,tm +c for the case in which the f3 and f4 parts of ta contain only terms +c linear and quadratic in pt, respectively. +c Written by Alex Dragt, Spring 1987 +c + use lieaparam, only : monoms + include 'impli.inc' +c + dimension ta(monoms),tm(6,6) + dimension am1(6,6),am2(6,6),am3(6,6) +c + dimension t1a(monoms),t1m(6,6),t2m(6,6) +c-------- +c procedure when IOPT = 1 (delta=pt). + if (iopt.eq.1) then +c Calculation of matrix associated with pt*f2 terms in ta. +c Set up f2a in t1a. + call clear(t1a,am1) + t1a(7)=ta(33) + t1a(8)=ta(38) + t1a(9)=ta(42) + t1a(10)=ta(45) + t1a(13)=ta(53) + t1a(14)=ta(57) + t1a(15)=ta(60) + t1a(18)=ta(67) + t1a(19)=ta(70) + t1a(22)=ta(76) +c Compute matrix t1m corresponding to :f2a:. + call matify(t1m,t1a) +c write(6,*) 'result from chrexp' +c call pcmap(1,0,0,0,t1a,t1m) +c Compute am1=t1m*tm + call mmult(t1m,tm,am1) +c Calculation of matrix associated with (pt**2)*f2 terms in ta. +c Set up f2a in t1a. + call clear(t1a,am2) + t1a(7)=ta(104) + t1a(8)=ta(119) + t1a(9)=ta(129) + t1a(10)=ta(135) + t1a(13)=ta(154) + t1a(14)=ta(164) + t1a(15)=ta(170) + t1a(18)=ta(184) + t1a(19)=ta(190) + t1a(22)=ta(200) +c Compute matrix t2m corresponding to :f2a:. + call matify(t2m,t1a) +c write(6,*) 'result from chrexp' +c call pcmap(1,0,0,0,t1a,t2m) +c Compute am3=t2m+t1m*t1m/2. + call mmult(t1m,t1m,am3) + call smmult(.5d0,am3,am3) + call madd(t2m,am3,am3) +c Compute am2=(t2m+t1m*t1m/2.)*tm + call mmult(am3,tm,am2) +c Compute am3=tm+delta*am1+delta2*am2 for specific value of delta. + delta2=delta*delta + call matmat(tm,am3) + call smmult(delta,am1,t1m) + call madd(am3,t1m,am3) + call smmult(delta2,am2,t1m) + call madd(am3,t1m,am3) + endif +c +c procedure when IOPT = 2 (delta=dp/p0). + if (iopt.eq.2) then + continue + endif +c + return + end +c + subroutine cod(p,th,tmh) +c This is a subroutine for computing closed orbit data. +c Written by Alex Dragt, 6 November 1985 + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'buffer.inc' +c + dimension p(6) + dimension th(monoms),tmh(6,6) +c + dimension ana(monoms),anm(6,6) + dimension ta(monoms),tm(6,6) + dimension tempa(monoms),tempm(6,6) + dimension ba(monoms),bm(6,6) + dimension ca(monoms),cm(6,6) + dimension am1(6,6),am2(6,6),am3(6,6) +c +c Set up control indices: + iopt=nint(p(1)) + delta=p(2) + idata=nint(p(3)) + ipmaps=nint(p(4)) + isend=nint(p(5)) + iwmaps=nint(p(6)) +c +c Write headings + if (isend.eq.1 .or. isend.eq.3) write(jof,90) + if (isend.eq.2 .or. isend.eq.3) write(jodf,90) + 90 format(/,1x,'closed orbit analysis for static map') +c +c Computation of fixed point and map about it. + call fxpt(th,tmh,ana,anm,ta,tm) +c +c Procedure for output of closed orbit location. + if(idata.eq.1 .or. idata.eq.3) then +c Procedure when IOPT = 1: + if (iopt.eq.1) then +c Compute location of closed orbit for given delta value + delta2=delta*delta + delta3=delta*delta2 + xc=delta*tm(1,6)-delta2*ta(63)-delta3*ta(174) + pxc=delta*tm(2,6)+delta2*ta(48)+delta3*ta(139) + yc=delta*tm(3,6)-delta2*ta(79)-delta3*ta(204) + pyc=delta*tm(4,6)+delta2*ta(73)+delta3*ta(194) +c Write out results + do 5 i=1,2 + if (i.eq.1) then + iflag=1 + if (isend.eq.2) iflag=0 + ifile=jof + endif + if (i.eq.2) then + iflag=1 + if (isend.eq.1) iflag=0 + ifile=jodf + endif + if (iflag.eq.0) goto 5 + write(ifile,100) + 100 format(/,1x,'closed orbit data for delta defined in terms of', + & 1x,'energy deviation:') + write(ifile,120) + 120 format(1x,'location of closed orbit (x,px,y,py)') + write(ifile,130) + 130 format(/,1x,'terms linear in delta') + write(ifile,140) tm(1,6),tm(2,6),tm(3,6),tm(4,6) + 140 format(1x,4(d15.8,2x)) + write(ifile,150) + 150 format(/,1x,'terms quadratic in delta') + write(ifile,140) -ta(63),ta(48),-ta(79),ta(73) + write(ifile,160) + 160 format(/,1x,'terms cubic in delta') + write(ifile,140) -ta(174),ta(139),-ta(204),ta(194) + write(ifile,110) delta + 110 format(/,1x,'location of closed orbit when delta = ',d15.8) + write(ifile,140) xc,pxc,yc,pyc + 5 continue + endif +c Procedure when IOPT = 2 + if (iopt.eq.2) then +c Compute location of closed orbit for given delta value +c +c the code below needs to be modified + delta2=delta*delta + delta3=delta*delta2 + xc=delta*tm(1,6)-delta2*ta(63)-delta3*ta(174) + pxc=delta*tm(2,6)+delta2*ta(48)+delta3*ta(139) + yc=delta*tm(3,6)-delta2*ta(79)-delta3*ta(204) + pyc=delta*tm(4,6)+delta2*ta(73)+delta3*ta(194) +c end of code to be modified +c +c Write out results + do 7 i=1,2 + if (i.eq.1) then + iflag=1 + if (isend.eq.2) iflag=0 + ifile=jof + endif + if (i.eq.2) then + iflag=1 + if (isend.eq.1) iflag=0 + ifile=jodf + endif + if (iflag.eq.0) goto 7 + write(ifile,102) + 102 format(/,1x,'closed orbit data for delta defined in terms of', + & 1x,'momentum deviation:') +c +c the code below needs to be modified + write(ifile,120) + write(ifile,130) + write(ifile,140) tm(1,6),tm(2,6),tm(3,6),tm(4,6) + write(ifile,150) + write(ifile,140) -ta(63),ta(48),-ta(79),ta(73) + write(ifile,160) + write(ifile,140) -ta(174),ta(139),-ta(204),ta(194) + write(ifile,110) delta + write(ifile,140) xc,pxc,yc,pyc +c end of code to be modified +c + 7 continue + write(6,*) 'IOPT = 2 case not yet installed completely' + endif + endif +c +c Factorization of map into betatron and remaining terms. +c Computation of betatron term script B. + call betmap(ana,anm,ba,bm) +c Computation of remaining nonlinear correction map script C. + call mapmap(ba,bm,tempa,tempm) + call inv(tempa,tempm) + call concat(tempa,tempm,ana,anm,ca,cm) +c Computation of B for specific value of delta. + call chrexp(iopt,delta,ba,bm,am1,am2,am3) +c +c Procedure for output of twiss matrix and corrections. + if(idata.eq.2 .or. idata.eq.3) then +c Procedure when IOPT =1 + if (iopt.eq.1) then +c Print out matrices bm, am1, and am2. + do 9 i=1,2 + if (i.eq.1) then + iflag=1 + if (isend.eq.2) iflag=0 + ifile=jof + endif + if (i.eq.2) then + iflag=1 + if (isend.eq.1) iflag=0 + ifile=jodf + endif + if (iflag.eq.0) goto 9 + write(ifile,198) + 198 format(//,1x,'twiss matrix for delta defined in terms of energy', + &1x,'deviation:') + write(ifile,200) + 200 format(/,1x,'on energy twiss matrix') + call pcmap(i,0,0,0,ba,bm) + write(ifile,300) + 300 format(//,1x,'matrix for delta correction') + call pcmap(i,0,0,0,ba,am1) + write(ifile,400) + 400 format(//,1x,'matrix for delta**2 correction') + call pcmap(i,0,0,0,ba,am2) +c Print out value of twiss matrix + write(ifile,402) delta + 402 format(//,1x,'value of twiss matrix when delta= ',d15.8) + call pcmap(i,0,0,0,ba,am3) + 9 continue + endif +c Procedure when IOPT = 2 + if (iopt.eq.2) then +c Print out matrices bm, am1, and am2. + do 11 i=1,2 + if (i.eq.1) then + iflag=1 + ifile=jof + if (isend.eq.2) iflag=0 + endif + if (i.eq.2) then + iflag=1 + if (isend.eq.1) iflag=0 + ifile=jodf + endif + if (iflag.eq.0) goto 11 + write(ifile,199) + 199 format(//,1x,'twiss matrix for delta defined in terms of', + &1x,'momentum deviation:') + write(ifile,202) + 202 format(/,1x,'on momentum twiss matrix') + call pcmap(i,0,0,0,ba,bm) + write(ifile,300) + call pcmap(i,0,0,0,ba,am1) + write(ifile,400) + call pcmap(i,0,0,0,ba,am2) +c Print out value of twiss matrix + write(ifile,402) delta + call pcmap(i,0,0,0,ba,am3) + 11 continue + endif + endif +c +c Procedure for output of the maps BC, B, and C. + if (ipmaps.eq.1 .or. ipmaps.eq.3) then + do 13 i=1,2 + if (i.eq.1) then + iflag=1 + if (isend.eq.2) iflag=0 + ifile=jof + endif + if (i.eq.2) then + iflag=1 + if (isend.eq.1) iflag=0 + ifile=jodf + endif + if (iflag.eq.0) goto 13 + write(ifile,600) + 600 format(//,1x,'total transfer map about the closed orbit') + call pcmap(i,i,0,0,ana,anm) + write(ifile,700) + 700 format(//,1x,'betatron factor of transfer map') + call pcmap(i,i,0,0,ba,bm) + write(ifile,800) + 800 format(//,1x,'nonlinear factor of transfer map') + call pcmap(i,i,0,0,ca,cm) + 13 continue + endif +c +c Procedure for output of script T. + if (ipmaps.eq.2 .or. ipmaps.eq.3) then + do 15 i=1,2 + if (i.eq.1) then + iflag=1 + if (isend.eq.2) iflag=0 + ifile=jof + endif + if (i.eq.2) then + iflag=1 + if (isend.eq.1) iflag=0 + ifile=jodf + endif + if (iflag.eq.0) goto 15 + write(ifile,900) + 900 format(//,1x,'transfer map script T to the closed orbit') + call pcmap(i,i,0,0,ta,tm) + 15 continue + endif + +c +c Put maps in buffers + call mapmap(ana,anm,buf1a,buf1m) + call mapmap(ba,bm,buf2a,buf2m) + call mapmap(ca,cm,buf3a,buf3m) + call clear(buf4a,buf4m) + call mapmap(buf4a,am3,buf4a,buf4m) + call mapmap(ta,tm,buf5a,buf5m) +c +c Procedure for writing of maps. + if(iwmaps.gt.0) then + mpot=mpo + mpo=iwmaps + call mapout(0,ana,anm) + call mapout(0,ba,bm) + call mapout(0,ca,cm) + call mapout(0,buf4a,buf4m) + call mapout(0,ta,tm) + mpo=mpot + endif +c + return + end +c +*********************************************************************** +c + subroutine csym(isend,fm,ans) +c +c This subroutine checks the symplectic condition for the matrix fm +c Written by Alex Dragt, 4 October 1989 +c + include 'impli.inc' + include 'files.inc' +c +c Calling arrays + dimension fm(6,6) +c +c Temporary arrays + dimension tm(6,6) +c +c-----Procedure +c + call matmat(fm,tm) + call minv(tm) + call mmult(tm,fm,tm) + do 10 i=1,6 + 10 tm(i,i)=tm(i,i)-1.d0 + call mnorm(tm,ans) +c +c Write out results if desired +c + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) ' symplectic violation = ',ans + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) ' symplectic violation = ',ans + endif +c + return + end +c +*********************************************************************** +c + subroutine dia(p,fa,fm) +c this is a routine for computing invariants in the dynamic case +c Written by Alex Dragt, Spring 1987 + use rays + use lieaparam, only : monoms + include 'impli.inc' +c + include 'files.inc' + include 'buffer.inc' +c + dimension p(6),fa(monoms),fm(6,6) +c + dimension ga(monoms),g1a(monoms) + dimension ta(monoms),t1a(monoms),t2a(monoms) + dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6),t2m(6,6) +c +c set up control indices + iopt=nint(p(1)) + idata=nint(p(2)) + ipmaps=nint(p(3)) + isend=nint(p(4)) + iwmaps=nint(p(5)) + iwnum=nint(p(6)) +c +c write headings + if (isend.eq.1 .or. isend.eq.3) then + write (jof,*) + write (jof,*) 'dynamic invariant analysis' + endif + if (isend.eq.2 .or. isend.eq.3) then + write (jodf,*) + write (jodf,*) 'dynamic invariant analysis' + endif +c +c begin calculation +c +c find the transforming (conjugating) map script A +c remove offensive terms from matrix part of map: + call dpur2(fa,fm,ga,gm,ta,tm) +c remove offensive terms from f3 part of map: + call dpur3(ga,gm,g1a,g1m,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,ta,tm,t2a,t2m) +c remove offensive terms from f4 part of map: + call dpur4(g1a,g1m,ga,gm,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,t2a,t2m,ta,tm) +c put script A in buffer 1 and script N in buffer 2 + call mapmap(ta,tm,buf1a,buf1m) + call mapmap(ga,gm,buf2a,buf2m) +c +c procedure for computing invariant +c invert script A + call inv(ta,tm) + call clear(t1a,t1m) +c computation of x invariant + if(iopt.eq.1) then + t1a(7)=1.d0 + t1a(13)=1.d0 + endif +c computation of y invariant + if(iopt.eq.2) then + t1a(18)=1.d0 + t1a(22)=1.d0 + endif +c computation of t invariant + if(iopt.eq.3) then + t1a(25)=1.d0 + t1a(27)=1.d0 + endif +c computation of mixed invariant + if(iopt.ge.4) then + read(iopt,*) anx,any,ant + if (isend.eq.1 .or. isend.eq.3) then + write(jof,*) 'parameters read in from file',iopt + endif + if (isend.eq.2 .or. isend.eq.3) then + write(jof,*) 'parameters read in from file',iopt + endif + t1a(7)=anx + t1a(13)=anx + t1a(18)=any + t1a(22)=any + t1a(25)=ant + t1a(27)=ant + endif +c put invariant in buffer 3 + call ident(buf3a,buf3m) + call fxform(ta,tm,t1a,buf3a) +c +c procedure for putting out data + if (idata.eq.1 .or. idata.eq.3) then + do 10 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 10 + write(ifile,*) + write(ifile,*) 'invariant polynomial' + call pcmap(0,j,0,0,buf3a,buf3m) + 10 continue + endif + if (idata.eq.2 .or. idata.eq.3) then + mpot=mpo + mpo=18 + call mapout(0,buf3a,buf3m) + mpo=mpot + endif +c +c procedure for printing out maps + do 20 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 20 + if (ipmaps.eq.1 .or. ipmaps.eq.3) then + write(ifile,*) + write(ifile,*) 'normalizing map script A' + call pcmap(j,j,0,0,buf1a,buf1m) + endif + if (ipmaps.eq.2 .or. ipmaps.eq.3) then + write(ifile,*) + write(ifile,*) 'normal form map script N' + call pcmap(j,j,0,0,buf2a,buf2m) + endif + 20 continue +c +c procedure for writing out maps + if (iwmaps.gt.0) then + mpot=mpo + mpo=iwmaps + call mapout(0,buf1a,buf1m) + call mapout(0,buf2a,buf2m) + call mapout(0,buf3a,buf3m) + mpo=mpot + endif +c +c procedure for computing values of invariant and writing them out + if (iwnum.gt.0) then + write(jof,*) + write(jof,*) 'values of invariant written on file ',iwnum + do 30 k=1,nraysp + do 40 j=1,6 + 40 zi(j)=zblock(j,k) + call evalf(zi,buf3a,val2,val3,val4) + write(iwnum,60) k,val2,val3,val4,0.,0. + 60 format(1x,i12,5(1x,1pe12.5)) + 30 continue + endif +c +c put maps in buffers +c buffers 1 and 2 already contain the transforming map script A +c and the normal form map script N, respectively. +c buffer 3 contains the map which has for its matrix the identity +c matrix and for its array the invariant polynomial. +c clear buffers 4 and 5 + call clear(buf4a,buf4m) + call clear(buf5a,buf5m) +c + return + end +c +*********************************************************************** +c + subroutine dnor_old(p,fa,fm) +c this is a subroutine for normal form analysis of dynamic maps +c Written by Alex Dragt, Spring 1987 + use parallel, only : idproc + use lieaparam, only : monoms + include 'impli.inc' +c + include 'files.inc' + include 'buffer.inc' +c + dimension p(6),fa(monoms),fm(6,6) +c + dimension ga(monoms),g1a(monoms) + dimension ta(monoms),t1a(monoms),t2a(monoms) + dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6),t2m(6,6) +c +c set up control indices + idata=nint(p(1)) + ipmaps=nint(p(2)) + isend=nint(p(3)) + iwmaps=nint(p(4)) +c +c write headings + if ((isend.eq.1 .or. isend.eq.3) .and. idproc.eq.0) then + write (jof,*) + write (jof,*) 'dynamic normal form analysis' + endif + if ((isend.eq.2 .or. isend.eq.3) .and. idproc.eq.0) then + write (jodf,*) + write (jodf,*) 'dynamic normal form analysis' + endif +c +c begin calculation +c +c remove offensive terms from matrix part of map: + call dpur2(fa,fm,ga,gm,ta,tm,t2m) +c remove offensive terms from f3 part of map: + call dpur3(ga,gm,g1a,g1m,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,ta,tm,t2a,t2m) +c remove offensive terms from f4 part of map: + call dpur4(g1a,g1m,ga,gm,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,t2a,t2m,ta,tm) +c put transforming map in buffer 1 + call mapmap(ta,tm,buf1a,buf1m) +c put transformed map in buffer 2 + call mapmap(ga,gm,buf2a,buf2m) +c +c procedure for computing normal form exponent and pseudo hamiltonian + call ident(buf3a,buf3m) + if (idata.eq.1 .or. idata.eq.2 .or. idata.eq.3) then +c compute phase advances + cwx=gm(1,1) + swx=gm(1,2) + wx=atan2(swx,cwx) + cwy=gm(3,3) + swy=gm(3,4) + wy=atan2(swy,cwy) + cwt=gm(5,5) + swt=gm(5,6) + wt=atan2(swt,cwt) +c set up normal form for exponent + do 10 i=1,27 + 10 ga(i)=0. + ga(7)=-wx/2.d0 + ga(13)=-wx/2.d0 + ga(18)=-wy/2.d0 + ga(22)=-wy/2.d0 + ga(25)=-wt/2.d0 + ga(27)=-wt/2.d0 + endif +c transform exponent to get pseudo hamiltonian + if (idata.eq.2 .or. idata.eq.3) then + call inv(ta,tm) + call fxform(ta,tm,ga,g1a) +c store results in buffer 3 + call mapmap(g1a,buf3m,buf3a,buf3m) + endif +c +c procedure for putting out data + do 20 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 20 + if (idata.eq.1 .or. idata.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'exponent for normal form' + call pcmap(0,j,0,0,ga,gm) + endif + if (idata.eq.2. .or. idata.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'pseudo hamiltonian' + call pcmap(0,j,0,0,buf3a,buf3m) + endif + 20 continue +c +c procedure for printing out maps + do 30 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 30 + if (ipmaps.eq.1 .or. ipmaps.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'normalizing map script A' + call pcmap(j,j,0,0,buf1a,buf1m) + endif + if (ipmaps.eq.2. .or. ipmaps.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0) + &write(ifile,*) 'normal form script N for transfer map' + call pcmap(j,j,0,0,buf2a,buf2m) + endif + 30 continue +c +c procedure for writing out maps + if (iwmaps.gt.0) then + mpot=mpo + mpo=iwmaps + call mapout(0,buf1a,buf1m) + call mapout(0,buf2a,buf2m) + call mapout(0,buf3a,buf3m) + mpo=mpot + endif +c +c put maps in buffers +c buffers 1 and 2 already contain the transforming map script A +c and the normal form map script N, respectively. +c buffer 3 contains the map which has for its matrix the identity +c matrix and for its array the pseudo hamiltonian. +c clear buffers 4 and 5 + call clear(buf4a,buf4m) + call clear(buf5a,buf5m) +c + return + end +c +******************************************************************* +c + subroutine dnor(p,fa,fm) +c this is a subroutine for normal form analysis of dynamic maps +c Written by Alex Dragt, Spring 1987 +c + use parallel, only : idproc + use lieaparam, only : monoms + include 'impli.inc' +c + include 'files.inc' + include 'buffer.inc' +c +c Calling arrays + dimension p(6),fa(monoms),fm(6,6) +c +c Local arrays + dimension ga(monoms),g1a(monoms) + dimension ta(monoms),t1a(monoms) + dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6) +c +c set up control indices + keep= nint(p(1)) + idata= nint(p(2)) + ipmaps=nint(p(3)) + isend= nint(p(4)) + iwmaps=nint(p(5)) +c +c write headings + if (isend.eq.1 .or. isend.eq.3) then + if(idproc.eq.0)write (jof,*) + if(idproc.eq.0)write (jof,*) 'dynamic normal form analysis' + endif + if (isend.eq.2 .or. isend.eq.3) then + if(idproc.eq.0)write (jodf,*) + if(idproc.eq.0)write (jodf,*) 'dynamic normal form analysis' + endif +c +c begin calculation +c +c remove offensive terms from matrix part of map: + call dpur2(fa,fm,ga,gm,ta,tm,t1m) +c remove offensive terms from f3 part of map: + call dpur3(ga,gm,g1a,g1m,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,ta,tm,ta,tm) +c remove offensive terms from f4 part of map: + call dpur4(g1a,g1m,ga,gm,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,ta,tm,ta,tm) +c put transforming map in buffer 1 + call mapmap(ta,tm,buf1a,buf1m) +c put transformed map in buffer 2 + call mapmap(ga,gm,buf2a,buf2m) +c +c procedure for computing normal form exponent and pseudo hamiltonian + call ident(buf3a,buf3m) + if (idata.eq.1 .or. idata.eq.2 .or. idata.eq.3) then +c compute phase advances + cwx=gm(1,1) + swx=gm(1,2) + wx=atan2(swx,cwx) + cwy=gm(3,3) + swy=gm(3,4) + wy=atan2(swy,cwy) + cwt=gm(5,5) + swt=gm(5,6) + wt=atan2(swt,cwt) +c set up normal form for exponent + do 10 i=1,27 + 10 ga(i)=0. + ga(7)=-wx/2.d0 + ga(13)=-wx/2.d0 + ga(18)=-wy/2.d0 + ga(22)=-wy/2.d0 + ga(25)=-wt/2.d0 + ga(27)=-wt/2.d0 + endif +c transform exponent to get pseudo hamiltonian + if (idata.eq.2 .or. idata.eq.3) then + call inv(ta,tm) + call fxform(ta,tm,ga,g1a) +c store results in buffer 3 + call mapmap(g1a,buf3m,buf3a,buf3m) + endif +c +c procedure for putting out data + do 20 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 20 + if (idata.eq.1 .or. idata.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'exponent for normal form' + call pcmap(0,j,0,0,ga,gm) + endif + if (idata.eq.2. .or. idata.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'pseudo hamiltonian' + call pcmap(0,j,0,0,buf3a,buf3m) + endif + 20 continue +c +c procedure for printing out maps + do 30 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 30 + if (ipmaps.eq.1 .or. ipmaps.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'normalizing map script A' + call pcmap(j,j,0,0,buf1a,buf1m) + endif + if (ipmaps.eq.2. .or. ipmaps.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0) + & write(ifile,*) 'normal form script N for transfer map' + call pcmap(j,j,0,0,buf2a,buf2m) + endif + 30 continue +c +c procedure for writing out maps + if (iwmaps.gt.0) then + mpot=mpo + mpo=iwmaps + call mapout(0,buf1a,buf1m) + call mapout(0,buf2a,buf2m) + call mapout(0,buf3a,buf3m) + mpo=mpot + endif +c +c put maps in buffers +c buffers 1 and 2 already contain the transforming map script A +c and the normal form map script N, respectively. +c buffer 3 contains the map which has for its matrix the identity +c matrix and for its array the pseudo hamiltonian. +c clear buffers 4 and 5 + call clear(buf4a,buf4m) + call clear(buf5a,buf5m) +c + return + end +c +******************************************************************* +c + subroutine fadm(p,fa,fm) +c this subroutine fourier analyzes a dynamic transfer map + use lieaparam, only : monoms + include 'impli.inc' + dimension p(6),fa(monoms),fm(6,6) +c + write(6,*) 'fadm not yet available' + return + end +c +******************************************************************* +c + subroutine fasm(p,fa,fm) +c this subroutine fourier analyzes a static transfer map + use lieaparam, only : monoms + include 'impli.inc' + dimension p(6),fa(monoms),fm(6,6) +c + write(6,*) 'fasm not yet available' + return + end +c +******************************************************************* +c + subroutine gbuf_old(p,fa,fm) +c this subroutine gets a map from an auxiliary buffer and +c concatenates it with the map in the main buffer. +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' + include 'buffer.inc' +c + dimension p(6),fa(monoms),fm(6,6) +c + dimension ta(monoms),tm(6,6) +c +c set up and test control index + i=nint(p(1)) + if (i.lt.1 .or. i.gt.5) then + write(6,*) 'trouble with index nmap in gbuf' + return + endif +c +c concatenate the map in bufi with the existing map + if(i.eq.1) call scncat(fa,fm,buf1a,buf1m,ta,tm) + if(i.eq.2) call scncat(fa,fm,buf2a,buf2m,ta,tm) + if(i.eq.3) call scncat(fa,fm,buf3a,buf3m,ta,tm) + if(i.eq.4) call scncat(fa,fm,buf4a,buf4m,ta,tm) + if(i.eq.5) call scncat(fa,fm,buf5a,buf5m,ta,tm) + call mapmap(ta,tm,fa,fm) +c + return + end +c +c***************************************************************************** +c + subroutine gbuf(p,fa,fm) +c this subroutine gets a map from an auxiliary buffer and +c either concatenates it with the map in the main buffer, +c or uses it to replace the map in the main buffer. +c Written by Alex Dragt, Spring 1987 +c Modified by Alex Dragt, 17 June 1988 +c Modified by Alex Dragt, 13 October 1988 +c + include 'impli.inc' + include 'param.inc' + include 'buffer.inc' +c +c Calling arrays + dimension p(6),fa(monoms),fm(6,6) +c +c set up and test control indices + iopt=nint(p(1)) + i=nint(p(2)) + if (i.lt.1 .or. i.gt.5) then + write(6,*) 'trouble with index nmap in gbuf' + return + endif +c +c if iopt=1, concatenate the existing map with the map in bufi + if(iopt.eq.1) then + if(i.eq.1) call concat(fa,fm,buf1a,buf1m,fa,fm) + if(i.eq.2) call concat(fa,fm,buf2a,buf2m,fa,fm) + if(i.eq.3) call concat(fa,fm,buf3a,buf3m,fa,fm) + if(i.eq.4) call concat(fa,fm,buf4a,buf4m,fa,fm) + if(i.eq.5) call concat(fa,fm,buf5a,buf5m,fa,fm) + return + endif +c +c if iopt=2, replace the existing map with the map in bufi + if(iopt.eq.2) then + if(i.eq.1) call mapmap(buf1a,buf1m,fa,fm) + if(i.eq.2) call mapmap(buf2a,buf2m,fa,fm) + if(i.eq.3) call mapmap(buf3a,buf3m,fa,fm) + if(i.eq.4) call mapmap(buf4a,buf4m,fa,fm) + if(i.eq.5) call mapmap(buf5a,buf5m,fa,fm) + return + endif +c + write(6,*) 'trouble with index iopt in gbuf' + return + end +c +c***************************************************************************** +c + subroutine geom(pp) +c +c Routine to compute geometry of a loop. +c Written by A. Dragt 8/27/92. +c Modified 5/27/98 AJD. +c Modified 1/8/99 AJD. +c Based on the subroutines cqlate and pmif +c + use beamdata + use lieaparam + use acceldata + include 'impli.inc' +c +c common blocks +c + include 'codes.inc' + include 'files.inc' + include 'loop.inc' + include 'core.inc' + include 'pie.inc' + include 'parset.inc' + include 'usrdat.inc' +c + dimension pp(6) +c +c local variables +c + character*8 string(5),str + dimension ex(3), ey(3), ez(3) + dimension exl(3), eyl(3), ezl(3) + dimension exlt(3), eylt(3), ezlt(3) + dimension dims(6) +c +c set up control indices +c + iopt=nint(pp(1)) + si=pp(2) + ti=pp(3) + ipset1=nint(pp(4)) + ipset2=nint(pp(5)) + isend=nint(pp(6)) +c +c get contents of psets +c + if (ipset1.gt.0 .and. ipset1.le.maxpst) then + xi=pst(1,ipset1) + yi=pst(2,ipset1) + zi=pst(3,ipset1) + phid=pst(4,ipset1) + thetad=pst(5,ipset1) + psid=pst(6,ipset1) + phir=phid*pi180 + thetar=thetad*pi180 + psir=psid*pi180 + endif + if (ipset2.gt.0 .and. ipset2.le.maxpst) then + ifile=nint(pst(1,ipset2)) + jfile=nint(pst(2,ipset2)) + kfile=nint(pst(3,ipset2)) + lfile=nint(pst(4,ipset2)) + mfile=nint(pst(5,ipset2)) + ndpts=nint(pst(6,ipset2)) + endif +c +c set up variables and constants +c + ss=si + tt=ti + vr=1.d0/(beta*c) + x=xi + y=yi + z=zi + do i=1,6 + dims(i)=0.d0 + end do + do i=1,3 + ex(i)=0.d0 + ey(i)=0.d0 + ez(i)=0.d0 + end do + ex(1)=1.d0 + ey(2)=1.d0 + ez(3)=1.d0 +c write(6,*) ' thetar =', thetar + call erotv(phir,thetar,psir,ex,exl) + call erotv(phir,thetar,psir,ey,eyl) + call erotv(phir,thetar,psir,ez,ezl) +c +c start routine +c +c write out header + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) ' ' + write(jof,*) ' Geometrical Analysis' + write(jof,*) ' ' + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) ' ' + write(jodf,*) ' Geometrical Analysis' + write(jodf,*) ' ' + endif +c +c see if a loop exists + if(nloop.le.0) then + write(jof ,*) ' error from geom: no loop has been specified' + write(jodf,*) ' error from geom: no loop has been specified' + return + endif +c +c write out starting values + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) ' initial s,x,y,z,t;ex,ey,ez:' + write(jof,237) si,xi,yi,zi,ti + write(jof,*) exl(1),exl(2),exl(3) + write(jof,*) eyl(1),eyl(2),eyl(3) + write(jof,*) ezl(1),ezl(2),ezl(3) + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jof,*) ' initial s,x,y,z,t;ex,ey,ez:' + write(jodf,237) si,xi,yi,zi,ti + write(jodf,*) exl(1),exl(2),exl(3) + write(jodf,*) eyl(1),eyl(2),eyl(3) + write(jodf,*) ezl(1),ezl(2),ezl(3) + endif +c +c scan the loop +c + do 137 jk1=1,joy +c +c initialize various quantities + icat=0 + grad = 0.d0 +c +c record element category and set various quantities +c +c element + if(mim(jk1).lt.0) then + string(1)=lmnlbl(-mim(jk1))(1:8) +c user supplied element + else if(mim(jk1).gt.5000) then + string(1)=lmnlbl(mim(jk1)-5000)(1:8) +c lump + else + string(1)=ilbl(inuse(mim(jk1)))(1:8) + endif + call lookup(string(1),itype,item) +c write(6,513) string(1) +c 513 format(1x,a8) +c write(6,*) 'itype and item are ',itype, item +c +c procedure for a menu item +c + if(itype.eq.1) then + k=item + imax=nrp(nt1(k),nt2(k)) +c +c see if item is a simple command +c + if (nt1(k) .eq. 7) then +c dims + if (nt2(k) .eq. 35) then + do ii=1,6 + dims(ii)=pmenu(ii+mpp(k)) + end do + endif +c + endif +c +c see if item is a simple element +c + if (nt1(k) .eq. 1) then +c +c drift + if (nt2(k) .eq. 1) then + icat=1 + aleng = pmenu(1+mpp(k)) + endif +c spce + if (nt2(k) .eq. 25) then + icat=1 + aleng = pmenu(1+mpp(k)) + endif +c arc + if (nt2(k) .eq. 30) then + icat=4 + d1 = pmenu(1+mpp(k)) + d2 = pmenu(2+mpp(k)) + aleng = pmenu(3+mpp(k)) + angd = pmenu(4+mpp(k)) + endif +c quad + if (nt2(k) .eq. 9) then + icat=1 + aleng = pmenu(1+mpp(k)) + grad = pmenu(2+mpp(k)) + endif +c cfqd + if (nt2(k) .eq. 18) then + icat=1 + aleng = pmenu(1+mpp(k)) + ipst = nint(pmenu(2+mpp(k))) + if (ipst.gt.0 .and. ipst.le.maxpst) then + grad = pst(1,ipst) + endif + endif +c sext + if (nt2(k) .eq. 10) then + icat=1 + aleng = pmenu(1+mpp(k)) + endif +c octm + if (nt2(k) .eq. 11) then + icat=1 + aleng = pmenu(1+mpp(k)) + endif +c recm + if (nt2(k) .eq. 24) then + icat=1 + aleng = pmenu(2+mpp(k)) - pmenu(1+mpp(k)) +c +c computing the gradient for recm is complicated +c and so it is not done for the time being +c + endif +c sol + if (nt2(k) .eq. 20) then + icat=1 + aleng = pmenu(2+mpp(k)) - pmenu(1+mpp(k)) + endif +c nbend + if (nt2(k) .eq. 2) then + icat=2 + angd=pmenu(1+mpp(k)) + b=pmenu(4+mpp(k)) + endif +c pbend + if (nt2(k) .eq. 3) then + icat=2 + angd=pmenu(1+mpp(k)) + b=pmenu(4+mpp(k)) + endif +c gbend + if (nt2(k) .eq. 4) then + icat=2 + angd=pmenu(1+mpp(k)) + b=pmenu(6+mpp(k)) + endif +c gbdy + if (nt2(k) .eq. 6) then + icat=2 + angd=pmenu(1+mpp(k)) + b=pmenu(4+mpp(k)) + endif +c cfbd + if (nt2(k) .eq. 8) then + icat=2 + angd=pmenu(1+mpp(k)) + b=pmenu(2+mpp(k)) + ipst = nint(pmenu(6+mpp(k))) + if (ipst.gt.0 .and. ipst.le.maxpst) then + grad = pst(1,ipst) + endif + endif +c arot + if (nt2(k) .eq. 14) then + icat=3 + angd=pmenu(1+mpp(k)) + endif +c prot +c if (nt2(k) .eq. 5) then +c angd=pmenu(1+mpp(k)) +c kind=nint(pmenu(2+mpp(k))) +c endif +c +c carry out computations for items dims thru prot above +c +c compute and write out local geometry + if( iopt .eq. 2 .or. iopt .eq. 3 + & .or. iopt .eq. 12 .or. iopt .eq. 13) then +c +c procedure for a straight element + if(icat .eq. 1) then +c +c write all descriptive information to external file mfile + if (mfile .gt. 0) then + write(mfile,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + 605 format(1h ,1x,a8,1x,a8,1x,i5,1x,i5,1x,i5) + if(imax.eq.0)goto 137 + write(mfile,607)(pmenu(i+mpp(k)),i=1,imax) +c Output using Mottershead's favorite pg format + 607 format((1h ,3(1x,1pg22.15))) + write(mfile,611) lmnlbl(k), aleng + 611 format(2x,a,f9.4) + write(mfile,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) + 608 format(1x,6f12.4) + endif +c +c write all descriptive information to terminal and/or drop file + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + if(imax.eq.0)goto 137 + write(jof,607)(pmenu(i+mpp(k)),i=1,imax) +c Output using Mottershead's favorite pg format + write(jof,609) lmnlbl(k), aleng + 609 format(2x,a,'length =',f9.4,2x,'dimensions:') + write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) + write(jof,*) ' s,x,y,z,t;ex,ey,ez along element:' + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + if(imax.eq.0)goto 137 + write(jodf,607)(pmenu(i+mpp(k)),i=1,imax) + write(jodf,609) lmnlbl(k), aleng + write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) + write(jodf,*) ' s,x,y,z,t;ex,ey,ez along element:' + endif +c +c subdivide element + ndptst=ndpts + if(ndpts .lt. 1) ndptst=1 + daleng=aleng/float(ndptst) + if( dabs(aleng) .lt. 1.0d-10) ndptst=0 + do i=0,ndptst + sst = ss + daleng*float(i) + ttt = tt + daleng*float(i)*vr + xt = x + daleng*float(i)*ezl(1) + yt = y + daleng*float(i)*ezl(2) + zt = z + daleng*float(i)*ezl(3) +c +c write simple element descriptive information +c and pathlength information to external file kfile + if (kfile .gt. 0) then + write(kfile,610) lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad + 610 format (1x,a8,2(i3),4(1x,1pe12.5)) + endif +c +c write simple element descriptive information and pathlength +c and coordinate information to external file lfile + if (lfile .gt. 0) then + write(lfile,710) + & lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad,xt,yt,zt,ttt + 710 format (1x,a8,2(i3),8(1x,1pe12.5)) + endif +c +c write coordinate information to external file mfile + if (mfile .gt. 0) then + write(mfile,236) sst,xt,yt,zt,ttt,0.0 + 236 format(6(1x,1pe12.5)) + endif +c +c write coordinate information to terminal and/or drop file + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,237) sst,xt,yt,zt,ttt + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,237) sst,xt,yt,zt,ttt + endif + 237 format(5(1x,1pe12.5)) +c +c write orientation information to external file mfile + if (mfile .gt. 0) then + write(mfile,*) exl(1), exl(2), exl(3) + write(mfile,*) eyl(1), eyl(2), eyl(3) + write(mfile,*) ezl(1), ezl(2), ezl(3) + endif +c +c write orientation information to terminal and/or drop file + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) exl(1), exl(2), exl(3) + write(jof,*) eyl(1), eyl(2), eyl(3) + write(jof,*) ezl(1), ezl(2), ezl(3) + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) exl(1), exl(2), exl(3) + write(jodf,*) eyl(1), eyl(2), eyl(3) + write(jodf,*) ezl(1), ezl(2), ezl(3) + endif +c + end do + endif +c +c procedure for a bending (dipole) element + if(icat .eq. 2) then + angr=angd*pi180 + rho=brho/b + aleng=rho*angr +c +c write all descriptive information to external file mfile + if (mfile .gt. 0) then + write(mfile,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + if(imax.eq.0)goto 137 + write(mfile,607)(pmenu(i+mpp(k)),i=1,imax) +c Output using Mottershead's favorite pg format + write(mfile,611) lmnlbl(k), aleng + write(mfile,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) + endif +c +c write all descriptive information to terminal and/or drop file + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + if(imax.eq.0)goto 137 + write(jof,607)(pmenu(i+mpp(k)),i=1,imax) + write(jof,609) lmnlbl(k), aleng + write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) + write(jof,*) ' s,x,y,z,t;ex,ey,ez along element:' + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + if(imax.eq.0)goto 137 + write(jodf,607)(pmenu(i+mpp(k)),i=1,imax) + write(jodf,609) lmnlbl(k), aleng + write(jodf,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) + write(jodf,*) ' s,x,y,z,t;ex,ey,ez along element:' + endif +c +c subdivide element + ndptst=ndpts + if(ndpts .lt. 1) ndptst=1 + daleng=aleng/float(ndptst) + dangr=angr/float(ndptst) + if( dabs(aleng) .lt. 1.0d-10) ndptst=0 + do i=0,ndptst + sst = ss + daleng*float(i) + ttt = tt + daleng*float(i)*vr + angrt=dangr*float(i) + sfact=rho*dsin(angrt) + cfact=rho*(1.d0 - dcos(angrt)) +c Note: signs have been adjusted to take into account that +c the rotation axis is - eyl. + xt = x -cfact*exl(1) + sfact*ezl(1) + yt = y -cfact*exl(2) + sfact*ezl(2) + zt = z -cfact*exl(3) + sfact*ezl(3) + angrt=-angrt + call rotv(eyl,angrt,exl,exlt) + call rotv(eyl,angrt,ezl,ezlt) +c +c write simple element descriptive information +c and pathlength information to external file kfile + if (kfile .gt. 0) then + write(kfile,610) lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad + endif +c +c +c write simple element descriptive information and pathlength +c and coordinate information to external file lfile + if (lfile .gt. 0) then + write(lfile,710) + & lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad,xt,yt,zt,ttt + endif +c +c write coordinate information to external file mfile + if (mfile .gt. 0) then + write(mfile,236) sst,xt,yt,zt,ttt,0.0 + endif +c +c write coordinate information to terminal and/or drop file + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,237) sst,xt,yt,zt,ttt + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,237) sst,xt,yt,zt,ttt + endif +c +c write orientation information to external file mfile + if (mfile .gt. 0) then + write(mfile,*) exlt(1), exlt(2), exlt(3) + write(mfile,*) eyl(1), eyl(2), eyl(3) + write(mfile,*) ezlt(1), ezlt(2), ezlt(3) + endif +c +c write orientation information to terminal and/or drop file + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) exlt(1), exlt(2), exlt(3) + write(jof,*) eyl(1), eyl(2), eyl(3) + write(jof,*) ezlt(1), ezlt(2), ezlt(3) + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) exlt(1), exlt(2), exlt(3) + write(jodf,*) eyl(1), eyl(2), eyl(3) + write(jodf,*) ezlt(1), ezlt(2), ezlt(3) + endif + end do + endif +c +c procedure for an arc (arc) + if(icat .eq. 4) then +c +c write all descriptive information to external file mfile + if (mfile .gt. 0) then + write(mfile,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + if(imax.eq.0)goto 137 + write(mfile,607)(pmenu(i+mpp(k)),i=1,imax) +c Output using Mottershead's favorite pg format + write(mfile,611) lmnlbl(k), aleng + write(mfile,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) + endif +c +c write all descriptive information to terminal and/or drop file + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + if(imax.eq.0)goto 137 + write(jof,607)(pmenu(i+mpp(k)),i=1,imax) + write(jof,609) lmnlbl(k), aleng + write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) + write(jof,*) ' s,x,y,z,t;ex,ey,ez along element:' + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + if(imax.eq.0)goto 137 + write(jodf,607)(pmenu(i+mpp(k)),i=1,imax) + write(jodf,609) lmnlbl(k), aleng + write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) + write(jodf,*) ' s,x,y,z,t;ex,ey,ez along element:' + endif +c +c subdivide element + ndptst=ndpts + if(ndpts .lt. 1) ndptst=1 + daleng=aleng/float(ndptst) + dd1=d1/float(ndptst) + dd2=d2/float(ndptst) + hypot=dsqrt(d1**2 + d2**2) + angt=0.d0 + if (hypot .gt. 0.d0) then + sin=d2/hypot + cos=d1/hypot + angt=atan2(sin,cos) + endif + call rotv(eyl,angt,exl,exlt) + call rotv(eyl,angt,ezl,ezlt) + if( dabs(aleng) .lt. 1.0d-10) ndptst=0 + do i=0,ndptst + sst = ss + daleng*float(i) + ttt = tt + daleng*float(i)*vr + xt = x + (dd1*ezl(1)+dd2*exl(1))*float(i) + yt = y + (dd1*ezl(2)+dd2*exl(2))*float(i) + zt = z + (dd1*ezl(3)+dd2*exl(3))*float(i) +c +c write simple element descriptive information +c and pathlength information to external file kfile + if (kfile .gt. 0) then + write(kfile,610) lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad + endif +c +c write simple element descriptive information and pathlength +c and coordinate information to external file lfile + if (lfile .gt. 0) then + write(lfile,710) + & lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad,xt,yt,zt,ttt + endif +c +c write coordinate information to external file mfile + if (mfile .gt. 0) then + write(mfile,236) sst,xt,yt,zt,ttt,0.0 + endif +c +c write coordinate information to terminal and/or drop file + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,237) sst,xt,yt,zt,ttt + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,237) sst,xt,yt,zt,ttt + endif +c +c write orientation information to external file mfile + if (mfile .gt. 0) then + write(mfile,*) exlt(1), exlt(2), exlt(3) + write(mfile,*) eyl(1), eyl(2), eyl(3) + write(mfile,*) ezlt(1), ezlt(2), ezlt(3) + endif +c +c write orientation information to terminal and/or drop file + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) exlt(1), exlt(2), exlt(3) + write(jof,*) eyl(1), eyl(2), eyl(3) + write(jof,*) ezlt(1), ezlt(2), ezlt(3) + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) exlt(1), exlt(2), exlt(3) + write(jodf,*) eyl(1), eyl(2), eyl(3) + write(jodf,*) ezlt(1), ezlt(2), ezlt(3) + endif +c + end do + endif +c + endif +c +c update geometry for items dims thru prot above +c +c procedure for a straight element + if(icat .eq. 1) then + ss = ss + aleng + tt = tt + aleng*vr + x = x + aleng*ezl(1) + y = y + aleng*ezl(2) + z = z + aleng*ezl(3) + endif +c +c procedure for a bending (dipole) element + if(icat .eq. 2) then + angr=angd*pi180 + rho=brho/b + aleng=rho*angr + ss = ss + aleng + tt = tt + aleng*vr + sfact=rho*dsin(angr) + cfact=rho*(1.d0 - dcos(angr)) +c Note: signs have been adjusted to take into account that +c the rotation axis is - eyl. + x = x -cfact*exl(1) + sfact*ezl(1) + y = y -cfact*exl(2) + sfact*ezl(2) + z = z -cfact*exl(3) + sfact*ezl(3) + angr=-angr + call rotv(eyl,angr,exl,exl) + call rotv(eyl,angr,ezl,ezl) + endif +c +c procedure for an arot + if(icat .eq. 3) then + angr=angd*pi180 +c Note: sign of angr has been adjusted in accord with Figure 6.14c +c of the MaryLie manual. + angr=-angr + call rotv(ezl,angr,exl,exl) + call rotv(ezl,angr,eyl,eyl) + endif +c +c procedure for an arc + if(icat .eq. 4) then + ss = ss + aleng + tt = tt + aleng*vr + x = x + d1*ezl(1) + d2*exl(1) + y = y + d1*ezl(2) + d2*exl(2) + z = z + d1*ezl(3) + d2*exl(3) + angr=angd*pi180 + call rotv(eyl,angr,exl,exl) + call rotv(eyl,angr,ezl,ezl) + endif +c +c +c response to a data point +c + if( iopt .eq. 1 .or. iopt .eq. 3 + & .or. iopt .eq. 11 .or. iopt .eq. 13) then +c + if (nt2(k) .eq. 23) then +c +c write all information to terminal and/or drop file + if (isend .eq. 1 .or. isend .eq. 3) then + write(jof,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + write(jof,*) ' dimensions:' + write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) + write(jof,*) ' s,x,y,z,t;ex,ey,ez:' + write(jof,237) ss,x,y,z,tt + write(jof,*) exl(1), exl(2), exl(3) + write(jof,*) eyl(1), eyl(2), eyl(3) + write(jof,*) ezl(1), ezl(2), ezl(3) + endif + if (isend .eq. 2 .or. isend .eq. 3) then + write(jodf,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + write(jodf,*) ' dimensions:' + write(jodf,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) + write(jodf,*) ' s,x,y,z,t;ex,ey,ez:' + write(jodf,237) ss,x,y,z,tt + write(jodf,*) exl(1), exl(2), exl(3) + write(jodf,*) eyl(1), eyl(2), eyl(3) + write(jodf,*) ezl(1), ezl(2), ezl(3) + endif +c +c write to external files +c write coordinate information to file ifile + if(ifile .gt. 0) then + write(ifile,520) ss,x,y,z,tt,0. + 520 format(6(1x,1pe12.5)) + endif +c write coordinate and orientation information to file jfile + if(jfile .gt. 0) then + write(jfile,520) ss,x,y,z,tt,0. + write(jfile,*) exl(1), exl(2), exl(3) + write(jfile,*) eyl(1), eyl(2), eyl(3) + write(jfile,*) ezl(1), ezl(2), ezl(3) + endif +c +c put result in ucalc + if( iopt .eq. 11 .or. iopt .eq. 13) then + ucalc(1)=ss + ucalc(2)=x + ucalc(3)=y + ucalc(4)=z + ucalc(5)=tt + ucalc(6)= exl(1) + ucalc(7)= exl(2) + ucalc(8)= exl(3) + ucalc(9)= eyl(1) + ucalc(10)=eyl(2) + ucalc(11)=eyl(3) + ucalc(12)=ezl(1) + ucalc(13)=ezl(2) + ucalc(14)=ezl(3) + endif +c + endif +c + endif +c + endif +c + endif +c +c procedure for a lump +c + if(itype .eq. 3) then +c write(ifile,515) string(1),mim(jk1) + 515 format(1x,1x,a8,1x,'lump',9x,'0',4x,'-1',2x,i4) + endif +c + 137 continue +c + return + end +c +************************************************************************ +c + subroutine hmltn1(h) +c this subroutine is used to specify a constant hamiltonian +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' + include 'extalk.inc' + include 'hmflag.inc' + dimension h(monoms) +c +c begin computation + iflag=0 + do 10 i=1,monoms + 10 h(i)=-fa(i) +c + return + end +c +******************************************************************** +c + subroutine lnf(p,fa,fm) +c this is a subroutine that takes the log of a map +c in normal form +c written by Alex Dragt 1/30/99 +c + use lieaparam, only : monoms + include 'impli.inc' +c + include 'files.inc' + include 'buffer.inc' +c +c Calling arrays + dimension p(6),fa(monoms),fm(6,6) +c +c Local arrays +c +c set up parameters +c + job=nint(p(1)) + iopt=nint(p(2)) + mult=nint(p(3)) +c +c compute exponent in the static case +c + if(job .eq. 1) then + call ident(buf1a,buf1m) +c horizontal plane f2 + cos = fm(1,1) + sin = fm(1,2) + ang = datan2(sin,cos) + buf1a(7) = -ang/2.d0 + buf1a(13) = -ang/2.d0 +c vertical plane f2 + cos = fm(3,3) + sin = fm(3,4) + ang = datan2(sin,cos) + buf1a(18) = -ang/2.d0 + buf1a(22) = -ang/2.d0 +c temporal plane f2 + endif +c +c compute exponent in the dynamic case +c + if(job .eq. 2) then + call ident(buf1a,buf1m) +c horizontal plane f2 + cos = fm(1,1) + sin = fm(1,2) + ang = datan2(sin,cos) + buf1a(7) = -ang/2.d0 + buf1a(13) = -ang/2.d0 +c vertical plane f2 + cos = fm(3,3) + sin = fm(3,4) + ang = datan2(sin,cos) + buf1a(18) = -ang/2.d0 + buf1a(22) = -ang/2.d0 +c temporal plane f2 + endif +c +c higher-order f's + if(iopt .eq. 2) then + do i=28,monoms + buf1a(i)=fa(i) + enddo + endif +c +c scale by (-1/pi) + if(mult .eq. 2) then + pi=4.d0*datan(1.d0) + scale=-1.d0/pi + call csmul(scale,buf1a,buf1a) + endif +c + return + end +c +*********************************************************************** +c + subroutine moma(p) +c this subroutine is for moment analysis +c + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'usrdat.inc' + include 'buffer.inc' + include 'fitdat.inc' +c + character*3 kynd +c Calling arrays + dimension p(6),fm(6,6),gm(6,6),hm(6,6) +cryne 8/9/2002 dimension ga(monoms5) +cryne 8/9/2002 dimension ha(monoms5) +cryne 8/9/2002 dimension t1a(monoms5) +cryne 8/9/2002 dimension t2a(monoms5) + dimension ga(monoms) + dimension ha(monoms) + dimension t1a(monoms) + dimension t2a(monoms) +c +c set up control indices + job=nint(p(1)) + isend=nint(p(2)) + ifile=nint(p(3)) + nopt=nint(p(4)) + nskip=nint(p(5)) + nmpo=nint(p(6)) +c +c procedure for reading in function or moments when job = 11,21, or 31: + if(job.eq.11 .or. job.eq.21 .or. job.eq.31) then +c test for file read or internal map fetch + if(ifile.lt.0) then + nmap=-ifile + call ident(ga,gm) + kynd='gtm' + call strget(kynd,nmap,ga,gm) + else + mpit=mpi + mpi=ifile + call mapin(nopt,nskip,ga,gm) + mpi=mpit + endif + endif +c +c procedure for reading in moments when job = 4,5, or 6: +c if (job.eq.4 .or. job.eq.5 .or. job.eq.6) then +c test for file read or internal map fetch +c if(ifile.lt.0) then +c nmap=-ifile +c kynd='gtm' +c call strget5(kynd,nmap,ga,gm) +c else +c mpit=mpi +c mpi=ifile +c call mapin5(nopt,nskip,ga,gm) +c mpi=mpit +c endif +c endif +c continue +c +c compute eigen emittances + if(job .eq. 11) call eigemt(2,ga) + if(job. eq. 21) call eigemt(4,ga) + if(job .eq. 31) call eigemt(6,ga) +c compute mean square eigen-emittances and put results in fitbuf + wex=buf1a(7)**2 + wey=buf1a(18)**2 + wet=buf1a(25)**2 +c +c write out results if desired +c code needs to be modified to write out eigen emittances + if (isend.eq.1.or.isend.eq.3) then + write (jof,*) 'xee2=',wex + write (jof,*) 'yee2=',wey + write (jof,*) 'tee2=',wet + endif + if (isend.eq.2.or.isend.eq.3) then + write (jodf,*) 'xee2=',wex + write (jodf,*) 'yee2=',wey + write (jodf,*) 'tee2=',wet + endif +c + return + end +c +*********************************************************************** +c + subroutine padd(p,ha,hm) +c this subroutine adds two polynomials +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' + include 'buffer.inc' + character*3 kynd +c + dimension p(6),ha(monoms),hm(6,6) +c + dimension fa(monoms),ga(monoms),ta(monoms) + dimension fm(6,6),gm(6,6),tm(6,6) +c +c set up control indices + nmapf=nint(p(1)) + nmapg=nint(p(2)) + nmaph=nint(p(3)) +c +c get maps and clear arrays + kynd='gtm' + if (nmapf.eq.0) call mapmap(ha,hm,fa,fm) + if (nmapf.ge.1 .and. nmapf.le.5) call strget(kynd,nmapf,fa,fm) + if (nmapg.eq.0) call mapmap(ha,hm,ga,gm) + if (nmapg.ge.1 .and. nmapg.le.5) call strget(kynd,nmapg,ga,gm) + call ident(ta,tm) +c +c perform calculation + call cpadd(fa,ga,ta) +c +c decide where to put results +c + if (nmaph.ge.1 .and. nmaph.le.5) then + kynd='stm' + call strget(kynd,nmaph,ta,tm) + endif +c + if (nmaph.eq.0) call mapmap(ta,tm,ha,hm) +c + if (nmaph.eq.-1) call mapmap(ta,tm,buf1a,buf1m) + if (nmaph.eq.-2) call mapmap(ta,tm,buf2a,buf2m) + if (nmaph.eq.-3) call mapmap(ta,tm,buf3a,buf3m) + if (nmaph.eq.-4) call mapmap(ta,tm,buf4a,buf4m) + if (nmaph.eq.-5) call mapmap(ta,tm,buf5a,buf5m) +c + return + end +c +******************************************************************** +c + subroutine pbpol(p,fa,fm) +c this subroutine poisson brackets two polynomials +c written 5/22/02 AJD + use lieaparam, only : monoms + include 'impli.inc' + include 'buffer.inc' + dimension p(6),fa(monoms),fm(6,6) + dimension ta(monoms),tm(6,6) + dimension t1a(monoms) + dimension t2a(monoms) + character*3 kynd +c + write (6,*) 'in subroutine pbpol' +c +c set up and test parameters + map1in=nint(p(1)) + map2in=nint(p(2)) + mapout=nint(p(3)) + if((map1in .lt. 0) .or. (map1in .gt. 9)) go to 100 + if((map2in .lt. 0) .or. (map2in .gt. 9)) go to 100 + if((mapout .lt. -6) .or. (mapout .gt. 9)) go to 100 +c +c get maps + if(map1in .eq. 0) then + call mapmap(fa,fm,t1a,tm) + else + kynd='gtm' + call strget(kynd,map1in,t1a,tm) + endif + if(map2in .eq. 0) then + call mapmap(fa,fm,t2a,tm) + else + kynd='gtm' + call strget(kynd,map2in,t2a,tm) + endif +c +c compute Poisson bracket + call mclear(tm) + call cppb(t1a,t2a,ta) +c +c deposit result and return + if(mapout .lt. 0) then + kbuf=-mapout + if(kbuf .eq. 1) call mapmap(ta,tm,buf1a,buf1m) + if(kbuf .eq. 2) call mapmap(ta,tm,buf2a,buf2m) + if(kbuf .eq. 3) call mapmap(ta,tm,buf3a,buf3m) + if(kbuf .eq. 4) call mapmap(ta,tm,buf4a,buf4m) + if(kbuf .eq. 5) call mapmap(ta,tm,buf5a,buf5m) + if(kbuf .eq. 6) call mapmap(ta,tm,buf6a,buf6m) + endif + if(mapout .eq. 0) call mapmap(ta,tm,fa,fm) + if(mapout .gt. 0) then + kynd='stm' + call strget(kynd,mapout,ta,tm) + endif + return +c + 100 continue +c error return + write(6,*) 'control parameters out of bounds in pbpol' + write(6,*)'map1in=',map1in + write(6,*)'map2in=',map2in + write(6,*)'mapout=',mapout + return + end +c +********************************************************************** +c + subroutine pdnf(p,ha,hm) +c this subroutine computes powers of a dynamic normal form +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + character*3 kynd +c + dimension p(6),ha(monoms),hm(6,6) +c + dimension fa(monoms),ta(monoms) + dimension fm(6,6),tm(6,6) +c +c set up control indices + jinopt=nint(p(1)) + if (jinopt.eq.1) pow=p(2) + if (jinopt.eq.2) npowf=nint(p(2)) + nmapi=nint(p(3)) + joutop=nint(p(4)) + nmapo=nint(p(5)) +c +c get map and clear arrays + kynd='gtm' + if (nmapi.eq.0) call mapmap(ha,hm,fa,fm) + if (nmapi.ge.1 .and. nmapi.le.5) call strget(kynd,nmapi,fa,fm) + call ident(ta,tm) +c +c perform calculation +c +c procedure when jinopt=1 + if (jinopt.eq.1) then + call cpdnf(pow,fa,fm,ta,tm) + call mapsnd(joutop,nmapo,ta,tm,ha,hm) + endif +c +c procedure when jinopt=2 + if (jinopt.eq.2) then +c +c procedure when npowf .lt. 0 + if (npowf.lt.0) then + do 10 k=1,6 + pow=0.d0 +c if (npowf.eq.-1) pow=pst1(k) +c if (npowf.eq.-2) pow=pst2(k) +c if (npowf.eq.-3) pow=pst3(k) +c if (npowf.eq.-4) pow=pst4(k) +c if (npowf.eq.-5) pow=pst5(k) + pow=pst(-npowf,k) + if (pow.ne.0.d0) then + call cpdnf(pow,fa,fm,ta,tm) + call mapsnd(joutop,nmapo,ta,tm,ha,hm) + endif + 10 continue + endif +c procedure when npowf .gt.0 + if (npowf.gt.0) then + 20 continue + read(npowf,*,end=30) pow + call cpdnf(pow,fa,fm,ta,tm) + call mapsnd(joutop,nmapo,ta,tm,ha,hm) + goto 20 + 30 continue + endif +c + endif +c + return + end +c +******************************************************************** +c + subroutine pmul(p,ha,hm) +c this subroutine multiplies two polynomials +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' + include 'buffer.inc' + character*3 kynd +c + dimension p(6),ha(monoms),hm(6,6) +c + dimension fa(monoms),ga(monoms),ta(monoms) + dimension fm(6,6),gm(6,6),tm(6,6) +c +c set up control indices + nmapf=nint(p(1)) + nmapg=nint(p(2)) + nmaph=nint(p(3)) +c +c get maps and clear arrays + kynd='gtm' + if (nmapf.eq.0) call mapmap(ha,hm,fa,fm) + if (nmapf.ge.1 .and. nmapf.le.5) call strget(kynd,nmapf,fa,fm) + if (nmapg.eq.0) call mapmap(ha,hm,ga,gm) + if (nmapg.ge.1 .and. nmapg.le.5) call strget(kynd,nmapg,ga,gm) + call ident(ta,tm) +c +c perform calculation + call cpmul(fa,ga,ta) +c +c decide where to put results +c + if (nmaph.ge.1 .and. nmaph.le.5) then + kynd='stm' + call strget(kynd,nmaph,ta,tm) + endif +c + if (nmaph.eq.0) call mapmap(ta,tm,ha,hm) +c + if (nmaph.eq.-1) call mapmap(ta,tm,buf1a,buf1m) + if (nmaph.eq.-2) call mapmap(ta,tm,buf2a,buf2m) + if (nmaph.eq.-3) call mapmap(ta,tm,buf3a,buf3m) + if (nmaph.eq.-4) call mapmap(ta,tm,buf4a,buf4m) + if (nmaph.eq.-5) call mapmap(ta,tm,buf5a,buf5m) +c + return + end +c +*********************************************************************** +c + subroutine pnlp(p,ga,gm) +c this subroutine raises the nonlinear part of a map to a power +c Written by Alex Dragt, Fall 1988 +c Fifth order by F. Neri (1989). +c + use lieaparam, only : monoms + include 'impli.inc' + include 'buffer.inc' + character*3 kynd +c +c Calling arrays + dimension p(6),ga(monoms),gm(6,6) +c +c Local arrays + dimension fa(monoms) + dimension fm(6,6) + dimension t5(461),t6(923),ff(monoms) +c +c set up scalar and control indices + iopt=nint(p(1)) + power=p(2) + nmapf=nint(p(3)) + nmapg=nint(p(4)) +c +c get map + if (nmapf.eq.0) call mapmap(ga,gm,fa,fm) + if (nmapf.ge.1 .and. nmapf.le.5) then + kynd='gtm' + call strget(kynd,nmapf,fa,fm) + endif +c +c perform calculation + if(iopt.eq.0) then + call mclear(fm) + do 10 i=1,6 + 10 fm(i,i)=1.d0 + endif + call csmul(power,fa,ff) +c +c f5 commutator: + call pbkt1(fa,3,fa,4,t5) + call pmadd(t5,5,(power*(1.d0-power)/2.d0),ff) +c f6 commutators: + call pbkt1(fa,3,t5,5,t6) + call pmadd(t6,6,(power-3.d0*power**2+2.d0*power**3)/12.d0,ff) + call pbkt1(fa,3,fa,5,t6) + call pmadd(t6,6,(power*(1.d0-power)/2.d0),ff) +c +c copy result back to fa: + call mapmap(ff,fm,fa,fm) +c +c decide where to put results +c + if (nmapg.ge.1 .and. nmapg.le.5) then + kynd='stm' + call strget(kynd,nmapg,fa,fm) + endif +c + if (nmapg.eq.0) call mapmap(fa,fm,ga,gm) +c + if (nmapg.eq.-1) call mapmap(fa,fm,buf1a,buf1m) + if (nmapg.eq.-2) call mapmap(fa,fm,buf2a,buf2m) + if (nmapg.eq.-3) call mapmap(fa,fm,buf3a,buf3m) + if (nmapg.eq.-4) call mapmap(fa,fm,buf4a,buf4m) + if (nmapg.eq.-5) call mapmap(fa,fm,buf5a,buf5m) +c + return + end +c +******************************************************************************** +c + subroutine pold(p,fa,fm) +c this is a subroutine for polar decomposition +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' +c + include 'files.inc' + include 'buffer.inc' +c + dimension p(6),fa(monoms),fm(6,6) +c + dimension ta(monoms) + dimension tm(6,6),rm(6,6),pdsm(6,6),revec(6,6) + dimension reval(6) +c +c set up control indices + mapin=nint(p(1)) + isend=nint(p(2)) + idata=nint(p(3)) + ipmaps=nint(p(4)) + iwmaps=nint(p(5)) +c +c write heading(s) +c +c begin calculation + call polr(fa,fm,rm,pdsm,reval,revec) +c put out data + call ident(ta,tm) +c +c put out maps +c +c put maps in buffers + call ident(ta,tm) + call mapmap(ta,pdsm,buf1a,buf1m) + call mapmap(ta,rm,buf2a,buf2m) + call mapmap(fa,tm,buf3a,buf3m) + do 10 i=1,6 + tm(i,i)=reval(i) + 10 continue + call mapmap(ta,tm,buf4a,buf4m) + call mapmap(ta,revec,buf5a,buf5m) +c +c write out maps +c + return + end +c +********************************************************************** +c + subroutine ppa(p,fa,fm) +c +c This routine computes focal lengths and principal planes for the +c current map. +c C. T. Mottershead LANL AT-3 / 2 Oct 89 +c--------------------------------------------------------------------- + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'fitdat.inc' + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c + isend = int(p(1)) + if(iquiet.eq.1) isend = 0 + eps = 1.e-9 +c +c x-plane +c + finv = fm(2,1) + if(abs(finv).lt.eps) finv = eps + f = -1.0/finv + z2 = f*(1.0 - fm(1,1)) + z1 = f*(1.0 - fm(2,2)) + fx = f + xb = z1 + xa = z2 + xu = f - z1 + xd = f - z2 +c +c y-plane +c + finv = fm(4,3) + if(abs(finv).lt.eps) finv = eps + f = -1.0/finv + z2 = f*(1.0 - fm(3,3)) + z1 = f*(1.0 - fm(4,4)) + fy = f + yb = z1 + ya = z2 + yu = f - z1 + yd = f - z2 +c +c print the matrix and focal lengths +c + if(isend.lt.2) go to 400 + lun = jodf + 300 continue + write(lun,17) fx,fy + 17 format(' * PPA Focal lengths : fx =',1pg15.7,' fy =',1pg15.7) + write(lun,33) + 33 format(' * Principal Planes (before and after):') + write(lun,37) xb,xa,yb,ya + 37 format(1x,' xb=',1pg15.7,' xa=',1pg15.7,' yb=',1pg15.7,' ya=', + & 1pg15.7) + write(lun,27) xu,yu + 27 format(' * Focal points (upstream): xu =',1pg15.7, + & ' yu =',1pg15.7) + write(lun,29) xd,yd + 29 format(' (downstream): xd =',1pg15.7, + & ' yd =',1pg15.7) + 400 if((isend.eq.1).or.(isend.eq.3)) then + lun = jof + isend = 0 + go to 300 + endif +c + return + end +c +********************************************************************** +c + subroutine psnf(p,ha,hm) +c this subroutine computes powers of a static normal form +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + character*3 kynd +c + dimension p(6),ha(monoms),hm(6,6) +c + dimension fa(monoms),ta(monoms) + dimension fm(6,6),tm(6,6) +c +c set up control indices + jinopt=nint(p(1)) + if (jinopt.eq.1) pow=p(2) + if (jinopt.eq.2) npowf=nint(p(2)) + nmapi=nint(p(3)) + joutop=nint(p(4)) + nmapo=nint(p(5)) +c +c get map and clear arrays + kynd='gtm' + if (nmapi.eq.0) call mapmap(ha,hm,fa,fm) + if (nmapi.ge.1 .and. nmapi.le.5) call strget(kynd,nmapi,fa,fm) + call ident(ta,tm) +c +c perform calculation +c +c procedure when jinopt=1 + if (jinopt.eq.1) then + call cpsnf(pow,fa,fm,ta,tm) + call mapsnd(joutop,nmapo,ta,tm,ha,hm) + endif +c +c procedure when jinopt=2 + if (jinopt.eq.2) then +c +c procedure when npowf .lt. 0 + if (npowf.lt.0) then + do 10 k=1,6 + pow=0.d0 +c if (npowf.eq.-1) pow=pst1(k) +c if (npowf.eq.-2) pow=pst2(k) +c if (npowf.eq.-3) pow=pst3(k) +c if (npowf.eq.-4) pow=pst4(k) +c if (npowf.eq.-5) pow=pst5(k) + pow = pst(-npowf,k) + if (pow.ne.0.d0) then + call cpsnf(pow,fa,fm,ta,tm) + call mapsnd(joutop,nmapo,ta,tm,ha,hm) + endif + 10 continue + endif +c procedure when npowf .gt.0 + if (npowf.gt.0) then + 20 continue + read(npowf,*,end=30) pow + call cpsnf(pow,fa,fm,ta,tm) + call mapsnd(joutop,nmapo,ta,tm,ha,hm) + goto 20 + 30 continue + endif +c + endif +c + return + end +c +*********************************************************************** +c + subroutine psp(p,ha,hm) +c this subroutine computes the scalar product of two polynomials +c Written by Alex Dragt, 10/23/89 +c + use lieaparam, only : monoms + include 'impli.inc' + include 'buffer.inc' + include 'usrdat.inc' +c + character*3 kynd +c Calling arrays + dimension p(6),ha(monoms),hm(6,6) +c +c Local arrays + dimension fa(monoms),ga(monoms) + dimension tm(6,6) +c +c set up control indices + job=nint(p(1)) + nmapf=nint(p(2)) + nmapg=nint(p(3)) + isend=nint(p(4)) +c +c clear arrays and get maps + if (nmapf.eq.0) call mapmap(ha,hm,fa,tm) + if (nmapf.ge.1 .and. nmapf.le.9) then + kynd='gtm' + call strget(kynd,nmapf,fa,tm) + endif + if (nmapg.eq.0) call mapmap(ha,hm,ga,tm) + if (nmapg.ge.1 .and. nmapg.le.9) then + kynd='gtm' + call strget(kynd,nmapg,ga,tm) + endif +c +c perform calculation + call cpsp(job,fa,ga,ans1,ans2,ans3,ans4) +ccccc call old_cpsp(fa,ga,ans1,ans2,ans3,ans4) +c +c decide where to send and put results +c +c write(6,*) ' ans1=',ans1,' ans2=',ans2 +c write(6,*) ' ans3=',ans3,' ans4=',ans4 + write(6,"('ans1234=',4(1pe15.8,1x))")ans1,ans2,ans3,ans4 + ucalc(141)=ans1 + ucalc(142)=ans2 + ucalc(143)=ans3 + ucalc(144)=ans4 + ucalc(145)=ans1+ans2+ans3+ans4 +c + return + end +c +******************************************************************** +c + subroutine pval(p,ga,gm) +c this is a routine for evaluating a polynomial +c Written by Alex Dragt, Spring 1987 + use rays + use lieaparam, only : monoms + include 'impli.inc' +c + include 'files.inc' + include 'parset.inc' + character*3 kynd +c + dimension p(6),ga(monoms),gm(6,6) +c + dimension fa(monoms),fm(6,6) + dimension zit(6) +c +c set up control indices + mapin=nint(p(1)) + idata=nint(p(2)) + iwnum=nint(p(3)) +c +c get polynomial +c + if (mapin.eq.0) call mapmap(ga,gm,fa,fm) + if (mapin.ge.1 .and. mapin.le.5) then + kynd='gtm' + call strget(kynd,mapin,fa,fm) + endif +c +c compute value(s) of polynomial and write them out +c + if (iwnum.gt.0) then + write(jof,*) + write(jof,*) 'value(s) of polymomial written on file ',iwnum +c +c procedure when idata > 0 + if (idata.gt.0) then + ipset=idata +c get phase space data from the parameter set ipset +c +c do 5 i=1,6 +c 5 zit(i)=0.d0 +c goto (10,20,30,40,50),ipset +c goto 60 +c 10 do 11 i=1,6 +c 11 zit(i)=pst1(i) +c goto 60 +c 20 do 21 i=1,6 +c 21 zit(i)=pst2(i) +c goto 60 +c 30 do 31 i=1,6 +c 31 zit(i)=pst3(i) +c goto 60 +c 40 do 41 i=1,6 +c 41 zit(i)=pst4(i) +c goto 60 +c 50 do 51 i=1,6 +c 51 zit(i)=pst5(i) +c 60 continue + if(ipset.lt.1 .or. ipset.gt.maxpst) then + do 50 i=1,6 + 50 zit(i) = 0.0d0 + else + do 60 i=1,6 + 60 zit(i) = pst(ipset,i) + endif +c carry out computation + call evalf(zit,fa,val2,val3,val4) + k=1 + write(iwnum,100) k,val2,val3,val4,0.,0. + 100 format(1x,i12,5(1x,1pe12.5)) + endif +c +c procedure when idata = 0 + if (idata.eq.0) then + do 70 k=1,nraysp +c check on status of k'th ray; skip this ray if its status is 'lost' + if (istat(k).ne.0) goto 70 + do 80 j=1,6 + 80 zit(j)=zblock(j,k) + call evalf(zit,fa,val2,val3,val4) + write(iwnum,100) k,val2,val3,val4,0.,0. + 70 continue + endif +c + endif +c + return + end +c +********************************************************************** +c + subroutine radm(p,fa,fm) +c this is a subroutine for resonance analysis of dynamic maps +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'buffer.inc' +c + dimension p(6),fa(monoms),fm(6,6) +c + dimension ta(monoms),t1a(monoms),t2a(monoms) + dimension tm(6,6),t1m(6,6),t2m(6,6) + dimension look(3),pmask(6) +c +c set up control indices + iopt=nint(p(1)) + i2=nint(p(2)) + i3=nint(p(3)) + i4=nint(p(4)) + iwmaps=nint(p(5)) +c +c compute isend + do 10 j=1,3 + look(j)=0 + if (i2.eq.j .or. i3.eq.j .or. i4.eq.j) look(j)=1 + 10 continue + isend=0 + if (look(1).eq.1) isend=1 + if (look(2).eq.1) isend=2 + if (look(1).eq.1 .and. look(2).eq.1) isend=3 + if (look(3).eq.1) isend=3 +c +c write headings + if (isend.eq.1 .or. isend.eq.3) then + write(jof,*) + write(jof,*) 'resonance analysis of dynamic map' + endif + if (isend.eq.2 .or. isend.eq.3) then + write(jodf,*) + write(jodf,*) 'resonance analysis of dynamic map' + endif +c +c beginning of calculation +c +c remove offensive terms from matrix part of map: + call dpur2(fa,fm,buf2a,buf2m,ta,tm) +c +c procedure for removing third order terms + if(iopt.eq.1) then + if (isend.eq.1 .or. isend.eq.3) then + write (jof,*) + write (jof,*) 'third order terms removed' + endif + if (isend.eq.2 .or. isend.eq.3) then + write (jodf,*) + write (jodf,*) 'third order terms removed' + endif + call dpur3(buf2a,buf2m,buf3a,buf3m,t1a,t1m) +c accumulate transforming map + call concat(t1a,t1m,ta,tm,t2a,t2m) +c put maps in proper places + call mapmap(buf3a,buf3m,buf2a,buf2m) + call mapmap(t2a,t2m,ta,tm) + endif +c +c resonance decompose purified map: + call matmat(buf2m,buf3m) + call ctodr(buf2a,buf3a) +c +c procedure for writing resonance driving terms at terminal (file jof) + if (isend.eq.1 .or. isend.eq.3) then + call mapmap(buf3a,buf3m,buf4a,buf4m) +c compute masking parameters pmask(j) + pmask(1)=1. + pmask(2)=0. + pmask(3)=0. + pmask(4)=0. + if (i2.eq.1 .or. i2.eq.3) pmask(2)=1. + if (i3.eq.1 .or. i3.eq.3) pmask(3)=1. + if (i4.eq.1 .or. i4.eq.3) pmask(4)=1. +c mask of unwanted portions of buf4a + call mask(pmask,buf4a,buf4m) +c display result in sr basis + write(jof,*) + write(jof,*) 'requested resonance driving terms written as a map' + call pdrmap(0,1,buf4a,buf4m) + endif +c +c procedure for writing resonance driving terms on external file +c (file jodf) + if (isend.eq.2 .or. isend.eq.3) then + call mapmap(buf3a,buf3m,buf4a,buf4m) +c compute masking parameters pmask(j) + pmask(1)=1. + pmask(2)=0. + pmask(3)=0. + pmask(4)=0. + if (i2.eq.2 .or. i2.eq.3) pmask(2)=1. + if (i3.eq.2 .or. i3.eq.3) pmask(3)=1. + if (i4.eq.2 .or. i4.eq.3) pmask(4)=1. +c mask of unwanted portions of buf4a + call mask(pmask,buf4a,buf4m) +c display result in sr basis + write(jodf,*) + write(jodf,*) 'requested resonance driving terms written as a map' + call pdrmap(0,2,buf4a,buf4m) + endif +c +c procedure for writing out maps + if (iwmaps.gt.0) then + mpot=mpo + mpo=iwmaps + call mapout(0,ta,tm) + call mapout(0,buf2a,buf2m) + call mapout(0,buf3a,buf3m) + mpo=mpot + endif +c +c put maps in buffers +c put the transforming map in buffer 1 + call mapmap(ta,tm,buf1a,buf1m) +c buffers 2 and 3 already contain the purified map in the cartesian +c and dynamic resonance bases, respectively +c clear the remaining buffers + call clear(buf4a,buf4m) + call clear(buf5a,buf5m) +c + return + end +c +*********************************************************************** +c + subroutine rasm(p,fa,fm) +c this is a subroutine for resonance analysis of static maps +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' +c + include 'files.inc' + include 'buffer.inc' +c + dimension p(6),fa(monoms),fm(6,6) +c + dimension ta(monoms),t1a(monoms),t2a(monoms) + dimension tm(6,6),t1m(6,6),t2m(6,6) + dimension look(3),pmask(6) + +c +c set up control indices + iopt=nint(p(1)) + i2=nint(p(2)) + i3=nint(p(3)) + i4=nint(p(4)) + iwmaps=nint(p(5)) +c +c compute isend + do 10 j=1,3 + look(j)=0 + if (i2.eq.j .or. i3.eq.j .or. i4.eq.j) look(j)=1 + 10 continue + isend=0 + if (look(1).eq.1) isend=1 + if (look(2).eq.1) isend=2 + if (look(1).eq.1 .and. look(2).eq.1) isend=3 + if (look(3).eq.1) isend=3 +c +c write headings + if (isend.eq.1 .or. isend.eq.3) then + write(jof,*) + write(jof,*) 'resonance analysis of static map' + endif + if (isend.eq.2 .or. isend.eq.3) then + write(jodf,*) + write(jodf,*) 'resonance analysis of static map' + endif +c +c beginning of calculation +c +c remove offensive terms from matrix part of map: + call spur2(fa,fm,buf2a,buf2m,ta,tm,t2m) +c +c procedure for removing third order terms + if(iopt.eq.1) then + if (isend.eq.1 .or. isend.eq.3) then + write (jof,*) + write (jof,*) 'third order terms removed' + endif + if (isend.eq.2 .or. isend.eq.3) then + write (jodf,*) + write (jodf,*) 'third order terms removed' + endif +c remove offensive chromatic terms from f3 part of map: + call scpur3(buf2a,buf2m,buf3a,buf3m,t1a,t1m) +c accumulate transforming map + call concat(t1a,t1m,ta,tm,t2a,t2m) +c remove offensive geometric terms from f3 part of map: + call sgpur3(buf3a,buf3m,buf2a,buf2m,t1a,t1m) +c accumulate transforming map + call concat(t1a,t1m,t2a,t2m,ta,tm) + endif +c +c resonance decompose purified map: + call matmat(buf2m,buf3m) + call ctosr(buf2a,buf3a) +c +c procedure for writing resonance driving terms at terminal (file jof) + if (isend.eq.1 .or. isend.eq.3) then + call mapmap(buf3a,buf3m,buf4a,buf4m) +c compute masking parameters pmask(j) + pmask(1)=1. + pmask(2)=0. + pmask(3)=0. + pmask(4)=0. + if (i2.eq.1 .or. i2.eq.3) pmask(2)=1. + if (i3.eq.1 .or. i3.eq.3) pmask(3)=1. + if (i4.eq.1 .or. i4.eq.3) pmask(4)=1. +c mask of unwanted portions of buf4a + call mask(pmask,buf4a,buf4m) +c display result in sr basis + write(jof,*) + write(jof,*) 'requested resonance driving terms written as a map' + call psrmap(0,1,buf4a,buf4m) + endif +c +c procedure for writing resonance driving terms on external file (file jodf) + if (isend.eq.2 .or. isend.eq.3) then + call mapmap(buf3a,buf3m,buf4a,buf4m) +c compute masking parameters pmask(j) + pmask(1)=1. + pmask(2)=0. + pmask(3)=0. + pmask(4)=0. + if (i2.eq.2 .or. i2.eq.3) pmask(2)=1. + if (i3.eq.2 .or. i3.eq.3) pmask(3)=1. + if (i4.eq.2 .or. i4.eq.3) pmask(4)=1. +c mask of unwanted portions of buf4a + call mask(pmask,buf4a,buf4m) +c display result in sr basis + write(jodf,*) + write(jodf,*) 'requested resonance driving terms written as a map' + call psrmap(0,2,buf4a,buf4m) + endif +c +c procedure for writing out maps + if (iwmaps.gt.0) then + mpot=mpo + mpo=iwmaps + call mapout(0,ta,tm) + call mapout(0,buf2a,buf2m) + call mapout(0,buf3a,buf3m) + mpo=mpot + endif +c +c put maps in buffers +c put the transforming map in buffer 1 + call mapmap(ta,tm,buf1a,buf1m) +c buffers 2 and 3 already contain the purified map in the cartesian +c and static resonance bases, respectively +c clear the remaining buffers + call clear(buf4a,buf4m) + call clear(buf5a,buf5m) +c + return + end +c +*********************************************************************** +c + subroutine sia(p,fa,fm) +c this is a routine for computing invariants in the static case +c Written by Alex Dragt, Spring 1987 + use rays + use lieaparam, only : monoms + include 'impli.inc' +c + include 'files.inc' + include 'buffer.inc' +c + dimension p(6),fa(monoms),fm(6,6) +c + dimension ga(monoms),g1a(monoms) + dimension ta(monoms),t1a(monoms),t2a(monoms) + dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6),t2m(6,6) +c +c set up control indices + iopt=nint(p(1)) + idata=nint(p(2)) + ipmaps=nint(p(3)) + isend=nint(p(4)) + iwmaps=nint(p(5)) + iwnum=nint(p(6)) +c +c write headings + if (isend.eq.1 .or. isend.eq.3) then + write (jof,*) + write (jof,*) 'static invariant analysis' + endif + if (isend.eq.2 .or. isend.eq.3) then + write (jodf,*) + write (jodf,*) 'static invariant analysis' + endif +c +c begin calculation +c +c find the transforming (conjugating) map script A +c remove offensive terms from matrix part of map: + call spur2(fa,fm,ga,gm,t1a,t1m,t2m) +c remove offensive chromatic terms from f3 part of map: + call scpur3(ga,gm,g1a,g1m,t2a,t2m) +c accumulate transforming map: + call concat(t2a,t2m,t1a,t1m,ta,tm) +c remove offensive geometric terms from f3 part of map: + call sgpur3(g1a,g1m,ga,gm,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,ta,tm,t2a,t2m) +c remove offensive terms from f4 part of map: + call spur4(ga,gm,g1a,g1m,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,t2a,t2m,ta,tm) +c put script A in buffer 1 and script N in buffer 2 + call mapmap(ta,tm,buf1a,buf1m) + call mapmap(g1a,g1m,buf2a,buf2m) +c +c procedure for computing invariant +c invert script A + call inv(ta,tm) + call clear(t1a,t1m) +c computation of x invariant + if(iopt.eq.1) then + t1a(7)=1.d0 + t1a(13)=1.d0 + endif +c computation of y invariant + if(iopt.eq.2) then + t1a(18)=1.d0 + t1a(22)=1.d0 + endif +c computation of mixed invariant + if(iopt.ge.3) then + read(iopt,*) anx,any + if (isend.eq.1 .or. isend.eq.3) then + write(jof,*) 'parameters read in from file',iopt + endif + if (isend.eq.2 .or. isend.eq.3) then + write(jof,*) 'parameters read in from file',iopt + endif + t1a(7)=anx + t1a(13)=anx + t1a(18)=any + t1a(22)=any + endif +c put invariant in buffer 3 + call ident(buf3a,buf3m) + call fxform(ta,tm,t1a,buf3a) +c +c procedure for putting out data + if (idata.eq.1 .or. idata.eq.3) then + do 10 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 10 + write(ifile,*) + write(ifile,*) 'invariant polynomial' + call pcmap(0,j,0,0,buf3a,buf3m) + 10 continue + endif + if (idata.eq.2 .or. idata.eq.3) then + mpot=mpo + mpo=18 + call mapout(0,buf3a,buf3m) + mpo=mpot + endif +c +c procedure for printing out maps + do 20 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 20 + if (ipmaps.eq.1 .or. ipmaps.eq.3) then + write(ifile,*) + write(ifile,*) 'normalizing map script A' + call pcmap(j,j,0,0,buf1a,buf1m) + endif + if (ipmaps.eq.2 .or. ipmaps.eq.3) then + write(ifile,*) + write(ifile,*) 'normal form map script N' + call pcmap(j,j,0,0,buf2a,buf2m) + endif + 20 continue +c +c procedure for writing out maps + if (iwmaps.gt.0) then + mpot=mpo + mpo=iwmaps + call mapout(0,buf1a,buf1m) + call mapout(0,buf2a,buf2m) + call mapout(0,buf3a,buf3m) + mpo=mpot + endif +c +c procedure for computing values of invariant and writing them out + if (iwnum.gt.0) then + write(jof,*) + write(jof,*) 'values of invariant written on file ',iwnum + do 30 k=1,nraysp + do 40 j=1,6 + 40 zi(j)=zblock(j,k) + call evalf(zi,buf3a,val2,val3,val4) + write(iwnum,60) k,val2,val3,val4,0.,0. + 60 format(1x,i12,5(1x,1pe12.5)) + 30 continue + endif +c +c put maps in buffers +c buffers 1 and 2 already contain the transforming map script A +c and the normal form map script N, respectively. +c buffer 3 contains the map which has for its matrix the identity +c matrix and for its array the invariant polynomial. +c clear buffers 4 and 5 + call clear(buf4a,buf4m) + call clear(buf5a,buf5m) +c + return + end +c +*********************************************************************** +c + subroutine smul(p,ga,gm) +c this subroutine multiplies a polynomial by a scalar +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' + include 'buffer.inc' + character*3 kynd +c + dimension p(6),ga(monoms),gm(6,6) +c + dimension fa(monoms),ta(monoms) + dimension fm(6,6),tm(6,6) +c +c set up scalar and control indices + scalar=p(1) + nmapf=nint(p(2)) + nmapg=nint(p(3)) +c +c get map and clear arrays + if (nmapf.eq.0) call mapmap(ga,gm,fa,fm) + if (nmapf.ge.1 .and. nmapf.le.5) then + kynd='gtm' + call strget(kynd,nmapf,fa,fm) + endif + call clear(ta,tm) +c +c perform calculation + call csmul(scalar,fa,ta) +c +c decide where to put results +c + if (nmapg.ge.1 .and. nmapg.le.5) then + kynd='stm' + call strget(kynd,nmapg,ta,tm) + endif +c + if (nmapg.eq.0) call mapmap(ta,tm,ga,gm) +c + if (nmapg.eq.-1) call mapmap(ta,tm,buf1a,buf1m) + if (nmapg.eq.-2) call mapmap(ta,tm,buf2a,buf2m) + if (nmapg.eq.-3) call mapmap(ta,tm,buf3a,buf3m) + if (nmapg.eq.-4) call mapmap(ta,tm,buf4a,buf4m) + if (nmapg.eq.-5) call mapmap(ta,tm,buf5a,buf5m) +c + return + end +c +*********************************************************************** +c + subroutine snor_old(p,fa,fm) +c this is a subroutine for normal form analysis of static maps +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' +c + include 'files.inc' + include 'buffer.inc' +c + dimension p(6),fa(monoms),fm(6,6) +c + dimension ga(monoms),g1a(monoms) + dimension ta(monoms),t1a(monoms),t2a(monoms) + dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6),t2m(6,6) +c +c set up control indices + idata=nint(p(1)) + ipmaps=nint(p(2)) + isend=nint(p(3)) + iwmaps=nint(p(4)) +c +c write headings + if (isend.eq.1 .or. isend.eq.3) then + write (jof,*) + write (jof,*) 'static normal form analysis' + endif + if (isend.eq.2 .or. isend.eq.3) then + write (jodf,*) + write (jodf,*) 'static normal form analysis' + endif +c +c begin calculation +c +c remove offensive terms from matrix part of map: + call spur2(fa,fm,ga,gm,t1a,t1m,t2m) +c remove offensive chromatic terms from f3 part of map: + call scpur3(ga,gm,g1a,g1m,t2a,t2m) +c accumulate transforming map: + call concat(t2a,t2m,t1a,t1m,ta,tm) +c remove offensive geometric terms from f3 part of map: + call sgpur3(g1a,g1m,ga,gm,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,ta,tm,t2a,t2m) +c remove offensive terms from f4 part of map: + call spur4(ga,gm,g1a,g1m,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,t2a,t2m,ta,tm) +c put transforming map in buffer 1 + call mapmap(ta,tm,buf1a,buf1m) +c put transformed map in buffer 2 + call mapmap(g1a,g1m,buf2a,buf2m) +c +c procedure for computing normal form exponent and pseudo hamiltonian + call ident(buf3a,buf3m) + if (idata.eq.1 .or. idata.eq.2 .or. idata.eq.3) then +c compute phase advances + cwx=g1m(1,1) + swx=g1m(1,2) + wx=atan2(swx,cwx) + cwy=g1m(3,3) + swy=g1m(3,4) + wy=atan2(swy,cwy) +c compute momentum compaction + wt=g1m(5,6) +c set up normal form for exponent + do 10 i=1,27 + 10 g1a(i)=0. + g1a(7)=-wx/2.d0 + g1a(13)=-wx/2.d0 + g1a(18)=-wy/2.d0 + g1a(22)=-wy/2.d0 + g1a(27)=-wt/2.d0 + endif +c transform exponent to get pseudo hamiltonian + if (idata.eq.2 .or.idata.eq.3) then + call inv(ta,tm) + call fxform(ta,tm,g1a,ga) +c store results in buffer 3 + call mapmap(ga,buf3m,buf3a,buf3m) + endif +c +c procedure for putting out data + do 20 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 20 + if (idata.eq.1 .or. idata.eq.3) then + write(ifile,*) + write(ifile,*) 'exponent for normal form' + call pcmap(0,j,0,0,g1a,g1m) + endif + if (idata.eq.2. .or. idata.eq.3) then + write(ifile,*) + write(ifile,*) 'pseudo hamiltonian' + call pcmap(0,j,0,0,buf3a,buf3m) + endif + 20 continue +c +c procedure for printing out maps + do 30 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 30 + if (ipmaps.eq.1 .or. ipmaps.eq.3) then + write(ifile,*) + write(ifile,*) 'normalizing map script A' + call pcmap(j,j,0,0,buf1a,buf1m) + endif + if (ipmaps.eq.2. .or. ipmaps.eq.3) then + write(ifile,*) + write(ifile,*) 'normal form script N for transfer map' + call pcmap(j,j,0,0,buf2a,buf2m) + endif + 30 continue +c +c procedure for writing out maps + if (iwmaps.gt.0) then + mpot=mpo + mpo=iwmaps + call mapout(0,buf1a,buf1m) + call mapout(0,buf2a,buf2m) + call mapout(0,buf3a,buf3m) + mpo=mpot + endif +c +c put maps in buffers +c buffers 1 and 2 already contain the transforming map script A +c and the normal form map script N, respectively. +c buffer 3 contains the map which has for its matrix the identity +c matrix and for its array the pseudo hamiltonian. +c clear buffers 4 and 5 + call clear(buf4a,buf4m) + call clear(buf5a,buf5m) +c + return + end +c +*********************************************************************** +c + subroutine snor(p,fa,fm) +c this is a subroutine for normal form analysis of static maps +c Written by Alex Dragt, Spring 1987 +c Modified 20 June 1988 +c + use parallel, only : idproc + use lieaparam, only : monoms + include 'impli.inc' +c + include 'files.inc' + include 'buffer.inc' +c +c Calling arrays + dimension p(6),fa(monoms),fm(6,6) +c +c Local arrays + dimension ga(monoms),g1a(monoms) + dimension ta(monoms),t1a(monoms) + dimension gm(6,6),g1m(6,6) + dimension tm(6,6),t1m(6,6) +c +c set up control indices + keep= nint(p(1)) + idata= nint(p(2)) + ipmaps=nint(p(3)) + isend= nint(p(4)) + iwmaps=nint(p(5)) +c +c write headings + if ((isend.eq.1 .or. isend.eq.3) .and. idproc.eq.0) then + write (jof,*) + write (jof,*) 'static normal form analysis' + endif + if ((isend.eq.2 .or. isend.eq.3) .and. idproc.eq.0) then + write (jodf,*) + write (jodf,*) 'static normal form analysis' + endif +c +c begin calculation +c +c remove offensive terms from matrix part of map: + call spur2(fa,fm,ga,gm,ta,tm,t1m) +c remove offensive chromatic terms from f3 part of map: + call scpur3(ga,gm,g1a,g1m,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,ta,tm,ta,tm) +c remove offensive geometric terms from f3 part of map: + call sgpur3(g1a,g1m,ga,gm,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,ta,tm,ta,tm) +c remove offensive terms from f4 part of map: + call spur4(ga,gm,g1a,g1m,t1a,t1m) +c accumulate transforming map: + call concat(t1a,t1m,ta,tm,ta,tm) +c put transforming map in buffer 1 + call mapmap(ta,tm,buf1a,buf1m) +c put transformed map in buffer 2 + call mapmap(g1a,g1m,buf2a,buf2m) +c +c procedure for computing normal form exponent and pseudo hamiltonian + call ident(buf3a,buf3m) + if (idata.eq.1 .or. idata.eq.2 .or. idata.eq.3) then +c compute phase advances + cwx=g1m(1,1) + swx=g1m(1,2) + wx=atan2(swx,cwx) + cwy=g1m(3,3) + swy=g1m(3,4) + wy=atan2(swy,cwy) +c compute momentum compaction + wt=g1m(5,6) +c set up normal form for exponent + do 10 i=1,27 + 10 g1a(i)=0. + g1a(7)=-wx/2.d0 + g1a(13)=-wx/2.d0 + g1a(18)=-wy/2.d0 + g1a(22)=-wy/2.d0 + g1a(27)=-wt/2.d0 + endif +c transform exponent to get pseudo hamiltonian + if (idata.eq.2 .or.idata.eq.3) then + call inv(ta,tm) + call fxform(ta,tm,g1a,ga) +c store results in buffer 3 + call mapmap(ga,buf3m,buf3a,buf3m) + endif +c +c procedure for putting out data + do 20 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 20 + if (idata.eq.1 .or. idata.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'exponent for normal form' + call pcmap(0,j,0,0,g1a,g1m) + endif + if (idata.eq.2. .or. idata.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'pseudo hamiltonian' + call pcmap(0,j,0,0,buf3a,buf3m) + endif + 20 continue +c +c procedure for printing out maps + do 30 j=1,2 + ifile=0 + if (j.eq.1) then + if (isend.eq.1 .or. isend.eq.3) ifile=jof + endif + if (j.eq.2) then + if (isend.eq.2 .or. isend.eq.3) ifile=jodf + endif + if (ifile.eq.0) goto 30 + if (ipmaps.eq.1 .or. ipmaps.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'normalizing map script A' + call pcmap(j,j,0,0,buf1a,buf1m) + endif + if (ipmaps.eq.2. .or. ipmaps.eq.3) then + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0) + &write(ifile,*) 'normal form script N for transfer map' + call pcmap(j,j,0,0,buf2a,buf2m) + endif + 30 continue +c +c procedure for writing out maps + if (iwmaps.gt.0) then + mpot=mpo + mpo=iwmaps + call mapout(0,buf1a,buf1m) + call mapout(0,buf2a,buf2m) + call mapout(0,buf3a,buf3m) + mpo=mpot + endif +c +c put maps in buffers +c buffers 1 and 2 already contain the transforming map script A +c and the normal form map script N, respectively. +c buffer 3 contains the map which has for its matrix the identity +c matrix and for its array the pseudo hamiltonian. +c clear buffers 4 and 5 + call clear(buf4a,buf4m) + call clear(buf5a,buf5m) +c + return + end +c +c +*********************************************************************** +c + subroutine submn(p,ha,hm) +c This subroutine computes the norm of a matrix +c Written by Alex Dragt, 10/20/90 +c + use parallel, only : idproc + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' +c +c Calling arrays + dimension p(6),ha(monoms),hm(6,6) +c +c Local arrays + dimension tm(6,6) +c +c set up control indices + iopt=nint(p(1)) + isend=nint(p(2)) +c +c copy matrix + call matmat(hm,tm) +c +c perform calculation +c +c modify matrix if required + if (iopt .eq. 1) then + do 10 i=1,6 + 10 tm(i,i) = tm(i,i) -1.d0 + endif +c +c compute norm + call mnorm(tm,ans) +c +c decide where to send and put results +c + if(idproc.eq.0)write(6,*) ' matrix norm = ',ans +c + return + end +c +*********************************************************************** +c + subroutine tadm(p,fa,fm) +c this is a subroutine for twiss analysis of dynamic maps +c Written by Alex Dragt, Spring 1987 +c this program will eventually have to be rewritten to improve the +c output data and its format + use parallel, only : idproc + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'buffer.inc' +c + dimension p(6),fa(monoms),fm(6,6) +c + dimension ga(monoms),g1a(monoms) + dimension ta(monoms),t1a(monoms),t2a(monoms) + dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6),t2m(6,6) +c +c set up control indices + idata=nint(p(1)) + ipmaps=nint(p(2)) + isend=nint(p(3)) + iwmaps=nint(p(4)) +c +c write headings + if ((isend.eq.1 .or. isend.eq.3) .and. idproc.eq.0) then + write(jof,*) + write(jof,*) 'twiss analysis of dynamic map' + endif + if ((isend.eq.2 .or. isend.eq.3) .and. idproc.eq.0) then + write(jodf,*) + write(jodf,*) 'twiss analysis of dynamic map' + endif +c +c beginning of calculation +c remove offensive terms from matrix part of map: + call dpur2(fa,fm,ga,gm,ta,tm) +c store purifying map script A2 in buffer 1 + call mapmap(ta,tm,buf1a,buf1m) +c +c compute tunes: + cwx=gm(1,1) + swx=gm(1,2) + cwy=gm(3,3) + swy=gm(3,4) + cwt=gm(5,5) + swt=gm(5,6) + pi=4.*atan(1.d0) + wx=atan2(swx,cwx) + if (wx.lt.0.) wx=wx+2.*pi + wy=atan2(swy,cwy) + if (wy.lt.0.) wy=wy+2.*pi + wt=atan2(swt,cwt) +c if (wt.lt.0.) wt=wt+2.*pi + tnx=wx/(2.*pi) + tny=wy/(2.*pi) + tnt=wt/(2.*pi) +c +c remove f3 part of map: + call dpur3(ga,gm,g1a,g1m,t1a,t1m) +c accumulate transforming map + call concat(t1a,t1m,ta,tm,t2a,t2m) +c resonance decompose purified map: + call ctodr(g1a,ga) +c +c compute dependence of tune on betatron amplitude: + hh=ga(84) + vv=ga(85) + tt=ga(86) + hv=ga(87) + ht=ga(88) + vt=ga(89) + hhn=-2.d0*hh/pi + vvn=-2.d0*vv/pi + ttn=-2.d0*tt/pi + hvn=-hv/pi + htn=-ht/pi + vtn=-vt/pi +c +c remove f4 part of map + call dpur4(g1a,g1m,ga,gm,t1a,t1m) +c accumulate transforming map + call concat(t1a,t1m,t2a,t2m,ta,tm) +c +c compute envelopes and twiss parameters +c use the map in buffer 1 + call mapmap(buf1a,buf1m,t1a,t1m) +c compute envelopes + exh2=t1m(1,1)**2+t1m(1,2)**2 + exv2=t1m(1,3)**2+t1m(1,4)**2 + ext2=t1m(1,5)**2+t1m(1,6)**2 + epxh2=t1m(2,1)**2+t1m(2,2)**2 + epxv2=t1m(2,3)**2+t1m(2,4)**2 + epxt2=t1m(2,5)**2+t1m(2,6)**2 + eyh2=t1m(3,1)**2+t1m(3,2)**2 + eyv2=t1m(3,3)**2+t1m(3,4)**2 + eyt2=t1m(3,5)**2+t1m(3,6)**2 + epyh2=t1m(4,1)**2+t1m(4,2)**2 + epyv2=t1m(4,3)**2+t1m(4,4)**2 + epyt2=t1m(4,5)**2+t1m(4,6)**2 + eth2=t1m(5,1)**2+t1m(5,2)**2 + etv2=t1m(5,3)**2+t1m(5,4)**2 + ett2=t1m(5,5)**2+t1m(5,6)**2 + epth2=t1m(6,1)**2+t1m(6,2)**2 + eptv2=t1m(6,3)**2+t1m(6,4)**2 + eptt2=t1m(6,5)**2+t1m(6,6)**2 + exh=sqrt(exh2) + exv=sqrt(exv2) + ext=sqrt(ext2) + epxh=sqrt(epxh2) + epxv=sqrt(epxv2) + epxt=sqrt(epxt2) + eyh=sqrt(eyh2) + eyv=sqrt(eyv2) + eyt=sqrt(eyt2) + epyh=sqrt(epyh2) + epyv=sqrt(epyv2) + epyt=sqrt(epyt2) + eth=sqrt(eth2) + etv=sqrt(etv2) + ett=sqrt(ett2) + epth=sqrt(epth2) + eptv=sqrt(eptv2) + eptt=sqrt(eptt2) +c compute twiss parameters + call inv(t1a,t1m) +c compute invariants using buffers 2 thru 5 +c computation of x invariant + call clear(buf2a,buf2m) + buf2a(7)=1.d0 + buf2a(13)=1.d0 + call fxform(t1a,t1m,buf2a,buf3a) +c computation of y invariant + call clear(buf2a,buf2m) + buf2a(18)=1.d0 + buf2a(22)=1.d0 + call fxform(t1a,t1m,buf2a,buf4a) +c computation of t invariant + call clear(buf2a,buf2m) + buf2a(25)=1.d0 + buf2a(27)=1.d0 + call fxform(t1a,t1m,buf2a,buf5a) +c get twiss parameters from the invariants +c terms for horizontal (x) plane +c 'diagonal' terms + ax=buf3a(8)/2.d0 + bx=buf3a(13) + gx=buf3a(7) +c skew terms +c remove diagonal terms, and later print buf3a as a map + buf3a(8)=0. + buf3a(13)=0. + buf3a(7)=0. +c terms for vertical (y) plane +c 'diagonal' terms + ay=buf4a(19)/2.d0 + by=buf4a(22) + gy=buf4a(18) +c skew terms +c remove diagonal terms, and later print buf4a as a map + buf4a(19)=0. + buf4a(22)=0. + buf4a(18)=0. +c terms for temporal (t) plane +c 'diagonal' terms + at=buf5a(26)/2.d0 + bt=buf5a(27) + gt=buf5a(25) +c skew terms +c remove diagonal terms, and later print buf5a as a map + buf5a(26)=0. + buf5a(27)=0. + buf5a(25)=0. +c +c procedure for writing out tunes and anharmonicities + if (idata.eq.1 .or. idata.eq.12 .or. + & idata.eq.13 .or. idata.eq.123) then + do 10 i=1,2 + if (i.eq.1) then + ifile=jof + iflag=1 + if (isend.eq.2) iflag=0 + endif + if (i.eq.2) then + ifile=jodf + iflag=1 + if (isend.eq.1) iflag=0 + endif + if (isend.eq.0) goto 10 + if (iflag.eq.0) goto 10 +c write out tunes: + if(idproc.eq.0)then + write (ifile,*) + write (ifile,*) 'horizontal tune =',tnx + write (ifile,*) 'vertical tune =',tny + write (ifile,*) 'temporal tune =',tnt +c write out normalized anharmonicities + write(ifile,*) + write(ifile,*) 'normalized anharmonicities' + write(ifile,*) ' hhn=',hhn + write(ifile,*) ' vvn=',vvn + write(ifile,*) ' ttn=',ttn + write(ifile,*) ' hvn=',hvn + write(ifile,*) ' htn=',htn + write(ifile,*) ' vtn=',vtn + endif + 10 continue + endif +c +c procedure for printing out twiss parameters and envelopes + if (idata.eq.2 .or. idata.eq.12 .or. + & idata.eq.23 .or. idata.eq.123) then + do 20 i=1,2 + if (i.eq.1) then + ifile=jof + iflag=1 + if (isend.eq.2) iflag=0 + endif + if (i.eq.2) then + ifile=jodf + iflag=1 + if (isend.eq.1) iflag=0 + endif + if (isend.eq.0) goto 20 + if (iflag.eq.0) goto 20 + if(idproc.eq.0)then + write(ifile,*) + write(ifile,*) 'horizontal twiss parameters' + write(ifile,*) 'diagonal terms (alpha,beta,gamma)' + write(ifile,*) ax,bx,gx + write(ifile,*) 'skew terms written as a map' + endif + call pcmap(0,i,0,0,buf3a,buf3m) + if(idproc.eq.0)then + write(ifile,*) + write(ifile,*) 'vertical twiss parameters' + write(ifile,*) 'diagonal terms (alpha,beta,gamma)' + write(ifile,*) ay,by,gy + write(ifile,*) 'skew terms written as a map' + endif + call pcmap(0,i,0,0,buf4a,buf4m) + if(idproc.eq.0)then + write(ifile,*) + write(ifile,*) 'temporal twiss parameters' + write(ifile,*) 'diagonal terms (alpha,beta,gamma)' + write(ifile,*) at,bt,gt + write(ifile,*) 'skew terms written as a map' + endif + call pcmap(0,i,0,0,buf5a,buf5m) + if(idproc.eq.0)then + write(ifile,*) + write(ifile,*) 'horizontal envelopes (exh,exv,ext;epxh,epxv,epxt)' + write(ifile,*) exh,exv,ext + write(ifile,*) epxh,epxv,epxt + write(ifile,*) + write(ifile,*) 'vertical envelopes (eyh,eyv,eyt;epyh,epyv,epyt)' + write(ifile,*) eyh,eyv,eyt + write(ifile,*) epyh,epyv,epyt + write(ifile,*) + write(ifile,*) 'temporal envelopes (eth,etv,ett;epth,eptv,eptt)' + write(ifile,*) eth,etv,ett + write(ifile,*) epth,eptv,eptt + endif + 20 continue + endif +c +c procedure for printing out eigenvectors + if (idata.eq.3 .or. idata.eq.13 .or. + & idata.eq.23 .or. idata.eq.123) then + do 30 i=1,2 + if (i.eq.1) then + ifile=jof + iflag=1 + if (isend.eq.2) iflag=0 + endif + if (i.eq.2) then + ifile=jodf + iflag=1 + if (isend.eq.1) iflag=0 + endif + if (isend.eq.0) goto 30 + if (iflag.eq.0) goto 30 +c write out the matrix buf1m + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'matrix of eigenvectors' + call pcmap (i,0,0,0,buf1a,buf1m) + 30 continue + endif +c +c procedure for printing of maps +c +c put out script A + if (ipmaps.eq.1 .or. ipmaps.eq.3) then + do 40 i=1,2 + if (i.eq.1) then + ifile=jof + iflag=1 + if (isend.eq.2) iflag=0 + endif + if (i.eq.2) then + ifile=jodf + iflag=1 + if (isend.eq.1) iflag=0 + endif + if (isend.eq.0) goto 40 + if (iflag.eq.0) goto 40 + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'transforming map script A' + call pcmap(i,i,0,0,ta,tm) + 40 continue + endif +c +c put out script N + if (ipmaps.eq.2 .or. ipmaps.eq.3) then + do 50 i=1,2 + if (i.eq.1) then + ifile=jof + iflag=1 + if (isend.eq.2) iflag=0 + endif + if (i.eq.2) then + ifile=jodf + iflag=1 + if (isend.eq.1) iflag=0 + endif + if (isend.eq.0) goto 50 + if (iflag.eq.0) goto 50 + if(idproc.eq.0)write(ifile,*) + if(idproc.eq.0)write(ifile,*) 'normal form map script N' + call pcmap(i,i,0,0,ga,gm) + 50 continue + endif +c +c procedure for writing of maps + if (iwmaps.gt.0) then + mpot=mpo + mpo=iwmaps + call mapout(0,buf1a,buf1m) + call mapout(0,ta,tm) + call mapout(0,ga,gm) + mpo=mpot + endif +c +c put maps in buffers +c buffer 1 already contains script A2 + call mapmap(ta,tm,buf2a,buf2m) + call mapmap(ga,gm,buf3a,buf3m) + call clear(buf4a,buf4m) + call clear(buf5a,buf5m) +c + return + end +c +*********************************************************************** + subroutine tasm(p,fa,fm) +c this is a subroutine for twiss analysis of static maps +c Written by Alex Dragt, Spring 1987 +c Modified by Alex Dragt, 20 June 1988 +c Again modified by Alex Dragt, 19 August 1988 +c + use parallel, only : idproc + use beamdata + use lieaparam, only : monoms + include 'impli.inc' +c + include 'files.inc' + include 'buffer.inc' + include 'fitdat.inc' +c +c Calling arrays + dimension p(6),fa(monoms),fm(6,6) +c +c Local arrays + dimension ga(monoms),g1a(monoms) + dimension ta(monoms),t1a(monoms),t2a(monoms) + dimension gm(6,6),g1m(6,6) + dimension tm(6,6),t1m(6,6),t2m(6,6) + dimension am1(6,6),am2(6,6),am3(6,6) +c +c temporary local arrays + dimension temp1a(monoms),temp2a(monoms),temp3a(monoms) + dimension temp1m(6,6),temp2m(6,6),temp3m(6,6) + dimension bm1(6,6),bm2(6,6),bm3(6,6) + dimension rm1(6,6),rm2(6,6),rm3(6,6) + dimension em3(6,6) + dimension pm1(6,6),pm2(6,6),pm3(6,6) + dimension um1(6,6) + dimension dm1(6,6) +c +c set up control indices + iopt=nint(p(1)) + delta=p(2) + idata=nint(p(3)) + ipmaps=nint(p(4)) + isend=nint(p(5)) + iwmaps=nint(p(6)) +c +c write headings + if (isend.eq.1.or.isend.eq.3) then + write(jof,*) + write(jof,*) 'twiss analysis of static map' + endif + if (isend.eq.2.or.isend.eq.3) then + write(jodf,*) + write(jodf,*) 'twiss analysis of static map' + endif +c +c first compute closed orbit to get dispersion functions +c this routine does not put out dispersions (subroutine cod does) +c but does put them in common /fitdat/ array for possible fitting +c or plotting + call fxpt(fa,fm,temp1a,temp1m,temp3a,temp3m) + dz(1)=temp3m(1,6) + dz(2)=temp3m(2,6) + dz(3)=temp3m(3,6) + dz(4)=temp3m(4,6) +c +c preparatory steps for starting main calculation +c one objective of this calculation is to find script Ac, +c the transforming map with respect to the closed orbit +c remove offensive terms from matrix part of map: + call clear(buf5a,buf5m) + call spur2(fa,fm,ga,gm,t1a,t1m,buf5m) +c temporarily save the transforming map associated with sa2 in +c buffer 5 for later use +c +c compute tunes: + cwx=gm(1,1) + swx=gm(1,2) + cwy=gm(3,3) + swy=gm(3,4) + pi=4.*atan(1.d0) + wx=atan2(swx,cwx) + if (wx.lt.0.) wx=wx+2.*pi + wy=atan2(swy,cwy) + if (wy.lt.0.) wy=wy+2.*pi + tx=wx/(2.*pi) + ty=wy/(2.*pi) +c put results in commom/fitdat/ array + tux=tx + tuy=ty +c +c preparatory steps for continuing calculation +c remove offensive chromatic terms from f3 part of map: + call scpur3(ga,gm,g1a,g1m,t1a,t1m) +c accumulate transforming map + call concat(t1a,t1m,buf5a,buf5m,ta,tm) +c resonance decompose purified map: + call ctosr(g1a,t2a) +c +c compute chromaticities +c +c procedure when IOPT = 1 + if (iopt.eq.1) then +c compute first order chromaticities: + chrox1=-(1.d0/pi)*t2a(28) + chroy1=-(1.d0/pi)*t2a(29) +c compute second order chromaticities: + chrox2=-(2.d0/pi)*t2a(84) + chroy2=-(2.d0/pi)*t2a(85) +c put results in commom/fitdat/ array + cx=chrox1 + cy=chroy1 + qx=chrox2 + qy=chroy2 +c +c compute tunes about closed orbit + delta2=delta*delta + txc=tx+delta*chrox1+delta2*chrox2 + tyc=ty+delta*chroy1+delta2*chroy2 + tsc=txc-tyc +c + endif +c +c procedure when IOPT = 2 + if (iopt.eq.2) then +c compute first order chromaticities: + chrox1=(beta/pi)*t2a(28) + chroy1=(beta/pi)*t2a(29) +c compute second order chromaticities: + beta2=beta*beta + beta3=beta*beta2 + chrox2=(t2a(28)*(beta-beta3)-2.d0*t2a(84)*beta2)/pi + chroy2=(t2a(29)*(beta-beta3)-2.d0*t2a(85)*beta2)/pi +c put results in commom/fitdat/ array + cx=chrox1 + cy=chroy1 + qx=chrox2 + qy=chroy2 +c +c compute tune about closed orbit + delta2=delta*delta + txc=tx+delta*chrox1+delta2*chrox2 + tyc=ty+delta*chroy1+delta2*chroy2 + tsc=txc-tyc +c + endif +c +c write out tunes and chromaticities + if (idata.eq.1 .or. idata.eq.12 .or. + # idata.eq.13 .or. idata.eq.123) then + if(isend.eq.0) goto 11 + do 10 i=1,2 + if (i.eq.1) then + ifile=jof + iflag=1 + if (isend.eq.2) iflag=0 + endif + if (i.eq.2) then + ifile=jodf + iflag=1 + if (isend.eq.1) iflag=0 + endif + if (iflag.eq.0) goto 10 + write (ifile,*) + if(iopt.eq.1) then + write (ifile,*) 'tunes and chromaticities for delta defined in', + #' terms of P sub tau:' + endif + if(iopt.eq.2) then + write (ifile,*) 'tunes and chromaticities for delta defined in', + #' terms of momentum deviation:' + endif + write (ifile,*) + write (ifile,*) 'horizontal tune =',tx + write (ifile,*) 'first order horizontal chromaticity =',chrox1 + write (ifile,*) 'second order horizontal chromaticity =',chrox2 + write (ifile,*) 'horizontal tune when delta =',delta + write (ifile,*) txc + write (ifile,*) + write (ifile,*) 'vertical tune =',ty + write (ifile,*) 'first order vertical chromaticity =',chroy1 + write (ifile,*) 'second order vertical chromaticity =',chroy2 + write (ifile,*) 'vertical tune when delta =',delta + write (ifile,*) tyc + write (ifile,*) + write (ifile,*) 'tune separation when delta=',delta + write (ifile,*) tsc + 10 continue + 11 continue + endif +c +c preparatory steps for continuing calculation +c remove offensive geometric terms from f3 part of map: + call sgpur3(g1a,g1m,ga,gm,t2a,t2m) +c accumulate transforming map + call concat(t2a,t2m,ta,tm,t1a,t1m) +c resonance decompose purified map: + call ctosr(ga,t2a) +c +c compute dependence of tune on betatron amplitude: + hhi=t2a(87) + vvi=t2a(88) + hvi=t2a(89) + hhn=-2.d0*hhi/pi + vvn=-2.d0*vvi/pi + hvn=-hvi/pi +c put results in commom/fitdat/ array + hh=hhn + vv=vvn + hv=hvn +c +c write out normalized anharmonicities + if (idata.eq.1 .or. idata.eq.12 .or. + # idata.eq.13 .or. idata.eq.123) then + if(isend.eq.0) goto 21 + do 20 i=1,2 + if (i.eq.1) then + ifile=jof + iflag=1 + if (isend.eq.2) iflag=0 + endif + if (i.eq.2) then + ifile=jodf + iflag=1 + if (isend.eq.1) iflag=0 + endif + if (iflag.eq.0) goto 20 + write(ifile,*) + write(ifile,*) 'normalized anharmonicities' + write(ifile,*) ' hhn=',hhn + write(ifile,*) ' vvn=',vvn + write(ifile,*) ' hvn=',hvn + 20 continue + 21 continue + endif +c +c complete computation of script Ac and script N +c store script Ac in buffer 1 and script N in buffer 2 + call spur4(ga,gm,buf2a,buf2m,t2a,t2m) +c accumulate transforming map to get script Ac + call concat(t2a,t2m,t1a,t1m,buf1a,buf1m) +c +c compute twiss parameter expansions (invariants) and envelopes +c +c preparatory steps for continuing calculation +c compute fixed point and map around it, and put the transforming +c map to the closed orbit in buffer 3 + call fxpt(fa,fm,g1a,g1m,buf3a,buf3m) +c extract the betatron factor of the map and store it in buffer 4 + call betmap(g1a,g1m,buf4a,buf4m) +c find the transforming (conjugating) map script Ab for the betatron factor +c use the map in buffer 5 to purify the f2 part of the betatron factor + call sndwch(buf5a,buf5m,buf4a,buf4m,g1a,g1m) +c remove offensive chromatic terms from f3 part of betatron factor + call scpur3(g1a,g1m,ga,gm,ta,tm) +c accumulate transforming map: + call concat(ta,tm,buf5a,buf5m,t2a,t2m) +c remove offensive terms from f4 part of betatron factor + call spur4(ga,gm,g1a,g1m,t1a,t1m) +c accumulate transforming map to get script Ab: + call concat(t1a,t1m,t2a,t2m,ta,tm) +c store script Ab in buffer 5 + call mapmap(ta,tm,buf5a,buf5m) +c invert script Ab + call inv(ta,tm) +c +c compute invariants +c computation of x invariant + call clear(ga,gm) + ga(7)=1.d0 + ga(13)=1.d0 + call fxform(ta,tm,ga,t1a) +c computation of y invariant + call clear(ga,gm) + ga(18)=1.d0 + ga(22)=1.d0 + call fxform(ta,tm,ga,t2a) +c +c preliminary calculations required for envelopes and eigenvalues + if (idata.eq.2 .or. idata.eq.3 .or. + # idata.eq.12 .or. idata.eq.13 .or. + # idata.eq.23 .or. idata.eq.123) then +c put script Ab in ta,tm + call mapmap(buf5a,buf5m,ta,tm) +c make chromatic expansion of ta,tm +c the result will be used to compute both envelopes and eigenvectors + call chrexp(iopt,delta,ta,tm,am1,am2,am3) + endif +c +c see if output of twiss parameters and envelopes is desired + if (idata.eq.2 .or. idata.eq.12 .or. + # idata.eq.23 .or. idata.eq.123) then +c +c continue with calculation +c +c terms for horizontal (x) plane +c 'diagonal terms' + ax0=t1a(8)/2.d0 + bx0=t1a(13) + gx0=t1a(7) +c all terms: later print t1a as a map +c terms for vertical (y) plane +c 'diagonal'terms + ay0=t2a(19)/2.d0 + by0=t2a(22) + gy0=t2a(18) +c all terms: later print t2a as a map +c +c put horizontal and vertical results in commom/fitdat/ array + ax=ax0 + bx=bx0 + gx=gx0 + ay=ay0 + by=by0 + gy=gy0 +c +c compute envelopes + exhc2=am3(1,1)**2+am3(1,2)**2 + exvc2=am3(1,3)**2+am3(1,4)**2 + epxhc2=am3(2,1)**2+am3(2,2)**2 + epxvc2=am3(2,3)**2+am3(2,4)**2 + eyhc2=am3(3,1)**2+am3(3,2)**2 + eyvc2=am3(3,3)**2+am3(3,4)**2 + epyhc2=am3(4,1)**2+am3(4,2)**2 + epyvc2=am3(4,3)**2+am3(4,4)**2 + exhc=sqrt(exhc2) + exvc=sqrt(exvc2) + epxhc=sqrt(epxhc2) + epxvc=sqrt(epxvc2) + eyhc=sqrt(eyhc2) + eyvc=sqrt(eyvc2) + epyhc=sqrt(epyhc2) + epyvc=sqrt(epyvc2) +c +c write out twiss functions invariants, and envelopes + if(isend.eq.0) goto 31 + do 30 i=1,2 + if (i.eq.1) then + ifile=jof + iflag=1 + if (isend.eq.2) iflag=0 + endif + if (i.eq.2) then + ifile=jodf + iflag=1 + if (isend.eq.1) iflag=0 + endif + if (iflag.eq.0) goto 30 + write (ifile,*) + write (ifile,*) 'twiss parameters, invariants, and envelopes' +c +c write twiss functions and invariants + write (ifile,*) + write (ifile,*) 'horizontal parameters' + write (ifile,*) 'on energy diagonal terms (alpha,beta,gamma)' + write (ifile,*) ax0,bx0,gx0 + write (ifile,*) 'full twiss invariant written as a map' + call pcmap(0,i,0,0,t1a,t1m) + write (ifile,*) + write (ifile,*) 'vertical parameters' + write (ifile,*) 'on energy diagonal terms (alpha,beta,gamma)' + write (ifile,*) ay0,by0,gy0 + write (ifile,*) 'full twiss invariant written as a map' + call pcmap(0,i,0,0,t2a,t2m) +c +c write out envelopes + if(iopt.eq.1) then + write (ifile,*) + write (ifile,*) 'envelopes for delta defined in terms of', + #' P sub tau with delta =',delta + endif + if(iopt.eq.2) then + write (ifile,*) 'envelopes for delta defined in terms of', + #' momentum deviation with delta =',delta + endif + write (ifile,*) + write (ifile,*) 'normalized horizontal envelope coefficients' + #,' (exhc,exvc;epxhc,epxvc)' + write (ifile,*) exhc,exvc + write (ifile,*) epxhc,epxvc + write (ifile,*) + write (ifile,*) 'normalized vertical envelope coefficients' + #,' (eyhc,eyvc;epyhc,epyvc)' + write (ifile,*) eyhc,eyvc + write (ifile,*) epyhc,epyvc +c + 30 continue + 31 continue + endif +c +c Procedure for output of eigenvectors. + if (idata.eq.3 .or. idata.eq.13 .or. + # idata.eq.23 .or. idata.eq.123) then +c Print out matrices tm, am1, and am2. + if(isend.eq.0) goto 41 + do 40 i=1,2 + if (i.eq.1) then + iflag=1 + if (isend.eq.2) iflag=0 + ifile=jof + endif + if (i.eq.2) then + iflag=1 + if (isend.eq.1) iflag=0 + ifile=jodf + endif + if (iflag.eq.0) goto 40 +c +c procedure when IOPT = 1 + if (iopt.eq.1) then + write(ifile,198) + 198 format(//,1x,'eigenvector expansion for delta defined', + #1x,'in terms of P sub tau:') + write(ifile,200) + 200 format(/,1x,'on energy matrix of eigenvectors') + endif +c +c procedure when IOPT = 2 + if (iopt.eq.2) then + write(ifile,199) + 199 format(//,1x,'eigenvector expansion for delta defined', + #1x,'in terms of momentum deviation:') + write(ifile,201) + 201 format(/,1x,'on momentum matrix of eigenvectors') + endif +c + call pcmap(i,0,0,0,ta,tm) + write(ifile,300) + 300 format(//,1x,'delta correction') + call pcmap(i,0,0,0,ta,am1) + write(ifile,400) + 400 format(//,1x,'delta**2 correction') + call pcmap(i,0,0,0,ta,am2) +c Print out value of twiss matrix + write(ifile,402) delta + 402 format(//,1x,'matrix of eigenvectors when delta= ',d15.8) + call pcmap(i,0,0,0,ta,am3) +c +c test results +c + write(ifile,*) 'test results' +************************************************************************** +*************************************************************************** +c compute matrix for betatron portion of map + call chrexp(iopt,delta,buf4a,buf4m,bm1,bm2,bm3) +c compute tune matrix + call spur2(fa,fm,ga,gm,t1a,t1m,t2m) + call scpur3(ga,gm,g1a,g1m,t1a,t1m) + call clear(temp1a,temp1m) + call clear(temp3a,temp3m) + call matmat(gm,temp1m) + call ctosr(g1a,temp2a) + temp3a(28)=temp2a(28) + temp3a(29)=temp2a(29) + temp3a(84)=temp2a(84) + temp3a(85)=temp2a(85) + call srtoc(temp3a,temp1a) + call chrexp(iopt,delta,temp1a,temp1m,rm1,rm2,rm3) +c set up matrix of eigenvectors + call matmat(am3,em3) +c form the product pm1=em3*rm3 + call mmult(em3,rm3,pm1) +c invert pm1 + call inv(t1a,pm1) +c form the product pm2=bm3*em3 + call mmult(bm3,em3,pm2) +c form the product pm3=(pm1 inverse)*pm2 + call mmult(pm1,pm2,pm3) +c form the negative identity matrix + call ident(temp1a,um1) + call smmult(-1.d0,um1,um1) +c form the difference dm1=pm3-um1 + call madd(pm3,um1,dm1) +c print the results bm3 and dm1 + call pcmap(i,0,0,0,ta,bm3) + call pcmap(i,0,0,0,ta,dm1) +************************************************************** +************************************************************** +c + 40 continue + 41 continue + endif +c +c Procedure for printing of maps. +c + if (ipmaps.eq.1 .or. ipmaps.eq.3) then +c print out script Ac and script N + if(isend.eq.0) goto 51 + do 50 i=1,2 + if (i.eq.1) then + iflag=1 + if (isend.eq.2) iflag=0 + ifile=jof + endif + if (i.eq.2) then + iflag=1 + if (isend.eq.1) iflag=0 + ifile=jodf + endif + if (iflag.eq.0) goto 50 + write(ifile,600) + 600 format(//,1x,'transforming map with respect to + # the closed orbit') + call pcmap(i,i,0,0,buf1a,buf1m) + write(ifile,700) + 700 format(//,1x,'normal form for transfer map') + call pcmap(i,i,0,0,buf2a,buf2m) + 50 continue + 51 continue + endif +c + if (ipmaps.eq.2 .or. ipmaps.eq.3) then +c print out betatron portion of map and script Ab + if(isend.eq.0) goto 61 + do 60 i=1,2 + if (i.eq.1) then + iflag=1 + if (isend.eq.2) iflag=0 + ifile=jof + endif + if (i.eq.2) then + iflag=1 + if (isend.eq.1) iflag=0 + ifile=jodf + endif + if (iflag.eq.0) goto 60 + write(ifile,610) + 610 format(//,1x,'betatron factor of transfer map') + call pcmap(i,i,0,0,buf4a,buf4m) + write(ifile,710) + 710 format(//,1x,'transforming map for betatron factor') + call pcmap(i,i,0,0,buf5a,buf5m) + 60 continue + 61 continue + endif +c +c Procedure for writing of maps. + if (iwmaps.gt.0) then + mpot=mpo + mpo=iwmaps + call mapout(0,buf1a,buf1m) + call mapout(0,buf2a,buf2m) + call mapout(0,buf3a,buf3m) + call mapout(0,buf4a,buf4m) + call mapout(0,buf5a,buf5m) + mpo=mpot + endif +c + return + end +*********************************************************************** +c + subroutine tbas(p,fa,fm) +c this routine translates bases +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' + dimension p(6),fa(monoms),fm(6,6) + dimension ga(monoms),gm(6,6) +c + call mapmap(fa,fm,ga,gm) + iopt=nint(p(1)) + if (iopt.eq.1) call ctosr(ga,fa) + if (iopt.eq.2) call ctodr(ga,fa) + if (iopt.eq.3) call srtoc(ga,fa) + if (iopt.eq.4) call drtoc(ga,fa) + return + end +c +******************************************************************* +c + subroutine trda(p,fa,fm) +c this subroutine transports a dynamic script A + use lieaparam, only : monoms + include 'impli.inc' + dimension p(6),fa(monoms),fm(6,6) +c + write(6,*) 'trda not yet available' + return + end +c +******************************************************************* +c + subroutine trsa(p,fa,fm) +c this subroutine transports a static script A + use lieaparam, only : monoms + include 'impli.inc' + dimension p(6),fa(monoms),fm(6,6) +c + write(6,*) 'trsa not yet available' + return + end +c +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/base.f b/OpticsJan2020/MLI_light_optics/Src/base.f new file mode 100755 index 0000000..b1c499e --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/base.f @@ -0,0 +1,1032 @@ +************************************************************************ +* header: CHANGE OF BASIS ROUTINES (BASE) +* ctosr,srtoc,ctodr,drtoc +************************************************************************ +c + subroutine ctosr(f,g) +c This is a subroutine for transforming from a cartesian basis +c to a static resonance basis. +c f is the cartesion vector, +c g is the vector in the static resonance basis. +c Written by F. Neri, Spring 1986 + use lieaparam, only : monoms +c implicit none + double precision f(monoms),g(monoms) +c + g(1) = f(6) + g(2) = f(1) + g(3) = f(2) + g(4) = f(3) + g(5) = f(4) + g(6) = f(5) + g(7) = .5d0*f(7)+.5d0*f(13) + g(8) = .5d0*f(18)+.5d0*f(22) + g(9) = f(27) + g(10) = f(12) + g(11) = f(17) + g(12) = f(21) + g(13) = f(24) + g(14) = .5d0*f(7)-.5d0*f(13) + g(15) = .5d0*f(8) + g(16) = .5d0*f(18)-.5d0*f(22) + g(17) = .5d0*f(19) + g(18) = .5d0*f(9)-.5d0*f(15) + g(19) = .5d0*f(10)+.5d0*f(14) + g(20) = .5d0*f(9)+.5d0*f(15) + g(21) = -.5d0*f(10)+.5d0*f(14) + g(22) = f(11) + g(23) = f(16) + g(24) = f(20) + g(25) = f(23) + g(26) = f(25) + g(27) = f(26) + g(28) = .5d0*f(33)+.5d0*f(53) + g(29) = .5d0*f(67)+.5d0*f(76) + g(30) = f(83) + g(31) = f(48) + g(32) = f(63) + g(33) = f(73) + g(34) = f(79) + g(35) = .5d0*f(33)-.5d0*f(53) + g(36) = .5d0*f(38) + g(37) = .5d0*f(67)-.5d0*f(76) + g(38) = .5d0*f(70) + g(39) = .5d0*f(42)-.5d0*f(60) + g(40) = .5d0*f(45)+.5d0*f(57) + g(41) = .5d0*f(42)+.5d0*f(60) + g(42) = -.5d0*f(45)+.5d0*f(57) + g(43) = .75d0*f(28)+.25d0*f(34) + g(44) = .25d0*f(29)+.75d0*f(49) + g(45) = .75d0*f(64)+.25d0*f(68) + g(46) = .25d0*f(65)+.75d0*f(74) + g(47) = .5d0*f(39)+.5d0*f(43) + g(48) = .5d0*f(54)+.5d0*f(58) + g(49) = .5d0*f(30)+.5d0*f(50) + g(50) = .5d0*f(31)+.5d0*f(51) + g(51) = .25d0*f(28)-.25d0*f(34) + g(52) = .25d0*f(29)-.25d0*f(49) + g(53) = .25d0*f(64)-.25d0*f(68) + g(54) = .25d0*f(65)-.25d0*f(74) + g(55) = .25d0*f(30)-.25d0*f(36)-.25d0*f(50) + g(56) = .25d0*f(31)+.25d0*f(35)-.25d0*f(51) + g(57) = .25d0*f(39)-.25d0*f(43)-.25d0*f(55) + g(58) = .25d0*f(40)+.25d0*f(54)-.25d0*f(58) + g(59) = .25d0*f(30)+.25d0*f(36)-.25d0*f(50) + g(60) = -.25d0*f(31)+.25d0*f(35)+.25d0*f(51) + g(61) = .25d0*f(39)-.25d0*f(43)+.25d0*f(55) + g(62) = .25d0*f(40)-.25d0*f(54)+.25d0*f(58) + g(63) = f(32) + g(64) = f(37) + g(65) = f(41) + g(66) = f(44) + g(67) = f(46) + g(68) = f(47) + g(69) = f(52) + g(70) = f(56) + g(71) = f(59) + g(72) = f(61) + g(73) = f(62) + g(74) = f(66) + g(75) = f(69) + g(76) = f(71) + g(77) = f(72) + g(78) = f(75) + g(79) = f(77) + g(80) = f(78) + g(81) = f(80) + g(82) = f(81) + g(83) = f(82) + g(84) = .5d0*f(104)+.5d0*f(154) + g(85) = .5d0*f(184)+.5d0*f(200) + g(86) = f(209) + g(87) = .375d0*f(84)+.125d0*f(90)+.375d0*f(140) + g(88) = .375d0*f(175)+.125d0*f(179)+.375d0*f(195) + g(89) = .25d0*f(95)+.25d0*f(99)+.25d0*f(145)+.25d0*f(149) + g(90) = f(139) + g(91) = f(174) + g(92) = f(194) + g(93) = f(204) + g(94) = .5d0*f(104)-.5d0*f(154) + g(95) = .5d0*f(119) + g(96) = .5d0*f(184)-.5d0*f(200) + g(97) = .5d0*f(190) + g(98) = .5d0*f(129)-.5d0*f(170) + g(99) = .5d0*f(135)+.5d0*f(164) + g(100) = .5d0*f(129)+.5d0*f(170) + g(101) = -.5d0*f(135)+.5d0*f(164) + g(102) = .75d0*f(89)+.25d0*f(109) + g(103) = .25d0*f(94)+.75d0*f(144) + g(104) = .75d0*f(178)+.25d0*f(187) + g(105) = .25d0*f(181)+.75d0*f(197) + g(106) = .5d0*f(123)+.5d0*f(132) + g(107) = .5d0*f(158)+.5d0*f(167) + g(108) = .5d0*f(98)+.5d0*f(148) + g(109) = .5d0*f(101)+.5d0*f(151) + g(110) = .25d0*f(89)-.25d0*f(109) + g(111) = .25d0*f(94)-.25d0*f(144) + g(112) = .25d0*f(178)-.25d0*f(187) + g(113) = .25d0*f(181)-.25d0*f(197) + g(114) = .25d0*f(98)-.25d0*f(116)-.25d0*f(148) + g(115) = .25d0*f(101)+.25d0*f(113)-.25d0*f(151) + g(116) = .25d0*f(123)-.25d0*f(132)-.25d0*f(161) + g(117) = .25d0*f(126)+.25d0*f(158)-.25d0*f(167) + g(118) = .25d0*f(98)+.25d0*f(116)-.25d0*f(148) + g(119) = -.25d0*f(101)+.25d0*f(113)+.25d0*f(151) + g(120) = .25d0*f(123)-.25d0*f(132)+.25d0*f(161) + g(121) = .25d0*f(126)-.25d0*f(158)+.25d0*f(167) + g(122) = .5d0*f(84)-.5d0*f(140) + g(123) = .25d0*f(85)+.25d0*f(105) + g(124) = .5d0*f(175)-.5d0*f(195) + g(125) = .25d0*f(176)+.25d0*f(185) + g(126) = .25d0*f(95)+.25d0*f(99)-.25d0*f(145)-.25d0*f(149) + g(127) = .25d0*f(110)+.25d0*f(114) + g(128) = .25d0*f(95)-.25d0*f(99)+.25d0*f(145)-.25d0*f(149) + g(129) = .25d0*f(96)+.25d0*f(146) + g(130) = .375d0*f(86)-.125d0*f(92)+.125d0*f(106)-.375d0*f(142) + g(131) = .375d0*f(87)+.125d0*f(91)+.125d0*f(107)+.375d0*f(141) + g(132) = .375d0*f(120)+.125d0*f(124)-.125d0*f(156)-.375d0*f(165) + g(133) = .125d0*f(121)+.375d0*f(130)+.375d0*f(155)+.125d0*f(159) + g(134) = .375d0*f(86)+.125d0*f(92)+.125d0*f(106)+.375d0*f(142) + g(135) = -.375d0*f(87)+.125d0*f(91)-.125d0*f(107)+.375d0*f(141) + g(136) = .375d0*f(120)+.125d0*f(124)+.125d0*f(156)+.375d0*f(165) + g(137) = .125d0*f(121)+.375d0*f(130)-.375d0*f(155)-.125d0*f(159) + g(138) = .125d0*f(84)-.125d0*f(90)+.125d0*f(140) + g(139) = .125d0*f(85)-.125d0*f(105) + g(140) = .125d0*f(175)-.125d0*f(179)+.125d0*f(195) + g(141) = .125d0*f(176)-.125d0*f(185) + g(142) = .125d0*f(86)-.125d0*f(92)-.125d0*f(106)+.125d0*f(142) + g(143) = .125d0*f(87)+.125d0*f(91)-.125d0*f(107)-.125d0*f(141) + g(144) = .125d0*f(120)-.125d0*f(124)-.125d0*f(156)+.125d0*f(165) + g(145) = .125d0*f(121)-.125d0*f(130)+.125d0*f(155)-.125d0*f(159) + g(146) = .125d0*f(86)+.125d0*f(92)-.125d0*f(106)-.125d0*f(142) + g(147) = -.125d0*f(87)+.125d0*f(91)+.125d0*f(107)-.125d0*f(141) + g(148) = .125d0*f(120)-.125d0*f(124)+.125d0*f(156)-.125d0*f(165) + g(149) = .125d0*f(121)-.125d0*f(130)-.125d0*f(155)+.125d0*f(159) + g(150) = .125d0*f(95)-.125d0*f(99)-.125d0*f(111) + &-.125d0*f(145)+.125d0*f(149) + g(151) = .125d0*f(96)+.125d0*f(110)-.125d0*f(114)-.125d0*f(146) + g(152) = .125d0*f(95)-.125d0*f(99)+.125d0*f(111) + &-.125d0*f(145)+.125d0*f(149) + g(153) = -.125d0*f(96)+.125d0*f(110)-.125d0*f(114)+.125d0*f(146) + g(154) = f(88) + g(155) = f(93) + g(156) = f(97) + g(157) = f(100) + g(158) = f(102) + g(159) = f(103) + g(160) = f(108) + g(161) = f(112) + g(162) = f(115) + g(163) = f(117) + g(164) = f(118) + g(165) = f(122) + g(166) = f(125) + g(167) = f(127) + g(168) = f(128) + g(169) = f(131) + g(170) = f(133) + g(171) = f(134) + g(172) = f(136) + g(173) = f(137) + g(174) = f(138) + g(175) = f(143) + g(176) = f(147) + g(177) = f(150) + g(178) = f(152) + g(179) = f(153) + g(180) = f(157) + g(181) = f(160) + g(182) = f(162) + g(183) = f(163) + g(184) = f(166) + g(185) = f(168) + g(186) = f(169) + g(187) = f(171) + g(188) = f(172) + g(189) = f(173) + g(190) = f(177) + g(191) = f(180) + g(192) = f(182) + g(193) = f(183) + g(194) = f(186) + g(195) = f(188) + g(196) = f(189) + g(197) = f(191) + g(198) = f(192) + g(199) = f(193) + g(200) = f(196) + g(201) = f(198) + g(202) = f(199) + g(203) = f(201) + g(204) = f(202) + g(205) = f(203) + g(206) = f(205) + g(207) = f(206) + g(208) = f(207) + g(209) = f(208) + return + end +c +*********************************************************************** +c + subroutine srtoc(g,f) +c This is a subroutine for transforming from a static +c resonance basis to a cartesian basis. +c g = static resonance basis array, +c f = cartesian array. +c Written by F. Neri, Spring 1986 + use lieaparam, only : monoms +c implicit none + double precision f(monoms),g(monoms) +c + f(1) = g(2) + f(2) = g(3) + f(3) = g(4) + f(4) = g(5) + f(5) = g(6) + f(6) = g(1) + f(7) = g(7)+g(14) + f(8) = 2.d0*g(15) + f(9) = g(18)+g(20) + f(10) = g(19)-g(21) + f(11) = g(22) + f(12) = g(10) + f(13) = g(7)-g(14) + f(14) = g(19)+g(21) + f(15) = -g(18)+g(20) + f(16) = g(23) + f(17) = g(11) + f(18) = g(8)+g(16) + f(19) = 2.d0*g(17) + f(20) = g(24) + f(21) = g(12) + f(22) = g(8)-g(16) + f(23) = g(25) + f(24) = g(13) + f(25) = g(26) + f(26) = g(27) + f(27) = g(9) + f(28) = g(43)+g(51) + f(29) = g(44)+3.d0*g(52) + f(30) = g(49)+g(55)+g(59) + f(31) = g(50)+g(56)-g(60) + f(32) = g(63) + f(33) = g(28)+g(35) + f(34) = g(43)-3.d0*g(51) + f(35) = 2.d0*g(56)+2.d0*g(60) + f(36) = -2.d0*g(55)+2.d0*g(59) + f(37) = g(64) + f(38) = 2.d0*g(36) + f(39) = g(47)+g(57)+g(61) + f(40) = 2.d0*g(58)+2.d0*g(62) + f(41) = g(65) + f(42) = g(39)+g(41) + f(43) = g(47)-g(57)-g(61) + f(44) = g(66) + f(45) = g(40)-g(42) + f(46) = g(67) + f(47) = g(68) + f(48) = g(31) + f(49) = g(44)-g(52) + f(50) = g(49)-g(55)-g(59) + f(51) = g(50)-g(56)+g(60) + f(52) = g(69) + f(53) = g(28)-g(35) + f(54) = g(48)+g(58)-g(62) + f(55) = -2.d0*g(57)+2.d0*g(61) + f(56) = g(70) + f(57) = g(40)+g(42) + f(58) = g(48)-g(58)+g(62) + f(59) = g(71) + f(60) = -g(39)+g(41) + f(61) = g(72) + f(62) = g(73) + f(63) = g(32) + f(64) = g(45)+g(53) + f(65) = g(46)+3.d0*g(54) + f(66) = g(74) + f(67) = g(29)+g(37) + f(68) = g(45)-3.d0*g(53) + f(69) = g(75) + f(70) = 2.d0*g(38) + f(71) = g(76) + f(72) = g(77) + f(73) = g(33) + f(74) = g(46)-g(54) + f(75) = g(78) + f(76) = g(29)-g(37) + f(77) = g(79) + f(78) = g(80) + f(79) = g(34) + f(80) = g(81) + f(81) = g(82) + f(82) = g(83) + f(83) = g(30) + f(84) = g(87)+g(122)+g(138) + f(85) = 2.d0*g(123)+4.d0*g(139) + f(86) = g(130)+g(134)+g(142)+g(146) + f(87) = g(131)-g(135)+g(143)-g(147) + f(88) = g(154) + f(89) = g(102)+g(110) + f(90) = 2.d0*g(87)-6.d0*g(138) + f(91) = g(131)+g(135)+3.d0*g(143)+3.d0*g(147) + f(92) = -g(130)+g(134)-3.d0*g(142)+3.d0*g(146) + f(93) = g(155) + f(94) = g(103)+3.d0*g(111) + f(95) = g(89)+g(126)+g(128)+g(150)+g(152) + f(96) = 2.d0*g(129)+2.d0*g(151)-2.d0*g(153) + f(97) = g(156) + f(98) = g(108)+g(114)+g(118) + f(99) = g(89)+g(126)-g(128)-g(150)-g(152) + f(100) = g(157) + f(101) = g(109)+g(115)-g(119) + f(102) = g(158) + f(103) = g(159) + f(104) = g(84)+g(94) + f(105) = 2.d0*g(123)-4.d0*g(139) + f(106) = g(130)+g(134)-3.d0*g(142)-3.d0*g(146) + f(107) = g(131)-g(135)-3.d0*g(143)+3.d0*g(147) + f(108) = g(160) + f(109) = g(102)-3.d0*g(110) + f(110) = 2.d0*g(127)+2.d0*g(151)+2.d0*g(153) + f(111) = -4.d0*g(150)+4.d0*g(152) + f(112) = g(161) + f(113) = 2.d0*g(115)+2.d0*g(119) + f(114) = 2.d0*g(127)-2.d0*g(151)-2.d0*g(153) + f(115) = g(162) + f(116) = -2.d0*g(114)+2.d0*g(118) + f(117) = g(163) + f(118) = g(164) + f(119) = 2.d0*g(95) + f(120) = g(132)+g(136)+g(144)+g(148) + f(121) = g(133)+g(137)+3.d0*g(145)+3.d0*g(149) + f(122) = g(165) + f(123) = g(106)+g(116)+g(120) + f(124) = g(132)+g(136)-3.d0*g(144)-3.d0*g(148) + f(125) = g(166) + f(126) = 2.d0*g(117)+2.d0*g(121) + f(127) = g(167) + f(128) = g(168) + f(129) = g(98)+g(100) + f(130) = g(133)+g(137)-g(145)-g(149) + f(131) = g(169) + f(132) = g(106)-g(116)-g(120) + f(133) = g(170) + f(134) = g(171) + f(135) = g(99)-g(101) + f(136) = g(172) + f(137) = g(173) + f(138) = g(174) + f(139) = g(90) + f(140) = g(87)-g(122)+g(138) + f(141) = g(131)+g(135)-g(143)-g(147) + f(142) = -g(130)+g(134)+g(142)-g(146) + f(143) = g(175) + f(144) = g(103)-g(111) + f(145) = g(89)-g(126)+g(128)-g(150)-g(152) + f(146) = 2.d0*g(129)-2.d0*g(151)+2.d0*g(153) + f(147) = g(176) + f(148) = g(108)-g(114)-g(118) + f(149) = g(89)-g(126)-g(128)+g(150)+g(152) + f(150) = g(177) + f(151) = g(109)-g(115)+g(119) + f(152) = g(178) + f(153) = g(179) + f(154) = g(84)-g(94) + f(155) = g(133)-g(137)+g(145)-g(149) + f(156) = -g(132)+g(136)-3.d0*g(144)+3.d0*g(148) + f(157) = g(180) + f(158) = g(107)+g(117)-g(121) + f(159) = g(133)-g(137)-3.d0*g(145)+3.d0*g(149) + f(160) = g(181) + f(161) = -2.d0*g(116)+2.d0*g(120) + f(162) = g(182) + f(163) = g(183) + f(164) = g(99)+g(101) + f(165) = -g(132)+g(136)+g(144)-g(148) + f(166) = g(184) + f(167) = g(107)-g(117)+g(121) + f(168) = g(185) + f(169) = g(186) + f(170) = -g(98)+g(100) + f(171) = g(187) + f(172) = g(188) + f(173) = g(189) + f(174) = g(91) + f(175) = g(88)+g(124)+g(140) + f(176) = 2.d0*g(125)+4.d0*g(141) + f(177) = g(190) + f(178) = g(104)+g(112) + f(179) = 2.d0*g(88)-6.d0*g(140) + f(180) = g(191) + f(181) = g(105)+3.d0*g(113) + f(182) = g(192) + f(183) = g(193) + f(184) = g(85)+g(96) + f(185) = 2.d0*g(125)-4.d0*g(141) + f(186) = g(194) + f(187) = g(104)-3.d0*g(112) + f(188) = g(195) + f(189) = g(196) + f(190) = 2.d0*g(97) + f(191) = g(197) + f(192) = g(198) + f(193) = g(199) + f(194) = g(92) + f(195) = g(88)-g(124)+g(140) + f(196) = g(200) + f(197) = g(105)-g(113) + f(198) = g(201) + f(199) = g(202) + f(200) = g(85)-g(96) + f(201) = g(203) + f(202) = g(204) + f(203) = g(205) + f(204) = g(93) + f(205) = g(206) + f(206) = g(207) + f(207) = g(208) + f(208) = g(209) + f(209) = g(86) + return + end +c +************************************************************ + subroutine ctodr(f,g) +* +* go from cartesian to static resonance frame +* f(*) : cartesian basis coefficients (input). +* g(*) : dynamic resonance basis coefficients (output). +* +* F. Neri 6/2/1986 +* +************************************************************ + use lieaparam, only : monoms +c implicit none + double precision f(monoms),g(monoms) +c + g(1) = 1.d0*f(1) + g(2) = 1.d0*f(2) + g(3) = 1.d0*f(3) + g(4) = 1.d0*f(4) + g(5) = 1.d0*f(5) + g(6) = 1.d0*f(6) + g(7) = .5d0*f(7)+.5d0*f(13) + g(8) = .5d0*f(18)+.5d0*f(22) + g(9) = .5d0*f(25)+.5d0*f(27) + g(10) = .5d0*f(25)-.5d0*f(27) + g(11) = .5d0*f(26) + g(12) = .5d0*f(11)-.5d0*f(17) + g(13) = .5d0*f(12)+.5d0*f(16) + g(14) = .5d0*f(11)+.5d0*f(17) + g(15) = -.5d0*f(12)+.5d0*f(16) + g(16) = .5d0*f(20)-.5d0*f(24) + g(17) = .5d0*f(21)+.5d0*f(23) + g(18) = .5d0*f(20)+.5d0*f(24) + g(19) = -.5d0*f(21)+.5d0*f(23) + g(20) = .5d0*f(7)-.5d0*f(13) + g(21) = .5d0*f(8) + g(22) = .5d0*f(18)-.5d0*f(22) + g(23) = .5d0*f(19) + g(24) = .5d0*f(9)-.5d0*f(15) + g(25) = .5d0*f(10)+.5d0*f(14) + g(26) = .5d0*f(9)+.5d0*f(15) + g(27) = -.5d0*f(10)+.5d0*f(14) + g(28) = .5d0*f(32)+.5d0*f(52) + g(29) = .5d0*f(33)+.5d0*f(53) + g(30) = .5d0*f(66)+.5d0*f(75) + g(31) = .5d0*f(67)+.5d0*f(76) + g(32) = .25d0*f(80)-.25d0*f(82) + g(33) = .25d0*f(81)-.25d0*f(83) + g(34) = .75d0*f(80)+.25d0*f(82) + g(35) = .25d0*f(81)+.75d0*f(83) + g(36) = .5d0*f(46)+.5d0*f(48) + g(37) = .5d0*f(61)+.5d0*f(63) + g(38) = .5d0*f(71)+.5d0*f(73) + g(39) = .5d0*f(77)+.5d0*f(79) + g(40) = .25d0*f(46)-.25d0*f(48)-.25d0*f(62) + g(41) = .25d0*f(47)+.25d0*f(61)-.25d0*f(63) + g(42) = .25d0*f(46)-.25d0*f(48)+.25d0*f(62) + g(43) = -.25d0*f(47)+.25d0*f(61)-.25d0*f(63) + g(44) = .25d0*f(71)-.25d0*f(73)-.25d0*f(78) + g(45) = .25d0*f(72)+.25d0*f(77)-.25d0*f(79) + g(46) = .25d0*f(71)-.25d0*f(73)+.25d0*f(78) + g(47) = -.25d0*f(72)+.25d0*f(77)-.25d0*f(79) + g(48) = .25d0*f(32)-.25d0*f(38)-.25d0*f(52) + g(49) = .25d0*f(33)+.25d0*f(37)-.25d0*f(53) + g(50) = .25d0*f(32)+.25d0*f(38)-.25d0*f(52) + g(51) = -.25d0*f(33)+.25d0*f(37)+.25d0*f(53) + g(52) = .25d0*f(66)-.25d0*f(70)-.25d0*f(75) + g(53) = .25d0*f(67)+.25d0*f(69)-.25d0*f(76) + g(54) = .25d0*f(66)+.25d0*f(70)-.25d0*f(75) + g(55) = -.25d0*f(67)+.25d0*f(69)+.25d0*f(76) + g(56) = .25d0*f(41)-.25d0*f(45)-.25d0*f(57)-.25d0*f(59) + g(57) = .25d0*f(42)+.25d0*f(44)+.25d0*f(56)-.25d0*f(60) + g(58) = .25d0*f(41)+.25d0*f(45)+.25d0*f(57)-.25d0*f(59) + g(59) = -.25d0*f(42)+.25d0*f(44)+.25d0*f(56)+.25d0*f(60) + g(60) = .25d0*f(41)+.25d0*f(45)-.25d0*f(57)+.25d0*f(59) + g(61) = .25d0*f(42)-.25d0*f(44)+.25d0*f(56)+.25d0*f(60) + g(62) = .25d0*f(41)-.25d0*f(45)+.25d0*f(57)+.25d0*f(59) + g(63) = -.25d0*f(42)-.25d0*f(44)+.25d0*f(56)-.25d0*f(60) + g(64) = .75d0*f(28)+.25d0*f(34) + g(65) = .25d0*f(29)+.75d0*f(49) + g(66) = .75d0*f(64)+.25d0*f(68) + g(67) = .25d0*f(65)+.75d0*f(74) + g(68) = .5d0*f(39)+.5d0*f(43) + g(69) = .5d0*f(54)+.5d0*f(58) + g(70) = .5d0*f(30)+.5d0*f(50) + g(71) = .5d0*f(31)+.5d0*f(51) + g(72) = .25d0*f(28)-.25d0*f(34) + g(73) = .25d0*f(29)-.25d0*f(49) + g(74) = .25d0*f(64)-.25d0*f(68) + g(75) = .25d0*f(65)-.25d0*f(74) + g(76) = .25d0*f(30)-.25d0*f(36)-.25d0*f(50) + g(77) = .25d0*f(31)+.25d0*f(35)-.25d0*f(51) + g(78) = .25d0*f(39)-.25d0*f(43)-.25d0*f(55) + g(79) = .25d0*f(40)+.25d0*f(54)-.25d0*f(58) + g(80) = .25d0*f(30)+.25d0*f(36)-.25d0*f(50) + g(81) = -.25d0*f(31)+.25d0*f(35)+.25d0*f(51) + g(82) = .25d0*f(39)-.25d0*f(43)+.25d0*f(55) + g(83) = -.25d0*f(40)+.25d0*f(54)-.25d0*f(58) + g(84) = .375d0*f(84)+.125d0*f(90)+.375d0*f(140) + g(85) = .375d0*f(175)+.125d0*f(179)+.375d0*f(195) + g(86) = .375d0*f(205)+.125d0*f(207)+.375d0*f(209) + g(87) = .25d0*f(95)+.25d0*f(99)+.25d0*f(145)+.25d0*f(149) + g(88) = .25d0*f(102)+.25d0*f(104)+.25d0*f(152)+.25d0*f(154) + g(89) = .25d0*f(182)+.25d0*f(184)+.25d0*f(198)+.25d0*f(200) + g(90) = .25d0*f(102)-.25d0*f(104)+.25d0*f(152) + & -.25d0*f(154) + g(91) = .25d0*f(103)+.25d0*f(153) + g(92) = .25d0*f(182)-.25d0*f(184)+.25d0*f(198) + & -.25d0*f(200) + g(93) = .25d0*f(183)+.25d0*f(199) + g(94) = .125d0*f(205)-.125d0*f(207)+.125d0*f(209) + g(95) = .125d0*f(206)-.125d0*f(208) + g(96) = .5d0*f(205)-.5d0*f(209) + g(97) = .25d0*f(206)+.25d0*f(208) + g(98) = .125d0*f(136)-.125d0*f(138)-.125d0*f(172) + & +.125d0*f(174) + g(99) = .125d0*f(137)-.125d0*f(139)+.125d0*f(171) + & -.125d0*f(173) + g(100) = .125d0*f(136)-.125d0*f(138)+.125d0*f(172) + & -.125d0*f(174) + g(101) = -.125d0*f(137)+.125d0*f(139)+.125d0*f(171) + & -.125d0*f(173) + g(102) = .125d0*f(191)-.125d0*f(193)-.125d0*f(202) + & +.125d0*f(204) + g(103) = .125d0*f(192)-.125d0*f(194)+.125d0*f(201) + & -.125d0*f(203) + g(104) = .125d0*f(191)-.125d0*f(193)+.125d0*f(202) + & -.125d0*f(204) + g(105) = -.125d0*f(192)+.125d0*f(194)+.125d0*f(201) + & -.125d0*f(203) + g(106) = .375d0*f(136)+.125d0*f(138)-.125d0*f(172) + & -.375d0*f(174) + g(107) = .125d0*f(137)+.375d0*f(139)+.375d0*f(171) + & +.125d0*f(173) + g(108) = .375d0*f(136)+.125d0*f(138)+.125d0*f(172) + & +.375d0*f(174) + g(109) = -.125d0*f(137)-.375d0*f(139)+.375d0*f(171) + & +.125d0*f(173) + g(110) = .375d0*f(191)+.125d0*f(193)-.125d0*f(202) + & -.375d0*f(204) + g(111) = .125d0*f(192)+.375d0*f(194)+.375d0*f(201) + & +.125d0*f(203) + g(112) = .375d0*f(191)+.125d0*f(193)+.125d0*f(202) + & +.375d0*f(204) + g(113) = -.125d0*f(192)-.375d0*f(194)+.375d0*f(201) + & +.125d0*f(203) + g(114) = .25d0*f(102)+.25d0*f(104)-.25d0*f(152) + & -.25d0*f(154) + g(115) = .25d0*f(117)+.25d0*f(119) + g(116) = .25d0*f(182)+.25d0*f(184)-.25d0*f(198) + & -.25d0*f(200) + g(117) = .25d0*f(188)+.25d0*f(190) + g(118) = .125d0*f(102)-.125d0*f(104)-.125d0*f(118) + & -.125d0*f(152)+.125d0*f(154) + g(119) = .125d0*f(103)+.125d0*f(117)-.125d0*f(119) + & -.125d0*f(153) + g(120) = .125d0*f(102)-.125d0*f(104)+.125d0*f(118) + & -.125d0*f(152)+.125d0*f(154) + g(121) = -.125d0*f(103)+.125d0*f(117)-.125d0*f(119) + & +.125d0*f(153) + g(122) = .125d0*f(182)-.125d0*f(184)-.125d0*f(189) + & -.125d0*f(198)+.125d0*f(200) + g(123) = .125d0*f(183)+.125d0*f(188)-.125d0*f(190) + & -.125d0*f(199) + g(124) = .125d0*f(182)-.125d0*f(184)+.125d0*f(189) + & -.125d0*f(198)+.125d0*f(200) + g(125) = -.125d0*f(183)+.125d0*f(188)-.125d0*f(190) + & +.125d0*f(199) + g(126) = .25d0*f(127)+.25d0*f(129)-.25d0*f(168) + & -.25d0*f(170) + g(127) = .25d0*f(133)+.25d0*f(135)+.25d0*f(162)+.25d0*f(164) + g(128) = .25d0*f(127)+.25d0*f(129)+.25d0*f(168)+.25d0*f(170) + g(129) = -.25d0*f(133)-.25d0*f(135)+.25d0*f(162)+.25d0*f(164) + g(130) = .125d0*f(127)-.125d0*f(129)-.125d0*f(134) + & -.125d0*f(163)-.125d0*f(168)+.125d0*f(170) + g(131) = .125d0*f(128)+.125d0*f(133)-.125d0*f(135) + & +.125d0*f(162)-.125d0*f(164)-.125d0*f(169) + g(132) = .125d0*f(127)-.125d0*f(129)+.125d0*f(134) + & +.125d0*f(163)-.125d0*f(168)+.125d0*f(170) + g(133) = -.125d0*f(128)+.125d0*f(133)-.125d0*f(135) + & +.125d0*f(162)-.125d0*f(164)+.125d0*f(169) + g(134) = .125d0*f(127)-.125d0*f(129)+.125d0*f(134) + & -.125d0*f(163)+.125d0*f(168)-.125d0*f(170) + g(135) = .125d0*f(128)-.125d0*f(133)+.125d0*f(135) + & +.125d0*f(162)-.125d0*f(164)+.125d0*f(169) + g(136) = .125d0*f(127)-.125d0*f(129)-.125d0*f(134) + & +.125d0*f(163)+.125d0*f(168)-.125d0*f(170) + g(137) = -.125d0*f(128)-.125d0*f(133)+.125d0*f(135) + & +.125d0*f(162)-.125d0*f(164)-.125d0*f(169) + g(138) = .375d0*f(88)-.125d0*f(94)+.125d0*f(108) + & -.375d0*f(144) + g(139) = .375d0*f(89)+.125d0*f(93)+.125d0*f(109) + & +.375d0*f(143) + g(140) = .375d0*f(88)+.125d0*f(94)+.125d0*f(108) + & +.375d0*f(144) + g(141) = -.375d0*f(89)+.125d0*f(93)-.125d0*f(109) + & +.375d0*f(143) + g(142) = .375d0*f(177)-.125d0*f(181)+.125d0*f(186) + & -.375d0*f(197) + g(143) = .375d0*f(178)+.125d0*f(180)+.125d0*f(187) + & +.375d0*f(196) + g(144) = .375d0*f(177)+.125d0*f(181)+.125d0*f(186) + & +.375d0*f(197) + g(145) = -.375d0*f(178)+.125d0*f(180)-.125d0*f(187) + & +.375d0*f(196) + g(146) = .25d0*f(122)+.25d0*f(131)-.25d0*f(158) + & -.25d0*f(167) + g(147) = .25d0*f(123)+.25d0*f(132)+.25d0*f(157)+.25d0*f(166) + g(148) = .25d0*f(122)+.25d0*f(131)+.25d0*f(158)+.25d0*f(167) + g(149) = -.25d0*f(123)-.25d0*f(132)+.25d0*f(157)+.25d0*f(166) + g(150) = .25d0*f(97)-.25d0*f(101)+.25d0*f(147) + & -.25d0*f(151) + g(151) = .25d0*f(98)+.25d0*f(100)+.25d0*f(148)+.25d0*f(150) + g(152) = .25d0*f(97)+.25d0*f(101)+.25d0*f(147)+.25d0*f(151) + g(153) = -.25d0*f(98)+.25d0*f(100)-.25d0*f(148)+.25d0*f(150) + g(154) = .125d0*f(88)-.125d0*f(94)-.125d0*f(108) + & +.125d0*f(144) + g(155) = .125d0*f(89)+.125d0*f(93)-.125d0*f(109) + & -.125d0*f(143) + g(156) = .125d0*f(88)+.125d0*f(94)-.125d0*f(108) + & -.125d0*f(144) + g(157) = -.125d0*f(89)+.125d0*f(93)+.125d0*f(109) + & -.125d0*f(143) + g(158) = .125d0*f(177)-.125d0*f(181)-.125d0*f(186) + & +.125d0*f(197) + g(159) = .125d0*f(178)+.125d0*f(180)-.125d0*f(187) + & -.125d0*f(196) + g(160) = .125d0*f(177)+.125d0*f(181)-.125d0*f(186) + & -.125d0*f(197) + g(161) = -.125d0*f(178)+.125d0*f(180)+.125d0*f(187) + & -.125d0*f(196) + g(162) = .125d0*f(97)-.125d0*f(101)-.125d0*f(113) + & -.125d0*f(115)-.125d0*f(147)+.125d0*f(151) + g(163) = .125d0*f(98)+.125d0*f(100)+.125d0*f(112) + & -.125d0*f(116)-.125d0*f(148)-.125d0*f(150) + g(164) = .125d0*f(97)+.125d0*f(101)+.125d0*f(113) + & -.125d0*f(115)-.125d0*f(147)-.125d0*f(151) + g(165) = -.125d0*f(98)+.125d0*f(100)+.125d0*f(112) + & +.125d0*f(116)+.125d0*f(148)-.125d0*f(150) + g(166) = .125d0*f(122)-.125d0*f(126)-.125d0*f(131) + & -.125d0*f(158)-.125d0*f(160)+.125d0*f(167) + g(167) = .125d0*f(123)+.125d0*f(125)-.125d0*f(132) + & +.125d0*f(157)-.125d0*f(161)-.125d0*f(166) + g(168) = .125d0*f(122)+.125d0*f(126)-.125d0*f(131) + & +.125d0*f(158)-.125d0*f(160)-.125d0*f(167) + g(169) = -.125d0*f(123)+.125d0*f(125)+.125d0*f(132) + & +.125d0*f(157)+.125d0*f(161)-.125d0*f(166) + g(170) = .125d0*f(97)+.125d0*f(101)-.125d0*f(113) + & +.125d0*f(115)-.125d0*f(147)-.125d0*f(151) + g(171) = .125d0*f(98)-.125d0*f(100)+.125d0*f(112) + & +.125d0*f(116)-.125d0*f(148)+.125d0*f(150) + g(172) = .125d0*f(97)-.125d0*f(101)+.125d0*f(113) + & +.125d0*f(115)-.125d0*f(147)+.125d0*f(151) + g(173) = -.125d0*f(98)-.125d0*f(100)+.125d0*f(112) + & -.125d0*f(116)+.125d0*f(148)+.125d0*f(150) + g(174) = .125d0*f(122)-.125d0*f(126)-.125d0*f(131) + & +.125d0*f(158)+.125d0*f(160)-.125d0*f(167) + g(175) = -.125d0*f(123)-.125d0*f(125)+.125d0*f(132) + & +.125d0*f(157)-.125d0*f(161)-.125d0*f(166) + g(176) = .125d0*f(122)+.125d0*f(126)-.125d0*f(131) + & -.125d0*f(158)+.125d0*f(160)+.125d0*f(167) + g(177) = .125d0*f(123)-.125d0*f(125)-.125d0*f(132) + & +.125d0*f(157)+.125d0*f(161)-.125d0*f(166) + g(178) = .5d0*f(84)-.5d0*f(140) + g(179) = .25d0*f(85)+.25d0*f(105) + g(180) = .5d0*f(175)-.5d0*f(195) + g(181) = .25d0*f(176)+.25d0*f(185) + g(182) = .25d0*f(95)+.25d0*f(99)-.25d0*f(145)-.25d0*f(149) + g(183) = .25d0*f(110)+.25d0*f(114) + g(184) = .25d0*f(95)-.25d0*f(99)+.25d0*f(145)-.25d0*f(149) + g(185) = .25d0*f(96)+.25d0*f(146) + g(186) = .375d0*f(86)-.125d0*f(92)+.125d0*f(106) + & -.375d0*f(142) + g(187) = .375d0*f(87)+.125d0*f(91)+.125d0*f(107) + & +.375d0*f(141) + g(188) = .375d0*f(120)+.125d0*f(124)-.125d0*f(156) + & -.375d0*f(165) + g(189) = .125d0*f(121)+.375d0*f(130)+.375d0*f(155) + & +.125d0*f(159) + g(190) = .375d0*f(86)+.125d0*f(92)+.125d0*f(106) + & +.375d0*f(142) + g(191) = -.375d0*f(87)+.125d0*f(91)-.125d0*f(107) + & +.375d0*f(141) + g(192) = .375d0*f(120)+.125d0*f(124)+.125d0*f(156) + & +.375d0*f(165) + g(193) = -.125d0*f(121)-.375d0*f(130)+.375d0*f(155) + & +.125d0*f(159) + g(194) = .125d0*f(84)-.125d0*f(90)+.125d0*f(140) + g(195) = .125d0*f(85)-.125d0*f(105) + g(196) = .125d0*f(175)-.125d0*f(179)+.125d0*f(195) + g(197) = .125d0*f(176)-.125d0*f(185) + g(198) = .125d0*f(86)-.125d0*f(92)-.125d0*f(106) + & +.125d0*f(142) + g(199) = .125d0*f(87)+.125d0*f(91)-.125d0*f(107) + & -.125d0*f(141) + g(200) = .125d0*f(120)-.125d0*f(124)-.125d0*f(156) + & +.125d0*f(165) + g(201) = .125d0*f(121)-.125d0*f(130)+.125d0*f(155) + & -.125d0*f(159) + g(202) = .125d0*f(86)+.125d0*f(92)-.125d0*f(106) + & -.125d0*f(142) + g(203) = -.125d0*f(87)+.125d0*f(91)+.125d0*f(107) + & -.125d0*f(141) + g(204) = .125d0*f(120)-.125d0*f(124)+.125d0*f(156) + & -.125d0*f(165) + g(205) = -.125d0*f(121)+.125d0*f(130)+.125d0*f(155) + & -.125d0*f(159) + g(206) = .125d0*f(95)-.125d0*f(99)-.125d0*f(111) + & -.125d0*f(145)+.125d0*f(149) + g(207) = .125d0*f(96)+.125d0*f(110)-.125d0*f(114) + & -.125d0*f(146) + g(208) = .125d0*f(95)-.125d0*f(99)+.125d0*f(111) + & -.125d0*f(145)+.125d0*f(149) + g(209) = -.125d0*f(96)+.125d0*f(110)-.125d0*f(114) + & +.125d0*f(146) + return + end +c +************************************************** + subroutine drtoc(g,f) +* +* change from dynamic resonance basis to cartesian +* g(*) : dynamic basis coefficints (input). +* f(*) : cartesion coefficients (output). +* +* F. Neri 6/2/1986 +* +************************************************** + use lieaparam, only : monoms +c implicit none + double precision f(monoms),g(monoms) +c + f(1) = 1.d0*g(1) + f(2) = 1.d0*g(2) + f(3) = 1.d0*g(3) + f(4) = 1.d0*g(4) + f(5) = 1.d0*g(5) + f(6) = 1.d0*g(6) + f(7) = 1.d0*g(7)+1.d0*g(20) + f(8) = 2.d0*g(21) + f(9) = 1.d0*g(24)+1.d0*g(26) + f(10) = 1.d0*g(25)-1.d0*g(27) + f(11) = 1.d0*g(12)+1.d0*g(14) + f(12) = 1.d0*g(13)-1.d0*g(15) + f(13) = 1.d0*g(7)-1.d0*g(20) + f(14) = 1.d0*g(25)+1.d0*g(27) + f(15) = -1.d0*g(24)+1.d0*g(26) + f(16) = 1.d0*g(13)+1.d0*g(15) + f(17) = -1.d0*g(12)+1.d0*g(14) + f(18) = 1.d0*g(8)+1.d0*g(22) + f(19) = 2.d0*g(23) + f(20) = 1.d0*g(16)+1.d0*g(18) + f(21) = 1.d0*g(17)-1.d0*g(19) + f(22) = 1.d0*g(8)-1.d0*g(22) + f(23) = 1.d0*g(17)+1.d0*g(19) + f(24) = -1.d0*g(16)+1.d0*g(18) + f(25) = 1.d0*g(9)+1.d0*g(10) + f(26) = 2.d0*g(11) + f(27) = 1.d0*g(9)-1.d0*g(10) + f(28) = 1.d0*g(64)+1.d0*g(72) + f(29) = 1.d0*g(65)+3.d0*g(73) + f(30) = 1.d0*g(70)+1.d0*g(76)+1.d0*g(80) + f(31) = 1.d0*g(71)+1.d0*g(77)-1.d0*g(81) + f(32) = 1.d0*g(28)+1.d0*g(48)+1.d0*g(50) + f(33) = 1.d0*g(29)+1.d0*g(49)-1.d0*g(51) + f(34) = 1.d0*g(64)-3.d0*g(72) + f(35) = 2.d0*g(77)+2.d0*g(81) + f(36) = -2.d0*g(76)+2.d0*g(80) + f(37) = 2.d0*g(49)+2.d0*g(51) + f(38) = -2.d0*g(48)+2.d0*g(50) + f(39) = 1.d0*g(68)+1.d0*g(78)+1.d0*g(82) + f(40) = 2.d0*g(79)-2.d0*g(83) + f(41) = 1.d0*g(56)+1.d0*g(58)+1.d0*g(60)+1.d0*g(62) + f(42) = 1.d0*g(57)-1.d0*g(59)+1.d0*g(61)-1.d0*g(63) + f(43) = 1.d0*g(68)-1.d0*g(78)-1.d0*g(82) + f(44) = 1.d0*g(57)+1.d0*g(59)-1.d0*g(61)-1.d0*g(63) + f(45) = -1.d0*g(56)+1.d0*g(58)+1.d0*g(60)-1.d0*g(62) + f(46) = 1.d0*g(36)+1.d0*g(40)+1.d0*g(42) + f(47) = 2.d0*g(41)-2.d0*g(43) + f(48) = 1.d0*g(36)-1.d0*g(40)-1.d0*g(42) + f(49) = 1.d0*g(65)-1.d0*g(73) + f(50) = 1.d0*g(70)-1.d0*g(76)-1.d0*g(80) + f(51) = 1.d0*g(71)-1.d0*g(77)+1.d0*g(81) + f(52) = 1.d0*g(28)-1.d0*g(48)-1.d0*g(50) + f(53) = 1.d0*g(29)-1.d0*g(49)+1.d0*g(51) + f(54) = 1.d0*g(69)+1.d0*g(79)+1.d0*g(83) + f(55) = -2.d0*g(78)+2.d0*g(82) + f(56) = 1.d0*g(57)+1.d0*g(59)+1.d0*g(61)+1.d0*g(63) + f(57) = -1.d0*g(56)+1.d0*g(58)-1.d0*g(60)+1.d0*g(62) + f(58) = 1.d0*g(69)-1.d0*g(79)-1.d0*g(83) + f(59) = -1.d0*g(56)-1.d0*g(58)+1.d0*g(60)+1.d0*g(62) + f(60) = -1.d0*g(57)+1.d0*g(59)+1.d0*g(61)-1.d0*g(63) + f(61) = 1.d0*g(37)+1.d0*g(41)+1.d0*g(43) + f(62) = -2.d0*g(40)+2.d0*g(42) + f(63) = 1.d0*g(37)-1.d0*g(41)-1.d0*g(43) + f(64) = 1.d0*g(66)+1.d0*g(74) + f(65) = 1.d0*g(67)+3.d0*g(75) + f(66) = 1.d0*g(30)+1.d0*g(52)+1.d0*g(54) + f(67) = 1.d0*g(31)+1.d0*g(53)-1.d0*g(55) + f(68) = 1.d0*g(66)-3.d0*g(74) + f(69) = 2.d0*g(53)+2.d0*g(55) + f(70) = -2.d0*g(52)+2.d0*g(54) + f(71) = 1.d0*g(38)+1.d0*g(44)+1.d0*g(46) + f(72) = 2.d0*g(45)-2.d0*g(47) + f(73) = 1.d0*g(38)-1.d0*g(44)-1.d0*g(46) + f(74) = 1.d0*g(67)-1.d0*g(75) + f(75) = 1.d0*g(30)-1.d0*g(52)-1.d0*g(54) + f(76) = 1.d0*g(31)-1.d0*g(53)+1.d0*g(55) + f(77) = 1.d0*g(39)+1.d0*g(45)+1.d0*g(47) + f(78) = -2.d0*g(44)+2.d0*g(46) + f(79) = 1.d0*g(39)-1.d0*g(45)-1.d0*g(47) + f(80) = 1.d0*g(32)+1.d0*g(34) + f(81) = 3.d0*g(33)+1.d0*g(35) + f(82) = -3.d0*g(32)+1.d0*g(34) + f(83) = -1.d0*g(33)+1.d0*g(35) + f(84) = 1.d0*g(84)+1.d0*g(178)+1.d0*g(194) + f(85) = 2.d0*g(179)+4.d0*g(195) + f(86) = 1.d0*g(186)+1.d0*g(190)+1.d0*g(198)+1.d0*g(202) + f(87) = 1.d0*g(187)-1.d0*g(191)+1.d0*g(199)-1.d0*g(203) + f(88) = 1.d0*g(138)+1.d0*g(140)+1.d0*g(154)+1.d0*g(156) + f(89) = 1.d0*g(139)-1.d0*g(141)+1.d0*g(155)-1.d0*g(157) + f(90) = 2.d0*g(84)-6.d0*g(194) + f(91) = 1.d0*g(187)+1.d0*g(191)+3.d0*g(199)+3.d0*g(203) + f(92) = -1.d0*g(186)+1.d0*g(190)-3.d0*g(198)+3.d0*g(202) + f(93) = 1.d0*g(139)+1.d0*g(141)+3.d0*g(155)+3.d0*g(157) + f(94) = -1.d0*g(138)+1.d0*g(140)-3.d0*g(154)+3.d0*g(156) + f(95) = 1.d0*g(87)+1.d0*g(182)+1.d0*g(184)+1.d0*g(206) + & +1.d0*g(208) + f(96) = 2.d0*g(185)+2.d0*g(207)-2.d0*g(209) + f(97) = 1.d0*g(150)+1.d0*g(152)+1.d0*g(162)+1.d0*g(164) + & +1.d0*g(170)+1.d0*g(172) + f(98) = 1.d0*g(151)-1.d0*g(153)+1.d0*g(163)-1.d0*g(165) + & +1.d0*g(171)-1.d0*g(173) + f(99) = 1.d0*g(87)+1.d0*g(182)-1.d0*g(184)-1.d0*g(206) + & -1.d0*g(208) + f(100) = 1.d0*g(151)+1.d0*g(153)+1.d0*g(163)+1.d0*g(165) + & -1.d0*g(171)-1.d0*g(173) + f(101) = -1.d0*g(150)+1.d0*g(152)-1.d0*g(162)+1.d0*g(164) + & +1.d0*g(170)-1.d0*g(172) + f(102) = 1.d0*g(88)+1.d0*g(90)+1.d0*g(114)+1.d0*g(118) + & +1.d0*g(120) + f(103) = 2.d0*g(91)+2.d0*g(119)-2.d0*g(121) + f(104) = 1.d0*g(88)-1.d0*g(90)+1.d0*g(114)-1.d0*g(118) + & -1.d0*g(120) + f(105) = 2.d0*g(179)-4.d0*g(195) + f(106) = 1.d0*g(186)+1.d0*g(190)-3.d0*g(198)-3.d0*g(202) + f(107) = 1.d0*g(187)-1.d0*g(191)-3.d0*g(199)+3.d0*g(203) + f(108) = 1.d0*g(138)+1.d0*g(140)-3.d0*g(154)-3.d0*g(156) + f(109) = 1.d0*g(139)-1.d0*g(141)-3.d0*g(155)+3.d0*g(157) + f(110) = 2.d0*g(183)+2.d0*g(207)+2.d0*g(209) + f(111) = -4.d0*g(206)+4.d0*g(208) + f(112) = 2.d0*g(163)+2.d0*g(165)+2.d0*g(171)+2.d0*g(173) + f(113) = -2.d0*g(162)+2.d0*g(164)-2.d0*g(170)+2.d0*g(172) + f(114) = 2.d0*g(183)-2.d0*g(207)-2.d0*g(209) + f(115) = -2.d0*g(162)-2.d0*g(164)+2.d0*g(170)+2.d0*g(172) + f(116) = -2.d0*g(163)+2.d0*g(165)+2.d0*g(171)-2.d0*g(173) + f(117) = 2.d0*g(115)+2.d0*g(119)+2.d0*g(121) + f(118) = -4.d0*g(118)+4.d0*g(120) + f(119) = 2.d0*g(115)-2.d0*g(119)-2.d0*g(121) + f(120) = 1.d0*g(188)+1.d0*g(192)+1.d0*g(200)+1.d0*g(204) + f(121) = 1.d0*g(189)-1.d0*g(193)+3.d0*g(201)-3.d0*g(205) + f(122) = 1.d0*g(146)+1.d0*g(148)+1.d0*g(166)+1.d0*g(168) + & +1.d0*g(174)+1.d0*g(176) + f(123) = 1.d0*g(147)-1.d0*g(149)+1.d0*g(167)-1.d0*g(169) + & -1.d0*g(175)+1.d0*g(177) + f(124) = 1.d0*g(188)+1.d0*g(192)-3.d0*g(200)-3.d0*g(204) + f(125) = 2.d0*g(167)+2.d0*g(169)-2.d0*g(175)-2.d0*g(177) + f(126) = -2.d0*g(166)+2.d0*g(168)-2.d0*g(174)+2.d0*g(176) + f(127) = 1.d0*g(126)+1.d0*g(128)+1.d0*g(130)+1.d0*g(132) + & +1.d0*g(134)+1.d0*g(136) + f(128) = 2.d0*g(131)-2.d0*g(133)+2.d0*g(135)-2.d0*g(137) + f(129) = 1.d0*g(126)+1.d0*g(128)-1.d0*g(130)-1.d0*g(132) + & -1.d0*g(134)-1.d0*g(136) + f(130) = 1.d0*g(189)-1.d0*g(193)-1.d0*g(201)+1.d0*g(205) + f(131) = 1.d0*g(146)+1.d0*g(148)-1.d0*g(166)-1.d0*g(168) + & -1.d0*g(174)-1.d0*g(176) + f(132) = 1.d0*g(147)-1.d0*g(149)-1.d0*g(167)+1.d0*g(169) + & +1.d0*g(175)-1.d0*g(177) + f(133) = 1.d0*g(127)-1.d0*g(129)+1.d0*g(131)+1.d0*g(133) + & -1.d0*g(135)-1.d0*g(137) + f(134) = -2.d0*g(130)+2.d0*g(132)+2.d0*g(134)-2.d0*g(136) + f(135) = 1.d0*g(127)-1.d0*g(129)-1.d0*g(131)-1.d0*g(133) + & +1.d0*g(135)+1.d0*g(137) + f(136) = 1.d0*g(98)+1.d0*g(100)+1.d0*g(106)+1.d0*g(108) + f(137) = 3.d0*g(99)-3.d0*g(101)+1.d0*g(107)-1.d0*g(109) + f(138) = -3.d0*g(98)-3.d0*g(100)+1.d0*g(106)+1.d0*g(108) + f(139) = -1.d0*g(99)+1.d0*g(101)+1.d0*g(107)-1.d0*g(109) + f(140) = 1.d0*g(84)-1.d0*g(178)+1.d0*g(194) + f(141) = 1.d0*g(187)+1.d0*g(191)-1.d0*g(199)-1.d0*g(203) + f(142) = -1.d0*g(186)+1.d0*g(190)+1.d0*g(198)-1.d0*g(202) + f(143) = 1.d0*g(139)+1.d0*g(141)-1.d0*g(155)-1.d0*g(157) + f(144) = -1.d0*g(138)+1.d0*g(140)+1.d0*g(154)-1.d0*g(156) + f(145) = 1.d0*g(87)-1.d0*g(182)+1.d0*g(184)-1.d0*g(206) + & -1.d0*g(208) + f(146) = 2.d0*g(185)-2.d0*g(207)+2.d0*g(209) + f(147) = 1.d0*g(150)+1.d0*g(152)-1.d0*g(162)-1.d0*g(164) + & -1.d0*g(170)-1.d0*g(172) + f(148) = 1.d0*g(151)-1.d0*g(153)-1.d0*g(163)+1.d0*g(165) + & -1.d0*g(171)+1.d0*g(173) + f(149) = 1.d0*g(87)-1.d0*g(182)-1.d0*g(184)+1.d0*g(206) + & +1.d0*g(208) + f(150) = 1.d0*g(151)+1.d0*g(153)-1.d0*g(163)-1.d0*g(165) + & +1.d0*g(171)+1.d0*g(173) + f(151) = -1.d0*g(150)+1.d0*g(152)+1.d0*g(162)-1.d0*g(164) + & -1.d0*g(170)+1.d0*g(172) + f(152) = 1.d0*g(88)+1.d0*g(90)-1.d0*g(114)-1.d0*g(118) + & -1.d0*g(120) + f(153) = 2.d0*g(91)-2.d0*g(119)+2.d0*g(121) + f(154) = 1.d0*g(88)-1.d0*g(90)-1.d0*g(114)+1.d0*g(118) + & +1.d0*g(120) + f(155) = 1.d0*g(189)+1.d0*g(193)+1.d0*g(201)+1.d0*g(205) + f(156) = -1.d0*g(188)+1.d0*g(192)-3.d0*g(200)+3.d0*g(204) + f(157) = 1.d0*g(147)+1.d0*g(149)+1.d0*g(167)+1.d0*g(169) + & +1.d0*g(175)+1.d0*g(177) + f(158) = -1.d0*g(146)+1.d0*g(148)-1.d0*g(166)+1.d0*g(168) + & +1.d0*g(174)-1.d0*g(176) + f(159) = 1.d0*g(189)+1.d0*g(193)-3.d0*g(201)-3.d0*g(205) + f(160) = -2.d0*g(166)-2.d0*g(168)+2.d0*g(174)+2.d0*g(176) + f(161) = -2.d0*g(167)+2.d0*g(169)-2.d0*g(175)+2.d0*g(177) + f(162) = 1.d0*g(127)+1.d0*g(129)+1.d0*g(131)+1.d0*g(133) + & +1.d0*g(135)+1.d0*g(137) + f(163) = -2.d0*g(130)+2.d0*g(132)-2.d0*g(134)+2.d0*g(136) + f(164) = 1.d0*g(127)+1.d0*g(129)-1.d0*g(131)-1.d0*g(133) + & -1.d0*g(135)-1.d0*g(137) + f(165) = -1.d0*g(188)+1.d0*g(192)+1.d0*g(200)-1.d0*g(204) + f(166) = 1.d0*g(147)+1.d0*g(149)-1.d0*g(167)-1.d0*g(169) + & -1.d0*g(175)-1.d0*g(177) + f(167) = -1.d0*g(146)+1.d0*g(148)+1.d0*g(166)-1.d0*g(168) + & -1.d0*g(174)+1.d0*g(176) + f(168) = -1.d0*g(126)+1.d0*g(128)-1.d0*g(130)-1.d0*g(132) + & +1.d0*g(134)+1.d0*g(136) + f(169) = -2.d0*g(131)+2.d0*g(133)+2.d0*g(135)-2.d0*g(137) + f(170) = -1.d0*g(126)+1.d0*g(128)+1.d0*g(130)+1.d0*g(132) + & -1.d0*g(134)-1.d0*g(136) + f(171) = 1.d0*g(99)+1.d0*g(101)+1.d0*g(107)+1.d0*g(109) + f(172) = -3.d0*g(98)+3.d0*g(100)-1.d0*g(106)+1.d0*g(108) + f(173) = -3.d0*g(99)-3.d0*g(101)+1.d0*g(107)+1.d0*g(109) + f(174) = 1.d0*g(98)-1.d0*g(100)-1.d0*g(106)+1.d0*g(108) + f(175) = 1.d0*g(85)+1.d0*g(180)+1.d0*g(196) + f(176) = 2.d0*g(181)+4.d0*g(197) + f(177) = 1.d0*g(142)+1.d0*g(144)+1.d0*g(158)+1.d0*g(160) + f(178) = 1.d0*g(143)-1.d0*g(145)+1.d0*g(159)-1.d0*g(161) + f(179) = 2.d0*g(85)-6.d0*g(196) + f(180) = 1.d0*g(143)+1.d0*g(145)+3.d0*g(159)+3.d0*g(161) + f(181) = -1.d0*g(142)+1.d0*g(144)-3.d0*g(158)+3.d0*g(160) + f(182) = 1.d0*g(89)+1.d0*g(92)+1.d0*g(116)+1.d0*g(122) + & +1.d0*g(124) + f(183) = 2.d0*g(93)+2.d0*g(123)-2.d0*g(125) + f(184) = 1.d0*g(89)-1.d0*g(92)+1.d0*g(116)-1.d0*g(122) + & -1.d0*g(124) + f(185) = 2.d0*g(181)-4.d0*g(197) + f(186) = 1.d0*g(142)+1.d0*g(144)-3.d0*g(158)-3.d0*g(160) + f(187) = 1.d0*g(143)-1.d0*g(145)-3.d0*g(159)+3.d0*g(161) + f(188) = 2.d0*g(117)+2.d0*g(123)+2.d0*g(125) + f(189) = -4.d0*g(122)+4.d0*g(124) + f(190) = 2.d0*g(117)-2.d0*g(123)-2.d0*g(125) + f(191) = 1.d0*g(102)+1.d0*g(104)+1.d0*g(110)+1.d0*g(112) + f(192) = 3.d0*g(103)-3.d0*g(105)+1.d0*g(111)-1.d0*g(113) + f(193) = -3.d0*g(102)-3.d0*g(104)+1.d0*g(110)+1.d0*g(112) + f(194) = -1.d0*g(103)+1.d0*g(105)+1.d0*g(111)-1.d0*g(113) + f(195) = 1.d0*g(85)-1.d0*g(180)+1.d0*g(196) + f(196) = 1.d0*g(143)+1.d0*g(145)-1.d0*g(159)-1.d0*g(161) + f(197) = -1.d0*g(142)+1.d0*g(144)+1.d0*g(158)-1.d0*g(160) + f(198) = 1.d0*g(89)+1.d0*g(92)-1.d0*g(116)-1.d0*g(122) + & -1.d0*g(124) + f(199) = 2.d0*g(93)-2.d0*g(123)+2.d0*g(125) + f(200) = 1.d0*g(89)-1.d0*g(92)-1.d0*g(116)+1.d0*g(122) + & +1.d0*g(124) + f(201) = 1.d0*g(103)+1.d0*g(105)+1.d0*g(111)+1.d0*g(113) + f(202) = -3.d0*g(102)+3.d0*g(104)-1.d0*g(110)+1.d0*g(112) + f(203) = -3.d0*g(103)-3.d0*g(105)+1.d0*g(111)+1.d0*g(113) + f(204) = 1.d0*g(102)-1.d0*g(104)-1.d0*g(110)+1.d0*g(112) + f(205) = 1.d0*g(86)+1.d0*g(94)+1.d0*g(96) + f(206) = 4.d0*g(95)+2.d0*g(97) + f(207) = 2.d0*g(86)-6.d0*g(94) + f(208) = -4.d0*g(95)+2.d0*g(97) + f(209) = 1.d0*g(86)+1.d0*g(94)-1.d0*g(96) + return + end +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/bessjm.f b/OpticsJan2020/MLI_light_optics/Src/bessjm.f new file mode 100644 index 0000000..5e71940 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/bessjm.f @@ -0,0 +1,723 @@ +c*********************************************************************** +c +c Bessel functions of the first kind. +c D.T.Abell, Tech-X Corp., November 2003. +c +c Updated December 2005---improved rational approximations, obtained by +c comparison with Mathematica's high-precision Bessel function values. +c +c*********************************************************************** + subroutine dbessj0(x,bj0) +c Bessel function of the first kind, order zero: bj0 = J_0(x). + implicit none + double precision x,bj0 +c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! + double precision Pi,Pid4 + double precision ax,t,pp,qq +c +c coefficients for rational approximations + double precision rabj0an(11),rabj0ad(11),rabj0bn(11),rabj0bd(11) + double precision rabj0cn(11),rabj0cd(11),rabj0dn(11),rabj0dd(11) + double precision rabj0en(11),rabj0ed(11),rabj0fn( 7),rabj0fd( 7) + data rabj0an / + &+1.0000000000000000000050179699999091D+00, + &-8.8230193349303631019069286292273592D-02, + &-2.2778858233747603162266489897356056D-01, + &+2.0341718595179019764036039758709466D-02, + &+1.0311930796055483981361241333992624D-02, + &-9.6558198466558060525000633951901562D-04, + &-1.4534545971264389949915743465588711D-04, + &+1.5385739184044285945395365895073623D-05, + &+5.0024280550288686235912958144335425D-07, + &-8.1837015732913880463394834114513691D-08, + &+1.8402156332042362862773578704341447D-09/ + data rabj0ad / + &+1.0000000000000000000000000000000000D+00, + &-8.8230193349303629919583311940311153D-02, + &+2.2211417662523928303822343473518375D-02, + &-1.7158297421463074264424446502031107D-03, + &+2.3978521168201685670512690979806517D-04, + &-1.5942649098416680654142008778904110D-05, + &+1.5752199434140609397499317066559390D-06, + &-8.4437977811612729526150890484969979D-08, + &+6.0918476815384520168977485010843715D-09, + &-2.1081214567148162491668339094873657D-10, + &+9.5689922998775932286006136295490244D-12/ + data rabj0bn / + &+0.9999947618451229408378453732245815D+00, + &-2.1079067749100990034907737987252581D-01, + &-2.1153610058761303594734319673660807D-01, + &+4.7914960041618770111290430390100304D-02, + &+6.4925682382712033512704530646438245D-03, + &-2.1181715676820241543828289838391954D-03, + &+3.5262828624115159195904623163278898D-05, + &+2.8964640803552355496585442664205909D-05, + &-3.1467459340839512757355221349774376D-06, + &+1.3056612961826745813193969076704308D-07, + &-1.9723613039425622244289372840306964D-09/ + data rabj0bd / + &+1.0000000000000000000000000000000000D+00, + &-2.1080954250115548577070508093772022D-01, + &+3.8495956449617845060277310851005345D-02, + &-4.8215559602633320002172981719561965D-03, + &+5.1704518623798707902299649434725156D-04, + &-4.3816500419579022209215618337287690D-05, + &+3.0961318132620954195784080539882816D-06, + &-1.6985374380267480945014770381800044D-07, + &+7.1683418472403236347208318913158728D-09, + &-2.0143582141730917107139467960886491D-10, + &+3.2401851766762590203597072719481002D-12/ + data rabj0cn / + &+4.8896470117798136933960119243767237D-02, + &-1.9199232842235873850450795814434952D-03, + &-5.7862889184410290524315292285640746D-02, + &+3.9102508961576130540892154545854854D-02, + &-1.1494590155653841967222931097121521D-02, + &+1.8803934283457853100848553874229646D-03, + &-1.8640431669347982491495399716692452D-04, + &+1.1474374355794768767774947971846314D-05, + &-4.2933509072418537179570698396689563D-07, + &+8.9528106522417889070362524823241969D-09, + &-7.9882819654637042538953026938994769D-11/ + data rabj0cd / + &+1.0000000000000000000000000000000000D+00, + &-1.1329555327217814998913315706968691D+00, + &+3.2591109585817699371371552353553638D-01, + &-5.7426238664400627746092218763981592D-02, + &+6.9805158757947823161383120930805137D-03, + &-6.1938100100437024756343054169434183D-04, + &+4.0427188509225439620395057691850240D-05, + &-1.9137212931564333474744008597798173D-06, + &+6.2684456139853366202327362897514514D-08, + &-1.2847022551902166826121217722839446D-09, + &+1.2563046316660055826508853359682238D-11/ + data rabj0dn / + &-1.2855106884992982411556047079499048D-02, + &+7.3122100400657976523877937106051494D-02, + &-5.3227204991088052536112979278795060D-02, + &+1.7018649354405257105380788618114423D-02, + &-3.0419674749227155566039454550406450D-03, + &+3.3475526134474814407534241200383970D-04, + &-2.3600739767436000858506331588751560D-05, + &+1.0701657071023291919125855988389812D-06, + &-3.0207072100726981004102397058083471D-08, + &+4.8321242798880922243680861245207648D-10, + &-3.3474933906957231905826150510301703D-12/ + data rabj0dd / + &+1.0000000000000000000000000000000000D+00, + &-3.2944072183253369366766487533934724D-01, + &+6.0965775940009661518427458794047474D-02, + &-7.5921317989016470654981426275636095D-03, + &+6.8802934300040013792164096446792849D-04, + &-4.6422034672029920649858016846729019D-05, + &+2.3380523557789858162629933228290598D-06, + &-8.6093073725985170178907421779610271D-08, + &+2.2141159560680130851824587967869377D-09, + &-3.5909539384246578384084604881458476D-11, + &+2.8364122289958662381014742871402263D-13/ + data rabj0en / + &+3.5224646241387634580428630255239534D-01, + &-2.7856689678561711255883463632505246D-01, + &+9.3729467733125313886079046699370299D-02, + &-1.7776325167929891943907611157376352D-02, + &+2.1156292810051315475968635296554389D-03, + &-1.6585801993726409351607592862093892D-04, + &+8.7086646940913853360940919270539488D-06, + &-3.0345030581942515926188590998173107D-07, + &+6.7356307310329723356037410610211086D-09, + &-8.6230544824987840642736370362678861D-11, + &+4.8463254940494631096363486040475736D-13/ + data rabj0ed / + &+1.0000000000000000000000000000000000D+00, + &-3.9437749159126193952363812178419292D-01, + &+7.7581865230995871051567171336090776D-02, + &-9.6726853312945266401280401225401609D-03, + &+8.3352527419529980773115111930086124D-04, + &-5.1371247731535664030011300083139149D-05, + &+2.2801094464620980467671861325928996D-06, + &-7.1714183814137341630980676930651847D-08, + &+1.5275616049573480145724295285266087D-09, + &-1.9906555330977615027102660888016815D-11, + &+1.2106511741132039245923717952671393D-13/ + data rabj0fn / + &-9.4845363290573921489820379821276979D-02, + &+2.8600548026603177758882128713536768D-02, + &-3.5476668104961868720495540952881358D-03, + &+2.3179029870614323398028994082351304D-04, + &-8.4165980090902303831222302065086657D-06, + &+1.6111527211980360198505293917220034D-07, + &-1.2708319802262517343077780038561572D-09/ + data rabj0fd / + &+1.0000000000000000000000000000000000D+00, + &-2.6409647927463548120030732742120998D-01, + &+2.9860012401515139424647801546743694D-02, + &-1.8401803786971692142522329594649180D-03, + &+6.5061344201723819188622837380416900D-05, + &-1.2504130549754413803085326308427806D-06, + &+1.0221043546656880551547140513637591D-08/ +c +c compute constants + Pi=2.d0*dasin(1.d0) + Pid4=0.25d0*Pi +c +c J_0(x) is even in x, so we use |x| + ax=dabs(x) +c +c use approximation appropriate to value of x: +c range (0,4): rational approximation of J_0(x) +c range [4,8): rational approximation of J_0(x) +c range [8,12): rational approximation of +c J_0(x)-sqrt(2/(pi*x))*cos(x-pi/4) +c range [12,15): rational approximation of +c J_0(x)-sqrt(2/(pi*x))*cos(x-pi/4) +c range [15,20): rational approximation of +c J_0(x)-sqrt(2/(pi*x))*cos(x-pi/4) +c range [20,21): rational approximation of +c J_0(x)-sqrt(2/(pi*x))*cos(x-pi/4) +c range [21,infinity): Hankel's asymptotic expansion +c + if (ax.eq.0.d0) then + bj0=1.d0 + else if (ax.lt.4.d0) then + call ratappr(ax,rabj0an,11,rabj0ad,11,bj0) + else if (ax.lt.8.d0) then + call ratappr(ax,rabj0bn,11,rabj0bd,11,bj0) + else if (ax.lt.12.d0) then + call ratappr(ax,rabj0cn,11,rabj0cd,11,bj0) + bj0=bj0+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pid4) + else if (ax.lt.15.d0) then + call ratappr(ax,rabj0dn,11,rabj0dd,11,bj0) + bj0=bj0+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pid4) + else if (ax.lt.20.d0) then + call ratappr(ax,rabj0en,11,rabj0ed,11,bj0) + bj0=bj0+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pid4) + else if (ax.lt.21.d0) then + call ratappr(ax,rabj0fn,7,rabj0fd,7,bj0) + bj0=bj0+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pid4) + else + t=ax-Pid4 + call HankelPQ(0,ax,pp,qq) + bj0=dsqrt(2.d0/(Pi*ax))*(pp*dcos(t)-qq*dsin(t)) + end if +c + return + end +c +c*********************************************************************** + subroutine dbessj1(x,bj1) +c Bessel function of the first kind, order one: bj1 = J_1(x). + implicit none + double precision x,bj1 +c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! + double precision Pi,Pi3d4 + double precision ax,t,pp,qq,sgn +c +c coefficients for rational approximations + double precision rabj1an(11),rabj1ad(11),rabj1bn(11),rabj1bd(11) + double precision rabj1cn(11),rabj1cd(11),rabj1dn(11),rabj1dd(11) + double precision rabj1en(11),rabj1ed(11),rabj1fn( 7),rabj1fd( 7) + data rabj1an / + &+1.3024604716812625136575985066550351D-21, + &+4.9999999999999999971769784794883053D-01, + &-2.7021475700860125161066293561710086D-02, + &-5.3285436029298919304319635517409686D-02, + &+2.9036486061909128531536930260765731D-03, + &+1.5368020011789656151354698315581584D-03, + &-8.5478332785495533785549719799392937D-05, + &-1.6331599044080528432091645493034297D-05, + &+9.4299064900371993501932762368482883D-07, + &+5.9154546709636257637272914412136624D-08, + &-3.6255546773750573374562132519289283D-09/ + data rabj1ad / + &+1.0000000000000000000000000000000000D+00, + &-5.4042951401720270639311664158490582D-02, + &+1.8429127941402451229391111842933448D-02, + &-9.4807171283539186854248011429003618D-04, + &+1.6891166170994095677427891725156792D-04, + &-7.9919244887708660985328880211035730D-06, + &+9.7266277426087547516841459653563922D-07, + &-3.9171386712324223695277101066676514D-08, + &+3.4953779352137137722880097405620162D-09, + &-9.4952410837245606026644100187155292D-11, + &+5.8322537268273354279510519335860106D-12/ + data rabj1bn / + &-9.6126582523756719172017705951900558D-06, + &+5.0003360984690369391627958263960859D-01, + &-1.0135247312540184243931882056358513D-01, + &-4.2699412675762871627685186040163278D-02, + &+1.0044781754253024712239985871722026D-02, + &+4.5619419956893940475029673398794519D-04, + &-2.4129439668031979459455941679644064D-04, + &+1.6016153674406627617877625760637880D-05, + &+2.1027192253057843266329778129856985D-07, + &-5.0707491857311754051124557929869265D-08, + &+1.2617640048087146823185552850801499D-09/ + data rabj1bd / + &+1.0000000000000000000000000000000000D+00, + &-2.0259445599160107275639117333790023D-01, + &+3.9487894299400709115590578713486066D-02, + &-5.1537400250629675578459531550226451D-03, + &+5.9728087755675845907468596531647125D-04, + &-5.4444672786583878044335341357153240D-05, + &+4.2045344283680687094812530071394440D-06, + &-2.5132379473265406943787755252580057D-07, + &+1.1653755299489430413597047842196229D-08, + &-3.5807396467498635498582625262060225D-10, + &+6.3908259113402294201974014102826536D-12/ + data rabj1cn / + &+6.0371438405985520492273239641094956D-01, + &-5.9666583821895112063164472546734882D-01, + &+2.6919847622163680583156066524301151D-01, + &-8.7672496487695919979136196550569105D-02, + &+2.1837199551259834491158951946045927D-02, + &-3.7370808859808720836608377144630291D-03, + &+4.1191847569201912836238278879683956D-04, + &-2.8438941172117570987518632348259140D-05, + &+1.1844617605399366234082982326828033D-06, + &-2.7169771614418824284498359366424714D-08, + &+2.6343527972027239886711798412892213D-10/ + data rabj1cd / + &+1.0000000000000000000000000000000000D+00, + &-1.6514728561739773326127601166782867D-01, + &+6.5774300517547309014897346964600873D-02, + &-1.5049813610294697551699714956373893D-02, + &+2.4206604468666677360733935930230549D-03, + &-2.6756346375625205474234901528281541D-04, + &+2.1308038490017812103019561719321294D-05, + &-1.2019599969650507783017925415454145D-06, + &+4.6774324464657799887986331519504851D-08, + &-1.1350580273767823974385743078813233D-09, + &+1.3694521779905435685524410856631591D-11/ + data rabj1dn / + &+4.2467609762315442400693029865795040D-01, + &-4.3083142135486853345320553054798065D-01, + &+1.6788517206101123528239344102761124D-01, + &-3.3796177537444951633168287614832691D-02, + &+3.8795047097080453256087993331777921D-03, + &-2.5515818965006319689426544517178161D-04, + &+8.3162429845444497107382145316229273D-06, + &-3.1934959167383968458778078011436116D-09, + &-9.3164847018358148213745655834193359D-09, + &+2.8746610644386035220167446103613304D-10, + &-2.8944287034616799451929693172577113D-12/ + data rabj1dd / + &+1.0000000000000000000000000000000000D+00, + &-3.6698450390768612683634161865311059D-01, + &+7.4884143212216256039432139181885445D-02, + &-1.0221916096061684403865100654999128D-02, + &+1.0074562131863317846318355992966287D-03, + &-7.3374157538561828451182655688029948D-05, + &+3.9570224775017050301357112675936376D-06, + &-1.5479721151459859100101554063875132D-07, + &+4.1934519331039533720220137503174087D-09, + &-7.1015545891050449440380478375745093D-11, + &+5.7826067387808782775528298874601191D-13/ + data rabj1en / + &-1.0727178100039883419848523490500134D+00, + &+7.0928196569351176003941921501759760D-01, + &-2.0244112729254919784586618692965949D-01, + &+3.2919122179062670197381146685815259D-02, + &-3.3846375280985925074645334995793181D-03, + &+2.3035146427123168406922044131847732D-04, + &-1.0526097486773898355270589440366091D-05, + &+3.1928037549687904672248561941454213D-07, + &-6.1569502122571540023308673784804519D-09, + &+6.8176863727717420052494188810057293D-11, + &-3.2903939595120148107005430367355315D-13/ + data rabj1ed / + &+1.0000000000000000000000000000000000D+00, + &-4.1294556742055131913125357418100254D-01, + &+8.2841362688762866622842985663978347D-02, + &-1.0382391872762524304804231048703553D-02, + &+8.9012846103463523752825990646025319D-04, + &-5.4163294972308871532368229256156985D-05, + &+2.3586205292066095764629097580766725D-06, + &-7.2385925159801043526475622512870661D-08, + &+1.4965837356032315825582092468612243D-09, + &-1.8825359032178275136083152292764955D-11, + &+1.0969526078193747331991670408293388D-13/ + data rabj1fn / + &-9.8075828607639007338780275479940338D-03, + &+6.2042628485312133436957794665065060D-03, + &-1.1711582212026499092489447079398142D-03, + &+1.0277604893169514981220012453729818D-04, + &-4.6894343161978861506416373649349031D-06, + &+1.0823475910761513088113165275317871D-07, + &-1.0009149629230385757860595107751339D-09/ + data rabj1fd / + &+1.0000000000000000000000000000000000D+00, + &-2.7630107315667408326367307184433078D-01, + &+3.2444450997756793186658519895099244D-02, + &-2.0654832225935412940479575463019885D-03, + &+7.5094528449918628311451893661611736D-05, + &-1.4778957595810851829028146021523979D-06, + &+1.2314771882129871146918134466632580D-08/ +c +c compute constants + Pi=2.d0*dasin(1.d0) + Pi3d4=0.75d0*Pi +c +c J_1(x) is odd in x, so we note the sign and use |x| + sgn=1.d0 + if(x.lt.0.d0) sgn=-1.d0 + ax=dabs(x) +c +c use approximation appropriate to value of x: +c range (0,4): rational approximation of J_1(x) +c range [4,8): rational approximation of J_1(x) +c range [8,12): rational approximation of +c J_1(x)-sqrt(2/(pi*x))*cos(x-3pi/4) +c range [12,15): rational approximation of +c J_1(x)-sqrt(2/(pi*x))*cos(x-3pi/4) +c range [15,20): rational approximation of +c J_1(x)-sqrt(2/(pi*x))*cos(x-3pi/4) +c range [20,21): rational approximation of +c J_1(x)-sqrt(2/(pi*x))*cos(x-3pi/4) +c range [21,infinity): Hankel's asymptotic expansion +c + if (ax.eq.0.d0) then + bj1=0.d0 + else if (ax.lt.4.d0) then + call ratappr(ax,rabj1an,11,rabj1ad,11,bj1) + else if (ax.lt.8.d0) then + call ratappr(ax,rabj1bn,11,rabj1bd,11,bj1) + else if (ax.lt.12.d0) then + call ratappr(ax,rabj1cn,11,rabj1cd,11,bj1) + bj1=bj1+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pi3d4) + else if (ax.lt.15.d0) then + call ratappr(ax,rabj1dn,11,rabj1dd,11,bj1) + bj1=bj1+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pi3d4) + else if (ax.lt.20.d0) then + call ratappr(ax,rabj1en,11,rabj1ed,11,bj1) + bj1=bj1+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pi3d4) + else if (ax.lt.21.d0) then + call ratappr(ax,rabj1fn,7,rabj1fd,7,bj1) + bj1=bj1+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pi3d4) + else + t=ax-Pi3d4 + call HankelPQ(1,ax,pp,qq) + bj1=dsqrt(2.d0/(Pi*ax))*(pp*dcos(t)-qq*dsin(t)) + end if + bj1=sgn*bj1 +c + return + end +c +c*********************************************************************** + subroutine dbessjm(m,x,bjm) +c Bessel function of integer orders 0 through m-1: bjm(k) = J_{k-1}(x). + implicit none + integer m + double precision x + double precision bjm(*) +c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! + integer sgn,acc + integer kk,ms,k,p + double precision sd2,maxb,scl + double precision bj0,bj1,bjp,bjc,bjn + double precision ax,twovx,norm +c +c set sd2 to roughly sqr(# of desired significant digits) +c set maxb to renomalizing threshold + sd2=169.d0 + maxb=1.d+16 + scl=1.d0/maxb +c +c sanity check + if(m.le.0) then + write(6,*) ' ' + write(6,*) ' <*** ERROR: dbessjm ***> requires argument m > 0.' + write(6,*) ' Returning result array unchanged!' + return + end if +c +c note sgn(x) and use |x|; correct signs at end + sgn=1 + if(x.lt.0.d0) sgn=-1 + ax=dabs(x) + twovx=2.d0/ax +c +c clear result array + do kk=1,m + bjm(kk)=0.d0 + enddo +c +c treat x = 0 as a special case + if(ax.eq.0.d0) then + bjm(1)=1.d0 +c use upward recursion if |x| exceeds maximum order + else if(nint(ax).gt.m-1) then + call dbessj0(x,bj0) + bjm(1)=bj0 + if(m.eq.1) return + call dbessj1(x,bj1) + bjm(2)=bj1 + if(m.eq.2) return + bjp=bj0 + bjc=bj1 + do k=1,m-2 + bjn=k*twovx*bjc-bjp + bjp=bjc + bjc=bjn + bjm(k+2)=bjc + end do + else +c use downward recursion, starting well above desired maximum order +c make ms even, set alternating flag acc to accumulate even J_k's, +c and initialize variables + ms=2*((m+nint(dsqrt(sd2*(m+1))))/2) + acc=0 + norm=0.d0 + bjp=0.d0 + bjc=1.d0 + do k=ms,1,-1 + bjn=k*twovx*bjc-bjp + bjp=bjc + bjc=bjn +c if results get out of hand, renormalize them + if(dabs(bjc).gt.maxb) then + norm=scl*norm + bjp=scl*bjp + bjc=scl*bjc + do kk=1,m + bjm(kk)=scl*bjm(kk) + enddo + end if + if(k.le.m) bjm(k)=bjc + if(acc.eq.1) then + acc=0 + norm=norm+bjc + else + acc=1 + end if + end do +c recursion done; now normalize results using the identity +c 1 = J_0(x) + 2 J_2(x) + 2 J_4(x) + 2 J_6(x) + ... + norm=1.d0/(2.d0*norm-bjc) + do kk=1,m + bjm(kk)=norm*bjm(kk) + end do + end if +c +c correct signs + if(sgn.lt.0) then + do kk=2,m,2 + bjm(kk)=-bjm(kk) + end do + end if +c + return + end +c +c*********************************************************************** + subroutine HankelPQ(m,x,P,Q) +c Compute the asymptotic functions P(m,x) and Q(m,x) that appear in +c Hankel's expansions of the Bessel functions for large x. + implicit none + integer m + double precision x,P,Q +c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! + integer k,loopP,loopQ + double precision mu,x8,e,sq,t,tp0,tp1,tq0,tq1 + double precision eps +c +c set tolerance: +c this subroutine complains if the last term included in +c the asymptotic series for P or Q exceeds this value + eps=1.d-12 +c +c initialize computation + mu=4.d0*m*m + x8=8.d0*x + e=1.d0 + sq=e + t=(mu-sq)/x8 + tp0=1.d0 + tq0=t + P=tp0 + Q=tq0 + k=1 + loopP=1 + loopQ=1 +c +c main loop + 1 continue + tp1=-tp0*t + k=k+1 + e=e+2 + sq=sq+e + e=e+2 + sq=sq+e + t=(mu-sq)/(k*x8) + tp1=tp1*t + tq1=tp1 + k=k+1 + e=e+2 + sq=sq+e + e=e+2 + sq=sq+e + t=(mu-sq)/(k*x8) + tq1=tq1*t + if (loopP.eq.1.and.dabs(tp1).lt.dabs(tp0)) then + P=P+tp1 + tp0=tp1 + else + if(loopP.eq.1.and.dabs(tp0).gt.eps) then + write(6,10) eps + write(6,11) tp0 + endif + loopP=0 + end if + if (loopQ.eq.1.and.dabs(tq1).lt.dabs(tq0)) then + Q=Q+tq1 + tq0=tq1 + else + if(loopQ.eq.1.and.dabs(tq0).gt.eps) then + write(6,10) eps + write(6,12) tq0 + endif + loopQ=0 + end if + if(loopP.eq.1.or.loopQ.eq.1) go to 1 +c +c end main loop +c + 10 format('\n <*** WARNING: HankelPQ ***> tolerance ',1pe9.3) + 11 format(' not reached in HankelP series: last term = ',e10.3,'.') + 12 format(' not reached in HankelQ series: last term = ',e10.3,'.') +c + return + end +c +c*********************************************************************** + double precision function HankelP(m,x) +c Compute the asymptotic function P(m,x) that appears in Hankel's +c expansions of the Bessel functions for large x. + implicit none + integer m + double precision x +c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! + integer k2,loop + double precision mu,x82,t0,t1,e,sq,P +c +c initialize computation + mu=4.d0*m*m + x82=(8.d0*x)**2 + k2=2 + e=1 + sq=e + t0=1.d0 + P=t0 + loop=1 +c +c main loop + 1 continue + t1=-t0/((k2-1)*k2*x82) + t1=t1*(mu-sq) + e=e+2 + sq=sq+e + e=e+2 + sq=sq+e + t1=t1*(mu-sq) + if (dabs(t1).le.dabs(t0)) then + P=P+t1 + t0=t1 + k2=k2+2 + e=e+2 + sq=sq+e + e=e+2 + sq=sq+e + else + loop=0 + end if + if(loop.eq.1) go to 1 +c +c end main loop +c + HankelP=P + return + end +c +c*********************************************************************** + double precision function HankelQ(m,x) +c Compute the asymptotic function Q(m,x) that appears in Hankel's +c expansions of the Bessel functions for large x. + implicit none + integer m + double precision x +c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! + integer k2,loop + double precision mu,x82,t0,t1,e,sq,Q +c +c initialize computation + mu=4.d0*m*m + x82=(8.d0*x)**2 + k2=2 + e=1 + sq=e + t0=(mu-sq)/x82 + Q=t0 + loop=1 +c +c main loop + 1 continue + t1=-t0/(k2*(k2+1)*x82) + e=e+2 + sq=sq+e + e=e+2 + sq=sq+e + t1=t1*(mu-sq) + e=e+2 + sq=sq+e + e=e+2 + sq=sq+e + t1=t1*(mu-sq) + if (dabs(t1).le.dabs(t0)) then + Q=Q+t1 + t0=t1 + k2=k2+2 + else + loop=0 + end if + if(loop.eq.1) go to 1 +c +c end main loop +c + HankelQ=Q + return + end +c +c*********************************************************************** + subroutine ratappr(x,cfn,nn,cfd,nd,r) +c Compute the rational approximation for a function r(x)=rn(x)/rd(x), +c where the polynomials rn(x) and rd(x) are defined respectively by the +c nn coefficients in cfn and the nd coefficients in cfd. The +c coefficients must be listed in order of increasing powers. Thus, for +c the numerator, cfn(1) is the constant term, and cfn(nn) is the +c coefficient of the highest order term. The polynomials are computed +c using Horner's method. Return the result in r. + implicit none + integer nn,nd + double precision x,r + double precision cfn(*),cfd(*) +c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! + integer j + double precision rn,rd +c +c compute numerator + rn=cfn(nn) + do j=nn-1,1,-1 + rn=cfn(j)+rn*x + end do +c compute denominator + rd=cfd(nd) + do j=nn-1,1,-1 + rd=cfd(j)+rd*x + end do +c compute ratio + r=rn/rd +c + return + end +c +c*********************************************************************** diff --git a/OpticsJan2020/MLI_light_optics/Src/book.f b/OpticsJan2020/MLI_light_optics/Src/book.f new file mode 100755 index 0000000..abb75d1 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/book.f @@ -0,0 +1,1032 @@ +************************************************************************ +* header: BOOKKEEP +* Index manipulation, table creation, block data, startup routines +************************************************************************ +c + subroutine binom +c +c computes the table of the binomial coefficients +c + implicit double precision (a-h,o-z) + integer bin(24,20) + common /bin/ bin + do 1 i=1,20 + bin(i,1)=i + do 1 k=2,20 + if (i-k) 2,3,4 + 2 bin(i,k)=0 + go to 1 + 3 bin(i,k)=1 + go to 1 + 4 ip=i-1 + kp=k-1 + bin(i,k)=bin(ip,kp)+bin(ip,k) + 1 continue + return + end +c + integer function ndexn(num,j) +c calculates the index of the long vector (dimension 209) +c for a given set of short indices that indicate a power of +c each variable, stored in the array j. +c This function is a combination of DRD's subroutines +c 'indice' and 'binom' in Marylie. +c Written by Liam Healy, June 8, 1984. +c +c 'bin(i,k)' is the binomial coefficient i select k (i>k) +cryne integer bin(24,20),j(6) + integer bin(24,20),j(*) + common/bin/ bin +c calculate the index + n=j(num) + m=j(num)-1 + do 100 i=2,num + ib=num+1-i + m=m+j(ib) + ib=m+i + n=n+bin(ib,i) + 100 continue + ndexn=n + return + end +c + integer function ndex(j) + integer j(6) + ndex=ndexn(6,j) +c + return + end +c +*********************************************************************** +c + subroutine setup +c + use lieaparam, only : monoms + include 'impli.inc' + include 'ind.inc' +cryne 5/3/2006 include 'files.inc' +cryne 5/3/2006 include 'time.inc' +c +c initialize commons (other than those in block data's) + imaxi = 6 + call initia +c +c initialize lie algebraic things + call binom + call tables + call init +c + return + end +c +*********************************************************************** +c + subroutine cpyrt +c + use parallel + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' +cryne 5/3/2006 include 'time.inc' + include 'ind.inc' +c +c write out copyright message at terminal +c + if(idproc.eq.0)then + write(jof,90) + 90 format( + &'***************************************************************', + &/, + &'* MARYLIE/IMPACT *', + &/, + &'* Parallel Lie Algebraic Beam Dynamics Code with Space Charge *', + &/, + &'* Last modified May 22, 2006 08:20PDT *', + &/, + &'* MaryLie copyright 1987, Alex J. Dragt, U. Maryland *', + &/, + &'* IMPACT copyright 2002, Robert D. Ryne, U. California *', + &/, + &'***************************************************************') + endif +c + return + end +c +****************************************************************************** +c + subroutine initia +c----------------------------------------------------------------------- +c This routine initializes some constants in common blocks, which are +c not initialized in block data +c +c Petra Schuett 10/30/87 +c Alex Dragt 6/20/88 +c----------------------------------------------------------------------- +c +cryne 7/23/2002 this is here because of the speed of light. fix later. + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' + include 'frnt.inc' +c +c set up constants +c +c pi = 3.14159265358979323846264d0 + pi = 4.d0*atan(1.d0) + pi180 = pi/180.d0 + twopi = 2.d0*pi + c = 2.99792458d+08 +c +c set up default values for cfbd fringe field parameters +c + cfbgap=0.d0 + cfblk1=.5 + cfbtk1=.5 +c + return + end +c +*********************************************************************** +c + subroutine tables +c This subroutine creates two tables used in bookkeeping: +c 1) expon(ind,psv) is the exponent of phase space variable +c 'psv' (1 to 6) for monomial index 'ind' (1 to top) +c 2) vblist(ind,vnum) is the variable list for each +c monomial index number 'ind' (1 to top). For nth +c order terms, there will be n non-zero variable +c numbers. +c For example, monomial number 109 is X.PX.PX.Pt. +c Thus, expon(109,1to6)=1,2,0,0,0,1 and vblist(109,1to4)=1,2,2,6. +c This subroutine was written by Liam Healy on June 20,1984, +c and is a replacement for Dave Douglas's subroutines 'addss' and 'sht' +c + use lieaparam, only : monoms,monom1 + implicit none +c ------Variables produced by subroutine------- + include 'expon.inc' + include 'vblist.inc' + include 'prodex.inc' + include 'order.inc' + include 'maxcat.inc' + include 'iprod.inc' +c ------Variables used internally-------- +c carry = carry amount from j(6) in counting for expon +c ind = monomial number index +c lnzj = last non-zero j +c psv = phase space variable 1...6 corresponds to X...Pt +c vnum = current postion for writing variable number in 'vblist' + integer carry,ind,lnzj,psv,vnum +c ord, pwr = order, exponent + integer ord,pwr +c indpr= index for product + integer indpr +c declaration for the integer function ndex(j) + integer ndex +c other needed integers + integer k,ind1,ind2 +c + include 'lims.inc' +c j = array of exponents + integer j(6) + save j + data j/6*0/ +c +c----------------------------------------------------- +c Sequentially create exponent table & calculate order & rearrangements + do 150 ind=1,topcat + carry=j(6) + j(6)=0 + lnzj=0 + do 100 psv=1,5 + if (j(psv).gt.0) lnzj=psv + 100 continue + if (lnzj.gt.0) j(lnzj)=j(lnzj)-1 + j(lnzj+1)=j(lnzj+1)+1+carry + ord=0 + do 120 psv=1,6 + pwr=j(psv) + expon(psv,ind)=pwr + ord=ord+pwr + 120 continue + order(ind)=ord +c +c------------------------------------------------------- +c Create variable list table, using exponent table + vnum=1 + do 220 psv=1,6 + do 200 k=1,j(psv) + vblist(vnum,ind)=psv + vnum=vnum+1 + 200 continue + 220 continue + 150 continue +c +c--------------------------------------------------------- +c Create product table, based on the idea of F. Neri and the +c method of C. Iselin. + do 380 psv=1,6 + 380 prodex(psv,0)=psv + do 300 ord=1,ordcat-1 + do 320 psv=1,6 + indpr=bottom(ord+1) + do 340 ind=bottom(ord),top(ord) + 360 if (expon(psv,indpr).eq.0) then + indpr=indpr+1 + if (indpr.le.top(ord+1)) goto 360 + endif + prodex(psv,ind)=indpr + indpr=indpr+1 + 340 continue + 320 continue + 300 continue +c +c Create table of products + do 401 ind1 = 1,monom1 + do 402 ind2 = 1,monom1 + do 403 psv = 1,6 + j(psv) = expon(psv,ind1)+expon(psv,ind2) + 403 continue + iprod(ind1,ind2) = ndex(j) + 402 continue + 401 continue + iprod(0,0) = 0 + do 500 ind1 = 1,monom1 + iprod(0,ind1) = ind1 + iprod(ind1,0) = ind1 + 500 continue +c +c--------------------------------------------------------- +cryne 6/21/2002 (based on ryne 8/26/2001) +c Create sum tables needed to convert maps from one set of +c scale variables to another. +cryne 08/26/2001 + do 600 ind=1,topcat + nxp135(ind)=expon(1,ind)+expon(3,ind)+expon(5,ind) -1 + nxp246(ind)=expon(2,ind)+expon(4,ind)+expon(6,ind) -1 + nxp13(ind)=expon(1,ind)+expon(3,ind) -1 + nxp24(ind)=expon(2,ind)+expon(4,ind) -1 +!cryne===== 12/21/2004 actually what is needed is: +! n1+n3+n6-1 for scale length [use nxp13+nxp6] +! n2+n4+n6-1 for scale momentum [use nxp24+nxp6] +! n6-n5 for scale angular freq [use nxp6-nxp5] +!!!!!!nxp5(ind)=expon(5,ind) -1 +!!!!!!nxp6(ind)=expon(6,ind) -1 +!cryne===== + nxp5(ind)=expon(5,ind) + nxp6(ind)=expon(6,ind) + 600 continue +c + return + end +c +*********************************************************************** +c + subroutine init +c +c produces the arrays index1 and index2 +c used to compute vector of monomials +c as follows: +c do 1 k = 7,length +c vector(k) = vector(index1(k))*vector(index2(k)) +c 1 continue +c the monomial of address k is product of +c monomial index1(k) and index2(k) +c +c also produces array pv(k), containing +c the sum +c 2 +c j(1)+j(2)*16+j(3)*16 +... +c +c of the exponents corresponding to monomial k. +c +c +c ind31 and ind32 are the equivalent of index1() and index2() +c for monomials in three variables. +c the monomials in 3 varibles are numbered in the same way the +c monomials in 6 are, except the start from 2, not from 1. +c 1 is used for the zeroth order monomial. +c this convention is use in ind31(), ind32(), ja3(), jv3() and ip- +c indecn(3,**,*), returns an index that starts from 1 for a first +c monomial so a 1 has to be added to the index returned by indecn( +c to convert the index to the convention used in the arrays built +c jv3() is the equivalent of jv() for third order monomials. +c ja3(i,n3) contains the ith exponent (i=1,3) of the +c n3 monomial in 3 varibles. +c +c Written by F. Neri, Spring 1985 +c + use lieaparam, only : monoms + include 'impli.inc' + include 'ind.inc' + include 'pq.inc' + include 'ind3.inc' + include 'ja3.inc' +c + integer j(6),j1(6),j2(6) + integer jp(3),jq(3) +c + call length + do 100 i1=0,imaxi + do 100 i2=0,imaxi-i1 + do 100 i3=0,imaxi-i1-i2 + j(1)=i1 + j(2)=i2 + j(3)=i3 + n3 = ndexn(3,j) + n3=n3+1 + jv3(n3)=0 + do 306 k=1,3 + jv3(n3)=jv3(n3)+j(k)*(16**(k-1)) + ja3(k,n3) = j(k) + 306 continue + ior3=i1+i2+i3 + ii2=ior3/2 + ii1=ior3-ii2 + itot=0 + do 2 k=1,3 + j1(k)=0 + j2(k)=0 + 2 continue + do 3 i=1,3 + j1(i)=j(i) + itot=itot+j(i) + if(itot-ii1) 3,31,32 + 3 continue + 32 continue + j1(i)=j1(i)+ii1-itot + j2(i)=itot-ii1 + 31 continue + if(i-3) 303,304,304 + 303 continue + do 305 ii=i+1,3 + j2(ii)=j(ii) + 305 continue + 304 continue + n1 = ndexn(3,j1) + n2 = ndexn(3,j2) + ind31(n3)=n1+1 + ind32(n3)=n2+1 + do 100 i4=0,imaxi-i1-i2-i3 + do 100 i5=0,imaxi-i1-i2-i3-i4 + do 100 i6=0,imaxi-i1-i2-i3-i4-i5 + iorder=i1+i2+i3+i4+i5+i6 + if(iorder-imaxi) 101,101,100 + 101 continue + if (iorder) 100,100,107 + 107 continue + j(1)=i1 + j(2)=i2 + j(3)=i3 + j(4)=i4 + j(5)=i5 + j(6)=i6 + jp(1)=j(2) + jp(2)=j(4) + jp(3)=j(6) + jq(1)=j(1) + jq(2)=j(3) + jq(3)=j(5) + n = ndex(j) + n1 = ndexn(3,jp) + n2 = ndexn(3,jq) + ip(n)=n1+1 + iq(n)=n2+1 + jv(n) = 0 + do 33 k = 1,6 + jv(n) = jv(n)+j(k)*(16**(k-1)) + 33 continue + ii2=iorder/2 + ii1=iorder-ii2 + itot=0 + do 55 k = 1,6 + j1(k) = 0 + j2(k) = 0 + 55 continue + do 200 i=1,6 + j1(i)=j(i) + itot=itot+j(i) + if(itot-ii1) 200,111,112 + 200 continue + 112 continue + j1(i)=j(i)+ii1-itot + j2(i)=itot-ii1 + 111 continue + if(i-6) 113,114,114 + 113 continue + do 115 ii=i+1,6 + j2(ii)=j(ii) + 115 continue + 114 continue + n1 = ndex(j1) + n2 = ndex(j2) + index1(n)=n1 + index2(n)=n2 + 100 continue + return + end +c +*********************************************************************** +c + subroutine length +c Written by F. Neri, Spring 1985 + use lieaparam, only : monoms + include 'impli.inc' + include 'len.inc' + include 'len3.inc' + include 'ind.inc' + dimension j(6),j3(3) +c + do 100 k =1,6 + 100 j(k) = 0 + do 103 k = 1,3 + 103 j3(k)=0 + do 200 k = 1, imaxi + j(6) = k + j3(3)=k + n=ndex(j) + len(k) = ndex(j) + len3(k) = ndexn(3,j3) + 200 continue + return + end +c +*********************************************************************** +c + block data matrcs +c Written by D. Douglas, ca 1982 +c implicit none + include 'id.inc' + include 'symp.inc' + data ident/1.,6*0.,1.,6*0.,1.,6*0.,1.,6*0.,1.,6*0.,1./ + data jm/0.,-1.,4*0.,1.,8*0.,-1.,4*0.,1.,8*0.,-1.,4*0.,1.,0./ + end +c +*********************************************************************** +c + block data spurex +c Written by F. Neri, Summer 1986 + use lieaparam, only : monoms +c implicit none + include 'sr.inc' +c + data (srexp(i,1),i=0,2)/0,0,0/ + data (srexp(i,2),i=0,2)/1,1,0/ + data (srexp(i,3),i=0,2)/0,0,0/ + data (srexp(i,4),i=0,2)/1,0,1/ + data (srexp(i,5),i=0,2)/0,0,0/ + data (srexp(i,6),i=0,2)/0,0,0/ + data (srexp(i,7),i=0,2)/0,0,0/ + data (srexp(i,8),i=0,2)/0,0,0/ + data (srexp(i,9),i=0,2)/0,0,0/ + data (srexp(i,10),i=0,2)/1,1,0/ + data (srexp(i,11),i=0,2)/0,0,0/ + data (srexp(i,12),i=0,2)/1,0,1/ + data (srexp(i,13),i=0,2)/0,0,0/ + data (srexp(i,14),i=0,2)/1,2,0/ + data (srexp(i,15),i=0,2)/0,0,0/ + data (srexp(i,16),i=0,2)/1,0,2/ + data (srexp(i,17),i=0,2)/0,0,0/ + data (srexp(i,18),i=0,2)/1,1,1/ + data (srexp(i,19),i=0,2)/0,0,0/ + data (srexp(i,20),i=0,2)/1,1,-1/ + data (srexp(i,21),i=0,2)/0,0,0/ + data (srexp(i,22),i=0,2)/0,0,0/ + data (srexp(i,23),i=0,2)/0,0,0/ + data (srexp(i,24),i=0,2)/0,0,0/ + data (srexp(i,25),i=0,2)/0,0,0/ + data (srexp(i,26),i=0,2)/0,0,0/ + data (srexp(i,27),i=0,2)/0,0,0/ + data (srexp(i,28),i=0,2)/0,0,0/ + data (srexp(i,29),i=0,2)/0,0,0/ + data (srexp(i,30),i=0,2)/0,0,0/ + data (srexp(i,31),i=0,2)/1,1,0/ + data (srexp(i,32),i=0,2)/0,0,0/ + data (srexp(i,33),i=0,2)/1,0,1/ + data (srexp(i,34),i=0,2)/0,0,0/ + data (srexp(i,35),i=0,2)/1,2,0/ + data (srexp(i,36),i=0,2)/0,0,0/ + data (srexp(i,37),i=0,2)/1,0,2/ + data (srexp(i,38),i=0,2)/0,0,0/ + data (srexp(i,39),i=0,2)/1,1,1/ + data (srexp(i,40),i=0,2)/0,0,0/ + data (srexp(i,41),i=0,2)/1,1,-1/ + data (srexp(i,42),i=0,2)/0,0,0/ + data (srexp(i,43),i=0,2)/1,1,0/ + data (srexp(i,44),i=0,2)/0,0,0/ + data (srexp(i,45),i=0,2)/1,0,1/ + data (srexp(i,46),i=0,2)/0,0,0/ + data (srexp(i,47),i=0,2)/1,1,0/ + data (srexp(i,48),i=0,2)/0,0,0/ + data (srexp(i,49),i=0,2)/1,0,1/ + data (srexp(i,50),i=0,2)/0,0,0/ + data (srexp(i,51),i=0,2)/1,3,0/ + data (srexp(i,52),i=0,2)/0,0,0/ + data (srexp(i,53),i=0,2)/1,0,3/ + data (srexp(i,54),i=0,2)/0,0,0/ + data (srexp(i,55),i=0,2)/1,2,1/ + data (srexp(i,56),i=0,2)/0,0,0/ + data (srexp(i,57),i=0,2)/1,1,2/ + data (srexp(i,58),i=0,2)/0,0,0/ + data (srexp(i,59),i=0,2)/1,2,-1/ + data (srexp(i,60),i=0,2)/0,0,0/ + data (srexp(i,61),i=0,2)/1,-1,2/ + data (srexp(i,62),i=0,2)/0,0,0/ + data (srexp(i,63),i=0,2)/0,0,0/ + data (srexp(i,64),i=0,2)/0,0,0/ + data (srexp(i,65),i=0,2)/0,0,0/ + data (srexp(i,66),i=0,2)/0,0,0/ + data (srexp(i,67),i=0,2)/0,0,0/ + data (srexp(i,68),i=0,2)/0,0,0/ + data (srexp(i,69),i=0,2)/0,0,0/ + data (srexp(i,70),i=0,2)/0,0,0/ + data (srexp(i,71),i=0,2)/0,0,0/ + data (srexp(i,72),i=0,2)/0,0,0/ + data (srexp(i,73),i=0,2)/0,0,0/ + data (srexp(i,74),i=0,2)/0,0,0/ + data (srexp(i,75),i=0,2)/0,0,0/ + data (srexp(i,76),i=0,2)/0,0,0/ + data (srexp(i,77),i=0,2)/0,0,0/ + data (srexp(i,78),i=0,2)/0,0,0/ + data (srexp(i,79),i=0,2)/0,0,0/ + data (srexp(i,80),i=0,2)/0,0,0/ + data (srexp(i,81),i=0,2)/0,0,0/ + data (srexp(i,82),i=0,2)/0,0,0/ + data (srexp(i,83),i=0,2)/0,0,0/ + data (srexp(i,84),i=0,2)/0,0,0/ + data (srexp(i,85),i=0,2)/0,0,0/ + data (srexp(i,86),i=0,2)/0,0,0/ + data (srexp(i,87),i=0,2)/0,0,0/ + data (srexp(i,88),i=0,2)/0,0,0/ + data (srexp(i,89),i=0,2)/0,0,0/ + data (srexp(i,90),i=0,2)/1,1,0/ + data (srexp(i,91),i=0,2)/0,0,0/ + data (srexp(i,92),i=0,2)/1,0,1/ + data (srexp(i,93),i=0,2)/0,0,0/ + data (srexp(i,94),i=0,2)/1,2,0/ + data (srexp(i,95),i=0,2)/0,0,0/ + data (srexp(i,96),i=0,2)/1,0,2/ + data (srexp(i,97),i=0,2)/0,0,0/ + data (srexp(i,98),i=0,2)/1,1,1/ + data (srexp(i,99),i=0,2)/0,0,0/ + data (srexp(i,100),i=0,2)/1,1,-1/ + data (srexp(i,101),i=0,2)/0,0,0/ + data (srexp(i,102),i=0,2)/1,1,0/ + data (srexp(i,103),i=0,2)/0,0,0/ + data (srexp(i,104),i=0,2)/1,0,1/ + data (srexp(i,105),i=0,2)/0,0,0/ + data (srexp(i,106),i=0,2)/1,1,0/ + data (srexp(i,107),i=0,2)/0,0,0/ + data (srexp(i,108),i=0,2)/1,0,1/ + data (srexp(i,109),i=0,2)/0,0,0/ + data (srexp(i,110),i=0,2)/1,3,0/ + data (srexp(i,111),i=0,2)/0,0,0/ + data (srexp(i,112),i=0,2)/1,0,3/ + data (srexp(i,113),i=0,2)/0,0,0/ + data (srexp(i,114),i=0,2)/1,2,1/ + data (srexp(i,115),i=0,2)/0,0,0/ + data (srexp(i,116),i=0,2)/1,1,2/ + data (srexp(i,117),i=0,2)/0,0,0/ + data (srexp(i,118),i=0,2)/1,2,-1/ + data (srexp(i,119),i=0,2)/0,0,0/ + data (srexp(i,120),i=0,2)/1,-1,2/ + data (srexp(i,121),i=0,2)/0,0,0/ + data (srexp(i,122),i=0,2)/1,2,0/ + data (srexp(i,123),i=0,2)/0,0,0/ + data (srexp(i,124),i=0,2)/1,0,2/ + data (srexp(i,125),i=0,2)/0,0,0/ + data (srexp(i,126),i=0,2)/1,2,0/ + data (srexp(i,127),i=0,2)/0,0,0/ + data (srexp(i,128),i=0,2)/1,0,2/ + data (srexp(i,129),i=0,2)/0,0,0/ + data (srexp(i,130),i=0,2)/1,1,1/ + data (srexp(i,131),i=0,2)/0,0,0/ + data (srexp(i,132),i=0,2)/1,1,1/ + data (srexp(i,133),i=0,2)/0,0,0/ + data (srexp(i,134),i=0,2)/1,1,-1/ + data (srexp(i,135),i=0,2)/0,0,0/ + data (srexp(i,136),i=0,2)/1,-1,1/ + data (srexp(i,137),i=0,2)/0,0,0/ + data (srexp(i,138),i=0,2)/1,4,0/ + data (srexp(i,139),i=0,2)/0,0,0/ + data (srexp(i,140),i=0,2)/1,0,4/ + data (srexp(i,141),i=0,2)/0,0,0/ + data (srexp(i,142),i=0,2)/1,3,1/ + data (srexp(i,143),i=0,2)/0,0,0/ + data (srexp(i,144),i=0,2)/1,1,3/ + data (srexp(i,145),i=0,2)/0,0,0/ + data (srexp(i,146),i=0,2)/1,3,-1/ + data (srexp(i,147),i=0,2)/0,0,0/ + data (srexp(i,148),i=0,2)/1,-1,3/ + data (srexp(i,149),i=0,2)/0,0,0/ + data (srexp(i,150),i=0,2)/1,2,2/ + data (srexp(i,151),i=0,2)/0,0,0/ + data (srexp(i,152),i=0,2)/1,2,-2/ + data (srexp(i,153),i=0,2)/0,0,0/ + data (srexp(i,154),i=0,2)/0,0,0/ + data (srexp(i,155),i=0,2)/0,0,0/ + data (srexp(i,156),i=0,2)/0,0,0/ + data (srexp(i,157),i=0,2)/0,0,0/ + data (srexp(i,158),i=0,2)/0,0,0/ + data (srexp(i,159),i=0,2)/0,0,0/ + data (srexp(i,160),i=0,2)/0,0,0/ + data (srexp(i,161),i=0,2)/0,0,0/ + data (srexp(i,162),i=0,2)/0,0,0/ + data (srexp(i,163),i=0,2)/0,0,0/ + data (srexp(i,164),i=0,2)/0,0,0/ + data (srexp(i,165),i=0,2)/0,0,0/ + data (srexp(i,166),i=0,2)/0,0,0/ + data (srexp(i,167),i=0,2)/0,0,0/ + data (srexp(i,168),i=0,2)/0,0,0/ + data (srexp(i,169),i=0,2)/0,0,0/ + data (srexp(i,170),i=0,2)/0,0,0/ + data (srexp(i,171),i=0,2)/0,0,0/ + data (srexp(i,172),i=0,2)/0,0,0/ + data (srexp(i,173),i=0,2)/0,0,0/ + data (srexp(i,174),i=0,2)/0,0,0/ + data (srexp(i,175),i=0,2)/0,0,0/ + data (srexp(i,176),i=0,2)/0,0,0/ + data (srexp(i,177),i=0,2)/0,0,0/ + data (srexp(i,178),i=0,2)/0,0,0/ + data (srexp(i,179),i=0,2)/0,0,0/ + data (srexp(i,180),i=0,2)/0,0,0/ + data (srexp(i,181),i=0,2)/0,0,0/ + data (srexp(i,182),i=0,2)/0,0,0/ + data (srexp(i,183),i=0,2)/0,0,0/ + data (srexp(i,184),i=0,2)/0,0,0/ + data (srexp(i,185),i=0,2)/0,0,0/ + data (srexp(i,186),i=0,2)/0,0,0/ + data (srexp(i,187),i=0,2)/0,0,0/ + data (srexp(i,188),i=0,2)/0,0,0/ + data (srexp(i,189),i=0,2)/0,0,0/ + data (srexp(i,190),i=0,2)/0,0,0/ + data (srexp(i,191),i=0,2)/0,0,0/ + data (srexp(i,192),i=0,2)/0,0,0/ + data (srexp(i,193),i=0,2)/0,0,0/ + data (srexp(i,194),i=0,2)/0,0,0/ + data (srexp(i,195),i=0,2)/0,0,0/ + data (srexp(i,196),i=0,2)/0,0,0/ + data (srexp(i,197),i=0,2)/0,0,0/ + data (srexp(i,198),i=0,2)/0,0,0/ + data (srexp(i,199),i=0,2)/0,0,0/ + data (srexp(i,200),i=0,2)/0,0,0/ + data (srexp(i,201),i=0,2)/0,0,0/ + data (srexp(i,202),i=0,2)/0,0,0/ + data (srexp(i,203),i=0,2)/0,0,0/ + data (srexp(i,204),i=0,2)/0,0,0/ + data (srexp(i,205),i=0,2)/0,0,0/ + data (srexp(i,206),i=0,2)/0,0,0/ + data (srexp(i,207),i=0,2)/0,0,0/ + data (srexp(i,208),i=0,2)/0,0,0/ + data (srexp(i,209),i=0,2)/0,0,0/ + end +c +*************************************************************** +c + block data dpurex +c Written by F. Neri, Summer 1986 + use lieaparam, only : monoms +c implicit none + include 'dr.inc' +c + data (drexp(i,1),i=0,3)/1,1,0,0/ + data (drexp(i,2),i=0,3)/0,0,0,0/ + data (drexp(i,3),i=0,3)/1,0,1,0/ + data (drexp(i,4),i=0,3)/0,0,0,0/ + data (drexp(i,5),i=0,3)/1,0,0,1/ + data (drexp(i,6),i=0,3)/0,0,0,0/ + data (drexp(i,7),i=0,3)/0,0,0,0/ + data (drexp(i,8),i=0,3)/0,0,0,0/ + data (drexp(i,9),i=0,3)/0,0,0,0/ + data (drexp(i,10),i=0,3)/1,0,0,2/ + data (drexp(i,11),i=0,3)/0,0,0,0/ + data (drexp(i,12),i=0,3)/1,1,0,1/ + data (drexp(i,13),i=0,3)/0,0,0,0/ + data (drexp(i,14),i=0,3)/1,1,0,-1/ + data (drexp(i,15),i=0,3)/0,0,0,0/ + data (drexp(i,16),i=0,3)/1,0,1,1/ + data (drexp(i,17),i=0,3)/0,0,0,0/ + data (drexp(i,18),i=0,3)/1,0,1,-1/ + data (drexp(i,19),i=0,3)/0,0,0,0/ + data (drexp(i,20),i=0,3)/1,2,0,0/ + data (drexp(i,21),i=0,3)/0,0,0,0/ + data (drexp(i,22),i=0,3)/1,0,2,0/ + data (drexp(i,23),i=0,3)/0,0,0,0/ + data (drexp(i,24),i=0,3)/1,1,1,0/ + data (drexp(i,25),i=0,3)/0,0,0,0/ + data (drexp(i,26),i=0,3)/1,1,-1,0/ + data (drexp(i,27),i=0,3)/0,0,0,0/ + data (drexp(i,28),i=0,3)/1,0,0,1/ + data (drexp(i,29),i=0,3)/0,0,0,0/ + data (drexp(i,30),i=0,3)/1,0,0,1/ + data (drexp(i,31),i=0,3)/0,0,0,0/ + data (drexp(i,32),i=0,3)/1,0,0,3/ + data (drexp(i,33),i=0,3)/0,0,0,0/ + data (drexp(i,34),i=0,3)/1,0,0,1/ + data (drexp(i,35),i=0,3)/0,0,0,0/ + data (drexp(i,36),i=0,3)/1,1,0,0/ + data (drexp(i,37),i=0,3)/0,0,0,0/ + data (drexp(i,38),i=0,3)/1,0,1,0/ + data (drexp(i,39),i=0,3)/0,0,0,0/ + data (drexp(i,40),i=0,3)/1,1,0,2/ + data (drexp(i,41),i=0,3)/0,0,0,0/ + data (drexp(i,42),i=0,3)/1,1,0,-2/ + data (drexp(i,43),i=0,3)/0,0,0,0/ + data (drexp(i,44),i=0,3)/1,0,1,2/ + data (drexp(i,45),i=0,3)/0,0,0,0/ + data (drexp(i,46),i=0,3)/1,0,1,-2/ + data (drexp(i,47),i=0,3)/0,0,0,0/ + data (drexp(i,48),i=0,3)/1,2,0,1/ + data (drexp(i,49),i=0,3)/0,0,0,0/ + data (drexp(i,50),i=0,3)/1,2,0,-1/ + data (drexp(i,51),i=0,3)/0,0,0,0/ + data (drexp(i,52),i=0,3)/1,0,2,1/ + data (drexp(i,53),i=0,3)/0,0,0,0/ + data (drexp(i,54),i=0,3)/1,0,2,-1/ + data (drexp(i,55),i=0,3)/0,0,0,0/ + data (drexp(i,56),i=0,3)/1,1,1,1/ + data (drexp(i,57),i=0,3)/0,0,0,0/ + data (drexp(i,58),i=0,3)/1,1,1,-1/ + data (drexp(i,59),i=0,3)/0,0,0,0/ + data (drexp(i,60),i=0,3)/1,1,-1,1/ + data (drexp(i,61),i=0,3)/0,0,0,0/ + data (drexp(i,62),i=0,3)/1,1,-1,-1/ + data (drexp(i,63),i=0,3)/0,0,0,0/ + data (drexp(i,64),i=0,3)/1,1,0,0/ + data (drexp(i,65),i=0,3)/0,0,0,0/ + data (drexp(i,66),i=0,3)/1,0,1,0/ + data (drexp(i,67),i=0,3)/0,0,0,0/ + data (drexp(i,68),i=0,3)/1,1,0,0/ + data (drexp(i,69),i=0,3)/0,0,0,0/ + data (drexp(i,70),i=0,3)/1,0,1,0/ + data (drexp(i,71),i=0,3)/0,0,0,0/ + data (drexp(i,72),i=0,3)/1,3,0,0/ + data (drexp(i,73),i=0,3)/0,0,0,0/ + data (drexp(i,74),i=0,3)/1,0,3,0/ + data (drexp(i,75),i=0,3)/0,0,0,0/ + data (drexp(i,76),i=0,3)/1,2,1,0/ + data (drexp(i,77),i=0,3)/0,0,0,0/ + data (drexp(i,78),i=0,3)/1,1,2,0/ + data (drexp(i,79),i=0,3)/0,0,0,0/ + data (drexp(i,80),i=0,3)/1,2,-1,0/ + data (drexp(i,81),i=0,3)/0,0,0,0/ + data (drexp(i,82),i=0,3)/1,1,-2,0/ + data (drexp(i,83),i=0,3)/0,0,0,0/ + data (drexp(i,84),i=0,3)/0,0,0,0/ + data (drexp(i,85),i=0,3)/0,0,0,0/ + data (drexp(i,86),i=0,3)/0,0,0,0/ + data (drexp(i,87),i=0,3)/0,0,0,0/ + data (drexp(i,88),i=0,3)/0,0,0,0/ + data (drexp(i,89),i=0,3)/0,0,0,0/ + data (drexp(i,90),i=0,3)/1,0,0,2/ + data (drexp(i,91),i=0,3)/0,0,0,0/ + data (drexp(i,92),i=0,3)/1,0,0,2/ + data (drexp(i,93),i=0,3)/0,0,0,0/ + data (drexp(i,94),i=0,3)/1,0,0,4/ + data (drexp(i,95),i=0,3)/0,0,0,0/ + data (drexp(i,96),i=0,3)/1,0,0,2/ + data (drexp(i,97),i=0,3)/0,0,0,0/ + data (drexp(i,98),i=0,3)/1,1,0,3/ + data (drexp(i,99),i=0,3)/0,0,0,0/ + data (drexp(i,100),i=0,3)/1,1,0,-3/ + data (drexp(i,101),i=0,3)/0,0,0,0/ + data (drexp(i,102),i=0,3)/1,0,1,3/ + data (drexp(i,103),i=0,3)/0,0,0,0/ + data (drexp(i,104),i=0,3)/1,0,1,-3/ + data (drexp(i,105),i=0,3)/0,0,0,0/ + data (drexp(i,106),i=0,3)/1,1,0,1/ + data (drexp(i,107),i=0,3)/0,0,0,0/ + data (drexp(i,108),i=0,3)/1,1,0,-1/ + data (drexp(i,109),i=0,3)/0,0,0,0/ + data (drexp(i,110),i=0,3)/1,0,1,1/ + data (drexp(i,111),i=0,3)/0,0,0,0/ + data (drexp(i,112),i=0,3)/1,0,1,-1/ + data (drexp(i,113),i=0,3)/0,0,0,0/ + data (drexp(i,114),i=0,3)/1,2,0,0/ + data (drexp(i,115),i=0,3)/0,0,0,0/ + data (drexp(i,116),i=0,3)/1,0,2,0/ + data (drexp(i,117),i=0,3)/0,0,0,0/ + data (drexp(i,118),i=0,3)/1,2,0,2/ + data (drexp(i,119),i=0,3)/0,0,0,0/ + data (drexp(i,120),i=0,3)/1,2,0,-2/ + data (drexp(i,121),i=0,3)/0,0,0,0/ + data (drexp(i,122),i=0,3)/1,0,2,2/ + data (drexp(i,123),i=0,3)/0,0,0,0/ + data (drexp(i,124),i=0,3)/1,0,2,-2/ + data (drexp(i,125),i=0,3)/0,0,0,0/ + data (drexp(i,126),i=0,3)/1,1,1,0/ + data (drexp(i,127),i=0,3)/0,0,0,0/ + data (drexp(i,128),i=0,3)/1,1,-1,0/ + data (drexp(i,129),i=0,3)/0,0,0,0/ + data (drexp(i,130),i=0,3)/1,1,1,2/ + data (drexp(i,131),i=0,3)/0,0,0,0/ + data (drexp(i,132),i=0,3)/1,1,1,-2/ + data (drexp(i,133),i=0,3)/0,0,0,0/ + data (drexp(i,134),i=0,3)/1,1,-1,2/ + data (drexp(i,135),i=0,3)/0,0,0,0/ + data (drexp(i,136),i=0,3)/1,1,-1,-2/ + data (drexp(i,137),i=0,3)/0,0,0,0/ + data (drexp(i,138),i=0,3)/1,1,0,1/ + data (drexp(i,139),i=0,3)/0,0,0,0/ + data (drexp(i,140),i=0,3)/1,1,0,-1/ + data (drexp(i,141),i=0,3)/0,0,0,0/ + data (drexp(i,142),i=0,3)/1,0,1,1/ + data (drexp(i,143),i=0,3)/0,0,0,0/ + data (drexp(i,144),i=0,3)/1,0,1,-1/ + data (drexp(i,145),i=0,3)/0,0,0,0/ + data (drexp(i,146),i=0,3)/1,1,0,1/ + data (drexp(i,147),i=0,3)/0,0,0,0/ + data (drexp(i,148),i=0,3)/1,1,0,-1/ + data (drexp(i,149),i=0,3)/0,0,0,0/ + data (drexp(i,150),i=0,3)/1,0,1,1/ + data (drexp(i,151),i=0,3)/0,0,0,0/ + data (drexp(i,152),i=0,3)/1,0,1,-1/ + data (drexp(i,153),i=0,3)/0,0,0,0/ + data (drexp(i,154),i=0,3)/1,3,0,1/ + data (drexp(i,155),i=0,3)/0,0,0,0/ + data (drexp(i,156),i=0,3)/1,3,0,-1/ + data (drexp(i,157),i=0,3)/0,0,0,0/ + data (drexp(i,158),i=0,3)/1,0,3,1/ + data (drexp(i,159),i=0,3)/0,0,0,0/ + data (drexp(i,160),i=0,3)/1,0,3,-1/ + data (drexp(i,161),i=0,3)/0,0,0,0/ + data (drexp(i,162),i=0,3)/1,2,1,1/ + data (drexp(i,163),i=0,3)/0,0,0,0/ + data (drexp(i,164),i=0,3)/1,2,1,-1/ + data (drexp(i,165),i=0,3)/0,0,0,0/ + data (drexp(i,166),i=0,3)/1,1,2,1/ + data (drexp(i,167),i=0,3)/0,0,0,0/ + data (drexp(i,168),i=0,3)/1,1,2,-1/ + data (drexp(i,169),i=0,3)/0,0,0,0/ + data (drexp(i,170),i=0,3)/1,2,-1,1/ + data (drexp(i,171),i=0,3)/0,0,0,0/ + data (drexp(i,172),i=0,3)/1,2,-1,-1/ + data (drexp(i,173),i=0,3)/0,0,0,0/ + data (drexp(i,174),i=0,3)/1,1,-2,-1/ + data (drexp(i,175),i=0,3)/0,0,0,0/ + data (drexp(i,176),i=0,3)/1,1,-2,1/ + data (drexp(i,177),i=0,3)/0,0,0,0/ + data (drexp(i,178),i=0,3)/1,2,0,0/ + data (drexp(i,179),i=0,3)/0,0,0,0/ + data (drexp(i,180),i=0,3)/1,0,2,0/ + data (drexp(i,181),i=0,3)/0,0,0,0/ + data (drexp(i,182),i=0,3)/1,2,0,0/ + data (drexp(i,183),i=0,3)/0,0,0,0/ + data (drexp(i,184),i=0,3)/1,0,2,0/ + data (drexp(i,185),i=0,3)/0,0,0,0/ + data (drexp(i,186),i=0,3)/1,1,1,0/ + data (drexp(i,187),i=0,3)/0,0,0,0/ + data (drexp(i,188),i=0,3)/1,1,1,0/ + data (drexp(i,189),i=0,3)/0,0,0,0/ + data (drexp(i,190),i=0,3)/1,1,-1,0/ + data (drexp(i,191),i=0,3)/0,0,0,0/ + data (drexp(i,192),i=0,3)/1,1,-1,0/ + data (drexp(i,193),i=0,3)/0,0,0,0/ + data (drexp(i,194),i=0,3)/1,4,0,0/ + data (drexp(i,195),i=0,3)/0,0,0,0/ + data (drexp(i,196),i=0,3)/1,0,4,0/ + data (drexp(i,197),i=0,3)/0,0,0,0/ + data (drexp(i,198),i=0,3)/1,3,1,0/ + data (drexp(i,199),i=0,3)/0,0,0,0/ + data (drexp(i,200),i=0,3)/1,1,3,0/ + data (drexp(i,201),i=0,3)/0,0,0,0/ + data (drexp(i,202),i=0,3)/1,3,-1,0/ + data (drexp(i,203),i=0,3)/0,0,0,0/ + data (drexp(i,204),i=0,3)/1,1,-3,0/ + data (drexp(i,205),i=0,3)/0,0,0,0/ + data (drexp(i,206),i=0,3)/1,2,2,0/ + data (drexp(i,207),i=0,3)/0,0,0,0/ + data (drexp(i,208),i=0,3)/1,2,-2,0/ + data (drexp(i,209),i=0,3)/0,0,0,0/ + end +c +*********************************************************************** +c + block data srlabl + use lieaparam, only : monoms +c implicit none + include 'srl.inc' +c +c Assignment of designation labels for static resonance basis: +c Written by F. Neri, Summer 1986 +c + data(sln(i),i=1,25)/ + &'R00001','R10000','I10000','R00100','I00100', + &'000010','R11000','R00110','R00002','R10001', + &'I10001','R00101','I00101','R20000','I20000', + &'R00200','I00200','R10100','I10100','R10010', + &'I10010','100010','010010','001010','000110'/ + data(sln(i),i=26,50)/ + &'000020','000011','R11001','R00111','R00003', + &'R10002','I10002','R00102','I00102','R20001', + &'I20001','R00201','I00201','R10101','I10101', + &'R10011','I10011','R21000','I21000','R00210', + &'I00210','R10110','I10110','R11100','I11100'/ + data(sln(i),i=51,75)/ + &'R30000','I30000','R00300','I00300','R20100', + &'I20100','R10200','I10200','R20010','I20010', + &'R01200','I01200','200010','110010','101010', + &'100110','100020','100011','020010','011010', + &'010110','010020','010011','002010','001110'/ + data(sln(i),i=76,100)/ + &'001020','001011','000210','000120','000111', + &'000030','000021','000012','R11002','R00112', + &'R00004','R22000','R00220','R11110','R10003', + &'I10003','R00103','I00103','R20002','I20002', + &'R00202','I00202','R10102','I10102','R10012'/ + data(sln(i),i=101,125)/ + &'I10012','R21001','I21001','R00211','I00211', + &'R10111','I10111','R11101','I11101','R30001', + &'I30001','R00301','I00301','R20101','I20101', + &'R10201','I10201','R20011','I20011','R01201', + &'I01201','R31000','I31000','R00310','I00310'/ + data(sln(i),i=126,150)/ + &'R20110','I20110','R11200','I11200','R21100', + &'I21100','R10210','I10210','R21010','I21010', + &'R01210','I01210','R40000','I40000','R00400', + &'I00400','R30100','I30100','R10300','I10300', + &'R30010','I30010','R01300','I01300','R20200'/ + data(sln(i),i=151,175)/ + &'I20200','R20020','I20020','300010','210010', + &'201010','200110','200020','200011','120010', + &'111010','110110','110020','110011','102010', + &'101110','101020','101011','100210','100120', + &'100111','100030','100021','100012','030010'/ + data(sln(i),i=176,200)/ + &'021010','020110','020020','020011','012010', + &'011110','011020','011011','010210','010120', + &'010111','010030','010021','010012','003010', + &'002110','002020','002011','001210','001120', + &'001111','001030','001021','001012','000310'/ + data(sln(i),i=201,209)/ + &'000220','000211','000130','000121','000112', + &'000040','000031','000022','000013'/ +c + end +c +************************************************************************ +c + block data drlabl + use lieaparam, only : monoms +c implicit none + include 'drl.inc' +c +c Assignment of designation labels for dynamic resonance basis: +c Written by F. Neri, Summer 1986 +c + data(dln(i),i=1,25)/ + &'R100000','I100000','R001000','I001000','R000010', + &'I000010','R110000','R001100','R000011','R000020', + &'I000020','R100010','I100010','R100001','I100001', + &'R001010','I001010','R001001','I001001','R200000', + &'I200000','R002000','I002000','R101000','I101000'/ + data(dln(i),i=26,50)/ + &'R100100','I100100','R110010','I110010','R001110', + &'I001110','R000030','I000030','R000021','I000021', + &'R100011','I100011','R001011','I001011','R100020', + &'I100020','R100002','I100002','R001020','I001020', + &'R001002','I001002','R200010','I200010','R200001'/ + data(dln(i),i=51,75)/ + &'I200001','R002010','I002010','R002001','I002001', + &'R101010','I101010','R101001','I101001','R100110', + &'I100110','R100101','I100101','R210000','I210000', + &'R002100','I002100','R101100','I101100','R111000', + &'I111000','R300000','I300000','R003000','I003000'/ + data(dln(i),i=76,100)/ + &'R201000','I201000','R102000','I102000','R200100', + &'I200100','R100200','I100200','R220000','R002200', + &'R000022','R111100','R110011','R001111','R110020', + &'I110020','R001120','I001120','R000040','I000040', + &'R000031','I000031','R100030','I100030','R100003'/ + data(dln(i),i=101,125)/ + &'I100003','R001030','I001030','R001003','I001003', + &'R100021','I100021','R100012','I100012','R001021', + &'I001021','R001012','I001012','R200011','I200011', + &'R002011','I002011','R200020','I200020','R200002', + &'I200002','R002020','I002020','R002002','I002002'/ + data(dln(i),i=126,150)/ + &'R101011','I101011','R100111','I100111','R101020', + &'I101020','R101002','I101002','R100120','I100120', + &'R100102','I100102','R210010','I210010','R210001', + &'I210001','R002110','I002110','R002101','I002101', + &'R101110','I101110','R101101','I101101','R111010'/ + data(dln(i),i=151,175)/ + &'I111010','R111001','I111001','R300010','I300010', + &'R300001','I300001','R003010','I003010','R003001', + &'I003001','R201010','I201010','R201001','I201001', + &'R102010','I102010','R102001','I102001','R200110', + &'I200110','R200101','I200101','R100201','I100201'/ + data(dln(i),i=176,200)/ + &'R100210','I100210','R310000','I310000','R003100', + &'I003100','R201100','I201100','R112000','I112000', + &'R211000','I211000','R102100','I102100','R210100', + &'I210100','R101200','I101200','R400000','I400000', + &'R004000','I004000','R301000','I301000','R103000'/ + data(dln(i),i=201,209)/ + &'I103000','R300100','I300100','R100300','I100300', + &'R202000','I202000','R200200','I200200'/ +c + end +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/boundp3d.f b/OpticsJan2020/MLI_light_optics/Src/boundp3d.f new file mode 100644 index 0000000..603d562 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/boundp3d.f @@ -0,0 +1,72 @@ + subroutine boundp3d(coord,msk,np,gblam,nx,ny,nz,nadj) + use rays + implicit double precision(a-h,o-z) + logical msk + dimension coord(6,np),msk(np) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + common/gridxtra/xsml,xbig,ysml,ybig,zsml,zbig + dimension bndy(6),rbndy(6) +!hpf$ distribute coord(*,block) +!hpf$ align (:) with coord(*,:) :: msk +! if(idproc.eq.0)write(6,*)'inside boundp' +! transverse: + bndy(1)=maxval(coord(1,:),1,msk) + bndy(2)=maxval(coord(3,:),1,msk) + bndy(3)=maxval(coord(5,:),1,msk) + bndy(4)=-minval(coord(1,:),1,msk) + bndy(5)=-minval(coord(3,:),1,msk) + bndy(6)=-minval(coord(5,:),1,msk) + call MPI_ALLREDUCE(bndy,rbndy,6,mreal,mpimax,lworld,ierror) + xbig=rbndy(1) + ybig=rbndy(2) + zbig=rbndy(3) + xsml=-rbndy(4) + ysml=-rbndy(5) + zsml=-rbndy(6) +! write(6,*)'xsml,xbig=',xsml,xbig +! write(6,*)'ysml,ybig=',ysml,ybig +! write(6,*)'zsml,zbig=',zsml,zbig +! note: this would be a good place to check which particles +! are inside the beampipe, then mask off those that are not. + eps=0.05 + xmin=xsml-eps*(xbig-xsml) + xmax=xbig+eps*(xbig-xsml) + ymin=ysml-eps*(ybig-ysml) + ymax=ybig+eps*(ybig-ysml) +! if(idproc.eq.0)then +! write(6,*)'xmin,xmax=',xmin,xmax +! write(6,*)'ymin,ymax=',ymin,ymax +! endif + hx=(xmax-xmin)/(nx-1) + hy=(ymax-ymin)/(ny-1) + hxi=1.d0/hx + hyi=1.d0/hy +! longitudinal: + delz=zbig-zsml +! if(idproc.eq.0)then +! write(6,*)'delz,gblam=',delz,gblam +! write(6,*)'nadj=',nadj +! endif + if(delz.gt.gblam .and. nadj.eq.1)then + if(idproc.eq.0)then + write(6,*)'error: delz.gt.gam*beta*lambda in routine boundp' + write(6,*)'zbig,zsml=',zbig,zsml + write(6,*)'delz,gblam=',zbig-zsml,gblam + endif + call myexit + endif + if(nadj.eq.0)then + zmin=zsml-eps*(zbig-zsml) + zmax=zbig+eps*(zbig-zsml) +! if(idproc.eq.0)write(6,*)'(nadj.eq.0) zmin,zmax=',zmin,zmax + else + zmin=zsml-0.5d0*(gblam-delz) + zmax=zbig+0.5d0*(gblam-delz) +! if(idproc.eq.0)write(6,*)'(nadj.ne.0) zmin,zmax=',zmin,zmax + endif + if(nadj.eq.0)hz=(zmax-zmin)/(nz-1) + if(nadj.eq.1)hz=gblam/nz + hzi=1.d0/hz +! if(idproc.eq.0)write(6,*)'leaving boundp3d with hz=',hz + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/cfbdang.f b/OpticsJan2020/MLI_light_optics/Src/cfbdang.f new file mode 100755 index 0000000..3795076 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/cfbdang.f @@ -0,0 +1,177 @@ +c + subroutine cgbend(rho,bndang,psideg,phideg,ijopt,coefpset,h,mh) + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + double precision mh(6,6),mht1(6,6),mht2(6,6),mht3(6,6) + double precision h(monoms),ht1(monoms),ht2(monoms),ht3(monoms) + double precision ptmp(6),coefpset(6) +c +c this routine is modeled on the Healy/Dragt subroutine gbend +c +c calculate each of the 3 individual pieces that make +c up the general bending magnet, and concatenate them: +c cgbend=hpf1*cfbend*hpf2 +c****NOV 7 "call hpf" replaced w/ calls to gbend+cfbend since routine hpf +c does not know about combined function magnets. RDR +c (note: "gbend" is the subroutine name for gbdy) +c (note: "cfbend" is the subroutine name for normal entry comb fxn magnet) +c +c 5 parameters and a 6-vector are passed to cfbend: +c bend angle, b field, ilfrn, itfrn, ijopt, coefpset(1-6) +c but note that, in the current implementation of cfbend, ilfrn and itfrn +c are not used. + aldeg=bndang-psideg-phideg +c write(6,*)'brho=',brho +c write(6,*)'rho=',rho + ptmp(2)=brho/rho + ptmp(3)=0. + ptmp(4)=0. + ptmp(5)=ijopt +c ( ptmp(6) is not used ) + ptmp(6)=0. +c compute hpf1 and nbend +c call hpf(rho,1,psideg,ht1,mht1) + azero=0.d0 +cryne 11/9/02 ptmp(1)=0.5d0*bndang + ptmp(1)=psideg + call gbend(rho,azero,psideg,azero,ht1,mht1) + call cfbend(ptmp,coefpset,ht2,mht2) + call concat(ht1,mht1,ht2,mht2,ht1,mht1) + ptmp(1)=aldeg + call cfbend(ptmp,coefpset,ht2,mht2) +c form the product hpf1*nbend + call concat(ht1,mht1,ht2,mht2,ht3,mht3) +c compute hpf2 +c call hpf(rho,-1,phideg,ht1,mht1) +c write(6,'(6(1pe12.5,1x))')((mht1(i,j),j=1,6),i=1,6) +c if(1.gt.0)call myexit +cryne 11/9/02 ptmp(1)=0.5d0*bndang + ptmp(1)=phideg + call cfbend(ptmp,coefpset,ht1,mht1) + call gbend(rho,azero,azero,phideg,ht2,mht2) + call concat(ht1,mht1,ht2,mht2,ht1,mht1) +c form the complete product hpf1*nbend*hpf2 + call concat(ht3,mht3,ht1,mht1,h,mh) + return + end +c +c------------------------------------------------------------------ +c + subroutine cgfrngg(iw,eangle,rho,kfrn,gap,fint,iopt,coefpset,h,mh) + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + include 'pie.inc' +cryne 7/13/2002 include 'frnt.inc' + double precision mh(6,6),mht1(6,6),mht2(6,6),mht3(6,6) + double precision h(monoms),ht1(monoms),ht2(monoms),ht3(monoms) + integer lfrn,tfrn,kfrn + dimension coefpset(6) +c write(6,*)'inside cgfrngg w/ coefpset=' +c write(6,*)coefpset +c write(6,*)'and kfrn=',kfrn +c kfrn = 1,2,or 3 for dipole and/or quad fringe fields +c iw denotes which fringe: =1 for leading, = 2 for trailing +c +c this is not the most efficient routine, but it is easy to follow. +c + call ident(h,mh) +c + if(iw.eq.2)goto 200 + lfrn=kfrn +c leading fringe (iw=1): +c put on leading dipole and quad fringe fields + if(lfrn.eq.0)return +c compute and put on leading dipole fringe field +cryne 7/13/2002 gap=cfbgap +cryne 7/13/2002 xk1=cfblk1 + xk1=fint + if((lfrn.eq.1).or.(lfrn.eq.3))then + call gfrngg(eangle,rho,1,ht1,mht1,gap,xk1) + call concat(ht1,mht1,h,mh,h,mh) + endif +c compute and put on leading quad fringe fields if lfrn=2 or 3 + if(lfrn.eq.1)return + if(iopt.eq.1) then + bqd=coefpset(1) + aqd=coefpset(2) + endif + if(iopt.eq.2) then + bqd=coefpset(1) + aqd=coefpset(2) + endif + if(iopt.eq.3) then + bqd=brho*coefpset(1) + aqd=brho*coefpset(2) + endif +c compute and put on normal quad fringe field +c write(6,*)'about to call frquad (1st time) w/ bqd=',bqd + call frquad(bqd,-1,ht1,mht1) +c write(6,*)'returned from 1st call to frqad w/ mht1=' +c do i=1,6 +c write(6,'(6(1pe12.5,1x))')(mht1(i,j),j=1,6) +c enddo + call concat(ht1,mht1,h,mh,h,mh) +c compute and put on skew quad fringe field +cryne 12/21/2004 write(6,*)'cgfrngg: check this IF test' + if(aqd.ne.0.d0)then + angr=-pi/4.d0 + call arot(angr,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) +c write(6,*)'about to call frquad (2nd time) w/ aqd=',aqd + call frquad(aqd,-1,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) + angr=-angr + call arot(angr,ht1,mht1) + call concat(ht1,mht1,h,mh,h,mh) + endif + return +c + 200 continue + tfrn=kfrn +c trailing fringe (iw=2): +c put on trailing dipole and quad fringe fields + if(tfrn.eq.0)return +c compute and put on trailing dipole fringe field +cryne 7/13/2002 gap=cfbgap +cryne 7/13/2002 xk1=cfbtk1 + xk1=fint + if((tfrn.eq.1).or.(tfrn.eq.3))then + call gfrngg(eangle,rho,2,ht1,mht1,gap,xk1) + call concat(h,mh,ht1,mht1,h,mh) + endif +c compute and put on trailing quad fringe fields if tfrn=2 or 3 + if(tfrn.eq.1)return + if(iopt.eq.1) then + bqd=coefpset(1) + aqd=coefpset(2) + endif + if(iopt.eq.2) then + bqd=coefpset(1) + aqd=coefpset(2) + endif + if(iopt.eq.3) then + bqd=brho*coefpset(1) + aqd=brho*coefpset(2) + endif +c compute and put on normal quad fringe field +c write(6,*)'about to call frquad (3rd time) w/ bqd=',bqd + call frquad(bqd,1,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c compute and put on skew quad fringe field +cryne 12/21/2004 write(6,*)'cgfrngg: also check this IF test' + if(aqd.ne.0.d0)then + angr=pi/4.d0 + call arot(angr,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) +c write(6,*)'about to call frquad (4th time) w/ aqd=',aqd + call frquad(aqd,1,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + angr=-angr + call arot(angr,ht1,mht1) + call concat(h,mh,ht1,mht1,h,mh) + endif + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/cfqd.f b/OpticsJan2020/MLI_light_optics/Src/cfqd.f new file mode 100644 index 0000000..8992719 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/cfqd.f @@ -0,0 +1,826 @@ +********************************************************************** +* header: COMBINED FUNCTION QUADRUPOLE ROUTINES (CFQD) * +* All routines for maps for combined function quadrupoles * +********************************************************************** +c + subroutine aarot(c, s, h, mh) +c + use lieaparam, only : monoms + include 'impli.inc' + double precision h(monoms),mh(6,6) +c + call clear(h,mh) +c Rotate coordinates + mh(1,1)=c + mh(1,3)=-s + mh(3,1)=s + mh(3,3)=c +c Rotate momenta + mh(2,2)=c + mh(2,4)=-s + mh(4,2)=s + mh(4,4)=c +c Don't touch flight time + mh(5,5)=1. + mh(6,6)=1. +c Polynomials are zero (bless those linear maps). + return + end +c +********************************************************************** +c + subroutine cfdrvr(pa,fa,fm) +c + use lieaparam, only : monoms + use beamdata + include 'impli.inc' +cryne include 'parm.inc' + include 'parset.inc' +c + dimension fa(monoms) + dimension fm(6,6) + dimension pa(6),pb(6) + dimension pc(6) + dimension a(10), b(10) +c + double precision gb0,k,k2,k3,k4,l,lk,lkm,lsc + double precision sinv,cosv,ev,bedo +c +c set up parameters and control indices +c + al=pa(1) + ilfrn=nint(pa(3)) + itfrn=nint(pa(4)) + ipset=nint(pa(2)) +c +c get multipole values from the parameter set ipset +c + if (ipset.lt.1 .or. ipset.gt.maxpst) then + do 50 i=1,6 + 50 pb(i) = 0.0d0 + else + do 60 i=1,6 + 60 pb(i) = pst(i,ipset) + endif +c +c compute multipole coefficients +c + bsex=pb(3) + asex=pb(4) + boct=pb(5) + aoct=pb(6) + a(3) = asex + a(4) = aoct + b(3) = bsex + b(4) = boct + a(2) = pb(2) + b(2) = pb(1) +c + call gcfqd(al, b, a, fa, fm, ilfrn, itfrn) +c + + return + end +c +********************************************************************** +c + subroutine gcfqd(al, b, a, qa, qm, ilfr, itfr) +c + use lieaparam, only : monoms + use beamdata + include 'impli.inc' +cryne include 'parm.inc' +c + dimension qa(*), qm(6,6) + dimension ha(monoms), hm(6,6) +c + dimension a(*), b(*) +c + absqd = b(2)**2 + a(2)**2 + if ( absqd .eq. 0.0d0 ) then + asex = a(3) + bsex = b(3) + aoct = a(4) + boct = b(4) + call xcfdr(al, bsex, asex, boct, aoct, qa, qm) + else + if (a(2) .eq. 0.0d0 ) then + if(b(2) .gt. 0 ) then + cos1 = 1.d0 + cos2 = 1.d0 + cos3 = 1.d0 + cos4 = 1.d0 + sin1 = 0.d0 + sin2 = 0.d0 + sin3 = 0.d0 + sin4 = 0.d0 + else if ( b(2) .lt. 0.d0 ) then + cos1 = 0.d0 + cos2 = -1.d0 + cos3 = 0.d0 + cos4 = 1.d0 + sin1 = 1.d0 + sin2 = 0.d0 + sin3 = -1.d0 + sin4 = 0.d0 + endif + else + phi2 = atan2(a(2), b(2)) + phi = phi2/2.d0 + phi3 = 3.d0*phi + phi4 = 4.d0*phi + cos1 = cos(phi) + cos2 = cos(phi2) + cos3 = cos(phi3) + cos4 = cos(phi4) + sin1 = sin(phi) + sin2 = sin(phi2) + sin3 = sin(phi3) + sin4 = sin(phi4) + endif +c + bqd = sqrt(absqd) +c + asex = a(3)*cos3 - b(3)*sin3 + aoct = a(4)*cos4 - b(4)*sin4 + bsex = b(3)*cos3 + a(3)*sin3 + boct = b(4)*cos4 + a(4)*sin4 +c + call aarot(cos1, sin1, qa, qm) + if (ilfr .ne. 0 ) then + call frquad(bqd,-1, ha, hm) + call concat (qa, qm, ha, hm, qa, qm) + endif + call xcffqd(al, bqd, bsex, asex, boct, aoct, ha, hm) + call concat (qa, qm, ha, hm, qa, qm) + if (itfr .ne. 0 ) then + call frquad(bqd, 1, ha, hm) + call concat(qa, qm, ha, hm, qa, qm) + endif + call aarot(cos1, -sin1, ha, hm) + call concat(qa, qm, ha, hm, qa, qm) +c + endif +c + return + end +c +********************************************************************** +c + subroutine xcfdr(al, bsex, asex, boct, aoct, fa, fm) +c +c + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' +c +c calling arrays + dimension fa(monoms) + dimension fm(6,6) + dimension pa(6) +c +c local arrays + dimension ha(monoms) + dimension hm(6,6) + dimension pb(6) +c + pb(1) = al + pb(2) = bsex*al + pb(3) = asex*al + pb(4) = boct*al + pb(5) = aoct*al +c +c put map for cplm in fa,fm + call cplm(pb,fa,fm) +c +c put map for a drift of length al/2 in ha,hm + alh=al/2.d0 + call drift(alh,ha,hm) +c +c preceed and follow map for cplm with map of half-length +c drift + call concat(ha,hm,fa,fm,fa,fm) + call concat(fa,fm,ha,hm,fa,fm) +c + return + end +c +********************************************************************** +c + subroutine xcffqd(al, bqd, bsex, asex, boct, aoct, fa, fm) +c +c This subroutine computes the map for a horizontally focusing +c combined function quadrupole. +c It uses analytic formulas produced by Johannes van Zeijts +c using the symbolic manipulation program Mathematica running +c on a MacII-ci. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' +cryne include 'parm.inc' + include 'parset.inc' +c + dimension fa(monoms) + dimension fm(6,6) + dimension pa(6),pb(6) + dimension pc(6) + dimension ha(monoms) + dimension hm(6,6) +c + double precision gb0,k,k2,k3,k4,l,lk,lkm,lsc + double precision B3,B4,A3,A4,lambda +c +c compute useful numbers +c + sl2=sl*sl + sl3=sl*sl2 + bet2=beta*beta + bet3=beta*bet2 + gam2=gamma*gamma +c + fqdnr=bqd/brho + B3=bsex/brho + A3=asex/brho + B4=boct/brho + A4=aoct/brho +c + lsc=al/sl + lambda = lsc +c +c evaluate k,lk +c + arg=(bqd*(sl**2))/brho + k=dsqrt(arg) + lk=lsc*k + lkm=(-1.0d0)*lk +c +c set coefficients of fm +c + chlk=(dexp(lk)+dexp(lkm))/(2.0d0) + shlk=(dexp(lk)-dexp(lkm))/(2.0d0) + clk=dcos(lk) + slk=dsin(lk) +c + call clear(fa,fm) +c + fm(3,3)=+chlk + fm(3,4)=+(shlk/k) + fm(4,4)=+chlk + fm(4,3)=+(k*shlk) + fm(1,1)=+clk + fm(1,2)=+(slk/k) + fm(2,2)=+clk + fm(2,1)=-(k*slk) + fm(5,5)=+1.0d0 + fm(5,6)=+(lsc/((gamma**2)*(beta**2))) + fm(6,6)=+1.0d0 +c + v = k*lsc +c F3 and F4 terms ( computed by Johannes et al) +c + v = k*lambda + fa(28)=-(B3*(9*Sin(v) + Sin(3*v)))/(36*k) + fa(29)=B3*(-4 + 3*Cos(v) + Cos(3*v))/(12*k**2) + fa(30)=A3*(2*Cosh(v)*Sin(2*v) + 5*Sinh(v) + + # Cos(2*v)*Sinh(v))/(10*k) + fa(31)=A3*(-6 + 5*Cosh(v) + Cos(2*v)*Cosh(v) + + # 2*Sin(2*v)*Sinh(v))/(10*k**2) + fa(33)=k*(-2*v + Sin(2*v))/(8*beta) + fa(34)=B3*(-3*Sin(v) + Sin(3*v))/(12*k**3) + fa(35)=A3*(2 - 2*Cos(2*v)*Cosh(v) + Sin(2*v)*Sinh(v))/ + # (5*k**2) + fa(36)=A3*(Cosh(v)*Sin(2*v) - 2*Cos(2*v)*Sinh(v))/ + # (5*k**3) + fa(38)=(1 - Cos(2*v))/(4*beta) + fa(39)=B3*(5*Sin(v) + Cosh(2*v)*Sin(v) + + # 2*Cos(v)*Sinh(2*v))/(10*k) + fa(40)=B3*(-2 + 2*Cos(v)*Cosh(2*v) + Sin(v)*Sinh(2*v))/ + # (5*k**2) + fa(43)=B3*(-5*Sin(v) + Cosh(2*v)*Sin(v) + + # 2*Cos(v)*Sinh(2*v))/(10*k**3) + fa(49)=B3*(-8 + 9*Cos(v) - Cos(3*v))/(36*k**4) + fa(50)=A3*(-2*Cosh(v)*Sin(2*v) + 5*Sinh(v) - + # Cos(2*v)*Sinh(v))/(10*k**3) + fa(51)=A3*(-4 + 5*Cosh(v) - Cos(2*v)*Cosh(v) - + # 2*Sin(2*v)*Sinh(v))/(10*k**4) + fa(53)=-(2*v + Sin(2*v))/(8*beta*k) + fa(54)=B3*(6 - 5*Cos(v) - Cos(v)*Cosh(2*v) + + # 2*Sin(v)*Sinh(2*v))/(10*k**2) + fa(55)=B3*(2*Cosh(2*v)*Sin(v) - Cos(v)*Sinh(2*v))/ + # (5*k**3) + fa(58)=B3*(-4 + 5*Cos(v) - Cos(v)*Cosh(2*v) + + # 2*Sin(v)*Sinh(2*v))/(10*k**4) + fa(64)=-(A3*(9*Sinh(v) + Sinh(3*v)))/(36*k) + fa(65)=A3*(4 - 3*Cosh(v) - Cosh(3*v))/(12*k**2) + fa(67)=k*(2*v - Sinh(2*v))/(8*beta) + fa(68)=A3*(3*Sinh(v) - Sinh(3*v))/(12*k**3) + fa(70)=(1 - Cosh(2*v))/(4*beta) + fa(74)=A3*(-8 + 9*Cosh(v) - Cosh(3*v))/(36*k**4) + fa(76)=-(2*v + Sinh(2*v))/(8*beta*k) + fa(83)=-lambda/(2*beta**3*gamma**2) + fa(84)=(-2700*k**7*lambda - 7920*v*A3**2 + 6000*v*B3**2 - + # 5400*k**3*lambda*B4 - 7200*B3**2*Sin(v) +1800*k**6*Sin(2*v)- + # 4320*A3**2*Sin(2*v) + 2400*B3**2*Sin(2*v) - + # 3600*k**2*B4*Sin(2*v) + 3456*A3**2*Cosh(v)*Sin(2*v) - + # 800*B3**2*Sin(3*v) - 225*k**6*Sin(4*v) - + # 180*A3**2*Sin(4*v) - 300*B3**2*Sin(4*v) - + # 450*k**2*B4*Sin(4*v) + 8640*A3**2*Sinh(v) + + # 1728*A3**2*Cos(2*v)*Sinh(v))/(57600*k**3) + fa(85)=(45*k**6 - 156*A3**2 + 60*B3**2 -150*k**2*B4 - + # 60*k**6*Cos(2*v) + 144*A3**2*Cos(2*v) - 80*B3**2*Cos(2*v) + + # 120*k**2*B4*Cos(2*v) + 15*k**6*Cos(4*v) + + # 12*A3**2*Cos(4*v) + 20*B3**2*Cos(4*v) + + # 30*k**2*B4*Cos(4*v) + 96*A3**2*Cosh(v) - + # 96*A3**2*Cos(2*v)*Cosh(v) + + # 96*A3**2*Sin(2*v)*Sinh(v))/(960*k**4) + fa(86)=(270*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v) - + # 380*A3*B3*Cosh(v)*Sin(v) + + # 36*A3*B3*Cosh(2*v)*Sin(v) + + # 64*A3*B3*Cosh(v)*Sin(2*v) + 10*A3*B3*Sin(3*v) + + # 45*k**2*A4*Cosh(v)*Sin(3*v) - + # 12*A3*B3*Cosh(v)*Sin(3*v) + 160*A3*B3*Sinh(v) + + # 225*k**2*A4*Cos(v)*Sinh(v) - + # 380*A3*B3*Cos(v)*Sinh(v) + + # 32*A3*B3*Cos(2*v)*Sinh(v) + + # 15*k**2*A4*Cos(3*v)*Sinh(v) - + # 4*A3*B3*Cos(3*v)*Sinh(v) + + # 72*A3*B3*Cos(v)*Sinh(2*v))/(600*k**3) + fa(87)=(-240*k**2*A4 + 384*A3*B3 - 90*A3*B3*Cos(v) - + # 30*A3*B3*Cos(3*v) + 40*A3*B3*Cosh(v) + + # 225*k**2*A4*Cos(v)*Cosh(v) - + # 380*A3*B3*Cos(v)*Cosh(v) + + # 8*A3*B3*Cos(2*v)*Cosh(v) + + # 15*k**2*A4*Cos(3*v)*Cosh(v) - + # 4*A3*B3*Cos(3*v)*Cosh(v) + + # 72*A3*B3*Cos(v)*Cosh(2*v) + + # 225*k**2*A4*Sin(v)*Sinh(v) - + # 380*A3*B3*Sin(v)*Sinh(v) + + # 16*A3*B3*Sin(2*v)*Sinh(v) + + # 45*k**2*A4*Sin(3*v)*Sinh(v) - + # 12*A3*B3*Sin(3*v)*Sinh(v) + + # 36*A3*B3*Sin(v)*Sinh(2*v))/(600*k**4) + fa(89)=B3*(-12*v - 9*v*Cos(v) - 3*v*Cos(3*v) - + # 3*Sin(v) + 6*Sin(2*v) + 5*Sin(3*v))/(144*beta*k) + fa(90)=(-2700*k**7*lambda - 7920*v*A3**2 + 6000*v*B3**2 - + # 5400*k**3*lambda*B4 - 3600*B3**2*Sin(v) + + # 576*A3**2*Cosh(v)*Sin(2*v) - 2000*B3**2*Sin(3*v) + + # 675*k**6*Sin(4*v) + 540*A3**2*Sin(4*v) + + # 900*B3**2*Sin(4*v) + 1350*k**2*B4*Sin(4*v) + + # 7200*A3**2*Sinh(v) - 2592*A3**2*Cos(2*v)*Sinh(v))/ + # (28800*k**5) + fa(91)=(360*k**2*A4 - 416*A3*B3 - 210*A3*B3*Cos(v) - + # 10*A3*B3*Cos(3*v) + 180*A3*B3*Cosh(v) - + # 225*k**2*A4*Cos(v)*Cosh(v) + + # 380*A3*B3*Cos(v)*Cosh(v) + + # 28*A3*B3*Cos(2*v)*Cosh(v) - + # 135*k**2*A4*Cos(3*v)*Cosh(v) + + # 36*A3*B3*Cos(3*v)*Cosh(v) + + # 12*A3*B3*Cos(v)*Cosh(2*v) + + # 225*k**2*A4*Sin(v)*Sinh(v) - + # 380*A3*B3*Sin(v)*Sinh(v) + + # 76*A3*B3*Sin(2*v)*Sinh(v) + + # 45*k**2*A4*Sin(3*v)*Sinh(v) - + # 12*A3*B3*Sin(3*v)*Sinh(v) + + # 96*A3*B3*Sin(v)*Sinh(2*v))/(600*k**4) + fa(92)=(-120*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v) - + # 380*A3*B3*Cosh(v)*Sin(v) + + # 96*A3*B3*Cosh(2*v)*Sin(v) + + # 4*A3*B3*Cosh(v)*Sin(2*v) - 80*A3*B3*Sin(3*v) + + # 45*k**2*A4*Cosh(v)*Sin(3*v) - + # 12*A3*B3*Cosh(v)*Sin(3*v) + 120*A3*B3*Sinh(v) - + # 225*k**2*A4*Cos(v)*Sinh(v) + + # 380*A3*B3*Cos(v)*Sinh(v) + + # 112*A3*B3*Cos(2*v)*Sinh(v) - + # 135*k**2*A4*Cos(3*v)*Sinh(v) + + # 36*A3*B3*Cos(3*v)*Sinh(v) + + # 12*A3*B3*Cos(v)*Sinh(2*v))/(600*k**5) + fa(94)=B3*(-2 + 4*Cos(v) + 2*Cos(2*v) - 4*Cos(3*v) - + # 3*v*Sin(v) - 3*v*Sin(3*v))/(48*beta*k**2) + fa(95)=(300*k**7*lambda + 1680*v*A3**2 - 1680*v*B3**2 + + # 1800*k**3*lambda*B4 + 2440*B3**2*Sin(v) + + # 272*B3**2*Cosh(2*v)*Sin(v) - 150*k**6*Sin(2*v) + + # 600*A3**2*Sin(2*v) - 440*B3**2*Sin(2*v) + + # 900*k**2*B4*Sin(2*v) - 544*A3**2*Cosh(v)*Sin(2*v) + + # 75*k**6*Cosh(2*v)*Sin(2*v) + + # 340*A3**2*Cosh(2*v)*Sin(2*v) + + # 140*B3**2*Cosh(2*v)*Sin(2*v) + + # 450*k**2*B4*Cosh(2*v)*Sin(2*v) + 120*B3**2*Sin(3*v) - + # 2440*A3**2*Sinh(v) - 272*A3**2*Cos(2*v)*Sinh(v) - + # 150*k**6*Sinh(2*v) + 440*A3**2*Sinh(2*v) - + # 600*B3**2*Sinh(2*v) + 900*k**2*B4*Sinh(2*v) + + # 544*B3**2*Cos(v)*Sinh(2*v) + + # 75*k**6*Cos(2*v)*Sinh(2*v) - + # 140*A3**2*Cos(2*v)*Sinh(2*v) - + # 340*B3**2*Cos(2*v)*Sinh(2*v) + + # 450*k**2*B4*Cos(2*v)*Sinh(2*v) - 120*A3**2*Sinh(3*v))/ + # (4800*k**3) + fa(96)=(15*k**6 - 60*A3**2 + 188*B3**2 - 270*k**2*B4 - + # 24*B3**2*Cos(v) - 8*B3**2*Cos(3*v) - 88*A3**2*Cosh(v) + + # 112*A3**2*Cos(2*v)*Cosh(v) - 30*k**6*Cosh(2*v) + + # 88*A3**2*Cosh(2*v) - 120*B3**2*Cosh(2*v) + + # 180*k**2*B4*Cosh(2*v) + 32*B3**2*Cos(v)*Cosh(2*v) + + # 15*k**6*Cos(2*v)*Cosh(2*v) - + # 28*A3**2*Cos(2*v)*Cosh(2*v) - + # 68*B3**2*Cos(2*v)*Cosh(2*v) + + # 90*k**2*B4*Cos(2*v)*Cosh(2*v) - 24*A3**2*Cosh(3*v) - + # 64*A3**2*Sin(2*v)*Sinh(v) + + # 16*B3**2*Sin(v)*Sinh(2*v) + + # 15*k**6*Sin(2*v)*Sinh(2*v) + + # 68*A3**2*Sin(2*v)*Sinh(2*v) + + # 28*B3**2*Sin(2*v)*Sinh(2*v) + + # 90*k**2*B4*Sin(2*v)*Sinh(2*v))/(480*k**4) + fa(98)=A3*(10*v + 5*v*Cosh(v) + + # 5*v*Cos(2*v)*Cosh(v) - 2*Sin(2*v) - + # 2*Cosh(v)*Sin(2*v) - Sinh(v) - + # 5*Cos(2*v)*Sinh(v) - 3*Sinh(2*v))/(40*beta*k) + fa(99)=(-300*k**7*lambda - 1680*v*A3**2 + 1680*v*B3**2 - + # 1800*k**3*lambda*B4 - 160*B3**2*Sin(v) - + # 112*B3**2*Cosh(2*v)*Sin(v) + 150*k**6*Sin(2*v) - + # 600*A3**2*Sin(2*v) + 440*B3**2*Sin(2*v) - + # 900*k**2*B4*Sin(2*v) - 256*A3**2*Cosh(v)*Sin(2*v) + + # 75*k**6*Cosh(2*v)*Sin(2*v) + + # 340*A3**2*Cosh(2*v)*Sin(2*v) + + # 140*B3**2*Cosh(2*v)*Sin(2*v) + + # 450*k**2*B4*Cosh(2*v)*Sin(2*v) - 80*B3**2*Sin(3*v) + + # 1160*A3**2*Sinh(v) + 1312*A3**2*Cos(2*v)*Sinh(v) - + # 150*k**6*Sinh(2*v) + 440*A3**2*Sinh(2*v) - + # 600*B3**2*Sinh(2*v) + 900*k**2*B4*Sinh(2*v) - + # 224*B3**2*Cos(v)*Sinh(2*v) + + # 75*k**6*Cos(2*v)*Sinh(2*v) - + # 140*A3**2*Cos(2*v)*Sinh(2*v) - + # 340*B3**2*Cos(2*v)*Sinh(2*v) + + # 450*k**2*B4*Cos(2*v)*Sinh(2*v) - 120*A3**2*Sinh(3*v))/ + # (4800*k**5) + fa(101)=A3*(-3 + 6*Cos(2*v) + 4*Cosh(v) - + # 4*Cos(2*v)*Cosh(v) - 3*Cosh(2*v) + + # 5*v*Sinh(v) + 5*v*Cos(2*v)*Sinh(v))/ + # (40*beta*k**2) + fa(104)=k*(-8*v + 4*beta**2*v + 2*v*Cos(2*v) + + # 3*Sin(2*v) - 2*beta**2*Sin(2*v))/(32*beta**2) + fa(105)=(75*k**6 - 132*A3**2 + 100*B3**2 - 90*k**2*B4 - + # 80*B3**2*Cos(v) - 60*k**6*Cos(2*v) + 144*A3**2*Cos(2*v) - + # 80*B3**2*Cos(2*v) + 120*k**2*B4*Cos(2*v) + + # 80*B3**2*Cos(3*v) - 15*k**6*Cos(4*v) - + # 12*A3**2*Cos(4*v) - 20*B3**2*Cos(4*v) - + # 30*k**2*B4*Cos(4*v) + 96*A3**2*Cosh(v) - + # 96*A3**2*Cos(2*v)*Cosh(v))/(960*k**6) + fa(106)=(90*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v) - + # 380*A3*B3*Cosh(v)*Sin(v) + + # 72*A3*B3*Cosh(2*v)*Sin(v) + + # 208*A3*B3*Cosh(v)*Sin(2*v) + 10*A3*B3*Sin(3*v) - + # 135*k**2*A4*Cosh(v)*Sin(3*v) + + # 36*A3*B3*Cosh(v)*Sin(3*v) + 60*A3*B3*Sinh(v) + + # 225*k**2*A4*Cos(v)*Sinh(v) - + # 380*A3*B3*Cos(v)*Sinh(v) - + # 76*A3*B3*Cos(2*v)*Sinh(v) - + # 45*k**2*A4*Cos(3*v)*Sinh(v) + + # 12*A3*B3*Cos(3*v)*Sinh(v) + + # 24*A3*B3*Cos(v)*Sinh(2*v))/(600*k**5) + fa(107)=(-180*k**2*A4 + 368*A3*B3 - 30*A3*B3*Cos(v)+ + # 70*A3*B3*Cos(3*v) - 60*A3*B3*Cosh(v) + + # 225*k**2*A4*Cos(v)*Cosh(v) - + # 380*A3*B3*Cos(v)*Cosh(v) - + # 4*A3*B3*Cos(2*v)*Cosh(v) - + # 45*k**2*A4*Cos(3*v)*Cosh(v) + + # 12*A3*B3*Cos(3*v)*Cosh(v) + + # 24*A3*B3*Cos(v)*Cosh(2*v) + + # 225*k**2*A4*Sin(v)*Sinh(v) - + # 380*A3*B3*Sin(v)*Sinh(v) + + # 232*A3*B3*Sin(2*v)*Sinh(v) - + # 135*k**2*A4*Sin(3*v)*Sinh(v) + + # 36*A3*B3*Sin(3*v)*Sinh(v) + + # 72*A3*B3*Sin(v)*Sinh(2*v))/(600*k**6) + fa(109)=B3*(-3*v*Cos(v) + 3*v*Cos(3*v) - + # 7*Sin(v) + 8*Sin(2*v) - 3*Sin(3*v))/(48*beta*k**3) + fa(110)=(-15*k**6 + 188*A3**2 - 60*B3**2 + 270*k**2*B4- + # 88*B3**2*Cos(v) + 30*k**6*Cos(2*v) - 120*A3**2*Cos(2*v) + + # 88*B3**2*Cos(2*v) - 180*k**2*B4*Cos(2*v) - + # 24*B3**2*Cos(3*v) - 24*A3**2*Cosh(v) + + # 32*A3**2*Cos(2*v)*Cosh(v) + + # 112*B3**2*Cos(v)*Cosh(2*v) - + # 15*k**6*Cos(2*v)*Cosh(2*v) - + # 68*A3**2*Cos(2*v)*Cosh(2*v) - + # 28*B3**2*Cos(2*v)*Cosh(2*v) - + # 90*k**2*B4*Cos(2*v)*Cosh(2*v) - 8*A3**2*Cosh(3*v) - + # 16*A3**2*Sin(2*v)*Sinh(v) + + # 64*B3**2*Sin(v)*Sinh(2*v) + + # 15*k**6*Sin(2*v)*Sinh(2*v) - + # 28*A3**2*Sin(2*v)*Sinh(2*v) - + # 68*B3**2*Sin(2*v)*Sinh(2*v) + + # 90*k**2*B4*Sin(2*v)*Sinh(2*v))/(480*k**4) + fa(111)=(-24*B3**2*Sin(v) + 16*B3**2*Cosh(2*v)*Sin(v) + + # 112*A3**2*Cosh(v)*Sin(2*v) + + # 15*k**6*Cosh(2*v)*Sin(2*v) - + # 28*A3**2*Cosh(2*v)*Sin(2*v) - + # 68*B3**2*Cosh(2*v)*Sin(2*v) + + # 90*k**2*B4*Cosh(2*v)*Sin(2*v) - 8*B3**2*Sin(3*v) - + # 24*A3**2*Sinh(v) + 16*A3**2*Cos(2*v)*Sinh(v) + + # 112*B3**2*Cos(v)*Sinh(2*v) - + # 15*k**6*Cos(2*v)*Sinh(2*v) - + # 68*A3**2*Cos(2*v)*Sinh(2*v) - + # 28*B3**2*Cos(2*v)*Sinh(2*v) - + # 90*k**2*B4*Cos(2*v)*Sinh(2*v) - 8*A3**2*Sinh(3*v))/ + # (240*k**5) + fa(113)=A3*(1 - Cosh(2*v) + 5*v*Cosh(v)*Sin(2*v) - + # 4*Sin(2*v)*Sinh(v))/(20*beta*k**2) + fa(114)=(45*k**6 - 52*A3**2 + 116*B3**2 - 90*k**2*B4 - + # 128*B3**2*Cos(v) - 30*k**6*Cos(2*v) + + # 120*A3**2*Cos(2*v) - 88*B3**2*Cos(2*v) + + # 180*k**2*B4*Cos(2*v) + 16*B3**2*Cos(3*v) - + # 24*A3**2*Cosh(v) + 32*A3**2*Cos(2*v)*Cosh(v) + + # 112*B3**2*Cos(v)*Cosh(2*v) - + # 15*k**6*Cos(2*v)*Cosh(2*v) - + # 68*A3**2*Cos(2*v)*Cosh(2*v) - + # 28*B3**2*Cos(2*v)*Cosh(2*v) - + # 90*k**2*B4*Cos(2*v)*Cosh(2*v) - 8*A3**2*Cosh(3*v) + + # 224*A3**2*Sin(2*v)*Sinh(v) - + # 32*B3**2*Sin(v)*Sinh(2*v) + + # 15*k**6*Sin(2*v)*Sinh(2*v) - + # 28*A3**2*Sin(2*v)*Sinh(2*v) - + # 68*B3**2*Sin(2*v)*Sinh(2*v) + + # 90*k**2*B4*Sin(2*v)*Sinh(2*v))/(480*k**6) + fa(116)=A3*(5*Sin(2*v) - 3*Cosh(v)*Sin(2*v) - + # 2*Cos(2*v)*Sinh(v) + 5*v*Sin(2*v)*Sinh(v) - + # Sinh(2*v))/(20*beta*k**3) + fa(119)=(2 - beta**2 - 2*Cos(2*v) + beta**2*Cos(2*v) + + # v*Sin(2*v))/(8*beta**2) + fa(120)=(-160*A3*B3*Sin(v) - 225*k**2*A4*Cosh(v)*Sin(v)+ + # 380*A3*B3*Cosh(v)*Sin(v) - + # 32*A3*B3*Cosh(2*v)*Sin(v) - + # 15*k**2*A4*Cosh(3*v)*Sin(v) + + # 4*A3*B3*Cosh(3*v)*Sin(v) - + # 72*A3*B3*Cosh(v)*Sin(2*v) - 270*A3*B3*Sinh(v) - + # 225*k**2*A4*Cos(v)*Sinh(v) + + # 380*A3*B3*Cos(v)*Sinh(v) - + # 36*A3*B3*Cos(2*v)*Sinh(v) - + # 64*A3*B3*Cos(v)*Sinh(2*v) - 10*A3*B3*Sinh(3*v) - + # 45*k**2*A4*Cos(v)*Sinh(3*v) + + # 12*A3*B3*Cos(v)*Sinh(3*v))/(600*k**3) + fa(121)=(360*k**2*A4 - 416*A3*B3 + 180*A3*B3*Cos(v)- + # 210*A3*B3*Cosh(v) - 225*k**2*A4*Cos(v)*Cosh(v) + + # 380*A3*B3*Cos(v)*Cosh(v) + + # 12*A3*B3*Cos(2*v)*Cosh(v) + + # 28*A3*B3*Cos(v)*Cosh(2*v) - 10*A3*B3*Cosh(3*v) - + # 135*k**2*A4*Cos(v)*Cosh(3*v) + + # 36*A3*B3*Cos(v)*Cosh(3*v) - + # 225*k**2*A4*Sin(v)*Sinh(v) + + # 380*A3*B3*Sin(v)*Sinh(v) - + # 96*A3*B3*Sin(2*v)*Sinh(v) - + # 76*A3*B3*Sin(v)*Sinh(2*v) - + # 45*k**2*A4*Sin(v)*Sinh(3*v) + + # 12*A3*B3*Sin(v)*Sinh(3*v))/(600*k**4) + fa(123)=B3*(10*v + 5*v*Cos(v) + + # 5*v*Cos(v)*Cosh(2*v) - Sin(v) - + # 5*Cosh(2*v)*Sin(v) - 3*Sin(2*v) - 2*Sinh(2*v) - + # 2*Cos(v)*Sinh(2*v))/(40*beta*k) + fa(124)=(60*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v) - + # 380*A3*B3*Cosh(v)*Sin(v) - + # 76*A3*B3*Cosh(2*v)*Sin(v) - + # 45*k**2*A4*Cosh(3*v)*Sin(v) + + # 12*A3*B3*Cosh(3*v)*Sin(v) + + # 24*A3*B3*Cosh(v)*Sin(2*v) + 90*A3*B3*Sinh(v) + + # 225*k**2*A4*Cos(v)*Sinh(v) - + # 380*A3*B3*Cos(v)*Sinh(v) + + # 72*A3*B3*Cos(2*v)*Sinh(v) + + # 208*A3*B3*Cos(v)*Sinh(2*v) + 10*A3*B3*Sinh(3*v) - + # 135*k**2*A4*Cos(v)*Sinh(3*v) + + # 36*A3*B3*Cos(v)*Sinh(3*v))/(600*k**5) + fa(126)=B3*(-1 + Cos(2*v) + 5*v*Cos(v)*Sinh(2*v) - + # 4*Sin(v)*Sinh(2*v))/(20*beta*k**2) + fa(130)=(-180*k**2*A4 + 368*A3*B3 - 180*A3*B3*Cos(v)+ + # 30*A3*B3*Cosh(v) + 225*k**2*A4*Cos(v)*Cosh(v) - + # 380*A3*B3*Cos(v)*Cosh(v) + + # 24*A3*B3*Cos(2*v)*Cosh(v) + + # 116*A3*B3*Cos(v)*Cosh(2*v) + 10*A3*B3*Cosh(3*v) - + # 45*k**2*A4*Cos(v)*Cosh(3*v) + + # 12*A3*B3*Cos(v)*Cosh(3*v) + + # 225*k**2*A4*Sin(v)*Sinh(v) - + # 380*A3*B3*Sin(v)*Sinh(v) + + # 48*A3*B3*Sin(2*v)*Sinh(v) - + # 32*A3*B3*Sin(v)*Sinh(2*v) - + # 15*k**2*A4*Sin(v)*Sinh(3*v) + + # 4*A3*B3*Sin(v)*Sinh(3*v))/(600*k**6) + fa(132)=B3*(-5*v*Cos(v) + 5*v*Cos(v)*Cosh(2*v) - + # 9*Sin(v) - 3*Cosh(2*v)*Sin(v) + 2*Sin(2*v) + + # 2*Sinh(2*v) + 2*Cos(v)*Sinh(2*v))/(40*beta*k**3) + fa(140)=(-2700*k**7*lambda - 7920*v*A3**2 + 6000*v*B3**2 - + # 5400*k**3*lambda*B4 - 4800*B3**2*Sin(v) -1800*k**6*Sin(2*v)+ + # 4320*A3**2*Sin(2*v) - 2400*B3**2*Sin(2*v) + + # 3600*k**2*B4*Sin(2*v) - 2304*A3**2*Cosh(v)*Sin(2*v) + + # 1600*B3**2*Sin(3*v) - 225*k**6*Sin(4*v) - + # 180*A3**2*Sin(4*v) - 300*B3**2*Sin(4*v) - + # 450*k**2*B4*Sin(4*v) + 5760*A3**2*Sinh(v) - + # 1152*A3**2*Cos(2*v)*Sinh(v))/(57600*k**7) + fa(141)=(180*k**2*A4 - 368*A3*B3 - 30*A3*B3*Cos(v) - + # 10*A3*B3*Cos(3*v) + 180*A3*B3*Cosh(v) - + # 225*k**2*A4*Cos(v)*Cosh(v) + + # 380*A3*B3*Cos(v)*Cosh(v) - + # 116*A3*B3*Cos(2*v)*Cosh(v) + + # 45*k**2*A4*Cos(3*v)*Cosh(v) - + # 12*A3*B3*Cos(3*v)*Cosh(v) - + # 24*A3*B3*Cos(v)*Cosh(2*v) + + # 225*k**2*A4*Sin(v)*Sinh(v) - + # 380*A3*B3*Sin(v)*Sinh(v) - + # 32*A3*B3*Sin(2*v)*Sinh(v) - + # 15*k**2*A4*Sin(3*v)*Sinh(v) + + # 4*A3*B3*Sin(3*v)*Sinh(v) + + # 48*A3*B3*Sin(v)*Sinh(2*v))/(600*k**6) + fa(142)=(-60*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v) - + # 380*A3*B3*Cosh(v)*Sin(v) + + # 48*A3*B3*Cosh(2*v)*Sin(v) - + # 8*A3*B3*Cosh(v)*Sin(2*v) + 20*A3*B3*Sin(3*v) - + # 15*k**2*A4*Cosh(v)*Sin(3*v) + + # 4*A3*B3*Cosh(v)*Sin(3*v) + 120*A3*B3*Sinh(v) - + # 225*k**2*A4*Cos(v)*Sinh(v) + + # 380*A3*B3*Cos(v)*Sinh(v) - + # 104*A3*B3*Cos(2*v)*Sinh(v) + + # 45*k**2*A4*Cos(3*v)*Sinh(v) - + # 12*A3*B3*Cos(3*v)*Sinh(v) - + # 24*A3*B3*Cos(v)*Sinh(2*v))/(600*k**7) + fa(144)=B3*(-20 + 30*Cos(v) - 12*Cos(2*v) + 2*Cos(3*v) - + # 9*v*Sin(v) + 3*v*Sin(3*v))/(144*beta*k**4) + fa(145)=(300*k**7*lambda + 1680*v*A3**2 - 1680*v*B3**2 + + # 1800*k**3*lambda*B4 + 1160*B3**2*Sin(v) + + # 1312*B3**2*Cosh(2*v)*Sin(v) + 150*k**6*Sin(2*v) - + # 600*A3**2*Sin(2*v) + 440*B3**2*Sin(2*v) - + # 900*k**2*B4*Sin(2*v) - 224*A3**2*Cosh(v)*Sin(2*v) - + # 75*k**6*Cosh(2*v)*Sin(2*v) - + # 340*A3**2*Cosh(2*v)*Sin(2*v) - + # 140*B3**2*Cosh(2*v)*Sin(2*v) - + # 450*k**2*B4*Cosh(2*v)*Sin(2*v) - 120*B3**2*Sin(3*v) - + # 160*A3**2*Sinh(v) - 112*A3**2*Cos(2*v)*Sinh(v) - + # 150*k**6*Sinh(2*v) + 440*A3**2*Sinh(2*v) - + # 600*B3**2*Sinh(2*v) + 900*k**2*B4*Sinh(2*v) - + # 256*B3**2*Cos(v)*Sinh(2*v) - + # 75*k**6*Cos(2*v)*Sinh(2*v) + + # 140*A3**2*Cos(2*v)*Sinh(2*v) + + # 340*B3**2*Cos(2*v)*Sinh(2*v) - + # 450*k**2*B4*Cos(2*v)*Sinh(2*v) - 80*A3**2*Sinh(3*v))/ + # (4800*k**5) + fa(146)=(45*k**6 - 116*A3**2 + 52*B3**2 - 90*k**2*B4 + + # 24*B3**2*Cos(v) + 8*B3**2*Cos(3*v) + + # 128*A3**2*Cosh(v) - 112*A3**2*Cos(2*v)*Cosh(v) - + # 30*k**6*Cosh(2*v) + 88*A3**2*Cosh(2*v) - + # 120*B3**2*Cosh(2*v) + 180*k**2*B4*Cosh(2*v) - + # 32*B3**2*Cos(v)*Cosh(2*v) - + # 15*k**6*Cos(2*v)*Cosh(2*v) + + # 28*A3**2*Cos(2*v)*Cosh(2*v) + + # 68*B3**2*Cos(2*v)*Cosh(2*v) - + # 90*k**2*B4*Cos(2*v)*Cosh(2*v) - 16*A3**2*Cosh(3*v) - + # 32*A3**2*Sin(2*v)*Sinh(v) + + # 224*B3**2*Sin(v)*Sinh(2*v) - + # 15*k**6*Sin(2*v)*Sinh(2*v) - + # 68*A3**2*Sin(2*v)*Sinh(2*v) - + # 28*B3**2*Sin(2*v)*Sinh(2*v) - + # 90*k**2*B4*Sin(2*v)*Sinh(2*v))/(480*k**6) + fa(148)=A3*(5*v*Cosh(v) - 5*v*Cos(2*v)*Cosh(v) - + # 2*Sin(2*v) - 2*Cosh(v)*Sin(2*v) + 9*Sinh(v) + + # 3*Cos(2*v)*Sinh(v) - 2*Sinh(2*v))/(40*beta*k**3) + fa(149)=(-300*k**7*lambda - 1680*v*A3**2 + 1680*v*B3**2 - + # 1800*k**3*lambda*B4 - 1040*B3**2*Sin(v) + + # 928*B3**2*Cosh(2*v)*Sin(v) - 150*k**6*Sin(2*v) + + # 600*A3**2*Sin(2*v) - 440*B3**2*Sin(2*v) + + # 900*k**2*B4*Sin(2*v) + 64*A3**2*Cosh(v)*Sin(2*v) - + # 75*k**6*Cosh(2*v)*Sin(2*v) - + # 340*A3**2*Cosh(2*v)*Sin(2*v) - + # 140*B3**2*Cosh(2*v)*Sin(2*v) - + # 450*k**2*B4*Cosh(2*v)*Sin(2*v) + 80*B3**2*Sin(3*v) + + # 1040*A3**2*Sinh(v) - 928*A3**2*Cos(2*v)*Sinh(v) - + # 150*k**6*Sinh(2*v) + 440*A3**2*Sinh(2*v) - + # 600*B3**2*Sinh(2*v) + 900*k**2*B4*Sinh(2*v) - + # 64*B3**2*Cos(v)*Sinh(2*v) - + # 75*k**6*Cos(2*v)*Sinh(2*v) + + # 140*A3**2*Cos(2*v)*Sinh(2*v) + + # 340*B3**2*Cos(2*v)*Sinh(2*v) - + # 450*k**2*B4*Cos(2*v)*Sinh(2*v) - 80*A3**2*Sinh(3*v))/ + # (4800*k**7) + fa(151)=A3*(-10 - 4*Cos(2*v) + 14*Cosh(v) + + # 2*Cos(2*v)*Cosh(v) - 2*Cosh(2*v) + + # 5*v*Sinh(v) - 5*v*Cos(2*v)*Sinh(v) - + # 4*Sin(2*v)*Sinh(v))/(40*beta*k**4) + fa(154)=(-12*v + 4*beta**2*v - 2*v*Cos(2*v) - + # 5*Sin(2*v) + 2*beta**2*Sin(2*v))/(32*beta**2*k) + fa(155)=(-240*k**2*A4 + 384*A3*B3 + 40*A3*B3*Cos(v) - + # 90*A3*B3*Cosh(v) + 225*k**2*A4*Cos(v)*Cosh(v) - + # 380*A3*B3*Cos(v)*Cosh(v) + + # 72*A3*B3*Cos(2*v)*Cosh(v) + + # 8*A3*B3*Cos(v)*Cosh(2*v) - 30*A3*B3*Cosh(3*v) + + # 15*k**2*A4*Cos(v)*Cosh(3*v) - + # 4*A3*B3*Cos(v)*Cosh(3*v) - + # 225*k**2*A4*Sin(v)*Sinh(v) + + # 380*A3*B3*Sin(v)*Sinh(v) - + # 36*A3*B3*Sin(2*v)*Sinh(v) - + # 16*A3*B3*Sin(v)*Sinh(2*v) - + # 45*k**2*A4*Sin(v)*Sinh(3*v) + + # 12*A3*B3*Sin(v)*Sinh(3*v))/(600*k**4) + fa(156)=(120*A3*B3*Sin(v) - 225*k**2*A4*Cosh(v)*Sin(v) + + # 380*A3*B3*Cosh(v)*Sin(v) + + # 112*A3*B3*Cosh(2*v)*Sin(v) - + # 135*k**2*A4*Cosh(3*v)*Sin(v) + + # 36*A3*B3*Cosh(3*v)*Sin(v) + + # 12*A3*B3*Cosh(v)*Sin(2*v) - 120*A3*B3*Sinh(v) + + # 225*k**2*A4*Cos(v)*Sinh(v) - + # 380*A3*B3*Cos(v)*Sinh(v) + + # 96*A3*B3*Cos(2*v)*Sinh(v) + + # 4*A3*B3*Cos(v)*Sinh(2*v) - 80*A3*B3*Sinh(3*v) + + # 45*k**2*A4*Cos(v)*Sinh(3*v) - + # 12*A3*B3*Cos(v)*Sinh(3*v))/(600*k**5) + fa(158)=B3*(3 - 4*Cos(v) + 3*Cos(2*v) - 6*Cosh(2*v) + + # 4*Cos(v)*Cosh(2*v) + 5*v*Sin(v) + + # 5*v*Cosh(2*v)*Sin(v))/(40*beta*k**2) + fa(159)=(180*k**2*A4 - 368*A3*B3 + 60*A3*B3*Cos(v) + + # 30*A3*B3*Cosh(v) - 225*k**2*A4*Cos(v)*Cosh(v) + + # 380*A3*B3*Cos(v)*Cosh(v) - + # 24*A3*B3*Cos(2*v)*Cosh(v) + + # 4*A3*B3*Cos(v)*Cosh(2*v) - 70*A3*B3*Cosh(3*v) + + # 45*k**2*A4*Cos(v)*Cosh(3*v) - + # 12*A3*B3*Cos(v)*Cosh(3*v) + + # 225*k**2*A4*Sin(v)*Sinh(v) - + # 380*A3*B3*Sin(v)*Sinh(v) + + # 72*A3*B3*Sin(2*v)*Sinh(v) + + # 232*A3*B3*Sin(v)*Sinh(2*v) - + # 135*k**2*A4*Sin(v)*Sinh(3*v) + + # 36*A3*B3*Sin(v)*Sinh(3*v))/(600*k**6) + fa(161)=B3*(2*Cosh(2*v)*Sin(v) + Sin(2*v) - + # 5*Sinh(2*v) + 3*Cos(v)*Sinh(2*v) + + # 5*v*Sin(v)*Sinh(2*v))/(20*beta*k**3) + fa(165)=(-120*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v)- + # 380*A3*B3*Cosh(v)*Sin(v) + + # 104*A3*B3*Cosh(2*v)*Sin(v) - + # 45*k**2*A4*Cosh(3*v)*Sin(v) + + # 12*A3*B3*Cosh(3*v)*Sin(v) + + # 24*A3*B3*Cosh(v)*Sin(2*v) + 60*A3*B3*Sinh(v) - + # 225*k**2*A4*Cos(v)*Sinh(v) + + # 380*A3*B3*Cos(v)*Sinh(v) - + # 48*A3*B3*Cos(2*v)*Sinh(v) + + # 8*A3*B3*Cos(v)*Sinh(2*v) - 20*A3*B3*Sinh(3*v) + + # 15*k**2*A4*Cos(v)*Sinh(3*v) - + # 4*A3*B3*Cos(v)*Sinh(3*v))/(600*k**7) + fa(167)=B3*(-10 + 14*Cos(v) - 2*Cos(2*v) - 4*Cosh(2*v) + + # 2*Cos(v)*Cosh(2*v) - 5*v*Sin(v) + + # 5*v*Cosh(2*v)*Sin(v) + 4*Sin(v)*Sinh(2*v))/ + # (40*beta*k**4) + fa(175)=(-2700*k**7*lambda - 6000*v*A3**2 + 7920*v*B3**2 - + # 5400*k**3*lambda*B4 - 8640*B3**2*Sin(v) - + # 1728*B3**2*Cosh(2*v)*Sin(v) + 7200*A3**2*Sinh(v) + + # 1800*k**6*Sinh(2*v) - 2400*A3**2*Sinh(2*v) + + # 4320*B3**2*Sinh(2*v) - 3600*k**2*B4*Sinh(2*v) - + # 3456*B3**2*Cos(v)*Sinh(2*v) + 800*A3**2*Sinh(3*v) - + # 225*k**6*Sinh(4*v) + 300*A3**2*Sinh(4*v) + + # 180*B3**2*Sinh(4*v) - 450*k**2*B4*Sinh(4*v))/(57600*k**3) + fa(176)=(-45*k**6 + 60*A3**2 - 156*B3**2 + 150*k**2*B4 + + # 96*B3**2*Cos(v) + 60*k**6*Cosh(2*v) - + # 80*A3**2*Cosh(2*v) + 144*B3**2*Cosh(2*v) - + # 120*k**2*B4*Cosh(2*v) - 96*B3**2*Cos(v)*Cosh(2*v) - + # 15*k**6*Cosh(4*v) + 20*A3**2*Cosh(4*v) + + # 12*B3**2*Cosh(4*v) - 30*k**2*B4*Cosh(4*v) - + # 96*B3**2*Sin(v)*Sinh(2*v))/(960*k**4) + fa(178)=A3*(-12*v - 9*v*Cosh(v) - 3*v*Cosh(3*v) - + # 3*Sinh(v) + 6*Sinh(2*v) + 5*Sinh(3*v))/(144*beta*k) + fa(179)=(2700*k**7*lambda + 6000*v*A3**2 - 7920*v*B3**2 + + # 5400*k**3*lambda*B4 + 7200*B3**2*Sin(v) - + # 2592*B3**2*Cosh(2*v)*Sin(v) - 3600*A3**2*Sinh(v) + + # 576*B3**2*Cos(v)*Sinh(2*v) - 2000*A3**2*Sinh(3*v) - + # 675*k**6*Sinh(4*v) + 900*A3**2*Sinh(4*v) + + # 540*B3**2*Sinh(4*v) - 1350*k**2*B4*Sinh(4*v))/(28800*k**5) + fa(181)=A3*(2 - 4*Cosh(v) - 2*Cosh(2*v) + 4*Cosh(3*v) - + # 3*v*Sinh(v) - 3*v*Sinh(3*v))/(48*beta*k**2) + fa(184)=k*(8*v - 4*beta**2*v - 2*v*Cosh(2*v) - + # 3*Sinh(2*v) + 2*beta**2*Sinh(2*v))/(32*beta**2) + fa(185)=(75*k**6 - 100*A3**2 + 132*B3**2 - 90*k**2*B4 - + # 96*B3**2*Cos(v) + 80*A3**2*Cosh(v) - 60*k**6*Cosh(2*v) + + # 80*A3**2*Cosh(2*v) - 144*B3**2*Cosh(2*v) + + # 120*k**2*B4*Cosh(2*v) + 96*B3**2*Cos(v)*Cosh(2*v) - + # 80*A3**2*Cosh(3*v) - 15*k**6*Cosh(4*v) + + # 20*A3**2*Cosh(4*v) + 12*B3**2*Cosh(4*v) - + # 30*k**2*B4*Cosh(4*v))/(960*k**6) + fa(187)=A3*(3*v*Cosh(v) - 3*v*Cosh(3*v) + + # 7*Sinh(v) - 8*Sinh(2*v) + 3*Sinh(3*v))/(48*beta*k**3) + fa(190)=(2 - beta**2 - 2*Cosh(2*v) + beta**2*Cosh(2*v) - + # v*Sinh(2*v))/(8*beta**2) + fa(195)=(-2700*k**7*lambda - 6000*v*A3**2 + 7920*v*B3**2 - + # 5400*k**3*lambda*B4 - 5760*B3**2*Sin(v) + + # 1152*B3**2*Cosh(2*v)*Sin(v) + 4800*A3**2*Sinh(v) - + # 1800*k**6*Sinh(2*v) + 2400*A3**2*Sinh(2*v) - + # 4320*B3**2*Sinh(2*v) + 3600*k**2*B4*Sinh(2*v) + + # 2304*B3**2*Cos(v)*Sinh(2*v) - 1600*A3**2*Sinh(3*v) - + # 225*k**6*Sinh(4*v) + 300*A3**2*Sinh(4*v) + + # 180*B3**2*Sinh(4*v) - 450*k**2*B4*Sinh(4*v))/(57600*k**7) + fa(197)=A3*(-20 + 30*Cosh(v) - 12*Cosh(2*v) + 2*Cosh(3*v) + + # 9*v*Sinh(v) - 3*v*Sinh(3*v))/(144*beta*k**4) + fa(200)=(-12*v + 4*beta**2*v - 2*v*Cosh(2*v) - + # 5*Sinh(2*v) + 2*beta**2*Sinh(2*v))/(32*beta**2*k) + fa(209)=(-5 + beta**2)*lambda/(8*beta**4*gamma**2) +c +c go from reverse to direct factorization: +c + call revf(1,fa,fm) +c +c fringe field effects are put on in the subroutine gcfqd +c + return + end +c +c end of file + diff --git a/OpticsJan2020/MLI_light_optics/Src/coil.f b/OpticsJan2020/MLI_light_optics/Src/coil.f new file mode 100644 index 0000000..ce4ed7b --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/coil.f @@ -0,0 +1,700 @@ +c +c +c A few changes made (like changing .0 to 0.d0) by P. Walstrom 6/04 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine coil(pa) +c +c Parse multipole input: +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + use acceldata + include 'impli.inc' + include 'multipole.inc' + include 'parset.inc' +cryneneriwalstrom include 'elmnts.inc' + parameter(maxgauss=100) + common/gauss/xgn(maxgauss,maxgauss),wgn(maxgauss,maxgauss) +c Gaussian nodes and weights- used with some thick coils + dimension xg(maxgauss),wg(maxgauss) + double precision pa(*) +c F. Neri 3/23/90 +c Revised 7/12/90 +c Version 6/26/91 +c Including spacers... +c F. Neri + integer np +ctm +ctm dump input parameters +ctm +cryne 8/5/2004 write(6,16) (pa(i),i=1,5) +cryne 8/5/2004 16 format(' coil: ',5f12.5) +cryne 8/5/2004 write(6,17) (pa(i),i=6,11) +cryne 8/5/2004 17 format(' shape: ',6f10.4) + it = nint(pa(5)) +c +c If itype == 0 initilize commons bincof,coeffs, and gauss +ctm /gauss/ initialization added for types 13 through 17 +c + if ( it .eq. 0 ) then + ncoil = 0 + ztotal = 0.0d0 + call bincof + call coeffs +c +c Precompute gaussian weights and nodes on [-1,1]- +c these are scaled linearily for other intervals.. +c + x1=-1.d0 + x2=1.d0 + do 13 ng=1,maxgauss + call gauleg(x1,x2,xg,wg,ng) + do 13 n=1,ng + xgn(n,ng)=xg(n) + wgn(n,ng)=wg(n) + 13 continue + return + endif +c +c If itype == -1 spacer. +c + if ( it .eq. -1 ) then + if ( ncoil .eq. 0 ) then + xldr = pa(1) + else + ztotal = ztotal + pa(1) + endif + return + endif +c Increase coil number + ncoil = ncoil + 1 + if ( ncoil .gt. maxcoils ) then + write (6,*) ' Exceeded maximum number of Coils!' + call myexit + endif +c Stack name: + lblcoil(ncoil) = lmnlbl(inmenu) +c Set Length, Strength and Multipole Number: + alcoil(ncoil) = pa(1) + glprod(ncoil) = -pa(2)*pa(1) + mcoil(ncoil) = nint(pa(3)) + acoil(ncoil) = pa(4) +c Set shape(*,1) +c For type 1: Quartic = slope +c type 2: Halback = a2 +c type 3: Lambertson = xlmin +c type 4 Lamb1rsth = xlmin +c type 5 Square = N.A. +c type 6 User = ifile +c type 7 FlatTop = wflat +c type 8 Thin Halbach = N.A. +c +ctm : load all 6 shape components from pa(6) through pa(11) (4/99) + do 20 j=1,6 + shape(ncoil,j) = pa(5+j) + 20 continue +c +c Increase length of String: + ztotal = ztotal + pa(1) +c Store position of center of coil: + zcoil(ncoil) = ztotal - pa(1)/2.d0 +c Get Type Number: + itype(ncoil) = nint(pa(5)) +c Move to position of next coil: +c ztotal = ztotal + pa(6) NOW done by spacers +c + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Plot multipole configuration:::: +c Option -1 in integ. +c Tlie output in file 19(?) +c F. Neri 7/28/91 +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine mulplt(zint) + use acceldata + include 'impli.inc' + include 'files.inc' + include 'multipole.inc' +cryneneriwalstrom include 'elmnts.inc' + character*11 names(10) +c + character*11 types(10) +c +c F. Neri 3/28/90 +c Names output 7/26/91 +c F. Neri +c Tlie Output 7/27/91 +c + names(1) = ' dipole' + names(2) = ' quadrupole' + names(3) = ' sextupole' + names(4) = ' octupole' +c +c type 1: Quartic +c type 2: Halback +c type 3: Lambertson +c type 4 Lamb1rsth +c type 5 Square +c type 6 User +c type 7 FlatTop +c type 8 Thin Halbach +c + types(1) = ' Quartic' + types(2) = ' RECM' + types(3) = ' Lambertson' + types(4) = ' Lamb1sth' + types(5) = ' Square' + types(6) = ' User' + types(7) = ' Flattop' + types(8) = ' Halbach' +c + zi = -xldr + zf = zint-xldr + write(jof , 101) zi, zf + write(jodf, 101) zi, zf + 101 format(1x,' Integration from ',f16.8, ' to ', f16.8) + do 2 nc = 1, ncoil + mm = mcoil(nc) + z0 = zcoil(nc) + ar = acoil(nc) + al = alcoil(nc) + z1 = z0 - (al/2.d0) + z2 = z0 + (al/2.d0) + if (mm .lt. 0 ) then + mm = -mm + write(jof ,*) lblcoil(nc) + write(jodf,*) lblcoil(nc) +c + write(jof , 102) names(mm), ar + write(jodf, 102) names(mm), ar + 102 format(' Skew',a11,' of radius ', f16.8, ' from') + write(jof , 103) z1, z2 + write(jodf, 103) z1, z2 + 103 format(' z = ',f16.8, ' to z = ', f16.8) +c Write Tlie file + write(19,*) lblcoil(nc),': multipole, ',types(itype(nc)),',' + write(19,*) ' L = ',al,', Skew, K = ', -glprod(nc)/al,',' + write(19,*) ' position = ',z1,',' + write(19,*) ' radius = ',ar,', m = ',mm + else + write(jof ,*) lblcoil(nc) + write(jodf,*) lblcoil(nc) +c + write(jof , 104) names(mm), ar + write(jodf, 104) names(mm), ar + 104 format(' ',a11,' of radius ', f16.8, ' from') +c Write Tlie file + write(jof , 103) z1, z2 + write(jodf, 103) z1, z2 + write(19,*) lblcoil(nc),': multipole, ',types(itype(nc)),',' + write(19,*) ' L = ',al,', K = ', -glprod(nc)/al,',' + write(19,*) ' position = ',z1,',' + write(19,*) ' radius = ',ar,', m = ',mm +c + endif + 2 continue + write(19,*) ' : multipolelist =(',(lblcoil(nc),',',nc=1,ncoil) + 4 continue + write(19,*) ' zmin = ',zi,', zmax = ',zf,')' + return + end +c +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine multcfq(zlength,fa,fm) +c +c option 0 in integ: translate coils to cfqd. +c this version by F. Neri, 6/27/91 +c +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' +cryneneriwalstrom include 'parm.inc' +cryneneriwalstrom include 'param.inc' + include 'dip.inc' + include 'pie.inc' + include 'gronax.inc' + include 'multipole.inc' +c calling arrays + dimension fa(monoms), fm(6,6) +c internal arrays + parameter (MAXX = 1000) + parameter (TINY=1.d-10) + dimension xv(MAXX) + dimension a(100), b(100) +c + dimension qa(monoms), qm(6,6) +c + xv(1) = 0.d0 + nx = 1 +c + nx = nx+1 + if( nx.gt. MAXX) goto 111 + xv(nx) = zlength +c + do 1 j = 1, ncoil + do 12 i = 1,nx + if(abs(xldr+zcoil(j)-alcoil(j)/2.d0-xv(i)).lt.TINY) goto 100 + 12 continue +c + nx = nx+1 + if( nx.gt. MAXX) goto 111 + xv(nx) = xldr+zcoil(j)-alcoil(j)/2.d0 +c + 100 continue +c + do 22 i = 1,nx + if(abs(xldr+zcoil(j)+alcoil(j)/2.d0-xv(i)).lt.TINY) goto 200 + 22 continue +c + nx = nx+1 + if( nx.gt. MAXX) goto 111 + xv(nx) = xldr+zcoil(j)+alcoil(j)/2.d0 +c + 200 continue + 1 continue +c +c Sort xv +c + call piksrt(nx,xv) +c + call clear(fa,fm) +c + do 444 j = 1,6 + fm(j,j) = 1.d0 + 444 continue +c + + do 3 i = 1, nx-1 + alen = xv(i+1)-xv(i) + xpos = (xv(i+1)+xv(i))/2.d0 + do 32 m = 1, 4 + a(m) = 0.0d0 + b(m) = 0.0d0 + 32 continue +c + do 31 j = 1, ncoil + if(xpos.gt.zcoil(j)-alcoil(j)/2.d0+xldr + # .and.xpos.lt.zcoil(j)+alcoil(j)/2.d0+xldr) then + if (mcoil(j) .gt. 0 ) then + b(mcoil(j)) = b(mcoil(j))-glprod(j)/alcoil(j) + else + a(-mcoil(j)) = a(-mcoil(j))-glprod(j)/alcoil(j) + endif + endif + 31 continue + write(6,113) alen,b(2),b(3),b(4) + 113 format(1x,4(1x,1pg16.8)) + call gcfqd(alen, b, a, qa, qm, 1, 1) +c call pcmap(3, 0, 0 ,0, qa, qm) + call concat(fa,fm,qa,qm,fa,fm) + 3 continue + return + 111 write(6,*) ' MAXX exceeded in integ CFQD interpreter!' + call myexit + return + end +c +c +c + SUBROUTINE PIKSRT(N,ARR) + include 'impli.inc' + DIMENSION ARR(N) + DO 12 J=2,N + A=ARR(J) + DO 11 I=J-1,1,-1 + IF(ARR(I).LE.A)GO TO 10 + ARR(I+1)=ARR(I) +11 CONTINUE + I=0 +10 ARR(I+1)=A +12 CONTINUE + RETURN + END +c +c + subroutine a3(q,x0,y0) + use beamdata + use lieaparam, only : monoms + include 'impli.inc' +cryneneriwalstrom include 'parm.inc' +cryneneriwalstrom include 'param.inc' + include 'vecpot.inc' + include 'gronax.inc' + include 'prodex.inc' +c + double precision AAx(0:10,0:10),AAy(0:10,0:10),AAz(0:10,0:10) + double precision a(0:10,0:10) +c + do 101 i = 0,10 + do 101 j = 0,10 + AAx(i,j) = 0.0d0 + AAy(i,j) = 0.0d0 + AAz(i,j) = 0.0d0 + 101 continue +c + AAz(1,0)=-(q*gn(1,0)) + AAz(0,1)=q*gs(1,0) + AAx(2,0)=q*gn(1,1) + AAz(2,0)=-(q*gn(2,0)) + AAx(1,1)=-(q*gs(1,1)) + AAy(1,1)=q*gn(1,1) + AAz(1,1)=2*q*gs(2,0) + AAy(0,2)=-(q*gs(1,1)) + AAz(0,2)=q*gn(2,0) + AAx(3,0)=q*gn(2,1)/2 + AAz(3,0)=3*q*gn(1,2)/8 - q*gn(3,0) + AAx(2,1)=-(q*gs(2,1)) + AAy(2,1)=q*gn(2,1)/2 + AAz(2,1)=-3*q*gs(1,2)/8 + 3*q*gs(3,0) + AAx(1,2)=-(q*gn(2,1))/2 + AAy(1,2)=-(q*gs(2,1)) + AAz(1,2)=3*q*gn(1,2)/8 + 3*q*gn(3,0) + AAy(0,3)=-(q*gn(2,1))/2 + AAz(0,3)=-3*q*gs(1,2)/8 - q*gs(3,0) + AAx(4,0)=-(q*gn(1,3))/8 + q*gn(3,1)/3 + AAz(4,0)=q*gn(2,2)/6 - q*gn(4,0) + AAx(3,1)=q*gs(1,3)/8 - q*gs(3,1) + AAy(3,1)=-(q*gn(1,3))/8 + q*gn(3,1)/3 + AAz(3,1)=-(q*gs(2,2))/3 + 4*q*gs(4,0) + AAx(2,2)=-(q*gn(1,3))/8 - q*gn(3,1) + AAy(2,2)=q*gs(1,3)/8 - q*gs(3,1) + AAz(2,2)=6*q*gn(4,0) + AAx(1,3)=q*gs(1,3)/8 + q*gs(3,1)/3 + AAy(1,3)=-(q*gn(1,3))/8 - q*gn(3,1) + AAz(1,3)=-(q*gs(2,2))/3 - 4*q*gs(4,0) + AAy(0,4)=q*gs(1,3)/8 + q*gs(3,1)/3 + AAz(0,4)=-(q*gn(2,2))/6 - q*gn(4,0) + AAx(5,0)=-(q*gn(2,3))/24 + q*gn(4,1)/4 + AAz(5,0)=-5*q*gn(1,4)/192 + 5*q*gn(3,2)/48 - q*gn(5,0) + AAx(4,1)=q*gs(2,3)/12 - q*gs(4,1) + AAy(4,1)=-(q*gn(2,3))/24 + q*gn(4,1)/4 + AAz(4,1)=5*q*gs(1,4)/192 - 5*q*gs(3,2)/16 + 5*q*gs(5,0) + AAx(3,2)=-3*q*gn(4,1)/2 + AAy(3,2)=q*gs(2,3)/12 - q*gs(4,1) + AAz(3,2)=-5*q*gn(1,4)/96 - 5*q*gn(3,2)/24 + 10*q*gn(5,0) + AAx(2,3)=q*gs(2,3)/12 + q*gs(4,1) + AAy(2,3)=-3*q*gn(4,1)/2 + AAz(2,3)=5*q*gs(1,4)/96 - 5*q*gs(3,2)/24 - 10*q*gs(5,0) + AAx(1,4)=q*gn(2,3)/24 + q*gn(4,1)/4 + AAy(1,4)=q*gs(2,3)/12 + q*gs(4,1) + AAz(1,4)=-5*q*gn(1,4)/192 - 5*q*gn(3,2)/16 - 5*q*gn(5,0) + AAy(0,5)=q*gn(2,3)/24 + q*gn(4,1)/4 + AAz(0,5)=5*q*gs(1,4)/192 + 5*q*gs(3,2)/48 + q*gs(5,0) + AAx(6,0)=q*gn(1,5)/192 - q*gn(3,3)/48 + q*gn(5,1)/5 + AAz(6,0)=-(q*gn(2,4))/128 + 3*q*gn(4,2)/40 - q*gn(6,0) + AAx(5,1)=-(q*gs(1,5))/192 + q*gs(3,3)/16 - q*gs(5,1) + AAy(5,1)=q*gn(1,5)/192 - q*gn(3,3)/48 + q*gn(5,1)/5 + AAz(5,1)=q*gs(2,4)/64 - 3*q*gs(4,2)/10 + 6*q*gs(6,0) + AAx(4,2)=q*gn(1,5)/96 + q*gn(3,3)/24 - 2*q*gn(5,1) + AAy(4,2)=-(q*gs(1,5))/192 + q*gs(3,3)/16 - q*gs(5,1) + AAz(4,2)=-(q*gn(2,4))/128 - 3*q*gn(4,2)/8 + 15*q*gn(6,0) + AAx(3,3)=-(q*gs(1,5))/96 + q*gs(3,3)/24 + 2*q*gs(5,1) + AAy(3,3)=q*gn(1,5)/96 + q*gn(3,3)/24 - 2*q*gn(5,1) + AAz(3,3)=q*gs(2,4)/32 - 20*q*gs(6,0) + AAx(2,4)=q*gn(1,5)/192 + q*gn(3,3)/16 + q*gn(5,1) + AAy(2,4)=-(q*gs(1,5))/96 + q*gs(3,3)/24 + 2*q*gs(5,1) + AAz(2,4)=q*gn(2,4)/128 - 3*q*gn(4,2)/8 - 15*q*gn(6,0) + AAx(1,5)=-(q*gs(1,5))/192 - q*gs(3,3)/48 - q*gs(5,1)/5 + AAy(1,5)=q*gn(1,5)/192 + q*gn(3,3)/16 + q*gn(5,1) + AAz(1,5)=q*gs(2,4)/64 + 3*q*gs(4,2)/10 + 6*q*gs(6,0) + AAy(0,6)=-(q*gs(1,5))/192 - q*gs(3,3)/48 - q*gs(5,1)/5 + AAz(0,6)=q*gn(2,4)/128 + 3*q*gn(4,2)/40 + q*gn(6,0) + AAx(7,0)=q*gn(2,5)/768 - q*gn(4,3)/80 + q*gn(6,1)/6 + AAz(7,0)=7*q*gn(1,6)/9216 - 7*q*gn(3,4)/1920 + + - 7*q*gn(5,2)/120 + AAx(6,1)=-(q*gs(2,5))/384 + q*gs(4,3)/20 - q*gs(6,1) + AAy(6,1)=q*gn(2,5)/768 - q*gn(4,3)/80 + q*gn(6,1)/6 + AAz(6,1)=-7*q*gs(1,6)/9216 + 7*q*gs(3,4)/640 - + - 7*q*gs(5,2)/24 + AAx(5,2)=q*gn(2,5)/768 + q*gn(4,3)/16 - 5*q*gn(6,1)/2 + AAy(5,2)=-(q*gs(2,5))/384 + q*gs(4,3)/20 - q*gs(6,1) + AAz(5,2)=7*q*gn(1,6)/3072 + 7*q*gn(3,4)/1920 - + - 21*q*gn(5,2)/40 + AAx(4,3)=-(q*gs(2,5))/192 + 10*q*gs(6,1)/3 + AAy(4,3)=q*gn(2,5)/768 + q*gn(4,3)/16 - 5*q*gn(6,1)/2 + AAz(4,3)=-7*q*gs(1,6)/3072 + 7*q*gs(3,4)/384 + + - 7*q*gs(5,2)/24 + AAx(3,4)=-(q*gn(2,5))/768 + q*gn(4,3)/16 + 5*q*gn(6,1)/2 + AAy(3,4)=-(q*gs(2,5))/192 + 10*q*gs(6,1)/3 + AAz(3,4)=7*q*gn(1,6)/3072 + 7*q*gn(3,4)/384 - + - 7*q*gn(5,2)/24 + AAx(2,5)=-(q*gs(2,5))/384 - q*gs(4,3)/20 - q*gs(6,1) + AAy(2,5)=-(q*gn(2,5))/768 + q*gn(4,3)/16 + 5*q*gn(6,1)/2 + AAz(2,5)=-7*q*gs(1,6)/3072 + 7*q*gs(3,4)/1920 + + - 21*q*gs(5,2)/40 + AAx(1,6)=-(q*gn(2,5))/768 - q*gn(4,3)/80 - q*gn(6,1)/6 + AAy(1,6)=-(q*gs(2,5))/384 - q*gs(4,3)/20 - q*gs(6,1) + AAz(1,6)=7*q*gn(1,6)/9216 + 7*q*gn(3,4)/640 + + - 7*q*gn(5,2)/24 + AAy(0,7)=-(q*gn(2,5))/768 - q*gn(4,3)/80 - q*gn(6,1)/6 + AAz(0,7)=-7*q*gs(1,6)/9216 - 7*q*gs(3,4)/1920 - + - 7*q*gs(5,2)/120 + AAx(8,0)=-(q*gn(1,7))/9216 + q*gn(3,5)/1920 - q*gn(5,3)/120 + AAz(8,0)=q*gn(2,6)/5760 - q*gn(4,4)/480 + q*gn(6,2)/21 + AAx(7,1)=q*gs(1,7)/9216 - q*gs(3,5)/640 + q*gs(5,3)/24 + AAy(7,1)=-(q*gn(1,7))/9216 + q*gn(3,5)/1920 - q*gn(5,3)/120 + AAz(7,1)=-(q*gs(2,6))/2880 + q*gs(4,4)/120 - 2*q*gs(6,2)/7 + AAx(6,2)=-(q*gn(1,7))/3072 - q*gn(3,5)/1920 + + - 3*q*gn(5,3)/40 + AAy(6,2)=q*gs(1,7)/9216 - q*gs(3,5)/640 + q*gs(5,3)/24 + AAz(6,2)=q*gn(2,6)/2880 + q*gn(4,4)/120 - 2*q*gn(6,2)/3 + AAx(5,3)=q*gs(1,7)/3072 - q*gs(3,5)/384 - q*gs(5,3)/24 + AAy(5,3)=-(q*gn(1,7))/3072 - q*gn(3,5)/1920 + + - 3*q*gn(5,3)/40 + AAz(5,3)=-(q*gs(2,6))/960 + q*gs(4,4)/120 + 2*q*gs(6,2)/3 + AAx(4,4)=-(q*gn(1,7))/3072 - q*gn(3,5)/384 + q*gn(5,3)/24 + AAy(4,4)=q*gs(1,7)/3072 - q*gs(3,5)/384 - q*gs(5,3)/24 + AAz(4,4)=q*gn(4,4)/48 + AAx(3,5)=q*gs(1,7)/3072 - q*gs(3,5)/1920 - 3*q*gs(5,3)/40 + AAy(3,5)=-(q*gn(1,7))/3072 - q*gn(3,5)/384 + q*gn(5,3)/24 + AAz(3,5)=-(q*gs(2,6))/960 - q*gs(4,4)/120 + 2*q*gs(6,2)/3 + AAx(2,6)=-(q*gn(1,7))/9216 - q*gn(3,5)/640 - q*gn(5,3)/24 + AAy(2,6)=q*gs(1,7)/3072 - q*gs(3,5)/1920 - 3*q*gs(5,3)/40 + AAz(2,6)=-(q*gn(2,6))/2880 + q*gn(4,4)/120 + 2*q*gn(6,2)/3 + AAx(1,7)=q*gs(1,7)/9216 + q*gs(3,5)/1920 + q*gs(5,3)/120 + AAy(1,7)=-(q*gn(1,7))/9216 - q*gn(3,5)/640 - q*gn(5,3)/24 + AAz(1,7)=-(q*gs(2,6))/2880 - q*gs(4,4)/120 - 2*q*gs(6,2)/7 + AAy(0,8)=q*gs(1,7)/9216 + q*gs(3,5)/1920 + q*gs(5,3)/120 + AAz(0,8)=-(q*gn(2,6))/5760 - q*gn(4,4)/480 - q*gn(6,2)/21 + AAx(9,0)=-(q*gn(2,7))/46080 + q*gn(4,5)/3840 - + - q*gn(6,3)/168 + AAz(9,0)=-(q*gn(1,8))/81920 + q*gn(3,6)/15360 - + - 3*q*gn(5,4)/2240 + AAx(8,1)=q*gs(2,7)/23040 - q*gs(4,5)/960 + q*gs(6,3)/28 + AAy(8,1)=-(q*gn(2,7))/46080 + q*gn(4,5)/3840 - + - q*gn(6,3)/168 + AAz(8,1)=q*gs(1,8)/81920 - q*gs(3,6)/5120 + 3*q*gs(5,4)/448 + AAx(7,2)=-(q*gn(2,7))/23040 - q*gn(4,5)/960 + q*gn(6,3)/12 + AAy(7,2)=q*gs(2,7)/23040 - q*gs(4,5)/960 + q*gs(6,3)/28 + AAz(7,2)=-(q*gn(1,8))/20480 + 3*q*gn(5,4)/280 + AAx(6,3)=q*gs(2,7)/7680 - q*gs(4,5)/960 - q*gs(6,3)/12 + AAy(6,3)=-(q*gn(2,7))/23040 - q*gn(4,5)/960 + q*gn(6,3)/12 + AAz(6,3)=q*gs(1,8)/20480 - q*gs(3,6)/1920 + AAx(5,4)=-(q*gn(4,5))/384 + AAy(5,4)=q*gs(2,7)/7680 - q*gs(4,5)/960 - q*gs(6,3)/12 + AAz(5,4)=-3*q*gn(1,8)/40960 - q*gn(3,6)/2560 + + - 3*q*gn(5,4)/160 + AAx(4,5)=q*gs(2,7)/7680 + q*gs(4,5)/960 - q*gs(6,3)/12 + AAy(4,5)=-(q*gn(4,5))/384 + AAz(4,5)=3*q*gs(1,8)/40960 - q*gs(3,6)/2560 - + - 3*q*gs(5,4)/160 + AAx(3,6)=q*gn(2,7)/23040 - q*gn(4,5)/960 - q*gn(6,3)/12 + AAy(3,6)=q*gs(2,7)/7680 + q*gs(4,5)/960 - q*gs(6,3)/12 + AAz(3,6)=-(q*gn(1,8))/20480 - q*gn(3,6)/1920 + AAx(2,7)=q*gs(2,7)/23040 + q*gs(4,5)/960 + q*gs(6,3)/28 + AAy(2,7)=q*gn(2,7)/23040 - q*gn(4,5)/960 - q*gn(6,3)/12 + AAz(2,7)=q*gs(1,8)/20480 - 3*q*gs(5,4)/280 + AAx(1,8)=q*gn(2,7)/46080 + q*gn(4,5)/3840 + q*gn(6,3)/168 + AAy(1,8)=q*gs(2,7)/23040 + q*gs(4,5)/960 + q*gs(6,3)/28 + AAz(1,8)=-(q*gn(1,8))/81920 - q*gn(3,6)/5120 - + - 3*q*gn(5,4)/448 + AAy(0,9)=q*gn(2,7)/46080 + q*gn(4,5)/3840 + q*gn(6,3)/168 + AAz(0,9)=q*gs(1,8)/81920 + q*gs(3,6)/15360 + + - 3*q*gs(5,4)/2240 + AAx(10,0)=q*gn(1,9)/737280 - q*gn(3,7)/138240 + + - q*gn(5,5)/6720 + AAz(10,0)=-(q*gn(2,8))/442368 + q*gn(4,6)/32256 - + - 5*q*gn(6,4)/5376 + AAx(9,1)=-(q*gs(1,9))/737280 + q*gs(3,7)/46080 - + - q*gs(5,5)/1344 + AAy(9,1)=q*gn(1,9)/737280 - q*gn(3,7)/138240 + + - q*gn(5,5)/6720 + AAz(9,1)=q*gs(2,8)/221184 - q*gs(4,6)/8064 + + - 5*q*gs(6,4)/896 + AAx(8,2)=q*gn(1,9)/184320 - q*gn(5,5)/840 + AAy(8,2)=-(q*gs(1,9))/737280 + q*gs(3,7)/46080 - + - q*gs(5,5)/1344 + AAz(8,2)=-(q*gn(2,8))/147456 - q*gn(4,6)/10752 + + - 65*q*gn(6,4)/5376 + AAx(7,3)=-(q*gs(1,9))/184320 + q*gs(3,7)/17280 + AAy(7,3)=q*gn(1,9)/184320 - q*gn(5,5)/840 + AAz(7,3)=q*gs(2,8)/55296 - q*gs(4,6)/4032 - 5*q*gs(6,4)/672 + AAx(6,4)=q*gn(1,9)/122880 + q*gn(3,7)/23040 - q*gn(5,5)/480 + AAy(6,4)=-(q*gs(1,9))/184320 + q*gs(3,7)/17280 + AAz(6,4)=-(q*gn(2,8))/221184 - q*gn(4,6)/2304 + + - 5*q*gn(6,4)/384 + AAx(5,5)=-(q*gs(1,9))/122880 + q*gs(3,7)/23040 + + - q*gs(5,5)/480 + AAy(5,5)=q*gn(1,9)/122880 + q*gn(3,7)/23040 - q*gn(5,5)/480 + AAz(5,5)=q*gs(2,8)/36864 - 5*q*gs(6,4)/192 + AAx(4,6)=q*gn(1,9)/184320 + q*gn(3,7)/17280 + AAy(4,6)=-(q*gs(1,9))/122880 + q*gs(3,7)/23040 + + - q*gs(5,5)/480 + AAz(4,6)=q*gn(2,8)/221184 - q*gn(4,6)/2304 - + - 5*q*gn(6,4)/384 + AAx(3,7)=-(q*gs(1,9))/184320 + q*gs(5,5)/840 + AAy(3,7)=q*gn(1,9)/184320 + q*gn(3,7)/17280 + AAz(3,7)=q*gs(2,8)/55296 + q*gs(4,6)/4032 - 5*q*gs(6,4)/672 + AAx(2,8)=q*gn(1,9)/737280 + q*gn(3,7)/46080 + + - q*gn(5,5)/1344 + AAy(2,8)=-(q*gs(1,9))/184320 + q*gs(5,5)/840 + AAz(2,8)=q*gn(2,8)/147456 - q*gn(4,6)/10752 - + - 65*q*gn(6,4)/5376 + AAx(1,9)=-(q*gs(1,9))/737280 - q*gs(3,7)/138240 - + - q*gs(5,5)/6720 + AAy(1,9)=q*gn(1,9)/737280 + q*gn(3,7)/46080 + + - q*gn(5,5)/1344 + AAz(1,9)=q*gs(2,8)/221184 + q*gs(4,6)/8064 + + - 5*q*gs(6,4)/896 + AAy(0,10)=-(q*gs(1,9))/737280 - q*gs(3,7)/138240 - + - q*gs(5,5)/6720 + AAz(0,10)=q*gn(2,8)/442368 + q*gn(4,6)/32256 + + - 5*q*gn(6,4)/5376 +c +cryneneriwalstrom 16 July, 2004 changed "4" to maxorder +cryneneriwalstrom and set maxorder to 6 + maxorder=6 +c + call exp2f1(x0,y0,AAx,a,10) + ind1 = 0 + do 1 i = 0, maxorder + ind2 = ind1 + do 2 j = 0, maxorder-i + Ax(ind2) = a(i,j) + if (j .lt. maxorder-i) then + ind2 = prodex(3,ind2) + endif + 2 continue + if ( i .lt. maxorder ) ind1 = prodex(1,ind1) + 1 continue +c + call exp2f1(x0,y0,AAy,a,10) + ind1 = 0 + do 10 i = 0, maxorder + ind2 = ind1 + do 20 j = 0, maxorder-i + Ay(ind2) = a(i,j) + if (j .lt. maxorder-i) then + ind2 = prodex(3,ind2) + endif + 20 continue + if ( i .lt. maxorder ) ind1 = prodex(1,ind1) + 10 continue +c + call exp2f1(x0,y0,AAz,a,10) + ind1 = 0 + do 100 i = 0, maxorder + ind2 = ind1 + do 200 j = 0, maxorder-i + Az(ind2) = a(i,j) + if (j .lt. maxorder-i) then + ind2 = prodex(3,ind2) + endif + 200 continue + if ( i .lt. maxorder ) ind1 = prodex(1,ind1) + 100 continue +c + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Reexpands a Polynomial in x and y where the coefficient +c of x^i y^j is a(i,j), and a() is dimensioned as a(0:md,0:md), +c around the point x0, y0. +c The coefficients of the reexpanded polynomial are in the array +c b(0:md,0:md). +c +c F. Neri 3/29/91. +c + subroutine exp2f1(x0,y0,a,b,md) + implicit double precision (a-h,o-z) + parameter (maxd = 100) + dimension a(0:md,0:md), b(0:md,0:md) +c + dimension c(0:maxd,0:maxd), d(0:maxd), e(0:maxd) +c + do 1 i = 0, md + call expoly(a(0,i), md, x0, c(0,i), md) + 1 continue +c + do 2 i = 0, md + do 20 j = 0, md + d(j) = c(i,j) + 20 continue + call expoly(d, md, y0 ,e, md) + do 200 j = 0, md + b(i,j) = e(j) + 200 continue + 2 continue + return + end +c +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + SUBROUTINE EXPOLY(C,NC,X,PD,ND) +c +c Given the NC+1 coefficients of a polynomial of degree NC as an array C +c with C(0) being the constant term, and a given a value X, and given a +c value ND>0, this routine returns the polynomial evaluated at X as PD(0) +c and ND derivatives times ND!, as PD(1) . . . PD(ND). +c From Numerical Recipes, pag. 138 (1986 FORTRAN/Pascal version). +c + implicit double precision (a-h,o-z) + DIMENSION C(0:NC),PD(0:ND) + if ( x .ne. 0.d0 ) then + PD(0)=C(NC) + DO 11 J=1,ND + PD(J)=0.d0 + 11 CONTINUE + DO 13 I=NC-1,0,-1 + NND=MIN(ND,NC-I) + DO 12 J=NND,1,-1 + PD(J)=PD(J)*X+PD(J-1) + 12 CONTINUE + PD(0)=PD(0)*X+C(I) + 13 CONTINUE + else + do 14 i = 0, nd + pd(i) = c(i) + 14 continue + endif + RETURN + END +c +c************************************************** +c + subroutine gauleg(x1,x2,x,w,n) + implicit double precision(a-h,o-z) + dimension x(n),w(n) +c Routine from Numerical Recipes to calculate Gaussian weights and node +c for Gaussian quadrature on the interval [x1,x2]. +c x1=lower end of integration interval +c x2=upper " " " " +c x=array of gauss nodes +c w=array of gauss weights +c n=gaussian order + parameter (eps=3.d-14) + parameter( half=0.5d0) + pi=2.d0*dasin(1.d0) + m=(n+1)/2 + xm=half*(x2+x1) + xl=half*(x2-x1) + do 12 i=1,m + z=dcos(pi*(i-0.25d0)/(n+half)) + 1 continue + p1=1.d0 + p2=0.d0 + do 11 j=1,n + p3=p2 + p2=p1 + p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j + 11 continue + pp=n*(z*p1-p2)/(z*z-1.d0) + z1=z + z=z1-p1/pp + if(dabs(z-z1).gt.eps) go to 1 + x(i)=xm-xl*z + x(n+1-i)=xm+xl*z + w(i)=2.d0*xl/((1.d0-z*z)*pp*pp) + w(n+1-i)=w(i) + 12 continue + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/comm.f b/OpticsJan2020/MLI_light_optics/Src/comm.f new file mode 100755 index 0000000..fde824d --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/comm.f @@ -0,0 +1,932 @@ +************************************************************************ +* header: COMMANDS (simple) +* These modules deal with simple commands that affect maps and phase +* space data. Ray trace related commands are found in TRAC, and input +* output related commands are found in INPU. +* +* Rob Ryne 7/28/2002 +* This file was generated by taking comm.f from the 5th order version +* that Tom Mottershead and I were using and including the following +* from the ML30dev version: +* cmom, cmom5, dpol, tpol +* also, wnda and wnd were added to replace swnd and dwnd +* Note that, in cmom5 (which is not used), monoms5 has been replaced by monom +* Note also that evalm and evalm5 (not used) have been added to liea.f +************************************************************************ +c + subroutine cmom(amom,am) +c this subroutine computes the moments of the particle distribution +c stored in zblock. The second moments are put in the matrix am, and +c all the moments are put in the array amom. +c Written by Alex Dragt, 1 July 1991. +c + use rays + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension am(6,6) + dimension amom(monoms) +c +c working arrays + dimension vmon(monoms) + dimension z(6) +c +c clear amom + do 5 i=1,monoms + 5 amom(i)=0.d0 +c +c computational loop + do 10 k=1,nraysp +c get a ray + do 20 i=1,6 + 20 z(i)=zblock(i,k) +c compute moments for the ray + call evalm(z,vmon) +c add results to moment sum + do 30 i=1,monoms + 30 amom(i)=amom(i)+vmon(i) + 10 continue +c +c normalize by the number of particles + fact=1.d0/float(nrays) + do 40 i=1,monoms + 40 amom(i)=fact*amom(i) +c +c also put second moments in the matrix part am +c + am(1,1)=amom(7) + am(1,2)=amom(8) + am(1,3)=amom(9) + am(1,4)=amom(10) + am(1,5)=amom(11) + am(1,6)=amom(12) + am(2,1)=amom(8) + am(2,2)=amom(13) + am(2,3)=amom(14) + am(2,4)=amom(15) + am(2,5)=amom(16) + am(2,6)=amom(17) + am(3,1)=amom(9) + am(3,2)=amom(14) + am(3,3)=amom(18) + am(3,4)=amom(19) + am(3,5)=amom(20) + am(3,6)=amom(21) + am(4,1)=amom(10) + am(4,2)=amom(15) + am(4,3)=amom(19) + am(4,4)=amom(22) + am(4,5)=amom(23) + am(4,6)=amom(24) + am(5,1)=amom(11) + am(5,2)=amom(16) + am(5,3)=amom(20) + am(5,4)=amom(23) + am(5,5)=amom(25) + am(5,6)=amom(26) + am(6,1)=amom(12) + am(6,2)=amom(17) + am(6,3)=amom(21) + am(6,4)=amom(24) + am(6,5)=amom(26) + am(6,6)=amom(27) +c +c write(6,*)'here I am in cmom; amom(1-27)=' +c do i=1,27 +c write(6,*)i,amom(i) +c enddo +c + return + end +c +****************************************************************** +c + subroutine dpol(p,fa,fm) +c This is a subroutine for setting up a quadratic polynomial +c described in terms of dispersion parameters. +c Written by Alex Dragt, 29 March 1991 +c + use lieaparam, only : monoms + include 'impli.inc' +c + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c +c set map to the identity + call ident(fa,fm) +c +c set up polynomial + fa(12)=p(2) + fa(17)=-p(1) + fa(21)=p(4) + fa(24)=-p(3) + fa(27)=-p(5)/2.d0 +c + return + end +c +********************************************************************* +c + subroutine eapt(p) +c this is a subroutine for an elliptic aperture +c Written by Alex Dragt, Spring 1987. + use rays + include 'impli.inc' + dimension p(6) +c + smas=p(2) + raxs=p(3) + iturn=iturn+1 + do 100 k=1,nraysp + if (istat(k).ne.0) goto 100 + x=zblock(1,k) + y=zblock(3,k) + x2=x*x + y2=y*y + test=x2+raxs*y2 +c examine particle location + if (test.ge.smas) goto 10 +c particle within aperture + goto 100 + 10 continue +c particle outside aperture + istat(k)=iturn + nlost=nlost+1 + ihist(1,nlost)=iturn + ihist(2,nlost)=k + 100 continue + return + end +c +********************************************************************* +c + subroutine ftm(p,fa,fm) +c this subroutine filters transfer maps +c Written by Alex Dragt, Spring 1987. + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + dimension p(6),fa(monoms),fm(6,6) + dimension ta(monoms),tm(6,6) +c + ifile=nint(p(1)) + nopt=nint(p(2)) + nskp=nint(p(3)) + kynd=nint(p(4)) + mpitmp=mpi + mpi=ifile + call mapin(nopt,nskp,ta,tm) + mpi=mpitmp +c determine procedure + if(kynd.eq.0) goto 5 + if(kynd.eq.1) goto 15 +c procedure for normal filter + 5 continue + do 10 i=1,monoms + if(ta(i).eq.0.) fa(i)=0. + 10 continue + return +c procedure for a reversed filter + 15 continue + do 20 i=1,monoms + if(ta(i).gt.0.) fa(i)=0. + 20 continue + return + end +c +*********************************************************************** +c + subroutine ident(h,xmh) +c Written by D. Douglas, ca 1982 + use lieaparam, only : monoms + include 'impli.inc' + dimension h(monoms),xmh(6,6) + do 10 i=1,6 + do 10 j=1,6 + 10 xmh(i,j)=0. + do 15 i=1,6 + 15 xmh(i,i)=1. + do 20 i=1,monoms + 20 h(i)=0. +c + return + end +c +*********************************************************************** +c + subroutine inv(ha,hm) +c Returns the inverse of the map represented by ha,hm +c based on the reverse to Marylie order factorization +c routine cfacrm. Written 2/2/96 AJD +c + include 'impli.inc' +c +c----Variables---- +c + dimension ha(*),hm(6,6) +c +c----Routine---- +c +c Invert matrix part of map. + call minv(hm) +c Reverse sign of polynomials: + do 100 ind=1,923 + 100 ha(ind)=-ha(ind) +c Now reverse order: + call cfacrm(ha,hm) +c + return + end +c +********************************************************************* +c + subroutine mask6(wipe,h,mh) +c +c Sets higher order monomial coefficients to zero as specified by wipe +c Written by Liam Healy, Spring 1985 +c +c implicit none +c Variables +c wipe = array of flags: if nth element is less than 0.5, nth order is +c set to the identity map + double precision wipe(*) +c h, mh = polynomial and matrix (input and output) + double precision h(*),mh(6,6) +c ord = order of polynomial + integer ord +c + include 'maxcat.inc' + include 'lims.inc' +c +c----Routine---- + if (wipe(1).le.0.5) then + do 100 i=1,6 + do 100 j=1,6 + 100 mh(i,j)=0. + do 120 i=1,6 + 120 mh(i,i)=1. + endif + do 200 ord=2,ordcat + if (wipe(ord).le.0.5) then + do 140 i=bottom(ord),top(ord) + 140 h(i)=0. + endif + 200 continue + return + end +c +********************************************************************* +c + subroutine mask(akeep,ha,hm) +c +c Keeps or removes portions of the map as specified by akeep. +c Written by A. Dragt 2/3/96 to work thru f6. +c + include 'impli.inc' + include 'maxcat.inc' + include 'lims.inc' +c +cryne 12/31/2004: + integer keep +c +c Variables +c +c akeep = array of flags: + dimension akeep(*) +c ha, hm = polynomial and matrix (input and output) + dimension ha(*),hm(6,6) +c keep = integer version of akeep + dimension keep(6) +c +c----Routine---- +c +c set up keep + do 10 i=1,6 + 10 keep(i) = nint(akeep(i)) +c +c mask the map order by order +c +c f1 contents: + if (keep(1) .eq. 0) then + do 100 i=1,6 + 100 ha(i) = 0.d0 + endif +c f2 and matrix contents: + if (keep(2) .eq. 0) then + do 200 i=7,27 + 200 ha(i) = 0.d0 + call mident(hm) + endif +c f3 contents: + if (keep(3) .eq. 0) then + do 300 i=28,83 + 300 ha(i) = 0.d0 + endif +c f4 contents: + if (keep(4) .eq. 0) then + do 400 i=84,209 + 400 ha(i) = 0.d0 + endif +c f5 contents: + if (keep(5) .eq. 0) then + do 500 i=210,461 + 500 ha(i) = 0.d0 + endif +c f6 contents: + if (keep(6) .eq. 0) then + do 600 i=462,923 + 600 ha(i) = 0.d0 + endif +c + return + end +c +*********************************************************************** +c + subroutine mtran(mh) +c Takes the transpose of the matrix mh. +c Written by Liam Healy, April 16, 1985. +c implicit none + double precision mh(6,6),hold + integer i,j +c +c----Routine---- + do 100 i=1,6 + do 100 j=1,i-1 + hold=mh(j,i) + mh(j,i)=mh(i,j) + mh(i,j)=hold + 100 continue + return + end +c +*********************************************************************** +c + subroutine rapt(p) +c this is a subroutine for a rectangular aperture +c Written by Alex Dragt, Spring 1987. + use beamdata + use rays + include 'impli.inc' + dimension p(*) +c +c if(idproc.eq.0)then +c write(6,*)'inside rectangular aperture routine' +c endif + xmin=p(1) + xmax=p(2) + ymin=p(3) + ymax=p(4) + iturn=iturn+1 + do 100 k=1,nraysp + if (istat(k).ne.0) goto 100 + x=sl*zblock(1,k) + y=sl*zblock(3,k) +c examine particle location + if (x.le.xmin) goto 10 + if (x.ge.xmax) goto 10 + if (y.le.ymin) goto 10 + if (y.ge.ymax) goto 10 +c particle within aperture + goto 100 + 10 continue +c particle outside aperture + write(6,*)'particle #',k,' from proc ',idproc,' is lost' + istat(k)=iturn + nlost=nlost+1 + ihist(1,nlost)=iturn + ihist(2,nlost)=k + 100 continue + return + end +c +*********************************************************************** +c + subroutine rev(h,mh) +c This is a subroutine for reversing a map. +c Written by Alex Dragt on Friday, 13 Sept 1985. + use lieaparam, only : monoms +c implicit none + include 'expon.inc' +c + double precision h(*),mh(6,6) + double precision temp(6,6) + double precision r(6,6) +c Define the reversing matrix r by a set of data statements: + data (r(1,j),j=1,6)/ 1.d0, 0.d0, 0.d0, 0.d0, 0.d0, 0.d0/ + data (r(2,j),j=1,6)/ 0.d0,-1.d0, 0.d0, 0.d0, 0.d0, 0.d0/ + data (r(3,j),j=1,6)/ 0.d0, 0.d0, 1.d0, 0.d0, 0.d0, 0.d0/ + data (r(4,j),j=1,6)/ 0.d0, 0.d0, 0.d0,-1.d0, 0.d0, 0.d0/ + data (r(5,j),j=1,6)/ 0.d0, 0.d0, 0.d0, 0.d0,-1.d0, 0.d0/ + data (r(6,j),j=1,6)/ 0.d0, 0.d0, 0.d0, 0.d0, 0.d0, 1.d0/ + save r +c----Routine---- +c Compute inverse map: + call inv(h,mh) +c Reverse matrix portion of map: + call mmult (r,mh,temp) + call mmult (temp,r,mh) +c Reverse polynomial portion of map: +c For now, work only with n in the interval [28,209]. +c Change range of n later when f1's are implemented. + do 10 n=28,209 + n2 = expon(2,n) + n4 = expon(4,n) + n5 = expon(5,n) + m = n2+n4+n5 + mm2 = mod(m,2) + if (mm2.eq.0) h(n)=-h(n) + 10 continue + return + end +c +*********************************************************************** +c + subroutine revf(iord,ha,hm) +c Changes the order of factorization. +c If iord=0, it is assumed that the map specified by ha,hm is in the +c standard MARYLIE order exp(:f2:)exp(:f3:)exp(:f4).... This +c routine will then return g3,g4... corresponding to the factorization +c ...exp(:g4:)exp(:g3:)exp(:f2:). +c If iord=1, it is assumed that the map specified by ha,hm is in +c reversed order. This routine then returns the standard +c MARYLIE order. Written by Alex Dragt 1/31/96 +c + include 'impli.inc' +c +c----Variables---- +c + dimension ha(*),hm(6,6) +c +c----Routine---- +c + if(iord.gt.0) then +c +c----Procedure for going from reversed order to MARYLIE order: +c + call cfacrm(ha,hm) +c + else +c +c----Procedure for going from MARYLIE order to reversed order: +c + call cfacmr(ha,hm) +c + endif +c + return + end +c +*********************************************************************** +c + subroutine cfacmr(ha,hm) +c Changes the order of factorization from Marylie to reversed order +c using the inversion routine. +c Written by Alex Dragt 1/31/96 +c +c----Variables---- +c + include 'impli.inc' +c + dimension ha(*),hm(6,6) + dimension ha1(923),hm1(6,6) + dimension ha2(923),hm2(6,6) +c +c----Routine---- +c +c----Procedure for going from MARYLIE order to reversed order: +c +c Clear ha1,hm1 + call clear(ha1,hm1) +c Copy hm into hm1 + call matmat(hm,hm1) +c Invert the map ha,hm + call inv(ha,hm) +c Concatenate with the map ha1,hm1 + call concat(ha1,hm1,ha,hm,ha2,hm2) +c Change signs of monomials + do 120 ind=1,923 + 120 ha(ind)=-ha2(ind) +c Replace current hm with its original version, hm1 + call matmat(hm1,hm) +c + return + end +c +*********************************************************************** +c + subroutine cfacrm(ha,hm) +c Changes the order of factorization from reversed to +c Marylie order using the concatenator. +c Written by Alex Dragt 1/31/96 +c +c----Variables---- +c + include 'impli.inc' +c + dimension ha(923),hm(6,6) + dimension ha1(923),hm1(6,6) + dimension ha2(923),hm2(6,6) + dimension ha3(923),hm3(6,6) + dimension akeep(6) +c +c----Routine---- +c +c----Procedure for going from reversed order to MARYLIE order: +c--- This should work thru 6th order (AJD) +c +c get only matrix part + call mapmap(ha,hm,ha1,hm1) + akeep(1)=0. + akeep(2)=1.d0 + akeep(3)=0. + akeep(4)=0. + akeep(5)=0. + akeep(6)=0. + call mask(akeep,ha1,hm1) +c get only g3 part + call mapmap(ha,hm,ha2,hm2) + akeep(1)=0. + akeep(2)=0. + akeep(3)=1.d0 + akeep(4)=0. + akeep(5)=0. + akeep(6)=0. + call mask(akeep,ha2,hm2) +c concatenate exp(:g3:)exp(:g2:) + call concat(ha2,hm2,ha1,hm1,ha3,hm3) +c store result in ha1,hm1 + call mapmap(ha3,hm3,ha1,hm1) +c get only g4 part + call mapmap(ha,hm,ha2,hm2) + akeep(1)=0. + akeep(2)=0. + akeep(3)=0. + akeep(4)=1.d0 + akeep(5)=0. + akeep(6)=0. + call mask(akeep,ha2,hm2) +c concatenate exp(:g4:)exp(:g3:)exp(:g2:) + call concat(ha2,hm2,ha1,hm1,ha3,hm3) +c store result in ha1,hm1 + call mapmap(ha3,hm3,ha1,hm1) +c write(6,*) 'result after g4' +c call pcmap(1,1,0,0,ha1,hm1) +c get only g5 part + call mapmap(ha,hm,ha2,hm2) + akeep(1)=0. + akeep(2)=0. + akeep(3)=0. + akeep(4)=0. + akeep(5)=1.d0 + akeep(6)=0. + call mask(akeep,ha2,hm2) +c write(6,*) 'first factor' +c call pcmap(1,1,0,0,ha2,hm2) +c write(6,*) 'second factor' +c call pcmap(1,1,0,0,ha1,hm1) +c concatenate exp(:g5:)exp(:g4:)exp(:g3:)exp(:g2:) + call concat(ha2,hm2,ha1,hm1,ha3,hm3) +c write(6,*) 'result after concat' +c call pcmap(1,1,0,0,ha3,hm3) +c store result in ha1,hm1 + call mapmap(ha3,hm3,ha1,hm1) +c write(6,*) 'result after g5 mapmap' +c call pcmap(1,1,0,0,ha1,hm1) +c get only g6 part + call mapmap(ha,hm,ha2,hm2) + akeep(1)=0. + akeep(2)=0. + akeep(3)=0. + akeep(4)=0. + akeep(5)=0. + akeep(6)=1.d0 + call mask(akeep,ha2,hm2) +c write(6,*) 'result after g6 mask' +c call pcmap(1,1,0,0,ha2,hm2) +c concatenate exp(:g6:)exp(:g5:)exp(:g4:)exp(:g3:)exp(:g2:) +c and put result in ha,hm. + call concat(ha2,hm2,ha1,hm1,ha,hm) +c + end +c +*********************************************************************** +c + subroutine strget(kynd,nmap,fa,fm) +cryne 12/15/2004 modified to use new common block structure of stmap.inc +c +c This is a subroutine for storing and getting maps. +c A total of 5 maps can be stored and retrieved. +c The incoming and outgoing maps are represented by fa,fm. +c In the store mode, the maps are stored in sf1,sm1 to sf5,sm5. +c In the retrieve mode, the map is gotten from sf1,sm1 to sf5,sm5. +c The maps sf1,sm1 to sf5,sm5 are stored in the block common stmap. +c Written by Alex Dragt, Spring 1987. Modified 10/13/88 AJD. +c + use lieaparam, only : monoms + use parallel + include 'impli.inc' + include 'files.inc' + include 'stmap.inc' + character*3 kynd +c +c Calling arrays + dimension fa(monoms),fm(6,6) +c +c +cryne fix later so that "20" is not hardwired + if(nmap.gt.20)then + if(idproc.eq.0)write(6,*)'ERROR: too many stored maps' + if(idproc.eq.0)write(6,*)'nmap=',nmap + call myexit + endif +c + if (kynd.eq.'gtm') goto 100 +c Procedure for storing maps: + write(jof,400) nmap + 400 format(1x,'map stored in location',2x,i2) +! goto(10,20,30,40,50),nmap +! 10 call mapmap(fa,fm,sf1,sm1) +! return +! 20 call mapmap(fa,fm,sf2,sm2) +! return +! 30 call mapmap(fa,fm,sf3,sm3) +! return +! 40 call mapmap(fa,fm,sf4,sm4) +! return +! 50 call mapmap(fa,fm,sf5,sm5) + call mapmap(fa,fm,storedpoly(1,nmap),storedmat(1,1,nmap)) + return +c +c Procedure for getting maps: + 100 continue +!!!!! write(jof,450) nmap +!!!!! 450 format(1x,'map gotten from location',2x,i2) +! goto(110,120,130,140,150),nmap +! 110 call mapmap(sf1,sm1,fa,fm) +! return +! 120 call mapmap(sf2,sm2,fa,fm) +! return +! 130 call mapmap(sf3,sm3,fa,fm) +! return +! 140 call mapmap(sf4,sm4,fa,fm) +! return +! 150 call mapmap(sf5,sm5,fa,fm) + call mapmap(storedpoly(1,nmap),storedmat(1,1,nmap),fa,fm) +c + return + end +c +********************************************************************* +c + subroutine sympl(itype,fa,fm) +c This is a symplectification subroutine +c Written by Alex Dragt, Spring 1987. + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),fm(6,6) +c + if (itype.eq.1) call sympl1(fm) + if (itype.eq.2) call sympl2(fm) + if (itype.eq.3) call sympl3(fm) +c + return + end +c +********************************************************************* +c + subroutine tpol(p,fa,fm) +c This is a subroutine for computing a quadratic polynomial +c described in terms of twiss parameters. +c Written by Alex Dragt, 21 December 1990 + include 'impli.inc' + include 'param.inc' + dimension p(6) + dimension fa(monoms),fm(6,6) +c----- +c set map to the identity + call ident(fa,fm) +c set up twiss parameters + ax=p(1) + bx=p(2) + ay=p(3) + by=p(4) + at=p(5) + bt=p(6) + if(bx .gt. 0.d0) gx=(1.+ax*ax)/bx + if(by .gt. 0.d0) gy=(1.+ay*ay)/by + if(bt .gt. 0.d0) gt=(1.+at*at)/bt + if (bx .le. 0.) then + ax=0. + bx=0. + gx=0. + endif + if (by .le. 0.) then + ay=0. + by=0. + gy=0. + endif + if (bt .le. 0.) then + at=0. + bt=0. + gt=0. + endif +c set up polynomial + fa(7)=gx + fa(8)=2.d0*ax + fa(13)=bx + fa(18)=gy + fa(19)=2.d0*ay + fa(22)=by + fa(25)=gt + fa(26)=2.d0*at + fa(27)=bt + return + end +c +c********************************************************************** +c + subroutine wnd(pp) +c this is a subroutine for windowing tracking results in +c all six variables. +c Written by Alex Dragt, 12 January 1991. + use rays + include 'impli.inc' + dimension pp(6) +c +c set up control parameters + iplane=nint(pp(1)) + if ((iplane .lt. 1) .or. (iplane .gt. 3)) then + write(6,*) 'iplane out of range in wnd' + return + endif + icon=2*(iplane - 1) + qmin=pp(2) + qmax=pp(3) + pmin=pp(4) + pmax=pp(5) +c + iturn=iturn+1 + do 100 k=1,nrays + if (istat(k).ne.0) goto 100 +c examine particle + q=zblock(1+icon,k) + p=zblock(2+icon,k) + if (q.lt.qmin .or. q.gt.qmax + & .or. p.lt.pmin .or. p.gt.pmax) + & then +c particle outside window + istat(k)=iturn + nlost=nlost+1 + ihist(1,nlost)=iturn + ihist(2,nlost)=k + endif + 100 continue + return + end +c +*********************************************************************** +c + subroutine wnda(p) +c this is a subroutine for windowing tracking results in all planes +c simultaneously. +c Written by Alex Dragt, Spring 1987. + use rays + include 'impli.inc' + dimension p(6) +c + iturn=iturn+1 + do 100 k=1,nraysp + if (istat(k).ne.0) goto 100 +c examine particle location + ax=abs(zblock(1,k)) + apx=abs(zblock(2,k)) + ay=abs(zblock(3,k)) + apy=abs(zblock(4,k)) + at=abs(zblock(5,k)) + apt=abs(zblock(6,k)) + if (ax.gt.p(1) .or. apx.gt.p(2) + & .or. ay.gt.p(3) .or. apy.gt.p(4) + & .or. at.gt.p(5) .or. apt.gt.p(6)) + & then +c particle outside window + istat(k)=iturn + nlost=nlost+1 + ihist(1,nlost)=iturn + ihist(2,nlost)=k + endif + 100 continue + return + end +c +c end of file +c +c *************the remaining routines are no longer needed************** +c + subroutine cmom5(amom) +c this subroutine computes the moments of the particle distribution +c stored in zblock. The moments are put in the array amom. +c Written by Alex Dragt, 1 July 1991. +c Modified to generate <5> and <6>, by Johannes van Zeijts, 11 November 1991. +c + use rays + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension amom(monoms) +c +c working arrays + dimension vmon(monoms) + dimension z(6) +c +c clear amom + do 5 i=1,monoms + 5 amom(i)=0.d0 +c +c computational loop + do 10 k=1,nraysp +c get a ray + do 20 i=1,6 + 20 z(i)=zblock(i,k) +c compute moments for the ray +cryne call evalm5(z,vmon) + call evalm(z,vmon) +c add results to moment sum + do 30 i=1,monoms + 30 amom(i)=amom(i)+vmon(i) + 10 continue +c +c normalize by the number of particles + fact=1.d0/float(nrays) + do 40 i=1,monoms + 40 amom(i)=fact*amom(i) +c + return + end +c +********************************************************************* +c + subroutine dwnd(p) +c this is a subroutine for windowing tracking results from a dynamic ma +c Written by Alex Dragt, Spring 1987. + use rays + include 'impli.inc' + dimension p(6) +c + iturn=iturn+1 + do 100 k=1,nraysp + if (istat(k).ne.0) goto 100 +c examine particle location + ax=abs(zblock(1,k)) + apx=abs(zblock(2,k)) + ay=abs(zblock(3,k)) + apy=abs(zblock(4,k)) + at=abs(zblock(5,k)) + apt=abs(zblock(6,k)) + if (ax.gt.p(1) .or. apx.gt.p(2) + & .or. ay.gt.p(3) .or. apy.gt.p(4) + & .or. at.gt.p(5) .or. apt.gt.p(6)) + & then +c particle outside window + istat(k)=iturn + nlost=nlost+1 + ihist(1,nlost)=iturn + ihist(2,nlost)=k + endif + 100 continue + return + end +c +********************************************************************* +c + subroutine swnd(p) +c this is a subroutine for windowing tracking results from a static map +c Written by Alex Dragt, Spring 1987. + use rays + include 'impli.inc' + dimension p(6) +c + iturn=iturn+1 + do 100 k=1,nraysp + if (istat(k).ne.0) goto 100 +c examine particle location + ax=abs(zblock(1,k)) + apx=abs(zblock(2,k)) + ay=abs(zblock(3,k)) + apy=abs(zblock(4,k)) + if (ax.gt.p(1) .or. apx.gt.p(2) + & .or. ay.gt.p(3) .or. apy.gt.p(4)) + & then +c particle outside window + istat(k)=iturn + nlost=nlost+1 + ihist(1,nlost)=iturn + ihist(2,nlost)=k + endif + 100 continue + return + end +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/cons.f b/OpticsJan2020/MLI_light_optics/Src/cons.f new file mode 100755 index 0000000..a106c1c --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/cons.f @@ -0,0 +1,59 @@ +************************************************************************ +* header: CONSTRAINTS (CONS) * +* Constraint subroutines to be used in conjunction with fitting * +* routines. * +************************************************************************ + subroutine con1(p) +c impose constraints amoung parameters in the various parameter sets + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + write(6,*) 'con1 not yet installed' + return + end +c +************************************************************************ +c + subroutine con2(p) +c impose constraints amoung parameters in the various parameter sets + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + write(6,*) 'con2 not yet installed' + return + end +c +************************************************************************ +c + subroutine con3(p) +c impose constraints amoung parameters in the various parameter sets + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + write(6,*) 'con3 not yet installed' + return + end +c +************************************************************************ +c + subroutine con4(p) +c impose constraints amoung parameters in the various parameter sets + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + write(6,*) 'con4 not yet installed' + return + end +c +************************************************************************ +c + subroutine con5(p) +c impose constraints amoung parameters in the various parameter sets + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + write(6,*) 'con5 not yet installed' + return + end +c +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/constants_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/constants_mod.f90 new file mode 100644 index 0000000..ca7af45 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/constants_mod.f90 @@ -0,0 +1,151 @@ +!*********************************************************************** +! +! constants_mod: This file contains definitions of the modules +! local, math_consts, and phys_consts +! +! Version: 0.1 +! Author: D.T.Abell, Tech-X Corp., Jan.2005 +! +! Comments +! This should have been written a long time ago! +! +! 13.Jan.2005 (DTA): The _right_ way to do this would be to have +! constants such as pi computed (eg., 2.d0*asin(1.d0)), so they're +! guaranteed to be machine precision. This, however, is a tough +! problem for compilers (which would have to emulate an arbitrary +! computer's floating point intrinsics). But since we don't want a +! user changing any of these constants (else why call them so?), we +! want them declared parameters, which means the compiler must know +! about them NOW. The values were generated through 21 digits using +! Mathematica. +! +!*********************************************************************** +!*********************************************************************** +! +! math_consts +! +! Description: This module defines some standard math constants. +! +!*********************************************************************** +! + module math_consts + implicit none +! +! data +! + double precision, parameter :: pi = 3.14159265358979323846d0 + double precision, parameter :: twopi = 6.28318530717958647693d0 + double precision, parameter :: fourpi = 12.5663706143591729539d0 + double precision, parameter :: euler_e = & + & 2.71828182845904523536d0 + double precision, parameter :: golden_ratio = & + & 1.61803398874989484820d0 + +! conversion factors between radians and degrees + double precision, parameter :: deg_per_rad = & + & 57.2957795130823208768d0 + double precision, parameter :: rad_per_deg = & + & 0.0174532925199432957692d0 + + end module math_consts +! +!*********************************************************************** +! +! phys_consts +! +! Description: This module defines the standard physical constants. For +! each constant, the comment states the units and (in parentheses) the +! expected error in the last digits. For more information, see the +! NIST web site: http://physics.nist.gov/cuu/index.html +! NB: The units are mostly SI, but some constants are given in alternate +! units. Two examples: (1) 'electron_mass' holds the value in kg, but +! 'electron_restE' holds the value in eV; (2) 'planck_h' holds the value +! in J.s, but 'planck_h_ev' holds the value in eV.s. +! +!*********************************************************************** +! + module phys_consts + implicit none +! +! data +! +! speed of light in vacuum /m.s^-1 (exact) + double precision, parameter :: c_light = 299792458.0d0 + +! permittivity of free space /F.m^-1 (exact to digits shown) + double precision, parameter :: epsilon_o = & + & 8.85418781762038985054d-12 + +! 4.pi.{permittivity of free space} /F.m^-1 (exact to digits shown) + double precision, parameter :: epsilon_o_4pi = & + & 1.11265005605361843217d-10 + +! permeability of free space /H.m^-1 (exact to digits shown) + double precision, parameter :: mu_o = 12.5663706143591729539d-7 + +! {permeability of free space}/4.pi /H.m^-1 (exact) + double precision, parameter :: mu_o_ovr_4pi = 1.0d-7 + +! elementary charge /C (63) + double precision, parameter :: elem_charge = 1.602176462d-19 + +! elementary charge /esu (19) + double precision, parameter :: elem_charge_esu = 4.80320420d-10 + +! alpha particle mass /kg (52) + double precision, parameter :: alpha_mass = 6.64465598d-27 + +! alpha particle rest energy /eV (15) + double precision, parameter :: alpha_restE = 3727.37904d+6 + +! electron mass /kg (72) + double precision, parameter :: electron_mass = 9.10938188d-31 + +! electron rest energy /eV (21) + double precision, parameter :: electron_restE = 0.510998902d+6 + +! muon mass /kg (16) + double precision, parameter :: muon_mass = 1.88353109d-28 + +! muon rest energy /eV (52) + double precision, parameter :: muon_restE = 105.6583568d+6 + +! neutron mass /kg (13) + double precision, parameter :: neutron_mass = 1.67492716d-27 + +! neutron rest energy /eV (38) + double precision, parameter :: neutron_restE = 939.565330d+6 + +! proton mass /kg (13) + double precision, parameter :: proton_mass = 1.67262158d-27 + +! proton rest energy /eV (38) + double precision, parameter :: proton_restE = 938.271998d+6 + +! fine-structure constant (27) + double precision, parameter :: fine_structure_a = 7.297352533d-3 + +! fine-structure constant (50) + double precision, parameter :: inv_fine_structure_a = & + & 137.03599976d0 + +! Planck constant /J.s (52) + double precision, parameter :: planck_h = 6.62606876d-34 + +! Planck constant /eV.s (16) + double precision, parameter :: planck_h_ev = 4.13566727d-15 + +! {Planck constant}/(2.pi) /J.s (82) + double precision, parameter :: planck_h_bar = 1.054571596d-34 + +! {Planck constant}/(2.pi) /eV.s (26) + double precision, parameter :: planck_hbar_ev = 6.58211889d-16 + +! Boltzmann constant /J.K^-1 (24) + double precision, parameter :: boltzmann_k = 1.3806503d-23 + +! Boltzmann constant /eV.K^-1 (15) + double precision, parameter :: boltzmann_k_ev = 8.617342d-5 + + end module phys_consts +! diff --git a/OpticsJan2020/MLI_light_optics/Src/curve_fit.f90 b/OpticsJan2020/MLI_light_optics/Src/curve_fit.f90 new file mode 100644 index 0000000..3a0030d --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/curve_fit.f90 @@ -0,0 +1,604 @@ +!*********************************************************************** +! +! curve_fit: module containing functions for fitting curves to data +! +! Description: +! This module implements subroutines for fitting curves to data. +! +! Version: 0.1 +! Author: D.T.Abell, Tech-X Corp., Apr.2005 +! +! Comments +! +! +!*********************************************************************** +! + module curve_fit + use parallel, only : idproc + implicit none +! +! functions and subroutines +! + contains +! +!*********************************************************************** + subroutine cf_polyInterp(xx,yy,x,y,ix,iorder,iorigin) +! +! Interpolate at abcissa x the ordinate value y determined by the +! polynomial of degree iorder that fits the (iorder+1) data points +! (xx,yy) nearest x. The interpolation uses Neville's algorithm, and +! iorder has a default value of three. +! NB: The values in xx MUST increase (or decrease) monotonically. + implicit none + double precision, dimension(:), intent(in) :: xx,yy ! input data + double precision, intent(in) :: x ! interpolate at this abcissa + double precision, intent(out) :: y ! interpolated ordinate value + integer, intent(inout) :: ix ! index of xx nearest x + integer, optional, intent(in) :: iorder ! polynomial order + integer, optional, intent(in) :: iorigin ! index origin of xx,yy +!-----!----------------------------------------------------------------! + integer :: ioff,iord + integer :: i,ii,il,m + double precision, dimension(:), allocatable :: p + + ! use iorder to set iord + iord=3 + if(present(iorder)) iord=iorder + ! use index origin to set index offset + ioff=0 + if(present(iorigin)) ioff=iorigin-1 + + ! allocate temporary array p(0:iord) + allocate(p(0:iord)) + + ! determine lower boundary of interpolation range [il,il+iord] + ! (within this subroutine, xx and yy have index origin one) + ix=ix-ioff + call cf_searchNrst(xx,x,ix) + il=ix-iord/2 + if (il.lt.1) then + il=1 + else if (il.gt.size(xx)-iord) then + il=size(xx)-iord + end if + + ! use array value or do interpolation using Neville's algorithm + if (x.eq.xx(ix)) then + y=yy(ix) + else + do i=0,iord + p(i)=yy(il+i) + end do + do m=1,iord + do i=0,iord-m + ii=il+i + p(i)=((x-xx(ii))*p(i+1)+(xx(ii+m)-x)*p(i))/(xx(ii+m)-xx(ii)) + end do + end do + y=p(0) + end if + + ! offset index for external value of index origin + ix=ix+ioff + + ! deallocate temporary array p(0:iord) + deallocate(p) + + return + end subroutine cf_polyInterp +! +!*********************************************************************** + subroutine cf_polyInterp3(xx,yy,x,y,ix,iorigin) +! +! Interpolate at abcissa x the ordinate value y determined by the +! third-order polynomial that fits the four data points (xx,yy) +! nearest x. The interpolation uses Neville's algorithm. +! NB: The values in xx MUST increase (or decrease) monotonically. + implicit none + double precision, dimension(:), intent(in) :: xx,yy ! input data + double precision, intent(in) :: x ! interpolate at this abcissa + double precision, intent(out) :: y ! interpolated ordinate value + integer, intent(inout) :: ix ! index of xx nearest x + integer, optional, intent(in) :: iorigin ! index origin of xx,yy +!-----!----------------------------------------------------------------! + integer :: ioff,iord + integer :: i,ii,il,m + double precision, dimension(0:3) :: p + + ! use cubic interpolation + iord=3 + ! use index origin to set index offset + ioff=0 + if(present(iorigin)) ioff=iorigin-1 + + ! determine lower boundary of interpolation range [il,il+iord] + ! (within this subroutine, xx and yy have index origin one) + ix=ix-ioff + call cf_search(xx,x,ix) + il=ix-1 ! il=ix-iorder/2=ix-3/2 + if (il.lt.1) then + il=1 + else if (il.gt.size(xx)-3) then + il=size(xx)-3 + end if + + ! use array value or do interpolation using Neville's algorithm + if (x.eq.xx(ix)) then + y=yy(ix) + else + do i=0,iord + p(i)=yy(il+i) + end do + !write(21,*) x,xx(il:il+iord) + !write(21,*) x,p(0:iord) + do m=1,iord + do i=0,iord-m + ii=il+i + p(i)=((x-xx(ii))*p(i+1)+(xx(ii+m)-x)*p(i))/(xx(ii+m)-xx(ii)) + end do + !write(21,*) x,p(0:iord-m) + end do + y=p(0) + end if + + ! offset index for external value of index origin + ix=ix+ioff + + return + end subroutine cf_polyInterp3 +! +!*********************************************************************** + subroutine cf_bivarInterp(ss,tt,ff,s,t,f,is,it,sorder,torder, & + & iorigin) +! +! The two-dimensional array ff records a set of data values over the +! points in the direct product of the one-dimensional arrays ss and tt. +! This subroutine performs bivariate polynomial interpolation of order +! sorder in s and torder in t to interpolate a value f = f(s,t) using +! the (sorder+1)*(torder+1) points nearest (s,t) and the corresponding +! data in ff. The interpolation uses Neville's algorithm in each +! variable, and sorder and torder both have default value three. The +! arrays are assumed to have an index origin of iorigin, which has a +! default value of one. +! NB: The values in ss and tt MUST increase (or decrease) monotonically. + implicit none + double precision, dimension(:), intent(in) :: ss,tt ! arg arrays + double precision, dimension(:,:), intent(in) :: ff ! ff(ss,tt) + double precision, intent(in) :: s,t ! interpolate at this point + double precision, intent(out) :: f ! interpolated value + integer, intent(inout) :: is,it ! indices of ss, tt nearest s,t + integer, optional, intent(in) :: sorder,torder ! polynomial orders + integer, optional, intent(in) :: iorigin ! index origin of arrays +!-----!----------------------------------------------------------------! + integer :: ioff,sord,tord + integer :: i,ii,isl + double precision, dimension(:), allocatable :: p,v + + ! use sorder and torder to set sord and tord + sord=3; tord=3 + if(present(sorder)) sord=sorder + if(present(torder)) tord=torder + + ! use index origin to set index offset + ioff=0 + if(present(iorigin)) ioff=iorigin-1 + ! adjust is and it for index origin (on entrance) + ! (within this subroutine, ss tt, and ff have index origin one) + is=is-ioff; it=it-ioff + + ! determine lower boundary of s interpolation range [isl,isl+sord] + call cf_search(ss,s,is) + isl=is-sord/2 + if (isl.lt.1) then + isl=1 + else if (isl.gt.size(ss)-sord) then + isl=size(ss)-sord + end if + + ! allocate temporary arrays p(0:sord) and v(0:sord) + allocate(p(0:sord)) + allocate(v(0:sord)) + + ! do polynomial interpolation in t for nearby s values + do i = 0,sord + v(i)=ss(isl+i) + call cf_polyInterp(tt,ff(isl+i,:),t,p(i),it,tord) + end do + ! do polynomial interpolation in s + ii=is-isl + call cf_polyInterp(v,p,s,f,ii,sord,0) + + ! adjust is and it for index origin (on exit) + is=is+ioff; it=it+ioff + + ! deallocate temporary arrays p and v + deallocate(p) + deallocate(v) + + return + end subroutine cf_bivarInterp +! +!*********************************************************************** + function cf_interp(xx,a,b,c,x) +! +! Interpolate at x the value of a function described by the n-element +! coefficient arrays a, b, and c. These arrays hold the quadratic +! fit parameters determined at locations xx by subroutine cf_parfit +! such that f = a + b*x + c*x**2. +! NB: The values in xx MUST increase (or decrease) monotonically. + implicit none + double precision :: cf_interp + double precision, dimension(:) :: a,b,c,xx + double precision :: x +!-----!----------------------------------------------------------------! + integer :: j,n + + n=size(xx) + call cf_search(xx,x,j) + if(j.lt.1) then + j=1 + else if(j.gt.(n-1)) then + j=n-1 + endif + cf_interp=a(j)+x*(b(j)+x*c(j)) + return + end function cf_interp +! +!*********************************************************************** + subroutine cf_interp2(xx,yy,x,y) +! +! Quadratic interpolation at x based on data pairs (xx,yy). +! NB: The data in xx MUST increase (or decrease) monotonically. + implicit none + double precision, dimension(0:2), intent(in) :: xx,yy + double precision, intent(in) :: x + double precision, intent(out) :: y +!-----!----------------------------------------------------------------! + double precision :: c1,c2 + + c1=(yy(1)-yy(0))/(xx(1)-xx(0)) + c2=((yy(2)-yy(0))/(xx(2)-xx(0))-c1)/(xx(2)-xx(1)) + y=yy(0)+(x-xx(0))*(c1+(x-xx(1))*c2) + return + end subroutine cf_interp2 +! +!*********************************************************************** + subroutine cf_parfit(xi,yi,ai,bi,ci) +! +! This subroutine takes data pairs (x(i),y(i)), i=1..npts, fits a +! quadratic form a+b*x+c*x**2 to each triple of adjacent points, and +! returns the lists of coefficients a(i), b(i), and c(i). +! Except at the ends, the coefficients reported for the i-th interval +! are computed as the average of those calculated using the points +! (i-1,i,i+1) and those calculated using the points (i,i+1,i+2). + implicit none + double precision, dimension(:), intent(in) :: xi,yi + double precision, dimension(:), intent(out) :: ai,bi,ci +!-----!----------------------------------------------------------------! + integer :: i,ip2,npts,npm1,npm2 + double precision :: x1,x2,x3,y1,y2,y3 + double precision :: d1,d2,d3,h1,h2,h3 + double precision :: a1,b1,c1,a2,b2,c2 +! + npts=size(xi) + npm1=npts-1 + npm2=npts-2 +! +! initialize the fitting + x1=xi(1) + x2=xi(2) + x3=xi(3) + y1=yi(1) + y2=yi(2) + y3=yi(3) + h1=x2-x1 + h2=x3-x2 + h3=x3-x1 + d1= y1/(h3*h1) + d2=-y2/(h1*h2) + d3= y3/(h2*h3) +! and fit a parabola to the first three points + a1= d1*x2*x3 + d2*x3*x1 + d3*x1*x2 + b1= -d1*(x2+x3) - d2*(x3+x1) - d3*(x1+x2) + c1= d1 + d2 + d3 + ai(1)=a1 + bi(1)=b1 + ci(1)=c1 +! +! compute the next set of quadratic coefficients, +! and average with the previous set + do i=2,npm2 + ip2=i+2 + x1=x2 + x2=x3 + x3=xi(ip2) + y1=y2 + y2=y3 + y3=yi(ip2) + h1=h2 + h2=x3-x2 + h3=x3-x1 + d1= y1/(h1*h3) + d2=-y2/(h1*h2) + d3= y3/(h2*h3) + a2= d1*x2*x3 + d2*x3*x1 + d3*x1*x2 + b2= -d1*(x2+x3) - d2*(x3+x1) - d3*(x1+x2) + c2= d1 + d2 + d3 + ai(i)=0.5d0*(a1+a2) + bi(i)=0.5d0*(b1+b2) + ci(i)=0.5d0*(c1+c2) + a1=a2 + b1=b2 + c1=c2 + end do +! +! rightmost interval + ai(npm1)=a2 + bi(npm1)=b2 + ci(npm1)=c2 +! + return + end subroutine cf_parfit +! +!*********************************************************************** + subroutine cf_search(xx,x,j,iorigin) +! +! Search array xx(1:n) and return index j such that x lies in range +! [xx(j),x(j+1)) or, if j=n-1, [xx(n-1),xx(n)]. If the value returned +! in j is either 0 or n=size(xx), then x lies outside the range of xx. +! Use the value of j on input as an initial guess for searching. +! If the array submitted to this routine has index origin other than 1, +! then one may specify it using the optional argument iorigin. In this +! case, of course, the values of j that indicate an out-of-range +! condition are (iorigin-1) and (size(xx)+iorigin-1). +! NB: The array xx must be monotonic, either increasing or decreasing. +! Cf. Numerical Recipes, 2nd ed. (1992), p.121. + implicit none + double precision, dimension(:), intent(in) :: xx + double precision, intent(in) :: x + integer, intent(inout) :: j + integer, optional, intent(in) :: iorigin +!-----!----------------------------------------------------------------! + integer jl,jm,ju,incr,n + logical ascend + double precision, parameter :: epsilon=1.d-13 + + ! get size of xx, and adjust for index origin + n=size(xx) + if(present(iorigin)) j=j-(iorigin-1) + ! do array values ascend or descend + ascend=(xx(n).gt.xx(1)) + ! use initial value of j to bracket binary search + if (j.lt.1.or.j.gt.n) then + ! bracket entire array + jl=0; ju=n+1 + else + ! hunt for smaller bracket + jl=j; ju=j + incr=1 + if ((x.gt.xx(jl).eqv.ascend).or.x.eq.xx(jl)) then + ! move bracket -=> + 1 ju=jl+incr + if (ju.gt.n) then + ju=n+1 + else if ((x.gt.xx(ju).eqv.ascend).or.x.eq.xx(ju)) then + jl=ju + incr=incr+incr + goto 1 + end if + else + ! move bracket <=- + 2 jl=ju-incr + if (jl.lt.1) then + jl=0 + else if ((x.lt.xx(jl).eqv.ascend).and.x.ne.xx(jl)) then + ju=jl + incr=incr+incr + goto 2 + end if + end if + end if + ! now do binary search + 3 if (ju-jl.gt.1) then + jm=(jl+ju)/2 + if(((x.gt.xx(jm)).eqv.ascend).or.(x.eq.xx(jm))) then + jl=jm + else + ju=jm + endif + goto 3 + end if + j=jl + ! be nice if within epsilon of edges + if (j.eq.0) then + if (abs(x-xx(1)).le.epsilon) j=1 + else if (j.eq.n) then + if (abs(x-xx(n)).le.epsilon) j=n-1 + end if + ! adjust for index origin + if(present(iorigin)) j=j+(iorigin-1) +! + return + end subroutine cf_search +! +!*********************************************************************** + subroutine cf_searchNrst(xx,x,j,iorigin) +! +! Search array xx(1:n) and return index j such that x lies in range +! [xx(j),x(j+1)) or, if j=n-1, [xx(n-1),xx(n)]. If the value returned +! in j is either 0 or n=size(xx), then x lies outside the range of xx. +! Use the value of j on input as an initial guess for searching. +! If the array submitted to this routine has index origin other than 1, +! then one may specify it using the optional argument iorigin. In this +! case, of course, the values of j that indicate an out-of-range +! condition are (iorigin-1) and (size(xx)+iorigin-1). +! NB: The array xx must be monotonic, either increasing or decreasing. +! Cf. Numerical Recipes, 2nd ed. (1992), p.121. + implicit none + double precision, dimension(:), intent(in) :: xx + double precision, intent(in) :: x + integer, intent(inout) :: j + integer, optional, intent(in) :: iorigin +!-----!----------------------------------------------------------------! + integer jl,jm,ju,incr,n + logical ascend + double precision, parameter :: epsilon=1.d-13 + + ! get size of xx, and adjust for index origin + n=size(xx) + if(present(iorigin)) j=j-(iorigin-1) + ! do array values ascend or descend + ascend=(xx(n).gt.xx(1)) + ! use initial value of j to bracket binary search + if (j.lt.1.or.j.gt.n) then + ! bracket entire array + jl=0; ju=n+1 + else + ! hunt for smaller bracket + jl=j; ju=j + incr=1 + if ((x.gt.xx(jl).eqv.ascend).or.x.eq.xx(jl)) then + ! move bracket -=> + 1 ju=jl+incr + if (ju.gt.n) then + ju=n+1 + else if ((x.gt.xx(ju).eqv.ascend).or.x.eq.xx(ju)) then + jl=ju + incr=incr+incr + goto 1 + end if + else + ! move bracket <=- + 2 jl=ju-incr + if (jl.lt.1) then + jl=0 + else if ((x.lt.xx(jl).eqv.ascend).and.x.ne.xx(jl)) then + ju=jl + incr=incr+incr + goto 2 + end if + end if + end if + ! now do binary search + 3 if (ju-jl.gt.1) then + jm=(jl+ju)/2 + if(((x.gt.xx(jm)).eqv.ascend).or.(x.eq.xx(jm))) then + jl=jm + else + ju=jm + endif + goto 3 + end if + j=jl + ! be nice if within epsilon of edges, + ! and be sure we return Nearest index + if (j.eq.0) then + if (abs(x-xx(1)).le.epsilon) j=1 + else if (j.eq.n) then + if (abs(x-xx(n)).le.epsilon) j=n + else + if (abs(x-xx(j)).gt.abs(x-xx(j+1))) j=j+1 + end if + ! adjust for index origin + if(present(iorigin)) j=j+(iorigin-1) +! + return + end subroutine cf_searchNrst +! +!*********************************************************************** + subroutine cf_locate(xx,x,j,iorigin) +! +! Search array xx(:) and return index j such that x lies in range +! [xx(j),x(j+1)) or, if j=n-1, [xx(n-1),xx(n)]. If the value returned +! in j is either 0 or n=size(xx), then x lies outside the range of xx. +! If the array submitted to this routine has index origin other than 1, +! then one may specify it using the optional argument iorigin. In this +! case, of course, the values of j that indicate an out-of-range +! condition are (iorigin-1) and (size(xx)+iorigin-1). +! NB: The array xx must be monotonic, either increasing or decreasing. +! Cf. Numerical Recipes, 2nd ed. (1992), p.121. + implicit none + double precision, dimension(:), intent(in) :: xx + double precision, intent(in) :: x + integer, intent(inout) :: j + integer, optional, intent(in) :: iorigin +!-----!----------------------------------------------------------------! + integer jl,jm,ju,incr,n + logical ascend + double precision, parameter :: epsilon=1.d-13 + + ! get size of xx + n=size(xx) + ! do array values ascend or descend? + ascend=(xx(n).gt.xx(1)) + ! now initialize and perform binary search + jl=0; ju=n+1 + 3 if (ju-jl.gt.1) then + jm=(jl+ju)/2 + if(((x.gt.xx(jm)).eqv.ascend).or.(x.eq.xx(jm))) then + jl=jm + else + ju=jm + endif + goto 3 + endif + j=jl + ! be nice if within epsilon of edges + if (j.eq.0) then + if (abs(x-xx(1)).le.epsilon) j=1 + else if (j.eq.n) then + if (abs(x-xx(n)).le.epsilon) j=n-1 + end if + ! adjust for index origin + if(present(iorigin)) j=j+(iorigin-1) +! + return + end subroutine cf_locate +! +!*********************************************************************** + subroutine cf_locate_nr(xx,x,j,iorigin) +! +! Search array xx(:) and return index j such that x lies in range +! [xx(j),x(j+1)). If the value j returned is either 0 or n=size(xx), +! then x lies outside the range of xx. +! If the array submitted to this routine has index origin other than 1, +! then one may specify it using the optional argument iorigin. In this +! case, of course, the values of j that indicate an out-of-range +! condition are (iorigin-1) and (size(xx)+iorigin-1). +! NB: The array xx must be monotonic, either increasing or decreasing. +! Cf. Numerical Recipes, 2nd ed. (1992), p.121. + implicit none + double precision, dimension(:), intent(in) :: xx + double precision, intent(in) :: x + integer, intent(inout) :: j + integer, optional, intent(in) :: iorigin +!-----!----------------------------------------------------------------! + integer jl,jm,ju,incr,n + logical ascend + double precision, parameter :: eps=1.d-13 + + ! get size of xx + n=size(xx) + ! do array values ascend or descend? + ascend=(xx(n).gt.xx(1)) + ! now initialize and perform binary search + jl=0; ju=n+1 + 3 if (ju-jl.gt.1) then + jm=(jl+ju)/2 + if(((x.gt.xx(jm)).eqv.ascend).or.(abs(x-xx(jm)).lt.eps)) then + jl=jm + else + ju=jm + endif + goto 3 + endif + !if (jl.eq.n.and.x.eq.xx(n)) jl=n-1 + j=jl + ! adjust for index origin + if(present(iorigin)) j=j+(iorigin-1) +! + return + end subroutine cf_locate_nr +! + end module curve_fit + diff --git a/OpticsJan2020/MLI_light_optics/Src/depositrho.f b/OpticsJan2020/MLI_light_optics/Src/depositrho.f new file mode 100644 index 0000000..eb40307 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/depositrho.f @@ -0,0 +1,95 @@ +! IMPACT 3D space charge routines +! Copyright 2003 University of California +! +! subroutine depositrho( C,Msk,Np,NpTot,Nx,Ny,Nz,Nadj,rho,rhotmp ) +! +! Arguments: +! C :in (1:5:2,Np) are x,y,z coordinates of particles +! Note: in the rest of MLI column 5 is time-of-flight (i.e. phase), +! but prior to calling the space charge routines it is +! converted to longitudinal position z. +! (2:6:2,Np) are momenta and not used here. +! Msk :in flag indicating valid particles +! Np :in number of particles (both good and bad) on this processor +! Nptot :in number of (good) particles on all processors +! Nx,Ny,Nz :in dimensions of grid on the regular sized grid +! Nadj :in =0 for open or Dirichlet BCs, >=1 for longitudinally periodic BCs +! rho :out array of charge density +! rhotmp :tmp scratch space +! +! Globals: +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine depositrho( C,Msk,Np,NpTot,Nx,Ny,Nz,rho,rhotmp ) +!Modules + use parallel + use ml_timer + implicit none +!Arguments + real*8 C(6,Np) + logical Msk(Np) + integer Np,Nptot,Nx,Ny,Nz,Nadj + real*8 rho(Nx,Ny,Nz) ,rhotmp(Nx,Ny,Nz) +!Local variables + integer ierror +!Globals + integer IVerbose + common/SHOWME/IVerbose + real*8 xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + common/GRIDSZ3D/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi +!Externals + +!Execute + if( IVerbose .GT. 5 ) write(6,*) 'in DEPOSITRHO' + +! deposit charge on the grid: + call increment_timer('rhoslo3d',0) + call rhoslo3d(C,rho,Msk,Np,Nx,Ny,Nz,Nadj) + if( NVP .GT. 1 )then + call MPI_ALLREDUCE(rho,rhotmp,Nx*Ny*Nz,Mreal,Mpisum,Lworld,ierror) + if( ierror .NE. 0 ) write(6,*) + & 'depositrho: MPI_ALLREDUCE returned ',ierror + rho=rhotmp + endif + call increment_timer('rhoslo3d',1) + +!-------- +!XXX!-- for iexactrho case +!XXX glrhochk=sum(rho) +!XXX if(idproc.eq.0) & +!XXX & write(6,*)'(exact rho): global sum of rho = ',glrhochk +!XXX call getrms(c,xrms,yrms,zrms,np) +!XXX if(idproc.eq.0) & +!XXX & write(6,*)'(exact rho): xrms,yrms,zrms=',xrms,yrms,zrms +!XXX xmac=sqrt(5.d0)*xrms +!XXX ymac=sqrt(5.d0)*yrms +!XXX zmac=sqrt(5.d0)*zrms +!XXX if(idproc.eq.0) & +!XXX & write(6,*)'(exact rho): xmac,ymac,zmac=',xmac,ymac,zmac +!XXX rho=0.d0 +!XXX do k=1,nz +!XXX z=zmin+(k-1)*hz +!XXX do j=1,ny +!XXX y=ymin+(j-1)*hy +!XXX do i=1,nx +!XXX x=xmin+(i-1)*hx +!XXX! if((x/xbig)**2+(y/ybig)**2+(z/zbig)**2 .le.1.d0)rho(i,j,k)=1.d0 +!XXX if((x/xmac)**2+(y/ymac)**2+(z/zmac)**2 .le.1.d0)rho(i,j,k)=1.d0 +!XXX enddo +!XXX enddo +!XXX enddo +!XXX glrhonew=sum(rho) +!XXX if(idproc.eq.0) & +!XXX & write(6,*)'(exact rho): glrhonew=',glrhonew +!XXX rho=rho*glrhochk/glrhonew +!XXX glrhochk=sum(rho) +!XXX if(idproc.eq.0) & +!XXX & write(6,*)'(exact rho): new global sum of rho = ',glrhochk +!XXX!-- end + +!-------- +cryne august 1, 2002 +cryne moved normalization out of rhoslo to here: + rho=rho/(hx*hy*hz*ntot) + call system_clock(count=iticks1) diff --git a/OpticsJan2020/MLI_light_optics/Src/diagnostics.f b/OpticsJan2020/MLI_light_optics/Src/diagnostics.f new file mode 100755 index 0000000..585ff85 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/diagnostics.f @@ -0,0 +1,905 @@ +c******************* ML/I DIAGNOSTIC ROUTINES******************* + subroutine writereftraj(sarclen,nfile,nprecision,nunits) + use parallel, only: idproc + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'map.inc' + include 'usrdat.inc' + integer :: nfile,nprecision,nunits + real*8 sarclen + character*16 :: myformat='(9(1x,1pe12.5 ))' + character*2 :: a2 + common/envdata/env(6),envold(6),emap(6,6) +!---format: + nlength=nprecision+7 + call num2string(nlength,a2,2) + myformat(10:11)=a2 + call num2string(nprecision,a2,2) + myformat(13:14)=a2 +! + xl=sl + wld=omegascl*xl*p0sc + z=sarclen +! reference trajecory (t-pt portion): + energy=(gamma-1.)*pmass + if(idproc.eq.0)then + if(nunits.eq.0)then + write(nfile,myformat)z,reftraj(1:6),energy + write(17,myformat)z,env(1:6) + call myflush(17) + elseif(nunits.eq.1)then + write(nfile,myformat)z,reftraj(1)*xl,reftraj(2)*p0sc, & + & reftraj(3)*xl,reftraj(4)*p0sc, & + & reftraj(5)/omegascl,reftraj(6)*wld,energy + write(17,myformat)z,env(1:6) + call myflush(17) + endif + endif + ucalc(100)=energy + return + end +c + subroutine writemom2d(sarclen,nfile1,nfile2,nfile3, & + & nprecision,nunits,ncorr,includepi,ncent) +cryne 8/11/2001 routine to print some 2nd moments +c arguments: +c sarclen = current arclength +c nfile1 = unit # for output xfile +c nfile2 = unit # for output yfile +c nfile3 = unit # for output tfile +c nprecision = precision at which to write data +c nunits = 0/1 for dimensionless/physical variables in output +c ncorr = 0/1 to report cross-terms (,...) as is/as ratios +c includepi = 0/1 to no/yes divide emittances by pi +c ncent = 0/1 to remove/keep beam centroid in emittance computation + use beamdata + use rays + use ml_timer + include 'impli.inc' + include 'usrdat.inc' +! + integer :: nfile1,nfile2,nfile3,nprecision,nunits,ncorr,ncent + real*8 sarclen +! + logical msk + dimension msk(nraysp) + dimension avg(6),ravg(6) + dimension diag(9),rdiag(9) + character*16 :: myformat='(6(1x,1pe12.5 ))' + character*2 :: a2 + real*8 :: zero=0. +! + call increment_timer('moments',0) +! +c set up particle mask + msk(1:nraysp)=.true. + do j=1,nraysp + if(istat(j).ne.0)msk(j)=.false. + enddo +! +c compute moments +c scale factors + den1=1./nrays + den2=den1*den1 + slp0=sl*p0sc + slp1=slp0 + wld=omegascl*slp0 + clyte=299792458.d0 + pi=2.d0*asin(1.d0) + z=sarclen +c compute beam centroid + ravg(1:6)=0.d0 + if(ncent.eq.0)then + avg(1)=sum(zblock(1,1:nraysp),msk)*den1 + avg(2)=sum(zblock(2,1:nraysp),msk)*den1 + avg(3)=sum(zblock(3,1:nraysp),msk)*den1 + avg(4)=sum(zblock(4,1:nraysp),msk)*den1 + avg(5)=sum(zblock(5,1:nraysp),msk)*den1 + avg(6)=sum(zblock(6,1:nraysp),msk)*den1 + call MPI_ALLREDUCE(avg,ravg,6,mreal,mpisum,lworld,ierror) + endif +c give readable names to coordinate entries + xbar=ravg(1) + ybar=ravg(3) + tbar=ravg(5) +c compute second-order moments + diag(1)=sum((zblock(1,1:nraysp)-ravg(1)) & + & *(zblock(1,1:nraysp)-ravg(1)),msk) + diag(2)=sum((zblock(2,1:nraysp)-ravg(2)) & + & *(zblock(2,1:nraysp)-ravg(2)),msk) + diag(3)=sum((zblock(3,1:nraysp)-ravg(3)) & + & *(zblock(3,1:nraysp)-ravg(3)),msk) + diag(4)=sum((zblock(4,1:nraysp)-ravg(4)) & + & *(zblock(4,1:nraysp)-ravg(4)),msk) + diag(5)=sum((zblock(5,1:nraysp)-ravg(1)) & + & *(zblock(5,1:nraysp)-ravg(2)),msk) + diag(6)=sum((zblock(6,1:nraysp)-ravg(3)) & + & *(zblock(6,1:nraysp)-ravg(4)),msk) + diag(7)=sum((zblock(1,1:nraysp)-ravg(1)) & + & *(zblock(2,1:nraysp)-ravg(2)),msk) + diag(8)=sum((zblock(3,1:nraysp)-ravg(3)) & + & *(zblock(4,1:nraysp)-ravg(4)),msk) + diag(9)=sum((zblock(5,1:nraysp)-ravg(5)) & + & *(zblock(6,1:nraysp)-ravg(6)),msk) + call MPI_ALLREDUCE(diag,rdiag,9,mreal,mpisum,lworld,ierror) +c give readable names to entries, and divide by number of particles + sq1=rdiag(1)*den1 + sq2=rdiag(2)*den1 + sq3=rdiag(3)*den1 + sq4=rdiag(4)*den1 + sq5=rdiag(5)*den1 + sq6=rdiag(6)*den1 + xpx=rdiag(7)*den1 + ypy=rdiag(8)*den1 + tpt=rdiag(9)*den1 +c compute derived quantities + epsx2=(sq1*sq2-xpx*xpx) + epsy2=(sq3*sq4-ypy*ypy) + epst2=(sq5*sq6-tpt*tpt) + xrms=sqrt(sq1) + yrms=sqrt(sq3) + trms=sqrt(sq5) + pxrms=sqrt(sq2) + pyrms=sqrt(sq4) + ptrms=sqrt(sq6) + epsx=sqrt(max(epsx2,zero)) + epsy=sqrt(max(epsy2,zero)) + epst=sqrt(max(epst2,zero)) + if(includepi.eq.1)then + epsx=epsx/pi + epsy=epsy/pi + epst=epst/pi + endif + if(ncorr.eq.1)then + xpxfac=0.d0 + ypyfac=0.d0 + tptfac=0.d0 + if(xrms.ne.0. .and. pxrms.ne.0.)xpxfac=1./(xrms*pxrms) + if(yrms.ne.0. .and. pyrms.ne.0.)ypyfac=1./(yrms*pyrms) + if(trms.ne.0. .and. ptrms.ne.0.)tptfac=1./(trms*ptrms) + xpx=xpx*xpxfac + ypy=ypy*ypyfac + tpt=tpt*tptfac + slp1=1.d0 + endif +! +c output results + if(idproc.eq.0)then +c set format for amount of data and desired precision + nlength=nprecision+7 + call num2string(nlength,a2,2) + myformat(10:11)=a2 + call num2string(nprecision,a2,2) + myformat(13:14)=a2 +c write 2D (transverse 2nd moments) + if(nunits.eq.0)then + write(nfile1,myformat)z,xrms,pxrms,xpx,epsx,xbar + write(nfile2,myformat)z,yrms,pyrms,ypy,epsy,ybar + else + write(nfile1,myformat)z,xrms*sl,pxrms*p0sc,xpx*slp1,epsx*slp0,& + & xbar*sl + write(nfile2,myformat)z,yrms*sl,pyrms*p0sc,ypy*slp1,epsy*slp0,& + & ybar*sl + endif + endif + ucalc(1)=xrms + ucalc(2)=pxrms + ucalc(3)=xpx + ucalc(4)=yrms + ucalc(5)=pyrms + ucalc(6)=ypy +c write 3D (t-pt 2nd moments) + if(idproc.eq.0)then + if(nunits.eq.0)then + write(nfile3,myformat)z,trms,ptrms,tpt,epst,tbar + else + write(nfile3,myformat)z,trms*beta*clyte/omegascl,ptrms*wld, & + & tpt*slp1,epst*slp0,tbar/omegascl + endif + endif + ucalc(7)=trms + ucalc(8)=ptrms + ucalc(9)=tpt +! + call increment_timer('moments',1) + return + end +! + subroutine writeemit(sarclen,nfile,nprecision,nunits, + & ne2,ne4,ne6,ncent) +cabell 8/29/2004 routine to write 2- 4- and/or 6-d emittances +c arguments: +c sarclen = current arclength +c nfile = unit # for output file +c nprecision = precision at which to write data +c nunits = 0/1 for dimensionless/physical variables in output +c ne2 = flag to compute 2-d emittances +c ne4 = flag to compute 4-d transverse emittance +c ne6 = flag to compute 6-d emittance +c ncent = 0/1 to remove/keep beam centroid in emittance computation + use beamdata + use rays + use ml_timer + include 'impli.inc' +! + integer :: nfile,nprecision,nunits,ne2,ne4,ne6,ncent + real*8 sarclen +! + logical msk + dimension msk(nraysp) + dimension avg(6),ravg(6) + dimension diag(21),rdiag(21) + dimension sigma6(6,6) + character*16 :: myformat='(6(1x,1pe12.5 ))' + character*1 :: a1 + character*2 :: a2 + real*8 :: zero=0. +! + call increment_timer('moments',0) +! +! if(idproc.eq.0) then +! write(6,*) "writeemit()::" +! if(nunits.eq.0) write(6,*) " using scaled variables" +! if(nunits.eq.1) write(6,*) " using physical variables" +! if(ne2.eq.1) write(6,*) " --2-D" +! if(ne4.eq.1) write(6,*) " --4-D" +! if(ne6.eq.1) write(6,*) " --6-D" +! endif +! +c set up particle mask + msk(1:nraysp)=.true. + do j=1,nraysp + if(istat(j).ne.0)msk(j)=.false. + enddo +! +c compute emittances +c scale factors + den1=1./nrays + slp0=sl*p0sc + clyte=299792458.d0 + wld=omegascl*slp0 + z=sarclen +c compute beam centroid + ravg(1:6)=0.d0 + if(ncent.eq.0)then + avg(1)=sum(zblock(1,1:nraysp),msk)*den1 + avg(2)=sum(zblock(2,1:nraysp),msk)*den1 + avg(3)=sum(zblock(3,1:nraysp),msk)*den1 + avg(4)=sum(zblock(4,1:nraysp),msk)*den1 + avg(5)=sum(zblock(5,1:nraysp),msk)*den1 + avg(6)=sum(zblock(6,1:nraysp),msk)*den1 + call MPI_ALLREDUCE(avg,ravg,6,mreal,mpisum,lworld,ierror) + endif +c compute entries of beam sigma matrix +c entries of diag() follow diagonals of the beam matrix +c starting from the main diagonal and going out to UR corner +c compute only required entries + diag(1:21)=0 + diag( 1)=sum((zblock(1,1:nraysp)-ravg(1)) & + & *(zblock(1,1:nraysp)-ravg(1)),msk) + diag( 2)=sum((zblock(2,1:nraysp)-ravg(2)) & + & *(zblock(2,1:nraysp)-ravg(2)),msk) + diag( 3)=sum((zblock(3,1:nraysp)-ravg(3)) & + & *(zblock(3,1:nraysp)-ravg(3)),msk) + diag( 4)=sum((zblock(4,1:nraysp)-ravg(4)) & + & *(zblock(4,1:nraysp)-ravg(4)),msk) + diag( 7)=sum((zblock(1,1:nraysp)-ravg(1)) & + & *(zblock(2,1:nraysp)-ravg(2)),msk) + diag( 9)=sum((zblock(3,1:nraysp)-ravg(3)) & + & *(zblock(4,1:nraysp)-ravg(4)),msk) + if(ne2.eq.1.or.ne6.eq.1)then + diag( 5)=sum((zblock(5,1:nraysp)-ravg(5)) & + & *(zblock(5,1:nraysp)-ravg(5)),msk) + diag( 6)=sum((zblock(6,1:nraysp)-ravg(6)) & + & *(zblock(6,1:nraysp)-ravg(6)),msk) + diag(11)=sum((zblock(5,1:nraysp)-ravg(5)) & + & *(zblock(6,1:nraysp)-ravg(6)),msk) + endif + if(ne4.eq.1.or.ne6.eq.1)then + diag( 8)=sum((zblock(2,1:nraysp)-ravg(2)) & + & *(zblock(3,1:nraysp)-ravg(3)),msk) + diag(12)=sum((zblock(1,1:nraysp)-ravg(1)) & + & *(zblock(3,1:nraysp)-ravg(3)),msk) + diag(13)=sum((zblock(2,1:nraysp)-ravg(2)) & + & *(zblock(4,1:nraysp)-ravg(4)),msk) + diag(16)=sum((zblock(1,1:nraysp)-ravg(1)) & + & *(zblock(4,1:nraysp)-ravg(4)),msk) + endif + if(ne6.eq.1)then + diag(10)=sum((zblock(4,1:nraysp)-ravg(4)) & + & *(zblock(5,1:nraysp)-ravg(5)),msk) + diag(14)=sum((zblock(3,1:nraysp)-ravg(3)) & + & *(zblock(5,1:nraysp)-ravg(5)),msk) + diag(15)=sum((zblock(4,1:nraysp)-ravg(4)) & + & *(zblock(6,1:nraysp)-ravg(6)),msk) + diag(17)=sum((zblock(2,1:nraysp)-ravg(2)) & + & *(zblock(5,1:nraysp)-ravg(5)),msk) + diag(18)=sum((zblock(3,1:nraysp)-ravg(3)) & + & *(zblock(6,1:nraysp)-ravg(6)),msk) + diag(19)=sum((zblock(1,1:nraysp)-ravg(1)) & + & *(zblock(5,1:nraysp)-ravg(5)),msk) + diag(20)=sum((zblock(2,1:nraysp)-ravg(2)) & + & *(zblock(6,1:nraysp)-ravg(6)),msk) + diag(21)=sum((zblock(1,1:nraysp)-ravg(1)) & + & *(zblock(6,1:nraysp)-ravg(6)),msk) + endif + call MPI_ALLREDUCE(diag,rdiag,21,mreal,mpisum,lworld,ierror) +c give readable names to entries, and divide by number of particles + xx=rdiag( 1)*den1 + pxpx=rdiag( 2)*den1 + yy=rdiag( 3)*den1 + pypy=rdiag( 4)*den1 + tt=rdiag( 5)*den1 + ptpt=rdiag( 6)*den1 + xpx=rdiag( 7)*den1 + pxy=rdiag( 8)*den1 + ypy=rdiag( 9)*den1 + pyt=rdiag(10)*den1 + tpt=rdiag(11)*den1 + xy=rdiag(12)*den1 + pxpy=rdiag(13)*den1 + yt=rdiag(14)*den1 + pypt=rdiag(15)*den1 + xpy=rdiag(16)*den1 + pxt=rdiag(17)*den1 + ypt=rdiag(18)*den1 + xt=rdiag(19)*den1 + pxpt=rdiag(20)*den1 + xpt=rdiag(21)*den1 +c epsX2=det(2x2 beam sigma matrix for horizontal plane) +c epsY2=det(2x2 beam sigma matrix for vertical plane) +c epsT2=det(2x2 beam sigma matrix for longitudinal plane) + if(ne2.eq.1)then + epsX2=(xx*pxpx-xpx*xpx) + epsY2=(yy*pypy-ypy*ypy) + epsT2=(tt*ptpt-tpt*tpt) + epsX=sqrt(max(epsX2,zero)) + epsY=sqrt(max(epsY2,zero)) + epsT=sqrt(max(epsT2,zero)) + if(nunits.eq.1)then + epsX=epsX*slp0 + epsY=epsY*slp0 + epsT=epsT*slp0 + endif + endif +c epsXY2=det(4x4 beam sigma matrix for transverse planes) + if(ne4.eq.1)then + epsXY2=xx*yy*pxpx*pypy & + & + xpx**2*ypy**2 + xy**2*pxpy**2 + xpy**2*pxy**2 & + & - xx*(pxpx*ypy**2 + yy*pxpy**2 + pypy*pxy**2) & + & - pxpx*(yy*xpy**2 + pypy*xy**2) - yy*pypy*xpx**2 & + & + 2*(xx*pxy*pxpy + pxpx*xy*xpy)*ypy & + & + 2*(yy*xpy*pxpy + pypy*xy*pxy)*xpx & + & - 2*xpx*(xpy*pxy + xy*pxpy)*ypy - 2*xy*xpy*pxy*pxpy + epsXYth=max(epsXY2,zero)**0.25 + if(nunits.eq.1)then + epsXYth=epsXYth*slp0 + endif + endif +c epsXYT2=det(6x6 beam sigma matrix) +c this COULD be coded by hand, but the det contains 388 terms! + if(ne6.eq.1)then + sigma6(1,1)=xx + sigma6(2,1)=xpx + sigma6(3,1)=xy + sigma6(4,1)=xpy + sigma6(5,1)=xt + sigma6(6,1)=xpt + sigma6(2,2)=pxpx + sigma6(3,2)=pxy + sigma6(4,2)=pxpy + sigma6(5,2)=pxt + sigma6(6,2)=pxpt + sigma6(3,3)=yy + sigma6(4,3)=ypy + sigma6(5,3)=yt + sigma6(6,3)=ypt + sigma6(4,4)=pypy + sigma6(5,4)=pyt + sigma6(6,4)=pypt + sigma6(5,5)=tt + sigma6(6,5)=tpt + sigma6(6,6)=ptpt + do i=1,6 + do j=i+1,6 + sigma6(i,j)=sigma6(j,i) + enddo + enddo +cabell:need to compute epsXYT2=det(sigma6) + epsXYT2=0.0 + epsXYTth=(max(epsXYT2,zero))**(1.d0/6.d0) + if(nunits.eq.1)then + epsXYTth=epsXYTth*slp0 + endif + endif +! +c output results + if(idproc.eq.0)then +c set format for amount of data and desired precision + nout=1 + if(ne2.eq.1)nout=nout+3 + if(ne4.eq.1)nout=nout+1 + if(ne6.eq.1)nout=nout+1 + call num2string(nout,a1,1) + myformat(2:2)=a1 + nlength=nprecision+7 + call num2string(nlength,a2,2) + myformat(10:11)=a2 + call num2string(nprecision,a2,2) + myformat(13:14)=a2 +c write results + if(ne2.eq.1.and.ne4.eq.0.and.ne6.eq.0)then +c 2d only + write(nfile,myformat)z,epsX,epsY,epsT + else if(ne2.eq.0.and.ne4.eq.1.and.ne6.eq.0)then +c 4d only + write(nfile,myformat)z,epsXYth + else if(ne2.eq.0.and.ne4.eq.0.and.ne6.eq.1)then +c 6d only + write(nfile,myformat)z,epsXYTth + else if(ne2.eq.1.and.ne4.eq.1.and.ne6.eq.0)then +c 2d and 4d + write(nfile,myformat)z,epsX,epsY,epsT,epsXYth + else if(ne2.eq.1.and.ne4.eq.0.and.ne6.eq.1)then +c 2d and 6d + write(nfile,myformat)z,epsX,epsY,epsT,epsXYTth + else if(ne2.eq.0.and.ne4.eq.1.and.ne6.eq.1)then +c 4d and 6d + write(nfile,myformat)z,epsXYth,epsXYTth + else +c 2d and 4d and 6d + write(nfile,myformat)z,epsX,epsY,epsT,epsXYth,epsXYTth + endif + endif +! + call increment_timer('moments',1) + return + end +! +! + subroutine writemaxsize(sarclen,nfile1,nfile2,nfile3,nfile4, & + & nprecision) +cryne 8/11/2001 routine to print min/max beam size +cryne various mods on 11/26/03 + use beamdata + use rays + include 'impli.inc' + integer :: nfile1,nfile2,nfile3,nfile4,nprecision + real*8 sarclen + logical msk + dimension msk(nraysp) + dimension mloca(1),diag(16),rdiag(16) +! + character*16 :: myformat='(6(1x,1pe12.5 ))' + character*2 :: a2 + if(idproc.eq.0)then +!---format: + nlength=nprecision+7 + call num2string(nlength,a2,2) + myformat(10:11)=a2 + call num2string(nprecision,a2,2) + myformat(13:14)=a2 + endif + +! +! if(idproc.eq.0)write(6,*)'inside routine printmaxsize' + msk(1:nraysp)=.true. + do j=1,nraysp + if(istat(j).ne.0)msk(j)=.false. + enddo +! +!------------ min/max quantities1:nrays---------------- +! pxmax=maxval(abs(zblock(2,1:nrays)))/gambet*econ +! pymax=maxval(abs(zblock(4,1:nrays)))/gambet*econ +! minvals and maxvals: + diag(1)=maxval(zblock(1,1:nraysp)) + diag(2)=maxval(zblock(2,1:nraysp)) + diag(3)=maxval(zblock(3,1:nraysp)) + diag(4)=maxval(zblock(4,1:nraysp)) + diag(5)=maxval(zblock(5,1:nraysp)) + diag(6)=maxval(zblock(6,1:nraysp)) + diag(7)=-minval(zblock(1,1:nraysp)) + diag(8)=-minval(zblock(2,1:nraysp)) + diag(9)=-minval(zblock(3,1:nraysp)) + diag(10)=-minval(zblock(4,1:nraysp)) + diag(11)=-minval(zblock(5,1:nraysp)) + diag(12)=-minval(zblock(6,1:nraysp)) + call MPI_ALLREDUCE(diag,rdiag,12,mreal,mpimax,lworld,ierror) + clyte=299792458.d0 + xl=sl + xk=1./xl + z=sarclen + econ=1.0 + wld=omegascl*xl*p0sc + xmax=rdiag(1)*xl + pxmax=rdiag(2)*p0sc + ymax=rdiag(3)*xl + pymax=rdiag(4)*p0sc + tmax=rdiag(5)/omegascl + ptmax=rdiag(6)*wld +! zmax=rdiag(5)*beta/xk + zmax=rdiag(5)*beta*clyte/omegascl + emax=rdiag(6)/(gamma**3*beta**2)*econ + xmin=-rdiag(7)*xl + pxmin=-rdiag(8)*p0sc + ymin=-rdiag(9)*xl + pymin=-rdiag(10)*p0sc + tmin=-rdiag(11)/omegascl + ptmin=-rdiag(12)*wld +! zmin=-rdiag(11)*beta/xk + zmin=-rdiag(11)*beta*clyte/omegascl + emin=-rdiag(12)/(gamma**3*beta**2)*econ +! location of min/max +! diag(15)=diag(8) +! diag(13)=diag(7) +! diag(11)=diag(6) +! diag(9)=diag(5) +! diag(7)=diag(4) +! diag(5)=diag(3) +! diag(3)=diag(2) +! x min/max1:nrays +! mloca=maxloc(zblock(1,1:nraysp)) +! diag(2)=mloca(1)+maxrayp*idproc +! mloca=maxloc(zblock(3,1:nraysp)) +! diag(4)=mloca(1)+maxrayp*idproc +! mloca=maxloc(zblock(5,1:nraysp)) +! diag(6)=mloca(1)+maxrayp*idproc +! mloca=maxloc(zblock(6,1:nraysp)) +! diag(8)=mloca(1)+maxrayp*idproc +! mloca=minloc(zblock(1,1:nraysp)) +! diag(10)=mloca(1)+maxrayp*idproc +! mloca=minloc(zblock(3,1:nraysp)) +! diag(12)=mloca(1)+maxrayp*idproc +! mloca=minloc(zblock(5,1:nraysp)) +! diag(14)=mloca(1)+maxrayp*idproc +! mloca=minloc(zblock(6,1:nraysp)) +! diag(16)=mloca(1)+maxrayp*idproc +! call MPI_ALLREDUCE(diag,rdiag,8,m2real,mpimaxloc,lworld,ierror) +! maxpcl1=rdiag(2) +! maxpcl3=rdiag(4) +! maxpcl5=rdiag(6) +! maxpcl6=rdiag(8) +! minpcl1=rdiag(10) +! minpcl3=rdiag(12) +! minpcl5=rdiag(14) +! minpcl6=rdiag(16) + if(idproc.eq.0)then + write(nfile1,myformat)z,xmin,xmax,pxmin,pxmax + write(nfile2,myformat)z,ymin,ymax,pymin,pymax + write(nfile3,myformat)z,tmin,tmax,ptmin,ptmax + write(nfile4,myformat)z,zmin,zmax,emin,emax +!!! write(nfile4,myformat)z,gamma*zmin,gamma*zmax,minpcl5,maxpcl5 +! call myflush(nfile1) +! call myflush(nfile2) +! call myflush(nfile3) +! call myflush(nfile4) + endif + return + end +! + subroutine profile1d(ncol,nbins,rwall,sarclen,nfile,fname, & + & nprecision) + use beamdata + use rays + use lieaparam, only : monoms + use ml_timer + include 'impli.inc' + include 'map.inc' + real*8, dimension(nbins) :: rho1d,rhotmp + real*8, dimension(2) :: bndy,rbndy + character*16 fname + call increment_timer('profile1d',0) +! write(6,*)'PE#',idproc,' is in profile1d w/ nraysp=',nraysp +! + if(idproc.eq.0)then +! write(6,*)'s= ',sarclen,';writing 1D profile on file ',fname + endif + if(rwall.gt.0.d0)then + xmin=-rwall + xmax=+rwall + else +! determine the range from the particle coords: + bndy(1)= maxval(zblock(ncol,:)) + bndy(2)=-minval(zblock(ncol,:)) + call MPI_ALLREDUCE(bndy,rbndy,2,mreal,mpimax,lworld,ierr) + xmax=rbndy(1) + xmin=-rbndy(2) +!DO express in physical units (i.e. meters): + xmin=xmin*sl + xmax=xmax*sl +! write(6,1122)sl +!1122 format(1x,'sl=',d21.14) +! a little bigger to make sure nothing falls off the end: + xmin=xmin*(1.d0+1.d-8) + xmax=xmax*(1.d0+1.d-8) + endif +! write(6,*)'inside profile1d w/ min,max=',xmin,xmax +! note that nbins is REALLY the number of grid points, not bins: + hx=(xmax-xmin)/(nbins-1) + hxi=1.d0/hx + rho1d=0.d0 + do n=1,nraysp + indx=(zblock(ncol,n)*sl-xmin)*hxi + 1 + if(indx.lt.1 .or. indx.gt.nbins-1)then +! write(6,*)'particle #',n,' is out of range; indx=',indx +! write(6,*)'zblock(' ,ncol, ',' ,n, ')=' ,zblock(ncol,n) + cycle + endif + ab=((xmin-zblock(ncol,n)*sl)+indx*hx)*hxi + rho1d(indx)=rho1d(indx)+ab + rho1d(indx+1)=rho1d(indx+1)+(1.d0-ab) + enddo +! +!------------------------------------------- +! now that every processor has its own 1d profile, sum them together +! on processor 0: + if(idproc.eq.0)then + do l=1,nvp-1 + call MPI_RECV(rhotmp,nbins,mreal,l,95,lworld,mpistat,ierr) +! write(6,*)'PE#0 has received rhotmp data from proc# ',l + rho1d(:)=rho1d(:)+rhotmp(:) + enddo + else + call MPI_SEND(rho1d,nbins,mreal,0,95,lworld,ierr) +! write(6,*)'PE#',idproc,' has sent is rho1d data.' + endif +!------------------------------------------- +! + if(idproc.eq.0)then + do n=1,nbins + xval=xmin+(n-1)*hx +! write(nfile,999,err=1001)xval,rho1d(n),arclen + write(nfile,999)xval,rho1d(n) + enddo + 999 format(3(1pe14.7,1x)) + total=sum(rho1d) + write(6,*)'s= ',sarclen,' ;total deposited=',total, & + & '; 1D profile to file ',fname + call increment_timer('profile1d',1) + return + 1001 write(6,*)'PE 0: TROUBLE WITH WRITE STMT IN PROFILE1D' + return + endif + call increment_timer('profile1d',1) +! write(6,*)'PE# ',idproc,' is returning from profile1d' + return + end +! + subroutine profilerad(ncol,nbins,rwall,sarclen,nfile,fname, & + & nprecision) + use beamdata + use rays + use lieaparam, only : monoms + use ml_timer + include 'impli.inc' + include 'map.inc' + real*8, dimension(nbins) :: rho1d,rhotmp,rhotest + real*8, dimension(2) :: bndy,rbndy + real*8, dimension(nraysp) :: radii + character*16 fname + call increment_timer('profile1d',0) +! write(6,*)'PE#',idproc,' is in profile1d w/ nraysp=',nraysp +! + if(idproc.eq.0)then + write(6,*)'s= ',sarclen,';writing radial profile on file ',fname + endif + clyte=299792458.d0 + t2z=beta*clyte/omegascl + do n=1,nraysp + radii(n)=sqrt( & + & (sl*zblock(1,n))**2+(sl*zblock(3,n))**2+(t2z*zblock(5,n))**2 ) + enddo + if(rwall.gt.0.d0)then + xmin=0.d0 + xmax=+rwall + else +! determine the range from the particle coords: + bndy(1)=maxval(radii(1:nraysp)) + bndy(2)=0.d0 + if(idproc.eq.0)then + write(6,*)'ready to call MPI_ALLREDUCE' + endif + call MPI_ALLREDUCE(bndy,rbndy,2,mreal,mpimax,lworld,ierr) + if(idproc.eq.0)then + write(6,*)'returned from MPI_ALLREDUCE' + endif + xmax=rbndy(1) + xmin=0.d0 +!DO express in physical units (i.e. meters): +! xmin=xmin*sl +! xmax=xmax*sl +! write(6,1122)sl +!1122 format(1x,'sl=',d21.14) +! a little bigger to make sure nothing falls off the end: +!!!!!!!!xmin=xmin*(1.d0+1.d-8) + xmax=xmax*(1.d0+1.d-8) + endif +! write(6,*)'inside profilerad w/ min,max=',xmin,xmax +! (old comment) note that nbins is REALLY the number of grid points, not bins. +! ABOVE COMMENT IS WRONG: in this routine nbins really IS the # of bins +!!!!!!hx=(xmax-xmin)/(nbins-1) + hx=xmax/nbins + hxi=1.d0/hx + bcon=hx*8.*asin(1.d0)*nbins + rho1d=0.d0 +!cryne This routine is a hacked version of the 1d histogram routine. +!cryne As such, its treatment of the value at r=0 is fishy, since I +!cryne will end up dividing by the radial values. + do n=1,nraysp + indx=(radii(n)-xmin)*hxi + 1 + if(indx.lt.1 .or. indx.gt.nbins)then +! if(indx.lt.1 .or. indx.gt.nbins-1)then !applies for linear weighting??? +! write(6,*)'particle #',n,' is out of range; indx=',indx +! write(6,*)'zblock(' ,ncol, ',' ,n, ')=' ,zblock(ncol,n) + if(rwall.gt.0.d0)then + cycle + else + write(6,*)'TROUBLE IN PROFILERAD, PE=',idproc + write(6,*)'xmin,xmax=',xmin,xmax + write(6,*)'n,radii(n)=',n,radii(n) + write(6,*)'indx=',indx + call myexit + endif + endif +!nearest grid point: +! rho1d(indx)=rho1d(indx)+(radii(n))**2 +!! rho1d(indx)=rho1d(indx)+(hx*(n-1))**2 +!!! rho1d(indx)=rho1d(indx)+(hx*(n-1)+0.5*hx)**2 + rho1d(indx)=rho1d(indx)+1.d0 +!linear weighting: +! ab=((xmin-radii(n))+indx*hx)*hxi +! rho1d(indx)=rho1d(indx)+ab +! rho1d(indx+1)=rho1d(indx+1)+(1.d0-ab) + enddo +! +!------------------------------------------- +! now that every processor has its own 1d profile, sum them together +! on processor 0: + if(idproc.eq.0)then + do l=1,nvp-1 + call MPI_RECV(rhotmp,nbins,mreal,l,95,lworld,mpistat,ierr) +! write(6,*)'PE#0 has received rhotmp data from proc# ',l + rho1d(:)=rho1d(:)+rhotmp(:) + enddo + else + call MPI_SEND(rho1d,nbins,mreal,0,95,lworld,ierr) +! write(6,*)'PE#',idproc,' has sent is rho1d data.' + endif +!------------------------------------------- + if(idproc.eq.0)then + write(6,*)'done with SEND and RECV' + endif +! +!cryne Here is the code for dealing the the radial values; +!cryne For now, I simply use the radial value at the bin center: +!cryne (Also, use rhotmp to hold the unscaled values) +!cryne (Also, use rhotest to scale by the radial value at the bin edge) + do n=1,nbins + rhotmp(n)=rho1d(n) + redge=hx*(n-1) + rcent=hx*(n-1)+0.5*hx + rho1d(n)=rho1d(n)/(bcon*rcent**2) + if(n.eq.1)rhotest(n)=0.d0 + if(n.ne.1)rhotest(n)=rhotmp(n)/(bcon*redge**2) + enddo + if(idproc.eq.0)then + write(6,*)'done computing rval and recomputing rho1d' + endif +! + if(idproc.eq.0)then + do n=1,nbins + xedge=xmin+(n-1)*hx + xcent=xmin+(n-1)*hx+0.5*hx +! write(nfile,999,err=1001)xcent,rho1d(n),arclen + write(nfile,999)xcent,rho1d(n),xedge,rhotest(n),rhotmp(n) + enddo + 999 format(5(1pe14.7,1x)) + total=sum(rho1d) + write(6,*)'Comment from Ryne: the following is not correct' + write(6,*)'for the radial histogram calculation. Fix later.' + write(6,*)'s= ',sarclen,' ;total deposited=',total, & + & '; 1D profile to file ',fname + call increment_timer('profile1d',1) + return + 1001 write(6,*)'PE 0: TROUBLE WITH WRITE STMT IN PROFILE1D' + return + endif + call increment_timer('profile1d',1) +! write(6,*)'PE# ',idproc,' is returning from profile1d' + return + end +! + subroutine writeenv2d(sarclen,nfile1,nfile2,nfile3, & + & nprecision,nunits,ncorr) +cryne routine to print 2nd moments obtained from env array + use parallel, only: idproc + use beamdata + include 'impli.inc' + include 'usrdat.inc' + integer :: nfile1,nfile2,nfile3,nprecision,nunits + real*8 sarclen + common/envdata/env(6),envold(6),emap(6,6) + common/emitdata/emxn2,emyn2,emtn2 +! + character*16 :: myformat='(6(1x,1pe12.5 ))' + character*2 :: a2 + + if(idproc.eq.0)then +!---format: + nlength=nprecision+7 + call num2string(nlength,a2,2) + myformat(10:11)=a2 + call num2string(nprecision,a2,2) + myformat(13:14)=a2 + endif +! + xl=sl + xk=1./xl + xlp0=xl*p0sc + xlp1=xlp0 + gambet=gamma*beta + clyte=299792458.d0 + wld=omegascl*xl*p0sc + z=sarclen +! + xrms=env(1) + xpx=env(2)*xrms + pxrms=0.d0 + if(xrms.ne.0.d0)pxrms=sqrt(emxn2+xpx**2)/xrms + epsx=sqrt(emxn2) +! + yrms=env(3) + ypy=env(4)*yrms + pyrms=0.d0 + if(yrms.ne.0.d0)pyrms=sqrt(emyn2+ypy**2)/yrms + epsy=sqrt(emyn2) +! + trms=env(5) + tpt=env(6)*trms + ptrms=0.d0 + if(trms.ne.0.d0)ptrms=sqrt(emtn2+tpt**2)/trms + epst=sqrt(emtn2) + if(ncorr.eq.1)then + xpxfac=0. + ypyfac=0. + tptfac=0. + if(xrms.ne.0. .and. pxrms.ne.0.)xpxfac=1./(xrms*pxrms) + if(yrms.ne.0. .and. pyrms.ne.0.)ypyfac=1./(yrms*pyrms) + if(trms.ne.0. .and. ptrms.ne.0.)tptfac=1./(trms*ptrms) + xpx=xpx*xpxfac + ypy=ypy*ypyfac + tpt=tpt*tptfac + xlp1=1.d0 + endif + if(idproc.eq.0)then + if(nunits.eq.0)then + write(nfile1,myformat)z,xrms,pxrms,xpx,epsx + write(nfile2,myformat)z,yrms,pyrms,ypy,epsy + else + write(nfile1,myformat)z,xrms*xl,pxrms*p0sc,xpx*xlp1,epsx*xlp0 + write(nfile2,myformat)z,yrms*xl,pyrms*p0sc,ypy*xlp1,epsy*xlp0 + endif + endif + ucalc(31)=xrms + ucalc(32)=pxrms + ucalc(33)=xpx + ucalc(34)=yrms + ucalc(35)=pyrms + ucalc(36)=ypy +! +! 3D (t-pt 2nd moments) + if(idproc.eq.0)then + if(nunits.eq.0)then + write(nfile3,myformat)z,trms,ptrms,tpt,epst + else + write(nfile3,myformat)z, & + & trms*beta*clyte/omegascl,ptrms*wld,tpt*xlp1,epst*xlp0 + endif + endif + ucalc(37)=trms + ucalc(38)=ptrms + ucalc(39)=tpt + return + end +! diff --git a/OpticsJan2020/MLI_light_optics/Src/dist.f b/OpticsJan2020/MLI_light_optics/Src/dist.f new file mode 100755 index 0000000..7a1606f --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/dist.f @@ -0,0 +1,2255 @@ +******************************************************************************* +* header: DIST * +* A collection of programs for generating, modifying, and * +* evaluating particle distributions * +******************************************************************************* + subroutine bgen(p,fa,fm) +c +c subroutine corresponding to the type code bgen +c written by Alex Dragt 6/14/91 +c modified 10/14/98 AJD +c modified by RDR on 7/28/2002. The quantity "nray" which is a dummy +c argument to several routines could be eliminated, in which case +c it should be replaced by nraysp in the body of the routines. +c I have left it in place in order to minimize changes to these routines. +c Note that, except for this routine (bgen), the variable "nrays" +c should not appear anywhere, since it is the global # of particles, +c and the remaining routines all use the local number, nraysp, which is +c passed in the argument lists and corresponds to "nray" in the routines. +c +c + use lieaparam, only : monoms + use rays + include 'impli.inc' + include 'buffer.inc' + include 'files.inc' + include 'parset.inc' +c +c calling arrays + dimension p(*) + dimension fa(*), fm(6,6) +c +c working arrays +c use buf1 and buf2: put numerical moments in buf1 and analytic +c moments in buf2 +c use buf3 as working space to store desired eigen moments +c +c set up control indices +c + job=nint(p(1)) + iopt=nint(p(2)) + nrays=nint(p(3)) + iseed=nint(p(4)) + isend=nint(p(5)) + ipset=nint(p(6)) +c +c read contents of pset ipset +c + if(ipset.ne.0)then + x2mom=pst(1,ipset) + y2mom=pst(2,ipset) + t2mom=pst(3,ipset) + if (x2mom .lt. 0.) then +c get eigenmoments from current map + x2mom=fa(7) + y2mom=fa(18) + t2mom=fa(25) + endif + sigmax=pst(4,ipset) + nof1=nint(pst(5,ipset)) + nof2=nint(pst(6,ipset)) + else + x2mom=p(7) + y2mom=p(8) + t2mom=p(9) + if (x2mom .lt. 0.) then +c get eigenmoments from current map + x2mom=fa(7) + y2mom=fa(18) + t2mom=fa(25) + endif + sigmax=p(10) + nof1=nint(p(11)) + nof2=nint(p(12)) + endif +c write(6,*)'done setting bgen parameters' +c write(6,*)'job,iopt,nrays=',job,iopt,nrays +c write(6,*)'iseed,isend,ipset=',iseed,isend,ipset +c write(6,*)'x2mom,y2mom,t2mom=',x2mom,y2mom,t2mom +c write(6,*)'sigmax=',sigmax +c write(6,*)'nof1,nof2=',nof1,nof2 +c +c put eigen moments in buf3 +c + call clear(buf3a,buf3m) + buf3a(7)=x2mom + buf3a(13)=x2mom + buf3a(18)=y2mom + buf3a(22)=y2mom + buf3a(25)=t2mom + buf3a(27)=t2mom +c +c select job +c +c compute moments of particle distribution, and write them on +c an external file, the terminal and/or a drop file + if (job .eq. 0) then +c +c if (iopt .ne. 6) then +c +c compute moments of particle distribution + call cmom(buf1a,buf1m) +c write moments on file nof1 + mpt=mpo + mpo=nof1 + if(mpo .gt. 0) call mapout(0,buf1a,buf1m) + mpo=mpt +c +c else +c compute moments of particle distribution including <5> and <6> +c call cmom5(buf1a) +c write moments on file nof1 +c mpt=mpo +c mpo=nof1 +c call mapout5(0,buf1a,buf1m) +c mpo=mpt +c endif +c +c print selected numerical moments at terminal and/or write on drop file + if(isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) ' ' + write(jof,*) + & ' numerically computed values of selected moments' + write(jof,*) ' values of , , :' + write(jof,*) buf1a(7),buf1a(8),buf1a(13) + write(jof,*) ' values of , , :' + write(jof,*) buf1a(18),buf1a(19),buf1a(22) + write(jof,*) ' values of , , :' + write(jof,*) buf1a(25),buf1a(26),buf1a(27) + endif + if(isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) ' ' + write(jodf,*) + & ' numerically computed values of selected moments' + write(jodf,*) ' values of , , :' + write(jodf,*) buf1a(7),buf1a(8),buf1a(13) + write(jodf,*) ' values of , , :' + write(jodf,*) buf1a(18),buf1a(19),buf1a(22) + write(jodf,*) ' values of , , :' + write(jodf,*) buf1a(25),buf1a(26),buf1a(27) + endif + endif +c +c for other values of job generate various distributions +c and/or moments +c +cryne 7/28/2002 +c before particles can be generated, each processor needs to know +c how many it owns: + nraysp=(nrays-1)/nvp + 1 + 1221 continue + if(nraysp*(nvp-1).ge.nrays)then + nraysp=nraysp-1 + if(nraysp.eq.0)then + write(6,*)'trouble: nraysp=0. something wrong. halting.' + endif + goto 1221 + endif +c + if(idproc.eq.nvp-1)nraysp = nrays - nraysp*(nvp-1) +c has the zblock array been allocated? + if(.not.allocated(zblock))then + if(idproc.eq.0)write(6,*)'setting maxray=',nrays,' ;allocating' + maxray=nrays + call new_particledata + endif +c also, need a different seed on every processor: + seedfac=1.+float(idproc)/float(nvp) + iseed=iseed*seedfac +c write(6,*)'idproc,iseed=',idproc,iseed +c warm up the F90 random number generator because it is needed +c to generate big vectors of random numbers: + call f90ranset(iseed) +c +c uniformly filled ellipse or ellipsoids + if (job .eq. 1) then +c set up scaling factors + sx=sqrt(4.d0*x2mom) + sy=0.d0 + st=0.d0 + if(iopt .eq. 1) call re2d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 2) call cmre2d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call re2d(nraysp,iseed,sx,sy,st) + call cmre2d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call re2d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 123) then + call re2d(nraysp,iseed,sx,sy,st) + call cmre2d(buf2a,buf2m,sx,sy,st) + endif + endif +c + if (job .eq. 2) then +c set up scaling factors + sx=sqrt(6.d0*x2mom) + sy=sqrt(6.d0*y2mom) + st=0.d0 + if(iopt .eq. 1) call re4d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 2) call cmre4d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call re4d(nraysp,iseed,sx,sy,st) + call cmre4d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call re4d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 123) then + call re4d(nraysp,iseed,sx,sy,st) + call cmre4d(buf2a,buf2m,sx,sy,st) + endif + endif +c + if (job .eq. 3) then +c set up scaling factors + sx=sqrt(8.d0*x2mom) + sy=sqrt(8.d0*y2mom) + st=sqrt(8.d0*t2mom) + if(iopt .eq. 1) call re6d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 2) call cmre6d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call re6d(nraysp,iseed,sx,sy,st) + call cmre6d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call re6d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 123) then + call re6d(nraysp,iseed,sx,sy,st) + call cmre6d(buf2a,buf2m,sx,sy,st) + endif + endif +c +c gaussian distributions + if (job .eq. 4) then +c set up scaling factors + sx=sqrt(x2mom) + sy=0.d0 + st=0.d0 + if(iopt .eq. 1) call rg2d(nraysp,iseed,sigmax,sx,sy,st) + if(iopt .eq. 2) call cmrg2d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call rg2d(nraysp,iseed,sigmax,sx,sy,st) + call cmrg2d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call rg2d(nraysp,iseed,sigmax,sx,sy,st) + if(iopt .eq. 123) then + call rg2d(nraysp,iseed,sigmax,sx,sy,st) + call cmrg2d(buf2a,buf2m,sx,sy,st) + endif + endif +c + if (job .eq. 5) then +c set up scaling factors + sx=sqrt(x2mom) + sy=sqrt(y2mom) + st=0.d0 + if(iopt .eq. 1) call rg4d(nraysp,iseed,sigmax,sx,sy,st) + if(iopt .eq. 2) call cmrg4d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call rg4d(nraysp,iseed,sigmax,sx,sy,st) + call cmrg4d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call rg4d(nraysp,iseed,sigmax,sx,sy,st) + if(iopt .eq. 123) then + call rg4d(nraysp,iseed,sigmax,sx,sy,st) + call cmrg4d(buf2a,buf2m,sx,sy,st) + endif + endif +c + if (job .eq. 6) then +c set up scaling factors + sx=sqrt(x2mom) + sy=sqrt(y2mom) + st=sqrt(t2mom) + if(iopt .eq. 1) call rg6d(nraysp,iseed,sigmax,sx,sy,st) + if(iopt .eq. 2) call cmrg6d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call rg6d(nraysp,iseed,sigmax,sx,sy,st) + call cmrg6d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call rg6d(nraysp,iseed,sigmax,sx,sy,st) + if(iopt .eq. 123) then + call rg6d(nraysp,iseed,sigmax,sx,sy,st) + call cmrg6d(buf2a,buf2m,sx,sy,st) + endif + endif +c +c systematic uniform tori + if (job .eq. 7) then +c set up scaling factors + sx=sqrt(2.d0*x2mom) + sy=0.d0 + st=0.d0 + if(iopt .eq. 1) call st2d(nraysp,sx,sy,st) + if(iopt .eq. 2) call cmst2d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call st2d(nraysp,sx,sy,st) + call cmst2d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call st2d(nraysp,sx,sy,st) + if(iopt .eq. 123) then + call st2d(nraysp,sx,sy,st) + call cmst2d(buf2a,buf2m,sx,sy,st) + endif + endif +c + if (job .eq. 8) then +c set up scaling factors + sx=sqrt(2.d0*x2mom) + sy=sqrt(2.d0*y2mom) + st=0.d0 + if(iopt .eq. 1) call st4d(nraysp,sx,sy,st) + if(iopt .eq. 2) call cmst4d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call st4d(nraysp,sx,sy,st) + call cmst4d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call st4d(nraysp,sx,sy,st) + if(iopt .eq. 123) then + call st4d(nraysp,sx,sy,st) + call cmst4d(buf2a,buf2m,sx,sy,st) + endif + endif +c + if (job .eq. 9) then +c set up scaling factors + sx=sqrt(2.d0*x2mom) + sy=sqrt(2.d0*y2mom) + st=sqrt(2.d0*t2mom) + if(iopt .eq. 1) call st6d(nraysp,sx,sy,st) + if(iopt .eq. 2) call cmst6d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call st6d(nraysp,sx,sy,st) + call cmst6d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call st6d(nraysp,sx,sy,st) + if(iopt .eq. 123) then + call st6d(nraysp,sx,sy,st) + call cmst6d(buf2a,buf2m,sx,sy,st) + endif + endif +c +c random uniform tori + if (job .eq. 10) then +c set up scaling factors + sx=sqrt(2.d0*x2mom) + sy=0.d0 + st=0.d0 + if(iopt .eq. 1) call rt2d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 2) call cmst2d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call rt2d(nraysp,iseed,sx,sy,st) + call cmst2d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call rt2d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 123) then + call rt2d(nraysp,iseed,sx,sy,st) + call cmst2d(buf2a,buf2m,sx,sy,st) + endif + endif +c + if (job .eq. 11) then +c set up scaling factors + sx=sqrt(2.d0*x2mom) + sy=sqrt(2.d0*y2mom) + st=0.d0 + if(iopt .eq. 1) call rt4d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 2) call cmst4d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call rt4d(nraysp,iseed,sx,sy,st) + call cmst4d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call rt4d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 123) then + call rt4d(nraysp,iseed,sx,sy,st) + call cmst4d(buf2a,buf2m,sx,sy,st) + endif + endif +c + if (job .eq. 12) then +c set up scaling factors + sx=sqrt(2.d0*x2mom) + sy=sqrt(2.d0*y2mom) + st=sqrt(2.d0*t2mom) + if(iopt .eq. 1) call rt6d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 2) call cmst6d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call rt6d(nraysp,iseed,sx,sy,st) + call cmst6d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call rt6d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 123) then + call rt6d(nraysp,iseed,sx,sy,st) + call cmst6d(buf2a,buf2m,sx,sy,st) + endif + endif +c +c KV distribution in 4-D phase space + if (job .eq. 13) then +c set up scaling factors + sx=sqrt(4.d0*x2mom) + sy=sqrt(4.d0*y2mom) + st=0.d0 + if(iopt .eq. 1) call kv4d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 2) call cmkv4d(buf2a,buf2m,sx,sy,st) + if(iopt .eq. 12) then + call kv4d(nraysp,iseed,sx,sy,st) + call cmkv4d(buf2a,buf2m,sx,sy,st) + endif + if(iopt .eq. 13) call kv4d(nraysp,iseed,sx,sy,st) + if(iopt .eq. 123) then + call kv4d(nraysp,iseed,sx,sy,st) + call cmkv4d(buf2a,buf2m,sx,sy,st) + endif + endif +c +c write to files and write selected numerical/analytic moments +c at terminal and/or drop file +c + if (job .ne. 0) then +c + if (iopt .eq. 2 .or. iopt .eq. 12) then +c write analytic moments to an external file and to +c terminal and/or drop file + mpt=mpo + mpo=nof2 + if(mpo .gt. 0) call mapout (0,buf2a,buf2m) + mpo=mpt + if(isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) ' ' + write(jof,*) + & ' analytically computed values of selected moments' + write(jof,*) ' values of , , :' + write(jof,*) buf2a(7),buf2a(8),buf2a(13) + write(jof,*) ' values of , , :' + write(jof,*) buf2a(18),buf2a(19),buf2a(22) + write(jof,*) ' values of , , :' + write(jof,*) buf2a(25),buf2a(26),buf2a(27) + endif + if(isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) ' ' + write(jodf,*) + & ' analytically computed values of selected moments' + write(jodf,*) ' values of , , :' + write(jodf,*) buf2a(7),buf2a(8),buf2a(13) + write(jodf,*) ' values of , , :' + write(jodf,*) buf2a(18),buf2a(19),buf2a(22) + write(jodf,*) ' values of , , :' + write(jodf,*) buf2a(25),buf2a(26),buf2a(27) + endif + endif +c +c compute numerical moments and write numerical moments to +c an external file and to terminal and/or drop file + if (iopt .eq. 13) then + call cmom(buf1a,buf1m) + mpt=mpo + mpo=nof1 + if(mpo .gt. 0) call mapout(0,buf1a,buf1m) + mpo=mpt + if(isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) ' ' + write(jof,*) + & ' numerically computed values of selected moments' + write(jof,*) ' values of , , :' + write(jof,*) buf1a(7),buf1a(8),buf1a(13) + write(jof,*) ' values of , , :' + write(jof,*) buf1a(18),buf1a(19),buf1a(22) + write(jof,*) ' values of , , :' + write(jof,*) buf1a(25),buf1a(26),buf1a(27) + endif + if(isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) ' ' + write(jodf,*) + & ' numerically computed values of selected moments' + write(jodf,*) ' values of , , :' + write(jodf,*) buf1a(7),buf1a(8),buf1a(13) + write(jodf,*) ' values of , , :' + write(jodf,*) buf1a(18),buf1a(19),buf1a(22) + write(jodf,*) ' values of , , :' + write(jodf,*) buf1a(25),buf1a(26),buf1a(27) + endif + endif +c +c compute numerical moments and write numerical and analytic +c moments to external files and to terminal and/or drop file + if (iopt .eq. 123) then + call cmom(buf1a,buf1m) + mpt=mpo + mpo=nof1 + if(mpo .gt. 0) call mapout(0,buf1a,buf1m) + mpo=nof2 + if(mpo .gt. 0) call mapout(0,buf2a,buf2m) + mpo=mpt + if(isend .eq. 1 .or. isend .eq. 3) then + write(jof,*) ' ' + write(jof,*) + & ' numerically computed values of selected moments' + write(jof,*) ' values of , , :' + write(jof,*) buf1a(7),buf1a(8),buf1a(13) + write(jof,*) ' values of , , :' + write(jof,*) buf1a(18),buf1a(19),buf1a(22) + write(jof,*) ' values of , , :' + write(jof,*) buf1a(25),buf1a(26),buf1a(27) + write(jof,*) ' ' + write(jof,*) + & ' analytically computed values of selected moments' + write(jof,*) ' values of , , :' + write(jof,*) buf2a(7),buf2a(8),buf2a(13) + write(jof,*) ' values of , , :' + write(jof,*) buf2a(18),buf2a(19),buf2a(22) + write(jof,*) ' values of , , :' + write(jof,*) buf2a(25),buf2a(26),buf2a(27) + endif + if(isend .eq. 2 .or. isend .eq. 3) then + write(jodf,*) ' ' + write(jodf,*) + & ' numerically computed values of selected moments' + write(jodf,*) ' values of , , :' + write(jodf,*) buf1a(7),buf1a(8),buf1a(13) + write(jodf,*) ' values of , , :' + write(jodf,*) buf1a(18),buf1a(19),buf1a(22) + write(jodf,*) ' values of , , :' + write(jodf,*) buf1a(25),buf1a(26),buf1a(27) + write(jodf,*) ' ' + write(jodf,*) + & ' analytically computed values of selected moments' + write(jodf,*) ' values of , , :' + write(jodf,*) buf2a(7),buf2a(8),buf2a(13) + write(jodf,*) ' values of , , :' + write(jodf,*) buf2a(18),buf2a(19),buf2a(22) + write(jodf,*) ' values of , , :' + write(jodf,*) buf2a(25),buf2a(26),buf2a(27) + endif + endif +c + endif +c + return + end +c +******************************************************************************** +c + subroutine cmre2d(fa,fm,sx,sy,st) +c subroutine to compute analytic moments of a 2D random +c uniform distribution that fills a 2D ellipse in phase space +c written by Alex Dragt 7/15/91 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms), fm(6,6) +c +c procedure +c +c clear array + do 10 i=1,monoms + 10 fa(i)=0.d0 +c compute squares + sx2=sx*sx +c compute nonzero moments +c quadratic moments + fa(7)=sx2/4.d0 + fa(13)=sx2/4.d0 +c matrix of moments + call mclear(fm) + fm(1,1)=fa(7) + fm(2,2)=fa(13) +c quartic moments + fa(84)=sx2*sx2*(1.d0/8.d0) + fa(90)=sx2*sx2*(1.d0/24.d0) + fa(140)=sx2*sx2*(1.d0/8.d0) +c + return + end +c +******************************************************************************** +c + subroutine cmre4d(fa,fm,sx,sy,st) +c subroutine to compute analytic moments of a 4D random +c uniform distribution that fills a 4D ellipsoid in phase space +c written by Alex Dragt 7/15/91 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms),fm(6,6) +c +c procedure +c +c clear array + do 10 i=1,monoms + 10 fa(i)=0.d0 +c compute squares + sx2=sx*sx + sy2=sy*sy +c compute nonzero moments +c quadratic moments + fa(7)=sx2/6.d0 + fa(13)=sx2/6.d0 + fa(18)=sy2/6.d0 + fa(22)=sy2/6.d0 +c matrix of moments + call mclear(fm) + fm(1,1)=fa(7) + fm(2,2)=fa(13) + fm(3,3)=fa(18) + fm(4,4)=fa(22) +c quartic moments + fa(84)=sx2*sx2*(1.d0/16.d0) + fa(90)=sx2*sx2*(1.d0/48.d0) + fa(95)=sx2*sy2*(1.d0/48.d0) + fa(99)=sx2*sy2*(1.d0/48.d0) + fa(140)=sx2*sx2*(1.d0/16.d0) + fa(145)=sx2*sy2*(1.d0/48.d0) + fa(149)=sx2*sy2*(1.d0/48.d0) + fa(175)=sy2*sy2*(1.d0/16.d0) + fa(179)=sy2*sy2*(1.d0/48.d0) + fa(195)=sy2*sy2*(1.d0/16.d0) +c + return + end +c +******************************************************************************** +c + subroutine cmre6d(fa,fm,sx,sy,st) +c subroutine to compute analytic moments of a 6D random +c uniform distribution that fills a 6D ellipsoid in phase space +c written by Alex Dragt 7/15/91 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms),fm(6,6) +c +c procedure +c +c clear array + do 10 i=1,monoms + 10 fa(i)=0.d0 +c compute squares + sx2=sx*sx + sy2=sy*sy + st2=st*st +c compute nonzero moments +c quadratic moments + fa(7)=sx2/8.d0 + fa(13)=sx2/8.d0 + fa(18)=sy2/8.d0 + fa(22)=sy2/8.d0 + fa(25)=st2/8.d0 + fa(27)=st2/8.d0 +c matrix of moments + call mclear(fm) + fm(1,1)=fa(7) + fm(2,2)=fa(13) + fm(3,3)=fa(18) + fm(4,4)=fa(22) + fm(5,5)=fa(25) + fm(6,6)=fa(27) +c quartic moments + fa(84)=sx2*sx2*(3.d0/80.d0) + fa(90)=sx2*sx2*(1.d0/80.d0) + fa(95)=sx2*sy2*(1.d0/80.d0) + fa(99)=sx2*sy2*(1.d0/80.d0) + fa(102)=sx2*st2*(1.d0/80.d0) + fa(104)=sx2*st2*(1.d0/80.d0) + fa(140)=sx2*sx2*(3.d0/80.d0) + fa(145)=sx2*sy2*(1.d0/80.d0) + fa(149)=sx2*sy2*(1.d0/80.d0) + fa(152)=sx2*st2*(1.d0/80.d0) + fa(154)=sx2*st2*(1.d0/80.d0) + fa(175)=sy2*sy2*(3.d0/80.d0) + fa(179)=sy2*sy2*(1.d0/80.d0) + fa(182)=sy2*st2*(1.d0/80.d0) + fa(184)=sy2*st2*(1.d0/80.d0) + fa(195)=sy2*sy2*(3.d0/80.d0) + fa(198)=sy2*st2*(1.d0/80.d0) + fa(200)=sy2*st2*(1.d0/80.d0) + fa(205)=st2*st2*(3.d0/80.d0) + fa(207)=st2*st2*(1.d0/80.d0) + fa(209)=st2*st2*(3.d0/80.d0) +c + return + end +c +******************************************************************************** +c + subroutine cmrg2d(fa,fm,sx,sy,st) +c subroutine to compute analytic moments of a 2D random +c gaussian distribution +c written by Alex Dragt 7/15/91 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms),fm(6,6) +c +c procedure +c +c clear array + do 10 i=1,monoms + 10 fa(i)=0.d0 +c compute squares + sx2=sx*sx +c compute nonzero moments +c quadratic moments + fa(7)=sx2 + fa(13)=sx2 +c matrix of moments + call mclear(fm) + fm(1,1)=fa(7) + fm(2,2)=fa(13) +c quartic moments + fa(84)=sx2*sx2*(3.d0) + fa(90)=sx2*sx2 + fa(140)=sx2*sx2*(3.d0) +c + return + end +c +******************************************************************************** +c + subroutine cmrg4d(fa,fm,sx,sy,st) +c subroutine to compute analytic moments of a 4D random +c gaussian distribution +c written by Alex Dragt 7/15/91 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms),fm(6,6) +c +c procedure +c +c clear array + do 10 i=1,monoms + 10 fa(i)=0.d0 +c compute squares + sx2=sx*sx + sy2=sy*sy +c compute nonzero moments +c quadratic moments + fa(7)=sx2 + fa(13)=sx2 + fa(18)=sy2 + fa(22)=sy2 +c matrix of moments + call mclear(fm) + fm(1,1)=fa(7) + fm(2,2)=fa(13) + fm(3,3)=fa(18) + fm(4,4)=fa(22) +c quartic moments + fa(84)=sx2*sx2*(3.d0) + fa(90)=sx2*sx2 + fa(95)=sx2*sy2 + fa(99)=sx2*sy2 + fa(140)=sx2*sx2*(3.d0) + fa(145)=sx2*sy2 + fa(149)=sx2*sy2 + fa(175)=sy2*sy2*(3.d0) + fa(179)=sy2*sy2 + fa(195)=sy2*sy2*(3.d0) +c + return + end +c +******************************************************************************** +c + subroutine cmrg6d(fa,fm,sx,sy,st) +c subroutine to compute analytic moments of a 6D random +c gaussian distribution +c written by Alex Dragt 7/15/91 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms),fm(6,6) +c +c procedure +c +c clear array + do 10 i=1,monoms + 10 fa(i)=0.d0 +c compute squares + sx2=sx*sx + sy2=sy*sy + st2=st*st +c compute nonzero moments +c quadratic moments + fa(7)=sx2 + fa(13)=sx2 + fa(18)=sy2 + fa(22)=sy2 + fa(25)=st2 + fa(27)=st2 +c matrix of moments + call mclear(fm) + fm(1,1)=fa(7) + fm(2,2)=fa(13) + fm(3,3)=fa(18) + fm(4,4)=fa(22) + fm(5,5)=fa(25) + fm(6,6)=fa(27) +c quartic moments + fa(84)=sx2*sx2*(3.d0) + fa(90)=sx2*sx2 + fa(95)=sx2*sy2 + fa(99)=sx2*sy2 + fa(102)=sx2*st2 + fa(104)=sx2*st2 + fa(140)=sx2*sx2*(3.d0) + fa(145)=sx2*sy2 + fa(149)=sx2*sy2 + fa(152)=sx2*st2 + fa(154)=sx2*st2 + fa(175)=sy2*sy2*(3.d0) + fa(179)=sy2*sy2 + fa(182)=sy2*st2 + fa(184)=sy2*st2 + fa(195)=sy2*sy2*(3.d0) + fa(198)=sy2*st2 + fa(200)=sy2*st2 + fa(205)=st2*st2*(3.d0) + fa(207)=st2*st2 + fa(209)=st2*st2*(3.d0) +c + return + end +c +******************************************************************************** +c + subroutine cmst2d(fa,fm,sx,sy,st) +c subroutine to compute analytic moments of a 2D systematic +c distribution on a torus +c written by Alex Dragt 7/15/91 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms),fm(6,6) +c +c procedure +c +c clear array + do 10 i=1,monoms + 10 fa(i)=0.d0 +c compute squares + sx2=sx*sx +c compute nonzero moments +c quadratic moments + fa(7)=sx2/2.d0 + fa(13)=sx2/2.d0 +c matrix of moments + call mclear(fm) + fm(1,1)=fa(7) + fm(2,2)=fa(13) +c quartic moments + fa(84)=sx2*sx2*(3.d0/8.d0) + fa(90)=sx2*sx2*(1.d0/8.d0) + fa(140)=sx2*sx2*(3.d0/8.d0) +c + return + end +c +******************************************************************************** +c + subroutine cmst4d(fa,fm,sx,sy,st) +c subroutine to compute analytic moments of a 4D systematic +c distribution on a torus +c written by Alex Dragt 7/15/91 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms),fm(6,6) +c +c procedure +c +c clear array + do 10 i=1,monoms + 10 fa(i)=0.d0 +c compute squares + sx2=sx*sx + sy2=sy*sy +c compute nonzero moments +c quadratic moments + fa(7)=sx2/2.d0 + fa(13)=sx2/2.d0 + fa(18)=sy2/2.d0 + fa(22)=sy2/2.d0 +c matrix of moments + call mclear(fm) + fm(1,1)=fa(7) + fm(2,2)=fa(13) + fm(3,3)=fa(18) + fm(4,4)=fa(22) +c quartic moments + fa(84)=sx2*sx2*(3.d0/8.d0) + fa(90)=sx2*sx2*(1.d0/8.d0) + fa(95)=sx2*sy2*(1.d0/4.d0) + fa(99)=sx2*sy2*(1.d0/4.d0) + fa(140)=sx2*sx2*(3.d0/8.d0) + fa(145)=sx2*sy2*(1.d0/4.d0) + fa(149)=sx2*sy2*(1.d0/4.d0) + fa(175)=sy2*sy2*(3.d0/8.d0) + fa(179)=sy2*sy2*(1.d0/8.d0) + fa(195)=sy2*sy2*(3.d0/8.d0) +c + return + end +c +******************************************************************************** +c + subroutine cmst6d(fa,fm,sx,sy,st) +c subroutine to compute analytic moments of a 6D systematic +c distribution on a torus +c written by Alex Dragt 7/15/91 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms),fm(6,6) +c +c procedure +c +c clear array + do 10 i=1,monoms + 10 fa(i)=0.d0 +c compute squares + sx2=sx*sx + sy2=sy*sy + st2=st*st +c compute nonzero moments +c quadratic moments + fa(7)=sx2/2.d0 + fa(13)=sx2/2.d0 + fa(18)=sy2/2.d0 + fa(22)=sy2/2.d0 + fa(25)=st2/2.d0 + fa(27)=st2/2.d0 +c matrix of moments + call mclear(fm) + fm(1,1)=fa(7) + fm(2,2)=fa(13) + fm(3,3)=fa(18) + fm(4,4)=fa(22) + fm(5,5)=fa(25) + fm(6,6)=fa(27) +c quartic moments + fa(84)=sx2*sx2*(3.d0/8.d0) + fa(90)=sx2*sx2*(1.d0/8.d0) + fa(95)=sx2*sy2*(1.d0/4.d0) + fa(99)=sx2*sy2*(1.d0/4.d0) + fa(102)=sx2*st2*(1.d0/4.d0) + fa(104)=sx2*st2*(1.d0/4.d0) + fa(140)=sx2*sx2*(3.d0/8.d0) + fa(145)=sx2*sy2*(1.d0/4.d0) + fa(149)=sx2*sy2*(1.d0/4.d0) + fa(152)=sx2*st2*(1.d0/4.d0) + fa(154)=sx2*st2*(1.d0/4.d0) + fa(175)=sy2*sy2*(3.d0/8.d0) + fa(179)=sy2*sy2*(1.d0/8.d0) + fa(182)=sy2*st2*(1.d0/4.d0) + fa(184)=sy2*st2*(1.d0/4.d0) + fa(195)=sy2*sy2*(3.d0/8.d0) + fa(198)=sy2*st2*(1.d0/4.d0) + fa(200)=sy2*st2*(1.d0/4.d0) + fa(205)=st2*st2*(3.d0/8.d0) + fa(207)=st2*st2*(1.d0/8.d0) + fa(209)=st2*st2*(3.d0/8.d0) +c + return + end +c +******************************************************************************** +c + subroutine cmkv4d(fa,fm,sx,sy,st) +c subroutine to compute analytic moments of a 4-variable +c KV distribution +c written by Alex Dragt 7/15/91 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms),fm(6,6) +c +c procedure +c +c clear array + do 10 i=1,monoms + 10 fa(i)=0.d0 +c compute squares + sx2=sx*sx + sy2=sy*sy +c compute nonzero moments +c quadratic moments + fa(7)=sx2/4.d0 + fa(13)=sx2/4.d0 + fa(18)=sy2/4.d0 + fa(22)=sy2/4.d0 +c matrix of moments + call mclear(fm) + fm(1,1)=fa(7) + fm(2,2)=fa(13) + fm(3,3)=fa(18) + fm(4,4)=fa(22) +c quartic moments + fa(84)=sx2*sx2*(1.d0/8.d0) + fa(90)=sx2*sx2*(1.d0/24.d0) + fa(95)=sx2*sy2*(1.d0/24.d0) + fa(99)=sx2*sy2*(1.d0/24.d0) + fa(140)=sx2*sx2*(1.d0/8.d0) + fa(145)=sx2*sy2*(1.d0/24.d0) + fa(149)=sx2*sy2*(1.d0/24.d0) + fa(175)=sy2*sy2*(1.d0/8.d0) + fa(179)=sy2*sy2*(1.d0/24.d0) + fa(195)=sy2*sy2*(1.d0/8.d0) +c + return + end +c +******************************************************************************** +c + subroutine re2d(nray,iseed,sx,sy,st) +c +c subroutine to generate a 2D random uniform distribution that fills +c a 2D ellipse in phase space +c written by Alex Dragt 7/6/91 +c + use rays + include 'impli.inc' + include 'files.inc' +c +c working arrays + dimension z(2) +c +c proceedure +c +c initialize indices and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + call myexit + endif +cryne nrays=nray +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c +c fill zblock +c +c select and warmup random number generator +c + if (iseed .lt. 0) ktype=1 + if (iseed .eq. 0) then + write(jof,*) ' iseed = 0 in bgen call' + call myexit + return + endif + if (iseed .gt. 0) ktype=2 + iseed=-iabs(iseed) + call myrand(ktype,iseed,ans) +c + do 20 j=1,nray +c generate a ray + 5 sumsq=0.d0 + do 10 i=1,2 + call myrand(ktype,iseed,ans) + z(i)=2.d0*ans-1.d0 + 10 sumsq=sumsq+z(i)*z(i) + if(sumsq .gt. 1.d0) goto 5 +c scale and store ray in zblock + zblock(1,j)=sx*z(1) + zblock(2,j)=sx*z(2) + zblock(3,j)=0.d0 + zblock(4,j)=0.d0 + zblock(5,j)=0.d0 + zblock(6,j)=0.d0 + 20 continue + write(6,*) nray, ' rays generated by re2d on PE# ',idproc +c + return + end +c +******************************************************************************** +c + subroutine re4d(nray,iseed,sx,sy,st) +c +c subroutine to generate a 4D random uniform distribution that fills +c a 4D ellipsoid in phase space +c written by Alex Dragt 7/6/91 +c + use rays + include 'impli.inc' + include 'files.inc' +c +c working arrays + dimension z(4) +c +c proceedure +c +c initialize indices and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + call myexit + endif +cryne nrays=nray +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c +c fill zblock +c +c select and warmup random number generator +c + if (iseed .lt. 0) ktype=1 + if (iseed .eq. 0) then + write(jof,*) ' iseed = 0 in bgen call' + call myexit + return + endif + if (iseed .gt. 0) ktype=2 + iseed=-iabs(iseed) + call myrand(ktype,iseed,ans) +c + do 20 j=1,nray +c generate a ray + 5 sumsq=0.d0 + do 10 i=1,4 + call myrand(ktype,iseed,ans) + z(i)=2.d0*ans-1.d0 + 10 sumsq=sumsq+z(i)*z(i) + if(sumsq .gt. 1.d0) goto 5 +c scale and store ray in zblock + zblock(1,j)=sx*z(1) + zblock(2,j)=sx*z(2) + zblock(3,j)=sy*z(3) + zblock(4,j)=sy*z(4) + zblock(5,j)=0.d0 + zblock(6,j)=0.d0 + 20 continue + write(6,*) nray, ' rays generated by re4d on PE# ',idproc +c + return + end +c +******************************************************************************** +c + subroutine re6d(nray,iseed,sx,sy,st) +c +c subroutine to generate a 6D random uniform distribution that fills +c a 6D ellipsoid in phase space +c written by Alex Dragt 7/6/91 +c + use rays + include 'impli.inc' + include 'files.inc' + integer, parameter :: ichunk=10000 +c +c working arrays + dimension z(6),za(6*ichunk) +c +c procedure +c +c initialize indices and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + write(6,*) 'nray=',nray + write(6,*) 'maxrayp=',maxrayp + call myexit + endif +cryne nrays=nray +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c +c fill zblock +c +c select and warmup random number generator +c + if (iseed .lt. 0) ktype=1 + if (iseed .eq. 0) then + write(jof,*) ' iseed = 0 in bgen call' + call myexit + return + endif + if (iseed .gt. 0) ktype=2 + iseed=-iabs(iseed) + call myrand(ktype,iseed,ans) +c +c procedure to generate a small number (~few thousand) of rays: +cryne 1/11/2005 if(nray.gt.5000)goto 23 + if(nray.gt.500000)goto 23 + do 20 j=1,nray +c generate a ray + 5 sumsq=0.d0 + do 10 i=1,6 + call myrand(ktype,iseed,ans) + z(i)=2.d0*ans-1.d0 + 10 sumsq=sumsq+z(i)*z(i) + if(sumsq .gt. 1.d0) goto 5 +c scale and store ray in zblock + zblock(1,j)=sx*z(1) + zblock(2,j)=sx*z(2) + zblock(3,j)=sy*z(3) + zblock(4,j)=sy*z(4) + zblock(5,j)=st*z(5) + zblock(6,j)=st*z(6) + 20 continue + goto 999 +c + 23 continue +c procedure to generate a large number of rays: + j=0 + 24 continue + call random_number(za) + do i=1,6*ichunk-5,6 + sumsq=(2.d0*za(i) -1.d0)**2+(2.d0*za(i+1)-1.d0)**2 & + & +(2.d0*za(i+2)-1.d0)**2+(2.d0*za(i+3)-1.d0)**2 & + & +(2.d0*za(i+4)-1.d0)**2+(2.d0*za(i+5)-1.d0)**2 + if(sumsq .gt. 1.d0)cycle + j=j+1 + if(j.gt.nray)exit +c scale and store ray in zblock + zblock(1,j)=sx*za(i) + zblock(2,j)=sx*za(i+1) + zblock(3,j)=sy*za(i+2) + zblock(4,j)=sy*za(i+3) + zblock(5,j)=st*za(i+4) + zblock(6,j)=st*za(i+5) + enddo + if(j.lt.nray)goto 24 +c + 999 continue + write(6,*) nray, ' rays generated by re6d on PE# ',idproc +c + return + end +c +******************************************************************************** +c + subroutine rg2d(nray,iseed,sigmax,sx,sy,st) +c +c subroutine to generate a 2D gaussian distribution +c written by Alex Dragt 7/10/91 +c + use rays + include 'impli.inc' + include 'files.inc' +c +c working arrays + dimension z(2) +c +c proceedure +c +c initialize indices and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + call myexit + endif +cryne nrays=nray +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c +c fill zblock +c +c select and warmup random number generator +c + if (iseed .lt. 0) ktype=1 + if (iseed .eq. 0) then + write(jof,*) ' iseed = 0 in bgen call' + call myexit + return + endif + if (iseed .gt. 0) ktype=2 + iseed=-iabs(iseed) + call myrand(ktype,iseed,ans) +c + sigm2=sigmax**2 + do 20 j=1,nray +c generate a ray + 25 call normdv(z,1,ktype,iseed) + ssq = z(1)**2 +z(2)**2 + if(ssq .gt. sigm2) go to 25 +c scale and store ray in zblock + zblock(1,j)=sx*z(1) + zblock(2,j)=sx*z(2) + zblock(3,j)=0.d0 + zblock(4,j)=0.d0 + zblock(5,j)=0.d0 + zblock(6,j)=0.d0 + 20 continue + write(6,*) nray, ' rays generated by rg2d on PE# ',idproc +c + return + end +c +******************************************************************************** +c + subroutine rg4d(nray,iseed,sigmax,sx,sy,st) +c +c subroutine to generate a 4D gaussian distribution +c written by Alex Dragt 7/10/91 +c + use rays + include 'impli.inc' + include 'files.inc' +c +c working arrays + dimension z(4) +c +c proceedure +c +c initialize indices and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + call myexit + endif +cryne nrays=nray +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c +c fill zblock +c +c select and warmup random number generator +c + if (iseed .lt. 0) ktype=1 + if (iseed .eq. 0) then + write(jof,*) ' iseed = 0 in bgen call' + call myexit + return + endif + if (iseed .gt. 0) ktype=2 + iseed=-iabs(iseed) + call myrand(ktype,iseed,ans) +c + sigm2=sigmax**2 + do 20 j=1,nray +c generate a ray + 25 call normdv(z,2,ktype,iseed) + ssq = z(1)**2 + z(2)**2 + z(3)**2 + z(4)**2 + if(ssq .gt. sigm2) go to 25 +c scale and store ray in zblock + zblock(1,j)=sx*z(1) + zblock(2,j)=sx*z(2) + zblock(3,j)=sy*z(3) + zblock(4,j)=sy*z(4) + zblock(5,j)=0.d0 + zblock(6,j)=0.d0 + 20 continue + write(6,*) nray, ' rays generated by rg4d on PE# ',idproc +c + return + end +c +******************************************************************************** +c + subroutine rg6d(nray,iseed,sigmax,sx,sy,st) +c +c subroutine to generate a 6D gaussian distribution +c written by Alex Dragt 7/10/91 +c + use rays + include 'impli.inc' + include 'files.inc' + integer, parameter :: ichunk=10000 +c +c working arrays + dimension z(6),za(6*ichunk) +c +c proceedure +c +c write(6,*)'inside rg6d w/ sigmax,sx,sy,st=' +c write(6,*)sigmax,sx,sy,st +c initialize indices and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + write(6,*) 'nray=',nray + write(6,*) 'maxrayp=',maxrayp + call myexit + endif +cryne nrays=nray +c +c initialize arrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c +c fill zblock +c +c select and warmup random number generator +c + if (iseed .lt. 0) ktype=1 + if (iseed .eq. 0) then + write(jof,*) ' iseed = 0 in bgen call' + call myexit + return + endif + if (iseed .gt. 0) ktype=2 + iseed=-iabs(iseed) + call myrand(ktype,iseed,ans) +c + sigm2=sigmax**2 +c +c procedure to generate a small number (~few thousand) of rays: +cryne 1/11/2005 if(nray.gt.5000)goto 23 + if(nray.gt.500000)goto 23 + do 20 j=1,nray +c generate a ray + 21 call normdv(z,3,ktype,iseed) + ssq=z(1)**2+z(2)**2+z(3)**2+z(4)**2+z(5)**2+z(6)**2 + if(ssq .gt. sigm2) go to 21 +c scale and store ray in zblock + zblock(1,j)=sx*z(1) + zblock(2,j)=sx*z(2) + zblock(3,j)=sy*z(3) + zblock(4,j)=sy*z(4) + zblock(5,j)=st*z(5) + zblock(6,j)=st*z(6) + 20 continue + goto 999 +c + 23 continue +c procedure to generate a large number of rays: + j=0 + 24 continue + call normdv(za,3*ichunk,ktype,iseed) + do i=1,6*ichunk-5,6 + ssq= & + & za(i)**2+za(i+1)**2+za(i+2)**2+za(i+3)**2+za(i+4)**2+za(i+5)**2 + if(ssq .gt. sigm2)cycle + j=j+1 + if(j.gt.nray)exit +c scale and store ray in zblock + zblock(1,j)=sx*za(i) + zblock(2,j)=sx*za(i+1) + zblock(3,j)=sy*za(i+2) + zblock(4,j)=sy*za(i+3) + zblock(5,j)=st*za(i+4) + zblock(6,j)=st*za(i+5) + enddo + if(j.lt.nray)goto 24 +c + 999 continue + write(6,*) nray, ' rays generated by rg6d on PE# ',idproc + return + end +c +****************************************************************************** +c + subroutine rt2d(nray,iseed,sx,sy,st) +c subroutine to generate a 2D random uniform distribution on a 2-torus +c written by Alex Dragt 7/15/91 +c + use rays + include 'impli.inc' + include 'files.inc' +c +c working arrays + dimension z(2) +c +c proceedure +c +c initialize constants, indices, and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + call myexit + endif +cryne nrays=nray + twopi = 8.d0*atan(1.d0) +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c +c fill zblock +c +c select and warmup random number generator +c + if (iseed .lt. 0) ktype=1 + if (iseed .eq. 0) then + write(jof,*) ' iseed = 0 in bgen call' + call myexit + return + endif + if (iseed .gt. 0) ktype=2 + iseed=-iabs(iseed) + call myrand(ktype,iseed,ans) +c + do 20 j=1,nray +c generate a ray on the unit torus + call myrand(ktype,iseed,ans) + arg = twopi*ans + z(1) = cos(arg) + z(2) = sin(arg) +c scale and store ray in zblock + zblock(1,j)=sx*z(1) + zblock(2,j)=sx*z(2) + zblock(3,j)=0.d0 + zblock(4,j)=0.d0 + zblock(5,j)=0.d0 + zblock(6,j)=0.d0 + 20 continue + write(6,*) nray, ' rays generated by rt2d on PE# ',idproc +c + return + end +c +******************************************************************************** +c + subroutine rt4d(nray,iseed,sx,sy,st) +c subroutine to generate a 4D random uniform distribution on a 4-torus +c written by Alex Dragt 7/15/91 +c + use rays + include 'impli.inc' + include 'files.inc' +c +c working arrays + dimension z(4) +c +c proceedure +c +c initialize constants, indices, and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + call myexit + endif +cryne nrays=nray + twopi = 8.d0*atan(1.d0) +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c +c fill zblock +c +c select and warmup random number generator +c + if (iseed .lt. 0) ktype=1 + if (iseed .eq. 0) then + write(jof,*) ' iseed = 0 in bgen call' + call myexit + return + endif + if (iseed .gt. 0) ktype=2 + iseed=-iabs(iseed) + call myrand(ktype,iseed,ans) +c + do 20 j=1,nray +c generate a ray on the unit torus + call myrand(ktype,iseed,ans) + arg = twopi*ans + z(1) = cos(arg) + z(2) = sin(arg) + call myrand(ktype,iseed,ans) + arg = twopi*ans + z(3) = cos(arg) + z(4) = sin(arg) +c scale and store ray in zblock + zblock(1,j)=sx*z(1) + zblock(2,j)=sx*z(2) + zblock(3,j)=sy*z(3) + zblock(4,j)=sy*z(4) + zblock(5,j)=0.d0 + zblock(6,j)=0.d0 + 20 continue + write(6,*) nray, ' rays generated by rt4d on PE# ',idproc +c + return + end +c +******************************************************************************** +c + subroutine rt6d(nray,iseed,sx,sy,st) +c subroutine to generate a 6D random uniform distribution on a 6-torus +c written by Alex Dragt 7/15/91 +c + use rays + include 'impli.inc' + include 'files.inc' +c +c working arrays + dimension z(6) +c +c proceedure +c +c initialize constants, indices, and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + call myexit + endif +cryne nrays=nray + twopi = 8.d0*atan(1.d0) +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c +c fill zblock +c +c select and warmup random number generator +c + if (iseed .lt. 0) ktype=1 + if (iseed .eq. 0) then + write(jof,*) ' iseed = 0 in bgen call' + call myexit + return + endif + if (iseed .gt. 0) ktype=2 + iseed=-iabs(iseed) + call myrand(ktype,iseed,ans) +c + do 20 j=1,nray +c generate a ray on the unit torus + call myrand(ktype,iseed,ans) + arg = twopi*ans + z(1) = cos(arg) + z(2) = sin(arg) + call myrand(ktype,iseed,ans) + arg = twopi*ans + z(3) = cos(arg) + z(4) = sin(arg) + call myrand(ktype,iseed,ans) + arg = twopi*ans + z(5) = cos(arg) + z(6) = sin(arg) +c scale and store ray in zblock + zblock(1,j)=sx*z(1) + zblock(2,j)=sx*z(2) + zblock(3,j)=sy*z(3) + zblock(4,j)=sy*z(4) + zblock(5,j)=st*z(5) + zblock(6,j)=st*z(6) + 20 continue + write(6,*) nray, ' rays generated by rt6d on PE# ',idproc +c + return + end +c +******************************************************************************** +c + subroutine st2d(nray,sx,sy,st) +c subroutine to generate a 2D systematic uniform distribution on a 2-torus +c written by Alex Dragt 7/15/91 +c + use rays + include 'impli.inc' +c +c working arrays + dimension z(2) +c +c proceedure +c +c initialize constants, indices, and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + call myexit + endif + twopi = 8.d0*atan(1.d0) +c +c fill zblock +c +c compute number of points on circle + npts=nray +c + pidiv = twopi/float(npts) + ntot = 0 + do 20 i=1,npts +c generate ray on unit 2-torus + ai = float(i-1) + arg= ai*pidiv + z(1) = cos(arg) + z(2) = sin(arg) + ntot = ntot + 1 +c scale and store ray in zblock + zblock(1,ntot)=sx*z(1) + zblock(2,ntot)=sx*z(2) + zblock(3,ntot)=0.d0 + zblock(4,ntot)=0.d0 + zblock(5,ntot)=0.d0 + zblock(6,ntot)=0.d0 + 20 continue + nrays=ntot + write(6,*) ntot, ' rays generated by st2d on PE# ',idproc +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c + return + end +c +******************************************************************************** +c + subroutine st4d(nray,sx,sy,st) +c subroutine to generate a 4D systematic uniform distribution on a 4-torus +c written by Alex Dragt 7/15/91 +c + use rays + include 'impli.inc' +c +c working arrays + dimension z(4) + dimension c(100),s(100) +c +c proceedure +c +c initialize constants, indices, and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + if(maxrayp .gt. 10000) write(6,*) + & 'error: maxrayp exceeds 10000, subroutines st* need rewriting' + call myexit + endif + twopi = 8.d0*atan(1.d0) +c +c fill zblock +c +c compute number of points on each circle + pow=1.d0/2.d0 + aray=float(nray) + npts=int(aray**pow) + if (npts.gt.100) then + write(6,*) + & 'error: maxrayp exceeds 10000, subroutines st* need rewriting' + call myexit + endif +c +c compute needed sines and cosines +c + pidiv = twopi/float(npts) + do 10 i=1,npts + ai = float(i-1) + arg= ai*pidiv + c(i) = cos(arg) + s(i) = sin(arg) + 10 continue +c +c generate rays on unit 4-torus +c + ntot = 0 + do 20 i=1,npts + z(1) = c(i) + z(2) = s(i) + do 30 j=1,npts + z(3) = c(j) + z(4) = s(j) + ntot = ntot + 1 +c scale and store ray in zblock + zblock(1,ntot)=sx*z(1) + zblock(2,ntot)=sx*z(2) + zblock(3,ntot)=sy*z(3) + zblock(4,ntot)=sy*z(4) + zblock(5,ntot)=0.d0 + zblock(6,ntot)=0.d0 + 30 continue + 20 continue +c + nrays=ntot + write(6,*) ntot, ' rays generated by st4d on PE# ',idproc +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c + return + end +c +******************************************************************************** +c + subroutine st6d(nray,sx,sy,st) +c subroutine to generate a 6D systematic uniform distribution on a 6-torus +c written by Alex Dragt 7/15/91 +c + use rays + include 'impli.inc' +c +c working arrays + dimension z(6) + dimension c(21),s(21) +c +c proceedure +c +c initialize constants, indices, and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + if(maxrayp .gt. 10000) write(6,*) + & 'error: maxrayp exceeds 10000, subroutines st* need rewriting' + call myexit + endif + twopi = 8.d0*atan(1.d0) +c +c fill zblock +c +c compute number of points on each circle + pow=1.d0/3.d0 + aray=float(nray) + npts=int(aray**pow) + if (npts.gt.21) then + write(6,*) + & 'error: maxrayp exceeds 10000, subroutines st* need rewriting' + call myexit + endif +c +c compute needed sines and cosines +c + pidiv = twopi/float(npts) + do 10 i=1,npts + ai = float(i-1) + arg= ai*pidiv + c(i) = cos(arg) + s(i) = sin(arg) + 10 continue +c +c generate rays on unit 6-torus +c + ntot = 0 + do 20 i=1,npts + z(1) = c(i) + z(2) = s(i) + do 30 j=1,npts + z(3) = c(j) + z(4) = s(j) + do 40 k=1,npts + z(5) = c(k) + z(6) = s(k) + ntot = ntot + 1 +c scale and store ray in zblock + zblock(1,ntot)=sx*z(1) + zblock(2,ntot)=sx*z(2) + zblock(3,ntot)=sy*z(3) + zblock(4,ntot)=sy*z(4) + zblock(5,ntot)=st*z(5) + zblock(6,ntot)=st*z(6) + 40 continue + 30 continue + 20 continue +c + nrays=ntot + write(6,*) ntot, ' rays generated by st6d on PE# ',idproc +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c + return + end +c +*************************************************************************** +c + subroutine kv4d(nray,iseed,sx,sy,st) +c subroutine to compute a KV distribution in 4-D phase space +c +c written by Alex Dragt 7/15/91 +c + use rays + include 'impli.inc' + include 'files.inc' +c +c working arrays + dimension z(4) +c +c proceedure +c +c initialize indices and arrays + if(nray .gt. maxrayp) then + write(6,*) 'error: nray exceeds maxrayp' + call myexit + endif +cryne nrays=nray +c +c initialize arrrays and set up counters +c + do 115 k=1,nray + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 +c +c fill zblock +c +c select and warmup random number generator +c + if (iseed .lt. 0) ktype=1 + if (iseed .eq. 0) then + write(jof,*) ' iseed = 0 in bgen call' + call myexit + return + endif + if (iseed .gt. 0) ktype=2 + iseed=-iabs(iseed) + call myrand(ktype,iseed,ans) +c + do 20 j=1,nray +c generate a ray + 5 sumsq=0.d0 + do 10 i=1,4 + call myrand(ktype,iseed,ans) + z(i)=2.d0*ans-1.d0 + 10 sumsq=sumsq+z(i)*z(i) + if(sumsq .gt. 1.d0) goto 5 + if(sumsq .eq. 0.d0) goto 5 +c scale and store ray in zblock + rad=sqrt(sumsq) + zblock(1,j)=sx*z(1)/rad + zblock(2,j)=sx*z(2)/rad + zblock(3,j)=sy*z(3)/rad + zblock(4,j)=sy*z(4)/rad + zblock(5,j)=0.d0 + zblock(6,j)=0.d0 + 20 continue + write(6,*) nray, ' rays generated by kv4d on PE# ',idproc +c + return + end +c +*********************************************************************** +c + subroutine myrand(ktype,iseed,ans) +c +c this subroutine generates random numbers using either myran1 +c or myran2 +c written by Alex Dragt, 7/28/91 +c modified 7/3/98 AJD +c + double precision ans +c +c write(6,*) iseed +c + if(ktype .eq. 1) call myran1(iseed,ans) + if(ktype .eq. 2) call myran2(iseed,ans) +c + return + end +c +*********************************************************************** +c + subroutine myran1(idum,ans) +c +c This subroutine is a minor modification of the FUNCTION ran1(idum) +c given in the article by Press and Teukolosky in Computers in Physics, +c vol. 6, p. 522 (1992). See also W. Press, S. Teukolsky, W. Vettering, +c and B. Flannery, Numerical Recipes in Fortran, Second edition, page 271, +c Cambridge University Press (1992). +c It requires seeds IDUM that are .lt. 0 to be reset. +c Written by Alex Dragt 7/3/98. +c + INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV + REAL sans,arg1,AM,EPS,RNMX + double precision ans + PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, + &NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS) + INTEGER j,k,iv(NTAB),iy + SAVE iv,iy + DATA iv /NTAB*0/, iy /0/ +c +c warmup generator + if (idum.le.0.or.iy.eq.0) then + idum=max(-idum,1) + do 11 j=NTAB+8,1,-1 + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + if (j.le.NTAB) iv(j)=idum +11 continue + iy=iv(1) + endif +c + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + j=1+iy/NDIV + iy=iv(j) + iv(j)=idum + arg1=AM*iy + sans=amin1(arg1,RNMX) + ans=dble(sans) +c + return + END +c +************************************************************************* +c + subroutine myran2(idum,ans) +c +c This subroutine is a minor modification of the FUNCTION ran2(idum) +c given in the article by Press and Teukolosky in Computers in Physics, +c vol. 6, p. 522 (1992). See also W. Press, S. Teukolsky, W. Vettering, +c and B. Flannery, Numerical Recipes in Fortran, Second edition, page 272, +c Cambridge University Press (1992). +c It requires seeds IDUM that are .lt. 0 to be reset. +c Written by Alex Dragt 7/3/98. +c + INTEGER idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV + REAL sans,arg1,AM,EPS,RNMX + double precision ans + PARAMETER (IM1=2147483563,IM2=2147483399,AM=1./IM1,IMM1=IM1-1, + &IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791, + &NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-7,RNMX=1.-EPS) + INTEGER idum2,j,k,iv(NTAB),iy + SAVE iv,iy,idum2 + DATA idum2/123456789/, iv/NTAB*0/, iy/0/ +c +c warmup generator + if (idum.le.0) then + idum=max(-idum,1) + idum2=idum + do 11 j=NTAB+8,1,-1 + k=idum/IQ1 + idum=IA1*(idum-k*IQ1)-k*IR1 + if (idum.lt.0) idum=idum+IM1 + if (j.le.NTAB) iv(j)=idum +11 continue + iy=iv(1) + endif +c + k=idum/IQ1 + idum=IA1*(idum-k*IQ1)-k*IR1 + if (idum.lt.0) idum=idum+IM1 + k=idum2/IQ2 + idum2=IA2*(idum2-k*IQ2)-k*IR2 + if (idum2.lt.0) idum2=idum2+IM2 + j=1+iy/NDIV + iy=iv(j)-idum2 + iv(j)=idum + if(iy.lt.1)iy=iy+IMM1 + arg1=AM*iy + sans=amin1(arg1,RNMX) + ans=dble(sans) +c + return + END +c +******************************************************************************** +c + subroutine normdv(x,n,ktype,iseed) +c routine to generate 2n independent normal deviates +c Polar method for normal deviates +c written by Alex Dragt ca 1986, revised by Alex Dragt 7/15/91 +c modified by Rob Ryne July 28, 2002 to avoid a large number +c of calls to myrand +c +c References: +c 1)Knuth, The Art of Computer Programming (Vol. 2, page 117) +c 2)Irving Haber, NRL Memo Report #3705 +c + include 'impli.inc' + integer, parameter :: ichunk=10000 +c +c calling arrays + dimension x(*) + real*8, dimension(n) :: u1a,u2a +c +cryne 1/11/2005 if(n.gt.5000)goto 150 + if(n.gt.500000)goto 150 +c procedure to generate a small number (~few thousand) of random numbers: + do 100 k=1,n + 50 call myrand(ktype,iseed,ans) + u1=ans + call myrand(ktype,iseed,ans) + u2=ans + v1=2.d0*u1-1.d0 + v2=2.d0*u2-1.d0 + s=v1**2 + v2**2 + if(s .ge. 1.d0)goto 50 + arg=sqrt(-2.d0*log(s)/s) + ans1=v1*arg + ans2=v2*arg + x(k)=ans1 + x(k+n)=ans2 + 100 continue + return +c procedure to generate a large number of random numbers: + 150 continue +c write(6,*)'using packed version of normdv' + j=0 + 200 continue + call random_number(u1a) + call random_number(u2a) + do i=1,ichunk + v1=2.d0*u1a(i)-1.d0 + v2=2.d0*u2a(i)-1.d0 + s=v1**2 + v2**2 + if(s .gt. 1.d0)cycle + j=j+1 + if(j.gt.n)exit +c store results: + arg=sqrt(-2.d0*log(s)/s) + ans1=v1*arg + ans2=v2*arg + x(j)=ans1 + x(j+n)=ans2 + enddo + if(j.lt.n)goto 200 +c + return + end +c +*********************************************************************** +c + subroutine tic(p) +c +c Translation of initial conditions. +c This subroutine produces a translation in 6-dimensional phase space. +c The parameters p(j) are used to specify translations deltaz(j) +c according to the relations deltaz(j)=p(j). +c The suffixes 'i' and 'f' refer to 'initial' and 'final' respectively. +c Written by Alex Dragt, Fall 1986 +c + use rays + include 'impli.inc' + dimension p(6) +c + do 100 i=1,nraysp +c check to see if i'th ray has been lost + if (istat(i).ne.0) goto 100 +c if not, copy the i'th ray out of zblock + do 110 j=1,6 + 110 zi(j)=zblock(j,i) +c +c transform this ray +c + do 10 j=1,6 + 10 zf(j)=zi(j)+p(j) +c +c put the transformed ray back into zblock + do 120 j=1,6 + 120 zblock(j,i)=zf(j) +c + 100 continue + return + end +c +*********************************************************************** +c routine to setup/warmup the F90 random number generator + subroutine f90ranset(iseed) + implicit double precision(a-h,o-z) + call random_seed(size=iseedsize) +c write(6,*)'random number seed size equals ',iseedsize + call f90ranwarm(iseedsize,iseed) +c write(6,*)'here are a few numbers from random_number:' +c do n=1,50 +c call random_number(x) +c write(6,*)x +c enddo + return + end + + subroutine f90ranwarm(iseedsize,iseed) + implicit double precision(a-h,o-z) + dimension iputarray(iseedsize) + if(iseedsize.eq.1)return + iputarray(1)=iseed +c multiply the seed by a random number +c note: the generator has not been initialized, so this is +c a bit flaky + do n=2,iseedsize + call random_number(x) + iputarray(n)=iseed*x + enddo +c set the seed: + call random_seed(put=iputarray) + return + end + +c +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/dummy.f b/OpticsJan2020/MLI_light_optics/Src/dummy.f new file mode 100755 index 0000000..4c6c864 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/dummy.f @@ -0,0 +1,87 @@ +******************************************************************************* +* DUMMY * +* These are dummy routines to please AFRO and OPTI * +******************************************************************************* +c +***************************************************************************** +c Routines fo please AFRO +***************************************************************************** +c + subroutine bell + write(6,*)' BEEP' + return + end +c +**************************************************************************** +c + subroutine wmrt(p) + dimension p(*) + write(6,*)' in wmrt' + return + end +c +*********************************************************************** +c + subroutine subctr(p) + dimension p(*) + write(6,*)' in subctr' + return + end +c +***************************************************************************** +c + subroutine fwa(p) + write(6,*) 'in dummy routine fwa' + return + end +c +***************************************************************************** +c + subroutine dism(p,h,mh) + write(6,*) 'in dummy routine dism' + return + end +c +***************************************************************************** +c + subroutine rmap(p,h,mh) + write(6,*) 'in dummy routine rmap' + return + end +c +***************************************************************************** +c + subroutine flag(p) + write(6,*) 'in dummy routine flag' + return + end +c +************************************************************************ +c Routines to please OPTI +************************************************************************** +c +cryne 8/17/02 subroutine dcopy(nx,fu,maxf,y,i) +cryne 8/17/02 write(6,*) 'in dummy routine dcopy' +cryne 8/17/02 return +cryne 8/17/02 end +c +*************************************************************************** +c + subroutine dposl( fjac,maxf,nx,step) + write(6,*) 'in dummy routine dposl' + return + end +c +*************************************************************************** +c + subroutine dqrdc(fjac,maxf,nf,nx,qraux,jdum,dum,i) + write(6,*) 'in dummy routine dqrdc' + return + end +c +*************************************************************************** +c + subroutine dqrsl(fj,ma,nf,nx,qr,fc,du,r,sp,rs,d,i,in) + write(6,*) 'in dummy routine dqrsl' + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/dumpin.f b/OpticsJan2020/MLI_light_optics/Src/dumpin.f new file mode 100644 index 0000000..78d2504 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/dumpin.f @@ -0,0 +1,4190 @@ + subroutine dumpin +c----------------------------------------------------------------------- +c This routine organizes the data input from file lf, the master input +c file. +c This file is divided into "components" beginning with a code "#..." +c The available codes are given in common/sharp/. +c In dumpin, they are numbered as they occur in that common. The +c component (segment) currently being read has number "msegm". +c The entries of the component "#menu" will be called "elements". +c The term "item" is used for entries of the components "#lines", +c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". +c +c Output is transferred via several commons. They are explained below. +c +c Written by Rob Ryne ca 1984 +c rewritten by Petra Schuett +c October 21, 1987 +c----------------------------------------------------------------------- + use parallel, only : idproc + use beamdata + use acceldata + use lieaparam, only : monoms + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- +c + include 'incmif.inc' + include 'codes.inc' + include 'files.inc' +c +cryne 5/4/2006 added this to allowing printing of messages from #labor: + integer, parameter :: lmaxmsg=1000 + character*256 lattmsg(lmaxmsg) + common/lattmsgb/lattmsg,lmsgpoi +c +cryne 5/4/2006 Added MADX capability. Initialized to MAD8 below. +c MADX is enabled by putting ";" on the #comment line after #comment + logical MAD8,MADX + common/mad8orx/MAD8,MADX +c + common/mlunits/sclfreq,magunits + common/showme/iverbose + common/symbdef/isymbdef + dimension bufr(4) +c----------------------------------------------------------------------- +c local variables: + character*16 strarr(40),string +c character*80 line + character*256 line + character*16 fname + integer narr(40) + character*60 symb(40) + integer istrtsym(40) + logical leof,lcont,npound +c----------------------------------------------------------------------- + lmsgpoi=0 + MAD8=.true. + MADX=.false. +c Here are some things that need to be initialized before the data are read in: + isymbdef=-1 +c default units are "static" (="magnetic") with scale length=1 and omega*l/c=1 + sl=1.d0 + clite=299792458.d0 + ts=sl/clite + omegascl=1.d0/ts + freqscl=omegascl/( 4.d0*asin(1.d0) ) + p0sc=0.d0 + magunits=1 + iverbose=0 +c + slicetype='none' +cryne if(idproc.eq.0)write(6,*)'AUG8, set default slicetype to none' + +c +cryne 7/20/2002 initialize character array so that, even if input is +c in the original MaryLie format, the mppc array will be filled with ' ' +c so that files are opened properly. (code checks for name=' ') +cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' +cryne 7/7/2002 +cryne initialize #const +cryne this should go somewhere else (near start of afro.f), but I am +cryne trying not to change MaryLie too much. + call initcons +cryne 7/7/2002 additional mods to deal w/ huge number of comments +cryne eventually it would be a good idea to let the user specify whether +cryne or not comments should be printed in the pmif command +cryne +c start + ignorcom=0 +cryne----- 15 Sept 2000 modified to check for input file: +ctm open(lf,file='fort.11',status='old',err=357) + read(lf,2000,end=2001,err=2001) line + 2000 format(a) + if(idproc.eq.0) & + &write(6,*)'reading from file associated with unit 11' + goto 4320 + 2001 continue + open(lf,file='mli.in',status='old',err=357) + read(lf,2000,end=357,err=357) line + if(idproc.eq.0) & + &write(6,*)'reading from file mli.in' + goto 4320 + 357 continue + write(6,*)'master input file does not exist or is empty' + write(6,*)'type filename or to halt' + read(5,2002)fname + 2002 format(a16) + if(fname.eq.' ')call myexit + open(lf,file=fname,status='old',err=3000) + read(lf,2000,end=3000,err=3000) line + goto 4320 + 3000 continue + write(6,*)'file still does not exist or is empty. Halting.' + call myexit +c----------------------------------------------------------------------- + 4320 continue + leof = .false. + rewind lf + msegm = -1 + curr0=-99999. +c-------------------- +c read first line of master input file (should set msegm) +c + 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm write(6,*) itot,' = itot after first REAREC' + if (leof) goto 1000 +c-------------------- +c new component (segment) begins, branch to appropriate part of code +c + 1 goto(100,200,300,400,500,600,700,800,900),msegm +c +c error exit: + write(jof ,99) + write(jodf,99) + 99 format(1x,'problems at 1st goto of routine dumpin; line=') + write(jof,*)TRIM(line) + write(jodf,*)TRIM(line) + call myexit +c-------------------- +c #comment +c + 100 continue +! write(6,*)'here I am at #comment' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 1) goto 1 + if(ignorcom.eq.1)goto 100 +c + npcom=npcom+1 + if(npcom.gt.maxcmt) then + write(jof ,199) maxcmt + write(jodf,199) maxcmt + 199 format(1x,'warning (dumpin): ', & + & 'entries in #comment beyond line ',i6,' will be ignored') + ignorcom=1 + npcom=maxcmt + goto 100 + endif + mline(npcom)=line + goto 100 +c-------------------- +c #beam +c + 200 continue +! write(6,*)'here I am at #beam' + read(lf,*,err=290,end=1000)brho,gamm1,achg,sl +c computation of relativistic beta and gamma factors: + gamma=gamm1+1.d0 + stuff2=gamm1*(gamma+1.d0) + stuff1=sqrt(stuff2) + beta=stuff1/gamma + ts=sl/c +cryne--- 1 August, 2004: + omegascl=1.d0/ts + freqscl=omegascl/( 4.d0*asin(1.d0) ) + pmass=brho/(gamma*beta/clite) + p0sc=gamma*beta*pmass/clite + lflagmagu=.true. + lflagdynu=.false. +cryne--- +cryne 08/14/2001 the beam component may contain other info: +c first set defaults + magunits=1 + iverbose=0 + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +!? if(msegm.ne.2)goto 1 + if (npound) goto 1 + if(msegm.eq.3)goto 301 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if(msegm.ne.2) goto 1 +!? +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c need to delete the following code, which is no longer useful or works. + if(msegm.ne.12345)then + write(6,*)'reached bad section of code in DUMPIN. Stopping.' + stop + endif +cryne there is other info in the #beam component: +c call txtnum(line,80,4,nget,bufr) + call txtnum(line,LEN(line),4,nget,bufr) + if(nget.ne.4)then + write(6,*)'(dumpin)error: could not read 4 more #beam numbers' + stop + endif +c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) +cryne current: + curr0=bufr(1) + if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 +cryne units: + if(nint(bufr(3)).ne.0)then + magunits=0 + sclfreq=4.*asin(1.d0)*bufr(3) + write(6,*)'input frequency=',bufr(3),' Hz' + write(6,*)'scale frequency=',sclfreq,' rad/sec' + write(6,*)'dynamic units (not magnetostatic units) will be used' + slnew=c/sclfreq + write(6,*)'scale length specified in the input file is',sl,'m' + write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' + if(abs(sl-slnew)/sl .gt. 1.e-3)then + write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' + write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' + write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' + write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' + endif + sl=slnew + endif +cryne verbose to show progress: + iverbose=bufr(4) +cryne autoslicing (thick elements need an extra parameter): + iautosl=nint(bufr(2)) + if(iautosl.ne.0)then + write(6,*)'autoslicing of thick elements will be enabled.' + endif + if(iautosl.gt.0)then + write(6,*)'fixed # of slices/element will be = ',iautosl + endif + if(iautosl.lt.0)then + write(6,*)'variable # of slices/element will be used' + if(na.ne.0)then + write(6,*)'error: input file specifies variable # of' + write(6,*)'slices/element, but some elements have already' + write(6,*)'been read in. stopping.' + stop + endif + nrp(1,1)=nrp(1,1)+1 + nrp(1,2)=nrp(1,2)+1 + nrp(1,3)=nrp(1,3)+1 + nrp(1,4)=nrp(1,4)+1 + nrp(1,6)=nrp(1,6)+1 + nrp(1,8)=nrp(1,8)+1 + nrp(1,9)=nrp(1,9)+1 + nrp(1,10)=nrp(1,10)+1 + nrp(1,11)=nrp(1,11)+1 + nrp(1,12)=nrp(1,12)+1 + nrp(1,18)=nrp(1,18)+1 + nrp(1,20)=nrp(1,20)+1 + nrp(1,24)=nrp(1,24)+1 + nrp(1,30)=nrp(1,30)+1 + endif + goto 10 +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c error exit: + 290 continue + write(jof ,299) + write(jodf,299) + 299 format(1h ,'data input error detected by dumpin near #beam'/ & + &'Note: if using MAD-style input for beam info, it should be'/ & + &'preceded by #menu, not #beam') + call myexit +c-------------------- +c #menu +c + 300 continue +! write(6,*)'here I am at #menu' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if(iverbose.eq.2)write(6,*)'#menu;',line(1:70) + if(iverbose.eq.2)write(6,*)'#menu;',itot,strarr(1),strarr(2),msegm + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if (msegm .ne. 3) goto 1 + 301 continue + if(iverbose.eq.2)write(6,*)'got past 301' +c +c 11/4/02 new code to deal with 'call' statements: + if(trim(strarr(1)).eq.'call')then + write(6,*)'found a call statement in dumpin' +c call getsymb60(line,80,symb,istrtsym,nsymb) + call getsymb60(line,LEN(line),symb,istrtsym,nsymb) + write(6,*)'symb(1), symb(2), symb(3)=' + write(6,*)symb(1) + write(6,*)symb(2) + write(6,*)symb(3) + lftemp2=lf + lf=42 + write(6,*)'potential bug in dumpin! Need to replace hardwired' + write(6,*)'file unit # (42) with code-selected #. fix later' + call dumpin2(symb(3)) + close(lf) + lf=lftemp2 + write(6,*)'returned from dumpin2' + goto 300 + endif + na=na+1 + if(na.gt.mnumax) then + write(jof ,399) mnumax + write(jodf,399) mnumax + 399 format(1h ,'error in dumpin:', & + & ' too many items (>= mnumax = ',i6,') elements in #menu') + call myexit + endif +c check for doubly defined names + if(iverbose.eq.2)write(6,*)'checking for doubly defined names' + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,396) strarr(1) + write(jodf,396) strarr(1) + 396 format(' error detected by dumpin in #menu: name ', & + & a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! goto 300 + & ' the first definition will be ignored') + lmnlbl(indx)(1:1)='*' + endif +cryne + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then +c check if element/command name is present ( F. Neri 4/14/89 ): + if ( itot .lt. 2 ) then + write(jof ,1396) strarr(1) + write(jodf ,1396) strarr(1) + 1396 format(' error in #menu: ',a16,' has no type code!') + call myexit + endif + endif +cryne July 4 2002 if ( itot .gt. 2 ) then +cryne July 4 2002 write(jof ,1397) strarr(1) +cryne July 4 2002 write(jodf ,1397) strarr(1) +c1397 format(' error in #menu: ',a16,' has more than one type code!') +cryne July 4 2002 call myexit +cryne July 4 2002 endif +c new item in menu: + lmnlbl(na)=strarr(1) + initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse +c string is name of element/command type, look up element indices +cryne string=strarr(2) + if((trim(strarr(1)).eq.'beam').or. & + &(trim(strarr(1)).eq.'units'))then + string=strarr(1) + else + string=strarr(2) + endif + if(iverbose.eq.2)write(6,*)'starting do 325' + do 325 m = 1,9 + do 325 n = 1,nrpmax +cryne Dec 1, 2002 if(string(1:8).eq.ltc(m,n)) then +c eventually the max string length should not be hardwired like this + if(string(1:16).eq.ltc(m,n)) then + nt1(na) = m + nt2(na) = n + if(iverbose.eq.2)then + write(6,*)'(3344) ',na,nt1(na),nt2(na),string(1:16) + endif + goto 3344 + endif + 325 continue +c============= +cryne Sept 17, 2003 +c before declaring this an unknown element/command name, +c check to see if it is the name of an existing menu item +c since this is a functionality that MAD allows + call lookup(strarr(2),itype,indx) + if(itype.ne.1)goto 3226 +c this *is* the name of an existing menu item. + if(idproc.eq.0)then + write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) + endif + m = nt1(indx) + n = nt2(indx) + nt1(na) = m + nt2(na) = n + imax=nrp(m,n) + if(imax.ne.0)then + do i=1,imax + pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) + enddo + endif + icmax=ncp(m,n) + if(icmax.ne.0)then + do i=1,icmax + cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) + enddo + endif + initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f + goto 3344 + 3226 continue +c============= +c error: unknown element/command name + if(idproc.eq.0)then + write(jof ,398)(strarr(j),j=1,2) + write(jodf,398)(strarr(j),j=1,2) + 398 format(1h ,'dumpin error at ',a16,': type code ',a16, & + &' not found.'/ & + & 1h ,'this item will be ignored') + endif + na=na-1 + goto 300 + 3344 continue +c write(6,*)'menu element;string,m,n=',string(1:16),m,n +c read parameters. Number of parameters is given in nrp + imax=nrp(m,n) + icmax=ncp(m,n) + imaxold=nrpold(m,n) +c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax +cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 + if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. + & index(line,':').eq.0)goto 300 +cryne July 4, 2002 +c if using the Standard Input Format, the remaining parameters +c are stored in "line"; otherwise use the MaryLie input format: +c +c mpp(na) points to where the real parameters will be stored +c mppc(na) points to where the char*16 parameters will be stored + mpp(na) = mpprpoi + mppc(na) = mppcpoi +cryne 7/9/2002 if(itot.eq.2)then +c original MaryLie input format (icmax not relevant here): + if( (itot.eq.2) .and. (index(line,':').eq.0) )then +c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string +cryne 12/31/2005 imaxold is now incremented for thick elements if autoslicing. +cryne But note that mpprpoi is incremented by imax, not imaxold. +cryne This allows use of MaryLie names, but to have additional +cryne parameters if read in using the SIF (MAD) format. + if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) +c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) +c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax + goto 300 +c error in parameter input + 390 write(jof ,397)lmnlbl(na) + write(jodf,397)lmnlbl(na) + 397 format(1h ,'(dumpin) parameter input error at element ',a16) + call myexit + endif +cryne July 4, 2002 +c if the code gets here, the Standard Input Format is being used +c to specify the elements in the menu: +c first delete the element name and type from the character string: +cryne this could be more easily done with the f90 intrinsic len_trim() +c kkk1=len_trim(strarr(1))-1 + string=strarr(1) + kkk1=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk1=kkk1-1 + enddo + do i=1,80 + if(line(i:i+kkk1).eq.strarr(1))then + line(i:i+kkk1)=' ' + exit + endif + enddo +cryne kkk2=len_trim(strarr(2))-1 + string=strarr(2) + kkk2=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk2=kkk2-1 + enddo +c + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then + do i=1,80 + if(line(i:i+kkk2).eq.strarr(2))then + line(i:i+kkk2)=' ' + exit + endif + enddo + endif +c get rid of other unneccesary characters: + do i=1,80 +c if(line(i:i).eq.',')line(i:i)=' ' + if(line(i:i).eq.':')line(i:i)=' ' + enddo + call stdinf(line,na,m,n,initparms,strarr(1)) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax +c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax +c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi + goto 300 +c +c-------------------- +c #lines,#lumps,#loops +c + 400 continue +! write(6,*)'here I am at #lines,lumps,loops' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 4) goto 1 + goto 410 + 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 5) goto 1 + goto 410 + 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 6) goto 1 +c + 410 nb=nb+1 + if(nb.gt.itmno)then + write(jof ,499) itmno + write(jodf,499) itmno + 499 format(1h ,'error in dumpin:', & + & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,497) ling(msegm),strarr(1) + write(jodf,497) ling(msegm),strarr(1) + 497 format(1x,'dumpin error in ', & + & a8,': name ',a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! if(msegm .eq.4) then +! goto 400 +! else if(msegm.eq.5) then +! goto 500 +! else if(msegm.eq.6) then +! goto 600 +! endif + & ' the first definition will be ignored') + ilbl(indx)(1:1)='*' + endif +c new item + ilbl(nb)=strarr(1) + imin=0 +cryne July 2002 Standard Input Format option: components might be on +cryne this record; check now +cryne Note: this assume that the 2nd string after the name is 'line', +cryne and so the 2nd string is ignored + if( (itot.eq.2) .and. (.not.(lcont)) )then + write(6,*)'error parsing line:' + write(6,*)'this should be a name alone, or' + write(6,*)'a name followed by LINE= followed by the components' + write(6,*)'input line =' + write(6,*)line + stop + endif + if(itot.gt.2)then +c write(6,*)'ITOT=',itot +c do i=1,itot +c write(6,*)i,narr(i),strarr(i) +c enddo + do 424 i=3,itot + icon(imin+i-2,nb)=strarr(i) + irep(imin+i-2,nb)=narr(i) + 424 continue + imin=imin+itot-2 + if(lcont)then + goto 420 + else + goto 426 + endif + endif +cryne remaining code is from original version: +c read components of item +c repeat... + 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if(imin+itot.gt.itmln)then + write(jof ,498) itmln,ilbl(nb) + write(jodf,498) itmln,ilbl(nb) + 498 format(1h ,'error in dumpin:', & + & ' too many entries (> itmln = ',i6,') in ',a16) + call myexit + endif +c store names and rep rates of components + do 425 i=1,itot + icon(imin+i,nb)=strarr(i) + irep(imin+i,nb)=narr(i) + 425 continue + imin=imin+itot + if(lcont) goto 420 +c ... until no more continuation lines +c-- +c now set length and type of element + 426 continue + ilen(nb)=imin + ityp(nb)=msegm-2 +c go back to appropriate component (segment) + if(msegm .eq.4) then + goto 400 + else if(msegm.eq.5) then + goto 500 + else if(msegm.eq.6) then + goto 600 + endif +c-------------------- +c #labor +c + 700 continue +! write(6,*)'here I am at #labor' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 7) goto 1 +c + noble=noble+1 + if(noble.gt.mlabor) then + write(jof ,799) mlabor + write(jodf,799) mlabor + 799 format(1h ,'error in dumpin:', & + & ' too many entries (>= mlabor = ',i6,') in #labor array') + call myexit + endif +c new task +cryne 5/4/2006 + if(line(1:1).eq.'>')then + lmsgpoi=lmsgpoi+1 + if(lmsgpoi.gt.lmaxmsg)then + if(idproc.eq.0) & + & write(6,*)'error: too many output messages (>) ini #labor' + call myexit + endif +c latt(noble)='>' + latt(noble)=line(1:3) + num(noble)=lmsgpoi + lattmsg(lmsgpoi)=line + goto 700 + endif +c + latt(noble)=strarr(1) + num(noble)=narr(1) + goto 700 +c-------------------- +c #call (formerly #include) + 800 continue + write(6,*)' Start #call after user name: ',strarr(1) +c +ctm 9/01 modified to open and save up to 32 long #include file names +c + ninc = 0 + 810 read(lf,2000,end=1000) line +c +c check for next segment +c + if(index(line,'#').ne.0) then + itot = -1 + na2 = na + nb2 = nb + noble2 = noble + write(6,813) na2,nb2,noble2 + 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') + write(6,817) line + 817 format(' End #include with: ',a) + go to 10 + endif +c +ctm save file name and pointers before opening 1st include file +c + ninc = ninc + 1 + if(ninc.eq.1) then + na1 = na + nb1 = nb + noble1 = noble + write(6,877) na1,nb1,noble1 + 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') + endif +c +ctm skip leading blanks +c + lc = 1 + 880 if(line(lc:lc).eq.' ') then + lc = lc + 1 + go to 880 + endif + incfil(ninc) = line(lc:) + write(6,888) ninc,incfil(ninc) + 888 format(' include',i3,' : ',a) + call mlfinc(incfil(ninc)) + go to 810 +ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm if (leof) goto 1000 +ctm goto 1 +c-------------------- +c #const + 900 continue +! write(6,*)'here I am at #const' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if((msegm.eq.9).and.(itot.ne.1))then + write(6,*)'input error (#const)' + write(6,*)'trying to read a definition, but did not find a' + write(6,*)'character string at the beginning of this record:' + write(6,*)line(1:80) + stop + endif + if(msegm.eq.3)goto 301 + if(msegm.eq.4)goto 410 + if (msegm .ne. 9) goto 1 + 901 continue + call getconst(line,strval,nreturn) + if(nreturn.ne.1)then + write(6,*)'trouble parsing the following line:' + write(6,*)line + write(6,*)'continuing...' + goto 900 + endif + nconst=nconst+1 + if(nconst.gt.nconmax)then + write(6,*)'too many constants defined in the input file' + stop + endif + constr(nconst)=strarr(1) + conval(nconst)=strval +c write(6,*)'nconst,constr(nconst),conval(nconst)=' +c write(6,*)nconst,constr(nconst),conval(nconst) + goto 900 +c normal return at end of file + 1000 continue + return + end +c +************************************************************************ + subroutine dumpin2(uname) +c----------------------------------------------------------------------- +c This routine organizes the data input from file lf, the master input +c file. +c This file is divided into "components" beginning with a code "#..." +c The available codes are given in common/sharp/. +c In dumpin, they are numbered as they occur in that common. The +c component (segment) currently being read has number "msegm". +c The entries of the component "#menu" will be called "elements". +c The term "item" is used for entries of the components "#lines", +c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". +c +c Output is transferred via several commons. They are explained below. +c +c Written by Rob Ryne ca 1984 +c rewritten by Petra Schuett +c October 21, 1987 +c----------------------------------------------------------------------- + use beamdata + use acceldata + use lieaparam, only : monoms + use parallel, only : idproc + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- +c + include 'incmif.inc' + include 'codes.inc' + include 'files.inc' + common/mlunits/sclfreq,magunits + common/showme/iverbose + common/symbdef/isymbdef + dimension bufr(4) +c----------------------------------------------------------------------- +c local variables: + character*60 uname + character*16 strarr(40),string + character*80 line + character*16 fname + integer narr(40) + character*60 symb(40) + integer istrtsym(40) + logical leof,lcont,npound +cryne 8/15/2001 new code to read in a character string instead of numbers: +c----------------------------------------------------------------------- +cryne 9/26/02 +c this could go somewhere else too, but here is OK: +c isymbdef=-1 +c +cryne 7/20/2002 initialize character array so that, even if input is +c in the original MaryLie format, the mppc array will be filled with ' ' +c so that files are opened properly. (code checks for name=' ') +cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' +cryne 7/7/2002 +cryne initialize #const +cryne this should go somewhere else (near start of afro.f), but I am +cryne trying not to change MaryLie too much. +c call initcons +cryne 7/7/2002 additional mods to deal w/ huge number of comments +cryne eventually it would be a good idea to let the user specify whether +cryne or not comments should be printed in the pmif command +cryne +c start +c ignorcom=0 +cryne----- 15 Sept 2000 modified to check for input file: +ctm open(lf,file='fort.11',status='old',err=357) +c read(lf,2000,end=2001,err=2001) line + 2000 format(a) +c goto 4320 +c2001 continue +c write(6,*)'master input file does not exist or is empty' +c write(6,*)'type filename or to halt' +c read(5,2002)fname +c2002 format(a16) +c if(fname.eq.' ')call myexit + open(lf,file=uname,status='old',err=3000) + write(6,*)'successfully opened file ',uname + goto 4320 + 3000 continue + write(6,*)'(dumpin2) file does not exist. File name=.' + write(6,*)uname + write(6,*)'Halting.' + call myexit +c----------------------------------------------------------------------- + 4320 continue + leof = .false. +c rewind lf +cryne 11/04/02 msegm = -1 + msegm=3 +c curr0=-99999. +c-------------------- +c read first line of master input file (should set msegm) +c + 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm write(6,*) itot,' = itot after first REAREC' + write(6,*)'dumpin2: done reading line=' + write(6,*)line + write(6,*)'msegm,itot,leof=',msegm,itot,leof + if(strarr(1).eq.'call')then + write(6,*)'found call statement after 10 in dumpin2' + goto 301 + endif + if (leof) goto 1000 + if(msegm.eq.3)goto 301 + if(msegm.eq.4 .or. msegm.eq.5 .or. msegm.eq.6)goto 410 + if(msegm.eq.9)goto 901 +c check for the statement '#labor' + if(msegm.eq.7)goto 700 + write(6,*)'error: read the first line of input file but' + write(6,*)'cannot determine where to go in routine dumpin2' + call myexit +c-------------------- +c new component (segment) begins, branch to appropriate part of code +c + 1 goto(100,200,300,400,500,600,700,800,900),msegm +c +c error exit: + write(jof ,99) + write(jodf,99) + 99 format(1x,'problems at 1st goto of routine dumpin2; line=') + write(jof,*)line + write(jodf,*)line + call myexit +c-------------------- +c #comment +c + 100 continue +! write(6,*)'here I am at #comment' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 1) goto 1 + if(ignorcom.eq.1)goto 100 +c + npcom=npcom+1 + if(npcom.gt.maxcmt) then + write(jof ,199) maxcmt + write(jodf,199) maxcmt + 199 format(1x,'warning (dumpin2): ', & + & 'entries in #comment beyond line ',i6,' will be ignored') + ignorcom=1 + npcom=maxcmt + goto 100 + endif + mline(npcom)=line + goto 100 +c-------------------- +c #beam +c + 200 continue +! write(6,*)'here I am at #beam' + read(lf,*,err=290,end=1000)brho,gamm1,achg,sl +c computation of relativistic beta and gamma factors: + gamma=gamm1+1.d0 + stuff2=gamm1*(gamma+1.d0) + stuff1=sqrt(stuff2) + beta=stuff1/gamma + ts=sl/c +cryne 08/14/2001 the beam component may contain other info: +c first set defaults + magunits=1 + iverbose=0 + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +!? if(msegm.ne.2)goto 1 + if (npound) goto 1 + if(msegm.eq.3)goto 301 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if(msegm.ne.2) goto 1 +!? +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c need to delete the following code, which is no longer useful or works. + if(msegm.ne.12345)then + write(6,*)'reached bad section of code in DUMPIN. Stopping.' + stop + endif +cryne there is other info in the #beam component: + call txtnum(line,80,4,nget,bufr) + if(nget.ne.4)then + write(6,*)'(dumpin2)error: could not read 4 more #beam numbers' + stop + endif +c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) +cryne current: + curr0=bufr(1) + if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 +cryne units: + if(nint(bufr(3)).ne.0)then + magunits=0 + sclfreq=4.*asin(1.d0)*bufr(3) + write(6,*)'input frequency=',bufr(3),' Hz' + write(6,*)'scale frequency=',sclfreq,' rad/sec' + write(6,*)'dynamic units (not magnetostatic units) will be used' + slnew=c/sclfreq + write(6,*)'scale length specified in the input file is',sl,'m' + write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' + if(abs(sl-slnew)/sl .gt. 1.e-3)then + write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' + write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' + write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' + write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' + endif + sl=slnew + endif +cryne verbose to show progress: + iverbose=bufr(4) +cryne autoslicing (thick elements need an extra parameter): + iautosl=nint(bufr(2)) + if(iautosl.ne.0)then + write(6,*)'autoslicing of thick elements will be enabled.' + endif + if(iautosl.gt.0)then + write(6,*)'fixed # of slices/element will be = ',iautosl + endif + if(iautosl.lt.0)then + write(6,*)'variable # of slices/element will be used' + if(na.ne.0)then + write(6,*)'error: input file specifies variable # of' + write(6,*)'slices/element, but some elements have already' + write(6,*)'been read in. stopping.' + stop + endif + nrp(1,1)=nrp(1,1)+1 + nrp(1,2)=nrp(1,2)+1 + nrp(1,3)=nrp(1,3)+1 + nrp(1,4)=nrp(1,4)+1 + nrp(1,6)=nrp(1,6)+1 + nrp(1,8)=nrp(1,8)+1 + nrp(1,9)=nrp(1,9)+1 + nrp(1,10)=nrp(1,10)+1 + nrp(1,11)=nrp(1,11)+1 + nrp(1,12)=nrp(1,12)+1 + nrp(1,18)=nrp(1,18)+1 + nrp(1,20)=nrp(1,20)+1 + nrp(1,24)=nrp(1,24)+1 + nrp(1,30)=nrp(1,30)+1 + endif + goto 10 +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c error exit: + 290 continue + write(jof ,299) + write(jodf,299) + 299 format(1h ,'data input error detected by dumpin2 near #beam') + call myexit +c-------------------- +c #menu +c + 300 continue +! write(6,*)'here I am at #menu' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +! write(6,*)line(1:80) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if (msegm .ne. 3) goto 1 + 301 continue +c +c 11/4/02 new code to deal with 'call' statements: + if(trim(strarr(1)).eq.'call')then + write(6,*)'found a call statement in dumpin2' + call getsymb60(line,80,symb,istrtsym,nsymb) + write(6,*)'symb(1), symb(2), symb(3)=' + write(6,*)symb(1) + write(6,*)symb(2) + write(6,*)symb(3) + lftemp3=lf + lf=43 + call dumpin3(symb(3)) + close(lf) + lf=lftemp3 + goto 300 + endif + na=na+1 + if(na.gt.mnumax) then + write(jof ,399) mnumax + write(jodf,399) mnumax + 399 format(1h ,'error in dumpin:', & + & ' too many items (>= mnumax = ',i6,') elements in #menu') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,396) strarr(1) + write(jodf,396) strarr(1) + 396 format(' error detected by dumpin2 in #menu: name ', & + & a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! goto 300 + & ' the first definition will be ignored') + lmnlbl(indx)(1:1)='*' + endif +cryne + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then +c check if element/command name is present ( F. Neri 4/14/89 ): + if ( itot .lt. 2 ) then + write(jof ,1396) strarr(1) + write(jodf ,1396) strarr(1) + 1396 format(' error in #menu: ',a16,' has no type code!') + call myexit + endif + endif +cryne July 4 2002 if ( itot .gt. 2 ) then +cryne July 4 2002 write(jof ,1397) strarr(1) +cryne July 4 2002 write(jodf ,1397) strarr(1) +c1397 format(' error in #menu: ',a16,' has more than one type code!') +cryne July 4 2002 call myexit +cryne July 4 2002 endif +c new item in menu: + lmnlbl(na)=strarr(1) + initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse +c string is name of element/command type, look up element indices +cryne string=strarr(2) + if((trim(strarr(1)).eq.'beam').or. & + &(trim(strarr(1)).eq.'units'))then + string=strarr(1) + else + string=strarr(2) + endif + do 325 m = 1,9 + do 325 n = 1,nrpmax + if(string(1:16).eq.ltc(m,n)) then + nt1(na) = m + nt2(na) = n + goto 3344 + endif + 325 continue +c============= +cryne Sept 17, 2003 +c before declaring this an unknown element/command name, +c check to see if it is the name of an existing menu item +c since this is a functionality that MAD allows + call lookup(strarr(2),itype,indx) + if(itype.ne.1)goto 3226 +c this *is* the name of an existing menu item. + if(idproc.eq.0)then + write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) + endif + m = nt1(indx) + n = nt2(indx) + nt1(na) = m + nt2(na) = n + imax=nrp(m,n) + if(imax.ne.0)then + do i=1,imax + pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) + enddo + endif + icmax=ncp(m,n) + if(icmax.ne.0)then + do i=1,icmax + cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) + enddo + endif + initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f + goto 3344 + 3226 continue +c============= +c error: unknown element/command name + write(jof ,398)(strarr(j),j=1,2) + write(jodf,398)(strarr(j),j=1,2) + 398 format(1h ,'dumpin2 error at ',a16,': type code ',a16, & + &' not found.'/ & + & 1h ,'this item will be ignored') + na=na-1 + goto 300 + 3344 continue +! write(6,*)'found a menu element;string,m,n=',string(1:8),m,n +c read parameters. Number of parameters is given in nrp + imax=nrp(m,n) + icmax=ncp(m,n) + imaxold=nrpold(m,n) +c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax +cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 + if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. + & index(line,':').eq.0)goto 300 +cryne July 4, 2002 +c if using the Standard Input Format, the remaining parameters +c are stored in "line"; otherwise use the MaryLie input format: +c +c mpp(na) points to where the real parameters will be stored +c mppc(na) points to where the char*16 parameters will be stored + mpp(na) = mpprpoi + mppc(na) = mppcpoi +cryne 7/9/2002 if(itot.eq.2)then +c original MaryLie input format (icmax not relevant here): + if( (itot.eq.2) .and. (index(line,':').eq.0) )then +c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string + if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) +c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) +c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax + goto 300 +c error in parameter input + 390 write(jof ,397)lmnlbl(na) + write(jodf,397)lmnlbl(na) + 397 format(1h ,'(dumpin2) parameter input error at element ',a16) + call myexit + endif +cryne July 4, 2002 +c if the code gets here, the Standard Input Format is being used +c to specify the elements in the menu: +c first delete the element name and type from the character string: +c write(6,*)'USING STANDARD INPUT FORMAT. LINE=' +c write(6,*)line +c write(6,*)'strarr(1),strarr(2)=' +c write(6,*)strarr(1) +c write(6,*)strarr(2) +ccc write(6,*)'will read params using SIF; imax,icmax=',imax,icmax +ccc write(6,*)'current values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi +cryne this could be more easily done with the f90 intrinsic len_trim() +c kkk1=len_trim(strarr(1))-1 + string=strarr(1) + kkk1=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk1=kkk1-1 + enddo + do i=1,80 + if(line(i:i+kkk1).eq.strarr(1))then + line(i:i+kkk1)=' ' + exit + endif + enddo +cryne kkk2=len_trim(strarr(2))-1 + string=strarr(2) + kkk2=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk2=kkk2-1 + enddo +c + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then + do i=1,80 + if(line(i:i+kkk2).eq.strarr(2))then + line(i:i+kkk2)=' ' + exit + endif + enddo + endif +c get rid of other unneccesary characters: + do i=1,80 +c if(line(i:i).eq.',')line(i:i)=' ' + if(line(i:i).eq.':')line(i:i)=' ' + enddo +c write(6,*)'TRIMMED LINE=' +c write(6,*)line + call stdinf(line,na,m,n,initparms,strarr(1)) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax +c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax +c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi + goto 300 +c +c-------------------- +c #lines,#lumps,#loops +c + 400 continue +! write(6,*)'here I am at #lines,lumps,loops' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 4) goto 1 + goto 410 + 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 5) goto 1 + goto 410 + 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 6) goto 1 +c + 410 nb=nb+1 + if(nb.gt.itmno)then + write(jof ,499) itmno + write(jodf,499) itmno + 499 format(1h ,'error in dumpin2:', & + & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,497) ling(msegm),strarr(1) + write(jodf,497) ling(msegm),strarr(1) + 497 format(1x,'dumpin2 error in ', & + & a8,': name ',a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! if(msegm .eq.4) then +! goto 400 +! else if(msegm.eq.5) then +! goto 500 +! else if(msegm.eq.6) then +! goto 600 +! endif + & ' the first definition will be ignored') + ilbl(indx)(1:1)='*' + endif +c new item + ilbl(nb)=strarr(1) + imin=0 +cryne July 2002 Standard Input Format option: components might be on +cryne this record; check now +cryne Note: this assume that the 2nd string after the name is 'line', +cryne and so the 2nd string is ignored + if( (itot.eq.2) .and. (.not.(lcont)) )then + write(6,*)'error parsing line:' + write(6,*)'this should be a name alone, or' + write(6,*)'a name followed by LINE= followed by the components' + write(6,*)'input line =' + write(6,*)line + stop + endif + if(itot.gt.2)then +c write(6,*)'ITOT=',itot +c do i=1,itot +c write(6,*)i,narr(i),strarr(i) +c enddo + do 424 i=3,itot + icon(imin+i-2,nb)=strarr(i) + irep(imin+i-2,nb)=narr(i) + 424 continue + imin=imin+itot-2 + if(lcont)then + goto 420 + else + goto 426 + endif + endif +cryne remaining code is from original version: +c read components of item +c repeat... + 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if(imin+itot.gt.itmln)then + write(jof ,498) itmln,ilbl(nb) + write(jodf,498) itmln,ilbl(nb) + 498 format(1h ,'error in dumpin2:', & + & ' too many entries (> itmln = ',i6,') in ',a16) + call myexit + endif +c store names and rep rates of components + do 425 i=1,itot + icon(imin+i,nb)=strarr(i) + irep(imin+i,nb)=narr(i) + 425 continue + imin=imin+itot + if(lcont) goto 420 +c ... until no more continuation lines +c-- +c now set length and type of element + 426 continue + ilen(nb)=imin + ityp(nb)=msegm-2 +c go back to appropriate component (segment) + if(msegm .eq.4) then + goto 400 + else if(msegm.eq.5) then + goto 500 + else if(msegm.eq.6) then + goto 600 + endif +c-------------------- +c #labor +c + 700 continue +! write(6,*)'here I am at #labor' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 7) goto 1 +c + noble=noble+1 + if(noble.gt.mlabor) then + write(jof ,799) mlabor + write(jodf,799) mlabor + 799 format(1h ,'error in dumpin2:', & + & ' too many entries (>= mlabor = ',i6,') in #labor array') + call myexit + endif +c new task + latt(noble)=strarr(1) + num(noble)=narr(1) + goto 700 +c-------------------- +c #call (formerly #include) + 800 continue + write(6,*)' Start #call after user name: ',strarr(1) +c +ctm 9/01 modified to open and save up to 32 long #include file names +c + ninc = 0 + 810 read(lf,2000,end=1000) line +c +c check for next segment +c + if(index(line,'#').ne.0) then + itot = -1 + na2 = na + nb2 = nb + noble2 = noble + write(6,813) na2,nb2,noble2 + 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') + write(6,817) line + 817 format(' End #include with: ',a) + go to 10 + endif +c +ctm save file name and pointers before opening 1st include file +c + ninc = ninc + 1 + if(ninc.eq.1) then + na1 = na + nb1 = nb + noble1 = noble + write(6,877) na1,nb1,noble1 + 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') + endif +c +ctm skip leading blanks +c + lc = 1 + 880 if(line(lc:lc).eq.' ') then + lc = lc + 1 + go to 880 + endif + incfil(ninc) = line(lc:) + write(6,888) ninc,incfil(ninc) + 888 format(' include',i3,' : ',a) + call mlfinc(incfil(ninc)) + go to 810 +ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm if (leof) goto 1000 +ctm goto 1 +c-------------------- +c #const + 900 continue +! write(6,*)'here I am at #const' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if((msegm.eq.9).and.(itot.ne.1))then + write(6,*)'input error (#const)' + write(6,*)'trying to read a definition, but did not find a' + write(6,*)'character string at the beginning of this record:' + write(6,*)line(1:80) + stop + endif + if(msegm.eq.3)goto 301 + if(msegm.eq.4)goto 410 + if (msegm .ne. 9) goto 1 + 901 continue + call getconst(line,strval,nreturn) + if(nreturn.ne.1)then + write(6,*)'trouble parsing the following line:' + write(6,*)line + write(6,*)'continuing...' + goto 900 + endif + nconst=nconst+1 + if(nconst.gt.nconmax)then + write(6,*)'too many constants defined in the input file' + stop + endif + constr(nconst)=strarr(1) + conval(nconst)=strval +c write(6,*)'nconst,constr(nconst),conval(nconst)=' +c write(6,*)nconst,constr(nconst),conval(nconst) + goto 900 +c normal return at end of file + 1000 continue + close(44) + write(6,*)'returning from routine dumpin2' + return + end +c +c*********************************************************************** +************************************************************************ + subroutine dumpin3(uname) +c----------------------------------------------------------------------- +c This routine organizes the data input from file lf, the master input +c file. +c This file is divided into "components" beginning with a code "#..." +c The available codes are given in common/sharp/. +c In dumpin, they are numbered as they occur in that common. The +c component (segment) currently being read has number "msegm". +c The entries of the component "#menu" will be called "elements". +c The term "item" is used for entries of the components "#lines", +c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". +c +c Output is transferred via several commons. They are explained below. +c +c Written by Rob Ryne ca 1984 +c rewritten by Petra Schuett +c October 21, 1987 +c----------------------------------------------------------------------- + use beamdata + use acceldata + use lieaparam, only : monoms + use parallel, only : idproc + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- +c + include 'incmif.inc' + include 'codes.inc' + include 'files.inc' + common/mlunits/sclfreq,magunits + common/showme/iverbose + common/symbdef/isymbdef + dimension bufr(4) +c----------------------------------------------------------------------- +c local variables: + character*60 uname + character*16 strarr(40),string + character*80 line + character*16 fname + integer narr(40) + character*60 symb(40) + integer istrtsym(40) + logical leof,lcont,npound +cryne 8/15/2001 new code to read in a character string instead of numbers: +c----------------------------------------------------------------------- +cryne 9/26/02 +c this could go somewhere else too, but here is OK: +c isymbdef=-1 +c +cryne 7/20/2002 initialize character array so that, even if input is +c in the original MaryLie format, the mppc array will be filled with ' ' +c so that files are opened properly. (code checks for name=' ') +cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' +cryne 7/7/2002 +cryne initialize #const +cryne this should go somewhere else (near start of afro.f), but I am +cryne trying not to change MaryLie too much. +c call initcons +cryne 7/7/2002 additional mods to deal w/ huge number of comments +cryne eventually it would be a good idea to let the user specify whether +cryne or not comments should be printed in the pmif command +cryne +c start +c ignorcom=0 +cryne----- 15 Sept 2000 modified to check for input file: +ctm open(lf,file='fort.11',status='old',err=357) +c read(lf,2000,end=2001,err=2001) line + 2000 format(a) +c goto 4320 +c2001 continue +c write(6,*)'master input file does not exist or is empty' +c write(6,*)'type filename or to halt' +c read(5,2002)fname +c2002 format(a16) +c if(fname.eq.' ')call myexit + open(lf,file=uname,status='old',err=3000) + write(6,*)'successfully opened file ',uname + goto 4320 + 3000 continue + write(6,*)'(dumpin3) file does not exist. File name=.' + write(6,*)uname + write(6,*)'Halting.' + call myexit +c----------------------------------------------------------------------- + 4320 continue + leof = .false. +c rewind lf +cryne 11/04/02 msegm = -1 + msegm=3 +c curr0=-99999. +c-------------------- +c read first line of master input file (should set msegm) +c + 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm write(6,*) itot,' = itot after first REAREC' + write(6,*)'dumpin3: done reading line=' + write(6,*)line + write(6,*)'msegm,itot,leof=',msegm,itot,leof + if(strarr(1).eq.'call')then + write(6,*)'found call statement after 10 in dumpin3' + goto 301 + endif + if (leof) goto 1000 + if(msegm.eq.3)goto 301 + if(msegm.eq.4 .or. msegm.eq.5 .or. msegm.eq.6)goto 410 + if(msegm.eq.9)goto 901 +c check for the statement '#labor' + if(msegm.eq.7)goto 700 + write(6,*)'error: read the first line of input file but' + write(6,*)'cannot determine where to go in routine dumpin3' + call myexit +c-------------------- +c new component (segment) begins, branch to appropriate part of code +c + 1 goto(100,200,300,400,500,600,700,800,900),msegm +c +c error exit: + write(jof ,99) + write(jodf,99) + 99 format(1x,'problems at 1st goto of routine dumpin3; line=') + write(jof,*)line + write(jodf,*)line + call myexit +c-------------------- +c #comment +c + 100 continue +! write(6,*)'here I am at #comment' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 1) goto 1 + if(ignorcom.eq.1)goto 100 +c + npcom=npcom+1 + if(npcom.gt.maxcmt) then + write(jof ,199) maxcmt + write(jodf,199) maxcmt + 199 format(1x,'warning (dumpin3: ', & + & 'entries in #comment beyond line ',i6,' will be ignored') + ignorcom=1 + npcom=maxcmt + goto 100 + endif + mline(npcom)=line + goto 100 +c-------------------- +c #beam +c + 200 continue +! write(6,*)'here I am at #beam' + read(lf,*,err=290,end=1000)brho,gamm1,achg,sl +c computation of relativistic beta and gamma factors: + gamma=gamm1+1.d0 + stuff2=gamm1*(gamma+1.d0) + stuff1=sqrt(stuff2) + beta=stuff1/gamma + ts=sl/c +cryne 08/14/2001 the beam component may contain other info: +c first set defaults + magunits=1 + iverbose=0 + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +!? if(msegm.ne.2)goto 1 + if (npound) goto 1 + if(msegm.eq.3)goto 301 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if(msegm.ne.2) goto 1 +!? +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c need to delete the following code, which is no longer useful or works. + if(msegm.ne.12345)then + write(6,*)'reached bad section of code in DUMPIN. Stopping.' + stop + endif +cryne there is other info in the #beam component: + call txtnum(line,80,4,nget,bufr) + if(nget.ne.4)then + write(6,*)'(dumpin3)error: could not read 4 more #beam numbers' + stop + endif +c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) +cryne current: + curr0=bufr(1) + if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 +cryne units: + if(nint(bufr(3)).ne.0)then + magunits=0 + sclfreq=4.*asin(1.d0)*bufr(3) + write(6,*)'input frequency=',bufr(3),' Hz' + write(6,*)'scale frequency=',sclfreq,' rad/sec' + write(6,*)'dynamic units (not magnetostatic units) will be used' + slnew=c/sclfreq + write(6,*)'scale length specified in the input file is',sl,'m' + write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' + if(abs(sl-slnew)/sl .gt. 1.e-3)then + write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' + write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' + write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' + write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' + endif + sl=slnew + endif +cryne verbose to show progress: + iverbose=bufr(4) +cryne autoslicing (thick elements need an extra parameter): + iautosl=nint(bufr(2)) + if(iautosl.ne.0)then + write(6,*)'autoslicing of thick elements will be enabled.' + endif + if(iautosl.gt.0)then + write(6,*)'fixed # of slices/element will be = ',iautosl + endif + if(iautosl.lt.0)then + write(6,*)'variable # of slices/element will be used' + if(na.ne.0)then + write(6,*)'error: input file specifies variable # of' + write(6,*)'slices/element, but some elements have already' + write(6,*)'been read in. stopping.' + stop + endif + nrp(1,1)=nrp(1,1)+1 + nrp(1,2)=nrp(1,2)+1 + nrp(1,3)=nrp(1,3)+1 + nrp(1,4)=nrp(1,4)+1 + nrp(1,6)=nrp(1,6)+1 + nrp(1,8)=nrp(1,8)+1 + nrp(1,9)=nrp(1,9)+1 + nrp(1,10)=nrp(1,10)+1 + nrp(1,11)=nrp(1,11)+1 + nrp(1,12)=nrp(1,12)+1 + nrp(1,18)=nrp(1,18)+1 + nrp(1,20)=nrp(1,20)+1 + nrp(1,24)=nrp(1,24)+1 + nrp(1,30)=nrp(1,30)+1 + endif + goto 10 +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c error exit: + 290 continue + write(jof ,299) + write(jodf,299) + 299 format(1h ,'data input error detected by dumpin3 near #beam') + call myexit +c-------------------- +c #menu +c + 300 continue +! write(6,*)'here I am at #menu' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +! write(6,*)line(1:80) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if (msegm .ne. 3) goto 1 + 301 continue +c +c 11/4/02 new code to deal with 'call' statements: + if(trim(strarr(1)).eq.'call')then + write(6,*)'found a call statement in dumpin3' + call getsymb60(line,80,symb,istrtsym,nsymb) + write(6,*)'symb(1), symb(2), symb(3)=' + write(6,*)symb(1) + write(6,*)symb(2) + write(6,*)symb(3) + lftemp4=lf + lf=44 + call dumpin4(symb(3)) + close(lf) + lf=lftemp4 + goto 300 + endif + na=na+1 + if(na.gt.mnumax) then + write(jof ,399) mnumax + write(jodf,399) mnumax + 399 format(1h ,'error in dumpin:', & + & ' too many items (>= mnumax = ',i6,') elements in #menu') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,396) strarr(1) + write(jodf,396) strarr(1) + 396 format(' error detected by dumpin in #menu: name ', & + & a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! goto 300 + & ' the first definition will be ignored') + lmnlbl(indx)(1:1)='*' + endif +cryne + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then +c check if element/command name is present ( F. Neri 4/14/89 ): + if ( itot .lt. 2 ) then + write(jof ,1396) strarr(1) + write(jodf ,1396) strarr(1) + 1396 format(' error in #menu: ',a16,' has no type code!') + call myexit + endif + endif +cryne July 4 2002 if ( itot .gt. 2 ) then +cryne July 4 2002 write(jof ,1397) strarr(1) +cryne July 4 2002 write(jodf ,1397) strarr(1) +c1397 format(' error in #menu: ',a16,' has more than one type code!') +cryne July 4 2002 call myexit +cryne July 4 2002 endif +c new item in menu: + lmnlbl(na)=strarr(1) + initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse +c string is name of element/command type, look up element indices +cryne string=strarr(2) + if((trim(strarr(1)).eq.'beam').or. & + &(trim(strarr(1)).eq.'units'))then + string=strarr(1) + else + string=strarr(2) + endif + do 325 m = 1,9 + do 325 n = 1,nrpmax + if(string(1:16).eq.ltc(m,n)) then + nt1(na) = m + nt2(na) = n + goto 3344 + endif + 325 continue +c============= +cryne Sept 17, 2003 +c before declaring this an unknown element/command name, +c check to see if it is the name of an existing menu item +c since this is a functionality that MAD allows + call lookup(strarr(2),itype,indx) + if(itype.ne.1)goto 3226 +c this *is* the name of an existing menu item. + if(idproc.eq.0)then + write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) + endif + m = nt1(indx) + n = nt2(indx) + nt1(na) = m + nt2(na) = n + imax=nrp(m,n) + if(imax.ne.0)then + do i=1,imax + pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) + enddo + endif + icmax=ncp(m,n) + if(icmax.ne.0)then + do i=1,icmax + cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) + enddo + endif + initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f + goto 3344 + 3226 continue +c============= +c error: unknown element/command name + write(jof ,398)(strarr(j),j=1,2) + write(jodf,398)(strarr(j),j=1,2) + 398 format(1h ,'dumpin error at ',a16,': type code ',a16, & + &' not found.'/ & + & 1h ,'this item will be ignored') + na=na-1 + goto 300 + 3344 continue +! write(6,*)'found a menu element;string,m,n=',string(1:8),m,n +c read parameters. Number of parameters is given in nrp + imax=nrp(m,n) + icmax=ncp(m,n) + imaxold=nrpold(m,n) +c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax +cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 + if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. + & index(line,':').eq.0)goto 300 +cryne July 4, 2002 +c if using the Standard Input Format, the remaining parameters +c are stored in "line"; otherwise use the MaryLie input format: +c +c mpp(na) points to where the real parameters will be stored +c mppc(na) points to where the char*16 parameters will be stored + mpp(na) = mpprpoi + mppc(na) = mppcpoi +cryne 7/9/2002 if(itot.eq.2)then +c original MaryLie input format (icmax not relevant here): + if( (itot.eq.2) .and. (index(line,':').eq.0) )then +c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string + if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) +c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) +c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax + goto 300 +c error in parameter input + 390 write(jof ,397)lmnlbl(na) + write(jodf,397)lmnlbl(na) + 397 format(1h ,'(dumpin) parameter input error at element ',a16) + call myexit + endif +cryne July 4, 2002 +c if the code gets here, the Standard Input Format is being used +c to specify the elements in the menu: +c first delete the element name and type from the character string: +c write(6,*)'USING STANDARD INPUT FORMAT. LINE=' +c write(6,*)line +c write(6,*)'strarr(1),strarr(2)=' +c write(6,*)strarr(1) +c write(6,*)strarr(2) +ccc write(6,*)'will read params using SIF; imax,icmax=',imax,icmax +ccc write(6,*)'current values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi +cryne this could be more easily done with the f90 intrinsic len_trim() +c kkk1=len_trim(strarr(1))-1 + string=strarr(1) + kkk1=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk1=kkk1-1 + enddo + do i=1,80 + if(line(i:i+kkk1).eq.strarr(1))then + line(i:i+kkk1)=' ' + exit + endif + enddo +cryne kkk2=len_trim(strarr(2))-1 + string=strarr(2) + kkk2=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk2=kkk2-1 + enddo +c + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then + do i=1,80 + if(line(i:i+kkk2).eq.strarr(2))then + line(i:i+kkk2)=' ' + exit + endif + enddo + endif +c get rid of other unneccesary characters: + do i=1,80 +c if(line(i:i).eq.',')line(i:i)=' ' + if(line(i:i).eq.':')line(i:i)=' ' + enddo +c write(6,*)'TRIMMED LINE=' +c write(6,*)line + call stdinf(line,na,m,n,initparms,strarr(1)) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax +c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax +c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi + goto 300 +c +c-------------------- +c #lines,#lumps,#loops +c + 400 continue +! write(6,*)'here I am at #lines,lumps,loops' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 4) goto 1 + goto 410 + 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 5) goto 1 + goto 410 + 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 6) goto 1 +c + 410 nb=nb+1 + if(nb.gt.itmno)then + write(jof ,499) itmno + write(jodf,499) itmno + 499 format(1h ,'error in dumpin:', & + & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,497) ling(msegm),strarr(1) + write(jodf,497) ling(msegm),strarr(1) + 497 format(1x,'dumpin error in ', & + & a8,': name ',a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! if(msegm .eq.4) then +! goto 400 +! else if(msegm.eq.5) then +! goto 500 +! else if(msegm.eq.6) then +! goto 600 +! endif + & ' the first definition will be ignored') + ilbl(indx)(1:1)='*' + endif +c new item + ilbl(nb)=strarr(1) + imin=0 +cryne July 2002 Standard Input Format option: components might be on +cryne this record; check now +cryne Note: this assume that the 2nd string after the name is 'line', +cryne and so the 2nd string is ignored + if( (itot.eq.2) .and. (.not.(lcont)) )then + write(6,*)'error parsing line:' + write(6,*)'this should be a name alone, or' + write(6,*)'a name followed by LINE= followed by the components' + write(6,*)'input line =' + write(6,*)line + stop + endif + if(itot.gt.2)then +c write(6,*)'ITOT=',itot +c do i=1,itot +c write(6,*)i,narr(i),strarr(i) +c enddo + do 424 i=3,itot + icon(imin+i-2,nb)=strarr(i) + irep(imin+i-2,nb)=narr(i) + 424 continue + imin=imin+itot-2 + if(lcont)then + goto 420 + else + goto 426 + endif + endif +cryne remaining code is from original version: +c read components of item +c repeat... + 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if(imin+itot.gt.itmln)then + write(jof ,498) itmln,ilbl(nb) + write(jodf,498) itmln,ilbl(nb) + 498 format(1h ,'error in dumpin:', & + & ' too many entries (> itmln = ',i6,') in ',a16) + call myexit + endif +c store names and rep rates of components + do 425 i=1,itot + icon(imin+i,nb)=strarr(i) + irep(imin+i,nb)=narr(i) + 425 continue + imin=imin+itot + if(lcont) goto 420 +c ... until no more continuation lines +c-- +c now set length and type of element + 426 continue + ilen(nb)=imin + ityp(nb)=msegm-2 +c go back to appropriate component (segment) + if(msegm .eq.4) then + goto 400 + else if(msegm.eq.5) then + goto 500 + else if(msegm.eq.6) then + goto 600 + endif +c-------------------- +c #labor +c + 700 continue +! write(6,*)'here I am at #labor' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 7) goto 1 +c + noble=noble+1 + if(noble.gt.mlabor) then + write(jof ,799) mlabor + write(jodf,799) mlabor + 799 format(1h ,'error in dumpin:', & + & ' too many entries (>= mlabor = ',i6,') in #labor array') + call myexit + endif +c new task + latt(noble)=strarr(1) + num(noble)=narr(1) + goto 700 +c-------------------- +c #call (formerly #include) + 800 continue + write(6,*)' Start #call after user name: ',strarr(1) +c +ctm 9/01 modified to open and save up to 32 long #include file names +c + ninc = 0 + 810 read(lf,2000,end=1000) line +c +c check for next segment +c + if(index(line,'#').ne.0) then + itot = -1 + na2 = na + nb2 = nb + noble2 = noble + write(6,813) na2,nb2,noble2 + 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') + write(6,817) line + 817 format(' End #include with: ',a) + go to 10 + endif +c +ctm save file name and pointers before opening 1st include file +c + ninc = ninc + 1 + if(ninc.eq.1) then + na1 = na + nb1 = nb + noble1 = noble + write(6,877) na1,nb1,noble1 + 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') + endif +c +ctm skip leading blanks +c + lc = 1 + 880 if(line(lc:lc).eq.' ') then + lc = lc + 1 + go to 880 + endif + incfil(ninc) = line(lc:) + write(6,888) ninc,incfil(ninc) + 888 format(' include',i3,' : ',a) + call mlfinc(incfil(ninc)) + go to 810 +ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm if (leof) goto 1000 +ctm goto 1 +c-------------------- +c #const + 900 continue +! write(6,*)'here I am at #const' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if((msegm.eq.9).and.(itot.ne.1))then + write(6,*)'input error (#const)' + write(6,*)'trying to read a definition, but did not find a' + write(6,*)'character string at the beginning of this record:' + write(6,*)line(1:80) + stop + endif + if(msegm.eq.3)goto 301 + if(msegm.eq.4)goto 410 + if (msegm .ne. 9) goto 1 + 901 continue + call getconst(line,strval,nreturn) + if(nreturn.ne.1)then + write(6,*)'trouble parsing the following line:' + write(6,*)line + write(6,*)'continuing...' + goto 900 + endif + nconst=nconst+1 + if(nconst.gt.nconmax)then + write(6,*)'too many constants defined in the input file' + stop + endif + constr(nconst)=strarr(1) + conval(nconst)=strval +c write(6,*)'nconst,constr(nconst),conval(nconst)=' +c write(6,*)nconst,constr(nconst),conval(nconst) + goto 900 +c normal return at end of file + 1000 continue + close(44) + write(6,*)'returning from routine dumpin3' + return + end +c +c*********************************************************************** +************************************************************************ + subroutine dumpin4(uname) +c----------------------------------------------------------------------- +c This routine organizes the data input from file lf, the master input +c file. +c This file is divided into "components" beginning with a code "#..." +c The available codes are given in common/sharp/. +c In dumpin, they are numbered as they occur in that common. The +c component (segment) currently being read has number "msegm". +c The entries of the component "#menu" will be called "elements". +c The term "item" is used for entries of the components "#lines", +c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". +c +c Output is transferred via several commons. They are explained below. +c +c Written by Rob Ryne ca 1984 +c rewritten by Petra Schuett +c October 21, 1987 +c----------------------------------------------------------------------- + use beamdata + use acceldata + use lieaparam, only : monoms + use parallel, only : idproc + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- +c + include 'incmif.inc' + include 'codes.inc' + include 'files.inc' + common/mlunits/sclfreq,magunits + common/showme/iverbose + common/symbdef/isymbdef + dimension bufr(4) +c----------------------------------------------------------------------- +c local variables: + character*60 uname + character*16 strarr(40),string + character*80 line + character*16 fname + integer narr(40) + character*60 symb(40) + integer istrtsym(40) + logical leof,lcont,npound +cryne 8/15/2001 new code to read in a character string instead of numbers: +c----------------------------------------------------------------------- +cryne 9/26/02 +c this could go somewhere else too, but here is OK: +c isymbdef=-1 +c +cryne 7/20/2002 initialize character array so that, even if input is +c in the original MaryLie format, the mppc array will be filled with ' ' +c so that files are opened properly. (code checks for name=' ') +cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' +cryne 7/7/2002 +cryne initialize #const +cryne this should go somewhere else (near start of afro.f), but I am +cryne trying not to change MaryLie too much. +c call initcons +cryne 7/7/2002 additional mods to deal w/ huge number of comments +cryne eventually it would be a good idea to let the user specify whether +cryne or not comments should be printed in the pmif command +cryne +c start +c ignorcom=0 +cryne----- 15 Sept 2000 modified to check for input file: +ctm open(lf,file='fort.11',status='old',err=357) +c read(lf,2000,end=2001,err=2001) line + 2000 format(a) +c goto 4320 +c2001 continue +c write(6,*)'master input file does not exist or is empty' +c write(6,*)'type filename or to halt' +c read(5,2002)fname +c2002 format(a16) +c if(fname.eq.' ')call myexit + open(lf,file=uname,status='old',err=3000) + write(6,*)'successfully opened file ',uname + goto 4320 + 3000 continue + write(6,*)'(dumpin4) file does not exist. File name=.' + write(6,*)uname + write(6,*)'Halting.' + call myexit +c----------------------------------------------------------------------- + 4320 continue + leof = .false. +c rewind lf +cryne 11/04/02 msegm = -1 + msegm=3 +c curr0=-99999. +c-------------------- +c read first line of master input file (should set msegm) +c + 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm write(6,*) itot,' = itot after first REAREC' + write(6,*)'dumpin4: done reading line=' + write(6,*)line + write(6,*)'msegm,itot,leof=',msegm,itot,leof + if(strarr(1).eq.'call')then + write(6,*)'found call statement after 10 in dumpin4' + goto 301 + endif + if (leof) goto 1000 + if(msegm.eq.3)goto 301 + if(msegm.eq.4 .or. msegm.eq.5 .or. msegm.eq.6)goto 410 + if(msegm.eq.9)goto 901 +c check for the statement '#labor' + if(msegm.eq.7)goto 700 + write(6,*)'error: read the first line of input file but' + write(6,*)'cannot determine where to go in routine dumpin4' + call myexit +c-------------------- +c new component (segment) begins, branch to appropriate part of code +c + 1 goto(100,200,300,400,500,600,700,800,900),msegm +c +c error exit: + write(jof ,99) + write(jodf,99) + 99 format(1x,'problems at 1st goto of routine dumpin4; line=') + write(jof,*)line + write(jodf,*)line + call myexit +c-------------------- +c #comment +c + 100 continue +! write(6,*)'here I am at #comment' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 1) goto 1 + if(ignorcom.eq.1)goto 100 +c + npcom=npcom+1 + if(npcom.gt.maxcmt) then + write(jof ,199) maxcmt + write(jodf,199) maxcmt + 199 format(1x,'warning (dumpin4): ', & + & 'entries in #comment beyond line ',i6,' will be ignored') + ignorcom=1 + npcom=maxcmt + goto 100 + endif + mline(npcom)=line + goto 100 +c-------------------- +c #beam +c + 200 continue +! write(6,*)'here I am at #beam' + read(lf,*,err=290,end=1000)brho,gamm1,achg,sl +c computation of relativistic beta and gamma factors: + gamma=gamm1+1.d0 + stuff2=gamm1*(gamma+1.d0) + stuff1=sqrt(stuff2) + beta=stuff1/gamma + ts=sl/c +cryne 08/14/2001 the beam component may contain other info: +c first set defaults + magunits=1 + iverbose=0 + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +!? if(msegm.ne.2)goto 1 + if (npound) goto 1 + if(msegm.eq.3)goto 301 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if(msegm.ne.2) goto 1 +!? +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c need to delete the following code, which is no longer useful or works. + if(msegm.ne.12345)then + write(6,*)'reached bad section of code in DUMPIN. Stopping.' + stop + endif +cryne there is other info in the #beam component: + call txtnum(line,80,4,nget,bufr) + if(nget.ne.4)then + write(6,*)'(dumpin4)error: could not read 4 more #beam numbers' + stop + endif +c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) +cryne current: + curr0=bufr(1) + if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 +cryne units: + if(nint(bufr(3)).ne.0)then + magunits=0 + sclfreq=4.*asin(1.d0)*bufr(3) + write(6,*)'input frequency=',bufr(3),' Hz' + write(6,*)'scale frequency=',sclfreq,' rad/sec' + write(6,*)'dynamic units (not magnetostatic units) will be used' + slnew=c/sclfreq + write(6,*)'scale length specified in the input file is',sl,'m' + write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' + if(abs(sl-slnew)/sl .gt. 1.e-3)then + write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' + write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' + write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' + write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' + endif + sl=slnew + endif +cryne verbose to show progress: + iverbose=bufr(4) +cryne autoslicing (thick elements need an extra parameter): + iautosl=nint(bufr(2)) + if(iautosl.ne.0)then + write(6,*)'autoslicing of thick elements will be enabled.' + endif + if(iautosl.gt.0)then + write(6,*)'fixed # of slices/element will be = ',iautosl + endif + if(iautosl.lt.0)then + write(6,*)'variable # of slices/element will be used' + if(na.ne.0)then + write(6,*)'error: input file specifies variable # of' + write(6,*)'slices/element, but some elements have already' + write(6,*)'been read in. stopping.' + stop + endif + nrp(1,1)=nrp(1,1)+1 + nrp(1,2)=nrp(1,2)+1 + nrp(1,3)=nrp(1,3)+1 + nrp(1,4)=nrp(1,4)+1 + nrp(1,6)=nrp(1,6)+1 + nrp(1,8)=nrp(1,8)+1 + nrp(1,9)=nrp(1,9)+1 + nrp(1,10)=nrp(1,10)+1 + nrp(1,11)=nrp(1,11)+1 + nrp(1,12)=nrp(1,12)+1 + nrp(1,18)=nrp(1,18)+1 + nrp(1,20)=nrp(1,20)+1 + nrp(1,24)=nrp(1,24)+1 + nrp(1,30)=nrp(1,30)+1 + endif + goto 10 +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c error exit: + 290 continue + write(jof ,299) + write(jodf,299) + 299 format(1h ,'data input error detected by dumpin4 near #beam') + call myexit +c-------------------- +c #menu +c + 300 continue +! write(6,*)'here I am at #menu' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +! write(6,*)line(1:80) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if (msegm .ne. 3) goto 1 + 301 continue +c +c 11/4/02 new code to deal with 'call' statements: + if(trim(strarr(1)).eq.'call')then + write(6,*)'found a call statement in dumpin4' + call getsymb60(line,80,symb,istrtsym,nsymb) + write(6,*)'symb(1), symb(2), symb(3)=' + write(6,*)symb(1) + write(6,*)symb(2) + write(6,*)symb(3) + lftemp5=lf + lf=45 + call dumpin5(symb(3)) + close(lf) + lf=lftemp5 + goto 300 + endif + na=na+1 + if(na.gt.mnumax) then + write(jof ,399) mnumax + write(jodf,399) mnumax + 399 format(1h ,'error in dumpin4:', & + & ' too many items (>= mnumax = ',i6,') elements in #menu') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,396) strarr(1) + write(jodf,396) strarr(1) + 396 format(' error detected by dumpin4 in #menu: name ', & + & a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! goto 300 + & ' the first definition will be ignored') + lmnlbl(indx)(1:1)='*' + endif +cryne + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then +c check if element/command name is present ( F. Neri 4/14/89 ): + if ( itot .lt. 2 ) then + write(jof ,1396) strarr(1) + write(jodf ,1396) strarr(1) + 1396 format(' error in #menu: ',a16,' has no type code!') + call myexit + endif + endif +cryne July 4 2002 if ( itot .gt. 2 ) then +cryne July 4 2002 write(jof ,1397) strarr(1) +cryne July 4 2002 write(jodf ,1397) strarr(1) +c1397 format(' error in #menu: ',a16,' has more than one type code!') +cryne July 4 2002 call myexit +cryne July 4 2002 endif +c new item in menu: + lmnlbl(na)=strarr(1) + initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse +c string is name of element/command type, look up element indices +cryne string=strarr(2) + if((trim(strarr(1)).eq.'beam').or. & + &(trim(strarr(1)).eq.'units'))then + string=strarr(1) + else + string=strarr(2) + endif + do 325 m = 1,9 + do 325 n = 1,nrpmax + if(string(1:16).eq.ltc(m,n)) then + nt1(na) = m + nt2(na) = n + goto 3344 + endif + 325 continue +c============= +cryne Sept 17, 2003 +c before declaring this an unknown element/command name, +c check to see if it is the name of an existing menu item +c since this is a functionality that MAD allows + call lookup(strarr(2),itype,indx) + if(itype.ne.1)goto 3226 +c this *is* the name of an existing menu item. + if(idproc.eq.0)then + write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) + endif + m = nt1(indx) + n = nt2(indx) + nt1(na) = m + nt2(na) = n + imax=nrp(m,n) + if(imax.ne.0)then + do i=1,imax + pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) + enddo + endif + icmax=ncp(m,n) + if(icmax.ne.0)then + do i=1,icmax + cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) + enddo + endif + initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f + goto 3344 + 3226 continue +c============= +c error: unknown element/command name + write(jof ,398)(strarr(j),j=1,2) + write(jodf,398)(strarr(j),j=1,2) + 398 format(1h ,'dumpin4 error at ',a16,': type code ',a16, & + &' not found.'/ & + & 1h ,'this item will be ignored') + na=na-1 + goto 300 + 3344 continue +! write(6,*)'found a menu element;string,m,n=',string(1:8),m,n +c read parameters. Number of parameters is given in nrp + imax=nrp(m,n) + icmax=ncp(m,n) + imaxold=nrpold(m,n) +c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax +cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 + if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. + & index(line,':').eq.0)goto 300 +cryne July 4, 2002 +c if using the Standard Input Format, the remaining parameters +c are stored in "line"; otherwise use the MaryLie input format: +c +c mpp(na) points to where the real parameters will be stored +c mppc(na) points to where the char*16 parameters will be stored + mpp(na) = mpprpoi + mppc(na) = mppcpoi +cryne 7/9/2002 if(itot.eq.2)then +c original MaryLie input format (icmax not relevant here): + if( (itot.eq.2) .and. (index(line,':').eq.0) )then +c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string + if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) +c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) +c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax + goto 300 +c error in parameter input + 390 write(jof ,397)lmnlbl(na) + write(jodf,397)lmnlbl(na) + 397 format(1h ,'(dumpin4) parameter input error at element ',a16) + call myexit + endif +cryne July 4, 2002 +c if the code gets here, the Standard Input Format is being used +c to specify the elements in the menu: +c first delete the element name and type from the character string: +c write(6,*)'USING STANDARD INPUT FORMAT. LINE=' +c write(6,*)line +c write(6,*)'strarr(1),strarr(2)=' +c write(6,*)strarr(1) +c write(6,*)strarr(2) +ccc write(6,*)'will read params using SIF; imax,icmax=',imax,icmax +ccc write(6,*)'current values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi +cryne this could be more easily done with the f90 intrinsic len_trim() +c kkk1=len_trim(strarr(1))-1 + string=strarr(1) + kkk1=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk1=kkk1-1 + enddo + do i=1,80 + if(line(i:i+kkk1).eq.strarr(1))then + line(i:i+kkk1)=' ' + exit + endif + enddo +cryne kkk2=len_trim(strarr(2))-1 + string=strarr(2) + kkk2=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk2=kkk2-1 + enddo +c + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then + do i=1,80 + if(line(i:i+kkk2).eq.strarr(2))then + line(i:i+kkk2)=' ' + exit + endif + enddo + endif +c get rid of other unneccesary characters: + do i=1,80 +c if(line(i:i).eq.',')line(i:i)=' ' + if(line(i:i).eq.':')line(i:i)=' ' + enddo +c write(6,*)'TRIMMED LINE=' +c write(6,*)line + call stdinf(line,na,m,n,initparms,strarr(1)) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax +c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax +c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi + goto 300 +c +c-------------------- +c #lines,#lumps,#loops +c + 400 continue +! write(6,*)'here I am at #lines,lumps,loops' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 4) goto 1 + goto 410 + 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 5) goto 1 + goto 410 + 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 6) goto 1 +c + 410 nb=nb+1 + if(nb.gt.itmno)then + write(jof ,499) itmno + write(jodf,499) itmno + 499 format(1h ,'error in dumpin4:', & + & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,497) ling(msegm),strarr(1) + write(jodf,497) ling(msegm),strarr(1) + 497 format(1x,'dumpin4 error in ', & + & a8,': name ',a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! if(msegm .eq.4) then +! goto 400 +! else if(msegm.eq.5) then +! goto 500 +! else if(msegm.eq.6) then +! goto 600 +! endif + & ' the first definition will be ignored') + ilbl(indx)(1:1)='*' + endif +c new item + ilbl(nb)=strarr(1) + imin=0 +cryne July 2002 Standard Input Format option: components might be on +cryne this record; check now +cryne Note: this assume that the 2nd string after the name is 'line', +cryne and so the 2nd string is ignored + if( (itot.eq.2) .and. (.not.(lcont)) )then + write(6,*)'error parsing line:' + write(6,*)'this should be a name alone, or' + write(6,*)'a name followed by LINE= followed by the components' + write(6,*)'input line =' + write(6,*)line + stop + endif + if(itot.gt.2)then +c write(6,*)'ITOT=',itot +c do i=1,itot +c write(6,*)i,narr(i),strarr(i) +c enddo + do 424 i=3,itot + icon(imin+i-2,nb)=strarr(i) + irep(imin+i-2,nb)=narr(i) + 424 continue + imin=imin+itot-2 + if(lcont)then + goto 420 + else + goto 426 + endif + endif +cryne remaining code is from original version: +c read components of item +c repeat... + 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if(imin+itot.gt.itmln)then + write(jof ,498) itmln,ilbl(nb) + write(jodf,498) itmln,ilbl(nb) + 498 format(1h ,'error in dumpin4:', & + & ' too many entries (> itmln = ',i6,') in ',a16) + call myexit + endif +c store names and rep rates of components + do 425 i=1,itot + icon(imin+i,nb)=strarr(i) + irep(imin+i,nb)=narr(i) + 425 continue + imin=imin+itot + if(lcont) goto 420 +c ... until no more continuation lines +c-- +c now set length and type of element + 426 continue + ilen(nb)=imin + ityp(nb)=msegm-2 +c go back to appropriate component (segment) + if(msegm .eq.4) then + goto 400 + else if(msegm.eq.5) then + goto 500 + else if(msegm.eq.6) then + goto 600 + endif +c-------------------- +c #labor +c + 700 continue +! write(6,*)'here I am at #labor' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 7) goto 1 +c + noble=noble+1 + if(noble.gt.mlabor) then + write(jof ,799) mlabor + write(jodf,799) mlabor + 799 format(1h ,'error in dumpin4:', & + & ' too many entries (>= mlabor = ',i6,') in #labor array') + call myexit + endif +c new task + latt(noble)=strarr(1) + num(noble)=narr(1) + goto 700 +c-------------------- +c #call (formerly #include) + 800 continue + write(6,*)' Start #call after user name: ',strarr(1) +c +ctm 9/01 modified to open and save up to 32 long #include file names +c + ninc = 0 + 810 read(lf,2000,end=1000) line +c +c check for next segment +c + if(index(line,'#').ne.0) then + itot = -1 + na2 = na + nb2 = nb + noble2 = noble + write(6,813) na2,nb2,noble2 + 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') + write(6,817) line + 817 format(' End #include with: ',a) + go to 10 + endif +c +ctm save file name and pointers before opening 1st include file +c + ninc = ninc + 1 + if(ninc.eq.1) then + na1 = na + nb1 = nb + noble1 = noble + write(6,877) na1,nb1,noble1 + 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') + endif +c +ctm skip leading blanks +c + lc = 1 + 880 if(line(lc:lc).eq.' ') then + lc = lc + 1 + go to 880 + endif + incfil(ninc) = line(lc:) + write(6,888) ninc,incfil(ninc) + 888 format(' include',i3,' : ',a) + call mlfinc(incfil(ninc)) + go to 810 +ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm if (leof) goto 1000 +ctm goto 1 +c-------------------- +c #const + 900 continue +! write(6,*)'here I am at #const' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if((msegm.eq.9).and.(itot.ne.1))then + write(6,*)'input error (#const)' + write(6,*)'trying to read a definition, but did not find a' + write(6,*)'character string at the beginning of this record:' + write(6,*)line(1:80) + stop + endif + if(msegm.eq.3)goto 301 + if(msegm.eq.4)goto 410 + if (msegm .ne. 9) goto 1 + 901 continue + call getconst(line,strval,nreturn) + if(nreturn.ne.1)then + write(6,*)'trouble parsing the following line:' + write(6,*)line + write(6,*)'continuing...' + goto 900 + endif + nconst=nconst+1 + if(nconst.gt.nconmax)then + write(6,*)'too many constants defined in the input file' + stop + endif + constr(nconst)=strarr(1) + conval(nconst)=strval +c write(6,*)'nconst,constr(nconst),conval(nconst)=' +c write(6,*)nconst,constr(nconst),conval(nconst) + goto 900 +c normal return at end of file + 1000 continue + close(44) + write(6,*)'returning from routine dumpin4' + return + end +c +c*********************************************************************** +************************************************************************ + subroutine dumpin5(uname) +c----------------------------------------------------------------------- +c This routine organizes the data input from file lf, the master input +c file. +c This file is divided into "components" beginning with a code "#..." +c The available codes are given in common/sharp/. +c In dumpin, they are numbered as they occur in that common. The +c component (segment) currently being read has number "msegm". +c The entries of the component "#menu" will be called "elements". +c The term "item" is used for entries of the components "#lines", +c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". +c +c Output is transferred via several commons. They are explained below. +c +c Written by Rob Ryne ca 1984 +c rewritten by Petra Schuett +c October 21, 1987 +c----------------------------------------------------------------------- + use beamdata + use acceldata + use lieaparam, only : monoms + use parallel, only : idproc + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- +c + include 'incmif.inc' + include 'codes.inc' + include 'files.inc' + common/mlunits/sclfreq,magunits + common/showme/iverbose + common/symbdef/isymbdef + dimension bufr(4) +c----------------------------------------------------------------------- +c local variables: + character*60 uname + character*16 strarr(40),string + character*80 line + character*16 fname + integer narr(40) + character*60 symb(40) + integer istrtsym(40) + logical leof,lcont,npound +cryne 8/15/2001 new code to read in a character string instead of numbers: +c----------------------------------------------------------------------- +cryne 9/26/02 +c this could go somewhere else too, but here is OK: +c isymbdef=-1 +c +cryne 7/20/2002 initialize character array so that, even if input is +c in the original MaryLie format, the mppc array will be filled with ' ' +c so that files are opened properly. (code checks for name=' ') +cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' +cryne 7/7/2002 +cryne initialize #const +cryne this should go somewhere else (near start of afro.f), but I am +cryne trying not to change MaryLie too much. +c call initcons +cryne 7/7/2002 additional mods to deal w/ huge number of comments +cryne eventually it would be a good idea to let the user specify whether +cryne or not comments should be printed in the pmif command +cryne +c start +c ignorcom=0 +cryne----- 15 Sept 2000 modified to check for input file: +ctm open(lf,file='fort.11',status='old',err=357) +c read(lf,2000,end=2001,err=2001) line + 2000 format(a) +c goto 4320 +c2001 continue +c write(6,*)'master input file does not exist or is empty' +c write(6,*)'type filename or to halt' +c read(5,2002)fname +c2002 format(a16) +c if(fname.eq.' ')call myexit + open(lf,file=uname,status='old',err=3000) + write(6,*)'successfully opened file ',uname + goto 4320 + 3000 continue + write(6,*)'(dumpin5) file does not exist. File name=.' + write(6,*)uname + write(6,*)'Halting.' + call myexit +c----------------------------------------------------------------------- + 4320 continue + leof = .false. +c rewind lf +cryne 11/04/02 msegm = -1 + msegm=3 +c curr0=-99999. +c-------------------- +c read first line of master input file (should set msegm) +c + 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm write(6,*) itot,' = itot after first REAREC' + write(6,*)'dumpin5: done reading line=' + write(6,*)line + write(6,*)'msegm,itot,leof=',msegm,itot,leof + if(strarr(1).eq.'call')then + write(6,*)'found call statement after 10 in dumpin5' + goto 301 + endif + if (leof) goto 1000 + if(msegm.eq.3)goto 301 + if(msegm.eq.4 .or. msegm.eq.5 .or. msegm.eq.6)goto 410 + if(msegm.eq.9)goto 901 +c check for the statement '#labor' + if(msegm.eq.7)goto 700 + write(6,*)'error: read the first line of input file but' + write(6,*)'cannot determine where to go in routine dumpin5' + call myexit +c-------------------- +c new component (segment) begins, branch to appropriate part of code +c + 1 goto(100,200,300,400,500,600,700,800,900),msegm +c +c error exit: + write(jof ,99) + write(jodf,99) + 99 format(1x,'problems at 1st goto of routine dumpin5; line=') + write(jof,*)line + write(jodf,*)line + call myexit +c-------------------- +c #comment +c + 100 continue +! write(6,*)'here I am at #comment' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 1) goto 1 + if(ignorcom.eq.1)goto 100 +c + npcom=npcom+1 + if(npcom.gt.maxcmt) then + write(jof ,199) maxcmt + write(jodf,199) maxcmt + 199 format(1x,'warning (dumpin5): ', & + & 'entries in #comment beyond line ',i6,' will be ignored') + ignorcom=1 + npcom=maxcmt + goto 100 + endif + mline(npcom)=line + goto 100 +c-------------------- +c #beam +c + 200 continue +! write(6,*)'here I am at #beam' + read(lf,*,err=290,end=1000)brho,gamm1,achg,sl +c computation of relativistic beta and gamma factors: + gamma=gamm1+1.d0 + stuff2=gamm1*(gamma+1.d0) + stuff1=sqrt(stuff2) + beta=stuff1/gamma + ts=sl/c +cryne 08/14/2001 the beam component may contain other info: +c first set defaults + magunits=1 + iverbose=0 + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +!? if(msegm.ne.2)goto 1 + if (npound) goto 1 + if(msegm.eq.3)goto 301 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if(msegm.ne.2) goto 1 +!? +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c need to delete the following code, which is no longer useful or works. + if(msegm.ne.12345)then + write(6,*)'reached bad section of code in DUMPIN. Stopping.' + stop + endif +cryne there is other info in the #beam component: + call txtnum(line,80,4,nget,bufr) + if(nget.ne.4)then + write(6,*)'(dumpin5)error: could not read 4 more #beam numbers' + stop + endif +c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) +cryne current: + curr0=bufr(1) + if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 +cryne units: + if(nint(bufr(3)).ne.0)then + magunits=0 + sclfreq=4.*asin(1.d0)*bufr(3) + write(6,*)'input frequency=',bufr(3),' Hz' + write(6,*)'scale frequency=',sclfreq,' rad/sec' + write(6,*)'dynamic units (not magnetostatic units) will be used' + slnew=c/sclfreq + write(6,*)'scale length specified in the input file is',sl,'m' + write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' + if(abs(sl-slnew)/sl .gt. 1.e-3)then + write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' + write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' + write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' + write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' + endif + sl=slnew + endif +cryne verbose to show progress: + iverbose=bufr(4) +cryne autoslicing (thick elements need an extra parameter): + iautosl=nint(bufr(2)) + if(iautosl.ne.0)then + write(6,*)'autoslicing of thick elements will be enabled.' + endif + if(iautosl.gt.0)then + write(6,*)'fixed # of slices/element will be = ',iautosl + endif + if(iautosl.lt.0)then + write(6,*)'variable # of slices/element will be used' + if(na.ne.0)then + write(6,*)'error: input file specifies variable # of' + write(6,*)'slices/element, but some elements have already' + write(6,*)'been read in. stopping.' + stop + endif + nrp(1,1)=nrp(1,1)+1 + nrp(1,2)=nrp(1,2)+1 + nrp(1,3)=nrp(1,3)+1 + nrp(1,4)=nrp(1,4)+1 + nrp(1,6)=nrp(1,6)+1 + nrp(1,8)=nrp(1,8)+1 + nrp(1,9)=nrp(1,9)+1 + nrp(1,10)=nrp(1,10)+1 + nrp(1,11)=nrp(1,11)+1 + nrp(1,12)=nrp(1,12)+1 + nrp(1,18)=nrp(1,18)+1 + nrp(1,20)=nrp(1,20)+1 + nrp(1,24)=nrp(1,24)+1 + nrp(1,30)=nrp(1,30)+1 + endif + goto 10 +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c error exit: + 290 continue + write(jof ,299) + write(jodf,299) + 299 format(1h ,'data input error detected by dumpin5 near #beam') + call myexit +c-------------------- +c #menu +c + 300 continue +! write(6,*)'here I am at #menu' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +! write(6,*)line(1:80) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if (msegm .ne. 3) goto 1 + 301 continue +c +c 11/4/02 new code to deal with 'call' statements: + if(trim(strarr(1)).eq.'call')then + write(6,*)'found a call statement in dumpin5' + call getsymb60(line,80,symb,istrtsym,nsymb) + write(6,*)'symb(1), symb(2), symb(3)=' + write(6,*)symb(1) + write(6,*)symb(2) + write(6,*)symb(3) + lftemp6=lf + lf=46 + call dumpin6(symb(3)) + close(lf) + lf=lftemp6 + goto 300 + endif + na=na+1 + if(na.gt.mnumax) then + write(jof ,399) mnumax + write(jodf,399) mnumax + 399 format(1h ,'error in dumpin5:', & + & ' too many items (>= mnumax = ',i6,') elements in #menu') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,396) strarr(1) + write(jodf,396) strarr(1) + 396 format(' error detected by dumpin5 in #menu: name ', & + & a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! goto 300 + & ' the first definition will be ignored') + lmnlbl(indx)(1:1)='*' + endif +cryne + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then +c check if element/command name is present ( F. Neri 4/14/89 ): + if ( itot .lt. 2 ) then + write(jof ,1396) strarr(1) + write(jodf ,1396) strarr(1) + 1396 format(' error in #menu: ',a16,' has no type code!') + call myexit + endif + endif +cryne July 4 2002 if ( itot .gt. 2 ) then +cryne July 4 2002 write(jof ,1397) strarr(1) +cryne July 4 2002 write(jodf ,1397) strarr(1) +c1397 format(' error in #menu: ',a16,' has more than one type code!') +cryne July 4 2002 call myexit +cryne July 4 2002 endif +c new item in menu: + lmnlbl(na)=strarr(1) + initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse +c string is name of element/command type, look up element indices +cryne string=strarr(2) + if((trim(strarr(1)).eq.'beam').or. & + &(trim(strarr(1)).eq.'units'))then + string=strarr(1) + else + string=strarr(2) + endif + do 325 m = 1,9 + do 325 n = 1,nrpmax + if(string(1:16).eq.ltc(m,n)) then + nt1(na) = m + nt2(na) = n + goto 3344 + endif + 325 continue +c============= +cryne Sept 17, 2003 +c before declaring this an unknown element/command name, +c check to see if it is the name of an existing menu item +c since this is a functionality that MAD allows + call lookup(strarr(2),itype,indx) + if(itype.ne.1)goto 3226 +c this *is* the name of an existing menu item. + if(idproc.eq.0)then + write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) + endif + m = nt1(indx) + n = nt2(indx) + nt1(na) = m + nt2(na) = n + imax=nrp(m,n) + if(imax.ne.0)then + do i=1,imax + pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) + enddo + endif + icmax=ncp(m,n) + if(icmax.ne.0)then + do i=1,icmax + cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) + enddo + endif + initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f + goto 3344 + 3226 continue +c============= +c error: unknown element/command name + write(jof ,398)(strarr(j),j=1,2) + write(jodf,398)(strarr(j),j=1,2) + 398 format(1h ,'dumpin5 error at ',a16,': type code ',a16, & + &' not found.'/ & + & 1h ,'this item will be ignored') + na=na-1 + goto 300 + 3344 continue +! write(6,*)'found a menu element;string,m,n=',string(1:8),m,n +c read parameters. Number of parameters is given in nrp + imax=nrp(m,n) + icmax=ncp(m,n) + imaxold=nrpold(m,n) +c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax +cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 + if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. + & index(line,':').eq.0)goto 300 +cryne July 4, 2002 +c if using the Standard Input Format, the remaining parameters +c are stored in "line"; otherwise use the MaryLie input format: +c +c mpp(na) points to where the real parameters will be stored +c mppc(na) points to where the char*16 parameters will be stored + mpp(na) = mpprpoi + mppc(na) = mppcpoi +cryne 7/9/2002 if(itot.eq.2)then +c original MaryLie input format (icmax not relevant here): + if( (itot.eq.2) .and. (index(line,':').eq.0) )then +c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string + if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) +c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) +c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax + goto 300 +c error in parameter input + 390 write(jof ,397)lmnlbl(na) + write(jodf,397)lmnlbl(na) + 397 format(1h ,'(dumpin5) parameter input error at element ',a16) + call myexit + endif +cryne July 4, 2002 +c if the code gets here, the Standard Input Format is being used +c to specify the elements in the menu: +c first delete the element name and type from the character string: +c write(6,*)'USING STANDARD INPUT FORMAT. LINE=' +c write(6,*)line +c write(6,*)'strarr(1),strarr(2)=' +c write(6,*)strarr(1) +c write(6,*)strarr(2) +ccc write(6,*)'will read params using SIF; imax,icmax=',imax,icmax +ccc write(6,*)'current values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi +cryne this could be more easily done with the f90 intrinsic len_trim() +c kkk1=len_trim(strarr(1))-1 + string=strarr(1) + kkk1=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk1=kkk1-1 + enddo + do i=1,80 + if(line(i:i+kkk1).eq.strarr(1))then + line(i:i+kkk1)=' ' + exit + endif + enddo +cryne kkk2=len_trim(strarr(2))-1 + string=strarr(2) + kkk2=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk2=kkk2-1 + enddo +c + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then + do i=1,80 + if(line(i:i+kkk2).eq.strarr(2))then + line(i:i+kkk2)=' ' + exit + endif + enddo + endif +c get rid of other unneccesary characters: + do i=1,80 +c if(line(i:i).eq.',')line(i:i)=' ' + if(line(i:i).eq.':')line(i:i)=' ' + enddo +c write(6,*)'TRIMMED LINE=' +c write(6,*)line + call stdinf(line,na,m,n,initparms,strarr(1)) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax +c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax +c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi + goto 300 +c +c-------------------- +c #lines,#lumps,#loops +c + 400 continue +! write(6,*)'here I am at #lines,lumps,loops' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 4) goto 1 + goto 410 + 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 5) goto 1 + goto 410 + 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 6) goto 1 +c + 410 nb=nb+1 + if(nb.gt.itmno)then + write(jof ,499) itmno + write(jodf,499) itmno + 499 format(1h ,'error in dumpin5:', & + & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,497) ling(msegm),strarr(1) + write(jodf,497) ling(msegm),strarr(1) + 497 format(1x,'dumpin5 error in ', & + & a8,': name ',a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! if(msegm .eq.4) then +! goto 400 +! else if(msegm.eq.5) then +! goto 500 +! else if(msegm.eq.6) then +! goto 600 +! endif + & ' the first definition will be ignored') + ilbl(indx)(1:1)='*' + endif +c new item + ilbl(nb)=strarr(1) + imin=0 +cryne July 2002 Standard Input Format option: components might be on +cryne this record; check now +cryne Note: this assume that the 2nd string after the name is 'line', +cryne and so the 2nd string is ignored + if( (itot.eq.2) .and. (.not.(lcont)) )then + write(6,*)'error parsing line:' + write(6,*)'this should be a name alone, or' + write(6,*)'a name followed by LINE= followed by the components' + write(6,*)'input line =' + write(6,*)line + stop + endif + if(itot.gt.2)then +c write(6,*)'ITOT=',itot +c do i=1,itot +c write(6,*)i,narr(i),strarr(i) +c enddo + do 424 i=3,itot + icon(imin+i-2,nb)=strarr(i) + irep(imin+i-2,nb)=narr(i) + 424 continue + imin=imin+itot-2 + if(lcont)then + goto 420 + else + goto 426 + endif + endif +cryne remaining code is from original version: +c read components of item +c repeat... + 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if(imin+itot.gt.itmln)then + write(jof ,498) itmln,ilbl(nb) + write(jodf,498) itmln,ilbl(nb) + 498 format(1h ,'error in dumpin5:', & + & ' too many entries (> itmln = ',i6,') in ',a16) + call myexit + endif +c store names and rep rates of components + do 425 i=1,itot + icon(imin+i,nb)=strarr(i) + irep(imin+i,nb)=narr(i) + 425 continue + imin=imin+itot + if(lcont) goto 420 +c ... until no more continuation lines +c-- +c now set length and type of element + 426 continue + ilen(nb)=imin + ityp(nb)=msegm-2 +c go back to appropriate component (segment) + if(msegm .eq.4) then + goto 400 + else if(msegm.eq.5) then + goto 500 + else if(msegm.eq.6) then + goto 600 + endif +c-------------------- +c #labor +c + 700 continue +! write(6,*)'here I am at #labor' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 7) goto 1 +c + noble=noble+1 + if(noble.gt.mlabor) then + write(jof ,799) mlabor + write(jodf,799) mlabor + 799 format(1h ,'error in dumpin5:', & + & ' too many entries (>= mlabor = ',i6,') in #labor array') + call myexit + endif +c new task + latt(noble)=strarr(1) + num(noble)=narr(1) + goto 700 +c-------------------- +c #call (formerly #include) + 800 continue + write(6,*)' Start #call after user name: ',strarr(1) +c +ctm 9/01 modified to open and save up to 32 long #include file names +c + ninc = 0 + 810 read(lf,2000,end=1000) line +c +c check for next segment +c + if(index(line,'#').ne.0) then + itot = -1 + na2 = na + nb2 = nb + noble2 = noble + write(6,813) na2,nb2,noble2 + 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') + write(6,817) line + 817 format(' End #include with: ',a) + go to 10 + endif +c +ctm save file name and pointers before opening 1st include file +c + ninc = ninc + 1 + if(ninc.eq.1) then + na1 = na + nb1 = nb + noble1 = noble + write(6,877) na1,nb1,noble1 + 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') + endif +c +ctm skip leading blanks +c + lc = 1 + 880 if(line(lc:lc).eq.' ') then + lc = lc + 1 + go to 880 + endif + incfil(ninc) = line(lc:) + write(6,888) ninc,incfil(ninc) + 888 format(' include',i3,' : ',a) + call mlfinc(incfil(ninc)) + go to 810 +ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm if (leof) goto 1000 +ctm goto 1 +c-------------------- +c #const + 900 continue +! write(6,*)'here I am at #const' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if((msegm.eq.9).and.(itot.ne.1))then + write(6,*)'input error (#const)' + write(6,*)'trying to read a definition, but did not find a' + write(6,*)'character string at the beginning of this record:' + write(6,*)line(1:80) + stop + endif + if(msegm.eq.3)goto 301 + if(msegm.eq.4)goto 410 + if (msegm .ne. 9) goto 1 + 901 continue + call getconst(line,strval,nreturn) + if(nreturn.ne.1)then + write(6,*)'trouble parsing the following line:' + write(6,*)line + write(6,*)'continuing...' + goto 900 + endif + nconst=nconst+1 + if(nconst.gt.nconmax)then + write(6,*)'too many constants defined in the input file' + stop + endif + constr(nconst)=strarr(1) + conval(nconst)=strval +c write(6,*)'nconst,constr(nconst),conval(nconst)=' +c write(6,*)nconst,constr(nconst),conval(nconst) + goto 900 +c normal return at end of file + 1000 continue + close(44) + write(6,*)'returning from routine dumpin5' + return + end +c +c*********************************************************************** +************************************************************************ + subroutine dumpin6(uname) +c----------------------------------------------------------------------- +c This routine organizes the data input from file lf, the master input +c file. +c This file is divided into "components" beginning with a code "#..." +c The available codes are given in common/sharp/. +c In dumpin, they are numbered as they occur in that common. The +c component (segment) currently being read has number "msegm". +c The entries of the component "#menu" will be called "elements". +c The term "item" is used for entries of the components "#lines", +c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". +c +c Output is transferred via several commons. They are explained below. +c +c Written by Rob Ryne ca 1984 +c rewritten by Petra Schuett +c October 21, 1987 +c----------------------------------------------------------------------- + use beamdata + use acceldata + use lieaparam, only : monoms + use parallel, only : idproc + include 'impli.inc' +c----------------------------------------------------------------------- +c common blocks +c----------------------------------------------------------------------- +c + include 'incmif.inc' + include 'codes.inc' + include 'files.inc' + common/mlunits/sclfreq,magunits + common/showme/iverbose + common/symbdef/isymbdef + dimension bufr(4) +c----------------------------------------------------------------------- +c local variables: + character*60 uname + character*16 strarr(40),string + character*80 line + character*16 fname + integer narr(40) + character*60 symb(40) + integer istrtsym(40) + logical leof,lcont,npound +cryne 8/15/2001 new code to read in a character string instead of numbers: +c----------------------------------------------------------------------- +cryne 9/26/02 +c this could go somewhere else too, but here is OK: +c isymbdef=-1 +c +cryne 7/20/2002 initialize character array so that, even if input is +c in the original MaryLie format, the mppc array will be filled with ' ' +c so that files are opened properly. (code checks for name=' ') +cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' +cryne 7/7/2002 +cryne initialize #const +cryne this should go somewhere else (near start of afro.f), but I am +cryne trying not to change MaryLie too much. +c call initcons +cryne 7/7/2002 additional mods to deal w/ huge number of comments +cryne eventually it would be a good idea to let the user specify whether +cryne or not comments should be printed in the pmif command +cryne +c start +c ignorcom=0 +cryne----- 15 Sept 2000 modified to check for input file: +ctm open(lf,file='fort.11',status='old',err=357) +c read(lf,2000,end=2001,err=2001) line + 2000 format(a) +c goto 4320 +c2001 continue +c write(6,*)'master input file does not exist or is empty' +c write(6,*)'type filename or to halt' +c read(5,2002)fname +c2002 format(a16) +c if(fname.eq.' ')call myexit + open(lf,file=uname,status='old',err=3000) + write(6,*)'successfully opened file ',uname + goto 4320 + 3000 continue + write(6,*)'(dumpin6) file does not exist. File name=.' + write(6,*)uname + write(6,*)'Halting.' + call myexit +c----------------------------------------------------------------------- + 4320 continue + leof = .false. +c rewind lf +cryne 11/04/02 msegm = -1 + msegm=3 +c curr0=-99999. +c-------------------- +c read first line of master input file (should set msegm) +c + 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm write(6,*) itot,' = itot after first REAREC' + write(6,*)'dumpin6: done reading line=' + write(6,*)line + write(6,*)'msegm,itot,leof=',msegm,itot,leof + if(strarr(1).eq.'call')then + write(6,*)'found call statement after 10 in dumpin6' + goto 301 + endif + if (leof) goto 1000 + if(msegm.eq.3)goto 301 + if(msegm.eq.4 .or. msegm.eq.5 .or. msegm.eq.6)goto 410 + if(msegm.eq.9)goto 901 +c check for the statement '#labor' + if(msegm.eq.7)goto 700 + write(6,*)'error: read the first line of input file but' + write(6,*)'cannot determine where to go in routine dumpin6' + call myexit +c-------------------- +c new component (segment) begins, branch to appropriate part of code +c + 1 goto(100,200,300,400,500,600,700,800,900),msegm +c +c error exit: + write(jof ,99) + write(jodf,99) + 99 format(1x,'problems at 1st goto of routine dumpin6; line=') + write(jof,*)line + write(jodf,*)line + call myexit +c-------------------- +c #comment +c + 100 continue +! write(6,*)'here I am at #comment' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 1) goto 1 + if(ignorcom.eq.1)goto 100 +c + npcom=npcom+1 + if(npcom.gt.maxcmt) then + write(jof ,199) maxcmt + write(jodf,199) maxcmt + 199 format(1x,'warning (dumpin6): ', & + & 'entries in #comment beyond line ',i6,' will be ignored') + ignorcom=1 + npcom=maxcmt + goto 100 + endif + mline(npcom)=line + goto 100 +c-------------------- +c #beam +c + 200 continue +! write(6,*)'here I am at #beam' + read(lf,*,err=290,end=1000)brho,gamm1,achg,sl +c computation of relativistic beta and gamma factors: + gamma=gamm1+1.d0 + stuff2=gamm1*(gamma+1.d0) + stuff1=sqrt(stuff2) + beta=stuff1/gamma + ts=sl/c +cryne 08/14/2001 the beam component may contain other info: +c first set defaults + magunits=1 + iverbose=0 + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +!? if(msegm.ne.2)goto 1 + if (npound) goto 1 + if(msegm.eq.3)goto 301 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if(msegm.ne.2) goto 1 +!? +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c need to delete the following code, which is no longer useful or works. + if(msegm.ne.12345)then + write(6,*)'reached bad section of code in DUMPIN. Stopping.' + stop + endif +cryne there is other info in the #beam component: + call txtnum(line,80,4,nget,bufr) + if(nget.ne.4)then + write(6,*)'(dumpin6)error: could not read 4 more #beam numbers' + stop + endif +c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) +cryne current: + curr0=bufr(1) + if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 +cryne units: + if(nint(bufr(3)).ne.0)then + magunits=0 + sclfreq=4.*asin(1.d0)*bufr(3) + write(6,*)'input frequency=',bufr(3),' Hz' + write(6,*)'scale frequency=',sclfreq,' rad/sec' + write(6,*)'dynamic units (not magnetostatic units) will be used' + slnew=c/sclfreq + write(6,*)'scale length specified in the input file is',sl,'m' + write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' + if(abs(sl-slnew)/sl .gt. 1.e-3)then + write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' + write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' + write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' + write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' + endif + sl=slnew + endif +cryne verbose to show progress: + iverbose=bufr(4) +cryne autoslicing (thick elements need an extra parameter): + iautosl=nint(bufr(2)) + if(iautosl.ne.0)then + write(6,*)'autoslicing of thick elements will be enabled.' + endif + if(iautosl.gt.0)then + write(6,*)'fixed # of slices/element will be = ',iautosl + endif + if(iautosl.lt.0)then + write(6,*)'variable # of slices/element will be used' + if(na.ne.0)then + write(6,*)'error: input file specifies variable # of' + write(6,*)'slices/element, but some elements have already' + write(6,*)'been read in. stopping.' + stop + endif + nrp(1,1)=nrp(1,1)+1 + nrp(1,2)=nrp(1,2)+1 + nrp(1,3)=nrp(1,3)+1 + nrp(1,4)=nrp(1,4)+1 + nrp(1,6)=nrp(1,6)+1 + nrp(1,8)=nrp(1,8)+1 + nrp(1,9)=nrp(1,9)+1 + nrp(1,10)=nrp(1,10)+1 + nrp(1,11)=nrp(1,11)+1 + nrp(1,12)=nrp(1,12)+1 + nrp(1,18)=nrp(1,18)+1 + nrp(1,20)=nrp(1,20)+1 + nrp(1,24)=nrp(1,24)+1 + nrp(1,30)=nrp(1,30)+1 + endif + goto 10 +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c error exit: + 290 continue + write(jof ,299) + write(jodf,299) + 299 format(1h ,'data input error detected by dumpin6 near #beam') + call myexit +c-------------------- +c #menu +c + 300 continue +! write(6,*)'here I am at #menu' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +! write(6,*)line(1:80) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.4)goto 410 + if (msegm .ne. 3) goto 1 + 301 continue +c +c 11/4/02 new code to deal with 'call' statements: + if(trim(strarr(1)).eq.'call')then + write(6,*)'found a call statement in dumpin6' + call getsymb60(line,80,symb,istrtsym,nsymb) + write(6,*)'symb(1), symb(2), symb(3)=' + write(6,*)symb(1) + write(6,*)symb(2) + write(6,*)symb(3) + write(6,*)'this exceeds the maximum amount of nested calls' + write(6,*)'in the dumpin subroutines; halting.' + call myexit +c for more nesting, uncomment the following and add routine dumpin7 +cccc lftemp7=lf +cccc lf=47 +cccc call dumpin7(symb(3)) +cccc close(lf) +cccc lf=lftemp7 +cccc goto 300 + endif + na=na+1 + if(na.gt.mnumax) then + write(jof ,399) mnumax + write(jodf,399) mnumax + 399 format(1h ,'error in dumpin6:', & + & ' too many items (>= mnumax = ',i6,') elements in #menu') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,396) strarr(1) + write(jodf,396) strarr(1) + 396 format(' error detected by dumpin6 in #menu: name ', & + & a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! goto 300 + & ' the first definition will be ignored') + lmnlbl(indx)(1:1)='*' + endif +cryne + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then +c check if element/command name is present ( F. Neri 4/14/89 ): + if ( itot .lt. 2 ) then + write(jof ,1396) strarr(1) + write(jodf ,1396) strarr(1) + 1396 format(' error in #menu: ',a16,' has no type code!') + call myexit + endif + endif +cryne July 4 2002 if ( itot .gt. 2 ) then +cryne July 4 2002 write(jof ,1397) strarr(1) +cryne July 4 2002 write(jodf ,1397) strarr(1) +c1397 format(' error in #menu: ',a16,' has more than one type code!') +cryne July 4 2002 call myexit +cryne July 4 2002 endif +c new item in menu: + lmnlbl(na)=strarr(1) + initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse +c string is name of element/command type, look up element indices +cryne string=strarr(2) + if((trim(strarr(1)).eq.'beam').or. & + &(trim(strarr(1)).eq.'units'))then + string=strarr(1) + else + string=strarr(2) + endif + do 325 m = 1,9 + do 325 n = 1,nrpmax + if(string(1:16).eq.ltc(m,n)) then + nt1(na) = m + nt2(na) = n + goto 3344 + endif + 325 continue +c============= +cryne Sept 17, 2003 +c before declaring this an unknown element/command name, +c check to see if it is the name of an existing menu item +c since this is a functionality that MAD allows + call lookup(strarr(2),itype,indx) + if(itype.ne.1)goto 3226 +c this *is* the name of an existing menu item. + if(idproc.eq.0)then + write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) + endif + m = nt1(indx) + n = nt2(indx) + nt1(na) = m + nt2(na) = n + imax=nrp(m,n) + if(imax.ne.0)then + do i=1,imax + pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) + enddo + endif + icmax=ncp(m,n) + if(icmax.ne.0)then + do i=1,icmax + cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) + enddo + endif + initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f + goto 3344 + 3226 continue +c============= +c error: unknown element/command name + write(jof ,398)(strarr(j),j=1,2) + write(jodf,398)(strarr(j),j=1,2) + 398 format(1h ,'dumpin6 error at ',a16,': type code ',a16, & + &' not found.'/ & + & 1h ,'this item will be ignored') + na=na-1 + goto 300 + 3344 continue +! write(6,*)'found a menu element;string,m,n=',string(1:8),m,n +c read parameters. Number of parameters is given in nrp + imax=nrp(m,n) + icmax=ncp(m,n) + imaxold=nrpold(m,n) +c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax +cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 + if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. + & index(line,':').eq.0)goto 300 +cryne July 4, 2002 +c if using the Standard Input Format, the remaining parameters +c are stored in "line"; otherwise use the MaryLie input format: +c +c mpp(na) points to where the real parameters will be stored +c mppc(na) points to where the char*16 parameters will be stored + mpp(na) = mpprpoi + mppc(na) = mppcpoi +cryne 7/9/2002 if(itot.eq.2)then +c original MaryLie input format (icmax not relevant here): + if( (itot.eq.2) .and. (index(line,':').eq.0) )then +c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string + if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) +c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) +c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax + goto 300 +c error in parameter input + 390 write(jof ,397)lmnlbl(na) + write(jodf,397)lmnlbl(na) + 397 format(1h ,'(dumpin6) parameter input error at element ',a16) + call myexit + endif +cryne July 4, 2002 +c if the code gets here, the Standard Input Format is being used +c to specify the elements in the menu: +c first delete the element name and type from the character string: +c write(6,*)'USING STANDARD INPUT FORMAT. LINE=' +c write(6,*)line +c write(6,*)'strarr(1),strarr(2)=' +c write(6,*)strarr(1) +c write(6,*)strarr(2) +ccc write(6,*)'will read params using SIF; imax,icmax=',imax,icmax +ccc write(6,*)'current values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi +cryne this could be more easily done with the f90 intrinsic len_trim() +c kkk1=len_trim(strarr(1))-1 + string=strarr(1) + kkk1=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk1=kkk1-1 + enddo + do i=1,80 + if(line(i:i+kkk1).eq.strarr(1))then + line(i:i+kkk1)=' ' + exit + endif + enddo +cryne kkk2=len_trim(strarr(2))-1 + string=strarr(2) + kkk2=len(string)-1 + do i=1,len(string) + if(string(i:i).eq.' ')kkk2=kkk2-1 + enddo +c + if((trim(strarr(1)).ne.'beam').and. & + &(trim(strarr(1)).ne.'units'))then + do i=1,80 + if(line(i:i+kkk2).eq.strarr(2))then + line(i:i+kkk2)=' ' + exit + endif + enddo + endif +c get rid of other unneccesary characters: + do i=1,80 +c if(line(i:i).eq.',')line(i:i)=' ' + if(line(i:i).eq.':')line(i:i)=' ' + enddo +c write(6,*)'TRIMMED LINE=' +c write(6,*)line + call stdinf(line,na,m,n,initparms,strarr(1)) + mpprpoi = mpprpoi + imax + mppcpoi = mppcpoi + icmax +c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax +c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi + goto 300 +c +c-------------------- +c #lines,#lumps,#loops +c + 400 continue +! write(6,*)'here I am at #lines,lumps,loops' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 4) goto 1 + goto 410 + 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 5) goto 1 + goto 410 + 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if(msegm.eq.9)goto 901 + if(msegm.eq.3)goto 301 + if (msegm .ne. 6) goto 1 +c + 410 nb=nb+1 + if(nb.gt.itmno)then + write(jof ,499) itmno + write(jodf,499) itmno + 499 format(1h ,'error in dumpin6:', & + & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') + call myexit + endif +c check for doubly defined names + call lookup(strarr(1),itype,indx) + if(itype.ne.5) then + write(jof ,497) ling(msegm),strarr(1) + write(jodf,497) ling(msegm),strarr(1) + 497 format(1x,'dumpin6 error in ', & + & a8,': name ',a16,' is doubly defined'/ & +! & ' the second definition will be ignored') +! na = na-1 +! if(msegm .eq.4) then +! goto 400 +! else if(msegm.eq.5) then +! goto 500 +! else if(msegm.eq.6) then +! goto 600 +! endif + & ' the first definition will be ignored') + ilbl(indx)(1:1)='*' + endif +c new item + ilbl(nb)=strarr(1) + imin=0 +cryne July 2002 Standard Input Format option: components might be on +cryne this record; check now +cryne Note: this assume that the 2nd string after the name is 'line', +cryne and so the 2nd string is ignored + if( (itot.eq.2) .and. (.not.(lcont)) )then + write(6,*)'error parsing line:' + write(6,*)'this should be a name alone, or' + write(6,*)'a name followed by LINE= followed by the components' + write(6,*)'input line =' + write(6,*)line + stop + endif + if(itot.gt.2)then +c write(6,*)'ITOT=',itot +c do i=1,itot +c write(6,*)i,narr(i),strarr(i) +c enddo + do 424 i=3,itot + icon(imin+i-2,nb)=strarr(i) + irep(imin+i-2,nb)=narr(i) + 424 continue + imin=imin+itot-2 + if(lcont)then + goto 420 + else + goto 426 + endif + endif +cryne remaining code is from original version: +c read components of item +c repeat... + 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if(imin+itot.gt.itmln)then + write(jof ,498) itmln,ilbl(nb) + write(jodf,498) itmln,ilbl(nb) + 498 format(1h ,'error in dumpin6:', & + & ' too many entries (> itmln = ',i6,') in ',a16) + call myexit + endif +c store names and rep rates of components + do 425 i=1,itot + icon(imin+i,nb)=strarr(i) + irep(imin+i,nb)=narr(i) + 425 continue + imin=imin+itot + if(lcont) goto 420 +c ... until no more continuation lines +c-- +c now set length and type of element + 426 continue + ilen(nb)=imin + ityp(nb)=msegm-2 +c go back to appropriate component (segment) + if(msegm .eq.4) then + goto 400 + else if(msegm.eq.5) then + goto 500 + else if(msegm.eq.6) then + goto 600 + endif +c-------------------- +c #labor +c + 700 continue +! write(6,*)'here I am at #labor' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (leof) goto 1000 + if (msegm .ne. 7) goto 1 +c + noble=noble+1 + if(noble.gt.mlabor) then + write(jof ,799) mlabor + write(jodf,799) mlabor + 799 format(1h ,'error in dumpin6:', & + & ' too many entries (>= mlabor = ',i6,') in #labor array') + call myexit + endif +c new task + latt(noble)=strarr(1) + num(noble)=narr(1) + goto 700 +c-------------------- +c #call (formerly #include) + 800 continue + write(6,*)' Start #call after user name: ',strarr(1) +c +ctm 9/01 modified to open and save up to 32 long #include file names +c + ninc = 0 + 810 read(lf,2000,end=1000) line +c +c check for next segment +c + if(index(line,'#').ne.0) then + itot = -1 + na2 = na + nb2 = nb + noble2 = noble + write(6,813) na2,nb2,noble2 + 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') + write(6,817) line + 817 format(' End #include with: ',a) + go to 10 + endif +c +ctm save file name and pointers before opening 1st include file +c + ninc = ninc + 1 + if(ninc.eq.1) then + na1 = na + nb1 = nb + noble1 = noble + write(6,877) na1,nb1,noble1 + 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') + endif +c +ctm skip leading blanks +c + lc = 1 + 880 if(line(lc:lc).eq.' ') then + lc = lc + 1 + go to 880 + endif + incfil(ninc) = line(lc:) + write(6,888) ninc,incfil(ninc) + 888 format(' include',i3,' : ',a) + call mlfinc(incfil(ninc)) + go to 810 +ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) +ctm if (leof) goto 1000 +ctm goto 1 +c-------------------- +c #const + 900 continue +! write(6,*)'here I am at #const' + call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) + if (npound) goto 1 + if (leof) goto 1000 + if((msegm.eq.9).and.(itot.ne.1))then + write(6,*)'input error (#const)' + write(6,*)'trying to read a definition, but did not find a' + write(6,*)'character string at the beginning of this record:' + write(6,*)line(1:80) + stop + endif + if(msegm.eq.3)goto 301 + if(msegm.eq.4)goto 410 + if (msegm .ne. 9) goto 1 + 901 continue + call getconst(line,strval,nreturn) + if(nreturn.ne.1)then + write(6,*)'trouble parsing the following line:' + write(6,*)line + write(6,*)'continuing...' + goto 900 + endif + nconst=nconst+1 + if(nconst.gt.nconmax)then + write(6,*)'too many constants defined in the input file' + stop + endif + constr(nconst)=strarr(1) + conval(nconst)=strval +c write(6,*)'nconst,constr(nconst),conval(nconst)=' +c write(6,*)nconst,constr(nconst),conval(nconst) + goto 900 +c normal return at end of file + 1000 continue + close(44) + write(6,*)'returning from routine dumpin6' + return + end +c diff --git a/OpticsJan2020/MLI_light_optics/Src/e_gengrad_mod.f b/OpticsJan2020/MLI_light_optics/Src/e_gengrad_mod.f new file mode 100644 index 0000000..01f7e61 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/e_gengrad_mod.f @@ -0,0 +1,1222 @@ +!*********************************************************************** +! +! e_gengrad: module for E-field generalized gradients +! +! Description: This module implements the derived types and subroutines +! for computing generalized gradients from E-field data given on the +! surface of a cylinder. +! +! Version: 0.1 +! Author: D.T.Abell, Tech-X Corp., Jan.2005 +! +! Comments +! 12.Jan.05 DTA: Only azimuthally symmetric case implemented. +! +!*********************************************************************** +! + module e_gengrad + use parallel, only : idproc + use lieaparam, only : monoms + use gengrad_data + implicit none +! +! data +! + integer, parameter, private :: max_j = 3 ! (N+1)/2 for MaryLie-N + ! extra z values required by adam11 + integer, parameter, private :: rkxtra = 306 + !double precision :: radius !don't think this is used + double precision :: rf_phase + double precision :: rf_escale +! +! derived types +! + type Efield_data + integer :: nz_intrvl + double precision :: zmin, zmax + double precision :: radius + double precision :: freq + ! must allocate the following arrays dim(0:nz_intrvl) + double precision, dimension(:), pointer :: zvals + double precision, dimension(:), pointer :: Ezdata + !double precision, dimension(:), pointer :: Erdata + !double precision, dimension(:), pointer :: Btdata + end type Efield_data +! + type charfn + integer :: nk_intrvl + double precision :: w_ovr_c + double precision :: kmax, dk + ! must allocate e0r(0:nk_intrvl), e0i(0:nk_intrvl) + double precision, dimension(:), pointer :: e0r + double precision, dimension(:), pointer :: e0i + end type charfn +! + type vecpot + double precision, dimension(0:monoms) :: Ax,Ay,Az + end type vecpot +! +! generalized gradient data to share +! + type (gengrad), save :: eggrdata + ! set G1[c,s](iz,j,m) = Crmj^{c,s}(z) + ! G2[c,s](iz,j,m) = Cfmj^{c,s}(z) + ! G3[c,s](iz,j,m) = Czmj^{c,s}(z) +! +! vector potential data to share +! + type (vecpot), save :: vp +! +! functions and subroutines +! + contains +! +!*********************************************************************** + subroutine read_efield_t7(fn,nf,zi,zf,f,r,efield) +! Read one or more 't7' files and extract the field data at the surface +! of a cylinder of specified radius r. A t7 file contains rf data for +! Ez, Er, Etot, and Htheta on a uniform grid in r and z. For a more on +! the t7 format, see, for example, p.35 of the Parmela manual. If the +! input 'f', for rf cavity frequency, has a non-zero value, it will +! override the value in the field-data files; it is otherwise replaced +! by the value from the field-data files. + use math_consts + use parallel + implicit none + character(16), intent(in) :: fn ! file name or base file name + integer, intent(in) :: nf ! file number range; 0 => use 'fname' + double precision, intent(in) :: zi,zf ! initial and final z + double precision, intent(inout) :: f ! cavity frequency + double precision, intent(in) :: r ! extract data at this radius + type (Efield_data), intent(out) :: efield +!-----!----------------------------------------------------------------! + character(29), parameter :: estrng="e_gengrad_mod::read_efield_t7" + double precision, parameter :: tiny=1.d-6 + character(16) :: fname + logical :: singleF + integer :: ierr,lng0,lng,nfc,nfile,offset + integer :: i,iu,ii,jj,kk,ll,irad,ir,iz,izt + integer :: nr,nz,nvals,nztot + double precision :: frq,r1,r2,ri,z1,z2,dr,dz + double precision :: ez,er,et,hth +cccccc +c if (idproc.eq.0) then +c print *," " +c print *,"(read_efield_t7): ..." +c print *,"(",fn,nf,zi,zf,r,")" +c end if +cccccc + ! are we reading just a single file + ! with a given filename? + if (nf.eq.0) then + nfc=1 + singleF=.true. + else + nfc=nf + singleF=.false. + offset=int(log10(real(nfc))) + end if + + ! loop over the files to read + nztot=0 + do nfile=1,nfc + + ! first open the E-field data file + fname=fn + if (singleF) then ! use 'fname' as is + call fnamechk(fname,iu,ierr,estrng) + else ! build name of current 't7' file + lng0=len_trim(fname) ! DTA: should test length + if (nfile.ge.1.and.nfile.le.9) then + lng=lng0+offset + do i=1,offset + fname(lng0+i:lng0+i)="0" + end do + fname(lng+1:lng+1)=char(nfile+48) + fname(lng+2:lng+4)=".t7" + call fnamechk(fname,iu,ierr,estrng) + if(ierr.ne.0) then + fname(lng+2:lng+4)=".T7" + call fnamechk(fname,iu,ierr,estrng) + end if + else if (nfile.ge.10.and.nfile.le.99) then + lng=lng0+offset-1 + do i=1,offset-1 + fname(lng0+i:lng0+i)="0" + end do + ii = nfile/10 + jj = nfile - ii*10 + fname(lng+1:lng+1) = char(ii+48) + fname(lng+2:lng+2) = char(jj+48) + fname(lng+3:lng+5)=".t7" + call fnamechk(fname,iu,ierr,estrng) + if(ierr.ne.0) then + fname(lng+3:lng+5)=".T7" + call fnamechk(fname,iu,ierr,estrng) + end if + else if (nfile.ge.100.and.nfile.le.999) then + lng=lng0+offset-2 + do i=1,offset-2 + fname(lng0+i:lng0+i)="0" + end do + ii = nfile/100 + jj = nfile - 100*ii + kk = jj/10 + ll = jj - 10*kk + fname(lng+1:lng+1) = char(ii+48) + fname(lng+2:lng+2) = char(kk+48) + fname(lng+3:lng+3) = char(ll+48) + fname(lng+4:lng+6)=".t7" + call fnamechk(fname,iu,ierr,estrng) + if(ierr.ne.0) then + fname(lng+4:lng+6)=".T7" + call fnamechk(fname,iu,ierr,estrng) + end if + else if (nfile.gt.999) then + ierr=1 + if (idproc.eq.0) then + write(6,*) "<*** ERROR ***> in ",estrng,":" + write(6,*) " range of file numbers too large!" + end if + end if + end if + if(ierr.ne.0) then + if (idproc.eq.0) then + write(6,*) "<*** ERROR ***> in ",estrng,":" + write(6,*) " can't read data file",fname + write(6,*) " exiting now..." + end if + call myexit + end if + if (idproc.eq.0) print *,fname," opened" + ! file unit iu should now be open for reading + ! ---but only by processor zero + + ! now read data file + if (idproc.eq.0) then + ! read data description: first three lines of t7 file describe + ! longitudinal range, frequency, and radial range + ! longitudinal range given in cm; convert to m + read(iu,*) z1,z2,nz + print *,"z-in: ",z1,z2,nz + z1=z1*1.0d-2 + z2=z2*1.0d-2 + ! if argument f is non-zero, use that value; + ! else read frequency in MHz, and convert to Hz + read(iu,*) frq + print *,"frq: ",f + if (f.eq.0.d0) then + f=frq*1.0d6 + endif + ! radial range given in cm; convert to m + read(iu,*) r1,r2,nr + print *,"r-in: ",r1,r2,nr + r1=r1*1.0d-2 + r2=r2*1.0d-2 + print *,"frequency: ",f + print *,"z-range: ",z1,z2,nz + print *,"r-range: ",r1,r2,nr + end if + + call MPI_BCAST(nr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(nz,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(r1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(r2,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(z1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(z2,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(f,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + + if (nfile.eq.1) then + efield%zmin = z1 + efield%zmax = z2 + efield%radius = r + efield%freq = f + ! deallocate old data, then allocate space we need + ! === not sure this is the right approach (DTA) === + ! DTA: if (nz(file2) > nz(file1)) problem exists! + if(associated(efield%zvals)) deallocate(efield%zvals) + if(associated(efield%Ezdata)) deallocate(efield%Ezdata) + !if(associated(efield%Erdata)) deallocate(efield%Erdata) + !if(associated(efield%Btdata)) deallocate(efield%Btdata) + nvals=nfc*nz ! best guess for total number of intervals + allocate(efield%zvals(0:nvals)) + allocate(efield%Ezdata(0:nvals)) + !allocate(efield%Erdata(0:nvals)) + !allocate(efield%Btdata(0:nvals)) + else + ! DTA: should do some sanity checks here + efield%zmax=z2 + end if + + ! compute and test radial index + ri=nr*(r-r1)/(r2-r1) + irad=int(ri+0.5) + if (abs(ri-irad).gt.tiny.or. & + & irad.lt.0.or.irad.gt.nr) then + if (idproc.eq.0) then + print *,"<*** ERROR ***> in ",estrng,":" + print *," desired radius ",r," does not appear in ",fname + print *," r1, r2, nr, dr =",r1,r2,nr,(r2-r1)/nr + print *," ri, irad =",ri,irad + print *," exiting now..." + end if + call myexit + end if + + ! read field data at desired radius + if (idproc.eq.0) then + do ir=1,irad ! skip inner radii + do iz=0,nz + read(iu,*) ez,er,et + read(iu,*) hth + end do + end do + dz=(z2-z1)/nz + do iz=0,nz + read(iu,*) ez,er,et + read(iu,*) hth + izt=nztot+iz + efield%zvals(izt)=z1+iz*dz + ! E-field given in MV/m, convert to V/m + efield%Ezdata(izt)=ez*1.0d6 + !efield%Erdata(izt)=er*1.0d6 + ! H-field given in A/m, convert to B-field in T + !efield%Btdata(izt)=hth*mu_o + end do + close(iu) + end if + nztot=nztot+nz + + end do ! loop over nfile + efield%nz_intrvl = nztot + + ! check (zmin,zmax) v. (zi,zf) + if (idproc.eq.0) then + if (.not.(zi.eq.0.d0.and.zf.eq.0.d0)) then ! shift z values + if (abs((efield%zmax-efield%zmin)-(zf-zi)).gt.tiny) then + if (idproc.eq.0) then + print *," <*** WARNING ***> from ",estrng + print *," desired range of z values is incompatible" + print *," with the data in file(s) ",fn + end if + else + dz=efield%zmin-zi + if (dz.ne.0.d0) then + do iz=0,nztot + efield%zvals(iz)=efield%zvals(iz)-dz + end do + end if + end if + end if + end if +cccccc +c if (idproc.eq.0) then +c print *," " +c print *," Efield data at radius ",r +c do iz=0,nztot +c print *,efield%zvals(iz),efield%Ezdata(iz) +c end do +c end if +cccccc + + ! broadcast E-field information to other processors + ! zmin,zmax,nz_intrvl,freq,w_ovr_c already done; + ! need to broadcast just zvals and Ezdata + call MPI_BCAST(efield%zvals(0),efield%nz_intrvl+1, & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(efield%Ezdata(0),efield%nz_intrvl+1, & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + + end subroutine read_efield_t7 +! +!*********************************************************************** + subroutine read_efield_ez(fn,nf,jf,zi,zf,f,r,efield) +! +! Read one or more data files and extract the field data at the surface +! of a cylinder of specified radius r. This subroutine reads field data +! for Ez on a uniform grid in r and z. The first three lines contain +! meta-data describing the file: +! +! r_min/m r_max/m N_r (N_r := number of r intervals) +! z_min/m z_max/m N_z (N_z := number of z intervals) +! rf-freq/Hz +! +! The remaining lines contain the data E_z(r_i,z_j), where i denotes +! the faster changing index. +! +! If the input 'f', for rf cavity frequency, has a non-zero value, it +! will override the value in the field-data files; it is otherwise +! replaced by the value from the field-data files. +! + use math_consts + use parallel + implicit none + character(16), intent(in) :: fn ! file name or base file name + integer, intent(in) :: nf ! file number range; 0 => use 'fn' + integer, intent(in) :: jf ! unit number for E-field diagnostic + double precision, intent(inout) :: zi,zf ! initial and final z + double precision, intent(inout) :: f ! cavity frequency + double precision, intent(in) :: r ! extract data at this radius + type (Efield_data), intent(out) :: efield +!-----!----------------------------------------------------------------! + character(29), parameter :: estrng="e_gengrad_mod::read_efield_ez" + double precision, parameter :: tiny=1.d-6 + double precision, parameter :: eps=1.d-13 + character(16) :: fname,numstr + logical :: singleF + integer :: ierr,lng,ndig,nfc,nfile + integer :: i,iu,ii,jj,kk,ll,irad,ir,iz,izt + integer :: nr,nz,nvals,nztot + double precision :: dr,dz,frq,r1,r2,ri,z1,z2 + double precision :: ez,er,et,hth +cccccc +c if (idproc.eq.0) then +c print *," " +c print *,estrng,": ..." +c print *," (",fn,",",nf,",",jf,",",zi,",",zf,",",r,",efield)" +c end if +cccccc + ! are we reading just a single file with a given filename? + if (nf.eq.0) then + nfc=1 + singleF=.true. + else + nfc=nf + singleF=.false. + end if + + ! loop over the files to read + ndig=1+int(log10(real(nfc))) + nztot=0 + do nfile=1,nfc + + ! first open the E-field data file + fname=fn + if (singleF) then ! use 'fname' as is + call fnamechk(fname,iu,ierr,estrng) + else ! build name of current data file + lng=len_trim(fname) ! DTA: should test length + call num2string(nfile,numstr,ndig) + fname=fname(1:lng)//numstr(1:ndig)//".ez" + call fnamechk(fname,iu,ierr,estrng) + end if + if(ierr.ne.0) then + if (idproc.eq.0) then + write(6,*) "<*** ERROR ***> in ",estrng,":" + write(6,*) " can't read data file ",fname + write(6,*) " exiting now..." + end if + call myexit + end if + if (idproc.eq.0) print *,fname," opened" + ! file unit iu should now be open for reading + ! ---but only by processor zero + + ! now read data file + if (idproc.eq.0) then + ! read data description: first three lines of ez file describe + ! r_min/m r_max/m N_r_intrvls + ! z_min/m z_max/m N_z_intrvls + ! rf-frequency/Hz + read(iu,*) r1,r2,nr + read(iu,*) z1,z2,nz + read(iu,*) frq + ! if argument f is non-zero, use that value instead + if (f.eq.0.d0) then + f=frq + else + print *," NB: not using rf-frequency ",frq," from data file" + endif + print *,"r-range: ",r1,r2,nr + print *,"z-range: ",z1,z2,nz + print *,"frequency: ",f + end if + + call MPI_BCAST(nr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(nz,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(r1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(r2,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(z1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(z2,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(f,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + + if (nfile.eq.1) then + efield%zmin = z1 + efield%zmax = z2 + efield%radius = r ! fix (below) if requested and actual differ + efield%freq = f + ! deallocate old data, then allocate space we need + ! === not sure this is the right approach (DTA) === + ! DTA: if (nz(file_i) > nz(file_1)) problem exists! + if(associated(efield%zvals)) deallocate(efield%zvals) + if(associated(efield%Ezdata)) deallocate(efield%Ezdata) + !if(associated(efield%Erdata)) deallocate(efield%Erdata) + !if(associated(efield%Btdata)) deallocate(efield%Btdata) + nvals=nfc*nz ! best guess for total number of intervals + allocate(efield%zvals(0:nvals)) + allocate(efield%Ezdata(0:nvals)) + !allocate(efield%Erdata(0:nvals)) + !allocate(efield%Btdata(0:nvals)) + else + ! DTA: should do some sanity checks here + efield%zmax=z2 + end if + + ! compute and test radial index + if (nr.ne.0) then + dr=(r2-r1)/nr + ri=(r-r1)/dr + else ! we have data at a single radius + dr=0 + ri=0 + end if + irad=nint(ri) + efield%radius=abs(r1+irad*dr) ! here store actual radius + if (abs(ri-irad).gt.tiny.or. & + & irad.lt.0.or.irad.gt.nr) then + if (idproc.eq.0) then + print *,"<*** ERROR ***> in ",estrng,":" + print *," desired radius ",r," does not appear in ",fname + print *," r1, r2, nr, dr = ",r1,r2,nr,dr + print *," ri, irad = ",ri,irad + print *," exiting now..." + end if + call myexit + else + print *,"extracting E-field data a radius ",efield%radius + end if + + ! read field data at desired radius + if (idproc.eq.0) then + dz=(z2-z1)/nz + do iz=0,nz + ! skip inner radii + do ir=0,irad-1 + read(iu,*) ez + end do + ! read and store next value (but don't duplicate boundary) + read(iu,*) ez + izt=nztot+iz ! overwrites last value at file boundary (iz=0) + efield%zvals(izt)=z1+iz*dz + efield%Ezdata(izt)=ez + ! skip outer radii + do ir=irad+1,nr + read(iu,*) ez + end do + end do + close(iu) + end if + nztot=nztot+nz + + end do ! loop over nfile + efield%nz_intrvl = nztot + + ! check (zmin,zmax) v. (zi,zf) + if (zi.eq.0.d0.and.zf.eq.0.d0) then + ! assign zi and zf from file + zi=efield%zmin + zf=efield%zmax + else if (abs((zf-zi)-(efield%zmax-efield%zmin)).lt.eps) then + ! shift data + dz=zi-efield%zmin + if (dz.ne.0.d0) then + if (idproc.eq.0) then + do iz=0,nztot + efield%zvals(iz)=efield%zvals(iz)+dz + end do + end if + efield%zmin=efield%zmin+dz + efield%zmax=efield%zmax+dz + end if + ! at this point, zi.eq.efield%zmin + ! and zf lies within eps of efield%zmax + if (zf.gt.efield%zmax) zf=efield%zmax + else if ((zf-zi).gt.(efield%zmax-efield%zmin)) then + ! complain, and assign zi and zf from file + if (idproc.eq.0) then + print *," <*** WARNING ***> from ",estrng + print *," desired z-range [",zi,",",zf,"]" + print *," is incompatible with the data in file(s) ",fn + print *," using z-range [",efield%zmin,",",efield%zmax,"]" + end if + zi=efield%zmin + zf=efield%zmax + else + ! deal with cases (zf-zi).lt.(efield%zmax-efield%zmin) + if (zi.lt.efield%zmin) then + if (idproc.eq.0) then + print *," <*** WARNING ***> from ",estrng + print *," changing desired z-range from [",zi,",",zf,"]" + print *," to [",efield%zmin,",",zf,"]" + end if + zi=efield%zmin + else if (zf.lt.efield%zmax) then + if (idproc.eq.0) then + print *," <*** WARNING ***> from ",estrng + print *," changing desired z-range from [",zi,",",zf,"]" + print *," to [",zi,",",efield%zmin,"]" + end if + zf=efield%zmax + end if + end if + + ! write E-field(s) at radius r + if (idproc.eq.0) then + if (jf.ne.0) then + do iz=0,nztot + write(jf,*) efield%zvals(iz),efield%Ezdata(iz) + end do + end if + end if + + ! broadcast E-field information to other processors + ! zmin,zmax,nz_intrvl,freq,w_ovr_c already done; + ! need to broadcast just zvals and Ezdata + call MPI_BCAST(efield%zvals(0),efield%nz_intrvl+1, & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(efield%Ezdata(0),efield%nz_intrvl+1, & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + + end subroutine read_efield_ez +! +!*********************************************************************** + subroutine comp_charfn(efield,kmx,nk_intrvl,kfile,e0) +! Compute the characteristic function \tilde{e}_0(k) from a given set +! of electric field data at radius r. + use math_consts + use phys_consts + use parallel, only : idproc + implicit none + type (Efield_data), intent(in) :: efield + double precision, intent(in) :: kmx ! maximum value of k + integer, intent(in) :: nk_intrvl ! number of intervals in k + integer, intent(in) :: kfile ! file unit number for output of e0 + type (charfn), intent(out) :: e0 +!-----!----------------------------------------------------------------! + double precision, parameter :: tiny=1.d-6 + integer :: ik,iz,izb,izt + double precision :: bessR,ei,er,invrt2pi + double precision :: k,kapsq,klsq,kR,dz,dz1 + double precision, dimension(1) :: bv +cccccc +c if (idproc.eq.0) then +c print *,"(comp_charfn): ..." +c end if +cccccc + e0%nk_intrvl=nk_intrvl + e0%w_ovr_c=twopi*efield%freq/c_light + e0%kmax=kmx + e0%dk=kmx/nk_intrvl + klsq=e0%w_ovr_c**2 + invrt2pi=1.d0/sqrt(twopi) + + ! allocate memory for e0%e0r and e0%e0i + ! deallocate old data, then allocate space we need + ! === not sure this is the best approach (DTA) === + if(associated(e0%e0r)) deallocate(e0%e0r) + if(associated(e0%e0i)) deallocate(e0%e0i) + allocate(e0%e0r(0:nk_intrvl)) + allocate(e0%e0i(0:nk_intrvl)) + e0%e0r=0.d0 + e0%e0i=0.d0 + + ! dz may not be uniform across the E-field data files, but the + ! filon integrator requires dz = constant: perform z integration + ! in discrete sections + izt=0 ! top index of current section + + do while (izt < efield%nz_intrvl) + ! set izb, and initialize search for next izt + izb=izt; izt=izb+1 + dz=efield%zvals(izt)-efield%zvals(izb) + do while (izt.lt.efield%nz_intrvl.and. & + & dabs(efield%zvals(izt+1)-efield%zvals(izt)-dz).lt.tiny) + izt=izt+1 + end do + ! compute real and imaginary parts of e0(k), k in [0,kmax] +cccccc +c if (idproc.eq.0) then +c print *,"iz-range:",izb,izt,"(",izt-izb+1,")" +c end if +cccccc + do ik=0,nk_intrvl + k=ik*e0%dk + call besselR0(k,e0%w_ovr_c,efield%radius,bessR) + call filon_io(efield%zvals,efield%Ezdata,k, & + & izb,izt-izb+1,ei,er) + e0%e0r(ik)=e0%e0r(ik)+invrt2pi*er/bessR + e0%e0i(ik)=e0%e0i(ik)-invrt2pi*ei/bessR + end do ! loop over k + end do ! loop over sections w/ dz=constant + + ! if asked, write characteristic function to file + if (idproc.eq.0.and.kfile.ne.0) then + write(kfile,*) "# ",e0%nk_intrvl + write(kfile,*) "# ",e0%w_ovr_c + write(kfile,*) "# ",e0%kmax,e0%dk + do ik=0,nk_intrvl + k=ik*e0%dk + write(kfile,*) k,e0%e0r(ik),e0%e0i(ik) + end do + end if +! + end subroutine comp_charfn +! +!*********************************************************************** + subroutine read_charfn(iu,e0) +! Read characteristic function from file. + use parallel + implicit none + integer, intent(in) :: iu ! file unit number for data file + type (charfn), intent(out) :: e0 ! characteristic function +!-----!----------------------------------------------------------------! + character(26), parameter :: estrng="e_gengrad_mod::read_charfn" + character(90) :: string + integer :: ierr,ik,ist,len,myerr + real*8 :: k + +! if (idproc.eq.0) then +! print *," reading characteristic functions ..." +! end if + + ! check file unit number + ! NB: only PE0 knows the argument iu + myerr=0 + if (idproc.eq.0) then + if (iu.eq.0) then + myerr=1 + write(6,*) "<*** ERROR ***> in ",estrng,": iu=0" + write(6,*) '<**ERROR**> e_gengrad_mod::read_charfn: iu=0' + endif + endif + call ibcast(myerr) + if (myerr.ne.0) call myexit() + + ! read characteristic function from file + ! first read and broadcast parameters from top three lines + ! (skipping possible comment character '#' at start of line) + if (idproc.eq.0) then + read(iu,'(a)') string + len=len_trim(string) + ist=index(trim(string),'#') + read(string(ist+1:len),*) e0%nk_intrvl + read(iu,'(a)') string + len=len_trim(string) + ist=index(trim(string),'#') + read(string(ist+1:len),*) e0%w_ovr_c + read(iu,'(a)') string + len=len_trim(string) + ist=index(trim(string),'#') + read(string(ist+1:len),*) e0%kmax,e0%dk + end if + call MPI_BCAST(e0%nk_intrvl,1, & + & MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(e0%w_ovr_c,1, & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(e0%kmax,1, & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(e0%dk,1, & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + ! allocate arrays + if(associated(e0%e0r)) deallocate(e0%e0r) + if(associated(e0%e0i)) deallocate(e0%e0i) + allocate(e0%e0r(0:e0%nk_intrvl)) + allocate(e0%e0i(0:e0%nk_intrvl)) + ! then read data and close file + if (idproc.eq.0) then + do ik=0,e0%nk_intrvl + read(iu,*) k,e0%e0r(ik),e0%e0i(ik) + end do + close(iu) + end if + ! broadcast char. fn. information to other processors + call MPI_BCAST(e0%e0r(0:e0%nk_intrvl),(e0%nk_intrvl+1), & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(e0%e0i(0:e0%nk_intrvl),(e0%nk_intrvl+1), & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) +! + end subroutine read_charfn +! +!*********************************************************************** + subroutine comp_egengrads(iu,e0,zi,zf,nz_intrvl) +! Compute electric field generalized gradients and write to unit iu. +! [NB: currently handles only azimuthally symmetric case.] + use math_consts + use phys_consts + use parallel, only : idproc + implicit none + integer, intent(in) :: iu ! file unit number for output + type (charfn), intent(in) :: e0 + double precision, intent(in) :: zi,zf ! initial and final z + integer, intent(in) :: nz_intrvl ! number of z intervals +!-----!----------------------------------------------------------------! + double precision, parameter :: tiny=1.d-6 + integer :: ik,iz,j,nkpts + double precision :: rt2ovrpi,z + double precision :: cosint,sinint + double precision, allocatable, dimension(:) :: kvals,sk,skj,skjr, & + & integrand +cccccc +c if (idproc.eq.0) then +c print *,"(comp_egengrads): ..." +c end if + print *,idproc,": (comp_egengrads): ..." +cccccc + ! initialize constants in eggrdata + eggrdata%maxj=max_j + eggrdata%maxm=0 + eggrdata%zmin=zi + eggrdata%zmax=zf + eggrdata%nz_intrvl=nz_intrvl + eggrdata%dz=(zf-zi)/nz_intrvl + eggrdata%angfrq=e0%w_ovr_c*c_light +cccccc +c if (idproc.eq.0) then +c print *," allocating memory for zvals and gen.grad. arrays..." +c end if + print *," proc.",idproc, & + & ": allocating memory for zvals and gen.grad. arrays..." +cccccc + ! allocate memory for eggrdata%{zvals,G1c,G3c} + ! deallocate old data, then allocate space we need + ! === not sure this is the best approach (DTA) === + if(associated(eggrdata%zvals)) deallocate(eggrdata%zvals) + if(associated(eggrdata%G1c)) deallocate(eggrdata%G1c) + !if(associated(eggrdata%G2c)) deallocate(eggrdata%G2c) + if(associated(eggrdata%G3c)) deallocate(eggrdata%G3c) + allocate(eggrdata%zvals(0:nz_intrvl+rkxtra)) + allocate(eggrdata%G1c(0:nz_intrvl+rkxtra,1:eggrdata%maxj, & + & 0:eggrdata%maxm)) + !allocate(eggrdata%G2c(0:nz_intrvl+rkxtra,1:eggrdata%maxj,0:0)) + allocate(eggrdata%G3c(0:nz_intrvl+rkxtra,0:eggrdata%maxj, & + & 0:eggrdata%maxm)) +cccccc +c if (idproc.eq.0) then +c print *,": done allocating zvals and gen.grad. arrays..." +c end if + print *," proc.",idproc, & + & ": done allocating zvals and gen.grad. arrays..." +cccccc + + ! define scalar variables we need + nkpts=e0%nk_intrvl+1 + rt2ovrpi=sqrt(2.d0/pi) + + ! allocate vectors we need + allocate(kvals(0:e0%nk_intrvl)) + allocate(sk(0:e0%nk_intrvl)) + allocate(skj(0:e0%nk_intrvl)) + allocate(skjr(0:e0%nk_intrvl)) + allocate(integrand(0:e0%nk_intrvl)) + + ! initialize vectors + do ik=0,e0%nk_intrvl + kvals(ik)=ik*e0%dk + end do + sk=kvals**2-e0%w_ovr_c**2 + skj=1.d0 + + ! compute generalized gradients + call zs_adam11(zi,zf,nz_intrvl,eggrdata%zvals) + if (idproc.eq.0) then + print *," Computing E-field generalized gradients ..." + end if + do j=0,eggrdata%maxj + if (j.ne.0) then + ! compute Crc(0,j,z) = eggrdata%G1c(z,j,0) + if (idproc.eq.0) then + print *," ... Crc(0,",j,",z)" + end if + skjr=j*kvals*skj + integrand=skjr*e0%e0r + do iz=0,nz_intrvl+rkxtra + z=eggrdata%zvals(iz) + call filon_io(kvals,integrand,z,0,nkpts,sinint,cosint) + eggrdata%G1c(iz,j,0)=sinint + end do + integrand=skjr*e0%e0i + do iz=0,nz_intrvl+rkxtra + z=eggrdata%zvals(iz) + call filon_io(kvals,integrand,z,0,nkpts,sinint,cosint) + eggrdata%G1c(iz,j,0)=rt2ovrpi*(eggrdata%G1c(iz,j,0)+cosint) + end do + end if + ! compute Czc(0,j,z) = eggrdata%G3c(z,j,0) + if (idproc.eq.0) then + print *," ... Czc(0,",j,",z)" + end if + if (j.ne.0) then + skj=skj*sk + end if + integrand=skj*e0%e0r + do iz=0,nz_intrvl+rkxtra + z=eggrdata%zvals(iz) + call filon_io(kvals,integrand,z,0,nkpts,sinint,cosint) + eggrdata%G3c(iz,j,0)=cosint + end do + integrand=skj*e0%e0i + do iz=0,nz_intrvl+rkxtra + z=eggrdata%zvals(iz) + call filon_io(kvals,integrand,z,0,nkpts,sinint,cosint) + eggrdata%G3c(iz,j,0)=rt2ovrpi*(eggrdata%G3c(iz,j,0)-sinint) + end do + end do ! loop over j + + ! write generalized gradients to file + if(idproc.eq.0.and.iu.ne.0) then + write(iu,*) "# ",eggrdata%nz_intrvl,eggrdata%maxj,eggrdata%maxm + write(iu,*) "# ",eggrdata%zmin,eggrdata%zmax,eggrdata%dz + write(iu,*) "# ",eggrdata%angfrq + do iz=0,nz_intrvl+rkxtra + z=eggrdata%zvals(iz) + write(iu,*) z,eggrdata%G3c(iz,0,0), & + & (eggrdata%G1c(iz,j,0),eggrdata%G3c(iz,j,0), & + & j=1,eggrdata%maxj) + end do + end if + + ! write z, Ez, dEz/dz + !if(idproc.eq.0.and.iude.ne.0) then + if(idproc.eq.0) then + do iz=0,nz_intrvl+rkxtra + write(81,*) z,eggrdata%G3c(iz,0,0),-eggrdata%G1c(iz,1,0) + ! write(81,'(3(1x,1pe22.15))') z,eggrdata%G3c(iz,0,0), & + !& -eggrdata%G1c(iz,1,0) + end do + end if + + ! clean up + deallocate(kvals) + deallocate(sk) + deallocate(skj) + deallocate(skjr) + deallocate(integrand) +! + end subroutine comp_egengrads +! +!*********************************************************************** + subroutine read_egengrads(iu) +! Read generalized gradients from file. + use parallel + implicit none + integer, intent(in) :: iu ! file unit number for data file +!-----!----------------------------------------------------------------! + character(29), parameter :: estrng="e_gengrad_mod::read_egengrads" + character(90) :: string + integer :: ierr,ist,iz,j,len,myerr + double precision :: z + + if (idproc.eq.0) then + print *," reading generalized gradients ..." + end if + + ! check file unit number + ! NB: only PE0 knows the argument iu + myerr=0 + if (idproc.eq.0) then + if (iu.eq.0) then + myerr=1 + write(6,*) "<*** ERROR ***> in ",estrng,": iu=0" + endif + endif + call ibcast(myerr) + if (myerr.ne.0) call myexit() + + ! read generalized gradients from file + ! first read and broadcast parameters from top three lines + ! (skipping possible comment character '#' at start of line) + if(idproc.eq.0.and.iu.ne.0) then + read(iu,'(a)') string + len=len_trim(string) + ist=index(trim(string),'#') + read(string(ist+1:len),*) eggrdata%nz_intrvl,eggrdata%maxj, & + & eggrdata%maxm + read(iu,'(a)') string + len=len_trim(string) + ist=index(trim(string),'#') + read(string(ist+1:len),*) eggrdata%zmin,eggrdata%zmax, & + & eggrdata%dz + read(iu,'(a)') string + len=len_trim(string) + ist=index(trim(string),'#') + read(string(ist+1:len),*) eggrdata%angfrq + end if + call MPI_BCAST(eggrdata%nz_intrvl,1, & + & MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(eggrdata%maxj,1, & + & MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(eggrdata%maxm,1, & + & MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(eggrdata%zmin,1, & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(eggrdata%zmax,1, & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(eggrdata%dz,1, & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(eggrdata%angfrq,1, & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + ! allocate arrays + if(associated(eggrdata%zvals)) deallocate(eggrdata%zvals) + if(associated(eggrdata%G3c)) deallocate(eggrdata%G3c) + if(associated(eggrdata%G1c)) deallocate(eggrdata%G1c) + allocate(eggrdata%zvals(0:eggrdata%nz_intrvl+rkxtra)) + allocate(eggrdata%G1c(0:eggrdata%nz_intrvl+rkxtra, & + & 1:eggrdata%maxj,0:eggrdata%maxm)) + allocate(eggrdata%G3c(0:eggrdata%nz_intrvl+rkxtra, & + & 0:eggrdata%maxj,0:eggrdata%maxm)) + ! then read data and close file + if(idproc.eq.0.and.iu.ne.0) then + do iz=0,eggrdata%nz_intrvl+rkxtra + read(iu,*) eggrdata%zvals(iz),eggrdata%G3c(iz,0,0), & + & (eggrdata%G1c(iz,j,0),eggrdata%G3c(iz,j,0), & + & j=1,eggrdata%maxj) + end do + close(iu) + end if + ! broadcast gen. grad. information to other processors + call MPI_BCAST(eggrdata%zvals(0:eggrdata%nz_intrvl+rkxtra), & + & (eggrdata%nz_intrvl+rkxtra+1), & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(eggrdata%G1c(0:eggrdata%nz_intrvl+rkxtra, & + & 1:eggrdata%maxj,0:0), & + & (eggrdata%nz_intrvl+rkxtra+1)*(eggrdata%maxj), & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(eggrdata%G3c(0:eggrdata%nz_intrvl+rkxtra, & + & 0:eggrdata%maxj,0:0), & + & (eggrdata%nz_intrvl+rkxtra+1)*(eggrdata%maxj+1), & + & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) +! + end subroutine read_egengrads +! +!*********************************************************************** + subroutine besselR0(k,kl,r,b) +! Compute, the values for the order zero "Bessel" function +! R_0(k,kl,r) := { J_0(sqrt(|k^2-kl^2|)*r), sgn(k^2-kl^2) < 0; +! { I_0(sqrt(|k^2-kl^2|)*r), otherwise. +! In words, R_0 switches from the regular to the modified Bessel +! function of the first kind as |k| crosses |kl|. + implicit none + double precision, intent(in) :: k,kl,r + double precision, intent(out) :: b +!-----!----------------------------------------------------------------! + double precision :: kapsq,kR + double precision, dimension(1) :: bv +! + kapsq=k**2-kl**2 + if (kapsq.lt.0.d0) then ! regular Bessel function + kR=sqrt(-kapsq)*r + call dbessj0(kR,b) + else ! modified Bessel function + kR=sqrt(kapsq)*r + call BESSIn(1,0,kR,bv,1) + b=bv(1) + endif +! + end subroutine besselR0 +! +!*********************************************************************** + subroutine besselR(m,k,kl,r,bv) +! Compute, for integer orders 0...m, values for the "Bessel" +! function R_m(k,kl,r) := { J_m(sqrt(|k^2-kl^2|)*r), sgn(k^2-kl^2) < 0; +! { I_m(sqrt(|k^2-kl^2|)*r), otherwise. +! In words, R_m switches from the regular to the modified Bessel +! function of the first kind as |k| crosses |kl|. + implicit none + integer, intent(in) :: m ! desired orders 0...m-1 + double precision, intent(in) :: k,kl,r + double precision, dimension(:), intent(out) :: bv ! bv(0:m) +!-----!----------------------------------------------------------------! + double precision :: kapsq,kR + double precision, dimension(:), allocatable :: bessR +! + allocate(bessR(m+1)) +! + kapsq=k**2-kl**2 + if (kapsq.lt.0.d0) then ! regular Bessel function + kR=sqrt(-kapsq)*r + call dbessjm(m+1,kR,bessR) + else ! modified Bessel function + kR=sqrt(kapsq)*r + call BESSIn(m+1,0,kR,bv,1) ! unscaled I_0 ... I_m + bessR=bv(1) + endif + bv=bessR +! + deallocate(bessR) +! + end subroutine besselR +! +!*********************************************************************** + subroutine filon_io(xn,fn,k,io,npts,sinint,cosint) +! +! Generic Filon integrator---array version with variable index origin: +! This subroutine uses Filon's method to evaluate the integrals from +! xn(io) to xn(io+npts-1) of +! +! fn(x) sin k*x dx +! and fn(x) cos k*x dx +! +! where fn is also an array of length npts with the same index origin +! io. Filon's method allows one to evaluate the integral of an +! oscillating function without having to follow every wiggle with many +! evaluation points. This version has only a single frequency, k. +! (See F.B.Hildebrand, Introduction to Numerical Analysis, 2nd ed., +! McGraw-Hill, 1974 (Dover reprint, 1987), Sect. 3.10. See, also, +! Abramowitz & Stegun, p.890.) For k=0, the cosine integral reduces to +! the extended form of Simpson's rule. +! +! NB: The input array xn must have equally spaced points. Moreover, it +! should contain an _odd_ number of points---or an even number of +! intervals. (If xn contains an even number of points, the rightmost +! point is ignored.) Also note that the usual definitions of Filon's +! formulas use index origin zero, so that the evaluation points are +! {x_0, x_1, ..., x_2n}. But many Fortran arrays have index origin +! one, which means the "even" points are those indexed 1, 3, 5, ..., +! while the "odd" points are those indexed 2, 4, 6, .... Sigh, ...! +! The implementation given here allows for an arbitrary index origin. +! +! Written by Peter Walstrom. +! Jan.2005 (DTA): Rewritten so that one may integrate over a portion +! of the data range. Also changed to implicit none. +!-----!----------------------------------------------------------------! + use parallel, only : idproc + implicit none +! +! arguments + double precision, dimension(0:), intent(in) :: xn,fn + double precision, intent(in) :: k + integer, intent(in) :: npts,io + double precision, intent(out) :: sinint,cosint +! +! local variables + double precision, parameter :: half=0.5d0,one=1.d0,zero=0.d0 + integer :: ii,ix,istart,iend,ievod,npoints + double precision :: h,theta,alf,bet,gam + double precision :: kx,coskx,sinkx,f,wt + double precision, dimension(3) :: dsinint,dcosint +! +! check parity of npts; if even, emit warning and reduce it by 1 + npoints=npts + if (2*(npts/2).eq.npts) then + if (idproc.eq.0) then + write(6,*) '<*** WARNING ***> from subroutine filon_io():' + write(6,*) ' must have an odd number of data points;' + write(6,*) ' ignoring last point!' + end if + npoints=npts-1 + end if +! +! set array endpoints + istart=io + iend=io+npoints-1 +! +! note step-size and get Filon weights + h=xn(istart+1)-xn(istart) + theta=h*k + call filon_wts(theta,alf,bet,gam) +c if (idproc.eq.0) then +c write(*,200) "filon weights:",theta,alf,bet,gam +c end if +c 200 format(1x,4(1pd11.4,1x)) +! +! initialize intermediate arrays to zero + do ievod=1,3 + dsinint(ievod)=zero + dcosint(ievod)=zero + end do +! +! perform Filon integration: +! +! ievod=1 --> odd points +! ievod=2 --> even points +! ievod=3 --> end points + ievod=2 + do ix=istart,iend + wt=one + if(ix.eq.istart.or.ix.eq.iend) wt=half + kx=k*xn(ix) + f=wt*fn(ix) + sinkx=dsin(kx) + coskx=dcos(kx) + dsinint(ievod)=dsinint(ievod)+f*sinkx + dcosint(ievod)=dcosint(ievod)+f*coskx + if(ievod.eq.2) then + ievod=1 + else + ievod=2 + endif + end do +! end points (upper end first) + do ii=1,2 + if(ii.eq.1) then + ix=iend + wt=one + else + ix=istart + wt=-one + endif + kx=k*xn(ix) + f=wt*fn(ix) + dsinint(3)=dsinint(3)-f*dcos(kx) + dcosint(3)=dcosint(3)+f*dsin(kx) + end do +! now sum the Filon-weighted contributions from ievod=1,2,3 + sinint=h*(alf*dsinint(3)+bet*dsinint(2)+gam*dsinint(1)) + cosint=h*(alf*dcosint(3)+bet*dcosint(2)+gam*dcosint(1)) +! + return + end subroutine filon_io +! +!*********************************************************************** + subroutine zs_adam11(zmin,zmax,nzsteps,zvals) +! Compute for given (zmin,zmax,nzsteps) the z-values required by adam11 +! Note: This routine requires size(zvals) >= nzsteps+rkxtra. + implicit none + double precision, intent(in) :: zmin,zmax ! end-points in z + integer, intent(in) :: nzsteps ! number of z integration steps + double precision, dimension(0:), intent(out) :: zvals +!-----!----------------------------------------------------------------! + double precision, dimension(7) :: rkvec + integer :: ih,ir,iz,nzvals + double precision :: dz,hq,z +c + ! define the step-size fractions used in the initial Runge-Kutta + ! steps required by the 11th-order Adams integration routine + rkvec(1)=0.d0 + rkvec(2)=1.d0/9.d0 + rkvec(3)=1.d0/6.d0 + rkvec(4)=1.d0/3.d0 + rkvec(5)=1.d0/2.d0 + rkvec(6)=2.d0/3.d0 + rkvec(7)=5.d0/6.d0 +c + ! compute z values + dz=(zmax-zmin)/nzsteps + hq=dz/5.d0 + nzvals=-1 + do iz=0,nzsteps + if (iz.lt.9) then + do ih=0,4 + do ir=1,7 + nzvals=nzvals+1 + zvals(nzvals)=zmin+iz*dz+(ih+rkvec(ir))*hq + end do + end do + else + nzvals=nzvals+1 + zvals(nzvals)=zmin+iz*dz + endif + end do +cccccc +c write(6,*) "size(zvals)=",size(zvals) +c write(6,*) "zmin, zmax, nzsteps =",zmin,zmax,nzsteps +c write(6,*) "dz, hq =",dz,hq +c do iz=0,nzvals +c write(6,*) iz,zvals(iz) +c end do +cccccc + return + end subroutine zs_adam11 + + end module e_gengrad + diff --git a/OpticsJan2020/MLI_light_optics/Src/ebcomp.f b/OpticsJan2020/MLI_light_optics/Src/ebcomp.f new file mode 100644 index 0000000..eb971e6 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/ebcomp.f @@ -0,0 +1,1138 @@ +************************************************************************ + function angle(x,y) +c +c compute the angle defined by the points (x,y), (0,0), and (1,0) +c returns a value in [0,twopi) +c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! + use math_consts + implicit none + double precision angle,x,y + double precision t +c + t=datan2(y,x) + if(t.lt.0.d0) t=t+twopi + angle=t +c + return + end +c +************************************************************************ + subroutine cegengrad(fnin,ftype,infiles,nfile,kfile,jfile, & + & zi,zf,nz,f,r,kmx,nk,nprec) +c +c Compute generalized gradients for an rf cavity. + use parallel, only : idproc + use math_consts + use phys_consts + use e_gengrad + implicit none + character(80), intent(in) :: fnin ! filename or base filename + character(8), intent(in) :: ftype ! file type + integer, intent(in) :: infiles ! number of input files + integer, intent(in) :: nfile ! file unit number for output + integer, intent(in) :: kfile ! file unit number for output of e0 + integer, intent(in) :: jfile ! file unit number for output of efld + double precision, intent(inout) :: zi, zf ! initial and final z + integer, intent(in) :: nz ! number of z intervals + double precision, intent(inout) :: f ! cavity frequency + double precision, intent(in) :: r ! extract data at this radius + double precision, intent(in) :: kmx ! maximum wave number k + integer, intent(in) :: nk ! number of k intervals + integer, intent(in) :: nprec ! precision at which to write data +c-----!----------------------------------------------------------------! + type (Efield_data) efield + type (charfn) e0 +c + nullify(efield%zvals) + nullify(efield%Ezdata) + !nullify(efield%Erdata) + !nullify(efield%Btdata) + nullify(e0%e0r) + nullify(e0%e0i) +c + if (trim(ftype).eq."t7") then + call read_efield_t7(fnin,infiles,zi,zf,f,r,efield) + else if (trim(ftype).eq."ez") then + call read_efield_ez(fnin,infiles,jfile,zi,zf,f,r,efield) + else + if (idproc.eq.0) then + write(6,*) "<*** ERROR ***> in ebcomp::cegengrad:" + write(6,*) " File type ",trim(ftype)," not recognized!" + end if + call myexit() + end if + call comp_charfn(efield,kmx,nk,kfile,e0) + call comp_egengrads(nfile,e0,zi,zf,nz) + close(nfile) +c + if(associated(efield%zvals)) deallocate(efield%zvals) + if(associated(efield%Ezdata)) deallocate(efield%Ezdata) + !if(associated(efield%Erdata)) deallocate(efield%Erdata) + !if(associated(efield%Btdata)) deallocate(efield%Btdata) + if(associated(e0%e0r)) deallocate(e0%e0r) + if(associated(e0%e0i)) deallocate(e0%e0i) +c + return + end +c +************************************************************************ + subroutine nlrfcav(zed,zlc,zh,nst,tm,gm,h,mh) +c +c Compute nonlinear map for slice of an rf cavity. + use parallel, only : idproc + use math_consts + use phys_consts + use beamdata + use lieaparam, only : monoms + use e_gengrad + implicit none + double precision, intent(in) :: zed ! z at cavity entrance (edge) + double precision, intent(in) :: zlc ! z at slice entrance + double precision, intent(in) :: zh ! length of slice + integer, intent(in) :: nst ! number of z-steps for this slice + double precision, intent(inout) :: tm ! w_scl*t_g at slice + double precision, intent(inout) :: gm ! rel. gamma at slice + ! Lie generators, h, and linear map, mh, for slice + double precision, dimension(monoms), intent(out) :: h + double precision, dimension(6,6), intent(out) :: mh +c-----!----------------------------------------------------------------! + include 'map.inc' + integer :: i,j + double precision :: betgam,engin,engfin +c + if (idproc.eq.0) then + write (6,*) "ebcomp::nlrfcav" + write (6,*) " ...under construction..." + end if +c +c sanity check + if (zh.le.0.) then + if (idproc.eq.0) then + write(6,*) "<*** ERROR ***> in ebcomp::nlrfcav:" + write(6,*) " The slice length zh (=",zh,") must exceed zero!" + endif + call myexit() + endif +c +c initialize map to identity + do i=1,6 + do j=1,6 + mh(i,j)=0.d0 + end do + mh(i,i)=1.d0 + end do + do i=1,monoms + h(i)=0.d0 + end do +c +c print initial map + !if (idproc.eq.0) then + ! write(6,*) '%%%%%%%%%%%%%%%%%%%%%%%%%%' + ! write(6,*) '==initial transfer map==' + ! write(6,*) ' matrix part:' + ! do i=1,6 + ! write(6,*) (mh(i,j),j=1,6) + ! end do + ! write(6,*) ' nonlinear generators:' + ! do i=1,monoms + ! if (h(i).ne.0.d0) then + ! write(6,*) 'h(',i,')=',h(i) + ! end if + ! end do + ! write(6,*) '%%%%%%%%%%%%%%%%%%%%%%%%%%' + !end if +c + engin=gm*pmass + if (idproc.eq.0) then + write(36,*) arclen,engin + call myflush(36) + endif + if (idproc.eq.0) then + write (6,*) 'calling subroutine mapnlrfcav() ...' + write (6,*) 'zed,zlc,zh,nst,tm,gm=' + write (6,*) zed,zlc,zh,nst,tm,gm + end if + call mapnlrfcav(zed,zlc,zh,nst,tm,gm,h,mh) + if (idproc.eq.0) then + write (6,*) 'returned from subroutine mapnlrfcav() ...' + write (6,*) 'zed,zlc,zh,nst,tm,gm=' + write (6,*) zed,zlc,zh,nst,tm,gm + end if + ! update beamdata: gamma, gamm1, beta, and brho + gamma=gm + gamm1=gamma-1.d0 + betgam=sqrt(gamm1*(gamma+1.d0)) + beta=betgam/gamma + brho=pmass*betgam/c_light + engfin=pmass*gamma + if (idproc.eq.0) then + write(36,*) arclen,engfin + write(36,*) ' ' + call myflush(36) + endif +c + return + end +c +************************************************************************ + subroutine mapnlrfcav(zed,zlc,zh,nst,tm,gm,h,mh) +c +c Compute nonlinear map for slice of an rf cavity. + use parallel, only : idproc + use math_consts + use phys_consts + use beamdata + use lieaparam, only : monoms + use e_gengrad + implicit none + double precision, intent(in) :: zed ! z at cavity entrance (edge) + double precision, intent(in) :: zlc ! z at slice entrance + double precision, intent(in) :: zh ! length of slice + integer, intent(in) :: nst ! number of z-steps for this slice + double precision, intent(inout) :: tm ! w_scl*t_g at slice + double precision, intent(inout) :: gm ! rel. gamma at slice + ! Lie generators, h, and linear map, mh, for slice + double precision, dimension(monoms), intent(inout) :: h + double precision, dimension(6,6), intent(inout) :: mh +c-----!----------------------------------------------------------------! + !!!! module anyone? !!!! + integer iflag + include 'hmflag.inc' + !!!! ^^^^^^^^^^^^^^ !!!! + integer, parameter :: neqn=monoms+15 + integer :: i,j + character(len=6) :: stctd + double precision :: dz + double precision, dimension(neqn) :: y +c + if (idproc.eq.0) then + write (6,*) "ebcomp::mapnlrfcav" + write (6,*) " ...under construction..." + end if +c +c array y comprises the quantities to integrate +c y(1-6) = given (design) trajectory +c y(7-42) = matrix (6x6) +c y(43-98) = f3 coefficients +c y(99-224) = f4 coefficients +c y(225-476) = f5 coefficients +c y(477-938) = f6 coefficients + y=0.d0 +c initialize design trajectory +c x = p_x = y = p_y = 0 +c tau = omega_ref t +c p_tau = -m gamma c^2/(omega_ref sl p_ref) + y(1:4)=0.d0 + y(5)=tm + y(6)=-gm*pmass/(omegascl*sl*p0sc) +c initialize rest to identity + do i=1,6 + y(7*i)=1.d0 + end do +c +c set flag that says "rf cavity" (really!, this approach seems antique) +c the subroutine feval uses this flag to switch to the correct RHSs +c as the differential equations for the map + iflag=5 +c now integrate map equations of motion + !if (zlc.eq.zed) then + ! stctd='start ' + !else + ! stctd='cont ' + !end if + stctd='start ' + dz=zh/nst + if (idproc.eq.0) then + write (6,*) "calling adam11() with arguments" + write (6,*) " eggrdata%dz =",eggrdata%dz + write (6,*) " eggrdata%nz_intrvl =",eggrdata%nz_intrvl + write (6,*) " dz =",dz + write (6,*) " nst =",nst + write (6,*) " stctd =",stctd + write (6,*) " zlc =",zlc + write (6,*) " size(y) =",size(y) + write (6,*) " neqn =",neqn + endif + !call adam11(eggrdata%dz,eggrdata%nz_intrvl,stctd,zlc,y,neqn) + call adam11(dz,nst,stctd,zlc,y,neqn) + write (6,*) "...returned from adam11()" + call errchk(y(7)) + call putmap(y,h,mh) + tm=y(5) + gm=-y(6)*(omegascl*sl*p0sc)/pmass +c + return + end +c +************************************************************************ + subroutine nlrfvecpot(z,y) +c +c Use generalized gradients in eggr to compute vector potential at z. +c The vector potential is multiplied by rf_escale*(e/p_ref). + use parallel, only : idproc + use beamdata, only : sl,p0sc,omegascl,pmass + use math_consts + use phys_consts + use e_gengrad + use curve_fit + implicit none + double precision, intent(in) :: z ! determine vec. pot. here + double precision, intent(in) :: y(:) ! y(1:6)=ref. ptcl. (scaled) +c-----!----------------------------------------------------------------! + include 'map.inc' + integer, save :: iz=0 + integer :: i,j + double precision, parameter :: tiny=2.0d-16 + double precision :: wl,wr,mwr2,phiz,cphiz,sphiz,cfwrl,sfwl + double precision :: sclfac + double precision :: sl2,sl3,sl4,sl5,sl6 + double precision, dimension(:,:), allocatable :: Crc,Czc +c + !if (idproc.eq.0) then + ! write (6,*) "(ebcomp)::nlrfvecpot(",z,")" + ! write (6,*) " ...under construction..." + !end if + + ! allocate temporary arrays + allocate(Crc(0:eggrdata%maxj,0:eggrdata%maxm)) + allocate(Czc(0:eggrdata%maxj,0:eggrdata%maxm)) + +c find index iz ofzvals nearest z (zvals has index origin 0) + call cf_searchNrst(eggrdata%zvals,z,iz,iorigin=0) + if (dabs(eggrdata%zvals(iz)-z).le.tiny) then + Czc(0,0)=eggrdata%G3c(iz,0,0) + do j=1,eggrdata%maxj + Crc(j,0)=eggrdata%G1c(iz,j,0) + Czc(j,0)=eggrdata%G3c(iz,j,0) + end do + else + call cf_polyInterp3(eggrdata%zvals,eggrdata%G3c(:,0,0), + & z,Czc(0,0),iz,iorigin=0) + do j=1,eggrdata%maxj + call cf_polyInterp3(eggrdata%zvals,eggrdata%G1c(:,j,0), + & z,Crc(j,0),iz,iorigin=0) + call cf_polyInterp3(eggrdata%zvals,eggrdata%G3c(:,j,0), + & z,Czc(j,0),iz,iorigin=0) + end do + end if +c compute phase phi(z) and other factors + wl=eggrdata%angfrq + wr=wl/omegascl + mwr2=-wr**2 + phiz=wr*y(5)+rf_phase + cphiz=dcos(phiz); cfwrl=cphiz*wr/wl + sphiz=dsin(phiz); sfwl=sphiz/wl + sl2=sl**2; sl3=sl2*sl; sl4=sl3*sl; sl5=sl4*sl; sl6=sl5*sl +cryneabell:09.Nov.05 + write(44,*) z,phiz,y(5:6),y(7:12) + write(45,*) z,rf_escale*Czc(0,0),-rf_escale*Crc(1,0) +cryneabell---------- +c A_x + vp%Ax(1) = -Crc(1,0)*sfwl*sl/2.d0 + vp%Ax(11) = -Crc(1,0)*cfwrl*sl/2.d0 + vp%Ax(28) = -Crc(2,0)*sfwl*sl3/32.d0 + vp%Ax(39) = vp%Ax(28) + vp%Ax(46) = mwr2*vp%Ax(1)/2.d0 + vp%Ax(88) = -Crc(2,0)*cfwrl*sl3/32.d0 + vp%Ax(122) = vp%Ax(88) + vp%Ax(136) = mwr2*vp%Ax(11)/6.d0 + vp%Ax(210) = -Crc(3,0)*sfwl*sl5/1152.d0 + vp%Ax(221) = 2.d0*vp%Ax(210) + vp%Ax(228) = mwr2*vp%Ax(39)/2.d0 + vp%Ax(301) = vp%Ax(210) + vp%Ax(308) = vp%Ax(228) + vp%Ax(331) = mwr2*vp%Ax(46)/12.d0 + vp%Ax(466) = -Crc(3,0)*cfwrl*sl5/1152.d0 + vp%Ax(500) = 2.d0*vp%Ax(466) + vp%Ax(514) = mwr2*vp%Ax(122)/6.d0 + vp%Ax(660) = vp%Ax(466) + vp%Ax(674) = vp%Ax(514) + vp%Ax(708) = mwr2*vp%Ax(136)/20.d0 +c A_y + vp%Ay(3) = vp%Ax(1) + vp%Ay(20) = vp%Ax(11) + vp%Ay(30) = vp%Ax(28) + vp%Ay(64) = vp%Ax(39) + vp%Ay(71) = vp%Ax(46) + vp%Ay(97) = vp%Ax(88) + vp%Ay(177) = vp%Ax(122) + vp%Ay(191) = vp%Ax(136) + vp%Ay(212) = vp%Ax(210) + vp%Ay(246) = vp%Ax(221) + vp%Ay(253) = vp%Ax(228) + vp%Ay(406) = vp%Ax(301) + vp%Ay(413) = vp%Ax(308) + vp%Ay(436) = vp%Ax(331) + vp%Ay(475) = vp%Ax(466) + vp%Ay(555) = vp%Ax(500) + vp%Ay(569) = vp%Ax(514) + vp%Ay(842) = vp%Ax(660) + vp%Ay(856) = vp%Ax(674) + vp%Ay(890) = vp%Ax(708) +c A_z + vp%Az(0) = -Czc(0,0)*sfwl + vp%Az(5) = -Czc(0,0)*cfwrl + vp%Az(7) = -Czc(1,0)*sfwl*sl2/4.d0 + vp%Az(18) = vp%Az(7) + vp%Az(25) = mwr2*vp%Az(0)/2.d0 + vp%Az(32) = -Czc(1,0)*cfwrl*sl2/4.d0 + vp%Az(66) = vp%Az(32) + vp%Az(80) = mwr2*vp%Az(5)/6.d0 + vp%Az(84) = -Czc(2,0)*sfwl*sl4/64.d0 + vp%Az(95) = 2.d0*vp%Az(84) + vp%Az(102) = mwr2*vp%Az(18)/2.d0 + vp%Az(175) = vp%Az(84) + vp%Az(182) = vp%Az(102) + vp%Az(205) = mwr2*vp%Az(25)/12.d0 + vp%Az(214) = -Czc(2,0)*cfwrl*sl4/64.d0 + vp%Az(248) = 2.d0*vp%Az(214) + vp%Az(262) = mwr2*vp%Az(66)/6.d0 + vp%Az(408) = vp%Az(214) + vp%Az(422) = vp%Az(262) + vp%Az(456) = mwr2*vp%Az(80)/20.d0 + vp%Az(462) = -Czc(3,0)*sfwl*sl6/2304.d0 + vp%Az(473) = 3.d0*vp%Az(462) + vp%Az(480) = mwr2*vp%Az(175)/2.d0 + vp%Az(553) = vp%Az(473) + vp%Az(560) = 2.d0*vp%Az(480) + vp%Az(583) = mwr2*vp%Az(182)/12.d0 + vp%Az(840) = vp%Az(462) + vp%Az(847) = vp%Az(480) + vp%Az(870) = vp%Az(583) + vp%Az(917) = mwr2*vp%Az(205)/30.d0 +c scale vector potential by rf_escale/(p_ref/e) = rf_escale*c/(mc^2/e) + sclfac=rf_escale*c_light/pmass + vp%Ax=sclfac*vp%Ax + vp%Ay=sclfac*vp%Ay + vp%Az=sclfac*vp%Az +c + !if (idproc.eq.0) then + ! write(6,*) "nlrf vector potential components" + ! write(6,*) " =scale factors=" + ! write(6,*) " sclfac =",sclfac + ! write(6,*) " wl, wr =",wl,wr + ! write(6,*) " phiz =",phiz + ! write(6,*) " Crc0j(z) =",(Crc(j,0),j=1,3) + ! write(6,*) " Czc0j(z) =",(Czc(j,0),j=0,3) + ! write(6,*) " =x=" + ! do i=0,monoms + ! if (vp%Ax(i).ne.0.d0) then + ! write(6,*) 'Ax(',i,')=',vp%Ax(i) + ! end if + ! end do + ! write(6,*) " =y=" + ! do i=0,monoms + ! if (vp%Ay(i).ne.0.d0) then + ! write(6,*) 'Ay(',i,')=',vp%Ay(i) + ! end if + ! end do + ! write(6,*) " =z=" + ! do i=0,monoms + ! if (vp%Az(i).ne.0.d0) then + ! write(6,*) 'Az(',i,')=',vp%Az(i) + ! end if + ! end do + !end if +c + ! deallocate temporary arrays + deallocate(Crc) + deallocate(Czc) +c + return + end +c +!*********************************************************************** + subroutine hmltnRF(s,y,h) +! Given longitudinal position s and phase-space coordinates y(1:6) of +! the reference particle, compute an expansion of the Hamiltonian h for +! an RF cavity. +! Based on the approach used in hmltn3 (by F. Neri): compute the +! hamiltonian using a polynomial expansion of the square root. +! (Later, we can use this to test a hard-wired version.) + use math_consts + use phys_consts + use lieaparam, only : monoms + use beamdata + use e_gengrad + use parallel, only : idproc + implicit none + double precision, intent(in) :: s ! longitudinal coordinate + double precision, intent(inout) :: y(:) ! y(1:6)=ref. ptcl. + double precision, intent(out) :: h(:) ! rf cavity Hamiltonian +!-----!----------------------------------------------------------------! +************************************************************************ + interface + subroutine nlrfvecpot(s,y) + implicit none + double precision, intent(in) :: s ! longitudinal coordinate + double precision, intent(in) :: y(:) ! y(1:6)=ref. ptcl. data + end subroutine nlrfvecpot + end interface +************************************************************************ + include 'expon.inc' + integer, parameter :: maxord=6 + integer :: i,j + double precision :: bg,gammag,wlbyc + double precision, dimension(0:maxord) :: a + double precision, dimension(0:monoms) :: pkx1,pky1,pkx2,pky2 + double precision, dimension(0:monoms) :: x,yy +c + !if (idproc.eq.0) then + ! print '(a,1pe16.9,a)',"(ebcomp)::hmltnRF[ s=",s,"]=" + ! do j=1,monoms + ! if(h(j).ne.0.d0) then + ! print '(2x,a,i3,a,1pe16.9,2x,3(2i1,1x))', & + ! &! 'h(',j,')=',h(j),(expon(i,j),i=1,6) + ! end if + ! end do + ! do j=1,monoms + ! if(y(j).ne.0.d0) then + ! print '(2x,a,i3,a,1pe16.9,2x,3(2i1,1x))', & + ! &! 'y(',j,')=',y(j),(expon(i,j),i=1,6) + ! end if + ! end do + !end if +c +c coefficients in expansion of 1-sqrt(1+x) + a(0) = 0.d0 + a(1) = -1.d0/2.d0 + do j=2,maxord + a(j)=a(j-1)*(1.5d0/j-1.d0) + end do +c +c factors + wlbyc=omegascl*sl/c_light + gammag=-wlbyc*y(6) + bg=sqrt((gammag+1.d0)*(gammag-1.d0)) +c +c compute rf cavity vector potential + !write(6,*) "calling nlrfvecpot ..." + call nlrfvecpot(s,y) + !write(6,*) "returned from nlrfvecpot ..." +c +c construct Hamiltonian + pkx1=0.d0; pkx1(2)=1.d0; pkx1=pkx1-vp%Ax + pky1=0.d0; pky1(4)=1.d0; pky1=pky1-vp%Ay + call pmult(pkx1,pkx1,pkx2,maxord) + call pmult(pky1,pky1,pky2,maxord) + x=0.d0; x(6)=-2.d0*gammag*wlbyc; x(27)=wlbyc**2 + x=(x-pkx2-pky2)/(bg**2) +c yy = 1-sqrt(1+x) + call poly1(maxord,a,x,yy,maxord) +c h = {bg*[1-sqrt(1+x)]-Az}/sl, but don't include constant +c or linear terms because we've already removed them + h=0.d0 + do j=7,monoms + h(j)=(bg*yy(j)-vp%Az(j))/sl + end do +c + !if (idproc.eq.0) then + ! print '(a,1pe16.9,a)',"(ebcomp)::hmltnRF[ s=",s,"]=" + ! do j=1,monoms + ! if(h(j).ne.0.d0) then + ! print '(2x,a,i3,a,1pe16.9,2x,3(2i1,1x))', & + ! &! 'h(',j,')=',h(j),(expon(i,j),i=1,6) + ! end if + ! end do + !end if +c + return + end subroutine hmltnRF +c +************************************************************************ + function finterp(x,xx,a,b,c,n) +c +c This subroutine interpolates at x the value of a function described +c by the n-element arrays a, b, and c. These arrays hold the quadratic +c fit parameter determined at the n locations xx by subroutine parfit. +c NB: The values in xx MUST increase (or decrease) monotonically. +c-----!----------------------------------------------------------------! + implicit none + double precision finterp + integer n,k + double precision a(n),b(n),c(n),xx(n),x +c + call locate(xx,n,x,k) + if(k.lt.1) then + k=1 + else if(k.gt.(n-1)) then + k=n-1 + endif + finterp=a(k)+x*(b(k)+x*c(k)) +c + return + end +c +************************************************************************ + function finterA(ang) +c +c This subroutine interpolates in the azimuthal direction a field value +c for some component of E or B. It first uses 'locate' to find where +c ang lies in the array phin; it then uses coefficients determined by +c 'parfit' to interpolate a value for that field component. +c NB: The angles in phin must increase (or decrease) monotonically. +c-----!----------------------------------------------------------------! + include 'impli.inc' + include 'ebdata.inc' +c + call locate(phin,maxna,ang,n) + if(n.lt.1) then + n=1 + else if(n.gt.(maxna-1)) then + n=maxna-1 + endif + finterA=aia(n)+ang*(bia(n)+ang*cia(n)) +c + return + end +c +************************************************************************ + function finterZ(z) +c +c This subroutine interpolates in the longitudinal direction a field +c value for some component of E or B. It first uses 'locate' to find +c where z lies in the array zn; it then uses coefficients determined by +c 'parfit' to interpolate a value for that field component. +c NB: The z's in zn must increase (or decrease) monotonically. +c-----!----------------------------------------------------------------! + include 'impli.inc' + include 'ebdata.inc' +c + call locate(zn,maxnz,z,n) + if(n.lt.1) then + n=1 + else if(n.gt.(maxnz-1)) then + n=maxnz-1 + endif + finterZ=aiz(n)+z*(biz(n)+z*ciz(n)) +c + return + end +c +************************************************************************ + subroutine filonint(xmin,xmax,y,nsteps,fname,sinint,cosint) +c +c Generic Filon integrator: +c This subroutine uses Filon's method to evaluate the integrals from +c xmin to xmax of +c +c fname(x) sin y*x dx +c and fname(x) cos y*x dx +c +c Filon's method allows one to evaluate the integral of an oscillating +c function without having to follow every wiggle with many evaluation +c points. Here the number of function evaluations equals 2*nsteps+3. +c This version has only a single frequency, y. +c (See F.B.Hildebrand, Introduction to Numerical Analysis, 2nd ed., +c McGraw-Hill, 1974 (Dover reprint, 1987), Sect. 3.10. See, also, +c Abramowitz & Stegun, p.890.) For y=0, the cosine integral reduces +c to the extended form of Simpson's rule. +c +c Written by Peter Walstrom. +c-----!----------------------------------------------------------------! + include 'impli.inc' + external fname +c + parameter(half=0.5d0,one=1.d0,zero=0.d0) + dimension dsinint(3),dcosint(3) +c +c compute step-size + h=(xmax-xmin)*half/dfloat(nsteps) +c get Filon weights + theta=h*y + call filon_wts(theta,alf,bet,gam) +c write(20,200) theta,alf,bet,gam +c 200 format(1x,4(1pd11.4,1x)) +c +c initialize intermediate arrays to zero + do 111 ievod=1,3 + dsinint(ievod)=zero + 111 dcosint(ievod)=zero +c +c perform Filon integration: +c +c step through odd, then even, x values + do 2 ievod=1,2 +c ievod=1 --> odd points +c ievod=2 --> even points +c ievod=3 --> end points + nstp=nsteps +c extra x value in set of even points + if(ievod.eq.2) nstp=nsteps+1 + do 2 n=1,nstp + if(ievod.eq.2) go to 3 +c odd points + x=h*dfloat(2*n-1)+xmin + wt=one + go to 4 +c even points + 3 wt=one + if(n.eq.1) wt=half + if(n.eq.nstp) wt=half + x=h*dfloat(2*n-2)+xmin + 4 continue + f=wt*fname(x) + xy=x*y + cosxy=dcos(xy) + sinxy=dsin(xy) + dsinint(ievod)=dsinint(ievod)+f*sinxy + 2 dcosint(ievod)=dcosint(ievod)+f*cosxy +c end points (upper end first) + x=xmax + wt=one + do 5 iend=1,2 + xy=y*x + cosxy=dcos(xy) + sinxy=dsin(xy) + f=wt*fname(x) + dsinint(3)=dsinint(3)-f*cosxy + dcosint(3)=dcosint(3)+f*sinxy + x=xmin + 5 wt=-one +c now sum the Filon-weighted contributions from ievod=1,2,3 + sinint=h*(alf*dsinint(3)+bet*dsinint(2)+gam*dsinint(1)) + cosint=h*(alf*dcosint(3)+bet*dcosint(2)+gam*dcosint(1)) +c + return + end +c +************************************************************************ + subroutine filonarr(xn,fn,y,npts,sinint,cosint) +c +c Generic Filon integrator---array version: +c This subroutine uses Filon's method to evaluate the integrals from +c xn(1) to xn(npts) of +c +c fn(x) sin y*x dx +c and fn(x) cos y*x dx +c +c where fn is also an array of length npts. Filon's method allows one +c to evaluate the integral of an oscillating function without having to +c follow every wiggle with many evaluation points. This version has +c only a single frequency, y. (See F.B.Hildebrand, Introduction to +c Numerical Analysis, 2nd ed., McGraw-Hill, 1974 (Dover reprint, 1987), +c Sect. 3.10. See, also, Abramowitz & Stegun, p.890.) For y=0, the +c cosine integral reduces to the extended form of Simpson's rule. +c +c NB: The input array xn must have equally spaced points. Moreover, it +c should contain an _odd_ number of points. (If xn contains an even +c number of points, the rightmost point is ignored.) Also note that +c the usual definitions of Filon's formulas use index origin zero, so +c that the evaluation points are {x_0, x_1, ..., x_2n}. But the +c implementation below uses index origin one, so that the "even" points +c are those indexed 1, 3, 5, ..., while the "odd" points are those +c indexed 2, 4, 6, .... Sigh, ...! +c +c Written by Peter Walstrom. +c-----!----------------------------------------------------------------! + include 'impli.inc' +c +c calling arrays + parameter(maxpts=4001) + dimension xn(maxpts),fn(maxpts) +c + parameter(half=0.5d0,one=1.d0,zero=0.d0) + dimension dsinint(3),dcosint(3) +c +c +c check parity of npts; if even, reduce it by 1 + npoints=npts + if(2*(npts/2).eq.npts) then + write(6,*) 'WARNING from subroutine filonarr():' + write(6,*) ' must have an odd number of data points;' + write(6,*) ' ignoring last point!' + npoints=npts-1 + endif + nhalf=npoints/2 +c note step-size + h=xn(2)-xn(1) +c get Filon weights + theta=h*y + call filon_wts(theta,alf,bet,gam) +c write(20,200) theta,alf,bet,gam +c 200 format(1x,4(1pd11.4,1x)) +c +c initialize intermediate arrays to zero + do 111 ievod=1,3 + dsinint(ievod)=zero + 111 dcosint(ievod)=zero +c +c perform Filon integration: +c +c step through odd, then even, x values + do 2 ievod=1,2 +c ievod=1 --> odd points +c ievod=2 --> even points +c ievod=3 --> end points + nstp=nhalf +c extra x value in set of even points + if(ievod.eq.2) nstp=nhalf+1 + do 2 n=1,nstp + if(ievod.eq.2) go to 3 +c "odd" points (n=2,4,6,...,npts-1) + x=xn(2*n) + f=fn(2*n) + wt=one + go to 4 +c "even" points (n=1,3,5, ... npts) + 3 wt=one + if(n.eq.1) wt=half + if(n.eq.nstp) wt=half + x=xn(2*n-1) + f=fn(2*n-1) + 4 continue + f=wt*f + xy=x*y + cosxy=dcos(xy) + sinxy=dsin(xy) + dsinint(ievod)=dsinint(ievod)+f*sinxy + 2 dcosint(ievod)=dcosint(ievod)+f*cosxy +c end points (upper end first) + n=npoints + wt=one + do 5 iend=1,2 + x=xn(n) + xy=y*x + cosxy=dcos(xy) + sinxy=dsin(xy) + f=wt*fn(n) + dsinint(3)=dsinint(3)-f*cosxy + dcosint(3)=dcosint(3)+f*sinxy + n=1 + 5 wt=-one +c now sum the Filon-weighted contributions from ievod=1,2,3 + sinint=h*(alf*dsinint(3)+bet*dsinint(2)+gam*dsinint(1)) + cosint=h*(alf*dcosint(3)+bet*dcosint(2)+gam*dcosint(1)) +c + return + end +c +************************************************************************ + subroutine filonarr_io(xn,fn,k,io,npts,sinint,cosint) +c +c Generic Filon integrator---array version with variable index origin: +c This subroutine uses Filon's method to evaluate the integrals from +c xn(io) to xn(io+npts-1) of +c +c fn(x) sin k*x dx +c and fn(x) cos k*x dx +c +c where fn is also an array of length npts with the same index origin +C io. Filon's method allows one to evaluate the integral of an +c oscillating function without having to follow every wiggle with many +c evaluation points. This version has only a single frequency, k. +c (See F.B.Hildebrand, Introduction to Numerical Analysis, 2nd ed., +c McGraw-Hill, 1974 (Dover reprint, 1987), Sect. 3.10. See, also, +c Abramowitz & Stegun, p.890.) For k=0, the cosine integral reduces to +c the extended form of Simpson's rule. +c +c NB: The input array xn must have equally spaced points. Moreover, it +c should contain an _odd_ number of points---or an even number of +c intervals. (If xn contains an even number of points, the rightmost +c point is ignored.) Also note that the usual definitions of Filon's +c formulas use index origin zero, so that the evaluation points are +c {x_0, x_1, ..., x_2n}. But many Fortran arrays have index origin +c one, which means the "even" points are those indexed 1, 3, 5, ..., +c while the "odd" points are those indexed 2, 4, 6, .... Sigh, ...! +c The implementation given here allows for an arbitrary index origin. +c +c Written by Peter Walstrom. +c Jan.2005 (DTA): Modified to allow for arbitrary index origin, and +c changed to implicit none. +c-----!----------------------------------------------------------------! + implicit none +c +c arguments + double precision, dimension(:), intent(in) :: xn,fn + double precision, intent(in) :: k + integer, intent(in) :: npts,io + double precision, intent(out) :: sinint,cosint +c +c local variables + double precision, parameter :: half=0.5d0,one=1.d0,zero=0.d0 + integer :: ii,ix,istart,iend,ievod,npoints + double precision :: h,theta,alf,bet,gam + double precision :: kx,coskx,sinkx,f,wt + double precision, dimension(3) :: dsinint,dcosint +c +c check parity of npts; if even, emit warning and reduce it by 1 + npoints=npts + if(2*(npts/2).eq.npts) then + write(6,*) '<*** WARNING ***> from subroutine filonarr():' + write(6,*) ' must have an odd number of data points;' + write(6,*) ' ignoring last point!' + npoints=npts-1 + endif +c +c set array endpoints + istart=io + iend=io+npoints-1 +c note step-size and get Filon weights + h=xn(istart+1)-xn(istart) + theta=h*k + call filon_wts(theta,alf,bet,gam) +c write(*,200) "filon weights:",theta,alf,bet,gam +c 200 format(1x,4(1pd11.4,1x)) +c +c initialize intermediate arrays to zero + do ievod=1,3 + dsinint(ievod)=zero + dcosint(ievod)=zero + end do +c +c perform Filon integration: +c +c ievod=1 --> odd points +c ievod=2 --> even points +c ievod=3 --> end points + ievod=2 + do ix=istart,iend + wt=one + if(ix.eq.istart.or.ix.eq.iend) wt=half + kx=k*xn(ix) + f=wt*fn(ix) + sinkx=dsin(kx) + coskx=dcos(kx) + dsinint(ievod)=dsinint(ievod)+f*sinkx + dcosint(ievod)=dcosint(ievod)+f*coskx + if(ievod.eq.2) then + ievod=1 + else + ievod=2 + endif + end do +c end points (upper end first) + do ii=1,2 + if(ii.eq.1) then + ix=iend + wt=one + else + ix=istart + wt=-one + endif + kx=k*xn(ix) + f=wt*fn(ix) + dsinint(3)=dsinint(3)-f*dcos(kx) + dcosint(3)=dcosint(3)+f*dsin(kx) + end do +c now sum the Filon-weighted contributions from ievod=1,2,3 + sinint=h*(alf*dsinint(3)+bet*dsinint(2)+gam*dsinint(1)) + cosint=h*(alf*dcosint(3)+bet*dcosint(2)+gam*dcosint(1)) +c + return + end +c +************************************************************************ + subroutine filon_wts(theta,alpha,beta,gamma) +c +c This subroutine computes the weights for Filon's integration method. +c-----!----------------------------------------------------------------! + implicit none +c +c arguments + double precision :: theta + double precision :: alpha,beta,gamma +c +c local variables + double precision, parameter :: a1=2.d0/4.5d1,a2=2.d0/3.15d2, & + & a3=2.d0/4.725d3,a4=8.d0/4.67775d5 + double precision, parameter :: b0=2.d0/3.d0,b1=2.d0/1.5d1, & + & b2=4.d0/1.05d2,b3=2.d0/5.67d2, & + & b4=4.d0/2.2275d4,b5=4.d0/6.75675d5 + double precision, parameter :: c0=4.d0/3.0d0,c1=2.d0/1.5d1, & + & c2=1.d0/2.1d2,c3=1.d0/1.134d4, & + & c4=1.d0/9.9792d5,c5=1.d0/1.297296d8 + double precision, parameter :: one=1.d0,two=2.d0,smal1=1.d-1 + double precision :: t2,t3 + double precision :: onoth,tuoth2,costh,sinc,cs +c +c small-angle approximation + if(dabs(theta).gt.smal1) go to 11 + t2=theta**2 + t3=theta*t2 + alpha=t3*(a1-t2*(a2-t2*(a3-t2*a4))); + beta=b0+t2*(b1-t2*(b2-t2*(b3-t2*(b4-t2*b5)))); + gamma=c0-t2*(c1-t2*(c2-t2*(c3-t2*(c4-t2*c5)))); + return +c +c full computation + 11 onoth=one/theta + tuoth2=two*onoth*onoth + costh=dcos(theta) + sinc=dsin(theta)*onoth + cs=costh-two*sinc + alpha=onoth*(one+sinc*cs) + beta=tuoth2*(one+costh*cs) + gamma=two*tuoth2*(sinc-costh) + return +c + end +c +************************************************************************ + subroutine intsimpodd(n,f,out) +c +c Use Simpson's three-point rule to integrate a function whose values at +c n equally-spaced locations are given in array f; put result in "out". +c [Numerical Recipes (1992), p.128] +c Notes: 1) The array f must have an odd number of entries. +c 2) To obtain the desired integral, one MUST, after calling +c intsimpodd, multiply the result "out" by the stepsize. MV +c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! + include 'impli.inc' + integer n + double precision f(n),out +c + sum1=0 + sum2=0 + nhalf=n/2 +c + sum2=sum2+f(2) + do j=2,nhalf + sum2=sum2 + f(2*j) + sum1=sum1 + f(2*j-1) + enddo + out = (f(1) + 2.d0*sum1 + 4.d0*sum2 + f(n))/3.d0 +c + return + end +c +************************************************************************ + subroutine intsimp(n,f,out) +c +c Use Simpson's rule to integrate a function whose values at n equally- +c spaced locations are given in the array f; put result in "out". +c [Numerical Recipes (1992), p.128] +c +c For odd n, use the extended three-point rule (subroutine intsimpodd). +c For even n, apply the three-point rule to the interval i=1,2,...,n-3; +c apply the four-point rule to the remaining interval, i=n-3,...,n; and +c then add the results. Overall error ~ h^{-4}. MV +c +c NB: To obtain the desired integral, one MUST, after calling intsimp, +c multiply the result "out" by the stepsize. +c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! + include 'impli.inc' + integer n + double precision f(n),out +c + if(n.eq.(2*(n/2)+1)) then + call intsimpodd(n,f,out) + else + call intsimpodd(n-3,f,out) + xtra=3.d0*(f(n-3) + 3.d0*(f(n-2) + f(n-1)) + f(n))/8.d0 + out=out+xtra + endif +c + return + end +c +************************************************************************ + subroutine locate(xx,n,x,j) +c +c This subroutine takes an array xx(1..n) and a value x, and it returns +c the index j such that x lies between xx(j) and x(j+1). If the value +c returned is either j=0 or j=n, then x lies outside the range. +c NB: The array xx must be monotonic, either increasing or decreasing. +c From Press, et al., Numerical Recipes, 2nd ed. (1992), p.111. +c-----!----------------------------------------------------------------! + integer j,n + double precision x,xx(n) +c +c local variables + integer jl,jm,ju +c + jl=0 + ju=n+1 +c + 10 if(ju-jl.gt.1) then + jm=(ju+jl)/2 + if((xx(n).gt.xx(1)).eqv.(x.gt.xx(jm))) then + jl=jm + else + ju=jm + endif + goto 10 + endif + j=jl +c + return + end +c +************************************************************************ +cryne subroutine name changed to parfit_eb to avoid conflict +cryne with parfit in magnet.f ; fix later. R.D. Ryne June 16, 2004 + subroutine parfit_eb(npoint,xi,yi,ai,bi,ci) +c +c This subroutine takes data pairs (x(i),y(i)), i=1..npoint and fits a +c parabola of the form a+b*x+c*x**2 to each triple of adjacent points. +c It returns the lists of parabola coefficients a(i), b(i), and c(i). +c Except at the ends, the parabola coefficients a(i), b(i), c(i) are +c the average of those calculated using the points (i-1,i,i+1) and +c those calculated using the points (i,i+1,i+2). +c-----!----------------------------------------------------------------! + include 'impli.inc' +c +c calling arrays + dimension xi(npoint),yi(npoint),ai(npoint),bi(npoint),ci(npoint) +c +c local variables + npm1=npoint-1 + npm2=npoint-2 +c +c initialize the fitting + x1=xi(1) + x2=xi(2) + x3=xi(3) + y1=yi(1) + y2=yi(2) + y3=yi(3) + h1=x2-x1 + h2=x3-x2 + h3=x3-x1 + d1= y1/(h1*h3) + d2=-y2/(h1*h2) + d3= y3/(h2*h3) +c and fit a parabola to the first three points + a1= d1*x2*x3 + d2*x3*x1 + d3*x1*x2 + b1= -d1*(x2+x3) - d2*(x3+x1) - d3*(x1+x2) + c1= d1 + d2 + d3 + ai(1)=a1 + bi(1)=b1 + ci(1)=c1 +c +c compute the next set of parabola coefficients +c and average with the previous set + do 1 i=2,npm2 + ip2=i+2 + x1=x2 + x2=x3 + x3=xi(ip2) + y1=y2 + y2=y3 + y3=yi(ip2) + h1=h2 + h2=x3-x2 + h3=x3-x1 + d1= y1/(h1*h3) + d2=-y2/(h1*h2) + d3= y3/(h2*h3) + a2= d1*x2*x3 + d2*x3*x1 + d3*x1*x2 + b2= -d1*(x2+x3) - d2*(x3+x1) - d3*(x1+x2) + c2= d1 + d2 + d3 + ai(i)=0.5d0*(a1+a2) + bi(i)=0.5d0*(b1+b2) + ci(i)=0.5d0*(c1+c2) + a1=a2 + b1=b2 + c1=c2 + 1 continue +c +c rightmost interval + ai(npm1)=a2 + bi(npm1)=b2 + ci(npm1)=c2 +c + return + end +c +************************************************************************ diff --git a/OpticsJan2020/MLI_light_optics/Src/elem.f b/OpticsJan2020/MLI_light_optics/Src/elem.f new file mode 100755 index 0000000..047167e --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/elem.f @@ -0,0 +1,2480 @@ +*********************************************************************** +* header: ELEMENT LIBRARY * +* Common beamline elements * +*********************************************************************** +c + subroutine arot(ang,h,mh) +c +c Rotates axes counterclockwise in x-y plane by angle 'ang', +c looking in the direction of the beam. +c In order to get the map for an element, e.g., a quad, +c rotated on its axis by theta clockwise looking in the direction +c of the beam, the element map should be preceded a +c by arot(theta) and followed by arot(-theta). +c Written by Liam Healy, June 12, 1984. + use lieaparam, only : monoms + include 'impli.inc' + double precision h(monoms),mh(6,6) +c + call clear(h,mh) +c Rotate coordinates + mh(1,1)=cos(ang) + mh(1,3)=-sin(ang) + mh(3,1)=sin(ang) + mh(3,3)=cos(ang) +c Rotate momenta + mh(2,2)=cos(ang) + mh(2,4)=-sin(ang) + mh(4,2)=sin(ang) + mh(4,4)=cos(ang) +c Don't touch flight time + mh(5,5)=1. + mh(6,6)=1. +c Polynomials are zero (bless those linear maps). + return + end +c +*********************************************************************** +c + subroutine jmap(h,mh) +c Creates a map consisting of the matrix J (used in the definition of +c symplectic matrices), with polynomials = zero. +c Written by Liam Healy, April 16, 1985. +c +c----Variables---- + include 'impli.inc' + include 'symp.inc' + double precision h(*),mh(6,6) +c +c----Routine---- + call clear(h,mh) + do 100 i=1,6 + do 100 j=1,6 + mh(i,j)=jm(i,j) + 100 continue + return + end +c +********************************************************************** +c + subroutine dquad(qlength,qgrad,h,hm) +c +c subroutine for a horizontally defocussing quad +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + dimension h(monoms),hm(6,6) +c +c change sign of gradient + grad=-qgrad + call sssquad(qlength,grad,h,hm) +c + return + end +c +*********************************************************************** +c + subroutine sssquad(qlength,qgrad,h,hm) +c +c Computes matrix hm and polynomial array +c h of a quadrupole of length qlength (meters) and with field +c gradient qgrad (tesla/meter) using the SSS algorithm. +c If qgrad is positive the quad is focusing in the horizontal +c plane. +c +c MARYLIE5.0 upgrade. +c Written by M.Venturini 5 Aug 1997. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + dimension h(monoms),hm(6,6) +c + dimension p(6) +c + call clear(h,hm) +c + p(1) = qlength/sl + p(2) =0.d0 + p(3) =0.d0 +c p(4) =.1d0 + p(4) =.05d0 +c p(5) =1.d0 + p(5) =0.d0 +c p(6) =12 + p(6) = 0.d0 +c + call hamdrift(h) +cryne 6/21/2002 modified to multiply by sl**2: + Qbrho=qgrad/2.d0/brho*sl**2 +c + h(7)=Qbrho + h(18)=-Qbrho +c + write(jodf,*)'sssquad has been used' + write(jodf,*)'eps=',p(4) +c +c call unixtime(ti1) + call sss(p,h,hm) +c call unixtime(ti2) +c t3=ti2-ti1 +c write(jof,*) 'Execution time in seconds =',t3 +c write(jof,*) ' ' +c write(jodf,*) 'Execution time in seconds =',t3 +c write(jodf,*) ' ' +c + return + end +c +*********************************************************************** +c + subroutine drift(el,h,hm) +c +c Generates linear matrix hm and +c array h containing nonlinearities +c for the transfer map describing +c a drift section of length el meters +c Written by A. Dragt 3 January 1995. +c Modified by A. Dragt 12 April 1997 to add degree 5 and 6 terms. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + double precision hm(6,6),h(monoms) +c + call clear(h,hm) +c + elsc=el/sl +c +c compute matrix part +c + do 40 k=1,6 + hm(k,k)=+1.0d0 + 40 continue + hm(1,2)=+elsc + hm(3,4)=+elsc + hm(5,6)=+(elsc/((gamma**2)*(beta**2))) +c +c compute array part h +c +c degree 3 +c + h(53)=-(elsc/(2.0d0*beta)) + h(76)=-(elsc/(2.0d0*beta)) + h(83)=-(elsc/(2.0d0*(gamma**2)*(beta**3))) +c +c degree 4 +c + h(140)=-elsc/8.0d0 + h(149)=-elsc/4.0d0 + h(154)=+(elsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 + h(195)=-elsc/8.0d0 + h(200)=+(elsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 + h(209)=+elsc*(1.0d0-(5.0d0/beta**2))/(8.0d0*gamma**2*beta**2) +c +c degree 5 +c + h(340)=-3.d0*elsc/(8.d0*beta) + h(363)=-3.d0*elsc/(4.d0*beta) + h(370)=elsc*(-5.d0+3.d0*beta**2)/(4.d0*beta**3) + h(443)=-3.d0*elsc/(8.d0*beta) + h(450)=elsc*(-5.d0+3.d0*beta**2)/(4.d0*beta**3) + h(461)=elsc*(-7.d0+3.d0*beta**2)/ + &(8.d0*beta**5*gamma**2) +c +c degree 6 +c + h(714)=-elsc/(16.d0) + h(723)=-3.d0*elsc/(16.d0) + h(728)=3.d0*elsc*(-5.d0+beta**2)/(16.d0*beta**2) + h(769)=-3.d0*elsc/(16.d0) + h(774)=3.d0*elsc*(-5.d0+beta**2)/(8.d0*beta**2) + h(783)=-elsc*(35.d0-30.d0*beta**2+3.d0*beta**4)/ + &(16.d0*beta**4) + h(896)=-elsc/(16.d0) + h(901)=3.d0*elsc*(-5.d0+beta**2)/(16.d0*beta**2) + h(910)=-elsc*(35.d0-30.d0*beta**2+3.d0*beta**4)/ + &(16.d0*beta**4) + h(923)=-elsc*(21.d0-14.d0*beta**2+beta**4)/ + &(16.d0*beta**6*gamma**2) +c + return + end +c +*********************************************************************** +c + subroutine gfrngg(psideg,rho,iedge,ha,hm,gap,xk1) +c +c subroutine to generate lie transformation +c for fringe fields of a general bending magnet. +c "Gap" correction a la TRANSPORT added by F. Neri (5/7/89). +c +c psi is the angle between the design +c orbit and the normal to the pole face, +c rho is the magnet design orbit radius in meters. +c +c iedge=1 for leading edge transformation +c iedge=2 for trailing edge transformation +c +c the fringe field map is symplectic through +c all orders, but is guaranteed to match the physical +c map only through order 2. that is, the +c fringe map is a symplectic approximation +c to the exact map, accurate through order 2. +c Written by Liam Healy, ca 1985 +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' +c + dimension ha(monoms) + dimension hm(6,6) +c write(6,*)'inside gfrngg with gap=',gap +c + call clear(ha,hm) +c set up needed quantities + psi=psideg*pi180 +c AAARGH...................... + cpsi=dsin(psi) + spsi=dcos(psi) +c AAARGH...................... + cot=cpsi/spsi + cot2=cot*cot + csc=1.0d0/spsi + csc2=csc*csc + csc3=csc2*csc + csc4=csc2*csc2 + csc5=csc2*csc3 + rhosc=rho/sl + gsc = gap/sl +c +c choice of leading or trailing edge + if (iedge.gt.1) go to 1100 +c +c leading edge fringe field map +c +c matrix array (containing linear effects) +c + do 160 i=1,6 + hm(i,i)=1.0d0 + 160 continue + bet0 = datan(cot) + hm(4,3)= -tan(bet0-xk1*(1.d0+cpsi**2)*csc*gsc/rhosc)/rhosc +c +c arrays contaning generators of nonlinearities +c +c degree 3 +c + ha(54)=-csc3/(rhosc*2.0d0) + ha(67)=-cot*csc2/(rhosc*beta*2.0d0) +c +c degree 4 +c + ha(145)=-3.d0*cot*csc4/(4.d0*rhosc) + ha(158)=-cot2*csc3/(rhosc*beta)-csc5/(2.d0*rhosc*beta) + ha(184)=-3.d0*cot*csc4/(4.d0*beta**2*rhosc) + &+cot*csc2/(4.d0*rhosc) +c + return +c + 1100 continue +c +c trailing edge fringe field map +c +c matrix array (containing linear effects) +c + do 190 i=1,6 + hm(i,i)=+1.0d0 + 190 continue + bet0 = datan(cot) + hm(4,3)= -tan(bet0-xk1*(1.d0+cpsi**2)*csc*gsc/rhosc)/rhosc +c +c arrays containing nonlinearities +c +c degree 3 +c + ha(54)=+csc3/(rhosc*2.0d0) + ha(67)=-cot*csc2/(rhosc*beta*2.0d0) +c +c degree 4 +c + ha(145)=-3.d0*cot*csc4/(4.d0*rhosc) + ha(158)=+cot2*csc3/(beta*rhosc)+csc5/(2.d0*beta*rhosc) + ha(184)=-3.d0*cot*csc4/(4.d0*beta**2*rhosc) + &+cot*csc2/(4.d0*rhosc) +c + return + end +c +*********************************************************************** +c + subroutine nfrng(rho,iedge,h,mh) +c +c generates lie transformation for fringe fields +c of a normal entry bend with a design orbit +c radius of rho meters +c +c iedge=1 for leading edge +c +c iedge=2 for trailing edge +c +c the map here is the psi=pi/2 case +c of the map employed in gfrng +c Written by Alex Dragt, Fall 1986 +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + double precision mh(6,6),h(monoms),rho +c + call clear(h,mh) +c +c set coefficients of arrays +c +c set mh equal to the identity +c + do 40 i=1,6 + mh(i,i)=+1.0d0 + 40 continue +c +c set coefficients of h +c +c choose leading or trailing edge +c + if (iedge.eq.2) go to 100 +c +c leading edge coefficients +c +c degree 3 +c + h(54)=-(sl/(2.0d0*rho)) +c +c degree 4 +c + h(158)=-sl/(2.d0*beta*rho) + return +c + 100 continue +c trailing edge coefficients +c +c degree 3 +c + h(54)=+(sl/(2.0d0*rho)) +c +c degree 4 +c + h(158)=+sl/(2.d0*beta*rho) + return + end +c +*********************************************************************** +c + subroutine gfrng(psideg,rho,iedge,ha,hm) +c +c subroutine to generate lie transformation +c for fringe fields of a general bending magnet. +c +c psi is the angle between the design +c orbit and the normal to the pole face, +c rho is the magnet design orbit radius in meters. +c +c iedge=1 for leading edge transformation +c iedge=2 for trailing edge transformation +c +c the fringe field map is symplectic through +c all orders, but is guaranteed to match the physical +c map only through order 2. that is, the +c fringe map is a symplectic approximation +c to the exact map, accurate through order 2. +c Written by Liam Healy, ca 1985 +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' +c + dimension ha(monoms) + dimension hm(6,6) +c + call clear(ha,hm) +c set up needed quantities + psi=psideg*pi180 + cpsi=dsin(psi) + spsi=dcos(psi) + cot=cpsi/spsi + cot2=cot*cot + csc=1.0d0/spsi + csc2=csc*csc + csc3=csc2*csc + csc4=csc2*csc2 + csc5=csc2*csc3 + rhosc=rho/sl +c +c choice of leading or trailing edge + if (iedge.gt.1) go to 1100 +c +c leading edge fringe field map +c +c matrix array (containing linear effects) +c + do 160 i=1,6 + hm(i,i)=1.0d0 + 160 continue + hm(4,3)= -cot/rhosc +c +c arrays contaning generators of nonlinearities +c +c degree 3 +c + ha(54)=-csc3/(rhosc*2.0d0) + ha(67)=-cot*csc2/(rhosc*beta*2.0d0) +c +c degree 4 +c + ha(145)=-3.d0*cot*csc4/(4.d0*rhosc) + ha(158)=-cot2*csc3/(rhosc*beta)-csc5/(2.d0*rhosc*beta) + ha(184)=-3.d0*cot*csc4/(4.d0*beta**2*rhosc) + &+cot*csc2/(4.d0*rhosc) +c + return +c + 1100 continue +c +c trailing edge fringe field map +c +c matrix array (containing linear effects) +c + do 190 i=1,6 + hm(i,i)=+1.0d0 + 190 continue + hm(4,3)=-cot/rhosc +c +c arrays containing nonlinearities +c +c degree 3 +c + ha(54)=+csc3/(rhosc*2.0d0) + ha(67)=-cot*csc2/(rhosc*beta*2.0d0) +c +c degree 4 +c + ha(145)=-3.d0*cot*csc4/(4.d0*rhosc) + ha(158)=+cot2*csc3/(beta*rhosc)+csc5/(2.d0*beta*rhosc) + ha(184)=-3.d0*cot*csc4/(4.d0*beta**2*rhosc) + &+cot*csc2/(4.d0*rhosc) + return + end +c +*********************************************************************** +c + subroutine octe(l,phi0,h,mh) +c +c computes matrix mh and polynomial h for +c electric octupole with length l meters and scalar +c potential of the form phi0*(x**4-6*x**2*y**2+y**4) +c Written by D. Douglas, ca 1982 +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + double precision l,h(monoms),mh(6,6) + double precision lsc +c + call clear(h,mh) + lsc=l/sl +c +c enter matrix elements +c + do 40 i=1,6 + mh(i,i)=+1.0d0 + 40 continue + mh(1,2)=+lsc + mh(3,4)=+lsc + mh(5,6)=+(lsc/((gamma**2)*(beta**2))) +c +c set coefficients of h +c +c degree 3 +c + h(53)=-(lsc/(2.0d0*beta)) + h(76)=-(lsc/(2.0d0*beta)) + h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) +c +c degree 4 +c + ap=((sl**4)*phi0)/(c*beta*brho) + h(84)=+lsc*ap + h(85)=-2.0d0*(lsc**2)*ap + h(90)=+2.0d0*(lsc**3)*ap + h(95)=-6.0d0*lsc*ap + h(96)=+6.d0*lsc**2*ap + h(99)=-(2.0d0*(lsc**3)*ap) + h(105)=-(lsc**4)*ap + h(110)=+6.0d0*(lsc**2)*ap + h(111)=-(8.0d0*(lsc**3)*ap) + h(114)=+3.0d0*(lsc**4)*ap + h(140)=-lsc/8.0d0+(lsc**5)*ap/5.0d0 + h(145)=-(2.0d0*(lsc**3)*ap) + h(146)=+3.0d0*(lsc**4)*ap + h(149)=-lsc/4.0d0-(6.0d0*(lsc**5)*ap)/5.0d0 + h(154)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 + h(175)=+lsc*ap + h(176)=-2.0d0*(lsc**2)*ap + h(179)=+2.0d0*(lsc**3)*ap + h(185)=-(lsc**4)*ap + h(195)=-lsc/8.0d0+(lsc**5)*ap/5.0d0 + h(200)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 + h(209)=+(lsc*(1.d0-(5.d0/beta**2)))/(8.d0*gamma**2*beta**2) + return + end +c +*********************************************************************** +c + subroutine octm(el,gb0,h,hm) +c +c computes matrix hm and polynomial h for +c magnetic octupole with length l meters and vector +c potential of the form -(gb0/4.)*(+x**4-6*x**2*y**2+y**4) +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + dimension h(monoms),hm(6,6) +c + call sssoctm(el,gb0,h,hm) +c + return + end +c +*********************************************************************** +c + subroutine sssoctm(olength,oct,h,hm) +c +c computes matrix mh and polynomial array +c h of a octupole of length olength (meters) and with strength +c oct (tesla/meter^3) using the SSS algorithm. +c The vector potential is A_z=-(oct/4)(x^4 - 6x^2*y^2 + y^4). +c +c MARYLIE5.0 upgrade. +c Written by M.Venturini 5 Aug 1997. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + dimension h(monoms),hm(6,6) +c + dimension p(6) +c + call clear(h,hm) +c + p(1) = olength/sl + p(2) =0.d0 + p(3) =0.d0 +cryne 6/21/2002 p(4) =.1d0 + p(4) =1.d-4 + p(5) =0.d0 + p(6) =0.d0 +c + call hamdrift(h) +c +cryne 6/21/2002 modified to multiply by sl**4: + oct4brho=oct/4.d0/brho*sl**4 +c + h(84)=oct4brho + h(95)=-6*oct4brho + h(175)=oct4brho +c + write(jodf,*)'sssoctm has been used' + write(jodf,*)'eps=',p(4) + call sss(p,h,hm) +c + return + end +c +*********************************************************************** +c + subroutine pbend(rho,phideg,h,mh) +c +c computes generators for the lie transformation +c describing a parallel-faced bending magnet +c subtending an angle of phi radians +c with a design orbit radius of rho meters +c Written by D. Douglas, ca 1982 +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' + double precision h(monoms),mh(6,6) +c + call clear(h,mh) + phi=phideg*pi180 + alpha=phi/2.0d0 + rhosc=rho/sl + cal=dcos(alpha) + sal=dsin(alpha) + tan=sal/cal +c +c enter matrix elements into mh +c + do 40 i=1,6 + mh(i,i)=+1.0d0 + 40 continue + mh(1,2)=+rhosc*tan*2.0d0 + mh(3,4)=+phi*rhosc + mh(5,6)=-phi*rhosc+(2.0d0*rhosc*tan)/(beta**2) +c +c add coefficients of generators of nonlinearities to h +c +c degree 3 +c + h(53)=-(rhosc*tan)/((cal**2)*beta) + h(76)=-(rhosc*tan)/beta + h(83)=+(rhosc*tan)/beta-(tan+tan**3/3.d0)*rhosc/beta**3 +c +c degree 4 +c + sec=1.d0/cal + sec2=sec*sec + sec4=sec2*sec2 + h(140)=-rhosc*tan*sec4/4.d0 + h(149)=-rhosc*tan*sec2/2.d0 + h(154)=-3.d0*rhosc*tan*sec4/(2.d0*beta**2) + &+rhosc*tan*sec2/2.d0 + h(195)=-rhosc*tan/4.d0 + h(200)=-rhosc*tan*sec2/(2.d0*beta**2) + &-rhosc*tan/(2.d0*gamma**2*beta**2) + &-rhosc*tan/(2.d0*beta**2) + h(209)=-rhosc*tan*tan*tan*tan*tan/(4.d0*beta**4) + &-5.d0*rhosc*tan*tan*tan/(6.d0*beta**4) + &-5.d0*rhosc*tan/(4.d0*beta**4) + &+rhosc*tan*tan*tan/(2.d0*beta**2) + &+3.d0*rhosc*tan/(2.d0*beta**2) + &-rhosc*tan/4.d0 + return + end +c +*********************************************************************** +c + subroutine nbend(rho,phideg,h,mh) +c +c computes generators for normal entry dipole bending +c magnet subtending angle phi radians and having +c design orbit radius rho meters +c Written by D. Douglas, ca 1982 +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' + double precision h(monoms),mh(6,6) +c + call clear(h,mh) +c +c compute useful numbers +c + rhosc=rho/sl + phi=phideg*pi180 + cphi=dcos(phi) + sphi=dsin(phi) +c +c set coefficients of mh +c + mh(1,1)=+cphi + mh(1,2)=+(rhosc*sphi) + mh(1,6)=-(((1.0d0-cphi)*rhosc)/beta) + mh(2,1)=-(sphi/rhosc) + mh(2,2)=+cphi + mh(2,6)=-(sphi/beta) + mh(3,3)=+1.d0 + mh(3,4)=+rhosc*phi + mh(4,4)=+1.d0 + mh(5,1)=+sphi/beta + mh(5,2)=+(((1.d0-cphi)*rhosc)/beta) + mh(5,5)=+1.d0 + mh(5,6)=-(rhosc*phi)+((rhosc*sphi)/(beta**2)) + mh(6,6)=+1.d0 +c +c set coefficients of array h +c +c degree 3 +c + sphi2=sphi*sphi + sphi3=sphi2*sphi + cphi2=cphi*cphi + cphi3=cphi2*cphi + h(28)=-(sphi3/(6.0d0*(rhosc**2))) + h(29)=-((cphi*sphi2)/((2.0d0)*rhosc)) + h(33)=-(sphi3/(2.0d0*rhosc*beta)) + h(34)=-((sphi*cphi2)/2.0d0) + h(38)=-((sphi2*cphi)/beta) + h(43)=-(sphi/2.0d0) + h(48)=-(sphi/(2.0d0*(gamma**2)*(beta**2))) + &-(sphi3/(2.0d0*(beta**2))) + h(49)=+(((1.0d0-cphi3)*rhosc)/6.d0) + h(53)=-((sphi*cphi2*rhosc)/(beta*2.d0)) + h(58)=+(((1.0d0-cphi)*rhosc)/2.0d0) + h(63)=+(((1.0d0-cphi)*rhosc)/(2.0d0*(gamma**2)*(beta**2))) + &-((sphi2*cphi*rhosc)/(2.0d0*(beta**2))) + h(76)=-((rhosc*sphi)/(2.0d0*beta)) + h(83)=-((rhosc*sphi)/(2.0d0*(gamma**2)*(beta**3))) + &-((rhosc*sphi3)/(6.0d0*(beta**3))) +c +c degree 4 +c + h(89)=-sphi3/(6.d0*beta*rhosc**2) + h(90)=-sphi3/(8.d0*rhosc) + h(94)=-cphi*sphi2/(2.d0*beta*rhosc) + h(99)=-sphi3/(8.d0*rhosc) + h(104)=-sphi3*(5.d0-beta**2)/(8.d0*beta**2*rhosc) + h(105)=-cphi*sphi2/4.d0 + h(109)=+sphi3/(4.d0*beta)-sphi/(2.d0*beta) + h(114)=-cphi*sphi2/4.d0 + h(119)=-cphi*sphi2/(4.d0*beta**2*gamma**2) + &-cphi*sphi2/beta**2 + h(132)=-sphi3/(4.d0*beta)-sphi/(2.d0*beta) + h(139)=-sphi3/(4.d0*beta**3*gamma**2) + &-sphi3/(2.d0*beta**3)-sphi/(2.d0*beta**3*gamma**2) + h(140)=-rhosc*sphi*cphi2/8.d0 + h(144)=-rhosc*cphi*sphi2/(1.2d1*beta) + &+rhosc*(1.d0-cphi)/(6.d0*beta) + h(149)=+rhosc*sphi3/8.d0-rhosc*sphi/4.d0 + h(154)=+rhosc*sphi3*(4.d0-beta**2)/(8.d0*beta**2) + &-rhosc*sphi/(4.d0*beta**2*gamma**2) + &-rhosc*sphi/(2.d0*beta**2) + h(167)=-rhosc*cphi*sphi2/(4.d0*beta) + &+rhosc*(1.d0-cphi)/(2.d0*beta) + h(174)=-rhosc*cphi*sphi2/(4.d0*beta**3*gamma**2) + &-rhosc*cphi*sphi2/(2.d0*beta**3) + &+rhosc*(1.d0-cphi)/(2.d0*beta**3*gamma**2) + h(195)=-rhosc*sphi/8.d0 + h(200)=-rhosc*sphi3/(8.d0*beta**2) + &-rhosc*sphi/(4.d0*beta**2*gamma**2) + &-rhosc*sphi/(2.d0*beta**2) + h(209)=-rhosc*sphi3/(8.d0*beta**4*gamma**2) + &-rhosc*sphi3/(6.d0*beta**4)-rhosc*sphi/(2.d0*beta**4*gamma**2) + &-rhosc*sphi/(8.d0*beta**4*gamma**4) + return + end +c +*********************************************************************** +c +cryne Aug 6, 2003: routine name changed to prot3 +cryne The fifth order version by Johannes van Zeijts is now called 'prot' + subroutine prot3(psideg,kind,ha,hm) +c +c subroutine to generate lie transformation +c for rotation of reference plane. +c used primarily in connection with computing +c map for dipoles with rotated pole faces. +c +c psideg is the rotation angle angle in degrees. +c +c kind=1 for transition from the normal reference plane +c to a rotated reference plane +c kind=2 for transition from a rotated reference plane +c to a normal reference plane +c Written by Alex Dragt, Fall 1986 +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' + double precision ha(monoms),hm(6,6) +c + dimension ha1(monoms),ha2(monoms) + dimension hm1(6,6),hm2(6,6) +c + call clear(ha,hm) + call clear(ha1,hm1) + call clear(ha2,hm2) +c +c set up needed quantities +c + psi=psideg*pi180 + cpsi=dsin(psi) + spsi=dcos(psi) + cot=cpsi/spsi + cot2=cot*cot + cot3=cot2*cot + cot4=cot2*cot2 + cot5=cot2*cot3 + csc=1.0d0/spsi + csc2=csc*csc +c +c choice of kind + if (kind.gt.1) go to 100 +c +c transition from normal to rotated reference plane +c +c matrix arrays (containing linear effects) +c + do 40 i=1,6 + hm1(i,i)=+1.0d0 + 40 continue + hm1(2,6)=-cot/beta + hm1(5,1)=+cot/beta + do 50 i=3,6 + hm2(i,i)=+1.0d0 + 50 continue + hm2(1,1)=hm2(1,1)+1.0d0/spsi + hm2(2,2)=hm2(2,2)+spsi +c +c arrays containing generators of nonlinearities +c +c degree 3 +c + ha1(34)=-cot/2.0d0 + ha1(38)=-cot2/beta + ha1(43)=-cot/2.0d0 + ha1(48)=-cot/(gamma**2*beta**2*2.0d0) + &-cot3/(beta**2*2.0d0) +c +c degree 4 +c + ha1(105)=-cot2/4.d0 + ha1(109)=-cot/(2.d0*beta)-3.d0*cot3/(4.d0*beta) + ha1(114)=-cot2/4.d0 + ha1(119)=-cot2/beta**2-3.d0*cot4/(4.d0*beta**2) + &-cot2/(4.d0*gamma**2*beta**2) + ha1(132)=-cot/(2.d0*beta)-cot3/(4.d0*beta) + ha1(139)=-cot3/(2.d0*beta**3)-cot5/(4.d0*beta**3) + &-cot/(2.d0*gamma**2*beta**3) + &-cot3/(4.d0*gamma**2*beta**3) +c +c compute map + call concat(ha1,hm1,ha2,hm2,ha,hm) + return +c + 100 continue +c +c transition from a rotated to a normal reference plane +c +c matrix arrays (containing linear effects) +c + do 60 i=1,6 + hm1(i,i)=+1.0d0 + 60 continue + hm1(2,6)=-cpsi/beta + hm1(5,1)=+cpsi/beta + do 70 i=3,6 + hm2(i,i)=+1.0d0 + 70 continue + hm2(1,1)=hm2(1,1)+spsi + hm2(2,2)=hm2(2,2)+csc +c +c arrays containing generators of nonlinearties +c +c degree 3 +c + ha1(34)=-cot*csc/2.0d0 + ha1(43)=-cpsi/2.0d0 + ha1(48)=-cpsi/(gamma**2*beta**2*2.0d0) +c +c degree 4 +c + ha1(105)=+cot2*csc2/4.d0 + ha1(109)=-cot*csc/(2.d0*beta) + ha1(114)=+cot2/4.d0 + ha1(119)=+cot2/(4.d0*gamma**2*beta**2) + ha1(132)=-cpsi/(2.d0*beta) + ha1(139)=-cpsi/(2.d0*gamma**2*beta**3) +c +c compute map + call concat(ha1,hm1,ha2,hm2,ha,hm) + return + end +c +*********************************************************************** +c +cryne Aug 6, 2003: routine name changed from myprot5 to prot + subroutine prot(angdeg,ijkind,h,mh) +c +c High order PROT routine. +c Actual code generated by Johannes van Zeijts using +c REDUCE. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' +c include 'param.inc' +c include 'parm.inc' + double precision l,h(monoms),mh(6,6) +c + dimension j(6) +c + DOUBLE PRECISION B + DOUBLE PRECISION CO + DOUBLE PRECISION Si +c +cryne mods to allow for leading/trailing option: +cryne ijkind=1 for normal-to-rotated, =2 for rotated-to-normal + phideg=angdeg + if(ijkind.eq.2)phideg=-angdeg + +c + call clear(h,mh) +c + B = beta + phi = phideg*pi180 + SI = SIN(phi) + CO = COS(phi) +c + mh(1,1)=1.0d0/CO + mh(2,2)=CO + mh(2,6)=(-SI)/B + mh(3,3)=1.0d0 + mh(4,4)=1.0d0 + mh(5,1)=SI/(B*CO) + mh(5,5)=1.0d0 + mh(6,6)=1.0d0 +c + h(34) =(-SI)/(2.0d0*CO) + h(43) =(-SI)/(2.0d0*CO) + h(48) =(SI*(B**2-1))/(2.0d0*B**2*CO) + h(105) =SI**2/(4.0d0*(SI**2-1)) + h(109) =(-SI)/(2.0d0*B*CO) + h(114) =SI**2/(4.0d0*(SI**2-1)) + h(119) =(SI**2*(-B**2+1))/(4.0d0*B**2*(SI**2-1)) + h(132) =(-SI)/(2.0d0*B*CO) + h(139) =(SI*(B**2-1))/(2.0d0*B**3*CO) + h(266) =SI/(8.0d0*CO*(SI**2-1)) + h(270) =SI**2/(2.0d0*B*(SI**2-1)) + h(275) =(SI*(-2.0d0*SI**2+3))/(12.0d0*CO*(SI**2-1)) + h(280) =(SI*(2.0d0*B**2*SI**2-3.0d0*B**2-8.0d0*SI**2+9))/( + & 12.0d0*B**2*CO*(SI**2-1)) + h(293) =SI**2/(2.0d0*B*(SI**2-1)) + h(300) =(SI**2*(-B**2+1))/(2.0d0*B**3*(SI**2-1)) + h(321) =(SI*(-4.0d0*SI**2+3))/(24.0d0*CO*(SI**2-1)) + h(326) =(SI*(4.0d0*B**2*SI**2-3.0d0*B**2-10.0d0*SI**2+9))/( + & 12.0d0*B**2*CO*(SI**2-1)) + h(335) =(SI*(-4.0d0*B**4*SI**2+3.0d0*B**4+20.0d0*B**2*SI**2- + & 18.0d0*B**2-16.0d0*SI**2+15))/(24.0d0*B**4*CO*(SI**2-1)) + h(588) =(SI**2*(SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+1)) + h(592) =(SI*(SI**2+6))/(16.0d0*B*CO*(SI**2-1)) + h(597) =(SI**2*(3.0d0*SI**2-4))/(16.0d0*(SI**4-2.0d0*SI**2+ + & 1)) + h(602) =(SI**2*(-3.0d0*B**2*SI**2+4.0d0*B**2+15.0d0*SI**2-16.0d0 + & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) + h(615) =(3.0d0*SI*(-SI**2+2))/(8.0d0*B*CO*(SI**2-1)) + h(622) =(SI*(3.0d0*B**2*SI**2-6.0d0*B**2-7.0d0*SI**2+10))/( + & 8.0d0*B**3*CO*(SI**2-1)) + h(643) =(SI**2*(5.0d0*SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+ + & 1)) + h(648) =(SI**2*(-5.0d0*B**2*SI**2+4.0d0*B**2+17.0d0*SI**2-16.0d0 + & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) + h(657) =(SI**2*(5.0d0*B**4*SI**2-4.0d0*B**4-34.0d0*B**2*SI**2 + & +32.0d0*B**2+29.0d0*SI**2-28))/(32.0d0*B**4*(SI**4-2.0d0*SI**2+ + & 1)) + h(695) =(SI*(-7.0d0*SI**2+6))/(16.0d0*B*CO*(SI**2-1)) + h(702) =(SI*(7.0d0*B**2*SI**2-6.0d0*B**2-11.0d0*SI**2+10))/( + & 8.0d0*B**3*CO*(SI**2-1)) + h(713) =(SI*(-7.0d0*B**4*SI**2+6.0d0*B**4+22.0d0*B**2*SI**2- + & 20.0d0*B**2-15.0d0*SI**2+14))/(16.0d0*B**5*CO*(SI**2-1)) +c + call revf(1,h,mh) +c +cryne this line added Aug 6, 2003: + if(ijkind.eq.2)call inv(h,mh) + return + end +c +c end of file +c +*********************************************************************** +c + subroutine fquad(qlength,qgrad,h,hm) +c +c subroutine for a horizontally focussing quad +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + dimension h(monoms),hm(6,6) +c + grad=qgrad + call sssquad(qlength,grad,h,hm) +c + return + end +c +*********************************************************************** +c + subroutine frquad(gb0,ifr,h,mh) +c +c computes hard edge fringe field map for quads +c Written by E. Forest, ca 1984 +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + double precision gb0,h(monoms),mh(6,6) +c +c set up linear part as identity matrix + do 1 i=1,6 + do 2 j=1,6 + mh(i,j)=0.d0 + if(i.ne.j) goto 2 + mh(i,j)=1.d0 + 2 continue + 1 continue +c clear polynomial array + do 3 i=1,monoms + h(i)=0.d0 + 3 continue + gb=gb0 +c see if fringe field is leading or trailing + if(ifr.lt.0)gb=-gb0 +c compute nonlinear part of map + arg=(gb*(sl**2))/brho + h(85)=arg/12.d0 + h(176)=-arg/12.d0 + h(110)=arg/4.d0 + h(96)=-arg/4.d0 + return + end +c +*********************************************************************** +c + subroutine gbend (rho,bndang,psideg,phideg,h,mh) +c a dipole bending magnet with arbitrary entrance and +c exit angles (psi and phi respectively) and arbitrary +c bend andgle (bndang). +c written by L. Healy, April 19, 1984. +c modified by A. Dragt, 5 Oct 1986. + use lieaparam, only : monoms + include 'impli.inc' + double precision mh(6,6),mht1(6,6),mht2(6,6),mht3(6,6) + double precision h(monoms),ht1(monoms),ht2(monoms),ht3(monoms) +c +c calculate each of the 3 individual pieces that make +c up the general bending magnet, and concatenate them: +c gbend=hpf1*nbend*hpf2 +c +c compute hpf1 and nbend + call hpf(rho,1,psideg,ht1,mht1) + aldeg=bndang-psideg-phideg + call nbend(rho,aldeg,ht2,mht2) +c form the product hpf1*nbend + call concat(ht1,mht1,ht2,mht2,ht3,mht3) +c compute hpf2 + call hpf(rho,-1,phideg,ht1,mht1) +c form the complete product hpf1*nbend*hpf2 + call concat(ht3,mht3,ht1,mht1,h,mh) + return + end +c +*********************************************************************** +c + subroutine hpf(rho,which,phideg,h,mh) +c This generates matrix elements and monomial coeffs +c for half of a parallel face bending magnet. +c The bending angle is phi, and 'which' indicates +c whether it is the leading half (1) or trailing half (-1). +c Written by Liam Healy, April 19, 1984. + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + integer which + double precision mh(6,6),h(monoms) + include 'pie.inc' + call clear(h,mh) +c set trig functions and scale rho + phi=phideg*pi180 + rhosc=rho/sl + tn=tan(phi) + tn2=tn*tn + tn3=tn*tn2 + tn5=tn2*tn3 + sec=1./cos(phi) + sec2=sec*sec + sec3=sec*sec2 + sec4=sec2*sec2 + sec5=sec2*sec3 +c set matrix + do 120 i=1,6 + 120 mh(i,i)=1. + mh(1,2)=rhosc*tn + mh(1,6)=-which*rhosc*(1.-sec)/beta + mh(3,4)=rhosc*phi + mh(5,2)=-which*rhosc*(1.-sec)/beta + mh(5,6)=rhosc*(tn/beta**2-phi) +c set monomial coefficients + h(49)=which*rhosc*(1.-sec3)/6. + h(53)=-rhosc*tn*sec2/(2.*beta) + h(58)=which*rhosc*(1.-sec)/2. + h(63)=which*rhosc*(1./beta**2-1.+sec*(1.-sec2/beta**2))/2. + h(76)=-rhosc*tn/(2.*beta) + h(83)=-rhosc*tn*(1.-beta**2+tn2/3.)/(2.*beta**3) + h(140)=-rhosc*tn*sec4/8. + h(144)=which*rhosc*(sec3/3.-sec5/2.+1.d0/6.d0)/beta + h(149)=-rhosc*tn*sec2/4. + h(154)=rhosc*tn*sec2*(1.-3.*sec2/beta**2)/4. + h(167)=which*rhosc*(1.-sec3)/(2.*beta) + h(174)=-which*rhosc*((1.-sec3)/(2.*beta)-(1.-sec5)/(2.*beta**3)) + h(195)=-rhosc*tn/8. + h(200)=-tn*rhosc*((sec2+2.)/beta**2-1.)/4. + h(209)=rhosc*(-(2.5*tn+5.*tn3/3.+tn5/2.)/beta**4 + & +tn*(3.+tn2)/beta**2-tn/2.)/4. +c + return + end +c +*********************************************************************** +c + subroutine cfbend(pa,pb,fa,fm) +c This subroutine computes the map for a combined function bend +c numerically by use of the GENMAP exponentiation routine. +c It should eventually be replaced by a collection of analytic formulas. +c Written by Alex Dragt, 30 March 1987. +c Corrected by Alex Dragt, 9 Sept 1989, based on calculations in the +c paper "Third Order Transfer Map for Combined Function Dipole" by +c Dragt et al. (1989). +cryne modified by Rob Ryne 7/13/2002 to get multipole coeffcients from +cryne an array passed in the parameter list. (previously this argument +cryne was an integer that pointed to a pset) +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' + include 'parset.inc' + include 'files.inc' +c + dimension fa(monoms) + dimension fm(6,6) + dimension pa(6),pb(6) + dimension pc(6) + dimension ha(monoms) + dimension hm(6,6) +c +c set up parameters and control indices +c + phideg=pa(1) + b=pa(2) + ilfrn=nint(pa(3)) + itfrn=nint(pa(4)) + ijopt=nint(pa(5)) +cryne 7/13/2002 ipset=nint(pa(6)) +c +cryne 1 August 2004: + myorder=nint(pa(6)) +c +c compute iopt and iecho +c + iopt=mod(ijopt,10) +c write(6,*)'inside cfbend; ijopt,iopt=',ijopt,iopt +c write(6,*)'pb(1-6)=',pb(1),pb(2),pb(3),pb(4),pb(5),pb(6) + iecho=(ijopt-iopt)/10 +c write(6,*) ' iopt=',iopt,' iecho=',iecho +c +c compute useful numbers +c + rho=brho/b + rhosc=rho/sl + phi=phideg*pi180 +c write(6,*)'phi,phideg=',phi,phideg +c +cryne 7/13/2002 get multipole values from the parameter set ipset +cryne get multipole values from the array in the argument list +c +c if (ipset.lt.1 .or. ipset.gt.maxpst) then +c do 50 i=1,6 +c 50 pb(i) = 0.0d0 +c else +c do 60 i=1,6 +c 60 pb(i) = pst(i,ipset) +c endif +c +c compute multipole coefficients +c procedure when iopt=1 + if (iopt.eq.1) then +c write(6,*)'(cfbend) iopt is 1' + bqd=pb(1) + aqd=pb(2) + bsex=pb(3) + asex=pb(4) + boct=pb(5) + aoct=pb(6) + endif +c procedure when iopt=2 + if (iopt.eq.2) then +c write(6,*)'(cfbend) iopt is 2' + tay1=pb(1) + aqd=pb(2) + tay2=pb(3) + asex=pb(4) + tay3=pb(5) + aoct=pb(6) + bqd=tay1 + bsex=tay2+(5.d0*tay1)/(8.d0*rho) + boct=tay3-tay1/(48.d0*rho*rho)+(2.d0*tay2)/(3.d0*rho) + endif +c procedure when iopt=3 + if (iopt.eq.3) then +c write(6,*)'(cfbend) iopt is 3; brho,rho,sl=',brho,rho,sl + tay1=brho*pb(1) + aqd=brho*pb(2) + tay2=brho*pb(3) + asex=brho*pb(4) + tay3=brho*pb(5) + aoct=brho*pb(6) + bqd=tay1 +c write(6,*)'pb(1),tay1,bqd=',pb(1),tay1,bqd + bsex=tay2+(5.d0*tay1)/(8.d0*rho) + boct=tay3-tay1/(48.d0*rho*rho)+(2.d0*tay2)/(3.d0*rho) + endif +c +c write out multipole and taylor coefficients if desired +c + if (iecho .ne. 0) then + ttay1=bqd + ttay2=bsex-5.d0*bqd/(8.d0*rho) + ttay3=boct+7.d0*bqd/(16.d0*rho*rho)-2.d0*bsex/(3.d0*rho) + if (iecho .eq. 1 .or. iecho .eq. 3) then + write (jof,137) + 137 format(/,1x,'multipole strengths bqd,aqd,bsex,asex,boct,aoct') + write (jof,*) bqd,aqd,bsex,asex,boct,aoct + write (jof,138) + 138 format(1x,'taylor coefficients tay1,tay2,tay3') + write (jof,*) ttay1,ttay2,ttay3 + write (jof,*) + endif + if (iecho .eq. 2 .or. iecho .eq. 3) then + write (jodf,137) + write (jodf,*) bqd,aqd,bsex,asex,boct,aoct + write (jodf,138) + write (jodf,*) ttay1,ttay2,ttay3 + write (jodf,*) + endif + endif +c +c scale multipole strengths and compute scaled curvature feed up terms +c + sbqdf=1.d0/(2.d0*rhosc) + saqd=aqd*sl*rho/brho + sbqd=bqd*sl*rho/(2.d0*brho) +c write(6,*)'saqd,sbqd=',saqd,sbqd +c + sasexf=aqd*(sl**2)/(8.d0*brho) + sbsexf=bqd*(sl**2)/(8.d0*brho) + sasex=asex*(sl**2)*rho/(3.d0*brho) + sbsex=bsex*(sl**2)*rho/(3.d0*brho) +c + sscalf=-bqd*(sl**3)/(64.d0*rho*brho) + saoctf=(asex/6.d0-aqd/(16.d0*rho))*(sl**3)/brho + sboctf=(bsex/12.d0-bqd/(32.d0*rho))*(sl**3)/brho + saoct=aoct*(sl**3)*rho/brho + sboct=boct*(sl**3)*rho/(4.d0*brho) +c +c compute the Hamiltonian +c + call clear(ha,hm) +c +c degree 2 +c + ha(7)=sbqdf + sbqd + ha(9)=-saqd + ha(12)=1.d0/beta + ha(13)=rhosc/2.d0 + ha(18)=-sbqd + ha(22)=rhosc/2.d0 + ha(27)=rhosc/(2.d0*(beta*gamma)**2) +c +c degree 3 +c + ha(28)=sbsexf + sbsex + ha(30)=-sasexf - 3.d0*sasex + ha(34)=1.d0/2.0d0 + ha(39)=sbsexf - 3.d0*sbsex + ha(43)=1.d0/2.d0 + ha(48)=1.d0/(2.0d0*((gamma*beta)**2)) + ha(53)=rhosc/(2.d0*beta) + ha(64)=-sasexf+sasex + ha(76)=rhosc/(2.d0*beta) + ha(83)=rhosc/(2.d0*(gamma**2)*(beta**3)) +c +c degree 4 +c + ha(84)=sscalf + sboctf + sboct + ha(86)=-saoctf - saoct + ha(95)=2.d0*sscalf -6.d0*sboct + ha(109)=1.d0/(2.d0*beta) + ha(120)=-saoctf + saoct + ha(132)=1.d0/(2.d0*beta) + ha(139)=1.d0/(2.d0*(beta**3)*(gamma**2)) + ha(140)=rhosc/8.d0 + ha(149)=rhosc/4.d0 + ha(154)=rhosc/(4.d0*(beta**2)*(gamma**2))+rhosc/(2.d0*(beta**2)) + ha(175)=sscalf - sboctf + sboct + ha(195)=rhosc/8.d0 + ha(200)=rhosc/(4.d0*(beta**2)*(gamma**2))+rhosc/(2.d0*(beta**2)) + ha(209)=rhosc/(2.d0*(beta**4)*(gamma**2)) + &+rhosc/(8.d0*(beta**4)*(gamma**4)) +c +c call GENMAP exponentiation routine + pc(1)=-phi + pc(2)=0.d0 + pc(3)=0.d0 +c--------------------- +c write(6,*)'pc(1)=',pc(1) +c write(6,*)'pc(2)=',pc(2) +c write(6,*)'pc(3)=',pc(3) +c write(6,*)'calling cex from routine cfbend' +c--------------------- + call cex(pc,ha,hm,myorder) +c write(6,*)'returned from cex' +c write(6,*)'hm=' +c do i=1,6 +c write(6,1232)(hm(i,j),j=1,6) +c1232 format(6(1pe12.5,1x)) +c enddo + call mapmap(ha,hm,fa,fm) +c +c fringe field effects (both dipole and quadrupole) are put on +c in the subroutine lmnt +c + return + end +c +*********************************************************************** +c + subroutine cfbend_old(pa,fa,fm) +c This subroutine computes the map for a combined function bend +c numerically by use of the GENMAP exponentiation routine. +c It should eventually be replaced by a collection of analytic formulas +c Written by Alex Dragt, 30 March 1987. + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms) + dimension fm(6,6) + dimension pa(6),pb(6) + dimension pc(6) + dimension ha(monoms) + dimension hm(6,6) +c + include 'pie.inc' + include 'parset.inc' +c +c set up parameters and control indices +c + phideg=pa(1) + b=pa(2) + ilfrn=nint(pa(3)) + itfrn=nint(pa(4)) + iopt=nint(pa(5)) + ipset=nint(pa(6)) +c +c compute useful numbers +c + rho=brho/b + rhosc=rho/sl + phi=phideg*pi180 +c +c get multipole values from the parameter set ipset +c +c do 5 i=1,6 +c 5 pb(i)=0.d0 +c goto (10,20,30,40,50),ipset +c goto 60 +c 10 do 11 i=1,6 +c 11 pb(i)=pst1(i) +c goto 60 +c 20 do 21 i=1,6 +c 21 pb(i)=pst2(i) +c goto 60 +c 30 do 31 i=1,6 +c 31 pb(i)=pst3(i) +c goto 60 +c 40 do 41 i=1,6 +c 41 pb(i)=pst4(i) +c goto 60 +c 50 do 51 i=1,6 +c 51 pb(i)=pst5(i) +c 60 continue + if (ipset.lt.1 .or. ipset.gt.maxpst) then + do 50 i=1,6 + 50 pb(i) = 0.0d0 + else + do 60 i=1,6 + 60 pb(i) = pst(ipset,i) + endif +c +c compute multipole coefficients +c procedure when iopt=1 + if (iopt.eq.1) then +c pb(3)=-pb(3) +c pb(4)=-pb(4) + bqd=pb(1) + aqd=pb(2) + bsex=pb(3) + asex=pb(4) + boct=pb(5) + aoct=pb(6) + endif +c procedure when iopt=2 + if (iopt.eq.2) then + tay1=pb(1) + aqd=pb(2) + tay2=pb(3) + asex=pb(4) + tay3=pb(5) + aoct=pb(6) + bqd=tay1 + bsex=tay2-(5.d0*tay1)/(8.d0*rho) + boct=tay3-(41.d0*tay1)/(48.d0*rho*rho)+(2.d0*tay2)/(3.d0*rho) + endif +c procedure when iopt=3 + if (iopt.eq.3) then + tay1=brho*pb(1) + aqd=brho*pb(2) + tay2=brho*pb(3) + asex=brho*pb(4) + tay3=brho*pb(5) + aoct=brho*pb(6) + bqd=tay1 + bsex=tay2-(5.d0*tay1)/(8.d0*rho) + boct=tay3-(41.d0*tay1)/(48.d0*rho*rho)+(2.d0*tay2)/(3.d0*rho) + endif +c +c scale multipole strengths and compute scaled curvature feed up terms +c + sbqdf=1.d0/(2.d0*rhosc) + saqd=aqd*sl*rho/brho + sbqd=bqd*sl*rho/(2.d0*brho) +c + sasexf=aqd*(sl**2)/(8.d0*brho) + sbsexf=bqd*(sl**2)/(8.d0*brho) + sasex=asex*(sl**2)*rho/(3.d0*brho) + sbsex=bsex*(sl**2)*rho/(3.d0*brho) +c + sscalf=-bqd*(sl**3)/(64.d0*rho*brho) + saoctf=(asex/6.d0-aqd/(16.d0*rho))*(sl**3)/brho + sboctf=(bsex/12.d0-bqd/(32.d0*rho))*(sl**3)/brho + saoct=aoct*(sl**3)*rho/brho + sboct=boct*(sl**3)*rho/(4.d0*brho) +c +c compute the Hamiltonian +c + call clear(ha,hm) +c +c degree 2 +c + ha(7)=sbqdf + sbqd + ha(8)=saqd + ha(12)=1.d0/beta + ha(13)=rhosc/2.d0 + ha(18)=-sbqd + ha(22)=rhosc/2.d0 + ha(27)=rhosc/(2.d0*(beta*gamma)**2) +c +c degree 3 +c + ha(28)=sbsexf + sbsex + ha(30)=sasexf + 3.d0*sasex + ha(34)=1.d0/2.0d0 + ha(39)=sbsexf - 3.d0*sbsex + ha(43)=1.d0/2.d0 + ha(44)=sasexf-sasex + ha(48)=1.d0/(2.0d0*((gamma*beta)**2)) + ha(53)=rhosc/(2.d0*beta) + ha(76)=rhosc/(2.d0*beta) + ha(83)=rhosc/(2.d0*(gamma**2)*(beta**3)) +c +c degree 4 +c + ha(84)=sscalf + sboctf + sboct + ha(86)=saoctf + saoct + ha(95)=2.d0*sscalf -6.d0*sboct + ha(109)=1.d0/(2.d0*beta) + ha(120)=saoctf - saoct + ha(132)=1.d0/(2.d0*beta) + ha(139)=1.d0/(2.d0*(beta**3)*(gamma**2)) + ha(140)=rhosc/8.d0 + ha(149)=rhosc/4.d0 + ha(154)=rhosc/(4.d0*(beta**2)*(gamma**2))+rhosc/(2.d0*(beta**2)) + ha(175)=sscalf - sboctf + sboct + ha(195)=rhosc/8.d0 + ha(200)=rhosc/(4.d0*(beta**2)*(gamma**2))+rhosc/(2.d0*(beta**2)) + ha(209)=rhosc/(2.d0*(beta**4)*(gamma**2)) + &+rhosc/(8.d0*(beta**4)*(gamma**4)) +c +c call GENMAP exponentiation routine + pc(1)=-phi + pc(2)=0.d0 + pc(3)=0.d0 + call cex(pc,ha,hm) + call mapmap(ha,hm,fa,fm) +c +c add fringe field effects +c not yet implemented +c + return + end +c +*********************************************************************** +c + subroutine srfc(phi0,w,h,mh) +c +c computes matrix representation mh of linear +c portion of transfer map and an +c array h containing coefficients of polynomial +c generators of nonlinearities +c for transfer map of a short rf cavity with +c max potential drop phi0 and +c frequency w +c Written by Alex Dragt, ca 1983 +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + double precision mh + dimension h(monoms) + dimension mh(6,6) +c + call clear(h,mh) +c +c set coefficients of mh +c + do 40 k=1,6 + mh(k,k)=+1.0d0 + 40 continue + mh(6,5)=-(phi0*w*ts)/(brho*c) +c +c degree 4 only in short buncher limit +c + h(205)=+(phi0*(ts**3)*(w**3))/(24.d0*c*brho) + return + end +c +*********************************************************************** +c + subroutine ssssext(slength,sex,h,hm) +c +c computes matrix hm and polynomial array +c h of a sextupole of length slength (meters) and with strength +c sex (tesla/meter^2) using the SSS algorithm. +c The vector potential is A_z=-(sex/3)(x**3-3xy**2). +c +c MARYLIE5.0 upgrade. +c Written by M.Venturini 5 Aug 1997. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + dimension h(monoms),hm(6,6) +c + dimension p(6) +c + call clear(h,hm) +c + p(1) = slength/sl + p(2) =0.d0 + p(3) =0.d0 +cryne 6/21/2002 p(4) =.1d0 + p(4) =1.d-4 + p(5) =0.d0 + p(6) =0.d0 +cryne p(6) =12 +c + call hamdrift(h) +c +cryne 6/21/2002 modified to multiply by sl**3: + sex3brho=sex/3.d0/brho*sl**3 +c + h(28)=sex3brho + h(39)=-3*sex3brho +c + write(jodf,*)'ssssext has been used' + write(jodf,*)'eps=',p(4) +c +c call unixtime(ti1) + call sss(p,h,hm) +c call unixtime(ti2) +c t3=ti2-ti1 +c write(jof,*) 'Execution time in seconds =',t3 +c write(jof,*) ' ' +c write(jodf,*) 'Execution time in seconds =',t3 +c write(jodf,*) ' ' +c + return + end +c +************************************************************************ +c + subroutine sext(el,gb0,h,hm) +c +c computes matrix mh and polynomial h +c for sextupole of length l with strength +c gb0 (in tesla/meter**2). routine assumes +c a vector potential of the form +c (gb0/3)(x**3-3xy**2) +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + dimension h(monoms) + dimension hm(6,6) +c + call ssssext(el,gb0,h,hm) +c + return + end +c +*********************************************************************** +c + subroutine thnl (lsqdnr,lsqdsk,lssxnr,lssxsk,lsocnr,lsocsk,h,mh) +c Does the thin lens map up through octupole. +c The length-strength product may be given for normal and skew +c Quads, sextupoles, and octupoles. The skew elements are +c rotated clockwise looking in the direction of the beam +c by half the pole symmetry angle +c (45, 30, 22.5 degrees respectively). +c Written by Liam Healy, February 28, 1985. +c + use beamdata + use lieaparam, only : monoms +c----Variables---- +c h, mh = output array and matrix + double precision h(monoms),mh(6,6) +c ls, f = length*strength (l*gb0), factor (used in calculation) +c qd, sx, oc : quad, sextupole, octupole +c nr, sk : normal, skew + double precision lsqdnr,lsqdsk,lssxnr,lssxsk,lsocnr,lsocsk + double precision fqdnr,fqdsk,fsxnr,fsxsk,focnr,focsk +c common quantities +c double precision brho,c,gamma,gamm1,beta,achg,sl,ts +c +c----Routine---- + fqdnr=lsqdnr*sl/brho + fqdsk=lsqdsk*sl/brho + fsxnr=-lssxnr*sl**2/(3.*brho) + fsxsk=-lssxsk*sl**2/(3.*brho) + focnr=-lsocnr*sl**3/(4.*brho) + focsk=-lsocsk*sl**3/(4.*brho) + call ident(h,mh) +c Matrix (quadrupole) + mh(2,1)=-fqdnr + mh(2,3)=fqdsk + mh(4,3)=fqdnr + mh(4,1)=fqdsk +c Polynomials (sextupole) + h(28)=fsxnr + h(30)=-3.*fsxsk + h(39)=-3.*fsxnr + h(64)=fsxsk +c Polynomials (octupole) + h(84)=focnr + h(86)=-4.*focsk + h(95)=-6.*focnr + h(120)=4.*focsk + h(175)=focnr +c That's all folks + return + end +c +*********************************************************************** +c + subroutine twsm(iplane,phad,alpha,beta,fa,fm) +c this is a subroutine for computing a linear transfer map +c described in terms of twiss parameters. +c Written b y Alex Dragt, Fall 1986 + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' + dimension fa(monoms),fm(6,6) +c----- +c set map to the identity + call ident(fa,fm) +c compute entries +c w=phad*pi/(180.d0) + w=phad*pi180 + cw=cos(w) + sw=sin(w) + gam=(1.+alpha*alpha)/beta +c set up subscripts + k=2*(iplane-1) + isub1=1+k + isub2=2+k +c set up matrix + fm(isub1,isub1)=cw+alpha*sw + fm(isub1,isub2)=beta*sw + fm(isub2,isub1)=-gam*sw + fm(isub2,isub2)=cw-alpha*sw + return + end +c +*********************************************************************** +c + subroutine cplm(p,h,mh) +c compressed low order multipole +c Written by Alex Dragt and E. Forest, Fall 1986 + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + double precision l,lsc,l1,l2,l3,l4,l5,l6,l7,mh + dimension h(monoms),p(6) + dimension mh(6,6) +c + l=p(1) +c +c set up multipole strengths and normalizations +c eventually the division by l should be removed +c and correspondingly multiplications by l should be removed elsewhere +c in the code + gs=-p(2)/l + sgs=-p(3)/l + go=-p(4)/(4.d0*l) + sgo=-p(5)/(4.d0*l) +c + call clear(h,mh) + lsc=l/sl +c +c evaluate coefficients of h +c +c +c set coefficients of mh +c + do 40 i=1,6 + mh(i,i)=+1.0d0 + 40 continue +c +c set coefficients of h +c +c degree 3 +c + srs=(sgs*(sl**3))/brho + sro=(sgo*sl**4)/brho + rs=(gs*(sl**3))/brho + ro=(go*sl**4)/brho + l1=lsc + l2=lsc**2 + l3=lsc**3 + l4=lsc**4 + l5=lsc**5 + l6=lsc**6 + l7=lsc**7 + h(28)=l1*rs/3.d0 + h(34)=l3*rs/12.d0 + h(39)=-l1*rs + h(43)=-l3*rs/12.d0 + h(55)=-l3*rs/6.d0 + h(64)=l1*srs/3.d0 + h(68)=l3*srs/12.d0 + h(30)=-l1*srs + h(50)=-l3*srs/12.d0 + h(36)=-l3*srs/6.d0 +c +c degree 4 +c + sr2=srs**2 + r2=rs**2 + h(84)=l1*ro+l3*r2/12.d0+l3*sr2/12.d0 + h(90)=l3*ro/2.d0 + h(95)=l3*r2/6.d0+l3*sr2/6.d0-6.d0*l1*ro + h(99)=-l5*r2/30.d0-l5*sr2/30.d0-l3*ro/2.d0 + h(109)=l3*rs/6.d0/beta + h(111)=l5*r2/15.d0+l5*sr2/15.d0-2.d0*l3*ro + h(132)=-l3*rs/6.d0/beta + h(140)=l7*r2/1344.d0+l7*sr2/1344.d0+l5*ro/80.d0 + h(145)=-l5*r2/30.d0-l5*sr2/30.d0-l3*ro/2.d0 + h(149)=l7*r2/672.d0+l7*sr2/672.d0-3.d0*l5*ro/40.d0 + h(161)=-l3*rs/3.d0/beta + h(175)=l3*r2/12.d0+l3*sr2/12.d0+l1*ro + h(179)=l3*ro/2.d0 + h(195)=l7*r2/1344.d0+l7*sr2/1344.d0+l5*ro/80.d0 + h(142)=-l5*sro/20.d0 + h(120)=4.d0*l1*sro + h(156)=l3*sro + h(86)=-4.d0*l1*sro + h(124)=l3*sro + h(106)=-l3*sro + h(187)=l3*srs/beta/6.d0 + h(148)=-l3*srs/6.d0/beta + h(92)=-l3*sro + h(116)=-l3*srs/3.d0/beta + h(165)=l5*sro/20.d0 + return + end +c +*********************************************************************** +c + subroutine iftm(p,fa,fm) +c subroutine for a linear matrix via initial +c and final twiss parameters + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) + write(6,*) 'iftm not yet available' + return + end +c +*********************************************************************** +c + subroutine sol(p,fa,fm) +c subroutine for a solenoid + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) + write(6,*) 'sol not yet available' + return + end +c +*********************************************************************** +c + subroutine cfqd(pa,ha,hm) +c +c This subroutine computes the map for a combined function quadrupole. +c Written by A. Dragt on 9 January 1988. +c Modified by A. Dragt 8/28/97 to use SSS routine. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + dimension pa(6),pb(6) + dimension pc(6) + dimension ha(monoms) + dimension hm(6,6) +c + include 'parset.inc' +c---- +c set up parameters and control indices +c + al=pa(1) + ipset=nint(pa(2)) + ilfrn=nint(pa(3)) + itfrn=nint(pa(4)) +c +c compute useful numbers +c + sl2=sl*sl + sl3=sl*sl2 +c +c get multipole values from the parameter set ipset +c + if (ipset.lt.1 .or. ipset.gt.maxpst) then + do 50 i=1,6 + 50 pb(i) = 0.0d0 + else + do 60 i=1,6 + 60 pb(i) = pst(i,ipset) + endif +c +c compute multipole coefficients +c + bquad=pb(1) + aquad=pb(2) + bsex=pb(3) + asex=pb(4) + boct=pb(5) + aoct=pb(6) +c + fqdnr=bquad/brho + fqdsk=aquad/brho + fsxnr=bsex/(3.d0*brho) + fsxsk=asex/(3.d0*brho) + focnr=boct/(4.d0*brho) + focsk=aoct/(4.d0*brho) +c +c compute the Hamiltonian +c + call clear(ha,hm) +c +c drift part +c + call hamdrift(ha) +c +c quad terms +c + ha(7)=fqdnr*sl/2.d0 + ha(18)=-ha(7) + ha(9)=-fqdsk*sl +c +c sext terms +c + ha(28)=fsxnr*sl2 + ha(30)=-3.d0*fsxsk*sl2 + ha(39)=-3.d0*fsxnr*sl2 + ha(64)=fsxsk*sl2 +c +c oct terms +c + ha(84)=focnr*sl3 + ha(86)=-4.0d0*focsk*sl3 + ha(95)=-6.d0*focnr*sl3 + ha(120)=4.d0*focsk*sl3 + ha(175)=focnr*sl3 +c +c set up and call sss routine +c + pc(1)= al/sl + pc(2)= 0.d0 + pc(3)= 0.d0 + pc(4)= .05d0 + pc(5)= 0.d0 + pc(6)= 0.d0 +c + write(jodf,*) 'ssscfqd has been used' + write(jodf,*) 'eps=',pc(4) +c + call sss(pc,ha,hm) +c +c fringe field effects are put on in the subroutine lmnt +c + return + end +c +c******************************************************************* +c + subroutine thnh (p,h,mh) +c Does the thin lens map for decapoles and duodecapoles. +c The length-strength product may be given for normal and skew +c Decapoles and Duodecapoles. The skew elements are +c rotated clockwise looking in the direction of the beam +c by half the pole symmetry angle ( 18 degs. for decapoles, +c 15 degs. for duodecapoles). +c Written by F. Neri, July 29, 1988. +c + use beamdata + use lieaparam, only : monoms + implicit none +c----Variables---- +c h, mh = output array and matrix + double precision h(monoms),mh(6,6),p(6) +c ls, f = length*strength (l*gb0), factor (used in calculation) +c qd, sx, oc : quad, sextupole, octupole +c nr, sk : normal, skew + double precision lsdenr,lsdesk,lsdunr,lsdusk + double precision fdenr,fdesk,fdunr,fdusk +c common quantities +c double precision brho,c,gamma,gamm1,beta,achg,sl,ts + external ident +c +c----Routine---- + lsdenr = p(1) + lsdesk = p(2) + lsdunr = p(3) + lsdusk = p(4) + fdenr=-lsdenr*sl**4/(5.*brho) + fdesk=-lsdesk*sl**4/(5.*brho) + fdunr=-lsdunr*sl**5/(6.*brho) + fdusk=-lsdusk*sl**5/(6.*brho) + call ident(h,mh) +c Matrix is identity +c Polynomials (decapole) + h(210)=fdenr + h(212)=-5.*fdesk + h(221)=-10.*fdenr + h(246)=10.*fdesk + h(301)=5.*fdenr + h(406)=-fdesk +c Polynomials (duodecapole) + h(462)=fdunr + h(464)=-6.*fdusk + h(473)=-15.*fdunr + h(498)=20.*fdusk + h(553)=15.*fdunr + h(658)=-6.*fdusk + h(840)=-fdunr +c That's all folks + return + end +c====================================================================== +c THIRD ORDER ROUTINES +c====================================================================== +c + subroutine drift3(l,h,mh) +c +c generates linear matrix mh and +c array h containing nonlinearities +c for the transfer map describing +c a drift section of length l meters +c Written by D. Douglas, ca 1982 +c + use lieaparam, only : monoms + use beamdata + include 'impli.inc' + double precision l,h(monoms),mh(6,6) +c + double precision lsc +c dimension j(6) +c + call clear(h,mh) + lsc=l/sl +c +c add drift terms to mh +c + do 40 k=1,6 + mh(k,k)=+1.0d0 + 40 continue + mh(1,2)=+lsc + mh(3,4)=+lsc + mh(5,6)=+(lsc/((gamma**2)*(beta**2))) +c +c add drift terms to h +c +c degree 3 +c + h(53)=-(lsc/(2.0d0*beta)) + h(76)=-(lsc/(2.0d0*beta)) + h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) +c +c degree 4 +c + h(140)=-lsc/8.0d0 + h(149)=-lsc/4.0d0 + h(154)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 + h(195)=-lsc/8.0d0 + h(200)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 + h(209)=+lsc*(1.0d0-(5.0d0/beta**2))/(8.0d0*gamma**2*beta**2) +c + if(monoms.gt.209)h(210:monoms)=0.d0 + return + end +c +c====================================================================== +c + subroutine dquad3(l,gb0,h,mh) +c +c computes matrix mh and polynomial array +c h for horizontally defocussing quadrupole +c of length l meters and with field +c gradient of gb0 tesla/meter +c Written by D. Douglas, ca 1982 +c + use lieaparam, only : monoms + use beamdata + include 'impli.inc' + double precision h(monoms),mh(6,6) + double precision gb0,k,k2,k3,k4,l,lk,lkm,lsc +c +c write(6,*)'USING DQUAD3' + call clear(h,mh) + lsc=l/sl +c +c evaluate k,lk +c + arg=(gb0*(sl**2))/brho + k=dsqrt(arg) + lk=lsc*k + lkm=(-1.0d0)*lk +c +c set coefficients of mh +c + chlk=(dexp(lk)+dexp(lkm))/(2.0d0) + shlk=(dexp(lk)-dexp(lkm))/(2.0d0) + clk=dcos(lk) + slk=dsin(lk) + mh(1,1)=+chlk + mh(1,2)=+(shlk/k) + mh(2,2)=+chlk + mh(2,1)=+(k*shlk) + mh(3,3)=+clk + mh(3,4)=+(slk/k) + mh(4,4)=+clk + mh(4,3)=-(k*slk) + mh(5,5)=+1.0d0 + mh(5,6)=+(lsc/((gamma**2)*(beta**2))) + mh(6,6)=+1.0d0 +c +c set coefficients of h +c + tlk=(2.0d0)*lk + tlkm=(-1.0d0)*tlk + flk=(4.0d0)*lk + flkm=(-1.0d0)*flk + chtlk=(dexp(tlk)+dexp(tlkm))/2.0d0 + shtlk=(dexp(tlk)-dexp(tlkm))/2.0d0 + stlk=dsin(tlk) + ctlk=dcos(tlk) + chflk=(dexp(flk)+dexp(flkm))/2.0d0 + shflk=(dexp(flk)-dexp(flkm))/2.0d0 + sflk=dsin(flk) + cflk=dcos(flk) +c +c degree 3 +c + h(33)=+((k*(tlk-shtlk))/(8.0d0*beta)) + h(38)=-((1.0d0-chtlk)/(4.0d0*beta)) + h(53)=-((tlk+shtlk)/(8.0d0*k*beta)) + h(67)=-((k*(tlk-stlk))/(8.0d0*beta)) + h(70)=-((1.0d0-ctlk)/(4.0d0*beta)) + h(76)=-((tlk+stlk)/(8.0d0*beta*k)) + h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) +c +c degree 4 +c + k2=k*k + k3=k*k2 + k4=k2*k2 + c2=clk*clk + s2=slk*slk + c4=c2*c2 + s4=s2*s2 + ch2=chlk*chlk + sh2=shlk*shlk + ch4=ch2*ch2 + sh4=sh2*sh2 + h(84)=-k3*shflk/2.56d2+k3*shtlk/3.2d1-3.d0*k4*lsc/6.4d1 + h(85)=+k2*sh4/8.d0 + h(90)=-3.d0*k*shflk/1.28d2+3.d0*k2*lsc/3.2d1 + h(95)=+k3*(chtlk-2.d0)*stlk/6.4d1+k4*lsc/1.6d1 + &+k3*(ctlk-2.d0)*shtlk/6.4d1 + h(96)=-k2*shtlk*stlk/3.2d1+k2*(chtlk-2.d0)*ctlk/3.2d1 + &+k2/3.2d1 + h(99)=-k*(chtlk-2.d0)*stlk/6.4d1 + &-k*(ctlk+2.d0)*shtlk/6.4d1 + &+k2*lsc/1.6d1 + h(104)=3.d0*k*shtlk/(3.2d1*beta**2) + &-k2*lsc*(chtlk+2.d0)/(1.6d1*beta**2) + &+k*(1.d0-3.d0/beta**2)*(shtlk-tlk)/1.6d1 + h(105)=+(ch4-1.d0)/8.d0 + h(110)=-k2*shtlk*stlk/3.2d1-k2*chtlk*(ctlk-2.d0)/3.2d1 + &-k2/3.2d1 + h(111)=+k*chtlk*stlk/1.6d1-k*shtlk*ctlk/1.6d1 + h(114)=+shtlk*stlk/3.2d1-3.d0/3.2d1 + &+chtlk*(ctlk+2.d0)/3.2d1 + h(119)=-chflk/(6.4d1*beta**2) + &+lk*shtlk/(8.d0*beta**2) + &-chtlk/(1.6d1*beta**2)+ch4/(8.d0*beta**2)-ch2/(4.d0*beta**2) + &+1.3d1/(6.4d1*beta**2) + &+(1.d0-3.d0/beta**2)*(1.d0-ch2)/4.d0 + h(140)=-shflk/(2.56d2*k)-shtlk/(3.2d1*k)-3.d0*lsc/6.4d1 + h(145)=+k*(chtlk+2.d0)*stlk/6.4d1 + &+k*(ctlk-2.d0)*shtlk/6.4d1-k2*lsc/1.6d1 + h(146)=-shtlk*stlk/3.2d1-3.d0/3.2d1 + &+(chtlk+2.d0)*ctlk/3.2d1 + h(149)=-(chtlk+2.d0)*stlk/(6.4d1*k) + &-(ctlk+2.d0)*shtlk/(6.4d1*k)-lsc/1.6d1 + h(154)=+shtlk/(k*3.2d1*beta**2)-lsc*chtlk/(1.6d1*beta**2) + &+(1.d0-3.d0/beta**2)*(shtlk+tlk)/(1.6d1*k) + h(175)=-k3*sflk/2.56d2+k3*stlk/3.2d1-3.d0*k4*lsc/6.4d1 + h(176)=-k2*s4/8.d0 + h(179)=+3.d0*k*sflk/1.28d2-3.d0*k2*lsc/3.2d1 + h(184)=-k*(1.d0-3.d0/beta**2)*(stlk-tlk)/1.6d1 + &-3.d0*k*stlk/(3.2d1*beta**2) + &+k2*lsc*(ctlk+2.d0)/(1.6d1*beta**2) + h(185)=+(c4-1.d0)/8.d0 + h(190)=+(1.d0-3.d0/beta**2)*(1.d0-c2)/4.d0 + &-cflk/(6.4d1*beta**2)-lk*stlk/(8.d0*beta**2) + &-ctlk/(1.6d1*beta**2)+c4/(8.d0*beta**2) + &-c2/(4.d0*beta**2)+1.3d1/(6.4d1*beta**2) + h(195)=-sflk/(2.56d2*k)-stlk/(3.2d1*k)-3.d0*lsc/6.4d1 + h(200)=+(1.d0-3.d0/beta**2)*(tlk+stlk)/(1.6d1*k) + &+stlk/(k*3.2d1*beta**2)-lsc*ctlk/(1.6d1*beta**2) + h(209)=+lsc*(1.d0-5.d0/beta**2)/(8.d0*gamma**2*beta**2) +c + if(monoms.gt.209)h(210:monoms)=0.d0 + return + end +c +c====================================================================== +c + subroutine fquad3(l,gb0,h,mh) +c +c computes matrix mh and polynomial array +c h for horizontally focussing quadrupole +c of length l meters and with field +c gradient of gb0 tesla/meter +c Written by D. Douglas, ca 1982 +c + use lieaparam, only : monoms + use beamdata + include 'impli.inc' + double precision h(monoms),mh(6,6) +c + double precision gb0,k,k2,k3,k4,l,lk,lkm,lsc +c +c write(6,*)'USING FQUAD3' + call clear(h,mh) + lsc=l/sl +c +c evaluate k,lk +c + arg=(gb0*(sl**2))/brho + k=dsqrt(arg) + lk=lsc*k + lkm=(-1.0d0)*lk +c +c set coefficients of mh +c + chlk=(dexp(lk)+dexp(lkm))/(2.0d0) + shlk=(dexp(lk)-dexp(lkm))/(2.0d0) + clk=dcos(lk) + slk=dsin(lk) + mh(3,3)=+chlk + mh(3,4)=+(shlk/k) + mh(4,4)=+chlk + mh(4,3)=+(k*shlk) + mh(1,1)=+clk + mh(1,2)=+(slk/k) + mh(2,2)=+clk + mh(2,1)=-(k*slk) + mh(5,5)=+1.0d0 + mh(5,6)=+(lsc/((gamma**2)*(beta**2))) + mh(6,6)=+1.0d0 +c +c set coefficients of h +c + tlk=(2.0d0)*lk + tlkm=(-1.0d0)*tlk + flk=(4.0d0)*lk + flkm=(-1.0d0)*flk + chtlk=(dexp(tlk)+dexp(tlkm))/2.0d0 + shtlk=(dexp(tlk)-dexp(tlkm))/2.0d0 + stlk=dsin(tlk) + ctlk=dcos(tlk) + chflk=(dexp(flk)+dexp(flkm))/2.0d0 + shflk=(dexp(flk)-dexp(flkm))/2.0d0 + sflk=dsin(flk) + cflk=dcos(flk) +c +c degree 3 +c + h(67)=+((k*(tlk-shtlk))/(8.0d0*beta)) + h(70)=-((1.0d0-chtlk)/(4.0d0*beta)) + h(76)=-((tlk+shtlk)/(8.0d0*k*beta)) + h(33)=-((k*(tlk-stlk))/(8.0d0*beta)) + h(38)=-((1.0d0-ctlk)/(4.0d0*beta)) + h(53)=-((tlk+stlk)/(8.0d0*beta*k)) + h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) +c +c degree 4 +c + k2=k*k + k3=k*k2 + k4=k2*k2 + c2=clk*clk + s2=slk*slk + c4=c2*c2 + s4=s2*s2 + ch2=chlk*chlk + sh2=shlk*shlk + ch4=ch2*ch2 + sh4=sh2*sh2 + h(175)=-k3*shflk/2.56d2+k3*shtlk/3.2d1-3.d0*k4*lsc/6.4d1 + h(176)=+k2*sh4/8.d0 + h(179)=-3.d0*k*shflk/1.28d2+3.d0*k2*lsc/3.2d1 + h(95)=+k3*(chtlk-2.d0)*stlk/6.4d1+k4*lsc/1.6d1 + &+k3*(ctlk-2.d0)*shtlk/6.4d1 + h(110)=-k2*shtlk*stlk/3.2d1+k2*(chtlk-2.d0)*ctlk/3.2d1 + &+k2/3.2d1 + h(145)=-k*(chtlk-2.d0)*stlk/6.4d1 + &-k*(ctlk+2.d0)*shtlk/6.4d1 + &+k2*lsc/1.6d1 + h(184)=+3.d0*k*shtlk/(3.2d1*beta**2) + &-k2*lsc*(chtlk+2.d0)/(1.6d1*beta**2) + &+k*(1.d0-3.d0/beta**2)*(shtlk-tlk)/1.6d1 + h(185)=+(ch4-1.d0)/8.d0 + h(96)=-k2*shtlk*stlk/3.2d1-k2*chtlk*(ctlk-2.d0)/3.2d1 + &-k2/3.2d1 + h(111)=+k*chtlk*stlk/1.6d1-k*shtlk*ctlk/1.6d1 + h(146)=+shtlk*stlk/3.2d1-3.d0/3.2d1 + &+chtlk*(ctlk+2.d0)/3.2d1 + h(190)=-chflk/(6.4d1*beta**2) + &+lk*shtlk/(8.d0*beta**2) + &-chtlk/(1.6d1*beta**2)+ch4/(8.d0*beta**2)-ch2/(4.d0*beta**2) + &+1.3d1/(6.4d1*beta**2) + &+(1.d0-3.d0/beta**2)*(1.d0-ch2)/4.d0 + h(195)=-shflk/(2.56d2*k)-shtlk/(3.2d1*k)-3.d0*lsc/6.4d1 + h(99)=+k*(chtlk+2.d0)*stlk/6.4d1 + &+k*(ctlk-2.d0)*shtlk/6.4d1-k2*lsc/1.6d1 + h(114)=-shtlk*stlk/3.2d1-3.d0/3.2d1 + &+(chtlk+2.d0)*ctlk/3.2d1 + h(149)=-(chtlk+2.d0)*stlk/(6.4d1*k) + &-(ctlk+2.d0)*shtlk/(6.4d1*k)-lsc/1.6d1 + h(200)=+shtlk/(k*3.2d1*beta**2)-lsc*chtlk/(1.6d1*beta**2) + &+(1.d0-3.d0/beta**2)*(shtlk+tlk)/(1.6d1*k) + h(84)=-k3*sflk/2.56d2+k3*stlk/3.2d1-3.d0*k4*lsc/6.4d1 + h(85)=-k2*s4/8.d0 + h(90)=+3.d0*k*sflk/1.28d2-3.d0*k2*lsc/3.2d1 + h(104)=-k*(1.d0-3.d0/beta**2)*(stlk-tlk)/1.6d1 + &-3.d0*k*stlk/(3.2d1*beta**2) + &+k2*lsc*(ctlk+2.d0)/(1.6d1*beta**2) + h(105)=+(c4-1.d0)/8.d0 + h(119)=+(1.d0-3.d0/beta**2)*(1.d0-c2)/4.d0 + &-cflk/(6.4d1*beta**2)-lk*stlk/(8.d0*beta**2) + &-ctlk/(1.6d1*beta**2)+c4/(8.d0*beta**2) + &-c2/(4.d0*beta**2)+1.3d1/(6.4d1*beta**2) + h(140)=-sflk/(2.56d2*k)-stlk/(3.2d1*k)-3.d0*lsc/6.4d1 + h(154)=+(1.d0-3.d0/beta**2)*(tlk+stlk)/(1.6d1*k) + &+stlk/(k*3.2d1*beta**2)-lsc*ctlk/(1.6d1*beta**2) + h(209)=+lsc*(1.d0-5.d0/beta**2)/(8.d0*gamma**2*beta**2) +c + if(monoms.gt.209)h(210:monoms)=0.d0 + return + end +c +*********************************************************************** +c + subroutine sext3(l,gb0,h,mh) +c +c computes matrix mh and polynomial h +c for sextupole of length l with strength +c gb0 (in tesla/meter**2). routine assumes +c a vector potential of the form +c (gb0/3)(x**3-3xy**2) +c Written by D. Douglas, ca 1982 +c + use lieaparam, only : monoms + use beamdata + include 'impli.inc' + double precision l,lsc,lsc2,lsc3,lsc4,lsc5,lsc6,lsc7,mh + dimension h(monoms) + dimension mh(6,6) +c + call clear(h,mh) + lsc=l/sl +c +c evaluate coefficients of h +c +c +c set coefficients of mh +c + do 40 i=1,6 + mh(i,i)=+1.0d0 + 40 continue + mh(1,2)=+lsc + mh(3,4)=+lsc + mh(5,6)=+(lsc/((gamma**2)*(beta**2))) +c +c set coefficients of h +c +c degree 3 +c + rk=-(gb0*(sl**3))/(brho*3.0d0) + h(28)=+(lsc*rk) + h(29)=-((3.0d0*(lsc**2)*rk)/2.0d0) + h(34)=+((lsc**3)*rk) + h(39)=-(3.0d0*lsc*rk) + h(40)=+(3.0d0*(lsc**2)*rk) + h(43)=-((lsc**3)*rk) + h(49)=-(((lsc**4)*rk)/4.0d0) + h(53)=-(lsc/(2.0d0*beta)) + h(54)=+((3.0d0*(lsc**2)*rk)/2.0d0) + h(55)=-(2.0d0*(lsc**3)*rk) + h(58)=+((3.0d0*(lsc**4)*rk)/4.0d0) + h(76)=-(lsc/(2.0d0*beta)) + h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) +c +c degree 4 +c + lsc2=lsc**2 + lsc3=lsc**3 + lsc4=lsc**4 + lsc5=lsc**5 + lsc6=lsc**6 + lsc7=lsc**7 + rk2=rk**2 + h(84)=+7.5d-1*rk2*lsc3 + h(85)=-1.5d0*rk2*lsc4 + h(90)=+1.125d0*rk2*lsc5 + h(95)=+1.5d0*rk2*lsc3 + h(96)=-1.5d0*rk2*lsc4 + h(99)=+3.d0*rk2*lsc5/4.d1 + h(105)=-3.75d-1*rk2*lsc6 + h(109)=+rk*lsc3/(2.0d0*beta) + h(110)=-1.5d0*rk2*lsc4 + h(111)=+2.1d0*rk2*lsc5 + h(114)=-3.75d-1*rk2*lsc6 + h(132)=-rk*lsc3/(2.0d0*beta) + h(140)=+3.0d0*rk2*lsc7/5.6d1-lsc/8.0d0 + h(144)=-rk*lsc4/(4.0d0*beta) + h(145)=+3.0d0*rk2*lsc5/4.d1 + h(146)=-3.75d-1*rk2*lsc6 + h(149)=+3.0d0*rk2*lsc7/2.8d1-lsc/4.0d0 + h(154)=+lsc*(1.0d0-(3.0d0/(beta**2)))/4.0d0 + h(161)=-rk*lsc3/beta + h(167)=+7.5d-1*rk*lsc4/beta + h(175)=+7.5d-1*rk2*lsc3 + h(176)=-1.5d0*rk2*lsc4 + h(179)=+1.125d0*rk2*lsc5 + h(185)=-3.75d-1*rk2*lsc6 + h(195)=+3.0d0*rk2*lsc7/5.6d1-lsc/8.0d0 + h(200)=+lsc*(1.d0-(3.d0/(beta**2)))/4.d0 + h(209)=+(lsc*(1.d0-(5.0d0/beta**2)))/(8.0d0*gamma**2*beta**2) +c + if(monoms.gt.209)h(210:monoms)=0.d0 + return + end +c +*********************************************************************** +c + subroutine octm3(l,gb0,h,mh) +c +c computes matrix mh and polynomial h for +c magnetic octupole with length l meters and vector +c potential of the form (gb0/4.)*(+x**4-6*x**2*y**2+y**4) +c Written by D. Douglas, ca 1982 +c + use lieaparam, only : monoms + use beamdata + include 'impli.inc' + double precision l,h(monoms),mh(6,6) + double precision lsc +c + call clear(h,mh) + lsc=l/sl +c +c enter matrix elements +c + do 40 i=1,6 + mh(i,i)=+1.0d0 + 40 continue + mh(1,2)=+lsc + mh(3,4)=+lsc + mh(5,6)=+(lsc/((gamma**2)*(beta**2))) +c +c set coefficients of h +c +c degree 3 +c + h(53)=-(lsc/(2.0d0*beta)) + h(76)=-(lsc/(2.0d0*beta)) + h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) +c +c degree 4 +c + ap=-(sl**4)*gb0/(4.d0*brho) + h(84)=+lsc*ap + h(85)=-2.0d0*(lsc**2)*ap + h(90)=2.0d0*(lsc**3)*ap + h(95)=-6.0d0*lsc*ap + h(96)=6.d0*lsc**2*ap + h(99)=-(2.0d0*(lsc**3)*ap) + h(105)=-(lsc**4)*ap + h(110)=+6.0d0*(lsc**2)*ap + h(111)=-(8.0d0*(lsc**3)*ap) + h(114)=+3.0d0*(lsc**4)*ap + h(140)=-lsc/8.0d0+(lsc**5)*ap/5.0d0 + h(145)=-(2.0d0*(lsc**3)*ap) + h(146)=+3.0d0*(lsc**4)*ap + h(149)=-lsc/4.0d0-(6.0d0*(lsc**5)*ap)/5.0d0 + h(154)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 + h(175)=+lsc*ap + h(176)=-2.0d0*(lsc**2)*ap + h(179)=+2.0d0*(lsc**3)*ap + h(185)=-(lsc**4)*ap + h(195)=-lsc/8.0d0+(lsc**5)*ap/5.0d0 + h(200)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 + h(209)=+(lsc*(1.d0-(5.d0/beta**2)))/(8.d0*gamma**2*beta**2) +c + if(monoms.gt.209)h(210:monoms)=0.d0 + return + end +c +*********************************************************************** diff --git a/OpticsJan2020/MLI_light_optics/Src/env.f b/OpticsJan2020/MLI_light_optics/Src/env.f new file mode 100644 index 0000000..0793386 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/env.f @@ -0,0 +1,844 @@ + subroutine initenv(p,icorrel) +c R. Ryne 4/7/2004 +c routine to initialize rms envelopes. +c this assumes that the units are those used in the current ML/I simulation. +c input parameters array elements: +c p(1)=x_rms, p(2)=px_rms, p(3)=xpx_rms, p(4)=x_emittance_normalized_rms +c p(5)=y_rms, p(6)=py_rms, p(7)=ypy_rms, p(8)=y_emittance_normalized_rms +c p(9)=t_rms, p(10)=pt_rms, p(11)=tpt_rms, p(12)=t_emittance_normalized_rms +c p(13-15)=canonical momenta conjugate to p(1-3), respectively +c icorrel describes whether xpx, ypy, tpt are scaled (i.e. correlations) or not +c e.g. if icorrel=0, then is really +c if icorrel=1, then is really /(xrms*pxrms)? +c and similary for and +c +c NOTE WELL: This routine assumes that, at the point the initial values +c are set, the beam is not inside an rf cavity. In this case, +c canonical mom. conjugate to x_rms = /xrms +c canonical mom. conjugate to y_rms = /yrms +c canonical mom. conjugate to t_rms = /trms +c If the beam is initialized inside an rf cavity, this does not hold. + use parallel, only : idproc + include 'impli.inc' + common/envdata/env(6),envold(6),emap(6,6) + common/emitdata/emxn2,emyn2,emtn2 + dimension p(*) + if(p(1).eq.0.d0)then + if(idproc.eq.0)then + write(6,*)'error(initenv): must specify rms beam sizes' + endif + call myexit + endif +c +c X-PX: + env(1)=p(1) + if(p(13).ne.0.d0)then +c user is specifying cpx (canonical px) and emittance: + env(2)=p(13) + emxn2=p(4)**2 + else +c user is specifying px & xpx, px & emit, or xpx & emit: + if(p(4).eq.0.d0)then !user specifying px & xpx + if(icorrel.eq.0)then + env(2)=p(3)/p(1) + emxn2=p(1)**2*p(2)**2-p(3)**2 + endif + if(icorrel.eq.1)then + env(2)=p(3)*p(2) + emxn2=p(1)**2*p(2)**2*(1.d0-p(3)**2) + endif + else + if(p(2).ne.0.d0)then !user specifying px & emit + emxn2=p(4)**2 + xpx2=p(1)**2*p(2)**2-emxn2 + env(2)=sqrt(xpx2)/p(1) + else !user specifying xpx & emit + env(2)=p(3)/p(1) + emxn2=p(4)**2 + endif + endif + endif +c +c Y-PY: + env(3)=p(5) + if(p(14).ne.0.d0)then +c user is specifying cpy (canonical py) and emittance: + env(4)=p(14) + emyn2=p(8)**2 + else +c user is specifying py & ypy, py & emit, or ypy & emit: + if(p(8).eq.0.d0)then !user specifying py & ypy + if(icorrel.eq.0)then + env(4)=p(7)/p(5) + emyn2=p(5)**2*p(6)**2-p(7)**2 + endif + if(icorrel.eq.1)then + env(4)=p(7)*p(6) + emyn2=p(5)**2*p(6)**2*(1.d0-p(7)**2) + endif + else + if(p(6).ne.0.d0)then !user specifying py & emit + emyn2=p(8)**2 + ypy2=p(5)**2*p(6)**2-emyn2 + env(4)=sqrt(ypy2)/p(5) + else !user specifying ypy & emit + env(4)=p(7)/p(5) + emyn2=p(8)**2 + endif + endif + endif +c +c T-PT: + env(5)=p(9) + if(p(15).ne.0.d0)then +c user is specifying cpt (canonical pt) and emittance: + env(6)=p(15) + emtn2=p(12)**2 + else +c user is specifying pt & tpt, pt & emit, or tpt & emit: + if(p(12).eq.0.d0)then !user specifying pt & tpt + if(icorrel.eq.0)then + env(6)=p(11)/p(9) + emtn2=p(9)**2*p(10)**2-p(11)**2 + endif + if(icorrel.eq.1)then + env(6)=p(11)*p(10) + emtn2=p(9)**2*p(10)**2*(1.d0-p(11)**2) + endif + else + if(p(10).ne.0.d0)then !user specifying pt & emit + emtn2=p(12)**2 + tpt2=p(9)**2*p(10)**2-emtn2 + env(6)=sqrt(tpt2)/p(9) + else !user specifying tpt & emit + env(6)=p(11)/p(9) + emtn2=p(12)**2 + endif + endif + endif +c initialize the matrix for the envelope map, +c in case the user wants to compute it: + emap(1:6,1:6)=0.d0 + do i=1,6 + emap(i,i)=1.d0 + enddo +c store the initial values of the envelopes, +c in case the user wants to perform a contraction mapping later: + envold(1:6)=env(1:6) + return + end +c + subroutine contractenv(delta) +c perform contraction map on envelopes to find fixed point (rms matched beam). +c delta is the residual, i.e. a metric to describe how close the beam is +c to a match. + use parallel, only : idproc + use beamdata + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' + include 'map.inc' + include 'setref.inc' + dimension d(6),v(6),ca(6),amat(6,6) + common/envdata/env(6),envold(6),emap(6,6) + dimension augm(6,7) +c Apply the contraction mapping, C, to the vector a : +c Ca = a + 1/(I-M) * (a-Na) +c where Na == Script m acting on a == numerical integration +c using a for initial values. +c +c if(idproc.eq.0)then +c write(6,*)'***********************entering contractenv' +c write(6,*)'***********************entering contractenv, env=' +c write(6,51)env(1:6) +c endif +c 51 format(6(1x,1pe12.5)) +c + d(:)=envold(:)-env(:) +c write(6,*)'***********************d(1:6)=' +c write(6,51)d(1:6) +c write(6,*)'***********************emap(1:6,1:6)=' +c write(6,51)emap(1:6,1:6) +c + amat(:,:)=-emap(:,:) + do i=1,6 + amat(i,i)=1.+amat(i,i) + enddo +c Compute 1/(I-M) * d by solving (I-M)v=d for v : +c write(6,*)'calling leshs, v(1-6)=',v(1:6) + call leshs(v,6,amat,d,augm,det) +c write(6,*)'returned from leshs, v(1-6)=',v(1:6) +c Now compute Ca: + ca(:)=envold(:)-v(:) +c check for convergence: + vnorm=sqrt(v(1)**2+v(2)**2+v(3)**2+v(4)**2+v(5)**2+v(6)**2) + anorm=sqrt(envold(1)**2+envold(2)**2+envold(3)**2+ & + & envold(4)**2+envold(5)**2+envold(6)**2) + delta=vnorm/anorm +c if(idproc.eq.0)write(6,*)'delta=',delta +c if(delta.lt.1.d-9)then +c if(idproc.eq.0)then +c write(6,*)'SEARCH CONVERGED' +c endif +c endif +c continue the contraction map procedure: + envold(:)=ca(:) + env(:)=envold(:) + emap(:,:)=0.d0 + do i=1,6 + emap(i,i)=1.d0 + enddo +ccccc reftraj(1:6)=refsave(1,1:6) +ccccc arclen=arcsave(1) +ccccc brho=brhosav(1) +ccccc gamma=gamsav(1) +ccccc gamm1=gam1sav(1) +ccccc beta=betasav(1) +c +c diagnostic for debug: +c if(idproc.eq.0)then +c write(6,*)'matrix:' +c write(6,51)(emap(1,j),j=1,6) +c write(6,51)(emap(2,j),j=1,6) +c write(6,51)(emap(3,j),j=1,6) +c write(6,51)(emap(4,j),j=1,6) +c write(6,51)(emap(5,j),j=1,6) +c write(6,51)(emap(6,j),j=1,6) +c endif +c write(6,*)'***********************leaving contractenv' +c write(6,*)'***********************leaving contractenv, env=' +c write(6,51)env(1:6) + return + end +c + subroutine envtrace(mh) +c "Envelope tracking" routine applies the linear map to the envelopes. +c This is used along with the split-operator symplectic integrator +c to advance the envelope equations. (The space-charge and emittance +c terms are handled in mid-step in subroutine envkick) +c R. Ryne 4/7/2004 + include 'impli.inc' + double precision mh(6,6) + double precision vec(6) + common/envdata/env(6),envold(6),emap(6,6) +c write(6,*)'here I am in *envtrace*; env(1:6)=' +c write(6,51)env(1:6) +c write(6,*)'mh(1:6,1:6)=' +c write(6,51)mh(1:6,1:6) +c 51 format(6(1x,1pe12.5)) +c initialize zlm + vec(1:6)=0.d0 +c + do 100 i=1,6 + do 90 j=1,6 + vec(i)=vec(i) + mh(i,j)*env(j) + 90 continue + 100 continue + env(1:6)=vec(1:6) +c write(6,*)'new values of env(1),env(2),env(5),env(6)=' +c write(6,*)env(1),env(2),env(5),env(6) +c code to advanced the momentum portion of the "envelope map," i.e. the +c linear map for envelope dynamics around the env reference envelope: + call mmult(mh,emap,emap) + return + end +c + subroutine envkick(tau) + use parallel, only : idproc + use beamdata +ccc real*8 :: brho,gamma,gamm1,beta,achg,pmass,bfreq,bcurr,c +ccc real*8 :: sl,p0sc,ts,omegascl,freqscl + include 'impli.inc' + dimension etmp(6,6) + common/envdata/env(6),envold(6),emap(6,6) + common/emitdata/emxn2,emyn2,emtn2 +c write(6,*)'here I am in envkick; env(1),env(3),env(5)=' +c write(6,*)env(1),env(3),env(5) +c formulas are coded in terms of xl,xp,xw; connect to parameters in acceldata: + clite=299792458.d0 + pi=2.d0*asin(1.d0) + fpei=(clite**2)*1.d-7 + q=1.d0 + xmc2=pmass + xl=sl + xp=p0sc + xw=omegascl +c The commented out statement below is probably wrong, because +c bfreq should only affect the total charge. +c The statement makes sense only if w is the scale ang freq. +c w=2.d0*pi*bfreq + w=xw + p0=gamma*beta*pmass/clite + xmp0=1./(gamma*beta*clite) +c + uu=env(1)**2 + vv=env(3)**2 + ww=(env(5)*gamma*beta*clite/(w*xl))**2 +c write(6,*)'new values of uu,vv,ww=',uu,vv,ww +cryne note: g311,g131,g113 all vary as ~1/[length**3]; g511 etc vary as 1/l**5 +cryne In other words, if env(1),env(3),and env(5) are doubled, then +cryne g311,g131,g113 are reduced by a factor of 8 (i.e. 8 times smaller) +c write(6,*)'calling scdrd' + call scdrd(uu,vv,ww,g311,g131,g113,g511,g151,g115,g331,g313,g133) +c write(6,*)'returned from scdrd' +cryne qtot=bcurr*2.*pi/w + qtot=bcurr/bfreq + xi0=xmc2*clite/(q*fpei) + xlam3=1.d0/(5.d0*sqrt(5.d0)) + qcon=1.5d0*qtot*xlam3*clite/(xi0*(beta*gamma*xl)**2)*p0/xp + tcon=qcon*(gamma*beta*clite/(w*xl))**2 +c + r11= qcon*g311*env(1) +emxn2*(xp/(p0*xl))/env(1)**3 + r33= qcon*g131*env(3) +emyn2*(xp/(p0*xl))/env(3)**3 + r55= tcon*g113*env(5)+emtn2/env(5)**3*(xl*xp*xw*xw*xmp0*xmp0/p0) +c + env(2)=env(2)+r11*tau + env(4)=env(4)+r33*tau + env(6)=env(6)+r55*tau +c write(6,*)'done updating env; preparing to update emap' +c +c Advance emap, which is transfer map around this envelope: +c Note: there is probably a bug in the original envelope code, fixsc3, +c which refers to the variable w0 (the cavity ang freq) in the formulas below. +c In fixsc3, w0 is set equal to the scale angular frequency. +c In other words, fixsc3 *only* works when the cav ang freq=scale ang freq. +c The two formulas are commented out below and replaced by the correct ones. +c + xyfac=xp/(p0*xl) +c xyfac=0.d0 +c + s11=3.*emxn2*xyfac/(uu**2)+qcon*(3.*uu*g511-g311) + s33=3.*emyn2*xyfac/(vv**2)+qcon*(3.*vv*g151-g131) +c s55=3.d0*(w0*xmp0*xl)**2*emtn2*xyfac/env(5)**4+ & + s55=3.d0*(xw*xmp0*xl)**2*emtn2*xyfac/env(5)**4+ & + & tcon*(3.d0*ww*g115-g113) + s13=qcon*env(1)*env(3)*g331 + s15=tcon*env(1)*env(5)*g313 + s35=tcon*env(3)*env(5)*g133 + s31=s13 + s51=s15 + s53=s35 + s22=xyfac + s44=s22 +c s66=(w0*xmp0*xl)**2*s22 + s66=(xw*xmp0*xl)**2*s22 +c + etmp(1:6,1:6)=0.d0 + do i=1,6 + etmp(i,i)=1.d0 + enddo + etmp(2,1)=-tau*s11 + etmp(4,3)=-tau*s33 + etmp(6,5)=-tau*s55 +c + etmp(2,3)=-tau*s13 + etmp(2,5)=-tau*s15 +c + etmp(4,1)=-tau*s13 + etmp(4,5)=-tau*s35 +c + etmp(6,1)=-tau*s15 + etmp(6,3)=-tau*s35 +c +c write(6,*)'calling mmult' + call mmult(etmp,emap,emap) !(left,right,out) +cxxx call mmult(emap,etmp,emap) +c write(6,*)'leaving envkick' + return + end + +c===================================================================== + subroutine scdrd(uu,vv,ww, & + &h311,h131,h113,h511,h151,h115,h331,h313,h133) + include 'impli.inc' + alpha=3.d0/(uu+vv+ww) + a=alpha*uu + b=alpha*vv + c=alpha*ww + fac5=sqrt(alpha**3) + fac7=sqrt(alpha**5) + eps=1.d-4 +c + result1=drd(b,c,a,ierr) + if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' + result1=2.d0/3.d0*result1 + h311=result1*fac5 +c + result2=drd(a,c,b,ierr) + if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' + result2=2.d0/3.d0*result2 + h131=result2*fac5 +c + result3=drd(a,b,c,ierr) + if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' + result3=2.d0/3.d0*result3 + h113=result3*fac5 +c----------------------------------------------------- + result1plus=drd(b*(1.d0+eps),c,a,ierr) + result1minus=drd(b*(1.d0-eps),c,a,ierr) + if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' + deriv=(result1plus-result1minus)/(2.d0*eps*b) + h331=-deriv*2.d0/3.d0*fac7*2.d0 +c + result1plus=drd(c*(1.d0+eps),b,a,ierr) + result1minus=drd(c*(1.d0-eps),b,a,ierr) + if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' + deriv=(result1plus-result1minus)/(2.d0*eps*c) + h313=-deriv*2.d0/3.d0*fac7*2.d0 +c + result1plus=drd(b*(1.d0+eps),a,c,ierr) + result1minus=drd(b*(1.d0-eps),a,c,ierr) + if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' + deriv=(result1plus-result1minus)/(2.d0*eps*b) + h133=-deriv*2.d0/3.d0*fac7*2.d0 +c----------------------------------------------------- + result1plus=drd(b,c,a*(1.d0+eps),ierr) + result1minus=drd(b,c,a*(1.d0-eps),ierr) + if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' + deriv=(result1plus-result1minus)/(2.d0*eps*a) + h511=-deriv*2.d0/3.d0*fac7*2.d0/3.d0 +c + result1plus=drd(a,c,b*(1.d0+eps),ierr) + result1minus=drd(a,c,b*(1.d0-eps),ierr) + if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' + deriv=(result1plus-result1minus)/(2.d0*eps*b) + h151=-deriv*2.d0/3.d0*fac7*2.d0/3.d0 +c + result1plus=drd(a,b,c*(1.d0+eps),ierr) + result1minus=drd(a,b,c*(1.d0-eps),ierr) + if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' + deriv=(result1plus-result1minus)/(2.d0*eps*c) + h115=-deriv*2.d0/3.d0*fac7*2.d0/3.d0 +c----------------------------------------------------- + return + end +c +c==================================================================== +c + DOUBLE PRECISION FUNCTION DRD(X,Y,Z,IER) DRD 3 +C***BEGIN PROLOGUE DRD DRD 4 +C***DATE WRITTEN 790801 (YYMMDD) DRD 5 +C***REVISION DATE 861211 (YYMMDD) DRD 6 +C***CATEGORY NO. C14 DRD 7 +C***KEYWORDS LIBRARY=SLATEC,TYPE=DOUBLE PRECISION(RD-S DRD-D), DRD 8 +C COMPLETE ELLIPTIC INTEGRAL,DUPLICATION THEOREM, DRD 9 +C INCOMPLETE ELLIPTIC INTEGRAL,INTEGRAL OF THE SECOND KIND, DRD 10 +C TAYLOR SERIES DRD 11 +C***AUTHOR CARLSON, B.C., AMES LABORATORY-DOE DRD 12 +C IOWA STATE UNIVERSITY, AMES, IOWA 50011 DRD 13 +C NOTIS, E.M., AMES LABORATORY-DOE DRD 14 +C IOWA STATE UNIVERSITY, AMES, IOWA 50011 DRD 15 +C PEXTON, R.L., LAWRENCE LIVERMORE NATIONAL LABORATORY DRD 16 +C LIVERMORE, CALIFORNIA 94550 DRD 17 +C***PURPOSE Compute the INCOMPLETE or COMPLETE Elliptic integral of DRD 18 +C the 2nd kind. For X and Y nonnegative, X+Y and Z positive, DRD 19 +C DRD(X,Y,Z) = Integral from ZERO to INFINITY of DRD 20 +C -1/2 -1/2 -3/2 DRD 21 +C (3/2)(t+X) (t+Y) (t+Z) dt. DRD 22 +C If X or Y is zero, the integral is COMPLETE. DRD 23 +C***DESCRIPTION DRD 24 +C DRD 25 +C 1. DRD DRD 26 +C Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL DRD 27 +C of the second kind DRD 28 +C Standard FORTRAN function routine DRD 29 +C Double precision version DRD 30 +C The routine calculates an approximation result to DRD 31 +C DRD(X,Y,Z) = Integral from zero to infinity of DRD 32 +C -1/2 -1/2 -3/2 DRD 33 +C (3/2)(t+X) (t+Y) (t+Z) dt, DRD 34 +C where X and Y are nonnegative, X + Y is positive, and Z is DRD 35 +C positive. If X or Y is zero, the integral is COMPLETE. DRD 36 +C The duplication theorem is iterated until the variables are DRD 37 +C nearly equal, and the function is then expanded in Taylor DRD 38 +C series to fifth order. DRD 39 +C DRD 40 +C 2. Calling Sequence DRD 41 +C DRD 42 +C DRD( X, Y, Z, IER ) DRD 43 +C DRD 44 +C Parameters On Entry DRD 45 +C Values assigned by the calling routine DRD 46 +C DRD 47 +C X - Double precision,nonnegative variable DRD 48 +C DRD 49 +C Y - Double precision,nonnegative variable DRD 50 +C DRD 51 +C X + Y is positive DRD 52 +C DRD 53 +C Z - Double precision,positive variable DRD 54 +C DRD 55 +C DRD 56 +C DRD 57 +C On Return (values assigned by the DRD routine) DRD 58 +C DRD 59 +C DRD - Double precision approximation to the integral DRD 60 +C DRD 61 +C DRD 62 +C IER - Integer DRD 63 +C DRD 64 +C IER = 0 Normal and reliable termination of the DRD 65 +C routine. It is assumed that the requested DRD 66 +C accuracy has been achieved. DRD 67 +C DRD 68 +C IER > 0 Abnormal termination of the routine DRD 69 +C DRD 70 +C DRD 71 +C X, Y, Z are unaltered. DRD 72 +C DRD 73 +C 3. Error Messages DRD 74 +C DRD 75 +C Value of IER assigned by the DRD routine DRD 76 +C DRD 77 +C Value assigned Error message printed DRD 78 +C IER = 1 DMIN1(X,Y) .LT. 0.0D0 DRD 79 +C = 2 DMIN1(X + Y, Z ) .LT. LOLIM DRD 80 +C = 3 DMAX1(X,Y,Z) .GT. UPLIM DRD 81 +C DRD 82 +C DRD 83 +C 4. Control Parameters DRD 84 +C DRD 85 +C Values of LOLIM,UPLIM,and ERRTOL are set by the DRD 86 +C routine. DRD 87 +C DRD 88 +C LOLIM and UPLIM determine the valid range of X, Y, and Z DRD 89 +C DRD 90 +C LOLIM - Lower limit of valid arguments DRD 91 +C DRD 92 +C Not less than 2 / (machine maximum) ** (2/3). DRD 93 +C DRD 94 +C UPLIM - Upper limit of valid arguments DRD 95 +C DRD 96 +C Not greater than (0.1D0 * ERRTOL / machine DRD 97 +C minimum) ** (2/3), where ERRTOL is described below. DRD 98 +C In the following table it is assumed that ERRTOL will DRD 99 +C never be chosen smaller than 1.0D-5. DRD 100 +C DRD 101 +C DRD 102 +C Acceptable values for: LOLIM UPLIM DRD 103 +C IBM 360/370 SERIES : 6.0D-51 1.0D+48 DRD 104 +C CDC 6000/7000 SERIES : 5.0D-215 2.0D+191 DRD 105 +C UNIVAC 1100 SERIES : 1.0D-205 2.0D+201 DRD 106 +C CRAY : 3.0D-1644 1.69D+1640 DRD 107 +C VAX 11 SERIES : 1.0D-25 4.5D+21 DRD 108 +C DRD 109 +C DRD 110 +C ERRTOL determines the accuracy of the answer DRD 111 +C DRD 112 +C The value assigned by the routine will result DRD 113 +C in solution precision within 1-2 decimals of DRD 114 +C "machine precision". DRD 115 +C DRD 116 +C ERRTOL Relative error due to truncation is less than DRD 117 +C 3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2. DRD 118 +C DRD 119 +C DRD 120 +C DRD 121 +C The accuracy of the computed approximation to the integral DRD 122 +C can be controlled by choosing the value of ERRTOL. DRD 123 +C Truncation of a Taylor series after terms of fifth order DRD 124 +C introduces an error less than the amount shown in the DRD 125 +C second column of the following table for each value of DRD 126 +C ERRTOL in the first column. In addition to the truncation DRD 127 +C error there will be round-off error, but in practice the DRD 128 +C total error from both sources is usually less than the DRD 129 +C amount given in the table. DRD 130 +C DRD 131 +C DRD 132 +C DRD 133 +C DRD 134 +C Sample choices: ERRTOL Relative truncation DRD 135 +C error less than DRD 136 +C 1.0D-3 4.0D-18 DRD 137 +C 3.0D-3 3.0D-15 DRD 138 +C 1.0D-2 4.0D-12 DRD 139 +C 3.0D-2 3.0D-9 DRD 140 +C 1.0D-1 4.0D-6 DRD 141 +C DRD 142 +C DRD 143 +C Decreasing ERRTOL by a factor of 10 yields six moreDRD 144 +C decimal digits of accuracy at the expense of one orDRD 145 +C two more iterations of the duplication theorem. DRD 146 +C***LONG DESCRIPTION DRD 147 +C DRD 148 +C DRD Special Comments DRD 149 +C DRD 150 +C DRD 151 +C DRD 152 +C Check: DRD(X,Y,Z) + DRD(Y,Z,X) + DRD(Z,X,Y) DRD 153 +C = 3 / DSQRT(X * Y * Z), where X, Y, and Z are positive. DRD 154 +C DRD 155 +C DRD 156 +C On Input: DRD 157 +C DRD 158 +C X, Y, and Z are the variables in the integral DRD(X,Y,Z). DRD 159 +C DRD 160 +C DRD 161 +C On Output: DRD 162 +C DRD 163 +C DRD 164 +C X, Y, Z are unaltered. DRD 165 +C DRD 166 +C DRD 167 +C DRD 168 +C ******************************************************** DRD 169 +C DRD 170 +C WARNING: Changes in the program may improve speed at the DRD 171 +C expense of robustness. DRD 172 +C DRD 173 +C DRD 174 +C DRD 175 +C -------------------------------------------------------------------DRD 176 +C DRD 177 +C DRD 178 +C Special double precision functions via DRD and DRF DRD 179 +C DRD 180 +C DRD 181 +C Legendre form of ELLIPTIC INTEGRAL of 2nd kind DRD 182 +C DRD 183 +C ----------------------------------------- DRD 184 +C DRD 185 +C DRD 186 +C 2 2 2 DRD 187 +C E(PHI,K) = SIN(PHI) DRF(COS (PHI),1-K SIN (PHI),1) - DRD 188 +C DRD 189 +C 2 3 2 2 2 DRD 190 +C -(K/3) SIN (PHI) DRD(COS (PHI),1-K SIN (PHI),1) DRD 191 +C DRD 192 +C DRD 193 +C 2 2 2 DRD 194 +C E(K) = DRF(0,1-K ,1) - (K/3) DRD(0,1-K ,1) DRD 195 +C DRD 196 +C PI/2 2 2 1/2 DRD 197 +C = INT (1-K SIN (PHI) ) D PHI DRD 198 +C 0 DRD 199 +C DRD 200 +C Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind DRD 201 +C DRD 202 +C ----------------------------------------- DRD 203 +C DRD 204 +C 2 2 2 DRD 205 +C EL2(X,KC,A,B) = AX DRF(1,1+KC X ,1+X ) + DRD 206 +C DRD 207 +C 3 2 2 2 DRD 208 +C +(1/3)(B-A) X DRD(1,1+KC X ,1+X ) DRD 209 +C DRD 210 +C DRD 211 +C DRD 212 +C DRD 213 +C Legendre form of alternative ELLIPTIC INTEGRAL DRD 214 +C of 2nd kind DRD 215 +C DRD 216 +C ----------------------------------------- DRD 217 +C DRD 218 +C DRD 219 +C DRD 220 +C Q 2 2 2 -1/2 DRD 221 +C D(Q,K) = INT SIN P (1-K SIN P) DP DRD 222 +C 0 DRD 223 +C DRD 224 +C DRD 225 +C DRD 226 +C 3 2 2 2 DRD 227 +C D(Q,K) = (1/3) (SIN Q) DRD(COS Q,1-K SIN Q,1) DRD 228 +C DRD 229 +C DRD 230 +C DRD 231 +C DRD 232 +C Lemniscate constant B DRD 233 +C DRD 234 +C ----------------------------------------- DRD 235 +C DRD 236 +C DRD 237 +C DRD 238 +C DRD 239 +C 1 2 4 -1/2 DRD 240 +C B = INT S (1-S ) DS DRD 241 +C 0 DRD 242 +C DRD 243 +C DRD 244 +C B = (1/3) DRD (0,2,1) DRD 245 +C DRD 246 +C DRD 247 +C Heuman's LAMBDA function DRD 248 +C DRD 249 +C ----------------------------------------- DRD 250 +C DRD 251 +C DRD 252 +C DRD 253 +C (PI/2) LAMBDA0(A,B) = DRD 254 +C DRD 255 +C 2 2 DRD 256 +C = SIN(B) (DRF(0,COS (A),1)-(1/3) SIN (A) * DRD 257 +C DRD 258 +C 2 2 2 2 DRD 259 +C *DRD(0,COS (A),1)) DRF(COS (B),1-COS (A) SIN (B),1) DRD 260 +C DRD 261 +C 2 3 2 DRD 262 +C -(1/3) COS (A) SIN (B) DRF(0,COS (A),1) * DRD 263 +C DRD 264 +C 2 2 2 DRD 265 +C *DRD(COS (B),1-COS (A) SIN (B),1) DRD 266 +C DRD 267 +C DRD 268 +C DRD 269 +C Jacobi ZETA function DRD 270 +C DRD 271 +C ----------------------------------------- DRD 272 +C DRD 273 +C 2 2 2 2 DRD 274 +C Z(B,K) = (K/3) SIN(B) DRF(COS (B),1-K SIN (B),1) DRD 275 +C DRD 276 +C DRD 277 +C 2 2 DRD 278 +C *DRD(0,1-K ,1)/DRF(0,1-K ,1) DRD 279 +C DRD 280 +C 2 3 2 2 2 DRD 281 +C -(K /3) SIN (B) DRD(COS (B),1-K SIN (B),1) DRD 282 +C DRD 283 +C DRD 284 +C --------------------------------------------------------------------- DRD 285 +C Subroutines or functions needed DRD 286 +C - XERROR DRD 287 +C - D1MACH DRD 288 +C - FORTRAN DABS, DMAX1,DMIN1, DSQRT DRD 289 +C***REFERENCES CARLSON, B.C. AND NOTIS,E .M. DRD 290 +C ALGORITHMS FOR INCOMPLETE ELLIPTIC INTEGRALS DRD 291 +C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE,VOL.7,NO.3, DRD 292 +C SEPT, 1981, PAGES 398-403 DRD 293 +C CARLSON, B.C. DRD 294 +C COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION DRD 295 +C NUMER. MATH. 33, (1979), 1-16 DRD 296 +C CARLSON, B.C. DRD 297 +C ELLIPTIC INTEGRALS OF THE FIRST KIND DRD 298 +C SIAM J. MATH. ANAL. 8 (1977), 231-242 DRD 299 +C***ROUTINES CALLED D1MACH,XERROR DRD 300 +C***END PROLOGUE DRD DRD 301 + CHARACTER*176 MESSG DRD 302 + INTEGER IER,ITODO DRD 303 + DOUBLE PRECISION LOLIM, UPLIM, EPSLON, ERRTOL, D1MACH DRD 304 + DOUBLE PRECISION C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA DRD 305 + DOUBLE PRECISION MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV DRD 306 + DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, DRD 307 + * ZNROOT DRD 308 +C DRD 309 +C DRD 310 + SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,C4,ITODO DRD 311 +C DRD 312 +C DRD 313 + DATA ITODO/1/ DRD 314 +C DRD 315 +C DRD 316 +C DRD 317 +C***FIRST EXECUTABLE STATEMENT DRD DRD 318 + IF(ITODO.EQ.1)THEN DRD 319 +C DRD 320 +C DRD 321 +cryne ERRTOL=(D1MACH(3)/3.0D0)**(1.0D0/6.0D0) DRD 322 +c errtol=1.d-3 + errtol=1.d-4 +c errtol=1.d-5 +C DRD 323 +C DRD 324 +cryne LOLIM = 2.0D0/(D1MACH(2))**(2.0D0/3.0D0) DRD 325 + lolim=1.d-25 +C DRD 326 +cryne UPLIM = D1MACH(1)**(1.0E0/3.0E0) DRD 327 + uplim=1.d25 +cryne UPLIM = (0.10D0*ERRTOL)**(1.0E0/3.0E0)/UPLIM DRD 328 +cryne UPLIM = UPLIM**2.0D0 DRD 329 +C DRD 330 +C DRD 331 + C1 = 3.0D0/14.0D0 DRD 332 + C2 = 1.0D0/6.0D0 DRD 333 + C3 = 9.0D0/22.0D0 DRD 334 + C4 = 3.0D0/26.0D0 DRD 335 +C DRD 336 +C DRD 337 + ITODO=0 DRD 338 +C DRD 339 + END IF DRD 340 +C DRD 341 +C DRD 342 +C DRD 343 +C DRD 344 +C CALL ERROR HANDLER IF NECESSARY. DRD 345 +C DRD 346 +C DRD 347 + 5 DRD=0.0D0 DRD 348 + IF( DMIN1(X,Y).LT.0.0D0) THEN DRD 349 + IER=1 DRD 350 + WRITE (MESSG,6) X, Y DRD 351 + 6 FORMAT('DRD - ERROR: DMIN1(X,Y).LT.0.0D0 WHERE X=', 1PD20.12, DRD 352 + * ' AND Y=', D20.12) DRD 353 +cryne CALL XERROR(MESSG(1:100),100,1,1) DRD 354 + write(6,'(a100)')messg(1:100) + RETURN DRD 355 + ENDIF DRD 356 + IF (DMAX1(X,Y,Z).GT.UPLIM) THEN DRD 357 + IER=3 DRD 358 + MESSG(1:43) = 'DRD - ERROR: DMAX1(X,Y,Z).GT.UPLIM WHERE X=' DRD 359 + WRITE (MESSG(44:176),7) X, Y, Z, UPLIM DRD 360 + 7 FORMAT( 1PD20.12, DRD 361 + * 15X, 'Y=', D20.12, ' Z=', D20.12, ' AND', 23X, 'UPLIM=', D20.12)DRD 362 +cryne CALL XERROR(MESSG(1:176),176,3,1) DRD 363 + write(6,'(a176)')messg(1:176) + RETURN DRD 364 + ENDIF DRD 365 + IF (DMIN1(X+Y,Z).LT.LOLIM) THEN DRD 366 + IER=2 DRD 367 + MESSG(1:43)='DRD - ERROR: DMIN1(X+Y,Z).LT.LOLIM WHERE X=' DRD 368 + WRITE (MESSG(44:176),8) X, Y, Z, LOLIM DRD 369 + 8 FORMAT( 1PD20.12, DRD 370 + * 15X, 'Y=', D20.12, ' Z=', D20.12, ' AND', 23X, 'LOLIM=', D20.12)DRD 371 +cryne CALL XERROR(MESSG(1:176),176,2,1) DRD 372 + write(6,'(a176)')messg(1:176) + RETURN DRD 373 + ENDIF DRD 374 +C DRD 375 +C DRD 376 +C DRD 377 +C DRD 378 + 20 IER = 0 DRD 379 + XN = X DRD 380 + YN = Y DRD 381 + ZN = Z DRD 382 + SIGMA = 0.0D0 DRD 383 + POWER4 = 1.0D0 DRD 384 +C DRD 385 +C DRD 386 +C DRD 387 + 30 MU = (XN+YN+3.0D0*ZN)*0.20D0 DRD 388 + XNDEV = (MU-XN)/MU DRD 389 + YNDEV = (MU-YN)/MU DRD 390 + ZNDEV = (MU-ZN)/MU DRD 391 + EPSLON = DMAX1(DABS(XNDEV),DABS(YNDEV),DABS(ZNDEV)) DRD 392 + IF (EPSLON.LT.ERRTOL) GO TO 40 DRD 393 + XNROOT = DSQRT(XN) DRD 394 + YNROOT = DSQRT(YN) DRD 395 + ZNROOT = DSQRT(ZN) DRD 396 + LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT DRD 397 + SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA)) DRD 398 + POWER4 = POWER4*0.250D0 DRD 399 + XN = (XN+LAMDA)*0.250D0 DRD 400 + YN = (YN+LAMDA)*0.250D0 DRD 401 + ZN = (ZN+LAMDA)*0.250D0 DRD 402 + GO TO 30 DRD 403 +C DRD 404 +C DRD 405 +C DRD 406 +C DRD 407 + 40 EA = XNDEV*YNDEV DRD 408 + EB = ZNDEV*ZNDEV DRD 409 + EC = EA - EB DRD 410 + ED = EA - 6.0D0*EB DRD 411 + EF = ED + EC + EC DRD 412 + S1 = ED*(-C1+0.250D0*C3*ED-1.50D0*C4*ZNDEV*EF) DRD 413 + S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA)) DRD 414 + DRD = 3.0D0*SIGMA + POWER4*(1.0D0+S1+S2)/(MU*DSQRT(MU)) DRD 415 +C DRD 416 + 50 RETURN DRD 417 +C DRD 418 +C DRD 419 +C DRD 420 +C DRD 421 + END DRD 422 diff --git a/OpticsJan2020/MLI_light_optics/Src/euclid.f b/OpticsJan2020/MLI_light_optics/Src/euclid.f new file mode 100644 index 0000000..f3c5869 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/euclid.f @@ -0,0 +1,114 @@ + subroutine rotv(a,theta,vin,vout) +c +c This subroutine rotates a vector by an angle theta about the axis a. +c + include 'impli.inc' +c + dimension aj1(3,3), aj2(3,3), aj3(3,3) + dimension adotj(3,3), adotj2(3,3), aiden(3,3) + dimension rotm(3,3) + dimension a(3), vin(3), vint(3), vout(3) +c +c set up j and identity matrices and store vin +c + do i=1,3 + do j=1,3 + aj1(i,j)=0.d0 + aj2(i,j)=0.d0 + aj3(i,j)=0.d0 + aiden(i,j)=0.d0 + rotm(i,j)=0.d0 + end do + end do + aj1(2,3)=-1.d0 + aj1(3,2)=1.d0 + aj2(1,3)=1.d0 + aj2(3,1)=-1.d0 + aj3(1,2)=-1.d0 + aj3(2,1)=1.d0 + do i=1,3 + aiden(i,i)=1.d0 + vint(i)=vin(i) + end do +c +c compute adotj +c + do i=1,3 + do j=1,3 + adotj(i,j)=a(1)*aj1(i,j)+a(2)*aj2(i,j)+a(3)*aj3(i,j) + end do + end do +c +c compute adotj2 +c + do i=1,3 + do j=1,3 + adotj2(i,j)=0.d0 + do k=1,3 + adotj2(i,j)=adotj2(i,j)+adotj(i,k)*adotj(k,j) + end do + end do + end do +c +c compute rotation matrix +c + do i=1,3 + do j=1,3 + rotm(i,j)=aiden(i,j)+(dsin(theta))*adotj(i,j) + rotm(i,j)=rotm(i,j)+(1.d0-dcos(theta))*adotj2(i,j) + end do + end do +c +c comput final result +c + do i=1,3 + vout(i)=0.d0 + do j=1,3 + vout(i)=vout(i)+rotm(i,j)*vint(j) + end do + end do +c + return + end +c +*************************************************************************** +c + subroutine erotv(phi,theta,psi,vin,vout) +c +c This subroutine rotates a vector by a rotation described by euler angles. +c + include 'impli.inc' +c +c + dimension vin(3), vout(3), vtemp1(3), vtemp2(3) + dimension ex(3), ey(3), ez(3) +c +c set up unit vectors +c + do i=1,3 + ex(i)=0.d0 + ey(i)=0.d0 + ez(i)=0.d0 + end do + ex(1)=1.d0 + ey(2)=1.d0 + ez(3)=1.d0 +c +c carry out rotations +c + call rotv(ez,psi,vin,vtemp1) + call rotv(ey,theta,vtemp1,vtemp2) + call rotv(ez,phi,vtemp2,vout) +c + return + end +c +****************************************************** +c + subroutine wrtdo +c +c This subroutine writes out points on the design orbit +c + return + end +c diff --git a/OpticsJan2020/MLI_light_optics/Src/fftessl.f b/OpticsJan2020/MLI_light_optics/Src/fftessl.f new file mode 100644 index 0000000..b30d98e --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/fftessl.f @@ -0,0 +1,65 @@ +! for calling ESSL using new FFT*HPF interface + + +! implements FFTs using ESSL instead of Ryne's Num.Recipes versions + + subroutine fft3dhpf (N1, N2, N3, KSign, Scale, ICpy, NAdj, x, x3) + implicit none +!Constants +!Args + integer N1, N2, N3, KSign, ICpy, NAdj + real*8 Scale + complex*16 x,x3 + dimension x(N1,N2,N3) + dimension x3(N3,N2,N1) +!Locals + complex*16 aux !just a placeholder, not really used + integer i,j,k + +!ValidateArgs + + if( KSign .EQ. 0 )then + write(6,*) 'ERROR: FFT3DHPF/ESSL with zero ksign' + stop 'FFT3err1' + endif + if( NAdj .NE. 0 )then + write(6,*) 'ERROR: FFT3DHPF/ESSL with non-zero nadj' + stop 'FFT3err2' + endif + if( ICpy .NE. 0 )then + write(6,*) 'ERROR: FFT3DHPF/ESSL with non-zero icpy' + stop 'FFT3err3' + endif + + if( Scale .EQ. 0.0 )then + write(6,*) 'ERROR: FFT3DHPF/ESSL with zero scale' + stop 'FFT3err4' + endif + +!Execute + ! the ESSL routine doesn't leave the output transposed, so + ! do the FFT in-place and transpose into the output variable. + + call DCFT3( x, N1,N1*N2, x, N1,N1*N2, N1,N2,N3 + & ,KSign,Scale ,aux,0 ) + + do k = 1 ,N3 + do j = 1,N2 + do i = 1,N1 + x3(k,j,i) = x(i,j,k) + enddo + enddo + enddo + +!Done + + return + end + +!---------------------------------------------------------------- + + subroutine fft2dhpf() + stop 'FFT2Derr' + return + end + diff --git a/OpticsJan2020/MLI_light_optics/Src/fftpkgq.f b/OpticsJan2020/MLI_light_optics/Src/fftpkgq.f new file mode 100755 index 0000000..f154042 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/fftpkgq.f @@ -0,0 +1,372 @@ +! 3D FFT package + subroutine fft3dhpf (n1, n2, n3, ksign, scale, icpy, nadj, x, x3) + use parallel !for idproc + use ml_timer + implicit none + integer n1, n2, n3, ksign, icpy, nadj, icpy2d, i,j,k + real*8 scale,scale2d,ezero + integer klen,k1,kn1,kn3,ierror + complex*16 x,x2,x3 + complex*16 x2t,x3t + dimension x(n1,n2,n3) + dimension x3(n3,n2,n1) + dimension x3t(n3,n2,n1) + dimension x2(n2,n1,n3) + real*8 alnum,rem + dimension x2t(n2,n1,n3) + + call increment_timer('fft',0) + +!!XXX Feb 2003 -- moved here from afro.f, because it applies only to this version of FFT +!---Jan 27, 2003 +! make sure that these are powers of 2 + alnum=log(1.d0*n1)/log(2.d0) + rem=abs(alnum-nint(alnum)) + if(rem.gt.1.d-8)then + if(idproc.eq.0)then + write(6,*)'(fft3dhpf) error: n1 has an input value of ',n1 + write(6,*)' but must be a power of 2. Halting.' + endif + call myexit + endif + alnum=log(1.d0*n2)/log(2.d0) + rem=abs(alnum-nint(alnum)) + if(rem.gt.1.d-8)then + if(idproc.eq.0)then + write(6,*)'(fft3dhpf) error: n2 has an input value of ',n2 + write(6,*)' but must be a power of 2. Halting.' + endif + call myexit + endif + if(n3.ne.0)then + alnum=log(1.d0*n3)/log(2.d0) + rem=abs(alnum-nint(alnum)) + if(rem.gt.1.d-8)then + if(idproc.eq.0)then + write(6,*)'(fft3dhpf) error: n3 has an input value of ',n3 + write(6,*)' but must be a power of 2. Halting.' + endif + call myexit + endif + endif + +!--- +! write(6,*)'starting fft' +! FFTs along all dimensions except the last: +! + scale2d=1.0 + icpy2d=0 +! + klen=n3/nvp +!logic goes here to decide whether to do serial or parallel fft. +!for example: +! if(klen.le.1000000)then !always do serial +! if(klen.le.256)then !do parallel if every proc has a lot of work + if(klen.eq.0)then !do parallel if every proc has some work to do + call increment_timer('timer1',0) + do k=1,n3 + call fft2dhpf(n1,n2,ksign,nadj,scale2d,icpy2d, & + & x(1,1,k),x2(1,1,k)) + enddo + call increment_timer('timer1',1) + else +! note to myself: check to see if this will work if n3, nvp are not +! both powers of 2 + k1=idproc*klen+1 + kn3=k1+klen-1 + call increment_timer('timer1',0) + do k=k1,kn3 + call fft2dhpf(n1,n2,ksign,nadj,scale2d,icpy2d, & + & x(1,1,k),x2t(1,1,k)) + enddo + call increment_timer('timer1',1) +! + call increment_timer('timer2',0) + call MPI_ALLGATHER(x2t(1,1,k1),n1*n2*klen,mcplx,x2(1,1,1), & + & n1*n2*klen,mcplx,lworld,ierror) + call increment_timer('timer2',1) + endif +! +! The 3D and higher, the previous call transposes the subarray of all but +! the last index; Now move the last index from the right-most position to +! the left-most position in preparation for final, in-place transformation: +! In 2D this is simply a tranpose of the entire array. +! write(6,*)'starting triple do to move x2 into x3' + call increment_timer('transp',0) +!2D x3=transpose(x) + do i = 1, n1 + do k = 1, n3 + do j = 1, n2 + x3(k,j,i) = x2(j,i,k) + end do + end do + end do +! x3(1:n3,1:n2,1:n1)=x2(1:n2,1:n1,1:n3) +! write(6,*)'finished triple-do' + call increment_timer('transp',1) +! +! Final transform along the left-most direction +! + klen=n1/nvp + if(klen.eq.0)then + call increment_timer('timer3',0) + call mfft_local13d(n3,n2,n1,ksign,nadj,1,n1,x3) + call increment_timer('timer3',1) + else + k1=idproc*klen+1 + kn1=k1+klen-1 + call increment_timer('timer3',0) + call mfft_local13d (n3,n2,n1,ksign,nadj,k1,kn1,x3) + call increment_timer('timer3',1) + x3t(:,:,k1:kn1)=x3(:,:,k1:kn1) + call increment_timer('timer4',0) + call MPI_ALLGATHER(x3t(1,1,k1),n3*n2*klen,mcplx,x3(1,1,1), & + & n3*n2*klen,mcplx,lworld,ierror) + call increment_timer('timer4',1) + endif +! +! +! + if(scale.ne.1.0)then + do k=1,n1 + do j=1,n2 + do i=1,n3 +! x3(:,:,:)=x3(:,:,:)*scale + x3(i,j,k)=x3(i,j,k)*scale + enddo + enddo + enddo + endif +! if icpy.eq.1, store the final result back in x +! if icpy.ne.1, store with zeros (ensure users know it's filled with junk) + if(icpy.eq.1)then + write(6,*)'error: should not get here! (icpy=1)' +!2D x=transpose(x3) + do k = 1, n3 + do j = 1, n2 + do i = 1, n1 + x(i,j,k) = x3(k,j,i) + end do + end do + end do + else + ezero=0. + do k = 1, n3 + do j = 1, n2 + do i = 1, n1 + x(i,j,k) = cmplx(ezero,ezero) + end do + end do + end do +! write(6,*)'...finished fft (without copying)' + endif + call increment_timer('fft',1) + return + end !subroutine fft3dhpf + +!======================================================================= +! +! HPF_Local subroutine to perform multiple FFTs on the inner dimension +! + subroutine mfft_local13d(n1,n2,n3,ksign,nadj,k1,kn3,x) + implicit none + integer n1,n2,n3,ksign,nadj,i,j,k,n3top,n2top + integer k1,kn3 + complex*16 x,tempi + dimension x(n1,n2,n3),tempi(n1) +! +! Perform multiple FFTs without scaling: + n3top=n3 + n2top=n2 +c this works for open bc's because it is not necessary to do the +c inverse transform over the complete (octupled) domain. +c Of the N^2 1D fft's performed over the ixj plane, only 1/4 are +c in the physical domain. However, for the periodic case, the +c full z-dimension has to be covered. At the time of the inverse +c transformation (when this routine is called with ksign=-1), +c the n2 and n3 dimensions are in fact y and z, respectively. +c So the full fft is needed along the third dimension in that case. + if(ksign.eq.-1 .and. nadj.eq.0)then +!dec28 n3top=n3/2 +!dec28 n2top=n2/2 + endif + if(ksign.eq.-1 .and. nadj.eq.1)then +! write(12,*)'8-29-01:testing needed for this part of fftpkgq.f' +!dec28 n2top=n2/2 + endif +cryne Nov 9, 2003 do k=1,n3top + do k=k1,kn3 + do j=1,n2top +cryne tempi(1:n1)=x(1:n1,j,k) +cryne call ccfftnr(tempi,n1,ksign) +cryne x(1:n1,j,k) = tempi(1:n1) + call ccfftnr(x(1,j,k),n1,ksign) + end do + end do + return + end +! end subroutine mfft_local13d +!======================================================================= +!======================================================================= +! 2D FFT package + subroutine fft2dhpf (n1,n2,ksign,nadj,scale,icpy,x,x3) + use parallel, only : idproc + implicit none + integer n1, n2, ksign, nadj, icpy, i,j,ihalf,itop + real*8 scale,ezero + complex*16 x,x3 + dimension x(n1,n2),x3(n2,n1) +! +! FFTs along all dimensions except the last: +! Note: In 3D and higher, this is accomplished with a routine mfft_local2 +! But in 2D this isn't necessary--just used mfft_local1 +! + ihalf=0 + call mfft_local1 (ksign,x,n1,n2,ihalf) +! +! The 3D and higher, the previous call transposes the subarray of all but +! the last index; Now move the last index from the right-most position to +! the left-most position in preparation for final, in-place transformation: +! In 2D this is simply a tranpose of the entire array. +cryne x3=transpose(x) + itop=n1 +!dec28 if(ksign.eq.-1.and.nadj.eq.0)itop=n1/2 + do i=1,itop + do j=1,n2 + x3(j,i)=x(i,j) + enddo + enddo +! +! Final transform along the left-most direction +! + if(ksign.eq.-1.and.nadj.eq.0)ihalf=1 +! if(ihalf.eq.1)write(6,*)'ihalf=1' + call mfft_local1 (ksign,x3,n2,n1,ihalf) +! +! if(scale.ne.1.0)x3=x3*scale + if(scale.ne.1.0)then + do j=1,n1 + do i=1,n2 + x3(i,j)=x3(i,j)*scale + enddo + enddo + endif +! if icpy.eq.1, store the final result back in x +! if icpy.ne.1, store with zeros (ensure users know it's filled with junk) + if(icpy.eq.1)then + write(6,*)'error:should not get here!(icpy.eq.1 in fft2dhpf)' +! x=transpose(x3) + do j=1,n2 + do i=1,n1 + x(i,j)=x3(j,i) + enddo + enddo + endif +! if(icpy.ne.1)x=(0.,0.) + ezero=0. + if(icpy.ne.1)then + do j=1,n2 + do i=1,n1 + x(i,j)=cmplx(ezero,ezero) + enddo + enddo + endif + return + end !subroutine fft2dhpf +! +!======================================================================= +! +! HPF_Local subroutine to perform multiple FFTs on the inner dimension +! + subroutine mfft_local1 (ksign,x,m1,m2,ihalf) + implicit none + integer ksign,j,m1,m2,m2top,ihalf + complex*16 x,tempi + dimension x(m1,m2),tempi(m1) +! complex tempo,table,work +! dimension tempo(m1),table(m1),work(2*m1) +! +! Initialize: +!!!!! call ccfft (0,m1,1.0,tempi,tempo,table,work,0) +! Perform multiple FFTs without scaling: + m2top=m2 +!dec28 if(ihalf.eq.1)m2top=m2/2 + do j = 1, m2top +c tempi = x(:,j) +!!!!! call ccfft(ksign,m1,1.0,tempi,tempo,table,work,0) +!!!!! x(:,j) = tempo +cryne call ccfftnr(tempi,m1,ksign) + call ccfftnr(x(1,j),m1,ksign) +c x(:,j) = tempi + end do + return + end +! end subroutine mfft_local1 +! + subroutine ccfftnr(cdata,nn,isign) + use ml_timer + implicit real*8(a-h,o-z) + complex*16 cdata + dimension cdata(nn),data(2*nn) + call increment_timer('ccfftnr',0) + do i=1,nn + data(2*i-1)=real(cdata(i)) + data(2*i) =aimag(cdata(i)) + enddo +! bit reversal: + n=2*nn + j=1 + do i=1,n,2 + if(j.gt.i)then + tempr=data(j) + tempi=data(j+1) + data(j)=data(i) + data(j+1)=data(i+1) + data(i)=tempr + data(i+1)=tempi + endif + m=n/2 + 1 if((m.ge.2).and.(j.gt.m))then + j=j-m + m=m/2 + goto 1 + endif + j=j+m + enddo +! Danielson-Lanczos: + twopi=4.0*asin(1.0d0) + mmax=2 + 2 if(n.gt.mmax)then + istep=2*mmax + theta=twopi/(isign*mmax) + wpr=-2.*sin(0.5*theta)**2 + wpi=sin(theta) + wr=1.0 + wi=0.0 + do m=1,mmax,2 + do i=m,n,istep + j=i+mmax + tempr=wr*data(j)-wi*data(j+1) + tempi=wr*data(j+1)+wi*data(j) + data(j)=data(i)-tempr + data(j+1)=data(i+1)-tempi + data(i)=data(i)+tempr + data(i+1)=data(i+1)+tempi + enddo + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi + enddo + mmax=istep + goto 2 + endif +c ezero=0. +c eunit=1. + do i=1,nn + cdata(i)=data(2*i-1)+(0.,1.)*data(2*i) +c cdata(i)=data(2*i-1)+cmplx(ezero,eunit)*data(2*i) + enddo + call increment_timer('ccfftnr',1) + return + end +!======================================================================= diff --git a/OpticsJan2020/MLI_light_optics/Src/fftw_dummy.f b/OpticsJan2020/MLI_light_optics/Src/fftw_dummy.f new file mode 100644 index 0000000..48ce210 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/fftw_dummy.f @@ -0,0 +1,17 @@ + subroutine rfftw_f77_create_plan() + write(6,*) 'error: rfftw_f77_create_plan: FFTW is not included ' + & ,'in this version.' + stop 'NOFFTW' + end + + subroutine rfftw_f77_one() + write(6,*) 'error: rfftw_f77_one: FFTW is not included ' + & ,'in this version.' + stop 'NOFFTW' + end + + subroutine rfftw_f77_destroy_plan() + write(6,*) 'error: rfftw_f77_destroy_plan: FFTW is not included ' + & ,'in this version.' + stop 'NOFFTW' + end diff --git a/OpticsJan2020/MLI_light_optics/Src/fparser.f90 b/OpticsJan2020/MLI_light_optics/Src/fparser.f90 new file mode 100644 index 0000000..150dd60 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/fparser.f90 @@ -0,0 +1,737 @@ +MODULE fparser + !------- -------- --------- --------- --------- --------- --------- --------- ------- + ! Fortran 90 function parser v1.0 + !------- -------- --------- --------- --------- --------- --------- --------- ------- + ! + ! This public domain function parser module is intended for applications + ! where a set of mathematical expressions is specified at runtime and is + ! then evaluated for a large number of variable values. This is done by + ! compiling the set of function strings into byte code, which is interpreted + ! very efficiently for the various variable values. + ! + ! The source code is available from: + ! http://www.its.uni-karlsruhe.de/~schmehl/opensource/fparser-v1.0.tar.gz + ! + ! Please send comments, corrections or questions to the author: + ! Roland Schmehl + ! + !------- -------- --------- --------- --------- --------- --------- --------- ------- + ! The function parser concept is based on a C++ class library written by Warp + ! available from: + ! http://www.students.tut.fi/~warp/FunctionParser/fparser.zip + !------- -------- --------- --------- --------- --------- --------- --------- ------- + USE parameters, ONLY: rn,is ! Import KIND parameters + IMPLICIT NONE + !------- -------- --------- --------- --------- --------- --------- --------- ------- + PUBLIC :: initf, & ! Initialize function parser for n functions + parsef, & ! Parse single function string + evalf, & ! Evaluate single function + EvalErrMsg ! Error message (Use only when EvalErrType>0) + INTEGER, PUBLIC :: EvalErrType ! =0: no error occured, >0: evaluation error + !------- -------- --------- --------- --------- --------- --------- --------- ------- + PRIVATE + SAVE + INTEGER(is), PARAMETER :: cImmed = 1, & + cNeg = 2, & + cAdd = 3, & + cSub = 4, & + cMul = 5, & + cDiv = 6, & + cPow = 7, & + cAbs = 8, & + cExp = 9, & + cLog10 = 10, & + cLog = 11, & + cSqrt = 12, & + cSinh = 13, & + cCosh = 14, & + cTanh = 15, & + cSin = 16, & + cCos = 17, & + cTan = 18, & + cAsin = 19, & + cAcos = 20, & + cAtan = 21, & + VarBegin = 22 + CHARACTER (LEN=1), DIMENSION(cAdd:cPow), PARAMETER :: Ops = (/ '+', & + '-', & + '*', & + '/', & + '^' /) + CHARACTER (LEN=5), DIMENSION(cAbs:cAtan), PARAMETER :: Funcs = (/ 'abs ', & + 'exp ', & + 'log10', & + 'log ', & + 'sqrt ', & + 'sinh ', & + 'cosh ', & + 'tanh ', & + 'sin ', & + 'cos ', & + 'tan ', & + 'asin ', & + 'acos ', & + 'atan ' /) + TYPE tComp + INTEGER(is), DIMENSION(:), POINTER :: ByteCode + INTEGER :: ByteCodeSize + REAL(rn), DIMENSION(:), POINTER :: Immed + INTEGER :: ImmedSize + REAL(rn), DIMENSION(:), POINTER :: Stack + INTEGER :: StackSize, & + StackPtr + END TYPE tComp + TYPE (tComp), DIMENSION(:), POINTER :: Comp ! Bytecode + INTEGER, DIMENSION(:), ALLOCATABLE :: ipos ! Associates function strings + ! +CONTAINS + ! + SUBROUTINE initf (n) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Initialize function parser for n functions + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + INTEGER, INTENT(in) :: n ! Number of functions + INTEGER :: i + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ALLOCATE (Comp(n)) + DO i=1,n + NULLIFY (Comp(i)%ByteCode,Comp(i)%Immed,Comp(i)%Stack) + END DO + END SUBROUTINE initf + ! + SUBROUTINE parsef (i, FuncStr, Var) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Parse ith function string FuncStr and compile it into bytecode + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + INTEGER, INTENT(in) :: i ! Function identifier + CHARACTER (LEN=*), INTENT(in) :: FuncStr ! Function string + CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names + CHARACTER (LEN=LEN(FuncStr)) :: Func ! Function string, local use + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IF (i < 1 .OR. i > SIZE(Comp)) THEN + WRITE(*,*) '*** Parser error: Function number ',i,' out of range' + STOP + END IF + ALLOCATE (ipos(LEN_TRIM(FuncStr))) ! Char. positions in orig. string + Func = FuncStr ! Local copy of function string + CALL Replace ('**','^ ',Func) ! Exponent into 1-Char. format + CALL RemoveSpaces (Func) ! Condense function string + CALL CheckSyntax (Func,FuncStr,Var) + DEALLOCATE (ipos) + CALL Compile (i,Func,Var) ! Compile into bytecode + END SUBROUTINE parsef + ! + FUNCTION evalf (i, Val) RESULT (res) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Evaluate bytecode of ith function for the values passed in array Val(:) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + INTEGER, INTENT(in) :: i ! Function identifier + REAL(rn), DIMENSION(:), INTENT(in) :: Val ! Variable values + REAL(rn) :: res ! Result + INTEGER :: IP, & ! Instruction pointer + DP, & ! Data pointer + SP ! Stack pointer + REAL(rn), PARAMETER :: zero = 0._rn + !----- -------- --------- --------- --------- --------- --------- --------- ------- + DP = 1 + SP = 0 + DO IP=1,Comp(i)%ByteCodeSize + SELECT CASE (Comp(i)%ByteCode(IP)) + + CASE (cImmed); SP=SP+1; Comp(i)%Stack(SP)=Comp(i)%Immed(DP); DP=DP+1 + CASE (cNeg); Comp(i)%Stack(SP)=-Comp(i)%Stack(SP) + CASE (cAdd); Comp(i)%Stack(SP-1)=Comp(i)%Stack(SP-1)+Comp(i)%Stack(SP); SP=SP-1 + CASE (cSub); Comp(i)%Stack(SP-1)=Comp(i)%Stack(SP-1)-Comp(i)%Stack(SP); SP=SP-1 + CASE (cMul); Comp(i)%Stack(SP-1)=Comp(i)%Stack(SP-1)*Comp(i)%Stack(SP); SP=SP-1 + CASE (cDiv); IF (Comp(i)%Stack(SP)==0._rn) THEN; EvalErrType=1; res=zero; RETURN; ENDIF + Comp(i)%Stack(SP-1)=Comp(i)%Stack(SP-1)/Comp(i)%Stack(SP); SP=SP-1 + CASE (cPow); Comp(i)%Stack(SP-1)=Comp(i)%Stack(SP-1)**Comp(i)%Stack(SP); SP=SP-1 + CASE (cAbs); Comp(i)%Stack(SP)=ABS(Comp(i)%Stack(SP)) + CASE (cExp); Comp(i)%Stack(SP)=EXP(Comp(i)%Stack(SP)) + CASE (cLog10); IF (Comp(i)%Stack(SP)<=0._rn) THEN; EvalErrType=3; res=zero; RETURN; ENDIF + Comp(i)%Stack(SP)=LOG10(Comp(i)%Stack(SP)) + CASE (cLog); IF (Comp(i)%Stack(SP)<=0._rn) THEN; EvalErrType=3; res=zero; RETURN; ENDIF + Comp(i)%Stack(SP)=LOG(Comp(i)%Stack(SP)) + CASE (cSqrt); IF (Comp(i)%Stack(SP)<0._rn) THEN; EvalErrType=3; res=zero; RETURN; ENDIF + Comp(i)%Stack(SP)=SQRT(Comp(i)%Stack(SP)) + CASE (cSinh); Comp(i)%Stack(SP)=SINH(Comp(i)%Stack(SP)) + CASE (cCosh); Comp(i)%Stack(SP)=COSH(Comp(i)%Stack(SP)) + CASE (cTanh); Comp(i)%Stack(SP)=TANH(Comp(i)%Stack(SP)) + CASE (cSin); Comp(i)%Stack(SP)=SIN(Comp(i)%Stack(SP)) + CASE (cCos); Comp(i)%Stack(SP)=COS(Comp(i)%Stack(SP)) + CASE (cTan); Comp(i)%Stack(SP)=TAN(Comp(i)%Stack(SP)) + CASE (cAsin); IF ((Comp(i)%Stack(SP)<-1._rn).OR.(Comp(i)%Stack(SP)>1._rn)) THEN + EvalErrType=4; res=zero; RETURN; ENDIF + Comp(i)%Stack(SP)=ASIN(Comp(i)%Stack(SP)) + CASE (cAcos); IF ((Comp(i)%Stack(SP)<-1._rn).OR.(Comp(i)%Stack(SP)>1._rn)) THEN + EvalErrType=4; res=zero; RETURN; ENDIF + Comp(i)%Stack(SP)=ACOS(Comp(i)%Stack(SP)) + CASE (cAtan); Comp(i)%Stack(SP)=ATAN(Comp(i)%Stack(SP)) + CASE DEFAULT; SP=SP+1; Comp(i)%Stack(SP)=Val(Comp(i)%ByteCode(IP)-VarBegin+1) + END SELECT + END DO + EvalErrType = 0 + res = Comp(i)%Stack(1) + END FUNCTION evalf + ! + SUBROUTINE CheckSyntax (Func,FuncStr,Var) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Check syntax of function string, returns 0 if syntax is ok + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(in) :: Func ! Function string without spaces + CHARACTER (LEN=*), INTENT(in) :: FuncStr ! Original function string + CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names + INTEGER(is) :: n + CHARACTER (LEN=1) :: c + REAL(rn) :: r + LOGICAL :: err + INTEGER :: ParCnt, & ! Parenthesis counter + j,ib,in,lFunc + !----- -------- --------- --------- --------- --------- --------- --------- ------- + j = 1 + ParCnt = 0 + lFunc = LEN_TRIM(Func) + step: DO + IF (j > lFunc) CALL ParseErrMsg (j, FuncStr) + c = Func(j:j) + !-- -------- --------- --------- --------- --------- --------- --------- ------- + ! Check for valid operand (must appear) + !-- -------- --------- --------- --------- --------- --------- --------- ------- + IF (c == '-' .OR. c == '+') THEN ! Check for leading - or + + j = j+1 + IF (j > lFunc) CALL ParseErrMsg (j, FuncStr, 'Missing operand') + c = Func(j:j) + IF (ANY(c == Ops)) CALL ParseErrMsg (j, FuncStr, 'Multiple operators') + END IF + n = MathFunctionIndex (Func(j:)) + IF (n > 0) THEN ! Check for math function + j = j+LEN_TRIM(Funcs(n)) + IF (j > lFunc) CALL ParseErrMsg (j, FuncStr, 'Missing function argument') + c = Func(j:j) + IF (c /= '(') CALL ParseErrMsg (j, FuncStr, 'Missing opening parenthesis') + END IF + IF (c == '(') THEN ! Check for opening parenthesis + ParCnt = ParCnt+1 + j = j+1 + CYCLE step + END IF + IF (SCAN(c,'0123456789.') > 0) THEN ! Check for number + r = RealNum (Func(j:),ib,in,err) + IF (err) CALL ParseErrMsg (j, FuncStr, 'Invalid number format: '//Func(j+ib-1:j+in-2)) + j = j+in-1 + IF (j > lFunc) EXIT + c = Func(j:j) + ELSE ! Check for variable + n = VariableIndex (Func(j:),Var,ib,in) + IF (n == 0) CALL ParseErrMsg (j, FuncStr, 'Invalid element: '//Func(j+ib-1:j+in-2)) + j = j+in-1 + IF (j > lFunc) EXIT + c = Func(j:j) + END IF + DO WHILE (c == ')') ! Check for closing parenthesis + ParCnt = ParCnt-1 + IF (ParCnt < 0) CALL ParseErrMsg (j, FuncStr, 'Mismatched parenthesis') + IF (Func(j-1:j-1) == '(') CALL ParseErrMsg (j-1, FuncStr, 'Empty parentheses') + j = j+1 + IF (j > lFunc) EXIT + c = Func(j:j) + END DO + !-- -------- --------- --------- --------- --------- --------- --------- ------- + ! Now, we have a legal operand: A legal operator or end of string must follow + !-- -------- --------- --------- --------- --------- --------- --------- ------- + IF (j > lFunc) EXIT + IF (ANY(c == Ops)) THEN ! Check for multiple operators + IF (j+1 > lFunc) CALL ParseErrMsg (j, FuncStr) + IF (ANY(Func(j+1:j+1) == Ops)) CALL ParseErrMsg (j+1, FuncStr, 'Multiple operators') + ELSE ! Check for next operand + CALL ParseErrMsg (j, FuncStr, 'Missing operator') + END IF + !-- -------- --------- --------- --------- --------- --------- --------- ------- + ! Now, we have an operand and an operator: the next loop will check for another + ! operand (must appear) + !-- -------- --------- --------- --------- --------- --------- --------- ------- + j = j+1 + END DO step + IF (ParCnt > 0) CALL ParseErrMsg (j, FuncStr, 'Missing )') + END SUBROUTINE CheckSyntax + ! + FUNCTION EvalErrMsg () RESULT (msg) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Return error message + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + CHARACTER (LEN=*), DIMENSION(4), PARAMETER :: m = (/ 'Division by zero ', & + 'Argument of SQRT negative ', & + 'Argument of LOG negative ', & + 'Argument of ASIN or ACOS illegal' /) + CHARACTER (LEN=LEN(m(1))) :: msg + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IF (EvalErrType < 1 .OR. EvalErrType > SIZE(m)) THEN + msg = ' ' + ELSE + msg = m(EvalErrType) + ENDIF + END FUNCTION EvalErrMsg + ! + SUBROUTINE ParseErrMsg (j, FuncStr, Msg) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Print error message and terminate program + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + INTEGER, INTENT(in) :: j + CHARACTER (LEN=*), INTENT(in) :: FuncStr ! Original function string + CHARACTER (LEN=*), OPTIONAL, INTENT(in) :: Msg + INTEGER :: k + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IF (PRESENT(Msg)) THEN + WRITE(*,*) '*** Error in syntax of function string: '//Msg + ELSE + WRITE(*,*) '*** Error in syntax of function string:' + ENDIF + WRITE(*,*) + WRITE(*,'(A)') ' '//FuncStr + DO k=1,ipos(j) + WRITE(*,'(A)',ADVANCE='NO') ' ' ! Advance to the jth position + END DO + WRITE(*,'(A)') '?' + STOP + END SUBROUTINE ParseErrMsg + ! + FUNCTION OperatorIndex (c) RESULT (n) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Return operator index + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + CHARACTER (LEN=1), INTENT(in) :: c + INTEGER(is) :: n,j + !----- -------- --------- --------- --------- --------- --------- --------- ------- + n = 0 + DO j=cAdd,cPow + IF (c == Ops(j)) THEN + n = j + EXIT + END IF + END DO + END FUNCTION OperatorIndex + ! + FUNCTION MathFunctionIndex (str) RESULT (n) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Return index of math function beginnig at 1st position of string str + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(in) :: str + INTEGER(is) :: n,j + INTEGER :: k + CHARACTER (LEN=LEN(Funcs(cAbs))) :: fun + !----- -------- --------- --------- --------- --------- --------- --------- ------- + n = 0 + DO j=cAbs,cAtan ! Check all math functions + k = MIN(LEN_TRIM(Funcs(j)), LEN(str)) + CALL LowCase (str(1:k), fun) + IF (fun == Funcs(j)) THEN ! Compare lower case letters + n = j ! Found a matching function + EXIT + END IF + END DO + END FUNCTION MathFunctionIndex + ! + FUNCTION VariableIndex (str, Var, ibegin, inext) RESULT (n) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Return index of variable at begin of string str (returns 0 if no variable found) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(in) :: str ! String + CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names + INTEGER(is) :: n ! Index of variable + INTEGER, OPTIONAL, INTENT(out) :: ibegin, & ! Start position of variable name + inext ! Position of character after name + INTEGER :: j,ib,in,lstr + !----- -------- --------- --------- --------- --------- --------- --------- ------- + n = 0 + lstr = LEN_TRIM(str) + IF (lstr > 0) THEN + DO ib=1,lstr ! Search for first character in str + IF (str(ib:ib) /= ' ') EXIT ! When lstr>0 at least 1 char in str + END DO + DO in=ib,lstr ! Search for name terminators + IF (SCAN(str(in:in),'+-*/^) ') > 0) EXIT + END DO + DO j=1,SIZE(Var) + IF (str(ib:in-1) == Var(j)) THEN + n = j ! Variable name found + EXIT + END IF + END DO + END IF + IF (PRESENT(ibegin)) ibegin = ib + IF (PRESENT(inext)) inext = in + END FUNCTION VariableIndex + ! + SUBROUTINE RemoveSpaces (str) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Remove Spaces from string, remember positions of characters in old string + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(inout) :: str + INTEGER :: k,lstr + !----- -------- --------- --------- --------- --------- --------- --------- ------- + lstr = LEN_TRIM(str) + ipos = (/ (k,k=1,lstr) /) + k = 1 + DO WHILE (str(k:lstr) /= ' ') + IF (str(k:k) == ' ') THEN + str(k:lstr) = str(k+1:lstr)//' ' ! Move 1 character to left + ipos(k:lstr) = (/ ipos(k+1:lstr), 0 /) ! Move 1 element to left + k = k-1 + END IF + k = k+1 + END DO + END SUBROUTINE RemoveSpaces + ! + SUBROUTINE Replace (ca,cb,str) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Replace ALL appearances of character set ca in string str by character set cb + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(in) :: ca + CHARACTER (LEN=LEN(ca)), INTENT(in) :: cb ! LEN(ca) must be LEN(cb) + CHARACTER (LEN=*), INTENT(inout) :: str + INTEGER :: j,lca + !----- -------- --------- --------- --------- --------- --------- --------- ------- + lca = LEN(ca) + DO j=1,LEN_TRIM(str)-lca+1 + IF (str(j:j+lca-1) == ca) str(j:j+lca-1) = cb + END DO + END SUBROUTINE Replace + ! + SUBROUTINE Compile (i, F, Var) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Compile i-th function string F into bytecode + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + INTEGER, INTENT(in) :: i ! Function identifier + CHARACTER (LEN=*), INTENT(in) :: F ! Function string + CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names + INTEGER :: istat + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IF (ASSOCIATED(Comp(i)%ByteCode)) DEALLOCATE ( Comp(i)%ByteCode, & + Comp(i)%Immed, & + Comp(i)%Stack ) + Comp(i)%ByteCodeSize = 0 + Comp(i)%ImmedSize = 0 + Comp(i)%StackSize = 0 + Comp(i)%StackPtr = 0 + CALL CompileSubstr (i,F,1,LEN_TRIM(F),Var) ! Compile string to determine size + ALLOCATE ( Comp(i)%ByteCode(Comp(i)%ByteCodeSize), & + Comp(i)%Immed(Comp(i)%ImmedSize), & + Comp(i)%Stack(Comp(i)%StackSize), & + STAT = istat ) + IF (istat /= 0) THEN + WRITE(*,*) '*** Parser error: Memmory allocation for byte code failed' + STOP + ELSE + Comp(i)%ByteCodeSize = 0 + Comp(i)%ImmedSize = 0 + Comp(i)%StackSize = 0 + Comp(i)%StackPtr = 0 + CALL CompileSubstr (i,F,1,LEN_TRIM(F),Var) ! Compile string into bytecode + END IF + ! + END SUBROUTINE Compile + ! + SUBROUTINE AddCompiledByte (i, b) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Add compiled byte to bytecode + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + INTEGER, INTENT(in) :: i ! Function identifier + INTEGER(is), INTENT(in) :: b ! Value of byte to be added + !----- -------- --------- --------- --------- --------- --------- --------- ------- + Comp(i)%ByteCodeSize = Comp(i)%ByteCodeSize + 1 + IF (ASSOCIATED(Comp(i)%ByteCode)) Comp(i)%ByteCode(Comp(i)%ByteCodeSize) = b + END SUBROUTINE AddCompiledByte + ! + FUNCTION MathItemIndex (i, F, Var) RESULT (n) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Return math item index, if item is real number, enter it into Comp-structure + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + INTEGER, INTENT(in) :: i ! Function identifier + CHARACTER (LEN=*), INTENT(in) :: F ! Function substring + CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names + INTEGER(is) :: n ! Byte value of math item + !----- -------- --------- --------- --------- --------- --------- --------- ------- + n = 0 + IF (SCAN(F(1:1),'0123456789.') > 0) THEN ! Check for begin of a number + Comp(i)%ImmedSize = Comp(i)%ImmedSize + 1 + IF (ASSOCIATED(Comp(i)%Immed)) Comp(i)%Immed(Comp(i)%ImmedSize) = RealNum (F) + n = cImmed + ELSE ! Check for a variable + n = VariableIndex (F, Var) + IF (n > 0) n = VarBegin+n-1 + END IF + END FUNCTION MathItemIndex + ! + FUNCTION CompletelyEnclosed (F, b, e) RESULT (res) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Check if function substring F(b:e) is completely enclosed by a pair of parenthesis + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(in) :: F ! Function substring + INTEGER, INTENT(in) :: b,e ! First and last pos. of substring + LOGICAL :: res + INTEGER :: j,k + !----- -------- --------- --------- --------- --------- --------- --------- ------- + res=.false. + IF (F(b:b) == '(' .AND. F(e:e) == ')') THEN + k = 0 + DO j=b+1,e-1 + IF (F(j:j) == '(') THEN + k = k+1 + ELSEIF (F(j:j) == ')') THEN + k = k-1 + END IF + IF (k < 0) EXIT + END DO + IF (k == 0) res=.true. ! All opened parenthesis closed + END IF + END FUNCTION CompletelyEnclosed + ! + RECURSIVE SUBROUTINE CompileSubstr (i, F, b, e, Var) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Compile i-th function string F into bytecode + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + INTEGER, INTENT(in) :: i ! Function identifier + CHARACTER (LEN=*), INTENT(in) :: F ! Function substring + INTEGER, INTENT(in) :: b,e ! Begin and end position substring + CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names + INTEGER(is) :: n + INTEGER :: b2,j,k,io + CHARACTER (LEN=*), PARAMETER :: calpha = 'abcdefghijklmnopqrstuvwxyz'// & + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Check for special cases of substring + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IF (F(b:b) == '+') THEN ! Case 1: F(b:e) = '+...' +! WRITE(*,*)'1. F(b:e) = "+..."' + CALL CompileSubstr (i, F, b+1, e, Var) + RETURN + ELSEIF (CompletelyEnclosed (F, b, e)) THEN ! Case 2: F(b:e) = '(...)' +! WRITE(*,*)'2. F(b:e) = "(...)"' + CALL CompileSubstr (i, F, b+1, e-1, Var) + RETURN + ELSEIF (SCAN(F(b:b),calpha) > 0) THEN + n = MathFunctionIndex (F(b:e)) + IF (n > 0) THEN + b2 = b+INDEX(F(b:e),'(')-1 + IF (CompletelyEnclosed(F, b2, e)) THEN ! Case 3: F(b:e) = 'fcn(...)' +! WRITE(*,*)'3. F(b:e) = "fcn(...)"' + CALL CompileSubstr(i, F, b2+1, e-1, Var) + CALL AddCompiledByte (i, n) + RETURN + END IF + END IF + ELSEIF (F(b:b) == '-') THEN + IF (CompletelyEnclosed (F, b+1, e)) THEN ! Case 4: F(b:e) = '-(...)' +! WRITE(*,*)'4. F(b:e) = "-(...)"' + CALL CompileSubstr (i, F, b+2, e-1, Var) + CALL AddCompiledByte (i, cNeg) + RETURN + ELSEIF (SCAN(F(b+1:b+1),calpha) > 0) THEN + n = MathFunctionIndex (F(b+1:e)) + IF (n > 0) THEN + b2 = b+INDEX(F(b+1:e),'(') + IF (CompletelyEnclosed(F, b2, e)) THEN ! Case 5: F(b:e) = '-fcn(...)' +! WRITE(*,*)'5. F(b:e) = "-fcn(...)"' + CALL CompileSubstr(i, F, b2+1, e-1, Var) + CALL AddCompiledByte (i, n) + CALL AddCompiledByte (i, cNeg) + RETURN + END IF + END IF + ENDIF + END IF + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Check for operator in substring: check only base level (k=0), exclude expr. in () + !----- -------- --------- --------- --------- --------- --------- --------- ------- + DO io=cAdd,cPow ! Increasing priority +-*/^ + k = 0 + DO j=e,b,-1 + IF (F(j:j) == ')') THEN + k = k+1 + ELSEIF (F(j:j) == '(') THEN + k = k-1 + END IF + IF (k == 0 .AND. F(j:j) == Ops(io) .AND. IsBinaryOp (j, F)) THEN + IF (ANY(F(j:j) == Ops(cMul:cPow)) .AND. F(b:b) == '-') THEN ! Case 6: F(b:e) = '-...Op...' with Op > - +! WRITE(*,*)'6. F(b:e) = "-...Op..." with Op > -' + CALL CompileSubstr (i, F, b+1, e, Var) + CALL AddCompiledByte (i, cNeg) + RETURN + ELSE ! Case 7: F(b:e) = '...BinOp...' +! WRITE(*,*)'7. Binary operator',F(j:j) + CALL CompileSubstr (i, F, b, j-1, Var) + CALL CompileSubstr (i, F, j+1, e, Var) + CALL AddCompiledByte (i, OperatorIndex(Ops(io))) + Comp(i)%StackPtr = Comp(i)%StackPtr - 1 + RETURN + END IF + END IF + END DO + END DO + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Check for remaining items, i.e. variables or explicit numbers + !----- -------- --------- --------- --------- --------- --------- --------- ------- + b2 = b + IF (F(b:b) == '-') b2 = b2+1 + n = MathItemIndex(i, F(b2:e), Var) +! WRITE(*,*)'8. AddCompiledByte ',n + CALL AddCompiledByte (i, n) + Comp(i)%StackPtr = Comp(i)%StackPtr + 1 + IF (Comp(i)%StackPtr > Comp(i)%StackSize) Comp(i)%StackSize = Comp(i)%StackSize + 1 + IF (b2 > b) CALL AddCompiledByte (i, cNeg) + END SUBROUTINE CompileSubstr + ! + FUNCTION IsBinaryOp (j, F) RESULT (res) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Check if operator F(j:j) in string F is binary operator + ! Special cases already covered elsewhere: (that is corrected in v1.1) + ! - operator character F(j:j) is first character of string (j=1) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + INTEGER, INTENT(in) :: j ! Position of Operator + CHARACTER (LEN=*), INTENT(in) :: F ! String + LOGICAL :: res ! Result + INTEGER :: k + LOGICAL :: Dflag,Pflag + !----- -------- --------- --------- --------- --------- --------- --------- ------- + res=.true. + IF (F(j:j) == '+' .OR. F(j:j) == '-') THEN ! Plus or minus sign: + IF (j == 1) THEN ! - leading unary operator ? + res = .false. + ELSEIF (SCAN(F(j-1:j-1),'+-*/^(') > 0) THEN ! - other unary operator ? + res = .false. + ELSEIF (SCAN(F(j+1:j+1),'0123456789') > 0 .AND. & ! - in exponent of real number ? + SCAN(F(j-1:j-1),'eEdD') > 0) THEN + Dflag=.false.; Pflag=.false. + k = j-1 + DO WHILE (k > 1) ! step to the left in mantissa + k = k-1 + IF (SCAN(F(k:k),'0123456789') > 0) THEN + Dflag=.true. + ELSEIF (F(k:k) == '.') THEN + IF (Pflag) THEN + EXIT ! * EXIT: 2nd appearance of '.' + ELSE + Pflag=.true. ! * mark 1st appearance of '.' + ENDIF + ELSE + EXIT ! * all other characters + END IF + END DO + IF (Dflag .AND. (k == 1 .OR. SCAN(F(k:k),'+-*/^(') > 0)) res = .false. + END IF + END IF + END FUNCTION IsBinaryOp + ! + FUNCTION RealNum (str, ibegin, inext, error) RESULT (res) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Get real number from string - Format: [blanks][+|-][nnn][.nnn][e|E|d|D[+|-]nnn] + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(in) :: str ! String + REAL(rn) :: res ! Real number + INTEGER, OPTIONAL, INTENT(out) :: ibegin, & ! Start position of real number + inext ! 1st character after real number + LOGICAL, OPTIONAL, INTENT(out) :: error ! Error flag + INTEGER :: ib,in,istat + LOGICAL :: Bflag, & ! .T. at begin of number in str + InMan, & ! .T. in mantissa of number + Pflag, & ! .T. after 1st '.' encountered + Eflag, & ! .T. at exponent identifier 'eEdD' + InExp, & ! .T. in exponent of number + DInMan, & ! .T. if at least 1 digit in mant. + DInExp, & ! .T. if at least 1 digit in exp. + err ! Local error flag + !----- -------- --------- --------- --------- --------- --------- --------- ------- + Bflag=.true.; InMan=.false.; Pflag=.false.; Eflag=.false.; InExp=.false. + DInMan=.false.; DInExp=.false. + ib = 1 + in = 1 + DO WHILE (in <= LEN_TRIM(str)) + SELECT CASE (str(in:in)) + CASE (' ') ! Only leading blanks permitted + ib = ib+1 + IF (InMan .OR. Eflag .OR. InExp) EXIT + CASE ('+','-') ! Permitted only + IF (Bflag) THEN + InMan=.true.; Bflag=.false. ! - at beginning of mantissa + ELSEIF (Eflag) THEN + InExp=.true.; Eflag=.false. ! - at beginning of exponent + ELSE + EXIT ! - otherwise STOP + ENDIF + CASE ('0':'9') ! Mark + IF (Bflag) THEN + InMan=.true.; Bflag=.false. ! - beginning of mantissa + ELSEIF (Eflag) THEN + InExp=.true.; Eflag=.false. ! - beginning of exponent + ENDIF + IF (InMan) DInMan=.true. ! Mantissa contains digit + IF (InExp) DInExp=.true. ! Exponent contains digit + CASE ('.') + IF (Bflag) THEN + Pflag=.true. ! - mark 1st appearance of '.' + InMan=.true.; Bflag=.false. ! mark beginning of mantissa + ELSEIF (InMan .AND..NOT.Pflag) THEN + Pflag=.true. ! - mark 1st appearance of '.' + ELSE + EXIT ! - otherwise STOP + END IF + CASE ('e','E','d','D') ! Permitted only + IF (InMan) THEN + Eflag=.true.; InMan=.false. ! - following mantissa + ELSE + EXIT ! - otherwise STOP + ENDIF + CASE DEFAULT + EXIT ! STOP at all other characters + END SELECT + in = in+1 + END DO + err = (ib > in-1) .OR. (.NOT.DInMan) .OR. ((Eflag.OR.InExp).AND..NOT.DInExp) + IF (err) THEN + res = 0.0_rn + ELSE + READ(str(ib:in-1),*,IOSTAT=istat) res + err = istat /= 0 + END IF + IF (PRESENT(ibegin)) ibegin = ib + IF (PRESENT(inext)) inext = in + IF (PRESENT(error)) error = err + END FUNCTION RealNum + ! + SUBROUTINE LowCase (str1, str2) + !----- -------- --------- --------- --------- --------- --------- --------- ------- + ! Transform upper case letters in str1 into lower case letters, result is str2 + !----- -------- --------- --------- --------- --------- --------- --------- ------- + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(in) :: str1 + CHARACTER (LEN=*), INTENT(out) :: str2 + INTEGER :: j,k + CHARACTER (LEN=*), PARAMETER :: lc = 'abcdefghijklmnopqrstuvwxyz' + CHARACTER (LEN=*), PARAMETER :: uc = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + !----- -------- --------- --------- --------- --------- --------- --------- ------- + str2 = str1 + DO j=1,LEN_TRIM(str1) + k = INDEX(uc,str1(j:j)) + IF (k > 0) str2(j:j) = lc(k:k) + END DO + END SUBROUTINE LowCase + ! +END MODULE fparser diff --git a/OpticsJan2020/MLI_light_optics/Src/gendip5.f b/OpticsJan2020/MLI_light_optics/Src/gendip5.f new file mode 100755 index 0000000..b516b03 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/gendip5.f @@ -0,0 +1,641 @@ +************************************************************************ +* header GENDIP (GENMAP for a "parallel" face dipole * +* magnet with soft fringe fields * +* All routines needed for this special GENMAP * +************************************************************************ +c + subroutine bderivs(z,y,b) +c This routine computes b(z) = Int(-Inf to z) By(z') dz +c and the second and fourth derivative b2(z) and b4(z) for +c (a dipole magnet.) + use beamdata + include 'impli.inc' + include 'dip.inc' +c---------------------------------------- + double precision z, y(*), b(0:6,0:6) +c---------------------------------------- + external amyf,f1,f2,f4,f6 +c---------------------------------------- + epsz2 = gap/sl + bb = (By*sl) + do 10 i=0,6 + do 10 j=0,6 + b(i,j) = 0.0d0 + 10 continue +c +c b = (amyf(z-za,epsz2) - amyf(z-zb,epsz2)) * bb + b(0,0)= (f1(z-za,epsz2) -f1(z-zb,epsz2)) * bb + b(0,1)= (f2(z-za,epsz2) -f2(z-zb,epsz2)) * bb + b(0,3)= (f4(z-za,epsz2) -f4(z-zb,epsz2)) * bb +c b6= (f6(z-za,epsz2)-f6(z-zb,epsz2)) * bb + return + end +c + function amyf(y,eps) + double precision amyf,y,eps + if (y/eps.lt.0.d0) then + amyf = eps*Log(1 + Exp(2*y/eps))/2 + else + amyf = y + eps*Log(Exp(-2*y/eps)+1)/2 + endif + return + end +c + function f1(y,eps) + double precision f1,y,eps + f1 = tanh(y/eps)/2.d0 +.5d0 + return + end +c + function f2(y,eps) + double precision f2,y,eps + if (dabs(y/eps).lt.10.d0) then + f2 = 2*Exp(2*y/eps)/(eps*(1 + Exp(2*y/eps))**2) + else + f2 = 0.d0 + endif + return + end +c + function f4(y,eps) + double precision f4,y,eps + if (dabs(y/eps).lt.10.d0) then + f4 = 8*Exp(2*y/eps)* + & (1 - 4*Exp(2*y/eps) + Exp(4*y/eps))/ + & (eps**3*(1 + Exp(2*y/eps))**4) + else + f4 = 0.0d0 + endif + return + end +c + function f6(y,eps) + double precision f6,y,eps + if (dabs(y/eps).lt.10.d0) then + f6 = 32*Exp(2*y/eps)* + & (1 - 26*Exp(2*y/eps) + + & 66*Exp(4*y/eps) - + & 26*Exp(6*y/eps) + Exp(8*y/eps))/ + & (eps**5*(1 + Exp(2*y/eps))**6) + else + f6 = 0.d0 + endif + return + end +c +************************************************************************ + subroutine gendip(p,fa,fm) +c This is a subroutine for computing the map for a soft edged dipole +c magnet ( F. Neri 5/16/89 ). +c The routine is based on Rob Ryne original gendip, but all the code has been +c rewritten. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + include 'hmflag.inc' + include 'combs.inc' + include 'files.inc' + include 'dip.inc' + include 'pie.inc' +c +c calling arrays + dimension p(6) + dimension fa(monoms), fm(6,6) +c +c local arrays + dimension pb(6) + dimension y(monoms+15) +c + real ttaa, ttbb +c +c use equivalence statement to make the various parameter sets pstj +c available as if they were in a two dimensional array +c +c +c y(1-6) = given (design) trajectory +c y(7-42) = matrix +c y(43-98) = f3 +c y(99-224) = f4 +c +c get interval and number of steps from GENREC parameters +c + za = p(1) + zb = p(2) + ns = 10000 + By = p(3) + phi = p(4) * pi180 + s = sin(phi) + gap = p(5) + zi = 0.0d0 + zf = p(6) +c + write(6,*) 'za=',za,'zb=',zb + write(6,*) 'By=',By,'phi=',p(4) + write(6,*) 'gap=',gap,'zf=',zf +c + jtty = 1 + jdsk = 1 +c +c if((isend.eq.1).or.(isend.eq.3)) jtty = 1 +c if((isend.eq.2).or.(isend.eq.3)) jdsk = 1 +c + h=(zf-zi)/float(ns) +c +c call VAX system routine for timing report +c + ttaa = secnds(0.0) +c +c initial values for design orbit (in dimensionless units) : +c + y(1)=0.d0 + y(2)= s + y(3)=0.d0 + y(4)=0.d0 + y(5)=0.d0 + y(6)=-1.d0/beta +c set constants + qbyp=1.d0/brho + ptg=-1.d0/beta +c +c initialize map to the identity map: + ne=224 + do 40 i=7,ne + 40 y(i)=0.d0 + do 50 i=1,6 + j=7*i + 50 y(j)=1.d0 +c +c do the computation: + t=zi + iflag = 3 + call adam11(h,ns,'start',t,y) + call errchk(y(7)) + call putmap(y,fa,fm) + s1 = -y(2) + phi1 = dasin(s1) + phi1deg = phi1/pi180 + write(jof , 991) phi1deg + write(jodf, 991) phi1deg +991 format(' Final angle is ',f16.8,' degrees') +c +c call VAX system routine for timing report +c + ttbb = secnds(ttaa) + if(jtty.eq.1) write( jof,567) ttbb + if(jdsk.eq.1) write(jodf,567) ttbb + 567 format(' GENDIP integration time = ',f12.2,' sec.') + end +c +********************************************************************** +c + subroutine hmltn3(t,y,h) +c this routine is used to specify h(z) for a dipole magnet. +c Written by F. Neri, 5/16/89. +c Modified 6/3/89 to handle different gauges. +c The design orbit is assumed to be in the Y = 0 plane. +c B Field derivatives on the design orbit are provided by the routine +c BDERIVS as a function of z,and x = y(1), bderivs is called as +c call bderivs(z,y,b) +c The derivatives are stored in the array b(0:*,0:*), defined in the +c include file bfield.inc, and passed to other parts of the program +c in the common/bfield/b(0:*,0:*) +c The array b is arranged so that B(0,0) is By, B(1,0) is d(By)/(dX), +c b(1,1) is d2(By)/(dX dz), etc. +c + use beamdata + use lieaparam, only : monoms + parameter (itop=209,iplus=224) + include 'impli.inc' + include 'dip.inc' + include 'bfield.inc' +c + dimension h(monoms),y(*) +c + dimension X(0:itop),YY(0:itop),P1(0:itop),P2(0:itop) + dimension A(0:12) +c begin calculation +c +c compute gradients + call bderivs(t,y,b) +c +c initialization + do 10 i=1,monoms + 10 h(i)=0.d0 +c +c cccc +c Slow method to produce hamiltonian: use polynomial +c expansion of square root: when this method works we will use it to +c to check the "hardwired" version. +c cccc +c Coefficients of expansion of -SQRT(1+X)+1 + A(0) = 0.d0 + A(1) = -1.d0/2.d0 + do 50 i=2, 6 + A(i) = A(i-1) * (1.d0/2.d0 - (i-1.d0))/i + 50 continue +c + do 60 i=0,209 + X(i) = 0.d0 + 60 continue + X(6) = -2.d0 / beta +c X(13) = -1.d0 + X(22) = -1.d0 + X(27) = 1.d0 +c + maxord = 4 + nn = 4 + cos2 = 1 - y(2)**2 +c P1 = px - q Ax + do 101 i=0,itop + 101 P1(i) = 0.d0 +c Note constant term in px - q Ax, coming from design orbit +c y(2) = Px = sin(phi). + P1(0) = y(2) +c + P1(2) = 1.d0 + P1(18) = b(0,1)/(2.d0*brho) + P1(39) = b(1,1)/(2.d0*brho) + P1(95) = b(2,1)/(4.d0*brho) + P1(175) = -(b(2,1)+b(0,3))/(24.d0*brho) +c P2 = P1**2 + call mypmult(P1,P1,P2,maxord) +c Zero order term subtracted ( Sum starts at 1 ): +c Divide by cos2 + do 102 i=1,itop + 102 X(i) = (X(i) - P2(i))/cos2 +c X = pt**2 - 2/beta*pt - (px -q Ax)**2 - (py)**2 +c YY = -Sqrt(1+X) + call mypoly1(nn,A,X,YY,maxord) +c h = -Az + h(7) = b(1,0)/(2.d0*brho) + h(18) = -b(1,0)/(2.d0*brho) + h(28) = b(2,0)/(6.d0*brho) + h(39) = -b(2,0)/(6.d0*brho) + h(84) = b(3,0)/(24.d0*brho) + h(95) = -b(3,0)/(4.d0*brho) + h(175) = (b(3,0)+b(1,2))/(24.d0*brho) +c h = -Sqrt(1+X) - Az +c Zero and first order terms subtracted ( Sum starts at 7 ): +c Scale by cos + do 70 i=7, 209 + h(i) = h(i) + dsqrt(cos2)*YY(i)/sl + 70 continue +c + return + end +c +c ****************************************************************** +c +c Aux polynomial routines (really a poor man's DA package). +c They don't really belong here. +c +c ****************************************************************** +c + subroutine mypoly1(N,A,X,Y,maxord) + parameter (MN=6) + include 'lims.inc' + double precision X(0:209),Y(0:209) + double precision A(0:N) +c + double precision Vect(0:209,MN) +c +c NO COMMENT + do 100 i=0,top(maxord) + 100 Y(i) = 0.0d0 + do 200 i=0,top(maxord) + 200 Vect(i,1) = X(i) + do 300 iord=2,N + call mypmult(X,Vect(0,iord-1),Vect(0,iord),maxord) + 300 continue + Y(0) = A(0) + do 400 iord=1,N + do 500 i=0,top(maxord) + Y(i) = Y(i) + Vect(i,iord)*A(iord) + 500 continue + 400 continue + return + end +c + subroutine mypmult(p1,p2,p3,maxord) + double precision p1(0:209),p2(0:209),p3(0:209) +c + include 'lims.inc' + if (maxord.lt.0) return +c + do 10 i=1,top(maxord) + 10 p3(i) = 0.0d0 + p3(0) = p1(0) * p2(0) + do 100 mord=1,maxord + call mypmadd(p1(1),mord,p2(0),p3(1)) + call mypmadd(p2(1),mord,p1(0),p3(1)) + do 200 nord1 = 1,mord-1 + nord2 = mord - nord1 + call myproduct(p1(1),nord1,p2(1),nord2,p3(1)) + 200 continue + 100 continue + return + end +c + subroutine mypmadd(f,n,coeff,h) + implicit double precision (a-h,o-z) + dimension f(209),h(209) + include 'len.inc' + include 'lims.inc' + if(coeff.eq.1.d0) goto 20 + do 10 i=len(n-1)+1,len(n) + h(i) = h(i) + f(i)*coeff + 10 continue + return + 20 continue + do 30 i = len(n-1)+1, len(n) + h(i) = h(i) + f(i) + 30 continue + return + end +c + subroutine myproduct(a,na,b,nb,c) + use lieaparam, only : monoms + include 'impli.inc' + include 'len.inc' + include 'expon.inc' + include 'vblist.inc' + dimension a(209),b(209),c(209),l(6) + if(na.eq.1) then + ia1 = 1 + else + ia1 = len(na-1)+1 + endif + if(nb.eq.1) then + ib1 = 1 + else + ib1 = len(nb-1)+1 + endif + do 200 ia=ia1,len(na) + if(a(ia).eq.0.d0) goto 200 + do 20 ib = ib1,len(nb) + if(b(ib).eq.0.d0) goto 20 + do 2 m=1,6 + l(m) = expon(m,ia) + expon(m,ib) + 2 continue + n = ndex(l) + c(n) = c(n) + a(ia)*b(ib) + 20 continue + 200 continue + return + end +c +*********************************************************************** +c + subroutine nndrift(l,phideg,h,mh) +c +c Transverse entry drift. +c generates linear matrix mh and +c array h containing nonlinearities +c for the transfer map describing +c a drift section of length l meters, +c with the design trajectory at an angle of phideg degrees +c F. Neri 5/24/89 +c Actual code generated by Johannes Van Zeijts using +c REDUCE. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' + double precision l,h(monoms),mh(6,6) +c + double precision lsc + dimension j(6) +c + DOUBLE PRECISION UL + DOUBLE PRECISION UB + DOUBLE PRECISION CO + DOUBLE PRECISION Si + DIMENSION UDERS(923) + DOUBLE PRECISION UDERS + DOUBLE PRECISION T1 +c + call clear(h,mh) + lsc=l/sl +c + phi = phideg*pi180 + SI = SIN(phi) + CO = COS(phi) +c +c add drift terms to mh +c + do 40 k=1,6 + mh(k,k)=+1.0d0 + 40 continue + mh(1,2)=+lsc*(1.d0/CO + SI**2/CO**3) + mh(1,6)=+lsc*SI/(beta*CO**3) + mh(3,4)=+lsc*(1.d0/CO) + mh(5,2)=+lsc*SI/(beta*CO**3) + mh(5,6)=+lsc*(-1.d0/CO+1.d0/(beta**2*CO**3)) +c mh(5,6)=+(lsc/((gamma**2)*(beta**2))) +c +c add drift terms to h + UL = lsc + UB = beta +c + do 1 i=1,923 + UDERS(i) = 0.0d0 + 1 continue +c +c From: CINCOM::JOHANNES "Johannes van Zeijts" 23-MAY-1989 16:38 +c + UDERS(923) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7)) + (-2.1875D0 + & ) * (UL / (UB ** 4 * CO ** 9)) + 1.3125D0 * (UL / (UB ** 6 + & * CO ** 11)) + (-6.25D-02) * (UL / CO ** 5) + UDERS(910) = (-1.875D0) * (UL / (UB ** 2 * CO ** 7)) + 2.1875D0 + & * (UL / (UB ** 4 * CO ** 9)) + 0.1875D0 * (UL / CO ** 5) + UDERS(901) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7)) + (-0.1875D0 + & ) * (UL / CO ** 5) + UDERS(896) = 6.25D-02 * (UL / CO ** 5) + UDERS(839) = 1.875D0 * ((UL * SI) / (UB * CO ** 7)) + ( + & -8.75D0) * ((UL * SI) / (UB ** 3 * CO ** 9)) + 7.875D0 * + & ((UL * SI) / (UB ** 5 * CO ** 11)) + UDERS(828) = (-3.75D0) * ((UL * SI) / (UB * CO ** 7)) + + & 8.75D0 * ((UL * SI) / (UB ** 3 * CO ** 9)) + UDERS(821) = 1.875D0 * ((UL * SI) / (UB * CO ** 7)) + UDERS(783) = (-1.875D0) * (UL / (UB ** 2 * CO ** 7)) + 2.1875D0 + & * (UL / (UB ** 4 * CO ** 9)) + 0.1875D0 * (UL / CO ** 5) + & + (-13.125D0) * ((UL * SI ** 2) / (UB ** 2 * CO ** 9)) + + & 19.6875D0 * ((UL * SI ** 2) / (UB ** 4 * CO ** 11)) + + & 0.9375D0 * ((UL * SI ** 2) / CO ** 7) + UDERS(774) = 1.875D0 * (UL / (UB ** 2 * CO ** 7)) + (-0.375D0) + & * (UL / CO ** 5) + 13.125D0 * ((UL * SI ** 2) / (UB ** 2 + & * CO ** 9)) + (-1.875D0) * ((UL * SI ** 2) / CO ** 7) + UDERS(769) = 0.1875D0 * (UL / CO ** 5) + 0.9375D0 * ((UL * SI + & ** 2) / CO ** 7) + UDERS(748) = (-3.75D0) * ((UL * SI) / (UB * CO ** 7)) + + & 8.75D0 * ((UL * SI) / (UB ** 3 * CO ** 9)) + (-8.75D0) * + & ((UL * SI ** 3) / (UB * CO ** 9)) + 26.25D0 * ((UL * SI + & ** 3) / (UB ** 3 * CO ** 11)) + UDERS(741) = 3.75D0 * ((UL * SI) / (UB * CO ** 7)) + 8.75D0 * + & ((UL * SI ** 3) / (UB * CO ** 9)) + UDERS(728) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7)) + (-0.1875D0 + & ) * (UL / CO ** 5) + 13.125D0 * ((UL * SI ** 2) / (UB ** + & 2 * CO ** 9)) + (-1.875D0) * ((UL * SI ** 2) / CO ** 7) + & + 19.6875D0 * ((UL * SI ** 4) / (UB ** 2 * CO ** 11)) + ( + & -2.1875D0) * ((UL * SI ** 4) / CO ** 9) + UDERS(723) = 0.1875D0 * (UL / CO ** 5) + 1.875D0 * ((UL * SI + & ** 2) / CO ** 7) + 2.1875D0 * ((UL * SI ** 4) / CO ** 9 + & ) + UDERS(718) = 1.875D0 * ((UL * SI) / (UB * CO ** 7)) + 8.75D0 + & * ((UL * SI ** 3) / (UB * CO ** 9)) + 7.875D0 * ((UL * + & SI ** 5) / (UB * CO ** 11)) + UDERS(714) = 6.25D-02 * (UL / CO ** 5) + 0.9375D0 * ((UL * SI + & ** 2) / CO ** 7) + 2.1875D0 * ((UL * SI ** 4) / CO ** + & 9) + 1.3125D0 * ((UL * SI ** 6) / CO ** 11) + UDERS(461) = 0.375D0 * (UL / (UB * CO ** 5)) + (-1.25D0) * (UL + & / (UB ** 3 * CO ** 7)) + 0.875D0 * (UL / (UB ** 5 * CO ** + & 9)) + UDERS(450) = (-0.75D0) * (UL / (UB * CO ** 5)) + 1.25D0 * (UL / + & (UB ** 3 * CO ** 7)) + UDERS(443) = 0.375D0 * (UL / (UB * CO ** 5)) + UDERS(405) = (-3.75D0) * ((UL * SI) / (UB ** 2 * CO ** 7)) + + & 4.375D0 * ((UL * SI) / (UB ** 4 * CO ** 9)) + 0.375D0 * ( + & (UL * SI) / CO ** 5) + UDERS(396) = 3.75D0 * ((UL * SI) / (UB ** 2 * CO ** 7)) + ( + & -0.75D0) * ((UL * SI) / CO ** 5) + UDERS(391) = 0.375D0 * ((UL * SI) / CO ** 5) + UDERS(370) = (-0.75D0) * (UL / (UB * CO ** 5)) + 1.25D0 * (UL / + & (UB ** 3 * CO ** 7)) + (-3.75D0) * ((UL * SI ** 2) / (UB + & * CO ** 7)) + 8.75D0 * ((UL * SI ** 2) / (UB ** 3 * CO + & ** 9)) + UDERS(363) = 0.75D0 * (UL / (UB * CO ** 5)) + 3.75D0 * ((UL * + & SI ** 2) / (UB * CO ** 7)) + UDERS(350) = 3.75D0 * ((UL * SI) / (UB ** 2 * CO ** 7)) + ( + & -0.75D0) * ((UL * SI) / CO ** 5) + 8.75D0 * ((UL * SI + & ** 3) / (UB ** 2 * CO ** 9)) + (-1.25D0) * ((UL * SI ** 3 + & ) / CO ** 7) + UDERS(345) = 0.75D0 * ((UL * SI) / CO ** 5) + 1.25D0 * ((UL * + & SI ** 3) / CO ** 7) + UDERS(340) = 0.375D0 * (UL / (UB * CO ** 5)) + 3.75D0 * ((UL * + & SI ** 2) / (UB * CO ** 7)) + 4.375D0 * ((UL * SI ** 4) + & / (UB * CO ** 9)) + UDERS(336) = 0.375D0 * ((UL * SI) / CO ** 5) + 1.25D0 * ((UL + & * SI ** 3) / CO ** 7) + 0.875D0 * ((UL * SI ** 5) / + & CO ** 9) + UDERS(209) = (-0.75D0) * (UL / (UB ** 2 * CO ** 5)) + 0.625D0 * + & (UL / (UB ** 4 * CO ** 7)) + 0.125D0 * (UL / CO ** 3) + UDERS(200) = 0.75D0 * (UL / (UB ** 2 * CO ** 5)) + (-0.25D0) * + & (UL / CO ** 3) + UDERS(195) = 0.125D0 * (UL / CO ** 3) + UDERS(174) = (-1.5D0) * ((UL * SI) / (UB * CO ** 5)) + 2.5D0 + & * ((UL * SI) / (UB ** 3 * CO ** 7)) + UDERS(167) = 1.5D0 * ((UL * SI) / (UB * CO ** 5)) + UDERS(154) = 0.75D0 * (UL / (UB ** 2 * CO ** 5)) + (-0.25D0) * + & (UL / CO ** 3) + 3.75D0 * ((UL * SI ** 2) / (UB ** 2 * + & CO ** 7)) + (-0.75D0) * ((UL * SI ** 2) / CO ** 5) + UDERS(149) = 0.25D0 * (UL / CO ** 3) + 0.75D0 * ((UL * SI ** + & 2) / CO ** 5) + UDERS(144) = 1.5D0 * ((UL * SI) / (UB * CO ** 5)) + 2.5D0 * ( + & (UL * SI ** 3) / (UB * CO ** 7)) + UDERS(140) = 0.125D0 * (UL / CO ** 3) + 0.75D0 * ((UL * SI ** + & 2) / CO ** 5) + 0.625D0 * ((UL * SI ** 4) / CO ** 7) + UDERS(83) = (-0.5D0) * (UL / (UB * CO ** 3)) + 0.5D0 * (UL / ( + & UB ** 3 * CO ** 5)) + UDERS(76) = 0.5D0 * (UL / (UB * CO ** 3)) + UDERS(63) = 1.5D0 * ((UL * SI) / (UB ** 2 * CO ** 5)) + ( + & -0.5D0) * ((UL * SI) / CO ** 3) + UDERS(58) = 0.5D0 * ((UL * SI) / CO ** 3) + UDERS(53) = 0.5D0 * (UL / (UB * CO ** 3)) + 1.5D0 * ((UL * SI + & ** 2) / (UB * CO ** 5)) + UDERS(49) = 0.5D0 * ((UL * SI) / CO ** 3) + 0.5D0 * ((UL * + & SI ** 3) / CO ** 5) +c + do 2 i=1, monoms + h(i) = -UDERS(i) + 2 continue + return + end +c +*********************************************************************** +c + subroutine myprot(phideg,h,mh) +c +c High order PROT routine. +c Actual code generated by Johannes van Zeijts using +c REDUCE. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' + double precision l,h(monoms),mh(6,6) +c + dimension j(6) +c + DOUBLE PRECISION B + DOUBLE PRECISION CO + DOUBLE PRECISION Si +c + call clear(h,mh) +c + B = beta + phi = phideg*pi180 + SI = SIN(phi) + CO = COS(phi) +c + mh(1,1)=1.0d0/CO + mh(2,2)=CO + mh(2,6)=(-SI)/B + mh(3,3)=1.0d0 + mh(4,4)=1.0d0 + mh(5,1)=SI/(B*CO) + mh(5,5)=1.0d0 + mh(6,6)=1.0d0 +c + h(34) =(-SI)/(2.0d0*CO) + h(43) =(-SI)/(2.0d0*CO) + h(48) =(SI*(B**2-1))/(2.0d0*B**2*CO) + h(105) =SI**2/(4.0d0*(SI**2-1)) + h(109) =(-SI)/(2.0d0*B*CO) + h(114) =SI**2/(4.0d0*(SI**2-1)) + h(119) =(SI**2*(-B**2+1))/(4.0d0*B**2*(SI**2-1)) + h(132) =(-SI)/(2.0d0*B*CO) + h(139) =(SI*(B**2-1))/(2.0d0*B**3*CO) + h(266) =SI/(8.0d0*CO*(SI**2-1)) + h(270) =SI**2/(2.0d0*B*(SI**2-1)) + h(275) =(SI*(-2.0d0*SI**2+3))/(12.0d0*CO*(SI**2-1)) + h(280) =(SI*(2.0d0*B**2*SI**2-3.0d0*B**2-8.0d0*SI**2+9))/( + & 12.0d0*B**2*CO*(SI**2-1)) + h(293) =SI**2/(2.0d0*B*(SI**2-1)) + h(300) =(SI**2*(-B**2+1))/(2.0d0*B**3*(SI**2-1)) + h(321) =(SI*(-4.0d0*SI**2+3))/(24.0d0*CO*(SI**2-1)) + h(326) =(SI*(4.0d0*B**2*SI**2-3.0d0*B**2-10.0d0*SI**2+9))/( + & 12.0d0*B**2*CO*(SI**2-1)) + h(335) =(SI*(-4.0d0*B**4*SI**2+3.0d0*B**4+20.0d0*B**2*SI**2- + & 18.0d0*B**2-16.0d0*SI**2+15))/(24.0d0*B**4*CO*(SI**2-1)) + h(588) =(SI**2*(SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+1)) + h(592) =(SI*(SI**2+6))/(16.0d0*B*CO*(SI**2-1)) + h(597) =(SI**2*(3.0d0*SI**2-4))/(16.0d0*(SI**4-2.0d0*SI**2+ + & 1)) + h(602) =(SI**2*(-3.0d0*B**2*SI**2+4.0d0*B**2+15.0d0*SI**2-16.0d0 + & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) + h(615) =(3.0d0*SI*(-SI**2+2))/(8.0d0*B*CO*(SI**2-1)) + h(622) =(SI*(3.0d0*B**2*SI**2-6.0d0*B**2-7.0d0*SI**2+10))/( + & 8.0d0*B**3*CO*(SI**2-1)) + h(643) =(SI**2*(5.0d0*SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+ + & 1)) + h(648) =(SI**2*(-5.0d0*B**2*SI**2+4.0d0*B**2+17.0d0*SI**2-16.0d0 + & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) + h(657) =(SI**2*(5.0d0*B**4*SI**2-4.0d0*B**4-34.0d0*B**2*SI**2 + & +32.0d0*B**2+29.0d0*SI**2-28))/(32.0d0*B**4*(SI**4-2.0d0*SI**2+ + & 1)) + h(695) =(SI*(-7.0d0*SI**2+6))/(16.0d0*B*CO*(SI**2-1)) + h(702) =(SI*(7.0d0*B**2*SI**2-6.0d0*B**2-11.0d0*SI**2+10))/( + & 8.0d0*B**3*CO*(SI**2-1)) + h(713) =(SI*(-7.0d0*B**4*SI**2+6.0d0*B**4+22.0d0*B**2*SI**2- + & 20.0d0*B**2-15.0d0*SI**2+14))/(16.0d0*B**5*CO*(SI**2-1)) +c + call revf(1,h,mh) +c + return + end +c +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/gengrad_mod.f b/OpticsJan2020/MLI_light_optics/Src/gengrad_mod.f new file mode 100644 index 0000000..8a95dfd --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/gengrad_mod.f @@ -0,0 +1,37 @@ +!*********************************************************************** +! +! gengrad: data module for generalized gradients +! +! Description: This module implements a derived type data container +! for generalized gradients for either electric or magnetic fields. +! +! Version: 0.1 +! Author: D.T.Abell, Tech-X Corp., May.2005 +! +! Comments +! 19.May.05 DTA: Implementing this so both electric and magnetic +! field generalized gradients can use the same data structure. +! +!*********************************************************************** +! + module gengrad_data + implicit none +! +! derived types +! + type gengrad + integer :: nz_intrvl, maxj, maxm + double precision :: zmin, zmax, dz + double precision :: angfrq + ! must allocate zvals(0:nz_intrvl+rkxtra) + ! G1c(0:nz_intrvl+rkxtra,0/1:maxj,0:maxm) + ! G1s(0:nz_intrvl+rkxtra,0/1:maxj,0:maxm) + ! ... + ! G3s(0:nz_intrvl+rkxtra,0/1:maxj,0:maxm) + ! [ rkxtra = extra z values required by adam11 ] + double precision, dimension(:), pointer :: zvals + double precision, dimension(:,:,:), pointer :: G1c,G2c,G3c + double precision, dimension(:,:,:), pointer :: G1s,G2s,G3s + end type gengrad + + end module gengrad_data diff --git a/OpticsJan2020/MLI_light_optics/Src/genm.f b/OpticsJan2020/MLI_light_optics/Src/genm.f new file mode 100755 index 0000000..3bb9a03 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/genm.f @@ -0,0 +1,526 @@ +************************************************************************ +* header GENM (General GENMAP Routines) * +* All routines common to the various GENMAP programs * +************************************************************************ + subroutine putmap(y,fa,fm) +c Written by Rob Ryne, Spring 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension y(monoms+15) + dimension fa(monoms),fm(6,6) + call clear(fa,fm) + do 10 i=28,monoms + 10 fa(i)=y(i+15) + do 20 i=1,6 + do 20 j=1,6 + 20 fm(i,j)=y(i+6*j) + call revf(1,fa,fm) + return + end +c +************************************************************************ +c + subroutine feval(t,yy,f,ne) +c subroutine called by numerical map integration routines +c Written by Rob Ryne, Spring 1986 +c Modified by F. Neri and A. Dragt 9/29/89 +c Generic Vector Potential Version by F. Neri, 3/28/90 +c Merged generic version with existing ML/I version June 2004 RDR/FN/PW +c +c The equations are expressed as dy/dt=f(y;t), where: +c t denotes the independent variable (usually s, the arc length), +c y denotes the transfer map's vector representation (elements 7--938) +c along with the reference trajectory (elements 1--6) +c This subroutine calls subroutine hlmtnN, which should return the +c coefficients of the Hamiltonian, which will depend on the particular +c beamline element (vector potential). +c This routine returns f, the RHS of the equation dy/dt=f. +c +cryneneriwalstrom=== + use lieaparam, only : monoms + use beamdata +cryneneriwalstrom=== +c==dabell== + use e_gengrad + use phys_consts +c==dabell== +c + include 'impli.inc' +************************************************************************ + interface + subroutine hmltnRF(s,y,h) + implicit none + double precision, intent(in) :: s ! longitudinal coordinate + double precision, intent(inout) :: y(:) ! y(1:6)=ref. ptcl. data + double precision, intent(out) :: h(:) ! rf cavity Hamiltonian + end subroutine hmltnRF + end interface +************************************************************************ +c +cryne fix this parameter statement later to use monoms instead of hardwire: + parameter (itop=monoms,iplus=monoms+15) + include 'hmflag.inc' +cryneneriwalstrom=== +cryneneriwalstrom:param.inc replaced w/ "use beamdata..." +cryneneriwalstrom:parm.inc replaced w/ "use lieaparam..."(needed by vecpot.inc) + include 'bfield.inc' + include 'gronax.inc' + include 'vecpot.inc' +cryneneriwalstrom=== + dimension h(itop),hint(itop),temp(itop),t5a(itop),t5b(itop) + dimension yy(iplus),f(iplus) + dimension ajsm(6,6) +cryne 7/11/2002 this missing "save" cost me many hours of lost sleep! +cryne 7/11/2002 would be nice to deal w/ the issue of save statements +cryne 7/11/2002 once and for all. + save ajsm,h +cryneneriwalstrom: check to make sure there are not other variables that +cryneneriwalstrom need to be saved in the merged version +c +c y(1-6) = given (design) trajectory +c y(7-42) = matrix +c y(43-98) = f3 +c y(99-224) = f4 +c y(225-476) = f5 +c y(477-938) = f6 +c +c design trajectory: +c NB We have assumed the coordinates have been selected so that +c the design trajectory is yy(i)=0.d0 for i=1 to 6. + f(1)=0.d0 + f(2)=0.d0 + f(3)=0.d0 + f(4)=0.d0 + f(5)=0.d0 + f(6)=0.d0 +c +c matrix and polynomials: +c the expressions for f below are from p. 2742 of +c J. Math.Phys.,Vol 24,No.12,Dec 1983 (A.J.Dragt and E.Forest) +c +c select and compute hamiltonian, s matrix, and ajsm=-j*s +c skip these steps if iflag=0 + if (iflag.eq.0) go to 100 +c otherwise carry out the selection and required computations +cryneneriwalstrom go to (10,20),iflag + go to (10,20,30,40,50),iflag + write(6,*) 'trouble with iflag in subroutine feval' + call myexit + 10 call hmltn1(h) + call matify(ajsm,h) + goto 100 + 20 call hmltn2(t,yy,h) + call matify(ajsm,h) + go to 100 +cryneneriwalstrom eventually, need to check that this works for +cryneneriwalstrom arbitrary choice of units. +c +cryneneriwalstrom===== code from Neri generic version follows: + 30 continue + call hmltn3(t,yy,h) + call matify(ajsm,h) +c Change in design trajectory in the general case: no midplane symmetry + q = 1./brho + x = yy(1) + y = yy(3) +c t = yy(5) Oh boy! + Px = yy(2) + Py = yy(4) + Pt = yy(6) +c + k1 = 1 + k2 = 2 + k3 = 3 + k4 = 4 + k5 = 5 + k6 = 6 +c +c Hamilton equations, given vector potential (Ax,Ay,Az): +c + Pix = yy(2) - Ax(0) + Piy = yy(4) - Ay(0) +cryneabell:9.Nov.05: beta and gamma do not change in dipole, so okay here +cryneabell:9.Nov.05: rfcavity (below) requires continous update + xm2 = 1.d0/(gamma*beta)**2 +c + root = Dsqrt(-xm2 + yy(6)**2 - Pix**2 - Piy**2) +c + f(k1) = Pix/root + f(k2) = (Ax(1)*Pix+Ay(1)*Piy)/root + Az(1) + f(k3) = Piy/root + f(k4) = (Ax(3)*Pix+Ay(3)*Piy)/root + Az(3) + f(k5) = (-yy(6))/root + f(k6)=0 +c write(6,*) t, Pix, yy(1) +c write(36,*) t, Pix, yy(1) + goto 100 +cryneneriwalstrom===== code from Neri generic version above +c +c solenoid + 40 continue ! uses static units + call hmltn4(t,yy,h) + call matify(ajsm,h) + ! no need to integrate reftraj for this element + !betag=-1.d0/yy(6) + !f(1:6)=0.d0 + !f(5)=1.d0/(sl*betag) + go to 100 +c +cdabell===code for nonlinear rf cavity=== + 50 continue + call hmltnRF(t,yy,h) + call matify(ajsm,h) +c given (reference) trajectory + xg = yy(1) + pxg = yy(2) + yg = yy(3) + pyg = yy(4) + tg = yy(5) + ptg = yy(6) +c +c Hamilton equations for given given vector potential (Ax,Ay,Az): +c here using dynamic units, which sets p_ref=mc +c also, the vector potential has already been multiplied by e/p_ref + !write(6,*) "... computing reftraj ..." + !write(6,*) "sl=",sl + !write(6,*) "omegascl=",omegascl + !write(6,*) "c_light=",c_light + !write(6,*) "beta=",beta + write(60,*) t,tg,ptg + wlbyc=omegascl*sl/c_light + gammag=-wlbyc*ptg + betag=sqrt((gammag+1.d0)*(gammag-1.d0))/gammag + f(1:4)=0.d0 + f(5)=wlbyc/(sl*betag) + f(6)=vp%Az(5)/sl + ! + goto 100 +cdabell================================== +c +c================================== +c Insert your code here! +c================================== +c + 100 continue +c +c continue to evaluate f's +c +c matrix part: dm/dt = j*s*m = -ajsm*m + do 110 i=7,42 + 110 f(i)=0.d0 + do 120 i=1,6 + do 120 j=1,6 + do 120 k=1,6 +c compute xm2dot(i,j) = -ajsm(i,k)*xm2(k,j) + ij=i+6*j + 120 f(ij)=f(ij) - ajsm(i,k)*yy(k+6*j) + if(ne.eq.42)return +c +c compute f3dot ********************************** + call xform5(h,3,yy(7),hint) + do 130 i=43,98 + 130 f(i)=-hint(i-15) + if(ne.eq.98)return +c compute f4dot ********************************** + call xform5(h,4,yy(7),hint) + call pbkt1(yy(16),3,f(16),3,temp) + do 140 i=99,224 + 140 f(i)=-hint(i-15)+0.5*temp(i-15) + if(ne.eq.224)return +c compute f5dot ********************************** + call xform5(h,5,yy(7),hint) + call pbkt1(yy(16),3,temp,4,t5a) + call pbkt1(yy(16),3,f(16),4,t5b) + do 150 i=225,476 + 150 f(i)=-hint(i-15)-t5a(i-15)/6.d0+t5b(i-15) + if(ne.eq.476)return +c compute f6dot ********************************** + call xform5(h,6,yy(7),hint) + do 160 i=210,461 + 160 temp(i)=t5a(i)/24.d0-t5b(i)/2.d0+f(15+i) + call pbkt1(yy(16),3,temp,5,t5a) + call pbkt1(yy(16),4,f(16),4,t5b) + do 170 i=477,938 + 170 f(i)=-hint(i-15)+t5a(i-15)+t5b(i-15)/2.d0 +c +c print some terms from the RHS (for debugging) +c ! s t' pt' +c write(61,*) t,f(5:6) +c ! s m11' m12' m21' m22' m55' m56' m65' m66' +c write(62,*) t,f( 7: 8), f(13:14), f(35:36), f(41:42) +c ! s f32' f33' f37' f38' f52' f53' f80'..f83' +c write(63,*) t,f(47:48), f(52:53), f(67:68), f(95:98) +c + return + end +c +************************************************************************ +c + subroutine adam11(h,ns,nf,t,y,ne) +c Written by Rob Ryne, Spring 1986, based on a routine of Alex Dragt +c This integration routine makes local truncation errors at each +c step of order h**11. That is, it is locally correct through +c order h**10. Due to round off errors, its true precision is +c realized only when more than 64 bits are used. + use lieaparam, only : monoms + use beamdata + use phys_consts + include 'impli.inc' + character*6 nf +cryneneriwalstrom fix later to use monoms instead of hardwire: + dimension y(938),yp(938),yc(938),f1(938),f2(938),f3(938),f4(938), + & f5(938),f6(938),f7(938),f8(938),f9(938),f10(938),f11(938) + dimension a(10),am(10),b(10),bm(10) +c + data (a(i),i=1,10)/57281.d0,-583435.d0,2687864.d0, + & -7394032.d0,13510082.d0,-17283646.d0,16002320.d0, + & -11271304.d0,9449717.d0,2082753.d0/ + data (b(i),i=1,10)/-2082753.d0,20884811.d0,-94307320.d0, + & 252618224.d0,-444772162.d0,538363838.d0,-454661776.d0, + & 265932680.d0,-104995189.d0,30277247.d0/ +cryne 7/23/2002 + save a,b +cryne 1 August 2004 ne=monoms+15 +c + nsa=ns + if (nf.eq.'cont') go to 20 +c rk start + iqt=5 + qt=float(iqt) + hqt=h/qt + !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light + !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) + !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) + call feval(t,y,f1,ne) + call rk78ii(hqt,iqt,t,y,ne) + !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light + !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) + !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) + call feval(t,y,f2,ne) + call rk78ii(hqt,iqt,t,y,ne) + !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light + !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) + !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) + call feval(t,y,f3,ne) + call rk78ii(hqt,iqt,t,y,ne) + !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light + !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) + !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) + call feval(t,y,f4,ne) + call rk78ii(hqt,iqt,t,y,ne) + !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light + !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) + !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) + call feval(t,y,f5,ne) + call rk78ii(hqt,iqt,t,y,ne) + !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light + !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) + !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) + call feval(t,y,f6,ne) + call rk78ii(hqt,iqt,t,y,ne) + !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light + !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) + !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) + call feval(t,y,f7,ne) + call rk78ii(hqt,iqt,t,y,ne) + !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light + !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) + !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) + call feval(t,y,f8,ne) + call rk78ii(hqt,iqt,t,y,ne) + !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light + !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) + !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) + call feval(t,y,f9,ne) + call rk78ii(hqt,iqt,t,y,ne) + !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light + !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) + !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) + call feval(t,y,f10,ne) + nsa=ns-9 + hdiv=h/7257600.0d+00 + do 10 i=1,10 + am(i)=hdiv*a(i) + 10 bm(i)=hdiv*b(i) + 20 tint=t + do 100 i=1,nsa + do 30 j=1,ne + yp(j)=y(j)+bm(1)*f1(j)+bm(2)*f2(j)+bm(3)*f3(j) + &+bm(4)*f4(j)+bm(5)*f5(j)+bm(6)*f6(j)+bm(7)*f7(j) + & +bm(8)*f8(j)+bm(9)*f9(j)+bm(10)*f10(j) + 30 continue + call feval(t+h,yp,f11,ne) + do 40 j=1,ne + yp(j)=y(j)+am(1)*f2(j)+am(2)*f3(j)+am(3)*f4(j)+am(4)*f5(j) + & +am(5)*f6(j)+am(6)*f7(j)+am(7)*f8(j)+am(8)*f9(j)+am(9)*f10(j) + 40 yc(j)=yp(j)+am(10)*f11(j) + 41 call feval(t+h,yc,f11,ne) + do 50 j=1,ne + 50 y(j)=yp(j)+am(10)*f11(j) + do 60 j=1,ne + f1(j)=f2(j) + f2(j)=f3(j) + f3(j)=f4(j) + f4(j)=f5(j) + f5(j)=f6(j) + f6(j)=f7(j) + f7(j)=f8(j) + f8(j)=f9(j) + f9(j)=f10(j) + 60 f10(j)=f11(j) + t=tint+i*h + !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light + !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) + !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) + !call myflush(41) + !call myflush(42) + !call myflush(43) + 100 continue + return + end +c +*********************************************************************** +c + subroutine rk78ii(h,ns,t,y,ne) +c Written by Rob Ryne, Spring 1986, based on a routine of +c J. Milutinovic. +c For a reference, see page 76 of F. Ceschino and J Kuntzmann, +c Numerical Solution of Initial Value Problems, Prentice Hall 1966. +c This integration routine makes local truncation errors at each +c step of order h**7. +c That is, it is locally correct through terms of order h**6. +c Each step requires 8 function evaluations. + + use lieaparam, only : monoms + include 'impli.inc' +cryneneriwalstrom fix later to use monoms instead of hardwire: + dimension y(938),yt(938),f(938),a(938),b(938),c(938),d(938), + &e(938),g(938),o(938),p(938) +cryne 1 August 2004 ne=monoms+15 +c + tint=t + do 200 i=1,ns + call feval(t,y,f,ne) + do 10 j=1,ne + 10 a(j)=h*f(j) + do 20 j=1,ne + 20 yt(j)=y(j)+a(j)/9.d+0 + tt=t+h/9.d+0 + call feval(tt,yt,f,ne) + do 30 j=1,ne + 30 b(j)=h*f(j) + do 40 j=1,ne + 40 yt(j)=y(j) + (a(j) + 3.d+0*b(j))/24.d+0 + tt=t+h/6.d+0 + call feval(tt,yt,f,ne) + do 50 j=1,ne + 50 c(j)=h*f(j) + do 60 j=1,ne + 60 yt(j)=y(j)+(a(j)-3.d+0*b(j)+4.d+0*c(j))/6.d+0 + tt=t+h/3.d+0 + call feval(tt,yt,f,ne) + do 70 j=1,ne + 70 d(j)=h*f(j) + do 80 j=1,ne + 80 yt(j)=y(j) + (-5.d+0*a(j) + 27.d+0*b(j) - + & 24.d+0*c(j) + 6.d+0*d(j))/8.d+0 + tt=t+.5d+0*h + call feval(tt,yt,f,ne) + do 90 j=1,ne + 90 e(j)=h*f(j) + do 100 j=1,ne + 100 yt(j)=y(j) + (221.d+0*a(j) - 981.d+0*b(j) + + & 867.d+0*c(j)- 102.d+0*d(j) + e(j))/9.d+0 + tt = t+2.d+0*h/3.d+0 + call feval(tt,yt,f,ne) + do 110 j=1,ne + 110 g(j)=h*f(j) + do 120 j=1,ne + 120 yt(j) = y(j)+(-183.d+0*a(j)+678.d+0*b(j)-472.d+0*c(j)- + & 66.d+0*d(j)+80.d+0*e(j) + 3.d+0*g(j))/48.d+0 + tt = t + 5.d+0*h/6.d+0 + call feval(tt,yt,f,ne) + do 130 j=1,ne + 130 o(j)=h*f(j) + do 140 j=1,ne + 140 yt(j) = y(j)+(716.d+0*a(j)-2079.d+0*b(j)+1002.d+0*c(j)+ + & 834.d+0*d(j)-454.d+0*e(j)-9.d+0*g(j)+72.d+0*o(j))/82.d+0 + tt = t + h + call feval(tt,yt,f,ne) + do 150 j=1,ne + 150 p(j)=h*f(j) + do 160 j=1,ne + 160 y(j) = y(j)+(41.d+0*a(j)+216.d+0*c(j)+27.d+0*d(j)+ + & 272.d+0*e(j)+27.d+0*g(j)+216.d+0*o(j)+41.d+0*p(j))/840.d+0 + t=tint+i*h + 200 continue + return + end +cryneneriwalstrom=== +c removed subroutine poly1 and pmult, which are now in integ.f +c also, left in place below a commented out version of subroutine drift +c as a reminder to ourselves +cryneneriwalstrom=== +c ****************************************************************** +c +c Drift and aux poly routines. +c They don't really belong here. +c +c ***************************************************************** +c +c subroutine drift(l,h,mh) +c +c generates linear matrix mh and +c array h containing nonlinearities +c for the transfer map describing +c a drift section of length l metres +c +c implicit double precision (a-h,o-z) +c double precision l,lsc,mh +c dimension j(6) +c dimension h(923) +c dimension mh(6,6) +c dimension X(0:923), Y(0:923), A(0:6) +c common/parm/brho,c,gamma,gamm1,beta,achg,sl,ts +c +c call clear(h,mh) +c lsc=l/sl +c +c add drift terms to mh +c +c do 40 k=1,6 +c mh(k,k)=+1.0d0 +c 40 continue +c mh(1,2)=+lsc +c mh(3,4)=+lsc +c mh(5,6)=+(lsc/((gamma**2)*(beta**2))) +c +c add drift terms to h +c +c do degree 3-6 +c +c F. Neri Aug. 28 1987 +c +c A(0) = 0.d0 +c A(1) = 1.d0/2.d0 +c do 50 i=2, 6 +c A(i) = A(i-1) * (1.d0/2.d0 - (i-1.d0))/i +c 50 continue +c +c do 60 i=0,923 +c X(i) = 0.d0 +c 60 continue +c X(6) = -2.d0 / beta +c X(13) = -1.d0 +c X(22) = -1.d0 +c X(27) = 1.d0 +c +c maxord = 6 +c nn = 6 +c call poly1(nn,A,X,Y,maxord) +c do 70 i=28, 923 +c h(i) = Y(i) * lsc +c 70 continue +c return +c end +c ******************************************************************* diff --git a/OpticsJan2020/MLI_light_optics/Src/gensol.f b/OpticsJan2020/MLI_light_optics/Src/gensol.f new file mode 100755 index 0000000..78fb2b3 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/gensol.f @@ -0,0 +1,511 @@ +************************************************************************ +* header GENSOL * +* (GENMAP for a solenoid magnet with soft fringe fields) * +* All routines needed for this special GENMAP * +************************************************************************ +c + subroutine gensol(p,fa,fm,jsl,nsl,slfr) +c +c This routine computes the map for a solenoid, by numerical integration. +c F. Neri, 8/18/89; A. Dragt, 10/4/89 +c The routine is based on Rob Ryne original solnsc, but all the code +c has been rewritten. +c Modified by D.T. Abell (15.Jan.07) to include 5th and 6th-order terms +c and enable slicing of solenoids. +c + use beamdata + use lieaparam, only : monoms + use parallel, only : idproc + include 'impli.inc' + include 'parset.inc' + include 'hmflag.inc' + include 'combs.inc' + include 'files.inc' + include 'sol.inc' +c +c calling arrays + dimension p(*) + dimension fa(monoms), fm(6,6) +c +c local arrays + dimension y(monoms+15) +c +c use equivalence statement to make the various parameter sets pstj +c available as if they were in a two dimensional array +c +c +c y(1-6) = given (design) trajectory +c y(7-42) = matrix +c y(43-98) = f3 +c y(99-224) = f4 +c y(225-476) = f5 +c y(477-938) = f6 +c +c get interval and number of steps from GENSOL parameters +c + zi = p(1) + zf = p(2) + ns = nint(p(3)) + ifile = nint(p(4)) + ips = nint(p(5)) + mpole = nint(p(6)) ! not used +c + if(ips.ge.1 .and. ips.le.9)then +c get other parameters from pset + di = pst(1,ips) + tl = pst(2,ips) + cl = pst(3,ips) + bz0 = pst(4,ips) + iecho = nint(pst(5,ips)) + ioptr = nint(pst(6,ips)) +c + elseif(ips.eq.-1)then +c If using sif-style input (type code 'solenoid' instead of 'sol') +c then the code will have set p(5)=-1. +c In that case, the other parameters are in array elements p(7)-p(12) + di = p(7) + tl = p(8) + cl = p(9) + bz0 = p(10) + iecho = nint(p(11)) + ioptr = nint(p(12)) + else + write(6,*)'error in solenoid specification' + write(6,*)'problem with element 5 of array passed to gensol' + stop + endif +c +c dabell Mon Jan 15 09:48:01 PST 2007 +c MaryLie manual defines di as length from zi to start of solenoid body +c but code treats di as z at start of solenoid body; so here we redefine +c di as the code expects. + di = zi + di +c +c complain if cl equals zero + if (cl.eq.0.d0) then + if (idproc.eq.0) then + write(6,*) ' <*** ERROR ***> solenoid specified with' + write(6,*) ' characteristic length of zero!' + end if + call myexit() + end if +c +c set parameters for this slice + if (nsl.gt.1) then + dz=slfr*(zf-zi) + z1=zi+dz*(jsl-1) + z2=zi+dz*jsl + nstep=nint(slfr*ns) + dz=dz/real(nstep) + else + dz = (zf - zi) / real(ns) + z1 = zi + z2 = zf + nstep = ns + end if +c +c +c write out parameters, if desired +c + if (iecho.eq.1.or.iecho.eq.3) then + if (jsl.eq.1) then + write(jof,*) + write(jof,*) ' zi=',zi,' zf=',zf,' nsl=',nsl + write(jof,*) ' ns=',ns + write(jof,*) ' di=',di,' length=',tl + write(jof,*) ' cl=',cl,' B=',bz0 + write(jof,*) ' iopt=',ioptr + write(jof,*) + end if + if (nsl.ne.1) then + write(jof,*) ' z1=',z1,' z2=',z2,' dz=',dz + write(jof,*) ' jsl=',jsl,' nstep=',nstep + write(jof,*) + end if + end if + if (iecho.eq.2.or.iecho.eq.3) then + if (jsl.eq.1) then + write(jodf,*) + write(jodf,*) ' zi=',zi,' zf=',zf,' nsl=',nsl + write(jodf,*) ' ns=',ns + write(jodf,*) ' di=',di,' length=',tl + write(jodf,*) ' cl=',cl,' B=',bz0 + write(jodf,*) ' iopt=',ioptr + write(jodf,*) + end if + if (nsl.ne.1) then + write(jodf,*) ' z1=',z1,' z2=',z2,' dz=',dz + write(jodf,*) ' jsl=',jsl,' nstep=',nstep + write(jodf,*) + end if + end if +c +c +c write out gradient and derivatives on file ifile: + ipflag=0 + if (ifile.ne.0) then + if (ifile.lt.0) then + ipflag=1 + ifile=-ifile + endif + zz = zi + h = (zf - zi) / real(ns) + do 999 ii = 0, ns + call bz04(zz,b0,b2,b4) + write(ifile,137) zz, b0, b2, b4, 0., 0. + 137 format(6(1x,1pg12.5)) + zz = zz + h + 999 continue + write(jof,*) ' profile written on file ',ifile + endif +c +c return identity map if ifile was < 0 +c + if (ipflag .eq. 1) then + call ident(fa,fm) + return + endif +c +c initial values for design orbit (in dimensionless units) : +c + y(1)= 0.d0 + y(2)= 0.d0 + y(3)= 0.d0 + y(4)= 0.d0 + y(5)= 0.d0 ! updated after integration (in afro.f) + y(6)= -1.d0/beta ! for static units (change to dynamic in afro) +c set constants + qbyp= 1.d0/brho + ptg= -1.d0/beta +c +c initialize map to the identity: +c + ne=monoms+15 + do 40 i=7,ne + 40 y(i)=0.d0 + do 50 i=1,6 + j=7*i + 50 y(j)=1.d0 +c +c do the computation: + t=z1 + iflag = 4 +cryne 1 August 2004 fix later: +cryne call adam11(h,ns,'start',t,y) + call adam11(dz,nstep,'start',t,y,ne) + call putmap(y,fa,fm) + call csym(1,fm,ans) +c + return + end +c +************************************************************************* +c + subroutine bz02(z,b0,b2) +c This routine computes b0(z) = Bz(z) +c and the second derivative b2(z) on axis +c Alex Dragt 10/4/89 +c + include 'impli.inc' + include 'sol.inc' +c + zz = z - di + call bump0(zz,cl,tl,ans0) + call bump2(zz,cl,tl,ans2) + b0 = bz0*ans0 + b2 = bz0*ans2 +c + return + end +c +************************************************************************* + subroutine bz04(z,b0,b2,b4) +c +c Return the zeroth, second, and fourth derivatives of the on-axis +c solenoidal field described by the parameters in 'sol.inc'. +c Dan Abell, January 2007 + implicit none + double precision, intent(in) :: z + double precision, intent(out) :: b0,b2,b4 +c-----!----------------------------------------------------------------! + include 'sol.inc' + double precision :: ta,ta2,tb,tb2,zz +c + zz = z - di + ta = tanh(zz/cl) + tb = tanh((zz-tl)/cl) + ta2=ta**2 + tb2=tb**2 + b0 = bz0 * 0.5d0 * (ta - tb) + b2 = -bz0 * (ta * (1.d0 - ta2) - tb * (1.d0 - tb2)) / (cl**2) + b4 = bz0 * 4.d0 * (ta * (1.d0 - ta2) * (2.d0 - 3.d0 * ta2) & + & - tb * (1.d0 - tb2) * (2.d0 - 3.d0 * tb2)) & + & / (cl**4) +c + return + end +c +********************************************************************** +c + subroutine bump0(z,cl,tl,ans0) +c +c This routine computes the soft-edge bump function +c Alex Dragt 10/4/89 +c + include 'impli.inc' +c +c----------------------------------------------------------- + sgn0(z,cl)=tanh(z/cl) +c----------------------------------------------------------- + ans0=( sgn0(z,cl) - sgn0(z-tl,cl) )/2. +c + return + end +c +************************************************************************ +c + subroutine bump2(z,cl,tl,ans2) +c +c This routine computes the second derivative of the soft-edge bump function +c Alex Dragt 10/4/89 +c + include 'impli.inc' +c + zl=z + zr=z-tl + call sgn2(zl,cl,ansl) + call sgn2(zr,cl,ansr) + ans2=(ansl - ansr)/2. +c + return + end +c +********************************************************************* +c + subroutine sgn2(z,cl,ans) +c +c This subroutine computes the second derivative of the approximating +c signum function +c Alex Dragt 10/4/89 +c + include 'impli.inc' +c + ans=0. + if( abs(z/cl) .lt. 30.) then + ans=-(2./(cl**2))*(tanh(z/cl))/((cosh(z/cl))**2) + endif +c + return + end +c +*********************************************************************** +c + subroutine hmltn4(t,y,h) +c +c This routine is used to specify the Hamiltonian h for a solenoid. +c Written by A. Dragt 9/28/89 +c Modified by D.T. Abell to include 5th and 6th-order terms (15.Jan.07) +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'sol.inc' +c +c calling arrays + dimension h(monoms) + dimension y(monoms+15) +c +c begin calculation +c +c compute gradients + call bz04(t,b0,b2,b4) +c +c scale gradients +c + b0=sl*b0/brho + b2=(sl**3)*b2/brho +c +c compute terms in hamiltonian +c + h=0.d0 +c +c terms of degree 2 +c + h( 7)= b0**2/(8.*sl) + h(10)= -b0/(2.*sl) + h(13)= 1./(2.*sl) + h(14)= b0/(2.*sl) + h(18)= b0**2/(8.*sl) + h(22)= 1./(2.*sl) + h(27)= 1./(2.*beta**2*gamma**2*sl) + if (ioptr .ne. 0) then + h(10)= 0.d0 + h(14)= 0.d0 + endif +c +c terms of degree 3 +c + h(33)= b0**2/(8.*beta*sl) + h(45)= -b0/(2.*beta*sl) + h(53)= 1./(2.*beta*sl) + h(57)= b0/(2.*beta*sl) + h(67)= b0**2/(8.*beta*sl) + h(76)= 1./(2.*beta*sl) + h(83)= 1./(2.*beta**3*gamma**2*sl) +c +c terms of degree 4 +c + h( 84)= b0*(b0**3 - 4.*b2)/(128.*sl) + h( 87)= -(b0**3 - b2)/(16.*sl) + h( 90)= b0**2/(16.*sl) + h( 91)= (b0**3 - b2)/(16.*sl) + h( 95)= b0*(b0**3 - 4.*b2)/(64.*sl) + h( 99)= 3.*b0**2/(16.*sl) + h(104)= b0**2*(3. - beta**2)/(16.*beta**2*sl) + h(107)= -b0/(4.*sl) + h(111)= -(b0**2)/(4.*sl) + h(121)= -(b0**3 - b2)/(16.*sl) + h(130)= -b0/(4.*sl) + h(135)= -b0*(3. - beta**2)/(4.*beta**2*sl) + h(140)= 1./(8.*sl) + h(141)= b0/(4.*sl) + h(145)= 3.*b0**2/(16.*sl) + h(149)= 1./(4.*sl) + h(154)= (3. - beta**2)/(4.*beta**2*sl) + h(155)= (b0**3 - b2)/(16.*sl) + h(159)= b0/(4.*sl) + h(164)= b0*(3. - beta**2)/(4.*beta**2*sl) + h(175)= b0*(b0**3 - 4.*b2)/(128.*sl) + h(179)= b0**2/(16.*sl) + h(184)= b0**2*(3. - beta**2)/(16.*beta**2*sl) + h(195)= 1./(8.*sl) + h(200)= (3. - beta**2)/(4.*beta**2*sl) + h(209)= (5. - beta**2)/(8.*beta**4*gamma**2*sl) +c +c terms of degree 5 +c + h(215)= b0*(3.*b0**3 - 4.*b2)/(128.*beta*sl) + h(227)= -(3.*b0**3 - b2)/(16.*beta*sl) + h(235)= 3.*b0**2/(16.*beta*sl) + h(239)= (3.*b0**3 - b2)/(16.*beta*sl) + h(249)= b0*(3.*b0**3 - 4.*b2)/(64.*beta*sl) + h(258)= 9.*b0**2/(16.*beta*sl) + h(265)= b0**2*(5. - 3.*beta**2)/(16.*beta**3*sl) + h(277)= -3.*b0/(4.*beta*sl) + h(287)= -3.*b0**2/(4.*beta*sl) + h(307)= -(3.*b0**3 - b2)/(16.*beta*sl) + h(323)= -3.*b0/(4.*beta*sl) + h(330)= -b0*(5. - 3.*beta**2)/(4.*beta**3*sl) + h(340)= 3./(8.*beta*sl) + h(344)= 3.*b0/(4.*beta*sl) + h(354)= 9.*b0**2/(16.*beta*sl) + h(363)= 3./(4.*beta*sl) + h(370)= (5. - 3.*beta**2)/(4.*beta**3*sl) + h(374)= (3.*b0**3 - b2)/(16.*beta*sl) + h(383)= 3.*b0/(4.*beta*sl) + h(390)= b0*(5. - 3.*beta**2)/(4.*beta**3*sl) + h(409)= b0*(3.*b0**3 - 4.*b2)/(128.*beta*sl) + h(418)= 3.*b0**2/(16.*beta*sl) + h(425)= b0**2*(5. - 3.*beta**2)/(16.*beta**3*sl) + h(443)= 3./(8.*beta*sl) + h(450)= (5. - 3.*beta**2)/(4.*beta**3*sl) + h(461)= (7. - 3.*beta**2)/(8.*beta**5*gamma**2*sl) +c +c terms of degree 6 +c + h(462)= (3.*b0**6 - 12.*b0**3*b2 + 6.*b2**2 + 4.*b0*b4)/(3072.*sl) + h(465)= (-9.*b0**5 + 18.*b0**2*b2 - 2.*b4)/(768.*sl) + h(468)= b0*(3.*b0**3 - 4.*b2)/(256.*sl) + h(469)= (9.*b0**5 - 18.*b0**2*b2 + 2.*b4)/(768.*sl) + h(473)= (3.*b0**6 - 12.*b0**3*b2 + 6.*b2**2 + 4.*b0*b4)/(1024.*sl) + h(477)= b0*(15.*b0**3 - 12.*b2)/(256.*sl) + h(482)= b0*(b0**3*(15. - 3.*beta**2) - b2*(12. - 4.*beta**2)) & + & /(256.*beta**2*sl) + h(485)= -(3.*b0**3 - b2)/(32.*sl) + h(489)= -b0*(3.*b0**3 - 2.*b2)/(32.*sl) + h(499)= -(9.*b0**5 - 18.*b0**2*b2 + 2.*b4)/(384.*sl) + h(508)= -(5.*b0**3 - b2)/(32.*sl) + h(513)= -(b0**3*(15. - 3.*beta**2) - b2*(3. - beta**2)) & + & /(32.*beta**2*sl) + h(518)= 3.*b0**2/(64.*sl) + h(519)= (3.*b0**3 - b2)/(32.*sl) + h(523)= b0*(9.*b0**3 - 8.*b2)/(128.*sl) + h(527)= 9.*b0**2/(32.*sl) + h(532)= 3.*b0**2*(5. - beta**2)/(32.*beta**2*sl) + h(533)= (9.*b0**5 - 18.*b0**2*b2 + 2.*b4)/(384.*sl) + h(537)= (9.*b0**3 - b2)/(32.*sl) + h(542)= (b0**3*(15. - 3.*beta**2) - b2*(3. - beta**2)) & + & /(32.*beta**2*sl) + h(553)= (3.*b0**6 - 12.*b0**3*b2 + 6.*b2**2 + 4.*b0*b4)/(1024.*sl) + h(557)= b0*(9.*b0**3 - 8.*b2)/(128.*sl) + h(562)= b0*(b0**3*(15. - 3.*beta**2) - b2*(12. - 4.*beta**2)) & + & /(128.*beta**2*sl) + h(573)= 15.*b0**2/(64.*sl) + h(578)= b0**2*(45. - 9.*beta**2)/(32.*beta**2*sl) + h(587)= b0**2*(35. - 30.*beta**2 + 3.*beta**4)/(64.*beta**4*sl) + h(590)= -3.*b0/(16.*sl) + h(594)= -3.*b0**2/(8.*sl) + h(604)= -(9.*b0**3 - b2)/(32.*sl) + h(613)= -3.*b0/(8.*sl) + h(618)= -b0*(15 - 3.*beta**2)/(8.*beta**2*sl) + h(624)= -b0*(3.*b0**3 - 2.*b2)/(32.*sl) + h(633)= -3.*b0**2/(8.*sl) + h(638)= -b0**2*(15. - 3.*beta**2)/(8.*beta**2*sl) + h(659)= -(9.*b0**5 - 18.*b0**2*b2 + 2.*b4)/(768.*sl) + h(668)= -(3.*b0**3 - b2)/(32.*sl) + h(673)= -(b0**3*(15. - 3.*beta**2) - b2*(3. - beta**2)) & + & /(32.*beta**2*sl) + h(693)= -3.*b0/(16.*sl) + h(698)= -b0*(15. - 3.*beta**2)/(8.*beta**2*sl) + h(707)= -b0*(35. - 30.*beta**2 + 3.*beta**4)/(16.*beta**4*sl) + h(714)= 1./(16.*sl) + h(715)= 3.*b0/(16.*sl) + h(719)= 15.*b0**2/(64.*sl) + h(723)= 3./(16.*sl) + h(728)= (15. - 3.*beta**2)/(16.*beta**2*sl) + h(729)= (5.*b0**3 - b2)/(32.*sl) + h(733)= 3.*b0/(8.*sl) + h(738)= b0*(15. - 3.*beta**2)/(8.*beta**2*sl) + h(749)= b0*(15.*b0**3 - 12.*b2)/(256.*sl) + h(753)= 9.*b0**2/(32.*sl) + h(758)= b0**2*(45. - 9.*beta**2)/(32.*beta**2*sl) + h(769)= 3./(16.*sl) + h(774)= (15. - 3.*beta**2)/(8.*beta**2*sl) + h(783)= (35. - 30.*beta**2 + 3.*beta**4)/(16.*beta**4*sl) + h(784)= (9.*b0**5 - 18.*b0**2*b2 + 2.*b4)/(768.*sl) + h(788)= (3.*b0**3 - b2)/(32.*sl) + h(793)= (b0**3*(15. - 3.*beta**2) - b2*(3. - beta**2)) & + & /(32.*beta**2*sl) + h(804)= 3.*b0/(16.*sl) + h(809)= b0*(15. -3.* beta**2)/(8.*beta**2*sl) + h(818)= b0*(35. - 30.*beta**2 + 3.*beta**4)/(16.*beta**4*sl) + h(840)= (3.*b0**6 - 12.*b0**3*b2 + 6.*b2**2 + 4.*b0*b4)/(3072.*sl) + h(844)= b0*(3.*b0**3 - 4.*b2)/(256.*sl) + h(849)= b0*(b0**3*(15. - 3.*beta**2) - b2*(12. - 4.*beta**2)) & + & /(256.*beta**2*sl) + h(860)= 3.*b0**2/(64.*sl) + h(865)= b0**2*(15. - 3.*beta**2)/(32.*beta**2*sl) + h(874)= b0**2*(35. - 30.*beta**2 + 3.*beta**4)/(64.*beta**4*sl) + h(896)= 1./(16.*sl) + h(901)= (15. - 3.*beta**2)/(16.*beta**2*sl) + h(910)= (35. - 30.*beta**2 + 3.*beta**4)/(16.*beta**4*sl) + h(923)= (21. - 14.*beta**2 + beta**4)/(16.*beta**6*gamma**2*sl) +c +c add sextupoles +c h(28)=fsxnr*sl2 +c h(30)=-3.d0*fsxsk*sl2 +c h(39)=-3.d0*fsxnr*sl2 +c h(64)=fsxsk*sl2 +c +c add octupoles +c +c h(84)=h(84)+focnr*sl3 +c h(86)=-4.0d0*focsk*sl3 +c h(95)=-6.d0*focnr*sl3 +c h(120)=4.d0*focsk*sl3 +c h(175)=h(175)+focnr*sl3 +c + return + end +c +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/greenfn_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/greenfn_mod.f90 new file mode 100644 index 0000000..3baf6a3 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/greenfn_mod.f90 @@ -0,0 +1,573 @@ +!*********************************************************************** +! +! intgreenfn: module for computing integrated Green functions +! +! Description: This module implements the derived types and subroutines +! for computing 'effective integrated Green functions'. +! +! Version: 0.1 +! Author: D.T.Abell, Tech-X Corp., Jan.2007 +! +! Comments +! 24.Jan.07 DTA: This module currently implements only the 3-D +! integrated Green functions for open boundary conditions. +! +!*********************************************************************** + module intgreenfn + !use parallel, only : idproc + implicit none +! +! data +! + double precision, parameter, private :: dtiny=1.d-13 +! +! derived types +! + type griddata + integer :: NxIntrvl,NyIntrvl,NzIntrvl + integer :: Nx,Ny,Nz,Nx2,Ny2,Nz2 + double precision :: xmin,xmax,ymin,ymax,zmin,zmax + double precision :: hx,hy,hz + double precision :: Vh,Vhinv + end type griddata +! +! functions and subroutines +! + contains +! +!*********************************************************************** + subroutine intgreenphi(grid,g) + use math_consts + implicit none + type(griddata), intent(in) :: grid +! complex*16, dimension(:,:,:), intent(out) :: g + complex*16,dimension(grid%Nx2,grid%Ny2,grid%Nz2),intent(out) :: g + + integer :: ix,nx1,nx12 + integer :: iy,ny1,ny12 + integer :: iz,nz1,nz12 + double precision :: invfourpi,gg,vh2i + + invfourpi=1/fourpi + vh2i = grid%vhinv ** 2 + nx1 = grid%Nx + 1; nx12 = 2 * nx1 + ny1 = grid%Ny + 1; ny12 = 2 * ny1 + nz1 = grid%Nz + 1; nz12 = 2 * nz1 + do iz = 1,nz1 + do iy = 1,ny1 + do ix = 1,nx1 + call geff3phi(grid%hx,grid%hy,grid%hz,ix-1,iy-1,iz-1,gg) + !g(ix,iy,iz) = vh2i * gg + g(ix,iy,iz) = invfourpi * gg + end do + do ix = nx1+1,grid%Nx2 + g(ix,iy,iz) = g(nx12-ix,iy,iz) + end do + end do + do iy = ny1+1,grid%Ny2 + do ix = 1,grid%Nx2 + g(ix,iy,iz) = g(ix,ny12-iy,iz) + end do + end do + end do + do iz = nz1+1,grid%Nz2 + do iy = 1,grid%Ny2 + do ix = 1,grid%Nx2 + g(ix,iy,iz) = g(ix,iy,nz12-iz) + end do + end do + end do + + return + end subroutine intgreenphi +! +!*********************************************************************** + subroutine geff3phi(hx,hy,hz,i,j,k,g) + implicit none + double precision, intent(in) :: hx,hy,hz + integer, intent(in) :: i,j,k + double precision, intent(out) :: g + + double precision :: g000,g001,g010,g011,g100,g101,g110,g111 + + call intg3(hx,hy,hz,i,j,k,0,0,0,g000) + call intg3(hx,hy,hz,i,j,k,0,0,1,g001) + call intg3(hx,hy,hz,i,j,k,0,1,0,g010) + call intg3(hx,hy,hz,i,j,k,0,1,1,g011) + call intg3(hx,hy,hz,i,j,k,1,0,0,g100) + call intg3(hx,hy,hz,i,j,k,1,0,1,g101) + call intg3(hx,hy,hz,i,j,k,1,1,0,g110) + call intg3(hx,hy,hz,i,j,k,1,1,1,g111) + + g = g000 - (g001 + g010 + g100) + (g011 + g101 + g110) - g111 + g = g/(hx*hy*hz)**2 + + return + end subroutine geff3phi +! +!*********************************************************************** + subroutine intg3(hx,hy,hz,i,j,k,r,s,t,g) + implicit none + double precision, intent(in) :: hx,hy,hz + integer, intent(in) :: i,j,k,r,s,t + double precision, intent(out) :: g + + double precision :: a,b,c,xl,xu,yl,yu,zl,zu + + a = hx*(i - 1 + 2*r); xl = hx*(i - 1 + r); xu = hx*(i + r) + b = hy*(j - 1 + 2*s); yl = hy*(j - 1 + s); yu = hy*(j + s) + c = hz*(k - 1 + 2*t); zl = hz*(k - 1 + t); zu = hz*(k + t) + + call defintg3(a,b,c,xl,xu,yl,yu,zl,zu,g) + + return + end subroutine intg3 +! +!*********************************************************************** + subroutine defintg3(a,b,c,xl,xu,yl,yu,zl,zu,g) + implicit none + double precision, intent(in) :: a,b,c + double precision, intent(in) :: xl,xu,yl,yu,zl,zu + double precision, intent(out) :: g + + double precision :: aa,ba,ca + double precision :: lll,llu,lul,ull,uul,ulu,luu,uuu + + aa=abs(a); ba=abs(b); ca=abs(c) + if (aa.lt.dtiny.and.ba.lt.dtiny.and.ca.lt.dtiny) then + call indef000(xl,yl,zl,lll) + call indef000(xl,yl,zu,llu) + call indef000(xl,yu,zl,lul) + call indef000(xl,yu,zu,luu) + call indef000(xu,yl,zl,ull) + call indef000(xu,yl,zu,ulu) + call indef000(xu,yu,zl,uul) + call indef000(xu,yu,zu,uuu) + else if (aa.lt.dtiny.and.ba.lt.dtiny) then + call indef00c(c,xl,yl,zl,lll) + call indef00c(c,xl,yl,zu,llu) + call indef00c(c,xl,yu,zl,lul) + call indef00c(c,xl,yu,zu,luu) + call indef00c(c,xu,yl,zl,ull) + call indef00c(c,xu,yl,zu,ulu) + call indef00c(c,xu,yu,zl,uul) + call indef00c(c,xu,yu,zu,uuu) + else if (aa.lt.dtiny.and.ca.lt.dtiny) then + call indef0b0(b,xl,yl,zl,lll) + call indef0b0(b,xl,yl,zu,llu) + call indef0b0(b,xl,yu,zl,lul) + call indef0b0(b,xl,yu,zu,luu) + call indef0b0(b,xu,yl,zl,ull) + call indef0b0(b,xu,yl,zu,ulu) + call indef0b0(b,xu,yu,zl,uul) + call indef0b0(b,xu,yu,zu,uuu) + else if (aa.lt.dtiny) then + call indef0bc(b,c,xl,yl,zl,lll) + call indef0bc(b,c,xl,yl,zu,llu) + call indef0bc(b,c,xl,yu,zl,lul) + call indef0bc(b,c,xl,yu,zu,luu) + call indef0bc(b,c,xu,yl,zl,ull) + call indef0bc(b,c,xu,yl,zu,ulu) + call indef0bc(b,c,xu,yu,zl,uul) + call indef0bc(b,c,xu,yu,zu,uuu) + else if (ba.lt.dtiny.and.ca.lt.dtiny) then + call indefa00(a,xl,yl,zl,lll) + call indefa00(a,xl,yl,zu,llu) + call indefa00(a,xl,yu,zl,lul) + call indefa00(a,xl,yu,zu,luu) + call indefa00(a,xu,yl,zl,ull) + call indefa00(a,xu,yl,zu,ulu) + call indefa00(a,xu,yu,zl,uul) + call indefa00(a,xu,yu,zu,uuu) + else if (ba.lt.dtiny) then + call indefa0c(a,c,xl,yl,zl,lll) + call indefa0c(a,c,xl,yl,zu,llu) + call indefa0c(a,c,xl,yu,zl,lul) + call indefa0c(a,c,xl,yu,zu,luu) + call indefa0c(a,c,xu,yl,zl,ull) + call indefa0c(a,c,xu,yl,zu,ulu) + call indefa0c(a,c,xu,yu,zl,uul) + call indefa0c(a,c,xu,yu,zu,uuu) + else if (ca.lt.dtiny) then + call indefab0(a,b,xl,yl,zl,lll) + call indefab0(a,b,xl,yl,zu,llu) + call indefab0(a,b,xl,yu,zl,lul) + call indefab0(a,b,xl,yu,zu,luu) + call indefab0(a,b,xu,yl,zl,ull) + call indefab0(a,b,xu,yl,zu,ulu) + call indefab0(a,b,xu,yu,zl,uul) + call indefab0(a,b,xu,yu,zu,uuu) + else + call indefabc(a,b,c,xl,yl,zl,lll) + call indefabc(a,b,c,xl,yl,zu,llu) + call indefabc(a,b,c,xl,yu,zl,lul) + call indefabc(a,b,c,xl,yu,zu,luu) + call indefabc(a,b,c,xu,yl,zl,ull) + call indefabc(a,b,c,xu,yl,zu,ulu) + call indefabc(a,b,c,xu,yu,zl,uul) + call indefabc(a,b,c,xu,yu,zu,uuu) + end if + g = uuu - (uul + ulu + luu) + (llu + lul + ull) - lll + + return + end subroutine defintg3 +! +!*********************************************************************** + subroutine aux23(a,b,v,r) + implicit none + double precision, intent(in) :: a,b,v + double precision, intent(out) :: r + + double precision :: d + + d = 2*v - 3*b + r = 0 + if (abs(d).gt.dtiny) r = d*atan(v*(3*v - 4*b)/(4*a*d)) + + return + end subroutine aux23 +! +!*********************************************************************** + subroutine aux34(b,c,v,w,v2,w2,vpr,r) + implicit none + double precision, intent(in) :: b,c,v,w,v2,w2,vpr + double precision, intent(out) :: r + + double precision :: d + + d = 3*w - 4*c + r = 0 + if (abs(d).gt.0.d0) r = d*log((v2+w2)*(4*vpr/(b*d*w*v2*w2))**2) + + return + end subroutine aux34 +! +!*********************************************************************** + subroutine indef000(u,v,w,g) + implicit none + double precision, intent(in) :: u,v,w + double precision, intent(out) :: g + + g = (u**2 + v**2 + w**2)**2.5d0/15.d0 + + return + end subroutine indef000 +! +!*********************************************************************** + subroutine indef00c(c,u,v,w,g) + implicit none + double precision, intent(in) :: c + double precision, intent(in) :: u,v,w + double precision, intent(out) :: g + + double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 + double precision :: u2v2 + + ua=abs(u); va=abs(v); wa=abs(w); + u2=u**2; v2=v**2; w2=w**2; + r2=u2+v2+w2; r=sqrt(r2); + upr=u+r; vpr=v+r; wpr=w+r; + + if (ua.lt.dtiny.and.va.lt.dtiny) then + g = (4*w2 - 5*c*w)*w2*wa/60.d0 + else if (va.lt.dtiny) then + g = (32*r2**2.5d0 + 5*c*(3*u2*(3*r2 + w2) - 4*r*w*(5*u2 + 2* & + & w2)) - 60*c*u2**2*log(wpr))/480.d0 + else if (wa.lt.dtiny) then + g = (32*r2**2.5d0 + 45*c*u2*(r2 + v2) - 30*c*r2**2*log(r2))/ & + & 480.d0 + else + u2v2 = u2 + v2 + g = (15*c*u2*(3*(r2 + v2) + w2) + 4*r*(8*r2**2 - 5*c*w*(2*r2 + & + & 3*u2v2)) - 60*c*u2*(u2v2 + v2)*log(wpr) - 30*c*v2**2* & + & log((v2 + w2) * ((4*wpr)/(3*c*v2**2*w2))**2))/480.d0 + end if + + return + end subroutine indef00c +! +!*********************************************************************** + subroutine indef0b0(b,u,v,w,g) + implicit none + double precision, intent(in) :: b + double precision, intent(in) :: u,v,w + double precision, intent(out) :: g + + double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 + + ua=abs(u); va=abs(v); wa=abs(w); + u2=u**2; v2=v**2; w2=w**2; + r2=u2+v2+w2; r=sqrt(r2); + upr=u+r; vpr=v+r; wpr=w+r; + + if (ua.lt.dtiny.and.wa.lt.dtiny) then + g = v2*(4*v2 - 5*b*v)*va/60.d0 + else if (va.lt.dtiny) then + g = (32*r2**2.5d0 + 15*b*u2*(r2 + w2) - 30*b*r2**2*log(r2))/ & + & 480.d0 + else if (wa.lt.dtiny) then + g = (32*r2**2.5d0 - 20*b*r*v*(5*u2 + 2*v2) + 15*b*u2**2*(1 - 4* & + & log(vpr)))/480.d0 + else + g = (4*r*(8*r2**2 - 5*b*v*(5*(u2 + w2) + 2*v2)) + 15*b*u2*(u2 + & + & 2*w2)*(1 - 4*log(vpr)) - 30*b*w2**2*log((16*(v2 + & + & w2)*vpr**2)/(9*b**2*v2**2*w2**4)))/480.d0 + end if + + return + end subroutine indef0b0 +! +!*********************************************************************** + subroutine indef0bc(b,c,u,v,w,g) + implicit none + double precision, intent(in) :: b,c + double precision, intent(in) :: u,v,w + double precision, intent(out) :: g + + double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 + double precision :: aux1,aux2 + + ua=abs(u); va=abs(v); wa=abs(w); + u2=u**2; v2=v**2; w2=w**2; + r2=u2+v2+w2; r=sqrt(r2); + upr=u+r; vpr=v+r; wpr=w+r; + + if (ua.lt.dtiny.and.va.lt.dtiny.and.wa.lt.dtiny) then + g = 0.d0 + else if (ua.lt.dtiny.and.va.lt.dtiny) then + g = w2*w*((16*w - 20*c)*wa - 15*b*(w - 4*c)*log(w2))/240.d0 + else if (ua.lt.dtiny.and.wa.lt.dtiny) then + g = v2*v*((16*v - 20*b)*va - 5*c*(3*v - 4*b)*log(v2))/240.d0 + else if (va.lt.dtiny) then + g = (15*u2*(c*(3*r2 + w2) + b*(r2 + w2 - 8*c*w)) + 4*r*(8* & + & r2**2 - 5*c*w*(5*u2 + 2*w2)) - 30*b*r2*(r2 - 4*c*w)* & + & log(r2) - 60*c*u2**2*log(wpr))/480.d0 + else if (wa.lt.dtiny) then + g = (5*u2*(b*(3*u2 - 56*c*v) + 9*c*(r2 + v2)) + 4*r*(8*r2**2 - & + & 5*b*v*(5*u2 + 2*v2)) + 160*b*c*u2*u*atan(v/u) - 10*c*(3* & + & r2**2 - 4*b*v*(r2 + 2*u2))*log(r2) - 60*b*u2**2*log(vpr))/ & + & 480.d0 + else if (ua.lt.dtiny) then + call aux34(b,c,v,w,v2,w2,vpr,aux1) + call aux34(c,b,w,v,w2,v2,wpr,aux2) + g = (2*r*(8*r2**2 + 5*(8*b*c*v*w - b*v*(5*w2 + 2*v2) - c*w*(5* & + & v2 + 2*w2))) + 40*b*c*w*w2*log(w2) - 5*b*w*w2*aux1 - 5*c* & + & v*v2*aux2)/240.d0 + else + call aux34(b,c,v,w,v2,w2,vpr,aux1) + call aux34(c,b,w,v,w2,v2,wpr,aux2) + g = (u2*(3*c*(3*(r2 + v2) + w2) + b*(3*u2 + 6*w2 - 8*c*(7*v + & + & 3*w))) + 0.8d0*r*(8*r2**2 - 5*(b*v*(2*r2 + 3*(u2 + w2)) + & + & c*w*(2*r2 + 3*(u2 + v2)) - 8*b*c*v*w)) + 32*b*c*u*u2* & + & (atan(v/u) - atan((v*w)/(u*r))) - 12*u2*(b*(u2 + 2*w*(w - & + & 2*c))*log(vpr) + c*(u2 + 2*v*(v - 2*b))*log(wpr)) + 16*b* & + & c*w*w2*log(u2 + w2) - 2*b*w*w2*aux1 - 2*c*v*v2*aux2)/96.d0 + end if + + return + end subroutine indef0bc +! +!*********************************************************************** + subroutine indefa00(a,u,v,w,g) + implicit none + double precision, intent(in) :: a + double precision, intent(in) :: u,v,w + double precision, intent(out) :: g + + double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 + double precision :: v2w2 + + ua=abs(u); va=abs(v); wa=abs(w); + u2=u**2; v2=v**2; w2=w**2; + r2=u2+v2+w2; r=sqrt(r2); + upr=u+r; vpr=v+r; wpr=w+r; + + if (ua.lt.dtiny.and.va.lt.dtiny.and.wa.lt.dtiny) then + g = 0.d0 + else if (va.lt.dtiny.and.wa.lt.dtiny) then + g = r*u2*(4*u2 - 5*a*u)/60.d0 + else + v2w2 = v2 + w2 + g = (r*(8*r2**2 - 5*a*u*(2*r2 + 3*v2w2)) - 15*a*v2w2**2* & + & log(upr))/120.d0 + end if + + return + end subroutine indefa00 +! +!*********************************************************************** + subroutine indefa0c(a,c,u,v,w,g) + implicit none + double precision, intent(in) :: a,c + double precision, intent(in) :: u,v,w + double precision, intent(out) :: g + + double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 + double precision :: u2v2,v2w2 + + ua=abs(u); va=abs(v); wa=abs(w); + u2=u**2; v2=v**2; w2=w**2; + r2=u2+v2+w2; r=sqrt(r2); + upr=u+r; vpr=v+r; wpr=w+r; + + if (ua.lt.dtiny.and.va.lt.dtiny.and.wa.lt.dtiny) then + g = 0.d0 + else if (ua.lt.dtiny.and.va.lt.dtiny) then + g = w2*w*((16*w - 20*c)*wa - 5*a*(3*w - 4*c)*log(w2))/240.d0 + else if (va.lt.dtiny.and.wa.lt.dtiny) then + g = u2*u*((96*u - 120*a)*ua + 5*c*((27*u - 40*a) - 6*(3*u - 4* & + & a)*log(u2)))/1440.d0 + else if (va.lt.dtiny) then + g = (5*c*u*(9*u*(3*r2 + w2) - 8*a*(5*u2 + 9*w2)) + & + & 12*r*(8*r2**2 + 5*(8*a*c*u*w - a*u*(2*r2 + 3*w2) - c*w*(2* & + & r2 + 3*u2))) + 60*a*w*(4*c - 3*w)*w2*log(upr) + 60*c*u*(4* & + & a - 3*u)*u2*log(wpr))/1440.d0 + else if (wa.lt.dtiny) then + g = (5*c*u*(27*u*(r2 + v2) - 8*a*(5*r2 + 16*v2)) + 12*r*(8* & + & r2**2 - 5*a*u*(2*r2 + 3*v2)) + 480*a*c*v*v2*(atan(u/v) + & + & atan((3*v)/(8*a))) - 30*c*(3*r2**2 - 4*a*u*(u2 + 3*v2))* & + & log(r2) - 180*a*v2**2*log(upr))/1440.d0 + else + u2v2 = u2 + v2 + v2w2 = v2 + w2 + g = (c*u*(9*u*(3*(r2 + v2) + w2) - 8*a*(5*r2 + 16*v2 + 4*w2)) + & + & 2.4d0*r*(8*r2**2 + 40*a*c*u*w - 5*a*u*(2*r2 + 3*v2w2) - 5* & + & c*w*(2*r2 + 3*u2v2)) + 96*a*c*v*v2*(atan(u/v) - atan((8*a* & + & u*w - 3*r*v2)/(v*(8*a*r + 3*u*w)))) - 12*a*(3*v2w2**2 - & + & 4*c*w*(3*v2 + w2))*log(upr) - 12*c*u*(3*u*(u2v2 + v2) - & + & 4*a*(u2v2 + 2*v2))*log(wpr) - 18*c*v2**2*log((v2w2/(64* & + & a**2 + 9*v2))*((4*wpr)/(c*v*v2*w2))**2))/288.d0 + end if + + return + end subroutine indefa0c +! +!*********************************************************************** + subroutine indefab0(a,b,u,v,w,g) + implicit none + double precision, intent(in) :: a,b + double precision, intent(in) :: u,v,w + double precision, intent(out) :: g + + double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 + + ua=abs(u); va=abs(v); wa=abs(w); + u2=u**2; v2=v**2; w2=w**2; + r2=u2+v2+w2; r=sqrt(r2); + upr=u+r; vpr=v+r; wpr=w+r; + + if (ua.lt.dtiny.and.va.lt.dtiny.and.wa.lt.dtiny) then + g = 0.d0 + else if (ua.lt.dtiny.and.wa.lt.dtiny) then + g = v2*v*((16*v - 20*b)*va - 5*a*(3*v - 4*b)*log(v2))/240.d0 + else if (va.lt.dtiny.and.wa.lt.dtiny) then + g = u2*u*((96*u - 120*a)*ua + 5*b*((9*u - 16*a) - 6*(3*u - 4* & + & a)*log(u2)))/1440.d0 + else if (wa.lt.dtiny) then + g = (5*b*u2*(9*u2 - 16*a*u) + 12*r*(8*r2**2 + 40*a*b*u*v - 5* & + & (a*u*(2*u2 + 5*v2) + b*v*(5*u2 + 2*v2))) + 60*(a*(4*b*v - & + & 3*v2)*v2*log(upr) + b*(4*a*u - 3*u2)*u2*log(vpr)))/1440.d0 + else if (va.lt.dtiny) then + g = (5*b*u*(9*u*(r2 + w2) - 16*a*(r2 + 5*w2)) + 12*r*(8*r2**2 - & + & 5*a*u*(2*u2 + 5*w2)) + 480*a*b*w*w2*(atan(u/w) + atan((3* & + & w)/(8*a))) - 30*b*(3*r2**2 - 4*a*u*(r2 + 2*w2))* & + & log(r2) - 180*a*w2**2*log(upr))/1440.d0 + else + g = (5*b*u*(9*u*(u2 + 2*w2) - 16*a*(u2 + 6*w2)) + 12*r*(8* & + & r2**2 + 40*a*b*u*v - 5*(a*u*(2*r2 + 3*(v2 + w2)) + b*v*(2* & + & r2 + 3*(u2 + w2)))) + 480*a*b*w*w2*(atan(u/w) - atan((8* & + & a*u*v - 3*r*w2)/((8*a*r + 3*u*v)*w))) + 60*a*(4*b*v*(v2 + & + & 3*w2) - 3*(v2 + w2)**2)*log(upr) - 60*b*u*(3*u*(u2 + 2* & + & w2) - 4*a*(u2 + 3*w2))*log(vpr) - 90*b*w2**2*log(((v2 + & + & w2)/(64*a**2 + 9*w2))*((4*vpr)/(b*w*v2*w2))**2))/1440.d0 + end if + + return + end subroutine indefab0 +! +!*********************************************************************** + subroutine indefabc(a,b,c,u,v,w,g) + implicit none + double precision, intent(in) :: a,b,c + double precision, intent(in) :: u,v,w + double precision, intent(out) :: g + + double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 + double precision :: aux1,aux2 + + ua=abs(u); va=abs(v); wa=abs(w); + u2=u**2; v2=v**2; w2=w**2; + r2=u2+v2+w2; r=sqrt(r2); + upr=u+r; vpr=v+r; wpr=w+r; + + if (ua.lt.dtiny.and.va.lt.dtiny.and.wa.lt.dtiny) then + g = 0.d0 + else if (ua.lt.dtiny.and.va.lt.dtiny) then + call aux23(a,c,w,aux2) + g = w2*(4*wa*(4*w2 - 5*c*w) + 5*(8*a*b*aux2 + w*(4*c*(a + 3* & + & b) - 3*w*(a + b))*log(w2)))/240.d0 + else if (ua.lt.dtiny.and.wa.lt.dtiny) then + call aux23(a,b,v,aux1) + g = v2*(4*va*(4*v2 - 5*b*v) + 5*(8*a*c*aux1 + (a + c)*(4*b*v - & + & 3*v2)*log(v2)))/240.d0 + else if (va.lt.dtiny.and.wa.lt.dtiny) then + g = u*u2*(24*(4*u - 5*a)*ua + 5*(9*(b + 3*c)*u - 8*a*(2*b + & + & 5*c) + 6*(b + c)*(4*a - 3*u)*log(u2)))/1440.d0 + else if (va.lt.dtiny) then + call aux23(a,c,w,aux2) + g = (12*r*(8*r2**2 + 40*a*c*u*w - 5*(a*u*(2*u2 + 5*w2) + c*w* & + & (5*u2 + 2*w2))) + 5*u*(9*u*((b + 3*c)*u2 + 2*(b + 2*c)* & + & w2) - 8*a*(2*b + 5*c)*u2 + 72*b*c*(4*a - u)*w - 24*a*(4* & + & b + 3*c)*w2) + 240*a*b*w2*((2*w - 6*c)*atan(u/w) + aux2) + & + & 30*b*(4*a*u*(u2 - 6*c*w + 3*w2) + 3*r2*(4*c*w - r2))* & + & log(r2) + 60*(a*w*(4*c - 3*w)*w2*log(upr) + c*u*(4*a - 3* & + & u)*u2*log(wpr)))/ 1440.d0 + else if (wa.lt.dtiny) then + call aux23(a,b,v,aux1) + g = (5*u*(3*u*(3*(b + 3*c)*u2 + c*(18*v2 - 56*b*v)) - 8*a*((2* & + & b + 5*c)*u2 + c*(21*v2 - 54*b*v))) + 12*r*(8*r2**2 + 40*a* & + & b*u*v - 5*(a*u*(2*u2 + 5*v2) + b*v*(5*u2 + 2*v2))) - 240* & + & c*(b*(3*a - 2*u)*u2*atan(v/u) + a*v2*((3*b - 2*v)* & + & atan(u/v) - aux1)) + 30*c*(4*(a*u*(u2 - 3*(b - v)*v) + b* & + & v*(v2 - 3*(a - u)*u)) - 3*r2**2)*log(r2) + 60*(a*v*(4*b - & + & 3*v)*v2*log(upr) + b*u*(4*a - 3*u)*u2*log(vpr)))/1440.d0 + else if (ua.lt.dtiny) then + call aux23(a,b,v,aux1) + call aux23(a,c,w,aux2) + g = (12*r*(8*r2**2 + 40*b*c*v*w - 5*(b*v*(2*v2 + 5*w2) + c*w* & + & (5*v2 + 2*w2))) + 30*a*(4*b*v*(v2 + 3*w*(w - c)) + 4*c*w* & + & (w2 + 3*v*(v - b)) - 3*r2**2)*log(r2) + 240*b*c*w*w2* & + & log(w2) + 240*a*(b*w2*aux2 + c*v2*aux1) + 30*b*w*(4*c - 3* & + & w)*w2*log((1/(16*a**2*(3*c - 2*w)**2 + (4*c - 3*w)**2* & + & w2))*((4*r*vpr)/(b*v2*w2))**2) + 30*c*v*(4*b - 3*v)*v2* & + & log((1/(16*a**2*(3*b - 2*v)**2 + (4*b - 3*v)**2*v2))*((4* & + & r*wpr)/(c*v2*w2))**2))/1440.d0 + else + g = (2.4d0*r*(8*r2**2 + 40*(a*b*u*v + a*c*u*w + b*c*v*w) - 5* & + & (a*u*(2*u2 + 5*(v2 + w2)) + b*v*(5*(u2 + w2) + 2*v2) + c*w & + & *(5*(u2 + v2) + 2*w2))) + u*(3*u*(3*(b + 3*c)*u2 + 2*c*(9* & + & v - 28*b)*v - 24*b*c*w + 6*(b + 2*c)*w2) - 8*a*(2*b*(u2 - & + & 27*c*v - 18*c*w + 6*w2) + c*(5*u2 + 21*v2 + 9*w2))) - 144* & + & a*b*c*w2*atan(u/w) - 48*b*c*(3*a - 2*u)*u2*(atan(v/u) - & + & atan((v*w)/(u*r))) - 48*a*c*(3*b - 2*v)*v2*(atan(u/v) - & + & atan((4*a*u*(3*b - 2*v)*w - (4*b - 3*v)*v2*r)/(v*(u*(4* & + & b - 3*v)*w + 4*a*(3*b - 2*v)*r)))) - 48*a*b*(3*c - 2*w)* & + & w2*(atan(u/w) - atan((4*a*u*v*(3*c - 2*w) - (4*c - 3*w)* & + & w2*r)/(w*(u*v*(4*c - 3*w) + 4*a*(3*c - 2*w)*r)))) + 12*a* & + & (4*b*v*(v2 + 3*w*(w - c)) + 4*c*w*(w2 + 3*v*(v - b)) - 3* & + & (v2 + w2)**2)*log(upr) - 12*b*u*(3*u*(u2 + 2*w*(w - 2* & + & c)) - 4*a*(u2 + 3*w*(w - 2*c)))*log(vpr) - 12*c*u*(3*u* & + & (u2 + 2*v*(v - 2*b)) - 4*a*(u2 + 3*v*(v - 2*b)))* & + & log(wpr) + 48*b*c*w*w2*log(u2 + w2) + 6*b*w*(4*c - 3*w)* & + & w2*log(((v2 + w2)/(16*a**2*(3*c - 2*w)**2 + (4*c - 3*w)** & + & 2*w2))*((4*vpr)/(b*v2*w2))**2) + 6*c*v*(4*b - 3*v)*v2* & + & log(((v2 + w2)/(16*a**2*(3*b - 2*v)**2 + (4*b - 3*v)**2* & + & v2))*((4*wpr)/(c*v2*w2))**2))/288.d0 + end if + + return + end subroutine indefabc +! +!*********************************************************************** + end module intgreenfn + diff --git a/OpticsJan2020/MLI_light_optics/Src/hamdrift.f b/OpticsJan2020/MLI_light_optics/Src/hamdrift.f new file mode 100755 index 0000000..8288222 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/hamdrift.f @@ -0,0 +1,58 @@ +c +*************************************************** +c + subroutine hamdrift(h) +c +c computes the Hamiltonian for a drift. +c MARYLIE5.0 upgrade. +c Written by M.Venturini 5 Aug 1997. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + dimension h(monoms) +c + do i=7,monoms + h(i)=0.d0 + enddo +c + ptg=-1/beta + ptg2=ptg*ptg + ptg3=ptg*ptg2 + ptg4=ptg*ptg3 + ptg5=ptg*ptg4 + ptg6=ptg*ptg5 +c + h(13)=1/2.d0 + h(22)=1/2.d0 + h(27)=(-1 + ptg2)/2.d0 + h(53)=-ptg/2.d0 + h(76)=-ptg/2.d0 + h(83)=(3*ptg - 3*ptg3)/6.d0 + h(140)=1/8.d0 + h(149)=1/4.d0 + h(154)=(-1 + 3*ptg2)/4.d0 + h(195)=1/8.d0 + h(200)=(-1 + 3*ptg2)/4.d0 + h(209)=(3 - 18*ptg2 + 15*ptg4)/24.d0 + h(340)=-3*ptg/8.d0 + h(363)=-3*ptg/4.d0 + h(370)=(9*ptg - 15*ptg3)/12.d0 + h(443)=-3*ptg/8.d0 + h(450)=(9*ptg - 15*ptg3)/12.d0 + h(461)=(-45*ptg + 150*ptg3 - 105*ptg5)/120.d0 + h(714)=1/16.d0 + h(723)=3/16.d0 + h(728)=(-9 + 45*ptg2)/48.d0 + h(769)=3/16.d0 + h(774)=(-3 + 15*ptg2)/8.d0 + h(783)=(9 - 90*ptg2 + 105*ptg4)/48.d0 + h(896)=1/16.d0 + h(901)=(-9 + 45*ptg2)/48.d0 + h(910)=(9 - 90*ptg2 + 105*ptg4)/48.d0 + h(923)=(-45 + 675*ptg2 - 1575*ptg4 + 945*ptg6)/720.d0 +c + return + end +c end of file + diff --git a/OpticsJan2020/MLI_light_optics/Src/imkmpak.f b/OpticsJan2020/MLI_light_optics/Src/imkmpak.f new file mode 100644 index 0000000..33c2ee2 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/imkmpak.f @@ -0,0 +1,1380 @@ +c******************************************************************* +c ImKmpak is a collection of portable modified Bessel function routines. +c Written 4-96 by P. L. Walstrom Northrop Grumman +c Modified from CLAMS and Numerical Recipes. Should give 12-digit +c precision for all valid arguments. +c Should use exponentially scaled functions when x is greater than 20. +c Function routines: +c dbesI0s=I0 +c dbesI0es=exponentially scaled I0 +c dbesK0s=K0 +c dbesK0es=exponentially scaled K0 +c dbesI1s=I1 +c dbesI1es=exponentially scaled I1 +c dbesK1s=K1 +c dbesK1es=exponentially scaled K1 +c Subroutines: +c +c BESSIn( M,N,x,y,KODE) +c computes a M-member sequence I_k(x), k=N, N+1, N+2 ... N+M-1. +c KODE=1 means unscaled, KODE=2 is exponentially scaled. Results in vector +c y, with y(1)=I_N, y(2)=I_N+1, etc. +c +c +c bessKn( M,N,x,y,KODE) +c computes a M-member sequence K_k(x), k=N, N+1, N+2 ... N+M-1. +c KODE=1 means unscaled, KODE=2 is exponentially scaled. Results in vector +c y, with y(1)=K_N, y(2)=K_N+1, etc. +c +c +c Exponential scaling means for the I_m +c +c I_m (x) scaled = exp(-x) * I_m (x) unscaled +c +c and for the K_m +c +c K_m (x) scaled = exp(x) * K_m (x) unscaled +c +c******************************************************************* + subroutine BESSIn(M,N,X,y,KODE) + implicit double precision(a-h,o-z) +c Calculates an M-member sequence of modified Bessel functions of the +c first kind. Needs subroutines for exponentially scaled and unscaled +c I_0(x). Sequence contains either unscaled or scaled Bessel functions. +c KODE=1 means unscaled. +c KODE=2 means scaled. +c y(k), k=1,2,..m contains I_N (x),I_N+1 (x),...I_N+M-1 (x) +c N must be > or = 0. + PARAMETER(IACC=40,BIGNO=1.0d10,BIGNI=1.0d-10) + parameter(mmax=1000) + dimension y(m),z(mmax) +C + if(m.gt.20) go to 1005 + if(dabs(x).gt.0.1d0) go to 44 + if(dabs(x).ne.0.d0) go to 23 + do 24 l=1,m + if(n.eq.0) y(1)=1.d0 + 24 y(l)=0.d0 + return + 23 continue +c Series expansion for I_n, I_n+1, ...I_n+m-1. + if(m.gt.mmax) go to 1001 + qx2=0.25d0*x**2 + hfx=0.5d0*x +c Find 1/n! and (x/2)**n. + rnfac=1.d0 + hfxn=1.d0 + if(n.gt.0) hfxn=hfx + if(n.lt.2) go to 1 + do 2 l=2,n + hfxn=hfxn*hfx + 2 rnfac=rnfac/dfloat(l) + 1 y(1)=rnfac +c find 1/ (n+l)!, l=0,1,2...m-1. +c store in z(1),z(2)...z(m) + z(1)=rnfac + if(m.lt.2) go to 6 + do 3 l=2,m + z(l)=z(l-1)/dfloat(l+n-1) + 3 y(l)=z(l) + 6 yy=1.d0 + do 5 k=1,4 + yy=yy*qx2/dfloat(k) + do 5 l=1,m + z(l)=z(l)/dfloat(l+k+n-1) + 5 y(l)=y(l)+yy*z(l) + y(1)=y(1)*hfxn + if(m.lt.2) go to 9 + yy=hfxn + do 10 l=2,m + yy=yy*hfx + 10 y(l)=y(l)*yy + 9 continue + if(kode.eq.1) return +c convert vector of I_n, I_n+1...I_n+m-1 to exponentially scaled values + zz=dexp(-dabs(x)) + do 45 l=1,m + 45 y(l)=zz*y(l) + return +c Larger x- use downwards recursion + 44 n2=n+m-1 + IF (N.LT.0) PAUSE 'bad argument N < 0 in BESSIn' + if(dabs(x).gt.dfloat(2*n2)) go to 60 + TOX=2.d0/X + BIP=0.d0 + BI=1.d0 + do 21 k=1,m + 21 y(k)=0.d0 + MAX=2*((N2+dINT(dSQRT(dFLOAT(IACC*N2))))) + DO 11 J=MAX,1,-1 + BIM=BIP+dFLOAT(J)*TOX*BI + BIP=BI + BI=BIM +c Rescale large numbers + IF (dABS(BI).GT.BIGNO) THEN + BI=BI*BIGNI + BIP=BIP*BIGNI + jmax=N2 + jmin=j+1 + if(jmin.gt.jmax) go to 22 + jdif=n2-j + if(jdif.gt.m) go to 17 + do 13 jj=jmin,jmax + k=jj-jmax+m + 13 y(k)=y(k)*bigni + go to 22 + 17 do 18 k=1,m + 18 y(k)=y(k)*bigni + 22 continue + ENDIF +c Rescale small numbers. + IF (dABS(BI).lT.BIGNI) THEN + BI=BI*BIGNO + BIP=BIP*BIGNO + jmax=N2 + jmin=j+1 + if(jmin.gt.jmax) go to 25 + jdif=n2-j + if(jdif.gt.m) go to 19 + do 16 jj=jmin,jmax + k=jj-jmax+m + 16 y(k)=y(k)*bigno + go to 25 + 19 do 20 k=1,m + 20 y(k)=y(k)*bigno + 25 continue + ENDIF + do 14 k=1,m + ncheck=k+n2-m + 14 if(j.eq.ncheck) y(k)=bip +11 CONTINUE + if(KODE.eq.1) zz=dbesi0s(x) + if(KODE.eq.2) zz=dbsi0es(x) + do 15 k=1,m + 15 y(k)=y(k)*zz/BI + if(n.eq.0) y(1)=zz + RETURN +c Very large x- use upwards recursion + 60 continue + if(kode.eq.2) bim=dbsi0es(x) + if(kode.eq.2) bi=dbsi1es(x) + if(kode.eq.1) bim=dbesi0s(x) + if(kode.eq.1) bi=dbesi1s(x) + if(n.gt.1) go to 64 + if(n.gt.0) go to 63 +c n=0 + y(1)=bim + if(m.lt.2) return + y(2)=bi + if(m.lt.3) return + lmin=3 + go to 64 + 63 y(1)=bi + if(m.lt.2) return + lmin=2 + 64 n2=n+m-1 + if(n.gt.1) lmin=1 + tox=2.d0/x + do 61 j=1,n2-1 + bip=bim-dfloat(j)*tox*bi + bim=bi + bi=bip + do 62 l=lmin,m + jj=n+l-2 + 62 if(jj.eq.j) y(l)=bi + 61 continue + return + 1001 write(5,200) m,mmax + 200 format(1x,'m=',i4,' > mmax=',i4,' in BESSIN-stopped') + stop + 1005 write(6,201) m + 201 format(1x,'m in BESSIn= ',i2,' is > 20- stopped') + stop + END + DOUBLE PRECISION FUNCTION DBSI0Es(X) +c Stripped of extraneous calls, etc. to make it portable. +C***BEGIN PROLOGUE DBSI0E +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESI0E-S DBSI0E-D),BESSEL FUNCTION, +C EXPONENTIALLY SCALED,FIRST KIND, +C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, +C ORDER ZERO,SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the d.p. exponentially scaled hyperbolic Bessel +C function of the first kind of order zero. +C***DESCRIPTION +C +C DBSI0E(X) calculates the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the first kind of order +C zero for double precision argument X. The result is the Bessel +C function I0(X) multiplied by EXP(-ABS(X)). +C +C Series for BI0 on the interval 0. to 9.00000E+00 +C with weighted error 9.51E-34 +C log weighted error 33.02 +C significant figures required 33.31 +C decimal places required 33.65 +C +C Series for AI0 on the interval 1.25000E-01 to 3.33333E-01 +C with weighted error 2.74E-32 +C log weighted error 31.56 +C significant figures required 30.15 +C decimal places required 32.39 +C +C Series for AI02 on the interval 0. to 1.25000E-01 +C with weighted error 1.97E-32 +C log weighted error 31.71 +C significant figures required 30.15 +C decimal places required 32.63 +C***REFERENCES (NONE) +C***ROUTINES CALLED DCSEVLs,INITDS +C***END PROLOGUE DBSI0E + DOUBLE PRECISION X, BI0CS(18), AI0CS(46), AI02CS(69), + 1 Y, DCSEVLs + SAVE BI0 CS, AI0 CS, AI02CS, NTI0, NTAI0, NTAI02 + DATA BI0 CS( 1) / -.7660547252 8391449510 8189497624 3285 D-1 / + DATA BI0 CS( 2) / +.1927337953 9938082699 5240875088 1196 D+1 / + DATA BI0 CS( 3) / +.2282644586 9203013389 3702929233 0415 D+0 / + DATA BI0 CS( 4) / +.1304891466 7072904280 7933421069 1888 D-1 / + DATA BI0 CS( 5) / +.4344270900 8164874513 7868268102 6107 D-3 / + DATA BI0 CS( 6) / +.9422657686 0019346639 2317174411 8766 D-5 / + DATA BI0 CS( 7) / +.1434006289 5106910799 6209187817 9957 D-6 / + DATA BI0 CS( 8) / +.1613849069 6617490699 1541971999 4611 D-8 / + DATA BI0 CS( 9) / +.1396650044 5356696994 9509270814 2522 D-10 / + DATA BI0 CS( 10) / +.9579451725 5054453446 2752317189 3333 D-13 / + DATA BI0 CS( 11) / +.5333981859 8625021310 1510774400 0000 D-15 / + DATA BI0 CS( 12) / +.2458716088 4374707746 9678591999 9999 D-17 / + DATA BI0 CS( 13) / +.9535680890 2487700269 4434133333 3333 D-20 / + DATA BI0 CS( 14) / +.3154382039 7214273367 8933333333 3333 D-22 / + DATA BI0 CS( 15) / +.9004564101 0946374314 6666666666 6666 D-25 / + DATA BI0 CS( 16) / +.2240647369 1236700160 0000000000 0000 D-27 / + DATA BI0 CS( 17) / +.4903034603 2428373333 3333333333 3333 D-30 / + DATA BI0 CS( 18) / +.9508172606 1226666666 6666666666 6666 D-33 / + DATA AI0 CS( 1) / +.7575994494 0237959427 2987203743 8 D-1 / + DATA AI0 CS( 2) / +.7591380810 8233455072 9297873320 4 D-2 / + DATA AI0 CS( 3) / +.4153131338 9237505018 6319749138 2 D-3 / + DATA AI0 CS( 4) / +.1070076463 4390730735 8242970217 0 D-4 / + DATA AI0 CS( 5) / -.7901179979 2128946607 5031948573 0 D-5 / + DATA AI0 CS( 6) / -.7826143501 4387522697 8898980690 9 D-6 / + DATA AI0 CS( 7) / +.2783849942 9488708063 8118538985 7 D-6 / + DATA AI0 CS( 8) / +.8252472600 6120271919 6682913319 8 D-8 / + DATA AI0 CS( 9) / -.1204463945 5201991790 5496089110 3 D-7 / + DATA AI0 CS( 10) / +.1559648598 5060764436 1228752792 8 D-8 / + DATA AI0 CS( 11) / +.2292556367 1033165434 7725480285 7 D-9 / + DATA AI0 CS( 12) / -.1191622884 2790646036 7777423447 8 D-9 / + DATA AI0 CS( 13) / +.1757854916 0324098302 1833124774 3 D-10 / + DATA AI0 CS( 14) / +.1128224463 2189005171 4441135682 4 D-11 / + DATA AI0 CS( 15) / -.1146848625 9272988777 2963387698 2 D-11 / + DATA AI0 CS( 16) / +.2715592054 8036628726 4365192160 6 D-12 / + DATA AI0 CS( 17) / -.2415874666 5626878384 4247572028 1 D-13 / + DATA AI0 CS( 18) / -.6084469888 2551250646 0609963922 4 D-14 / + DATA AI0 CS( 19) / +.3145705077 1754772937 0836026730 3 D-14 / + DATA AI0 CS( 20) / -.7172212924 8711877179 6217505917 6 D-15 / + DATA AI0 CS( 21) / +.7874493403 4541033960 8390960332 7 D-16 / + DATA AI0 CS( 22) / +.1004802753 0094624023 4524457183 9 D-16 / + DATA AI0 CS( 23) / -.7566895365 3505348534 2843588881 0 D-17 / + DATA AI0 CS( 24) / +.2150380106 8761198878 1205128784 5 D-17 / + DATA AI0 CS( 25) / -.3754858341 8308744291 5158445260 8 D-18 / + DATA AI0 CS( 26) / +.2354065842 2269925769 0075710532 2 D-19 / + DATA AI0 CS( 27) / +.1114667612 0479285302 2637335511 0 D-19 / + DATA AI0 CS( 28) / -.5398891884 3969903786 9677932270 9 D-20 / + DATA AI0 CS( 29) / +.1439598792 2407526770 4285840452 2 D-20 / + DATA AI0 CS( 30) / -.2591916360 1110934064 6081840196 2 D-21 / + DATA AI0 CS( 31) / +.2238133183 9985839074 3409229824 0 D-22 / + DATA AI0 CS( 32) / +.5250672575 3647711727 7221683199 9 D-23 / + DATA AI0 CS( 33) / -.3249904138 5332307841 7343228586 6 D-23 / + DATA AI0 CS( 34) / +.9924214103 2050379278 5728471040 0 D-24 / + DATA AI0 CS( 35) / -.2164992254 2446695231 4655429973 3 D-24 / + DATA AI0 CS( 36) / +.3233609471 9435940839 7333299199 9 D-25 / + DATA AI0 CS( 37) / -.1184620207 3967424898 2473386666 6 D-26 / + DATA AI0 CS( 38) / -.1281671853 9504986505 4833868799 9 D-26 / + DATA AI0 CS( 39) / +.5827015182 2793905116 0556885333 3 D-27 / + DATA AI0 CS( 40) / -.1668222326 0261097193 6450150399 9 D-27 / + DATA AI0 CS( 41) / +.3625309510 5415699757 0068480000 0 D-28 / + DATA AI0 CS( 42) / -.5733627999 0557135899 4595839999 9 D-29 / + DATA AI0 CS( 43) / +.3736796722 0630982296 4258133333 3 D-30 / + DATA AI0 CS( 44) / +.1602073983 1568519633 6551253333 3 D-30 / + DATA AI0 CS( 45) / -.8700424864 0572298845 2249599999 9 D-31 / + DATA AI0 CS( 46) / +.2741320937 9374811456 0341333333 3 D-31 / + DATA AI02CS( 1) / +.5449041101 4108831607 8960962268 0 D-1 / + DATA AI02CS( 2) / +.3369116478 2556940898 9785662979 9 D-2 / + DATA AI02CS( 3) / +.6889758346 9168239842 6263914301 1 D-4 / + DATA AI02CS( 4) / +.2891370520 8347564829 6692402323 2 D-5 / + DATA AI02CS( 5) / +.2048918589 4690637418 2760534093 1 D-6 / + DATA AI02CS( 6) / +.2266668990 4981780645 9327743136 1 D-7 / + DATA AI02CS( 7) / +.3396232025 7083863451 5084396952 3 D-8 / + DATA AI02CS( 8) / +.4940602388 2249695891 0482449783 5 D-9 / + DATA AI02CS( 9) / +.1188914710 7846438342 4084525196 3 D-10 / + DATA AI02CS( 10) / -.3149916527 9632413645 3864862961 9 D-10 / + DATA AI02CS( 11) / -.1321581184 0447713118 7540739926 7 D-10 / + DATA AI02CS( 12) / -.1794178531 5068061177 7943574026 9 D-11 / + DATA AI02CS( 13) / +.7180124451 3836662336 7106429346 9 D-12 / + DATA AI02CS( 14) / +.3852778382 7421427011 4089801777 6 D-12 / + DATA AI02CS( 15) / +.1540086217 5214098269 1325823339 7 D-13 / + DATA AI02CS( 16) / -.4150569347 2872220866 2689972015 6 D-13 / + DATA AI02CS( 17) / -.9554846698 8283076487 0214494312 5 D-14 / + DATA AI02CS( 18) / +.3811680669 3526224207 4605535511 8 D-14 / + DATA AI02CS( 19) / +.1772560133 0565263836 0493266675 8 D-14 / + DATA AI02CS( 20) / -.3425485619 6772191346 1924790328 2 D-15 / + DATA AI02CS( 21) / -.2827623980 5165834849 4205593759 4 D-15 / + DATA AI02CS( 22) / +.3461222867 6974610930 9706250813 4 D-16 / + DATA AI02CS( 23) / +.4465621420 2967599990 1042054284 3 D-16 / + DATA AI02CS( 24) / -.4830504485 9441820712 5525403795 4 D-17 / + DATA AI02CS( 25) / -.7233180487 8747539545 6227240924 5 D-17 / + DATA AI02CS( 26) / +.9921475412 1736985988 8046093981 0 D-18 / + DATA AI02CS( 27) / +.1193650890 8459820855 0439949924 2 D-17 / + DATA AI02CS( 28) / -.2488709837 1508072357 2054491660 2 D-18 / + DATA AI02CS( 29) / -.1938426454 1609059289 8469781132 6 D-18 / + DATA AI02CS( 30) / +.6444656697 3734438687 8301949394 9 D-19 / + DATA AI02CS( 31) / +.2886051596 2892243264 8171383073 4 D-19 / + DATA AI02CS( 32) / -.1601954907 1749718070 6167156200 7 D-19 / + DATA AI02CS( 33) / -.3270815010 5923147208 9193567485 9 D-20 / + DATA AI02CS( 34) / +.3686932283 8264091811 4600723939 3 D-20 / + DATA AI02CS( 35) / +.1268297648 0309501530 1359529710 9 D-22 / + DATA AI02CS( 36) / -.7549825019 3772739076 9636664410 1 D-21 / + DATA AI02CS( 37) / +.1502133571 3778353496 3712789053 4 D-21 / + DATA AI02CS( 38) / +.1265195883 5096485349 3208799248 3 D-21 / + DATA AI02CS( 39) / -.6100998370 0836807086 2940891600 2 D-22 / + DATA AI02CS( 40) / -.1268809629 2601282643 6872095924 2 D-22 / + DATA AI02CS( 41) / +.1661016099 8907414578 4038487490 5 D-22 / + DATA AI02CS( 42) / -.1585194335 7658855793 7970504881 4 D-23 / + DATA AI02CS( 43) / -.3302645405 9682178009 5381766755 6 D-23 / + DATA AI02CS( 44) / +.1313580902 8392397817 4039623117 4 D-23 / + DATA AI02CS( 45) / +.3689040246 6711567933 1425637280 4 D-24 / + DATA AI02CS( 46) / -.4210141910 4616891492 1978247249 9 D-24 / + DATA AI02CS( 47) / +.4791954591 0828657806 3171401373 0 D-25 / + DATA AI02CS( 48) / +.8459470390 2218217952 9971707412 4 D-25 / + DATA AI02CS( 49) / -.4039800940 8728324931 4607937181 0 D-25 / + DATA AI02CS( 50) / -.6434714653 6504313473 0100850469 5 D-26 / + DATA AI02CS( 51) / +.1225743398 8756659903 4464736990 5 D-25 / + DATA AI02CS( 52) / -.2934391316 0257089231 9879821175 4 D-26 / + DATA AI02CS( 53) / -.1961311309 1949829262 0371205728 9 D-26 / + DATA AI02CS( 54) / +.1503520374 8221934241 6229900309 8 D-26 / + DATA AI02CS( 55) / -.9588720515 7448265520 3386388206 9 D-28 / + DATA AI02CS( 56) / -.3483339380 8170454863 9441108511 4 D-27 / + DATA AI02CS( 57) / +.1690903610 2630436730 6244960725 6 D-27 / + DATA AI02CS( 58) / +.1982866538 7356030438 9400115718 8 D-28 / + DATA AI02CS( 59) / -.5317498081 4918162145 7583002528 4 D-28 / + DATA AI02CS( 60) / +.1803306629 8883929462 3501450390 1 D-28 / + DATA AI02CS( 61) / +.6213093341 4548931758 8405311242 2 D-29 / + DATA AI02CS( 62) / -.7692189292 7721618632 0072806673 0 D-29 / + DATA AI02CS( 63) / +.1858252826 1117025426 2556016596 3 D-29 / + DATA AI02CS( 64) / +.1237585142 2813957248 9927154554 1 D-29 / + DATA AI02CS( 65) / -.1102259120 4092238032 1779478779 2 D-29 / + DATA AI02CS( 66) / +.1886287118 0397044900 7787447943 1 D-30 / + DATA AI02CS( 67) / +.2160196872 2436589131 4903141406 0 D-30 / + DATA AI02CS( 68) / -.1605454124 9197432005 8446594965 5 D-30 / + DATA AI02CS( 69) / +.1965352984 5942906039 3884807331 8 D-31 / + DATA NTI0, NTAI0, NTAI02 / 3*0/ +C***FIRST EXECUTABLE STATEMENT DBSI0E + IF (NTI0.NE.0) GO TO 10 +c ETA = 0.1*SNGL(D1MACH(3)) +c replace above statement + eta=1.4d-18 + NTI0 = INITDSs (BI0CS, 18, ETA) + NTAI0 = INITDSs (AI0CS, 46, ETA) + NTAI02 = INITDSs (AI02CS, 69, ETA) +C + 10 Y = DABS(X) + IF (Y.GT.3.0D0) GO TO 20 +C + DBSI0Es = 1.0D0 + IF (Y.GT.1.d-15) DBSI0Es = DEXP(-Y) * (2.75D0 + + 1 DCSEVLs (Y*Y/4.5D0-1.D0, BI0CS, NTI0) ) + RETURN +C + 20 IF (Y.LE.8.D0) DBSI0Es = + & (0.375D0 + DCSEVLs ((48.D0/Y-11.D0)/5.D0, + 1 AI0CS, NTAI0))/DSQRT(Y) + IF (Y.GT.8.D0) DBSI0Es = + & (0.375D0 + DCSEVLs (16.D0/Y-1.D0, AI02CS, + 1 NTAI02))/DSQRT(Y) +C + RETURN + END + DOUBLE PRECISION FUNCTION DCSEVLs(X,A,N) +c Stripped down version - no XERROR call- stops on wrong input. +C***BEGIN PROLOGUE DCSEVLs +C***DATE WRITTEN 770401 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C3A2 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(CSEVL-S DCSEVLs-D),CHEBYSHEV, +C SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Evaluate the double precision N-term Chebyshev series A +C at X. +C***DESCRIPTION +C +C Evaluate the N-term Chebyshev series A at X. Adapted from +C R. Broucke, Algorithm 446, C.A.C.M., 16, 254 (1973). +C W. Fullerton, C-3, Los Alamos Scientific Laboratory. +C +C Input Arguments -- +C X double precision value at which the series is to be evaluated. +C A double precision array of N terms of a Chebyshev series. In +C evaluating A, only half of the first coefficient is summed. +C N number of terms in array A. +C***REFERENCES (NONE) +C***ROUTINES CALLED XERROR +C***END PROLOGUE DCSEVLs +C + DOUBLE PRECISION A(N),X,TWOX,B0,B1,B2 +C***FIRST EXECUTABLE STATEMENT DCSEVLs + IF(N.LT.1) go to 1001 + IF(N.GT.1000) go to 1002 + IF ((X.LT.-1.D0) .OR. (X.GT.1.D0)) go to 1003 +C + TWOX = 2.0D0*X + B1 = 0.D0 + B0=0.D0 + DO 10 I=1,N + B2=B1 + B1=B0 + NI = N - I + 1 + B0 = TWOX*B1 - B2 + A(NI) + 10 CONTINUE +C + DCSEVLs = 0.5D0 * (B0-B2) +C + RETURN + 1001 write(6,201) N + 201 format(1x,'N < 1 in DCSEVLs- stopped') + stop + 1002 write(6,202) N + 202 format(1x,'N>1000 in DCSEVLs- stopped') + stop + 1003 write(6,203) x + 203 format(1x,'x outside interval [-1,1] in DCSEVLs- stopped') + stop + END + FUNCTION INITDSs(DOS,NOS,ETA) +C***BEGIN PROLOGUE INITDS +C***DATE WRITTEN 770601 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C3A2 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(INITS-S INITDS-D),CHEBYSHEV, +C INITIALIZE,ORTHOGONAL POLYNOMIAL,ORTHOGONAL SERIES,SERIES, +C SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Initializes the d.p. properly normalized orthogonal +C polynomial series to determine the number of terms needed +C for specific accuracy. +C***DESCRIPTION +C +C Initialize the double precision orthogonal series DOS so that INITDS +C is the number of terms needed to insure the error is no larger than +C ETA. Ordinarily ETA will be chosen to be one-tenth machine precision +C +C Input Arguments -- +C DOS dble prec array of NOS coefficients in an orthogonal series. +C NOS number of coefficients in DOS. +C ETA requested accuracy of series. +C***REFERENCES (NONE) +C***ROUTINES CALLED XERROR +C***END PROLOGUE INITDS +C + DOUBLE PRECISION DOS(NOS) +C***FIRST EXECUTABLE STATEMENT INITDS + IF (NOS.LT.1) write(6,201) + 201 format( 'INITDS NUMBER OF COEFFICIENTS LT 1') +C + ERR = 0. + DO 10 II=1,NOS + I = NOS + 1 - II + ERR = ERR + ABS(DOS(I)) + IF (ERR.GT.ETA) GO TO 20 + 10 CONTINUE +C + 20 IF (I.EQ.NOS) write(6,200) + 200 format( 'INITDSs ETA MAY BE TOO SMALL') + INITDSs = I +C + RETURN + END + DOUBLE PRECISION FUNCTION DBSI1Es(X) +C***BEGIN PROLOGUE DBSI1E +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESI1E-S DBSI1E-D),BESSEL FUNCTION, +C EXPONENTIALLY SCALED,FIRST KIND, +C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, +C ORDER ONE,SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the d.p. exponentially scaled modified (hyper- +C bolic) Bessel function of the first kind of order one. +C***DESCRIPTION +C +C DBSI1E(X) calculates the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the first kind of order +C one for double precision argument X. The result is I1(X) +C multiplied by EXP(-ABS(X)). +C +C Series for BI1 on the interval 0. to 9.00000E+00 +C with weighted error 1.44E-32 +C log weighted error 31.84 +C significant figures required 31.45 +C decimal places required 32.46 +C +C Series for AI1 on the interval 1.25000E-01 to 3.33333E-01 +C with weighted error 2.81E-32 +C log weighted error 31.55 +C significant figures required 29.93 +C decimal places required 32.38 +C +C Series for AI12 on the interval 0. to 1.25000E-01 +C with weighted error 1.83E-32 +C log weighted error 31.74 +C significant figures required 29.97 +C decimal places required 32.66 +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DCSEVL,INITDS,XERROR +C***END PROLOGUE DBSI1E + DOUBLE PRECISION X, BI1CS(17), AI1CS(46), AI12CS(69), XMIN, + 1 XSML, Y, DCSEVLs + SAVE BI1 CS, AI1 CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML + DATA BI1 CS( 1) / -.1971713261 0998597316 1385032181 49 D-2 / + DATA BI1 CS( 2) / +.4073488766 7546480608 1553936520 14 D+0 / + DATA BI1 CS( 3) / +.3483899429 9959455866 2450377837 87 D-1 / + DATA BI1 CS( 4) / +.1545394556 3001236038 5984010584 89 D-2 / + DATA BI1 CS( 5) / +.4188852109 8377784129 4588320041 20 D-4 / + DATA BI1 CS( 6) / +.7649026764 8362114741 9597039660 69 D-6 / + DATA BI1 CS( 7) / +.1004249392 4741178689 1798080372 38 D-7 / + DATA BI1 CS( 8) / +.9932207791 9238106481 3712980548 63 D-10 / + DATA BI1 CS( 9) / +.7663801791 8447637275 2001716813 49 D-12 / + DATA BI1 CS( 10) / +.4741418923 8167394980 3880919481 60 D-14 / + DATA BI1 CS( 11) / +.2404114404 0745181799 8631720320 00 D-16 / + DATA BI1 CS( 12) / +.1017150500 7093713649 1211007999 99 D-18 / + DATA BI1 CS( 13) / +.3645093565 7866949458 4917333333 33 D-21 / + DATA BI1 CS( 14) / +.1120574950 2562039344 8106666666 66 D-23 / + DATA BI1 CS( 15) / +.2987544193 4468088832 0000000000 00 D-26 / + DATA BI1 CS( 16) / +.6973231093 9194709333 3333333333 33 D-29 / + DATA BI1 CS( 17) / +.1436794822 0620800000 0000000000 00 D-31 / + DATA AI1 CS( 1) / -.2846744181 8814786741 0037246830 7 D-1 / + DATA AI1 CS( 2) / -.1922953231 4432206510 4444877497 9 D-1 / + DATA AI1 CS( 3) / -.6115185857 9437889822 5624991778 5 D-3 / + DATA AI1 CS( 4) / -.2069971253 3502277088 8282377797 9 D-4 / + DATA AI1 CS( 5) / +.8585619145 8107255655 3694467313 8 D-5 / + DATA AI1 CS( 6) / +.1049498246 7115908625 1745399786 0 D-5 / + DATA AI1 CS( 7) / -.2918338918 4479022020 9343232669 7 D-6 / + DATA AI1 CS( 8) / -.1559378146 6317390001 6068096907 7 D-7 / + DATA AI1 CS( 9) / +.1318012367 1449447055 2530287390 9 D-7 / + DATA AI1 CS( 10) / -.1448423418 1830783176 3913446781 5 D-8 / + DATA AI1 CS( 11) / -.2908512243 9931420948 2504099301 0 D-9 / + DATA AI1 CS( 12) / +.1266388917 8753823873 1115969040 3 D-9 / + DATA AI1 CS( 13) / -.1664947772 9192206706 2417839858 0 D-10 / + DATA AI1 CS( 14) / -.1666653644 6094329760 9593715499 9 D-11 / + DATA AI1 CS( 15) / +.1242602414 2907682652 3216847201 7 D-11 / + DATA AI1 CS( 16) / -.2731549379 6724323972 5146142863 3 D-12 / + DATA AI1 CS( 17) / +.2023947881 6458037807 0026268898 1 D-13 / + DATA AI1 CS( 18) / +.7307950018 1168836361 9869812612 3 D-14 / + DATA AI1 CS( 19) / -.3332905634 4046749438 1377861713 3 D-14 / + DATA AI1 CS( 20) / +.7175346558 5129537435 4225466567 0 D-15 / + DATA AI1 CS( 21) / -.6982530324 7962563558 5062922365 6 D-16 / + DATA AI1 CS( 22) / -.1299944201 5627607600 6044608058 7 D-16 / + DATA AI1 CS( 23) / +.8120942864 2427988920 5467834286 0 D-17 / + DATA AI1 CS( 24) / -.2194016207 4107368981 5626664378 3 D-17 / + DATA AI1 CS( 25) / +.3630516170 0296548482 7986093233 4 D-18 / + DATA AI1 CS( 26) / -.1695139772 4391041663 0686679039 9 D-19 / + DATA AI1 CS( 27) / -.1288184829 8979078071 1688253822 2 D-19 / + DATA AI1 CS( 28) / +.5694428604 9670527801 0999107310 9 D-20 / + DATA AI1 CS( 29) / -.1459597009 0904800565 4550990028 7 D-20 / + DATA AI1 CS( 30) / +.2514546010 6757173140 8469133448 5 D-21 / + DATA AI1 CS( 31) / -.1844758883 1391248181 6040002901 3 D-22 / + DATA AI1 CS( 32) / -.6339760596 2279486419 2860979199 9 D-23 / + DATA AI1 CS( 33) / +.3461441102 0310111111 0814662656 0 D-23 / + DATA AI1 CS( 34) / -.1017062335 3713935475 9654102357 3 D-23 / + DATA AI1 CS( 35) / +.2149877147 0904314459 6250077866 6 D-24 / + DATA AI1 CS( 36) / -.3045252425 2386764017 4620617386 6 D-25 / + DATA AI1 CS( 37) / +.5238082144 7212859821 7763498666 6 D-27 / + DATA AI1 CS( 38) / +.1443583107 0893824464 1678950399 9 D-26 / + DATA AI1 CS( 39) / -.6121302074 8900427332 0067071999 9 D-27 / + DATA AI1 CS( 40) / +.1700011117 4678184183 4918980266 6 D-27 / + DATA AI1 CS( 41) / -.3596589107 9842441585 3521578666 6 D-28 / + DATA AI1 CS( 42) / +.5448178578 9484185766 5051306666 6 D-29 / + DATA AI1 CS( 43) / -.2731831789 6890849891 6256426666 6 D-30 / + DATA AI1 CS( 44) / -.1858905021 7086007157 7190399999 9 D-30 / + DATA AI1 CS( 45) / +.9212682974 5139334411 2776533333 3 D-31 / + DATA AI1 CS( 46) / -.2813835155 6535611063 7083306666 6 D-31 / + DATA AI12CS( 1) / +.2857623501 8280120474 4984594846 9 D-1 / + DATA AI12CS( 2) / -.9761097491 3614684077 6516445730 2 D-2 / + DATA AI12CS( 3) / -.1105889387 6262371629 1256921277 5 D-3 / + DATA AI12CS( 4) / -.3882564808 8776903934 5654477627 4 D-5 / + DATA AI12CS( 5) / -.2512236237 8702089252 9452002212 1 D-6 / + DATA AI12CS( 6) / -.2631468846 8895195068 3705236523 2 D-7 / + DATA AI12CS( 7) / -.3835380385 9642370220 4500678796 8 D-8 / + DATA AI12CS( 8) / -.5589743462 1965838068 6811252222 9 D-9 / + DATA AI12CS( 9) / -.1897495812 3505412344 9892503323 8 D-10 / + DATA AI12CS( 10) / +.3252603583 0154882385 5508067994 9 D-10 / + DATA AI12CS( 11) / +.1412580743 6613781331 6336633284 6 D-10 / + DATA AI12CS( 12) / +.2035628544 1470895072 2452613684 0 D-11 / + DATA AI12CS( 13) / -.7198551776 2459085120 9258989044 6 D-12 / + DATA AI12CS( 14) / -.4083551111 0921973182 2849963969 1 D-12 / + DATA AI12CS( 15) / -.2101541842 7726643130 1984572746 2 D-13 / + DATA AI12CS( 16) / +.4272440016 7119513542 9778833699 7 D-13 / + DATA AI12CS( 17) / +.1042027698 4128802764 1741449994 8 D-13 / + DATA AI12CS( 18) / -.3814403072 4370078047 6707253539 6 D-14 / + DATA AI12CS( 19) / -.1880354775 5107824485 1273453396 3 D-14 / + DATA AI12CS( 20) / +.3308202310 9209282827 3190335240 5 D-15 / + DATA AI12CS( 21) / +.2962628997 6459501390 6854654205 2 D-15 / + DATA AI12CS( 22) / -.3209525921 9934239587 7837353288 7 D-16 / + DATA AI12CS( 23) / -.4650305368 4893583255 7128281897 9 D-16 / + DATA AI12CS( 24) / +.4414348323 0717079499 4611375964 1 D-17 / + DATA AI12CS( 25) / +.7517296310 8421048054 2545808029 5 D-17 / + DATA AI12CS( 26) / -.9314178867 3268833756 8484784515 7 D-18 / + DATA AI12CS( 27) / -.1242193275 1948909561 1678448869 7 D-17 / + DATA AI12CS( 28) / +.2414276719 4548484690 0515390217 6 D-18 / + DATA AI12CS( 29) / +.2026944384 0532851789 7192286069 2 D-18 / + DATA AI12CS( 30) / -.6394267188 2690977870 4391988681 1 D-19 / + DATA AI12CS( 31) / -.3049812452 3730958960 8488450357 1 D-19 / + DATA AI12CS( 32) / +.1612841851 6514802251 3462230769 1 D-19 / + DATA AI12CS( 33) / +.3560913964 3099250545 1027090462 0 D-20 / + DATA AI12CS( 34) / -.3752017947 9364390796 6682800324 6 D-20 / + DATA AI12CS( 35) / -.5787037427 0747993459 5198231074 1 D-22 / + DATA AI12CS( 36) / +.7759997511 6481619619 8236963209 2 D-21 / + DATA AI12CS( 37) / -.1452790897 2022333940 6445987408 5 D-21 / + DATA AI12CS( 38) / -.1318225286 7390367021 2192275337 4 D-21 / + DATA AI12CS( 39) / +.6116654862 9030707018 7999133171 7 D-22 / + DATA AI12CS( 40) / +.1376279762 4271264277 3024338363 4 D-22 / + DATA AI12CS( 41) / -.1690837689 9593478849 1983938230 6 D-22 / + DATA AI12CS( 42) / +.1430596088 5954331539 8720108538 5 D-23 / + DATA AI12CS( 43) / +.3409557828 0905940204 0536772990 2 D-23 / + DATA AI12CS( 44) / -.1309457666 2707602278 4573872642 4 D-23 / + DATA AI12CS( 45) / -.3940706411 2402574360 9352141755 7 D-24 / + DATA AI12CS( 46) / +.4277137426 9808765808 0616679735 2 D-24 / + DATA AI12CS( 47) / -.4424634830 9826068819 0028312302 9 D-25 / + DATA AI12CS( 48) / -.8734113196 2307149721 1530978874 7 D-25 / + DATA AI12CS( 49) / +.4045401335 6835333921 4340414242 8 D-25 / + DATA AI12CS( 50) / +.7067100658 0946894656 5160771780 6 D-26 / + DATA AI12CS( 51) / -.1249463344 5651052230 0286451860 5 D-25 / + DATA AI12CS( 52) / +.2867392244 4034370329 7948339142 6 D-26 / + DATA AI12CS( 53) / +.2044292892 5042926702 8177957421 0 D-26 / + DATA AI12CS( 54) / -.1518636633 8204625683 7134680291 1 D-26 / + DATA AI12CS( 55) / +.8110181098 1875758861 3227910703 7 D-28 / + DATA AI12CS( 56) / +.3580379354 7735860911 2717370327 0 D-27 / + DATA AI12CS( 57) / -.1692929018 9279025095 9305717544 8 D-27 / + DATA AI12CS( 58) / -.2222902499 7024276390 6775852777 4 D-28 / + DATA AI12CS( 59) / +.5424535127 1459696550 4860040112 8 D-28 / + DATA AI12CS( 60) / -.1787068401 5780186887 6491299330 4 D-28 / + DATA AI12CS( 61) / -.6565479068 7228149388 2392943788 0 D-29 / + DATA AI12CS( 62) / +.7807013165 0611452809 2206770683 9 D-29 / + DATA AI12CS( 63) / -.1816595260 6689797173 7933315222 1 D-29 / + DATA AI12CS( 64) / -.1287704952 6600848203 7687559895 9 D-29 / + DATA AI12CS( 65) / +.1114548172 9881645474 1370927369 4 D-29 / + DATA AI12CS( 66) / -.1808343145 0393369391 5936887668 7 D-30 / + DATA AI12CS( 67) / -.2231677718 2037719522 3244822893 9 D-30 / + DATA AI12CS( 68) / +.1619029596 0803415106 1790980361 4 D-30 / + DATA AI12CS( 69) / -.1834079908 8049414139 0130843921 0 D-31 / + DATA NTI1, NTAI1, NTAI12, XMIN, XSML / 3*0, 2*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBSI1Es + IF (NTI1.NE.0) GO TO 10 +c type *,'D1mach(3)',d1mach(3) + eta=1.4e-18 +c ETA = 0.1*SNGL(D1MACH(3)) +c type *,'eta',eta + NTI1 = INITDSs (BI1CS, 17, ETA) + NTAI1 = INITDSs (AI1CS, 46, ETA) + NTAI12 = INITDSs (AI12CS, 69, ETA) +C + XMIN = 4.d-39 +c type *,'D1mach(1)',d1mach(1) + XSML = 1.d-8 +C + 10 Y = DABS(X) + IF (Y.GT.3.0D0) GO TO 20 +C + DBSI1Es = 0.0D0 + IF (Y.EQ.0.D0) RETURN +C + IF (Y.LT.XMIN) write(6,301) + 301 format(1x,'DBSI1Es DABS(X) SO SMALL I1 UNDERFLOWS') + IF (Y.GT.XMIN) DBSI1Es = 0.5D0*X + IF (Y.GT.XSML) DBSI1Es = + & X*(0.875D0 + DCSEVLs (Y*Y/4.5D0-1.D0, + 1 BI1CS, NTI1) ) + DBSI1Es = DEXP(-Y) * DBSI1Es + RETURN +C + 20 IF (Y.LE.8.D0) DBSI1Es = + & (0.375D0 + DCSEVLs ((48.D0/Y-11.D0)/5.D0, + 1 AI1CS, NTAI1))/DSQRT(Y) + IF (Y.GT.8.D0) DBSI1Es = + & (0.375D0 + DCSEVLs (16.D0/Y-1.D0, AI12CS, + 1 NTAI12))/DSQRT(Y) + DBSI1Es = DSIGN (DBSI1Es, X) +C + RETURN + END + DOUBLE PRECISION FUNCTION DBESI1s(X) +C***BEGIN PROLOGUE DBESI1 +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESI1-S DBESI1-D),BESSEL FUNCTION, +C FIRST KIND,HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION,ORDER ONE,SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the d.p. modified (hyperbolic) Bessel function +C of the first kind of order one. +C***DESCRIPTION +C +C DBESI1(X) calculates the double precision modified (hyperbolic) +C Bessel function of the first kind of order one and double precision +C argument X. +C +C Series for BI1 on the interval 0. to 9.00000E+00 +C with weighted error 1.44E-32 +C log weighted error 31.84 +C significant figures required 31.45 +C decimal places required 32.46 +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DBSI1E,DCSEVL,INITDS,XERROR +C***END PROLOGUE DBESI1 + DOUBLE PRECISION X, BI1CS(17), XMAX, XMIN, XSML, Y, + 1 DCSEVLs, DBSI1Es + SAVE BI1 CS, NTI1, XMIN, XSML, XMAX + DATA BI1 CS( 1) / -.1971713261 0998597316 1385032181 49 D-2 / + DATA BI1 CS( 2) / +.4073488766 7546480608 1553936520 14 D+0 / + DATA BI1 CS( 3) / +.3483899429 9959455866 2450377837 87 D-1 / + DATA BI1 CS( 4) / +.1545394556 3001236038 5984010584 89 D-2 / + DATA BI1 CS( 5) / +.4188852109 8377784129 4588320041 20 D-4 / + DATA BI1 CS( 6) / +.7649026764 8362114741 9597039660 69 D-6 / + DATA BI1 CS( 7) / +.1004249392 4741178689 1798080372 38 D-7 / + DATA BI1 CS( 8) / +.9932207791 9238106481 3712980548 63 D-10 / + DATA BI1 CS( 9) / +.7663801791 8447637275 2001716813 49 D-12 / + DATA BI1 CS( 10) / +.4741418923 8167394980 3880919481 60 D-14 / + DATA BI1 CS( 11) / +.2404114404 0745181799 8631720320 00 D-16 / + DATA BI1 CS( 12) / +.1017150500 7093713649 1211007999 99 D-18 / + DATA BI1 CS( 13) / +.3645093565 7866949458 4917333333 33 D-21 / + DATA BI1 CS( 14) / +.1120574950 2562039344 8106666666 66 D-23 / + DATA BI1 CS( 15) / +.2987544193 4468088832 0000000000 00 D-26 / + DATA BI1 CS( 16) / +.6973231093 9194709333 3333333333 33 D-29 / + DATA BI1 CS( 17) / +.1436794822 0620800000 0000000000 00 D-31 / + DATA NTI1, XMIN, XSML, XMAX / 0, 3*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBESI1 + IF (NTI1.NE.0) GO TO 10 + eta=1.4d-18 + NTI1 = INITDSs (BI1CS, 17, eta) + XMIN = 4.0d-39 + XSML = 1.d-8 + XMAX = 86.d0 +C + 10 Y = DABS(X) + IF (Y.GT.3.0D0) GO TO 20 +C + DBESI1s = 0.D0 + IF (Y.EQ.0.D0) RETURN +C + IF (Y.LT.XMIN) + & write(6,*) 'DBESI1s DABS(X) SO SMALL IT UNDERFLOWS' + IF (Y.GT.XMIN) DBESI1s = 0.5D0*X + IF (Y.GT.XSML) DBESI1s = X*(0.875D0 + + & DCSEVLs (Y*Y/4.5D0-1.D0, + 1 BI1CS, NTI1)) + RETURN +C + 20 IF (Y.GT.XMAX) write(6,*)'DBESI1s DABS(X) SO BIG I1 OVERFLOWS' +C + DBESI1s = DEXP(Y) * DBSI1Es(X) +C + RETURN + END + DOUBLE PRECISION FUNCTION DBESI0s(X) +c Stripped version of CLAMS DBESI0 - no machine-dependent calls. +C***BEGIN PROLOGUE DBESI0 +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESI0-S DBESI0-D),BESSEL FUNCTION, +C FIRST KIND,HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION,ORDER ZERO,SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the d.p. hyperbolic Bessel function of the first +C kind of order zero. +C***DESCRIPTION +C +C DBESI0(X) calculates the double precision modified (hyperbolic) +C Bessel function of the first kind of order zero and double +C precision argument X. +C +C Series for BI0 on the interval 0. to 9.00000E+00 +C with weighted error 9.51E-34 +C log weighted error 33.02 +C significant figures required 33.31 +C decimal places required 33.65 +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DBSI0E,DCSEVL,INITDS,XERROR +C***END PROLOGUE DBESI0 + DOUBLE PRECISION X, BI0CS(18), XMAX, XSML, Y, + 1 DCSEVLs, DBSI0Es + SAVE BI0 CS, NTI0, XSML, XMAX + DATA BI0 CS( 1) / -.7660547252 8391449510 8189497624 3285 D-1 / + DATA BI0 CS( 2) / +.1927337953 9938082699 5240875088 1196 D+1 / + DATA BI0 CS( 3) / +.2282644586 9203013389 3702929233 0415 D+0 / + DATA BI0 CS( 4) / +.1304891466 7072904280 7933421069 1888 D-1 / + DATA BI0 CS( 5) / +.4344270900 8164874513 7868268102 6107 D-3 / + DATA BI0 CS( 6) / +.9422657686 0019346639 2317174411 8766 D-5 / + DATA BI0 CS( 7) / +.1434006289 5106910799 6209187817 9957 D-6 / + DATA BI0 CS( 8) / +.1613849069 6617490699 1541971999 4611 D-8 / + DATA BI0 CS( 9) / +.1396650044 5356696994 9509270814 2522 D-10 / + DATA BI0 CS( 10) / +.9579451725 5054453446 2752317189 3333 D-13 / + DATA BI0 CS( 11) / +.5333981859 8625021310 1510774400 0000 D-15 / + DATA BI0 CS( 12) / +.2458716088 4374707746 9678591999 9999 D-17 / + DATA BI0 CS( 13) / +.9535680890 2487700269 4434133333 3333 D-20 / + DATA BI0 CS( 14) / +.3154382039 7214273367 8933333333 3333 D-22 / + DATA BI0 CS( 15) / +.9004564101 0946374314 6666666666 6666 D-25 / + DATA BI0 CS( 16) / +.2240647369 1236700160 0000000000 0000 D-27 / + DATA BI0 CS( 17) / +.4903034603 2428373333 3333333333 3333 D-30 / + DATA BI0 CS( 18) / +.9508172606 1226666666 6666666666 6666 D-33 / + DATA NTI0, XSML, XMAX / 0, 2*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBESI0 + IF (NTI0.NE.0) GO TO 10 + NTI0 = INITDSs(BI0CS, 18, 1.4e-18) +c XSML = DSQRT (8.0D0*D1MACH(3)) + xsml=7.5d-9 +c XMAX = DLOG (D1MACH(2)) + xmax=86.4d0 +C + 10 Y = DABS(X) + IF (Y.GT.3.0D0) GO TO 20 +C + DBESI0s= 1.0D0 + IF (Y.GT.XSML) DBESI0s= 2.75D0 + DCSEVLs(Y*Y/4.5D0-1.D0, BI0CS, + 1 NTI0) + RETURN +C + 20 IF (Y.GT.XMAX) go to 1001 +C + DBESI0s= DEXP(Y) * DBSI0Es(X) +C + RETURN + 1001 write(6,*) 'X>XMAX in DBESI0s-stopped:XMAX=86.4,x=',x + stop + END + DOUBLE PRECISION FUNCTION DBESK0s(X) +c Stripped of machine-dependent calls . +C***BEGIN PROLOGUE DBESK0s +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESK0-S DBESK0s-D),BESSEL FUNCTION, +C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, +C ORDER ZERO,SPECIAL FUNCTIONS,THIRD KIND +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes d.p. modified (hyperbolic) Bessel function of +C the third kind of order zero. +C***DESCRIPTION +C +C DBESK0s(X) calculates the double precision modified (hyperbolic) +C Bessel function of the third kind of order zero for double +C precision argument X. The argument must be greater than zero +C but not so large that the result underflows. +C +C Series for BK0 on the interval 0. to 4.00000E+00 +C with weighted error 3.08E-33 +C log weighted error 32.51 +C significant figures required 32.05 +C decimal places required 33.11 +C***REFERENCES (NONE) +C***ROUTINES CALLED DBESI0,DBSK0E,DCSEVL,INITDS +C***END PROLOGUE DBESK0s + DOUBLE PRECISION X, BK0CS(16), XMAX, XSML, Y, + 1 DCSEVLs, DBESI0s, DBSK0Es + SAVE BK0 CS, NTK0, XSML, XMAX + DATA BK0 CS( 1) / -.3532739323 3902768720 1140060063 153 D-1 / + DATA BK0 CS( 2) / +.3442898999 2462848688 6344927529 213 D+0 / + DATA BK0 CS( 3) / +.3597993651 5361501626 5721303687 231 D-1 / + DATA BK0 CS( 4) / +.1264615411 4469259233 8479508673 447 D-2 / + DATA BK0 CS( 5) / +.2286212103 1194517860 8269830297 585 D-4 / + DATA BK0 CS( 6) / +.2534791079 0261494573 0790013428 354 D-6 / + DATA BK0 CS( 7) / +.1904516377 2202088589 7214059381 366 D-8 / + DATA BK0 CS( 8) / +.1034969525 7633624585 1008317853 089 D-10 / + DATA BK0 CS( 9) / +.4259816142 7910825765 2445327170 133 D-13 / + DATA BK0 CS( 10) / +.1374465435 8807508969 4238325440 000 D-15 / + DATA BK0 CS( 11) / +.3570896528 5083735909 9688597333 333 D-18 / + DATA BK0 CS( 12) / +.7631643660 1164373766 7498666666 666 D-21 / + DATA BK0 CS( 13) / +.1365424988 4407818590 8053333333 333 D-23 / + DATA BK0 CS( 14) / +.2075275266 9066680831 9999999999 999 D-26 / + DATA BK0 CS( 15) / +.2712814218 0729856000 0000000000 000 D-29 / + DATA BK0 CS( 16) / +.3082593887 9146666666 6666666666 666 D-32 / + DATA NTK0, XSML, XMAX / 0, 2*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBESK0s + IF (NTK0.NE.0) GO TO 10 + NTK0 = INITDSs(BK0CS, 16, 1.4e-18) + XSML = 7.5d-9 + XMAX = 86.4 +C + 10 if(x.le.0.d0) go to 1001 + IF (X.GT.2.0D0) GO TO 20 +C + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBESK0s = -DLOG(0.5D0*X)*DBESI0s(X) + & - 0.25D0 + DCSEVLs(.5D0*Y-1.D0, + 1 BK0CS, NTK0) + RETURN +C + 20 DBESK0s = 0.D0 + IF (X.GT.XMAX) write(6,*)'DBESK0s X SO BIG K0 UNDERFLOWS' + IF (X.GT.XMAX) RETURN +C + DBESK0s = DEXP(-X) * DBSK0Es(X) +C + RETURN + 1001 write(6,*) 'DBESK0s X IS ZERO OR NEGATIVE- stopped' + stop + END + DOUBLE PRECISION FUNCTION DBSK0Es(X) +c Stripped of machine-dependent calls. +C***BEGIN PROLOGUE DBSK0Es +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESK0E-S DBSK0Es-D),BESSEL FUNCTION, +C EXPONENTIALLY SCALED,HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION,ORDER ZERO,SPECIAL FUNCTIONS, +C THIRD KIND +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the d.p. exponentially scaled modified (hyper- +C bolic) Bessel function of the third kind of order zero. +C***DESCRIPTION +C +C DBSK0Es(X) computes the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the third kind of +C order zero for positive double precision argument X. +C +C Series for BK0 on the interval 0. to 4.00000E+00 +C with weighted error 3.08E-33 +C log weighted error 32.51 +C significant figures required 32.05 +C decimal places required 33.11 +C +C Series for AK0 on the interval 1.25000E-01 to 5.00000E-01 +C with weighted error 2.85E-32 +C log weighted error 31.54 +C significant figures required 30.19 +C decimal places required 32.33 +C +C Series for AK02 on the interval 0. to 1.25000E-01 +C with weighted error 2.30E-32 +C log weighted error 31.64 +C significant figures required 29.68 +C decimal places required 32.40 +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DBESI0,DCSEVL,INITDSs,XERROR +C***END PROLOGUE DBSK0Es + DOUBLE PRECISION X, BK0CS(16), AK0CS(38), AK02CS(33), + 1 XSML, Y, DCSEVLs,DBESI0s + SAVE BK0 CS, AK0 CS, AK02CS,NTK0, NTAK0, NTAK02, XSML + DATA BK0 CS( 1) / -.3532739323 3902768720 1140060063 153 D-1 / + DATA BK0 CS( 2) / +.3442898999 2462848688 6344927529 213 D+0 / + DATA BK0 CS( 3) / +.3597993651 5361501626 5721303687 231 D-1 / + DATA BK0 CS( 4) / +.1264615411 4469259233 8479508673 447 D-2 / + DATA BK0 CS( 5) / +.2286212103 1194517860 8269830297 585 D-4 / + DATA BK0 CS( 6) / +.2534791079 0261494573 0790013428 354 D-6 / + DATA BK0 CS( 7) / +.1904516377 2202088589 7214059381 366 D-8 / + DATA BK0 CS( 8) / +.1034969525 7633624585 1008317853 089 D-10 / + DATA BK0 CS( 9) / +.4259816142 7910825765 2445327170 133 D-13 / + DATA BK0 CS( 10) / +.1374465435 8807508969 4238325440 000 D-15 / + DATA BK0 CS( 11) / +.3570896528 5083735909 9688597333 333 D-18 / + DATA BK0 CS( 12) / +.7631643660 1164373766 7498666666 666 D-21 / + DATA BK0 CS( 13) / +.1365424988 4407818590 8053333333 333 D-23 / + DATA BK0 CS( 14) / +.2075275266 9066680831 9999999999 999 D-26 / + DATA BK0 CS( 15) / +.2712814218 0729856000 0000000000 000 D-29 / + DATA BK0 CS( 16) / +.3082593887 9146666666 6666666666 666 D-32 / + DATA AK0 CS( 1) / -.7643947903 3279414240 8297827008 8 D-1 / + DATA AK0 CS( 2) / -.2235652605 6998190520 2309555079 1 D-1 / + DATA AK0 CS( 3) / +.7734181154 6938582353 0061817404 7 D-3 / + DATA AK0 CS( 4) / -.4281006688 8860994644 5214643541 6 D-4 / + DATA AK0 CS( 5) / +.3081700173 8629747436 5001482666 0 D-5 / + DATA AK0 CS( 6) / -.2639367222 0096649740 6744889272 3 D-6 / + DATA AK0 CS( 7) / +.2563713036 4034692062 9408826574 2 D-7 / + DATA AK0 CS( 8) / -.2742705549 9002012638 5721191524 4 D-8 / + DATA AK0 CS( 9) / +.3169429658 0974995920 8083287340 3 D-9 / + DATA AK0 CS( 10) / -.3902353286 9621841416 0106571796 2 D-10 / + DATA AK0 CS( 11) / +.5068040698 1885754020 5009212728 6 D-11 / + DATA AK0 CS( 12) / -.6889574741 0078706795 4171355798 4 D-12 / + DATA AK0 CS( 13) / +.9744978497 8259176913 8820133683 1 D-13 / + DATA AK0 CS( 14) / -.1427332841 8845485053 8985534012 2 D-13 / + DATA AK0 CS( 15) / +.2156412571 0214630395 5806297652 7 D-14 / + DATA AK0 CS( 16) / -.3349654255 1495627721 8878205853 0 D-15 / + DATA AK0 CS( 17) / +.5335260216 9529116921 4528039260 1 D-16 / + DATA AK0 CS( 18) / -.8693669980 8907538076 3962237883 7 D-17 / + DATA AK0 CS( 19) / +.1446404347 8622122278 8776344234 6 D-17 / + DATA AK0 CS( 20) / -.2452889825 5001296824 0467875157 3 D-18 / + DATA AK0 CS( 21) / +.4233754526 2321715728 2170634240 0 D-19 / + DATA AK0 CS( 22) / -.7427946526 4544641956 9534129493 3 D-20 / + DATA AK0 CS( 23) / +.1323150529 3926668662 7796746240 0 D-20 / + DATA AK0 CS( 24) / -.2390587164 7396494513 3598146559 9 D-21 / + DATA AK0 CS( 25) / +.4376827585 9232261401 6571255466 6 D-22 / + DATA AK0 CS( 26) / -.8113700607 3451180593 3901141333 3 D-23 / + DATA AK0 CS( 27) / +.1521819913 8321729583 1037815466 6 D-23 / + DATA AK0 CS( 28) / -.2886041941 4833977702 3595861333 3 D-24 / + DATA AK0 CS( 29) / +.5530620667 0547179799 9261013333 3 D-25 / + DATA AK0 CS( 30) / -.1070377329 2498987285 9163306666 6 D-25 / + DATA AK0 CS( 31) / +.2091086893 1423843002 9632853333 3 D-26 / + DATA AK0 CS( 32) / -.4121713723 6462038274 1026133333 3 D-27 / + DATA AK0 CS( 33) / +.8193483971 1213076401 3568000000 0 D-28 / + DATA AK0 CS( 34) / -.1642000275 4592977267 8075733333 3 D-28 / + DATA AK0 CS( 35) / +.3316143281 4802271958 9034666666 6 D-29 / + DATA AK0 CS( 36) / -.6746863644 1452959410 8586666666 6 D-30 / + DATA AK0 CS( 37) / +.1382429146 3184246776 3541333333 3 D-30 / + DATA AK0 CS( 38) / -.2851874167 3598325708 1173333333 3 D-31 / + DATA AK02CS( 1) / -.1201869826 3075922398 3934621245 2 D-1 / + DATA AK02CS( 2) / -.9174852691 0256953106 5256107571 3 D-2 / + DATA AK02CS( 3) / +.1444550931 7750058210 4884387805 7 D-3 / + DATA AK02CS( 4) / -.4013614175 4357097286 7102107787 9 D-5 / + DATA AK02CS( 5) / +.1567831810 8523106725 9034899033 3 D-6 / + DATA AK02CS( 6) / -.7770110438 5217377103 1579975446 0 D-8 / + DATA AK02CS( 7) / +.4611182576 1797178825 3313052958 6 D-9 / + DATA AK02CS( 8) / -.3158592997 8605657705 2666580330 9 D-10 / + DATA AK02CS( 9) / +.2435018039 3650411278 3588781432 9 D-11 / + DATA AK02CS( 10) / -.2074331387 3983478977 0985337350 6 D-12 / + DATA AK02CS( 11) / +.1925787280 5899170847 4273650469 3 D-13 / + DATA AK02CS( 12) / -.1927554805 8389561036 0034718221 8 D-14 / + DATA AK02CS( 13) / +.2062198029 1978182782 8523786964 4 D-15 / + DATA AK02CS( 14) / -.2341685117 5792424026 0364019507 1 D-16 / + DATA AK02CS( 15) / +.2805902810 6430422468 1517882845 8 D-17 / + DATA AK02CS( 16) / -.3530507631 1618079458 1548246357 3 D-18 / + DATA AK02CS( 17) / +.4645295422 9351082674 2421633706 6 D-19 / + DATA AK02CS( 18) / -.6368625941 3442664739 2205346133 3 D-20 / + DATA AK02CS( 19) / +.9069521310 9865155676 2234880000 0 D-21 / + DATA AK02CS( 20) / -.1337974785 4236907398 4500531199 9 D-21 / + DATA AK02CS( 21) / +.2039836021 8599523155 2208896000 0 D-22 / + DATA AK02CS( 22) / -.3207027481 3678405000 6086997333 3 D-23 / + DATA AK02CS( 23) / +.5189744413 6623099636 2635946666 6 D-24 / + DATA AK02CS( 24) / -.8629501497 5405721929 6460799999 9 D-25 / + DATA AK02CS( 25) / +.1472161183 1025598552 0803840000 0 D-25 / + DATA AK02CS( 26) / -.2573069023 8670112838 1235199999 9 D-26 / + DATA AK02CS( 27) / +.4601774086 6435165873 7664000000 0 D-27 / + DATA AK02CS( 28) / -.8411555324 2010937371 3066666666 6 D-28 / + DATA AK02CS( 29) / +.1569806306 6353689393 0154666666 6 D-28 / + DATA AK02CS( 30) / -.2988226453 0057577889 7919999999 9 D-29 / + DATA AK02CS( 31) / +.5796831375 2168365206 1866666666 6 D-30 / + DATA AK02CS( 32) / -.1145035994 3476813321 5573333333 3 D-30 / + DATA AK02CS( 33) / +.2301266594 2496828020 0533333333 3 D-31 / + DATA NTK0, NTAK0, NTAK02, XSML / 3*0, 0.0D0 / +C***FIRST EXECUTABLE STATEMENT DBSK0Es + IF (NTK0.NE.0) GO TO 10 +c type *,d1mach(3) + ETA = 1.d-18 + NTK0 = INITDSs (BK0CS, 16, ETA) + NTAK0 = INITDSs (AK0CS, 38, ETA) + NTAK02 = INITDSs (AK02CS, 33, ETA) + XSML = 1.d-9 +c type *,xsml +C + 10 IF (X.LE.0.D0) write(6,*)'DBSK0Es X IS ZERO OR NEGATIVE' + IF (X.GT.2.0D0) GO TO 20 +C + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBSK0Es = + & DEXP(X)*(-DLOG(0.5D0*X)*DBESI0s(X) - 0.25D0 + + 1 DCSEVLs (.5D0*Y-1.D0, BK0CS, NTK0)) + RETURN +C + 20 IF (X.LE.8.D0) DBSK0Es = + & (1.25D0 + DCSEVLs ((16.D0/X-5.D0)/3.D0, + 1 AK0CS, NTAK0))/DSQRT(X) + IF (X.GT.8.D0) DBSK0Es = (1.25D0 + + 1 DCSEVLs (16.D0/X-1.D0, AK02CS, NTAK02))/DSQRT(X) +C + RETURN + END + DOUBLE PRECISION FUNCTION DBSK1Es(X) +c Stripped of machine-dependent calls- same as CLAMS DBSK1E +C***BEGIN PROLOGUE DBSK1E +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESK1E-S DBSK1E-D),BESSEL FUNCTION, +C EXPONENTIALLY SCALED,HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION,ORDER ONE,SPECIAL FUNCTIONS, +C THIRD KIND +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the exponentially scaled,modified (hyperbolic) +C Bessel function of the third kind of order one (double +C precision). +C***DESCRIPTION +C +C DBSK1E(S) computes the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the third kind of order +C one for positive double precision argument X. +C +C Series for BK1 on the interval 0. to 4.00000E+00 +C with weighted error 9.16E-32 +C log weighted error 31.04 +C significant figures required 30.61 +C decimal places required 31.64 +C +C Series for AK1 on the interval 1.25000E-01 to 5.00000E-01 +C with weighted error 3.07E-32 +C log weighted error 31.51 +C significant figures required 30.71 +C decimal places required 32.30 +C +C Series for AK12 on the interval 0. to 1.25000E-01 +C with weighted error 2.41E-32 +C log weighted error 31.62 +C significant figures required 30.25 +C decimal places required 32.38 +C***REFERENCES (NONE) +C***ROUTINES CALLED DBESI1,DCSEVLs,INITDS +C***END PROLOGUE DBSK1E + DOUBLE PRECISION X, BK1CS(16), AK1CS(38), AK12CS(33), XMIN, + 1 XSML, Y, DCSEVLs, DBESI1s + SAVE BK1 CS, AK1 CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML + DATA BK1 CS( 1) / +.2530022733 8947770532 5311208685 33 D-1 / + DATA BK1 CS( 2) / -.3531559607 7654487566 7238316918 01 D+0 / + DATA BK1 CS( 3) / -.1226111808 2265714823 4790679300 42 D+0 / + DATA BK1 CS( 4) / -.6975723859 6398643501 8129202960 83 D-2 / + DATA BK1 CS( 5) / -.1730288957 5130520630 1765073689 79 D-3 / + DATA BK1 CS( 6) / -.2433406141 5659682349 6007350301 64 D-5 / + DATA BK1 CS( 7) / -.2213387630 7347258558 3152525451 26 D-7 / + DATA BK1 CS( 8) / -.1411488392 6335277610 9583302126 08 D-9 / + DATA BK1 CS( 9) / -.6666901694 1993290060 8537512643 73 D-12 / + DATA BK1 CS( 10) / -.2427449850 5193659339 2631968648 53 D-14 / + DATA BK1 CS( 11) / -.7023863479 3862875971 7837971200 00 D-17 / + DATA BK1 CS( 12) / -.1654327515 5100994675 4910293333 33 D-19 / + DATA BK1 CS( 13) / -.3233834745 9944491991 8933333333 33 D-22 / + DATA BK1 CS( 14) / -.5331275052 9265274999 4666666666 66 D-25 / + DATA BK1 CS( 15) / -.7513040716 2157226666 6666666666 66 D-28 / + DATA BK1 CS( 16) / -.9155085717 6541866666 6666666666 66 D-31 / + DATA AK1 CS( 1) / +.2744313406 9738829695 2576662272 66 D+0 / + DATA AK1 CS( 2) / +.7571989953 1993678170 8923781492 90 D-1 / + DATA AK1 CS( 3) / -.1441051556 4754061229 8531161756 25 D-2 / + DATA AK1 CS( 4) / +.6650116955 1257479394 2513854770 36 D-4 / + DATA AK1 CS( 5) / -.4369984709 5201407660 5808450891 67 D-5 / + DATA AK1 CS( 6) / +.3540277499 7630526799 4171390085 34 D-6 / + DATA AK1 CS( 7) / -.3311163779 2932920208 9826882457 04 D-7 / + DATA AK1 CS( 8) / +.3445977581 9010534532 3114997709 92 D-8 / + DATA AK1 CS( 9) / -.3898932347 4754271048 9819374927 58 D-9 / + DATA AK1 CS( 10) / +.4720819750 4658356400 9474493390 05 D-10 / + DATA AK1 CS( 11) / -.6047835662 8753562345 3735915628 90 D-11 / + DATA AK1 CS( 12) / +.8128494874 8658747888 1938379856 63 D-12 / + DATA AK1 CS( 13) / -.1138694574 7147891428 9239159510 42 D-12 / + DATA AK1 CS( 14) / +.1654035840 8462282325 9729482050 90 D-13 / + DATA AK1 CS( 15) / -.2480902567 7068848221 5160104405 33 D-14 / + DATA AK1 CS( 16) / +.3829237890 7024096948 4292272991 57 D-15 / + DATA AK1 CS( 17) / -.6064734104 0012418187 7682103773 86 D-16 / + DATA AK1 CS( 18) / +.9832425623 2648616038 1940046506 66 D-17 / + DATA AK1 CS( 19) / -.1628416873 8284380035 6666201156 26 D-17 / + DATA AK1 CS( 20) / +.2750153649 6752623718 2841203370 66 D-18 / + DATA AK1 CS( 21) / -.4728966646 3953250924 2810695680 00 D-19 / + DATA AK1 CS( 22) / +.8268150002 8109932722 3920503466 66 D-20 / + DATA AK1 CS( 23) / -.1468140513 6624956337 1939648853 33 D-20 / + DATA AK1 CS( 24) / +.2644763926 9208245978 0858948266 66 D-21 / + DATA AK1 CS( 25) / -.4829015756 4856387897 9698688000 00 D-22 / + DATA AK1 CS( 26) / +.8929302074 3610130180 6563327999 99 D-23 / + DATA AK1 CS( 27) / -.1670839716 8972517176 9977514666 66 D-23 / + DATA AK1 CS( 28) / +.3161645603 4040694931 3686186666 66 D-24 / + DATA AK1 CS( 29) / -.6046205531 2274989106 5064106666 66 D-25 / + DATA AK1 CS( 30) / +.1167879894 2042732700 7184213333 33 D-25 / + DATA AK1 CS( 31) / -.2277374158 2653996232 8678400000 00 D-26 / + DATA AK1 CS( 32) / +.4481109730 0773675795 3058133333 33 D-27 / + DATA AK1 CS( 33) / -.8893288476 9020194062 3360000000 00 D-28 / + DATA AK1 CS( 34) / +.1779468001 8850275131 3920000000 00 D-28 / + DATA AK1 CS( 35) / -.3588455596 7329095821 9946666666 66 D-29 / + DATA AK1 CS( 36) / +.7290629049 2694257991 6799999999 99 D-30 / + DATA AK1 CS( 37) / -.1491844984 5546227073 0240000000 00 D-30 / + DATA AK1 CS( 38) / +.3073657387 2934276300 7999999999 99 D-31 / + DATA AK12CS( 1) / +.6379308343 7390010366 0048853410 2 D-1 / + DATA AK12CS( 2) / +.2832887813 0497209358 3503028470 8 D-1 / + DATA AK12CS( 3) / -.2475370673 9052503454 1454556673 2 D-3 / + DATA AK12CS( 4) / +.5771972451 6072488204 7097662576 3 D-5 / + DATA AK12CS( 5) / -.2068939219 5365483027 4553319655 2 D-6 / + DATA AK12CS( 6) / +.9739983441 3818041803 0921309788 7 D-8 / + DATA AK12CS( 7) / -.5585336140 3806249846 8889551112 9 D-9 / + DATA AK12CS( 8) / +.3732996634 0461852402 2121285473 1 D-10 / + DATA AK12CS( 9) / -.2825051961 0232254451 3506575492 8 D-11 / + DATA AK12CS( 10) / +.2372019002 4841441736 4349695548 6 D-12 / + DATA AK12CS( 11) / -.2176677387 9917539792 6830166793 8 D-13 / + DATA AK12CS( 12) / +.2157914161 6160324539 3956268970 6 D-14 / + DATA AK12CS( 13) / -.2290196930 7182692759 9155133815 4 D-15 / + DATA AK12CS( 14) / +.2582885729 8232749619 1993956522 6 D-16 / + DATA AK12CS( 15) / -.3076752641 2684631876 2109817344 0 D-17 / + DATA AK12CS( 16) / +.3851487721 2804915970 9489684479 9 D-18 / + DATA AK12CS( 17) / -.5044794897 6415289771 1728250880 0 D-19 / + DATA AK12CS( 18) / +.6888673850 4185442370 1829222399 9 D-20 / + DATA AK12CS( 19) / -.9775041541 9501183030 0213248000 0 D-21 / + DATA AK12CS( 20) / +.1437416218 5238364610 0165973333 3 D-21 / + DATA AK12CS( 21) / -.2185059497 3443473734 9973333333 3 D-22 / + DATA AK12CS( 22) / +.3426245621 8092206316 4538880000 0 D-23 / + DATA AK12CS( 23) / -.5531064394 2464082325 0124800000 0 D-24 / + DATA AK12CS( 24) / +.9176601505 6859954037 8282666666 6 D-25 / + DATA AK12CS( 25) / -.1562287203 6180249114 4874666666 6 D-25 / + DATA AK12CS( 26) / +.2725419375 4843331323 4943999999 9 D-26 / + DATA AK12CS( 27) / -.4865674910 0748279923 7802666666 6 D-27 / + DATA AK12CS( 28) / +.8879388552 7235025873 5786666666 6 D-28 / + DATA AK12CS( 29) / -.1654585918 0392575489 3653333333 3 D-28 / + DATA AK12CS( 30) / +.3145111321 3578486743 0399999999 9 D-29 / + DATA AK12CS( 31) / -.6092998312 1931276124 1600000000 0 D-30 / + DATA AK12CS( 32) / +.1202021939 3698158346 2399999999 9 D-30 / + DATA AK12CS( 33) / -.2412930801 4594088413 8666666666 6 D-31 / + DATA NTK1, NTAK1, NTAK12, XMIN, XSML / 3*0, 2*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBSK1Es + IF (NTK1.NE.0) GO TO 10 +c ETA = 0.1*SNGL(D1MACH(3)) + eta=1.4e-18 + NTK1 = INITDSs (BK1CS, 16, ETA) + NTAK1 = INITDSs (AK1CS, 38, ETA) + NTAK12 = INITDSs (AK12CS, 33, ETA) +C +c XMIN = DEXP (DMAX1(DLOG(D1MACH(1)), -DLOG(D1MACH(2))) + 0.01D0) + xmin=5.94d-39 +c XSML = DSQRT (4.0D0*D1MACH(3)) + xsml=7.5d-9 +C + 10 IF (X.LE.0.D0) write(6,*)'DBSK1Es X IS ZERO OR NEGATIVE' + IF (X.GT.2.0D0) GO TO 20 +C + IF (X.LT.XMIN) write(6,*)'DBSK1Es X SO SMALL K1 OVERFLOWS' + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBSK1Es = DEXP(X)*(DLOG(0.5D0*X)*DBESI1s(X) + (0.75D0 + + 1 DCSEVLs (0.5D0*Y-1.D0, BK1CS, NTK1))/X ) + RETURN +C + 20 IF (X.LE.8.D0) DBSK1Es = + & (1.25D0 + DCSEVLs ((16.D0/X-5.D0)/3.D0, + 1 AK1CS, NTAK1))/DSQRT(X) + IF (X.GT.8.D0) DBSK1Es = (1.25D0 + + 1 DCSEVLs (16.D0/X-1.D0, AK12CS, NTAK12))/DSQRT(X) +C + RETURN + END + DOUBLE PRECISION FUNCTION DBESK1s(X) +C***BEGIN PROLOGUE DBESK1 +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESK1-S DBESK1-D),BESSEL FUNCTION, +C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, +C ORDER ONE,SPECIAL FUNCTIONS,THIRD KIND +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the dp modified Bessel function of the third kind +C of order one. +C***DESCRIPTION +C +C DBESK1(X) calculates the double precision modified (hyperbolic) +C Bessel function of the third kind of order one for double precision +C argument X. The argument must be large enough that the result does +C not overflow and small enough that the result does not underflow. +C +C Series for BK1 on the interval 0. to 4.00000E+00 +C with weighted error 9.16E-32 +C log weighted error 31.04 +C significant figures required 30.61 +C decimal places required 31.64 +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DBESI1,DBSK1E,DCSEVL,INITDS,XERROR +C***END PROLOGUE DBESK1 + DOUBLE PRECISION X, BK1CS(16), XMAX, XMIN, XSML, Y, + 1 DCSEVLs, DBESI1s, DBSK1Es + SAVE BK1 CS, NTK1, XMIN, XSML, XMAX + DATA BK1 CS( 1) / +.2530022733 8947770532 5311208685 33 D-1 / + DATA BK1 CS( 2) / -.3531559607 7654487566 7238316918 01 D+0 / + DATA BK1 CS( 3) / -.1226111808 2265714823 4790679300 42 D+0 / + DATA BK1 CS( 4) / -.6975723859 6398643501 8129202960 83 D-2 / + DATA BK1 CS( 5) / -.1730288957 5130520630 1765073689 79 D-3 / + DATA BK1 CS( 6) / -.2433406141 5659682349 6007350301 64 D-5 / + DATA BK1 CS( 7) / -.2213387630 7347258558 3152525451 26 D-7 / + DATA BK1 CS( 8) / -.1411488392 6335277610 9583302126 08 D-9 / + DATA BK1 CS( 9) / -.6666901694 1993290060 8537512643 73 D-12 / + DATA BK1 CS( 10) / -.2427449850 5193659339 2631968648 53 D-14 / + DATA BK1 CS( 11) / -.7023863479 3862875971 7837971200 00 D-17 / + DATA BK1 CS( 12) / -.1654327515 5100994675 4910293333 33 D-19 / + DATA BK1 CS( 13) / -.3233834745 9944491991 8933333333 33 D-22 / + DATA BK1 CS( 14) / -.5331275052 9265274999 4666666666 66 D-25 / + DATA BK1 CS( 15) / -.7513040716 2157226666 6666666666 66 D-28 / + DATA BK1 CS( 16) / -.9155085717 6541866666 6666666666 66 D-31 / + DATA NTK1, XMIN, XSML, XMAX / 0, 3*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBESK1s + IF (NTK1.NE.0) GO TO 10 + NTK1 = INITDSs (BK1CS, 16, 1.4e-18) +c XMIN = DEXP (DMAX1(DLOG(D1MACH(1)), -DLOG(D1MACH(2))) + 0.01D0) + xmin=5.94d-39 + xsml=7.5e-9 +c XSML = DSQRT (4.0D0*D1MACH(3)) +c XMAX = -DLOG(D1MACH(1)) +c XMAX = XMAX - 0.5D0*XMAX*DLOG(XMAX)/(XMAX+0.5D0) + xmax=86.4 +C + 10 IF (X.LE.0.D0) go to 1001 + IF (X.GT.2.0D0) GO TO 20 +C + IF (X.LT.XMIN) write(6,*)'DBESK1s X SO SMALL K1 OVERFLOWS' + Y=0.d0 + IF (X.GT.XSML) Y = X*X + DBESK1s = DLOG(0.5D0*X)*DBESI1s(X) + + & (0.75D0 + DCSEVLs(.5D0*Y-1.D0, + 1 BK1CS, NTK1))/X + RETURN +C + 20 DBESK1s = 0.D0 + IF (X.GT.XMAX) write(6,*)'DBESK1s X SO BIG K1 UNDERFLOWS' + IF (X.GT.XMAX) RETURN +C + DBESK1s = DEXP(-X) * DBSK1Es(X) +C + RETURN + 1001 write(6,*)'DBESK1s X IS ZERO OR NEGATIVE- stopped' + stop + END + subroutine BESSKn(M,N,X,y,KODE) + implicit double precision(a-h,o-z) +c Calculates an M-member sequence of modified Bessel functions of the +c 2nd kind. Needs subroutines for exponentially scaled and unscaled +c K_0(x) and K1(x). +c Sequence contains either unscaled or scaled Bessel functions. +c KODE=1 means unscaled. +c KODE=2 means scaled. +c y(k), k=1,2,..m contains K_N (x),K_N+1 (x),...K_N+M-1 (x) +c N must be > or = 0. + dimension y(m) + IF (N.LT.0) go to 1001 + if(kode.eq.2) bkm=dbsk0es(x) + if(kode.eq.2) bk=dbsk1es(x) + if(kode.eq.1) bkm=dbesk0s(x) + if(kode.eq.1) bk=dbesk1s(x) + if(n.gt.1) go to 64 + if(n.gt.0) go to 63 +c n=0 + y(1)=bkm + if(m.lt.2) return + y(2)=bk + if(m.lt.3) return + lmin=3 + go to 64 +c n=1 + 63 y(1)=bk + if(m.lt.2) return + lmin=2 + 64 n2=n+m-1 + if(n.gt.1) lmin=1 + tox=2.d0/x + do 61 j=1,n2-1 + bkp=bkm+dfloat(j)*tox*bk + bkm=bk + bk=bkp + do 62 l=lmin,m + jj=n+l-2 + 62 if(jj.eq.j) y(l)=bk + 61 continue + return + 1001 write(6,*) 'Stopped in BESSKn- N<0: N=',N + stop + end diff --git a/OpticsJan2020/MLI_light_optics/Src/inpu.f b/OpticsJan2020/MLI_light_optics/Src/inpu.f new file mode 100755 index 0000000..65aab06 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/inpu.f @@ -0,0 +1,1857 @@ +************************************************************************ +* header: INPUT AND OUTPUT * +* Input and output for maps, matrices, files, arrays, and parameter * +* sets * +************************************************************************ +c + subroutine cf(p) +c subroutine to close files +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' + dimension p(6),ip(6) + include 'files.inc' +c +c set up control indices + do 10 j=1,6 + ip(j)=nint(p(j)) + 10 continue +c +c close indicated files + do 20 j=1,6 + n=ip(j) + if( n.gt.0) close(unit=n, err=30) + go to 20 + 30 write(jof,*) 'error in closing file unit ',n + 20 continue +c + return + end +c +*********************************************************************** +c + subroutine fnamechk(fname,iu,ierr,str) +cryne +c R. Ryne 7/16/2002 +c check file names and associated unit number +c this is needed now that it is possible to open files w/ given names +c NB: At the end of this routine, only PE0 knows the file unit number iu, +c and only PE0 has an connection to file fname via file unit number iu. +c All PEs know the error flag ierr. + use parallel + logical ex,op,exu,opu,lname + character*16 fname,uname + character (len=*) str + integer n + common/bfileinfo/ifileinfo +!cryne===== 28 July, 2004 if(idproc.ne.0)return + if(idproc.eq.0)then +!cryne===== +! +! +! write(6,*)'here I ama in fnamemchk, iu=',iu + nmax=len_trim(str) + ierr=0 +cryne----- Jan 3, 2003: +c if the requested unit number =0, then the code should obtain +c a valid, unused unit number. +c For historical purposes (original Marylie used multiple files <~20), +c the unit numbers will be searched between 31 on upward. +c This should be irrelevant to the user, as these numbers will not be seen. + if(iu.eq.0)then + iumin=31 + iumax=1000 + do iuu=iumin,iumax + INQUIRE(UNIT=iuu,EXIST=exu,OPENED=opu,NAMED=lname,NAME=uname) + if(exu .and. .not.opu)then + iu=iuu + exit + endif + enddo + if(iu.eq.0)then + if(idproc.eq.0)write(6,*)'unable to find an available unit #' + ierr=1 + goto 9999 + endif + endif +cryne----- + INQUIRE(UNIT=iu,EXIST=exu,OPENED=opu,NAMED=lname,NAME=uname) + INQUIRE(FILE=fname,EXIST=ex,OPENED=op,NUMBER=numb) +c if the file is already open and connected to the unit specified +c by the user (or the default value in use), then everything is OK: + if(op.and.(numb.eq.iu))then + if(idproc.eq.0.and.fname.ne.' ')then + if(ifileinfo.ne.0)write(6,*)'(',str(1:nmax),') ', & + & 'file ',fname(1:16), ' will stay connected to unit ',iu + endif + goto 9999 + endif +c the file needs to be created and/or opened. +c first check to see if iu is a valid unit number: + if(.not.exu)then + write(6,*)'Error: file unit ',iu,' is not valid for this system.' + write(6,*)'It cannot be assigned to file ',fname + write(6,*)'command ',str(1:nmax),' will be ignored' + ierr=1 + goto 9999 + endif +c does the file exist? + if(.not.ex)then +c if not, create/open it: + if(fname.ne.' ')then + if(idproc.eq.0)then + if(ifileinfo.ne.0)write(6,*)'(',str(1:nmax),') ','creating ', & + & 'file ',fname(1:16), ' and connecting to unit ',iu + endif + open(unit=iu,file=fname,status='new') + else +cg95 open(unit=iu,status='new') + if(idproc.eq.0)write(6,*)'code should not get here' + call myexit + endif + goto 9999 + endif +c file exists. Is it open? +c if not, open it, but first make sure unit iu is not in use. + if(.not.op)then + if(.not.opu)then + if(idproc.eq.0.and.ifileinfo.ne.0)then + write(6,*)'(',str(1:nmax),') ','opening ', & + & 'existing file ',fname(1:16), ' and connecting to unit ',iu + write(6,*)'If written to, the file will be overwritten' + endif + open(unit=iu,file=fname,status='old') + goto 9999 + else + write(6,*)'file unit ',iu,' is already in use.' + write(6,*)'It cannot be assigned to file ',fname +c write(6,*)'command ',str(1:nmax),' will be ignored' +c ierr=1 + write(6,*)'instead the following file will be used: ',uname + goto 9999 + endif + else +c the file exists and is open. There must be a problem with +c conflicting unit numbers [numb.ne.iu] Fix it: +c write(6,*)'(',str(1:nmax),') Problem w/ file unit specification' +c write(6,*)'for file with name ',fname +c write(6,*)'File is already connected to unit ',numb +c write(6,*)'but user has specified (or default is) unit ',iu +c write(6,*)'Existing unit number will be used' +c + if(ifileinfo.ne.0)then + write(6,*)'(',str(1:nmax),') File named ',fname + write(6,*)'will continue to stay connected to unit ',numb + endif + iu=numb + goto 9999 + endif +c +!cryne===== 28 July 2004 only PE 0 executed the above code + 9999 continue + endif +!cryne===== 28 July 2004 now all PEs execute the following: + call ibcast(ierr) +cryne-abell: delete next four lines when read_egengrads works in || +c call ibcast(iu) +c if (idproc.ne.0.and.iu.ne.0) then +c open(unit=iu,file=fname,status='old') +c endif + return + end +c +*********************************************************************** +c + subroutine mapin(nopt,nskp,h,mh) +c read nonzero matrix elements and monomials from file unit mpi + use lieaparam, only : monoms + include 'impli.inc' + double precision h,mh + include 'files.inc' + dimension mh(6,6),h(monoms) +c Written by D. Douglas ca 1982 and modified by Rob Ryne +c and Alex Dragt ca 1986 +c + if(nopt.eq.0)goto 5 + rewind mpi + write(jof,210)mpi + 5 continue +c initialize arrays: + do 10 j=1,monoms + 10 h(j)=0.d0 + do 20 k=1,6 + do 20 l=1,6 + 20 mh(k,l)=0. +c +c skip nskp maps: + ns=nskp + 55 if(ns.eq.0)goto 100 + 60 read(mpi,*)i,j,temp + if(i.eq.6.and.j.eq.6)goto 80 + goto 60 + 80 read(mpi,*)k,temp + if(k.eq.monoms)goto 90 + goto 80 + 90 ns=ns-1 + goto 55 +c +c now read in the map: + 100 continue + 160 read(mpi,*)i,j,temp + mh(i,j)=temp + if(i.eq.6.and.j.eq.6)goto 180 + goto 160 + 180 read(mpi,*)k,temp + h(k)=temp + if(k.eq.monoms)goto 200 + goto 180 + 200 continue + write(6,205) mpi,nskp + 205 format(1x,'map read in from file ',i3,'; ',i3, + &' record(s) skipped') + 210 format(1x,'file unit ',i2,' rewound') + return + end +c +*********************************************************************** +c + subroutine mapout(nopt,h,mh) +c output present matrix and polynomials (nonzero values) +c Written by D. Douglas ca 1982 and modified by Rob Ryne +c and Alex Dragt ca 1984 +c modified Oct 89 by Tom Mottershead to work without requiring +c a prior map file. +c The parameter nopt is not currently used +c + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' +c +c calling arrays +c + double precision h,mh + dimension mh(6,6),h(monoms) +c +c check to see if file assignment makes sense + if(mpo .le. 0) return +c + nout=mpo +c + read(nout,*,end=5,err=19)dummy + 5 rewind(nout) +c +c count the # of lines in the file: + ncount=0 + 10 read(nout,*,end=15)dummy + ncount=ncount+1 + goto 10 + 15 continue + write(6,*)'found ',ncount,' lines in file ',nout + rewind(nout) + do n=1,ncount + read(nout,*)dummy + enddo + write(jof,*)'adding current map to file on unit ',nout + goto 25 +c +c read error means map file does not exist, so start a new one +c + 19 write(jof,21) nout + 21 format(' starting new map file on unit',i3) +c +c write out map +c + 25 continue + do 30 i=1,6 + do 30 j=1,6 + 30 if(mh(i,j).ne.0.)write(nout,*)i,j,mh(i,j) + if(mh(6,6).eq.0.)write(nout,*)6,6,mh(6,6) + do 40 k=1,monoms + 40 if(h(k).ne.0.)write(nout,*)k,h(k) + if(h(monoms).eq.0.)write(nout,*)monoms,h(monoms) +c write(jof,100) nout +c 100 format(1x,'map written on file ',i2) + return + end +c +*********************************************************************** +c + subroutine mapsnd(iopt,nmap,ta,tm,ha,hm) +c this is a subroutine for sending a map to some buffer or file +c Written by Alex Dragt, Spring 1987 + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'buffer.inc' + character*3 kynd +c + dimension ta(monoms),ha(monoms) + dimension tm(6,6),hm(6,6) +c +c procedure when iopt = 0 + if (iopt.eq.0) then + if (nmap.ge.1 .and. nmap.le.5) then + kynd='stm' + call strget(kynd,nmap,ta,tm) + endif +c + if (nmap.eq.0) call mapmap(ta,tm,ha,hm) +c + if (nmap.eq.-1) call mapmap(ta,tm,buf1a,buf1m) + if (nmap.eq.-2) call mapmap(ta,tm,buf2a,buf2m) + if (nmap.eq.-3) call mapmap(ta,tm,buf3a,buf3m) + if (nmap.eq.-4) call mapmap(ta,tm,buf4a,buf4m) + if (nmap.eq.-5) call mapmap(ta,tm,buf5a,buf5m) + endif +c +c procedure when iopt .gt. 0 + if (iopt.gt.0) then + mpot=mpo + mpo=iopt + call mapout(0,ta,tm) + mpo=mpot + endif +c + return + end +c +************************************************************************ +c + subroutine numfile(p) +c This is a subroutine for numbering lines in a file +c Written by Alex Dragt, Spring 1987 + use rays + include 'impli.inc' + dimension p(6) + write(6,*)'THIS ROUTINE (NUMFILE) NEEDS TO BE MODIFIED TO' + write(6,*)'EXECUTE PROPERLY IN PARALLEL' +c +c set up control indices + iopt=nint(p(1)) + nfile=nint(p(2)) + ifirst=nint(p(3)) + istep=nint(p(4)) +c +c procedure for writing out a file with numbered lines + line=ifirst + do 10 i=1,nraysp + write(nfile,100) line, + & zblock(1,i), zblock(2,i), zblock(3,i), + & zblock(4,i), zblock(5,i), zblock(6,i) + 100 format(1x,i5,6(1x,1pe11.4)) + line=line+istep + 10 continue +c + return + end +c +*********************************************************************** +c + subroutine of(p) +c subroutine to open files +c Written by Alex Dragt, Spring 1987 + include 'impli.inc' + character*6 unit + dimension p(6),ip(6) + dimension unit(50) + include 'files.inc' +c +c set up file names +c + data (unit(i),i=1,50)/ + &'unit01','unit02','unit03','unit04','unit05', + &'unit06','unit07','unit08','unit09','unit10', + &'unit11','unit12','unit13','unit14','unit15', + &'unit16','unit17','unit18','unit19','unit20', + &'unit21','unit22','unit23','unit24','unit25', + &'unit26','unit27','unit28','unit29','unit30', + &'unit31','unit32','unit33','unit34','unit35', + &'unit36','unit37','unit38','unit39','unit40', + &'unit41','unit42','unit43','unit44','unit45', + &'unit46','unit47','unit48','unit49','unit50'/ +cryne 7/23/2002 + save unit +c +c set up control indices + do 10 j=1,6 + ip(j)=nint(p(j)) + 10 continue +c +c open indicated files + do 20 j=1,6 + n=ip(j) + if( n.gt.0 .and. n.le.50 .and. n.ne.lf .and. n.ne.jof + & .and. n.ne.jodf) then + open(unit=n, file=unit(n), status='unknown', err=30) + endif + go to 20 + 30 write(jof,*) 'error in opening file unit ',n + 20 continue +c + return + end +c +*********************************************************************** +c + subroutine pcmap(n1,n2,n3,n4,fa,fm) +c routine to print m,f3,f4 and t,u. +c Written by D. Douglas ca 1982 and modified by Rob Ryne +c and Alex Dragt ca 1986 + use parallel + use lieaparam, only : monoms + include 'impli.inc' + integer colme(6,0:6) + include 'expon.inc' + include 'pbkh.inc' + include 'files.inc' + dimension fa(monoms),fm(6,6) + dimension t(monoms),u(monoms),u2(monoms) + if(idproc.ne.0)return +c +c test for matrix write + if(n1.eq.0) goto 20 +c +c procedure for writing out matrix +c write matrix at terminal + if(n1.eq.1.or.n1.eq.3)then + write(jof,13) + 13 format(/1h ,'matrix for map is :'/) + write(jof,15)((fm(k,i),i=1,6),k=1,6) + 15 format(6(1x,1pe12.5)) + write(jof,*) + write(jof,*)'nonzero matrix elements in full precision:' + do k=1,6 + do i=1,6 + if(fm(k,i).ne.0.d0)write(jof,155)k,i,fm(k,i) + 155 format(i1,2x,i1,2x,1pg21.14) + enddo + enddo + write(jof,*) + endif +c write matrix on file 12 + if(n1.eq.2.or.n1.eq.3)then + write(jodf,13) + write(jodf,15)((fm(k,i),i=1,6),k=1,6) + write(jodf,*) + write(jodf,*)'nonzero matrix elements in full precision:' + do k=1,6 + do i=1,6 + if(fm(k,i).ne.0.d0)write(jodf,155)k,i,fm(k,i) + enddo + enddo + write(jodf,*) + endif +c +c test for polynomial write + 20 continue + if(n2.eq.0)goto 30 +c +c procedure for writing out polynomial +c write polynomial at terminal + if(n2.eq.1.or.n2.eq.3)then + write(jof,22) + 22 format(/1h ,'nonzero elements in generating polynomial are :'/) + do 25 i=1,monoms +ccccc if(fa(i).eq.0.0d0) goto 25 + if(fa(i).eq.0.0d0) goto 25 + write(jof,27)i,(expon(j,i),j=1,6),fa(i) +cryne 6/21/2002 27 format(2x,'f(',i3,')=f( ',3(2i1,1x),')=',d21.14) + 27 format(2x,'f(',i3,')=f( ',3(2i1,1x),')=',1pg21.14) + 25 continue + endif +c write polynomial on file 12 + if(n2.eq.2.or.n2.eq.3)then + write(jodf,22) + do 26 i=1,monoms +c06jan2019 if(fa(i).eq.0.0d0) goto 26 + write(jodf,27)i,(expon(j,i),j=1,6),fa(i) + 26 continue + endif +c +c prepare for higher order matrix write if required + 30 continue +cryne write(6,*)'inside pcmap' + if(n3.gt.0.or.n4.gt.0)then +cryne write(6,*)'calling brkts' + call brkts(fa) +cryne write(6,*)'returned from brkts' + endif +c +c test for t matrix write + if(n3.eq.0) goto 40 +c +c procedure for writing t matrix +c write out heading + if(n3.eq.1.or.n3.eq.3)write(jof,32) + if(n3.eq.2.or.n3.eq.3)write(jodf,32) + 32 format(/1h ,'nonzero elements in second order matrix are :'/) +c write out contents + do 35 i=1,6 + call xform(pbh(1,i),2,fm,i-1,t) + do 36 n=7,27 + if(t(n).eq.0.0d0) goto 36 + if(n3.eq.1.or.n3.eq.3) + & write(jof,38) i,n,i,(expon(j,n),j=1,6),t(n) + if(n3.eq.2.or.n3.eq.3) + & write(jodf,38) i,n,i,(expon(j,n),j=1,6),t(n) +cryne6/21/02 38format(2x,'t',i1,'(',i3,')','=t',i1,'( ',3(2i1,1x),')=',d21.14) + 38 format(2x,'t',i1,'(',i3,')','=t',i1,'( ',3(2i1,1x),')=',1pg21.14) + 36 continue + 35 continue +c + +c test for u matrix write + 40 continue + if(n4.eq.0) goto 50 +c +c procedure for writing u matrix +c write out heading + if(n4.eq.1.or.n4.eq.3)write(jof,42) + if(n4.eq.2.or.n4.eq.3)write(jodf,42) + 42 format(/1h ,'nonzero elements in third order matrix are :'/) +c write out contents + do 44 i=1,6 + call xform(pbh(1,i),3,fm,i-1,u) + call xform(pbh(1,i+6),3,fm,1,u2) + do 45 n=28,83 + u(n)=u(n)+u2(n)/2.d0 + if(u(n).eq.0.0d0) goto 45 + if(n4.eq.1.or.n4.eq.3) + & write(jof,46) i,n,i,(expon(j,n),j=1,6),u(n) + if(n4.eq.2.or.n4.eq.3) + & write(jodf,46) i,n,i,(expon(j,n),j=1,6),u(n) +cryne 6/21/02 46format(2x,'u',i1,'(',i3,')','=u',i1,'( ',3(2i1,1x),')=',d21.14) + 46 format(2x,'u',i1,'(',i3,')','=u',i1,'( ',3(2i1,1x),')=',1pg21.14) + 45 continue + 44 continue +c +c procedure if all n's are zero or are faulty + 50 continue +c + return + end +c +*********************************************************************** +c + subroutine pset(p,k) +c subroutine to read in parameter set values +c the integer k labels the parameter set +c Written by Alex Dragt, Fall 1986 + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + dimension p(6) +c +c test on k + if (k.gt.maxpst .or. k.le.0) then + write(6,*) 'improper attempt to store parameters in + & a parameter set with k=',k + call myexit + endif +c +c store parameter values + do 10 i=1,6 + 10 pst(i,k)=p(i) +c + return + end +c +*********************************************************************** +c + subroutine psrmap(n1,n2,fa,fm) +c routine to print mij in the cartesian basis +c and the f's in the static resonance basis. +c Written by Alex Dragt, Fall 1986 +c + use lieaparam, only : monoms + include 'impli.inc' + include 'srl.inc' + include 'files.inc' + dimension fa(monoms),fm(6,6) +c +c beginning of routine +c +c writing out matrix + if(n1.eq.0)goto 20 + if(n1.eq.1.or.n1.eq.3)write(jof,33) + if(n1.eq.2.or.n1.eq.3)write(jodf,33) + 33 format(/1h ,'matrix for map is :'/) + if(n1.eq.1.or.n1.eq.3)write(jof,35)((fm(k,i),i=1,6),k=1,6) + if(n1.eq.2.or.n1.eq.3)write(jodf,35)((fm(k,i),i=1,6),k=1,6) +c 35 format(6(1x,e12.5)) + 35 format(6(1x,1pe12.5)) +c +c writing out f's + 20 if(n2.eq.0)goto 30 + if(n2.eq.1.or.n2.eq.3)write(jof,55) + if(n2.eq.2.or.n2.eq.3)write(jodf,55) + 55 format(/1h ,'nonzero elements in generating polynomial in',/, + &1x,'the static resonance basis are :'/) + do 22 i=1,monoms + if (fa(i).eq.0.0d0) go to 22 + if(n2.eq.1.or.n2.eq.3)write(jof,60)i,sln(i),fa(i) + if(n2.eq.2.or.n2.eq.3)write(jodf,60)i,sln(i),fa(i) + 60 format(1x,'f(',i3,')=f( ',a6,' )=',d21.14) + 22 continue +c + 30 continue + return + end +c +*********************************************************************** +c + subroutine pdrmap(n1,n2,fa,fm) +c routine to print mij in the cartesian basis +c and the f's in the dynamic resonance basis. +c F. Neri 6/3/1986 +c + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'drl.inc' + dimension fa(monoms),fm(6,6) +c +c beginning of routine +c +c writing out matrix + if(n1.eq.0)goto 20 + if(n1.eq.1.or.n1.eq.3)write(jof,33) + if(n1.eq.2.or.n1.eq.3)write(jodf,33) + 33 format(/1h ,'matrix for map is :'/) + if(n1.eq.1.or.n1.eq.3)write(jof,35)((fm(k,i),i=1,6),k=1,6) + if(n1.eq.2.or.n1.eq.3)write(jodf,35)((fm(k,i),i=1,6),k=1,6) +c 35 format(6(1x,e12.5)) + 35 format(6(1x,1pe12.5)) +c +c writing out f's + 20 if(n2.eq.0)goto 30 + if(n2.eq.1.or.n2.eq.3)write(jof,55) + if(n2.eq.2.or.n2.eq.3)write(jodf,55) + 55 format(/1h ,'nonzero elements in generating polynomial in',/, + &1x,'the dynamic resonance basis are :'/) + do 22 i=1,monoms + if (fa(i).eq.0.0d0) go to 22 + if(n2.eq.1.or.n2.eq.3)write(jof,60)i,dln(i),fa(i) + if(n2.eq.2.or.n2.eq.3)write(jodf,60)i,dln(i),fa(i) + 60 format(1x,'f(',i3,')=f( ',a7,' )=',d21.14) + 22 continue +c + 30 continue + return + end +c +***************************************************************** +c + subroutine pmif(iu,itype,fname) +c subroutine to write out the master input file +c written by Rob Ryne ca 1984 +ctm modified 9/01 to write unexpanded #include files +c + use parallel + use beamdata + use acceldata + use lieaparam, only : monoms + include 'impli.inc' + include 'codes.inc' + include 'incmif.inc' + include 'files.inc' +c + character*79 line + logical noitem, nolab + character*16 str1,fname +c +cryne 7/23/2002 don't know why this save statement was put here, +cryne but I will leave it for now. + save + if(idproc.ne.0)return +c------------------ +c start routine +c------------------ +ctm itype = 0 to echo input file as is +ctm itype = 1 to write input file from full internal commons. +ctm itype = 2 to write only #labor part +ctm itype = 3 to write from commons without expanding the #includes +c------------------------------------------------------- +c------------------------------------------------------- +c +c initialize loop limits for full common dump +c + noitem = .true. + if(nb.gt.0) noitem = .false. + nolab = .true. + if(noble.gt.0) nolab = .false. + kbgn = 1 + kend = na + ibgn = 1 + iend = nb + jbgn = 1 + jend = noble + goto(4,90,30)itype +c +c echo exact contents of file lf: (for out of bounds itype) +c + rewind lf + 1 read(lf,1002,end=3)line + 1002 format(a) + write(iu,1003)line + 1003 format(1x,a) + goto 1 + 3 continue + write(iu,*) + return +c +ctm reset loop limits to exclude #includes +c + 30 continue + if(ninc.eq.0) go to 4 + kend = na1 + noitem = .true. + if((nb1.gt.0).and.(nb2.eq.nb)) then + ibgn = 1 + iend = nb1 + noitem = .false. + endif + if((nb2.gt.0).and.(nb.gt.nb2)) then + ibgn = nb2 + 1 + iend = nb + noitem = .false. + endif + jbgn = noble2 + 1 +c +c +c write from internal commons +c + 4 continue +c +c comments + if(np.eq.0)goto 5 + write(iu,530)ling(1) + write(iu,6)(mline(i),i=1,np) +c mline is character*80, but is written out with an a79 format +c so that the last character (which should be a blank) does not +c cause carriage returns (and hence blank lines) on laser printers + 6 format(a79) +c 6 format(a80) +c beam + 5 write(iu,530)ling(2) + write(iu,*)brho + write(iu,*)gamm1 + write(iu,*)achg + write(iu,*)sl +c menu + write(iu,530)ling(3) +cryne quick hack to check for long names in the menu: + longnm=0 + do 10 k=kbgn,kend + str1=lmnlbl(k) + if(str1(9:9).ne.' ')longnm=1 + if(longnm.eq.0)write(iu,600)lmnlbl(k),ltc(nt1(k),nt2(k)) + if(longnm.eq.1)write(iu,6000)trim(lmnlbl(k)),ltc(nt1(k),nt2(k)) + imax=nrp(nt1(k),nt2(k)) + if(imax.eq.0)goto 10 + write(iu,603)(pmenu(i+mpp(k)),i=1,imax) + 10 continue +c +ctm explicit #include +c + if(itype.eq.3) then + if(ninc.eq.0) go to 50 + write(iu,530)ling(8) + do 35 jj = 1, ninc + write(iu,33) incfil(jj) + 33 format(2x,a) + 35 continue + endif +c lines,lumps,loops + 50 if(noitem)goto 90 + do 40 ii=2,4 + write(iu,530)ling(ii+2) + do 20 k=ibgn,iend + if(ityp(k).ne.ii)goto 20 + write(iu,790)ilbl(k) + if(longnm.eq.0)write(iu,791)(irep(l,k),icon(l,k),l=1,ilen(k)) + if(longnm.eq.1) & + & write(iu,7910)(irep(l,k),trim(icon(l,k)),l=1,ilen(k)) + 20 continue + 40 continue +c labor + 90 if(nolab)goto 999 + write(iu,530)ling(7) + do 100 j=jbgn,jend + 100 write(iu,800)num(j),latt(j) +c 529 format(1h ,'#comments') + 530 format(1h ,a8) + 600 format(1h ,1x,a8,1x,a8) + 6000 format(1h ,1x,a,1x,a8) +c 603 format((1h ,3(1x,d22.15))) +c Output using Mottershead's favorite pg format + 603 format((1h ,3(1x,1pg22.15))) +cryne 790 format(1h ,1x,a8) + 790 format(1h ,1x,a) + 791 format((1h ,1x,5(i5,'*',a8),1x,:'&')) +cryne 7910 format((1h ,1x,3(i5,'*',a28),1x,:'&')) + 7910 format((1h ,1x,5(i5,'*',a),1x,:'&')) +cryne 800 format(1h ,1x,i4,'*',a8) + 800 format(1h ,1x,i4,'*',a) + 999 continue +c write(iu,*) + return + end +c +****************************************************************** +c + subroutine randin(nfile,kt1,kt2,p) +c This is a subroutine for reading in and checking the parameters +c for random elements. +c Written by Alex Dragt, ca 1985, and modified by F. Neri +c and Alex Dragt on 29 January 1988 + use lieaparam, only : monoms + include 'impli.inc' + double precision p(6) + include 'files.inc' + include 'codes.inc' + include 'parset.inc' +c + if(nfile.gt.0) then +c Read in parameters from file: + 2 read(nfile,*,end=4,err=6)(p(i),i=1,nrp(kt1,kt2)) + goto 8 + 4 rewind nfile + goto 2 + 6 write(6,7) nfile,kt1,kt2 + 7 format(1x,'nfile=',i4,'kt1,kt2=',2i4,'error in randin') + call myexit + 8 continue + else if(nfile.lt.0) then +c Read in parameters form parameter sets: + npar = -nfile + if(npar.gt.maxpst) then + write(jof,*) ' num of pset too large in rnd lmnt.' + call myexit + endif + do 7008 i=1,6 + p(i) = pst(i,npar) + 7008 continue + else + write(jof,*) ' zero pset number in rnd lmnt.' + call myexit + endif +c +c Check on parameter values corresponding to control indices: + goto(10,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160, + &170),kt2 + return +c +c drift: + 10 continue + return +c +c normal entry bend: + 20 call rcheck(0,1,p(3),'lfrn','nbnd',nfile) + call rcheck(0,1,p(4),'tfrn','nbnd',nfile) + return +c +c parallel faced bend: + 30 continue + return +c +c general bending magnet: + 40 call rcheck(0,1,p(5),'lfrn','gbnd',nfile) + call rcheck(0,1,p(6),'tfrn','gbnd',nfile) + return +c +c leading or trailing rotation for a parallel faced bend: + 50 call rcheck(0,1,p(2),'kind','prot',nfile) + return +c +c body of a general bending magnet: + 60 continue + return +c +c hard edge fringe fields of a normal entry bend: + 70 call rcheck(0,1,p(2),'iedg','frng',nfile) + return +c +c combined function bend: + 80 continue + return +c +c quadrupole: + 90 call rcheck(0,1,p(3),'lfrn','quad',nfile) + call rcheck(0,1,p(4),'tfrn','quad',nfile) + return +c +c sextupole: + 100 continue + return +c +c mag. octupole: + 110 continue + return +c +c elec. octupole: + 120 continue + return +c +c short rf cavity + 130 continue + return +c +c axial rotation: + 140 continue + return +c +c linear matrix via twiss parameters: + 150 call rcheck(1,3,p(1),'ipla','twsm',nfile) + return +c +c thin lens low order multipole: + 160 continue + return +c +c "compressed" low order multipole: + 170 continue +c + return + end +c +c +*************************************************************** +c + subroutine raysin(icfile,nraysinp,scaleleni,scalefrqi,scalemomi, & + &ubuf,jerr) +c routine to read in initial conditions of rays to be traced +c and to initialize the arrays istat and ihist +c Written by Robert Ryne ca 1984, and modified by Alex Dragt +cryne 2/16/2002 mods to handle missing file and file with a bad record + + use rays +! use parallel + include 'impli.inc' + include 'files.inc' + include 'parset.inc' + character*80 fname,line + character*80 string + character*16 symb(50),istrtsymb(50) + character*16 ubuf + logical keypres,numpres,leof + dimension bufr(1) + dimension tmpvec(6) +c +c procedure for reading a single set of initial conditions from +c a parameter set +c + if(icfile.lt.0) then +cryne 3/10/2004 this option does not work sensibly on multiple processors. +cryne Whatever is in ipset goes in zblock, so all procs get the same partcles. + ipset=-icfile + if(ipset.gt.maxpst) then + if(idproc.eq.0)write(jof,*)'(raysin)parameter icfile out of range' + call myexit + endif + nrays=1 + do 10 j=1,6 + 10 zblock(j,1)=pst(j,ipset) + goto 130 + endif +c + if(idproc.eq.0)then +c procedure for reading initial conditions from a file +c first check to see if there is a header (scaling info) in the input file: + write(6,*)'Rewinding/reading particle data in file connected', & + & ' to unit ',icfile + 20 continue + nrays=0 + rewind icfile + ncomm=0 + 22 continue + read(icfile,'(a)',end=110,err=120)line +cryne quick hack: % should be in column 1, or user might put an extra +cryne space or two: + if(line(1:1).eq.'%' .or. & + & line(1:2).eq.' %' .or. & + & line(1:3).eq.' %')then + call low(line) + write(6,'(a)')line + ncomm=ncomm+1 + ubuf=' ' + call getscaleinfo(line,ubuf,scaleleni,scalefrqi,scalemomi,jerr) + if(jerr.ne.0)write(6,*)'(RAYSIN)ERROR RETURN FROM GETSCALEINFO' + else + write(6,*)'found ',ncomm, 'lines of header info' + goto 123 + endif + goto 22 +c EOF: + 110 continue + write(6,*)'trouble:particle data file may be missing or empty.' + goto 122 +c ERR: + 120 write(jof,121) + 121 format(1x,'trouble in raysin while trying to read header info') + 122 continue +c try opening another file: + write(6,*)'type a file name or to stop' + read(5,210)fname + if(fname.eq.' ')call myexit + 210 format(a16) + open(icfile,file=fname,status='old',err=300) + goto 20 + 300 continue + write(6,*)'file still does not exist. Halting.' + call myexit + + 123 continue +c count particle data + if(nraysinp.gt.0)then + nrays=nraysinp + goto 125 + endif +c + nrays=0 + rewind icfile + if(ncomm.ne.0)then + do i=1,ncomm +cryne could put an end= and err= here, but not really needed. +cryne read(icfile,'(a)',end=987,err=987)line + read(icfile,'(a)')line + enddo + endif +cryne 222 read(icfile,'(a)',end=910,err=920)line +cryne modified March 10, 2004 to perform unformmated read of 6 numbers +cryne instead of a formatted read of a character string. +cryne this was done because there may be blank lines (e.g. at end), which +cryne lead to an incorrect count unless reading 6 numbers (not a char string) + 222 read(icfile,*,end=910,err=920)tmpvec(1:6) + nrays=nrays+1 + goto 222 + 910 continue + if(nrays.ne.0)then + write(6,*)'found ',nrays,' particles in data file' + goto 125 + endif + write(6,*)'trouble: no particles found in particle data file' + call myexit + 920 continue + write(6,*)'error trying to read particle data' + call myexit +c Processor 0 knows value of nrays. Now broadcast it to all processors + 125 continue + do l=1,nvp-1 + call MPI_SEND(nrays,1,mntgr,l,96,lworld,ierr) + enddo + else + call MPI_RECV(nrays,1,mntgr,0,96,lworld,mpistat,ierr) + endif +c +cryne 1 August, 2004 + if(nrays.lt.nvp)then + if(idproc.eq.0)then + write(6,*)'ERROR: # of particles is < # of processors' + write(6,*)'Execution will be terminated' + endif + call myexit + endif +c + if( (nrays.le.maxray) .and. allocated(zblock) )goto 127 + if( (nrays.le.maxray) .and. .not.allocated(zblock) )then + call new_particledata + goto 127 + endif +c +c trouble: nrays.gt.maxray +c has zblock already been allocated? yes... + if(allocated(zblock))then + if(idproc.eq.0)then + write(6,*)'error: zblock has been allocated but is not large' + write(6,*)'enough to contain the particle array to be read in' + write(6,*)'Rerun with maxray .ge. ',nrays,' in beam definition' + endif + call myexit + endif +c ...no, zblock has not been allocated + if(idproc.eq.0)then + write(6,*)'WARNING: # of rays in input file = ',nrays + write(6,*)' current value of maxray = ',maxray + write(6,*)'setting maxray to ',nrays,' and allocating zblock' + endif + maxray=nrays + call new_particledata +c=========== data file counted; now proc 0 reads in the rays=========== + 127 continue + if(idproc.eq.0)then + rewind icfile + write(6,*)'PE0 has rewound file with unit number ',icfile + if(ncomm.gt.0)then + do n=1,ncomm + read(icfile,*)line(1:80) + enddo + endif +cryne May 19 2006 nraysp=(nrays-1)/nvp + 1 + nraysp0=nrays/nvp + nremain=nrays-nraysp0*nvp + nraysp=nraysp0 + if(nremain.gt.0.and.idproc.le.nremain-1)nraysp=nraysp0+1 +c1221 continue +c if(nraysp*(nvp-1).ge.nrays)then +c nraysp=nraysp-1 +c if(nraysp.eq.0)then +c write(6,*)'trouble: nraysp=0. something wrong. halting.' +c endif +c goto 1221 +c endif +c write(6,*)'nraysp=',nraysp + do k=1,nraysp +c write(6,*)k + read(icfile,*,end=9991,err=9992)zblock(:,k) +c write(6,1841)zblock(1:6,k) +c1841 format(6(1pe12.5,1x)) + enddo + write(6,*)'PE0 has read its own data' +cryne May 19, 2006 nraysw=nraysp + do l=1,nvp-1 +cryne May 19, 2006 if (l.eq.nvp-1) nraysw = nrays - nraysp*(nvp-1) + nraysw=nraysp0 + if(nremain.gt.0.and.l.le.nremain-1)nraysw=nraysp0+1 +c write(6,*)'PE0 is reading nraysw=',nraysw,' for PE#',l,'...' + do k=1,nraysw + read(icfile,*,end=9991,err=9992)tblock(:,k) + enddo +c write(6,*)'...done' + if(l.lt.nvp)then + call MPI_SEND(tblock,6*nraysw,mreal,l,99,lworld,ierr) + endif + enddo +c + izero=0 + write(6,*)'processor ',izero,' retained ',nraysp,' rays' +c + else + call MPI_RECV(zblock,6*maxrayp,mreal,0,99,lworld,mpistat,ierr) + call MPI_GET_COUNT(mpistat,mreal,nraysp,ierr) + nraysp=nraysp/6 + write(6,*)'processor ',idproc,' received ',nraysp,' rays' + endif + + 130 continue +c +c initialize arrrays and set up counters +c + do 115 k=1,nraysp + istat(k)=0 + ihist(1,k)=0 + ihist(2,k)=0 + 115 continue + iturn=0 + nlost=0 + return +cryne This does not work properly, since only PE0 would get here and exit. +cryne To do this right all the procs should find out that there is a problem, +cryne and all should exit. E.G. PE0 could send a special number in tblock(1,1), +cryne and all the procs could check to see if they received it, and if so, exit +cryne Too much trouble. MPI is a pain in the neck. + 9991 continue + if(idproc.eq.0)write(6,*)'error reading particle data file' + call myexit + 9992 continue + if(idproc.eq.0)write(6,*)'EOF encountered reading ptcl data file' + call myexit + end +*********************************************************************** +c + subroutine rcheck(min,max,arg,ivar,itype,nfile) +c This is a subroutine for checking that control +c parameters for random elements lie within the allowed range. +c Written by Alex Dragt ca 1985 + double precision arg + character*4 ivar,itype + iarg=nint(arg) + if (iarg.lt.min.or.iarg.gt.max) goto 10 + return + 10 write (6,100) ivar,iarg,itype,nfile + 100 format(1x,a4,'=',i4,1x,'trouble with random element',1x,a4,1x, + &'read from file',1x,i4) + call myexit + return + end +c +************************************************************************ +c + subroutine wcl(pp) +c subroutine to write out contents of a loop +c Written by Alex Dragt, 23 August 1988 +c Modified 19 June 1998 AJD +c Based on the subroutines cqlate and pmif +c + use beamdata + use acceldata + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' +c +c common blocks +c + include 'codes.inc' + include 'files.inc' + include 'loop.inc' + include 'core.inc' +c + dimension pp(6) +c +c local variables +c + character*8 string(5),str + logical ljof,ljodf +c +c set up control indices +c + iopt=nint(pp(1)) + ifile=nint(pp(2)) + isend=nint(pp(3)) +c +c start routine +c +c see if a loop exists + if(nloop.le.0) then + write(jof ,*) ' error from wcl: no loop has been specified' + write(jodf,*) ' error from wcl: no loop has been specified' + return + endif +c +c procedure when iopt=1 (write only names of loop contents +c at the terminal and/or file 12) + if (iopt.eq.1) then + ljof = isend.eq.1 .or. isend.eq.3 + ljodf = isend.eq.2 .or. isend.eq.3 + if (ljof .or. ljodf) then +c write loop name + if(ljof ) write(jof ,510) ilbl(nloop), joy + if(ljodf) write(jodf,510) ilbl(nloop), joy + 510 format(/,1h ,'contents of loop ',a8,';',i6,' items:') +c write loop contents + do 1 jtot=0,joy,5 + kmax=min(5,joy-jtot) + do 2 k=1,kmax + jk1=jtot+k +c element + if(mim(jk1).lt.0) then + string(k)=lmnlbl(-mim(jk1)) +c user supplied element + else if(mim(jk1).gt.5000) then + string(k)=lmnlbl(mim(jk1)-5000) +c lump + else + string(k)=ilbl(inuse(mim(jk1))) + endif + 2 continue + if(ljof) write(jof ,511)(string(k),k=1,kmax) + if(ljodf) write(jodf,511)(string(k),k=1,kmax) + 511 format(' ',5(1x,a8)) + 1 continue + endif + endif +c +c Procedure when iopt=2 (write out names of loop contents with & signs +c on file ifile. Each line is preceded by a blank space.) + if (iopt .eq. 2 .and. ifile .gt. 0) then +c write loop contents + do jtot=0,joy,5 + kmax=min(5,joy-jtot) + jcheck=joy-jtot + do k=1,kmax + jk1=jtot+k +c element + if(mim(jk1).lt.0) then + string(k)=lmnlbl(-mim(jk1)) +c user supplied element + else if(mim(jk1).gt.5000) then + string(k)=lmnlbl(mim(jk1)-5000) +c lump + else + string(k)=ilbl(inuse(mim(jk1))) + endif + end do + if (jcheck .gt. 5) write(ifile,612) (string(k),k=1,kmax) + if (jcheck .le. 5) write(ifile,613) (string(k),k=1,kmax) + 612 format(' ',' ',5(1x,a8),' &') + 613 format(' ',' ',5(1x,a8)) + end do + endif +c +c procedure when iopt=3 (write out names of loop contents +c with % and & signs on file ifile) + if (iopt .eq. 3 .and. ifile .gt. 0) then +c write loop contents + do jtot=0,joy,5 + kmax=min(5,joy-jtot) + jcheck=joy-jtot + do k=1,kmax + jk1=jtot+k +c element + if(mim(jk1).lt.0) then + string(k)=lmnlbl(-mim(jk1)) +c user supplied element + else if(mim(jk1).gt.5000) then + string(k)=lmnlbl(mim(jk1)-5000) +c lump + else + string(k)=ilbl(inuse(mim(jk1))) + endif + end do + if (jcheck .gt. 5) write(ifile,712) (string(k),k=1,kmax) + if (jcheck .eq. 5) write(ifile,713) (string(k),k=1,kmax) + if (jcheck .lt. 5 .and. kmax .gt. 0) then + write(ifile,714) (string(k),k=1,kmax) + endif + 712 format(' ',' ',5(1x,'% ',a8),' &') + 713 format(' ',' ',5(1x,'% ',a8),' %') + 714 format(' ',' ',5(1x,'% ',a8)) + end do + endif +c +c procedure when iopt=4 or iopt=5 (write out full loop contents) + if (ifile .gt. 0 .and. (iopt.eq.4 .or. iopt.eq.5)) then +c comments + write(ifile,530) ling(1) +c write loop name + write(ifile,512) ilbl(nloop) + 512 format(1h ,' contents of loop ',a8) +c beam + write(ifile,530) ling(2) + write(ifile,*) brho + write(ifile,*) gamm1 + write(ifile,*) achg + write(ifile,*) sl +c biglist heading + write(ifile,127) + 127 format(1h ,'#biglist') +c +c contents of biglist +c write loop contents + do 137 jk1=1,joy +c element + if(mim(jk1).lt.0) then + string(1)=lmnlbl(-mim(jk1)) +c user supplied element + else if(mim(jk1).gt.5000) then + string(1)=lmnlbl(mim(jk1)-5000) +c lump + else + string(1)=ilbl(inuse(mim(jk1))) + endif + call lookup(string(1),itype,item) +c write(6,513) string(1) +c 513 format(1x,a8) +c write(6,*) 'itype and item are ',itype, item +c procedure for a menu item + if(itype.eq.1) then + k=item +c case where iopt=4 + if (iopt.eq.4) then + write(ifile,600)lmnlbl(k),ltc(nt1(k),nt2(k)) + 600 format(1h ,1x,a8,1x,a8) + imax=nrp(nt1(k),nt2(k)) + if(imax.eq.0)goto 137 + write(ifile,603)(pmenu(i+mpp(k)),i=1,imax) +c 603 format((1h ,3(1x,d22.15))) +c Output using Mottershead's favorite pg format + 603 format((1h ,3(1x,1pg22.15))) + endif +c case where iopt=5 + if (iopt.eq.5) then + imax=nrp(nt1(k),nt2(k)) + write(ifile,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) + 605 format(1h ,1x,a8,1x,a8,1x,i5,1x,i5,1x,i5) + if(imax.eq.0)goto 137 + write(ifile,607)(pmenu(i+mpp(k)),i=1,imax) +c 607 format((1h ,3(1x,d22.15))) +c Output using Mottershead's favorite pg format + 607 format((1h ,3(1x,1pg22.15))) + endif + endif +c procedure for a lump + if(itype.eq.3) then +c case where iopt=4 + if (iopt .eq. 4) then + write(ifile,514) string(1) + 514 format(1x,1x,a8,1x,'lump') + endif +c case where iopt=5 + if (iopt .eq. 5) then + write(ifile,515) string(1),mim(jk1) + 515 format(1x,1x,a8,1x,'lump',9x,'0',4x,'-1',2x,i4) + endif + endif + 137 continue + endif +c + 530 format(1h ,a8) +c + return + end +c +************************************************************************ +c + subroutine whst(p) +c subroutine to write out history of beam loss +c Written by Alex Dragt, Fall 1986 + use rays + include 'impli.inc' + dimension p(6) + write(6,*)'THIS ROUTINE (WHST) NEEDS TO BE MODIFIED TO' + write(6,*)'EXECUTE PROPERLY IN PARALLEL' +c begin routine + ifile=nint(p(1)) + job=nint(p(2)) +c determine what job is to be done + if (job.eq.2) goto 200 +c procedure for writing out istat +c + do 5 k=1,nraysp + write (ifile,50) k, istat(k) + 50 format (1h ,i10,i10) + 5 continue + if(nraysp.gt.0)then + write(6,*)'istat written on file ',ifile,' for PE# ',idproc + endif + return +c +c procedure for writing out ihist +c + 200 continue + do 10 k=1,nlost + write (ifile,100) k, ihist(1,k), ihist(2,k) + 100 format (1h ,i10,i10,i10) + 10 continue + write(6,*) 'nlost =',nlost + if(nlost.eq.0) write(6,*) 'ihist not written out' + if(nlost.gt.0) write(6,*) 'ihist written on file ',ifile + return + end +c +*********************************************************************** +c + subroutine wps(ipset,isend) +c subroutine for writing out values in a parameter set +c Written by Alex Dragt, 30 January 1988 +c + include 'impli.inc' + include 'files.inc' + include 'parset.inc' +c +c Check to see that ipset is within range + if ((ipset.lt.1) .or. (ipset.gt.maxpst)) then + write (jof,*) 'WARNING: ipset out of range in command', + & ' with typecode wps' + return + endif +c +c Write out values of parameters +c + if ((isend.eq.1) .or. (isend.eq.3)) then + write (jof,*) 'values of parameters in the parameter set',ipset + write (jof,100)( pst(j,ipset), j=1,6) + endif + if ((isend.eq.2) .or. (isend.eq.3)) then + write (jodf,*) 'values of parameters in the parameter set',ipset + write (jodf,100)( pst(j,ipset), j=1,6) + endif + 100 format((1h ,3(1x,1pg22.15))) +c + return + end +c +c-------------- +c + subroutine getfirststring(line,m1,mlast,istart,iend,ierr) + implicit none + character*80 line + integer m1,mlast,istart,iend,ierr + integer m + ierr=0 + do m=m1,mlast + if(line(m:m).ne.' ')then + istart=m + goto 100 + endif + enddo + ierr=1 + return + 100 continue + do m=istart+1,mlast + if(line(m:m).eq.' ')then + iend=m-1 + return + endif + enddo + iend=80 + return + end +c +c-------------- +c + subroutine getscaleinfo(line,ubuf,scaleleni,scalefrqi,scalemomi, & + &jerr) + implicit none +c arguments: + character*80 line + character*16 ubuf + real*8 scaleleni,scalefrqi,scalemomi + integer jerr,iostat,numerr +c other variables: + real*8 bufr(1),value + character*80 string + integer m0,istart,iend,ierr +cryne!!!!!!!!!!!!!!!!!!!!!!!!!!!!!July 5, 2004 needs cleaning up!!! + ierr=0 +cryne!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +c units: + + m0=index(line,'units') + if(m0.ne.0)then + write(6,*)'found units' + m0=index(line,'=') + call getfirststring(line,m0+1,80,istart,iend,ierr) + if(ierr.eq.0)then +c write(6,*)'found istart,iend=',istart,iend +c write(6,*)'char value is ',line(istart:iend) + ubuf=line(istart:iend) + else + write(6,*)'error return from getfirststring' + jerr=1 + endif +c write(6,*)'character string following UNITS is: ',ubuf + goto 23 + endif +c scale length: + m0=index(line,'length') + if(m0.ne.0)then + write(6,*)'found scale_length' + m0=index(line,'=') + call getfirststring(line,m0+1,80,istart,iend,ierr) + if(ierr.eq.0)then +c write(6,*)'found istart,iend=',istart,iend +c write(6,*)'char value is ',line(istart:iend) + string=line(istart:iend) + else + write(6,*)'error return from getfirststring' + jerr=1 + endif + read(string,*,iostat=numerr)value + if(numerr.eq.0)then + bufr(1)=value + else + write(6,*)'ERROR reading SCALE LENGTH info' + endif + scaleleni=bufr(1) + write(6,*)'scale length in particle data file is ',scaleleni + goto 23 + endif +c scale frequency: + m0=index(line,'freq') + if(m0.ne.0)then + write(6,*)'found scale_frequency' + m0=index(line,'=') + call getfirststring(line,m0+1,80,istart,iend,ierr) + if(ierr.eq.0)then +c write(6,*)'found istart,iend=',istart,iend +c write(6,*)'char value is ',line(istart:iend) + string=line(istart:iend) + else + write(6,*)'error return from getfirststring' + jerr=1 + endif + read(string,*,iostat=numerr)value + if(numerr.eq.0)then + bufr(1)=value + else + write(6,*)'ERROR reading SCALE FREQENCY info' + endif + scalefrqi=bufr(1) + write(6,*)'scale freq in particle data file is ',scalefrqi + goto 23 + endif +c scale momentum: + m0=index(line,'momentum') + if(m0.ne.0)then + write(6,*)'found scale_momentum' + m0=index(line,'=') + call getfirststring(line,m0+1,80,istart,iend,ierr) + if(ierr.eq.0)then +c write(6,*)'found istart,iend=',istart,iend +c write(6,*)'char value is ',line(istart:iend) + string=line(istart:iend) + else + write(6,*)'error return from getfirststring' + jerr=1 + endif + read(string,*,iostat=numerr)value + if(numerr.eq.0)then + bufr(1)=value + else + write(6,*)'ERROR reading SCALE MOMENTUM info' + endif + scalemomi=bufr(1) + write(6,*)'scale momentum in input file is ',scalemomi + goto 23 + endif + 23 continue + jerr=ierr + return + end + +c\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +c============================================================================== +c////////////////////////////////////////////////////////////////////////////// + + subroutine wrtmap(iu,refinit,reffin,arclen,h,mh) +c------------------------------------------------------------------------------ +c +c wrtmap: writes a map to file, including the scale factors used to generate +c the map, the initial and final reference particle trajectories, the +c arclength of the map, and the matrix and non-linear parts of the +c map. Map is written in internal units, and the scale factors +c allow one to convert from these units to any other units by +c rescaling. Also, only the non-zero components of the map are +c written to file. +c +c input: +c iu : file unit number +c refinit : initial reference trajectory +c reffin : final reference trajectory +c arclen : length of map element +c h : non-linear part of map +c mh : linear (matrix) part of map +c +c misc: +c scale factors for length, momentum, and frequency are stored in the +c beamdata module found in 'afro_mod.f90' +c +c KMP - 9 Nov 2006 +c------------------------------------------------------------------------------ + use parallel, only : idproc + use lieaparam, only : monoms + use beamdata, only : sl,p0sc,freqscl + implicit none + double precision arclen,refinit(6),reffin(6),mh(6,6),h(monoms) + integer i,j,iu +c +c +c Begin Map File delimiter: + write(iu,'(a)') '#BeginMap' +c +c Scale Factors: + write(iu,100) '#ScaleLen=',sl + write(iu,100) '#ScaleMom=',p0sc + write(iu,100) '#ScaleFrq=',freqscl + 100 format(A10,1X,ES21.13E3) +c +c Arc Length of Map Element: + write(iu,150) '#ArcLen=',arclen + 150 format(A8,1X,ES21.13E3) + write(iu,160) '#Monoms=',monoms + 160 format(A8,1X,I8) +c +c Initial/Final Reference Trajectory: + write(iu,200) '#InitialRefTraj=',refinit + write(iu,200) '#FinalRefTraj= ',reffin + 200 format(A16,6(1X,ES21.13E3)) +c +c Matrix/Linear part of Transfer Map: + do i=1,6 + do j=1,6 + if(abs(mh(i,j)).gt.0.)then + write(iu,300) i,j,mh(i,j) + 300 format(I1,1X,I1,1X,ES21.13E3) + endif + enddo + enddo +c +c Non-linear part of Transfer Map (output 'monoms' in case it changes at some point) + do i=28,monoms + if(abs(h(i)).gt.0.)then + write(iu,400) i,h(i) + 400 format(I8,1X,ES21.13E3) + endif + enddo +c +c End Map File delimiter: + write(iu,'(a)') '#EndMap' +c +c Automatically flush write to file so map can be read and used immediately + call myflush(iu) + end + +c\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +c============================================================================== +c////////////////////////////////////////////////////////////////////////////// + + subroutine rdmap(iu,darc,dreftraj,h,mh) +c------------------------------------------------------------------------------ +c +c readmap: reads a map, or series of maps, from file, including the scale +c factors used to generate the map, the initial and final reference +c particle trajectories, the arclength of the map, and the matrix +c and non-linear parts of the map. The map is read in assuming +c internal units, and the scale factors allow one to convert from +c these units to any other units by rescaling. The map, once read, +c is immediately applied. +c +c input: +c iu : file unit number +c +c +c misc: +c scale factors for length, momentum, and frequency are stored in the +c beamdata module found in 'afro_mod.f90' +c +c KMP - 15 Dec 2006 +c------------------------------------------------------------------------------ + use parallel, only : idproc + use lieaparam, only : monoms + use beamdata, only : sl,p0sc,freqscl + implicit none + include 'map.inc' + double precision refinit(6),reffin(6),dreftraj(6) + double precision mh(6,6),h(monoms),mh2(6,6),h2(monoms) + double precision lsctmp,psctmp,fsctmp,darc + double precision d1,d2 + integer i,j,iu,monomstmp + character*160 cline + character*20 cword + character ch +c +c Read a line from the file + 100 read(iu,'(A160)',end=300) cline +c write(*,*) cline +c +c Look for #BeginMap delimiter + if(cline(1:9).eq.'#BeginMap')then + read(iu,*) cword, lsctmp + if(lsctmp.eq.0.0)then + write(*,*) 'ERROR (rdmap): length scale is zero!' + write(*,*) ' keeping current length scale' + lsctmp = sl + endif +c write(*,*) cword, lsctmp + read(iu,*) cword, psctmp + if(psctmp.eq.0.0)then + write(*,*) 'ERROR (rdmap): momentum scale is m*c' + write(*,*) ' keeping current momentum scale' + psctmp = p0sc + endif +c write(*,*) cword, psctmp + read(iu,*) cword, fsctmp + if(fsctmp.eq.0.0)then + write(*,*) 'ERROR (rdmap): frequency scale is zero!' + write(*,*) ' keeping current frequency scale' + fsctmp = freqscl + endif +c write(*,*) cword, fsctmp + read(iu,*) cword, darc +c write(*,*) cword, darc + read(iu,*) cword, monomstmp +c write(*,*) cword, monomstmp + if(monoms.ne.monomstmp)then + if(idproc.eq.0)then + write(*,*) 'WARNING (rdmap): Lie Algebraic order of ', + & 'map read from file is ',monomstmp,' but ' + write(*,*) ' the current order in the simulation ', + & 'is ',monoms,'.' + endif + endif + read(iu,*) cword, refinit +c write(*,*) cword, refinit +c +c Rescale initial reference trajectory + refinit(1) = refinit(1) * lsctmp / sl + refinit(2) = refinit(2) * psctmp / p0sc + refinit(3) = refinit(3) * lsctmp / sl + refinit(4) = refinit(4) * psctmp / p0sc + refinit(5) = refinit(5) * freqscl / fsctmp + refinit(6) = refinit(6) * (fsctmp*lsctmp*psctmp) + & / (freqscl*sl*p0sc) +c +c Compare initial and current reference trajectories + do i=1,6 + if(i.ne.5)then + d1 = reftraj(i) - refinit(i) + d2 = abs(reftraj(i)) + abs(refinit(i)) + if((d2.gt.0.0).and.(abs(d1).gt.0.05*d2))then + if(idproc.eq.0)then + write(*,*) 'WARNING (rdmap): Map reference trajectory ', + & 'coordinate',i,'differs from simulation ' + write(*,*) 'reference trajectory by greater than 10%!', + & ' Results could be inaccurate!' + endif + endif + endif + enddo + read(iu,*) cword, reffin +c write(*,*) cword, reffin +c Rescale final reference trajectory + reffin(1) = reffin(1) * lsctmp / sl + reffin(2) = reffin(2) * psctmp / p0sc + reffin(3) = reffin(3) * lsctmp / sl + reffin(4) = reffin(4) * psctmp / p0sc + reffin(5) = reffin(5) * freqscl / fsctmp + reffin(6) = reffin(6) * (fsctmp*lsctmp*psctmp) + & / (freqscl*sl*p0sc) +c +c Find change in reference trajectory + dreftraj = reffin - refinit +c +c Initialize map and read in non-zero coefficients + h = 0.0 + mh = 0.0 + 200 read(iu,'(A160)') cline +c write(*,*) '1: ',cline + if(cline(1:1).eq.'#')then + if(cline(1:7).eq.'#EndMap')goto 400 + else + read(cline,*) i +c write(*,*) '2: ',i + if(i.gt.6)then + read(cline,*) i,d1 +c write(*,*) '3: ',i,d1 + if(i.le.monoms)h(i) = d1 + else + read(cline,*) i,j,d1 +c write(*,*) '4: ',i,j,d1 + mh(i,j) = d1 + endif + endif + goto 200 + else + goto 100 + endif +c +c Error trapping: Only reaches here if no map found in file. + 300 continue + write(*,*) 'ERROR (rdmap): No map found in file. ', + & 'Returning the identity map.' + call ident(h,mh) + darc = 0.0 + dreftraj = 0.0 + return +c + 400 continue +c Scale map to with current scale factors + call rescale_map(lsctmp,psctmp,fsctmp,h,mh) +c +c Check return values: +! if(idproc.eq.0)then +! write(*,*) 'ERROR CHECKING:' +! write(*,*) 'darc = ',darc +! write(*,*) 'mh:' +! do i=1,6 +! write(*,*) ' ',(mh(i,j),j=1,6) +! enddo +! write(*,*) 'h:' +! do i=1,monoms +! if(h(i).ne.0.0)write(*,*) ' ',i,': ',h(i) +! enddo +! endif + return + end + diff --git a/OpticsJan2020/MLI_light_optics/Src/integ.f b/OpticsJan2020/MLI_light_optics/Src/integ.f new file mode 100644 index 0000000..0d0c8cf --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/integ.f @@ -0,0 +1,803 @@ +************************************************************************ +* header INTEGRATE (GENMAP for a general string of * +* magnets with soft fringe fields) * +* All routines needed for this special GENMAP * +************************************************************************ + subroutine integ(p,fa,fm) +c This is a subroutine for computing the map for a soft edged dipole +c magnet ( F. Neri 5/16/89 ). +c Interface to subroutine BONAX by P. Walstrom. +c Computes By (and derivatives on axis) for a sinPHI +c (Walstrom) steering magnet. 2/15/90. +c Eventually use GRONAX for m diff. from 1. +c Done (F. Neri 3/13/90). +c Generalized to arbitrary m, etc. 3/23/90, F. Neri +c Added type 8 (REC dipole sheets). +c Corrected sign problem. +c 11-19-90. +c Interface to CFQD F. Neri 5/8/91. +c Spacers, etc. F. Neri 6/28/91. +c Thick Halbach magnets. 6/28/91. +c +c included in ML/I +c + use lieaparam, only : monoms + use beamdata +cryneneriwalstrom include 'param.inc' + include 'impli.inc' + include 'parset.inc' + include 'hmflag.inc' + include 'combs.inc' +cryneneriwalstrom include 'parm.inc' + include 'files.inc' + include 'dip.inc' + include 'pie.inc' + include 'gronax.inc' + include 'multipole.inc' + include 'zz.inc' + include 'vecpot.inc' + include 'nnprint.inc' +c +c calling arrays + dimension p(6) + dimension fa(monoms), fm(6,6) +c +c local arrays + dimension ha(monoms), hm(6,6) + dimension pb(6) + dimension y(monoms+15) +c + real ttaa, ttbb +c +c use equivalence statement to make the various parameter sets pstj +c available as if they were in a two dimensional array +c +c +c y(1-6) = given (design) trajectory +c y(7-42) = matrix +c y(43-98) = f3 +c y(99-224) = f4 +c +c + zlength = xldr + ztotal +c + nops = nint(p(2)) + shflag = nint(p(3)) + ashield = p(4) + ns = nint(p(5)) + lun = nint(p(1)) + if (lun.gt.10) then + nnprint = 2*nint(p(6)) + endif + if ( nops .eq. 0 ) then +c write (6,*) ' CFQD option not implemented!!!' + call multcfq(zlength,fa,fm) + return + else if ( nops .lt. 0 ) then + call mulplt(zlength) +c write (6,*) ' PLOT option not implemented!!!' + return + endif + zi = 0.d0 + zf = zlength + h=(zf-zi)/float(ns) +c +c call VAX system routine for timing report +c + ttaa = secnds(0.0) +c +c initial values for design orbit (in dimensionless units) : +c + do 2 i = 1,6 + y(i) = 0.0d0 + 2 continue +c +c I really don't understand this! FN: +c Actually it just means that the design trajectory is +c ALWAYS on momentum. +c + y(6)=-1.d0/beta +c set constants + qbyp=1.d0/brho + ptg=-1.d0/beta +c +c initialize map to the identity map: +cryneneriwalstrom ne=224 + ne=monoms+15 + do 40 i=7,ne + 40 y(i)=0.d0 + do 50 i=1,6 + j=7*i + 50 y(j)=1.d0 +c +c do the computation: + t=zi + iflag = 3 +cryne 1 August 2004 fix later: +cryne call adam11(h,ns,'start',t,y) + nedummy=monoms+15 + call adam11(h,ns,'start',t,y,nedummy) + call errchk(y(7)) + call putmap(y,fa,fm) + s1 = -(y(2)-Ax(0)) + phi1 = dasin(s1) + phi1deg = phi1/pi180 +cx for test only the following lines are commented out: +c call prot(phi1deg,2,ha,hm) +c call concat(fa,fm,ha,hm,fa,fm) +c + write(jof,*) ' Final conditions in fixed reference frame!' + write(jodf,*) ' Final conditions in fixed reference frame!' +c + do 22 i = 1,6 + zfinal(i) = y(i) + 22 continue +c + write(jof , 999) (zfinal(i),i=1,6) + write(jodf, 999) (zfinal(i),i=1,6) + 999 format(' zf=',6e12.5) +c + write(jof , 991) phi1deg + write(jodf, 991) phi1deg +991 format(' Final angle is ',f16.8,' degrees') +c +c call VAX system routine for timing report +c + ttbb = secnds(ttaa) + write( jof,567) ttbb + write(jodf,567) ttbb + 567 format(' Integration time = ',f12.2,' sec.') +c call vecpot(Ax,Ay) +cryneneriwalstrom: added return statement + return + end +c +********************************************************************** + subroutine vecpot(Ax,Ay) + use lieaparam, only : monoms + use beamdata + include 'impli.inc' +cryneneriwalstrom include 'parm.inc' +cryneneriwalstrom include 'param.inc' + include 'files.inc' + double precision Ax(0:monoms), Ay(0:monoms) + do 1 i=1,monoms + if(Ax(i).ne. 0.d0) write(jodf,*) ' Ax(',i,')=',Ax(i) + if(Ay(i).ne. 0.d0) write(jodf,*) ' Ay(',i,')=',Ay(i) + 1 continue + return + end +c +********************************************************************** +c + subroutine gradients(z0) +c +c F. Neri +c Revised version 7/12/90. +c Corrected bug 8/6/90. +c Skew Multipoles 5/27/91. +c + include 'impli.inc' + include 'gronax.inc' + include 'multipole.inc' + include 'dip.inc' + integer ifirst,nderiv + logical initg + data ifirst/0/ + double precision bb(14) +c +cryne this looks like old code that is not needed here, +cryne so I am commenting it out +cryne data blprod/2.d0/,a1/0.75d0/,a2/1.d0/,xl/2.d0/,ss/1.d0/ +cryne data nmax/100/,kmax/100/ +c + save ifirst +c +c Initialization, if necessary: + if (ifirst .eq. 0 ) then + do 10 j=1, ncoil + initg = .false. + jtyp = itype(j) + if(jtyp.eq.3) initg = .true. + if(jtyp.eq.4) initg = .true. + if(jtyp.eq.6) initg = .true. + if(jtyp.eq.17) initg = .true. +cryneneriwalstrom if(initg) call onaxgr(0,0.d0,j,bb) + if(initg) call onaxgr(0,0.d0,j,nderiv,bb) + 10 continue + ifirst = 1 + endif +c +ctm plot net gradient in file 79 +c + gnet = 0.0d0 + do 1 j = 1, ncoil +c zz = z0 - zcoil(j) + zz = z0 - xldr +c write(6,*) j,z0,zz + call onaxgr(1,zz,j,11,bb) + gnet = gnet + bb(1) +c write(79,*) zz, bb(1) +c + if ( mcoil(j) .gt. 0 ) then + do 666 i= 0, 10 + gn(mcoil(j),i) = gn(mcoil(j),i) + bb(i+1)/float(mcoil(j)) + 666 continue + else + do 777 i= 0, 10 + gs(-mcoil(j),i) = gs(-mcoil(j),i) + bb(i+1)/float(-mcoil(j)) + 777 continue + endif +c +c write(6,*) ' z = ',zz, ' b =',bb(1) + 1 continue + write(79,*) zz,gnet + return + end +c +********************************************************************** +c + subroutine prenv(z,y) + include 'impli.inc' + include 'sigbuf.inc' + include 'nnprint.inc' + include 'gronax.inc' +c + dimension y(*) +c + save ncount, nf +c + if(ncount.eq.0) then + nf = 1 + xx(1) = xxin + ax(1) = axin + px(1) = pxin + yy(1) = yyin + ay(1) = ayin + py(1) = pyin + endif + ncount = ncount+1 + if (mod(ncount, nnprint).ne.0) return +c------------------- x plane ------------ + cfx = y(7) + sfx = y(13) + cpx = y(8) + spx = y(14) + txx = cfx**2 + tax = 2.0*cfx*sfx + tpx = sfx**2 + txa = cfx*cpx + taa = cfx*spx+sfx*cpx + tpa = sfx*spx + txp = cpx**2 + tap = 2.0*cpx*spx + tpp = spx**2 +c------------------- y plane ------------ + cfy = y(21) + sfy = y(27) + cpy = y(22) + spy = y(28) + ryy = cfy**2 + ray = 2.0*cfy*sfy + rpy = sfy**2 + rya = cfy*cpy + raa = cfy*spy+sfy*cpy + rpa = sfy*spy + ryp = cpy**2 + rap = 2.0*cpy*spy + rpp = spy**2 +c +c +c compute x-plane final beam ellipse +c + ni = 1 +c + nf = nf + 1 + zu = z +c + xs = xx(ni)**2 + xa = -xx(ni)*ax(ni)*px(ni)/sqrt(1.0d0 + ax(ni)**2) + xps = px(ni)**2 +c sigf1 = (cfx**2)*xs + 2.0*cfx*sfx*xa + (sfx**2)*xps +c sigf2 = cfx*cpx*xs + (cfx*spx+sfx*cpx)*xa + sfx*spx*xps +c sigf3 = (cpx**2)*xs + 2.0*cpx*spx*xa + (spx**2)*xps + sigf1 = txx*xs + tax*xa + tpx*xps + sigf2 = txa*xs + taa*xa + tpa*xps + sigf3 = txp*xs + tap*xa + tpp*xps + exsq = sigf1*sigf3 - sigf2**2 + if(exsq.le.0.0) exsq = 1.e-30 + ex = sqrt(exsq) + xx(nf) = sqrt(sigf1) + if(xx(nf).gt.xmax) then + xmax = xx(nf) + zxmax = zu + endif + if(xx(nf).gt.exmax) then + exmax = xx(nf) + zxm = zu + endif + if(xx(nf).lt.exmin) exmin = xx(nf) + px(nf) = sqrt(sigf3) + ax(nf) = -sigf2/ex +c +c compute y-plane beam ellipse +c + ys = yy(ni)**2 + ya = -yy(ni)*ay(ni)*py(ni)/sqrt(1.0d0 + ay(ni)**2) + yps = py(ni)**2 +c sigf4 = (cfy**2)*ys + 2.0*cfy*sfy*ya + (sfy**2)*yps +c sigf5 = cfy*cpy*ys + (cfy*spy+sfy*cpy)*ya + sfy*spy*yps +c sigf6 = (cpy**2)*ys + 2.0*cpy*spy*ya + (spy**2)*yps + sigf4 = ryy*ys + ray*ya + rpy*yps + sigf5 = rya*ys + raa*ya + rpa*yps + sigf6 = ryp*ys + rap*ya + rpp*yps + eysq = sigf4*sigf6 - sigf5**2 + if(eysq.le.0.0) eysq = 1.e-30 + ey = sqrt(eysq) + yy(nf) = sqrt(sigf4) + if(yy(nf).gt.ymax) then + ymax = yy(nf) + zymax = zu + endif + if(yy(nf).gt.eymax) then + eymax = yy(nf) + zym = zu + endif + if(yy(nf).lt.eymin) eymin = yy(nf) + py(nf) = sqrt(sigf6) + ay(nf) = -sigf5/ey +c + quadp = gn(2,0)*2. + octp = gn(4,0)*4. +c + if(lun.gt.0) write(lun,27) zu,xx(nf),px(nf),yy(nf),py(nf),ax(nf) + * ,ay(nf), quadp, octp + 27 format(f10.4,4(1pe11.4),4(1pe12.4)) + return + end +c +********************************************************************** +c + subroutine hmltn3(t,y,h) +c Originally written by F. Neri, 5/16/89. +c Modified 6/3/89 to handle different gauges. +c Modified 3/13/90 for arbitrary sin(m theta)+cos(m theta) +c magnets, as given in common block GRONAX. +c Interfaces to routine GRONAX by P. Walstrom. +c Modified again 3/23/90 for new input format. +c + use lieaparam, only : monoms + use beamdata +cryneneriwalstrom It appears that iplus is not used. Comment out later. +cryneneriwalstrom Need to set itop to whatever makes sense for this version +c +cryneneriwalstrom parameter (itop=209,iplus=224) + parameter (itop=923,iplus=itop+15) + include 'impli.inc' +cryneneriwalstrom include 'param.inc' +cryneneriwalstrom include 'parm.inc' + include 'dip.inc' + include 'bfield.inc' + include 'gronax.inc' + include 'multipole.inc' + include 'vecpot.inc' + include 'nnprint.inc' +c + dimension h(monoms),y(*) +c + dimension X(0:itop),YY(0:itop),P1(0:itop),P2(0:itop) + dimension P12(0:itop),P22(0:itop) + dimension A(0:12) + double precision bb(14) +c +c begin calculation +c +c compute gradients on axis: +c + do 10 i=0,10 + do 10 j=0,10 + gn(i,j) = 0.0d0 + gs(i,j) = 0.0d0 + 10 continue +c + zz = t +c write(6,*) zz +c call dbonax(1,a1,a2,xl,blprod,ss,nmax,kmax,ndriv,zz,bb) +c + call gradients(zz) +c +c print out envelopes, gradients, etc. + if(lun.gt.10) then + call prenv(zz,y) + endif +c +c initialization + do 11 i=1,monoms + 11 h(i)=0.d0 +c +c cccc +c Slow method to produce hamiltonian: use polynomial +c expansion of square root: when this method works we will use it to +c to check the "hardwired" version. +c cccc +c Coefficients of expansion of -SQRT(1+X)+1 + A(0) = 0.d0 + A(1) = -1.d0/2.d0 + do 50 i=2, 6 + A(i) = A(i-1) * (1.d0/2.d0 -(i-1.d0))/i + 50 continue +c + do 60 i=0,monoms + X(i) = 0.d0 + 60 continue + X(6) = -2.d0 / beta +c X(13) = -1.d0 +c X(22) = -1.d0 + X(27) = 1.d0 +c +cryneneriwalstrom maxord = 4 +cryneneriwalstrom nn = 4 + maxord = 6 + nn = 6 +c P1 = px -q Ax + do 101 i=0,monoms + Ax(i) = 0.d0 + Ay(i) = 0.d0 + Az(i) = 0.d0 + P2(i) = 0.d0 + 101 P1(i) = 0.d0 +c + q = 1.d0/brho + x0 = y(1) + y0 = y(3) +c +c write(6,*) ' x0=',x0,' y0=',y0 +c +c Mathematica generated block follows: +c include 'a3.fop' +c NEED A SWITCH HERE THAT SAYS, "IF(not an rf cavity)THEN + call a3(q,x0,y0) +c ELSE +c call rf cavity routines +c + cos2 = 1.d0 -(y(2) -Ax(0))**2 -(y(4)-Ay(0))**2 +c +c Note constant term in px -q Ax, coming from design orbit +c y(2) = Px = sin(phi) (initially). + P1(0) = y(2) + P1(2) = 1.d0 +c P12 = P1**2 + do 112 i=0,itop + 112 P1(i) = P1(i)-Ax(i) + call pmult(P1,P1,P12,maxord) +c + P2(0) = y(4) + P2(4) = 1.d0 + do 122 i=0,itop + 122 P2(i) = P2(i)-Ay(i) + call pmult(P2,P2,P22,maxord) +c +c Zeroth order term subtracted ( Sum starts at 1 ): +c Divide by cos2 + do 102 i=1,itop + 102 X(i) = (X(i)-P12(i)-P22(i))/cos2 +c X = pt**2 -2/beta*pt -(px -q Ax)**2 -(py -q Ay)**2 +c YY = -Sqrt(1+X) + call poly1(nn,A,X,YY,maxord) +c h = -Az + do 132 i=7, monoms + 132 h(i) = -Az(i) +c +c h = -Sqrt(1+X)-Az +c Zero and first order terms subtracted ( Sum starts at 7 ): +c Scale by cos + do 70 i=7, monoms + h(i) = h(i)+dsqrt(cos2)*YY(i)/sl + 70 continue + return + end +c +*********************************************************************** +c + subroutine poly1(N,A,X,Y,maxord) + include 'lims.inc' + parameter (MN=6) +cryne 7/23/2002 common /lims/bottom,top +cryne 7/23/3003 integer bottom(0:12),top(0:12) + double precision X(0:923),Y(0:923) + double precision A(0:N) + + double precision Vect(0:923,MN) + +c NO COMMENT + do 100 i=0,top(maxord) + 100 Y(i) = 0.0d0 + do 200 i=0,top(maxord) + 200 Vect(i,1) = X(i) + do 300 iord=2,N + call pmult(X,Vect(0,iord-1),Vect(0,iord),maxord) + 300 continue + Y(0) = A(0) + do 400 iord=1,N + do 500 i=0,top(maxord) + Y(i) = Y(i) + Vect(i,iord)*A(iord) + 500 continue + 400 continue + return + end +c + subroutine pmult(p1,p2,p3,maxord) + include 'lims.inc' + double precision p1(0:923),p2(0:923),p3(0:923) +c +cryne 7/23/2002 common /lims/bottom,top +cryne 7/23/3003 integer bottom(0:12),top(0:12) + if (maxord.lt.0) return +c + do 10 i=1,top(maxord) + 10 p3(i) = 0.0d0 + p3(0) = p1(0) * p2(0) + do 100 mord=1,maxord + call pmadd(p1(1),mord,p2(0),p3(1)) + call pmadd(p2(1),mord,p1(0),p3(1)) + do 200 nord1 = 1,mord-1 + nord2 = mord - nord1 + call product(p1(1),nord1,p2(1),nord2,p3(1)) + 200 continue + 100 continue + return + end +*********************************************************************** +c + subroutine nndrift(l,phideg,h,mh) +c +c Transverse entry drift. +c generates linear matrix mh and +c array h containing nonlinearities +c for the transfer map describing +c a drift section of length l meters, +c with the design trajectory at an angle of phideg degrees +c F. Neri 5/24/89 +c Actual code generated by Johannes Van Zeijts using +c REDUCE. +c + use lieaparam, only : monoms + use beamdata +c + include 'impli.inc' +cryneneriwalstrom include 'param.inc' +cryneneriwalstrom include 'parm.inc' + include 'pie.inc' + double precision l,h(monoms),mh(6,6) +c + double precision lsc + dimension j(6) +c + DOUBLE PRECISION UL + DOUBLE PRECISION UB + DOUBLE PRECISION CO + DOUBLE PRECISION Si + DIMENSION UDERS(923) + DOUBLE PRECISION UDERS + DOUBLE PRECISION T1 +c + call clear(h,mh) + lsc=l/sl +c + phi = phideg*pi180 + SI = SIN(phi) + CO = COS(phi) +c +c add drift terms to mh +c + do 40 k=1,6 + mh(k,k)=+1.0d0 + 40 continue + mh(1,2)=+lsc*(1.d0/CO+SI**2/CO**3) + mh(1,6)=+lsc*SI/(beta*CO**3) + mh(3,4)=+lsc*(1.d0/CO) + mh(5,2)=+lsc*SI/(beta*CO**3) + mh(5,6)=+lsc*(-1.d0/CO+1.d0/(beta**2*CO**3)) +c mh(5,6)=+(lsc/((gamma**2)*(beta**2))) +c +c add drift terms to h + UL = lsc + UB = beta +c + do 1 i=1,923 + UDERS(i) = 0.0d0 + 1 continue +c +c From: CINCOM::JOHANNES "Johannes van Zeijts" 23-MAY-1989 16:38 +c + UDERS(923) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7))+(-2.1875D0 + & ) * (UL / (UB ** 4 * CO ** 9))+1.3125D0 * (UL / (UB ** 6 + & * CO ** 11))+(-6.25D-02) * (UL / CO ** 5) + UDERS(910) = (-1.875D0) * (UL / (UB ** 2 * CO ** 7))+2.1875D0 + & * (UL / (UB ** 4 * CO ** 9))+0.1875D0 * (UL / CO ** 5) + UDERS(901) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7))+(-0.1875D0 + & ) * (UL / CO ** 5) + UDERS(896) = 6.25D-02 * (UL / CO ** 5) + UDERS(839) = 1.875D0 * ((UL * SI) / (UB * CO ** 7))+( + & -8.75D0) * ((UL * SI) / (UB ** 3 * CO ** 9))+7.875D0 * + & ((UL * SI) / (UB ** 5 * CO ** 11)) + UDERS(828) = (-3.75D0) * ((UL * SI) / (UB * CO ** 7))+ + & 8.75D0 * ((UL * SI) / (UB ** 3 * CO ** 9)) + UDERS(821) = 1.875D0 * ((UL * SI) / (UB * CO ** 7)) + UDERS(783) = (-1.875D0) * (UL / (UB ** 2 * CO ** 7))+2.1875D0 + & * (UL / (UB ** 4 * CO ** 9))+0.1875D0 * (UL / CO ** 5) + & +(-13.125D0) * ((UL * SI ** 2) / (UB ** 2 * CO ** 9))+ + & 19.6875D0 * ((UL * SI ** 2) / (UB ** 4 * CO ** 11))+ + & 0.9375D0 * ((UL * SI ** 2) / CO ** 7) + UDERS(774) = 1.875D0 * (UL / (UB ** 2 * CO ** 7))+(-0.375D0) + & * (UL / CO ** 5)+13.125D0 * ((UL * SI ** 2) / (UB ** 2 + & * CO ** 9))+(-1.875D0) * ((UL * SI ** 2) / CO ** 7) + UDERS(769) = 0.1875D0 * (UL / CO ** 5)+0.9375D0 * ((UL * SI + & ** 2) / CO ** 7) + UDERS(748) = (-3.75D0) * ((UL * SI) / (UB * CO ** 7))+ + & 8.75D0 * ((UL * SI) / (UB ** 3 * CO ** 9))+(-8.75D0) * + & ((UL * SI ** 3) / (UB * CO ** 9))+26.25D0 * ((UL * SI + & ** 3) / (UB ** 3 * CO ** 11)) + UDERS(741) = 3.75D0 * ((UL * SI) / (UB * CO ** 7))+8.75D0 * + & ((UL * SI ** 3) / (UB * CO ** 9)) + UDERS(728) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7))+(-0.1875D0 + & ) * (UL / CO ** 5)+13.125D0 * ((UL * SI ** 2) / (UB ** + & 2 * CO ** 9))+(-1.875D0) * ((UL * SI ** 2) / CO ** 7) + & +19.6875D0 * ((UL * SI ** 4) / (UB ** 2 * CO ** 11))+( + & -2.1875D0) * ((UL * SI ** 4) / CO ** 9) + UDERS(723) = 0.1875D0 * (UL / CO ** 5)+1.875D0 * ((UL * SI + & ** 2) / CO ** 7)+2.1875D0 * ((UL * SI ** 4) / CO ** 9 + & ) + UDERS(718) = 1.875D0 * ((UL * SI) / (UB * CO ** 7))+8.75D0 + & * ((UL * SI ** 3) / (UB * CO ** 9))+7.875D0 * ((UL * + & SI ** 5) / (UB * CO ** 11)) + UDERS(714) = 6.25D-02 * (UL / CO ** 5)+0.9375D0 * ((UL * SI + & ** 2) / CO ** 7)+2.1875D0 * ((UL * SI ** 4) / CO ** + & 9)+1.3125D0 * ((UL * SI ** 6) / CO ** 11) + UDERS(461) = 0.375D0 * (UL / (UB * CO ** 5))+(-1.25D0) * (UL + & / (UB ** 3 * CO ** 7))+0.875D0 * (UL / (UB ** 5 * CO ** + & 9)) + UDERS(450) = (-0.75D0) * (UL / (UB * CO ** 5))+1.25D0 * (UL / + & (UB ** 3 * CO ** 7)) + UDERS(443) = 0.375D0 * (UL / (UB * CO ** 5)) + UDERS(405) = (-3.75D0) * ((UL * SI) / (UB ** 2 * CO ** 7))+ + & 4.375D0 * ((UL * SI) / (UB ** 4 * CO ** 9))+0.375D0 * ( + & (UL * SI) / CO ** 5) + UDERS(396) = 3.75D0 * ((UL * SI) / (UB ** 2 * CO ** 7))+( + & -0.75D0) * ((UL * SI) / CO ** 5) + UDERS(391) = 0.375D0 * ((UL * SI) / CO ** 5) + UDERS(370) = (-0.75D0) * (UL / (UB * CO ** 5))+1.25D0 * (UL / + & (UB ** 3 * CO ** 7))+(-3.75D0) * ((UL * SI ** 2) / (UB + & * CO ** 7))+8.75D0 * ((UL * SI ** 2) / (UB ** 3 * CO + & ** 9)) + UDERS(363) = 0.75D0 * (UL / (UB * CO ** 5))+3.75D0 * ((UL * + & SI ** 2) / (UB * CO ** 7)) + UDERS(350) = 3.75D0 * ((UL * SI) / (UB ** 2 * CO ** 7))+( + & -0.75D0) * ((UL * SI) / CO ** 5)+8.75D0 * ((UL * SI + & ** 3) / (UB ** 2 * CO ** 9))+(-1.25D0) * ((UL * SI ** 3 + & ) / CO ** 7) + UDERS(345) = 0.75D0 * ((UL * SI) / CO ** 5)+1.25D0 * ((UL * + & SI ** 3) / CO ** 7) + UDERS(340) = 0.375D0 * (UL / (UB * CO ** 5))+3.75D0 * ((UL * + & SI ** 2) / (UB * CO ** 7))+4.375D0 * ((UL * SI ** 4) + & / (UB * CO ** 9)) + UDERS(336) = 0.375D0 * ((UL * SI) / CO ** 5)+1.25D0 * ((UL + & * SI ** 3) / CO ** 7)+0.875D0 * ((UL * SI ** 5) / + & CO ** 9) + UDERS(209) = (-0.75D0) * (UL / (UB ** 2 * CO ** 5))+0.625D0 * + & (UL / (UB ** 4 * CO ** 7))+0.125D0 * (UL / CO ** 3) + UDERS(200) = 0.75D0 * (UL / (UB ** 2 * CO ** 5))+(-0.25D0) * + & (UL / CO ** 3) + UDERS(195) = 0.125D0 * (UL / CO ** 3) + UDERS(174) = (-1.5D0) * ((UL * SI) / (UB * CO ** 5))+2.5D0 + & * ((UL * SI) / (UB ** 3 * CO ** 7)) + UDERS(167) = 1.5D0 * ((UL * SI) / (UB * CO ** 5)) + UDERS(154) = 0.75D0 * (UL / (UB ** 2 * CO ** 5))+(-0.25D0) * + & (UL / CO ** 3)+3.75D0 * ((UL * SI ** 2) / (UB ** 2 * + & CO ** 7))+(-0.75D0) * ((UL * SI ** 2) / CO ** 5) + UDERS(149) = 0.25D0 * (UL / CO ** 3)+0.75D0 * ((UL * SI ** + & 2) / CO ** 5) + UDERS(144) = 1.5D0 * ((UL * SI) / (UB * CO ** 5))+2.5D0 * ( + & (UL * SI ** 3) / (UB * CO ** 7)) + UDERS(140) = 0.125D0 * (UL / CO ** 3)+0.75D0 * ((UL * SI ** + & 2) / CO ** 5)+0.625D0 * ((UL * SI ** 4) / CO ** 7) + UDERS(83) = (-0.5D0) * (UL / (UB * CO ** 3))+0.5D0 * (UL / ( + & UB ** 3 * CO ** 5)) + UDERS(76) = 0.5D0 * (UL / (UB * CO ** 3)) + UDERS(63) = 1.5D0 * ((UL * SI) / (UB ** 2 * CO ** 5))+( + & -0.5D0) * ((UL * SI) / CO ** 3) + UDERS(58) = 0.5D0 * ((UL * SI) / CO ** 3) + UDERS(53) = 0.5D0 * (UL / (UB * CO ** 3))+1.5D0 * ((UL * SI + & ** 2) / (UB * CO ** 5)) + UDERS(49) = 0.5D0 * ((UL * SI) / CO ** 3)+0.5D0 * ((UL * + & SI ** 3) / CO ** 5) +c + do 2 i=1, monoms + h(i) = -UDERS(i) + 2 continue + return + end +c +*********************************************************************** +c + subroutine myprot(phideg,h,mh) +c +c High order PROT routine. +c Actual code generated by Johannes van Zeijts using +c REDUCE. +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' + double precision l,h(monoms),mh(6,6) +c + dimension j(6) +c + DOUBLE PRECISION B + DOUBLE PRECISION CO + DOUBLE PRECISION Si +c + call clear(h,mh) +c + B = beta + phi = phideg*pi180 + SI = SIN(phi) + CO = COS(phi) +c + mh(1,1)=1.0d0/CO + mh(2,2)=CO + mh(2,6)=(-SI)/B + mh(3,3)=1.0d0 + mh(4,4)=1.0d0 + mh(5,1)=SI/(B*CO) + mh(5,5)=1.0d0 + mh(6,6)=1.0d0 +c + h(34) =(-SI)/(2.0d0*CO) + h(43) =(-SI)/(2.0d0*CO) + h(48) =(SI*(B**2-1))/(2.0d0*B**2*CO) + h(105) =SI**2/(4.0d0*(SI**2-1)) + h(109) =(-SI)/(2.0d0*B*CO) + h(114) =SI**2/(4.0d0*(SI**2-1)) + h(119) =(SI**2*(-B**2+1))/(4.0d0*B**2*(SI**2-1)) + h(132) =(-SI)/(2.0d0*B*CO) + h(139) =(SI*(B**2-1))/(2.0d0*B**3*CO) + h(266) =SI/(8.0d0*CO*(SI**2-1)) + h(270) =SI**2/(2.0d0*B*(SI**2-1)) + h(275) =(SI*(-2.0d0*SI**2+3))/(12.0d0*CO*(SI**2-1)) + h(280) =(SI*(2.0d0*B**2*SI**2-3.0d0*B**2-8.0d0*SI**2+9))/( + & 12.0d0*B**2*CO*(SI**2-1)) + h(293) =SI**2/(2.0d0*B*(SI**2-1)) + h(300) =(SI**2*(-B**2+1))/(2.0d0*B**3*(SI**2-1)) + h(321) =(SI*(-4.0d0*SI**2+3))/(24.0d0*CO*(SI**2-1)) + h(326) =(SI*(4.0d0*B**2*SI**2-3.0d0*B**2-10.0d0*SI**2+9))/( + & 12.0d0*B**2*CO*(SI**2-1)) + h(335) =(SI*(-4.0d0*B**4*SI**2+3.0d0*B**4+20.0d0*B**2*SI**2- + & 18.0d0*B**2-16.0d0*SI**2+15))/(24.0d0*B**4*CO*(SI**2-1)) + h(588) =(SI**2*(SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+1)) + h(592) =(SI*(SI**2+6))/(16.0d0*B*CO*(SI**2-1)) + h(597) =(SI**2*(3.0d0*SI**2-4))/(16.0d0*(SI**4-2.0d0*SI**2+ + & 1)) + h(602) =(SI**2*(-3.0d0*B**2*SI**2+4.0d0*B**2+15.0d0*SI**2-16.0d0 + & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) + h(615) =(3.0d0*SI*(-SI**2+2))/(8.0d0*B*CO*(SI**2-1)) + h(622) =(SI*(3.0d0*B**2*SI**2-6.0d0*B**2-7.0d0*SI**2+10))/( + & 8.0d0*B**3*CO*(SI**2-1)) + h(643) =(SI**2*(5.0d0*SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+ + & 1)) + h(648) =(SI**2*(-5.0d0*B**2*SI**2+4.0d0*B**2+17.0d0*SI**2-16.0d0 + & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) + h(657) =(SI**2*(5.0d0*B**4*SI**2-4.0d0*B**4-34.0d0*B**2*SI**2 + & +32.0d0*B**2+29.0d0*SI**2-28))/(32.0d0*B**4*(SI**4-2.0d0*SI**2+ + & 1)) + h(695) =(SI*(-7.0d0*SI**2+6))/(16.0d0*B*CO*(SI**2-1)) + h(702) =(SI*(7.0d0*B**2*SI**2-6.0d0*B**2-11.0d0*SI**2+10))/( + & 8.0d0*B**3*CO*(SI**2-1)) + h(713) =(SI*(-7.0d0*B**4*SI**2+6.0d0*B**4+22.0d0*B**2*SI**2- + & 20.0d0*B**2-15.0d0*SI**2+14))/(16.0d0*B**5*CO*(SI**2-1)) +c + call revf(1,h,mh) +c + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/iron.f b/OpticsJan2020/MLI_light_optics/Src/iron.f new file mode 100644 index 0000000..be70550 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/iron.f @@ -0,0 +1,2264 @@ +c Changes made 6/04, especially to ImKmpak to eliminate +c single-double mismatches, etc. P. Walstrom +c This collection of subroutines is in the file IRON.for +c +c They are used in adding the equivalent iron shape function to +c magnets. Must also link in Bessel function package ImKmpak to +c do iron coils. +c CTM Bessel package ImKmpak included in this file for MaryLie use (4/99) +c 6/04- cleaned up package- passes ftnchek +c Subroutines in this package: +c subroutine fksegm(z1,z2,ai,k,fcos,fsin,nterm) +c subroutine firon(k,fsin,fcos) +c subroutine fderiv(k,fsin,fcos) +c subroutine filonin(xmin,xmax,y,nsteps,fname, +c subroutine weight(theta,alpha,beta,gamma) +c subroutine cubint(x1,x2,y1,y2,y1p,y2p,a1,a2,a3,a4) +c subroutine fbar11(xl,w1,w2,s1,s2,xbar) +c subroutine fk11(k,xl,w1,w2,s1,s2,fk,gk) +c subroutine divis(a,b,xl,w1,w2,s1,s2,xj,nj) +c function fkern(k) +c function aintgrl(a,a2,m) +c +c +c +c + function fkern(k) + implicit double precision(a-h,o-z) + double precision k + parameter(small=1.d-12) + common/stuff/ a,b,m +c Evaluates Fourier fkernel -K_m(kb) * I_m'(ka) / ( K_m'(kb) * I_m(kb)) +c This kernel when convoluted with the shape function gives the iron +c contribution to a winding of radius a with a cylinder of radius b. + dimension yia(3),yib(3),ykb(3) + bk=k*b + if(bk.gt.small) go to 1 +c small k value + fkern=1.d0 + if(m.lt.2) return + fkern=(a/b)**(m-1) + return + 1 continue + ml=m-1 + bk=b*k + ak=a*k + mm=m + if(bk.gt.1.d1) go to 2 +c Useunscaled Bessel functions + call bessin(3,ml,ak,yia,1) + call bessin(1,mm,bk,yib,1) + call besskn(3,ml,bk,ykb,1) +c derivatives of K and I + xkmp=-0.5d0*(ykb(1)+ykb(3)) + ximp=0.5d0*(yia(1)+yia(3)) + xnum=ykb(2)*ximp + fkern=-xnum/(xkmp*yib(1)) + return +c Usescaled Bessel functions + 2 continue + call bessin(3,ml,ak,yia,2) + call bessin(1,mm,bk,yib,2) + call besskn(3,ml,bk,ykb,2) +c derivatives of K and I + xkmp=-0.5d0*(ykb(1)+ykb(3)) + ximp=0.5d0*(yia(1)+yia(3)) + xnum=ykb(2)*ximp + fkern=-xnum/(xkmp*yib(1)) + fkern=fkern*dexp((a-b)*k) + return + end +c +c*********************************** +c + subroutine fksegm(z1,z2,ai,k,fcos,fsin,nterm) + implicit double precision(a-h,o-z) + real*8 k,k2 +c This subroutine evaluates +c +c fcos=1/pi * integral from z1 to z2 of f(x) * cos(k*x), and +c fsin=1/pi * integral from z1 to z2 of f(x) * sin(k*x) +c +c where f(x)= ai(1)+ai(2)*x+ai(3)*x^2+ai(4)*x^3+ai(5)*x^4 +c + parameter(pi=3.141592653589793d0) + parameter(smal=0.05d0) + parameter(c13=-1.d0/6.d0,c15=1.d0/1.2d2,c17=-1.d0/5.04d3, + &c19=1.d0/3.6288d5) + parameter(c22=0.5d0,c24=-0.125d0,c26=1.d0/1.44d2) + parameter(c28=-1.d0/5.76d3,c210=1.d0/4.03d5) + parameter(c33=1.d0/3.d0,c35=-0.1d0,c37=1.d0/1.68d2, + &c39=-1.d0/6.480d3) + parameter(c44=0.25d0,c46=-1.d0/1.2d1,c48=1.d0/1.92d2, + &c410=-1.d0/7.2d3) + parameter(c55=0.2d0,c57=-1.d0/1.4d1,c59=1.d0/2.16d2) + parameter(d12=0.5d0,d14=-1.d0/2.4d1,d16=1.d0/7.2d2, + &d18=-1.d0/4.032d4,d110=1.d0/3.6288d6) + parameter(d23=1.d0/3.d0,d25=-1.d0/3.d1,d27=1.d0/8.4d2, + &d29=-1.d0/4.536d4) + parameter(d34=0.25d0,d36=-1.d0/3.6d1,d38=1.d0/9.6d2, + &d310=-1.d0/5.04d4) + parameter(d45=0.2d0,d47=-1.d0/4.2d1,d49=1.d0/1.08d3) + parameter(d56=1.d0/6.d0,d58=-1.d0/4.8d1,d510=1.d0/1.2d3) + dimension ai(5) + if((nterm.gt.5).or.(nterm.lt.1)) go to 1001 + check=(z2-z1)*k + if(check.lt.smal) go to 50 +c k is not "small" + coskz1=dcos(k*z1) + coskz2=dcos(k*z2) + sinkz1=dsin(k*z1) + sinkz2=dsin(k*z2) + r=1.d0/k +c useidentity cos(k*z2)-cos(k*z1)=2 sin(k(z2+z1)/2) * sin(k(z1-z2)/2) to +c retain accuracy for small k. + fc1=2.d0*dsin(0.5d0*k*(z1+z2))*dsin(0.5d0*k*(z1-z2))*r + fs1=(sinkz2-sinkz1)*r + fcos=ai(1)*fs1 + fsin=-ai(1)*fc1 + if(nterm.lt.2) go to 40 + fc2=(z2*coskz2-z1*coskz1)*r + fs2=(z2*sinkz2-z1*sinkz1)*r + fcos=fcos+ai(2)*(fc1+k*fs2)*r + fsin=fsin+ai(2)*(fs1-k*fc2)*r + if(nterm.lt.3) go to 40 + z12=z1**2 + z22=z2**2 + r2=r**2 + fc3=(z22*coskz2-z12*coskz1)*r + fs3=(z22*sinkz2-z12*sinkz1)*r + fcos=fcos+ai(3)*(-2.d0*fs1+k*(2.d0*fc2+k*fs3))*r2 + fsin=fsin+ai(3)*(2.d0*fc1+k*(2.d0*fs2-k*fc3))*r2 + if(nterm.lt.4) go to 40 + z13=z1*z12 + z23=z2*z22 + r3=r*r2 + fc4=(z23*coskz2-z13*coskz1)*r + fs4=(z23*sinkz2-z13*sinkz1)*r + fsin=fsin+ai(4)*(-6.d0*fs1+k*(6.d0*fc2+k*(3.d0*fs3-k*fc4)))*r3 + fcos=fcos+ai(4)*(-6.d0*fc1+k*(-6.d0*fs2+k*(3.d0*fc3+k*fs4)))*r3 + if(nterm.lt.5) go to 40 + z14=z1*z13 + z24=z2*z23 + r4=r*r3 + fc5=(z24*coskz2-z14*coskz1)*r + fs5=(z24*sinkz2-z14*sinkz1)*r + fcos=fcos+ai(5)*(24.d0*fs1+k*(-24.d0*fc2+k*(-12.d0*fs3+ + &k*(4.d0*fc4+k*fs5))))*r4 + fsin=fsin+ai(5)*(-24.d0*fc1+k*(-24.d0*fs2+k*(12.d0*fc3+ + &k*(4.d0*fs4-k*fc5))))*r4 + 40 fcos=fcos/pi + fsin=fsin/pi + return +c small k limit +c Note- in deriving these, it is necessary to carry the expansions of +c sin(k*z1),sin(k*z2),cos(k*z1),cos(k*z2) to enough places that all +c of the coefficients in the expansions for integral of sinkx * x**n +c andintegral of coskx * x**n +c areof the form 1/m, where m is an integer. (See parameter statements). +c This means sin to x**11, cos to x**10. + 50 continue + fcos=fcos/pi + fsin=fsin/pi + k2=k**2 + z12=z1**2 + z13=z1*z12 + z14=z1*z13 + z15=z1*z14 + z16=z1*z15 + z17=z1*z16 + z18=z1*z17 + z22=z2**2 + z23=z2*z22 + z24=z2*z23 + z25=z2*z24 + z26=z2*z25 + z27=z2*z26 + z28=z2*z27 + z211=z2-z1 + z212=z211*(z2+z1) + z213=z211*(z22+z1*z2+z12) + z214=z212*(z22+z12) + z215=z211*(z24+z23*z1+z22*z12+z2*z13+z14) + z216=z213*(z23+z13) + z217=z211*(z26+z25*z1+z24*z12+z23*z13+z22*z14+z2*z15+z16) + z218=z214*(z24+z14) + z219=z211*(z28+z27*z1+z26*z12+z25*z13+z24*z14+z23*z15+z22*z16+ + &z2*z17+z18) + z2110=z215*(z25+z15) + fcos=ai(1)*(z211+k2*(c13*z213+k2*(c15*z215+k2*(c17*z217+ + &k2*c19*z219)))) + fsin=ai(1)*k*(d12*z212+k2*(d14*z214+k2*(d16*z216+k2*(d18*z218+ + &k2*d110*z2110)))) + if(nterm.lt.2) go to 11 + fcos=fcos+ai(2)*(c22*z212+k2*(c24*z214+k2*(c26*z216+k2*(c28*z218+ + &k2*c210*z2110)))) + fsin=fsin+ai(2)*k*(d23*z213+k2*(d25*z215+k2* + * (d27*z217+k2*d29*z219))) + if(nterm.lt.3) go to 11 + fcos=fcos+ai(3)*(c33*z213+k2*(c35*z215+k2*(c37*z217+k2*c39*z219))) + fsin=fsin+ai(3)*k*(d34*z214+k2*(d36*z216+k2* + * (d38*z218+k2*d310*z2110))) + if(nterm.lt.4) go to 11 + fcos=fcos+ai(4)*(c44*z214+k2*(c46*z216+k2*(c48*z218+ + &k2*c410*z2110))) + fsin=fsin+ai(4)*k*(d45*z215+k2*(d47*z217+k2*d49*z219)) + if(nterm.lt.5) go to 11 + fcos=fcos+ai(5)*(c55*z215+k2*(c57*z217+k2*c59*z219)) + fsin=fsin+ai(5)*k*(d56*z216+k2*(d58*z218+k2*d510*z2110)) + 11 continue + fcos=fcos/pi + fsin=fsin/pi + return + 1001 write(6,*) 'NTERM out of bounds in FKSEGM: NTERM=',nterm + stop + end +c +c*********************************** +c + subroutine firon(k,fsin,fcos) + implicit double precision(a-h,o-z) + real*8 k + common/geom1/xl,w1,w2,s1,s2 + common/stuff/a,b,m + call fk11(k,xl,w1,w2,s1,s2,fk,gk) + hk=fkern(k) + fsin=gk*hk + fcos=fk*hk + return + end +c +c*********************************** +c + subroutine fderiv(k,fsin,fcos) + implicit double precision(a-h,o-z) + real*8 k + common/geom1/xl,w1,w2,s1,s2 + common/stuff/a,b,m + call fk11(k,xl,w1,w2,s1,s2,fk,gk) + hk=fkern(k) + fsin=-k*fk*hk + fcos=k*gk*hk + return + end +c +c*********************************** +c + subroutine filonin(xmin,xmax,y,nsteps,fname,sinint,cosint) +c This version uses a subroutine with two functions in the EXTERNAL, +c instead of one function in a function subroutine (FILONINT). +c Different functions for sine and cosine integrals 6-28-96. + implicit double precision(a-h,o-z) + external fname +c Generic Filon integrator +c Method of Filon is used to evaluate the integrals from xmin to xmax +c of +c +c fsin(x) sin xy dx and +c +c fcos(x) cos xy dx +c +c Method of Filon allows evaluation of the integral of an oscillating +c function without having to follow every wiggle with many evaluation +c points. This version has only a single freqency, y. + parameter(half=0.5d0,one=1.d0,zero=0.d0) + dimension dsinint(3),dcosint(3) + h=(xmax-xmin)*half/dfloat(nsteps) +c find Filon weights + theta=h*y + call weight(theta,alf,bet,gam) +c write(20,200) theta,alf,bet,gam +c 200format(1x,4(1pd11.4,1x)) +c Zero intermediate arrays. + do 111 ievod=1,3 + dsinint(ievod)=zero + 111 dcosint(ievod)=zero +c nowperform Filon integration +c Step through odd, then x values. + do 2 ievod=1,2 +c ievod=1 ----- odd points +c ievod=2 -----even points +c ievod=3 ------endpoints + nstp=nsteps +c Extra x value in set of even points. + if(ievod.eq.2) nstp=nsteps+1 + do 2 n=1,nstp + if(ievod.eq.2) go to 3 +c oddpoints. + x=h*dfloat(2*n-1)+xmin + wt=one + go to 4 +c even points + 3 wt=one + if(n.eq.1) wt=half + if(n.eq.nstp) wt=half + x=h*dfloat(2*n-2)+xmin + 4 continue +ccccccf=wt*fname(x) + call fname(x,fsin,fcos) + fsin=fsin*wt + fcos=fcos*wt + xy=x*y + cosxy=dcos(xy) + sinxy=dsin(xy) + dsinint(ievod)=dsinint(ievod)+fsin*sinxy + 2 dcosint(ievod)=dcosint(ievod)+fcos*cosxy +c Nowdo end points-first, upper end (xk=xkmx) + x=xmax + wt=one + do 5 iend=1,2 + xy=y*x + cosxy=dcos(xy) + sinxy=dsin(xy) +ccccccc f=wt*fname(x) + call fname(x,fsin,fcos) + fsin=fsin*wt + fcos=fcos*wt + dsinint(3)=dsinint(3)-fsin*cosxy + dcosint(3)=dcosint(3)+fcos*sinxy + x=xmin + 5 wt=-one +c Nowsum up contributions from ievod=1,2,3 with Filon weights. + sinint=h*(alf*dsinint(3)+bet*dsinint(2)+gam*dsinint(1)) + cosint=h*(alf*dcosint(3)+bet*dcosint(2)+gam*dcosint(1)) + return + end +c +c*********************************** +c + subroutine weight(theta,alpha,beta,gamma) +c Subroutine to calculate weights for method of Filon (called by FILON) + implicit double precision(a-h,o-z) + parameter(a1=2.d0/4.5d1,a2=2.d0/3.15d2,a3=2.d0/4.725d3) + parameter(b1=2.d0/3.d0,b2=2.d0/1.5d1,b3=4.d0/1.05d2, + &b4=2.d0/5.67d2) + parameter(c1=4.d0/3.0d0,c2=2.d0/1.5d1,c3=1.d0/2.1d2, + &c4=1.d0/1.134d4) + parameter(two=2.d0,smal1=1.d-1,one=1.d0) + if(dabs(theta).gt.smal1) go to 11 + t2=theta**2 + t3=theta*t2 + alpha=t3*(a1-t2*(a2-t2*a3)) + beta=b1+t2*(b2-t2*(b3-t2*b4)) + gamma=c1-t2*(c2-t2*(c3-t2*c4)) + return + 11 sinth=dsin(theta) + costh=dcos(theta) + onoth=one/theta + tuoth2=two*onoth**2 + beta=tuoth2*(one+costh*(costh-two*sinth*onoth)) + gamma=two*tuoth2*(sinth*onoth-costh) + alpha=onoth*(one+onoth*sinth*(costh-two*sinth*onoth)) + return + end +c +c*********************************** +c + subroutine cubint(x1,x2,y1,y2,y1p,y2p,a1,a2,a3,a4) + implicit double precision(a-h,o-z) + h=x2-x1 + a=y1 + b=y1p + c=(3.d0*(y2-y1-y1p*h)-h*(y2p-y1p))/h**2 + d=((y2p-y1p)*h-2.d0*(y2-y1-y1p*h))/h**3 + a1=a-x1*(b-x1*(c-x1*d)) + a2=b-x1*(2.d0*c-x1*3.d0*d) + a3=c-3.d0*x1*d + a4=d + return + end +c +c*********************************** +c + subroutine fbar11(xl,w1,w2,s1,s2,xbar) + implicit double precision(a-h,o-z) + parameter(third=1.d0/3.d0,sixth=1.d0/6.d0) + parameter(fifteenth=1.d0/1.5d1,eight15th=8.d0/1.5d1) + parameter(small=1.d-9) +c xl=coil length +c w1=width of the curved section from -xl/2 to the flattop. +c w2=width of the curved section from the flattop to xl/2. +c s1=LH slope*w1 +c s2=-RH slope*w2 +c +c Output variables: +c dg=vector with ndriv components containing the on-axis gradient, and +c its ndriv-1 derivatives. +c +c Shape function has form +c +c f(x)=1+A1(x+xl/2-w1)**2 + B1*(x+xl/2-w1)**4 -xl/2xl in GTYPE11-stopped') + stop + end +c +c*********************************** +c + subroutine fk11(k,xl,w1,w2,s1,s2,fk,gk) + implicit double precision(a-h,o-z) + real*8 k +c Modified 7-11 to use shifted form for better accuracy. +c Calculates cosine and sine transforms of type 11 shape function, +c Coil is centered in coordinate system. +c x=0at center of windings- i.e., LH end is at -xl/2, RH end at xl/2. +c +c Inputs: +c k=inverse-distance independent variable of transforms. (f(k),g(k)). +c xl=coil length +c w1=width of the curved section from -xl/2 to the flattop. +c w2=width of the curved section from the flattop to xl/2. +c s1=w1* slope at -xl/2 +c s2=-w2*slope at +xl/2 +c +c Outputs: +c +c fk=f(k)= cosine transform = 1/pi*integral from -xl/2 to xl/2 +c of f(x) * cos(k*x) dx +c gk=g(k)= sine transform = 1/pi*integral from -xl/2 to xl/2 +c of f(x) * sin(k*x) dx + parameter(fifteenth=1.d0/1.5d1,eight15th=8.d0/1.5d1) + parameter(small=1.d-9) + dimension ai(5) +c +c +c Shape function has form +c +c f(x)=1+A1(x+xl/2-w1)**2 + B1*(x+xl/2-w1)**4 -xl/2xl in FK11-stopped') + stop + end +c +c*********************************** +c + subroutine divis(a,b,xl,w1,w2,s1,s2,xj,nj) + implicit double precision(a-h,o-z) + dimension xj(101) + cwidth=xl-w1-w2 + hfw1=0.5d0*w1 + hfw2=0.5d0*w2 + hfl=0.5d0*xl + ratio=b/a + if(ratio.lt.1.1d0) go to 1001 + if(ratio.ge.1.3d0) go to 1 + t=2.d0*(b-a) + xj(1)=-hfl-3.d0*b + xj(2)=-hfl-b + xj(3)=-hfl-0.50d0*b + nl=3 + xj(nl+1)=-hfl-t + xj(nl+2)=-hfl + if(w1.lt.(4.d0*t)) go to 3 + if(w1.ge.(0.5d0*a)) go to 21 + xj(nl+3)=-hfl+t + xj(nl+4)=-hfl+hfw1 + xj(nl+5)=-hfl+w1-t + xj(nl+6)=-hfl+w1 + nw1=nl+6 + go to 4 + 21 xj(nl+3)=-hfl+t + xj(nl+4)=-hfl+0.25d0*w1 + xj(nl+5)=-hfl+hfw1 + xj(nl+6)=-hfl+0.75d0*w1 + xj(nl+7)=-hfl+w1-t + xj(nl+8)=-hfl+w1 + nw1=nl+8 + go to 4 + 3 xj(nl+3)=-hfl+hfw1 + xj(nl+4)=-hfl+w1 + nw1=nl+4 + 4 if(cwidth.lt.(4.d0*t)) go to 5 + if(cwidth.gt.a) go to 9 + xj(nw1+1)=-hfl+w1+t + xj(nw1+2)=hfw1-hfw2 + xj(nw1+3)=hfl-w2-t + xj(nw1+4)=hfl-w2 + nww=nw1+4 + go to 6 + 9 if(cwidth.gt.(4.d0*a)) go to 11 + xj(nw1+1)=-hfl+w1+t + xj(nw1+2)=-hfl+0.5d0*a+w1 + xj(nw1+3)=hfw1-hfw2 + xj(nw1+4)=hfl-0.5d0*a-w2 + xj(nw1+5)=hfl-w2-t + xj(nw1+6)=hfl-w2 + nww=nw1+6 + go to 6 + 11 if(cwidth.gt.(6.d0*a)) go to 25 + xj(nw1+1)=-hfl+w1+t + xj(nw1+2)=-hfl+w1+0.5d0*a + xj(nw1+3)=-hfl+w1+a + xj(nw1+4)=hfw1-hfw2 + xj(nw1+5)=hfl-w2-a + xj(nw1+6)=hfl-w2-0.5d0*a + xj(nw1+7)=hfl-w2-t + xj(nw1+8)=hfl-w2 + nww=nw1+8 + go to 6 + 25 xj(nw1+1)=-hfl+w1+t + xj(nw1+2)=-hfl+w1+0.5d0*a + xj(nw1+3)=-hfl+w1+a + xj(nw1+4)=-hfl+w1+0.25d0*cwidth + xj(nw1+5)=hfw1-hfw2 + xj(nw1+6)=hfl-w2-0.25d0*cwidth + xj(nw1+7)=hfl-w2-a + xj(nw1+8)=hfl-w2-0.5d0*a + xj(nw1+9)=hfl-w2-t + xj(nw1+10)=hfl-w2 + nww=nw1+10 + go to 6 + 5 xj(nw1+1)=-hfl+w1+0.2d0*cwidth + xj(nw1+2)=hfw1-hfw2 + xj(nw1+3)=hfl-w2-0.2d0*cwidth + xj(nw1+4)=hfl-w2 + nww=nw1+4 + 6 if(w2.lt.(4.d0*t)) go to 7 + if(w2.ge.0.5d0*a) go to 22 + xj(nww+1)=hfl-w2+t + xj(nww+2)=hfl-hfw2 + xj(nww+3)=hfl-t + xj(nww+4)=hfl + nw2=nww+4 + go to 8 + 22 xj(nww+1)=hfl-w2+t + xj(nww+2)=hfl-0.75d0*w2 + xj(nww+3)=hfl-hfw2 + xj(nww+4)=hfl-0.25d0*w2 + xj(nww+5)=hfl-t + xj(nww+6)=hfl + nw2=nww+6 + go to 8 + 7 xj(nww+1)=hfl-hfw2 + xj(nww+2)=hfl + nw2=nww+2 + 8 xj(nw2+1)=hfl+t + xj(nw2+2)=hfl+0.5d0*b + nr=nw2+2 + 16 xj(nr+1)=hfl+b + xj(nr+2)=hfl+3.d0*b + nj=nr+2 + return +c************************************************************************* +c +c r/a> or equal 1.3 + 1 if(ratio.ge.1.5d0) go to 2 + xj(1)=-hfl-3.d0*b + xj(2)=-hfl-b + xj(3)=-hfl-0.50d0*b + xj(4)=-hfl-0.25d0*b + xj(5)=-hfl + nl=5 + if(w1.ge.(0.5d0*a)) go to 31 + xj(nl+1)=-hfl+hfw1 + xj(nl+2)=-hfl+w1 + nw1=nl+2 + go to 34 + 31 xj(nl+1)=-hfl+0.25d0*w1 + xj(nl+2)=-hfl+hfw1 + xj(nl+3)=-hfl+0.75d0*w1 + xj(nl+4)=-hfl+w1 + nw1=nl+4 + 34 if(cwidth.gt.(2.d0*a)) go to 39 + xj(nw1+1)=hfw1-hfw2 + xj(nw1+2)=hfl-w2 + nww=nw1+2 + go to 36 + 39 if(cwidth.gt.(4.d0*a)) go to 41 + xj(nw1+1)=-hfl+0.5d0*a+w1 + xj(nw1+2)=hfw1-hfw2 + xj(nw1+3)=hfl-0.5d0*a-w2 + xj(nw1+4)=hfl-w2 + nww=nw1+4 + go to 36 + 41 if(cwidth.gt.(6.d0*a)) go to 45 + xj(nw1+1)=-hfl+w1+0.5d0*a + xj(nw1+2)=-hfl+w1+a + xj(nw1+3)=hfw1-hfw2 + xj(nw1+4)=hfl-w2-a + xj(nw1+5)=hfl-w2-0.5d0*a + xj(nw1+6)=hfl-w2 + nww=nw1+6 + go to 36 + 45 xj(nw1+1)=-hfl+w1+0.5d0*a + xj(nw1+2)=-hfl+w1+a + xj(nw1+3)=-hfl+w1+0.25d0*cwidth + xj(nw1+4)=hfw1-hfw2 + xj(nw1+5)=hfl-w2-0.25d0*cwidth + xj(nw1+6)=hfl-w2-a + xj(nw1+7)=hfl-w2-0.5d0*a + xj(nw1+8)=hfl-w2 + nww=nw1+8 + 36 if(w2.ge.0.5d0*a) go to 42 + xj(nww+1)=hfl-hfw2 + xj(nww+2)=hfl + nw2=nww+2 + go to 38 + 42 xj(nww+1)=hfl-0.75d0*w2 + xj(nww+2)=hfl-hfw2 + xj(nww+3)=hfl-0.25d0*w2 + xj(nww+4)=hfl + nw2=nww+4 + 38 xj(nw2+1)=hfl+0.25d0*b + xj(nw2+2)=hfl+0.5d0*b + xj(nw2+3)=hfl+b + xj(nw2+4)=hfl+3.d0*b + nj=nw2+4 + return +c************************************************************************* +c +c r/a> or equal 1.5 + 2 continue +c To left of windings + xj(1)=-hfl-3.d0*b + xj(2)=-hfl-2.d0*b + xj(3)=-hfl-b + xj(4)=-hfl-0.50d0*b + xj(5)=-hfl-0.25d0*b + xj(6)=-hfl + nl=6 +c LH curved section, w1 in width. + if(w1.ge.(0.5d0*b)) go to 51 + xj(nl+1)=-hfl+hfw1 + xj(nl+2)=-hfl+w1 + nw1=nl+2 + go to 54 + 51 xj(nl+1)=-hfl+0.25d0*w1 + xj(nl+2)=-hfl+hfw1 + xj(nl+3)=-hfl+0.75d0*w1 + xj(nl+4)=-hfl+w1 + nw1=nl+4 +c Central flattop + 54 if(cwidth.ge.(2.d0*b)) go to 59 + xj(nw1+1)=-hfl+w1+0.25d0*cwidth + xj(nw1+2)=hfw1-hfw2 + xj(nw1+3)=hfl-w2-0.25d0*cwidth + xj(nw1+4)=hfl-w2 + nww=nw1+4 + go to 56 + 59 if(cwidth.gt.(4.d0*b)) go to 52 + xj(nw1+1)=-hfl+0.5d0*b+w1 + xj(nw1+2)=hfw1-hfw2 + xj(nw1+3)=hfl-0.5d0*b-w2 + xj(nw1+4)=hfl-w2 + nww=nw1+4 + go to 56 + 52 if(cwidth.gt.(6.d0*b)) go to 55 + xj(nw1+1)=-hfl+w1+0.5d0*b + xj(nw1+2)=-hfl+w1+b + xj(nw1+3)=hfw1-hfw2 + xj(nw1+4)=hfl-w2-b + xj(nw1+5)=hfl-w2-0.5d0*b + xj(nw1+6)=hfl-w2 + nww=nw1+6 + go to 56 + 55 xj(nw1+1)=-hfl+w1+0.5d0*b + xj(nw1+2)=-hfl+w1+b + xj(nw1+3)=-hfl+w1+0.25d0*cwidth + xj(nw1+4)=hfw1-hfw2 + xj(nw1+5)=hfl-w2-0.25d0*cwidth + xj(nw1+6)=hfl-w2-b + xj(nw1+7)=hfl-w2-0.5d0*b + xj(nw1+8)=hfl-w2 + nww=nw1+8 +c RH curved section, w2 in width. + 56 if(w2.ge.0.5d0*b) go to 57 + xj(nww+1)=hfl-hfw2 + xj(nww+2)=hfl + nw2=nww+2 + go to 58 + 57 xj(nww+1)=hfl-0.75d0*w2 + xj(nww+2)=hfl-hfw2 + xj(nww+3)=hfl-0.25d0*w2 + xj(nww+4)=hfl + nw2=nww+4 +c To right of windings. + 58 xj(nw2+1)=hfl+0.25d0*b + xj(nw2+2)=hfl+0.5d0*b + xj(nw2+3)=hfl+b + xj(nw2+4)=hfl+2.d0*b + xj(nw2+5)=hfl+3.d0*b + nj=nw2+5 + return + 1001 write(6,*) 'b/a=',ratio,' <1.1 in DIVIS- stopped' + stop + end +c +c*********************************** +c + function aintgrl(a,a2,m) + implicit double precision(a-h,o-z) +c calculates integral from a to a2 of dx/x**(m-1) +c m> or equal 1. + if(m.gt.1) go to 1 +c m=1 + aintgrl=a2-a + return + 1 if(m.gt.2) go to 2 +c m=2 + aintgrl=dlog(a2/a) + return + 2 aintgrl=(a2**(2-m)-a**(2-m))/dfloat(2-m) + return + end +c +c*********************************** +c + subroutine fitlength(Leff,a1i,a2i,a3i,a4i,xi,ni) + implicit double precision(a-h,o-z) + double precision Leff +c Calculates Leff=integral for xi(1) to xi(ni) of a Piecewise-Continuous +c Polynomial of maximum degree 3 (=cubic). The PCP is assumed to be zero +c outside of [xi(1),xi(ni)] +c ThePCP is of the form a1i(i)+a2i(i)*x+a3i(i)*x**2+a4i(i)*x**3 +c Inputs: +c +c a1i,a2i,a3i,a4i are arrays with ni-1 nonzero components (sometimes +c more are nonzero) +c xi is an array of length ni containing the endpoints of the ni-1 +c intervals on which the PCP is defined. +c ni is the number of node points specifying the intervals for the PCP. +c +c Output: Leff +c + parameter(third=1.d0/3.d0) + dimension a1i(ni),a2i(ni),a3i(ni),a4i(ni),xi(ni) + Leff=0.d0 + do 1 i=1,ni-1 + x1=xi(i) + x2=xi(i+1) + Leff=Leff+x2*(a1i(i)+x2*(0.5d0*a2i(i)+x2*(third*a3i(i)+ + &x2*0.25d0*a4i(i))))- + &x1*(a1i(i)+x1*(0.5d0*a2i(i)+x1*(third*a3i(i)+x1*0.25d0*a4i(i)))) + 1 continue + return + end +c +c*********************************** +c + subroutine BESSIn(M,N,X,y,KODE) +c ImKmpak is a collection of portable modified Bessel function routines. +c Written 4-96 by P. L. Walstrom Northrop Grumman +c Modified from CLAMS and Numerical Recipes. Should give 12-digit +c precision for all valid arguments. +c Should use exponentially scaled functions when x is greater than 20. +c Function routines: +c dbesI0s=I0 +c dbesI0es=exponentially scaled I0 +c dbesK0s=K0 +c dbesK0es=exponentially scaled K0 +c dbesI1s=I1 +c dbesI1es=exponentially scaled I1 +c dbesK1s=K1 +c dbesK1es=exponentially scaled K1 +c Subroutines: +c +c BESSIn( M,N,x,y,KODE) +c computes a M-member sequence I_k(x), k=N, N+1, N+2 ... N+M-1. +c KODE=1 means unscaled, KODE=2 is exponentially scaled. Results in vector +c y,with y(1)=I_N, y(2)=I_N+1, etc. +c +c +c bessKn( M,N,x,y,KODE) +c computes a M-member sequence K_k(x), k=N, N+1, N+2 ... N+M-1. +c KODE=1 means unscaled, KODE=2 is exponentially scaled. Results in vector +c y,with y(1)=K_N, y(2)=K_N+1, etc. +c +c +c Exponential scaling means for the I_m +c +c I_m(x) scaled = exp(-x) * I_m (x) unscaled +c +c andfor the K_m +c +c K_m(x) scaled = exp(x) * K_m (x) unscaled +c +c******************************************************************* + implicit double precision(a-h,o-z) +c Calculates an M-member sequence of modified Bessel functions of the +c first kind. Needs subroutines for exponentially scaled and unscaled +c I_0(x). Sequence contains either unscaled or scaled Bessel functions. +c KODE=1 means unscaled. +c KODE=2 means scaled. +c y(k), k=1,2,..m contains I_N (x),I_N+1 (x),...I_N+M-1 (x) +c N must be > or = 0. + PARAMETER(IACC=40,BIGNO=1.0d10,BIGNI=1.0d-10) + parameter(mmax=1000) + dimension y(m),z(mmax) +C + if(m.gt.20) go to 1005 + if(dabs(x).gt.0.1d0) go to 44 + if(dabs(x).ne.0.d0) go to 23 + do 24 l=1,m + if(n.eq.0) y(1)=1.d0 + 24 y(l)=0.d0 + return + 23 continue +c Series expansion for I_n, I_n+1, ...I_n+m-1. + if(m.gt.mmax) go to 1001 + qx2=0.25d0*x**2 + hfx=0.5d0*x +c Find 1/n! and (x/2)**n. + rnfac=1.d0 + hfxn=1.d0 + if(n.gt.0) hfxn=hfx + if(n.lt.2) go to 1 + do 2 l=2,n + hfxn=hfxn*hfx + 2 rnfac=rnfac/dfloat(l) + 1 y(1)=rnfac +c find 1/ (n+l)!, l=0,1,2...m-1. +c store in z(1),z(2)...z(m) + z(1)=rnfac + if(m.lt.2) go to 6 + do 3 l=2,m + z(l)=z(l-1)/dfloat(l+n-1) + 3 y(l)=z(l) + 6 yy=1.d0 + do 5 k=1,4 + yy=yy*qx2/dfloat(k) + do 5 l=1,m + z(l)=z(l)/dfloat(l+k+n-1) + 5 y(l)=y(l)+yy*z(l) + y(1)=y(1)*hfxn + if(m.lt.2) go to 9 + yy=hfxn + do 10 l=2,m + yy=yy*hfx + 10 y(l)=y(l)*yy + 9 continue + if(kode.eq.1) return +c convert vector of I_n, I_n+1...I_n+m-1 to exponentially scaled values + zz=dexp(-dabs(x)) + do 45 l=1,m + 45 y(l)=zz*y(l) + return +c Larger x- use downwards recursion + 44 n2=n+m-1 +cryne IF (N.LT.0) PAUSE 'bad argument N < 0 in BESSIn' + IF (N.LT.0) write(6,*) 'bad argument N < 0 in BESSIn' + if(dabs(x).gt.dfloat(2*n2)) go to 60 + TOX=2.d0/X + BIP=0.d0 + BI=1.d0 + do 21 k=1,m + 21 y(k)=0.d0 + MAX=2*((N2+dINT(dSQRT(dFLOAT(IACC*N2))))) + DO 11 J=MAX,1,-1 + BIM=BIP+dFLOAT(J)*TOX*BI + BIP=BI + BI=BIM +c Rescale large numbers + IF (dABS(BI).GT.BIGNO) THEN + BI=BI*BIGNI + BIP=BIP*BIGNI + jmax=N2 + jmin=j+1 + if(jmin.gt.jmax) go to 22 + jdif=n2-j + if(jdif.gt.m) go to 17 + do 13 jj=jmin,jmax + k=jj-jmax+m + 13 y(k)=y(k)*bigni + go to 22 + 17 do 18 k=1,m + 18 y(k)=y(k)*bigni + 22 continue + ENDIF +c Rescale small numbers. + IF (dABS(BI).lT.BIGNI) THEN + BI=BI*BIGNO + BIP=BIP*BIGNO + jmax=N2 + jmin=j+1 + if(jmin.gt.jmax) go to 25 + jdif=n2-j + if(jdif.gt.m) go to 19 + do 16 jj=jmin,jmax + k=jj-jmax+m + 16 y(k)=y(k)*bigno + go to 25 + 19 do 20 k=1,m + 20 y(k)=y(k)*bigno + 25 continue + ENDIF + do 14 k=1,m + ncheck=k+n2-m + 14 if(j.eq.ncheck) y(k)=bip +11 CONTINUE + if(KODE.eq.1) zz=dbesi0s(x) + if(KODE.eq.2) zz=dbsi0es(x) + do 15 k=1,m + 15 y(k)=y(k)*zz/BI + if(n.eq.0) y(1)=zz + RETURN +c Very large x- use upwards recursion + 60 continue + if(kode.eq.2) bim=dbsi0es(x) + if(kode.eq.2) bi=dbsi1es(x) + if(kode.eq.1) bim=dbesi0s(x) + if(kode.eq.1) bi=dbesi1s(x) + if(n.gt.1) go to 64 + if(n.gt.0) go to 63 +c n=0 + y(1)=bim + if(m.lt.2) return + y(2)=bi + if(m.lt.3) return + lmin=3 + go to 64 + 63 y(1)=bi + if(m.lt.2) return + lmin=2 + 64 n2=n+m-1 + if(n.gt.1) lmin=1 + tox=2.d0/x + do 61 j=1,n2-1 + bip=bim-dfloat(j)*tox*bi + bim=bi + bi=bip + do 62 l=lmin,m + jj=n+l-2 + 62 if(jj.eq.j) y(l)=bi + 61 continue + return + 1001 write(5,200) m,mmax + 200 format(1x,'m=',i4,' > mmax=',i4,' in BESSIN-stopped') + stop + 1005 write(6,201) m + 201 format(1x,'m in BESSIn= ',i2,' is > 20- stopped') + stop + END + DOUBLE PRECISION FUNCTION DBSI0Es(X) +c Stripped of extraneous calls, etc. to make it portable. +C***BEGIN PROLOGUE DBSI0E +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESI0E-S DBSI0E-D),BESSEL FUNCTION, +C EXPONENTIALLY SCALED,FIRST KIND, +C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, +C ORDER ZERO,SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the d.p. exponentially scaled hyperbolic Bessel +C function of the first kind of order zero. +C***DESCRIPTION +C +C DBSI0E(X) calculates the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the first kind of order +C zerofor double precision argument X. The result is the Bessel +C function I0(X) multiplied by EXP(-ABS(X)). +C +C Series for BI0 on the interval 0. to 9.00000E+00 +C with weighted error 9.51E-34 +C log weighted error 33.02 +C significant figures required 33.31 +C decimal places required 33.65 +C +C Series for AI0 on the interval 1.25000E-01 to 3.33333E-01 +C with weighted error 2.74E-32 +C log weighted error 31.56 +C significant figures required 30.15 +C decimal places required 32.39 +C +C Series for AI02 on the interval 0. to 1.25000E-01 +C with weighted error 1.97E-32 +C log weighted error 31.71 +C significant figures required 30.15 +C decimal places required 32.63 +C***REFERENCES (NONE) +C***ROUTINES CALLED DCSEVLs,INITDS +C***END PROLOGUE DBSI0E + DOUBLE PRECISION X, BI0CS(18), AI0CS(46), AI02CS(69), + 1Y,DCSEVLs,eta + SAVE BI0CS, AI0CS, AI02CS, NTI0, NTAI0, NTAI02 + DATA BI0CS( 1) /-.7660547252 8391449510 8189497624 3285 D-1 / + DATA BI0CS( 2) /+.1927337953 9938082699 5240875088 1196 D+1 / + DATA BI0CS( 3) /+.2282644586 9203013389 3702929233 0415 D+0 / + DATA BI0CS( 4) /+.1304891466 7072904280 7933421069 1888 D-1 / + DATA BI0CS( 5) /+.4344270900 8164874513 7868268102 6107 D-3 / + DATA BI0CS( 6) /+.9422657686 0019346639 2317174411 8766 D-5 / + DATA BI0CS( 7) /+.1434006289 5106910799 6209187817 9957 D-6 / + DATA BI0CS( 8) /+.1613849069 6617490699 1541971999 4611 D-8 / + DATA BI0CS( 9) /+.1396650044 5356696994 9509270814 2522 D-10 / + DATA BI0CS( 10) /+.9579451725 5054453446 2752317189 3333 D-13 / + DATA BI0CS( 11) /+.5333981859 8625021310 1510774400 0000 D-15 / + DATA BI0CS( 12) /+.2458716088 4374707746 9678591999 9999 D-17 / + DATA BI0CS( 13) /+.9535680890 2487700269 4434133333 3333 D-20 / + DATA BI0CS( 14) /+.3154382039 7214273367 8933333333 3333 D-22 / + DATA BI0CS( 15) /+.9004564101 0946374314 6666666666 6666 D-25 / + DATA BI0CS( 16) /+.2240647369 1236700160 0000000000 0000 D-27 / + DATA BI0CS( 17) /+.4903034603 2428373333 3333333333 3333 D-30 / + DATA BI0CS( 18) /+.9508172606 1226666666 6666666666 6666 D-33 / + DATA AI0CS( 1) /+.7575994494 0237959427 2987203743 8 D-1 / + DATA AI0CS( 2) /+.7591380810 8233455072 9297873320 4 D-2 / + DATA AI0CS( 3) /+.4153131338 9237505018 6319749138 2 D-3 / + DATA AI0CS( 4) /+.1070076463 4390730735 8242970217 0 D-4 / + DATA AI0CS( 5) /-.7901179979 2128946607 5031948573 0 D-5 / + DATA AI0CS( 6) /-.7826143501 4387522697 8898980690 9 D-6 / + DATA AI0CS( 7) /+.2783849942 9488708063 8118538985 7 D-6 / + DATA AI0CS( 8) /+.8252472600 6120271919 6682913319 8 D-8 / + DATA AI0CS( 9) /-.1204463945 5201991790 5496089110 3 D-7 / + DATA AI0CS( 10) /+.1559648598 5060764436 1228752792 8 D-8 / + DATA AI0CS( 11) /+.2292556367 1033165434 7725480285 7 D-9 / + DATA AI0CS( 12) /-.1191622884 2790646036 7777423447 8 D-9 / + DATA AI0CS( 13) /+.1757854916 0324098302 1833124774 3 D-10 / + DATA AI0CS( 14) /+.1128224463 2189005171 4441135682 4 D-11 / + DATA AI0CS( 15) /-.1146848625 9272988777 2963387698 2 D-11 / + DATA AI0CS( 16) /+.2715592054 8036628726 4365192160 6 D-12 / + DATA AI0CS( 17) /-.2415874666 5626878384 4247572028 1 D-13 / + DATA AI0CS( 18) /-.6084469888 2551250646 0609963922 4 D-14 / + DATA AI0CS( 19) /+.3145705077 1754772937 0836026730 3 D-14 / + DATA AI0CS( 20) /-.7172212924 8711877179 6217505917 6 D-15 / + DATA AI0CS( 21) /+.7874493403 4541033960 8390960332 7 D-16 / + DATA AI0CS( 22) /+.1004802753 0094624023 4524457183 9 D-16 / + DATA AI0CS( 23) /-.7566895365 3505348534 2843588881 0 D-17 / + DATA AI0CS( 24) /+.2150380106 8761198878 1205128784 5 D-17 / + DATA AI0CS( 25) /-.3754858341 8308744291 5158445260 8 D-18 / + DATA AI0CS( 26) /+.2354065842 2269925769 0075710532 2 D-19 / + DATA AI0CS( 27) /+.1114667612 0479285302 2637335511 0 D-19 / + DATA AI0CS( 28) /-.5398891884 3969903786 9677932270 9 D-20 / + DATA AI0CS( 29) /+.1439598792 2407526770 4285840452 2 D-20 / + DATA AI0CS( 30) /-.2591916360 1110934064 6081840196 2 D-21 / + DATA AI0CS( 31) /+.2238133183 9985839074 3409229824 0 D-22 / + DATA AI0CS( 32) /+.5250672575 3647711727 7221683199 9 D-23 / + DATA AI0CS( 33) /-.3249904138 5332307841 7343228586 6 D-23 / + DATA AI0CS( 34) /+.9924214103 2050379278 5728471040 0 D-24 / + DATA AI0CS( 35) /-.2164992254 2446695231 4655429973 3 D-24 / + DATA AI0CS( 36) /+.3233609471 9435940839 7333299199 9 D-25 / + DATA AI0CS( 37) /-.1184620207 3967424898 2473386666 6 D-26 / + DATA AI0CS( 38) /-.1281671853 9504986505 4833868799 9 D-26 / + DATA AI0CS( 39) /+.5827015182 2793905116 0556885333 3 D-27 / + DATA AI0CS( 40) /-.1668222326 0261097193 6450150399 9 D-27 / + DATA AI0CS( 41) /+.3625309510 5415699757 0068480000 0 D-28 / + DATA AI0CS( 42) /-.5733627999 0557135899 4595839999 9 D-29 / + DATA AI0CS( 43) /+.3736796722 0630982296 4258133333 3 D-30 / + DATA AI0CS( 44) /+.1602073983 1568519633 6551253333 3 D-30 / + DATA AI0CS( 45) /-.8700424864 0572298845 2249599999 9 D-31 / + DATA AI0CS( 46) /+.2741320937 9374811456 0341333333 3 D-31 / + DATA AI02CS( 1) /+.5449041101 4108831607 8960962268 0 D-1 / + DATA AI02CS( 2) /+.3369116478 2556940898 9785662979 9 D-2 / + DATA AI02CS( 3) /+.6889758346 9168239842 6263914301 1 D-4 / + DATA AI02CS( 4) /+.2891370520 8347564829 6692402323 2 D-5 / + DATA AI02CS( 5) /+.2048918589 4690637418 2760534093 1 D-6 / + DATA AI02CS( 6) /+.2266668990 4981780645 9327743136 1 D-7 / + DATA AI02CS( 7) /+.3396232025 7083863451 5084396952 3 D-8 / + DATA AI02CS( 8) /+.4940602388 2249695891 0482449783 5 D-9 / + DATA AI02CS( 9) /+.1188914710 7846438342 4084525196 3 D-10 / + DATA AI02CS( 10) /-.3149916527 9632413645 3864862961 9 D-10 / + DATA AI02CS( 11) /-.1321581184 0447713118 7540739926 7 D-10 / + DATA AI02CS( 12) /-.1794178531 5068061177 7943574026 9 D-11 / + DATA AI02CS( 13) /+.7180124451 3836662336 7106429346 9 D-12 / + DATA AI02CS( 14) /+.3852778382 7421427011 4089801777 6 D-12 / + DATA AI02CS( 15) /+.1540086217 5214098269 1325823339 7 D-13 / + DATA AI02CS( 16) /-.4150569347 2872220866 2689972015 6 D-13 / + DATA AI02CS( 17) /-.9554846698 8283076487 0214494312 5 D-14 / + DATA AI02CS( 18) /+.3811680669 3526224207 4605535511 8 D-14 / + DATA AI02CS( 19) /+.1772560133 0565263836 0493266675 8 D-14 / + DATA AI02CS( 20) /-.3425485619 6772191346 1924790328 2 D-15 / + DATA AI02CS( 21) /-.2827623980 5165834849 4205593759 4 D-15 / + DATA AI02CS( 22) /+.3461222867 6974610930 9706250813 4 D-16 / + DATA AI02CS( 23) /+.4465621420 2967599990 1042054284 3 D-16 / + DATA AI02CS( 24) /-.4830504485 9441820712 5525403795 4 D-17 / + DATA AI02CS( 25) /-.7233180487 8747539545 6227240924 5 D-17 / + DATA AI02CS( 26) /+.9921475412 1736985988 8046093981 0 D-18 / + DATA AI02CS( 27) /+.1193650890 8459820855 0439949924 2 D-17 / + DATA AI02CS( 28) /-.2488709837 1508072357 2054491660 2 D-18 / + DATA AI02CS( 29) /-.1938426454 1609059289 8469781132 6 D-18 / + DATA AI02CS( 30) /+.6444656697 3734438687 8301949394 9 D-19 / + DATA AI02CS( 31) /+.2886051596 2892243264 8171383073 4 D-19 / + DATA AI02CS( 32) /-.1601954907 1749718070 6167156200 7 D-19 / + DATA AI02CS( 33) /-.3270815010 5923147208 9193567485 9 D-20 / + DATA AI02CS( 34) /+.3686932283 8264091811 4600723939 3 D-20 / + DATA AI02CS( 35) /+.1268297648 0309501530 1359529710 9 D-22 / + DATA AI02CS( 36) /-.7549825019 3772739076 9636664410 1 D-21 / + DATA AI02CS( 37) /+.1502133571 3778353496 3712789053 4 D-21 / + DATA AI02CS( 38) /+.1265195883 5096485349 3208799248 3 D-21 / + DATA AI02CS( 39) /-.6100998370 0836807086 2940891600 2 D-22 / + DATA AI02CS( 40) /-.1268809629 2601282643 6872095924 2 D-22 / + DATA AI02CS( 41) /+.1661016099 8907414578 4038487490 5 D-22 / + DATA AI02CS( 42) /-.1585194335 7658855793 7970504881 4 D-23 / + DATA AI02CS( 43) /-.3302645405 9682178009 5381766755 6 D-23 / + DATA AI02CS( 44) /+.1313580902 8392397817 4039623117 4 D-23 / + DATA AI02CS( 45) /+.3689040246 6711567933 1425637280 4 D-24 / + DATA AI02CS( 46) /-.4210141910 4616891492 1978247249 9 D-24 / + DATA AI02CS( 47) /+.4791954591 0828657806 3171401373 0 D-25 / + DATA AI02CS( 48) /+.8459470390 2218217952 9971707412 4 D-25 / + DATA AI02CS( 49) /-.4039800940 8728324931 4607937181 0 D-25 / + DATA AI02CS( 50) /-.6434714653 6504313473 0100850469 5 D-26 / + DATA AI02CS( 51) /+.1225743398 8756659903 4464736990 5 D-25 / + DATA AI02CS( 52) /-.2934391316 0257089231 9879821175 4 D-26 / + DATA AI02CS( 53) /-.1961311309 1949829262 0371205728 9 D-26 / + DATA AI02CS( 54) /+.1503520374 8221934241 6229900309 8 D-26 / + DATA AI02CS( 55) /-.9588720515 7448265520 3386388206 9 D-28 / + DATA AI02CS( 56) /-.3483339380 8170454863 9441108511 4 D-27 / + DATA AI02CS( 57) /+.1690903610 2630436730 6244960725 6 D-27 / + DATA AI02CS( 58) /+.1982866538 7356030438 9400115718 8 D-28 / + DATA AI02CS( 59) /-.5317498081 4918162145 7583002528 4 D-28 / + DATA AI02CS( 60) /+.1803306629 8883929462 3501450390 1 D-28 / + DATA AI02CS( 61) /+.6213093341 4548931758 8405311242 2 D-29 / + DATA AI02CS( 62) /-.7692189292 7721618632 0072806673 0 D-29 / + DATA AI02CS( 63) /+.1858252826 1117025426 2556016596 3 D-29 / + DATA AI02CS( 64) /+.1237585142 2813957248 9927154554 1 D-29 / + DATA AI02CS( 65) /-.1102259120 4092238032 1779478779 2 D-29 / + DATA AI02CS( 66) /+.1886287118 0397044900 7787447943 1 D-30 / + DATA AI02CS( 67) /+.2160196872 2436589131 4903141406 0 D-30 / + DATA AI02CS( 68) /-.1605454124 9197432005 8446594965 5 D-30 / + DATA AI02CS( 69) /+.1965352984 5942906039 3884807331 8 D-31 / + DATA NTI0, NTAI0, NTAI02 / 3*0/ +C***FIRST EXECUTABLE STATEMENT DBSI0E + IF (NTI0.NE.0) GO TO 10 +c ETA = 0.1*SNGL(D1MACH(3)) +c replace above statement + eta=1.4d-18 + NTI0 = INITDSs (BI0CS, 18, ETA) + NTAI0 = INITDSs (AI0CS, 46, ETA) + NTAI02 = INITDSs (AI02CS, 69, ETA) +C + 10 Y = DABS(X) + IF (Y.GT.3.0D0) GO TO 20 +C + DBSI0Es = 1.0D0 + IF (Y.GT.1.d-15) DBSI0Es = DEXP(-Y) * (2.75D0 + + 1DCSEVLs (Y*Y/4.5D0-1.D0, BI0CS, NTI0) ) + RETURN +C + 20 IF (Y.LE.8.D0) DBSI0Es = + &(0.375D0 + DCSEVLs ((48.D0/Y-11.D0)/5.D0, + 1AI0CS, NTAI0))/DSQRT(Y) + IF (Y.GT.8.D0) DBSI0Es = + &(0.375D0 + DCSEVLs (16.D0/Y-1.D0, AI02CS, + 1NTAI02))/DSQRT(Y) +C + RETURN + END + DOUBLE PRECISION FUNCTION DCSEVLs(X,A,N) +c Stripped down version - no XERROR call- stops on wrong input. +C***BEGIN PROLOGUE DCSEVLs +C***DATE WRITTEN 770401 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C3A2 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(CSEVL-S DCSEVLs-D),CHEBYSHEV, +C SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Evaluate the double precision N-term Chebyshev series A +C at X. +C***DESCRIPTION +C +C Evaluate the N-term Chebyshev series A at X. Adapted from +C R. Broucke, Algorithm 446, C.A.C.M., 16, 254 (1973). +C W. Fullerton, C-3, Los Alamos Scientific Laboratory. +C +C Input Arguments -- +C X double precision value at which the series is to be evaluated. +C A double precision array of N terms of a Chebyshev series. In +C evaluating A, only half of the first coefficient is summed. +C N number of terms in array A. +C***REFERENCES (NONE) +C***ROUTINES CALLED XERROR +C***END PROLOGUE DCSEVLs +C + DOUBLE PRECISION A(N),X,TWOX,B0,B1,B2 +C***FIRST EXECUTABLE STATEMENT DCSEVLs + IF(N.LT.1) go to 1001 + IF(N.GT.1000) go to 1002 + IF ((X.LT.-1.D0) .OR. (X.GT.1.D0)) go to 1003 +C + TWOX = 2.0D0*X + B1 = 0.D0 + B0=0.D0 + DO 10 I=1,N + B2=B1 + B1=B0 + NI = N - I + 1 + B0 = TWOX*B1 - B2 + A(NI) + 10 CONTINUE +C + DCSEVLs = 0.5D0 * (B0-B2) +C + RETURN + 1001 write(6,201) N + 201 format(1x,'N < 1 in DCSEVLs- stopped') + stop + 1002 write(6,202) N + 202 format(1x,'N>1000 in DCSEVLs- stopped') + stop + 1003 write(6,203) x + 203 format(1x,'x outside interval [-1,1] in DCSEVLs- stopped') + stop + END + FUNCTION INITDSs(DOS,NOS,ETA) +C***BEGIN PROLOGUE INITDS +C***DATE WRITTEN 770601 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C3A2 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(INITS-S INITDS-D),CHEBYSHEV, +C INITIALIZE,ORTHOGONAL POLYNOMIAL,ORTHOGONAL SERIES,SERIES, +C SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Initializes the d.p. properly normalized orthogonal +C polynomial series to determine the number of terms needed +C for specific accuracy. +C***DESCRIPTION +C +C Initialize the double precision orthogonal series DOS so that INITDS +C is the number of terms needed to insure the error is no larger than +C ETA.Ordinarily ETA will be chosen to be one-tenth machine precision +C +C Input Arguments -- +C DOS dble prec array of NOS coefficients in an orthogonal series. +C NOS number of coefficients in DOS. +C ETA requested accuracy of series. +C***REFERENCES (NONE) +C***ROUTINES CALLED XERROR +C***END PROLOGUE INITDS +C + DOUBLE PRECISION DOS(NOS),eta,err +C***FIRST EXECUTABLE STATEMENT INITDS + IF (NOS.LT.1) write(6,201) + 201 format( 'INITDS NUMBER OF COEFFICIENTS LT 1') +C + ERR = 0.d0 + DO 10 II=1,NOS + I = NOS + 1 - II + ERR = ERR + ABS(DOS(I)) + IF (ERR.GT.ETA) GO TO 20 + 10 CONTINUE +C + 20 IF (I.EQ.NOS) write(6,200) + 200 format( 'INITDSs ETA MAY BE TOO SMALL') + INITDSs = I +C + RETURN + END + DOUBLE PRECISION FUNCTION DBSI1Es(X) +C***BEGIN PROLOGUE DBSI1E +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESI1E-S DBSI1E-D),BESSEL FUNCTION, +C EXPONENTIALLY SCALED,FIRST KIND, +C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, +C ORDER ONE,SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the d.p. exponentially scaled modified (hyper- +C bolic) Bessel function of the first kind of order one. +C***DESCRIPTION +C +C DBSI1E(X) calculates the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the first kind of order +C one for double precision argument X. The result is I1(X) +C multiplied by EXP(-ABS(X)). +C +C Series for BI1 on the interval 0. to 9.00000E+00 +C with weighted error 1.44E-32 +C log weighted error 31.84 +C significant figures required 31.45 +C decimal places required 32.46 +C +C Series for AI1 on the interval 1.25000E-01 to 3.33333E-01 +C with weighted error 2.81E-32 +C log weighted error 31.55 +C significant figures required 29.93 +C decimal places required 32.38 +C +C Series for AI12 on the interval 0. to 1.25000E-01 +C with weighted error 1.83E-32 +C log weighted error 31.74 +C significant figures required 29.97 +C decimal places required 32.66 +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DCSEVL,INITDS,XERROR +C***END PROLOGUE DBSI1E + DOUBLE PRECISION X, BI1CS(17), AI1CS(46), AI12CS(69), XMIN, + 1XSML, Y, DCSEVLs,eta + SAVE BI1CS, AI1CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML + DATA BI1CS( 1) /-.1971713261 0998597316 1385032181 49 D-2 / + DATA BI1CS( 2) /+.4073488766 7546480608 1553936520 14 D+0 / + DATA BI1CS( 3) /+.3483899429 9959455866 2450377837 87 D-1 / + DATA BI1CS( 4) /+.1545394556 3001236038 5984010584 89 D-2 / + DATA BI1CS( 5) /+.4188852109 8377784129 4588320041 20 D-4 / + DATA BI1CS( 6) /+.7649026764 8362114741 9597039660 69 D-6 / + DATA BI1CS( 7) /+.1004249392 4741178689 1798080372 38 D-7 / + DATA BI1CS( 8) /+.9932207791 9238106481 3712980548 63 D-10 / + DATA BI1CS( 9) /+.7663801791 8447637275 2001716813 49 D-12 / + DATA BI1CS( 10) /+.4741418923 8167394980 3880919481 60 D-14 / + DATA BI1CS( 11) /+.2404114404 0745181799 8631720320 00 D-16 / + DATA BI1CS( 12) /+.1017150500 7093713649 1211007999 99 D-18 / + DATA BI1CS( 13) /+.3645093565 7866949458 4917333333 33 D-21 / + DATA BI1CS( 14) /+.1120574950 2562039344 8106666666 66 D-23 / + DATA BI1CS( 15) /+.2987544193 4468088832 0000000000 00 D-26 / + DATA BI1CS( 16) /+.6973231093 9194709333 3333333333 33 D-29 / + DATA BI1CS( 17) /+.1436794822 0620800000 0000000000 00 D-31 / + DATA AI1CS( 1) /-.2846744181 8814786741 0037246830 7 D-1 / + DATA AI1CS( 2) /-.1922953231 4432206510 4444877497 9 D-1 / + DATA AI1CS( 3) /-.6115185857 9437889822 5624991778 5 D-3 / + DATA AI1CS( 4) /-.2069971253 3502277088 8282377797 9 D-4 / + DATA AI1CS( 5) /+.8585619145 8107255655 3694467313 8 D-5 / + DATA AI1CS( 6) /+.1049498246 7115908625 1745399786 0 D-5 / + DATA AI1CS( 7) /-.2918338918 4479022020 9343232669 7 D-6 / + DATA AI1CS( 8) /-.1559378146 6317390001 6068096907 7 D-7 / + DATA AI1CS( 9) /+.1318012367 1449447055 2530287390 9 D-7 / + DATA AI1CS( 10) /-.1448423418 1830783176 3913446781 5 D-8 / + DATA AI1CS( 11) /-.2908512243 9931420948 2504099301 0 D-9 / + DATA AI1CS( 12) /+.1266388917 8753823873 1115969040 3 D-9 / + DATA AI1CS( 13) /-.1664947772 9192206706 2417839858 0 D-10 / + DATA AI1CS( 14) /-.1666653644 6094329760 9593715499 9 D-11 / + DATA AI1CS( 15) /+.1242602414 2907682652 3216847201 7 D-11 / + DATA AI1CS( 16) /-.2731549379 6724323972 5146142863 3 D-12 / + DATA AI1CS( 17) /+.2023947881 6458037807 0026268898 1 D-13 / + DATA AI1CS( 18) /+.7307950018 1168836361 9869812612 3 D-14 / + DATA AI1CS( 19) /-.3332905634 4046749438 1377861713 3 D-14 / + DATA AI1CS( 20) /+.7175346558 5129537435 4225466567 0 D-15 / + DATA AI1CS( 21) /-.6982530324 7962563558 5062922365 6 D-16 / + DATA AI1CS( 22) /-.1299944201 5627607600 6044608058 7 D-16 / + DATA AI1CS( 23) /+.8120942864 2427988920 5467834286 0 D-17 / + DATA AI1CS( 24) /-.2194016207 4107368981 5626664378 3 D-17 / + DATA AI1CS( 25) /+.3630516170 0296548482 7986093233 4 D-18 / + DATA AI1CS( 26) /-.1695139772 4391041663 0686679039 9 D-19 / + DATA AI1CS( 27) /-.1288184829 8979078071 1688253822 2 D-19 / + DATA AI1CS( 28) /+.5694428604 9670527801 0999107310 9 D-20 / + DATA AI1CS( 29) /-.1459597009 0904800565 4550990028 7 D-20 / + DATA AI1CS( 30) /+.2514546010 6757173140 8469133448 5 D-21 / + DATA AI1CS( 31) /-.1844758883 1391248181 6040002901 3 D-22 / + DATA AI1CS( 32) /-.6339760596 2279486419 2860979199 9 D-23 / + DATA AI1CS( 33) /+.3461441102 0310111111 0814662656 0 D-23 / + DATA AI1CS( 34) /-.1017062335 3713935475 9654102357 3 D-23 / + DATA AI1CS( 35) /+.2149877147 0904314459 6250077866 6 D-24 / + DATA AI1CS( 36) /-.3045252425 2386764017 4620617386 6 D-25 / + DATA AI1CS( 37) /+.5238082144 7212859821 7763498666 6 D-27 / + DATA AI1CS( 38) /+.1443583107 0893824464 1678950399 9 D-26 / + DATA AI1CS( 39) /-.6121302074 8900427332 0067071999 9 D-27 / + DATA AI1CS( 40) /+.1700011117 4678184183 4918980266 6 D-27 / + DATA AI1CS( 41) /-.3596589107 9842441585 3521578666 6 D-28 / + DATA AI1CS( 42) /+.5448178578 9484185766 5051306666 6 D-29 / + DATA AI1CS( 43) /-.2731831789 6890849891 6256426666 6 D-30 / + DATA AI1CS( 44) /-.1858905021 7086007157 7190399999 9 D-30 / + DATA AI1CS( 45) /+.9212682974 5139334411 2776533333 3 D-31 / + DATA AI1CS( 46) /-.2813835155 6535611063 7083306666 6 D-31 / + DATA AI12CS( 1) /+.2857623501 8280120474 4984594846 9 D-1 / + DATA AI12CS( 2) /-.9761097491 3614684077 6516445730 2 D-2 / + DATA AI12CS( 3) /-.1105889387 6262371629 1256921277 5 D-3 / + DATA AI12CS( 4) /-.3882564808 8776903934 5654477627 4 D-5 / + DATA AI12CS( 5) /-.2512236237 8702089252 9452002212 1 D-6 / + DATA AI12CS( 6) /-.2631468846 8895195068 3705236523 2 D-7 / + DATA AI12CS( 7) /-.3835380385 9642370220 4500678796 8 D-8 / + DATA AI12CS( 8) /-.5589743462 1965838068 6811252222 9 D-9 / + DATA AI12CS( 9) /-.1897495812 3505412344 9892503323 8 D-10 / + DATA AI12CS( 10) /+.3252603583 0154882385 5508067994 9 D-10 / + DATA AI12CS( 11) /+.1412580743 6613781331 6336633284 6 D-10 / + DATA AI12CS( 12) /+.2035628544 1470895072 2452613684 0 D-11 / + DATA AI12CS( 13) /-.7198551776 2459085120 9258989044 6 D-12 / + DATA AI12CS( 14) /-.4083551111 0921973182 2849963969 1 D-12 / + DATA AI12CS( 15) /-.2101541842 7726643130 1984572746 2 D-13 / + DATA AI12CS( 16) /+.4272440016 7119513542 9778833699 7 D-13 / + DATA AI12CS( 17) /+.1042027698 4128802764 1741449994 8 D-13 / + DATA AI12CS( 18) /-.3814403072 4370078047 6707253539 6 D-14 / + DATA AI12CS( 19) /-.1880354775 5107824485 1273453396 3 D-14 / + DATA AI12CS( 20) /+.3308202310 9209282827 3190335240 5 D-15 / + DATA AI12CS( 21) /+.2962628997 6459501390 6854654205 2 D-15 / + DATA AI12CS( 22) /-.3209525921 9934239587 7837353288 7 D-16 / + DATA AI12CS( 23) /-.4650305368 4893583255 7128281897 9 D-16 / + DATA AI12CS( 24) /+.4414348323 0717079499 4611375964 1 D-17 / + DATA AI12CS( 25) /+.7517296310 8421048054 2545808029 5 D-17 / + DATA AI12CS( 26) /-.9314178867 3268833756 8484784515 7 D-18 / + DATA AI12CS( 27) /-.1242193275 1948909561 1678448869 7 D-17 / + DATA AI12CS( 28) /+.2414276719 4548484690 0515390217 6 D-18 / + DATA AI12CS( 29) /+.2026944384 0532851789 7192286069 2 D-18 / + DATA AI12CS( 30) /-.6394267188 2690977870 4391988681 1 D-19 / + DATA AI12CS( 31) /-.3049812452 3730958960 8488450357 1 D-19 / + DATA AI12CS( 32) /+.1612841851 6514802251 3462230769 1 D-19 / + DATA AI12CS( 33) /+.3560913964 3099250545 1027090462 0 D-20 / + DATA AI12CS( 34) /-.3752017947 9364390796 6682800324 6 D-20 / + DATA AI12CS( 35) /-.5787037427 0747993459 5198231074 1 D-22 / + DATA AI12CS( 36) /+.7759997511 6481619619 8236963209 2 D-21 / + DATA AI12CS( 37) /-.1452790897 2022333940 6445987408 5 D-21 / + DATA AI12CS( 38) /-.1318225286 7390367021 2192275337 4 D-21 / + DATA AI12CS( 39) /+.6116654862 9030707018 7999133171 7 D-22 / + DATA AI12CS( 40) /+.1376279762 4271264277 3024338363 4 D-22 / + DATA AI12CS( 41) /-.1690837689 9593478849 1983938230 6 D-22 / + DATA AI12CS( 42) /+.1430596088 5954331539 8720108538 5 D-23 / + DATA AI12CS( 43) /+.3409557828 0905940204 0536772990 2 D-23 / + DATA AI12CS( 44) /-.1309457666 2707602278 4573872642 4 D-23 / + DATA AI12CS( 45) /-.3940706411 2402574360 9352141755 7 D-24 / + DATA AI12CS( 46) /+.4277137426 9808765808 0616679735 2 D-24 / + DATA AI12CS( 47) /-.4424634830 9826068819 0028312302 9 D-25 / + DATA AI12CS( 48) /-.8734113196 2307149721 1530978874 7 D-25 / + DATA AI12CS( 49) /+.4045401335 6835333921 4340414242 8 D-25 / + DATA AI12CS( 50) /+.7067100658 0946894656 5160771780 6 D-26 / + DATA AI12CS( 51) /-.1249463344 5651052230 0286451860 5 D-25 / + DATA AI12CS( 52) /+.2867392244 4034370329 7948339142 6 D-26 / + DATA AI12CS( 53) /+.2044292892 5042926702 8177957421 0 D-26 / + DATA AI12CS( 54) /-.1518636633 8204625683 7134680291 1 D-26 / + DATA AI12CS( 55) /+.8110181098 1875758861 3227910703 7 D-28 / + DATA AI12CS( 56) /+.3580379354 7735860911 2717370327 0 D-27 / + DATA AI12CS( 57) /-.1692929018 9279025095 9305717544 8 D-27 / + DATA AI12CS( 58) /-.2222902499 7024276390 6775852777 4 D-28 / + DATA AI12CS( 59) /+.5424535127 1459696550 4860040112 8 D-28 / + DATA AI12CS( 60) /-.1787068401 5780186887 6491299330 4 D-28 / + DATA AI12CS( 61) /-.6565479068 7228149388 2392943788 0 D-29 / + DATA AI12CS( 62) /+.7807013165 0611452809 2206770683 9 D-29 / + DATA AI12CS( 63) /-.1816595260 6689797173 7933315222 1 D-29 / + DATA AI12CS( 64) /-.1287704952 6600848203 7687559895 9 D-29 / + DATA AI12CS( 65) /+.1114548172 9881645474 1370927369 4 D-29 / + DATA AI12CS( 66) /-.1808343145 0393369391 5936887668 7 D-30 / + DATA AI12CS( 67) /-.2231677718 2037719522 3244822893 9 D-30 / + DATA AI12CS( 68) /+.1619029596 0803415106 1790980361 4 D-30 / + DATA AI12CS( 69) /-.1834079908 8049414139 0130843921 0 D-31 / + DATA NTI1, NTAI1, NTAI12, XMIN, XSML / 3*0, 2*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBSI1Es + IF (NTI1.NE.0) GO TO 10 +c type *,'D1mach(3)',d1mach(3) + eta=1.4d-18 +c ETA = 0.1*SNGL(D1MACH(3)) +c type *,'eta',eta + NTI1 = INITDSs (BI1CS, 17, ETA) + NTAI1 = INITDSs (AI1CS, 46, ETA) + NTAI12 = INITDSs (AI12CS, 69, ETA) +C + XMIN = 4.d-39 +c type *,'D1mach(1)',d1mach(1) + XSML = 1.d-8 +C + 10 Y = DABS(X) + IF (Y.GT.3.0D0) GO TO 20 +C + DBSI1Es = 0.0D0 + IF (Y.EQ.0.D0) RETURN +C + IF (Y.LT.XMIN) write(6,301) + 301 format(1x,'DBSI1Es DABS(X) SO SMALL I1 UNDERFLOWS') + IF (Y.GT.XMIN) DBSI1Es = 0.5D0*X + IF (Y.GT.XSML) DBSI1Es = + &X*(0.875D0 + DCSEVLs (Y*Y/4.5D0-1.D0, + 1BI1CS, NTI1) ) + DBSI1Es = DEXP(-Y) * DBSI1Es + RETURN +C + 20 IF (Y.LE.8.D0) DBSI1Es = + &(0.375D0 + DCSEVLs ((48.D0/Y-11.D0)/5.D0, + 1AI1CS, NTAI1))/DSQRT(Y) + IF (Y.GT.8.D0) DBSI1Es = + &(0.375D0 + DCSEVLs (16.D0/Y-1.D0, AI12CS, + 1NTAI12))/DSQRT(Y) + DBSI1Es = DSIGN (DBSI1Es, X) +C + RETURN + END + DOUBLE PRECISION FUNCTION DBESI1s(X) +C***BEGIN PROLOGUE DBESI1 +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESI1-S DBESI1-D),BESSEL FUNCTION, +C FIRST KIND,HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION,ORDER ONE,SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the d.p. modified (hyperbolic) Bessel function +C of the first kind of order one. +C***DESCRIPTION +C +C DBESI1(X) calculates the double precision modified (hyperbolic) +C Bessel function of the first kind of order one and double precision +C argument X. +C +C Series for BI1 on the interval 0. to 9.00000E+00 +C with weighted error 1.44E-32 +C log weighted error 31.84 +C significant figures required 31.45 +C decimal places required 32.46 +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DBSI1E,DCSEVL,INITDS,XERROR +C***END PROLOGUE DBESI1 + DOUBLE PRECISION X, BI1CS(17), XMAX, XMIN, XSML, Y, + 1DCSEVLs, DBSI1Es,eta + SAVE BI1CS, NTI1, XMIN, XSML, XMAX + DATA BI1CS( 1) /-.1971713261 0998597316 1385032181 49 D-2 / + DATA BI1CS( 2) /+.4073488766 7546480608 1553936520 14 D+0 / + DATA BI1CS( 3) /+.3483899429 9959455866 2450377837 87 D-1 / + DATA BI1CS( 4) /+.1545394556 3001236038 5984010584 89 D-2 / + DATA BI1CS( 5) /+.4188852109 8377784129 4588320041 20 D-4 / + DATA BI1CS( 6) /+.7649026764 8362114741 9597039660 69 D-6 / + DATA BI1CS( 7) /+.1004249392 4741178689 1798080372 38 D-7 / + DATA BI1CS( 8) /+.9932207791 9238106481 3712980548 63 D-10 / + DATA BI1CS( 9) /+.7663801791 8447637275 2001716813 49 D-12 / + DATA BI1CS( 10) /+.4741418923 8167394980 3880919481 60 D-14 / + DATA BI1CS( 11) /+.2404114404 0745181799 8631720320 00 D-16 / + DATA BI1CS( 12) /+.1017150500 7093713649 1211007999 99 D-18 / + DATA BI1CS( 13) /+.3645093565 7866949458 4917333333 33 D-21 / + DATA BI1CS( 14) /+.1120574950 2562039344 8106666666 66 D-23 / + DATA BI1CS( 15) /+.2987544193 4468088832 0000000000 00 D-26 / + DATA BI1CS( 16) /+.6973231093 9194709333 3333333333 33 D-29 / + DATA BI1CS( 17) /+.1436794822 0620800000 0000000000 00 D-31 / + DATA NTI1, XMIN, XSML, XMAX / 0, 3*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBESI1 + IF (NTI1.NE.0) GO TO 10 + eta=1.4d-18 + NTI1 = INITDSs (BI1CS, 17, eta) + XMIN = 4.0d-39 + XSML = 1.d-8 + XMAX = 86.d0 +C + 10 Y = DABS(X) + IF (Y.GT.3.0D0) GO TO 20 +C + DBESI1s = 0.D0 + IF (Y.EQ.0.D0) RETURN +C + IF (Y.LT.XMIN) + &write(6,*) 'DBESI1s DABS(X) SO SMALL IT UNDERFLOWS' + IF (Y.GT.XMIN) DBESI1s = 0.5D0*X + IF (Y.GT.XSML) DBESI1s = X*(0.875D0 + + &DCSEVLs (Y*Y/4.5D0-1.D0, + 1BI1CS, NTI1)) + RETURN +C + 20 IF (Y.GT.XMAX) write(6,*)'DBESI1s DABS(X) SO BIG I1 OVERFLOWS' +C + DBESI1s = DEXP(Y) * DBSI1Es(X) +C + RETURN + END + DOUBLE PRECISION FUNCTION DBESI0s(X) +c Stripped version of CLAMS DBESI0 - no machine-dependent calls. +C***BEGIN PROLOGUE DBESI0 +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESI0-S DBESI0-D),BESSEL FUNCTION, +C FIRST KIND,HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION,ORDER ZERO,SPECIAL FUNCTIONS +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the d.p. hyperbolic Bessel function of the first +C kind of order zero. +C***DESCRIPTION +C +C DBESI0(X) calculates the double precision modified (hyperbolic) +C Bessel function of the first kind of order zero and double +C precision argument X. +C +C Series for BI0 on the interval 0. to 9.00000E+00 +C with weighted error 9.51E-34 +C log weighted error 33.02 +C significant figures required 33.31 +C decimal places required 33.65 +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DBSI0E,DCSEVL,INITDS,XERROR +C***END PROLOGUE DBESI0 + DOUBLE PRECISION X, BI0CS(18), XMAX, XSML, Y, + 1DCSEVLs, DBSI0Es + SAVE BI0CS, NTI0, XSML, XMAX + DATA BI0CS( 1) /-.7660547252 8391449510 8189497624 3285 D-1 / + DATA BI0CS( 2) /+.1927337953 9938082699 5240875088 1196 D+1 / + DATA BI0CS( 3) /+.2282644586 9203013389 3702929233 0415 D+0 / + DATA BI0CS( 4) /+.1304891466 7072904280 7933421069 1888 D-1 / + DATA BI0CS( 5) /+.4344270900 8164874513 7868268102 6107 D-3 / + DATA BI0CS( 6) /+.9422657686 0019346639 2317174411 8766 D-5 / + DATA BI0CS( 7) /+.1434006289 5106910799 6209187817 9957 D-6 / + DATA BI0CS( 8) /+.1613849069 6617490699 1541971999 4611 D-8 / + DATA BI0CS( 9) /+.1396650044 5356696994 9509270814 2522 D-10 / + DATA BI0CS( 10) /+.9579451725 5054453446 2752317189 3333 D-13 / + DATA BI0CS( 11) /+.5333981859 8625021310 1510774400 0000 D-15 / + DATA BI0CS( 12) /+.2458716088 4374707746 9678591999 9999 D-17 / + DATA BI0CS( 13) /+.9535680890 2487700269 4434133333 3333 D-20 / + DATA BI0CS( 14) /+.3154382039 7214273367 8933333333 3333 D-22 / + DATA BI0CS( 15) /+.9004564101 0946374314 6666666666 6666 D-25 / + DATA BI0CS( 16) /+.2240647369 1236700160 0000000000 0000 D-27 / + DATA BI0CS( 17) /+.4903034603 2428373333 3333333333 3333 D-30 / + DATA BI0CS( 18) /+.9508172606 1226666666 6666666666 6666 D-33 / + DATA NTI0, XSML, XMAX / 0, 2*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBESI0 + IF (NTI0.NE.0) GO TO 10 + NTI0 = INITDSs(BI0CS, 18, 1.4d-18) +c XSML = DSQRT (8.0D0*D1MACH(3)) + xsml=7.5d-9 +c XMAX = DLOG (D1MACH(2)) + xmax=86.4d0 +C + 10 Y = DABS(X) + IF (Y.GT.3.0D0) GO TO 20 +C + DBESI0s= 1.0D0 + IF (Y.GT.XSML) DBESI0s= 2.75D0 + DCSEVLs(Y*Y/4.5D0-1.D0, BI0CS, + 1NTI0) + RETURN +C + 20 IF (Y.GT.XMAX) go to 1001 +C + DBESI0s= DEXP(Y) * DBSI0Es(X) +C + RETURN + 1001 write(6,*) 'X>XMAX in DBESI0s-stopped:XMAX=86.4,x=',x + stop + END + DOUBLE PRECISION FUNCTION DBESK0s(X) +c Stripped of machine-dependent calls . +C***BEGIN PROLOGUE DBESK0s +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESK0-S DBESK0s-D),BESSEL FUNCTION, +C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, +C ORDER ZERO,SPECIAL FUNCTIONS,THIRD KIND +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes d.p. modified (hyperbolic) Bessel function of +C the third kind of order zero. +C***DESCRIPTION +C +C DBESK0s(X) calculates the double precision modified (hyperbolic) +C Bessel function of the third kind of order zero for double +C precision argument X. The argument must be greater than zero +C but not so large that the result underflows. +C +C Series for BK0 on the interval 0. to 4.00000E+00 +C with weighted error 3.08E-33 +C log weighted error 32.51 +C significant figures required 32.05 +C decimal places required 33.11 +C***REFERENCES (NONE) +C***ROUTINES CALLED DBESI0,DBSK0E,DCSEVL,INITDS +C***END PROLOGUE DBESK0s + DOUBLE PRECISION X, BK0CS(16), XMAX, XSML, Y, + 1DCSEVLs, DBESI0s, DBSK0Es + SAVE BK0CS, NTK0, XSML, XMAX + DATA BK0CS( 1) /-.3532739323 3902768720 1140060063 153 D-1 / + DATA BK0CS( 2) /+.3442898999 2462848688 6344927529 213 D+0 / + DATA BK0CS( 3) /+.3597993651 5361501626 5721303687 231 D-1 / + DATA BK0CS( 4) /+.1264615411 4469259233 8479508673 447 D-2 / + DATA BK0CS( 5) /+.2286212103 1194517860 8269830297 585 D-4 / + DATA BK0CS( 6) /+.2534791079 0261494573 0790013428 354 D-6 / + DATA BK0CS( 7) /+.1904516377 2202088589 7214059381 366 D-8 / + DATA BK0CS( 8) /+.1034969525 7633624585 1008317853 089 D-10 / + DATA BK0CS( 9) /+.4259816142 7910825765 2445327170 133 D-13 / + DATA BK0CS( 10) /+.1374465435 8807508969 4238325440 000 D-15 / + DATA BK0CS( 11) /+.3570896528 5083735909 9688597333 333 D-18 / + DATA BK0CS( 12) /+.7631643660 1164373766 7498666666 666 D-21 / + DATA BK0CS( 13) /+.1365424988 4407818590 8053333333 333 D-23 / + DATA BK0CS( 14) /+.2075275266 9066680831 9999999999 999 D-26 / + DATA BK0CS( 15) /+.2712814218 0729856000 0000000000 000 D-29 / + DATA BK0CS( 16) /+.3082593887 9146666666 6666666666 666 D-32 / + DATA NTK0, XSML, XMAX / 0, 2*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBESK0s + IF (NTK0.NE.0) GO TO 10 + NTK0 = INITDSs(BK0CS, 16, 1.4d-18) + XSML = 7.5d-9 + XMAX = 86.4d0 +C + 10 if(x.le.0.d0) go to 1001 + IF (X.GT.2.0D0) GO TO 20 +C + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBESK0s = -DLOG(0.5D0*X)*DBESI0s(X) + &- 0.25D0 + DCSEVLs(.5D0*Y-1.D0, + 1BK0CS, NTK0) + RETURN +C + 20 DBESK0s = 0.D0 + IF (X.GT.XMAX) write(6,*)'DBESK0s X SO BIG K0 UNDERFLOWS' + IF (X.GT.XMAX) RETURN +C + DBESK0s = DEXP(-X) * DBSK0Es(X) +C + RETURN + 1001 write(6,*) 'DBESK0s X IS ZERO OR NEGATIVE- stopped' + stop + END + DOUBLE PRECISION FUNCTION DBSK0Es(X) +c Stripped of machine-dependent calls. +C***BEGIN PROLOGUE DBSK0Es +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESK0E-S DBSK0Es-D),BESSEL FUNCTION, +C EXPONENTIALLY SCALED,HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION,ORDER ZERO,SPECIAL FUNCTIONS, +C THIRD KIND +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the d.p. exponentially scaled modified (hyper- +C bolic) Bessel function of the third kind of order zero. +C***DESCRIPTION +C +C DBSK0Es(X) computes the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the third kind of +C order zero for positive double precision argument X. +C +C Series for BK0 on the interval 0. to 4.00000E+00 +C with weighted error 3.08E-33 +C log weighted error 32.51 +C significant figures required 32.05 +C decimal places required 33.11 +C +C Series for AK0 on the interval 1.25000E-01 to 5.00000E-01 +C with weighted error 2.85E-32 +C log weighted error 31.54 +C significant figures required 30.19 +C decimal places required 32.33 +C +C Series for AK02 on the interval 0. to 1.25000E-01 +C with weighted error 2.30E-32 +C log weighted error 31.64 +C significant figures required 29.68 +C decimal places required 32.40 +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DBESI0,DCSEVL,INITDSs,XERROR +C***END PROLOGUE DBSK0Es + DOUBLE PRECISION X, BK0CS(16), AK0CS(38), AK02CS(33), + 1XSML, Y, DCSEVLs,DBESI0s,eta + SAVE BK0CS, AK0CS, AK02CS,NTK0, NTAK0, NTAK02, XSML + DATA BK0CS( 1) /-.3532739323 3902768720 1140060063 153 D-1 / + DATA BK0CS( 2) /+.3442898999 2462848688 6344927529 213 D+0 / + DATA BK0CS( 3) /+.3597993651 5361501626 5721303687 231 D-1 / + DATA BK0CS( 4) /+.1264615411 4469259233 8479508673 447 D-2 / + DATA BK0CS( 5) /+.2286212103 1194517860 8269830297 585 D-4 / + DATA BK0CS( 6) /+.2534791079 0261494573 0790013428 354 D-6 / + DATA BK0CS( 7) /+.1904516377 2202088589 7214059381 366 D-8 / + DATA BK0CS( 8) /+.1034969525 7633624585 1008317853 089 D-10 / + DATA BK0CS( 9) /+.4259816142 7910825765 2445327170 133 D-13 / + DATA BK0CS( 10) /+.1374465435 8807508969 4238325440 000 D-15 / + DATA BK0CS( 11) /+.3570896528 5083735909 9688597333 333 D-18 / + DATA BK0CS( 12) /+.7631643660 1164373766 7498666666 666 D-21 / + DATA BK0CS( 13) /+.1365424988 4407818590 8053333333 333 D-23 / + DATA BK0CS( 14) /+.2075275266 9066680831 9999999999 999 D-26 / + DATA BK0CS( 15) /+.2712814218 0729856000 0000000000 000 D-29 / + DATA BK0CS( 16) /+.3082593887 9146666666 6666666666 666 D-32 / + DATA AK0CS( 1) /-.7643947903 3279414240 8297827008 8 D-1 / + DATA AK0CS( 2) /-.2235652605 6998190520 2309555079 1 D-1 / + DATA AK0CS( 3) /+.7734181154 6938582353 0061817404 7 D-3 / + DATA AK0CS( 4) /-.4281006688 8860994644 5214643541 6 D-4 / + DATA AK0CS( 5) /+.3081700173 8629747436 5001482666 0 D-5 / + DATA AK0CS( 6) /-.2639367222 0096649740 6744889272 3 D-6 / + DATA AK0CS( 7) /+.2563713036 4034692062 9408826574 2 D-7 / + DATA AK0CS( 8) /-.2742705549 9002012638 5721191524 4 D-8 / + DATA AK0CS( 9) /+.3169429658 0974995920 8083287340 3 D-9 / + DATA AK0CS( 10) /-.3902353286 9621841416 0106571796 2 D-10 / + DATA AK0CS( 11) /+.5068040698 1885754020 5009212728 6 D-11 / + DATA AK0CS( 12) /-.6889574741 0078706795 4171355798 4 D-12 / + DATA AK0CS( 13) /+.9744978497 8259176913 8820133683 1 D-13 / + DATA AK0CS( 14) /-.1427332841 8845485053 8985534012 2 D-13 / + DATA AK0CS( 15) /+.2156412571 0214630395 5806297652 7 D-14 / + DATA AK0CS( 16) /-.3349654255 1495627721 8878205853 0 D-15 / + DATA AK0CS( 17) /+.5335260216 9529116921 4528039260 1 D-16 / + DATA AK0CS( 18) /-.8693669980 8907538076 3962237883 7 D-17 / + DATA AK0CS( 19) /+.1446404347 8622122278 8776344234 6 D-17 / + DATA AK0CS( 20) /-.2452889825 5001296824 0467875157 3 D-18 / + DATA AK0CS( 21) /+.4233754526 2321715728 2170634240 0 D-19 / + DATA AK0CS( 22) /-.7427946526 4544641956 9534129493 3 D-20 / + DATA AK0CS( 23) /+.1323150529 3926668662 7796746240 0 D-20 / + DATA AK0CS( 24) /-.2390587164 7396494513 3598146559 9 D-21 / + DATA AK0CS( 25) /+.4376827585 9232261401 6571255466 6 D-22 / + DATA AK0CS( 26) /-.8113700607 3451180593 3901141333 3 D-23 / + DATA AK0CS( 27) /+.1521819913 8321729583 1037815466 6 D-23 / + DATA AK0CS( 28) /-.2886041941 4833977702 3595861333 3 D-24 / + DATA AK0CS( 29) /+.5530620667 0547179799 9261013333 3 D-25 / + DATA AK0CS( 30) /-.1070377329 2498987285 9163306666 6 D-25 / + DATA AK0CS( 31) /+.2091086893 1423843002 9632853333 3 D-26 / + DATA AK0CS( 32) /-.4121713723 6462038274 1026133333 3 D-27 / + DATA AK0CS( 33) /+.8193483971 1213076401 3568000000 0 D-28 / + DATA AK0CS( 34) /-.1642000275 4592977267 8075733333 3 D-28 / + DATA AK0CS( 35) /+.3316143281 4802271958 9034666666 6 D-29 / + DATA AK0CS( 36) /-.6746863644 1452959410 8586666666 6 D-30 / + DATA AK0CS( 37) /+.1382429146 3184246776 3541333333 3 D-30 / + DATA AK0CS( 38) /-.2851874167 3598325708 1173333333 3 D-31 / + DATA AK02CS( 1) /-.1201869826 3075922398 3934621245 2 D-1 / + DATA AK02CS( 2) /-.9174852691 0256953106 5256107571 3 D-2 / + DATA AK02CS( 3) /+.1444550931 7750058210 4884387805 7 D-3 / + DATA AK02CS( 4) /-.4013614175 4357097286 7102107787 9 D-5 / + DATA AK02CS( 5) /+.1567831810 8523106725 9034899033 3 D-6 / + DATA AK02CS( 6) /-.7770110438 5217377103 1579975446 0 D-8 / + DATA AK02CS( 7) /+.4611182576 1797178825 3313052958 6 D-9 / + DATA AK02CS( 8) /-.3158592997 8605657705 2666580330 9 D-10 / + DATA AK02CS( 9) /+.2435018039 3650411278 3588781432 9 D-11 / + DATA AK02CS( 10) /-.2074331387 3983478977 0985337350 6 D-12 / + DATA AK02CS( 11) /+.1925787280 5899170847 4273650469 3 D-13 / + DATA AK02CS( 12) /-.1927554805 8389561036 0034718221 8 D-14 / + DATA AK02CS( 13) /+.2062198029 1978182782 8523786964 4 D-15 / + DATA AK02CS( 14) /-.2341685117 5792424026 0364019507 1 D-16 / + DATA AK02CS( 15) /+.2805902810 6430422468 1517882845 8 D-17 / + DATA AK02CS( 16) /-.3530507631 1618079458 1548246357 3 D-18 / + DATA AK02CS( 17) /+.4645295422 9351082674 2421633706 6 D-19 / + DATA AK02CS( 18) /-.6368625941 3442664739 2205346133 3 D-20 / + DATA AK02CS( 19) /+.9069521310 9865155676 2234880000 0 D-21 / + DATA AK02CS( 20) /-.1337974785 4236907398 4500531199 9 D-21 / + DATA AK02CS( 21) /+.2039836021 8599523155 2208896000 0 D-22 / + DATA AK02CS( 22) /-.3207027481 3678405000 6086997333 3 D-23 / + DATA AK02CS( 23) /+.5189744413 6623099636 2635946666 6 D-24 / + DATA AK02CS( 24) /-.8629501497 5405721929 6460799999 9 D-25 / + DATA AK02CS( 25) /+.1472161183 1025598552 0803840000 0 D-25 / + DATA AK02CS( 26) /-.2573069023 8670112838 1235199999 9 D-26 / + DATA AK02CS( 27) /+.4601774086 6435165873 7664000000 0 D-27 / + DATA AK02CS( 28) /-.8411555324 2010937371 3066666666 6 D-28 / + DATA AK02CS( 29) /+.1569806306 6353689393 0154666666 6 D-28 / + DATA AK02CS( 30) /-.2988226453 0057577889 7919999999 9 D-29 / + DATA AK02CS( 31) /+.5796831375 2168365206 1866666666 6 D-30 / + DATA AK02CS( 32) /-.1145035994 3476813321 5573333333 3 D-30 / + DATA AK02CS( 33) /+.2301266594 2496828020 0533333333 3 D-31 / + DATA NTK0, NTAK0, NTAK02, XSML / 3*0, 0.0D0 / +C***FIRST EXECUTABLE STATEMENT DBSK0Es + IF (NTK0.NE.0) GO TO 10 +c type *,d1mach(3) + ETA = 1.d-18 + NTK0 = INITDSs (BK0CS, 16, ETA) + NTAK0 = INITDSs (AK0CS, 38, ETA) + NTAK02 = INITDSs (AK02CS, 33, ETA) + XSML = 1.d-9 +c type *,xsml +C + 10 IF (X.LE.0.D0) write(6,*)'DBSK0Es X IS ZERO OR NEGATIVE' + IF (X.GT.2.0D0) GO TO 20 +C + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBSK0Es = + &DEXP(X)*(-DLOG(0.5D0*X)*DBESI0s(X) - 0.25D0 + + 1DCSEVLs (.5D0*Y-1.D0, BK0CS, NTK0)) + RETURN +C + 20 IF (X.LE.8.D0) DBSK0Es = + &(1.25D0 + DCSEVLs ((16.D0/X-5.D0)/3.D0, + 1AK0CS, NTAK0))/DSQRT(X) + IF (X.GT.8.D0) DBSK0Es = (1.25D0 + + 1DCSEVLs (16.D0/X-1.D0, AK02CS, NTAK02))/DSQRT(X) +C + RETURN + END + DOUBLE PRECISION FUNCTION DBSK1Es(X) +c Stripped of machine-dependent calls- same as CLAMS DBSK1E +C***BEGIN PROLOGUE DBSK1E +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESK1E-S DBSK1E-D),BESSEL FUNCTION, +C EXPONENTIALLY SCALED,HYPERBOLIC BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION,ORDER ONE,SPECIAL FUNCTIONS, +C THIRD KIND +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the exponentially scaled,modified (hyperbolic) +C Bessel function of the third kind of order one (double +C precision). +C***DESCRIPTION +C +C DBSK1E(S) computes the double precision exponentially scaled +C modified (hyperbolic) Bessel function of the third kind of order +C one for positive double precision argument X. +C +C Series for BK1 on the interval 0. to 4.00000E+00 +C with weighted error 9.16E-32 +C log weighted error 31.04 +C significant figures required 30.61 +C decimal places required 31.64 +C +C Series for AK1 on the interval 1.25000E-01 to 5.00000E-01 +C with weighted error 3.07E-32 +C log weighted error 31.51 +C significant figures required 30.71 +C decimal places required 32.30 +C +C Series for AK12 on the interval 0. to 1.25000E-01 +C with weighted error 2.41E-32 +C log weighted error 31.62 +C significant figures required 30.25 +C decimal places required 32.38 +C***REFERENCES (NONE) +C***ROUTINES CALLED DBESI1,DCSEVLs,INITDS +C***END PROLOGUE DBSK1E + DOUBLE PRECISION X, BK1CS(16), AK1CS(38), AK12CS(33), XMIN, + 1XSML, Y, DCSEVLs, DBESI1s,eta + SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML + DATA BK1CS( 1) /+.2530022733 8947770532 5311208685 33 D-1 / + DATA BK1CS( 2) /-.3531559607 7654487566 7238316918 01 D+0 / + DATA BK1CS( 3) /-.1226111808 2265714823 4790679300 42 D+0 / + DATA BK1CS( 4) /-.6975723859 6398643501 8129202960 83 D-2 / + DATA BK1CS( 5) /-.1730288957 5130520630 1765073689 79 D-3 / + DATA BK1CS( 6) /-.2433406141 5659682349 6007350301 64 D-5 / + DATA BK1CS( 7) /-.2213387630 7347258558 3152525451 26 D-7 / + DATA BK1CS( 8) /-.1411488392 6335277610 9583302126 08 D-9 / + DATA BK1CS( 9) /-.6666901694 1993290060 8537512643 73 D-12 / + DATA BK1CS( 10) /-.2427449850 5193659339 2631968648 53 D-14 / + DATA BK1CS( 11) /-.7023863479 3862875971 7837971200 00 D-17 / + DATA BK1CS( 12) /-.1654327515 5100994675 4910293333 33 D-19 / + DATA BK1CS( 13) /-.3233834745 9944491991 8933333333 33 D-22 / + DATA BK1CS( 14) /-.5331275052 9265274999 4666666666 66 D-25 / + DATA BK1CS( 15) /-.7513040716 2157226666 6666666666 66 D-28 / + DATA BK1CS( 16) /-.9155085717 6541866666 6666666666 66 D-31 / + DATA AK1CS( 1) /+.2744313406 9738829695 2576662272 66 D+0 / + DATA AK1CS( 2) /+.7571989953 1993678170 8923781492 90 D-1 / + DATA AK1CS( 3) /-.1441051556 4754061229 8531161756 25 D-2 / + DATA AK1CS( 4) /+.6650116955 1257479394 2513854770 36 D-4 / + DATA AK1CS( 5) /-.4369984709 5201407660 5808450891 67 D-5 / + DATA AK1CS( 6) /+.3540277499 7630526799 4171390085 34 D-6 / + DATA AK1CS( 7) /-.3311163779 2932920208 9826882457 04 D-7 / + DATA AK1CS( 8) /+.3445977581 9010534532 3114997709 92 D-8 / + DATA AK1CS( 9) /-.3898932347 4754271048 9819374927 58 D-9 / + DATA AK1CS( 10) /+.4720819750 4658356400 9474493390 05 D-10 / + DATA AK1CS( 11) /-.6047835662 8753562345 3735915628 90 D-11 / + DATA AK1CS( 12) /+.8128494874 8658747888 1938379856 63 D-12 / + DATA AK1CS( 13) /-.1138694574 7147891428 9239159510 42 D-12 / + DATA AK1CS( 14) /+.1654035840 8462282325 9729482050 90 D-13 / + DATA AK1CS( 15) /-.2480902567 7068848221 5160104405 33 D-14 / + DATA AK1CS( 16) /+.3829237890 7024096948 4292272991 57 D-15 / + DATA AK1CS( 17) /-.6064734104 0012418187 7682103773 86 D-16 / + DATA AK1CS( 18) /+.9832425623 2648616038 1940046506 66 D-17 / + DATA AK1CS( 19) /-.1628416873 8284380035 6666201156 26 D-17 / + DATA AK1CS( 20) /+.2750153649 6752623718 2841203370 66 D-18 / + DATA AK1CS( 21) /-.4728966646 3953250924 2810695680 00 D-19 / + DATA AK1CS( 22) /+.8268150002 8109932722 3920503466 66 D-20 / + DATA AK1CS( 23) /-.1468140513 6624956337 1939648853 33 D-20 / + DATA AK1CS( 24) /+.2644763926 9208245978 0858948266 66 D-21 / + DATA AK1CS( 25) /-.4829015756 4856387897 9698688000 00 D-22 / + DATA AK1CS( 26) /+.8929302074 3610130180 6563327999 99 D-23 / + DATA AK1CS( 27) /-.1670839716 8972517176 9977514666 66 D-23 / + DATA AK1CS( 28) /+.3161645603 4040694931 3686186666 66 D-24 / + DATA AK1CS( 29) /-.6046205531 2274989106 5064106666 66 D-25 / + DATA AK1CS( 30) /+.1167879894 2042732700 7184213333 33 D-25 / + DATA AK1CS( 31) /-.2277374158 2653996232 8678400000 00 D-26 / + DATA AK1CS( 32) /+.4481109730 0773675795 3058133333 33 D-27 / + DATA AK1CS( 33) /-.8893288476 9020194062 3360000000 00 D-28 / + DATA AK1CS( 34) /+.1779468001 8850275131 3920000000 00 D-28 / + DATA AK1CS( 35) /-.3588455596 7329095821 9946666666 66 D-29 / + DATA AK1CS( 36) /+.7290629049 2694257991 6799999999 99 D-30 / + DATA AK1CS( 37) /-.1491844984 5546227073 0240000000 00 D-30 / + DATA AK1CS( 38) /+.3073657387 2934276300 7999999999 99 D-31 / + DATA AK12CS( 1) /+.6379308343 7390010366 0048853410 2 D-1 / + DATA AK12CS( 2) /+.2832887813 0497209358 3503028470 8 D-1 / + DATA AK12CS( 3) /-.2475370673 9052503454 1454556673 2 D-3 / + DATA AK12CS( 4) /+.5771972451 6072488204 7097662576 3 D-5 / + DATA AK12CS( 5) /-.2068939219 5365483027 4553319655 2 D-6 / + DATA AK12CS( 6) /+.9739983441 3818041803 0921309788 7 D-8 / + DATA AK12CS( 7) /-.5585336140 3806249846 8889551112 9 D-9 / + DATA AK12CS( 8) /+.3732996634 0461852402 2121285473 1 D-10 / + DATA AK12CS( 9) /-.2825051961 0232254451 3506575492 8 D-11 / + DATA AK12CS( 10) /+.2372019002 4841441736 4349695548 6 D-12 / + DATA AK12CS( 11) /-.2176677387 9917539792 6830166793 8 D-13 / + DATA AK12CS( 12) /+.2157914161 6160324539 3956268970 6 D-14 / + DATA AK12CS( 13) /-.2290196930 7182692759 9155133815 4 D-15 / + DATA AK12CS( 14) /+.2582885729 8232749619 1993956522 6 D-16 / + DATA AK12CS( 15) /-.3076752641 2684631876 2109817344 0 D-17 / + DATA AK12CS( 16) /+.3851487721 2804915970 9489684479 9 D-18 / + DATA AK12CS( 17) /-.5044794897 6415289771 1728250880 0 D-19 / + DATA AK12CS( 18) /+.6888673850 4185442370 1829222399 9 D-20 / + DATA AK12CS( 19) /-.9775041541 9501183030 0213248000 0 D-21 / + DATA AK12CS( 20) /+.1437416218 5238364610 0165973333 3 D-21 / + DATA AK12CS( 21) /-.2185059497 3443473734 9973333333 3 D-22 / + DATA AK12CS( 22) /+.3426245621 8092206316 4538880000 0 D-23 / + DATA AK12CS( 23) /-.5531064394 2464082325 0124800000 0 D-24 / + DATA AK12CS( 24) /+.9176601505 6859954037 8282666666 6 D-25 / + DATA AK12CS( 25) /-.1562287203 6180249114 4874666666 6 D-25 / + DATA AK12CS( 26) /+.2725419375 4843331323 4943999999 9 D-26 / + DATA AK12CS( 27) /-.4865674910 0748279923 7802666666 6 D-27 / + DATA AK12CS( 28) /+.8879388552 7235025873 5786666666 6 D-28 / + DATA AK12CS( 29) /-.1654585918 0392575489 3653333333 3 D-28 / + DATA AK12CS( 30) /+.3145111321 3578486743 0399999999 9 D-29 / + DATA AK12CS( 31) /-.6092998312 1931276124 1600000000 0 D-30 / + DATA AK12CS( 32) /+.1202021939 3698158346 2399999999 9 D-30 / + DATA AK12CS( 33) /-.2412930801 4594088413 8666666666 6 D-31 / + DATA NTK1, NTAK1, NTAK12, XMIN, XSML / 3*0, 2*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBSK1Es + IF (NTK1.NE.0) GO TO 10 +c ETA = 0.1*SNGL(D1MACH(3)) + eta=1.4d-18 + NTK1 = INITDSs (BK1CS, 16, ETA) + NTAK1 = INITDSs (AK1CS, 38, ETA) + NTAK12 = INITDSs (AK12CS, 33, ETA) +C +c XMIN = DEXP (DMAX1(DLOG(D1MACH(1)), -DLOG(D1MACH(2))) + 0.01D0) + xmin=5.94d-39 +c XSML = DSQRT (4.0D0*D1MACH(3)) + xsml=7.5d-9 +C + 10 IF (X.LE.0.D0) write(6,*)'DBSK1Es X IS ZERO OR NEGATIVE' + IF (X.GT.2.0D0) GO TO 20 +C + IF (X.LT.XMIN) write(6,*)'DBSK1Es X SO SMALL K1 OVERFLOWS' + Y = 0.D0 + IF (X.GT.XSML) Y = X*X + DBSK1Es = DEXP(X)*(DLOG(0.5D0*X)*DBESI1s(X) + (0.75D0 + + 1DCSEVLs (0.5D0*Y-1.D0, BK1CS, NTK1))/X ) + RETURN +C + 20 IF (X.LE.8.D0) DBSK1Es = + &(1.25D0 + DCSEVLs ((16.D0/X-5.D0)/3.D0, + 1AK1CS, NTAK1))/DSQRT(X) + IF (X.GT.8.D0) DBSK1Es = (1.25D0 + + 1DCSEVLs (16.D0/X-1.D0, AK12CS, NTAK12))/DSQRT(X) +C + RETURN + END + DOUBLE PRECISION FUNCTION DBESK1s(X) +C***BEGIN PROLOGUE DBESK1 +C***DATE WRITTEN 770701 (YYMMDD) +C***REVISION DATE 861211 (YYMMDD) +C***CATEGORY NO. C10B1 +C***KEYWORDS LIBRARY=SLATEC(FNLIB), +C TYPE=DOUBLE PRECISION(BESK1-S DBESK1-D),BESSEL FUNCTION, +C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, +C ORDER ONE,SPECIAL FUNCTIONS,THIRD KIND +C***AUTHOR FULLERTON, W., (LANL) +C***PURPOSE Computes the dp modified Bessel function of the third kind +C of order one. +C***DESCRIPTION +C +C DBESK1(X) calculates the double precision modified (hyperbolic) +C Bessel function of the third kind of order one for double precision +C argument X. The argument must be large enough that the result does +C not overflow and small enough that the result does not underflow. +C +C Series for BK1 on the interval 0. to 4.00000E+00 +C with weighted error 9.16E-32 +C log weighted error 31.04 +C significant figures required 30.61 +C decimal places required 31.64 +C***REFERENCES (NONE) +C***ROUTINES CALLED D1MACH,DBESI1,DBSK1E,DCSEVL,INITDS,XERROR +C***END PROLOGUE DBESK1 + DOUBLE PRECISION X, BK1CS(16), XMAX, XMIN, XSML, Y, + 1DCSEVLs, DBESI1s, DBSK1Es + SAVE BK1CS, NTK1, XMIN, XSML, XMAX + DATA BK1CS( 1) /+.2530022733 8947770532 5311208685 33 D-1 / + DATA BK1CS( 2) /-.3531559607 7654487566 7238316918 01 D+0 / + DATA BK1CS( 3) /-.1226111808 2265714823 4790679300 42 D+0 / + DATA BK1CS( 4) /-.6975723859 6398643501 8129202960 83 D-2 / + DATA BK1CS( 5) /-.1730288957 5130520630 1765073689 79 D-3 / + DATA BK1CS( 6) /-.2433406141 5659682349 6007350301 64 D-5 / + DATA BK1CS( 7) /-.2213387630 7347258558 3152525451 26 D-7 / + DATA BK1CS( 8) /-.1411488392 6335277610 9583302126 08 D-9 / + DATA BK1CS( 9) /-.6666901694 1993290060 8537512643 73 D-12 / + DATA BK1CS( 10) /-.2427449850 5193659339 2631968648 53 D-14 / + DATA BK1CS( 11) /-.7023863479 3862875971 7837971200 00 D-17 / + DATA BK1CS( 12) /-.1654327515 5100994675 4910293333 33 D-19 / + DATA BK1CS( 13) /-.3233834745 9944491991 8933333333 33 D-22 / + DATA BK1CS( 14) /-.5331275052 9265274999 4666666666 66 D-25 / + DATA BK1CS( 15) /-.7513040716 2157226666 6666666666 66 D-28 / + DATA BK1CS( 16) /-.9155085717 6541866666 6666666666 66 D-31 / + DATA NTK1, XMIN, XSML, XMAX / 0, 3*0.D0 / +C***FIRST EXECUTABLE STATEMENT DBESK1s + IF (NTK1.NE.0) GO TO 10 + NTK1 = INITDSs (BK1CS, 16, 1.4d-18) +c XMIN = DEXP (DMAX1(DLOG(D1MACH(1)), -DLOG(D1MACH(2))) + 0.01D0) + xmin=5.94d-39 + xsml=7.5d-9 +c XSML = DSQRT (4.0D0*D1MACH(3)) +c XMAX = -DLOG(D1MACH(1)) +c XMAX = XMAX - 0.5D0*XMAX*DLOG(XMAX)/(XMAX+0.5D0) + xmax=86.4d0 +C + 10 IF (X.LE.0.D0) go to 1001 + IF (X.GT.2.0D0) GO TO 20 +C + IF (X.LT.XMIN) write(6,*)'DBESK1s X SO SMALL K1 OVERFLOWS' + Y=0.d0 + IF (X.GT.XSML) Y = X*X + DBESK1s = DLOG(0.5D0*X)*DBESI1s(X) + + &(0.75D0 + DCSEVLs(.5D0*Y-1.D0, + 1BK1CS, NTK1))/X + RETURN +C + 20 DBESK1s = 0.D0 + IF (X.GT.XMAX) write(6,*)'DBESK1s X SO BIG K1 UNDERFLOWS' + IF (X.GT.XMAX) RETURN +C + DBESK1s = DEXP(-X) * DBSK1Es(X) +C + RETURN + 1001 write(6,*)'DBESK1s X IS ZERO OR NEGATIVE- stopped' + stop + END + subroutine BESSKn(M,N,X,y,KODE) + implicit double precision(a-h,o-z) +c Calculates an M-member sequence of modified Bessel functions of the +c 2ndkind. Needs subroutines for exponentially scaled and unscaled +c K_0(x) and K1(x). +c Sequence contains either unscaled or scaled Bessel functions. +c KODE=1 means unscaled. +c KODE=2 means scaled. +c y(k), k=1,2,..m contains K_N (x),K_N+1 (x),...K_N+M-1 (x) +c N must be > or = 0. + dimension y(m) + IF (N.LT.0) go to 1001 + if(kode.eq.2) bkm=dbsk0es(x) + if(kode.eq.2) bk=dbsk1es(x) + if(kode.eq.1) bkm=dbesk0s(x) + if(kode.eq.1) bk=dbesk1s(x) + if(n.gt.1) go to 64 + if(n.gt.0) go to 63 +c n=0 + y(1)=bkm + if(m.lt.2) return + y(2)=bk + if(m.lt.3) return + lmin=3 + go to 64 +c n=1 + 63 y(1)=bk + if(m.lt.2) return + lmin=2 + 64 n2=n+m-1 + if(n.gt.1) lmin=1 + tox=2.d0/x + do 61 j=1,n2-1 + bkp=bkm+dfloat(j)*tox*bk + bkm=bk + bk=bkp + do 62 l=lmin,m + jj=n+l-2 + 62 if(jj.eq.j) y(l)=bk + 61 continue + return + 1001 write(6,*) 'Stopped in BESSKn- N<0: N=',N + stop + end +c +c*********************************** +c diff --git a/OpticsJan2020/MLI_light_optics/Src/liea.f b/OpticsJan2020/MLI_light_optics/Src/liea.f new file mode 100644 index 0000000..4f2aef5 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/liea.f @@ -0,0 +1,1900 @@ +************************************************************************ +* header: LIE ALGEBRAIC * +* Lie algebraic manipulations: Poisson brackets, etc. * +************************************************************************ +c + subroutine brkts(h) +c +c computes poisson brackets of total +c lattice generator h with each +c dynamical variable z(i) +c pbh(j,i=1,6) contains +c exp(:h3:) exp(:h4:) exp(:h5:) exp(:h6:) z(i) +c truncated to sixth order ( for marylie 5.0 ) +c +c + use rays + use lieaparam, only : monoms + include 'impli.inc' + include 'pbkh.inc' + include 'ind.inc' + include 'lims.inc' +cryne 7/23/2002 implicit double precision (a-h,o-z) +c double precision tmh(6,6) + dimension h(923),pb1(923),pb2(923),pb3(923),pb4(923),pb5(923) +cryne 7/23/2002 common /pbkh/ pbh(923,12) +cryne 7/23/2002 common/ind/imaxi,jv(923),index1(923),index2(923) +cryne 7/23/2002 integer bottom(0:12),top(0:12) +cryne 7/23/2002 common/lims/bottom,top +c +c if(idproc.eq.0)write(6,*)'inside brkts' +c +c initialize arrays +c + do 10 i=1,923 + pb1(i)=0.0d0 + pb2(i)=0.0d0 + pb3(i)=0.0d0 + do 20 j=1,12 + pbh(i,j)=0.0d0 + 20 continue + 10 continue +c +c if(idproc.eq.0)write(6,*)'done with initialization' + do i=1,27 + if(h(i).ne.h(i))write(6,*)'warning: element undefined:',i + enddo +c +c compute poisson brackets and store in pbh +c + do 100 iz = 1,6 +c if(idproc.eq.0)write(6,*)'do 100; iz=',iz + do 110 i=1,923 + pb1(i) = 0.d0 + 110 continue + pb1(iz)=1.d0 + do 200 ideg = imaxi,3,-1 + call exphf(h,ideg,pb1,imaxi,pb2) + do 220 i=1,top(imaxi) + pb1(i) = pb2(i) + 220 continue + 200 continue + do 300 i = 1,top(imaxi) + pbh(i,iz) = pb1(i) + 300 continue + 100 continue +c if(idproc.eq.0)write(6,*)'done with do 100' +c debug = 0 +c if ( debug .eq. 1) then +c do 7 i=1,6 +c do 70 j=1,6 +c 70 if(tmh(i,j) .ne. 0.d0 ) write(36,*) i,j,tmh(i,j) +c do 7 no = 2,6 +c call xform5(pbh(1,i),no,tmh,pb1) +c do 7 j=bottom(no),top(no) +c if(pb1(j).ne.0.d0 ) write(36,*) i,j,pb1(j) +c 7 continue +c endif +c +cryne 8/6/2002 +c pbh6=0.d0 +c do i=7,top(imaxi) +c do j=1,6 +c pbh6(i,j)=pbh(i,j) +c enddo +c enddo +c if(idproc.eq.0)write(6,*)'here I am before alloc check' + if(allocated(pbh6t))then +c if(idproc.eq.0)write(6,*)'pbh6t is already allocated' + pbh6t=0.d0 + do i=7,top(imaxi) + do j=1,6 + pbh6t(j,i)=pbh(i,j) + enddo + enddo + endif +c if(idproc.eq.0)write(6,*)'done with final do loop' +c if(idproc.eq.0) then +c write(6,*) ' === liea::brkts() ===' +c write(6,'(a)') ' pbh6t(:) =' +c do i=1,top(imaxi) +c write(6,123) i,(pbh6t(j,i),j=1,6) +c123 format(i4,6(1x,1pe16.9)) +c enddo +c write(6,*) ' leaving liea::brkts()' +c write(6,*) ' =====================' +c end if + return + end +c +************************************************************************ +c + subroutine clear(h,mh) +c Clears to zero the polynomials h and the matrix mh. +c Written by Liam Healy, June 12, 1984. + use lieaparam, only : monoms + double precision mh(6,6),h(monoms) +c Clear out polynomial coefficients: + do 120 i=1,monoms + 120 h(i)=0. +c Clear out matrix: + do 100 i=1,6 + do 100 j=1,6 + 100 mh(i,j)=0. + return + end +*********************************************************************** +c + subroutine concat(fa,fm,ga,gm,ha,hm) +c + use lieaparam, only : monoms + include 'impli.inc' +c +c variables +c + + dimension fa(923),fm(6,6) + dimension ga(923),gm(6,6) + dimension ha(923),hm(6,6) + dimension ha1(923),hm1(6,6) +c +c write(6,*) 'first factor in concat is' +c call pcmap(1,1,0,0,fa,fm) +c write(6,*) 'second factor in concat is' +c call pcmap(1,1,0,0,ga,gm) +c + maxcat = 6 + call drcat(fa,fm,ga,gm,ha1,hm1) +c +c write(6,*) 'result of concat is' +c call pcmap(1,1,0,0,ha1,hm1) +c + call mapmap(ha1,hm1,ha,hm) +c + return + end +c +******************************************************************** +c + subroutine cpadd(fa,ga,ha) +c this is a subroutine for computing the sum of two polynomials +c Written by Alex Dragt, Fall 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms),ha(monoms) +c +c perform calculation + do 10 j=1,monoms + ha(j)=fa(j)+ga(j) + 10 continue +c + return + end +c +************************************************************************ +c + subroutine cpdnf(pow,fa,fm,ga,gm) +c this subroutine computes the power of a dynamic normal form map: +c mapg=(mapf)**pow +c Written by Alex Dragt, Fall 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms) + dimension fm(6,6),gm(6,6) + dimension ta(monoms),t1a(monoms) +c +c clear output array + call clear(t1a,gm) +c +c begin calculation +c +c compute phase advances + cwx=fm(1,1) + swx=fm(1,2) + wx=atan2(swx,cwx) + cwy=fm(3,3) + swy=fm(3,4) + wy=atan2(swy,cwy) + cwt=fm(5,5) + swt=fm(5,6) + wt=atan2(swt,cwt) +c compute new quantities + pwx=pow*wx + cpwx=cos(pwx) + spwx=sin(pwx) + pwy=pow*wy + cpwy=cos(pwy) + spwy=sin(pwy) + pwt=pow*wt + cpwt=cos(pwt) + spwt=sin(pwt) +c compute new matrix + gm(1,1)=cpwx + gm(1,2)=spwx + gm(2,1)=-spwx + gm(2,2)=cpwx + gm(3,3)=cpwy + gm(3,4)=spwy + gm(4,3)=-spwy + gm(4,4)=cpwy + gm(5,5)=cpwt + gm(5,6)=spwt + gm(6,5)=-spwt + gm(6,6)=cpwt +c compute polynomials of old normal form map in dynamic resonance basis + call ctodr(fa,ta) +c pick out those terms which are allowed to be nonzero + t1a(84)=ta(84) + t1a(85)=ta(85) + t1a(86)=ta(86) + t1a(87)=ta(87) + t1a(88)=ta(88) + t1a(89)=ta(89) +c compute polynomials of new map in dynamic resonance basis + call csmul(pow,t1a,t1a) +c transform back to cartesian basis + call drtoc(t1a,ga) +c + return + end +c +******************************************************************** +c + subroutine cppb(fa,ga,ha) +c This subroutine computes the poisson brackets two polynomials +c It gives the result ha=[fa,ga] +c The aray ha is cleared upon entry +c written 5/22/02 AJD +c revised 6/14/02 AJD +c + use lieaparam, only : monoms + include 'impli.inc' +cryne include 'param.inc' +c +c calling arrays +c + dimension fa(monoms) + dimension ga(monoms) + dimension ha(monoms) +c +c working arrays + dimension ta(monoms) + dimension tm(6,6) +c +c clear ha + call clear(ha,tm) +c +c compute Poisson bracket + do if=1,6 !4 changed to 6 + do ig=1,6 !4 changed to 6 + iord=if+ig-2 + if((iord .ge. 0) .and. (iord .le. 6)) then !4 changed to 6 +c clear the result array ta since pbkt does not do so completely + call clear(ta,tm) + call pbkt(fa,if,ga,ig,ta) + call cpadd(ha,ta,ha) + endif + enddo + enddo + return + end +c +******************************************************************** +c + subroutine cpmul(fa,ga,ha) +c Subroutine for computing the product of polynomials +c Written by Alex Dragt, Fall 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms),ha(monoms) +c +c perform calculation + do 10 nf=1,3 + do 20 ng=1,3 + if ((nf+ng).le.4) then + call pprod(fa,nf,ga,ng,ha) + endif + 20 continue + 10 continue +c + return + end +c +************************************************************************ +c + subroutine cpsnf(pow,fa,fm,ga,gm) +c this subroutine computes the power of a static normal form map: +c mapg=(mapf)**pow +c Written by Alex Dragt, Fall 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms) + dimension fm(6,6),gm(6,6) + dimension ta(monoms),t1a(monoms) +c +c clear output array + call clear(t1a,gm) +c +c begin calculation +c +c compute phase advances + cwx=fm(1,1) + swx=fm(1,2) + wx=atan2(swx,cwx) + cwy=fm(3,3) + swy=fm(3,4) + wy=atan2(swy,cwy) +c compute momentum compaction + wt=fm(5,6) +c compute new quantities + pwx=pow*wx + cpwx=cos(pwx) + spwx=sin(pwx) + pwy=pow*wy + cpwy=cos(pwy) + spwy=sin(pwy) + pwt=pow*wt +c compute new matrix + gm(1,1)=cpwx + gm(1,2)=spwx + gm(2,1)=-spwx + gm(2,2)=cpwx + gm(3,3)=cpwy + gm(3,4)=spwy + gm(4,3)=-spwy + gm(4,4)=cpwy + gm(5,5)=1.d0 + gm(5,6)=pwt + gm(6,6)=1.d0 +c compute polynomials of old normal form map in static resonance basis + call ctosr(fa,ta) +c pick out those terms which are allowed to be nonzero + t1a(28)=ta(28) + t1a(29)=ta(29) + t1a(30)=ta(30) + t1a(84)=ta(84) + t1a(85)=ta(85) + t1a(86)=ta(86) + t1a(87)=ta(87) + t1a(88)=ta(88) + t1a(89)=ta(89) +c compute polynomials of new map in static resonance basis + call csmul(pow,t1a,t1a) +c transform back to cartesian basis + call srtoc(t1a,ga) +c + return + end +c +******************************************************************** +c + subroutine csmul(scalar,fa,ga) +c this subroutine computes the scalar multiple of a polynomial +c Written by Alex Dragt, Fall 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms) +c +c perform calculation + do 10 j=1,monoms + ga(j)=scalar*fa(j) + 10 continue +c + return + end +c +*********************************************************************** +c + subroutine drcat(f,mf,g,mg,h,mh) +c concatenates a map with linear piece +c represented by a matrix mf and nonlinearities +c represented by exp:f:, with a map whose +c linear piece has matrix representation mg +c and whose nonlinearities are represented by exp:g: +c +c the result is a map with linearities possessing +c a matrix representation mh=mg*mf +c and with nonlinearities generated by exp:h: +c +c the "f" map is assumed to occur first in the beamline +c the "g" map is encountered second +c + implicit double precision (a-h,o-z) + double precision mf,mg,mh,m + dimension f(923), g(923), h(923) + dimension mf(6,6),mg(6,6),mh(6,6),m(6,6) + dimension f3(923),f4(923),f5(923),f6(923) + dimension t3(923),t4(923),t5(923),t6(923) + include 'symp.inc' +c +c write(6,*) 'first factor in mycat' +c call pcmap(1,1,0,0,f,mf) +c write(6,*) 'second factor in mycat' +c call pcmap(1,1,0,0,g,mg) +c + call ident(h,mh) + do 666 i1=1,923 + t3(i1) = 0.0d0 + 666 continue +c +c compute mh=mg*mf +c + call mmult(mg,mf,mh) +c +c compute m = mginverse +c + call matmat(mg,m) + call minv(m) +c +c compute transformed arrays +c + call xform5(f,3,m,f3) + call xform5(f,4,m,f4) + call xform5(f,5,m,f5) +c +c write(6,*) 'contents of f5 and m' +c call pcmap(1,1,0,0,f5,m) +c + call xform5(f,6,m,f6) +c third order terms + call pmadd(g,3,1.d0,h) + call pmadd(f3,3,1.d0,h) +c fourth order terms + call pbkt1(f3,3,g,3,t4) + call pmadd(g,4,1.d0,h) + call pmadd(f4,4,1.d0,h) + call pmadd(t4,4,.5d0,h) +c fifth order terms + call pmadd(g,5,1.d0,h) + call pmadd(f5,5,1.d0,h) + call pmadd(g,3,1.d0,t3) + call pmadd(f3,3,1.d0/2.d0,t3) + call pbkt1(t3,3,t4,4,t5) + call pmadd(t5,5,-1.d0/3.d0,h) + call pbkt1(g,3,f4,4,t5) + call pmadd(t5,5,-1.d0,h) +c write(6,*) 'result of drcat at end of fifth order' +c call pcmap(1,1,0,0,h,mh) + +c sixth order terms + call pbkt1(g,4,f4,4,t6) + call pmadd(t6,6,-.5d0,h) + call pmadd(g,6,1.d0,h) + call pmadd(f6,6,1.d0,h) + call pbkt1(g,3,f5,5,t6) + call pmadd(t6,6,-1.d0,h) + call pbkt1(f3,3,g,3,t4) + call pbkt1(g,3,t4,4,t5) + call pbkt1(f3,3,t5,5,t6) + call pmadd(t6,6,(-1.d0/24.d0),h) + call pbkt1(h,3,t4,4,t5) + call pbkt1(h,3,t5,5,t6) + call pmadd(t6,6,(1.d0/12.d0),h) + call pbkt1(g,3,f4,4,t5) + call pbkt1(g,3,t5,5,t6) + call pmadd(t6,6,(.5d0),h) + call pbkt1(f4,4,t4,4,t6) + call pmadd(t6,6,-.25d0,h) + call pbkt1(g,4,t4,4,t6) + call pmadd(t6,6,-.25d0,h) + call pbkt1(g,3,t4,4,t5) + call pbkt1(h,3,t5,5,t6) + call pmadd(t6,6,(1.d0/24.d0),h) + call pbkt1(f3,3,t4,4,t5) + call pbkt1(h,3,t5,5,t6) + call pmadd(t6,6,(-1.d0/24.d0),h) +c This is not very efficient, but we are trying to +c make it work before making it fast. +c +c write(6,*) 'result of drcat' +c call pcmap(1,1,0,0,h,mh) +c + return + end +c +*********************************************************************** + + subroutine cpsp(job,f,g,ans1,ans2,ans3,ans4) +c this subroutine computes the scalar product of the two polynomials +c f and g. +c Written by Alex Dragt 10/23/89 +c + use lieaparam, only : monoms + include 'impli.inc' +ccccc include 'param.inc' + include 'expon.inc' +c +c calling arrays + dimension f(*), g(*) +ccccc dimension f(0:monoms), g(0:monoms) +c + integer jf(6),jg(6) +c +c compute scalar products +c +c procedure for USp(6) invariant scalar product +c + if(job .eq. 1) then +c +c first order part +c + ans1=0.d0 + do ind=1,6 + test=f(ind)*g(ind) + if (test .ne. 0.d0) then + do k=1,6 + jf(k)=expon(k,ind) + enddo + call msp1(jf,val) + ans1=ans1+test*val + endif + enddo +c +c second order part +c + ans2=0.d0 + do ind=7,27 + test=f(ind)*g(ind) + if (test .ne. 0.d0) then + do k=1,6 + jf(k)=expon(k,ind) + enddo + call msp1(jf,val) + ans2=ans2+test*val + endif + enddo +c +c third order part +c + ans3=0.d0 + do ind=28,83 + test=f(ind)*g(ind) + if (test .ne. 0.d0) then + do k=1,6 + jf(k)=expon(k,ind) + enddo + call msp1(jf,val) + ans3=ans3+test*val + endif + enddo +c +c fourth order part +c + ans4=0.d0 + do ind=84,209 + test=f(ind)*g(ind) + if (test .ne. 0.d0) then + do k=1,6 + jf(k)=expon(k,ind) + enddo + call msp1(jf,val) + ans4=ans4+test*val + endif + enddo +c + endif +c +c procedure for integration over S^5 invariant scalar product +c + if(job .eq. 2) then +c +c first order part +c + ans1=0.d0 + do 10 indf=1,6 + do 10 indg=1,6 + test=f(indf)*g(indg) + if (test .ne. 0.d0) then + do 12 k=1,6 + jf(k)=expon(k,indf) + jg(k)=expon(k,indg) + 12 continue + call msp2(jf,jg,val) + ans1=ans1+test*val + endif + 10 continue + ans1=ans1/3.d0 +c +c second order part +c + ans2=0.d0 + do 20 indf=7,27 + do 20 indg=7,27 + test=f(indf)*g(indg) + if (test .ne. 0.) then + do 22 k=1,6 + jf(k)=expon(k,indf) + jg(k)=expon(k,indg) + 22 continue + call msp2(jf,jg,val) + ans2=ans2+test*val + endif + 20 continue + ans2=ans2/12.d0 +c +c third order part +c + ans3=0.d0 + do 30 indf=28,83 + do 30 indg=28,83 + test=f(indf)*g(indg) + if (test .ne. 0.d0) then + do 32 k=1,6 + jf(k)=expon(k,indf) + jg(k)=expon(k,indg) + 32 continue + call msp2(jf,jg,val) + ans3=ans3+test*val + endif + 30 continue + ans3=ans3/60.d0 +c +c fourth order part +c + ans4=0.d0 + do 40 indf=84,209 + do 40 indg=84,209 + test=f(indf)*g(indg) + if (test .ne. 0.) then + do 42 k=1,6 + jf(k)=expon(k,indf) + jg(k)=expon(k,indg) + 42 continue + call msp2(jf,jg,val) + ans4=ans4+test*val + endif + 40 continue + ans4=ans4/360.d0 +c + endif +c + return + end + +*********************************************************************** +c + subroutine old_cpsp(f,g,ans1,ans2,ans3,ans4) +c this subroutine computes the scalar product of the two polynomials +c f and g. +c Written by Alex Dragt 10/23/89 +c + use lieaparam, only : monoms + include 'impli.inc' + include 'expon.inc' +c +c calling arrays +ccccc dimension f(209), g(209) + dimension f(*), g(*) +c + integer jf(6),jg(6) +c +c compute inner products +c +c first order part +c + ans1=0.d0 + do 10 indf=1,6 + do 10 indg=1,6 + test=f(indf)*g(indg) + if (test .ne. 0.d0) then + do 12 k=1,6 + jf(k)=expon(k,indf) + jg(k)=expon(k,indg) + 12 continue + call msp(jf,jg,val) + ans1=ans1+test*val + endif + 10 continue + ans1=ans1/3.d0 +c +c second order part +c + ans2=0.d0 + do 20 indf=7,27 + do 20 indg=7,27 + test=f(indf)*g(indg) + if (test .ne. 0.) then + do 22 k=1,6 + jf(k)=expon(k,indf) + jg(k)=expon(k,indg) + 22 continue + call msp(jf,jg,val) + ans2=ans2+test*val + endif + 20 continue + ans2=ans2/12.d0 +c +c third order part +c + ans3=0.d0 + do 30 indf=28,83 + do 30 indg=28,83 + test=f(indf)*g(indg) + if (test .ne. 0.d0) then + do 32 k=1,6 + jf(k)=expon(k,indf) + jg(k)=expon(k,indg) + 32 continue + call msp(jf,jg,val) + ans3=ans3+test*val + endif + 30 continue + ans3=ans3/60.d0 +c +c fourth order part +c + ans4=0.d0 + do 40 indf=84,209 + do 40 indg=84,209 + test=f(indf)*g(indg) + if (test .ne. 0.) then + do 42 k=1,6 + jf(k)=expon(k,indf) + jg(k)=expon(k,indg) + 42 continue + call msp(jf,jg,val) + ans4=ans4+test*val + endif + 40 continue + ans4=ans4/360.d0 +c + return + end +c +*********************************************************************** +c + subroutine evalf(zi,h,val2,val3,val4) +c this subroutine computes the value of the function h(zi) +c Written by Alex Dragt, Fall 1986, based on work of F. Neri + use lieaparam, only : monoms + include 'impli.inc' + dimension zi(6) + dimension h(monoms),avect(monoms) + include 'ind.inc' +c compute vector containing values of basis monomials +cryne call evalm(zi,vect) + call evalm(zi,avect) +c +c the following code has been commented out since it is replaced +c by the use of evalm +c compute linear monomials +c do 10 i=1,6 +c 10 avect(i) = zi(i) +c compute higher order monomials +c do 20 i = 7,monoms +c 20 avect(i) = avect(index1(i))*avect(index2(i)) +c +c compute value of h + val2=0.d0 + do 30 i=1,27 + 30 val2=val2+h(i)*avect(i) + val3=val2 + do 40 i=28,83 + 40 val3=val3+h(i)*avect(i) + val4=val3 + do 50 i=84,209 + 50 val4=val4+h(i)*avect(i) + return + end +c +************************************************************ +c + subroutine evalf_old(zi,h,val2,val3,val4) +c this subroutine computes the value of the function h(zi) +c Written by Alex Dragt, Fall 1986, based on work of F. Neri + use lieaparam, only : monoms + include 'impli.inc' + dimension zi(6) + dimension h(monoms),avect(monoms) + include 'ind.inc' +c compute vector containing values of basis monomials +c compute linear monomials + do 10 i=1,6 + 10 avect(i) = zi(i) +c compute higher order monomials + do 20 i = 7,monoms + 20 avect(i) = avect(index1(i))*avect(index2(i)) +c compute value of h + val2=0.d0 + do 30 i=1,27 + 30 val2=val2+h(i)*avect(i) + val3=val2 + do 40 i=28,83 + 40 val3=val3+h(i)*avect(i) + val4=val3 + do 50 i=84,209 + 50 val4=val4+h(i)*avect(i) + return + end +c +******************************************************************** +c + subroutine evalm(zi,vect) +c this subroutine computes the values of the basis +c monomials and stores them in the vector vect. +c Written by Alex Dragt, 1 July 1991, based on work of F. Neri +c + use lieaparam, only : monoms + include 'impli.inc' + include 'ind.inc' +c +c calling arrays + dimension zi(6) + dimension vect(monoms) +c +c compute linear monomials + do 10 i=1,6 + 10 vect(i) = zi(i) +c compute higher order monomials + do i = 7,27 + vect(i) = vect(index1(i))*vect(index2(i)) + enddo + do i = 28,209 + vect(i) = vect(index1(i))*vect(index2(i)) + enddo + do i = 210,monoms + vect(i) = vect(index1(i))*vect(index2(i)) + enddo +c + return + end +c + subroutine exphf(h,ideg,f,maxf,trf) +c Applies Exp(:h:) on polynomial f. +c h is a polynomial of degree ideg. +c f has terms from 1 thru maxf. +c The result is trf, which has terms 1-maxf. +c +c Written By F. Neri 9/26/86. +c + include 'lims.inc' + double precision f(923),h(923),trf(923) + double precision tmpf1(923),tmpf2(923) +c maxf has to be .le. 6. + integer maxf + integer maxpow, ifact, maxord +cryne 7/23/2002 integer bottom(0:12),top(0:12) +cryne 7/23/2002 common/lims/bottom,top + do 1 i=1,top(maxf) + tmpf1(i) = f(i) + 1 continue + do 3 i = 1,top(maxf) + trf(i) = f(i) + 3 continue + maxpow = int((maxf-1)/(ideg-2)) + ifact = 1 + do 10 n=1,maxpow + ifact = ifact * (-n) + maxord = int(maxf - (ideg-2) ) + do 11 i=1,top(maxf) + tmpf2(i) = 0.d0 + 11 continue + do 20 iord=maxord,1,-1 + call pbkt(tmpf1,iord,h,ideg,tmpf2) + call pmadd(tmpf2,iord+ideg-2,(1.d0/ifact),trf) + 20 continue + do 30 i=1,top(maxf) + tmpf1(i) = tmpf2(i) + 30 continue + 10 continue + return + end +c +****************************************************************** +c + subroutine fxform(ga,gm,fa,ha) +c this is a subroutine for transforming a function f. +c that is, it computes h=exp(:g:)f where f is given +c by f=f2+f3+f4 and exp(:g:) denotes a general map. +c Written by Alex Dragt, Fall 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension ga(monoms),fa(monoms),ha(monoms),t1a(monoms), + & t2a(monoms),t3a(monoms) + dimension gm(6,6),tm(6,6) +c clear arrays + call clear(t1a,tm) + call clear(t2a,tm) + call clear(t3a,tm) + call clear(ha,tm) +c compute [g3,f2] + call pbkt(ga,3,fa,2,t1a) +c compute [g3,f3] + call pbkt(ga,3,fa,3,t2a) +c compute [g3,[g3,f2]] + call pbkt(ga,3,t1a,3,t3a) +c compute [g4,f2] + call pbkt(ga,4,fa,2,t1a) +c accumulate results +c set up second order part + do 10 i=7,27 + 10 t1a(i)=fa(i) +c set up third order part + do 20 i=28,83 + 20 t1a(i)=fa(i) + t1a(i) +c set up fourth order part + do 30 i=84,209 + 30 t1a(i)=fa(i) + t2a(i) + t3a(i)/2.d0 + t1a(i) +c transform results by gm + call xform(t1a,2,gm,0,ha) + call xform(t1a,3,gm,1,ha) + call xform(t1a,4,gm,1,ha) + return + end +c + subroutine mapmap(rh,rmh,th,tmh) +c Written by Rob Ryne, ca 1982 + use lieaparam, only : monoms + include 'impli.inc' + dimension rh(monoms),th(monoms),rmh(6,6),tmh(6,6) + do 10 i=1,6 + do 10 j=1,6 + 10 tmh(i,j)=rmh(i,j) + do 20 i=1,monoms + 20 th(i)=rh(i) +c + return + end +c +*********************************************************************** +c + subroutine matify(matrix,f2) +c Computes the matrix that corresponds to :f2:. +c It is written in a simple-minded manner to keep execution time short. +c Written by Liam Healy, May 29, 1985. +c +c----Variables---- +c implicit none +c matrix = matrix supplied + double precision matrix(6,6) +c f2 = array of coefficients giving f2 values (others are ignored) + double precision f2(*) +c +c----Routine---- + matrix(1,1)=-f2(8) + matrix(1,2)=-2.*f2(13) + matrix(1,3)=-f2(14) + matrix(1,4)=-f2(15) + matrix(1,5)=-f2(16) + matrix(1,6)=-f2(17) + matrix(2,1)=2.*f2(7) + matrix(2,2)=f2(8) + matrix(2,3)=f2(9) + matrix(2,4)=f2(10) + matrix(2,5)=f2(11) + matrix(2,6)=f2(12) + matrix(3,1)=-f2(10) + matrix(3,2)=-f2(15) + matrix(3,3)=-f2(19) + matrix(3,4)=-2.*f2(22) + matrix(3,5)=-f2(23) + matrix(3,6)=-f2(24) + matrix(4,1)=f2(9) + matrix(4,2)=f2(14) + matrix(4,3)=2*f2(18) + matrix(4,4)=f2(19) + matrix(4,5)=f2(20) + matrix(4,6)=f2(21) + matrix(5,1)=-f2(12) + matrix(5,2)=-f2(17) + matrix(5,3)=-f2(21) + matrix(5,4)=-f2(24) + matrix(5,5)=-f2(26) + matrix(5,6)=-2.*f2(27) + matrix(6,1)=f2(11) + matrix(6,2)=f2(16) + matrix(6,3)=f2(20) + matrix(6,4)=f2(23) + matrix(6,5)=2.*f2(25) + matrix(6,6)=f2(26) + return + end +c +*********************************************************************** +c + subroutine mclear(mh) +c +c Clears to zero the matrix mh. +c Written by Liam Healy, June 12, 1984. +c + double precision mh(6,6) +c + do 100 i=1,6 + do 100 j=1,6 + 100 mh(i,j)=0.d0 + return + end +c +*********************************************************************** +c +c +*********************************************************************** +c + subroutine mident(mh) +c +c Sets mh to the identity matrix. +c + double precision mh(6,6) +c + call mclear(mh) +c + do 100 i=1,6 + 100 mh(i,i)=1.d0 +c + return + end +c +************************************************************************ +c + subroutine minv(fm) +c Returns the inverse of the matrix fm on the +c assumption that fm is symplectic. +c Written by Alex Dragt, 4 October 1989. +c + include 'impli.inc' + include 'symp.inc' +c +c Calling array + dimension fm(6,6) +c +c Temporary arrays + dimension temp(6,6) +c +c----Routine---- +c +c Calculate (fm transpose)*jm +c + call mclear(temp) + do 120 j=1,6 + do 120 k=1,6 + do 120 l=1,6 + 120 temp(j,k)=temp(j,k)+fm(l,j)*jm(l,k) +c +c Calculate (jm transpose)*(fm transpose)*jm +c + call mclear(fm) + do 140 j=1,6 + do 140 l=1,6 + do 140 k=1,6 + 140 fm(j,k)=fm(j,k)+jm(l,j)*temp(l,k) +c + return + end +c +*********************************************************************** +c + subroutine mycat(maxcat,f,mf,g,mg,h,mh) +c concatenates a map with linear piece +c represented by a matrix mf and nonlinearities +c represented by exp:f:, with a map whose +c linear piece has matrix representation mg +c and whose nonlinearities are represented by exp:g: +c +c the result is a map with linearities possessing +c a matrix representation mh=mg*mf +c and with nonlinearities generated by exp:h: +c +c the "f" map is assumed to occur first in the beamline +c the "g" map is encountered second +c + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' + include 'symp.inc' + include 'ind.inc' + double precision j4,mf,mg,mh,m,l3,l4 + dimension mf(6,6),mg(6,6),mh(6,6),temp(6,6),m(6,6) + dimension f(monoms), g(monoms), h(monoms) + dimension f3(monom2),f4(monom2),f5(monom1),f6(monoms) + dimension t3(monom2),t4(monom2),t5(monom1),t6(monoms) +cryne 7/23/2002 implicit double precision (a-h,o-z) +cryne 7/23/2002 dimension f(923), g(923), h(923) +cryne 7/23/2002 dimension f3(209),f4(209),f5(461),f6(923) +cryne 7/23/2002 dimension t3(209),t4(209),t5(461),t6(923) +cryne 7/23/2002 common /ind/imaxi,jv(923),index1(923),index2(923) +c + write(6,*) 'first factor in mycat' + call pcmap(1,1,0,0,f,mf) + write(6,*) 'second factor in mycat' + call pcmap(1,1,0,0,g,mg) +c + call ident(h,mh) + do 666 i1=1,209 + t3(i1) = 0.0d0 + 666 continue + do 777 i1=1,6 + do 777 i2=1,6 + m(i1,i2)=0.d0 + mh(i1,i2) = 0.d0 + temp(i1,i2) = 0.d0 + 777 continue +c +c compute mh=mg*mf and temp=mgtransposed*jm +c + do 40 j=1,6 + do 30 k=1,6 + do 20 l=1,6 + mh(j,k)=mh(j,k)+mg(j,l)*mf(l,k) + temp(j,k)=temp(j,k)+mg(l,j)*jm(l,k) + 20 continue + 30 continue + 40 continue +c +c compute m=inverse of mg=jmtransposed*temp +c + do 41 j=1,6 + do 31 k=1,6 + do 21 l=1,6 + m(j,k)=m(j,k)+jm(l,j)*temp(l,k) + 21 continue + 31 continue + 41 continue +c +c compute transformed arrays +c + call xform5(f,3,m,f3) + call xform5(f,4,m,f4) + if(maxcat.gt.4) call xform5(f,5,m,f5) + if(maxcat.gt.5) call xform5(f,6,m,f6) +c third order terms + call pmadd(g,3,1.d0,h) + call pmadd(f3,3,1.d0,h) +c fourth order terms + call pbkt1(f3,3,g,3,t4) + call pmadd(g,4,1.d0,h) + call pmadd(f4,4,1.d0,h) + call pmadd(t4,4,.5d0,h) +c fifth order terms + if(maxcat.gt.4) then + call pmadd(g,5,1.d0,h) + call pmadd(f5,5,1.d0,h) + call pmadd(g,3,1.d0,t3) + call pmadd(f3,3,1.d0/2.d0,t3) + call pbkt1(t3,3,t4,4,t5) + call pmadd(t5,5,-1.d0/3.d0,h) + call pbkt1(g,3,f4,4,t5) + call pmadd(t5,5,-1.d0,h) + endif +c sixth order terms + if(maxcat.gt.5) then + call pbkt1(g,4,f4,4,t6) + call pmadd(t6,6,-.5d0,h) + call pmadd(g,6,1.d0,h) + call pmadd(f6,6,1.d0,h) + call pbkt1(g,3,f5,5,t6) + call pmadd(t6,6,-1.d0,h) + call pbkt1(f3,3,g,3,t4) + call pbkt1(g,3,t4,4,t5) + call pbkt1(f3,3,t5,5,t6) + call pmadd(t6,6,(-1.d0/24.d0),h) + call pbkt1(h,3,t4,4,t5) + call pbkt1(h,3,t5,5,t6) + call pmadd(t6,6,(1.d0/12.d0),h) + call pbkt1(g,3,f4,4,t5) + call pbkt1(g,3,t5,5,t6) + call pmadd(t6,6,(.5d0),h) + call pbkt1(f4,4,t4,4,t6) + call pmadd(t6,6,-.25d0,h) + call pbkt1(g,4,t4,4,t6) + call pmadd(t6,6,-.25d0,h) + call pbkt1(g,3,t4,4,t5) + call pbkt1(h,3,t5,5,t6) + call pmadd(t6,6,(1.d0/24.d0),h) + call pbkt1(f3,3,t4,4,t5) + call pbkt1(h,3,t5,5,t6) + call pmadd(t6,6,(-1.d0/24.d0),h) +c This is not very efficient, but we are trying to +c make it work before making it fast. + endif +c + write(6,*) 'result of mycat' + call pcmap(1,1,0,0,h,mh) +c + return + end +c +*********************************************************************** +c + subroutine msp(j1,j2,val) +c Calculated the scalar product of two monomials having exponent +c arrays j1 and j2. +c Written by Alex Dragt 10/22/89 +c + include 'impli.inc' +c +c calling arrays + integer j1(6),j2(6) +c + integer jt(6) +c + do 10 i=1,6 + 10 jt(i)=j1(i)+j2(i) + call s5i(jt,val) +c + return + end +c +*********************************************************************** +c + subroutine msp1(j1,val) +c For a monomial having exponent array j1, calculates +c the USp(6) invariant scalar product of the monomial +c with itself. +c Written by Alex Dragt 2/18/03. +c + include 'impli.inc' +c +c calling arrays + integer j1(6) +c +c procedure for computing j1! +c + val=1.d0 + do i=1,6 + ipow=j1(i) + call factfn(ipow,coefi) + val=val*coefi + enddo +c + return + end +c +*********************************************************************** +c + subroutine msp2(j1,j2,val) +c Calculates the S^5 invariant scalar product of two monomials +c having exponent arrays j1 and j2. +c Written by Alex Dragt 10/22/89 +c + include 'impli.inc' +c +c calling arrays + integer j1(6),j2(6) +c + integer jt(6) +c + do 10 i=1,6 + 10 jt(i)=j1(i)+j2(i) + call s5i(jt,val) +c + return + end +*********************************************************************** +c + subroutine factfn(intg,val) +c +c This subroutine finds val=intg! +c Written by Alex Dragt 2/18/03 +c + include 'impli.inc' +c + dimension table(0:6) +c + data table/1.d0,1.d0,2.d0,6.d0,24.d0,120.d0,720.d0/ +c + val=table(intg) +c + return + end + +*********************************************************************** +c + subroutine pbkt(f,ordf,g,ordg,pb) +c Calculates the Poisson Bracket of the order ordf part of f with +c the order ordg part of g, leaving the result in pb. +c Written by Liam Healy, November 26, 1984. +c + use lieaparam, only : monoms +c----Variables---- +c f,g,pb = two arrays and their Poisson bracket + double precision f(*),g(*),pb(*) +c ordf,ordg = order desired from f and g + integer ordf,ordg +c indf,indg,indpb = index in f,g and pb + integer indf,indg,indpb +c pr = array of exponents for the product of f(indf) and g(indg) +c prd =copy of pr +c prx, prp = exponents of particular x, p variables, from pr + integer pr(6),prd(6),prx,prp +c xvb, pvb, vbl = x variable, p variable (pvb=xvb+1), variable number + integer xvb,pvb,vbl + include 'expon.inc' + include 'lims.inc' +c +c----Routine---- +c initialize array pb + do 80 indpb=bottom(ordf+ordg-2),top(ordf+ordg-2) + 80 pb(indpb)=0. +c pick individual indf and indg, find what element of pb it affects, +c and calculate the new value. Loop for all indeces in the specified +c orders. + do 100 indf=bottom(ordf),top(ordf) + if (f(indf).ne.0.) then + do 120 indg=bottom(ordg),top(ordg) + if (g(indg).ne.0.) then +c load sum of exponents into pr + do 140 vbl=1,6 + 140 pr(vbl)=expon(vbl,indf)+expon(vbl,indg) + do 160 xvb=1,5,2 +c go through three axes; for each one that pb can +c be taken, modify appropriate element of pb. + pvb=xvb+1 + do 180 vbl=1,6 + 180 prd(vbl)=pr(vbl) + prx=prd(xvb) + prp=prd(pvb) + if (prx*prp.gt.0) then + prd(xvb)=prx-1 + prd(pvb)=prp-1 + indpb=ndex(prd) + pb(indpb)=pb(indpb)+f(indf)*g(indg) + & *(expon(xvb,indf)*expon(pvb,indg) + & -expon(pvb,indf)*expon(xvb,indg)) + endif + 160 continue + endif + 120 continue + endif + 100 continue + return + end +c + subroutine pbkt1(f,ordf,g,ordg,pb) +c Calculates the Poisson Bracket of the order ordf part of f with +c the order ordg part of g, leaving the result in pb. +c + use lieaparam, only : monoms,monom1 + include 'iprod.inc' + include 'expon.inc' + include 'lims.inc' + include 'prodex.inc' +c----Variables---- +c f,g,pb = two arrays and their Poisson bracket + double precision f(*),g(*),pb(*) +c ordf,ordg = order desired from f and g + integer ordf,ordg +c indf,indg,indpb = index in f,g and pb + integer indf,indg,indpb +c pr = array of exponents for the product of f(indf) and g(indg) +c prd =copy of pr +c prx, prp = exponents of particular x, p variables, from pr + integer pr(6),prd(6),prx,prp +c xvb, pvb, vbl = x variable, p variable (pvb=xvb+1), variable number + integer xvb,pvb,vbl +c expon = table of exponents +cryne 7/23/2002 integer expon(6,0:923) +cryne 7/23/2002 common/expon/expon +c bottom, top = lowest and highest monomial number for each order +cryne 7/23/2002 integer bottom(0:12),top(0:12) +cryne 7/23/2002 common/lims/bottom,top +cryne 7/23/2002 integer prodex(6,0:923) +cryne 7/23/2002 common /prodex/prodex + integer vbf,vbg + integer conj(6),sigj(6) + data conj /2,1,4,3,6,5/ + data sigj /1,-1,1,-1,1,-1/ + save conj,sigj !cryne 7/23/3003 +c +c----Routine---- +c initialize array pb + do 80 indpb=bottom(ordf+ordg-2),top(ordf+ordg-2) + 80 pb(indpb)=0. +c pick individual indf and indg, find what element of pb it affects, +c and calculate the new value. Loop for all indeces in the specified orders. + do 160 vbf = 1,6 + vbg = conj(vbf) + sign = sigj(vbf) + do 100 indf=bottom(ordf-1),top(ordf-1) + if(f(prodex(vbf,indf)).eq.0.0d0 ) goto 100 + do 110 indg=bottom(ordg-1),top(ordg-1) + indpb = iprod(indg,indf) + pb(indpb) = pb(indpb) + + & sign * f(prodex(vbf,indf)) * g(prodex(vbg,indg)) + & * (expon(vbf,indf)+1) * (expon(vbg,indg)+1) + 110 continue + 100 continue + 160 continue + return + end +c + subroutine pbkt2(f,n,index,bpb) +c computes the poisson bracket [f,z(i)] of +c an n-th degree polynomial whose coefficients +c are stored in an array f with the i-th component +c of the dynamical variable array z. +c z(1)=x +c z(2)=px +c . +c . +c . +c +c the coefficients of the result are +c stored in the array bpb. note the +c result is a polynomial of degree n-1 +c + use lieaparam, only : monoms + include 'impli.inc' + include 'expon.inc' + include 'vblist.inc' + include 'len.inc' +cryne 7/23/2002 implicit double precision (a-h,o-z) +cryne 7/23/2002 integer expon(6,0:923),vblist(6,0:923) +cryne 7/23/2002 dimension f(923),bpb(923),j(6) +cryne 7/23/2002 common/expon/expon +cryne 7/23/2002 common/vblist/vblist + dimension f(monoms),bpb(monoms),j(6) + dimension zz(6) +cryne 7/23/2002 common /len/ len(16) + do 10 i = 1,6 + zz(i) = 0.0d0 + 10 continue + zz(index) = 1.0d0 + call pbkt1(f,n,zz,1,bpb) +c + return + end +c +************************************************************************ +c + subroutine polr(fa,fm,rm,pdsm,reval,revec) +c this subroutine finds the polar decomposition of a symplectic map +c fa,fm is the incoming matrix, and is left unchanged +c rm and pdsm are its orthogonal (rotation) and positive definite +c symmetric factors +c reval and revec are the eigenvalues and eigenvector array for pdsm +c Written by Alex Dragt, Fall 1986 +c + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms) + dimension fm(6,6),rm(6,6),pdsm(6,6),reval(6),revec(6,6) + dimension t1m(6,6),t2m(6,6) + dimension ta(monoms) +c +c clear array + call clear(ta,t1m) +c +c begin computation +c +c computation of positive definite symmetric factor +c along with its eigenvalues and eigenvectors +c +c find (fm transpose)*fm + call matmat(fm,t1m) + call mtran(t1m) + call mmult(t1m,fm,t2m) +c extract square root + call seig6(t2m,reval,revec) + call mclear(t2m) + do 10 i=1,6 + reval(i)=sqrt(reval(i)) + t2m(i,i)=reval(i) + 10 continue + call matmat(revec,t1m) + call inv(ta,t1m) + call sndwch(ta,t1m,ta,t2m,ta,pdsm) +c +c computation of orthogonal (rotation) factor +c + call matmat(pdsm,t1m) + call inv(ta,t1m) + call concat(ta,t1m,ta,fm,ta,rm) +c + return + end +c +*********************************************************************** +c + subroutine pprod(a,na,b,nb,c) +c this subroutine computes the product of two polynomials: c=a*b +c Written by Alex Dragt, Fall 1986, based on work of F. Neri + use lieaparam, only : monoms + include 'impli.inc' + include 'expon.inc' + include 'lims.inc' + dimension a(monoms),b(monoms),c(monoms),l(6) +c + do 200 ia=bottom(na),top(na) + if(a(ia).eq.0.d0) goto 200 + do 20 ib = bottom(nb),top(nb) + if(b(ib).eq.0.d0) goto 20 + do 2 m=1,6 + l(m) = expon(m,ia) + expon(m,ib) + 2 continue + n = ndex(l) + c(n) = c(n) + a(ia)*b(ib) + 20 continue + 200 continue +c + return + end +c +*********************************************************************** +c + subroutine s2f(revec,k1,k2,val) +c this subroutine evaluates the symplectic 2-form assiciated with J +c Written by Alex Dragt, Fall 1986 + include 'impli.inc' + dimension revec(6,6) +c +c begin calculation + val=0.d0 + do 10 ip=2,6,2 + iq=ip-1 + val=val+revec(iq,k1)*revec(ip,k2)-revec(ip,k1)*revec(iq,k2) + 10 continue +c + return + end +c +*********************************************************************** +c + subroutine s5i(j,ans) +c Calculates the integral over S5 of the monomial having exponents +c stored in j. +c Written by Alex Dragt 10/22/89 +c + include 'impli.inc' +c +c calling array + integer j(6) +c + dimension anst(6) +c + ans=0. + do 10 i=1,6 + tans=0.d0 + ji=j(i) + if (ji .eq. 0) tans=1.d0 + if (ji .eq. 2) tans=1.d0/2.d0 + if (ji .eq. 4) tans=3.d0/4.d0 + if (ji .eq. 6) tans=15.d0/8.d0 + if (ji .eq. 8) tans=105.d0/16.d0 + if (tans .eq. 0.d0) return + anst(i)=tans + 10 continue + ans=anst(1)*anst(2)*anst(3)*anst(4)*anst(5)*anst(6) +c + return + end +c +*********************************************************************** +c + subroutine scncat(fa,fm,ga,gm,ha,hm) +c this is a special routine for concatenation. +c it calls concat and then transfers the +c coefficients for the linear and quadratic +c polynomials. +c Written by Alex Dragt, Fall 1985 +c + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms),ha(monoms) + dimension fm(6,6),gm(6,6),hm(6,6) + call clear(ha,hm) + call concat(fa,fm,ga,gm,ha,hm) +c transfer coefficients for linear and quadratic polynomials + do 10 i=1,27 + ha(i)=ga(i) + 10 continue + return + end +c +*********************************************************************** +c + subroutine smtof(scale,tm,ta) +c converts the symmetric matrix scale*tm to the array ta. +c written by Alex Dragt 22 May 1991 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension ta(monoms), tm(6,6) +c +c procedure +c clear array + do 5 i=1,monoms + 5 ta(i)=0.d0 +c put in new contents + ta(7)=tm(1,1) + ta(8)=tm(1,2) + ta(9)=tm(1,3) + ta(10)=tm(1,4) + ta(11)=tm(1,5) + ta(12)=tm(1,6) + ta(13)=tm(2,2) + ta(14)=tm(2,3) + ta(15)=tm(2,4) + ta(16)=tm(2,5) + ta(17)=tm(2,6) + ta(18)=tm(3,3) + ta(19)=tm(3,4) + ta(20)=tm(3,5) + ta(21)=tm(3,6) + ta(22)=tm(4,4) + ta(23)=tm(4,5) + ta(24)=tm(4,6) + ta(25)=tm(5,5) + ta(26)=tm(5,6) + ta(27)=tm(6,6) +c + do 10 i=7,27 + 10 ta(i)=scale*ta(i) +c + return + end +c +*********************************************************************** +c + subroutine sndwch(t1a,t1m,t2a,t2m,t3a,t3m) +c this is a subroutine for sandwiching a map +c it computes t3=t1*t2*(t1 inverse) +c Written by Alex Dragt, Fall 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension t1a(monoms),t2a(monoms),t3a(monoms),t4a(monoms), + & t5a(monoms) + dimension t1m(6,6),t2m(6,6),t3m(6,6),t4m(6,6),t5m(6,6) + call mapmap(t1a,t1m,t4a,t4m) + call inv(t4a,t4m) + call concat(t1a,t1m,t2a,t2m,t5a,t5m) + call concat(t5a,t5m,t4a,t4m,t3a,t3m) + return + end +c +************************************************************************ + subroutine sndwchi(t1a,t1m,t2a,t2m,t3a,t3m) +c added to liea.f by rdr and ctm on 5/22/02 +cryne 08/17/2001 This version (sndwchi) reverses the order +c +c this is a subroutine for sandwiching a map +c it computes t3=t1*t2*(t1 inverse) +c Written by Alex Dragt, Fall 1986 +c Modified by Alex Dragt, 18 July 1988 +c + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension t1a(monoms),t2a(monoms),t3a(monoms) + dimension t1m(6,6),t2m(6,6),t3m(6,6) +c +c working arrays + dimension ta(monoms) + dimension tm(6,6) +c + call mapmap(t1a,t1m,ta,tm) + call inv(ta,tm) + call concat(ta,tm,t2a,t2m,ta,tm) + call concat(ta,tm,t1a,t1m,t3a,t3m) +c + return + end +c +*********************************************************************** +c + subroutine svpbkt(in,ord,psv,base, pb) +c Single Variable Poisson BracKeT +c Takes the poisson bracket of the order 'ord' part of 'in' with the +c phase space variable represented by 'psv'. The result is left in pb. +c This subroutine replaces DRD's pbkt2 and was written by Liam Healy +c on November 29, 1984 from an idea of Christoph Iselin. +c + use lieaparam, only : monoms +c----Variables---- +c base = lowest index of pb + integer base +c in, pb = incoming array, outgoing pb array + double precision in(*),pb(base:*) +c ord = order of 'in' to be pb-ed + integer ord +c psv,wrt = phase space variable in pb, +c variable to be diff with resp to + integer psv,wrt +c indin,indpb = indeces for 'in' and 'pb' + integer indin,indpb +c sign = multiplier +1 or -1 depending on whether x or p +c differentiating + double precision sign + include 'expon.inc' + include 'lims.inc' +c +c----Routine---- + if (mod(psv,2).eq.1) then +c psv is a coordinate, diff wrt the canonical momentum and flip sign + wrt=psv+1 + sign=-1. + else +c psv is a momentum, diff wrt the canonical coordinate + wrt=psv-1 + sign=+1. + endif + indin=bottom(ord) + do 120 indpb=bottom(ord-1),top(ord-1) + 100 if (expon(wrt,indin).eq.0) then + indin=indin+1 + if (indin.le.top(ord)) goto 100 + return + endif + pb(indpb)=sign*expon(wrt,indin)*in(indin) + 120 indin=indin+1 + return + end +c +*********************************************************************** +c + subroutine xform(in,ord,matrix,matold,out) +c Transforms the order 'ord' part of polynomial represented by array +c 'in' with the matrix 'matrix', and leaves the resulting polynomial +c in the array 'out'. 'matold' should be set >=1 if the +c matrix in the previous call to xform was the same as this call. +c This subroutine replaces DRD's xform and was written by +c Liam Healy on November 30, 1984. +c + use lieaparam, only : monoms +c----Variables---- +c in, out = original polynomial array, transformed polynomial array + double precision in(*),out(*) +c ord = order to be transformed + integer ord +c matrix = matrix that represents the linear transformation +c prod = product, used to accumulate matrix elements + double precision matrix(6,6),prod +c indin, indout = indices for arrays 'in' and 'out' + integer indin,indout +c colme(row,count) = column number of the count-th one + integer colme(6,0:6),size + save colme +c matold = matrix supplied was used in the last call to xform + integer matold +c posn,psv = position in incoming variable list, phase space variable + integer posn,psv +c code = packed information on which combination of matrix elts to +c select +c ncombs = number of different combinations of me's that can be selected +c rem= remainder, gives the code information for the remaining positions + integer code,ncombs,rem +c row, this = row for this position, ordinal of non-zero me at this posn +c col = column + integer row(6),this(6),col + include 'vblist.inc' + include 'prodex.inc' + include 'lims.inc' +c +c rowa, cola = row and column in matrix +c count = ordinal of the non-zero matrix elements for a given row + integer count,rowa,cola +c +c------------------------ +c Find non-zero matrix elements +c Analyzes the matrix to find its non-zero entries, which are +c recorded in the array 'colme' by row number, together with +c the total number of non-zero entries in each row in colme(rowa,0). + if (matold.le.0) then + do 100 rowa=1,6 + count=0 + do 110 cola=1,6 + if(matrix(rowa,cola).ne.0.) then + count=count+1 + colme(rowa,count)=cola + endif + 110 continue + colme(rowa,0)=count + 100 continue + endif +c +c--------------- +c Clear the 'out' array elements of this order + do 80 indout=bottom(ord),top(ord) + 80 out(indout)=0. +c------------------------ +c Cycle through incoming array elements, for each that are non-zero +c Map them to outgoing elements + do 120 indin=bottom(ord),top(ord) + if (in(indin).ne.0.) then + ncombs=1 + do 140 posn=1,ord + row(posn)=vblist(posn,indin) + 140 ncombs=ncombs*colme(row(posn),0) +c------------------------ +c Go through all possible combinations of matrix elements that +c have the correct rows, i.e. corrosponding to the variables in 'indin' +c 'Code' contains packed (by variable base) information on which me to +c select. + do 160 code=0,ncombs-1 + rem=code + prod=1. + indout=0 + do 200 posn=1,ord + size=colme(row(posn),0) + this(posn)=mod(rem,size)+1 + rem=rem/size + col=colme(row(posn),this(posn)) + indout=prodex(col,indout) + prod=prod*matrix(row(posn),col) + 200 continue + out(indout)=out(indout)+in(indin)*prod + 160 continue +c------------------------ + endif + 120 continue + return + end +c +****************************************************************** +c + subroutine xform5(f,no,m,l) +c +c Transforms arguments of the polynomial f of degree no +c by the matrix m. The coefficients of the resultant +c polynomial are stored in the the array l which +c thus contains the coefficients of f(m*z). +c + use lieaparam, only : monoms + include 'impli.inc' + include 'expon.inc' + include 'vblist.inc' + include 'prodex.inc' + include 'len.inc' + include 'ind.inc' +c + double precision l,m,f +cryne 7/23/2002 dimension f(923),l(923) +cryne 7/23/2002 double precision temp(923) +cryne dimension f(monoms),l(monoms),temp(monoms) + dimension f(*),l(*),temp(monoms) + dimension m(6,6) +c +c do 127 my=1,6 +c write(6,*) my, len(my), +c & vblist(my,211), prodex(my,84) +c 127 continue +c return +c +c write(6,*) 'm and f coming into xform5' +c write(6,*) 'with no =',no +c call pcmap(1,1,0,0,f,m) +c +c initialise arrays +c + do 10 kp=1,len(no) + l(kp)=0.0d0 + temp(kp) = 0.0d0 + 10 continue + do 100 n= len(no-1)+1,len(no) + if(f(n).eq.0.0d0) goto 100 + do 101 kp=1,len(no-1) + temp(kp) = 0.0d0 + 101 continue + do 102 k=1,6 + if(m(vblist(1,n),k).eq.0.0d0) goto 102 + temp(k) = f(n)*m(vblist(1,n),k) + 102 continue + do 110 ior=1,no-1 + k1 = vblist(ior+1,n) + if(ior.eq.1) then + n1 = 1 + else + n1=len(ior-1)+1 + endif + do 112 k=1,6 + if(m(k1,k).eq.0.0d0) goto 112 + xm = m(k1,k) +cryne 7/21/01 cdir$ ivdep + do 111 nn=n1,len(ior) + temp(prodex(k,nn)) = temp(prodex(k,nn)) + temp(nn)*xm + 111 continue + 112 continue + 110 continue + 100 continue + do 200 nn=len(no-1)+1,len(no) + l(nn) = l(nn)+temp(nn) + 200 continue +c +c write(6,*) 'm and l coming out of xform5' +c write(6,*) 'with no =',no +c call pcmap(1,1,0,0,l,m) + + return + end +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/liea_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/liea_mod.f90 new file mode 100755 index 0000000..4a6e1fc --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/liea_mod.f90 @@ -0,0 +1,4 @@ +module lieaparam +integer, parameter :: monoms=923,monom1=461,monom2=209 +save +end module lieaparam diff --git a/OpticsJan2020/MLI_light_optics/Src/linpak.f b/OpticsJan2020/MLI_light_optics/Src/linpak.f new file mode 100755 index 0000000..ddfd2b8 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/linpak.f @@ -0,0 +1,1187 @@ + SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) +C***BEGIN PROLOGUE DGECO +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A1 +C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, +C MATRIX +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE Factors a double precision matrix by Gaussian elimination +C and estimates the condition of the matrix. +C***DESCRIPTION +C +C DGECO factors a double precision matrix by Gaussian elimination +C and estimates the condition of the matrix. +C +C If RCOND is not needed, DGEFA is slightly faster. +C To solve A*X = B , follow DGECO by DGESL. +C To compute INVERSE(A)*C , follow DGECO by DGESL. +C To compute DETERMINANT(A) , follow DGECO by DGEDI. +C To compute INVERSE(A) , follow DGECO by DGEDI. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the matrix to be factored. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C On Return +C +C A an upper triangular matrix and the multipliers +C which were used to obtain it. +C The factorization can be written A = L*U where +C L is a product of permutation and unit lower +C triangular matrices and U is upper triangular. +C +C IPVT INTEGER(N) +C an INTEGER vector of pivot indices. +C +C RCOND DOUBLE PRECISION +C an estimate of the reciprocal condition of A . +C For the system A*X = B , relative perturbations +C in A and B of size EPSILON may cause +C relative perturbations in X of size EPSILON/RCOND . +C If RCOND is so small that the logical expression +C 1.0 + RCOND .EQ. 1.0 +C is true, then A may be singular to working +C precision. In particular, RCOND is zero if +C exact singularity is detected or the estimate +C underflows. +C +C Z DOUBLE PRECISION(N) +C a work vector whose contents are usually unimportant. +C If A is close to a singular matrix, then Z is +C an approximate null vector in the sense that +C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . +C +C LINPACK. This version dated 08/14/78 . +C Cleve Moler, University of New Mexico, Argonne National Lab. +C +C Subroutines and Functions +C +C LINPACK DGEFA +C BLAS DAXPY,DDOT,DSCAL,DASUM +C Fortran DABS,DMAX1,DSIGN +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DASUM,DAXPY,DDOT,DGEFA,DSCAL +C***END PROLOGUE DGECO + INTEGER LDA,N,IPVT(1) + DOUBLE PRECISION A(LDA,1),Z(1) + DOUBLE PRECISION RCOND +C + DOUBLE PRECISION DDOT,EK,T,WK,WKM + DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM + INTEGER INFO,J,K,KB,KP1,L +C +C COMPUTE 1-NORM OF A +C +C***FIRST EXECUTABLE STATEMENT DGECO + ANORM = 0.0D0 + DO 10 J = 1, N + ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1)) + 10 CONTINUE +C +C FACTOR +C + CALL DGEFA(A,LDA,N,IPVT,INFO) +C +C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . +C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE +C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE +C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID +C OVERFLOW. +C +C SOLVE TRANS(U)*W = E +C + EK = 1.0D0 + DO 20 J = 1, N + Z(J) = 0.0D0 + 20 CONTINUE + DO 100 K = 1, N + IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) + IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30 + S = DABS(A(K,K))/DABS(EK-Z(K)) + CALL DSCAL(N,S,Z,1) + EK = S*EK + 30 CONTINUE + WK = EK - Z(K) + WKM = -EK - Z(K) + S = DABS(WK) + SM = DABS(WKM) + IF (A(K,K) .EQ. 0.0D0) GO TO 40 + WK = WK/A(K,K) + WKM = WKM/A(K,K) + GO TO 50 + 40 CONTINUE + WK = 1.0D0 + WKM = 1.0D0 + 50 CONTINUE + KP1 = K + 1 + IF (KP1 .GT. N) GO TO 90 + DO 60 J = KP1, N + SM = SM + DABS(Z(J)+WKM*A(K,J)) + Z(J) = Z(J) + WK*A(K,J) + S = S + DABS(Z(J)) + 60 CONTINUE + IF (S .GE. SM) GO TO 80 + T = WKM - WK + WK = WKM + DO 70 J = KP1, N + Z(J) = Z(J) + T*A(K,J) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + Z(K) = WK + 100 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C +C SOLVE TRANS(L)*Y = W +C + DO 120 KB = 1, N + K = N + 1 - KB + IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) + IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110 + S = 1.0D0/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + 110 CONTINUE + L = IPVT(K) + T = Z(L) + Z(L) = Z(K) + Z(K) = T + 120 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C + YNORM = 1.0D0 +C +C SOLVE L*V = Y +C + DO 140 K = 1, N + L = IPVT(K) + T = Z(L) + Z(L) = Z(K) + Z(K) = T + IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) + IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130 + S = 1.0D0/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 130 CONTINUE + 140 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C +C SOLVE U*Z = V +C + DO 160 KB = 1, N + K = N + 1 - KB + IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150 + S = DABS(A(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 150 CONTINUE + IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) + IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + T = -Z(K) + CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) + 160 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C + IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM + IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END + SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) +C***BEGIN PROLOGUE DGESL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A1 +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE Solves the double precision system A*X=B or TRANS(A)*X=B +C using the factors computed by DGECO or DGEFA. +C***DESCRIPTION +C +C DGESL solves the double precision system +C A * X = B or TRANS(A) * X = B +C using the factors computed by DGECO or DGEFA. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the output from DGECO or DGEFA. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C IPVT INTEGER(N) +C the pivot vector from DGECO or DGEFA. +C +C B DOUBLE PRECISION(N) +C the right hand side vector. +C +C JOB INTEGER +C = 0 to solve A*X = B , +C = nonzero to solve TRANS(A)*X = B where +C TRANS(A) is the transpose. +C +C On Return +C +C B the solution vector X . +C +C Error Condition +C +C A division by zero will occur if the input factor contains a +C zero on the diagonal. Technically this indicates singularity +C but it is often caused by improper arguments or improper +C setting of LDA . It will not occur if the subroutines are +C called correctly and if DGECO has set RCOND .GT. 0.0 +C or DGEFA has set INFO .EQ. 0 . +C +C To compute INVERSE(A) * C where C is a matrix +C with P columns +C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) +C IF (RCOND is too small) GO TO ... +C DO 10 J = 1, P +C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) +C 10 CONTINUE +C +C LINPACK. This version dated 08/14/78 . +C Cleve Moler, University of New Mexico, Argonne National Lab. +C +C Subroutines and Functions +C +C BLAS DAXPY,DDOT +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DDOT +C***END PROLOGUE DGESL + INTEGER LDA,N,IPVT(1),JOB + DOUBLE PRECISION A(LDA,1),B(1) +C + DOUBLE PRECISION DDOT,T + INTEGER K,KB,L,NM1 +C***FIRST EXECUTABLE STATEMENT DGESL + NM1 = N - 1 + IF (JOB .NE. 0) GO TO 50 +C +C JOB = 0 , SOLVE A * X = B +C FIRST SOLVE L*Y = B +C + IF (NM1 .LT. 1) GO TO 30 + DO 20 K = 1, NM1 + L = IPVT(K) + T = B(L) + IF (L .EQ. K) GO TO 10 + B(L) = B(K) + B(K) = T + 10 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) + 20 CONTINUE + 30 CONTINUE +C +C NOW SOLVE U*X = Y +C + DO 40 KB = 1, N + K = N + 1 - KB + B(K) = B(K)/A(K,K) + T = -B(K) + CALL DAXPY(K-1,T,A(1,K),1,B(1),1) + 40 CONTINUE + GO TO 100 + 50 CONTINUE +C +C JOB = NONZERO, SOLVE TRANS(A) * X = B +C FIRST SOLVE TRANS(U)*Y = B +C + DO 60 K = 1, N + T = DDOT(K-1,A(1,K),1,B(1),1) + B(K) = (B(K) - T)/A(K,K) + 60 CONTINUE +C +C NOW SOLVE TRANS(L)*X = Y +C + IF (NM1 .LT. 1) GO TO 90 + DO 80 KB = 1, NM1 + K = N - KB + B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) + L = IPVT(K) + IF (L .EQ. K) GO TO 70 + T = B(L) + B(L) = B(K) + B(K) = T + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RETURN + END + SUBROUTINE DSICO(A,LDA,N,KPVT,RCOND,Z) +C***BEGIN PROLOGUE DSICO +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2B1A +C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, +C MATRIX,SYMMETRIC +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with symmet- +C ric pivoting and estimates the condition of the matrix. +C***DESCRIPTION +C +C DSICO factors a double precision symmetric matrix by elimination +C with symmetric pivoting and estimates the condition of the +C matrix. +C +C If RCOND is not needed, DSIFA is slightly faster. +C To solve A*X = B , follow DSICO by DSISL. +C To compute INVERSE(A)*C , follow DSICO by DSISL. +C To compute INVERSE(A) , follow DSICO by DSIDI. +C To compute DETERMINANT(A) , follow DSICO by DSIDI. +C To compute INERTIA(A), follow DSICO by DSIDI. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the symmetric matrix to be factored. +C Only the diagonal and upper triangle are used. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C Output +C +C A a block diagonal matrix and the multipliers which +C were used to obtain it. +C The factorization can be written A = U*D*TRANS(U) +C where U is a product of permutation and unit +C upper triangular matrices, TRANS(U) is the +C transpose of U , and D is block diagonal +C with 1 by 1 and 2 by 2 blocks. +C +C KPVT INTEGER(N) +C an integer vector of pivot indices. +C +C RCOND DOUBLE PRECISION +C an estimate of the reciprocal condition of A . +C For the system A*X = B , relative perturbations +C in A and B of size EPSILON may cause +C relative perturbations in X of size EPSILON/RCOND . +C If RCOND is so small that the logical expression +C 1.0 + RCOND .EQ. 1.0 +C is true, then A may be singular to working +C precision. In particular, RCOND is zero if +C exact singularity is detected or the estimate +C underflows. +C +C Z DOUBLE PRECISION(N) +C a work vector whose contents are usually unimportant. +C If A is close to a singular matrix, then Z is +C an approximate null vector in the sense that +C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . +C +C LINPACK. This version dated 08/14/78 . +C Cleve Moler, University of New Mexico, Argonne National Lab. +C +C Subroutines and Functions +C +C LINPACK DSIFA +C BLAS DAXPY,DDOT,DSCAL,DASUM +C Fortran DABS,DMAX1,IABS,DSIGN +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DASUM,DAXPY,DDOT,DSCAL,DSIFA +C***END PROLOGUE DSICO + INTEGER LDA,N,KPVT(1) + DOUBLE PRECISION A(LDA,1),Z(1) + DOUBLE PRECISION RCOND +C + DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T + DOUBLE PRECISION ANORM,S,DASUM,YNORM + INTEGER I,INFO,J,JM1,K,KP,KPS,KS +C +C FIND NORM OF A USING ONLY UPPER HALF +C +C***FIRST EXECUTABLE STATEMENT DSICO + DO 30 J = 1, N + Z(J) = DASUM(J,A(1,J),1) + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 20 + DO 10 I = 1, JM1 + Z(I) = Z(I) + DABS(A(I,J)) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + ANORM = 0.0D0 + DO 40 J = 1, N + ANORM = DMAX1(ANORM,Z(J)) + 40 CONTINUE +C +C FACTOR +C + CALL DSIFA(A,LDA,N,KPVT,INFO) +C +C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . +C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL +C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . +C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. +C +C SOLVE U*D*W = E +C + EK = 1.0D0 + DO 50 J = 1, N + Z(J) = 0.0D0 + 50 CONTINUE + K = N + 60 IF (K .EQ. 0) GO TO 120 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + KP = IABS(KPVT(K)) + KPS = K + 1 - KS + IF (KP .EQ. KPS) GO TO 70 + T = Z(KPS) + Z(KPS) = Z(KP) + Z(KP) = T + 70 CONTINUE + IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,Z(K)) + Z(K) = Z(K) + EK + CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) + IF (KS .EQ. 1) GO TO 80 + IF (Z(K-1) .NE. 0.0D0) EK = DSIGN(EK,Z(K-1)) + Z(K-1) = Z(K-1) + EK + CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) + 80 CONTINUE + IF (KS .EQ. 2) GO TO 100 + IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 90 + S = DABS(A(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + EK = S*EK + 90 CONTINUE + IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) + IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + GO TO 110 + 100 CONTINUE + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + BK = Z(K)/A(K-1,K) + BKM1 = Z(K-1)/A(K-1,K) + DENOM = AK*AKM1 - 1.0D0 + Z(K) = (AKM1*BK - BKM1)/DENOM + Z(K-1) = (AK*BKM1 - BK)/DENOM + 110 CONTINUE + K = K - KS + GO TO 60 + 120 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C +C SOLVE TRANS(U)*Y = W +C + K = 1 + 130 IF (K .GT. N) GO TO 160 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + IF (K .EQ. 1) GO TO 150 + Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) + IF (KS .EQ. 2) + & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) + KP = IABS(KPVT(K)) + IF (KP .EQ. K) GO TO 140 + T = Z(K) + Z(K) = Z(KP) + Z(KP) = T + 140 CONTINUE + 150 CONTINUE + K = K + KS + GO TO 130 + 160 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C + YNORM = 1.0D0 +C +C SOLVE U*D*V = Y +C + K = N + 170 IF (K .EQ. 0) GO TO 230 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + IF (K .EQ. KS) GO TO 190 + KP = IABS(KPVT(K)) + KPS = K + 1 - KS + IF (KP .EQ. KPS) GO TO 180 + T = Z(KPS) + Z(KPS) = Z(KP) + Z(KP) = T + 180 CONTINUE + CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) + IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) + 190 CONTINUE + IF (KS .EQ. 2) GO TO 210 + IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 200 + S = DABS(A(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 200 CONTINUE + IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) + IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + GO TO 220 + 210 CONTINUE + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + BK = Z(K)/A(K-1,K) + BKM1 = Z(K-1)/A(K-1,K) + DENOM = AK*AKM1 - 1.0D0 + Z(K) = (AKM1*BK - BKM1)/DENOM + Z(K-1) = (AK*BKM1 - BK)/DENOM + 220 CONTINUE + K = K - KS + GO TO 170 + 230 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C +C SOLVE TRANS(U)*Z = V +C + K = 1 + 240 IF (K .GT. N) GO TO 270 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + IF (K .EQ. 1) GO TO 260 + Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) + IF (KS .EQ. 2) + & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) + KP = IABS(KPVT(K)) + IF (KP .EQ. K) GO TO 250 + T = Z(K) + Z(K) = Z(KP) + Z(KP) = T + 250 CONTINUE + 260 CONTINUE + K = K + KS + GO TO 240 + 270 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C + IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM + IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END + SUBROUTINE DSISL(A,LDA,N,KPVT,B) +C***BEGIN PROLOGUE DSISL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2B1A +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, +C SYMMETRIC +C***AUTHOR BUNCH, J., (UCSD) +C***PURPOSE Solves the double precision SYMMETRIC system +C A*X=B using the factors computed by DSIFA. +C***DESCRIPTION +C +C DSISL solves the double precision symmetric system +C A * X = B +C using the factors computed by DSIFA. +C +C On Entry +C +C A DOUBLE PRECISION(LDA,N) +C the output from DSIFA. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C KPVT INTEGER(N) +C the pivot vector from DSIFA. +C +C B DOUBLE PRECISION(N) +C the right hand side vector. +C +C On Return +C +C B the solution vector X . +C +C Error Condition +C +C A division by zero may occur if DSICO has set RCOND .EQ. 0.0 +C or DSIFA has set INFO .NE. 0 . +C +C To compute INVERSE(A) * C where C is a matrix +C with P columns +C CALL DSIFA(A,LDA,N,KPVT,INFO) +C IF (INFO .NE. 0) GO TO ... +C DO 10 J = 1, P +C CALL DSISL(A,LDA,N,KPVT,C(1,J)) +C 10 CONTINUE +C +C LINPACK. This version dated 08/14/78 . +C James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. +C +C Subroutines and Functions +C +C BLAS DAXPY,DDOT +C Fortran IABS +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DDOT +C***END PROLOGUE DSISL + INTEGER LDA,N,KPVT(1) + DOUBLE PRECISION A(LDA,1),B(1) +C + DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP + INTEGER K,KP +C +C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND +C D INVERSE TO B. +C +C***FIRST EXECUTABLE STATEMENT DSISL + K = N + 10 IF (K .EQ. 0) GO TO 80 + IF (KPVT(K) .LT. 0) GO TO 40 +C +C 1 X 1 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 30 + KP = KPVT(K) + IF (KP .EQ. K) GO TO 20 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 20 CONTINUE +C +C APPLY THE TRANSFORMATION. +C + CALL DAXPY(K-1,B(K),A(1,K),1,B(1),1) + 30 CONTINUE +C +C APPLY D INVERSE. +C + B(K) = B(K)/A(K,K) + K = K - 1 + GO TO 70 + 40 CONTINUE +C +C 2 X 2 PIVOT BLOCK. +C + IF (K .EQ. 2) GO TO 60 + KP = IABS(KPVT(K)) + IF (KP .EQ. K - 1) GO TO 50 +C +C INTERCHANGE. +C + TEMP = B(K-1) + B(K-1) = B(KP) + B(KP) = TEMP + 50 CONTINUE +C +C APPLY THE TRANSFORMATION. +C + CALL DAXPY(K-2,B(K),A(1,K),1,B(1),1) + CALL DAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) + 60 CONTINUE +C +C APPLY D INVERSE. +C + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + BK = B(K)/A(K-1,K) + BKM1 = B(K-1)/A(K-1,K) + DENOM = AK*AKM1 - 1.0D0 + B(K) = (AKM1*BK - BKM1)/DENOM + B(K-1) = (AK*BKM1 - BK)/DENOM + K = K - 2 + 70 CONTINUE + GO TO 10 + 80 CONTINUE +C +C LOOP FORWARD APPLYING THE TRANSFORMATIONS. +C + K = 1 + 90 IF (K .GT. N) GO TO 160 + IF (KPVT(K) .LT. 0) GO TO 120 +C +C 1 X 1 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 110 +C +C APPLY THE TRANSFORMATION. +C + B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) + KP = KPVT(K) + IF (KP .EQ. K) GO TO 100 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 100 CONTINUE + 110 CONTINUE + K = K + 1 + GO TO 150 + 120 CONTINUE +C +C 2 X 2 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 140 +C +C APPLY THE TRANSFORMATION. +C + B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) + B(K+1) = B(K+1) + DDOT(K-1,A(1,K+1),1,B(1),1) + KP = IABS(KPVT(K)) + IF (KP .EQ. K) GO TO 130 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 130 CONTINUE + 140 CONTINUE + K = K + 2 + 150 CONTINUE + GO TO 90 + 160 CONTINUE + RETURN + END + SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) +****BEGIN PROLOGUE DGEFA +****DATE WRITTEN 780814 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D2A1 +****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX +****AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +****PURPOSE Factors a double precision matrix by Gaussian elimination. +****DESCRIPTION +* +* DGEFA factors a double precision matrix by Gaussian elimination. +* +* DGEFA is usually called by DGECO, but it can be called +* directly with a saving in time if RCOND is not needed. +* (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . +* +* On Entry +* +* A DOUBLE PRECISION(LDA, N) +* the matrix to be factored. +* +* LDA INTEGER +* the leading dimension of the array A . +* +* N INTEGER +* the order of the matrix A . +* +* On Return +* +* A an upper triangular matrix and the multipliers +* which were used to obtain it. +* The factorization can be written A = L*U where +* L is a product of permutation and unit lower +* triangular matrices and U is upper triangular. +* +* IPVT INTEGER(N) +* an integer vector of pivot indices. +* +* INFO INTEGER +* = 0 normal value. +* = K if U(K,K) .EQ. 0.0 . This is not an error +* condition for this subroutine, but it does +* indicate that DGESL or DGEDI will divide by zero +* if called. Use RCOND in DGECO for a reliable +* indication of singularity. +* +* LINPACK. This version dated 08/14/78 . +* Cleve Moler, University of New Mexico, Argonne National Lab. +* +* Subroutines and Functions +* +* BLAS DAXPY,DSCAL,IDAMAX +****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +* *LINPACK USERS GUIDE*, SIAM, 1979. +****ROUTINES CALLED DAXPY,DSCAL,IDAMAX +****END PROLOGUE DGEFA + INTEGER LDA,N,IPVT(1),INFO + DOUBLE PRECISION A(LDA,1) +* + DOUBLE PRECISION T + INTEGER IDAMAX,J,K,KP1,L,NM1 +* +* GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING +* +****FIRST EXECUTABLE STATEMENT DGEFA + INFO = 0 + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 70 + DO 60 K = 1, NM1 + KP1 = K + 1 +* +* FIND L = PIVOT INDEX +* + L = IDAMAX(N-K+1,A(K,K),1) + K - 1 + IPVT(K) = L +* +* ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED +* + IF (A(L,K) .EQ. 0.0D0) GO TO 40 +* +* INTERCHANGE IF NECESSARY +* + IF (L .EQ. K) GO TO 10 + T = A(L,K) + A(L,K) = A(K,K) + A(K,K) = T + 10 CONTINUE +* +* COMPUTE MULTIPLIERS +* + T = -1.0D0/A(K,K) + CALL DSCAL(N-K,T,A(K+1,K),1) +* +* ROW ELIMINATION WITH COLUMN INDEXING +* + DO 30 J = KP1, N + T = A(L,J) + IF (L .EQ. K) GO TO 20 + A(L,J) = A(K,J) + A(K,J) = T + 20 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) + 30 CONTINUE + GO TO 50 + 40 CONTINUE + INFO = K + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IPVT(N) = N + IF (A(N,N) .EQ. 0.0D0) INFO = N + RETURN + END + SUBROUTINE DSIFA(A,LDA,N,KPVT,INFO) +****BEGIN PROLOGUE DSIFA +****DATE WRITTEN 780814 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D2B1A +****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX, +* SYMMETRIC +****AUTHOR BUNCH, J., (UCSD) +****PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with +* symmetric pivoting +****DESCRIPTION +* +* DSIFA factors a double precision symmetric matrix by elimination +* with symmetric pivoting. +* +* To solve A*X = B , follow DSIFA by DSISL. +* To compute INVERSE(A)*C , follow DSIFA by DSISL. +* To compute DETERMINANT(A) , follow DSIFA by DSIDI. +* To compute INERTIA(A) , follow DSIFA by DSIDI. +* To compute INVERSE(A) , follow DSIFA by DSIDI. +* +* On Entry +* +* A DOUBLE PRECISION(LDA,N) +* the symmetric matrix to be factored. +* Only the diagonal and upper triangle are used. +* +* LDA INTEGER +* the leading dimension of the array A . +* +* N INTEGER +* the order of the matrix A . +* +* On Return +* +* A a block diagonal matrix and the multipliers which +* were used to obtain it. +* The factorization can be written A = U*D*TRANS(U) +* where U is a product of permutation and unit +* upper triangular matrices, TRANS(U) is the +* transpose of U , and D is block diagonal +* with 1 by 1 and 2 by 2 blocks. +* +* KPVT INTEGER(N) +* an integer vector of pivot indices. +* +* INFO INTEGER +* = 0 normal value. +* = K if the K-th pivot block is singular. This is +* not an error condition for this subroutine, +* but it does indicate that DSISL or DSIDI may +* divide by zero if called. +* +* LINPACK. This version dated 08/14/78 . +* James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. +* +* Subroutines and Functions +* +* BLAS DAXPY,DSWAP,IDAMAX +* Fortran DABS,DMAX1,DSQRT +****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +* *LINPACK USERS GUIDE*, SIAM, 1979. +****ROUTINES CALLED DAXPY,DSWAP,IDAMAX +****END PROLOGUE DSIFA + INTEGER LDA,N,KPVT(1),INFO + DOUBLE PRECISION A(LDA,1) +* + DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T + DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX + INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,IDAMAX + LOGICAL SWAP +* +* INITIALIZE +* +* ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. +****FIRST EXECUTABLE STATEMENT DSIFA + ALPHA = (1.0D0 + DSQRT(17.0D0))/8.0D0 +* + INFO = 0 +* +* MAIN LOOP ON K, WHICH GOES FROM N TO 1. +* + K = N + 10 CONTINUE +* +* LEAVE THE LOOP IF K=0 OR K=1. +* +* ...EXIT + IF (K .EQ. 0) GO TO 200 + IF (K .GT. 1) GO TO 20 + KPVT(1) = 1 + IF (A(1,1) .EQ. 0.0D0) INFO = 1 +* ......EXIT + GO TO 200 + 20 CONTINUE +* +* THIS SECTION OF CODE DETERMINES THE KIND OF +* ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, +* KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND +* SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS +* REQUIRED. +* + KM1 = K - 1 + ABSAKK = DABS(A(K,K)) +* +* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN +* COLUMN K. +* + IMAX = IDAMAX(K-1,A(1,K),1) + COLMAX = DABS(A(IMAX,K)) + IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 + KSTEP = 1 + SWAP = .FALSE. + GO TO 90 + 30 CONTINUE +* +* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN +* ROW IMAX. +* + ROWMAX = 0.0D0 + IMAXP1 = IMAX + 1 + DO 40 J = IMAXP1, K + ROWMAX = DMAX1(ROWMAX,DABS(A(IMAX,J))) + 40 CONTINUE + IF (IMAX .EQ. 1) GO TO 50 + JMAX = IDAMAX(IMAX-1,A(1,IMAX),1) + ROWMAX = DMAX1(ROWMAX,DABS(A(JMAX,IMAX))) + 50 CONTINUE + IF (DABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 + KSTEP = 1 + SWAP = .TRUE. + GO TO 80 + 60 CONTINUE + IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 + KSTEP = 1 + SWAP = .FALSE. + GO TO 80 + 70 CONTINUE + KSTEP = 2 + SWAP = IMAX .NE. KM1 + 80 CONTINUE + 90 CONTINUE + IF (DMAX1(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100 +* +* COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. +* + KPVT(K) = K + INFO = K + GO TO 190 + 100 CONTINUE + IF (KSTEP .EQ. 2) GO TO 140 +* +* 1 X 1 PIVOT BLOCK. +* + IF (.NOT.SWAP) GO TO 120 +* +* PERFORM AN INTERCHANGE. +* + CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K),1) + DO 110 JJ = IMAX, K + J = K + IMAX - JJ + T = A(J,K) + A(J,K) = A(IMAX,J) + A(IMAX,J) = T + 110 CONTINUE + 120 CONTINUE +* +* PERFORM THE ELIMINATION. +* + DO 130 JJ = 1, KM1 + J = K - JJ + MULK = -A(J,K)/A(K,K) + T = MULK + CALL DAXPY(J,T,A(1,K),1,A(1,J),1) + A(J,K) = MULK + 130 CONTINUE +* +* SET THE PIVOT ARRAY. +* + KPVT(K) = K + IF (SWAP) KPVT(K) = IMAX + GO TO 190 + 140 CONTINUE +* +* 2 X 2 PIVOT BLOCK. +* + IF (.NOT.SWAP) GO TO 160 +* +* PERFORM AN INTERCHANGE. +* + CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) + DO 150 JJ = IMAX, KM1 + J = KM1 + IMAX - JJ + T = A(J,K-1) + A(J,K-1) = A(IMAX,J) + A(IMAX,J) = T + 150 CONTINUE + T = A(K-1,K) + A(K-1,K) = A(IMAX,K) + A(IMAX,K) = T + 160 CONTINUE +* +* PERFORM THE ELIMINATION. +* + KM2 = K - 2 + IF (KM2 .EQ. 0) GO TO 180 + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + DENOM = 1.0D0 - AK*AKM1 + DO 170 JJ = 1, KM2 + J = KM1 - JJ + BK = A(J,K)/A(K-1,K) + BKM1 = A(J,K-1)/A(K-1,K) + MULK = (AKM1*BK - BKM1)/DENOM + MULKM1 = (AK*BKM1 - BK)/DENOM + T = MULK + CALL DAXPY(J,T,A(1,K),1,A(1,J),1) + T = MULKM1 + CALL DAXPY(J,T,A(1,K-1),1,A(1,J),1) + A(J,K) = MULK + A(J,K-1) = MULKM1 + 170 CONTINUE + 180 CONTINUE +* +* SET THE PIVOT ARRAY. +* + KPVT(K) = 1 - K + IF (SWAP) KPVT(K) = -IMAX + KPVT(K-1) = KPVT(K) + 190 CONTINUE + K = K - KSTEP + GO TO 10 + 200 CONTINUE + RETURN + END + DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) + implicit double precision (a-h, o-z) + INTEGER NEXT + DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE + DATA ZERO, ONE /0.0D0, 1.0D0/ +C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE +C INCREMENT INCX . +C C.L.LAWSON, 1978 JAN 08 + DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / + IF(N .GT. 0) GO TO 10 + DNRM2 = ZERO + GO TO 300 + 10 ASSIGN 30 TO NEXT + SUM = ZERO + NN = N * INCX +C BEGIN MAIN LOOP + I = 1 + 20 GO TO NEXT,(30, 50, 70, 110) + 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + ASSIGN 50 TO NEXT + XMAX = ZERO +C PHASE 1. SUM IS ZERO + 50 IF( DX(I) .EQ. ZERO) GO TO 200 + IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 +C PREPARE FOR PHASE 2. + ASSIGN 70 TO NEXT + GO TO 105 +C PREPARE FOR PHASE 4. + 100 I = J + ASSIGN 110 TO NEXT + SUM = (SUM / DX(I)) / DX(I) + 105 XMAX = DABS(DX(I)) + GO TO 115 +C PHASE 2. SUM IS SMALL. +C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. + 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 +C COMMON CODE FOR PHASES 2 AND 4. +C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. + 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 + SUM = ONE + SUM * (XMAX / DX(I))**2 + XMAX = DABS(DX(I)) + GO TO 200 + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 +C PREPARE FOR PHASE 3. + 75 SUM = (SUM * XMAX) * XMAX +C FOR REAL OR D.P. SET HITEST = CUTHI/N +C FOR COMPLEX SET HITEST = CUTHI/(2*N) + 85 HITEST = CUTHI/FLOAT( N ) +C PHASE 3. SUM IS MID-RANGE. NO SCALING. + DO 95 J =I,NN,INCX + IF(DABS(DX(J)) .GE. HITEST) GO TO 100 + 95 SUM = SUM + DX(J)**2 + DNRM2 = DSQRT( SUM ) + GO TO 300 + 200 CONTINUE + I = I + INCX + IF ( I .LE. NN ) GO TO 20 +C END OF MAIN LOOP. +C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. + DNRM2 = XMAX * DSQRT(SUM) + 300 CONTINUE + RETURN + END diff --git a/OpticsJan2020/MLI_light_optics/Src/linpak_all.f b/OpticsJan2020/MLI_light_optics/Src/linpak_all.f new file mode 100755 index 0000000..346369d --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/linpak_all.f @@ -0,0 +1,1615 @@ + SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) +C***BEGIN PROLOGUE DGECO +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A1 +C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, +C MATRIX +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE Factors a double precision matrix by Gaussian elimination +C and estimates the condition of the matrix. +C***DESCRIPTION +C +C DGECO factors a double precision matrix by Gaussian elimination +C and estimates the condition of the matrix. +C +C If RCOND is not needed, DGEFA is slightly faster. +C To solve A*X = B , follow DGECO by DGESL. +C To compute INVERSE(A)*C , follow DGECO by DGESL. +C To compute DETERMINANT(A) , follow DGECO by DGEDI. +C To compute INVERSE(A) , follow DGECO by DGEDI. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the matrix to be factored. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C On Return +C +C A an upper triangular matrix and the multipliers +C which were used to obtain it. +C The factorization can be written A = L*U where +C L is a product of permutation and unit lower +C triangular matrices and U is upper triangular. +C +C IPVT INTEGER(N) +C an INTEGER vector of pivot indices. +C +C RCOND DOUBLE PRECISION +C an estimate of the reciprocal condition of A . +C For the system A*X = B , relative perturbations +C in A and B of size EPSILON may cause +C relative perturbations in X of size EPSILON/RCOND . +C If RCOND is so small that the logical expression +C 1.0 + RCOND .EQ. 1.0 +C is true, then A may be singular to working +C precision. In particular, RCOND is zero if +C exact singularity is detected or the estimate +C underflows. +C +C Z DOUBLE PRECISION(N) +C a work vector whose contents are usually unimportant. +C If A is close to a singular matrix, then Z is +C an approximate null vector in the sense that +C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . +C +C LINPACK. This version dated 08/14/78 . +C Cleve Moler, University of New Mexico, Argonne National Lab. +C +C Subroutines and Functions +C +C LINPACK DGEFA +C BLAS DAXPY,DDOT,DSCAL,DASUM +C Fortran DABS,DMAX1,DSIGN +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DASUM,DAXPY,DDOT,DGEFA,DSCAL +C***END PROLOGUE DGECO + INTEGER LDA,N,IPVT(1) + DOUBLE PRECISION A(LDA,1),Z(1) + DOUBLE PRECISION RCOND +C + DOUBLE PRECISION DDOT,EK,T,WK,WKM + DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM + INTEGER INFO,J,K,KB,KP1,L +C +C COMPUTE 1-NORM OF A +C +C***FIRST EXECUTABLE STATEMENT DGECO + ANORM = 0.0D0 + DO 10 J = 1, N + ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1)) + 10 CONTINUE +C +C FACTOR +C + CALL DGEFA(A,LDA,N,IPVT,INFO) +C +C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . +C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE +C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE +C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID +C OVERFLOW. +C +C SOLVE TRANS(U)*W = E +C + EK = 1.0D0 + DO 20 J = 1, N + Z(J) = 0.0D0 + 20 CONTINUE + DO 100 K = 1, N + IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) + IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30 + S = DABS(A(K,K))/DABS(EK-Z(K)) + CALL DSCAL(N,S,Z,1) + EK = S*EK + 30 CONTINUE + WK = EK - Z(K) + WKM = -EK - Z(K) + S = DABS(WK) + SM = DABS(WKM) + IF (A(K,K) .EQ. 0.0D0) GO TO 40 + WK = WK/A(K,K) + WKM = WKM/A(K,K) + GO TO 50 + 40 CONTINUE + WK = 1.0D0 + WKM = 1.0D0 + 50 CONTINUE + KP1 = K + 1 + IF (KP1 .GT. N) GO TO 90 + DO 60 J = KP1, N + SM = SM + DABS(Z(J)+WKM*A(K,J)) + Z(J) = Z(J) + WK*A(K,J) + S = S + DABS(Z(J)) + 60 CONTINUE + IF (S .GE. SM) GO TO 80 + T = WKM - WK + WK = WKM + DO 70 J = KP1, N + Z(J) = Z(J) + T*A(K,J) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + Z(K) = WK + 100 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C +C SOLVE TRANS(L)*Y = W +C + DO 120 KB = 1, N + K = N + 1 - KB + IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) + IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110 + S = 1.0D0/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + 110 CONTINUE + L = IPVT(K) + T = Z(L) + Z(L) = Z(K) + Z(K) = T + 120 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C + YNORM = 1.0D0 +C +C SOLVE L*V = Y +C + DO 140 K = 1, N + L = IPVT(K) + T = Z(L) + Z(L) = Z(K) + Z(K) = T + IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) + IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130 + S = 1.0D0/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 130 CONTINUE + 140 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C +C SOLVE U*Z = V +C + DO 160 KB = 1, N + K = N + 1 - KB + IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150 + S = DABS(A(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 150 CONTINUE + IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) + IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + T = -Z(K) + CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) + 160 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C + IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM + IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END + SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) +C***BEGIN PROLOGUE DGESL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A1 +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE Solves the double precision system A*X=B or TRANS(A)*X=B +C using the factors computed by DGECO or DGEFA. +C***DESCRIPTION +C +C DGESL solves the double precision system +C A * X = B or TRANS(A) * X = B +C using the factors computed by DGECO or DGEFA. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the output from DGECO or DGEFA. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C IPVT INTEGER(N) +C the pivot vector from DGECO or DGEFA. +C +C B DOUBLE PRECISION(N) +C the right hand side vector. +C +C JOB INTEGER +C = 0 to solve A*X = B , +C = nonzero to solve TRANS(A)*X = B where +C TRANS(A) is the transpose. +C +C On Return +C +C B the solution vector X . +C +C Error Condition +C +C A division by zero will occur if the input factor contains a +C zero on the diagonal. Technically this indicates singularity +C but it is often caused by improper arguments or improper +C setting of LDA . It will not occur if the subroutines are +C called correctly and if DGECO has set RCOND .GT. 0.0 +C or DGEFA has set INFO .EQ. 0 . +C +C To compute INVERSE(A) * C where C is a matrix +C with P columns +C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) +C IF (RCOND is too small) GO TO ... +C DO 10 J = 1, P +C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) +C 10 CONTINUE +C +C LINPACK. This version dated 08/14/78 . +C Cleve Moler, University of New Mexico, Argonne National Lab. +C +C Subroutines and Functions +C +C BLAS DAXPY,DDOT +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DDOT +C***END PROLOGUE DGESL + INTEGER LDA,N,IPVT(1),JOB + DOUBLE PRECISION A(LDA,1),B(1) +C + DOUBLE PRECISION DDOT,T + INTEGER K,KB,L,NM1 +C***FIRST EXECUTABLE STATEMENT DGESL + NM1 = N - 1 + IF (JOB .NE. 0) GO TO 50 +C +C JOB = 0 , SOLVE A * X = B +C FIRST SOLVE L*Y = B +C + IF (NM1 .LT. 1) GO TO 30 + DO 20 K = 1, NM1 + L = IPVT(K) + T = B(L) + IF (L .EQ. K) GO TO 10 + B(L) = B(K) + B(K) = T + 10 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) + 20 CONTINUE + 30 CONTINUE +C +C NOW SOLVE U*X = Y +C + DO 40 KB = 1, N + K = N + 1 - KB + B(K) = B(K)/A(K,K) + T = -B(K) + CALL DAXPY(K-1,T,A(1,K),1,B(1),1) + 40 CONTINUE + GO TO 100 + 50 CONTINUE +C +C JOB = NONZERO, SOLVE TRANS(A) * X = B +C FIRST SOLVE TRANS(U)*Y = B +C + DO 60 K = 1, N + T = DDOT(K-1,A(1,K),1,B(1),1) + B(K) = (B(K) - T)/A(K,K) + 60 CONTINUE +C +C NOW SOLVE TRANS(L)*X = Y +C + IF (NM1 .LT. 1) GO TO 90 + DO 80 KB = 1, NM1 + K = N - KB + B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) + L = IPVT(K) + IF (L .EQ. K) GO TO 70 + T = B(L) + B(L) = B(K) + B(K) = T + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RETURN + END + SUBROUTINE DSICO(A,LDA,N,KPVT,RCOND,Z) +C***BEGIN PROLOGUE DSICO +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2B1A +C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, +C MATRIX,SYMMETRIC +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with symmet- +C ric pivoting and estimates the condition of the matrix. +C***DESCRIPTION +C +C DSICO factors a double precision symmetric matrix by elimination +C with symmetric pivoting and estimates the condition of the +C matrix. +C +C If RCOND is not needed, DSIFA is slightly faster. +C To solve A*X = B , follow DSICO by DSISL. +C To compute INVERSE(A)*C , follow DSICO by DSISL. +C To compute INVERSE(A) , follow DSICO by DSIDI. +C To compute DETERMINANT(A) , follow DSICO by DSIDI. +C To compute INERTIA(A), follow DSICO by DSIDI. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the symmetric matrix to be factored. +C Only the diagonal and upper triangle are used. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C Output +C +C A a block diagonal matrix and the multipliers which +C were used to obtain it. +C The factorization can be written A = U*D*TRANS(U) +C where U is a product of permutation and unit +C upper triangular matrices, TRANS(U) is the +C transpose of U , and D is block diagonal +C with 1 by 1 and 2 by 2 blocks. +C +C KPVT INTEGER(N) +C an integer vector of pivot indices. +C +C RCOND DOUBLE PRECISION +C an estimate of the reciprocal condition of A . +C For the system A*X = B , relative perturbations +C in A and B of size EPSILON may cause +C relative perturbations in X of size EPSILON/RCOND . +C If RCOND is so small that the logical expression +C 1.0 + RCOND .EQ. 1.0 +C is true, then A may be singular to working +C precision. In particular, RCOND is zero if +C exact singularity is detected or the estimate +C underflows. +C +C Z DOUBLE PRECISION(N) +C a work vector whose contents are usually unimportant. +C If A is close to a singular matrix, then Z is +C an approximate null vector in the sense that +C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . +C +C LINPACK. This version dated 08/14/78 . +C Cleve Moler, University of New Mexico, Argonne National Lab. +C +C Subroutines and Functions +C +C LINPACK DSIFA +C BLAS DAXPY,DDOT,DSCAL,DASUM +C Fortran DABS,DMAX1,IABS,DSIGN +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DASUM,DAXPY,DDOT,DSCAL,DSIFA +C***END PROLOGUE DSICO + INTEGER LDA,N,KPVT(1) + DOUBLE PRECISION A(LDA,1),Z(1) + DOUBLE PRECISION RCOND +C + DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T + DOUBLE PRECISION ANORM,S,DASUM,YNORM + INTEGER I,INFO,J,JM1,K,KP,KPS,KS +C +C FIND NORM OF A USING ONLY UPPER HALF +C +C***FIRST EXECUTABLE STATEMENT DSICO + DO 30 J = 1, N + Z(J) = DASUM(J,A(1,J),1) + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 20 + DO 10 I = 1, JM1 + Z(I) = Z(I) + DABS(A(I,J)) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + ANORM = 0.0D0 + DO 40 J = 1, N + ANORM = DMAX1(ANORM,Z(J)) + 40 CONTINUE +C +C FACTOR +C + CALL DSIFA(A,LDA,N,KPVT,INFO) +C +C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . +C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL +C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . +C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. +C +C SOLVE U*D*W = E +C + EK = 1.0D0 + DO 50 J = 1, N + Z(J) = 0.0D0 + 50 CONTINUE + K = N + 60 IF (K .EQ. 0) GO TO 120 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + KP = IABS(KPVT(K)) + KPS = K + 1 - KS + IF (KP .EQ. KPS) GO TO 70 + T = Z(KPS) + Z(KPS) = Z(KP) + Z(KP) = T + 70 CONTINUE + IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,Z(K)) + Z(K) = Z(K) + EK + CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) + IF (KS .EQ. 1) GO TO 80 + IF (Z(K-1) .NE. 0.0D0) EK = DSIGN(EK,Z(K-1)) + Z(K-1) = Z(K-1) + EK + CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) + 80 CONTINUE + IF (KS .EQ. 2) GO TO 100 + IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 90 + S = DABS(A(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + EK = S*EK + 90 CONTINUE + IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) + IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + GO TO 110 + 100 CONTINUE + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + BK = Z(K)/A(K-1,K) + BKM1 = Z(K-1)/A(K-1,K) + DENOM = AK*AKM1 - 1.0D0 + Z(K) = (AKM1*BK - BKM1)/DENOM + Z(K-1) = (AK*BKM1 - BK)/DENOM + 110 CONTINUE + K = K - KS + GO TO 60 + 120 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C +C SOLVE TRANS(U)*Y = W +C + K = 1 + 130 IF (K .GT. N) GO TO 160 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + IF (K .EQ. 1) GO TO 150 + Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) + IF (KS .EQ. 2) + & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) + KP = IABS(KPVT(K)) + IF (KP .EQ. K) GO TO 140 + T = Z(K) + Z(K) = Z(KP) + Z(KP) = T + 140 CONTINUE + 150 CONTINUE + K = K + KS + GO TO 130 + 160 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C + YNORM = 1.0D0 +C +C SOLVE U*D*V = Y +C + K = N + 170 IF (K .EQ. 0) GO TO 230 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + IF (K .EQ. KS) GO TO 190 + KP = IABS(KPVT(K)) + KPS = K + 1 - KS + IF (KP .EQ. KPS) GO TO 180 + T = Z(KPS) + Z(KPS) = Z(KP) + Z(KP) = T + 180 CONTINUE + CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) + IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) + 190 CONTINUE + IF (KS .EQ. 2) GO TO 210 + IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 200 + S = DABS(A(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 200 CONTINUE + IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) + IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + GO TO 220 + 210 CONTINUE + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + BK = Z(K)/A(K-1,K) + BKM1 = Z(K-1)/A(K-1,K) + DENOM = AK*AKM1 - 1.0D0 + Z(K) = (AKM1*BK - BKM1)/DENOM + Z(K-1) = (AK*BKM1 - BK)/DENOM + 220 CONTINUE + K = K - KS + GO TO 170 + 230 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C +C SOLVE TRANS(U)*Z = V +C + K = 1 + 240 IF (K .GT. N) GO TO 270 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + IF (K .EQ. 1) GO TO 260 + Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) + IF (KS .EQ. 2) + & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) + KP = IABS(KPVT(K)) + IF (KP .EQ. K) GO TO 250 + T = Z(K) + Z(K) = Z(KP) + Z(KP) = T + 250 CONTINUE + 260 CONTINUE + K = K + KS + GO TO 240 + 270 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C + IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM + IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END + SUBROUTINE DSISL(A,LDA,N,KPVT,B) +C***BEGIN PROLOGUE DSISL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2B1A +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, +C SYMMETRIC +C***AUTHOR BUNCH, J., (UCSD) +C***PURPOSE Solves the double precision SYMMETRIC system +C A*X=B using the factors computed by DSIFA. +C***DESCRIPTION +C +C DSISL solves the double precision symmetric system +C A * X = B +C using the factors computed by DSIFA. +C +C On Entry +C +C A DOUBLE PRECISION(LDA,N) +C the output from DSIFA. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C KPVT INTEGER(N) +C the pivot vector from DSIFA. +C +C B DOUBLE PRECISION(N) +C the right hand side vector. +C +C On Return +C +C B the solution vector X . +C +C Error Condition +C +C A division by zero may occur if DSICO has set RCOND .EQ. 0.0 +C or DSIFA has set INFO .NE. 0 . +C +C To compute INVERSE(A) * C where C is a matrix +C with P columns +C CALL DSIFA(A,LDA,N,KPVT,INFO) +C IF (INFO .NE. 0) GO TO ... +C DO 10 J = 1, P +C CALL DSISL(A,LDA,N,KPVT,C(1,J)) +C 10 CONTINUE +C +C LINPACK. This version dated 08/14/78 . +C James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. +C +C Subroutines and Functions +C +C BLAS DAXPY,DDOT +C Fortran IABS +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DDOT +C***END PROLOGUE DSISL + INTEGER LDA,N,KPVT(1) + DOUBLE PRECISION A(LDA,1),B(1) +C + DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP + INTEGER K,KP +C +C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND +C D INVERSE TO B. +C +C***FIRST EXECUTABLE STATEMENT DSISL + K = N + 10 IF (K .EQ. 0) GO TO 80 + IF (KPVT(K) .LT. 0) GO TO 40 +C +C 1 X 1 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 30 + KP = KPVT(K) + IF (KP .EQ. K) GO TO 20 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 20 CONTINUE +C +C APPLY THE TRANSFORMATION. +C + CALL DAXPY(K-1,B(K),A(1,K),1,B(1),1) + 30 CONTINUE +C +C APPLY D INVERSE. +C + B(K) = B(K)/A(K,K) + K = K - 1 + GO TO 70 + 40 CONTINUE +C +C 2 X 2 PIVOT BLOCK. +C + IF (K .EQ. 2) GO TO 60 + KP = IABS(KPVT(K)) + IF (KP .EQ. K - 1) GO TO 50 +C +C INTERCHANGE. +C + TEMP = B(K-1) + B(K-1) = B(KP) + B(KP) = TEMP + 50 CONTINUE +C +C APPLY THE TRANSFORMATION. +C + CALL DAXPY(K-2,B(K),A(1,K),1,B(1),1) + CALL DAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) + 60 CONTINUE +C +C APPLY D INVERSE. +C + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + BK = B(K)/A(K-1,K) + BKM1 = B(K-1)/A(K-1,K) + DENOM = AK*AKM1 - 1.0D0 + B(K) = (AKM1*BK - BKM1)/DENOM + B(K-1) = (AK*BKM1 - BK)/DENOM + K = K - 2 + 70 CONTINUE + GO TO 10 + 80 CONTINUE +C +C LOOP FORWARD APPLYING THE TRANSFORMATIONS. +C + K = 1 + 90 IF (K .GT. N) GO TO 160 + IF (KPVT(K) .LT. 0) GO TO 120 +C +C 1 X 1 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 110 +C +C APPLY THE TRANSFORMATION. +C + B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) + KP = KPVT(K) + IF (KP .EQ. K) GO TO 100 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 100 CONTINUE + 110 CONTINUE + K = K + 1 + GO TO 150 + 120 CONTINUE +C +C 2 X 2 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 140 +C +C APPLY THE TRANSFORMATION. +C + B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) + B(K+1) = B(K+1) + DDOT(K-1,A(1,K+1),1,B(1),1) + KP = IABS(KPVT(K)) + IF (KP .EQ. K) GO TO 130 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 130 CONTINUE + 140 CONTINUE + K = K + 2 + 150 CONTINUE + GO TO 90 + 160 CONTINUE + RETURN + END + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +****BEGIN PROLOGUE DSWAP +****DATE WRITTEN 791001 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D1A5 +****KEYWORDS BLAS,DOUBLE PRECISION,INTERCHANGE,LINEAR ALGEBRA,VECTOR +****AUTHOR LAWSON, C. L., (JPL) +* HANSON, R. J., (SNLA) +* KINCAID, D. R., (U. OF TEXAS) +* KROGH, F. T., (JPL) +****PURPOSE Interchange d.p. vectors +****DESCRIPTION +* +* B L A S Subprogram +* Description of Parameters +* +* --Input-- +* N number of elements in input vector(s) +* DX double precision vector with N elements +* INCX storage spacing between elements of DX +* DY double precision vector with N elements +* INCY storage spacing between elements of DY +* +* --Output-- +* DX input vector DY (unchanged if N .LE. 0) +* DY input vector DX (unchanged if N .LE. 0) +* +* Interchange double precision DX and double precision DY. +* For I = 0 to N-1, interchange DX(LX+I*INCX) and DY(LY+I*INCY), +* where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is +* defined in a similar way using INCY. +****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +****ROUTINES CALLED (NONE) +****END PROLOGUE DSWAP +* + DOUBLE PRECISION DX(1),DY(1),DTEMP1,DTEMP2,DTEMP3 +****FIRST EXECUTABLE STATEMENT DSWAP + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE +* +* CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. +* + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP1 = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP1 + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +* +* CODE FOR BOTH INCREMENTS EQUAL TO 1 +* +* +* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. +* + 20 M = MOD(N,3) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 30 CONTINUE + IF( N .LT. 3 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,3 + DTEMP1 = DX(I) + DTEMP2 = DX(I+1) + DTEMP3 = DX(I+2) + DX(I) = DY(I) + DX(I+1) = DY(I+1) + DX(I+2) = DY(I+2) + DY(I) = DTEMP1 + DY(I+1) = DTEMP2 + DY(I+2) = DTEMP3 + 50 CONTINUE + RETURN + 60 CONTINUE +* +* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. +* + NS = N*INCX + DO 70 I=1,NS,INCX + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 70 CONTINUE + RETURN + END + INTEGER FUNCTION IDAMAX(N,DX,INCX) +****BEGIN PROLOGUE IDAMAX +****DATE WRITTEN 791001 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D1A2 +****KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT, +* VECTOR +****AUTHOR LAWSON, C. L., (JPL) +* HANSON, R. J., (SNLA) +* KINCAID, D. R., (U. OF TEXAS) +* KROGH, F. T., (JPL) +****PURPOSE Find largest component of d.p. vector +****DESCRIPTION +* +* B L A S Subprogram +* Description of Parameters +* +* --Input-- +* N number of elements in input vector(s) +* DX double precision vector with N elements +* INCX storage spacing between elements of DX +* +* --Output-- +* IDAMAX smallest index (zero if N .LE. 0) +* +* Find smallest index of maximum magnitude of double precision DX. +* IDAMAX = first I, I = 1 to N, to minimize ABS(DX(1-INCX+I*INCX) +****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +****ROUTINES CALLED (NONE) +****END PROLOGUE IDAMAX +* + DOUBLE PRECISION DX(1),DMAX,XMAG +****FIRST EXECUTABLE STATEMENT IDAMAX + IDAMAX = 0 + IF(N.LE.0) RETURN + IDAMAX = 1 + IF(N.LE.1)RETURN + IF(INCX.EQ.1)GOTO 20 +* +* CODE FOR INCREMENTS NOT EQUAL TO 1. +* + DMAX = DABS(DX(1)) + NS = N*INCX + II = 1 + DO 10 I = 1,NS,INCX + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 5 + IDAMAX = II + DMAX = XMAG + 5 II = II + 1 + 10 CONTINUE + RETURN +* +* CODE FOR INCREMENTS EQUAL TO 1. +* + 20 DMAX = DABS(DX(1)) + DO 30 I = 2,N + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 30 + IDAMAX = I + DMAX = XMAG + 30 CONTINUE + RETURN + END + SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) +****BEGIN PROLOGUE DGEFA +****DATE WRITTEN 780814 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D2A1 +****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX +****AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +****PURPOSE Factors a double precision matrix by Gaussian elimination. +****DESCRIPTION +* +* DGEFA factors a double precision matrix by Gaussian elimination. +* +* DGEFA is usually called by DGECO, but it can be called +* directly with a saving in time if RCOND is not needed. +* (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . +* +* On Entry +* +* A DOUBLE PRECISION(LDA, N) +* the matrix to be factored. +* +* LDA INTEGER +* the leading dimension of the array A . +* +* N INTEGER +* the order of the matrix A . +* +* On Return +* +* A an upper triangular matrix and the multipliers +* which were used to obtain it. +* The factorization can be written A = L*U where +* L is a product of permutation and unit lower +* triangular matrices and U is upper triangular. +* +* IPVT INTEGER(N) +* an integer vector of pivot indices. +* +* INFO INTEGER +* = 0 normal value. +* = K if U(K,K) .EQ. 0.0 . This is not an error +* condition for this subroutine, but it does +* indicate that DGESL or DGEDI will divide by zero +* if called. Use RCOND in DGECO for a reliable +* indication of singularity. +* +* LINPACK. This version dated 08/14/78 . +* Cleve Moler, University of New Mexico, Argonne National Lab. +* +* Subroutines and Functions +* +* BLAS DAXPY,DSCAL,IDAMAX +****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +* *LINPACK USERS GUIDE*, SIAM, 1979. +****ROUTINES CALLED DAXPY,DSCAL,IDAMAX +****END PROLOGUE DGEFA + INTEGER LDA,N,IPVT(1),INFO + DOUBLE PRECISION A(LDA,1) +* + DOUBLE PRECISION T + INTEGER IDAMAX,J,K,KP1,L,NM1 +* +* GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING +* +****FIRST EXECUTABLE STATEMENT DGEFA + INFO = 0 + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 70 + DO 60 K = 1, NM1 + KP1 = K + 1 +* +* FIND L = PIVOT INDEX +* + L = IDAMAX(N-K+1,A(K,K),1) + K - 1 + IPVT(K) = L +* +* ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED +* + IF (A(L,K) .EQ. 0.0D0) GO TO 40 +* +* INTERCHANGE IF NECESSARY +* + IF (L .EQ. K) GO TO 10 + T = A(L,K) + A(L,K) = A(K,K) + A(K,K) = T + 10 CONTINUE +* +* COMPUTE MULTIPLIERS +* + T = -1.0D0/A(K,K) + CALL DSCAL(N-K,T,A(K+1,K),1) +* +* ROW ELIMINATION WITH COLUMN INDEXING +* + DO 30 J = KP1, N + T = A(L,J) + IF (L .EQ. K) GO TO 20 + A(L,J) = A(K,J) + A(K,J) = T + 20 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) + 30 CONTINUE + GO TO 50 + 40 CONTINUE + INFO = K + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IPVT(N) = N + IF (A(N,N) .EQ. 0.0D0) INFO = N + RETURN + END + SUBROUTINE DSIFA(A,LDA,N,KPVT,INFO) +****BEGIN PROLOGUE DSIFA +****DATE WRITTEN 780814 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D2B1A +****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX, +* SYMMETRIC +****AUTHOR BUNCH, J., (UCSD) +****PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with +* symmetric pivoting +****DESCRIPTION +* +* DSIFA factors a double precision symmetric matrix by elimination +* with symmetric pivoting. +* +* To solve A*X = B , follow DSIFA by DSISL. +* To compute INVERSE(A)*C , follow DSIFA by DSISL. +* To compute DETERMINANT(A) , follow DSIFA by DSIDI. +* To compute INERTIA(A) , follow DSIFA by DSIDI. +* To compute INVERSE(A) , follow DSIFA by DSIDI. +* +* On Entry +* +* A DOUBLE PRECISION(LDA,N) +* the symmetric matrix to be factored. +* Only the diagonal and upper triangle are used. +* +* LDA INTEGER +* the leading dimension of the array A . +* +* N INTEGER +* the order of the matrix A . +* +* On Return +* +* A a block diagonal matrix and the multipliers which +* were used to obtain it. +* The factorization can be written A = U*D*TRANS(U) +* where U is a product of permutation and unit +* upper triangular matrices, TRANS(U) is the +* transpose of U , and D is block diagonal +* with 1 by 1 and 2 by 2 blocks. +* +* KPVT INTEGER(N) +* an integer vector of pivot indices. +* +* INFO INTEGER +* = 0 normal value. +* = K if the K-th pivot block is singular. This is +* not an error condition for this subroutine, +* but it does indicate that DSISL or DSIDI may +* divide by zero if called. +* +* LINPACK. This version dated 08/14/78 . +* James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. +* +* Subroutines and Functions +* +* BLAS DAXPY,DSWAP,IDAMAX +* Fortran DABS,DMAX1,DSQRT +****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +* *LINPACK USERS GUIDE*, SIAM, 1979. +****ROUTINES CALLED DAXPY,DSWAP,IDAMAX +****END PROLOGUE DSIFA + INTEGER LDA,N,KPVT(1),INFO + DOUBLE PRECISION A(LDA,1) +* + DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T + DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX + INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,IDAMAX + LOGICAL SWAP +* +* INITIALIZE +* +* ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. +****FIRST EXECUTABLE STATEMENT DSIFA + ALPHA = (1.0D0 + DSQRT(17.0D0))/8.0D0 +* + INFO = 0 +* +* MAIN LOOP ON K, WHICH GOES FROM N TO 1. +* + K = N + 10 CONTINUE +* +* LEAVE THE LOOP IF K=0 OR K=1. +* +* ...EXIT + IF (K .EQ. 0) GO TO 200 + IF (K .GT. 1) GO TO 20 + KPVT(1) = 1 + IF (A(1,1) .EQ. 0.0D0) INFO = 1 +* ......EXIT + GO TO 200 + 20 CONTINUE +* +* THIS SECTION OF CODE DETERMINES THE KIND OF +* ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, +* KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND +* SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS +* REQUIRED. +* + KM1 = K - 1 + ABSAKK = DABS(A(K,K)) +* +* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN +* COLUMN K. +* + IMAX = IDAMAX(K-1,A(1,K),1) + COLMAX = DABS(A(IMAX,K)) + IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 + KSTEP = 1 + SWAP = .FALSE. + GO TO 90 + 30 CONTINUE +* +* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN +* ROW IMAX. +* + ROWMAX = 0.0D0 + IMAXP1 = IMAX + 1 + DO 40 J = IMAXP1, K + ROWMAX = DMAX1(ROWMAX,DABS(A(IMAX,J))) + 40 CONTINUE + IF (IMAX .EQ. 1) GO TO 50 + JMAX = IDAMAX(IMAX-1,A(1,IMAX),1) + ROWMAX = DMAX1(ROWMAX,DABS(A(JMAX,IMAX))) + 50 CONTINUE + IF (DABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 + KSTEP = 1 + SWAP = .TRUE. + GO TO 80 + 60 CONTINUE + IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 + KSTEP = 1 + SWAP = .FALSE. + GO TO 80 + 70 CONTINUE + KSTEP = 2 + SWAP = IMAX .NE. KM1 + 80 CONTINUE + 90 CONTINUE + IF (DMAX1(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100 +* +* COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. +* + KPVT(K) = K + INFO = K + GO TO 190 + 100 CONTINUE + IF (KSTEP .EQ. 2) GO TO 140 +* +* 1 X 1 PIVOT BLOCK. +* + IF (.NOT.SWAP) GO TO 120 +* +* PERFORM AN INTERCHANGE. +* + CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K),1) + DO 110 JJ = IMAX, K + J = K + IMAX - JJ + T = A(J,K) + A(J,K) = A(IMAX,J) + A(IMAX,J) = T + 110 CONTINUE + 120 CONTINUE +* +* PERFORM THE ELIMINATION. +* + DO 130 JJ = 1, KM1 + J = K - JJ + MULK = -A(J,K)/A(K,K) + T = MULK + CALL DAXPY(J,T,A(1,K),1,A(1,J),1) + A(J,K) = MULK + 130 CONTINUE +* +* SET THE PIVOT ARRAY. +* + KPVT(K) = K + IF (SWAP) KPVT(K) = IMAX + GO TO 190 + 140 CONTINUE +* +* 2 X 2 PIVOT BLOCK. +* + IF (.NOT.SWAP) GO TO 160 +* +* PERFORM AN INTERCHANGE. +* + CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) + DO 150 JJ = IMAX, KM1 + J = KM1 + IMAX - JJ + T = A(J,K-1) + A(J,K-1) = A(IMAX,J) + A(IMAX,J) = T + 150 CONTINUE + T = A(K-1,K) + A(K-1,K) = A(IMAX,K) + A(IMAX,K) = T + 160 CONTINUE +* +* PERFORM THE ELIMINATION. +* + KM2 = K - 2 + IF (KM2 .EQ. 0) GO TO 180 + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + DENOM = 1.0D0 - AK*AKM1 + DO 170 JJ = 1, KM2 + J = KM1 - JJ + BK = A(J,K)/A(K-1,K) + BKM1 = A(J,K-1)/A(K-1,K) + MULK = (AKM1*BK - BKM1)/DENOM + MULKM1 = (AK*BKM1 - BK)/DENOM + T = MULK + CALL DAXPY(J,T,A(1,K),1,A(1,J),1) + T = MULKM1 + CALL DAXPY(J,T,A(1,K-1),1,A(1,J),1) + A(J,K) = MULK + A(J,K-1) = MULKM1 + 170 CONTINUE + 180 CONTINUE +* +* SET THE PIVOT ARRAY. +* + KPVT(K) = 1 - K + IF (SWAP) KPVT(K) = -IMAX + KPVT(K-1) = KPVT(K) + 190 CONTINUE + K = K - KSTEP + GO TO 10 + 200 CONTINUE + RETURN + END + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +****BEGIN PROLOGUE DASUM +****DATE WRITTEN 791001 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D1A3A +****KEYWORDS ADD,BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAGNITUDE,SUM, +* VECTOR +****AUTHOR LAWSON, C. L., (JPL) +* HANSON, R. J., (SNLA) +* KINCAID, D. R., (U. OF TEXAS) +* KROGH, F. T., (JPL) +****PURPOSE Sum of magnitudes of d.p. vector components +****DESCRIPTION +* +* B L A S Subprogram +* Description of Parameters +* +* --Input-- +* N number of elements in input vector(s) +* DX double precision vector with N elements +* INCX storage spacing between elements of DX +* +* --Output-- +* DASUM double precision result (zero if N .LE. 0) +* +* Returns sum of magnitudes of double precision DX. +* DASUM = sum from 0 to N-1 of DABS(DX(1+I*INCX)) +****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +****ROUTINES CALLED (NONE) +****END PROLOGUE DASUM +* + DOUBLE PRECISION DX(1) +****FIRST EXECUTABLE STATEMENT DASUM + DASUM = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 +* +* CODE FOR INCREMENTS NOT EQUAL TO 1. +* + NS = N*INCX + DO 10 I=1,NS,INCX + DASUM = DASUM + DABS(DX(I)) + 10 CONTINUE + RETURN +* +* CODE FOR INCREMENTS EQUAL TO 1. +* +* +* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. +* + 20 M = MOD(N,6) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DASUM = DASUM + DABS(DX(I)) + 30 CONTINUE + IF( N .LT. 6 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,6 + DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) + & + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) + 50 CONTINUE + RETURN + END + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +****BEGIN PROLOGUE DAXPY +****DATE WRITTEN 791001 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D1A7 +****KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,TRIAD,VECTOR +****AUTHOR LAWSON, C. L., (JPL) +* HANSON, R. J., (SNLA) +* KINCAID, D. R., (U. OF TEXAS) +* KROGH, F. T., (JPL) +****PURPOSE D.P computation y = a*x + y +****DESCRIPTION +* +* B L A S Subprogram +* Description of Parameters +* +* --Input-- +* N number of elements in input vector(s) +* DA double precision scalar multiplier +* DX double precision vector with N elements +* INCX storage spacing between elements of DX +* DY double precision vector with N elements +* INCY storage spacing between elements of DY +* +* --Output-- +* DY double precision result (unchanged if N .LE. 0) +* +* Overwrite double precision DY with double precision DA*DX + DY. +* For I = 0 to N-1, replace DY(LY+I*INCY) with DA*DX(LX+I*INCX) + +* DY(LY+I*INCY), where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N +* and LY is defined in a similar way using INCY. +****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +****ROUTINES CALLED (NONE) +****END PROLOGUE DAXPY +* + DOUBLE PRECISION DX(1),DY(1),DA +****FIRST EXECUTABLE STATEMENT DAXPY + IF(N.LE.0.OR.DA.EQ.0.D0) RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE +* +* CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. +* + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +* +* CODE FOR BOTH INCREMENTS EQUAL TO 1 +* +* +* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. +* + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I + 1) = DY(I + 1) + DA*DX(I + 1) + DY(I + 2) = DY(I + 2) + DA*DX(I + 2) + DY(I + 3) = DY(I + 3) + DA*DX(I + 3) + 50 CONTINUE + RETURN +* +* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. +* + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DY(I) = DA*DX(I) + DY(I) + 70 CONTINUE + RETURN + END + SUBROUTINE DSCAL(N,DA,DX,INCX) +****BEGIN PROLOGUE DSCAL +****DATE WRITTEN 791001 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D1A6 +****KEYWORDS BLAS,LINEAR ALGEBRA,SCALE,VECTOR +****AUTHOR LAWSON, C. L., (JPL) +* HANSON, R. J., (SNLA) +* KINCAID, D. R., (U. OF TEXAS) +* KROGH, F. T., (JPL) +****PURPOSE D.P. vector scale x = a*x +****DESCRIPTION +* +* B L A S Subprogram +* Description of Parameters +* +* --Input-- +* N number of elements in input vector(s) +* DA double precision scale factor +* DX double precision vector with N elements +* INCX storage spacing between elements of DX +* +* --Output-- +* DX double precision result (unchanged if N.LE.0) +* +* Replace double precision DX by double precision DA*DX. +* For I = 0 to N-1, replace DX(1+I*INCX) with DA * DX(1+I*INCX) +****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +****ROUTINES CALLED (NONE) +****END PROLOGUE DSCAL +* + DOUBLE PRECISION DA,DX(1) +****FIRST EXECUTABLE STATEMENT DSCAL + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 +* +* CODE FOR INCREMENTS NOT EQUAL TO 1. +* + NS = N*INCX + DO 10 I = 1,NS,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN +* +* CODE FOR INCREMENTS EQUAL TO 1. +* +* +* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. +* + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I + 1) = DA*DX(I + 1) + DX(I + 2) = DA*DX(I + 2) + DX(I + 3) = DA*DX(I + 3) + DX(I + 4) = DA*DX(I + 4) + 50 CONTINUE + RETURN + END + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) + implicit double precision (a-h, o-z) +C RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. +C DDOT = SUM FOR I = 0 TO N-1 OF DX(LX+I*INCX) * DY(LY+I*INCY) +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. + DOUBLE PRECISION DX(1),DY(1) + DDOT = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DDOT = DDOT + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C CODE FOR BOTH INCREMENTS EQUAL TO 1. +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DDOT = DDOT + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + & DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + RETURN +C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DDOT = DDOT + DX(I)*DY(I) + 70 CONTINUE + RETURN + END + DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) + implicit double precision (a-h, o-z) + INTEGER NEXT + DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE + DATA ZERO, ONE /0.0D0, 1.0D0/ +C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE +C INCREMENT INCX . +C C.L.LAWSON, 1978 JAN 08 + DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / + IF(N .GT. 0) GO TO 10 + DNRM2 = ZERO + GO TO 300 + 10 ASSIGN 30 TO NEXT + SUM = ZERO + NN = N * INCX +C BEGIN MAIN LOOP + I = 1 + 20 GO TO NEXT,(30, 50, 70, 110) + 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + ASSIGN 50 TO NEXT + XMAX = ZERO +C PHASE 1. SUM IS ZERO + 50 IF( DX(I) .EQ. ZERO) GO TO 200 + IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 +C PREPARE FOR PHASE 2. + ASSIGN 70 TO NEXT + GO TO 105 +C PREPARE FOR PHASE 4. + 100 I = J + ASSIGN 110 TO NEXT + SUM = (SUM / DX(I)) / DX(I) + 105 XMAX = DABS(DX(I)) + GO TO 115 +C PHASE 2. SUM IS SMALL. +C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. + 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 +C COMMON CODE FOR PHASES 2 AND 4. +C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. + 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 + SUM = ONE + SUM * (XMAX / DX(I))**2 + XMAX = DABS(DX(I)) + GO TO 200 + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 +C PREPARE FOR PHASE 3. + 75 SUM = (SUM * XMAX) * XMAX +C FOR REAL OR D.P. SET HITEST = CUTHI/N +C FOR COMPLEX SET HITEST = CUTHI/(2*N) + 85 HITEST = CUTHI/FLOAT( N ) +C PHASE 3. SUM IS MID-RANGE. NO SCALING. + DO 95 J =I,NN,INCX + IF(DABS(DX(J)) .GE. HITEST) GO TO 100 + 95 SUM = SUM + DX(J)**2 + DNRM2 = DSQRT( SUM ) + GO TO 300 + 200 CONTINUE + I = I + INCX + IF ( I .LE. NN ) GO TO 20 +C END OF MAIN LOOP. +C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. + DNRM2 = XMAX * DSQRT(SUM) + 300 CONTINUE + RETURN + END diff --git a/OpticsJan2020/MLI_light_optics/Src/linpak_old.f b/OpticsJan2020/MLI_light_optics/Src/linpak_old.f new file mode 100755 index 0000000..ddfd2b8 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/linpak_old.f @@ -0,0 +1,1187 @@ + SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) +C***BEGIN PROLOGUE DGECO +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A1 +C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, +C MATRIX +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE Factors a double precision matrix by Gaussian elimination +C and estimates the condition of the matrix. +C***DESCRIPTION +C +C DGECO factors a double precision matrix by Gaussian elimination +C and estimates the condition of the matrix. +C +C If RCOND is not needed, DGEFA is slightly faster. +C To solve A*X = B , follow DGECO by DGESL. +C To compute INVERSE(A)*C , follow DGECO by DGESL. +C To compute DETERMINANT(A) , follow DGECO by DGEDI. +C To compute INVERSE(A) , follow DGECO by DGEDI. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the matrix to be factored. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C On Return +C +C A an upper triangular matrix and the multipliers +C which were used to obtain it. +C The factorization can be written A = L*U where +C L is a product of permutation and unit lower +C triangular matrices and U is upper triangular. +C +C IPVT INTEGER(N) +C an INTEGER vector of pivot indices. +C +C RCOND DOUBLE PRECISION +C an estimate of the reciprocal condition of A . +C For the system A*X = B , relative perturbations +C in A and B of size EPSILON may cause +C relative perturbations in X of size EPSILON/RCOND . +C If RCOND is so small that the logical expression +C 1.0 + RCOND .EQ. 1.0 +C is true, then A may be singular to working +C precision. In particular, RCOND is zero if +C exact singularity is detected or the estimate +C underflows. +C +C Z DOUBLE PRECISION(N) +C a work vector whose contents are usually unimportant. +C If A is close to a singular matrix, then Z is +C an approximate null vector in the sense that +C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . +C +C LINPACK. This version dated 08/14/78 . +C Cleve Moler, University of New Mexico, Argonne National Lab. +C +C Subroutines and Functions +C +C LINPACK DGEFA +C BLAS DAXPY,DDOT,DSCAL,DASUM +C Fortran DABS,DMAX1,DSIGN +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DASUM,DAXPY,DDOT,DGEFA,DSCAL +C***END PROLOGUE DGECO + INTEGER LDA,N,IPVT(1) + DOUBLE PRECISION A(LDA,1),Z(1) + DOUBLE PRECISION RCOND +C + DOUBLE PRECISION DDOT,EK,T,WK,WKM + DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM + INTEGER INFO,J,K,KB,KP1,L +C +C COMPUTE 1-NORM OF A +C +C***FIRST EXECUTABLE STATEMENT DGECO + ANORM = 0.0D0 + DO 10 J = 1, N + ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1)) + 10 CONTINUE +C +C FACTOR +C + CALL DGEFA(A,LDA,N,IPVT,INFO) +C +C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . +C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE +C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE +C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID +C OVERFLOW. +C +C SOLVE TRANS(U)*W = E +C + EK = 1.0D0 + DO 20 J = 1, N + Z(J) = 0.0D0 + 20 CONTINUE + DO 100 K = 1, N + IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) + IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30 + S = DABS(A(K,K))/DABS(EK-Z(K)) + CALL DSCAL(N,S,Z,1) + EK = S*EK + 30 CONTINUE + WK = EK - Z(K) + WKM = -EK - Z(K) + S = DABS(WK) + SM = DABS(WKM) + IF (A(K,K) .EQ. 0.0D0) GO TO 40 + WK = WK/A(K,K) + WKM = WKM/A(K,K) + GO TO 50 + 40 CONTINUE + WK = 1.0D0 + WKM = 1.0D0 + 50 CONTINUE + KP1 = K + 1 + IF (KP1 .GT. N) GO TO 90 + DO 60 J = KP1, N + SM = SM + DABS(Z(J)+WKM*A(K,J)) + Z(J) = Z(J) + WK*A(K,J) + S = S + DABS(Z(J)) + 60 CONTINUE + IF (S .GE. SM) GO TO 80 + T = WKM - WK + WK = WKM + DO 70 J = KP1, N + Z(J) = Z(J) + T*A(K,J) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + Z(K) = WK + 100 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C +C SOLVE TRANS(L)*Y = W +C + DO 120 KB = 1, N + K = N + 1 - KB + IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) + IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110 + S = 1.0D0/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + 110 CONTINUE + L = IPVT(K) + T = Z(L) + Z(L) = Z(K) + Z(K) = T + 120 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C + YNORM = 1.0D0 +C +C SOLVE L*V = Y +C + DO 140 K = 1, N + L = IPVT(K) + T = Z(L) + Z(L) = Z(K) + Z(K) = T + IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) + IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130 + S = 1.0D0/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 130 CONTINUE + 140 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C +C SOLVE U*Z = V +C + DO 160 KB = 1, N + K = N + 1 - KB + IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150 + S = DABS(A(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 150 CONTINUE + IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) + IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + T = -Z(K) + CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) + 160 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C + IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM + IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END + SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) +C***BEGIN PROLOGUE DGESL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A1 +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE Solves the double precision system A*X=B or TRANS(A)*X=B +C using the factors computed by DGECO or DGEFA. +C***DESCRIPTION +C +C DGESL solves the double precision system +C A * X = B or TRANS(A) * X = B +C using the factors computed by DGECO or DGEFA. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the output from DGECO or DGEFA. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C IPVT INTEGER(N) +C the pivot vector from DGECO or DGEFA. +C +C B DOUBLE PRECISION(N) +C the right hand side vector. +C +C JOB INTEGER +C = 0 to solve A*X = B , +C = nonzero to solve TRANS(A)*X = B where +C TRANS(A) is the transpose. +C +C On Return +C +C B the solution vector X . +C +C Error Condition +C +C A division by zero will occur if the input factor contains a +C zero on the diagonal. Technically this indicates singularity +C but it is often caused by improper arguments or improper +C setting of LDA . It will not occur if the subroutines are +C called correctly and if DGECO has set RCOND .GT. 0.0 +C or DGEFA has set INFO .EQ. 0 . +C +C To compute INVERSE(A) * C where C is a matrix +C with P columns +C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) +C IF (RCOND is too small) GO TO ... +C DO 10 J = 1, P +C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) +C 10 CONTINUE +C +C LINPACK. This version dated 08/14/78 . +C Cleve Moler, University of New Mexico, Argonne National Lab. +C +C Subroutines and Functions +C +C BLAS DAXPY,DDOT +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DDOT +C***END PROLOGUE DGESL + INTEGER LDA,N,IPVT(1),JOB + DOUBLE PRECISION A(LDA,1),B(1) +C + DOUBLE PRECISION DDOT,T + INTEGER K,KB,L,NM1 +C***FIRST EXECUTABLE STATEMENT DGESL + NM1 = N - 1 + IF (JOB .NE. 0) GO TO 50 +C +C JOB = 0 , SOLVE A * X = B +C FIRST SOLVE L*Y = B +C + IF (NM1 .LT. 1) GO TO 30 + DO 20 K = 1, NM1 + L = IPVT(K) + T = B(L) + IF (L .EQ. K) GO TO 10 + B(L) = B(K) + B(K) = T + 10 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) + 20 CONTINUE + 30 CONTINUE +C +C NOW SOLVE U*X = Y +C + DO 40 KB = 1, N + K = N + 1 - KB + B(K) = B(K)/A(K,K) + T = -B(K) + CALL DAXPY(K-1,T,A(1,K),1,B(1),1) + 40 CONTINUE + GO TO 100 + 50 CONTINUE +C +C JOB = NONZERO, SOLVE TRANS(A) * X = B +C FIRST SOLVE TRANS(U)*Y = B +C + DO 60 K = 1, N + T = DDOT(K-1,A(1,K),1,B(1),1) + B(K) = (B(K) - T)/A(K,K) + 60 CONTINUE +C +C NOW SOLVE TRANS(L)*X = Y +C + IF (NM1 .LT. 1) GO TO 90 + DO 80 KB = 1, NM1 + K = N - KB + B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) + L = IPVT(K) + IF (L .EQ. K) GO TO 70 + T = B(L) + B(L) = B(K) + B(K) = T + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RETURN + END + SUBROUTINE DSICO(A,LDA,N,KPVT,RCOND,Z) +C***BEGIN PROLOGUE DSICO +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2B1A +C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, +C MATRIX,SYMMETRIC +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with symmet- +C ric pivoting and estimates the condition of the matrix. +C***DESCRIPTION +C +C DSICO factors a double precision symmetric matrix by elimination +C with symmetric pivoting and estimates the condition of the +C matrix. +C +C If RCOND is not needed, DSIFA is slightly faster. +C To solve A*X = B , follow DSICO by DSISL. +C To compute INVERSE(A)*C , follow DSICO by DSISL. +C To compute INVERSE(A) , follow DSICO by DSIDI. +C To compute DETERMINANT(A) , follow DSICO by DSIDI. +C To compute INERTIA(A), follow DSICO by DSIDI. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the symmetric matrix to be factored. +C Only the diagonal and upper triangle are used. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C Output +C +C A a block diagonal matrix and the multipliers which +C were used to obtain it. +C The factorization can be written A = U*D*TRANS(U) +C where U is a product of permutation and unit +C upper triangular matrices, TRANS(U) is the +C transpose of U , and D is block diagonal +C with 1 by 1 and 2 by 2 blocks. +C +C KPVT INTEGER(N) +C an integer vector of pivot indices. +C +C RCOND DOUBLE PRECISION +C an estimate of the reciprocal condition of A . +C For the system A*X = B , relative perturbations +C in A and B of size EPSILON may cause +C relative perturbations in X of size EPSILON/RCOND . +C If RCOND is so small that the logical expression +C 1.0 + RCOND .EQ. 1.0 +C is true, then A may be singular to working +C precision. In particular, RCOND is zero if +C exact singularity is detected or the estimate +C underflows. +C +C Z DOUBLE PRECISION(N) +C a work vector whose contents are usually unimportant. +C If A is close to a singular matrix, then Z is +C an approximate null vector in the sense that +C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . +C +C LINPACK. This version dated 08/14/78 . +C Cleve Moler, University of New Mexico, Argonne National Lab. +C +C Subroutines and Functions +C +C LINPACK DSIFA +C BLAS DAXPY,DDOT,DSCAL,DASUM +C Fortran DABS,DMAX1,IABS,DSIGN +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DASUM,DAXPY,DDOT,DSCAL,DSIFA +C***END PROLOGUE DSICO + INTEGER LDA,N,KPVT(1) + DOUBLE PRECISION A(LDA,1),Z(1) + DOUBLE PRECISION RCOND +C + DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T + DOUBLE PRECISION ANORM,S,DASUM,YNORM + INTEGER I,INFO,J,JM1,K,KP,KPS,KS +C +C FIND NORM OF A USING ONLY UPPER HALF +C +C***FIRST EXECUTABLE STATEMENT DSICO + DO 30 J = 1, N + Z(J) = DASUM(J,A(1,J),1) + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 20 + DO 10 I = 1, JM1 + Z(I) = Z(I) + DABS(A(I,J)) + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + ANORM = 0.0D0 + DO 40 J = 1, N + ANORM = DMAX1(ANORM,Z(J)) + 40 CONTINUE +C +C FACTOR +C + CALL DSIFA(A,LDA,N,KPVT,INFO) +C +C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . +C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL +C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . +C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. +C +C SOLVE U*D*W = E +C + EK = 1.0D0 + DO 50 J = 1, N + Z(J) = 0.0D0 + 50 CONTINUE + K = N + 60 IF (K .EQ. 0) GO TO 120 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + KP = IABS(KPVT(K)) + KPS = K + 1 - KS + IF (KP .EQ. KPS) GO TO 70 + T = Z(KPS) + Z(KPS) = Z(KP) + Z(KP) = T + 70 CONTINUE + IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,Z(K)) + Z(K) = Z(K) + EK + CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) + IF (KS .EQ. 1) GO TO 80 + IF (Z(K-1) .NE. 0.0D0) EK = DSIGN(EK,Z(K-1)) + Z(K-1) = Z(K-1) + EK + CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) + 80 CONTINUE + IF (KS .EQ. 2) GO TO 100 + IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 90 + S = DABS(A(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + EK = S*EK + 90 CONTINUE + IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) + IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + GO TO 110 + 100 CONTINUE + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + BK = Z(K)/A(K-1,K) + BKM1 = Z(K-1)/A(K-1,K) + DENOM = AK*AKM1 - 1.0D0 + Z(K) = (AKM1*BK - BKM1)/DENOM + Z(K-1) = (AK*BKM1 - BK)/DENOM + 110 CONTINUE + K = K - KS + GO TO 60 + 120 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C +C SOLVE TRANS(U)*Y = W +C + K = 1 + 130 IF (K .GT. N) GO TO 160 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + IF (K .EQ. 1) GO TO 150 + Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) + IF (KS .EQ. 2) + & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) + KP = IABS(KPVT(K)) + IF (KP .EQ. K) GO TO 140 + T = Z(K) + Z(K) = Z(KP) + Z(KP) = T + 140 CONTINUE + 150 CONTINUE + K = K + KS + GO TO 130 + 160 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C + YNORM = 1.0D0 +C +C SOLVE U*D*V = Y +C + K = N + 170 IF (K .EQ. 0) GO TO 230 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + IF (K .EQ. KS) GO TO 190 + KP = IABS(KPVT(K)) + KPS = K + 1 - KS + IF (KP .EQ. KPS) GO TO 180 + T = Z(KPS) + Z(KPS) = Z(KP) + Z(KP) = T + 180 CONTINUE + CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) + IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) + 190 CONTINUE + IF (KS .EQ. 2) GO TO 210 + IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 200 + S = DABS(A(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 200 CONTINUE + IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) + IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + GO TO 220 + 210 CONTINUE + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + BK = Z(K)/A(K-1,K) + BKM1 = Z(K-1)/A(K-1,K) + DENOM = AK*AKM1 - 1.0D0 + Z(K) = (AKM1*BK - BKM1)/DENOM + Z(K-1) = (AK*BKM1 - BK)/DENOM + 220 CONTINUE + K = K - KS + GO TO 170 + 230 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C +C SOLVE TRANS(U)*Z = V +C + K = 1 + 240 IF (K .GT. N) GO TO 270 + KS = 1 + IF (KPVT(K) .LT. 0) KS = 2 + IF (K .EQ. 1) GO TO 260 + Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) + IF (KS .EQ. 2) + & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) + KP = IABS(KPVT(K)) + IF (KP .EQ. K) GO TO 250 + T = Z(K) + Z(K) = Z(KP) + Z(KP) = T + 250 CONTINUE + 260 CONTINUE + K = K + KS + GO TO 240 + 270 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C + IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM + IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END + SUBROUTINE DSISL(A,LDA,N,KPVT,B) +C***BEGIN PROLOGUE DSISL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2B1A +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, +C SYMMETRIC +C***AUTHOR BUNCH, J., (UCSD) +C***PURPOSE Solves the double precision SYMMETRIC system +C A*X=B using the factors computed by DSIFA. +C***DESCRIPTION +C +C DSISL solves the double precision symmetric system +C A * X = B +C using the factors computed by DSIFA. +C +C On Entry +C +C A DOUBLE PRECISION(LDA,N) +C the output from DSIFA. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C KPVT INTEGER(N) +C the pivot vector from DSIFA. +C +C B DOUBLE PRECISION(N) +C the right hand side vector. +C +C On Return +C +C B the solution vector X . +C +C Error Condition +C +C A division by zero may occur if DSICO has set RCOND .EQ. 0.0 +C or DSIFA has set INFO .NE. 0 . +C +C To compute INVERSE(A) * C where C is a matrix +C with P columns +C CALL DSIFA(A,LDA,N,KPVT,INFO) +C IF (INFO .NE. 0) GO TO ... +C DO 10 J = 1, P +C CALL DSISL(A,LDA,N,KPVT,C(1,J)) +C 10 CONTINUE +C +C LINPACK. This version dated 08/14/78 . +C James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. +C +C Subroutines and Functions +C +C BLAS DAXPY,DDOT +C Fortran IABS +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DDOT +C***END PROLOGUE DSISL + INTEGER LDA,N,KPVT(1) + DOUBLE PRECISION A(LDA,1),B(1) +C + DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP + INTEGER K,KP +C +C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND +C D INVERSE TO B. +C +C***FIRST EXECUTABLE STATEMENT DSISL + K = N + 10 IF (K .EQ. 0) GO TO 80 + IF (KPVT(K) .LT. 0) GO TO 40 +C +C 1 X 1 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 30 + KP = KPVT(K) + IF (KP .EQ. K) GO TO 20 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 20 CONTINUE +C +C APPLY THE TRANSFORMATION. +C + CALL DAXPY(K-1,B(K),A(1,K),1,B(1),1) + 30 CONTINUE +C +C APPLY D INVERSE. +C + B(K) = B(K)/A(K,K) + K = K - 1 + GO TO 70 + 40 CONTINUE +C +C 2 X 2 PIVOT BLOCK. +C + IF (K .EQ. 2) GO TO 60 + KP = IABS(KPVT(K)) + IF (KP .EQ. K - 1) GO TO 50 +C +C INTERCHANGE. +C + TEMP = B(K-1) + B(K-1) = B(KP) + B(KP) = TEMP + 50 CONTINUE +C +C APPLY THE TRANSFORMATION. +C + CALL DAXPY(K-2,B(K),A(1,K),1,B(1),1) + CALL DAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) + 60 CONTINUE +C +C APPLY D INVERSE. +C + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + BK = B(K)/A(K-1,K) + BKM1 = B(K-1)/A(K-1,K) + DENOM = AK*AKM1 - 1.0D0 + B(K) = (AKM1*BK - BKM1)/DENOM + B(K-1) = (AK*BKM1 - BK)/DENOM + K = K - 2 + 70 CONTINUE + GO TO 10 + 80 CONTINUE +C +C LOOP FORWARD APPLYING THE TRANSFORMATIONS. +C + K = 1 + 90 IF (K .GT. N) GO TO 160 + IF (KPVT(K) .LT. 0) GO TO 120 +C +C 1 X 1 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 110 +C +C APPLY THE TRANSFORMATION. +C + B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) + KP = KPVT(K) + IF (KP .EQ. K) GO TO 100 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 100 CONTINUE + 110 CONTINUE + K = K + 1 + GO TO 150 + 120 CONTINUE +C +C 2 X 2 PIVOT BLOCK. +C + IF (K .EQ. 1) GO TO 140 +C +C APPLY THE TRANSFORMATION. +C + B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) + B(K+1) = B(K+1) + DDOT(K-1,A(1,K+1),1,B(1),1) + KP = IABS(KPVT(K)) + IF (KP .EQ. K) GO TO 130 +C +C INTERCHANGE. +C + TEMP = B(K) + B(K) = B(KP) + B(KP) = TEMP + 130 CONTINUE + 140 CONTINUE + K = K + 2 + 150 CONTINUE + GO TO 90 + 160 CONTINUE + RETURN + END + SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) +****BEGIN PROLOGUE DGEFA +****DATE WRITTEN 780814 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D2A1 +****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX +****AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +****PURPOSE Factors a double precision matrix by Gaussian elimination. +****DESCRIPTION +* +* DGEFA factors a double precision matrix by Gaussian elimination. +* +* DGEFA is usually called by DGECO, but it can be called +* directly with a saving in time if RCOND is not needed. +* (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . +* +* On Entry +* +* A DOUBLE PRECISION(LDA, N) +* the matrix to be factored. +* +* LDA INTEGER +* the leading dimension of the array A . +* +* N INTEGER +* the order of the matrix A . +* +* On Return +* +* A an upper triangular matrix and the multipliers +* which were used to obtain it. +* The factorization can be written A = L*U where +* L is a product of permutation and unit lower +* triangular matrices and U is upper triangular. +* +* IPVT INTEGER(N) +* an integer vector of pivot indices. +* +* INFO INTEGER +* = 0 normal value. +* = K if U(K,K) .EQ. 0.0 . This is not an error +* condition for this subroutine, but it does +* indicate that DGESL or DGEDI will divide by zero +* if called. Use RCOND in DGECO for a reliable +* indication of singularity. +* +* LINPACK. This version dated 08/14/78 . +* Cleve Moler, University of New Mexico, Argonne National Lab. +* +* Subroutines and Functions +* +* BLAS DAXPY,DSCAL,IDAMAX +****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +* *LINPACK USERS GUIDE*, SIAM, 1979. +****ROUTINES CALLED DAXPY,DSCAL,IDAMAX +****END PROLOGUE DGEFA + INTEGER LDA,N,IPVT(1),INFO + DOUBLE PRECISION A(LDA,1) +* + DOUBLE PRECISION T + INTEGER IDAMAX,J,K,KP1,L,NM1 +* +* GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING +* +****FIRST EXECUTABLE STATEMENT DGEFA + INFO = 0 + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 70 + DO 60 K = 1, NM1 + KP1 = K + 1 +* +* FIND L = PIVOT INDEX +* + L = IDAMAX(N-K+1,A(K,K),1) + K - 1 + IPVT(K) = L +* +* ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED +* + IF (A(L,K) .EQ. 0.0D0) GO TO 40 +* +* INTERCHANGE IF NECESSARY +* + IF (L .EQ. K) GO TO 10 + T = A(L,K) + A(L,K) = A(K,K) + A(K,K) = T + 10 CONTINUE +* +* COMPUTE MULTIPLIERS +* + T = -1.0D0/A(K,K) + CALL DSCAL(N-K,T,A(K+1,K),1) +* +* ROW ELIMINATION WITH COLUMN INDEXING +* + DO 30 J = KP1, N + T = A(L,J) + IF (L .EQ. K) GO TO 20 + A(L,J) = A(K,J) + A(K,J) = T + 20 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) + 30 CONTINUE + GO TO 50 + 40 CONTINUE + INFO = K + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IPVT(N) = N + IF (A(N,N) .EQ. 0.0D0) INFO = N + RETURN + END + SUBROUTINE DSIFA(A,LDA,N,KPVT,INFO) +****BEGIN PROLOGUE DSIFA +****DATE WRITTEN 780814 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D2B1A +****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX, +* SYMMETRIC +****AUTHOR BUNCH, J., (UCSD) +****PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with +* symmetric pivoting +****DESCRIPTION +* +* DSIFA factors a double precision symmetric matrix by elimination +* with symmetric pivoting. +* +* To solve A*X = B , follow DSIFA by DSISL. +* To compute INVERSE(A)*C , follow DSIFA by DSISL. +* To compute DETERMINANT(A) , follow DSIFA by DSIDI. +* To compute INERTIA(A) , follow DSIFA by DSIDI. +* To compute INVERSE(A) , follow DSIFA by DSIDI. +* +* On Entry +* +* A DOUBLE PRECISION(LDA,N) +* the symmetric matrix to be factored. +* Only the diagonal and upper triangle are used. +* +* LDA INTEGER +* the leading dimension of the array A . +* +* N INTEGER +* the order of the matrix A . +* +* On Return +* +* A a block diagonal matrix and the multipliers which +* were used to obtain it. +* The factorization can be written A = U*D*TRANS(U) +* where U is a product of permutation and unit +* upper triangular matrices, TRANS(U) is the +* transpose of U , and D is block diagonal +* with 1 by 1 and 2 by 2 blocks. +* +* KPVT INTEGER(N) +* an integer vector of pivot indices. +* +* INFO INTEGER +* = 0 normal value. +* = K if the K-th pivot block is singular. This is +* not an error condition for this subroutine, +* but it does indicate that DSISL or DSIDI may +* divide by zero if called. +* +* LINPACK. This version dated 08/14/78 . +* James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. +* +* Subroutines and Functions +* +* BLAS DAXPY,DSWAP,IDAMAX +* Fortran DABS,DMAX1,DSQRT +****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +* *LINPACK USERS GUIDE*, SIAM, 1979. +****ROUTINES CALLED DAXPY,DSWAP,IDAMAX +****END PROLOGUE DSIFA + INTEGER LDA,N,KPVT(1),INFO + DOUBLE PRECISION A(LDA,1) +* + DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T + DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX + INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,IDAMAX + LOGICAL SWAP +* +* INITIALIZE +* +* ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. +****FIRST EXECUTABLE STATEMENT DSIFA + ALPHA = (1.0D0 + DSQRT(17.0D0))/8.0D0 +* + INFO = 0 +* +* MAIN LOOP ON K, WHICH GOES FROM N TO 1. +* + K = N + 10 CONTINUE +* +* LEAVE THE LOOP IF K=0 OR K=1. +* +* ...EXIT + IF (K .EQ. 0) GO TO 200 + IF (K .GT. 1) GO TO 20 + KPVT(1) = 1 + IF (A(1,1) .EQ. 0.0D0) INFO = 1 +* ......EXIT + GO TO 200 + 20 CONTINUE +* +* THIS SECTION OF CODE DETERMINES THE KIND OF +* ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, +* KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND +* SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS +* REQUIRED. +* + KM1 = K - 1 + ABSAKK = DABS(A(K,K)) +* +* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN +* COLUMN K. +* + IMAX = IDAMAX(K-1,A(1,K),1) + COLMAX = DABS(A(IMAX,K)) + IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 + KSTEP = 1 + SWAP = .FALSE. + GO TO 90 + 30 CONTINUE +* +* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN +* ROW IMAX. +* + ROWMAX = 0.0D0 + IMAXP1 = IMAX + 1 + DO 40 J = IMAXP1, K + ROWMAX = DMAX1(ROWMAX,DABS(A(IMAX,J))) + 40 CONTINUE + IF (IMAX .EQ. 1) GO TO 50 + JMAX = IDAMAX(IMAX-1,A(1,IMAX),1) + ROWMAX = DMAX1(ROWMAX,DABS(A(JMAX,IMAX))) + 50 CONTINUE + IF (DABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 + KSTEP = 1 + SWAP = .TRUE. + GO TO 80 + 60 CONTINUE + IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 + KSTEP = 1 + SWAP = .FALSE. + GO TO 80 + 70 CONTINUE + KSTEP = 2 + SWAP = IMAX .NE. KM1 + 80 CONTINUE + 90 CONTINUE + IF (DMAX1(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100 +* +* COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. +* + KPVT(K) = K + INFO = K + GO TO 190 + 100 CONTINUE + IF (KSTEP .EQ. 2) GO TO 140 +* +* 1 X 1 PIVOT BLOCK. +* + IF (.NOT.SWAP) GO TO 120 +* +* PERFORM AN INTERCHANGE. +* + CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K),1) + DO 110 JJ = IMAX, K + J = K + IMAX - JJ + T = A(J,K) + A(J,K) = A(IMAX,J) + A(IMAX,J) = T + 110 CONTINUE + 120 CONTINUE +* +* PERFORM THE ELIMINATION. +* + DO 130 JJ = 1, KM1 + J = K - JJ + MULK = -A(J,K)/A(K,K) + T = MULK + CALL DAXPY(J,T,A(1,K),1,A(1,J),1) + A(J,K) = MULK + 130 CONTINUE +* +* SET THE PIVOT ARRAY. +* + KPVT(K) = K + IF (SWAP) KPVT(K) = IMAX + GO TO 190 + 140 CONTINUE +* +* 2 X 2 PIVOT BLOCK. +* + IF (.NOT.SWAP) GO TO 160 +* +* PERFORM AN INTERCHANGE. +* + CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) + DO 150 JJ = IMAX, KM1 + J = KM1 + IMAX - JJ + T = A(J,K-1) + A(J,K-1) = A(IMAX,J) + A(IMAX,J) = T + 150 CONTINUE + T = A(K-1,K) + A(K-1,K) = A(IMAX,K) + A(IMAX,K) = T + 160 CONTINUE +* +* PERFORM THE ELIMINATION. +* + KM2 = K - 2 + IF (KM2 .EQ. 0) GO TO 180 + AK = A(K,K)/A(K-1,K) + AKM1 = A(K-1,K-1)/A(K-1,K) + DENOM = 1.0D0 - AK*AKM1 + DO 170 JJ = 1, KM2 + J = KM1 - JJ + BK = A(J,K)/A(K-1,K) + BKM1 = A(J,K-1)/A(K-1,K) + MULK = (AKM1*BK - BKM1)/DENOM + MULKM1 = (AK*BKM1 - BK)/DENOM + T = MULK + CALL DAXPY(J,T,A(1,K),1,A(1,J),1) + T = MULKM1 + CALL DAXPY(J,T,A(1,K-1),1,A(1,J),1) + A(J,K) = MULK + A(J,K-1) = MULKM1 + 170 CONTINUE + 180 CONTINUE +* +* SET THE PIVOT ARRAY. +* + KPVT(K) = 1 - K + IF (SWAP) KPVT(K) = -IMAX + KPVT(K-1) = KPVT(K) + 190 CONTINUE + K = K - KSTEP + GO TO 10 + 200 CONTINUE + RETURN + END + DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) + implicit double precision (a-h, o-z) + INTEGER NEXT + DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE + DATA ZERO, ONE /0.0D0, 1.0D0/ +C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE +C INCREMENT INCX . +C C.L.LAWSON, 1978 JAN 08 + DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / + IF(N .GT. 0) GO TO 10 + DNRM2 = ZERO + GO TO 300 + 10 ASSIGN 30 TO NEXT + SUM = ZERO + NN = N * INCX +C BEGIN MAIN LOOP + I = 1 + 20 GO TO NEXT,(30, 50, 70, 110) + 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + ASSIGN 50 TO NEXT + XMAX = ZERO +C PHASE 1. SUM IS ZERO + 50 IF( DX(I) .EQ. ZERO) GO TO 200 + IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 +C PREPARE FOR PHASE 2. + ASSIGN 70 TO NEXT + GO TO 105 +C PREPARE FOR PHASE 4. + 100 I = J + ASSIGN 110 TO NEXT + SUM = (SUM / DX(I)) / DX(I) + 105 XMAX = DABS(DX(I)) + GO TO 115 +C PHASE 2. SUM IS SMALL. +C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. + 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 +C COMMON CODE FOR PHASES 2 AND 4. +C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. + 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 + SUM = ONE + SUM * (XMAX / DX(I))**2 + XMAX = DABS(DX(I)) + GO TO 200 + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 +C PREPARE FOR PHASE 3. + 75 SUM = (SUM * XMAX) * XMAX +C FOR REAL OR D.P. SET HITEST = CUTHI/N +C FOR COMPLEX SET HITEST = CUTHI/(2*N) + 85 HITEST = CUTHI/FLOAT( N ) +C PHASE 3. SUM IS MID-RANGE. NO SCALING. + DO 95 J =I,NN,INCX + IF(DABS(DX(J)) .GE. HITEST) GO TO 100 + 95 SUM = SUM + DX(J)**2 + DNRM2 = DSQRT( SUM ) + GO TO 300 + 200 CONTINUE + I = I + INCX + IF ( I .LE. NN ) GO TO 20 +C END OF MAIN LOOP. +C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. + DNRM2 = XMAX * DSQRT(SUM) + 300 CONTINUE + RETURN + END diff --git a/OpticsJan2020/MLI_light_optics/Src/magnet.f b/OpticsJan2020/MLI_light_optics/Src/magnet.f new file mode 100644 index 0000000..b93dce3 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/magnet.f @@ -0,0 +1,3985 @@ +c Minor changes made 6/04 by P. Walstrom to help it pass FTNCHEK +c P Walstrom's current sheet magnet routines for all gtypes +c + subroutine onaxgr(init,zfp,icoil,ndriv,dg) +c modified 8-25 to use modified gtype6=gtipe6. +ctm renamed back to gtype6 and gtype17 for MaryLie version + implicit double precision(a-h,o-z) +c Requires initialization calls for some values of icoil,according +c to value of itype(icoil). See below. +c Also, must call subroutines BINCOF,GAULEG and COEFFS once +c before the above initialization calls +c Applies to cylindrical current sheet coils or PMMs. Some types can h +c an infinitely long, cylindrical infinite-mu shield surrrounding the +c windings. +c +c Written by P. L. Walstrom, Grumman Space Systems,6-90, LANL. +c Modified by P. L. Walstrom 4/91 to include thick and thin Halbach PMM +c Modified 8-96 to include coils with an iron cylinder or shield +c around the windings. This is done by adding an equivalent cylindrcal +c current sheet of radius b, the iron radius, that duplicates the +c iron contribution for r1 +c +c Input variables: +c +c z=zcoordinate of field point with respect to coil center. +c a1=inner magnet radius +c a2=outer magnet radius +c xl=coil length +c glprod=integral of on axis gradient +c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. +c ndriv=highest derivative of on-axis gradient, plus 1. +c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize +c gradient. +c mu0=4pi*1.d-7 + parameter (maxdrv=20,maxcof=35) + common /cmcof/ cm(maxcof),cmp(maxcof),xmu0 + common /dnms/ denom(maxcof,2,2) + dimension dg(maxdrv),dgdz(maxdrv) +c cmp(m)=1*3*5*...(2m+1)/(m!*2**(m+1)) +c +c Output variables: +c dg=vector with ndriv components containing the on-axis gradient, and +c its ndriv-1 derivatives. +c +c Themagnetic moment per unit area has magnitude +c M_0, -xl/21gradient constant + 44 mm1=m-1 + c=glprod*cmp(m)*dfloat(m-1)/(xl*(a1**(-mm1)-a2**(-mm1))) +c Get0th derivative of g_m + 45 hfl=0.5d0*xl + x1=-hfl-z + x2=hfl-z +c call g0hlb to get the above double integral +c + call denoms(a1,a2,x1,x2,m,ndriv) +c + call g0hlb(a1,a2,x1,x2,m,g0) + dg(1)=-c*g0 + if(ndriv.lt.2) return + s1=-x1 + s2=-x2 + ndrvm1=ndriv-1 +c Get1st and higher derivatives of g_m + call dghlb(a1,a2,s1,s2,m,ndriv,dgdz) + do 1 n=1,ndrvm1 + np1=n+1 + 1 dg(np1)=c*dgdz(n) + return + end +c +c************************************************** +c + subroutine gtype3(init,k,icoil,xl,xlmin,z,a,glprod,m, + &ndriv,dg) + implicit double precision(a-h,o-z) + parameter(maxcof=35) + common /cmcof/ cm(maxcof),cmp(maxcof),xmu0 +c This subroutine calulates the on-axis gradient for both the fundament +c andfirst harmonic of a Lambertson m-pole coil. +c Called with init=0 to initialize, with init=1 for gradient. +c k=0means fundamental +c k=1means first harmonic +c m=multipole index of harmonic in question. +c i.e., if k=1, m=3*(m of fundamental) + parameter(maxcoils=100,maxdrv=20,npoint=25) + dimension aii(npoint,maxcoils),bii(npoint,maxcoils), + &cii(npoint,maxcoils),amid(maxcoils),zn(npoint,maxcoils) + dimension xi(npoint),yi(npoint),ai(npoint),bi(npoint) + dimension ccoil(maxcoils),alfi(5),dg(maxdrv) + dimension xngi(maxdrv),ci(npoint),points(npoint) + data small/1.d-4/ + save aii,bii,cii,amid,zn,ccoil,npm1 + save small + if(init.gt.0) go to 1 + dif=(xl-xlmin)/xl + if(dabs(dif).lt.small) go to 1001 + m2=2*m + hfl=xl*0.5d0 + hflmin=0.5d0*xlmin + npm1=npoint-1 + dell=hfl-hflmin + points(1)=0.d0 + points(npoint)=1.d0 + npm2=npoint-2 + dy=1.d0/dfloat(npm2) + do 55 n=2,npm2 + y=dy*dfloat(n-1) + 55 points(n)=y**2*(2.d0-y) + points(npm1)=0.5d0*points(npm2)+0.5d0 + xleff=0.5d0*(xl+xlmin) + ccoil(icoil)=glprod*cm(m)*a**m2/xleff + do 4 n=1,npoint + x=dell*points(n)-hfl + xi(n)=x + zn(n,icoil)=x + call flamb(xl,xlmin,x,fz,f3z) + if(k.eq.0) yi(n)=fz + if(k.eq.1) yi(n)=f3z + 4 continue +c nowfit parabolae to xi,yi + call parfit(npoint,xi,yi,ai,bi,ci) + do 5 n=1,npm1 + aii(n,icoil)=ai(n) + bii(n,icoil)=bi(n) + 5 cii(n,icoil)=ci(n) + amid(icoil)=yi(npoint) + return +c Calculate gradients in subsequent calls. + 1 continue + hflmin=0.5d0*xlmin + c=ccoil(icoil) + do 6 nd=1,ndriv + 6 dg(nd)=0.d0 + do 7 n=1,npm1 + np1=n+1 + x1=zn(n,icoil) + x2=zn(np1,icoil) + alfi(1)=aii(n,icoil) + alfi(2)=bii(n,icoil) + alfi(3)=cii(n,icoil) + call xngmin(m,3,ndriv,a,x1,x2,z,alfi,xngi) + do 8 nd=1,ndriv + 8 dg(nd)=dg(nd)+xngi(nd) +c right hand side of coil is mirror image of left + zm=-z + call xngmin(m,3,ndriv,a,x1,x2,zm,alfi,xngi) + sign=-1.d0 + do 9 nd=1,ndriv + sign=-sign + 9 dg(nd)=dg(nd)+xngi(nd)*sign + 7 continue +c getmiddle + alfi(1)=amid(icoil) + x1=-hflmin + x2=hflmin + call xngmin(m,1,ndriv,a,x1,x2,z,alfi,xngi) + do 10 nd=1,ndriv + 10 dg(nd)=dg(nd)+xngi(nd) + do 11 nd=1,ndriv + 11 dg(nd)=dg(nd)*c + return + 1001 write(6,300) + 300 format(1x,'End zone of Lambertson too short-stopped in GTYPE3') + stop + end +c +c************************************************** +c + subroutine gtype5(z,a,xl,glprod,m,ndriv,dg) + implicit double precision(a-h,o-z) + parameter(maxcof=35) + common /cmcof/ cm(maxcof),cmp(maxcof),xmu0 +c This subroutine calculates the on-axis generalized gradient for a +c cylindrical surface winding without iron, with a flat shape function. +c Input variables: +c +c z=zcoordinate of field point with respect to coil center. +c a=coil radius +c xl=coil length +c glprod=integral of on axis gradient +c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. +c ndriv=highest derivative of on-axis gradient, plus 1. +c Forthis shape function, NI=2*glprod*a**mcoil/(xl*mu0) +c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize +c gradient. +c mu0=4pi*1.d-7 + parameter (maxdrv=20) + dimension dg(maxdrv),ai(5),xngi(maxdrv) +c cm(m)=1*3*5*...(2m-1)/(m!*2**m) +c +c Output variables: +c dg=vector with ndriv components containing the on-axis gradient, and +c its ndriv-1 derivatives. +c +c Shape function has form +c f(x)=1, -xl/21001-stopped in GTYPE6') + stop + end +c +c************************************************** +c + subroutine gtype7(z,a,xl,wflat,glprod,m,ndriv,dg) + implicit double precision(a-h,o-z) + parameter(maxcof=35) + common /cmcof/ cm(maxcof),cmp(maxcof),xmu0 +c This subroutine calculates the on-axis generalized gradient for a +c cylindrical surface winding without iron, with a shape function +c that is flat in the center and rounded at the ends. The ends +c arerepresented by a parabola tangent to the flat top. +c Input variables: +c +c z=zcoordinate of field point with respect to coil center. +c a=coil radius +c xl=coil length +c wflat=length of the flat section of the shape function. +c glprod=integral of on axis gradient +c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. +c ndriv=highest derivative of on-axis gradient, plus 1. +c Forthis shape function, NI=2*glprod*a**mcoil/(xleff*mu0) +c where xleff=2/3*xl+1/3*wflat +c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize +c gradient. +c mu0=4pi*1.d-7 + parameter (maxdrv=20) + dimension dg(maxdrv),ai(5),xngi(maxdrv) +c cm(m)=1*3*5*...(2m-1)/(m!*2**m) +c +c Output variables: +c dg=vector with ndriv components containing the on-axis gradient, and +c its ndriv-1 derivatives. +c +c Shape function has form +c f(x)=1, -wflat/2xl in GTYPE11-stopped') + stop + end +c +c************************************************** +c + subroutine gtype12(z,a,xl,w1,w2,s1,s2,glprod,m,ndriv,dg) + implicit double precision(a-h,o-z) + parameter(maxcof=35) + common /cmcof/ cm(maxcof),cmp(maxcof),xmu0 +c This subroutine calculates the on-axis generalized gradient for a +c cylindrical surface winding without iron, with a shape function +c that is flat in the center and rounded at the ends. The ends +c arequadratic + cubic in distance from flattop. +c Input variables: +c +c z=zcoordinate of field point with respect to coil center. +c a=coil radius +c xl=coil length +c w1=width of the curved section from -xl/2 to the flattop. +c w2=width of the curved section from the flattop to xl/2. +c glprod=integral of on-axis gradient +c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. +c ndriv=highest derivative of on-axis gradient, plus 1. +c Forthis shape function, NI=glprod*a**mcoil/(xleff*mu0) +c where xleff=w1*(8+s1)/15+xl-w1-w2+w2*(8+s2)/15 +c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize +c gradient. +c mu0=4pi*1.d-7 + parameter (maxdrv=20) + parameter(twelveth=1.d0/1.2d1) + dimension dg(maxdrv),ai(5),xngi(maxdrv) +c cm(m)=1*3*5*...(2m-1)/(m!*2**m) +c +c Output variables: +c dg=vector with ndriv components containing the on-axis gradient, and +c its ndriv-1 derivatives. +c +c Shape function has form +c +c f(x)=1+A1(x+xl/2-w1)**2 + B1*(x+xl/2-w1)**3 -xl/2xl in GTYPE12-stopped') + stop + end +c +c************************************************** +c + subroutine gtype13(z,a,a2,xl,eslope,glprod,m,ndriv,dg) + implicit double precision(a-h,o-z) +c This subroutine calculates the on-axis generalized gradient for a +c cylindrical surface winding without iron,with an even quartic shape +c function. Thick analog of gtype1. +c Input variables: +c +c z=zcoordinate of field point with respect to coil center. +c a=inner coil radius +c a2 = outer coil radius. +c xl=coil length +c eslope=dimensionless end slope of the shape function +c glprod=integral of on axis gradient +c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. +c ndriv=highest derivative of on-axis gradient, minus 1. +c Forthis shape function, NI=2*glprod*a**mcoil/(Leff*mu0) +c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize +c gradient. +c +c Output variables: +c dg=vector with ndriv components containing the on-axis gradient, and +c its ndriv-1 derivatives. +c +c typical value for eslope (for dipoles) is 1. +c Shape function has form +c f(x)=1+x**2*(eslope/2-2)*4/xl**2+x**4*(1-eslope/2)*16/xL**4 +c =1+bb*x**2+dd*x**4, -xl/2 or = xl in GTYPE14-stopped') + stop + end +c +c************************************************** +c + subroutine gtype15(z,a,a2,xl,w1,w2,s1,s2,glprod,m,ndriv,dg) + implicit double precision(a-h,o-z) +c This subroutine calculates the on-axis generalized gradient for a +c cylindrical surface winding without iron, with a shape function +c that is flat in the center and rounded at the ends. The ends +c arequadratic + quartic in distance from flattop. +c Thick analog of gtype11. Integration in radial depth by Gaussian +c quadrature. +c Assumes that NI/layer scales as ap, the radius of the layer, +c while the shape function and Leff stay the same as the winding radius +c increases. This is not quite right. +c Since more turns are added to increase NI in the outer +c layers, there is less room at the ends for crossover parts of the tur +c Therefore, the shape function would be different, and Leff of the out +c layers would be lower. For a better approximation of real windings, +c multiple thick coils with increasing end zone widths w1 and w2 should +c be used. +c Input variables: +c +c z=zcoordinate of field point with respect to coil center. +c a=inner coil radius +c a2=outer coil radius +c xl=coil length +c w1=width of the curved section from -xl/2 to the flattop. +c w2=width of the curved section from the flattop to xl/2. +c s1=Left hand end slope=df/dz(-xl/2) +c s2=Right hand end slope=-df/dz(xl/2) +c glprod=integral of on-axis gradient +c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. +c ndriv=highest derivative of on-axis gradient, plus 1. +c Forthis shape function, NI=2*glprod*a**mcoil/(xleff*mu0) +c where xleff=w1*(8+s1)/15+xl-w1-w2+w2*(8+s2)/15 +c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize +c gradient. +c mu0=4pi*1.d-7 +c cm(m)=1*3*5*...(2m-1)/(m!*2**m) +c +c Output variables: +c dg=vector with ndriv components containing the on-axis gradient, and +c its ndriv-1 derivatives. +c +c Shape function has form +c +c f(x)=1+A1(x+xl/2-w1)**2 + B1*(x+xl/2-w1)**4 -xl/2xl in GTYPE15-stopped') + stop + end +c +c************************************************** +c + subroutine gtype16(z,a,a2,xl,w1,w2,s1,s2,glprod,m,ndriv,dg) + implicit double precision(a-h,o-z) +c This subroutine calculates the on-axis generalized gradient for a +c cylindrical surface winding without iron, with a shape function +c that is flat in the center and rounded at the ends. The ends +c arequadratic + cubic in distance from flattop. +c Thick analog of gtype12. Integration in radial depth by Gaussian +c quadrature. +c Assumes that NI/layer scales as ap, the radius of the layer, +c while the shape function and Leff stay the same as the winding radius +c increases. This is not quite right. +c Since more turns are added to increase NI in the outer +c layers, there is less room at the ends for crossover parts of the tur +c Therefore, the shape function would be different, and Leff of the out +c layers would be lower. For a better approximation of real windings, +c multiple thick coils with increasing end zone widths w1 and w2 should +c be used. +c Input variables: +c +c z=zcoordinate of field point with respect to coil center. +c a=inner coil radius +c a2=outer coil radius +c xl=coil length +c w1=width of the curved section from -xl/2 to the flattop. +c w2=width of the curved section from the flattop to xl/2. +c s1=Left hand end slope=df/dz(-xl/2) +c s2=Right hand end slope=-df/dz(xl/2) +c glprod=integral of on-axis gradient +c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. +c ndriv=highest derivative of on-axis gradient, plus 1. +c Forthis shape function, NI=2*glprod*a**mcoil/(xleff*mu0) +c where xleff=w1*(8+s1)/15+xl-w1-w2+w2*(8+s2)/15 +c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize +c gradient. +c mu0=4pi*1.d-7 +c cm(m)=1*3*5*...(2m-1)/(m!*2**m) +c +c Output variables: +c dg=vector with ndriv components containing the on-axis gradient, and +c its ndriv-1 derivatives. +c +c Shape function has form +c +c f(x)=1+A1(x+xl/2-w1)**2 + B1*(x+xl/2-w1)**3 -xl/2xl in GTYPE16-stopped') + stop + end +c +c************************************************** +c + subroutine gtype17(init,icoil,z,a,a2,b,xL,w1,w2,s1,s2,glprod,dg, + & m,ndriv) +c Like gtype17, except finer Gaussian quadrature. +c This subroutine calculates the on-axis generalized gradient for a +c cylindrical surface winding WITH iron, with a shape function +c that is flat in the center and rounded at the ends. The ends +c arequadratic + quartic in distance from flattop. +c +c Coaxial mu=infinity iron cylinder surrounding a thick GTYPE15 coil. +c Requires an initialization call to compute and store the equivalent i +c shape function. This is the shape function for a fictitious +c winding of radius b(=the iron radius) that mimics the incremental eff +c of the iron for ra2>a. If b< +c the iron contribution is omitted and the calculation +c applies to a "bare" thick coil (just like GTYPE15). +c +c xL=coil length +c w1=width of the curved section from -xL/2 to the flattop. +c w2=width of the curved section from the flattop to xL/2. +c s1=Left hand end slope=df/dz(-xL/2) +c s2=Right hand end slope=-df/dz(xL/2) +c glprod=integral of on-axis gradient +c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. +c ndriv=highest derivative of on-axis gradient, plus 1. +c init=initialization code: 0 meams initialize, 1 means compute gradien +c +c +c mu0=4pi*1.d-7 +c cm(m)=1*3*5*...(2m-1)/(m!*2**m) +c +c Output variables: +c dg=vector with ndriv components containing the on-axis gradient, and +c its ndriv-1 derivatives. +c +c Shape function has form +c +c f(x)=1+A1(x+xL/2-w1)**2 + B1*(x+xL/2-w1)**4 -xL/2a2) + if(b.le.a2) go to 9 +c Find iron contribution to gradient + do 10 n=1,ndriv + 10 giron(n)=0.d0 +c Step through intervals of piecewise-continuous cubic interpolant of +c Fstar. +c There are ni-1 intervals, ni nodes. + ni=nin(icoil) + do 11 i=1,ni-1 + ai(1)=a1in(i,icoil) + ai(2)=a2in(i,icoil) + ai(3)=a3in(i,icoil) + ai(4)=a4in(i,icoil) + ndeg=4 + if((i.eq.1).or.(i.eq.(ni-1))) ndeg=2 + x1=xin(i,icoil) + x2=xin(i+1,icoil) + call xngmin(m,ndeg,ndriv,b,x1,x2,z,ai,xngi) + do 12 n=1,ndriv + 12 giron(n)=giron(n)+xngi(n) + 11 continue + 9 continue +c calculate field constant C0=m*mu0*J0/2 +c This constant is chosen to make the integral gradient equal the +c specified value, glprod. +c Use"new" generalized gradient definition, including factor of m. +c i.e, g_m(z)= m * lim as r goes to 0 of V_m(r,z)/r**m. +c J0 is the winding current density at phi=0, z=0, and is assumed to +c be constant with radial depth. + denom=xLeff*aintgrl(a,a2,m) + Lstar=Lstarn(icoil) + if(b.gt.a2) denom=denom+adif*a*Lstar/b**m + c0=glprod/denom +c Nowadd up bare-coil and iron contributions to gradient with +c appropriate weights. + fact0=a**(m+1)*adif + facti=b**m*a*adif + c0cm=c0*cm(m) + do 13 n=1,ndriv + dg(n)=fact0*gbare(n) + if(b.gt.a2) dg(n)=dg(n)+facti*giron(n) + 13 dg(n)=c0cm*dg(n) + if(iniflg.eq.0) then + iniflg = iniflg+1 +c write(6,297) fact0,facti,c0cm +c write(6,166) glprod,xL,a,a2,b +c rite(6,167) w1,w2,s1,s2 + 297 format(' 1st grad, f0,fi,c)cm:',3f12.5) + endif + return + 1001 write(6,300) + 300 format(1x,'w1+w2>xL in GTYPE15-stopped') + stop + end +c +c************************************************** +c +c +c rest of routines called by gtypes +c + subroutine denoms(a1,a2,s1,s2,m,ndriv) + implicit double precision(a-h,o-z) +c Calculates the quantities +c +c 1/(rho**2+s**2)**(n+1/2)) +c +c for n=0,1,2,3,....m+ndriv-1 +c rho= a1,a2 +c s= s1,s2 +c +c Results stored in common block DNMS +c + parameter(maxcof=35) + common /dnms/ denom(maxcof,2,2) + dimension u(2,2) +c +c First index in denoms is n+1, 2nd is 1 for a1, 2 for a2. 3rd index is +c 1 for s1, 2 for s2 +c +c ndriv is always equal to or greater than 1 + a12=a1**2 + a22=a2**2 + s12=s1**2 + s22=s2**2 + u(1,1)=1.d0/(a12+s12) + u(1,2)=1.d0/(a12+s22) + u(2,1)=1.d0/(a22+s12) + u(2,2)=1.d0/(a22+s22) + denom(1,1,1)=dsqrt(u(1,1)) + denom(1,1,2)=dsqrt(u(1,2)) + denom(1,2,1)=dsqrt(u(2,1)) + denom(1,2,2)=dsqrt(u(2,2)) + maxn=m+ndriv + if(maxn.lt.2) return + do 1 n=2,maxn + nm1=n-1 + do 1 k=1,2 + do 1 l=1,2 + 1 denom(n,k,l)=denom(nm1,k,l)*u(k,l) +c do 5 k=1,maxn +c 5write(6,500) k,denom(k,1,2),denom(k,1,2),denom(k,2,1), +c &denom(k,2,2) +c 500format(1x,'k,denom:',i2,4(1x,1pd14.7)) + return + end +c +c************************************************** +c + subroutine dghlb(a1,a2,s1,s2,m,ndriv,dg) + implicit double precision(a-h,o-z) +c +c Evaluates repeated derivatives with respect to z of the double +c integral +c +c s1to s2 ds a1 to a2 drho of +c +c rho**(m+2)/(rho**2+s**2)**(m+3/2) +c +c s1=z+L/2 +c s2=z-L/2 +c +c Thefirst element of the output vector dg is the first derivative, et +c dg has nd computed elements. +c +c Note difference in definition from that of s1 and s2 in G0HLB- they +c differ by a factor of -1. +c +c Calls subroutine RHOINT +c + parameter(maxdrv=20) + parameter(small=1.d-6) + dimension dg(maxdrv),ck(maxdrv),rhoin1(maxdrv), + &rhoin2(maxdrv),ckold(maxdrv),pwr(maxdrv) + dimension s1oddp(maxdrv),s2oddp(maxdrv),s1evnp(maxdrv), + &s2evnp(maxdrv),xk(maxdrv),xkold(maxdrv) + nd=ndriv-1 +c write(20,204) m,nd +c 204format(1x,'m=',i3,2x,'nd=',i3) + call rhoint(a1,a2,s1,1,m,nd,rhoin1) +c write(6,200) (rhoin1(k),k=1,nd) + 200 format(5(1x,1pd12.5)) + call rhoint(a1,a2,s2,2,m,nd,rhoin2) +c First derivative + dg(1)=rhoin2(1)-rhoin1(1) + if(nd.lt.2) return +c Second derivative + nmin=m+1 + xkmin=dfloat(2*nmin+1) + dg(2)=xkmin*(s1*rhoin1(2)-s2*rhoin2(2)) + if(nd.lt.3) return +c Third derivative + s12=s1**2 + s22=s2**2 + dg(3)=xkmin*(rhoin1(2)-rhoin2(2)+(xkmin+2.d0)*(s22*rhoin2(3)- + &s12*rhoin1(3))) + if(nd.lt.4) return +c Fourth and higher derivatives. +c Find out if nd is odd or even + x=0.5d0*dfloat(nd)+small + id=x + ileft=0 + if((x-dfloat(id)).gt.0.1d0) ileft=1 +c ileft=0 if nd is even, =1 if nd is odd +c write(20,205) id,ileft +c 205format(1x,'id=',i3,1x,'ileft=',i3) + ckold(1)=-xkmin + xkold(1)=xkmin + xkold(2)=xkmin+2.d0 + ckold(2)=-ckold(1)*xkold(2) + pwr(1)=0.d0 + pwr(2)=2.d0 + s1oddp(1)=s1 + s2oddp(1)=s2 + s1evnp(1)=1.d0 + s2evnp(1)=1.d0 + s1evnp(2)=s12 + s2evnp(2)=s22 + do 1 i=2,id +c write(20,200) i +c write(20,240) + 240 format(1x,'Even derivative Coefficients') + im=i-1 + ip=i+1 +c first, even derivative in pair + s1oddp(i)=s1oddp(im)*s12 + s2oddp(i)=s2oddp(im)*s22 + ng=2*i + do 9 j=1,i + 9 xk(j)=xkold(j)+2.d0 + do 2 j=1,im + jp=j+1 + 2 ck(j)=-ckold(j)*xk(j)+ckold(jp)*pwr(jp) + do 3 j=1,i + 3 pwr(j)=pwr(j)+1.d0 + xk(i)=xk(im)+2.d0 + ck(i)=-ckold(i)*xk(i) + dg(ng)=0.d0 + do 4 j=1,i + jcol=i+j + 4 dg(ng)=dg(ng)+(s2oddp(j)*rhoin2(jcol)- + &s1oddp(j)*rhoin1(jcol))*ck(j) +c Done with even derivative for this value of i +c replace elements in ckold vector with elements in ck vector + do 11 j=1,i +c write(20,201) j,xk(j),pwr(j),ck(j),s1oddp(j),s2oddp(j) + 11 ckold(j)=ck(j) +c skipodd derivative calculation if not wanted- i.e. i=id & ileft=0 + if(i.lt.id) go to 5 + if(ileft.eq.0) go to 1 + 5 continue + s1evnp(ip)=s1evnp(i)*s12 + s2evnp(ip)=s2evnp(i)*s22 + ng=ng+1 + ck(1)=ckold(1) + do 6 j=2,i + jm=j-1 + 6 ck(j)=-ckold(jm)*xk(j)+pwr(j)*ckold(j) + xk(ip)=xk(i)+2.d0 + ck(ip)=-ckold(i)*xk(ip) + do 7 j=1,i + 7 pwr(j)=pwr(j)-1.d0 + pwr(ip)=pwr(i)+2.d0 + dg(ng)=0.d0 + do 8 j=1,ip + jcol=i+j + 8 dg(ng)=dg(ng)+(s2evnp(j)*rhoin2(jcol)- + &s1evnp(j)*rhoin1(jcol))*ck(j) + if(i.eq.id) go to 1 +c write(20,250) +c 250format(1x,'Odd Derivative Coefficients') +c if not last value of i, load ck into ckold + do 12 j=1,ip +c write(20,201) j,xk(j),pwr(j),ck(j),s1evnp(j),s2evnp(j) +c 201format(1x,i3,5(1x,1pd14.7)) + xkold(j)=xk(j) + 12 ckold(j)=ck(j) + 1 continue + return + end +c +c************************************************** +c + subroutine dpmrv(m,ndriv,a,s,dipm) + implicit double precision(a-h,o-z) +c Used in dipole sheet model of large bore PMMs. +c This subroutine calculates repeated s derivatives of h_m= +c +c 1/(a**2+s**2)**(m+3/2)) +c +c dipm(1) = h_m, dipm(2)=d h_m /ds, dipm(3)= d**2 h_m /ds**2, etc. +c +c Uses formula from Gradstein and Ryzhik, Table of Integrals, +c Series, and Products, 1980, p.20 +c +c a=coil radius +c m=multipole index(m=1 for dipole,2 for quadrupole, 3 for sextupole,etc +c s=x-z, where x=coil z coordinate, z= field point z coordinate. +c ndriv= no. of entries in dipm (no. of times h_m is differentiated + 1 +c +c maxdrv is the maximum value of ndriv required. + parameter (maxdrv=20,maxhlf=11) +c maxhlf must be at least 1/2 of maxdrv if maxdrv is even, +c 1/2(maxdrv+1) if maxdrv is odd. +c + dimension dipm(maxdrv) + dimension cnk(maxhlf,maxdrv), + &rnk2(maxhlf,maxdrv),snk(maxhlf,maxdrv),rkfac(maxhlf) + aa=1.d0/a**2 + xm=dfloat(m) + u=1.d0+aa*s**2 + ru=1.d0/u + rru=dsqrt(ru) + m2mm3=-2*m-3 + denom=ru**m*rru*a**m2mm3 + c2=denom*ru + dipm(1)=c2 + if(ndriv.lt.2) return + tas=2.d0*aa*s + p2=-xm-1.5d0 + c2=c2*p2*ru + dipm(2)=c2*tas + if(ndriv.lt.3) return + p2m=p2 + au=aa*u + aunh=1.d0 + snk(1,1)=tas +c n=order of derivative +c find integers nhalf= nearest integer below or = (ndriv-1)/2, +c and ileft=1+(ndriv-1)-2*nhalf + xhalf=0.5d0*dfloat(ndriv-1) + nhalf=xhalf + dif=xhalf-dfloat(nhalf) + ileft=1 + if(dif.gt.0.1d0) ileft=2 + n=1 + rkf=1.d0 + do 1 nh=1,nhalf + rkf=rkf/dfloat(nh) + rkfac(nh)=rkf + nhp1=nh+1 + ilef=2 + if(nh.lt.nhalf) go to 6 + if(ileft.eq.1) ilef=1 + 6 aunh=aunh*au + nhp1=nh+1 + do 1 il=1,ilef + nm1=n + nm2=n-1 + n=n+1 + p2m=p2m-1.d0 + c2=c2*p2m*ru + snk(nhp1,n)=aunh + do 4 k=1,nh + 4 snk(k,n)=snk(k,nm1)*tas + if(il.eq.2) snk(nhp1,n)=snk(nhp1,n)*tas + cnk(2,n)=dfloat(n*(n-1)) + rnk2(2,n)=1.d0/p2m + if(nhp1.lt.3) go to 8 + do 7 k=3,nhp1 + km1=k-1 + cnk(k,n)=cnk(km1,nm2)*cnk(2,n) + 7 rnk2(k,n)=rnk2(km1,nm1)*rnk2(2,n) + 8 sum2=snk(1,n) + do 5 k=2,nhp1 + km1=k-1 + 5 sum2=sum2+snk(k,n)*cnk(k,n)*rnk2(k,n)*rkfac(km1) + np1=n+1 + 1 dipm(np1)=sum2*c2 + return + end +c +c************************************************** +c + subroutine flamb(xl,xlmin,z,fz,f3z) + implicit double precision(a-h,o-z) +c This routine calculates the mth and 3mth(i.e., the two lowest) Fourie +c coeffients of the stream function for an ideal Lambertson coil. +c This type of Lambertson coil has equal z spacing of end crossover +c turns. The stream function is dimensionless-i.e., the results +c of this routine, fz, must be multiplied somewhere by NI, +c where NI is the number of amp-turns/pole. +c +c Input variables: +c xl=coil length +c xlmin=length of shortest turn (at center of pole) +c z=axial coordinate measured from coil center +c +c Output +c fz=mth Fourier coefficient of the dimensionless stream function +c fora Lambertson m-pole coil. (All lower coefficients are zero). +c f3z=3m th Fourier coefficient " " " " +c +c Note that the shape functions f(z) and f3z(z) have no m dependence. + data two/2.d0/,three/3.d0/,half/0.5d0/,zero/0.d0/ + data five/5.d0/,four/4.d0/ + data one/1.d0/,small/1.d-12/ + hfl=half*xl + zet=dabs(z) + fz=zero + f3z=zero + if(zet.gt.hfl) return + dif=dabs(xl-xlmin) + if(dif.gt.small) go to 2 + fz=one + return + 2 hflmin=half*xlmin + hfpi=dasin(one) + xl2=xl**2 + qtrpi=half*hfpi + xlmin2=xlmin**2 + third=one/three + b=(xl2-xlmin2)/xl2 + b2=b**2 + c=xl/((xl-xlmin)*qtrpi) + xkc2=(one-b)/(one+b) + xkc=dsqrt(xkc2) +c find elliptic integrals E(pi/4,r),F(pi/4,r), where r=sqrt(2b/(1+b)). + ee=el2(one,xkc,one,xkc2) + ff=el2(one,xkc,one,one) + rootab=dsqrt(one+b) + sixth=half*third + g2f=(one-b)*sixth/b + g2e=(three*b-one)*sixth/b + g2cos=-sixth/rootab + denom=one/(30.d0*b2) + g4f=-(five*b2-four*b-one)*denom + g4e=(12.d0*b2-5.d0*b-one)*denom + g4cos=-one/(60.d0*b*rootab) + g6g2=-three*(one+b)/(14.d0*b) + g6g4=(two+8.d0*b)/(7.d0*b) + g6cos=one/(56.d0*b*rootab) + dif=(zet-hflmin)/hflmin + if(dif.gt.small) go to 1 +c z falls in center part of coil, ie. between crossover regions at ends + dele=cel(xkc,one,one,xkc2)-ee + delf=cel(xkc,one,one,one)-ff + cm=third*(one+two*(rootab*dele-(one-b2)*delf/rootab)/b) + fz=cm*c + g0=dele + g2=g2f*delf+g2e*dele-g2cos + g4=g4f*delf+g4e*dele-g4cos*(10.d0*b-one) + g6=g6g2*g2+g6g4*g4-g6cos + c3m=third-two*rootab*(g0-18.d0*g2+48.d0*g4-32.d0*g6) + f3z=c*c3m + return + 1 continue +c z falls in one of 2 crossover regions + zr=zet/hfl + zr2=zr**2 + sinfz=(one-zr2)/b + cosfz=dsqrt(one-sinfz**2) + x=dsqrt((one+sinfz)/(one-sinfz)) + dele=el2(x,xkc,one,xkc2)-ee + delf=el2(x,xkc,one,one)-ff + fz=third*(two*(rootab*dele-(one-b**2)*delf/rootab)/b+ + &one-cosfz*zr) + fz=fz*c + cos3fz=cosfz*(one-four*sinfz**2) + g0=dele + g2=g2cos*(cosfz*zr-one)+g2e*dele+g2f*delf + g4=g4cos*((10.d0*b-one+three*b*sinfz)*cosfz*zr- + &10.d0*b+one)+g4e*dele+g4f*delf + g6=(cosfz*(one+sinfz)*zr*zr2-one)*g6cos+g6g2*g2+g6g4*g4 + f3z=third*(one-zr*cos3fz)-two*rootab*(g0-18.d0*g2+ + &48.d0*g4-32.d0*g6) + f3z=f3z*c + return + end +c +c************************************************** +c +c +c +c this is a function subprogram copied from numerical recipes +c by w.h.press ,etl pp. 186-187. +c evaluates the general incomplete elliptic integral of +c the 2nd kind as the following function of four variables: +c +c el2(x,kc,a,b)= +c int[ (a+b*x**2)dx/{1+x**2)*sqrt((1+x**2)*(1+kc**2*x**2))} ] +c from x=0 to x=x +c +c the elliptic integral of the 1st kind is called by el2(x,kc,1,1) +c the elliptic integral of the 2nd kind is called by el2(x,kc,1,kc** +c + subroutine g0hlb(a1,a2,s1,s2,m,g0) + implicit double precision(a-h,o-z) + parameter(small=1.d-6) + parameter(maxcof=35) + dimension zinti(maxcof,2) +c The array ZINTI contains the integrals from s1 to s2 of +c +c ds/(a**2+s**2)**n+1/2, n=nmin,nmin+1,nmin+2,...m +c +c zinti(i,1) is evaluated at a1, zinti(i,2) at a2. +c The index i runs from 1 to m-nmin+1, with n=nmin for i=1, nmin+1 for +c i=2, etc. +c +c +c +c Used in calculating the gradient on axis of thick Halbach PMMs. +c Evaluates the double integral, s=s1 to s2, rho=a1 to a2 of +c +c (drho*ds*rho**(m+2))/(rho**2+s**2)**(m+3/2) +c +c This is the gradient on axis , except for a constant factor +c +c a1=inner radius +c a2=outer radius +c s1=-L/2-z +c s2=L/2-z +c where L is the length of the PMM, assumed to be rectangular in cro +c section in the r-z plane, and z is the axial coordinate where the +c gradient is evaluated. +c m=multipole index: m=1 for dipole, 2 for quad, etc. +c g0=value of double integral +c Uses repeated integration by parts to do the rho integral +c Each term in resultant series is integrated in z, except if m is eve +c Then the series ends in a double integral that is evaluated by the +c special-case subroutine INTEND. +c Check to see if m is even or odd. + if(m.lt.2) go to 8 + mm1=m-1 + ra1=a1**(-mm1) + ra2=a2**(-mm1) + go to 9 + 8 ra1=1.d0 + ra2=1.d0 + 9 x=dfloat(m+3)*0.5d0+small + iterms=x + dif=x-dfloat(iterms) + ileft=0 + if(dif.gt.0.1d0) ileft=1 +c ileft=0 if m is odd, =1 if m is even + if(ileft.gt.0) go to 11 +c m is odd + itop=0 + ibot=m-2 +c Exponent on denominator in innermost term=n+1/2 + nmin=(m-1)/2 + g0=0.d0 + go to 1 + 11 continue +c m is even- descending series ends in an integral evaluated by INTE + itop=1 + ibot=m-1 + nmin=m/2 + call intend(a1,a2,s1,s2,m,xiend) + g0=-xiend + 1 itrm1=iterms-1 + call zint(a1,a2,s1,s2,nmin,m,zinti) + do 2 i=1,itrm1 + if(m.lt.2) go to 10 + g0=g0+zinti(i,2)*ra2-zinti(i,1)*ra1 + go to 14 + 10 g0=g0+zinti(i,2)-zinti(i,1) + 14 itop=itop+2 + ibot=ibot+2 + g0=g0*dfloat(itop)/dfloat(ibot) + 2 continue + ibot=ibot+2 + if(m.lt.2) go to 12 + g0=g0+zinti(iterms,2)*ra2-zinti(iterms,1)*ra1 + go to 13 + 12 g0=g0+zinti(iterms,2)-zinti(iterms,1) + 13 g0=-g0/dfloat(ibot) + return + end +c +c************************************************** +c + subroutine parfit(npoint,xi,yi,ai,bi,ci) + implicit double precision(a-h,o-z) + dimension xi(npoint),yi(npoint),ai(npoint),bi(npoint), + &ci(npoint) +c fit parabola to 1st 3 points. + x1=xi(1) + y1=yi(1) + x2=xi(2) + y2=yi(2) + x3=xi(3) + y3=yi(3) + h1=x2-x1 + h2=x3-x2 + d1=y1/(h1*(h1+h2)) + d2=y2/(h1*h2) + d3=y3/(h2*(h1+h2)) +c parabola of form a1+b1*x+c1*x**2 + a1=x1*x2*d3+x2*x3*d1-x1*x3*d2 + b1=(x1+x3)*d2-(x2+x3)*d1-(x1+x2)*d3 + c1=d1-d2+d3 + ai(1)=a1 + bi(1)=b1 + ci(1)=c1 + npm2=npoint-2 +c except for ends, the parabola coefficients for a particular interval +c theaverage of those calculated with the point on the right, with tho +c calculated with the point on the left. + do 1 i=2,npm2 + ip2=i+2 + x1=x2 + x2=x3 + y1=y2 + y2=y3 + h1=h2 + x3=xi(ip2) + y3=yi(ip2) + h2=x3-x2 + d1=y1/(h1*(h1+h2)) + d2=y2/(h1*h2) + d3=y3/(h2*(h1+h2)) + a2=x1*x2*d3+x2*x3*d1-x1*x3*d2 + b2=(x1+x3)*d2-(x2+x3)*d1-(x1+x2)*d3 + c2=d1-d2+d3 + ai(i)=0.5d0*(a1+a2) + bi(i)=0.5d0*(b1+b2) + ci(i)=0.5d0*(c1+c2) + a1=a2 + b1=b2 + 1 c1=c2 + npm1=npoint-1 +c rightmost interval + ai(npm1)=a2 + bi(npm1)=b2 + ci(npm1)=c2 + return + end +c +c************************************************** +c + subroutine parfit1(npoint,xi,yi,ai,bi,ci) + implicit double precision(a-h,o-z) + dimension xi(npoint),yi(npoint),ai(npoint),bi(npoint), + &ci(npoint) +c This subroutine finds coefficients for a piecewise-quadratic fit to a +c of xi,yi points. There are npoint (xi,yi) points and npoint-1 interva +c also npoint-1 ai values, npoint-1 bi values, npoint-1 ci values. +c fitto ith interval is ai(i)+bi(i)*t+ci(i)*t**2, where t=x-xi(i). +c Like PARFIT, but coefficients apply to x-xi(i), not x. Roundoff erro +c should be lower. +c fit parabola to 1st 3 points. + y1=yi(1) + y2=yi(2) + y3=yi(3) + h1=xi(2)-xi(1) + h2=xi(3)-xi(2) + denom=h1*h2*(h1+h2) + aa=y1 + denom=h1*h2*(h1+h2) + bb=((y2-y1)*(h1+h2)**2-(y3-y1)*h1**2)/denom + cc=(h1*(y3-y2)-h2*(y2-y1))/denom +c parabola of form a+b*t+c*t**2 +c where t=x-x1 + ai(1)=aa + bi(1)=bb + ci(1)=cc +c except for ends, the parabola coefficients for a particular interval +c theaverage of those calculated with the point on the right, with tho +c calculated with the point on the left. + if(npoint.lt.4) go to 2 + do 1 i=2,npoint-2 + h3=xi(i+2)-xi(i+1) + y4=yi(i+2) +c LH expression + aa=y2 + denom=h2*h3*(h2+h3) + bb=((y3-y2)*(h2+h3)**2-(y4-y2)*h2**2)/denom + cc=(h2*(y4-y3)-h3*(y3-y2))/denom +c RH expression + denom=h1*h2*(h1+h2) + a=y2 + b=(h2**2*(y2-y1)+h1**2*(y3-y2))/denom + c=(h1*(y3-y2)-h2*(y2-y1))/denom +c Average two expressions + ai(i)=0.5d0*(a+aa) + bi(i)=0.5d0*(b+bb) + ci(i)=0.5d0*(c+cc) +c Shift fit window, unless at RH end of array. + if(i.ne.(npoint-2)) then + h1=h2 + y1=y2 + h2=h3 + y2=y3 + y3=y4 + endif + 1 continue + 2 npm1=npoint-1 +c rightmost interval + denom=h2*h3*(h2+h3) + a=y3 + b=(h3**2*(y3-y2)+h2**2*(y4-y3))/denom + c=(h2*(y4-y3)-h3*(y3-y2))/denom + ai(npm1)=a + bi(npm1)=b + ci(npm1)=c + ai(npoint)=0.d0 + bi(npoint)=0.d0 + ci(npoint)=0.d0 + return + end +c +c************************************************** +c + subroutine pmmint(x1,x2,a,m,gm0int) + implicit double precision(a-h,o-z) +c this subroutine calculates the integral from x1 to x2 of +c +c (s**2+a**2)**(-m-3/2) ds +c +c Uses formula for Gradstein and Ryzhik, p. 86 + parameter(maxcof=35) + common /bicof/ bcoeff(maxcof,maxcof) +c bcoeff contains the binomial expansion coefficients up to order +c maxcof-1 + mp1=m+1 + gm0int=0.d0 + a2=a**2 + x=x2 + do 1 i=1,2 + xsq=x**2 + root2=xsq+a2 + root=dsqrt(root2) + term=x/root + temp=bcoeff(1,m)*term + do 2 k=2,mp1 + term=-term*xsq/root2 + x2km1=dfloat(2*k-1) + 2 temp=temp+bcoeff(k,m)*term/x2km1 + gm0int=gm0int+temp + 1 x=-x1 + gm0int=gm0int*a2**(-mp1) + return + end +c +c************************************************** +c + subroutine rdrivs(m,ndriv,a,s,di) + implicit double precision(a-h,o-z) +c This subroutine calculates repeated derivatives of g_m= +c +c 1/(a**2+s**2)**(m+1/2)) +c +c di(1) = g_m, di(2)=d g_m /ds, di(3)= d**2 g_m /ds**2, etc. +c +c Uses formula from Gradstein and Ryzhik, Table of Integrals, +c Series, and Products, 1980, p.20 +c +c a=coil radius +c m=multipole index (m=1 for dipole,2 for quadrupole, 3 for sextupole,e +c s=x-z, where x=coil z coordinate, z= field point z coordinate. +c ndriv= no. of entries in di (no. of times g_m is differentiated + 1) +c +c maxdrv is the maximum value of ndriv required. + parameter (maxdrv=20,maxhlf=11) +c maxhlf must be at least 1/2 of maxdrv if maxdrv is even, +c 1/2(maxdrv+1) if maxdrv is odd. +c + dimension di(maxdrv) + dimension cnk(maxhlf,maxdrv),rnk1(maxhlf,maxdrv), + &snk(maxhlf,maxdrv),rkfac(maxhlf) + aa=1.d0/a**2 + xm=dfloat(m) + u=1.d0+aa*s**2 + ru=1.d0/u + rru=dsqrt(ru) + m2mm1=-2*m-1 + denom=ru**m*rru*a**m2mm1 + c1=xm*denom + di(1)=c1 + if(ndriv.lt.2) return + tas=2.d0*aa*s + p1=-xm-0.5d0 + c1=c1*p1*ru + di(2)=c1*tas + if(ndriv.lt.3) return + p1m=p1 + au=aa*u + aunh=1.d0 + snk(1,1)=tas +c n=order of derivative +c find integers nhalf= nearest integer below or = (ndriv-1)/2, +c and ileft=1+(ndriv-1)-2*nhalf + xhalf=0.5d0*dfloat(ndriv-1) + nhalf=xhalf + dif=xhalf-dfloat(nhalf) + ileft=1 + if(dif.gt.0.1d0) ileft=2 + n=1 + rkf=1.d0 + do 1 nh=1,nhalf + rkf=rkf/dfloat(nh) + rkfac(nh)=rkf + nhp1=nh+1 + ilef=2 + if(nh.lt.nhalf) go to 6 + if(ileft.eq.1) ilef=1 + 6 aunh=aunh*au + nhp1=nh+1 + do 1 il=1,ilef + nm1=n + nm2=n-1 + n=n+1 + p1m=p1m-1.d0 + c1=c1*p1m*ru + snk(nhp1,n)=aunh + do 4 k=1,nh + 4 snk(k,n)=snk(k,nm1)*tas + if(il.eq.2) snk(nhp1,n)=snk(nhp1,n)*tas + cnk(2,n)=dfloat(n*(n-1)) + rnk1(2,n)=1.d0/p1m + if(nhp1.lt.3) go to 8 + do 7 k=3,nhp1 + km1=k-1 + cnk(k,n)=cnk(km1,nm2)*cnk(2,n) + 7 rnk1(k,n)=rnk1(km1,nm1)*rnk1(2,n) + 8 sum1=snk(1,n) + do 5 k=2,nhp1 + km1=k-1 + 5 sum1=sum1+snk(k,n)*cnk(k,n)*rnk1(k,n)*rkfac(km1) + np1=n+1 + 1 di(np1)=sum1*c1 + return + end +c +c************************************************** +c + subroutine thickf(a,a2,ratio,m) + implicit double precision(a-h,o-z) +c calculates ratio of thin to thick coils for correction of field +c constant to get desired glprod in gtype 13,14,15,16. +c factor of 1/2 comes from the fact that sum of wgn is 2. +c RATIO is 1/2 * (a2-a)/a**(m-1) / integral from a to a2 of dx*x**(1-m +c this comes from the fact that if NI varies as x, and gL varies as +c x**(-m), the product varies as x**(1-m) (x=dummy coil radius variabl +c of integration). For thin coils, RATIO approcahes 1/2. For m=1, it +c EXACTLY 1/2, for any thickness. + parameter(c1=0.5d0,c2=0.5d0,c3=1.d0/6.d0,c4=1.d0/6.d0, + &c5=1.9d1/9.0d1,c6=0.3d0,c7=8.63d2/1.89d3,c8=2.75d2/3.78d2) + parameter(third=1.d0/3.d0) + if(m.gt.1) go to 22 + ratio=0.5d0 + go to 50 + 22 x=0.5d0*(a2-a)/a + if(x.lt.0.002d0) go to 44 + if(m.gt.2) go to 23 +c m=2, not thin + ratio=0.5d0*(a2-a)/(a*dlog(a2/a)) + go to 50 + 23 if(m.gt.3) go to 24 +c m=3, not thin + ratio=0.5d0*a2/a + go to 50 +c m>3, not thin + 24 ratio=x*dfloat(m-2)/ + &(1.d0-(a/a2)**(m-2)) + go to 50 + 44 continue +c Thin-small value of x + x=0.5d0*(a2-a)/a + if(m.gt.2) go to 25 +c thin-m=2 + ratio=c1+x*(c2-x*(c3-x*(c4-x*(c5-x*c6)))) + go to 50 + 25 if(m.gt.3) go to 26 +c Thin- m=3 + ratio=0.5d0*a2/a + go to 50 +c Thin- m>3 + 26 ratio=0.5d0*(1.d0+dfloat(m-1)*x*(1.d0+third*x* + &dfloat(m-3)*(1.d0-x))) + 50 continue + return + end +c +c************************************************** +c + subroutine xngmin(m,nterm,ndriv,a,x1,x2,z,ai,xngi) + implicit double precision(a-h,o-z) +c Evaluates analytical expressions for +c +c d**n/ dz**n of Integral from x1 to x2 of f(x)g_m(x,z) dx, where +c +c f(x)=ai(1)+ai(2)*x+..ai(nterm)*x**(nterm-1) +c +c g_m=a**(1-m) * d/da [a**m/(a**2+(x-z)**2)**(m+1/2)] +c +c for n=0 to ndriv-1. +c Maximum value of nterm is 5. + parameter(maxdrv=20) + dimension c0(5,5),c1(4,4),c2(3,3),bi(5),ai(5) +c dimension c3(2,2) + dimension xgi1(5),xgi2(5),xngi(maxdrv),di1(maxdrv),di2(maxdrv) + data (c0(k,1),k=1,5) /5*1.d0/ + data (c0(k,2),k=1,5) /0.d0,1.d0,2.d0,3.d0,4.d0/ + data (c0(k,3),k=1,5) /2*0.d0,1.d0,3.d0,6.d0/ + data (c0(k,4),k=1,5) /3*0.d0,1.d0,4.d0/ + data (c0(k,5),k=1,5) /4*0.d0,1.d0/ + data (c1(k,1),k=1,4) /1.d0,2.d0,3.d0,4.d0/ + data (c1(k,2),k=1,4) /0.d0,2.d0,6.d0,12.d0/ + data (c1(k,3),k=1,4) /2*0.d0,3.d0,12.0/ + data (c1(k,4),k=1,4) /3*0.d0,4.d0/ + data (c2(k,1),k=1,3) /2.d0,6.d0,12.d0/ + data (c2(k,2),k=1,3) /0.d0,6.d0,24.d0/ + data (c2(k,3),k=1,3) /2*0.d0,12.d0/ +c data (c3(k,1),k=1,2) /6.d0,24.d0/ +c data (c3(k,2),k=1,2) /0.d0,24.d0/ +c data c4/24.d0/ + save c0,c1,c2 + if(nterm.gt.5) go to 1001 + if(nterm.lt.1) go to 1002 + s1=x1-z + s2=x2-z + call xngint(m,nterm,a,s1,xgi1) + call xngint(m,nterm,a,s2,xgi2) +c Find coefficients for the expansion of f(x)=f(z+s) in powers of s. + do 1 n=1,nterm + kmax=nterm-n + bi(n)=ai(nterm)*c0(nterm,n) + if(kmax.lt.1) go to 1 + do 2 k=1,kmax + l=nterm-k + 2 bi(n)=ai(l)*c0(l,n)+z*bi(n) + 1 continue +c Find integral of f(s+z)*g_m(s)ds from s1 to s2, where s1=x1-z, x2=x2- +c =zeroth derivative of integral. + xngi(1)=0.d0 + do 3 n=1,nterm + 3 xngi(1)=xngi(1)+bi(n)*(xgi2(n)-xgi1(n)) + if(ndriv.lt.2) return +c Getfirst derivative of integral +c Getzeroth, first, and higher derivatives of g_m +c Need only ndriv-1 terms in derivative vector, since everything is +c integrated once. + ndrm1=ndriv-1 + call drivs(m,ndrm1,a,s1,di1) + call drivs(m,ndrm1,a,s2,di2) + f1=ai(nterm) + f2=f1 + if(nterm.lt.2) go to 6 + do 5 n=2,nterm + k=nterm-n+1 + f1=ai(k)+x1*f1 + 5 f2=ai(k)+x2*f2 + 6 xngi(2)=f1*di1(1)-f2*di2(1) + if(nterm.lt.2) go to 7 +c calculate coefficients in expansion of df/dx(x)=df/dx(s+z) in powers o + ntrm1=nterm-1 + do 8 n=2,nterm + nm1=n-1 + kmax=nterm-n + bi(n)=ai(nterm)*c1(ntrm1,nm1) + if(kmax.lt.1) go to 8 + do 9 k=1,kmax + l=ntrm1-k + lp=nterm-k + 9 bi(n)=ai(lp)*c1(l,nm1)+z*bi(n) + 8 continue + do 10 n=2,nterm + nm1=n-1 + 10 xngi(2)=xngi(2)+bi(n)*(xgi2(nm1)-xgi1(nm1)) + 7 if(ndriv.lt.3) return +c Now get second derivative of integral + xngi(3)=f2*di2(2)-f1*di1(2) + if(nterm.lt.2) go to 11 +c Evaluate df/dx at x1 and x2 + f1p=c1(ntrm1,1)*ai(nterm) + f2p=f1p + if(nterm.lt.3) go to 12 + do 13 n=3,nterm + k=nterm-n+2 + km1=k-1 + f1p=ai(k)*c1(km1,1)+x1*f1p + 13 f2p=ai(k)*c1(km1,1)+x2*f2p + 12 xngi(3)=xngi(3)+f1p*di1(1)-f2p*di2(1) + if(nterm.lt.3) go to 11 +c Find coefficients in expansion of d**2 f(x)/dx**2 in powers of s. + ntrm2=nterm-2 + do 14 n=3,nterm + nm2=n-2 + kmax=nterm-n + bi(n)=ai(nterm)*c2(ntrm2,nm2) + if(kmax.lt.1) go to 14 + do 15 k=1,kmax + l=ntrm2-k + lp=nterm-k + 15 bi(n)=ai(lp)*c2(l,nm2)+z*bi(n) + 14 continue + do 16 n=3,nterm + nm2=n-2 + 16 xngi(3)=xngi(3)+bi(n)*(xgi2(nm2)-xgi1(nm2)) + 11 if(ndriv.lt.4) return +c Get3rd derivative of integral. + xngi(4)=f1*di1(3)-f2*di2(3) + if(nterm.lt.2) go to 17 + xngi(4)=xngi(4)+f2p*di2(2)-f1p*di1(2) + if(nterm.lt.3) go to 17 +c evaluate d**2 f/ dz**2 at x1 and x2 + f1pp=c2(ntrm2,1)*ai(nterm) + f2pp=f1pp + if(nterm.lt.4) go to 18 + do 19 n=4,nterm + k=nterm-n+3 + km2=k-2 + f1pp=ai(k)*c2(km2,1)+x1*f1pp + 19 f2pp=ai(k)*c2(km2,1)+x2*f2pp + 18 xngi(4)=xngi(4)+f1pp*di1(1)-f2pp*di2(1) + if(nterm.lt.4) go to 17 + delxg=xgi2(1)-xgi1(1) + xngi(4)=xngi(4)+6.d0*ai(4)*delxg + if(nterm.lt.5) go to 17 + xngi(4)=xngi(4)+24.d0*ai(5)*(z*delxg+xgi2(2)-xgi1(2)) + 17 if(ndriv.lt.5) return +c Integral of 4th derivative + xngi(5)=f2*di2(4)-f1*di1(4) + if(nterm.lt.2) go to 20 + xngi(5)=xngi(5)-f2p*di2(3)+f1p*di1(3) + if(nterm.lt.3) go to 20 + xngi(5)=xngi(5)+f2pp*di2(2)-f1pp*di1(2) + if(nterm.lt.4) go to 20 + f1ppp=6.d0*ai(4) + f2ppp=f1ppp + if(nterm.lt.5) go to 21 + f1ppp=f1ppp+24.d0*ai(5)*x1 + f2ppp=f2ppp+24.d0*ai(5)*x2 + 21 xngi(5)=xngi(5)+f1ppp*di1(1)-f2ppp*di2(1) + if(nterm.lt.5) go to 20 + xngi(5)=xngi(5)+24.d0*ai(5)*(xgi2(1)-xgi1(1)) + 20 if(ndriv.lt.6) return +c ndriv=6 or higher- ie., 5th or higher derivatives + sign=-1.d0 + do 22 n=6,ndriv + sign=-sign + nm1=n-1 + xngi(n)=f1*di1(nm1)-f2*di2(nm1) + if(nterm.lt.2) go to 22 + nm2=n-2 + xngi(n)=xngi(n)+f2p*di2(nm2)-f1p*di1(nm2) + if(nterm.lt.3) go to 22 + nm3=n-3 + xngi(n)=xngi(n)+f1pp*di1(nm3)-f2pp*di2(nm3) + if(nterm.lt.4) go to 22 + nm4=n-4 + xngi(n)=xngi(n)+f2ppp*di2(nm4)-f1ppp*di1(nm4) + if(nterm.lt.5) go to 22 + nm5=n-5 + xngi(n)=xngi(n)+24.d0*ai(5)*(di1(nm5)-di2(nm5)) + 22 xngi(n)=xngi(n)*sign + return + 1001 write(6,300) nterm + 300 format(1x,'nterm=',i4,' was >5 in XNGMIN --stopped') + stop + 1002 write(6,301) nterm + 301 format(1x,'nterm=',i4,' was < 1 in XNGMIN --stopped') + stop + end +c +c************************************************** +c +c +c next group of called routines +c + function cel(qqc,pp,aa,bb) + implicit double precision(a-h,o-z) +c +c returns the general complete elliptic integral cel(kc,p,a,b) with +c qqc=kc, pp=p, aa=a and bb=b. +c + parameter (ca=.00001d0 , pio2=1.570796326795d0) +c +c the desired accuracy is the square of ca +c + if(qqc.eq.0.d0) go to 21 + 22 format(1x,'xkc=0 in cel-stopped') + qc=dabs(qqc) + a=aa + b=bb + p=pp + e=qc + em=1.d0 + if(p.gt.0.d0)then + p=dsqrt(p) + b=b/p + else + f=qc*qc + q=1.d0-f + g=1.d0-p + f=f-p + q=q*(b-a*p) + p=dsqrt(f/g) + a=(a-b)/g + b=-q/(g*g*p)+a*p + endif + 1 f=a + a=a+b/p + g=e/p + b=b+f*g + b=b+b + p=g+p + g=em + em=qc+em + if(dabs(g-qc).gt.g*ca)then + qc=dsqrt(e) + qc=qc+qc + e=qc*em + go to 1 + endif + cel=pio2*(b+a*em)/(em*(em+p)) + return + 21 write(6,22) + stop + end +c +c************************************************** +c + subroutine drivs(m,ndriv,a,s,di) + implicit double precision(a-h,o-z) +c This subroutine calculates repeated derivatives of g_m= +c +c a**(1-m)d/da(a**m/(a**2+s**2)**(m+1/2)) +c +c di(1) = g_m, di(2)=d g_m /ds, di(3)= d**2 g_m /ds**2, etc. +c +c Uses formula from Gradstein and Ryzhik, Table of Integrals, +c Series, and Products, 1980, p.20 +c +c a=coil radius +c m=multipole index (m=1 for dipole,2 for quadrupole, 3 for sextupole,e +c s=x-z, where x=coil z coordinate, z= field point z coordinate. +c ndriv= no. of entries in di (no. of times g_m is differentiated + 1) +c +c maxdrv is the maximum value of ndriv required. + parameter (maxdrv=20,maxhlf=11) +c maxhlf must be at least 1/2 of maxdrv if maxdrv is even, +c 1/2(maxdrv+1) if maxdrv is odd. +c + dimension di(maxdrv) + dimension cnk(maxhlf,maxdrv),rnk1(maxhlf,maxdrv), + &rnk2(maxhlf,maxdrv),snk(maxhlf,maxdrv),rkfac(maxhlf) + aa=1.d0/a**2 + xm=dfloat(m) + u=1.d0+aa*s**2 + ru=1.d0/u + rru=dsqrt(ru) + m2mm1=-2*m-1 + denom=ru**m*rru*a**m2mm1 + c1=xm*denom + c2=(2.d0*xm+1.d0)*denom*ru + di(1)=c1-c2 + if(ndriv.lt.2) return + tas=2.d0*aa*s + p1=-xm-0.5d0 + p2=p1-1.d0 + c1=c1*p1*ru + c2=c2*p2*ru + di(2)=(c1-c2)*tas + if(ndriv.lt.3) return + p1m=p1 + p2m=p2 + au=aa*u + aunh=1.d0 + snk(1,1)=tas +c n=order of derivative +c find integers nhalf= nearest integer below or = (ndriv-1)/2, +c and ileft=1+(ndriv-1)-2*nhalf + xhalf=0.5d0*dfloat(ndriv-1) + nhalf=xhalf + dif=xhalf-dfloat(nhalf) + ileft=1 + if(dif.gt.0.1d0) ileft=2 + n=1 + rkf=1.d0 + do 1 nh=1,nhalf + rkf=rkf/dfloat(nh) + rkfac(nh)=rkf + nhp1=nh+1 + ilef=2 + if(nh.lt.nhalf) go to 6 + if(ileft.eq.1) ilef=1 + 6 aunh=aunh*au + nhp1=nh+1 + do 1 il=1,ilef + nm1=n + nm2=n-1 + n=n+1 + p1m=p1m-1.d0 + p2m=p2m-1.d0 + c1=c1*p1m*ru + c2=c2*p2m*ru + snk(nhp1,n)=aunh + do 4 k=1,nh + 4 snk(k,n)=snk(k,nm1)*tas + if(il.eq.2) snk(nhp1,n)=snk(nhp1,n)*tas + cnk(2,n)=dfloat(n*(n-1)) + rnk1(2,n)=1.d0/p1m + rnk2(2,n)=1.d0/p2m + if(nhp1.lt.3) go to 8 + do 7 k=3,nhp1 + km1=k-1 + cnk(k,n)=cnk(km1,nm2)*cnk(2,n) + rnk1(k,n)=rnk1(km1,nm1)*rnk1(2,n) + 7 rnk2(k,n)=rnk2(km1,nm1)*rnk2(2,n) + 8 sum1=snk(1,n) + sum2=sum1 + do 5 k=2,nhp1 + km1=k-1 + sum1=sum1+snk(k,n)*cnk(k,n)*rnk1(k,n)*rkfac(km1) + 5 sum2=sum2+snk(k,n)*cnk(k,n)*rnk2(k,n)*rkfac(km1) + np1=n+1 + 1 di(np1)=sum1*c1-sum2*c2 + return + end +c +c************************************************** +c + function el2(x,qqc,aa,bb) + implicit double precision(a-h,o-z) +c +c returns the general elliptic integral of the second kind, +c el2(x,kc,a,b) with x.ge.0,qqc=kc,aa=a and bb=b. +c + parameter (pi=3.14159265359d0 , ca=.00001d0,cb=1.d-11) +c +c the desired accuracy is the square of ca, while cb should be +c set to 0.01 times desired accuracy. +c + if(x.eq.0.d0)then + el2=0.d0 + else if(qqc.ne.0.d0) then + qc=qqc + a=aa + b=bb + c=x**2 + d=1.d0+c + p=dsqrt((1.d0+qc**2*c)/d) + d=x/d + c=d/(2.d0*p) + z=a-b + eye=a + a=0.5d0*(b+a) + y=abs(1.d0/x) + f=0.d0 + l=0 + em=1.d0 + qc=dabs(qc) + 1 b=eye*qc+b + e=em*qc + g=e/p + d=f*g+d + f=c + eye=a + p=g+p + c=0.5d0*(d/p+c) + g=em + em=qc+em + a=0.5d0*(b/em+a) + y=-e/y+y + if(y.eq.0)y=dsqrt(e)*cb + if(dabs(g-qc).gt.ca*g)then + qc=dsqrt(e)*2.d0 + l=l+l + if(y.lt.0.) l=l+1 + go to 1 + endif + if(y.lt.0.)l=l+1 + e=(datan(em/y)+pi*l)*a/em + if(x.lt.0) e=-e + el2=e+c*z + else + write(6,21) + 21 format(1x,'xkc=0 in el2-stopped') + stop +c argument qqc was zero + endif + return + end +c +c************************************************** +c +c +c +c this is a function subprogram copied from numerical recipes +c by w.h.press ,etl pp. 186-187. +c evaluates the general complete elliptic integral +c as the following function of four variables: +c +c cel(kc,p,a,b)= +c int[ (a+b*x**2)dx/{1+p*x**2)*sqrt((1+x**2)*(1+kc**2*x**2))} +c from x=0 to x=infinite +c + subroutine intend(a1,a2,z1,z2,m,xiend) +c Used for m even case, 0th derivative of on-axis gradient of a PMM. + implicit double precision(a-h,o-z) +c Evaluates the double integral from a1 to a2 and z1 to z2 of +c +c drho*dz/((rho**2+z**2)**(m/2+1/2)) +c +c using a polar coordinate approach. +c z1 or z2 can be zero; a1 and a2 are assumed to always be greater +c than zero. +c +c mMUST BE EVEN! +c +c mgreater than or equal to 2 +c + parameter(mmax=26) + dimension amk(mmax) +c data small/1.d-1/ + xm=dfloat(m) + xmm1=xm-1.d0 + mm1=m-1 + mhalf=m/2 + a12=a1**2 + a22=a2**2 + z12=z1**2 + z22=z2**2 + hyp12=a12+z22 + hyp22=a22+z22 + hyp32=a22+z12 + hyp42=a12+z12 + hyp1=dsqrt(hyp12) + hyp2=dsqrt(hyp22) + hyp3=dsqrt(hyp32) + hyp4=dsqrt(hyp42) + sin1=a1/hyp1 + sin2=a2/hyp2 + sin3=a2/hyp3 + sin4=a1/hyp4 + cos1=z2/hyp1 + cos2=z2/hyp2 + cos3=z1/hyp3 + cos4=z1/hyp4 +c Find coefficients for cosine**(m-1) and sine**(m-1) integrals-- +c they are the same for both--see Gradshtein&Ryzhik, p. 131. +c There are a total of m/2-1 coefficients. 2l+1 in G&R is m-1 here. +c Skip calculation of coeffficients if m=2 + if(m.lt.3) go to 2 + xnum=xm-2.d0 + dnom=xm-3.d0 + amk(1)=xnum/dnom + mhm1=mhalf-1 + if(mhm1.lt.2) go to 23 + do 22 j=2,mhm1 + jm1=j-1 + xnum=xnum-2 + dnom=dnom-2 + 22 amk(j)=amk(jm1)*xnum/dnom + 23 continue +c m>2 case-- use subroutine INTCOS +c RHS vertical line + call intcos(cos1,cos2,sin1,sin2,hyp12,hyp22,z2,amk,m,cosint) + xiend=cosint +c LHSvertical line + call intcos(cos3,cos4,sin3,sin4,hyp32,hyp42,z1,amk,m,cosint) + xiend=xiend+cosint +c Tophorizontal line + call intcos(sin1,sin4,cos1,cos4,hyp12,hyp42,a1,amk,m,cosint) + xiend=xiend+cosint +c Bottom horizontal line + call intcos(sin2,sin3,cos2,cos3,hyp22,hyp32,a2,amk,m,cosint) + xiend=xiend-cosint + xiend=xiend/dfloat(m-1) + return +c m=2case + 2 xiend=0.d0 + if(cos1.eq.0.d0) go to 3 + if(dabs(cos1).gt.0.1d0) go to 4 +c small angle formula used when z2 is small +c Floating-point numbers in the expression below are the coefficients +c theexpansion for (1+x)**(-1/2) + e12=z22/a12 + e22=z22/a22 + t2=(0.5d0-e22*(0.375d0-e22*(0.3125d0-e22*(0.2734375d0- + &e22*(0.24609375d0-e22*(0.2255859375d0- + &e22*(0.20947265625d0-e22*(0.196380615234375d0- + &e22*(0.1854705810546875d0- + &e22*0.1761970520019531d0)))))))))/a22 + t1=(0.5d0-e12*(0.375d0-e12*(0.3125d0-e12*(0.2734375d0- + &e12*(0.24609375d0-e12*(0.2255859375d0- + &e12*(0.20947265625d0-e12*(0.196380615234375d0- + &e12*(0.1854705810546875d0- + &e12*0.1761970520019531d0)))))))))/a12 + xiend=z2*(t2-t1) + go to 3 +c General (z2 not small) case + 4 xiend=(sin1-sin2)/z2 +c Left hand vertical line at z1 + 3 if(cos4.eq.0.d0) go to 5 + if(dabs(cos4).gt.0.1d0) go to 6 +c Small angle formula for small z1 + e12=z12/a12 + e22=z12/a22 + t2=(0.5d0-e22*(0.375d0-e22*(0.3125d0-e22*(0.2734375d0- + &e22*(0.24609375d0-e22*(0.2255859375d0- + &e22*(0.20947265625d0-e22*(0.196380615234375d0- + &e22*(0.1854705810546875d0- + &e22*0.1761970520019531d0)))))))))/a22 + t1=(0.5d0-e12*(0.375d0-e12*(0.3125d0-e12*(0.2734375d0- + &e12*(0.24609375d0-e12*(0.2255859375d0- + &e12*(0.20947265625d0-e12*(0.196380615234375d0- + &e12*(0.1854705810546875d0- + &e12*0.1761970520019531d0)))))))))/a12 + xiend=xiend-z1*(t2-t1) + go to 5 +c General (z1 not small) case + 6 xiend=xiend+(sin3-sin4)/z1 +c Upper and lower horizontal lines + 5 xiend=xiend+(cos1-cos4)/a1+(cos3-cos2)/a2 + return + end +c +c************************************************** +c + subroutine rhoint(a1,a2,s,is,m,nd,rhoin) +c Checked by numerical integration +c Used for gtype2 (thick Halbach) + implicit double precision(a-h,o-z) +c This subroutine evaluates the components of the vector rhoin, which +c arethe integrals +c integral from a1 to a2 dr of +c (r**(m+2))/((r**2+s**2)*(m+k+3/2)) , +c k=0,1,2,3,...nd-1 +c +c m=multipole index. m=1 for dipole, 2 for quad.,etc. m is > or = 1. +c ndis number of derivatives. This subroutine called only if nd > or +c + parameter(maxdrv=20,small=1.d-6,smal=5.d-2) + parameter(nterms=15) + parameter(maxcof=35) + common /dnms/ denom(maxcof,2,2) +c NTERMS is the number of terms used in the small-s expansion. Can be m +c large, while SMAL is also made larger, for check. + dimension rhoin(maxdrv),rhon1(maxdrv) + dimension rhon2(maxdrv),xirend(maxdrv) +c +c Calls subroutine RHOEND if m is even (2 or greater). +c +c First check to see if s is small or zero. If so, use expansion in s/a + x1=(s/a1)**2 + if(x1.lt.smal) go to 3 +c +c Next check to see if m is odd or even +c + a12=a1**2 + a22=a2**2 + x=dfloat(m+3)*0.5d0+small + iterms=x + dif=x-dfloat(iterms) + ileft=0 + if(dif.gt.0.1d0) ileft=1 +c ileft=0 if m is odd, =1 if m is even + if(ileft.gt.0) go to 1 +c m is odd + do 2 l=1,nd + 2 rhoin(l)=0.d0 +c Exponent on denominator in innermost term=n+k+1/2 ,k=0,1,..nd-1 + nmin=(m-1)/2 + a1prod=1.d0 + a2prod=1.d0 + itop=0 + ibot=m-2 + go to 5 + 1 continue +c m is even- descending series ends in an integral evaluated by RHOE + nmin=m/2 + call rhoend(a1,a2,s,is,m,nd,xirend) + do 6 l=1,nd + 6 rhoin(l)=-xirend(l) + a1prod=a1 + a2prod=a2 + itop=1 + ibot=m-1 + 5 itrm1=iterms-1 + np1=nmin+1 + do 8 i=1,itrm1 + itop=itop+2 + ibot=ibot+2 + do 10 l=1,nd + k=l-1 + np1pk=np1+k + 10 rhoin(l)=(rhoin(l)+a2prod*denom(np1pk,2,is)- + &a1prod*denom(np1pk,1,is))*dfloat(itop)/dfloat(ibot+2*k) + a1prod=a1prod*a12 + a2prod=a2prod*a22 + np1=np1+1 + 8 continue + ibot=ibot+2 + do 7 l=1,nd + k=l-1 + np1pk=np1+k + 7 rhoin(l)=-(rhoin(l)+a2prod*denom(np1pk,2,is)- + &a1prod*denom(np1pk,1,is))/dfloat(ibot+2*k) + return + 3 x2=(s/a2)**2 +c Small-s expansion algorithm +c No.of terms should be increased if quadruple precision, etc. is used + do 11 l=1,nd + k=l-1 + rhon1(l)=1.d0/dfloat(m+2*k) + rhon2(l)=rhon1(l) + xnum=dfloat(m+k+1)-0.5d0 + fac=1.d0 + y1=1.d0 + y2=1.d0 + do 9 n=1,nterms + xnum=xnum+1.d0 + y1=-y1*xnum*x1 + y2=-y2*xnum*x2 + fac=fac*dfloat(n) + dnm=1.d0/(fac*dfloat(m+2*(k+n))) + rhon1(l)=rhon1(l)+y1*dnm + rhon2(l)=rhon2(l)+y2*dnm + 9 continue + n=m+2*(l-1) + 11 rhoin(l)=rhon1(l)*a1**(-n)-rhon2(l)*a2**(-n) + return + end +c +c************************************************** +c + subroutine xngint(m,nint,a,s,xgi) + implicit double precision(a-h,o-z) + parameter(maxcof=35) + parameter(c83=8.d0/3.d0) + parameter(t3rds=2.d0/3.d0) + parameter(sv3rds=7.d0/3.d0) + common /bicof/ bcoeff(maxcof,maxcof) +c This subroutine calculates indefinite integrals to s of gm*x**(n-1), +c n=1,nint, fixed m. +c +c where gm=a**(1-m)*d/da((a**m)/(a**2+x**2)**(m+1/2)) +c +c maximum nint=5 +c "m =9 +c +c m=multipole index +c nint=no. of integrals, = no. of components in xgi +c xgi=vector of nint integrals +c a=coil radius + dimension xgi(5) +c bcoeff contains the binomial expansion coefficients up to order maxc +c input parameter checks + if(m.gt.100) go to 1001 + if(m.lt.1) go to 1002 + if(nint.gt.5) go to 1003 + if(a.le.0.d0) go to 1004 +c m=1and m=2 are treated specially + if(m.gt.1) go to 20 +c m=1case + a2=a**2 + ra2=1.d0/a2 + s2=s**2 + u2=a2+s2 + ru2=1.d0/u2 + u=dsqrt(u2) + ru=1.d0/u + xgi(1)=-s*(ra2+ru2)*ru + if(nint.lt.2) return + xgi(2)=-ru+a2*ru*ru2 + if(nint.lt.3) return + dl=dlog(s+u) + xgi(3)=-s*ru+dl+a2*s*ru2*ru+a2*ru/(s+u) + if(nint.lt.4) return + xgi(4)=u+a2*ru*(4.d0-a2*ru2) + if(nint.lt.5) return + xgi(5)=s*(0.5d0*u+ru*a2*(4.d0+s2*ru2))-4.5d0*a2*dl + return +c m=2case + 20 if(m.gt.2) go to 30 + a2=a**2 + a4=a2**2 + s2=s**2 + u2=a2+s2 + u22=u2**2 + u=dsqrt(u2) + ru=1.d0/u + ru2=1.d0/u2 + xgi(1)=(s*ru*(c83*s2*ru2-3.d0-(s2*ru2)**2))/a4 + if(nint.lt.2) return + xgi(2)=ru2*ru*(a2*ru2-t3rds) + if(nint.lt.3) return + xgi(3)=-s2*s/(u22*u) + if(nint.lt.4) return + xgi(4)=ru*(a2*ru2*(sv3rds-a2*ru2)-2.d0) + if(nint.lt.5) return + xgi(5)=2.d0*dlog(s+u)- + &s*ru*(2.d0+s2*ru2*(t3rds+ru2*s2)) + return + 30 continue +c m=3or greater + xm=dfloat(m) + mm1=m-1 + mm2=m-2 + mm3=m-3 + mp1=m+1 + xmm1=dfloat(mm1) + xmm2=dfloat(mm2) + a2=a**2 + a2m=a2**m + a2mm2=a2m/a2 + a2mm4=a2mm2/a2 + x2mp1=dfloat(2*m+1) + tmm1=dfloat(2*m-1) + tmm3=dfloat(2*m-3) + r1=xm/tmm3 + r2=dfloat(3*m+1)/tmm1 + z=s + zsq=z**2 + u2=zsq+a2 + ru2=1.d0/u2 + ur2=a2/u2 + u=dsqrt(u2) + rz2u2=zsq/u2 + rzu=z/u + rend=rz2u2**m*rzu + u2mm3=u2**mm2*u + u2mm1=u2*u2mm3 +c n=1 + sign=-1.d0 + sum=0.d0 + do 2 k=1,m + sign=-sign + k2m1=2*k-1 + km1=k-1 + tkm1=dfloat(k2m1) + if(km1.eq.0) go to 21 + term=rzu/tkm1*rz2u2**km1 + go to 22 + 21 term=rzu/tkm1 + 22 c=xm*bcoeff(k,mm1)-x2mp1*bcoeff(k,m) + 2 sum=sum+c*term*sign + sum=sum+sign*rend + sum=sum/a2m + xgi(1)=sum + if(nint.lt.2) return +c n=2 + term=(ur2-xm/tmm1)/u2mm1 + xgi(2)=term + if(nint.lt.3) return +c n=3 + sign=-1.d0 + sum=0.d0 + do 3 k=1,mm1 + km1=k-1 + sign=-sign + tkp1=dfloat(2*k+1) + term=rzu/tkp1*rz2u2**k + c=xm*bcoeff(k,mm2)-x2mp1*bcoeff(k,mm1) + 3 sum=sum+c*term*sign + sum=sum+sign*rend + sum=sum/a2mm2 + xgi(3)=sum + if(nint.lt.4) return +c n=4 + term=(r1-ur2*(r2-ur2))/u2mm3 + xgi(4)=-term + if(nint.lt.5) return +c n=5 + if(m.gt.3) go to 8 +c m=3is a special case + term=(rend-0.8d0*rzu*rz2u2**2)/a2 + xgi(5)=term + return + 8 sign=-1.d0 + sum=0.d0 + do 4 k=1,mm2 + tkp3=dfloat(2*k+3) + kp1=k+1 + sign=-sign + c=xm*bcoeff(k,mm3)-x2mp1*bcoeff(k,mm2) + term=rzu/tkp3*rz2u2**kp1 + 4 sum=sum+c*term*sign + sum=sum+sign*rend + sum=sum/a2mm4 + xgi(5)=sum + return + 1001 write(6,3001) + 3001 format(1x,'m greater than 100 in xngint-stopped') + stop + 1002 write(6,3002) + 3002 format(1x,'m less than 1 in xngint-stopped') + stop + 1003 write(6,3003) + 3003 format(1x,'nint greater than 5 in xngint-stopped') + stop + 1004 write(6,3004) + 3004 format(1x,'a less than or equal 0 in xngint-stopped') + stop + end +c +c************************************************** +c + subroutine zint(a1,a2,s1,s2,nmin,m,zinti) + implicit double precision(a-h,o-z) + parameter(maxcof=35) +c The array ZINTI contains the integrals from s1 to s2 of +c +c ds*a**2n/(a**2+s**2)**n+1/2, n=nmin,nmin+1,nmin+2,...m +c +c zinti(i,1) is evaluated at a1, zinti(i,2) at a2. +c The index i runs from 1 to m-nmin+1, with n=nmin for i=1, nmin+1 for +c i=2, etc. +c +c +c Uses analytical formula from Gradshtein and Ryzhik, p. 86. +c +c + common /bicof/ bcoeff(maxcof,maxcof) +c bcoeff(k,n) is an element of array containing the binomial coefficien +c index k goes from 1 to maxcof; elements with k>n+1 are zero. +c index n goes from 1 to maxcof + common/dnms/denom(maxcof,2,2) + dimension zinti(maxcof,2) + if(nmin.gt.0) go to 1 +c nmin=0 --- First term is a logarithmic expression, since m=1 +c There are two terms. + a12=a1**2 + a22=a2**2 + s12=s1**2 + s22=s2**2 +c fora1: + zinti(1,1)=dlog((s2+dsqrt(s22+a12))/(s1+dsqrt(s12+a12))) +c fora2: + zinti(1,2)=dlog((s2+dsqrt(s22+a22))/(s1+dsqrt(s12+a22))) +c fora1: + zinti(2,1)=s2*denom(1,1,2)-s1*denom(1,1,1) +c fora2: + zinti(2,2)=s2*denom(1,2,2)-s1*denom(1,2,1) + return +c nmin=1 or greater + 1 nterm=m-nmin+1 +c nterm is the number of elements in each of zinti(n,1) and zinti(n,2), +c separately. + s12=s1**2 + s22=s2**2 + s1n=s1 + s2n=s2 + do 2 l=1,nterm +c rho=a1 + zinti(l,1)=s2*denom(1,1,2)-s1*denom(1,1,1) +c rho=a2 + 2 zinti(l,2)=s2*denom(1,2,2)-s1*denom(1,2,1) + do 3 k=2,m + r2kp1=1.d0/dfloat(2*k-1) + s1n=-s12*s1n + s2n=-s22*s2n + ck1=s1n*r2kp1 + ck2=s2n*r2kp1 + lmin=1 + if(k.gt.nmin) lmin=k-nmin+1 + do 3 l=lmin,nterm + n=nmin+l-2 + ckl1=bcoeff(k,n)*ck1 + ckl2=bcoeff(k,n)*ck2 +c rho=a1 + zinti(l,1)=zinti(l,1)+ckl2*denom(k,1,2)-ckl1*denom(k,1,1) +c rho=a2 + 3 zinti(l,2)=zinti(l,2)+ckl2*denom(k,2,2)-ckl1*denom(k,2,1) + return + end +c +c************************************************** +c + subroutine intcos(cos1,cos2,sin1,sin2,r12,r22,x,amk,m,cosint) + implicit double precision(a-h,o-z) + dimension amk(m) +c This subroutine evaluates 1/x times the integral from phi1 to phi2 of +c +c (cos phi)**(m-1) * dphi +c +c used only for even m values +c +c when x is small, by definition cos1 and cos2 are small, and the +c result is well-behaved as x goes to zero. For small x, a small +c x expansion is used. Otherwise, the expression from Gradstein and +c Ryzhik, p. 131, is used to evaluate the integral, and the result is +c divided by x. +c analogous sine integral obtained by switching sine for cosines in +c call and changing the sign of COSINT. + if(cos1.eq.0.d0) go to 1 + xm=dfloat(m) + mhalf=m/2 + if(dabs(cos1).gt.0.1d0) go to 2 +c Usesmall angle Taylor series to evaluate integral + cos12=cos1**2 + cos22=cos2**2 + t2=1.d0/xm+cos22*(0.5d0/(xm+2.d0)+cos22*(0.375d0/(xm+4.d0)+ + &cos22*(0.3125d0/(xm+6.d0)+cos22*(0.2734375d0/(xm+8.d0)+ + &cos22*(0.24609375d0/(xm+1.d1)+cos22*(0.2255859375d0/ + &(xm+1.2d1)+cos22*(0.20947265625d0/(xm+1.4d1)+ + &cos22*(0.196380615234375d0/(xm+1.6d1)+ + &cos22*(0.1854705810546875d0/(xm+1.8d1)+ + &cos22*0.1761970520019531d0/(xm+2.d1)))))))))) + t1=1.d0/xm+cos12*(0.5d0/(xm+2.d0)+cos12*(0.375d0/(xm+4.d0)+ + &cos12*(0.3125d0/(xm+6.d0)+cos12*(0.2734375d0/(xm+8.d0)+ + &cos12*(0.24609375d0/(xm+1.d1)+cos12*(0.2255859375d0/ + &(xm+1.2d1)+cos12*(0.20947265625d0/(xm+1.4d1)+ + &cos12*(0.196380615234375d0/(xm+1.6d1)+ + &cos12*(0.1854705810546875d0/(xm+1.8d1)+ + &cos12*0.1761970520019531d0/(xm+2.d1)))))))))) + r1m=r12**(-mhalf) + r2m=r22**(-mhalf) + cosint=x*(t2*r2m-t1*r1m) + return +c General expression for cosine integral + 2 cosi2=cos2**2 + sini=sin2 + mhm1=mhalf-1 + mm1=m-1 + xmm1=dfloat(mm1) + temp=0.d0 + do 11 i=1,2 + cos2k=1.d0 + sum=0.d0 + do 12 j=1,mhm1 + k=mhm1-j+1 + sum=sum+amk(k)*cos2k + 12 cos2k=cos2k*cosi2 + sum=sum+cos2k + sum=sum*sini + if(i.eq.1) sum=-sum + temp=temp+sum + cosi2=cos1**2 + 11 sini=sin1 + cosint=temp/(xmm1*x**mm1) + return + 1 cosint=0.d0 + return + end +c +c************************************************** +c + subroutine rhoend(a1,a2,s,is,m,nd,xirend) +c Checked by numerical integration +c used for gtype2 (thick Halbach) + implicit double precision(a-h,o-z) + parameter(maxcof=35,maxdrv=20) + common /dnms/ denom(maxcof,2,2) + common /bicof/ bcoeff(maxcof,maxcof) + dimension xirend(maxdrv) +c This subroutine evaluates the integral from a1 to a2 of +c +c drho/(rho**2+s**2)**(m/2+k+1/2) , k=0,2,3....nd-1 +c +c s is assumed not to be small or zero-- if so, the subroutine calling +c one(i.e. RHOINT) uses a series expansion in s, and therefore does no +c call this one. +c +c THIS SUBROUTINE IS CALLED ONLY IF m IS EVEN (2 or GREATER). +c Also nd must be 1 or greater. +c +c Uses analytical formula from Gradshtein and Ryzhik, p. 86. +c +c is =1 for s1, 2 for s2 +c xirend is a vector of length nd containing the inetgrals + a12=a1**2 + a22=a2**2 + a1n=a1 + a2n=a2 + rs2=1.d0/s**2 + mo2=m/2 + kmax=mo2+nd-1 + do 2 l=1,nd + 2 xirend(l)=a2*denom(1,2,is)-a1*denom(1,1,is) + do 3 k=2,kmax + r2kp1=1.d0/dfloat(2*k-1) + a1n=-a12*a1n + a2n=-a22*a2n + ck1=a1n*r2kp1 + ck2=a2n*r2kp1 + lmin=1 + if(k.gt.mo2) lmin=k-mo2+1 + do 3 l=lmin,nd + n=mo2+l-2 + ckl1=bcoeff(k,n)*ck1 + ckl2=bcoeff(k,n)*ck2 + 3 xirend(l)=xirend(l)+ckl2*denom(k,2,is)-ckl1*denom(k,1,is) + if(m.gt.2) go to 6 + sfac=rs2 + go to 7 + 6 sfac=rs2**mo2 + 7 do 5 l=1,nd + xirend(l)=xirend(l)*sfac + if(l.eq.nd) go to 5 + sfac=sfac*rs2 + 5 continue + return + end +c +c************************************************** +c diff --git a/OpticsJan2020/MLI_light_optics/Src/makeit b/OpticsJan2020/MLI_light_optics/Src/makeit new file mode 100755 index 0000000..cbedab0 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/makeit @@ -0,0 +1,2 @@ +cd ../Makedir +make diff --git a/OpticsJan2020/MLI_light_optics/Src/math.f b/OpticsJan2020/MLI_light_optics/Src/math.f new file mode 100644 index 0000000..0cbce9f --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/math.f @@ -0,0 +1,2037 @@ +*********************************************************************** +* header MATH UTILITIES * +* Routines for handling maps and general mathematical utilities * +*********************************************************************** +c + subroutine dcdiv(a,b,c,d,e,f) +c computes the complex division +c a + ib = (c + id)/(e + if) +c very slow, but tries to be as accurate as +c possible by changing the order of the +c operations, so to avoid under(over)flow +c problems. +c Written by F. Neri Feb. 12 1986 +c +c implicit none + double precision a,b,c,d,e,f + double precision s,t + double precision cc,dd,ee,ff + double precision temp + integer flip + flip = 0 + cc = c + dd = d + ee = e + ff = f + if( dabs(f).ge.dabs(e) ) then + ee = f + ff = e + cc = d + dd = c + flip = 1 + endif + s = 1.d0/ee + t = 1.d0/(ee+ ff*(ff*s)) + if ( dabs(ff) .ge. dabs(s) ) then + temp = ff + ff = s + s = temp + endif + if( dabs(dd) .ge. dabs(s) ) then + a = t*(cc + s*(dd*ff)) + else if ( dabs(dd) .ge. dabs(ff) ) then + a = t*(cc + dd*(s*ff)) + else + a = t*(cc + ff*(s*dd)) + endif + if ( dabs(cc) .ge. dabs(s)) then + b = t*(dd - s*(cc*ff)) + else if ( dabs(cc) .ge. dabs(ff)) then + b = t*(dd - cc*(s*ff)) + else + b = t*(dd - ff*(s*cc)) + endif + if (flip.ne.0 ) then + b = -b + endif + return + end +c +c ****************************************************************** +c + subroutine dhqr2(nm,n,low,igh,h,wr,wi,z,ierr) +c +c implicit none + integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn, + & igh,its,low,mp2,enm2,ierr + double precision h(nm,n),wr(n),wi(n),z(nm,n) + double precision p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,machep +c double precision dsqrt,dabs,dsign +c integer min0 + logical notlas +c complex z3 + double precision z3r,z3i +c complex cmplx +c double precision real,aimag +c +c +c +c this subroutine is a translation of the algol procedure hqr2, +c num. math. 16, 181-204(1970) by peters and wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 372-395(1971). +c +c this subroutine finds the eigenvalues and eigenvectors +c of a real upper hessenberg matrix by the qr method. the +c eigenvectors of a real general matrix can also be found +c if elmhes and eltran or orthes and ortran have +c been used to reduce this general matrix to hessenberg form +c and to accumulate the similarity transformations. +c +c on input- +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement, +c +c n is the order of the matrix, +c +c low and igh are integers determined by the balancing +c subroutine balanc. if balanc has not been used, +c set low=1, igh=n, +c +c h contains the upper hessenberg matrix, +c +c z contains the transformation matrix produced by eltran +c after the reduction by elmhes, or by ortran after the +c reduction by orthes, if performed. if the eigenvectors +c of the hessenberg matrix are desired, z must contain the +c identity matrix. +c +c on output- +c +c h has been destroyed, +c +c wr and wi contain the real and imaginary parts, +c respectively, of the eigenvalues. the eigenvalues +c are unordered except that complex conjugate pairs +c of values appear consecutively with the eigenvalue +c having the positive imaginary part first. if an +c error exit is made, the eigenvalues should be correct +c for indices ierr+1,...,n, +c +c z contains the real and imaginary parts of the eigenvectors. +c if the i-th eigenvalue is real, the i-th column of z +c contains its eigenvector. if the i-th eigenvalue is complex +c with positive imaginary part, the i-th and (i+1)-th +c columns of z contain the real and imaginary parts of its +c eigenvector. the eigenvectors are unnormalized. if an +c error exit is made, none of the eigenvectors has been found, +c +c ierr is set to +c zero for normal return, +c j if the j-th eigenvalue has not been +c determined after 30 iterations. +c +c arithmetic is double precision. complex division +c is simulated by routin dcdiv. +c +c fortran routine by b. s. garbow. +c modified by f. neri. +c +c +c ********** machep is a machine dependent parameter specifying +c the relative precision of floating point arithmetic. +c +c ********** + machep = 1.d-15 +c machep = r1mach(4) +c + ierr = 0 + norm = 0.0 + k = 1 +c ********** store roots isolated by balanc +c and compute matrix norm ********** + do 50 i = 1, n +c + do 40 j = k, n + 40 norm = norm + dabs(h(i,j)) +c + k = i + if (i .ge. low .and. i .le. igh) go to 50 + wr(i) = h(i,i) + wi(i) = 0.0 + 50 continue +c + en = igh + t = 0.0 +c ********** search for next eigenvalues ********** + 60 if (en .lt. low) go to 340 + its = 0 + na = en - 1 + enm2 = na - 1 +c ********** look for single small sub-diagonal element +c for l=en step -1 until low do -- ********** + 70 do 80 ll = low, en + l = en + low - ll + if (l .eq. low) go to 100 + s = dabs(h(l-1,l-1)) + dabs(h(l,l)) + if (s .eq. 0.0) s = norm + if (dabs(h(l,l-1)) .le. machep * s) go to 100 + 80 continue +c ********** form shift ********** + 100 x = h(en,en) + if (l .eq. en) go to 270 + y = h(na,na) + w = h(en,na) * h(na,en) + if (l .eq. na) go to 280 + if (its .eq. 30) go to 1000 + if (its .ne. 10 .and. its .ne. 20) go to 130 +c ********** form exceptional shift ********** + t = t + x +c + do 120 i = low, en + 120 h(i,i) = h(i,i) - x +c + s = dabs(h(en,na)) + dabs(h(na,enm2)) + x = 0.75 * s + y = x + w = -0.4375 * s * s + 130 its = its + 1 +c ********** look for two consecutive small +c sub-diagonal elements. +c for m=en-2 step -1 until l do -- ********** + do 140 mm = l, enm2 + m = enm2 + l - mm + zz = h(m,m) + r = x - zz + s = y - zz + p = (r * s - w) / h(m+1,m) + h(m,m+1) + q = h(m+1,m+1) - zz - r - s + r = h(m+2,m+1) + s = dabs(p) + dabs(q) + dabs(r) + p = p / s + q = q / s + r = r / s + if (m .eq. l) go to 150 + if (dabs(h(m,m-1)) * (dabs(q) + dabs(r)) .le. machep * dabs(p) + & * (dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1)))) go to 150 + 140 continue +c + 150 mp2 = m + 2 +c + do 160 i = mp2, en + h(i,i-2) = 0.0 + if (i .eq. mp2) go to 160 + h(i,i-3) = 0.0 + 160 continue +c ********** double qr step involving rows l to en and +c columns m to en ********** + do 260 k = m, na + notlas = k .ne. na + if (k .eq. m) go to 170 + p = h(k,k-1) + q = h(k+1,k-1) + r = 0.0 + if (notlas) r = h(k+2,k-1) + x = dabs(p) + dabs(q) + dabs(r) + if (x .eq. 0.0) go to 260 + p = p / x + q = q / x + r = r / x + 170 s = dsign(dsqrt(p*p+q*q+r*r),p) + if (k .eq. m) go to 180 + h(k,k-1) = -s * x + go to 190 + 180 if (l .ne. m) h(k,k-1) = -h(k,k-1) + 190 p = p + s + x = p / s + y = q / s + zz = r / s + q = q / p + r = r / p +c ********** row modification ********** + do 210 j = k, n + p = h(k,j) + q * h(k+1,j) + if (.not. notlas) go to 200 + p = p + r * h(k+2,j) + h(k+2,j) = h(k+2,j) - p * zz + 200 h(k+1,j) = h(k+1,j) - p * y + h(k,j) = h(k,j) - p * x + 210 continue +c + j = min0(en,k+3) +c ********** column modification ********** + do 230 i = 1, j + p = x * h(i,k) + y * h(i,k+1) + if (.not. notlas) go to 220 + p = p + zz * h(i,k+2) + h(i,k+2) = h(i,k+2) - p * r + 220 h(i,k+1) = h(i,k+1) - p * q + h(i,k) = h(i,k) - p + 230 continue +c ********** accumulate transformations ********** + do 250 i = low, igh + p = x * z(i,k) + y * z(i,k+1) + if (.not. notlas) go to 240 + p = p + zz * z(i,k+2) + z(i,k+2) = z(i,k+2) - p * r + 240 z(i,k+1) = z(i,k+1) - p * q + z(i,k) = z(i,k) - p + 250 continue +c + 260 continue +c + go to 70 +c ********** one root found ********** + 270 h(en,en) = x + t + wr(en) = h(en,en) + wi(en) = 0.0 + en = na + go to 60 +c ********** two roots found ********** + 280 p = (y - x) / 2.0 + q = p * p + w + zz = dsqrt(dabs(q)) + h(en,en) = x + t + x = h(en,en) + h(na,na) = y + t + if (q .lt. 0.0) go to 320 +c ********** real pair ********** + zz = p + dsign(zz,p) + wr(na) = x + zz + wr(en) = wr(na) + if (zz .ne. 0.0) wr(en) = x - w / zz + wi(na) = 0.0 + wi(en) = 0.0 + x = h(en,na) + s = dabs(x) + dabs(zz) + p = x / s + q = zz / s + r = dsqrt(p*p+q*q) + p = p / r + q = q / r +c ********** row modification ********** + do 290 j = na, n + zz = h(na,j) + h(na,j) = q * zz + p * h(en,j) + h(en,j) = q * h(en,j) - p * zz + 290 continue +c ********** column modification ********** + do 300 i = 1, en + zz = h(i,na) + h(i,na) = q * zz + p * h(i,en) + h(i,en) = q * h(i,en) - p * zz + 300 continue +c ********** accumulate transformations ********** + do 310 i = low, igh + zz = z(i,na) + z(i,na) = q * zz + p * z(i,en) + z(i,en) = q * z(i,en) - p * zz + 310 continue +c + go to 330 +c ********** complex pair ********** + 320 wr(na) = x + p + wr(en) = x + p + wi(na) = zz + wi(en) = -zz + 330 en = enm2 + go to 60 +c ********** all roots found. backsubstitute to find +c vectors of upper triangular form ********** + 340 if (norm .eq. 0.0) go to 1001 +c ********** for en=n step -1 until 1 do -- ********** + do 800 nn = 1, n + en = n + 1 - nn + p = wr(en) + q = wi(en) + na = en - 1 + if (q) 710, 600, 800 +c ********** real vector ********** + 600 m = en + h(en,en) = 1.0 + if (na .eq. 0) go to 800 +c ********** for i=en-1 step -1 until 1 do -- ********** + do 700 ii = 1, na + i = en - ii + w = h(i,i) - p + r = h(i,en) + if (m .gt. na) go to 620 +c + do 610 j = m, na + 610 r = r + h(i,j) * h(j,en) +c + 620 if (wi(i) .ge. 0.0) go to 630 + zz = w + s = r + go to 700 + 630 m = i + if (wi(i) .ne. 0.0) go to 640 + t = w + if (w .eq. 0.0) t = machep * norm + h(i,en) = -r / t + go to 700 +c ********** solve real equations ********** + 640 x = h(i,i+1) + y = h(i+1,i) + q = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) + t = (x * s - zz * r) / q + h(i,en) = t + if (dabs(x) .le. dabs(zz)) go to 650 + h(i+1,en) = (-r - w * t) / x + go to 700 + 650 h(i+1,en) = (-s - y * t) / zz + 700 continue +c ********** end real vector ********** + go to 800 +c ********** complex vector ********** + 710 m = na +c ********** last vector component chosen imaginary so that +c eigenvector matrix is triangular ********** + if (dabs(h(en,na)) .le. dabs(h(na,en))) go to 720 + h(na,na) = q / h(en,na) + h(na,en) = -(h(en,en) - p) / h(en,na) + go to 730 +c 720 z3 = cmplx(0.0,-h(na,en)) / cmplx(h(na,na)-p,q) +c h(na,na) = real(z3) +c h(na,en) = aimag(z3) + 720 call dcdiv(z3r,z3i,0.d0,-h(na,en),h(na,na)-p,q) + h(na,na) = z3r + h(na,en) = z3i + 730 h(en,na) = 0.0 + h(en,en) = 1.0 + enm2 = na - 1 + if (enm2 .eq. 0) go to 800 +c ********** for i=en-2 step -1 until 1 do -- ********** + do 790 ii = 1, enm2 + i = na - ii + w = h(i,i) - p + ra = 0.0 + sa = h(i,en) +c + do 760 j = m, na + ra = ra + h(i,j) * h(j,na) + sa = sa + h(i,j) * h(j,en) + 760 continue +c + if (wi(i) .ge. 0.0) go to 770 + zz = w + r = ra + s = sa + go to 790 + 770 m = i + if (wi(i) .ne. 0.0) go to 780 +c z3 = cmplx(-ra,-sa) / cmplx(w,q) +c h(i,na) = real(z3) +c h(i,en) = aimag(z3) + call dcdiv(z3r,z3i,-ra,-sa,w,q) + h(i,na) = z3r + h(i,en) = z3i + go to 790 +c ********** solve complex equations ********** + 780 x = h(i,i+1) + y = h(i+1,i) + vr = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) - q * q + vi = (wr(i) - p) * 2.0 * q + if (vr .eq. 0.0 .and. vi .eq. 0.0) vr = machep * norm + & * (dabs(w) + dabs(q) + dabs(x) + dabs(y) + dabs(zz)) +c z3 = cmplx(x*r-zz*ra+q*sa,x*s-zz*sa-q*ra) / cmplx(vr,vi) +c h(i,na) = real(z3) +c h(i,en) = aimag(z3) + call dcdiv(z3r,z3i,x*r-zz*ra+q*sa,x*s-zz*sa-q*ra,vr,vi) + h(i,na) = z3r + h(i,en) = z3i + if (dabs(x) .le. dabs(zz) + dabs(q)) go to 785 + h(i+1,na) = (-ra - w * h(i,na) + q * h(i,en)) / x + h(i+1,en) = (-sa - w * h(i,en) - q * h(i,na)) / x + go to 790 +c 785 z3 = cmplx(-r-y*h(i,na),-s-y*h(i,en)) / cmplx(zz,q) +c h(i+1,na) = real(z3) +c h(i+1,en) = aimag(z3) + 785 call dcdiv(z3r,z3i,-r-y*h(i,na),-s-y*h(i,en),zz,q) + h(i+1,na) = z3r + h(i+1,en) = z3i + 790 continue +c ********** end complex vector ********** + 800 continue +c ********** end back substitution. +c vectors of isolated roots ********** + do 840 i = 1, n + if (i .ge. low .and. i .le. igh) go to 840 +c + do 820 j = i, n + 820 z(i,j) = h(i,j) +c + 840 continue +c ********** multiply by transformation matrix to give +c vectors of original full matrix. +c for j=n step -1 until low do -- ********** + do 880 jj = low, n + j = n + low - jj + m = min0(j,igh) +c + do 880 i = low, igh + zz = 0.0 +c + do 860 k = low, m + 860 zz = zz + z(i,k) * h(k,j) +c + z(i,j) = zz + 880 continue +c + go to 1001 +c ********** set error -- no convergence to an +c eigenvalue after 30 iterations ********** + 1000 ierr = en + 1001 return +c ********** last card of dhqr2 ********** + end +c +c ****************************************************************** +c + subroutine dorhes(nm,n,low,igh,a,ort) +c implicit none + integer i,j,m,n,ii,jj,la,mp,nm,igh,kp1,low + double precision a(nm,n),ort(igh) + double precision f,g,h,scale +c double precision dsqrt,dabs,dsign +c +c this subroutine is a translation of the algol procedure orthes, +c num. math. 12, 349-368(1968) by martin and wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 339-358(1971). +c +c given a real general matrix, this subroutine +c reduces a submatrix situated in rows and columns +c low through igh to upper hessenberg form by +c orthogonal similarity transformations. +c +c on input- +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement, +c +c n is the order of the matrix, +c +c low and igh are integers determined by the balancing +c subroutine balanc. if balanc has not been used, +c set low=1, igh=n, +c +c a contains the input matrix. +c +c on output- +c +c a contains the hessenberg matrix. information about +c the orthogonal transformations used in the reduction +c is stored in the remaining triangle under the +c hessenberg matrix, +c +c ort contains further information about the transformations. +c only elements low through igh are used. +c +c fortran routine by b. s. garbow +c modified by filippo neri. +c +c + la = igh - 1 + kp1 = low + 1 + if (la .lt. kp1) go to 200 +c + do 180 m = kp1, la + h = 0.0 + ort(m) = 0.0 + scale = 0.0 +c ********** scale column (algol tol then not needed) ********** + do 90 i = m, igh + 90 scale = scale + dabs(a(i,m-1)) +c + if (scale .eq. 0.0) go to 180 + mp = m + igh +c ********** for i=igh step -1 until m do -- ********** + do 100 ii = m, igh + i = mp - ii + ort(i) = a(i,m-1) / scale + h = h + ort(i) * ort(i) + 100 continue +c + g = -dsign(dsqrt(h),ort(m)) + h = h - ort(m) * g + ort(m) = ort(m) - g +c ********** form (i-(u*ut)/h) * a ********** + do 130 j = m, n + f = 0.0 +c ********** for i=igh step -1 until m do -- ********** + do 110 ii = m, igh + i = mp - ii + f = f + ort(i) * a(i,j) + 110 continue +c + f = f / h +c + do 120 i = m, igh + 120 a(i,j) = a(i,j) - f * ort(i) +c + 130 continue +c ********** form (i-(u*ut)/h)*a*(i-(u*ut)/h) ********** + do 160 i = 1, igh + f = 0.0 +c ********** for j=igh step -1 until m do -- ********** + do 140 jj = m, igh + j = mp - jj + f = f + ort(j) * a(i,j) + 140 continue +c + f = f / h +c + do 150 j = m, igh + 150 a(i,j) = a(i,j) - f * ort(j) +c + 160 continue +c + ort(m) = scale * ort(m) + a(m,m-1) = scale * g + 180 continue +c + 200 return +c ********** last card of dorhes ********** + end +c +c ****************************************************************** +c + subroutine dorttr(nm,n,low,igh,a,ort,z) +c +c implicit none + integer i,j,n,kl,mm,mp,nm,igh,low,mp1 + double precision a(nm,igh),ort(igh),z(nm,n) + double precision g +c +c this subroutine is a translation of the algol procedure ortrans, +c num. math. 16, 181-204(1970) by peters and wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 372-395(1971). +c +c this subroutine accumulates the orthogonal similarity +c transformations used in the reduction of a real general +c matrix to upper hessenberg form by dorhes. +c +c on input- +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement, +c +c n is the order of the matrix, +c +c low and igh are integers determined by the balancing +c subroutine balanc. if balanc has not been used, +c set low=1, igh=n, +c +c a contains information about the orthogonal trans- +c formations used in the reduction by orthes +c in its strict lower triangle, +c +c ort contains further information about the trans- +c formations used in the reduction by dorhes. +c only elements low through igh are used. +c +c on output- +c +c z contains the transformation matrix produced in the +c reduction by dorhes, +c +c ort has been altered. +c +c fortran routine by b. s. garbow. +c modified by f. neri. +c +c +c ********** initialize z to identity matrix ********** + do 80 i = 1, n +c + do 60 j = 1, n + 60 z(i,j) = 0.0 +c + z(i,i) = 1.0 + 80 continue +c + kl = igh - low - 1 + if (kl .lt. 1) go to 200 +c ********** for mp=igh-1 step -1 until low+1 do -- ********** + do 140 mm = 1, kl + mp = igh - mm + if (a(mp,mp-1) .eq. 0.0) go to 140 + mp1 = mp + 1 +c + do 100 i = mp1, igh + 100 ort(i) = a(i,mp-1) +c + do 130 j = mp, igh + g = 0.0 +c + do 110 i = mp, igh + 110 g = g + ort(i) * z(i,j) +c ********** divisor below is negative of h formed in orthes. +c double division avoids possible underflow ********** + g = (g / ort(mp)) / a(mp,mp-1) +c + do 120 i = mp, igh + 120 z(i,j) = z(i,j) + g * ort(i) +c + 130 continue +c + 140 continue +c + 200 return +c ********** last card of dorttr ********** + end +c +************************************************************************ +c + subroutine drphse(fm) +c this subroutine readjusts the phases of the eigenvectors making up the +c matrix computed by the subroutine da2 in such a way that fm(1,2)=0 and +c fm(1,1).ge.0, etc. +c Written by Alex Dragt, Fall 1986 + include 'impli.inc' + dimension fm(6,6) + dimension t1m(6,6),t2m(6,6) +c +c clear the matrix t1m + call mclear(t1m) +c compute required phases + arg1=-fm(1,2) + arg2=fm(1,1) + wx=atan2(arg1,arg2) + arg1=-fm(3,4) + arg2=fm(3,3) + wy=atan2(arg1,arg2) + arg1=-fm(5,6) + arg2=fm(5,5) + wt=atan2(arg1,arg2) +c compute rephasing matrix + cwx=cos(wx) + swx=sin(wx) + cwy=cos(wy) + swy=sin(wy) + cwt=cos(wt) + swt=sin(wt) + 10 continue + t1m(1,1)=cwx + t1m(1,2)=swx + t1m(2,1)=-swx + t1m(2,2)=cwx + t1m(3,3)=cwy + t1m(3,4)=swy + t1m(4,3)=-swy + t1m(4,4)=cwy + t1m(5,5)=cwt + t1m(5,6)=swt + t1m(6,5)=-swt + t1m(6,6)=cwt +c rephase fm + call mmult(fm,t1m,t2m) +c check that t2m(1,1).ge.0 etc. + iflag=0 + if (t2m(1,1).lt.0.d0) then + iflag=1 + cwx=-cwx + swx=-swx + endif + if (t2m(3,3).lt.0.d0) then + iflag=1 + cwy=-cwy + swy=-swy + endif + if (t2m(5,5).lt.0.d0) then + iflag=1 + cwt=-cwt + swt=-swt + endif + if (iflag.eq.1) goto 10 + call matmat(t2m,fm) +c + return + end +c +************************************************************************ +c + subroutine dvsort(revec,aievec) +c this is a subroutine that sorts eigenvectors for a dynamic map. +c it also standardizes the magnitudes and signs of the eigenvctors. +c Written by Alex Dragt, Fall 1986 + include 'impli.inc' + dimension revec(6,6),aievec(6,6) + dimension rtv(6,6),aitv(6,6) + dimension r2v(2),ai2v(2) + dimension c(6),kpnt(6) +c store vectors in temporary array + do 10 i=1,5,2 + do 10 j=1,6 + rtv(i,j)=revec(i,j) + aitv(i,j)=aievec(i,j) + 10 continue +c find vertical components of vectors + do 20 i=1,5,2 + r2v(1)=rtv(i,3) + ai2v(1)=aitv(i,3) + r2v(2)=rtv(i,4) + ai2v(2)=aitv(i,4) + sqnrm=r2v(1)**2+ai2v(1)**2+r2v(2)**2+ai2v(2)**2 + c(i)=sqnrm + 20 continue +c find vector with the largest vertical component + kv=1 + big=c(1) + if(c(3).gt.big) big=c(3) + if(c(5).gt.big) big=c(5) + if(big.eq.c(3)) kv=3 + if(big.eq.c(5)) kv=5 +c set pointer + kpnt(3)=kv +c find horizontal components of vectors + do 30 i=1,5,2 + c(i)=0. + if(i.eq.kv) go to 30 + r2v(1)=rtv(i,1) + ai2v(1)=aitv(i,1) + r2v(2)=rtv(i,2) + ai2v(2)=aitv(i,2) + sqnrm=r2v(1)**2+ai2v(1)**2+r2v(2)**2+ai2v(2)**2 + c(i)=sqnrm + 30 continue +c find vector with the largest horizontal component + kh=1 + big=c(1) + if(c(3).gt.big) big=c(3) + if(c(5).gt.big) big=c(5) + if(big.eq.c(3)) kh=3 + if(big.eq.c(5)) kh=5 +c set pointer + kpnt(1)=kh +c find the remaining vector + do 40 i=1,5,2 + if (i.eq.kv) go to 40 + if (i.eq.kh) go to 40 + kt=i + 40 continue +c set pointer + kpnt(5)=kt +c reorder vectors + do 50 i=1,5,2 + k=kpnt(i) + do 60 j=1,6 + revec(i,j)=rtv(k,j) + aievec(i,j)=aitv(k,j) + 60 continue + 50 continue +c standardize magnitudes and signs +c the goal is to maximize revec(1,1), revec(3,3), and revec(5,5) + do 70 i=1,5,2 +c see if u and v should be interchanged + amaxu=abs(revec(i,i)) + amaxv=abs(aievec(i,i)) + if(amaxv.gt.amaxu) then + do 80 j=1,6 + unew=aievec(i,j) + vnew=-revec(i,j) + revec(i,j)=unew + aievec(i,j)=vnew + 80 continue + endif +c see if signs of u and v should be changed + if( revec(i,i) .lt. 0.d0) then + do 90 j=1,6 + revec(i,j)=-revec(i,j) + aievec(i,j)=-aievec(i,j) + 90 continue + endif + 70 continue + return + end +c +*********************************************************************** +c + subroutine egphse(fm) +c this subroutine readjusts the phases of the eigenvectors making up the +c matrix computed by the subroutine da2 in such a way that fm(2,1)=0 and +c fm(1,1).ge.0, etc. Consequently, when fm is transposed, the 1,2 entry +c will be zero, and the 1,1 entry will be .ge. 0, etc. +c Written by Alex Dragt, 5 June 1991 + include 'impli.inc' + dimension fm(6,6) + dimension t1m(6,6),t2m(6,6) +c +c clear the matrix t1m + call mclear(t1m) +c compute required phases + arg1=fm(2,1) + arg2=fm(2,2) + wx=0.d0 + if(arg1 .ne. 0.d0) wx=atan2(arg1,arg2) + arg1=fm(4,3) + arg2=fm(4,4) + wy=0.d0 + if(arg1 .ne. 0.d0) wy=atan2(arg1,arg2) + arg1=fm(6,5) + arg2=fm(6,6) + wt=0.d0 + if(arg1 .ne. 0.d0) wt=atan2(arg1,arg2) +c compute rephasing matrix + cwx=cos(wx) + swx=sin(wx) + cwy=cos(wy) + swy=sin(wy) + cwt=cos(wt) + swt=sin(wt) + 10 continue + t1m(1,1)=cwx + t1m(1,2)=swx + t1m(2,1)=-swx + t1m(2,2)=cwx + t1m(3,3)=cwy + t1m(3,4)=swy + t1m(4,3)=-swy + t1m(4,4)=cwy + t1m(5,5)=cwt + t1m(5,6)=swt + t1m(6,5)=-swt + t1m(6,6)=cwt +c rephase fm + call mmult(fm,t1m,t2m) +c check that t2m(1,1).ge.0 etc. + iflag=0 + if (t2m(1,1).lt.0.d0) then + iflag=1 + cwx=-cwx + swx=-swx + endif + if (t2m(3,3).lt.0.d0) then + iflag=1 + cwy=-cwy + swy=-swy + endif + if (t2m(5,5).lt.0.d0) then + iflag=1 + cwt=-cwt + swt=-swt + endif + if (iflag.eq.1) goto 10 + call matmat(t2m,fm) +c + return + end + +c +************************************************************************ +c + subroutine eig4(fm,reval,aieval,revec,aievec) +c this routine finds the eigenvalues and eigenvectors +c of the 4X4 upper left part of fm. +c the eigenvectors are normalized so that the real and +c imaginary part of vectors 1 and 3 have +1 antisymmetric +c product: +c revec1 J aivec1 = 1 ; revec3 J aivec3 = 1. +c the eigenvector 2 and 4 have the opposite normalization. +c written by F. Neri, Feb 26 1986. +c +c implicit none + integer i,j,ilo,ihi,nn,mdim,info + double precision fm(6,6),reval(6),aieval(6) + double precision revec(6,6),aievec(6,6),pbkt(6) + double precision vv(6,6),ort(6),aa(6,6) +c clear vector arrays + do 10 i=1,6 + do 20 j=1,6 + revec(j,i)=0. + aievec(j,i)=0. + vv(j,i) = 0. + 20 continue + 10 continue + ilo = 1 + ihi = 4 + mdim = 6 + nn = 4 +c copy matrix to temporary storage ( the matrix aa is destroyed). + do 100 i=1,6 + do 200 j=1,6 + aa(j,i) = fm(j,i) + 200 continue + 100 continue +c compute eigenvalues and vectors using double precision +c Eispack routines: + call dorhes(mdim,nn,ilo,ihi,aa,ort) + call dorttr(mdim,nn,ilo,ihi,aa,ort,vv) + call dhqr2(mdim,nn,ilo,ihi,aa,reval,aieval,vv,info) + if ( info .ne. 0 ) then + write(6,*) ' Something wrong in eig4' + return + endif + vv(5,5) = 1.d0 + vv(6,6) = 1.d0 + call neigv(vv,pbkt) + reval(5) = 1.d0 + reval(6) = 1.d0 + aieval(5) = 0.d0 + aieval(6) = 0.d0 + do 300 j=1,4 + revec(1,j) = vv(j,1) + revec(2,j) = vv(j,1) + revec(3,j) = vv(j,3) + revec(4,j) = vv(j,3) + aievec(1,j) = vv(j,2) + aievec(2,j) = -vv(j,2) + aievec(3,j) = vv(j,4) + aievec(4,j) = -vv(j,4) + 300 continue +c if poisson bracket is negative,change sign of imaginary part of +c eigenvalue + do 400 i=2,4,2 + if( pbkt(i) .lt. 0.d0 ) then + aieval(i-1) = -aieval(i-1) + aieval(i) = -aieval(i) + endif + 400 continue + revec(5,5) = 1.d0 + revec(6,6) = 1.d0 +c if eigenvalues are off the unit circle, print warning message: + do 600 i=1,4 + if(dabs(reval(i)**2+aieval(i)**2 - 1.d0).gt.1.d-10) then + write(6,*) ' Eig4: Eigenvalues off the unit circle!' + write(6,*) ' delta=',dabs(reval(i)**2+aieval(i)**2 - 1.d0) + return + endif + 600 continue + return + end +c +******************************************************************** +c + subroutine eig6(fm,reval,aieval,revec,aievec) +c this routine finds the eigenvalues and eigenvectors +c of the full matrix fm. +c the eigenvectors are normalized so that the real and +c imaginary part of vectors 1, 3, and 5 have +1 antisymmetric +c product: +c revec1 J aivec1 = 1 ; revec3 J aivec3 = 1 ; +c revec5 J aivec5 = 1. +c the eigenvectors 2 ,4, and 6 have the opposite normalization. +c written by F. Neri, Feb 26 1986. +c +c implicit none + integer nn + integer nnr,ilo,ihi,mdim,info + double precision reval(6),aieval(6),revec(6,6),aievec(6,6) + double precision fm(6,6),aa(6,6) + integer i,i1,j + double precision ort(6),vv(6,6) + double precision pbkt(6) +c copy matrix to temporary storage (the matrix aa is destroyed) + do 600 i=1,6 + do 600 i1=1,6 + aa(i1,i) = fm(i1,i) + 600 continue + ilo = 1 + ihi = 6 + mdim = 6 + nn = 6 +c compute eigenvalues and eigenvectors using double +c precision Eispack routines: + call dorhes(mdim,nn,ilo,ihi,aa,ort) + call dorttr(mdim,nn,ilo,ihi,aa,ort,vv) + call dhqr2(mdim,nn,ilo,ihi,aa,reval,aieval,vv,info) + if ( info .ne. 0 ) then + write(6,*) ' ERROR IN EIG6' + return + endif + call neigv(vv,pbkt) + do 700 j=1,6 + revec(1,j) = vv(j,1) + revec(2,j) = vv(j,1) + revec(3,j) = vv(j,3) + revec(4,j) = vv(j,3) + revec(5,j) = vv(j,5) + revec(6,j) = vv(j,5) + aievec(1,j) = vv(j,2) + aievec(2,j) = -vv(j,2) + aievec(3,j) = vv(j,4) + aievec(4,j) = -vv(j,4) + aievec(5,j) = vv(j,6) + aievec(6,j) = -vv(j,6) + 700 continue +c if poisson bracket is negative, change sign of imginary part of +c eigenvalue + do 800 i=2,6,2 + if( pbkt(i) .lt. 0.d0) then + aieval(i-1) = -aieval(i-1) + aieval(i ) = -aieval(i ) + endif + 800 continue +c if eigenvalues are off unit circle, print warning message: + do 900 i=1,6 + if(dabs(reval(i)**2+aieval(i)**2 -1.d0).gt.1.d-10) then + write(6,*) ' EIG6: Eigenvalues off the unit circle!' + return + endif + 900 continue + return + end +c +************************************************************************ +c + subroutine eigemt(idim,ha) +c This subroutine computes eigen emittances, etc. +c The array ha contains the incoming moments. +c As described below, rusults are put in buffers 1 through 5. +c This subroutine eventually needs to be improved because at present it +c does not deal properly with the case of degenerate eigenvalues. +c Written by Alex Dragt, 22 May 1991. +c Modified by Alex Dragt, 25 May 1998 to deal with +c phase spaces of various dimensions. +c Again modified 10/14/98 by AJD to change contents of buffers 1 and 2. +c + use lieaparam + include 'impli.inc' + include 'buffer.inc' +c + dimension ha(monoms) +c +c local arrays + dimension t1m(6,6), t2m(6,6) +c +c Case of 2-dimensional phase space +c + if (idim .eq. 2) then +c compute "diagonalizing" matrix and put it in the matrix part of buffer 1. + z11=ha(7) + if(z11 .le. 0.d0) then + write(6,*) 'error: is negative or zero' + return + endif + z12=ha(8) + z22=ha(13) + if(z22 .le. 0.d0) then + write(6,*) 'error: is negative or zero' + return + endif +c remove possibly offensive moments in 2-dimensional case. + do 2 i=7,27 + 2 ha(i)=0.d0 + ha(7)=z11 + ha(8)=z12 + ha(13)=z22 + emit2=z11*z22-z12**2 + if(emit2 .le. 0.d0) then + write(6,*) 'error: x emittance is zero or imaginary' + return + endif + emit=dsqrt(emit2) + beta=z11/emit + rbeta=dsqrt(beta) + alpha=-z12/emit + call mclear(buf1m) + buf1m(1,1)=1.d0/rbeta + buf1m(1,2)=alpha/rbeta + buf1m(2,1)=0.d0 + buf1m(2,2)=rbeta + buf1m(3,3)=1.d0 + buf1m(4,4)=1.d0 + buf1m(5,5)=1.d0 + buf1m(6,6)=1.d0 + go to 100 + endif +c +c Case of 4- and 6-dimensional phase space +c + if ((idim .eq. 4) .or. (idim .eq. 6)) then +c compute "diagonalizing" matrix and put it in the matrix part of buffer 1. +c +c Remove possibly offensive moments in 4-dimensional case. +c + if(idim .eq. 4) then + ha(11)=0.d0 + ha(12)=0.d0 + ha(16)=0.d0 + ha(17)=0.d0 + ha(20)=0.d0 + ha(21)=0.d0 + ha(23)=0.d0 + ha(24)=0.d0 + ha(25)=0.d0 + ha(26)=0.d0 + ha(27)=0.d0 + endif +c +c let Z denote the matrix with entries Zij=. +c compute the polynomial -(1/2)*(z,Zz) and temporarily +c put result in buf2a + do 5 i=7,27 + 5 buf2a(i)=-ha(i) + buf2a(7)=buf2a(7)/2.d0 + buf2a(13)=buf2a(13)/2.d0 + buf2a(18)=buf2a(18)/2.d0 + buf2a(22)=buf2a(22)/2.d0 + buf2a(25)=buf2a(25)/2.d0 + buf2a(27)=buf2a(27)/2.d0 +c +c matify buf2a. this should produce the matrix JZ. + call matify(buf1m,buf2a) +c compute norm of buf1m=JZ. + call mnorm(buf1m,ans) +c compute taylor series result buf2m=exp(scale*buf1m) + scale=.1d0/ans + call smmult(scale,buf1m,buf1m) + call exptay(buf1m,buf2m) +c compute normal form transformation + if (idim .eq. 4) call sa2(buf2m,buf2a,buf1m) + if (idim .eq. 6) call da2(buf2m,buf2a,buf1m) +c + endif !cryne 8/9/2002 + 100 continue +c +c rephase and transpose result + call egphse(buf1m) + call mtran(buf1m) +cryne 8/9/2002 moved endif to before "100 continue" endif +c +c act on moments with "diagonalizing" matrix and put result in buf2a +c letting the map (matrix) act on moments amounts to computing buf2a = D*ha +c +c clear arrays (the array buf2a has already been cleared by da2) +c temporarily use buf3a, buf4a, and buf5a. + do 10 i=1,monoms + buf3a(i)=0.d0 + 10 buf4a(i)=0.d0 +c +c compute "diagonalized" moments only through 2'nd moments + imax=27 +c +c perform calculation + do 20 i=7,imax + buf3a(i)=1.d0 + call fxform(buf4a,buf1m,buf3a,buf5a) + buf3a(i)=0.d0 + do 30 j=1,imax + 30 buf2a(i)=buf2a(i)+buf5a(j)*ha(j) + 20 continue +c +c put result in buf1a + do 40 i=7,monoms + 40 buf1a(i)=buf2a(i) +c +c at this stage buf1m contains the "diagonalizing" matrix. +c put this matrix in buf2m, and put the inverse of the +c diagonalizing matrix in buf1m. + call matmat(buf1m,buf2m) + call inv(buf3a,buf1m) +c +c put original moments in buf2a + do 50 i=7,monoms + 50 buf2a(i)=ha(i) +c +c compute results for buffers 3 through 5 +c need to compute buf1m*diagj*(buf1m transpose) for j=X,Y,Tau, +c and then multiply the result by eigemitj. +c + call matmat(buf1m,t1m) + call mtran(t1m) +c + call mclear(t2m) + t2m(1,1)=1.d0 + t2m(2,2)=1.d0 + call mmult(buf1m,t2m,buf3m) + call mmult(buf3m,t1m,buf3m) + scale=buf1a(7) + call smtof(scale,buf3m,buf3a) +c + call mclear(t2m) + t2m(3,3)=1.d0 + t2m(4,4)=1.d0 + call mmult(buf1m,t2m,buf4m) + call mmult(buf4m,t1m,buf4m) + scale=buf1a(18) + call smtof(scale,buf4m,buf4a) +c + call mclear(t2m) + t2m(5,5)=1.d0 + t2m(6,6)=1.d0 + call mmult(buf1m,t2m,buf5m) + call mmult(buf5m,t1m,buf5m) + scale=buf1a(25) + call smtof(scale,buf5m,buf5a) +c + return + end +c +************************************************************************ +c + subroutine exptay(em,fm) +c this subroutine computes fm=exp(em) using a finite taylor series +c Written by Alex Dragt, Fall 1986, based on work of Liam Healy + include 'impli.inc' + include 'id.inc' + dimension em(6,6),fm(6,6),tm1(6,6),tm2(6,6) +c +c initialize fm and tm1 to be the identity matrix + call matmat(ident,fm) + call matmat(ident,tm1) +c +c begin calculation + kmax=10 + do 10 k=1,kmax + rk=1.d0/float(k) + call mmult(em,tm1,tm2) + call smmult(rk,tm2,tm1) + call madd(fm,tm1,fm) + 10 continue +c + return + end +c +*********************************************************************** +c + subroutine leshs(soln, dim,matrix,rhs,augm,det) +c Linear Equation Solver HandShaking routine. +c Interfaces Etienne's need for linear equation solutions with my +c 'solver'. +c Written by Liam Healy, May 9, 1985. +c +c----Variables---- +c dim = size of linear space + integer dim +c matrix = matrix supplied (dim x dim) +c rhs = right hand side of equation, supplied (dim) +c augm = augmented martrix (dim x dim+1), set up with arbitrary +c contents by calling routine +c det = determinant of original matrix + double precision matrix(dim,dim),rhs(dim),soln(dim),det + double precision augm(dim,dim+1) +c +c----Routine---- + do 120 i=1,dim + do 100 j=1,dim + 100 augm(i,j)=matrix(i,j) + 120 augm(i,dim+1)=rhs(i) + call solver(augm,dim,det) + do 140 i=1,dim + 140 soln(i)=augm(i,dim+1) + return + end +c + subroutine madd(a,b,c) +c This is a subroutine for adding two matrices. +c Written by Alex Dragt on 11 Nov 1985. + double precision a(6,6),b(6,6),c(6,6) + do 10 j=1,6 + do 10 i=1,6 + 10 c(i,j)=a(i,j)+b(i,j) + return + end +c +*********************************************************************** +c + subroutine matmat(a,b) +c This is a subroutine for copying a matrix. +c Written by Alex Dragt on 11 Nov 1985. + double precision a(6,6),b(6,6) +c---Routine--- + do 10 j=1,6 + do 10 i=1,6 + 10 b(i,j)=a(i,j) + return + end +c +*********************************************************************** +c + subroutine mmult(a,b,c) +c This is a subroutine for matrix multiplication. +c Written by Alex Dragt on Friday, 13 Sept 1985. + double precision a(6,6),b(6,6),c(6,6),ct(6,6),sum +c----Routine---- + do 10 k=1,6 + do 20 i=1,6 + sum = 0.d0 + do 30 j=1,6 + sum = sum + a(i,j)*b(j,k) + 30 continue + ct(i,k) = sum + 20 continue + 10 continue + call matmat(ct,c) +c + return + end +c +*********************************************************************** +c + subroutine mnorm(fm,res) +c Computes the norm (maximum column sum norm) for the matrix fm. +c Reference: L. Collatz, Functional Analysis & Numerical Mathematics, +c p.177 +c Written by Alex Dragt, Fall 1986, based on work of Liam Healy + include 'impli.inc' + dimension fm(6,6),sum(6) +c +c initialize variables + res=0.d0 + do 100 j=1,6 + 100 sum(j)=0.d0 +c +c perform calculation + do 120 j=1,6 + do 110 i=1,6 + 110 sum(j)=sum(j)+abs(fm(i,j)) + 120 res=max(res,sum(j)) +c + return + end +c +*********************************************************************** +c + subroutine neigv(m,pbkt) +c this subroutine normalizes the eigenvectors of +c a stable ( all roots on the unit circle ) symplectic +c matrix. on entry m has on the odd numbered colums +c the real part of the eigenvectors, on the even ones +c the imaginary parts. only one real (imaginary ) vector +c is included of each complex conjugate pair. +c on exit the vectors are rescaled so that the poisson +c brackets of the real x imaginary parts are equal to 1. +c also, the real and imaginary parts of each eigenvector +c are made orthogonal. +c the resulting matrix is symplectic. when used in sa2 or da2, +c it tranforms +c the original matrix to block diagonal form, with the +c blocks being 2 dimensional rotations. +c WARNING: this only works if the eigenvalues are on +c the unit circle. +c written by F. Neri Feb 10 1986. +c implicit none + integer n + parameter ( n = 3 ) + double precision m(2*n,2*n),pbkt(2*n) + double precision pb,s + double precision usq,vsq,udotv,a,b,phi(6),sn,cn,unew,vnew + integer k,iq,ip,i,j +c rescale u and v + do 10 k=1,5,2 + pb = 0.d0 + do 20 ip = 2,2*n,2 + iq = ip-1 + pb = pb + m(iq,k)*m(ip,k+1) - m(ip,k)*m(iq,k+1) + 20 continue + s = dsqrt(dabs(pb)) +c write(6,*) ' PB=',pb + pbkt(k) = pb + pbkt(k+1)=pb + do 30 i=1,2*n + m(i,k) = m(i,k)/s + m(i,k+1) = m(i,k+1)*(s/pb) + 30 continue + 10 continue +c orthogonalize u and v +c compute required phase + do 40 k=1,5,2 + usq=0.d0 + vsq=0.d0 + udotv=0.d0 + do 50 j=1,6 + usq=usq+m(j,k)**2 + vsq=vsq+m(j,k+1)**2 + udotv=udotv+m(j,k)*m(j,k+1) + 50 continue + phi(k)=0.d0 + a=udotv + if(a.eq.0.d0) goto 40 + b=(usq-vsq)/2.d0 + phi(k)=(1/2.d0)*atan2(-a,b) + 40 continue +c transform u and v + do 60 k=1,5,2 + sn=sin(phi(k)) + cn=cos(phi(k)) + do 70 j=1,6 + unew=cn*m(j,k)-sn*m(j,k+1) + vnew=sn*m(j,k)+cn*m(j,k+1) + m(j,k)=unew + m(j,k+1)=vnew + 70 continue + 60 continue + return + end +c end of file + subroutine pmadd(f,n,coeff,h) + implicit double precision (a-h,o-z) + include 'len.inc' + dimension f(923),h(923) + if(n.eq.1)then + istart=1 + else + istart=len(n-1)+1 + endif +c + if(coeff.eq.1.d0) goto 20 +cryne do 10 i=len(n-1)+1,len(n) + do 10 i=istart,len(n) + h(i) = h(i) + f(i)*coeff + 10 continue + return + 20 continue +cryne do 30 i = len(n-1)+1, len(n) + do 30 i = istart, len(n) + h(i) = h(i) + f(i) + 30 continue + return + end +c + subroutine product(a,na,b,nb,c) + use lieaparam, only : monoms + implicit double precision(a-h,o-z) + include 'len.inc' + include 'expon.inc' + include 'vblist.inc' +cryne 7/23/2002 common/expon/expon +cryne 7/23/2002 common/vblist/vblist +cryne 7/23/2002 common /len/ len(16) +cryne 7/23/2002 integer expon(6,0:923),vblist(6,0:923) + dimension a(923),b(923),c(923),l(6) + if(na.eq.1) then + ia1 = 1 + else + ia1 = len(na-1)+1 + endif + if(nb.eq.1) then + ib1 = 1 + else + ib1 = len(nb-1)+1 + endif + do 200 ia=ia1,len(na) + if(a(ia).eq.0.d0) goto 200 + do 20 ib = ib1,len(nb) + if(b(ib).eq.0.d0) goto 20 + do 2 m=1,6 + l(m) = expon(m,ia) + expon(m,ib) + 2 continue + n = ndex(l) + c(n) = c(n) + a(ia)*b(ib) + 20 continue + 200 continue + return + end +c +******************************************************************** +c + subroutine pttodp(f,ft) +c +c This subroutine converts a power series in the variable Ptau +c (which is the negative of the normalized energy deviation) to a power +c series in the normalized momentum deviation [deltap=(delta p)/p]. +c This routine works through third order. +c Reference: A. Dragt and M. Venturini, Relation between Expansions +c in Energy and Momentum Deviation Variables, U.MD. Physics Dept. +c Technical Report (1995). +c Written in Sept. 1995 by A. Dragt and M. Venturini +c +c f is an aray containing the coefficients of the power +c series in terms of the variable Ptau. +c ft is a transformed aray that contains the coefficients +c of the transformed power series in terms of the variable deltap. +c The transformation uses the matrix a(i,j). +c + use beamdata + include 'impli.inc' + dimension f(*), ft(*) + dimension a(3,3) +c +c Set up transforming coefficients +c + beta2=beta*beta + beta3=beta2*beta + beta4=beta2*beta2 + beta5=beta2*beta3 +c + a(1,1)= -beta + a(2,1)=(-beta + beta3)/(2.d0) + a(2,2)= beta2 + a(3,1)=( beta3 - beta5)/(2.d0) + a(3,2)= beta2 - beta4 + a(3,3)= -beta3 +c +c Make transformation +c + ft(1)=a(1,1)*f(1) + ft(2)=a(2,1)*f(1) + a(2,2)*f(2) + ft(3)=a(3,1)*f(1) + a(3,2)*f(2) + a(3,3)*f(3) +c + return + end +c +******************************************************************* +c + subroutine seig6(fm,reval,revec) +c this routine finds the eigenvalues and eigenvectors +c of a real symmetric 6x6 matrix +c the eigenvectors are normalized so that related pairs (those +c with eigenvalues eval and 1/eval) have antisymmetric product: +c revec1 J revec2 = 1 ; revec3 J revec4 = 1 ; +c revec5 J revec6 = 1. +c further details about normalization and ordering +c conventions may be gleaned from examination of the code +c written by A. Dragt 20 March 1987 +c + include 'impli.inc' + dimension fm(6,6),reval(6),revec(6,6) + dimension aieval(6),ort(6),pbkt(6) + dimension tm(6,6),vv(6,6) +c +c begin computation +c +c copy matrix to temporary storage (the matrix tm is destroyed) + call matmat(fm,tm) +c +c set up control indices + ilo = 1 + ihi = 6 + mdim = 6 + nn = 6 +c +c compute eigenvalues and eigenvectors using double +c precision Eispack routines: + call dorhes(mdim,nn,ilo,ihi,tm,ort) + call dorttr(mdim,nn,ilo,ihi,tm,ort,vv) + call dhqr2(mdim,nn,ilo,ihi,tm,reval,aieval,vv,info) + if ( info .ne. 0 ) then + write(6,*) ' Error in seig6 from Eispack routines ' + return + endif +c +c sort eigenvalues and eigenvectors into related pairs +c +c normalize eigenvectors to have unit Euclidean norm + do 10 i=1,6 + vsq=0.d0 + do 20 j=1,6 + vsq=vsq+vv(j,i)**2 + 20 continue + rv=1.d0/sqrt(vsq) + do 30 k=1,6 + revec(k,i)=rv*vv(k,i) + 30 continue + 10 continue +c find largest eigenvalue + big=0.d0 + do 40 i=1,6 + if (reval(i).gt.big) then + big=reval(i) + imax1=i + endif + 40 continue +c find its reciprocal pair based on symplectic 2-form J + big=0.d0 + do 50 i=1,6 + if (i.eq.imax1) goto 50 + call s2f(revec,imax1,i,val) + aval=abs(val) + if (aval.gt.big) then + big=aval + imax1r=i + endif + 50 continue +c find second largest eigenvalue + big=0.d0 + do 60 i=1,6 + if (i.eq.imax1 .or. i.eq.imax1r) goto 60 + if (reval(i).gt.big) then + big=reval(i) + imax2=i + endif + 60 continue +c find its reciprocal pair based on symplectic 2-form J + big=0.d0 + do 70 i=1,6 + if (i.eq.imax1 .or. i.eq.imax1r .or. i.eq.imax2) goto 70 + call s2f(revec,imax2,i,val) + aval=abs(val) + if (aval.gt.big) then + big=aval + imax2r=i + endif + 70 continue +c find third largest eigenvalue + big=0.d0 + do 80 i=1,6 + if (i.eq.imax1 .or. i.eq.imax1r) goto 80 + if (i.eq.imax2 .or. i.eq.imax2r) goto 80 + if (reval(i).gt.big) then + big=reval(i) + imax3=i + endif + 80 continue +c find its reciprocal pair by elimination + do 90 i=1,6 + if (i.eq.imax1 .or. i.eq.imax1r) goto 90 + if (i.eq.imax2 .or. i.eq.imax2r) goto 90 + if (i.eq.imax3) goto 90 + imax3r=i + 90 continue +c +c renormalize eigenvectors + call s2f(revec,imax1,imax1r,prd) + aprod=abs(prd) + sign=1.d0 + if (prd.lt.0.d0) sign=-1.d0 + rfact=1.d0/sqrt(aprod) + do 100 i=1,6 + vv(i,imax1)=rfact*revec(i,imax1) + vv(i,imax1r)=sign*rfact*revec(i,imax1r) + 100 continue + call s2f(revec,imax2,imax2r,prd) + aprod=abs(prd) + sign=1.d0 + if (prd.lt.0.d0) sign=-1.d0 + rfact=1.d0/sqrt(aprod) + do 110 i=1,6 + vv(i,imax2)=rfact*revec(i,imax2) + vv(i,imax2r)=sign*rfact*revec(i,imax2r) + 110 continue + call s2f(revec,imax3,imax3r,prd) + aprod=abs(prd) + sign=1.d0 + if (prd.lt.0.d0) sign=-1.d0 + rfact=1.d0/sqrt(aprod) + do 120 i=1,6 + vv(i,imax3)=rfact*revec(i,imax3) + vv(i,imax3r)=sign*rfact*revec(i,imax3r) + 120 continue +c +c rearrange eigenvectors + do 130 i=1,6 + revec(i,1)=vv(i,imax1) + revec(i,2)=vv(i,imax1r) + revec(i,3)=vv(i,imax2) + revec(i,4)=vv(i,imax2r) + revec(i,5)=vv(i,imax3) + revec(i,6)=vv(i,imax3r) + 130 continue +c +c rearrange eigenvalues + do 140 i=1,6 + aieval(i)=reval(i) + 140 continue + reval(1)=aieval(imax1) + reval(2)=aieval(imax1r) + reval(3)=aieval(imax2) + reval(4)=aieval(imax2r) + reval(5)=aieval(imax3) + reval(6)=aieval(imax3r) +c + return + end +c +*********************************************************************** +c + subroutine smmult(s,a,b) +c This is a subroutine for multiplying a matrix by a scalar. +c Written by Alex Dragt on 11 Nov 1985. + double precision s,a(6,6),b(6,6) +c---Routine--- + do 10 j=1,6 + do 10 i=1,6 + 10 b(i,j)=s*a(i,j) + return + end +c +*********************************************************************** +c + subroutine solver(augmat,dim,det) +c Solves the linear equation +c m*a = b +c where m is n by n +c On entry : augmat = m augmented by b +c dim = n +c On return: matrix = identity augmented by a +c det = determinant of m +c Coded from a routine originally written for the HP41C calculator +c (Dearing, p.46). Written by Liam Healy, February 14, 1985. +c +c----Variables---- +c dim= dimension of matrix + integer dim +c matrix= input matrix m, vector = input and output vector + double precision augmat(dim,dim+1) +c det = determinant returned + double precision det +c row,col,r,c,roff,rs = row and column numbers, row and column indices, +c row offset, row number for finding max + integer row,col,r,c,roff,rs +c nrow,ncol = total number of rows and columns + integer nrow,ncol +c me, mer, h = matrix element and its row number, held value of mat elt +c const = constant used in multiplication + double precision me,h,const + integer mer +c +c----Routine---- + det=1. + nrow=dim + ncol=dim+1 + col=0 + do 100 row=1,nrow + 300 col=col+1 + if (col.le.ncol) then +c find max of abs of mat elts in this col, and its row number + me=0. + mer=0 + do 120 rs=row,nrow + if (abs(augmat(rs,col)).ge.abs(me)) then + me=augmat(rs,col) + mer=rs + endif + 120 continue + det=det*me + if (me.eq.0.) goto 300 + do 140 c=1,ncol + augmat(mer,c)=augmat(mer,c)/me + 140 continue + r=0 + if (mer.ne.row) then +c swap the rows + do 160 c=1,ncol + h=augmat(mer,c) + augmat(mer,c)=augmat(row,c) + augmat(row,c)=h + 160 continue + det=-det + endif + 320 r=r+1 + if (r.le.nrow.and.row.lt.nrow) then + if (r.eq.row) goto 320 +c multiply row row by const & subtract from row r + const=augmat(r,col) + do 180 c=1,ncol + augmat(r,c)=augmat(r,c)-augmat(row,c)*const + 180 continue + goto 320 + endif + endif + 100 continue +c +c Matrix is now in upper triangular form. +c To solve equation, must get it to the identity. + do 200 roff=nrow,1,-1 + do 200 row=roff-1,1,-1 + const=augmat(row,roff) + do 200 c=row,ncol + augmat(row,c)=augmat(row,c)-const*augmat(roff,c) + 200 continue + return + end +c +************************************************************************ +c + subroutine srphse(fm) +c this subroutine readjusts the phases of the eigenvectors making up the +c matrix computed by the subroutine sa2 in such a way that fm(1,2)=0 and +c fm(1,1).ge.0, etc. +c Written by Alex Dragt, Fall 1986 + include 'impli.inc' + dimension fm(6,6) + dimension t1m(6,6),t2m(6,6) +c +c clear the matrix t1m + call mclear(t1m) +c compute required phases + arg1=-fm(1,2) + arg2=fm(1,1) + wx=atan2(arg1,arg2) + arg1=-fm(3,4) + arg2=fm(3,3) + wy=atan2(arg1,arg2) +c compute rephasing matrix + cwx=cos(wx) + swx=sin(wx) + cwy=cos(wy) + swy=sin(wy) + 10 continue + t1m(1,1)=cwx + t1m(1,2)=swx + t1m(2,1)=-swx + t1m(2,2)=cwx + t1m(3,3)=cwy + t1m(3,4)=swy + t1m(4,3)=-swy + t1m(4,4)=cwy + t1m(5,5)=1.d0 + t1m(6,6)=1.d0 +c rephase fm + call mmult(fm,t1m,t2m) +c check that t2m(1,1).ge.0 etc. + iflag=0 + if (t2m(1,1).lt.0.d0) then + iflag=1 + cwx=-cwx + swx=-swx + endif + if (t2m(3,3).lt.0.d0) then + iflag=1 + cwy=-cwy + swy=-swy + endif + if (iflag.eq.1) goto 10 + call matmat(t2m,fm) +c + return + end +c +*********************************************************************** +c + subroutine svsort(revec,aievec) +c this is a subroutine that sorts eigenvectors for a static map. +c it also standardizes the magnitudes and signs of the eigenvectors. +c Written by Alex Dragt, Fall 1986 + include 'impli.inc' + dimension revec(6,6),aievec(6,6) + dimension rtv(6,6),aitv(6,6) + dimension r2v(2),ai2v(2) + dimension c(6),kpnt(6) +c store vectors in temporary array + do 10 i=1,3,2 + do 10 j=1,6 + rtv(i,j)=revec(i,j) + aitv(i,j)=aievec(i,j) + 10 continue +c find vertical components of vectors + do 20 i=1,3,2 + r2v(1)=rtv(i,3) + ai2v(1)=aitv(i,3) + r2v(2)=rtv(i,4) + ai2v(2)=aitv(i,4) + sqnrm=r2v(1)**2+ai2v(1)**2+r2v(2)**2+ai2v(2)**2 + c(i)=sqnrm + 20 continue +c find vector with the largest vertical component + kv=1 + big=c(1) + if(c(3).gt.big) kv=3 +c set pointer + kpnt(3)=kv +c find the remaining vector + do 30 i=1,3,2 + if (i.eq.kv) go to 30 + kh=i + 30 continue +c set pointer + kpnt(1)=kh +c reorder vectors + do 40 i=1,3,2 + k=kpnt(i) + do 50 j=1,6 + revec(i,j)=rtv(k,j) + aievec(i,j)=aitv(k,j) + 50 continue + 40 continue +c standardize magnitudes and signs +c the goal is to maximize revec(1,1) and revec(3,3) + do 60 i=1,3,2 +c see if u and v should be interchanged + amaxu=abs(revec(i,i)) + amaxv=abs(aievec(i,i)) + if(amaxv.gt.amaxu) then + do 70 j=1,6 + unew=aievec(i,j) + vnew=-revec(i,j) + revec(i,j)=unew + aievec(i,j)=vnew + 70 continue + endif +c see if signs of u and v should be changed + if( revec(i,i) .lt. 0.d0) then + do 80 j=1,6 + revec(i,j)=-revec(i,j) + aievec(i,j)=-aievec(i,j) + 80 continue + endif + 60 continue + return + end +c +************************************************************************ +c + subroutine sympl1(fm) + include 'impli.inc' + dimension fm(6,6) + return + end +c +************************************************************************ +c + subroutine sympl2(fm) + include 'impli.inc' + dimension fm(6,6) + return + end +c +*********************************************************** +c +c SYMPL3 +c +c********************************************************** +c +c Written by F. Neri Feb 7 1986 +c + subroutine sympl3(m) +c implicit none + integer n + parameter ( n = 3 ) + double precision m(2*n,2*n) +c +c On return ,the matrix m(*,*), supposed to be almost +c symplectic on entry is made exactly symplectic by +c using a non iterative, constructive method. +c + double precision qq,pq,qp,pp + integer kp,kq,lp,lq,jp,jq,i +c + do 100 kp=2,2*n,2 + kq = kp-1 + do 200 lp=2,kp-2,2 + lq = lp-1 + qq = 0.d0 + pq = 0.d0 + qp = 0.d0 + pp = 0.d0 + do 300 jp=2,2*n,2 + jq = jp-1 + qq = qq + m(lq,jq)*m(kq,jp) - m(lq,jp)*m(kq,jq) + pq = pq + m(lp,jq)*m(kq,jp) - m(lp,jp)*m(kq,jq) + qp = qp + m(lq,jq)*m(kp,jp) - m(lq,jp)*m(kp,jq) + pp = pp + m(lp,jq)*m(kp,jp) - m(lp,jp)*m(kp,jq) + 300 continue +c write(6,*) qq,pq,qp,pp + do 400 i=1,2*n + m(kq,i) = m(kq,i) - qq*m(lp,i) + pq*m(lq,i) + m(kp,i) = m(kp,i) - qp*m(lp,i) + pp*m(lq,i) + 400 continue + 200 continue + qp = 0.d0 + do 500 jp=2,2*n,2 + jq = jp-1 + qp = qp + m(kq,jq)*m(kp,jp) - m(kq,jp)*m(kp,jq) + 500 continue +c write(6,*) qp + do 600 i=1,2*n + m(kp,i) = m(kp,i)/qp + 600 continue +c +c Maybe the following is a better idea ( uses sqrt and is slower ) +c sign = 1.d0 +c if ( qp.lt.0.d0 ) sign = -1.d0 +c OR, BETTER: +c if ( qp.le.0.d0 ) then complain +c qp = dabs(qp) +c qp = dsqrt(qp) +c do 600 i=1,2*n +c m(kq,i) = m(kq,i)/qp +c m(kp,i) = sign*m(kp,i)/qp +c 600 continue + 100 continue + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/meri.f b/OpticsJan2020/MLI_light_optics/Src/meri.f new file mode 100644 index 0000000..27933bc --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/meri.f @@ -0,0 +1,793 @@ +************************************************************************ +* header MERIT FUNCTIONS +* Weighted sum of sqares and user specified merit functions +*********************************************************************** +c + subroutine mrt0(pp) +c +c This is the weighted sum of squares or the square root of +c weighted sum of squares merit function defined by aims for +c loop pp(2). +c +c T. Mottershead, LANL Feb 89; A. Dragt 7/10/98 +c----------------------------------------------------- + include 'impli.inc' + include 'merit.inc' +c + dimension pp(*) +c +c gather the computed function values +c + kind = nint(pp(1)) + loon = nint(pp(2)) +c write(6,*) 'in mrt0' + temp = rmserr(loon) + if (kind .eq. 1) fval = temp**2 + if (kind .eq. 2) fval = temp + val(0) = fval +c + return + end +c +***************************************************************** +c + subroutine mrt1(p) +c + include 'impli.inc' + include 'merit.inc' + common/count/ifcnt,igcnt,ihcnt +c +c Calling arrays: + dimension p(6) +c +c Local arrays: + dimension c(10), a(10), b(10) +c + write(6,*) 'in mrt1' + ifcnt=ifcnt+1 +c + fcn = 0.d0 + n=6 + kc = n/2 + do 10 i= 1,n + c(i) = i-kc + a(i) = 2 + mod(i,3) + b(i) = mod(i,kc) + next = 1 + mod(i,n) + fcn = fcn + a(i)*(p(i) + b(i)*p(next)- c(i))**2 + 10 continue + val(1) = fcn + return + end +c +************************************************************************ +c + subroutine mrt2(p) +c + include 'impli.inc' + include 'merit.inc' + include 'parset.inc' + include 'usrdat.inc' +c +c Calling arrays: + dimension p(6) +c +c set up sum of squares merit function based +c on contents of ucalc +c +c get strengths of octupole components of cfqds + res1=ucalc(1) + res2=ucalc(2) + res3=ucalc(3) +c get strengths of remaining octupoles + res4=ucalc(4) + res5=ucalc(5) + res6=ucalc(6) + res7=ucalc(7) +c form sum of squares of cfqds octupole strengths + sscf=res1**2 + res2**2 + res3**2 +c form sum of squares of remaining octupole strengths + sso=res4**2 + res5**2 + res6**2 + res7**2 +c form full sum of squares + sst = sscf + sso +c divide by 7 (the number of octupoles) + wss = sst/7.d0 +c square root and square result + rwssq = sqrt(wss) + wss = rwssq**2 +c assign value + val(2)=wss +c + return + end +c +************************************************************************ +c + subroutine mrt3(p) +c + include 'impli.inc' + include 'merit.inc' +c +c Calling arrays: + dimension p(6) + write(6,*) 'in mrt3' + val(3)=p(3) + return + end +c +************************************************************************ +c + subroutine mrt4(p) +c + include 'impli.inc' + include 'merit.inc' +c +c Calling arrays: + dimension p(6) + write(6,*) 'in mrt4' + val(4)=p(4) + return + end +c +************************************************************************ +c + subroutine mrt5(p) +c +c provides standard set of optimization test problems +c C. T. Mottershead LANL AT-3 19 Mar 93 +c------------------------------------------------------------ + include 'impli.inc' + include 'merit.inc' + include 'parset.inc' +c +c Calling arrays: + dimension p(6), xv(6) +c write(6,*) 'in mrt5' + mode = nint(p(1)) + numf = nint(p(2)) + nvar = nint(p(3)) + npset = nint(p(4)) + if((npset.lt.1).or.(npset.gt.maxpst)) then + write(6,*) ' *** mrt5 error:' + write(6,*) npset,' is not a valid parameter set' + return + endif + isend = nint(p(5)) + do 20 j = 1, nvar + xv(j) = pst(j,npset) + 20 continue + call optest(mode, numf, nvar, xv, fval) + val(5) = fval + return + end +c +c end of file + subroutine optest(mode,numf,nv,xv,fv) +c +c selects and evaluates at (xv(i), i=1,nv) test function number numf +c from the standard suite from R. Schnabel, U. Colo +c C. T. Mottershead AT-3 19 Mar 93 +c------------------------------------------------- + implicit double precision (a-h,o-z) + character*24 remark(20), title + character*6 fcname(20) + dimension maxvar(20), xv(*) + external fcn03,fcn04,fcn05,fcn07,fcn09,fcn12,fcn14 + *, fcn16,fcn18,fcn20,fcn21,fcn22,fcn23,fcn24,fcn25 + *, fcn26,fcn35,fcn36,fcn37,fcn38 + data maxvar /3*2,3*3,2*4,11*6,4/, ndone /0/ + if(ndone.eq.0) call fcnlbl(num,remark,fcname) + ndone = 1 +c +c list available test functions +c + if(mode.eq.1) then + write(6,*) num,' test functions available' + kpr = (num + 1)/2 + do 20 k=1,kpr + k2 = k+kpr + write(6,27) k, fcname(k), remark(k), k2, fcname(k2), remark(k2) + 27 format(2(i4,'= ',a6,': ',a24)) + 20 continue + go to 80 + endif +c +c evaluate selected function +c + if((numf.le.0).or.(numf.gt.20)) go to 77 + title = remark(numf) + if(nv.gt.maxvar(numf)) nv=maxvar(numf) + write(6,51) nv,numf,title + 51 format(i5,' variables in test function',i3,': ',a) + go to (61,62,63,64,65,66,67,68,69,70,71,72,73,24,25,26,35,36 + * ,37,38), numf + 61 call fcn03(nv, xv, fv) + go to 80 + 62 call fcn04(nv, xv, fv) + go to 80 + 63 call fcn05(nv, xv, fv) + go to 80 + 64 call fcn07(nv, xv, fv) + go to 80 + 65 call fcn09(nv, xv, fv) + go to 80 + 66 call fcn12(nv, xv, fv) + go to 80 + 67 call fcn14(nv, xv, fv) + go to 80 + 68 call fcn16(nv, xv, fv) + go to 80 + 69 call fcn18(nv, xv, fv) + go to 80 + 70 call fcn20(nv, xv, fv) + go to 80 + 71 call fcn21(nv, xv, fv) + go to 80 + 72 call fcn22(nv, xv, fv) + go to 80 + 73 call fcn23(nv, xv, fv) + go to 80 + 24 call fcn24(nv, xv, fv) + go to 80 + 25 call fcn25(nv, xv, fv) + go to 80 + 26 call fcn26(nv, xv, fv) + go to 80 + 35 call fcn35(nv, xv, fv) + go to 80 + 36 call fcn36(nv, xv, fv) + go to 80 + 37 call fcn37(nv, xv, fv) + go to 80 + 38 call fcn38(nv, xv, fv) + 80 return + 77 write(6,*) numf, ' = invalid function number' + return + end +c +cccccccccccccccccccccccccc fcnlbl ccccccccccccccccccccccccccccccccccc +c + subroutine fcnlbl(num,remark,fcname) + character*24 remark(*) + character*6 fcname(*) + num = 0 +c + num = num + 1 + remark(num) = 'POWELLS BADLY SCALED' + fcname(num) = 'FCN03' +c + num = num + 1 + remark(num) = 'BROWN BADLY SCALED' + fcname(num) = 'FCN04' +c + num = num + 1 + remark(num) = 'BEALE' + fcname(num) = 'FCN05' +c + num = num + 1 + remark(num) = 'HELICAL VALLEY' + fcname(num) = 'FCN07' +c + num = num + 1 + remark(num) = 'GAUSSIAN' + fcname(num) = 'FCN09' +c + num = num + 1 + remark(num) = 'BOX 3D' + fcname(num) = 'FCN12' +c + num = num + 1 + remark(num) = 'WOOD' + fcname(num) = 'FCN14' +c + num = num + 1 + remark(num) = 'BROWN-DENNIS' + fcname(num) = 'FCN16' +c + num = num + 1 + remark(num) = 'BIGGS EXP' + fcname(num) = 'FCN18' +c + num = num + 1 + remark(num) = 'WATSON' + fcname(num) = 'FCN20' +c + num = num + 1 + remark(num) = 'ROSENBROCK BANANA VALLEY' + fcname(num) = 'FCN21' +c + num = num + 1 + remark(num) = 'POWELL SINGULAR' + fcname(num) = 'FCN22' +c + num = num + 1 + remark(num) = 'PENALTY I' + fcname(num) = 'FCN23' +c + num = num + 1 + remark(num) = 'PENALTY II' + fcname(num) = 'FCN24' +c + num = num + 1 + remark(num) = 'VARIABLE DIMENSION' + fcname(num) = 'FCN25' +c + num = num + 1 + remark(num) = 'TRIGONOMETRIC' + fcname(num) = 'FCN26' +c + num = num + 1 + remark(num) = 'CHEBYQUAD' + fcname(num) = 'FCN35' +c + num = num + 1 + remark(num) = 'ROSENBROCK BADLY SCALED' + fcname(num) = 'FCN36' +c + num = num + 1 + remark(num) = 'QUADRATIC FORM' + fcname(num) = 'FCN37' +c + num = num + 1 + remark(num) = 'BERZ' + fcname(num) = 'FCN38' + return + end +c +cccccccccccccccccccccccc powell bad scale cccccccccccccccccccccccccc +c + subroutine fcn03(n,x,f) + implicit double precision (a-h, o-z) +c +c powell"s badly scaled function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + f=(1.d4*x(1)*x(2)-1.d0)**2 + (exp(-x(1))+exp(-x(2))-1.0001d0)**2 + return + end +c +ccccccccccccccccccccccc brown bad scale ccccccccccccccccccc +c + subroutine fcn04(n,x,f) + implicit double precision (a-h, o-z) +c +c brown badly scaled function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + f=(x(1)-1.d6)**2 + (x(2)-2.d-6)**2 + (x(1)*x(2)-2.d0)**2 + return + end +c +cccccccccccccccccccccccccccccccc beale ccccccccccccccccccccccccc +c + subroutine fcn05(n,x,f) + implicit double precision (a-h, o-z) +c +c beale function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + f=(1.5d0-1.0d0*x(1)*(1.d0-1.0d0*x(2)))**2 + + + (2.25d0 -1.0d0*x(1)*(1.d0-1.0d0*x(2)*x(2)))**2 + + + (2.625d0-1.0d0*x(1)*(1.d0-1.d0*x(2)*x(2)*x(2)))**2 + return + end +c +ccccccccccccccccccccccccc helical valley cccccccccccccccccccccc +c + subroutine fcn07(n,x,f) + implicit double precision (a-h, o-z) +c +c helical valley function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 +c pi=3.1415926535898 + pi=3.1415926535897931d0 + if(x(1).gt. 0.d0) th= (1.d0/(2.d0*pi)) * atan(x(2)/x(1)) + if(x(1).lt. 0.d0) th= (1.d0/(2.d0*pi)) * atan(x(2)/x(1))+0.5d0 + f=100.d0*(x(3)-10.d0*th)**2 + + +100.d0*(sqrt(x(1)**2 + x(2)**2)-1.d0)**2 + + + x(3)*x(3) + return + end +c +cccccccccccccccccccccc odd gaussian cccccccccccccccccccccccccc +c + subroutine fcn09(n,x,f) + implicit double precision (a-h, o-z) +c +c gaussian function +c + dimension x(n),y(15) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + y(1)=.0009d0 + y(2)=.0044d0 + y(3)=.0175d0 + y(4)=.0540d0 + y(5)=.1295d0 + y(6)=.2420d0 + y(7)=.3521d0 + y(8)=.3989d0 + y(9)= y(7) + y(10)=y(6) + y(11)=y(5) + y(12)=y(4) + y(13)=y(3) + y(14)=y(2) + y(15)=y(1) + g=0.d0 + do 10 i=1,15 + g=g + (x(1)*exp( -x(2)*((8.d0-i)/2.d0-x(3))**2/2.d0) - y(i))**2 + 10 continue + f=g + return + end +c +ccccccccccccccccccccccccccc 3D box ccccccccccccccccccccccc +c + subroutine fcn12(n,x,f) + implicit double precision (a-h, o-z) +c +c box 3-dimensional function(n,x,f) +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + g=0.d0 + do 10 i=1,n + t=i/10.d0 + g=g + (exp(-t*x(1)) - exp(-t*x(2)) + + - x(3)*(exp(-t)-exp(-10.d0*t)))**2 + 10 continue + f=g + return + end +c +ccccccccccccccccccccccccccc wood cccccccccccccccccccccccccccc +c + subroutine fcn14(n,x,f) + implicit double precision (a-h, o-z) +c +c wood function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + f=100.d0*(x(2)-x(1)*x(1))**2 + (1.d0-x(1))**2 + + + 90.d0*(x(4)-x(3)*x(3))**2 + (1.d0-x(3))**2 + + +10.1d0*( (1.d0-x(2))**2 + (1.d0-x(4))**2) + + +19.8d0*(1.d0-x(2))*(1.d0-x(4)) + return + end +c +cccccccccccccccccccccccccc brown-dennis cccccccccccccccccccccccccccc +c + subroutine fcn16(n,x,f) + implicit double precision (a-h, o-z) +c +c brown + dennis function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + g=0.d0 + do 10 i=1,20 + t=i/5.d0 + g=g + ((x(1)+t*x(2)-exp(t))**2 + + + (x(3)+x(4)*sin(t)-cos(t))**2 )**2 + 10 continue + f=g + return + end +c +ccccccccccccccccccccccccc biggs exp6 cccccccccccccccccccccccc +c + subroutine fcn18(n,x,f) + implicit double precision (a-h, o-z) +c +c biggs exp6 function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + g=0.d0 + do 10 i=1,13 + t=i/10.d0 + g=g + (x(3)*exp(-t*x(1))-x(4)*exp(-t*x(2)) + + + x(6)*exp(-t*x(5))-exp(-t)+5.d0*exp(-10.d0*t) + + - 3.d0*exp(-4.d0*t) )**2 + 10 continue + f=g + return + end +c +ccccccccccccccccccccccccc watson cccccccccccccccccccccccccccccc +c + subroutine fcn20(n,x,f) + implicit double precision (a-h, o-z) +c +c watson function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + g=0.d0 + do 40 i=1,29 + t=i/29.d0 + sum=0.d0 + s=1.d0 + do 20 j=2,n + sum=sum + (j-1)*x(j)*s + s=t*s + 20 continue + sum2=0.d0 + s=1.d0 + do 30 j=1,n + sum2=sum2 + x(j)*s + s=t*s + 30 continue + g=g + (sum - sum2*sum2 - 1.d0)**2 + 40 continue + g=g + x(1)*x(1) + (x(2)-x(1)**2-1.d0)**2 + f=g + return + end +c +ccccccccccccccccccccccc extended rosenbrock cccccccccccccccccccccc +c + subroutine fcn21(n,x,f) + implicit double precision (a-h, o-z) +c +c extended rosenbrock function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + g=0.d0 + j=n/2 + do 10 i=1,j + g=g+ 100.d0*(x(2*i)- x(2*i-1)**2)**2 + (1.d0-x(2*i-1))**2 + 10 continue + f=g + return + end +c +ccccccccccccccccccccccc powell singular cccccccccccccccccccccccc +c + subroutine fcn22(n,x,f) + implicit double precision (a-h, o-z) +c +c extended powell singular function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + g=0.d0 + j=n/4 + do 10 i=1,j + g=g + (x(4*i-3) + 10.d0*x(4*i-2))**2 + + + 5.d0*(x(4*i-1) - x(4*i))**2 + + + ( (x(4*i-2)-2.d0*x(4*i-1))**2)**2 + + + 10.d0*( (x(4*i-3)-x(4*i))**2)**2 + 10 continue + f=g + return + end +c +ccccccccccccccccccccccccccccccc penalty I ccccccccccccccccccc +c + subroutine fcn23(n,x,f) + implicit double precision (a-h, o-z) +c +c penalty function i +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + g=0.d0 + do 20 i=1,n + g=g + (1.d-5) * (x(i)-1.d0)**2 + 20 continue + sum=0.d0 + do 30 j=1,n + sum=sum + x(j)*x(j) + 30 continue + g=g + (sum-.25d0)**2 + f=g + return + end +c +ccccccccccccccccccccccccccccccc penalty II cccccccccccccccccccc +c + subroutine fcn24(n,x,f) + implicit double precision (a-h, o-z) +c +c penalty function ii +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + g=(x(1)-.2d0)**2 + do 10 i=2,n + t=exp(i/10.d0) + exp((i-1)/10.d0) + g=g + 1.d-5* (exp(x(i)/10.d0) + exp(x(i-1)/10.d0) - t)**2 + 10 continue + m1=n+1 + m2=2*n-1 + do 20 i=m1,m2 + g=g + 1.d-5* (exp(x(i-n+1)/10.d0) - exp(1.d0/10.d0))**2 + 20 continue + sum=0.d0 + do 30 j=1,n + sum=sum + (n-j+1)*x(j)*x(j) + 30 continue + g=g + (sum-1.d0)**2 + f=g + return + end +c +ccccccccccccccccccccccccccccc variable dimension ccccccccccccccccc +c + subroutine fcn25(n,x,f) + implicit double precision (a-h, o-z) +c +c variably dimensioned function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + g=0.d0 + do 10 i=1,n + g=g + (x(i)-1.d0)**2 + 10 continue + s=0.d0 + do 20 i=1,n + s=s + i*(x(i)-1.d0) + 20 continue + g=g + s*s + (s*s)**2 + f=g + return + end +c +cccccccccccccccccccccc trigonometric cccccccccccccccccccccc +c + subroutine fcn26(n,x,f) + implicit double precision (a-h, o-z) +c +c trigonometric function +c + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + g=0.d0 + sum=0.d0 + do 10 j=1,n + sum=sum + cos(x(j)) + 10 continue + do 20 i=1,n + g=g+ (n-sum + i*(1.d0-cos(x(i))) - sin(x(i)) )**2 + 20 continue + f=g + return + end +c +ccccccccccccccccccccccccc chebyquad cccccccccccccccccccccccccccccccccc +c + subroutine fcn35(n,x,f) + implicit double precision (a-h, o-z) +c +c chebyquad function +c + dimension x(n) +c work arrays passed thru common dimensioned .ge. n + common y1(100),y2(100),y3(100) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 +c + sum=0.d0 + do 10 j=1,n + y1(j)=2.d0*x(j)-1.d0 + sum=sum+y1(j) + 10 continue + g=(sum/n)**2 +c + sum=0.d0 + do 20 j=1,n + y2(j)=2.d0*(2.d0*x(j)-1.d0)*y1(j)-1.d0 + sum=sum+y2(j) + 20 continue + g=g+ (sum/n + 1.d0/3.d0)**2 +c + sum=0.d0 + do 30 j=1,n + y3(j)=2.d0*(2.d0*x(j)-1.d0)*y2(j)-y1(j) + sum=sum+y3(j) + 30 continue + g=g+(sum/n)**2 +c + do 40 i=4,n +c i-th component + sum=0.d0 + do 35 j=1,n + y1(j)=y2(j) + y2(j)=y3(j) + y3(j)=2.d0*(2.d0*x(j)-1.d0)*y3(j)-y1(j) + sum=sum+y3(j) + 35 continue + k=mod(i,2) + if(k.eq.1) g=g+(sum/n)**2 + if(k.eq.0) g=g+(sum/n + 1.d0/(i*i-1))**2 + 40 continue + f=g + return + end +c +ccccccccccccccccccccccc extended rosenbrock badscale ccccccccccccccccccc +c + subroutine fcn36(n,x,f) + implicit double precision (a-h,o-z) +c +c extended rosenbrock badly scaled function +c + dimension x(n) + parameter (alpha = 1.0d-2) + dimension xt(10) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 + g=0.d0 + j=n/2 + do 10 i=1,j + xt(2*i-1) = x(2*i-1)*alpha + xt(2*i) = x(2*i)/alpha + g=g+ 100.d0*(xt(2*i)- xt(2*i-1)**2)**2 + (1.d0-xt(2*i-1))**2 + 10 continue + f=g + return + end +c +ccccccccccccccccccccccccccccccc quad cccccccccccccccccccccccccccc +c + subroutine fcn37(n,x,fv) +c +c rotated quadratic form with minimum of n at x(k) = k, k=1,n +c C. T. Mottershead LANL AT3 22 Mar 93 +c------------------------------------------------------------ + implicit double precision (a-h,o-z) + dimension x(n), c(10), a(10), b(10) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 +c + fv = n + do 10 k = 1,n + ak = k + km = k-1 + if(km.lt.1) km = n + akm = km + kp = k+1 + if(kp.gt.n) kp = 1 + akp = kp + fv = fv + ak*(x(k)-ak + x(kp)-akp - x(km)+akm)**2 + 10 continue + return + end +c +ccccccccccccccccccccccccccccccc berz cccccccccccccccccccccccccccc +c + subroutine fcn38(n,x,f) + implicit double precision (a-h,o-z) + dimension x(n) + common/count/ifcnt,igcnt,ihcnt + ifcnt=ifcnt+1 +c + f = x(1)**4 + x(2)**2 + dabs( x(2)**3 + x(4)**3) + + $ 13.0d0 * x(3)**2 + (x(2) - x(3)**2)**2 + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/mpi.f b/OpticsJan2020/MLI_light_optics/Src/mpi.f new file mode 100644 index 0000000..f3c9d46 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/mpi.f @@ -0,0 +1,161 @@ + blockdata mpifbd + logical mpif_initialized + common /MPILCOMN/ mpif_initialized + data mpif_initialized/.FALSE./ + end + + subroutine MPI_SEND( ) + include 'mpif.h' + print*,'in MPI_SEND: not implemented' + stop 'MPISEND' + end + + subroutine MPI_RECV( ) + include 'mpif.h' + print*,'in MPI_RECV: not implemented' + stop 'MPRECV' + end + + subroutine MPI_GET_COUNT( ) + include 'mpif.h' + print*,'in MPI_GET_COUNT: not implemented' + stop 'MPGETC' + end + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine MPI_ALLGATHER( Sendbuf,SendCount,SendType + & ,recvbuf,RecvCount,RecvType + & ,Comm,ierror ) + include 'mpif.h' + integer Sendbuf(*) ,SendCount,SendType + & ,recvbuf(*) ,RecvCount,RecvType ,Comm ,ierror + ! ignore possible differences in type and count + call MPI_ALLREDUCE( Sendbuf,recvbuf,RecvCount,RecvType + & ,MPI_SUM,Comm,ierror ) + if( ierror .NE. 0 )then + print*,'error: MPI_ALLGATHER: error in MPI_ALLREDUCE()' + else + ! check for count and type differences + if( SendCount .NE. RecvCount )then + ierror = 99 + elseif( SendType .NE. RecvType )then + ierror = 98 + endif + endif + return + end + + + subroutine MPI_ALLREDUCE( Sendbuf,recvbuf,Count,Datatype,Op,Comm + & ,ierror ) + include 'mpif.h' + integer Sendbuf(*) ,recvbuf(*) ,Count,Datatype,Op,Comm ,ierror + integer dtype ,dtypemult + + dtype = MOD( Datatype,100 ) / 10 + dtypemult = MOD( Datatype ,10 ) + +!XXX if( Op .LT. MPII_OP_FIRST .OR. Op .GT. MPII_OP_LAST )then +!XXX print*,'error: MPI_ALLREDUCE: unknown reduce operator ',Op +!XXX print*,'info: op must be in ',MPII_OP_FIRST,' to ',MPII_OP_LAST +!XXX ierror = 1 +!XXX return +!XXX endif + if( dtype .LT. 0 .OR. dtype .GT. MPII_MAX_TYPE )then + print*,'error: MPI_ALLREDUCE: unknown datatype ',Datatype + ierror = 2 + endif + if( dtypemult .LE. 0 .OR. dtypemult .GT. MPII_MAX_TYPE_MULT )then + print*,'error: MPI_ALLREDUCE: unknown datatype ',Datatype + ierror = 3 + return + endif + + call MPII_COPY( recvbuf,Sendbuf,count,dtypemult ) + ierror = 0 + ! warn about invalid args + if( Op .LT. MPII_OP_FIRST .OR. Op .GT. MPII_OP_LAST )then + ierror = 99 + elseif( Comm .NE. MPI_COMM_WORLD )then + ierror = 98 + endif + return + end + + subroutine MPI_BCAST( Bdata,DataLen,DataType,Root,Comm,ierror ) + integer Bdata ,DataLen,DataType,Root,Comm,ierror + ierror = 0 + return + end + + + subroutine MPI_INITIALIZED( flag ,ierror ) + include 'mpif.h' + integer flag ,ierror + if( mpif_initialized )then + flag = 1 + else + flag = 0 + endif + ierror = 0 + return + end + + subroutine MPI_INIT( ierror ) + include 'mpif.h' + integer ierror + mpif_initialized = .TRUE. + ierror = 0 + return + end + + subroutine MPI_COMM_SIZE( Communicator ,num_p ,status ) + include 'mpif.h' + integer Communicator ,num_p ,status(MPI_STATUS_SIZE) + num_p = 1 + status(1) = 0 + if( Communicator .NE. MPI_COMM_WORLD )then + status(1) = 99 + endif + return + end + + subroutine MPI_COMM_RANK( Communicator ,rank_p ,ierror ) + include 'mpif.h' + integer Communicator ,rank_p ,ierror + rank_p = 0 + ierror = 0 + if( Communicator .NE. MPI_COMM_WORLD )then + ierror = 99 + endif + return + end + + subroutine MPI_BARRIER( Communicator ,ierror ) + include 'mpif.h' + integer Communicator ,ierror + ierror = 0 + if( Communicator .NE. MPI_COMM_WORLD )then + ierror = 99 + endif + return + end + + subroutine MPI_FINALIZE( ierror ) + include 'mpif.h' + integer ierror + mpif_initialized = .FALSE. + ierror = 0 + return + end + + subroutine MPII_COPY( recvbuf,Sendbuf,Count,Dtypemult ) + integer recvbuf(*),Sendbuf(*) ,Count,Dtypemult + integer i + do i = 1,Count*Dtypemult + recvbuf(i) = Sendbuf(i) + enddo + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/mpif.h b/OpticsJan2020/MLI_light_optics/Src/mpif.h new file mode 100644 index 0000000..77430e1 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/mpif.h @@ -0,0 +1,29 @@ + implicit none + + integer MPI_STATUS_SIZE ,MPI_COMM_WORLD + parameter( MPI_STATUS_SIZE=1 ,MPI_COMM_WORLD=2 ) + ! values of type parameters are 100*+10*+, + ! where is the number of words in the type, + ! indicates the base type, + ! and is the multiple of the length of this type times + ! int length + integer MPI_DOUBLE_PRECISION ,MPI_DOUBLE_COMPLEX + parameter( MPI_DOUBLE_PRECISION=112 ,MPI_DOUBLE_COMPLEX=124 ) + integer MPI_2DOUBLE_PRECISION + parameter( MPI_2DOUBLE_PRECISION=214 ) + integer MPI_INTEGER ,MPI_2INTEGER + parameter( MPI_INTEGER=101 ,MPI_2INTEGER=202 ) + ![NOTE: have to update these when types change!!! -dbs] + integer MPII_TYPE_INT ,MPII_TYPE_REAL ,MPII_TYPE_CPLX + parameter( MPII_TYPE_INT=0 ,MPII_TYPE_REAL=1 ,MPII_TYPE_CPLX=2 ) + integer MPII_MAX_TYPE ,MPII_MAX_TYPE_MULT + parameter( MPII_MAX_TYPE=2 ,MPII_MAX_TYPE_MULT=4 ) + + integer MPI_SUM ,MPI_MAX ,MPI_MAXLOC + parameter( MPI_SUM=1001 ,MPI_MAX=1002 ,MPI_MAXLOC=1003 ) + integer MPII_OP_FIRST ,MPII_OP_LAST + parameter( MPII_OP_FIRST=MPI_SUM ,MPII_OP_LAST=MPI_MAXLOC ) + + logical mpif_initialized + common /MPILCOMN/ mpif_initialized + save /MPILCOMN/ diff --git a/OpticsJan2020/MLI_light_optics/Src/multitrack_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/multitrack_mod.f90 new file mode 100644 index 0000000..65f577b --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/multitrack_mod.f90 @@ -0,0 +1,62 @@ +module multitrack + use rays + use lieaparam, only : monoms + implicit none + real*8, dimension(:), allocatable :: tlistin,ptlistin !initial t,pt + real*8, dimension(:,:), allocatable :: rho56 !t-pt density (future use) + integer,dimension(:),allocatable::inear,jnear !indices of nearest init t,pt + real*8,dimension(:),allocatable::tdelt,ptdelt !distance to nearest init t,pt + real*8, dimension(:,:,:,:), allocatable :: tmhlist !linear maps + real*8, dimension(:,:,:), allocatable :: hlist !nonlinear maps + real*8, dimension(:,:,:,:),allocatable::pbhlist !Taylor tracking info + real*8, dimension(:,:), allocatable :: tlistfin,ptlistfin !final t,pt +!if multitrac.ne.0, then use multiple maps when tracking +!cover the longitudinal phase space on a grid of size (imaps)x(jmaps) +!refentry5,refentry6 are values for the (single) ref particle at entrance + integer :: multitrac,imaps,jmaps + real*8 :: refentry5,refentry6 +save + +contains + + subroutine new_multiarrays +! create arrays "on the fly" based on imaps, jmaps, nraysp + allocate(tlistin(imaps),ptlistin(jmaps),rho56(imaps,jmaps), & + &inear(nraysp),jnear(nraysp),tdelt(nraysp),ptdelt(nraysp), & + &tmhlist(6,6,imaps,jmaps),hlist(monoms,imaps,jmaps), & + &tlistfin(imaps,jmaps),ptlistfin(imaps,jmaps)) + return + end subroutine new_multiarrays + + subroutine del_multiarrays +! destroy arrays + deallocate(tlistin,ptlistin,inear,jnear,tdelt,ptdelt, & + & tmhlist,hlist) + return + end subroutine del_multiarrays + + subroutine multibrkts +! for nonlinear Taylor tracking, need to store the result of calling brkts + include 'pbkh.inc' + real*8 pbh + integer i,j + if(allocated(pbhlist))deallocate(pbhlist) + if(idproc.eq.0)write(6,*)'(multibrkts): allocating pbhlist array' + allocate(pbhlist(monoms,12,imaps,jmaps)) + do i=1,imaps + do j=1,jmaps + call brkts(hlist(1,i,j)) + pbhlist(:,:,i,j)=pbh(:,:) + enddo + enddo + return + end subroutine multibrkts + + subroutine multicanx +! for nonlinear symplectic tracking, need to store the result of calling canx + if(idproc.eq.0) & + &write(6,*)'error: multitrack symp tracking not yet implemented' + call myexit + end subroutine multicanx + +end module multitrack diff --git a/OpticsJan2020/MLI_light_optics/Src/myblas.f b/OpticsJan2020/MLI_light_optics/Src/myblas.f new file mode 100644 index 0000000..f410015 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/myblas.f @@ -0,0 +1,932 @@ + SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, + & BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 TRANSA, TRANSB + INTEGER M, N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* Purpose +* ======= +* +* DGEMM performs one of the matrix-matrix operations +* +* C := alpha*op( A )*op( B ) + beta*C, +* +* where op( X ) is one of +* +* op( X ) = X or op( X ) = X', +* +* alpha and beta are scalars, and A, B and C are matrices, with op( A ) +* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +* +* Parameters +* ========== +* +* TRANSA - CHARACTER*1. +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n', op( A ) = A. +* +* TRANSA = 'T' or 't', op( A ) = A'. +* +* TRANSA = 'C' or 'c', op( A ) = A'. +* +* Unchanged on exit. +* +* TRANSB - CHARACTER*1. +* On entry, TRANSB specifies the form of op( B ) to be used in +* the matrix multiplication as follows: +* +* TRANSB = 'N' or 'n', op( B ) = B. +* +* TRANSB = 'T' or 't', op( B ) = B'. +* +* TRANSB = 'C' or 'c', op( B ) = B'. +* +* Unchanged on exit. +* +* M - INTEGER. +* On entry, M specifies the number of rows of the matrix +* op( A ) and of the matrix C. M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix +* op( B ) and the number of columns of the matrix C. N must be +* at least zero. +* Unchanged on exit. +* +* K - INTEGER. +* On entry, K specifies the number of columns of the matrix +* op( A ) and the number of rows of the matrix op( B ). K must +* be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is +* k when TRANSA = 'N' or 'n', and is m otherwise. +* Before entry with TRANSA = 'N' or 'n', the leading m by k +* part of the array A must contain the matrix A, otherwise +* the leading k by m part of the array A must contain the +* matrix A. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When TRANSA = 'N' or 'n' then +* LDA must be at least max( 1, m ), otherwise LDA must be at +* least max( 1, k ). +* Unchanged on exit. +* +* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is +* n when TRANSB = 'N' or 'n', and is k otherwise. +* Before entry with TRANSB = 'N' or 'n', the leading k by n +* part of the array B must contain the matrix B, otherwise +* the leading n by k part of the array B must contain the +* matrix B. +* Unchanged on exit. +* +* LDB - INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. When TRANSB = 'N' or 'n' then +* LDB must be at least max( 1, k ), otherwise LDB must be at +* least max( 1, n ). +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then C need not be set on input. +* Unchanged on exit. +* +* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). +* Before entry, the leading m by n part of the array C must +* contain the matrix C, except when beta is zero, in which +* case C need not be set on entry. +* On exit, the array C is overwritten by the m by n matrix +* ( alpha*op( A )*op( B ) + beta*C ). +* +* LDC - INTEGER. +* On entry, LDC specifies the first dimension of C as declared +* in the calling (sub) program. LDC must be at least +* max( 1, m ). +* Unchanged on exit. +* +* +* Level 3 Blas routine. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Local Scalars .. + LOGICAL NOTA, NOTB + INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA, NCOLA and NROWB as the number of rows +* and columns of A and the number of rows of B respectively. +* + NOTA = LSAME( TRANSA, 'N' ) + NOTB = LSAME( TRANSB, 'N' ) + IF( NOTA )THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF( NOTB )THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF( ( .NOT.NOTA ).AND. + & ( .NOT.LSAME( TRANSA, 'C' ) ).AND. + & ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.NOTB ).AND. + & ( .NOT.LSAME( TRANSB, 'C' ) ).AND. + & ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN + INFO = 2 + ELSE IF( M .LT.0 )THEN + INFO = 3 + ELSE IF( N .LT.0 )THEN + INFO = 4 + ELSE IF( K .LT.0 )THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 8 + ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN + INFO = 10 + ELSE IF( LDC.LT.MAX( 1, M ) )THEN + INFO = 13 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGEMM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + & ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + & RETURN +* +* And if alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, M + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF( NOTB )THEN + IF( NOTA )THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 50, I = 1, M + C( I, J ) = ZERO + 50 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 60, I = 1, M + C( I, J ) = BETA*C( I, J ) + 60 CONTINUE + END IF + DO 80, L = 1, K + IF( B( L, J ).NE.ZERO )THEN + TEMP = ALPHA*B( L, J ) + DO 70, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 70 CONTINUE + END IF + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A'*B + beta*C +* + DO 120, J = 1, N + DO 110, I = 1, M + TEMP = ZERO + DO 100, L = 1, K + TEMP = TEMP + A( L, I )*B( L, J ) + 100 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF( NOTA )THEN +* +* Form C := alpha*A*B' + beta*C +* + DO 170, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 130, I = 1, M + C( I, J ) = ZERO + 130 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 140, I = 1, M + C( I, J ) = BETA*C( I, J ) + 140 CONTINUE + END IF + DO 160, L = 1, K + IF( B( J, L ).NE.ZERO )THEN + TEMP = ALPHA*B( J, L ) + DO 150, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 150 CONTINUE + END IF + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A'*B' + beta*C +* + DO 200, J = 1, N + DO 190, I = 1, M + TEMP = ZERO + DO 180, L = 1, K + TEMP = TEMP + A( L, I )*B( J, L ) + 180 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM . +* + END + + LOGICAL FUNCTION LSAME( CA, CB ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* September 30, 1994 +* +* .. Scalar Arguments .. + CHARACTER CA, CB +* .. +* +* Purpose +* ======= +* +* LSAME returns .TRUE. if CA is the same letter as CB regardless of +* case. +* +* Arguments +* ========= +* +* CA (input) CHARACTER*1 +* CB (input) CHARACTER*1 +* CA and CB specify the single characters to be compared. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA, INTB, ZCODE +* .. +* .. Executable Statements .. +* +* Test if the characters are equal +* + LSAME = CA.EQ.CB + IF( LSAME ) + & RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR( 'Z' ) +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR( CA ) + INTB = ICHAR( CB ) +* + IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 + IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 +* + ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.129 .AND. INTA.LE.137 .OR. + & INTA.GE.145 .AND. INTA.LE.153 .OR. + & INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 + IF( INTB.GE.129 .AND. INTB.LE.137 .OR. + & INTB.GE.145 .AND. INTB.LE.153 .OR. + & INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 +* + ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 + IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 + END IF + LSAME = INTA.EQ.INTB +* +* RETURN +* +* End of LSAME +* + END +* +************************************************************************** +****BEGIN PROLOGUE DCOPY +****PURPOSE Copy a vector. +****LIBRARY SLATEC (BLAS) +****CATEGORY D1A5 +****TYPE DOUBLE PRECISION (SCOPY-S, DCOPY-D, CCOPY-C, ICOPY-I) +****KEYWORDS BLAS, COPY, LINEAR ALGEBRA, VECTOR +****AUTHOR Lawson, C. L., (JPL) +* Hanson, R. J., (SNLA) +* Kincaid, D. R., (U. of Texas) +* Krogh, F. T., (JPL) +****DESCRIPTION +* +* B L A S Subprogram +* Description of Parameters +* +* --Input-- +* N number of elements in input vector(s) +* DX double precision vector with N elements +* INCX storage spacing between elements of DX +* DY double precision vector with N elements +* INCY storage spacing between elements of DY +* +* --Output-- +* DY copy of vector DX (unchanged if N .LE. 0) +* +* Copy double precision DX to double precision DY. +* For I = 0 to N-1, copy DX(LX+I*INCX) to DY(LY+I*INCY), +* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is +* defined in a similar way using INCY. +* +****REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. +* Krogh, Basic linear algebra subprograms for Fortran +* usage, Algorithm No. 539, Transactions on Mathematical +* Software 5, 3 (September 1979), pp. 308-323. +****ROUTINES CALLED (NONE) +****REVISION HISTORY (YYMMDD) +* 791001 DATE WRITTEN +* 890831 Modified array declarations. (WRB) +* 890831 REVISION DATE from Version 3.2 +* 891214 Prologue converted to Version 4.0 format. (BAB) +* 920310 Corrected definition of LX in DESCRIPTION. (WRB) +* 920501 Reformatted the REFERENCES section. (WRB) +****END PROLOGUE DCOPY + + subroutine dcopy(n,dx,incx,dy,incy) +c +c copies a vector, x, to a vector, y. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + dy(i) = dx(i) + dy(i + 1) = dx(i + 1) + dy(i + 2) = dx(i + 2) + dy(i + 3) = dx(i + 3) + dy(i + 4) = dx(i + 4) + dy(i + 5) = dx(i + 5) + dy(i + 6) = dx(i + 6) + 50 continue + return + end + +************************************************************************** + + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +****BEGIN PROLOGUE DSWAP +****DATE WRITTEN 791001 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D1A5 +****KEYWORDS BLAS,DOUBLE PRECISION,INTERCHANGE,LINEAR ALGEBRA,VECTOR +****AUTHOR LAWSON, C. L., (JPL) +* HANSON, R. J., (SNLA) +* KINCAID, D. R., (U. OF TEXAS) +* KROGH, F. T., (JPL) +****PURPOSE Interchange d.p. vectors +****DESCRIPTION +* +* B L A S Subprogram +* Description of Parameters +* +* --Input-- +* N number of elements in input vector(s) +* DX double precision vector with N elements +* INCX storage spacing between elements of DX +* DY double precision vector with N elements +* INCY storage spacing between elements of DY +* +* --Output-- +* DX input vector DY (unchanged if N .LE. 0) +* DY input vector DX (unchanged if N .LE. 0) +* +* Interchange double precision DX and double precision DY. +* For I = 0 to N-1, interchange DX(LX+I*INCX) and DY(LY+I*INCY), +* where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is +* defined in a similar way using INCY. +****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +****ROUTINES CALLED (NONE) +****END PROLOGUE DSWAP +* + DOUBLE PRECISION DX(1),DY(1),DTEMP1,DTEMP2,DTEMP3 +****FIRST EXECUTABLE STATEMENT DSWAP + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE +* +* CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. +* + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP1 = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP1 + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +* +* CODE FOR BOTH INCREMENTS EQUAL TO 1 +* +* +* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. +* + 20 M = MOD(N,3) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 30 CONTINUE + IF( N .LT. 3 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,3 + DTEMP1 = DX(I) + DTEMP2 = DX(I+1) + DTEMP3 = DX(I+2) + DX(I) = DY(I) + DX(I+1) = DY(I+1) + DX(I+2) = DY(I+2) + DY(I) = DTEMP1 + DY(I+1) = DTEMP2 + DY(I+2) = DTEMP3 + 50 CONTINUE + RETURN + 60 CONTINUE +* +* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. +* + NS = N*INCX + DO 70 I=1,NS,INCX + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 70 CONTINUE + RETURN + END + INTEGER FUNCTION IDAMAX(N,DX,INCX) +****BEGIN PROLOGUE IDAMAX +****DATE WRITTEN 791001 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D1A2 +****KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT, +* VECTOR +****AUTHOR LAWSON, C. L., (JPL) +* HANSON, R. J., (SNLA) +* KINCAID, D. R., (U. OF TEXAS) +* KROGH, F. T., (JPL) +****PURPOSE Find largest component of d.p. vector +****DESCRIPTION +* +* B L A S Subprogram +* Description of Parameters +* +* --Input-- +* N number of elements in input vector(s) +* DX double precision vector with N elements +* INCX storage spacing between elements of DX +* +* --Output-- +* IDAMAX smallest index (zero if N .LE. 0) +* +* Find smallest index of maximum magnitude of double precision DX. +* IDAMAX = first I, I = 1 to N, to minimize ABS(DX(1-INCX+I*INCX) +****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +****ROUTINES CALLED (NONE) +****END PROLOGUE IDAMAX +* + DOUBLE PRECISION DX(1),DMAX,XMAG +****FIRST EXECUTABLE STATEMENT IDAMAX + IDAMAX = 0 + IF(N.LE.0) RETURN + IDAMAX = 1 + IF(N.LE.1)RETURN + IF(INCX.EQ.1)GOTO 20 +* +* CODE FOR INCREMENTS NOT EQUAL TO 1. +* + DMAX = DABS(DX(1)) + NS = N*INCX + II = 1 + DO 10 I = 1,NS,INCX + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 5 + IDAMAX = II + DMAX = XMAG + 5 II = II + 1 + 10 CONTINUE + RETURN +* +* CODE FOR INCREMENTS EQUAL TO 1. +* + 20 DMAX = DABS(DX(1)) + DO 30 I = 2,N + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 30 + IDAMAX = I + DMAX = XMAG + 30 CONTINUE + RETURN + END +**************************************************************** + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +****BEGIN PROLOGUE DASUM +****DATE WRITTEN 791001 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D1A3A +****KEYWORDS ADD,BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAGNITUDE,SUM, +* VECTOR +****AUTHOR LAWSON, C. L., (JPL) +* HANSON, R. J., (SNLA) +* KINCAID, D. R., (U. OF TEXAS) +* KROGH, F. T., (JPL) +****PURPOSE Sum of magnitudes of d.p. vector components +****DESCRIPTION +* +* B L A S Subprogram +* Description of Parameters +* +* --Input-- +* N number of elements in input vector(s) +* DX double precision vector with N elements +* INCX storage spacing between elements of DX +* +* --Output-- +* DASUM double precision result (zero if N .LE. 0) +* +* Returns sum of magnitudes of double precision DX. +* DASUM = sum from 0 to N-1 of DABS(DX(1+I*INCX)) +****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +****ROUTINES CALLED (NONE) +****END PROLOGUE DASUM +* + DOUBLE PRECISION DX(1) +****FIRST EXECUTABLE STATEMENT DASUM + DASUM = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 +* +* CODE FOR INCREMENTS NOT EQUAL TO 1. +* + NS = N*INCX + DO 10 I=1,NS,INCX + DASUM = DASUM + DABS(DX(I)) + 10 CONTINUE + RETURN +* +* CODE FOR INCREMENTS EQUAL TO 1. +* +* +* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. +* + 20 M = MOD(N,6) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DASUM = DASUM + DABS(DX(I)) + 30 CONTINUE + IF( N .LT. 6 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,6 + DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) + & + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) + 50 CONTINUE + RETURN + END +**************************************************************** + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +****BEGIN PROLOGUE DAXPY +****DATE WRITTEN 791001 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D1A7 +****KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,TRIAD,VECTOR +****AUTHOR LAWSON, C. L., (JPL) +* HANSON, R. J., (SNLA) +* KINCAID, D. R., (U. OF TEXAS) +* KROGH, F. T., (JPL) +****PURPOSE D.P computation y = a*x + y +****DESCRIPTION +* +* B L A S Subprogram +* Description of Parameters +* +* --Input-- +* N number of elements in input vector(s) +* DA double precision scalar multiplier +* DX double precision vector with N elements +* INCX storage spacing between elements of DX +* DY double precision vector with N elements +* INCY storage spacing between elements of DY +* +* --Output-- +* DY double precision result (unchanged if N .LE. 0) +* +* Overwrite double precision DY with double precision DA*DX + DY. +* For I = 0 to N-1, replace DY(LY+I*INCY) with DA*DX(LX+I*INCX) + +* DY(LY+I*INCY), where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N +* and LY is defined in a similar way using INCY. +****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +****ROUTINES CALLED (NONE) +****END PROLOGUE DAXPY +* + DOUBLE PRECISION DX(1),DY(1),DA +****FIRST EXECUTABLE STATEMENT DAXPY + IF(N.LE.0.OR.DA.EQ.0.D0) RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE +* +* CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. +* + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +* +* CODE FOR BOTH INCREMENTS EQUAL TO 1 +* +* +* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. +* + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I + 1) = DY(I + 1) + DA*DX(I + 1) + DY(I + 2) = DY(I + 2) + DA*DX(I + 2) + DY(I + 3) = DY(I + 3) + DA*DX(I + 3) + 50 CONTINUE + RETURN +* +* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. +* + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DY(I) = DA*DX(I) + DY(I) + 70 CONTINUE + RETURN + END +**************************************************************** + SUBROUTINE DSCAL(N,DA,DX,INCX) +****BEGIN PROLOGUE DSCAL +****DATE WRITTEN 791001 (YYMMDD) +****REVISION DATE 820801 (YYMMDD) +****CATEGORY NO. D1A6 +****KEYWORDS BLAS,LINEAR ALGEBRA,SCALE,VECTOR +****AUTHOR LAWSON, C. L., (JPL) +* HANSON, R. J., (SNLA) +* KINCAID, D. R., (U. OF TEXAS) +* KROGH, F. T., (JPL) +****PURPOSE D.P. vector scale x = a*x +****DESCRIPTION +* +* B L A S Subprogram +* Description of Parameters +* +* --Input-- +* N number of elements in input vector(s) +* DA double precision scale factor +* DX double precision vector with N elements +* INCX storage spacing between elements of DX +* +* --Output-- +* DX double precision result (unchanged if N.LE.0) +* +* Replace double precision DX by double precision DA*DX. +* For I = 0 to N-1, replace DX(1+I*INCX) with DA * DX(1+I*INCX) +****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +****ROUTINES CALLED (NONE) +****END PROLOGUE DSCAL +* + DOUBLE PRECISION DA,DX(1) +****FIRST EXECUTABLE STATEMENT DSCAL + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 +* +* CODE FOR INCREMENTS NOT EQUAL TO 1. +* + NS = N*INCX + DO 10 I = 1,NS,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN +* +* CODE FOR INCREMENTS EQUAL TO 1. +* +* +* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. +* + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I + 1) = DA*DX(I + 1) + DX(I + 2) = DA*DX(I + 2) + DX(I + 3) = DA*DX(I + 3) + DX(I + 4) = DA*DX(I + 4) + 50 CONTINUE + RETURN + END +**************************************************************** + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) + implicit double precision (a-h, o-z) +* RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. +* DDOT = SUM FOR I = 0 TO N-1 OF DX(LX+I*INCX) * DY(LY+I*INCY) +* WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +* DEFINED IN A SIMILAR WAY USING INCY. + DOUBLE PRECISION DX(1),DY(1) + DDOT = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE +* CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DDOT = DDOT + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +* CODE FOR BOTH INCREMENTS EQUAL TO 1. +* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DDOT = DDOT + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + & DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + RETURN +* CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DDOT = DDOT + DX(I)*DY(I) + 70 CONTINUE + RETURN + END diff --git a/OpticsJan2020/MLI_light_optics/Src/mygenrec5.f b/OpticsJan2020/MLI_light_optics/Src/mygenrec5.f new file mode 100755 index 0000000..21062e1 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/mygenrec5.f @@ -0,0 +1,554 @@ +************************************************************************ +* header GENREC (GENMAP for a pattern of REC quads) * +* All routines needed for this special GENMAP * +************************************************************************ +************************************************************************ + subroutine gnrec3(p,fa,fm) +c This is a subroutine for computing the map for patterns of REC quads. +c It is based on Rob Ryne's GENMAP as modified by Alex Dragt 12/18/86. +c +c Further modified 4 June 87 by Tom Mottershead to allow any number +c of cycles through a pattern of up to 5 REC quads, with arbitrary +c numbers of repeats. Actually probably more general than this. AJD +c +c Modified by Filippo Neri Jan. 16 1989 to include multipoles. +c Fifth order version by F. Neri Mar 13 1989. +c Modified to be like MaryLie 3.0 version by A. Dragt 4/24/95 +c +c The input parameters come from recn, and the +c auxilary parameter NPQUAD, MULTIPOLES, plus NQT pset defining the quads. + +******************************************************************************* + +c +c The parameters of recm are: +c 1. zi Initial integration point. +c 2. zf Final integration point. +c 3. NS Number of integration steps. +c 4. IFILE (profile file number). +c 5. MULTIPOLES index of pset containin multipole information +c for this integration region. If MULTIPOLES is 0, then +c the value of all multipoles is set to zero. +c 6. NPQUAD index of pset containing quad pattern information. +c--------------------------------------------------------------- +c The pset MULTIPOLES has the same format as used in the cfq element: +c 1. Normal sextupole ( Tesla/meter^2 ). +c 2. Skew sextupole ( Tesla/meter^2 ). +c 3. Normal octupole ( Tesla/meter^3 ). +c 4. Skew octupole ( Tesla/Meter^3 ). +c 5. UNUSED ( must be there!) +c 6. UNUSED ( nust be there!) +c--------------------------------------------------------------- +c The parameter set NPQUAD defines the set of Halbach quad units as follows: +c 1. Di Initial drift to first quad ( starting from Z = 0.) +c 2. NQT Number of psets used for quads. +c 3. IPS Index of inital pset used for quads. The following +c psets in order define the successive quads. +c 4. MAXQ Maximum number of quads actually used, including multiple +c cycles thru pattern (but not repeats). +c 5. NCYC Number of cycles thru pattern, except that the sequence +c stops when MAXQ is reached. +c 6. ISEND output control: 0 = quiet running +c 1 = print on terminal (jof) +c 2 = print on std. output file (jodf) +c 3 = print on both +c--------------------------------------------------------------- +c The parameter set type codes are used to define the Halbach quad unit +c cells in a manner parallel to the normal quad type codes: +c ps(1) = ql, the quad length in meters. +c ps(2) = fg, the field gradient in Tesla/meter (if the quad were +c infinitely long). +c ps(3) = ra, the inner radius. (These radii control the shape of the +c ps(4) = rb, the outer radius. fringe field) +c ps(5) = td, the trailing drift to the front face of the next quad in +c the pattern (meters). Note: the trailing drift assigned to +c the last quad in the whole pattern is ignored; the +c integration proceeds to the final point zf anyway. +c ps(6) = nr, the number of consecutive repetitions, or multiplicity, +c of this quad unit cell in the basic pattern. +c------------------------------------------------------------------- +c + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + include 'hmflag.inc' + include 'combs.inc' + include 'quadpn.inc' + include 'files.inc' + include 'recmul.inc' +c +c calling arrays + dimension p(6) + dimension fa(monoms), fm(6,6) +c +c local arrays + dimension pb(6) + dimension y(monoms+15) +c +c timing variables +c real ttaa, ttbb +c +c use equivalence statement to make the various parameter sets pstj +c available as if they were in a two dimensional array +c +c +c y(1-6) = given (design) trajectory +c y(7-42) = matrix +c y(43-98) = f3 +c y(99-224) = f4 +c y(225-*) = f5 +c y(*-*) = f6 +c +c get interval and number of steps from GENREC parameters +c + zi = p(1) + zf = p(2) + ns = nint(p(3)) + ifile = nint(p(4)) + mpole = nint(p(5)) + npquad = nint(p(6)) +c +c get multipole values from the parameter set mpole +c Note that if mpole is zero, then the multipoles are set to zero. +c + if (mpole.lt.1 .or. mpole.gt.maxpst) then + do 500 i=1,6 + 500 pb(i) = 0.0d0 + else + do 600 i=1,6 + 600 pb(i) = pst(i,mpole) + endif +c +c compute multipole coefficients +c + bsex=pb(1) + asex=pb(2) + boct=pb(3) + aoct=pb(4) + fsxnr=bsex/(3.d0*brho) + fsxsk=asex/(3.d0*brho) + focnr=boct/(4.d0*brho) + focsk=aoct/(4.d0*brho) +c +c get REC pattern information from pset npquad +c + di = pst(1,npquad) + nqt = nint(pst(2,npquad)) + if (nqt .gt. 6) then + write(jof,*) ' input error: nqt=',nqt + write(jof,*) ' this value is > 6 and therefore too large' + call myexit + endif + ips = nint(pst(3,npquad)) + maxq = nint(pst(4,npquad)) + ncyc = nint(pst(5,npquad)) + isend = nint(pst(6,npquad)) + jtty = 0 + jdsk = 0 + if((isend.eq.1).or.(isend.eq.3)) jtty = 1 + if((isend.eq.2).or.(isend.eq.3)) jdsk = 1 +c + h=(zf-zi)/float(ns) +c +c echo input parameters +c + if(jtty.eq.1) write( jof,13) ns,zi,zf + if(jdsk.eq.1) write(jodf,13) ns,zi,zf + 13 format(/' Integrating in ',i6,' steps from',f10.5,'=zi to', + &f10.5,'=zf') + if (mpole.lt.1 .or. mpole.gt.maxpst) then + if(jtty.eq.1) write( jof,*) + &' mpole=0, all multipoles are zero' + if(jdsk.eq.1) write( jodf,*) + &' mpole=0, all multipoles are zero' + endif + if (mpole.ge.1 .and. mpole.le.maxpst) then + if(jtty.eq.1) write( jof,14) mpole,bsex,asex,boct,aoct + if(jdsk.eq.1) write(jodf,14) mpole,bsex,asex,boct,aoct + 14 format(1x,'multipole strengths from pset',i2,':',/, + &1x,' Sextupole:',2(1pg12.4),/, + &1x,' Octupole: ',2(1pg12.4)) + endif + if(jtty.eq.1) write( jof,15) npquad,ncyc,nqt,maxq,di + if(jdsk.eq.1) write(jodf,15) npquad,ncyc,nqt,maxq,di + 15 format(' Pattern from pset',i2,':',/, + &i4,' cycle(s) of',i3,' type(s) of section(s) with a maximum of' + &,i3,' section(s)',/,' di=',f10.5) + if(jtty.eq.1) write( jof,*) ' types of section(s) are:' + if(jdsk.eq.1) write(jodf,*) ' types of section(s) are:' + if(jtty.eq.1) write( jof,16) + if(jdsk.eq.1) write(jodf,16) + 16 format(1x,'pset',2x,'length',4x,'strength',3x, + &'radii: inner',6x,'outer',6x,'tdrift',4x,'number') +c +c inititialize the nqt quad types from the first nqt parameter sets +c + do 20 n = ips, nqt+ips-1 + kn = n-ips+1 + wd(kn) = pst(1,n) + ga(kn) = pst(2,n) + ra(kn) = pst(3,n) + rb(kn) = pst(4,n) + dr(kn) = pst(5,n) + nr(kn) = nint(pst(6,n)) + if(jtty.eq.1) write(jof,17) + & n,wd(kn),ga(kn),ra(kn),rb(kn),dr(kn),nr(kn) + if(jdsk.eq.1) write(jodf,17) + & n,wd(kn),ga(kn),ra(kn),rb(kn),dr(kn),nr(kn) + 17 format(i4,5f12.6,i6) + 20 continue +c +c call VAX system routine for timing report +c +c ttaa = secnds(0.0) +c +c initial values for design orbit (in dimensionless units) : +c + y(1)=0.d0 + y(2)=0.d0 + y(3)=0.d0 + y(4)=0.d0 + y(5)=0.d0 + y(6)=0.d0 +c set constants + qbyp=1.d0/brho + ptg=-1.d0/beta +c cmp2=(1.d0/(beta*gamma))**2 +c +c initialize map to the identity map: + ne=monoms+15 + do 40 i=7,ne + 40 y(i)=0.d0 + do 50 i=1,6 + j=7*i + 50 y(j)=1.d0 +c +c Set up multipoles: +c +c compute useful numbers +c + sl2=sl*sl + sl3=sl*sl2 + bet2=beta*beta + bet3=beta*bet2 + gam2=gamma*gamma +c +c write out gradient and derivatives on file ifile: + ipflag=0 + if (ifile .ne. 0) then + if (ifile .lt.0 ) then + ipflag=1 + ifile=-ifile + endif + do 100 i=0,ns + s=zi + float(i)*h + call g01234(s,g,gz,gzz,gzzz,gzzzz) + 100 write(ifile,101)s,g,gz,gzz,gzzz,gzzzz + 101 format(6(1x,1pg12.5)) + write(jof,*) ' ' + write(jof,*) ' profile written on file ',ifile + endif +c +c return identity map if ifile was < 0 + if (ipflag .eq. 1) then + call ident(fa,fm) + return + endif +c +c do the computation: + t=zi + iflag = 2 +cryne 1 August 2004 fix later: +cryne call adam11(h,ns,'start',t,y) + nedummy=monoms+15 + call adam11(h,ns,'start',t,y,nedummy) + call errchk(y(7)) + call putmap(y,fa,fm) + call csym(1,fm,ans) +c +c call VAX system routine for timing report +c +c ttbb = secnds(ttaa) +c if(jtty.eq.1) write( jof,567) ttbb +c if(jdsk.eq.1) write(jodf,567) ttbb +c 567 format(' GENREC integration time = ',f12.2,' sec.') +c + return + end +c +********************************************************************** +c + subroutine errchk(y) + use lieaparam, only : monoms + use parallel, only : idproc + include 'impli.inc' +cryne dimension y(monoms+15) + dimension y(*) + s1=1.d0 -( y(1)*y(8)-y(2)*y(7) ) + s2=1.d0 -( y(15)*y(22)-y(16)*y(21) ) + s3=1.d0 -( y(29)*y(36)-y(30)*y(35) ) + if (idproc.eq.0) then + write(6,100) s1,s2,s3 + end if + 100 format(1x,'1. - 2 x 2 determinants = ',e14.7,1x,e14.7,1x,e14.7) + return + end +c +********************************************************************** +c + subroutine hmltn2(t,y,h) +c new version by R. Ryne 6/9/2002 +c +c this routine is used to specify h(z) for a REC quad triplet +c This version ( f5 + f6 ) by F. Neri. +c Jan 7 1988. +c Multipoles added by F. Neri Mar 13 1989. + use beamdata + implicit double precision(a-h,o-z) + parameter (itop=923,iplus=938) + include 'combs.inc' + include 'recmul.inc' + dimension A(0:12),X(0:itop),YY(0:itop),P1(0:itop),P2(0:itop) + dimension h(itop),y(*) +c +c begin calculation +c +c compute gradients + call g01234(t,g,gz,gzz,gzzz,gzzzz) + f=0.5d0*g + fz=0.25d0*gz + fzz=gzz/12.d0 + fzzz=gzzz/48.d0 + fzzzz=gzzzz/256.d0 + brho=1./qbyp + beta=-1.d0/ptg +c +c initialization + do 10 i=7,itop + 10 h(i)=0.d0 +c +c 2nd order + h(27)=-(-1.d0 + beta**2)/(2.d0*beta**2*sl) + h(13)=1.d0/(2.d0*sl) + h(22)=1.d0/(2.d0*sl) + h(7)=(f*sl)/brho + h(18)=-((f*sl)/brho) +c 3rd order + h(83)=-(-1.d0 + beta**2)/(2.d0*beta**3*sl) + h(53)=1.d0/(2.d0*beta*sl) + h(76)=1.d0/(2.d0*beta*sl) +c 4th order + h(209)=(5.d0 - 6.d0*beta**2 + beta**4)/(8.d0*beta**4*sl) + h(154)=-(-3.d0 + beta**2)/(4.d0*beta**2*sl) + h(200)=-(-3.d0 + beta**2)/(4.d0*beta**2*sl) + h(140)=1.d0/(8.d0*sl) + h(149)=1.d0/(4.d0*sl) + h(195)=1.d0/(8.d0*sl) + h(85)=-((fz*sl**2)/brho) + h(84)=-((fzz*sl**3)/brho) + h(96)=-((fz*sl**2)/brho) + h(110)=(fz*sl**2)/brho + h(176)=(fz*sl**2)/brho + h(175)=(fzz*sl**3)/brho +c 5th order + h(370)=-(-5.d0 + 3.d0*beta**2)/(4.d0*beta**3*sl) + h(450)=-(-5.d0 + 3.d0*beta**2)/(4.d0*beta**3*sl) + h(461)=(7.d0 - 10.d0*beta**2 + 3.d0*beta**4)/(8.d0*beta**5*sl) + h(340)=3.d0/(8.d0*beta*sl) + h(363)=3.d0/(4.d0*beta*sl) + h(443)=3.d0/(8.d0*beta*sl) + h(220)=-((fz*sl**2)/(beta*brho)) + h(252)=-((fz*sl**2)/(beta*brho)) + h(284)=(fz*sl**2)/(beta*brho) + h(412)=(fz*sl**2)/(beta*brho) +c 6th order + h(783)=(35.d0 - 30.d0*beta**2 + 3.d0*beta**4)/(16.d0*beta**4*sl) + h(910)=(35.d0 - 30.d0*beta**2 + 3.d0*beta**4)/(16.d0*beta**4*sl) + h(728)=(-3.d0*(-5.d0 + beta**2))/(16.d0*beta**2*sl) + h(901)=(-3.d0*(-5.d0 + beta**2))/(16.d0*beta**2*sl) + h(923)= & + &-(-21.d0+35.d0*beta**2-15.d0*beta**4+beta**6)/(16.d0*beta**6*sl) + h(774)=(-3.d0*(-5.d0 + beta**2))/(8.d0*beta**2*sl) + h(714)=1.d0/(16.d0*sl) + h(723)=3.d0/(16.d0*sl) + h(769)=3.d0/(16.d0*sl) + h(896)=1.d0/(16.d0*sl) + h(483)=-(fz*sl**2)/(2.d0*brho) + h(492)=-(fz*sl**2)/(2.d0*brho) + h(497)=((-3.d0 + beta**2)*fz*sl**2)/(2.d0*beta**2*brho) + h(463)=(fzzz*sl**4)/brho + h(462)=(sl**5*(fz**2 + 2.d0*brho*fzzzz))/(2.d0*brho**2) + h(524)=-(fz*sl**2)/(2.d0*brho) + h(563)=-(fz*sl**2)/(2.d0*brho) + h(568)=((-3.d0 + beta**2)*fz*sl**2)/(2.d0*beta**2*brho) + h(474)=(fzzz*sl**4)/brho + h(593)=(fz*sl**2)/(2.d0*brho) + h(627)=(fz*sl**2)/(2.d0*brho) + h(632)=-((-3.d0 + beta**2)*fz*sl**2)/(2.d0*beta**2*brho) + h(473)=(sl**5*(-fz**2 + 2.d0*brho*fzzzz))/(2.d0*brho**2) + h(750)=(fz*sl**2)/(2.d0*brho) + h(850)=(fz*sl**2)/(2.d0*brho) + h(855)=-((-3.d0 + beta**2)*fz*sl**2)/(2.d0*beta**2*brho) + h(623)=-((fzzz*sl**4)/brho) + h(553)=-(sl**5*(fz**2 + 2.d0*brho*fzzzz))/(2.d0*brho**2) + h(841)=-((fzzz*sl**4)/brho) + h(840)=(sl**5*(fz**2 - 2.d0*brho*fzzzz))/(2.d0*brho**2) +c +c add sextupoles + h(28)=fsxnr*sl2 + h(30)=-3.d0*fsxsk*sl2 + h(39)=-3.d0*fsxnr*sl2 + h(64)=fsxsk*sl2 +c +c add octupoles +c + h(84)=h(84)+focnr*sl3 + h(86)=-4.0d0*focsk*sl3 + h(95)=-6.d0*focnr*sl3 + h(120)=4.d0*focsk*sl3 + h(175)=h(175)+focnr*sl3 +c + return + end +c +************************************************************************ +c + subroutine g01234(z,g,gz,gzz,gzzz,gzzzz) +c This routine computes g, dg/dz, and d/dz(dg/dz) for +c (a REC Quadrupole Triplet.) +c Written by Alex Dragt, Fall 1986, and based on work of +c Rob Ryne and F. Neri +c This version by T. Mottershead allows up to 9(?) different +c REC Quadrupoles. +c Extended to derivatives up to 4 by F. Neri Mar 13 1989. + include 'impli.inc' + include 'quadpn.inc' +c---------------------------------------- + external f,fz,fzz,fzzz,fzzzz +c---------------------------------------- +c + g=0.d0 + gz=0.d0 + gzz=0.d0 + gzzz=0.d0 + gzzzz=0.d0 + kuad = 0.d0 + za = di + do 60 i=1,ncyc + do 50 k=1,nqt + gk = ga(k) + wk = wd(k) + dk = dr(k) + aa = ra(k) + bb = rb(k) + do 40 j=1,nr(k) + zb = za + wk + g = g +gk*( f(z-zb,aa,bb)-f(z-za,aa,bb)) + gz = gz +gk*( fz(z-zb,aa,bb)-fz(z-za,aa,bb)) + gzz= gzz+gk*(fzz(z-zb,aa,bb)-fzz(z-za,aa,bb)) + gzzz= gzzz+gk*(fzzz(z-zb,aa,bb)-fzzz(z-za,aa,bb)) + gzzzz= gzzzz+gk*(fzzzz(z-zb,aa,bb)-fzzzz(z-za,aa,bb)) + kuad = kuad + 1 + if(kuad.ge.maxq) return + za = zb + dk + 40 continue + 50 continue + 60 continue + return + end +c + double precision function f(z,r1,r2) + implicit double precision (a-h,o-z) + v(z,r)=1.d0/sqrt(1.d0+(z/r)**2) + f = 0.5d0-.0625d0*z* + &(1.d0/r1+1.d0/r2)*v(z,r1)**2*v(z,r2)**2/(v(z,r1)+v(z,r2))*( & + &v(z,r1)**2+v(z,r1)*v(z,r2)+v(z,r2)**2+4.d0+8.d0/(v(z,r1)*v(z,r2))) + return + end +c + double precision function fz(z,r1,r2) + implicit double precision (a-h,o-z) + v(z,r)=1.d0/sqrt(1.d0+(z/r)**2) + fz = -.1875d0*(1.d0/r1+1.d0/r2)*v(z,r1)**2*v(z,r2)**2* & + &(v(z,r1)**3+v(z,r2)**3 + v(z,r1)**2*v(z,r2)**2/(v(z,r1)+v(z,r2))) + return + end +c + double precision function fzz(z,r1,r2) + implicit double precision (a-h,o-z) + v(z,r)=1.d0/sqrt(1.d0+(z/r)**2) + fzz = .1875d0*(1.d0/r1+1.d0/r2)*z*v(z,r1)**2*v(z,r2)**2 *( & + &5.d0*(v(z,r1)**5/r1**2+v(z,r2)**5/r2**2) & + &+v(z,r1)**2*v(z,r2)**2 *( & + & 2.d0*(v(z,r2)/r1**2+v(z,r1)/r2**2) & + &+4.d0*(v(z,r1)**2/r1**2+v(z,r2)**2/r2**2)/(v(z,r1)+v(z,r2)) & + &-(v(z,r1)**3/r1**2+v(z,r2)**3/r2**2)/(v(z,r1)+v(z,r2))**2 )) + return + end +c +c Higher derivatives of the Halbach function by +c F. Neri, Jan 1988. +c + double precision function fzzz(z,r1,r2) + implicit double precision (a-h,o-z) + v(z,r)=1.d0/sqrt(1.d0+(z/r)**2) + if(dabs(z) .ge. 0.0001d0*r1) then + fzzz =.375d0*((3.5d0*(v(z,r1)**7/(r1**2*z**2)) & + &+3.d0*(v(z,r1)**7/z**4)+7.d0*(v(z,r1)**9/(r1**2*z**2)) & + &+24.5d0*(v(z,r1)**9/r1**4) & + & -3.5d0*(v(z,r2)**7/(r2**2*z**2)) & + &-3.d0*(v(z,r2)**7/z**4)-7.d0*(v(z,r2)**9/(r2**2*z**2)) & + &-24.5d0*(v(z,r2)**9/r2**4))/(1.d0/r1-1.d0/r2)) + else +c-------------------------------------- +c Limiting expression for z ~ 0 + fzzz = 6.d0*(35.d0/128.d0)*(1./(r1*r2**2)+1./(r1**2*r2) & + &+ 1.d0/(r1**3)+1.d0/(r2**3)) & + &+60.d0*(-63.d0/256.d0)*z**2*(1.d0/(r1*r2**4)+1.d0/(r1**2*r2**3) & + &+1.d0/(r1**3*r2**2)+1.d0/(r1**4*r2)+1.d0/(r1**5)+1.d0/(r2**5)) & + &+210.d0*(495.d0/2048.d0)*z**4*(1.d0/(r1*r2**6)+1.d0/(r1**2*r2**5) & + &+1.d0/(r1**3*r2**4)+1.d0/(r1**4*r2**3)+1.d0/(r1**5*r2**2) & + &+1.d0/(r1**6*r2)+1.d0/(r1**7)+1.d0/(r2**7)) & + &+504.d0*(-1001.d0/4096.d0)*z**6*(1./(r1*r2**8)+1.d0/(r1**2*r2**7) & + &+1.d0/(r1**3*r2**6)+1.d0/(r1**4*r2**5)+1.d0/(r1**5*r2**4) & + &+1.d0/(r1**6*r2**3)+1.d0/(r1**7*r2**2)+1.d0/(r1**8*r2) & + &+1.d0/(r1**9)+1.d0/(r2**9)) + endif + return + end +c + double precision function fzzzz(z,r1,r2) + implicit double precision (a-h,o-z) + v(z,r)=1.d0/sqrt(1.d0+(z/r)**2) + if (dabs(z) .ge. 0.0001d0*r1) then + fzzzz = 0.375d0*(( & + &-220.5d0*((z*v(z,r1)**11)/r1**6)-7.d0*(v(z,r1)**7/(r1**2*z**3)) & + &-12.d0*(v(z,r1)**7/z**5)-35.d0*(v(z,r1)**9/(r1**2*z**3)) & + &-24.5d0*(v(z,r1)**9/(r1**4*z))-63.d0*(v(z,r1)**11/(r1**4*z)) & + &+220.5d0*((z*v(z,r2)**11)/r2**6)+7.d0*(v(z,r2)**7/(r2**2*z**3)) & + &+12.d0*(v(z,r2)**7/z**5)+35.d0*(v(z,r2)**9/(r2**2*z**3)) & + &+24.5d0*(v(z,r2)**9/(r2**4*z))+63.d0*(v(z,r2)**11/(r2**4*z)) & + & )/(1.d0/r1-1.d0/r2)) +c---------------------------------------- + else +c Limiting expression for z ~ 0 +cryne 105.*18.? +cryne fzzzz = -105.*18*z*(1./r1**6-1./r2**6)/(64.*(1./r1-1./r2)) + fzzzz = -105.d0*18.d0*z*(1.d0/r1**6-1.d0/r2**6)/(64.d0*(1.d0/r1- & + &1.d0/r2)) & + &+840.d0*z**3*(495.d0/2048.d0)*( 1.d0/(r1*r2**6) & + &+ 1.d0/(r1**2*r2**5) & + &+ 1.d0/(r1**3*r2**4) + 1.d0/(r1**4*r2**3) + 1.d0/(r1**5*r2**2) & + &+ 1.d0/(r1**6*r2) + 1.d0/r1**7 + 1.d0/r2**7 ) & + &-3024.d0*z**5*(1001.d0/4096.d0)*(1.d0/(r1*r2**8) & + &+1.d0/(r1**2*r2**7) & + &+1.d0/(r1**3*r2**6)+1.d0/(r1**4*r2**5)+1.d0/(r1**5*r2**4) & + &+1.d0/(r1**6*r2**3)+1.d0/(r1**7*r2**2)+1.d0/(r1**8*r2) & + &+1.d0/r1**9 + 1.d0/r2**9 ) +c + endif + return + end +c +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/myprot5.f b/OpticsJan2020/MLI_light_optics/Src/myprot5.f new file mode 100644 index 0000000..30a0f40 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/myprot5.f @@ -0,0 +1,83 @@ + subroutine myprot(phideg,h,mh) +c +c High order PROT routine. +c Actual code generated by Johannes van Zeijts using +c REDUCE. +c + include 'impli.inc' + include 'param.inc' + include 'parm.inc' + include 'pie.inc' + double precision l,h(monoms),mh(6,6) +c + dimension j(6) +c + DOUBLE PRECISION B + DOUBLE PRECISION CO + DOUBLE PRECISION Si +c + call clear(h,mh) +c + B = beta + phi = phideg*pi180 + SI = SIN(phi) + CO = COS(phi) +c + mh(1,1)=1.0d0/CO + mh(2,2)=CO + mh(2,6)=(-SI)/B + mh(3,3)=1.0d0 + mh(4,4)=1.0d0 + mh(5,1)=SI/(B*CO) + mh(5,5)=1.0d0 + mh(6,6)=1.0d0 +c + h(34) =(-SI)/(2.0d0*CO) + h(43) =(-SI)/(2.0d0*CO) + h(48) =(SI*(B**2-1))/(2.0d0*B**2*CO) + h(105) =SI**2/(4.0d0*(SI**2-1)) + h(109) =(-SI)/(2.0d0*B*CO) + h(114) =SI**2/(4.0d0*(SI**2-1)) + h(119) =(SI**2*(-B**2+1))/(4.0d0*B**2*(SI**2-1)) + h(132) =(-SI)/(2.0d0*B*CO) + h(139) =(SI*(B**2-1))/(2.0d0*B**3*CO) + h(266) =SI/(8.0d0*CO*(SI**2-1)) + h(270) =SI**2/(2.0d0*B*(SI**2-1)) + h(275) =(SI*(-2.0d0*SI**2+3))/(12.0d0*CO*(SI**2-1)) + h(280) =(SI*(2.0d0*B**2*SI**2-3.0d0*B**2-8.0d0*SI**2+9))/( + # 12.0d0*B**2*CO*(SI**2-1)) + h(293) =SI**2/(2.0d0*B*(SI**2-1)) + h(300) =(SI**2*(-B**2+1))/(2.0d0*B**3*(SI**2-1)) + h(321) =(SI*(-4.0d0*SI**2+3))/(24.0d0*CO*(SI**2-1)) + h(326) =(SI*(4.0d0*B**2*SI**2-3.0d0*B**2-10.0d0*SI**2+9))/( + # 12.0d0*B**2*CO*(SI**2-1)) + h(335) =(SI*(-4.0d0*B**4*SI**2+3.0d0*B**4+20.0d0*B**2*SI**2- + # 18.0d0*B**2-16.0d0*SI**2+15))/(24.0d0*B**4*CO*(SI**2-1)) + h(588) =(SI**2*(SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+1)) + h(592) =(SI*(SI**2+6))/(16.0d0*B*CO*(SI**2-1)) + h(597) =(SI**2*(3.0d0*SI**2-4))/(16.0d0*(SI**4-2.0d0*SI**2+ + # 1)) + h(602) =(SI**2*(-3.0d0*B**2*SI**2+4.0d0*B**2+15.0d0*SI**2-16.0d0 + # ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) + h(615) =(3.0d0*SI*(-SI**2+2))/(8.0d0*B*CO*(SI**2-1)) + h(622) =(SI*(3.0d0*B**2*SI**2-6.0d0*B**2-7.0d0*SI**2+10))/( + # 8.0d0*B**3*CO*(SI**2-1)) + h(643) =(SI**2*(5.0d0*SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+ + # 1)) + h(648) =(SI**2*(-5.0d0*B**2*SI**2+4.0d0*B**2+17.0d0*SI**2-16.0d0 + # ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) + h(657) =(SI**2*(5.0d0*B**4*SI**2-4.0d0*B**4-34.0d0*B**2*SI**2 + # +32.0d0*B**2+29.0d0*SI**2-28))/(32.0d0*B**4*(SI**4-2.0d0*SI**2+ + # 1)) + h(695) =(SI*(-7.0d0*SI**2+6))/(16.0d0*B*CO*(SI**2-1)) + h(702) =(SI*(7.0d0*B**2*SI**2-6.0d0*B**2-11.0d0*SI**2+10))/( + # 8.0d0*B**3*CO*(SI**2-1)) + h(713) =(SI*(-7.0d0*B**4*SI**2+6.0d0*B**4+22.0d0*B**2*SI**2- + # 20.0d0*B**2-15.0d0*SI**2+14))/(16.0d0*B**5*CO*(SI**2-1)) +c + call revf(1,h,mh) +c + return + end +c +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/opti.f b/OpticsJan2020/MLI_light_optics/Src/opti.f new file mode 100755 index 0000000..0664d92 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/opti.f @@ -0,0 +1,1798 @@ +c +c*************************************** +c +c OPTI is an alphabetized collection of the routines in +c NLS, QSO, and SHARED, by Kurt Overley, LANL 89, +c as modified by Tom Mottershead, March 91 +c-------------------------------------------------------- + subroutine condn( maxf,nx,fjac,info) +c +c subroutine condn returns the condition number of the jacobian. +c---------------------------------------------------------------------- + include 'impli.inc' + parameter (epsmach = 1.0d-16) + dimension fjac(maxf,nx) +c + dmax = dabs(fjac(1,1)) + dmin = dmax + do 10 i = 2,nx + diag = dabs(fjac(i,i)) + if (diag .gt. dmax) then + dmax = diag + else if (diag .lt. dmin ) then + dmin = diag + endif + 10 continue + rcond = dmin / dmax + if (rcond .lt. epsmach) info = 5 + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + double precision function enorm(n,x) + integer n + double precision x(n) +c ********** +c +c function enorm +c +c given an n-vector x, this function calculates the +c euclidean norm of x. +c +c the euclidean norm is computed by accumulating the sum of +c squares in three different sums. the sums of squares for the +c small and large components are scaled so that no overflows +c occur. non-destructive underflows are permitted. underflows +c and overflows do not occur in the computation of the unscaled +c sum of squares for the intermediate components. +c the definitions of small, intermediate and large components +c depend on two constants, rdwarf and rgiant. the main +c restrictions on these constants are that rdwarf**2 not +c underflow and rgiant**2 not overflow. the constants +c given here are suitable for every known computer. +c +c the function statement is +c +c double precision function enorm(n,x) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c subprograms called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i + double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, + & x1max,x3max,zero + data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ + save one,zero,rdwarf,rgiant !cryne 7/23/2002 + s1 = zero + s2 = zero + s3 = zero + x1max = zero + x3max = zero + floatn = n + agiant = rgiant/floatn + do 90 i = 1, n + xabs = dabs(x(i)) + if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 + if (xabs .le. rdwarf) go to 30 +c +c sum for large components. +c + if (xabs .le. x1max) go to 10 + s1 = one + s1*(x1max/xabs)**2 + x1max = xabs + go to 20 + 10 continue + s1 = s1 + (xabs/x1max)**2 + 20 continue + go to 60 + 30 continue +c +c sum for small components. +c + if (xabs .le. x3max) go to 40 + s3 = one + s3*(x3max/xabs)**2 + x3max = xabs + go to 50 + 40 continue + if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 + 50 continue + 60 continue + go to 80 + 70 continue +c +c sum for intermediate components. +c + s2 = s2 + xabs**2 + 80 continue + 90 continue +c +c calculation of norm. +c + if (s1 .eq. zero) go to 100 + enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) + go to 130 + 100 continue + if (s2 .eq. zero) go to 110 + if (s2 .ge. x3max) + & enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) + if (s2 .lt. x3max) + & enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3))) + go to 120 + 110 continue + enorm = x3max*dsqrt(s3) + 120 continue + 130 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine findhi( dmuhi, ld, n, h, hmu, + & g, step, region, info) +c +c subroutine findhi finds the upper value of the levenberg-marquardt +c parameter that brackets the root of the nonlinear equation, +c phi = region - stepnm. +c-------------------------------------------------------- + include 'impli.inc' + dimension h(ld,n), hmu(ld,n) + dimension g(n), step(n) +c + 10 continue + do 20 i = 1,n + call vecopy( n, h(1,i), hmu(1,i)) + hmu(i,i) = h(i,i) + dmuhi + 20 continue + call newton( ld, n, hmu, g, step, info) + if ( info .gt. 0) return + stepnm = enorm(n, step) + if (stepnm .gt. region) then + dmuhi = 2.0d0 * dmuhi + go to 10 + endif + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine geta (maxv, maxq, nx, m, a, xu) +c +c subroutine geta forms the linear system in the center of mass +c coordinates whose solution yields the quadratic coefficients. +c--------------------------------------------------------------- + include 'impli.inc' + dimension a(maxq,m), xu(maxv, m) +c + do 10 k = 1, m + a(k,1) = 1.0 + do 20 i = 1, nx + a(k,i+1) = xu(i,k) + if ( (i+1+nx) .gt. m) go to 20 + a(k,i+1+nx) = xu(i,k)**2 + 20 continue + 25 indexa = 2 * nx + 1 + do 30 i = 1, nx-1 + do 40 j = i+1,nx + indexa = indexa + 1 + if (indexa .gt. m) go to 10 + a(k,indexa) = xu(i,k) * xu(j,k) + 40 continue + 30 continue + 10 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine gradck( n, sgrad, grel, sigma, fv, tol, info) +c +c subroutine gradck provides the main stopping criterion for +c oracle. +c------------------------------------------------------------------ + include 'impli.inc' + dimension sgrad(n), sigma(n) +c + grel = 0 + fmag = dmax1(dabs(fv), 1.0d0) + do 10 i = 1,n + grcomp = dabs( sgrad(i)*dmax1(sigma(i), 1.0d0))/fmag + grel = dmax1( grel, grcomp) + 10 continue + if (grel .lt. tol) info = 9 + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine hesian( ld, nx, h, g, nq, q) +c +c subroutine hesian forms the hessian matrix and the gradient vector +c from the vector of the quadratic coefficients. +c------------------------------------------------------ + include 'impli.inc' + dimension h(ld,nx), g(nx), q(nq) +c + do 10 i = 1, nx + g(i) = - q(i+1) + h(i,i) = 2.0d0 * q(i+1+nx) + 10 continue + indexq = 2*nx + 1 + do 20 i = 1, nx-1 + do 30 j = i+1, nx + indexq = indexq + 1 + h(i,j) = q(indexq) + h(j,i) = h(i,j) + 30 continue + 20 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine initq( m, nx, q) +c +c subroutine initq sets the initial vector of quadratic coefficients +c so that the hessian will start as the identity. +c--------------------------------------------------- + include 'impli.inc' + dimension q(m) +c + do 10 i=1,m + if ( (i .gt. (1+nx)) .and. (i .le. (1+2*nx))) then + q(i) = 0.5 + else + q(i) = 0.0 + endif + 10 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine optisort( iter, dist, nseq, nq) +c +c sorts the first nq entries of the nseq to the +c list of distances from nearest to farthest. +cryne 8/17/02 name changed from isort to optisort because isort +cryne is a name found in a widely used library. +c--------------------------------------------------------------------- + include 'impli.inc' + dimension dist(iter), nseq(iter) +c +c initialize nseq array in reverse order to lessen sorting. +c + do 10 i=1,iter + nseq(i) = iter + 1 - i + 10 continue +c +c make nq passes through the nseq list, sorting on distance. +c + do 20 j=1,nq + do 30 k= j+1, iter + if ( dist(nseq(k)) .lt. dist(nseq(j)) ) then +c +c switch indices. +c + itemp = nseq(j) + nseq(j) = nseq(k) + nseq(k) = itemp + endif + 30 continue + 20 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine jtjmul( ldj,ldjtj,nc,fjac,fjtj) +c +c subroutine jtjmul multiplies the jacobian transpose times the jacobian +c----------------------------------------------------------------------- + include 'impli.inc' + dimension fjac(ldj,nc), fjtj(ldjtj,nc) + parameter (maxv = 10) + dimension temp(maxv), tempt(maxv) +c + do 10 i= 1,nc + do 20 j = i,nc + do 30 k=1,nc + temp(k) = 0.0 + tempt(k) = 0.0 + 30 continue + call vecopy(i,fjac(1,i),tempt) + call vecopy(j,fjac(1,j),temp) + fjtj(i,j) = ddot(nc, tempt, 1, temp, 1) + fjtj(j,i) = fjtj(i,j) + 20 continue + 10 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine lform(maxv,maxf,nx,nf,nq,xu,fu,fjac,info,rcond) +c +c subroutine lform makes a linear approximation to the list of +c xv points and corresponding fv values. +c------------------------------------------------------------------- + include 'impli.inc' + dimension xu(maxv, nq), fu(maxf,nq) + dimension fjac(maxf, nx) +c + parameter (nxdim = 10, maxq = nxdim+1, epsmach = 1.0d-16) + dimension a(nxdim, nxdim), ascale(nxdim) + dimension y(nxdim), ipvt(nxdim), w(nxdim) +c + call nlsa(maxv, nx, nq, a, xu) + call scale(nxdim, nx, ascale, a, info) + if (info .ne. 0) return + call dgeco(a,nxdim,nx,ipvt,rcond,w) + if (rcond .lt. epsmach) then + info = 4 + return + endif + do 10 i = 1,nf + call dcopy(nx,fu(i,2),maxf,y,1) + call dgesl(a,nxdim,nx,ipvt,y,0) + do 20 j= 1,nx + fjac(i,j) = y(j) * ascale(j) + 20 continue + 10 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine lpick(nxmax,nfmax,nx,nf,nvec,iter,xu,fcen,fmu,fu) +c +c subroutine lpick selects the xu from among all xv points by +c choosing the best point, xcen, and the nvec - 1 nearest points +c to xcen. +c-------------------------------------------------------------------- + include 'impli.inc' +cryne 3/15/06 include 'nlsvar.inc' +cryne 3/15/06 here is nlsvar.inc: + + parameter (maxdat = 1000) + parameter (maxv = 10, maxf = 15, maxq = maxv+1 ) + common /nlsvar/ modu, ntot, nomin, minpt, maxpt, nlsi, fmin, + * fmax, regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), + * fdat(maxf,maxdat), fmdat(maxdat), fvmin(maxf), xcen(maxv) +cryne 3/15/06 save /nlsvar/ + + dimension xu(nxmax,nvec), fu(nfmax,nvec), fmu(nvec), fcen(nf) + dimension dist(maxdat), nseq(maxdat), xdif(maxv) + +cryne 3/15/06 + save +c +c write(6,*)'HEEEEEEERRRRRREEEEE I am in LPICK' + do 10 k = 1,iter + call vecdif(nx, xdat(1,k), xcen, xdif) + dist(k) = enorm(nx, xdif) + 10 continue + call optisort( iter, dist, nseq, nvec) +c +c check that the current point is included in the list +c + do 20 k=1,nvec + if(nseq(k).eq.iter) go to 30 + 20 continue +c +c didn't find current point (iter) in the list, so force it +c by replacing worst of the points already chosen: +c + nseq(nvec) = iter +c +c copy the selected points into the working vectors xu. The +c origin is taken as xcen. +c + 30 do 40 k = 1, nvec + nu = nseq(k) + call vecdif( nx, xdat(1,nu), xcen, xu(1,k)) + call vecdif( nf, fdat(1,nu), fcen, fu(1,k)) + fmu(k) = fmdat(nu) + 40 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine message(info,ipr) +c +c subroutine message prints out termination messages in the file +c qout.dat. +c--------------------------------------------------------------------- + include 'impli.inc' + parameter (epsmach = 1.0d-16, epsqrt = 1.0d-8) +c + write(ipr,*) + write(ipr,*) 'done' + if (info .eq. 1) then + write(ipr,*) 'the relative difference between ' + write(ipr,*) 'predicted and actual f values agree within ', + & epsqrt + else if (info .eq. 2) then + write(ipr,*) 'the relative norm of the difference between' + write(ipr,*) 'the last two x vectors lies within stol.' + else if (info .eq. 3) then + write(ipr,*) 'the relative norm of the difference between' + write(ipr,*) 'the last two q vectors lies within stol.' + else if (info .eq. 4) then + write(ipr,*)'exit due to ill-conditioning of the q-coefficient' + write(ipr,*) 'matrix, a. ' + else if (info .eq. 5) then + write(ipr,*) 'exit due to ill-conditioning of the hessian.' + else if (info .eq. 6) then + write(ipr,*)'exit due to attempted step of enormous magnitude.' + write(ipr,*)'If using mss, try increasing parameter 4' + else if (info .eq. 7) then + write(ipr,*) 'absolute f error lies within ',epsqrt + else if (info .eq. 8) then + write(ipr,*) 'absolute x error lies within stol.' + else if (info .eq. 9) then + write(ipr,*) 'relative gradient is less than gtol.' + else if (info .eq. 10) then + write(ipr,*) 'maximum number of iterations exceeded.' + else if (info .eq. 11) then + write(ipr,*) 'norm of residual lies within ftol.' + else if (info .eq. 12) then + write(ipr,*) 'successive steps have an identical component.' + else if (info .eq. 13) then + write(ipr,*) 'one of user-specified weights is zero.' + else if (info .eq. 14) then + write(ipr,*) '# of equations is less than # of unkowns.' + endif + return + end +c +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine mvmult(lda,nr,nc,a,x,result) +c +c subroutine mvmult multiplies a vector, x, by a matrix, a. +c----------------------------------------------------------------------- + include 'impli.inc' + dimension a(lda,nc), x(nc), result(nr) + parameter (maxv = 10) + dimension xtemp(maxv) +c + call vecopy( nc, x, xtemp) + do 10 i = 1, nr + result(i) = ddot(nc, a(i,1), lda, xtemp, 1) + 10 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine newton( ld, nv, h, g, step, info) +c +c subroutine newton calculates the newton step from the best point, xce +c which is now the origin in the transformed frame of reference. +c----------------------------------------------------------------------- + include 'impli.inc' + parameter (maxv = 10, epsmach = 1.0d-16) + dimension h(ld,nv), g(nv), step(nv) + dimension w(maxv), ipvt(maxv), ht(maxv,maxv) +c + do 10 i= 1,nv + call vecopy( nv, h(1,i), ht(1,i)) + 10 continue + call dsico( ht, maxv, nv, ipvt, rcond, w) + if (rcond .lt. epsmach) then + info = 5 + return + endif + call vecopy(nv, g, step) + call dsisl( ht, maxv, nv, ipvt, step) + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine nls(mode,iter,nx,xv,nf,fv,iscale,wts,tol,info) +c +c subroutine nls solves nonlinear equations and least squares problems. +c +c written by tom mottershead and kurt overley of los alamos national +c laboratory in august 1989. +c +c +c variables: +c +c --> mode: running mode. +c = 0 for normal unconstrained minimization +c = 1 for constrained minimization in the box defined by +c (xlo(i),xhi(i)), i=1,nx +c = 2 to reload internal data commons and return without +c computing new point. +c = 3 for inquiry. The best point so far is returned in +c (xv,fv), its index is returned in iter, and the tota +c points stored is returned as info = - ntot +c +c --> iter: the iteration counter. should be incremented before ever +c call in normal running. +c iter = +n means (xv,fv) is stored and used as nth data +c iter = 0 or 1 causes initialization, clearing stored da +c iter = -n means return nth stored point in (xv,fv) +c +c --> nx: the number of variables. +c +c <--> xv(nx): the current point on input, the new point on output. +c +c <--> fv: the residual vector of function values at the current poi +c on input. +c +c --> iscale: controls x and f scaling. +c iscale = 0: no scaling. this is the recommended +c default value. if unsatisfactory performa +c results, the problem may be poorly scaled +c try the various scalings. +c iscale = 1: auto x scaling +c iscale = 2: auto f scaling +c iscale = 3: auto x and f scaling +c iscale = 4: scale f with wts, no x scaling +c iscale = 5: scale f with wts, auto x scaling +c +c --> wts(nf): a vector of weights to scale f. f(j) is replaced +c by w(j)*f(j). +c +c --> tol(j), j=1,4 +c tol(1) = gtol: if the relative gradient lies within the +c tolerance, gtol, nls exits. +c tol(2) = stol: nls exits if the absolute or relative +c difference between the the suggested minimizer, +c xnew, and the current point, xc, is less +c than stol. +c tol(3) = ftol: if the magnitude of the residual f vector +c is less than ftol, qadnls exits. +c tol(4) = initial step fraction stpfrc (default = 0.1) +c +c <-- info: on return info contains information as to the +c termination status of nls. +c info = 0: no termination yet. +c = 1: the relative difference between the predicted +c and actual values agrees within ftol. +c = 2: the relative difference between the last two +c xv vectors lies within stol. +c = 3: the relative difference between the last two +c q vectors lies within qtol. +c = 4: exit due to ill-conditioning of the q-coeffici +c matrix, a. +c = 5: exit due to ill-conditioning of the hessian. +c = 6: exit due to attempted step of enormous magnitu +c = 7: absolute fv error lies within ftol. +c = 8: absolute xv error lies within stol. +c = 9: relative gradient is less than gtol. +c = 10: maximum iterations exceeded (this must be +c determined by the program calling nls). +c = 11: absolute norm of residual function vector lie +c within ftol. +c = 12: successive steps have an identical x componen +c = 13: one of the user-specified weights is zero. +c = 14: number of equations is less than number of un +c +c parameters: +c +c maxv: the maximum number of variables allowed. +c +c maxf: the maximum number of equations allowed. +c +c maxq: the maximum number of points needed for fitting to a +c quadratic form. +c +c maxdat: the maximum number of points that can be stored. +c +c epsmach: the machine precision. +c +c gtol: the relative gradient tolerance. if the current relative +c gradient falls below gtol, nls exits. +c +c stol: the step tolerance. if two successive points lie +c within stol, nls exits. +c +c ftol: the residual tolerance. if the norm of the current residual +c falls below ftol, nls exits. +c +c stpfrc: the initial random steps are of length stpfrc * the +c norm of the current best point. +c +c trfrac: the initial trust region is set to trustfrac times +c the 2 norm of a vector of unit components, representativ +c of an "average" shifted and rms scaled xv vector. +c +c internal variables: +c +c xcen(maxv): the best point so far. it is the center of the linear +c approximation to the nonlinear system. +c +c xu(maxv,maxq): contains a list of the last nv + 1 points. +c +c fu(maxf,maxq): contains a list of the last nv + 1 function vectors +c +c fmu(maxq): the list of previous norms of residual function values. +c +c xdat(maxv,maxdat): the entire list of all points. +c +c fdat(maxf,maxdat): the entire list of all function vectors. +c +c fvmin(maxf): the best function vector so far. +c +c fcen(maxf): forms the centering function vector for the linear +c approximation to the nonlinear system. it is the same +c as fvmin. +c +c fmdat(maxdat): the entire list of norms of residual function vecto +c +c minpt: location of the minimum fv and xv in the data pool. +c +c maxpt: a pointer to the maximum fv and xv in the list. +c +c a(maxq,maxq): the quadratic coefficient matrix. +c +c ascale(maxq): a scaling vector that normalizes the columns +c of a to unit euclidean norm. +c +c y(maxq): the solution of the scaled a matrix. +c +c q(maxq): the vector of coefficients to the quadratic form. +c +c g(maxv): the gradient vector. +c +c fjac(maxv,maxv): the jacobian of the nonlinear system of equations +c or for nonlinear least squares is the jacobian of +c the norm of the function residual vector. +c +c step(maxv): the trust region newton step (nlstep). +c +c nq = nx+1 : the number of points needed to +c make a linear approximation to the jacobian of the +c norm of the function vector. +c +c nomin: the number of iterations since a new minimum point +c has been found. +c +c region: the region or radius about the current best point +c in which the quadratic model is trusted to accurately +c model the function. +c +c regold: the old trust region. +c +c dmu: the levenberg-marquardt parameter that adjusts the hessian +c to solve the constrained problem of minimizing the quadratic +c form subject to lying in a trust region about the best point. +c +c oldmu: the old levenberg-marquardt parameter. +c +c sgrad: the gradient of the function with respect to a step +c from the minimum point. note that this gradient is +c different from the gradient of fv with respect to xv. +c +c sigma: a vector containing the diagonal elements of a +c scaling matrix used to normalize each of the components of +c xcen to one. +c +c fsigma: a similar scaling vector for the function vectors. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + include 'impli.inc' +cryne 3/15/06 include 'nlsvar.inc' + dimension xv(nx), fv(nf), tol(4), wts(nf) + parameter (epsmach = 1.0d-16) + parameter ( trfrac = 2.0d0) + +cryne 3/15/06 here is nlsvar.inc: + parameter (maxdat = 1000) + parameter (maxv = 10, maxf = 15, maxq = maxv+1 ) + common /nlsvar/ modu, ntot, nomin, minpt, maxpt, nlsi, fmin, + * fmax, regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), + * fdat(maxf,maxdat), fmdat(maxdat), fvmin(maxf), xcen(maxv) +cryne 3/15/06 save /nlsvar/ + + dimension xu(maxv, maxq), xnew(maxv) + dimension fu(maxf, maxq), fmu(maxq), fcen(maxf) + dimension fjac(maxf, maxv), g(maxv) + dimension sigma(maxv), fsigma(maxf), step(maxv) +cryne 3/15/06 + save +c + if (info .gt. 0) return + if (nf .lt. nx) then + info = 14 + return + endif + modu = mode +c +c nq is number of points needed for full linear form. +c nvec is the number available this iteration. +c + nq = nx + 1 + nvec = min0(nq,iter) + if(iter.gt.ntot) ntot=iter + gtol = tol(1) + stol = tol(2) + ftol = tol(3) + stpfrc = 0.1 + if(tol(4).gt.0.0) stpfrc = tol(4) +c type *, ' nls:',nq,'=nq',iter,'=iter',nvec,'=nvec' + if(iter.lt.0) return + if (iter .gt. 1) go to 60 +c +c initialize varibles on first iteration +c + seed = 1.0d0 + grel = 0.0 + fmin = 1.e30 + fmax = -fmin + minpt = 1 + maxpt = 1 + ntot = 0 + nomin = 0 + regold = 0.0 + region = 0.0 + oldmu = 0.0 + dmu = 0.0 + do 10 i = 1,nx + xnew(i) = 0.0 + xcen(i) = 0.0 + g(i) = 0.0 + sigma(i) = 0.0 + step(i) = 0.0 + 10 continue + do 15 i = 1,nf + fcen(i) = 0.0 + fvmin(i) = 0.0 + fsigma(i) = 0.0 + 15 continue + do 20 j = 1,nq + fmu(j) = 0.0 + do 25 i = 1,nf + fu(i,j) = 0.0 + 25 continue + do 30 i = 1,nx + xu(i,j) = 0.0 + 30 continue + 20 continue + do 40 j = 1,maxdat + fmdat(j) = 0.0 + do 45 i = 1,nf + fdat(i,j) = 0.0 + 45 continue + do 50 i = 1,nx + xdat(i,j) = 0.0 + 50 continue + 40 continue +c +c add new xv & fv to the data pool. +c + 60 continue + call vecopy( nx, xv, xdat(1,iter)) + call vecopy( nf, fv, fdat(1,iter)) + call vecopy( nf, fvmin, fcen) + fmerit = 0.5d0 * (enorm( nf,fv) ** 2.0d0) + fmdat(iter) = fmerit +c +c check for new minimum point +c + if(fmerit.lt.fmin) then + fmin = fmerit + minpt = iter + call vecopy(nx,xv,xcen) + call vecopy(nf,fv,fcen) + call vecopy(nf,fv,fvmin) + endif +c +c check for new maximum point +c + if(fmerit.gt.fmax) then + fmax = fmerit + maxpt = iter + endif +c +c random steps about the minimum the first nx times: +c +c write(6,*)'INSIDE NLS with iter, nx=',iter,nx + if (iter .le. nx) then + call ranstep(iter, nx, seed, xcen, xv, stpfrc) + return + endif +c------------------------------------------------------------- +c Normal running: fit and solve the linear approximation when +c there are enough points: +c------------------------------------------------------------- +c +c lpick the best points - xu - to fit to a quadratic form: +c + call lpick(maxv,maxf,nx,nf,nq,iter,xu,fcen,fmu,fu) +c +c normalize the working points - xu +c + if ((iscale.eq.1) .or. (iscale.eq.3) .or. (iscale.eq.5)) then + call nlscal( maxv, nx, nq, nvec, sigma, xu) + endif + if (iscale.ge.2) then + call scalfu( maxf,nf,nq,fsigma,fu,fcen,iscale,wts,info) + endif +c +c determine quadratic form +c + call lform(maxv,maxf,nx,nf,nq,xu,fu,fjac,info,rcond) + if (info .gt. 0) go to 99 +c +c reset trust region +c + call truset(nx, nq, fmu, fpred, fmerit, + & trfrac, iter, nomin, minpt, nvec, regold, region) +c +c compute step on surface of trust region +c + call nlstep(maxf, nx, nf, fjac, fcen, g, step, trfrac, + & nq, iter, regold, region, oldmu, dmu, info) + if (info .gt. 0) go to 99 +c +c compute xnew by adding rescaled step to xcen +c + do 80 i = 1,nx + if ((iscale.eq.1).or.(iscale.eq.3).or.(iscale.eq.5)) then + xnew(i) = xcen(i) + step(i)*sigma(i) + else + xnew(i) = xcen(i) + step(i) + endif + 80 continue +c +c check whether xnew has moved enough to continue the search +c + call xstop(nx, xv, xnew, stol, info) +c +c put xnew in the xv vector for the return + call vecopy(nx, xnew, xv) + if (info .gt. 0) go to 99 +c +c check gradient for convergence +c +cryne not sure I did this right, but here is how I changed this on 29 April 2008: +cryne call gradck( nx, g, grel, sigma, fv, gtol, info) + fvmaxabs=maxval(abs(fv)) + call gradck( nx, g, grel, sigma, fvmaxabs, gtol, info) + if (fmerit .lt. ftol) info = 11 + 99 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine nlsa (maxv, nx, nq, a, xu) +c +c subroutine nlsa forms the linear system in the center of mass +c coordinates whose solution yields the quadratic coefficients. +c--------------------------------------------------------------- + include 'impli.inc' + dimension a(maxv,nx), xu(maxv, nq) +c + do 10 k = 1, nx + call dcopy(nx,xu(1,k+1),1,a(k,1),maxv) + 10 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine nlscal( nxmax, nx, nq, nvec, sigma, xu) +c +c subroutine nlscal finds the rms values of each of the components +c in the xu. then each of the xu vector components is scaled +c by the inverse of the rms values. +c------------------------------------------------------------------ + include 'impli.inc' + dimension sigma(nx), xu(nxmax, nq) +c + tol = 1.d-15 + denom = nvec - 1 +c +c loop over all components +c + do 40 i = 1, nx + sigma(i) = 0.0 +c +c collect standard deviation of all components +c + do 20 j = 2, nvec + sigma(i) = sigma(i) + xu(i,j)**2 + 20 continue + sigma(i) = dsqrt(sigma(i)/ denom) +c +c renormalize all vectors +c + xdenom = dabs(xu(i,2)) + if(xdenom.le.tol) then + sigma(i) = 1.0d0 + go to 40 + else + sigma(i) = xdenom/ sigma(i) + do 30 j = 2, nvec + xu(i,j) = xu(i,j)/sigma(i) + 30 continue + endif + 40 continue + return + end +c +c********************************************************************* +c + subroutine nlstep( mf, nx, nf, fjac, fcen, g, step, trfrac, + & nq, iter, regold, region, oldmu, dmu, info) +c +c nlstep (trust region step) calculates the new xv point that solves th +c constrained problem of minimizing a quadratic functional subject to +c lying in trust region about the best xv point. +c------------------------------------------------------------ + include 'impli.inc' + dimension fjac(mf, nx), g(nx), step(nx), fcen(nf) +c + parameter (maxv = 10, maxf = 15) + dimension fjact(maxv, maxf),fjtj(maxv,maxv),fjtjmu(maxv,maxv) + dimension qraux(maxv), rsd(maxf) +c +c c first try the newton step. +c + factor = -1.0d0 + call dscal(nf, factor, fcen, 1) + call trnsps(maxf,maxv,nf,nx,fjac,fjact) + call mvmult(maxv,nx,nf,fjact,fcen,g) + call dqrdc(fjac,maxf,nf,nx,qraux,jdum,dum,0) + call condn(maxf,nx,fjac,info) + if (info .gt. 0) return + if (nf .eq. nx) then + call dqrsl(fjac,maxf,nf,nx,qraux,fcen,dum,rsd,step,rsd, + & dum,110,info) + else + call vecopy( nx,g,step) + call dposl( fjac,maxf,nx,step) + endif + if ( info .gt. 0) return + stepnm = enorm(nx, step) + regmax = 1.5*region + regmin = 0.75*region + if (stepnm .lt. regmax) then + oldmu = 0.0 + region = stepnm + return + endif +c +c c newton step has failed, so calculate a dmu such that step(dmu) +c c is fairly close to the region. +c + call jtjmul(maxf,maxv,nx,fjac,fjtj) + dmulow = 0.0 + gnorm = enorm(nx, g) + dmuhi = gnorm/ region + call findhi( dmuhi, maxv, nx, fjtj, fjtjmu, + & g, step, region, info) + if (info .gt. 0) return + if (oldmu .eq. 0.0) then + dmu = dmuhi/ 2.0d0 + else + dmu = (regold/ region) * oldmu + endif + if ( (dmu .lt. dmulow) .or. (dmuhi .lt. dmu) ) then + dmu = dmulow + (dmuhi - dmulow)/ 2.0d0 + endif +c +c c at 40 the mu loop begins by calculating a new step. +c + 40 continue + do 30 i = 1,nx + call vecopy( nx, fjtj(1,i), fjtjmu(1,i)) + fjtjmu(i,i) = fjtj(i,i) + dmu + 30 continue + call newton( maxv, nx, fjtjmu, g, step, info) + if (info .gt. 0) return +c call dpofa(fjtjmu,maxv,nx,info) +c if (info .gt. 0) then +c info = 5 +c return +c endif +c call vecopy(nx, g, step) +c call dposl(fjtjmu,maxv,nx,step) + stepnm = enorm(nx, step) + if ( (regmin .lt. stepnm) .and. (stepnm .lt. regmax) ) then + go to 99 + endif +c +c c update the mu bounds and get a new mu. +c + phi = stepnm - region + if (phi .gt. 0.0) then + dmulow = dmu + else + dmuhi = dmu + endif + if (dmuhi .le. dmulow) then + go to 99 + endif + dmu = dmulow + (dmuhi - dmulow)/ 2.0d0 + go to 40 +c +c c at 99 do exit chores. +c + 99 continue + oldmu = dmu + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine qform(maxv, nx, nq, nvec, xu, fu, h, g, info, rcond) +c +c subroutine qform fits a quadratic form (finds the hessian matrix, h, +c and the gradient, g) to the list of xv points and corresponding +c fv values. +c------------------------------------------------------------------- + include 'impli.inc' + dimension xu(maxv, nq), fu(nq) + dimension h(maxv, nx), g(nx) +c + parameter (nxdim = 10, maxq = (nxdim+1)*(nxdim+2)/2) + dimension a(maxq, maxq), ascale(maxq) + dimension y(maxq), q(maxq) +c +c type *, ' qform:',maxv,'=maxv',nx,'=nx',nvec,'=nvec',nq,'=nq' + if (nvec .lt. nq) call initq( nq, nx, q) + call geta(maxv, maxq, nx, nvec, a, xu) +cryne 3/15/06 call scale(maxq, nvec, ascale, a) + call scale(maxq, nvec, ascale, a, info) + call solve(maxq, nvec, a, y, fu, info, rcond) + if (info .gt. 0) return + do 10 i = 1,nvec + q(i) = y(i) * ascale(i) + 10 continue + call hesian(maxv, nx, h, g, nq, q) + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine qso(mode,iter,nx,xv,fv,iscale,tol,info) +c +c subroutine qadmin is an unconstrained minimization routine that employ +c quadratic form fitting with a trust region step control stategy. +c +c written by tom mottershead and kurt overley of los alamos national +c laboratory in august 1988. +c Renamed 22 Mar 91 to QFM = Quadratic Fit Minimizer (at first +c installation in Marylie. Still not happy with name. +c +c variables: +c +c --> mode: running mode. +c = 0 for normal unconstrained minimization +c = 1 for constrained minimization in the box defined by +c (xlo(i),xhi(i)), i=1,nx +c = 2 to reload internal data commons and return without +c computing new point. +c = 3 for inquiry. The best point so far is returned in +c (xv,fv), its index is returned in iter, and the tota +c points stored is returned as info = - ntot +c +c --> iter: the iteration counter. should be incremented before ever +c call in normal running. +c iter = +n means (xv,fv) is stored and used as nth data +c iter = 0 or 1 causes initialization, clearing stored da +c iter = -n means return nth stored point in (xv,fv) +c +c --> nx: the number of variables. +c +c <--> xv(nx): the current point on input, the new point on output. +c +c <--> fv: the function value at the current point on input, the new +c predicted value of the minimun on output +c +c --> iscale: controls x. +c iscale = 0: no scaling. this is the recommended +c default value. if unsatisfactory performa +c results, the problem may be poorly scaled +c try scaling. +c iscale = 1: auto x scaling. +c +c --> tol(j), j=1,4 +c tol(1) = gtol: if the relative gradient lies within the +c tolerance, gtol, qadmin exits. +c tol(2) = stol: qadmin exits if the absolute or relative +c difference between the the suggested minimizer, +c xnew, and the current point, xc, is less +c than stol. +c +c tol(3) = ftol: not used by qadmin, but by nls. +c tol(4) = initial step fraction stpfrc (default = 0.1) +c +c <-- info: on return info contains information as to the +c termination status of qadmin. +c info = 0: no termination yet. +c = 1: the relative difference between the predicted +c and actual values agrees within ftol. +c = 2: the relative difference between the last two +c xv vectors lies within stol. +c = 3: the relative difference between the last two +c q vectors lies within qtol. +c = 4: exit due to ill-conditioning of the q-coeffici +c matrix, a. +c = 5: exit due to ill-conditioning of the hessian. +c = 6: exit due to attempted step of enormous magnitu +c = 7: absolute fv error lies within ftol. +c = 8: absolute xv error lies within stol. +c = 9: relative gradient is less than gtol. +c +c parameters: +c +c maxv: then maximum number of variables allowed. +c +c maxq: the maximum number of points needed for fitting to a +c quadratic form. +c +c maxdat: the maximum number of points that can be stored. +c +c epsmach: the machine precision. +c +c gtol: the relative gradient tolerance. if the current relative +c gradient falls below gtol, qadmin exits. +c +c stol: the step tolerance. if two successive points lie +c within stol, qadmin exits. +c +c ftol: the residual tolerance. if the norm of the current residual +c falls below ftol, qadmin exits. +c +c stpfrc: the initial random steps are of length stpfrc * the +c norm of the current best point. +c +c trfrac: the initial trust region is set to trustfrac times +c the 2 norm of a vector of unit components, representativ +c of an "average" shifted and rms scaled xv vector. +c +c internal variables: +c +c xu(maxv,maxq): contains a list of the last (n+1)(n+2)/2 points. +c +c fu(maxq): the list of previous function values. +c +c xdat(maxv,maxdat): the entire list of all points. +c +c fdat(maxdat): the entire list of function values. +c +c minpt: location of the minimum fv and xv in the data pool. +c +c maxpt: a pointer to the maximum fv and xv in the list. +c +c a(maxq,maxq): the quadratic coefficient matrix. +c +c ascale(maxq): a scaling vector that normalizes the columns +c of a to unit euclidean norm. +c +c y(maxq): the solution of the scaled a matrix. +c +c q(maxq): the vector of coefficients to the quadratic form. +c +c h(maxv,maxv): the second derivative hessian matrix. +c +c g(maxv): the gradient vector. +c +c step(maxv): the trust region newton step (trstep). +c +c nq = (nx+1)*(nx+2)/2 : the number of points needed to +c determine a quadratic form. +c +c nomin: the number of iterations since a new minimum point +c has been found. +c +c region: the region or radius about the current best point +c in which the quadratic model is trusted to accurately +c model the function. +c +c regold: the old trust region. +c +c dmu: the levenberg-marquardt parameter that adjusts the hessian +c to solve the constrained problem of minimizing the quadratic +c form subject to lying in a trust region about the best point. +c +c oldmu: the old levenberg-marquardt parameter. +c +c sgrad: the gradient of the function with respect to a step +c from the minimum point. note that this gradient is +c different from the gradient of fv with respect to xv. +c +c sigma: a vector containing the diagonal elements of a +c scaling matrix used to normalize each of the components of +c xcen to one. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + include 'impli.inc' +cryne--- 23 March 2006 include 'minvar.inc' + parameter ( maxdat = 1000) + parameter (maxv = 10, maxq = (maxv+1)*(maxv+2)/2 ) + common /minvar/ jtyp, modu, ntot, nomin, minpt, maxpt, fmin, fmax, + * regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), fdat(maxdat) +cryne save /minvar/ +cryne--- + dimension xv(nx), tol(4) + parameter (epsmach = 1.0d-16) + parameter ( trfrac = 2.0d0) + dimension xu(maxv, maxq), fu(maxq), xcen(maxv), xnew(maxv) + dimension h(maxv, maxv), g(maxv) + dimension sigma(maxv), step(maxv) +cryne--- 23 march 2006: + save +c + write(6,*)'------****-----INSIDE QSO with iter=',iter +c + if (info .gt. 0) return + modu = mode +c +c nq is number of points needed for full quadratic form. +c nvec is the number available this iteration. +c + nq = (nx + 1)*(nx + 2)/2 + nvec = min0(nq,iter) + if(iter.gt.ntot) ntot=iter + stol = tol(1) + gtol = tol(2) + stpfrc = 0.1 + if(tol(4).gt.0.0) stpfrc = tol(4) +c type *, ' qadmin:',nq,'=nq',iter,'=iter',nvec,'=nvec' + if(iter.lt.0) return + if (iter .gt. 1) go to 60 +c +c initialize varibles on first iteration +c + seed = 1.0d0 + grel = 0.0 + fmin = 1.e30 + fmax = -fmin + minpt = 1 + maxpt = 1 + ntot = 0 + nomin = 0 + regold = 0.0 + region = 0.0 + oldmu = 0.0 + dmu = 0.0 + do 10 i = 1,nx + xnew(i) = 0.0 + xcen(i) = 0.0 + g(i) = 0.0 + sigma(i) = 0.0 + step(i) = 0.0 + 10 continue + do 20 j = 1,nq + fu(j) = 0.0 + do 30 i = 1,nx + xu(i,j) = 0.0 + 30 continue + 20 continue + do 40 j = 1,maxdat + fdat(j) = 0.0 + do 50 i = 1,nx + xdat(i,j) = 0.0 + 50 continue + 40 continue +c +c add new xv & fv to the data pool. +c + 60 continue + call vecopy( nx, xv, xdat(1,iter)) + fdat(iter) = fv +c +c check for new minimum point +c + if(fv.lt.fmin) then + fmin = fv + minpt = iter + call vecopy(nx,xv,xcen) + endif +c +c check for new maximum point +c + if(fv.gt.fmax) then + fmax = fv + maxpt = iter + endif +c +c random steps about the minimum the first nx times: +c + if (iter .le. nx) then + call ranstep(iter, nx, seed, xcen, xv, stpfrc) + return + endif +c------------------------------------------------------------- +c Normal running: fit and solve the quadratic form when +c there are enough points: +c------------------------------------------------------------- +c +c select the best points - xu - to fit to a quadratic form: +c + call bestpt(maxv,nx,nvec,iter,xcen,xu,fu) +c +c normalize the working points - xu +c + if (iscale .eq. 1) then + call scalxu( maxv, nx, nq, nvec, sigma, xu) + endif +c +c determine quadratic form +c + call qform(maxv, nx, nq, nvec, xu, fu, h, g, info, rcond) + if (info .gt. 0) go to 99 +c +c reset trust region +c + call truset(nx, nq, fu, fpred, fv, + & trfrac, iter, nomin, minpt, nvec, regold, region) +c +c compute step on surface of trust region +c + call trstep(maxv, nx, h, g, step, trfrac, + & nq, iter, regold, region, oldmu, dmu, info) + if (info .gt. 0) go to 99 +c +c compute xnew by adding rescaled step to xcen +c + do 80 i = 1,nx + if (iscale .eq. 1) then + xnew(i) = xcen(i) + step(i)*sigma(i) + else + xnew(i) = xcen(i) + step(i) + endif + 80 continue +c +c check whether xnew has moved enough to continue the search +c + call xstop(nx, xv, xnew, stol, info) +c +c put xnew in the xv vector for the return + call vecopy(nx, xnew, xv) + if (info .gt. 0) go to 99 +c +c check gradient for convergence +c + call gradck( nx, g, grel, sigma, fv, gtol, info) + 99 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine ranstep( iter, nv, seed, xcen, xnew, stpfrc) +c +c subroutine ranstep generates the first n+1 points by taking random +c steps from the current best point. note there is no protection +c for components of xnew to remain positive. +c-------------------------------------------------------------------- + include 'impli.inc' + dimension xcen(nv), xnew(nv) +c +c + call vecopy( nv, xcen, xnew) + do 10 i=1,nv +c seed = ran( idint( seed*1.0d8 + 1.0d0) ) +c xnew(i) = seed - 0.5d0 + call random_number(x) +c write(6,*)'i,x=',i,x + xnew(i) = x - 0.5d0 + 10 continue + cnorm = enorm(nv, xnew) + xnorm = enorm(nv, xcen) + if (xnorm .eq. 0.) then + dnv = nv + xnorm = dsqrt(dnv) + endif + factor = stpfrc * xnorm/cnorm +c write(6,*)'cnorm,xnorm=',cnorm,xnorm +c write(6,*)'stpfrc,factor=',stpfrc,factor + do 20 i=1,nv + xnew(i) = xcen(i) + factor * xnew(i) + 20 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine scale(ld, n, vscale, dmat, info) +c +c subroutine scale scales a matrix so its columns have unit norm. +c---------------------------------------------------------------- + include 'impli.inc' + dimension vscale(n), dmat(ld,ld) +c + do 10 i = 1,n + denom = enorm(n, dmat(1,i)) + if (denom .eq. 0.) then + info = 12 + return + endif + vscale(i) = 1.0d0/denom + 10 continue + do 30 i = 1,n + do 40 j = 1,n + dmat(j,i) = dmat(j,i) * vscale(i) + 40 continue + 30 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine scalfu( nfmax, nf, nq, fsigma, fu, fcen, + & iscale, wts, info) +c +c subroutine scalfu scales the list of function vectors using the same +c automatic scaling as the x points or else the user-specified weight +c vector. +c---------------------------------------------------------------------- + include 'impli.inc' + dimension fsigma(nf), fu(nfmax, nq), fcen(nf), wts(nf) +c + if (iscale.ge.4) then + do 20 i=1,nf + if (wts(i) .eq. 0.0) then + info = 13 + return + endif + fsigma(i) = 1.0d0/ wts(i) + do 30 j = 2, nq + fu(i,j) = fu(i,j)/ fsigma(i) + 30 continue + 20 continue + else + call nlscal( nfmax, nf, nq, nq, fsigma, fu) + endif + do 10 i = 1,nf + fcen(i) = fcen(i)/ fsigma(i) + 10 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine scalxu( nxmax, nx, nq, nvec, sigma, xu) +c +c subroutine scalxu finds the rms values of each of the components +c in the xu. then each of the xu vector components is scaled +c by the inverse of the rms values - i.e. normalized to unit variance. +c------------------------------------------------------------------ + include 'impli.inc' + dimension sigma(nx), xu(nxmax, nq) +c + tol = 1.d-15 + denom = nvec - 1 +c +c loop over all components +c + do 40 i = 1, nx + sigma(i) = 0.0 +c +c collect standard deviation of all components +c + do 20 j = 2, nvec + sigma(i) = sigma(i) + xu(i,j)**2 + 20 continue + sigma(i) = dsqrt(sigma(i)/ denom) +c +c renormalize all vectors to unit variance +c + if(sigma(i).le.tol) go to 40 + do 30 j = 2, nvec + xu(i,j) = xu(i,j)/sigma(i) + 30 continue + 40 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine bestpt(nxmax,nx,nvec,iter,xcen,xu,fu) +c +c subroutine bestpt selects the xu from among all xv points by +c choosing the best point, xcen, and the nvec - 1 nearest points +c to xcen. +c-------------------------------------------------------------------- + include 'impli.inc' +cryne--- 23 March 2006 include 'minvar.inc' + parameter ( maxdat = 1000) + parameter (maxv = 10, maxq = (maxv+1)*(maxv+2)/2 ) + common /minvar/ jtyp, modu, ntot, nomin, minpt, maxpt, fmin, fmax, + * regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), fdat(maxdat) +cryne save /minvar/ +cryne--- + dimension xu(nxmax,nvec), fu(nvec), xcen(nx) + dimension dist(maxdat), nseq(maxdat), xdif(maxv) +cryne--- 23 march 2006: + save +c + do 10 k = 1,iter + call vecdif(nx, xdat(1,k), xcen, xdif) + dist(k) = enorm(nx, xdif) + 10 continue + call optisort( iter, dist, nseq, nvec) +c +c check that the current point is included in the list +c + do 20 k=1,nvec + if(nseq(k).eq.iter) go to 30 + 20 continue +c +c didn't find current point (iter) in the list, so force it +c by replacing worst of the points already chosen: +c + nseq(nvec) = iter +c +c copy the selected points into the working vectors xu. The +c origin is taken as xcen. +c + 30 do 40 k = 1, nvec + nu = nseq(k) + call vecdif( nx, xdat(1,nu), xcen, xu(1,k)) + fu(k) = fdat(nu) + 40 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine solve(ld, n, dmat, dx, data, info, rcond) +c +c subroutine solve uses the linpack subroutine dgeco and dgesl to +c solve a general linear system. +c---------------------------------------------- + include 'impli.inc' + dimension dmat(ld,ld), dx(n), data(n) + parameter (maxv = 10, maxq = (maxv+1)*(maxv+2)/2 ) + parameter (epsmach = 1.0d-16) + dimension w(maxq), ipvt(maxq), tempd(maxq,maxq) +c + do 10 i = 1,n + call vecopy( n, dmat(1,i), tempd(1,i)) + 10 continue + call dgeco( tempd, maxq, n, ipvt, rcond, w) + if (rcond .lt. epsmach) then + info = 4 + return + endif + call vecopy( n, data, dx) + call dgesl( tempd, maxq, n, ipvt, dx, 0) + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine trnsps( lda, ldat, nr, nc, a, at) +c +c subroutine trnsps transposes a matrix. +c----------------------------------------------------------------------- + include 'impli.inc' + dimension a(lda,nc), at(ldat,nr) +c + do 10 i = 1,nc + call dcopy(nr, a(1,i),1,at(i,1),ldat) + 10 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine trstep( ld, nx, h, g, step, trfrac, + & nq, iter, regold, region, oldmu, dmu, info) +c +c trstep (trust region step) calculates the new xv point that solves th +c constrained problem of minimizing a quadratic functional subject to +c lying in trust region about the best xv point. +c------------------------------------------------------------ + include 'impli.inc' + dimension h(ld,nx), g(nx), step(nx) +c + parameter (maxv = 10) + dimension hmu(maxv,maxv) +c +c c first try the newton step. +c + call newton( ld, nx, h, g, step, info) + if ( info .gt. 0) return + stepnm = enorm(nx, step) +c if (iter .eq. nq) then +c region = stepnm +c endif + regmax = 1.5*region + regmin = 0.75*region + if (stepnm .lt. regmax) then + oldmu = 0.0 + region = stepnm + return + endif +c +c c newton step has failed, so calculate a dmu such that step(dmu) +c c is fairly close to the region. +c + dmulow = 0.0 + gnorm = enorm(nx, g) + dmuhi = gnorm/ region + call findhi( dmuhi, maxv, nx, h, hmu, + & g, step, region, info) + if (info .gt. 0) return + if (oldmu .eq. 0.0) then + dmu = dmuhi/ 2.0d0 + else + dmu = (regold/ region) * oldmu + endif + if ( (dmu .lt. dmulow) .or. (dmuhi .lt. dmu) ) then + dmu = dmulow + (dmuhi - dmulow)/ 2.0d0 + endif +c +c c at 40 the mu loop begins by calculating a new step. +c + 40 continue + do 30 i = 1,nx + call vecopy( nx, h(1,i), hmu(1,i)) + hmu(i,i) = h(i,i) + dmu + 30 continue + call newton( ld, nx, hmu, g, step, info) + if ( info .gt. 0) return + stepnm = enorm(nx, step) + if ( (regmin .lt. stepnm) .and. (stepnm .lt. regmax) ) then + go to 99 + endif +c +c c update the mu bounds and get a new mu. +c + phi = stepnm - region + if (phi .gt. 0.0) then + dmulow = dmu + else + dmuhi = dmu + endif +c call vecopy( nx, step, temp) +c call dsisl( hmu, maxv, nx, ipvt, temp) +c phip = ddot( nx, step, 1, temp, 1) / stepnm + if (dmuhi .le. dmulow) then + go to 99 + endif +c if (phip .ne. 0.) then +c dmu = dmu - (stepnm/ region) * (phi/ phip) +c endif + dmu = dmulow + (dmuhi - dmulow)/ 2.0d0 +c if ( (dmu .lt. dmulow) .or. (dmuhi .lt. dmu) ) then +c dmu = dmulow + (dmuhi - dmulow)/ 2.0d0 +c endif + go to 40 +c +c c at 99 do exit chores. +c + 99 continue + oldmu = dmu + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine truset(nv, nq, fmu, fpred, fmerit, + & trfrac, iter, nomin, minpt, maxpt, regold, region) +c +c subroutine truset updates the size of the trust region. if the +c current fv value is less than the previous best, than the trust regio +c doubles. the trust region will also double if the current function +c value is within 10% of the predicted function value. if the fv value +c worse than the previous worst, the trust region halves. +c +c function values which lie between the best and worst function values +c cause no change in the size of the trust region for n iterations. +c thereafter, each in-between function value halves the trust region. +c +c the reason n iterations are allowed without effect is to keep at leas +c n function evaluations within the current trust region, to avoid the +c problem of allowing the trust region to shrink so far that all the +c other points besides xcen lie outside. the latter situation is +c undesirable because the model that we "trust" is determined by points +c that lie outside the region in which we trust the model, a glaring +c contradiction. +c--------------------------------------------------------------------- + include 'impli.inc' + dimension fmu(nq) +c + regold = region + if ( iter .eq. (nv+1)) then + dnv = nv + region = trfrac * dsqrt(dnv) + return + else if ( fmerit .le. fmu(1) ) then + region = 2.0d0 * regold + nomin = 0 + else + nomin = nomin + 1 +c if ( relerr(1, fv, fpred) .lt. 1.0d-1) then +c region = 2.0d0 * regold + if (nomin .ge. nv) then + region = regold / 2.0d0 + else if ( fmerit .ge. fmu(maxpt) ) then + region = regold / 2.0d0 + endif + endif + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine vecdif(n, v1, v2, dif) +c +c subroutine vecdif subtracts two vectors. +c------------------------------------------------- + include 'impli.inc' + dimension v1(n), v2(n), dif(n) +c + do 10 i = 1,n + dif(i) = v1(i) - v2(i) + 10 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine vecopy( n, xin, xout) + include 'impli.inc' + dimension xin(n), xout(n) +c + do 10 i=1,n + xout(i) = xin(i) + 10 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine xstop( n, xv, xnew, tol, info) +c +c subroutine xstop determines whether current xv and the new xv lie +c within the specified tolerance, either absolutely or relatively. +c------------------------------------------------------------------ + include 'impli.inc' + parameter (maxv = 10, maxq = (maxv+1)*(maxv+2)/2 ) + dimension xv(n), xnew(n), xdif(maxv) + call vecdif(n, xv, xnew, xdif) +c +c check absolute difference +c + absdif = enorm(n, xdif) + if (absdif .lt. tol) then + info = 8 + return + endif +c +c check for grossly oversized step +c + xnorm = enorm(n, xv) + xnewnm = enorm(n, xnew) + if (xnorm .lt. tol*xnewnm) then + info = 6 + return + endif +c +c check relative step size +c + xnmax = dmax1( xnewnm, xnorm) + reldif = absdif/ xnmax + if (reldif .lt. tol) then + info = 2 + endif + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/optics.f b/OpticsJan2020/MLI_light_optics/Src/optics.f new file mode 100755 index 0000000..f90958c --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/optics.f @@ -0,0 +1,299 @@ + subroutine transit(el,en,h,hm) + use lieaparam, only : monoms + include 'impli.inc' + double precision hm(6,6),h(monoms) + write(6,*)'inside transit; el,en=',el,en +c + call clear(h,hm) +c +c matrix: + do k=1,6 + hm(k,k)=+1.0d0 + enddo + hm(1,2)=el/en + hm(3,4)=el/en +c f4: + h(140)=-0.125d0*el/en**3 + h(149)=-2.d0*0.125d0*el/en**3 + h(195)=-0.125d0*el/en**3 +c f6: + h(714)=-0.0625d0*el/en**5 + h(723)=-3.d0*0.0625d0*el/en**5 + h(769)=-3.d0*0.0625d0*el/en**5 + h(896)=-0.0625d0*el/en**5 + return + end +c +c +c + subroutine interface(enm,enp,b2,b4,b6,h,hm) + use lieaparam, only : monoms +ccccc include 'impli.inc' + implicit none + integer k + double precision enm,enp,b2,b4,b6 + double precision endiff,term1,term2,term3,term4,term5 + double precision term6,term7,term8,term9 + double precision hm(6,6),h(monoms) + write(6,*)'inside interface; enm,enp=',enm,enp + write(6,*)'b2,b4,b6=',b2,b4,b6 +c + endiff=enm-enp + call clear(h,hm) +c +c matrix: + do k=1,6 + hm(k,k)=+1.0d0 + enddo + hm(2,1)=2.d0*b2*endiff + hm(4,3)=2.d0*b2*endiff +c f4: + term1=-endiff/enm*(enm*(2.d0*b2**3-b4) - 2.d0*b2**3*enp) + term2=2.d0*b2**2*endiff/enm + term3=0.5d0*b2*endiff/(enm*enp) +c (q^2)^2 + h(84)=term1 + h(95)=2.d0*term1 + h(175)=term1 +c (q^2)p.q + h(85)=term2 + h(96)=term2 + h(110)=term2 + h(176)=term2 +c (q^2)(p^2) + h(90)=term3 + h(99)=term3 + h(145)=term3 + h(179)=term3 +c f6: + term4=(1.d0/enm**3)*( (b6-6.d0*b2**2*b4+2.d0*b2**5)*enm**4 & + & + (-b6+12.d0*b2**2*b4-4.d0*b2**5)*enm**3*enp & + & -6.d0*b2**2*b4*enm**2*enp**2+4.d0*b2**5*enm*enp**3 & + & -2.d0*b2**5*enp**4 ) + term5=(1.d0/(enm**3*enp))*( & + &(2.d0*b2*b4-4.d0*b2**4)*enm**4+(2.d0*b2*b4+6.d0*b2**4)*enm**3*enp & + &-(4.d0*b2*b4+4.d0*b2**4)*enm**2*enp**2 & + &+6.d0*b2**4*enm*enp**3-4.d0*b2**4*enp**4 ) + term6=0.5d0/(enm**3*enp)*( & + &b4*enm**3-b4*enm**2*enp+2.d0*b2**3*enm*enp**2-2.d0*b2**3*enp**3) + term9=2.d0*b2**3/(enm**3*enp)* & + &(enm**3-enm**2*enp+enm*enp**2-enp**3) + term7=0.5d0*b2**2/(enm**3*enp**2)* & + &(enm**3+enm*enp**2-2.d0*enp**3) + term8=0.125d0*b2/(enm**3*enp**3)*(enm**3-enp**3) +c f6: +c (q^2)^3 + h(462)=term4 + h(473)=3.d0*term4 + h(553)=3.d0*term4 + h(840)=term4 +c (q^2)^2 q.p + h(463)=term5 + h(474)=term5 + h(488)=2.d0*term5 + h(554)=2.d0*term5 + h(623)=term5 + h(841)=term5 +c (q^2)^2 p^2 + h(468)=term6 + h(477)=term6 + h(523)=2.d0*term6 + h(557)=2.d0*term6 + h(749)=term6 + h(844)=term6 +c q^2 p^2 q.p + h(483)=term7 + h(492)=term7 + h(524)=term7 + h(563)=term7 + h(593)=term7 + h(750)=term7 + h(627)=term7 + h(850)=term7 +c q^2 (p^2)^2 + h(518)=term8 + h(527)=2.d0*term8 + h(573)=term8 + h(719)=term8 + h(753)=2.d0*term8 + h(860)=term8 +c q^2 (p.q)^2 + h(468)=h(468)+term9 + h(489)=2.d0*term9 + h(523)=h(523)+term9 + h(557)=h(557)+term9 + h(624)=2.d0*term9 + h(844)=h(844)+term9 + return + end +c +c +c + subroutine rootmap(en,b2,b4,b6,h,hm) + use lieaparam, only : monoms + include 'impli.inc' + double precision hm(6,6),h(monoms) +c + call clear(h,hm) +c +c matrix: + do k=1,6 + hm(k,k)=+1.0d0 + enddo + hm(2,1)=2.d0*b2*en + hm(4,3)=2.d0*b2*en +c f4: + term1=en*(b4-2.d0*b2**3) + term2=2.d0*b2**2 + term3=-0.5d0*b2/en +c (q^2)^2 + h(84)=term1 + h(95)=2.d0*term1 + h(175)=term1 +c (q^2)p.q + h(85)=term2 + h(96)=term2 + h(110)=term2 + h(176)=term2 +c (q^2)(p^2) + h(90)=term3 + h(99)=term3 + h(145)=term3 + h(179)=term3 +c f6: + term4=en*(b6-6.d0*b2**2*b4+2.d0*b2**5) + term5=4.d0*b2*b4-2.d0*b2**4 + term6=-0.5d0*b4/en + term7=0.5d0*b2**2/en**2 + term8=-0.125d0*b2/en**3 +c (q^2)^3 + h(462)=term4 + h(473)=3.d0*term4 + h(553)=3.d0*term4 + h(840)=term4 +c (q^2)^2 q.p + h(463)=term5 + h(474)=term5 + h(488)=2.d0*term5 + h(554)=2.d0*term5 + h(623)=term5 + h(841)=term5 +c (q^2)^2 p^2 + h(468)=term6 + h(477)=term6 + h(523)=2.d0*term6 + h(557)=2.d0*term6 + h(749)=term6 + h(844)=term6 +c q^2 p^2 q.p + h(483)=term7 + h(492)=term7 + h(524)=term7 + h(563)=term7 + h(593)=term7 + h(750)=term7 + h(627)=term7 + h(850)=term7 +c q^2 (p^2)^2 + h(518)=term8 + h(527)=2.d0*term8 + h(573)=term8 + h(719)=term8 + h(753)=2.d0*term8 + h(860)=term8 + return + end +c + subroutine optirot(angdeg,ijkind,h,mh) +c +c High order PROT routine. +c Actual code generated by Johannes van Zeijts using +c REDUCE. +c +cryne use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'pie.inc' +c include 'param.inc' +c include 'parm.inc' + double precision l,h(monoms),mh(6,6) +c + dimension j(6) +c + DOUBLE PRECISION B + DOUBLE PRECISION CO + DOUBLE PRECISION Si +c +cryne mods to allow for leading/trailing option: +cryne ijkind=1 for normal-to-rotated, =2 for rotated-to-normal + phideg=angdeg + if(ijkind.eq.2)phideg=-angdeg + +c + call clear(h,mh) +c +cryne B = beta + B = 1.0d0 + phi = phideg*pi180 + SI = SIN(phi) + CO = COS(phi) +c + mh(1,1)=1.0d0/CO + mh(2,2)=CO + mh(2,6)=(-SI)/B + mh(3,3)=1.0d0 + mh(4,4)=1.0d0 + mh(5,1)=SI/(B*CO) + mh(5,5)=1.0d0 + mh(6,6)=1.0d0 +c + h(34) =(-SI)/(2.0d0*CO) + h(43) =(-SI)/(2.0d0*CO) + h(48) =(SI*(B**2-1))/(2.0d0*B**2*CO) + h(105) =SI**2/(4.0d0*(SI**2-1)) + h(109) =(-SI)/(2.0d0*B*CO) + h(114) =SI**2/(4.0d0*(SI**2-1)) + h(119) =(SI**2*(-B**2+1))/(4.0d0*B**2*(SI**2-1)) + h(132) =(-SI)/(2.0d0*B*CO) + h(139) =(SI*(B**2-1))/(2.0d0*B**3*CO) + h(266) =SI/(8.0d0*CO*(SI**2-1)) + h(270) =SI**2/(2.0d0*B*(SI**2-1)) + h(275) =(SI*(-2.0d0*SI**2+3))/(12.0d0*CO*(SI**2-1)) + h(280) =(SI*(2.0d0*B**2*SI**2-3.0d0*B**2-8.0d0*SI**2+9))/( + & 12.0d0*B**2*CO*(SI**2-1)) + h(293) =SI**2/(2.0d0*B*(SI**2-1)) + h(300) =(SI**2*(-B**2+1))/(2.0d0*B**3*(SI**2-1)) + h(321) =(SI*(-4.0d0*SI**2+3))/(24.0d0*CO*(SI**2-1)) + h(326) =(SI*(4.0d0*B**2*SI**2-3.0d0*B**2-10.0d0*SI**2+9))/( + & 12.0d0*B**2*CO*(SI**2-1)) + h(335) =(SI*(-4.0d0*B**4*SI**2+3.0d0*B**4+20.0d0*B**2*SI**2- + & 18.0d0*B**2-16.0d0*SI**2+15))/(24.0d0*B**4*CO*(SI**2-1)) + h(588) =(SI**2*(SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+1)) + h(592) =(SI*(SI**2+6))/(16.0d0*B*CO*(SI**2-1)) + h(597) =(SI**2*(3.0d0*SI**2-4))/(16.0d0*(SI**4-2.0d0*SI**2+ + & 1)) + h(602) =(SI**2*(-3.0d0*B**2*SI**2+4.0d0*B**2+15.0d0*SI**2-16.0d0 + & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) + h(615) =(3.0d0*SI*(-SI**2+2))/(8.0d0*B*CO*(SI**2-1)) + h(622) =(SI*(3.0d0*B**2*SI**2-6.0d0*B**2-7.0d0*SI**2+10))/( + & 8.0d0*B**3*CO*(SI**2-1)) + h(643) =(SI**2*(5.0d0*SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+ + & 1)) + h(648) =(SI**2*(-5.0d0*B**2*SI**2+4.0d0*B**2+17.0d0*SI**2-16.0d0 + & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) + h(657) =(SI**2*(5.0d0*B**4*SI**2-4.0d0*B**4-34.0d0*B**2*SI**2 + & +32.0d0*B**2+29.0d0*SI**2-28))/(32.0d0*B**4*(SI**4-2.0d0*SI**2+ + & 1)) + h(695) =(SI*(-7.0d0*SI**2+6))/(16.0d0*B*CO*(SI**2-1)) + h(702) =(SI*(7.0d0*B**2*SI**2-6.0d0*B**2-11.0d0*SI**2+10))/( + & 8.0d0*B**3*CO*(SI**2-1)) + h(713) =(SI*(-7.0d0*B**4*SI**2+6.0d0*B**4+22.0d0*B**2*SI**2- + & 20.0d0*B**2-15.0d0*SI**2+14))/(16.0d0*B**5*CO*(SI**2-1)) +c + call revf(1,h,mh) +c +cryne this line added Aug 6, 2003: + if(ijkind.eq.2)call inv(h,mh) + return + end +c diff --git a/OpticsJan2020/MLI_light_optics/Src/parallel_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/parallel_mod.f90 new file mode 100755 index 0000000..43ec432 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/parallel_mod.f90 @@ -0,0 +1,57 @@ +module parallel + include 'mpif.h' +! # of processors, processor id + integer ,save :: nvp=1,idproc=0 +! current communicator, MPI datatypes + integer ,save :: lworld,mreal,mcplx,m2real,mntgr +! MPI operators + integer ,save :: mpisum, mpimax, mpimaxloc +! the MPI implementation may require more than one error code + integer ,save ,dimension(MPI_STATUS_SIZE) :: mpistat + + +!cryne Jan 3, 2005 +! The include file "mpi_stubs.inc" contains the mpi stub +! interface files and the mpi stubs themselves. They are +! separated by a line with the word "contains" +! If the code is being run on a parallel machine (so the +! stubs are not needed) then this include file should +! simply consist of a single line with the word "contains" +! (not in quotes, obviously) + include 'mpi_stubs.inc' + + subroutine init_parallel + logical flag + + call MPI_INITIALIZED(flag,mpistat) + if(.not.flag)then + call MPI_INIT(mpistat) + endif + lworld=MPI_COMM_WORLD +! how many processors? + call MPI_COMM_SIZE(lworld,nvp,mpistat) +! get processor id + call MPI_COMM_RANK(lworld,idproc,mpistat) +! in the future, these can be set differently for other precision: + mreal=MPI_DOUBLE_PRECISION + mcplx=MPI_DOUBLE_COMPLEX + m2real=MPI_2DOUBLE_PRECISION + mntgr=MPI_INTEGER +! mntgr=MPI_2INTEGER + mpisum=MPI_SUM + mpimax=MPI_MAX + mpimaxloc=MPI_MAXLOC + end subroutine init_parallel +! + subroutine end_parallel + include 'mpif.h' + logical flag + + call MPI_INITIALIZED(flag,mpistat) + if(flag)then + call MPI_BARRIER(lworld,mpistat) + call MPI_FINALIZE(mpistat) + endif + end subroutine end_parallel + +end module parallel diff --git a/OpticsJan2020/MLI_light_optics/Src/parameters.f90 b/OpticsJan2020/MLI_light_optics/Src/parameters.f90 new file mode 100644 index 0000000..58bed9f --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/parameters.f90 @@ -0,0 +1,10 @@ +MODULE parameters + !--------- -------- --------- --------- --------- --------- --------- --------- ----- + ! Specify data types + !--------- -------- --------- --------- --------- --------- --------- --------- ----- + IMPLICIT NONE + INTEGER, PARAMETER :: rn = KIND(0.0d0) ! Precision of real numbers + INTEGER, PARAMETER :: is = SELECTED_INT_KIND(4) ! Data type of bytecode +END MODULE parameters + + diff --git a/OpticsJan2020/MLI_light_optics/Src/proc.f b/OpticsJan2020/MLI_light_optics/Src/proc.f new file mode 100755 index 0000000..45fc597 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/proc.f @@ -0,0 +1,3328 @@ +c Newest version of proc w/ block data initialization. Berkeley 5/02 +c New version of proc using amdii in fit D-Day June 6 1994 +c + block data prokey + use lieaparam, only : monoms + include 'keyset.inc' +c keyset initialized here. rdr and ctm 5/26/02 + data maxj/2*6,2*monoms,3*6,monoms,250,5,3,6,4/ + data key/'sm','bm', + &'sf','bf', & + &'r(','s(','z(', & + &'f(', & + &'u(', & + &'um', & + &'ls', & + &'rt', & + &'dz', & + &'tx','ty','ts','cx','cy','qx','qy','hh','vv','tt','hv','ht', & + &'vt','ax','bx','gx','ay','by','gy','at','bt','gt','ex','ey','et', & + &'wx','wy','wt','fx','xb','xa','xu','xd','fy','yb','ya','yu','yd', & + &'ft','tb','ta','tu','td','ar'/ + data kask/2*4,5*3,6*2,44*1/ + end +c------------------------------------------- + subroutine aim(pp) +c +c aim allows user selection of map elements to fit +c C. T. Mottershead /AT-6 & L. B. Schweitzer /UCB Dec 86 +c New character controled version July 87 & July 88 +c +c----------------------------------------------------------------------- + use lieaparam, only : monoms + include 'impli.inc' + include 'labpnt.inc' + include 'files.inc' + include 'aimdef.inc' + include 'keyset.inc' + include 'fitbuf.inc' + include 'map.inc' +c + dimension pp(6) + character*1 yn + character*8 word + character*128 card + logical rewind + dimension bufr(4) +c-----!----------------------------------------------------------------! +c write(6,*)'************HERE I AM IN AIM************' + if(jicnt.ne.0) return + keyrms = 11 + ier = 0 + iaim = nint(pp(1)) + infile=nint(pp(2)) + rewind = .true. + if(infile.eq.0) infile = jif + if(infile.eq.jif) rewind = .false. + if(infile.lt.0) then + infile = -infile + rewind = .false. + endif + if(rewind) rewind(infile) + logf = nint(pp(3)) + iquiet = nint(pp(4)) + loon = nint(pp(5)) + if((loon.lt.1).or.(loon.gt.3)) loon = 1 + ksq(loon) = iaim + do 3 j=1,3 + lsq(j,loon) = 0 + 3 continue + isend = nint(pp(6)) + 5 nf = 0 + do 10 j=1,maxf + wts(j,loon) = 1.d0 + 10 continue + go to 45 +c +c help section +c + 20 if(infile.eq.jif) then + write(jof,*) ' ' + write(jof,*) ' Symbols are defined for the following categories:' +c write(jof,*) ' (Enter the catagory number to get help)' + write(jof,*) + &' 1. The current map, the reference trajectory around which the', + &' map has' + write(jof,*) + &' been computed, the arc length, various stored maps, and', + &' maps in buffers.' + write(jof,*) ' 2. Standard quantities derived from the current ma + &p, including tunes,' + write(jof,*) ' chromaticities, anharmonicities, dispersions, a + &nd twiss parameters.' + write(jof,*) ' 3. Beam parameters.' + write(jof,*) ' 4. User calculated quantities.' + write(jof,*) ' -----Select help catagory-----' + ihelp=0 + card = ' ' + read(infile,17,end=45) card + if(card.eq.' ') go to 45 + call txtnum(card,20,1,ng,bufr) + if(ng.gt.0) ihelp = bufr(1) + if((ihelp.gt.0).and.(ihelp.le.4)) go to (25,30,35,40), ihelp + go to 45 + 25 continue + write(jof,*) ' *** Quantities in Map Format ***' + write(jof,*) ' ' + write(jof,*) ' The current transfer map:' + write(jof,*) ' r(i,j) = first order (linear) matrix elements i + &,j=1,6.' + write(jof,*) ' f(i) = Lie polynomial coefficients, i=1,209.' + write(jof,*) ' ' + write(jof,*) + write(jof,*) ' The reference trajectory:' + write(jof,*) + &' rt1,rt2,rt3,rt4,rt5,rt6 = x,px,y,py,t,pt on the reference ', + &'trajectory' + write(jof,*) ' ' + write(jof,*) ' The arc length:' + write(jof,*) ' al = arc length at the current location in', + &' the lattice' + write(jof,*) ' ' + write(jof,*) ' Stored maps in locations 1 through 5:' + write(jof,*) ' sm1(i,j) ... sm5(i,j) = first order (linear) ma + &trix elements i,j=1,6.' + write(jof,*) ' sf1(i) ... sf5(i) = Lie polynomial coefficients + &, i=1,209.' + write(jof,*) ' ' + write(jof,*) ' Result arrays in buffers 1 through 5:' + write(jof,*) ' bm1(i,j) ... bm5(i,j) = first order (linear) ma + &trix elements i,j=1,6.' + write(jof,*) ' bf1(i) ... bf5(i) = Lie polynomial coefficients + &, i=1,209.' + go to 45 + 30 continue + write(jof,*) ' *** Standard quantities computed by COD, TASM + &, and TADM ***' + write(jof,*) ' ' + write(jof,*) ' Tunes:' + write(jof,*) ' tx, ty = horizontal and vertical tunes.' + write(jof,*) ' ts = synchrotron (temporal) tune for a dynam + &ic map,' + write(jof,*) ' or temporal dispersion (eta) for a stat + &ic map.' + write(jof,*) ' ' + write(jof,*) ' Chromaticities:' + write(jof,*) ' cx, cy = horizontal and vertical 1st order chrom + &aticities.' + write(jof,*) ' qx, qy = horizontal and vertical 2nd order (quad + &ratic) chromaticities.' + write(jof,*) ' ' + write(jof,*) ' Anharmonicities:' + write(jof,*) ' hh, vv, tt, hv, ht, vt = second order anharmonic + &ities.' + write(jof,*) ' ' + write(jof,*) ' Dispersions:' + write(jof,*) ' dz1, dz2, dz3, dz4 = first order dispersions for + & the' + write(jof,*) ' transverse phase space coor + &dinates.' + write(jof,*) ' ' + write(jof,*) ' Twiss parameters (zeroth order):' + write(jof,*) ' ax,bx,gx = horizontal alpha, beta, gamma.' + write(jof,*) ' ay,by,gy = vertical alpha, beta, gamma.' + write(jof,*) ' at,bt,gt = temporal alpha, beta, gamma.' + go to 45 + 35 continue + write(jof,*) ' *** Beam Parameters ***' + write(jof,*) ' ' + write(jof,*) ' Particle coordinates from tracking:' +c-----!----------------------------------------------------------------! + write(jof,*) ' z(i,j) = jth component of ith particle in', + & ' tracking buffer.' + write(jof,*) ' ' + write(jof,*) ' Moments (from AMAP):' + write(jof,*) ' s(i,j) = 2nd moments of the beam .' +c-----!----------------------------------------------------------------! + write(jof,*) ' bf1(i) = moments of the beam in standard Lie mon + &omial sequence.' + write(jof,*) ' ' + write(jof,*) ' Emittances (from AMAP):' + write(jof,*) ' ex,ey,et = rms emittances for the x, y, and t pl + &anes.' + write(jof,*) ' wx,wy,wt = eigen emittances for coupled systems. + &' + go to 45 + 40 continue +c-----!----------------------------------------------------------------! + write(jof,*) ' *** User defined quantities computed by USER', + & ' and MERIT routines ***' + write(jof,*) ' ' + write(jof,*) ' u(i) = ucalc(i) for i=1 to 250, stored in common + &/usrdat/' + write(jof,*) ' ' + write(jof,*) ' umi = val(i) for i=1 to 5, computed by user ', + & 'merit functions',' MRT1 through MRT5 and stored in', + & ' common/merit/' + endif +c +c prompt for and read input line +c + 45 if(infile.eq.jif) then + write(jof,*) ' ' + if(iaim.eq.1) write(jof,*) ' Select quantities by entering their s + &ymbols' + if(iaim.eq.2) write(jof,*) ' Enter aim(s) in the form: symbol = t + &arget value' + if(iaim.eq.3) write(jof,*) ' Enter aim(s) in the form: symbol = t + &arget value, weight' + write(jof,*) ' (Enter a # sign when finished, or type help to revi + &ew the defined symbols)' + endif + 50 card = ' ' + 15 read(infile,17,end=200) card(2: ) + 17 format(a) + if(card.eq.' ') go to 50 + call low(card) + ifin = index(card,'#') +c +c scan input line for keywords and numeric values +c + do 150 ku=1,nkeys + nask = kask(ku) + nget = 0 + ntgt = nask + if(iaim.eq.1) nask = nask-1 + if(iaim.eq.3) nask = nask+1 + ju = ku +cryne 20 March 2006 if(ju.gt.12) ju = 12 + if(ju.gt.maxjlen) ju = maxjlen + jmax = maxj(ju) + 60 call keynum(card,key(ku),nask,nget,nloc,bufr) + if(nloc.eq.0) go to 150 +c +c found key(ku) ; check and interpret input +c write(6,*)'FOUND IT: ku, key(ku)=',ku,key(ku) +c + if(nget.ne.nask) go to 60 +c +c scalar variables +c + idu = 0 + jdu = 0 + nsu = 0 +cryne 20 March 2006 if(ku.ge.13) go to 72 + if(ku.ge.(maxjlen+1))then +c write(6,*)'going to 72 with ku=',ku + go to 72 + endif +c write(6,*)'did not go to 72; ku=',ku +c +c stored maps +c + nj = 1 + if(ku.le.4) then + nsu = bufr(1) + nj = 2 + endif + idu = bufr(nj) +c write(6,*)'idu=',idu + imax = jmax + if (ku.eq.7) imax = 999 + if((idu.lt.1).or.(idu.gt.imax)) go to 60 +cryne 20 March 2006 if(jmax.eq.6) then + if(jmax.eq.6 .and. ku.le.7) then + jdu = bufr(nj+1) + if((jdu.lt.1).or.(jdu.gt.jmax)) go to 60 + endif +c +c accept and report the entry +c + 72 if(nf.ge.maxa) then + write(jof,*) maxa,' = maximum aims allowed' + write(jodf,*) maxa,' = maximum aims allowed' + go to 200 + endif +c +c trap and flag rmserr requests +c + if(ku.eq.keyrms) then + lsq(idu,loon) = 1 + write(jof,74) idu + 74 format(' RMS',i1,' enabled') + go to 60 + endif + nf=nf+1 + if(iaim.gt.1) target(nf,loon) = bufr(ntgt) + if(iaim.eq.3) wts(nf,loon) = bufr(nget) + kyf(nf,loon) = ku + nsf(nf,loon) = nsu + idf(nf,loon) = idu + jdf(nf,loon) = jdu +c +c echo accepted aim and see if there are any more +c +cryne 20 March 2006 if(ku.gt.12) then + if(ku.gt.maxjlen) then +c write(6,*)'echoing accepted aim; ku, key(ku)=',ku,key(ku) + write(word,42) key(ku) + 42 format(6x,a2) + go to 100 + endif +c write(6,*)'BEFORE GOTO statement with ku=',ku +cryne 20 March 2006 go to (75,75,80,80,85,85,88,90,90,95,95,95), ku + go to (75,75,80,80,85,85,88,90,90,95,95,95,95), ku + 75 write(word,76) key(ku), nsu, idu, jdu + 76 format(a2,i1,'(',i1,',',i1,')') + go to 100 + 80 write(word,81) key(ku), nsu, idu + 81 format(a2,i1,'(',i3,')') + go to 100 + 85 write(word,86) key(ku), idu, jdu + 86 format(2x,a2,i1,',',i1,')') + go to 100 + 88 write(word,89) key(ku), idu, jdu + 89 format(a2,i3,',',i1,')') + go to 100 + 90 write(word,91) key(ku), idu + 91 format(2x,a2,i3,')') + go to 100 + 95 write(word,96) key(ku), idu + 96 format(5x,a2,i1) + 100 write(jof,101) nf, word +cccccccccccc target(nf,loon) + 101 format(' accept',i3,': ',a) +ccccccccccccc ,' = ',1pg22.14) + qname(nf,loon) = word + go to 60 + 150 continue +c +c check for pleas for help +c + if(index(card,'help').ne.0) go to 20 + if(index(card,'HELP').ne.0) go to 20 + if(ifin.eq.0) go to 50 +c +c End of input, echo variables and target values +c + 200 continue + nsq(loon) = nf + if((isend.eq.1).or.(isend.eq.3)) call wrtaim(jof,iaim,loon) + if((isend.eq.2).or.(isend.eq.3)) call wrtaim(jodf,iaim,loon) +c + if(infile.eq.jif) then + write(jof,*) ' ' + write(jof,*) ' Do you wish to start over? (y/n) :' + yn='n' + read(jif,177) yn + 177 format(a) + if ((yn .eq.'y').or.(yn .eq.'Y')) go to 5 + endif +c +c write log file if requested +c + if(logf.gt.0) then + call wrtaim(logf,4,loon) + write(logf,*) ' #' + endif + return + end +c +ccccccccccccccccccccccccccccc AMDII ccccccccccccccccccccccccc +c + subroutine amdii(iter,nv,fv,xv,ef,em,step,info) +c +c Adaptive MultiDimensional Inverse Interpolation algorithm for +c solving simultaneous non-linear equations. +c +c C. T. Mottershead LANL AT-3 Jan 93 +c email: motters@atdiv.lanl.gov, phone (505) 667-9730 +c +c Parameters: +c iter = external iteration counter +c for iter = 0, initialize routine by passing in: +c fv(i) = target(i), i=1,nv +c em = errtol = quitting tolerance for Max(fv(i)-target(i)) on +c normal running calls with iter>nv +c step = delta = feeler step size for first nv iterations. +c info = maxcut = maximum allowed cuts in the reach from initial +c point to final target. Reach is defined as the fraction +c of the distance between the best point found so far and +c the ultimate target. Full reach = 1.0, in which case we +c try to step xv(i) to fit fv(i) = target(i). If this fail +c and maxcut>0, we cut the reach in half. Thus maxcut=N +c means attempts as short as 2**-N of the original distanc +c are allowed. If the iteration succeeds twice with a reac +c less than 1.0, the reach is doubled (but never exceeds 1 +c iter > 0: normal running. ic = internal iteration counter. Norma +c self incrementing on each call, but may be set back to 0 +c cause new orthogonal feeler steps if the matrix becomes +c degenerate. +c On call: +c nv = number of variables (= dimension of fit, maximum of 40) +c fv(i), i=1,nv = computed or measured function values +c at the current point xv(i), i=1,nv. +c On return: +c xv(i), i=1,nv = recommended new value for the independent +c variables. The function values fv(i), i=1,nv at this new +c point should be acquired and passed in on the next iteratio +c em = Max(fv(i)-target(i)) = error measure of new incoming point. +c Used internally for branching and quitting decisions. +c step = length of step = cartesian distance between incoming old +c xv(i) and returned new xv(i), i=1,nv +c info = control flag. Quit if info > 0. +c = -N for normal return with reach cut by 2**N. Keep going. +c = 0 for normal return at full reach toward final target. +c Keep going. +c = 1 Converged: Quit because new point is below error +c tolerance: em maxv =',maxv + info = 6 + return + endif +c +c initialization: store targets and flags for iter = 0 +c + if(iter.le.0) then + do 5 i = 1,nv + fultgt(i) = fv(i) + partgt(i) = fv(i) + 5 continue + ncut = 0 + ic = 0 + level = 0 + reach = 1.d0 + detol = 1.0d-9 + errtol = ef + auxtol = em + antmin = 1.0d-6 +c antol = 1.e4*errtol + antol = auxtol + if(antol.le.0.0d0) antol = antmin + delta = step + stpmin = 0.01d0*delta + slo = 0.0d0 + maxcut = info +c undocumented function limits test + ymax = 1.0d+38 + ymin = -ymax + if(info.lt.0) then + maxcut = -info + ymax = xv(1) + ymin = xv(2) + endif + return + endif +c +c running for iter>0 +c + info = -ncut + last = nv+1 + ic = ic + 1 +c +c compute error measure of new point and test for convergence +c + em = difmax(nv,fv,partgt) + ef = difmax(nv,fv,fultgt) + if(ef.le.errtol) then + info = 1 + step = 0.0d0 + return + endif +c +c save new xv,fv and em and increment xv on first nv calls: +c + 10 continue + if(ic.le.nv) then + do 20 i = 1,nv + ff(i,ic) = fv(i) + xx(i,ic) = xv(i) + 20 continue + err(ic) = em + do 30 i = 1,nv + xv(i) = xx(i,1) + 30 continue + step = delta*xv(ic) + if(abs(step).lt.stpmin) step=stpmin + xv(ic) = xv(ic) + step + return + endif +c +c at ic = nv+1, we have just enough to take a MDII step, so save +c the incoming point and do it: +c + if(ic.eq.last) then + isav = last + go to 100 + endif +c +c converged enough to extend reach for next MDII step +c + if((ncut.gt.0).and.(em.lt.antol)) then + iwin = 1-iwin + if(iwin.eq.0) ncut = ncut - 1 + call mdicut(nv) + level = -1 + call mdipik(nv,ibest,iworst,best,worst) + antol = best*antmin + if(antol.lt.antmin) antol = antmin + em = difmax(nv,fv,partgt) + write(6,*) ' New em =',em,' antol=',antol + info = -ncut + go to 60 + endif +c---------------------------------------------------------------- +c When ic > nv+1, search for best and worst previous points: +c + call mdipik(nv,ibest,iworst,best,worst) + antol = best*antmin + if(antol.lt.antmin) antol = antmin +c +c return to best case and quit if error fails to decrease at full +c reach while below antol +c + if((ncut.eq.0).and.(em.ge.best).and.(em.lt.antol)) then + info = 2 + do 40 i = 1,nv + xv(i) = xx(i,ibest) + fv(i) = ff(i,ibest) + 40 continue + em = difmax(nv,fv,partgt) + ef = difmax(nv,fv,fultgt) + return + endif +c +c New point is the worst yet. Cut reach if allowed, otherwise restore +c best available point and quit: +c + if(em.ge.worst) then + if(ncut.lt.maxcut) then + ncut = ncut + 1 + call mdicut(nv) + level = 1 + call mdipik(nv,ibest,iworst,best,worst) + antol = best*antmin + if(antol.lt.antmin) antol = antmin + em = difmax(nv,fv,partgt) + write(6,*) ' New em =',em,' antol=',antol + info = -ncut + go to 60 + else + info = 4 + do 50 i = 1,nv + xv(i) = xx(i,ibest) + 50 continue + return + endif + endif +c-------------------------------------------------------------------- +c +c arrange data pool for MDII step +c + 60 continue + isav = 0 + if(em.lt.best) isav = last + if((em.ge.best).and.(em.lt.worst)) isav = iworst +c +c Overwrite the previous worst case with the last one, in preparatio +c saving the new one in last place. +c + if(isav.eq.last) then + do 70 i = 1,nv + ff(i,iworst) = ff(i,last) + xx(i,iworst) = xx(i,last) + 70 continue + err(iworst) = err(last) + endif +c +c if best is not last, swap it there +c + if((isav.ne.last).and.(ibest.ne.last)) then + write(6,*) ' Swapping',ibest,'=ibest for last' + do 90 i=1,nv + temp = ff(i,last) + ff(i,last) = ff(i,ibest) + ff(i,ibest) = temp + temp = xx(i,last) + xx(i,last) = xx(i,ibest) + xx(i,ibest) = temp + 90 continue + temp = err(last) + err(last) = err(ibest) + err(ibest) = temp + endif +c +c save new xv,fv and em in column isav of xx,ff, and err arrays +c + 100 continue + if(isav.gt.0) then + do 120 i = 1,nv + ff(i,isav) = fv(i) + xx(i,isav) = xv(i) + 120 continue + err(isav) = em + endif +c------------------------------------------------------------------- +c compute xv using the amdii algorithm for ic > nv: +c + 200 continue +c +c compute ga matrix for linear solver, with the best rhs vector +c as the nv+1st column. +c + gav = 0.0d0 + do 230 i = 1,nv + kolum = nv*(i-1) + do 210 j = 1,nv + ga(j+kolum) = ff(j,i)-ff(j,last) + gav = gav + abs(ga(j+kolum)) + 210 continue + 230 continue +c +c check for null matrix (serious error) +c + if(gav.eq.0.d0) then + info = 5 + return + endif +c +c ok, ga matrix not 0, so normalize to make mean element = 1 +c (to prevent underflow or overflow) +c + nvsq = nv**2 + gav = gav/float(nvsq) + gfac = 1.d0/gav + do 260 i = 1,nv + kolum = nv*(i-1) + do 250 j = 1,nv + ga(j+kolum) = gfac*ga(j+kolum) + 250 continue + ga(i+nvsq) = gfac*(ff(i,last) - partgt(i)) + 260 continue +c +c Solve for correction vector yy: +c + 265 continue + call solveh(ga,nv,1,det) +cryne========== +c do j=1,nv+1 +c do i=1,nv +c k=nv*(j-1)+i +c ga2d(i,j)=ga(k) +c enddo +c enddo +c call solveh(ga2d,nv,1,det) +c +c do j=1,nv+1 +c do i=1,nv +c k=nv*(j-1)+i +c ga(k)=ga2d(i,j) +c enddo +c enddo +cryne========== +c +c redo feeler steps if determinant is bad +c +c if(abs(det).lt.detol) then +c type *, ' Restart from best point because determinant = ',det +c do 270 i = 1,nv +c xv(i) = xx(i,ibest) +c fv(i) = ff(i,ibest) +c 270 continue +c em = difmax(nv,fv,partgt) +c ef = difmax(nv,fv,fultgt) +cc delta = 2.0*delta +c ic = 1 +c go to 10 +c endif +c +c extract yy from solveh return +c + ytot = 0.d0 + do 280 j = 1,nv + yy(j) = ga(j+nvsq) + ytot = ytot + yy(j) + 280 continue +c +c Set new parameter vector for next round: +c + do 340 i = 1,nv + xbar(i) = 0.d0 + do 320 j = 1,nv + xbar(i) = xbar(i) + yy(j)*xx(i,j) + 320 continue + 340 continue +c +c add the step to xn+1 to get xv +c + step = 0.d0 + 400 do 450 i = 1,nv + yy(i) = ytot*xx(i,last) - xbar(i) + if(yy(i).gt.ymax) yy(i) = ymax + if(yy(i).lt.ymin) yy(i) = ymin + step = step + yy(i)**2 + xv(i) = xx(i,last) + yy(i) + 450 continue + step = sqrt(step) + if((step.lt.slo).and.(ncut.eq.0)) info = 3 + return + end +c************************************************************** + subroutine bip(p) +c subroutine for beginning an inner procedure +c Written by Alex Dragt on 8-8-88. + include 'impli.inc' + dimension p(6) + include 'labpnt.inc' + nitms=nint(p(1)) + jbipnt=lp +c write(6,*) 'lp=',lp + jicnt = 0 + return + end +c +************************************************************************ +c + subroutine bop(p) +c subroutine for beginning an outer procedure +c Written by Alex Dragt on 8-8-88. + include 'impli.inc' + dimension p(6) + include 'labpnt.inc' + notms=nint(p(1)) + jbopnt=lp +c write(6,*) 'lp=',lp + jocnt = 0 + return + end +c +************************************************************************ +c + subroutine chekit(loon,iter,maxit) +c +c returns current loop counter (iter), and +c maximum number of iterations (maxit) for specified loop. +c iter = current loop counter +c maxit = maximum number of iterations +c loon = loop number = 1 for inner loop +c = 2 for outer loop +c +c T. Mottershead LANL AT-3 7 Oct 91 +c---------------------------------------------------- + include 'impli.inc' + include 'files.inc' + include 'labpnt.inc' + if(loon.eq.2) then + iter = jocnt + maxit = notms + else + iter = jicnt + maxit = nitms + endif + iquiet = 1 + return + end +c +c******************************************************************** +c + subroutine cps(prms,p,ipset) +c subroutine for capturing a parameter set +c Written by Alex Dragt, 28 July 1988 +c + include 'impli.inc' + include 'parset.inc' + include 'psflag.inc' +c + dimension prms(6),p(6) +c +c test to see that ipset is in range +c + if(ipset.le.0 .or. ipset.gt.maxpst) then +c print some message + return + endif +c +c capture a parameter set and flag it +c + if(icapt(ipset).eq.0) then + do 10 i=1,6 + 10 prms(i)=pst(i,ipset) + icapt(ipset)=1 + return + endif +c +c transfer p to a captured parameter set +c + do 20 i=1,6 + 20 pst(i,ipset)=p(i) + return + end +c +*********************************************************************** +c + subroutine dapt(p) +c This subroutine finds the dynamic aperture in one dimension. +c + use rays + use lieaparam, only : monoms + include 'impli.inc' + include 'parset.inc' + include 'usrdat.inc' +c +c calling array + dimension p(6) +c +c saved quantities + save ient, gut, bad +c +c set up control parameters + ipset = nint(p(2)) + prec=p(3) + gutic=0.d0 + badic=1.d5 +c +c see if this is initial entry into this subroutine + if(ient .eq. 0) then + gut=gutic + bad=badic + ient=1 + endif +c +c examine result of tracking, and proceed accordingly +c +c procedure if particle not lost + if(nlost .eq. 0) then + gut=pst(1,ipset) +c + if(bad .eq. badic) then + pst(1,ipset)=2.d0*gut + endif +c + if(bad .ne. badic) then + pst(1,ipset)=gut+(bad-gut)/2.d0 + endif +c + acc=(bad-gut)/bad + write(6,*) gut, pst(1,ipset), bad, acc + return + endif +c +c procedure if particle lost + if(nlost .ne. 0) then + bad=pst(1,ipset) +c + if(gut .eq. gutic) then + pst(1,ipset)=bad/2.d0 + endif +c + if(gut .ne. gutic) then + pst(1,ipset)=gut+(bad-gut)/2.d0 + endif +c + acc=(bad-gut)/bad + write(6,*) gut, pst(1,ipset), bad, acc + endif +c + return + end +c +********************************************************************** +c + double precision function difmax(n,aa,bb) + implicit double precision (a-h,o-z) + dimension aa(*), bb(*) +c +c evaluate error of incoming functions +c + difmax = 0.0d0 + do 18 i=1,n + del = abs(aa(i)-bb(i)) + difmax = dmax1(del,difmax) + 18 continue + return + end +c**************************************************************** + subroutine fit(pp) +c +c----------------------------------------------------------------------- + use acceldata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' +cryne 21 March 2006 include 'status.inc' +cryne include 'index.inc' !is now in acceldata, but what is this needed for??? +c include 'fitbuf.inc' + include 'aimdef.inc' +c + dimension pp(6) +c + character*50 quit(6) + parameter (maxf=100) + dimension xv(maxf), aims(maxf), lout(2) +!dbs -- this is redundant since the next statement saves everything +!dbs -- and the Intel compiler objects to it +!dbs save kut, info, em, ef, step + save +c +c reason for quiting messsages +c + quit(1) = 'Converged: error < tolerance' + quit(2) = 'Best effort: Hit bottom at full reach' + quit(3) = 'step size below limit' + quit(4) = '**FAILURE: error increase at full cut' + quit(5) = '**NULL MATRIX: Nothing is Happening!!! **' + quit(6) = '**AMDII OVERFLOW: Too many variables **' +c +c check and reset error flag from eig4 or eig6 to ok value +cryne 21 March 2006 if (imbad .ne. 0) imbad=0 +c +c check iteration counter for specified loop +c + loon =1 + nfit = nint(pp(1)) + if(nfit.lt.0) then + nfit = -nfit + loon = 2 + endif + call chekit(loon,jiter,maxit) + if(jiter.eq.0) then +c +c pick up parameters only on first pass (jiter=0) +c + auxtol = pp(2) + errtol = pp(3) + delta = pp(4) + mode = nint(pp(5)) + nrpt = 0 + if(mode.lt.0) nrpt = -mode +c type *, mode,'=MODE',nrpt,'=NRPT' + isend = nint(pp(6)) +c +c check for x damping +c + relax = 0.5d0 + nrep = 0 + if(nfit.lt.0) then + nrep = -nfit + if(auxtol.ne.0.d0) relax = auxtol + endif + ibsave = ibrief + ibrief = -7 + kfit = 0 ! one more time flag +c +c load fixed data into amdii +c + nf = nsq(loon) + do 20 j=1,nf + aims(j) = target(j,loon) + write(6,*) ' target',j,' =',aims(j) + 20 continue +cryne? nfit=0 + call amdii(jiter,nf,aims,xv,errtol,auxtol,delta,nfit) + endif +c +c set up output levels and routing +c + lout(1) = jof + lout(2) = jodf + ja = 1 + if(iabs(isend).eq.2) ja = 2 + jb = 1 + if(iabs(isend).gt.1) jb = 2 + if(isend.eq.0) ja=3 +c +c check the last go around flag to restore final values everywhere +c + if(kfit.eq.1) go to 700 +c-------------------------------------------------------------- +c Have another go at it: Collect the current x-parameter vector, +c and computed function values: +c + call getaim(loon,nf,aims) + call getvar(loon,nx,xv) + if(nx.ne.nf) then + write(jof,31) nx,nf,loon + write(jof,31) nx,nf,loon + 31 format(' **FATAL FIT ERROR:',i3,' variables with',i3, + &' aims. Abort loop',i3) + go to 1000 + endif +c +c compute the next estimate of the x-parameters, and put them +c back in the parameter buffer: +c + iter=jiter+1 +cryne?info=0 + call amdii(iter,nf,aims,xv,ef,em,step,info) + call putvar(loon,xv) +c +c check the MDII error flag. If quit, do the reset pass. +c + if(info.gt.0) then + kfit = 1 + return + endif +c +c iteration reports +c + if(ja.gt.jb) go to 100 + do 60 j = ja,jb + lun = lout(j) +c +c optional reports every nrpt iterations +c +cryne if((nrpt.gt.0).and.(mod(iter,nrpt).eq.0)) then + if(nrpt.gt.0)then + if(mod(iter,nrpt).eq.0) then + write(lun,53) (aims(k), k=1,nf) + 53 format(' AIMS: ',4(1pg18.9)) + write(lun,54) (xv(k), k=1,nx) + 54 format(' XNEW: ',4(1pg18.9)) + endif + endif + kut = 2**(-info) + write(lun,57) iter,ef,step,em,kut + 57 format(' Iter',i4,' Error=',1pe11.4,', Step=',1pe11.4, + & ', SubErr=',1pe11.4,' @cut=',i5) + write(lun,58) + 58 format(1x,55('-')) + 60 continue + 100 continue + return +c +c Converged at full reach, or failed. Display final results. +c + 700 continue + if(isend.eq.0) go to 1000 + ja = 1 + jb = 2 + do 900 j=ja,jb + lun = lout(j) + write(lun,710) iter,info,quit(info),kut + 710 format(' Quit on iteration',i4,' for reason',i2,': ',a,/ + &' Final values with reach =',i4,' are:') + call wrtaim(lun,2,loon) +c +c Display new values for parameters. +c + call wrtvar(loon,lun) +c +c Display maximum percent error. +c + write(lun,*)' ' + write(lun,840) em + 840 format(2x,'Maximum error is ',1pg13.6) + write(lun,841) errtol + 841 format(2x,'Maximum allowed was ',1pg13.6) + 900 continue + 1000 ibrief = ibsave + call stopit(loon) + return + end +c +********************************************************************** +c + subroutine fps(ipset) +c +c this subroutine frees a parameter set so that it can be recaptured +c if desired +c Written by Alex Dragt, 28 July 1988 +c + include 'impli.inc' + include 'parset.inc' + include 'psflag.inc' +c +c test to see that ipset is within range +c + if(ipset.le.0 .or. ipset.gt.maxpst) then +c write error message + return + endif +c +c free the indicated parameter set +c + icapt(ipset)=0 +c + return + end +c +************************* GETAIM ******************************** +c + subroutine getaim(loon,naim,aims) +c +c getaim returns the number of aims selected (nf,loon), and +c their current values (aims(j), j=1,nf) from aim block loon +c +c C. T. Mottershead LANL AT-3 16 Aug 90 +c modified 29 May 91 to double aim blocks, selected by loon. +c-------------------------------------------------- + include 'impli.inc' + include 'aimdef.inc' + dimension aims(*) +c + naim = nsq(loon) + do 20 nu = 1, naim + ku = kyf(nu,loon) + nsu = nsf(nu,loon) + idu = idf(nu,loon) + jdu = jdf(nu,loon) + aims(nu) = valuat(ku,nsu,idu,jdu) + 20 continue + return + end +c +c************************* GETVAR *************************** +c + subroutine getvar(loon,nx,xv) +c +c collect the current x-parameter vector +c mm(i,kvs) is the i-th marylie menu item selected in vary +c idx(i,kvs) is the index (1 to 6) of the i-th variable parameter +c T. Mottershead LANL AT-3 23 July 90 +c------------------------------------------------------- + use acceldata + include 'impli.inc' + include 'xvary.inc' + dimension xv(*) + kvs = loon + if((kvs.lt.1).or.(kvs.gt.3)) kvs = 1 + nx = nva(kvs) + do 210 i = 1,nx + mnu = mm(i,kvs) +cryne 23 March 2006: + if(mnu.eq.0)then + write(6,*)'error from getvar: mnu =0. This should not happen!' + stop + endif + xv(i) = pmenu(idx(i,kvs)+mpp(mnu)) + 210 continue + return + end +c +c*********************************** GRAD *************************** +c + subroutine grad(pp) +c----------------------------------------------------------------------- + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'aimdef.inc' + include 'xvary.inc' +c + parameter (maxg=100) + common/gradat/nx,ny,dxx,dyy,xcen(maxg),ycen(maxg) + dimension pp(6) + dimension yval(maxg), xval(maxg) + logical ltty, lfile + character*12 vname + character*8 yname(maxg) +cryne + save lun,delta,scale,ltty,lfile,yname +c +c check loop and option flag +c + loon = 1 + job = nint(pp(1)) + if(job.lt.0) then + job = -job + loon = 2 + endif + call chekit(loon,iter,maxit) +c +c initialization for iter = 0 (ic=1) +c + if(iter.eq.0) then +cryne: NOTE: isides is never used + isides = nint(pp(2)) + lun = nint(pp(3)) + delta = pp(4) + scale = pp(5) + isend = nint(pp(6)) + ltty = .false. + lfile = .false. + if((isend.eq.1).or.(isend.eq.3)) ltty = .true. + if((isend.eq.2).or.(isend.eq.3)) lfile = .true. +c +c collect the central x-parameter vector +c + call getvar(loon,nx,xcen) +c +c collect central y-values +c + ny = 0 + if((job.eq.1).or.(job.eq.3)) then + call getaim(loon,ny,ycen) + do 10 k=1,ny + yname(k) = qname(k,loon) + 10 continue + endif +c +c compute any rms errors selected in current loon +c + if(job.ge.2) then + do 15 ku = 1,3 + if(lsq(ku,loon).ne.1) go to 15 + ny = ny + 1 + ycen(ny) = rmserr(ku) + write(yname(ny),14) ku + 14 format(2x,'rms',i1,2x) + 15 continue + endif +c +c increment the first x-variable on the first call +c + do 20 i=1,nx + xval(i) = xcen(i) + 20 continue + xval(1) = xcen(1) + delta + call putvar(loon,xval) + return + endif +c +c all done, jump out of labor loop +c + if(iter.gt.nx) then + write(jif,*) ' gradient loop is finished' + call stopit(loon) + return + endif +c +c normal running: compute and save numerical gradients for iter=1,n +c + call getvar(loon,nx,xval) + ny = 0 + if((job.eq.1).or.(job.eq.3)) call getaim(loon,ny,yval) +c +c compute any rms errors selected in current loon +c + if(job.ge.2) then + do 515 ku = 1,3 + if(lsq(ku,loon).ne.1) go to 515 + ny = ny + 1 + yval(ny) = rmserr(ku) + 515 continue + endif + delx = xval(iter) - xcen(iter) + do 600 n = 1,ny + dydx = (yval(n) - ycen(n))/delx + if(dydx.eq.0.d0) go to 600 + qsq = dydx/delx + qs = 0.d0 + if(qsq.gt.0.0) qs = scale*sqrt(qsq) + vname = varnam(iter,loon) + if(ltty) write(jof,577) n,iter,dydx,qs,yname(n),vname + if(lfile) write(jodf,577) n,iter,dydx,qs,yname(n),vname + if(lun.gt.0) write(lun,577) n,iter,dydx,qs,yname(n),vname + 577 format(2i5,1pg22.14,1pg16.8,2x,a,' / ',a) + 600 continue +c +c increment parameter vector on first nx-1 calls, and restore +c central values on last call: +c + if(iter.lt.nx) then + do 520 i=1,nx + xval(i) = xcen(i) + 520 continue + xval(iter+1) = xcen(iter+1) + delta + call putvar(loon,xval) + else + call putvar(loon,xcen) + endif + return + end +c +********************************************************************** +c + subroutine keynum(text,word,nask,nget,nloc,bufr) +c +c keynum scans the character string 'text' for one +c keyword, followed by a list of associated numbers. +c +c parameters: +c text - the input character string to be searched +c word - the single keyword +c nask - maximum length of number list +c nget - actual number of numbers found +c nloc - location in text string of keyword found +c bufr - output array of real numbers +c +c T. Mottershead Los Alamos Aug 1985 +c---------------------------------------------------------- + implicit double precision (a-h,o-z) + character text *(*), word*(*) + dimension bufr(1) + max=len(text) + nch=len(word) + nloc=index(text,word) + if(nloc.eq.0) go to 40 + jj=nloc+nch-1 + text(nloc:jj)=' ' + nrem=max-nloc+1 + if(nask.gt.0) call txtnum(text(nloc: ),nrem,nask,nget,bufr) +c write(6,17) nrem,nask,nget,(bufr(k), k=1,nask) +c 17 format(' in keynum:',3i3,3(1pg14.6)) + 40 return + end +c +************************************************************************ +c + subroutine lexort(num,namlst,indx) +c +c General character array sorting subroutine. +c parameters - +c num - dimension of the arrays +c namlst - input array of character variables to be +c indexed in alphabetical order. This input +c array is not altered. +c indx - output sorted index array, generated so that +c namlst(indx(k)), k=1,num is in alphabetical order. +c C. T. Mottershead/ AT-3 2 Feb 88 +c---------------------------------------- + dimension indx(*) + character*(*) namlst(*) + character*8 first +c +c initialize the index array +c + do 5 j = 1, num + indx(j) = j + 5 continue +c +c find smallest remaining value and corresponding index +c + j=1 + 10 jin = indx(j) + first=namlst(jin) + mv=j +c +c find first remaining name, and location of its pointer in the +c index array (i.e namlst(indx(mv)) is the lowest remaining name) +c + do 30 k=j,num + kin = indx(k) + if(lge(namlst(kin),first)) go to 30 + first=namlst(kin) + mv=k + 30 continue +c +c swap the index of the lowest name (in location mv) with the +c first index (in location j) in the remaining list +c + isav = indx(j) + indx(j) = indx(mv) + indx(mv) = isav +c +c move starting location down one and repeat if necessary +c + j=j+1 + if(j.lt.num) go to 10 + 77 return + end +c +************************************************************************ +c + subroutine mdicut(nv) +c +c reset partial target (PARTGT) and rejudge the pool (XX,FF) relat +c to the new target +c +c C. T. Mottershead AT-3 6 July 92 +c----------------------------------------------------------------------- + include 'impli.inc' + include 'amdiip.inc' + include 'files.inc' +c----------------------------------------------------------- + last = nv+1 + npower = 2**ncut + write(jof,*) npower,'<<----Reach cut factor' + write(jodf,*) npower,'<<----Reach cut factor' + reach = 1.d0/float(npower) + do 20 k = 1, nv + partgt(k) = ff(k,last) + reach*(fultgt(k) - ff(k,last)) + 20 continue +c +c reevaluate errors of data pool relative to new target +c + do 60 n=1,last + em = 0.d0 + do 40 i=1,nv + df = abs(ff(i,n)-partgt(i)) + em = dmax1(df,em) + 40 continue + err(n) = em + 60 continue + return + end +c************************************************************** + subroutine mdipik(nv,ibest,iworst,best,worst) +c----------------------------------------------------------------------- + include 'impli.inc' + include 'amdiip.inc' +c----------------------------------------------------------- + last = nv + 1 + best=1.d30 + worst=-best + ibest=1 + iworst=1 + do 60 i = 1,last + if(err(i).lt.best) then + best = err(i) + ibest=i + endif + if(err(i).gt.worst) then + worst = err(i) + iworst = i + endif + 60 continue +c write(6,67) ibest,best,iworst,worst +c 67 format(' MDIPIK:',i3,' is best=',1pg15.7,i8,' is worst=',1pg15.7) + return + end +c************************************************************* +c subroutine mrt0 +c +c This is the least squares merit function defined by aims for loop 1 +c +c T. Mottershead, LANL Feb 89 +c----------------------------------------------------- +c include 'impli.inc' +c include 'merit.inc' +c +c gather the computed function values +c +c loon = 1 +c write(6,*) 'in mrt0' +c fval = rmserr(loon) +c val(0) = fval +c return +c end +c +***************************************************************** +c + subroutine mss(pp) +c +c optimization routine to least squares fit the selected aims to the +c specified targets. +c T. Mottershead LANL AT-3 24 Nov 92 +c----------------------------------------------------------------------- +cryne 3/14/06pm use acceldata +cryne 3/14/06pm use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' +cryne 21 March 2006 include 'status.inc' + include 'aimdef.inc' +c + parameter (maxf = 100) + dimension pp(6), tol(4) + dimension aims(maxf), xv(maxf), fv(maxf), lout(2) +cryne 3/15/06 save xv, fval, nx + save +c +c check and reset error flag from eig4 or eig6 to ok value +cryne 21 March 2006 if (imbad .ne. 0) imbad=0 +c +c check iteration counter for specified loop +c + nrpt = 1 + loon =1 + nopt = nint(pp(1)) +c write(6,*)'***INSIDE MSS***, nopt=',nopt + if(nopt.lt.0) then + nopt = -nopt + loon = 2 + endif + call chekit(loon,jiter,maxit) + iter = jiter + 1 + if(jiter.eq.0) then +c +c pick up parameters only on first pass (jicnt=0) +c + ftol = pp(2) + gtol = pp(3) + delta = pp(4) + xtol = pp(5) + tol(1) = gtol + tol(2) = xtol + tol(3) = ftol + tol(4) = delta + isend = nint(pp(6)) + info = 0 + ibsave = ibrief + ibrief = -7 + iscale = 0 + mode = 0 +c +c set up output levels and routing +c + lout(1) = jof + lout(2) = jodf + italk = 0 + if(isend.lt.0) italk = -isend + if(isend.eq.4) italk = 2 + if(isend.eq.-4) italk = 1 + ja = 1 + if(iabs(isend).eq.2) ja = 2 + jb = 1 + if(iabs(isend).gt.1) jb = 2 + write(jof,*) ' MSS is initialized' + endif +c +c progress report on previous iteration; +c compute fv and chi-squared +c + call getaim(loon,nf,aims) + do 40 jj = 1,nf + fv(jj) = aims(jj) - target(jj,loon) +40 continue + fold = fval + fval = rmserr(loon) + change = fval - fold +c if(abs(change).lt.ftol) go to 700 + write(6,*)'change,ja,jb=',change,ja,jb + if(ja.gt.jb) go to 100 + do 60 j = ja,jb + lun = lout(j) + write(lun,*)' ' + write(lun,51) iter, fval, change + 51 format(2x,'MSS iteration',i5,' F=',1pg18.9,' DF=',1pg14.6) + if((nrpt.gt.0).and.(mod(iter,nrpt).eq.0)) then + write(lun,54) (xv(k), k=1,nx) + 54 format(' XNEW: ',4(1pg18.9)) + endif + write(lun,58) + 58 format(1x,55('-')) + 60 continue + 100 continue +c +c Collect the current x-parameter vector. +c + call getvar(loon,nx,xv) +c +c compute the next estimate of the minimum, +c + if(nopt.eq.1) then + write(6,*)'using nls' + call nls(mode,iter,nx,xv,nf,fv,iscale,wts(1,loon),tol,info) + else +c +c use QSO on rms error merit function +c + write(6,*)'using qso' + call qso(mode,iter,nx,xv,fval,iscale,tol,info) + endif + write(jof,*)' optimizer return:',info,'=info' + write(jof,*)' XV=',(xv(ij),ij=1,nx) +c +c scatter the new x-parameter estimate, and let the labor continue. +c + if(info.eq.0) then + call putvar(loon,xv) + write(6,*)'info=0; RETURNING from MSS after first putvar' + return + endif +c +c Termination. Display final results. +c + 700 continue + if((info.lt.4).or.(info.gt.6)) call putvar(loon,xv) + if(isend.eq.0) go to 1000 + do 900 j=ja,jb + lun = lout(j) + call message(info,lun) + write(lun,710) iter + 710 format(' After ',i4,' total iterations, final values are:') + call wrtaim(lun,2,loon) + call wrtvar(loon,lun) + write(lun,*)' ' + write(lun,840) change + 840 format(2x,'Final change was ',1pg13.6) +c write(lun,841) dftol +c 841 format(2x,'Tolerance was ',1pg13.6) + 900 continue + 1000 call stopit(loon) + ibrief = ibsave + write(6,*)'RETURNING from MSS at end of routine; info=',info + return + end +c +********************************************************************** +c + subroutine opt(pp) +c +c optimization routine +c----------------------------------------------------------------------- +cryne 3/14/06pm use acceldata +cryne 3/14/06pm use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' +cryne 21 March 2006 include 'status.inc' +c include 'labpnt.inc' + include 'merit.inc' + parameter (maxf = 100) + dimension aims(maxf), xv(maxf), xold(maxf), lout(2) +c + dimension pp(6), tol(4) + common/rynetest/val12345 + save fffval + save ftol,gtol,delta,xtol,tol,isend,info,ibsave, & + & iscale,mode,lout,ja,jb + +c +c +c check and reset error flag from eig4 or eig6 to ok value +cryne 21 March 2006 if (imbad .ne. 0) imbad=0 +c +c check iteration counter for specified loop +c + nrpt = 1 + loon =1 + job = nint(pp(1)) + write(6,*)'***INSIDE OPT***, job=',job +c write(6,*)'***INSIDE OPT***, pp(1)=',pp(1) + if(job.lt.0) then + job = -job + loon = 2 + endif + call chekit(loon,jiter,maxit) + iter = jiter + 1 +ccc write(6,*)'(OPT) iter,jiter=',iter,jiter + if(jiter.eq.0) then +c +c pick up parameters only on first pass (jicnt=0) +c + ftol = pp(2) + gtol = pp(3) + delta = pp(4) + xtol = pp(5) + tol(1) = gtol + tol(2) = xtol + tol(3) = ftol + tol(4) = delta + isend = nint(pp(6)) + info = 0 + ibsave = ibrief + ibrief = -7 + iscale = 0 + mode = 0 +c +c set up output levels and routing +c + lout(1) = jof + lout(2) = jodf + ja = 1 + if(iabs(isend).eq.2) ja = 2 + jb = 1 + if(iabs(isend).gt.1) jb = 2 + write(jof,*)'************ OPT is initialized' +ccc write(6,*)'jof,jodf,isend,ja,jb=',jof,jodf,isend,ja,jb + fffval=val12345 +c write(6,*)'**********at this point fffval=',fffval + endif +c +c Collect the current x-parameter vector. +c + call getvar(loon,nx,xold) + write(6,*)'(OPT) ######### nx=',nx + do 20 j=1,nx + xv(j) = xold(j) + 20 continue +c +c collect selected merit function +c +c write(6,*)'******************now fffval=',fffval + fold = fffval + if(job.eq.1) then + call getaim(loon,nf,aims) + fffval = aims(1) + else + fffval = rmserr(loon) + endif + change = fffval - fold +c +c use QSO on selected merit function +c + call qso(mode,iter,nx,xv,fffval,iscale,tol,info) +ccc write(6,*)'QSO REPORT:' + dxsq = 0.d0 + do 40 j=1,nx +ccc write(6,*)j,xv(j),xold(j),(xv(j) - xold(j))**2 + dxsq = (xv(j) - xold(j))**2 + 40 continue + step = sqrt(dxsq) +c +c progress report +c write(6,*)'PROGRESS REPORT FROM OPT: ja,jb=',ja,jb +c + if(ja.gt.jb) go to 600 + do 60 j = ja,jb + lun = lout(j) + write(lun,*)' ' + write(lun,51) iter, fffval, change, step + 51 format(i5,'=iter F=',1pg20.12,' DF=',1pg14.6, + & ' DX=',1pg14.6) + if((nrpt.gt.0).and.(mod(iter,nrpt).eq.0)) then + write(lun,54) (xv(k), k=1,nx) + 54 format(' XNEW: ',4(1pg18.10)) +c write(lun,57) (dx(k), k=1,nx) +c 57 format(' DX: ',6(1pg12.4)) + endif + write(lun,58) + 58 format(1x,55('-')) + 60 continue + 600 continue +c +c scatter the new x-parameter estimate, and let the labor continue. +c + if(info.eq.0) then + call putvar(loon,xv) + return + endif +c +c Termination. Display final results. +c + 700 continue + if((info.lt.4).or.(info.gt.6)) call putvar(loon,xv) + if(isend.eq.0) go to 1000 + do 900 j=ja,jb + lun = lout(j) + call message(info,lun) + write(lun,710) iter + 710 format(' After ',i4,' total iterations, final values are:') + if(job.eq.1) then + call wrtaim(lun,1,loon) + else + final = rmserr(loon) + write(lun,721) loon, final + 721 format(' Final RMS error for loop',i2,' is',1pg18.10) + endif + call wrtvar(loon,lun) + write(lun,*)' ' + write(lun,840) change, step + 840 format(2x,'Final change was ',1pg13.6,2x,'final step was ', + & 1pg13.6) + write(lun,841) ftol, xtol + 841 format(2x,'Tolerances: ftol=',1pg13.6,12x,'xtol=',1pg13.6) + 900 continue + 1000 call stopit(loon) + ibrief = ibsave + return + end +c +********************************************************************** +c + subroutine putvar(loon,xnew) +c +c scatter the new x-parameter vector back to the parameter blocks +c including reseting the dependent variables. +c mm(i,kvs) is the i-th marylie menu item selected in vary +c idx(i,kvs) is the index (1 to 6) of the i-th variable parameter +c The first nv of these specify the independent variables being +c adjusted by the fit or optimization routines. +c The next nd entries specify parameters linearly dependent on +c one of the independent variables in the form +c base_value + slope*variable +c idv(j,kvs) specifies which independent variable (1 to nv) +c the j-th dependent parameter is tied to. +c xbase(j) and xslope(j) are the relevant base value and +c slope specified in vary. +c +c T. Mottershead LANL AT-3 23 July 90 +c------------------------------------------------------------- + use acceldata + include 'impli.inc' + include 'xvary.inc' + dimension xnew(*) +c +c simple copy back for the independent varables +c + kvs = loon + if(kvs.ne.2) kvs = 1 + nv = nva(kvs) + nd = nda(kvs) + do 20 i=1,nv + mnu = mm(i,kvs) + pmenu(idx(i,kvs)+mpp(mnu)) = xnew(i) + 20 continue + if (nd.le.0) return +c +c compute new values for linearly dependendent variables +c + do 50 j=1,nd + idu = idx(j+nv,kvs) + mnu = mm(j+nv,kvs) + depvar = xbase(j,kvs) + xslope(j,kvs)*xnew(idv(j,kvs)) + pmenu(idu+mpp(mnu)) = depvar + 50 continue + return + end +c +ccccccccccccccccccccccc RMSERR cccccccccccccccccccccccc +c + double precision function rmserr(loon) +c +c This function calculates the RMS error of the specified loop +c +c T. Mottershead, LANL AT-3 8 Dec 92 +c----------------------------------------------------- + include 'impli.inc' + include 'aimdef.inc' +c + rmserr = 0.d0 + nf = nsq(loon) + if(nf.le.0) return + fnum = float(nf) + chisq = 0.d0 + do 20 nu = 1, nf + ku = kyf(nu,loon) + nsu = nsf(nu,loon) + idu = idf(nu,loon) + jdu = jdf(nu,loon) + aimiss = valuat(ku,nsu,idu,jdu) - target(nu,loon) + chisq = chisq + wts(nu,loon)*aimiss**2 + 20 continue + rmserr = sqrt(chisq/fnum) + return + end +c +*************************************************************** +c + subroutine rset(pp) +c +c this subroutine resets items in the #menu component interactively +c made from parts of 'vary', 19 Aug 91, T. Mottershead, LANL +c + use acceldata + include 'impli.inc' + include 'files.inc' + include 'codes.inc' + character*80 card + dimension pp(6), menitm(20), indvar(20) + logical ltty, lfile, rewind +c +c write(6,*) ' in subroutine rset' +c----------------------------------------------------- + job = nint(pp(1)) + infile=nint(pp(2)) + rewind = .true. + if(infile.eq.0) infile = jif + if(infile.eq.jif) rewind = .false. + if(infile.lt.0) then + infile = -infile + rewind = .false. + endif + if(rewind) rewind(infile) + logf = nint(pp(3)) + lun = nint(pp(4)) + isend = nint(pp(5)) + lfile = .false. + ltty = .false. + if((isend.eq.1).or.(isend.eq.3)) ltty = .true. + if((isend.eq.2).or.(isend.eq.3)) lfile = .true. + ktot = 0 + maxrs = 20 + 10 if(ltty) call varlis(jof) +c +c select variable parameters +c + 20 if(ltty) write(jof,32) + 32 format(/' To RESET #menu items, enter name and (optional)', + & ' parameter index.',/' Type * to relist, or a # sign', + & ' when finished.') +c +c read a new input line +c + 40 read(infile,41,end=200) card + 41 format(a) + if(card.eq.' ') go to 40 + call low(card) + ifin = index(card,'#') + list = index(card,'*') + call vreset(infile,card,maxrs,ktot,menitm,indvar) + if(list.ne.0) go to 10 + if(ifin.eq.0) go to 20 + 200 continue +c +c Display reset selections +c + if(ktot.eq.0) return + if(ltty) write(jof,203) ktot + if(lfile) write(jodf,203) ktot + if(lun.gt.0) write(lun,203) ktot + 203 format(/' The following',i3,' #menu item(s) have been reset:') + if(ltty) write(jof,175) + if(lfile) write(jodf,175) + if(lun.gt.0) write(lun,175) + 175 format(' No. Item ',4x,'Type',5x,'Parameter',3x,'New value' + & /60('-')) + do 170 i = 1,ktot + idu = indvar(i) + mnu = menitm(i) + mt1 = nt1(mnu) + mt2 = nt2(mnu) + if(ltty) write(jof, 176) i, lmnlbl(mnu), ltc(mt1,mt2), idu, + & pmenu(idu+mpp(mnu)) + if(lfile) write(jodf, 176) i, lmnlbl(mnu), ltc(mt1,mt2), + & idu, pmenu(idu+mpp(mnu)) + if(lun.gt.0) write(lun, 176) i, lmnlbl(mnu), ltc(mt1,mt2), + & idu, pmenu(idu+mpp(mnu)) + 176 format(i3,4x,a8,3x,a8,i6,5x,1pg21.14) + 170 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine scan(pp) +c +c routine for scanning parameters +c T. Mottershead LANL AT-3 29-MAR-91 +c----------------------------------------------------------------------- + include 'impli.inc' + include 'files.inc' +c + parameter (maxg=100) + common/gradat/nx,nz,dxx,dyy,xcen(maxg),ycen(maxg) + dimension pp(6) + dimension xval(maxg) + logical ltty, lfile + save ltty, lfile, ncyc, deltax + loon =1 + nopt = nint(pp(1)) + if(nopt.lt.0) then + nopt = -nopt + loon = 2 + endif + call chekit(loon,iter,maxit) +c +c initialization for iter = 0 (ic=1) +c + if(iter.eq.0) then + ndx = nint(pp(2)) + ndy = nint(pp(3)) + ncyc = ndx + 1 + if(ndx.lt.0) ncyc = 1 - 2*ndx + if(ncyc.ge.maxit) ncyc = maxit - 1 + deltax = pp(4) + deltay = pp(5) + isend = nint(pp(6)) + ltty = .false. + lfile = .false. + if((isend.eq.1).or.(isend.eq.3)) ltty = .true. + if((isend.eq.2).or.(isend.eq.3)) lfile = .true. +c +c save the original x-parameter vector and set up loop +c + call getvar(loon,nx,xcen) + xx = xcen(1) + if(ndx.lt.0) xx = xx + float(ndx)*deltax +c +c increment the first x-variable +c + do 20 i=1,nx + xval(i) = xcen(i) + 20 continue + xval(1) = xx + call putvar(loon,xval) + return + endif +c +c normal running: print selected quantities for iter=1,nx: +c + if(iter.gt.ncyc) go to 900 + call getvar(loon,nx,xval) + xx = xval(1) + yy = xval(2) + if(ltty) write(jof,433) iter, xx, yy + if(lfile) write(jodf,433) iter, xx, yy + 433 format(' ** Scan Step',i4,' xx, yy =',2(1pg15.7)) +c +c increment parameter vector on first ncyc-1 calls: +c + if(iter.lt.ncyc) then + do 520 i=1,nx + xval(i) = xcen(i) + 520 continue + xx = xx + deltax + xval(1) = xx + call putvar(loon,xval) + else +c restore original values on last pass + if(nopt.eq.1) call putvar(loon,xcen) + endif + return +c +c all done, put it back the way it was +c and jump out of labor loop +c + 900 continue + if(ltty) write(jof,*) ' Scan loop is finished' + if(lfile) write(jodf,*) ' Scan loop is finished' + call stopit(loon) + return + end +c +***************************************************************** +c + subroutine solveh(augmat,nrow,nca,det) +c Solves the linear equations +c m*a = b +c where m is nrow by nrow +c a is nrow by nca +c b is nrow by nca +c On entry : augmat = m augmented by b +c nca = number of columns in a or b +c On return: augmat = identity augmented by a +c det = determinant of m + double precision augmat(nrow,nrow+nca), det +c +c Coded from a routine originally written for the HP41C calculator +c (Dearing, p.46). Written by Liam Healy, February 14, 1985. +c routine and some variables renamed by Tom Mottershead, 15-Nov-88. +c----Variables---- +c nrow = dimension of matrix = total number of rows. +c nca = number of columns augmented +c ncol = total number of columns = nrow + nca. + integer nrow, nca, ncol +c +c irow,jcol,ir,jc,roff,mr=row and column numbers, row and column indice +c row offset, row number for finding maxc. + integer irow,jcol,ir,jc,roff,mr +c +c elem, mrow, hold = matrix element, its row number, and held value. +c const = constant used in multiplication + double precision elem,hold,const + integer mrow +c +c----Routine---- + det=1.d0 + ncol=nrow+nca + jcol=0 + do 100 irow=1,nrow + 300 jcol=jcol+1 + if (jcol.le.ncol) then +c find max of abs of mat elts in this col, and its row num + elem=0.d0 + mrow=0 + do 120 mr=irow,nrow + if (abs(augmat(mr,jcol)).ge.abs(elem)) then + elem=augmat(mr,jcol) + mrow=mr + endif + 120 continue + det=det*elem + if (elem.eq.0.) goto 300 + do 140 jc=1,ncol + augmat(mrow,jc)=augmat(mrow,jc)/elem + 140 continue + if (mrow.ne.irow) then +c swap the rows + do 160 jc=1,ncol + hold=augmat(mrow,jc) + augmat(mrow,jc)=augmat(irow,jc) + augmat(irow,jc)=hold + 160 continue + det=-det + endif + if (irow.lt.nrow) then + do 190 ir=1,nrow + if (ir.ne.irow) then +c multiply row row by const & subtract from row ir + const=augmat(ir,jcol) + do 180 jc=1,ncol + augmat(ir,jc)=augmat(ir,jc)-augmat(irow,jc)*const + 180 continue + endif + 190 continue + endif + endif + 100 continue +c +c Matrix is now in upper triangular form. +c To solve equation, must get it to the identity. + do 200 roff=nrow,1,-1 + do 200 irow=roff-1,1,-1 + const=augmat(irow,roff) + do 200 jc=irow,ncol + augmat(irow,jc)=augmat(irow,jc)-const*augmat(roff,jc) + 200 continue + return + end +c +********************************************************************* +c + subroutine sq(p) +c +c This subroutine selects quantities to be written out by a command +c with type code wsq (write selected quantities). +c It it essentially a special way of calling the subroutine aim. +c Written by Alex Dragt 6/15/89 +c Revised (interim) by Tom Mottershead, 30 May 91 +c----------------------------------------------------------------------- + include 'impli.inc' + include 'files.inc' + dimension p(6), pp(6) +c +c set up control parameters for pass thru to aim +c + pp(1) = 1.d0 + pp(2) = p(1) + pp(3) = p(2) + pp(4) = 0.d0 + pp(5) = p(3) + pp(6) = p(4) +c +c write(jof,*) ' ' +c write(jof,*) ' In subroutine sq' + call aim(pp) +c + return + end +c +c******************************************************************** +c + subroutine stopit(loon) +c +c stops loop number loon = 1 for inner loop +c = 2 for outer loop +c +c T. Mottershead LANL AT-3 7 Oct 91 +c---------------------------------------------------- + include 'impli.inc' + include 'files.inc' + include 'labpnt.inc' + if(loon.eq.2) then + jocnt = notms + else + jicnt = nitms + endif + iquiet = 0 + return + end +c +************************************************************************ +c + subroutine subtip(p) +c subroutine for terminating an inner procedure +c Written by Alex Dragt on 8-8-88. Modified 9-3-90 AJD +c + include 'impli.inc' + include 'labpnt.inc' + include 'files.inc' +c + dimension p(6) + character*1 yn +c + iopt=nint(p(1)) + if (iopt.eq.1) then +c jif = 5 + write(jof,*) ' ' + write(jof,*) + & ' Do you wish to jump out of inner procedure? (y/n) :' + yn='n' + read(jif,177) yn + 177 format(a) + if ((yn .eq.'y').or.(yn .eq.'Y')) then + jicnt=0 + return + endif + endif +c + jicnt=jicnt+1 + if (jicnt.lt.nitms) then +c write(6,*) 'lp in epro is',lp + lp=jbipnt + return + else + jicnt=0 + iquiet=0 + return + endif +c + end +c +********************************************************************* +c + subroutine subtop(p) +c subroutine for terminating an outer procedure +c Written by Alex Dragt on 8-8-88. Modified 9-3-90 AJD +c + include 'impli.inc' + include 'labpnt.inc' + include 'files.inc' +c + dimension p(6) + character*1 yn +c + iopt=nint(p(1)) + if (iopt.eq.1) then +c jif = 5 + write(jof,*) ' ' + write(jof,*) + & ' Do you wish to jump out of outer procedure? (y/n) :' + yn='n' + read(jif,177) yn + 177 format(a) + if ((yn .eq.'y').or.(yn .eq.'Y')) then + jocnt=0 + return + endif + endif +c + jocnt=jocnt+1 + if (jocnt.lt.notms) then +c write(6,*) 'lp in epro is',lp + lp=jbopnt + return + else + jocnt=0 + iquiet = 0 + return + endif +c + end +c +*************************************************************** +c + subroutine txtnum(str,nch,nask,nget,bufr) +c +c txtnum scans the first nch characters of the string 'str' for +c real numbers in any format. all non-numeric characters +c serve as delimiters. +c +c parameters: +c str - the input character string to be searched +c nch - length of character string to be searched +c nask - maximum length of number list +c nget - actual number of numbers found +c bufr - output array of real numbers +c +c T. Mottershead Los Alamos June 1985 +c---------------------------------------------------------- + implicit double precision(a-h,o-z) +c----------------------------------------------------------------------- + dimension bufr(*) + dimension numc(4) ,ntyp(17) + character*1 ic + character*17 numric + character numdat*30, card*30, str*(*) + data ntyp /10*1,2*2,3,4*4/ + save ntyp !cryne 7/23/2002 + numric='0123456789+-.EeDd' + maxch=len(str) + if(maxch.gt.nch) maxch=nch + indx=0 + maxc=30 + nget=0 +c write(6,17) +c 17 format(' err nget -----numc-----',16x,'extracted text',5x +c $,'value') +c +c scan for numeric characters +c + 90 do 95 j=1,4 + 95 numc(j)=0 + idc=0 + 100 continue + indx=indx+1 + if(indx.le.maxch) go to 110 + if(idc.gt.0) go to 200 + go to 599 + 110 ic=str(indx:indx) + nn=index(numric,ic) + if(nn.eq.0) go to 200 +c +c valid numeric character found, save in decode buffer: +c + kk=ntyp(nn) + numc(kk)=numc(kk)+1 + idc=idc+1 + numdat(idc:idc)=ic + go to 100 +c +c delimiter character, check for valid string +c + 200 continue + if(idc.eq.0) go to 100 + if((numc(1).eq.0).or.(numc(2).gt.2)) go to 90 + if((numc(3).gt.1).or.(numc(4).gt.1)) go to 90 +c +c possible string, right justify and decode +c + if(idc.gt.maxc) idc=maxc + m=maxc-idc+1 + card=' ' + value=-7777777.d0 + card(m:maxc)=numdat(1:idc) + read(card,301,iostat=numerr) value +cryne?read(card,*,iostat=numerr) value + 301 format(f30.0) +c write(6,317) numerr,nget+1,numc,card,value +c 317 format(6i4,a30,1pg16.7) +c +c save the good ones in the output buffer +c + if(numerr.eq.0) then + nget=nget+1 + bufr(nget)=value + if(nget.eq.nask) go to 599 + endif + go to 90 + 599 return + end +c +ccccccccccccccccccccccc valuat ccccccccccccccccccccccccc +c + function valuat(ku,nsu,idu,jdu) +cryne 12/15/2004 modified to use new common block structure in stmap.inc +cryne Originally: +cryne common/stmap/sf1(monoms),sf2(monoms),sf3(monoms),... +cryne# ... sm4(6,6),sm5(6,6) +cryne which is equivalenced to: +cryne dimension sfa(monoms,5), sma(6,6,5) +cryne Replaced with: +cryne common/stmap/storedpoly(monoms,20),storedmat(6,6,20) + use rays + use lieaparam, only : monoms + include 'impli.inc' + include 'fitdat.inc' + include 'buffer.inc' + include 'stmap.inc' + include 'usrdat.inc' + include 'map.inc' + include 'merit.inc' +cryne 20 March 2006 added keyset.inc to get access to maxjlen + include 'keyset.inc' + dimension matsig(6,6) + data matsig /7,8,9,10,11,12,8,13,14,15,16,17,9,14,18,19,20,21, + & 10,15,19,22,23,24,11,16,20,23,25,26,12,17,21,24,26,27/ + save matsig !cryne 7/23/2002 + noffset=9 +cryne----20 March, 2006: + if(ku.eq.57)then + valuat=arclen + return + endif +cryne---- +c +cryne----20 March 2006: +c if(ku.gt.12) then +c valuat = fitval(ku - 8) +c noffset is determined by: +c position of 'tx' in array key minus noffset=position of tux in fitdat +c As of today, 14-noffset=5, i.e. noffset=9 +c As of today, this is hardwired at at routine entry (for debugging) +c Also, variable maxjlen (formerly hardwired 12) = length of maxj array + if(ku.gt.maxjlen) then + valuat = fitval(ku - noffset) + return + endif + go to (10,20,30,40,50,60,70,80,90,100,110,120,130), ku +c +c stored maps +c + 10 continue +cryne valuat = sma(idu,jdu,nsu) + valuat = storedmat(idu,jdu,nsu) + return +c +c map buffers +c + 20 continue + valuat = bma(idu,jdu,nsu) + return +c +c stored polynomials +c + 30 continue +cryne valuat = sfa(idu,nsu) + valuat = storedpoly(idu,nsu) + return +c +c polynomial buffers +c + 40 continue + valuat = bfa(idu,nsu) + return +c +c map matrix +c + 50 continue + valuat = tmh(idu,jdu) + return +c +c beam sigma matrix +c + 60 continue + isig = matsig(idu,jdu) + valuat = bfa(isig,1) + return +c +c ray coordinate +c + 70 continue +cryne valuat = zblock(idu,jdu) + valuat = zblock(jdu,idu) + return +c +c current polynomial +c + 80 continue + valuat = th(idu) + return +c +c user data +c + 90 continue + valuat = ucalc(idu) + return +c +c merit function +c + 100 continue + valuat = val(idu) + return +c +c least squares is just flagged +c + 110 continue + valuat = -777.d0 + return +c +c reference trajectory +c + 120 continue + valuat = reftraj(idu) + return +c +c dispersions +c + 130 continue + valuat = dz(idu) + return + end +c +cccccccccccccccccccccccc VARLIS cccccccccccccccccccccccccc +c + subroutine varlis(jof) +c +c display list of menu item labels +c + use acceldata + include 'impli.inc' +c + dimension kseq(8), lseq(mnumax) + character*8 nwrd(8) +c +cryne + lseq(1:mnumax)=0 +cryne + call lexort(na,lmnlbl,lseq) + nnw = (na+7)/8 + write(jof,11) + 11 format(' MARYLIE #menu entries available to be varied:', + &/72('-')) + do 20 j = 1,nnw + do 15 nn=1,8 +cryne this statement references elements of lseq beyond na, +c so lseq must be initialized to zero or it will cause a core dump + kseq(nn) = lseq(j+(nn-1)*nnw) + 15 continue + do 18 i=1,8 + if (kseq(i).eq.0) nwrd(i) = ' ' + if (kseq(i).ne.0) nwrd(i) = lmnlbl(kseq(i)) + 18 continue + write(jof,19) (nwrd(i),i=1,8) + 19 format(8(1x,a8)) + 20 continue + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine vary(pp) +c +c VARY selects the #menu parameters to vary in fitting procedures +c +c C. T. Mottershead /LANL & L. B. Schweitzer/UCB +c----------------------------------------------------- +c + use acceldata + use lieaparam, only : monoms + include 'impli.inc' + include 'aimdef.inc' + include 'xvary.inc' + include 'labpnt.inc' + include 'files.inc' + include 'codes.inc' +c +c lmnlbl(i) = name of ith element (numbered as they occur in #menu) +c pmenu(k+mpp(i)) = kth parameter of ith element +c nt1(i) = group index of the elements type (see /monics/) +c nt2(i) = type index ..... +c + dimension pp(6), menitm(20), indvar(20) +c +c ltc(i,k) = name of element k in group i +c nrp(i,k) = number of parameters +c both are constants, set in block data names +c + character*128 card, retext + character*12 vword + character*1 yn + logical nodep, rewind +c + write(6,*)'INSIDE VARY' + loon = nint(pp(5)) + if((loon.lt.1).or.(loon.gt.3)) loon = 1 + call chekit(loon,iter,maxit) + if(iter.ne.0) return + ivar=nint(pp(1)) + nodep = .true. + if(ivar.lt.0) then + nodep = .false. + ivar = -ivar + endif +c jif = 5 + infile=nint(pp(2)) + rewind = .true. + if(infile.eq.0) infile = jif + if(infile.eq.jif) rewind = .false. + if(infile.lt.0) then + infile = -infile + rewind = .false. + endif + if(rewind) rewind(infile) + logf = nint(pp(3)) + iscale = nint(pp(4)) + if(iscale.ne.0) write(jof,*)' VARY:scale and bounds not ready yet' + isend = nint(pp(6)) + maxrs = 20 + ktot = 0 + nmax = nsq(loon) + if(ivar.gt.2) nmax = maxv + 5 nrem = nmax + nv = 0 + ibgn = 1 + do 8 j=1,maxv + idx(j,loon) = 0 + mm(j,loon) = 0 + 8 continue + if(infile.ne.jif) go to 40 + 10 call varlis(jof) +c +c select variable parameters +c + 30 if(infile.ne.jif) go to 40 + write(jof,32) + 32 format(/' Enter name and (optional) parameter index for', + &' #menu element(s) to be varied.',/' Elements named following a + & $ may be reset only. Type * to relist') + if(ivar.eq.1) then + write(jof,36) nrem + 36 format(' Selection of',i4,' more elements is required') + else + write(jof,34) nrem + 34 format(' Select up to',i4,' element(s): (Enter a # sign when finis + &hed)') + endif +c +c read a new input line +c + 40 read(infile,41,end=200) card + 41 format(a) + write(jof,41) card + if(card.eq.' ') go to 40 + call low(card) + ifin = index(card,'#') + list = index(card,'*') + idol = index(card,'$') + retext = ' ' +c +c check for reset commands +c + if(idol.gt.0) then + retext = card(idol+1:80) + card(idol+1:80) = ' ' + call vreset(infile,retext,maxrs,ktot,menitm,indvar) + endif +c +c look for normal variable selections +c + write(jof,53) card + 53 format(' New input record:',/,a) + call vscan(card,kount,menitm,indvar) + write(jof,*) kount,' items found in VSCAN' +c +c finish the incomplete specifications +c + do 100 kr = 1, kount + mnu = menitm(kr) + idu = indvar(kr) + mt1 = nt1(mnu) + mt2 = nt2(mnu) + npar=nrp(mt1,mt2) + if(npar.eq.1) idu = 1 + nv = nv + 1 +c write(jof,*) ' card',nv,'=nv',kr,'=kr',mnu,'=mnu',npar,'=npar' + mm(nv,loon) = mnu +c +c ask for new selections for out of bounds parameters +c + 80 if((idu.gt.0).and.(idu.le.npar)) go to 85 + write(jof,81) nv, lmnlbl(mnu), ltc(mt1,mt2) + 81 format(' No.',i3,' is ',2a8,'. Select parameter to vary:') + write(jof,83) (pmenu(k+mpp(mnu)),k = 1,npar) + 83 format(' p=',6(1pg12.4)) + read(jif,*) idu + go to 80 +c +c save valid parameter index and show what is picked so far +c + 85 idx(nv,loon) = idu + 90 write(jof,91) nv, lmnlbl(mnu), ltc(mt1,mt2), idu, npar + 91 format(' No.',i3,' is ',a8,1x,a8,'. Parameter',i2,' out of',i2, + &' selected.') + nch = index(lmnlbl(mnu),' ') +c write(jof,92) nch, mnu, lmnlbl(mnu) +c 92 format(' nch,mnu=',2i6,' name = ',a) + if(nch.eq.0) nch=9 + write(vword,93) idu + 93 format(9x,'(',i1,')') + vword(11-nch:9) = lmnlbl(mnu)(1:nch-1) + varnam(nv,loon) = vword + write(jof,95) varnam(nv,loon),pmenu(idu+mpp(mnu)) + 95 format(1x,a,' = ',1pg21.14) + 100 continue +c +c See if we are finished. If not, go back to read another card +c + nrem = nmax - nv +c write(jof,*) ' VARY end check:',nrem,ifin,list + if(nrem.le.0) go to 200 + if(ifin.ne.0) go to 200 + if(list.ne.0) go to 10 + go to 30 +c +c Display final selections +c + 200 continue + kprt = 0 + if((isend.eq.1).or.(isend.eq.3)) lun = jof + if(isend.eq.2) lun = jodf +cryne 20 March 2006 added "if(isend.ne.0)" to "write(lun..." statements below + 201 if(isend.ne.0)write(lun,203) + 203 format(/' Variable #menu elements selected:') + if(isend.ne.0)write(lun,175) + 175 format(' No. Element',4x,'Type',5x,'Parameter',3x,'Present value' + & /60('-')) + do 170 i = 1,nv + idu = idx(i,loon) + mnu = mm(i,loon) + mt1 = nt1(mnu) + mt2 = nt2(mnu) + if(isend.ne.0) + &write(lun,176) i,lmnlbl(mnu),ltc(mt1,mt2),idu,pmenu(idu+mpp(mnu)) + 176 format(i3,4x,a8,3x,a8,i6,5x,1pg21.14) + 170 continue + if((isend.eq.3).and.(kprt.eq.0)) then + kprt = 1 + lun = jodf + go to 201 + endif +c + if(infile.eq.jif) then + write(jof,*) ' ' + write(jof,*) ' Do you wish to start over? (y/n) :' + yn='n' + read(jif,41) yn + if ((yn .eq.'y').or.(yn .eq.'Y')) go to 5 + endif +c +c select dependent parameters +c + nd = 0 + if(nodep) go to 400 + 300 continue + nd = 0 + nmax = maxv - nv + nrem = nmax + 430 if(infile.ne.jif) go to 340 + write(jof,332) nrem + 332 format(/' Define up to',i4,' dependent variables V by entering the + &ir names',/,' and (optional) parameter indices. (Enter a # sign wh + &en finished)') +c +c read a new input line +c + 340 read(infile,41,end=600) card + write(jof,41) card + if(card.eq.' ') go to 340 + call low(card) + ifin = index(card,'#') + list = index(card,'*') +c +c look for normal variable selections +c + call vscan(card,kount,menitm,indvar) +c +c finish the incomplete specifications +c + if(kount.eq.0) go to 530 + do 500 kr = 1, kount + mnu = menitm(kr) + idu = indvar(kr) + mt1 = nt1(mnu) + mt2 = nt2(mnu) + npar=nrp(mt1,mt2) + if(npar.eq.1) idu = 1 + nd = nd + 1 + mm(nd + nv,loon) = mnu +c +c ask for new selections for out of bounds parameters +c + 380 if((idu.gt.0).and.(idu.le.npar)) go to 355 + write(jof,81) nd, lmnlbl(mnu), ltc(mt1,mt2) + write(jof,83) (pmenu(k+mpp(mnu)),k = 1,npar) + read(jif,*) idu + go to 380 +c +c read new parameter value +c + 355 idx(nd + nv,loon) = idu + write(jof,91) nd, lmnlbl(mnu), ltc(mt1,mt2), idu, npar + if(infile.eq.jif) write(jof,357) nv + 357 format(' Enter ID (1 to',i4,') of independent variable x , and the + & derivative dV/dx:') + read(infile,*) ivn, deriv + idv(nd,loon) = ivn + xslope(nd,loon) = deriv + pval = pmenu(idx(ivn,loon)+mpp(mm(ivn,loon))) + xbase(nd,loon) = pmenu(idu+mpp(mnu)) - xslope(nd,loon)*pval + 500 continue +c +c See if we are finished. If not, go back to read another card +c + 530 nrem = nmax - nd + if(nrem.le.0) go to 600 + if(ifin.ne.0) go to 600 + if(list.ne.0) go to 200 + go to 430 +c +c Display final selections +c + 600 continue + if(nd.le.0) go to 650 + kprt = 0 + if((isend.eq.1).or.(isend.eq.3)) lun = jof + if(isend.eq.2) lun = jodf +cryne 20 March 2006 added "if(isend.ne.0)" to "write(lun..." statements below + 301 if(isend.ne.0)write(lun,303) + 303 format(/' Dependent #menu elements selected:') + if(isend.ne.0)write(lun,375) + 375 format(' No. Element',4x,'Type',5x,'Parameter',3x,'Present value' + &,6x,' IDV Slope', /72('-')) + do 570 i = 1,nd + idu = idx(i+nv,loon) + mnu = mm(i+nv,loon) + mt1 = nt1(mnu) + mt2 = nt2(mnu) + if(isend.ne.0) + &write(lun,376) i,lmnlbl(mnu),ltc(mt1,mt2),idu,pmenu(idu+mpp(mnu)), + & idv(i,loon), xslope(i,loon) + 376 format(i3,3x,a8,3x,a8,i4,5x,1pg21.14,i5,0pf10.5) + 570 continue + if((isend.eq.3).and.(kprt.eq.0)) then + kprt = 1 + lun = jodf + go to 301 + endif +c + 650 if(infile.eq.jif) then + write(jof,*) ' ' + write(jof,*) ' Do you wish to start over? (y/n) :' + yn='n' + read(jif,41) yn + if ((yn .eq.'y').or.(yn .eq.'Y')) go to 300 + endif +c +c write final selections to log file +c + 400 if(logf.gt.0) then + do 410 i = 1,nv + write(logf,407) lmnlbl(mm(i,loon)), idx(i,loon) + 407 format(2x,a8,2x,i2) + 410 continue + if(nd.gt.0) then + if(ivar.gt.1) write(logf,*) ' #' + do 450 j = 1,nd + i = j + nv + write(logf,407) lmnlbl(mm(i,loon)), idx(i,loon) + write(logf,*) idv(j,loon), xslope(j,loon) + 450 continue + endif + write(logf,*) ' #' + endif + nva(loon) = nv + nda(loon) = nd + return + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine vreset(infile,retext,maxrs,ktot,mrset,irset) + use acceldata + include 'impli.inc' + include 'files.inc' + include 'codes.inc' + dimension menitm(20), indvar(20), mrset(*), irset(*) + character*(*) retext + jout = jof + if(infile.ne.jif) jout = jodf +c +c lmnlbl(i) = name of ith element (numbered as they occur in #menu) +c pmenu(k+mpp(i)) = kth parameter of ith element +c nt1(i) = group index of the elements type (see /monics/) +c nt2(i) = type index ..... +c ltc(i,k) = name of element k in group i +c nrp(i,k) = number of parameters +c both are constants, set in block data names +c + call vscan(retext,kount,menitm,indvar) +c write(jof,*) ' after vscan:',kount,'=kount' +c write(jof,*) ' menitm:',(menitm(j),j=1,kount) +c write(jof,*) ' indvar:',(indvar(j),j=1,kount) +c +c complete the resets +c + do 60 kr = 1, kount + mnu = menitm(kr) + idu = indvar(kr) + mt1 = nt1(mnu) + mt2 = nt2(mnu) + npar=nrp(mt1,mt2) + if(npar.eq.0) go to 60 +c write(jof,*) ' vreset',kr,'=kr',mnu,'=mnu',idu,'=idu',mt1,'=mt1 +c &,mt2,'=mt2', npar,'=npar' + if(npar.eq.1) idu = 1 +c +c ask for new selections for out of bounds parameters +c + 50 if((idu.gt.0).and.(idu.le.npar)) go to 55 + write(jout,51) lmnlbl(mnu), ltc(mt1,mt2) + 51 format(' Select parameter to reset for ',2a8) + write(jout,53) (pmenu(k+mpp(mnu)),k = 1,npar) + 53 format(1x,6(1pe13.5)) + read(infile,*) idu + go to 50 +c +c valid index, read new parameter value +c + 55 pval = pmenu(idu+mpp(mnu)) + write(jout,57) idu, lmnlbl(mnu), pval + 57 format(' Enter new value for parameter',i2,' of ',a8, + & ' <',1pg16.8,'>:') + read(infile,*) pval + pmenu(idu+mpp(mnu)) = pval + ktot = ktot + 1 + if(ktot.le.maxrs) then + mrset(ktot) = mnu + irset(ktot) = idu + endif + 60 continue + return + end +c +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine vscan(card,kount,menitm,indvar) +c +c VSCAN scans the character array card for valid #menu +c items (menitm) and parameter selections (indvar) +c C. T. Mottershead /LANL AT-3 18 July 90 +c----------------------------------------------------- + use acceldata + include 'impli.inc' + include 'codes.inc' +c +c nt1(i) = group index of the elements type (see /monics/) +c nt2(i) = type index ..... +c nrp(i,k) = number of parameters +c both are constants, set in block data names +c + dimension menitm(*), indvar(*) + character*(*) card + character*10 string + logical lfound, lnum, leftel +c +c parse the input card +c + kbeg = 1 + leftel = .false. + kount = 0 + npar = 0 + 50 continue + msegm=2 + call cread(kbeg,msegm,card,string,lfound) + if(.not.lfound) return +c +c string found, see if it is an element +c + call lookup(string,itype,mnu) + if(itype.ne.1) go to 60 +c +c it is an element +c + mt1 = nt1(mnu) + mt2 = nt2(mnu) + npar=nrp(mt1,mt2) +c +c reject if no parameters +c + if(npar.eq.0) then + leftel = .false. + go to 50 + endif +c +c accept it because it has parameters +c + kount = kount + 1 + menitm(kount) = mnu + indvar(kount) = 0 + leftel = .true. + go to 50 +c +c it isn't an element, see if it is a number +c +cryne August 5, 2004 +cryne Calling cnumb0 (the original version of cnumb) solved a +cryne problem that I was having in which the code would not run +cryne one of Peter Walstrom's examples. The reason for this is +cryne most likely that cnumb was modified for to tread 16 character +cryne strings, but in this routine the dimension is 10. A single +cryne version of cnumb would probably work if it used LEN(string) +cryne instead of hardwired values such as 10 or 16. +cryne This should be checked later, and the two versions consolidated +cryne if possible. + 60 call cnumb(string,num0,lnum) +c +c if it is a number, and a preceeding element is defined, and it is +c in bounds, interpret it as the selected parameter for that element +c + if(lnum.and.leftel) then + if((num0.ge.1).and.(num0.le.npar)) indvar(kount) = num0 + endif + leftel = .false. + go to 50 + end +c +cccccccccccccccccccccc WRTAIM ccccccccccccccccccccccccc +c + subroutine wrtaim(lun,kaim,loon) +c-----!----------------------------------------------------------------! + include 'impli.inc' + include 'aimdef.inc' + include 'fitbuf.inc' + include 'files.inc' + dimension aimbuf(3) + if(kaim.le.3) write(lun,*)' ' + if(kaim.le.3) write(lun,*)' Aims selected : ' + if(kaim.eq.1) write(lun,103) + 103 format(' No. item',6x,'present value',/35('-')) + if(kaim.eq.2) write(lun,105) + 105 format(' No. item',8x,'present value',8x,'target value', + & /53('-')) + if(kaim.eq.3) write(lun,107) + 107 format(' No. item',8x,'present value',8x,'target value', + & 8x,'weights', /70('-')) + jmin = 1 + jmax = kaim + if(kaim.gt.3) then + jmin = 2 + jmax = 3 + endif + nf = nsq(loon) + do 100 nu = 1, nf + ku = kyf(nu,loon) + nsu = nsf(nu,loon) + idu = idf(nu,loon) + jdu = jdf(nu,loon) + aimbuf(1) = valuat(ku,nsu,idu,jdu) + aimbuf(2) = target(nu,loon) + aimbuf(3) = wts(nu,loon) + write(lun,96) nu, qname(nu,loon), (aimbuf(j),j=jmin,jmax) + 96 format(i3,' ',a,' = ',2(1pg20.9),0pf14.4) + go to 100 + 100 continue + return + end +c +ccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine wrtsq(lun,kform,nf,names,values) +c +c Output selected quantities array to unit lun in format kform. +c +c kform = format selection flag +c = 0 to write names only +c = 1 to write a line of values (6 digit accuracy) +c = 2 to write 3 names and values per line (8 digit accuracy) +c = 3 to write a single value per line, full precision +c Tom Mottershead, 31 May 91 +c-----!----------------------------------------------------------------! + use lieaparam, only : monoms + include 'impli.inc' + include 'map.inc' + dimension values(*) + character*(*) names(*) +c write(lun,*) ' *WRTSQ:',nf,' = number items' +c +c format 0: labels only +c + if(kform.eq.0) then + write(lun,63) (names(i), i=1,nf) + 63 format(10(1x,a12)) + endif +c +c format 1: 6 digit columns +c + if(kform.eq.1) then +cryne 20 March 2006 write(lun,67) arclen, (values(i), i=1,nf) + write(lun,67) (values(i), i=1,nf) + 67 format(10(1pe13.5)) + endif +c +c format 2: 3 on a line +c + if(kform.eq.2) then +c write(lun,43) ((names(i),values(i)),i=1,nf) + write(lun,43) (names(i),values(i),i=1,nf) + 43 format(3(a12,'=',1pg13.6)) + endif +c +c format 3: full precision +c + if(kform.eq.3) then + do 25 nu = 1, nf + write(lun,27) nu, names(nu), values(nu) + 27 format(' SQ',i3,': ',a,' = ', 1pg23.15) + 25 continue + endif + return + end +c +c******************************************************************* +c + subroutine wrtvar(kpik,lun) +c +c Display new values for parameters. +c + use acceldata + include 'impli.inc' + include 'codes.inc' + include 'xvary.inc' + loon = kpik + if((loon.lt.1).or.(loon.gt.3)) loon = 1 + nv = nva(loon) + nd = nda(loon) + write(lun,*)' ' + write(lun,*)' New values for parameters:' + write(lun,65) + 65 format(' No. Element',4x,'Type',3x,'Parameter',3x,'Present value' + &,8x,' IDV Slope', /72('-')) + do 50 i = 1,nv + idu = idx(i,loon) + mnu = mm(i,loon) + mt1 = nt1(mnu) + mt2 = nt2(mnu) + write(lun,48) i,lmnlbl(mnu),ltc(mt1,mt2),idu,pmenu(idu+mpp(mnu)) + 48 format(i3,3x,a8,3x,a8,i4,5x,1pg21.14) + 50 continue + do 70 i = 1,nd + j = i + nv + idu = idx(j,loon) + mnu = mm(j,loon) + mt1 = nt1(mnu) + mt2 = nt2(mnu) + write(lun,68) j,lmnlbl(mnu),ltc(mt1,mt2),idu,pmenu(idu+mpp(mnu)), + & idv(i,loon), xslope(i,loon) + 68 format(i3,3x,a8,3x,a8,i4,5x,1pg21.14,i5,0pf10.4) + 70 continue + return + end +c +ccccccccccccccccccc wsq cccccccccccccccccccccccccc +c +c + subroutine wsq(pp) +c subroutine for writing out selected quantities +c Written by Alex Dragt, 21 August 1988 +c Filled in by Tom Mottershead, 30 May 91 +c +c-----!----------------------------------------------------------------! + use acceldata + include 'impli.inc' + include 'files.inc' + include 'aimdef.inc' + include 'xvary.inc' + include 'usrdat.inc' + dimension pp(6), qbuf(30) + character*12 names(30) + job = nint(pp(1)) + loon = nint(pp(2)) + if((loon.lt.1).or.(loon.gt.3)) loon = 1 + lun = nint(pp(3)) + kform = nint(pp(4)) + jform = nint(pp(5)) + isend = nint(pp(6)) + nv = 0 + nf = 0 + numq = 0 +c write(jof,*)job,loon,lun,kform,jform,isend,' = WSQ (PP)' + if(job.eq.4) go to 100 +c +c copy variables to print buffers +c + if(job.eq.1) go to 50 + nv = nva(loon) + numq = nv + if(numq.gt.30) numq = 30 + do 40 i = 1,numq + mnu = mm(i,loon) + qbuf(i) = pmenu(idx(i,loon)+mpp(mnu)) + names(i) = varnam(i,loon) + 40 continue +c +c copy selected quantities (aims) to print buffers +c + 50 if(job.eq.2) go to 100 + nf = nsq(loon) + numq = nf + nv + if(numq.gt.30) then + numq = 30 + nf = 30 - nv + endif + do 60 nu = 1, nf + ku = kyf(nu,loon) + nsu = nsf(nu,loon) + idu = idf(nu,loon) + jdu = jdf(nu,loon) + qbuf(nu+nv) = valuat(ku,nsu,idu,jdu) + names(nu+nv) = qname(nu,loon) + 60 continue +c +c print any rms errors selected in current loon +c + 100 continue + do 150 ku = 1,3 + lu = lsq(ku,loon) + if(lu.ne.1) go to 150 + numq = numq+1 + fval = rmserr(ku) + qbuf(numq) = fval + write(names(numq),141) lu + 141 format(3x,'rms',i1,5x) + 150 continue +c +c print buffers +c +c write(jof,*)' WSQ: nva =', nva +c write(jof,*)' WSQ: nsq =', nsq +c write(jof,*)' * WSQ:',nv,'=nv',nf,'=nf',numq,'=numq total' + if(lun.gt.0) call wrtsq(lun,kform,numq,names,qbuf) + if(isend.ge.2) call wrtsq(jodf,jform,numq,names,qbuf) + if((isend.eq.1).or.(isend.eq.3)) + & call wrtsq(jof,jform,numq,names,qbuf) +c +c copy to ucalc if lun<0 22 Aug 00 CTM from AJD's version +c + if(lun.lt.0) then + ibgn = -lun + do 200 j = 1, numq + ucalc(ibgn+j-1) = qbuf(j) + 200 continue + endif + return + end +c +c*********************************************************************** +cryne August 5, 2004 : This is the original version of cread + subroutine cread0(kbeg,msegm,line,string,lfound) +c----------------------------------------------------------------------- +c This routine searches line(kbeg:80) for the next string; strings are +c delimited by ' ','*' or ','. +c +c Input: line character*80 input line +c kbeg integer line is only searched behind kbeg +c if a string is found, kbeg is set to +c possible start of next string +c msegm integer segment number. for msegm=1 (comment +c section), the length of a string is not +c checked. +c output:string character*10 found string +c lfound logical =.true. if a string was found +c +c Written by Rob Ryne ca 1984 +c Rewritten by Petra Schuett +c October 19, 1987 +c----------------------------------------------------------------------- + include 'impli.inc' + include 'files.inc' +c + integer kbeg + character line*80, string*10 + logical lfound +c +c look for first character of string +c + do 1 k=kbeg,80 + if( (line(k:k).ne.' ') + & .and.(line(k:k).ne.'*') + & .and.(line(k:k).ne.',')) then +c found: + lfound=.true. +c string has max 10 characters + lmax = min(k+10,80) +c look for delimiter + do 2 l=k,lmax + if( (line(l:l).eq.' ') + & .or.(line(l:l).eq.'*') + & .or.(line(l:l).eq.',')) then +c if found, string is known + string=line(k:l-1) + kbeg =l+1 +c done. + return + endif + 2 continue +c no delimiter behind string found... + string=line(k:lmax) +c ...end of line + if(lmax.eq.80) then + kbeg=80 +c ...or string too long (ignored for comment section) + else if (msegm.ne.1) then + write(jof,99) kbeg,line + 99 format(' ---> warning from cread0:'/ + & ' the following line has a very long string at ', + & 'position ',i2,' :'/' ',a80) + kbeg=lmax+1 + endif +c ...anyway, its done. + return + endif + 1 continue +c No string was found after all. + lfound=.false. + return + end +c +c*********************************************************************** +cryne August 5, 2004 : This is the original version of cnumb + subroutine cnumb0(string,num,lnum) +c----------------------------------------------------------------------- +c This routine finds out, whether string codes an integer number. +c if so, it converts it to num +c +c Input: string character*10 input string +c Output:num integer correspondent number +c lnum logical =.true. if string is a number +c +c Author: Petra Schuett +c October 19, 1987 +c----------------------------------------------------------------------- + include 'impli.inc' + include 'files.inc' +c + integer num + character string*10 + logical lnum +c + character*10 digits + save digits + data digits /'0123456789'/ +c----------------- +c The first char may be minus or digit +c write(jodf,*)'cnumb0: string= ',string + if(index(digits,string(1:1)).eq.0 .and. string(1:1).ne.'-') then + lnum=.false. +c write(jodf,*)'first char is no digit' + return + endif +c All other characters must be digits... + do 1 k=2,10 + if(index(digits,string(k:k)).eq.0) then +c ...or trailing blanks + if(string(k:10).ne.' ') then +c write(jodf,*)'string(',k,':10) is not blank' + lnum=.false. + return + else + goto 11 + endif + endif + 1 continue +c string is a number + 11 read(string,*,err=999) num + lnum=.true. + return +c----------------- +c error exit + 999 write(jof ,99) string + write(jodf,99) string + 99 format(' ---> error in cnumb0: string ',a10,' could not be', + &' converted to number') + call myexit + end +c diff --git a/OpticsJan2020/MLI_light_optics/Src/pure.f b/OpticsJan2020/MLI_light_optics/Src/pure.f new file mode 100755 index 0000000..f6a3258 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/pure.f @@ -0,0 +1,576 @@ +*********************************************************************** +* header PURIFYING (PURE) ROUTINES * +* Routines for computing conjugacy classes * +*********************************************************************** +* + subroutine da2(fm,a2a,a2m) +c this is a subroutine that generates the matrix a2m +c that brings fm to block form in the dynamic case +c Written by Alex Dragt, Spring 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fm(6,6),a2a(monoms),a2m(6,6) + dimension reval(6),aieval(6) + dimension revec(6,6),aievec(6,6) +c clear the array a2a + do 10 i=1,monoms + 10 a2a(i)=0. +c compute the eigenvectors of fm + call eig6(fm,reval,aieval,revec,aievec) +c sort these eigenvectors + call dvsort(revec,aievec) +c compute a2m from these eigenvectors + do 20 i=1,6 + a2m(i,1)=revec(1,i) + a2m(i,2)=aievec(1,i) + a2m(i,3)=revec(3,i) + a2m(i,4)=aievec(3,i) + a2m(i,5)=revec(5,i) + a2m(i,6)=aievec(5,i) + 20 continue +c rephase the result + call drphse(a2m) + return + end +c +*********************************************************************** +c + subroutine dpur2(fa,fm,ga,gm,ta,tm) +c this is a subroutine for purifying the f2 (matrix) +c part of a dynamic map. +c fa,fm is the original map, and it is left unchanged. +c ga,gm is the purified map. +c ta,tm is the transforming map. that is g=t*f*(t inverse). +c Written by Alex Dragt, Spring 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms),ta(monoms) + dimension fm(6,6),gm(6,6),tm(6,6) +c find the map a2: + call da2(fm,ta,tm) +c go to floquet variables: + call sndwch(ta,tm,fa,fm,ga,gm) + return + end +c +******************************************************************** +c + subroutine dpur3(fa,fm,ga,gm,ta,tm) +c this is a subroutine for purifying the f3 +c part of a dynamic map. +c fa,fm is the original map, and it is left unchanged. +c ga,gm is the purified map, and ta,tm is the purifying transformation. +c that is, g=t*f*(t inverse). +c Written by Alex Dragt, Spring 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms),ta(monoms) + dimension fm(6,6),gm(6,6),tm(6,6) + ibrief = 1 + detmin = 1.d-12 + min=28 + max=83 + call gdpur(fa,fm,ga,gm,ta,tm,min,max,ibrief,detmin) + return + end +c +****************************************************** +c + subroutine dpur4(fa,fm,ga,gm,ta,tm) +c this is a subroutine for purifying the f4 +c part of a dynamic map. +c fa,fm is the original map, and it is left unchanged. +c ga,gm is the purified map, and ta,tm is the purifying transformation. +c that is, g=t*f*(t inverse). +c Written by Alex Dragt, Spring 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms),ta(monoms) + dimension fm(6,6),gm(6,6),tm(6,6) + ibrief = 1 + detmin = 1.d-12 + min=90 + max=208 + call gdpur(fa,fm,ga,gm,ta,tm,min,max,ibrief,detmin) + return + end +c +************************************************************ +c + subroutine fxpt(fa,fm,ana,anm,ta,tm) +c This is a subroutine for finding the fixed point of a map. +c The initial map is given by fa and fm. It is unchanged by the +c subroutine. The map about the closed orbit corresponding to +c the fixed point is given by ana and anm. The transformation +c to the fixed point is given by the map ta,tm. +c Written by Alex Dragt, 11 October 1985. + use parallel, only : idproc + implicit double precision (a-h,o-z) + dimension fa(923),fm(6,6) + dimension ana(923),anm(6,6) + dimension ta(923),tm(6,6) + dimension tta(923),ttm(6,6) + dimension tempa(923),tempm(6,6) + dimension am(4,4),av(4),alphv(4),augm(4,5) +c Computation of an1: +c Set up am = 4x4 block of fm-i: + do 10 i=1,4 + do 10 j=1,4 + am(i,j)=fm(i,j) + if(i.eq.j) am(i,j)=am(i,j)-1.d0 + 10 continue +c Set up av: + do 20 i=1,4 + 20 av(i)=fm(i,6) +c Compute alphv: + call leshs(alphv,4,am,av,augm,det) +c Write out message about determinant: +cryne Jan 3, 2005 added ".lt. 1.d-3" to only print det if it is small + if(idproc.eq.0 .and. det.lt.1.d-3)write(6,600) det + 600 format(1x,'det in fxpt is',e15.4) +c Compute t1: + call ident(ta,tm) + do 30 i=1,4 + 30 tm(i,6)=-alphv(i) + tm(5,1)=alphv(2) + tm(5,2)=-alphv(1) + tm(5,3)=alphv(4) + tm(5,4)=-alphv(3) +c Store t1 + call mapmap(ta,tm,tta,ttm) +c Compute t1*m*t1inv where m is initial map: + call sndwch(ta,tm,fa,fm,ana,anm) +c call mycat(6,ta,tm,fa,fm,tempa,tempm) +c call inv(ta,tm) +c call mycat(6,tempa,tempm,ta,tm,ana,anm) +c Computation of an2: +c Set up am: + call mapmap(ana,anm,tempa,tempm) + call inv(tempa,tempm) + do 40 i=1,4 + do 40 j=1,4 + am(i,j)=tempm(j,i) + if(i.eq.j) am(i,j)=am(i,j)-1.d0 + 40 continue +c Set up av: + av(1)=-ana(48) + av(2)=-ana(63) + av(3)=-ana(73) + av(4)=-ana(79) +c Compute alphv: + call leshs(alphv,4,am,av,augm,det) +c Compute t2: + call ident(ta,tm) + ta(48)=alphv(1) + ta(63)=alphv(2) + ta(73)=alphv(3) + ta(79)=alphv(4) +c Compute and store t2*t1 +c call mycat(6,ta,tm,tta,ttm,tempa,tempm) +cryne 8/16/02 call concat(6,ta,tm,tta,ttm,tempa,tempm) + call concat(ta,tm,tta,ttm,tempa,tempm) + call mapmap(tempa,tempm,tta,ttm) +c Compute t2*an1*t2inv: + call sndwch(ta,tm,ana,anm,ana,anm) +c call mycat(6,ta,tm,ana,anm,tempa,tempm) +c call inv(ta,tm) +c call mycat(6,tempa,tempm,ta,tm,ana,anm) +c Computation of an3: +c The matrix am is unchanged from the previous step. +c Set up av: + av(1)=-ana(139) + av(2)=-ana(174) + av(3)=-ana(194) + av(4)=-ana(204) +c Compute alphv: + call leshs(alphv,4,am,av,augm,det) +c Compute t3: + call ident(ta,tm) + ta(139)=alphv(1) + ta(174)=alphv(2) + ta(194)=alphv(3) + ta(204)=alphv(4) +c Compute and store t3*t2*t1: +c call mycat(6,ta,tm,tta,ttm,tempa,tempm) +cryne 8/16/02 call concat(6,ta,tm,tta,ttm,tempa,tempm) + call concat(ta,tm,tta,ttm,tempa,tempm) + call mapmap(tempa,tempm,tta,ttm) +c Compute t3*an2*t3inv: + call sndwch(ta,tm,ana,anm,ana,anm) +c call mycat(6,ta,tm,ana,anm,tempa,tempm) +c call inv(ta,tm) +c call mycat(6,tempa,tempm,ta,tm,ana,anm) +c Computation of an4: +c The matrix am is the same for all orders. +c Set up av: + av(1)=-ana(335) + av(2)=-ana(405) + av(3)=-ana(440) + av(4)=-ana(455) +c Compute alphv: + call leshs(alphv,4,am,av,augm,det) +c Compute t4: + call ident(ta,tm) + ta(335)=alphv(1) + ta(405)=alphv(2) + ta(440)=alphv(3) + ta(455)=alphv(4) +c Compute and store t4*t3*t2*t1: +c call mycat(6,ta,tm,tta,ttm,tempa,tempm) +cryne 8/16/02 call concat(6,ta,tm,tta,ttm,tempa,tempm) + call concat(ta,tm,tta,ttm,tempa,tempm) + call mapmap(tempa,tempm,tta,ttm) +c Compute t4*an3*t4inv: + call sndwch(ta,tm,ana,anm,ana,anm) +c Computation of an5: +c Set up av: + av(1)=-ana(713) + av(2)=-ana(839) + av(3)=-ana(895) + av(4)=-ana(916) +c Compute alphv: + call leshs(alphv,4,am,av,augm,det) +c Compute t5: + call ident(ta,tm) + ta(713)=alphv(1) + ta(839)=alphv(2) + ta(895)=alphv(3) + ta(916)=alphv(4) +c Compute and store t5*t4*t3*t2*t1: +c call mycat(6,ta,tm,tta,ttm,tempa,tempm) +cryne 8/16/02 call concat(6,ta,tm,tta,ttm,tempa,tempm) + call concat(ta,tm,tta,ttm,tempa,tempm) + call mapmap(tempa,tempm,tta,ttm) +c Compute an5 = t5*an4*t5inv: + call sndwch(ta,tm,ana,anm,ana,anm) +c Store t5*t4*t3*t2*t1 in t: + call mapmap(tta,ttm,ta,tm) + return + end +c +*********************************************************************** +c + subroutine gdpur(fa,fm,ga,gm,ta,tm,min,max, + & ibrief,detmin) +c This is a generic purifying routine for the +c dynamic resonance case +c fa,fm is the original map, which is left unchanged. +c ga,gm is the purified map, and ta,tm is the purifying +c transformation, that is g=t*f*(t inverse) +c min and max are the minimum and maximum index +c of the monomials to be purified +c Written by Alex Dragt and F. Neri, Spring 1986 + use parallel, only : idproc + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(*),ga(*),ta(*),t1a(monoms),t2a(monoms) + dimension fm(6,6),gm(6,6),tm(6,6),t1m(6,6),t2m(6,6) + dimension ax(-4:4),bx(-4:4),ay(-4:4),by(-4:4),at(-4:4),bt(-4:4) + include 'dr.inc' +c +c Set up multiple angle arrays + cwx = fm(1,1) + swx = fm(1,2) + cwy = fm(3,3) + swy = fm(3,4) + cwt = fm(5,5) + swt = fm(5,6) + ax(0)=1.d0 + bx(0)=0.d0 + ay(0)=1.d0 + by(0)=0.d0 + at(0)=1.d0 + bt(0)=0.d0 + ax(1)=cwx + bx(1)=swx + ay(1)=cwy + by(1)=swy + at(1)=cwt + bt(1)=swt +c + do 10 n=2,4 + ax(n)=ax(1)*ax(n-1)-bx(1)*bx(n-1) + bx(n)=bx(1)*ax(n-1)+ax(1)*bx(n-1) + 10 continue +c + do 20 n=2,4 + ay(n)=ay(1)*ay(n-1)-by(1)*by(n-1) + by(n)=by(1)*ay(n-1)+ay(1)*by(n-1) + 20 continue +c + do 30 n=2,4 + at(n)=at(1)*at(n-1)-bt(1)*bt(n-1) + bt(n)=bt(1)*at(n-1)+at(1)*bt(n-1) + 30 continue +c + do 40 n=1,4 + ax(-n)=ax(n) + bx(-n)=-bx(n) + ay(-n)=ay(n) + by(-n)=-by(n) + at(-n)=at(n) + bt(-n)=-bt(n) + 40 continue +c +c Resonance decompose map: + call ctodr(fa,t1a) +c +c Set up map to remove offensive terms of index min->max: + call ident(t2a,t2m) + do 100 k=min,max + if (drexp(0,k).ne.0) then +c compute cth=cos(theta) and sth=sin(theta) for +c theta = drexp(1,k)*wx + drexp(2,k)*wy + drexp(3,k)*wt + nx=drexp(1,k) + ny=drexp(2,k) + nt=drexp(3,k) + axnx=ax(nx) + bxnx=bx(nx) + ayny=ay(ny) + byny=by(ny) + atnt=at(nt) + btnt=bt(nt) + cth=(axnx*ayny-bxnx*byny)*atnt-(axnx*byny+bxnx*ayny)*btnt + sth=(axnx*ayny-bxnx*byny)*btnt+(axnx*byny+bxnx*ayny)*atnt +c +c Carry out rest of calculation + det = 2.d0 * (1.d0 - cth) + k1 = k + k2 = k+1 + if ( ibrief.ne.1 ) then + if(idproc.eq.0) + & write(6,*) ' Det in subspace',k1,',',k2,' is',det + endif + if ( dabs(det) .gt. detmin) then + t2a(k1) = ((1.-cth)*t1a(k1) + sth*t1a(k2))/det + t2a(k2) = ((1.-cth)*t1a(k2) - sth*t1a(k1))/det + else + if(idproc.eq.0) + & write(6,*) ' Det(',k1,',',k2,') =',det,' not removed' + endif + endif + 100 continue +c transfom map t2 to cartesian basis; the result is the map t: + call ident(ta,tm) + call drtoc(t2a,ta) +c remove offensive terms ( min->max ) + call sndwch(ta,tm,fa,fm,ga,gm) + return + end +c +************************************************************************ +c + subroutine gspur(fa,fm,ga,gm,ta,tm,min,max, + & ibrief,detmin) +c This is a generic purifying routine for the +c static resonance case +c fa,fm is the original map, which is left unchanged. +c ga,gm is the purified map, and ta,tm is the purifying +c transformation, that is g=t*f*(t inverse) +c min and max are the minimum and maximum index +c of the monomials to be purified +c Written by Alex Dragt and F. Neri, Spring 1986 + use parallel, only : idproc + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(*),ga(*),ta(*),t1a(monoms),t2a(monoms) + dimension fm(6,6),gm(6,6),tm(6,6),t1m(6,6),t2m(6,6) + dimension ax(-4:4),bx(-4:4),ay(-4:4),by(-4:4) + include 'sr.inc' +c +c Set up multiple angle arrays + cwx = fm(1,1) + swx = fm(1,2) + cwy = fm(3,3) + swy = fm(3,4) + ax(0)=1.d0 + bx(0)=0.d0 + ay(0)=1.d0 + by(0)=0.d0 + ax(1)=cwx + bx(1)=swx + ay(1)=cwy + by(1)=swy +c + do 10 n=2,4 + ax(n)=ax(1)*ax(n-1)-bx(1)*bx(n-1) + bx(n)=bx(1)*ax(n-1)+ax(1)*bx(n-1) + 10 continue +c + do 20 n=2,4 + ay(n)=ay(1)*ay(n-1)-by(1)*by(n-1) + by(n)=by(1)*ay(n-1)+ay(1)*by(n-1) + 20 continue +c + do 30 n=1,4 + ax(-n)=ax(n) + bx(-n)=-bx(n) + ay(-n)=ay(n) + by(-n)=-by(n) + 30 continue +c +c Resonance decompose map: + call ctosr(fa,t1a) +c +c Set up map to remove offensive terms of index min->max: + call ident(t2a,t2m) + do 100 k=min,max + if (srexp(0,k).ne.0) then +c compute cth =cos(theta) and sth=sin(theta) for +c theta = srexp(1,k)*wx + srexp(2,k)*wy + nx=srexp(1,k) + ny=srexp(2,k) + axnx=ax(nx) + bxnx=bx(nx) + ayny=ay(ny) + byny=by(ny) + cth=axnx*ayny-bxnx*byny + sth=bxnx*ayny+axnx*byny +c +c Carry out rest of calculation + det = 2.d0 * (1.d0 - cth) + k1 = k + k2 = k+1 + if ( ibrief.ne.1 ) then + if(idproc.eq.0) + & write(6,*) ' Det in subspace',k1,',',k2,' is',det + endif + if ( dabs(det) .gt. detmin) then + t2a(k1) = ((1.-cth)*t1a(k1) + sth*t1a(k2))/det + t2a(k2) = ((1.-cth)*t1a(k2) - sth*t1a(k1))/det + else + if(idproc.eq.0) + & write(6,*) ' Det(',k1,',',k2,') =',det,' not removed' + endif + endif + 100 continue +c transform map to cartesian basis; the result is the map t: + call ident(ta,tm) + call srtoc(t2a,ta) +c remove offensive terms ( min->max ) + call sndwch(ta,tm,fa,fm,ga,gm) + return + end +c +************************************************************* +c + subroutine sa2(fm,a2a,a2m) +c this is a subroutine that generates the matrix a2m +c that brings fm to block form in the static case +c Written by Alex Dragt, Spring 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fm(6,6),a2a(monoms),a2m(6,6) + dimension reval(6),aieval(6) + dimension revec(6,6),aievec(6,6) +c clear the array a2a + do 10 i=1,monoms + 10 a2a(i)=0. +c compute the eigenvectors of fm + call eig4(fm,reval,aieval,revec,aievec) +c sort these eigenvectors + call svsort(revec,aievec) +c compute a2m from these eigenvectors + do 20 i=1,6 + a2m(i,1)=revec(1,i) + a2m(i,2)=aievec(1,i) + a2m(i,3)=revec(3,i) + a2m(i,4)=aievec(3,i) + a2m(i,5)=revec(5,i) + a2m(i,6)=revec(6,i) + 20 continue +c rephase the result + call srphse(a2m) + return + end +c +*********************************************************************** +c + subroutine scpur3(fa,fm,ga,gm,ta,tm) +c this is a subroutine for purifying the chromatic f3 +c part of a static map. +c fa,fm is the original map, and it is left unchanged. +c ga,gm is the purified map, and ta,tm is the purifying transformation. +c that is, g=t*f*(t inverse). +c Written by Alex Dragt, Spring 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms),ta(monoms) + dimension fm(6,6),gm(6,6),tm(6,6) + ibrief = 1 + detmin = 1.d-12 + min=31 + max=42 + call gspur(fa,fm,ga,gm,ta,tm,min,max,ibrief,detmin) + return + end +c +************************************************** +c + subroutine sgpur3(fa,fm,ga,gm,ta,tm) +c this is a subroutine for purifying the geometric f3 +c part of a static map. +c fa,fm is the original map, and it is left unchanged. +c ga,gm is the purified map, and ta,tm is the purifying transformation. +c that is, g=t*f*(t inverse). +c Written by Alex Dragt, Spring 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms),ta(monoms) + dimension fm(6,6),gm(6,6),tm(6,6) + ibrief = 1 + detmin = 1.d-12 + min=43 + max=62 + call gspur(fa,fm,ga,gm,ta,tm,min,max,ibrief,detmin) + return + end +c +****************************************************** +c + subroutine spur2(fa,fm,ga,gm,ta,tm,t2m) +c this is a subroutine for purifying the f2 (matrix) +c part of a static map. +c fa,fm is the original map, and it is left unchanged. +c ga,gm is the purified map. +c ta,tm is the transforming map. that is g=t*f*(t inverse). +c the matrix t2m associated with a2 is also returned. +c Written by Alex Dragt, Spring 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms),ta(monoms),t1a(monoms),t2a(monoms) + dimension fm(6,6),gm(6,6),tm(6,6),t1m(6,6),t2m(6,6) +c go to the off momentum closed orbit: + call fxpt(fa,fm,ta,tm,t1a,t1m) +c find the map a2: + call sa2(tm,t2a,t2m) +c go to floquet variables: + call sndwch(t2a,t2m,ta,tm,ga,gm) +c accumulate transforming map: + call concat(t2a,t2m,t1a,t1m,ta,tm) + return + end +c +******************************************************************** +c +c + subroutine spur4(fa,fm,ga,gm,ta,tm) +c this is a subroutine for purifying the f4 +c part of a static map. +c fa,fm is the original map, and it is left unchanged. +c ga,gm is the purified map, and ta,tm is the purifying transformation. +c that is, g=t*f*(t inverse). +c Written by Alex Dragt, Spring 1986 + use lieaparam, only : monoms + include 'impli.inc' + dimension fa(monoms),ga(monoms),ta(monoms) + dimension fm(6,6),gm(6,6),tm(6,6) + ibrief = 1 + detmin = 1.d-12 + min=90 + max=153 + call gspur(fa,fm,ga,gm,ta,tm,min,max,ibrief,detmin) + return + end +c +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/rfgap.f b/OpticsJan2020/MLI_light_optics/Src/rfgap.f new file mode 100755 index 0000000..fbedc2c --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/rfgap.f @@ -0,0 +1,809 @@ +c IMPACT RF Gap routines +c Copyright 2001 University of California +c + subroutine rfgap(zedge,zmap,nstep,rffreq,escale,theta0, & + &t00,gam00,itype,h,mh) +cryne use Dataclass +c h(28-209) = 2nd order and 3rd order map, mh(6,6)=transfer matrix + use parallel, only : idproc + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' +cryne include 'para.inc' + include 'map.inc' +ctm include 'arcblk.inc' + include 'usrdat.inc' + double precision zedge,zmap,rffreq,escale,theta0 + integer nstep,itype,npusr + double precision h(monoms),mh(6,6) + common/rfcdata/zdat(20500),edat(20500),epdat(20500),Nsize +! write(6,*)'(rfgap) ref(6),brho=',reftraj(6),brho +! nonlinear map for rf gap not implemented yet + do 10 i=1,monoms + h(i)=0. + 10 continue +!!!!!!!!!!!!! fix these hardwired values later: +! qmcc=1./938.28e6 +cryne 7/21/02 qmcc=1./939.294308e6 + qmcc=1.d0/pmass +c + xl=sl + xk=1./xl + ww=rffreq/(c/xl) +c write(6,*) "==> ww = ",ww +c g0 is the quadrupole gradient, assumed to be zero +c (combined rfgap+quad will be implemented later if requested) + g0=0. +c + if(zmap.lt.0.)then + write(6,*)'error(rfgap): zmap cannot be < 0 in this version' + endif + tau=zmap +c + engin=gam00*pmass +c ucalc(11)=engin + if(idproc.eq.0)write(36,*)arclen,engin + call myflush(36) + call mapgap(mh,arclen,tau,nstep,qmcc,xk,xl,ww,zedge, & + & escale,theta0,g0,t00,gam00,itype) +! update brho, beta, and gamma: +cryne 5/1/2006 No. don't update here. Moved to routine lmnt in afro.f +! engfin=gam00*pmass +cryne-abell Mon Nov 24 18:39:30 PST 2003 +! ucalc(12)=engfin + return + end + + subroutine mapgap(xm,t,tau,mapstp,qmcc,xk,xl,ww,zedge,escale, & + & theta0,g0,t00,gam00,itype) +! Compute the linear map for an rf gap + quadrupole +! 2 design orbit eqns + 12 matrix coeffs = 14 eqns +! all the following arrays are serial arrays: +cryne== implicit none + include 'impli.inc' +cryne== + dimension xm(6,6), y(14) +ctm integer, intent(in) :: mapstp,itype +ctm double precision, intent(in) :: t,tau,qmcc,xk,xl,ww,zedge, & +ctm & escale,theta0,g0 +ctm double precision, intent(inout) :: t00,gam00 +ctm double precision, dimension(6,6), intent(out) :: xm +ctm double precision, dimension(14) :: y +ctm double precision :: h,t0,gi,betai,ui,squi,sqi3,ein,e1in,e2in, & +ctm & sinthi +ctm double precision :: costhi,uprimi,qpwi,dlti,thli,gf,betaf,uf, & +ctm & squf,sqf3 +ctm double precision :: tfin,ef,e1f,e2f,sinthf,costhf,uprimf,qpwf, & +ctm & dltf,thlf +! xm = 0.0 + do 11 i=1,6 + do 10 j=1,6 + xm(i,j)=0.d0 + 10 continue + 11 continue +c y(1)=mpasyn(5) +c y(2)=mpasyn(6) + y(1)=t00 + y(2)=-gam00 + y(3)=1.d0 + y(4)=0.d0 + y(5)=0.d0 + y(6)=1.d0 + y(7)=1.d0 + y(8)=0.d0 + y(9)=0.d0 + y(10)=1.d0 + y(11)=1.d0 + y(12)=0.d0 + y(13)=0.d0 + y(14)=1.d0 + h=tau/mapstp + t0=t +c gi=-mpasyn(6) + gi=gam00 + betai=sqrt((gi-1.d0)*(gi+1.d0))/gi + ui=gi*betai + squi=sqrt(ui) + sqi3=sqrt(ui)**3 + call eintrp(t,ein,e1in,e2in,zedge,escale,itype,ww,theta0,y) + sinthi=sin(ww*t00+theta0) + costhi=cos(ww*t00+theta0) + uprimi=qmcc*ein/betai*costhi + qpwi=0.5d0*qmcc*xl/(ui*ww) + dlti=xl*(0.5d0*uprimi/ui-qpwi*e1in*sinthi) + thli=1.5d0*xl*(uprimi/ui) +! call rk6i(h,mapstp,t0,y,qmcc,xk,xl,ww,zedge,escale,g0, & +! & theta0,itype) + call adam11rf(h,mapstp,t0,y,qmcc,xk,xl,ww,zedge,escale,g0, & + & theta0,itype) +c mpasyn(5)=y(1) +c mpasyn(6)=y(2) +c gf=-mpasyn(6) + t00=y(1) + gam00=-y(2) + gf=gam00 + betaf=sqrt((gf-1.d0)*(gf+1.d0))/gf + uf=gf*betaf + squf=sqrt(uf) + sqf3=sqrt(uf)**3 + tfin=t+tau + call eintrp(tfin,ef,e1f,e2f,zedge,escale,itype,ww,theta0,y) + sinthf=sin(ww*t00+theta0) + costhf=cos(ww*t00+theta0) + uprimf=qmcc*ef/betaf*costhf + qpwf=0.5d0*qmcc*xl/(uf*ww) + dltf=xl*(0.5d0*uprimf/uf-qpwf*e1f*sinthf) + thlf=1.5d0*xl*(uprimf/uf) + xm(1,1)= y(3)*squi/squf+y(5)*squi/squf*dlti + xm(2,1)=(y(4)-y(3)*dltf)*squi*squf+(y(6)-y(5)*dltf)*squi*squf* & + & dlti + xm(1,2)= y(5)/(squi*squf) + xm(2,2)=(y(6)-y(5)*dltf)*squf/squi + xm(3,3)= y(7)*squi/squf+y(9)*squi/squf*dlti + xm(4,3)= & + & (y(8)-y(7)*dltf)*squi*squf+(y(10)-y(9)*dltf)*squi*squf*dlti + xm(3,4)= y(9)/(squi*squf) + xm(4,4)=(y(10)-y(9)*dltf)*squf/squi + xm(5,5)= y(11)*sqi3/sqf3+y(13)*sqi3/sqf3*thli + xm(6,5)= & + & (y(12)-y(11)*thlf)*sqi3*sqf3+(y(14)-y(13)*thlf)*sqi3*sqf3*thli + xm(5,6)= y(13)/(sqi3*sqf3) + xm(6,6)=(y(14)-y(13)*thlf)*sqf3/sqi3 + + end !subroutine mapgap +! + subroutine eintrp(z,ez1,ezp1,ezpp1,zedge,escale,itype,ww,theta0,y) + use parallel + use beamdata, only : pmass + include 'impli.inc' + include 'fitbuf.inc' + dimension y(14) + common/rfcdata/zdat(20500),edat(20500),epdat(20500),Nsize +! if(itype.eq.0 .or. itype.eq.1)then +! ez1=0. +! ezp1=0. +! ezpp1=0. +! goto 1000 +! endif + zz=z-zedge + checklo=zz-zdat(1) + checkhi=zdat(Nsize)-zz + eps=1.d-10 + if(checklo.lt.0.d0)then + if(abs(checklo).lt.eps)then + zz=zdat(1) + else + if(idproc.eq.0)then + write(6,*)'interpolation error in routine eintrp' + write(6,*)'zz,zdat(1)=',zz,zdat(1) + endif + call myexit + endif + endif + if(checkhi.lt.0.d0)then + if(abs(checkhi).lt.eps)then + zz=zdat(Nsize) + else + if(idproc.eq.0)then + write(6,*)'interpolation error in routine eintrp' + write(6,*)'zz,zdat(Nsize)=',zz,zdat(Nsize) + endif + call myexit + endif + endif +!============================ + klo=1 + khi=Nsize + 1 if (khi-klo.gt.1)then + k=(khi+klo)/2 + if(zdat(k).gt.zz)then + khi=k + else + klo=k + endif + goto 1 + endif + h=zdat(khi)-zdat(klo) + if(h.eq.0.)then + write(6,*)'bad data in routine eintrp' + call myexit + endif +!============================ +!start linear interpolation. + slope1=(edat(khi)-edat(klo))/h + ez1 =edat(klo)+slope1*(zz-zdat(klo)) + slope2=(epdat(khi)-epdat(klo))/h + ezp1=epdat(klo)+slope2*(zz-zdat(klo)) + ez1=ez1*escale + ezp1=ezp1*escale + ezpp1=0. +cryne +cryne if(idproc.eq.0) then +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c modification to only write when fitting has converged: + 1000 continue +cryne 5/9/2006 write(42,*) z,ez1,ezp1,klo,khi,min(zz-zdat(klo),zdat(khi)-zz) +c if(kfit.eq.1 .and. idproc.eq.0)then + if(idproc.eq.0)then +cccc write(49,101)z,zz,y(1),(-y(2)-1.)*pmass,ez1,ezp1,1.0*m +cccc call myflush(49) + m=klo +c if(m.eq.435 .or. m.eq.920)then + if( m.gt.1 .and. m.lt.Nsize)then +c if( (edat(m-1).lt.edat(m)).and.(edat(m+1).lt.edat(m)) )then + if( ((edat(m-1).lt.edat(m)).and.(edat(m+1).lt.edat(m))).or. & + & ((edat(m-1).gt.edat(m)).and.(edat(m+1).gt.edat(m))) )then + twopi=4.*asin(1.0d0) + phasprnt=360./twopi*mod(ww*y(1)+theta0,twopi) + if(phasprnt.lt.10.)phasprnt=phasprnt+360. + prxrad=360./twopi*(ww*y(1)+theta0) + preng=(-y(2)-1.)*939.294308 + write(59,101)z,1.0*m,phasprnt,prxrad,theta0*360./twopi,preng + call myflush(59) + endif + endif + endif +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc +cryne endif + 101 format(7(1x,1pe12.5)) + return + end !subroutine eintrp + + double precision function func1(x,pi52) +cryne== implicit none + include 'impli.inc' +cryne== +ctm double precision, intent(in) :: x, pi52 + + func1 = exp(-(4.*x)**4)*cos(pi52*tanh(5.*x)) + + end !function func1 +c************************************************************ + double precision function func2(x,pi52) +cryne== implicit none + include 'impli.inc' +cryne== +ctm double precision, intent(in) :: x, pi52 + + func2=-5.*pi52*exp(-(4.*x)**4)*sin(pi52*tanh(5.*x))/ & + & cosh(5.*x)**2-16.*(4.*x)**3*exp(-(4.*x)**4)*cos(pi52*tanh(5.*x)) + + end !function func2 + +c*********************************************** + subroutine rk6i(h,ns,t,y,qmcc,xk,xl,ww,zedge,escale,g0, & + & theta0,itype) +cryne== implicit none + include 'impli.inc' +cryne== +ctm integer, intent(in) :: ns,itype +ctm double precision, intent(in) :: qmcc,xk,xl,ww,zedge,escale, & +ctm & g0,theta0 +ctm double precision, intent(inout) :: t +ctm double precision, intent(in) :: h +ctm double precision, dimension(14), intent(inout) :: y +ctm double precision, dimension(14) :: yt,a,b,c,d,e,f,g,o,p +ctm double precision:: tint,tt,blg +ctm integer :: i + dimension y(14),yt(14),a(14),b(14),c(14),d(14),e(14),f(14), & + & g(14),o(14),p(14) + blg=0. + tint=t + do i=1,ns + call evalrf(t,y,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 10 j=1,14 + a(j)=h*f(j) + yt(j)=y(j)+a(j)/9.d0 + 10 continue + tt=t+h/9.d0 + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 20 j=1,14 + b(j)=h*f(j) + yt(j)=y(j) + (a(j) + 3.d0*b(j))/24.d0 + 20 continue + tt=t+h/6.d0 + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 30 j=1,14 + c(j)=h*f(j) + yt(j)=y(j)+(a(j)-3.d0*b(j)+4.d0*c(j))/6.d0 + 30 continue + tt=t+h/3.d0 + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 40 j=1,14 + d(j)=h*f(j) + yt(j)=y(j) + & + &(278.d0*a(j) - 945.d0*b(j) + 840.d0*c(j) + 99.d0*d(j))/544.d0 + 40 continue + tt=t+.5d0*h + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 50 j=1,14 + e(j)=h*f(j) + yt(j)=y(j) + & + &(-106.d0*a(j)+273.d0*b(j)-104.d0*c(j)-107.d0*d(j)+48.d0*e(j))/6.d0 + 50 continue + tt = t+2.d0*h/3.d0 + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 60 j=1,14 + g(j)=h*f(j) + yt(j) = y(j)+(110974.d0*a(j)-236799.d0*b(j)+68376.d0*c(j)+ & + & 103803.d0*d(j)-10240.d0*e(j) + 1926.d0*g(j))/45648.d0 + 60 continue + tt = t + 5.d0*h/6.d0 + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 70 j=1,14 + o(j)=h*f(j) + yt(j) = y(j)+(-101195.d0*a(j)+222534.d0*b(j)-71988.d0*c(j)- & + & 26109.d0*d(j)-2.d4*e(j)-72.d0*g(j)+22824.d0*o(j))/25994.d0 + 70 continue + tt = t + h + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 80 j=1,14 + p(j)=h*f(j) + y(j) = y(j)+(41.d0*a(j)+216.d0*c(j)+27.d0*d(j)+ & + & 272.d0*e(j)+27.d0*g(j)+216.d0*o(j)+41.d0*p(j))/840.d0 + 80 continue + t=tint+i*h +crynedabell +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2) +cryne 5/9/2006 call myflush(41) +crynedabell +! write(20,101)t,y(1),(-y(2)-1.0)*938.28 +cryne write(20,101)t,y(1),(-y(2)-1.0)*939.294308 + 101 format(3(1pe12.5,1x)) +cryne write(21,102)t,y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11), & +cryne& y(12) + 102 format(11(1pe12.5,1x)) + enddo + end !subroutine rk6i +c******************************************************************** + subroutine evalrf(t,y,f,qmcc,xk,xl,ww,zedge,blg,escale,g0, & + & theta0,itype) + use beamdata, only : pmass +cryne== implicit none + include 'impli.inc' +cryne== +ctm integer, intent(in) :: itype +ctm double precision, intent(in) :: t,qmcc,xk,xl,ww,zedge,blg, & +ctm & escale,g0,theta0 +ctm double precision, dimension(14), intent(in) :: y +ctm double precision, dimension(14), intent(out) :: f +ctm double precision :: clite,ez1,ezp1,ezpp1,gamma0,beta0, & +ctm & gbet,sinphi,cosphi +ctm double precision :: rfdsgn,pmass,brho,s11tmp,s11,s33,s55 +cryne 7/21/02 +c + dimension f(14), y(14) + clite=299792458.d0 + call eintrp(t,ez1,ezp1,ezpp1,zedge,escale,itype,ww,theta0,y) +! synchronous particle: + gamma0=-y(2) + beta0=sqrt((gamma0-1.d0)*(gamma0+1.d0))/gamma0 + gbet=beta0*gamma0 + sinphi=sin(ww*y(1)+theta0) + cosphi=cos(ww*y(1)+theta0) + rfdsgn=ez1*cosphi + f(1)=xk/beta0 + f(2)=-qmcc*rfdsgn +cryneabell:09.Nov.05 +cryne 5/9/2006 write(44,*) t,ww*y(1)+theta0,ez1,ezp1 +cryneabell---------- +! matrix elements +! pmass=938.28d6 +! mistaken comment was here previously; now set to H- mass Sept 5, 2000 +! pmass=939.294308d6 +!!!************************************************************************ +!!!cryne 11/06/2003 eventually this should be fixed to use pmass in common** +! pmass=938.27231d6 +!!!************************************************************************ +!!!************************************************************************ +! put a negative sign here for H-. +! brho=-gbet/clite*pmass + brho=gbet/clite*pmass + s11tmp=0.5d0*(1.d0+0.5d0*gamma0**2)* & + & (qmcc*rfdsgn/beta0**2/gamma0**2)**2 + & + & qmcc*xk*ww*0.5d0/beta0**3/gamma0**3*ez1*sinphi +! qmcc*xk*0.5d0/beta0**3/gamma0**3*ez1*sinphi + s11=(s11tmp+g0/brho)*xl + s33=(s11tmp-g0/brho)*xl + s55= & + & -1.5d0*qmcc/beta0**2/gamma0*ezp1*cosphi & + & +(beta0**2+0.5d0)/beta0**3/gamma0*qmcc*xk*ww*ez1*sinphi & + & +1.5d0*(1.d0-0.5d0*gamma0**2)* & + & (qmcc*rfdsgn/beta0**2/gamma0**2)**2 +! +(beta0**2+0.5d0)/beta0**3/gamma0*qmcc*xk*ez1*sinphi + s55=xl*s55 + f(3)=y(4)/xl + f(4)=-s11*y(3) + f(5)=y(6)/xl + f(6)=-s11*y(5) + f(7)=y(8)/xl + f(8)=-s33*y(7) + f(9)=y(10)/xl + f(10)=-s33*y(9) + f(11)=y(12)/xl + f(12)=-s55*y(11) + f(13)=y(14)/xl + f(14)=-s55*y(13) +cryneabell---9.Nov.05 +cryne 5/9/2006 write(43,*) t,f(1)*ww,f(2)/ww,f(1:2),f(7:14) +cryneabell + end !subroutine evalrf + +c========================================================== + subroutine read_RFdata(nunit,numdata,zlen) + use parallel + include 'impli.inc' + common/rfcdata/zdat(20500),edat(20500),epdat(20500),Nsize + if(idproc.eq.0)then + numdata=0 + do i = 1, 999999 + read(nunit,*,end=999)zdat(i),edat(i),epdat(i) + numdata=numdata+1 + enddo + 999 continue +cryne note: this sets the left hand edge to zero: + zdat1=zdat(1) + do i=1,numdata + zdat(i)=zdat(i)-zdat1 + enddo +c if(idproc.eq.0)then +c write(6,*)'Done reading RF data. Closing file unit ',nunit +c endif + close(nunit) + endif + call MPI_BCAST(numdata,1,mntgr,0,lworld,ierr) + call MPI_BCAST(zdat,numdata,mreal,0,lworld,ierr) + call MPI_BCAST(edat,numdata,mreal,0,lworld,ierr) + call MPI_BCAST(epdat,numdata,mreal,0,lworld,ierr) + Nsize = numdata + zlen=zdat(numdata)-zdat(1) + return + end +************************************************************************ +c +! subroutine adam11rf(h,ns,nf,t,y,ne) + subroutine adam11rf(h,ns,t,y,qmcc,xk,xl,ww,zedge,escale,g0, & + & theta0,itype) +c Written by Rob Ryne, Spring 1986, based on a routine of Alex Dragt +c This integration routine makes local truncation errors at each +c step of order h**11. That is, it is locally correct through +c order h**10. Due to round off errors, its true precision is +c realized only when more than 64 bits are used. + use lieaparam, only : monoms + use beamdata + use phys_consts + include 'impli.inc' +c character*6 nf +cryneneriwalstrom fix later to use monoms instead of hardwire: + dimension y( 14),yp( 14),yc( 14),f1( 14),f2( 14),f3( 14),f4( 14), + & f5( 14),f6( 14),f7( 14),f8( 14),f9( 14),f10( 14),f11( 14) + dimension a(10),am(10),b(10),bm(10) +c + data (a(i),i=1,10)/57281.d0,-583435.d0,2687864.d0, + & -7394032.d0,13510082.d0,-17283646.d0,16002320.d0, + & -11271304.d0,9449717.d0,2082753.d0/ + data (b(i),i=1,10)/-2082753.d0,20884811.d0,-94307320.d0, + & 252618224.d0,-444772162.d0,538363838.d0,-454661776.d0, + & 265932680.d0,-104995189.d0,30277247.d0/ +cryne 7/23/2002 + save a,b +c +cryneabell 11/8/2005 + ne=14 +c nf='start' +cryneabell 11/8/2005 +c +cryne 1 August 2004 ne=monoms+15 +c + nsa=ns +c if (nf.eq.'cont') go to 20 +c rk start + iqt=5 + qt=float(iqt) + hqt=h/qt +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light +cryne 5/9/2006 call myflush(41) + call evalrf(t,y,f1,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) + call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & + & theta0,itype) +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light +cryne 5/9/2006 call myflush(41) + call evalrf(t,y,f2,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) + call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & + & theta0,itype) +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light +cryne 5/9/2006 call myflush(41) + call evalrf(t,y,f3,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) + call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & + & theta0,itype) +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light +cryne 5/9/2006 call myflush(41) + call evalrf(t,y,f4,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) + call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & + & theta0,itype) +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light +cryne 5/9/2006 call myflush(41) + call evalrf(t,y,f5,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) + call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & + & theta0,itype) +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light +cryne 5/9/2006 call myflush(41) + call evalrf(t,y,f6,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) + call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & + & theta0,itype) +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light +cryne 5/9/2006 call myflush(41) + call evalrf(t,y,f7,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) + call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & + & theta0,itype) +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light +cryne 5/9/2006 call myflush(41) + call evalrf(t,y,f8,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) + call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & + & theta0,itype) +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light +cryne 5/9/2006 call myflush(41) + call evalrf(t,y,f9,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) + call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & + & theta0,itype) +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light +cryne 5/9/2006 call myflush(41) + call evalrf(t,y,f10,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + nsa=ns-9 + hdiv=h/7257600.0d+00 + do 10 i=1,10 + am(i)=hdiv*a(i) + 10 bm(i)=hdiv*b(i) + 20 tint=t + do 100 i=1,nsa + do 30 j=1,ne + yp(j)=y(j)+bm(1)*f1(j)+bm(2)*f2(j)+bm(3)*f3(j) & + &+bm(4)*f4(j)+bm(5)*f5(j)+bm(6)*f6(j)+bm(7)*f7(j) & + & +bm(8)*f8(j)+bm(9)*f9(j)+bm(10)*f10(j) + 30 continue + call evalrf(t+h,yp,f11,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 40 j=1,ne + yp(j)=y(j)+am(1)*f2(j)+am(2)*f3(j)+am(3)*f4(j)+am(4)*f5(j) & + & +am(5)*f6(j)+am(6)*f7(j)+am(7)*f8(j)+am(8)*f9(j)+am(9)*f10(j) + 40 yc(j)=yp(j)+am(10)*f11(j) + 41 call evalrf(t+h,yc,f11,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 50 j=1,ne + 50 y(j)=yp(j)+am(10)*f11(j) + do 60 j=1,ne + f1(j)=f2(j) + f2(j)=f3(j) + f3(j)=f4(j) + f4(j)=f5(j) + f5(j)=f6(j) + f6(j)=f7(j) + f7(j)=f8(j) + f8(j)=f9(j) + f9(j)=f10(j) + 60 f10(j)=f11(j) + t=tint+i*h +cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light +cryne 5/9/2006 call myflush(41) + 100 continue + return + end +c +*********************************************************************** +c +c subroutine rk78iirf(h,ns,t,y,ne) + subroutine rk78iirf(h,ns,t,y,qmcc,xk,xl,ww,zedge,blg,escale, & + & g0,theta0,itype) +c Written by Rob Ryne, Spring 1986, based on a routine of +c J. Milutinovic. +c For a reference, see page 76 of F. Ceschino and J Kuntzmann, +c Numerical Solution of Initial Value Problems, Prentice Hall 1966. +c This integration routine makes local truncation errors at each +c step of order h**7. +c That is, it is locally correct through terms of order h**6. +c Each step requires 8 function evaluations. + + use lieaparam, only : monoms + include 'impli.inc' +cryneneriwalstrom fix later to use monoms instead of hardwire: + dimension y( 14),yt( 14),f( 14),a( 14),b( 14),c( 14),d( 14), & + &e( 14),g( 14),o( 14),p( 14) +cryne 1 August 2004 ne=monoms+15 +c + ne=14 +c + tint=t + do 200 i=1,ns + call evalrf(t,y,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 10 j=1,ne + 10 a(j)=h*f(j) + do 20 j=1,ne + 20 yt(j)=y(j)+a(j)/9.d+0 + tt=t+h/9.d+0 + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 30 j=1,ne + 30 b(j)=h*f(j) + do 40 j=1,ne + 40 yt(j)=y(j) + (a(j) + 3.d+0*b(j))/24.d+0 + tt=t+h/6.d+0 + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 50 j=1,ne + 50 c(j)=h*f(j) + do 60 j=1,ne + 60 yt(j)=y(j)+(a(j)-3.d+0*b(j)+4.d+0*c(j))/6.d+0 + tt=t+h/3.d+0 + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 70 j=1,ne + 70 d(j)=h*f(j) + do 80 j=1,ne + 80 yt(j)=y(j) + (-5.d+0*a(j) + 27.d+0*b(j) - + & 24.d+0*c(j) + 6.d+0*d(j))/8.d+0 + tt=t+.5d+0*h + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 90 j=1,ne + 90 e(j)=h*f(j) + do 100 j=1,ne + 100 yt(j)=y(j) + (221.d+0*a(j) - 981.d+0*b(j) + + & 867.d+0*c(j)- 102.d+0*d(j) + e(j))/9.d+0 + tt = t+2.d+0*h/3.d+0 + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 110 j=1,ne + 110 g(j)=h*f(j) + do 120 j=1,ne + 120 yt(j) = y(j)+(-183.d+0*a(j)+678.d+0*b(j)-472.d+0*c(j)- + & 66.d+0*d(j)+80.d+0*e(j) + 3.d+0*g(j))/48.d+0 + tt = t + 5.d+0*h/6.d+0 + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 130 j=1,ne + 130 o(j)=h*f(j) + do 140 j=1,ne + 140 yt(j) = y(j)+(716.d+0*a(j)-2079.d+0*b(j)+1002.d+0*c(j)+ + & 834.d+0*d(j)-454.d+0*e(j)-9.d+0*g(j)+72.d+0*o(j))/82.d+0 + tt = t + h + call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & + & itype) + do 150 j=1,ne + 150 p(j)=h*f(j) + do 160 j=1,ne + 160 y(j) = y(j)+(41.d+0*a(j)+216.d+0*c(j)+27.d+0*d(j)+ + & 272.d+0*e(j)+27.d+0*g(j)+216.d+0*o(j)+41.d+0*p(j))/840.d+0 + t=tint+i*h + 200 continue + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine multirfsetup(imap5,jmap6) + use multitrack + include 'impli.inc' + include 'map.inc' ! this contains the reftraj array (need 5 and 6) + integer imap5,jmap6 + real*8 hx,hy,hxi,hyi + integer nx,ny,i,j,n,ierror + integer imin,imax,jmin,jmax + real*8, dimension(4) :: diag,rdiag +! +! if arrays exist, make sure they have the correct size + if( allocated(tlistin) .and. & + & ((imap5.ne.imaps) .or. (jmap6.ne.jmaps)) )then + if(idproc.eq.0)write(6,*)'(rfsetup) deallocating multiarrays...' + call del_multiarrays + imaps=imap5 + jmaps=jmap6 + if(idproc.eq.0)write(6,*)'(rfsetup) ...allocating multiarrays' + call new_multiarrays + endif +! if arrays do not exist, create them: + if( .not.allocated(tlistin) )then + imaps=imap5 + jmaps=jmap6 + if(idproc.eq.0)write(6,*)'(rfsetup) allocating multiarrays' + call new_multiarrays + endif +! +! save the reference t,pt (these are changed by rfgap, so need to store them) + refentry5=reftraj(5) + refentry6=reftraj(6) +! +! Set up grid of initial t-pt values: +! Note: In theory the 5th variable should be periodic. But in most cases it +! will not fill the full 2pi. And it is not worth the hassle to deal with the +! special case that it does fill the full 2pi. So don't bother with periodic: +! +! pack the values into an array of length 4 to minimize MPI calls: + diag(1)= maxval(zblock(5,1:nraysp)) !tmax + diag(2)= maxval(zblock(6,1:nraysp)) !ptmax + diag(3)=-minval(zblock(5,1:nraysp)) !tmin + diag(4)=-minval(zblock(6,1:nraysp)) !ptmin + call MPI_ALLREDUCE(diag,rdiag,4,mreal,mpimax,lworld,ierror) + xmax= rdiag(1) + ymax =rdiag(2) + xmin=-rdiag(3) + ymin=-rdiag(4) +! +! nx, ny are just local variables (could use imaps and jmaps instead) + nx=imaps + ny=jmaps +! Note that, in the following, tlist and ptlist are *not* deviation variables, +! as can be seen from the addition of refentry5 and refentry6 in the formulas. +! The reason is that the non-deviation variables must be passed to rfgap. +! +! Compute the tlistin grid points and array inear: + if( (xmin.eq.xmax).and.(nx.gt.1) )then + if(idproc.eq.0) & + & write(6,*)'warning: phase spread is zero and imaps.ne.1' + tlistin(1:imaps)=xmin+refentry5 + inear(1:nraysp)=1 + elseif( (xmin.ne.xmax).and.(nx.gt.1) )then + hx=(xmax-xmin)/(nx-1) + hxi=1./hx + do i=1,nx + tlistin(i)=xmin+(i-1)*hx+refentry5 + enddo + do n=1,nraysp + inear(n)=nint((zblock(5,n)-xmin)*hxi)+1 !nearest grid point + enddo + else +! tlistin(1)=0.5d0*(xmin+xmax)+refentry5 + tlistin(1)=refentry5 + inear(1:nraysp)=1 + endif +! Compute the ptlistin grid points and array jnear: + if( (ymin.eq.ymax).and.(ny.gt.1) )then + if(idproc.eq.0) & + & write(6,*)'warning: energy spread is zero and jmaps.ne.1' + ptlistin(1:jmaps)=ymin+refentry6 + jnear(1:nraysp)=1 + elseif( (ymin.ne.ymax).and.(ny.gt.1) )then + hy=(ymax-ymin)/(ny-1) + hyi=1./hy + do j=1,ny + ptlistin(j)=ymin+(j-1)*hy+refentry6 + enddo + do n=1,nraysp + jnear(n)=nint((zblock(6,n)-ymin)*hyi)+1 !nearest grid point + enddo + else +! ptlistin(1)=0.5d0*(ymin+ymax)+refentry6 + ptlistin(1)=refentry6 + jnear(1:nraysp)=1 + endif +! +! compute tdelt, ptdelt arrays: + do n=1,nraysp + tdelt(n)= zblock(5,n)+refentry5- tlistin(inear(n)) + ptdelt(n)=zblock(6,n)+refentry6-ptlistin(jnear(n)) + enddo +! +! In the future, use rho56 to determine whether or not to compute a map: + rho56=0.d0 + do n=1,nraysp + rho56(inear(n),jnear(n))=rho56(inear(n),jnear(n))+1.d0 + enddo +!----- +! just for checking/debugging +! imin=minval(inear) +! imax=maxval(inear) +! jmin=minval(jnear) +! jmax=maxval(jnear) +! if(idproc.eq.0)write(6,*)'imin,imax=',imin,imax +! if(idproc.eq.0)write(6,*)'jmin,jmax=',jmin,jmax +!----- + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/setbound.f b/OpticsJan2020/MLI_light_optics/Src/setbound.f new file mode 100644 index 0000000..2845203 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/setbound.f @@ -0,0 +1,229 @@ + subroutine setbound(c6,msk,np,gblam,gamma,nx0,ny0,nz0,noresize, & + & nadj0) + use rays + use parallel + include 'impli.inc' + real*8 hmax + logical msk + dimension c6(6,np),msk(np) +!hpf$ distribute (*,block) :: c6 +!hpf$ align (:) with c6(*,:) :: msk + real*8 Xmin,Xmax,Ymin,Ymax,Zmin,Zmax,Hx,Hy,Hz,Hxi,Hyi,Hzi + common/GRIDSZ3D/Xmin,Xmax,Ymin,Ymax,Zmin,Zmax,Hx,Hy,Hz,Hxi,Hyi,Hzi + common/gxyzsave/xmin0,xmax0,ymin0,ymax0,zmin0,zmax0,kfixbdy,madegr + integer IDirectFieldCalc,IDensityFunction,ISolve + & ,AnagPatchSize,AnagRefRatio + common/NEWPOISSON/IDirectFieldCalc,IDensityFunction,ISolve + & ,AnagPatchSize,AnagRefRatio + integer IVerbose + common/SHOWME/IVerbose + n0min=16 + n0max=1024 + 37 continue +c if(idproc.eq.0)then +c write(6,*)'inside setbound; gamma=',gamma +c endif + call boundp3d(c6,msk,np,gblam,nx0,ny0,nz0,nadj0) +c if(idproc.eq.0)then +c write(6,*)'returned from boundp3d' +c write(6,*)'xmin,xmax=',xmin,xmax +c write(6,*)'ymin,ymax=',ymin,ymax +c write(6,*)'zmin,zmax=',zmin,zmax +c endif + +! special case for ANAG Infinite Domain Poisson solver which requires +! uniform grid spacing, only applicable in variable grid case + if( kfixbdy .NE. 1 .AND. ISolve/10 .EQ. 1 )then + ! set all h's to max and adjust the physical domain boundaries + ! without moving the center of the domain + hmax = MAX( hx,hy,hz ) + if( IVerbose .GT. 4 .AND. IdProc .EQ. 0 .AND. + & (hmax.NE.hx .OR. hmax.NE.hy .OR. hmax.NE.hz) )then + write(6,*) 'info: SETBOUND: enforcing isotropic grid spacing ' + & ,'for ANAG Poisson solver; old h[xyz] = ',hx,hy,hz + & ,', new h = ',hmax + endif + if( hx .LT. hmax )then + ! new_xmin is center minus 1/2 new X domain length + hx = hmax + xmin0 = 0.5 * ( xmax0 + xmin0 ) - 0.5 * ( hmax * (nx0-1) ) + xmax0 = xmin0 + ( hmax * (nx0-1) ) + endif + if( hy .LT. hmax )then + hy = hmax + ymin0 = 0.5 * ( ymax0 + ymin0 ) - 0.5 * ( hmax * (ny0-1) ) + ymax0 = ymin0 + ( hmax * (ny0-1) ) + endif + if( hz .LT. hmax )then + hz = hmax + zmin0 = 0.5 * ( zmax0 + zmin0 ) - 0.5 * ( hmax * (nz0-1) ) + zmax0 = zmin0 + ( hmax * (nz0-1) ) + endif + hxi = 1.0d0 / hx + hyi = 1.0d0 / hy + hzi = 1.0d0 / hz + endif + +c=================================================================== +c 12/4/2002 new code to allow for fixed grid size: + if(kfixbdy.eq.1)then +cryne 11/27/03 if(idproc.eq.0)write(6,*)'kfixbdy.eq.1' + if(xmin0.lt.xmin)then + xmin=xmin0 + else + if(idproc.eq.0)then + write(6,*)'ERROR: particle range falls outside xmin; halting.' + write(6,*)'xmin0,xmin=',xmin0,xmin + endif + call myexit + endif + if(xmax0.gt.xmax)then + xmax=xmax0 + else + if(idproc.eq.0)then + write(6,*)'ERROR: particle range falls outside xmax; halting.' + write(6,*)'xmax0,xmax=',xmax0,xmax + endif + call myexit + endif + if(ymin0.lt.ymin)then + ymin=ymin0 + else + if(idproc.eq.0)then + write(6,*)'ERROR: particle range falls outside ymin; halting.' + write(6,*)'ymin0,ymin=',ymin0,ymin + endif + call myexit + endif + if(ymax0.gt.ymax)then + ymax=ymax0 + else + if(idproc.eq.0)then + write(6,*)'ERROR: particle range falls outside ymax; halting.' + write(6,*)'ymax0,ymax=',ymax0,ymax + endif + call myexit + endif + hx=(xmax-xmin)/(nx0-1) + hy=(ymax-ymin)/(ny0-1) + hxi=1./hx + hyi=1./hy + endif + if(kfixbdy.eq.1 .and. nadj0.eq.0)then +! if(idproc.eq.0)write(6,*)'kfixbdy.eq.1 .and. nadj0.eq.0' +cryne 11/27/03 from now on, zmin is the grid size IN THE BUNCH FRAME, +cryne WHERE THE POISSON EQUATION IS ACTUALLY SOLVED +cryne if(gamma*zmin0.lt.zmin)then +cryne zmin=gamma*zmin0 + if(zmin0.lt.zmin)then + zmin=zmin0 + else + if(idproc.eq.0)then + write(6,*)'ERROR: particle range falls outside zmin; halting.' +cryne write(6,*)'zmin0,zmin=',gamma*zmin0,zmin + write(6,*)'zmin0,zmin=',zmin0,zmin + endif + call myexit + endif +cryne if(gamma*zmax0.gt.zmax)then +cryne zmax=gamma*zmax0 + if(zmax0.gt.zmax)then + zmax=zmax0 + else + if(idproc.eq.0)then + write(6,*)'ERROR: particle range falls outside zmax; halting.' +cryne write(6,*)'zmax0,zmax=',gamma*zmax0,zmax + write(6,*)'zmax0,zmax=',zmax0,zmax + endif + call myexit + endif + hz=(zmax-zmin)/(nz0-1) + hzi=1./hz + endif +!=================================================================== +! check grid sizes: +! aspect is the max allowed ratio between any *two* grid sizes + aspect=1.9 + aspinv=1./aspect + ierrx=0 + ierry=0 + ierrz=0 + if(hx.lt.hy .and. hx.lt.hz)then + if(hx.lt.aspinv*min(hy,hz))ierrx=1 + else if(hy.lt.hx .and. hy.lt.hz)then + if(hy.lt.aspinv*min(hx,hz))ierry=1 + else if(hz.lt.hx .and. hz.lt.hy)then + if(hz.lt.aspinv*min(hx,hy))ierrz=1 + endif + if(ierrx.eq.1 .and. idproc.eq.0)write(12,1111)hx,hy,hz + if(ierry.eq.1 .and. idproc.eq.0)write(12,1112)hx,hy,hz + if(ierrz.eq.1 .and. idproc.eq.0)write(12,1113)hx,hy,hz + 1111 format('(aspect ratio)should increase hx; hx,hy,hz=',3(1pe9.3,1x)) + 1112 format('(aspect ratio)should increase hy; hx,hy,hz=',3(1pe9.3,1x)) + 1113 format('(aspect ratio)should increase hz; hx,hy,hz=',3(1pe9.3,1x)) + if(hx.gt.hy .and. hx.gt.hz)then + if(hx.gt.aspect*max(hy,hz))ierrx=-1 + else if(hy.gt.hx .and. hy.gt.hz)then + if(hy.gt.aspect*max(hx,hz))ierry=-1 + else if(hz.gt.hx .and. hz.gt.hy)then + if(hz.gt.aspect*max(hx,hy))ierrz=-1 + endif + if(ierrx.eq.-1 .and. idproc.eq.0)write(12,1114)hx,hy,hz + if(ierry.eq.-1 .and. idproc.eq.0)write(12,1115)hx,hy,hz + if(ierrz.eq.-1 .and. idproc.eq.0)write(12,1116)hx,hy,hz + 1114 format('(aspect ratio)should decrease hx; hx,hy,hz=',3(1pe9.3,1x)) + 1115 format('(aspect ratio)should decrease hy; hx,hy,hz=',3(1pe9.3,1x)) + 1116 format('(aspect ratio)should decrease hz; hx,hy,hz=',3(1pe9.3,1x)) +c flush file 12 just in case the code crashes or runs out of time: + call myflush(12) +c=================================================================== +c if(ierrx.ne.0 .or. ierry.ne.0 .or. ierrz.ne.0) +c #write(6,*)'warning from setbound: ierr (x,y,z)=',ierrx,ierry,ierrz + if(noresize.eq.1 .or. kfixbdy.eq.1)goto 38 +c resize the grid if needed: + if((ierrx.eq.1 .or. ierry.eq.1 .or. ierrz.eq.1) .and. + & (nx0.le.n0min .or. ny0.le.n0min .or. nz0.le.n0min))then + write(6,*)'cannot decrease grid size; doubling all sizes' + nx0=2*nx0 + ny0=2*ny0 + nz0=2*nz0 + goto 37 + endif + if(ierrx.eq.1)then + nx0=nx0/2 + if(idproc.eq.0)write(6,*)'#DECREASING NX0 to ',nx0 + else if(ierry.eq.1)then + ny0=ny0/2 + if(idproc.eq.0)write(6,*)'#DECREASING NY0 to ',ny0 + else if(ierrz.eq.1)then + nz0=nz0/2 + if(idproc.eq.0)write(6,*)'#DECREASING NZ0 to ',nz0 + endif + if((ierrx.eq.-1 .or. ierry.eq.-1 .or. ierrz.eq.-1) .and. + & (nx0.ge.n0max .or. ny0.ge.n0max .or. nz0.ge.n0max))then + write(6,*)'cannot increase grid size; stopping.' + stop + endif + if(ierrx.eq.-1)then + nx0=2*nx0 + if(idproc.eq.0)write(6,*)'#INCREASING NX0 to ',nx0 + else if(ierry.eq.-1)then + ny0=2*ny0 + if(idproc.eq.0)write(6,*)'#INCREASING NY0 to ',ny0 + else if(ierrz.eq.-1)then + nz0=2*nz0 + if(idproc.eq.0)write(6,*)'#INCREASING NZ0 to ',nz0 + endif + if(abs(ierrx)+abs(ierry)+abs(ierrz).ne.0)then + write(6,'(3i5,9x,3i5)')nx0,ny0,nz0 + goto 37 + endif + 38 continue +c========== + if(idproc.eq.0.and.iverbose.ge.5)then + write(6,*)'setbound: [xyz]min=',xmin,ymin,zmin + & ,' [xyz]max=',xmax,ymax,zmax, ' h[xyz]=' + & ,hx,hy,hz + endif + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/sfft3d_dummy.f b/OpticsJan2020/MLI_light_optics/Src/sfft3d_dummy.f new file mode 100644 index 0000000..bec4ade --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/sfft3d_dummy.f @@ -0,0 +1,13 @@ +! -*- Mode: Fortran; Modified: "Mon 17 Nov 2003 11:36:42 by dbs"; -*- + +! non-operative version of sfft3d() routine for building MLI without FFTW or ESSL + + subroutine sfft3d( f,N ) + implicit none +!Arguments + integer N + real*8 f(0:N,0:N,0:N) + write(6,*) 'error: sfft3d: not implemented. ' + & ,'Requires FFTW or ESSL.' + stop 'NOSFFT3D' + end diff --git a/OpticsJan2020/MLI_light_optics/Src/sfft3d_essl.f b/OpticsJan2020/MLI_light_optics/Src/sfft3d_essl.f new file mode 100644 index 0000000..942e3d5 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/sfft3d_essl.f @@ -0,0 +1,119 @@ +! -*- Mode: Fortran; Modified: "Fri 14 Nov 2003 17:34:29 by dbs"; -*- + +! Computes 3D sine transform on a cubic grid using FFT from IBM ESSL + + subroutine sfft3d(f,N) + implicit none +!Arguments + integer N + real*8 f(0:N,0:N,0:N) +!Locals + integer i,j,k,ll ,naux1,naux2 + real*8 in1d(0:N-1) + real*8 sincoef(0:N-1) + real*8 out1d(0:N) + real*8 aux1(22000+N+N),aux2(25000) + real*8 Pi + +!Initialization + Pi = ATAN(1.0d0) * 4 + naux1 = 22000+N+N + naux2 = 25000 +!Execution + + ! N must be an even number. + if ((N/2)*2 .ne. N) then + write(6,*) "sfft3d: N is odd, N = ",N + call abort + endif + + ! Set up preliminary stuff. + do ll = 0,N-1 + sincoef(ll) = sin(ll*Pi/N) + enddo + + ! assuming cubic grids, initialize internal data just once + call DRCFT( 1 ,in1d ,0 ,out1d,0 ,N,1 ,+1,1.0d0 + & ,aux1,naux1 ,aux2,naux2 ) + + ! Sine transform in the x direction. + do k = 0,N-1 + do j = 0,N-1 + in1d(0) = 0.d0 + do i = 1,N-1 + in1d(i) = sincoef(i)*(f(i,j,k) + f(N-i,j,k)) + + & (f(i,j,k) - f(N-i,j,k))/2 + enddo + + call DRCFT( 0 ,in1d ,0 ,out1d,0 ,N,1 ,+1,1.0d0 + & ,aux1,naux1 ,aux2,naux2 ) + + f(1,j,k) = out1d(0)/2 + f(0,j,k) = 0.d0 + + ! ESSL returns the complex result, but + ! this is the same as the real result just + ! reordered so the imaginary part of out(1:N/2-1) + ! is the same as the real part of out(N/2:N-1) + do i = 1,N/2-1 + f(2*i,j,k) = -out1d(2*i+1) !out(N - i) + f(2*i+1,j,k) = out1d(2*i) + f(2*i-1,j,k) !out(i) + enddo + + enddo + enddo + + + ! Sine transform in the y direction. + do k = 0,N-1 + do j = 0,N-1 + in1d(0) = 0.d0 + do i = 1,N-1 + in1d(i) = sincoef(i)*(f(j,i,k) + f(j,N-i,k)) + + & (f(j,i,k) - f(j,N-i,k))/2 + enddo + + call DRCFT( 0 ,in1d ,0 ,out1d,0 ,N,1 ,+1,1.0d0 + & ,aux1,naux1 ,aux2,naux2 ) + + f(j,1,k) = out1d(0)/2 + f(j,0,k) = 0.d0 + + ![NOTE: see comment above.] + do i = 1,N/2-1 + f(j,2*i,k) = -out1d(2*i+1) !out(N - i) + f(j,2*i+1,k) = out1d(2*i) + f(j,2*i-1,k) !out(i) + enddo + + enddo + enddo + + + ! Sine transform in the z direction. + do k = 0,N-1 + do j = 0,N-1 + in1D(0) = 0.d0 + + do i = 1,N-1 + in1D(i) = sincoef(i)*(f(j,k,i) + f(j,k,N-i)) + + & (f(j,k,i) - f(j,k,N-i))/2 + enddo + + call DRCFT( 0 ,in1d ,0 ,out1d,0 ,N,1 ,+1,1.0d0 + & ,aux1,naux1 ,aux2,naux2 ) + + f(j,k,0) = 0.d0 + f(j,k,1) = out1d(0)/2 + + ![NOTE: see comment above.] + do i = 1,N/2-1 + f(j,k,2*i) = -out1d(2*i+1) !out(N - i) + f(j,k,2*i+1) = out1d(2*i) + f(j,k,2*i-1) !out(i) + enddo + + enddo + enddo + +!done + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/sif.f b/OpticsJan2020/MLI_light_optics/Src/sif.f new file mode 100644 index 0000000..0727b07 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/sif.f @@ -0,0 +1,5735 @@ +cryne The bulk of this file (sif.f) is devoted to reading in +cryne parameters in the Standard Input Format +c + subroutine getconst(line,strval,nreturn) +cryne read & parse a symbolic constant defined in the input file +cryne Note: this assumes only one definition per input record, +cryne i.e. can't have multiple definitions separated by ; if using MADX format. +cryne If using MADX format, the record terminates with the first ; + use parallel + include 'impli.inc' + character line*(*) +cryne 5/4/2006 character linetmp*256 + character linetmp*800 + character cdummy*1 + integer lentmp + logical keypres,numpres + dimension bufr(1) +c +cryne 5/4/2006 linetmp=line +cryne 5/4/2006 lentmp = LEN( linetmp ) +c I don't remember exactly why I added readin800. +c I think it was to process symbolic constants defined on continued lines. +c + call readin800(line,linetmp,mmax) + lentmp=mmax + nreturn=0 +c + +cryne---5/4/2006 I don't know exactly why I commented this out +cryne It must be that this (and other) data processing is handled in readin800 +c n1=index(line,'!') +c if(n1.ne.0)then +c do n=n1,lentmp +c linetmp(n:n)=' ' +c enddo +c endif +c for now assume that there is only one definition per record: +c n1=index(line,';') +c if(n1.ne.0)then +c do n=n1,lentmp +c linetmp(n:n)=' ' +c enddo +c endif +cryne--- + call getparm(linetmp,lentmp,'=',bufr,keypres,numpres,0,cdummy) + if(numpres)then + nreturn=1 + strval=bufr(1) +cc write(6,*)'returning from getparm w/ strval=',strval + endif + return + end +c + subroutine initcons + use acceldata + include 'impli.inc' +c initialize the first few values of #const + pi=2.d0*asin(1.d0) + twopi=4.d0*asin(1.d0) + clite=299792458.d0 + constr(1)='pi' + conval(1)=pi + constr(2)='twopi' + conval(2)=twopi + constr(3)='clite' + conval(3)=clite + nconst=3 +c write(6,*)'nconst=',nconst + return + end +c +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine stdinf(line80,na,kt1,kt2,initparms,lmntname) +c read a record in the Standard Input Format +c input: +c line80=input line +c na=na'th entry in the menu +c kt1, kt2 = indices describing entry category and type +cryne 5/4/2006: removed a lot of code from stdinf and put it in readin800 +cryne 5/4/2006: na appears unused. formerly for debugging? +cryne 12/17/2004: +cryne added initparms (controls whether or not to initialize parameters) +cryne added lmntname (element label; used for diagnostic info & debugging) + include 'impli.inc' + character line80*(*) + character line*800 + character*16 lmntname + call readin800(line80,line,mmax) + call lmntparm(line,mmax,kt1,kt2,initparms,lmntname) + return + end +c + subroutine readin800(line80,line,mmax) +cryne 5/4/2006 store multiline input into a buffer of length 800 +cryne and do some minimal processing of the line +c line80=first 80 character input line +c line=full 800 characture buffer +c mmax=length of resulting line (i.e. nonblank character length) + include 'impli.inc' + character line80*(*) + character line*800 + logical leof + dimension bufr(1) + integer ilen + common/showme/iverbose +c +cryne 5/4/2006 + logical MAD8,MADX + common/mad8orx/MAD8,MADX +c +c write(6,*)'inside readin800' +c +c + leof = .FALSE. + +! if(iverbose.ge.6 .AND. idproc.eq.0)then +! write(6,*)'entering stdinf; kt1,kt2=',kt1,kt2 +! write(6,*)'line80(1:78) = ',line80(1:78) +! endif + +!XXX -- I rewrote this Aug04 + ! read input lines until all the data for this entry is read; + ! and pack it into 'line' + i1 = 0 + i2 = 0 + do !until eof or entry is terminated + ! first iteration uses line80 from caller; rest get input from file + if( i1 .NE. 0 )then +! write(6,*)'calling readin' + call readin(line80,leof) +! write(6,*)'line80(1:78) = ',line80(1:78) + if( leof )then + if( iverbose.ge.6 .AND. idproc.eq.0 )then + write(6,*) 'info: STDINF(): EOF happend with line80=' + & ,line80 + endif + exit + endif + endif + line80 = ADJUSTL( line80 ) !remove leading blanks + ilen = LEN_TRIM( line80 ) !dont look at trailing blanks + ! skip additional blank lines; + ! line80 initially blank is ok but doesnt need processing + if( ilen .EQ. 0 )then + if(i1 .GT. 0 )cycle + else + ! debug + if( iverbose.ge.6 .AND. idproc.eq.0 )then + write(6,*)'info: STDINF(): line80=' + write(6,*) line80(:ilen) + endif + i1 = i2 + 1 !start inserting after end of previous line80 + ! find comments and ignore them + j1 = INDEX( line80(:ilen) ,'!' ) + if( j1 .GT. 0 )then + ! skip if nothing on the line except the comment + if( j1 .EQ. 1 ) cycle + ! strip trailing blanks before the '!' + ilen = LEN_TRIM(line80(:j1-1)) + ! skip if non-comment part of the line is blank + if( ilen .EQ. 0 ) cycle + endif + ! check for not enough buffer space + i2 = i1 + ilen - 1 + if( i2 .GT. LEN( line ) )then + write(6,*) 'error: STDINF(): input too long for line buffer' + write(6,*) 'info: input is [',line80(:ilen),']' + stop + endif + ! convert to lowercase + ![NOTE: readin() does this, so this is probably redundant. ] + call LOW( line80(:ilen) ) + if( iverbose.ge.6 .AND. idproc.eq.0 )then + write(6,*) 'info: STDINF(): after low(), input line is ' + write(6,*) line80(:ilen) + endif +cryne 5/4/2006 +cryne in MADX style, there could be space between ; and !, so deal with it: + do iq=ilen,1,-1 + ilast=iq + if(line80(ilast:ilast).ne.' ')exit + enddo +cryne + ! save this line + line(i1:i2) = line80(:ilen) + ! check if there are more lines to read + if( (MAD8) .and. line80(ilen:ilen) .EQ. '&' )then + ! add a space to the buffer to make sure words are separated + i2 = i2 + 1 + line(i2:i2) = ' ' + ! continue to next line + cycle + elseif( (MADX) .and. line80(ilast:ilast) .NE. ';' )then + write(6,*)'continuing...' +! write(6,*)line80(1:ilen) + i2 = i2 + 1 + line(i2:i2) = ' ' + cycle + endif + endif + ! line is blank or, for ML and MAD8, this is the end, + ! but for MAD9 we should keep going until a ";" is found: +!cryne if( MAD9 ) cycle + exit + enddo + + ! finished with packing all the input lines into the buffer + mmax = i2 + if( iverbose.ge.6 .AND. idproc.eq.0 )then + write(6,*) 'info: STDINF(): completed input buffer =' + write(6,*) line(:mmax) + endif +cryne 5/4/2006 +cryne skip the rest of there is no equal sign on this line +c write(6,*)'nearly finished in readin800 having found:' +c write(6,*)line(1:mmax) + if(index(line,'=').eq.0)then + write(6,*)'leaving readin800 without cleanup up near = sign' + goto 999 + endif + + ! remove blanks around "="; + ! move each character to the left + ! by the number of blanks found up to that character + move = 0 + i1 = 2 !can skip the 1st char + do while( i1 .LE. mmax ) !loop up to the last non-blank + ![NOTE: use a 'while' loop because i1 gets changed inside the loop] + if( line(i1:i1) .EQ. '=' )then + ! count spaces to the left (dont go past the start of the string) + do i2 = 1 ,i1-1 + if( line(i1-i2:i1-i2) .NE. ' ' ) exit + enddo + ! increase the move distance by the number of spaces found + move = move + i2 - 1 + ! do the move, if necessary + if( move .GT. 0 ) line(i1-move:i1-move) = line(i1:i1) + ! count spaces to the right (dont go past the end) + do i2 = 1 ,mmax-i1 + if( line(i1+i2:i1+i2) .NE. ' ' ) exit + enddo + ! increase the move distance by the number of spaces found + move = move + i2 - 1 + ! skip over the spaces on the right so we dont move them + i1 = i1 + i2 - 1 + else + ! not '=', so just move it, if necessary + if( move .GT. 0 ) line(i1-move:i1-move) = line(i1:i1) + endif + i1 = i1 + 1 + enddo + ! clean up chars at end of the string that were moved but not overwritten + if( move .GT. 0 ) line(mmax-move+1:mmax) = ' ' + + if( iverbose.ge.6 .AND. idproc.eq.0 )then + write(6,*) 'info: STDINF(): completed parsing, line =' + write(6,*) line(:mmax) + endif +cryne 5/4/2006 + mmax=mmax-move +cryne now lmntparm is called separately from the above parsing +cryne call lmntparm(line,mmax,kt1,kt2,initparms,lmntname) +cryne call lmntparm(line,mmax-move,kt1,kt2,initparms,lmntname) +cryne debugging: + 999 continue +c write(6,*)'leaving readin800 at end having found:' +c write(6,*)line(1:mmax) + return + end +c +c + subroutine lmntparm(line,mmax,kt1,kt2,initparms,lmntname) +cryne 12/17/2004 added initparms +cryne If initparms=1 the parameters get initialized, otherwise they do not. +cryne This is needed when a menu element is definied in terms of a previous +cryne element, in which case the initial values are inherited, not set here. +cryne 12/17/2004 also added lmntname: used for diagnostic info & debugging + use rays + use acceldata + use beamdata + include 'impli.inc' + include 'pie.inc' + include 'codes.inc' ! added Dec 1, 2002 to check nrp + include 'setref.inc' ! added by RDR, April 18, 2004 (used in BEAM) + include 'files.inc'!RDR 7/29/04 (to backspace(lf) [wake code after BEAM]) +c character*800 line + character line*(*) + character*16 cbuf + character*16 lmntname +cryne 5/4/2006 logical keypres,keypres1,keypres2,numpres + logical keypres,keypres1,keypres2,numpres,leof + dimension bufr(1) + common/mlunits/sclfreq,magunits + common/showme/iverbose +! common/autslice/iautosl +! common/autoslice/islicetype,isliceprecedence,islicevalue + common/symbdef/isymbdef + data multmsg/1/ + save multmsg +c + if(idproc.eq.0.and.iverbose.ge.6)then + write(6,*)'(lmntparm) mmax,kt1,kt2=',mmax,kt1,kt2 + write(6,*)'line=',line(1:mmax) + endif +c +c files.inc contains the unit # (lf) connected to the master input file. +c this is needed so that that wake_init reads from the correct file + iunitnum=lf +cryne=== 9/16/2004 new code to deal with "at=' +cryne=== (needed to emulate MAD "sequence") +c note: eventually, it might be better not to have a separate array +c called atarray, but instead to store the "at" info in pmenu + call getparm(line,mmax,'at=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)atarray(1+mpp(na))=bufr(1) +cryne=== +cryne=== +c +c eventually "c" should be replaced by "clite" in common/parm/ + clite=c +c Select appropriate action depending on value of kt1,kt2 +c + go to (11,12,13,14,15,16,17,18,19), kt1 +c +c 1: simple elements ************************************* +c +11 continue +c write(6,*)'line(1:80)=' +c write(6,*)line(1:80) +c write(6,*)'(lmntparm) kt1,kt2=',kt1,kt2 +c 'drft ','nbnd ','pbnd ','gbnd ','prot ', + go to(101, 102, 103, 104, 105, +c 'gbdy ','frng ','cfbd ','quad ','sext ', + & 106, 107, 108, 109, 110, +c 'octm ','octe ','srfc ','arot ','twsm ', + & 111, 112, 113, 114, 115, +c 'thlm ','cplm ','cfqd ','dism ','sol ', + & 116, 117, 118, 119, 120, +c 'mark ','jmap ','dp ','recm ','spce ', + & 121, 122, 123, 124, 125, +c 'cfrn ','coil ','intg ','rmap ','arc ', + & 126, 127, 128, 129, 130, +c 'rfgap ','confoc ','spare1 ','spare2 ','spare3 ', + & 1135, 1136, 133, 134, 135, +c 'spare4 ','spare5 ','spare6 ','spare7 ','spare8 ', + & 136, 137, 138, 139, 140, +c 'marker ','drift ','rbend ','sbend ','gbend ', + & 141, 142, 143, 1045, 145, +c 'quadrupo','sextupol','octupole','multipol','solenoid', + & 146, 147, 148, 149, 150, +c 'hkicker ','vkicker ','kicker ','rfcavity','elsepara', + & 151, 152, 153, 154, 155, +c 'hmonitor','vmonitor','monitor ','instrume','sparem1 ', + & 156, 157, 158, 159, 160, +c 'rcollima','ecollima','yrot ','srot ','prot3 ', + & 161, 162, 163, 164, 165, +c 'beambeam','matrix ','profile1d','yprofile','tprofile', + & 166, 167, 168, 169, 170, +c 'hkick ','vkick ','kick ','sparem6 ','nlrf '/ + & 171, 172, 173, 174, 175),kt2 +c +c===================================================================== +c DRFT +c===================================================================== +c 'drft ': drift +101 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) +c slices: + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(nrp(1,1).eq.1)then + write(6,*)'DRFT input warning: SLICES will be ignored.' + write(6,*)'To autoslice individual elements specified in the' + write(6,*)'original MaryLie input style, use the SLICEMARYLIE' + write(6,*)'argument of AUTOSLICE and place first in the menu' + else + pmenu(2+mpp(na))=1. + if(numpres)pmenu(2+mpp(na))=bufr(1) + endif + endif + return +c +c +c===================================================================== +c NBND +c===================================================================== +c 'nbnd': +102 continue +c if(idproc.eq.0)write(6,*)'nbnd element is: ',lmntname +c defaults: + if(initparms.eq.1)then + angle=0. + pmenu(1+mpp(na))=angle !angle or angdeg + pmenu(2+mpp(na))=0. !gap or hgap + pmenu(3+mpp(na))=0.5 !fint + pmenu(4+mpp(na))=0. !b + pmenu(5+mpp(na))=0. !lfrn + pmenu(6+mpp(na))=0. !tfrn +cryne 12/21/2004 need to add slices to MaryLie element parsed in MAD format + if(nrp(1,2).eq.7)then +c if(idproc.eq.0)write(6,*)'initializing nbnd slices to 1' + pmenu(7+mpp(na))=1. + endif + endif +c values provided by user: +c angle: + call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angdeg=bufr(1) + pmenu(1+mpp(na))=angdeg + angle=angdeg*pi180 + else + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angle=bufr(1) + pmenu(1+mpp(na))=angle/pi180 + else + write(6,*)'warning: nbnd bend angle not found' + endif + endif +c +c b field: + call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=bufr(1) + else + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=brho*angle/bufr(1) + else + write(6,*)'Error: nbnd L or B not found' + stop + endif + endif +c +c gap, field integral: + call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=2.d0*bufr(1) + endif + call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) +c leading fringe, trailing fringe: + call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) +c slices: + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(nrp(1,2).eq.6)then + write(6,*)' NBND input warning: SLICES will be ignored.' + write(6,*)'To autoslice individual elements specified in the' + write(6,*)'original MaryLie input style, use the SLICEMARYLIE' + write(6,*)'argument of AUTOSLICE and place first in the menu' + else + if(numpres)then +c if(idproc.eq.0)write(6,*)'resetting nbnd slices to ',bufr(1) + pmenu(7+mpp(na))=bufr(1) + endif + endif + endif + return +c +c===================================================================== +c PBND +c===================================================================== +c 'pbnd': +103 continue +c defaults: + if(initparms.eq.1)then + angle=0. + pmenu(1+mpp(na))=angle + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0.5 + pmenu(4+mpp(na))=0. + pmenu(5+mpp(na))=1. !slices + endif +c values provided by user: +c angle: + call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angdeg=bufr(1) + pmenu(1+mpp(na))=bufr(1) + angle=angdeg*pi180 + else + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angle=bufr(1) + pmenu(1+mpp(na))=angle/pi180 + else + write(6,*)'warning: pbnd bend angle not found' + endif + endif +c +c gap, field integral: + call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=2.d0*bufr(1) + endif + call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) +c +c b field: + call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=bufr(1) + else + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=2.d0*brho*sin(0.5d0*angle)/bufr(1) + else + write(6,*)'Error: pbnd L or B not found' + stop + endif + endif +c slices: +cryne 3/17/2004 this is not quite right. +cryne need to clarify how to handle mixed MaryLie and SIF input +cryne and implement it correctly throughout. This will do for now: + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(nrp(1,3).eq.4)then + write(6,*)' PBND input warning: SLICES will be ignored.' + write(6,*)'To autoslice elements specified in the original' + write(6,*)'MaryLie input style, place an autoslice element' + write(6,*)'in the input file BEFORE any MaryLie elements' + else + if(numpres)pmenu(5+mpp(na))=bufr(1) + endif + endif + return +c +c===================================================================== +c GBND +c===================================================================== +c 'gbnd ': general bending magnet +104 continue +c defaults: +c 6 Marylie parameters = angdeg, e1deg, e2deg, gap, fint, B field + if(initparms.eq.1)then + angle=0.d0 + pmenu(1+mpp(na))=angle + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. + pmenu(4+mpp(na))=0. + pmenu(5+mpp(na))=0.5 + pmenu(6+mpp(na))=0. + endif +c values provided by user: +c angle: + call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angdeg=bufr(1) + pmenu(1+mpp(na))=angdeg + angle=angdeg*pi180 + else + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angle=bufr(1) + pmenu(1+mpp(na))=angle/pi180 + else + write(6,*)'warning: gbnd bend angle not found' + endif + endif +c +c entry angle: + call getparm(line,mmax,'e1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1)/pi180 + else + call getparm(line,mmax,'e1deg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + write(6,*)'warning: gbnd entry angle not found' + endif + endif +c +c exit angle: + call getparm(line,mmax,'e2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=bufr(1)/pi180 + else + call getparm(line,mmax,'e2deg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=bufr(1) + else + write(6,*)'warning: gbnd exit angle not found' + endif + endif +c gap and field integral: +c + call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=2.d0*bufr(1) + call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) +c +c b field: + call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(6+mpp(na))=bufr(1) + else + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + write(6,*)'Reading gbnd parameters. Performing conversion' + write(6,*)'from length to B field assuming sbend geometry' + pmenu(6+mpp(na))=brho*angle/bufr(1) + else + write(6,*)'Error: gbnd L or B not found' + stop + endif + endif +c slices: + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(nrp(1,4).eq.6)then + write(6,*)' GBND input warning: SLICES will be ignored.' + write(6,*)'To autoslice individual elements specified in the' + write(6,*)'original MaryLie input style, use the SLICEMARYLIE' + write(6,*)'argument of AUTOSLICE and place first in the menu' + else + pmenu(7+mpp(na))=1. + if(numpres)pmenu(7+mpp(na))=bufr(1) + endif + endif + return +c===================================================================== +c PROT +c===================================================================== +c +c 'prot ': rotation of reference plane +105 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + endif +c values provided by user: + call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1)/pi180 + call getparm(line,mmax,'kind=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + return +c +c===================================================================== +c GBDY +c===================================================================== +c 'gbdy ': body of a general bending magnet +106 continue +c defaults: + if(initparms.eq.1)then + angle=0. + pmenu(1+mpp(na))=angle + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. + pmenu(4+mpp(na))=0. + endif +c values provided by user: +c angle: + call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angdeg=bufr(1) + pmenu(1+mpp(na))=angdeg + angle=angdeg*pi180 + else + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angle=bufr(1) + pmenu(1+mpp(na))=angle/pi180 + else + write(6,*)'warning: gbnd bend angle not found' + endif + endif +c +c entry angle: + call getparm(line,mmax,'e1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1)/pi180 + else + call getparm(line,mmax,'e1deg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + write(6,*)'warning: gbnd entry angle not found' + endif + endif +c +c exit angle: + call getparm(line,mmax,'e2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=bufr(1)/pi180 + else + call getparm(line,mmax,'e2deg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=bufr(1) + else + write(6,*)'warning: gbnd exit angle not found' + endif + endif +c b field: + call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=bufr(1) + else + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + write(6,*)'Reading gbdy parameters. Performing conversion' + write(6,*)'from length to B field assuming sbend geometry' + pmenu(4+mpp(na))=brho*angle/bufr(1) + else + write(6,*)'Error: gbnd L or B not found' + stop + endif + endif +c slices: + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(nrp(1,6).eq.4)then + write(6,*)' GBDY input warning: SLICES will be ignored.' + write(6,*)'To autoslice individual elements specified in the' + write(6,*)'original MaryLie input style, use the SLICEMARYLIE' + write(6,*)'argument of AUTOSLICE and place first in the menu' + else + pmenu(5+mpp(na))=1. + if(numpres)pmenu(5+mpp(na))=bufr(1) + endif + endif + return +c +c===================================================================== +c FRNG +c===================================================================== +c 'frng ': hard edge dipole fringe fields +107 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0.5 + pmenu(4+mpp(na))=0. + pmenu(5+mpp(na))=0. + endif +c values provided by user: + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=2.d0*bufr(1) + call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'iedge=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + return +c +c===================================================================== +c CFBD : PROBABLY NOT FUNCTIONAL; USE 'SBEND' INSTEAD +c===================================================================== +c 'cfbd ': combined function bend (normal entry and exit) +108 continue + write(6,*)'*****CFBD input is not functional*************' + write(6,*)'USE SBEND INSTEAD' +cryne 12/17/2004 what was I thinking here??? this element is all screwed up! +c combined function bend with arbitrary entrance/exit angles? + call getparm(line,mmax,'e1=',bufr,keypres1,numpres,0,cbuf) + call getparm(line,mmax,'e2=',bufr,keypres1,numpres,0,cbuf) + if(keypres1.or.keypres2)then +! (make sure nt1,nt2,na are present in commons) +! nt1(na)=??? +! nt2(na)=??? + goto 1045 + endif +c defaults: + if(initparms.eq.1)then + angle=0. + pmenu(1+mpp(na))=angle + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. + pmenu(4+mpp(na))=0. + pmenu(5+mpp(na))=0. + pmenu(6+mpp(na))=0. + endif +c values provided by user: +c angle: + call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(numpres)pmenu(1+mpp(na))=bufr(1) + angle=angdeg*pi180 + else + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + angle=bufr(1) + if(numpres)pmenu(1+mpp(na))=angle/pi180 + else + write(6,*)'WARNING: no bend angle specified for cfbd' + endif + endif +c b field: + call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(numpres)pmenu(2+mpp(na))=bufr(1) + else + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(numpres)pmenu(2+mpp(na))=brho*bufr(1)/angle + else + write(6,*)'WARNING: no bfield or length specified for cfbd' + endif + endif +c leading fringe, trailing fringe, iopt, ipset: + call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'ipset=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + return +c +c===================================================================== +c SBEND +c===================================================================== +c 'sbend ': combined function bend (arbitrary entry and exit) +1045 continue +c defaults (in MaryLie units, i.e. degrees for angles) : +c (1)bend angle in degrees, (2)B field, +c (3)entry angle in degrees, (4)exit angle in degrees, +c (5)entry fringe, (6)exit fringe, [DEFAULT FOR BOTH = 3, i.e. turned on] +c (7)gap size for leading (entry) fringe field calculation, +c (8)gap size for trailing (exit) fringe field calculation, +c (9)normalized field integral for leading (entry) edge fringe field, +c (10)normalized field integral for trailing (exit) edge fringe field, +c (11)iopt[interpretation of multipole coeffs;default=3=same meaning as MAD], +c (12)ipset [if multipole coeffs specified in pset], +c (13-18)=P1,P2,P3,P4,P5,P6 +c =BQD, AQD,BSEX,ASEX,BOCT,AOCT if iopt=1 +c =Tay1,AQD,Tay2,ASEX,Tay3,AOCT if iopt=2 +c =Tay1/brho,AQD/brho,Tay2/brho,ASEX/brho,Tay3/brho,AOCT/brho if iopt=3 +c (19)axial rotation angle ["TILT" in MAD] +c (20)order +c (21)number of slices + if(initparms.eq.1)then +c The phrases "entry angle" and "exit angle" are WRONG!!!!!!!!!!! +c They should be "entry pole face rotation angle" and "exit pole face +c rotation angle" (This is what E1 and E2 mean in MAD notation.) +c These are only comments in the code, but they will cause confusion. +c FIX LATER!!!!!!!!! + angle=0. + pmenu(1+mpp(na))=angle + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. + pmenu(4+mpp(na))=0. + pmenu(5+mpp(na))=3. !fixed on 11/3/02 (formerly default was 1) + pmenu(6+mpp(na))=3. !ditto + pmenu(7+mpp(na))=0.d0 + pmenu(8+mpp(na))=0.d0 + pmenu(9+mpp(na))=0.d0 + pmenu(10+mpp(na))=0.d0 + pmenu(11+mpp(na))=3.d0 + pmenu(12+mpp(na))=0. + pmenu(13+mpp(na))=0. + pmenu(14+mpp(na))=0. + pmenu(15+mpp(na))=0. + pmenu(16+mpp(na))=0. + pmenu(17+mpp(na))=0. + pmenu(18+mpp(na))=0. + pmenu(19+mpp(na))=0. + pmenu(20+mpp(na))=5. ! order + pmenu(21+mpp(na))=1. ! slices + endif +c values provided by user: +c angle: + call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angdeg=bufr(1) + pmenu(1+mpp(na))=angdeg + angle=angdeg*pi180 + else + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angle=bufr(1) + pmenu(1+mpp(na))=angle/pi180 + else + write(6,*)'warning: sbend bend angle not found' + endif + endif +c +c b field: + call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=brho*angle/bufr(1) + else + write(6,*)'Error: sbend L or B not found' + stop + endif + endif +c +c entry angle: + call getparm(line,mmax,'e1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=bufr(1)/pi180 + else + call getparm(line,mmax,'e1deg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=bufr(1) + else +c write(6,*)'warning: sbend entry angle not found' + endif + endif +c +c exit angle: + call getparm(line,mmax,'e2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=bufr(1)/pi180 + else + call getparm(line,mmax,'e2deg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=bufr(1) + else +c write(6,*)'warning: sbend exit angle not found' + endif + endif +c +c leading fringe, trailing fringe: + call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) +c gap sizes: + call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(7+mpp(na))=bufr(1) + pmenu(8+mpp(na))=bufr(1) + else + call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=2.d0*bufr(1) + if(keypres.and.numpres)pmenu(8+mpp(na))=2.d0*bufr(1) +c + call getparm(line,mmax,'gap1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) + call getparm(line,mmax,'gap2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) +c + call getparm(line,mmax,'hgap1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=2.d0*bufr(1) + call getparm(line,mmax,'hgap2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=2.d0*bufr(1) + endif +c write(6,*)'sbend gap/hgap: found the following:' +c write(6,*)pmenu(7+mpp(na)),pmenu(8+mpp(na)) +c normalized field integrals: + call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(9+mpp(na))=bufr(1) + pmenu(10+mpp(na))=bufr(1) + else + call getparm(line,mmax,'fint1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) + call getparm(line,mmax,'fint2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) + endif +c check consistency of input parameters regarding fringe fields: + if( (pmenu(7+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then + write(6,*)'warning(sbend): input specifies a nonzero gap size' + write(6,*)'but leading-edge fringe effects are turned off?' + endif + if( (pmenu(8+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then + write(6,*)'warning(sbend): input specifies a nonzero gap size' + write(6,*)'but trailing-edge fringe effects are turned off?' + endif + if( (pmenu(9+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then + write(6,*)'warning(sbend):input specifies nonzero field integral' + write(6,*)'but leading-edge fringe effects are turned off?' + endif + if( (pmenu(10+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then + write(6,*)'warning(sbend):input specifies nonzero field integral' + write(6,*)'but trailing-edge fringe effects are turned off?' + endif + if( (pmenu(3+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then + write(6,*)'warning(sbend):input specifies nonzero entrance angle' + write(6,*)'but leading-edge fringe effects are turned off?' + endif + if( (pmenu(4+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then + write(6,*)'warning(sbend):input specifies nonzero exit angle' + write(6,*)'but trailing-edge fringe effects are turned off?' + endif +c +c +c iopt, ipset: + call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) + call getparm(line,mmax,'ipset=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) +c multipole coefficients: + call getparm(line,mmax,'k1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(13+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'s1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(14+mpp(na))=bufr(1) +c for compatability w/ MAD: + call getparm(line,mmax,'ks=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(14+mpp(na))=bufr(1) + call getparm(line,mmax,'k2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(15+mpp(na))=bufr(1) + call getparm(line,mmax,'s2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(16+mpp(na))=bufr(1) + call getparm(line,mmax,'k3=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(17+mpp(na))=bufr(1) + call getparm(line,mmax,'s3=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(18+mpp(na))=bufr(1) +c tilt: + call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(19+mpp(na))=bufr(1) +c order: + call getparm(line,mmax,'order=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(20+mpp(na))=bufr(1) +c slices: + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(21+mpp(na))=bufr(1) +c for debugging: + if(idproc.eq.0 .and. iverbose.ge.1)then + write(6,*)'done reading SBEND parameters,' + write(6,*)'angle,b=',pmenu(1+mpp(na)),pmenu(2+mpp(na)) + write(6,*)'e1,e2=',pmenu(3+mpp(na)),pmenu(4+mpp(na)) + endif + return +c +c +c===================================================================== +c QUAD +c===================================================================== +c 'quad ': quadrupole +109 continue + if(idproc.eq.0)then + write(6,*)'reading parameters for a QUAD in MAD format.' + write(6,*)'**NOTE WELL** QUAD is used for backward compatibility' + write(6,*)'with MaryLie and corresponds to the original MaryLie' + write(6,*)'code. Suggest you use QUADRUPOLE instead.' + endif +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. + pmenu(4+mpp(na))=0. +cryne 12/17/2004 added initialization of # of slices too, +cryne commented out below at end of QUAD section + pmenu(5+mpp(na))=1. + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'g1=',bufr,keypres1,numpres,0,cbuf) + if(keypres1.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + call getparm(line,mmax,'k1=',bufr,keypres2,numpres,0,cbuf) + if(keypres2.and.numpres)then + pmenu(2+mpp(na))=bufr(1)*brho + endif + endif + if((.not.keypres1).and.(.not.keypres2))then + write(6,*)lmntname,'WARNING: neither g1 nor k1 has been specified' + endif + call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) +c slices: + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(nrp(1,9).eq.4)then + write(6,*)' QUAD input warning: SLICES will be ignored.' + write(6,*)'To autoslice individual elements specified in the' + write(6,*)'original MaryLie input style, use the SLICEMARYLIE' + write(6,*)'argument of AUTOSLICE and place first in the menu' + else +cryne 12/17/2004 pmenu(5+mpp(na))=1. + if(numpres)pmenu(5+mpp(na))=bufr(1) + endif + endif + write(6,*)'done reading QUAD parameters:' + write(6,*)pmenu(1+mpp(na)),pmenu(2+mpp(na)) + write(6,*)pmenu(3+mpp(na)),pmenu(4+mpp(na)) + return +c +c===================================================================== +c SEXT +c===================================================================== +c 'sext ': sextupole +110 continue +c write(6,*)'(LMNTPARM) SEXT:' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'g2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + call getparm(line,mmax,'k2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1)*brho/2.d0 + endif + endif +c slices: + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(nrp(1,10).eq.2)then + write(6,*)' SEXT input warning: SLICES will be ignored.' + write(6,*)'To autoslice individual elements specified in the' + write(6,*)'original MaryLie input style, use the SLICEMARYLIE' + write(6,*)'argument of AUTOSLICE and place first in the menu' + else + pmenu(3+mpp(na))=1. + if(numpres)pmenu(3+mpp(na))=bufr(1) + endif + endif + return +c +c===================================================================== +c OCTM +c===================================================================== +c 'octm ': mag. octupole +111 continue +c write(6,*)'(LMNTPARM) OCTM:' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'g3=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + call getparm(line,mmax,'k3=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1)*brho/6.d0 + endif + endif +c slices: + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(nrp(1,11).eq.2)then + write(6,*)' SEXT input warning: SLICES will be ignored.' + write(6,*)'To autoslice individual elements specified in the' + write(6,*)'original MaryLie input style, use the SLICEMARYLIE' + write(6,*)'argument of AUTOSLICE and place first in the menu' + else + pmenu(3+mpp(na))=1. + if(numpres)pmenu(3+mpp(na))=bufr(1) + endif + endif + return +c +c===================================================================== +c OCTE +c===================================================================== +c 'octe ': elec. octupole +112 continue + if(initparms.eq.1)then +c ... + endif + write(6,*)'MAD-style input for MaryLie octe not implemented' + stop +c +c===================================================================== +c SRFC +c===================================================================== +c 'srfc ': short rf cavity +113 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. !volts (in Volts) + pmenu(2+mpp(na))=0. !freq (in Hz) + endif + call getparm(line,mmax,'volts=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'freq=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + return +c +c===================================================================== +c RFGAP +c===================================================================== +c 'rfgap ': rf gap +1135 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=-1.0 !length + pmenu(2+mpp(na))=0. !frequency + pmenu(3+mpp(na))=0. !escale + pmenu(4+mpp(na))=0. !phasedeg + pmenu(5+mpp(na))=0. !unit (integer N for data file called rfdataN) + pmenu(6+mpp(na))=0. !steps + pmenu(7+mpp(na))=0. !e1deg + pmenu(8+mpp(na))=0. !notused + pmenu(9+mpp(na))=1. !tdim + pmenu(10+mpp(na))=1. !ptdim + pmenu(11+mpp(na))=1. !slices + cmenu(1+mppc(na))=' ' !file = name of data file + cmenu(2+mppc(na))=' ' !wake + endif +c write(6,*)'READING RFGAP PARAMETERS' +c length (or flag), freq,volts, phase, #, int_steps, slices +c + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) +c + call getparm(line,mmax,'freq=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) +c + call getparm(line,mmax,'volts=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(idproc.eq.0)then + write(6,*)'ERROR (RFGAP): the keywork VOLTS has been replaced' + write(6,*)'with ESCALE. Modify your input file and re-run' + endif + call myexit + endif + call getparm(line,mmax,'escale=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) +c + call getparm(line,mmax,'phasedeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) +c + call getparm(line,mmax,'unit=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) +c + call getparm(line,mmax,'steps=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) +c + call getparm(line,mmax,'e1deg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) +c + call getparm(line,mmax,'notused=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) +c + call getparm(line,mmax,'tdim=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) +c + call getparm(line,mmax,'ptdim=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) +c + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) +c file: + call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif +c wake: + call getparm(line,mmax,'wake=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(2+mppc(na))='wake' + write(6,*)'found rfgap wake; name of wake =',cbuf + call wake_init(cbuf) + endif +! check for over-specification: + if(pmenu(5+mpp(na)).ne.0. .and. cmenu(1+mppc(na)).ne.' ')then + if(idproc.eq.0)then + write(6,*)'rfgap input error:' + write(6,*)'specified file rfgapN, where N =',pmenu(5+mpp(na)) + write(6,*)'specified file name, where name=',cmenu(1+mppc(na)) + write(6,*)'cannot specify file by both number and name' + endif + call myexit + endif + return +c +c===================================================================== +c CONFOC +c===================================================================== +c 'confoc ': "constant focusing" element rdr 08/29/2001 +1136 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !length + pmenu(2+mpp(na))=0.d0 !k1 + pmenu(3+mpp(na))=0.d0 !k2 + pmenu(4+mpp(na))=0.d0 !k3 + pmenu(5+mpp(na))=1.d0 !slices + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'k1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'k2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'k3=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) +! + if(idproc.eq.0)then + write(6,*)'results of confoc input:' + write(6,*)'l=',pmenu(1+mpp(na)) + write(6,*)'k1=',pmenu(2+mpp(na)) + write(6,*)'k2=',pmenu(3+mpp(na)) + write(6,*)'k3=',pmenu(4+mpp(na)) + write(6,*)'slices=',pmenu(5+mpp(na)) + endif + return +c +c===================================================================== +c AROT +c===================================================================== +c 'arot ': axial rotation +114 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + endif +c values provided by user: + call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1)/pi180 + return + stop +c +c===================================================================== +c TWSM +c===================================================================== +c 'twsm ': linear matrix via twiss parameters +115 continue + if(initparms.eq.1)then +c ... + endif + write(6,*)'MAD-style input for ML twsm not implemented' + stop +c +c===================================================================== +c THLM +c===================================================================== +c 'thlm ': thin lens low order multipole +116 continue +c if(idproc.eq.0)write(6,*)'reading parameters for thlm' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. + pmenu(4+mpp(na))=0. + pmenu(5+mpp(na))=0. + pmenu(6+mpp(na))=0. + endif +c values provided by user: +c normal quadrupole (n=0): + call getparm(line,mmax,'bqd=',bufr,keypres,numpres,0,cbuf) + if(keypres)then +c if(idproc.eq.0)write(6,*)'found bqd' + if(numpres)then + pmenu(1+mpp(na))=bufr(1) +c if(idproc.eq.0)write(6,*)'param1=',pmenu(1+mpp(na)) + endif + else + call getparm(line,mmax,'k1l=',bufr,keypres,numpres,0,cbuf) + if(keypres)then +c if(idproc.eq.0)write(6,*)'found k1l' + if(numpres)then + pmenu(1+mpp(na))=bufr(1)*brho +c if(idproc.eq.0)write(6,*)'param1=',pmenu(1+mpp(na)) + endif + endif + endif +c skew quadrupole: +c fix later. +c +c normal sextupole: + call getparm(line,mmax,'bsex=',bufr,keypres,numpres,0,cbuf) + if(keypres)then +c if(idproc.eq.0)write(6,*)'found bsex' + if(numpres)then + pmenu(3+mpp(na))=bufr(1) +c if(idproc.eq.0)write(6,*)'param3=',pmenu(3+mpp(na)) + endif + else + call getparm(line,mmax,'k2l=',bufr,keypres,numpres,0,cbuf) + if(keypres)then +c if(idproc.eq.0)write(6,*)'found k2l' + if(numpres)then + pmenu(3+mpp(na))=bufr(1)*brho +c if(idproc.eq.0)write(6,*)'param3=',pmenu(3+mpp(na)) + endif + endif + endif +c skew sextupole: +c fix later. +c +c normal octupole: + call getparm(line,mmax,'boct=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(numpres)pmenu(5+mpp(na))=bufr(1) + else + call getparm(line,mmax,'k3l=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(numpres)pmenu(5+mpp(na))=bufr(1)*brho + endif + endif +c skew sextupole: +c fix later. +c higher order stuff from MAD: +c fix later. +c printout for debugging: +c if(idproc.eq.0)then +c write(6,*)'multipole parameters have been set to:' +c do ii=1,6 +c write(6,*)pmenu(ii+mpp(na)) +c enddo +c endif + return +c +c===================================================================== +c CPLM +c===================================================================== +c 'cplm ': "compressed" low order multipole +117 continue + write(6,*)'MAD-style input for MaryLie cplm not implemented' + stop +c +c===================================================================== +c CFQD +c===================================================================== +c 'cfqd ': combined function quadrupole +118 continue + write(6,*)'MAD-style input for MaryLie cfqd not implemented' + stop +c +c dispersion matrix (dism) +119 continue + write(6,*)'MAD-style input for MaryLie dism not implemented' + stop +c +c 'sol ': solenoid +120 continue + write(6,*)'MAD-style input for MaryLie sol not implemented' + write(6,*)'Use solenoid instead of sol' + stop +c +c 'mark ': marker +121 continue + write(6,*)'MAD-style input for MaryLie mark not implemented' + stop +c +c 'jmap ': j mapping +122 continue + write(6,*)'MAD-style input for MaryLie jmap not implemented' + stop +c +c 'dp ': data point +123 continue + write(6,*)'MAD-style input for MaryLie dp not implemented' + stop +c +c 'recm ': REC multiplet +124 continue + write(6,*)'MAD-style input for MaryLie recm not implemented' + stop +c +c 'spce ': space +125 continue + write(6,*)'MAD-style input for MaryLie spce not implemented' + stop +c +c 'cfrn ': change/write fringe field params for comb function dipole +126 continue + write(6,*)'MAD-style input for MaryLie cfrn not implemented' + stop +c +c 'coil' +127 continue + write(6,*)'MAD-style input for MaryLie coil not implemented' + stop +c +c 'intg' +128 continue + write(6,*)'MAD-style input for MaryLie intg not implemented' + stop +c +129 continue +c 'rmap' + write(6,*)'MAD-style input for MaryLie rmap not implemented' + stop +c +c 'arc' +130 continue + write(6,*)'MAD-style input for MaryLie arc not implemented' + stop +c +c 'transit' +133 continue + write(6,*)'(sif) transit' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. !l (length) + pmenu(2+mpp(na))=1. !n + pmenu(3+mpp(na))=1. !slices + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'n=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + return +c 'interface' +134 write(6,*)'(sif) interface' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=1. !n1 + pmenu(2+mpp(na))=1. !n2 + pmenu(3+mpp(na))=0. !b2 + pmenu(4+mpp(na))=0. !b4 + pmenu(5+mpp(na))=0. !b6 + endif +c values provided by user: + call getparm(line,mmax,'n1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'n2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'b2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'b4=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'b6=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + return +c 'rootmap' +135 write(6,*)'(sif) rootmap' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=1. !n + pmenu(2+mpp(na))=0. !b2 + pmenu(3+mpp(na))=0. !b4 + pmenu(4+mpp(na))=0. !b6 + cmenu(1+mppc(na))='false' !invert= : flag to compute inverted map + endif +c values provided by user: + call getparm(line,mmax,'n=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'b2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'b4=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'b6=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'inverse=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + return +c 'optirot' +136 write(6,*)'(sif) optirot' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + endif +c values provided by user: + call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1)/pi180 + call getparm(line,mmax,'kind=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + return +c +c 'spare5' +137 write(6,*)'spare5 just a placeholder (not a valid type code)' + return +c 'spare6' +138 write(6,*)'spare6 just a placeholder (not a valid type code)' + return +c 'spare7' +139 write(6,*)'spare7 just a placeholder (not a valid type code)' + return +c 'spare8' +140 write(6,*)'spare8 just a placeholder (not a valid type code)' + return +c +c 'marker': MAD marker +141 continue +cryne 5/4/2006 write(6,*)'ignoring input for MAD marker (not implemented)' + write(12,*)'ignoring input for MAD marker (not implemented)' + return +c +c===================================================================== +c DRIFT +c===================================================================== +c 'drift': MAD drift +142 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. !isssflag + pmenu(3+mpp(na))=1. !slices + cmenu(1+mppc(na))=' ' !wake + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=bufr(1) + endif +c wake: + call getparm(line,mmax,'wake=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))='wake' + write(6,*)'found drift wake; name of wake =',cbuf + call wake_init(cbuf) + endif +c write(6,*)'FOUND DRIFT; SLICES=',nint(bufr(1)) + return +c +c===================================================================== +c RBEND +c===================================================================== +c 'rbend': MAD rectangular bend +143 continue +c defaults: + if(initparms.eq.1)then +cryne NOTE TO MYSELF: +c The phrases "entry angle" and "exit angle" are WRONG!!!!!!!!!!! +c They should be "entry pole face rotation angle" and "exit pole face +c rotation angle" (This is what E1 and E2 mean in MAD notation.) +c These are only comments in the code, but they will cause confusion. +c FIX LATER!!!!!!!!! + angle=0. + pmenu(1+mpp(na))=angle !bend angle + pmenu(2+mpp(na))=0. !B field + pmenu(3+mpp(na))=0. !entry angle + pmenu(4+mpp(na))=0. !exit angle + pmenu(5+mpp(na))=3. !entry fringe on/off (default on) + pmenu(6+mpp(na))=3. !exit fringe on/off (default on) + pmenu(7+mpp(na))=0.d0 !gap size for leading (entry) fringe field calc + pmenu(8+mpp(na))=0.d0 !gap size for trailing (exit) fringe field calc + pmenu(9+mpp(na))=0.d0 !fint for leading (entry) fringe + pmenu(10+mpp(na))=0.d0 !fint size for trailing (exit) fringe + pmenu(11+mpp(na))=0. ! tilt + pmenu(12+mpp(na))=5. ! order + pmenu(13+mpp(na))=1. ! slices + endif +c values provided by user: +c angle: + call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angdeg=bufr(1) + pmenu(1+mpp(na))=angdeg + angle=angdeg*pi180 + else + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + angle=bufr(1) + pmenu(1+mpp(na))=angle/pi180 + else + write(6,*)'warning (rbend): bend angle not found' + endif + endif +c +c b field: + call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + if(angle.ne.0.)then + pmenu(2+mpp(na))=brho/(0.5*bufr(1)/sin(0.5*angle)) + else + write(6,*)'error (rbend): angle=0 in b field calculation' + call myexit + endif + else + write(6,*)'Error: rbend L or B not found' + stop + endif + endif +c +c entry angle: + call getparm(line,mmax,'e1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=bufr(1)/pi180 + else + call getparm(line,mmax,'e1deg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=bufr(1) + else +c write(6,*)'warning (rbend): entry angle not found' + endif + endif +c +c exit angle: + call getparm(line,mmax,'e2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=bufr(1)/pi180 + else + call getparm(line,mmax,'e2deg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=bufr(1) + else +c write(6,*)'warning (rbend): exit angle not found' + endif + endif +c +c leading fringe, trailing fringe: + call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) +c gap sizes: + call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(7+mpp(na))=bufr(1) + pmenu(8+mpp(na))=bufr(1) + else + call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=2.d0*bufr(1) + if(keypres.and.numpres)pmenu(8+mpp(na))=2.d0*bufr(1) +c + call getparm(line,mmax,'gap1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) + call getparm(line,mmax,'gap2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) +c + call getparm(line,mmax,'hgap1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=2.d0*bufr(1) + call getparm(line,mmax,'hgap2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=2.d0*bufr(1) + endif +c write(6,*)'rbend gap/hgap: found the following:' +c write(6,*)pmenu(7+mpp(na)),pmenu(8+mpp(na)) +c normalized field integrals: + call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(9+mpp(na))=bufr(1) + pmenu(10+mpp(na))=bufr(1) + else + call getparm(line,mmax,'fint1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) + call getparm(line,mmax,'fint2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) + endif +c check consistency of input parameters regarding fringe fields: + if( (pmenu(7+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then + write(6,*)'warning (rbend): input specifies a nonzero gap size' + write(6,*)'but leading-edge fringe effects are turned off?' + endif + if( (pmenu(8+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then + write(6,*)'warning (rbend): input specifies a nonzero gap size' + write(6,*)'but trailing-edge fringe effects are turned off?' + endif + if( (pmenu(9+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then + write(6,*)'warning (rbend):input specifies nonzero field integral' + write(6,*)'but leading-edge fringe effects are turned off?' + endif + if( (pmenu(10+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then + write(6,*)'warning (rbend):input specifies nonzero field integral' + write(6,*)'but trailing-edge fringe effects are turned off?' + endif + if( (pmenu(3+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then + write(6,*)'warning (rbend):input specifies nonzero entrance angle' + write(6,*)'but leading-edge fringe effects are turned off?' + endif + if( (pmenu(4+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then + write(6,*)'warning (rbend):input specifies nonzero exit angle' + write(6,*)'but trailing-edge fringe effects are turned off?' + endif +c +c +c tilt: + call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) +c order: + call getparm(line,mmax,'order=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) +c slices: + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(13+mpp(na))=bufr(1) +c +c write(6,*)'done reading RBEND parameters for element: ',lmntname +c write(6,*)'bend angle=',pmenu(1+mpp(na)) +c write(6,*)'B field=',pmenu(2+mpp(na)) +c write(6,*)'entry angle=',pmenu(3+mpp(na)) +c write(6,*)'exit angle=',pmenu(4+mpp(na)) +c write(6,*)'lfrn=',pmenu(5+mpp(na)) +c write(6,*)'tfrn=',pmenu(6+mpp(na)) +c write(6,*)'gap1=',pmenu(7+mpp(na)) +c write(6,*)'gap2=',pmenu(8+mpp(na)) +c write(6,*)'fint1=',pmenu(9+mpp(na)) +c write(6,*)'fint2=',pmenu(10+mpp(na)) +c write(6,*)'tilt=',pmenu(11+mpp(na)) +c write(6,*)'order=',pmenu(12+mpp(na)) +c write(6,*)'slices=',pmenu(13+mpp(na)) + return +c +c 'sbend': MAD sector bend +c 144 continue +c see statement 1045 +c +c 'gbend': MAD general bend +145 continue + write(6,*)'MAD general bend not implemented' + stop +c +c===================================================================== +c QUADRUPOLE +c===================================================================== +c 'quadrupole': MAD quadrupole +146 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. + pmenu(4+mpp(na))=0. + pmenu(5+mpp(na))=0. !isssflag + pmenu(6+mpp(na))=1. !slices + cmenu(1+mppc(na))=' ' !wake + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'g1=',bufr,keypres1,numpres,0,cbuf) + if(keypres1.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + call getparm(line,mmax,'k1=',bufr,keypres2,numpres,0,cbuf) + if(keypres2.and.numpres)then + pmenu(2+mpp(na))=bufr(1)*brho + endif + endif + if((.not.keypres1).and.(.not.keypres2))then + write(6,*)lmntname,'WARNING: neither g1 nor k1 has been specified' + endif + call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) +c + call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) +c + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(6+mpp(na))=bufr(1) + endif +c wake: + call getparm(line,mmax,'wake=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))='wake' + write(6,*)'found quadrupole wake; name of wake =',cbuf + call wake_init(cbuf) + endif + return +c +c +c===================================================================== +c SEXTUPOLE +c===================================================================== +c 'sextupol': MAD sextupole +147 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=1. !slices + cmenu(1+mppc(na))=' ' !wake + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'g2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + call getparm(line,mmax,'k2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1)*brho/2.d0 + endif + endif +c + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) +c wake: + call getparm(line,mmax,'wake=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))='wake' + write(6,*)'found sextupole wake; name of wake =',cbuf + call wake_init(cbuf) + endif + return +c +c===================================================================== +c OCTUPOLE +c===================================================================== +c 'octupole': MAD octupole +148 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=1. !slices + cmenu(1+mppc(na))=' ' !wake + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'g3=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + else + call getparm(line,mmax,'k3=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1)*brho/6.d0 + endif + endif +c + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) +c wake: + call getparm(line,mmax,'wake=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))='wake' + write(6,*)'found octupole wake; name of wake =',cbuf + call wake_init(cbuf) + endif + return +c +c===================================================================== +c MULTIPOLE +c===================================================================== +c 'multipole': MAD general thin multipole +c NOTE WELL: no factors of brho here; dealt with in subroutine lmnt +149 continue + if(multmsg.eq.1)then + if(idproc.eq.0)write(6,*)'MAD multipole partially implemented' + multmsg=0 + endif +c if(idproc.eq.0)write(6,*)'reading parameters for MAD multipole' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. + pmenu(4+mpp(na))=0. + pmenu(5+mpp(na))=0. + pmenu(6+mpp(na))=0. + endif +c values provided by user: +c normal quadrupole (n=0): + call getparm(line,mmax,'k1l=',bufr,keypres,numpres,0,cbuf) + if(keypres)then +c if(idproc.eq.0)write(6,*)'found k1l' + if(numpres)then + pmenu(1+mpp(na))=bufr(1) +c if(idproc.eq.0)write(6,*)'param1=',pmenu(1+mpp(na)) + endif + endif +c skew quadrupole: +c fix later. +c +c normal sextupole: + call getparm(line,mmax,'bsex=',bufr,keypres,numpres,0,cbuf) + call getparm(line,mmax,'k2l=',bufr,keypres,numpres,0,cbuf) + if(keypres)then +c if(idproc.eq.0)write(6,*)'found k2l' + if(numpres)then + pmenu(3+mpp(na))=bufr(1) +c if(idproc.eq.0)write(6,*)'param3=',pmenu(3+mpp(na)) + endif + endif +c skew sextupole: +c fix later. +c +c normal octupole: + call getparm(line,mmax,'k3l=',bufr,keypres,numpres,0,cbuf) + if(keypres)then + if(numpres)pmenu(5+mpp(na))=bufr(1) + endif +c skew sextupole: +c fix later. +c higher order stuff from MAD: +c fix later. +c printout for debugging: + if(idproc.eq.0)then + write(12,*)'(sif) multipole parameters read in, set to:' + do ii=1,6 + write(12,*)pmenu(ii+mpp(na)) + enddo + endif + return +c +c===================================================================== +c +c 'solenoid': MAD solenoid +150 continue +c defaults: + if (initparms.eq.1) then + pmenu(1+mpp(na))= 0. ! zstart + pmenu(2+mpp(na))= 0. ! zend + pmenu(3+mpp(na))= 100. ! steps + pmenu(4+mpp(na))= 0. ! iprofile + pmenu(5+mpp(na))= -1. ! ipset (not used, but -1 ==> SIF-style) + pmenu(6+mpp(na))= 0. ! multipoles (not used) + pmenu(7+mpp(na))= 0. ! ldrift + pmenu(8+mpp(na))= 0. ! lbody + pmenu(9+mpp(na))= 0. ! clength + pmenu(10+mpp(na))= 0. ! b + pmenu(11+mpp(na))= 0. ! iecho + pmenu(12+mpp(na))= 0. ! iopt + pmenu(13+mpp(na))= 1. ! slices + end if +c values provided by user: +c first make sure the user is not using a pset: + call getparm(line,mmax,'ipset=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + if(idproc.eq.0)then + write(6,*)'error: solenoid with MAD-style input does not' + write(6,*)'require specification of ipset' + endif + stop + endif +c + call getparm(line,mmax,'zstart=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'zend=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'steps=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'iprofile=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) +ccccc call getparm(line,mmax,'ipset=',bufr,keypres,numpres,0,cbuf) +ccccc if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'multipoles=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + call getparm(line,mmax,'ldrift=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) + call getparm(line,mmax,'lbody=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) + call getparm(line,mmax,'clength=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) + call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) + call getparm(line,mmax,'iecho=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) + call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(13+mpp(na))=bufr(1) + return +c +c 'hkicker': MAD horizontal kicker +151 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. !isssflag + pmenu(4+mpp(na))=0. + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'kick=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + return +c +c 'vkicker': MAD vertical kicker +152 continue +c defaults: + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. !isssflag + pmenu(4+mpp(na))=0. +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'kick=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + return +c +c 'kicker': MAD kicker +153 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. + pmenu(4+mpp(na))=0. !isssflag + pmenu(5+mpp(na))=0. + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'hkick=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'vkick=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + return +c +c 'rfcavity': MAD rf cavity +154 continue + write(6,*)'MAD RFCAVITY' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. ! l + pmenu(2+mpp(na))=0. ! volt + pmenu(3+mpp(na))=0. ! lag + pmenu(4+mpp(na))=0. ! harmon + pmenu(5+mpp(na))=0. ! betrf + pmenu(6+mpp(na))=0. ! pg + pmenu(7+mpp(na))=0. ! shunt + pmenu(8+mpp(na))=0. ! tfill + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'volt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'lag=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'harmon=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'betrf=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'pg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + call getparm(line,mmax,'shunt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) + call getparm(line,mmax,'tfill=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) + return +c +c 'elsepara': MAD electrostatic separator +155 continue + write(6,*)'MAD ELSEPARATOR' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + pmenu(3+mpp(na))=0. + pmenu(4+mpp(na))=0. !isssflag + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'e=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + return +c +c 'hmonitor': MAD horizontal monitor +156 continue + write(12,*)'reading SIF input for MAD hmonitor' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. !length + pmenu(2+mpp(na))=0. !isssflag + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + return +c +c 'vmonitor': MAD vertical monitor +157 continue + write(12,*)'reading SIF input for MAD vmonitor' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. !length + pmenu(2+mpp(na))=0. !isssflag + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + return +c +c 'monitor': MAD monitor +158 continue + write(12,*)'reading SIF input for MAD monitor' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. !length + pmenu(2+mpp(na))=0. !isssflag + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + return +c +c 'instrume': MAD instrument +159 continue + write(12,*)'reading SIF input for MAD instrument' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. !length + pmenu(2+mpp(na))=0. !isssflag + endif +c values provided by user: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + return +c +c 'sparem1' +160 write(6,*)'sparem1 just a placeholder (not a valid type code)' + return +c +c 'rcollima': MAD rectangular collimator +161 continue + write(6,*)'ignoring input for MAD rcollimator (not implemented)' + return +c +c 'ecollima': MAD elliptical collimator +162 continue + write(6,*)'ignoring input for MAD ecollimator (not implemented)' + return +c +c 'yrot' +163 write(6,*)'YROT input: using MaryLie prot' + write(6,*)'NOTE WELL: this will not work!' + write(6,*)'YROT has one parameter; MaryLie prot has two.' + write(6,*)'this needs to be fixed.' +cryne goto 105 + stop +c +c 'srot' +164 write(6,*)'SROT input: using MaryLie arot (check sign!)' + goto 114 +c +c===================================================================== +c PROT3 +c===================================================================== +c +c 'prot3 ': 3rd order rotation of reference plane +165 continue + if(idproc.eq.0)write(6,*)'reading prot3 data in sif.f' +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=0. + endif +c values provided by user: + call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1)/pi180 + call getparm(line,mmax,'kind=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + return +c +c 'beambeam': MAD beam-beam element +166 write(6,*)'MAD beambeam not implemented' + stop +c +c 'matrix': MAD matrix command +167 write(6,*)'MAD matrix not implemented' + stop +c +c===================================================================== +c PROFILE1 +c===================================================================== +c 'profile1d': 1D profile monitor +168 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=1.d0 !column for 1D histrogram + pmenu(2+mpp(na))=128.d0 !number of bins + pmenu(3+mpp(na))=0.d0 !sequencelength (=max # of files in sequence) + pmenu(4+mpp(na))=5.d0 !precision + pmenu(5+mpp(na))=0.d0 !assigned unit# for output file (or can be read in) + pmenu(6+mpp(na))=0.d0 !assigned counter for sequence of files + pmenu(7+mpp(na))=0.d0 !rwall + cmenu(1+mppc(na))=' ' !file= : name of output file + cmenu(2+mppc(na))='true' !close= : flag to close output file + cmenu(3+mppc(na))='false' !flush= : flag to flush output file + endif +c values provided by user: + call getparm(line,mmax,'column=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(1+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'bins=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'sequencelength=',bufr,keypres,numpres, & + & 0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'precision=',bufr,keypres,numpres, & + & 0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'unit=',bufr,keypres,numpres, & + & 0,cbuf) + if(keypres.and.numpres)then + pmenu(5+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'close=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(3+mppc(na))=cbuf + endif + call getparm(line,mmax,'rwall=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) +! if(idproc.eq.0)then +! write(6,*)'done reading data for profile1' +! write(6,*)'column=',pmenu(1+mpp(na)) +! write(6,*)'bins=',pmenu(2+mpp(na)) +! endif + return +c 'sparem4' +169 write(6,*)'sparem4 just a placeholder (not a valid type code)' + return +c 'sparem5' +170 write(6,*)'sparem5 just a placeholder (not a valid type code)' + return +c +c 'hkick ': synonym for MAD horizontal kicker +171 continue + goto 151 +c +c 'vkick ': synonym for MAD vertical kicker +172 continue + goto 152 +c +c 'kick ': synonym for MAD kicker +173 continue + goto 153 +c +c 'sparem6' +174 write(6,*)'sparem6 just a placeholder (not a valid type code)' + return +c +c===================================================================== +c NLRF +c===================================================================== +c 'nlrf': nonlinear rf cavity +175 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !zstart + pmenu(2+mpp(na))=0.d0 !zend + pmenu(3+mpp(na))=0.d0 !frequency + pmenu(4+mpp(na))=0.d0 !phasedeg + pmenu(5+mpp(na))=1.d0 !escale + pmenu(6+mpp(na))=0.d0 !steps + pmenu(7+mpp(na))=1.d0 !slices + cmenu(1+mppc(na))='rfdata' !E-field data file + cmenu(2+mppc(na))='crz.dat' !generalized gradients file + endif +c values provided by user: +cp1 + call getparm(line,mmax,'zstart=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) +cp2 + call getparm(line,mmax,'zend=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) +cp3 + call getparm(line,mmax,'frequency=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) +cp4 + call getparm(line,mmax,'phasedeg=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) +cp5 + call getparm(line,mmax,'escale=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) +cp6 + call getparm(line,mmax,'nz=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) +cp7 + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) +cc1 + call getparm(line,mmax,'efile=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif +cc2 + call getparm(line,mmax,'crzfile=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif +c + if(idproc.eq.0)then + write(6,*) 'Read nlrf parameters:' + write(6,*) ' zstart=',pmenu(1+mpp(na)) + write(6,*) ' zend=',pmenu(2+mpp(na)) + write(6,*) ' frequency=',pmenu(3+mpp(na)) + write(6,*) ' phasedeg=',pmenu(4+mpp(na)) + write(6,*) ' escale=',pmenu(5+mpp(na)) + write(6,*) ' steps=',pmenu(6+mpp(na)) + write(6,*) ' slices=',pmenu(7+mpp(na)) + write(6,*) ' efile=',cmenu(1+mppc(na)) + write(6,*) ' crzfile=',cmenu(2+mppc(na)) + endif + return +c +c +c 2: user-supplied elements ************************************ +c +c 'usr1 ','usr2 ','usr3 ','usr4 ','usr5 ', +12 go to (201, 202, 203, 204, 205, & +c 'usr6 ','usr7 ','usr8 ','usr9 ','usr10 ' + & 206, 207, 208, 209, 210, & +c 'usr11 ','usr12 ','usr13 ','usr14 ','usr15 ', + & 211, 212, 213, 214, 215, & +c 'usr16 ','usr17 ','usr18 ','usr19 ','usr20 ', + & 216, 217, 218, 219, 220),kt2 +c +201 continue + return +202 continue + return +203 continue + return +204 continue + return +205 continue + return +206 continue + return +207 continue + return +208 continue + return +209 continue + return +210 continue + return +211 continue + return +212 continue + return +213 continue + return +214 continue + return +215 continue + return +216 continue + return +217 continue + return +218 continue + return +219 continue + return +220 continue + return +c +c 3: parameter sets ********************************************** +c +c 'ps1 ','ps2 ','ps3 ','ps4 ','ps5 ', +13 go to (301, 302, 303, 304, 305, & +c 'ps6 ','ps7 ','ps8 ','ps9 '/ + & 306, 307, 308, 309),kt2 +c +301 continue + return +302 continue + return +303 continue + return +304 continue + return +305 continue + return +306 continue + return +307 continue + return +308 continue + return +309 continue + return +c +c 4-6: random elements +c +14 continue +15 continue +16 continue + return +c +c 7: simple commands ************************************* +c +c 'rt ','sqr ','symp ','tmi ','tmo ', +17 go to (701, 702, 703, 704, 705, +c 'pmif ','circ ','stm ','gtm ','end ', + & 706, 707, 708, 709, 710, +c 'ptm ','iden ','whst ','inv ','tran ', + & 711, 712, 713, 714, 715, +c 'revf ','rev ','mask ','num ','rapt ', + & 716, 717, 718, 719, 720, +c 'eapt ','of ','cf ','wnd ','wnda ', + & 721, 722, 723, 724, 725, +c 'ftm ','wps ','time ','cdf ','bell ', + & 726, 727, 728, 729, 730, +c 'wmrt ','wcl ','paws ','inf ','dims ', + & 731, 732, 733, 734, 735, +c 'zer ','sndwch ','tpol ','dpol ','cbm ', + & 736, 737, 738, 739, 740, +c 'poisson ','preapply','midapply','autoapply','autoconc', + & 741, 742, 743, 744, 745, +c 'rayscale','beam ','units ','autoslic','verbose ', + & 746, 747, 748, 749, 750, +c 'mask6 ','arcreset','symbdef ','particledump','raytrace', + & 751, 752, 753, 754, 755, +c 'autotrack','sckick','moments ','maxsize','reftraj', + & 756, 757, 758, 759, 760, +c 'initenv','envelopes','contractenv','setreftraj','setarclen', + & 761, 762, 763, 764, 765, +c 'wakedefault','emittance','matchenv','fileinfo','egengrad', + & 766, 767, 768, 769, 770, +c 'wrtmap','rdmap','sparec7','sparec8','sparec9'/ + & 771, 772, 773, 774, 775),kt2 + + +c +c 'rt': ray trace +701 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=13. + pmenu(2+mpp(na))=14. + pmenu(3+mpp(na))=5. + pmenu(4+mpp(na))=1. + pmenu(5+mpp(na))=1. + pmenu(6+mpp(na))=0. + cmenu(1+mppc(na))=' ' + cmenu(2+mppc(na))=' ' + endif +c values provided by user: + call getparm(line,mmax,'unit1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'unit2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'order=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'ntrace=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'nwrite=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'ibrief=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + call getparm(line,mmax,'file1=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'file2=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + return +c +c square the existing map: +c +702 continue + return +c +c symplectify matrix in transfer map +c +703 continue + return +c +c input transfer map from an external file: +c +704 continue + return +c +c output transfer map to an external file (tmo): +c +705 continue + return +c +c 'pmif': print contents of file master input file: +706 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. + pmenu(2+mpp(na))=12. + pmenu(3+mpp(na))=3. + cmenu(1+mppc(na))=' ' + endif +c values provided by user: + call getparm(line,mmax,'itype=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'unit=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + return +c +707 continue + return +c +c store the existing transfer map +c +708 continue + return +c +c get transfer map from storage +c +709 continue + return +c +c end of job: +c +710 continue +c defaults: + cmenu(1+mppc(na))='false' !timers= +c values provided by user: + call getparm(line,mmax,'timers=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + return +c +c 'ptm': print transfer map: +711 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=3. + pmenu(2+mpp(na))=3. + pmenu(3+mpp(na))=0. + pmenu(4+mpp(na))=0. + pmenu(5+mpp(na))=1. + endif +c values provided by user: + call getparm(line,mmax,'matrix=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'poly=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'t2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'u3=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'basis=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + return +c +c identity mapping: +c +712 continue + return +c +c write history of beam loss +c +713 continue + return +c +c inverse: +c +714 continue + return +c +c transpose: +c +715 continue + return +c +c reverse factorization: +c +716 continue + return +c +c Dragt's reversal +c +717 continue + return +c +c mask off selected portions of transfer map: +c +718 continue +c defaults: + if(initparms.eq.1)then +c default it to not mask anything: + pmenu(1+mpp(na))=1. !f1 + pmenu(2+mpp(na))=1. !matrix and f2 + pmenu(3+mpp(na))=1. !f3 + pmenu(4+mpp(na))=1. !f4 + pmenu(5+mpp(na))=1. !f5 + pmenu(6+mpp(na))=1. !f6 + endif +c values provided by user: + call getparm(line,mmax,'f1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'f2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'f3=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'f4=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'f5=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'f6=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) +c "matrix=" means the same thing as "f2=" + call getparm(line,mmax,'matrix=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + return +c +c number lines in a file +c +719 continue + return +c +c aperture particle distribution +c +720 continue + return +c +721 continue + return +c +c open files +c +722 continue + return +c +c close files +c +723 continue + return +c +c window particle distribution +c +724 continue + return +725 continue + return +c +c filter transfer map +c +726 continue + return +c +c write parameter set +c +727 continue + return +c +c write time +c +728 continue + return +c +c 'cdf': change output drop file +729 continue +c default: + if(initparms.eq.1)then + pmenu(1+mpp(na))=12. + endif +c values provided by user: + call getparm(line,mmax,'ifile=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + return +c +c ring bell +c +730 continue + return +c +c write value of merit function +c +731 continue + return +c +c write contents of loop +c +732 continue + return +c +c pause (paws) +c +733 continue + return +c +c change or write out infinities (inf) +c +734 continue + return +c +c get dimensions (dims) +c +735 continue + return +c +c change or write out values of zeroes (zer) +c +736 continue + return +c +c sndwch +c +737 continue + return +c +c twiss polynomial (tpol) +c +738 continue + return +c +c dispersion polynomial (dpol) +c +739 continue + return +c +c change or write out beam parameters (cbm) +c +740 continue + return +c +c set parameters for poisson solver +c===================================================================== +c POISSON +c===================================================================== +741 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0. !nx + pmenu(2+mpp(na))=0. !ny + pmenu(3+mpp(na))=0. !nz + pmenu(4+mpp(na))=0. !xmin + pmenu(5+mpp(na))=0. !xmax + pmenu(6+mpp(na))=0. !ymin + pmenu(7+mpp(na))=0. !ymax + pmenu(8+mpp(na))=0. !zmin + pmenu(9+mpp(na))=0. !zmax + pmenu(10+mpp(na))=0. !anag_patchsize + pmenu(11+mpp(na))=0. !anag_refineratio + cmenu(1+mppc(na))='fft' !solver (fft or fft2 or chombo) + cmenu(2+mppc(na))='rectangular' !geometry [not currently used] + cmenu(3+mppc(na))='variable' !gridsize (fixed or variable) + cmenu(4+mppc(na))='fixed' !gridpoints (fixed or variable) + cmenu(5+mppc(na))='open' !xboundary (open, dirichlet, or periodic) + cmenu(6+mppc(na))='open' !yboundary + cmenu(7+mppc(na))='open' !zboundary + cmenu(8+mppc(na))='open' !boundary + cmenu(9+mppc(na))='E' !solving_for (phi, E) + cmenu(10+mppc(na))='delta' !densityfunction (delta or linear) + cmenu(11+mppc(na))='undefined' !chombo_file + cmenu(12+mppc(na))='none' !anag_smooth + cmenu(13+mppc(na))='undefined' !spare_13 + cmenu(14+mppc(na))='undefined' !spare_14 + cmenu(15+mppc(na))='undefined' !spare_15 + cmenu(16+mppc(na))='undefined' !spare_16 + cmenu(17+mppc(na))='undefined' !spare_17 + endif +c values provided by user: +c nx: + call getparm(line,mmax,'nx=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) +c ny: + call getparm(line,mmax,'ny=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) +c nz: + call getparm(line,mmax,'nz=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) +c xmin: + call getparm(line,mmax,'xmin=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) +c xmax: + call getparm(line,mmax,'xmax=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) +c ymin: + call getparm(line,mmax,'ymin=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) +c ymax: + call getparm(line,mmax,'ymax=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) +c zmin: + call getparm(line,mmax,'zmin=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) +c zmax: + call getparm(line,mmax,'zmax=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) +c anag_patchsize: + call getparm(line,mmax,'anag_patchsize=',bufr,keypres,numpres,0 + & ,cbuf) + if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) +c anag_refineratio: + call getparm(line,mmax,'anag_refineratio=',bufr,keypres,numpres,0 + & ,cbuf) + if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) +c solver: + call getparm(line,mmax,'solver=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))=cbuf + endif +c geometry: + call getparm(line,mmax,'geometry=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(2+mppc(na))=cbuf + endif +c gridsize: + call getparm(line,mmax,'gridsize=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(3+mppc(na))=cbuf + endif +c gridpoints: + call getparm(line,mmax,'gridpoints=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(4+mppc(na))=cbuf + endif +c xboundary:: + call getparm(line,mmax,'xboundary=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(5+mppc(na))=cbuf + endif +c yboundary:: + call getparm(line,mmax,'yboundary=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(6+mppc(na))=cbuf + endif +c zboundary:: + call getparm(line,mmax,'zboundary=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(7+mppc(na))=cbuf + endif +c boundary: + call getparm(line,mmax,'boundary=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(8+mppc(na))=cbuf + endif +c solving_for: + call getparm(line,mmax,'solving_for=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(9+mppc(na))=cbuf + endif +c densityfunction: + call getparm(line,mmax,'densityfunction=',bufr,keypres, & + & numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(10+mppc(na))=cbuf + endif +c chombo_file: + call getparm(line,mmax,'chombo_file=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(11+mppc(na))=cbuf + endif +c anag_smooth: + call getparm(line,mmax,'anag_smooth=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(12+mppc(na))=cbuf + endif +c spare_13: + call getparm(line,mmax,'spare_13=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(13+mppc(na))=cbuf + endif +c spare_14: + call getparm(line,mmax,'spare_14=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(14+mppc(na))=cbuf + endif +c spare_15: + call getparm(line,mmax,'spare_15=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(15+mppc(na))=cbuf + endif +c spare_16: + call getparm(line,mmax,'spare_16=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(16+mppc(na))=cbuf + endif +c spare_17: + call getparm(line,mmax,'spare_17=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(17+mppc(na))=cbuf + endif + return +c +c===================================================================== +c PREAPPLY +c===================================================================== +c preapply commands automatically +c +742 continue + if(initparms.eq.1)then + cmenu(1+mppc(na))=' ' + cmenu(2+mppc(na))='physical' !applyto= 'physical' or 'all' elements + endif + call getparm(line,mmax,'name=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'applyto=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(2+mppc(na))=cbuf + endif + return +c +c===================================================================== +c MIDAPPLY +c===================================================================== +c midapply commands automatically +c +743 continue + if(initparms.eq.1)then + cmenu(1+mppc(na))=' ' + cmenu(2+mppc(na))='physical' !applyto= 'physical' or 'all' elements + endif + call getparm(line,mmax,'name=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'applyto=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(2+mppc(na))=cbuf + endif + return +c +c===================================================================== +c AUTOAPPLY +c===================================================================== +c autoapply commands automatically +c +744 continue + if(initparms.eq.1)then + cmenu(1+mppc(na))=' ' + cmenu(2+mppc(na))='physical' !applyto= 'physical' or 'all' elements + endif + call getparm(line,mmax,'name=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'applyto=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(2+mppc(na))=cbuf + endif +c + if(idproc.eq.0 .and. iverbose.ge.1)then + write(6,*)'(routine lmntparm) results from POST-APPLY command:' + write(6,*)'cmenu(1+mppc(na))=',cmenu(1+mppc(na)) + endif + return +c +c autoconc ('auto-concatenate') +c===================================================================== +c AUTOCONC +c===================================================================== +c +745 continue +c default: + if(initparms.eq.1)then + cmenu(1+mppc(na))='true' !set + endif +c + call getparm(line,mmax,'set=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))=cbuf + else + call getparm(line,mmax,'true',bufr,keypres,numpres,1,cbuf) + if(keypres)cmenu(1+mppc(na))='true' + call getparm(line,mmax,'false',bufr,keypres,numpres,1,cbuf) + if(keypres)cmenu(1+mppc(na))='false' + endif + if(idproc.eq.0)then + write(6,*)'(sif) result of autoconc input:' + write(6,*)'set=',cmenu(1+mppc(na)) + endif + return +c +c rayscale ('scale zblock array') +c===================================================================== +c RAYSCALE +c===================================================================== +c +746 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=1.d0 + pmenu(2+mpp(na))=1.d0 + pmenu(3+mpp(na))=1.d0 + pmenu(4+mpp(na))=1.d0 + pmenu(5+mpp(na))=1.d0 + pmenu(6+mpp(na))=1.d0 + endif +c note: this code allows the use of a 'div' option instead of +c a multiplicative factor. However, when the div option is used +c the data are immediately converted to multiplicative factors, +c which is how they are stored in the pmenu array. +c +c values provided by user: +c X: + call getparm(line,mmax,'xmult=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(1+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'xdiv=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(1+mpp(na))=1.d0/bufr(1) + endif +c PX: + call getparm(line,mmax,'pxmult=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'pxdiv=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=1.d0/bufr(1) + endif +c Y: + call getparm(line,mmax,'ymult=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'ydiv=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(3+mpp(na))=1.d0/bufr(1) + endif +c PY: + call getparm(line,mmax,'pymult=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'pydiv=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(4+mpp(na))=1.d0/bufr(1) + endif +c T: + call getparm(line,mmax,'tmult=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(5+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'tdiv=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(5+mpp(na))=1.d0/bufr(1) + endif +c PT: + call getparm(line,mmax,'ptmult=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(6+mpp(na))=bufr(1) + endif + call getparm(line,mmax,'ptdiv=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(6+mpp(na))=1.d0/bufr(1) + endif + return +c +c===================================================================== +c BEAM +c===================================================================== +c beam: set parameters for an ensemble of particles +747 continue +c write(6,*)'******************************here I am at beam' +c defaults: + if(initparms.eq.1)then + maxray=0 +! energy=1.d9 +! pmass=938.27200d6 +! gamma=energy/pmass +! gamm1=gamma-1.d0 +! beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma +! brho=gamma*beta/clite*pmass + energy=0.d0 + pmass=0.d0 + gamma=1.d0 + gamm1=0.d0 + beta=0.d0 + brho=0.d0 + achg=1.d0 + bcurr=0.d0 + bfreq=0.d0 + bomega=twopi*bfreq +! + icompmass=0 +! + pmenu(1+mpp(na))=maxray + pmenu(2+mpp(na))=brho + pmenu(3+mpp(na))=gamma + pmenu(4+mpp(na))=gamm1 + pmenu(5+mpp(na))=beta + pmenu(6+mpp(na))=pmass + pmenu(7+mpp(na))=achg + pmenu(8+mpp(na))=bcurr + pmenu(9+mpp(na))=bfreq + pmenu(10+mpp(na))=bomega + cmenu(1+mppc(na))='proton' + endif +c values provided by user: +c maximum number of particles: + call getparm(line,mmax,'maxray=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + maxray=nint(bufr(1)) + pmenu(1+mpp(na))=maxray +c allocate space for the particle array, etc: + if(.not.allocated(zblock))call new_particledata + endif +c particle: + call getparm(line,mmax,'particle=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))=cbuf + if(cbuf.eq.'proton')then + achg=1.d0 + pmass=938.27231d6 + endif + if(cbuf.eq.'H+')then + achg=1.d0 + pmass=939.29400d6 + endif + if(cbuf.eq.'electron')then + achg=-1.d0 + pmass=0.511d6 + endif + if(cbuf.eq.'positron')then + achg=1.d0 + pmass=0.511d6 + endif + endif +c mass (read in as GeV, same as MAD): + call getparm(line,mmax,'mass=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmass=bufr(1)*1.d9 + pmenu(6+mpp(na))=pmass + endif +c charge: + call getparm(line,mmax,'charge=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + achg=bufr(1) + pmenu(7+mpp(na))=achg + endif +c energy: + call getparm(line,mmax,'energy=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + energy=bufr(1)*1.d9 + if(pmass.ne.0.d0)then + gamma=energy/pmass + gamm1=gamma-1.d0 + beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma + brho=gamma*beta/clite*pmass + pc=sqrt(energy**2-pmass**2) + ekinetic=energy-pmass + endif + endif +c pc: + call getparm(line,mmax,'pc=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pc=bufr(1)*1.d9 + if(pmass.ne.0.d0)then + energy=sqrt(pc**2+pmass**2) + gamma=energy/pmass + gamm1=gamma-1.d0 + beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma + brho=gamma*beta/clite*pmass + ekinetic=energy-pmass + endif + endif +c gamma: + call getparm(line,mmax,'gamma=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + gamma=bufr(1) + gamm1=gamma-1.d0 + beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma + if(pmass.ne.0.d0)then + brho=gamma*beta/clite*pmass + energy=gamma*pmass + pc=sqrt(energy**2-pmass**2) + ekinetic=energy-pmass + endif + endif +c gamma-1: + call getparm(line,mmax,'gamma1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + gamm1=bufr(1) + gamma=gamm1+1.d0 + beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma + if(pmass.ne.0.d0)then + brho=gamma*beta/clite*pmass + energy=gamma*pmass + pc=sqrt(energy**2-pmass**2) + ekinetic=energy-pmass + endif + endif +c ekinetic: + call getparm(line,mmax,'ekinetic=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + ekinetic=bufr(1)*1.d9 + if(pmass.ne.0.d0)then + gamm1=ekinetic/pmass + gamma= gamm1+1.d0 + beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma + brho=gamma*beta/clite*pmass + energy=ekinetic+pmass + pc=sqrt(energy**2-pmass**2) + endif + endif +c brho: + call getparm(line,mmax,'brho=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + brho=bufr(1) + if(gamma.ne.1.d0 .and. beta.ne.0.d0)then + pmass=brho/(gamma*beta/clite) + icompmass=1 +! if(idproc.eq.0)then +! write(6,*)'computed pmass (from brho,gamma,beta) = ',pmass +! endif + energy=gamma*pmass + pc=sqrt(energy**2-pmass**2) + ekinetic=energy-pmass + endif + endif +c store brho,gamma,gamm1,beta in pmenu + pmenu(2+mpp(na))=brho + pmenu(3+mpp(na))=gamma + pmenu(4+mpp(na))=gamm1 + pmenu(5+mpp(na))=beta +c beam current: + call getparm(line,mmax,'bcurr=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + bcurr=bufr(1) + pmenu(8+mpp(na))=bcurr + endif +c beam frequency: + call getparm(line,mmax,'bfreq=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + bfreq=bufr(1) + pmenu(9+mpp(na))=bfreq + bomega=twopi*bfreq + endif +c beam angular frequency: + call getparm(line,mmax,'bomega=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + bomega=bufr(1) + pmenu(10+mpp(na))=bomega + bfreq=bomega/twopi + endif +c print results: + if(idproc.eq.0)then + write(6,*)' ' + write(6,*)'done reading BEAM parameters:' + write(6,'(1x,''brho='',1pd23.16)')brho + write(6, & + &'(1x,''gamma, gamma-1='',1pd23.16,2x,1pd23.16)')gamma,gamm1 + write(6,'(1x,''beta='',1pd23.16)')beta + write(6, & + &'(1x,''energy, ekinetic='',1pe18.11,2x,1pe18.11)')energy,ekinetic + write(6,'(1x,''pc='',1pe18.11)')pc + write(6,'(1x,''mass, charge='',1pe18.11,2x,1pe18.11)')pmass,achg + write(6,'(1x,''beam current='',1pe18.11)')bcurr + write(6,'(1x,''beam frequency='',1pe18.11)')bfreq +c write(6,*)'beam angular freq=',bomega +c write(6,*)'array size=',maxray +c write(6,*)'symbol(1)=',cmenu(1+mppc(na)) +! write(6,*)' ' + if(bcurr.ne.0.d0 .and. bfreq.eq.0.d0)then + write(6,*)'**********************WARNING************************' + write(6,*) & + &'Beam current has been specfied, but the beam rf frequency that' + write(6,*) & + &'defines the total bunch charge, Q=I/freq, has not been specified' + write(6,*)'*****************************************************' + endif +! write(6,*)' ' + endif +cryne 09/20/02 + constr(nconst+1)='brho' + conval(nconst+1)=brho + constr(nconst+2)='gamma' + conval(nconst+2)=gamma + constr(nconst+3)='charge' + conval(nconst+3)=charge + constr(nconst+4)='mass' + conval(nconst+4)=pmass + constr(nconst+5)='beta' + conval(nconst+5)=beta + constr(nconst+6)='energy' + conval(nconst+6)=energy + constr(nconst+7)='ekinetic' + conval(nconst+7)=ekinetic + constr(nconst+8)='pc' + conval(nconst+8)=pc + nconst=nconst+8 +cryne +c--------- +c also set the default units in case the user forgets to use the +c units command later: +!Jan23, 2003 sl=1.d0 +!Jan23, 2003 ts=sl/clite +!Jan23, 2003 omegascl=1.d0/ts +!Jan23, 2003 p0sc=pc +c other stuff: +!Jan23, 2003 magunits=1 +!Jan23, 2003 iverbose=0 +!jan 23, 2003 set p0sc if it has not been set by the user already: +!jan 24, 2003 if(p0sc.eq.0.d0)p0sc=pc +!!!!! if(p0sc.eq.0.d0)p0sc=pc/clite +!!!!! if(idproc.eq.0)write(6,*)'p0sc=pc/clite=',p0sc +!!!!! if(idproc.eq.0)write(6,*)'note also that pc=',pc +! if(idproc.eq.0 )then +! write(6,*)'default scaling variables follow. (Note:' +! write(6,*)'default scaling can be changed using the units command)' +! write(6,*)'scale length, sl=',sl +! write(6,*)'scale time, ts=',ts +! write(6,*)'scale omega, omegascl=',omegascl +! write(6,*)'scale momentum, p0sc=',pc +! write(6,*)'end of reporting of data for BEAM command' +! endif +c--------- +c this does not make sense if the default value for maxray is zero, +c so I have commented it out. +c allocate space for the particle array, etc: +c if(.not.allocated(zblock))call new_particledata +c +cryne March 18, 2004 +c store ref particle data in the default location (location #1) +c in case the user wants to do multiple runs from the same initial values: +c [note: initial reftraj data, refsave(1:6), is set/stored in subroutine tran] + brhosav(1)=brho + gamsav(1)=gamma + gam1sav(1)=gamm1 + betasav(1)=beta + +! Global defautls for wakefields + call readin(line,leof) + if(line(1:9) .ne. 'wakedflt:')then +!cryne write(6,*)'\nWakefield global defaults are not specified' +!cryne write(6,*)'You may specify wakefield global defaults' +!cryne write(6,*)'in the following format' +!cryne write(6,*)'wakedflt: type= nturns= nmodes= r= conduct= ' +!cryne write(6,*)'nx= ny= nz= ndx= ndy= \n' + backspace lf + else + call wake_defaults(line) + endif + + return +c +c +c===================================================================== +c UNITS +c===================================================================== +c units: set scaling variables +748 continue +c defaults: +!Jan23, 2003: now these are set in routine dumpin +!Jan23, 2003 sl=1.d0 +!Jan23, 2003 ts=sl/clite +!Jan23, 2003 omegascl=1.d0/ts +!Jan23, 2003 p0sc=pc + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !scale length + pmenu(2+mpp(na))=0.d0 !scale momentum + pmenu(3+mpp(na))=0.d0 !scale time (sec) + pmenu(4+mpp(na))=0.d0 !scale ang freq (rad/sec) + pmenu(5+mpp(na))=0.d0 !scale freq (Hz) + cmenu(1+mppc(na))=' ' + cmenu(2+mppc(na))=' ' + endif + lflagmagu=.true. + lflagdynu=.false. + itscaleset=0 + ilscaleset=0 + if(idproc.eq.0)then + write(6,*)' ' + write(6,*)'reading UNITS parameters' + endif +c values provided by user: +c type (magnetic, static, or general): + call getparm(line,mmax,'type=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + if( (cbuf.eq.'magnetic') .or. (cbuf.eq.'static') )then + p0sc=gamma*beta*pmass/clite + pmenu(2+mpp(na))=p0sc + cmenu(1+mppc(na))='static' + cmenu(2+mppc(na))='p0' + lflagmagu=.true. + lflagdynu=.false. + if(idproc.eq.0)then + write(6,*)'STATIC UNITS WILL BE USED. p0sc=',p0sc + endif + elseif(cbuf.eq.'dynamic')then + p0sc=pmass/clite + pmenu(2+mpp(na))=p0sc + cmenu(1+mppc(na))='dynamic' + cmenu(2+mppc(na))='mc' + lflagmagu=.false. + lflagdynu=.true. + if(idproc.eq.0)then + write(6,*)'DYNAMIC UNITS WILL BE USED. p0sc=',p0sc + endif + else + cmenu(1+mppc(na))='general' + cmenu(2+mppc(na))='none' + lflagmagu=.false. + lflagdynu=.false. + if(idproc.eq.0)write(6,*)'GENERAL UNITS WILL BE USED.' + endif + endif +! +! momentum: + if(cmenu(1+mppc(na)).ne.'static' .and. & + & cmenu(1+mppc(na)).ne.'magnetic' .and. & + & cmenu(1+mppc(na)).ne.'dynamic')then + call getparm(line,mmax,'p=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + p0sc=bufr(1) + endif + call getparm(line,mmax,'psymbolic=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(2+mppc(na))=cbuf + if(trim(cbuf).eq.'p0')then + pmenu(2+mpp(na))=pc + p0sc=pc + endif + if(trim(cbuf).eq.'mc')then + pmenu(2+mpp(na))=pmass/clite + p0sc=pmass/clite + endif + endif + if(pmenu(2+mpp(na)).eq.0.d0)then + if(idproc.eq.0)then + write(6,*)'ERROR: general units are being used but the' + write(6,*)'scale momentum has not been specified; halting' + call myexit + endif + endif + endif + +! length: + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(1+mpp(na))=bufr(1) + sl=bufr(1) + ilscaleset=1 + else + if(idproc.eq.0)then + write(6,*)'WARNING: scale length has not been specified' + endif + endif +! time: + call getparm(line,mmax,'w=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + omegascl=bufr(1) + ts=1.d0/omegascl + freqscl=omegascl/twopi + itscaleset=1 + endif + call getparm(line,mmax,'f=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + freqscl=bufr(1) + omegascl=twopi*freqscl + ts=1.d0/omegascl + itscaleset=1 + endif + call getparm(line,mmax,'t=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + ts=bufr(1) + omegascl=1.d0/ts + freqscl=omegascl/twopi + itscaleset=1 + endif + if(itscaleset.eq.0)then + if(idproc.eq.0)then + write(6,*)'WARNING: scale time has not been specified' + endif + endif +! choose some sensible defaults for data that have not been provided: + if(itscaleset.eq.0 .and. ilscaleset.eq.0)then +! if(idproc.eq.0)then +! write(6,*)'neither the scale length nor the scale time have ', & +! & 'been specified' +! endif +! static/magnetic: + if(bfreq.eq.0.d0)then + if(idproc.eq.0)write(6,*)'setting sl=1, omega=clite/sl' + sl=1.d0 + omegascl=clite/sl + ts=1.d0/omegascl + freqscl=omegascl/twopi + endif +! dynamic: + if(bfreq.ne.0.d0)then + if(idproc.eq.0)then + write(6,*)'setting scalefreq=beamfreq, l=c/omega' + endif + freqscl=bfreq + omegascl=twopi*freqscl + ts=1.d0/omegascl + sl=clite/omegascl + endif + elseif(ilscaleset.eq.0)then + if(idproc.eq.0)then + write(6,*)'The scale length has not been specified' + write(6,*)'Setting sl=clite/omega=',clite/omegascl + endif + sl=clite/omegascl + elseif(itscaleset.eq.0)then + if(idproc.eq.0)then + write(6,*)'The scale time has not been specified' + write(6,*)'Setting omegascl=clite/sl=',clite/sl + endif + omegascl=clite/sl + ts=1.d0/omegascl + freqscl=omegascl/twopi + endif +! +c print results: + if(idproc.eq.0)then + write(6,*)'done reading UNITS parameters:' + write(6,'(1x,''scale length (m) ='',1pe18.11)')sl + write(6,'(1x,''scale momentum ='',1pe18.11)')p0sc + write(6,'(1x,''scale time (sec)='',1pe18.11)')ts + write(6,'(1x,''scale freq (Hz)='',1pe18.11)')freqscl + write(6,'(1x,''scale angular freq (rad/sec)='',1pe18.11)')omegascl +! write(6,*)'symbol(1)=',cmenu(1+mppc(na)) +! write(6,*)'symbol(2)=',cmenu(2+mppc(na)) + write(6,*)' ' + endif + return +c +c===================================================================== +c AUTOSLICE +c===================================================================== +c autoslice +c +749 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !slices=N + pmenu(2+mpp(na))=0.d0 !l= + cmenu(1+mppc(na))='local' !control="local", "global", or "none" + cmenu(2+mppc(na))='false' !sckick="true" or "false"; determines +c !if a space charge kick will be performed +c !automatically in the middle of each slice + cmenu(3+mppc(na))='false' !includemlstyle="true" or "false" + endif +c values provided by user: +!slices: + call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(1+mpp(na))=bufr(1) + endif +!l (interval between slices): + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(2+mpp(na))=bufr(1) + endif +!control: + localcontrol=0 + call getparm(line,mmax,'control=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))=cbuf + if(cbuf.eq.'local')localcontrol=1 + endif +!sckick: + call getparm(line,mmax,'sckick=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(2+mppc(na))=cbuf + endif +!includemlstyle: + inclmlstyle=0 + call getparm(line,mmax,'includemlstyle=',bufr,keypres,numpres, & + & 1,cbuf) + if(keypres.and.numpres)then + cmenu(3+mppc(na))=cbuf + if(cbuf.eq.'true')inclmlstyle=1 + endif +! +! Dec 3, 2002: +! Augment parameter lists for old-style MaryLie input to include # of slices. +! Note that includemlstyle appears to be no longer needed; instead I just +! force it to be enabled if the user specifies local control. +! However, I have left the code in place in case it is needed later. + if(localcontrol.eq.1 .or. inclmlstyle.eq.1)call sliceml +! +! if(idproc.eq.0)then +! write(6,*)'(routine lmntparm) results from AUTOSLICE command:' +! write(6,*)'slices=',pmenu(1+mpp(na)),'l=',pmenu(2+mpp(na)) +! write(6,*)'control=',cmenu(1+mppc(na)) +!!!!!!write(6,*)'sckick=',cmenu(2+mppc(na)) +! endif + return +c +c===================================================================== +c VERBOSE +c===================================================================== +c autoslice +c +750 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 + endif +c values provided by user: + call getparm(line,mmax,'iverbose=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pmenu(1+mpp(na))=bufr(1) + iverbose=nint(bufr(1)) + endif + if(idproc.eq.0 .and. iverbose.ge.1)then + write(6,*)'(routine lmntparm) results from VERBOSE command:' + write(6,*)'iverbose=',iverbose + endif + return +c +c mask6: +cryne 12/31/2004 mask6 now appears to be unecessary. +751 continue + return +c +c arcreset +752 continue + return +c +c symbdef +753 continue + isymbdef=1 + if(idproc.eq.0)then + write(6,*)'SYMBDEF: from now on symbolic names that appear in' + write(6,*)'arithmetic expressions will have default value 0' + endif + return +c +c===================================================================== +c PARTICLEDUMP +c===================================================================== +c particledump: +754 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !min= : ... + pmenu(2+mpp(na))=0.d0 !max= : to print particles # min to max + pmenu(3+mpp(na))=0.d0 !sequencelength (=max # of files in sequence) + pmenu(4+mpp(na))=5.d0 !precision + pmenu(5+mpp(na))=0.d0 !assigned unit# for output file (or can be read in) + pmenu(6+mpp(na))=0.d0 !assigned counter for sequence of files + pmenu(7+mpp(na))=1.d0 !nunits (=0 for dimensionless; =1 for physical) + cmenu(1+mppc(na))=' ' !file= : name of output file + cmenu(2+mppc(na))='true' !close= : flag to close output file + cmenu(3+mppc(na))='false' !flush= : flag to flush output file + cmenu(4+mppc(na))='false' !printarc=:flag to print arc length in column 1 + endif +c values provided by user: + call getparm(line,mmax,'min=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'max=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'sequencelength=',bufr,keypres,numpres, & + & 0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'unit=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) + call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'close=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(3+mppc(na))=cbuf + endif + call getparm(line,mmax,'printarc=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(4+mppc(na))=cbuf + endif +! if(idproc.eq.0)then +! write(6,*)'(lmntparm) results from PARTICEDUMP sif input:' +! write(6,*)'min=',pmenu(1+mpp(na)) +! write(6,*)'max=',pmenu(2+mpp(na)) +! write(6,*)'sequencelength=',pmenu(3+mpp(na)) +! write(6,*)'precision=',pmenu(4+mpp(na)) +! write(6,*)'unit=',pmenu(5+mpp(na)) +! write(6,*)'sequence counter=',pmenu(6+mpp(na)) +! write(6,*)'file=',cmenu(1+mppc(na)) +! write(6,*)'close=',cmenu(2+mppc(na)) +! write(6,*)'flush=',cmenu(3+mppc(na)) +! endif + return +c +c +c===================================================================== +c RAYTRACE +c===================================================================== +c raytrace: +755 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !min= : ... + pmenu(2+mpp(na))=0.d0 !max= : to print particles # min to max + pmenu(3+mpp(na))=5. !norder + pmenu(4+mpp(na))=1. !ntrace + pmenu(5+mpp(na))=1. !nwrite + pmenu(6+mpp(na))=0. !ibrief + pmenu(7+mpp(na))=0. !sequencelength (=max # of files in sequence) + pmenu(8+mpp(na))=6. !precision + pmenu(9+mpp(na))=0. !assigned unit# for initial condition file + pmenu(10+mpp(na))=0. !assigned unit# for final condition file + pmenu(11+mpp(na))=0.d0 !assigned counter for sequence of files + pmenu(12+mpp(na))=0.d0 !nrays=# to read when reading from data file + cmenu(1+mppc(na))=' ' !name of initial condition file + cmenu(2+mppc(na))=' ' !name of final condition file + cmenu(3+mppc(na))='false' !flag to close final condition file + cmenu(4+mppc(na))='false' !flag to flush final condition file + cmenu(5+mppc(na))='undefined' !alternate way to specify track type&order + endif +c values provided by user: + call getparm(line,mmax,'min=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'max=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'order=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'ibrief=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + call getparm(line,mmax,'sequencelength=',bufr,keypres,numpres,0, & + & cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) + call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) + call getparm(line,mmax,'unit1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) + call getparm(line,mmax,'unit2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) + call getparm(line,mmax,'nrays=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) +c + call getparm(line,mmax,'file1=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'file2=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + call getparm(line,mmax,'close=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(3+mppc(na))=cbuf + endif + call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(4+mppc(na))=cbuf + endif +c type: + call getparm(line,mmax,'type=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(5+mppc(na))=cbuf + if(cbuf.eq.'readonly')then +c change defaults: + pmenu(4+mpp(na))=0. !ntrace + pmenu(5+mpp(na))=0. !nwrite + endif + endif +c ntrace, nwrite: + call getparm(line,mmax,'ntrace=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'nwrite=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + return +c +c +c===================================================================== +c AUTOTRACK +c===================================================================== +c autotrack +756 continue +c defaults: + if(initparms.eq.1)then + cmenu(1+mppc(na))='true' !set + cmenu(2+mppc(na))='undefined' !type (taylorN, symplecticN, undefined) + cmenu(3+mppc(na))='undefined' !sckick (true,false) + cmenu(4+mppc(na))='false' !env (true,false) + endif +c set: + call getparm(line,mmax,'set=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))=cbuf + else + call getparm(line,mmax,'true',bufr,keypres,numpres,1,cbuf) + if(keypres)cmenu(1+mppc(na))='true' + call getparm(line,mmax,'false',bufr,keypres,numpres,1,cbuf) + if(keypres)cmenu(1+mppc(na))='false' + endif +c type: + call getparm(line,mmax,'type=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(2+mppc(na))=cbuf + endif +c sckick: + call getparm(line,mmax,'sckick=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(3+mppc(na))=cbuf + endif +c env: + call getparm(line,mmax,'env=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(4+mppc(na))=cbuf + endif +c +c if(idproc.eq.0)then +c write(6,*)'(sif) results of autotrack input:' +c write(6,*)'set= ',cmenu(1+mppc(na)) +c write(6,*)'type= ',cmenu(2+mppc(na)) +c write(6,*)'sckick= ',cmenu(3+mppc(na)) +c write(6,*)'env= ',cmenu(4+mppc(na)) +c endif + return +c +c===================================================================== +c SCKICK +c===================================================================== +c sckick +757 continue + return +c +c===================================================================== +c MOMENTS +c===================================================================== +c moments: +758 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !assigned unit# for xfile + pmenu(2+mpp(na))=0.d0 !assigned unit# for yfile + pmenu(3+mpp(na))=0.d0 !assigned unit# for tfile + pmenu(4+mpp(na))=5.d0 !precision + pmenu(5+mpp(na))=1.d0 !nunits (=0 for dimensionless; =1 for physical) + cmenu(1+mppc(na))='xrms.out' !name of xfile + cmenu(2+mppc(na))='yrms.out' !name of yfile + cmenu(3+mppc(na))='trms.out' !name of tfile + cmenu(4+mppc(na))='true' !flag to flush xfile + cmenu(5+mppc(na))='true' !flag to flush yfile + cmenu(6+mppc(na))='true' !flag to flush tfile + cmenu(7+mppc(na))='ratio' !crossterm [ or /(xrms*pxrms)] + cmenu(8+mppc(na))='false' !set to true to divide emittances by pi + cmenu(9+mppc(na))='keep' !flag to keep/remove beam centroid + endif +c values provided by user: + call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) +c + call getparm(line,mmax,'xfile=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'yfile=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + call getparm(line,mmax,'tfile=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(3+mppc(na))=cbuf + endif + call getparm(line,mmax,'xflush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(4+mppc(na))=cbuf + endif + call getparm(line,mmax,'yflush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(5+mppc(na))=cbuf + endif + call getparm(line,mmax,'tflush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(6+mppc(na))=cbuf + endif + call getparm(line,mmax,'crossterm=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(7+mppc(na))=cbuf + endif + call getparm(line,mmax,'includepi=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(8+mppc(na))=cbuf + endif + call getparm(line,mmax,'centroid=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(9+mppc(na))=cbuf + endif + return +c +c +c +c===================================================================== +c MAXSIZE +c===================================================================== +c maxsize: +759 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !assigned unit# for output file 1 + pmenu(2+mpp(na))=0.d0 !assigned unit# for output file 2 + pmenu(3+mpp(na))=0.d0 !assigned unit# for output file 3 + pmenu(4+mpp(na))=0.d0 !assigned unit# for output file 4 + pmenu(5+mpp(na))=5.d0 !precision + pmenu(6+mpp(na))=1.d0 !nunits (=0 for dimensionless; !=0 for physical) + cmenu(1+mppc(na))=' ' !name of output file 1 + cmenu(2+mppc(na))=' ' !name of output file 2 + cmenu(3+mppc(na))=' ' !name of output file 3 + cmenu(4+mppc(na))=' ' !name of output file 4 + cmenu(5+mppc(na))='true' !flag to flush output file 1 + cmenu(6+mppc(na))='true' !flag to flush output file 2 + cmenu(7+mppc(na))='true' !flag to flush output file 3 + cmenu(8+mppc(na))='true' !flag to flush output file 4 + cmenu(9+mppc(na))='automatic' !flag to use 'standard' file names + endif +c values provided by user: + call getparm(line,mmax,'unit1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'unit2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'unit3=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'unit4=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) +c + call getparm(line,mmax,'file1=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'file2=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + call getparm(line,mmax,'file3=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(3+mppc(na))=cbuf + endif + call getparm(line,mmax,'file4=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(4+mppc(na))=cbuf + endif + call getparm(line,mmax,'flush1=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(5+mppc(na))=cbuf + endif + call getparm(line,mmax,'flush2=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(6+mppc(na))=cbuf + endif + call getparm(line,mmax,'flush3=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(7+mppc(na))=cbuf + endif + call getparm(line,mmax,'flush4=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(8+mppc(na))=cbuf + endif + call getparm(line,mmax,'files=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(9+mppc(na))=cbuf + endif + return +c +c===================================================================== +c REFTRAJ +c===================================================================== +c reftraj: +760 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !assigned unit# for output file + pmenu(2+mpp(na))=5.d0 !precision + pmenu(3+mpp(na))=1.d0 !nunits (=0 for dimensionless; !=0 for physical) + cmenu(1+mppc(na))='reftraj.out' !name of output file + cmenu(2+mppc(na))='true' !flag to flush output file + endif +c values provided by user: + call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) +c + call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + return +c===================================================================== +c INITENV +c===================================================================== +c initenv (initialize rms envelopes): +761 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 ! x= + pmenu(2+mpp(na))=0.d0 ! px= + pmenu(3+mpp(na))=0.d0 ! xpx= + pmenu(4+mpp(na))=0.d0 ! xemit= + pmenu(5+mpp(na))=0.d0 ! y= + pmenu(6+mpp(na))=0.d0 ! py= + pmenu(7+mpp(na))=0.d0 ! ypy= + pmenu(8+mpp(na))=0.d0 ! yemit= + pmenu(9+mpp(na))=0.d0 ! t= + pmenu(10+mpp(na))=0.d0 ! pt= + pmenu(11+mpp(na))=0.d0 ! tpt= + pmenu(12+mpp(na))=0.d0 ! temit= + pmenu(13+mpp(na))=0.d0 ! cpx= + pmenu(14+mpp(na))=0.d0 ! cpy= + pmenu(15+mpp(na))=0.d0 ! cpt= + cmenu(1+mppc(na))='ratio' !crossterm [ or /(xrms*pxrms)] + endif +c values provided by user: + call getparm(line,mmax,'x=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'px=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'xpx=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'xemit=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'y=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'py=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + call getparm(line,mmax,'ypy=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) + call getparm(line,mmax,'yemit=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) + call getparm(line,mmax,'t=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) + call getparm(line,mmax,'pt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) + call getparm(line,mmax,'tpt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) + call getparm(line,mmax,'temit=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) + call getparm(line,mmax,'cpx=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(13+mpp(na))=bufr(1) + call getparm(line,mmax,'cpy=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(14+mpp(na))=bufr(1) + call getparm(line,mmax,'cpt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(15+mpp(na))=bufr(1) + call getparm(line,mmax,'crossterm=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + return +c +c===================================================================== +c ENVELOPES +c===================================================================== +c envelopes: +762 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !assigned unit# for xfile + pmenu(2+mpp(na))=0.d0 !assigned unit# for yfile + pmenu(3+mpp(na))=0.d0 !assigned unit# for tfile + pmenu(4+mpp(na))=5.d0 !precision + pmenu(5+mpp(na))=1.d0 !nunits (=0 for dimensionless; =1 for physical) + cmenu(1+mppc(na))='xenv.out' !name of xfile + cmenu(2+mppc(na))='yenv.out' !name of yfile + cmenu(3+mppc(na))='tenv.out' !name of tfile + cmenu(4+mppc(na))='true' !flag to flush xfile + cmenu(5+mppc(na))='true' !flag to flush yfile + cmenu(6+mppc(na))='true' !flag to flush tfile + cmenu(7+mppc(na))='ratio' !crossterm [ or /(xrms*pxrms)] + endif +c values provided by user: + call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) +c + call getparm(line,mmax,'xfile=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'yfile=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + call getparm(line,mmax,'tfile=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(3+mppc(na))=cbuf + endif + call getparm(line,mmax,'xflush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(4+mppc(na))=cbuf + endif + call getparm(line,mmax,'yflush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(5+mppc(na))=cbuf + endif + call getparm(line,mmax,'tflush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(6+mppc(na))=cbuf + endif + call getparm(line,mmax,'crossterm=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(7+mppc(na))=cbuf + endif + return +c +c===================================================================== +c CONTRACTENV +c===================================================================== +c contractenv (apply contraction map to rms envelopes): +763 continue + return +c +c===================================================================== +c SETREFTRAJ +c===================================================================== +764 continue + if(initparms.eq.1)then + pmenu(1+mpp(na)) =0.d0 ! x= + pmenu(2+mpp(na)) =0.d0 ! px= + pmenu(3+mpp(na)) =0.d0 ! y= + pmenu(4+mpp(na)) =0.d0 ! py= + pmenu(5+mpp(na)) =0.d0 ! t= + pmenu(6+mpp(na)) =0.d0 ! pt= + pmenu(7+mpp(na)) =-9999.d0 ! s= + pmenu(8+mpp(na)) =0.d0 ! sto= + pmenu(9+mpp(na)) =0.d0 ! get= + pmenu(10+mpp(na))=0.d0 ! write= + cmenu(1+mppc(na))='false' !restart= true/false +! resets to values +! stored in loc 1, which contain values from +! start of run (unless overwritten by user)] + cmenu(2+mppc(na))='true' !includearc=true/false [used w/ sto,get] + endif +c values provided by user: + call getparm(line,mmax,'x=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'px=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'y=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'py=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'t=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'pt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + call getparm(line,mmax,'arclen=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) +c sto: + call getparm(line,mmax,'sto=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) + if(bufr(1).le.0 .or. bufr(1).ge.9)then + if(idproc.eq.0)then + write(6,*)'setreftraj error: sto must be in (1,...,8)' + endif + call myexit + endif +c get: + call getparm(line,mmax,'get=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) + if(bufr(1).le.0 .or. bufr(1).ge.9)then + if(idproc.eq.0)then + write(6,*)'setreftraj error: get must be in (1,...,8)' + endif + call myexit + endif +c + call getparm(line,mmax,'write=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) +c + call getparm(line,mmax,'restart=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'includearc=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + return +c +c===================================================================== +c SETARCLEN +c===================================================================== +765 continue + if(initparms.eq.1)then + pmenu(1+mpp(na)) =0.d0 ! s= + pmenu(2+mpp(na))=0.d0 ! write= + cmenu(1+mppc(na))='false' !restart= true/false + endif +c values provided by user: + call getparm(line,mmax,'s=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'write=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) +c + call getparm(line,mmax,'restart=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + return +c +c===================================================================== +c WAKEDEFAULT +c===================================================================== +766 continue + if(idproc.eq.0)then + write(6,*)'CODE UNDER DEVELOPMENT. POSSIBLY PUT WAKEDEFAULT HERE' + endif + return +c +c===================================================================== +c EMITTANCE +c===================================================================== +c emittance: +767 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !assigned unit# for file + pmenu(2+mpp(na))=5.d0 !precision + pmenu(3+mpp(na))=1.d0 !nunits (=0 for dimensionless; =1 for physical) + cmenu(1+mppc(na))='true' !flag to compute 2-D emittances + cmenu(2+mppc(na))='true' !flag to compute 4-D transverse emittance + cmenu(3+mppc(na))='false' !flag to compute 6-D emittance + cmenu(4+mppc(na))='keep' !flag to keep/remove beam centroid + cmenu(5+mppc(na))='emitrms.out' !name of output file + cmenu(6+mppc(na))='true' !flag to flush output file + endif +c values provided by user: + call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) +c + call getparm(line,mmax,'2d=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'4d=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + call getparm(line,mmax,'6d=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(3+mppc(na))=cbuf + endif + call getparm(line,mmax,'centroid=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(4+mppc(na))=cbuf + endif + call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(5+mppc(na))=cbuf + endif + call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(6+mppc(na))=cbuf + endif + return +c +c===================================================================== +c MATCHENV +c===================================================================== +768 continue + if(initparms.eq.1)then + pmenu(1+mpp(na)) =10.d0 ! iterations= + pmenu(2+mpp(na)) =1.d-8 ! tolerance= + cmenu(1+mppc(na))=' ' ! name= + endif + call getparm(line,mmax,'iterations=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'tolerance=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'name=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + cmenu(1+mppc(na))=cbuf + endif + return +c +c===================================================================== +c FILEINFO +c (controls printing of file open/close info) +c===================================================================== +769 continue + if(initparms.eq.1)then + pmenu(1+mpp(na)) =0. ! info= + endif + call getparm(line,mmax,'info=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + return +c +c===================================================================== +c EGENGRAD +c===================================================================== +c egengrad: +770 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=0.d0 !assigned unit# for output file + pmenu(2+mpp(na))=0.d0 !zstart + pmenu(3+mpp(na))=0.d0 !zend + pmenu(4+mpp(na))=1.d0 !nz (intervals) + pmenu(5+mpp(na))=0.d0 !frequency + pmenu(6+mpp(na))=0.d0 !radius + pmenu(7+mpp(na))=3.d2 !kmax + pmenu(8+mpp(na))=3.d3 !nk (intervals) + pmenu(9+mpp(na))=0.d0 !infiles + pmenu(10+mpp(na))=5.d0 !precision + cmenu(1+mppc(na))='rfdata' ! name of input datafile + cmenu(2+mppc(na))='crz.dat' ! name of output datafile + cmenu(3+mppc(na))='true' ! flag to flush output file(s) + cmenu(4+mppc(na))='e0.dat' ! name of optional output datafile + cmenu(5+mppc(na))='false' ! flag to (not) write char. fns. + cmenu(6+mppc(na))='t7' ! E-field file type + cmenu(7+mppc(na))=' ' ! name of optional E-field diagnos. + endif +c values provided by user: +cp2 + call getparm(line,mmax,'zstart=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) +cp3 + call getparm(line,mmax,'zend=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) +cp4 + call getparm(line,mmax,'nz=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) +cp5 + call getparm(line,mmax,'frequency=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) +cp6 + call getparm(line,mmax,'radius=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) +cp7 + call getparm(line,mmax,'kmax=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) +cp8 + call getparm(line,mmax,'nk=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) +cp9 + call getparm(line,mmax,'infiles=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) +cp10 + call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) +cc1 + call getparm(line,mmax,'efile=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif +cc2 + call getparm(line,mmax,'crzfile=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif +cc3 + call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(3+mppc(na))=cbuf + endif +cc4 + call getparm(line,mmax,'charfile=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(4+mppc(na))=cbuf + endif +cc5 + call getparm(line,mmax,'wrtchar=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(5+mppc(na))=cbuf + endif +cc6 + call getparm(line,mmax,'ftype=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(6+mppc(na))=cbuf + endif +cc7 + call getparm(line,mmax,'ediag=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(7+mppc(na))=cbuf + endif + return +c +c===================================================================== +c WRTMAP: Write Map to File (KMP: 8 Nov 2006) +c===================================================================== +c +771 continue +c +c Initialized Parameters to default values (in case they are not specified): + if(initparms.eq.1)then + cmenu(1+mppc(na))='map.dat' ! name of file for map write + cmenu(2+mppc(na))='lastslice' ! kind of write: accumulated, lastslice + cmenu(3+mppc(na))='append' ! iostatus of write to file: overwrite, append + endif +c +c Get file name for map write: + call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif +c +c Get kind of write to perform: + call getparm(line,mmax,'kind=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif +c +c Get iostatus of write: + call getparm(line,mmax,'iostat=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(3+mppc(na))=cbuf + endif + return +c +c===================================================================== +c RDMAP: Read a Map from File (KMP: 14 Dec 2006) +c===================================================================== +c +772 continue +c +c Initialized Parameters to default values (in case they are not specified): + if(initparms.eq.1)then + cmenu(1+mppc(na))='map.dat' ! name of file for map read + cmenu(2+mppc(na))='true' ! name of file for map read + endif +c +c Get file name for map write: + call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif +c +c Get rewind information + call getparm(line,mmax,'rewind=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + return + +c===================================================================== +c SPARES TYPE CODES +c===================================================================== + +773 continue +774 continue +775 continue + return +c +c +c 8: advanced commands ******************************** +c +c 'cod ','amap ','dia ','dnor ','exp ', +18 go to (801, 802, 803, 804, 805, +c 'pdnf ','psnf ','radm ','rasm ','sia ', + & 806, 807, 808, 809, 810, +c 'snor ','tadm ','tasm ','tbas ','gbuf ', + & 811, 812, 813, 814, 815, +c 'trsa ','trda ','smul ','padd ','pmul ', + & 816, 817, 818, 819, 820, +c 'pb ','pold ','pval ','fasm ','fadm ', + & 821, 822, 823, 824, 825, +c 'sq ','wsq ','ctr ','asni ','pnlp ', + & 826, 827, 828, 829, 830, +c 'csym ','psp ','mn ','bgen ','tic ', + & 831, 832, 833, 834, 835, +c 'ppa ','moma ','geom ','fwa '/ + & 836, 837, 838, 839),kt2 +c +c off-momentum closed orbit analysis +c +801 continue + return +c +c apply map to a function or moments +c +802 continue + return +c +c dynamic invariant analysis +c +803 continue + return +c +c dynamic normal form analysis +c +804 continue + return +c +c compute exponential +c +805 continue + return +c +c compute power of dynamic normal form +c +806 continue + return +c +c compute power of static normal form +c +807 continue + return +c +c resonance analyze dynamic map +c +808 continue + return +c +c resonance analyze static map +c +809 continue + return +c +c static invariant ayalysis +c +810 continue + return +c +c static normal form analysis +c +811 continue + return +c +c twiss analyze dynamic map +c +812 continue + return +c +c 'tasm': twiss analyze static map +813 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=2 + pmenu(2+mpp(na))=1.d-3 + pmenu(3+mpp(na))=1 + pmenu(4+mpp(na))=0 + pmenu(5+mpp(na))=3 + pmenu(6+mpp(na))=0 + endif +c values provided by user: + call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'delta=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'idata=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'ipmaps=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'iwmaps=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + return +c +c translate basis +c +814 continue + return +c +c get buffer contents +c +815 continue + return +c +c transport static (script) A +c +816 continue + return +c +c transport dynamic script A +c +817 continue + return +c +c multiply polynomial by a scalar +c +818 continue + return +c +c add two polynomials +c +819 continue + return +c +c multiply two polynomials +c +820 continue + return +c +c Poisson bracket two polynomials +c +821 continue +c defaults: + if(initparms.eq.1)then + pmenu(1+mpp(na))=1. !map1in + pmenu(2+mpp(na))=2. !map2in + pmenu(3+mpp(na))=0. !mapout + endif +c values provided by user: + call getparm(line,mmax,'map1in=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'map2in=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'mapout=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + return +c +c polar decompose matrix portion of transfer map +c +822 continue + return +c +c evaluate a polynomial +c +823 continue + return +c +c fourier analyze static map +c +824 continue + return +c +c fourier analyze dynamic map +c +825 continue + return +c +c select quantities +c +826 continue + return +c +c write selected quantities +c +827 continue + return +c +c change tune ranges +c +828 continue + return +c +c apply script N inverse +c +829 continue + return +c +c compute power of nonlinear part +c +830 continue + return +c +c check for symplecticity +c +831 continue + return +c +c (psp) compute scalar product of two polynomials +c +832 continue + return +c +c (mn) compute matrix norm +c +833 continue + return +c +c===================================================================== +c BGEN +c===================================================================== +c (bgen) generate a beam +834 continue +c write(6,*)'HERE I AM AT BGEN; MMAX=',mmax, ' LINE(1:800)=' +c write(6,*)line(1:800) + write(6,*)'getting bgen parameters in sif.f' +c defaults: + if(initparms.eq.1)then + job=6 + iopt=1 + nray=10000 + iseed=1234567 + isend=3 + ipset=0 + xx=1.d-3 + yy=1.d-3 + tt=1.d-3 + sigmax=5.d0 + unit1=0 + unit2=0 + pmenu(1+mpp(na))=job !this is called 'dist' by the parser + pmenu(2+mpp(na))=iopt + pmenu(3+mpp(na))=nray !this is called 'maxray' by the parser + pmenu(4+mpp(na))=iseed + pmenu(5+mpp(na))=isend + pmenu(6+mpp(na))=ipset + pmenu(7+mpp(na))=xx + pmenu(8+mpp(na))=yy + pmenu(9+mpp(na))=tt + pmenu(10+mpp(na))=sigmax + pmenu(11+mpp(na))=unit1 + pmenu(12+mpp(na))=unit2 + cmenu(1+mppc(na))=' ' + cmenu(2+mppc(na))=' ' + endif +c values provided by user: + call getparm(line,mmax,'dist=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'maxray=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'iseed=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'ipset=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + call getparm(line,mmax,'xx=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) + call getparm(line,mmax,'yy=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) + call getparm(line,mmax,'tt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) + call getparm(line,mmax,'sigmax=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) +c + call getparm(line,mmax,'unit1=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) + call getparm(line,mmax,'unit2=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) +c + call getparm(line,mmax,'file1=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(1+mppc(na))=cbuf + endif + call getparm(line,mmax,'file2=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + call quotechk(cbuf,16) + cmenu(2+mppc(na))=cbuf + endif + return +c +c (tic) translate (move) initial conditions +c +835 continue + return +c +c (ppa) principal planes analysis +c +836 continue + return +c +c (moma) moment and map analysis +c +837 continue + return +c +c (geom) compute geometry of a loop +c +838 continue + return +c +c (fwa) copy file to working array +c +839 continue + return +c +c 9: procedures and fitting and optimization ************************* +c +c 'bip ','bop ','tip ','top ', +19 go to (901, 902, 903, 904, +c 'aim ','vary ','fit ','opt ', + & 905, 906, 907, 908, +c 'con1 ','con2 ','con3 ','con4 ','con5 ', + & 909, 910, 911, 912, 913, +c 'mrt0 ', + & 914, +c 'mrt1 ','mrt2 ','mrt3 ','mrt4 ','mrt5 ', + & 915, 916, 917, 918, 919, +c 'fps ', + & 920, +c 'cps1 ','cps2 ','cps3 ','cps4 ','cps5 ', + & 921, 922, 923, 924, 925, +c 'cps6 ','cps7 ','cps8 ','cps9 ', + & 926, 927, 928, 929, +c 'dapt ','grad ','rset ','flag ','scan ', + & 930, 931, 932, 933, 934, +c 'mss ','spare1 ','spare2 '/ + & 935, 936, 937),kt2 +c begin procedures +c +c===================================================================== +c BIP +c===================================================================== +c 'bip ': begin inner procedure +901 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=10. !ntimes + endif + call getparm(line,mmax,'ntimes=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + return +c +c===================================================================== +c BOP +c===================================================================== +c 'bop ': begin outer procedure +902 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=10. !ntimes + endif + call getparm(line,mmax,'ntimes=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + return +c +c===================================================================== +c TIP +c===================================================================== +c 'tip ': terminate inner procedure +903 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=1. !iopt + endif + call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + return +c +c===================================================================== +c TOP +c===================================================================== +c 'tip ': terminate outer procedure +904 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=1. !iopt + endif + call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + return +c +c end procedures +c +c +c specify aims +c +c===================================================================== +c AIM +c===================================================================== +c 'aim ': specify quantities to be fit/optimized and set target values +905 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=2. !job + pmenu(2+mpp(na))=0. !infile + pmenu(3+mpp(na))=0. !logfile + pmenu(4+mpp(na))=0. !iquiet + pmenu(5+mpp(na))=0. !istore + pmenu(6+mpp(na))=1. !isend + endif + call getparm(line,mmax,'job=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'infile=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'logfile=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'iquiet=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'istore=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + return +c +c specify quantities to be varied +c +c===================================================================== +c VARY +c===================================================================== +c 'vary ': specify quantities to be varied +906 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=1. !job + pmenu(2+mpp(na))=0. !infile + pmenu(3+mpp(na))=0. !logfile + pmenu(4+mpp(na))=0. !isb (scaling and bounds) + pmenu(5+mpp(na))=0. !istore + pmenu(6+mpp(na))=1. !isend + endif + call getparm(line,mmax,'job=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'infile=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'logfile=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'isb=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'istore=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + return +c +c===================================================================== +c FIT +c===================================================================== +c 'fit ': fit to achieve aims +907 continue + if(initparms.eq.1)then + pmenu(1+mpp(na))=10. !job + pmenu(2+mpp(na))=1. !aux + pmenu(3+mpp(na))=1.d-8 !error + pmenu(4+mpp(na))=1.d-3 !delta + pmenu(5+mpp(na))=0. !mprint + pmenu(6+mpp(na))=1. !isend + endif + call getparm(line,mmax,'job=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) + call getparm(line,mmax,'aux=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) + call getparm(line,mmax,'error=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) + call getparm(line,mmax,'delta=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) + call getparm(line,mmax,'mprint=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) + call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) + return +c +c +c optimize +c +908 continue + return +c +c constraints +c +909 continue + return +910 continue + return +911 continue + return +912 continue + return +913 continue + return +c +c merit functions +c +c least squares merit function +c +914 continue + return +c +c user supplied merit functions +c +915 continue + return +916 continue + return +917 continue + return +918 continue + return +919 continue + return +c +c free parameter sets +c +920 continue + return +c +c capture parameter sets +c +921 continue + return +922 continue + return +923 continue + return +924 continue + return +925 continue + return +926 continue + return +927 continue + return +928 continue + return +929 continue + return +c +c compute dynamic aperture (dapt) +c +930 continue + return +c +c gradient (grad) +c +931 continue + return +c +c rset +c +932 continue + return +c +c flag +c +933 continue + return +c +c scan +c +934 continue + return +c +c mss +c +935 continue + return +c +c spare1 + +936 continue + return +c +c spare2 + +937 continue + return + return + end +c + subroutine getparm(line,mmax,kywrd,bufr,keypres,numpres,iopt,cbuf) +c "string" has to be long enough to hold a single number or expression + use parallel, only : idproc + use acceldata + include 'impli.inc' + include 'files.inc' +cryne 7/15/2002 parameter (nstrmax=80) +c nstrmax=80 should be sufficient for most purposes. The only reason +c to make it longer is if there is an arithmetic (symbolic) expression +c that extends over several lines. So, just in case, set nstrmax=800 + parameter (nstrmax=800) + character (len=*) line + character(len=nstrmax) string + character(len=*) kywrd + character(len=*) cbuf + logical keypres,numpres + dimension bufr(1) + character*16 symb(50) + integer istrtsym(50) + common/showme/iverbose + + keylen=len(kywrd) + if(kywrd(1:keylen).eq.'=')then + n1=index(line,kywrd) + goto 500 + endif +c-------------------------------- + if(iverbose.eq.2 .and. idproc.eq.0)then + write(6,*)'[getparm] kywrd=',kywrd(1:keylen),', line(1:',mmax,')=' + write(6,*)line(1:mmax) + endif +cccc n1=index(line,kywrd) + call getsymb(line,mmax,symb,istrtsym,nsymb) + if(iverbose.eq.2 .and. idproc.eq.0)then + write(6,*)'(getparm)returned from getsymb with nsymb=',nsymb + do n=1,nsymb + write(6,*)'n,symb(n)=',n,symb(n) + enddo + endif + n1=0 + if(nsymb.gt.0)then + do n=1,nsymb +c write(6,*)n,' ',kywrd(1:keylen),' ',trim(symb(n)) + if(kywrd(1:keylen).eq.trim(symb(n))//'=')then + n1=istrtsym(n) +c write(6,*)'found a match with n, n1 = ',n,n1 + exit + endif + enddo + endif +c-------------------------------- + 500 continue + if(n1.eq.0)then + keypres=.false. + numpres=.false. +c if(jwarn.eq.1)then +c write(6,*)'warning: could not find ',kywrd,' on input line:' +c write(6,*)line(1:mmax) +c endif + return + endif +c possibly this came from a multiline input. +c in that case, there may be '&' that need to be removed. + do n=1,mmax + if(line(n:n).eq.'&')line(n:n)=' ' + enddo +c obtain value for kywrd: +c write(6,*)'obtaining value for keyword:',kywrd +c write(6,*)'with line equal to' +c write(6,*)line(1:mmax) + keypres=.true. + string(1:nstrmax)=' ' + m=1 +c write(6,*)'starting do loop with n=',n1+keylen,' to',mmax + do n=n1+keylen,mmax +cryne 7/9/2002 if(line(n:n).eq.' ')exit + if(line(n:n).eq.',')exit + if((line(n:n).eq.'!').or.(line(n:n).eq.';'))exit + string(m:m)=line(n:n) +cryne can exit after storing another '=' (if any) + if(line(n:n).eq.'=')exit + m=m+1 + if(m.gt.nstrmax)then + write(6,*)'TROUBLE: m > nstrmax' + endif + enddo +c write(6,*)'finished do loop. now string=' +c write(6,*)string(1:nstrmax) +cccccccccccccccccccccc +c in case the user omitted the commas: +c find the next occurence of '=': + mm1=index(string,'=') +c write(6,*)'mm1=',mm1 + if(mm1.eq.0)goto 150 + string(mm1:nstrmax)=' ' + do n=mm1-1,1,-1 + if((string(n:n).eq.' ').or.(string(n:n).eq.','))exit + string(n:n)=' ' + enddo +cccccccccccccccccccccc + 150 continue +c write(6,*)'*string* = ' +c write(6,*)string(1:nstrmax) +c option to return string instead of value (i.e. if looking for a string): +c use numpres to indicate that this is normal return + if(iopt.eq.1)then + nbuf=len(cbuf) + cbuf(1:nbuf)=string(1:nbuf) + numpres=.true. +c write(6,*)'returning from getparm w/ iopt=1' +c write(6,*)'kywrd,cbuf=',kywrd(1:keylen),cbuf(1:nbuf) + return + endif +c + numpres=.false. +c------------------------------------ +c COMMENT THIS SECTION OUT WHEN FPARSER IS WORKING ON YOUR MAC: +c call txtnum(string,nstrmax,1,nget,bufr) +c read(string,*,iostat=numerr)value +c if(numerr.eq.0)then +c numpres=.true. +c bufr(1)=value +c endif +c------------------------------------- + if(.not.numpres)then + call strngfeval(string,nstrmax,value,numpres) + if(numpres)bufr(1)=value +c do j=1,nconst +c if(string.eq.constr(j))then +c write(6,*)'j,constr,conval=',j,constr(j),conval(j) +c bufr(1)=conval(j) +c numpres=.true. +c exit +c endif +c enddo + if(.not.numpres)write(6,*)'ERROR READING ELEMENT PARAMTERS:', & + & 'The string ',trim(string), ' has not been defined' + endif + if(numpres)then +c write(6,*)'bufr(1)=',bufr(1) + else + write(6,*)'number not found for kywrd ',kywrd + endif + return + end +c + subroutine strngfeval(string,nstrmax,result,numpres) + use parallel, only : idproc + use acceldata + include 'impli.inc' +c parameter (nstrmax=80) + character(len=nstrmax) string + character*16 symb(50),newsymb + integer istrtsym(50) + logical numpres + dimension val(50),bufr(1) + common/showme/iverbose + common/symbdef/isymbdef + numpres=.false. +c write(6,*)'evaluating string:',string +c iverbose=2 + if(iverbose.eq.2 .and. idproc.eq.0)then + write(6,*)'inside strngfeval; nstrmax=',nstrmax,' ;string=' + write(6,*)string(1:nstrmax) + endif + call getsymb(string,nstrmax,symb,istrtsym,nsymb) + if(iverbose.eq.2 .and. idproc.eq.0)then + write(6,*)'(strngfeval)returned from getsymb; nsymb=',nsymb + do n=1,nsymb + write(6,*)'n,symb(n)=',n,symb(n) + enddo + endif +c this is wrong; there can be an expression even though there are no symbols. +c so evaluate the symbolic expression regardless. +c if(nsymb.eq.0)then +c call txtnum(string,80,1,nget,bufr) +c if(nget.ge.1)then +c result=bufr(1) +c numpres=.true. +c else +c write(6,*)'trouble(strngfeval):txtnum did not return a number' +c endif +c return +c endif +c found symbols on this line; evaluate the symbolic expression: + do n=1,nsymb +c this is the place to check for function names (e.g. sqrt) and skip: + if(iverbose.eq.2 .and. idproc.eq.0)then + write(6,*)'[strngfeval] n,symb(n),nconst =',n,symb(n),nconst + endif + if(trim(symb(n)).eq.'sqrt')cycle + if(trim(symb(n)).eq.'sin')cycle + if(trim(symb(n)).eq.'cos')cycle + if(trim(symb(n)).eq.'tan')cycle + if(trim(symb(n)).eq.'asin')cycle + if(trim(symb(n)).eq.'acos')cycle + if(trim(symb(n)).eq.'atan')cycle + if(trim(symb(n)).eq.'abs')cycle + do j=1,nconst +c write(6,*)'j,constr(j)=',j,constr(j) + if(symb(n).eq.constr(j))then +ccccc write(6,*)'j,constr,conval=',j,constr(j),conval(j) + val(n)=conval(j) + goto 199 + endif + enddo +c the symbol was not found in the constr array; check for [...] +c new code------------------------- +c if you find it, set val(n)=... and goto 199 + ir1=index(symb(n),'[') + ir2=index(symb(n),']') + if(ir1.eq.0 .or. ir2.eq.0)goto 198 +c found [...] in the symbol. Now determine the value of xxxx[...]: + write(6,*)'reached the [...] section of code' + newsymb=symb(n)(ir1+1:ir2-1) + nlength=ir2-ir1-1 +c write(6,*)'calling str2int w/ newsymb,nlength=',newsymb,nlength + call str2int(newsymb,nlength,mval) + write(6,*)'returned from str2int w/ mval=',mval +c now that the value of the symbol has been found, make sure that +c it corresponds to a menu item: + newsymb=symb(n)(1:ir1-1) + write(6,*)'looking up the following symbol: ',newsymb + call lookup(newsymb,itype,indx) + if(itype.ne.1)then + write(6,*)'error: the symbol ',newsymb,' is not in the menu' + call myexit + endif + write(6,*)'Found ',newsymb,' in the menu (element #',indx,')' + write(6,*)'Parameter ',mval,' has the value ', & + & pmenu(mval+mpp(indx)) + val(n)=pmenu(mval+mpp(indx)) + goto 199 +c --------------------------------- + 198 continue +cryne 9/26/02: +c the symbol has not been defined. deal with it: + if(isymbdef.eq.1)then + if(idproc.eq.0)then + write(6,*)'error: symbol ',symb(n),' is used in expression:' + write(6,*)string + write(6,*)'but the symbol has not been defined. Setting to 0.' + endif + val(n)=0.d0 + else + if(idproc.eq.0)then + write(6,*)'error: symbol ',symb(n),' is used in expression:' + write(6,*)string + write(6,*)'but the symbol has not been defined. Halting.' + endif + call myexit + endif + 199 continue + enddo + nfunc=1 +!dbs -- fproutine expects an array so construct one on the fly +!dbs call fproutine(string,nfunc,symb,val,nsymb,result,nget) + call fproutine( (/ string /),nfunc,symb,val,nsymb,result,nget) + if(nget.eq.1)numpres=.true. + return + end +c + subroutine str2int(newsymb,nlength,mval) + character*16 newsymb + integer nlength,mval,n,ntmp + if(nlength.le.0)then + write(6,*)'error (str2int): nlength = ',nlength + call myexit + endif + mval=0 + do n=nlength,1,-1 + if(newsymb(n:n).eq.'0')ntmp=0 + if(newsymb(n:n).eq.'1')ntmp=1 + if(newsymb(n:n).eq.'2')ntmp=2 + if(newsymb(n:n).eq.'3')ntmp=3 + if(newsymb(n:n).eq.'4')ntmp=4 + if(newsymb(n:n).eq.'5')ntmp=5 + if(newsymb(n:n).eq.'6')ntmp=6 + if(newsymb(n:n).eq.'7')ntmp=7 + if(newsymb(n:n).eq.'8')ntmp=8 + if(newsymb(n:n).eq.'9')ntmp=9 + npow=nlength-n +c write(6,*)'n,ntmp,npow=',n,ntmp,npow + mval=mval+ntmp*10**npow + enddo + return + end +c + subroutine getsymb(line,nstrmax,symb,istrtsym,nsymb) +cryne 09/21/02 modified to include ] and [ + use acceldata + include 'impli.inc' + character (len=*) line + character*16 symb(*) + integer istrtsym(*) + character*1 str + character*26 alpha +ccc character*38 alphaug + character*40 alphaug + character*11 numerdot + logical acheck,echeck,dcheck + alpha='abcdefghijklmnopqrstuvwxyz' +ccc alphaug='abcdefghijklmnopqrstuvwxyz0123456789_.' + alphaug='abcdefghijklmnopqrstuvwxyz0123456789_.[]' + numerdot='0123456789.' + nsymb=0 + i=0 +! search for a new symbol beginning with an alpha character: + 100 i=i+1 +c if(i.eq.81)goto 9999 + if(i.ge.nstrmax+1)goto 9999 + istart=i +c if(line(i:i) .eq. an alpha)then + str=line(i:i) + echeck=.false. + dcheck=.false. + if(i.ge.2)then + echeck=(str.eq.'e').and.(scan(line(i-1:i-1),numerdot).ne.0) + dcheck=(str.eq.'d').and.(scan(line(i-1:i-1),numerdot).ne.0) + endif + acheck=.false. + if(scan(str,alpha).ne.0)acheck=.true. + if( (acheck) .and. (.not.echeck) .and. (.not.dcheck) )then + nsymb=nsymb+1 + 200 i=i+1 +c if(i.eq.81)goto 9999 + if(i.eq.nstrmax+1)goto 9999 +cryne 5/4/2006 if( (line(i:i).eq.'!') .or. (line(i:i).eq.';') )goto 9999 + if( (line(i:i).eq.'!') .or. (line(i:i).eq.';') )goto 201 +c if(line(i:i).eq. an alphanumeric or _ or . or "'")goto 200 + str=line(i:i) +!dbs -- if the last char in the line is the last char in the symbol +!dbs then process the symbol + if( scan(str,alphaug).ne.0 )then + if( i.lt.nstrmax ) goto 200 + !make it seem like the next char is a symbol terminator + i = i + 1 + endif +!dbs if(scan(str,alphaug).ne.0)goto 200 +cryne 5/4/2006 ------ + 201 continue +c-------------------- +cryne 11/04/02 +c store the symbol but first make sure it is not too long: + if(i-istart.gt.16)then + write(6,*)'(getsymb)warning: long character string on line=' + write(6,*)line + endif +c + imax=i-1 + if(i-istart.gt.16)imax=istart+16-1 +c symb(nsymb)=line(istart:i-1) + symb(nsymb)=line(istart:imax) + istrtsym(nsymb)=istart + goto 100 + endif + goto 100 + 9999 continue + return + end +c + subroutine getsymb60(line,nstrmax,symb,istrtsym,nsymb) +cryne 09/21/02 modified to include ] and [ + use acceldata + include 'impli.inc' + character (len=*) line + character*60 symb(*) + integer istrtsym(*) + character*1 str + character*26 alpha +ccc character*38 alphaug + character*40 alphaug + character*11 numerdot + logical acheck,echeck,dcheck + alpha='abcdefghijklmnopqrstuvwxyz' +ccc alphaug='abcdefghijklmnopqrstuvwxyz0123456789_.' + alphaug='abcdefghijklmnopqrstuvwxyz0123456789_.[]' + numerdot='0123456789.' + nsymb=0 + i=0 +! search for a new symbol beginning with an alpha character: + 100 i=i+1 +c if(i.eq.81)goto 9999 + if(i.eq.nstrmax+1)goto 9999 + istart=i +c if(line(i:i) .eq. an alpha)then + str=line(i:i) + echeck=.false. + dcheck=.false. + if(i.ge.2)then + echeck=(str.eq.'e').and.(scan(line(i-1:i-1),numerdot).ne.0) + dcheck=(str.eq.'d').and.(scan(line(i-1:i-1),numerdot).ne.0) + endif + acheck=.false. + if(scan(str,alpha).ne.0)acheck=.true. + if( (acheck) .and. (.not.echeck) .and. (.not.dcheck) )then + nsymb=nsymb+1 + 200 i=i+1 +c if(i.eq.81)goto 9999 + if(i.eq.nstrmax+1)goto 9999 + if( (line(i:i).eq.'!') .or. (line(i:i).eq.';') )goto 9999 +c if(line(i:i).eq. an alphanumeric or _ or . or "'")goto 200 + str=line(i:i) + if(scan(str,alphaug).ne.0)goto 200 +cryne 11/04/02 +c store the symbol but first make sure it is not too long: + if(i-istart.gt.60)then + write(6,*)'(getsymb)warning: long character string on line=' + write(6,*)line + endif +c + imax=i-1 + if(i-istart.gt.60)imax=istart+16-1 +c symb(nsymb)=line(istart:i-1) + symb(nsymb)=line(istart:imax) + istrtsym(nsymb)=istart + goto 100 + endif + goto 100 + 9999 continue + return + end +c +c +c + subroutine fproutine(func,nfunc,var,val,nvar,res,nget) + USE parameters, ONLY: rn + USE fparser, ONLY: initf, parsef, evalf, EvalErrType, EvalErrMsg + IMPLICIT NONE + INTEGER nfunc,nvar,i,nget + CHARACTER (LEN=*), DIMENSION(nfunc) :: func + CHARACTER (LEN=*), DIMENSION(nvar) :: var + REAL(rn), DIMENSION(nvar) :: val + REAL(rn) :: res +! + CALL initf (nfunc) ! Initialize function parser for nfunc functions + DO i=1,nfunc + CALL parsef(i,func(i),var) ! Parse and bytecompile ith function string + END DO +! WRITE(*,*)'==> Bytecode evaluation:' + DO i=1,nfunc + res=evalf(i,val) ! Interprete bytecode representation of ith function + IF(EvalErrType.gt.0)WRITE(6,*)'*** Error: ',EvalErrMsg () + nget=0 + IF(EvalErrType.eq.0)nget=1 +! WRITE(6,*)trim(func(i)),'=',res + END DO + return + end +c + subroutine quotechk(fname,lmax) +c check for unnecessary quotes and apostrophes + character (len=*) fname +c + if(fname.ne.' ')then + if((fname(1:1).eq.'"').or.(fname(1:1).eq."'"))then + write(6,*)'(pmif) quotes and apostrophes not needed in: ',fname + write(6,*)'They will be stripped off.' +c lmax=len(fname) + do i=1,lmax-1 + fname(i:i)=fname(i+1:i+1) + enddo + fname(lmax:lmax)=' ' + n=index(fname,'"') + if(n.ne.0)fname(n:n)=' ' + n=index(fname,"'") + if(n.ne.0)fname(n:n)=' ' + endif + endif + return + end +c--------------------------------------------------- diff --git a/OpticsJan2020/MLI_light_optics/Src/spch2d.f b/OpticsJan2020/MLI_light_optics/Src/spch2d.f new file mode 100755 index 0000000..08bfef4 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/spch2d.f @@ -0,0 +1,960 @@ +c IMPACT 2D space charge routines +c Copyright 2001 University of California +c + subroutine spch2dphi(c,ex,ey,msk,np,ntot,nx,ny,n1,n2) + use rays + implicit double precision(a-h,o-z) + logical msk + complex*16 grnxtr,erhox,erhoxtr,rho2,rho2xtr +! rho=charge density on the grid +! rho2=...on doubled grid +! rho2xtr=...xformed (by fft) and transposed +! grnxtr=green function, xformed, transposed + dimension c(4,maxrayp),msk(maxrayp),ex(maxrayp),ey(maxrayp) + dimension rho(nx,ny),exg(nx,ny),eyg(nx,ny),rhosum(nx,ny) + dimension rho2(n1,n2),rho2xtr(n2,n1),grnxtr(n2,n1) +! weights, indices associated with area weighting: + dimension ab(maxrayp),cd(maxrayp) + dimension indx(maxrayp),jndx(maxrayp) + dimension indxp1(maxrayp),jndxp1(maxrayp) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + common/newpoisson/idirectfieldcalc,idensityfunction,idummy(4) +! compute grid quantities hx,hy,... + call boundp2d(c,msk,np,nx,ny) +! deposit charge on the grid: + call rhoslo2d(c,rho,msk,np,ab,cd,indx,jndx,indxp1,jndxp1,nx,ny) + call MPI_ALLREDUCE(rho,rhosum,nx*ny,mreal,mpisum,lworld,ierror) + rho=rhosum +! store rho in lower left quadrant of doubled grid: + rho2=(0.,0.) + do j=1,ny + do i=1,nx + rho2(i,j)=cmplx(rho(i,j),0.) + enddo + enddo +!---------convolution------------ + twopi=4.d0*asin(1.d0) +! compute FFT of the Green function on the grid: + if(idensityfunction.eq.0)then +! if(idproc.eq.0)write(6,*)'in spch2d (via phi); NOT using slic' + call greenf2d(grnxtr,nx,ny,n1,n2) + grnxtr=0.5d0*grnxtr/(twopi*nrays) + else +! if(idproc.eq.0)write(6,*)'in spch2d, using slic (for phi)' + call greenphi2d(grnxtr,rho,nx,ny,n1,n2) + grnxtr=-1.d0*grnxtr/(hx*hy*twopi*nrays) + endif +! fft the charge density: + scale=1.0 + call fft2dhpf(n1,n2,1,0,scale,0,rho2,rho2xtr) +! multiply transformed charge density and transformed Green function: + rho2xtr=rho2xtr*grnxtr/(n1*n2) +! inverse fft: + call fft2dhpf(n2,n1,-1,0,scale,0,rho2xtr,rho2) +!----done with convolution------- +! store physical data back on grid of correct (not doubled) size: + do j=1,ny + do i=1,nx + rho(i,j)=real(rho2(i,j)) + enddo + enddo +! obtain the electric fields: + exg=0.5*hxi*(cshift(rho,-1,1)-cshift(rho,1,1)) + eyg=0.5*hyi*(cshift(rho,-1,2)-cshift(rho,1,2)) +! interpolate electric field at particle postions: + call ntrslo2d(exg,eyg,ex,ey,msk,ab,cd,indx,jndx,indxp1,jndxp1, & + & nx,ny,np) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! do i=1,nx +! j=ny/2 +! x=xmin+(i-1)*hx +! y=ymin+(j-1)*hy +! write(58,*)x,y,exg(i,j),eyg(i,j) +! enddo +! do j=1,ny +! i=nx/2 +! x=xmin+(i-1)*hx +! y=ymin+(j-1)*hy +! write(59,*)x,y,exg(i,j),eyg(i,j) +! enddo +! if(nx.ne.12345)call myexit +!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + return + end +! + subroutine boundp2d(c,msk,np,nx,ny) + use rays + implicit double precision(a-h,o-z) + logical msk + dimension c(4,maxrayp),msk(maxrayp) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi +! transverse: + xbig=maxval(c(1,:),1,msk) + xsml=minval(c(1,:),1,msk) + ybig=maxval(c(3,:),1,msk) + ysml=minval(c(3,:),1,msk) +! note: this would be a good place to check which particles +! are inside the beampipe, then mask off those that are not. + xmin=xsml-0.05*(xbig-xsml) + xmax=xbig+0.05*(xbig-xsml) + ymin=ysml-0.05*(ybig-ysml) + ymax=ybig+0.05*(ybig-ysml) + hx=(xmax-xmin)/(nx-1) + hy=(ymax-ymin)/(ny-1) + hxi=1./hx + hyi=1./hy + return + end +! + subroutine greenf2d(grnxtr,nx,ny,n1,n2) + implicit double precision(a-h,o-z) + complex*16 grn,grnxtr + dimension grn(n1,n2) + dimension grnxtr(n2,n1) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + eps=1.d-25 + do j=-ny,ny-1 + do i=-nx,nx-1 + grn(1+mod(i+n1,n1),1+mod(j+n2,n2))= -log((hx*i)**2+(hy*j)**2+eps) + enddo + enddo + grn(1,1)=grn(1,2) +! compute FFT of the Green function + scale=1.d0 + call fft2dhpf(n1,n2,1,0,scale,0,grn,grnxtr) + return + end +! +! + subroutine rhoslo2d(c,rho,msk,np,ab,cd,indx,jndx,indxp1, & + & jndxp1,nx,ny) + use rays + implicit double precision(a-h,o-z) + logical msk + dimension c(4,maxrayp),msk(maxrayp),vol(maxrayp) + dimension ab(maxrayp),cd(maxrayp) + dimension indx(maxrayp),jndx(maxrayp) + dimension indxp1(maxrayp),jndxp1(maxrayp) + dimension rho(nx,ny) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + do j=1,np + indx(j)=(c(1,j)-xmin)*hxi + 1 + jndx(j)=(c(3,j)-ymin)*hyi + 1 + enddo + do j=1,np + indxp1(j)=indx(j)+1 + jndxp1(j)=jndx(j)+1 + enddo +!------- + imin=minval(indx,1,msk) + imax=maxval(indx,1,msk) + jmin=minval(jndx,1,msk) + jmax=maxval(jndx,1,msk) + if((imin.lt.1).or.(imax.gt.nx-1))then + write(6,*)'error in rhoslo2d: imin,imax=',imin,imax + call myexit + endif + if((jmin.lt.1).or.(jmax.gt.ny-1))then + write(6,*)'error in rhoslo3d: jmin,jmax=',jmin,jmax + call myexit + endif +!------- + do j=1,np + ab(j)=((xmin-c(1,j))+indx(j)*hx)*hxi + cd(j)=((ymin-c(3,j))+jndx(j)*hy)*hyi + enddo + rho=0. +!1 (i,j): + vol=ab*cd + do n=1,np + rho(indx(n),jndx(n))=rho(indx(n),jndx(n))+vol(n) + enddo +!2 (i,j+1): + vol=ab*(1.-cd) + do n=1,np + rho(indx(n),jndxp1(n))=rho(indx(n),jndxp1(n))+vol(n) + enddo +!3 (i+1,j): + vol=(1.-ab)*cd + do n=1,np + rho(indxp1(n),jndx(n))=rho(indxp1(n),jndx(n))+vol(n) + enddo +!4 (i+1,j+1): + vol=(1.-ab)*(1.-cd) + do n=1,np + rho(indxp1(n),jndxp1(n))=rho(indxp1(n),jndxp1(n))+vol(n) + enddo +! ngood=count(msk) +! rho=rho/ngood + return + end +! + subroutine ntrslo2d(exg,eyg,ex,ey,msk,ab,cd,indx,jndx,indxp1, + &jndxp1,nx,ny,np) + use rays + implicit double precision(a-h,o-z) + logical msk + dimension exg(nx,ny),eyg(nx,ny) + dimension ex(maxrayp),ey(maxrayp),msk(maxrayp) + dimension ab(maxrayp),cd(maxrayp) + dimension indx(maxrayp),jndx(maxrayp) + dimension indxp1(maxrayp),jndxp1(maxrayp) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + do n=1,np + ex(n)= + & exg(indx(n),jndx(n))*ab(n)*cd(n) + & +exg(indx(n),jndxp1(n))*ab(n)*(1.-cd(n)) + & +exg(indxp1(n),jndx(n))*(1.-ab(n))*cd(n) + & +exg(indxp1(n),jndxp1(n))*(1.-ab(n))*(1.-cd(n)) + enddo + do n=1,np + ey(n)= + & eyg(indx(n),jndx(n))*ab(n)*cd(n) + & +eyg(indx(n),jndxp1(n))*ab(n)*(1.-cd(n)) + & +eyg(indxp1(n),jndx(n))*(1.-ab(n))*cd(n) + & +eyg(indxp1(n),jndxp1(n))*(1.-ab(n))*(1.-cd(n)) + enddo + return + end +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!======================================================================= +! 2D SPACE CHARGE ROUTINES BEGIN HERE +!======================================================================= + subroutine spch2ddirect(c,ex,ey,msk,np,ntot,nx,ny,n1,n2) + use rays + implicit double precision(a-h,o-z) + logical msk + double complex grnxtr + double complex rho2,rho2xtr,rho2tmp +! rho=charge density on the grid +! rho2=...on doubled grid +! rho2xtr=...xformed (by fft) and transposed +! grnxtr=green function, xformed, transposed + dimension c(4,maxrayp),msk(maxrayp),ex(maxrayp),ey(maxrayp) + dimension rho(nx,ny),exg(nx,ny),eyg(nx,ny),rhosum(nx,ny) + dimension rho2(n1,n2),rho2xtr(n2,n1),rho2tmp(n2,n1) + dimension grnxtr(n2,n1) +! weights, indices associated with area weighting: + dimension ab(maxrayp),cd(maxrayp) + dimension indx(maxrayp),jndx(maxrayp) + dimension indxp1(maxrayp),jndxp1(maxrayp) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + common/newpoisson/idirectfieldcalc,idensityfunction,idummy(4) +! if(idproc.eq.0)write(6,*)'inside spch2ddirect; np,ntot,nx,ny=' +! if(idproc.eq.0)write(6,*)np,ntot,nx,ny + +! compute grid quantities hx,hy,... + call boundp2d(c,msk,np,nx,ny) +! deposit charge on the grid: + call rhoslo2d(c,rho,msk,np,ab,cd,indx,jndx,indxp1,jndxp1,nx,ny) + call MPI_ALLREDUCE(rho,rhosum,nx*ny,mreal,mpisum,lworld,ierror) + rho=rhosum +! +! store rho in lower left quadrant of doubled grid: + rho2=(0.,0.) + do j=1,ny + do i=1,nx + rho2(i,j)=cmplx(rho(i,j),0.) + enddo + enddo +!---------convolution------------ +! fft the charge density: + scale=1.0 + call fft2dhpf(n1,n2,1,0,scale,0,rho2,rho2xtr) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! compute FFT of the x-Green function on the grid: + twopi=4.d0*asin(1.d0) + if(idensityfunction.eq.0)then +! if(idproc.eq.0)write(6,*)'in spch2ddirect; NOT using slic' + call greenfxold(grnxtr,rhosum,nx,ny,n1,n2) + grnxtr=grnxtr/(twopi*nrays) + else +! if(idproc.eq.0)write(6,*)'in spch2ddirect; using slic' + call greenfx2d(grnxtr,rhosum,nx,ny,n1,n2) + grnxtr=grnxtr/(twopi*nrays) + endif +! multiply transformed charge density and transformed Green function: + rho2tmp=rho2xtr*grnxtr/(n1*n2) +! inverse fft: + call fft2dhpf(n2,n1,-1,0,scale,0,rho2tmp,rho2) +! store physical data back on grid of correct (not doubled) size: + do j=1,ny + do i=1,nx + rho(i,j)=real(rho2(i,j)) + enddo + enddo +! obtain the x-electric field: +! exg=rho/(4.d0*asin(1.d0)) + exg=rho/(hx*hy) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! compute FFT of the y-Green function on the grid: + if(idensityfunction.eq.0)then + call greenfy2d(grnxtr,rhosum,nx,ny,n1,n2) + grnxtr=grnxtr/(twopi*nrays) + else + call greenfyold(grnxtr,rhosum,nx,ny,n1,n2) + grnxtr=grnxtr/(twopi*nrays) + endif +! multiply transformed charge density and transformed Green function: + rho2tmp=rho2xtr*grnxtr/(n1*n2) +! inverse fft: + call fft2dhpf(n2,n1,-1,0,scale,0,rho2tmp,rho2) +! store physical data back on grid of correct (not doubled) size: + do j=1,ny + do i=1,nx + rho(i,j)=real(rho2(i,j)) + enddo + enddo +! obtain the y-electric field: +! eyg=rho/(4.d0*asin(1.d0)) + eyg=rho/(hx*hy) +! +! interpolate electric field at particle postions: + call ntrslo2d(exg,eyg,ex,ey,msk,ab,cd,indx,jndx,indxp1,jndxp1, & + & nx,ny,np) +! if(idproc.eq.0)write(6,*)'done with interpolation' +! do j=1,np +! ex(j)=0.5*ex(j) +! enddo +! do j=1,np +! ey(j)=0.5*ey(j) +! enddo + return + end +! +! + subroutine spch2dold(c,ex,ey,msk,np,exg,eyg,nx,ny,n1,n2) + use rays + implicit double precision(a-h,o-z) + logical msk + double complex grnxtr + double complex rho2,rho2xtr,rho2tmp +! rho=charge density on the grid +! rho2=...on doubled grid +! rho2xtr=...xformed (by fft) and transposed +! grnxtr=green function, xformed, transposed + dimension c(4,maxrayp),msk(maxrayp),ex(maxrayp),ey(maxrayp) + dimension rho(nx,ny),exg(nx,ny),eyg(nx,ny),rhosave(nx,ny) + dimension rho2(n1,n2),rho2xtr(n2,n1),rho2tmp(n2,n1) + dimension grnxtr(n2,n1) +! weights, indices associated with area weighting: + dimension ab(maxrayp),cd(maxrayp) + dimension indx(maxrayp),jndx(maxrayp) + dimension indxp1(maxrayp),jndxp1(maxrayp) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + if(idproc.eq.0)write(6,*)'inside spch2dold' +! deposit charge on the grid: +! call rho2d(c,rho,msk,ab,de,indx,jndx,indxp1,jndxp1,nx,ny) + call rhoslo2d(c,rho,msk,np,ab,cd,indx,jndx,indxp1,jndxp1,nx,ny) +! +! store rho in lower left quadrant of doubled grid: + rhosave(:,:)=rho(:,:) + rho2=(0.,0.) + do j=1,ny + do i=1,nx + rho2(i,j)=cmplx(rho(i,j),0.) + enddo + enddo +!---------convolution------------ +! fft the charge density: + scale=1.0 + call fft2dhpf(n1,n2,1,0,scale,0,rho2,rho2xtr) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! compute FFT of the x-Green function on the grid: + if(idproc.eq.0)write(6,*)'calling greenfxold' + call greenfxold(grnxtr,rhosave,nx,ny,n1,n2) + if(idproc.eq.0)write(6,*)'done with greenfxold' +! multiply transformed charge density and transformed Green function: + rho2tmp=rho2xtr*grnxtr/(n1*n2) +! inverse fft: + call fft2dhpf(n2,n1,-1,0,scale,0,rho2tmp,rho2) + if(idproc.eq.0)write(6,*)'done with inverse fft' +! store physical data back on grid of correct (not doubled) size: + do j=1,ny + do i=1,nx + rho(i,j)=real(rho2(i,j)) + enddo + enddo +! obtain the x-electric field: + exg=rho/(4.d0*asin(1.d0)) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! compute FFT of the y-Green function on the grid: + if(idproc.eq.0)write(6,*)'calling greenfyold' + call greenfyold(grnxtr,rhosave,nx,ny,n1,n2) + if(idproc.eq.0)write(6,*)'done with greenfyold' +! multiply transformed charge density and transformed Green function: + rho2tmp=rho2xtr*grnxtr/(n1*n2) +! inverse fft: + call fft2dhpf(n2,n1,-1,0,scale,0,rho2tmp,rho2) + if(idproc.eq.0)write(6,*)'done with inverse fft' +! store physical data back on grid of correct (not doubled) size: + do j=1,ny + do i=1,nx + rho(i,j)=real(rho2(i,j)) + enddo + enddo +! obtain the y-electric field: + eyg=rho/(4.d0*asin(1.d0)) +! +! interpolate electric field at particle postions: + call ntrslo2d(exg,eyg,ex,ey,msk,ab,cd,indx,jndx,indxp1,jndxp1, & + & nx,ny,np) +! if(idproc.eq.0)write(6,*)'done with interpolation' + return + end +! +!============================================================= +! + subroutine greenphi2d(gxtr,rho,nx,ny,n1,n2) +! green function routine. + implicit double precision(a-h,o-z) + double complex g,gxtr + dimension g(n1,n2),gxtr(n2,n1) + dimension rho(nx,ny),exg(nx,ny),fxg(nx,ny) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + + xint1(x,y,a,b,hx,hy,e2)= + & (((a - hx)*x**3)/9. - x**4/16. + + & (x**2*(28*b - 28*hy - 9*y)*y)/24. - + & ((a - hx)*x*(18*b - 18*hy - 7*y)*y)/6. + + & ((3*a*b*y**2 - 3*b*hx*y**2 - 3*a*hy*y**2 + 3*hx*hy*y**2 - + & 2*a*y**3 + 2*hx*y**3)*atan(x/y))/3. - + & ((b - hy)*x**2*(-3*a + 3*hx + 2*x)*atan(y/x))/3. + + & (x*(-4*a*x**2 + 4*hx*x**2 + 3*x**3 + 24*a*b*y - + & 24*b*hx*y - 24*a*hy*y + 24*hx*hy*y - 12*b*x*y + + & 12*hy*x*y - 12*a*y**2 + 12*hx*y**2 + 6*x*y**2)* + & Log(x**2 + y**2))/24. + + & ((-4*b*y**3 + 4*hy*y**3 + 3*y**4)*Log(x**2 + y**2))/24.)/ + & 2. + + xint2(x,y,a,b,hx,hy,e2)= + & (((-a - hx)*x**3)/9. + x**4/16. + + & ((a + hx)*x*(18*b - 18*hy - 7*y)*y)/6. + + & (x**2*y*(-28*b + 28*hy + 9*y))/24. + + & ((-3*a*b*y**2 - 3*b*hx*y**2 + 3*a*hy*y**2 + + & 3*hx*hy*y**2 + 2*a*y**3 + 2*hx*y**3)*atan(x/y))/3. + & + ((b - hy)*x**2*(-3*a - 3*hx + 2*x)*atan(y/x))/3. - + & (x*(-4*a*x**2 - 4*hx*x**2 + 3*x**3 + 24*a*b*y + + & 24*b*hx*y - 24*a*hy*y - 24*hx*hy*y - 12*b*x*y + + & 12*hy*x*y - 12*a*y**2 - 12*hx*y**2 + 6*x*y**2)* + & Log(x**2 + y**2))/24. + + & ((4*b*y**3 - 4*hy*y**3 - 3*y**4)*Log(x**2 + y**2))/24.)/2. + + xint3(x,y,a,b,hx,hy,e2)= + & (((-a + hx)*x**3)/9. + x**4/16. + + & ((a - hx)*x*(18*b + 18*hy - 7*y)*y)/6. + + & (x**2*y*(-28*b - 28*hy + 9*y))/24. + + & ((-3*a*b*y**2 + 3*b*hx*y**2 - 3*a*hy*y**2 + + & 3*hx*hy*y**2 + 2*a*y**3 - 2*hx*y**3)*atan(x/y))/3. + & + ((b + hy)*x**2*(-3*a + 3*hx + 2*x)*atan(y/x))/3. - + & (x*(-4*a*x**2 + 4*hx*x**2 + 3*x**3 + 24*a*b*y - + & 24*b*hx*y + 24*a*hy*y - 24*hx*hy*y - 12*b*x*y - + & 12*hy*x*y - 12*a*y**2 + 12*hx*y**2 + 6*x*y**2)* + & Log(x**2 + y**2))/24. + + & ((4*b*y**3 + 4*hy*y**3 - 3*y**4)*Log(x**2 + y**2))/24.)/2. + + xint4(x,y,a,b,hx,hy,e2)= + & (((a + hx)*x**3)/9. - x**4/16. + + & (x**2*(28*b + 28*hy - 9*y)*y)/24. - + & ((a + hx)*x*(18*b + 18*hy - 7*y)*y)/6. + + & ((3*a*b*y**2 + 3*b*hx*y**2 + 3*a*hy*y**2 + 3*hx*hy*y**2 - + & 2*a*y**3 - 2*hx*y**3)*atan(x/y))/3. - + & ((b + hy)*x**2*(-3*a - 3*hx + 2*x)*atan(y/x))/3. + + & (x*(-4*a*x**2 - 4*hx*x**2 + 3*x**3 + 24*a*b*y + + & 24*b*hx*y + 24*a*hy*y + 24*hx*hy*y - 12*b*x*y - + & 12*hy*x*y - 12*a*y**2 - 12*hx*y**2 + 6*x*y**2)* + & Log(x**2 + y**2))/24. + + & ((-4*b*y**3 - 4*hy*y**3 + 3*y**4)*Log(x**2 + y**2))/24.)/ + & 2. +! + xintlimit11= + & (-25*hx**2*hy**2 + 8*hx*hy**3*atan(hx/hy) + + & 8*hx**3*hy*atan(hy/hx) + hx**4*Log(hx**2) + + & hy**4*Log(hy**2) - hx**4*Log(hx**2 + hy**2) + + & 6*hx**2*hy**2*Log(hx**2 + hy**2) - + & hy**4*Log(hx**2 + hy**2))/12. + + xintlimit21= + & (-50*hx**2*hy**2 - 16*hx*hy**3*atan(hx/hy) + + & 16*hx*hy**3*atan((2*hx)/hy) + + & 64*hx**3*hy*atan(hy/(2.*hx)) - + & 16*hx**3*hy*atan(hy/hx) - 2*hx**4*Log(hx**2) + + & 16*hx**4*Log(4*hx**2) - hy**4*Log(hy**2) + + & 2*hx**4*Log(hx**2 + hy**2) - + & 12*hx**2*hy**2*Log(hx**2 + hy**2) + + & 2*hy**4*Log(hx**2 + hy**2) - + & 16*hx**4*Log(4*hx**2 + hy**2) + + & 24*hx**2*hy**2*Log(4*hx**2 + hy**2) - + & hy**4*Log(4*hx**2 + hy**2))/24. +! + xintlimit12= + & (-50*hx**2*hy**2 + 64*hx*hy**3*atan(hx/(2.*hy)) - + & 16*hx*hy**3*atan(hx/hy) - 16*hx**3*hy*atan(hy/hx) + + & 16*hx**3*hy*atan((2*hy)/hx) - hx**4*Log(hx**2) - + & 2*hy**4*Log(hy**2) + 16*hy**4*Log(4*hy**2) + + & 2*hx**4*Log(hx**2 + hy**2) - + & 12*hx**2*hy**2*Log(hx**2 + hy**2) + + & 2*hy**4*Log(hx**2 + hy**2) - hx**4*Log(hx**2 + 4*hy**2) + + & 24*hx**2*hy**2*Log(hx**2 + 4*hy**2) - + & 16*hy**4*Log(hx**2 + 4*hy**2))/24. +! + xintlimit22= + & (-100*hx**2*hy**2 - 128*hx*hy**3*atan(hx/(2.*hy)) + + & 160*hx*hy**3*atan(hx/hy) - + & 32*hx*hy**3*atan((2*hx)/hy) - + & 128*hx**3*hy*atan(hy/(2.*hx)) + + & 160*hx**3*hy*atan(hy/hx) - + & 32*hx**3*hy*atan((2*hy)/hx) + 2*hx**4*Log(hx**2) - + & 16*hx**4*Log(4*hx**2) + 2*hy**4*Log(hy**2) - + & 16*hy**4*Log(4*hy**2) - 4*hx**4*Log(hx**2 + hy**2) + + & 24*hx**2*hy**2*Log(hx**2 + hy**2) - + & 4*hy**4*Log(hx**2 + hy**2) + + & 32*hx**4*Log(4*hx**2 + hy**2) - + & 48*hx**2*hy**2*Log(4*hx**2 + hy**2) + + & 2*hy**4*Log(4*hx**2 + hy**2) + + & 2*hx**4*Log(hx**2 + 4*hy**2) - + & 48*hx**2*hy**2*Log(hx**2 + 4*hy**2) + + & 32*hy**4*Log(hx**2 + 4*hy**2) - + & 16*hx**4*Log(4*hx**2 + 4*hy**2) + + & 96*hx**2*hy**2*Log(4*hx**2 + 4*hy**2) - + & 16*hy**4*Log(4*hx**2 + 4*hy**2))/48. +! +! eps2=1.d-20 + eps2=0.d0 +! compute integrals involving the Green function for Ex: +! do j=1,ny+1 + do j=1,ny + y0=hy*(j-1) + y1=hy*j +! do i=1,nx+1 + do i=1,nx + x0=hx*(i-1) + x1=hx*i +!----------- + fmp= + & xint1(x0-hx,y0-hy,x0,y0,hx,hy,eps2)+xint1(x0,y0,x0,y0,hx,hy,eps2) + &-xint1(x0-hx,y0,x0,y0,hx,hy,eps2)-xint1(x0,y0-hy,x0,y0,hx,hy,eps2) + &+xint2(x0,y0-hy,x0,y0,hx,hy,eps2)+xint2(x0+hx,y0,x0,y0,hx,hy,eps2) + &-xint2(x0,y0,x0,y0,hx,hy,eps2)-xint2(x0+hx,y0-hy,x0,y0,hx,hy,eps2) + &+xint3(x0-hx,y0,x0,y0,hx,hy,eps2)+xint3(x0,y0+hy,x0,y0,hx,hy,eps2) + &-xint3(x0-hx,y0+hy,x0,y0,hx,hy,eps2)-xint3(x0,y0,x0,y0,hx,hy,eps2) + &+xint4(x0,y0,x0,y0,hx,hy,eps2)+xint4(x0+hx,y0+hy,x0,y0,hx,hy,eps2) + &-xint4(x0,y0+hy,x0,y0,hx,hy,eps2)-xint4(x0+hx,y0,x0,y0,hx,hy,eps2) + if(fmp.ne.fmp)then + write(12,123)i,j,x0,y0 + 123 format(1x,'(greenfx)fmp=NaN at i,j,x0,y0=',2(i5,1x),2(1pe12.5,1x)) + call myflush(12) + if(i.eq.1.and.j.eq.1)fmp=xintlimit11 + if(i.eq.1.and.j.eq.2)fmp=xintlimit12 + if(i.eq.2.and.j.eq.1)fmp=xintlimit21 + if(i.eq.2.and.j.eq.2)fmp=xintlimit22 + write(12,*)'new limiting value of fmp =',fmp + call myflush(12) + endif + g(i,j)=fmp/(hx*hy) +!----------- + enddo + enddo +!reflections: + do j=1,ny + do i=1+nx,nx+nx + g(i,j)=g(n1-i+2,j) + enddo + enddo + do j=1+ny,ny+ny + do i=1,nx + g(i,j)=g(i,n2-j+2) + enddo + enddo + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j)=g(n1-i+2,n2-j+2) + enddo + enddo +! compute FFT of the Green function + scale=1.0 +! write(6,*)'calling fft2dhpf in greenfx' + call fft2dhpf(n1,n2,1,0,scale,0,g,gxtr) +! write(6,*)'returned from fft2dhpf in greenfx' + return + end +! +!============================================================= +! +! + subroutine greenfx2d(gxtr,rho,nx,ny,n1,n2) +! green function routine. + implicit double precision(a-h,o-z) + double complex g,gxtr + dimension g(n1,n2),gxtr(n2,n1) + dimension rho(nx,ny),exg(nx,ny),fxg(nx,ny) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + + xint1(x,y,a,b,hx,hy,e2)= + & -((-a + hx)*x**2)/4. - x**3/9. + + & (x*y*(-3*b + 3*hy + 2*y))/6. - + & ((-3*b*y**2 + 3*hy*y**2 + 2*y**3)*atan(x/(y+e2)))/6. - + & ((b - hy)*x*(-2*a + 2*hx + x)*atan(y/(x+e2)))/2. + + & (x**2*(-3*a + 3*hx + 2*x)*log(x**2 + y**2 +e2))/12. - + & ((-2*a*b*y + 2*b*hx*y + 2*a*hy*y - 2*hx*hy*y + + & a*y**2 - hx*y**2)*log(x**2 + y**2 +e2))/4. + + xint2(x,y,a,b,hx,hy,e2)= + & -((a + hx)*x**2)/4. + x**3/9. - + & (x*y*(-3*b + 3*hy + 2*y))/6. - + & ((3*b*y**2 - 3*hy*y**2 - 2*y**3)*atan(x/(y+e2)))/6. + + & ((b - hy)*x*(-2*a - 2*hx + x)*atan(y/(x+e2)))/2. - + & (x**2*(-3*a - 3*hx + 2*x)*log(x**2 + y**2 +e2))/12. - + & ((2*a*b*y + 2*b*hx*y - 2*a*hy*y - 2*hx*hy*y - + & a*y**2 - hx*y**2)*log(x**2 + y**2 +e2))/4. + + xint3(x,y,a,b,hx,hy,e2)= + & ((-a + hx)*x**2)/4. + x**3/9. - + & (x*y*(-3*b - 3*hy + 2*y))/6. + + & ((-3*b*y**2 - 3*hy*y**2 + 2*y**3)*atan(x/(y+e2)))/6. + + & ((b + hy)*x*(-2*a + 2*hx + x)*atan(y/(x+e2)))/2. - + & (x**2*(-3*a + 3*hx + 2*x)*log(x**2 + y**2 +e2))/12. + + & ((-2*a*b*y + 2*b*hx*y - 2*a*hy*y + 2*hx*hy*y + + & a*y**2 - hx*y**2)*log(x**2 + y**2 +e2))/4. + + xint4(x,y,a,b,hx,hy,e2)= + & ((a + hx)*x**2)/4. - x**3/9. + + & (x*y*(-3*b - 3*hy + 2*y))/6. + + & ((3*b*y**2 + 3*hy*y**2 - 2*y**3)*atan(x/(y+e2)))/6. - + & ((b + hy)*x*(-2*a - 2*hx + x)*atan(y/(x+e2)))/2. + + & (x**2*(-3*a - 3*hx + 2*x)*log(x**2 + y**2 +e2))/12. + + & ((2*a*b*y + 2*b*hx*y + 2*a*hy*y + 2*hx*hy*y - + & a*y**2 - hx*y**2)*log(x**2 + y**2 +e2))/4. +! +! write(6,*)'inside greenfx2d w/ hx,hy=',hx,hy + xintlimit21= + & (-2*hy**3*atan(hx/hy) + hy**3*atan((2*hx)/hy) + + & 12*hx**2*hy*atan(hy/(2.*hx)) - + & 6*hx**2*hy*atan(hy/hx) - hx**3*Log(hx**2) + + & 4*hx**3*Log(4*hx**2) + hx**3*Log(hx**2 + hy**2) - + & 3*hx*hy**2*Log(hx**2 + hy**2) - + & 4*hx**3*Log(4*hx**2 + hy**2) + + & 3*hx*hy**2*Log(4*hx**2 + hy**2))/3. +! + xintlimit22= + & (-16*hy**3*atan(hx/(2.*hy)) + 12*hy**3*atan(hx/hy) - + & 2*hy**3*atan((2*hx)/hy) - + & 24*hx**2*hy*atan(hy/(2.*hx)) + + & 36*hx**2*hy*atan(hy/hx) - + & 12*hx**2*hy*atan((2*hy)/hx) + hx**3*Log(hx**2) - + & 4*hx**3*Log(4*hx**2) - 2*hx**3*Log(hx**2 + hy**2) + + & 6*hx*hy**2*Log(hx**2 + hy**2) + + & 8*hx**3*Log(4*hx**2 + hy**2) - + & 6*hx*hy**2*Log(4*hx**2 + hy**2) + + & hx**3*Log(hx**2 + 4*hy**2) - + & 12*hx*hy**2*Log(hx**2 + 4*hy**2) - + & 4*hx**3*Log(4*hx**2 + 4*hy**2) + + & 12*hx*hy**2*Log(4*hx**2 + 4*hy**2))/6. +! +! eps2=1.d-20 + eps2=0.d0 +! compute integrals involving the Green function for Ex: +! do j=1,ny+1 + do j=1,ny + y0=hy*(j-1) + y1=hy*j +! do i=1,nx+1 + do i=1,nx + x0=hx*(i-1) + x1=hx*i +!----------- + fmp= + & xint1(x0-hx,y0-hy,x0,y0,hx,hy,eps2)+xint1(x0,y0,x0,y0,hx,hy,eps2) + &-xint1(x0-hx,y0,x0,y0,hx,hy,eps2)-xint1(x0,y0-hy,x0,y0,hx,hy,eps2) + &+xint2(x0,y0-hy,x0,y0,hx,hy,eps2)+xint2(x0+hx,y0,x0,y0,hx,hy,eps2) + &-xint2(x0,y0,x0,y0,hx,hy,eps2)-xint2(x0+hx,y0-hy,x0,y0,hx,hy,eps2) + &+xint3(x0-hx,y0,x0,y0,hx,hy,eps2)+xint3(x0,y0+hy,x0,y0,hx,hy,eps2) + &-xint3(x0-hx,y0+hy,x0,y0,hx,hy,eps2)-xint3(x0,y0,x0,y0,hx,hy,eps2) + &+xint4(x0,y0,x0,y0,hx,hy,eps2)+xint4(x0+hx,y0+hy,x0,y0,hx,hy,eps2) + &-xint4(x0,y0+hy,x0,y0,hx,hy,eps2)-xint4(x0+hx,y0,x0,y0,hx,hy,eps2) + if(fmp.ne.fmp)then + write(12,123)i,j,x0,y0 + 123 format(1x,'(greenfx)fmp=NaN at i,j,x0,y0=',2(i5,1x),2(1pe12.5,1x)) + call myflush(12) + if(i.eq.1.and.j.eq.1)fmp=0.d0 + if(i.eq.1.and.j.eq.2)fmp=0.d0 + if(i.eq.2.and.j.eq.1)fmp=xintlimit21 + if(i.eq.2.and.j.eq.2)fmp=xintlimit22 + write(12,*)'new limiting value of fmp =',fmp + call myflush(12) + endif + g(i,j)=fmp/(hx*hy) +!----------- + enddo + enddo +!reflections: + do j=1,ny + do i=1+nx,nx+nx + g(i,j)=-g(n1-i+2,j) +! g(i,j)=-g(n1-i+1,j) + enddo + enddo + do j=1+ny,ny+ny + do i=1,nx + g(i,j)=g(i,n2-j+2) +! g(i,j)=g(i,n2-j+1) + enddo + enddo + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j)=-g(n1-i+2,n2-j+2) +! g(i,j)=-g(n1-i+1,n2-j+1) + enddo + enddo +! compute FFT of the Green function + scale=1.0 +! write(6,*)'calling fft2dhpf in greenfx' + call fft2dhpf(n1,n2,1,0,scale,0,g,gxtr) +! write(6,*)'returned from fft2dhpf in greenfx' + return + end +! +!============================================================= +! + subroutine greenfy2d(gxtr,rho,nx,ny,n1,n2) +! green function routine. + implicit double precision(a-h,o-z) + double complex g,gxtr + dimension g(n1,n2),gxtr(n2,n1) + dimension rho(nx,ny),fyg(nx,ny) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + yint1(x,y,a,b,hx,hy,e2)= + & -((a - hx)*x*(2*b - 2*hy + y))/2. + + & (x**2*(3*b - 3*hy + 4*y))/12. + + & ((2*a*b*y - 2*b*hx*y - 2*a*hy*y + 2*hx*hy*y - + & a*y**2 + hx*y**2)*atan(x/(y+e2)))/2. - + & (x**2*(-3*a + 3*hx + 2*x)*atan(y/(x+e2)))/6. - + & ((b - hy)*x*(-2*a + 2*hx + x)*log(x**2 + y**2 +e2))/4. + + & ((-3*b*y**2 + 3*hy*y**2 + 2*y**3)*log(x**2 + y**2 +e2))/ + & 12. + + yint2(x,y,a,b,hx,hy,e2)= + & (x**2*(-3*b + 3*hy - 4*y))/12. + + & ((a + hx)*x*(2*b - 2*hy + y))/2. + + & ((-2*a*b*y - 2*b*hx*y + 2*a*hy*y + 2*hx*hy*y + + & a*y**2 + hx*y**2)*atan(x/(y+e2)))/2. + + & (x**2*(-3*a - 3*hx + 2*x)*atan(y/(x+e2)))/6. + + & ((b - hy)*x*(-2*a - 2*hx + x)*log(x**2 + y**2 +e2))/4. + + & ((3*b*y**2 - 3*hy*y**2 - 2*y**3)*log(x**2 + y**2 +e2))/ + & 12. + + yint3(x,y,a,b,hx,hy,e2)= + & (x**2*(-3*b - 3*hy - 4*y))/12. + + & ((a - hx)*x*(2*b + 2*hy + y))/2. + + & ((-2*a*b*y + 2*b*hx*y - 2*a*hy*y + 2*hx*hy*y + + & a*y**2 - hx*y**2)*atan(x/(y+e2)))/2. + + & (x**2*(-3*a + 3*hx + 2*x)*atan(y/(x+e2)))/6. + + & ((b + hy)*x*(-2*a + 2*hx + x)*log(x**2 + y**2 +e2))/4. + + & ((3*b*y**2 + 3*hy*y**2 - 2*y**3)*log(x**2 + y**2 +e2))/ + & 12. + + yint4(x,y,a,b,hx,hy,e2)= + & -((a + hx)*x*(2*b + 2*hy + y))/2. + + & (x**2*(3*b + 3*hy + 4*y))/12. + + & ((2*a*b*y + 2*b*hx*y + 2*a*hy*y + 2*hx*hy*y - + & a*y**2 - hx*y**2)*atan(x/(y+e2)))/2. - + & (x**2*(-3*a - 3*hx + 2*x)*atan(y/(x+e2)))/6. - + & ((b + hy)*x*(-2*a - 2*hx + x)*log(x**2 + y**2 +e2))/4. + + & ((-3*b*y**2 - 3*hy*y**2 + 2*y**3)*log(x**2 + y**2 +e2))/ + & 12. +! +! write(6,*)'inside greenfy2d' + + yintlimit12= + & (12*hx*hy**2*atan(hx/(2.*hy)) - + & 6*hx*hy**2*atan(hx/hy) - 2*hx**3*atan(hy/hx) + + & hx**3*atan((2*hy)/hx) - hy**3*Log(hy**2) + + & 4*hy**3*Log(4*hy**2) - 3*hx**2*hy*Log(hx**2 + hy**2) + + & hy**3*Log(hx**2 + hy**2) + + & 3*hx**2*hy*Log(hx**2 + 4*hy**2) - + & 4*hy**3*Log(hx**2 + 4*hy**2))/3. + + yintlimit22= + & (-24*hx*hy**2*atan(hx/(2.*hy)) + + & 36*hx*hy**2*atan(hx/hy) - + & 12*hx*hy**2*atan((2*hx)/hy) - + & 16*hx**3*atan(hy/(2.*hx)) + 12*hx**3*atan(hy/hx) - + & 2*hx**3*atan((2*hy)/hx) + hy**3*Log(hy**2) - + & 4*hy**3*Log(4*hy**2) + 6*hx**2*hy*Log(hx**2 + hy**2) - + & 2*hy**3*Log(hx**2 + hy**2) - + & 12*hx**2*hy*Log(4*hx**2 + hy**2) + + & hy**3*Log(4*hx**2 + hy**2) - + & 6*hx**2*hy*Log(hx**2 + 4*hy**2) + + & 8*hy**3*Log(hx**2 + 4*hy**2) + + & 12*hx**2*hy*Log(4*hx**2 + 4*hy**2) - + & 4*hy**3*Log(4*hx**2 + 4*hy**2))/6. + +! eps2=1.d-20 + eps2=0.d0 +! compute integrals involving the Green function for Ey: + do j=1,ny+1 + y0=hy*(j-1) + y1=hy*j + do i=1,nx+1 + x0=hx*(i-1) + x1=hx*i +!----------- + fmp= + & yint1(x0-hx,y0-hy,x0,y0,hx,hy,eps2)+yint1(x0,y0,x0,y0,hx,hy,eps2) + &-yint1(x0-hx,y0,x0,y0,hx,hy,eps2)-yint1(x0,y0-hy,x0,y0,hx,hy,eps2) + &+yint2(x0,y0-hy,x0,y0,hx,hy,eps2)+yint2(x0+hx,y0,x0,y0,hx,hy,eps2) + &-yint2(x0,y0,x0,y0,hx,hy,eps2)-yint2(x0+hx,y0-hy,x0,y0,hx,hy,eps2) + &+yint3(x0-hx,y0,x0,y0,hx,hy,eps2)+yint3(x0,y0+hy,x0,y0,hx,hy,eps2) + &-yint3(x0-hx,y0+hy,x0,y0,hx,hy,eps2)-yint3(x0,y0,x0,y0,hx,hy,eps2) + &+yint4(x0,y0,x0,y0,hx,hy,eps2)+yint4(x0+hx,y0+hy,x0,y0,hx,hy,eps2) + &-yint4(x0,y0+hy,x0,y0,hx,hy,eps2)-yint4(x0+hx,y0,x0,y0,hx,hy,eps2) + if(fmp.ne.fmp)then + write(12,123)i,j,x0,y0 + 123 format(1x,'(greenfy)fmp=NaN at i,j,x0,y0=',2(i5,1x),2(1pe12.5,1x)) + call myflush(12) + if(i.eq.1.and.j.eq.1)fmp=0.d0 + if(i.eq.1.and.j.eq.2)fmp=yintlimit12 + if(i.eq.2.and.j.eq.1)fmp=0.d0 + if(i.eq.2.and.j.eq.2)fmp=yintlimit22 + write(12,*)'new limiting value of fmp =',fmp + call myflush(12) + endif + g(i,j)=fmp/(hx*hy) +!----------- + enddo + enddo +!reflections: + do j=1,ny + do i=1+nx,nx+nx + g(i,j)=g(n1-i+2,j) + enddo + enddo + do j=1+ny,ny+ny + do i=1,nx + g(i,j)=-g(i,n2-j+2) + enddo + enddo + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j)=-g(n1-i+2,n2-j+2) + enddo + enddo +! compute FFT of the Green function + scale=1.0 +! write(6,*)'calling fft2dhpf in greenfy' + call fft2dhpf(n1,n2,1,0,scale,0,g,gxtr) +! write(6,*)'returned from fft2dhpf in greenfy' + return + end +! + subroutine greenfxold(gxtr,rho,nx,ny,n1,n2) +! green function routine. + implicit double precision(a-h,o-z) + double complex g,gxtr + dimension g(n1,n2),gxtr(n2,n1) + dimension rho(nx,ny) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi +! + gfunx(x,y,e2)=x/(x**2+y**2+e2) +! +! write(6,*)'inside greenfxold' + eps2=1.d-20 +! compute integrals involving the Green function for Ex: + do j=1,ny+1 + y0=hy*(j-1) + y1=hy*j + do i=1,nx+1 + x0=hx*(i-1) + x1=hx*i +!----------- + fmp=gfunx(x0,y0,eps2) + g(i,j)=fmp*hx*hy +!----------- + enddo + enddo +!reflections: + do j=1,ny + do i=1+nx,nx+nx + g(i,j)=-g(n1-i+2,j) + enddo + enddo + do j=1+ny,ny+ny + do i=1,nx + g(i,j)=g(i,n2-j+2) + enddo + enddo + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j)=-g(n1-i+2,n2-j+2) + enddo + enddo +! +! compute FFT of the Green function + scale=1.0 +! write(6,*)'calling fft2dhpf in greenfx' + call fft2dhpf(n1,n2,1,0,scale,0,g,gxtr) +! write(6,*)'returned from fft2dhpf in greenfx' + return + end +! +!============================================================= +! + subroutine greenfyold(gxtr,rho,nx,ny,n1,n2) +! green function routine. + implicit double precision(a-h,o-z) + double complex g,gxtr + dimension g(n1,n2),gxtr(n2,n1) + dimension rho(nx,ny),fyg(nx,ny) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi +! + gfuny(x,y,e2)=y/(x**2+y**2+e2) +! +! write(6,*)'inside greenfyold' + eps2=1.d-20 +! compute integrals involving the Green function for Ey: + do j=1,ny+1 + y0=hy*(j-1) + y1=hy*j + do i=1,nx+1 + x0=hx*(i-1) + x1=hx*i +!----------- + fmp=gfuny(x0,y0,eps2) + g(i,j)=fmp*hx*hy +!----------- + enddo + enddo +!reflections: + do j=1,ny + do i=1+nx,nx+nx + g(i,j)=g(n1-i+2,j) + enddo + enddo + do j=1+ny,ny+ny + do i=1,nx + g(i,j)=-g(i,n2-j+2) + enddo + enddo + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j)=-g(n1-i+2,n2-j+2) + enddo + enddo +! compute FFT of the Green function + scale=1.0 +! write(6,*)'calling fft2dhpf in greenfy' + call fft2dhpf(n1,n2,1,0,scale,0,g,gxtr) +! write(6,*)'returned from fft2dhpf in greenfy' + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d.f b/OpticsJan2020/MLI_light_optics/Src/spch3d.f new file mode 100755 index 0000000..22bcdf9 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/spch3d.f @@ -0,0 +1,1274 @@ +!*********************************************************************** +! +! IMPACT 3D space charge routines +! Copyright 2001 University of California +! +! subroutine SPCH3D(c,ex,ey,ez,msk,Np,Ntot, +! & Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,rparams,cparams) +! Arguments in SPCH3D(...) +! c in:out (1:5:2,*) are x,y,z coordinates of particles +! NB: in the rest of MLI, col.5 denotes time-of-flight (i.e., phase), +! but prior to calling the space-charge routines, it is +! converted to longitudinal position z +! (2:6:4,*) are momenta and not used here +! ex,ey,ez :out electric field at particles +! msk :in flag indicating valid particles +! Np :in number of particles (good and bad) on this processor +! Ntot :in number of (good) particles on all processors +! Nx,Ny,Nz :in dimensions of grid on the regular sized grid +! N1,N2,N3 :in dimensions of the bigger (usually doubled) grid +! N3a :in =Nz for longitudinal periodic BCs, =2*Nz for open +! Nadj :in =0 for long. open or Dirichlet BCs, >=1 for periodic +! +! Globals: +! ISolve :in flag denoting Poisson solver to use +! 1 for default Infinite Domain +! 1x for ANAG ID +! 2x for ANAG Homogenous Dirichlet +! 30 for Chombo AMR Homogenous Dirichlet +! 4x for Chombo AMR Infinite Domain +! here "x" denotes the discretization to use +! 0 for Spectral (MLI-style) +! 1 for Laplace (Chombo-style 7-point) +! 2 for Mehrstellen O(h^6) +! 3 for Mehrstellen O(h^4) +! +!*********************************************************************** + subroutine spch3d(c,ex,ey,ez,msk,np,ntot, & + & nx,ny,nz,n1,n2,n3,n3a,nadj,rparams,cparams) + use parallel + implicit none +!Arguments + integer np,ntot,nx,ny,nz,n1,n2,n3,n3a,nadj + double precision c(6,np) + double precision ex(np),ey(np),ez(np) + logical msk(np) + double precision rparams + character*16 cparams + dimension rparams(60),cparams(60) +!Local variables + double precision phi(nx,ny,nz) + integer i,j,k ,ip +!Globals + integer iverbose + common/showme/iverbose + integer idirectfieldcalc,idensityfunction,isolve,idum + common/newpoisson/idirectfieldcalc,idensityfunction,isolve,idum(2) + integer idirich + common/dirichlet/idirich + doubleprecision xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi +!Externals + +!Execute + +!----------------------------------------------------------------------- + +! save particle data in real coordinates for the Chombo programs + if (iverbose.GT.9.AND.idproc.EQ.0) then + write(6,*) 'Writing particle coords to file MLI.Pxyz.dat ...' + open(90,file='MLI.Pxyz.dat') + write(90,9001) ((c(i,ip),i=1,5,2),ip=1,Np) + close(90) + 9001 format(3(1x,E16.9)) + endif + +!----------------------------------------------------------------------- + +!dbs -- added other solvers and formatted output of phi + if( iverbose .ge. 5 .AND. idproc .eq. 0 ) + & write(6,*) 'in SPCH3D with solver,dirich = ',isolve,idirich + + if( isolve .ge. 1 .AND. isolve .lt. 10 )then + ! default open BC (infinite domain) solver + ![NOTE: the value of isolve isnt important because SPCH3D1() + ! ignores the fft_stencil input keyword because it only + ! implements the spectral stencil.] + if( idirich .ne. 0 )then + write(6,*) 'error: SPCH3D1: Dirichlet BC not supported' + stop 'SPCH3D1a' + endif + if( iverbose .ge. 6 .AND. idproc .eq. 0 ) + & write(6,*) 'SPCH3D: calling SPCH3D1' + call SPCH3D1( c ,ex,ey,ez ,msk & + & ,np,ntot,nx,ny,nz,n1,n2,n3,n3a,nadj,phi ) + + elseif( isolve .ge. 10 .and. isolve .lt. 20 )then + ! ANAG infinite domain solver + if( idirectfieldcalc .ne. 0 )then + write(6,*) 'error: SPCH3D2: solving_for=E not supported' + stop 'SPCH3D2a' + endif + if( idirich .ne. 0 )then + write(6,*) 'error: SPCH3D2: Dirichlet BC not supported' + stop 'SPCH3D2b' + endif + if( iverbose .ge. 6 .AND. idproc .eq. 0 ) + & write(6,*) 'SPCH3D: calling SPCH3D2' + call SPCH3D2( c ,ex,ey,ez ,msk & + & ,np,ntot,nx,ny,nz,n1,n2,n3,n3a,nadj,phi ) + + elseif( isolve .ge. 20 .and. isolve .lt. 30 )then + ! ANAG solver for homogenous Dirichlet BCs + if( idirectfieldcalc .ne. 0 )then + write(6,*) 'error: SPCH3DBC0: solving_for=E not supported' + stop 'SPCH3D0a' + endif + if( idirich .EQ. 0 )then + write(6,*) 'warning: SPCH3D: non-Dirichlet BC is inconsistent' + & ,' with SPCH3DBC0 solver.' + stop 'SPCH3D0b' + endif + if( iverbose .ge. 6 .AND. idproc .eq. 0 ) + & write(6,*) 'SPCH3D: calling SPCH3DBC0' + call SPCH3DBC0( c ,ex,ey,ez ,msk & + & ,np,ntot,nx,ny,nz,n1,n2,n3,n3a,nadj,phi ) + + elseif( isolve .ge. 30 .and. isolve .lt. 50 )then + ! ANAG Chombo AMR solver for infinite domain (open) or homogenous Dirichlet BCs + if( idirectfieldcalc .ne. 0 )then + write(6,*) 'error: SPCH3DAMR: solving_for=E not supported' + stop 'SPCH3DEAb' + endif + if( iverbose .ge. 6 .AND. idproc .eq. 0 ) + & write(6,*) 'SPCH3D: calling SPCH3DAMR' + call SPCH3DAMR( c ,ex,ey,ez ,msk & + & ,np,ntot,nx,ny,nz,n1,n2,n3,n3a,nadj,phi ) + + else + write(6,*) 'error: unknown solver = ',isolve + stop 'SPCH3D' + endif + +!----------------------------------------------------------------------- + + if( iverbose .ge. 10 .and. idproc .eq. 0 .AND. + & idirectfieldcalc .EQ. 0 )then !no phi is solving_for=E + write(6,*) 'Writing grid phi data to unit 86 ...' + write(86,8601)' phi on grid (',nx,ny,nz,'), h=' ,hx,hy,hz + write(86,*)' I J K X Y Z phi' + do k = 1 ,nz + do j = 1 ,ny + do i = 1 ,nx + write(86,8602) i,j,k + & ,xmin+(i-1)*hx,ymin+(j-1)*hy,zmin+(k-1)*hz ,phi(i,j,k) + enddo + enddo + enddo + elseif( iverbose .ge. 8 .and. idproc .eq. 0 )then + write(6,*) 'Writing grid centerline phi data to unit 86 ...' + write(86,8601)' phi on grid (',nx,ny,nz,'), h=' ,hx,hy,hz + write(86,*)' I J K X Y Z phi' + i=nx/2+1 + j=ny/2+1 + do k = 1 ,nz + write(86,8602) i,j,k + & ,xmin+(i-1)*hx,ymin+(j-1)*hy,zmin+(k-1)*hz ,phi(i,j,k) + enddo + i=nx/2+1 + k=nz/2+1 + do j = 1 ,ny + write(86,8602) i,j,k + & ,xmin+(i-1)*hx,ymin+(j-1)*hy,zmin+(k-1)*hz ,phi(i,j,k) + enddo + j=ny/2+1 + k=nz/2+1 + do i = 1 ,nx + write(86,8602) i,j,k + & ,xmin+(i-1)*hx,ymin+(j-1)*hy,zmin+(k-1)*hz ,phi(i,j,k) + enddo + write(6,*) 'Writing E on particles 1-10 to unit 87 ...' + write(87,8701)'p X Y Z Ex Ey Ez' + do ip = 1,10 + write(87,8702) ip,(c(i,ip),i=1,5,2),ex(ip),ey(ip),ez(ip) + enddo + endif + if( iverbose .ge. 9 .and. idproc .eq. 0 )then + write(6,*) 'Writing particle XYZ,E data to MLI.Pxyze.dat ...' + open(90,file='MLI.Pxyze.dat') + write(90,9002)((c(i,ip),i=1,5,2),ex(ip),ey(ip),ez(ip),ip=1,Np) + close(90) + endif + 8601 format(A,1x,3(I3,1x),A,1x,1P,3(E11.5,1x)) + 8602 format(1x,3(1X,I3),1P,3(1X,E15.8),4(1X,E15.8)) + 8701 format(1x,A) + 8702 format(1x,I2,1P,6(1x,E16.9)) + 9002 format(1P,6(1x,E16.9)) +!dbs +!Done + if( IVerbose .GT. 19 ) stop 'SPCHDONE' + if( iverbose .ge. 5 .AND. idproc .eq. 0 ) + & write(6,*) 'leaving SPCH3D' + + return + end +! +!*********************************************************************** + subroutine spch3d1(c,ex,ey,ez,msk,np,ntot, & + & nx,ny,nz,n1,n2,n3,n3a,nadj,rho) + use parallel + use spchdata + use intgreenfn + use ml_timer + implicit double precision(a-h,o-z) + real*8, dimension(6,np) :: c + logical, dimension(np) :: msk + real*8, dimension(np) :: ex,ey,ez + real*8, dimension(nx,ny,nz) :: rho,exg,eyg,ezg,rhosum + type (griddata) :: griddims + integer :: idebug=0 +cryne 8/4/2004 integer :: idebug=1 +!in module spchdata complex*16,dimension(n1,n2,n3a) :: rho2 +!in module spchdata complex*16,dimension(n3a,n2,n1) :: grnxtr,rho2xtr + +! rho=charge density on the grid +! rho2=...on doubled grid +! rho2xtr=...xformed (by fft) and transposed +! grnxtr=green function, xformed, transposed +! weights, indices associated with area weighting: + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi +!XXX common/accum/at10,at21,at32,at43,at54,at65,at76,at70 + common/showme/iverbose + common/gxyzsave/xmin0,xmax0,ymin0,ymax0,zmin0,zmax0,kfixbdy,madegr + common/gridxtra/xsml,xbig,ysml,ybig,zsml,zbig + common/newpoisson/idirectfieldcalc,idensityfunction,idum(3) + save idebug + +! if(idproc.eq.0)write(6,*)'inside spch3d' + iexactrho=0 + + iunity=1 + munity=-1 + izero=0 + scale=1.d0 + hxyz=hx*hy*hz + hxyzi=hxi*hyi*hzi + n123a=n1*n2*n3a + + if (idproc.eq.0.and.iverbose.ge.3) then + write(6,*) ' In spch3d1() ...' + write(6,*) ' {np ntot} = {',np,ntot,'}' + write(6,*) ' {nx ny nz} = {',nx,ny,nz,'}' + write(6,*) ' {hx hy hz} = {',hx,hy,hz,'}' + write(6,*) ' {n1 n2 n3} = {',n1,n2,n3,'}' + write(6,*) ' {hxi hyi hzi} = {',hxi,hyi,hzi,'}' + write(6,*) ' {n3a nadj} = {',n3a,nadj,'}' + write(6,*) ' hxyz = ',hxyz + write(6,*) ' hxyzi = ',hxyzi + write(6,*) ' nxyz = ',nx*ny*nz + write(6,*) ' n123 = ',n1*n2*n3 + write(6,*) ' n123a = ',n1*n2*n3a + end if +!====================================================================== +! deposit charge on the grid: + call increment_timer('rhoslo3d',0) + call rhoslo3d(c,rho,msk,np,nx,ny,nz,nadj) + call MPI_ALLREDUCE(rho,rhosum,nx*ny*nz,mreal,mpisum,lworld,ierror) + rho=rhosum + call increment_timer('rhoslo3d',1) +!-------- + if(iexactrho.eq.1)then + glrhochk=sum(rho) +! if(idproc.eq.0)write(6,*)'(exact rho): global sum = ',glrhochk + call getrms(c,xrms,yrms,zrms,np) +! if(idproc.eq.0)write(6,*)'xrms,yrms,zrms=',xrms,yrms,zrms + xmac=sqrt(5.d0)*xrms + ymac=sqrt(5.d0)*yrms + zmac=sqrt(5.d0)*zrms +! if(idproc.eq.0)write(6,*)'xmac,ymac,zmac=',xmac,ymac,zmac + rho=0.d0 + do k=1,nz + z=zmin+(k-1)*hz + do j=1,ny + y=ymin+(j-1)*hy + do i=1,nx + x=xmin+(i-1)*hx +! if((x/xbig)**2+(y/ybig)**2+(z/zbig)**2 .le.1.d0)rho(i,j,k)=1.d0 + if((x/xmac)**2+(y/ymac)**2+(z/zmac)**2 .le.1.d0)rho(i,j,k)=1.d0 + enddo + enddo + enddo + glrhonew=sum(rho) +! if(idproc.eq.0)write(6,*)'glrhonew=',glrhonew + rho=rho*glrhochk/glrhonew + glrhochk=sum(rho) +! if(idproc.eq.0)write(6,*)'new global sum of rho = ',glrhochk + endif +!ryne august 1, 2002 +!ryne moved normalization out of rhoslo to here: + rho=rho/(hx*hy*hz*ntot) + call system_clock(count=iticks1) +!-------- + ! print rho on the grid + if(iverbose.GT.9.AND.idproc.EQ.0)then + write(6,*) 'Writing grid rho data to unit 85 ...' + write(85,*)' SPCH3D rho on grid (',nx,ny,nz,'), h=',hx,hy,hz + write(85,*)' I J K X Y Z rho' + do k = 1 ,nz + do j = 1 ,ny + do i = 1 ,nx + write(85,8501) i,j,k + $ ,xmin+(i-1)*hx,ymin+(j-1)*hy,zmin+(k-1)*hz + $ ,rho(i,j,k) + enddo + enddo + enddo + 8501 format(1x,3(1X,I3),1P,3(1X,E15.8),1X,E15.8) + endif +!-------- +! keep a copy of rho for diagnostics: + if(iexactrho.eq.1)rhosum=rho + checknorm=hx*hy*hz*sum(rhosum) +! store rho in lower left quadrant of doubled grid: + do k=1,n3a + do j=1,n2 + do i=1,n1 + rho2(i,j,k)=0.d0 + enddo + enddo + enddo +cryne forall(i=1:nx,j=1:ny,k=1:nz)rho2(i,j,k)=cmplx(rho(i,j,k),0.) + do k=1,nz + do j=1,ny + do i=1,nx + rho2(i,j,k)=rho(i,j,k) + enddo + enddo + enddo +! fft the charge density: + call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,rho2xtr) +!====================================================================== +!HERE IS THE OLD IMPLEMENTATION THAT USES PHI AND CSHIFTS: + if(idirectfieldcalc.ne.1)then +! if(idproc.eq.0)write(6,*)'******obtaining scalar potential******' + call increment_timer('greenf3d',0) + if(madegr.eq.0 .or. kfixbdy.eq.0)then +! if (idproc.eq.0) then +! write(12,*) ' spch3d::spch3d1:' +! write(12,*) ' computing green function for phi' +! end if + griddims%NxIntrvl=nx-1 + griddims%NyIntrvl=ny-1 + griddims%NzIntrvl=nz-1 + griddims%Nx=nx; griddims%Nx2=n1; griddims%hx=hx + griddims%Ny=ny; griddims%Ny2=n2; griddims%hy=hy + griddims%Nz=nz; griddims%Nz2=n3; griddims%hz=hz + griddims%Vh=hxyz + griddims%Vhinv=hxyzi + if (idensityfunction.eq.0) then +! write(12,*) ' using function greenphi' + call greenphi(rho2,nx,ny,nz,n1,n2,n3,n3a,nadj) + else if (idensityfunction.eq.1) then +! write(12,*) ' using function intgreenphi' + call intgreenphi(griddims,rho2) + end if +c ===DBG=== +! write(6,*) ' === G_phi array ===' +! write(6,*) ' {hx,hy,hz} = {',hx,',',hy,',',hz,'}' +! gmn=rho2(1,1,1) +! gmx=gmn +! agmn=abs(gmn) +! agmx=agmn +! do iz=1,n1 +! do iy=1,n2 +! do ix=1,n1 +! g=rho2(ix,iy,iz) +! ag=abs(g) +! if(g.lt.gmn) gmn=g +! if(g.gt.gmx) gmx=g +! if(ag.lt.agmn) agmn=ag +! if(ag.gt.agmx) agmx=ag +! end do +! end do +! end do +! write(6,*) ' min(G_phi) =',gmn +! write(6,*) ' max(G_phi) =',gmx +! write(6,*) ' min(abs(G_phi)) =',agmn +! write(6,*) ' max(abs(G_phi)) =',agmx +! do iz=1,4 +! do iy=1,4 +! do ix=1,4 +! write(6,*) ix,iy,iz,rho2(ix,iy,iz) +! end do +! end do +! end do +! do iz=1,nz+1 +! do iy=1,ny+1 +! do ix=1,nx+1 +! g=rho2(ix,iy,iz) +! if (g.lt.0) write(6,'(3(1x,i3),2x,1pe12.5))') & +! & ix-1,iy-1,iz-1,g +! end do +! end do +! end do +c ========= + call increment_timer('greenf3d',1) + call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,xgrnxtr) + madegr=1 + else +! if(idproc.eq.0)write(12,*)'using saved green function' + call increment_timer('greenf3d',1) + endif + grnxtr=rho2xtr*xgrnxtr/n123a + call fft3dhpf(n3a,n2,n1,munity,scale,izero,nadj,grnxtr,rho2) + rho(1:nx,1:ny,1:nz)=hxyz*real(rho2(1:nx,1:ny,1:nz)) +! obtain the electric fields: +!XXX exg=0.d0 +!XXX eyg=0.d0 +!XXX ezg=0.d0 + exg=cshift(rho,-1,1) + exg=exg-cshift(rho,1,1) + exg=exg*(0.5*hxi) + eyg=cshift(rho,-1,2) + eyg=eyg-cshift(rho,1,2) + eyg=eyg*(0.5*hyi) +!XXX exg=0.5*hxi*(cshift(rho,-1,1)-cshift(rho,1,1)) +!XXX eyg=0.5*hyi*(cshift(rho,-1,2)-cshift(rho,1,2)) +! ezg=0.5*hzi*(cshift(rho,-1,3)-cshift(rho,1,3)) +! the previous statement (ezg=...) causes a crash on seaborg. Replace with: + ezg=cshift(rho,-1,3) + ezg=ezg-cshift(rho,1,3) + ezg=ezg*(0.5*hzi) + else + !======================================================= + ! New implementation that solves for E directly: + ! compute the Green function on the grid (use rho2 for storage): + call increment_timer('greenf3d',0) + if(madegr.eq.0 .or. kfixbdy.eq.0)then +! if(idproc.eq.0)write(12,*)'computing green function' + call greenfx(rho2,nx,ny,nz,n1,n2,n3,n3a,nadj) + call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,xgrnxtr) + call greenfy(rho2,nx,ny,nz,n1,n2,n3,n3a,nadj) + call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,ygrnxtr) + call greenfz(rho2,nx,ny,nz,n1,n2,n3,n3a,nadj) + call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,zgrnxtr) + madegr=1 + else +! if(idproc.eq.0)write(12,*)'using saved green function' + endif + call increment_timer('greenf3d',1) + !======================================================== +! if(idproc.eq.0)write(6,*)'starting convolution' + !---------convolution------------ + grnxtr=rho2xtr*xgrnxtr/n123a + call fft3dhpf(n3a,n2,n1,munity,scale,izero,nadj,grnxtr,rho2) + exg(1:nx,1:ny,1:nz)=hxyz*real(rho2(1:nx,1:ny,1:nz)) + + grnxtr=rho2xtr*ygrnxtr/n123a + call fft3dhpf(n3a,n2,n1,munity,scale,izero,nadj,grnxtr,rho2) + eyg(1:nx,1:ny,1:nz)=hxyz*real(rho2(1:nx,1:ny,1:nz)) + + grnxtr=rho2xtr*zgrnxtr/n123a + call fft3dhpf(n3a,n2,n1,munity,scale,izero,nadj,grnxtr,rho2) + ezg(1:nx,1:ny,1:nz)=hxyz*real(rho2(1:nx,1:ny,1:nz)) + !----done with convolution------- + endif + +! if(idproc.eq.0)write(6,*)'done with convolution' +!--------------- + if((idebug.eq.1.or.iverbose.ge.8) .and. idproc.eq.0)then + write(6,*)'writing out potential and fields' + do i=1,nx + j=ny/2+1 + k=nz/2+1 + xval=xmin+(i-1)*hx + yval=ymin+(j-1)*hy + zval=zmin+(k-1)*hz + del2=0.d0 + if(i.gt.1 .and. i.lt.nx)then + del2=(exg(i+1,j,k)-exg(i-1,j,k))*0.5*hxi+ & + & (eyg(i,j+1,k)-eyg(i,j-1,k))*0.5*hyi+ & + & (ezg(i,j,k+1)-ezg(i,j,k-1))*0.5*hzi + endif + write(61,1001)xval,yval,zval, & + & rho(i,j,k),exg(i,j,k),eyg(i,j,k),ezg(i,j,k) & + & ,rhosum(i,j,k),del2 + enddo + write(61,*)' ' + call myflush(61) + do j=1,ny + i=nx/2+1 + k=nz/2+1 + xval=xmin+(i-1)*hx + yval=ymin+(j-1)*hy + zval=zmin+(k-1)*hz + del2=0.d0 + if(j.gt.1 .and. j.lt.ny)then + del2=(exg(i+1,j,k)-exg(i-1,j,k))*0.5*hxi+ & + & (eyg(i,j+1,k)-eyg(i,j-1,k))*0.5*hyi+ & + & (ezg(i,j,k+1)-ezg(i,j,k-1))*0.5*hzi + endif + write(62,1001)xval,yval,zval, & + & rho(i,j,k),exg(i,j,k),eyg(i,j,k),ezg(i,j,k) & + & ,rhosum(i,j,k),del2 + enddo + write(62,*)' ' + call myflush(62) + do k=1,nz + i=nx/2+1 + j=ny/2+1 + xval=xmin+(i-1)*hx + yval=ymin+(j-1)*hy + zval=zmin+(k-1)*hz + del2=0.d0 + if(k.gt.1 .and. k.lt.nz)then + del2=(exg(i+1,j,k)-exg(i-1,j,k))*0.5*hxi+ & + & (eyg(i,j+1,k)-eyg(i,j-1,k))*0.5*hyi+ & + & (ezg(i,j,k+1)-ezg(i,j,k-1))*0.5*hzi + endif + write(63,1001)xval,yval,zval, & + & rho(i,j,k),exg(i,j,k),eyg(i,j,k),ezg(i,j,k) & + & ,rhosum(i,j,k),del2 + enddo + write(63,*)' ' + call myflush(63) + 1001 format(9(1pe13.6,1x)) + + endif + if( IVerbose .GT. 11 .AND. idproc .EQ. 0 )then + write(6,*) 'Writing grid E data to unit 88 ...' + write(88,8601)' phi on grid (',nx,ny,nz,'), h=' ,hx,hy,hz + write(88,8701)' I J K X Y ' + & ,' Z Ex ' + & ,'Ey Ez' + do k = 1 ,nz + do j = 1 ,ny + do i = 1 ,nx + write(88,8602) i,j,k,xmin+(i-1)*hx,ymin+(j-1)*hy + & ,zmin+(k-1)*hz + & ,exg(i,j,k),eyg(i,j,k),ezg(i,j,k) + enddo + enddo + enddo + endif + 8601 format(A,1x,3(I3,1x),A,1x,1P,3(E11.5,1x)) + 8602 format(1x,3(1X,I3),1P,3(1X,E15.8),4(1X,E15.8)) + 8701 format(1x,A,A,A) + + + if(idebug.eq.1)then + write(6,*)'PE',idproc,':hxyz,n123a=',hxyz,n123a + write(6,*)'PE',idproc,':rho2xtr(4,6,8),=',rho2xtr(4,6,8) + write(6,*)'PE',idproc,':xgrnxtr(4,6,8),=',xgrnxtr(4,6,8) + endif + if(idebug.eq.1)idebug=0 +!--------------- +! +! +! if(idproc.eq.0)write(6,*)'interpolating electric fields' +! interpolate electric field at particle postions: + call increment_timer('ntrslo3d',0) + call ntrslo3d(c,exg,eyg,ezg,ex,ey,ez,msk,nx,ny,nz,np,nadj) + call increment_timer('ntrslo3d',1) +! if(idproc.eq.0)write(6,*)'done interpolating; leaving spch3d' + return + end + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + subroutine rhoslo3d(coord,rho,msk,np,nx,ny,nz,nadj) +cryne 08/24/2001 use hpf_library + implicit double precision(a-h,o-z) + logical msk + dimension coord(6,np),msk(np) + dimension rho(nx,ny,nz) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + common/showme/iverbose +! if(idproc.eq.0) write(6,*)'inside rhoslo3d' +! write(6,*)'xmin,xmax=',xmin,xmax +! write(6,*)'nx,ny,nz=',nx,ny,nz +! write(6,*)'nadj=',nadj +! xminnn=minval(coord(1,:)) +! xmaxxx=maxval(coord(1,:)) +! write(6,*)'xminnn,xmaxxx=',xminnn,xmaxxx +cryne 6/25/2002 do i=1,np + rho=0. + do n=1,np +c INSERT STATEMENT HERE TO SKIP IF MSK(N)=.FALSE. + indx=(coord(1,n)-xmin)*hxi + 1 + jndx=(coord(3,n)-ymin)*hyi + 1 + kndx=(coord(5,n)-zmin)*hzi + 1 + indxp1=indx+1 + jndxp1=jndx+1 + kndxp1=kndx+1 + ab=((xmin-coord(1,n))+indx*hx)*hxi + de=((ymin-coord(3,n))+jndx*hy)*hyi + gh=((zmin-coord(5,n))+kndx*hz)*hzi +!------- + imin=indx + imax=indx + jmin=jndx + jmax=jndx + kmin=kndx + kmax=kndx + if((imin.lt.1).or.(imax.gt.nx-1))then + write(6,*)'error in rhoslo3d: imin,imax=',imin,imax + write(6,*)'nx,xmin,xmax,hx=',nx,xmin,xmax,hx + write(6,*)'nadj=',nadj + call myexit + endif + if((jmin.lt.1).or.(jmax.gt.ny-1))then + write(6,*)'error in rhoslo3d: jmin,jmax=',jmin,jmax + call myexit + endif + if(nadj.eq.0)then + if((kmin.lt.1).or.(kmax.gt.nz-1))then + write(6,*)'error in rhoslo3d (nadj=0): kmin,kmax=',kmin,kmax + call myexit + endif + endif + if(nadj.eq.1)then + if((kmin.lt.1).or.(kmax.gt.nz))then + write(6,*)'error in rhoslo3d (nadj=1): kmin,kmax=',kmin,kmax + call myexit + endif + endif +!------- + if(nadj.eq.1)then + if(kndxp1.eq.nz+1)kndxp1=1 + endif +!1 (i,j,k): + rho(indx,jndx,kndx)=rho(indx,jndx,kndx)+ab*de*gh +!2 (i,j+1,k): + rho(indx,jndxp1,kndx)=rho(indx,jndxp1,kndx)+ab*(1.-de)*gh +!3 (i,j+1,k+1): + rho(indx,jndxp1,kndxp1)=rho(indx,jndxp1,kndxp1)+ab*(1.-de)*(1.-gh) +!4 (i,j,k+1): + rho(indx,jndx,kndxp1)=rho(indx,jndx,kndxp1)+ab*de*(1.-gh) +!5 (i+1,j,k+1): + rho(indxp1,jndx,kndxp1)=rho(indxp1,jndx,kndxp1)+(1.-ab)*de*(1.-gh) +!6 (i+1,j+1,k+1): + rho(indxp1,jndxp1,kndxp1)= & + &rho(indxp1,jndxp1,kndxp1)+(1.-ab)*(1.-de)*(1.-gh) +!7 (i+1,j+1,k): + rho(indxp1,jndxp1,kndx)=rho(indxp1,jndxp1,kndx)+(1.-ab)*(1.-de)*gh +!8 (i+1,j,k): + rho(indxp1,jndx,kndx)=rho(indxp1,jndx,kndx)+(1.-ab)*de*gh + enddo +! +cryne august 1, 2002: +cccc ngood=count(msk) +cccc write(6,*)'ngood=',ngood +cccc rho=rho/ngood +!wrong rho=rho/ngood*hxi*hyi*hzi +! if(idproc.eq.0)write(6,*)'leaving rhoslo3d' +! rhochk=sum(rho) +! write(6,*)'[rhoslo3d]sum(rho)=',rhochk + return + end + + subroutine ntrslo3d(coord,exg,eyg,ezg,ex,ey,ez,msk,nx,ny,nz,np, & + & nadj) + use parallel + implicit double precision(a-h,o-z) + logical msk + dimension coord(6,np) + dimension exg(nx,ny,nz),eyg(nx,ny,nz),ezg(nx,ny,nz) +!hpf$ distribute exg(*,*,block) +!hpf$ align (*,*,:) with exg(*,*,:) :: eyg,ezg + dimension ex(np),ey(np),ez(np),msk(np) + dimension abz(np),dez(np),ghz(np),indz(np),jndz(np),kndz(np), + &indzp1(np),jndzp1(np),kndzp1(np) +!hpf$ template t1(np) +!hpf$ distribute t1(block) +!hpf$ align (:) with t1(:) :: ex,ey,ez,msk,ab,de,gh +!hpf$ align (:) with t1(:) :: indx,jndx,kndx,indxp1,jndxp1,kndxp1 + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi +! if(idproc.eq.0)write(6,*)'inside ntrslo3d' +! if(idproc.eq.0)then +! do n=1,np +! if(indx(n).lt.1 .or. indx(n).gt.nx)write(6,*)'error: indx(n)' +! enddo +! do n=1,np +! if(jndx(n).lt.1 .or. jndx(n).gt.ny)write(6,*)'error: jndx(n)' +! enddo +! do n=1,np +! if(kndx(n).lt.1 .or. kndx(n).gt.nz)write(6,*)'error: kndx(n)' +! enddo +! do n=1,np +! if(indxp1(n).lt.1.or.indxp1(n).gt.nx)write(6,*)'err:indxp1(n)' +! enddo +! do n=1,np +! if(jndxp1(n).lt.1.or.jndxp1(n).gt.ny)write(6,*)'err:jndxp1(n)' +! enddo +! do n=1,np +! if(kndxp1(n).lt.1.or.kndxp1(n).gt.nz)write(6,*)'err:kndxp1(n)' +! enddo +! endif +cryne forall(n=1:np)ex(n)= + do 100 n=1,np + indx=(coord(1,n)-xmin)*hxi + 1 + jndx=(coord(3,n)-ymin)*hyi + 1 + kndx=(coord(5,n)-zmin)*hzi + 1 + indxp1=indx+1 + jndxp1=jndx+1 + kndxp1=kndx+1 +!cryne August 4, 2004 ------- + if(nadj.eq.1)then + if(kndxp1.eq.nz+1)kndxp1=1 + endif +!cryne ------- + ab=((xmin-coord(1,n))+indx*hx)*hxi + de=((ymin-coord(3,n))+jndx*hy)*hyi + gh=((zmin-coord(5,n))+kndx*hz)*hzi + ex(n)= & + & exg(indx,jndx,kndx)*ab*de*gh + &+exg(indx,jndxp1,kndx)*ab*(1.-de)*gh + &+exg(indx,jndxp1,kndxp1)*ab*(1.-de)*(1.-gh) + &+exg(indx,jndx,kndxp1)*ab*de*(1.-gh) + &+exg(indxp1,jndx,kndxp1)*(1.-ab)*de*(1.-gh) + &+exg(indxp1,jndxp1,kndxp1)*(1.-ab)*(1.-de)*(1.-gh) + &+exg(indxp1,jndxp1,kndx)*(1.-ab)*(1.-de)*gh + &+exg(indxp1,jndx,kndx)*(1.-ab)*de*gh + + ey(n)= & + & eyg(indx,jndx,kndx)*ab*de*gh + &+eyg(indx,jndxp1,kndx)*ab*(1.-de)*gh + &+eyg(indx,jndxp1,kndxp1)*ab*(1.-de)*(1.-gh) + &+eyg(indx,jndx,kndxp1)*ab*de*(1.-gh) + &+eyg(indxp1,jndx,kndxp1)*(1.-ab)*de*(1.-gh) + &+eyg(indxp1,jndxp1,kndxp1)*(1.-ab)*(1.-de)*(1.-gh) + &+eyg(indxp1,jndxp1,kndx)*(1.-ab)*(1.-de)*gh + &+eyg(indxp1,jndx,kndx)*(1.-ab)*de*gh + + ez(n)= & + & ezg(indx,jndx,kndx)*ab*de*gh + &+ezg(indx,jndxp1,kndx)*ab*(1.-de)*gh + &+ezg(indx,jndxp1,kndxp1)*ab*(1.-de)*(1.-gh) + &+ezg(indx,jndx,kndxp1)*ab*de*(1.-gh) + &+ezg(indxp1,jndx,kndxp1)*(1.-ab)*de*(1.-gh) + &+ezg(indxp1,jndxp1,kndxp1)*(1.-ab)*(1.-de)*(1.-gh) + &+ezg(indxp1,jndxp1,kndx)*(1.-ab)*(1.-de)*gh + &+ezg(indxp1,jndx,kndx)*(1.-ab)*de*gh + 100 continue +! if(idproc.eq.0)write(6,*)'leaving ntrslo3d' + return + end +c +c block data etimes +c common/accum/at10,at21,at32,at43,at54,at65,at76,at70 +c data at10,at21,at32,at43,at54,at65,at76,at70/0.,0.,0.,0.,0.,0.,0.,& +c & 0./ +c end +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine getrms(cblock,xrms,yrms,zrms,np) + use beamdata + use rays + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'map.inc' + real*8, dimension(6,np) :: cblock +! + dimension diag(16),rdiag(16) +! if(1.gt.0)return +! rms quantities: + den1=1./nrays + den2=den1*den1 + econ=1.0 + xl=sl + xk=1./xl + gambet=gamma*beta + z=arclen +! xbar=sum(cblock(1,1:nraysp))*xl*den1 +! ybar=sum(cblock(3,1:nraysp))*xl*den1 +! zbar=sum(cblock(5,1:nraysp))*(beta/xk)*den1 +! sq1=sum(cblock(1,1:nraysp)*cblock(1,1:nraysp))*xl**2 +! sq2=sum(cblock(2,1:nraysp)*cblock(2,1:nraysp))/gambet**2*econ**2 +! sq3=sum(cblock(3,1:nraysp)*cblock(3,1:nraysp))*xl**2 +! sq4=sum(cblock(4,1:nraysp)*cblock(4,1:nraysp))/gambet**2*econ**2 +! xpx=sum(cblock(1,1:nraysp)*cblock(2,1:nraysp))*xl/gambet*econ +! ypy=sum(cblock(3,1:nraysp)*cblock(4,1:nraysp))*xl/gambet*econ + diag(1)=sum(cblock(1,1:nraysp))*den1 + diag(2)=sum(cblock(3,1:nraysp))*den1 + diag(3)=sum(cblock(5,1:nraysp))*den1 + diag(4)=sum(cblock(1,1:nraysp)*cblock(1,1:nraysp)) + diag(5)=sum(cblock(2,1:nraysp)*cblock(2,1:nraysp)) + diag(6)=sum(cblock(3,1:nraysp)*cblock(3,1:nraysp)) + diag(7)=sum(cblock(4,1:nraysp)*cblock(4,1:nraysp)) + diag(8)=sum(cblock(5,1:nraysp)*cblock(5,1:nraysp)) + diag(9)=sum(cblock(6,1:nraysp)*cblock(6,1:nraysp)) + diag(10)=sum(cblock(1,1:nraysp)*cblock(2,1:nraysp)) + diag(11)=sum(cblock(3,1:nraysp)*cblock(4,1:nraysp)) + diag(12)=sum(cblock(5,1:nraysp)*cblock(6,1:nraysp)) + call MPI_ALLREDUCE(diag,rdiag,12,mreal,mpisum,lworld,ierror) +c------- + xbar=rdiag(1) + ybar=rdiag(2) + zbar=rdiag(3) + sq1=rdiag(4) + sq2=rdiag(5) + sq3=rdiag(6) + sq4=rdiag(7) + sq5=rdiag(8) + sq6=rdiag(9) + xpx=rdiag(10) + ypy=rdiag(11) + zpz=rdiag(12) +c------- + epsx2=(sq1*sq2-xpx*xpx)*den2 + epsy2=(sq3*sq4-ypy*ypy)*den2 + epsz2=(sq5*sq6-zpz*zpz)*den2 + xrms=sqrt( sq1*den1 ) + yrms=sqrt( sq3*den1 ) + zrms=sqrt( sq5*den1 ) + pxrms=sqrt( sq2*den1 ) + pyrms=sqrt( sq4*den1 ) + pzrms=sqrt( sq6*den1 ) + zero=0. + epsx=sqrt(max(epsx2,zero)) + epsy=sqrt(max(epsy2,zero)) + epsz=sqrt(max(epsz2,zero)) + xpx=xpx*den1 + ypy=ypy*den1 + zpz=zpz*den1 + xpxfac=0. + ypyfac=0. + zpzfac=0. + if(xrms.ne.0. .and. pxrms.ne.0.)xpxfac=1./(xrms*pxrms) + if(yrms.ne.0. .and. pyrms.ne.0.)ypyfac=1./(yrms*pyrms) + if(zrms.ne.0. .and. pzrms.ne.0.)zpzfac=1./(zrms*pzrms) + return + end +c +c-------------------------------------------------------------- +c-------------------------------------------------------------- + + subroutine greenphi(g,nx,ny,nz,n1,n2,n3,n3a,nadj) +! green function routine. + implicit double precision(a-h,o-z) + complex*16 g + dimension g(n1,n2,n3a) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + gfun(x,y,z)=1.d0/sqrt(x**2+y**2+z**2+1.d-20) +! +!******* +! 3/21/2003 include correct factor of 1/(4pi) in the Green function: + fourpi=8.d0*(asin(1.d0)) + fourpinv=1.d0/fourpi +!******* +! write(6,*)'inside greenphi' + if(nadj.eq.1)goto 50 +! write(6,*)'(greenf): isolated boundary conditions' +! zero adjacent bunches (isolated boundary conditions): + do k=1,nz+1 + z=(k-1)*hz + do j=1,ny+1 + y=(j-1)*hy + do i=1,nx+1 + x=(i-1)*hx + g(i,j,k)=fourpinv*gfun(x,y,z) + enddo + enddo + enddo +!OTHER OPTIONS POSSIBLE HERE: +!!! g(1,1,1)=0.d0 + g(1,1,1)=g(1,1,2) +! + do k=1,nz + do j=1,ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,j,k) + enddo + enddo + enddo + do k=1,nz + do j=1+ny,ny+ny + do i=1,nx + g(i,j,k)=g(i,n2-j+2,k) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1,ny + do i=1,nx + g(i,j,k)=g(i,j,n3-k+2) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1+ny,ny+ny + do i=1,nx + g(i,j,k)=g(i,n2-j+2,n3-k+2) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1,ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,j,n3-k+2) + enddo + enddo + enddo + do k=1,nz + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,n2-j+2,k) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,n2-j+2,n3-k+2) + enddo + enddo + enddo + goto 200 +! adjacent bunches (periodic boundary conditions): + 50 continue +! nbunch=200 + nbunch=20 + d=hz*nz + do 100 k=-nz/2,nz/2-1 + do 99 j=-ny,ny-1 + do 98 i=-nx,nx-1 + if(i.eq.0 .and. j.eq.0 .and. k.eq.0)goto 98 + tmp=0.d0 + do n=-nbunch,nbunch + tmp=tmp+1.0/(fourpi*sqrt( (hx*i)**2+(hy*j)**2+(hz*k+n*d)**2)) + enddo + g(1+mod(i+n1,n1),1+mod(j+n2,n2),1+mod(k+nz,nz))=tmp + 98 continue + 99 continue + 100 continue + g(1,1,1)=g(1,1,2) + 200 continue +! write(6,*)'leaving greenphi' + return + end +c-------------------------------------------------------------- +c-------------------------------------------------------------- + + subroutine greenfx(g,nx,ny,nz,n1,n2,n3,n3a,nadj) +! green function routine. + implicit double precision(a-h,o-z) + complex*16 g + dimension g(n1,n2,n3a) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + gfun(x,y,z)=x/sqrt(x**2+y**2+z**2+1.d-20)**3 +! +!******* +! 3/21/2003 include correct factor of 1/(4pi) in the Green function: + fourpi=8.d0*(asin(1.d0)) + fourpinv=1.d0/fourpi +!******* +! write(6,*)'inside greenfx' + if(nadj.eq.1)goto 50 +! write(6,*)'(greenf): isolated boundary conditions' +! zero adjacent bunches (isolated boundary conditions): + do k=1,nz+1 + z=(k-1)*hz + do j=1,ny+1 + y=(j-1)*hy + do i=1,nx+1 + x=(i-1)*hx + g(i,j,k)=fourpinv*gfun(x,y,z) + enddo + enddo + enddo + g(1,1,1)=0.d0 +! + do k=1,nz + do j=1,ny + do i=1+nx,nx+nx + g(i,j,k)=-g(n1-i+2,j,k) + enddo + enddo + enddo + do k=1,nz + do j=1+ny,ny+ny + do i=1,nx + g(i,j,k)=g(i,n2-j+2,k) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1,ny + do i=1,nx + g(i,j,k)=g(i,j,n3-k+2) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1+ny,ny+ny + do i=1,nx + g(i,j,k)=g(i,n2-j+2,n3-k+2) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1,ny + do i=1+nx,nx+nx + g(i,j,k)=-g(n1-i+2,j,n3-k+2) + enddo + enddo + enddo + do k=1,nz + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j,k)=-g(n1-i+2,n2-j+2,k) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j,k)=-g(n1-i+2,n2-j+2,n3-k+2) + enddo + enddo + enddo + goto 200 +! adjacent bunches (periodic boundary conditions): + 50 continue + if(idproc.eq.0)write(6,*)'(greenfx)THIS PORTION OF CODE IS BROKEN' +! nbunch=200 + nbunch=20 + d=hz*nz + do 100 k=-nz/2,nz/2-1 + do 99 j=-ny,ny-1 + do 98 i=-nx,nx-1 + if(i.eq.0 .and. j.eq.0 .and. k.eq.0)goto 98 + tmp=0.d0 + do n=-nbunch,nbunch + tmp=tmp+(hx*i)/(fourpi*sqrt((hx*i)**2+(hy*j)**2+(hz*k+n*d)**2))**3 + enddo + g(1+mod(i+n1,n1),1+mod(j+n2,n2),1+mod(k+nz,nz))=tmp + 98 continue + 99 continue + 100 continue +!cryne July 7, 2004 g(1,1,1)=g(1,1,2) + g(1,1,1)=0.d0 + 200 continue +! write(6,*)'leaving greenfx' + return + end + +c-------------------------------------------------------------- +c-------------------------------------------------------------- + + subroutine greenfy(g,nx,ny,nz,n1,n2,n3,n3a,nadj) +! green function routine. + implicit double precision(a-h,o-z) + complex*16 g + dimension g(n1,n2,n3a) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + gfun(x,y,z)=y/sqrt(x**2+y**2+z**2+1.d-20)**3 +! +!******* +! 3/21/2003 include correct factor of 1/(4pi) in the Green function: + fourpi=8.d0*(asin(1.d0)) + fourpinv=1.d0/fourpi +!******* +! write(6,*)'inside greenfy' + if(nadj.eq.1)goto 50 +! write(6,*)'(greenf): isolated boundary conditions' +! zero adjacent bunches (isolated boundary conditions): + do k=1,nz+1 + z=(k-1)*hz + do j=1,ny+1 + y=(j-1)*hy + do i=1,nx+1 + x=(i-1)*hx + g(i,j,k)=fourpinv*gfun(x,y,z) + enddo + enddo + enddo + g(1,1,1)=0.d0 +!case2 g(1,1,1)=2.d0*g(1,1,2) +!case3 g(1,1,1)=g(2,1,1) +! + do k=1,nz + do j=1,ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,j,k) + enddo + enddo + enddo + do k=1,nz + do j=1+ny,ny+ny + do i=1,nx + g(i,j,k)=-g(i,n2-j+2,k) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1,ny + do i=1,nx + g(i,j,k)=g(i,j,n3-k+2) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1+ny,ny+ny + do i=1,nx + g(i,j,k)=-g(i,n2-j+2,n3-k+2) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1,ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,j,n3-k+2) + enddo + enddo + enddo + do k=1,nz + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j,k)=-g(n1-i+2,n2-j+2,k) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j,k)=-g(n1-i+2,n2-j+2,n3-k+2) + enddo + enddo + enddo + goto 200 +! adjacent bunches (periodic boundary conditions): + 50 continue + if(idproc.eq.0)write(6,*)'(greenfy)THIS PORTION OF CODE IS BROKEN' +! nbunch=200 + nbunch=20 + d=hz*nz + do 100 k=-nz/2,nz/2-1 + do 99 j=-ny,ny-1 + do 98 i=-nx,nx-1 + if(i.eq.0 .and. j.eq.0 .and. k.eq.0)goto 98 + tmp=0.d0 + do n=-nbunch,nbunch + tmp=tmp+(hy*j)/(fourpi*sqrt((hx*i)**2+(hy*j)**2+(hz*k+n*d)**2))**3 + enddo + g(1+mod(i+n1,n1),1+mod(j+n2,n2),1+mod(k+nz,nz))=tmp + 98 continue + 99 continue + 100 continue +!cryne July 7, 2004 g(1,1,1)=g(1,1,2) + g(1,1,1)=0.d0 + 200 continue +! write(6,*)'leaving greenfy' + return + end + +c-------------------------------------------------------------- +c-------------------------------------------------------------- + + subroutine greenfz(g,nx,ny,nz,n1,n2,n3,n3a,nadj) + use parallel, only : idproc +! green function routine. + implicit double precision(a-h,o-z) + complex*16 g + dimension g(n1,n2,n3a) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + gfun(x,y,z)=z/sqrt(x**2+y**2+z**2+1.d-20)**3 +! +!******* +! 3/21/2003 include correct factor of 1/(4pi) in the Green function: + fourpi=8.d0*(asin(1.d0)) + fourpinv=1.d0/fourpi +!******* + if(idproc.eq.0)write(6,*)'inside greenfz' + if(nadj.eq.1)goto 50 +! write(6,*)'(greenf): isolated boundary conditions' +! zero adjacent bunches (isolated boundary conditions): + do k=1,nz+1 + z=(k-1)*hz + do j=1,ny+1 + y=(j-1)*hy + do i=1,nx+1 + x=(i-1)*hx + g(i,j,k)=fourpinv*gfun(x,y,z) + enddo + enddo + enddo + g(1,1,1)=0.d0 +!case2 g(1,1,1)=2.d0*g(1,1,2) +!case3 g(1,1,1)=g(2,1,1) +! + do k=1,nz + do j=1,ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,j,k) + enddo + enddo + enddo + do k=1,nz + do j=1+ny,ny+ny + do i=1,nx + g(i,j,k)=g(i,n2-j+2,k) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1,ny + do i=1,nx + g(i,j,k)=-g(i,j,n3-k+2) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1+ny,ny+ny + do i=1,nx + g(i,j,k)=-g(i,n2-j+2,n3-k+2) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1,ny + do i=1+nx,nx+nx + g(i,j,k)=-g(n1-i+2,j,n3-k+2) + enddo + enddo + enddo + do k=1,nz + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,n2-j+2,k) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j,k)=-g(n1-i+2,n2-j+2,n3-k+2) + enddo + enddo + enddo + goto 200 +! adjacent bunches (periodic boundary conditions): + 50 continue + if(idproc.eq.0)write(6,*)'adjacent bunches' +! nbunch=200 + if(idproc.eq.0)write(6,*)'(greenfz)THIS PORTION OF CODE IS BROKEN' + nbunch=20 + d=hz*nz + do 100 k=-nz/2,nz/2-1 + do 99 j=-ny,ny-1 + do 98 i=-nx,nx-1 + if(i.eq.0 .and. j.eq.0 .and. k.eq.0)goto 98 + tmp=0.d0 + do n=-nbunch,nbunch + tmp=tmp+(hz*k+n*d)/ & + & (fourpi*sqrt( (hx*i)**2+(hy*j)**2+(hz*k+n*d)**2))**3 + enddo + g(1+mod(i+n1,n1),1+mod(j+n2,n2),1+mod(k+nz,nz))=tmp + 98 continue + 99 continue + 100 continue +!cryne July 7, 2004 g(1,1,1)=g(1,1,2) + g(1,1,1)=0.d0 + 200 continue + if(idproc.eq.0)write(6,*)'leaving greenfz' + return + end + diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo.f b/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo.f new file mode 100644 index 0000000..30a9221 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo.f @@ -0,0 +1,435 @@ +! IMPACT 3D space charge routines +! Copyright 2001 University of California +! +! Using Chombo AMR Poisson solver for Infinite Domain or Homogenous Dirichlet BCs +! +! subroutine SPCH3DAMR( c,ex,ey,ez,msk,Np,Ntot +! & ,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,phi ) + +! Arguments: +! c in:out (1:5:2,*) are x,y,z coordinates of particles +! note: in the rest of MLI column 5 is time-of-flight (i.e. phase), +! but prior to calling the space charge routines it is +! converted to longitudinal position z. +! (2:6:2,*) are momenta and not used here. +! ex,ey,ez :out electric field at particles +! Msk :in flag indicating valid particles +! Np :in number of particles (both good and bad) on this processor +! Ntot :in number of (good) particles on all processors +! Nx,Ny,Nz :in dimensions of grid on the regular sized grid +! N1,N2,N3 :in dimensions of the bigger (usually doubled) grid +! N3a :in =Nz for periodic bc longitudinally, =2*Nz for open bc longit. +! Nadj :in =0 for open or Dirichlet BCs, >=1 for longitudinally periodic BCs +! phi :out solution to Poisson equation +! +! Globals: +! Common /NEWPOISSON/ +! ISolve :in choose which Poisson solver to use -- 1 for default Infinite Domain, +! 3x for Chombo AMR Infinite Domain solver +! 4x for Chombo Hom.Dirichlet +! x0 = spectral discretization +! x1 = Mehrstellen " +! x2 = Laplacian " (7-point) +! x3 = Mehrstellen (4th order) +! Common /SHOWME/ +! IVerbose :in +! Common /GRIDSZ3D/ +! Xmin,Xmax :in location of corners of physical grid +! Ymin,Ymax :in +! Zmin,Zmax :in +! Hx,Hy,Hz :in grid spacings +! Hxi,Hyi,Hzi :in 1.0 / Hx,Hy,Hz +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine SPCH3DAMR( c,ex,ey,ez,Msk,Np,Ntot & + & ,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,phi ) + use parallel ,ONLY : NVP,IDPROC + use ml_timer + implicit none +!Constants + integer ,parameter :: InterpType = 1 + integer :: Nxyz !set below + real*8 :: FourPi, Hxyz, Neg4Pi ! " " +!Arguments + integer Np,Ntot,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj + real*8, dimension(6,Np) :: c + logical, dimension(Np) :: Msk + real*8, dimension(Np) :: ex,ey,ez + real*8, dimension(Nx,Ny,Nz) :: phi +!Locals + character filename*32 + integer i,j,k,ierror,status ,stride + integer CHPHandle ,maxlvls ,maxp ,tagsbuffer ,solvertype + integer domain(3,2) ,subdomains(3,2,1) ,bcflags(3,2) + integer refratios(10) + logical ltmp +!!! real*8, dimension(Nx,Ny,Nz) :: exg,eyg,ezg,rhosum + real*8 x0(3) ,fillratio,tolerance ,charge ,bcvals(3,2) + real*8 checknorm ,scale ,xval,yval,zval,del2 + integer iteration ,plotiters + save iteration + data iteration/0/ + character*12 stencil(0:3) !input names of stencils, indexed by ISolve + data stencil/'spectral' ,'mehrstellen' ,'laplace' ,'4mehrstellen'/ + save stencil + +!Globals + real*8 Xmin,Xmax,Ymin,Ymax,Zmin,Zmax,Hx,Hy,Hz,Hxi,Hyi,Hzi + common/GRIDSZ3D/Xmin,Xmax,Ymin,Ymax,Zmin,Zmax,Hx,Hy,Hz,Hxi,Hyi,Hzi + integer IVerbose + common/SHOWME/IVerbose + integer IDirectFieldCalc,IDensityFunction,ISolve + common/NEWPOISSON/IDirectFieldCalc,IDensityFunction,ISolve + character*256 ChomboFilename + common/chombochar/ChomboFilename +!Externals + integer LENC + logical HANDLE_ERROR + external LENC ,HANDLE_ERROR + +!====================================================================== + +!Execution + + if(idproc.eq.0 .AND. iverbose.ge.5) + & write(6,*)'info: SPCH3DAMR: solving for phi with ' + & ,TRIM( stencil( MOD( ISolve,10 ) ) ) ,' stencil' + + !! Set constants + FourPi = 4.0 * ACOS( -1.0d0 ) + Neg4Pi = -FourPi + Nxyz = Nx*Ny*Nz + Hxyz = Hx*Hy*Hz + +!----------------------------------------------------------------------- + +! check for valid conditions for this solver + + if( ISolve.LT.30 .OR. ISolve.GT.42 )then + write(6,*) 'error: SPCH3DAMR: invalid Chombo solver type. ' + & ,' Should be 30--42, not ',ISolve + stop 'SPCH3DAMR' + endif + if( ISolve - 30 .LT. 10 .AND. ( Nx.NE.Ny .OR. Ny.NE.Nz ) )then + write(6,*) 'error: SPCH3DAMR: non-cubic grids are not supported' + & ,'. Nx,Ny,Nz = ' ,Nx,Ny,Nz + stop 'SPCH3DAMR' + endif + if( Hx.NE.Hy .OR. Hy.NE.Hz )then + write(6,*) 'error: SPCH3DAMR: anisotropic grids are not ' + & ,'supported. Hx,Hy,Hz = ' ,Hx,Hy,Hz + stop 'SPCH3DAMR' + endif + if( IDirectFieldCalc .EQ. 1 )then + write(6,*) 'error: SPCH3DAMR: direct Efield calculation is not ' + & ,'supported (i.e. IDirectFieldCalc should be 0).' + stop 'SPCH3DAMR' + endif + if( Nadj .NE. 0 )then + write(6,*) 'error: SPCH3DAMR: periodic longitudinal BC is not ' + & ,'supported (i.e. Nadj should be 0).' + stop 'SPCH3DAMR' + endif + if( NVP .NE. 1 )then + write(6,*) 'error: SPCH3DAMR: parallel not implemented.' + stop 'NVP>1' + endif + if( Ntot .NE. NP )then + write(6,*) 'error: SPCH3DAMR: all particles not on process 1' + stop 'NP!=NPtot' + endif + if( COUNT( Msk ) .NE. NP )then + write(6,*) 'error: SPCH3DAMR: masked particles not supported.' + stop 'Msk!=NP' + endif + if( ChomboFilename .EQ. ' ' )then + write(6,*) 'error: SPCH3DAMR: chombo input filename is blank.' + stop 'SPCH3DAMR' + endif + +!----------------------------------------------------------------------- + + !! keep track of how many calls + iteration = iteration + 1 + + !! read the Chombo input file from + call CH_READINFILE( ChomboFilename ,maxlvls ,refratios ,maxp + & ,tagsbuffer ,fillratio ,tolerance ,solvertype + & ,bcvals ,plotiters ) + + !! instantiate a ChomboPIC object and return a handle to it + call CHP_CREATE( CHPHandle ,status ) + ltmp = HANDLE_ERROR( status, 'CHP_CREATE' ) !ignore warnings + + call CHP_SETDEBUG( CHPHandle, IVerbose ) + + ! set the computational domain (in grid points) + ! and the per-processor subdomains +!XXX for now, assume one cpu + ! domain is in nodes + domain(:,1) = 0 + domain(1,2) = Nx-1 ; domain(2,2) = Ny-1 ; domain(3,2) = Nz-1 + subdomains(:,:,1) = domain + x0(1) = Xmin ; x0(2) = Ymin ; x0(3) = Zmin + + call CHP_SETGRIDPARAMS( CHPHandle, x0,Hx,domain,subdomains,maxlvls + & ,refratios ,maxp ,tagsbuffer ,fillratio + & ,status ) + ltmp = HANDLE_ERROR( status, 'CHP_SETGRID' ) + if( ltmp ) stop 'SPCH3A02' + + if( IVerbose .GE. 5 .AND. iteration .EQ. 1 )then + write(6,*) 'SPCH3D_CHOMBO parameters:' + write(6,*) ' MaxLevels',maxlvls + write(6,*) ' RefRatios',refratios + write(6,*) ' MaxParticlesPerCell',MaxP + write(6,*) ' TagsBufferCells',tagsbuffer + write(6,*) ' FillRatio',fillratio + write(6,*) ' Tolerance',Tolerance + write(6,*) ' SolverType',solvertype + write(6,*) ' BoundaryValues' ,bcvals + write(6,*) ' PlotIters' ,plotiters + endif + + !! set solver parameters + bcflags = 0 !default dirichlet + if( ISolve .LT. 40 )then + !! infinite domain boundary condition on all faces + bcflags = 5 !5==Chombo::PICOpen +!XXX -- discretization type is hardcoded +!XXX !! the infinite domain solver has 3 flavors for the type of +!XXX !! discretization used on the level_0 FFT solver, so extract +!XXX !! this from the ISolve global paramter and pack it into solvertype +!XXX !! (default: spectral, +10 for Mehrstellan, +20 for laplace +!XXX solvertype = solvertype + 10*(ISolve-30) + if( ISolve-30 .NE. 1 )then + write(6,*) 'warning: SPCH3DAMR: ignoring FFT discretization ' + & ,'type ' ,ISolve-30 + write(6,*) 'info: using Mehrstellen discretization instead.' + endif +!XXX + endif + + call CHP_SETSOLVEPARAMS( CHPHandle ,tolerance ,bcflags,bcvals + & ,InterpType ,IVerbose,solvertype,status ) + ltmp = HANDLE_ERROR( status, 'CHP_SETSOLVE' ) + if( ltmp ) stop 'SPCH3A03' + +!----------------------------------------------------------------------- + +! pass particles to ChomboPIC + + !! divide charge by number of particles so rho will be same as MLI + !![NOTE: Chombo::PIC divides by cell volume, so dont need to do that here.] + !![NOTE: poisson3d solver assumes rho is negative.] + call increment_timer('rhoslo3d',0) + charge = -1.0d0 / Ntot + stride = 6 + call CHP_PUTPARTICLES( CHPHandle,1,charge,NP,stride + & ,c(1,1),c(3,1),c(5,1) !x,y,z + & ,status ) + ltmp = HANDLE_ERROR( status, 'CHP_PUTPARTICLES' ) + call increment_timer('rhoslo3d',1) + if( ltmp ) stop 'SPCH3A04' + +!----------------------------------------------------------------------- + +! solve the Poisson equation using the ChomboPIC solver + + call increment_timer('fft',0) + call CHP_SOLVE( CHPHandle ,status ) + ltmp = HANDLE_ERROR( status, 'CHP_SOLVE' ) + call increment_timer('fft',1) + if( ltmp ) stop 'SPCH3A05' + +!----------------------------------------------------------------------- + +! extract results from Chombo::PIC + + call increment_timer('timer1',0) + + !! get the solution on the base grid + call CHP_GETPHIGRID0( CHPHandle ,phi ,status ) + ltmp = HANDLE_ERROR( status, 'CHP_GETPHIGRID' ) + call increment_timer('timer1',1) + if( ltmp ) stop 'SPCH3A08' + + !! get the electric field at the particles + call CHP_GETEFIELD( CHPHandle, 1,NP,stride ,c(1,1),c(3,1),c(5,1) + & ,1 ,ex ,ey ,ez ,status ) !stride for exyz is 1, not 6 + ltmp = HANDLE_ERROR( status, 'CHP_GETEFIELD' ) + if( ltmp ) stop 'SPCH3A06' + + ![NOTE: this may need a factor of 'h' as well] +!! ex = ex * FourPi +!! ey = ey * FourPi +!! ez = ez * FourPi + ex = -ex + ey = -ey + ez = -ez + + call increment_timer('timer1',1) + +!----------------------------------------------------------------------- + +! write data files + + call increment_timer('timer2',0) + + if( iteration .EQ. 1 .OR. MOD( iteration,plotiters ) .EQ. 0 )then + + !! poisson solution on all grids + filename = 'phi_0000.hdf5 ' + write(filename(5:8),'(I4.4)') iteration + if( iverbose .ge. 4 ) + & write(6,*) 'SPCH3DAMR: writing phi to ',TRIM(filename) + call CHP_WRITEPHI( CHPHandle,filename,status ) + ltmp = HANDLE_ERROR( status, 'CHP_WRITEPHI' ) + ! ignore errors or warnings + + !! all data including particles on all grids + filename = 'soln_0000.hdf5 ' + write(filename(6:9),'(I4.4)') iteration + if( iverbose .ge. 4 ) + & write(6,*) 'SPCH3DAMR: writing solution to ',TRIM(filename) + call CHP_WRITESOLN( CHPHandle ,filename ,status ) + ltmp = HANDLE_ERROR( status, 'CHP_WRITESOLN' ) + ! ignore errors or warnings + + endif + + call increment_timer('timer2',1) + +!====================================================================== + +! Done + call CHP_DESTROY( CHPHandle, status ) + ltmp = HANDLE_ERROR( status, 'CHP_DESTROY' ) !ignore warnings + if(idproc.eq.0 .AND. iverbose.gt.5) write(6,*)'leaving SPCH3DAMR' + return + end + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + logical function HANDLE_ERROR( Status ,IdString ) + integer Status + character IdString*(*) + if( Status .EQ. 0 )then + HANDLE_ERROR = .FALSE. + elseif( Status .LT. 0 )then + write(6,*) 'FATALERROR(' ,Status ,') from ' + $ ,IdString(1:LEN(IdString)) + stop + else + write(6,*) 'WARNING(' ,Status ,') from ' + $ ,IdString(1:LEN(IdString)) + HANDLE_ERROR = .TRUE. + endif + return + end + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine CH_READINFILE( FileName ,maxlvls ,refratios ,maxp + & ,tagsbuffer ,fillratio ,tolerance + & ,solvertype ,bcvals ,plotiters ) + +!! Input file format: (filename: chombo.input) +!! Version -- (V2 or later) +!! MaxLevels -- number of AMR levels to use +!! RefRatios -- refinement ratios for levels > 0 (none if MaxLevels==1) +!! MaxParticlesPerCell -- threshold for making tags for MeshRefine +!! TagsBufferCells -- number of cells around tags to include in grids (V3 or later) +!! FillRatio -- portion of cells in a refined box that must be tagged (V4 or later) +!! Tolerance -- AMRNodeElliptic solver tolerance (V4 or later) +!! SolverType -- AMRNodeElliptic solver type (0=default, 1=alternate) +!! BoundaryValues -- homogenous BC values for each direction (both faces) (V2 or later) +!! PlotIters -- number of iterations between plot files (V5 or later) (def: 1) +!! Notes: +!! +!! Defaults: +!! MaxLevels: 1 +!! RefRatios: none +!! MaxParticlesPerCell: 10 +!! TagsBufferCells: 1 +!! FillRatio: .75 +!! Tolerance: 1e-12 +!! SolverType: 0 +!! BoundaryValues: 0 0 0 +!! PlotIters: 1 +!! +!!========================================================================= + implicit none +!Arguments + character FileName*(*) + integer maxlvls ,refratios(*) ,maxp ,tagsbuffer ,solvertype + integer plotiters + real*8 x0(3) ,fillratio ,tolerance ,bcvals(3,2) +!Locals + character word*32 + integer i ,version +!Globals + integer IVerbose + common/SHOWME/IVerbose +!Execute + version = 4 + maxlvls = 1 + maxp = 10 + tagsbuffer = 1 + fillratio = 0.75 + tolerance = 1.0d-12 + solvertype = 0 + bcvals = 0 + plotiters = 1 + + open(2,file=FileName,err=99) + read(2,*,err=99,end=99) word ,version + if( word .NE. 'Version' )then + write(6,*) 'error: Chombo input: expecting Version, got ' + & ,version + stop 'CHOMBOIN' + endif + if( version .LT. 4 )then + write(6,*) 'error: Chombo input: input file versions <4 ' + & ,' are not supported.' + stop 'CHOMBOIN' + endif + read(2,*) word, maxlvls + write(6,*) 'Expecting MaxLevels, got [',TRIM(word),']=',maxlvls + read(2,*) word, (refratios(i),i=1,maxlvls-1) + write(6,*) 'Expecting RefRatios, got [',TRIM(word),']=' + & ,(refratios(i),i=1,maxlvls-1) + read(2,*) word, maxp + write(6,*) 'Expecting MaxParticlesPerCell, got [',TRIM(word),']=' + & ,maxp + read(2,*) word,tagsbuffer + write(6,*) 'Expecting TagsBufferCells, got [',TRIM(word),']=' + & ,tagsbuffer + read(2,*) word,fillratio + write(6,*) 'Expecting FillRatio, got [',TRIM(word),']=',fillratio + read(2,*) word,tolerance + write(6,*) 'Expecting Tolerance, got [',TRIM(word),']=',tolerance + read(2,*) word,solvertype + write(6,*) 'Expecting SolverType, got [',TRIM(word),']=' + & ,solvertype + read(2,*) word,(bcvals(i,1),i=1,3) + do i = 1,3 + bcvals(i,2) = bcvals(i,1) + enddo + if( version .GE. 5 )then + read(2,*) word,plotiters + write(6,*) 'Expecting PlotIters, got [',TRIM(word),']=' + & ,plotiters + endif +!Done + close(2) + return + +!Errors + ! handle missing file + 99 write(6,*) 'info: Chombo: input file [' ,TRIM( FileName ) + & ,'] is missing or empty so using default input values.' + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo_dummy.f b/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo_dummy.f new file mode 100644 index 0000000..fcf195f --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo_dummy.f @@ -0,0 +1,13 @@ + subroutine SPCH3DAMR( c,ex,ey,ez,Msk,Np,Ntot & + & ,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,phi ) + implicit none +!Arguments + integer Np,Ntot,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj + real*8, dimension(6,Np) :: c + logical, dimension(Np) :: Msk + real*8, dimension(Np) :: ex,ey,ez + real*8, dimension(Nx,Ny,Nz) :: phi + write(6,*) 'error: SPCH3DAMR: Chombo AMR is not included ' + & ,'in this version.' + stop 'NOAMR' + end diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d_dummy.f b/OpticsJan2020/MLI_light_optics/Src/spch3d_dummy.f new file mode 100644 index 0000000..5e0ca12 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/spch3d_dummy.f @@ -0,0 +1,29 @@ + subroutine SPCH3D2( c,ex,ey,ez,Msk,Np,Ntot & + & ,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,rhophi ) + implicit none +!Arguments + integer Np,Ntot,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj + real*8, dimension(6,Np) :: c + logical, dimension(Np) :: Msk + real*8, dimension(Np) :: ex,ey,ez + real*8, dimension(Nx,Ny,Nz) :: rhophi + write(6,*) 'error: SPCH3D2: ANAG Poisson is not included ' + & ,'in this version.' + stop 'NOANAG' + return + end + + subroutine SPCH3DBC0( c,ex,ey,ez,Msk,Np,Ntot & + & ,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,rho ) +!Arguments + implicit none! double precision(a-h,o-z) + integer Np,Ntot,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj + real*8, dimension(6,Np) :: c + logical, dimension(Np) :: Msk + real*8, dimension(Np) :: ex,ey,ez + real*8, dimension(Nx,Ny,Nz) :: rho + write(6,*) 'error: SPCH3D2: ANAG Poisson is not included ' + & ,'in this version.' + stop 'NOANAG' + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d_essl.f b/OpticsJan2020/MLI_light_optics/Src/spch3d_essl.f new file mode 100755 index 0000000..a646543 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/spch3d_essl.f @@ -0,0 +1,529 @@ +c IMPACT 3D space charge routines +c Copyright 2001 University of California +c +c at this point np is the # of particles on a processor: + subroutine spch3d(c,ex,ey,ez,msk,np,ntot, & + & nx,ny,nz,n1,n2,n3,n3a,nadj) + use parallel + use ml_timer + implicit double precision(a-h,o-z) + real*8, dimension(6,np) :: c + logical, dimension(np) :: msk + real*8, dimension(np) :: ex,ey,ez + real*8, dimension(nx,ny,nz) :: rho,exg,eyg,ezg,rhosum +! real*8,dimension(n1,n2,n3a) :: rho2 +! complex*16,dimension(n3a,n2,n1) :: grnxtr,rho2xtr +! + real*8,dimension(n1+2,n2,n3a) :: rho2 + complex*16,dimension(n1/2+1,n2,n3a) :: grnxtr,rho2xtr +! + integer, parameter :: naux=120000 +c rho=charge density on the grid +c rho2=...on doubled grid +c rho2xtr=...xformed (by fft) and transposed +c grnxtr=green function, xformed, transposed +c weights, indices associated with area weighting: + dimension ab(np),de(np),gh(np),indx(np),jndx(np),kndx(np), + &indxp1(np),jndxp1(np),kndxp1(np) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + common/accum/at10,at21,at32,at43,at54,at65,at76,at70 + common/showme/iverbose + real*8 aux(naux) +! if(idproc.eq.0)write(6,*)'inside spchg; nadj=',nadj +c +! call system_clock(count_rate=ihertz) +! hertz=ihertz +! call system_clock(count=iticks0) +c +! compute the Green function on the grid (use rho2 for storage): + call increment_timer('greenf3d',0) + call greenf3d(rho2,nx,ny,nz,n1,n2,n3,n3a,nadj) + call increment_timer('greenf3d',1) +! call system_clock(count=iticks3) +! if(idproc.eq.0)write(6,*)'returned from greenf' +! FFT the Green function: + scale=1.0 +! write(6,*)'(greenf) calling fft3dhpf; grn=' + iunity=1 + izero=0 + scale=1.d0 + ijsign=1 +! if(idproc.eq.0)then +! write(6,*)'calling dcft w/ n1,n2*n1,n3a,n2*n3a,n1,n2,n3a=' +! write(6,*)n1,n2*n1 +! write(6,*)n3a,n2*n3a +! write(6,*)n1,n2,n3a +! endif + call drcft3(rho2,n1+2,n2*(n1+2), & + & grnxtr,n1/2+1,n2*(n1/2+1),n1,n2,n3a,ijsign,scale,aux,naux) +! call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,grnxtr) +! if(idproc.eq.0)write(6,*)'rtrnd frm dcft3 grnf' +! +! deposit charge on the grid: + call increment_timer('rhoslo3d',0) +! if(idproc.eq.0)write(6,*)'calling rhoslo3d' + call rhoslo3d(c,rho,msk,np,ab,de,gh,indx,jndx,kndx, + &indxp1,jndxp1,kndxp1,nx,ny,nz,nadj) +! if(idproc.eq.0)write(6,*)'returned from rhoslo3d' + call MPI_ALLREDUCE(rho,rhosum,nx*ny*nz,mreal,mpisum,lworld,ierror) +! if(idproc.eq.0)write(6,*)'returned from MPI_ALLREDUCE' + rho=rhosum + call increment_timer('rhoslo3d',1) +! glrhochk=sum(rho) +! if(idproc.eq.0)write(6,*)'global sum of rho = ',glrhochk +cryne august 1, 2002 +cryne moved normalization out of rhoslo to here: + rho=rho/ntot +c gnrhochk=sum(rho) +c if(iverbose.ge.0)then +c write(6,*)'normalized global rhosum=',gnrhochk +c endif +c--------------- + idebug=0 + hxyzi=hxi*hyi*hzi + if(idebug.eq.1)then + write(6,*)'writing charge density (note mult by hxi*hyi*hzi)' + do i=1,nx + write(65,*)xmin+(i-1)*hx,rho(i,ny/2,nz/2)*hxi*hyi*hzi + enddo + endif +c--------------- + call system_clock(count=iticks1) +! store rho in lower left quadrant of doubled grid: + do k=1,n3a + do j=1,n2 + do i=1,n1 + rho2(i,j,k)=0.d0 + enddo + enddo + enddo +cryne forall(i=1:nx,j=1:ny,k=1:nz)rho2(i,j,k)=cmplx(rho(i,j,k),0.) + do k=1,nz + do j=1,ny + do i=1,nx + rho2(i,j,k)=rho(i,j,k) + enddo + enddo + enddo +! if(idproc.eq.0)then +! write(6,*)'finished storing in lower left quadrant; start conv' +! endif +! call system_clock(count=iticks2) +!---------convolution------------ +! +! fft the charge density: + ijsign=1 +! if(idproc.eq.0)then +! write(6,*)'(rho)calling dcft w/ n1,n2*n1,n3a,n2*n3a,n1,n2,n3a=' +! write(6,*)n1,n2*n1 +! write(6,*)n3a,n2*n3a +! write(6,*)n1,n2,n3a +! endif + call drcft3(rho2,n1+2,n2*(n1+2), & + & rho2xtr,n1/2+1,n2*(n1/2+1),n1,n2,n3a,ijsign,scale,aux,naux) +! call fft3dhpf(n1,n2,n3a,1,scale,0,nadj,rho2,rho2xtr) +! call system_clock(count=iticks4) +! if(idproc.eq.0)write(6,*)'returned from dcft3 of rho' +! multiply transformed charge density and transformed Green function: +! rho2xtr=rho2xtr*grnxtr/(n1*n2*n3a) + rho2xtr=rho2xtr*grnxtr + scale=1.d0/(n1*n2*n3a) +! inverse fft: +! if(idproc.eq.0)then +! write(6,*)'calling inv. dcft w/ n1/2+1,n2*(n1/2+1),n1,n2,n3a=' +! write(6,*)n1/2+1,n2*(n1/2+1) +! write(6,*)n1,n2,n3a +! endif + ijsign=-1 + call dcrft3(rho2xtr,n1/2+1,n2*(n1/2+1), & + & rho2,n1+2,n2*(n1+2),n1,n2,n3a,ijsign,scale,aux,naux) +!!!! & rho2,n1,n2*n1,n1/2+1,n2,n3a,ijsign,scale,aux,naux) +! if(idproc.eq.0)write(6,*)'returned from inverse dcft3' +! call fft3dhpf(n3a,n2,n1,-1,scale,0,nadj,rho2xtr,rho2) +! call system_clock(count=iticks5) +!!!! rho2=rho2*hx*hy*hz +!----done with convolution------- +! store physical data back on grid of correct (not doubled) size: +cryne forall(i=1:nx,j=1:ny,k=1:nz)rho(i,j,k)=real(rho2(i,j,k)) + do k=1,nz + do j=1,ny + do i=1,nx + rho(i,j,k)=rho2(i,j,k) + enddo + enddo + enddo +c--------------- + idebug=0 + if(idebug.eq.1)then + write(6,*)'writing out potential' + do i=1,nx + write(66,*)xmin+(i-1)*hx,rho(i,ny/2,nz/2) + enddo + write(6,*)'stopping due to debug statement in spch3d' + call myexit + endif +c--------------- +! if(idproc.eq.0)write(6,*)'obtaining electric fields' +! obtain the electric fields: + exg=0.5*hxi*(cshift(rho,-1,1)-cshift(rho,1,1)) + eyg=0.5*hyi*(cshift(rho,-1,2)-cshift(rho,1,2)) + ezg=0.5*hzi*(cshift(rho,-1,3)-cshift(rho,1,3)) + call system_clock(count=iticks6) +! if(idproc.eq.0)write(6,*)'interpolating electric fields' +! interpolate electric field at particle postions: + call increment_timer('ntrslo3d',0) + call ntrslo3d(exg,eyg,ezg,ex,ey,ez,msk,ab,de,gh,indx,jndx,kndx, + &indxp1,jndxp1,kndxp1,nx,ny,nz,np) + call increment_timer('ntrslo3d',1) +! if(idproc.eq.0)write(6,*)'done interpolating electric fields' +! call system_clock(count=iticks7) +! t10=(iticks1-iticks0)/hertz +! t21=(iticks2-iticks1)/hertz +! t32=(iticks3-iticks2)/hertz +! t43=(iticks4-iticks3)/hertz +! t54=(iticks5-iticks4)/hertz +! t65=(iticks6-iticks5)/hertz +! t76=(iticks7-iticks6)/hertz +! t70=(iticks7-iticks0)/hertz +! at10=at10+t10 +! at21=at21+t21 +! at32=at32+t32 +! at43=at43+t43 +! at54=at54+t54 +! at65=at65+t65 +! at76=at76+t76 +! at70=at70+t70 +! write(3,2468)t10,t21,t32,t43,t54,t65,t76,t70 +! write(4,2468)at10,at21,at32,at43,at54,at65,at76,at70 +!2468 format(8(1pe9.3,1x)) +! call flush_(3) +! call flush_(4) + return + end + + subroutine greenf3d(g,nx,ny,nz,n1,n2,n3,n3a,nadj) + implicit double precision(a-h,o-z) + real*8 g +! dimension g(n1,n2,n3a) + dimension g(n1+2,n2,n3a) + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi +! write(6,*)'inside greenf3d' +! write(6,*)'nx,ny,nz=',nx,ny,nz +! write(6,*)'n1,n2,n3,n3a=',n1,n2,n3,n3a +! write(6,*)'nadj=',nadj + if(nadj.eq.1)goto 50 +! write(6,*)'(greenf): isolated boundary conditions' +! zero adjacent bunches (isolated boundary conditions): + do k=1,nz+1 + do j=1,ny+1 + do i=1,nx+1 + g(i,j,k) = (hx*(i-1))**2 +(hy*(j-1))**2 +(hz*(k-1))**2 + enddo + enddo + enddo + g(1,1,1)=1. + g(1:nx+1,1:ny+1,1:nz+1)=1.d0/sqrt(g(1:nx+1,1:ny+1,1:nz+1)) + g(1,1,1)=g(1,1,2) + do k=1,nz + do j=1,ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,j,k) + enddo + enddo + enddo + do k=1,nz + do j=1+ny,ny+ny + do i=1,nx + g(i,j,k)=g(i,n2-j+2,k) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1,ny + do i=1,nx + g(i,j,k)=g(i,j,n3-k+2) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1+ny,ny+ny + do i=1,nx + g(i,j,k)=g(i,n2-j+2,n3-k+2) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1,ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,j,n3-k+2) + enddo + enddo + enddo + do k=1,nz + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,n2-j+2,k) + enddo + enddo + enddo + do k=1+nz,nz+nz + do j=1+ny,ny+ny + do i=1+nx,nx+nx + g(i,j,k)=g(n1-i+2,n2-j+2,n3-k+2) + enddo + enddo + enddo + goto 200 +! adjacent bunches (periodic boundary conditions): + 50 continue + d=hz*nz + do 100 k=-nz/2,nz/2-1 + do 99 j=-ny,ny-1 + do 98 i=-nx,nx-1 + if(i.eq.0 .and. j.eq.0 .and. k.eq.0)goto 98 + g(1+mod(i+n1,n1),1+mod(j+n2,n2),1+mod(k+nz,nz))= & + & 1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+1.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+2.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+3.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+4.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+5.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+6.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+7.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+8.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-1.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-2.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-3.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-4.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-5.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-6.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-7.*d)**2) & + &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-8.*d)**2) + 98 continue + 99 continue + 100 continue + g(1,1,1)=g(1,1,2) + 200 continue +! write(6,*)'leaving greenf3d' + return + end + + subroutine rhoslo3d(coord,rho,msk,np,ab,de,gh,indx,jndx,kndx, + &indxp1,jndxp1,kndxp1,nx,ny,nz,nadj) +cryne 08/24/2001 use hpf_library + implicit double precision(a-h,o-z) + logical msk + dimension coord(6,np),msk(np),vol(np) +!hpf$ distribute coord(*,block) +!hpf$ align (:) with coord(*,:) :: msk,vol + dimension ab(np),de(np),gh(np),indx(np),jndx(np),kndx(np), + &indxp1(np),jndxp1(np),kndxp1(np) +!hpf$ align (:) with coord(*,:) :: ab,de,gh,indx,jndx,kndx +!hpf$ align (:) with coord(*,:) :: indxp1,jndxp1,kndxp1 + dimension rho(nx,ny,nz),tmp(nx,ny,nz) +!hpf$ distribute rho(*,*,block) +!hpf$ align (*,*,:) with rho(*,*,:) :: tmp + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + common/showme/iverbose + if(idproc.eq.0) write(6,*)'inside rhoslo3d' +! write(6,*)'xmin,xmax=',xmin,xmax +! write(6,*)'nx,ny,nz=',nx,ny,nz +! write(6,*)'nadj=',nadj +! xminnn=minval(coord(1,:)) +! xmaxxx=maxval(coord(1,:)) +! write(6,*)'xminnn,xmaxxx=',xminnn,xmaxxx +cryne 6/25/2002 do i=1,np + do j=1,np + indx(j)=(coord(1,j)-xmin)*hxi + 1 + jndx(j)=(coord(3,j)-ymin)*hyi + 1 + kndx(j)=(coord(5,j)-zmin)*hzi + 1 + enddo + do j=1,np + indxp1(j)=indx(j)+1 + jndxp1(j)=jndx(j)+1 + kndxp1(j)=kndx(j)+1 + enddo +!------- + imin=minval(indx,1,msk) + imax=maxval(indx,1,msk) + jmin=minval(jndx,1,msk) + jmax=maxval(jndx,1,msk) + kmin=minval(kndx,1,msk) + kmax=maxval(kndx,1,msk) + if((imin.lt.1).or.(imax.gt.nx-1))then + write(6,*)'error in rhoslo3d: imin,imax=',imin,imax + call myexit + endif + if((jmin.lt.1).or.(jmax.gt.ny-1))then + write(6,*)'error in rhoslo3d: jmin,jmax=',jmin,jmax + call myexit + endif + if(nadj.eq.0)then + if((kmin.lt.1).or.(kmax.gt.nz-1))then + write(6,*)'error in rhoslo3d (nadj=0): kmin,kmax=',kmin,kmax + call myexit + endif + endif + if(nadj.eq.1)then + if((kmin.lt.1).or.(kmax.gt.nz))then + write(6,*)'error in rhoslo3d (nadj=1): kmin,kmax=',kmin,kmax + call myexit + endif + endif +!------- + if(nadj.eq.1)then + do n=1,np + if(kndxp1(n).eq.nz+1)kndxp1(n)=1 + enddo + endif + ab=((xmin-coord(1,:))+indx*hx)*hxi + de=((ymin-coord(3,:))+jndx*hy)*hyi + gh=((zmin-coord(5,:))+kndx*hz)*hzi + rho=0. +!1 (i,j,k): + vol=ab*de*gh + do 100 n=1,np + rho(indx(n),jndx(n),kndx(n))= & + &rho(indx(n),jndx(n),kndx(n))+vol(n) + 100 continue +!2 (i,j+1,k): + vol=ab*(1.-de)*gh + do 200 n=1,np + rho(indx(n),jndxp1(n),kndx(n))= & + &rho(indx(n),jndxp1(n),kndx(n))+vol(n) + 200 continue +!3 (i,j+1,k+1): + vol=ab*(1.-de)*(1.-gh) + do 300 n=1,np + rho(indx(n),jndxp1(n),kndxp1(n))= & + &rho(indx(n),jndxp1(n),kndxp1(n))+vol(n) + 300 continue +!4 (i,j,k+1): + vol=ab*de*(1.-gh) + do 400 n=1,np + rho(indx(n),jndx(n),kndxp1(n))= & + &rho(indx(n),jndx(n),kndxp1(n))+vol(n) + 400 continue +!5 (i+1,j,k+1): + vol=(1.-ab)*de*(1.-gh) + do 500 n=1,np + rho(indxp1(n),jndx(n),kndxp1(n))= & + &rho(indxp1(n),jndx(n),kndxp1(n))+vol(n) + 500 continue +!6 (i+1,j+1,k+1): + vol=(1.-ab)*(1.-de)*(1.-gh) + do 600 n=1,np + rho(indxp1(n),jndxp1(n),kndxp1(n))= & + &rho(indxp1(n),jndxp1(n),kndxp1(n))+vol(n) + 600 continue +!7 (i+1,j+1,k): + vol=(1.-ab)*(1.-de)*gh + do 700 n=1,np + rho(indxp1(n),jndxp1(n),kndx(n))= & + &rho(indxp1(n),jndxp1(n),kndx(n))+vol(n) + 700 continue +!8 (i+1,j,k): + vol=(1.-ab)*de*gh + do 800 n=1,np + rho(indxp1(n),jndx(n),kndx(n))= & + &rho(indxp1(n),jndx(n),kndx(n))+vol(n) + 800 continue +! +cryne august 1, 2002: +cccc ngood=count(msk) +cccc write(6,*)'ngood=',ngood +cccc rho=rho/ngood +!wrong rho=rho/ngood*hxi*hyi*hzi +! if(idproc.eq.0)write(6,*)'leaving rhoslo3d' +! rhochk=sum(rho) +! write(6,*)'[rhoslo3d]sum(rho)=',rhochk + return + end + + subroutine ntrslo3d(exg,eyg,ezg,ex,ey,ez,msk,ab,de,gh, + &indx,jndx,kndx,indxp1,jndxp1,kndxp1,nx,ny,nz,np) + use parallel + implicit double precision(a-h,o-z) + logical msk + dimension exg(nx,ny,nz),eyg(nx,ny,nz),ezg(nx,ny,nz) +!hpf$ distribute exg(*,*,block) +!hpf$ align (*,*,:) with exg(*,*,:) :: eyg,ezg + dimension ex(np),ey(np),ez(np),msk(np) + dimension ab(np),de(np),gh(np),indx(np),jndx(np),kndx(np), + &indxp1(np),jndxp1(np),kndxp1(np) +!hpf$ template t1(np) +!hpf$ distribute t1(block) +!hpf$ align (:) with t1(:) :: ex,ey,ez,msk,ab,de,gh +!hpf$ align (:) with t1(:) :: indx,jndx,kndx,indxp1,jndxp1,kndxp1 + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi +! if(idproc.eq.0)write(6,*)'inside ntrslo3d' +! if(idproc.eq.0)then +! do n=1,np +! if(indx(n).lt.1 .or. indx(n).gt.nx)write(6,*)'error: indx(n)' +! enddo +! do n=1,np +! if(jndx(n).lt.1 .or. jndx(n).gt.ny)write(6,*)'error: jndx(n)' +! enddo +! do n=1,np +! if(kndx(n).lt.1 .or. kndx(n).gt.nz)write(6,*)'error: kndx(n)' +! enddo +! do n=1,np +! if(indxp1(n).lt.1.or.indxp1(n).gt.nx)write(6,*)'err:indxp1(n)' +! enddo +! do n=1,np +! if(jndxp1(n).lt.1.or.jndxp1(n).gt.ny)write(6,*)'err:jndxp1(n)' +! enddo +! do n=1,np +! if(kndxp1(n).lt.1.or.kndxp1(n).gt.nz)write(6,*)'err:kndxp1(n)' +! enddo +! endif +cryne forall(n=1:np)ex(n)= + do 100 n=1,np + ex(n)= & + & exg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) + &+exg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) + &+exg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) + &+exg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) + &+exg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) + &+exg(indxp1(n), + &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) + &+exg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) + &+exg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) + 100 continue + +cryne forall(n=1:np)ey(n)= + do 200 n=1,np + ey(n)= & + & eyg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) + &+eyg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) + &+eyg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) + &+eyg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) + &+eyg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) + &+eyg(indxp1(n), + &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) + &+eyg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) + &+eyg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) + 200 continue + +cryne forall(n=1:np)ez(n)= + do 300 n=1,np + ez(n)= & + & ezg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) + &+ezg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) + &+ezg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) + &+ezg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) + &+ezg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) + &+ezg(indxp1(n), + &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) + &+ezg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) + &+ezg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) + 300 continue +! if(idproc.eq.0)write(6,*)'leaving ntrslo3d' + return + end +c +c block data etimes +c common/accum/at10,at21,at32,at43,at54,at65,at76,at70 +c data at10,at21,at32,at43,at54,at65,at76,at70/0.,0.,0.,0.,0.,0.,0.,& +c & 0./ +c end diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/spch3d_mod.f90 new file mode 100755 index 0000000..03789e6 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/spch3d_mod.f90 @@ -0,0 +1,43 @@ +module spchdata + implicit none +!!! real*8, dimension(:,:,:), allocatable :: rho + complex*16, dimension(:,:,:), allocatable :: rho2 + complex*16, dimension(:,:,:), allocatable :: grnxtr,rho2xtr +!3/21/03 added three more arrays: + complex*16, dimension(:,:,:), allocatable::xgrnxtr,ygrnxtr,zgrnxtr +save + +contains + + subroutine new_spchdata(nx,ny,nz,n1,n2,n3a,isolve) + implicit none + integer :: nx,ny,nz,n1,n2,n3a,isolve + integer :: ierror +!!! allocate(rho(nx,ny,nz)) + if( isolve .ge. 10 )return !ANAG solver doesnt need these arrays + allocate(rho2(n1,n2,n3a),stat=ierror) + if( ierror .NE. 0 )then + print*,'error: new_spchdata: allocate(rho2) failed with code ',ierror + stop 'NEWSPCH' + endif + allocate(grnxtr(n3a,n2,n1),rho2xtr(n3a,n2,n1),stat=ierror) + if( ierror .NE. 0 )then + print*,'error: new_spchdata: allocate({grn,rho2}xtr) failed with code ',ierror + stop 'NEWSPCH' + endif +!3/21/03 three more arrays: + allocate(xgrnxtr(n3a,n2,n1),ygrnxtr(n3a,n2,n1),zgrnxtr(n3a,n2,n1),stat=ierror) + if( ierror .NE. 0 )then + print*,'error: new_spchdata: allocate({xyz}grnxtr) failed with code ',ierror + stop 'NEWSPCH' + endif + end subroutine new_spchdata + + subroutine del_spchdata +!!! deallocate(rho) + deallocate(rho2) + deallocate(grnxtr,rho2xtr) +!3/21/03 three more arrays: + deallocate(xgrnxtr,ygrnxtr,zgrnxtr) + end subroutine del_spchdata +end module spchdata diff --git a/OpticsJan2020/MLI_light_optics/Src/sss.f b/OpticsJan2020/MLI_light_optics/Src/sss.f new file mode 100755 index 0000000..3c66287 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/sss.f @@ -0,0 +1,580 @@ +*********************************************************************** +c +c THIS FILE CONTAINS THE ROUTINES THAT IMPLEMENT THE SCALING +c SPLITTING SQUARING (SSS) ALGORITHM FOR MARYLIE5.0 +c (Written 23 April 97) +c (Fixed 8 May 97) +c (Modified 4 Aug 97) +*********************************************************************** +c + subroutine sss(p,ga,gm) +c +c This routine performs the Dragt-Finn factorization of the map +c exp(-t:h:) using the Scaling Splitting, Squaring algorithm. +c The arrays ga initially contains the Hamiltonian h. +c +c Two options are possible: +c 1. ncheck = 0 ; the calculation of the map is done only once. +c The number of squarings np is fixed by the requirement that +c |norm(JS)*.5**np| < eps, with eps specified by the user. +c 2. ncheck =/= 0 ; the calculation of the map is repeated with np=np+1 +c and the difference between selected generators of the map +c calculated with np and np+1 squarings checked. +c If the relative difference is greater than 'err' the calculation is +c repeated by increasing np by one. If the relative difference increases +c with np (round off errors) the algorithm is stopped. +c +c Written by M.Venturini April 23, 97. +c Modified Aug. 4, 97 (M.V.) +c +c*************************** +c err = error allowed for the map generators +c integration length = t +c np = # of squaring +c eps = max norm of the linear part of the generators +c npse = n. of squaring set by the user regardless of err +c (if npse=0 np is set based on err) +c*************************** +c + use lieaparam, only : monoms + implicit double precision (a-h,o-z) + include 'files.inc' +c + parameter(err=1.d-13) +c + character*3 kynd + dimension p(6) + dimension fa(monoms),fm(6,6) + dimension ga(monoms),gm(6,6) + dimension fa2(monoms),fm2(6,6) + dimension fap(monoms),fmp(6,6) + dimension faw(monoms),fmw(6,6) +c + t=p(1) + nmapf=nint(p(2)) + nmapg=nint(p(3)) + eps=p(4) + ncheck=nint(p(5)) + npset=nint(p(6)) +c +c Get the array fa + if (nmapf.eq.0) call mapmap(ga,gm,fa,fm) + if (nmapg.ge.1 .and. nmapf.le.5) then + kynd='gtm' + call strget(kynd,nmapf,fa,fm) + endif +c +c Multiply fa by t + call csmul(t,fa,fa) +c + If(npset.gt.0) then + np=nint(p(6)) + ncheck=0 +cryne write(jof,*) ' ' +cryne write(jof,*) 'number of squaring np=',np + write(jodf,*) ' ' + write(jodf,*) 'number of squaring np=',np + goto 21 + endif +c +c Compute the number of squarings based on eps +c + call matify(fm,fa) + call mnorm(fm,res) + np=1 + scale=.5d0 + 10 continue + test=6*res*scale + if (test .lt. eps) goto 20 + np=np+1 + scale=scale/2.d0 + goto 10 + 20 continue +c +cryne write(jof,*) ' ' +cryne write(jof,*) 'number of squaring np=',np +cryne write(jof,*) 'norm of the linear part of the map generators',res +cryne write(jof,*) 'scale',scale +cryne write(jof,*) ' ' +c + write(jodf,*) ' ' + write(jodf,*) 'number of squaring np=',np + write(jodf,*) 'norm of the linear part of the map generators',res + write(jodf,*) 'scale',scale + write(jodf,*) ' ' +cryne 6/21/2002 +cryne put in a diagnostic until we are sure that these routines are +cryne robust when ncheck=0: + if(ncheck.eq.0 .and. np.lt.5)then + write(jof,*)'WARNING FROM SUBROUTINE SSS: # OF SPLITTINGS=',np + write(jodf,*)'WARNING FROM SUBROUTINE SSS: # OF SPLITTINGS=',np + endif +c + if (ncheck.ne.0) then + call mapmap(fa,fm,fap,fmp) + endif +c + 21 tau=1/2.d0**np + call splitT(np,tau,fa,fm) +c +c Concatenate +c + do 30 i=1,np + call concat(fa,fm,fa,fm,fa2,fm2) + call mapmap(fa2,fm2,fa,fm) + 30 continue +c +c Want to increase np? +c + if (ncheck.eq.0) goto 70 +c + reldifbef=1 + 50 continue + fbef463 = fa(463) + np=np+1 + tau=1/2.d0**np + call mapmap(fap,fmp,fa,fm) + call splitT(np,tau,fa,fm) +c + do 31 i=1,np + call concat(fa,fm,fa,fm,fa2,fm2) + call mapmap(fa2,fm2,fa,fm) + 31 continue +c +c + diff463 = fa(463) -fbef463 + reldif=diff463/fa(463) +c + write(jof,*)'np=',np,' f(463)=',fa(463) + write(jof,*)'np=',np-1,' f(463)=',fbef463 + write(jof,*)'difference =',diff463 + write(jof,*)'relative error =',reldif + write(jof,*)' ' +c + write(jodf,*)'np=',np,' f(463)=',fa(463) + write(jodf,*)'np=',np-1,' f(463)=',fbef463 + write(jodf,*)'difference =',diff463 + write(jodf,*)'relative error =',reldif + write(jodf,*)' ' + +c +c Stop the calculation if the relative error increases with np +c + if (abs(reldifbef).lt. abs(reldif)) then +c + write(jof,*) 'Increasing np (n. of squaring) does not' + write(jof,*) 'improve the accuracy.' + write(jof,*) 'Stop at np=',np-1 + write(jof,*) ' ' +c + write(jodf,*) 'Increasing np (n. of squaring) does not' + write(jodf,*) 'improve the accuracy.' + write(jodf,*) 'Stop at np=',np-1 + write(jodf,*) ' ' +c + call mapmap(faw,fmw,fa,fm) + goto 70 + endif +c + call mapmap(fa,fm,faw,fmw) + reldifbef=reldif +c + if (abs(reldif).le. err) then + goto 70 + endif +c + goto 50 +c +c Set the output +c + 70 if (nmapg.ge.1 .and. nmapg.le.5) then + kynd='stm' + call strget(kynd,nmapg,fa,fm) + endif +c + if (nmapg.eq.0) call mapmap(fa,fm,ga,gm) +c + return + end +c +*********************************************************************** +c + subroutine splitT(np,tau,ga,gm) +c +c The routine calculates the splitting term in the SSS algorithm +c using the Taylor expansion of the generators through 5th order +c in t=tau. The expansions have been evaluated using a Mathematica program. +c The splitting term has the structure: +c R(t) exp(:g3(t):) exp(:g4(t):) exp(:g5(t):) exp(:g6(t):), +c The gn(t) are given through 5th order in t. R(t) is computed +c using the routine 'exptay'. +c Written by M.Venturini April 23, 97. +c Modified Aug. 4, 97 M.V. + +c +c np = number of squarings +c + implicit double precision (a-h,o-z) + dimension h(923),hw(923),hw1(923),ga(923),gm(6,6),hm(6,6) + dimension em(6,6) +c + dimension pb23(923),pb2p23(923),pb2p33(923) + dimension pb24(923),pb2p24(923),pb2p34(923) + dimension pb25(923),pb2p25(923),pb2p35(923) +c + dimension pb234(923),pb233(923),pb2p233(923),pb3b233(923) + dimension pb34(923),pb2p2324(923),pb2p234(923),pb2324(923) +c +c Map the content of ga,gm into ha,hm + call mapmap(ga,gm,h,hm) +c +c Reset ga,gm: + call clear(ga,gm) +c +c Evaluate the linear part: +c + do 10 i=7,27 + ga(i)= -tau*h(i) + 10 continue +c + call matify(em,ga) + call exptay(em,gm) +c +c +c Evaluate some recurrent quantities +c + tau2=tau*tau + tau3=tau2*tau + tau4=tau3*tau + tau5=tau4*tau +c----------- +c pb23= :h2: h3 + call pbkt1(h,2,h,3,pb23) +c +c pb2p23=:h2:^2 h3 + call pbkt1(h,2,pb23,3,pb2p23) +c +c pb2p33 = :h2:^3 h3 + call pbkt1(h,2,pb2p23,3,pb2p33) +c +c------- +c pb24= :h2: h4 + call pbkt1(h,2,h,4,pb24) +c +c pb2p24=:h2:^2 h4 + call pbkt1(h,2,pb24,4,pb2p24) +c +c pb2p34 = :h2:^3 h4 + call pbkt1(h,2,pb2p24,4,pb2p34) +c-------- +c +c pb25= :h2: h5 + call pbkt1(h,2,h,5,pb25) +c +c pb2p25=:h2:^2 h5 + call pbkt1(h,2,pb25,5,pb2p25) +c +c pb2p35 = :h2:^3 h5 + call pbkt1(h,2,pb2p25,5,pb2p35) +c +c-------- +c pb34 = [h3,h4] + call pbkt1(h,3,h,4,pb34) +c +c pb234 = [[h2,h3],h4] + call pbkt1(pb23,3,h,4,pb234) +c +c pb233 = [[h2,h3],h3] + call pbkt1(pb23,3,h,3,pb233) + +c pb2p233 = [:h2:^2 h3 ,h3] + call pbkt1(pb2p23,3,h,3,pb2p233) +c +c pb3b233 = [h3,[:h2: h3,h3]] + call pbkt1(h,3,pb233,4,pb3b233) +c +c pb2p234 = [:h2:^2 h3,h4] + call pbkt1(pb2p23,3,h,4,pb2p234) +c +c pb2p2324 = [:h2: h3, :h2: h4] + call pbkt1(pb23,3,pb24,4,pb2324) +c +c +c +c*************************** +c Evaluate the g3 term (only the direct term is present): +c + call dirterm(tau,h,3,ga) +c +c************************** +c Evaluate the g4 term: +c direct term + call dirterm(tau,h,4,ga) +c +c feed-up term + tc=tau3/12 + call pmadd(pb233,4,tc,ga) +c + tc=tau4/24 + call pmadd(pb2p233,4,tc,ga) +c + call pbkt1(pb2p23,3,pb23,3,hw) + tc=tau5/120 + call pmadd(hw,4,tc,ga) +c + call pbkt1(pb2p33,3,h,3,hw) + tc=tau5/80 + call pmadd(hw,4,tc,ga) +c +c************************** +c Evaluate the g5 term: +c direct term + call dirterm(tau,h,5,ga) +c +c feed-up term +c1 + tc=-tau2/2 + call pmadd(pb34,5,tc,ga) +c2 + call pbkt1(h,3,pb24,4,hw) + tc=-tau3/3 + call pmadd(hw,5,tc,ga) +c3 + tc=-tau3/6 + call pmadd(pb234,5,tc,ga) +c4 + tc=tau4/24 + call pmadd(pb3b233,5,tc,ga) +c5 + call pbkt1(h,3,pb2p24,4,hw) + tc=-tau4/8 + call pmadd(hw,5,tc,ga) +c6 + tc=-tau4/8 + call pmadd(pb2324,5,tc,ga) +c7 + tc=-tau4/24 + call pmadd(pb2p234,5,tc,ga) +c8 + call pbkt1(h,3,pb2p233,4,hw) + tc=tau5/45 + call pmadd(hw,5,tc,ga) +c9 + call pbkt1(h,3,pb2p34,4,hw) + tc = -tau5/30 + call pmadd(hw,5,tc,ga) +c10 + call pbkt1(pb23,3,pb233,4,hw) + tc = tau5/60 + call pmadd(hw,5,tc,ga) +c11 + call pbkt1(pb23,3,pb2p24,4,hw) + tc = -tau5/20 + call pmadd(hw,5,tc,ga) +c12 + call pbkt1(pb2p23,3,pb24,4,hw) + tc = -tau5/30 + call pmadd(hw,5,tc,ga) +c13 + call pbkt1(pb2p33,3,h,4,hw) + tc = -tau5/120 + call pmadd(hw,5,tc,ga) +c +c +c************************** +c +c Evaluate the g6 term +c direct term + call dirterm(tau,h,6,ga) +c +c feed-up term +c1 + call pbkt1(h,3,h,5,hw) + tc = -tau2/2 + call pmadd(hw,6,tc,ga) +c2 + call pbkt1(h,3,pb34,5,hw) + tc = -tau3/6 + call pmadd(hw,6,tc,ga) +c3 + call pbkt1(h,3,pb25,5,hw) + tc = -tau3/3 + call pmadd(hw,6,tc,ga) +c4 + call pbkt1(pb23,3,h,5,hw) + tc = -tau3/6 + call pmadd(hw,6,tc,ga) +c5 + call pbkt1(pb24,4,h,4,hw) + tc = tau3/12 + call pmadd(hw,6,tc,ga) +c6 + call pbkt1(h,3,pb24,4,hw1) + call pbkt1(h,3,hw1,5,hw) + tc = -tau4/8 + call pmadd(hw,6,tc,ga) +c7 + call pbkt1(h,3,pb234,5,hw) + tc = -tau4/16 + call pmadd(hw,6,tc,ga) +c8 + call pbkt1(h,3,pb2p25,5,hw) + tc = -tau4/8 + call pmadd(hw,6,tc,ga) +c9 + call pbkt1(h,4,pb233,4,hw) + tc = tau4/48 + call pmadd(hw,6,tc,ga) +c10 + call pbkt1(pb23,3,pb34,5,hw) + tc = -tau4/16 + call pmadd(hw,6,tc,ga) +c11 + call pbkt1(pb23,3,pb25,5,hw) + tc = -tau4/8 + call pmadd(hw,6,tc,ga) +c12 + call pbkt1(pb2p23,3,h,5,hw) + tc = -tau4/24 + call pmadd(hw,6,tc,ga) +c13 + call pbkt1(pb2p24,4,h,4,hw) + tc = tau4/24 + call pmadd(hw,6,tc,ga) +c14 + call pbkt1(h,3,pb3b233,5,hw) + tc = tau5/80 + call pmadd(hw,6,tc,ga) +c15 + call pbkt1(h,3,pb2p24,4,hw1) + call pbkt1(h,3,hw1,5,hw) + tc = -tau5/20 + call pmadd(hw,6,tc,ga) +c16 + call pbkt1(h,3,pb2324,5,hw) + tc = -tau5/20 + call pmadd(hw,6,tc,ga) +c17 + call pbkt1(h,3,pb2p234,5,hw) + tc = -tau5/60 + call pmadd(hw,6,tc,ga) +c18 + call pbkt1(h,3,pb2p35,5,hw) + tc = -tau5/30 + call pmadd(hw,6,tc,ga) +c19 + call pbkt1(h,4,pb2p233,4,hw) + tc = tau5/80 + call pmadd(hw,6,tc,ga) +c20 + call pbkt1(h,3,pb24,4,hw1) + call pbkt1(pb23,3,hw1,5,hw) + tc = -tau5/20 + call pmadd(hw,6,tc,ga) +c21 + call pbkt1(pb23,3,pb234,5,hw) + tc = -tau5/40 + call pmadd(hw,6,tc,ga) +c22 + call pbkt1(pb23,3,pb2p25,5,hw) + tc = -tau5/20 + call pmadd(hw,6,tc,ga) +c23 + call pbkt1(pb24,4,pb233,4,hw) + tc = tau5/240 + call pmadd(hw,6,tc,ga) +c24 + call pbkt1(pb2p23,3,pb34,5,hw) + tc = -tau5/60 + call pmadd(hw,6,tc,ga) +c25 + call pbkt1(pb2p23,3,pb25,5,hw) + tc = -tau5/30 + call pmadd(hw,6,tc,ga) +c26 + call pbkt1(pb2p24,4,pb24,4,hw) + tc = tau5/120 + call pmadd(hw,6,tc,ga) +c27 + call pbkt1(pb2p33,3,h,5,hw) + tc = -tau5/120 + call pmadd(hw,6,tc,ga) +c28 + call pbkt1(pb2p34,4,h,4,hw) + tc = tau5/80 + call pmadd(hw,6,tc,ga) +c + return + end +c +*********************************************************************** +c + subroutine dirterm(t,h,ideg,ga) +c +c The routine calculates g =- sum_{i=1}^{nt} (t^i/i!) :h_2:^{i-1} h_{ideg} +c through t^nt; +c (direct term in the SSS algorithm). +c Written by M.Venturini April 23, 97. +c + implicit double precision (a-h,o-z) + parameter(nt=5) + dimension h(923),hw(923),ga(923),hw1(923) + dimension isup(6),iinf(6) + data iinf /0,0,28,84,210,462/ + data isup /0,0,83,209,461,923/ + save iinf,isup !cryne 7/23/2002 +c +c Initialize + do 10 i=iinf(ideg),isup(ideg) + hw(i)=h(i) + ga(i)=0.d0 + 10 continue +c + tc=t + call pmadd(hw,ideg,-tc,ga) +c + do 20 i=2,nt + call pbkt1(h,2,hw,ideg,hw1) + tc=tc*t/float(i) + call pmadd(hw1,ideg,-tc,ga) +c + do 11 j=iinf(ideg),isup(ideg) + hw(j)=hw1(j) + 11 continue +c + 20 continue +c + return + end +c +*********************************************************************** +c + subroutine expJS(ga,gm) +c +c The subroutine calculates the matrix exp. out of the +c Lie generator gm. For now the sub cex is called. In the +c future a direct algorithm should be implemented. +c Written by M.Venturini April 24, 97. +c + implicit double precision (a-h,o-z) + dimension p(6),gm(6,6),ga(923),ga2(923) +c + do i=7,923 + ga2(i)=ga(i) + enddo +c + do i=28,923 + ga2(i)=0.d0 + enddo +c + p(1)=1.d0 + p(2)=0 + p(3)=0 +c + call cex(p,ga2,gm) +c + return + end +c +*********************************************************************** + diff --git a/OpticsJan2020/MLI_light_optics/Src/timer_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/timer_mod.f90 new file mode 100755 index 0000000..7ad54d6 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/timer_mod.f90 @@ -0,0 +1,138 @@ +module ml_timer + implicit none + integer, parameter :: ntimers=16 + integer :: ihertz + real*8 :: hertz + real*8, dimension(6*ntimers) :: time_vec +! each 5-vec contains, for a given operation: +! 1: start time for an operation during a step +! 2: elapsed time for an operation during a step +! 3: elasped time (minimum over PEs) during a step +! 4: elasped time (maximum over PEs) during a step +! 5: elasped time (average over PEs) during a step +! 6: elasped time (maximum over PEs) accumulated since start of run +! + character*16 :: opname(ntimers) + save +contains + + subroutine init_ml_timers + use parallel + implicit none + integer n + opname(1)='step' + opname(2)='raysin' + opname(3)='spch3d' + opname(4)='rhoslo3d' + opname(5)='ntrslo3d' + opname(6)='greenf3d' + opname(7)='fft' + opname(8)='transp' + opname(9)='eval' + opname(10)='moments' + opname(11)='ccfftnr' + opname(12)='profile1d' + opname(13)='timer1' + opname(14)='timer2' + opname(15)='timer3' + opname(16)='timer4' + call system_clock(count_rate=ihertz) + hertz=ihertz + time_vec(1:6*ntimers)=0.d0 + if(idproc.eq.0)then + write(71,100)(opname(n)(1:10),n=1,ntimers) + write(72,100)(opname(n)(1:10),n=1,ntimers) + write(73,100)(opname(n)(1:10),n=1,ntimers) + 100 format(12x,20(a10,1x)) + endif + end subroutine init_ml_timers +! + subroutine init_step_timer + implicit none + integer n + do n=1,ntimers + time_vec(6*n-4)=0.d0 + enddo + end subroutine init_step_timer +! + subroutine increment_timer(str,init) +! stores the times at which various operations have been completed + implicit none + character(len=*) :: str + integer :: init,iticks,n,n1,n2 +! time_vec(n1) is the oldest stored time, time_vec(n2) is the most recent + do n=1,ntimers + n1=6*n-5 + n2=6*n-4 + if(str.ne.trim(opname(n)))cycle + call system_clock(count=iticks) + if(init.eq.0)then + time_vec(n1)=iticks/hertz + else + time_vec(n2)=time_vec(n2)+(iticks/hertz-time_vec(n1)) + endif + return + enddo + write(6,*)'timer error: string ',str,' not found.' + end subroutine increment_timer +! + subroutine step_timer(str,ioscreen) +! to be called at the end of each ste. computes, for all operations: +! the min/max times/proc in a step, the average time/proc in a step, +! and the total accumulated time + use parallel + implicit none + character*16 :: str + integer ioscreen + integer :: n,ierror + real*8, dimension(2*ntimers) :: tmp,gtmp +!---------------- + do n=1,ntimers +! "t_elapsed=time_vec(2)-time_vec(1)" + tmp(2*n-1)=-time_vec(6*n-4) + tmp(2*n )=+time_vec(6*n-4) + enddo + call MPI_ALLREDUCE(tmp,gtmp,2*ntimers,mreal,mpimax,lworld,ierror) + do n=1,ntimers + time_vec(6*n-3)=-gtmp(2*n-1) + time_vec(6*n-2)=+gtmp(2*n) + enddo +!---------------- + do n=1,ntimers + tmp(n)=time_vec(6*n-4) + enddo + call MPI_ALLREDUCE(tmp,gtmp,ntimers,mreal,mpisum,lworld,ierror) + do n=1,ntimers + time_vec(6*n-1)=gtmp(n)/nvp + time_vec(6*n)=time_vec(6*n)+time_vec(6*n-2) + enddo +!---------------- + if(idproc.eq.0)then +! minimum times: + write(71,101)str(1:8),(time_vec(6*n-3),n=1,ntimers) +! maximum times: + write(72,101)str(1:8),(time_vec(6*n-2),n=1,ntimers) + if(ioscreen.eq.-1)write(6,101)str(1:8),(time_vec(6*n-2),n=1,ntimers) +! average times: + write(73,101)str(1:8),(time_vec(6*n-1),n=1,ntimers) + 101 format(a8,1x,12(1pe10.3,1x)) + endif +! + do n=1,ntimers + time_vec(6*n-4)=0.d0 + enddo + end subroutine step_timer +! +! + subroutine end_ml_timers + use parallel + implicit none + integer n + if(idproc.eq.0)then + do n=1,ntimers + write(6,100)opname(n),time_vec(6*n) + enddo + 100 format(a16,'::',1pe13.6) + endif + end subroutine end_ml_timers +end module ml_timer diff --git a/OpticsJan2020/MLI_light_optics/Src/trac.f b/OpticsJan2020/MLI_light_optics/Src/trac.f new file mode 100755 index 0000000..3161497 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/trac.f @@ -0,0 +1,1674 @@ +************************************************************************ +* header: TRACK * +* Particle tracking, both symplectic and non-symplectic. * +************************************************************************ +c + subroutine eval(amh,norder,ntrace,nwrite,nunit,idmin,idmax, & + & nprecision) +c +c evaluates the image zf of initial +c data zi under the lie transformation +c with linear part having matrix representation +c mh and nonlinear part having generators +c with coefficients stored in the array h +c + use multitrack !includes 'use rays' May 9, 2006 + use lieaparam, only : monoms + include 'impli.inc' +cryne May 22, 2006 need reftraj from map.inc + include 'map.inc' + include 'ind.inc' + include 'pbkh.inc' + include 'lims.inc' + include 'vblist.inc' + include 'files.inc' +c +c xmh is a local array, amh is in the argument list: + dimension xmh(6,6), amh(6,6) + dimension tempz(6),vect(923) +c +c write(6,*)'HELLO FROM TRACE' + write(6,*)'inside eval with norder=',norder + if(.not.allocated(tblock))then + write(6,*)'error:tblock not allocated' + stop + endif +c +c generate tempz=amh*zi (linear contribution) +c + ktrace=ntrace + if(ktrace.eq.0)ktrace=1 +c + do 9999 idum=1,ktrace + do 5678 nnnn=1,nraysp +c +c store 6-vector in zi. +cNote that zi(5), zi(6) get changed below if multitrac.ne.0 + zi(1:6)=zblock(1:6,nnnn) +c +c Default (multitrac=0) is to use the current transfer map mh: + if(multitrac.eq.0)xmh(1:6,1:6)=amh(1:6,1:6) +c + if(multitrac.ne.0)then + imin=inear(nnnn) + jmin=jnear(nnnn) + xmh(1:6,1:6)=tmhlist(1:6,1:6,imin,jmin) + zi(5)=tdelt(nnnn) + zi(6)=ptdelt(nnnn) + endif +c +c +c perform matrix-vector multiply: + tempz(1:6)=0.d0 + do 30 i=1,6 + do 20 k=1,6 + tempz(i)=tempz(i)+xmh(i,k)*zi(k) + 20 continue + 30 continue + tblock(1:6,nnnn)=tempz(1:6) + + if(norder.eq.1)goto 5001 +c +c loop to compute final values zf(i), including nonlinearities + vect(1:923)=0.d0 + vect(1:6) = tblock(1:6,nnnn) + do i=7,27 + vect(i) = vect(index1(i)) * vect(index2(i)) + enddo +c if(norder.ge.3)then + do i=28,83 + vect(i) = vect(index1(i)) * vect(index2(i)) + enddo +c endif +c if(norder.ge.4)then + do i=84,209 + vect(i) = vect(index1(i)) * vect(index2(i)) + enddo +c endif +c if(norder.ge.5)then + do i=210,461 + vect(i) = vect(index1(i)) * vect(index2(i)) + enddo +c endif +c if(norder.ge.6)then + do i=462,923 + vect(i) = vect(index1(i)) * vect(index2(i)) + enddo +c endif + + klast=923 + if(norder.eq.2)klast=27 + if(norder.eq.3)klast=83 + if(norder.eq.4)klast=209 + if(norder.eq.5)klast=461 + if(norder.eq.6)klast=923 +c if(multitrac.eq.0)then +c +c endif + if(multitrac.ne.0)then + pbh(:,:)=pbhlist(:,:,imin,jmin) +c call brkts(hlist(1,imin,jmin)) + endif + do i=1,6 + tmp = 0.d0 + do k=7,klast + tmp = tmp + pbh(k,i)*vect(k) + enddo + tblock(i,nnnn)=tblock(i,nnnn) + tmp + enddo + 5001 continue +c +c if using multiple maps, then shift the result back to with respect +c to the main reference trajectory: + if(multitrac.ne.0)then + tblock(5,nnnn)=tblock(5,nnnn)+ tlistfin(imin,jmin)-reftraj(5) + tblock(6,nnnn)=tblock(6,nnnn)+ptlistfin(imin,jmin)-reftraj(6) + endif + + 5678 continue + +cryne 3/25/04 : if ntrace.ge.0, copy the tblock data to zblock, +cryne then print what is in zblock. +cryne Otherwise, print what is tblock. NOTE WELL: this will +cryne ruin the tblock array, but that is OK since it is no +cryne longer needed after that data have been printed. +c +c Case with ntrace.ge.1: + if(ntrace.ge.1)then +! zblock(:,1:nraysp)=tblock(:,1:nraysp) + do j=1,nraysp + if(istat(j).eq.0)zblock(1:6,j)=tblock(1:6,j) + enddo + if(nwrite.ne.0)then + if( (mod(idum,nwrite).eq.0) .and. (jfcf.gt.0) )then + call pwritez(nunit,idmin,idmax,nprecision,0,0) + endif + endif + if(nwrite.ne.0)then + if( (mod(idum,nwrite).eq.0) .and. (jfcf.lt.0) )then + jfcf=-jfcf + call pwritezfp + jfcf=-jfcf + endif + endif + endif +c Case with ntrace.eq.0 (print rays trace results if requested, +c but do not do tracking, i.e. leave zblock unchanged): + if(ntrace.eq.0)then + if(nwrite.ne.0)then + if( (mod(idum,nwrite).eq.0) .and. (jfcf.gt.0) )then + call pwritet(nunit,idmin,idmax,nprecision) + endif + endif + if(nwrite.ne.0)then + if( (mod(idum,nwrite).eq.0) .and. (jfcf.lt.0) )then + jfcf=-jfcf + call pwritetfp + jfcf=-jfcf + endif + endif + endif + 9999 continue +c write(6,*)'LEAVING EVAL' + return + end +c +*********************************************************************** +c + subroutine evalsr_old(mh,zi,zf,df,rdf,rrjac) +cryne 8/13/02 sbroutne evalsr_old(mh,zi,zf) +c subroutine to evaluate the image zf of initial data zi under the +c lie transformation with linear part mh and nonlinear part +c represented by a standard representation stored in common/deriv/df +c this subroutine modified on 8/13/86 to change the +c order in which exp(:f2:) acts. +c canx was also modified accordingly. this +c whole subroutine needs rewriting badly AJD +c + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' +cryne 8/13/02 include 'deriv.inc' + include 'files.inc' + include 'ind.inc' + include 'len.inc' + double precision mh + dimension mh(6,6) +!!!!! dimension df(6,monoms),rdf(3,monom1+1),rrjac(3,3,monom2+1) + dimension df(6,monoms),rdf(3,monoms),rrjac(3,3,monoms) + dimension ztmp1(6),ztmp2(6),ztmp3(6) + dimension vect(monoms) +c zlm added for ordering modification 8/13/86 + dimension zlm(6) + dimension zi(6),zf(6) +c +c initialize arrays + zf(1:6)=0.d0 + ztmp1(1:6)=0.d0 + ztmp2(1:6)=0.d0 + ztmp3(1:6)=0.d0 +c also initialize zlm + zlm(1:6)=0.d0 +c the following section is added due to reordering: +c +c compute effect of linear part of the map on zi +c + do 40 i=1,6 + do 4 j=1,6 + zlm(i)=zlm(i) + mh(i,j)*zi(j) + 4 continue + 40 continue +c +c call newton search routine to find value of new momentum +c +c the following statement is commented out due to reordering +c call newt(zi,ztmp1,rdf,rrjac) +c the following statement is added due to reordering + call newt(zlm,ztmp1,rdf,rrjac) +cryne 8/15/02 call newt(zlm,ztmp1) +c +c compute vector containing values of basis monomials +c + do 2 i=1,6 + vect(i) = ztmp1(i) + 2 continue +c +c (only terms through order imaxi-1 are required) +c + do 20 i = 7,len(imaxi-1) + vect(i) = vect(index1(i))*vect(index2(i)) + 20 continue +c compute values of the new coords and old momenta using the standard +c rep of the transfer map which is stored in df +c + do 3000 i=1,5,2 + ivalue=i+1 + do 300 j=1,len(imaxi-1) +c +c new coordinate values + ztmp2(i)=ztmp2(i)+df(ivalue,j)*vect(j) +c ztmp2(i)= ddot(len(imaxi-1),vect,1,df(ivalue,1),6) +c old momentum values (done as a check) + ztmp3(ivalue)=ztmp3(ivalue)+df(i,j)*vect(j) + 300 continue +c ztmp3(ivalue)=ddot(len(imaxi-1),vect,1,df(i,1),6) +c +c transfer new momentum values to ztmp2 (these were returned from +c newt in ztmp1) +c + ztmp2(ivalue)=ztmp2(ivalue)+ztmp1(ivalue) + 3000 continue +c +c at this point, the nonlinearities are fixed. the image of +c the initial data under the nonlinear portion of the +c transformation is stored in ztmp2. before applying the linear +c part of the map to this, check to see if the old momentum values +c which were read in match those computed using the standard +c representation (done immediately above.) +c +c nonlinearities check +c + delpx=zi(2)-ztmp3(2) + delpy=zi(4)-ztmp3(4) + delpz=zi(6)-ztmp3(6) + if(ibrief.ne.2)goto 302 + write(jof,9250) + 9250 format(1h ,' **momentum deviations** ') + write(jof,9300)delpx,delpy,delpz + 9300 format(1h ,3(d22.15,2x)) + 302 continue +c the following statements are commented out due to reordering +c +c compute effect of linear part of the map on ztmp2 +c +c do 40 i=1,6 +c do 4 j=1,6 +c zf(i)=zf(i) + mh(i,j)*ztmp2(j) +c 4 continue +c 40 continue +c add the following lines due to reordering: + do 137 i=1,6 + 137 zf(i)=ztmp2(i) + return + end +c +*********************************************************************** +c + subroutine evalsr(mh,df,rdf,rrjac,norder,ntrace,nwrite,nunit, & + & idmin,idmax,nprecision) +c subroutine to evaluate the image zf of initial data zi under the +c lie transformation with linear part mh and nonlinear part +c represented by a standard representation stored in common/deriv/df +c this subroutine modified on 8/13/86 to change the +c order in which exp(:f2:) acts. +c canx was also modified accordingly. this +c whole subroutine needs rewriting badly AJD +c + use rays + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' +cryne 8/13/02 include 'deriv.inc' + include 'files.inc' + include 'ind.inc' + include 'len.inc' + double precision mh + dimension mh(6,6) +!!!!! dimension df(6,monoms),rdf(3,monom1+1),rrjac(3,3,monom2+1) + dimension df(6,monoms),rdf(3,monoms),rrjac(3,3,monoms) + dimension ztmp1(6),ztmp2(6),ztmp3(6) + dimension vect(monoms) +c zlm added for ordering modification 8/13/86 + dimension zlm(6) +!!!!! dimension zi(6),zf(6) +c + ktrace=ntrace + if(ktrace.eq.0)ktrace=1 +c + do 9999 idum=1,ktrace +c write(6,*)'idum=',idum +c + lda=6 + ldb=6 + ldc=6 + call DGEMM('N','N',6,nraysp,6,1.0d0,mh,lda, + &zblock,ldb,0.0d0,tblock,ldc) +c + if(norder.eq.1)then + goto 5001 + else + write(6,*) '(evalsr) computing nonlinear part' + endif +c + do 8500 nnn=1,nraysp + zi(1:6)=zblock(1:6,nnn) + zf(1:6)=0.d0 + ztmp1(1:6)=0.d0 + ztmp2(1:6)=0.d0 + ztmp3(1:6)=0.d0 +c +c the following section is added due to reordering: +c +c compute effect of linear part of the map on zi +c +! do 40 i=1,6 +! do 4 j=1,6 +! zlm(i)=zlm(i) + mh(i,j)*zi(j) +! 4 continue +! 40 continue + zlm(1:6)=tblock(1:6,nnn) +c +c call newton search routine to find value of new momentum +c +c the following statement is commented out due to reordering +c call newt(zi,ztmp1,rdf,rrjac) +c the following statement is added due to reordering + call newt(zlm,ztmp1,rdf,rrjac) +cryne 8/15/02 call newt(zlm,ztmp1) +c +c compute vector containing values of basis monomials +c + do 2 i=1,6 + vect(i) = ztmp1(i) + 2 continue +c +c (only terms through order imaxi-1 are required) +c + do 20 i = 7,len(imaxi-1) + vect(i) = vect(index1(i))*vect(index2(i)) + 20 continue +c compute values of the new coords and old momenta using the standard +c rep of the transfer map which is stored in df +c + do 3000 i=1,5,2 + ivalue=i+1 + do 300 j=1,len(imaxi-1) +c +c new coordinate values + ztmp2(i)=ztmp2(i)+df(ivalue,j)*vect(j) +c ztmp2(i)= ddot(len(imaxi-1),vect,1,df(ivalue,1),6) +c old momentum values (done as a check) + ztmp3(ivalue)=ztmp3(ivalue)+df(i,j)*vect(j) + 300 continue +c ztmp3(ivalue)=ddot(len(imaxi-1),vect,1,df(i,1),6) +c +c transfer new momentum values to ztmp2 (these were returned from +c newt in ztmp1) +c + ztmp2(ivalue)=ztmp2(ivalue)+ztmp1(ivalue) + 3000 continue +c +c at this point, the nonlinearities are fixed. the image of +c the initial data under the nonlinear portion of the +c transformation is stored in ztmp2. before applying the linear +c part of the map to this, check to see if the old momentum values +c which were read in match those computed using the standard +c representation (done immediately above.) +c +c nonlinearities check +c + delpx=zi(2)-ztmp3(2) + delpy=zi(4)-ztmp3(4) + delpz=zi(6)-ztmp3(6) + if(ibrief.ne.2)goto 302 + write(jof,9250) + 9250 format(1h ,' **momentum deviations** ') + write(jof,9300)delpx,delpy,delpz + 9300 format(1h ,3(d22.15,2x)) + 302 continue +c the following statements are commented out due to reordering +c +c compute effect of linear part of the map on ztmp2 +c +c do 40 i=1,6 +c do 4 j=1,6 +c zf(i)=zf(i) + mh(i,j)*ztmp2(j) +c 4 continue +c 40 continue +c add the following lines due to reordering: + do 137 i=1,6 + 137 zf(i)=ztmp2(i) +c +cryne May 22, 2006 if(ntrace.ge.1)then +cryne May 22, 2006 zblock(1:6,nnn)=zf(1:6) +cryne May 22, 2006 endif +c As in routine eval, the result should temporarily be in tblock: + tblock(1:6,nnn)=zf(1:6) +cryne May 22, 2006 + 8500 continue +c + 5001 continue +c +cryne May 22, 2006 -- Same code as from routine eval: +c +c Case with ntrace.ge.1: + if(ntrace.ge.1)then +! zblock(:,1:nraysp)=tblock(:,1:nraysp) + do j=1,nraysp + if(istat(j).eq.0)zblock(1:6,j)=tblock(1:6,j) + enddo + if(nwrite.ne.0)then + if( (mod(idum,nwrite).eq.0) .and. (jfcf.gt.0) )then + call pwritez(nunit,idmin,idmax,nprecision,0,0) + endif + endif + if(nwrite.ne.0)then + if( (mod(idum,nwrite).eq.0) .and. (jfcf.lt.0) )then + jfcf=-jfcf + call pwritezfp + jfcf=-jfcf + endif + endif + endif +c Case with ntrace.eq.0 (print rays trace results if requested, +c but do not do tracking, i.e. leave zblock unchanged): + if(ntrace.eq.0)then + if(nwrite.ne.0)then + if( (mod(idum,nwrite).eq.0) .and. (jfcf.gt.0) )then + call pwritet(nunit,idmin,idmax,nprecision) + endif + endif + if(nwrite.ne.0)then + if( (mod(idum,nwrite).eq.0) .and. (jfcf.lt.0) )then + jfcf=-jfcf + call pwritetfp + jfcf=-jfcf + endif + endif + endif + 9999 continue +c write(6,*)'LEAVING EVALSR' + return + end +c +*********************************************************************** +c +c subroutine canx +c the following line is commented out due to reordering; +c see the note below. +c subroutine canx(mh,h) +c the following line is inserted due to reordering. + subroutine canx(mh,h,norder) +c subroutine to establish standard rep of transfer map for +c use in evaluating ray traces. +c +cryne 5/22/02 implicit none + use lieaparam, only : monoms + include 'impli.inc' + include 'deriv.inc' + include 'len.inc' + include 'ind.inc' + external pbkt1,pbkt2,pmadd,product + integer i,j,k,l,m,n,nn,ior + integer ivalue,jvalue + integer index1,index2,jv,len,imaxi + integer iq,ip,jq,jp,kq,kp +cryne 5/22/02 double precision df,rjac + double precision deriv3 + double precision mh(6,6) + double precision dg(923,6) + double precision h(923),g(923),gtemp(923) + double precision dgtmp(923),crstrm(923),f(923) + double precision temp(923),dum(923),tmp1(923),tmp2(923) + double precision t1(6),t2(27),t3(83),t4(209),t5(461),t6(923) +cryne common/deriv/df(6,923) +cryne common/rjacob/rjac(3,3,923) +cryne 7/23/2002 common /len/len(16) +cryne 7/23/2002 common/ind/imaxi,jv(923),index1(923),index2(923) +c +c initialize arrays +c + do 1000 n=1,len(imaxi) + g(n)=0.d0 + gtemp(n)=0.d0 + dgtmp(n)=0.d0 + crstrm(n)=0.d0 + f(n)=0.d0 + t6(n) = 0.0d0 + temp(n)=0.d0 + tmp1(n)=0.d0 + tmp2(n)=0.d0 + dum(n)=0.d0 + do 1 m=1,6 + dg(n,m)=0.d0 + df(m,n)=0.d0 + 1 continue + do 100 l=1,3 + do 10 m=1,3 + rjac(l,m,n)=0.d0 + 10 continue + 100 continue + 1000 continue +c +c transfor nonlinear arrays by linear piece +c +c write(6,*) ' The Transfer Map is: ' +c do 7777 k=1,len(imaxi) +c if(dabs(h(k)).gt.1.d-10) write(6,*) k,h(k) +c 7777 continue +c do 200 k=3,imaxi +c do 2 l=1,len(imaxi) +c gtemp(l)=0.d0 +c 2 continue +c call xform5(h,k,mh,gtemp) +c do 20 l=1,len(imaxi) +c g(l)=g(l)+gtemp(l) +c 20 continue +c 200 continue +c +c The nonlinear part of h is not transformed, just copied to g: + do 20 l=1,len(imaxi) + g(l) = h(l) + 20 continue +c +c determine derivs of array g +c + do 303 ior = 3,imaxi-1 + do 300 i=1,6 + do 3 j=1,len(imaxi) + dgtmp(j)=0.d0 + 3 continue + call pbkt2(g,ior,i,dgtmp) + do 30 j=1,len(imaxi) + dg(j,i) = dg(j,i) + dgtmp(j) + 30 continue + 300 continue + 303 continue +c + ivalue = 0 + do 7 i= 1,5,2 + ivalue = ivalue+2 + call product(dg(1,i),2,dg(1,ivalue),2,crstrm) + if(imaxi.gt.4) then + call product(dg(1,i),2,dg(1,ivalue),3,crstrm) + call product(dg(1,i),3,dg(1,ivalue),2,crstrm) + endif + if (imaxi.gt.5) then +c The following implements the 2 derivative part of the contribution to F6. + call product(dg(1,i),3,dg(1,ivalue),3,crstrm) + call product(dg(1,i),2,dg(1,ivalue),4,crstrm) + call product(dg(1,i),4,dg(1,ivalue),2,crstrm) + endif + 7 continue +c +c sum all the contributions to F excluding terms +c with more than 2 derivs and commutators. +c + do 4 n=1,len(imaxi) + f(n)=f(n)-g(n)- crstrm(n)/2.0d0 + 4 continue +c +c +c Terms with 4 derivatives + if(imaxi.gt.4) then + do 808 nn = 1,461 + 808 t5(nn) = 0.0d0 + ip = 0 + do 800 iq = 1,5,2 + ip = ip+2 + call pbkt2(crstrm,4,iq,t3) + call product(t3,3,dg(1,ip),2,t5) + 800 continue + ip = 0 + do 900 iq = 1,5,2 + ip = ip+2 + jp = 0 + do 9000 jq = 1,5,2 + jp = jp+2 + call pbkt2(dg(1,ip),2,jp,t1) + do 999 nn=1,83 + 999 t3(nn) = 0.0d0 + call product(dg(1,iq),2,t1,1,t3) + call product(dg(1,jq),2,t3,3,t5) + 9000 continue + 900 continue +c + call pmadd(t5,5,-1.0d0/6.0d0,f) +c Commutator term + call pbkt1(g,3,g,4,temp) + call pmadd(temp,5,-1.0d0/2.0d0,f) + endif + if ( imaxi .gt. 5 ) then +c four derivative terms ( 1f4 x 2f3 ) +c ( See Dave's Notes ) +c term #1 and #2: + do 66 iq = 1,5,2 + ip = iq+1 + do 666 jq = 1,5,2 + jp = jq+1 + do 6666 nn=1,209 + 6666 t4(nn) = 0.0d0 + call pbkt2(dg(1,jq),2,ip,t1) + call product(t1,1,dg(1,jp),3,t4) + call pbkt2(dg(1,jp),3,ip,t2) + call product(t2,2,dg(1,jq),2,t4) +c add up + call product(dg(1,iq),2,t4,4,tmp1) + 666 continue + 66 continue +c term #3 + do 36 iq = 1,5,2 + ip=iq+1 + do 366 jq = 1,5,2 + jp = jq+1 + do 3666 nn = 1, 209 + 3666 t4(nn) = 0.0d0 + call pbkt2(dg(1,iq),2,jq,t1) + call product(t1,1,dg(1,jp),3,t4) + call product(dg(1,ip),2,t4,4,tmp1) + 366 continue + 36 continue +c add #1,#2,#2, with correct coefficient: +c + call pmadd(tmp1,6,-1.0d0/2.0d0,f) +c +c six derivative terms ( 4f3 ) +c +c + do 1777 iq = 1,5,2 + ip = iq+1 + do 177 jq = 1,5,2 + jp = jq+1 + call pbkt2(dg(1,ip),2,jp,t1) +c *** second term ( done with the first ). + call pbkt2(crstrm,4,iq,temp) + do 37 nn = 1, 83 + 37 t3(nn) = 0.0d0 + call product(t1,1,dg(1,jq),2,t3) + call product(t3,3,temp,3,dum) +c *** end second term ****** + do 17 kq = 1,5,2 + kp = kq+1 + do 117 nn = 1,27 + 117 t2(nn) = 0.0d0 + do 27 nn = 1,209 + 27 t4(nn) = 0.0d0 + deriv3 = t1(kq) + call pmadd(dg(1,iq),2,deriv3,t2) + call product(dg(1,jq),2,t2,2,t4) + call product(dg(1,kq),2,t4,4,t6) + 17 continue + 177 continue + 1777 continue +c *** 3rd term : + do 88 iq = 1,5,2 + ip = iq+1 + call pbkt2(t5,5,iq,t4) + call product(t4,4,dg(1,ip),2,t6) + 88 continue +c *** **** +c add second term with coeff 3. ): + call pmadd(dum,6,3.0d0,t6) +c + call pmadd(t6,6,-1.0d0/24.0d0,f) +c End Six derivative terms +c +c Commutator term: + call pbkt1(g,3,g,5,temp) + call pmadd(temp,6,-1.d0/2.0d0,f) + endif +C End six and 4 deriv terms ************** +c +c add in 2nd order piece +c + f(8)=f(8)+1.d0 + f(19)=f(19)+1.d0 + f(26)=f(26)+1.d0 +c +c print out F (debug mode only) +c write(6,*) ' The generating function F is : ' +c do 77 i=1,923 +c if (dabs(f(i)).gt.1.d-10 ) write(6,*) i,f(i) +c 77 continue +c +c======================================================= +c this is a quick hack to compare these results w/ 3.0: +c write(6,*)'(canx) hack' +c f(210:monoms)=0.d0 +c 8/15/02 verified that, for example 2_7, the symplectic +c tracking results are the same for ML3.0 and ML5.0 with +c the above statement enabled. RDR +c +cryne 12/31/2004: + if(norder.eq.4)f(462:monoms)=0.d0 + if(norder.eq.3)f(210:monoms)=0.d0 + if(norder.eq.2)f(84:monoms) =0.d0 +c======================================================= +c +c now compute the derivs of the generating fxn f (which define +c the standard representation of the canonical transformation) +c + do 5000 i=1,5,2 + do 500 k=2,imaxi + do 5 l=1,len(imaxi) + tmp1(l)=0.d0 + tmp2(l)=0.d0 + 5 continue + ivalue=i+1 + call pbkt2(f,k,ivalue,tmp1) + call pbkt2(f,k,i,tmp2) + do 50 l=1,len(imaxi) + df(i,l)=df(i,l)+tmp1(l) + df(ivalue,l)=df(ivalue,l)-tmp2(l) + 50 continue + 500 continue + 5000 continue +c print out the derivatives of F (debug only) +c write(6,*) ' The derivatives of F are :' +c do 771 i=1,6 +c write(6,772) i +c 772 format(' Derivatives with repect to z',i1, ' are:') +c do 773 l=1,923 +c if(dabs(df(i,l)).gt.1.d-10 ) write(6,*) l,df(i,l) +c 773 continue +c 771 continue +c +c now compute the jacobian of the momentum part of the +c standard rep (which will be used in sub. newton to determine +c the new momentum) +c + ivalue=0 + do 6000 i=1,5,2 + do 6 n=1,len(imaxi) + dum(n)=df(i,n) + 6 continue + ivalue=ivalue+1 + jvalue=0 + do 600 j=1,5,2 + jvalue=jvalue+1 + do 60 k=2,imaxi-1 + do 58 l=1,len(imaxi) + temp(l)=0.d0 + 58 continue + call pbkt2(dum,k,j,temp) + do 59 l=1,len(imaxi) + rjac(ivalue,jvalue,l)=rjac(ivalue,jvalue,l)+temp(l) + 59 continue + 60 continue + 600 continue + 6000 continue + return + end +c +*********************************************************************** +c + subroutine invrs(a,b,d) +c subroutine to compute the inverse b and determinant d +c of a 3x3 matrix a. used by newton search subroutine +c when searching for the new momentum. +c Written by D. Douglas, ca 1983 + include 'impli.inc' + include 'files.inc' + dimension a(3,3),b(3,3),c(3,3) + do 10 i=1,3 + do 1 j=1,3 + b(i,j)=0.d0 + c(i,j)=0.d0 + 1 continue + 10 continue +c +c compute determinant of a +c + d=a(1,1)*a(2,2)*a(3,3)+a(1,2)*a(2,3)*a(3,1)+a(1,3)*a(2,1)*a(3,2) + & -a(1,3)*a(2,2)*a(3,1)-a(1,1)*a(2,3)*a(3,2)-a(1,2)*a(2,1)*a(3,3) +c write(jof,9100)d +c9100 format(1h ,'determinant of a is ',d21.15) + abd=dabs(d) + if(abd.lt.1.d-30)write(6,9000) + 9000 format(1h ,'determinant underflow in subroutine invrs') + if(abd.lt.1.d-30)return +c +c compute b=inverse of a +c + b(1,1)=(a(2,2)*a(3,3)-a(3,2)*a(2,3))/d + b(2,2)=(a(1,1)*a(3,3)-a(1,3)*a(3,1))/d + b(3,3)=(a(1,1)*a(2,2)-a(1,2)*a(2,1))/d + b(1,2)=(a(1,3)*a(3,2)-a(1,2)*a(3,3))/d + b(1,3)=(a(1,2)*a(2,3)-a(2,2)*a(1,3))/d + b(2,1)=(a(2,3)*a(3,1)-a(2,1)*a(3,3))/d + b(2,3)=(a(2,1)*a(1,3)-a(1,1)*a(2,3))/d + b(3,1)=(a(2,1)*a(3,2)-a(2,2)*a(3,1))/d + b(3,2)=(a(1,2)*a(3,1)-a(1,1)*a(3,2))/d +c +c check if this is a reasonable inverse +c +c do 200 i=1,3 +c do 20 j=1,3 +c do 2 k=1,3 +c c(i,j)=c(i,j) + a(i,k)*b(k,j) +c 2 continue +c 20 continue +c 200 continue +c write(6,9150) +c9150 format(1h ,'a * ainverse = '/) +c do 3 i=1,3 +c write(6,9200)(c(i,j),j=1,3) +c9200 format(1h ,3(d21.15,2x)) +c 3 continue + return + end +c +*********************************************************************** +c + subroutine newt(zi,zo,rdf,rrjac) +cryne 8/15/02 subroutine newt(zi,zo) +c subroutine to invert map p(old)=df(q(old),p(new))/dq(old) +c for p(new) using a newton's search procedure +c +c Written by D. Douglas, ca 1983 and substantially modified +c by F. Neri +c + use lieaparam, only : monoms + include 'impli.inc' +cryne 8/15/02 include 'deriv.inc' +cryne 8/15/02 dimension rdf(3,monom1+1),rrjac(3,3,monom2+1) + dimension rdf(3,monoms),rrjac(3,3,monoms) + dimension ztmp(6),zi(6),zo(6) + dimension rlin(3,3),rmat(3,3),ri(3,3),rinv(3,3) + dimension pi(3),crtrm(3),pimag(3),p(3),delp(3),cp(3) + dimension pjac(3,3,84),pdf(3,84) + dimension qvec(84),pvec(84) + include 'files.inc' + include 'ind.inc' + include 'len.inc' + include 'len3.inc' + include 'ind3.inc' + include 'talk.inc' + data ri/1.,3*0.,1.,3*0.,1./ +cryne 5/22/02 + save ri +c +c initialize arrays +c + l31=len3(imaxi-1) + l32=len3(imaxi-2) + ivalue=0 + do 1 i=1,3 + ivalue=ivalue+2 + pi(i)=zi(ivalue) + 1 continue + do 2 i=1,6 + ztmp(i)=zi(i) + 2 continue +c +c generate monomials in the q's +c + qvec(1) = 1.0d0 + ivalue=-1 + do 10 i=1,3 + ivalue=ivalue+2 + qvec(i+1)=ztmp(ivalue) + 10 continue + do 11 i=5,len3(imaxi-1)+1 + qvec(i)=qvec(ind31(i))*qvec(ind32(i)) + 11 continue +c +c generate coefficient of polynomials in the momentum +c variables +c + do 1001 i1=1,3 + do 1001 i2=1,3 + pjac(i1,i2,1)=0.d0 + 1001 continue +c + do 1002 n=1,4 + do 1003 i=1,3 + pdf(i,n) = 0.d0 + 1003 continue + 1002 continue +c +c generate coefficients of reduced df (pdf),function only of p: +c*********************** + do 190 i = 1,3 + do 190 ip = 5,len3(imaxi-1)+1 + pdf(i,ip) = rdf(i,ip) + 190 continue +c***** previous loops replaced by: ************* +c call dcopy(3*(len3(imaxi-1)-3),rdf(1,5),1,pdf(1,5),1) +c********************** + n0 = len3(imaxi-1)+1 + iq2=1 + do 9 ipoq=1,imaxi-2 + iq1=iq2+1 + iq2=len3(ipoq)+1 + if(imaxi.eq.ipoq+1) l = 1 + if(imaxi.gt.ipoq+1) l = len3(imaxi-1-ipoq)+1 + do 99 iq=iq1,iq2 + qval = qvec(iq) +c******************** + do 191 i = 1,3 + do 191 ip = 1,l + pdf(i,ip) = pdf(i,ip) + rdf(i,n0+ip)*qval + 191 continue +c**** previous loops replaced by: ********** +c call daxpy(3*l,qval,rdf(1,n0+1),1,pdf(1,1),1) +c******************** + n0 = n0 + l + 99 continue + 9 continue +c******************** + do 999 i = 1,3 + do 999 ip = 1,l31-l32 + pdf(i,1) = pdf(i,1) + rdf(i,n0+ip)*qvec(l32+1+ip) + 999 continue +c**** previous loops replaced by: ********** +c pdf(1,1)=pdf(1,1)+ddot(l31-l32,qvec(l32+2),1,rdf(1,n0+1),3) +c pdf(2,1)=pdf(2,1)+ddot(l31-l32,qvec(l32+2),1,rdf(2,n0+1),3) +c pdf(3,1)=pdf(3,1)+ddot(l31-l32,qvec(l32+2),1,rdf(3,n0+1),3) +c******************** +c +c genarate coefficients of reduce jacobian (rrjac): +c******************** + do 1190 i1 = 1,3 + do 1190 i2 = 1,3 + do 1190 ip = 2,len3(imaxi-2)+1 + pjac(i1,i2,ip) = rrjac(i1,i2,ip) + 1190 continue +c**** previous loops replaced by: ********** +c call dcopy(9*len3(imaxi-2),rrjac(1,1,2),1,pjac(1,1,2),1) +c******************** + n0 = len3(imaxi-2)+1 + iq2=1 + do 19 ipoq = 1,imaxi-2 + iq1 = iq2 + 1 + iq2 = len3(ipoq)+1 + if(imaxi.eq.ipoq+2) l = 1 + if(imaxi.gt.ipoq+2) l = len3(imaxi-2-ipoq)+1 + do 199 iq = iq1,iq2 + qval = qvec(iq) +c********************* + do 1999 i1 = 1,3 + do 1999 i2 = 1,3 + do 1999 ip = 1,l + pjac(i1,i2,ip) = pjac(i1,i2,ip) + rrjac(i1,i2,n0+ip)*qval + 1999 continue +c**** previous loops replaced by: ********** +c call daxpy(9*l,qval,rrjac(1,1,n0+1),1,pjac(1,1,1),1) +c******************** + n0 = n0 + l + 199 continue + 19 continue +c +c +c loop to apply contraction mapping +c + do 9999 index=1,12 +c + do 30 i=1,3 + crtrm(i)=0.d0 + pimag(i)=0.d0 + p(i)=0.d0 + delp(i)=0.d0 + cp(i)=0.d0 + do 3 j=1,3 + rlin(i,j)=0.d0 + 3 continue + 30 continue +c compute monomials in the momenta +c + pvec(1) = 1.d0 +c first order monomials are equal to the p's; + ivalue=0 + do 4 i=1,3 + ivalue=ivalue+2 + pvec(i+1)=ztmp(ivalue) + 4 continue +c +c compute the remaining monomials as products of +c previous ones: +c need only term up to order imaxi-1 + do 40 i=5,len3(imaxi-1)+1 + pvec(i)=pvec(ind31(i))*pvec(ind32(i)) + 40 continue +c +c compute jacobian +c + do 500 i=1,3 + do 50 j=1,3 +c only terms of order up to imaxi-2 are present in the jacobian, +c the jacobian is produced by taking the second derivatives of a +c imaxi order polynomial. +c******************** + do 5 n =1,len3(imaxi-2)+1 + rlin(i,j) = rlin(i,j) + pjac(i,j,n)*pvec(n) + 5 continue +c**** previous loop replaced by: ********** +c rlin(i,j)=ddot(l32+1,pvec,1,pjac(i,j,1),9) +c******************** +c +c + rmat(i,j)=ri(i,j)-rlin(i,j) + 50 continue + 500 continue + call invrs(rmat,rinv,det) + adet=dabs(det) + if(adet.lt.1.d-30)write(6,501) + 501 format(1h ,'determinant underflow in newt') + if(adet.lt.1.d-30)return + ivalue=0 + do 6 i=1,3 + ivalue=ivalue+2 + p(i)=ztmp(ivalue) + 6 continue + do 600 i=1,3 + pimag(i)=pimag(i)+pi(i) +c only term of order 2 to imaxi-1 are present +c so the sum only goes up to len(imaxi-1) . not +c******************** + do 60 n=1,l31+1 + pimag(i) = pimag(i) - pdf(i,n)*pvec(n) + 60 continue +c**** previous loop repplaced by: ********** +c pimag(i)=pimag(i)-ddot(l31+1,pvec,1,pdf(i,1),3) +c******************** +c +c + delp(i)=p(i)-pimag(i) + 600 continue + do 70 i=1,3 + do 7 j=1,3 + crtrm(i)=crtrm(i)+rinv(i,j)*delp(j) + 7 continue + 70 continue +c square=crtrm(1)**2 + crtrm(2)**2 + crtrm(3)**2 +c root=dsqrt(square) + root=abs(crtrm(1)) + abs(crtrm(2)) + abs(crtrm(3)) + if(ibrief.ne.2)goto 705 + write(jof,71)index,(crtrm(i),i=1,3) + 71 format(1h ,'corrections at iteration ',i2/ + & 1h ,'crtrm(1) = ',d21.15/1h ,'crtrm(2) = ',d21.15/ + & 1h ,'crtrm(3) = ',d21.15) +c if (1.+root.eq.1.) write(jof,72)index + if (root .le. 1.d-12) write(jof,72)index + 72 format(1h ,'iteration has converged; i= ',i1) + 705 continue + do 8 i=1,3 + cp(i)=p(i)-crtrm(i) + 8 continue + ivalue=0 + do 80 i=1,3 + ivalue=ivalue+2 + ztmp(ivalue)=cp(i) + 80 continue + do 800 i=1,6 + zo(i)=ztmp(i) + 800 continue +c if(1.+root.eq.1.) goto 1234 + if(root .le. 1.d-12) goto 1234 + 9999 continue + write(6,906) root + 906 format(' Search did not converge; root= ',e12.5) +c if (root.gt..1) jwarn=1 + jwarn=1 + 1234 continue + return + end +c +*********************************************************************** +c + subroutine prod(dg,crstrm) +c subroutine to compute crossterm in generating fxn of standard +c rep of transfer map +c Written by D. Douglas, ca 1982, and modified by Liam Healy +c + use lieaparam, only : monoms + include 'impli.inc' + dimension dg(6,*),crstrm(*),l(6) + include 'expon.inc' + include 'lims.inc' +c + do 1 m=1,top(4) + crstrm(m)=0.d0 + 1 continue + do 2000 i=1,5,2 + ivalue=i+1 + do 200 j=bottom(2),top(2) + if(dg(i,j).eq.0.d0)goto 200 + do 20 k=bottom(2),top(2) + if(dg(ivalue,k).eq.0.d0)goto 20 + do 2 m=1,6 + l(m)=expon(m,j)+expon(m,k) + 2 continue + n=ndex(l) + crstrm(n)=crstrm(n) - dg(i,j)*dg(ivalue,k)/2.d0 + 20 continue + 200 continue + 2000 continue + return + end +c +*********************************************************************** + subroutine rearr +c Written by F. Neri, ca 1984 + use lieaparam, only : monoms + include 'impli.inc' + dimension j(6) + include 'ja3.inc' + include 'ind.inc' + include 'deriv.inc' + include 'len.inc' + include 'len3.inc' + include 'ind3.inc' +c + do 22 i=1,6 + j(i)=0 + 22 continue + do 1 ip = 2,len3(imaxi-1)+1 + ivalue = 0 + do 11 i = 1,3 + ivalue = ivalue + 2 + j(ivalue) = ja3(i,ip) + 11 continue + n = ndex(j) + if(ip.gt.(len3(imaxi-2)+1)) goto 112 + do 111 i1 = 1,3 + do 111 i2 = 1,3 + rrjac(i1,i2,ip) = rjac(i1,i2,n) + 111 continue + 112 continue + ivalue = -1 + do 10 i = 1,3 + ivalue = ivalue + 2 + rdf(i,ip) = df(ivalue,n) + 10 continue + 1 continue + n1 = len3(imaxi-1)+1 + n2 = len3(imaxi-2)+1 + iq2 = 1 + do 3 ipoq = 1,imaxi-1 + iq1 = iq2+1 + iq2 = len3(ipoq)+1 + if(imaxi-2.gt.ipoq) then + l2 = len3(imaxi-2-ipoq)+1 + l1 = len3(imaxi-1-ipoq)+1 + else if(imaxi-2.eq.ipoq) then + l2 = 1 + l1 = len3(imaxi-1-ipoq)+1 + else + l1 = 1 + end if + do 33 iq = iq1,iq2 + if(imaxi-2.ge.ipoq) then + do 333 ip = 1,l2 + ivalue = -1 + do 3333 i=1,3 + ivalue = ivalue + 2 + j(ivalue) = ja3(i,iq) + j(ivalue+1) = ja3(i,ip) + 3333 continue + n = ndex(j) + do 4 i1=1,3 + do 4 i2 = 1,3 + rrjac(i1,i2,n2+ip) = rjac(i1,i2,n) + 4 continue + 333 continue + n2 = n2 + l2 + endif + do 334 ip = 1,l1 + ivalue = -1 + do 3334 i = 1,3 + ivalue = ivalue + 2 + j(ivalue) = ja3(i,iq) + j(ivalue+1) = ja3(i,ip) + 3334 continue + n = ndex(j) + ivalue = -1 + do 44 i = 1,3 + ivalue = ivalue+2 + rdf(i,n1+ip) = df(ivalue,n) + 44 continue + 334 continue + n1 = n1 + l1 + 33 continue + 3 continue + return + end +c +*********************************************************************** +c + subroutine trace(icfile,nunit,ntaysym,norder,ntrace,nwrite, & + & jdmin,jdmax,nprecision,nraysinp,th,tmh) +c Written by D. Douglas, ca 1982, and modified since by +c nearly everyone at Maryland. Could still stand improvement. +c + use rays + use beamdata + use lieaparam, only : monoms + use multitrack + use ml_timer + include 'impli.inc' + include 'deriv.inc' + include 'files.inc' + include 'talk.inc' + dimension th(monoms),tmh(6,6) + character*16 ubuf +cryne 12/30/2004 moved idmin/idmax statements below past raysin +cryne because calling raysin can potentially change maxray +! data iifile/50/ +! save iifile +c +! write(6,*)'(trace) hello from PE ',idproc +! if(idproc.eq.0)then +! write(6,*)'in routine trace; icfile,nunit,norder,ntrace,nwrite=' +! write(6,*)icfile,nunit,norder,ntrace,nwrite +! endif +c +c read initial conditions, if requested: + if(icfile.gt.0)then + scaleleni=0.d0 + scalefrqi=0.d0 + scalemomi=0.d0 + call increment_timer('raysin',0) + call raysin(icfile,nraysinp,scaleleni,scalefrqi,scalemomi, & + & ubuf,jerror) + call increment_timer('raysin',1) + call rbcast(scaleleni) + call rbcast(scalefrqi) + call rbcast(scalemomi) +c if all the scaling constants are zero, then they are not in the prologue, +c so the sectio of code below on units conversion should be skipped: + if(scaleleni.eq.0.d0.and.scalefrqi.eq.0.d0.and.scalemomi.eq.0.d0& + & )goto 555 +c +c if one of the scaling constants are zero, but not all of them, +c then there is some sort of problem, so exit: + scaleprod=scaleleni*scalefrqi*scalemomi + if(scaleprod.eq.0)then + if(idproc.eq.0)then + write(6,*)'problem reading scaling constants in input file' + write(6,*)'is one of them zero???' + endif + call myexit + endif +c here is where the units conversion takes place: + iconvert=1 + if(iconvert.eq.1)then + slratio=scaleleni/sl + smomratio=scalemomi/p0sc + timratio=freqscl/scalefrqi + wldratio=(scalefrqi*scaleleni*scalemomi)/(freqscl*sl*p0sc) + if(idproc.eq.0)then + write(6,*)'raysin complete; scaling input data' +c write(6,*)'scaleleni,sl=',scaleleni,sl +c write(6,*)'scalemomi,p0sc=',scalemomi,p0sc +c write(6,*)'scalefrqi,freqscl=',scalefrqi,freqscl +c write(6,*)'twopi*freqscl,omegascl=',4.d0*asin(1.d0)*freqscl, & +c & omegascl +c write(6,*)'wld_i,wld=',(scalefrqi*scaleleni*scalemomi), & +c & (freqscl*sl*p0sc) +c write(6,*)' ' +c write(6,*)' ' + write(6,*)'scale length ratio=',slratio + write(6,*)'scale momentum ratio=',smomratio + write(6,*)'scale time ratio=',timratio + write(6,*)'scale energy ratio=',wldratio + endif + do n=1,nraysp + zblock(1,n)=zblock(1,n)*slratio + zblock(2,n)=zblock(2,n)*smomratio + zblock(3,n)=zblock(3,n)*slratio + zblock(4,n)=zblock(4,n)*smomratio + zblock(5,n)=zblock(5,n)*timratio + zblock(6,n)=zblock(6,n)*wldratio + enddo + endif + 555 continue + endif +c +!---new code to print particles in range jdmin to jdmax: + idmin=jdmin + idmax=jdmax + if(idmin.eq.0)idmin=1 + if(idmax.eq.0)idmax=maxray +!--- +c +c examine various cases for norder +c norder=-1 + if(norder.eq.-1.and.icfile.gt.0) return + if(norder.eq.-1.and.icfile.eq.0) then + write(6,*) 'icfile and norder have inconsistent values' + write(12,*) 'icfile and norder have inconsistent values' + call myexit + endif +c +c norder=0 +c write final conditions in full precision +! if(norder.eq.0.and.jfcf.lt.0)then + if(norder.eq.0.and.nunit.lt.0)then + write(6,*)'FULL PRECISION WRITE ON FILE ',jfcf + call pwritezfp + endif +cryne if(norder.eq.0.and.jfcf.lt.0)then +cryne do 120 i=1,nraysp +cryne do 110 j=1,6 +cryne write(-jfcf,2468)zblock(j,i) + 2468 format(1x,d32.25,1x,d32.25) +cryne 110 continue +cryne 120 continue +cryne write(jof,130) -jfcf +cryne 130 format(1x,'final conditions written in full precision on', +cryne # ' file ',i4) +cryne endif +c +c write final conditions in standard format +! if(norder.eq.0.and.jfcf.gt.0)call pwritez(nunit,idmin,idmax, & + if(norder.eq.0.and.nunit.gt.0)call pwritez(nunit,idmin,idmax, & + & nprecision,0,0) +cryne if(norder.eq.0.and.jfcf.gt.0)then +cryne do 135,i=1,nraysp +cryne write(jfcf,136)(zblock(j,i),j=1,6) +cryne 136 format(6(1x,1pe12.5)) +cryne 135 continue +cryne endif + if(norder.eq.0)return +c +c cases where norder > 0 +c +c call preliminary routines depending on type of ray trace: +cryne May 10, 2006 added "if" test on norder =============== + if(norder.gt.1)then + if(ntaysym.eq.1)then + if(multitrac.eq.0)then + call brkts(th) + else + call multibrkts + endif + else +cryne 12/31/2004 added norder to canx argument list. +cryne This is a temporary fix to allow symplectic tracking of order < 5. +cryne It would be better if do loops did not extend to 923 in evalsr. + if(multitrac.eq.0)then + call canx(tmh,th,norder) + call rearr + else + call multicanx + endif + endif + endif +c +c setup before entering main loop: + ktrace=ntrace + if(ktrace.eq.0)ktrace=1 +c +c the 2 statements below seem to cause a problem and have been commented out: +c kwrite=nwrite +c if(kwrite.eq.0)kwrite=1 +c +cryne May 22, 2006 it is very bad and confusing that the names th and tmh +cryne used in the argument list to this routine, since they might/might not be +cryne the total transfer map coefficients stored in common under these names!!! + call increment_timer('eval',0) + if(ntaysym.eq.1)then + call eval(tmh,norder,ntrace,nwrite,nunit,idmin,idmax,nprecision) + call increment_timer('eval',1) + return + else + jwarn=0 + call evalsr(tmh,df,rdf,rrjac,norder,ntrace,nwrite,nunit, & + & idmin,idmax,nprecision) + call increment_timer('eval',1) + return + endif +cryne 8/3/2002 original code still in place for symplectic ray trace: +c main loop; do 'ktrace' ray traces (of the 'nraysp' initial rays) + if(idproc.eq.0)write(6,*)'ERROR: CODE SHOULD NOT GET HERE!!!' + do 300 idum=1,ktrace + do 200 k=1,nraysp +ccc if (nlost.ge.nrays) then +ccc write (jof,*) 'all particles lost' +ccc return +ccc endif +c check to see if particle has already been lost + if (istat(k).ne.0) goto 200 +c + do 150 l=1,6 + 150 zi(l)=zblock(l,k) +c +cryne 8/3/2002 if(norder.le.4)then +cryne 8/3/2002 call eval(tmh,norder,zi,zf) +cryne 8/3/2002 endif + if(norder.gt.4)then +c perform a symplectic ray trace + jwarn=0 + call evalsr_old(tmh,zi,zf,df,rdf,rrjac) +cryne 8/13/02 call evalsr(tmh,zi,zf) +c if(jfcf.lt.0)write(6,*)'back from evalsr, jfcf=',jfcf +c write(6,*)'returned from evalsr for ray #',k +c check to see if particle was 'lost' by the symplectic ray tracer +c and mark so 'lost' particles by a a distinctive negative number + if (jwarn.ne.0) then +c write(6,*)'setting istat,nlost' + istat(k)=-idum + nlost=nlost+1 + ihist(1,nlost)=-idum + ihist(2,nlost)=k +c write(6,*)'done setting istat,nlost' + endif + endif +c the line below has been replaced by the following two lines +c if(mod(idum,kwrite).ne.0)goto 176 + if(nwrite.eq.0)goto 176 + if(mod(idum,nwrite).ne.0)goto 176 +c if(jfcf.lt.0)write(6,*)'did not goto 176;jfcf=',jfcf +c end of modifications +c write out final conditions +c full precision case + if(jfcf.lt.0) then + write(6,*)'writing in full prec, idum=',idum +cryne June 4 2002 do 152 l=1,6 +cryne June 4 2002 write(-jfcf,*) zf(l) +cryne June 4 2002 152 continue + do 152 l=1,6,2 + write(-jfcf,2468)zf(l),zf(l+1) + 152 continue + write(6,*)'donewriting in full prec, idum=',idum + endif +c standard format case + if(jfcf.gt.0)then + tblock(:,k)=zf(:) + endif + if(ibrief.eq.0)goto 176 +c print lengthy info: + write(jof,155) + 155 format(/1h ,'initial conditions are: (dimensionless form)') + write(jof,*)zi(1),zi(2) + write(jof,*)zi(3),zi(4) + write(jof,*)zi(5),zi(6) + write(jof,160) + 160 format(/1h ,'final conditions are: (dimensionless form)') + write(jof,*)zf(1),zf(2) + write(jof,*)zf(3),zf(4) + write(jof,*)zf(5),zf(6) +c (end of lengthy info) +c + 176 continue + if(ntrace.eq.0)goto 200 + zblock(:,k)=zf(:) +c + 200 continue + if(nwrite.ne.0)then + if(mod(idum,nwrite).eq.0 .and. jfcf.gt.0)then + call pwritet(nunit,idmin,idmax,nprecision) + endif + endif + 300 continue + call increment_timer('eval',1) + return + end +c--------------------------------------- + subroutine pwritez(nunit,idmin,idmax,nprecision,nphysunits, & + & iprintarc) +c routine to perform parallel write of zblock array + use rays + use beamdata + use lieaparam, only : monoms !cryne 9/23/07 + include 'impli.inc' + include 'map.inc' !cryne 9/23/07 need to know arclen + integer l,nraysw + include 'files.inc' + character*16 :: myformat='(7(1x,1pe12.5 ))' + character*2 :: a2 + if(idproc.eq.0)then +!---format: + nlength=nprecision+7 + call num2string(nlength,a2,2) + myformat(10:11)=a2 + call num2string(nprecision,a2,2) + myformat(13:14)=a2 +!--- + mycount=0 + do i=1,nraysp + mycount=mycount+1 + if(mycount.lt.idmin)cycle + if(mycount.gt.idmax)exit + if(nphysunits.eq.0)then + if(iprintarc.eq.0)write(nunit,myformat)zblock(:,i) + if(iprintarc.eq.1)write(nunit,myformat)arclen,zblock(:,i) + else + if(iprintarc.eq.0) & + & write(nunit,myformat)zblock(1,i)*sl,zblock(2,i)*p0sc, & + & zblock(3,i)*sl,zblock(4,i)*p0sc,zblock(5,i)/omegascl, & + & zblock(6,i)*(omegascl*sl*p0sc) + if(iprintarc.eq.1) & + & write(nunit,myformat)arclen,zblock(1,i)*sl,zblock(2,i)*p0sc, & + & zblock(3,i)*sl,zblock(4,i)*p0sc,zblock(5,i)/omegascl, & + & zblock(6,i)*(omegascl*sl*p0sc) + endif + enddo + do l=1,nvp-1 + call MPI_RECV(tblock,6*maxrayp,mreal,l,98,lworld,mpistat,ierr) + call MPI_GET_COUNT(mpistat,mreal,nraysw,ierr) + nraysw=nraysw/6 + do i=1,nraysw + mycount=mycount+1 + if(mycount.lt.idmin)cycle + if(mycount.gt.idmax)exit + if(nphysunits.eq.0)then + if(iprintarc.eq.0)write(nunit,myformat)tblock(1:6,i) + if(iprintarc.eq.1)write(nunit,myformat)arclen,tblock(1:6,i) + else + if(iprintarc.eq.0) & + & write(nunit,myformat)tblock(1,i)*sl,tblock(2,i)*p0sc, & + & tblock(3,i)*sl,tblock(4,i)*p0sc,tblock(5,i)/omegascl, & + & tblock(6,i)*(omegascl*sl*p0sc) + if(iprintarc.eq.1) & + & write(nunit,myformat)arclen,tblock(1,i)*sl,tblock(2,i)*p0sc, & + & tblock(3,i)*sl,tblock(4,i)*p0sc,tblock(5,i)/omegascl, & + & tblock(6,i)*(omegascl*sl*p0sc) + endif + 100 format(6(1x,1pe12.5)) + enddo + enddo + else + call MPI_SEND(zblock,6*nraysp,mreal,0,98,lworld,ierr) + endif + return + end +c--------------------------------------- + subroutine pwritet(nunit,idmin,idmax,nprecision) +c routine to perform parallel write of tblock array + use rays +! implicit none + include 'impli.inc' + integer l,nraysw + include 'files.inc' + character*16 :: myformat='(6(1x,1pe12.5 ))' + character*2 :: a2 + if(idproc.eq.0)then +!---format: + nlength=nprecision+7 + call num2string(nlength,a2,2) + myformat(10:11)=a2 + call num2string(nprecision,a2,2) + myformat(13:14)=a2 +! write(6,*)'nlength,nprecision=',nlength,nprecision +! write(6,*)'myformat=',myformat +!--- + mycount=0 + do i=1,nraysp + mycount=mycount+1 + if(mycount.lt.idmin)cycle + if(mycount.gt.idmax)exit +! write(nunit,100)tblock(:,i) + write(nunit,myformat)tblock(:,i) + enddo + do l=1,nvp-1 + call MPI_RECV(tblock,6*maxrayp,mreal,l,98,lworld,mpistat,ierr) + call MPI_GET_COUNT(mpistat,mreal,nraysw,ierr) + nraysw=nraysw/6 +! write(6,*)'(pwrite) PE 0 received ',nraysw,' rays from PE ',l + do i=1,nraysw + mycount=mycount+1 + if(mycount.lt.idmin)cycle + if(mycount.gt.idmax)exit +! write(nunit,100)tblock(1:6,i) + write(nunit,myformat)tblock(1:6,i) + 100 format(6(1x,1pe12.5)) + enddo + enddo + else + call MPI_SEND(tblock,6*nraysp,mreal,0,98,lworld,ierr) + endif + return + end +c--------------------------------------- + subroutine pwritezfp +c routine to perform parallel write of zblock array in FULL PRECISION + use rays +! implicit none + include 'impli.inc' + integer l,nraysw + include 'files.inc' + if(idproc.eq.0)then + do i=1,nraysp + write(jfcf,*)zblock(1,i),zblock(2,i) + write(jfcf,*)zblock(3,i),zblock(4,i) + write(jfcf,*)zblock(5,i),zblock(6,i) + enddo + do l=1,nvp-1 + call MPI_RECV(tblock,6*maxrayp,mreal,l,98,lworld,mpistat,ierr) + call MPI_GET_COUNT(mpistat,mreal,nraysw,ierr) + nraysw=nraysw/6 +! write(6,*)'(pwrite) PE 0 received ',nraysw,' rays from PE ',l + do i=1,nraysw + write(jfcf,*)tblock(1,i),tblock(2,i) + write(jfcf,*)tblock(3,i),tblock(4,i) + write(jfcf,*)tblock(5,i),tblock(6,i) + enddo + enddo + else + call MPI_SEND(zblock,6*nraysp,mreal,0,98,lworld,ierr) + endif + return + end +c end of file +c--------------------------------------- + subroutine pwritetfp +c routine to perform parallel write of tblock array + use rays +! implicit none + include 'impli.inc' + integer l,nraysw + include 'files.inc' + if(idproc.eq.0)then + do i=1,nraysp + write(jfcf,*)tblock(1,i),tblock(2,i) + write(jfcf,*)tblock(3,i),tblock(4,i) + write(jfcf,*)tblock(5,i),tblock(6,i) + enddo + do l=1,nvp-1 + call MPI_RECV(tblock,6*maxrayp,mreal,l,98,lworld,mpistat,ierr) + call MPI_GET_COUNT(mpistat,mreal,nraysw,ierr) + nraysw=nraysw/6 +! write(6,*)'(pwrite) PE 0 received ',nraysw,' rays from PE ',l + do i=1,nraysw + write(jfcf,*)tblock(1,i),tblock(2,i) + write(jfcf,*)tblock(3,i),tblock(4,i) + write(jfcf,*)tblock(5,i),tblock(6,i) + enddo + enddo + else + call MPI_SEND(tblock,6*nraysp,mreal,0,98,lworld,ierr) + endif + return + end +c--------------------------------------- +c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/user.f b/OpticsJan2020/MLI_light_optics/Src/user.f new file mode 100755 index 0000000..4fb6fb2 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/user.f @@ -0,0 +1,1667 @@ +c************ USER routines ********** + subroutine user1(p) +c Modified to plot beam envelopes 18 Dec 90 +c Overhauled some more to take various input beams +c CTM Oct 91 +c +c Ray tracing added Mar 96 FRN (&CTM) +c FOV calculation added Dec 97 (CTM) +c both moved to other USER routines May 01 +c +c This routine applies the current map in (fa,fm) to the initial sigma +c matrix given in the parameter set p = (s11,s12,s22,s33,s34,s44), to +c produce the output sigma matrix of the same form, which is saved in +c +c control parameters +c p(1) = job = -N, 0, +N : -N (N<0) means silent running in +c a fit or scan loop, with no output files. +c job = 0 (default) is to fill in /linbuf/ +c N = 1 means also slice the elements and fill in the +c sincos buffer for future use in FOV and RAY. +c N = 2 means to compute the envelope from the initial +c moments read in by USER8. The resulting envelope +c excursions are stored in UCALC(33 - 36). +c N = 3 means to also generate the table of envelope +c excursions in each element. ISEND controls where +c (and if) it is written. +c p(2) = menv = 0 for no output files. (used in fit loops, etc.) +c = 1 to write the sincos buffer to the .MSC file (lun=34) +c = 2 to write the beam envelope to the .ENV file (lun=24) +c = 3 to write both. +c p(3) = mincut = minimum no. of slices/element +c p(4) = step: nominal thickness of one slice. nslice=L/step +c p(5) = isend as usual: controls jof and jodf output. +c p(6) = jtran = 0 for no translation files. +c = 1 to write ADLIB dump on unit 22 +c = 2 to write TRACE3D format to .TRC file on unit 36 +c = 3 to write old TRANSPORT format to .TRN on unit 38 +c = 4 to write MAD format to .MAD file on unit 40 +c +c beam parameters: xx(nn) = xmax = sqrt(betax*xemit) +c ax(nn) = alphax +c px(nn) = thetax = sqrt(gammax*xemit) +c yy(nn) = ymax = sqrt(betay*yemit) +c ay(nn) = alphay +c py(nn) = thetay = sqrt(gammay*yemit) +c Tom Mottershead LANL 31-Mar-89 +c revised Dec 97 +c--------------------------------------------------------------------- + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'linbuf.inc' + include 'sigbuf.inc' + include 'usrdat.inc' + include 'parset.inc' + include 'sincos.inc' + dimension xc(2),pxc(2),xs(2),pxs(2),yc(2),pyc(2),ys(2),pys(2) + dimension p(6), fm(6,6) + logical lterm, lfile, lenv, jenv, msc, nosig + write(6,*)'WARNING (user1): sincos.inc has different declaration' + write(6,*)'for common/csrays/ than routines in usubs.f' + write(6,*)'Rob Ryne 7/23/2002' +c +c decode input parameters +c + job = nint(p(1)) + menv = nint(p(2)) + mincut = nint(p(3)) + step = p(4) + isend = nint(p(5)) + jtran = nint(p(6)) +c +c backward compatibility resets for no output if job < 0 +c + msc = .false. + lenv = .false. + jenv = .false. + nosig = .true. + if(job.lt.0) then + iquiet=1 + job = -job + endif + if(job.gt.1) nosig = .false. + if(job.eq.3) jenv = .true. + if((menv.eq.1).or.(menv.eq.3)) msc = .true. + if(menv.eq.2) lenv = .true. + lterm = .false. + lfile = .false. + if((isend.eq.1).or.(isend.eq.3)) lterm = .true. + if(isend.gt.1) lfile = .true. +c +c temp setup of dump files +c + ltrace = 1 + ltran = 0 + if(jtran.eq.1) ltran = 22 + if(jtran.eq.2) ltran = 36 + zero = 0.0d0 + one = 1.0d0 + two = 2.0d0 +c +c fillin linbuf from the loop arrays +c + npsu = 9 + call filin +c +c count the beamline +c + ndrft = 0 + nquad = 0 + do 10 nn = nbgn,nend + if(lintyp(nn).eq.0) then + ndrft = ndrft+1 + else + nquad = nquad+1 + endif + 10 continue + if(lterm) write(jof,13) ndrft,nquad + if(lfile) write(jodf,13) ndrft,nquad + 13 format(' Line has',i4,' drifts and',i4,' quads') + if(job.eq.0) return + nep = 1 + ndrft +3*nquad +c type *, ' ACTPAR on FILIN exit:' +c type *, aapar,bbpar,ccpar,ddpar,eepar,ffpar + if(lterm) write(jof,*) ' Beam Line Summary' + if(lfile) write(jodf,*) ' Beam Line Summary' + total = zero + gltot = zero + zbeg = zero +c +c write beamline list and element blocks to .ENV file +c + ap = 0.0 + nn = 0 + if(lterm) write(jof,16) + if(lfile) write(jodf,16) + 16 format(3x,'n',2x,'name',4x,' codes',2x,'aper(cm) length(cm)',4x, + & 'Gradient',5x,'PoleTip(g)',3x,'path(cm)') + do 20 nn = nbgn, nend + ltyp = lintyp(nn) + zbeg = total + total = total + elong(nn) + cmtot = 100.0*total + cml = 100.0*elong(nn) + glp = elong(nn)*strong(nn) + gltot = gltot + abs(glp) + rcm = 100.0*radius(nn) + qupole = 1.e4*strong(nn)*radius(nn) + sxpole = 1.e4*pssext(nn)*radius(nn)**2 + ocpole = 1.e4*psoctu(nn)*radius(nn)**3 + if(lterm) then + write(jof,17) nn, cname(nn), mltyp1(nn), mltyp2(nn), + & lintyp(nn), rcm, cml, strong(nn), qupole, cmtot + if(pssext(nn).ne.0.0) write(jof,18) 'sext',pssext(nn),sxpole + if(psoctu(nn).ne.0.0) write(jof,18) 'oct ',psoctu(nn),ocpole + endif + if(lfile) then + write(jodf,17) nn, cname(nn), mltyp1(nn), mltyp2(nn), + & lintyp(nn), rcm, cml, strong(nn), qupole, cmtot + if(pssext(nn).ne.0.0) write(jodf,18) 'sext',pssext(nn),sxpole + if(psoctu(nn).ne.0.0) write(jodf,18) 'oct ',psoctu(nn),ocpole + endif + 17 format(i4,2x,a,3i2,f8.2,f10.3,f15.7,f15.5,f10.3) + 18 format(16x,a4,18x,f15.7,f15.5) + 20 continue + ucalc(39) = total + ucalc(40) = gltot +cryne 08/24/2001 write(6,*),' *** Step =',step,mincut,'=mincut' + write(6,*)' *** Step =',step,mincut,'=mincut' + nask = total/step + if(lterm) write(jof,23) total,nask,step,gltot + if(lfile) write(jodf,23) total,nask,step,gltot + 23 format(' total length = ',f15.5,' in',i5,' steps of',f9.4, + & f12.6,'= Sum|GL|') +c +c write blocks on top of .ENV file +c + lun = 24 + if(lenv) call blocks(nep,lun) +c +c initialize sin/cos variables +c + jp = 1 + ni = 1 + zu = zero + xc(ni) = one + pxc(ni) = zero + xs(ni) = zero + pxs(ni) = one + yc(ni) = one + pyc(ni) = zero + ys(ni) = zero + pys(ni) = one +c +c initialize sin,cosine file +c + lun = 34 + if(msc) call blocks(nep,lun) + rcm = 100.0*radius(1) + if(msc) write(lun,147) zero,rcm,one,zero,one,zero +c +c initialize element loop +c + ni = 0 + nf = 0 + kka = 0 + kkb = 1 + xmax = 0.0 + ymax = 0.0 + xmin = 1.0e38 + ymin = 1.0e38 + if(jenv) then + if(lterm) write(jof,88) + if(lfile) write(jodf,88) + endif + 88 format(' element cuts',4x,'zxmax',6x,'xmax',6x,'xmin',5x, + &'zymax',6x,'ymax',6x,'ymin') +c +c initialize envelope points +c + xx(1) = xxin + ax(1) = axin + px(1) = pxin + yy(1) = yyin + ay(1) = ayin + py(1) = pyin + if(lenv) write(24,27) zu,xx(1),px(1),yy(1),py(1),ax(1),ay(1) + 27 format(f10.4,4(1pe11.4),2(1pe12.4)) +c +c big loop over all elements +c + do 200 nn = nbgn, nend +c +c setup transfer matrix for one slice +c + nslice = elong(nn)/step + if(nslice.lt.mincut) nslice = mincut + delta = elong(nn)/float(nslice) + grad = strong(nn) + rcm = 100.0*radius(nn) + call rmquad(delta,grad,fm) +c------------------- x plane ------------ + cfx = fm(1,1) + sfx = fm(1,2) + cpx = fm(2,1) + spx = fm(2,2) + txx = cfx**2 + tax = 2.0*cfx*sfx + tpx = sfx**2 + txa = cfx*cpx + taa = cfx*spx+sfx*cpx + tpa = sfx*spx + txp = cpx**2 + tap = 2.0*cpx*spx + tpp = spx**2 +c------------------- y plane ------------ + cfy = fm(3,3) + sfy = fm(3,4) + cpy = fm(4,3) + spy = fm(4,4) + ryy = cfy**2 + ray = 2.0*cfy*sfy + rpy = sfy**2 + rya = cfy*cpy + raa = cfy*spy+sfy*cpy + rpa = sfy*spy + ryp = cpy**2 + rap = 2.0*cpy*spy + rpp = spy**2 +c +c propagate through all the slices +c + exmax = 0.0 + eymax = 0.0 + exmin = 1.0e30 + eymin = 1.0e30 + zbgn = zu + do 100 kk = 1, nslice + ni = kka + 1 + nf = kkb + 1 + kka = 1- kka + kkb = 1- kkb + zu = zu + delta +c +c collect Sinelike and Cosinelike rays for FOV calculation +c + xc(nf) = cfx*xc(ni)+sfx*pxc(ni) + pxc(nf) = cpx*xc(ni)+spx*pxc(ni) + xs(nf) = cfx*xs(ni)+sfx*pxs(ni) + pxs(nf) = cpx*xs(ni)+spx*pxs(ni) + yc(nf) = cfy*yc(ni)+sfy*pyc(ni) + pyc(nf) = cpy*yc(ni)+spy*pyc(ni) + ys(nf) = cfy*ys(ni)+sfy*pys(ni) + pys(nf) = cpy*ys(ni)+spy*pys(ni) + cx(jp) = xc(nf) + sx(jp) = xs(nf) + cy(jp) = yc(nf) + sy(jp) = ys(nf) + za(jp) = zu + if(msc) write(lun,147) za(jp),rcm,cx(jp),sx(jp),cy(jp),sy(jp) + 147 format(6f13.7) + jp = jp+1 + if(nosig) go to 100 +c +c compute x-plane final beam ellipse +c + xss = xx(ni)**2 + xa = -xx(ni)*ax(ni)*px(ni)/sqrt(1.0d0 + ax(ni)**2) + xps = px(ni)**2 +c sigf1 = (cfx**2)*xss + 2.0*cfx*sfx*xa + (sfx**2)*xps +c sigf2 = cfx*cpx*xss + (cfx*spx+sfx*cpx)*xa + sfx*spx*xps +c sigf3 = (cpx**2)*xss + 2.0*cpx*spx*xa + (spx**2)*xps + sigf1 = txx*xss + tax*xa + tpx*xps + sigf2 = txa*xss + taa*xa + tpa*xps + sigf3 = txp*xss + tap*xa + tpp*xps + exsq = sigf1*sigf3 - sigf2**2 + if(exsq.le.0.0) exsq = 1.e-30 + ex = sqrt(exsq) + xx(nf) = sqrt(sigf1) + if(xx(nf).gt.xmax) then + xmax = xx(nf) + zxmax = zu + endif + if(xx(nf).gt.exmax) then + exmax = xx(nf) + zxm = zu + endif + if(xx(nf).lt.exmin) exmin = xx(nf) + px(nf) = sqrt(sigf3) + ax(nf) = -sigf2/ex +c +c compute y-plane beam ellipse +c + yss = yy(ni)**2 + ya = -yy(ni)*ay(ni)*py(ni)/sqrt(1.0d0 + ay(ni)**2) + yps = py(ni)**2 +c sigf4 = (cfy**2)*yss + 2.0*cfy*sfy*ya + (sfy**2)*yps +c sigf5 = cfy*cpy*yss + (cfy*spy+sfy*cpy)*ya + sfy*spy*yps +c sigf6 = (cpy**2)*yss + 2.0*cpy*spy*ya + (spy**2)*yps + sigf4 = ryy*yss + ray*ya + rpy*yps + sigf5 = rya*yss + raa*ya + rpa*yps + sigf6 = ryp*yss + rap*ya + rpp*yps + eysq = sigf4*sigf6 - sigf5**2 + if(eysq.le.0.0) eysq = 1.e-30 + ey = sqrt(eysq) + yy(nf) = sqrt(sigf4) + if(yy(nf).gt.ymax) then + ymax = yy(nf) + zymax = zu + endif + if(yy(nf).gt.eymax) then + eymax = yy(nf) + zym = zu + endif + if(yy(nf).lt.eymin) eymin = yy(nf) + py(nf) = sqrt(sigf6) + ay(nf) = -sigf5/ey + if(lenv) write(24,27) zu,xx(nf),px(nf),yy(nf),py(nf),ax(nf) + & ,ay(nf) + 100 continue + if(nosig) go to 200 + exmax = 100.0*exmax + eymax = 100.0*eymax + exmin = 100.0*exmin + eymin = 100.0*eymin + dzz = 100.0*delta + zxm = 100.0*(zxm-zbgn) + zym = 100.0*(zym-zbgn) + if(jenv) then + if(lterm) write(jof,117) cname(nn), nslice, zxm, exmax, exmin, + & zym, eymax, eymin + if(lfile) write(jodf,117) cname(nn), nslice, zxm, exmax, exmin, + & zym, eymax, eymin + endif + 117 format(2x,a,i4,6f10.3) + 200 continue + if(nosig) go to 400 + if(jenv) then +cryne 08/24/2001 if(lterm) write(jof,203), nf, xmax, zxmax, ymax, zymax +cryne 08/24/2001 if(lfile) write(jodf,203), nf, xmax, zxmax, ymax, zymax + if(lterm) write(jof,203) nf, xmax, zxmax, ymax, zymax + if(lfile) write(jodf,203) nf, xmax, zxmax, ymax, zymax + endif + 203 format(i6,' points generated. xmax =',f10.6,' at z =',f10.6,/ + & 26x,'ymax =',f10.6,' at z =',f10.6) +c +c save envelope excursions and elliptic parameters in ucalc +c + big = xmax + if(ymax.gt.big) big = ymax + ucalc(33) = xmax + ucalc(34) = ymax + ucalc(35) = xmax - ymax + ucalc(36) = big + ucalc(46) = sqrt(ymax/xmax) + ucalc(47) = sqrt(xmax*ymax) + ucalc(48) = ucalc(40)*(ucalc(47)**3) + 400 continue +c +c optional beamline translation files +c + 600 if(jtran.eq.1) call adump(ltran) + if(jtran.eq.2) call trcdmp(ltran,ltrace) + if(jtran.eq.3) call trnspt(ltran) + if(jtran.eq.4) call madump(ltran) + 777 return + end +c--------------------------------------- + subroutine user2(p) +c +c CTM 16 Apr 2001: +c New USER 2 routine generates a Taylor map from the current map in +c common/map/th(monoms),tmh(6,6) in map.inc. The Taylor map generation +c is adapted from sunroutine pcmap that writes a taylor map in +c the cartesian basis. +c + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'map.inc' + include 'expon.inc' + include 'taylor.inc' + include 'parset.inc' + dimension p(6), iuse(6), zz(6), zvec(monoms) + character*1 tu, tag(2) + logical lterm, lfile +c +c LUT for rearranging Giorgelli indexing by aberration class +c + dimension lut(209),kblok(35) + data lut /1,3,7,9,18,28,30,39,64,84,86,95,120, + & 175,2,4,8,10,14,19,29,31,35,40,54,65,85,87,91, + & 96,110,121,155,176,13,15,22,34,36,43,50,55,68,90,92, + & 99,106,111,124,145,156,179,49,51,58,74,105,107,114,130,141, + & 146,159,185,140,142,149,165,195,6,12,21,33,42,67,89,98, + & 123,178,17,24,38,45,57,70,94,101,113,126,158,181,53,60, + & 76,109,116,132,148,161,187,144,151,167,197,27,48,73,104,129, + & 184,63,79,119,135,164,190,154,170,200,83,139,194,174,204,209, + & 5,11,20,32,41,66,88,97,122,177,16,23,37,44,56,69, + & 93,100,112,125,157,180,52,59,75,108,115,131,147,160,186,143, + & 150,166,196,26,47,72,103,128,183,62,78,118,134,163,189,153, + & 169,199,82,138,193,173,203,208,25,46,71,102,127,182,61,77, + & 117,133,162,188,152,168,198,81,137,192,172,202,207,80,136,191, + & 171,201,206,205/ +c + data kblok /14,20,18,12,5,10,12,9,4,6,6,3,3, + & 2,1,10,12,9,4,6,6,3,3,2,1,6,6,3,3,2,1,3,2,1,1/ + save lut,kblok !cryne 7/23/2002 +c +c User routine for computine and printing Taylor map coefficients +c +c P(1) = iopt = 0 for compute only +c = 1 to also print +c P(2) = ipq = 0 for no T,U components +c = 1 to print Q components (x,y) only +c = 2 to print P components (Px,Py) only +c = 3 to print both Q and P components +c = 4 to print all components, including TOF +c P(3) = lun = file to write machine readback format (0 if none) +c P(4) = isend for formatted writes (0=none, 1=jof, 2=jodf, 3=both) +c P(5) = iref = pset number containing reference point to weight by +c (0=none) +c P(6) = print threshhold for weighted coefficient (at ref pt) +c + write(6,*)'inside routine user2' + iopt = nint(p(1)) + ipq = nint(p(2)) + lun = nint(p(3)) + isend= nint(p(4)) + iref = nint(p(5)) + fmin = p(6) + zero = 0.0d0 + lterm = .false. + lfile = .false. + if((isend.eq.1).or.(isend.eq.3)) lterm = .true. + if((isend.eq.2).or.(isend.eq.3)) lfile = .true. + zero = 0.0d0 +c +c set components list and reference point +c + imax = 6 + do 10 j = 1,6 + iuse(j) = j + zz(j) = pst(j,iref) + 10 continue + if(ipq.eq.3) imax = 4 + if(ipq.eq.1) then + imax = 2 + iuse(2) = 3 + endif + if(ipq.eq.2) then + imax = 2 + iuse(1) = 2 + iuse(2) = 4 + endif +c +c fill z monomial vector +c + write(6,*)'calling routine zmono' + call zmono(iopt,zz,zvec) + write(6,*)'returned from zmono' +c +c reordered dump of Lie polynomials +c + if(lterm) write(jof,19) zz + if(lfile) write(jodf,19) zz + 19 format(/,' Ref Z:',6(1pe11.2)) + if(lterm) write(jof,22) + if(lfile) write(jodf,22) + 22 format(/1h ,'nonzero elements in generating polynomial are :'/) + kmax = 35 + jmin = 1 + jmax = 0 + do 60 k = 1, kmax + jmax = jmax + kblok(k) + nfuse = 0 + do 50 j = jmin, jmax + n = lut(j) +c +c test to see if th(n) is large enough to write +c + if( abs(th(n)) .le. zero) go to 50 + frp = th(n)*zvec(n) + if(lterm) write(jof,27)n,(expon(m,n),m=1,6),th(n),th(n),frp + if(lfile) write(jodf,27)n,(expon(m,n),m=1,6),th(n),th(n),frp + 27 format(2x,'f(',i3,')=f( ',3(2i1,1x),')=',f21.6,2(1pe12.2)) + nfuse = nfuse + 1 + 50 continue + if(nfuse.gt.0) then + if(lterm) write(jof,*) ' ' + if(lfile) write(jodf,*) ' ' + endif + jmin = jmax + 1 + 60 continue +c +c generate Taylor map +c + write(6,*)'calling routine tugen' + call tugen(th,tmh) + write(6,*)'returned from tugen' +c +c write formatted dump of taylor map +c + tag(1) = 't' + tag(2) = 'u' +c +c T-matrix elements +c + if(lterm) write(jof,61) fmin + if(lfile) write(jodf,61) fmin + 61 format(/,' T-Matrix elements >',1pe10.3,/) +c +c optional machine readback file of taylor map +c + if(lun.gt.0) then + ii = 0 + jj = 0 + write(lun,68) ii,jj,zero + 68 format(2i4,1pg23.14) + do 75 ii = 1, 6 + do 70 jj = 1, 6 + if(tmh(ii,jj).ne.zero) write(lun,68) ii,jj,tmh(ii,jj) + 70 continue + 75 continue + do 85 jj = 1, 6 + do 80 ii = 1, 83 + if(tumat(ii,jj).ne.zero) then + write(lun,78) jj,ii,tumat(ii,jj),(expon(m,ii),m=1,6) + 78 format(2i4,1pg23.14,3x,6i2) + endif + 80 continue + 85 continue + endif +c +c begin formatted writes +c + write(6,*)'beginning formatted writes' + do 90 ii = 1,imax + i = iuse(ii) + kmax = 35 + jmin = 1 + jmax = 0 + tu = tag(1) + do 120 k = 1, kmax + jmax = jmax + kblok(k) + nfuse = 0 + do 100 j = jmin, jmax + n = lut(j) + if(n.gt.27) go to 100 + tval = tumat(n,i) + if(dabs(tval).le.fmin) go to 100 + tref = tval*zvec(n) + if(lterm) then + write(jof,38) tu,i,n,tu,i,(expon(m,n),m=1,6),tval,tval,tref + endif + if(lfile) then + write(jodf,38) tu,i,n,tu,i,(expon(m,n),m=1,6),tval,tval,tref + endif + 38 format(2x,a1,i1,'(',i2,')',' = ',a1,i1,'( ',2i1,2(i2,i1),' ) =', + & f21.6,' =',1pe10.2,' ref:',1pe10.2) +c if(lun.gt.0) write(lun,138) i,n,(expon(m,n),m=1,6),tumat(n,i) + 138 format(2i3,6i2,1pg21.13) + nfuse = nfuse + 1 + 100 continue + jmin = jmax + 1 + 120 continue + if(lterm) write(jof,*) ' ' + if(lfile) write(jodf,*) ' ' + 90 continue +c +c print sorted U-matrix +c + tu = tag(2) + if(lterm) write(jof,91) fmin + if(lfile) write(jodf,91) fmin + 91 format(/,' U-Matrix elements >',1pe10.3,/) +c if(lun.gt.0) write(lun,91) fmin + kmax = 35 + jmin = 1 + jmax = 0 + do 180 k = 1, kmax + jmax = jmax + kblok(k) + do 190 ii = 1,imax + i = iuse(ii) + nfuse = 0 + do 170 j = jmin, jmax + n = lut(j) + if(n.lt.28) go to 170 + if(n.gt.83) go to 170 + tval = tumat(n,i) + if(dabs(tval).le.fmin) go to 170 + tref = tval*zvec(n) + if(lterm) then + write(jof,38) tu,i,n,tu,i,(expon(m,n),m=1,6),tval,tval,tref + endif + if(lfile) then + write(jodf,38) tu,i,n,tu,i,(expon(m,n),m=1,6),tval,tval,tref + endif +c if(lun.gt.0) write(lun,138) i,n,(expon(m,n),m=1,6),tumat(n,i) + nfuse = nfuse + 1 + 170 continue + if(nfuse.gt.0) then + if(lterm) write(jof,*) ' ' + if(lfile) write(jodf,*) ' ' + endif + 190 continue + jmin = jmax + 1 + 180 continue + return + end +c +*********************************************************************** +c + subroutine user3(p) +c +c user3 dumps the specified range of ucalc in full +c precision on unit nfile + + use acceldata + use lieaparam, only : monoms + include 'impli.inc' + include 'usrdat.inc' + include 'map.inc' + dimension p(6) +c +c parameters +c +c p(1) = nfile = unit to write on +c p(2) = kmin = array min to write +c p(3) = kmax = array max to write +c p(4) = job: job = 0 to dump range if ucalc to unit nfile +c job = 1 to dump current matrix to unit nfile +c job = 2 to list typecodes +c job = 3 to list all typecodes +c job = 4 to edit comment block +c job = 5 for a Marylie dump of all commons +c p(5) = kform = format flag for dumps = 0 for full * precision +c p(6) = nextra = spare flag +c + nfile = nint(p(1)) + if(nfile.le.0) return + kmin = nint(p(2)) + kmax = nint(p(3)) + job = nint(p(4)) + kform = nint(p(5)) + nextra = nint(p(6)) +c +c ucalc dump is job 0 +c + if(job.eq.0) then + write(nfile,*) ' UCALC DUMP' + do 100 k=kmin, kmax + if(ucalc(k).ne.0.0) write(nfile,*) k, ucalc(k) + 100 continue + endif +c +c matrix print is job 1 +c + if(job.eq.1) then + write(nfile,*) ' -------- Current Matrix ----------' + write(nfile,130) (tmh(1,j),j=1,2),(tmh(3,j),j=3,4) + write(nfile,130) (tmh(2,j),j=1,2),(tmh(4,j),j=3,4) + 130 format(' Rx:',2f15.9,' Ry:',2f15.9) + endif +c +c list typecodes in this version of marylie +c + if(job.eq.2) call listyp(nfile) + if(job.eq.3) call allist(nfile) +c +c comment editing +c + if(job.eq.4) then + write(6,*)' Edit comments (e.g. to show purpose of this run)' + call caedit(maxcmt, np, mline) + endif +c +c marylie input dump +c + if(job.eq.5) call dump(nfile) + return + end +c------------------------------------------------------ + subroutine user4(p) + dimension p(*) + write(6,*)'In dummy USER4' + return + end +c--------------------------------------------------------------- + subroutine user5(pp) + include 'impli.inc' + include 'files.inc' + include 'linbuf.inc' + include 'usrdat.inc' + parameter (maxa=200, maxpt=2000) + dimension ktyp(maxa), path(maxa), bend(maxa), pp(*) + dimension xx(maxpt),yy(maxpt),key(maxpt) + logical ltty, ldsk + ltty = .true. + ldsk = .true. +c write(jof,*) ' USER5 Parameter set processor called for arcs.' + npsu = 7 + call filin +c type *, npsu,'=npsu',npst,' of these are in loop:' + if(npst.le.0) return + zero = 0.0d0 + one = 1.0d0 + two = 2.0d0 + pi = 3.14159265358979d0 + radeg = pi/180.0d0 + rdef = 192.0d0/pi + rru = rdef +c------------------------------------------ + iop = nint(pp(1)) + xbeg = pp(2) + ybeg = pp(3) + if(iop.eq.1) then + xbeg = pp(2)*dcos(radeg*pp(3)) + ybeg = pp(2)*dsin(radeg*pp(3)) + endif + angle = pp(4) + iud = nint(pp(5)) + if(iud.lt.0) then + iud = -iud + ltty = .false. + ldsk = .false. + endif + lun = nint(pp(6)) +c +c echo and process contents of loop +c + arclen = zero + do 20 j = 1, npst + job = nint(aap(j)) + path(j) = bbp(j) + bend(j) = ccp(j) + theta = radeg*bend(j) + if(job.eq.1) rru = dabs(path(j)/theta) + if(job.eq.2) path(j) = dabs(rru*radeg*bend(j)) + if(job.eq.3) bend(j) = path(j)/(rru*radeg) + ktyp(j) = nint(ddp(j)) + arclen = arclen + path(j) + if(ltty) then + write(jof,17) j,job,ktyp(j),path(j),bend(j),rru,bbp(j),ccp(j) + endif + if(ldsk) then + write(jodf,17) j,job,ktyp(j),path(j),bend(j),rru,bbp(j),ccp(j) + endif + 17 format(i6,2i3,5f13.6) + 20 continue +c +c data in, draw arcs +c + xx(1) = xbeg + yy(1) = ybeg + delta = two + call arcs(npst,ktyp,path,bend,angle,delta,maxpt,xx,yy,key,nn) + if(ltty) write(jof,32) arclen,nn + if(ldsk) write(jodf,32) arclen,nn + 32 format(' Total path length =',f12.6,' in',i4,' points') + if(ltty) write(jof,34) xx(nn),yy(nn),angle + if(ldsk) write(jodf,34) xx(nn),yy(nn),angle + 34 format(' Endpoint:',f13.6,' = x',f13.6,' = y at',f10.4,' deg.') +c +c optional save to ucalc +c + if((iud.gt.0).and.(iud.le.250)) then + ucalc(iud) = arclen + ucalc(iud+1) = angle + ucalc(iud+2) = xx(nn) + ucalc(iud+3) = yy(nn) + endif +c +c optional coordinate dump +c + if(lun.le.0) return + do 50 j = 1,nn + write(lun,47) key(j),xx(j),yy(j) + 47 format(i5,2f12.6) + 50 continue + return + end +c +*********************************************************************** +c + subroutine user6(p,f,fm) +c +c alternate sigma matrix input +c +c p(1) = alphax +c p(2) = betax +c p(3) = epsx +c p(4) = alphay +c p(5) = betay +c p(6) = epsy + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'usrdat.inc' + include 'sigbuf.inc' + dimension f(monoms) + dimension fm(6,6) + dimension p(6), psig(6) + alphax = p(1) + betax = p(2) + epsx = p(3) + if(epsx.le.0.0) epsx = 1.0 + alphay = p(4) + betay = p(5) + epsy = p(6) + if(epsy.le.0.0) epsy = 1.0 + psig(1) = sqrt(epsx*betax) + psig(2) = alphax + gamx = (1.0 + alphax**2)/betax + psig(3) = sqrt(epsx*gamx) + psig(4) = sqrt(epsy*betay) + psig(5) = alphay + gamy = (1.0 + alphay**2)/betay + psig(6) = sqrt(epsy*gamy) + call user8(psig, f, fm) + return + end +c +************************************************************************ +c +cryne 8/11/2001 subroutine user7(p,g,mh) +cryne 8/11/2001 include 'impli.inc' +cryne 8/11/2001 dimension p(6) +ccc call u7test(p) +cryne 8/11/2001 return +cryne 8/11/2001 end +c +c subroutine user7(p,g,mh) +c type *, ' In dummy USER7' +c return +c end +*********************************************************************** +c + subroutine user8(p,f,rm) +c This routine applies the current map in (f,rm) to the initial sigma +c matrix given in the parameter set p = (s11,s12,s22,s33,s34,s44), to +c produce the output sigma matrix of the same form, which is saved in +c ucalc(1:6) in the same order. +c +c parameters: p(1) = xmax = sqrt(betax*xemit) +c p(2) = alphax +c p(3) = thetax = sqrt(gammax*xemit) +c p(4) = ymax = sqrt(betay*yemit) +c p(5) = alphay +c p(6) = thetay = sqrt(gammay*yemit) +c Tom Mottershead LANL 31-Mar-89 +c f Neri LANL 5-Dec-90 Full 4D calculation. +c Elliptical beam kicks. 8-Apr-92 +c--------------------------------------------------------------------- + use beamdata + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'usrdat.inc' + include 'sigbuf.inc' + include 'parset.inc' + dimension f(monoms) + dimension rm(6,6) + dimension p(6) + logical lterm, lfile + isend = 3 + level = 1 + lterm = .true. + lfile = .true. +c +c save input parameters to sigbuf for user1 +c +c load input beam from #menu +c + if(p(1).gt.0.0) then + xxin = p(1) + axin = p(2) + pxin = p(3) + yyin = p(4) + ayin = p(5) + pyin = p(6) + go to 100 + endif +c +c optional input specifications +c + job = nint(-p(1)) + inform = nint(p(2)) + lunin = nint(p(3)) + lout = nint(p(4)) +c +c output switches +c + level = nint(p(5)) + isend = nint(p(6)) + lterm = .false. + lfile = .false. + if((isend.eq.1).or.(isend.eq.3)) lterm = .true. + if(isend.ge.2) lfile = .true. +c +c aberrations only case +c + if(job.eq.5) go to 300 + if(inform.ne.0) go to 100 + if(lunin.gt.0) then + rewind(lunin) + read(lunin,*) xxin,axin,pxin,yyin,ayin,pyin + endif + if(lunin.lt.0) then + kpu = -lunin + if((kpu.lt.1).or.(kpu.gt.maxpst)) then + write(jof,*) ' USR8 Error:',kpu,' is not a valid pset' + call myexit + endif + xxin = pst(1,kpu) + axin = pst(2,kpu) + pxin = pst(3,kpu) + yyin = pst(4,kpu) + ayin = pst(5,kpu) + pyin = pst(6,kpu) + endif +c +c end of input options, map the beam +c + 100 continue + if(iquiet.eq.1) then + lterm = .false. + lfile = .false. + endif +c +c clear sigma matrices +c + do 150 i=1,4 + do 150 j=1,4 + sig0(i,j) = 0.d0 + sigf(i,j) = 0.d0 + 150 continue +c +c Initialize Sigma Matrix from input beam parameter block +c + sig0(1,1) = xxin**2 + sig0(1,2) = -xxin*axin*pxin/sqrt(1.0d0 + axin**2) + sig0(2,2) = pxin**2 + sig0(2,1) = sig0(1,2) + sig0(3,3) = yyin**2 + sig0(3,4) = -yyin*ayin*pyin/sqrt(1.0d0 + ayin**2) + sig0(4,4) = pyin**2 + sig0(4,3) = sig0(3,4) +c +c Transport Ellipse ( 4D ) +c + do 250 i=1,4 + do 250 j=1,4 + do 200 k=1,4 + do 200 n=1,4 + sigf(i,j) = sigf(i,j) + rm(i,n)*sig0(n,k)*rm(j,k) + 200 continue + 250 continue +c type *, ' sigf:', sigf +c +c normal moments +c + xxf = sigf(1,1) + xpf = sigf(1,2) + ppf = sigf(2,2) + yyf = sigf(3,3) + yqf = sigf(3,4) + qqf = sigf(4,4) +c +c cross moments +c + xyf = sigf(1,3) + ypf = sigf(2,3) + xqf = sigf(1,4) + detc = xxf*yyf-xyf**2 +c type *,' detc =',detc + xfocus = (yyf*xpf-xyf*ypf)/detc + yfocus = (xxf*yqf-xyf*xqf)/detc + xcross = (xxf*ypf-xyf*xpf)/detc + ycross = (yyf*xqf-xyf*yqf)/detc +c +c normal emittances +c + exsq = xxf*ppf - xpf**2 + if(exsq.le.0.0) exsq = 1.e-30 + ex = sqrt(exsq) + betax = xxf/ex + gammax = ppf/ex +c + eysq = yyf*qqf - yqf**2 + if(eysq.le.0.0) eysq = 1.e-30 + ey = sqrt(eysq) + betay = yyf/ey +c + ucalc(1) = sqrt(xxf) + ucalc(2) = -xpf/ex + ucalc(3) = sqrt(ppf) + ucalc(4) = sqrt(yyf) + ucalc(5) = -yqf/ey + ucalc(6) = sqrt(qqf) + ucalc(7) = betax + ucalc(8) = ex + ucalc(9) = xfocus + ucalc(10) = xcross + ucalc(11) = betay + ucalc(12) = ey + ucalc(13) = yfocus + ucalc(14) = ycross + ucalc(50) = xxf-yyf +c +c save output beam +c + if (lout.gt.0) write(lout,*) (ucalc(j), j= 1,6) + if (lout.lt.0) then + kpu = -lout + if((kpu.lt.1).or.(kpu.gt.maxpst)) then + write(jof,*) ' USR8 Error:',kpu,' is not a valid pset' + call myexit + endif + do 400 j=1,6 + pst(j,kpu) = ucalc(j) + 400 continue + endif +c +c copy output back over input if job=3 +c + if(job.eq.3) then + xxin = ucalc(1) + axin = ucalc(2) + pxin = ucalc(3) + yyin = ucalc(4) + ayin = ucalc(5) + pyin = ucalc(6) + endif +c +c Change of Sigma with energy: first order ( f. Neri 12-5-1990 ). +c + dsig(1,1) = -2*f(38)*sigf(1,1) - 4*f(53)*sigf(1,2) - + & 2*f(57)*sigf(1,3) - 2*f(60)*sigf(1,4) + dsig(1,2) = 2*f(33)*sigf(1,1) + f(42)*sigf(1,3) + + & f(45)*sigf(1,4) - 2*f(53)*sigf(2,2) - + & f(57)*sigf(2,3) - f(60)*sigf(2,4) + dsig(2,2) = 4*f(33)*sigf(1,2) + 2*f(38)*sigf(2,2) + + & 2*f(42)*sigf(2,3) + 2*f(45)*sigf(2,4) + dsig(1,3) = -(f(45)*sigf(1,1)) - f(60)*sigf(1,2) - + & f(38)*sigf(1,3) - f(70)*sigf(1,3) - + & 2*f(76)*sigf(1,4) - 2*f(53)*sigf(2,3) - + & f(57)*sigf(3,3) - f(60)*sigf(3,4) + dsig(2,3) = -(f(45)*sigf(1,2)) + 2*f(33)*sigf(1,3) - + & f(60)*sigf(2,2) + f(38)*sigf(2,3) - + & f(70)*sigf(2,3) - 2*f(76)*sigf(2,4) + + & f(42)*sigf(3,3) + f(45)*sigf(3,4) + dsig(3,3) = -2*f(45)*sigf(1,3) - 2*f(60)*sigf(2,3) - + & 2*f(70)*sigf(3,3) - 4*f(76)*sigf(3,4) + dsig(1,4) = f(42)*sigf(1,1) + f(57)*sigf(1,2) + + & 2*f(67)*sigf(1,3) - f(38)*sigf(1,4) + + & f(70)*sigf(1,4) - 2*f(53)*sigf(2,4) - + & f(57)*sigf(3,4) - f(60)*sigf(4,4) + dsig(2,4) = f(42)*sigf(1,2) + 2*f(33)*sigf(1,4) + + & f(57)*sigf(2,2) + 2*f(67)*sigf(2,3) + + & f(38)*sigf(2,4) + f(70)*sigf(2,4) + + & f(42)*sigf(3,4) + f(45)*sigf(4,4) + dsig(3,4) = f(42)*sigf(1,3) - f(45)*sigf(1,4) + + & f(57)*sigf(2,3) - f(60)*sigf(2,4) + + & 2*f(67)*sigf(3,3) - 2*f(76)*sigf(4,4) + dsig(4,4) = 2*f(42)*sigf(1,4) + 2*f(57)*sigf(2,4) + + & 4*f(67)*sigf(3,4) + 2*f(70)*sigf(4,4) +c + ds11 = dsig(1,1) + ds12 = dsig(1,2) + ds22 = dsig(2,2) + ds33 = dsig(3,3) + ds34 = dsig(3,4) + ds44 = dsig(4,4) +c + ucalc(21) = ds11 + ucalc(22) = ds12 + ucalc(23) = ds22 + ucalc(24) = ds33 + ucalc(25) = ds34 + ucalc(26) = ds44 +c + dfxdp = -beta*(xxf*ds12 - xpf*ds11)/(xxf**2) + dfydp = -beta*(yyf*ds34 - yqf*ds33)/(yyf**2) + ucalc(15) = dfxdp + ucalc(16) = dfydp + ucalc(37) = dfxdp - dfydp + ucalc(38) = dfxdp**2 + dfydp**2 +c +c rms cubic aberration amplitude +c +c aa = f(84) +c bb = f(95) +c cc = f(175) +c qq0 = 5.0*(aa**2 + cc**2) + 0.5*bb**2 + bb*(aa+cc) +c abcube = sqrt(qq0) +c Get Ellipticity from user1: + rx = ucalc(46) + if (rx .eq. 0.0 ) then + write(6,*) ' user8: Ellipticity not set in user1, so take r=1' + rx = 1.0 + endif + ry = 1/rx +c +c Mathematica formula for quadratic and cubic kicks +c + 300 continue +c abquad=3.375*(f(28)**2 + f(64)**2) + 0.875*(f(30)**2 + f(39)**2) +c * + 0.75*(f(30)*f(64) + f(28)*f(39)) +c abcube=5.*(f(84)**2 + f(175)**2) + f(95)*(f(175)+f(84)) + +c * 0.5*f(95)**2 + 0.75*f(86)*f(120) + 0.875*(f(86)**2+f(120)**2) +c + abquad=3.375*rx**4*f(28)**2 + 0.375*rx**4*f(30)**2 + + & 0.5*rx**2*ry**2*f(30)**2 + + & 0.75*rx**2*ry**2*f(28)*f(39) + + & 0.5*rx**2*ry**2*f(39)**2 + 0.375*ry**4*f(39)**2 + + & 0.75*rx**2*ry**2*f(30)*f(64) + 3.375*ry**4*f(64)**2 + abcube=5.*rx**6*f(84)**2 + 0.3125*rx**6*f(86)**2 + + & 0.5625*rx**4*ry**2*f(86)**2 + + & rx**4*ry**2*f(84)*f(95) + + & 0.25*rx**4*ry**2*f(95)**2 + + & 0.25*rx**2*ry**4*f(95)**2 + + & 0.375*rx**4*ry**2*f(86)*f(120) + + & 0.375*rx**2*ry**4*f(86)*f(120) + + & 0.5625*rx**2*ry**4*f(120)**2 + + & 0.3125*ry**6*f(120)**2 + rx**2*ry**4*f(95)*f(175) + + & 5.*ry**6*f(175)**2 +c +c + ptquad=3.375*(f(49)**2 + f(74)**2) + 0.875*(f(51)**2 + f(58)**2) + & + 0.75*(f(51)*f(74) + f(49)*f(58)) +c + ptcube=5.*(f(140)**2 + f(195)**2) + f(149)*(f(195)+f(140)) + + & 0.5*f(149)**2 + 0.75*f(142)*f(165) + 0.875*(f(142)**2+f(165)**2) +c + abfour = 0.0 + abfive = 0.0 + ucalc(17) = sqrt(abquad) + ucalc(18) = sqrt(abcube) + ucalc(19) = sqrt(abfour) + ucalc(20) = sqrt(abfive) + ucalc(60) = sqrt(ptquad) + ucalc(61) = sqrt(ptcube) +c + cx = -2.0*beta*f(33) + cy = -2.0*beta*f(67) + ucalc(41) = cx + ucalc(42) = cy + ucalc(43) = cx**2 + cy**2 + ucalc(44) = cx - cy + ucalc(45) = ucalc(1)*ucalc(4) + cxim = -2.0*beta*f(53) + ucalc(62) = cxim + if(f(38).ne.0.0) xvs = -2.0*f(53)/f(38) + ucalc(63) = xvs + cyim = -2.0*beta*f(76) + ucalc(64) = cyim + if(f(70).ne.0.0) yvs = -2.0*f(76)/f(70) + ucalc(65) = yvs + if(lterm) call u8out(jof,level) + if(lfile) call u8out(jodf,level) + return + end +c**************************************************************** + subroutine user9(p,fa,fm) +c +c This routine does arithmetic operations on the current map. +c C. T. Mottershead LANL AOT-1 / 4 April 96 +c--------------------------------------------------------------------- + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'usrdat.inc' + include 'taylor.inc' + dimension fa(monoms) + dimension fm(6,6) + dimension p(6), xv(30) +c + job = int(p(1)) + jndx = int(p(2)) + kndx = int(p(3)) + nusr = int(p(4)) + aa = p(5) + bb = p(6) +c type *,' USR9:',job,jndx,kndx,nusr,aa,bb + if(job.lt.0) then + job = -job + idxa = nint(p(5)) + if((idxa.gt.0).and.(idxa.le.250)) aa = ucalc(idxa) + idxb = nint(p(6)) + if((idxb.gt.0).and.(idxb.le.250)) bb = ucalc(idxb) + endif + zero = 0.0d0 + value = zero +c +c job = 0 is to set constants into ucalc +c + if(job.eq.0) then + if((jndx.gt.0).and.(jndx.le.250)) ucalc(jndx) = aa + if((kndx.gt.0).and.(kndx.le.250)) ucalc(kndx) = bb +c write(6,17) jndx,aa,kndx,bb +c 17 format(' in USR9, set u(',i3,')=',f12.6,' u(',i3,')=',f12.6) + return + endif +c +c a valid user location is required for job.ne.0 +c + if((nusr.lt.1).or.(nusr.gt.250)) then + write(jof,117) nusr + 117 format(' USR9 ERROR:',i8,' is not a valid UCALC location') + return + endif +c +c job = 1 is to store linear combinations of R-matrix elements +c + if(job.eq.1) then + if((jndx.gt.10).and.(jndx.lt.67)) then + ii = jndx/10 + jj = jndx - 10*ii + value = value + aa*fm(ii,jj) + endif + if((kndx.gt.10).and.(kndx.lt.67)) then + ii = kndx/10 + jj = kndx - 10*ii + value = value + bb*fm(ii,jj) + endif + endif +c +c job = 2 is to store linear combinations of Lie coefficients +c + if(job.eq.2) then + if((jndx.gt.0).and.(jndx.le.monoms)) value=value+aa*fa(jndx) + if((kndx.gt.0).and.(kndx.le.monoms)) value=value+bb*fa(kndx) + endif +c +c job=3 is to store linear combinations of UCALC entries +c + if(job.eq.3) then + if((jndx.gt.0).and.(jndx.le.250)) value=value+aa*ucalc(jndx) + if((kndx.gt.0).and.(kndx.le.250)) value=value+bb*ucalc(kndx) + endif +c +c job=4 is to compute reciprocals of selected variables +c + if(job.eq.4) then + if((kndx.gt.0).and.(kndx.lt.4)) then + call getvar(kndx,nv,xv) + if((jndx.le.nv).and.(jndx.gt.0)) then + xpar = xv(jndx) + if(xpar.ne.0.0d0) value = aa/xpar + endif + endif + endif +c +c job=5 is to compute ratios of Lie coefficients +c + if(job.eq.5) then + if((jndx.gt.0).and.(jndx.le.monoms)) value=value+aa*fa(jndx) + if((kndx.gt.0).and.(kndx.le.monoms)) then + denom = fa(kndx) + bb + if(denom.ne.zero) value = value/denom + endif + endif +c +c job=6 is to compute ratios of Taylor coefficients +c + if(job.eq.6) then + if((jndx.gt.10).and.(jndx.lt.836)) then + ii = jndx/10 + jj = jndx - 10*ii + value = value + aa*tumat(ii,jj) + endif + if((kndx.gt.10).and.(kndx.lt.836)) then + ii = kndx/10 + jj = kndx - 10*ii + denom = tumat(ii,jj) + bb + if(denom.ne.zero) value = value/denom + endif + endif +c +c job=7 is to compute ratios of ucalc entries +c + if(job.eq.7) then + if((jndx.gt.0).and.(jndx.le.250)) value=value+aa*ucalc(jndx) + if((kndx.gt.0).and.(kndx.le.250)) then + denom = ucalc(kndx) + bb + if(denom.ne.zero) value = value/denom + endif + endif +c +c job=8 is to compute the weighted RMS of the two ucalc entries: +c + if(job.eq.8) then + if((jndx.gt.0).and.(jndx.le.250)) then + value=value+aa*ucalc(jndx)**2 + endif + if((kndx.gt.0).and.(kndx.le.250)) then + value=value+bb*ucalc(kndx)**2 + endif + value = dsqrt(value) + endif + ucalc(nusr) = value + return + end +c**************************************************************** + subroutine user10(p,fa,fm) +cryne routine to print data in the fitbuf array +c--------------------------------------------------------------------- + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'usrdat.inc' + include 'taylor.inc' + include 'fitdat.inc' +ctm include 'arcblk.inc' + include 'map.inc' + dimension fa(monoms) + dimension fm(6,6),p(6) +c + nfile = nint(p(1)) + i1=nint(p(2)) + i2=nint(p(3)) + i3=nint(p(4)) + i4=nint(p(5)) + i5=nint(p(6)) + if(i1.eq.0)then + col1=arclen + else + col1=fitval(i1) + endif + if(i3.eq.0)then + write(nfile,101)col1,fitval(i2) + elseif(i4.eq.0)then + write(nfile,101)col1,fitval(i2),fitval(i3) + elseif(i5.eq.0)then + write(nfile,101)col1,fitval(i2),fitval(i3),fitval(i4) + else + write(nfile,101)col1,fitval(i2),fitval(i3),fitval(i4),fitval(i5) + endif + 101 format(5(1pe13.6,1x)) +ctm9/01 call flush_(nfile) + return + end +c +************************************************************************ +c + subroutine user11(p,fa,fm) +c dbleArr p(6) +c p(1)= +c p(2)= +c p(3)= +c p(4)= +c p(5)= +c p(6)= +c dblArr fa(monoms)=Lie generators for map f +c dblArr fm(6,6)=linear part of map f +c +c Dummy user routine 'user11'. +c-----!----------------------------------------------------------------! + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c + write(6,*) 'in user11 ... returning ...' +c + return + end +c +************************************************************************ +c + subroutine user12(p,fa,fm) +c dbleArr p(6) +c p(1)= +c p(2)= +c p(3)= +c p(4)= +c p(5)= +c p(6)= +c dblArr fa(monoms)=Lie generators for map f +c dblArr fm(6,6)=linear part of map f +c +c Dummy user routine 'user12'. +c-----!----------------------------------------------------------------! + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c + write(6,*) 'in user12 ... returning ...' +c + return + end +c +************************************************************************ +c + subroutine user13(p,fa,fm) +c dbleArr p(6) +c p(1)= +c p(2)= +c p(3)= +c p(4)= +c p(5)= +c p(6)= +c dblArr fa(monoms)=Lie generators for map f +c dblArr fm(6,6)=linear part of map f +c +c Dummy user routine 'user13'. +c-----!----------------------------------------------------------------! + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c + write(6,*) 'in user13 ... returning ...' +c + return + end +c +************************************************************************ +c + subroutine user14(p,fa,fm) +c dbleArr p(6) +c p(1)= +c p(2)= +c p(3)= +c p(4)= +c p(5)= +c p(6)= +c dblArr fa(monoms)=Lie generators for map f +c dblArr fm(6,6)=linear part of map f +c +c Dummy user routine 'user14'. +c-----!----------------------------------------------------------------! + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c + write(6,*) 'in user14 ... returning ...' +c + return + end +c +************************************************************************ +c + subroutine user15(p,fa,fm) +c dbleArr p(6) +c p(1)= +c p(2)= +c p(3)= +c p(4)= +c p(5)= +c p(6)= +c dblArr fa(monoms)=Lie generators for map f +c dblArr fm(6,6)=linear part of map f +c +c Dummy user routine 'user15'. +c-----!----------------------------------------------------------------! + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c + write(6,*) 'in user15 ... returning ...' +c + return + end +c +************************************************************************ +c + subroutine user16(p,fa,fm) +c dbleArr p(6) +c p(1)= +c p(2)= +c p(3)= +c p(4)= +c p(5)= +c p(6)= +c dblArr fa(monoms)=Lie generators for map f +c dblArr fm(6,6)=linear part of map f +c +c Dummy user routine 'user16'. +c-----!----------------------------------------------------------------! + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c + write(6,*) 'in user16 ... returning ...' +c + return + end +c +************************************************************************ +c + subroutine user17(p,fa,fm) +c dbleArr p(6) +c p(1)= +c p(2)= +c p(3)= +c p(4)= +c p(5)= +c p(6)= +c dblArr fa(monoms)=Lie generators for map f +c dblArr fm(6,6)=linear part of map f +c +c Dummy user routine 'user17'. +c-----!----------------------------------------------------------------! + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c + write(6,*) 'in user17 ... returning ...' +c + return + end +c +************************************************************************ +c + subroutine user18(p,fa,fm) +c dbleArr p(6) +c p(1)= +c p(2)= +c p(3)= +c p(4)= +c p(5)= +c p(6)= +c dblArr fa(monoms)=Lie generators for map f +c dblArr fm(6,6)=linear part of map f +c +c Dummy user routine 'user18'. +c-----!----------------------------------------------------------------! + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c + write(6,*) 'in user18 ... returning ...' +c + return + end +c +************************************************************************ +c + subroutine user19(p,fa,fm) +c dbleArr p(6) +c p(1)= +c p(2)= +c p(3)= +c p(4)= +c p(5)= +c p(6)= +c dblArr fa(monoms)=Lie generators for map f +c dblArr fm(6,6)=linear part of map f +c +c Dummy user routine 'user19'. +c-----!----------------------------------------------------------------! + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c + write(6,*) 'in user19 ... returning ...' +c + return + end +c +************************************************************************ +c + subroutine user20(p,fa,fm) +c dbleArr p(6) +c p(1)= +c p(2)= +c p(3)= +c p(4)= +c p(5)= +c p(6)= +c dblArr fa(monoms)=Lie generators for map f +c dblArr fm(6,6)=linear part of map f +c +c Dummy user routine 'user20'. +c-----!----------------------------------------------------------------! + use lieaparam, only : monoms + include 'impli.inc' +c +c calling arrays + dimension fa(monoms) + dimension fm(6,6) + dimension p(6) +c + write(6,*) 'in user20 ... returning ...' +c + return + end +c +************************************************************************ diff --git a/OpticsJan2020/MLI_light_optics/Src/user7.f b/OpticsJan2020/MLI_light_optics/Src/user7.f new file mode 100755 index 0000000..c4a7c84 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/user7.f @@ -0,0 +1,51 @@ + subroutine user7(p,g,hmh) + use lieaparam, only : monoms + include 'impli.inc' + include 'ind.inc' + include 'prodex.inc' + dimension p(*), g(*), hmh(*) + write(6,*)' In USER7 test' + lun = p(1) + mbgn = p(2) + if(mbgn.le.0) mbgn = 1 + num = p(3) + if(num.le.0) num = monoms + write(6,*)'PRODEX:' + do i=0,923 + write(96,1234)i,prodex(1:6,i) + enddo + 1234 format(i5,4x,6i10) +c call sixi(lun,prodex,monoms) + write(6,*)imaxi,' = IMAXI' + write(6,*)' JV, INDEX1, INDEX2' + call onei(lun,jv(mbgn),index1(mbgn),index2(mbgn),num) + return + end +c-------------------------------- + subroutine sixi(lun,ival,num) + dimension ival(6,*), ibuf(6) + do 100 k = 1,num+1 + kv = 0 + do 50 j = 1,6 + ibuf(j) = ival(j,k) + if(ibuf(j).ne.0) kv = kv + 1 + 50 continue + if(kv.gt.0) write(lun,77) k,ibuf + 77 format(7i5) + 100 continue + return + end +c-------------------------------------- + subroutine onei(lun,ival,jval,kval,num) + dimension ival(*), jval(*), kval(*) + do 100 k = 1,num + if(ival(k).ne.0) write(lun,77) k,ival(k),jval(k),kval(k) + 77 format(4i8) + 100 continue + return + end +c +c subroutine user7(p,g,hmh) +c dimension p(*), g(*), hmh(*) +c return +c end diff --git a/OpticsJan2020/MLI_light_optics/Src/usubs.f b/OpticsJan2020/MLI_light_optics/Src/usubs.f new file mode 100755 index 0000000..37fa2c7 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/usubs.f @@ -0,0 +1,1185 @@ +c********* USER subroutines pkg ******* + subroutine allist(lun) +c +c allist makes an alphabetical LaTeX table of all +c type codes in the current vesion of marylie +c T. Mottershead LANL AT-3 16 Jan 92 +c------------------------------------------------- + include 'codes.inc' + character*8 tcode(360), word + dimension nseq(360), npars(360), kind(360) +c +c fill unsorted tcode array, stopping on null string for each group +c + long = 40 + max = 0 + do 20 j = 1, 9 + do 10 n=1,40 + word = ltc(j,n) + if(ichar(word(1:1)).eq.0) go to 20 + max = max + 1 + tcode(max) = word + npars(max) = nrp(j,n) + kind(max) = j + 10 continue + 20 continue +c +c alphabetize and write Latex table +c + call lexort(max,tcode,nseq) + call headoc(lun,'MaryLie Type Codes') + call tabdef(lun,5) + write(lun,27) + 27 format(' No. & Code & Kind & NRP & \\') + write(lun,*) ' \hline' + do 50 k = 1,max + jj = nseq(k) + write(lun,37) k, tcode(jj), kind(jj), npars(jj) + 37 format(i6,' & ',a,' &',i3,' &',i3,' & \\') + if(mod(k,long).eq.0) then + call tabend(lun) + write(lun,*) ' \newpage' + call tabdef(lun,5) + write(lun,27) + write(lun,*) ' \hline' + endif + 50 continue + call tabend(lun) + call endoc(lun) + return + end +c--------------------------------------------------- + subroutine arcs(nseg,ktyp,path,bend,angle,delta,max,xx,yy,key,nn) +c +c Generates (xx(i),yy(i),i=1,nn) for drawing a sequence of +c connected arcs. The curve starts from x(1),y(1) at input angle, +c and ends at x(nn),y(nn) headed in direction of final angle. +c nseg = number of path segments k=1,nseg +c path(k) = arclength of kth segment +c bend(k) = bend angle in degrees of kth segment +c ktyp(k) = ID or type code for kth segment +c delta = degrees of bend per plot point (max allowed) +c max = maximum number of output points allowed +c +c C. T. Mottershead 24 Aug 99 +c------------------------------------------------------- + implicit double precision (a-h,o-z) + dimension path(*),bend(*),ktyp(*),xx(max),yy(max),key(max) + pi = 3.14159265358979d0 + radeg = pi/180.0d0 + bmin = 0.001 + one = 1.0d0 + xu = xx(1) + yu = yy(1) + key(1) = ktyp(1) + lout = 44 + nn = 0 +c +c loop over all path segments +c + do 200 k = 1,nseg + theta = radeg*angle + angle = angle + bend(k) + xs = path(k)*dcos(theta) + ys = path(k)*dsin(theta) + write(lout,207) k,ktyp(k),path(k),bend(k),angle,xs,ys + 207 format(' Arc:',2i4,5f12.4) +c +c straight segment +c + if(dabs(bend(k)).lt.bmin) then + nn = nn+1 + if(nn.gt.max) return + xx(nn) = xu + yy(nn) = yu + key(nn) = ktyp(k) + nn = nn+1 + if(nn.gt.max) return + xu = xu + xs + yu = yu + ys + xx(nn) = xu + yy(nn) = yu + key(nn) = ktyp(k) + np = 1 +c write(lout,97) nn,key(nn),xx(nn),yy(nn),xs,ys + go to 190 + endif +c +c curved segment (starts with duplicate of previous point) +c + nn = nn+1 + if(nn.gt.max) return + xx(nn) = xu + yy(nn) = yu + key(nn) = ktyp(k) + phi = radeg*bend(k) + radius = path(k)/phi + np = nint(bend(k)/delta) + if(np.lt.0) np = -np + if(np.eq.0) np = 1 + fnp = float(np) + alpha = phi/fnp + xs = xs/fnp + ys = ys/fnp + cosa = dcos(alpha) + sina = dsin(alpha) + sfac = sina/alpha + cfac = (one-cosa)/alpha + x0 = xs + y0 = ys +c +c update plot points in arc +c + do 100 j = 1,np + dx = sfac*xs - cfac*ys + dy = sfac*ys + cfac*xs + xu = xu + dx + yu = yu + dy + nn = nn+1 + if(nn.gt.max) return + xx(nn) = xu + yy(nn) = yu + key(nn) = ktyp(k) + xs = cosa*x0 - sina*y0 + ys = cosa*y0 + sina*x0 + x0 = xs + y0 = ys + 100 continue + 190 continue + 200 continue + return + end +c +ccccccccccccccccc Blocks cccccccccccccccccccccccccccccc +c + subroutine blocks(nep,lun) + use beamdata + include 'impli.inc' + include 'linbuf.inc' + zero = 0.0d0 + ap = zero + zbeg = zero + nn = 0 + write(lun,12) nep,nrays,npos,nang,brho,beta,gamm1 + write(lun,13) zbeg, ap, strong(1), nn,nn, cname(1) + 12 format(4i5,3f16.7) + 13 format(3f16.7,2i5,2x,a8) +c +c write envelope file top section +c + do 20 nn = nbgn, nend + ltyp = lintyp(nn) + zbeg = total + total = total + elong(nn) + cmtot = 100.0*total + cml = 100.0*elong(nn) + glp = elong(nn)*strong(nn) + gltot = gltot + abs(glp) + rcm = 100.0*radius(nn) + kk = nn + if(ltyp.ne.0) then + ap = radius(nn) + write(lun,13) zbeg, ap, strong(nn), nn, ltyp, cname(nn) + write(lun,13) total, ap, strong(nn), nn, ltyp, cname(nn) + kk = nn + 1 + endif + ap = 0.0 + write(lun,13) total, ap, zero, nn, ltyp, cname(kk) + 20 continue + return + end +c-------------------------------------- + + subroutine caedit(max, nl, text) +c +c caedit is a simple character array editing routine. +c text(i), i=1,nl is the array of character strings to be edited. +c The length of the strings is determined internally. +c All strings are the same length. +c nl = actual number of character strings, which may be increased +c or decreased by this routine. +c max = maximum number of character strings allowed by the calling +c program. +c +c T. Mottershead/ LANL AT-3 / 24 Jan 91 +c---------------------------------------------------------- + character*(*) text(max) + character*74 card +c +c print array +c + 10 do 20 j=1, nl + card = text(j) + write(6,13) j,card + 13 format(i3,a) + 20 continue +c +c command input +c + 30 write(6,32) + 32 format(' enter command: +N = insert new line N, 0 = quit,', + & ' -N = delete line N') + read(5,*) kl + if(kl.eq.0) return +c +c delete line N +c + if(kl.lt.0) then + nd = -kl + if(nd.gt.nl) go to 30 + last = nd + card = ' ' + write(6,37) last + 37 format(' enter last line to delete <',i3,'>:') + read(5,64) card + if(card.ne.' ') then + read(card,*) last + endif + 40 nl = nl-1 + do 50 n = nd,nl + text(n) = text(n+1) + 50 continue + if(last.le.nd) go to 10 + last = last-1 + go to 40 + endif +c +c add new line N +c + if(kl.gt.0) then + if(kl.gt.nl) kl = nl+1 + write(6,*) ' Enter new line(s) =print' + 60 card = ' ' + read(5,64) card + 64 format(a) + if(card.eq.' ') go to 10 + nl = nl+1 + do 90 n = nl-1, kl, -1 + text(n+1) = text(n) + 90 continue + text(kl)=card + kl = kl+1 + go to 60 + endif + go to 10 + end +c +cccccccccccccccccccccccccccccccccccccccccccccccccccc +c + subroutine endoc(lun) +c +c writes LaTeX document end to LUN from fortran programs. +c T. Mottershead AT-3 16 Jan 91 +c-------------------------------------------------- + write(lun,*) ' \end{document}' + return + end +c +*********************************************************************** +c + subroutine filin +c +c filin's job is to fill in /linbuf/ from the contents of +c a loop. Derived from wcl, written by Alex Dragt, 23 August 1988 +c Based on the SRs cqlate and pmif. WCL modified by F. Ner +c Dec 90 to fill LINBUF. That function of wcl save is this routine +c April 91, by T. Mottershead. +c + use beamdata + use acceldata + use lieaparam, only : monoms,monom1,monom2 + include 'impli.inc' + include 'linbuf.inc' + include 'actpar.inc' +c +c common blocks +c + include 'codes.inc' + include 'parset.inc' + include 'files.inc' + include 'loop.inc' + include 'core.inc' +c + dimension ltype(50) + data (ltype(j),j=1,25)/ + & 0,2,2,2,2, + & 2,3,2,1,0, + & 0,0,4,5,7, + & -1,7,1,7,6, + & 7,7,7,7,7/ + save ltype +c +c set parameter set to use (old=9, now pass in from caller CTM 5/00) +c +c npsu = 9 +c +c start routine by checking to see if a loop exists +c + if(nloop.le.0) then + write(jodf,*) ' error in filin: no loop in labor' + write(jof,*) ' error in filin: no loop in labor' + return + endif +c +c initialize linbuf pointers: +c + nbgn = 1 + nend = 0 + npst = 0 +c +c contents of biglist +c +c write(jodf,*) joy,' = joy in filin' + do 100 jj=1,joy + mmv = mim(jj) +c element + if(mmv.lt.0) then + ktyp = 1 + mnu = -mmv +c user supplied element + else if(mmv.gt.5000) then + ktyp = 1 + mnu = mmv-5000 +c lump + else + ktyp = 3 + endif +c write(jodf,*) ' filin: ',jj,'=jj',mmv,'=mim(jj)',mnu,'=mnu', +c * ktyp,'=ktyp' +c procedure for a menu item + if(ktyp.ne.1) go to 100 + imax=nrp(nt1(mnu),nt2(mnu)) + if(imax.eq.0)goto 100 +c +c reset default radius from pset(npsu) (T. Mottershead 23 Jan 91) +c keep all values from the same pset for other purposes, e.g. FOV calc +c (CTM 12/97) +c CTM 11/99: save all instances of npsu in linbuf for future use +c + if((nt1(mnu).eq.3).and.(nt2(mnu).eq.npsu)) then + aapar = pmenu(1+mpp(mnu)) + bbpar = pmenu(2+mpp(mnu)) + ccpar = pmenu(3+mpp(mnu)) + ddpar = pmenu(4+mpp(mnu)) + eepar = pmenu(5+mpp(mnu)) + ffpar = pmenu(6+mpp(mnu)) + npst = npst + 1 + aap(npst) = aapar + bbp(npst) = bbpar + ccp(npst) = ccpar + ddp(npst) = ddpar + eep(npst) = eepar + ffp(npst) = ffpar + endif +c +c Put simple element in linbuf (F. Neri 12/18/1990) +c + if (nt1(mnu).eq.1) then + lt = ltype(nt2(mnu)) + if(lt.eq.1.or.lt.eq.0) then + nend = nend+1 + cname(nend) = lmnlbl(mnu) + lintyp(nend) = lt + mltyp1(nend) = nt1(mnu) + mltyp2(nend) = nt2(mnu) + elong(nend) = pmenu(1+mpp(mnu)) + radius(nend) = aapar + strong(nend) = 0.d0 +c +c normal quad +c + if(nt2(mnu).eq.9) strong(nend) = pmenu(2+mpp(mnu)) +c +c quick & dirty fix for new cfqd (think again about when psets are exe +c + if(nt2(mnu).eq.18) then + ids = nint(pmenu(2+mpp(mnu))) + strong(nend) = pst(1,ids) + pssext(nend) = pst(3,ids) + psoctu(nend) = pst(5,ids) + endif + endif + endif + 100 continue + return + end +c +ccccccccccccccccc RMQUAD ccccccccccccccccccccccccccccccc +c + subroutine fvscan(wx,wy,aper,theta,xfov,yfov,kx,ky) + implicit double precision (a-h,o-z) + parameter (maxz=2000) + common/csrays/jp,mode,cx(maxz),sx(maxz),cy(maxz),sy(maxz) + & ,z(maxz) + write(6,*)'WARNING (fvscan): this routine has a different' + write(6,*)'declaration for common/csrays/ than in sincos.inc' + write(6,*)'Rob Ryne 7/23/2002' +c + eps = 1.0d-12 + xfov = 1.0d6 + yfov = xfov + do 100 k = 1,jp + denx = cx(k)+wx*sx(k) + deny = cy(k)+wy*sy(k) + if(dabs(denx).lt.eps) denx = eps + if(dabs(deny).lt.eps) deny = eps +c type *,k,denx,deny + biga = aper/denx + bigb = aper/deny + xbar = sx(k)*theta/denx + ybar = sy(k)*theta/deny + xsiz = dabs(biga+xbar) + if(xsiz.lt.xfov) then + xfov = xsiz + kx = k + endif + xsiz = dabs(biga-xbar) + if(xsiz.lt.xfov) then + xfov = xsiz + kx = k + endif + ysiz = dabs(bigb+ybar) + if(ysiz.lt.yfov) then + yfov = ysiz + ky = k + endif + ysiz = dabs(bigb-ybar) + if(ysiz.lt.yfov) then + yfov = ysiz + ky = k + endif + 100 continue + xfov = 200.0d0*xfov + yfov = 200.0d0*yfov + return + end +c-------------------------------------------------------------- + subroutine genray(wx,wy,lunz,npos,dx,dy,nang,dxp,dyp) +c +c generates matched ray initial conditions for a map +c and a set of scattered rays +c C. T. Mottershead LANL AOT-1 16 April 1996 +c------------------------------------------------------- + use rays + implicit double precision (a-h,o-z) + logical ltbl + include 'parset.inc' + dimension pp(6) + write(6,*) igen,' = igen, wx,wy=', wx,wy + zero = 0.0d0 + ltbl = .false. + if(lunz.gt.0) ltbl = .true. + do 10 j = 1,6 + pp(j) = zero + 10 continue + nn = 0 + do 100 i = 1, npos + fi = npos - i + 1 + x = fi*dx + xpref = x*wx + y = fi*dy + ypref = y*wy + pp(1) = x + pp(3) = y +c +c positive scattering angles +c + if(nang.ge.1) then + do 50 j = 1, nang + fj = nang - j + 1 + pp(2) = xpref + fj*dxp + pp(4) = ypref + fj*dyp + if(ltbl) write(lunz,57) pp + nn = nn + 1 + do 40 k = 1, 6 + zblock(nn,k) = pp(k) + 40 continue + 50 continue + endif +c +c central matched ray +c + pp(2) = xpref + pp(4) = ypref + if(ltbl) write(lunz,57) pp + nn = nn + 1 + do 60 k = 1, 6 + zblock(nn,k) = pp(k) + 60 continue + 57 format(1x,4(1pe13.5),2(1pe12.4)) +c +c negative scattering angles +c + if(nang.ge.1) then + do 80 j = 1, nang + fj = j + pp(2) = xpref - fj*dxp + pp(4) = ypref - fj*dyp + if(ltbl) write(lunz,57) pp + nn = nn + 1 + do 70 k = 1, 6 + zblock(nn,k) = pp(k) + 70 continue + 80 continue + endif + 100 continue +c +c on axis rays +c + pp(1) = zero + pp(3) = zero + if(nang.ge.1) then + do 120 j = 1, nang + fj = nang - j + 1 + pp(2) = fj*dxp + pp(4) = fj*dyp + if(ltbl) write(lunz,57) pp + nn = nn + 1 + do 110 k = 1, 6 + zblock(nn,k) = pp(k) + 110 continue + 120 continue + endif + pp(2) = zero + pp(4) = zero + if(ltbl) write(lunz,57) pp + nn = nn + 1 + do 140 k = 1, 6 + zblock(nn,k) = pp(k) + 140 continue + nrays = nn + write(6,147) npos,nang,nrays + 147 format(' #GENRAY:',i6,' positions',i6,' angles',i6,' rays') + return + end +c +*********************************************************************** +c + subroutine headoc(lun,title) +c +c writes LaTeX document header to LUN from fortran programs. +c +c T. Mottershead AT-3 16 Jan 91 +c-------------------------------------------------- + character title*(*) +c +c Write Document opening +c + write(lun,*) ' \documentstyle[12pt]{article} ' + write(lun,*) ' \setlength{\textwidth}{6.5in}' + write(lun,*) ' \setlength{\oddsidemargin}{0in} ' + write(lun,*) ' \setlength{\topmargin}{-0.5in}' + write(lun,*) ' \setlength{\textheight}{9in} \pagestyle{empty}' + write(lun,*) ' \begin{document}' + write(lun,*) ' ' + write(lun,*) ' {\large ' + write(lun,14) title + 14 format(' \begin{center} {\bf ',a,' } \\ + & \today \end{center} }') + return + end +c*************************************************************** + subroutine kinema(bmass,ener,pmom) + use beamdata + implicit double precision (a-h,o-z) +cryne 7/23/2002 common/parm/brho,c,gamma,gamm1,beta,charge,sl,ts,pbeam + two = 2.0d0 + light = 299792458 + fmev = 1.0d-6*float(light) + pmom = fmev*brho + gambet = dsqrt(gamm1*(gamm1+two)) + bmass = pmom/gambet + ener = gamm1*bmass + return + end +c----------------------------------------------------------------- + subroutine listyp(lun) +c +c listyp lists the type codes in the current vesion of marylie +c T. Mottershead LANL AT-3 17 Jan 91 +c------------------------------------------------- + include 'codes.inc' + character*8 tcode(9), word + dimension numcmd(9), nord(9), jlo(2),jhi(2) + data nord /1,4,7,8,9,2,3,5,6/ + save nord !cryne 7/23/2002 + jlo(1)=1 + jhi(1)=5 + jlo(2)=6 + jhi(2)=9 +c +c scan for null string to indicate number of commands +c + ntot = 0 + do 20 j = 1, 9 + max = 0 + do 10 n=1,40 + word = ltc(j,n) + if(ichar(word(1:1)).eq.0) go to 15 + max = max + 1 + 10 continue + 15 numcmd(j) = max + ntot = ntot + max + 20 continue +c +c report total +c + write(lun,*) ' Marylie Type Codes ' + write(lun,*) + write(lun,*) ntot,' type codes in this version' +c +c writeout +c + do 90 kk = 1,2 + jmin = jlo(kk) + jmax = jhi(kk) + nmax = 0 + do 30 j=jmin, jmax + mm = numcmd(nord(j)) + if(mm.gt.nmax) nmax = mm + 30 continue + write(lun,*) + write(lun,33) (nord(k),k=jmin,jmax) + 33 format(' index ',2x,5('nrp (G',i1,')',4x)) + do 50 n = 1 ,nmax + do 40 j=jmin, jmax + tcode(j) = ' ' + jju = nord(j) + if(n.le.numcmd(jju)) tcode(j) = ltc(jju,n) + 40 continue + write(lun,43) n,(nrp(nord(j),n), tcode(j), j=jmin,jmax) + 43 format(i4,5x,5(i2,2x,a8)) + 50 continue + write(lun,31) (numcmd(nord(j)), j=jmin, jmax) + 31 format(' total:',i8,4i12) + 90 continue + return + end +c +c******************************************************* + subroutine mlfov(wx,wy,aper,phiref,philim,lunf,ufov,kfov) + implicit double precision (a-h,o-z) + dimension ufov(*),kfov(*) + parameter (maxz=2000) + common/csrays/jp,mode,cx(maxz),sx(maxz),cy(maxz),sy(maxz) + & ,z(maxz) + logical ltbl, last +c + write(6,*)'WARNING (mlfov): this routine has a different' + write(6,*)'declaration for common/csrays/ than in sincos.inc' + write(6,*)'Rob Ryne 7/23/2002' +c +c write(99,*) ' MLFOV call:',jp,aper,philim,phiref,lunf + ltbl = .false. + last = .false. + if(lunf.gt.0) ltbl = .true. +c +c scan given sin/cosine rays for extrema +c +c type *, jp,'=jp in mlfov (length of S/C buffer)' + sxmax = 0.0d0 + cxlo = 1.0d30 + cxhi = -cxlo + symax = 0.0d0 + cylo = 1.0d30 + cyhi = -cylo + do 50 k = 1,jp + cc = cx(k) + ss = sx(k) + xmat = cc + wx*ss + if(xmat.gt.cxhi) cxhi = xmat + if(xmat.lt.cxlo) cxlo = xmat + sab = dabs(ss) + if(sab.gt.sxmax) sxmax = sab + cc = cy(k) + ss = sy(k) + ymat = cc + wy*ss + if(ymat.gt.cyhi) cyhi = ymat + if(ymat.lt.cylo) cylo = ymat + sab = dabs(ss) + if(sab.gt.symax) symax = sab + 50 continue +c type *, ' C+wS:',cxlo,cxhi,cylo,cyhi +c +c solve for envelope max +c + pxm = 1000.0d0*aper/sxmax + pym = 1000.0d0*aper/symax + if(ltbl) write(lunf,73) sxmax,symax, pxm, pym + 73 format(' Max S: ',2f13.5,' Max-phi(mR):',2f10.3) + phi = 0.0d0 + phimax = pxm + if(ltbl) write(lunf,506) + 506 format(' phi(mR) xfov yfov kx ky', + & 6x,'ysize+/-',10x,'xsize+/-') +c +c scan for FOV at the reference angle +c + xrefov = 0.0d0 + yrefov = 0.0d0 + if(phiref.lt.phimax) then + theta = 1.0d-3*phiref + call fvscan(wx,wy,aper,theta,xrefov,yrefov,kx,ky) + endif +c +c initialize search over all angles +c + kf = 0 + kx = 0 + ky = 0 + dphi = 0.05 + theta = 0.0d0 + eps = 1.0d-12 + 510 continue + kf = kf+1 + kxo = kx + kyo = ky + call fvscan(wx,wy,aper,theta,xfov,yfov,kx,ky) +c +c check size of other axis ellipse at limit points (kx,ky) +c + dyx = cy(kx) + wy*sy(kx) + if(dabs(dyx).lt.eps) dyx = eps + ayxm = 100.0d0*(aper - sy(kx)*theta)/dyx + ayxp = 100.0d0*(aper + sy(kx)*theta)/dyx + dxy = cx(ky) + wx*sx(ky) + if(dabs(dxy).lt.eps) dxy = eps + axym = 100.0d0*(aper - sx(ky)*theta)/dxy + axyp = 100.0d0*(aper + sx(ky)*theta)/dxy + phi = 1000.0d0*theta + ango = ang + xapo = xap + ang = phi + xap = xfov + if(ltbl) write(lunf,107) phi,xfov,yfov,kx,ky + & ,ayxm,ayxp,axym,axyp + 107 format(f7.2,2f9.4,2i5,4f9.3) + if(kf.eq.1) xzero = xfov + if((iabs(kxo-kx).gt.80).and.(iabs(ky-kyo).gt.80)) then + xfb = xapo + phib = ango + kxb = kx + kyb = ky + endif + if(last) then + radphi = phib/philim + bratio = zrad(radphi) + rmax = phimax/philim + radmax = zrad(rmax) +c type *, 'break ratios: phi,z ',phi, radphi, bratio +c type *, 'endpoint ratios: phi,z ',phimax,rmax,radmax + pipe = 200.0d0*aper + ufov(1) = pipe + ufov(2) = xzero + ufov(3) = xfb + ufov(4) = phib + ufov(5) = phimax + ufov(6) = bratio + ufov(7) = radmax + ufov(8) = sxmax + ufov(9) = symax + ufov(10)= pym + ufov(11)= xrefov + ufov(12)= yrefov + kfov(1) = kxb + kfov(2) = kyb + endif + phi = phi + dphi + theta = 1.0d-3*phi + if(last) return + if(phi.lt.phimax) go to 510 + phi = phimax + theta = 1.0d-3*phi + last = .true. + go to 510 + end +c-------------------------------------------------------------- + subroutine rmquad(zlen,grad,rm) +c +c computes matrix rm for a quadrupole of length zlen meters +c and with field gradient of grad tesla/meter +c if grad>0, the quad is horizontally focusing, vertically defocusin +c if grad<0, the quad is vertically focusing, horizontally defocusin +c If grad=0, it is simply a drift. +c T. Mottershead LANL AT-3, 10/89, copied from MARYLIE routines +c FQUAD and DQUAD by D. Douglas, 1982. +c------------------------------------------------------------------ + use beamdata + implicit double precision (a-h,o-z) +c +c beam and kinematic constants: +cryne 7/23/2002 common/parm/brho,c,gamma,gamm1,beta,achg,sl,ts + double precision rm(6,6) +c +c initialize rm to the identitiy matrix +c + do 40 i=1,6 + do 20 j=1,6 + rm(i,j)=0.0 + 20 continue + rm(i,i)=+1.0d0 + 40 continue +c +c add drift terms to rm +c + rm(1,2)= zlen + rm(3,4)= zlen + rm(5,6)= zlen/(gamma*beta)**2 +c +c drift return +c + if(grad.eq.0.0) return +c +c positive quad (horizontally focusing) +c + square = grad/brho + if(square.gt.0.0) then + ifp = 1 + jfp = 2 + idp = 3 + jdp = 4 + endif +c +c negative quad (horizontally defocusing) +c + if(square.lt.0.0) then + idp = 1 + jdp = 2 + ifp = 3 + jfp = 4 + square = -square + endif +c +c coefficients for transverse rm +c + wavek=dsqrt(square) + zk=zlen*wavek + coshkz=(dexp(zk)+dexp(-zk))/(2.0d0) + sinhkz=(dexp(zk)-dexp(-zk))/(2.0d0) + coskz=dcos(zk) + sinkz=dsin(zk) +c +c matrix in the focusing plane +c + rm(ifp,ifp) = coskz + rm(ifp,jfp) = sinkz/wavek + rm(jfp,jfp) = coskz + rm(jfp,ifp) = -wavek*sinkz +c +c matrix in the defocusing plane +c + rm(idp,idp) = coshkz + rm(idp,jdp) = sinhkz/wavek + rm(jdp,jdp) = coshkz + rm(jdp,idp) = wavek*sinhkz + return + end +c +*********************************************************************** +c + subroutine setcor(kor,wx,wy) + use lieaparam, only : monoms + include 'impli.inc' + include 'taylor.inc' + include 'map.inc' + include 'parset.inc' + include 'usrdat.inc' + zero = 0.0d0 + two = 2.0d0 +c +c No corr: Straight in +c + if(kor.eq.0) then + wx = zero + wy = zero + endif +c +c Fourier corr +c + if(kor.eq.1) then + wx = -tmh(1,1)/tmh(1,2) + wy = -tmh(3,3)/tmh(3,4) + endif +c +c Chromatic corr for identity lens +c + if(kor.eq.2) then + wx = -th(38)/(two*th(53)) + wy = -th(70)/(two*th(76)) + endif +c +c Chromatic corr in general from Taylor map +c + if(kor.eq.3) then + wx = -tumat(12,1)/tumat(17,1) + wy = -tumat(21,3)/tumat(24,3) + endif +c +c general correlation from ucalc(N) and N+1 +c + if(kor.lt.0) then + nc = -kor + if(nc.gt.250) return + wx = ucalc(nc) + wy = ucalc(nc+1) + endif + return + end +c========================================== + subroutine tabdef(lun,ncol) +c +c writes LaTeX table headers to LUN from fortran programs. +c T. Mottershead AT-3 16 Jan 91 +c-------------------------------------------------- + write(lun,*) ' \begin{center}' + write(lun,*) ' \begin{tabular}{',('|c',j=1,ncol),'|}' + write(lun,*) ' \hline' + return + end +c*************************************************************** + subroutine tabend(lun) +c +c writes LaTeX table end to LUN from fortran programs. +c T. Mottershead AT-3 16 Jan 91 +c-------------------------------------------------- + write(lun,*) ' \hline \end{tabular} \end{center}' + return + end +c*************************************************************** + subroutine tugen(fa,fm) +c pcmap routine to print m,f3,f4 and t,u. +c Written by D. Douglas ca 1982 and modified by Rob Ryne +c and Alex Dragt ca 1986 +ctm modified to just generate the taylor map in 'taylor.inc' +c + use lieaparam, only : monoms + include 'impli.inc' + include 'files.inc' + include 'expon.inc' + include 'pbkh.inc' + include 'taylor.inc' +c + dimension fa(monoms),fm(6,6),fsav(monoms) + dimension t(monoms),u(monoms),u2(monoms) + write(6,*)'inside routine tugen' +c +c prepare for higher order matrix generation +c + do 10 jj = 1, monoms + fsav(jj) = fa(jj) + 10 continue + call brkts(fa) +c +c procedure for generating t-matrix +c + do 35 i=1,6 + call xform(pbh(1,i),2,fm,i-1,t) + do 36 n=7,27 + tumat(n,i) = t(n) + 36 continue + 35 continue +c +c procedure for generating U-matrix +c + do 44 i=1,6 + call xform(pbh(1,i),3,fm,i-1,u) + call xform(pbh(1,i+6),3,fm,1,u2) + do 45 n=28,83 + u(n)=u(n)+u2(n)/2.d0 + tumat(n,i) = u(n) + 45 continue + 44 continue + return + end +c +c------------------------------------------------------ +c + subroutine u8out(lun,level) + use lieaparam, only : monoms + include 'impli.inc' + include 'usrdat.inc' + include 'sigbuf.inc' + character*3 tag + write(lun,21) + 21 format(/' Output beam parameters:',/,' x=u(1) ', + &' alfx=u(2) px=u(3) y=u(4) alfy=u(5) ', + &' py=u(6) ') + write(lun,25) (ucalc(j), j=1,6) + 25 format(6(1pe13.5)) + write(lun,22) + 22 format(6x,'beta',15x,'emittance',10x,'focus',14x,'cross-focus') + tag = ' X:' + write(lun,24) tag, (j,ucalc(j),j=7,10) + 24 format(a3,i3,'>',1pe14.7,3(i4,'>',1pe14.7)) + tag = ' Y:' + write(lun,24) tag, (j,ucalc(j),j=11,14) + if(level.lt.1) return +c +c also write aberration coefficients for level 1 +c + write(lun,27) + 27 format(/,' Chromatic and RMS Geometric Aberration Coefficients:', + &/,' dFx/dp=u(15) dFy/dp=u(16) K2(R/m^2)=u(17)', + &' K3(R/m^3)=u(18)') + write(lun,29) (ucalc(j),j=15,18) + 29 format(4(1pg18.7)) + if(level.lt.2) return +c +c also write dsigma/de for level 2 +c + write(lun,23) + 23 format(/' Energy dependence of sigma matrix:',/,' ds11=u(21)', + &' ds12=u(22) ds22=u(23) ds33=u(24) ds34=u(25)', + &' ds44=u(26)') + write(lun,25) (ucalc(j),j=21,26) +c write(lun,*) ' Sigma matrix:' +c do 201 i=1,4 +c write(lun,26) (sigf(i,j),j=1,4) +c 201 continue +c 26 format(3x,4(1pe15.7)) +c write(lun,*) ' Energy derivative of Sigma matrix:' +c do 202 i=1,4 +c write(lun,26) (dsig(i,j),j=1,4) +c 202 continue + return + end +c +*********************************************************************** +c + subroutine zmono(nopt,zz,zvec) + use lieaparam, only : monoms + include 'impli.inc' + include 'expon.inc' + include 'vblist.inc' + dimension zz(6) +cryne August 4, 2004 +cryne setting the following to 209 to reproduce old results. +cryne Extend later to 5th order +c dimension zvec(monoms) + dimension zvec(209) + write(6,*)'inside routine zmono' +c +c do 20 n = 1, monoms +c j = 1 +c kode = expon(j,n) +c 18 continue +c j = j + 1 +c kode = 10*kode + expon(j,n) +c if(j.lt.6) go to 18 +c write(89,19) n,kode,(expon(j,n),j=1,6),(vblist(k,n),k=1,4) +c 19 format(2i8,2x,6i2,' vb:',4i2) +c 20 continue + one = 1.0d0 + nord = 2 +cryne August 4, 2004 +cryne setting the following to 209 to reproduce old results. +cryne Extend later to 5th order +c do 100 n = 1, monoms + do 100 n = 1, 209 + if(n.eq.28) nord = 3 + if(n.eq.84) nord = 4 + prod = one + do 50 j = 1,nord + prod = prod*zz(vblist(j,n)) + 50 continue + zvec(n) = prod + 100 continue + return + end + double precision function zrad(radphi) + implicit double precision (a-h,o-z) + common/iters/it + zero = 0.0d0 + if(radphi.le.zero) then + zrad = zero + return + endif + tol = 1.0d-9 + derr = 1.0d9 + one = 1.0d0 + two = 2.0d0 + bb = 9.0d0*dlog(10.0d0) + aa = one/bb + bb = bb/two +c type *, ' aa=',aa,' bb=',bb + maxit=50 + y = radphi**2 + zest = y + do 80 j=1,maxit + it = j + vv = one+aa*dlog(zest) + yc = zest*(vv)**2 + err = yc-y +c type *,j,zest,err + errold = derr + derr = dabs(err) + if(derr.lt.tol) then + if(derr.ge.errold) go to 100 + endif + zest = (vv*zest+bb*y)/(vv*(one+bb*vv)) + 80 continue + 100 zrad = zest + return + end +c----------------------------------------------- + subroutine trcdmp(ltran,ltrace) + use beamdata + include 'impli.inc' + include 'linbuf.inc' + include 'actpar.inc' + include 'sigbuf.inc' + include 'usrdat.inc' + ntrc = ltrace-1 + write(ltran,*) '$data' + do 500 nn = nbgn, nend + nnu = nn + ntrc + tlong = 1000.0*elong(nn) +c +c drift +c + if(lintyp(nn).eq.0) then + ityp = 1 + write(ltran,488) nnu,cname(nn),nnu,ityp,nnu,tlong + endif +c +c quad +c + if(lintyp(nn).eq.1) then + ityp = 3 + write(ltran,488) nnu,cname(nn),nnu,ityp,nnu,strong(nn),tlong + endif + 488 format(1x,'cmt(',i3,')=''',a,''' nt(',i3,')=',i3,', a(1,',i3 + & ,')=',2(1pg17.9,',')) + 500 continue + write(ltran,*) '$end' + return + end +ccccccccccccccc++++++++++++++++++++++++++++c + subroutine adump(ldump) + use beamdata + include 'impli.inc' + include 'linbuf.inc' + include 'actpar.inc' + include 'sigbuf.inc' +c write(ldump,*) ' Beam:', beta, gamm1, brho +c write(ldump,*) ' Xsig:', xxin, axin, pxin +c write(ldump,*) ' Ysig:', yyin, ayin, pyin +c write(ldump,*) ' Zsig:', zzin, azin, pzin + write(ldump,*) beta, gamm1, brho + write(ldump,*) xxin, axin, pxin + write(ldump,*) yyin, ayin, pyin + write(ldump,*) zzin, azin, pzin + do 700 nn = nbgn, nend + write(ldump,617) cname(nn),nn,lintyp(nn),mltyp1(nn),mltyp2(nn), + & radius(nn), elong(nn), strong(nn) + 617 format(2x,a8,i4,3i3,2f12.7,1pg24.16) + 700 continue + return + end +c-------------------------- + subroutine trnspt(ltran) + return + end + subroutine madump(ltran) + return + end diff --git a/OpticsJan2020/MLI_light_optics/Src/wakefld.f b/OpticsJan2020/MLI_light_optics/Src/wakefld.f new file mode 100644 index 0000000..28363e3 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/wakefld.f @@ -0,0 +1,1732 @@ +! wakefld.f +! +! Contains subroutines for computing wakefield forces +! written by Roman Samulyak (BNL), July 2002 +! rosamu@bnl.gov, (631) 344-3304 +! +!*********************************************************************** + module wakefld_params + double precision :: z0 = 377.0 ! Free space impedance + + character*8 :: wktype !Wakefield type + +! Global defaults + integer :: gnmodes !Number of modes + integer :: nturns !Number of turns for collecting + !wakefield forces (long range wakes) + double precision :: gcond !Conductivity + double precision :: gradius !Average radius of chamber elements + + +! elements creating wake fields + + type WKFLD_WALL + double precision :: length + double precision :: conduct + double precision :: radius + integer :: nmodes + end type WKFLD_WALL + + type WKFLD_RLC + double precision, dimension(6) :: res_fr + double precision, dimension(6) :: r_shunt + double precision, dimension(6) :: quality + integer :: nmodes + end type WKFLD_RLC + + type WKFLD_PILLBOX + double precision, dimension(3) :: length + double precision, dimension(3) :: depth + double precision, dimension(3) :: radius + integer :: nmodes + end type WKFLD_PILLBOX + + type WKFLD_DATAFILE + character*31 :: fname + integer :: nmodes + end type WKFLD_DATAFILE + + type(WKFLD_WALL), dimension(100) :: rwall_param + type(WKFLD_RLC), dimension(100) :: rlc_param + type(WKFLD_PILLBOX), dimension(100) :: pbx_param + type(WKFLD_DATAFILE), dimension(100) :: file_param + + integer :: nrwall = 0 ! Order number of rwall element model + integer :: nrlc = 0 ! Order number of rlc element model + integer :: npbx = 0 ! Order number of pbx element model + integer :: nfile = 0 ! Order number of datafile element + + integer :: ncurel = 0 ! Order number of the current wakefield +! element in the ring + integer :: nwkel = 0 ! total number of wakefield el. in the list + character*8, dimension(500) :: wk_el_list ! contains element names + integer, dimension(500,3) :: wkfld_work +! wkfld_work(i,j) : +! i = element # in the list of elements creating wakes +! wkfld_work(i,1) : model # for ith elemnt: +! 0 = read wake function data from file +! 1 = res. wall +! 2 = rlc resonator +! 3 = pbx model +! 4 = +! wkfld_work(i,2) : element # in this group of elements +! wkfld_work(i,3) : # of modes for this el. + + +! variables used for the beam moments calculation + double precision, dimension(:,:), allocatable :: moments + double precision, dimension(:,:,:), allocatable :: density + type LOCAL_COORD + double precision :: x + integer :: k + integer :: nn ! entry # in the moments array + end type LOCAL_COORD + type(LOCAL_COORD) :: lcoord + + type WKGRID + integer :: nx,ny,nz ! the number of nodes. +! users should enter number of mesh cells (2^n numbers) +! number of nodes = number of mesh cells + 1 + double precision :: hx,hy,hz + double precision :: xmin,xmax,ymin,ymax,zmin,zmax + integer :: ndx,ndy ! number of subdomains in x and y directions + end type WKGRID + type(WKGRID) :: grid + +! variables used for wake field force calculation + double precision, dimension(:,:,:), allocatable :: wkfx,wkfy,wkfz + double precision,dimension(:,:,:),allocatable::lwkfx,lwkfy,lwkfz + +! an array for tabulated wake function values + double precision, dimension(:,:), allocatable :: wkfunc_table + +! temp arrays needed to deposit particles on the grid and interp. fields + double precision, dimension(:,:), allocatable :: p_data + integer, dimension(:), allocatable :: indx,jndx,kndx + integer, dimension(:), allocatable :: indxp1,jndxp1,kndxp1 + double precision, dimension(:), allocatable :: ab,de,gh + logical, dimension(:), allocatable :: msk + integer :: flg + + save + + end module wakefld_params + +!*********************************************************************** + + subroutine wake_defaults(line) + + use wakefld_params, only: wktype,gnmodes,nturns,gradius,gcond,grid + use parallel, only : nvp,idproc !cryne + + character*80 :: line + character*16 :: cbuf + logical keypres, numpres + double precision, dimension(1) :: bufr + integer :: mmax + mmax=80 + + call getparm(line,mmax,'type=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + wktype=cbuf + endif + + call getparm(line,mmax,'nmodes=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + gnmodes=int(bufr(1)) + endif + + call getparm(line,mmax,'nturns=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + nturns=int(bufr(1)) + endif + + call getparm(line,mmax,'r=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + gradius=bufr(1) + endif + + call getparm(line,mmax,'conduct=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + gcond=bufr(1) + endif +! another name + call getparm(line,mmax,'cond=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + gcond=bufr(1) + endif + +! new line containinf wakefield grid parameters + call readin(line,leof) + + call getparm(line,mmax,'nx=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + grid%nx=int(bufr(1))+1 + endif + + call getparm(line,mmax,'ny=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + grid%ny=int(bufr(1))+1 + endif + + call getparm(line,mmax,'nz=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + grid%nz=int(bufr(1))+1 + endif + + call getparm(line,mmax,'ndx=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + grid%ndx=int(bufr(1)) + endif + + call getparm(line,mmax,'ndy=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + grid%ndy=int(bufr(1)) + endif +!cryne--- + if(grid%ndx*grid%ndy.ne.nvp)then + if(idproc.eq.0)then + write(6,*)'ERROR (in wake_defaults) : ndx*ndy .ne. nvp' + write(6,*)'ndx, ndy, nvp = ',grid%ndx,grid%ndy,nvp + write(6,*)'Halting.' + endif + call myexit + endif +!cryne--- + + return + end subroutine wake_defaults + +!*********************************************************************** + + subroutine wake_init(cbufin) + + use wakefld_params + use acceldata + include 'files.inc' + + character*16 :: cbufin, cbuf + integer :: mmax, i + double precision, dimension(1) :: bufr + logical keypres, numpres, leof + character*80 :: line + double precision :: l,r,sigma + mmax=80 + nwkel=nwkel+1 + + if ((cbufin.eq.'rwall').or.(cbufin.eq.'res_wall')) then + go to 110 + elseif (cbufin.eq.'rlc') then + go to 120 + elseif ((cbufin.eq.'pillbox').or.(cbufin.eq.'pbx')) then + go to 130 + elseif ((cbufin.eq.'datafile').or.(cbufin.eq.'file')) then + go to 140 + else + write(6,*)'Wakefield model',cbufin,'is not supported' + call myexit + endif + +!*** res_wall +! Input format: +! wakedata: nmodes= l= r= conduct= + + 110 nrwall = nrwall+1 + backspace lf +! Defaults: + call readin(line,leof) + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + rwall_param(nrwall)%length=bufr(1) + endif + rwall_param(nrwall)%nmodes = gnmodes + rwall_param(nrwall)%radius = gradius + rwall_param(nrwall)%conduct = gcond + + wk_el_list(nwkel) = lmnlbl(na) + wkfld_work(nwkel,1) = 1 + wkfld_work(nwkel,2) = nrwall + wkfld_work(nwkel,3) = gnmodes + +! End defaults + + call readin(line,leof) + if(line(1:9) .ne. 'wakedata:')then + write(6,*)'No user specified wakefield data. Using defaults' + backspace lf + return + endif + + call getparm(line,mmax,'nmodes=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + rwall_param(nrwall)%nmodes=int(bufr(1)) + endif + + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + rwall_param(nrwall)%length=bufr(1) + endif + + call getparm(line,mmax,'r=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + rwall_param(nrwall)%radius=bufr(1) + endif + + call getparm(line,mmax,'conduct=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + rwall_param(nrwall)%conduct=bufr(1) + endif + + wkfld_work(nwkel,3) = rwall_param(nrwall)%nmodes + + if (ibrief.eq.2) then + write(6,*)'\n Initialized parameters for rwall:' + write(6,*)'nrwall = ',nrwall + write(6,*)'nmodes = ',rwall_param(nrwall)%nmodes + write(6,*)'l = ',rwall_param(nrwall)%length + write(6,*)'r = ',rwall_param(nrwall)%radius + write(6,*)'conduct = ',rwall_param(nrwall)%conduct,'\n' + endif + return + +!*** rlc +! Input format: +! wakedata: nmodes= +! mode0: fr= q= r= +! mode1: fr= q= r= +! ............ +! the word 'mode' is optional + + 120 nrlc = nrlc + 1 + call readin(line,leof) + if(line(1:9) .ne. 'wakedata:')then + write(6,*)'\n Error:' + write(6,*)'There are no defaults for rlc wakefield model.' + write(6,*)'Please enter wakefield model data: ' + write(6,*)'the number of modes and the resonant frequency, ' + write(6,*)'shunt impedance, and quality factor for each mode' + write(6,*)'in the following format' + write(6,*)'wakedata: nmodes= ' + write(6,*)'mode0: fr= q= r=' + write(6,*)'mode1: fr= q= r=' + write(6,*)' ............\n' + call myexit + return + endif + +! If there is wake data, get the number of modes + call getparm(line,mmax,'nmodes=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + rlc_param(nrlc)%nmodes=int(bufr(1)) + endif + +! Get parameters for each mode + do i=1,rlc_param(nrlc)%nmodes + call readin(line,leof) + + call getparm(line,mmax,'fr=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + rlc_param(nrlc)%res_fr(i)=bufr(1) + endif + + call getparm(line,mmax,'r=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + rlc_param(nrlc)%r_shunt(i)=bufr(1) + endif + + call getparm(line,mmax,'q=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + rlc_param(nrlc)%quality(i)=bufr(1) + endif + enddo + + wk_el_list(nwkel) = lmnlbl(na) + wkfld_work(nwkel,1) = 2 + wkfld_work(nwkel,2) = nrlc + wkfld_work(nwkel,3) = rlc_param(nrlc)%nmodes + + if (ibrief.eq.2) then + write(6,*)'\n Initialized parameters for rlc:' + write(6,*)'nrlc = ',nrlc, 'nmodes = ',rlc_param(nrlc)%nmodes + write(6,*)'fr = ',rlc_param(nrlc)%res_fr(1:rlc_param(nrlc)%nmodes) + write(6,*)'R = ',rlc_param(nrlc)%r_shunt(1:rlc_param(nrlc)%nmodes) + write(6,*)'Q = ',rlc_param(nrlc)%quality(1:rlc_param(nrlc)%nmodes) + write(6,*)'\n' + endif + return + +!*** pillbox +! Input format: +! wakedata: nmodes= +! mode0: l= h= r= +! mode1: l= h= r= +! ............ +! the word 'mode' is optional + + 130 npbx = npbx + 1 + call readin(line,leof) + if(line(1:9) .ne. 'wakedata:')then + write(6,*)'\n Error:' + write(6,*)'There are no defaults for pillbox wakefield model.' + write(6,*)'Please enter wakefield model data: ' + write(6,*)'the number of modes and the length, depth,' + write(6,*)'and radius for each mode in the following format' + write(6,*)'wakedata: nmodes= ' + write(6,*)'mode0: l= h= r= ' + write(6,*)'mode1: l= h= r= ' + write(6,*)' ............\n' + call myexit + return + endif + +! If there is wake data, get the number of modes + call getparm(line,mmax,'nmodes=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pbx_param(npbx)%nmodes=int(bufr(1)) + endif + +! Get parameters for each mode + do i=1,pbx_param(npbx)%nmodes + call readin(line,leof) + call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pbx_param(npbx)%length(i)=bufr(1) + endif + + call getparm(line,mmax,'r=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pbx_param(npbx)%radius(i)=bufr(1) + endif + + call getparm(line,mmax,'h=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + pbx_param(npbx)%depth(i)=bufr(1) + endif + enddo + + wk_el_list(nwkel) = lmnlbl(na) + wkfld_work(nwkel,1) = 3 + wkfld_work(nwkel,2) = npbx + wkfld_work(nwkel,3) = pbx_param(npbx)%nmodes + + if (ibrief.eq.2) then + write(6,*)'\n Initialized parameters for pillbox:' + write(6,*)'npbx = ',npbx, 'nmodes = ',pbx_param(npbx)%nmodes + write(6,*)'l = ',pbx_param(npbx)%length(1:pbx_param(npbx)%nmodes) + write(6,*)'r = ',pbx_param(npbx)%radius(1:pbx_param(npbx)%nmodes) + write(6,*)'h = ',pbx_param(npbx)%depth(1:pbx_param(npbx)%nmodes) + write(6,*)'\n' + endif + + return + +!*** datafile +! Input format: +! wakedata: file=file_name nmodes=number_of_modes + + 140 nfile = nfile + 1 + call readin(line,leof) + if(line(1:9) .ne. 'wakedata:')then + write(6,*)'\n Error:' + write(6,*)'There are no defaults for tabulated wakefield data.' + write(6,*)'Please enter the file name and the number of modes' + write(6,*)'in the following format' + write(6,*)'wakedata: file=file_name nmodes=number_of_modes\n' + call myexit + return + endif +! If there is wake data, get parameters + call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) + if(keypres.and.numpres)then + file_param(nfile)%fname=cbuf + endif + + call getparm(line,mmax,'nmodes=',bufr,keypres,numpres,0,cbuf) + if(keypres.and.numpres)then + file_param(nfile)%nmodes=int(bufr(1)) + endif + + wk_el_list(nwkel) = lmnlbl(na) + wkfld_work(nwkel,1) = 0 + wkfld_work(nwkel,2) = nfile + wkfld_work(nwkel,3) = file_param(nfile)%nmodes + + if (ibrief.eq.2) then + write(6,*)'\nInitialized parameters for tabulated wakefield data:' + write(6,*)'nfile = ',nfile + write(6,*)'file name = ',file_param(nfile)%fname + write(6,*)'nmodes = ',file_param(nfile)%nmodes,'\n' + endif + + return + + end subroutine wake_init + + +!*********************************************************************** + + subroutine wkfld_srange(nslices,elname,tau) + + use wakefld_params, only: wktype,ncurel,nwkel,wk_el_list + + integer :: nslices, i + character*8 :: elname + double precision :: tau + + if (wktype.ne.'short') return + +! Identify the current element + do ncurel=1,nwkel + if (elname .eq. wk_el_list(ncurel)) exit + enddo + + call initialize_wk_structures + call compute_beam_moments + call compute_wk_forces + call apply_wk_forces(tau) + call free_wk_structures + + end subroutine wkfld_srange + +!*********************************************************************** + + subroutine initialize_wk_structures + + use wakefld_params + use rays, only : nraysp,maxrayp + + implicit double precision(a-h,o-z) + integer :: nx,ny,nz,nmodes,j +! common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0,nspchset + + nx = grid%nx + ny = grid%ny + nz = grid%nz + + allocate(density(nx,ny,nz)) + allocate(p_data(6,nraysp)) + + nmodes = wkfld_work(ncurel,3) + allocate(moments(nz,2*nmodes+1)) + + allocate(wkfx(nx,ny,nz)) + allocate(wkfy(nx,ny,nz)) + allocate(wkfz(nx,ny,nz)) + + allocate(indx(nraysp)) + allocate(jndx(nraysp)) + allocate(kndx(nraysp)) + allocate(indxp1(nraysp)) + allocate(jndxp1(nraysp)) + allocate(kndxp1(nraysp)) + allocate(ab(nraysp)) + allocate(de(nraysp)) + allocate(gh(nraysp)) + allocate(msk(maxrayp)) + + end subroutine initialize_wk_structures + +!*********************************************************************** + + subroutine free_wk_structures + + use wakefld_params + + deallocate(density) + deallocate(moments) + deallocate(p_data) + deallocate(wkfx) + deallocate(wkfy) + deallocate(wkfz) + + deallocate(indx) + deallocate(jndx) + deallocate(kndx) + deallocate(indxp1) + deallocate(jndxp1) + deallocate(kndxp1) + deallocate(ab) + deallocate(de) + deallocate(gh) + deallocate(msk) + + end subroutine free_wk_structures + +!*********************************************************************** + + subroutine wkfld_lrange + + use wakefld_params + + if (wktype.ne.'long') return + + end subroutine wkfld_lrange + +!*********************************************************************** +! INTEGRATOR + + subroutine compute_beam_moments + + use wakefld_params + use rays, only : zblock,nraysp,maxrayp + use beamdata + use parallel + + double precision,dimension(:,:,:), allocatable :: dens_local + double precision, dimension(:,:), allocatable :: mom_local + integer :: i,j,nx,ny,nz,nmodes,nz_start,nz_end,n_zone,noresize + double precision :: ss,bbyk,gblam + double precision :: xmin,xmax,ymin,ymax,zmin,zmax + double precision :: hx,hy,hz,hxi,hyi,hzi + double precision :: toopi,c5j,ac5j + + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi +! common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0,nspchset + + external ysimpsonint + + nmodes = wkfld_work(ncurel,3) + nx = grid%nx + ny = grid%ny + nz = grid%nz + + allocate(dens_local(nx,ny,nz)) + allocate(mom_local(nz,2*nmodes+1)) + + bbyk = gamma*beta*c/omegascl + gblam = gamma*beta*c/bfreq + + noresize = 1 + + do j = 1,nraysp + p_data(1,j) = zblock(1,j) + p_data(2,j) = zblock(2,j) + p_data(3,j) = zblock(3,j) + p_data(4,j) = zblock(4,j) + p_data(5,j) = zblock(5,j) + p_data(6,j) = zblock(6,j) + enddo + +! if(nadj0.ne.0)then +! toopi=4.d0*asin(1.d0) +! do j=1,nraysp +! c5j=p_data(5,j) +! ac5j=abs(c5j) +! if(c5j.gt.0.)p_data(5,j)=mod(c5j,toopi) +! if(c5j.lt.0.)p_data(5,j)=toopi-mod(ac5j,toopi) +! enddo! +! +!c place the value which is in(-pi,pi) back in the zblock array: +! do j=1,nraysp +! zblock(5,j)=p_data(5,j)-0.5d0*toopi +! enddo +! endif + +c convert phase to z (bbyk) and transform to the beam frame (gamma) +c also multiply by scale length (sl) to convert x and y to units of meters + do j=1,nraysp + p_data(5,j)=p_data(5,j)*gamma*bbyk + p_data(1,j)=p_data(1,j)*sl + p_data(3,j)=p_data(3,j)*sl + enddo + +c mask off lost particles + do j=1,nraysp + msk(j)=.true. + enddo + if(nraysp.lt.maxrayp)then + do j=nraysp+1,maxrayp + msk(j)=.false. + enddo + endif + + call setbound(p_data,msk,nraysp,gblam,gamma,nx,ny,nz,noresize,0) + + grid%xmin = xmin + grid%xmax = xmax + grid%ymin = ymin + grid%ymax = ymax + grid%zmin = zmin + grid%zmax = zmax + grid%hx = (xmax - xmin)/(nx - 1) + grid%hy = (ymax - ymin)/(ny - 1) + grid%hz = (zmax - zmin)/(nz - 1) + +! Deposit local chunk of particles on every processor on the entire grid + call rhoslo3d_loc(p_data,dens_local,msk,nraysp,ab,de,gh,indx,jndx,& + &kndx,indxp1,jndxp1,kndxp1,nx,ny,nz,0) + call MPI_ALLREDUCE(dens_local,density,nx*ny*nz,mreal,mpisum, & + &lworld,ierror) + + n_zone = int(nz/nvp) + nz_start = 1 + n_zone*idproc + nz_end = n_zone*(idproc + 1) + if (idproc .eq. nvp - 1) nz_end = nz + + do i = nz_start,nz_end + lcoord%k = i + do j = 1, 2*nmodes+1 + lcoord%nn = j + call qsimpsonx(ysimpsonint,xmin,xmax,ss) + mom_local(i,j) = ss + enddo + enddo + + call MPI_ALLREDUCE(mom_local,moments,nz*(2*nmodes+1),mreal,mpisum,& + &lworld,ierror) + + deallocate(dens_local) + deallocate(mom_local) + + return + end subroutine compute_beam_moments + +!*********************************************************************** + + function ysimpsonint(xx) + + use wakefld_params + implicit double precision(a-h,o-z) + + external func_rho + ymin = grid%ymin + ymax = grid%ymax + + lcoord%x = xx + call qsimpsony(func_rho,ymin,ymax,sst) + ysimpsonint = sst + + return + end function ysimpsonint + +!*********************************************************************** + + function func_rho(yy) + + use wakefld_params, only: grid, lcoord, density + implicit double precision(a-h,o-z) + integer i,j,k + + xmin = grid%xmin + xmax = grid%xmax + ymin = grid%ymin + ymax = grid%ymax + hx = grid%hx + hy = grid%hy + + xx = lcoord%x + i = int((xx - xmin)/hx) + 1 + j = int((yy - ymin)/hy) + 1 + k = lcoord%k + +! mode # 0 + if (lcoord%nn .eq. 1) then + func_rho = density(i,j,k) + endif +! mode # 1 + if (lcoord%nn .eq. 2) then + func_rho = density(i,j,k)*xx + endif + + if (lcoord%nn .eq. 3) then + func_rho = density(i,j,k)*yy + endif +! mode # 2 + if (lcoord%nn .eq. 4) then + func_rho = density(i,j,k)*(xx**2 - yy**2) + endif + + if (lcoord%nn .eq. 5) then + func_rho = density(i,j,k)*2*xx*yy + endif +! mode # 3 + if (lcoord%nn .eq. 6) then + func_rho = density(i,j,k)*(xx**3 - 3*xx*yy**2) + endif + + if (lcoord%nn .eq. 7) then + func_rho = density(i,j,k)*(3*xx**2*yy - yy**3) + endif +! mode # 4 + if (lcoord%nn .eq. 8) then + func_rho = density(i,j,k) + endif + + if (lcoord%nn .eq. 9) then + func_rho = density(i,j,k) + endif +! mode # 5 + if (lcoord%nn .eq. 10) then + func_rho = density(i,j,k) + endif + + if (lcoord%nn .eq. 11) then + func_rho = density(i,j,k) + endif + + + if (lcoord%nn .gt. 11) then + write(6,*)'Error in the beam moment computation:' + write(6,*)'only 5 modes are supported' + call myexit + endif + + return + end function func_rho + +!*********************************************************************** + + subroutine qsimpsonx(function,start,end,dint) + + implicit double precision(a-h,o-z) + integer :: j,jmax + external function + + eps=1.e-9 + jmax = 10 + ost=-1.e30 + os =-1.e30 + + do j=1,jmax + call trapzdx(function,start,end,st,j) + dint=(4.*st-ost)/3. + if (abs(dint-os) .lt. eps*abs(os)) return + if (dint .eq. 0. .and. os .eq. 0. .and. j .gt. 6) return + os = dint + ost = st + enddo + end subroutine qsimpsonx + +!*********************************************************************** + + subroutine qsimpsony(function,start,end,dint) + + implicit double precision(a-h,o-z) + integer :: j,jmax + external function + + eps=1.e-9 + jmax = 10 + ost=-1.e30 + os =-1.e30 + + do j=1,jmax + call trapzdy(function,start,end,st,j) + dint=(4.*st-ost)/3. + if (abs(dint-os) .lt. eps*abs(os)) return + if (dint .eq. 0. .and. os .eq. 0. .and. j .gt. 6) return + os = dint + ost = st + enddo + end subroutine qsimpsony + +!*********************************************************************** + + subroutine trapzdx(func,a,b,s,n) + + implicit double precision(a-h,o-z) + integer :: n,it,j + external func + + if (n .eq. 1) then + s = 0.5*(b-a)*(func(a)+func(b)) + else + it = 2**(n-2) + tnm = it + del = (b-a)/tnm + x = a+0.5*del + sum = 0. + do j = 1,it + sum = sum + func(x) + x = x +del + enddo + s = 0.5*(s+(b-a)*sum/tnm) + endif + return + end subroutine trapzdx + +!*********************************************************************** + + subroutine trapzdy(func,a,b,s,n) + + implicit double precision(a-h,o-z) + integer :: n,it,j + external func + + if (n .eq. 1) then + s = 0.5*(b-a)*(func(a)+func(b)) + else + it = 2**(n-2) + tnm = it + del = (b-a)/tnm + x = a+0.5*del + sum = 0. + do j = 1,it + sum = sum + func(x) + x = x +del + enddo + s = 0.5*(s+(b-a)*sum/tnm) + endif + return + end subroutine trapzdy + +!*********************************************************************** + + subroutine compute_wk_forces + + use wakefld_params + use parallel + +! 2d domain decomposition in x-y plane. ndx, ndy = number of subdomains +! in x and y directions (declared in wakefld_params) +! nxst,nxend,nyst,nyend = start and end grid nodes in x and y directions +! nnx,nny = number of grids in x and y directions +! ii,jj = indices of subdomains: +! +! ---------------------|-------------------- +! idproc = 4 | idproc = 5 +! | +! ii = 1, jj = 3 | ii = 2, jj = 3 +! ---------------------|-------------------- +! idproc = 2 | idproc = 3 +! | +! ii = 1, jj = 2 | ii = 2, jj = 2 +! ---------------------|-------------------- +! idproc = 0 | idproc = 1 +! | +! ii = 1, jj = 1 | ii = 2, jj = 1 +! ---------------------|-------------------- +! + + double precision :: rho, z + integer :: nxst,nxend,nyst,nyend,ii,jj,nnx,nny + integer :: i,j,k1,k2,nx,ny,nz,nm + + nx = grid%nx + ny = grid%ny + nz = grid%nz + hz = grid%hz + ndx = grid%ndx + ndy = grid%ndy + + allocate(lwkfx(nx,ny,nz)) + allocate(lwkfy(nx,ny,nz)) + allocate(lwkfz(nx,ny,nz)) + + jj = int(idproc/ndx) + 1 + ii = idproc - (jj - 1)*ndx + 1 + nnx = int(nx/ndx) + nny = int(ny/ndy) + + nxst = 1 + (ii - 1)*nnx + nxend = ii*nnx + if(ii .eq. ndx) nxend = nx + + nyst = 1 + (jj - 1)*nny + nyend = jj*nny + if (jj .eq. ndy) nyend = ny + + do k1 = 1,nz + do j = nyst,nyend + do i = nxst,nxend + +! For every grid point include wake fields created by +! particles in the head of the bunch + do k2 = k1,nz + z = (k1 - k2)*hz + rho = density(i,j,k1) + nm = wkfld_work(ncurel,3) + + if (wkfld_work(ncurel,1) .eq. 0) then + call compute_wkfrc_from_table + elseif (wkfld_work(ncurel,1) .eq. 1) then + call compute_wkfrc_reswall(rho,z,i,j,k1,k2,nm) + elseif (wkfld_work(ncurel,1) .eq. 2) then + call compute_wkfrc_rlc(rho,z,i,j,k1,k2,nm) + elseif (wkfld_work(ncurel,1) .eq. 3) then + call compute_wkfrc_pbx(rho,z,i,j,k1,k2,nm) + else + write(6,*)'Error in compute_wk_forces:' + write(6,*)'unimplemented wakefield model' + call myexit + endif + enddo + + enddo + enddo + enddo + + + call MPI_ALLREDUCE(lwkfx,wkfx,nx*ny*nz,mreal,mpisum,lworld,ierror) + call MPI_ALLREDUCE(lwkfy,wkfy,nx*ny*nz,mreal,mpisum,lworld,ierror) + call MPI_ALLREDUCE(lwkfz,wkfz,nx*ny*nz,mreal,mpisum,lworld,ierror) + + deallocate(lwkfx) + deallocate(lwkfy) + deallocate(lwkfz) + + ncurel = ncurel + 1 + if (ncurel .gt. nwkel) then + ncurel = 1 + endif + return + end subroutine compute_wk_forces + +!*********************************************************************** + + + subroutine apply_wk_forces(tau) + + use wakefld_params, only: wkfx,wkfy,wkfz,ab,de,gh,indx,jndx,kndx, & + &msk,indxp1,jndxp1,kndxp1,grid + use rays, only: zblock, nraysp + use beamdata + + double precision, dimension (:), allocatable :: fx,fy,fz + double precision :: tau,fourpi,perv,xycon,tcon,ratio3,gbi,fpei + integer :: j + + allocate(fx(nraysp)) + allocate(fy(nraysp)) + allocate(fz(nraysp)) + + nx = grid%nx + ny = grid%ny + nz = grid%nz + +! Interpolate forces to positions of particles + + call ntrslo3d_loc(wkfx,wkfy,wkfz,fx,fy,fz,msk,ab,de,gh,indx,jndx, & + &kndx,indxp1,jndxp1,kndxp1,nx,ny,nz,nraysp) + + fpei=c*c*1.d-7 + perv=2.d0*bcurr*fpei/(brho*beta*beta*c*c*gamma*gamma) + fourpi=8.d0*(asin(1.d0)) + xycon=fourpi*0.5*perv*gamma*beta*(beta*c/bfreq) + tcon=beta*xycon*gamma**2 + ratio3=omegascl*sl/299792458.d0 + tcon=tcon/ratio3 + + gbi=1./(gamma*beta) + + if(lflagmagu)then + xycon=xycon*gbi + tcon=tcon*gbi + endif + + open(77,file='wake_data') + + do j=1,nraysp + + write(77,88)zblock(2,j),tau*xycon*fx(j),zblock(4,j), & + & xycon*fy(j),zblock(6,j),tau*tcon*fz(j) + 88 format(6d12.3) + + zblock(2,j)=zblock(2,j) + tau*xycon*fx(j) + zblock(4,j)=zblock(4,j) + tau*xycon*fy(j) + zblock(6,j)=zblock(6,j) + tau*tcon*fz(j) + enddo + + deallocate(fx) + deallocate(fy) + deallocate(fz) + + end subroutine apply_wk_forces + +!*********************************************************************** + + subroutine compute_wkfrc_reswall(rho,z,ii,jj,kk1,kk2,nmod) + +! Computes wake forces acting on the test particle due to wake wields +! created by the source particle using the resistive wake field model +! Writes forces to arrays lwkfx,lwkfy,lwkfz in wakefld_params.mod +! +! z is the distance between the source and test particles +! ii,jj,kk1 are discrete coordinates of the test particle +! kk2 is the discrete z coord. of the source particle +! nmod is the number of modes + + use wakefld_params + implicit double precision(a-h,o-z) + integer ii,jj,kk1,kk2,nmod,nrw + + x = grid%xmin + grid%hx*(ii-1) + y = grid%ymin + grid%hy*(jj-1) + + nrw = wkfld_work(ncurel,2) + call wkfunction_rwall(z,1,1,nrw,wkfl) + lwkfx(ii,jj,kk1) = 0. + lwkfy(ii,jj,kk1) = 0. + lwkfz(ii,jj,kk1) = -moments(kk2,1)*wkfl + + if (nmod .gt. 1) then + call wkfunction_rwall(z,2,0,nrw,wkft) + call wkfunction_rwall(z,2,1,nrw,wkfl) + + lwkfx(ii,jj,kk1) = -moments(kk2,2)*wkft + + lwkfy(ii,jj,kk1) = -moments(kk2,3)*wkft + + lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & + & wkfl*(x*moments(kk2,2) + y*moments(kk2,3)) + endif + + if (nmod .gt. 2) then + call wkfunction_rwall(z,3,0,nrw,wkft) + call wkfunction_rwall(z,3,1,nrw,wkfl) + + lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & + & 2*wkft*(x*moments(kk2,4) + y*moments(kk2,5)) + + lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & + & 2*wkft*(-y*moments(kk2,4) + x*moments(kk2,5)) + + lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & + & wkfl*((x**2-y**2)*moments(kk2,4)+2*x*y*moments(kk2,5)) + endif + + if (nmod .gt. 3) then + call wkfunction_rwall(z,4,0,nrw,wkft) + call wkfunction_rwall(z,4,1,nrw,wkfl) + + lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & + & 3*wkft*((x**2-y**2)*moments(kk2,6)+2*x*y*moments(kk2,7)) + + lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & + & 3*wkft*(-2*x*y*moments(kk2,6)+(x**2-y**2)*moments(kk2,7)) + + lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & + & wkfl*((x**3-3*x*y**2)*moments(kk2,6) + & + & (3*x**2*y-y**3)*moments(kk2,7)) + endif + +! if (nmod .gt. 4) then +! call wkfunction_rwall(z,5,0,nrw,wkft) +! call wkfunction_rwall(z,5,1,nrw,wkfl) +! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) +! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) +! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) +! endif + +! if (nmod .gt. 5) then +! call wkfunction_rwall(z,6,0,nrw,wkft) +! call wkfunction_rwall(z,6,1,nrw,wkfl) +! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) +! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) +! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) +! endif + + return + end subroutine compute_wkfrc_reswall + +!*********************************************************************** + + subroutine compute_wkfrc_rlc(rho,z,ii,jj,kk1,kk2,nmod) + +! Computes wake forces acting on the test particle due to wake wields +! created by the source particle using the rlc resonator model +! Writes forces to arrays lwkfx,lwkfy,lwkfz in wakefld_params.mod +! +! z is the distance between the source and test particles +! ii,jj,kk1 are discrete coordinates of the test particle +! kk2 is the discrete z coord. of the source particle +! nmod is the number of modes + + use wakefld_params + implicit double precision(a-h,o-z) + integer ii,jj,kk1,kk2,nmod,nrf + + x = grid%xmin + grid%hx*(ii-1) + y = grid%ymin + grid%hy*(jj-1) + + nrf = wkfld_work(ncurel,2) + call wkfunction_rlc(z,1,1,nrf,wkfl) + lwkfx(ii,jj,kk1) = 0. + lwkfy(ii,jj,kk1) = 0. + lwkfz(ii,jj,kk1) = -moments(kk2,1)*wkfl + + if (nmod .gt. 1) then + call wkfunction_rlc(z,2,0,nrf,wkft) + call wkfunction_rlc(z,2,1,nrf,wkfl) + + lwkfx(ii,jj,kk1) = -moments(kk2,2)*wkft + + lwkfy(ii,jj,kk1) = -moments(kk2,3)*wkft + + lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & + & wkfl*(x*moments(kk2,2) + y*moments(kk2,3)) + endif + + if (nmod .gt. 2) then + call wkfunction_rlc(z,3,0,nrf,wkft) + call wkfunction_rlc(z,3,1,nrf,wkfl) + + lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & + & 2*wkft*(x*moments(kk2,4) + y*moments(kk2,5)) + + lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & + & 2*wkft*(-y*moments(kk2,4) + x*moments(kk2,5)) + + lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & + & wkfl*((x**2-y**2)*moments(kk2,4)+2*x*y*moments(kk2,5)) + endif + + if (nmod .gt. 3) then + call wkfunction_rlc(z,4,0,nrf,wkft) + call wkfunction_rlc(z,4,1,nrf,wkfl) + + lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & + & 3*wkft*((x**2-y**2)*moments(kk2,6)+2*x*y*moments(kk2,7)) + + lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & + & 3*wkft*(-2*x*y*moments(kk2,6)+(x**2-y**2)*moments(kk2,7)) + + lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & + & wkfl*((x**3-3*x*y**2)*moments(kk2,6) + & + & (3*x**2*y-y**3)*moments(kk2,7)) + endif + +! if (nmod .gt. 4) then +! call wkfunction_rlc(z,5,0,nrf,wkft) +! call wkfunction_rlc(z,5,1,nrf,wkfl) +! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) +! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) +! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) +! endif + +! if (nmod .gt. 5) then +! call wkfunction_rlc(z,6,0,nrf,wkft) +! call wkfunction_rlc(z,6,1,nrf,wkfl) +! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) +! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) +! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) +! endif + + return + end subroutine compute_wkfrc_rlc + +!*********************************************************************** + + subroutine compute_wkfrc_pbx(rho,z,ii,jj,kk1,kk2,nmod) + +! Computes wake forces acting on the test particle due to wake wields +! created by the source particle using the pbx resonator model +! Writes forces to arrays lwkfx,lwkfy,lwkfz in wakefld_params.mod +! +! z is the distance between the source and test particles +! ii,jj,kk1 are discrete coordinates of the test particle +! kk2 is the discrete z coord. of the source particle +! nmod is the number of modes + + use wakefld_params + implicit double precision(a-h,o-z) + integer ii,jj,kk1,kk2,nmod,nrf + + x = grid%xmin + grid%hx*(ii-1) + y = grid%ymin + grid%hy*(jj-1) + + nrf = wkfld_work(ncurel,2) + call wkfunction_pbx(z,1,1,nrf,wkfl) + lwkfx(ii,jj,kk1) = 0. + lwkfy(ii,jj,kk1) = 0. + lwkfz(ii,jj,kk1) = -moments(kk2,1)*wkfl + + if (nmod .gt. 1) then + call wkfunction_pbx(z,2,0,nrf,wkft) + call wkfunction_pbx(z,2,1,nrf,wkfl) + + lwkfx(ii,jj,kk1) = -moments(kk2,2)*wkft + + lwkfy(ii,jj,kk1) = -moments(kk2,3)*wkft + + lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & + & wkfl*(x*moments(kk2,2) + y*moments(kk2,3)) + endif + + if (nmod .gt. 2) then + call wkfunction_pbx(z,3,0,nrf,wkft) + call wkfunction_pbx(z,3,1,nrf,wkfl) + + lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & + & 2*wkft*(x*moments(kk2,4) + y*moments(kk2,5)) + + lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & + & 2*wkft*(-y*moments(kk2,4) + x*moments(kk2,5)) + + lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & + & wkfl*((x**2-y**2)*moments(kk2,4)+2*x*y*moments(kk2,5)) + endif + + if (nmod .gt. 3) then + call wkfunction_pbx(z,4,0,nrf,wkft) + call wkfunction_pbx(z,4,1,nrf,wkfl) + + lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & + & 3*wkft*((x**2-y**2)*moments(kk2,6)+2*x*y*moments(kk2,7)) + + lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & + & 3*wkft*(-2*x*y*moments(kk2,6)+(x**2-y**2)*moments(kk2,7)) + + lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & + & wkfl*((x**3-3*x*y**2)*moments(kk2,6) + & + & (3*x**2*y-y**3)*moments(kk2,7)) + endif + +! if (nmod .gt. 4) then +! call wkfunction_pbx(z,5,0,nrf,wkft) +! call wkfunction_pbx(z,5,1,nrf,wkfl) +! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) +! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) +! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) +! endif + +! if (nmod .gt. 5) then +! call wkfunction_pbx(z,6,0,nrf,wkft) +! call wkfunction_pbx(z,6,1,nrf,wkfl) +! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) +! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) +! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) +! endif + + return + end subroutine compute_wkfrc_pbx + +!*********************************************************************** + + subroutine compute_wkfrc_from_table + + end subroutine compute_wkfrc_from_table + +!*********************************************************************** + + subroutine wkfunction_rlc(z,m,ntype,nel,wkfunction) + +! z is the longitudinal coordinate +! m is the mode number +! ntype = 0 for the transverse wake function +! ntype = 1 for the longitudinal wake function +! nel is the order number of this rlc element model +! wkfunction is the wake function value + + use wakefld_params + use beamdata, only: c + + implicit double precision(a-h,o-z) + integer m,ntype,nel + common/pie/pi,pi180,twopi + + Q = rlc_param(nel)%quality(m) + omega = rlc_param(nel)%res_fr(m) + Rs = rlc_param(nel)%r_shunt(m) + alpha = 0.5*omega/Q + bomega = sqrt(omega**2 - alpha**2) + + if (ntype .eq. 0) then ! transverse wake function + if (z .gt. 0.) then + write(6,*)'Error: positive z in subroutine wkfunction_rlc' + call myexit + else + wkfunction=c*Rs*omega*exp(alpha*z/c)*sin(bomega*z/c)/(Q*bomega) + endif + endif + + if (ntype .eq. 1) then ! longitudinal wake function + if (z .gt. 0.) then + write(6,*)'Error: positive z in subroutine wkfunction_rlc' + call myexit + elseif (z .eq. 0.) then + wkfunction=alpha*Rs + else + wkfunction=2*alpha*Rs*exp(alpha*z/c)*(cos(bomega*z/c)+ & + & alpha*sin(bomega*z/c)/bomega) + endif + endif + + if (ntype .gt. 1) then ! invalid ntype + write(6,*)'Invalid ntype of the rlc wake function' + call myexit + endif + return + + end subroutine wkfunction_rlc + +!*********************************************************************** + + subroutine wkfunction_rwall(z,m,ntype,nel,wkfunction) + +! z is the distance between the source and test particles (with - sign) +! m is the mode number +! ntype = 0 for the transverse wake function +! ntype = 1 for the longitudinal wake function +! nel is the order number of this res. wall element model +! wkfunction is the wake function value + + use wakefld_params + use beamdata, only : c + + implicit double precision(a-h,o-z) + integer m,ntype,nel + common/pie/pi,pi180,twopi + + if (z .eq. 0) then + wkfunction = 0 + return + endif + + if (m .eq. 0) then + delta = 1. + else + delta = 0. + endif + + if (ntype .eq. 0) then ! transverse wake function + wkfunction = c*sqrt(z0)/(pi*(rwall_param(nel)%radius)**(m+1)* & + & (1+delta)*sqrt(pi*rwall_param(nel)%conduct*abs(z))) + endif + + if (ntype .eq. 1) then ! longitudinal wake function + wkfunction = c*sqrt(z0)/(twopi*(rwall_param(nel)%radius)**(m+1)*& + & (1+delta)*z*sqrt(pi*rwall_param(nel)%conduct*abs(z))) + endif + + if (ntype .gt. 1) then ! invalid ntype + write(6,*)'Invalid ntype of the resistive wall wake function' + call myexit + endif + return + end subroutine wkfunction_rwall + +!*********************************************************************** + + subroutine wkfunction_pbx(z,m,ntype,nel,wkfunction) + +! z is the longitudinal coordinate +! m is the mode number +! ntype = 0 for the transverse wake function +! ntype = 1 for the longitudinal wake function +! nel is the order number of this rlc element model +! wkfunction is the wake function value + + use wakefld_params + use beamdata, only: c + + implicit double precision(a-h,o-z) + integer m,ntype,nel + common/pie/pi,pi180,twopi + + l = pbx_param(nel)%length(m) + d = pbx_param(nel)%depth(m) + r = pbx_param(nel)%radius(m) + + if (m .eq. 1) then + dlt = 2 + else + dlt = 1 + endif + + if (ntype .eq. 0) then ! transverse wake function + if (z .gt. 0.) then + write(6,*)'Error: positive z in subroutine wkfunction_pbx' + call myexit + else + wkfunction=2*z0*c*sqrt(-2.d0*l*z)/(dlt*pi**2*r**(2*m-1)) + endif + endif + + if (ntype .eq. 1) then ! longitudinal wake function + if (z .gt. 0.) then + write(6,*)'Error: positive z in subroutine wkfunction_pbx' + call myexit + elseif (z .eq. 0.) then + wkfunction=0 + else + wkfunction=z0*c*sqrt(2.d0*l)/(dlt*pi**2*r**(2*m-1)*sqrt(-z)) + endif + endif + + if (ntype .gt. 1) then ! invalid ntype + write(6,*)'Invalid ntype of the pbx wake function' + call myexit + endif + return + + end subroutine wkfunction_pbx + +!*********************************************************************** + + + subroutine locate_index(x,n,j) + +! Given an array wkfunc_table(:,:), and given a value x, returns a value +! j such that x is between wkfunc_table(j,1) and wkfunc_table(j+1,1). +! wkfunc_table(1:n,1) must be monotonic. j = 0 or j = n is rturned to +! indicate that x is out of range + + use wakefld_params, only: wkfunc_table + + implicit double precision(a-h,o-z) + integer j,n + integer jl,jm,ju +!temp + allocate(wkfunc_table(100,2)) + + jl = 0 + ju = n+1 + 10 if (ju-jl .gt. 1) then + jm = (ju+jl)/2 + if ((wkfunc_table(n,1) .ge. wkfunc_table(1,1)) .eqv. & + & (x .ge. wkfunc_table(jm,1))) then +!XXX gfortran compiler complains about uninitialized variable +!XXX jl = lm + write(6,*) 'error: locate_index(): uninitialized var: lm' + stop 'LMERROR' +!XXX + else + ju = jm + endif + goto 10 + endif + if (x .eq. wkfunc_table(1,1)) then + j = 1 + else if (x .eq. wkfunc_table(n,1)) then + j = n-1 + else + j = jl + endif +!temp + deallocate(wkfunc_table) + + + return + end subroutine locate_index + +!*********************************************************************** + + subroutine rhoslo3d_loc(coord,rho,msk,np,ab,de,gh,indx,jndx,kndx, & + &indxp1,jndxp1,kndxp1,nx,ny,nz,nadj) +cryne 08/24/2001 use hpf_library + implicit double precision(a-h,o-z) + logical msk + dimension coord(6,np),msk(np),vol(np) +!hpf$ distribute coord(*,block) +!hpf$ align (:) with coord(*,:) :: msk,vol + dimension ab(np),de(np),gh(np),indx(np),jndx(np),kndx(np), & + &indxp1(np),jndxp1(np),kndxp1(np) +!hpf$ align (:) with coord(*,:) :: ab,de,gh,indx,jndx,kndx +!hpf$ align (:) with coord(*,:) :: indxp1,jndxp1,kndxp1 + dimension rho(nx,ny,nz),tmp(nx,ny,nz) +!hpf$ distribute rho(*,*,block) +!hpf$ align (*,*,:) with rho(*,*,:) :: tmp + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi + common/showme/iverbose +! if(idproc.eq.0) write(6,*)'inside rhoslo3d' +! write(6,*)'xmin,xmax=',xmin,xmax +! write(6,*)'nx,ny,nz=',nx,ny,nz +! write(6,*)'nadj=',nadj +! xminnn=minval(coord(1,:)) +! xmaxxx=maxval(coord(1,:)) +! write(6,*)'xminnn,xmaxxx=',xminnn,xmaxxx +cryne 6/25/2002 do i=1,np + do j=1,np + indx(j)=(coord(1,j)-xmin)*hxi + 1 + jndx(j)=(coord(3,j)-ymin)*hyi + 1 + kndx(j)=(coord(5,j)-zmin)*hzi + 1 + enddo + do j=1,np + indxp1(j)=indx(j)+1 + jndxp1(j)=jndx(j)+1 + kndxp1(j)=kndx(j)+1 + enddo +!------- + imin=minval(indx,1,msk) + imax=maxval(indx,1,msk) + jmin=minval(jndx,1,msk) + jmax=maxval(jndx,1,msk) + kmin=minval(kndx,1,msk) + kmax=maxval(kndx,1,msk) + if((imin.lt.1).or.(imax.gt.nx-1))then + write(6,*)'error in rhoslo3d: imin,imax=',imin,imax + write(6,*)'nx,xmin,xmax,hx=',nx,xmin,xmax,hx + write(6,*)'nadj=',nadj + call myexit + endif + if((jmin.lt.1).or.(jmax.gt.ny-1))then + write(6,*)'error in rhoslo3d: jmin,jmax=',jmin,jmax + call myexit + endif + if(nadj.eq.0)then + if((kmin.lt.1).or.(kmax.gt.nz-1))then + write(6,*)'error in rhoslo3d (nadj=0): kmin,kmax=',kmin,kmax + call myexit + endif + endif + if(nadj.eq.1)then + if((kmin.lt.1).or.(kmax.gt.nz))then + write(6,*)'error in rhoslo3d (nadj=1): kmin,kmax=',kmin,kmax + call myexit + endif + endif +!------- + if(nadj.eq.1)then + do n=1,np + if(kndxp1(n).eq.nz+1)kndxp1(n)=1 + enddo + endif + ab=((xmin-coord(1,:))+indx*hx)*hxi + de=((ymin-coord(3,:))+jndx*hy)*hyi + gh=((zmin-coord(5,:))+kndx*hz)*hzi + rho=0. +!1 (i,j,k): + vol=ab*de*gh + do 100 n=1,np + rho(indx(n),jndx(n),kndx(n))= & + &rho(indx(n),jndx(n),kndx(n))+vol(n) + 100 continue +!2 (i,j+1,k): + vol=ab*(1.-de)*gh + do 200 n=1,np + rho(indx(n),jndxp1(n),kndx(n))= & + &rho(indx(n),jndxp1(n),kndx(n))+vol(n) + 200 continue +!3 (i,j+1,k+1): + vol=ab*(1.-de)*(1.-gh) + do 300 n=1,np + rho(indx(n),jndxp1(n),kndxp1(n))= & + &rho(indx(n),jndxp1(n),kndxp1(n))+vol(n) + 300 continue +!4 (i,j,k+1): + vol=ab*de*(1.-gh) + do 400 n=1,np + rho(indx(n),jndx(n),kndxp1(n))= & + &rho(indx(n),jndx(n),kndxp1(n))+vol(n) + 400 continue +!5 (i+1,j,k+1): + vol=(1.-ab)*de*(1.-gh) + do 500 n=1,np + rho(indxp1(n),jndx(n),kndxp1(n))= & + &rho(indxp1(n),jndx(n),kndxp1(n))+vol(n) + 500 continue +!6 (i+1,j+1,k+1): + vol=(1.-ab)*(1.-de)*(1.-gh) + do 600 n=1,np + rho(indxp1(n),jndxp1(n),kndxp1(n))= & + &rho(indxp1(n),jndxp1(n),kndxp1(n))+vol(n) + 600 continue +!7 (i+1,j+1,k): + vol=(1.-ab)*(1.-de)*gh + do 700 n=1,np + rho(indxp1(n),jndxp1(n),kndx(n))= & + &rho(indxp1(n),jndxp1(n),kndx(n))+vol(n) + 700 continue +!8 (i+1,j,k): + vol=(1.-ab)*de*gh + do 800 n=1,np + rho(indxp1(n),jndx(n),kndx(n))= & + &rho(indxp1(n),jndx(n),kndx(n))+vol(n) + 800 continue +! +cryne august 1, 2002: +cccc ngood=count(msk) +cccc write(6,*)'ngood=',ngood +cccc rho=rho/ngood +!wrong rho=rho/ngood*hxi*hyi*hzi +! if(idproc.eq.0)write(6,*)'leaving rhoslo3d' +! rhochk=sum(rho) +! write(6,*)'[rhoslo3d]sum(rho)=',rhochk + return + end + +!************************************************************* + + + subroutine ntrslo3d_loc(exg,eyg,ezg,ex,ey,ez,msk,ab,de,gh, + #indx,jndx,kndx,indxp1,jndxp1,kndxp1,nx,ny,nz,np) + use parallel + implicit double precision(a-h,o-z) + logical msk + dimension exg(nx,ny,nz),eyg(nx,ny,nz),ezg(nx,ny,nz) +!hpf$ distribute exg(*,*,block) +!hpf$ align (*,*,:) with exg(*,*,:) :: eyg,ezg + dimension ex(np),ey(np),ez(np),msk(np) + dimension ab(np),de(np),gh(np),indx(np),jndx(np),kndx(np), + #indxp1(np),jndxp1(np),kndxp1(np) +!hpf$ template t1(np) +!hpf$ distribute t1(block) +!hpf$ align (:) with t1(:) :: ex,ey,ez,msk,ab,de,gh +!hpf$ align (:) with t1(:) :: indx,jndx,kndx,indxp1,jndxp1,kndxp1 + common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi +! if(idproc.eq.0)write(6,*)'inside ntrslo3d' +! if(idproc.eq.0)then +! do n=1,np +! if(indx(n).lt.1 .or. indx(n).gt.nx)write(6,*)'error: indx(n)' +! enddo +! do n=1,np +! if(jndx(n).lt.1 .or. jndx(n).gt.ny)write(6,*)'error: jndx(n)' +! enddo +! do n=1,np +! if(kndx(n).lt.1 .or. kndx(n).gt.nz)write(6,*)'error: kndx(n)' +! enddo +! do n=1,np +! if(indxp1(n).lt.1.or.indxp1(n).gt.nx)write(6,*)'err:indxp1(n)' +! enddo +! do n=1,np +! if(jndxp1(n).lt.1.or.jndxp1(n).gt.ny)write(6,*)'err:jndxp1(n)' +! enddo +! do n=1,np +! if(kndxp1(n).lt.1.or.kndxp1(n).gt.nz)write(6,*)'err:kndxp1(n)' +! enddo +! endif +cryne forall(n=1:np)ex(n)= + do 100 n=1,np + ex(n)= & + & exg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) + &+exg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) + &+exg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) + &+exg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) + &+exg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) + &+exg(indxp1(n), + &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) + &+exg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) + &+exg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) + 100 continue + +cryne forall(n=1:np)ey(n)= + do 200 n=1,np + ey(n)= & + & eyg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) + &+eyg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) + &+eyg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) + &+eyg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) + &+eyg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) + &+eyg(indxp1(n), + &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) + &+eyg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) + &+eyg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) + 200 continue + +cryne forall(n=1:np)ez(n)= + do 300 n=1,np + ez(n)= & + & ezg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) + &+ezg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) + &+ezg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) + &+ezg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) + &+ezg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) + &+ezg(indxp1(n), + &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) + &+ezg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) + &+ezg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) + 300 continue +! if(idproc.eq.0)write(6,*)'leaving ntrslo3d_loc' + return + end + + + + + + + + + + diff --git a/OpticsJan2020/MLI_light_optics/Src/xerbla.f b/OpticsJan2020/MLI_light_optics/Src/xerbla.f new file mode 100644 index 0000000..963eefd --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/xerbla.f @@ -0,0 +1,43 @@ + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- LAPACK auxiliary routine (preliminary version) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. Scalar Arguments .. + CHARACTER SRNAME*(*) + INTEGER INFO +* .. +* +* Purpose +* ======= +* +* XERBLA is an error handler for the LAPACK routines. +* It is called by an LAPACK routine if an input parameter has an +* invalid value. A message is printed and execution stops. +* +* Installers may consider modifying the STOP statement in order to +* call system-specific exception-handling facilities. +* +* Arguments +* ========= +* +* SRNAME (input) CHARACTER*(*) +* The name of the routine which called XERBLA. +* +* INFO (input) INTEGER +* The position of the invalid parameter in the parameter list +* of the calling routine. +* +* + WRITE( *, FMT = 9999 )SRNAME, INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END diff --git a/OpticsJan2020/MLI_light_optics/Src/xtra.f b/OpticsJan2020/MLI_light_optics/Src/xtra.f new file mode 100755 index 0000000..0e4bbf7 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/xtra.f @@ -0,0 +1,95 @@ +************************************************************************ +* header XTRA CODE * +* MARYLIE code that is not part of the f90 standard +************************************************************************ +c + subroutine myflush(nfile) + call flush(nfile) +c call flush_(nfile) + return + end +c +c +c + subroutine cputim(t) +c----------------------------------------------------------------------- +c implicit real(a-h,o-z),logical(l),integer(i,j,k,m,n) +c----------------------------------------------------------------------- +c t is the cpu time used so far +c note, that this routine will work only for VAX VMS-Systems +c written by Petra Schuett, 12 April 1988 +c----------------------------------------------------------------------- +c include '($jpidef)' +c integer*2 ilen1,ilen2,ilen3,icod1,icod2,icod3 +c integer*4 iadd1,iadd11,iadd2,iadd21 +c common/tcbl/ilen1,icod1,iadd1,iadd11, +c * ilen2,icod2,iadd2,iadd21, +c * ilen3,icod3 +c data ilen1,ilen2,ilen3/3*4/ +c * iadd11,iadd21,icod3/3*0/ +c data icod1/jpi$_cpulim/ +c * icod2/jpi$_cputim/ + +c iadd1 = %loc(icpulm) +c iadd2 = %loc(icputm) + +c call sys$getjpi(,,,ilen1,,,) +c t = icputm/100. +c100 return + t=0. + return + end +c +*********************************************************************** +c + subroutine mytime(p) +c +c This subroutine computes and prints out the run time. +c It calls the VAX specific routine cputim. This is the +c only place in MaryLie where cputim is called. +c Written by A. Dragt on 7 April 1988. Modified +c 28 September 1991. +c + include 'impli.inc' + include 'time.inc' + include 'files.inc' +c + dimension p(6) + real runtim,tnow +c +c Compute and write out run time. +c + iopt = nint(p(1)) + ifile = nint(p(2)) + isend = nint(p(3)) +c + if (isend .ne. 0) then + call cputim(tnow) + runtim = tnow-tstart + if ((isend .eq. 1) .or. (isend .eq. 3)) + & write (jof,100) runtim + if ((isend .eq. 2) .or. (isend .eq. 3)) + & write (ifile,100) runtim + 100 format(/,1x,'Execution time in seconds = ',f8.2) + endif +c +c Reset clock if iopt .ne. 0 +c + if (iopt .ne. 0) then + call cputim(tstart) + if ((isend .eq. 1) .or. (isend .eq. 3)) + & write (jof,*) ' time reset to zero' + if ((isend .eq. 2) .or. (isend .eq. 3)) + & write (ifile,*) ' time reset to zero' + endif +c + return + end +c + real function secnds(tt) + real tt + secnds=0.0 + return + end +c end of file + diff --git a/OpticsJan2020/MLI_light_optics/Src/xtra_notgnu.f b/OpticsJan2020/MLI_light_optics/Src/xtra_notgnu.f new file mode 100755 index 0000000..0e4bbf7 --- /dev/null +++ b/OpticsJan2020/MLI_light_optics/Src/xtra_notgnu.f @@ -0,0 +1,95 @@ +************************************************************************ +* header XTRA CODE * +* MARYLIE code that is not part of the f90 standard +************************************************************************ +c + subroutine myflush(nfile) + call flush(nfile) +c call flush_(nfile) + return + end +c +c +c + subroutine cputim(t) +c----------------------------------------------------------------------- +c implicit real(a-h,o-z),logical(l),integer(i,j,k,m,n) +c----------------------------------------------------------------------- +c t is the cpu time used so far +c note, that this routine will work only for VAX VMS-Systems +c written by Petra Schuett, 12 April 1988 +c----------------------------------------------------------------------- +c include '($jpidef)' +c integer*2 ilen1,ilen2,ilen3,icod1,icod2,icod3 +c integer*4 iadd1,iadd11,iadd2,iadd21 +c common/tcbl/ilen1,icod1,iadd1,iadd11, +c * ilen2,icod2,iadd2,iadd21, +c * ilen3,icod3 +c data ilen1,ilen2,ilen3/3*4/ +c * iadd11,iadd21,icod3/3*0/ +c data icod1/jpi$_cpulim/ +c * icod2/jpi$_cputim/ + +c iadd1 = %loc(icpulm) +c iadd2 = %loc(icputm) + +c call sys$getjpi(,,,ilen1,,,) +c t = icputm/100. +c100 return + t=0. + return + end +c +*********************************************************************** +c + subroutine mytime(p) +c +c This subroutine computes and prints out the run time. +c It calls the VAX specific routine cputim. This is the +c only place in MaryLie where cputim is called. +c Written by A. Dragt on 7 April 1988. Modified +c 28 September 1991. +c + include 'impli.inc' + include 'time.inc' + include 'files.inc' +c + dimension p(6) + real runtim,tnow +c +c Compute and write out run time. +c + iopt = nint(p(1)) + ifile = nint(p(2)) + isend = nint(p(3)) +c + if (isend .ne. 0) then + call cputim(tnow) + runtim = tnow-tstart + if ((isend .eq. 1) .or. (isend .eq. 3)) + & write (jof,100) runtim + if ((isend .eq. 2) .or. (isend .eq. 3)) + & write (ifile,100) runtim + 100 format(/,1x,'Execution time in seconds = ',f8.2) + endif +c +c Reset clock if iopt .ne. 0 +c + if (iopt .ne. 0) then + call cputim(tstart) + if ((isend .eq. 1) .or. (isend .eq. 3)) + & write (jof,*) ' time reset to zero' + if ((isend .eq. 2) .or. (isend .eq. 3)) + & write (ifile,*) ' time reset to zero' + endif +c + return + end +c + real function secnds(tt) + real tt + secnds=0.0 + return + end +c end of file + From e2a38e64696b8afdfece61b6db924086f09b15b4 Mon Sep 17 00:00:00 2001 From: ChristopherMayes <31023527+ChristopherMayes@users.noreply.github.com> Date: Wed, 17 Mar 2021 21:35:17 -0700 Subject: [PATCH 2/4] New method for free space and image charge calculations. Uses an offset grid trick to evaluate the indefinite integral. --- .gitignore | 2 + CMakeLists.txt | 2 +- code/open_spacecharge_mod.f90 | 322 ++++++++++++++- code/test_opensc.f90 | 28 +- examples/benchmark.ipynb | 713 ++++++++++++++++++++++++++++++++++ 5 files changed, 1059 insertions(+), 8 deletions(-) create mode 100644 .gitignore create mode 100644 examples/benchmark.ipynb diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..191310e --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +build/* +*.DS_Store diff --git a/CMakeLists.txt b/CMakeLists.txt index 33ffb95..1aea837 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -39,7 +39,7 @@ if(GetFFTW) # FFTW3 include(ExternalProject) ExternalProject_Add(project_fftw - URL http://www.fftw.org/fftw-3.3.7.tar.gz + URL http://www.fftw.org/fftw-3.3.9.tar.gz PREFIX ${CMAKE_CURRENT_BINARY_DIR}/fftw CONFIGURE_COMMAND ${CMAKE_CURRENT_BINARY_DIR}/fftw/src/project_fftw/configure --enable-openmp --prefix= BUILD_COMMAND make -j 8 diff --git a/code/open_spacecharge_mod.f90 b/code/open_spacecharge_mod.f90 index 3ed68b4..25a5563 100644 --- a/code/open_spacecharge_mod.f90 +++ b/code/open_spacecharge_mod.f90 @@ -70,10 +70,11 @@ subroutine space_charge_freespace(mesh3d, direct_field_calc, integrated_green_fu if(present(integrated_green_function) .and. .not. integrated_green_function) igfflag = 0 call osc_freespace_solver(mesh3d%rho, mesh3d%gamma, & - mesh3d%delta(1), mesh3d%phi, mesh3d%efield, mesh3d%bfield, & + mesh3d%delta, mesh3d%phi, mesh3d%efield, mesh3d%bfield, & mesh3d%nlo, mesh3d%nhi, mesh3d%nlo, mesh3d%nhi, mesh3d%npad, idirectfieldcalc,igfflag) end subroutine + !------------------------------------------------------------------------ !------------------------------------------------------------------------ !------------------------------------------------------------------------ @@ -389,4 +390,323 @@ subroutine interpolate_field(x, y, z, mesh3d, E, B) end subroutine + + +!------------------------------------------------------------------------ +!+ +! Subroutine space_charge_3d(mesh3d, offset, at_cathode) +! +! Performs the space charge calculation using the integrated Green function method +! and FFT-based convolutions. +! +! Input: +! mesh3d -- mesh3d_struct: populated with %rho +! +! offset -- real(3), optional: Offset coordinates x0, y0, z0 to evaluate the field, +! relative to rho. +! Default: (0,0,0) +! For example, an offset of (0,0,10) can be used to compute +! the field at z=+10 m relative to rho. +! +! at_cathode -- logical, optional: Maintain constant voltage at the cathode +! using image charges. Default is False. +! +! Output: +! mesh3d -- mesh3d_struct: populated with %efield +! +! +! +! Notes: +! The magnetic field components can be calculated by: +! Bx = -Ey/(c*beta*gamma^2) +! By = Ex/(c*beta*gamma^2) +! Bz = 0 +! +!- +subroutine space_charge_3d(mesh3d, offset, at_cathode) +type(mesh3d_struct) :: mesh3d +real(dp), allocatable, dimension(:,:,:,:) :: image_efield ! electric field grid +real(dp), optional :: offset(3) +real(dp) :: offset0(3) +logical, optional :: at_cathode + +if (.not. present(offset)) then + offset0 = 0 +else + offset0 = offset +endif + +! Free space field +call osc_freespace_solver2(mesh3d%rho, mesh3d%gamma, mesh3d%delta, efield=mesh3d%efield, offset=offset0) + +! Cathode calc +if (.not. present(at_cathode)) return +if (.not. at_cathode) return + +! Allocate scratch array for the image field +allocate(image_efield, mold=mesh3d%efield) + +! Image field, with an offset assuming the cathode is at z=0. +! The offset is the z width of the mesh, plus 2 times the distance of the mesh from the cathode. +offset0(3) = offset0(3) + 2*mesh3d%min(3) + (mesh3d%max(3)-mesh3d%min(3)) + +! Flip the charge mesh in z +call osc_freespace_solver2( mesh3d%rho(:,:,size(mesh3d%rho,3):1:-1), & + mesh3d%gamma, mesh3d%delta, efield=image_efield, offset=offset0) + +mesh3d%efield = mesh3d%efield - image_efield + +end subroutine + + + +!------------------------------------------------------------------------ +!+ +! elemental real(dp) function xlafun2(x, y, z) +! +! The indefinite integral: +! \int x/r^3 dx dy dz = x*atan((y*z)/(r*x)) -z*log(r+y) + y*log((r-z)/(r+z))/2 +! +! This corresponds to the electric field component Ex. +! Other components can be computed by permuting the arguments +! +!- +elemental real(dp) function xlafun2(x, y, z) + real(dp), intent(in) :: x, y, z + real(dp) :: r + r=sqrt(x**2+y**2+z**2) + xlafun2 = x*atan((y*z)/(r*x)) -z*log(r+y) + y*log((r-z)/(r+z))/2 +end function + +!------------------------------------------------------------------------ +!+ +! elemental real(dp) function lafun2(x,y,z) +! +! The indefinite integral: +! \int 1/r^3 dx dy dz = +! -z**2*atan(x*y/(z*r))/2 - y**2*atan(x*z/(y*r))/2 -x**2*atan(y*z/(x*r))/2 +! +y*z*log(x+r) + x*z*log(y+r) + x*y*log(z+r) +! +! This corresponds to the scalar potential. +! Other components can be computed by permuting the arguments +! +!- +elemental real(dp) function lafun2(x,y,z) + real(dp), intent(in) :: x, y, z + real(dp) :: r + r=sqrt(x**2+y**2+z**2) + lafun2 = -z**2*atan(x*y/(z*r))/2 - y**2*atan(x*z/(y*r))/2 -x**2*atan(y*z/(x*r))/2 & + +y*z*log(x+r) + x*z*log(y+r) + x*y*log(z+r) +end function + +!------------------------------------------------------------------------ +!+ +! Subroutine osc_get_cgrn_freespace(cgrn, delta, gamma, icomp, offset) +! +! Computes the free space Green function on a mesh with given spacings in the lab frame. +! The computation is performed in the rest fram by boosting the coordinates by gamma. +! +! +! Input: +! cgrn -- COMPLEX128(:,:,:): pre-allocated array +! delta -- REAL64(3): vector of grid spacings dx, dy, dz +! gamma -- REAL64: relativistic gamma +! icomp -- integer: Field component requested: +! 0: phi (scalar potential) +! 1: Ex +! 2: Ey +! 3: Ez +! offset -- real(3), optional: Offset coordinates for the center of the grid in [m]. +! Default: (0,0,0) +! For example, an offset of (0,0,10) can be used to compute +! the field at z=+10 m relative to the rho_mesh center. +! +! Output: +! cgrn -- COMPLEX128(:,:,:): Green function array +! +! +! Notes: +! Internally, dz -> dz*gamma. +! For efficients, the indefinite functions lafun2, xlafun2 are actually evaluated +! on a grid slightly offset by -dx/2, -dy/2, -dz/2, +! and these points are used to evaluate the integral with array addition and subtraction. +! +!- +subroutine osc_get_cgrn_freespace(cgrn, delta, gamma, icomp, offset) + +complex(dp), intent(out), dimension(0:,0:,0:) :: cgrn ! Convenient indexing +real(dp), intent(in), dimension(3) :: delta +integer, intent(in) :: icomp +real(dp), intent(in) :: gamma +real(dp), intent(in), optional :: offset(3) +! Local +real(dp) :: dx,dy,dz +real(dp) :: u,v,w, umin, vmin, wmin +real(dp) :: gval, factor +integer :: imin, imax, jmin, jmax, kmin, kmax +integer :: i,j,k, isize, jsize, ksize + +! Mesh spacings. dz is stretched in the rest frame. +dx=delta(1); dy=delta(2); dz=delta(3)*gamma + +! Special cases: Ex and Ey are enhanced by gamma +if ((icomp==1) .or. (icomp==2)) then + factor = gamma /(dx*dy*dz) +else + factor = 1.0 /(dx*dy*dz) +endif + +! Evaluate on an offset grid, for use in the indefinite integral evaluation below. +isize = size(cgrn,1); jsize=size(cgrn,2); ksize=size(cgrn,3) +umin = (0.5-isize/2) *dx +vmin = (0.5-jsize/2) *dy +wmin = (0.5-ksize/2) *dz + +! Add optional offset +if (present(offset)) then + umin = umin + offset(1) + vmin = vmin + offset(2) + wmin = wmin + offset(3)*gamma ! Don't forget this! +endif + +! !$ print *, 'OpenMP Green function calc osc_get_cgrn_freespace' +!$OMP PARALLEL DO & +!$OMP DEFAULT(FIRSTPRIVATE), & +!$OMP SHARED(cgrn) +do k = 0, ksize-1 + w = k*dz + wmin + + do j=0, jsize-1 + v=j*dy + vmin + + do i=0, isize-1 + u = i*dx + umin + + if(icomp == 0) gval=lafun2(u,v,w)*factor + if(icomp == 1) gval=xlafun2(u,v,w)*factor + if(icomp == 2) gval=xlafun2(v,w,u)*factor + if(icomp == 3) gval=xlafun2(w,u,v)*factor + cgrn(i,j,k)= cmplx(gval, 0, dp) + + enddo + enddo +enddo +!$OMP END PARALLEL DO + +! Evaluate the indefinite integral over the cube +!cgrn = cgrn(1:,1:,1:) - cgrn(:-1,1:,1:) - cgrn(1:,:-1,1:) - cgrn(1:,1:,:-1) - cgrn(:-1,:-1,:-1) + cgrn(:-1,:-1,1:) + cgrn(:-1,1:,:-1) + cgrn(1:,:-1,:-1) +! (x2,y2,z2) - (x1,y2,z2) - (x2,y1,z2) - (x2,y2,z1) - (x1,y1,z1) + (x1,y1,z2) + (x1,y2,z1) + (x2,y1,z1) +cgrn = cgrn(1:,1:,1:) - cgrn(0:,1:,1:) - cgrn(1:,0:,1:) - cgrn(1:,1:,0:) - cgrn(0:,0:,0:) + cgrn(0:,0:,1:) + cgrn(0:,1:,0:) + cgrn(1:,0:,0:) + +end subroutine osc_get_cgrn_freespace + + + +!------------------------------------------------------------------------ +!+ +! Subroutine osc_freespace_solver2(rho, gamma, delta, efield, phi, offset) +! +! Deposits particle arrays onto mesh +! +! Input: +! rho -- REAL64(:,:,:): charge density array in x, y, z +! delta -- REAL64(3): vector of grid spacings dx, dy, dz +! gamma -- REAL64: relativistic gamma +! icomp -- integer: Field component requested: +! 0: phi (scalar potential) +! +! +! efield -- REAL64(:,:,:,3), optional: allocated electric field array to populate. +! +! The final index corresponds to components +! 1: Ex +! 2: Ey +! 3: Ez +! If present, all components will be computed. +! +! phi -- REAL64(:,:,:), optional: allocated potential array to populate +! +! offset -- real(3), optional: Offset coordinates x0, y0, z0 to evaluate the field, +! relative to rho. +! Default: (0,0,0) +! For example, an offset of (0,0,10) can be used to compute +! the field at z=+10 m relative to rho. +! +! Output: +! efield -- REAL64(:,:,:,:) : electric field +! phi -- REAL64(:,:,:) : potential +! +! +! Notes: +! The magnetic field components can be calculated by: +! Bx = -Ey/(c*beta*gamma^2) +! By = Ex/(c*beta*gamma^2) +! Bz = 0 +! +!- +subroutine osc_freespace_solver2(rho, gamma, delta, efield, phi, offset) + + +real(dp), intent(in), dimension(:,:,:) :: rho +real(dp), intent(in) :: gamma, delta(3) +real(dp), optional, intent(out), dimension(:,:,:,:) :: efield +real(dp), optional, intent(out), dimension(:,:,:) :: phi +real(dp), intent(in), optional :: offset(3) +! internal arrays +complex(dp), allocatable, dimension(:,:,:) :: crho, cgrn +real(dp) :: factr, offset0=0 +real(dp), parameter :: clight=299792458.0 +real(dp), parameter :: fpei=299792458.0**2*1.00000000055d-7 ! this is 1/(4 pi eps0) after the 2019 SI changes + +integer :: nx, ny, nz, nx2, ny2, nz2 +integer :: icomp, ishift, jshift, kshift + +! Sizes +nx = size(rho, 1); ny = size(rho, 2); nz = size(rho, 3) +nx2 = 2*nx; ny2 = 2*ny; nz2 = 2*nz; + +! Allocate complex scratch arrays +allocate(crho(nx2, ny2, nz2)) +allocate(cgrn(nx2, ny2, nz2)) + +! rho -> crho -> FFT(crho) +crho = 0 +crho(1:nx, 1:ny, 1:nz) = rho ! Place in one octant +call ccfft3d(crho, crho, [1,1,1], nx2, ny2, nz2, 0) + +! Loop over phi, Ex, Ey, Ez +do icomp=0, 3 + if ((icomp == 0) .and. (.not. present(phi))) cycle + if ((icomp == 1) .and. (.not. present(efield))) exit + + call osc_get_cgrn_freespace(cgrn, delta, gamma, icomp, offset=offset) + + ! cgrn -> FFT(cgrn) + call ccfft3d(cgrn, cgrn, [1,1,1], nx2, ny2, nz2, 0) + + ! Multiply FFT'd arrays, re-use cgrn + cgrn=crho*cgrn + + ! Inverse FFT + call ccfft3d(cgrn, cgrn, [-1,-1,-1], nx2, ny2, nz2, 0) + + ! This is where the output is shifted to + ishift = nx-1 + jshift = ny-1 + kshift = nz-1 + + ! Extract field + factr = fpei/(nx2*ny2*nz2) + + if (icomp == 0) then + phi(:,:,:) = factr * real(cgrn(1+ishift:nx+ishift, 1+jshift:ny+jshift, 1+kshift:nz+kshift), dp) + else + efield(:,:,:,icomp) = factr * real(cgrn(1+ishift:nx+ishift, 1+jshift:ny+jshift, 1+kshift:nz+kshift), dp) + endif + +enddo + + +end subroutine osc_freespace_solver2 + end module diff --git a/code/test_opensc.f90 b/code/test_opensc.f90 index fb33b33..29e6a45 100644 --- a/code/test_opensc.f90 +++ b/code/test_opensc.f90 @@ -55,7 +55,7 @@ program opensc_test integer :: nxlo,nxhi,nylo,nyhi,nzlo,nzhi namelist / opensc_test_params / & nxlo,nxhi,nylo,nyhi,nzlo,nzhi, n_particle, e_tot, bunch_charge, sigma_x, sigma_y, sigma_z, gaussiancutoff, & - direct_field_calc, integrated_green_function, cathode_images, image_method,& + direct_field_calc, integrated_green_function, cathode_images, image_method,disttype,& rectpipe, read_rectpipe, write_rectpipe, apipe, bpipe ! if rectangular pipe BC is being used, apipe=full width, bpipe=full height !Namelist defaults @@ -67,11 +67,11 @@ program opensc_test bunch_charge=0.25d-9 sigma_x = 0.001d0; sigma_y = 0.001d0; sigma_z = 0.0001d0 gaussiancutoff=4 -disttype=0 ! =0 for uniform, =1 for Gaussian +disttype=1 ! =0 for uniform, =1 for Gaussian direct_field_calc = .true. ! .false. integrated_green_function = .true. -cathode_images=.true. -image_method=2 ! =1 for convolution/correlation, =2 for shifted Green function +cathode_images=.false. +image_method=3 ! =1 for convolution/correlation, =2 for shifted Green function , =3 Chris' method rectpipe=.false. read_rectpipe=.false. write_rectpipe=.false. @@ -154,6 +154,7 @@ program opensc_test write(6,*)'delta(1:3)=',delta(1:3) call depose_rho_scalar(ptcl(:,1),ptcl(:,3),ptcl(:,5),lostflag,rho,chrgpermacro,nlo,delta,umin,n_particle,nlo,ifail) + write(6,*)'Done with charge deposition' mesh3d%nlo = [nxlo, nylo, nzlo] @@ -176,13 +177,28 @@ program opensc_test if(.not.rectpipe.and..not.cathode_images)then !FREE SPACE print *, 'Space charge field calc with free-space boundary condition...' !!call osc_freespace_solver(rho,gamma,delta,phi,efield,bfield,nlo,nhi,nlo,nhi,npad,idirectfieldcalc,igfflag) - call space_charge_freespace(mesh3d, direct_field_calc, integrated_green_function) + !mesh3d%rho(:,:,33:)=0 + !call space_charge_freespace(mesh3d, direct_field_calc, integrated_green_function) + ! New method + print *, "Chris' method" + call space_charge_3d(mesh3d) + endif if(.not.rectpipe.and.cathode_images)then !FREE SPACE BUT WITH CATHODE IMAGES print *, 'Space charge field calc with cathode images...' if(umin(3).lt.0.d0)write(6,*)'error: umin(3) is less than zcathode!' if(umin(3).lt.0.d0)stop - call space_charge_cathodeimages(mesh3d, direct_field_calc, integrated_green_function, image_method) + + if (image_method == 3) then + print *, "Chris' method" + call space_charge_3d(mesh3d, at_cathode=.true.) + + else + call space_charge_cathodeimages(mesh3d, direct_field_calc, integrated_green_function, image_method) + endif + + + endif if(rectpipe)then !RECTANGULAR PIPE print *, 'Space charge field calc with rectangular pipe boundary condition...' diff --git a/examples/benchmark.ipynb b/examples/benchmark.ipynb new file mode 100644 index 0000000..7453ddb --- /dev/null +++ b/examples/benchmark.ipynb @@ -0,0 +1,713 @@ +{ + "cells": [ + { + "cell_type": "markdown", + "id": "compound-teens", + "metadata": {}, + "source": [ + "# OpenSpaceCharge tests\n", + "\n", + "This notebook will run the test_opensc program, and reproduce the benchmark plots in:\n", + "\n", + "C. E. Mayes, R. D. Ryne, D. C. Sagan, *3D Space Charge in Bmad*, IPAC2018, Vancouver, BC, Canada\n", + "https://accelconf.web.cern.ch/ipac2018/papers/thpak085.pdf\n" + ] + }, + { + "cell_type": "code", + "execution_count": 1, + "id": "latter-pregnancy", + "metadata": {}, + "outputs": [], + "source": [ + "import numpy as np\n", + "\n", + "import subprocess\n", + "import tempfile\n", + "import os\n", + "import time\n", + "\n", + "import matplotlib.pyplot as plt\n", + "import matplotlib\n", + "matplotlib.rcParams['figure.figsize'] = (8,6)\n", + "%config InlineBackend.figure_format = 'retina'" + ] + }, + { + "cell_type": "code", + "execution_count": 2, + "id": "plain-correction", + "metadata": {}, + "outputs": [], + "source": [ + "# Executable \n", + "TEST_BIN = os.path.abspath('../build/test_opensc')" + ] + }, + { + "cell_type": "code", + "execution_count": 3, + "id": "physical-passport", + "metadata": {}, + "outputs": [], + "source": [ + "# Change any of this to test\n", + "\n", + "PARAMS = \"\"\"\n", + "&OPENSC_TEST_PARAMS\n", + " NXLO=1 ,\n", + " NXHI=64 ,\n", + " NYLO=1 ,\n", + " NYHI=64 ,\n", + " NZLO=1 ,\n", + " NZHI=64 ,\n", + " N_PARTICLE=1000000 ,\n", + " E_TOT= 0.51099891e6 ,\n", + " BUNCH_CHARGE= 1e-9,\n", + " DISTTYPE = 1, \n", + " SIGMA_X= 1e-3,\n", + " SIGMA_Y= 1e-3,\n", + " SIGMA_Z= 1e-3,\n", + " GAUSSIANCUTOFF= 4 ,\n", + " DIRECT_FIELD_CALC=T,\n", + " INTEGRATED_GREEN_FUNCTION=T,\n", + " CATHODE_IMAGES=F,\n", + " IMAGE_METHOD=1 ,\n", + " RECTPIPE=F,\n", + " READ_RECTPIPE=F,\n", + " WRITE_RECTPIPE=F,\n", + " APIPE= 1.2000000000000000E-002,\n", + " BPIPE= 1.2000000000000000E-002,\n", + " /\n", + "\n", + "\"\"\"\n", + "\n", + "with open('test.in', 'w') as f:\n", + " f.write(PARAMS)" + ] + }, + { + "cell_type": "code", + "execution_count": 4, + "id": "false-programmer", + "metadata": {}, + "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + " ------------------------\n", + "&OPENSC_TEST_PARAMS\n", + " NXLO=1 ,\n", + " NXHI=64 ,\n", + " NYLO=1 ,\n", + " NYHI=64 ,\n", + " NZLO=1 ,\n", + " NZHI=64 ,\n", + " N_PARTICLE=1000000 ,\n", + " E_TOT= 510998.90999999997 ,\n", + " BUNCH_CHARGE= 1.0000000000000001E-009,\n", + " SIGMA_X= 1.0000000000000000E-003,\n", + " SIGMA_Y= 1.0000000000000000E-003,\n", + " SIGMA_Z= 1.0000000000000000E-003,\n", + " GAUSSIANCUTOFF= 4.0000000000000000 ,\n", + " DIRECT_FIELD_CALC=T,\n", + " INTEGRATED_GREEN_FUNCTION=T,\n", + " CATHODE_IMAGES=F,\n", + " IMAGE_METHOD=1 ,\n", + " DISTTYPE=1 ,\n", + " RECTPIPE=F,\n", + " READ_RECTPIPE=F,\n", + " WRITE_RECTPIPE=F,\n", + " APIPE= 1.2000000000000000E-002,\n", + " BPIPE= 1.2000000000000000E-002,\n", + " /\n", + " ------------------------\n", + " gamma= 1.0000000000000000 \n", + " beta0= 0.0000000000000000 \n", + " particle xmin,xmax= -3.9826073840537940E-003 3.9869615736364229E-003\n", + " particle ymin,ymax= -3.9509672876726944E-003 3.9790345163215803E-003\n", + " particle zmin,zmax= -3.8981835420025877E-003 3.9605290566242009E-003\n", + " added zcentroid to z particle data, where zcentroid= 0.0000000000000000 \n", + " Done computing initial 3D Gaussian spatial distribution w/ cold velocity distribution\n", + " mesh xmin,xmax= -4.1132560554917492E-003 4.1176102450743799E-003\n", + " mesh ymin,ymax= -4.0809673172467788E-003 4.1090345458956682E-003\n", + " mesh zmin,zmax= -4.0270148960788394E-003 4.0893604107004574E-003\n", + " delta(1:3)= 1.3064867143755760E-004 1.3000002957368962E-004 1.2883135407586185E-004\n", + " Done with charge deposition\n", + " Space charge field calc with free-space boundary condition...\n", + " Chris' method\n", + " ...done\n", + " Time for space charge calc (s): 3.2612119999999996 \n" + ] + } + ], + "source": [ + "!../build/test_opensc test.in" + ] + }, + { + "cell_type": "markdown", + "id": "cloudy-columbus", + "metadata": {}, + "source": [ + "# Parsers" + ] + }, + { + "cell_type": "code", + "execution_count": 5, + "id": "placed-experience", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "[]" + ] + }, + "execution_count": 5, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAAA9gAAALfCAYAAACaWGp9AAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAACHKElEQVR4nOzddXiUV8L+8fvESQgJIcFdg7tr3bfuBnXZbtvd7Xbf3Xa3Xd/u1t2AUqpbdwWKu7u7hASIEp3z/jHDZJISCGSSZ+T7ua5ck+eMcPP7vdvk5jlirLUCAAAAAAA1E+F0AAAAAAAAQgEFGwAAAAAAP6BgAwAAAADgBxRsAAAAAAD8gIINAAAAAIAfULABAAAAAPADCjYAAAAAAH5AwQYAAAAAwA8o2AAAAAAA+AEFGwAAAAAAP6BgAwAAAADgBxRsAAAAAAD8gIINAAAAAIAfULABAAAAAPADCnYNGGMuM8Y8a4yZYYzJMcZYY8zkWvhzehpjJhljdhhjiowxGcaYn4wxN/j7zwIAAAAAnJwopwMEuYck9ZaUJ2mnpHR//wHGmLGSXpNUIOkLSVslJUvqIelcSZP8/WcCAAAAAE4cBbtm7pe7WG+UNFrSVH9+uDFmiNzleqWks621eys9H+3PPw8AAAAAcPKYIl4D1tqp1toN1lpb3fcYY642xkw1xhw0xhQaY9YYYx4yxsQe5eWPSYqUdF3lcu3580tqEB8AAAAA4Efcwa5DxpjXJd0k913vjyQdkjRE0l8lnWaMOcNaW+p5bUtJIyUtlLTKGHOKpP6SrKSlkqZaa111/XcAAAAAABwdBbuOeNZS3yTpY0nXWmsP+zz3iKQ/S7pb0tOe4YGexw2SpkgaU+kjVxhjLrHWbqy91AAAAACA6mKKeN25V1KppJt8y7XHXyVlSbrWZ6yx5/EKSV0lXSIpSVJHSW9K6inpS2NMTG2GBgAAAABUD3ew64AxJl7u3cYzJd1njDnay4rkLtJHRPo83mKt/cJznWOMudHz2gGSLpX0Tm3kBgAAAABUHwW7bjSUZCSlyT0VvDoOeh6LJH3l+4S11hpjPpW7YA8SBRsAAAAAHMcU8bqR7XlcYq01x/ryec86z2NuFZuZHSng9WotNQAAAACg2ijYdcBamydplaTuxpiUar5tudxTylONMU2O8nwPz+PWmicEAAAAANQUBbvuPCEpRtJ4Y0xy5SeNMQ2NMf2OXHuO63rZc/mYMSbC57U9JY2Ve9O0D2oxMwAAAACgmoy11ukMQcsYc5GkizyXTSWdJWmzpBmesUxr7W99Xv+8pLskHZD0raTtklIktZM0StIEa+0dPq+Pl/Sj3GdlL5E0Te513JfKPTX8N9baJ2rlLwcAAAAAOCEU7BrwOb+6KtustW0rved8SXfIvTlZstxle7uk7yRNttaurfT6eEm/k3SV3EW8UNICSY9ba7/2x98DAAAAAFBzFGwAAAAAAPyANdgAAAAAAPgBBRsAAAAAAD+gYAMAAAAA4AcUbAAAAAAA/CDK6QDBxhizRVIDSVsdjgIAAAAA8L+2knKste1O9I0U7BPXoF69eildu3ZNcToIAAAAAMC/1qxZo8OHD5/UeynYJ25r165dUxYtWuR0DgAAAACAn/Xv31+LFy/eejLvZQ02AAAAAAB+QMEGAAAAAMAPKNgAAAAAAPgBBRsAAAAAAD+gYAMAAAAA4AcUbAAAAAAA/ICCDQAAAACAHwREwTbGNDLG3GKM+dgYs9EYc9gYk22MmWmMudkYc0I5jTEtjTHjjTG7jTFFxpitxpinjDENa+vvAAAAAAAIb1FOB/C4XNKLkvZImippu6Qmki6R9Jqkc4wxl1tr7fE+yBjTQdJsSY0lfSppraRBku6VdLYxZri1NqtW/hYAAAAAgLAVKAV7vaRfSPrSWus6MmiM+YOk+ZIulbtsf1iNz3pB7nL9K2vtsz6f9YSk+yX9XdId/osOAAAAAECATBG31k6x1n7uW64943slveS5HHO8zzHGtJd0pqStkp6v9PSfJeVLut4Yk1DTzAAAAAAA+AqIgn0cJZ7H0mq89lTP43dHKeu5kmZJipc0xH/xAAAAAAAI8IJtjImSdIPn8ptqvKWL53F9Fc9v8Dx2rkkuAAAAAAAqC5Q12FX5l6Qekr6y1n5bjdcneR6zq3j+yHjy8T7IGLOoiqfSq5EDAAAAABBmAvYOtjHmV5J+I/cu4Nf762M9j8fdjRwAAAAAgBMRkHewjTF3S3pa0mpJp1lrD1TzrUfuUCdV8XyDSq+rkrW2fxXZFknqV808AAAAAIAwEXB3sI0x90l6TtJKSad4dhKvrnWex6rWWHfyPFa1RhsAAAAAgJMSUAXbGPOgpCclLZW7XGec4EdM9TyeaYyp8HczxiRKGi7psKS5NYwKAAAAAEAFAVOwjTEPy72p2SK5p4VnHuO10caYdGNMB99xa+0mSd9Jaivp7kpve1RSgqRJ1tp8f2YHAAAAACAg1mAbY26U9BdJZZJmSPqVMabyy7Zaayd6vm8haY2kbXKXaV93SZot6RljzGme1w2WdIrcU8P/6P+/AQAAAAAg3AVEwZbUzvMYKem+Kl7zk6SJx/sga+0mY8wAuQv72ZLOlbRH0jOSHj2BDdMAAAAAAKi2gCjY1tpHJD1yAq/fqvIjt472/A5J42qaCwAAAACA6gqYNdgAAAAAAAQzCjYAAAAAAH5AwQYAAAAAwA8o2AAAAAAA+EFAbHIGAACA4GetVVZ+sbYfKNAOz1duUak6pNZXerNEdWqcqHoxkU7HBIBaQ8EGAABAteUXlWrHwQLtOHDYW6R3HizwfH9Yh0vKqnxvhJHapiYovWmi0ps28D62bFhPERFVHhADAEGDgg0AAIBj2p5VoP9+t06zNmYqK7/4pD/HZaXN+/O1eX++vlqx1zueEBOpLk0Tld7MXbq7NWugPq2SFRXJakYAwYWCDQAAgKMqKC7VC1M36ZUZm1Vc6qrWexJjo9QqJV6tUuqpdUq86sVEaWNGrtbuydWWrHxZ+/P35BeXafH2Q1q8/ZB3rEVyPd04rI2uHNBaSfHRfvobAUDtomADAACgAmutPlu2W//8aq325hRWeC460qhFcj1PiY5X65R4tWpYXqiT6kXLmKNP9z5cXKYNnrK9Zm+O1u3N1Zo9OTpYUPKz1+46dFj/+Gqtnvx+gy7t30Jjh7VTx8b1a+XvCwD+QsEGAACA18pd2Xr081VasPVghfHerZL18Hld1bd1Q0We5HrpejGR6tUyWb1aJnvHrLXan1ukNXtztW5vjtbsydW0dRne0n24pEyT527X5LnbNapzmsYNb6vRndJYsw0gIFGwAQAAoKy8Iv33u/V6d8H2CtO4U+vH6sGzu+jSfi1rpdQaY9S4QZwaN4jT6M5pkqTCkjJ9unSXJszaqrV7c72vnb5+v6av36/2aQkaN6ytLunXUgmx/DoLIHAYe7SFMKiSMWZRv379+i1atMjpKAAAADVWUubS5Lnb9OT365VTWOodj440Gje8ne45taMS45xZA22t1ZzNWRo/c6t+XLvvZ+u3E+OidNXAVrphaFu1Sol3JCOA0NO/f38tXrx4sbW2/4m+l3/yAwAACFMzN2Tq0c9XaUNGXoXxMV3S9Kfzu6l9mrNrno0xGtYhVcM6pGpbVr7emL1N/1u4Q7lF7n8IyC0s1asztuj1mVt0Zremuvf0TurarIGjmQGENwo2AABAmNlxoEB/+3K1vl21r8J4u9QEPXx+V52a3sShZFVr0yhBf7qgm359Zmd9sHCHJs7eqq1ZBZLcx399s2qvpqzN0O/PSde44W2r3GgNAGoTBRsAACCMTFuXoTsnL9bhkjLvWEJMpO45rZPGDW+r2KhIB9MdX/3YKI0d3k43DG2raeszNH7mVs3cmClJKi5z6S9frNasjZn6z+W9lZIQ43BaAOEmwukAAAAAqBvfrNyjWyctrFCuL+nXQlN/O0Z3jO4Q8OXaV0SE0anpTTT5lsH6+t6R6tGifGr4j2szdM7T0zVnU5aDCQGEIwo2AABAGPho8U7d/fYSlZS5dwprkVxPH901TE9c0UeNG8Q5nK5mujZroA/vHKabR7Tzju3LKdI1r83V49+tU2mZy8F0AMIJBRsAACDEvTl3m379/jKVudzlun1qgv53x1D1a93Q4WT+ExsVqYfP76YJYwd6p4ZbKz07ZaOuemWudh067HBCAOGAgg0AABDCXv5pkx7+ZKX3Or1pot67faiaJ9dzMFXtOSW9sb6+d6SGdWjkHVu47aDOeWq6vlm5x8FkAMIBBRsAACAEWWv1xHfr9M+v13rHerdK1ru3DVFaYqyDyWpfkwZxevPmwXrgrC6KjHDvJp5TWKo7Ji/WQ5+sUKHPGnQA8CcKNgAAQIix1uqvX6zRM1M2eseGtE/RW7cMVnJ8eOysHRlhdPcpHfX+7UPUwudu/eS523Xhc7O0fl+ug+kAhCoKNgAAQAgpc1n930crNH7WFu/YmC5pmjhukOrHht8Jrf3bpOire0fq3J5NvWPr9uXqF8/N1Nvztsta62A6AKGGgg0AABAiSspcuu+9pXp3wQ7v2Lk9m+qV6wcoLjp4juDyt6R60Xr+mn76x8U9FRvl/vW3sMSlP3y8Qve+u1RFpUwZB+AfFGwAAIAQUFhSpjsnL9Lny3Z7xy7r31LPXNVXMVH8ymeM0TWDW+vze0aoc5P63vHPlu3WuAkLlFtY4mA6AKGC/9oCAAAEufyiUt38xgL9sCbDO3bj0DZ67NJeiork1z1fnZsk6rNfjtDVg1p5x2ZvytJVr8zV/twiB5MBCAX8FxcAACCIZR8u0Q3j52vWxizv2J1jOuiRX3RXhGcHbVQUFx2pf1zcUw+c1cU7tmp3ji57aba2ZeU7mAxAsKNgAwAABKnsghJd8+pcLdp20Dv2wFld9ODZ6TKGcn0sxrh3Gf/3pT115N8htmUV6NIXZ2vlrmxnwwEIWhRsAACAIPXHT1Zo1e4c7/UjF3TT3ad0dDBR8LlyYGu9fP0A7+ZnmXnFuuqVuZq9MdPhZACCEQUbAAAgCH22bLe+WL7He/3vS3tq7PB2DiYKXmd0a6LJtwxWgzj3MWZ5RaUaO2GBvvT5f18AqA4KNgAAQJDZm12ohz5e4b2+ckArXTmwtYOJgt/Atin63x3D1KRBrCSpuMylX76zWG/O2epsMABBhYINAAAQRKy1euCDZcopLJUktWxYTw9f0M3hVKGhS9NEfXjnMLVPS5AkWSs9/OkqPfHdOllrHU4HIBhQsAEAAILI5HnbNWODe32wMdLjl/dW/dgoh1OFjpYN4/XBHcPUu1Wyd+yZKRv1h49XqsxFyQZwbBRsAACAILElM1//+HKN9/rWke01uH0jBxOFppSEGL1z62CN7pzmHXtn/nbd9dYiFZaUOZgMQKCjYAMAAASB0jKXfv3+Uh32FLwuTRL16zM6O5wqdMXHROm1Gwfo4r4tvGPfrtqnG8bPV/bhEgeTAQhkFGwAAIAg8PL0zVqy/ZAkKTrS6IkreysuOtLZUCEuOjJCj1/eW7eOLN+dff6WA7rqlbk6kF/sYDIAgYqCDQAAEOBW7srWk9+v917fd3pndW+e5GCi8BERYfTH87rpD+eme8fW7MnRNa9SsgH8HAUbAAAggBWWlOnX7y9VqWeDrb6tk3X7qPYOpwo/t43qoP9c1kvGuK/X7s2lZAP4GQo2AABAAHv8u3Vavy9PklQvOlJPXNFHUZH8CueEywe00hNX9KZkA6gS/3UGAAAIUHM3Z+m1mVu81384r6vapSY4mAgX921JyQZQJQo2AABAAMotLNFv/7dM1nP08qjOabpucGtnQ0ESJRtA1SjYAAAAAeivX6zWzoOHJUlJ9aL12KW9ZI40OjiOkg3gaCjYAAAAAeb71fv0/sKd3uu/XtRDTZPiHEyEo6FkA6iMgg0AABBAsvKK9H8fLfden9+rmX7Ru7mDiXAsR0p2BCUbgCjYAAAAAcNaqz98vEKZee5y1jgxVn+7qIfDqXA8F/dtqccp2QBEwQYAAAgYHy3epW9X7fNeP3ZZLyXHxziYCNVFyQYgUbABAAACwq5Dh/XIZ6u819cObq0xXRo7mAgnipINgIINAAAQAB77Zq1yi0olSW0axesP53Z1OBFOBiUbCG8UbAAAAIet25urz5bt9l7/57LeSoiNcjARaqKqkp1dUOJsMAC1joINAADgsCe/Xy9r3d+flt5Yg9qlOBsINXa0kn3rmwtVWFLmbDAAtYqCDQAA4KAVO7P1zaq93uv7z+jsYBr408V9W+q/l/f2Xs/fckC/fn+pylzWwVQAahMFGwAAwEFPfL/O+/25PZuqR4skB9PA3y7p11J/9FlP/9WKvfrrF6tlLSUbCEUUbAAAAIcs2nZAU9ftlyQZI91/OnevQ9EtI9vppuHtvNcTZ2/VK9M3O5gIQG2hYAMAADjk8e/We7+/qE8LdWqS6GAa1BZjjB46r6vO69XMO/bPr9fqkyW7HEwFoDZQsAEAABwwe2OmZm/KkiRFRhjde1onhxOhNkVEGD1+eW8N9tnA7oEPlmnmhkwHUwHwNwo2AABAHbPW6vHvy+9eX96/pdqmJjiYCHUhLjpSr9wwQJ2b1JcklZRZ3TF5kVbtznY4GQB/oWADAADUsWnr92vRtoOSpJjICN3D3euwkVQvWm/cNEjNkuIkSXlFpRo7YYF2HChwOBkAf6BgAwAA1CFrrR7/rnzn8KsHtVKL5HoOJkJda5ZUTxPHDVJiXJQkaX9ukW6cMF8H84sdTgagpijYAAAAdejbVfu0cleOJCk2KkJ3n9LR4URwQpemiXr1hgGKiXT/Or55f75ufmOBCkvKHE4GoCYo2AAAAHWkzGUrnHt947C2atwgzsFEcNKQ9o305JV9ZIz7evH2Q7rnnSUqLXM5GwzASaNgAwAA1JEvlu/W+n15kqSEmEjdPqq9w4ngtPN6NdOfzu/mvf5+9T796bNVstY6mArAyaJgAwAA1IHSMpee+mGD9/qmEe3UqH6sg4kQKMYNb1fhH1venrddz0/d6GAiACeLgg0AAFAHPlqyS1sy8yVJDeKidMtI7l6j3INnp+vCPs291//9br3+t3CHg4kAnAwKNgAAQC0rLnXpaZ+717eNaq+ketEOJkKgiYgw+s9lvTW8YyPv2O8/WqFp6zIcTAXgRAVEwTbGXGaMedYYM8MYk2OMscaYySfxOVs97z3a197ayA4AAHA87y3coV2HDkuSUhJiNHZ4O4cTIRDFREXopev6q2uzBpLcm+Ld9dZirdyV7XAyANUV5XQAj4ck9ZaUJ2mnpPQafFa2pKeOMp5Xg88EAAA4KYUlZXpuSvnd6ztHd1D92ED5FQyBJjEuWhPHDdQlL8zWrkOHVVBcprETFujju4apVUq80/EAHEeg/Nf9frmL9UZJoyVNrcFnHbLWPuKPUAAAADU1ee427cspkiQ1TozVdUPaOJwIga5JgzhNHDdQl744WzmFpcrMK9KNE+brwzuGqWFCjNPxABxDQEwRt9ZOtdZusJxHAAAAQkh+UalenLbJe/3LUzuqXkykg4kQLDo1SdSrNwxQTKT71/XN+/N1y6SFKiwpczgZgGMJiILtZ7HGmOuMMX8wxtxrjDnFGMNPMgAAUOcmzt6qrPxiSVKL5Hq6cmArhxMhmAxu30hPXNnbe71o20Hd++4Slbm4JwUEqkCZIu5PTSW9WWlsizFmnLX2p+p+iDFmURVP1WR9OAAACBPZh0v08k/ld69/dVpHxUbxb/44Mef3aq692YX625drJEnfrtqnv36xWn++oJuMMQ6nA1BZqN3BniDpNLlLdoKknpJeltRW0tfGmN5VvxUAAMB/Xp+5RTmFpZKkto3idUm/lg4nQrC6ZWR73eSz8/zE2Vv16ozNDiYCUJWQuoNtrX200tBKSXcYY/Ik/UbSI5IuruZn9T/auOfOdr8axAQAACHuQH6xxs/c4r2+7/TOio4MtfsaqEsPnddV+3IK9eWKPZKkf3y1Vk2T6ukXvZs7nAyAr3D5L/1LnsdRjqYAAABh4fWZm5VX5L573alxfV1ACUINRUQYPX5Fbw1s29A79tv3l2nOpiwHUwGoLFwKdobnMcHRFAAAIOQVl7r07vwd3uv7Tu+syAjWyqLm4qIj9eoNA9SxcX1JUnGZS7e9uVDr9uY6nAzAEeFSsId6HlmsAgAAatW3q/Z6dw5vnhSns3s0dTgRQklyfIwmjhuotMRYSVJuYanGTpivvdmFDicDIAVhwTbGRBtj0o0xHSqNdzfGpBzl9W0kPee5nFwXGQEAQPh6a9427/dXDmzN3Wv4XcuG8Zo4bqASPGeq78ku1NgJ85VTWOJwMgABUbCNMRcZYyYaYyZK+r1neOiRMWPMf31e3kLSGkk/VvqYyyXtNsZ8bYx5wRjzb2PMB5LWSuoo6StJ/xUAAEAt2ZiRp7mbD0iSIiMM516j1nRvnqQXr+uvKM8/4Kzdm6s73lyk4lKXw8mA8BYQBVtSH0k3er7O8oy19xm7rBqfMVXSx5LaSbpG0q8ljZY00/MZ51tri/2aGgAAwMfb87Z7vz+9a2M1TYpzMA1C3ajOafrXpb2817M3Zel3HyyTy2UdTAWEt4A4psta+4jcR2hV57VbJf1srpW19idJP/kzFwAAQHUVlpTpw8U7vdfXDm7jYBqEi8v6t9Te7MP673frJUmfLN2tZsn19ODZ6Q4nA8JToNzBBgAACGpfLt+j7MPuNbCtU+I1omOqw4kQLu4+paOuHtTae/3itE16c+62Y7wDQG2hYAMAAPiB7+ZmVw9qrQg2N0MdMcborxd216npjb1jf/50pb5fvc/BVEB4omADAADU0Jo9OVq8/ZAkKTrS6PIBLZ0NhLATFRmh567pq14tkyRJLivd885iLd1xyNlgQJihYAMAANSQ7+ZmZ3VvqtT6sQ6mQbiKj4nS6zcOVKuUepKkwhKXbp64QNuy8h1OBoQPCjYAAEAN5BeV6uMlu7zXbG4GJ6UlxuqNcYPUMD5akpSVX6wbx89XVl6Rw8mA8EDBBgAAqIHPlu1WXlGpJKl9WoKGtE9xOBHCXfu0+nrtxgGKjXL/qr81q0C3TFqow8VlDicDQh8FGwAAoAZ8Nze7dnAbGcPmZnBe/zYpevqqPjryf45Lth/Sr95dojLOyAZqFQUbAADgJC3feUgrd+VIkmKiInRpvxYOJwLKnd2jmf50fjfv9fer9+nRz1fJWko2UFso2AAAACfprbnlm5ud36uZkuNjHEwD/Ny44e1068h23utJc7bplembHUwEhDYKNgAAwEnIPlyiz5bt9l6zuRkC1f+d01Xn9Wrmvf7n12sr/N8uAP+hYAMAAJyET5bs0uES96ZR6U0T1a91srOBgCpERBg9fnlvDWpXvgHfb99fprmbsxxMBYQmCjYAAMAJstZWOPv62sGt2dwMAS0uOlKvXN9fHRvXlyQVl7l026SFWr8v1+FkQGihYAMAAJygRdsOap2nmMTHROqivmxuhsCXHB+jieMGKi0xVpKUU1iqsePna19OocPJgNBBwQYAADhBb/ncvb6wT3MlxkU7mAaovpYN4zVh7EAlxERKknZnF2rshAXKLSxxOBkQGijYAAAAJ+BgfrG+XLHHe33NIDY3Q3Dp0SJJL1zXX5ER7mUNa/bk6PY3F6motMzhZEDwo2ADAACcgA8X71RxqUuS1Ktlknq2THI4EXDiRndO0z8v6em9nr0pS/e/t1RlLs7IBmqCgg0AAFBN1toK08OvHdzawTRAzVwxoJUeOKuL9/qrFXv1p09XylpKNnCyKNgAAADVNGdTlrZk5kuSEmOjdEHv5g4nAmrmrjEdNHZYW+/1W/O266kfNjgXCAhyFGwAAIBq8r17fXG/FoqPiXIwDVBzxhj96fxu+oXPPxY9/eMGvTl3m4OpgOBFwQYAAKiG/blF+nbVXu/1NUwPR4iIiDD67+W9NapzmnfsT5+u1JfL9xzjXQCOhoINAABQDe8v3KFSzwZQA9o0VHrTBg4nAvwnJipCL17bT71bJUuSrJXue2+JZm3MdDYYEGQo2AAAAMdR5rJ6Z77P5mZDuHuN0JMQG6UJYweqfVqCJKmkzOq2SQu1Yme2w8mA4EHBBgAAOI7pG/Zr58HDkqTk+Gid06OZw4mA2pGSEKM3bx6spg3iJEn5xWUaO2G+d3M/AMdGwQYAADiOt302N7usX0vFRUc6mAaoXS2S62nSzYOUVC9akpSVX6zrX5+nfTmFDicDAh8FGwAA4Bj2ZB/Wj2v2ea+vZnMzhIHOTRI1fuxAxUW768LOg4d14/j5yj5c4nAyILBRsAEAAI7h3fk75NnbTEPbN1KHtPrOBgLqSP82DfXitf0VGWEkSWv35uqWNxaosKTM4WRA4KJgAwAAVMFaq4+X7PJeczQXws0p6Y31n8t6ea8XbD2oX769RKVlLgdTAYGLgg0AAFCFVbtztP1AgSSpfmyUzujWxOFEQN27pF9L/fHcrt7rH9bs0x8+XiFrrYOpgMBEwQYAAKjCF8v3eL8/o1sTNjdD2Lp1VHvdPrq99/r9hTv19y/XULKBSijYAAAAR2Gt1Vcrygv2eT05mgvh7fdnp+uy/i2916/N3KL/fLuOkg34oGADAAAcxcpd5dPDE2OjNLJzqsOJAGcZY/SvS3rqrO7lSyVemLZJz/y40cFUQGChYAMAABzFFyt2e78/o1sTxUYxPRyIiozQs1f302npjb1jT/6wXi9O2+RgKiBwULABAAAq+dn08F5MDweOiImK0PPX9tPITuWzOv79zVq9NmOzg6mAwEDBBgAAqGTFrmztOHBYknt6+IhOTA8HfMVFR+rVGwZoaPtG3rG/fblGb87Z6lwoIABQsAEAACr50nf38O5MDweOJi46Uq+PHaCBbRt6xx7+dJXenb/dwVSAsyjYAAAAPqy1+tJnevj5TA8HqhQfE6XxYweqT6tk79j/fbxCHy7a6VwowEEUbAAAAB/Ld2Zr50HP9PC4KI3omOZwIiCwJcZF642bBqlHiwaSJGulBz5Yps+X7T7OO4HQQ8EGAADw4bu52Zndmiomil+XgONJqhetN28arPSmiZIkl5Xue2+pvlm55zjvBEILPzEAAAA8rLX6YjnTw4GT0TAhRpNvGaxOjetLkspcVve8s0Q/rtnncDKg7lCwAQAAPJbtzNauQ+7p4Q3iojS8I7uHAycitX6s3rplsNqlJkiSSsqs7py8WD+t3+9wMqBuULABAAA8KkwP7870cOBkNG4Qp7dvHazWKfGSpOIyl26btFCzN2Y6nAyoffzUAAAAkGf3cJ/p4ef1ZHo4cLKaJdXT27cOVovkepKkolKXbn5joeZvOeBwMqB2UbABAAAkLd1xiOnhgB+1bBivt28drCYNYiVJh0vKNHbCfM3bnOVwMqD2ULABAABUcXr4WUwPB/yiTaMEvX3rEKUlukt2QXGZxk1cQMlGyOInBwAACHuVp4efy+7hgN90SKuvdyqV7LETFmguJRshiIINAADC3pIdh7Q7u1CS+zzf4R2YHg74U8fGFUv24ZIyjZuwQHM2UbIRWijYAAAg7H213Hd6eBOmhwO1oGPj+nr3tiFq7FuyJ87X7E3sLo7QwU8PAAAQ1lwuW2H99bnsHg7Umg5p7pJ9ZOOzwhKXbpq4gCO8EDIo2AAAIKwt3Vlpeji7hwO1qn1afb1729CKJfuNBZpFyUYIoGADAICw5ru52dndmyo6kl+PgNrWLjVB7942VE0bxEkqv5NNyUaw4ycIAAAIWz+bHs7u4UCdcZfsIWqW5C7ZRaXukj1zAyUbwYuCDQAAwtaSHYe0xzM9PDk+WsM6NHI4ERBe2h6lZN/8xgLN2LDf4WTAyaFgAwCAsMX0cMB5bRq5S3bzCiV7oaavp2Qj+PBTBAAAhCV2DwcCh7tkD1WL5HqSpOJSl26ZtFA/UbIRZCjYAAAgLC3ZcVB7c9zTwxvGR2so08MBR7VuFK93bxtSoWTfOmmhpq7LcDgZUH0UbAAAEJa+8JkefhbTw4GA0Crl5yX7tkkL9e2qvQ4nA6qHnyQAACDsuFxWX68o/4X9PHYPBwLGkZLdsqG7ZJeUWd311mJ9unSXw8mA46NgAwCAsLN4e6Xp4e2ZHg4EklYp8Xr/9qFql5ogSSpzWd333lK9t2C7w8mAY6NgAwCAsOM7PfzsHk0VxfRwIOA0T66n924foi5NEiVJ1koPfrhCE2dtcTgZUDV+mgAAgLDicll9vbK8YJ/Xs7mDaQAcS+PEOL172xD1aNHAO/bI56v14rRNDqYCqkbBBgAAYWXR9oPal1MkSUpJiNGQ9ikOJwJwLA0TYvTWLUPUr3Wyd+zf36zVE9+tk7XWuWDAUVCwAQBAWPmy0u7hTA8HAl9SvWi9efPgCvslPDNlo/7+5RpKNgJKQPxEMcZcZox51hgzwxiTY4yxxpjJJ/lZLY0x440xu40xRcaYrcaYp4wxDf2dGwAABBeXy+qrFeUF+3x2DweCRkJslCaMG6gxXdK8Y6/N3KKHPlkpl4uSjcAQEAVb0kOSfimpj6ST3n/fGNNB0iJJ4yTNl/SkpM2S7pU0xxjDFqEAAISxhdsOKiPXPT28UUKMBrdjejgQTOKiI/Xy9f11Vvcm3rG35m3XAx8sV2mZy8FkgFugFOz7JXWW1EDSnTX4nBckNZb0K2vtRdba31trT5W7aHeR9PcaJwUAAEHry+W7vd+fxe7hQFCKjYrU89f004V9yjco/HDxTt377lIVl1Ky4ayA+KlirZ1qrd1ga7CAwhjTXtKZkrZKer7S03+WlC/pemNMwkkHBQAAQcvlsvpm1V7v9fk9mR4OBKuoyAg9cUUfXTWwlXfsyxV7dOfkRSosKXMwGcJdQBRsPznV8/idtbbCP11Za3MlzZIUL2lIXQcDAADOW7Er27t7eHJ8tAYxPRwIapERRv+8pKfGDmvrHftxbYZueWOhCopLnQuGsBZKBbuL53F9Fc9v8Dx2roMsAAAgwHy3uvzu9WnpTZgeDoQAY4z+fEE33TWmg3ds5sZMXffaPB3ML3YwGcJVlNMB/CjJ85hdxfNHxpOr82HGmEVVPJV+ApkAAECA+H71Pu/3Z/pskAQguBlj9Luz0xUfE6n/fue+17Z4+yFd+tJsvTFukFqlxDucEOEknP7p1nge2cMfAIAwsyUzX+v35UmSYqMiNLJTqsOJAPjbL0/tpD9f0E3G81v/5v35uuTF2Vq5q6r7b4D/hVLBPvK/nKQqnm9Q6XXHZK3tf7QvSWtrGhQAANSt732mh4/slKb4mFCaxAfgiHHD2+m5q/spxrMEZH9uka56Za5mbNjvcDKEi1Aq2Os8j1Wtse7keaxqjTYAAAhRFaaHd2N6OBDKzuvVTJNuHqTEOPc/pOUVlWrchAX6aPFOh5MhHIRSwZ7qeTzTGFPh72WMSZQ0XNJhSXPrOhgAAHBOZl6RFm47KEmKMNJpXRs7nAhAbRvSvpE+uGOYmiXFSZJKXVa/fn+ZXpy2STU4GRg4rqAr2MaYaGNMujGmg++4tXaTpO8ktZV0d6W3PSopQdIka21+nQQFAAABYcqaDB35fXpAmxQ1qh/rbCAAdaJL00R9dNcwdWmS6B379zdr9chnq1TmomSjdgTEAiRjzEWSLvJcNvU8DjXGTPR8n2mt/a3n+xaS1kjaJneZ9nWXpNmSnjHGnOZ53WBJp8g9NfyP/k8PAAACme/xXGcwPRwIK82S6un9O4bqtkkLNW/LAUnSG3O2aV9OkZ66qo/ioiMdTohQEyh3sPtIutHzdZZnrL3P2GXV+RDPXewBkibKXax/I6mDpGckDbXWZvkzNAAACGwFxaWasSHTe03BBsJPUr1oTbp5kM7r1cw79s2qvbr+9Xk6VMBZ2fCvgCjY1tpHrLXmGF9tfV67tfJYpc/aYa0dZ61tZq2Nsda2sdbea609UFd/HwAAEBimr89UUalLktS5SX21TU1wOBEAJ8RGRerZq/rq5hHtvGMLth7UZS/N0a5Dhx1MhlATEAUbAACgNvhODz+zW9NjvBJAqIuIMHr4/G566Lyu3rGNGXm65IVZWr07x8FkCCUUbAAAEJJKy1yasjbDe31md6aHA5BuGdlez1zdV9GRRpK0L6dIV7w8RzN9lpMAJ4uCDQAAQtKCrQd1qKBEktS0QZx6tkhyOBGAQPGL3s31xk2DlBhbflb2jRPma/zMLRzjhRqhYAMAgJD0/ep93u/P6NZExhgH0wAINMM6pOr9O4aqSQP30X1lLqu/fLFav/nfMhWWlDmcDsGKgg0AAEKOtZbjuQAcV9dmDfTp3SPUu1Wyd+yjxbt0xctztJvNz3ASKNgAACDkrNmTq50H3b8cJ8ZGaUj7Rg4nAhComibF6b3bhujy/i29Y8t3ZusXz83Ugq0cRIQTQ8EGAAAhx3d6+CnpjRUTxa88AKoWFx2pxy7rpb9c2F1REe7lJJl5xbr6lbmaPHcb67JRbfy0AQAAIYfp4QBOlDFGNwxtq8m3DFZKQowkqdRl9dAnK/WHj1eoqJR12Tg+CjYAAAgpuw4d1irPmbbRkUZjuqQ5nAhAMBnSvpE+v2eEujdv4B17Z/4OXf3KXO3LKXQwGYIBBRsAAISU71eV370e2iFViXHRDqYBEIxaJNfTB3cM00V9mnvHFm8/pAuenanF2w86mAyBjoINAABCync+66/PZHo4gJNULyZST17ZRw+d11WeZdnKyC3SVS/P1XsLtjsbDgGLgg0AAEJGdkGJ5m0p3/WX9dcAasIYo1tGttekmwYrOd49G6a4zKUHP1yhhz9ZqeJSl8MJEWgo2AAAIGRMWbdPZS73br+9WyWrSYM4hxMBCAUjOqXqs7tHKL1ponfszbnbdM2rc7WL87Lhg4INAABCxvdMDwdQS1o3itdHdw3Teb2aeccWbjuoc5+eoW999n5AeKNgAwCAkFBYUqZp6/Z7rynYAPwtPiZKz13dVw+ena5Iz8Ls7MMluv3NRfrzpytVWMJRXuGOgg0AAELC7E2ZKih2/3LbLjVBHRvXdzgRgFBkjNGdYzrovduGqHlS+TKUN+Zs08UvzNam/XkOpoPTKNgAACAkVJ4eboxxMA2AUDegbYq+undkhdkya/bk6IJnZ+qDRTsdTAYnUbABAEDQc7msvl+d4b1m93AAdSE5PkYvX99ff7mwu2Ki3NWqoLhMv/3fMt3/3lLlFZU6nBB1jYINAACC3pIdh5SZVyRJSq0fo76tGzqcCEC4MMbohqFt9fFdw9Q+LcE7/vGSXTr/mRlauSvbwXSoaxRsAAAQ9L5bXb6D72npTbybDwFAXenePEmf/3KELuvf0ju2NatAl7wwW+NnbpG11sF0qCsUbAAAEPS+X+Wz/ro708MBOCMhNkr/vby3nryytxJiIiVJxWUu/eWL1bp10kIdzC92OCFqGwUbAAAEtY0ZedqcmS9Jio+J1PCOqQ4nAhDuLu7bUl/8aqR6tGjgHfthTYbOeXqG5m7OcjAZahsFGwAABDXf6eGjOqUpLjrSwTQA4NYuNUEf3jlMNw1v5x3bm1Ooq1+dq79+sZozs0MUBRsAAAS1CsdzMT0cQACJjYrUny7optduGKDk+GhJkrXS6zO36NynZ2jRtoMOJ4S/UbABAEDQysgp1JLthyRJkRFGp6Y3djYQABzF6d2a6Ot7R2pU5zTv2ObMfF3+0mz986s13M0OIRRsAAAQtH5YU3729aC2KUqOj3EwDQBUrVlSPb0xbqD+dUlP1Y+NkiS5rPTy9M06/9mZWrrjkLMB4RcUbAAAELR8118zPRxAoDPG6KpBrfXNfSM1vGMj7/jGjDxd8sIsPfbNWhWVcjc7mFGwAQBAUMorKtXsjeW78Z7RjYINIDi0bBivyTcP1t8u6qF4z3FeLiu9MG2TfvHsLK3Yme1wQpwsCjYAAAhKP63br+IylySpW7MGatkw3uFEAFB9xhhdN6SNvr1vlIa0T/GOr9uXq4temKUnvlun4lKXgwlxMijYAAAgKPlOD+fuNYBg1SolXm/fMkSP/qK76nmOGSxzWT0zZaMufH6WVu/OcTghTgQFGwAABJ3SMpemri3f4Iz11wCCWUSE0Y3D2urre0dqYNuG3vE1e3L0i+dm6snv17PTeJCgYAMAgKCzZMch5RSWSpKaNohTt2YNHE4EADXXNjVB7942VA+f302xUe6qVuqyevrHDTrrqekV/mERgYmCDQAAgs5P6/Z7vx/TJU3GGAfTAID/REYY3Tyinb66d6T6tU72jm/LKtC4iQt066SF2nGgwLmAOCYKNgAACDrT1pffxRnTJc3BJABQOzqk1df/7himv17YXQ3iorzj36/ep9Of+EnP/LiBaeMBiIINAACCSkZuoVbucm/6ExVhNLxjqsOJAKB2REYYXT+0rab8doyuGNDSO15U6tIT36/XWU9N15S1+xxMiMoo2AAAIKhMX5/p/b5/m4ZKjIt2MA0A1L7U+rF67LLe+vDOYerevHzPiW1ZBbpp4kLd8gbTxgMFBRsAAASVaet8p4c3djAJANSt/m0a6rNfjtBfL+qhpHrl/7j4wxr3tPGnfmC3cadRsAEAQNAoLXNpxobyO9isvwYQbiIjjK4f0kZTfjNaVw1s5R0vKnXpqR826Mwnp+vHNUwbdwoFGwAABI1lOw8p+3CJJKlJg1ilN010OBEAOKNR/Vj969Je+viuYerZIsk7vv1AgW5+Y6FumrhAGzNyHUwYnijYAAAgaEzzOZ5rdGeO5wKAvq0b6pO7h+vvF1ecNj5lbYbOfHK6/u+jFcrIKXQwYXihYAMAgKAxrcL516y/BgDJPW382sFtNPW3Y3T1oFY68m+PLiu9M3+7Rv9nmp74fr3yikqdDRoGKNgAACAoZOYVacWubEnuXyY5ngsAKkpJiNE/L+mlL+4ZoZGdyv8bebikTM/8uEFj/jNVb87dppIyl4MpQxsFGwAABIXp68vvXvdv3bDCVEgAQLnuzZP05s2DNemmQerarPxYr8y8Yj38yUqd9eR0fbNyr6y1DqYMTRRsAAAQFCqsv2b3cAA4rlGd0/TFPSP0+OW91Twpzju+OTNfd0xepMtemqNF2w44mDD0ULABAEDAK3NZTd/gu/6agg0A1REZYXRp/5aa8tsx+v056UqMi/I+t2jbQV364hzd/uZCbdqf52DK0EHBBgAAAW/ZzkM6VOA+nistMVbdfKY8AgCOLy46UneM7qDpD5yim0e0U0xkeRX8dtU+nfnkdP3x4xXak33YwZTBj4INAAACHsdzAYB/NEyI0cPnd9OPvxmtC/s0946Xuazemrddox+bpj9/ulJ7szna62RQsAEAQMD7aV2G93umhwNAzbVKidfTV/XV578coaHtG3nHi8tcemPONo36z1Q98tkqivYJomADAICAlpVXpOWe47kijDSyIwUbAPylZ8skvX2re8fxvq2TvePFpS5NnL3VW7T35VC0q4OCDQAAAtqMDZk6cpJMv9YNlRTP8VwA4E/GGI3qnKaP7hymieMGqk+rZO9zR4r2yMfcRTuDon1MFGwAABDQpjE9HADqhDFGY7o01sd3DdOEcQPVu2WS9znfov3o5xTtqlCwAQBAwHK5rKZvyPRej+nS2ME0ABAejDE6pUtjfXL3cE0YO1C9fIp2UalLE2a5i/ZfPl+tjFyKti8KNgAACFjLd2XrQH6xJCm1PsdzAUBdMsbolPTG+vTu4Ro/dsDPivb4WVs08t9T9YePV2hLZr6DSQNH1PFfAgAA4Azf6eGjOqcqIoLjuQCgrhljdGp6E53SpbGmrM3QUz9s0ArP5pNFpS69PW+73pm/XWd2a6LbRrVX/zYpDid2DgUbAAAELN/zr5keDgDOMsbotK5NdGp6Y/24JkNP/1hetK2Vvl21T9+u2qf+bRrqtlHtdUbXJmH3D6MUbAAAEJAO5Bdr2c5DktzHc43qlOpsIACAJHfRPr1bE53WtbHmbM7SK9M3V/gH0UXbDur2NxepXWqCbhnZTpf2a6m46EgHE9cd1mADAICANGPDfu/xXH1aJSs5PsbZQACACowxGtYhVRPHDdK3943SZf1bKjqy/I71lsx8/fHjlRr+ryl6+ocN3j01QhkFGwAABKSfmB4OAEGjS9NE/ffy3pr54Km6Y3QHJcaVT5bOyi/Wkz+s17B//ag/fbpS27JCd0M0CjYAAAg4LpfVT+t9CzbnXwNAMGjSIE6/Pyddc/7vND10Xlc1T4rzPldY4tKkOdt0yn+n6e63Fqu0zOVg0tpBwQYAAAFn5e5sZXmmEjZKiFGP5knHeQcAIJDUj43SLSPb66ffnaKnr+pT4ZhFl5UKS8oUFRl6dZRNzgAAQMDx3SxnVOe0sNuFFgBCRXRkhC7s00K/6N1cszZm6ZUZmzV9/X7dNqq909FqBQUbAAAEHN/zr5keDgDBzxijEZ1SNaJTqjbtz1P71ASnI9UKCjYAAAgohwqKtXTHIUmSMdLIThRsAAglHdLqOx2h1gTUpHdjTEtjzHhjzG5jTJExZqsx5iljTMMT+Iytxhhbxdfe2swPAABqbvqGTLk8x3P1bpmslASO5wIABIeAuYNtjOkgabakxpI+lbRW0iBJ90o62xgz3FqbVc2Py5b01FHG8/wQFQAA1CKmhwMAglXAFGxJL8hdrn9lrX32yKAx5glJ90v6u6Q7qvlZh6y1j/g9IQAAqFUul9X09Znea86/BgAEk4CYIm6MaS/pTElbJT1f6ek/S8qXdL0xJjRXwgMAAEnS6j05yswrkiSlJMSoVwuO5wIABI9AuYN9qufxO2tthdPGrbW5xphZchfwIZJ+rMbnxRpjrpPUWu5yvlzSdGttmR8zAwAAP/OdHj6yUyrHcwEAgkqgFOwunsf1VTy/Qe6C3VnVK9hNJb1ZaWyLMWactfan6gQyxiyq4qn06rwfAACcON/zr1l/DQAINgExRVzSkflf2VU8f2Q8uRqfNUHSaXKX7ARJPSW9LKmtpK+NMb1POiUAAKg12QUlWrz9oCT38VyjOJ4LABBkAuUO9vEcmR9mj/dCa+2jlYZWSrrDGJMn6TeSHpF0cTU+p/9Rg7jvbPc73vsBAMCJmbFxv/d4rl4tktSofqyzgQAAOEGBcgf7yB3qqnYyaVDpdSfjJc/jqBp8BgAAqCW+08NHs3s4ACAIBUrBXud57FzF8508j1Wt0a6OI7umsBM5AAABxuWy+mk9668BAMEtUAr2VM/jmcaYCpmMMYmShks6LGluDf6MoZ7HzTX4DAAAUAtW78nR/lz38VzJ8dHq3TLZ2UAAAJyEgCjY1tpNkr6TeyOyuys9/ajcd50nWWvzJckYE22MSTfGdPB9oTGmuzEmpfLnG2PaSHrOcznZz/EBAEAN+d69HtkpTZEczwUACEKBtMnZXZJmS3rGGHOapDWSBks6Re6p4X/0eW0Lz/Pb5C7lR1wu6ffGmKmStkjKldRB0nmS4iR9Jem/tfq3AAAAJ+wn3+O5OjM9HAAQnAKmYFtrNxljBkj6i6SzJZ0raY+kZyQ9aq09UI2PmSr3mdp95Z4SniDpkKSZcp+L/aa19rg7kQMAgLqTfbhEizzHc0nSKAo2ACBIBUzBliRr7Q5J46rxuq0qP7rLd/wnST/5PxkAAKgtszZmqsxzPlfPFklKS+R4LgBAcAqINdgAACB8TV2b4f2e3cMBAMGMgg0AABxjbeXjuTj/GgAQvCjYAADAMav35CjD53iuPq2SnQ0EAEANULABAIBjpq3jeC4AQOigYAMAAMdwPBcAIJRQsAEAgCM4ngsAEGoo2AAAwBEczwUACDUUbAAA4Ajf47lO4XguAEAIoGADAIA6V/l4rtEczwUACAEUbAAAUOc4ngsAEIoo2AAAoM5xPBcAIBRRsAEAQJ3jeC4AQCiiYAMAgDpV+Xiu0WxwBgAIERRsAABQp2ZuKD+eq1fLJKXW53guAEBooGADAIA6NW1d+fFcTA8HAIQSCjYAAKgzHM8FAAhlFGwAAFBnOJ4LABDKKNgAAKDOcDwXACCUUbABAECd8T2e6xR2DwcAhBgKNgAAqBOVj+caxQZnAIAQQ8EGAAB1guO5AAChjoINAADqBMdzAQBCHQUbAADUOo7nAgCEAwo2AACodRzPBQAIBxRsAABQ63yP5xrF8VwAgBBFwQYAALXO93iuMRzPBQAIURRsAABQqzieCwAQLijYAACgVnE8FwAgXFCwAQBAreJ4LgBAuKBgAwCAWsPxXACAcELBBgAAtYbjuQAA4YSCDQAAag3HcwEAwgkFGwAA1JoK6685ngsAEOIo2AAAoFZkHy7R4u2HvNcczwUACHUUbAAAUCs4ngsAEG4o2AAAoFZUnB7O7uEAgNBHwQYAAH5X+Xgu1l8DAMIBBRsAAPid7/FcDeOj1btlsrOBAACoAxRsAADgd77Hc43keC4AQJigYAMAAL/jeC4AQDiiYAMAAL/ieC4AQLiiYAMAAL/yPZ6rN8dzAQDCCAUbAAD4le/08NEczwUACCMUbAAA4DcczwUACGcUbAAA4De+x3MlczwXACDMULABAIDf+B7PNYrjuQAAYYaCDQAA/MZ3/fUp6UwPBwCEFwo2AADwi+yC8uO5jHHfwQYAIJxQsAEAgF/M2LjfezxXrxZJasTxXACAMEPBBgAAfuG7/prjuQAA4YiCDQAAaszlqng81ykczwUACEMUbAAAUGOr9+Rov+d4robx0erF8VwAgDBEwQYAADXmu3v4qM4czwUACE8UbAAAUGO+669PYf01ACBMUbABAECNuI/nOijJczxXZ9ZfAwDCEwUbAADUyPQN++U5nUu9WiYrJSHG2UAAADiEgg0AAGrEd3r4GO5eAwDCGAUbAACctJ8dz5XO+msAQPiiYAMAgJO2aneOMvPcx3OlJMSoV4skhxMBAOAcCjYAADhpFY7n6pSqCI7nAgCEMQo2AAA4adOYHg4AgBcFGwAAnJRDBcVa4nM818hObHAGAAhvFGwAAHBSpm/I9B7P1ZvjuQAACKyCbYxpaYwZb4zZbYwpMsZsNcY8ZYxp6MTnAACAqvmuvx7ThbvXAABEOR3gCGNMB0mzJTWW9KmktZIGSbpX0tnGmOHW2qy6+hwAAFA1l8tquu/66y6svwYAIGAKtqQX5C7Fv7LWPntk0BjzhKT7Jf1d0h11+DkAAKAKK3dna2HpZVKc+9rV4pCjeQAACAQBMUXcGNNe0pmStkp6vtLTf5aUL+l6Y0xCXXwOAAA4tmnr9le45nguAAACpGBLOtXz+J211uX7hLU2V9IsSfGShtTR5wAAgGPwXX8NAADcAqVgd/E8rq/i+Q2ex8519Dkyxiw62pek9OO9FwCAUHYwv1hLdhxyOgYAAAEnUAp2kucxu4rnj4wn19HnAACAKkzfsF/WOp0CAIDAE0ibnB3LkYVdNf1xXu3Psdb2P+oHuO9i96thDgAAgtZPldZfAwAAt0C5g33kznJSFc83qPS62v4cAABwFC6X1U/rKdgAABxNoNzBXud5rGptdCfPY1Vrq/39OQAA4ChW7MpWVn6xJGlA1Aea/4fT2UEcAACPQLmDPdXzeKYxpkImY0yipOGSDkuaW0efAwAAjsL3eK5RndIo1wAA+AiIgm2t3STpO0ltJd1d6elHJSVImmStzZckY0y0MSbdGNOhJp8DAABOzLT15cdzjUlv7GASAAACT6BMEZekuyTNlvSMMeY0SWskDZZ0itxTuv/o89oWnue3yV2mT/ZzAABANR3IL9ZSz/FcEUYa1SnV2UAAAASYgLiDLXnvPg+QNFHuQvwbSR0kPSNpqLU2qy4/BwAAVDTD53iuPq2SlRwf42wgAAACTCDdwZa1doekcdV43VaVH7l10p8DAACqz3f99ZguTA8HAKCygLmDDQAAAlfl47lOoWADAPAzFGwAAHBcy3dl64DneK7U+jHq3ryBw4kAAAg8FGwAAHBc09aV7x4+qjPHcwEAcDQUbAAAcFysvwYA4Pgo2AAA4Jiy8oq0bOchSRzPBQDAsVCwAQDAMc3YkOk9nqtv64YczwUAQBUo2AAA4Jh811+P6ZzmYBIAAAIbBRsAAFSprPLxXOmsvwYAoCoUbAAAUKXlOw/pYEGJJCm1fqy6NeN4LgAAqkLBBgAAVfLdPXw0x3MBAHBMFGwAAFClaet9j+di/TUAAMdCwQYAAEeVlVek5RWO56JgAwBwLBRsAABwVDM3VjyeKyk+2tlAAAAEOAo2AAA4qhkbMr3fj+Z4LgAAjouCDQAAfsZaqxkbytdfj+yU6mAaAACCAwUbAAD8zIaMPO3LKZIkNYiLUq+Wyc4GAgAgCFCwAQDAz0z32T18eMdURXI8FwAAx0XBBgAAP+O7/noku4cDAFAtFGwAAFBBYUmZ5m3J8l6z/hoAgOqhYAMAgAoWbTuowhKXJKldaoJapcQ7nAgAgOBAwQYAABVMZ/dwAABOCgUbAABUMGM9668BADgZFGwAAOC1P7dIq/fkSJKiIoyGtE9xOBEAAMGDgg0AALxmbSy/e92vdUMlxkU7mAYAgOBCwQYAAF6svwYA4ORRsAEAgCTJWlvx/OvOrL8GAOBEULABAIAkad2+XO3PLZIkJdWLVs8WSQ4nAgAguFCwAQCApIq7h4/omKrICONgGgAAgg8FGwAASGL9NQAANUXBBgAAKiwp0/wtB7zXIyjYAACcMAo2AADQgq0HVFTqkiS1T0tQy4bxDicCACD4ULABAECF3cNHdWL3cAAATgYFGwAAaPp61l8DAFBTFGwAAMJcRk6h1u7NlSRFRxoNad/I4UQAAAQnCjYAAGFu5sby6eH9WjdUQmyUg2kAAAheFGwAAMJchfXXnVl/DQDAyaJgAwAQxlwuW6Fgs/4aAICTR8EGACCMrd2bq8y8IklSw/hodW+e5HAiAACCFwUbAIAwNmND+e7hwzumKjLCOJgGAIDgRsEGACCMcf41AAD+Q8EGACBMFZaUaf7WA97rEay/BgCgRijYAACEqflbDqi41CVJ6ti4vpon13M4EQAAwY2CDQBAmPJdf83u4QAA1BwFGwCAMMX6awAA/IuCDQBAGMrIKdTavbmSpOhIo8HtUxxOBABA8KNgAwAQhnzvXg9ok6L4mCgH0wAAEBoo2AAAhKEK6687s/4aAAB/oGADABBmXC6rmRtZfw0AgL9RsAEACDNr9uYoM69YkpSSEKNuzRo4nAgAgNBAwQYAIMz4rr8e0TFVERHGwTQAAIQOCjYAAGGG868BAKgdFGwAAMLI4eIyLdhy0Hs9kvXXAAD4DQUbAIAwMm9LlorLXJKkzk3qq2lSnMOJAAAIHRRsAADCiO/6a+5eAwDgXxRsAADCCOuvAQCoPRRsAADCxN7sQq3flydJiomM0OB2jRxOBABAaKFgAwAQJnzvXg9s11D1YiIdTAMAQOihYAMAECZYfw0AQO2iYAMAEAZcLquZG30LNuuvAQDwNwo2AABhYPWeHB3IL5YkpdaPUdemDRxOBABA6KFgAwAQBn5aX77+enjHVEVEGAfTAAAQmijYAACEgek+BXsU668BAKgVAVOwjTHDjDFfGWMOGGMKjDHLjTH3GWOqvcWpMaatMcYe4+vd2vw7AAAQiPKKSrVo20Hv9cjOrL8GAKA2RDkdQJKMMRdK+lBSoaT3JB2QdIGkJyUNl3T5CX7kMkmfHGV85cmnBAAgOM3ZlKVSl5UkdW3WQI0T4xxOBABAaHK8YBtjGkh6VVKZpDHW2oWe8YclTZF0mTHmKmvtidx9XmqtfcTvYQEACEK+51+PYvdwAABqTSBMEb9MUpqkd4+Ua0my1hZKeshzeacTwQAACAUV1l93Zv01AAC1xfE72JJO9Tx+c5TnpksqkDTMGBNrrS2q5mc2N8bcLqmRpCxJc6y1y2seFQCA4LI9q0BbswokSfWiIzWgbUOHEwEAELoCoWB38Tyur/yEtbbUGLNFUndJ7SWtqeZnnuH58jLGTJN0o7V2+8lHBQAguPzkMz18SPsUxUZVe+9QAABwggKhYCd5HrOreP7IeHI1PqtA0l/l3uBss2esl6RHJJ0i6UdjTB9rbf7xPsgYs6iKp9KrkQMAgIDA9HAAAOqOX9ZgG2O2Hud4rMpfk0/k4z2P9ngvtNZmWGv/ZK1dbK095PmaLulMSfMkdZR0y4n/DQEACD4lZS7N2ZTlvaZgAwBQu/x1B3uT3EdsVddun++P3KFOOtoLJTWo9LoT5plq/pqkwZJGSXq6Gu/pf7Rxz53tfiebBQCAurJk+yHlFZVKklok11P71ASHEwEAENr8UrCttafV4O3rJA2Q1FlShWnZxpgoSe0klap8yvfJOjJHLqR/u1i645CiIox6tKjq3ysAAOGi4vTwVBljjvFqAABQU4FwTNcUz+PZR3lulKR4SbNPYAfxqgzxPNa0qAe0f3y5Ruc/O1OXvDBLnyzZpaLSMqcjAQAcMr3C+ddMDwcAoLYFQsH+QFKmpKuMMQOODBpj4iT9zXP5ou8bjDFJxph0Y0yzSuODjTExlf8AY8ypku73XJ7I+u+gsmZPjuZvPSBJWrz9kO57b6mG/2uK/vvtOu0+dNjhdACAunQgv1grdrlXV0VGGA3rmOpwIgAAQp/jBdtamyPpVkmRkqYZY14zxjwmaamkoXIX8Pcqve1iuY/s+mel8X9L2mWM+Z8x5knP14+SfpQUK+lha+3s2vvbOCs2KkIX9Wmu6MjyKYCZecV6bupGjfj3FN3+5kLN2pgpa4+7XxwAIMjN3JipI/+579MqWUn1op0NBABAGAiEY7pkrf3EGDNa0h8lXSopTtJGSb+W9IytfiN8U+7yPVDSOZKiJe2T9L6k56y1M/ydPZC0T6uvp67qqz+e103vLdiut+Zt155s995zLit9u2qfvl21Tx0b19f1Q9rokn4tlBjHL1wAEIp811+P7MTdawAA6oLhbuaJMcYs6tevX79Fi6o6JjtwlJa59MOaDE2as1WzfY5pOSIhJlIX92uhG4a2VecmiQ4kBADUBmuthvzzR+3LcW9f8tFdw9SvdUOHUwEAEBz69++vxYsXL67qZKljCYg72KgdUZEROrtHU53do6k2ZuTqzTnb9OHiXd4jW/KLyzR57nZNnrtdQ9qnaOywdjqzWxNFRLDLLAAEs3X7cr3lOqletHq3THY2EAAAYYKCHSY6Nk7Uoxf20ANnp+vjxTs1ac42bcjI8z4/d/MBzd18QO1TE3TLyPa6pF8LxUVHOpgYAHCyfKeHj+iYqkj+4RQAgDrh+CZnqFv1Y6N0/dC2+u7+UXrn1iE6p0fTCr94bc7M1x8+XqER/56i56Zs0KGCYgfTAgBOxvT1md7vR3Vm/TUAAHWFO9hhyhijoR0aaWiHRtqTfViT5mzT5LnblFvonj6emVes/363Xi9M26QrBrTSzSPaqVVKvMOpAQDHc7i4zHtkoySN5PxrAADqDHewoWZJ9fTg2ema83+n6aHzuqpZUpz3uYLiMk2cvVVj/jtNv3pniVZ6zlQFAASmeVuyVFzqkiR1bFxfzZPrOZwIAIDwQcGGV/3YKN0ysr2m/+4UPXFFb6U3Ld9ZvMxl9dmy3Tr/2Zm67rV5mr5+P+dpA0AAqjA9nLvXAADUKaaI42eiIyN0Sb+WurhvC03fkKmXf9pU4ZivmRszNXNjpro2a6A7RrfX+b2as4EOAASI6RvKNzhj/TUAAHWLO9iokjFGozun6e1bh+jzX47QBb2by7dHr9mTo3vfXaozn/xJny7dpTIXd7QBwEm7Dx3WRs8JETFRERrcrpHDiQAACC8UbFRLz5ZJevbqvvrpgVM0dlhb1fM5wmvT/nzd++5SnfHkT/pkCUUbAJwyw+fu9eB2KaoXw3GLAADUJQo2TkirlHg98ovumv37U/WrUzsqMbZ8lcHm/fm67z2KNgA4hfXXAAA4i4KNk9IwIUa/PrOLZj54qn51WqejF+0nftLHS3aqtMzlYFIACA9lLquZG8sL9kjWXwMAUOco2KiRpPho/fqMzpr54Km6t3LRzszX/e8t0xlPTtdHiynaAFCblu08pOzDJZKkJg1i1aVJ4nHeAQAA/I2CDb9Iio/W/b5FO668aG/JzNev36doA0Btmr6+fP31yE5pMobTHQAAqGsUbPiVb9G+7/SjF+0zn5yub1bu5RxtAPAj34I9qjPrrwEAcAIFG7UiqV607jvdXbTvP71zhaK9OTNfd0xepMtemqNF2w44mBIAQkP24RIt3XFIkmSMNKIj668BAHACBRu1KqletO49vdNRi/aibQd16YtzdMebi7R5f56DKQEguM3emKkjBzf0bJGklIQYZwMBABCmKNioE0eK9k8PnKKbhrdTdGT52sBvVu3VGU9O18OfrNT+3CIHUwJAcJruc/41x3MBAOAcCjbqVEpCjP50QTf9+OsxuqB3c+94mcvqzbnbNOY/U/XMjxtUUFzqYEoACB7W2ornX7P+GgAAx1Cw4YjWjeL17NV99endwzW4XYp3PL+4TE98v16j/zNN78zfzo7jAHAcm/bna9ehw5Kk+rFR6ts62dlAAACEMQo2HNW7VbLevW2Ixo8doE6N63vH9+cW6f8+WqGzn56h71fvY8dxAKjCDJ/p4cM6NFJ0JD/aAQBwCj+F4ThjjE5Nb6Kv7x2pf1/aU40TY73PbczI062TFuqqV+Zq7d4cB1MCQGDieC4AAAIHBRsBIyoyQlcObK1pD4zRb8/srPqx5TuOz9tyQOc9M1N//WK1cgtLHEwJAIGjqLRMczeXH3fIBmcAADiLgo2AEx8TpV+e2knTHhijG4e2UVSEe8fxMpfV6zO36LTHf9KnS3cxbRxA2Fu49aAOl5RJkto2ilfrRvEOJwIAILxRsBGwUuvH6tELe+ire0dW2AgtI7dI9767VNe8Ok8b9uU6mBAAnMX0cAAAAgsFGwGvc5NEvXvbED19VR+l+azPnrM5S+c8PUP//GqN8os41gtA+Jm+wed4LqaHAwDgOAo2goIxRhf2aaEpvxmtm4a3U6Rn2nipy+rl6Zt12uM/6cvle5g2DiBsZOQWas0e9+aP0ZFGQzs0cjgRAACgYCOoJMZF608XdNMX94zQwLYNveN7cwp199uLdcP4+dq0P8/BhABQN2asL7973a91QyX4bAwJAACcQcFGUOrarIHev32oHr+8t1Lrx3jHZ2zI1NlPTdd/vl2rgmKmjQMIXdM3sP4aAIBAQ8FG0DLG6NL+LfXjb9y7jXtmjaukzOr5qZt0xhPTNdNnfSIAhAqXy2qGz3/fRlOwAQAICBRsBL2ketF69MIe+uyXI9S3dbJ3fNehw7ru9Xl66JMVbIIGIKSs2p2jA/nFkqRGCTHq1qyBw4kAAIBEwUYI6dEiSR/eMUyPXdpLyfHR3vHJc7fr7Kena+7mLAfTAYD/TFmb4f1+ZKdURRyZwgMAABxFwUZIiYgwumJgK313/yid0a2Jd3zHgcO66pW5evTzVTpcXOZgQgCoue/X7PV+f2rXJsd4JQAAqEsUbISkxolxeuX6/nryyt5qEFe+s+6EWVt17jMztGjbAQfTAcDJ233osFbuKj+ea0wX1l8DABAoKNgIWcYYXdy3pb67f3SFX0C3ZObrspfm6B9frVFhCXezAQSXH9bs834/pH0jNYiLPsarAQBAXaJgI+Q1TYrThLED9dilvVTfc06stdIr0zfrvGdmaOmOQ84GBIAT8P3q8oLtuxQGAAA4j4KNsGCMe232t/eP0oiOqd7xTfvzdckLs/Sfb9eqqJS72QACW05hSYUNG09n/TUAAAGFgo2w0iK5nt68eZD+fnEPxcdESpJcVnp+6iZd+NwsrdyV7XBCAKjatHX7VVJmJUk9WjRQ8+R6DicCAAC+KNgIO8YYXTu4jb69b5SGtE/xjq/dm6uLnp+lV6ZvkrXWwYQAcHS+08PP7NbUwSQAAOBoKNgIW61S4vX2LUP0yAXdFBft/p9CqcvqH1+t1a2TFupQQbHDCQGgXHGpS9N8zr9m/TUAAIGHgo2wFhFhNHZ4O3197yj1bpXsHf9hTYbOe2amFm8/6Fw4APAxb0uWcotKJUktG9ZTetNEhxMBAIDKKNiApHapCfrf7UN1y4h23rFdhw7ripfm6LUZm5kyDsBxlXcPN8Y4mAYAABwNBRvwiImK0EPnd9Mr1/dXgzj3cV6lLqu/fblGt05axJRxAI6x1uoHjucCACDgUbCBSs7s3lRf/mpkpSnj+3TeMzO1hCnjABywaneOdmcXSpKS6kVrUNuU47wDAAA4gYINHEWrlHj97/ahuml4pSnjL8/R6zO3MGUcQJ36zufu9anpjRUVyY9vAAACET+hgSrEREXoTxd008vX91eiZ8p4SZnVX79YrdveXKTsghKHEwIIF5XXXwMAgMBEwQaO46zuTfXVr0aqd8sk79j3q/fpvGdnaOmOQ84FAxAWdhwo0Jo9OZKkmMgIjeqc5nAiAABQFQo2UA2tUuL1vzuGadzwtt6xnQcP6/KXZms8U8YB1KIf1pTfvR7WsZHqx0Y5mAYAABwLBRuoppioCP35gu566bp+FaaM/+WL1frVu0t1uLjM4YQAQhHTwwEACB4UbOAEnd2jmb68Z6R6+UwZ/3zZbl364mztOFDgYDIAoSa7oETzthzwXp/elYINAEAgo2ADJ6F1o3j9746hunZwa+/Y6j05uvD5WZqzKcvBZABCydR1GSpzuZeg9G6VrCYN4hxOBAAAjoWCDZyk2KhI/f3invrnJT0VHWkkSQfyi3Xd6/M0cRbrsgHUnO/08DOZHg4AQMCjYAM1dPWg1nrn1iFKrR8rSSpzWT3y+Wo9+OFyFZWyLhvAySkqLdO0dRnea9ZfAwAQ+CjYgB8MaJuiz+8ZXuEor/cX7tSVL8/VvpxCB5MBCFZzNmUp37N5YptG8erUuL7DiQAAwPFQsAE/aZZUT+/dPlSX9GvhHVu645AueHamFm8/6GAyAMGowu7hXZvIGONgGgAAUB0UbMCP4qIj9fjlvfXw+d0UGeH+ZTgjt0hXvTxX7y3Y7nA6AMHC5bIVzr9mejgAAMGBgg34mTFGN49op0k3DVJyfLQkqbjMpQc/XKE/f7pSJWUuhxMCCHQrdmVrX06RJKlhfLT6t2nocCIAAFAdFGyglgzvmKrP7h6h9KaJ3rE35mzTda/NU1ZekYPJAAQ63+nhp6Y3UVQkP64BAAgG/MQGalHrRvH66K5hOq9nM+/YvC0H9IvnZmn17hwHkwEIZBXWXzM9HACAoEHBBmpZfEyUnrumrx44q4uO7FG069BhXf7SbE1dm3HsNwMIO9uy8rVuX64kKTYqQqM6pzqcCAAAVBcFG6gDxhjdfUpHvXbDACXGRkmS8ovLdPMbC/TG7K3OhgMQUHzvXo/omKr4mCgH0wAAgBNBwQbq0Gldm+jDu4apRXI9SZLLSn/+bJUe+WyVylzW4XQAAsF3TA8HACBoUbCBOta5SaI+uXu4erdK9o5NnL1Vt01aqPyiUueCAXDcgfxiLdx6QJJkjPsf5QAAQPCgYAMOSEuM1bu3DtE5PZp6x35cm6ErXp6jvdmFDiYD4KQpazN0ZDJL31bJSkuMdTYQAAA4IY4XbGNMtDHmXmPMBGPMUmNMsTHGGmNuqcFnDjPGfGWMOWCMKTDGLDfG3GeMifRndqAm6sVE6vlr+umO0R28Y6t25+ii52dp1e5sB5MBcMr3q/d6vz+jW9NjvBIAAAQixwu2pARJT0kaK6mppL3HevHxGGMulDRd0ihJH0t6XlKMpCclvVuTzwb8LSLC6PfnpOtfl/RUVIR7i/G9OYW6/KU5+nHNvuO8G0AoKSwp0/T1md7rM7szPRwAgGATCAW7QNK5kppba5tKGn+yH2SMaSDpVUllksZYa2+21j4gqY+kOZIuM8ZcVfPIgH9dNai1Jo4bpMQ4927BBcVlunXSQk2YtcXhZADqyqyNmTpcUiZJap+WoA5p9R1OBAAATpTjBdtaW2yt/dpau8cPH3eZpDRJ71prF/r8GYWSHvJc3umHPwfwuxGdUvXRncPUsmH5DuOPfr6aHcaBMPE9u4cDABD0HC/Yfnaq5/Gbozw3Xe675cOMMewag4DUqUmiPr5ruPpU2mH81kkLlccO40DIcrmsfliT4b0+k4INAEBQCrWC3cXzuL7yE9baUklbJEVJan+8DzLGLDral6R0vyYGKklLjNW7tw3ReT2becemrM3Q5S/N0Z7sww4mA1Bbluw4pMy8IklSav0Y9WnV0OFEAADgZIRawU7yPFa1BfOR8eTajwKcvLjoSD17dV/dNaZ8h/E1e3J02YtztHl/noPJANQG3+nhp6U3UaRn00MAABBc/FKwjTFbPUdrVfdrsj/+3JOJ6nk87oJWa23/o31JWlu7EQG3iAij352drscu7eXdYXzXocO64uU5HOMFhJiKx3MxPRwAgGAV5afP2SSp8ARev9tPf25lR1pHUhXPN6j0OiDgXTGwlZokxen2NxeqsMSlzLxiXfXyXI0fN1AD26Y4HQ9ADW3en6dN+/MlSfWiIzWiU6rDiQAAwMnyyx1sa+1p1tr0E/j6nT/+3KNY53nsXPkJY0yUpHaSSiVtrqU/H6gVozunafLNg73HeOUWler61+dp6tqM47wTQKD7dlX59PCRnVIVFx3pYBoAAFATobYGe4rn8eyjPDdKUryk2dbaorqLBPjHgLYpeu+2oUqt794Ev7DEpVsnLdRny2prQgiAuvDp0l3e78/u0dTBJAAAoKaCsmAbY5KMMenGmGaVnvpAUqakq4wxA3xeHyfpb57LF+soJuB33Zo30P/uGKoWye6zsktdVve+u0ST525zOBmAk7FmT47W7s2V5J4eflZ3CjYAAMEsIAq2Meb3xpiJxpiJki7yDI87MmaMuaXSWy6WtEbSP30HrbU5km6VFClpmjHmNWPMY5KWShoqdwF/r9b+IkAdaJeaoA/vHKaOjetLkqyVHvpkpZ6fulHWHnf/PgAB5BOfu9dndGuihFh/bY0CAACcEBAFW+4p3Td6vnp7xob5jI2o7gdZaz+RNFrSdEmXSrpHUomkX0u6ytJAEAKaJsXp/duHqnfL8v38/vPtOv3r67WUbCBIuFxWny0tX+JxUd/mDqYBAAD+EBD/VG6tHXOCr58oaeIxnp8l6dwahQICXEpCjN66dYhufWOh5mzOkiS9PH2zsg+X6O8X9+QcXSDAzdtyQHuy3QdwpCTEaGSnNIcTAQCAmgqUO9gATkL92ChNGDewwrm57y7YoV+9s0RFpWUOJgNwPJ8sKZ8efn6vZoqO5EcyAADBjp/mQJCLi47Ui9f20yX9WnjHvlyxR7e8sVAFxaUOJgNQlcKSMn21co/3+qK+LY7xagAAECwo2EAIiIqM0H8v662xw9p6x2ZsyNR1r81TdkGJc8EAHNXUtRnKLXT/A1ibRvHq2yrZ2UAAAMAvKNhAiIiIMPrzBd10/+mdvWOLtx/SNa/NpWQDAcZ39/AL+7SQMeyZAABAKKBgAyHEGKN7T++kP1/QzTu2aneObpgwX7mFlGwgEGQXlGjq2v3e64v6sHs4AAChgoINhKBxw9vp35f29F4v23FI4yYsUH4Ra7IBp321co+Ky1ySpN4tk9Q+rb7DiQAAgL9QsIEQdeXA1vrrRT281wu3HdTNbyzQ4WJ2Fwec9PGSitPDAQBA6KBgAyHs+iFt9PD55dPF524+oNveXKjCEko24IRdhw5r/pYDkqTICKMLejM9HACAUELBBkLczSPa6cGz073XMzZk6q63Fqu41OVgKiA8feqzudnwjqlKS4x1MA0AAPA3CjYQBu4c06HC7uJT1mbonncWq6SMkg3UFWutPvGZHn5xX+5eAwAQaijYQJj41WkddfcpHbzX367ap/vfW6pSSjZQJ9bsydX6fXmSpHrRkTqzW1OHEwEAAH+jYANhwhij357ZRbeObOcd+2L5Hv3ug+Uqc1kHkwHhwXd6+JndmyghNsrBNAAAoDZQsIEwYozRH87tqhuHtvGOfbRkl/748Qq5KNlArSlzWX26dLf3+iJ2DwcAICRRsIEwY4zRny/orqsHtfKOvbtgh/782SpZS8kGasO8LVnam1MoSWqUEKMRnVIdTgQAAGoDBRsIQxERRn+/qKcu7dfSO/bm3G3625drKNlALfDd3Oz8Xs0UHcmPXwAAQhE/4YEwFRFh9NhlvfQLn3N4X5+5RY99u46SDfhRYUmZvl6x13t9UV+mhwMAEKoo2EAYi4wweuKK3jqnR/luxi9O26Snf9zgYCogtExZm6HcolJJUptG8erTKtnZQAAAoNZQsIEwFxUZoaev6qvTuzb2jj31wwZNmLXFwVRA6PjYZ3r4RX1ayBjjYBoAAFCbKNgAFBMVoeev7adRndO8Y49+vlofLd7pYCog+B0qKNa0dRnea6aHAwAQ2ijYACRJsVGReum6furfpqF37IEPluv71fscTAUEty9X7FFJmXtPg96tktUuNcHhRAAAoDZRsAF4xcdEafyNA5XeNFGS++zeu99erDmbshxOBgSnT5f4nn3d/BivBAAAoYCCDaCCpPhoTbppkNo0ipckFZe6dOukhVqxM9vhZEBw2XmwQPO3HpDk3lDw/F4UbAAAQh0FG8DPNG4Qp8k3D1bjxFhJUl5RqW6cMF8bM/IcTgYEj0+Xlt+9HtExVWme/z0BAIDQRcEGcFStUuL15s2DlVQvWpJ0IL9YN7w+T7sOHXY4GRD4rLX6xGf38IvZ3AwAgLBAwQZQpS5NEzVh3EDFx0RKknZnF+r61+cpK6/I4WRAYFu9J0cbPDM+6kVH6oxuTRxOBAAA6gIFG8Ax9WvdUC9f31/Rke6zezfvz9eNE+Yrt7DE4WRA4PK9e31W9yZKiI1yMA0AAKgrFGwAxzWyU5qevqqvItwdWyt35eiWNxaqsKTM2WBAACpzWX22rHz99YVMDwcAIGxQsAFUy7k9m+kfF/f0Xs/bckC/fHuxSspcDqYCAs/czVnal+NeRtEoIUYjO6Y6nAgAANQVCjaAartqUGv93znp3usf1mTowQ+Wy+WyDqYCAovv9PALejdXVCQ/agEACBf81AdwQm4f3UF3jungvf5oyS795YvVspaSDRSWlOnrlXu91xcxPRwAgLBCwQZwwn53VhddPai193ri7K165seNDiYCAsOPazKUV1QqSWrbKF69WyY5nAgAANQlCjaAE2aM0d8u6qHzejbzjj35w3pNnrvNwVSA895buMP7/YV9WsgY42AaAABQ1yjYAE5KZITRk1f20chO5Rs4PfzpSn21Yo+DqQDnbM8q0IwN+yVJxkiX9W/pcCIAAFDXKNgATlpMVIReuq6/erdKliRZK9337lLN3pjpbDDAAe8s2K4jWxGM7pymVinxzgYCAAB1joINoEYSYqM0YexAtU9LkCQVl7l025uLtHJXtsPJgLpTXOrS/3ymh1/js0cBAAAIHxRsADWWkhCjSTcNUtMGcZKkvKJSjZ0wX1sz8x1OBtSN71fvU2ZesSSpaYM4nZre2OFEAADACRRsAH7RsmG83rhpkBrERUmSMvOKdcP4+crILXQ4GVD73ppXvsHflQNbcfY1AABhit8AAPhNl6aJGj92oGKj3P9p2X6gQDeOX6CcwhKHkwG1Z0tmvmZvypIkRRjpqkGtHE4EAACcQsEG4FcD2qbohWv7KTLCfTzRmj05uvWNhSosKXM4GVA73pm/3fv9qemN1SypnoNpAACAkyjYAPzutK5N9K9Lenqv5205oPveXaoyl3UwFeB/RaVlFTY3u3ZwGwfTAAAAp1GwAdSKywe00u/PSfdef7Nqrx76ZKWspWQjdHyzcq8OFriXQLRIrqdRndMcTgQAAJxEwQZQa24f1V63jGjnvX5n/nY9+f16BxMB/vXWvPLp4VcNbOVdGgEAAMITBRtArTHG6A/ndtXFfVt4x56ZslFvzN7qXCjATzZm5Gr+lgOSpMgIoysGsrkZAADhjoINoFZFRBg9dlkvjelSPnX2kc9X6Yvlux1MBdSc793rM7o2URPPOfAAACB8UbAB1LroyAi9cG0/9W2dLEmyVrr/vaWauSHT2WDASSosKdOHi3Z6r68Z3NrBNAAAIFBQsAHUifiYKI2/caA6Nq4vSSops7r9zYVauSvb4WTAifty+R7lFJZKklqnxGtEx1SHEwEAgEBAwQZQZxomxGjSTYPULMk9lTa/uExjJyzQjgMFDicDTsxb87Z5v796UGtFsLkZAAAQBRtAHWueXE+TbhqkBnFRkqTMvCLdMH6+DuQXO5wMqJ61e3O0ePshSVJ0pNHlA1o6GwgAAAQMCjaAOtepSaJeu3GgYqLc/wnakpmvmyYu0OHiMoeTAcf3ts/mZmd2b6rU+rEOpgEAAIGEgg3AEYPapeiZq/rIeGbWLt1xSL98e7FKy1zOBgOOoaC4VB8v3uW9vpbNzQAAgA8KNgDHnN2jmR79RXfv9Y9rM/TQJytlrXUwFVC1z5ftVm6Re3Oz9qkJGtq+kcOJAABAIKFgA3DUDUPb6q4xHbzX7y7Yoad/3OBgIqBqvtPDrx7UWsawuRkAAChHwQbguAfO6qJL+rXwXj/1wwa9M3/7Md4B1L2Vu7K1bKf7WLmYyAhd2p/NzQAAQEUUbACOM8bo35f20qjOad6xP368Qj+u2edgKqCit3zuXp/bs6lSEmIcTAMAAAIRBRtAQIiOjNAL1/ZTzxZJkiSXle5+e7EWbz/ocDJAyisq1WdLyzc3u2ZwGwfTAACAQEXBBhAw6sdGafzYgWqVUk+SVFji0s0TF2jT/jyHkyHcfbp0l/I9x8h1bFxfA9s2dDgRAAAIRBRsAAElLTFWk24a7J1+e7CgRDeOn6+M3EKHkyFcWWv11tzy6eHXDmZzMwAAcHQUbAABp11qgsaPHah60ZGSpJ0HD2vchAXKLSxxOBnC0bKd2Vq9J0eSFBsVoUv6srkZAAA4Ogo2gIDUp1Wynr+2ryIj3HcKV+3O0Z2TF6u41OVwMoSbt+dt835/fq/mSoqPdjANAAAIZBRsAAHr1PQm+ufFPb3XMzdm6sEPl8vlsg6mQjjJPlyiz5bt9l5fM7i1g2kAAECgo2ADCGhXDGylX5/R2Xv98ZJd+u936xxMhHDyyZJdKixxz5pIb5qofq2TnQ0EAAACGgUbQMC759SOunpQ+Z3DF6Zt0uS5247xDqDmrLV6ex6bmwEAgOpzvGAbY6KNMfcaYyYYY5YaY4qNMdYYc8tJfFZbz3ur+nq3Nv4OAGqXMUZ/vbC7Tktv7B3706cr9cPqfQ6mQqhbtO2g1u3LlSTVi47UhX1bOJwIAAAEuiinA0hKkPSU5/t9kvZKalXDz1wm6ZOjjK+s4ecCcEhUZISevaavrn5lrpbtzJbLSr98Z7HevW2o+rRKdjoeQtCE2Vu931/Yp7kaxLG5GQAAODbH72BLKpB0rqTm1tqmksb74TOXWmsfOcrXB374bAAOiY+J0ms3DlTrlHhJUmGJSzdPXKBtWfkOJ0Oo2bAvV1+t2OO9vm5IGwfTAACAYOF4wbbWFltrv7bW7jn+qwGEu7TEWE0cN1ANPUclZeUX68bx85WVV+RwMoSSZ6ZslPVsVn9qemP1aJHkbCAAABAUHC/YtaS5MeZ2Y8wfPI+9nA4EwH/ap9XXazcOUGyU+z9hW7MKdMukhTpcXOZwMoSCjRm5+mJ5+dFc957WycE0AAAgmIRqwT5D0kuS/u55XGaMmWqM4QBTIET0b5Oip6/qqyObOi/Zfkj3vrtEZZyRjRp65sfyu9endElTb9b4AwCAagq1gl0g6a+S+ktq6PkaLWmqpDGSfjTGJFTng4wxi472JSm9dqIDOFFn92iqP5/fzXv93ep9+svnq2QtJRsnZ2NGnj73vXt9eudjvBoAAKAivxRsY8zW4xyPVflrsj/+3MqstRnW2j9Zaxdbaw95vqZLOlPSPEkdJZ3w8V8AAtfY4e1068h23us35mzTqzM2O5gIwey5KRu8d6/HdEljh3oAAHBC/HVM1yZJhSfw+t3Hf4n/WGtLjTGvSRosaZSkp6vxnv5HG/fcxe7n34QAauL/zumq3dmF+nK5e6/Ef3y1Vk2T6ukXvZs7nAzBZNP+PH22jLXXAADg5PmlYFtrT/PH59Sy/Z7Hak0RBxA8IiKMHr+8t/bnFmn+lgOSpN++v0yNE2M1pH0jh9MhWDw3ZaOOLOEf1TlNfVs3dDYQAAAIOqG2BvtYhngemTsKhKC46Ei9cn1/dWxcX5JUXObSbZMWav2+XIeTIRhs3p+nT5fu8l5z9xoAAJyMoCzYxpgkY0y6MaZZpfHBxpiYo7z+VEn3ey5rZf03AOclx8do4riBSkuMlSTlFJZq7Pj52pdzIitYEI58716P7JSq/m24ew0AAE5cQBRsY8zvjTETjTETJV3kGR53ZMwYU3ljsoslrZH0z0rj/5a0yxjzP2PMk56vHyX9KClW0sPW2tm19zcB4LSWDeM1YexAJcRESpJ2Zxdq7IQFyikscTgZAtWWzHx94nP3+r7TuXsNAABOTkAUbElnS7rR89XbMzbMZ2xENT/nTbl3Cx8o6VZJd0nqJOl9SaOstX/zY2YAAapHiyS9cF1/RUa4D8lesydHt76xUIUlZQ4nQyB6dsqGSnevU5wNBAAAglZAFGxr7RhrrTnG19hKr59Yxfjr1trzrbVtrbX1rbWx1trW1torrbUz6vLvBMBZozun6Z+X9PRez9tyQPe8s0SlZS4HUyHQbM3M16dL2TkcAAD4R0AUbACoDVcMaKXfn5Puvf5+9T79/qMVskcOOkbYe27qRpV5bl+P6JiqAW25ew0AAE4eBRtASLtjdAfdPqq99/qDRTv1j6/WULKhbVn5+niJz87hrL0GAAA1RMEGEPJ+f066rhjQ0nv96owteuknTuwLd89NKb97PaxDIw3k7jUAAKghCjaAkGeM0T8u7qkzuzXxjv37m7V6Z/52B1PBSduzCvTREs69BgAA/kXBBhAWoiIj9MzVfTWkffldyj9+vEJfr9jjYCo45bmpG7x3r4e2b6TB7Rs5nAgAAIQCCjaAsBEXHalXbxigHi0aSJJcVrr33aWatTHT4WSoS9uzCvTRYtZeAwAA/6NgAwgriXHRmjhukNqnJkiSistcum3SQi3bccjZYKgzz0/dqFLP3esh7VM0hLvXAADATyjYAMJOav1YTbp5kJo2iJMk5ReXaeyE+dqYkedwMtS2HQcK9OHind7re0/r7GAaAAAQaijYAMJSy4bxevPmQUqOj5YkHSwo0fWvz9OuQ4cdToba9MK08rvXg9ulaGgH7l4DAAD/oWADCFudmiRqwtiBio+JlCTtyS7U9a/PU1ZekcPJUBt2HCjQ/xb63L1m7TUAAPAzCjaAsNa3dUO9fH1/RUcaSdLm/fkaN3GB8opKHU4Gf3th2ibv3etBbVM0lLXXAADAzyjYAMLeyE5peurKvjLujq3lO7N126SFKiwpczYY/GbnwQJ9sGiH9/q+0zvJHPn/cAAAAD+hYAOApPN6NdPfLurhvZ69KUt3TF5EyQ4RT36/QSVl7rvXA9s2ZO01AACoFRRsAPC4dnAbPXBWF+/1tHX7defkRSoqpWQHsylr9/1s53DuXgMAgNpAwQYAH3eN6aB7Tu3ovZ66br/ueJOSHawO5hfrwQ9XeK/P69VMIzqlOpgIAACEMgo2APgwxujXZ3TWL0+pWLLvnLyYkh2EHvp0pfbnuneFT0uM1d8u7HGcdwAAAJw8CjYAVGKM0W/O7Ky7T+ngHZuyNkN3UbKDymfLduvL5Xu81/++tKcaJsQ4mAgAAIQ6CjYAHIUxRr89s4vuGlNesn9cm6G736JkB4N9OYV6+JOV3usrB7TSqelNHEwEAADCAQUbAKpgjNEDZ3XRnT4l+4c17pJdXOpyMBmOxVqrBz9cruzDJZKkFsn19ND5XR1OBQAAwgEFGwCOwRij353VRXeMrliy76JkB6x3F+zQtHX7vdf/vby3EuOiHUwEAADCBQUbAI7DGKMHz+6i20e39479sGaf7n6bkh1odhwo0N++WO29vml4O868BgAAdYaCDQDVYIzR789O1+2jykv296v36ZeU7IDhcln95n/LlF/sXiPfIS1Bvzu7y3HeBQAA4D8UbACoJmOMfn9Oum7zKdnfrd6ne95ZrJIySrbTxs/aovlbDkiSIiOMHr+ij+KiIx1OBQAAwgkFGwBOgDFG/3dOum4d2c479u2qfbrn7SWUbAdtzMjVY9+u817fNaaD+rRKdi4QAAAISxRsADhBxhj94dyuFUr2N6v26lfvULKdUFLm0q/fX+adqt+9eQPdc2onh1MBAIBwRMEGgJNwpGTfMqK8ZH+9ci9rsh3wwtRNWr4zW5IUExmhJ67oo5gofrwBAIC6x28gAHCSjDH643lddfOIitPF75y8SEWlZQ4mCx8rdmbr2SkbvNe/PrOzujRNdDARAAAIZxRsAKgBY4weOq9rhY3PflybodsmLVJhCSW7NhWWlOnX7y9VqctKkga0aahbR7Y/zrsAAABqDwUbAGroyMZnd43p4B37af1+3fLGQh0upmTXlie+X68NGXmSpHrRkfrv5b0VGWEcTgUAAMIZBRsA/MAYowfO6qJ7TyvfXGvmxkyNmzhf+UWlDiYLTfO3HNCrMzZ7r/9wXle1TU1wMBEAAAAFGwD8xhij+8/orN+e2dk7NnfzAd04fr5yC0scTBZa8otK9dv/LZN1zwzXyE6pum5wa2dDAQAAiIINAH73y1M76ffnpHuvF247qBvGz1f2YUp2TblcVn/4eIW2HyiQJCXGRemxy3rJGKaGAwAA51GwAaAW3DG6gx4+v5v3esn2Q7r+9Xk6VFDsYKrg5nJZ/d9HK/Tp0t3esb9c2F3Nkuo5mAoAAKAcBRsAasnNI9rpLxd2914v35mta16dpwP5lOwT5XJZ/fGTlXpv4Q7v2NWDWuuiPi0cTAUAAFARBRsAatENQ9vqn5f01JEZzKv35OiaV+cqM6/I2WBBxFqrP322Uu/M3+4du6x/S/39oh5MDQcAAAGFgg0AtezqQa312KW9vCV77d5cXfXKXGXkFDobLAhYa/Xo56s1eW55ub6kbwv9+9JeiuBILgAAEGAo2ABQBy4f0EpPXNFbRzrhxow8XfXKXO3NpmRXxVqrv36xRhNnb/WOXdinuf7DedcAACBAUbABoI5c3Lelnr6qr7ccbs7M15WvzNGWzHyHkwUea63++fVajZ+1xTt2fq9mepxyDQAAAhgFGwDq0AW9m+v5a/oqylMSt2UV6LxnZuj9BTtkjxzsHOastfr3N+v0yvTN3rFzezbVU1f2UVQkP7YAAEDg4jcVAKhjZ/doppeu668YT1ksKC7T7z5crrvfXqzsgvA+K9taq8e/W6+XftrkHTurexM9fVVfyjUAAAh4/LYCAA44vVsTfXTXMHVIS/COfbVir85+errmbs5yMJmznv5xg56butF7fXrXJnr26n6KplwDAIAgwG8sAOCQHi2S9MU9I3XN4NbesT3Zhbr61bl67Ju1KilzOZiu7j374wY99cMG7/Wp6Y31/LV9FRPFjyoAABAc+K0FABxULyZS/7i4p16+vr8axkdLkqyVXpi2SZe9ODtsNkB7fupGPf79eu/16M5peuHafoqNinQwFQAAwImhYANAADire1N9c98oDe/YyDu2bGd2WGyA9vJPm/Sfb9d5r0d2StXL1/dXXDTlGgAABBcKNgAEiCYN4vTmTYP1h3PTFR3p3mX8yAZov3x7SchtgFZQXKp/fb1W//x6rXdsWIdGevWGAZRrAAAQlCjYABBAIiKMbhvVQR/fNVztfTZA+3LFHp0TIhugWWv16dJdOu3xnyrsFj6kfYpev3Eg5RoAAAQtCjYABKAeLZL0ZaUN0HZ7NkD7z7drVVhS5mC6k7d85yFd9tIc3fvuUu3JLvSOD23fSK/fOFD1YijXAAAgeEU5HQAAcHRHNkAb3TlND364XIcKSmSt9PzUTXp73nZdPai1bhjaVk2T4pyOelwZOYV67Nt1+mDRzgrjqfVj9MBZXXRZ/1aKjDAOpQMAAPAPCjYABLizujdVn1bJ+vX7SzVro3uK+MGCEr0wbZNemb5Z5/ZspnHD26pv64YOJ/25otIyjZ+5Vc9N2aD84vK77tGRRjcNb6dfntpRiXHRDiYEAADwHwo2AASBIxugvTVvm16evlk7Dx6WJJW6rD5btlufLdutvq2TddPwdjq7R1NFRzq7Ashaq+9W79Pfv1yj7QcKKjx3etfG+uN53dQuNaGKdwMAAAQnCjYABImICKPrh7bVNYPb6PvV+zRh1hbN23LA+/yS7Yd0z/YlatogTjcMa6OrB7ZWw4SYOs+5bm+u/vLFKu/d9iM6Na6vh8/vplGd0+o8EwAAQF2gYANAkImMMDq7R1Od3aOpVu7K1oRZW/X5st0qLnNJkvbmFOqxb9bpmR836OK+LXXT8Lbq1CSxVjO5XFab9udp0pxtemveNrl8ju1Oqhet+0/vpGuHtHH8zjoAAEBtMtba478KXsaYRf369eu3aNEip6MAgNf+3CK9NW+bJs/dpsy84p89P7xjI/Vvk6JOjeurY+P6apeaUKPjsPblFGrpjkNauuOQlu04pOU7s5VXVFrhNZERRtcObq37T+/syJ10AACAk9G/f38tXrx4sbW2/4m+lzvYABAC0hJjdd/pnXXnmA76YtkejZ+1Rat253ifn7Uxq8KU7QgjtU6JV8fGierYuL63eHdsXF8JsRV/NOQVlWrFzmxvmV6281CFI7aOZnjHRvrT+d3VpWnt3jkHAAAIJBRsAAghsVGRurR/S13Sr4XmbzmgCbO26rvVeytM2ZYkl5W2ZhVoa1aBflizr8JzzZPi1LFJoholxGj17hxtyMj92fuPJrV+jPq0aqgrB7bS6V0byxiO3QIAAOGFgg0AIcgYo8HtG2lw+0baebBAszdlaVNGnjZm5GlDRp52HCxQVSuEdmcXavdx7lDXi45UzxZJ6t0qSX1aNVTvVklqkVyPUg0AAMIaBRsAQlzLhvG6YkB8hbHCkjJt2u8u3Bsz8rRhX5427s/T1sx8lVa6XR1hpM5NEtW7ZbL6tE5W75bJ6tykvqLYsAwAAKACCjYAhKG46Eh1b56k7s2TKoyXlLm0LStfG/blKTOvSJ2aJKpni6SfrcsGAADAz/EbEwDAKzoywrPxGZuTAQAAnCjm9wEAAAAA4AcUbAAAAAAA/ICCDQAAAACAH1CwAQAAAADwA8cLtjGmkzHmQWPMFGPMDmNMsTFmnzHmU2PMKSf5mcOMMV8ZYw4YYwqMMcuNMfcZYyL9nR8AAAAAACkACrakv0r6l6Qmkr6S9LikWZLOkzTFGPOrE/kwY8yFkqZLGiXpY0nPS4qR9KSkd/0XGwAAAACAcoFwTNc3kv5trV3iO2iMGS3pe0n/Mcb8z1q753gfZIxpIOlVSWWSxlhrF3rGH5Y0RdJlxpirrLUUbQAAAACAXzl+B9taO7FyufaM/yRpmtx3n4dV8+Muk/T/7d1/rGRlfcfx97csP1bDjxW0oUvrrlhY2pggbtq6KG4g+KPBH0SNpFpZaYy2hVJt0jbVUGptUAtIMZZtlLr8jBYEoi2rbaUrhq1VSWppXFYXWZVFrMAKuyy7CPv0j+e5OFzn3jsz99x7zjPzfiUnc+f8eOaZ53PvnfOdOXPOc4FPTxXXpa29wPvL3d+fV4clSZIkSeqj9QJ7Dj8tt08OuP6p5fYLfZbdDuwB1kTEwfPtmCRJkiRJvbpwiHhfEfF84DRyUXz7gJsdX26/PX1BSunJiLgX+HXgBcCWOR7/zhkWrRqwL5IkSZKkCdLJArt8wnwdcDDwpymlnQNueni5fWSG5VPzjxi9d5IkSZIk/bxGCuyI2A48f4hNrkspvW2Gtg4ArgFOBj4DXDzvDvY0X27TXCumlF7St4H8yfZJDfZJkiRJkjQGmvoE+x5g7xDr399vZimurwXeDPwT8LaU0pzFcI+pT6gPn2H5YdPWkyRJkiSpEY0U2Cml0+bbRkQsAa4nF9fXA29PKT01ZDNbgdXAccAzvkNd2l9JPmHad+fbX0mSJEmSenXiLOIRcRBwI7m4vhr43RGKa8jXugZ4dZ9lpwDPAjanlPaN1FFJkiRJkmbQeoFdTmh2M/B64ErgHSml/XNsc3hErIqIo6ctuhF4EDgrIlb3rH8I8MFy94rGOi9JkiRJUtGFs4ivB36bXBjvAC6IiOnrbEopbeq5fybwKeAqYN3UzJTSoxHxTnKhvSkiPg08DLyOfAmvG8knTpMkSZIkqVFdKLBXltujgAtmWW/TII2llG6JiFcA7wPeCBwCbAPeC1w+5EnTJEmSJEkaSOsFdkpp7QjbbAA2zLL8DvKn4pIkSZIkLYrWv4MtSZIkSdI4sMCWJEmSJKkBFtiSJEmSJDXAAluSJEmSpAZYYEuSJEmS1AALbEmSJEmSGmCBLUmSJElSAyKl1HYfqhIRDy1duvQ5J5xwQttdkSRJkiQ1bMuWLTz++OMPp5SOHHZbC+whRcS9wGHA9pa70pRV5fbuVnuhKebRLebRLebRPWbSLebRLebRLebRLV3PYwXwaEpp5bAbWmBPuIi4EyCl9JK2+yLz6Brz6Bbz6B4z6Rbz6Bbz6Bbz6JZxzsPvYEuSJEmS1AALbEmSJEmSGmCBLUmSJElSAyywJUmSJElqgAW2JEmSJEkN8CzikiRJkiQ1wE+wJUmSJElqgAW2JEmSJEkNsMCWJEmSJKkBFtiSJEmSJDXAAluSJEmSpAZYYEuSJEmS1AALbEmSJEmSGmCBXbGIWBMRt0bEwxGxJyL+JyL+OCIOWIy2IuLsiPhaROyOiEciYlNEnDHg4x0XEY9FRIqIa4ftbxfVlEdEnBMRt0TEtoh4tGSxJSI+ERHHD9vfLqolj4g4MCLOjIgrI+J/Sx57IuKuiPhARBw6bH+7qpZMyrq/EREXRcTGiHig/K+6b9h+tikijomIf4yI+yNiX0Rsj4jLImLZQrez2K8ptaglk9L++yLihvI6sb/8DbxwlOfdVRXlcXJEfCQivh4RPy6PcW9EfHKcMqkoj1Mi4prIr9kPRcTeksfnIuK0UZ57F9WSR59tDy7ZtPe6nVJyqnACXg88CewGrgT+FrgbSMANC90WcHFZ/gPgo8DHgYfKvHPneLwlwH8Bu8r617Y9npOWB3AbsAW4DrikPMat5XH3Aa9pe0wnJQ9gVZm/G/g88OGy/rYyfytwVNtjOkmZlPUvK8ueAL5Zfr6v7XEcYoyOBX5U+n0L8KHyd5/KWB25UO0sRj41TjVlAryhLNsP3APsLPdf2PY4TmgeDwBPAV8p/5suBu7gZ68dL217PCcsjwuBHcBNwOXAReT9qan92r9uezwnKY8+21/Sk0Urr9utB+g0QmhwGPB/5EJodc/8Q4DN5RfqrIVqC1hT5m8DlvXMX0HeIdoLrJjlMS8oj/dHjEGBXWMewCEzPP7ppa1vtT2uk5IHsBz4A+DZ09o5CPjn0tbH2h7XScqkLDsReDFwULlfW4H9xdLn86bNv7TMX78Q7SxWPjVOlWVyDPBy4LByfxPjV2DXlMefAb/U57H/oqx/V9vjOWF5zLQPtZxcTD4FHN32mE5KHtO2X0t+Y/DdWGA7DRUanFN+aa7qs+zUsuzLC9UWcHWZ/44+23ygLPurGR5vNfBT4P3lj2AcCuxq85ihDzuBJ9oeV/N4RuFR9c7TOGTS5gv1COP9gtLfe4FfmLbsUPKnAo8x7U2dJtpp+2+mq1NtmfRZbxNjVGDXnkfP+gcAe8o2A32i2MVpXPIo29xctjm57XGdtDzIxfl24N/K/dZet/0Odp1OLbdf6LPsdvI/2zURcfACtTXbNhunrfO0iFhK3pH6b/IhIuOiyjz6iYiXAUcAdw2yfkeNTR7kN6MgHypVs3HKpAZTz+VfU0r7exeklHaRDy19FvBbC9CO+fRXWybjblzySPzs9eGpAdbvqrHIIyKeB/wm+dPXrXOt32G15nE5sAz4vTn6teAssOs0dRKqb09fkFJ6kvxO0RLyO0eNthURzyYfArM7pfTDPu19p9we12fZh0o7Z5e2x0WteRARb4qICyPiwxFxM/Al4GHg3AH62lXV5tHHOeW23wtNTcYpkxrMOEbFoM95lHbMp79qMpkQ45LHm8mfBH41pfSTAdbvqirziIjVZR/qgxGxgfw94ecB70kpPThHX7usujwi4kzgbOC9KaXvz9GvBbek7Q5oJIeX20dmWD41/4gFaGukxy5nVTwP+POU0rcG6FdNqsujx5uAt/Tc/w7wOymlb8zay26rOY+nRcTrgHcB9wEfmWv9jhuLTCrS1HMepR3z6a+mTCZB9XlExErgY+RPsP9ktnUrUGseq4G/7Lm/i/xVl2tm7WX3VZVHRPwi8A/AxpTSlXP0aVH4CXZLyinq0xDTMJeyinKbmujqiG09vX5EHAF8inzm8Esa6FPjJimPZ8xM6ayUUpD/oZ1MfmfwjohYN3IPGzCpeTzdaMQa4Hryd5PemFLaOULfGjXpmYyZpsZ7lHbMp78aMxlnnc6jHIq8EXgucH5KafNo3atGJ/NIKa0v+1BLgV8j7+teHRHr59XL7utaHp8ADgTeOc/+NMZPsNtzD/nMqIO6v+fnqXdvDu+3IvlL/r3rzWbYtuZav987T5cCRwGnp5S6+h2hScrj56SUHgU2R8RrgW8AV0TEv6eU2rru78TmEREvJe847SdfLu1rA/RzMUxsJhVqarxHacd8+qspk0lQbR6luL6NfCjt+Smlv5+jjzWoNg+AlNJe8qVPzy/fDX5X2Ye6cY7+dlU1eUTE24HXkr9+umOO/iwaC+yWpJTmcyH6reTDUo4D7uxdEBFLgJXkQ4a+23RbKaXHImIHsDwiju7znblfLbe93504ifzu3t0RQR9vjYi3At9MKZ04QJ8bN2F5zCil9EREfAl4EfmkE628OExqHhHxcuBfyMX1q1JKXx2gj4tiUjOp1NTJdWb6ftygz3mUdsynv2oymRBV5hERR5PPlbIK+MMxKa6h0jxmsJH89a61tLQP1YCa8jip3F4VEVf1eYzlETH1afeyxTpXgYeI1+m2cvvqPstOIZ+Rb3NKad8CtTXbNq+Ztg7ATeQLxU+fbi3L7yn3bxqgv11UWx5zWV5uaz0RXZV5RMSp5BfmJ8lHe3SmuG5AlZlU7D/K7Ssj4hmv8xFxKPnrII8Dc/2OjdKO+fRXWybjrro8IuIY4Mvk4vrdY1RcQ4V5zKL2fSioK4//pH+NMfVd7D099xfvf1wb1wZzmt9EPjzixwxxEXbyoRarmHbh+xHbmro27zbyu0FT81cAD5EPI10xwPNYy3hcB7uqPIAjgRfN8FzOIF8aaldvWzVNteVRlr2S/CLwIPDitsfQTPo+h0Ql18Eu/f1i6fN50+ZfWuav75l3YBnrY+fTTpv51DDVlEmfx9zEGF0Hu7Y8gF8hfxjxFH2uFz8OU2V5vIJp13Uu848FdpRtTm97TCclj1meQ2uv260H6DRicPAG8rtju4FPks8yfHf5ZboBiGnrryvLNsy3rbLNJWX5D4CPAh8nFwcJOHfA57CWMSiwa8sDOLHMv5N8XfKLgCvI7wIm4AngLW2P6QTlcTz5HdxEPpzswn5T22M6SZmU9VcBG3qmRD7pXO+8o9oe11nG+1jgR6Xft5S/89vK/a3AkT3rrijzt8+nncXMp8apwkx6f9cfKOt+tmfey9oe00nJg3wC0kQ+R8qFM0wr2h7TCcrjJ8B24DPAxcBlwOfJH1Ak4PK2x3OS8pjlOVhgO40QXj604lZgJ3kH/S7gPcABfdZdxww7q8O21bPN2cDXyTudu8iHLp0xRP/XMiYFdk15AMuAvwG+AvyQXFA/Rj5Bx3rghLbHcsLymPo7mHVqezwnKZMhclnR9pjOMd6/TD6r7dTf+feAvwOeM229FcywczRMO4uZT61TTZkM8Pu/ru3xnJQ8BsgiAWvbHs8JyuN88vlSvkc++mwf8H1y8feqtsdx0vKYpY3WCuwoHZAkSZIkSfPgSc4kSZIkSWqABbYkSZIkSQ2wwJYkSZIkqQEW2JIkSZIkNcACW5IkSZKkBlhgS5IkSZLUAAtsSZIkSZIaYIEtSZIkSVIDLLAlSZIkSWqABbYkSZIkSQ2wwJYkSZIkqQEW2JIkSZIkNcACW5IkSZKkBlhgS5IkSZLUAAtsSZIkSZIaYIEtSZIkSVIDLLAlSZIkSWrA/wPfMjV36ezwMQAAAABJRU5ErkJggg==\n", + "text/plain": [ + "
" + ] + }, + "metadata": { + "image/png": { + "height": 367, + "width": 492 + }, + "needs_background": "light" + }, + "output_type": "display_data" + } + ], + "source": [ + "# Simple parser\n", + "def parse_lineout(file):\n", + " rdat = np.loadtxt(file)\n", + " columns = ['x', 'y', 'z', 'Ex', 'Ey', 'Ez']\n", + " return {name:rdat[:,i] for i, name in enumerate(columns)}\n", + "\n", + "dat = parse_lineout('x_lineout.dat')\n", + "plt.plot(dat['x'], dat['Ex'])\n", + "plt.plot(dat['z'], dat['Ez'])" + ] + }, + { + "cell_type": "code", + "execution_count": 6, + "id": "hairy-automation", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "[]" + ] + }, + "execution_count": 6, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAAA9gAAALfCAYAAACaWGp9AAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAACIIUlEQVR4nOzdd3hUVeLG8fdk0kgnIaH33nuXqqJrb2sXrNjL7rrdXd3221236NrdVQQruta1oFjoIL0jEEroLYSEkJ7M+f2RYTIgJSGT3Cnfz/PkmblnZm5enl0hb+655xhrrQAAAAAAQO1EOB0AAAAAAIBQQMEGAAAAAMAPKNgAAAAAAPgBBRsAAAAAAD+gYAMAAAAA4AcUbAAAAAAA/ICCDQAAAACAH1CwAQAAAADwAwo2AAAAAAB+QMEGAAAAAMAPKNgAAAAAAPgBBRsAAAAAAD+gYAMAAAAA4AcUbAAAAAAA/ICCXQvGmKuMMU8bY+YYYw4bY6wx5vU6+D49jTGvGmN2GGNKjDH7jTGzjDHj/f29AAAAAABnJtLpAEHuEUm9JR2RtFNSF39/A2PMzZJeklQo6RNJWZJSJPWQdIGkV/39PQEAAAAANUfBrp0fqbJYb5I0StIMf57cGDNEleV6jaTzrbV7j3s9yp/fDwAAAABw5pgiXgvW2hnW2kxrra3uZ4wx1xljZhhjDhljio0x3xljHjHGxJzg7Y9Lckm68fhy7fn+ZbWIDwAAAADwI65g1yNjzMuSblXlVe/3JeVKGiLpD5LONsaca60t97y3haQRkpZIWmuMGSOpvyQraYWkGdZad33/GQAAAAAAJ0bBrieee6lvlfSBpBustUU+rz0m6VFJ90r6l2d4oOcxU9I3kkYfd8rVxpgrrLWb6i41AAAAAKC6mCJefx6UVC7pVt9y7fEHSQcl3eAzluF5vFpSV0lXSEqW1EHSa5J6SvrUGBNdl6EBAAAAANXDFex6YIyJU+Vq49mSHjLGnOhtJaos0ke5fB5vt9Z+4jk+bIyZ4HnvAElXSnqrLnIDAAAAAKqPgl0/GkoyktJVORW8Og55Hkskfeb7grXWGmM+UmXBHiQKNgAAAAA4jini9SPP87jcWmtO9eXzmQ2ex/yTLGZ2tIA3qLPUAAAAAIBqo2DXA2vtEUlrJXU3xqRW82OrVDmlvJExpvEJXu/hecyqfUIAAAAAQG1RsOvPPyVFS5pkjEk5/kVjTENjTL+jx57tul70HD5ujInweW9PSTerctG0d+swMwAAAACgmoy11ukMQcsYc5mkyzyHTSSdJ2mLpDmesWxr7cM+739W0j2SciR9IWm7pFRJbSWNlPSKtfYun/fHSfpalXtlL5c0U5X3cV+pyqnhP7HW/rNO/nAAAAAAgBqhYNeCz/7VJ7PNWtvmuM9cJOkuVS5OlqLKsr1d0nRJr1tr1x/3/jhJP5N0rSqLeLGkxZL+Ya2d5o8/BwAAAACg9ijYAAAAAAD4AfdgAwAAAADgBxRsAAAAAAD8gIINAAAAAIAfULABAAAAAPCDSKcDBBtjzFZJSZKyHI4CAAAAAPC/NpIOW2vb1vSDFOyaS2rQoEFq165dU50OAgAAAADwr++++05FRUVn9FkKds1lde3aNXXp0qVO5wAAAAAA+Fn//v21bNmyrDP5LPdgAwAAAADgBxRsAAAAAAD8gIINAAAAAIAfULABAAAAAPADCjYAAAAAAH5AwQYAAAAAwA8o2AAAAAAA+AEFGwAAAAAAP6BgAwAAAADgBwFRsI0xacaY240xHxhjNhljiowxecaYucaY24wxNcppjGlhjJlkjNltjCkxxmQZY540xjSsqz8DAAAAACC8RTodwOOHkp6XtEfSDEnbJTWWdIWklyT9wBjzQ2utPd2JjDHtJc2XlCHpI0nrJQ2S9KCk840xw621B+vkTwEAAAAACFuBUrA3SrpE0qfWWvfRQWPMryQtknSlKsv2e9U413OqLNcPWGuf9jnXPyX9SNKfJN3lv+gAAAAAAATIFHFr7TfW2o99y7VnfK+kFzyHo093HmNMO0njJGVJeva4lx+VVCDpJmNMfG0zAwAAAADgKyAK9mmUeR7Lq/HesZ7H6Sco6/mS5kmKkzTEf/EAAAAAAAicKeInZIyJlDTec/h5NT7S2fO48SSvZ6ryCncnSV+f5nsvPclLXaqRAwAAAAAQZgL9CvZfJPWQ9Jm19otqvD/Z85h3ktePjqfUMhcAAAAAAMcI2CvYxpgHJP1ElauA3+Sv03oeT7saubW2/0lyLZXUz095AAAAAAAhIiCvYBtj7pX0L0nrJI2x1uZU86NHr1Ann+T1pOPeBwAAAACAXwRcwTbGPCTpGUlrVFmu99bg4xs8j51O8npHz+PJ7tEGAAAAAOCMBFTBNsb8XNITklaoslzvr+EpZngexxljjvmzGWMSJQ2XVCTp21pGBQAAAADgGAFTsI0xv1HlomZLJZ1trc0+xXujjDFdjDHtfcettZslTZfURtK9x33sd5LiJb1qrS3wZ3YAAAAAAAJikTNjzARJv5dUIWmOpAeMMce/LctaO9nzvLmk7yRtU2WZ9nWPpPmSnjLGnO1532BJY1Q5NfzX/v8TAAAAAADCXUAUbEltPY8uSQ+d5D2zJE0+3YmstZuNMQNUWdjPl3SBpD2SnpL0uxosmAYAAAAAQLUFRMG21j4m6bEavD9LVVtunej1HZJuqW0uAAAAAACqK2DuwQYAAAAAIJhRsAEAAAAA8IOAmCIOAACA4GetVW5hmbbnFGpbTqF25BSqsLRcA1qnaki7NDWIdjkdEQDqFAUbAAAA1VZe4daevOLKEn2wUNtzCrU9p8D7PL+4/ASf2qzoyAgNbpuq0Z0zNKpTutqnx+sEu8YAQFCjYAMAAOCUcgpK9c8vN2hOZrZ2HSpSudvW+Byl5W7NyczWnMxs/UFSi4YNNLpzukZ1ytCw9mmKj+HHUgDBj7/JAAAAcELWWn26eo8e/WitDhaUVuszDaJcap0Wp5apcWqVGidrpTmZB5S5/8gx79t5qEivf7tdr3+7XdGuCA1s21CjOqVrdOcMdcxI4Oo2gKBEwQYAAMD37DtcrEc+XKMv1+373msZiTFqlRqnVmmVJbq157FVarwaJUSfsBzvPFSo2RuzNXPDfs3blK2C0grva6UVbs3bdFDzNh3U/322Xs2SY3XNwFYaP7S1GsZH1+mfEwD8yVhb8yk+4cwYs7Rfv379li5d6nQUAAAAv7PW6p0lO/THT7875n7qJkmx+t2l3TWyY3qtFysrLXdr6bZDmrlxv2ZtOKD1e/NP+L64aJeuHdhKt49oq2YpDWr1PQGguvr3769ly5Yts9b2r+lnKdg1RMEGAAChavvBQv3i/VWav/ngMePXD26lX/ygi5Jio+rk++7NK9asjfs1c8MBzc3MVn7JsQulRUYYXdKnme4a1V6dGifWSQYAOKo2BZsp4gAAAGGuwm01eX6W/v7FBhWVVU3dbp0Wp79c0UtD26fV6fdv4pkSfs3AViqrcOuz1Xv0/MzN3ivb5W6r95ft0vvLdunsLhm6a3R7DWyTWqeZAOBMULABAADCWOa+fP3svVVavj3XOxZhpNtHtNOPzulU73tXR7kidGmf5rqkdzPN3HhAL8zcrIVbc7yvf71+v75ev18DWjfUXaPaa2yXDEVEsCAagMBAwQYAAAhDpeVuvTBrs575ZpNKK9ze8S5NEvXXK3upd8sU58JJMsZoTOcMjemcoWXbD+mFmZs13WfBtSXbDun2V5eoY0aC7hzVXpf0bqboyAgHEwMA92DXGPdgAwCAYLdqZ65+9u6qYxYXi3IZ3Temo+4e3T5gi+qm/Uf079mb9cHyXSqrOPZn2KbJsXp4XGdd0a85W3wBqJXa3IMdmH97AgAAoE58umqPrnhu/jHlunfLFH36wAg9eE7HgC3XktQhI0GPX9Vbc342VneMaKt4n+nre/KK9ZP/rtR9by5XXmGZgykBhLPA/RsUAAAAfvXRil16YOpylbsrr/7GRkXokQu76v27hwXV6txNkmP16wu7af4vztZPz+usRglVe2V/unqPzv/XbC04biV0AKgPFGwAAIAw8MHynfrR2ytU4SnX7dPj9cVDI3X7iHZyBekiYclxUbp3TAfN/tkYXTeolXd8T16xrn/pW/1l2nqVlrtPcQYA8C8KNgAAQIh7Z8kO/fidlfJ0a3XMSNDUiUPVOi3e2WB+EhcdqT9f0VMv3tRfDeMq9+q2Vnph1mZd8fw8bT5wxOGEAMIFBRsAACCEvbVou3727iodXde2S5NETZ04ROmJMc4GqwPndW+izx8aqREdG3nH1uw6rIuemqu3Fm0Xi/sCqGsUbAAAgBD12rfb9Mv3V3uPuzVN0pt3DFFaQuiV66MaJ8Vqyi2D9MiFXRXtqvxRt6isQr98f7XufG2pcgpKHU4IIJRRsAEAAELQ5Hlb9ZsP13iPezZP1pt3DFZqfPQpPhUaIiKMbh/RTh/eO1wdMxK849PX7dP5T87WnMwDDqYDEMoo2AAAACHmpTlb9NjH67zHfVqm6PXbByslLvTLta9uzZL08f1nacLQ1t6x/fkluunlRfrjJ+tUUl7hYDoAoYiCDQAAEEKen7lZf/z0O+9x/9YN9dptg5TcIMrBVM6JjXLpd5f20KSbBxyznddLc7fqsmfnK3Nf/ik+DQA1Q8EGAAAIEc98k6m/fr7eezyoTaqm3DpIibHhWa59je3SWNMeHKnRndO9Y9/tOazLn5uv+ZuyHUwGIJRQsAEAAIKctVZPfrVRf5++0Ts2pF2qJt86UAkxkQ4mCyzpiTF65eaB+t0l3RUdWflj8JGSck14ZZE+Xrnb4XQAQgEFGwAAIIhZa/WP6Rv15FeZ3rGzOjTSKzcPUlw05fp4xhhNGNZGH94zXI2TKldTL6uwemDqcr0yb6vD6QAEOwo2AABAkLLW6q+fb9AzMzZ5x0Z1StdLEwaoQbTLwWSBr1uzJL139zC1T4+XJFkr/e7jdfrLtPXslw3gjFGwAQAAgtSkeVl6YdZm7/HYLhl68ab+io2iXFdHi4ZxeveuYerXKsU79sKszfrJf1eqrMLtXDAAQYuCDQAAEISWZOXoz59VrRZ+brfGev7GfpTrGmoYH603bh+is7tkeMfeX7ZLd7y6RIWl5Q4mAxCMKNgAAABBJvtIie59c5nK3ZVTmXu3TNEz1/dVTCTl+kw0iHbpxZv66+oBLbxjMzcc0HX/WaicglIHkwEINhRsAACAIFLhtnpw6nLtO1wiSWoYF6XnbuhHua6lSFeE/nplL90/toN3bOWOXF31/HztyCl0MBmAYELBBgAACCJPfLlR8zYdlCQZIz15bV81T2ngcKrQYIzRT8Z11u8v7S5jKse2ZBfoiufna93uw86GAxAUKNgAAABB4pv1+45ZMfyBsR01qlO6g4lC0/ihbfTs9f0U7ar8UflAfomueXGBFmw+6HAyAIGOgg0AABAEduQU6kdvr/Qej+jYSA+c3dHBRKHtgp5NNeXWQUqMqdxLPL+kXBMmLdJnq/c4nAxAIKNgAwAABLiS8grd88Yy5RWVSZKaJsfqX9f2lSvCOJwstA1tn6Z37hqqjMQYSVJphVv3vrlMry7IcjYYgIBFwQYAAAhwv/94nVbvypMkRbmMnr2hn1Ljox1OFR66Nk3S+/cMU7v0eEmStdJvP1qrf8/efJpPAghHFGwAAIAA9sHynXpj4Xbv8a8v6Kp+rRo6mCj8tGgYp3fvGqY+LVO8Y//32Xo963M/PABIFGwAAICAtWFvvn75/mrv8YW9mmrCsDbOBQpjqfHReuP2wRrUNtU79rcvNuhfX2U6mApAoKFgAwAABKD84jLd/fpSFZe5JUnt0+P11yt7yRjuu3ZKfEykJt8yUMPap3nHnvhqo/45fYOstQ4mAxAoKNgAAAABxlqrX7y3WluyCyRJDaJcev7G/krwrGgN58RFR+rlCQM1omMj79hT32zS376gZAOgYAMAAAScV+Zl6VOf7aD+fEVPdWqc6GAi+GoQ7dJ/xg/Q6M5Ve5A/N3Oz/jxtPSUbCHMUbAAAgACydFuO/u+z77zHNw5ppcv6NncwEU4kNsqlF2/qr7O7ZHjH/j17i/7wyXeUbCCMUbABAAACRPaREt37xnKVuysLWq8WyfrNRd0cToWTiYmsnLo/rltj79ikeVv12P/WUrKBMEXBBgAACAAVbqsHpy7X3sPFkqTkBlF69vp+iol0OZwMpxIdGaFnb+inC3o28Y5NWbBNj3y4Rm43JRsINxRsAACAAPDy3C2at+mg9/jJa/qoZWqcg4lQXVGuCD11bV9d3LuZd+yNhdv1qw9WU7KBMEPBBgAAcFj2kRI99fUm7/F9YzpojM+9vQh8ka4IPXF1b13Wp6pkT128Qz99d5UqKNlA2KBgAwAAOOyJLzfqSEm5JKlderwePKejw4lwJiJdEfrH1X10Vf8W3rH3lu3UT95ZofIKt4PJANQXCjYAAICDNuzN11uLtnuPf31BV0W5+BEtWLkijB6/speuHdjSO/bhit360TsrKdlAGOBvbwAAAIdYa/XHT9fp6Aziszo00limhge9iAij/7u8p24Y3Mo79vHK3frVB6tZXRwIcRRsAAAAh8zceEBzMrMlSRFGeuSirjLGOJwK/hARYfTHy3po/NDW3rF3luzUnz5ln2wglFGwAQAAHFBW4dafPv3Oe3zNwJbq0iTJwUTwN2OMHru4+zH3ZL80d6uenbHpFJ8CEMwo2AAAAA54a9F2bdp/RJKUEBOpH5/b2eFEqAsREUZ/uaKnzu9etU/236dv1KsLspwLBaDOULABAADqWV5RmZ74cqP3+J4x7ZWeGONgItSlSFeE/nVdH53VoZF37LcfrdWHy3c5mApAXaBgAwAA1LNnvsnUocIySVLzlAa6dXhbhxOhrsVEuvTiTf3Vt1WKd+wn/12pr9btcy4UAL+jYAMAANSjrOwCTZ6f5T3+xQ+6KDbK5Vwg1Jv4mEi9cvNAdW6cKEmqcFvd8+YyLdh80OFkAPyFgg0AAFCP/jJtvcoqKleR7t+6oS7q1dThRKhPKXHReu22QWqVGidJKi136/Ypi7VqZ66zwQD4BQUbAACgnny75aA+X7vXe/zIhWzLFY4ykmL1xu2DleG5776gtEITJi1S5r58h5MBqC0KNgAAQD1wu63++Ok67/GlfZqpb6uGDiaCk1qmxun12wcrJS5KknSosEw3vbxIO3IKHU4GoDYo2AAAAPXgvWU7tWbXYUlSTGSEfnZ+F4cTwWmdGidq8i2DFB9deQ/+3sPFuvHlhdqfX+xwMgBnioINAABQxwpLy/W3LzZ4jyeObKfmKQ0cTIRA0adliv4zfoCiIyt/LN92sFDjX16kPM8q8wCCCwUbAACgjr0wa4v255dIktITY3TXqPYOJ0IgGdahkZ65rq9cEZX346/fm69bJi9SYWm5w8kA1BQFGwAAoA7tySvSv2dv9h7/dFxnxcdEOpgIgWhc9yZ6/Mpe3uNl23N152tLVVrudjAVgJqiYAMAANShv32+QcVllSWpW9MkXdm/hcOJEKiu7N9Cj17czXs8JzNbD/93pdxu62AqADUREAXbGHOVMeZpY8wcY8xhY4w1xrx+BufJ8nz2RF97T38GAAAA/1m5I1fvL9/lPX7koq7eacDAidwyvK0eOqej9/h/K3frj59+J2sp2UAwCJT5SY9I6i3piKSdkmqzrGaepCdPMH6kFucEAACoEWut/vBJ1bZc53ZrrGHtGzmYCMHiwbM76uCRUr327TZJ0qR5W9U4KUZ3cu8+EPACpWD/SJXFepOkUZJm1OJcudbax/wRCgAA4ExNW7NXS7YdkiRFuYx+dUFXhxMhWBhj9Ngl3XUgv0Sfr62chPnnaeuVnhijK/pxiwEQyAJiiri1doa1NtMy9wUAAISA4rIK/Xnad97j8UPbqG2jeAcTIdi4IoyevLaPBrVN9Y797N1Vmrlhv4OpAJxOQBRsP4sxxtxojPmVMeZBY8wYY4zL6VAAACB8vP7tNu3IKZIkpcRF6YGxHU/zCeD7YqNc+s/4AercOFGSVO62uueNZVq5I9fZYABOKhQLdhNJr0n6kyrvxf5GUqYxZlRNTmKMWXqiL9Xu/nAAABDiKtxWr8zL8h4/dHZHJcdFORcIQS25QZSm3DpIzVMaSJIKSyt0y+TF2ppd4HAyACcSagX7FUlnq7Jkx0vqKelFSW0kTTPG9HYuGgAACAffrN+vXbmVV69T46N17aBWDidCsGuSHKsptw5SiucXNTkFpRo/aaH25xc7nAzA8UKqYFtrf2et/cZau89aW2itXWOtvUvSPyU1kPRYDc7V/0RfktbXUXwAABACjq78LElXD2ip2CjuVEPtdchI0MsTBio2qvLH9x05Rbp50mLlF5c5nAyAr5Aq2KfwgudxpKMpAABASMvKLtDsjQckScZINwzm6jX8p3/rhnr2+n7evdTX7Tmsu15fqpLyCoeTATgqXAr20eUWWb4TAADUmdd9rl6P7ZyhlqlxDqZBKDq7a2P9+fKe3uN5mw7qJ++slNvNZjxAIAiXgj3U87jF0RQAACBkFZVW6L9Ld3qPbxza2sE0CGVXD2yph8d18h5/smqP/vDpOrHjLeC8oCvYxpgoY0wXY0z748a7G2NST/D+1pKe8Ry+Xh8ZAQBA+Pl45W7lFVXeD9sqNU6jOqY7nAih7N4xHTTe55c4r8zL0ouzuZYEOC3S6QCSZIy5TNJlnsMmnsehxpjJnufZ1tqHPc+bS/pO0jZVrg5+1A8l/cIYM0PSVkn5ktpLulBSrKTPJP29Tv4AAAAgrFlr9eq3Wd7jG4e0UoTnPlmgLhhj9OjF3ZV9pESfrd4rSfrLtPVKT4jRlf1bOJwOCF8BUbAl9ZE04bixdp4vqbJMP6xTmyGps6S+qpwSHi8pV9JcVe6L/Zpl3gwAAKgDK3bkas2uw5KkmMgI/bB/S4cTIRy4Ioz+eXUfHTyySAu35kiSfv7eKqUmRGtM5wyH0wHhKSCmiFtrH7PWmlN8tfF5b9bxY57xWdba66y1Xay1KdbaKGtturX2XGvtq5RrAABQV3y35rq4dzM1jI92MA3CSWyUS/+ZMEBdmiRKksrdVve8vkzLtx9yOBkQngKiYAMAAASrnIJSfbJqj/f4piEsbob6lRQbpSm3DlLzlAaSpKKyCt06ebE2HzjicDIg/FCwAQAAauGdJTtUWu6WJPVukazeLVOcDYSw1DgpVq/eNkgN46IkSYcKyzT+5UXam1fscDIgvFCwAQAAzlCF2+qNhVXTw2/k6jUc1D49Qa/cMkgNolySpF25RZowaZF3dXsAdY+CDQAAcIZmbdyvHTlFkqSUuChd3LuZw4kQ7vq0TNHzN/ZTpGcV+w378nXHlCUqLqtwOBkQHijYAAAAZ+i1BVVXr68e0FKxniuHgJNGd87Q337Yy3u8KCtHD7y1XBVu1vwF6hoFGwAA4AxsP1iomRsPSJKMkW4Y3MrhRECVy/u20K8v6Oo9nr5unx75cI3YWAeoWxRsAACAM/DGwm062lVGdUpX67R4ZwMBx7ljZDvdMaKt9/itRdv15FeZDiYCQh8FGwAAoIaKyyr09pId3mO25kKg+uUPuuryvs29x//6OvOYfdsB+BcFGwAAoIY+WbVHuYWVKzO3aNhAoztnOJwIOLGICKPHr+qlUZ3SvWO//WiNpq3ec4pPAThTFGwAAIAa8r0CeMPg1nJ5VmwGAlGUK0LP3dBPvVskS5KslR6cukILNh90OBkQeijYAAAANbBqZ65W7siVJEVHRuiagS2dDQRUQ3xMpCbdPFDtGlWuFVBa4dbEV5do3e7DDicDQgsFGwAAoAZ8t+a6qGdTpcZHO5gGqL60hBhNuXWQMhJjJEn5JeWa8Moi7cgpdDgZEDoo2AAAANWUW1iq/63c7T2+aSiLmyG4tEyN05RbBykxJlKSdCC/ROMnLdLBIyUOJwNCAwUbAACgmv67ZKdKyt2SpB7Nk9SnZYqzgYAz0LVpkv4zYYCiIyurwNbsAt06ZYkKS8sdTgYEPwo2AABANbjdVq8vrJoeftOQ1jKGxc0QnIa0S9NT1/bR0f8Lr9yRq/veXK7yCrezwYAgR8EGAACohjmbsrXtYOW9qkmxkbqkd/PTfAIIbOf3aKrfXdLde/zN+v369QdrZK11MBUQ3CjYAAAA1fDagizv8x8OaKkG0S7nwgB+Mn5oG90zur33+O0lO/TkV5kOJgKCGwUbAADgNHbkFOrr9fu9xzcOYXEzhI6fntdZV/SrmpHxr68z9dai7Q4mAoIXBRsAAOA03ly0XUdnzY7o2EhtPXsJA6HAGKO/XtlLIzule8d+/cFqff3dPgdTAcGJgg0AAHAKJeUVenvxDu/x+KFtnAsD1JEoV4Seu6GfejRPkiS5rXTvm8u0bPshh5MBwYWCDQAAcArTVu9VTkGpJKl5SgON7ZLhcCKgbiTERGrSzQPVMrWBJKm4zK3bJi/WlgNHHE4GBA8KNgAAwCn43ot6/eBWckWwNRdCV0ZirKbcMkgN46IkSYcKyzThlUXan1/scDIgOFCwAQAATmJvXrEWZeVIkiKM9MMBLRxOBNS9dukJmnTzQMVGVVaFHTlFunXyYh0pKXc4GRD4KNgAAAAn8enqPd7FzYa1b6SMxFhnAwH1pG+rhnr2+n46OmFjza7Duvv1pSqrcDsbDAhwFGwAAICT+Hjlbu/zi3s3dTAJUP/O7tpYf7q8p/d4Tma2fv7eKtmjv3UC8D0UbAAAgBPYkVOoFTtyJUlRLqPzujdxNhDggOsGtdKDZ3f0Hr+/bJf+9sUGBxMBgY2CDQAAcAIfr6q6ej2yY7pS4qIdTAM456FzOuqaAS29x8/N3KxXF2Q5FwgIYBRsAACAE/h45R7v84t7N3MwCeAsY4z+dHkPjemc7h179H9r9dnqPaf4FBCeKNgAAADH2bQ/X9/tOSxJiomM0DndGjucCHBWpCtCz97QT71bpkiSrJUenLpcszYecDYYEGAo2AAAAMfxvXo9tkuGEmIiHUwDBIa46EhNmjBA7RrFS5LKKqzufG2Jlni2sgNAwQYAADiGtfaY+6+ZHg5USUuI0eu3D1bzlAaSpOIyt26ZvFhrd+c5nAwIDBRsAAAAH+v2HNaWAwWSpPhol8Z0znA4ERBYmqU00Gu3DVKjhMqF//KLyzX+5UXacuCIw8kA51GwAQAAfPhODz+3W2M1iHY5mAYITO3SE/TqrYOVGFt5+8TBglLd+NJC7cotcjgZ4CwKNgAAgIe1Vh+vZHo4UB3dmiVp8i0D1SCq8pdQu/OKddNLC3Ugv8ThZIBzKNgAAAAey3fkeq/AJcVGakTH9NN8Aghv/Vun6t/j+yvaVVkrtmQXaPykRcorKnM4GeAMCjYAAICH79XrH/RoquhIflQCTmdEx3Q9dV0fRZjK4+/2HNatkxersLTc2WCAA/hXAwAAQFKF2+rTVVX3XzM9HKi+83s01eNX9fYeL912SHe+tlQl5RUOpgLqHwUbAABA0qKtOdrvuXe0UUK0hrRLdTgREFyu6t9Cj17czXs8JzNbD01dofIKt4OpgPpFwQYAAJCO2fv6gp5NFenixySgpm4Z3lY/PreT93jamr36xfur5XZbB1MB9Yd/OQAAQNgrq3Br2mqmhwP+cP/YDrr9rLbe43eX7tQfPl0naynZCH0UbAAAEPbmbcrWocLKVY+bJseqf6uGDicCgpcxRr++sKuuGdDSO/bKvCz96+tMB1MB9YOCDQAAwt7HK6uuXl/Uq6kiji6HDOCMGGP0f1f01IU9m3rHnvwqUy/O2uxgKqDuUbABAEBYKy6r0PS1e73HTA8H/MMVYfTENX00qlPVfvJ/nrZeT3MlGyGMgg0AAMLarI0HlF9SuV9v67Q49Wye7HAiIHRER0bohRv7H7Mq/z++3Ki/f7GBe7IRkijYAAAgrH28smr18It7NZMxTA8H/KlBtEuv3DxIIzo28o49M2OT/jxtPSUbIYeCDQAAwlZhabm+/m6/95jp4UDdaBDt0n/GD9DYLhnesX/P3qLH/reWLbwQUijYAAAgbH313X4VlVVIkjo1TlDnJokOJwJCV2yUSy/c2F/ndW/sHZuyYJt+9QH7ZCN0ULABAEDYOn56OIC6FR0ZoWeu73fMbJGpi3fo4f+uVHmF28FkgH9QsAEAQFjKKyrTrA0HvMcXMT0cqBdRrgg9eU0fXdmvhXfs/eW79NDbK1RGyUaQo2ADAICwNH3tXpV6fpjv2TxZbRvFO5wICB+uCKO/XdVL1w1q6R37ZNUe3fvGMpWUVziYDKgdCjYAAAhLH6/a431+ce+mDiYBwlNEhNH/Xd5TNw9r4x2bvm6f7nptqYrLKNkIThRsAAAQdg4eKdG8Tdne4wu5/xpwhDFGj17cTRNHtvOOzdhwQLdPWaKiUko2gg8FGwAAhJ1pa/aqwrNq8YDWDdU8pYHDiYDwZYzRL3/QRfeP7eAdm7spWxNeWaQjJeUOJgNqjoINAADCzjGrh7O4GeA4Y4x+Mq6zfnJuJ+/Yoq05Gv/yQuUVlTmYDKgZCjYAAAgre/OKtSgrR5IUYaQf9GzicCIAR91/dkf96oIu3uNl23N1/X++VfaREgdTAdVHwQYAAGHl09V7ZCtnh2to+zRlJMY6GwjAMSaObK/fXdLde7x292Fd/cIC7cotcjAVUD0UbAAAEFZ8p4dfxOJmQECaMKyNHr+ylyJM5fGW7AJd9fx8bdp/xNlgwGlQsAEAQNjYkVOoFTtyJUmREUbnd2d6OBCorh7YUs9e30/RrsrKsievWFe/uECrd+Y5nAw4OQo2AAAIGx+vqrp6PaJjIzWMj3YwDYDT+UHPpnr55gGKi3ZJknIKSnXdf77Vt1sOOpwMODEKNgAACBsfr9zjfc7q4UBwGNExXa/fPljJDaIkSUdKyjVh0iJ9/d0+h5MB30fBBgAAYWFrdoG+23NYkhQdGaFzuzV2OBGA6urXqqHeuXOoMhJjJEkl5W5NfG2pPly+y+FkwLEo2AAAICx8trrq6vXIjulKjI1yMA2AmurcJFHv3jVMrVLjJEkVbquH3l6hKfOznA0G+AiIgm2MucoY87QxZo4x5rAxxhpjXj/Dc7Uwxkwyxuw2xpQYY7KMMU8aYxr6OzcAAAgen66qKtgX9mJxMyAYtUqL07t3DVXnxonesUf/t1ZPfZ0pe3T/PcBBAVGwJT0i6T5JfSSd8TwPY0x7SUsl3SJpkaQnJG2R9KCkBcaYtFonBQAAQScru0Drjk4Pd0Xo7K5MDweCVUZSrN6+c4j6tkrxjv3zy436wyffye2mZMNZgVKwfySpk6QkSXfX4jzPScqQ9IC19jJr7S+stWNVWbQ7S/pTrZMCAICg86nv9PBOjZTE9HAgqKXEReuN2wdrRMdG3rFJ87bqp++uUnmF28FkCHcBUbCttTOstZm2FvM6jDHtJI2TlCXp2eNeflRSgaSbjDHxZxwUAAAEJd/7ry/o2dTBJAD8JS46Ui9NGKALff6bfm/ZTt39xjIVl1U4mAzhLCAKtp+M9TxOt9Ye82sra22+pHmS4iQNqe9gAADAOdsOFmjt7qrp4eewejgQMmIiXXrqur66dmBL79iX6/Zp/KRFyissczAZwlUoFezOnseNJ3k90/PYqR6yAACAAOE7PXxER6aHA6HGFWH05yt66s5R7bxji7bm6MoX5mtHTqGDyRCOQqlgJ3se807y+tHxlOqczBiz9ERfkrrUMicAAKhHTA8HQp8xRr/8QVf98gdVP6pv2n9Elz83X6t25joXDGEnlAr26RjPI0sLAgAQJrYfLNSaXZXTw6NchunhQIi7c1R7PX1dX0W7KmtO9pESXfPit/r6u30OJ0O4CKWCffQKdfJJXk867n2nZK3tf6IvSetrGxQAANSPY6eHpyu5AdPDgVB3ce9mev32wd7/3ovKKnTHq0v02rfbHE6GcBBKBXuD5/Fk91h39Dye7B5tAAAQYqatYXo4EI4GtU3Ve3cPU8vUBpIkt5V+8+Ea/Xkae2WjboVSwZ7heRxnjDnmz2WMSZQ0XFKRpG/rOxgAAKh/O3IKtWpn5cS1KJfRuUwPB8JKh4wEvX/3cPVuUTXB9cVZW/TA1OVs44U6E3QF2xgTZYzpYoxp7zturd0sabqkNpLuPe5jv5MUL+lVa21BvQQFAACO8l3c7KwOjZgeDoSh9MQYvTVxiM7pmuEd+2TVHt308kLlFpY6mAyhKiAKtjHmMmPMZGPMZEm/8AwPPTpmjPm7z9ubS/pO0tcnONU9kvZLesoY86Ex5s/GmG8k/UiVU8N/XXd/CgAAEEhYPRyAJMVFR+rFmwZo/NDW3rHFWYd0xfPztf0g23jBvwKiYEvqI2mC5+s8z1g7n7GrqnMSz1XsAZImSxos6SeS2kt6StJQa+1Bf4YGAACBaUdOoVb6TA8f162Jw4kAOMkVYfS7S7rr1xd09Y5tOVCgK56fp5U7cp0LhpATEAXbWvuYtdac4quNz3uzjh877lw7rLW3WGubWmujrbWtrbUPWmtz6uvPAwAAnOW7uNnwDo2UHMf0cCDcGWN0x8h2evb6foqOPLqNV6mu+fcCfbmObbzgHwFRsAEAAPzp09V7vc+ZHg7A14W9murN2wcrxfOLt+Iyt+58bYkmzd0qa1lhHLVDwQYAACFl56FC75TPyAijcaweDuA4A9qk6v27h6lVapykym28fv/JOv3o7RUqLC13OB2CGQUbAACElGk+V6+Hd2iklLhoB9MACFTt0hP0/j3D1KdlinfswxW7dcVz85WVzcZDODMUbAAAEFI+9Vk9/EKmhwM4hUYJMZo6cYiuHdjSO7Z+b74ufmauvuK+bJwBCjYAAAgZu3KLtMJ3enh3pocDOLXYKJf+cmUv/eWKnt7Fz/KLy3X7q0v0j+kbVOHmvmxUHwUbAACEjGk+V6+HMT0cQA1cO6iV3r1rqJqnNPCOPf3NJt0yebEOFZQ6mAzBhIINAABCxrHTw9n7GkDN9GqRoo/vP0sjOjbyjs3eeEAXPzNXa3blOZgMwYKCDQAAQsLu3CIt354rSXJFGI3rRsEGUHOp8dGafMsg3TumvXds56EiXfH8fL2zZIeDyRAMKNgAACAkfOY7Pbx9mhrGMz0cwJlxRRj99Lwu+vdN/ZUYEylJKi1362fvrtIv31+tkvIKhxMiUFGwAQBASPiM1cMB+Nm47k300X3D1alxgnfsrUXbdfULC7Q7t8jBZAhUFGwAABD0ducWaZnv9PDuTA8H4B/t0hP04b3DdXHvZt6xlTvzdNHTczU3M9vBZAhEFGwAABD0pq3Z630+rH2aUpkeDsCP4qIj9dS1ffTbi7opMsJIknIKSnXTpIX66+frVVbhdjghAgUFGwAABD3f6eEXMD0cQB0wxujWs9rqzTuGKD0xRpJkrfT8zM266oUF2nawwOGECAQUbAAAENT25BVp6bZDkiqnh5/H9HAAdWhQ21R9+sCxW3mt3JGrC5+aqw+W73QwGQIBBRsAAAS1aaurpocPbcf0cAB1LyMxVlNuGaRfXdBFUa7KKeNHSsr1o7dX6kdvr1B+cZnDCeEUCjYAAAhqTA8H4ISICKOJI9vrvbuHqU1anHf8g+W7dOFTc7ViR65z4eAYCjYAAAhae/OKteSY6eGNHU4EINz0apGiTx4YoSv7tfCObc8p1FXPz9dzMzfJ7bYOpkN9o2ADAICgNW1N1dXrIe1SlZYQ42AaAOEqISZS/7i6t/51bR8lxkRKksrdVo9/vkE3TVqofYeLHU6I+kLBBgAAQYvp4QACyaV9muuzB0eob6sU79i8TQd1/pOz9dW6fc4FQ72hYAMAgKC073DV9PAII1YPBxAQWqbG6Z07h+q+MR1kKtc/06HCMt3+6hI9+tEaFZdVOBsQdYqCDQAAgtLna/bKem5tHNw2TY2YHg4gQES5IvTweZ315u1D1CQp1js+ZcE2XfLMXK3emedgOtQlCjYAAAhKn/pOD+/F9HAAgWdo+zRNe3CExnWrWoBx474juuy5efrH9A0qLXc7mA51gYINAACCTvaREi3JypEkGSOdz/RwAAGqYXy0Xrypv/54WQ81iHJJkircVk9/s0mXPDNXa3ZxNTuUULABAEDQ+ea7/Tq6883A1qlKT2R6OIDAZYzRjUNa6/OHRmhQm1Tv+Pq9+brs2Xl68quNKqvganYooGADAICgM33dXu/zcex9DSBItE6L19SJQ/Toxd0UG1VZxcrdVk9+lalLn5mndbsPO5wQtUXBBgAAQaWgpFyzM7O9x+d2o2ADCB4REUa3DG+raQ+O1IDWDb3j6/Yc1qXPztVTX2dyNTuIUbABAEBQmZN5wLswUJcmiWqdFu9wIgCoubaN4vX2nUP1yIVdFRNZWcvKKqz++eVGXf7cPG3Ym+9wQpwJCjYAAAgq09fu8z4fx9VrAEHMFWF0+4h2+uzBEerbKsU7vmbXYV309Bw9O2OTyrmaHVQo2AAAIGiUVbj19fr93uNzu7F6OIDg1z49Qe/eNUy/uqCLon2uZv/tiw268vn52riPq9nBgoINAACCxuKtOcorKpMkNU2OVY/mSQ4nAgD/cEUYTRzZXp89cJZ6t0zxjq/cmacLn5qjv36+XoWl5c4FRLVQsAEAQNCYvu7Y6eHGGAfTAID/dchI1Ht3DdXPz++iaFfV1eznZ27WOf+Ypc9W75G11uGUOBkKNgAACArWWn3pW7C7Mz0cQGiKdEXo7tHt9ckDZx2z0vjuvGLd88YyjZ+0SJsPHHEwIU6Ggg0AAILC2t2HtSu3SJKUFBupQW1THU4EAHWrU+NEvXPnUP39h72VFh/tHZ+Tma3zn5ytx5k2HnAo2AAAICj4Tg8/u2tjRbn4MQZA6IuIMLqqfwt98/BoTRjaWhGeO2PKKqye80wb/3wN08YDBf8yAQCAoDB97V7vc7bnAhBukhtE6XeX9tD/7jtL/Xy29NqdV6y7Xl+mCa8s1hamjTuOgg0AAALe9oOFWr+3cpua6MgIjeyU7nAiAHBGj+bJeveuYXr8ql5K9Zk2PnvjAZ3/5Bz97Yv1KiqtcDBheKNgAwCAgDd9XdXV6xEdGik+JtLBNADgrIgIo6sHtNSMn4zWTUOqpo2XVrj17IzNOuefTBt3CgUbAAAEPN/7r89lejgASJKS46L0h8sqp4338dk7e1duke56fZmufnGBlm0/5FzAMETBBgAAAe3gkRItycqRJBlTucAZAKBKj+bJev/uYfrrlT3VMC7KO74465CueG6+7n59Kfdn1xMKNgAACGhfr98vt2eWY/9WDZWeGONsIAAIQBERRtcMbKUZD4/WzcPaKPLovHFJ09bs1bgnZus3H67RgfwSB1OGPgo2AAAIaF/6TA8f152r1wBwKilx0Xrsku766sejdGGvpt7xcrfVa99u0+i/zdBTX2eyf3YdoWADAICAVVRaoTmZB7zH53Zr4mAaAAgebRrF69nr++nDe4drUNtU73hBaYX++eVGjf7bTL21aLvKK9wOpgw9FGwAABCwZmceUHFZ5Q9/nRonqG2jeIcTAUBw6dMyRW9PHKKXJwxQx4wE7/j+/BL98v3VOv9fc/Tlun2sOO4nFGwAABCwpq/1mR7O1WsAOCPGGJ3dtbGmPThCf7mipzJ81rLYtP+I7nh1ia558VtWHPcDCjYAAAhI5RVufb2e+68BwF8iXRG6dlArzfzpaD08rpMSYiK9ry3KytEVz83XrZMXa+WOXOdCBjkKNgAACEiLsw4pt7BMktQkKVY9myc7nAgAQkNcdKTuG9tRs376/RXHv1m/X5c+O4+ifYYo2AAAICBNX7fX+/zcbo1ljDnFuwEANZWWEONdcfzi3s3k+9csRfvMULABAEDAsdYee/8108MBoM60aRSvp6/rq+kPjaRo1xIFGwAABJzv9uRrV26RJCkxNlKD26Y5nAgAQl/HxokU7VqiYAMAgIDjOz18bJcMRUfyIwsA1BeK9pnjXysAABBw2J4LAJxXnaJ9yyuLtHDLQfbR9qBgAwCAgLIjp1Dr9hyWJEW7IjSqc7rDiQAgvJ2qaM/YcEDX/PtbXfbcfH26ao8q3OFdtCnYAAAgoHy5rurq9fAOacfs0woAcM6pivbKHbm6981lGvP3mXp1QZYKS8udC+ogCjYAAAgovvdfj+vO9HAACDRHi/ZXPx6l6wa1PGadjO05hfrtR2s17C/f6J/TN+hAfomDSesfBRsAAASMQwWlWrQ1R5JkjHR21wyHEwEATqZ9eoL+fEUvzfv5WN0/toNS4qK8r+UWlumpbzZp+F+/0S/fX63NB444mLT+ULABAEDA+Hr9fh29fa9fq4bKSIx1NhAA4LTSE2P0k3GdNf8XY/W7S7qrZWoD72ul5W69tWi7zvnnLN3x6hItzsoJ6QXRuKkJAAAEjOlrq6aHn9utsYNJAAA1FRcdqQnD2uiGwa30+dq9+vfsLVq1M0+SZG3lGhtfrtunvq1SdOfIdhrXrYkiIsxpzhpcuIINAAACQlFphWZnHvAej6NgA0BQinRF6KJezfTRvcM1deIQje1y7O0+y7fn6q+fb3AoXd3iCjYAAAgIczdlq7jMLUnqkJGgdukJDicCANSGMUZD2qVpSLs0Ze7L13/mbNGHy3ertMKt20e0Dbmr1xIFGwAABAjf6eFcvQaA0NKxcaIev6q3Hh7XWW8u2q4r+7VwOlKdoGADAADHlVe49dV3Vftfsz0XAISmjKRYPXROJ6dj1BnuwQYAAI5buu2QDhWWSZIaJ8WoV/NkhxMBAFBzFGwAAOC46euqrl6f261xSN6XBwAIfQFVsI0xLYwxk4wxu40xJcaYLGPMk8aYhjU4R5Yxxp7ka+/pzwAAAOqTtVbT1/nef830cABAcAqYe7CNMe0lzZeUIekjSeslDZL0oKTzjTHDrbUHq3m6PElPnmD8iB+iAgAAP9p84Ih25BRJkhJiIjWkXZrDiQAAODMBU7AlPafKcv2Atfbpo4PGmH9K+pGkP0m6q5rnyrXWPub3hAAAwO9mrK/a+3pEx0aKjgyoCXYAAFRbQPwLZoxpJ2mcpCxJzx738qOSCiTdZIyJr+doAACgjs3YsN/7fEznDAeTAABQO4FyBXus53G6tdbt+4K1Nt8YM0+VBXyIpK+rcb4YY8yNklqpspyvkjTbWlvhx8wAAKCW8ovLtDgrx3s8qnO6g2kAAKidQCnYnT2PG0/yeqYqC3YnVa9gN5H02nFjW40xt1hrZ1UnkDFm6Ule6lKdzwMAgNObt+mgyiqsJKl7syQ1Top1OBEAAGcuIKaISzq62WXeSV4/Op5SjXO9IulsVZbseEk9Jb0oqY2kacaY3mecEgAA+NVMpocDAEJIoFzBPp2jm2Ha073RWvu744bWSLrLGHNE0k8kPSbp8mqcp/8Jg1Re2e53us8DAIBTs9Yee/91F6aHAwCCW6BcwT56hTr5JK8nHfe+M/GC53FkLc4BAAD85Ls9+dp3uESSlNwgSn1aNnQ4EQAAtRMoBXuD57HTSV7v6Hk82T3a1XH0V+SsRA4AQACYubHq6vXITulyRZhTvBsAgMAXKAV7hudxnDHmmEzGmERJwyUVSfq2Ft9jqOdxSy3OAQAA/GSmz/7XY1g9HAAQAgKiYFtrN0uarsqFyO497uXfqfKq86vW2gJJMsZEGWO6GGPa+77RGNPdGJN6/PmNMa0lPeM5fN3P8QEAQA3lFZZp6fZDkiRjKq9gAwAQ7AJpkbN7JM2X9JQx5mxJ30kaLGmMKqeG/9rnvc09r29TZSk/6oeSfmGMmSFpq6R8Se0lXSgpVtJnkv5ep38KAABwWnM2HVCFu3Lt0l4tUtQoIcbhRAAA1F7AFGxr7WZjzABJv5d0vqQLJO2R9JSk31lrc6pxmhmq3FO7ryqnhMdLypU0V5X7Yr9mrT3tSuQAAKBuzWB6OAAgBAVMwZYka+0OSbdU431Zqtq6y3d8lqRZ/k8GAAD8xe22mrWR/a8BAKEnIO7BBgAA4WPN7jxlHymVJKXFR6tn85Pt0gkAQHChYAMAgHrlOz18VKd0RbA9FwAgRFCwAQBAvfLd/3p0F6aHAwBCBwUbAADUm5yCUq3YkStJijDSyI6NnA0EAIAfUbABAEC9mb3xgI7u59GvVUOlxEU7GwgAAD+iYAMAgHozY4PP6uFMDwcAhBgKNgAAqBcVbqtZG6sWOBvN/tcAgBBDwQYAAPVixY5c5RaWSZIyEmPUrWmSw4kAAPAvCjYAAKgXM32mh4/unC5j2J4LABBaKNgAAKBeHHP/dWfuvwYAhB4KNgAAqHP784u1ZtdhSVJkhNFwtucCAIQgCjYAAKhzszZULW42oE1DJcVGOZgGAIC6QcEGAAB1bqZPwWZ6OAAgVFGwAQBAnSqrcGt2pk/BZv9rAECIomADAIA6tWzbIeUXl0uSmqc0UMeMBIcTAQBQNyjYAACgTs3wmR4+iu25AAAhjIINAADq1Ey25wIAhAkKNgAAqDO7c4u0fm++JCnaFaFh7dMcTgQAQN2hYAMAgDoza2PV9PDB7VIVHxPpYBoAAOoWBRsAANSZGeurpoePZno4ACDEUbABAECdKCmv0LxN2d7jMZ3THUwDAEDdo2ADAIA6sSTrkApKKyRJrdPi1LZRvMOJAACoWxRsAABQJ46ZHt6J7bkAAKGPgg0AAOrEDJ/tuUZ34f5rAEDoo2ADAAC/236wUJsPFEiSYiIjNLQd23MBAEIfBRsAAPjdzI1VV6+HtU9TbJTLwTQAANQPCjYAAPC7mRuq9r8ew/RwAECYoGADAAC/Ki6r0PzNVdtzje5EwQYAhAcKNgAA8KtvtxxUcZlbktQ+PV6t0uIcTgQAQP2gYAMAAL/ynR4+ujNXrwEA4YOCDQAA/MZaq2989r8eQ8EGAIQRCjYAAPCbrdkF2p5TKEmKi3ZpYNuGDicCAKD+ULABAIDfzPCZHj6sfSPFRLI9FwAgfFCwAQCA38zcUDU9fCzbcwEAwgwFGwAA+EVhabkWbsnxHo/unO5gGgAA6h8FGwAA+MX8TQdVWlG5PVeXJolqltLA4UQAANQvCjYAAPCLGT7Tw9meCwAQjijYAACg1qy1x+x/PYbp4QCAMETBBgAAtZa5/4h25RZJkhJjI9WvNdtzAQDCDwUbAADU2oz1VdPDR3RspCgXP2IAAMIP//oBAIBa4/5rAAAo2AAAoJYOF5dpSdYh7/HoTtx/DQAITxRsAABQK/Mys1XutpKkHs2TlJEU63AiAACcQcEGAAC14js9fAzTwwEAYYyCDQAAztjx23Nx/zUAIJxRsAEAwBlbt+ew9ueXSJJS4qLUp2WKs4EAAHAQBRsAAJwx36vXozqlyxVhHEwDAICzKNgAAOCM+e5/zf3XAIBwR8EGAABnJLewVMu2V27PZYw0ku25AABhjoINAADOyOzMbHl251LvFilKjY92NhAAAA6jYAMAgDMyk+nhAAAcg4INAABqzO22mrmxaoGzMV2YHg4AAAUbAADU2KpdecopKJUkNUqIVo9myQ4nAgDAeRRsAABQY76rh4/qlKEItucCAICCDQAAao7p4QAAfB8FGwAA1Ej2kRKt2pkrSXJFGI3oQMEGAECiYAMAgBqavfGArGd7rv6tGio5LsrZQAAABAgKNgAAqJEZG6qmh49mejgAAF4UbAAAUG3lFW7N9rn/enQn9r8GAOAoCjYAAKi2FTtylVdUJklqnBSjrk0THU4EAEDgoGADAIBqm7GhanuuMZ0zZAzbcwEAcBQFGwAAVNuM9T7TwzszPRwAAF8BVbCNMS2MMZOMMbuNMSXGmCxjzJPGmIZOnAcAAFTZm1esdXsOS5KiXEbDO6Q5nAgAgMAS6XSAo4wx7SXNl5Qh6SNJ6yUNkvSgpPONMcOttQfr6zwAAOBYszZWTQ8f2CZVibFszwUAgK9AuoL9nCpL8QPW2sustb+w1o6V9ISkzpL+VM/nAQAAPmb6bM81hunhAAB8T0AUbGNMO0njJGVJeva4lx+VVCDpJmNMfH2cBwAAHKuswq05mdne4zHsfw0AwPcERMGWNNbzON1a6/Z9wVqbL2mepDhJQ+rpPAAAwMeSrEM6UlIuSWrRsIHapyc4nAgAgMATKAW7s+dx40lez/Q8dqqn88gYs/REX5K6nO6zAACEmplszwUAwGkFSsFO9jzmneT1o+Mp9XQeAADgw3f/69GdmR4OAMCJBMwq4qdx9Nfktr7OY63tf8ITVF7F7lfLHAAABI2dhwq1cd8RSVJ0ZISGtmd7LgAATiRQrmAfvbKcfJLXk457X12fBwAAePiuHj6kXZriooPl9/MAANSvQCnYGzyPJ7s3uqPn8WT3Vvv7PAAAwOPY+6+ZHg4AwMkESsGe4XkcZ4w5JpMxJlHScElFkr6tp/MAAABJxWUVmrfpoPeY/a8BADi5gCjY1trNkqZLaiPp3uNe/p2keEmvWmsLJMkYE2WM6WKMaV+b8wAAgFNbtDVHRWUVkqS2jeLVplG8w4kAAAhcgXQT1T2S5kt6yhhztqTvJA2WNEaVU7p/7fPe5p7Xt6myTJ/peQAAwCn43n/N6uEAAJxaQFzBlrxXnwdImqzKQvwTSe0lPSVpqLX24Mk/7f/zAACA7+9/DQAATi6QrmDLWrtD0i3VeF+WqrbcOuPzAACAk9t2sEBbsivvqmoQ5dKgtqkOJwIAILAFzBVsAAAQWGZnZnufD22fptgol4NpAAAIfBRsAABwQvN8CvZZHRo5mAQAgOBAwQYAAN9T4baav7mqYI/oSMEGAOB0KNgAAOB7Vu3M1eHicklS46QYdchIcDgRAACBj4INAAC+Z+4x08PTZcxJ1xYFAAAeFGwAAPA9czYxPRwAgJqiYAMAgGMUlJRr+fZD3uNhHdIcTAMAQPCgYAMAgGMs3HpQZRVWktSlSaIyEmMdTgQAQHCgYAMAgGPMzTzofc72XAAAVB8FGwAAHGPupgPe52dx/zUAANVGwQYAAF77Dhdr474jkqRoV4QGt+X+awAAqouCDQAAvHy35+rfuqEaRLscTAMAQHChYAMAAK+5PttzMT0cAICaoWADAABJkrX22ILNAmcAANQIBRsAAEiSNu47ogP5JZKk5AZR6tE82eFEAAAEFwo2AACQJM3JrFo9fHiHNLkijINpAAAIPhRsAAAg6bj7rzukO5gEAIDgRMEGAAAqKa/Qwi053uMRLHAGAECNUbABAICWbctVUVmFJKl1WpxapsY5nAgAgOBDwQYAAJq7yff+a65eAwBwJijYAABAczcd9D4fQcEGAOCMULABAAhzeYVlWr0zV5IUYaRh7SnYAACcCQo2AABhbv7mbLlt5fOeLVKUHBflbCAAAIIUBRsAgDA3x2d7LqaHAwBw5ijYAACEubmZPvtfsz0XAABnjIINAEAY236wUNtzCiVJDaJc6tsqxdlAAAAEMQo2AABhbK7P9PDB7VIVE+lyMA0AAMGNgg0AQBjz3f/6LO6/BgCgVijYAACEqQq31Tzf/a87pjuYBgCA4EfBBgAgTK3Zlae8ojJJUkZijDo1TnA4EQAAwY2CDQBAmPK9//qsDo1kjHEwDQAAwY+CDQBAmJqT6XP/NdtzAQBQaxRsAADCUGFpuZZuO+Q9Hs4CZwAA1BoFGwCAMLRoa47KKqwkqVPjBDVOinU4EQAAwY+CDQBAGJqb6Xv/NauHAwDgDxRsAADCkO8CZyO4/xoAAL+gYAMAEGb25xdr/d58SVKUy2hwu1SHEwEAEBoo2AAAhJl5Plev+7VqqLjoSAfTAAAQOijYAACEmTmZx+5/DQAA/IOCDQBAGLHWHnMFm/2vAQDwHwo2AABhZNP+I9p3uESSlBQbqV4tUpwNBABACKFgAwAQRnynhw9r30iuCONgGgAAQgsFGwCAMDKX6eEAANQZCjYAAGGitNytb7cc9B6z/zUAAP5FwQYAIEws335IhaUVkqQWDRuoVWqcw4kAAAgtFGwAAMKE7+rhIzo2kjHcfw0AgD9RsAEACBNzfO+/7pDuYBIAAEITBRsAgDCQV1SmlTtyJUnGSMPapzkbCACAEETBBgAgDCzYnC23rXzes3myGsZHOxsIAIAQRMEGACAMzNp47P3XAADA/yjYAACEOGutZm884D0e2ZH7rwEAqAsUbAAAQtyW7ALtyi2SJCXERKpf64YOJwIAIDRRsAEACHG+V6+Htk9TlIt//gEAqAv8CwsAQIg7Znp4J6aHAwBQVyjYAACEsOKyCi3YctB7PIr7rwEAqDMUbAAAQtiSrEMqLnNLkto2ilertDiHEwEAELoo2AAAhLDZmb6rh7M9FwAAdYmCDQBACOP+awAA6g8FGwCAELXvcLHW782XJEW5jIa0S3M4EQAAoY2CDQBAiPK9ej2gdariYyIdTAMAQOijYAMAEKJmZ2Z7nzM9HACAukfBBgAgBFW4reb4LnDWiQXOAACoawFTsI0xw4wxnxljcowxhcaYVcaYh4wxrhqco40xxp7ia2pd/hkAAAgUq3flKbewTJKUnhijbk2THE4EAEDoC4ibsYwxl0p6T1KxpLcl5Ui6WNITkoZL+mENT7lS0ocnGF9z5ikBAAgevvdfj+jYSMYYB9MAABAeHC/YxpgkSf+RVCFptLV2iWf8N5K+kXSVMeZaa21Nrj6vsNY+5vewAAAECd+CPYr7rwEAqBeBMEX8KknpkqYeLdeSZK0tlvSI5/BuJ4IBABCMDheXafmOXEmSMdJZHbj/GgCA+uD4FWxJYz2Pn5/gtdmSCiUNM8bEWGtLqnnOZsaYOyWlSTooaYG1dlXtowIAEPjmb8pWhdtKkno0S1ZaQozDiQAACA+BULA7ex43Hv+CtbbcGLNVUndJ7SR9V81znuv58jLGzJQ0wVq7/cyjAgAQ+GZt9N2ei6vXAADUl0Ao2Mmex7yTvH50PKUa5yqU9AdVLnC2xTPWS9JjksZI+toY08daW3C6Exljlp7kpS7VyAEAgCOstcfcfz2yI/dfAwBQX/xyD7YxJus022Md//V6TU7vebSne6O1dr+19rfW2mXW2lzP12xJ4yQtlNRB0u01/xMCABAcNh8o0K7cIklSQkyk+rVu6HAiAADCh7+uYG9W5RZb1bXb5/nRK9TJJ3qjpKTj3ldjnqnmL0kaLGmkpH9V4zP9TzTuubLd70yzAABQl3yvXg9rn6YoVyCsZwoAQHjwS8G21p5di49vkDRAUidJx0zLNsZESmorqVxVU77P1NGfOOJreR4AAALW7Eyf6eFszwUAQL0KhF9rf+N5PP8Er42UFCdpfg1WED+ZIZ7H2hZ1AAACUnFZhb7dctB7zP7XAADUr0Ao2O9KypZ0rTFmwNFBY0yspD96Dp/3/YAxJtkY08UY0/S48cHGmOjjv4ExZqykH3kOa3L/NwAAQWNJ1iEVl7klSW0bxatlapzDiQAACC+OryJurT1sjLlDlUV7pjFmqqQcSZeocguvdyW9fdzHLpf0iqQpkm72Gf+rpO6eLbl2esZ6qWqv7d9Ya+fXwR8DAADHHTM9vCPbcwEAUN8cL9iSZK390BgzStKvJV0pKVbSJkk/lvSUtfa0K4h7vKbK8j1Q0g8kRUnaJ+kdSc9Ya+f4O3ug+ddXmdp04IhuO6ut+rRMcToOAKAezdrA/dcAADgpIAq2JFlr50m6oJrvnSxp8gnGX5b0sl+DBZHisgpNWZClnIJSfbxyt/q1StGtZ7XV+d2bKJJVZAEgpO3NK9aGffmSpGhXhIa0S3M4EQAA4SdgCjZqb05mtnIKSr3Hy7bnatmby9UsOVYThrXRtQNbKTkuysGEAIC64js9fECbhoqP4Z94AADqG5c1Q8i53Rrrk/vP0pX9WijKZbzju/OK9edp6zX0L1/rtx+t0ZYDRxxMCQCoC777XzM9HAAAZ1CwQ0yP5sn6x9W9Ne8XY/XA2R2VFl+1qHphaYVeXbBNY/8xS7dNXqx5m7JV/dvbAQCBqsJtNXdTtvd4ZEcKNgAATmD+WIjKSIzVj8/tpHtGt9f/VuzWpHlbtX5vvvf1r9fv19fr96tLk0TdOrytLunTTLFRLgcTAwDO1OpdecotLJMkpSfGqGvTRIcTAQAQnriCHeJio1y6emBLTXtwhN68fbDO7pJxzOvr9+brZ++t0vC/fKMnv9qoPM8PaACA4OE7PXxEx0Yyxpzi3QAAoK5wBTtMGGM0rEMjDevQSFsOHNHk+Vn675KdKiqrkCQdLCjVk19l6qU5W3XjkNa67ay2Sk+McTg1AKA6ZvkU7FHcfw0AgGO4gh2G2qUn6PeX9tC3vzxbv/xBFzVLjvW+dqSkXC/M2qyz/vqNHvvfWu3OLXIwKQDgdPKKyrRiR64kyRjprA6NnA0EAEAYo2CHseS4KN05qr1m/2yMnrymjzpmJHhfKyl3a/L8LI362wz9/N1VysoucDApAOBk5m/KVoW7csHKns2TlZbA7CMAAJxCwYYiXRG6rG9zffHQSL1wYz/1aJ7kfa2swurtJTs09h8z9eDU5drgs1AaAMB5vvtfs3o4AADO4h5seEVEGJ3fo6nO695EszYe0LMzNmlx1iFJkttKH63YrY9W7Na4bo1139gO6tUixdnAABDmrLWavdFney7uvwYAwFEUbHyPMUajO2dodOcMLdxyUM/M2KQ5mVU/wE1ft0/T1+3TiI6N9ODZHTWgTaqDaQEgfG0+UKBdnrUyEmIi1bdVirOBAAAIcxRsnNLgdmka3C5NK3fk6pkZm/Tlun3e1+ZkZmtOZrZGd07Xw+M6q0fzZAeTAkD48d2ea1j7NEW5uPMLAAAn8S8xqqV3yxT9Z/wAff7QCF3Su5kifLZYnbnhgC56eq7ufWOZNu0/4lxIAAgzvttzMT0cAADnUbBRI12aJOmp6/rq65+M1hV9m8v4FO1PV+/RuCdm6eH/rtSOnELnQgJAGCguq9DCrQe9x+x/DQCA8yjYOCNtG8Xrn9f00RcPjdT53Zt4x91WenfpTo39x0w9+tEa7c8vdjAlAISuxVk5Ki5zS5LaNYpXy9Q4hxMBAAAKNmqlU+NEvXBTf31073CN6NjIO15WYTVlwTaNfHyG/jJtvXILSx1MCQChZzbTwwEACDgUbPhF75Ypeu22wZo6cYgGtG7oHS8uc+uFWZs14q8z9PTXmTpSUu5gSgAIHcduz9XoFO8EAAD1hYINvxrSLk3/vWuoXrl5oLo1TfKO55eU6x9fbtTIx2do0tytKi13O5gSAILb3rxibdiXL0mKdkVoSLs0hxMBAACJgo06YIzRmC4Z+uT+s/Ts9f3ULj3e+1pOQal+/8k6nf/kbH2zfp+stQ4mBYDgNGvjfu/zAW0aKi6aXTcBAAgEFGzUmYgIowt7NdX0h0bq8at6qXlKA+9rW7ILdOvkJRo/aZE2eq7CAACqZ/rafd7nYzpnOJgEAAD4omCjzkW6InT1gJb65uFReuTCrkqMrbrSMiczWz/41xz95sM1yilgITQAOJ2CknLN2VR1//W47o0dTAMAAHxRsFFvYiJdun1EO818eLRuGNxKEZ49tCvcVq99u02j/1Z5f3ZZBfdnA8DJzMk84F3HonPjRLVOiz/NJwAAQH2hYKPepSXE6E+X99RnD47Q8A5VC/McLi7X7z9Zp/O4PxsATsp3ejhXrwEACCwUbDimS5MkvX7bYP1n/AC1SYvzjm85UHV/dib3ZwOAV3mFW1+vr1rg7NxuFGwAAAIJBRuOMsbo3G6N9cWPRurXF3RVYsyx92ef/685evSjNTrE/dkAoEVZOcorKpMkNUmKVc/myQ4nAgAAvijYCAgxkS7dMbKdZvx0tK4/7v7sKQu2afTfZ+qdJTuYNg4grB0/PdwY42AaAABwPAo2AkqjhBj93+U99ekDIzS0XdX92XlFZfrZu6t0/X8Wamt2gYMJAcAZ1lp9uc6nYHdr4mAaAABwIhRsBKSuTZP05h2D9e+b+qtFw6r9sxdsOajznpytZ2ds8q6iCwDhYN2ew9qVWyRJSoyN1OB2qQ4nAgAAx6NgI2AZYzSuexNN/9FITRzZzjttvLTcrb99sUEXPz1Xy7YfcjYkANQT3+nhY7tkKMrFP+EAAAQa/nVGwIuLjtSvLuiq/913lno0T/KOb9iXryufn69HP1qj/OIyBxMCQN2bzvRwAAACHgUbQaNH82R9eM9wPXJhVzWIckmSrJWmLNimc/85W9PX7nU4IQDUjR05hfpuz2FJUrQrQqM6pzucCAAAnAgFG0El0hWh20e00/QfjdSoTlU/YO49XKyJry3V3a8v1b7DxQ4mBAD/813cbFiHNCX4bGkIAAACBwUbQallapwm3zJQ/7q2j9Lio73j09bs1Tn/mKXXv90mt5stvQCEhunrqmboMD0cAIDARcFG0DLG6NI+zfX1T0bp6gEtvOP5JeV65MM1uvrFBWzpBSDoHSoo1aKtOd7jc7pmOJgGAACcCgUbQS8lLlqPX9Vbb94xWG3S4rzjS7Yd0gX/mqNXF2RxNRtA0Ppm/X4d/Susb6sUZSTFOhsIAACcFAUbIWNY+0b6/KGRum9MB0V69vQqKqvQbz9aqwmvLNKevCKHEwJAzTE9HACA4EHBRkiJjXLp4fM668N7h6tT4wTv+JzMbI17YrbeX7ZT1nI1G0BwKC6r0OyN2d7jc7s1djANAAA4HQo2QlKP5sn6331n6c6R7WQqL2Yrv7hcP35npe5+fZkOHilxNiAAVMPczGwVlVVIktqlx6tDRsJpPgEAAJxEwUbIio1y6ZcXdNXbE4eqZWoD7/jna/fqvCfZNxtA4GN6OAAAwYWCjZA3qG2qpj04UtcNauUdyz5SqomvLdXD/12pw8VlDqYDgBOrcFt99d1+7/G47kwPBwAg0FGwERYSYiL15yt66pVbBiojMcY7/u7SnfrBk3M0f1P2KT4NAPVv6bZDyikolSSlJ8aoT4sUZwMBAIDTomAjrIzpnKHpPxqpS3o3847tyi3S9S8t1GP/W6ui0goH0wFAlS99poef07WxIjy7IwAAgMBFwUbYSYmL1lPX9dUz1/dVSlyUd3zy/Cxd+NQcrdmV52A6AJCstZq+bp/3mOnhAAAEBwo2wtZFvZpp+kMjNaZzundsS3aBrnhuvl77dhvbeQFwzMZ9R7TtYKEkKT7apWHt0xxOBAAAqoOCjbCWkRSrSTcP1F+u6Kn4aJckqbTCrd98uEb3vbmcBdAAOMJ3evjozhmKiXQ5mAYAAFQXBRthzxijawe10sf3n6WuTZO845+u3qOLn56r1TuZMg6gfjE9HACA4ETBBjzapSfog3uG6YbBVdt5bTtYqCufn68p87OYMg6gXuzOLdIqzy/2IiOMRnfOcDgRAACoLgo24CM2yqU/Xd5TT1/XVwkxkZIqp4w/+r+1uueNZUwZB1Dnvvqu6ur1kHZpSm4QdYp3AwCAQELBBk7g4t7N9PH9Z6l7s6op49PW7NVFT83Vqp25zgUDEPK+ZHo4AABBi4INnETbRvF67+5humlIa+/Y9pzKKeOvzNvKlHEAfpdXVKYFmw96j8/pSsEGACCYULCBU4iNcukPl/XQs9f3804ZL6uw+t3H63TX60uVV8SUcQD+M3PDfpW7K39517N5spqlNHA4EQAAqAkKNlANF/Zqqk8fOEs9mldNGf9i7T5d+NQcrdiR61wwACHlmNXDu3H1GgCAYEPBBqqpdVrllPGbh7Xxju08VKQfvjBfr3+7zblgAEJCSXmFZq7f7z0e172Jg2kAAMCZoGADNRAT6dJjl3TX8zf0U2Js1ZTxRz5co19/sFql5W6HEwIIVvM3H1RBaYUkqVVqnDo1TnA4EQAAqCkKNnAGftCzqT69f8QxU8bfWLhdN768UAePlDiYDECwmr722OnhxhgH0wAAgDNBwQbOUKu0OP33zmG6uHcz79iirTm65Jl5Wrs7z8FkAIKN222P2f+a6eEAAAQnCjZQCw2iXXrq2j762fmddfRi067cIl31/AJ9umqPs+EABI0VO3N1IL9y9ktqfLT6t27ocCIAAHAmKNhALRljdM/oDnp5wgAlerbyKiqr0L1vLtM/pm+Q281+2QBOzXd6+NldMuSKYHo4AADBiIIN+MnYLo31wb3D1CYtzjv29DebNPG1pcovZr9sACf35bq93udMDwcAIHhRsAE/6pCRqI/uPUsjOjbyjn313T5d8dx8bTtY4GAyAIFq0/4j2nyg8u+H2KgIndWh0Wk+AQAAAhUFG/Cz5LgovXLzQN0xoq13LHP/EV3yzDzNzcx2MBmAQDTd5+r1yI7pahDtcjANAACoDQo2UAciXRH69YXd9I8f9lZ0ZOV/ZnlFZZrwyiJNmrtV1nJfNoBKn62uWhDxPKaHAwAQ1CjYQB26sn8LvT1xiDISYyRJFW6r33+yTj97d5VKyiscTgfAadsOFmjNrsOSpCiX0TndGjucCAAA1IbjBdsYE2WMedAY84oxZoUxptQYY40xt9finMOMMZ8ZY3KMMYXGmFXGmIeMMcy7Q73r26qhPr7/LPVumeId++/SnRr/8iLlFbH4GRDOPvW5ej2yY7qSG0Q5mAYAANSW4wVbUrykJyXdLKmJpL2nevPpGGMulTRb0khJH0h6VlK0pCckTa3NuYEz1TgpVm9PHKIr+jX3ji3cmqMfvjBfe/KKHEwGwEm+08Mv6NnUwSQAAMAfAqFgF0q6QFIza20TSZPO9ETGmCRJ/5FUIWm0tfY2a+1PJfWRtEDSVcaYa2sfGai52CiX/vHD3vr5+V28Yxv3HdEVz83Xhr35DiYD4ASmhwMAEHocL9jW2lJr7TRr7Z7Tv/u0rpKULmmqtXaJz/colvSI5/BuP3wf4IwYY3T36PZ64preiowwkqQ9ecW66oX5+nbLQYfTAahPvtPDRzA9HACAkOB4wfazsZ7Hz0/w2mxVXi0fZoyJqb9IwPdd3reFXrlloOI92/HkF5dr/MuL9Mmq3Q4nA1BffKeHX8j0cAAAQkKoFezOnseNx79grS2XtFVSpKR2pzuRMWbpib4kdTndZ4HqGNExXW/fOVTpnhXGSyvcuv+t5Xp57laHkwGoa9sPFjI9HACAEBRqBTvZ85h3ktePjqfUfRTg9Ho0T9b7dw9Tu/R4SZK10h8+Wac/fbpObjd7ZQOhiunhAACEJr8UbGNMlmdrrep+ve6P73smUT2Pp20u1tr+J/qStL5uIyLctEyN03t3DVO/Vinesf/M2aoH317BXtlAiGJ6OAAAoSnST+fZLKm4Bu+vqxtNj16hTj7J60nHvQ8ICA3jo/XmHUP0wFvLNX3dPknSxyt3Kzu/RC+O76+kWK5uAaFi+8FCrd5V+c8Q08MBAAgtfrmCba0921rbpQZfP/PH9z2BDZ7HTse/YIyJlNRWUrmkLXX0/YEzFhvl0vM39teNQ1p5xxZsOairX1igvXk1+f0VgEDG9HAAAEJXqN2D/Y3n8fwTvDZSUpyk+dbakvqLBFSfK8LoD5f20E/P6+wdW783X1c8N0+Z+9grGwgFvtPDL2B6OAAAISUoC7YxJtkY08UYc/xPJu9KypZ0rTFmgM/7YyX90XP4fD3FBM6IMUb3jumgv/+waq/s3XnFuvL5+VqSleNwOgC1cfz08HOZHg4AQEgJiIJtjPmFMWayMWaypMs8w7ccHTPG3H7cRy6X9J2kP/sOWmsPS7pDkkvSTGPMS8aYxyWtkDRUlQX87Tr7gwB+dFX/Fnr55oGK8+yVfbi4XOMnLdKirZRsIFgxPRwAgNAWEAVblVO6J3i+envGhvmMnVXdE1lrP5Q0StJsSVdKul9SmaQfS7rWWsveRwgaozql6507h6pRQrQkqbC0Qje/skjfbjnocDIAZ4Lp4QAAhLaAKNjW2tHWWnOKr5uPe//kE437vD7PWnuBtbahtbaBtbantfYJay17HiHo9GierKkThyo9MUZSZcm+5ZXFWrCZkg0EE6aHAwAQ+gKiYAM4tQ4ZCZo6cYgyPCW7qKxCt0xepPmbsh1OBqC6PlvD9HAAAEIdBRsIEu3TK0t246TKkl1c5tYtkxdrbiYlGwgGTA8HACD0UbCBINIuPUFTJw5Vk6RYSVJJuVu3TVmsOZkHHE4G4FS2HyzUqp1MDwcAINRRsIEg07ZRvKZOHKKmyb4le4lmbaRkA4HKd3r4WR0aMT0cAIAQRcEGglAbT8lu5inZpeVu3fHqEs3csN/hZABOxHd6+IW9mjmYBAAA1CUKNhCkWqfFa+rEoWqe0kBSZcme+OpSzVhPyQYCyY4cpocDABAuKNhAEGuVFqepE4dUlewKt+58bam+Wb/P4WQAjvp0NdPDAQAIFxRsIMi1TI3T23cOUYuGx5bsr9ZRsoFAwOrhAACEDwo2EAJaNIzT23cOVcvUypJdVmF19xtL9SUlG3DU8dPDx3Vr4nAiAABQlyjYQIhontJAb08cqlapcZIqS/Y9byzV9LV7HU4GhK/Pjp8eHsf0cAAAQhkFGwghzVIa6O07h6h1WlXJvvfNZZrB6uKAI5geDgBAeKFgAyGmaXLllew2PiX7rteWav6mbIeTAeFlR06hVjI9HACAsELBBkJQk+RYvXlH1cJnJeVu3TZliRZn5TicDAgfTA8HACD8ULCBENUspYHeumOImiTFSpKKyip0yyuLtXJHrrPBgDDB9HAAAMIPBRsIYS1T4/TmHYPVKCFGknSkpFzjJy3Sut2HHU4GhDamhwMAEJ4o2ECIa5eeoDduH6yGnumpeUVluvHlhcrcl+9wMiB0MT0cAIDwRMEGwkDnJol67bbBSoyNlCTlFJTq+pcWamt2gcPJgNDE9HAAAMITBRsIEz2aJ2vKrYMUH+2SJB3IL9EN//lWO3IKHU4GhBamhwMAEL4o2EAY6deqoSbdPFCxUZX/6e/OK9YNLy3U3rxih5MBoWPamqqr18OZHg4AQFihYANhZnC7NP1n/ABFR1b+5789p1DXv/StDuSXOJwMCA2frt7rfX4h08MBAAgrFGwgDI3omK7nb+inyAgjSdpyoEA3vrRQOQWlDicDgtuOnELvVnhMDwcAIPxQsIEwdXbXxnr6ur5yeUr2hn35Gj9pofKKyhxOBgQv38XNmB4OAED4oWADYewHPZvqHz/sLVPZsbVm12Hd/MoiHSkpdzYYEISstXp78Q7vMdPDAQAIPxRsIMxd1re5/nJFT+/x8u25um3yYhWXVTiYCgg+C7fmaItn67vEmEhd2IuCDQBAuKFgA9A1A1vp95d29x4v3Jqje95YptJyt4OpgODy5sLt3ueX9W2uuOhIB9MAAAAnULABSJLGD22jX/6gi/f4m/X79eN3VqjCbR1MBQSHnIJSfb6mavXw6wa1cjANAABwCgUbgNedo9rr3jHtvcefrNqjRz5cI2sp2cCpvLd0p0orKmd89G6Zom7NkhxOBAAAnEDBBnCMh8d11vihrb3Hby3arr9MW0/JBk7CWqu3FlVND7+Bq9cAAIQtCjaAYxhj9NjF3XV53+besRdnb9FzMzc7mAoIXMcvbnZRbxY3AwAgXFGwAXxPRITR367qpXO7NfaO/e2LDXp1QZZzoYAAxeJmAADgKAo2gBOKdEXo6ev6aniHNO/Ybz9aq/eX7XQwFRBYWNwMAAD4omADOKnYKJf+fdMA9WmZ4h376bur9MXavSf/EBBGWNwMAAD4omADOKX4mEhNvmWgujRJlCRVuK3uf3O55mZmO5wMcBaLmwEAgONRsAGcVkpctF69bZDapMVJkkor3Jr42hIt3XbI4WSAc1jcDAAAHI+CDaBaMhJj9frtg9U0OVaSVFhaoVteWaTv9hx2OBngDBY3AwAAx6NgA6i2Fg3j9Nptg5UWHy1JOlxcrpteXqStnqt4QLhgcTMAAHAiFGwANdIhI0FTbh2kxJjKq3XZR0p040sLtTu3yOFkQP1hcTMAAHAiFGwANdajebIm3TJQsVGVf4Xsyi3SjS8vVE5BqcPJgLrH4mYAAOBkKNgAzsjANql68aYBinIZSdKWAwW6bcpiFZVWOJwMqFvfbmFxMwAAcGIUbABnbFSndD15TV+Zyo6t5dtzdd+by1TumToLhCLfq9csbgYAAHxRsAHUyoW9murRi7p5j79ev1+PfLhG1loHUwF1g8XNAADAqVCwAdTazcPb6q5R7b3HUxfv0BNfZTqYCKgbLG4GAABOhYINwC9+fn5nXdGvuff4qa8z9cbCbQ4mAvyLxc0AAMDpULAB+IUxRn+9spdGdkr3jv3mwzX6Yu3eU3wKCB6+i5slsLgZAAA4AQo2AL+JckXo+Rv6qVeLZEmS20oPvLVcS7JyHE4G1N6xi5s1Y3EzAADwPRRsAH4VHxOpSTcPVOu0OElSSblbt01Zosx9+Q4nA87c8YubXT+otYNpAABAoKJgA/C7RgkxevXWQWqUEC1Jyisq04RJi7Q3r9jhZMCZYXEzAABQHRRsAHWidVq8Jt08UHHRLknS7rxiTZi0SHlFZQ4nA2qGxc0AAEB1UbAB1JleLVL0/I39FRlhJEkb9uVr4qtLVFxW4XAyoPpY3AwAAFQXBRtAnRrVKV2PX9XLe7xwa45+/M4KVbitg6mA6mNxMwAAUF0UbAB17op+LfSLH3TxHn+2eq9+//FaWUvJRmBjcTMAAFATFGwA9eLOke1087A23uMpC7bp+VmbnQsEVAOLmwEAgJqgYAOoF8YY/faibrqwV9X9q49/vkHvLt3pYCrg5FjcDAAA1BQFG0C9iYgw+ufVvTWkXap37OfvrdLMDfsdTAWcGIubAQCAmqJgA6hXMZEu/Xv8AHVpkihJqnBb3fPGMq3cketsMOA4U+ZneZ+zuBkAAKgOCjaAepcUG6Uptw5S85QGkqTC0grdOnmxsjxXCwGnbdibr8/XVi1uduMQFjcDAACnR8EG4IjGSbGacutApcRFSZIOFpRq/KRFOpBf4nAyQHpmxibv83O6NlaXJixuBgAATo+CDcAxHTIS9fKEAYqJrPyraHtOoW6dvFhHSsodToZwtvnAEX2yarf3+IGzOziYBgAABBMKNgBH9W+dqmeu76cIU3m8elee7n59qUrL3c4GQ9h6dsYmHd2ifXTndPVqkeJoHgAAEDwo2AAcd263xvrjZT29x3Mys/WL91bJHm05QD3ZdrBAH62ounp9/9iODqYBAADBhoINICBcP7iVHjy7qsy8v3yX/vr5BgcTIRw9N2OzKtyVv9gZ3iFN/Vs3dDgRAAAIJhRsAAHjoXM66rpBLb3HL8zarFfmbXUwEcLJzkOFem/ZTu8xV68BAEBNOV6wjTFRxpgHjTGvGGNWGGNKjTHWGHP7GZyrjeezJ/uaWhd/BgD+YYzRHy7toXO6NvaO/f6TdccsOAXUlRdmbVa55+r1oDapGtIuzeFEAAAg2EQ6HUBSvKQnPc/3SdorqeVJ3109KyV9eILxNbU8L4A6FumK0NPX9dUNL32rZdtzZa3047dXKi0+RkPbU3hQN/bmFeudxT5Xr1k5HAAAnAHHr2BLKpR0gaRm1tomkib54ZwrrLWPneDrXT+cG0AdaxDt0ssTBqpderwkqbTCrYmvLtF3ew47nAyh6sXZm1VaUblyfZ+WKTqrQyOHEwEAgGDkeMG21pZaa6dZa/c4nQVA4GgYH61Xbx2kjMQYSVJ+SblufmWRduUWOZwMoeZAfoneXLjde/zA2R1kjHEwEQAACFaOF+w60swYc6cx5leex15OBwJQcy0axmnyLYOUGFN5N8u+wyUa//JCHSoodTgZQslLc7aoxLPveo/mSRrTOcPhRAAAIFiFasE+V9ILkv7keVxpjJlhjGlV3RMYY5ae6EtSlzrKDOAEujVL0ovj+yvaVfnX1eYDBbp58mIVlJQ7nAyhIKegVK99u817fN+Yjly9BgAAZyzUCnahpD9I6i+poedrlKQZkkZL+toYE+9YOgBnZFj7RvrnNb11tPes3JGru15fqpLyCmeDIehNmrtVhaWV/z/q3DhR47o1Ps0nAAAATs4vBdsYk3Wa7bGO/3rdH9/3eNba/dba31prl1lrcz1fsyWNk7RQUgdJ1dr+y1rb/0RfktbXRXYAp3ZRr2b6/aU9vMdzMrP147dXqsKzrRJQU3lFZZoyP8t7fN/YDoqI4Oo1AAA4c/7apmuzpOIavL9eN7W11pYbY16SNFjSSEn/qs/vD8A/bhrSWrkFpfrHlxslSZ+u3qPkuCj96bIeTOtFjU2el6V8z60G7dLjdUHPpg4nAgAAwc4vBdtae7Y/zlPHDngemSIOBLH7xnZQTmGpXpmXJUl6c+F2pcZF6+HzOjsbDEElv7hMk+Zt9R7fP7aDXFy9BgAAtRRq92CfyhDP4xZHUwCoFWOMfnNhN13et7l37JkZm/Ty3K2n+BRwrNe+3aa8ojJJUuu0OF3cq5nDiQAAQCgIyoJtjEk2xnQxxjQ9bnywMSb6BO8fK+lHnsM6uf8bQP2JiDB6/KpeGtulajulP3yyTu8v2+lgKgSLwtJyvTSn6hcy947uoEhXUP5zCAAAAoy/7sGuFWPML1S1/VUfz+MtxpizPM/nWmtf8vnI5ZJekTRF0s0+43+V1N0YM1PS0Z+0e0ka63n+G2vtfL+GB+CIKFeEnr2+n256eaGWbDskSfrpu6uUFBulc1gJGqfwxrfblePZS715SgNd3q/5aT4BAABQPYHyK/vzJU3wfPX2jA3zGTvrJJ873muqXC18oKQ7JN0jqaOkdySNtNb+0Y+ZATisQbRLL988UF2aJEqSKtxW9765TIu25jicDIGquKxCL86uulPo7tHtFcXVawAA4CcB8VOFtXa0tdac4uvm494/+STjL1trL7LWtrHWJlhrY6y1ray111hr59TnnwlA/UhuEKVXbx2kVqlxkqSScrdum7xYa3fnOZwMgWjqou3KPlIiSWqSFKsfDmjhcCIAABBKAqJgA0BtZCTF6vXbBis9MUaSlF9SrgmTFisru8DhZAgkJeUVemFW1dXrO0e1U0yky8FEAAAg1FCwAYSEVmlxevXWQUqMrVxaIvtIiW58eaH2HS52OBkCxbtLd2qv5/8PjRJidN2gVg4nAgAAoYaCDSBkdG2apEk3D1RsVOVfbTsPFWn8y4uUV1jmcDI4razCrednbvYeTxzZVrFRXL0GAAD+RcEGEFIGtknV8zf0V2SEkSRt2JevW6csVmFpucPJ4KQPlu/SzkNFkqSGcVG6YXBrhxMBAIBQRMEGEHLGdMnQ33/Y23u8dNsh3fHqEhWXVTiYCk7JKyzT459v8B7fPqKd4mMCYpdKAAAQYijYAELSZX2b69GLu3mP5206qHveWKbScreDqeCEP366zrtyeHpijMYP5eo1AACoGxRsACHrluFt9dPzOnuPv1m/Xw9OXa7yCkp2uJiTeUD/XbrTe/zHy3ooMTbKwUQAACCUUbABhLR7x3TQfWM6eI+nrdmrh/+7UhVu62Aq1IeCknL98v3V3uMLezbVed2bOJgIAACEOgo2gJD3k3GddNtZbb3HH67YrV9/sFrWUrJD2d+nb/AubJYSF6XHLunucCIAABDqKNgAQp4xRo9c2FU3DK7a93jq4h363cfrKNkhaum2HE2en+U9/u1F3ZSeGONcIAAAEBYo2ADCgjFGf7i0h67o19w7Nnl+lv76+QZKdogpLqvQz95dpaP/s47qlK7L+zY/9YcAAAD8gIINIGxERBg9fmUvXdirqXfshVmb9fQ3mxxMBX97dsYmbT5QIEmKj3bpT5f3kDHG4VQAACAcULABhJVIV4SevKaPzuna2Dv2zy836t+zNzuYCv6ybvdhPT+z6n/Ln/+gi1o0jHMwEQAACCcUbABhJ8oVoWeu76sRHRt5x/7vs/V6bUGWc6FQa+UVbv38vVUq96wQP7BNQ904mD2vAQBA/aFgAwhLsVEu/fumARrUNtU79puP1uqdJTscTIXaeGnuVq3elSdJio6M0F+u7KWICKaGAwCA+kPBBhC2GkS7NOnmgerTMsU79vP3VumjFbucC4UzsuXAET3x5Ubv8UPndFT79AQHEwEAgHBEwQYQ1hJiIjXl1kHq3ixJkmSt9ON3VurzNXsdTobqcrutfvH+apWUuyVJ3Zsl6Y4R7RxOBQAAwhEFG0DYS24QpdduG6yOGZVXPCvcVve/tUxff7fP4WSojjcXbdeirTmSJFeE0V+v7KUoF/+8AQCA+sdPIAAgKTU+Wm/cPlhtG8VLksoqrO56fammr+VKdiDbnVukv0xb7z2+a1Q79Wie7GAiAAAQzijYAOCRkRSrN24frFaplds6lVVY3fPGMqaLByhrrR75cI2OlJRLktqlx+v+sR0dTgUAAMIZBRsAfDRLaaCpE4eodVplyS53W9335jJNW73H4WQ43kcrduub9fslScZIj1/ZS7FRLodTAQCAcEbBBoDjNEtpoLcnDvVOFy93W9331nJ9uoqSHSiyj5Todx+v9R6PH9JaA9qknuITAAAAdY+CDQAn0CQ5VlMnDlG79MqSXeG2emDqcn28crfDySBJv/t4nQ4VlkmSmqc00E/P7+JwIgAAAAo2AJxU46RYTb1jiNr7lOwHpy5nn2yHfblu3zG/6Pi/K3oqISbSwUQAAACVKNgAcAoZSbGaOnGodwsvt5V+9PYKfbB8p8PJwtO63Yf147dXeI+v7NdCozqlOxcIAADABwUbAE4jPTFGb00cok6Nq0r2j99ZqXeXUrLr046cQk14ZZHyPauGN06K0W8u6upwKgAAgCoUbACohkYJMXrrjiHq0iRRkmSt9NN3V+qdxTscThYeso+UaPykRTqQXyJJSoyJ1ORbBiklLtrhZAAAAFUo2ABQTWkJMXrzjiHq2jRJUmXJ/tl7qzR10XaHk4W2IyXlunXyYm3NLpAkRUdG6KUJA7z/OwAAAAQKCjYA1EBqfLTevH2wujerKne/eH+13lxIya4LpeVu3f36Uq3amSdJijDS09f11eB2aQ4nAwAA+D4KNgDUUMP4aL1x+2D1bJ7sHfvVB6v12rfbHEwVetxuq4f/u1JzMrO9Y3+8rKfO697EwVQAAAAnR8EGgDOQEhet128brN4tqkr2bz5co2dnbJK11sFkocFaqz98uk7/89mO68fndtL1g1s5mAoAAODUKNgAcIaS46L06m2D1adlinfsb19s0E/fXaXScrdzwULA87M265V5Wd7jm4a01v1jOzgXCAAAoBoo2ABQC8kNovTqbYM01Oee4HeX7tT4SQuVW1jqYLLg9c6SHXr88w3e4wt6NtFjl3SXMcbBVAAAAKdHwQaAWkqKjdKUWwfph/1beMe+3ZKjK56bryzPyteonq/W7dMv31/tPR7aLk1PXNNHrgjKNQAACHwUbADwg+jICD1+VS/99LzO3rEt2QW6/Ll5WpyV42Cy4LEkK0f3vrlMFe7Ke9i7NU3Sv8f3V0yky+FkAAAA1UPBBgA/Mcbo3jEd9Oz1/RQTWfnX66HCMt3wn4X6aMUuh9MFto378nXr5MUq8dy73io1TpNvHajE2CiHkwEAAFQfBRsA/OzCXk311sQhapQQLUkqrXDrwakr9ORXG1lh/AR25RZp/MuLdLi4XJLUKCFar946SBmJsQ4nAwAAqBkKNgDUgX6tGuqDe4arY0aCd+zJrzL143dWqqS8wsFkgeVQQanGv7xQew8XS5Lio12afMsgtWkU73AyAACAmqNgA0AdaZkap3fvHqYRHRt5xz5Yvks3vrRQOQWsML4jp1DX/edbbT5QuRBclMvo3+MHqEfz5NN8EgAAIDBRsAGgDiU3iNKkmwfqukGtvGOLsw7p8ufmacuBIw4mc9bCLQd16bPztH5vviTJGOmJa/poeIdGp/kkAABA4KJgA0Adi3JF6P8u76FfXdBFR7dy3nawUJc/N1/fbjnobDgHvLVou27wuYof7YrQ36/qrYt6NXM4GQAAQO1QsAGgHhhjNHFkez1/Q3/FRlX+1ZtXVKabXl6oJ7/aqOKy0L8vu6zCrUc/WqNfvr9a5Z6tuBolROutiYN1pc8e4gAAAMGKgg0A9ej8Hk309sShSk+MkSSVVVg9+VWmxj0xW19/t8/hdHXnUEGpJkxapCkLtnnHujdL0kf3naX+rVMdTAYAAOA/FGwAqGe9W6bow3uHq3eLqsW8tucU6rYpS3T7lMXakVPoYDr/y9yXr8uem6f5m6umw1/Ys6n+e9dQNU9p4GAyAAAA/6JgA4ADmqc00Pv3DNefLu+h5AZR3vGvvtuvc/45K2SmjX/93T5d/tx8bTtY9UuDn5zbSc9c31dx0ZEOJgMAAPA/CjYAOMQVYXTD4Naa8fBoXTuwpXe8pNztnTb+zfrgnDZurdXzMzfr9leX6EhJuSQpLtqlF27sr/vP7ihzdLU3AACAEELBBgCHpcZH6y9X9tIH9wxTz+bHThu/dfIS3T5lSVBNGy8uq9CP3l6hv36+XrZyLTM1T2mg9+4epvN7NHE2HAAAQB2iYANAgOjbqqE+vHe4/njZ8dPG9+mcf87Sv77KDPhp43vzinXNiwv04Yrd3rFBbVP1v/uGq2vTJAeTAQAA1D0KNgAEEFeE0Y1DTjxt/ImvNnqnjdujl4YDhLVW8zZl65Jn5mrlzjzv+HWDWun12wYrLSHGwXQAAAD1gxVmACAAHZ02fs3AlvrtR2u1eldlaT06bbxLk0TdMLiVLu3bXEmxUac5W92pcFt9sXavXpy9RSt35HrHXRFGv72om8YPbc391gAAIGyYQLsKEuiMMUv79evXb+nSpU5HARAmKtxWby3arr99sUF5RWXHvNYgyqVLejfTdYNbqXeL5Hors0WlFXp36Q69NHfrMSuES1Jygyg9d0M/De/QqF6yAAAA+FP//v21bNmyZdba/jX9LFewASDAHZ02/oMeTfTEVxv17tKdKi5zS5KKyir09pIdenvJDnVrmqTrB7fSpX2aKbGOrmofPFKiVxds02vfblNOQekxr0W7InRFv+a6b2wHtWgYVyffHwAAIJBxBbuGuIINwGl5RWX6cPkuvblwuzbsy//e63HRlVe1rx/cSr1apPjle2ZlF+iluVv03yU7VVLuPua15AZRunFIK00Y1kYZibF++X4AAABO4Qo2AISR5AZRmjCsjcYPba1l23P15sLt+mTVbm/xLSyt0NTFOzR18Q71aJ6k6we11iV9mikhpuZ/5S/ffkj/nr1Fn6/dq+N/H9s8pYFuO6utrhnYUvFncG4AAIBQwxXsGuIKNoBAlFdYpveX79SbC7crc/+R770e5TJKiIlUdGSEYiJdiomMUEyUz/Oj41FVzzfszdeirJzvnat7syRNHNlOF/ZsqkgXm1EAAIDQwhVsAAhzyXFRumV4W908rI2WbDukNxdu16er96jUc1W7rMLqUGHZac5yaiM7pevOke00rH0aK4MDAACcAAUbAEKI+f/27j1IsrK84/j3cZfLSrHLAmItS5JZUFissoK4JnFBWKHwkiBIiSUVE0EoSpOAqKmKqWgIUVOAchOLsCkkLhcJBgIkJgvGuFmwIAahjJIS0EVWYLlELnJbWNjdN3+870AzdM/0zJyZc07391N1qqfP5e2339/MdD99Tp8TwdtGduZtIztz6uFv4pofbuAfbr2PdV32avdj7muCI35zd048aE/2XTS/4t5KkiQNFgtsSRpQC3fYlhMOXMIJBy7h2U2b2bR5K5s2b2HTi1tf/nnz1nJ/y6uWz50TvHOf3dh9p3l1PxVJkqRWsMCWpCGww3Zz2WG7unshSZI02Dw7jSRJkiRJFbDAliRJkiSpAhbYkiRJkiRVoPYCOyLeGBGfiYg1EXF/RLwQEY9ExD9HxDun2ObyiFgdEY9HxMaI+HFEfDIi5lTdf0mSJEmSoAEFNvAF4Azg9cBq4GzgZuD3gDUR8YnJNBYRRwI3AQcB1wIXANsC5wJXVtdtSZIkSZJe1oSziN8AnJlS+mHnzIg4GPgO8OWIuCql9NBEDUXEfOAiYAuwIqV0W5n/l8Aa4OiIOCalZKEtSZIkSapU7XuwU0qrxhbXZf6NwFry3uflfTZ3NPA64MrR4rq09TzwuXL3j6bVYUmSJEmSuqi9wJ7Ai+V2c5/rH1Jub+iy7CZgI7A8IrwarCRJkiSpUo0tsCPiN4BDyUXxTX1utk+5/enYBSmlzcC95MPi96yij5IkSZIkjWrCd7Bfpexh/gawHfBnKaUn+tx0Qbl9ssfy0fk79dGH23ssWtpnXyRJkiRJQ6SSPdgRsT4i0iSmy8dpaw5wGXAA8E3grCr6ONp8uU0VtilJkiRJUmV7sO8Bnp/E+g92m1mK68uBDwL/CPxBSmkyxfDoHuoFPZbPH7NeTymlt/bo4+3A/pPokyRJkiRpCFRSYKeUDp1uGxExF7iCXFxfAXwkpbRlks3cDSwD9gZecYh3aX8J+YRpP59ufyVJkiRJ6tSIk5xFxLbA1eTi+lLgD6dQXEO+1jXAe7osOwh4LXBLSmnTlDoqSZIkSVIPtRfY5YRm1wJHAhcDH00pbZ1gmwURsTQiFo1ZdDXwKHBMRCzrWH974Ivl7oWVdV6SJEmSpKIJZxFfCfwuuTDeAJwaEWPXWZtSWttx/yjg68AlwHGjM1NKT0XEieRCe21EXAk8DhxBvoTX1eQTp0mSJEmSVKkmFNhLyu2uwKnjrLe2n8ZSStdFxMHAZ4EPANsD64BPA+dP8qRpkiRJkiT1pfYCO6W0YgrbrAJWjbP8ZvJecUmSJEmSZkXt38GWJEmSJGkQWGBLkiRJklQBC2xJkiRJkipggS1JkiRJUgUssCVJkiRJqoAFtiRJkiRJFbDAliRJkiSpAhbYkiRJkiRVIFJKdfehVSLisXnz5u2877771t0VSZIkSVLF7rzzTp577rnHU0q7THZbC+xJioh7gfnA+pq70o+l5fauWnuhscylecykmcylmcylecykmcylmcyleZqYyQjwVEppyWQ3tMAeYBFxO0BK6a1190UvM5fmMZNmMpdmMpfmMZNmMpdmMpfmGbRM/A62JEmSJEkVsMCWJEmSJKkCFtiSJEmSJFXAAluSJEmSpApYYEuSJEmSVAHPIi5JkiRJUgXcgy1JkiRJUgUssCVJkiRJqoAFtiRJkiRJFbDAliRJkiSpAhbYkiRJkiRVwAJbkiRJkqQKWGBLkiRJklQBC+yGiojlEbE6Ih6PiI0R8eOI+GREzJmNtiLi2Ii4NSKeiYgnI2JtRBze5+PtHRHPRkSKiMsn298ma1MuEXF8RFwXEesi4qmSyZ0RcVFE7DPZ/jZZW3KJiG0i4qiIuDgi/rfksjEi7oiIz0fEjpPtb1O1JZOy7m9FxOkRcX1EPFz+dz0w2X42QUTsERF/HxEPRsSmiFgfEedFxMKZbme2X2vapC25lPY/GxFXldeOreXv4Q1Ted5N16JcDoiIL0XEDyLil+Ux7o2Irw1aNi3K5KCIuCzya/ljEfF8yeRfIuLQqTz3JmtLLl223a5kNLuv6yklp4ZNwJHAZuAZ4GLgy8BdQAKumum2gLPK8vuBc4ELgMfKvJMmeLy5wH8DT5f1L697PIc1F2ANcCfwDeDs8hiry+NuAt5b95gOWy7A0jL/GeBbwJll/XVl/t3ArnWP6TBlUtY/ryx7AfhR+fmBusdxCuO+F/BI6f91wBnl/0AqY7bLTLUzGzm1dWpTLsD7y7KtwD3AE+X+G+oexyHP5WFgC/C98v/qLOBmXn49eXvd4zmEmZwGbACuAc4HTie/3xp9//uFusdzGHPpsv3ZHZnM2ut67aE5veoXYT7wf+QCaFnH/O2BW8ovyDEz1RawvMxfByzsmD9CfuPzPDAyzmOeWh7vEwxQgd3GXIDtezz+YaWtn9Q9rsOWC7AY+GNghzHtbAv8a2nrq3WP6zBlUpbtB7wF2Lbcb2uB/e3S95PHzD+nzF85E+3MVk5tnVqWyx7AO4D55f5aBrfAblMunwF27/LYf1HWv6Pu8RzCTHq9x1pMLiK3AIvqHtNhy2XM9ivIHxZ+HAvs4Z6A48svwSVdlh1Slt04U20Bl5b5H+2yzefLsr/u8XjLgBeBz5Vf6kEqsFubS48+PAG8UPe4mssr1h8tOFr9RmkQMpntF+KKxn3P0u97gdeMWbYj+dP/Zxnz4U4V7dT9t9PkqW25dFlvLQNYYLc9l4715wAbyzZ97UVs6jQomZRtri3bHFD3uA5rLuTifD3wnXJ/Vl/X/Q528xxSbm/osuwm8j/S5RGx3Qy1Nd42149Z5yURMY/8hul/yId8DJpW5tJNRBwI7ATc0c/6DTcwuZA/nIJ8KFSbDVImbTL6nP49pbS1c0FK6Wny4aSvBX5nBtoxp97alsuwGJRcEi+/ZmzpY/0mG4hMImI34LfJe13vnmj9FmhrLucDC4ETJujXjLDAbp7Rk0/9dOyClNJm8ic/c8mfBFXaVkTsQD605ZmU0kNd2vtZud27y7IzSjvHlrYHTVtzISKOjojTIuLMiLgW+C7wOHBSH31tutbm0sXx5bbbC0mbDFImbdJzrIp+n/tU2jGn3lqTy5AZlFw+SN779/2U0q/6WL/JWplJRCwr77G+GBGryN8P3g34VErp0Qn62gatyyUijgKOBT6dUrpvgn7NiLl1PKjGtaDcPtlj+ej8nWagrSk9djlb4snAn6eUftJHv9qodbl0OBr4UMf9nwG/n1K6bdxetkObc3lJRBwBfAx4APjSROs33EBk0kJVPfeptGNOvbUpl2HS+lwiYgnwVfIe7D8db92WaGsmy4C/6rj/NPmrL5eN28v2aFUuEfF64O+A61NKF0/QpxnjHuwZUE45nyYxTeZSVlFuUxVdnWJbL60fETsBXyefOfzsCvo0Y4Ypl1fMTOmYlFKQ/1EdQP7E7+aIOG7KPazQsObyUqMRy4EryN89+kBK6Ykp9K1Sw57JgKpq3KfSjjn11sZchkGjcymHIV8PvA44JaV0y9S61yqNzCSltLK8x5oHvIn8nvjSiFg5rV62R9NyuQjYBjhxmv2ZFvdgz4x7yGdA7deDHT+PfhqzoNuK5C/td643nsm2NdH63T5JOgfYFTgspdT07/8MUy6vklJ6CrglIt4H3AZcGBH/kVKq+3q/Q5tLRLyd/CZpK/myabf20c/ZMLSZtFhV4z6VdsyptzblMkxam0sprteQD589JaX0txP0sS1amwlASul58qVRTynfCf5YeY919QT9bbrW5BIRHwHeR/666oYJ+jOjLLBnQEppOheYv5t8uMnewO2dCyJiLrCEfDjQz6tuK6X0bERsABZHxKIu3417Y7nt/C7E/uRP7e6KCLr4cER8GPhRSmm/Pvo8Y4Ysl55SSi9ExHeBN5NPJlHrP/9hzSUi3gH8G7m4fndK6ft99HFWDGsmLTd6Mp1e34Pr97lPpR1z6q01uQyZVuYSEYvI51FZCvzJABXX0NJMerie/LWvFdT8HqsCbcpl/3J7SURc0uUxFkfE6N7uhTN53gIPEW+eNeX2PV2WHUQ+w94tKaVNM9TWeNu8d8w6ANeQL/w+dlpdlt9T7l/TR3+brG25TGRxuW37CelamUtEHEJ+Ad5MPvqjMcV1BVqZyQD4z3L7roh4xWt7ROxI/nrIc8BEv2tTacecemtbLsOidblExB7AjeTi+uMDVlxDCzMZx6C8x4J25fJfdK9JRr+LvbHj/sz+35ut64E59TeRD3f4JZO72P0C8j/cRRW0NXot3nXkT3dG548Aj5EPGx3p43msYLCug92qXIBdgDf3eC6Hky8J9XRnW22c2pZLWfYu8j/5R4G31D2GZtL1OSRadh3s0u9vl76fPGb+OWX+yo5525Qx32s67dSZU1umNuXS5THXMoDXwW5bLsCvk3dYbKHLteMHZWpZJgcz5nrOZf5ewIayzWF1j+mw5TLOc5jV1/XaQ3Pq+kvwfvKnXs8AXyOfVfiu8stxFRBj1j+uLFs13bbKNmeX5fcD5wIXkIuBBJzU53NYwQAV2G3LBdivzL+dfH3y04ELyZ/uJeAF4EN1j+kQ5rIP+RPaRD5s7LRuU91jOkyZlPWXAqs6pkQ+6VznvF3rHtc+xn0v4JHS/+vK3/2acv9uYJeOdUfK/PXTaWc2c2rr1MJcOn/vHy7r/lPHvAPrHtNhy4V8ctJEPn/KaT2mkbrHdMgy+RWwHvgmcBZwHvAt8g6MBJxf93gOYy7jPAcLbKcE+VCJ1cAT5DfkdwCfAuZ0Wfc4erw5nWxbHdscC/yA/CbzafJhSYdPov8rGLACu025AAuBvwG+BzxELqifJZ+AYyWwb91jOaS5jP5djDvVPZ7DlMkkchmpe0z7HPdfI5/FdvTv/hfAV4Cdx6w3Qo83QZNpZzZzavPUplz6+Fs4ru7xHLZc+sgkASvqHs8hy+QU8nlUfkE+Km0TcB+56Ht33eM4rLmM08asFthRHlSSJEmSJE2DJzmTJEmSJKkCFtiSJEmSJFXAAluSJEmSpApYYEuSJEmSVAELbEmSJEmSKmCBLUmSJElSBSywJUmSJEmqgAW2JEmSJEkVsMCWJEmSJKkCFtiSJEmSJFXAAluSJEmSpApYYEuSJEmSVAELbEmSJEmSKmCBLUmSJElSBSywJUmSJEmqgAW2JEmSJEkVsMCWJEmSJKkC/w+Imo7E3DMmMQAAAABJRU5ErkJggg==\n", + "text/plain": [ + "
" + ] + }, + "metadata": { + "image/png": { + "height": 367, + "width": 492 + }, + "needs_background": "light" + }, + "output_type": "display_data" + } + ], + "source": [ + "dat = parse_lineout('z_lineout.dat')\n", + "plt.plot(dat['z'], dat['Ez'])" + ] + }, + { + "cell_type": "markdown", + "id": "looking-evening", + "metadata": {}, + "source": [ + "# Paper results\n", + "\n", + "Reproduce plots in:\n", + "\n", + "C. E. Mayes, R. D. Ryne, D. C. Sagan, *3D Space Charge in Bmad*, IPAC2018, Vancouver, BC, Canada\n", + "https://accelconf.web.cern.ch/ipac2018/papers/thpak085.pdf" + ] + }, + { + "cell_type": "code", + "execution_count": 7, + "id": "willing-sleep", + "metadata": {}, + "outputs": [], + "source": [ + "def set_params(filename='params.in', sigma_z=1e-3, sigma_x=1e-3):\n", + " params = f\"\"\"\n", + " &OPENSC_TEST_PARAMS\n", + " NXLO=1 ,\n", + " NXHI=128 ,\n", + " NYLO=1 ,\n", + " NYHI=128 ,\n", + " NZLO=1 ,\n", + " NZHI=128 ,\n", + " N_PARTICLE=10000000 ,\n", + " E_TOT= 0.51099891e6 ,\n", + " BUNCH_CHARGE= 1e-9,\n", + " DISTTYPE = 1, \n", + " SIGMA_X= {sigma_x},\n", + " SIGMA_Y= 1.0000000000000000E-003,\n", + " SIGMA_Z= {sigma_z},\n", + " GAUSSIANCUTOFF= 6 ,\n", + " DIRECT_FIELD_CALC=T,\n", + " INTEGRATED_GREEN_FUNCTION=T,\n", + " CATHODE_IMAGES=F,\n", + " IMAGE_METHOD=3 ,\n", + " RECTPIPE=F,\n", + " READ_RECTPIPE=F,\n", + " WRITE_RECTPIPE=F,\n", + " APIPE= 1.2000000000000000E-002,\n", + " BPIPE= 1.2000000000000000E-002,\n", + " /\n", + " \n", + " \"\"\"\n", + " with open(filename, 'w') as f:\n", + " f.write(params)\n", + "set_params() " + ] + }, + { + "cell_type": "code", + "execution_count": 8, + "id": "experienced-mission", + "metadata": {}, + "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + " ------------------------\n", + "&OPENSC_TEST_PARAMS\n", + " NXLO=1 ,\n", + " NXHI=128 ,\n", + " NYLO=1 ,\n", + " NYHI=128 ,\n", + " NZLO=1 ,\n", + " NZHI=128 ,\n", + " N_PARTICLE=10000000 ,\n", + " E_TOT= 510998.90999999997 ,\n", + " BUNCH_CHARGE= 1.0000000000000001E-009,\n", + " SIGMA_X= 1.0000000000000000E-003,\n", + " SIGMA_Y= 1.0000000000000000E-003,\n", + " SIGMA_Z= 1.0000000000000000E-003,\n", + " GAUSSIANCUTOFF= 6.0000000000000000 ,\n", + " DIRECT_FIELD_CALC=T,\n", + " INTEGRATED_GREEN_FUNCTION=T,\n", + " CATHODE_IMAGES=F,\n", + " IMAGE_METHOD=3 ,\n", + " DISTTYPE=1 ,\n", + " RECTPIPE=F,\n", + " READ_RECTPIPE=F,\n", + " WRITE_RECTPIPE=F,\n", + " APIPE= 1.2000000000000000E-002,\n", + " BPIPE= 1.2000000000000000E-002,\n", + " /\n", + " ------------------------\n", + " gamma= 1.0000000000000000 \n", + " beta0= 0.0000000000000000 \n", + " particle xmin,xmax= -5.1371331804109365E-003 5.2486260066664289E-003\n", + " particle ymin,ymax= -5.1327292599210534E-003 5.1362984650888356E-003\n", + " particle zmin,zmax= -5.1727941411408721E-003 5.5060669996351945E-003\n", + " added zcentroid to z particle data, where zcentroid= 0.0000000000000000 \n", + " Done computing initial 3D Gaussian spatial distribution w/ cold velocity distribution\n", + " mesh xmin,xmax= -5.2202192539080776E-003 5.3317120801635804E-003\n", + " mesh ymin,ymax= -5.2148814817216532E-003 5.2184506868894372E-003\n", + " mesh zmin,zmax= -5.2582250302676062E-003 5.5914978887619624E-003\n", + " delta(1:3)= 8.3086073496627225E-005 8.2152221800087325E-005 8.5430889126217069E-005\n", + " Done with charge deposition\n", + " Space charge field calc with free-space boundary condition...\n", + " Chris' method\n", + " ...done\n", + " Time for space charge calc (s): 26.045808000000001 \n", + "\n" + ] + } + ], + "source": [ + "def run_test(verbose=False, **params):\n", + " dat = {}\n", + " tdir = tempfile.TemporaryDirectory()\n", + " fname = os.path.join(tdir.name, 'params.in')\n", + " set_params(filename=fname, **params)\n", + " t0 = time.time()\n", + " res = subprocess.run([TEST_BIN, 'params.in'], cwd=tdir.name, stdout=subprocess.PIPE, stderr=subprocess.PIPE)\n", + " dat['run_time'] = time.time() - t0\n", + " if verbose:\n", + " print(res.stdout.decode('utf-8'))\n", + "\n", + " \n", + " dat['x_line'] = parse_lineout(os.path.join(tdir.name, 'x_lineout.dat'))\n", + " dat['z_line'] = parse_lineout(os.path.join(tdir.name, 'z_lineout.dat'))\n", + " return dat\n", + "\n", + "DAT = run_test(verbose=True) " + ] + }, + { + "cell_type": "code", + "execution_count": 9, + "id": "norman-silence", + "metadata": {}, + "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + "CPU times: user 20.7 ms, sys: 23.1 ms, total: 43.8 ms\n", + "Wall time: 2min\n" + ] + } + ], + "source": [ + "%%time\n", + "# Run various ratios\n", + "ALLDAT = {}\n", + "for ratio in [.01, .1, 1, 10]:\n", + " sigma_x = 0.001\n", + " sigma_z = ratio*sigma_x\n", + " ALLDAT[ratio] = run_test(sigma_x=sigma_x, sigma_z=sigma_z) " + ] + }, + { + "cell_type": "code", + "execution_count": 10, + "id": "surface-cooperation", + "metadata": {}, + "outputs": [], + "source": [ + "# To plot the charge density. Ignore the normalization.\n", + "def gauss(x):\n", + " return np.exp(-x**2/2)" + ] + }, + { + "cell_type": "code", + "execution_count": 11, + "id": "first-service", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "" + ] + }, + "execution_count": 11, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAABDAAAAKCCAYAAAAnRilSAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAADd30lEQVR4nOzdeXycVdn/8c+ZzEz2pE3SNN3oRjeWtkBpS4GyV0AU3MBHURD19yA+IrggigooiAqyCYIbLqCyKpuIBVq2FgqlCxS6r3RJ0mZPZp85vz/uzCRpkzbLJDNJvu/X67zumXPfc+4rbSgz15xzHWOtRUREREREREQknblSHYCIiIiIiIiIyKEogSEiIiIiIiIiaU8JDBERERERERFJe0pgiIiIiIiIiEjaUwJDRERERERERNKeEhgiIiIiIiIikvaUwBARERERERGRtKcEhoiIiIiIiIikPSUwRERERERERCTtKYEhIiIiIiIiImlPCQwRERERERERSXtKYIiIiIiIiIhI2lMCQ0RERERERETSnhIYIiIiIiIiIpL2Bn0CwxjzaWPMr40xrxlj6o0x1hjz0CFeM88Y85wxptoY4zPGvGuMucoYk9GN+ydtLBEREREREZGByp3qANLAD4EZQCOwE5h6sIuNMecDTwAB4BGgGvgYcAdwIvCZzt44mWOJiIiIiIiIDGTGWpvqGFLKGHMaTuJiE3AKsBj4m7X24nauLWi+rhA40Vq7vLk/C1gEnAD8j7X24U7cN2ljiYiIiIiIiAx0g34JibV2sbV2o+1cJufTwDDg4XjCoXmMAM5MDoCvdfLWyRxLREREREREZEAb9AmMLjq9+fh8O+deBXzAPGNMZh+PJSIiIiIiIjKgKYHRNVOajxv2P2GtjQBbceqKTOjjsUREREREREQGNBXx7JrC5mNdB+fj/UP6cixjzDsdnDqm+ejvRDwiIiIiIiLSv2QDUWutJ9WB9AUlMJLLNB+TURk1GWMZgOzs7JyehyMiIiIiIiLpxO/3A2SkOo6+ogRG18RnRRR2cL5gv+v6ZCxr7XHt9RtjmrKzs3N8Pl8nwhEREREREZH+JCcnB39zFmMwUA2MrlnffJy8/wljjBsYD0SALX08loiIiIiIiMiApgRG1yxqPp7dzrn5QA6w1Fob7OOxRERERERERAY0JTC65nFgH/BZY8yseKcxJgu4qfnpfa1fYIwpNMZMNcaM6OlYIiIiIiIiIoPVoK+BYYy5ALig+WlZ8/EEY8yfmx/vs9Z+B8BaW2+M+SpO8uFlY8zDQDXwcZxtUR8HHtnvFp8A/gT8Bbg03tnNsUREREREREQGpUGfwABmApfs1zehuQFsB74TP2GtfdIYcwpwHfApIAvYBHwLuNta2+ldQ5I5loiIiIiIiMhAZvQZeeDSLiQiIiIiIiIDV/MuJD5rbW6qY+kLqoEhIiIiIiIiImlPS0hERERERET6uVgsRnV1NQ0NDQSDQTTTvv8xxpCZmUl+fj5FRUW4XJpvsD8lMERERERERPqxWCzGhx9+iJaO92/WWgKBAIFAgKamJsaMGaMkxn6UwBAREREREenHqqur8fl8uN1uysrKyM3N1QfffigWi9HU1ER5eTk+n4/q6mpKSkpSHVZa0W+1iIiIiIhIP9bQ0ABAWVkZ+fn5Sl70Uy6Xi/z8fMrKyoCWv1dpod9sERERERGRfiwYDAKQmzsoNqIY8OJ/j/G/V2mhBIaIiIiIiEg/Fi/YqZkXA4MxBkCFWNuh33ARERERERGRNBFPYMiBlMAQERERERERkbSnBIaIiIiIiIiIpD0lMEREREREREQGKWPMp40xvzbGvGaMqTfGWGPMQ90ca7Qx5gFjzG5jTNAYs80Yc6cxZmgyYnUnYxARERERERER6Zd+CMwAGoGdwNTuDGKMmQgsBUqBp4B1wGzgm8DZxpgTrbVVPQlUMzBEREREREREBq+rgclAAfC1HozzG5zkxZXW2gustddaa08H7gCmADf3NFAlMEREREREREQGKWvtYmvtRtuDfVuNMROABcA24N79Tl8PNAFfMMbkdjtQlMAQERERERGRNLdt2zaMMVx66aVs2LCBiy66iNLSUlwuFy+//HKqwxM4vfm40Foba33CWtsALAFygLk9uYlqYIiIiMiAEv8CyRiT4khERCTZNm/ezJw5c5g8eTKf//zn8fv9FBQUpDqsVMsyxrzT3glr7XF9FMOU5uOGDs5vxJmhMRl4qbs3UQJDRERE+q1IJEIkEiEcDieO4XCYjIwMsrOzycnJwePxpDpMERFJktdff53vf//7/OxnP0t1KNJWYfOxroPz8f4hPbmJEhgiIiLS7wQCAerq6hKJi2g0mkhmRKNRMjIyyMzMTLScnByys7PJyMhIdegiItIDw4cP5/rrr091GOkm0IczLborPi2y23U2QAkMERER6UestdTX11NfX09DQwPRaBS3201GRgYejyeRpIhGowQCAWpra8nIyCArK4vMzEyys7MZMmQILpfKgImI9EczZswgMzMz1WHIgeIzLAo7OF+w33XdogSGiIiI9AvhcJja2loaGxtpbGxMzKpoj9vtJi8vj9zcXMLhMIFAgKamJnJycohGoxQVFWk2hohIP1RWVpbqEKR965uPkzs4P6n52FGNjE5RAkNERETSXlNTE3V1dTQ0NBAOhyksLMTtPvTbGGMMXq8Xr9dLNBqlrq6OWCyGtZaioqJOjSEiIulDBZrT1uLm4wJjjKv1TiTGmHzgRMAPvNmTm2j+pIiIiKStWCxGTU0NVVVV1NTUADB06NBuJR4yMjIYMmQI4XCYmpoa9u7dSzgcTnbIIiIiA5YxxmOMmWqMmdi631q7GVgIjAO+vt/LbgRygb9aa5t6cn997SAiIiJpq7a2ltraWpqamsjNzSUrK6tH47lcLgoLC6mvr6euzlmGW1RUpPXUIiIyaBljLgAuaH4aX6NzgjHmz82P91lrv9P8eBSwFtiOk6xo7QpgKXC3MeaM5uvmAKfhLB25rqexKoEhIiIiaamhoYGGhgZ8Pl+nl4x0hjGGgoICGhoaqK2tJRaLUVRU1GE9DRERkQFuJnDJfn0Tmhs4yYrvcAjW2s3GmFnAT4CzgXOBPcDdwI3W2uqeBqoEhoiIiKSd+DapDQ0N5OXlJb1WRTyJ0djYSG1tLQAlJSWaiSEiIoOOtfYG4IZOXruNli1R2zv/IfClZMTVHiUwREREJK1EIhFqamqor68nKysLr9fba/fKy8ujsbGR+vp63G43w4YN0xarIiJpaNy4cVhrUx2GpJj+Dy0iIiJpIxaLUV1dTX19PS6Xi5ycnF6/Z25uLtZaGhsbE3UxREREJP0ogSEiIiJpo7a2lsbGRsLhMHl5eX1yT2MM+fn5+Hw+Ghsb8fv9fXJfERER6RotIREREZG00NjYSENDA01NTRQWFvbpUo6MjAxyc3MTS0m8Xi8ZGRl9dn8RERE5NM3AEBERkZQLBoPU1tb2WtHOzsjKysLlctHU1JQo7CkiIiLpQwkMERERSSlrbWLHkczMzJTuBJKfn08gEKCxsZGmpqaUxSEiIiIHUgJDREREUqqpqQmfz0c0Gu2Top0H43K5yM3NTRT0jEQiKY1HREREWiiBISIiIikTi8USdS/y8vIwpsOt5ftMZmYmbrebhoYGampqtG2fiIhImlACQ0RERFKmoaEBn8+Hy+XC6/WmOpyE3NxcwuEwTU1NWkoiIiKSJpTAEBERkZQIh8M0Njbi8/nIzc1NdThtuFwu8vLyaGpqoqGhgVgsluqQREREBj0lMERERCQl6uvraWpqSizZSDderxdjDH6/X7MwRERE0oASGCIiItLnAoEAPp+PYDCY8sKdB5Obm4vf76exsVGzMERERFJMCQwRERHpU9baxOyL7OxsXK70fTvi8XhwuVz4fD4aGxtTHY6IiMiglr7vGERERGRA8vl8+P1+IpEI2dnZqQ7nkHJychKzMKLRaKrDERERGbSUwBAREZE+E982tbGxkdzc3LTYNvVQPB4Pbrc7kcQQERGR1FACQ0RERPpMfNcRYwyZmZmpDqfTcnJy8Pl8NDU1aRaGiEg/sHPnTi677DJGjhxJZmYm48aN46qrrqKmpqbXxgmHw9x111186UtfYubMmYli0H/4wx+S9WMNeulX8ltEREQGpFgslkhgFBQUpDqcLnG73Xg8Hvx+Pw0NDQwZMiTVIYmISAc2b97MvHnzqKys5Pzzz2fq1Km89dZb3HXXXTz//PMsWbKE4uLipI/T1NTEVVddBcDw4cMpKyvjww8/7K0fc1DSDAwRERHpEz6fj0AgQEZGRlpum3oorWdhRCKRVIcjIiIduOKKK6isrOTuu+/mySef5Oc//zmLFi3i6quvZv369Vx33XW9Mk5OTg7PPfccu3fvpry8nMsuu6w3frxBTQkMERER6XXWWpqamvD7/f2icGd73G43Xq83MQtDRETSz5YtW1i4cCHjxo3j61//eptzN954I7m5uTz44IM0NTUlfRyv18s555zDiBEjkvcDSRtKYIiIiEiv8/v9BAIBwHmD11/FdyTx+XyEw+FUhyMiIvtZtGgRAAsWLDhgm+78/HxOPPFEfD4fb775Zp+MI8mlBIaIiIj0uqamJnw+X7+dfRGXkZFBZmYmPp9PO5KIiKSh9evXAzB58uR2z0+aNAmADRs29Mk4klz9bwGqiIiI9CvBYBC/308kEul3xTvbk52dTW1tLX6/n4KCAjIyMlIdkojIQd1obkx1CJ12vb2+R6+vq6sDoLCwsN3z8f7a2to+GUeSSzMwREREpFe1rn1hjEl1OD2WkZGBx+MhEAjg8/lSHY6IiHSBtRagx/8/StY40jVKYIiIiEiviUQi+Hw+QqEQWVlZqQ4nabKyshK1MOJvYkVEJPXiMyPiMyj2V19f3+a63h5HkktLSERERKTXNDY2EggEyMzMPKAIWn/m9XoTP1sgEOj3tT1EZGDr6bKM/mTKlClAx7UpNm7cCHRc2yLZ40hyDZx3EiIiIpJWYrEYPp8Pv98/oGZfxGVnZ2sZiYhImjnttNMAWLhwIbFYrM25hoYGlixZQnZ2NnPnzu2TcSS5lMAQERGRXhGvfeF2u3G7B96kz8zMTEKhUKJAqYiIpN7EiRNZsGAB27Zt4957721z7vrrr6epqYkvfvGL5ObmAhAOh1m3bh2bN2/u0TjSN4zWbQ5cxpim7OzsHH0zJCIifc1aS0VFBVVVVeTm5uL1elMdUq9obGzE5XIxbNgwrYMWkZRZu3YtANOmTUtxJOlh8+bNzJs3j8rKSs4//3ymTZvGsmXLWLx4MZMnT2bp0qUUFxcDsG3bNsaPH8/YsWPZtm1bt8eJ+/nPf866desAWLVqFatXr2bevHmJbVdPOukkvvKVrxzyZ+js32lOTg5+v99nrR0UmZSB93VILzPGXAr86RCXxay1h9xTzRizDRjbwekKa21Z16ITERFJD36/n0AgADBgkxfgFPOsr6/H5/ORn58/oOp8iIj0VxMnTmT58uX8+Mc/5vnnn+e5555jxIgRXHnllVx//fUUFRX12jjPP/88r7zySpu+pUuXsnTp0sTzziQwpH2agdFFxpiZwAUdnD4ZOB34t7X2vE6MtQ0YAtzZzulGa+1t3Ymx1fiagSEiIilRWVlJVVUVmZmZA7L+RWu1tbVkZ2dTWlqqqcQikhKagTHwaAZG+zQDo4ustauAVe2dM8a80fzwd10YstZae0PPohIREUkfoVCIYDBIJBKhoKAg1eH0ungxz6amJiUwREREepHmOSaJMeYoYC6wC/h3isMRERFJGZ/PRyAQICsrC2NMqsPpdV6vl0gkQiAQIBgMpjocERGRAUszMJLnf5uPf7TWRrvwukxjzMXAYUAT8C7wahfHEBERSQvWWvx+P8FgcFDMvgAwxpCVlZXYUjUzMzPVIYmIiAxISmAkgTEmG7gYiAF/6OLLy4AH9+vbaoz5krX2lfZeICIikq7isxBcLteA3Dq1I9nZ2dTU1ODz+SgoKCAj45C1vEVERKSLBs87i951IU4xzn9baz/swuv+BLwGvA80ABOA/wP+H/AfY8wJ1trVhxrEGPNOB6cGdtU0ERFJOz6fj2AwOOhmIbhcLjweT2IWRn5+fqpDEhERGXBUAyM5/l/z8bddeZG19kZr7SJrbYW11metXWOtvRy4HcgGbkhynCIiIr0mGo0SCAQIhUKDLoEBLcU8fT4f2uVNREQk+TQDo4eMMUcA84CdwHNJGvZ+4NvA/M5cbK09roPYmoCcJMUkIiJyUPHinR6PB5dr8H1H4vF4sNYSDAYHbRJHRESkNw2+dxfJ193inQdT2XzUXmwiItJvxIt3ZmUN3hWMmZmZBINB/H5/qkMREREZcJTA6AFjTBbwBZzinX9M4tAnNB+3JHFMERGRXhMKhQgGg0SjUTweT6rDSZl4AiMQCGgZiYiISJIpgdEznwGGAs91VLzTGOMxxkw1xkzcr/9IY0xRO9ePBe5pfvpQsgMWERHpDfHlI1lZWRhjUh1OyrjdbowxiSSGiIiIJI9qYPRMvHjn7w5yzShgLbAdGNeq/zPAtcaYxcBWnF1IJgIfxdk95DngtiTHKyIiknTW2sTykYKCglSHk3JZWVkEAgH8fj/Z2dmpDkdERGTAUAKjm4wx04CT6H7xzsXAFOAYnCUjuUAt8DrwIPCg1dxTERHpBwKBAMFgEJfLhduttxaZmZmJGSmxWGxQFjQVERHpDXqX0U3W2rXAIefIWmu3tXedtfYV4JXkRyYiItK3fD4fwWBQu240iydy4sU8c3NVk1tERCQZ9JWAiIiIdFs0GiUQCGjb0P1oNxIREZHkUwJDREREui2+VMLj8WipRCter5dwOJzYmUVERPrWzp07ueyyyxg5ciSZmZmMGzeOq666ipqamk6P8fjjj/ONb3yDk08+mYKCAowxXHzxxb0YtRyKlpCIiIhIt8WLd+bk5KQ6lLTicrnweDyJYp55eXmpDklEZNDYvHkz8+bNo7KykvPPP5+pU6fy1ltvcdddd/H888+zZMkSiouLDznOTTfdxOrVq8nLy2P06NGsW7euD6KXg9FXJSIiItItoVAoMcPA4/GkOpy0k5WVRTAYxOfzpToUEZFB5YorrqCyspK7776bJ598kp///OcsWrSIq6++mvXr13Pdddd1apw77riDDRs2UF9fz3333dfLUUtnKIEhIiIi3RLffSQzMxNjDlnXetDxeDxEo1GCwSDhcDjV4YiIDApbtmxh4cKFjBs3jq9//ettzt14443k5uby4IMP0tTUdMixTjvtNCZNmqT/x6URJTBERESkW+LLR1S8s33GGBXzFBHpY4sWLQJgwYIFB9Rmys/P58QTT8Tn8/Hmm2+mIjzpISUwREREpMtCoRChUIhYLKblIwfROoFhrU11OCIiA9769esBmDx5crvnJ02aBMCGDRv6LCZJHhXxFBERkS5rvXxEOubxeLDWEgwGtdWsiKRMf1oB0dNcb11dHQCFhYXtno/319bW9uxGkhKagSEiIiJdpgRG52kZiYhI+ojPhlNdi/5JCQwRERHpknA4TDAYJBaL4XZrMuehxBMYgUBAy0hERHpZfIZFfCbG/urr69tcJ/2L3nWIiIhIl/j9/sRyCH2DdWhutxtjDMFgkGAwSFZWVqpDEpFBZjDlTqdMmQJ0XONi48aNQMc1MiS9aQaGiIiIdEkgECAQCOD1elMdSr+RmZlJKBQiEAikOhQRkQHttNNOA2DhwoXEYrE25xoaGliyZAnZ2dnMnTs3FeFJDymBISIiIp3WevmIdh/pPK/Xm0hgaBmJiEjvmThxIgsWLGDbtm3ce++9bc5df/31NDU18cUvfpHc3FzA+f/aunXr2Lx5cyrClS7SEhIRERHptEAgQCgUwuv1avlIF7jdbqy1hEIhwuGwZq+IiPSi3/zmN8ybN48rr7ySl156iWnTprFs2TIWL17M5MmTufnmmxPX7tq1i2nTpjF27Fi2bdvWZpwnn3ySJ598EoDy8nIA3njjDS699FIASkpKuO222/riR5JmSmCIiIhIp/n9foLBIDk5OakOpd+Jz8Lw+/1KYIiI9KKJEyeyfPlyfvzjH/P888/z3HPPMWLECK688kquv/56ioqKOjXOqlWr+Mtf/tKmb8uWLWzZsgWAsWPHKoHRx4ymMQ5cxpim7OzsHJ/Pl+pQRERkAAiHw1RUVFBTU0NRUZFmYHRROBymsbGRkpIShg8fnupwRGQAWbt2LQDTpk1LcSSSLJ39O83JycHv9/ustbl9EVeqqQaGiIiIdEogECAYDGr5SDd5PB5isVhiGYmIiIh0jRIYIiIi0inxBEZmZmaqQ+m3tBuJiIhI9ymBISIiIocUiUQIBoNEo1HtPtIDXq+XYDCoBIaIiEg3KIEhIiIihxQv3qnlIz3j8XiIRqMEg0EikUiqwxEREelXlMAQERGRQ9LykeQwxuDxeDQLQ0REpBuUwBAREZGD0vKR5FIdDBERke5RAkNEREQOKj77wuPxaPlIEni93jZJIREREekcJTBERETkoAKBAOFwWMtHkiS+jESzMERERLpGCQwRERHpUCwWIxgMEg6HtXwkibQbiYiISNcpgSEiIiIdiicvMjIycLn0tiFZvF4v4XCYYDBILBZLdTgiIiL9gt6JiIiISIe0+0jvcLlcZGRkEAqFCAaDqQ5HRESkX1ACQ0RERNplrU3MwPB6vakOZ8DJzMwkGAzi9/tTHYqIiEi/oASGiIiItCsUChEKhQDIyMhIcTQDj9frTRTytNamOhwREZG0pwSGiIiItCsYDBIKhTT7opfE64rEa2GIiIjIwSmBISIiIu2K179QAqP3ZGZmqg6GiEgSPf7443zjG9/g5JNPpqCgAGMMF198carDkiRxpzoAERERST+RSIRQKEQsFtP2qb3I4/HQ2NhIIBCgsLAw1eGIiPR7N910E6tXryYvL4/Ro0ezbt26VIckSaQZGCIiInKA+PIRj8eDMSbV4QxYHo+HWCxGOBwmEomkOhwRkX7vjjvuYMOGDdTX13PfffelOhxJMs3AEBERkQMEAgHVv+gjXq+XYDBIIBAgLy8v1eGIiPRrp512WqpDkF6kGRgiIiLSRiwWUwHPPuT1elXIU0REpBOUwBAREZE24skLt9uNy6W3Cr3N4/EkCnnGYrFUhyMiIpK2tIRERERE2tDsi77lcrlwu92JWRjZ2dmpDklEBpj+VMvIWpvqECSN6WsVERERSbDWqv5FCsTrYGgZiYiISMeUwBAREZGEcDhMKBQCwO3WRM2+ojoYIiIih6Z3JiIiIpIQCAQIh8OafdHH3G43sViMUChEOBzG4/GkOiQRGUC0LEMGCs3AEBERkYT4MgYlMPqe1+slFAoRCARSHYqIiEhaUgJDREREAIhGo4RCISKRiGYApEA8gaFlJCIi0teMMaONMQ8YY3YbY4LGmG3GmDuNMUO7OM5HjTELjTE7jTF+Y8wWY8xjxpgTkhGnlpCIiIgI4Cwfic++6E8V6wcKj8dDY2NjYjtVbWErItJ1Tz75JE8++SQA5eXlALzxxhtceumlAJSUlHDbbbelKLr0ZIyZCCwFSoGngHXAbOCbwNnGmBOttVWdGOcXwDVAFfAksA84HDgf+JQx5ovW2od6EqsSGCIiIgI4y0dU/yJ1XC4XGRkZ2k5VRKQHVq1axV/+8pc2fVu2bGHLli0AjB07VgmMA/0GJ3lxpbX21/FOY8ztwNXAzcDlBxvAGFMGfAeoAKZbaytbnTsNWAT8BOhRAkOpfREREcFaSzAYJBQKaflICsW3U1UdDBGR7rnhhhuw1nbYtm3bluoQ04oxZgKwANgG3Lvf6euBJuALxpjcQww1Fie/sKx18gLAWrsYaACG9TReJTBERESEUChEKBRKzAKQ1Gi9nap2DRARkT5wevNxobU21vqEtbYBWALkAHMPMc5GIATMNsaUtD5hjJkP5AMv9jRYLSERERGRxPIRzb5ILbfbeWsW305Vy3lERKQTsowx77R3wlp73CFeO6X5uKGD8xtxZmhMBl7qaBBrbbUx5nvA7cAHxpgncWphTAQ+DrwA/O8hYjkkJTBEREQksXwkJycn1aEMeq1nYSiBISIivayw+VjXwfl4/5BDDWStvdMYsw14APhqq1ObgD/vv7SkO7SEREREZJCLb58ajUY1AyMNqA6GiIh0UcBae1x7LQljx7clO+S6RmPMNcDjwJ9xZl7kAscBW4C/GWN+2dNglMAQEREZ5OLLFdxut7ZPTQMej6dNUklERKQXxWdYFHZwvmC/69pljDkV+AXwtLX2W9baLdZan7V2BfAJYBfw7eaiod2mBIaIiMggp91H0osxBrfbTSgUIhgMpjocEREZ2NY3Hyd3cH5S87GjGhlx5zUfF+9/wlrrA97CyT8c09UAW1MCQ0REZJCLJzBUbyF9eL1eJTBERKQvxBMOC4wxbfIDxph84ETAD7x5iHEym48dbZUa7w91J8g4JTBEREQGsXA4TCgUwlqb2AFDUs/j8SQKeYqIiPQWa+1mYCEwDvj6fqdvxKlj8VdrbROAMcZjjJlqjJm437WvNR//nzFmVOsTxphzcBIhAWBpT+LVO5VuaK6sOraD0xXW2rIujDUa+AlwNlAM7AGeBG601tb0LFIREZGD0+yL9BRPJoXDYW1vKyIive0KnMTC3caYM4C1wBzgNJylI9e1unZU8/ntOEmPuMeBF4EzgbXGmH8B5cA0nOUlBrjWWlvVk0CVwOi+OuDOdvobOztAc9ZqKVAKPAWsA2YD3wTONsac2NO/YBERkYMJBoOEw2EyMzMPfbH0KY/Hk1hGogSGiIj0FmvtZmPMLFq+WD8X54v1u3G+WK/uxBgxY8y5OLM4PotTuDMHqAaeA+621i7saaxKYHRfrbX2hh6O8Ruc5MWV1tpfxzuNMbcDVwM3A5f38B4iIiLtstYmZmDk5eWlOhzZT+sEhv5+RESkN1lrPwS+1InrttGyter+58I4X/LfmcTQ2lANjBRp3j5mAbANuHe/09cDTcAXjDG5fRyaiIgMEvHZF263G5dLbwnSjdfrTdTBsNamOhwREZGU0wyM7ss0xlwMHIaTbHgXeNVa29kN209vPi601sZan7DWNhhjluAkOOYCLyUpZhERkQRtn5reXC4XLpcrUWhVy3xERGSwUwKj+8qAB/fr22qM+ZK19pVOvH5K87Gj/XQ34iQwJqMEhoiI9AItH0l/rWdhKIEhIiKDneaLds+fgDNwkhi5wNHAb3GqsP7HGDOjE2MUNh/rOjgf7x9yqIGMMe+014CsTsQhIiKDUDQaJRwOE4vFtH1qGmtdB0NERA7t8ccf5xvf+AYnn3wyBQUFGGO4+OKLD/qapUuXcu6551JUVEROTg7Tp0/nzjvvJBrt7OR66St6x9IN1tob9+taA1xujGkEvg3cgFN1tSfihVG06FVERJKu9fIRY9qtxSVpwOPxEI1GCYVCRKNRMjIyUh2SiEhau+mmm1i9ejV5eXmMHj2adevWHfT6p556ik996lNkZWVx0UUXUVRUxDPPPMPVV1/NkiVLeOyxx/oocukMzcBIrvubj/M7cW18hkVhB+cL9ruuQ9ba49prQKATcYiIyCAUCARU/6IfMMbgdrsTdTBEROTg7rjjDjZs2EB9fT333XffQa+tr6/nq1/9KhkZGbz88sv88Y9/5NZbb2XVqlWccMIJPP744zz88MN9FLl0hhIYyVXZfOzMziHrm4+TOzg/qfnYUY0MERGRbrHWEgqFCIfDeL3eVIcjh6BlJCIinXfaaacxadKkTs0ufPzxx9m7dy+f/exnmTVrVqI/KyuLm266CeCQSRDpW0pgJNcJzcctnbh2cfNxgTGmzd+DMSYfOBHwA28mLzwRERHafJuvJQnpr3UhTxERSZ5FixYBcPbZZx9wbv78+eTk5LB06VL9+5tGlMDoImPMkcaYonb6xwL3ND99qFW/xxgz1RgzsfX11trNwEKcwp9f32+4G3FmcfzVWtuUxPBFREQIBoOafdGPuN1uYrFYYtaMiIgkx/r1zqT4yZMPnBTvdrsZP348kUiELVs68/209AUV8ey6zwDXGmMWA1uBBmAi8FGcXT+eA25rdf0oYC2wHSdZ0doVwFLgbmPMGc3XzQFOw1k6cl2v/RQiIjJoxQt4ZmdnpzoU6aT4MhLVLRGRbulPxZpt3+1hUFfnlBssLGy/LGG8v7a2tq9CkkNQAqPrFgNTgGNwlozkArXA68CDwIPWdu6/OmvtZmPMLOAnwNnAucAe4G7gRmttddKjFxGRQS3+TX4kEtH2qf1I62UkubmdKbUlIiI9Ff9Yp9260ofeuXSRtfYV4JUuXL+Nli1R2zv/IfClnkcmIiJyaPFlCBkZGbhcWknaX3i9XpqamggEAlhr9WZaRCQJ4jMs4jMx9ldfX9/mOkk9vXMREREZROLLR7QMoX9xuVy4XC5tpyoi3WNt/2l9aMqUKQBs2HDgxo+RSIStW7fidruZMGFCn8YlHVMCQ0REZBDR9qn9l8fj0W4kIiJJdPrppwPw/PPPH3Du1VdfxefzMW/ePDIzM/s6NOmAEhgiIiKDRDQaVf2Lfszr9RIKhZTAEBFJkk9/+tOUlJTw8MMPs3z58kR/IBDghz/8IQBf+9rXUhWetEPvXkRERAaJ+OwLj8ejGgr9kMfjSSShYrGYapiIiLTjySef5MknnwSgvLwcgDfeeINLL70UgJKSEm67zdk0sqCggN///vd8+tOf5tRTT+Wzn/0sRUVFPP3006xfv55Pf/rTXHTRRan4MaQDSmCIiIgMEqp/0b8ZY8jIyEgsI9E2uCIiB1q1ahV/+ctf2vRt2bKFLVu2ADB27NhEAgPgggsu4JVXXuHmm2/miSeeIBAIcPjhh3P77bdz5ZVXKuGfZkwnd/yUfsgY05SdnZ3j8/lSHYqIiKSBiooK9u3bR35+vpaQ9FM+n49YLEZpaSlDhgxJdTgikibWrl0LwLRp01IciSRLZ/9Oc3Jy8Pv9PmvtoNhjW3MPRUREBoFIJEI4HCYWiyl50Y/FC3lqJxIRERmMlMAQEREZBLR8ZGBwu93EYjFCoRDRaDTV4YiIiPQpJTBEREQGgdYFPKX/MsZoO1URERm0lMAQEREZBILBIOFwGK/Xm+pQpIc8Ho+2UxURkUFJCQwREZEBLhwOEw6HAcjIyEhxNNJTHo+HSCSiOhgiIjLoKIEhIiIywKn+xcASr4MRDoeJRCKpDkdERKTPKIEhIiIywMWXjyiBMXBoGYmIyMBlrU11CGlLCQwREZEBzFqbKOCp+hcDh9fr1XaqIpJgjAEgFoulOBJJhngCI/73Ki2UwBARERnA4vUvjDG4XPrf/kChnUhEpLXMzEwAmpqaUhyJJEP87zH+9yot9E5GRERkANPuIwNTvBhr6wKtIjJ45efnA1BeXk5DQwOxWEzLEPoZay2xWIyGhgbKy8uBlr9XaeFOdQAiIiLSe+IFPLOyslIdiiRZ6zoYqm8iMrgVFRXR1NSEz+dj586dqQ5HkiAnJ4eioqJUh5F2lMAQEREZoFrXv9C3OANPPIGhOhgi4nK5GDNmDNXV1TQ0NBAMBjUDox8yxpCZmUl+fj5FRUVa+tkOJTBEREQGqPjyEbfbrTdBA5DX66WpqSnxQUXF3kQGN5fLRUlJCSUlJakORaTX6N2MiIjIABWffaHlBQOTy+XCGNNndTCstfpGV0REUkozMERERAaoeP2LnJycVIcivSS+nWowGExKodZQY4gP3/iQms011O2oo/7Deuo+dI71O+uJhqN4c714cj1487xOy/WSOzyX0SeMZuzJYxlx7AgyvBlJ+OlERETaUgJDRERkAIrFYoRCIaLRqGZgDGAejyeRqOoOG7OUrypn88LNbF64mR2v7yAWjh30NaHGEKHGEE0VbbdrXPevdQC4s92Mnjuaw04+jLHzxzL25LFKaIiISFIogSEiIjIAxetfZGRkqDbCAObxeNoU7Ovs3/WO13ew/L7lbF64Gd8+X1JjivgjbFu8jW2LtwGQWZjJ1POnMu3T05i4YCLuTL39FBGR7jFayzhwGWOasrOzc3y+5L4xERGR9FdXV0dlZSXGGC0hGeBqamrIy8ujrKyMzMzMg15bvqqcl37wEpv+s6nDa0qPLmXkrJEUjCmg8LBCCscUOo/HFOLOdhNuChNqcmZhhJvCBBuCVK2vYsdrO9j+2nZqt9Z2OLY338uUj0/hiE8fweFnH447S8kMEZGeyMnJwe/3+6y1uamOpS8ogTGAKYEhIjJ4VVZWsnfvXvLy8rSEZIBrbGzE5XJRWlpKQUFBu9dUbaxi8Y8W8/4j7x9wLmdYDhMXTGTigolMOGsC+SN6tuVu/c56dry+g+2vbmfjcxup217X7nVZQ7I46n+OYualMxl5/EjNFBIR6QYlMGTAUAJDRGRwikajlJeXU1VVRXFxsT4YDnChUAi/38+wYcMO2D6xYXcDL9/4Miv/uBIbbfWez8CML8xg9pWzGXHMCIyrd35HrLXseWcPHzz+AR889gE1W2rava5kWgkzL53J9Iunkz+yZwkUEZHBRAkMGTCUwBARGZz8fj8VFRX4/X4KCwtTHY70slgsRk1NDUVFRYwYMQKXy4WNWZbfv5wXr32RUEPbAp9TL5jKaTedRumRpX0ap7WWitUVvP/Y+6z5x5p2l5oYl2HyeZOZ9915jDlxjJJvIiKHoASGDBhKYIiIDE51dXVUVFTgcrlU/2KQqK2tJTc3l+HDh9OwtYFnvvoMHy75sM01404bxxm3nMHoOaO7PL61UFkJtbUQjUIs5rT449xcmDgROrtaycYsO17fwao/r+L9R98n3BQ+4JrRJ4xm3nfnMfX8qb02Q0REpL9TAkMGDCUwREQGJ9W/GHyampqIRWJse3Qbb//sbaKhaOJc8ZRizrn7HCacNaFTMxo+/BDeew/WrnXaBx84x9rag7/O44GpU+Goo1ra0UfDuHFwsNuGGkOs/edaVv15VWLnktaKJxdzwndOYMYXZqjop4jIfpTAkAFDCQwRkcFH9S8Gp12rdvHaXa/RsLIB9jp9LreLk75/Eif/4OSDfvCPRGDJEnj2WaetW5fc2MaOhY98BBYsgDPOgCFDOr5279q9LL1tKe899F6bJAxA3og8Tr3hVI657BhcbldygxQR6aeUwJABQwkMEZHBR/UvBpdoKMry+5fz7oPvQjFQBZTDqONH8bHff4zhRw9v93VNTfDUU07C4j//OfTsCoD8fBgxAjIywOVyWvzx3r3OzI1DyciAOXOcZMYFF8D06e3PzmjY3cCyu5ex/P7lBOuCbc4VTynmjJ+dwdRPTFWCTkQGPSUwZMBQAkNEZPCpra2lsrJS9S8Ggb1r9/Ly9S9Tu6XW6SiEDJvBqZefyrxvzMOVceAshbo6uPdeuOMO2Lev/XGzs+H44+GII2DatJbjyJEHXwpSV+csN1mzxmnvvQdvvw2NjR2/ZtIkuPBC+Mxn2k9mBOuDrPjDCpbetpTGPW0HGjVnFGf98izGzh/b8Q1ERAY4JTBkwFACQ0Rk8FH9i4EvFomx8oGVrPjDCoi19JedWMacq+Yw/qjxB8y+2bcP7roLfv1rJ9Gwv9Gj4bzz4GMfg9NOc5IYyRAOwxtvwH//CwsXwjvvOAVB2zN5spPI+PznnYRJm3F8YZbdvYzXf/76ATMyJn10EmffdTZFE4uSE7SISD+iBIYMGEpgiIgMLvH6F9XV1RQVFWl6/QBUs7mGxT9eTNX6qkSfO8vNnKvmMPFjE/H7/QwbNoxhw4YBUFEBt90G993nLBtp7bDD4KtfdZIWHS3lSLa9e+HFF+GZZ5zW0eyMefOc2D7zGWeHkzhflY/Xb3mdt379VpsaGe4sN/N/NJ9535lHhjejl38KEZH0oQSGDBhKYIiIDC4+n4+KigoCgYDqXwxAH77xIQu/vZBYqGXaRdnMMk654RQKRhdgrU0kr4YNG8H997v40Y+gvr7tOJMmwfe/Dxdf3PltT3uD3w/PPw+PPQZPP31gggWgoAA+9zknmXHssS39tdtrefnHL7P6wdXQ6q3ssCOGcd5vz+Owkw7r/R9ARCQNKIEhA4YSGCIig4vqXwxc5avKee7rzxENOrMOXF4Xs78+m6P+5yiMq2XqRG1tLVu35nDjjcN5++2260COOgquu86Z1ZCRZpMU4smMv/3NKS4aiRx4zfHHww9+AB//uFM4FGD3O7t59v89y54Ve9pce+xXj+XMX5xJ9tAkrYUREUlTSmDIgKEEhojI4FJRUcG+ffvIz8/H7e5420zpX6o2VPHM/3uGcGMYcLYTPfvusxk6fmib6+rq4De/8fH885bKylLq651ZOFOmwM9/3vaDfzqrrIS//AX+8AfYsOHA80cfDT/8IXzqU04iJhaJ8dY9b7Hoh4sIN4UT1+WW5vLR+z7KtE9OO3AQEZEBQgkMGTCUwBARGTwikQjl5eXU1NRQXFyc6nAkSep21PH0V54mUB0AIKsoi/P/eD4FYwoS11jrbId6113Q2BgmL6+RfftKaWgYxo9+BN/+NmRmpuon6D5r4bXXnETGY49BIND2/NSpzoySz34W3G6o+7CO//zff1j/9Po218344gzOvvtssgqz+jB6EZG+oQSGDBhKYIiIDB7x+hfBYJCCgoJDv0DSXlNlE09f9jSN5U6lS2++l/N+dx7Fk1oSVLW1cNNN8PLL8R5LcXE1RxxRxM9+NoKJE/vBlItOqKiAX/0KfvObA2tlHH6482dw4YVOIdJ1T67juf97joZdDYlrCg8r5IK/XMC4U8f1beAiIr1MCQwZMJTAEBEZPGpqaqisrMTtdpOdrD0wJWX8NX6e/eqz1G6rBSAjM4OP3vdRhk8fnrjmjTfghhugqmVDEsrK4JvfrOWUU3IYPnz4gPtd2LcP7rzT2Q52/+Kkxx8Pv/wlnHoqBGoDPPd/z/He395rucDA3KvncsbNZ+DO0hIrERkYlMCQAUMJDBGRwUP1LwaOcFOYZy9/ln1r9wFg3IaP3PERxpwwBoBg0PkA//DDbV/3mc/AlVeCtT6stZSWlg7Y3Whqapw/gzvucGahtHbuufCLXzhFS99/9H2evfxZAjUt60+GHTmMTzz4CUYcM6JvgxYR6QWDLYExMOYVioiIDGKRSIRwOEwsFlPyop+z1vLy9S8nkhcYOP2m0xPJi40b4QtfaJu8KCpy6l9873uQnQ0ej4dQKEQwGEzBT9A3hg6FH/8YtmyBa65pW+Pjuedgxgy47DIYetKRXLHmCiZ+ZGLi/N739/KH2X9g0Y8WEQm2s92JiIikLSUwRERE+rlQKEQ4HMbj8aQ6FOmhNQ+vYdvL2xLPT/rBSUw4cwIAixbBF7/ofGiPmz8fHnkETjyxpc/tdhONRgmHw0Sj0T6KPDWGDnVmW2zYAJdc4tTAAIjF4E9/cnZguf9v+Xzmqc9z7r3n4s52EnyxSIzXbnqN3x33O3a9vSuFP4GIiHSFEhgiIiL9XDAYJBQKKYHRz1WuqWTZncsSz4/6n6OY9glnC9BnnoFrr4Vw8y6hmZnwgx84hS2Htt1NFWMMHo+HcDhMKBTqq/BT6rDD4M9/hlWr4OyzW/obG50ZGtOnG6omHM/lqy/nsJMOS5zf+/5e/jj3j7x47YtEApqNISKS7pTAEBER6edCoRCRSEQJjH4sWB/kpe+/hI06tclKjihhzpVzAGe5yI03OrMKwPmw/ve/wyc/2TLjYH+DLYERN306/Oc/8MILcMQRLf0bNsA558Bl3ynm5Acu5ey7zsaT4/z3YmOWJb9Ywm+P+S0739yZoshFRKQzlMAQERHpx1T/ov+z1vLKDa/QuKdlu9Qzf34mxu3ij3+E225ruXbyZPjjH2Hs2IOPORjqYBzMmWc6szHuuANa7yr89NNw1NGGZ/fO4YvLLm+zreq+dft44MQHeOF7L2g2hohImlICQ0REpB/T8pH+b83f17D91e2J56dcfwp5I/K5+264776W66ZPh9/+9sAlI+0ZTHUwOuLxwFVXOYVPL7uspT8YhJtugpM/VsTQq77Iub85F2+eF3BmYyz95VJ+d9zv2L18d2oCFxGRDimBISIi0o+pgGf/VvleJcvublX34nNHcdj8cdxyCzz4YMt1s2fDvfdCfn7nxh2MdTA6UlrqzFpZtgyOP76lf9s2OP8Cw0+eO55zn/s6408fnzi394O9/GGus1NJNDQ4E0AiIulICQwREZF+TAmM/itYH+TFa19M1L0YduQwZn9jDrfeCv/8Z8t1p54Kd97pbJHaFfFlJIM9gRE3eza8+Sb87nfO1rNxzz4LcxcUsHX+Fzjjzo+21MaIWl676TV+f/zvKV9VnqKoRUSkNSUwRERE+ql4/Qtrrepf9DPWWl658RWaKpoA8BZ4OePnZ/Do4y4ee6zlunPPdbYJ9Xq7fo/4DIzBWgejPS4XfPWrsH69c4wXQQ0E4IYbDF+6ZxaTfv0Nxs5vKTJS8W4Fv5/9e5b8cgk2ZlMUuYiIgBIYIiIi/ZbqX/Rf659az/ZXWupenHrjqazalM/tt7dcs2CBs/tIRkb37qE6GB0rKXFmYrzxBhx7bEv/pk1w4Zfzeab4EmZe/zHc2U5iMBaO8eL3XuSvZ/yVug/rUhS1iIgogSEiItJPaflI/1T/YT1v/OqNxPMjLzqS4PCx/OAHYJu/4J8+HW64oeNtUjtDdTAObc4ceOstp77IkCEt/f/8l+Fztx5L6IqrGD5rTKJ/28vbuH/6/ax5ZE3fBysiIkpgiIiI9FehUIhIJKIERj9io5bFP15MxO9s0zlk3BDG/89srroK/H7nmpEj4Ve/6t6ykf0N9u1UOyMjA664wllWcumlLf0+H/zkV7nc3fgl8i7+GMblZJMCtQGe+OwT/OuL/yJYrz9XEZG+pARGFxljio0xXzHG/MsYs8kY4zfG1BljXjfGfNkY0+k/U2PMNmOM7aCpWpSIiHQoXv8iFoup/kU/svJPK6l8rxIAk2E44Uen891r3VQ6XeTmwl13dW6r1M7QDIzOKy2FP/0JXnsNjj66pX/tOsN3HjqWNR/5Fp4xZYn+dx98l/tn3s/OZTtTEK2IyOBkrFUxoq4wxlwO3AfsARYDO4DhwCeBQuAJ4DO2E3+wxphtwBDgznZON1prb+thrE3Z2dk5Pp+vJ8OIiEga8vl8lJeXEwqFKCgoSHU40gl7P9jLk5c+CTHn+bFfm8XfPziGV15xnrtc8OtfO8saksVaS3V1NUVFRZSVlZHR3YIag0wk4vxdXH89NDS09JcUWz4/9R2GLPk38dU9LreL0392OvO+PS8xS0NEpK/k5OTg9/t91trcVMfSF5TA6CJjzOlALvBva22sVX8Z8BYwBvi0tfaJToy1DcBaO66XYlUCQ0RkgKqpqaGyshK32012V/fXlD4X9of51+f/Rd0OpwDk8BnD2T7jY/zlry0feK+7Dj7xieTfu66ujuzsbIYPH67flS7avRuuvhoefbRt/7zpDZy49SFyGyoTfYeffTgX/OUCcksHxWcIEUkTgy2BoSUkXWStXWStfaZ18qK5vxy4v/npqX0emIiIDCqqf9G/LLtrWSJ54c5xk/3xM9skLy6+uHeSF6A6GD0xciQ88gg88wyMaanlydJ387knfDnvHXYO0ea5GJue38T9M+5ny0tbUhStiMjApwRGcoWbj5EuvCbTGHOxMeYHxphvGmNOM8ZofqeIiHRI9S/6lw+XfMjax9cmnk/96nx+fndO4vm8eXDllb13f9XB6LnzzoMPPoCrrnKW+gD4A4Yndszm0RHfpJJhADSWN/LgWQ+y6IeLiEViHQ8oIiLdoiUkSWKMcQMrgaOAs621/+3Ea7YBY9s5tRX4krX2lR7GpCUkIiIDkOpf9B+BugCPX/g4/ipni5Ex88fxeP2ZrFrlfGtfWgp//3vbLTyTzVpLVVUVxcXFqoORBG+/DV/9Kqxe3dLn8VjO8L7O8U2LycB5bz1qzig++dAnKTq8KEWRishgoCUk0l0/x0lePNeZ5EWzPwFnAGU4dTWOBn4LjAP+Y4yZ0ZlBjDHvtNeArK7+ECIikv6CwSDhcFjLR/qBpb9cmkheZBVlsX70qYnkhcsFN9/cu8kLAGOMZmEk0fHHw/LlcMstLVvdhsOG55tO5sH8r1PRPBtj17Jd3D/zflb8cQX6wlBEJDmUwEgCY8yVwLeBdcAXOvs6a+2NzTU1Kqy1PmvtGmvt5cDtQDZwQ68ELCIi/ZrqX/QPWxdtZfN/NyeeF3xmAQ/9o+Xv7PLL4Zhj+iaWeB0MJTCSw+2Ga6+FlSth9uyW/m0Nxfw+43Jec80niotwU5hnvvIMj37qUXz7NCNWRKSntISkh4wxXwfuAT4Azmgu5tnTMQ8HNgLV1triHoyjJSQiIgNMJBKhvLycmpoaiou7/b8I6WX+Gj+PX/g4gZoAAMPPOJJfr5hHTY1zfs4cuOceMH2062Y4HKaxsZFhw4ZRWlraNzcdJCIRuP12+PGPoXWd1FGZ+zg3+C9GsRuAvLI8zv/z+Rz+kcNTFKmIDERaQiKdZoy5Cid5sQY4LRnJi2bxPbkGxS+hiIh0XigU0vKRNGet5fVbXk8kL7KG5fJs9dxE8qK4GH76075LXgC43W6i0SjhcJhoNNp3Nx4E3G645hpnNsacOS39u4Il/NF8hef5CEE8NJY38rez/8azX3uWYIN2hBER6Q4lMLrJGPM94A5gFU7yovLgr+iSE5qP2odLRETaCAaDhEIhJTDS2JYXt7Bt0bbE84rjP8qKlc5bLmOcuhdFfVzXUXUwet+0abBkCdx2G2RnO30xa3iTudzv+jobmQjAO/e/w31H3cfmhZsPMpqIiLRHCYxuMMb8CKdo5zs4y0b2HeRajzFmqjFm4n79RxpjDnj7YowZizOrA+ChJIYtIiIDgOpfpDd/lZ8ltyxJPPfOn8Wjzxcmnn/1qzBrVioi03aqfSEjA779bVizBs46q6W/JlbI37iYJ/gEjeRQt6OOhz7yEE9/5WkCdYHUBSwi0s+oBkYXGWMuAf4MRIFfA3XtXLbNWvvn5uvH4WyLut1aO67VODcA1wKLm883ABOBj+LsHvIc8AlrbbffZagGhojIwKL6F+nNWssL33mB7a9sB8BTOoR/uj/N7t3OWpFjj4X773d2H0kF1cHoW9bCgw/C1VdDdXVLf7YJcJpdxCyW48KSPyqfj/3uY0w6d1LqghWRfmuw1cBwpzqAfmh88zEDuKqDa17BSXIczGJgCnAMzpKRXKAWeB14EHjQKrskIiKtqP5Fetv0n02J5AXAusPPZfdSJ3mRl+fUvUhV8gIOrIORkZGRumAGAWPgi1+Ec85xkhh/+5vT77dZPMe5rOAYzuU5Dtu1k79/9O8c/bmjOevWs8gfmZ/awEVE0phmYAxgmoEhIjKw1NTUUFlZidvtJju+yF7Sgr/Kz6OffpRQgzNxMjzvJB5YOi1x/qab4OyzUxVdi7q6OrKzsxk+fLh+h/rYf/8L//d/sGlT2/6ZrORMXiQPH948L6fccApzrpxDhkcJJhE5tME2A0M1MERERPoJ1b9IX2/e8WYieeEqG8Y/35+aOLdgQXokL0B1MFLpIx+B995zklmtc0erOIZ7+D/eZDb+xggvfOcFfjvzt2xdvDV1wYqIpCklMERERPqBSCRCOBwmFovhdmsFaDrZ9fYuNj3vfK1ugWVFZ1Nb5ywdKS2F738/hcHtx+PxEAqFlMBIkawsuO46WLsWPvGJlv4A2TzPOdzLFaxlCpUf7OWvp/+Vxz/7OPU761MXsIhImlECQ0REpB9Q/Yv0FA1H2+w6sveI+az4ICvx/MYbIT+NShrE62CEQiFisViqwxm0xo6Ff/4TnnsODj+8pb+aYh7hs/yZS9jFCN5/5H3umXoPS25dQjQUTV3AIiJpQgkMERGRfiD+rbkSGOll9V9WU7fD2ZCsMaeE5zZNTpz73Ofg+ONTFVn7jDG43W7C4TDBYDDV4Qx655zjbLl6221Q2LLbLtsZx+/5fzzBJ9jblMOL17zI/TPvZ+siLSsRkcFNCQwREZF+IBgMqv5Fmqn/sJ6VD6wEIIphacHZBEPO0pGJE52CjenI6/WqDkYaycyEb38bNm+Gb34TWq8Qe4/p/Jr/4wXOYOfaBv56xl954n+eoH6XlpWISHIZY0YbYx4wxuw2xgSNMduMMXcaY4Z2Y6yTjTFPGGP2NI+1xxiz0Bhzbo/j1C4kA5d2IRERGRgikQjl5eXU1NRQXFyc6nAEsNby/DeeZ+ebOwFYN+wkXtnr7Dri8cBf/wqTJqUywo6Fw2EaGxspLS1l2LBhSRvXWksoFCIQCOD3+wkEAoTDYdxuNx6PB4/Hg9frTRy9Xm/S7j2QbNwI3/se/OtfbftzaOIUXmUWy8nOc2u3EhEBkrMLiTFmIrAUKAWeAtYBs4HTgPXAidbaqk6O9UPgp8A+4FlgD1ACHAMsttZe0904AVQFTEREJM2p/kX62fri1kTyosoUsaS6ZdeRyy9P3+QFOHUwYrFYog6Gy3XoCbn79u3j3XffZfv27ezevZtdu3axe/fuRKuuriYQCNCVL8ZycnIoKiqiqKiI4uLixLGsrIyRI0e2aaWlpWRkDI4P6pMmOfUxXnvNmZnx9ttOv49c/sM5LGM2ZzW+SPA7L7DqT6s4995zGXfKuJTGLCL93m9wkhdXWmt/He80xtwOXA3cDFx+qEGMMZ/BSV68CHzSWtuw3/kev5HRDIwBTDMwREQGhtraWioqKnC73WS33n9RUiLcFOaRTz2Cf5+fKIbnh36WnTV5ABx1FDzwAHQiJ5BStbW15OTkUFZWRlZWS9FRay2bNm1i5cqVrF69mtWrV7Nq1Sp27dqVwmghIyOD0aNHM2nSJA4//HAmTZqUaBMmTBiwszliMXj0Ubj2Wti+ve25w9jOWbzAGHYx/eLpnHXrWeSV5aUmUBFJmZ7OwDDGTAA2A9uAidbaWKtz+TgzKAxQaq1tOsg4LmATMBwYZ63d2514DhmvEhgDlxIYIiIDQ0VFBfv27SM/P19bqKaBpbct5f2H3wfg3ZzZvOGbAYDXC3//O4wbl8LgOsnn82GtZdiwYezevZtXXnkl0crLy7s9rsfjISsri+zsbLKysvB4PIktgOMzieIFRKPR5Oyq4Xa7mTJlCtOnT2f69OkcffTRTJ8+ndGjR2OMSco9Ui0QgHvugZtvhtratueO4H3OYBEjC5o47abTOP5rx+Nyp3kGTUSSJgkJjK8Avwd+Z63933bO/xdYAJxprX3pIOOcBLwGPA78D/AR4CggALxlrX2jO/HtT++CRERE0lg0GiUcDhOLxZS8SANVG6p4/1EnebGPIt4KTE+c+9rX+kfyora2lldeeYXly5ezZMkS1q9ff8jXZGVlcdRRRzFlyhRGjRp1wBKPYcOGkZWV1enfUWstjY2NVFVVUV1dTXV1NVVVVVRVVbFnz57E0pT4UpWqqo6XXkciEd5//33ef/99/vGPfyT6hw4dyjHHHMOxxx6baJMmTerUkpl0k5UF3/kOfOlLcNNNcO+9EA475z7gSNYxlePq36HqyldY+ceVnPnzM5n4kYkDJoEjIoeUZYx5p70T1trjDvHaKc3HDR2c34iTwJgMdJjAAOL7blUAK4CjW580xrwKfLqnMzP0TkhERCSNBYNB1b9II2/d/RbEnF1HluScRdTnfECcPh0+//kUB3cQu3bt4pVXXuHll19m1apVxGIxiouLaWhowOVyEYslZgwzZMgQZs+ezcyZM5k5cyYzZsxg8uTJSU2gGWPIz88nPz+fcZ3I+gQCAbZu3crGjRvZtGlTm+P2/ddWNKupqWHRokUsWrQo0ZeXl8fMmTOZPXs2c+bMYe7cuYwZM6bffNAvLoY77nB2uLnuOnjkEac/RgZvM5vVzODE1UvZfs5jTD6pjNNvPp2x88emNmgRSXfxTZzrOjgf7x9yiHFKm4+XA1uBM4FlwFjgVzgzMh4DTu1mnICWkAxoWkIiItL/1dbWUllZicvlIicnJ9XhDGq73trFc1c8B8BycyzvNH+p5fXCP/4BY9Psc+KePXt47rnneOGFF9i0adMB5wsLC/H7/QSDQebOncupp57KKaecwtFHH92vCmY2NDTw/vvv8+677ybae++9R+3+ay06UFZWxpw5c5gzZw4nnXQSxx9/fJu6IOnsrbfgu9+FV19t25+Fn7ksYw7LOPKskZx+0+mMmj0qNUGKSK9KwhKS3wFfBb5qrf1DO+d/Bnwf+L619ucHGeeXwHeBGHCstXZ1q3PZODM8RgPzerKcJGmpdOOkrs8EzgLmA4fhbJfiByqBVcAi4GlrbWorQYmIiPQT8RkY+fn5qQ5lULPWsuyuZQDspYiVHJs4d8UV6ZO88Pv9vPTSSzz77LMsX7683WuMMUyfPp1TTjmF4447jlmzZjF06NA+jjR58vPzmTt3LnPnzk30WWvZsWMH77zzDitWrGDFihW88847VFZWHvD68vJynnrqKZ566ikAMjMzmTNnDqeccgrz58/nhBNOIDe327sT9qrZs+Hll+Hf/4ZrroG1a53+ANm8zKm8wVxmv/AWa174G8d8/DDm/2g+I2eNTGnMIpJ24jMsCjs4X7DfdR2paT5uaZ28ALDW+ptraXwZZ3vW1CUwjDE5wJXA/+IkLeJz8AI4iYtsYAIwEfgUcJcx5hngV9bapT29v4iIyEDVuv5Ff/pGfCDavHAzVeuriGB4xZxGzLYsHfnc51Ibm7WWFStW8NRTT7Fo0SICgcAB13i9XubMmcOpp57KySefTFFREaFQCJ/PRyQSSUHUvcsYw9ixYxk7diyf/OQnAefPac+ePbz99tssW7aMZcuW8fbbb9PQ0GaXP4LBIK+++iqvNk9rcLvdzJ49m7POOoszzzyTOXPmpNWSLmPgvPPg7LPhwQedQp+bNzvngmTxGvN5k7kc//TbLH/6H8xcMJyTvn8SY08Z22+WzohIr4oXQprcwfn4xuAd1cjYf5zaDs7HExw92k6tR0tIjDFfAm4CRgDrgIeBJcDb1tr6VtcZnOIgc3HWvpwPZOJUKP2utXZHt4OQDmkJiYhI/+bz+aioqCAQCFBY2NEXI9LbouEoj37qURp3N7KSGbzFbMBZOvLww3DYYamJy+/38+9//5tHH32ULVu2HHDe5XIxZ84czjvvPObPn3/AFrzWWqqrqykqKmLEiBH9srhlT0WjUdauXcuyZct44403ePXVV9m4ceNBX5OXl8epp57KmWeeyVlnncW0adPSKhEQiTi/lzffDOvWtT2XQYTpvMs8lnLMCdmc9P2TmHze5LSKX0S6JglLSCbibH+6jY63UXUBww6xjWpJ87VNOFuuhvY7/x/gbOB/rLUPdydW6HkCIwY8CdxirX27C68rAC4BrgV+a639SbeDkA4pgSEi0r+p/kV6eO8f7/Hmr96knjwe4zNEmiewXnUVXHxx38ezfft2Hn30UZ599lmamg58LzlhwgTOO+88zjnnHIYNG3bQsWpra8nNzWX48OH9pu5Db9uzZw+vvfYar7zyCq+++ipr1qw56PWjRo1iwYIFLFiwgDPPPJOSkpI+ivTgolF44gn46U+hvR9hCus4kaXMOjrISdeexJEXHqntV0X6oZ4mMKDNVqlXWmt/3ar/duBqnM/slzf3eXBWV4SttZv3G+ch4PPAzdbaH7bqPwv4L1APjLPW1nY71h4mMI611q7oweuzcH6AdYe8WLpMCQwRkf6tsrKSvXv3kp+fry1UUyTUGOLh8x8mWBfkPyxgB06xi8mTnen6fbmyZ/Xq1fz+97/nzTffPOBcdnY25557LhdccAFTp07t9Dfq8QRIaWmpZvl0YO/evSxevJgXXniBF154ocNdT8BZunLcccexYMECzjrrLObNm4fX6+3DaA8Ui8HTT8MvfgHt/Oowmg+ZxxvMHVvOSdecwMwvzcSTnT5LZETk4JKUwJgILMXZSeQpYC0wBzgNZ+nIPGttVfO143B2GdlurR233zilOCsyDgdeA97C2YXkE4AFPmetfay7cYJ2IRnQlMAQEem/otEo5eXliSn+muKdGm//5m1WPbCKrYxlIQsAp+bAAw/A0Ucf4sVJ8t577/Hb3/623cTF2LFjufDCC/noRz9KXl5el8eO18EYNmzYIWdriLPsZsuWLYlkxksvvURdXcd17XJycjj11FM566yzOOusszjiiCNS9t+ytbBkCfzyl/DMMweeH0INc3iLE4vXceq3juX4K44na4hm5Yiku2QkMACMMWOAn+As8yjGWQ7yJHCjtba61XXj6CCB0Xy+CPghTtJiFNAAvI6zaqOdNGoX41QCY+BSAkNEpP9S/YvU8+318fAFDxMIGh7l0zTi7ATzyU/CD37Q+/f/4IMPuP/++1m6tG3Nc5fLxfz587nwwgs5/vjje/SBWHUweiYSibB8+XL++9//snDhQpYtW0Y0Gu3w+pEjR3LmmWdy5plncsYZZzByZGp2BFm7Fm67DR580BIOt/398RLkGFZycs5Kzrx8AnOunMOQsUNSEqeIHFqyEhj9RdITGMaY0TjrZGbi7PPa3hw0a62dmNQbywGUwBAR6b9U/yL1Xrv5Ndb9ax1vMpvVzABg6FCnrkBBwSFe3ANbt27l7rvv5rXXXmvT73K5OPfcc/nyl7/MmDFjknY/1cFIntraWhYtWpSYobF58+aDXn/kkUcmEhrz58+noDd/sdqxezfcey/cf7+lurptIsMQYzIbON71Dh/7dCYnfvsERs0e1afxicihKYHRk8GMORV4DsgCIkBF8/EA1trxSbuxtEsJDBGR/kv1L1Krdlstj134GFWxIfyTTxHDmZlwww3OlpW9we/38/vf/56//e1vbb7Fd7lcnH322XzlK1/hsF7Y8kR1MHrP/stNamtrO7w2IyOD2bNnc8YZZ3DGGWdwwgknkJmZ2Sdx+nzw0ENw5x2WtesOnNEzlGqO4x3Om13Jgu8dy5Tzp+DK0GwdkXSgBEZPBjPmLWAG8GXg7623YJG+pwSGiEj/pPoXqffCd15g68vbeJrzKGcEAMceC7/9rVMDI5mstbz00kvcfvvtVFZWJvqNMSxYsICvfvWrjBs3Lrk3bUV1MPpGJBJhxYoVvPjii7z44ossWbKEUCjU4fXZ2dmcdNJJnHHGGZx55pnMnDmTjF6uGhuLwQsvwB23W/678MBf9AwiHMEHnFK6jk9+rZRjLzuGwsOU9BJJJSUwejKYMX7gEWvtpUkbVLpNCQwRkf7J7/dTXl6u+hcpUr66nGe+/AzrmMQrnAo4u4384x8wYUJy77Vt2zZ++ctf8tZbb7XpnzlzJt/73veYNGlScm/YDtXBSA2fz8frr7+eSGisWrWKg70vHzp0KKeffnoioXH44Yf3anJzwwa4/3740x9j1NYf+DsxlGpmsJrz59ex4BuTmfLxKWR4+3BbHhEBlMDo2WDG7AYettZ+K2mDSrcpgSEi0j+p/kXqWGt5+stPs/3dOh7lMwTIBuCSS+Ab30jefSKRCA888AAPPPAAkUjLatuioiKuuuoqzjnnnD6deaM6GKm3b98+Fi9ezEsvvcRLL73Epk2bDnr9mDFjOP300xNt9OjRvRKX3w+PPAL33B3lnZXtJyjGso3Z+Wv5ny96mHvZkZQdU6aZYyJ9RAmMngxmzO+A46y1xyVtUOk2JTBERPqneP2LvLw8PJ72amFLb9m6eCsvfvdFXuUk1jINgBEj4NFHITs7OffYsmULP/7xj1m3bl2iz+VyceGFF/K///u/5OfnJ+dGXRCvgzF8+PA+LyQp7duxY0cimfHiiy9SUVFx0OsnTZrE6aefzmmnncapp57K8OHDkx7TihVw/30xHv67pcF3YDLDTZjJbGDeqB1c+OV8Zl1yJEMnDE16HCLSQgmMngxmTAnwJvBf4BprbVPSBpcuUwJDRKT/ide/qKqqori4WN9i9iEbtTx24WNs2u7hn1wAOH/2v/oVnHJKz8ePxWL8/e9/5ze/+U2b2gfTp0/n+9//fp8sF+mI6mCkN2st77//fiKZ8corr9DQ0HDQ10ydOpVTTz2VU089lVNOOYWysrKkxeP3w9NPwx/uD7PoFTcxe+C/U16CTGUdp04p58LLi5h+4VTyR/Z9ck5koFMCo6cDGnM4sAzwAhuAunYus9baM5J6YzmAEhgiIv2P3++noqICv9+v+hd9bO0/1/Lqz17nKT5OJc631yeeCHfe2fPCnbt27eKGG25g5cqViT6Px8MVV1zB5z//+ZTXnVAdjP4lHA7zzjvvsGjRIhYtWsSSJUsIBAIHfc2UKVM45ZRTmD9/PvPnz0/aVry7d8NDD8b44/1hNmxrf9eULPxMYT0nT93Hp76UzzGfnarinyJJogRGTwYz5khgMVByiEuttVZVfnqZEhgiIv2P6l+kRtgf5pELHmFl1ehE4U6Px1k60pPPedZann76aW677Tb8fn+if+rUqfzkJz9hQrKrgvaA6mD0X4FAgDfffJNFixbx8ssvs2zZsoPucAIwbtw4Tj75ZObPn89JJ53ElClTejzja80a+PuDUf72lwg7KtpPZngIcTibOHFCBZ/+YjazPjeJ4knFPbqvyGCmBEZPBjPmv8CZwPXAX4Dd1trowV8lvUUJDBGR/kf1L1JjxR9WsOT+d3mUi/A3F+687DK44oruj9nY2MjPfvYzFi5cmOhzuVx8+ctf5stf/jJut7unYSeV6mAMHH6/nzfffJOXX36Zl19+mTfffPOQCY2SkhLmzZvHSSedxIknnshxxx1HZmb7SYhDsRZWroQH/xTm4b/HKK9ufxwXUcaynWPLdvPxT2Rw5mVjGXHcCC2dE+kCJTB6Mpgx9cB/rbWfSdqg0m1KYIiI9C+qf5Ea/ho/D5//MK/4ZrGGowEoLYUnnuh+4c41a9bwgx/8gN27dyf6xo4dy09/+lOOOOKIZISddKqDMXD5/X7eeustXn31VV599VWWLl3Kod4fZmZmMmvWLE444YREGzFiRJfvbS0sXw6P/i3EY4/E2F7e8eyeIqo4Om8bC86IcP6Xi5ly1jjcWemV6BNJN0pg9GQwY/YBf7LWfjdpg0q3KYEhItK/qP5Faiz55RJee3QPT/ApbHPhzp//HM48s+tjWWt56KGHuOeee4hGWyahfvKTn+Rb3/pWWi/NUB2MwSMcDrNixYo2CY3q6upDvm7cuHGccMIJzJ07lzlz5jBz5swuz9JYuxYe+VuYRx8Ks3Z7x8vkPIQY79rBnCl1nPtJDwu+NIaiidrRRGR/SmD0ZDBjHgeGWWuTUKtbekoJDBGR/kX1L/pe/Yf1PPKpR3k69lH24Hy7fPzx8JvfdL1wZ3V1Nddffz1vvPFGoi83N5cf/ehHnNmdbEgKqA7G4BSLxVi/fj2vv/46S5Ys4fXXX2fz5s2HfJ3H42HmzJnMnj2bOXPmcPzxxzN58uROJ7927oSn/xXh8Qf9LF2ZTTDS8WyLfOo5omAXJ80OcvYns5n7yVHkDc/r9M8oMlApgdGTwYyZgLMDya+AX9hkb3EiXaIEhohI/6L6F31v0Q8W8fxCyyKczdEyMiwPP2wYP75r47z99tv88Ic/pKqqKtF31FFH8bOf/YyRI0cmM+Re1dTUhDGG0tJS1cEY5CoqKnjjjTcS7e233z7kTicAeXl5HHPMMRx33HEcd9xxzJo1q1NJjUAAXnoxyqN/bGThYg/ldQdP4g6hhikF5cw9JshHLshi3qdHUjhav7My+CiB0ZPBjHkAGA/MB7YBq+h4G9UvJ+3G0i4lMERE+o94/Yv4FH7Vv+h9NVtq+PuFT/IIF+LDed938cVw1VWdHyMajfLb3/6WP/3pT8TfUxljuOSSS7j88svTrlDnoagOhnQkFAqxevVq3njjDd566y2WLVvGpk2bOvXa3NxcZsyYwTHHHMPMmTM55phjOOqoow66/GTLFnjq7008/XiQt97PwxfxHvQe+dQzIaeCmVP9nHKGhzM/W8zomcMwLv1bKgObEhg9GcyYWCcv1TaqfUAJDBGR/sPv91NeXk4gEFD9iz7y4rUv8vCLJaxiJgDFxfDPf0JuJ98CVlRUcN1117Fq1apEX1FRET/96U+ZM2dO8gPuA6qDIV1RVVXF8uXLWbZsGcuWLeOdd96hoqKiU691u91MmzaNGTNmMH369EQrKys7IIEbicAbr0f455/qefVVWLOjgFDs4MnBDCKMyqjgyDH1zDrOcsq5Ocz9eCm5JVqeJwOLEhg9GcyYsZ291lq7PWk3lnYpgSEi0n+o/kXfqt5YzZ//5788zIXEcL5T+clP4NxzO/f6V199lRtuuIH6+vpE3+zZs/npT39KcXFxb4TcZ1QHQ7rLWsvu3bt55513Em358uWdTmoAFBcXM336dI466iiOPPLIRBs6tKWAZygEby6J8Mzf63llMby3LZ9A9NDL7rLxMTZ7L0dO8DN7ruGUc/OYedYwMvMPPrtDJJ0pgSEDhhIYIiL9R7z+RX5+fr9bdtAfvXDNC/xx0Tg2MQmAI4+EP//50IU7w+Ewv/71r/n73/+e6HO5XHzta1/j0ksvHRBLf1QHQ5Jtz549rFy5kpUrV7Jq1SpWrlzZqSKhrY0cOZIjjzySI444gmnTpiXasGHDiERg9cooCx9v4NVFYVauzaKiKb9T4+bQxNjcfUwbG+DY4+Ckj+Qw6yMl5JZ0cw9lkT6mBEZXBzDmTuCfwGsq2plelMAQEekfVP+ib1VtqOL+z73Kv/hEou/3v4djjjn46/bt28e1117bZslIaWkpP/vZz5g5c2bvBJsCqoMhfaGuro53332X9957j3fffTfxuLGxsUvjFBcXM3XqVKZOncqUKVOYPHkyU6ZMITd3PK8+F+KV//h4Z6WLdbvy8UU7N6PIS5CR3iomlDVx5NQYx53g4aRzCxl/7FBcbi2rkvSiBEZXBzAmAhigCngaJ5nxorU21PPwpCeUwBAR6R98Ph8VFRWqf9FH/vuthdzz6tGJbVNPOw1uvfXgr3n33Xe55ppr2LdvX6Jv/vz5XH/99QPu70x1MCRVYrEY27dv59133+X9999PtLVr1xIKde2jRUZGBuPHj2fSpElMmjSJiRMPJytzPLvWDmfdyuGsWZ/Dlr0FBGKdXz6STz2j8uqYMDLIlCkxjjney+wz8zl81hAyPCrvJ6mhBEZXBzCmFLgA+ARwGuABmoDngH8Bz1lrG3oWpnSHEhgiIv2D6l/0nb1r93LnF1bwXz4CONumPvaY4bDD2r/eWsvjjz/Or371KyKRCOAsGfm///s/vvCFLwzY2TKqgyHpJBKJsHnz5kQyI97WrVtHd97nZmRkMHbsWMaPn0DRkHGE6kdSUzGK8t3j2Vl9FL7YiC6Nl4OPsuw6xgwLcPj4CEcc7WbmvGyOPa2QIWVaiiK9SwmMngxmTAFwHk4y4yNAHhAEXsJJZjxtrd2btBvKQSmBISLSP6j+Rd957psL+dWS2dQxBIALL4Rrrmn/2mAwyC233MKzzz6b6CssLOSWW25h9uzZfRBt6jQ1NQHOEpmBNsNEBo5YLMbOnTtZu3YtGzZsYP369Ynjjh07uj1uQUEhQwvG4GYUYf9oGhonUBecQowJwGFAEc4E9EOxDHHVU5bXyJjSEOPHRZl6pJsjj8vi6BPyKJuYO2CToNJ3lMBI1sDGZOIkMT6Bk9QoBqLAUpxlJk9qJ5LepQSGiEj6U/2LvrP3g73c/MX1vM5JAOTkWJ56ytBqc4OE8vJyvvOd77Bu3bpE39SpU7n11lsZMaJr3872R6qDIf2dz+dj06ZNbNq0iY0bNyYeb9q0iZ07d/ZobHdGNt6MUdjoGILR8cQYB4wGxrQ6HvqzZA4+SrIaKBsSYMyICOPHwYQpbqbMyGLa8bmUTVCCQw5NCYzeuIkxLuAU4JPA+Tj/ZVtglbX2uF4PYJBSAkNEJP2p/kXf+dcVL/Crt04igDOl+xvfgEsuOfC69957j29/+9tUV1cn+j72sY9x7bXXkpmZ2VfhppTqYMhA5vf72bJlC1u3bmXLli0HNL/f3+N7GAqxjAFGASObj60fjwBKgY5n3WXhpzizkdL8AGUlEUaPshw23jB+sofJ07OZclweBSWD498k6ZgSGH1xU2Nm4SQzLrDWHtHnAQwSSmCIiKQ/1b/oG5XvVXLdl3axEmerkdLiGP962sX++Yh///vf3HTTTYTDYcBZK//d736XT33qU4Pum9Da2lpycnIoKytTHQwZNKy17N27l23btrFt2za2bt2aeLxjxw62b9+eWGLVcy6cJMaIVq2suQ3f73E+7S1byTVNDPX6KM4LUjo0TNlwy+gxhsMmuBlzuIcJR2Qz/shcsvK0PHGgUgKjqwMY83HgWWttLDkhSbIogSEikv5U/6JvPPz/FnPHipOJNn/b+dOfwjnntJyPxWLcc889/PWvf030DRkyhFtvvZVjDrW/6gDl8/mw1qoOhkgr1lpqa2vZsWNHon344Yfs3Lkzcdy5c2eXd005tCycREbpfsdhHbTWSUdLnmmi0BugKC9IcUGEYcUxyspgxGgXo8a6GTspk8OmZDHq8Gy8WdpRpT8ZbAmMZLxTehLYZYz5E/BH1bUQERHpnGg0SigUIhaLkZGhN4y9pXx1OU+vGJVIXkyaEOXss1v+vH0+H9dddx2vvfZaom/ixInccccdjBw5ss/jTRdutxufz9cLH8RE+i9jDEOHDmXo0KHMmDGj3Wviszh27drVpu3evTtx3LNnD3v3dmVvgwCwvbl1Rh5QkmiNtoTG4DB2BYuhqhi2FuOUKCzGKUqaC2RjiJFjmijwBCjMDjE0P0xRYYyS4hglwwxlIzMoG+1mxFgPI8dnMmpiFvlFnkE3Q01SJxkzMF4ATseZ0xQDXgB+h7PjSLTHEUq3aQaGiEh6i9e/CAaDFBQUpDqcAeuPl7zGfe+fRHz69f33w6xZzrk9e/Zw1VVXsXnz5sT18+fP56abbhr0S3pUB0Okd4VCISoqKtizZ0+iVVRUUF5enmjx84FAoA8iysRJZrRuQw/RhuAmh7wMyPMEKcgKU5gXoTA/xtAhlqIiKBlmKBmewbAyN6WjPJSO8TBibBZDhntxuZT46CnNwOgia+1ZxpixwFeAS3F2HlkAVLSalbGlp/cREREZaEKhEOFwWEtHetGeFXt45v1xxJMXc48LM2uWB4A1a9bwrW99q02xzksuuYSvf/3r+rCO801zRkYG4XCYYDBIdnZ2qkMSGVC8Xi9jxoxhzJgxB73OWktjYyOVlZVUVlZSUVGROO7du5e9e/cmliPu3buXffv2EYlEuhFRENjT3DovAtRGM6mNDoHAEKgtBOJtSKvH8VYAFOIihyyyyXFnkufNIj/LTX5ujIK8GIUFliFDYMgQGFqcwdASFyXD3RSXuSkZ6aF0VCZDy7y4Pfq3erBJahHP5t1GzgW+CpyDkyCJAYtwZmU8aa3tzn9N0g2agSEikt4qKirYt2+f6l/0Emstd312GQ9tnguAy1gefsQwYQIsXryY6667LrE8wuPx8MMf/pCPfvSjqQw57agOhkj/Y62lrq6Offv2tWl79+6lqqqq3VZdXZ0Gy8XcOMmN/OZj/HFHLRc3WWSaLLIyssjxZJKTmU1edjYFuVkU5rnJy4OCAigcYvj4xYXMPaedfbP7Oc3A6IHmQp7PAs8aY8qAy5rbmcAZwD5jzJ+BP1hrNybz3iIiIv1JNBolHA4Ti8WUvOglu97ew3ObJyWen31WhPHj3Tz00N+46667iH+JU1hYyO23397hevbBzOPx0NjYSDAQAK8XAgGnBYMtLRCAUAjCYae1fhyJOC0abTnGH1sLsdiBx7j2vmQz5sDmckFGRttj/HG8ud1tH7duHk/bx16v01o/bt00O0fSnDGGIUOGMGTIEA4//PBOvcZai9/vp7q6+oBWW1tLTU3NAa22tjZxLr5zU89EgOrm1vlXRCw0RaAqAviB2vhZD04tEKdt3vNNHjnnf5MQp6RSr71jstaWAz8DfmaMOQNnickFwHeAb/fmvUVERNJdMBgkHA7j8XhSHcqAZK3lzz+voLp521RvRpQrrnTxi1/8gscffzxx3ZgxY7j77rsPOYW737HWSSw0NDitsRGampzW2Njy3OdraX5/y9Hvh0AAdyBANCeH8J49RPfsISOmTedwuyEz00lmZGYe+LgzLSur/ccdnWt9bP3Y63WSOCI9ZIwhJyeHnJwcRo8e3aXXxpMf8WRGXV3dAa22tpb6+nrq6uoSx9qaOqqr66ivq6PJ30gkkuwZIGGgprmBNzuY5PElFfoqifAKThWY8cDsPrqniIhI2orXv1ACo3dsW7KbF3a0zL741AX13HLLDSxZsiTRN2PGDH71q18xZMiQFETYSdY6SYWaGqfV1jqtvh7q6pxj6xZPWDQ0ODMdesgAnmiUsNtNyOslu08KCaa5+KySpqZUR+LoKNHR3vFQ59p73lHf/k3JlEGrdfKjJzs3BYNBGhoaqK+vT7SGhoYOW319I9X76qiprqe+roGGxkb8/iYCwSYCoSb2309i8pEDb/nIYNSrCQxjzBScmRdfxNnDxwBbgT/25n1FRETSXXwGRlZWVqpDGXCstdz381qaGAVAjnc3y9/9Dhs3bkhcs2DBAm644Qa8Xm9qggwGYe9ep+3bB1VVLS3+PJ60SMrU7O7zhMOEPB5CeXlkd/ShtvWyi/jSi9ZLM/ZfwhFf4hFfAtL62PpDcOvH1rbfYjGnRaMHHlsvWdn/ceslLpFIy7KX1stgQqGWFgw6x3QTX8qTDjqamdKZ4/6PO9s6WvbT+vew9dHtVqIlTWVmZpKZmUlJSUmPx7LWEgqFaGxspLGxkaamJkaNGpWEKCXVkp7AMMZkARfiJC5OxElahIF/Ar+31i5M9j1TwRgzGvgJcDbOBsp7gCeBG621NX09joiI9B+RSET1L3rRBy/u4vXy+OyLLWR4v8HGjRWJ85dddhlf+9rXML3xIcZaZ3lGRQVUVjrH+OPKypakRX198u+9v8xMyM93Wl4e5OYeeMzNhZwcyM4+8Ni8XMHjdtMYDhMcPhxKS3s/7nRmbUtio3UdkJ629uqK7H9s73GKk1sHiMff0JDqSA6udb2TeNKtqy0+RkePO3Nsrw5LV9v+dV1aJwkHMWNMIiFSXFyc6nAkiZL2rskYMxNn95HP4ZSMNcBm4A/An6y1lcm6V6oZYyYCS4FS4ClgHc7SmG8CZxtjTrTWVvXVOCIi0r+EQiFCoZCWj/QCay333hoghBd4B8O3aWhsBMDlcnHddddx/vnnd/8GPh/s2dOSmNi/VVY69SOSKSureS/BoU4bMgQKC5tL67c6xsvtFxQ4j5P0++W2lmhVFeFwmGg0SkZGRlLG7ZeMafmGPy8v1dE4M01aJz1aJ0L2T3i0d66zjzvT0i2ZcjDxWTfJ/m81nRjTcXKjvcK2HfXt/7i954dq+1+/f5Hdg7X9r239vL3HB+s77DDn31Dp13qcwDDG/C9O4uIYnKRFCHgM+J21dlFPx09Tv8FJOlxprf11vNMYcztwNXAzcHkfjiMiIv2ICnj2nuVP7WZ59QTgeeBGLM6HqpycHH7xi19wwgkndPxia536Env2OG33budYXu60PXuS981yRgYMG9bSiotbWkkJFBU5behQJ4GRQsYYPB4P4XCYUChEdnZ2SuORVlwuZ7ZMOvydxGJtZ6bsP0tl/6U4rRMf+5+P97dewhM/13qZT0f9+59vfS4JtWH6BWtbEjXieOgh+PznUx2F9JCx7W1R1ZUBjImXo94A/B74i7V2X08DS1fGmAk4M0u2ARObt46Nn8vHWQJigFJrbYfVnZI1ziFibcrOzs7x+XzdebmIiPSS8vJy9u3bR0FBgZaQJJG1lktO38kHDS8B9yT6S0pKuOuuu5gyebKzdGP37rZt166WpEUyilRmZcHw4S2ttLSlDRvmHIcO7Vfr8H0+H7FYjNLS0vQueipyKLGY86G+dWJj//on+9dEad3aOxfvO9jxUH3xx/E6Le31x8+1d/3+5+RA//gHfPazqY4i6XJycvD7/T5rbW6qY+kLyXjX9A+c2RavJGGs/uD05uPC1kkHAGttgzFmCbAAmAu81AfjiIhIPxIOhwmHw1hrlbxIsv/+eSdbGv7CBJ5kFDASOKKggDMmTiTrhhucREVPk/peL5SVtU1QlJU5SYn487y8fpWc6AyPx0NjYyOhdCxiKdIVLlfLMqCBLJ6oaS+5cbDitvv3tX7eUWHcg7X2rtu/yO7BWutru/K4vYK+Sr4OCD1+52StHWzzcKY0Hzd0cH4jTuJhMgdPPCRrHBER6Ue0fWoPBYMtsyV27UrMooju3MmcdZt4nf2+eayvh2XLOj9+Tg6MGgUjRrRtZWXOsZ/NnEgWt9tNLBZTHQyR/mKwJGpk0ElGDYwvdud11tq/9vTeKVLYfKzr4Hy8f0gfjYMx5p0OTmlvPhGRNBOvf5Gy7TvTXTjs1Jtob4nH7t3O9qLtyAA6VZotKwtGjnSSFPHjiBEtxwE4eyIZjDG43W5CoRDBYJCcnJxUhyQiIoNQMuau/hnoSiEN03x9f01gHEr8XU/PioskbxwREUkT8X3pw+Hw4P0AGAy2JCjihTHjxTL37HG2GO1Bfa4wsM+VR9nxR2JaJylGjnTakCFKUHRT60Keg/b3V0REUipZi28jwLPAB0kaL53FZ0YUdnC+YL/renscrLXHtddvjGkCBvY7jHvugT//uevbKHVmC6f2tm3q6rZRh9pu6mBbWHV2uyvt+S3Sb0QiEcLNWw0OyCn40agzQ6L1tqLxHTziraamZ/dwuZzlHCNHUpGRwTMrVrAjHGYXsAcXNVzD009+DDMyMyk/krTwer00NDQQDAZTHYqIiAxSyUhgvALMBy7A2RL098Cj1toklPFOS+ubj5M7OD+p+dhRbYtkjzO4ffghvNPRCppByJgDkxvttYOd93i61newY0d9+5/zeJw1mvufb6/P7da3p9JvBYNBQqFQ/6x/4fM5syMqK2HfPucYfx5v+/Y5BdN6wuVyCmKOHNl2aUd8BkVpKWRk8Pjjj/PLX/6SWOJ+ecCtXHRiGcOUvOgVretgRCIRFaEVEZE+l4winqcZYw4Hvgp8EfgTcJcx5iHg99bad3t6jzSzuPm4wBjjamf70xMBP/BmH40zuA2Wvbw7y9qWLb0GstbJjfaO+z9u7/mhWmZm+8/bO+7/ODPTuZ8SLbKf+PKRtKl/EQ5DbS1UV7e0qionEbF/S9aW3C6Xs1NHvDhmPDERL5I5fLjz308HrLXcdeedPPTQQ616RwB3M8RVzP/9JDs5cUq7PB4PoVCIUCikBIaIiPS5pPyfx1q7CfieMeY64HycZMbXgCuaC0z+FnjYWtuUjPulkrV2szFmIc4OIV8Hft3q9I1ALvDb+M9qjPEAE4GwtXZzd8eRDlx1FVx0UftbJR2s72CPO7ONU3e3jdq/r6OtrNrbzupgx8G253d/SNIYc2BSo72WlXXwx4c635lzmZlaXpQGrLWJAp55eXnJHhwCAWfHjf1bbS3U1TnH1q2mBhoakhsHQFGRk4QYNqwlKRHfdrSsDEpKuv37GAgE+NGPfsTixYtb9R4B3AkU8fmzt5JdOD4JP4R0JF4HQ4U8RUQkFYztQaGsgw5szFjgK8ClOFuxNwJnW2vf6JUb9iFjzERgKc6SmaeAtcAc4DScJR/zrLVVzdeOA7YC262147o7TjfjbMrOzs7xJetbM0l/sZjzwb6jBEfrc6339g6H2/a1vr69vtb98ccH6299vnWLRCAUav9cR/2addM9Hk/bBEfr1rqvvcedTZK0NxulvVkrg3QZUCgUory8nPr6eoqKilqSDvs3v9+Z7eDzQVNT28dNTU7SId4aG1se93YS0+t1kg+lpU5yIt5KS50WT1r00vKY6upqrr76at5///1EX2HuydQ13QJkMdpdzmOLi/Fk98PlOf1IJBKhvr6ekpISysrKUh2OiMigl5OTg9/v91lrc1MdS1/otbl/1trtwI+MMUtxZmCMAob11v36UvPsiVnAT4CzgXOBPcDdwI3W2uq+HGcwa2xsJBKJkJeXp6ms4HyrmTnA137HkzStkxyhUNvHrfs6uiYUcnZD2P956/7483hfR8/be5xuM2Lif2aNjamOxNHe8p+O6p50VGdl/+K48ecuV9vCvfFmTPuttdZJfWtbZl/tP6OrvSRfR79/oRAEAgSNIZybizcScWZApMMsIpfL2ZWjqMhpQ4dCcbGTqNi/5eenLPG0detWrrzySvbs2ZPoO/20z7Fo8VWAC7B85aIGPNn6QN3b3G431lrC4TDhcLh/1nMREZF+q1c+8RljRgKXNbexQAB4CFjRG/dLBWvth8CXOnHdNlq2RO32ONK+yy78CY/951YAMjIyyfLmkJ2VR25OLnl5eRQU5jO0KJ+ikkIKCvLJy8sjP985FhQUkJ+f3+FRCZE0FU/SpHuiJhZrSWa01wKBzj9v7/H+x4ONEwql+k/jQP1hGVCShYqLCQOZgUDv/OxeLxQUOK2w0Ek4FBQ4CYrCQucYb4WFTrKisDDtlxe9/fbbfPe736WxOfnmcrn4zne+yz/+dB5O8gKOyNrKOV+fkMIoBxev15uog6EEhoiI9KWkfUIzxriA83CWjZzdPPZ7wDeBB621h9wOVKSr3n+v5dcqGg3S5A/S5K9hXw936QPI9OaQl5fPkMJChhYVUjikgIKCAgoLCxOtoKCAIUOGUFhY2O4xbQr1Sd9zuSA722mpZm1iFkC7iZD4Y7+/7fnW7WBJkvba/rNaWs9sGWSJCwBrDEGvl7DHQ17ruhOZmc7vSHzZTvxxdjbk5DgtN7flmJvrJCby8yEvr+0x3ZN63fDMM89w0003EW1eOpadnc0tt9zCvooT+HCvsw1tBhH+35cjZHgH4La0aap1HYzc3EExY1lERNJEjxMYxpjxwJdxZhGMAJqAv+DsQPJWT8cXOZhwKAMowCmx0sOt+/YTDPkIVvuoqq5wqph0Q05ODkOGDGHo0KEMGTIk8Xj/VlRUlDjGm5IfkjTGpNeslfhuOfsvs2iv5knrein7Hzsqfrv/0o/4sg9r22/7L4to/Ty+PKX1UhSXq+3SltbLWtrb+cbjIeR2E/b5cEUiuEpKnCTFIK0F0hnWWu677z4eeOCBRN+wYcO46667OOywyZz3kTDgJCyOz1vLvIuPTFGkg5PH46GpqYlQKIS1FqPfYxER6SPJmIGxqfm4HLge+Id2zpC+8t0rfsDLC7/rFNtvDFHv89MYCOALBfCHAwRiAUI2SJQA0NDcGoH6Vs8bWj1vfex5gVufz4fP52P37t1dfm1eXh5FRUUUFxdTVFRESUkJxcXFiVZSUpJow4YNo6SkRBXhpX+I79AyiJJ0oYYGIpWVeKJRZ8aEdCgUCnHDDTewcOHCRN+kSZO46667KC0t5ff3R6ltcpYt5ODjK1dk4vKk9zKYgSYjIwNjTPptCywiIgNej3chMcbEgDBQ0YWXWWvt2B7dWA5Ju5C0CPqi7N0VpGpPmL17QlSVR6iujFK1N0pttaWmxlJXB3X1LuqbXDQ0GRqCYZrCAXzRIMFEAqTuIK221TH+uG93zMjJyUkkNEpLSyktLT3g8fDhwxk+fDilpaV60ynSR/bt28fevXvJzs7Wf3cHUVNTw7e//W3efffdRN+JJ57ILbfcQk5ODlVV8PHzYgTDTsJiQeFb3PT8LCUwUqCxsZGMjAyGDx+e/G2BRUSk07QLSfd4gNFJGksk6TJzMhg9KYfRk7r3+kg4RuWHASq2h6jYGaJiZ5h9FVH2VcSorrJUV0NNnYu6Bhf1fjcNAS8NIS8+osRoAGpoSWzUtGrV7Tyuan7c9SUxPp+PHTt2sGPHjk5dP3To0ERCo6ysjLKyMkaMGJF4HH9eUlKCK80L/YmkK2tt4pvq/Pz8VIeTtrZv386VV17Jrl27En2f+cxn+M53vkNGhrNc5L57W5IXRVTz+a/nK3mRIh6Ph2AwSDAYVAJDRET6TI8TGNZavXOQAc/tcTFyQg4jJ3RtiUYsatm3K5Odm/LYs304e3aEqdgVpWJPjL17oaraUFOfQW2Th7pAJg2RLAJk4yQvGnCSGfGExr5Wz6uan8fb3uZj13abqKmpoaamhnXr1h3853e7GTFiBCNGjGDkyJGJNmrUqEQbPXo0BQUFXbq/yGAQT1643W4lAjuwfPlyrrnmGurr6wEwxvCtb32Lz372s4n6Clu2wNPPtNRaOHXoaqZ97JSUxCtOAqOxsZFgMKg6GCIi0me0T6RIL3JlGEoPy6b0sM7vRNFQHWLHej87NgTYtdXDrh3D2LO7mIryyeyrcVFV56HGn0ldKAc/rce1OPU99ja3ylbH+OOKVm0vnZ3lEYlE+PDDD/nwww8Pel1eXh6jR49m9OjRjBkzpk077LDDOOyww1SxXgadYDBIOBzWdpMdeOyxx7j11luJxZx/j7Kysrj55ps55ZS2yYk777DErPMheRQ7ueDyMs2+SCGXy4XL5SIcDhMKhchMlyLBIiIyoCmBIZJm8ou8HHmClyNPKDzktQ3VIba852Pz+352bA6zc1uE3bthT0UZlTVjqGrKoiacS4j23lhGcWZyVADlrY7lwJ5Wxz04S18OrbGxkXXr1h10RkdxcTFjx45t08aPH8+4ceMYP368ZnHIgBMMBgmFQiqyu59IJMKtt97KE088kegrLi7mzjvvZNq0aW2ufestWPpG/Bt+y2lF7zL142f3YbTSHo/HQyQSUQJDRET6TI8SGMaYbGutP9VjiAxW+UVeZpziZcYpQzq8xlpLxTYf61c0sen9AFvWR9i+1bJrj4vyai/7mkZTE51G9KD/HPhxEhm7m4+7mh/vAnY2H3cBgUPGXFVVRVVVFStWrGj3fFFREePHj2f8+PFMmDCBiRMnJo5jxozB7VbeVfqPWCxGKBQiGo1qBkYrtbW1XHPNNW3+HZg2bRq/+tWvKC0tbXNtLAZ33G4BJ4ExmQ185H/Ha/ZFGvB6vfj9foLBoOq7iIhIn+jpJ4GtxphbgPuttcGuvNAYMwP4Cc72qz/tYRwi0gFjDGXjcygbn8Mpn2r/mnAgysaVNXyw3MfGNSG2bIzx4U7Drr1eKhpzqI4UEGUCMOEgd7I4tTp2Ah8mjm6zFW/GdnDtJBDZQywWPmi81dXVVFdX88477xxwzu12M27cOA4//HAmTZqUOE6aNIlx48YpuSFpJ758JL7tpMDmzZu5+uqr22wvvWDBAq6//vp2v8V/7jnYuMn5s3MT5pSSD5j88Y/3WbzSMbfbnZiBEYvFVONFRER6XY+2UTXG/BX4PM5+kY8AjwJvdjSjwhgzAfgI8EVgNs6nnIutta93OwjpkLZRlWQJNoXZsLyBNW81sX5NiM0bLdt2ZLCzKpvKQAE+Ojs1PoqzNGUHXrORguyN5OZsx531IYHYTvbu20Eo1LVCpHFut5sJEyYwdepUpkyZ0uZYXFzcrTFFeqquro7KykqMMVpCAixevJjrr7+e1v9f+vrXv86ll17aboInEIBPfsJSudc5dywruOraLI749BF9FrMcXG1tLbm5uQwfPpysrKxUhyMiMugMtm1Ue5TAADDGzAJ+BpzR3BUF1uLMM68BsoBiYApQgjMHtAK4C7ijqzM3pPOUwJC+EIvG2P5ePStfbWTNiiDr18bYvN3Dh9W5VIaHEKEr0+ajlGRtYmTJBkpHbKNw+G5M5i5279nMli1bKC8v71aMJSUlHHHEEUybNo0jjjgi8XjkyJH6Vlx6VWVlJXv37iUvL29QLyGJRCLcc889PPTQQ4m+nJwcfvrTnx5QrLO1P/0J7r3XeZyNny8Pe4YvPP0pMjwZvR2ydFJTUxPGGEpLS1XDSEQkBZTA6O5AxkwCvoyTyJgJ7P/uYi/wKvAE8IS19uDzyKXHlMCQVAs0hHj31Vreea2J91ZEWLchg63l2ewOFnVQWLR9Q7xNTBndxFFHNXL4jAqGHbabfVWb2LRpExs3bmTjxo1tpqN3VmFhIUceeSRHHXVU4njUUUcdsAZfpDsikQjl5eXU1NRQVFQ0aJNle/fu5dprr2X16tWJvpEjR3L77bdz+OGHd/i6mho4/3yLz+f8uZ3Ma3zle0Uc+Zkjez1m6bxQKITP52PYsGEMGzYs1eGIiAw6SmAkY1BjcoBRODMv/ECltXZP0m8kB6UEhqSrUFOY1S9X8daiJla+HeGD9W627CugMlaMpXNrqIuzmjhyfBNz5hrOOD+fGXMi7NmzkXXr1rF+/frEcf369fj9XasTPGzYMKZPn8706dOZMWMGM2bMYNq0aaqyL13i8/moqKggGAwO2m+m3377bX7wgx9QU1OT6Dv55JO58cYbD/ln8stfwqOPOo+HUMMlJf/hc09fRIZXsy/SibWW6upqioqKGDFihOpgiIj0MSUwZMBQAkP6E2st5etrWfJMLcteDbD6PRcbduexOzyMMN5Dvt4QY+zQeo6fEeKs87I4+8J8xowxxGIxduzYwQcffMDatWv54IMPEo/r6uo6HZ/b7Wbq1Kkcc8wxHHvssRx77LHMnDlz0H4wlUOrqamhsrISt9tNdnZ2qsPpU9ZaHnjgAe6//37i7zNcLhdXXHEFl1xyySFno+zYAZ/5jCUada77CM/zP98dzVEXHdXrsUvX1dbWkpOTw/Dhwwfd77qISKopgSEDhhIY0t9Za6nd0cDrT+1jyUsBVq12sX5XHjsjwztVW2NYThPHTvNx+ke8XPDFAiZNNsQ/N1lr2b17N2vWrOH9999nzZo1rFmzhg8++ICmpqZOxzhp0iSOPfZYjjvuOI4//niOO+44bScoAJSXl7Nv3z4KCwvJyBg8swb27dvHDTfcwJtvvpnoKyoq4pZbbuG4447r1BjXXAOLFjmPR7CHi4Yt4n+e+qxmX6Qpn8+HtZbS0lIKCwtTHY6IyKCiBIYMGEpgyEBkraVyfQ2v/rOK114KsvI9Dxv3DaHSDjvk8pOibB9zp/s4+xNZfOyiXMaNO/Bb4FgsxtatW3n33XdZvXo1q1ev5t1332XLli2dis8Yw9SpUzn++OOZNWsWs2fPZubMmVp+MsiEw2HKy8upq6ujqKgo1eH0mVdffZWf/OQn1NbWJvqOPfZYfvazn1FSUtKpMd59Fy67rOX5J/gXn/jeFI74jHYeSVfhcJjGxkaGDRumGkIiIn1MCQwZMJTAkMEiEoywaUkFzz9cy2uvWFZvyWNHZOQhl56U5TdxyglBPvGFPM7+mJeDfXFYX1/Pu+++y8qVK1mxYgUrVqzg/fffJxqNHjI+r9fLzJkzmTNnDnPnzmXOnDlMmDBh0BZ1HAwaGxupqKggEokMihk5gUCAO+64gyeeeCLRZ4zh0ksv5fLLL+/0DBRr4ctfdpIYABPZxPnD3+KiJy/SziNpLF4HY+jQoZSVleF2u1MdkojIoKEEhgwYSmDIYGVjlt2r9/Liw/tY9N8wb6/NY0toFEGyOnyNixhHjmvknHNdfOILuRx/vOFQn7n8fj9r1qzhnXfeYfny5bz99tudTmqUlJQwb968RJs1a5bWjg8gVVVV7N27F6/XS1ZWx793A8H69eu57rrr2LZtW6KvtLSUn/zkJ8yaNatLYy1eDN/9rvPYRYyLeIRzvz+TaZ+alsSIpTfU19eTmZlJaWkpubmD4j20iEhaUAJDBgwlMEQc1lp2r6rk+b9U8sLzUVZsKmBrdMxB62gUZgc5c36Iiy7L5SNnu+hsrU6fz8eqVat4++23efvtt1m2bBmbNm065OvcbjfHHnss8+bN4+STT+akk07SVOx+ylrLnj17qKqqYujQoQN2V4ZYLMbf/vY37r33XiKRSKL/jDPO4LrrrutygdtIBC680CngCXA077GgbA0X/esiXJ6B+Wc4kPj9fiKRCKWlpQwdOjTV4YiIDBpKYMiAoQSGSPui4ShbXt/Fs3+qYuELsLp8OHsY2eH1bleM2Uf7+fQXsvjkpzMYO7Zr96uqquKtt97izTffZNmyZSxbtqxNjYCOTJ48mZNPPjnRxo8fr2Un/UAwGKS8vJzGxsYB+0Fu27Zt3Hjjjbz33nuJvuzsbK655hrOO++8bv2ePvYY/OIXzmMvIT7Lw5x13fFM+4RmX/QH0WiUuro6SkpKGD58uP6tEhHpI0pg9MZNjBlmrd3b6zeSNpTAEOmcxvJG3np0K0//w8dr7+SwPjyeJvI6vH76JD//v707D4+rrPs//r5ny8wkTdI23YAClraUAgWk7GWHsrggyCIIAs+Dsqqg/NTHFVQe9XFDEBFBwV1Q2dygUOhCC7KXrUApFKilTdvssy/3748zM03aJM0yyZnl87quuU7mnDMn35SQmfnMfX/vcy4McMZZXqZNG/z3y2azvPbaayxfvrxwe/XVV7f7uB133JEjjzySI488kiOOOILdd99dbxJKUEdHB83NzWSzWerq+v49Kkf5URc333wzyWSysH/27Nlcd911TJ06dUjXjUTgIx+B1lbn/kH8m3lT3uSsuzX6opy0tLRQX1/P5MmTCQS2v/y1iIgMnwKMkfgmxqwCTrDWDqyNvxSFAgyRwcums7y1+G3+dss6/vmAhxc7d2U9U/o8f8/pcc4+P8DZ53iGFGbkbd68mccff5xly5axdOlSnnrqqR5vEHszadIkjjjiiEKoMXv27IqdrlBONm3axMaNGwmFQhX1Jq63URc+n4+LLrqICy64YFiNG2+6CW6/3fm6jk7O5C6O+dphzDpl1nDLllHU1dWF1+tl4sSJVdG8VkSkFCjAGIlvYsxPgLOAk621z3bbfwTwHWvtYSNeRBVSgCEyPDZr+c9T/2Hpr9/ivr+keGbjVN5kGll67+55wJwE/3VpgLPOMgx35kA8Huepp55i6dKlLF26lGXLltHZ2dnvY8aPH98j0JgzZ44CjVGWzWZ57733aGlpYdy4cRUxQiaTyfCHP/xhm1EXu+++O9dccw0zZswY1vXffdfpfZFKOfeP5lH233EDZ/71TDw+/f6Wk0QiQSKRoKmpacDL5oqIyPAowBipb2TM1cDXgDOAZuC7wPHAXdbas0eliCqjAEOkeKy1bHhhA0/c8Rp/+X2CJzfuymp26zXM8HuznHxilv/6lI8TT4RifAifTqdZsWIFixcvZsmSJSxZsoTW/Hj7PowdO5YjjjiCo446iqOOOkqBxiiIx+Ns2LCBSCRCY2Oj2+UM28svv8x1113H66+/XthXrFEX4Cyb+tnPwvLlzv2JbOAU7ueobxzB7h/afVjXltGXzWZpaWmhqamJKVOmVESAJyJS6hRgjOQ3M+aLwLcAA9wLXGOtfXnUCqgyCjBERoa1lnVPr+PJ37zGX/6Q4KmW3XiD6Vi2DQfG1qc5/0IvF33SsOeexashm83y0ksvsXjx4sJt06ZN/T4mH2gcffTRHHfcccyePVtvMIqsvb2d5uZmjDGEw2G3yxmyrq4ufvazn/HnP/+Z7q8TijXqIm/JEvjc5/L3LKdxL9N2SnDWX8/CePW7WY7a2tqora1l0qRJFb+EsIhIKVCAMRLfxJipwFeBC4CngX2AK6y1d4z4N69iCjBERp7NWt557B0W/ewV/nyPl2eTe/W5osnc/dJ86lIfZ53FgJdlHXAd1rJy5UoWLVpUCDQ2bNjQ72OmTJnCcccdx/HHH89xxx3HlCl99/qQgWlubmbjxo3U1dXh9/e9TG+pstbyyCOP8P3vf79HIFZTU8MnP/lJzj333GGPushLJOCMM2DdOuf+bFZyOI9x5DVHMvODM4vyPWT0RSIRACZOnEhDQ4PL1YiIVD4FGCPxTYyJAy8AX7HWPmSMOQb4K/ADa+11I15AlVKAITK6kl1JXv7zy/zzprd44JkJvMAcOtj2BXyoJsuZHzNceqnhwANhJAZBWGt57bXXWLRoUeG2vUBjzz33ZP78+ZxwwgkcfvjhZT2CwA2ZTIb169eXbf+Ld955hx/96Ec89thjPfYfeuihfPGLX2THHXcs6ve79Va45Rbn6xrinMVdTJkW4vQ/nY7xlNe/nWyRTCaJRqM0NTUxceJEt8sREal4CjBG4psYc7q19i9b7dsH+Adwv7X2shEvogopwBBxT8sbLTz9y+f48y1tLG+dxavM6rVfxj57Z7n80x7OOQdqR/BpJx9oPProozz88MM88sgjtLW19Xl+TU0Nhx9+OPPnz2f+/PnMmTOn7N6Qj7ZoNMqGDRtIJBLUF3uIzQhqa2vj1ltv5S9/+QuZTKawf/z48Vx99dUcd9xxRf9vv24dnH465HuCHs5SZvMqJ/7kRKYeNrSlWKU0WGvZvHkz48ePZ/LkyXi9vTc9FhGR4lCAMdgLGPNl4G5r7atDeOwuwL+stbOHVYT0SgGGiPsyqQyv3f8ai258ifsX1/Mc+9HMpG3OG1OX5RPne7j0UoraK6PPujIZnnnmGR5++GEeeughli9f3u+yrZMmTeL4449n/vz5HH/88UyePHnkiywzra2tNDc34/P5CIVCbpezXclkkjvvvJNf/vKXdHV1FfYbY/joRz/K5ZdfPmJLYX7+87B4sfN1Exs5lXvZce4UPnDzBxSUVYD29naCwSCTJk3SSC4RkRGmAGOwFzAmi9OM85vd9oWstbEBPn6stbb/VvoyJAowREpLy+oWnvnFs9z/i/d4rG0vXmIv0mzbJ+G44yxXX22YP39kppf0JhKJsGTJEhYsWMCCBQt45ZVX+j1/zpw5hTDj8MMPL4s37CNt/fr1bNq0ifr6+qL1iRgJ1loefvhhbrzxRtblG1DkvP/97+eqq65ijz32GLHvv3w5fOYzW+6fwr1MZiMf+e1HmLDHhBH7vjJ6YrEY6XSaiRMnMna4a0qLiEi/FGAM9gK9BxjfAC631m4z+dEYMxnotNZGhvWNZbsUYIiUpnQizct3vcyjP3qeB56fxNPMZTNN25y3156Wz19tOPtsqKkZ3RrXrl3LggULePDBB3n44YdpaWnp89yamhrmzZvH8ccfz/HHH8++++5bdcu1plIp1q9fT3t7O+PGjXO7nF6l02kWLFjAHXfcwZtvvtnj2M4778xnP/tZjjjiiBEdAZFKwZlnwrvvOvdn8hpHs4TpJ07n6G8fPWLfV0ZXOp2mo6ODpqYmjdYSERlhCjAGe4G+A4yvW2u3mfiYO/ZVa235tWcvMwowREqbtZb//Ps//PuGJ/n7nRH+nd2fV5m1zXKsUyZbPv0Zw6WXQmPj6NeZyWR47rnnWLBgAQ899BDLli0jlUr1eX5TUxPHHHMMxx57LMceeyzTpk2r+GkBXV1dbNiwgXQ6PWLTLoYqkUhw//3389vf/nabERcNDQ1cfPHFnHbaaaMyauT22+Gmm5yvAyQ5izup8yc5869nMmaH0vp3k+HZvHkzjY2NTJ48uSxX5BERKRcKMAZ7gaEFGL0ek+JSgCFSPjrf6+Tpnz/NA9e/xuKO/XiW/UgR6HFOfb3l0582XHUVjB/vUqE4b9YXL15cCDRWrlzZ7/m77LJLIcw45phjKvIT2c2bN7Nx40ZqamqoGe3hMn3o6Ojgr3/9K3/84x+3GUETDoc544wzuOCCC0YtcHn7bTj77C2NOw9lOXvzMnt9fC8OueqQUalBRk9nZyc+n49JkyZRV1fndjkiIhVLAcZgL6AAo2QpwBApP4nOBE/f/DQLv/8sSzbtwb85iC56vsGsq7Ncdpnh85+HUlilcO3atYVmoA8//DDNzc39nj9z5kyOPPLIwm2nnXYapUpHRjabLfS/GDdunKvTZ6y1PP/889xzzz08/PDD2zRmbWxs5Oyzz+bMM88c1ZEi1sJFF8GKFc798WziVO4hNCbAx+77GDX1pRH6SPHE43GSySQTJkxgvJuJq4hIhVOAMdgLKMAoWQowRMpXKpri2V8+y+LvPs7j63blMQ5jEz0bHIZClksuMfy//wdTprhU6Fay2SwvvfQSCxcuZOHChSxevLjHChe9mTZtGkcccQSHH3448+bNY8aMGWU15SQej7NhwwYikQiNbszxwVn14R//+Ad33303a9as2eb45MmTOe+88zjllFMIBoOjXt+dd8L3v+987SHLR7iHCbRw0GcPYs55c0a9Hhl52WyW1tZWxo8fz5QpU8rq/2kRkXJSrADDGLMT8E3gRGA88B5wL3DtUBfdMMacB/wmd/eT1trbhlMjFC/A+Ia19lvd9inAKAEKMETKXzqRZsWvV/DotUv497qdWMIR2yzDGgzCxRfDF79YOkFGXiqV4qmnnioEGk888QSJRKLfx0yYMIF58+Yxb948DjvsMPbbbz8CgUC/j3FTe3s7zc3NGGNGdcnIeDzOsmXLWLBgAUuWLOm1L8ns2bM588wzOfHEE11bGWXdOqdxZzzu3H8/z3IAz1A3uY4z7z4Tb0AvBypVa2srdXV1TJ48uWSmVomIVJpiBBjGmN2A5cBE4D7gVeBA4GjgNeAwa+3mQV5zKvAi4AXqKLEAI5Ur7qnc7TDgAgUY7lKAIVI5UrEUT974JEv+9zFWtO/KYo5gPT3TilIOMvLi8ThPPvkkixcvZvHixSxfvpxYrP9Vt4PBIAcccACHHnoohx56KIcccggTJpTOcpvNzc1s3LiRurq6EW9WmEwmWb58OQsWLGDp0qW9/tuFw2FOOukkTj31VGbNmjWi9WyPtXDZZfDUU879caaVU+3d+Mhy1LeOYsZJM1ytT0ZWV1cXHo+HiRMnUl9f73Y5IiIVqUgBxoPAfOAz1tobu+3/EXAVcIu19pJBXM8ADwHvA+4GrqaEAoyHgP2A/Lpx3S/4GLCi2+1F4EsowBgVCjBEKk+sNcZj332MJ67/NyuT01jMkaxjxx7n1NRsCTJ22MGlQgcomUzy9NNP89hjjxVura3bH6U4ffp05s6dy3777cf73/9+9ttvP1fm2afTadavX09rayvjxo0r+jB5ay1r167lqaee4qmnnmLZsmX09Td99uzZnHbaaZxwwgmEQqGi1jFU99wD113nfG2wnMK9TGITTbOb+MivP6JpBRUumUwSjUaZMGFCSYWOIiKVZLgBhjFmGrAaWAPsZq3Ndjs2BmcqiQEmWmsjA7zmZ4EfA0cBxwDfoFQCjMKFnB98brfbfkBD7nD+m2SBLqBeAcbIU4AhUrna321n0TWLeP72Fbxup7OolyCjHEZkbC2bzbJy5Uoee+wxli5dyvLly3nrrbcG9Nidd96Z/fbbj7333ps999yT2bNnM3PmzBHt+RCJRNiwYQPJZLIonzBba1m3bh3PPfdcIbTorynqrrvuyvz58zn++ON53/veN+zvX0zNzXDGGRDJvdSZwwscwr8BOOWOU5i4Vwl0oJURZa2lpaWFcePGMXnyZLxevfQTESm2IgQYFwG3Ar+w1l7cy/H86IzjrLULB3C9PYBngZ9ba68yxlxDKQYYvV7cmJn0DDX2xZn/YhVgjDwFGCKVb+MrG3nkK4+w8t5XWcWMPoOMSy91goxJk/q4UAlbv349jz/+OMuXL2f58uU8/fTT26yu0RePx8Nuu+3G7Nmz2X333Zk2bVrhtvPOOw97ykdLSwsbN27E7/cPOijp6urizTffZNWqVbz++uusWrWKN954o88RFnlTp07l+OOPZ/78+ey2224lOYrBWrjySli2zLk/1tfJqek/4yfDzA/P5MivH+lqfTJ62tvbCQaDTJo0aVR7xIiIVItcgJEFnu/tuLV2//4eb4z5Ps4Uj6uttT/s5fhPgcuBy6y1N2/nWj7gCWAMsK+1NlbsAGNEO3pZa18HXgf+AIW5MHsA/f4jiojIwEyYPYGz7jmLdx9/l4VfWsiMJbexiuks4qhCkBGPw49/DD//udOP4AtfKI3lVwdq8uTJnHrqqZx66qkAJBIJVqxYwXPPPcezzz7Lc889xwsvvNBrc9BsNsuqVatYtWrVNsc8Hg8777wzu+yyC1OmTGGHHXbosZ04cSK1tbXU1tYSDocJhUI9lki11pJIJEgmk9TW1mKtJRqNEolEiEQidHV1FW4bNmzgvffe63Hb3uosebW1tey///4ccMABHHDAASUbWnT3wANbwguAw9OL8JPBX+vnwCsOdK8wGXWBQIBkMkkikVCAISJSmvKzJtr7OJ7f3ziAa30dZybGPGtt/03OhmhUW5JbZ7jHK7mbiIgUydRDpnL+ovN5419vsPB/FjLjhdt4nRks4ijew2mEEYvBD3/oBBlXX+3c6upcLnwIampqOPDAAznwwC1vhFOpFCtXruT555/nlVdeKdzefPNN+hppmM1mWbNmTa/LjvYlHA4TDAbJZDJ4PB7Gjx9POBxm8+bNZLPZ7V9gABoaGpg1axZz587lwAMPZNasWWU19H7jxi1LpgLs7VvJlPR6APa/ZH9C40qjP4eMjkAgQCwWI5FIYK0t+fBNRKRMxbc30mIY8n+4+526YYw5EPgy8ENr7eMjVMvoBhgiIjJyjDHMOHkG00+czkt/eolHv/YoM9+8ldeYySKOKqxaEonAtdc6QcY118BFF4FLK2wWjd/vZ86cOcyZM6fH/lgsxmuvvcYrr7zC6tWrefPNN3nzzTdZvXo1//nPfwb9faLRaGGKx5gxYwqjLoYSXgQCAaZOncrMmTOZMWMGM2bMYPr06TQ1NZXtmzxrnd+pjg7n/thQjLmxJwBonNbInmfs6V5x4op8+JZMJkmlUiW9JLKISJXKj7Bo6ON4/VbnbSM3deS3OLMvvla80nr5XiPZA0PcpR4YItUtk8rw3C+fY/E3F9P5XhevsjuPcjTN9GyEsfvu8L3vwYc/DGX6vnlI4vE4a9asYe3ataxbt4733nuPdevWFb7evHlzYTpIJBLZZorKhAkTaGpqIhKJkEqlAAiFQtTW1lJXV1eYflJXV0dTUxNTpkzpcRs7dmzZBhV9uesu+L//c742xvJB+3d2wBl98YGbP8AOB5T4sjgyIrq6uvB6vUycOJExY8a4XY6ISEUphSaexphGYPvLyDl+Yq29cii1ggKMiqYAQ0QAUtEUT970JMu+u4xIS5wVzOERjqGTnqtmzJsH118P+6tLUa8ymQzRaJR4PA44DTw7OjpoamrC6/Xi9XorLpAYjDVr4JxzIN9f9aBxr7Nvy2IA3nfs+zjue8e5V5y4KplMEovFCqGfiIgUTxECjN2AN+h/GVUPMKGvZVSNMSHgxj6+xftx+mI8BrwGPGStvXMotYICjIqmAENEuou3x3nsO4/xxI+fIJ40PMFBPMY8EmxZPcMY+OQn4brrQO8z+haNRtmwYQPxeJyGhr5GXFaPdBouvBBWrnTuT50YZ37z7/GRxVvj5cy/nknd5DJsuCJF0X051SlTpvRohisiIsMz3AADeoyy+Iy19sZu+38EXAXcYq29JLfPD+wGpKy1qwdw7Wso4iokegYREakSwYYgx333OC596VJmf+B9HM4yPsONHMS/8ZABnB4Gv/gFzJwJN93kvDGVbeVXH9F8fsdtt20JL/x+y7yuBfhwPsDZ98J9FV5UOWMMPp+PVCrV62pBIiLiusuAZuAGY8y9xpjvGGMewQkvXge+0u3cHYGVQK/TSUaaAgwRkSozfsZ4zvn7OZz997OZOj3ISTzA5fyM6WxZarS1Fa64wplOsmSJi8WWqEQiQSqVwu/3u12K6158EX71qy33509bTX10AwB1O9Sxzyf2cakyKSV+v59EIlGYgiUiIqUjN5JiLnAHcBDweZxRFjcAh1hrN7tXXU+aQlLBNIVERLYnnUjzxPVPsORbS0hGUrzOTB7gBFoZ1+O8c891lmCdONGlQktIKpVi/fr1tLe3M27cuO0/oILFYk7fi3ffde7vOT3OoW/8tvDpyIk3nsjUQ6a6Vp+UjnQ6XegZM3nyZLfLERGpGMWYQlJONAJDRKSK+Wp8zPviPC57+TJ2O34au/M6l/EzjuER/CQL5/3udzBrljNVYAgrhlaUeDyu6SM511+/JbwIhy2HdDxYeGEx/aTpCi+kwJdbqzmVSpFMJrdztoiISO8UYIiICI27NHLug+fyods+RF29jyNYyhXcxGxeLpzT2uo0+DziCHjpJReLdVm+/0W1Tx956CH461+33P/ovqvxNjcDUFNfw8GfO9ilyqRUBQIBksmk+mCIiMiQKcAQERHAabT3/v9+P5e9fBnTT5pOAx2cyV/4OL+jsdvS3suWwX77wZe+BNU2Qy2bzZJMJkmn01UdYLz5Jnzzm1vuH3ZAgvDjjxbuH/y5gwmNDblQmZQyv9+vAENERIZFAcYgGGNmGGO+aIx5xBjzrjEmaYzZYIy5zxhz9CCvtasxxvZz+9NI/RwiIv2p36mec/5xDqfccQrBxiAzWM1l/IzDWYo3t1pJOg3f+x7svTcsdKUHtTvyzTu9Xm/VLgUZicDVVzv9LwB23tlycNsCyLXU2uGAHZjxgRnuFSgly+/3k06nSSQSZKt9LpqIiAyJmngOQi5UOAt4BXgMaAF2Bz4MeIHPWmtvGOC1dgXeAlYA9/ZyykvW2r8Ms1418RSRYen4Twf3//f9rH7QWea7mSb+wQd5m116nHfhhU6Tz7Fj3ahy9LS1tdHc3IzH4yEcDrtdzqizFr7wBXg0N9giGISvnP46a3+3GABvwMvpd55O/dR6F6uUUtbW1kY4HGbSpEmEQhqlIyIyXNXWxFMBxiAYYy4AVlhrn9tq/5HAQzifP+1qrX1vANfaFSfA+LW19oKiF4sCDBEpDmstz9zyDAs+v4BUNEUWeJ59edh7ItFMTeG8SZPgxhvh9NPBGPfqHUnr169n06ZN1NfXF5oSVpPf/AZu6BbTf/XzMVpv+hPpeBqAuZfPZb8L93OpOikH0WiUbDbLxIkTaWxsdLscEZGyV20BRnWOfx0ia+0dW4cXuf2LgUVAADh0tOsSERlJxhjmXjKXS1Zcwk6H7IQHeD/Pc2nmRvbyvlI4b8MGOPNMOPVU+M9/3Kt3pCSTycLqCdUYXjz1FPz0p1vuf+xjlprliwrhxdjpY9nnvH1cqk7KRSAQIJVKqQ+GiIgMiQKM4knltulBPm4HY8zFxpgv57Zzil2YiEgxjJs+jguXXMgx/3sMHr+HMUQ4PfNnPsafGFuzZaTXfffB7Nnwi19U1pKr+f4X1bh86oYN8OUvb/nvuc8+MH/Hlax9fK2zw8ARXz0Cj08vK6R/Pp8Pay3JZJJUKrX9B4iIiHSjKSRFYIzZBXgNyAA7WWtbt/OQ7lNIerMION9a+84Av/8zfRzaNxQKeTSFRESKbf3z67n73LvZ+PJGAOLU8GjNifw7sW+P8446Cm69FaZPH/0ai23jxo1s3LiRcDhcVSFGKuUsn5tfOnf8ePjpN1tZcuXdZFNOorHXOXtxyOcOcbFKKSednZ34fD4mTZpEXV2d2+WIiJQ1TSGRQTHG1AC/B2qAawYSXuREgW8B+wNjc7cjgUeBo4CFxpiq+CUUkfIzed/JfOrpT3HwVQcDECTBSYn7uIA72KG+q3DeokXOSiU/+IGzckm5ymQyJJNJMplMVS2fai1861tbwguPB759TZrn/u+hQngxfuZ4DrziQBerlHITCARIJpPE43G3SxERkTJTdSMwjDFrYKv2+f37vbX23D6u5QX+CJwB3AmcbYf5D2qM8eGscHIQcKW19ifDuJaaeIrIiHtz4Zvcd8F9dKztACCFjycaTmBR1/5kMlu6ec6dC7/8Jcwpw4ly0WiUDRs2kEgkqK+vnhU2br8dbrppy/3Pfx52eH0xr//tdQB8IR+n/u5UGndpdKdAKUvZbJbW1lbGjx/P5MmTq3ZJYhGRYtAIjMq3Gme6x0Bv63q7SC68+B1OeHEXcO5wwwsAa20auC1394jhXk9EZKRNO3Yal7xwCXudvRcAftIc3v4PLrK3Mn3KltEYTz8N++8PX/wiRCJuVTs08XicZDJZVVNHFi7sGV585CMwt3FVIbwAOOyLhym8kEHzeDx4vV6SyaSaeYqIyKBU3QiMYsiNkvgDTnjxB+AT1tpMEa9/CnAv8KC19sRhXEcjMERkVL34hxf5x2X/INHuvCnJ4OGVXU/m7++9n0Riy2iMXXZxVrT44AfdqnTgrLW89957bN68mbFjx1bFp8WvvOL0vci/t5w7F677Ygf3n/9X0lFnLtD0k6dz1LVHYSp1zVwZUbFYjHQ6zcSJExk7dqzb5YiIlC2NwJB+GWMCwF9wwovfAOcVM7zIOTi3fbPI1xURGVF7n7M3l6y4hKmHTQXAS5a91/ydKwK3MXePLcMu3n4bPvQh+OhHYe1at6odmPxqCR6PpyrCiw0b4KqrtoQXO+8M3/l2hiVfW1gIL+qn1jPvS/MUXsiQdV9OVR+miYjIQFX+K7EiyjXsvAc4BfglcKG1tt9FAo0xDcaYWcaYKVvtPygXhmx9/jHAVbm7vytO5SIio6dxl0YuWHSB8+m813mDO6ZzHR9Y+QM+Pe9Zxo/b8mbl7rthjz3gxz8u3Saf1TR9JBZzwovNm5379fVw/fXw6m+eZNOrmwAwPsOx3zkWf7h6mplK8Xm9XsBZnjiZTLpcjYiIlAtNIRkEY8ztwAXAJuBnQG//eIustYu6PeYC4Hbg19baC7rtXwTsibNkav7zxznAMbmvv2at/fYw69UUEhFx1bvL3+Xuj99N25q2wj7f1Mm8sPfHueufPZdP3GcfuPlmOKTEVuNsbm5m48aN1NXVVfQKJNksXH01LFni3Pd6nR4YTZE1PPT5hwrnHfz5g9n77L1dqlIqSSQSwRjDxIkTq6o5rohIMVXbFBKf2wWUmffltk3A1/s5b9EArvVb4FTgAOAkwA9swGkI+lNr7dKhlykiUhqmHjqVi5+/mH9e9k9e/MOLAKTfXc/stT/kB2edzK9emMsrK51RGitWwKGHOr0XvvtdGDfOzcod6XSaZDJJNpvF56vcp0xrnX/zfHgB8D//A9MntHHP5x4t7Nv58J3Z62N7uVChVKJAIEBXVxfxeFwBhoiIDIhGYFQwjcAQkVLy4h9f5J+X/5N4a7ywb+wek1h/7Dlc/8t6YrEt5zY1wfe/D+efD262Wejq6mLDhg2k02nGjBnjXiEjyFr40Y/gj3/csu+88+CyT6W49/x7aXuzDYC6Heo49benEmwIulOoVBxrLS0tLYwdO5bJkydXdEgoIjJSqm0EhnpgiIjIqNj77L259MVL2e2E3Qr7WlduIPTzn/Cri5/ggx/YEqhv2gQXXghHHumsiOGWeDxOKpWq2P4X1sKNN/YML04+Ga64wrL42sWF8MIb8HL8949XeCFFZYwhEAiQSCSIx+Pbf4CIiFQ9BRgiIjJq6nes5+P/+jgfuPkDhSaQ2XSW165/kA8338ZvftrBzjtvOX/pUth3X/jqV+kxQmM0ZLPZwgokldr74tZb4Te/2XL/uOPgG9+Al//4Im89/FZh/7wvz6Np9yYXKpRKFwgESCaTCjBERGRAFGCIiMioMsYw95K5XLLiEnY6ZKfC/nVPreOdq2/k11c8xRe+YMmPJk+l4LrrYM4cWLhw9OrMr47g9XorcvnU22+HX/xiy/0jj4Rvfxs2PLeOf9/w78L+Pc7Yg5kfnOlChVIN/H4/6XSaRCJBNtvvwm4iIiIKMERExB3jpo/jwqUXcux3jsXjd56O0vE0i7/wT2Y/9RuW/LOTQw/dcv4bbzgjBD7xCdi4ceTrq+TlU//wB2eFkbxDD3WaeMY3d7HwfxZC7n3kxDkTOfRzh/Z+EZEi8Hg8+Hw+UqmURmGIiMh2KcAQERHXeLwe5n1pHp986pNMmjOpsH/No2tYfPpN3HjR89x8s6WhYctjfvtbmDXLmf6QyYxMXdbawgiMSgowrHX+/X70oy37DjzQaZjqIcPDX3i40GQ1OC7Icd87rhAuiYyUfB+MRCLhdikiIlLi9KpERERcN3mfyVz05EXM+595GI+z7EiiI8Hf/us+xj38Z557PMZZZ205v6UFPvUp5833smXFryeVSpFMJgEqZmWEVAq+9S34yU+27NtvP/jhDyEQsCy5dgkbX84NbfHAcd89jtoJVdHQXFyW74ORSCTQ6ngiItIfBRgiIlISfDU+jv3fY7lw6YWMmz6usH/lX1dy7/yf873L3uaf/4Rdd93ymGefhXnz4Nxz4T//KV4tlTZ9pL0dLr8c7r9/y7799nPCjFAI/n3Dv3njgTcKxw6+8mCmvH+KC5VKNcr3mcmPehIREemLAgwRESkpUw+dysXPX8z+l+xf2NextoNfH/1rapY/wosrsnzjGxDstqLn738Pu+8O3/kOFGMUejweJ5FIVESAsWYNnH++E/bkffCD8LOfQTgML/7xRV787YuFY7M+Oou9zt5r9AuVqqbVSEREZCAUYIiISMkJ1Ab44M0f5Kx7zyI0LgSAzVqWfnspd554O589v5VXX4XTT9/ymEgEvvxlJ8j41a8gnR7a985PH8lms2W/fOqTT8IFF8Datc59Y+DTn3aWSvX7YfVDq3nih08Uzt/1qF2Z98V5GGPcKViqlgIMEREZCAUYIiJSsmadMotLXriEXY/etbBv7eNruWXfW2hbsoK77rIsXAh77rnlMW+/Df/93zB7NvzxjzDYlRm7j74o1zfy1jorjVxxBXR1OfuCQfi//3NGYxgD655ex6KvLyo8ZtI+kzj6uqMLPUhERpPf7yebzZJKpUilUm6XIyIiJUoBhoiIlLT6Hes576HznOVWfc7TVqIjwb2fuJc/fvCPzJ3ZwfPPww03QFPTlsetWgXnnAP77AP33OO8qR+IfP+Lmpqa4v8wo+C99+DSS52VRvLhzcSJ8MtfwtFHO/c3r9rMgs8vIJtyTmh8XyMn/PgEfDWV0bBUypNWIxERke1RgCEiIiUvv9zqfy37L8ZOG1vYv+qfq/jZnj9jxa+e4YorLG++Cd/+Nj2WXX3pJTjtNKdp5W9+A/31CMxkMiSTSdLpdNlNH7EW/vY3OOssePrpLftnz4Zf/9qZWgPQ+V4n//r0v0hFnE+5wxPCnHTjSdTUl2dgI5VD00hERGR7jJarqlzGmEgoFApHo1G3SxERKZpkV5KFX17Ikzc+2WP/+455Hx+69UOMnTaW1lZnBML112+ZQpE3ebIzteLii3uO2ACIRCJs2LCBZDJJfX39yP4gRdTa6gQ3ixdv2efxOP0vPvlJp98FQOubrfzrin8RaY4A4K/18+FffrjHqi8ibrHW0tLSwrhx45gyZQoejz5nExHZnnA4TCwWi1prq2LtcwUYFUwBhohUsreXvs39/30/LataCvv8YT9HXXsUB376QHw1PjZudPo+3HQTxGI9Hx8Mwic+AVdeCXvs4ezbvHkzGzduJBAIEOy+zEmJymbhwQfhhz+EtrYt+3feGa69Fvbee8u+DS9s4IErHyDZ4QxB8fg9nPzTk5myv5ZLldLR3t5OMBhk0qRJhMNht8sRESl5CjCkYijAEJFKl4qlWHTNIh7/wePY7Jbns8b3NXLcd49j9hmzMcaweTPccgv89KdOj4itnXgiXHlllr32Wk9Ly2bGjh1b0p/+ptPwr3/B7bfDO+/0PHbmmc5KI6HQln3vLH2Hh7/0MJlEBgBf2Mf8H8xnxwN3HMWqRbYvHo+TSqVoampi/PjxbpcjIlLyFGBIxVCAISLV4j9P/Yf7/+t+ml9q7rF/p4N3Yv4P5zP10KmA0//irruc6SXPPdfzGqFQlAMPbOa002J86EMNlGIPz1TK6XNxxx2wbl3PYxMnwte/Dgcf3HP/6397ncXfWgy5hp7BsUFOvOFEJuwxYVRqFhmMbDZLa2sr48ePZ/LkySUdJIqIlAIFGFIxFGCISDXJJDM8/fOnWXztYmItPeeLzD59Nsd+59hCrwdrYckS+PGP4f77nftjx7YwYcJGUikfwWCI006D44+H6dOdZUfd9O678MgjcOed0Nwzo6GuDj72Mfj4x2HMmC37rbWs+M0KnrrxqS3n7lDHyTedTMPUBkRKVVtbG+FwmIkTJ2oaiYjIdijAkIqhAENEqlG8Lc6S65bw5A1PkklmCvuN17DPJ/bh8C8f3qNp5erVcMMNlr///T3C4c20to4lm93yqe+UKXDkkc5tv/3ANworjVrr1PXoo05wsWrVtuc0NDihxZlnOiFGd6lYiid+9ASv3vNqYd+4meM4+caTCY0PIVLKYrEY6XSaCRMmMG6cGsyKiPRHAYZUDAUYIlLNWt9q5ZEvP8JLf3qpx37jNcz5+BwO/+rhjJ/hzLGPx+OsXr2Bv/89wl13NfbaJwOcEQ6HHOIsSbrrrs5txx2HH2pY60wJefllePFFeOwxZ9RFb8aNc5qPfvSjPftc5G18ZSOPfvVR2t9pL+ybsv8U5v9wPoG6wPAKFRkF3aeRTJkyBeP2ECgRkRKmAEMqhgIMERFY+++1LPyfhax5dE2P/cZj2PucvTn8q4fjm+SjubkZj8dDTU2YJUvg4Ydh2bJtl2HdmtcLU6fCLrs4ozUmTXKWap040fl6wgRntZCuLucWiTjbzk544w146SUnuOi+isjWAgGnt8XRR8P8+fTan8NmLM/f8TzP/OIZbGbLc/u0+dM46pqj8Aa8A/9HE3FZW1sbtbW1TJw4kVBvSZ2IiAAKMKSCKMAQEdni7aVvs/jaxby18K2eB7ww+/LZTDtrGhN2moCv23CKVMpp9rlokdMzY/360as3HIZ585zQ4rDDnPt96VjbwaNff5TmF7Y0yPCFfRz6/w5l5gdn6hNsKTvRaJRMJsPEiRMZO3as2+WIiJQsBRhSMRRgiIhs651l77Dkm0tYvWC1syMATALfZB9zz5rLnqfvice/7coH1jq9KFasgDVrttw2bChOXWPGwOzZsOeesM8+cMABzsiL/qTjaVbes5Knb36adDRd2D9pziSO/tbRjNlxTD+PFildmUyGtrY2TSMREdkOBRhSMRRgiIj07d3H3+XRrz7KW8+8BU25nVFo2LmBg686mKnzpg7oTVMsBm+/7dyam51RGs3NTrCxfj20tIDH4zTa7H6rrYUddoC99nJCi6lTB77aSaw1xit/foWX73yZRHuisN94DftfvD/7nr8vxqs3fFLeWltbqaurY9KkSQSDQbfLEREpSQowpGIowBAR6Z+1lifvepKlv1hKZFUEtgxiYMeDdmS/i/Zj8r6Th/XpbybjBBjF+AC5Y20HL/z+BV6/7/UeK6yAE7wcfd3RTNhjwvC/kUgJiEajZLNZJk6cSGNjo9vliIiUJAUYUjEUYIiI9C+ZTLJhwwZaN7eybsE6nr31WVKRVI9zmmY1sdfH92K343brdWrJSEvH07yz9B3eeOAN3l76NmR7Hq+bUsfeH9+bWR+ZhS84Cmu8ioySdDpNR0cHTU1NTJo0SdNIRER6oQBDKoYCDBGR/nV0dLBx40YymQx1dXXEWmM8/fOnefWeV7cJCkJNIfY8a0/2OG0Pgg0jO5w9m8qy9om1rH5wNWsWryEdS29zzvjdx7PP+fsw7dhpmi4iFSs/jWTy5MnU9Lb8johIlVOAIRVDAYaISP+am5vZuHEjtbW1BLp1zGxb08aLf3iRVX9ftc1UDY/fQ+OujTTs0kDDzg3O1zs7XwfGBIb0KXEqlmLz65vZ9OomNr68kXcee4dkR7LXc3c6ZCfmfGIOO8zdQZ9IS8WLRCIATJgwQdNIRER6oQBDKoYCDBGRvuWnj7S1tTFu3Lhew4B4W5yVd6/k5bteJrYptt1remu8hMaHCDeFCY8PExofIjQ+hMfXy9STLLS93camVzfRtqZtmxEf3TXs0sBuJ+7G9BOm07BzwyB+SpHylk6n6ezsZPz48ZpGIiLSCwUYUjEUYIiI9K2jo4Pm5may2Sx1dXX9nptNZVn90Gpe+sNLbHp106jUVzeljt3m78ZuJ+zGuBm9Bywi1aClpYX6+nomTZqkaSQiIluptgBD3b5ERKQqxWIxEonEdsMLcKaNzDh5BjNOnkG8PU77O+20v91O+zvttK1po/2ddjre7SCTyGz3Wr1/A2jctZGmWU007dHEpL0nMWHPCQotRICamhqSySTxeFwBhohIlVOAISIiVSeZTJJIJLDW4vf7B/XYYEOQ4N5BJu09qcd+ay3paJro5ijRzVFim2OFrc32Ptox3BSmaY8mxs8cjz80uDpEqkUgEKCrq4t4PE5Dg6ZQiYhUMwUYIiJSdWKxGMlkskfjzuEyxuCv9dNQ26A+FSJF5Pf7sdaSTCaL/v+tiIiUl9Ff0F5ERMRF1lri8TiJRIJgcGSXQxWR4ggEAiQSCeLxuNuliIiIixRgiIhIVek+fcTn00BEkXJQU1NDIpEgFouhBvQiItVLAYaIiFSV/OgLNQMUKR/5aSSJRIJkMul2OSIi4hIFGCIiUjWstYXVRxRgiJSX7qMwRESkOinAEBGRqpGfPgJo+ohImckHGPF4XNNIRESqlAIMERGpGvnVRzT6QqT8+Hw+jDEkEolCECkiItVFAYaIiFSF7quPKMAQKU81NTXE43FNIxERqVIKMEREpCrkP7U1xmj6iEiZqqmpIZlMEovFyGazbpcjIiKjTAGGiIhUBTXvFCl/Xq8Xr9fbo5+NiIhUDwUYIiJS8fLTR9T/QqT8aTUSEZHqpQBDREQqXiKRIJlMYozB6/W6XY6IDEN+Gkk8Htc0EhGRKqMAQ0REKl4sFiMej2v0hUgF8Hg8+Hw+jcIQEalCCjBERKSiZbNZLZ8qUmE0jUREpDopwBARkYqWXzo13/xPRMpfIBAglUqRSCTIZDJulyMiIqNEAYaIiFS0aDRKIpEgGAy6XYqIFInH48Hv92sUhohIlVGAISIiFSudTpNIJEilUpo+IlJhNI1ERKT6KMAQEZGKlW/eGQgEMMa4XY6IFFEgECiElOl02u1yRERkFCjAEBGRihWNRrX6iEiFMsYQCAQ0CkNEpIoowBARkYqUSCRIJBJYawkEAm6XIyIjIBgMEo/HiUajWGvdLkdEREaYAgwREalIsViMRCKh0RciFczv92OtJR6Pk0wm3S5HRERGmAIMERGpONbawvQRrT4iUtmCwSCJRIJoNOp2KSIiMsIUYAyCMWZXY4zt5/anIVzzUGPMP40xLcaYqDHmBWPMlcYY70j8DCIi1SAWi5FMJvF6vXi9+nMqUsm6r0aSzWbdLkdEREaQz+0CytQK4N5e9r80mIsYY04B/grEgTuBFuBDwI+Bw4AzhlWliEiVyk8f0egLkcrn9Xrx+XyFEKO2ttbtkkREZIQowBia56211wznAsaYeuBWIAMcZa19Orf/a8AjwOnGmI9Zawc9qkNEpJplMpnCfHi9kRGpDt2beer/exGRyqUpJO45HZgA/CkfXgBYa+PAV3N3L3WjMBGRcpbvfeH3+/F49DQnUg0CgQDpdJp4PE4qlXK7HBERGSEagTE0OxhjLgbGA5uBx621LwzyGsfktg/0cmwJEAUONcbUWGsTQy9VRKS65KePhMNht0sRkVFijCn0wohGozQ0NLhdkoiIjAAFGENzfO5WYIxZBJxvrX1ngNfYPbd9fesD1tq0MeYtYE9gGrCyvwsZY57p45Amf4tIVUkmkyQSCTKZDH6/3+1yRGQUBYNBOjo6iMVi1NfXY4xxuyQRESkyja0dnCjwLWB/YGzudiTwKHAUsNAYM9CJl/mPBtr7OJ7f3ziUQkVEqlEsFiMej1NTU6M3LyJVxufzYYwhkUgQj8fdLkdEREZA1Y3AMMasAXYZxEN+b609F8Ba2wx8favjS4wx84HHgIOAi4CfFKPU3NZu70Rr7f69XsCYCKAx1CJSFay1hekj9fX1bpcjIi7o3swzFAq5XY6IiBRZ1QUYwGqcZUsHat32TshN+bgNJ8A4goEFGPkRFn1N0qzf6jwREelHfvSFx+PB56vGpzcRqampKTTyzWQyeL1et0sSEZEiqrpXeNbaY0fo0htz24FOIXkNmAvMBHr0sDDG+ID3AWngzWIVKCJSySKRCPF4nGBQ7X9EqpXH48Hv9xdGYYwZM8btkkREpIjUA6N4Ds5tBxo4PJLbntjLsSNwpn4s1wokIiLbl0qlSCQSpFIpampq3C5HRFzUfRqJiIhUFgUYg2CMOcgYE+hl/zHAVbm7v9vqWIMxZpYxZspWD/sLsAn4mDFmbrfzg8C3c3dvLlrxIiIVLBKJEIvF1LxTRAgEAlhrSSQSJBL6HEhEpJIowBic7wH/Mcb82Rjz49xtIbAQqAG+Zq1dvtVjTsVZBvU73XdaazuATwJeYJEx5jZjzP8BzwOH4AQcd47oTyMiUgGy2Wxhzrumj4gIOL0wNApDRGTgjDE7GWN+ZYxZZ4xJGGPWGGOuN8aMHeDjxxtjLjLG3GOMecMYEzPGtBtjHjPG/LcxpijZQ9X1wBim3+IEEgcAJwF+YANwF/BTa+3SwVzMWnuvMeZI4CvAR4Eg8AbwOeAGa+12VyAREal2+ZVHvF6vmneKCOBMI2lrayMWi1FfX69mniIi/TDG7AYsByYC9wGvAgcCnwVONMYcZq3dvJ3LnIEzg+A94FHgHWAScBpwG3CSMeaM4b7HNXqPXLmMMZFQKBTWpw8iUsmam5vZtGkToVBI/S9EpKCjo4NAIMCECRPUzFNEKlY4HCYWi0WttQNdTGIbxpgHgfnAZ6y1N3bb/yOcVgm3WGsv2c41jsFZ0OIf1tpst/2TgSeBqcDp1tq/DrVO0BQSEREpY8lkkkQiQSaTIRDYpkWRiFSxYDBILBYjGo2iD+xERHpnjJmGE16sAW7a6vA3gAhwnjGm34DEWvuItfZv3cOL3P71wM9zd48abr0KMEREpGzlm3cGg0E17xSRHvLNPOPxOPF43O1yRERK1TG57YJewodOYBnOCpkHb/3AQUjltulhXANQgCEiImUqm80W+l+oeaeI9CYUChGPx4lEIm6XIiJSqnbPbV/v4/iq3HbmUC5ujPEBn8jdfWAo1+hO3c5ERKQs5Vce8fl8atAnIr2qqakp/K1IpVL4/X63SxIRGQlBY8wzvR2w1u6/ncc25LbtfRzP728cQl0A3wX2Av5prX1wiNco0AgMEREpS/npI6FQyO1SRKREeTyewpKqGoUhIjIk+Tm6g24mZIz5DPB5nFVNzitGMRqBISIiZScej5NIJLDWqnmniPQrGAzS3t5ONBqlvr4ej0ef34lIxYkPYKRFX/IjLBr6OF6/1XkDYoy5HPgJ8ApwrLW2ZWjl9aS/4CIiUnai0WiheaeISH98Ph8+n494PI6WlhcR2cZruW1fPS5m5LZ99cjYhjHmSuCnwEvA0bmVSIpCAYaIiJSVTCZDLBYjmUwqwBCRAck389SSqiIi23g0t51vjOmRDxhjxgCHATHgiYFczBjzReDHwPM44UVz8UpVgCEiImWmq6uLeDyO3+/XUHARGRC/399j5SIREXFYa1cDC4Bdgcu3OnwtUAv8xlobATDG+I0xs4wxu219LWPM13Cadj6DM21kU7HrVQ8MEREpG9lsttC8s76+fvsPEBEBjDEEg8FCM0+N3hIR6eEyYDlwgzHmWGAlcBBwNM7Uka90O3fH3PG3cUIPAIwx5wPfBDLAUuAzxhi2ssZae8dwClWAISIiZSO/HKLX68Xn01OYiAxcMBiktbWVeDxOOp3W3xARkRxr7WpjzFycAOJE4GTgPeAG4NoBNuB8X27rBa7s45zFwB3DqdVoHmDlMsZEQqFQWA2rRKQSWGtpbm5m06ZN1NbWavURERm0zs5OfD4fTU1NNDT01XBfRKR8hMNhYrFY1Fpb63Yto0GTh0VEpCzEYjHi8TiAwgsRGZJQKEQsFiMajZLNZt0uR0REBkkBhoiIlIWuri6i0SihUMjtUkSkTPl8PjweTyHEEBGR8qIAQ0RESl48Hi/MW6+pqXG7HBEpY7nh1nR1dWlJVRGRMqMAQ0RESl5+5ZFQKEQvHa1FRAYsPwUtHo9rFIaISJlRgCEiIiUtlUoRi8VIJpNa+lBEiiIcDhONRjUKQ0SkzCjAEBGRktbV1UUsFqOmpgaPR09bIjJ8NTU1ZLPZwvQ0EREpD3olKCIiJSuTyRCNRonH42reKSJF1X0UhoiIlAcFGCIiUrIikQjxeBy/34/X63W7HBGpIDU1NaTT6R5LNIuISGlTgCEiIiUpm80Wpo+Ew2G3yxGRCmOMIRQKFVYkERGR0qcAQ0RESlJ+9IXH48Hn87ldjohUoFAoRDKZJBaLkUgk3C5HRES2QwGGiIiUHI2+EJHRkB+FoV4YIiLlQQGGiIiUnEgkQiwWwxhDIBBwuxwRqWDBYLAwCiOVSrldjoiI9EMBhoiIlJRsNktnZyfRaJTa2lq3yxGRCufxeKipqVEvDBGRMqAAQ0RESkp+6ojX68Xv97tdjohUgVAoRDweJxqNkk6n3S5HRET6oABDRERKhnpfiIgbvF4vNTU1RKNROjo63C5HRET6oABDRERKhkZfiIhbwuFwYRRGMpl0uxwREemFAgwRESkJmUymEGCo94WIjDaPx0MwGCQSidDZ2el2OSIi0gsFGCIiUhLy4YXP58Pn87ldjohUoVAoRDKZJBqNkkgk3C5HRES2ogBDRERcl8lkCkunqveFiLjF4/EQCoXUC0NEpEQpwBAREddp9IWIlIr8KIxYLEYsFnO7HBER6UYBhoiIuCo/+iIajWr0hYi4zhhDOBwu9MKw1rpdkoiI5CjAEBERV3V2dhKLxfD7/Rp9ISIlIRgMkslkNApDRKTEKMAQERHXJJNJurq6iEajWnlEREqGRmGIiJQmBRgiIuKajo4OIpEIwWAQr9frdjkiIgXBYBBrLbFYjEgk4nY5IiKCAgwREXFJLBYjGo2STCYJhUJulyMiso3a2loikQhdXV1ks1m3yxERqXoKMEREZNRZa+no6KCrq4va2lo8Hj0diUjpCQQCGGOIRqN0dXW5XY6ISNXTK0YRERl1+b4X1lpqamrcLkdEpE91dXWFXhipVMrtckREqpoCDBERGVWZTIbOzk4ikQh1dXUYY9wuSUSkTz6fj5qaGiKRCB0dHW6XIyJS1RRgiIjIqOro6CAajeLz+fD7/W6XIyKyXeFwmGQySSQS0bKqIiIuUoAhIiKjpvsbAC2bKiLlwuPxEA6H6erqoqOjQw09RURcogBDRERGjZZNFZFyFQwGAQqrkoiIyOhTgCEiIqMiGo0SiURIJpOEw2G3yxERGTQ19BQRcZcCDBERGXHZbJb29vbCsqlq3Cki5UgNPUVE3KUAQ0RERlx7ezvRaBSPx1MYhi0iUo7U0FNExD0KMEREZETF43G6urqIRqPU1dW5XY6IyLCooaeIiHsUYIiIyIjJTx3p7OwkHA6rcaeIVITuDT07OztdrkZEpHoowBARkRHT0dFR6NYfCoVcrkZEpHi6N/RMJBJulyMiUhUUYIiIyIhIJBJ0dnZq6oiIVCSfz0coFKKzs5O2tjZNJRERGQUKMEREpOiy2SxtbW10dXURCoXw+XxulyQiUnShUAhrLV1dXbS3t7tdjohIxVOAISIiRdfZ2UkkEiGbzWrqiIhULGMMY8aMIRqN0tXVpVVJRERGmD4SExGRospPHYlEIjQ0NGCMcbskEZER4/V6CYfDdHZ24vP5CAQCalgsIjJCNAJjEIwxdxhj7HZuCwd4rV23c50/jfTPIyJSbJo6IiLVKBQKYYwhEoloKomIyAjSK8vBuRdY08ex84BpwL8Gec0Vuetu7aVBXkdExHX58CKTyTBmzBi3yxERGTVjxoyhtbWVrq4ugsEg4XDY7ZJERCqOAoxBsNbeSy9hgzGmEfgCkATuGORln7fWXjO8ykRE3NfV1VVYdaSxsVFTR0Skqng8Hmpra3tMJdEoNBGR4tIUkuI4DwgBd1trN7ldjIjIaEsmk7S3t9PZ2UldXZ3mf4tIVQoGg3i9XiKRCG1tbVhr3S5JRKSiKBYujk/mtr8YwmN3MMZcDIwHNgOPW2tfKFplIiIjLJvN0traSmdnJ4FAgJqaGrdLEhFxTV1dHW1tbYWRGI2NjW6XJCJSMRRgDJMx5hBgb+B1a+2jQ7jE8blb92suAs631r4zwBqe6eNQcAj1iIgMSr7vRTabVd8LEal6Ho+H+vp62tvbC1NJ1A9DRKQ4NIVk+D6V2946yMdFgW8B+wNjc7cjgUeBo4CFxpjaItUoIjIiuve9GDNmjPpeiIgAPp+P2tpaOjo6aG1tJZlMul2SiEhFMNU2N88YswbYZRAP+b219tw+rtUArMMZybJjMfpfGGN8wGPAQcCV1tqfDONakVAoFI5Go8MtS0RkG8lkko0bN9La2kptba2mjoiIbCU/Om3s2LE0NTWpP5CIFF04HCYWi0WttVXx4Xc1TiFZDcQHcf66fo6dC4SBPxWreae1Nm2MuQ0nwDgCGHKAISIyUjKZjPpeiIhsR21tbaHBsc/nY9y4cRqpJiIyDFUXYFhrjy3i5fLNO28p4jUBNua2VZGiiUh5yWaztLS00NHRob4XIiL9MMZQX19Pa2srPp8Pv99PfX2922WJiJStqgswisUYcxCwD07zzkVFvvzBue2bRb6uiMiwWGtpbW2lo6ODRCJBY2OjPk0UEelHvqlnR0cHXq8Xv99PKBRyuywRkbKkJp5Dl2/e2e/SqcaYBmPMLGPMlK32H2SMCfRy/jHAVbm7vytKpSIiRZIfCh2LxWhoaMDj0dOIiMj2+P1+wuEwHR0dtLS0kEgk3C5JRKQsaQTGEBhj6oGzgCTw6+2cfipwe+68C7rt/x6wZ27J1LW5fXOAY3Jff81au7xIJYuIDFtnZycdHR10dnZSX1+vZnQiIoMQCoXIZDK0t7djjGHChAn4/X63yxIRKSsKMIbm4zj9KYbTvPO3OOHGAcBJgB/YANwF/NRau7QYhYqIFEMsFqO9vZ2Ojg7q6ur0oltEZAjq6uro6Oigo6OjEGL4fHo5LiIyUFW3jGo10TKqIlIMiUSCTZs20dbWRjAY1NxtEZFhsNbS0dGBx+OhsbFRy6uKyLBU2zKqmrwsIiJ9SqVShRVH1HhORGT48iuTZDIZOjo62Lx5M9ls1u2yRETKggIMERHpVTKZZNOmTYX52rW1VRHsi4iMuHyIkUwm6ezspKWlBY2KFhHZPk26ExGRbSSTSTZv3kx7ezsAY8aM0XKpIiJF5PF4aGhooK2tDWMMxhjGjRunv7UiIv1QgCEiIj1sPfJC4YWIyMjIhxj5sNhay7hx47REtYhIHxRgiIhIQSKRKIy8UHghIjLyvF4v9fX1dHR0YK0thBhq7Ckisi0FGCIiAvQMLzweD3V1dQovRERGgc/nK4zEyGazhRBDS6yKiPSk8WkiIkIsFisslerxeDTyQkRklHm9XhobG0kmk7S1tbF582ZSqZTbZYmIlBQFGCIiVa6zs5PNmzfT1taGz+djzJgxbpckIlKV8j0x0uk0bW1tbNq0iWQy6XZZIiIlQwGGiEiVstbS2tpKS0sLbW1t1NTUUFdX53ZZIiJVLR9iWGtpb29n06ZNxGIxt8sSESkJmlgnIlKFMpkMLS0tdHV10dXVxZgxYwgEAm6XJSIiUGii3NXVRWtrK5lMhvr6eurr6zW9T0SqmgIMEZEqk0qlaGlpoaOjg0QiQUNDgxrFiYiUmHyIEYvFaGtrI5PJkEqlGDt2rFYoEZGqpVesIiJVJBqN0tbWRkdHB9lslsbGRjwezSYUESlVoVAIn89HR0cH6XSaTCbD2LFjNWpORKqSAgwRkSqQzWZpa2ujq6uLzs7OwpJ9GoosIlL6/H4/Y8eOpaOjg9bWVtLpNI2NjdTW1rpdmojIqFKAISJS4eLxOO3t7XR1dRGNRqmtrSUYDLpdloiIDEK+uWckEilMKclPA9SUEhGpFgowREQqlLWWjo4OOjs76ezsxFpLY2OjXuiKiJQpYwx1dXWFYDqZTBZCjHA47HZ5IiIjTgGGiEgFSiaTtLW1EYlE6OrqIhQKEQqFNGVERKQCBINBAoEAnZ2dtLS0kEqlqK2tVUgtIhVPAYaISAXJZDJ0dnbS1dVFJBIhlUpplRERkQqUn1ISj8cLq0rlR2OoN4aIVCq9ohURqQDWWiKRCJ2dnUSjUaLRKMFgkLFjx2rUhYhIBcuPxujq6qK1tZVUKkU0GqW+vp6amhq3yxMRKSoFGCIiZS6RSNDe3k40GiUSieDxeDSMWESking8Hurr60kkEnR0dBCPx4nH49TW1jJmzBj8fr/bJYqIFIUCDBGRMpVMJgsjLiKRCOl0mrq6OgKBgNuliYiIC2pqaggEAsRiMdra2ojFYsRisUKQoWBbRMqdAgwRkTKTSCQKS6JGo1GSySShUIgxY8ZouoiISJUzxhAOhwkGg0SjUVpaWojH40SjUerq6qitrVWQISJlSwGGiEiZSCQSdHZ2EovFCsFFvs+Fx+NxuzwRESkhHo+Hurq6QpCRH43R1dVFOBymtrZWU0tEpOwowBARKWHZbLYQWORffOZHXCi4EBGR7fH5fNTX15NKpQrPJ92X2K6rq1OzTxEpGwowRERKUDKZLEwRSSQSxONx0uk0oVCIcePGaaqIiIgMit/vx+/3k8lkiMVitLa2EolEiEQiBINBwuEwoVBI00tEpKQpwBARKRGZTKYwTznfQT6RSODxeAgGg9TX1yu4EBGRYfF6vdTV1REOh4nH47S3t9PV1UUwGKSmpqYQZgSDQT3niEjJUYAhIuKifGgRi8VIJBIkk8nCaIuamhrq6+vx+fSnWkREisvj8RRGXaRSKeLxOJFIhEAgQDAYJBAIEAqFCsGGwgwRKQV6VSwiMspSqVRhWkgikSgEF6lUCp/PVwgu9GJRRERGmjGGQCBAIBAgm82SSCSIRCJ0dnYSCASoqanB7/f3GKGhaSYi4hYFGCIiIyydTpNMJgthRSqVIplMkkwmSafT+P1+AoEAdXV1asopIiKu8Xg8hEIhQqFQ4bkrEomQyWQKIUf+VlNTU/haz10iMloUYIiIFJG1llQqVbjlg4r816lUCmttjyG6GmkhIiKlxufz4fP5CIfDZLPZQhDf1dWF1+sthO8+n2+bcEMjNETKjzFmJ+CbwInAeOA94F7gWmtt62hfp8/rW2uHew0pUcaYSCgUCkejUbdLEalI2WyWdDpNOp3uEVjk7+ePZbPZQvd3v9+vnhYiIlK2tg7qM5lMIdDIP8f5fL4ez3t+vx+v16vAXmQEhMNhYrFY1FpbO9RrGGN2A5YDE4H7gFeBA4GjgdeAw6y1m0frOv3Rq2gRkX5YawtBRSaT2SacyO/LZDKF/R6Pp/AiLr8knV60iYhIJejeMwOc58n8c2MsFiOdTgNbRnBs7+b1ejUFRcR9P8MJHT5jrb0xv9MY8yPgKuA64JJRvE6fNAKjgmkEhsj2ZbNZMpkMmUymx9cDvXm9Xrxeb48XY3ohJiIi1SybzW4T9mez2cLzZf65c3s3j8dT2Oq5VaR3wx2BYYyZBqwG1gC7WWuz3Y6NwZkCYoCJ1trISF9nezQCQ0QqQjabLYyW2Hq7vVsmk8FaW3iBld+X3xpjerygqqmpKXytkRUiIiI9eTweampqqKmpKezLP7/mA41EIlH4MMAY0yOs6B5adL/1tT//+O5fd9+KSL+OyW0XdA8dAKy1ncaYZcB84GBg4Shcp18KMEQEcIaADvRYf/d7+3og2/6+7uuWDyn6299XoJH/2hhTCCi6v0DKd1VXSCEiIjJ8+efY3vpAdf/wIH9LpVI9PmwACs/JvYUW+fv579V9X/7rgd6Afr/ubTvQrwdyf3v7RYps99z29T6Or8IJHmbSf/BQrOv0SwGGlL1kMsmmTZvcLqMiDHRK2UADjd6ut3VAsfV5Aw0z8vvyYcRQ5F/o5OfvioiISOkxxgz5ubqvcCL/GmDrkKKvYKK/4KL7eb09trdzBlq7FIfX66WpqamSV8gJGmOe6e2AtXb/7Ty2Ibdt7+N4fn/jKF2nXwowpOxlMhm3Sxi0Uus9M9x6hvPkLCIiIlItBvOaK39uqb6uKtW6etO9D4sMWv4/9HDfwBTlOgowpOyFQiECgUBheGG5Gck//uX0xCIiIiIiQzNSH46V2oduQ1UFq93EBzDSoi/5kRENfRyv3+q8kb5OvxRgSEXIN1QUERERERGRAXstt53Zx/EZuW1fvS2KfZ1+VXQMJSIiIiIiIiJ9ejS3nW+M6ZEP5JY/PQyIAU+M0nX6pQBDREREREREpApZa1cDC4Bdgcu3OnwtUAv8xlobATDG+I0xs4wxuw3nOkNlKmVek2zLGBMJhULhaDTqdikiIiIiIiJSZOFwmFgsFrXW1g71GrkwYjkwEbgPWAkcBByNM+XjUGvt5ty5uwJvAW9ba3cd6nWGSiMwRERERERERKpUbvTEXOAOnMDh88BuwA3AIQMNHYp1nf5oBEYF0wgMERERERGRylWMERjlRCMwRERERERERKTkKcAQERERERERkZKnAENERERERERESp4CDBEREREREREpeQowRERERERERKTkKcAQERERERERkZKnAENERERERERESp4CDBEREREREREpeQowRERERERERKTkKcAQERERERERkZJXtQGGMcZvjPmsMeZ2Y8zzxpikMcYaYy4awGPPN8Y8aYzpMsa0G2MWGWM+OMQ6inYtERERERERkUpVtQEGUAtcD1wATAbWD+RBxpgfAHcAU4Bbgd8BewN/M8ZcMZgCinktERERERERkUpmrLVu1+AKY0wAOBZ43lr7njHmGuAbwCettbf18ZhDgWXAauAAa21rbv+uwDM4ocgsa+2aAXz/ol2rn+8RCYVC4Wg0OtRLiIiIiIiISIkKh8PEYrGotbbW7VpGQ9WOwLDWJq21/7LWvjeIh12S216XDxxy11oD3ATUABe6cC0RERERERGRila1AcYQHZPbPtDLsX9tdc5oXktERERERESkovncLqBcGGNqgR2Brj5GbazKbWeO5rVy13umj0PhWCxGOBweyGVERERERESkjMRiMYCQ23WMFgUYA9eQ27b3cTy/v3GUr7VdsVhMTTCkWIK5bdzVKqSS6HdKikm/T1Js+p2SYtPvlBRbVX1aXdYBhjFmDbDLIB7ye2vtuSNUTl4xu6IO6FrW2v17258fmdHXcZHB0u+UFJt+p6SY9PskxabfKSk2/U5JsfUzGr8ilXWAgbOCx2DSy3XD+F75URENfRzf3qiKkbqWiIiIiIiISMUr6wDDWnvsKH6viDHmP8COxpgpvfSumJHbvj6a1xIRERERERGpBlqFZHAeyW1P7OXYSVudM5rXEhEREREREaloCjAG5+e57VeMMWPzO40xuwKXAwng9u4PMMZMMcbMMsZsPV1k0NcSERERERERqVZlPYVkuIwxXwJm5e7um9teaIyZl/v6MWvtbfnzrbXLjTE/Aj4HvGCM+QsQAM4CxgGfttau2erbfAc4H7gQuGOY1xIRERERERGpSsbaYi6aUV6MMYuAI/s55dfW2gt6edz5wBXAbCALPAt831r7917OvYNcgGGtvWM41xIRERERERGpVlUdYIiIiIiIiIhIeVAPDBEREREREREpeQowRERERERERKTkKcAQERERERERkZKnAENERERERERESp4CDBEREREREREpeQowRERERERERKTkKcCoMsZxvjFmkTGmxRgTM8a8ZYy5yxgz0+36pLwZY35pjLG523S365HyYoyZYYz5ojHmEWPMu8aYpDFmgzHmPmPM0W7XJ6XLGLOTMeZXxph1xpiEMWaNMeZ6Y8xYt2uT8mKMGW+MucgYc48x5o3c66R2Y8xjxpj/NsbotbMUhTHmvG6vmS5yux4pT8aYw40xfzXGvJd7/nvPGLPAGHOy27WNFJ/bBcjoMcYEgT8DHwReA/4AdAI7AIcDM4HXXStQypox5kPAfwFdQJ3L5Uh5+hZwFvAK8E+gBdgd+DDwYWPMZ621N7hYn5QgY8xuwHJgInAf8CpwIPBZ4ERjzGHW2s0ulijl5QzgZuA94FHgHWAScBpwG3CSMeYMa611r0Qpd8aYqcCN6DWTDIMx5qs4r502AX/H+bvVBOwHHIXzWqriGP39rR7GmJuAy4DvAF+11ma3Ou631qZcKU7KmjFmAvAisAiYDBwJzLDWvuFmXVJejDEXACustc9ttf9I4CHAArtaa99zoTwpUcaYB4H5wGestTd22/8j4CrgFmvtJW7VJ+XFGHMMUAv8o/vrJGPMZOBJYCpwurX2ry6VKGXOGGNwntPeB9wNXA180lp7m6uFSVkxxpwB3AU8DJxmre3c6njFvq/TMLgqkfuE6hLgKeArW4cXAJX6Sy6j4he57eWuViFlzVp7x9bhRW7/YpxwLAAcOtp1SekyxkzDCS/WADdtdfgbQAQ4zxhTO8qlSZmy1j5irf3b1q+TrLXrgZ/n7h416oVJJfkMcAxwIc7fKJFByU1l+x4QBc7ZOryAyn5fpykk1eNsnMDq10B9brj/VGAz8Ig+KZehyn1q/hHgVGvtZueDBZGiyz8Rp12tQkrNMbntgl7ecHYaY5bhBBwHAwtHuzipOPo7JMNijNkD+C7wE2vtktyIH5HBOhRnBM9fgFZjzAeAvYA48KS19nE3ixtpCjCqxwG5bQOwGhjf7Zg1xtyMM/w2M+qVSdkyxuwC/AT4nbX2XpfLkQqV+z07FueThiUulyOlZffctq/+TatwAoyZKMCQYTDG+IBP5O4+4GYtUp5yv0O/xemr8mWXy5Hyln9ftwF4Fti7+0FjzBKcqW4bR7uw0aApJNVjYm77TeBpnF/0MThvClbj9Mb4mjulSTnKDV/7NU4Dqs+4XI5UKGNMDfB7oAa4xlrb6nJJUloactv2Po7n9zeOfClS4b6L8wnnP621D7pdjJSlr+M0V7zAWhtzuxgpa/n3dZcAIeA4nPd1ewEPAkfgLNxQkRRglJHcsnB2ELffdXu4N7d9D2eo/0vW2i5r7SPA6UAW+JwxJjDaP5e4Z5i/U1fhNOv8pN5USt4wf6e2vpYX59Oqw4A7gR+M1s8hFSM/p00dy2XIjDGfAT6Ps8LNeS6XI2XIGHMgzqiLH1b68H4ZFfn3dQZnpMXC3Pu6l4FTgbXAkcaYQ1yrcARpCkl5WY0zt2mg1nX7Ov8G84GtU19r7QpjzFvAbsAewIphVSnlZEi/U8aYGcB1wO3W2opcokmGbDh/pwpy4cXvcJY0vAs4V8sWSi/yIywa+jhev9V5IoNijLkcZ6rkK8Cx1toWl0uSMtNt6sjraLSzFEf+fd2b1toe79ustbHc6lz/jbOkeMUFZgowyoi19thhPPw1nHnAbX0cz/+PEBrG95AyM4zfqT1xhvRfaIy5sI9zVuUaep6q/hjVY5h/p4DCi70/4IQXfwA+of480ofXctuZfRyfkdv21SNDpE/GmCuBHwMv4YQXze5WJGWqji1/o+J9NDu/1RhzK05zzytHqzApW/nnvrY+jlf0+zoFGNVjIfBpnLlRPeTmmOdf5K0ZxZqkfK0BftnHsQ8Ak3Hm3nWg3ykZhNw0truAU4DfABf2tuyzSM6jue18Y4yn+++KMWYMzvSjGPCEG8VJ+TLGfBGn78XzwPHW2k3uViRlLEHfr5nej9MX4zGcN6UV92m5jIglOKshzTDGBKy1ya2O59/vrRnVqkaJ0Yjc6pB7U7ASZ8mdE6y1D3U79m3gK8Bia+1R7lQolcIYswinN8YMLc8rg5ELU+8GTsZ5sfcphReyPbmhsvNxVtK6sdv+H+H06rnFWnuJW/VJ+THGfA2n6fkzwHxNG5GRYoy5BvgGTj+x21wuR8pIrofYx4HrrLVf7bb/eJxGnh3ArtbaNncqHDkagVElrLVJY8z5wALgX8aYe4C3cZbhOQLYCHzKxRJFRH6OE15sAv4DfL2XobaLrLWLRrkuKW2XAcuBG4wxx+KE9QcBR+NMHfmKi7VJmcm9VvomkAGWAp/p5e/QGmvtHaNcmohId5/Dea77ijHmCOBJYBecJp4ZnFCszb3yRo4CjCpirX3MGDMXJ+k9GmdZuQ3AL4BvWWvXulieiMj7ctsmnOXm+rJo5EuRcmGtXZ17bvsmcCJOCPYecANwrT49l0HK/x3yAlf2cc5i4I7RKEZEpDfW2mZjzEHAV3FCi4OBTuAfwHestRU7dVJTSERERERERESk5HncLkBEREREREREZHsUYIiIiIiIiIhIyVOAISIiIiIiIiIlTwGGiIiIiIiIiJQ8BRgiIiIiIiIiUvIUYIiIiIiIiIhIyVOAISIiIiIiIiIlTwGGiIiIiIiIiJQ8BRgiIiIiIiIiUvIUYIiIiIiIiIhIyVOAISIiIiIiIiIlTwGGiIiIiIiIiJQ8BRgiIiIiIiIiUvIUYIiIiEjZMsZMMsZkjDE3uF2LiIiIjCwFGCIiIlLOTsF5PXOP24WIiIjIyDLWWrdrEBERERkSY8y/gAOASdbajNv1iIiIyMjRCAwRERFxnTFmgTHGGmNO22q/McbckTv23a2ONQDHAH/bOrwwxtQZY75ujHnOGNOZe3xvt4kj/9OJiIhIMSjAEBERkVLw/4As8G1jjLfb/h8A5wO3Wmu/tNVjPgAEgLu778yFEk8B1+K81vk5cCOwPndKClgN/Nta21zkn0NERERGiKaQiIiISEkwxtyBE1ZcaK29wxjzZeA64C7gbGttdqvz/wycBDRZa+Pd9j8MHAv8H/Alm3uxY4yZCqwCvMAUa+2mkf+pREREpFgUYIiIiEhJMMbshBMwbMAZeXEj8CDwYWttcqtzg8BG4AFr7Rnd9h8PLACWAUf0Eno8BBwHHG+tfXgEfxwREREpMk0hERERkZJgrV0LXA/sghNeLAdO2zq8yJkP1LHt6iPn5rY/3jq8yGnPbfUaSEREpMzoyVtERERKycZuX/+3tTbax3mnAkngH1vtPxynl8YDfTxup9z2jSFXKCIiIq5QgCEiIiIlwRhzNs7UkXyzzc/2cZ4X+BDwiLW2vdt+D87ojWZrbaSXx03CWXL1LWvtm7l9ZxhjEsaYXbqd9xNjzOrc+SIiIlIiFGCIiIiI64wxJwO/Bl4G5gCvAhcZY2b1cvoRwHi2nT6Sb+w1JhdmbO0LOK99bum27y/Ai8BXc3VcDZwNnGit3TC0n0ZERERGggIMERERcZUxZh5OkLAWmG+t3Qh8DfAB3+3lIafhTBO5r/vO3GojK4BanBCi+/c4HbgSJxj5yVaP+TJwgTHmS8A3gA9Ya1cV42cTERGR4tEqJCIiIuIaY8w+wGIgBsyz1q7uduwpYC7OaiJLu+1/F1hjrT28l+t9BLgbSAN3Au/iTBs5DmeFkxOstW/18rjlwIHAh6y1/yraDygiIiJFoxEYIiIi4gpjzHScZVItTrCweqtT/ie3/X63xxyA04hz6+kjAFhr78Vp8Pk0zkiNK4EJwFeA9/cRXhwD7AMYnCVcRUREpARpBIaIiIiUDWPM/+IEG9N6CyOGcL38CJDPAR8A6qy1Jwz3uiIiIlJ8CjBERESkbBhjVgIJa+2+RbjWLsBy4BZr7TeNMXsBLwDHWGsXDff6IiIiUlwKMERERKTqGGPGAcuAJdbai7vtvxPY2Vp7iGvFiYiISK8UYIiIiIiIiIhIyVMTTxEREREREREpeQowRERERERERKTkKcAQERERERERkZKnAENERERERERESp4CDBEREREREREpeQowRERERERERKTkKcAQERERERERkZKnAENERERERERESp4CDBEREREREREpeQowRERERERERKTkKcAQERERERERkZKnAENERERERERESp4CDBEREREREREpeQowRERERERERKTkKcAQERERERERkZKnAENERERERERESt7/B900oyn0GkG/AAAAAElFTkSuQmCC\n", + "text/plain": [ + "
" + ] + }, + "metadata": { + "image/png": { + "height": 321, + "width": 536 + }, + "needs_background": "light" + }, + "output_type": "display_data" + } + ], + "source": [ + "# Ex \n", + "\n", + "fig, ax = plt.subplots(figsize=(8,5))\n", + "COLOR = {1:'black', 0.1:'blue', 0.01: 'purple', 10:'red'}\n", + "for ratio in [.01, .1, 1, 10]: \n", + " dat = ALLDAT[ratio]['x_line']\n", + " x0 = dat['x']\n", + " Ex0 = dat['Ex']\n", + " sigx = .001\n", + "\n", + " ax.plot(x0/sigx, Ex0/1e6, color=COLOR[ratio], label=f'{ratio}')\n", + " \n", + " \n", + "# Charge density \n", + "ax2 = ax.twinx() \n", + "ax2.fill_between(x0/sigx, 0, gauss(x0/sigx), color='gray', alpha=0.2) \n", + "\n", + "ax.set_xlim(-6, 6)\n", + "ax.set_ylim(-10,10) \n", + "ax.set_xlabel(r'$x/\\sigma_x$')\n", + "ax.set_ylabel(r'$E_x$'+' (MV/m)') \n", + "ax.legend(title='r')" + ] + }, + { + "cell_type": "code", + "execution_count": 12, + "id": "tough-howard", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "" + ] + }, + "execution_count": 12, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAABDAAAAKCCAYAAAAnRilSAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAADvSUlEQVR4nOzdd3hcxbnH8e9I2lWzJFtucsO9YmODbTCmN1OS0AmEEAIkuSlcSAhpBG6AhIQUAgHSQxKSACHBJCYQigGDAVewsTG49yrJsqy2vcz942hXxZKsstKupN/neeY558w5Z87IkqXdd2feMdZaRERERERERERSWVqyOyAiIiIiIiIicjQKYIiIiIiIiIhIylMAQ0RERERERERSngIYIiIiIiIiIpLyFMAQERERERERkZSnAIaIiIiIiIiIpDwFMEREREREREQk5SmAISIiIiIiIiIpTwEMEREREREREUl5CmCIiIiIiIiISMpTAENEREREREREUp4CGCIiIiIiIiKS8hTAEBEREREREZGUpwCGiIiIiIiIiKS8Xh/AMMZcaYx51BjztjGmyhhjjTFPHOWeucaYF40x5cYYrzHmA2PM14wx6e14fsLaEhEREREREempMpLdgRRwFzAdqAH2ApNautgYcwnwLOAH/gGUA58AHgJOAa5q7YMT2ZaIiIiIiIhIT2astcnuQ1IZY87CCVxsBc4A3gCetNZe18S1+bXXFQCnWGvfq63PAhYBJwOfstY+3YrnJqwtERERERERkZ6u108hsda+Ya3dYlsXybkSGAg8HQs41LbhxxnJAfDlVj46kW2JiIiIiIiI9Gi9PoDRRmfXbl9u4txbgBeYa4zJ7OK2RERERERERHo0BTDaZmLtdnPjE9baMLADJ6/ImC5uS0RERERERKRHUxLPtimo3VY2cz5W37cr2zLGrGrm1PG1W18r+iMiIiIiIiLdSzYQsda6kt2RrqAARmKZ2m0iMqMmoi0DkJ2dndPx7oiIiIiIiEgq8fl8AOnJ7kdXUQCjbWKjIgqaOZ/f6LouactaO7OpemOMJzs7O8fr9baiOyIiIiIiItKd5OTk4KuNYvQGyoHRNptqtxManzDGZACjgTCwvYvbEhEREREREenRFMBom0W12wuaOHc6kAMstdYGurgtERERERERkR5NAYy2mQ+UAdcYY2bFKo0xWcB9tYe/qX+DMabAGDPJGDOko22JiIiIiIiI9Fa9PgeGMeZS4NLaw6La7cnGmMdr98ustd8AsNZWGWO+gBN8eNMY8zRQDlyMsyzqfOAfjR5xGfBn4C/ADbHKdrYlIiIiIiIi0iv1+gAGMAP4bKO6MbUFYBfwjdgJa+0CY8wZwJ3AFUAWsBX4OvCItbbVq4Yksi0RERERERGRnszoPXLPpVVIREREREREeq7aVUi81trcZPelKygHhoiIiIiIiIikPE0hEQCi0Sjl5eVUV1cTCATQyJzuxRhDZmYmeXl5FBYWkpam2KSIiIiIiPQsCmAI0WiUPXv2oKkm3Ze1Fr/fj9/vx+PxMGLECAUxRERERESkR1EAQygvL8fr9ZKRkUFRURG5ubl689vNRKNRPB4PxcXFeL1eysvLGTBgQLK7JSIiIiIikjB6lypUV1cDUFRURF5enoIX3VBaWhp5eXkUFTkrAce+pyIiIiIiIj2F3qkKgUAAgNzcXpG4tkeLfQ9j31MREREREZGeQgEMiSfs1MiL7s8YA6AkrCIiIiIi0uPoHatIDxILYIiIiIiIiPQ0CmCIiIiIiIiISMpTAENEREREREREUp4CGCIiIiIiIiK9lDHmSmPMo8aYt40xVcYYa4x5op1tDTfG/MkYs98YEzDG7DTG/MIY0y8Rfc1IRCMiIiIiIiIi0i3dBUwHaoC9wKT2NGKMGQssBQYBzwEbgROBrwIXGGNOsdYe6khHNQJDREREREREpPe6DZgA5ANf7kA7v8YJXtxqrb3UWvsda+3ZwEPAROCHHe2oAhgiIiIiIiIivZS19g1r7RZrrW1vG8aYMcA8YCfwq0an7wY8wGeMMbnt7igKYEgvsXPnTowx3HDDDWzevJmrr76aQYMGkZaWxptvvpns7omIiIiIiHRnZ9duF1pro/VPWGurgSVADjCnIw9RDgzpVbZt28ZJJ53EhAkT+PSnP43P5yM/Pz/Z3RIRkQSy1hL7ECktTZ/ViIhIj5dljFnV1Alr7cwu6sPE2u3mZs5vwRmhMQF4vb0PUQBDepV33nmHO+64gx/96EfJ7oqIiHRQNBqluroav99PNOp82FM/eAHgdrvJz88nMzMzWd0UERHpDQpqt5XNnI/V9+3IQxTAkF5l8ODB3H333cnuhoiIdJDX66WqqgqPx4PP54sHLqy1GGMwxmCtJTMzE7/fT05ODvn5+bhcrmR3XUREJNH8XTjSor1M7bbdeTZAAQzpZaZPn65P4UREurFgMBgPXNTU1GCMIT8/n7S0tHjgIsZai8/no6KiAp/Ph8/nIzc3l7y8PDIy9BJIREQkgWIjLAqaOZ/f6Lp20V9v6VWKioqS3QUREWmHaDRKVVUVNTU1eDwegsEgubm5ZGVlNXuPMYacnByysrLwer0cPnwYn8+H1+slLy+PvLy8BgEPERERabdNtdsJzZwfX7ttLkdGqyiAIb2KXqiKiHQ/kUiEsrIyampq8Hq9ZGVl0a9fv1Yn6ExLS6NPnz5kZ2fj9XopLy8nHA5jraWgoLkPikRERKQN3qjdzjPGpNVficQYkwecAviA5R15iFJzi4iISMqKRqMcOnSIyspKAoEABQUF5Obmtmt1kfT09PjIi6qqKiorK6muru6EXouIiPRMxhiXMWaSMWZs/Xpr7TZgITAKuLnRbfcCucBfrbWejjxfIzBEREQkJVlrOXz4MNXV1QSDQfr27ZuQZVHdbjd9+vShsrISYwxpaWnk5uYmoMciIiLdjzHmUuDS2sPYnPuTjTGP1+6XWWu/Ubs/DNgA7MIJVtT3FWAp8Igx5pza604CzsKZOnJnR/uqAIaIiIikpIqKCqqrq/F6vQkLXsRkZmZirW0QxMjOzk5Y+yIiIt3IDOCzjerG1BZwghXf4CistduMMbOA7wMXABcBB4BHgHutteUd7agCGCIiIpJyqqurqaqqorq6moKCAtLT0xP+jKysLKLRaDyIMWDAAK1UJSIivY619h7gnlZeu5O6JVGbOr8HuDER/WqKAhjSK4waNQprO7TksIiIdBGv10tFRQVVVVWdvuRpTk7OEUEMt9vdac8TERGR9lMSTxEREUkZgUCAw4cPU1VVRW5ubpcEE/r06UN6ejpVVVUcOnSIcDjc6c8UERGRttMIDBEREUkJ4XA4vuKI2+0mKyury57dp0+f+JQVt9tN//79u+zZIp3FWkskECHkDTnFFyISjDQo0VDU2YajRCNRbMTWbcPRhiNYGw1mNemGtIw00tLTSMtIqzuOlfS0hsf1i6vhcbornXR3erzemGZHqItIL6YAhoiIiKSEyspKampqkrIqiDGGvLw8Kioq8Hg8ZGdnk5OT06V9EGlKyBvCc9CDp9SD96C3br/MS6AyQKCqttTbD3qC8aBF46BDd5HmSiPd7QQ1MjIznP3MeseZzjYjq4n9rIyWS7azdWW74seubJezzXHF602agigiqUYBDBEREUk6n8+Hx+OJL5eaDGlpaeTk5MRHYWRlZSV05RORxqLhKBW7Kji87TCVuyup2lt1RAlUBpLdzaSIhqJEQ1FCnlDS+pCemR4PaLhyGgY46h/H62Ml29XwuF5p6to0l0aciLSWAhgiIiKSVNZaqqqqqKmpIScnJ6lBg6ysLPx+Px6PJ74CikhH1ZTUULK2hNKPSinfWs7hbYcp31pOxc4KbKRzh0jE34Tn1I42iI1mqJ2uke5OJ92VXjcFJP3IbQOx99mWBlNNopGosw3Xq2tliYTqprJEQpFO/zdprUggQiQQwX/Y36nPMemm2YBH/WBIRk5Gi8GRowVL0l2JX81JpKspgCEiIiJJVV1djcfjwVqbEsuY9unTh8rKSqqrq8nOztaqJNJqNmo5uOEgB1YfoOSDEkrWllDyQQmeEk+720x3p5MzMIfcQbnkDsyN7+cMyCGrXxaZ+ZnxklWQhTvPTWZeZvwN7BEBiG7ARi2RUL1cHQFnGw6Ej9gP+8N1+4EwYX+9+nol5AsR8Ufi+2FfuMF+/W3IGyISiHTd1xuxBKuDBKuDnfqctIy0pkeBNBUoaWFEydFGnGhEiXQmBTBEREQkacLhMNXV1Xi9XvLy8lLiRW9GRgZZWVl4PB4qKysZMGBASvRLUo+/ws/eFXvZu6y2rNjb5ikfeUPz6De2H31H9SV/RD75w51SMKKA/OH5ZPfP7nU/fybNODktMpP3VsVGbTzAEfI2DG4csV8vSWrIE2r6XL36xqWrRpxEw9F4npTOdMSIkqMEQI4WUGkuaJKemd7r/m+IAhgiIiKSRJWVlXg8HlwuFy6XK9ndicvJyeHw4cN4vV48Hg99+vRJdpckBfgr/Ox8cyc7Fu1g5xs7Kf2otFVJMl05LgZNG8Tg4wbTf0J/CscVUjiukH5j+uHKSZ2fe6lj0urehNOJixJZa51cH00FN5oLhngbBkPC3vARwZP6JewLE/QEuyxQ0lUjSjA0PYKkca6SJqbeHG0USYPz2S4ldE0hCmCIiIhIUsQSdwYCAfr165fs7jRgjKFPnz7U1NTgcrnIzs4mPV3zx3ubkC/E7rd3s2PRDna8voMDqw9goy2/CcwdlMuwk4ZRNKOIwccNZvD0wfQb069bTuWQzmeMieckySro3KWjI6FIs0GSJgMkniYCJd4QQU+wwSiUZI0oweL0sQsSvTZO6DrzSzOZe/vcTn+uHEkBDBEREelyqZS4szlutxu/34/X66WyspLCwsJkd0m6gPeQly3/3cLGBRvZ9so2ZynSZph0Q9H0IoafPJzhJw9nxMkj6Du6r4a1S0pKd6WTXtB1gZKWRo3UHxkSv87XMFDS1PX1AyiRYNflKWmc0LW3rg6UChTAEBERkS4Xy3thrSUrq3NfTHdEbm4uFRUVeDwecnJyUrqv0n4VuyrY+O+NbFywkd3v7G72E2STZhgycwijzxnN6LNHM2LuCNy5SvIqUl8sUEInL+IUjURbnlrja3nESNgXbnoEShPTdhrT1K/kUQBDREREulQscafH40mZxJ3NSU9PJycnh5qaGjIzM8nMzEzp/krrhf1hNi7YyOrHVrPj9R3NXtd/Yn/Gnj+W0WePZtQZo8jqqyCWSCpIS0/D3ceNu0/nBhGtdRK61g9oZBdmd+ozpXkKYIiIiEiXqqqqwuv1plzizuZkZWXh8/nw+Xz4/X6ys/XCtTsrWVfC+398nw/+9gG+ct+RFxgYPmc4Ey+ZyKRLJjFg0oCu76SIpAxjjJP7ItulwEUKUABDREREukw4HI4HAlItcWdzjDFkZ2fj8/moqalRAKMbikairJ+/nuUPLWffin1HnDdphjHnjWHyFZOZ+ImJ9CnSqjMiIqko9TJmiSTZ3r17uemmmxg6dCiZmZmMGjWKr33taxw+fLjT2gmFQjz88MPceOONzJgxA7fbjTGGxx57LFFflohISqipqcHn85GZmZmSiTubk5WVRSgUwufzEQgoeVt3EQlGWP3H1fxq8q949ppnjwheFIws4Mzvn8lXd36V616+jplfmKnghYhICtMIDJF6tm3bxty5cyktLeWSSy5h0qRJrFy5kocffpiXX36ZJUuW0L//0RcDb2s7Ho+Hr33tawAMHjyYoqIi9uzZ01lfpohIUkQiEbxeLz6fj759+ya7O23SeBRGZmZmsrskLQh5Q6x+bDVLf7aUqr1VDc6lu9OZdOkkjv/88Yw5ZwwmTTlNRES6CwUwROr5yle+QmlpKY888gi33HJLvP7rX/86Dz30EHfeeSe//e1vE95OTk4OL774IjNmzGDIkCHcc8893HvvvYn94kREkszj8eDz+XC5XKSnpye7O22WlZXF4cOH8fl8BINB3G6tPpFqwv4wKx5dwdKfLcV70NvgXFbfLE685UROvOVEcgfmJqmHIiLSEcbappeJku7PGOPJzs7O8Xq9LV63YcMGACZPntwV3UpZ27dvZ+zYsYwaNYpt27Y1GNpcXV3NkCFDsNZSWlpKbm7zL3wS0U4sgPGHP/yBz3/+8236OvT9FJFUFI1GKSkp4dChQ+Tl5XWL5J1N8Xg8WGsZMGAAhYWFye6O1LLWsn7+el779mtU7KhocC53cC4nf/1kZn1pFpn5GjkjIj1LTk4OPp/Pa63tFZHZ7jP5VKSTLVq0CIB58+YdMS87Ly+PU045Ba/Xy/Lly7ukHRGRniQ2dSQtLa3bBi8AsrOzCQQC+Hw+QqFQsrsjwL539/H46Y8z/5PzGwQvCkYWcNGvLuKrO77KKd86RcELEZEeQAEMkVqbNm0CYMKECU2eHz9+PACbN2/uknZERHoKa218+khOTk6yu9MhaWlpZGZm4vV68Xg8ye5Or1a1t4p/X/9vHjvxMXa/szten90/mwt/eSG3bLmF2V+ZjSu7+wbMRESkIeXAkKO613SfXAx327vbfW9lZSUABQUFTZ6P1VdUVHRJOyIiPYXP58Pn8wH0iLwR2dnZVFRU4PF4yMvL65b5PLozG7Ws/NVKXv/O64S8daNg0lxpnHjLiZx+1+lk99NStyIiPZECGCKtFMsXY0zHspUnqh0Rke4itnRqdnbPeFOZnp6Oy+XC7/dTU1PTbMBaEq9iZwXP3fQcO9/Y2aB+0qWTOPen59J//NFXChMRke5LAQyRWrEXoLERFI1VVVU1uK6z2xER6Qn8fj8+n49IJNKjlh7NycmhqqoKj8dDnz59NAqjk1lref+P7/PKba8QrAnG6wdNHcQFj1zA6LNGJ7F3IiLSVRTAkKPqyLSM7mTixIlA87kptmzZAjSf2yLR7YiI9AQ1NTX4/X6ys7N71MizjIwMMjIy8Pl8eDwe8vPzk92lHqt6fzX/+fx/2PrS1nidSTOc8u1TOOPuM8jI1MtZEZHeQr/xRWqdddZZACxcuJBoNHrE8qdLliwhOzubOXPmdEk7IiLdXTAYxOfzEQwG6dOnT7K7k3DZ2dnU1NTER2E0XnlKOm79/PU8/4Xn8Vf443X9J/Tn0r9eyvCThiexZyIikgz6SytSa+zYscybN4+dO3fyq1/9qsG5u+++G4/Hw/XXX09urrPEcigUYuPGjWzbtq1D7YiI9FQ1NTV4vV6ysrJ61OiLGJfLhTGGQCCA3+8/+g3SapFQhJdve5lnrnqmLnhh4KSvncQX3/+ighciIr2UiSUUlJ7HGOPJzs7O8Xq9LV63YcMGACZPntwV3Upp27ZtY+7cuZSWlnLJJZcwefJkVqxYwRtvvMGECRNYunQp/fs7CcJ27tzJ6NGjGTlyJDt37mx3OzE//vGP2bhxIwBr1qxh7dq1zJ07N77s6qmnnsrnP//5o34N+n6KSCoIh8OUlJRQXl5Ov379euzoBL/fTzAYZMCAAQwYMCDZ3ekRqvdX88wnn2HPkj3xur6j+nLJ45cw6oxRyeuYiEgKysnJwefzea21veLTUU0haSNjzA3An49yWdRae9RsXsaYncDIZk6XWGuL2tY76aixY8fy3nvv8b3vfY+XX36ZF198kSFDhnDrrbdy9913U1hY2GntvPzyyyxevLhB3dKlS1m6dGn8uDUBDBGRVODz+fD7/bjd7h4bvADIzMzE4/Hg9/sJhUK4XK5kd6lb27l4J/Ovno+nxBOvm3jJRC59/FKy+mYlsWciIpIKNAKjjYwxM4BLmzl9GnA28F9r7cdb0dZOoC/wiyZO11hrH2hPH+u1rxEYvZC+nyKSbNZaSktLKSsrIzc3F7fbnewudaqamhrS0tIYOHCgVphqJ2stSx9Yyut3vI6N1C43nmY4+0dnc8o3T8Gk9bwpSCIiiaARGNIia+0aYE1T54wxy2p3f9+GJiustfd0rFciIiKpIxgM4vf7sdb2+OAFQFZWFtXV1fh8PvLz83tkvo/OFPQEWfDZBWx4dkO8LndQLlc8fYWWRxURkQYUwEgQY8xUYA6wD/hvkrsjIiKSNF6vl0AgQFZW7xjyn5HhvJyKJfPMzs5Oco+6j5qSGv7+ib+z/9398brhJw/nqmeuIn+YlqYVEZGGFMBInC/Wbv9orY204b5MY8x1wDGAB/gAeKuNbYiIiKSEaDSKz+cjEAjQt2/fZHeny2RlZeH3+/F6vQpgtFLZxjKevOhJKnZUxOtOvOVE5j0wj3T3UVOJiYhIL6QARgIYY7KB64Ao8Fgbby8C/taobocx5kZr7eKmbhAREUlVseBFRkYG6em9501oZmYmXq8Xv99POByOj8qQpu16axdPX/o0/sPOEqkmzXDhLy9k9pdnJ7lnIiKSyvTXNTE+iZOM87/W2j1Huba+PwNvAx8B1cAY4H+B/wFeMsacbK1de7RGjDGrmjnVO8buiohIyoi9ie8t00di0tLScLlc+P1+fD4feXl5ye5Sylr393U8d8NzRILOYFNXjosr/3ElEz4+Ick9ExGRVKcARmL8T+32d225yVp7b6OqD4EvGWNqgNuBe4DLOtw7ERGRLhAKheIjEHpD8s7GsrKy8Hg8eL1e+vTpo2SejVhrWfKTJbx+x+vxuj5FffjUC59i6MyhSeyZiIh0FwpgdJAxZgowF9gLvJigZn+LE8A4vTUXW2tnNtM3D5CToD6JiIi0KJa8MzMzs1e+eXe73dTU1OD3+3tVEtPWsNby6rdeZdkDy+J1A6cM5NoXr6XvyL7J65iIiHQracnuQA/Q3uSdLSmt3faKtXxFRKT7s9bi8/l65fSR+uon8xRHU8GLUWeN4qYlNyl4ISIibaIARgcYY7KAz+Ak7/xjAps+uXa7PYFtioiIdJrYqANjTK9OYJmVlUUwGMTv9xOJaEGxpoIXky6bxHUvX0dW394b6BIRkfZRAKNjrgL6AS82l7zTGOMyxkwyxoxtVH+sMaawietHAr+sPXwi0R0WERHpDL01eWdjjZN59mbNBS+u/MeVWiZVRETapfd+RJIYseSdv2/hmmHABmAXMKpe/VXAd4wxbwA7cFYhGQt8DGf1kBeBBxLcXxERkYSLRCL4/X6CwSC5uZr9mJWVhdfrjSfz7I2stbz27deODF48fSXpLgUvRESkfRTAaCdjzGTgVNqfvPMNYCJwPM6UkVygAngH+BvwN2utTUhnRUREOlFs9IXL5SItTYM7XS4XkUiEQCBAMBjsdSuyxIIXS3+2NF436dLa4IVGXoiISAcogNFO1toNwFFTrFtrdzZ1nbV2MbA48T0TERHpWrEAhkZfOIwxDZJ59rYAxuvffb1B8GLiJRM1bURERBJCH5OIiIhIuwUCAQKBANbaXvdGvSWZmZkEAgH8fj+9aUDlikdWsOTHS+LHEy+ZyFX/vErBCxERSQgFMEQa2bt3LzfddBNDhw4lMzOTUaNG8bWvfY3Dhw+3uo358+dzyy23cNppp5Gfn48xhuuuu64Tey0ikhw+n49AIEBmZmayu5JSYiuxxKaR9Abr56/n5a+9HD+e8PEJCl6IiEhCaQqJSD3btm1j7ty5lJaWcskllzBp0iRWrlzJww8/zMsvv8ySJUvo37//Udu57777WLt2LX369GH48OFs3LixC3ovItK1rLXx5VPz8/OT3Z2Uk5mZSTAYxOfz9fgAz663dvGv6/4FtYNNhs8ZrmkjIiKScBqBIVLPV77yFUpLS3nkkUdYsGABP/7xj1m0aBG33XYbmzZt4s4772xVOw899BCbN2+mqqqK3/zmN53caxGR5AgGgwQCAaBuxIHU6S3TSEo/KuXpS54mEogA0H9Cfz71/Kdw5biS3DMREelpFMAQqbV9+3YWLlzIqFGjuPnmmxucu/fee8nNzeVvf/sbHo/nqG2dddZZjB8/HmOOmudVRKTb8vl8BIPBHj+6oL0yMjIwxvToaSRVe6t48oIn8Vf4AcgdnMunX/40OQNyktwzERHpiRTAEKm1aNEiAObNm3fEMoB5eXmccsopeL1eli9fnozuiYiklPrTRxTAaF5sFIbP50t2VxLOX+nnyYuepGpvFQDuPm4+/eKn6Te6X5J7JiIiPZUCGCK1Nm3aBMCECROaPD9+/HgANm/e3GV9EhFJVZo+0jput5tgMNjjppFEghH+cdk/KF1XCkBaRhqffPaTDDlhSJJ7JiIiPZlecchRdadZEB15bVhZWQlAQUFBk+dj9RUVFe1/iIhID6HpI61TfxpJIBAgKysr2V1KiJe++hI739gZP774Txczdt7Y5HVIRER6BY3AEGml2CdnymshIr2dpo+0Tf1knj3B6sdWs+q3q+LHZ//wbKZ/ZnoSeyQiIr2FAhgitWIjLGIjMRqrqqpqcJ2ISG+l6SNtE1tOtSdMI9mzbA8v3vxi/HjqNVM59Y5Tk9gjERHpTfSqQ46qm7/WarWJEycCzee42LJlC9B8jgwRkd5C00faJj09vUdMI6neX80/r/gnkaCzXOrg4wbzicc+oZGJIiLSZRTAEKl11llnAbBw4UKi0WiDlUiqq6tZsmQJ2dnZzJkzJ1ldFBFJuvrTR/Lz85PdnW6j/mok3TGAEQ6E+eeV/6TmQA0A2YXZXL3gaty57iT3rHNFo+DzOdvYBzrW1u27XJCZCRqIJCLSNfTrVqTW2LFjmTdvHgsXLuRXv/oVt9xyS/zc3Xffjcfj4Ytf/CK5ubkAhEIhtm3bhsvlYuxYJS4Tkd5B00faJzMzk4qKCnw+H3379u12oxZeuuUl9i7bC4BJM1z5jyu77XKplZWwcyfs2uVsY/sHD0J1NdTU1G09nta1mZ4OWVlOMCMrC3JzoV+/ulJYWLcdOhSGD4dhw5x9DWQSEWk9vfIQqefXv/41c+fO5dZbb+X1119n8uTJrFixgjfeeIMJEybwwx/+MH7tvn37mDx5MiNHjmTnzp0N2lmwYAELFiwAoLi4GIBly5Zxww03ADBgwAAeeOCBrviSREQSStNH2ic9PZ20tDRCoVC3m0by3u/eY/UfVsePz/3puYw5d0wSe9Q61sLevfDuu3Xl/fehvDzxz4pEnGBHawMe9Q0a5AQzRo6EMWOcMnassx05UgEOEZH6FMAQqWfs2LG89957fO973+Pll1/mxRdfZMiQIdx6663cfffdFBYWtqqdNWvW8Je//KVB3fbt29m+fTsAI0eOVABDRLodTR/pmMzMTPx+f7eaRrJn6R5euuWl+PG0a6dx8tdPTmKPmmctbNgAL74Iixc7AYuSko63m50NaWnOsvKxgTOxbTjsTDHpSL6w0lKnvP/+keeMgREjYNKkhmXyZBg8uHstdS8ikgimu2fDluYZYzzZ2dk5Xq+3xes2bNgAwOTJk7uiW9LJ9P0Ukc4SCAQoLi6murq61QFdqROJRKioqKB///4MGTIk5aeR+A77+O3031K1x1mFq2hGETctuQlXjivJPavj9cIbbzhBixdfdKaDHE1WFowaVVdGjnS2Q4ZAXh706VO3zc11ghctsdYJZAQC4Pc7paYGDh92Snl53X5ZGezb55S9e+HAASe/RnsUFMDUqTB9ulOOOw6mTXP6LCK9R05ODj6fz2ut7RX/+zUCQ0RERFpF00c6Jj09nfT0dEKhEH6/n+zs7GR3qVnWWp7/wvPx4EVWvyyu/vfVKRG8CIXg+efhT3+C115zAgfNycuDmTNh9uy6MnJkYkcuGOMk83S5nKBHW4TDziiRPXuc4Mv27Q3Lnj3NBzgqK2HJEqfU78u4cTBjBpxwQl0ZMKC9X52ISGpRAENERESOStNHEsPtduP3+1M+gLH6sdVseHZD/PjiP15M31F9k9chnDf0jz3mBC6amxqSlwfz5sEFF8App8DEiUcfQZFMGRlO/othw6CpRc6CQefr3rjRKRs21O1XVR15vbWwZYtTnnmmrv6YY+qCGSee6ARyNIhKRLojBTBERETkqLT6SGJ0h9VIDm44yMtffTl+PPNLM5l8WXKmJYZCsGAB/P73zmiLpkyZAhddBB/7GMydC+4etLKr212X96I+a2H/fli7Fj74wNmuXQubNjU9YmP3bqfU5hcHnEShJ55YV44/3sn3ISKSyvQKRERERI5K00cSo/5qJKn47xn2h3n2mmcJ+8IADDx2IOc/eH6X9yMQgL/8Be6/v+m8FkOGwE03wY03Om/Eextj6kZuXHRRXb3PBx995CQEXb3aKWvXNj3NZts2p/z9785xRoaTS2POnLoydqwShYpIalEAQ0RERI4qEAgQDAbJy8tLdle6PbfbTTAYxO/3p1wA49VvvUrJB878jPTMdK74+xW4srsu74Xf70wT+clPnCSX9RkDF14I//M/zmgLDQQ6UnY2zJrllJhQyJl6smqVU1auhDVrnPr6wuG6a371K6euf38nkHHyyc7olhNPVJJQEUku/eoXERGRFsWmj1hrNX0kATIzM6mursbv91NQUJDs7sRten4TKx9dGT8+/8HzGTxtcJc82+uF3/0OfvYzZ2WO+vr3h5tvhs99zsnlIG3jcjkrlBx3nDNiBZwRGR984AQzVq6EFSuc6SeNHToE//2vUwDS051RGnPnOkGNU0/V90REupZehYiIiEiLAoEAoVAId09KLpBEGRkZRKNRgsEgoVAIlyv5K3tU76/muRufix9PvGQis748q4U7EiMahSefhG9/+8jAxaBB8M1vwpe+1PbVPaRlmZl1q7LcfLNTd/iwE8xYvtwJaCxf7tTVF4nUTU355S+dumOOgdNOqyuTJqV24lQR6d4UwBAREZEWxVYfycnJSXZXeoz600iSHcCw1vLv6/+N75APgLxheVz8x4s7PcHoypXw1a86b5TrGzoUvvUt+MIXQD9yXadfPzj/fKeAkyh082bn+7N0qVM++sipr2/3bicI9eSTznH//s4KMKed5ozQOOGEnpVYVUSSSwEMERERaVYkEiEYDBIOh5P+RrsnyczMxOfz4ff7k55XZPVjq9nx+g7nwMDlT1xOTv/OixwUF8Mdd8DjjzesHzIE7rrLSc6ZldVpj5dWMsZZhnbiRPjsZ526igpndMaSJU5AY9kyZ/pPfYcOwX/+4xRw8nLMmeMEM047zdlXKh0RaS8FMERERKRZsdEXbrc7JZf87K5cLhfV1dUEg0EikQjp6elJ6UfV3ipe/car8eO535jLqDNHdcqzQiH4xS/gBz+A6uq6ercbvv51+O539cY21fXt23CURijkrHjyzjvw9tvOtqys4T0+H7zxhlPAmV4yY4YzSuPUU50ydGhXfhUi0p0pgCEiIiLNUv6LzmGMweVyxROkJmN6jrWW/375vwSqnDU2C8cXcua9Z3bKs7Zsgeuuc6aN1HfJJfDAAzBuXKc8VjqZy+WsTHLiiU4QylrYuNEJZMSCGjt2NLwnGq3Lo/Hoo07d6NF1IzROPdXJo6F4qYg0RQEMERERaZK1Fr/fTzAYJFdrJyZc/TwYyQhgfPj0h2x+YXP8+OLHLk74kqnWwp/+5OS68Hjq6idPhocfhvPOS+jjJMmMcb63kyc7OUwA9u2rC2YsWQJr1x6ZR2PHDqf87W/O8YABdaMzTjsNjj/eCZaIiCiAISIiIk2Kjb5IT08nTcsKJJzb7cbj8eD3+7HWdukUHc9BDy/f+nL8eNZXZjHy9JEJfcahQ86b2H//u67O5YLvfx9uv11vSHuLYcPg6qudAlBZ6SQGjY3SWLHCmWZSX1kZLFjgFIDcXCd3Rmylk5NOcupEpPdRAENERESaVD//hSReWloa6enphEIhAoEAWV2YufLlr76Mt8zJvpg/Ip9z7z83oe2/+qqT+LH+0qiTJjkrVZxwQkIfJd1MQUHDPBrBoDOdpH4ejfLyhvd4PPD6604ByMhwfo5iAY1TT3VWPxGRnk8fp4jUM3/+fG655RZOO+008vPzMcZw3XXXJbtbIiJJofwXnc/tdhMIBPD7/V32zE3Pb+LDv38YP/747z5OZn5mQtqOROA734F58xoGL77yFVi1SsELOZLb7Yyu+MY34Lnn4OBBZ7nW3/3OyZsysomBQeGwk0/l5z+HSy91ppwceyx88YvwxBOwa9eR01REpGfQCAyReu677z7Wrl1Lnz59GD58OBs3bkx2l0REkiIYDBIMBrHWkpGhlwudxe12U11dTSAQ6JLn+Sv9/PdL/40fH/eZ4xh/4fiEtF1VBZ/6FLz4Yl3doEFODoyPfSwhj5BeIC0Npkxxyv/8j1O3Z48zOiNWPvroyPvWr3fK73/vHA8fXjc647TTnACHZsKJdH96RSJSz0MPPcTw4cMZN24cixcv5qyzzkp2l0REkiIQCBAMBjX6opNlZGRgre2yf+9Xv/kq1fudNUxzB+Vy/kPnJ6TdrVvh4othw4a6ugsvhD//GQYPTsgjpBcbMQKuvdYp4ORXWbq0LqDx3nvOqIz69u6Fv//dKeAsAXvKKXVBjVmzIDMxA49EpAspgCFSjwIWIiKOWP6LZKyO0du43W5CoRB+v79TAxg7F+9k9R9Wx48v+tVF5PTv+Pd30SK46qqGeQvuuAPuu0+feEvn6N8fPvEJpwB4vc6UklhAY9kyqKlpeE9FBfz3v04BJ3hx4ol1IzROPtkJcohIalMAQ0RERBqIRCIEg0HC4TAuLRXR6dxuN16vt1OnkURCEV68uW5ux6TLJjH5iskdbvfXv4Zbb3VyX4DzpvCPf4RPf7rDTYu0Wk4OnHmmU8AZjbF2bV1S0LffhtLShvcEAnUBj/vvd5aAnTat4bSTYcO6+isRkaNRAENEREQaqL/6SFcu7dlbuVyueNAoEomQnp6e8GesfHQlBz866Dwv18WFj17Yoe9tJOIELn7967q6oiInCeOJJ3a0tyIdk5EBM2c65WtfcxJ6btlSt3Tr2287057qsxY++MApv/qVUzdqlBPMOPVUZ/rJlCkaVSSSbApgyFF1pxevVimnRUQ6TKuPdC1jDC6XK74aSW5ubkLbr95fzZt3vxk/PvOeM8kflt/u9oJBZ3WIZ56pq5s5ExYscBIniqQaY2DCBKfcdJNTV1zccOnWNWsgGm14386dTnniCec4lkfjlFOcoMbs2dCFqx+LCApgiIiISD3WWvx+P8FgMOFvpKV5brebYDDYKQGMhbcvJFgTBGDglIGc9NWT2t2WzwdXXAEvvVRXd/XVzkojSpci3UlREVx5pVMAqqth+fK6oMby5c7Pe32N82i4XE4y0FhQ45RTYODALv0yRHodBTBEREQkLjb6Ij09nTSNle4ybrebmpoaAoEA0Wg0Yf/2Oxbt4MOnP4wfX/Sri0h3tW+KSlWVs9LI4sV1dbfeCg89pGH10v3l5cF55zkFIBSC1athyRKnvPPOkXk0QiEnYeiyZfDAA07dhAlOIGPuXGc7caL+f4gkkgIYclSaliEi0nvUz38hXSctLY2MjAxCoRDBYJCsBIxLjwQjvPi/dYk7p107jVFnjmpXW4cOOcuivvtuXd3//R/ce68zPF+kp3G54KSTnPL1rzs5MrZurcujsWQJbNp05H2bNzvlz392jgsLnRVOYiM0Zs3SaCWRjlAAQ0REROJiIzDy8vKS3ZVex+12x/NgJCKAsfzh5ZRtKHPaznNz3s/Oa1c7Bw7AvHnwYd1ADn76U/jmNzvcRZFuwxgYP94pN97o1B08CEuX1o3SeO89J0dMfeXlDaedZGTA8cc7IzRiRbljRFpPAQwREREBiH/6b60lI0MvEbqa2+2muro6IcupVu2tYvG9dXM9zrz3TPKGtj0otXs3nHNO3YoNxsBvfgNf/GKHuyjS7Q0cCJdc4hQAvx9WraoLaCxZ4oxeqi8cdkYyvfsuPPywUzdihBPIOPlkp8yYARoEJ13NGDMc+D5wAdAfOAAsAO611h5uQzsfA74KTKnXzirgQWvtso72U69OROpZsGABCxYsAKC4uBiAZcuWccMNNwAwYMAAHohNchQR6WECgQDBYBCXy5XsrvRKGRkZRKNRQqEQ4XC4Q0GkV77+CiFPCIBBUwdx4v+2fW3T0lI499y64EV6Ovz1r3Dtte3ulkiPlpVVN1UEnGknmzfXjdJYuhQ2bDjyvj174B//cEqsnVmznKDGnDlOUKOoqOu+Dul9jDFjgaXAIOA5YCNwIk4g4gJjzCnW2kMtNBFr5yfAt4BDOMGPMmAccAlwhTHmemvtEx3pqwIYIvWsWbOGv/zlLw3qtm/fzvbt2wEYOXKkAhgi0mPFVh9JxPQFaR+Xy0UwGCQQCLQ7gLH9te2sf2Z9/Lg9iTsrK+H882HLFufY7YZ//rPuk2YROTpjnCSeEyfWTTspL3dWOFm61CkrVoDX2/A+v78u10bMqFFOMCMW0NAoDUmwX+MEL2611j4aqzTGPAjcBvwQ+FJLDRhjioBvACXAcdba0nrnzgIW4Yzw6FAAwyhBY89ljPFkZ2fneBv/VmxkQ20oePLkyV3RLelk+n6KSHtEo1GKi4s5dOgQ/fr10wokSRILIg0cOJD+/fu3+f5oOMpvp/+Wg+sPAnDcdcdx2d8ua1MbXi9ccIGzlCQ4KyjMnw+Xta0ZEWmFcBg++KBuNZOlS2HHjqPfl5kJM2fWBTXmzHFyaSipbu+Tk5ODz+fzWmvbtQa3MWYMsA3YCYy11kbrncvDmQJigEHWWk8L7ZwELAf+Y609ItxtjKnCiT90KMmWRmCIiIgIwWBQy6emALfbjcfjIRAIYK3FtPHdyOo/ro4HL9x93Jz703PbdH8wCFddVRe8AHjsMQUvRDpLRgaccIJTbr7ZqSsudoIZy5c72/feA5+v4X2BQN0ojpihQ51VU+bMcbazZkFuu97SSi9zdu12Yf3gBYC1ttoYswSYB8wBXm+hnS1AEDjRGDPAWlsWO2GMOR3Iw5lW0iEKYIiIiEg8/4WWT02utLQ00tLS4glVMzMzW31voCrAG//3Rvz41DtOJW9I6z/oikTgs5+FF+tWXuXBB+uGvotI1ygqcoKGscBhKFQ3SiMW1Kid3dzA/v3w7387BZy8NVOnNgxqTJrkjKqSHifLGLOqqRPW2plHuXdi7XZzM+e34AQwJtBCAMNaW26M+TbwILDeGLMAJxfGWOBi4FWgwymgFcAQERGReACjT58+ye5Kr+d2uwmFQgQCgTYFMN758Tt4DzrTRvNH5DPntjmtvtdauOUWePrpurq77oLbbmt1EyLSSVwuZ7rIzJnwv//r1JWWOvkzli93ysqVUFPT8L5IBNaudcrvf+/U5eXB7NlOMOPEE53tkCFd+/VIyimo3VY2cz5W3/doDVlrf2GM2Qn8CfhCvVNbgcfr58VoLwUwREREerlwOEwwGCQajWr51BTgcrnweDz4/X7y8/NbdU/FrgqWPVi3Ot05PzoHV3brV5O5+25nedSYr3wFvv/9Vt8uIl1s0CD4xCecAk6wYv36uqDGihXw0UdOcLK+6mpYtMgpMcOHO8GMWJk5E1r5q0dSh78VIy3aKzaX8ajJM40x3wJ+BDwC/BIoBiYB9wNPGmNmWGu/1ZHO6FWKiIhIL1d/+dS25lyQxHO5XEQiEUKhEJFIhPT0o68gsui7i4gEIgAMnTWUaddOa/XznnoKfvCDuuNrr4VHH1UyQJHuJD0dpk1zyuc/79RVVTn5M1asqCvFxUfeu3evU/71L+fYGJg82QlmzJ7tbI87Tque9GCxERYFzZzPb3Rdk4wxZwI/Af5trf16vVOrjTGX4UxRud0Y81trbROToFpHAQwREZFeLhAIEAqFlP8iRRhjcLvd8eVUc3JyWrx+38p9rHtqXfx43s/nYdJaF31YtQo+97m64wsugMcf1xx5kZ4gPx/OPtsp4IzG2LPHmW4SC2isWnXkMq7WOqM51q93fh+AE7yYPr0uqDF7trM8bCviq5L6NtVuJzRzfnzttrkcGTEfr92+0fiEtdZrjFkJXAYcDyiAISIiIm1nrY2PwMhVuvqU4XK5WhXAsNay8PaF8eNJl01i5OkjW/WMkhK49FLw+2vvneTkwHC1fuaJiHQjxsAxxzjlyiudunDYCVSsXFlX1q2DaLThvcEgvPuuU2L69HGmm8QCGrNmwejRGr3VDcUCDvOMMWlNLKN6CuDDWSK1JbGkTQObOR+rD7a3o6AAhoiISK8WDAYJBoPx1S8kNbjdbnw+31GXU934743sfmc3AGkZaZz7k9YtmxoMwhVXOMPGAQoK4LnnnK2I9B4ZGc70kOOOq5t64vHA6tVOsGLlSmfb1KonNTWweLFTYvr3dwIZ9cuwYQpqpDJr7TZjzEKclUZuBh6td/peIBf4nbXWA2CMceGsLBKy1m6rd+3bwP8C/2OM+Z21dl/shDHmQpxAiB+ot/hv2ymA0Q61mVWb+3ijxFpb1Ia2hgPfBy4A+gMHcNbHvddae7hjPRUREWlZbPqISx+7p5RY3otgMNjs9J5IMMKr33o1fjz75tn0H9//qG1b66xksGSJc5yW5oy8mNDc4GER6VVyc+G005wSU1bm5NOIjcJ4992m82kcOgSvvOKUmMGDnUDGzJl126FDO//rkDb5Ck5g4RFjzDnABuAk4CycqSN31rt2WO35XcCoevXzgdeAc4ENxph/4yTxnIwzvcQA37HWHupIRxXAaL9K4BdN1Nc0UdckY8xYnB+UQcBzwEbgROCrwAXGmFM6+g0WERFpSWz6yNHyLEjXq7+calMBjJW/Wsnhbc5nHVl9szjje2e0qt3f/Ab+8Ie645/8xMl9ISLSnAEDnN8Tsd8V1sK+fXXBjFhwo6LiyHtLSuC//3VKzJAhdUvDxoqCGslTOwpjFnUfrF+E88H6IzgfrJe3oo2oMeYinFEc1+Dku8gByoEXgUestQtbaKJVjG28to4cVe0IDKy1ozrYzis4Q3VutdY+Wq/+QeA2nKE6X+pA+57s7Owcb+PMPI1s2LABgMmTJ7f3UZJC9P0UkdaKRCIUFxdTXl5OYWGhViBJMcFgEJ/Px8CBAxkwYECDc/4KPw+PeRj/YSeBxbwH53HybScftc0334TzznPmvQN8+tPwt79peLeIdJy1zlST996rK6tWOUu3tkZRUdNBDf1+allOTg4+n89rre0Viaw0AiNJjDFjcIIXO4FfNTp9N/A/wGeMMbfH5huJiIgkUmz6SEZGhoIXKcjlclFdXU0gECAajTbIUbLsoWXx4EW/Mf048eYTj9re7t1w1VV1wYuZM52RGPrWi0giGANjxzrl6qudumgUNm92AhmxgMbq1U6ejcaKi48cqTFoEJxwgvP7KrY95hj93urNFMBov0xjzHXAMYAH+AB4y1obaeX9tQsasbB+plcAa221MWYJToBjDvB6gvosIiISFwgEmp2eIMlnjCE9PT0+jSQ7OxsA7yEvyx+qSwZ/5r1nku5ueS3DUAg+9SlnHjs4c9IXLIDaJkVEOkVamrPC0aRJzogvgEjECWrERmmsXg3vv990UKO0FF5+2SkxhYVOMOP4453tCSfAuHFa/rm3UACj/YqAvzWq22GMudFau7ipGxqZWLttbj3dLTgBjAkogCEiIp0gNgIjW+9iU5bb7Y4vpxr7Pi37+TKC1c4qdAMmDWDqp6YetZ2774altXnf09Nh/nwYPrzTui0i0qz0dJg82Smf+YxTFwtqrFpVV95/31nppLHycnjtNafE9OkDM2Y4QY1YYGPKFC0L3RMpgNE+f8ZZJuYjoBoYQ+2SMcBLxpiTrbVrj9JGbKGyymbOx+r7Hq0zxphVzZzKOtq90tD8+fNZvHgxa9asYe3atVRXV/PpT3+aJ554otl7li5dyn333cfy5cvx+/2MGzeOm266iVtuuSWeRV5EJNWEQiFCoRAAGRl6OZCq3G53fBoJgOeghxWPrIifP+OeM0hLb/ljx4UL4cc/rjv+wQ/g1FM7pbsiIu1SP6hx3XVOXTQKW7Y4IzRWr66bflLZxLunmhp45x2nxLjdMHVqXVDj+OOd5WL79Omar0k6h16xtIO19t5GVR8CXzLG1AC3A/fgZF3tiNjMLmVZ7UL33Xcfa9eupU+fPgwfPpyNGze2eP1zzz3HFVdcQVZWFldffTWFhYU8//zz3HbbbSxZsoRnnnmmi3ouItI2sdVHtHxqasvIyCAajcaXU13ykyWEPE7gadC0QRx71bEt3l9c7HzCGcvZft558O1vd3avRUQ6Li0NJk50yqc+5dRZCzt21E07iQU3SkuPvD8YrDsfYwyMH183WmPGDKcUFXXBFyQJoQBGYv0WJ4BxeiuujcUOC5o5n9/oumZZa2c2VW+M8eAsXSOt9NBDDzF8+HDGjRvH4sWLOeuss5q9tqqqii984Qukp6fz5ptvMmvWLAB+8IMfcPbZZzN//nyefvpprrnmmq7qvohIq8Wmj2RmZia7K3IUsWkkh3Yf4t1fvRuvP/PeMzFpzWeyi0ScOeexF/ZFRc6KI5onLiLdlTEwZoxTrrzSqbMWDhyoC2rEys6dR95vrTNVZfNm+Oc/6+oHD64LZsTK+PHOyBBJLQpgJFYs9teaJWw21W4nNHN+fO22uRwZ0glaClg0Nn/+fA4ePMj1118fD14AZGVlcd9993HOOefwm9/8RgEMEUk50Wg0PgKjj8bSpjy3200gEGDZ75YR9jtLiBQdX8SkSye1eN/998OiRc6+MfDEE86LdBGRnsQYZ7nVoUPh4x+vqz98GNascQIba9Y4QY2NG53gbmMlJfDKK06Jyc6GadNg+nQnoDF9ujMFJS+vk78gaZECGIkVW4B9eyuufaN2O88Yk1Z/JRJjTB5wCuADljd1syTfotpXhRdccMER504//XRycnJYunQpgUBAn3CKSEqJTUfIyMhosDSnpCaXy0Xp7lLWPbvOmWBq4azvn9Xi0rdvv+0k7oy5804455zO76uISKro1w/OOsspMT4ffPhhXUDj/ffhgw/A6z3yfp8PVq50Sn1jx8JnPwv/93+d2n1phgIYbWSMORY4YK0tb1Q/Evhl7eET9epdwFggZK3dFqu31m4zxizEWWnkZuDRes3dizOK43fW2iYWFJJUsGmTM4hmwoQjB9FkZGQwevRoPvroI7Zv387kyZO7unsiIs1S/ovuJS0tjc0LNmOx4IJhxw9j/MfGN3t9WZkzXzxa+9HIaac1DGaIiPRW2dkwe7ZTYiIR2LbNCWrULwcONN3Gtm1QXd35fZWmKYDRdlcB3zHGvAHswFmFZCzwMZxVP14EHqh3/TBgA7ALGNWora8AS4FHjDHn1F53EnAWztSROzvtq2iLFj7hSTm263KeVtamQC4oaDqNSay+oqKiq7okItIqmj7SvVQfqGb7S9vBDWS2PPrCWvjCF2DfPue4f3946inQQjMiIk1LT4cJE5zyyU/W1ZeWwtq1Tlmzxtlu2OAEPKZPT1p3ez39OWu7N4CJwPE4U0ZygQrgHeBvwN+sbd276NpRGLOA7wMXABcBB4BHgHsbj/KQ7iX2Y9DSEF8Rka4WiUQIhUJEIhEtn9pNvP/Y++AHsqFoThFjzhvT7LVPPgkLFtQdP/44DB/e2T0UEel5Bg1yVm4677y6Or8f1q+HkSOT16/eTq9c2shauxhY3Ibrd1K3JGpT5/cAN3a8Z9LVYiMsKptajBpnlZL614mIpIL600cUYE19VXur2PT8JogC+XDCzSdgrW3ye7dvH/zv/9Ydf+lLDRPaiYhIx2RlwQknJLsXvZsyd8nRWdt9SheaOHEiAJs3H7lQTDgcZseOHWRkZDBmTPOflImIdLVYAk/lv+ge1vx5jRO8AAZOHMigGYMIBoNHXGctfP7zEIupjx4NP/tZ1/VTRESkKyiAIdJOZ599NgAvv/zyEefeeustvF4vc+fO1QokIpJSAoEAoVAIt9ud7K7IUdQU17D5hbog+fRrpxMMBgkEAkdc+9hjEPtzZIwzdUQpTkREpKdRAEOkna688koGDBjA008/zXvvvRev9/v93HXXXQB8+ctfTlb3RESOEA6HCYVCRKNR5b/oBtb+dS024owuLDqhiOEnDG8ygLFzJ3z963XHt90Gp5/ehR0VERHpInr1IlLPggULWFCb/ay4uBiAZcuWccMNNwAwYMAAHnjAWWQmPz+fP/zhD1x55ZWceeaZXHPNNRQWFvKf//yHTZs2ceWVV3L11Vcn48sQEWmSlk/tPrxlXjYu2Bg/Pv5zx5ORkdEgCWt6ejrRKNx4I9TUONdNmgT33ZekTouIiHQyBTBE6lmzZg1/+ctfGtRt376d7du3AzBy5Mh4AAPg0ksvZfHixfzwhz/k2Wefxe/3M27cOB588EFuvfVWJcgTkZSi6SPdxwdPfEA06CS/GHjsQIadOAxjDC6XKz4KIycnh1/+Et5807knLQ3+8hfIzk5ev0VERDqTaeWKn9INGWM82dnZOV6vt8XrNmzYAMDkyZO7olvSyfT9FJGmWGspKSmhrKyMgoIC0tPTk90laYa/ws/fP/53wv4wAPMemsfI05w1+7xeL9FolEGDBlFa2pcZM8Dnc+67806NvhAR6W1ycnLw+Xxea21usvvSFZQDQ0REpBeI5b8AFLxIceueWhcPXhROKOSYU4+Jn3O73YRCIXy+ADfcUBe8OO44+N73ktBZERGRLqQAhoiISC+g/BfdQ7A6yEf/+Ch+fPxNxzeYjpiRkUE0GuXZZ0O8+64T5HC54K9/Bc0MEhGRnk4BDBERkV4glv9CAYzU9tE/PyLkcUbK9B3Vl9Fnjz7iGp/Pxe9/HyQz01mN5DvfgenTu7SbIiIiSaEAhoiISA9nrVUCz24g5Aux7sl18eMZN83ApB2ZDPrPf3YTCIRwuwOMGQN33NGVvRQREUkeBTBERER6uGAwSCgUIi0tjbQ0/elPVRvmbyBQ5Yyq6DO0D+POH3fENWvXwvPPu3C5gmRmBnn0UatVR0REpNfQqxgREZEeLhgMEg6HNX0khYUDYdb+bW38eMaNMzDpDUdfRCJw//0QjaZjreGcc4Kce26oq7sqIiKSNApgiPQgWhZZRJoSS+Cp6SOpa9Nzm/CX+wHIHZTLhI9POOKaf/wDtm519tPS3Nx8c4hgMNiV3RQREUkqBTAknt08Go0muSfSUbEARv2M9SLSu0Wj0fgIjIyMjGR3R5oQDUf54K8fxI+P++xxpLsaLnV78CD89rd1x5/6lIt+/UIEAoGu6qaIiEjSKYAhZGZmAuDxeJLcE+mo2Pcw9j0VEYnlv0hPT1f+ixS17dVt1BTXAJDVL4tJl0w64pqHHgKv19kfPdoJYASDQQKBgEbfiYhIr6FXMkJeXh4AxcXFVFdXE41G9WKoG7HWEo1Gqa6upri4GKj7noqIxKaPKP9FarLWsvYvdbkvpl4zlYyshiNlVqyAhQvrjr/zHcjMTCM9PZ1QSNNIRESk99BYUqGwsBCPx4PX62Xv3r3J7o50UE5ODoWFhcnuhoikiNgIjJycnGR3RZqwd9leDm89DEBGdgZTrprS4HwoBD/5Sd3xhRfCzJnOvsvlIhRyppFo5J2IiPQGCmAIaWlpjBgxgvLycqqrqzUctRsyxpCZmUleXh6FhYUaJi4iAEQiEa1AkuLWPL4mvj/psklk5jcMRDz5JOze7ezn5sLXvlZ3zu124/V6lQdDRER6DQUwBHCCGAMGDGDAgAHJ7oqIiCRIbPSFy+VSct8UVPphKcWrnal/Jt0w7dppDc4fOgR/+lPd8Ze/DP371x27XK54kCoajSp4LSIiPZ7+0omIiPRQyn+R2urnvhh7/lj6FPVpcP5Xv6pL3DlmDFx1VcP7jTGkp6cTDoeVB0NERHoFBTBERER6qEAgQCgUwu12J7sr0kjFrgp2vrkzfjzjszManN+4EZ5/vu7461+H9IYrqwLOKIzYaiQiIiI9nQIYIiIiPVA4HCYUChGNRklv6p2vJNUHf/sAatNNjTh1BP3G9oufsxYefNDZApx6KsyZ03Q7sUSeGoEhIiK9gQIYIiIiPZDyX6Qub5mXLf/dEj+e/tnpDc4vWgSrVzv76elw223Nt9U4D4aIiEhPpgCGiIhIDxQMBpX/IkV9+PcPiYacYMOgaYMomlEUPxcMwsMP11179dUwcmTzbcXyYMSWUxUREenJFMAQERHpgQKBgJZPTUHBmiDr56+PH0//7PQGI2Seegr273f2CwrgC184eptut1vTSEREpFdQAENERKSHqZ//IiNDK6ankg3/2kDIEwKg76i+jDyjbnhFWVnDZVO/9CXIyzt6m0rkKSIivYUCGCIiIj1M/fwXkjoioQjrnloXPz7u+uMajL749a8bLpt6+eWtazcjI4NIJEIoFCISiSSyyyIiIilFAQwREZEeJhAIKP9FCtr2yjZ8ZT4AsgdkM+7CcfFzrV02tSnGGK1GIiIivYICGCIiIj1MMBhU/osUY61tMPpi6jVTSXel155ruGzqaac1v2xqc2LTSBTAEBGRnkwBDBERkR5E+S9S04FVByjfXA5ARlYGky+fHD+3ZEnDZVO/9rW2tx8bgaE8GCIi0pMpgCEiItKDaPpIalr3ZN3oi/GfGE9mfiYA0Sg8+mjddZdf3vKyqc1RHgwREekNFMAQERHpQZTAM/VU7q5k99u748fTPjUtvv/f/8K2bc5+Tk7rlk1tivJgiIhIb6AAhoiISA8SCAQUwEgx6/5eN/rimNOOoeCYAgD8fvjNb+qu+8xnoLCw/c/RcqoiItLTKYAhIiLSQ4RCIUKhENZa5b9IEYGqAFue3xI/nnZt3eiLp5+G0lJnv7AQrruuY89yu90agSEiIj2aAhgiIiI9hKaPpJ4N/9pA2B8GoHBCIUNmDQGgshIef7zuui9+EbKzO/as9PR0otGo8mCIiEiPpQCGiIhIDxGbPuJ2u5PdFQGioSgf/eOj+PG0a6dhjAHgj3+Emhqn/phj4JJLOv48YwwZGRmaRiIiIj2WAhgiIiI9hEZgpJZtr23De9ALQFZhFmPPHwvAgQPwzDN1191yCyRqxo8SeYqISE+mAIaIiEgPEMt/Ac5UAkkuay0fPvVh/Hjq1VNJdznfl1//Gmq/VRx3HJx5ZuKeG8uDoREYIiLSEymAISIi0gMEg0GCwaBGX6SI4jXFlG0oAyDdnc7kKyYDsGkTvPRS3XW33gq1s0oSIiMjI54HIxwOJ65hERGRFKAAhoiISA8QCAQIh8MKYKSID5+sG30x/mPjyeqbBcAjj9Rdc/rpMGNG4p+taSQiItJTKYAhIiLSzVlrlf8ihVTtrWLn4p3x46nXTgXgvfdgxQqnLi3NyX3RGVwulxJ5iohIj6QAhoiISDcXDoeV/yKFfPSPj8A6+8PnDqff6H5YC7/5Td01H/84jB7dOc93uVyEw2GNwBARkR5HAQwREZFuLhAIKP9Figh5Q2z6z6b48dRPOaMvli+HtWuduowM+MIXOq8PyoMhIiI9lQIYIiIi3VwwGFT+ixSx+b+bCXmc0TAFIwsYPmf4EaMvLr8chgzp3H7EppFoFIaIiPQkCmCIiIh0Y7H8FxqBkXzWWj56+qP48bHXHIsxhrfegvXrnTq3G268sfP7EkvkqTwYIiLSkyiAISIi0o3FVpswxij/RZLtXb6Xyl2VALhyXUz42IQjRl9cdRUMHNj5fVEeDBER6YkUwBAREenGtPpI6vjoH3WjLyZeMhFXjovXXoOtW5267Gy44Yau6YvyYIiISE+kAIaIiEg3pgBGaqjcU8med/Y4BwaOvepYIhH47W/rrvnUp6Bfv67rk/JgiIhIT6MAhoiISDcVy3+hAEbyrf/n+vj+iFNGkD8in5dfhl27nLrcXLjuuq7tk/JgiIhIT6MAhoiISDcVy3Gg/BfJFfKG2Pjcxvjx1GumEg7D739fd81110F+ftf2S3kwRESkp1EAQ0REpJsKBAIafZECNv93M2Gvk2ei76i+DDtpGM8/D/v2Oefz8+Haa7u+X8qDISIiPY0CGCIiIt1UMBgkHA4rgJFERyydevWxhEKGP/yh7pobbnCmkCSD8mCIiEhPogCGiIhINxTLfxEMBhXASKLGS6eO//h4FiyA0lLnfGGhs3RqsigPhoiI9CQKYLSRMaa/Mebzxph/G2O2GmN8xphKY8w7xpjPGWNa/W9qjNlpjLHNlOLO/DpERKR7U/6L1NB46VQyXDz+eN35G290lk9NFuXBEBGRniQj2R3ohq4CfgMcAN4AdgODgcuBx4ALjTFXWWttK9urBH7RRH1Nx7sqIiI9lfJfJF9TS6fWH33Rvz9cfnnSugccmQcjI0Mv/UREpPvSX7G22wxcDPzXWhuNVRpjvgusBK7ACWY828r2Kqy19yS6kyIi0rMp/0Xy1V869ZhTjyG7KJ8//7nu/A03QGZm1/ersdg0kmAwqACGiIh0a5pC0kbW2kXW2ufrBy9q64uB39YentnlHRMRkV5D+S+SL+QLsek/m+LHx15zLM891zD3RbJHX8TEEnkqD4aIiHR3CsMnVqh225a1yjKNMdcBxwAe4APgLWttJNGdExGRniEcDhMKhZT/Iom2vryVkMf5s19wTAGDjh/Gn79fd/6zn02N0RfgBDD8fr/yYIiISLenAEaCGGMygOtrD19uw61FwN8a1e0wxtxorV2ckM6JiEiPEggENPoiiay1DaaPTL5qMi+8YCgpcY779Uud0RegPBgiItJz6C9Y4vwYmAq8aK19pZX3/Bl4G/gIqAbGAP8L/A/wkjHmZGvt2qM1YoxZ1cyprFb2Q0REuhHlv0iukg9KKN9SDkBGVgZjLpjIHZ+pO3/99cldeaQpyoMhIiI9gXJgJIAx5lbgdmAj8JmjXB5nrb23NqdGibXWa6390Fr7JeBBIBu4p1M6LCIi3VYs/4VWIEmeDc9siO+Pu3AcC990U1y7+HnfvnDllcnpV0uUB0NERHoCheA7yBhzM/AwsB44x1pbnoBmf4sTEDm9NRdba2c20zcPkJOA/oiISIqI5b8AlP8iCXzlPra9ti1+POGyKfzsO3XnP/OZ1Bt9AcqDISIiPYNGYHSAMeZrwC+BD4GzalciSYTaHObkJqg9ERHpIZT/Irk2PrcRG7YADD5uMMu39Gf/fudcQQF88pNJ7FwLGufBEBER6Y4UwGgnY8y3gYeANTjBi9KW72iTk2u32xPYpoiI9ADKf5E8NmLZML9u+sj4yyfzxz/Wnb/uutQcfRFTPw+GiIhId6QARjsYY/4PJ2nnKpxpI2UtXOsyxkwyxoxtVH+sMaawietH4ozqAHgigd0WEZFuTvkvkmvXO7vwlHgAyOqXxabQ2Pjoi/x8uPrqJHauFZQHQ0REujvlwGgjY8xnge8DEZwVRG41xjS+bKe19vHa/WHABmAXMKreNVcB3zHGvAHswFmFZCzwMZzVQ14EHuiUL0JERLol5b9IrvpLp46/eBI/+Wvd50DXXQc5KZ51SnkwRESku1MAo+1G127Tga81c81i4PGjtPMGMBE4HmfKSC5QAbwD/A34m7XWdqyrIiLSkwSDQeW/SJLK3ZXsW7HPOUiD4oFT2bPHOczLS/3RF3BkHgwtpyoiIt2N/nK1kbX2HtqwvKm1didwxBANa+1inECHiIhIqwQCAeW/SJL18+tGX4w4dSR//nddsotrroHcbpJ2u34eDAUwRESku1EODBERkW5C+S+SI+wPs/n5zfFj76Tj2Va7kmp2thPA6C6UB0NERLozBTBERES6gVAopPwXSbL1la0Eq528EXnD83luyYD4uSuucJZP7S5cLhfhcFh5MEREpFtSAENERKQbUP6L5LDWNkjeaU6azUcfOTNDXS749KeT1bP2aZwHQ0REpDtRAENERKQbUP6L5Dj40UEObToEQHpmOot2jIqfu/hiGDgwSR3rgPp5MERERLoTBTBERES6AeW/SI4Nz26I72fMPp5Vq52XTmlpcP31yepVxyiAISIijRljhhtj/mSM2W+MCRhjdhpjfmGM6deOtk4zxjxrjDlQ29YBY8xCY8xFHe2n0k+LiIikOOW/SI5gdZBtC7fFj1d4psT3L7gAhg1LRq86zuVy4ff7OyWRp9/vp6KigqqqKqLRaLzemLoF2bKzsykoKCAvL4+0NH2WJiKSbMaYscBSYBDwHLAROBH4KnCBMeYUa+2hVrZ1F/ADoAx4ATgADACOB84EXuxIXxXAEBERSXEafZEcm1/cTCQQASA8cjQr3s+Mn7vxxmT1quPq58GIRCKtCor5/X527tzJ9u3b2bFjR3y7f/9+Kioq4qUtQRFjDPn5+RQUFNC3b1/69evH4MGDKSoqalCGDBnCiBEjKCwsbBAIERGRhPk1TvDiVmvto7FKY8yDwG3AD4EvHa0RY8xVOMGL14DLrbXVjc53+IWMAhgiIiIpLhAIKIDRxay1DaaPrM+dHd8/6ywYPToZvUqc2DSSQCBATk5OvN5ay44dO1izZg3vv/8+a9asYe3atezZsyfhfbDWUllZSWVlJbt37z7q9Xl5eYwePZpRo0bFt+PHj2fq1Kkcc8wxCm6IiLSDMWYMMA/YCfyq0em7gf8BPmOMud1a62mhnTTgJ4AXuLZx8ALAWhvqaH8VwBAREUlxsREY9d9oSucqWVtCxfYKADxZhazYmB8/d9NNSepUAmVkZBAKhaiurubdd9/ltdde46233mLNmjVUVVW1u12Xy0W/fv3Iz8+Pj+yw1sbPW2vxer1UVlZSU1PTprarq6v54IMP+OCDD444l5eXx9SpU+Nl2rRpHH/88fTt27fdX4uISC9xdu12obU2Wv+EtbbaGLMEJ8AxB3i9hXbmAqOB+cBhY8zHgKmAH1hprV2WiM4qgCEiIpLCYvkvrLXKf9GFNvyrbvTF1qK5RHc6n+7PmQOTJyerVx1nrWXr1q2sWLGCDz74gLfffrtVox/S0tI45phjGD16NGPGjIlvY1M7+vbtS9++fcnOzm71SIhwOExVVRWVlZVUVFRw6NAhSkpKKC4ublD279/Prl278Hia/eCP6upqli1bxrJlDV8fjxs3jlmzZjFz5kxmzZrFCSecQH5+fjOtiIh0W1nGmFVNnbDWzjzKvRNrt5ubOb8FJ4AxgZYDGLGhiiXAamBa/ZPGmLeAK621B4/SnxYpgCEiIpLClP+i6/kr/Wx/bTsA1eTw3p6i+LnPfS5ZvWo/ay3r16/nlVde4bXXXqO0tBSA/v37x3NgRCKR+PWFhYUcf/zxHH/88cyYMYMZM2YwYcKEhP8MZmRkUFhYSGFhYau+hrKyMnbu3MmOHTviZcOGDaxbt47Dhw83ed/WrVvZunUrTz/9dLxu8uTJzJ07l7lz53LyySczceJEJRMVkd6soHZb2cz5WH3fo7QzqHb7JWAHcC6wAhgJ/Bw4H3gGJ5FnuymAISIiksJiAQy3253srvQaW17YQjTojKLdVngi4XJnRMH06TBjRhI71gaxkRavvPIKCxcuZP/+/UdcEwqFyMjIYMKECZx++umce+65nHTSSQwfPjzl8kkYYxg4cCADBw5k9uzZDc5ZaykuLubDDz9k3bp1fPjhh6xZs4Z169YRDoePaGvDhg1s2LCBP/7xjwD069ePk08+mVNOOYXTTz+d2bNnk5mZecR9IiIpzN+KkRbtFfuDYFu8CmLDRA3OSIu1tccfGWMuwxnhcYYx5uSOTCdRAENERCSFxRJ4Kv9F16ifvNOPm7U1Y+PnbrgBUux9/RGqqqp4/vnnWbBgATt27Gjymvz8fE466SRmzZrF9OnTOe6447p1rghjDEOGDGHIkCGcd9558Xq/38+6detYtWoV7733HqtWreLDDz88Iqhx+PBhXnzxRV580VnZLysri5NPPpkzzzyTM844g5NOOomsrKwu/ZpERLpQbIRFQTPn8xtd15zYULjt9YIXAFhrfcaYV4DP4SzPmvwAhnFC9ecC5wGnA8fgrPfqA0qBNcAi4D/W2n2Jeq6IiEhPpfwXXe/AqgNU7nZeo212T8UfdKYWjBkDp56azJ41z1rLRx99xPz581m4cCHBYPCIa/r06cPZZ5/NvHnzmD17Nunp6YTDYaqrq5u8vifIyspi9uzZDUZseL1e3nvvPZYtW8bSpUtZunQpZWVlDe7z+/288cYbvPHGGwBkZmYyd+5czjnnHM455xxmzZpFRoY+AxSRHmNT7XZCM+fH126by5HRuJ2KZs7HAhzZretW00z9zNDtasCYHOBW4Is4QYvYZxN+oLy2g33r1YeB54GfW2uXdujh0iJjjCc7OzvH6/UmuysiItIOHo+HkpISgsGgEg92kde/+zrbF24nRBrPZF5PdcDJ+3DPPfDxjye3b435/X5efvll5s+fz8aNG484n52dzRlnnMH555/PnDlzjshhYa2lvLycwsJCioqKemWQLDbVZsmSJbz99tssXryYbdu2tXhPXl4eZ5xxRjygMXXq1JSbciMivUdOTg4+n89rrc1tz/3GmLHAVpxlVMfWX4nEGJMHHADSgIFHWUZ1QO21HmCQtTbY6PxLwAXAp6y1TzfRROv625EAhjHmRuA+YAiwEXgaWAK8a62tqnedwcluOgcnecclQCbOEivftNYePf21tJkCGCIi3dvhw4cpLS3F5XJpCHsX8B328eSFT2LDlvVM4m1OA2DQIHjuOUiVPKp+v5/58+fz17/+lfLy8iPOT5o0iSuvvJLzzz+f7OyWP+iqrKwkKyuLoqKio17bW+zdu5e33nqLxYsXs3jxYjZt2tTi9YMHD+bss8/m3HPP5ZxzzmHkyJFd1FMRkY4HMABqp3fMA2611j5ar/5B4Dbgd9baL9XWuYCxQMhau61RO08AnwZ+aK29q179ecArQBUwylpb0e6+djCAEQUWAPdba99tw335wGeB7+D8Y3y/3Z2QZimAISLSvRUXF1NWVkZ+fr6GrHeBNX9Zw7uPvksUeNb9KcqDfQC47Tb49KeT2zdwAhfPPvssf/nLX44IXLjdbs4//3yuvPJKpkyZ0uoRAV6vl2g0yqBBg7p1HozOtH//fhYtWsTrr7/O66+/zp49e1q8fty4cZxzzjmce+65nHXWWfTv37+LeioivVGCAhhjgaU4K4k8B2wATgLOwpk6Mtdae6j22lE4q4zsstaOatTOIJwBDeOAt4GVOKuQXIaTBPRaa+0z7e0ndDyAcYK1dnUH7s/CicAcOe5ROkwBDBGR7iscDnPgwAEqKir0BqgLWGv5x6X/oHpfNdsZxas4ySDz8uC//4Vk5lANBAL861//4vHHH+fQoUMNzg0ePJhrr72WT3ziE+2aZhQKhaipqWHgwIEMGjTo6Df0crEpJ7FgxqJFi5ocBRNjjOGEE07g3HPP5dxzz+WUU07RSBcRSahEBDAAjDEjgO/jTPPojzMdZAFwr7W2vN51o2gmgFF7vhC4CydoMQyoBt7BGfSwvCN9hATkwJDUpQCGiEj3pfwXXWvv8r289L8vYYEFaZdSGh0IwE03wVe+kpw+RaNRXnjhBX7zm99w8ODBBucGDRrE5z73OS6++OIjclu0hfJgdEw0GmXNmjW8/vrrvPbaa7z99tv4fL5mr8/MzOS0007j/PPPZ968eUybNk35M0SkQxIVwOguFMDowRTAEBHpvmL5LzIyMvSJbRd49VuvsnPRTvZRxAt8AgC3G154AQoLu74/7777Lg899BCbNzdM+j5o0CBuuukmLrnkkg4FLuqrrKwkOzubwYMH62etgwKBAMuWLYsHNFauXEk0Gm32+qKiIubNm8e8efM499xzGTx4cBf2VkR6AgUwOtqgMcNxEn3MAIYDTf11tdbasU3USwIpgCEi0n2VlJRw8OBB5b/oAt6DXp782JMQhRe5gD2MAODyy+G73+3avuzcuZOHH36Yt99+u0H9gAED+NznPsell16asMBFjPJgdJ7KykrefPPNeEBjw4YNLV5/3HHHcd5553Heeedx2mmnkZPMuUsi0i0ogNGRxow5E3gRyMJZLrWkdnsEa+3ohD1YmqQAhohI9xQOhykuLubw4cPKf9EF3v/j+7z3m/coox/PciUAxsC//gUjRnRNHyorK/nd737H/PnzG3xin5WVxWc/+1muu+66ThsdoTwYXWfv3r0sXLiQhQsX8uqrr7aYP8PtdnPKKadw3nnncc455zBz5kxN8RGRIyiA0ZHGjFkJTAc+BzxVfw1Z6XoKYIiIdE/Kf9F1bNTy9MVPU1Ncw+ucyVbGA3DOOfCTn3TB863l+eef5+GHH6aysjJeb4zh4x//OF/5ylcYOHBgp/fh0KFD9O/fX3kwulAkEmH16tUsXLiQV155hWXLlhEON/m5HwAFBQWcddZZnHPOOZxzzjlMmjRJ+TNERAGMDjVmjA/4h7X2hoQ1Ku2mAIaISPek/BddZ8+SPbz81Zeppg9Pcw1RnDeEf/sbTJ7cuc/eunUr999/P2vXrm1QP3PmTG677TYmTZrUuR2oR3kwkq+mpobFixfz6quv8uqrr7J+/foWrx86dChnn302Z599Nueccw7HHHNMF/VURFKJAhgdacyY/cDT1tqvJ6xRaTcFMEREuqeSkhLKysrIy8tT/otO9srXX2H3W7tZwsl8yFQAZs+G3/ym857p8/n4/e9/z5NPPtlgukhRURHf+MY3OOOMM7r8k/VYHozBgwdTUFDQpc+Wpu3bt4/XXnstvmTr/v37W7x+7Nix8WDGmWeeqYSgIr2EAhgdacyY3wMzrbUzE9aotJsCGCIi3Y/yX3SdmpIa/v6Jv+OLZvIUnyJcm3f80Ufh5JM755mLFy/mJz/5CaWlpfG69PR0PvOZz/C5z30uaaMflAcjtVlr2bhxYzyY8eabb1JRUdHiPZMnT+bMM8/kzDPP5IwzzlBAQ6SHUgCjI40ZMwBYDrwCfMta60lY49JmCmCIiHQ/Xq+X4uJi5b/oAqt+v4rVv1/NexzPKmYBMGECPPmkk8QzkaqqqvjZz37GSy+91KD+hBNO4I477mD06OTmNlcejO4llj9j0aJFLFq0iLfffhufz9fiPZMnT+aMM87g9NNP5/TTT2fYsGFd1FsR6UwKYHS0QWPGASsAN7AZqGziMmutPSehD5YjKIAhItL9KP9F17ARy1Mff4rKgwGe4lP4cf6t77sPLrggsc965513uO+++ygrK4vXFRYW8rWvfY0LL7wwZRIxKg9G9xUIBFi5ciWvv/46ixYtYvny5YRCoRbvGTNmTDyYcfrppzNmzJiU+VkUkdZTAKMjjRlzLPAGMOAol1prrUL7nUwBDBGR7kf5L7rGzsU7efX2V/mQKSzhFACGDIEFCyBRgw9qamp48MEH+c9//tOg/mMf+xjf+MY3yMvLS8yDEkR5MHoOr9fL8uXLefPNN3nzzTdZsWIFwWCwxXuKioqYO3cup5xyCnPnzuWEE07A7XZ3UY9FpL0UwOhIY8a8ApwL3A38BdhvrY0k7AHSJgpgiIh0L8p/0XVeuvUldi3dyz+4hmqcQMI3vwlXX52Y9lesWMH3v/99SkpK4nWFhYXcddddnH766Yl5SIIpD0bP5fP5WLZsGW+99RZvvfUWy5Ytw+/3t3hPVlYWs2fPZu7cucyZM4c5c+ZQVFTURT0WkdZSAKMjjRlTBbxirb0qYY1KuymAISLSvXi9XkpKSggEAsp/0YmqD1Tz9MVPs8WOYRHOjNaCAnjhBejozIlQKMSjjz7KU0891aB+3rx5fOtb36Jv374de0AnUh6M3iMYDLJq1Sreeust3n77bd555x0qK5ua9d3QyJEjOemkk+IBjRkzZmi6kUiSKYDRkcaMKQP+bK39ZsIalXZTAENEpHtR/ouu8e6v3+X9P63hWS7jUO2s1//5H6d0xO7du/nud7/Lxo0b43UFBQXccccdnHvuuR1rvIsoD0bvFI1GWb9+PUuWLImX7du3H/W+jIwMjjvuOE488URmz57NiSeeyOTJkxX8EulCCmB0pDFj5gMDrbVnJKxRaTcFMEREuhflv+h80XCUJy96ki3l/XmRiwDIzIT//hfaOzjCWsuLL77Ij3/84wYrQZx66ql873vfo7CwMAE97xqxPBiDBg1K6dEi0vmKi4tZunQpy5cvZ/ny5bz33ntHXekEIDc3lxNOOIGZM2fGtxMnTlRQQ6STKIDRkcaMGYOzAsnPgZ/YRC9xIm2iAIaISPeh/BddY8frO3jt26/xPBexH2cZyU9+Er71rfa15/F4+PGPf9xgeVSXy8VXv/pVrr766m63qoPyYEhzQqEQ69atY8WKFfGgxubNm1t1b25uLjNmzOCEE05g+vTpzJgxg2OPPZasrKxO7rVIz6cARkcaM+ZPwGjgdGAnsIbml1H9XMIeLE1SAENEpPvweDyUlJQQDAaV/6ITvfiVF1mzMsC/uAyAtDR47jlnBZK22rBhA3fccQd79+6N1x1zzDHcf//9TJw4MVFd7lLKgyFtUVFRwXvvvce7777LypUrWblyJfv372/Vvenp6UyaNCke0Jg2bRrTpk1j6NCh3S7wJ5JMCmB0pDFjoq28VMuodgEFMEREug/lv+h8VXuq+Mdl/+BVzmY7YwE4/3z44Q/b3tZ//vMffvzjHzdYmvLiiy/mm9/8Zrf//ikPhnTE/v37WbVqVYNy4MCBVt9fWFgYD2ZMmzaNqVOnMmXKFE1pEmmGAhgdacyYka291lq7K2EPliYpgCEi0n0o/0XnW/HICt7+6w7+wdVYnE94n3oKJkxofRuhUIif/exn/Otf/4rX5eTkcOedd3L++ecnustJoTwYkmgHDhxg9erVrFmzJl62bt3apjaGDh3KlClTmDJlCsceeyxTpkxh4sSJDBgwQCM2pFdTAEN6DAUwRES6B+W/6HyRUISnLnyKVytmsp4pAMyZA7/8ZevbKC0t5Zvf/CYfffRRvG7s2LE88MADjBgxItFdThrlwZCuUF1dzbp161i7di1r165l3bp1rFu3jurq6ja1U1hYyMSJE5k4cSKTJk1i4sSJTJgwgbFjx5KZmdlJvRdJHb0tgNHhj3iMMb8A/gW8raSdIiIibRcIBAgGg7hcrmR3pcfa+cZOyitgE3XDLT772dbfv2rVKr7zne9w+PDheN3555/PXXfd1eOmWWRkZBCJRAiFQkQiEeXBkE6Rl5fH3LlzmTt3brzOWsvu3bvjwYx169axfv16Nm7cSCAQaLKd8vJyli1bxrJlyxrUG2MYOXIk48ePZ/z48UyYMIFx48YxduxYRo8ereCGSDfV4REYxpgwYIBDwH9wghmvWWuDLd4onU4jMEREugflv+h8L3zxBf6zahirOR6AyZPhr3+Fo408t9by97//nV/84hdEo06qr7S0NG677TauueaaHjt0XXkwJJWEw2F27NjBRx99xPr16/noo4/YuHEjmzZtwuPxtLk9YwzDhw9n7NixDYIasaJpKdKd9LYRGIkIYAwCLgUuA84CXIAHeBH4N/CitbZtY8EkIRTAEBHpHkpKSjh48CD5+fnKf9EJKnZV8OQV/+ZJriWI86nrj38M557b8n2hUIj777+f//znP/G6wsJCfvzjH3PCCSd0ZpeTTnkwpDuw1rJv3754MCO23bJlC7t27aK973P69OkTD2aMGjWKkSNHxsuoUaPo37+/AhySMhTA6EhjxuQDH8cJZpwP9AECwOs4wYz/WGsPJuyB0iIFMEREUp/yX3S+ZQ8t46knYRknAzB8OPzrX84Sqs2pqKjgm9/8Ju+//368btq0afz0pz9l4MCBnd3lpFMeDOnuAoEA27dvZ/PmzWzZsoUtW7awdetWtm3bxp49e+IjqtojJyeHY445hmOOOYYRI0bES+x42LBh9OnTJ4FfjUjzFMBIVMPGZOIEMS7DCWr0ByLAUpxpJgu0EknnUgBDRCT1eTweSkpKCAaD5OfnJ7s7PU4kGOGvFzzF41WX4cF5Q3HHHXDFFc3fs2PHDr761a+yf//+eN0nPvEJvvvd7/aaPCXWWsrLyyksLKSoqEh5MKRHCQaD7Ny5k23btrF161a2b9/Ojh072LFjB9u3b6empqbDzygoKGDYsGEMHz6cYcOGxcvQoUMZOnQoQ4YMYfDgwRp1Jx2mAEZnPMSYNOAM4HLgEmA4YIE11tqZnd6BXkoBDBGR1Kf8F51ry0tb+P3/7eUNzgKgXz/LCy8Ymsvft3TpUu644474vHpjDLfeeivXXXddrxsyXllZSVZWFkVFRfrZlF7DWsuhQ4fiAY1du3axc+dOdu3aFS9tXSmlOcYYBg8ezJAhQygqKopvY/uDBw+Ol/z8/F73O0hap7cFMLok5GetjQJv1JZbjDGzcIIZl3bF80VERFJVIBAgFArpDWIn2TB/I2s5JX58zTVNBy+stTz99NM89NBD8aHl2dnZ/PCHP+T000/vqu6mFJfLRSgUIhAI6OdTeg1jDAMGDGDAgAHMnj37iPPWWg4fPsyePXvYs2cPu3fvju/Hyr59+wgGj76egbWW4uJiiouLj3ptZmZmPJgxaNCgeIlN8xo4cGB8f8CAAfo/Kz1WIpZRvRh4oTZI0SrW2veA94DvdvT5IiIi3VUoFCIUCmGt1TDiTnB4+2HeXZtBOYUAZGdZrrrqyE8ww+EwP/3pT/nXv/4VrysqKuKhhx5i/PjxXdbfVON2u6murm7VGzGR3sIYQ2FhIYWFhUyfPr3Ja6y1lJWVsW/fPvbu3RvfHjhwgP3797N//34OHDhAaWlpq58bCATYvXs3u3fvbtX1OTk5DBw4MB6MiZX+/fs3KAMGDKCwsJD+/fuTk5OjUR6S8hLxamkBsM8Y82fgj8prISIi0jrBYJBQKNRr8ip0tQ3/2sAaZsSPL7vc0DjNSGVlJd/61rdYtWpVvO64447jgQceoLCwsIt6mprS09OJRqOEQiEikYjyYIi0kjEmPiJixowZzV4XDAYpKSnhwIED8ZEY9cuBAwcoKSmhpKSEtk4J93q98SkvreV2u+PBmcLCQvr16xffNlX69u1L37596devH1lZWQp+SJdIxDKqrwJnAwaIAq8Cv8dZcSTS4R5KuykHhohIaovlv3C5XGRlZSW7Oz1KOBDm5+e9wjPejwGQnmZ57j+GoqK6a3bu3Mltt93Gnj174nUXXXQRd911F263u6u7nJKUB0MkNcQSPsdKaWkpBw8ebLAtLS2lrKyMsrIyQqFQl/bP7XbHAxoFBQUUFBTE9+vX5efnH7Gfn59Pfn6+giDtpBwYbWStPc8YMxL4PHADzsoj84CSeqMytnf0OSIiIj1NLP9FTk5OsrvS42x/dTvveafEj8+/gAbBixUrVvDtb3+7wWoDN998MzfccINeQNejPBgiqSE3N5cxY8YwZsyYo15rraWqqioezCgrK+PgwYMcOnToiFJWVkZ5eTmHDh0iEAi0u3/BYDAeRGmvjIwM8vPzycvLi2/rl/p1ffr0OWK/T58+DYrb7dbv8x4ooauQ1K42chHwBeBCnABJFFiEMypjgbU2nLAHSos0AkNEJHWFQiGKi4upqKigf//+ye5Oj/Ona1/j15vPwRkgCk8/DePGOeeeeeYZfvazn8WTdWZlZfGDH/yAs846K0m9TV3hcJjq6up4ckAR6bl8Pl88mHHo0CEOHz7cZCkvL6eyspLDhw9TUVHB4cOHu3zER2tkZGTEgxm5ubnxUv84tp+Tk9PgmljJycmJl/rH2dnZpKWlJftLBDQCo0NqE3m+ALxgjCkCbqot5wLnAGXGmMeBx6y1WxL5bBERke5E+S86T/nWct7YPIxY8OLkEyOMG5dOJBLh5z//Of/85z/j1w4aNIgHH3yQSZMmJam3qU15MER6j+zsbIYNG8awYcPadJ+1Fr/fz+HDh6msrKSyspKKioojtlVVVVRVVcWvie1XV1dTVVXVoREgTQmHw1RUVFBRUZHQdgG++c1v8tOf/jTh7crRdVrKc2ttMfAj4EfGmHNwpphcCnwDuL0zny0iIpLqYtNHlGsh8Vb8fRubOCF+fOPn0/F4PNxxxx0sXbo0Xj9lyhQefPBBBgwYkIxudgvGGDIyMggGgwQCAU13EpEjGGPIzs4mOzuboUOHtrudQCAQD2ZUVVVRXV3doNSvq6mpoaampsFxdXU1Ho8nvh8Od97Af/0uTJ6uCiIsBgqB0cCJXfRMERGRlBUbgaEXQYkVCUb4z0uZRHFGCkwYFaSo6BA33vhVtm+vS8l13nnncc8995CZmZmsrnYbsTwYwWBQP68i0mkyMzPJzMxMWFA5GAw2CGzEghtN7Xu93iP2vV5vs/u5ub1itkZK6tQAhjFmIs7Ii+uBAThjOXcAf+zM53YFY8xw4PvABUB/4ADOkrL3WmsPd3U7IiLSfYRCIUKhENZaDclPsI2v7OSD4IT48bkXbuKGG26nvLw8Xve5z32OL33pS0ru1kput5vq6uqED+8WEelM9ZeFlZ4j4QEMY0wW8EmcwMUpOEGLEPAv4A/W2oWJfmZXM8aMBZYCg4DngI04I0u+ClxgjDnFWnuoq9oREZHuRfkvOs8zj3sJ4CxJ2yfrvzz2xx8SDAYBZyTB//3f/3HRRRcls4vdTkZGRjwPRjgcJiNDs4BFRCQ5EvYXyBgzA2f1kWuBfJzAxTbgMeDP1tr2r6mTen6NE3S41Vr7aKzSGPMgcBvwQ+BLXdiOiIh0I8p/0Tkq9lTx9q4RgAX+RI3/N/FzBQUF/PznP2fGjBnJ6l7zIhEIBiEQcLbBIIRCznEoVHccCkE4fOR+JALRqHMcjdbtW1t3HCuxOmsb7oOzH9NolTpXWhohIBiJkGEtGOOUtLTmS3o6ZGQcuT1aqX9d/X2X68htrLjdDfc1sklEpEfq8DKqxpgv4gQujscJWgRxpkD83lq7qKMdTDXGmDE4gZmdwNjalVdi5/JwpoAYYJC11tPZ7Rylr1pGVUQkxVhrKSkpoaysjIKCAk0hSaA/fnsLv3l9FE4O8efj9aNGjeIXv/gFw4cPb3ujoRB4vU7x+RpuY/t+f9228X4g4JT6+/WDFYFAw8BBivJlZRF2uRhUWkq/Tsjon3DGNB/gaG1dc/uN6xoHUxqX5s7Xr28qQFO/pMhyjSKSerSMatvFPt7YDPwB+Iu1tiwB7aaqs2u3C+sHHQCstdXGmCXAPGAO8HoXtCMiIt1ILBkioOBFAtmI5bk300njFnJ5jxwgF5g1ZQr/e8MN5GzeDO+/Dx5PXfChpRK7LhRK9peWElyhEL6cHILdJemptXWjWXoCY5oepVJ/Gyv1j5vbb67ERs40td94dE1r6uqX+iN2YvstbVvab6muqdLcdbF/2+bqmttvXNfUde3ZdvSepo47st+W69raVkfqk90WQJ8+TpEul4gAxt9xRlssTkBb3cHE2u3mZs5vwQk8TKDlwEOi2ul95s+HW25pWNfRX5Dtuae1v+Bbc00i//B05P72/gE92h/v9uwf7QVGW0rjFy7NHbdl295S/wVe4xeITR0frb5xae6FbXNDtVv6PyGdQvkvmhAKNRzV4PHUBRBi+/VLE/WBskr+Gakmi0YjS9evh299KzlfV2ulpTmf5rvdkJnpfAIf28bqm/r0vvEb2vrTNmL7Tf3uij0ztl//mvrqHWdYi41ECKalEU5Pd15A1p+C0niqSiTilHC44X7sOLZfv8SmwxztmsZTaWIlNtUmGDxiCky3Z23d1ykiyXf33XDPPcnuRa/U4QCGtfbTiehIN1JQu61s5nysvm8XtYMxZlUzp7KOdm+35PNBcXGyeyHSM6SlHTm/vP5xU8OfW5qL3tJ9LQ3HbuoNWnOlpWu7QVCmW+W/qP8pdmy6Q2wqROPpEY1L/akVjadX1C9er/NmtIM67Q9eWhrk5DQs2dl129h+VpZTsrPrtpmZDUtWlrONBSpi+7FAQ4pzVVURcrsJDB5MRqovIRiJHBngaCrY0Tjw0VxApKX7mwuoNJezpLnSVLAmti8iIkACAhjGmOvbc5+19q8dfXaKir0C6WjoP1HtiIg0LxrtWcOs4eiBjpYCMo33G49eOdpw7eaGUteO9rHWEoxGCUUi9Kn/pjWWULG5/fp1jRMw1v/Eu/4n17FPveu/cWr8pqh+wsj6b8hiySO74ae9Fgi53Lj79YXcXCe4kJvbcD+2zc4+chsLUsSuc7u7RXChK7jdbkKhEIFAgNxUD2DE/k9m9YDPcmL/15sandLU//vGo15i+00d1y/1R8403m/8uya2rd+3+uebGpXTVCLZ1m4bJ509Wl1rron92zZX19x+47qmrmvPtqP3NHXckf22XNfWtjpSn+y2YlL9d2APlogpJI/TtjfZpvb67hrAiI2MKGjmfH6j6zq7Hay1M5uqN8Z4gJyj3d/tXHEFnHtu3XFHf0G2557W/oJvzTWJ/MPTkfvb+wf0aH+827N/tBcYbS2tecHTlhdTLQ2Zbqm+/ou+xsOsm3rR2Jr6pkpLL2rrv+jthm9OWyX2xjsFExiH3G5Cgwdj8vJIO3w42d1JHWlpDQMIsYBD4wBEo/q3V6/msb//nWpr8QIe+lCQ9X+88M45yf6KeiSXy4XX643ncJEuYkxdQKY7jNwSEelEiVpGNQy8AKxPUHupbFPtdkIz58fXbpvLbZHodnqf2KdjItJx9QMbzQ13bjzsualP81s7XPpoQ7HrjwhoT4lEkv0v2qKA203I7cbdnd4AxnIw1J/2UH86RGwbmzpRfxpFU9Mq6u/Hfp+3ceqPtZbf/va3/PGpp+rVDgEe4ebLe8An7ikqlnQ2FAopj4uIiCRFIgIYi4HTgUuBQTgrkfzTWutPQNup6I3a7TxjTFoTy5+eAviA5V3UjohI+8U+1esuKwscTTR69IBJS0GYxokEm0o62NwQ7cbDq+vv144mCqalEUxLIyt2vqnEt7H95hLZNpdUtrkVBxpPj2lNfpL6iSNTbPpEOBzmvvvu44UXXqhXOxn4BX3TXFzxZQW4O5PL5SIYDBIIBBTAEBGRLpeIJJ5nGWPGAV8Argf+DDxsjHkC+IO19oOOPiOVWGu3GWMW4qwQcjPwaL3T9+Ks2vY7a60HwBjjAsYCIWvttva2IyIirZCWVjdCIMVYawkcOECorIy8wsK6FSCk1bxeL9/85jdZsWJFvM6VNodQ9GdANufN2IYre2zyOtgLuFyuBksBi4iIdCVjj5agpC2NGZMBXIITzDgXJ9/FKuB3wNM95c24MWYssBRnxMlzwAbgJOAsnCkfc621h2qvHQXsAHZZa0e1t5129tOTnZ2d403BeeAiIr1NIBCguLiYmpoa+vXrl+zudDtlZWXceuutbN5cN7PyhBkfZ/Wau4AMMvHzzONehk4tTF4ne4FoNMrhw4cZMGAARUVFmBQboSMi0tvk5OTg8/m81tpekVk0oR//WGvD1tpnrbUX4Iw6+BHOpNTfA/uNMScn8nnJUjuSYhZOAtOTgNtxvt5HgJNbG3RIVDu9zeHDh1m9ejWbN29m3759VFZWEtYSYyKS4mLLp2rYfdvt2LGDG2+8sUHw4otf/CJVpd8gNph01oBdCl50gbS0NIwx8TwYIiIiXSlRSTyPYK3dBfyfMWYpzgiMYcDAznpeV7PW7gFubMV1O6lbErXd7UidRYsWceWVVx5Rn5WVRZ8+fRqUvLy8I7bNlfz8/HjJy8uLJysTEUmEYDBIKBQiOzs72V3pVt5//31uv/12qqqqAOcN9F133cX48Z/gd79z/rymEeWaazUlp6vEllMNBoO4tSqGiIh0oU4JYBhjhgI31ZaRgB94AljdGc+T3qWmpqbJer/fj9/vp6ysLCHPyc3NJS8vj4KCAvLz85vcFhQU0Ldv3wb7sVJQUKBPWkUEcIbdBwIBwuEwGRmd9tlBj/Pqq6/yve99L/5Jf3Z2Nj/5yU+YO3cu3/maH3BWHBmXtp2Zl49MYk97F5fLRSAQIBAI0KdPn2R3R0REepGEvYoyxqQBHwc+D1xQ2/Y64KvA36y1lYl6lvRueXl5zJgxA4/HQ01NTbwkMp8LgMfjwePxUFxc3O42cnNz6du3L/369YsHNvr163dEKSwsbFD69eun4IdIDxIMBgmHw6Snp5Om5J1HZa3liSee4OGHH47XFRYW8vDDDzN58mTKy+GNpXWf/F8wpwJ3n3HJ6Gqv5HK5qKmpIRAIYK1VHgwREekyHQ5gGGNGA5/DmQYxBPAAf8FZgWRlR9sXaezyyy/n8ssvb1BnrcXn8zUIaFRXVzfYjx1XV1dTVVUVr2t8HNtPREAkFgTZt29fm+/Ny8ujsLCQ/v37079/fwYMGBDfjx0PHDiQAQMGxEtWVlaH+ywiiRcMBgkGgwpMtkI0GuWBBx7gn//8Z7xu1KhRPProowwZMgSA+f+MEok6gaBBlHDOZ4Ykpa+9VVpaGmlpafFpJJkpuOqPiIj0TIkYgbG1dvsecDfw956y2oh0H8YYcnJyyMnJYdCgQR1uLxqN4vF4qKyspKqqKl5ix5WVlfFSUVHR4Pjw4cPx+mg02u4+xAIqu3btavU9ffr0iQc2Bg0adMR20KBBDB48mMGDBzNw4EC9mRLpIrEEnjk5OcnuSkrz+/3ceeedLF68OF53/PHH8/Of/5z8/HwAQiH45z+ixPKQz+q7laGz5iaju72ay+UiHA4rgCEiIl0qEQEMA4RwRl98D/heK4YSWmutJqtKykpLS4sn92wvay01NTUcPnyYioqK+La8vJzDhw/HS+y4vLy8wbn2BD9iI0527tzZqusLCwsZPHgwRUVFzZahQ4fSv39/DREWaadoNEowGCQSiSho2IJDhw5x++238+GHH8br5s2bxz333NMgUeRrr0FFtfPyJQcPH7s8S7+fksDlcuH3+wkEAh36WykiItIWicqB4QKGJ6gtkR7BGBMPghxzzDFtujcajVJVVcWhQ4fipays7Ij9srIyysrKOHjwIGVlZW1eTjYWNNmwYUOL17ndboYMGcKQIUMYOnQoQ4cOZdiwYQwfPrzBVp8uixwpNvoiPT1db7SbsWHDBm6//XZKS0vjdddffz233HJLg38za+GJv9WNvjiW9Uy5dFJXd1dwAhjV1dUEg0HlwRARkS7T4QCGtVbZyEQSLC0tLZ70c+zYsa26x1pLZWVlPKBRWlp6xLakpCS+LSsra/Uoj2AwyK5du446naVfv34MHz6cESNGNFs01Fh6m9jyqVpusmkvvfQSP/jBDwgGg4Dz++8b3/gGn/zkJ4+49sMPYdNm52VHGhHOPO4weUP16X8ypKWlkZ6erjwYIiLSpbSWm0gPYYyJBz3GjTt6Nv5IJMKhQ4coKSmhuLj4iHLgwAGKi4vZv38/lZWtW0QoNv1l3bp1zfaxqKiIkSNHcswxxzBy5EhGjhzJqFGjGD16NKNGjdIoDulxAoEAwWBQy002Eo1G+eUvf8lf//rXeF1eXh73338/c+bMafKev//d4sxchXFs5YQrRndFV6UZbrebUChEIBBQAENERLqEAhgivVR6eno8see0adNavNbj8XDgwAH279/PgQMH2LdvX7zs3bs3vh8KhVpsx1rLgQMHOHDgAMuXL2/ymkGDBjF69Oh4GTt2bLwMGzZMS1BKtxKJRAiFQkQiETIy9Cc3prq6mjvvvJOlS5fG60aPHs2DDz7IiBEjmrzn4EF4/bW64xlZGxl19kWd3VVpgcvlwuv1EggEkt0VERHpJTr0asoYk22t9SW7DRHpXLm5uYwbN67FkR3RaJSDBw+yd+9e9uzZw549e9i9e3eD/f379x912kppaSmlpaWsWLHiiHNut5vRo0fH+zJhwgTGjx/P+PHjGTFiBOnp6R3+WkUSqf7yqcoR4NixYwe33347u3fvjtedfvrp/OAHPyA3N7fZ+555BiJR599wCAeYc34/XNlKippMLpeLSCRCMBgkGo0qwCwiIp2uox8H7TDG3A/81lrbpvC7MWY68H2c5Vd/0MF+iEiSpaWlxZdonTlzZpPXhEIh9u3bF8+nsXv3bnbu3MnOnTvZsWMHu3fvbjERaTAYZNOmTWzatOmIc5mZmYwdO5aJEycyceJEJk2axKRJk5g4cSJ9+/ZN1Jcp0iaxBJ5afcTx6quv8oMf/ACv1xuvu+mmm/jyl7/cYoAnEIBn59dNH5nKh0y4uOWRY9L5jDHxPBiBQIDs7Oxkd0lERHq4jgYwFgIPAncbY/4B/BNY3tyICmPMGOB84HrgRGAP8LMO9kFEugmXy8WoUaMYNWpUk+cjkQj79u2LBzS2bdvG9u3b2bZtG9u2bePgwYPNth0IBFi/fj3r168/4tzgwYOZPHkyU6ZMYcqUKRx77LFMmTKFgQMH6lNx6VSxAEZvX2YyHA7zyCOP8NRTT8XrMjMzueeeezjvvPOOev8rr0BllfN/tQ/VHHdMBYOPG9xp/ZXWi+XBCAaDCmCIiEinM9bajjVgzCzgR8A5tVURYANwADgMZAH9gYnAAJyPT0qAh4GH2jpyQ1rPGOPJzs7Oqf9Jl0h3VlVVxfbt29m6dStbtmxhy5YtbN68mS1btjRYfrG1+vfvz5QpU5g6dSrTpk2Ll4KCgk7ovfQ24XCY4uJiDh8+TP/+/ZPdnaQ5ePAg3/nOd1i7dm28bsSIEfz0pz9l/PjxR73fWvj0p2HzZuf4JFbw+ZvdHH/j8Z3VZWmDUChETU0NAwcOZNCgQcnujohIr5OTk4PP5/Naa5ufh9mDdDiAEW/ImPHA53ACGTOAxpPRDwJvAc8Cz1prW872Jx2mAIb0JpWVlWzevDk+xWTjxo1s2rSJzZs3tznB3IgRI5g2bRrTp09n+vTpzJgxg3HjxinHhrSJx+OhpKSEYDBIfn5+sruTFKtXr+Y73/kO5eXl8bozzjiDe+65p9WjUlatgi9+0dlPJ8xnzFPc+OIV5A7sFa/TUp61lvLycvr168eQIUP0e1JEpIspgJGIRo3JAYbhjLzwAaXW2gMJf5C0SAEMEWdayq5du9iwYQPr16/no48+ik818Xg8rW4nJyeH4447Lh7QmDlzJtOmTSMrK6sTey/dWXl5OQcPHsTlcvW6nxNrLU888QSPPvpoPHFvWloaN998M9dff32bpm594xvw5pvO/hQ28Km5O7nwkQs7odfSXlVVVWRmZjJ48GAthS0i0sUUwJAeQwEMkeZFo1H27t3Lhx9+yLp16+Jlw4YNR10ONiYjI4Njjz2WmTNncsIJJzBz5kymT5+ueeCCtZaSkhIOHjxI3759e9Wn0hUVFdx9990sWbIkXtevXz9+9KMfMXv27Da1tW8fXHqpxVon4PFJnuHK+2cy5rwxCe2zdIzP5yMcDjNo0CD69euX7O6IiPQqCmBIj6EAhkjbhUIhNm/ezLp161i7di1r1qxhzZo1FBcXt+r+jIwMpk6dyqxZs5g9ezazZ89m6tSpWoWilwkGgxQXF1NVVUVhYWGyu9Nl3n//fe68884GOWmOO+44fvKTnzBw4MA2t/fggxDL+zmcPVyWv4jrXr6OdHfvCQh1B+FwmKqqKgYMGEBRUVGyuyMi0qsogCE9hgIYIolTUlISD2i8//77rFq1ii1btrTq3szMTE444QTmzJkTLyNGjNAKKD1YdXU1paWlRCIR+vTpk+zudLpoNMqf//xnfve738WnjABcf/31fOUrXyEjo+2Lnnm9cOGFEJvpdSEvccEn8znlW6ckqtuSQOXl5RQUFFBUVKSArYhIF1IAQ3oMBTBEOldlZSVr1qxh1apV8bJp06ZW3Tt06NB4MOPUU09l5syZuN3uTu6xdJWysjIOHjxIVlYWmZmZye5OpyovL+euu+5i5cqV8bqCggLuvfdeTj311Ha3+89/wk9/WtseFXySZ7jiicsYMGlAR7ssnaC6upqMjAwGDx7cK4J2IiKpQgEM6TEUwBDpepWVlaxevZp33303Xnbt2nXU+7KysjjppJM49dRTOfXUUzn55JO1nGs3Za3lwIEDlJWVUVhYSFpaWrK71GkWL17MD3/4wwarjMyYMYMf/ehHHVpS01q44grYvds5PoUlnD6hmMufvFwjl1KU3+8nGAwycODAXr1ssIhIV+ttAYy2j+kUEZFmFRQUcNZZZ3HWWWfF60pLS1m5ciXLli1j+fLlrFy5kpqamgb3+f1+Fi9ezOLFiwEwxjB9+nROO+20eNHc8u4hEAgQCoXIyMjoscGLyspKfvazn/Hyyy/H64wx3HjjjXzxi1/scNLSJUvqghdugkxgMxM+MUvBixTmdrvxeDwE/r+9+46Tq673P/76Tt2+m93NbgIEQkJCQkjoJUASSACxgMgFKwhYrnrxoniv13sVFdvPdkUR6xUFVEBBKWIDBEIJCRIgkEAgEBJKSLLJ9tnpM9/fH2fK7mZ7m/Z+Ph7ncebU+WxYdmbe8y2RCNZa/bcSEZFJoRYYRUwtMETyUyKR4Pnnn2ft2rU89thjPPLII7zyyivDXjdv3jyWLVvG8uXLWb58ObNnz9aHhDzU2dmZGcSysrL4vgx58MEH+eY3v9mn1UVDQwNf/epXOeGEEybkOS67DB5/3Hm8hGc5yfNPLvz7hZTVldZ0tIWmvb2dqqoqZsyYUfRdp0RE8kWptcCYkgDDGHMV8Gtr7fDv0GXCKMAQKRxvvvkma9as4dFHH+XRRx9lw4YNfQZDHMj++++fCTOWL1/OwoULFWjkgT179tDS0kJlZWVRjWvS3t7Od7/7Xe69994++9/2trfxn//5n9TU1EzI87zyCrz73c5jg+W9/I4lKxs54ztnTMj9ZfIEAgFcLhdNTU0T9vsgIiJDU4AxGU9iTBLYCayw1r7ca78fOMla++CkF1GCFGCIFK6urq5M64xHHnmEf/7zn0QikSGvaWxsZMWKFZx66qmcdtppHHbYYQo0plgikWDXrl20trbS0NBQFP/+1lr+/ve/c/XVV9Pe3p7ZP336dD7/+c+zbNmyCX2+//f/4PbbnccHs40z+Qdv+cFbOPCUAyf0eWTiRaNRgsEgTU1NNDZqsFURkamgAGMynsQJML4HvBc41Vq7NbW/GXjTWqsJ3SeBAgyR4hGJRHjiiScygcajjz5Kd3f3kNdMnz49E2asWrWKefPmFcUH6nwWDAbZvXs34XC4KAZh3bJlC9/+9rd55pln+uw/++yz+cxnPkN1dfWEPl9XlzN1ajqrO5u7mdvYyQf+8gGMW7+7+c5aS1tbG/X19cycObNox4AREcknCjAm40mMSQAzgUuBTwLLrbXbUgHGTmutXuEmgQIMkeIVj8d59tlnefjhh3nkkUd4+OGH2bt375DXHHDAAZx++umcfvrprFq1SoOCToKOjg5aWlpwuVxUVFTkupwx6+rq4qc//Sl//OMf+3Rlampq4sorr+Skk06alOe98Ua49lrncQN7+Rfu4MiLj+D4fz9+Up5PJl5HRwcVFRXMmDGDsjKNWSIiMtkUYEzGk6QCDGttizHmf4CPAyuAEGqBMWkUYIiUDmstzz//PA8++CAPPvggDz30EK2trUNes2jRokygsWLFign/Nr0U7d69m71791JdXY3HU3gTfSWTSe666y5+9KMf0dnZmdnv8Xh4//vfz0c+8pFJC2bicTjnHEiNf8qprOZQXuKCP15A3UF1k/KcMvGCwSDWWpqamoqiFZKISL5TgDEZT+J0IZlhrW1JbX8B+ChOl5I1CjAmhwIMkdKVTCbZtGkTq1ev5v7772f16tV0dXUNer7H42Hp0qWcccYZnH766Rx33HEF+QE8l2KxGLt27aKjo4OGhoZclzNqTzzxBD/4wQ948cUX++w/8cQT+exnP8tBBx00qc9/773w+c87j8sJ8X5uZv8l0znnV+dM6vPKxIrFYgQCAaZPn05TU1OuyxERKXoKMCbjSYz5LPATa21Pr31fBC4H6hVgTA4FGCKSFo/HefLJJ/nHP/7BP/7xD9asWUMsFhv0/NraWlauXMmZZ57JW97yFg4++OAprLYw9fT0sHv3bqLRaEHNwLB161auueYaHnvssT7799tvPz7zmc+wYsWKSR87xVq46CJ44QVn+2ie5DieYtmVy1hw7oJJfW6ZWL3HwZgxYwZut97iiYhMJgUYo72BMZ8HbrfWvjCGa78AfNZaWzeuImRACjBEZDA9PT08+uij3Hfffdx33308++yzQ55/yCGHZMKMU089taA+oE+VtrY29uzZg9frLYi+/3v27OFnP/sZd999d59xLvx+PxdffDEXX3wxfr9/Smp54gn4xCecx27ifIBbqC6Lc+E9F+Kt9E5JDTJxurq68Pv9NDc3F/RYMCIihUABxmhv4HQPucpa+9Ve+8qttaHxFifjowBDREZq9+7d3H///ZlAY8eOHYOe6/F4OPHEEznjjDM488wzOfbYY0u+u4m1ll27drF3716mTZuW17MvdHV1cdNNN3HTTTcRDocz+40xnH322XziE59g+vTpU1rTJz8J69Y5jw/jOZbxGPPePo9Tv3LqlNYhEyMUChGPx2lqamLatGm5LkdEpKgpwBjtDQYOML4MXGat3afzozFmBtDduzuJTA4FGCIyFtZaXnjhBe655x7uvfdeVq9eTSg0eCZdW1vLqlWrOOOMM1i1ahWHHHJIyU3XGo1G2bVrF11dXdTX1+e6nAHt2bOHm266idtvv53+rwtLly7l8ssvZ968eVNe15Yt8P73O48NlvfwO2oJ8I6fv4OZx8yc8npk/OLxOF1dXTQ2Nmq2IxGRSVZqAcZkfmU22AhmHwOuBNQmVEQkDxljWLhwIQsXLuTTn/40kUiENWvWcO+993LPPfewYcOGPud3dnZy++23c/vttwMwa9YsVq1alVlmziz+D6GRSIRYLIbP58t1Kft44403+PWvf83dd9+9z7gn8+fP51Of+hQnnHBCjqqDX/86+/hgXqGWANX7VzPjaH3wLVTpFlmxWIxYLIbXq7d8IiIyMXLV5jd/29aKiEgffr+flStXsnLlSr71rW/R0tLC/fffz7333jtgd5PXX3+dG264gRtuuAGAhQsXsmrVKlauXMmKFSvytoXCeEQiEaLRKOXl5bkuBXBa0WzcuJHf//733HfffX3GuACYO3cul156KWeeeWZOu7vs3OnMPpJ2JM5YLIeec2jJteIpNl6vl2g0SiQSUYAhIiITprQ7LYuIyKg1NTXxvve9j/e9731Ya9m8eTP33XdfZrrW7u7uPudv3ryZzZs386Mf/QhjDEcddRQrV67ktNNOY9myZVRXV+foJ5kYyWSSaDRKPB7P+Vgg7e3t/PnPf+ZPf/oT27Zt2+f44sWLufTSS1m2bFleBAQ33QTpbGU/djCdveByAgwpbD6fj0gkQjgcpqqqKtfliIjIMIwxBwBfBc7C6U2xE7gT+Iq1tn2M97wISLe1/Ki19rrx1qkAQ0RExswYw2GHHcZhhx3Gpz71KWKxGOvXr+f+++/nH//4B2vXriUajWbOt9by1FNP8dRTT/G///u/uFwujj76aJYvX86KFSs45ZRTCq6FRrr1hdvtzklrhmQyydq1a7nrrrt46KGHSCQS+5xzwgkn8KEPfYijjz46L4ILgM5OuPPO7PaRPAPA7OWzqZiumSsKndfrJRAIEI1GSSaTeT2wrYhIqTPGzAUeA5qAu4AXgOOBTwFnGWNOtta2jvKes4BrgQAwYUn2RAUY4xsJVEREioLX62Xp0qUsXbqUK6+8kmAwyJo1a3jggQd44IEHWL9+fZ/uDMlkkvXr17N+/XquvvpqwGklsHz58sx9Dj744Lz50D2QdIAxleNfxONxnnzyyUyrl7a2tn3Oqaio4IwzzuD8889n4cKFU1bbSN12G6QnQWl0tXFA0umKtOC8BTmsSiaKy+XC7XYTi8WIRqMFMbWwiEgJ+wlOeHG5tfba9E5jzNXAFcA3gI+P9GbGeeN2PdAK3A7850QVOlGzkMSAjcATqeVk4BJrrXuA878MfGmgYzKxNAuJiOSbzs5OHnnkER544AEefPBBnnnmGYZ7HWpubs6EGUuXLuXoo4+msjJ/BtrevXs3e/fupbq6elK7kMRiMdatW8cDDzzAQw89RFdX14DnLVmyhHPPPZczzjgjb8bk6C8Sgbe/HTo6nO2VPMg8XqZqZhXvveu9GFf+BlYycsFgEGstTU1N1NbW5rocEZGiNN5ZSIwxc4CtwHZgrrU22etYNU5XEgM0jXQmUWPMp4DvA6cCK4Evk0ddSO4HjgKOTi3/mj5gjHkIeKbXsnECnk9ERApUbW0t73jHO3jHO94BQEdHB48++igPP/wwDz30EE8++eQ+XSB2797NnXfeyZ2p/gYul4tFixZx3HHHZZbFixfnZAaQ9LfLyWRyUsKLHTt2sHbtWh577DHWr1+/z/SnafX19bz97W/nnHPO4eCDD57wOiba3Xdnw4taX4g50a0ALDh3gcKLIpLuRhIOhxVgiIjkr5Wp9b29wwsAa223MWYNcCZwIs5n/yEZYxYC3wKusdY+bIxZOdw1ozHud1vW2jMgk9wc22s5CliWWtJfryVx+sCIiIhQV1fXJ9AIBAI89thjPPbYY6xdu5Z169bt09IgmUyyceNGNm7cyK9+9SvAGTDw8MMPZ/HixSxZsiSzbm5untT6J7r7SHt7O5s2bWLdunWsXbuW1157bdBzm5qaMrO7HHHEEQUzxkAyCb/5TXZ7UXQDbqwG7yxCHo+HZDJJLBbLi0FuRURkQOkX3y2DHH8JJ8CYzzABhjHGA/wGeA34/EQV2NuEvZJYa18BXgFuTe8zxsynb6hxJFCLxswQEZEBVFVVceaZZ3LmmWcCTlixefPmTCuExx9/nM2bN+/T7SQajWYGB+1t+vTpLFq0iLlz5zJnzhzmzp2beTwRg4VGIhFisdioA4x4PM6OHTvYsmULW7Zs4cUXX2TLli3s3bt3yOv233//TGixaNGivB4bZDAPPADpmXcrfHEOjb4AaPDOYmSM6TOdqgIMEZFJU2aMeXKgA9baY4a5Nt1ErnOQ4+n9dSOo40s4DRlOsdaGRnD+qE3qK4m1dgtOknMzZAbzWAgM948oIiKS6S6yaNEiPvKRjwDQ3d3NU089xRNPPJFZBpoyFGDPnj2sXr2a1atX73OstraWWbNmccABB7D//vtn1vvvvz9NTU3U1dVRW1tLXV0dXq93n+uttZkAo6qqCmst3d3ddHZ20tHRQWdnJ52dnezZs4eWlpY+S2tr67BjfwD4/X6OPfZYli5dykknncSsWbMKMrRIsxZuuCG7vcg8j484oME7i5XP5yMWixGJRPJq7BoRERmx9BuPId+4GGOOx2l18T1r7drJKmZKo3DrvFt7PrWIiIiMWnV1NStWrGDFihWZfW1tbWzcuJFnn302s960aRM9PYOPNZUOGDZt2jTsc1ZUVFBXV0dFRQXJZJJEIoHL5aKurg6/3097ezuBQKDPDCtj4ff7mTt3LkcffTQnnXQSRx55ZE7G9pgsa9fCC06DC3xey4KIM3Vq1cwqDjjxgBxWJpPF5/PR09NDOBzGWlvQAZyISB4Lj6ClxWDSLSwGG6yopt95++jVdWQL8MUx1jEiassnIiIFr76+fp9QI5lMsm3bNrZs2cIrr7zC1q1b+6xHM0NTMBjc5/yamprMuBNjme2psbGR+fPnM2/ePA499FDmz5/PgQceWDBjWYxFasgSAI6ctp2KFmceVQ3eWbxcLhculysz4K3f7891SSIi0teLqfX8QY7PS60HGyMDoKrX9eFBwupfGGN+gTO456dHW2SaAgwRESlKLpcrM+ZFf9Za9uzZwxtvvMGOHTvYsWNH5vEbb7xBW1sbHR0dmWWglhVlZWX4/X66u7sz+yorKzPdTmpra6mtraW+vp7m5maampoyS2Nj44DdUorZ00/Dhg3OY4/HckhLqnWpBu8ser27kSjAEBHJOw+m1mcaY1wDTKN6MhAC1g1xjwjwy0GOHY0zLsajOGHJuLqXKMAQEZGSY4zJhAlHH330kOdaawkEAnR0dBAKhXC73Vhr6ezsJBAIUFdXh8fjobq6WoMUDuGXvd7WHHfQHqq3Ot17NHhn8fN6vQSDQSKRSK5LERGRfqy1W40x9+LMNHIZcG2vw18BKoGfW2t7AIwxXmAuELPWbk3dIwR8ZKD7G2OuwgkwbrTWXjfeevVOS0REZAjGGKqrq6murs7s6+npweVyUVlZSU1NzRBXC8Dzz8O61Pc2Lpdl3u41mWMavLP4eb1e4vE40WiURCKB2+3OdUkiItLXvwGPAT80xqwCNgMnAKfhdB35Qq9z908dfxWYPbVlQvF2tBUREZkkY50+tVT1HvvixMMDlAec6WI1eGdpMMbg8/ky06mKiEh+SbWkOBa4ASe4+A+cVhY/BJZaa1tzV11faoEhIiIyCunpU6PRqKaFHIFXXoHes9guiT6ZmYdNg3eWDq/XmwkwKirUZUhEJN9Ya18HLh3BedvJTq06kvteBVw11rr6UwsMERGRUYhGo0Sj0czsCjK066/PPl56TBT7wksAGLfR4J0lpPdAntba4S8QEREZgN55iYiIjEK6+0ipzSIyFm+8Affck90+sfb5zOPZp2nwzlKSHvciGo0Si8VyXI2IiBQqBRgiIiKjkO4+ovEvhnfjjZCegfa4YyzRdU9nji26YFGOqpJc6d0KQ0REZCwUYIiIiIxQIpEgGo0Sj8fVAmMYLS1w993Z7dPnv0o8GAeg7uA6Zhw9I0eVSa5oIE8RERkvBRijYIyZZ4z5nDHmAWPM68aYqDFmtzHmLmPMaaO812xjjB1i+d1k/RwiIjI26dYXXq8XYzT45FB++1uIO3kFS5ZYko8/kTl22AWH6d+vBKWnU41EIiTTTXNERERGQbOQjM7XgPcAzwN/BdqAQ4FzgHOMMZ+y1v5wlPd8BrhzgP2bxlGniIhMAnUfGZn2dvjjH7Pb71rRwa5rOwDwlHuY97Z5uSlMcsoYg9vtznQjKS8vz3VJIiJSYBRgjM7fgW9ba5/uvdMYswK4D/iuMeY2a+3OUdxzQ2pqGRERyWPp6VNjsZimgRzGTTdBupfA/PlQ/sJTmWOHvPUQfFUKgEpVuhtJOBxWgCEiIqOmLiSjYK29oX94kdr/ELAa8AEnTXVdIiIy+WKxGNFoFMjOqCD76uqCW2/Nbl/07gjbH9iW2T7sgsNyUJXki97jYGg6VRERGS21wJg46TnB4qO8bj9jzMeABqAVWGutfXZCKxMRkXELh8PEYjF1HxnGLbdAMOg8njMHmvY8zxsJ54Nq8xHNNMxryGF1kmsej/PWMz2dqv5/EhGR0VCAMQGMMQcBq4Ag8PAoLz8jtfS+32rgYmvtayN8/icHOVQ2ylpERGQQkUiESCSi7iNDCAScACPt0kssL/5oc2ZbrS8E+nYjUYAhIiKjoS4k42SM8QM3AX7gKmtt+wgvDeIMCnoMMC21rAAeBE4F7jfGVE54wSIiMmqaPnVkbrvNCTEADjwQDi17lZ6WHgDKppVx8KqDc1id5AtNpyoiImNVci0wjDHbgYNGcclN1toLB7mXG/gNcDLwe+B/R3pTa20L8KV+ux82xpwJPAqcAHwEuGYE9zpmkPp6AH1VKCIyTuFwmEgkgs/n0/SfgwiFnKlT0y69FF68Pdv6YsG5C3B7NXaIZKdTjUajJBIJjSkjIiIjVnIBBrAVCI/i/DcH2pkKL34LXADcClxoJ2A0Kmtt3BhzHU6AsZwRBBgiIjK50rOPqLn74P7wB+jsdB7vtx+cdHgnt3/lDWeHgQXnLchdcZJXjDH4fD4ikQjhcJjKSjU4FRGRkSm5AMNau2q89zDGeICbccKLm4EPWmsT471vL3tSa72ii4jkmLWWcDhMNBrVB61BRCLwm99kty+5BLbc+Xxm+8BlB1I9s3rqC5O85fP5iMViRCIR/X8lIiIjpjEwRskY4wP+gBNe/Bq4aILDC4ATU+tXJvi+IiIySunWF263G5dLL5sDufNOaGtzHjc1wVvPiLPl7i2Z4xq8U/rrPZCnplMVEZGR0juxUUgN2HkH8E7gl8Cl1trkMNfUGmMWGGNm9tt/QioM6X/+SuCK1OZv+x8XEZGp1Xv8C9lXLAY33pjdvvhiePWBl4l2RQGo3r+aA048IEfVSb5yuVy43e5MKwwREZGRKLkuJOP0M+BtwF5gB/ClAQZzW22tXd1r+13A9cCNwCW99n8bWJSaMjXVSZglwMrU4y9aax+bwNpFRGQM0i0wqqvVBWIgd98NLS3O4/p6eOc7LX/9ULb7yGEXHKaBT2VAvcfBKCvTzO8iIjI8BRijk57/rZF9ZxDpbfUI7vUbnHDjOOCtgBfYjTMg6I+stY+MvUwREZkIsViMaDSKtRaPRy+Z/cXjcMMN2e2LLoLOLS20bmkFwO1zc+g5h+amOMl7Pp+P7u5utcAQEZER07uxUbDWnjqGa24Abhhg/y9xuqGIiEieSg/eqe4jA/vrX+HN1FxdtbVw/vmw7hvZ1hdzz5qLv8afo+ok33k8HpLJJNFolFgshtfrzXVJIiKS5zQGhoiIyCA0/sXgYjH4xS+y2xdeCIRCbP3H1sy+Re9eNPWFSUHx+/2ZwTxFRESGowBDRERkAIlEgmg0SiKR0DfDA7jrLti503lcVwfveQ+8cMcL2Lgzo0TTkiYaFzTmrkApCOnZSNSNRERERkIBhoiIyAAikQjRaBSv16tBKPuJROCXvTpBXnIJlPstz/+x7+CdIsPxer3E43EikQiJxETPSi8iIsVGAYaIiMgANP7F4G6/HfbscR43NDhjX2x/aDvBliAAZfVlzDl9Tg4rlEJhjMHj8agVhoiIjIgCDBERkX6stQowBhEKwfXXZ7c//GEoK4Pnbn0us2/BuQtwe905qE4KUbobicbBEBGR4SjAEBER6ScSiRCLxXC5XLhceqns7fe/h7Y253FzM7zrXdC+rZ2d61MDYrhg4b8szF2BUnB6j4Nhrc11OSIiksf0rkxERKSf9PgXan3RVyAAv/51dvujHwWvt2/ri9mnzqaquSoH1UmhcrvduFwuotEo0Wg01+WIiEgeU4AhIiLST7r7iN/vz3UpeeWWW6Cry3m8//7wjndArCfGS395KXPOogs0daqMnrqRiIjISCjAEBER6SUWixGNRkkmk3g8nlyXkzc6O+G3v81uf+xj4PHAlr9uIR6MA1B3cB0zj52ZowqlkCnAEBGRkVCAISIi0osG7xzYb34DPT3O49mz4ayznMFOn7+119Sp7z5MU87KmHi9XpLJJNFolFgslutyREQkTynAEBER6UUBxr7a2uB3v8tuf/zj4HLBzvU76djWAYCnwsP8t83PTYFSFPx+v1phiIjIkBRgiIiIpCQSCaLRKPF4XAFGLzfcAOnPlPPnw6pVzuONt2zMnDPv7fPwVnqnvjgpGj6fj0gkogBDREQGpQBDREQkJRwOE4lE8Hq96gqRsmMH3HprdvvjHwdjoPP1Tl575LXM/sPfe3gOqpNi4vV6SSQSRCIR4vF4rssREZE8pABDREQkJRQKqftIPz/+MaQ/Sy5ZAsuWOY833bIJrPN41imzqDuoLif1SfEwxuD1etUKQ0REBqUAQ0REBDLf/MZiMQUYKZs2wb33ZrevuMJpfRHpjrDlT1sy+xe/f3EOqpNipHEwRERkKAowREREgEgkQjQaxePx4HLp5dFa+MEPstunnw6LUznFC3e+QDzsNMuYdsg09jtuv6kvUIqSz+cjHo8TiURIJBK5LkdERPKM3qGJiIiQ7T7i9/tzXUpeWL0aNmxwHns88MlPOo9twvLc757LnLf4/Ys1XohMGHUjERGRoSjAEBGRkpdMJolEIkQiEXUfwRnz4tprs9vvfjcccIDzeNsD2+jZ3QNA2bQyDjnrkBxUKMXM5/OpG4mIiAxIAYaIiJQ8dR/p6/bb4bXUBCNVVfDhD2ePbbw5O3XqwvMX4va5p7g6KXY+n49YLEYkEiGZTOa6HBERySN6lyYiIiUvFAoRiUTUfQQIBOD//i+7/eEPQ22t87hlYwstG1sAcHldLLpgUQ4qlGLncrnweDxqhSEiIvtQgCEiIiXNWks4HNb0qSk33ggdHc7jmTPhPe/JHtt4S7b1xSFnHUJ5ffnUFiclw+fzaRwMERHZhwIMEREpaempU91uN253aXeH2L0bbropu33ZZZDOdAK7Arzyj1cyxw5//+FTXJ2Ukt7TqVprc12OiIjkCQUYIiJS0tLdR9T6An7yE4hGnceHHQZveUv22HO3Pgep4QhmHjuThnkNU1+glAyXy4Xb7SYWi6kVhoiIZCjAEBGRkmWtzQzgWeoBxvPPw1//mt3+9KchPTtqLBTjhTteyBxb/IHFU1uclCR1IxERkf4UYIiISMmKRqNEIhGMMXg8nlyXkzPWwne/66wBli+Ho4/OHt/y5y1Eu52mGTWzajjwlANzUKWUmnQ3kkgkom4kIiICKMAQEZESFgqF1PoC+NvfYGNqfE6vF664InvMJi0bb8oO3nn4+w7HpJtmiEwit9uNMSbTSkpEREQBhoiIlKTes4+U8vSpwSBcc012+wMfgFmzstvb7t9G9xvdAPhqfMw/e/4UVyilzOfzEY1GCYVCuS5FRETygAIMEREpSbFYjGg0irW2pLuPXHcdtLY6j6dPhw9/OHvMWsuGGzZkthe9ZxHecu/UFiglTd1IRESkNwUYIiJSktR9BF5/HW6+Obt9+eVQXp7d3vH4DlpfdNINt9/N4e/R1KkytTweT5/BdkVEpLQpwBARkZIUDoeJRCIl3X3ke9+DeNx5vGQJnHVW3+O9W18sOHcBZXVlU1ecSIrf79dsJCIiAijAEBGREhSNRolGoySTSbze0uwSsWYNPPqo89gY+Oxns9OmAux5bg871+90Nlyw+EJNnSq5kQ4wQqGQupGIiJQ4BRgiIlJyQqFQSbe+iMWc1hdp73wnLFzY95wNN27IPD7krEOonlk9NcWJ9JMeo0bdSERERAGGiIiUlPTsI6UcYPzud/Daa87jqiq47LK+xzu2d7D9we2Z7SM+eMTUFScygLKyskwrDBERKV0KMEREpKT0ntGgFLuPtLbCL36R3f7Yx2DatL7nPPPrZyDVUv/AZQdSf0j91BUoMoD0dKrhcFjdSERESpgCDBERKSml3n3ke9+DYNB5fPDBcMEFfY/3tPTw0l9fymwfcbFaX0jueTwejDFEIhEikUiuyxERkRxRgCEiIiWj1LuPPPII3Htvdvuzn4XU8AIZG2/eiI0733A3H9HMjCNnTGGFIoPz+/2Ew2F1IxERKWEKMEREpGSkv701xmQGBiwVPT3wzW9mt9/xDjj++L7nRLoibL59c2b7yEuOnJriREbA7/cTjUY1G4mISAlTgCEiIiWjlLuP/PjH0NLiPJ42Da64Yt9znr/teeLBuHPO3GnMOmXWFFYoMjS3243b7c6MhSEiIqVHAYaIiJQEa23JBhjPPAO33Zbd/uxnoba27znxcJxNt2zKbB9x8REYY6aoQpGR8fv9mo1ERKSEKcAQEZGSEA6HiUajmW9xS0UsBl//OqRb3J9yCpxxxr7nbb59M+EO51vtqhlVzD1z7hRWKTIy6W4k4XCYZDKZ63JERGSKKcAQEZGSUKqtL66/HrZtcx5XVMB//zf0b1gRj8R55sZnMttHXHIELo/eIkj+cblcuN1uIpGIupGIiJQgvTsREZGil0wmMy0wSinAeOUV+NWvstuf/CTMGGBSkRfufIFQq9Mkv2J6BYeec+gUVSgyemVlZZnBPEVEpLQowBARkaKXnjrV4/HgcpXGS18yCV/7GsSdMTlZsgTOP3/f8xKxRN/WFxcfgdtXOl1spPD4fD51IxERKVGl8S5ORERKWil2H7ntNti40Xns8cCVV8JA2c2WP20h2BIEoKy+jAXvWjCFVYqMnsvlwuPxqBWGiEgJUoAhIiJFLZFIEA6HicVi+Hy+XJczJbZtgx/+MLv9oQ/BnDn7npeMJdlw/YbM9pEXH4nH75n8AkXGSbORiIiUJgUYIiJS1NLdR7xeb0l0H4nF4AtfgEjE2Z47Fy69dOBzt/xlC4FdAQDKppWx4Dy1vpDC4PP5iMViRCIREolErssREZEpUvzv5EREpKSVWveRn/wEtmxxHvt88I1vgNe773nJeJKnf/V0ZnvxhYvxlg9wokgecrlceL1etcIQESkxCjBERKRoxeNxIpEI8Xi8JLqP/POf8JvfZLcvvxwOOWTgc1/++8sE3nRaX/hr/Cy6YNEUVCgycfx+P+FwWAGGiEgJUYAhIiJFKxQKEQ6H8Xq9GGNyXc6k6uyEL385u33SSfCe9wx8rk3YfVtfVKj1hRQWn8+XGeMmGo3muhwREZkCCjBERKRopQOMsrKyXJcyqayFr38d9uxxtqdNc8KMwTKbl+99ma7XugDwVftY9G61vpDCY4zRYJ4iIiVGAYaIiBSlSCRCOBzGWot3oEEgisidd8KDD2a3v/QlaGgY+FybtGz41YbM9uHvPxxfVfF3r5HiVFZWlulGYq3NdTkiIjLJFGCIiEhR6j14ZzF3H3n1Vfje97Lb7343LFs2+Pmv/OMVOrZ1AOCp8HD4ew+f3AJFJpHH48EYkwksRUSkuCnAEBGRopNMJgkGg0XffSQWgyuvhPTntjlz4FOfGvz8ZDzJ+p+tz2wf/t7D8VeXxuwsUrzSrTCCwWCuSxERkUmmAGMUjDGzjTF2iOV3Y7jnScaYvxpj2owxQWPMs8aYTxtj3JPxM4iIlIL0oH5utxu3u3j/nH7/+7B5s/PY63WmTB1qttgX736xz9gXSy5aMgVVikwuv99PNBolHA6TSCRyXY6IiEwiT64LKFDPAHcOsH/TaG5ijHkn8EcgDPweaAPOBr4PnAxcMK4qRURKVCm0vrjvPrj11uz25ZfDvHmDnx8Px3nq/57KbB9xyRFqfSFFweVy4fV6M2NhVFVV5bokERGZJAowxmaDtfaq8dzAGFMD/AJIAKdaa9en9n8ReAA43xjzXmvtqFt1iIiUsng8TjgcJhaLUV1dnetyJsWrr8LXvpbdXrkS3vveoa957tbnCO5xmtiXN5Zz+Hs09oUUj7KyMoLBIMFgUAGGiEgRUxeS3DkfmA78Lh1eAFhrw8CVqc1P5KKwfPfqq3DKKc63jddfDxs2gKZ/F5G0YDBIJBLB5/MV5eCd4TD8139Burv/rFnOrCND/aiR7ggbrt+Q2T7mX4/BU6bvMKR4eL1eEokEkUiEqN4UiIgULb17GZv9jDEfAxqAVmCttfbZUd5jZWr99wGOPQwEgZOMMX5rbWTspRafJ5+ENWucJc3ng0WL4Kij4OijnfURR0BlZe7qFJGpZ60lFAoRDoeL9lvYb38btm51Hvt8zvZwP+ozNz5DtNv5UFczq4ZDzzl0kqsUmVrGmD6Defp8mhpYRKQYKcAYmzNSS4YxZjVwsbX2tRHeI/3ucUv/A9bauDFmG7AImANsHupGxpgnBzlUlJ2/N2zYd180Ck8/7Sy/+pWzzxhYsCAbaqSDjbq6qaxWRKZSeipFay1erzfX5Uy4P/0J7r47u/3Zz8L8+UNfE9wTZNMt2SGajv23Y3F51ABTio/f76erq4tQKERtbW1RtsASESl1CjBGJwh8DWcAz1dS+5YAVwGnAfcbY4601vaM4F61qXXnIMfT++vGUmgxu+wyOP74bGDx9NOwffu+51nrjM6/eTPcfHN2/5w52UAjvUyfPmXli8gkKubBO196Cb71rez2294G5547/HVPXvckiYgzM0PDoQ3MOX3O5BQokmMejweXy5UJMsvLy3NdkoiITDBjrc11DVPKGLMdOGgUl9xkrb1wmHt6gEeBE4BPW2uvGUEdW4B5wDxr7csDHH8MWAostdauG0W9ve/RU15eXlEK86K3tzstM55+Gp56ylm/8AIkkyO7ftYsJ8g45hhnOfpomDFjUksWkQmWTCbZtWsXra2tTJs2DZereFoZ9PTARRfBa6k2fnPmwI03wnCfzzpf7+TWf7kVUn8Lz7r2LGYtnTW5xYrkUCgUIh6P09jYSENDQ67LERGZdBUVFYRCoaC1tiQ6z5diC4ytONOWjtSbw52Q6vJxHU6AsRwYNsAg28KidpDjNf3OkyFMmwanneYsacEgPPtsNtR46inYuBFisX2vf/11Z7nrruy+/fZzwoxjj82um5sn/2cRkbFJj32R/ha2WFgLX/5yNrwoL3fGvRjJl8tP/vTJTHgx85iZHHDiAZNXqEge8Pv9mZZYiUQCt9ud65JERGQClVyAYa1dNUm33pNajzT5ehE4FpgP9BnDItWi42AgTrarioxSRQWceKKzpEWj8NxzzkCgTz3lrJ95BiIDDJP65pvO0ru/+f779w00jj1W3U9E8kV69pFi6z5y3XWwenV2+8or4eCDh79u74t72Xrv1sz28Z88XmMCSNFzuVx4vd7MYJ7FOpWyiEipKrkAYxKlPyaPNHB4APgAcBZwS79jy4EK4GHNQDKxfD5nIM+jjsrui8WccTJ6hxobNkAotO/1O3Y4S++WGgcdlA0z0uHGtGmT/qOISC+xWIxwOEw8Hi+q2Qcefhh+/vPs9vvfD295y/DXWWv55w//mdmefdpsmhY3TUKFIvmnrKyMnp4egsEgVVVVCu5ERIpIyY2BMR7GmBOAp6210X77VwJ/BfzAydbax3odqwVmAp3W2p299tfgdGepSV2zPrW/DCfcWAq8z1r7u3HUWzJjYEy0eNwZQ+PJJ7PL008PHGoMZO5cOO44J9A47jhnTI0indFRJC90dnayZ88ekslk0Uyfum0bXHyx0x0OnL8lP/oRjKRF/KsPv8q9n7nX2XDB+b8/n2kHK1mV0mCtpb29nerqapqbm4uuVZaISG+lNgaGAoxRSE2VughYDbyR2r0EWJl6/EVr7df7XXMJcD1wo7X2kn7HzgX+gDMmx++ANuAcnClW/wC8247jP5ACjInVO9RYvz4baoRHMKKKMbBwofMB5PjjnfWSJeD3T37dIsUumUyye/duWltbqampweMp/MaFgQB88IPZcS/22w9+/euRTQOdiCW47YLb6H6jG4CF5y/klP8+ZfKKFclDwWCQRCKhwTxFpOhNVIBhjDkA+CpOD4EGYCfO7Jtfsda2j+D6BuBdwNuBxcD+QBTYiPN5+Hpr7QinWBjieRRgjJwx5sM4/1EOBxoBL7AbWAv8yFr7yADXXMIgAUbq+MnAF3BaXJQBLwO/An5orU2Ms14FGJMsFoPnn3cCjfXr4YknnIFDBxootD+fD444IhtqHH88HHooFNHYgyJToqenhz179hAMBqkbySf8PGctXHEFPPqos+33ww03wLx5I7t+ww0beOJHTwDgq/HxnjveQ1mtvoGW0pJMJmlvb6e+vp7m5uaiCDZFRAYyEQGGMWYu8BjQBNwFvAAcD5yGM3bjydba1mHu8XHgpzjBx4PAa0AzcB7OxBV/BC4Yzxf0oACjqCnAyI1IxAkx0oHGE084IcdIpnStqXG6naQDjeOPdwYOFZHBtbS00NraSllZGf4iaNb005/CL3+Z3f7mN+GMM0Z2bXBPkN+f93vioTgASz+7lMPfc/gkVCmS/7q7u/F4PEyfPp2amprhLxARKUATFGDcA5wJXG6tvbbX/quBK4CfW2s/Psw9VuJMaPGX3i0tjDEzgH8Cs4DzrbV/HGudoACjqCnAyB89PU53kyeegH/+01lv3Tr8deAEGMcfDyec4KyPPRY0qLqIIxKJ0NLSQkdHB/X19QU/WN8DD8B//Vd2++KL4d//feTXr/7yal76y0sA1M2p4/xbzse4C/vfRGSsYrEY3d3dNDY20tzcXPB/H0REBjLeAMMYMwdnbMbtwNx+4UM1TosKAzRZa3vG+ByfB76B02thFO9s9qX2dCJToLISTjnFWdJaW51WGulA4/HHoaVl32t37IA77nAWcMbTOOwwJ9A44QRnmthFi0Y2sJ9IsQkGg4RCIcrLywv+w8mTTzpTpKYtXQqXXTby61s2tWTCC4CTPnuSwgspaV6vF5fLRTgcJhQKUVFRkeuSRETyUXo8x3v7j1Fhre02xqzBaZ1xInD/GJ8j3cE+PsbrMxRgiORIQ4MzHWJ6SkRr4fXXnUAjvaxf77Te6M1aeO45Z/nVr5x9lZVOy4x0oHHCCc6gfyLFLJFIEAwGiUQiTCvwuYs3b3bGvYim5riaNQu+8Y2Rj4ljrWXNd9ZktmefNpv9j1P/M5GysjLC4TA9PT0KMEREBnZoar1lkOMv4QQY8xlDgGGM8QAfTG3+fdTV9aMAQyRPGAMHHugs55/v7EsknPEzHn/cCTQefxw2bdp3PI2eHnjoIWdJmzUrG2aceKIzlWt5+dT9PCKTLRgMEg6HM9+yFqpt2+CTn8xOl9rYCD/+sTMmzki99OeX2Pv8XgBcPhcnXnHiJFQqUnj8fj89PT2Ew2Gi0Sg+ny/XJYmITIYyY8yTAx2w1h4zzLW1qXXnIMfT++vGUBfAt3AmwfirtfaeMd4jQwGGSB5zu2HxYmf5yEecfYGA09T88cezy44d+177+uvOctttzrbHA0ce6YQZS5c664MPdoITkUJjrc18KKmqqsp1OWO2c6fTTaQz9dagpgZ+8pPRtaCK9cR4/NrHM9tLLlxC9X4aKEcEwBiD3+8nHA4TDAYVYIiIjF7608KoB880xlwO/AfOrCYXTUQxCjBECkxVFaxY4SxpO3b0DTSeeCL7bW5aPJ6d7vVHP3L2NTU5YUZ6OfZYUAtbKQThcJhIJAI4/dwLUWsrfOIT2bFvKirg2mthzpzR3eepXz5FuC3s3KOpgiMvPXJiCxUpcOXl5XR0dBAMBqmpqSnoFlsiIoMIj6ClxWDSLSxqBzle0++8ETHGXAZcAzwPrLLWto2tvL4UYIgUgf33h/POcxZwwopNm2Dduuzy4ov7XtfSAnfd5SyQbaWxdCmcdJKzPvBAtdKQ/NPT05MZvLMQdXc7LS/eeMPZ9vng6qudAXlHo2N7Bxtv3pjZPuHyE/CWF2agIzJZ3G43Ho8n0wqjkFttiYhMgvSnhPmDHJ+XWg82RsY+jDGfBr4PbMIJLwaYqmBsNI1qEdM0qtJbW5vTOmPdOli71nnc1TX8dfvt54QZ6eWoo5wPWyK5EovF2L17N+3t7QU5dWp3N1x+OWxM5Q4uF/zv/8Ly5aO7j7WWv3ziL+xcvxOA5iOaOfu6swvu30NkKkSjUXp6emhsbKSpqUn/n4hI0ZiAaVTnAi8z9DSqLmD6SKZRNcZ8Dmfciw3AGdbavWOpa9D7K8AoXgowZCjJpDPzwdq12WXz5uGvKytzupqcfHI21GhsnPx6RdI6OjrYs2cP1tqC+yZ1zx7493+Hl1/O7vva1+Ctbx39vV7620us/uJqZ8MF5910Hg3zGiakTpFi1NbWRnV1Nc3NzZSVleW6HBGRCTHeAAPAGHMPzkwjl1trr+21/2rgCuDn1tqPp/Z5gblAzFq7td99vgh8FXgSOHOiuo30eQ4FGMVLAYaMVnt7toXGY485rTQCgeGvmz/fCTTSy6GHqtuJTI5kMsmuXbtobW2lrq4Ot9ud65JGbPt2Z7aRXbuy+z73ObjggtHfK9Id4dbzbiXc7ox9sfjCxZz4ac08IjKUYDBIIpGgsbGRhgaFfSJSHCYowJgLPAY0AXcBm4ETgNNwuo6cZK1tTZ07G9gGvGqtnd3rHhcDNwAJ4FoGHjNju7X2hrHWCQowipoCDBmvRMIZS+Oxx7LLK68Mf11Dg9MyIx1oHHus03JDZLwCgQAtLS1EIhFqawcbayr/bNoEn/pUdrYRtxu+/GV429vGdr9HvvkIL/zxBQAqmyq54I8XaOwLkWEkk8lM17Pm5mY8Hg0FJyKFbyICDABjzCyc1hNnAQ04XUfuBL7SuyXFEAHGVcCXh3mah6y1p46rTgUYxUsBhkyGXbuyYcaaNc6UrrHY0Nd4vXDMMX1baTQ1TU29UjystbS0tLB3714qKysLZjrENWuclhZhp7EEZWXw3e86g+SORcvGFu760F2ZycxO/+7pHHzawRNTrEiR6+7uxu1209jYSF1dXa7LEREZt4kKMAqFAowipgBDpkI47EzNmg401qxxpoccziGH9A00FixwBjMUGUwoFKKlpYXu7m7q6+tzXc6I/PnP8NWvOmPOANTVwTXXjH62kTSbsNx+0e20bXG+CJl1yize8v23aEBCkRGKx+N0dnbS0NBAc3NzQXVDExEZiAIMKRoKMCQXrIUtW7Jhxpo1A0/h2l99vfONdDrQOO44KNAZMmWS7Nmzh9bWVnw+X94PwGctXHcd/Pzn2X377Qc/+pEzNfFYbbx5I+uuXgeA2+/mgtsuoHq/6nFWK1Jaurq68Hq9TJ8+nZqamlyXIyIyLgowpGgowJB8sXdv3xYaTzwB0ejQ16S7nZxySjbUmD59auqV/BOJRNi9ezednZ15P3VqKARXXQX335/dN28eXHvt+Gbs6Wnp4dbzbyUejANw3CeP48hLjhxXrSKlKBaL0d3dnWmF4VLzPxEpYAowpGgowJB8FQ47Y2f0bqUxkm4nhx6aDTSWLYO5czXbSanYu3cvra2tuN1uKioqcl3OoHbvhs98pm+ro+OPh+98B8Y74+t9/3Uf2x/YDkDdnDr+5aZ/weXVBy+Rsejo6KC8vJzp06cX3HTMIiK9KcCQoqEAQwpF/24njz0GL7ww/HUzZjiBxrJlzrJkiTO7gxSXaDTK7t276ejoYNq0aXn7benGjfAf/wFtvWY8f/e7nUBjvJMdvL7mdf7+qb9ntt/xi3cw86iZ47upSAmLRqP09PTQ2NhIU1NTXrfqEhEZigIMKRoKMKSQpbudPPpottvJcLOdVFc707cuWwbLlzvjaOT5UAkyAm1tbezduxdjDJWV+fna/Oc/wze+kf0ddbudmUfOO2/8944FY9x2wW307O4BYN475nHqVaeO/8YiJa69vZ3KykqampryumWXiMhQFGBI0VCAIcUkFHJmO3n00Wyo0dk59DU+n9N8Px1onHQSaLy2whKLxdi9ezft7e152foiGnXGtrjlluy+2lqny8gxx0zMc6z5zhqev/V5APy1fi74wwWUT9MItyLjFQ6HCYfDNDY2Mn36dLXCEJGCpABDioYCDClmiQQ89xw88kh2efPNoa9xueDII50wY/lyp/uJBgbNb+3t7ezduxdrbd71U3/5ZbjySmedNmcOfP/7sP/+E/Mcu57Zxd0fuRtSL9Wnfu1U5r113sTcXKTEWWtpb2+nurqapqYmyjX1lYgUIAUYUjQUYEgpsRa2b+8baIxk+taFC50wY8UKZz1RHzxl/OLxOLt376atrY26ujrceTLAibXwu985LS96z6azfDl87WswUb1cEtEEt7//djq2dwAw6+RZvOUHb9G3xCITKBQKEYvFaGhoYLoSbREpQAowpGgowJBSt3u3090kHWhs2ADJ5NDXzJmTDTOWL4eDD9ZMJ7nS2dnJ3r17icfjVFdX57ocAPbscaZIffzx7D6fD664As4/f2J/V5746RNs+OUGADwVHi649QKqZuRXKxSRQmetzYSkTU1N+P3+XJckIjIqCjCkaCjAEOmrs9MZGPThh51lJAODHnBANsxYscKZylWBxuRLJBKZ1hc1NTV4xjuNxzhZCw884AzU2dWV3X/oofD1rztB10Rqe6mN2y+8HZtwXqNP+txJLLpg0cQ+iYgAEAwGSSQSNDY20tDQkOtyRERGRQGGFA0FGCJDCwadb9LTgcbatc5goUNpanLCjPTAoIsXa+rWydDV1cWePXuIxWLU5Hjk1RdfhB/8wAm80oyBiy6CT3wCvN6JfT6bsNx56Z3sfX4vAM1HNHP2dWer64jIJEkmk5mBgpubm/FO9P/UIiKTSAGGFA0FGCKjE406M508/DA89JAz00l399DX1NbCySdnQ41jj3W6FMjYJZPJTOuLqqqqnH2Y2LMHfvxj+MtfnBYYac3N8NWvTtwsI/09+9tnefwHTh8Vl9fFv9zyL9TNrpucJxMRAAKBAMYYGhoaqK+vz3U5IiIjpgBDioYCDJHxicfhmWecMCPdSqO9fehrysqcqVtPOcUJNk46CerqpqTcohEIBNizZw+hUIi6HPzjhUJw443wm99AJJLd73LBeefBZZfBZA3J0fVGF394zx9IRBIAHPtvx3LUh46anCcTkYzerTCamprwKYkWkQKhAEOKhgIMkYmVTMKmTc6AoOlAY9euoa8xBg4/PBtonHwyHHSQxtEYTO/WF5WVlVP6IaKnB+64wwkuWlv7Hlu2DC6/fOLHuujNJi1/+cRf2PnkTgDq59Xzrt+8C5fHNXlPKiIZPT09JJNJjYUhIgVFAYYUDQUYIpPLWti6NRtmPPIIvPLK8Nftv382zDj5ZDjiCMjxGJV5Iz32RTQapba2dkqec88euOUW+OMfnRCjt/nznRlGjjtu8ut4+vqnWf/j9c6GC8698VymL9S0jiJTJd0KQzOSiEghUYAhRUMBhsjU27nTGTvj0UedZcMGSCSGvqayEk44IRtoLF0KOR63Mid6zzxSXV096WNfbNvmtLb461+d7kK9TZ8O//Zv8Pa3O11HJtvuZ3fzp4/8CVLT/B754SM57hNTkJqISB/pGUkaGhpobGzMdTkiIsNSgCFFQwGGSO4FAs5MJ+lQY+1aZ99QjHFmNznhBOeb/+OOg0WLJn62i3zT0dFBa2vrpM48Eos5rWXuuAPWrdv3+IEHOrOLvP3tUzcYa7Q7yh/f/0cCO51fjOYlzZz9i7MxbvUzEplq6VYYtbW1NDU1UVZWluuSRESGpABDioYCDJH8k0jAxo1OmLFmjbO8/vrw15WVwVFHOWHGMcfAkiWwcCEUSwvneDyeaX1RW1uLZ4L71GzfDnfdBX/+88ADsS5ZAh/8IKxYMbXjk1hruf9/7mfbP7YB4Kv2cd7N51E9c5JGCRWRYYVCIWKxGA0NDUyfrm5cIpLfFGBI0VCAIVIYXn89G2asWePMfJJMDn+dxwMLFjgfvtPL4sXOGBuFNkhoe3s7e/fuJZlMUj1BU3y0tzvjktx9Nzz99L7HjXEG57z4Ymccklx44c4XeOTrj2S2T//O6Ry8chJHChWRYVlraW9vp7q6mqamJsrLy3NdkojIoBRgSNFQgCFSmLq74Ykn+i6vvTby6+vqnJlPDj/cCTQWL3a6oNTXT1rJ4xKLxdi9e3dm8Dy32z2m+1jrjGvx0ENOcLFxo7Ovv6YmeOc74ZxzYObMcRY/Du3b2rnjwjsyU6YuOG8Byz6/LHcFiUhGOBwmEolkWmGYQkuFRaRkKMCQoqEAQ6R47N4N69c7YcazzzqtNEYy40lvM2Y4QUbvZeHC3Acbra2ttKbmLa2qqhrxddY6/y4bNzqDpT7yCLz55sDnut2wfDmce64zSOpUDMw5lEQ0wZ0X30nbS20A1M2p412/fheeMk1HI5IPerfCmD59OhUVFbkuSURkQAowpGgowBApbt3dsGlTNtDYuNFZOjtHd5/6eme60Hnzssshh8Ds2dDQMLndUSKRCC0tLXR0dDBt2jRcgyQL1jo/19atzs+4aZOzTuUeA3K5nG41K1bA297m/Cz5Ys131vD8rc8D4Pa5eddv3sW0udNyXJWI9BaJRAiFQjQ0NNDU1KRWGCKSlxRgSNFQgCFSeqyFHTv6fsjfuBFeeAHC4dHfr6ICDjqo7zJjhjPNaGOjs54+HaqrxxZ07N27l717W4nF3MTjFXR1OUHFrl3O2CC9l+Fmb0nXe9JJTmuLk05yutPkm5f+9hKrv7g6s33yf5/MYecflruCRGRQ7e3tVFZW0tjYOKoWYiIiU0UBhhQNBRgikpZIOF1Onnuu7/LSSxAKjf/+Ph/U1jqzpZSVObOjpB97vc7zx2IQj2cXCONytWBMJ7t31wOjT0AqKrLjfRxzDBx9dH5PN9uysYW7P3Y3yagzSuvs02Zz+ndO1ze7InkqGo3S09NDfX09zc3Ng7YSExHJFQUYUjQUYIjIcJJJp8XGSy9lly1bnLDj1VdH1uphbCzTp++hvr6NaNRLODz8KP8VFTBrFhx2WHaA0tmzcz+exUgFdgW444N3EG5zmsLUzanj3OvPxVuZx4mLiNDR0YHf76ehoYG6fGzWJSIlrdQCDI0WJiJSwlwuJxSYNQtWrux7zFpnKtJXX80ur78OLS2wZ4+z7N3rrEebk1ZV9VBREcTtjhMOV2dacNTUOOv6ejjwwGxts2Y5+wq1oUIsFOPez9ybCS/8tX7O+v5ZCi9ECkBVVRWdnZ2UlZVRWVmJN5+beYmIFDkFGCIiMiBjnNCgvh6OOmroc3t6nNYakYgz1kZ6iUQgGgWPx+na4fGAy5Wgp6eLcLiHhoYqGhoMfv/U/Ey5YK1l9ZdW07rFGXHUuA1nfPcMqvevznFlIjISHo8Hv99PIBDA7/fT2NiY65JEREqWAgwRERm3ykpnGYm2tk7a2oLE425qanyTW1geWP/T9Wx/cHtm+5TPn8LMo2fmriARGbWKigra29vp6emhoqJC06qKiORIgfQcFhGRYhCJROjp6SEUClE50sSjgL30t5fY8KsNme3D3384C965IHcFiciYuFwuKisrCQQCdHV1kUwmc12SiEhJUoAhIiJTwlpLZ2cnPT09lJeX43a7c13SpNq9cTcPf+3hzPYBJx3AiZ8+MYcVich4lJWVYYyhp6eH7u7uXJcjIlKSFGCIiMiUCAQCBINB4vE45eXDzzpSyDpe7eCeT9+TmS617uA6Vv2/VRhXgY5CKiKAM6BnMBgkEAgQi8VyXY6ISMlRgCEiIpMuHo/T3d1NIBCgqqoKU6jTiYxAcG+Qv33yb0Q6IwCU1ZXxlu+/BV9V8Y/3IVLseg/o2dnZmetyRERKjgIMERGZdF1dXfT09ODxePD5iveDfKwnxt8u/xuBnQEAPGUezrrmLGoOqMlxZSIyUSoqKohGowSDQYKjnUNaRETGRQGGiIhMqnA4TE9PD+FwmKqqqlyXM2mSsST3fvZe2ra0OTtccPq3T2f6oum5LUxEJlTvAT27u7s1oKeIyBRSgCEiIpMmPXBnIBCgoqICl6s4X3astay+ajVv/vPNzL7lX1zOrJNn5bAqEZksZWVlAJlZSUREZGoU5ztJERHJC11dXQSDQZLJZOYNfzF6/JrH2XrP1sz2sZ84lkPPPjSHFYnIZEsP6Nnd3U04HM51OSIiJUEBhoiITIpIJJIZuLO6urpoB+589rfPsvG3GzPbC/5lAUd+6MjcFSQiU8Lj8VBRUUF3dzcdHR3qSiIiMgUUYIiIyIRLJpN0dHTQ3d1NeXk5Ho8n1yVNio23bOTxHzye2Z596mxO+dwpRRvWiEhf6Smhe3p66OjoyG0xIiIlQAGGiIhMuPS4F9bazBv8YrPxlo2s+966zPaMI2dw2jdOw7gUXoiUkurqaoLBIIFAgFAolOtyRESKWnF+JSYiIjkTCoUIBAIEg0Hq6uqKsjXCxps3su7qbHjRvKSZs354Fh6/XlZFSo3b7aayspLu7m68Xi8+nw+3253rskREipJaYIyCMeYGY4wdZrl/hPeaPcx9fjfZP4+IyERLJBJ0dHTQ1dVFZWVlUb6J33hTv/DiiGbe+qO34q3w5rAqEcmlsrIyXC6XupKIiEwyfVU0OncC2wc5dhEwB/jbKO/5TOq+/W0a5X1ERHKuo6ODQCCAy+UqyllHnv3ts33GvJhx5AzO+uFZCi9EhOrq6szfwLKyMiorK3NdkohI0VGAMQrW2jsZIGwwxtQB/wVEgRtGedsN1tqrxleZiEju9fT0EAgEiEQi1NXV5bqcCafwQkSG4nK5qKysJBAI4PV68fv9RTuAsYhIruiv6sS4CCgHfmet3ZvrYkREplo8Hs8M3FlZWYnLVTw9FG3Ssu6adWy6KdswbsZRqfCiXOGFiGT5/X4ikUgmxGhsbCzKcYBERHJFAcbE+Ghq/X9juHY/Y8zHgAagFVhrrX12wioTEZlkyWSStrY2uru78Xg8+P3+XJc0YWKhGA984QFee/i1zL4ZR8/grGsUXojIwKqqqjJdSbxeb1G2SBMRyRUFGONkjFkKLAa2WGsfHMMtzkgtve+5GrjYWvvagFfsW8OTgxwqvg7oIpJ3Ojo66O7uJh6PF9Ub9cDuAPdccQ9tW9oy+2afOptTv3aqwgsRGZTL5aKmpobOzk7cbjder1fjYYiITJDiaeObO/+aWv9ilNcFga8BxwDTUssK4EHgVOB+Y4xe7UQkr3V3d9Pd3U0wGKSmpqZomkrveW4Pd37wzj7hxZIPLuH0756u8EJEhuXxeDJTq3Z0dBCNRnNdkohIUTDW2lzXMKWMMduBg0ZxyU3W2gsHuVct8CZOS5b9J2L8C2OMB3gUOAH4tLX2mnHcq6e8vLwiGAyOtywRkX2Ew2H27t1Le3s71dXV+Hy+XJc0IV657xVWf3k1iWgCAOM2LPvCMg4959AcVyYihSYQCJBIJKivr6exsbEop5YWkdyqqKggFAoFrbUl8eV3KXYh2QqER3H+m0McuxCoYAIH77TWxo0x1+EEGMuBMQcYIiKTJR6P09bWRmdnJ+Xl5UURXtiEZf3P1rPh+g2Zfb4aH2d+90xmHjMzd4WJSMGqrKyks7OT7u5u3G43DQ0NRdNSTUQkF0ouwLDWrprA26UH7/z5BN4TYE9qXRIpmogUlt6DdrrdbioqKnJd0rgFdgd44PMPsPuZ3Zl9NQfWcNY1Z1E7qzaHlYlIITPGUFNT02dQz9pa/U0RERmrkgswJoox5gTgCJzBO1dP8O1PTK1fmeD7ioiMi7W26AbtfPWRV3noyw8R6Ypk9u1//P6s+tYq/DXFM6OKiOSGy+Wiurqarq6uzKCexRD8iojkggKMsUsP3jnk1KmpcTJmAp3W2p299p8APG2tjfY7fyVwRWrztxNXrojI+KUH7QyFQtTW1hZ0U+hkLMnj1z7Opps3ZXe64NiPH8uRlxyJcRXuzyYi+SU9E0lXVxculwu3211UU06LiEwVBRhjYIypAd4DRIEbhzn9XcD1qfMu6bX/28Ci1JSpb6T2LQFWph5/0Vr72ASVLCIyboFAgM7OTrq6uqiuri7owei6d3Tzj//5B3ufzw5fVNFUwcpvrGTmURrvQkQmXllZGfF4nM7OTowxNDY2FsX4QSIiU0kBxth8AGd8ivEM3vkbnHDjOOCtgBfYDdwK/Mha+8hEFCoiMhGCwSAdHR10dnZSWVlZsG+6rbW8cOcLrPv+OuLBeGb/rFNmcepVp1JWV5bD6kSk2FVVVdHd3U1XV1cmxPB6NTWziMhIldw0qqVE06iKyEQIhUK0trbS2dlJWVkZ5eXluS5pTAK7Azz81YfZ8fiOzD7jNhz/78ez+AOLC7o7jIgUDmst3d3dGGOoq6vT9KoiMi6aRlVERCQlHA5npkv1+/0FGV5Ya9ly9xbWfm8tsZ5YZn/tQbWc9tXTmL5oeg6rE5FSY4yhurqazs7OTHeShoYGhRgiIiOgAENERAYUjUYz4UWhjpof3BPk4a8/zOtrXs/uNLD4A4s59hPH4vHrZVBEpl56etX0uELpEMPlcuW6NBGRvKZ3biIiso9YLJbpNuJ2u6mqqsp1SaOSjCd57rbnePLnTxILZFtd1MyqYcVVK5hxxIwcVici4kyvWltbS0dHB8aYTIih7mwiIoNTgCEiIn3EYjH27t2badpcaOHF62tfZ9331tGxvaPP/kXvXcTxnzweT5le+kQkP/QPMQDq6+vVEkNEZBB6FyciIhmRSITW1la6urqw1lJTU1Mw3wZ2vt7JuqvX8dojr/XZXzOrhuVfXM7MozU9qojkH7fbTW1tbebvrrWW+vp6jYkhIjIABRgiIgI4s42kx7xwuVwFE15EuiNsuH4DG2/eiI1nZ9byVHg45qPHcPh7D8fl1beZIpK/PB4PtbW1dHZ2kkwmSSaTNDQ04PHorbqISG/6qygiIvT09NDe3p4ZsLMQuo2EO8NsvGkjz/3+uT6zi2Bg/tnzOf6y4ylvKLxZU0SkNLndburq6ujq6qKjo4NkMkljYyNerzfXpYmI5A0FGCIiJa6rqysznV9ZWVnezzYSag/x7G+e5fnbniceivc51rykmaWfXcr0hZoaVUQKT3pMjPTfZXDGxPD7/TmuTEQkPyjAEBEpUdbaTHDR1dVFZWUlZWVluS5rUME9QZ757TNs/sNmEpFEn2N1s+s46qNHMffMuQXR7UVEZDDpKVa7u7szLTHq6+spL1eLMhERBRgiIiUokUjQ0dFBd3c33d3dVFdX4/P5cl3WPqy17Fy/k+due47tq7dDsu/xaXOncdRHjmLOqjkYl4ILESkO6RAjEAhkQoyampqCGZtIRGSyKMAQESkxkUgkE16EQiFqamryro91tDvKi39+kc1/2Eznq537HK+fX8/RHz2a2afO1pt5ESlaVVVVhEIhOjo6SCQSxGIxpk2bphlKRKRkKcAQESkhgUAg02XEWsu0adNwufJjhg6bsOxYv4Ot92xl6z1b9+kmAjDj6BksuWgJB55yoIILESkJ5eXleDweurq6iMVixONxpk2bpnExRKQkKcAQESkByWSS9vZ2AoEA3d3d+P1+Kioqch4C2ITlzafe5JX7XmHb/duIdEb2OcdT4WH+O+Zz2PmHMW3OtBxUKSKSW16vl2nTptHV1UV7ezuJRILa2tqCmDFKRGQiKcAQESly0Wg0E16EQiGqqqpyOt5FLBRj5/qdvPrIq2x/cDvh9vCA59XPq+ewCw7jkLcegrc8v7q4iIhMtfQMJcFgkPb2duLxONFolNraWnUpEZGSoQBDCk7rS628/LeX8VZ48ZR78FZ4naXcm33c75jLnR9N5EWmUjKZpLu7O9PqIplM5uSNrrWWtpfaeH3t67yx9g12bdiFjdsBz61oqmDO6XOYe8Zcph8+PectRERE8okxhsrKSrxeb6ZLSSQSoba2Nu+nwBYRmQgKMKTg7HxyJ3//1N9HdY3b5+4bdgwTeAy0vc8ywPVur74BkfwQDofp7Oykp6eHnp4eysrKqK6unpJAwCYsrS+1suuZXbQ808KbT75JqDU06PnljeXMOX0Oc86YQ/OSZoUWIiLD8Pl81NXVEQgEaGtrIxqNUlVVRW1tLR6P3t6LSPHSXzgpOLFgbNTXJKIJEtHEgP3rJ5LL4xo+BCn34qkYJhwZJmRRUCKDSSQSdHV1EQgECAQCmVYXk/WG1lpLYFeAtpfbaNnYwu5nd7Nn0x7i4fiQ1007ZBoHLD2Ag5YdxIwjZ2gKVBGRUXK73dTW1hIOh+nu7iYajRKJRKipqaGyslJhsIgUJQUYUnAaFzRy3CePIx6KEwvG+izxUJxoT7TvsVAMBm6tPuGS8SSRrgiRrqkJSkbbqmRULUwUlBQUay2hUIjOzk6CwSDBYJCKigrKysom5E1sMp4ksCtA1xtdtL/STtvLbbRvbaf9lXbioaHDCgB/rZ8DTjiAA5YewAEnHkDFdDV1FhGZCGVlZfh8PgKBAO3t7cRiMUKhELW1tTkd70hEZDIYa6fok51MOWNMT3l5eUUwGMx1KTllrSURSWSDjdAwoccAx0d0fk8Mmyyu/58GDUqGWDzlnkyQkrmuPLu/99pTln3s8rj0bdEYpb99CwaDBAIBXC4XVVVVIx7rwlpLuCNMcG+Q4J4gwb1BArsDdO/opvvNbgJvBgi0BCA58pqqZlTRvKSZpiOaaF7STOOhjWplISIyyaLRKIFAAK/XS2VlJRUVFVRXV+P1aiBkkWJVUVFBKBQKWmsrc13LVFCAUcQUYEwtay3JWHLAECQdcMRC+wYivc+PB/seK5WgBMC4DJ4yz4gXd5k7G4CM4rrBFpen8AZ6jUQimeAiGAwSj8cp95VDDCJdEaLdUSLdzjrcGSbcESbSESHSGXG2O8OE9oYItgaxibH/Tvlr/dQfUk/D/AaalzTTfEQzlU0l8RoqIpJ3kskkoVCIcDiM3++nsrKSyspKqqurNVuJSBFSgCFFQwFGcbLWkogm9ukmM2BIMkxrkqH2R3ui4/pQW2iMu1+A4k8FJX43Hv++a5fXhdvnxu1zZx973Ri3weV2Zdcug3EbZ51ejLPGOCPK06thQroVSvq/cyKaIBFx1vFInEQ0QbgnTE+oh2AoSCQeIRaJEe+IE2uNkQgnJukfCCqmV1CzXw21s2uZNnca9YfUUz+3nrJpE9NNRUREJk4ymSQYDBKJRCgvL6eiooLKyspRtdATkfynAEOKhgIMGa9ENNEnBEkHHfuMM9K/xUivEKV3mNL7WDzc93EyPor+CaXKD1QC5UBFajsIDD7Bx4j5qn1UTK+gotFZKqdXUr1/NdX7OUvVzCqNiSIiUoASiQQ9PT3EYjEqKir6hBnqWiJS+EotwNAgniIyqHQLg7Laskl/rmQ8STzihBnxcNwJNnpvp/elgo9EJJENQQa4JhFOZPb3Pr//kr5+qgZ6HTWDE1ZU4gQW5YAPJ7RoY9+6XeCv9uOv8eOr9uGvTq1r/JTVlVFWW4a/1u+s6/yUTyunYnoFHr9eDkREipHb7aampoZ4PJ7pctjT00MgEKC8vJzKykr8fr9a0olIQdA7VhHJCy6PC5/Hh69y6kdMt9aSjCf3DTki8ey+9OPUOhFzunUkY8lsV49YApuwJBPJ7DppsQnrrG1qnbRgyezLFpJ9mCRJ0p8k4UtgfZakJ4nxGHweHxWVFfir/PiqnH8vb5UXX6UPX5UPT7lHb0JFRGQfHo+HmpoaEokEoVCI9vb2PkFGunWGupeISD5TgCEiJc8Yg9vrjGHhq8rdlHPpN5WhUIhIJEI4HCYcDuNyuSgvL8fn8ymcEBGRcXG73VRVVVFRUZGZxaqnp4eysjL8fj9lZWWUl5dTVlaGy1V4A1yLSHFTgCEikkPp0eJ7hxbRaJR4PI7f76empgaPR3+qRURkYrlcrkyri2g0SiQSoaenB5/Ph9/vx+fzUV5eTnl5ubqYiEje0LtiEZEpZK0lFosRiUQyS/qNYywWw+v1UlZWptYWIiIyJYwx+P1+/H4/yWSSSCRCMBiku7s7sz/92pRuoaFuJiKSKwowREQmWSKR2CewiMVimZYWHo8Hv99PdXW1QgsREcmZdJfF8vLyzGtXIBAgmUzi8/nwer19Ag2fz4fP51NXExGZMgowREQmULqFRTqgSIcU6cexWAwAn89HWVkZXq9Xb/xERCTvuN1uKioqqKioIJlMZl7Henp6cLlcmSDD4/Fkwo10oKGujyKFxxhzAPBV4CygAdgJ3Al8xVrbPtX3GfT+fUbAl6JijOkpLy+vCAaDuS5FpCglk0ni8TixWCyz7r3E43Hi8TjJZLLPGzy9sRMRkULVO6iPxWIkEglcLhderzezeDyefR57PJolS2QyVFRUEAqFgtbayrHewxgzF3gMaALuAl4AjgdOA14ETrbWtk7VfYaid9EiIkOw1pJIJEgkEsTj8cy6d0DR/5gxJvPGrby8XIGFiIgUDWNMpqUFOK+T6dfFdJcTYwwejwe3243H48k8TgcZ/Y+pJaJIzv0EJ3S43Fp7bXqnMeZq4ArgG8DHp/A+g1ILjCKmFhgiw0smkyQSicx6qCXdmqL3vvQbML0RExERcfQP9tOvn71fM91uNy6Xq892/8XlcmXWem0VGdh4W2AYY+YAW4HtwFxrbbLXsWqcLiAGaLLW9kz2fYajrwVFpOBZa/ssyWSSZDLZ5/FQSyKRyLS06B1opB8bY/q8ofL7/ZnHag4rIiLSV/o1srd0S430FwCRSCTzegv0CSt6hxb9l4GOGWP2edx7LSJDWpla39s7dACw1nYbY9YAZwInAvdPwX2GpABDRADnjcVIjw21PdDj/vv67++/b7DtgYKK4fb3f9w/3DDGZAKK9Juf9MCa6TdKevMjIiIyPr27V/bX+0uD9DoWi/V53QYGDS16H0u/rvdeBts/0JKutf927/399/X+GYd7PJLt4faLTLBDU+stgxx/CSd4mM/QwcNE3WdICjCkICUSCfbu3Usikch1KUVlNF3KBgstem8PdL/BAozBjg8WZKT3pcOIsUi/6Ul/KyQiIiL5xxjTZ0yq0V47VEAxXGjR+1jv/QOFC4MdGyrMGK52yT/GGBoaGjLjwOSJMmPMkwMdsNYeM8y1tal15yDH0/vrpug+Q1KAIQUpnc4Xonwcd2a8NY30mwQRERGRUjaWL4vy7X1VvtUz1dJfoJWQ9H/w8X6ImZD7KMCQguT1epkxY0bBhhgDmawXg1J/kREREREpdpPxBVk+fumWD9JdjPNMeAQtLQaTbhlRO8jxmn7nTfZ9hqQAQwqWRqQWEREREREZlxdT6/mDHJ+XWg82tsVE32dI+vQnIiIiIiIiUpoeTK3PNMb0yQdS05+eDISAdVN0nyEpwBAREREREREpQdbarcC9wGzgsn6HvwJUAr+21vYAGGO8xpgFxpi547nPWBn1bSpexpie8vLyimAwmOtSREREREREZIJVVFQQCoWC1trKsd4jFUY8BjQBdwGbgROA03C6fJxkrW1NnTsb2Aa8aq2dPdb7jJVaYIiIiIiIiIiUqFTriWOBG3ACh/8A5gI/BJaONHSYqPsMRS0wiphaYIiIiIiIiBSviWiBUUjUAkNERERERERE8p4CDBERERERERHJewowRERERERERCTvKcAQERERERERkbynAENERERERERE8p4CDBERERERERHJewowRERERERERCTvKcAQERERERERkbynAENERERERERE8p4CDBERERERERHJeyUbYBhjvMaYTxljrjfGbDDGRI0x1hjzkRFce7Ex5p/GmIAxptMYs9oY844x1jFh9xIREREREREpViUbYACVwA+AS4AZwK6RXGSM+V/gBmAm8Avgt8Bi4G5jzCdHU8BE3ktERERERESkmBlrba5ryAljjA9YBWyw1u40xlwFfBn4qLX2ukGuOQlYA2wFjrPWtqf2zwaexAlFFlhrt4/g+SfsXkM8R095eXlFMBgc6y1EREREREQkT1VUVBAKhYLW2spc1zIVSrYFhrU2aq39m7V25ygu+3hq/Y104JC613bgx4AfuDQH9xIREREREREpaiUbYIzRytT67wMc+1u/c6byXiIiIiIiIiJFzZPrAgqFMaYS2B8IDNJq46XUev5U3it1vycHOVQRCoWoqKgYyW1ERERERESkgIRCIYDyXNcxVRRgjFxtat05yPH0/ropvtewQqGQBsGQiVKWWodzWoUUE/1OyUTS75NMNP1OyUTT75RMtJL6trqgAwxjzHbgoFFccpO19sJJKidtIkdFHdG9rLXHDLQ/3TJjsOMio6XfKZlo+p2SiaTfJ5lo+p2SiabfKZloQ7TGL0oFHWDgzOAxmvTyzXE8V7pVRO0gx4drVTFZ9xIREREREREpegUdYFhrV03hc/UYY3YA+xtjZg4wdsW81HrLVN5LREREREREpBRoFpLReSC1PmuAY2/td85U3ktERERERESkqCnAGJ2fpdZfMMZMS+80xswGLgMiwPW9LzDGzDTGLDDG9O8uMup7iYiIiIiIiJSqgu5CMl7GmP8GFqQ2j0ytLzXGnJJ6/Ki19rr0+dbax4wxVwOfAZ41xvwB8AHvAeqBf7fWbu/3NN8ELgYuBW4Y571ERERERERESpKxdiInzSgsxpjVwIohTrnRWnvJANddDHwSOAxIAk8B37XW/nmAc28gFWBYa28Yz71ERERERERESlVJBxgiIiIiIiIiUhg0BoaIiIiIiIiI5D0FGCIiIiIiIiKS9xRgiIiIiIiIiEjeU4AhIiIiIiIiInlPAYaIiIiIiIiI5D0FGCIiIiIiIiKS9xRglBjjuNgYs9oY02aMCRljthljbjXGzM91fVLYjDG/NMbY1HJIruuRwmKMmWeM+Zwx5gFjzOvGmKgxZrcx5i5jzGm5rk/ylzHmAGPMr4wxbxpjIsaY7caYHxhjpuW6NiksxpgGY8xHjDF3GGNeTr1P6jTGPGqM+bAxRu+dZUIYYy7q9Z7pI7muRwqTMWaZMeaPxpidqde/ncaYe40xb8t1bZPFk+sCZOoYY8qA24B3AC8CNwPdwH7AMmA+sCVnBUpBM8acDXwICABVOS5HCtPXgPcAzwN/BdqAQ4FzgHOMMZ+y1v4wh/VJHjLGzAUeA5qAu4AXgOOBTwFnGWNOtta25rBEKSwXAD8FdgIPAq8BzcB5wHXAW40xF1hrbe5KlEJnjJkFXIveM8k4GGOuxHnvtBf4M87frUbgKOBUnPdSRcfo72/pMMb8GPg34JvAldbaZL/jXmttLCfFSUEzxkwHNgKrgRnACmCetfblXNYlhcUYcwnwjLX26X77VwD3ARaYba3dmYPyJE8ZY+4BzgQut9Ze22v/1cAVwM+ttR/PVX1SWIwxK4FK4C+93ycZY2YA/wRmAedba/+YoxKlwBljDM5r2sHA7cB/Ah+11l6X08KkoBhjLgBuBf4BnGet7e53vGg/16kZXIlIfUP1ceAJ4Av9wwuAYv0llynxf6n1ZTmtQgqatfaG/uFFav9DOOGYDzhpquuS/GWMmYMTXmwHftzv8JeBHuAiY0zlFJcmBcpa+4C19u7+75OstbuAn6U2T53ywqSYXA6sBC7F+RslMiqprmzfBoLA+/uHF1Dcn+vUhaR0vA8nsLoRqEk1958FtAIP6JtyGavUt+bnAu+y1rY6XyyITLj0C3E8p1VIvlmZWt87wAfObmPMGpyA40Tg/qkuToqO/g7JuBhjFgLfAq6x1j6cavEjMlon4bTg+QPQbox5O3A4EAb+aa1dm8viJpsCjNJxXGpdC2wFGnods8aYn+I0v01MeWVSsIwxBwHXAL+11t6Z43KkSKV+z1bhfNPwcI7LkfxyaGo92PhNL+EEGPNRgCHjYIzxAB9Mbf49l7VIYUr9Dv0GZ1yVz+e4HCls6c91u4GngMW9DxpjHsbp6rZnqgubCupCUjqaUuuvAutxftGrcT4UbMUZG+OLuSlNClGq+dqNOANQXZ7jcqRIGWP8wE2AH7jKWtue45Ikv9Sm1p2DHE/vr5v8UqTIfQvnG86/WmvvyXUxUpC+hDO44iXW2lCui5GClv5c93GgHDgd53Pd4cA9wHKciRuKkgKMApKaFs6OYvltr8vdqfVOnKb+m6y1AWvtA8D5QBL4jDHGN9U/l+TOOH+nrsAZrPOj+lApaeP8nep/LzfOt1UnA78H/neqfg4pGuk+bRqxXMbMGHM58B84M9xclONypAAZY47HaXXxvWJv3i9TIv25zuC0tLg/9bnuOeBdwBvACmPM0pxVOInUhaSwbMXp2zRSb/Z6nP6A+ff+qa+19hljzDZgLrAQeGZcVUohGdPvlDFmHvAN4HprbVFO0SRjNp6/Uxmp8OK3OFMa3gpcqGkLZQDpFha1gxyv6XeeyKgYYy7D6Sr5PLDKWtuW45KkwPTqOrIFtXaWiZH+XPeKtbbP5zZrbSg1O9eHcaYUL7rATAFGAbHWrhrH5S/i9APuGOR4+n+E8nE8hxSYcfxOLcJp0n+pMebSQc55KTWg57s0PkbpGOffKSDzZu9mnPDiZuCDGp9HBvFiaj1/kOPzUuvBxsgQGZQx5tPA94FNOOFFS24rkgJVRfZvVHiQwc5/YYz5Bc7gnp+eqsKkYKVf+zoGOV7Un+sUYJSO+4F/x+kb1Ueqj3n6Td72KaxJCtd24JeDHHs7MAOn710X+p2SUUh1Y7sVeCfwa+DSgaZ9Fkl5MLU+0xjj6v27Yoypxul+FALW5aI4KVzGmM/hjHuxATjDWrs3txVJAYsw+Humo3HGxXgU50Np0X1bLpPiYZzZkOYZY3zW2mi/4+nPe9untKopYtQitzSkPhRsxply5y3W2vt6Hfs68AXgIWvtqbmpUIqFMWY1ztgY8zQ9r4xGKky9HXgbzpu9f1V4IcNJNZU9E2cmrWt77b8aZ6yen1trP56r+qTwGGO+iDPo+ZPAmeo2IpPFGHMV8GWc8cSuy3E5UkBSY4h9APiGtfbKXvvPwBnIswuYba3tyE2Fk0ctMEqEtTZqjLkYuBf4mzHmDuBVnGl4lgN7gH/NYYkiIj/DCS/2AjuALw3Q1Ha1tXb1FNcl+e3fgMeAHxpjVuGE9ScAp+F0HflCDmuTApN6r/RVIAE8Alw+wN+h7dbaG6a4NBGR3j6D81r3BWPMcuCfwEE4g3gmcEKxjtyVN3kUYJQQa+2jxphjcZLe03CmldsN/B/wNWvtGzksT0Tk4NS6EWe6ucGsnvxSpFBYa7emXtu+CpyFE4LtBH4IfEXfnssopf8OuYFPD3LOQ8ANU1GMiMhArLUtxpgTgCtxQosTgW7gL8A3rbVF23VSXUhEREREREREJO+5cl2AiIiIiIiIiMhwFGCIiIiIiIiISN5TgCEiIiIiIiIieU8BhoiIiIiIiIjkPQUYIiIiIiIiIpL3FGCIiIiIiIiISN5TgCEiIiIiIiIieU8BhoiIiIiIiIjkPQUYIiIiIiIiIpL3FGCIiIiIiIiISN5TgCEiIiIiIiIieU8BhoiIiIiIiIjkPQUYIiIiIiIiIpL3FGCIiIhIwTLGNBtjEsaYH+a6FhEREZlcCjBERESkkL0T5/3MHbkuRERERCaXsdbmugYRERGRMTHG/A04Dmi21iZyXY+IiIhMHrXAEBERkbxhjFljjLFDLA/1OrcWWAnc3T+8MMZUGWO+ZIx52hjTPcT9mqb6ZxQREZGx8eS6ABEREZFe7gDuG2D/pcCBwIO99r0d8AG39z4xFUo8BCwAngV+BviBC4AZQAx4DdhrrW2Z4PpFRERkkqgLiYiIiOQ1Y8x3gf8EbgA+bK1NpvbfBrwVaLTWhnud/w9gFfAd4L9t6s2OMWYW8BLgBmZaa/dO5c8hIiIi46MuJCIiIpKXjOMnOOHFj4EP9QovyoCzgL/1Cy/OwAkv1gD/Y3t9U2OtfR14BKcF6pFT9XOIiIjIxFAXEhEREck7xhg38Cvgg8B3rLWf63fKmUAV+84+cmFq/f102NFPZ2qtL3FEREQKjF68RUREJK8YY7zA73DCi6sGCC8A3gVEgb/0278MSAJ/H+T2B6TWL09AqSIiIjKFFGCIiIhI3kh1DbkDOB/4T2vtVwY4xw2cDTxgre3std8FHAS0WGt7BriuGWfK1W3W2ldS+/5rkNlJvjopP6CIiIiMmQIMERERyQvGmEqcFhVvA/7NWvu9QU5dDjSwb/eR9HgX1akwo7//wnnv8/Ne+34KzOy1fA/YBfx6LD+DiIiITB4FGCIiIpJzxpha4F5gBXCJtfanQ5x+Hk43kbt670wN2PkMUAm8r9/9zwc+DbwAXNPrmm5r7S5r7S7g4tR1p1pr1cVEREQkz2gaVREREck5Y0y65cU/gb8Ncto3rbURY8zrwHZr7bIB7nMucDsQB34PvI7TbeR0nClU32Kt3TbAdf8DfBI4zVq7Zfw/kYiIiEw0BRgiIiKSU6nuHp04s4oMpsVa22yMOQ4n5PgPa+3Vg9zvncDngCMAA2wBbgV+aK0NDHD+F4CP44QXankhIiKSpxRgiIiISMEwxvw/4H+AOQO1pBjD/b4IfBQnvNg63vuJiIjI5FGAISIiIgXDGLMZiFhrj5yAe30BuAI4B3il16EOa214vPcXERGRiaUAQ0REREqOMcYAHUDNAIdPt9beP7UViYiIyHAUYIiIiIiIiIhI3tM0qiIiIiIiIiKS9xRgiIiIiIiIiEjeU4AhIiIiIiIiInlPAYaIiIiIiIiI5D0FGCIiIiIiIiKS9xRgiIiIiIiIiEjeU4AhIiIiIiIiInlPAYaIiIiIiIiI5D0FGCIiIiIiIiKS9xRgiIiIiIiIiEjeU4AhIiIiIiIiInlPAYaIiIiIiIiI5D0FGCIiIiIiIiKS9xRgiIiIiIiIiEjeU4AhIiIiIiIiInlPAYaIiIiIiIiI5L3/D5EcguX2MnNMAAAAAElFTkSuQmCC\n", + "text/plain": [ + "
" + ] + }, + "metadata": { + "image/png": { + "height": 321, + "width": 536 + }, + "needs_background": "light" + }, + "output_type": "display_data" + } + ], + "source": [ + "# Ez \n", + "\n", + "fig, ax = plt.subplots(figsize=(8,5))\n", + "COLOR = {1:'black', 0.1:'blue', 0.01: 'purple', 10:'red'}\n", + "for ratio in [.01, .1, 1, 10]: \n", + " sigz = .001*ratio\n", + " dat = ALLDAT[ratio]['z_line']\n", + " z0 = dat['z']\n", + " Ez0 = dat['Ez']\n", + " ax.plot(z0/sigz, Ez0/1e6, color=COLOR[ratio], label=f'{ratio}')\n", + " \n", + " \n", + "# Charge density \n", + "ax2 = ax.twinx() \n", + "ax2.fill_between(z0/sigz, 0, gauss(z0/sigz), color='gray', alpha=0.2) \n", + "\n", + "ax.set_xlim(-6, 6)\n", + "ax.set_ylim(-10,10) \n", + "ax.set_xlabel(r'$z/\\sigma_z$')\n", + "ax.set_ylabel(r'$E_z$'+' (MV/m)') \n", + "ax.legend(title='r')" + ] + }, + { + "cell_type": "markdown", + "id": "systematic-emperor", + "metadata": {}, + "source": [ + "# Cathode images\n", + "\n", + "Test the three methods" + ] + }, + { + "cell_type": "code", + "execution_count": 13, + "id": "allied-afghanistan", + "metadata": {}, + "outputs": [], + "source": [ + "def set_params(filename='params.in', sigma_z=1e-3, sigma_x=1e-3, imethod=3):\n", + " params = f\"\"\"\n", + " &OPENSC_TEST_PARAMS\n", + " NXLO=1 ,\n", + " NXHI=64 ,\n", + " NYLO=1 ,\n", + " NYHI=64 ,\n", + " NZLO=1 ,\n", + " NZHI=64 ,\n", + " N_PARTICLE=10000000 ,\n", + " E_TOT= 0.51099891e6 ,\n", + " BUNCH_CHARGE= 1e-9,\n", + " DISTTYPE = 0, \n", + " SIGMA_X= {sigma_x},\n", + " SIGMA_Y= 1.0000000000000000E-003,\n", + " SIGMA_Z= {sigma_z},\n", + " GAUSSIANCUTOFF= 6 ,\n", + " DIRECT_FIELD_CALC=T,\n", + " INTEGRATED_GREEN_FUNCTION=T,\n", + " CATHODE_IMAGES=T,\n", + " IMAGE_METHOD={imethod} ,\n", + " RECTPIPE=F,\n", + " READ_RECTPIPE=F,\n", + " WRITE_RECTPIPE=F,\n", + " APIPE= 1.2000000000000000E-002,\n", + " BPIPE= 1.2000000000000000E-002,\n", + " /\n", + " \n", + " \"\"\"\n", + " with open(filename, 'w') as f:\n", + " f.write(params)\n", + "set_params() " + ] + }, + { + "cell_type": "code", + "execution_count": 14, + "id": "statistical-allocation", + "metadata": {}, + "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + "CPU times: user 11.9 ms, sys: 16.3 ms, total: 28.2 ms\n", + "Wall time: 37.8 s\n" + ] + } + ], + "source": [ + "%%time\n", + "IDAT = {}\n", + "\n", + "method = {1:'convolution/correlation', 2:'shifted Green function', 3:\"Chris' shifted Green function\"}\n", + "\n", + "for imethod in method:\n", + " IDAT[imethod] = run_test(verbose=False, imethod=imethod)" + ] + }, + { + "cell_type": "code", + "execution_count": 15, + "id": "banned-jacket", + "metadata": {}, + "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + "14.140 s for convolution/correlation \n", + "14.210 s for shifted Green function \n", + "9.461 s for Chris' shifted Green function \n" + ] + } + ], + "source": [ + "# Print the times\n", + "for i, name in method.items():\n", + " print(f'{IDAT[i][\"run_time\"]:0.3f} s for {name} ')" + ] + }, + { + "cell_type": "code", + "execution_count": 16, + "id": "growing-bullet", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "" + ] + }, + "execution_count": 16, + "metadata": {}, + "output_type": "execute_result" + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAABAMAAAJ8CAYAAACLGmgAAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAADAnElEQVR4nOzdeXxU1f3/8deZLCSEPcCwSkwwIqayahSQICiK1hUardaC1FRrKa3fVkFLJdQNbN2QujQtoHVBREQFUZFCxKBBQPSHSMMWlG3YlSUxmcz5/XGTIUMmIXtC8n4+HvOY5J5z7z0zE0Lu557z+RhrLSIiIiIiIiLSeLjqegAiIiIiIiIiUrsUDBARERERERFpZBQMEBEREREREWlkFAwQERERERERaWQUDBARERERERFpZBQMEBEREREREWlkFAwQERERERERaWQUDBARERERERFpZBQMEBEREREREWlkFAwQERERERERaWQUDBARERERERFpZBQMEBEREREREWlkQut6AFJzjDHbgBZAdh0PRURERERERKpfDPCDtfbMiu6oYEDD1iIyMrLNOeec06auByIiIiIiIiLV65tvviEnJ6dS+yoY0LBln3POOW3WrFlT1+MQERERERGRatavXz/Wrl2bXZl9lTNAREREREREpJFRMEBERERERESkkVEwQERERERERKSRUTBAREREREREpJFRMEBERERERESkkVEwQERERERERKSRUTBAREREREREpJEJresBSP3g8/k4ePAgR44c4ccff8RaW9dDEhFpdIwxNGnShObNm9OmTRtcLsXsRUREpGYoGCD4fD6+++47jh8/XtdDERFp1Ky15Obmkpuby7Fjx+jatasCAiIiIlIjFAwQDh48yPHjxwkNDaVDhw5ERUXpj08RkTrg8/k4duwYe/bs4fjx4xw8eJC2bdvW9bBERESkAdIVn3DkyBEAOnToQPPmzRUIEBGpIy6Xi+bNm9OhQwfgxO9nERERkeqmqz7hxx9/BCAqKqqORyIiInDi93HR72cRERGR6qZggPiTBWpGgIhI/WCMAVAyVxEREakxuvoTERGpZ4qCASIiIiI1RcEAERERERERkUZGwQARERERERGRRkbBAJFGyhjDkCFDavw8MTExxMTE1Ph5Gqvs7GyMMYwZM6ZGzzN79myMMcyePbtGzyMiIiJSZzYuAp8PgCzPEWZlbOOZpZuYlbGNLE9hhR+fz+nXACgYICJVMmTIkHq/vvmNN97AGMP8+fPreij11vLlyzHGkJqaWtdDEREREal9yx6FOTfjeSWFG5/PYPiTHzPl3Q08viSLKe9uYPiTH3Pj8xl4XkmBOTc7/U9zoXU9ABFp2JYuXVrXQ+Ctt94iMjKSyy+/vK6Hctq6/vrrufDCC+nYsWNdD0VERESkem1cBOlTAXBvmcdI7z5WkYItdu/c4GPkjmm4Q9OdDelToeN50OOquhhxtVAwQGpVlucIGZv3czTXS7OIUAZ2b0u8u3ldD0tqUFxcXJ2ePy8vj0WLFjF8+HB/7XapuJYtW9KyZcu6HoaIiIhI9YsfgSduFO4t8wBIDk0n3/hIjUzEhB3C5rcmNSeT5JAV/l08caNwx4+oqxFXCy0TkFqRsXk/yS98GnS6TfILn5KxeX9dD9Fv1apV3HjjjXTu3JkmTZrQsWNHhg8fzty5cwP6zZ07l8GDB9OyZUsiIyP5yU9+wqOPPsqPP/5Y4phF6+aPHz/OPffcwxlnnEGTJk3o3r0706ZNC6gl/umnn2KM4YYbbih1jOeccw5NmjTh4MGD/m0+n4/nn3+e888/n2bNmhEVFcX555/Pc889h69w7dOpjBkzBmMM2dnZJdpOnkZetFY9Pd2Jjhpj/I/iuQhKyxnw448/MnXqVM477zyaNm1KixYtuPjii0u8z8XPNWbMGLKzs7npppto27YtERER9O/fn4ULF5b6mpYuXcoPP/zA9ddfH7D9+PHjTJs2jf79+9O8eXOaNWvGOeecw/jx4/F4PAF9d+/ezW9/+1tiYmIIDw+nXbt23HDDDaxZs6bE+YqvrX///fcZMmQILVu29C+lOFU7gNfr5dlnn+XCCy+kRYsWNG3alD59+jBjxoxyf5ZZWVlMnDiR/v37065dO5o0aUK3bt349a9/zY4dOwL6jhkzhksuuQSAKVOmBHyWy5cvLzHuk61Zs4aRI0fSvn17/3nuuusudu/eXaJv8Z+xF154gZ/85CdERETgdrv59a9/zffff1+u1yciIiJSbVwuxh8by1xvEgDrw8NJi9lKROe5NGm/hIjOc0mL2cr68HAA5nqT+P2xseA6vS+nNTNAatzrn3/LffP/Hz4bvH3VtoPc+u9Mpt5wHsnnd63dwZ0kLS2N3/zmN4SEhHDNNddw1llnsXfvXlavXs2zzz5LcnIyAPfffz+PPvoobdu25eabb6ZZs2YsXryY+++/nw8++IAlS5YQFhYWcOz8/HyGDx/Orl27GDFiBKGhoSxYsICJEyeSm5vL5MmTAbjooos4++yzWbhwIQcOHCA6OjrgOKtWrWLjxo2MHDmSNm3a+LffeuutvPrqq3Tt2pXbb78dYwxvvfUWd911F5988gmvvPJKtb5XrVq1YvLkycyePZvt27f7xw+cMmFgXl4el19+Oenp6fTo0YPf/va3HD9+nHnz5nHjjTeybt06HnnkkRL7bd++nQsuuIDY2FhuvfVWDh48yOuvv861117LRx995L+gLe6tt94iNDSUq6++2r/t0KFDXHLJJXz55ZecffbZjB07lvDwcLZs2cLMmTO54YYbcLvdAGzbto1Bgwaxa9cuhg4dys9//nO+++473njjDRYtWsSbb77JT3/60xLnnTdvHu+//z4jRozgzjvvLBFgKa09Pz+fq6++mg8++ICzzz6bm2++mYiICJYtW8bvfvc7MjMz+c9//lPm+wswf/58nn/+eS655BIGDBhAeHg4X3/9Nf/617949913Wb16NZ07dwbguuuuA+DFF18kKSmpRDCnLAsXLmTkyJFYaxk1ahTdunVjzZo1PPfcc7z99ttkZGQEPca9997LBx98wNVXX83w4cNZtmwZaWlpbN68mf/+97+nfH0iIiIiZdq4COJHgMtV+uxknw+yFpPVejCZ2YdZRQr5xkeaeysHQkMCDncgNIRx7nakZMcyyZuCzT5MlufI6T3L2VqrRwN9AGv69u1rT2XDhg12w4YNp+xXGZ9s2mfPnLjQdptw6seZExfaTzbtq5FxlMfXX39tQ0NDbevWre369etLtH/33XfWWmtXrlxpAdu1a1e7e/duf3t+fr796U9/agH78MMPB+zbrVs3C9gRI0bY48eP+7d7PB7bsmVL27JlS5uXl+ff/sgjj1jAPvPMMyXGcdddd1nAvvPOO/5tr776qgVsnz597JEjR/zbjx49avv162cB+8orrwQcB7BJSUkB20aPHm0Bu23bthLnXbZsmQXs5MmTA7YnJSVZ51dJcN26dbPdunUL2Fb0+kaMGGHz8/P92z0ej/+9ysjI8G/ftm2bBSxgU1NTA471/vvv+491soKCAut2u+2wYcMCtv/85z+3gL3zzjttQUFBQNsPP/xgDx8+7P9++PDhFrAPPfRQQL+MjAwbEhJi27RpE/Cez5o1ywLWGGMXL15cYkynap88ebIF7Lhx46zX6/Vv93q9duzYsRawCxYsKPHejB49OuA4O3bssLm5uSWO/8EHH1iXy2XvvPPOgO2lfb4nj3vWrFn+bUeOHLHR0dHW5XLZjz/+OKD/1KlTLWAvu+yygO1FP2Ndu3a127dv92/Pz8+3F198sQVsZmZm0DE0NjX5u1lERKRB++8j1k5uYfe8NNYmP/dJ0GuP5Oc+sXteGmvt5BZ27Yv3+Ld3f/ivNmF2QqmP7g//1d935idb6/qV2r59+1pgja3E9eLpPa9B6r2nl24qdUbAyXwWpi/dVLMDKsNzzz2H1+vlL3/5C+eee26J9i5dugAwc+ZMACZNmkSHDh387aGhoTz++OO4XC7+9a9/BT3H9OnTiYyM9H/fvn17rr32Wr7//nv+97//+bffeuutuFwuXnzxxYD98/LymDNnDu3bt2fEiBNrlIrGNHXqVJo1a+bfHhUVxbRp0wBKHVNdmDlzJsYYnnjiCUJDT0xQat++PX/5y1+A4OPt1q0bkyZNCth2+eWXc8YZZ7Bq1aoS/VeuXInH4wlYIrB3715ef/11OnbsyN///ndcJ03vat68uX9t/I4dO/jwww8544wzuPfeewP6DRgwgJ///OccPHgwaJWCa6+9liuuuKLU9yBYu8/nY8aMGXTo0IEnn3ySkJATEemQkBAef/xxjDHlmuVRtMzlZMOHD+fcc8/lgw8+OOUxTuXtt9/mwIED3HjjjVx88cUBbX/84x+JiYlhyZIlfPvttyX2feCBBzjjjDP834eGhnLbbbcBBP0sRURERMrl5GSAO6ZhCFxm6U8GWJgjoM/WF7jMtdppCztU5uGLtx/N9VbnyGudlglIjcnyHGHVtoOn7lhM5raDdTbd5rPPPgMIuMgOZu3atQAMHTq0RFt8fDxdunRh27ZtHD58mFatWvnbWrZsSffu3Uvs07WrszTi0KETv1i6dOnCsGHDWLJkCRs2bKBnz54AvPvuuxw8eJC777474CJ67dq1uFyugOndRZKSkggJCeGLL74o83XVliNHjrB582Y6d+5Mjx49SrQXva/Bxtu7d++AC+QiXbt25dNPPy2xff78+Rhj/NPgAT7//HN8Ph+DBw8+ZULBojFcfPHFJZZ9FI315Zdf5osvvuCXv/xlQNsFF1xQ5rGDtWdlZXHgwAHOOussHnrooaD7RUZG8s0335R5bHBmfb3yyivMnj2bL7/8kkOHDlFQUOBvDy9c81YVZf1bCA0NZfDgwWRnZ/PFF18EXPgD9O/fv8Q+wf4tiIiIiFRIJZIBrmlzFR/t6guAzW9d5uGLtzeLOL0vp0/v0Uu9VtmkgBmb99dJMODw4cMA/nXUpSlKcFZaibWOHTvy7bff8v333wcEA4p/XVzRRX3xCzVwEq0tWbKEF1980X93v2imwOjRo0uMqU2bNkEv8EJDQ2nbti179+4t83XVlvK8f3Di8yiurPcwWGK9BQsWcMEFFwR8puX9nKs61uKzRoIJ1n7gwAEANm3axJQpU0rd9+jRo2UeG+D//u//eOqpp+jYsSOXX345nTt39s9KKcrzUFXV/VmW9m9BREREpNwKkwGO9O4jOTTdSQbo3kpE6Im/fdK8BfTyhJOQl8dcbxIvcweWoxh8pOZkkuYtKJEzACDaW0BKTiaT6I3FxcDubWvzlVU7BQOkxlR22kxdTbcpujjZuXNn0DvWRYqmkO/Zsydo2byiDOpVLcN2/fXX06JFC15++WUeeeQRDh48yOLFi+nVqxe9evUqMaaDBw+Sn59f4g621+tl//79tGjR4pTnLJoy7/WW/AyCXdBVRvH3L5jqev/WrVvHtm3buOOOOwK2F/+cT6UqYy1eHSCYYO1Fx7n++uuDLj0or7179zJ9+nQSEhJYuXIlzZsHBtdee+21Sh+7uNr6LEVERETKK8tzpOLJAHcd5bxOzfnF3r+THLKCXp5wxrnbBewX7S1ghmcfCSE7CbMu5neZcHonD0SlBaUGVXbaTF1Nt7nwwgsBWLx4cZn9+vTpA+AvuVbc5s2b2bFjB2eeeWapd7HLKzIykuTkZHbt2sVHH33EK6+8gtfrLTEroGhMPp+Pjz/+uETbxx9/TEFBAX379j3lOVu3dqY9fffddyXaVq9eHXSfomn75b2b27x5c+Li4ti5cyebNpXMEbFs2TKAco23LG+99RZAiZKCF1xwAS6Xi48//phjx46VeYyiz/qTTz4JGiCprrEW6dGjB61ateKzzz4jPz+/0sfZunUrPp+P4cOHlwgE7Nixg61bt5bYp6KfI5T9b8Hr9fLJJ58A1ff+iIiISCO1cZGT+R/nYn9WxjaeWbqJWRnbyPIccfr4fLBxkX92ssVFamRi0Dv84AQEUiMTsbgw+JjMcySHOiWzE/LySMmOJXdnMj/uvYzcncmkZMeSkJcHOEsPno6a6R/T6UrBAKkxlZ02U1fTbX7zm98QGhrKgw8+yIYNG0q0F9VmHzt2LAAPPfQQ+/bt87cXFBTwpz/9CZ/Px69+9atqGdOYMWMAeOmll3jppZcIDQ3llltuKdGvaEz33Xcfx48f928/fvw4EydOBCjXmIrWsaelpQVs/3//7//x9NNPB92nqPRhsCRxpRk7dizWWu65556Ai8/9+/fz4IMP+vtUxfz58+nZsyfx8fEB29u1a8dNN93E7t27/Z9XcUePHvVPf+/SpQuXXXYZ2dnZPPXUUwH9MjMzefXVV2ndunWJgENlhYaG8rvf/Y7du3czfvx4cnJySvTZvXt30J/P4opK+X3yyScB7+/Ro0dJSUkJGtiozOd43XXX0aZNG1577TV/zo0iTz31FFu3buXSSy8tkS9AREREpNyWPQpzbsbzSgo3Pp/B8Cc/Zsq7G3h8SRZT3t3A8Cc/5sbnM/C8kgJzbqbn//7h37W8yQAvda2l38H3/NvnepOYlH8H+T/0Je/AMPJ/6Muk/DuY603y93FvmQdZZd9ErO+0TKASjDHZQLdSmj3W2rIXCwceqwvwV+AKIBrYDSwAplhrT+ssWvHu5lxwZpsKJRFMPLNNnU236dmzJ88++yx33nknffr04dprr+Wss87iwIEDrF69mubNm7Ns2TIGDBjAvffey2OPPUZCQgKjRo0iKiqKxYsXs379egYNGsQ999xTLWMaOHAg3bt354033vDXn2/fvn2JfjfffDNvv/02c+fO5dxzz+W6667DGMOCBQvYtm0bycnJQYMIJyt6za+99ho7duwgMTGRb7/9lrfffptrr72WuXPnlthn2LBhvPHGG9xwww1ceeWVREZG0q1bN2699dZSz/OnP/2JxYsX8/bbb9OrVy+uvPJKjh8/zhtvvMHevXu59957GTRoUMXerGI2b97M+vXrS1QeKDJjxgzWr1/P888/z/Lly7n88ssJDw9n27ZtfPDBB7zzzjv+ZIzPP/88AwcO5J577uHDDz+kf//+fPfdd7zxxhu4XC5mzZpV4u57VfzlL3/hyy+/5Pnnn+fdd99l6NChdO7cmb1797Jp0yYyMjJ4+OGH/Uklg+nQoQM33XQTc+bMoXfv3gwfPpzvv/+eJUuWEBERQe/evVm3bl3APmeffTadO3dmzpw5hIeHc8YZZ2CM4dZbb6Vbt+C/7po1a8bMmTP52c9+RlJSEj/72c8444wzWLNmDR9++CEdOnTghRdeqLb3RkRERBqZkysDePexihSKF8XzVwYovKuf+G0al7mas8TXv9zJAJf4+vNF7B302foCnrhRzD82Fpt9OLAvztKApKh2TiAgaSL0uKoaX2ztUzCg8r4Hngqy/dSZvQoZY+KAlUB74G1gI3AB8HvgCmPMQGvtgaoPte78fthZ3PrvzHKVF3QZGD/srJofVBlSUlJISEjg73//O8uXL2fBggW0bduW8847j9tvv93fb9q0afTp04cZM2bw0ksvkZ+fT1xcHA899BB//OMfqyVTe5HRo0f7y+0FWyJQ5LXXXiMpKYmZM2f6L8DOOecc/vjHP/Kb3/ymXOeKiIhg6dKl/OlPf2LJkiV8/vnnJCQk8Oqrr9KmTZugwYDbb7+d7du3M2fOHB577DG8Xi9JSUllBgPCw8NZsmQJTzzxBK+++irPPPMMoaGh9OrVi6eeeoqf//zn5RpvaUpbIlCkdevWrFy5kqeeeorXX3+df/7zn4SEhNC1a1fGjh0bcKEdGxvL6tWreeihh3jvvfdYvnw5LVq04IorruDPf/4z559/fpXGerKwsDAWLFjAyy+/zOzZs1m4cCFHjx6lXbt2nHnmmTz44IPlCuz8+9//JjY2ltdff51//OMftGvXjmuuuYa//vWvjBw5skT/kJAQ3nrrLSZOnMjcuXM5cuQI1loGDRpUajAAnABSRkYGjzzyCB988AHff/89HTp04M477+Qvf/kLnTp1qtL7ISIiIo1YJSoDbO1yHR9t7lvhZIBRl/8FDiXhjh/BHJeLLM8RMjbv52iul2YRoQzs3ta5aem7CLJuOO0DAQDG2nIWgRe/wpkBWGtjqnicD4DhwHhr7TPFtj8B3A28YK29swrHX9O3b9++a9asKbNfUZmyc845p7KnKtPrn3/LffP/X5kBAZeBqTecR/L5XWtkDNK4DBgwgJ07d1ZLxnyRulLTv5tFREROBzc+n8HIHdP8lQFKTexXWBlgfpcJWKjwPnPuHFgHr67q+vXrx9q1a9daa/tVdF/NDKgjxphYnEBANvCPk5onA78GbjXG/NFaW3aWs3ruxvPPoEvrpkxfuonMIEsGEs9sw/hhZ532pTmkfti9ezefffYZ48ePr+uhiIiIiEgVVKYyANkHWdp9HrEnJQMsPpsgJSeThBCnslRyaDpJUe2cO/6uxpVST8GAymtijPkFcAZwDPgK+NhaW95U3EMLnz+01gZkMLPWHjHGZOAECy4EllbTmOvMwO5tGdi9benTbUSqSceOHUskBRQRERGRemLjIogfAWVOxfdB1mIyDjhLN4sqA0SEBp/16a8MkO/iMtdqYncs8LfN9SY55QPzT1zoT6I3Ydblrx7gJANsGFP/K0LBgMrrAPznpG3bjDG3WWvTy7H/2YXPWaW0b8IJBsRzimCAMaa0dQA9yjGOWhXvbq6LfxERERGRxmjZo5A+FU/cKMYfG0vmSUn6ABJjWjE9aibuLfPoeUYKcAlQ/soAS3z9yTwjhcRv0xpVMsDKUDCgcmYBK4CvgSNALDAOZ2r/YmPMRdbaL09xjJaFz9+X0l60vVXVhioiIiIiIlLHaqkyAMCGs39L4oBLGlUywMpQMKASrLVTTtq0HrjTGHMU+COQClS18LgpOl05xhM0WUThjIG+VRyHiIiIiIhI1dRiZYCB3duC+8QFfqmzk12uRhsIAAUDqtvzOMGAweXoW3Tnv2Up7S1O6iciIiIiInJ6crkYf2wsI737/Fn+09xbA/IApHkL6OUJP5Hl3/trLogprAwQsoJenjIqA4TsJMw60/+1LLl8FAyoXnsLn6PK0fd/hc/xpbSfVfhcWk4BERERERGR04IqA9Q/CgZUr4sKn7eWo++ywufhxhhX8YoCxpjmwEAgB/iseocoIiIiIiJSDVQZ4LSmYEAFGWPOBXZbaw+etL0bMKPw25eLbQ8D4oB8a+2Wou3W2i3GmA9xKgb8Fnim2OGm4MwueMFae6xGXoiIiIiIiEhlqTLAaU/BgIr7GTDRGLMM2IZTTSAOuAqIAN4D/l6sf2fgG2A7EHPSse4CVgLTjTHDCvsl4vwryQL+XGOvQkREREREpDJUGaBBUDCg4pYBZwN9cJYFRAGHgU+A/wD/sdaesgIA+GcH9Af+ClwBXAnsBqYDU06efSAiIiIiIlLnVBmgQVAwoIKstelAegX6Z3OiTGCw9u+A26o+MhERERERkVqgygANgoIBIiIiIiIiUm6qDNAw6F0VqYQhQ4ZgTKkTPoIyxjBkyJAS2/fs2cPo0aPp0qULISEhGGM4fPhw9Qy0nJYvX44xhtTU1Fo9b0Myffp0evbsSWRkJMYYnnrqqboeUqWMGTMGYwzZ2dl1PRQRERGpTRsXOZn/cS72Z2Vs45mlm5iVsY0szxGnj88HGxeRsXk/cKIyQLDp/lCsMgAuLnWtLVkZIP8O8n/oS96BYeT/0JdJ+Xcw15vk7+NUBlhcM69XNDNApK6NGTOGDz/8kJ///Od0794dYwwREREMGTKE9PR0ypmCos4sW7aM2bNn8+mnn7J7925+/PFH2rRpw7nnnstll13GL37xC7p06VLXw6xRc+bM4fe//z19+vThD3/4A02aNOHCCy+s62EFlZqaypQpU1i2bFnQ4JSIiIg0QqoM0CgpGCBSS7755huaNm0asC0vL48lS5Zw6aWX8sorr9TRyCrnhx9+YPTo0SxYsICwsDAGDx7MlVdeSVRUFPv27WPVqlXcd999TJ48mc8++4w+ffrU9ZBrzMKFC/3PnTp1quPRVM2jjz7KxIkT6dy5c10PRURERGqDKgM0WgoGSM3buAjiR5S91sfnc6YANeB/8D169Cixbc+ePfh8vtPuArKgoICRI0fy0UcfkZSUxH/+8x+6du1aot+GDRt44IEH+OGHH+pglLVn165dAKfd5xhMx44d6dixY10PQ0RERGqLKgM0WsoZIDVr2aMw52Z453f+NUgl+HxO+5ybnf516J133mHYsGF07NiRJk2a0KlTJ5KSknj22WeD9vd6vTzyyCOcddZZNGnShK5duzJhwgTy8vJK9D05Z0BMTAzdunUD4MUXX8QYgzHGv2Y7PT3dv1/R4+Rp3Tt27GDcuHHExsbSpEkToqOjueaaa/j888+Djtfj8fCrX/0Kt9tNZGQkvXv35sUXX6zw+/Tyyy/z0UcfcdZZZ7Fo0aKggQCAnj17Mm/ePAYOHBiwPSYmhpiYGH744Qf+7//+j5iYGMLCwgJyFmzcuJExY8bQtWtXmjRpgtvt5uabb+Z///tf0HMdP36cRx99lN69exMVFUWzZs246KKLeO2110r0LZ4jYd26dVx11VW0atWKpk2bkpSUxMqVK8v1PqSmpmKMYdmyZUDgZwWQnZ3t/0yDCZZ7orJjKygo4Pnnn2fgwIG0bNmSyMhIunfvzu23386mTZsA532fMmUKAJdcckmJ8ULZOQPmzp3L4MGD/cf/yU9+wqOPPsqPP/5Yom/RZ3z8+HHuuecezjjjDJo0aUL37t2ZNm1avV/+IiIi0mgUVgYoWqu/PjyctJitRHSeS5P2S4joPJe0mK2sDw8HnLX+93t/zQUxbZgWmsYtISuY4dlHtLcg4LBFlQFuCVnBtNA0LoxppcoA9YxmBkjNKTbliHUvO8/XPBM4Q6AoEFDUnj4VOp5XJ5HAf/7zn9xxxx106NCBq6++mrZt27J3716++uorZs2axV133VVin5tvvpkVK1YwYsQIWrRowXvvvcdjjz3G3r17mTVrVpnn+8Mf/kB2djZPP/00vXr14rrrrgOgd+/exMTEMHv2bLZv387kyZP9+8TExPi/Xrt2LcOHD+fgwYNcfvnl3HDDDezfv58FCxYwaNAg3nrrLa688kp//wMHDjBgwAC2bt3KoEGDGDRoELt37+bOO+9k+PDhFXqv/vWvfwFwzz33EBUVdcr+oaElf9Xk5eUxdOhQDh48yPDhw2nRogVnnnkmAO+//z433HAD+fn5XH311XTv3p0dO3Ywf/58Fi1axLJly+jbt6//WIcPH2bo0KF88cUX9O3bl7Fjx+Lz+fjggw+4+eab+frrr3nooYdKjGH16tU89thjXHTRRdx+++18++23vPnmmwwbNox169Zx9tlnl/m6ioIzwT6rqqrI2PLy8rjqqqv46KOP6Nq1KzfffDMtWrQgOzubt956i0GDBnHWWWfxhz/8gQULFpCens7o0aMDfp5O5f777+fRRx+lbdu23HzzzTRr1ozFixdz//3388EHH7BkyRLCwsIC9snPz2f48OHs2rWLESNGEBoayoIFC5g4cSK5ubnV+n6JiIhIMcVm5pY+Fd+ZmZvVerAqAzRW1lo9GugDWNO3b197Khs2bLAbNmw4Zb8KKyiw9q27rJ3c4sTjrbuc7eVpr2V9+/a14eHh1uPxlGjbt29fwPdJSUkWsH379rUHDhzwbz969KiNi4uzLpfL7t69O2AfwCYlJQVs27ZtmwXs6NGjS5yz6BzB5Ofn27i4ONukSRO7fPnygLadO3faTp062Q4dOtjc3Fz/9pSUFAvYP/zhDwH9P//8cxsaGmoBO3ny5KDnO/ncYWFhFrCbN28+Zf9gunXrZgE7bNgwe/To0YC2gwcP2latWtno6Gj79ddfB7StX7/eRkVF2T59+gRsHz16tAXstGnTArbn5OTYyy+/3Bpj7BdffOHfvmzZMgtYwM6aNStgn+eff94C9je/+U25X09pn1VZn29p+1VmbPfdd58F7NVXXx3wmVtrbW5urt27d6//+8mTJ1vALlu2LOiYit7Lbdu2+betXLnSArZr164BP9f5+fn2pz/9qQXsww8/HHCcos94xIgR9vjx4/7tHo/HtmzZ0rZs2dLm5eUFHYM4aux3s4iINGz/fcTayS3snpfG2uTnPrHdJiws8Uh+7hO756Wx1k5uYde+eI9/e/eH/2oTZieU+uj+8F9ttwkL7e33pQb8Df/6n6+2MRPeCThHzIR37Ot/vjrwb/1vFtb1u9Pg9O3b1wJrbCWuFxWWkZrjcjkzAXr/4sS2dS87MwEKvIEzAsDpd/LMgVoWGhpa4u4mQNu2bYP2nzZtGm3atPF/HxUVxS233ILP52P16tU1Ns5FixaxZcsWfve735GUlBTQ1qlTJ+6991727NnD0qVLAecO7SuvvELz5s1LlA/s378/t9xyS7nPffDgQfLz8wGCJplbvnw5qampAY8FCxYEPdbjjz9eYmbBSy+9xOHDh5kyZQo9e/YMaDv33HNJSUnhiy++YMOGDYAz4+Hll1+mf//+3HvvvQH9IyIi/FPSX3311RLnHzhwYIkp/GPHjiU0NJRVq1aV+T7UtPKOraCggGeffZbIyEief/55mjRpErBPkyZNaNeuXZXGMnPmTAAmTZpEhw4d/NtDQ0N5/PHHcblc/tkiJ5s+fTqRkZH+79u3b8+1117L999/X+qSDxEREamkk5MB7piGIXCprj8ZYGGOgD5bX+Ayl/N3a0UrAwBOZYAuEzj50rKoMoAnbpSzQZUB6h0tE5CaVRQQgBMX/uteDgwCQL0IBNxyyy388Y9/5Nxzz+XGG28kKSmJgQMHlnkh1b9//xLbitbPHzpU9i/Tqvj0008B2L59e4mLe8C/Rvybb77hyiuvZOPGjRw/fpyLL76Yli1blug/ZMiQcucOsLbstd7Lly/3r0svMnr0aP8yiCIRERGcd955JfYvem1ffvll0NeWlZUFOK+tZ8+efP755xQUFPjX2Z+sKHDxzTfflGgL9vmFhYXhdrtr9PMrj/KObePGjXz//fckJibWWALDtWvXAjB06NASbfHx8XTp0oVt27Zx+PBhWrVq5W9r2bIl3bt3L7FPbfwbERERaZQqkQxwTZur+GiXs/xSlQEaFwUDpOYFCwgUVw8CAQD/93//R9u2bXn22WeZPn06Tz31FMYYkpKS+Nvf/hb04qz4hU+RovXxBQUFJdqqy4EDBwB44403yux39OhRAL7//nsA3G530H7F7/aeSnR0NGFhYeTn57Nr1y5iY2MD2otmAwB89NFHXHbZZUGP0759+xLJ8+DEa0tLSytzHEWvraj/559/XmrixOL9iwv2+YHzGdbk51ce5R3b4cOHgeCzNKpL0c9PaVUGOnbsyLfffsv3338fMO6yXgPU7L8RERGRRqkwGeBI7z6SQ9OdZIDurUSEbvd3SfMW0MsTTkJeHnO9SbzMHViOqjJAI6RlAlI7XC64+ungbVc/XeeBgCK//OUv+eyzzzhw4ACLFi3iV7/6FR9//DGXX345e/furevh+RXd3X/77bfLXAdUlKCtqL/H4wl6vD179pT73KGhoSQmJgL4lyFURrBAAJwY65dfflnmaxs9enRA/7vvvrvM/kUZ/2uTq/Dn2uv1Bm0vupCviqIL7p07d1b5WKUpeo9L+znZvXt3QD8RERGpG1meI2RmH2aCN4VXCi5mnLtdqckAXym4mAneFL7adZTzOjVXZYBGqH5cgUnD5/PBu78P3vbu70svO1hHWrVqxZVXXklaWhpjxozh4MGDrFix4tQ7VqOQEOcXd7C7pxdeeCFAucfUo0cPmjZtyrp16/x3eYtbvnx5hcZ2++23A86a/+PHj1do31Op6Gu74IILcLlctf75lEfr1s5Uuu+++65E2w8//OBf8lAVPXr0oFWrVnz11Vfs2rXrlP3L+rkqTZ8+fYDgPyebN29mx44dnHnmmaXOBBAREZEq2LjI/7dylucIszK28czSTczK2EaW54jTx+eDjYvI2LwfcNbrp0YmBr3DD05AIDUyEYsLg4/JPEfySZUBcncm8+Pey8jdmUxKdiwJhaWzk0PTeTpqZr37+10qTsEAqXknlw88WVFSwTr+hfL+++8HvYNbNCOgadOmtTqe6OhoAL799tsSbddeey1xcXH84x//4L333gu6/6effuq/UA8LC+OWW27hyJEjJdbVr169mldeeaVCY/vFL37BsGHD+N///sfVV1/Njh07gvarzJ3v2267jVatWjFlypSgSfx8Pl/ARWn79u255ZZbWL16NQ8++GDQz3DLli1s27atwmOpqubNm9OjRw8yMjL8CQ/BuRD/v//7P3Jycqp8jpCQEO666y5ycnK48847+fHHHwPa8/Ly2Ldvn//7sn6uSjN27FgAHnrooYBjFRQU8Kc//Qmfz8evfvWrqrwMERERCWbZozDnZjyvpHDj8xkMf/Jjpry7gceXZDHl3Q0Mf/Jjbnw+A88rKTDnZnr+7x/+XcubDPBS11r6HTzx9+RcbxKT8u8g/4e+5B0YRv4PfZmUfwdzvSeSVru3zIOsxdX8YqW2KWeA1KxggYDev3CWBrz7+8CkglCnuQNuuukmIiIiGDRoEDExMVhrWbFiBZ9//jn9+vXj0ksvrdXxDBs2jDfeeIMbbriBK6+8ksjISLp168att95KWFgY8+fP5/LLL+eqq65iwIAB9O7dm6ZNm/Ldd9/x+eefs3XrVnbv3u0PYjzyyCMsXbqUp556itWrVzNo0CB2797N66+/zpVXXsk777xT7rGFhIQwf/58fvnLX/L2228TGxtLUlISCQkJNG3alH379vH111+zcuVKwsPD/csKyiM6Opp58+Zx/fXXc+GFFzJs2DDOPfdcXC4X3377LZ9++ikHDhwgNzfXv8+MGTPYtGkTDzzwAP/5z38YNGgQbrebXbt28c033/D555/z2muvceaZZ5b/A6gm99xzD7/61a8YOHAgP/vZz4iIiGDZsmXk5+fTq1cvvvzyyyqfY/LkyWRmZvLuu+8SHx/PT3/6U5o3b853333Hhx9+yN/+9jd/ZYJLLrkEl8vFfffdx/r16/2zFyZNmlTq8QcMGMC9997LY489RkJCAqNGjSIqKorFixezfv16Bg0axD333FPl1yEiIiLFnFwZwLuPVaQEZO33VwYovKuf+G0al7mas8TXv9zJAJf4+vNF7B302fqCUxng2Fhs9uHAvoWVAZKi2jmBAFUGaBAUDJCaU1ogoOiCP1iVAaizgMDUqVP54IMPWLt2Le+99x4RERF069aNadOm8Zvf/CZoycGadPvtt7N9+3bmzJnDY489htfrJSkpiVtvvRWA8847jy+//JInnniChQsXMmvWLFwuFx07dqRPnz5MmTIloCRi27ZtycjI4P777+fdd99l9erVnH322Tz33HPExMRUKBgA0KJFCxYsWMDSpUt58cUXWblyJStXriQ/P5/WrVtz7rnn8vDDD/PLX/6SLl26VOjYw4YN46uvvuLvf/87H3zwAStWrCA8PJxOnToxdOhQRo4cWWIs6enp/POf/+TVV1/lzTffJDc3F7fbzVlnncWTTz5ZaiLDmjZ27FistTzxxBO8+OKLtG7dmmuvvZZHHnmkxOuorPDwcN5//32ef/55XnrpJV588UWstXTq1Inrr7+eQYMG+fuec845vPjii/z973/n2Wef9QdVygoGgFNGs0+fPsyYMYOXXnqJ/Px84uLieOihh/jjH/9IeHh4tbwWERERKVSJygBbu1zHR5v7VjgZYNTlf4FDSaoM0MiYU5UJk9OXMWZN3759+65Zs6bMfkUl184555zqHcDGRTDn5hPfB6saECxgcNOr+gUjIo1ejf1uFhGR08aNz2cwcsc0f2WAkxMCFiX2K6oMML/LBCxUeJ85dw6sg1cn1aFfv36sXbt2rbW2X0X31cwAqTk9rnKmEKVPLb184MkzBDTlSEREREQaoo2LIH4ElHnn3eesxe9xlb8ywCpSyDc+0txbS60MkJIdyyRvCmQfZGn3ecSelAyw+GyClJxMEkKcKkTJoekkRbVz7vjXk+peUnsUDJCadcl90PE8/y++oIoCAj2uVCBARERERBqeZY9C+lQ8caMYf2wsmSetyQdIjGnF9KiZ/jX5GeE3AScqA0SEbg96aH9lgHwXl7lWE7tjgb9trjeJSd4UbP6Jv8Mn0Zsw6/JXD3CSAWrqf2Ok8I/UvB5XnTrS6HLpF5CIiIiINDwnJwLcMQ1DYBUtfyLAwvwApE+l3c6PTrSXszLAEl9/Ms9IAXCSAXaZEJBwEE4kA/TEjXI2aGZuo6WZASIiIiIiIjWlEokAPXGj2NdpKKzdCFDuygAAG87+LYkDLlEyQDklBQNERERERERqisvF+GNjGend50/ql+beGjDtP81bQC9P+ImkfsfG8tez2gMbK1wZYGD3tuA+cYEf727uXPwHGZcCAY2bggEiIiIiIiI1pDKJAG1hToHEmFZOZYCQFfTylFEZIGQnYdaZ/h/0wl8kCAUDREREREREakjG5v1AxRIBAmRs2uskFFRlAKkhCgaIiIiIiIhURAXKBB7NjffvVt5EgADtdv33REJBVBlAqp+CASIiIiIiIuVVwTKBg2Lv4HGSgIolAtzX+VJoN9F/rvnHxvqXD/j7F1YGSIpq5y9JqECAlJeCASIiIiIiIuVxcplA7z5WkRJQvs9fJrDwbn2frS9wmSuKj3x9K5EI8D7oeJ4qA0iNUDBARERERESkPCpZJvDI0aFM2/m3yiUC7KHKAFIzFAwQEREREREpj0qUCXzr6BiebjZbiQCl3lEwQEREREREpBwqUybw0u/+iztciQCl/lGoSaSKsrOzMcYwZsyYaj2uMYYhQ4ZU6zGrQ0XHtXz5cowxpKamlmhbvXo1l112GW3btsUYQ+/evattnOWVmpqKMYbly5fX+rkbgh9++IHx48cTExNDaGgoxhjWrVtX18OqlJiYGGJiYup6GCIiUts2LnIy/+Nc7M/K2MYzSzcxK2MbWZ4jTh+fDzYuKlEmMNjafyhWJhAXS3z9+SL2DsBZMjC/y4SAHANFx5vfZQKeuFHOBiUClFqgmQEiQWzcuJF//OMfLFu2jO+++46cnBzatm1Lnz59uOGGG7jllluIiIio62GWKjs7mzPPPJPJkycHvQivD3744QeuuuoqcnNzufXWW2nbti0dOnQAnIBDUlJSvb5Az8/P57XXXmP+/PmsWbOG/fv3Y4zB7XbTu3dvrrrqKn7+858TFRVV10OtUffeey8vvPACP/3pT7n11lsJCQnxf471zZAhQ0hPT8daW9dDERGR+qKClQF6npECXAJUrEzgJ51T6HNBkhIBSr2iYIDISf76178yZcoUfD4fF154IaNHj6ZZs2Z4PB6WL1/O7bffznPPPcfq1atrdBzffPMNTZs2rdFz1IYLLriAb775hrZt2wZsX7VqFXv37uXhhx/m/vvvr6PRVc7GjRsZOXIkGzZsoFWrVgwdOpQzzzyT0NBQdu7cyccff8yCBQu477772LdvX10Pt0YtXLiQ+Ph43n333boeSpUtXbq0rocgIiK1qRKVARK/TeMyV3OW+PpXqExgs4hQJQKUekfBAJFiHnnkESZPnkzXrl154403SExMLNFn4cKFPP744zU+lh49etT4OWpD06ZNg76WXbt2AdCpU6faHlKV7N69m2HDhrFr1y5+97vf8cgjj9CsWbMS/ZYsWcI999xTByOsXbt27WLw4MF1PYxqERcXV9dDEBGR2lSJygBbu1zHR5v7YvBVvEygSD2jnAEihbKzs0lNTSUsLIz33nsvaCAA4Kc//Snvv/9+qce46aabaNu2LREREfTv35+FCxeW6Dd79myMMcyePZv333+fIUOG0LJlS4wx/j7B1uYfOXKEBx98kISEBFq0aEHz5s2Ji4vjxhtvZM2aNZV+7Xl5eUyfPp2+ffvSunVrmjZtSkxMDNdeey0fffRR0H3279/Pr3/9azp27EiTJk0499xzmTVrVol+J+cMKMqxMHr0aABuu+02jDH+96PoPUhPT/dvD5ZzIDMzk1GjRtGhQwfCw8Pp2rUrd9xxhz/IcLI1a9ZwxRVX0Lx5c1q0aMGll17Kp59+WuH36v7772fXrl3cfPPNTJ8+PWggAOCyyy4rMXukeH6JrKwsbrzxRtq3b4/L5QpYEvHBBx9w5ZVX0rZtW5o0aUJcXBz33HMPhw8fDnquHTt2MG7cOGJjY2nSpAnR0dFcc801fP755yX6Fs+RMG/ePC644AKaNm1KmzZtuOmmm9i5c2e53ochQ4ZgjMFaG/BZFf3MFv8ZDybYz3dlx3bw4EH+/Oc/k5CQQNOmTWnZsiW9evVi4sSJHDt2zP++p6en+8998nih9JwBP/74I1OnTuW8886jadOmtGjRgosvvpi5c+eW6Fv8My7v7wMREakjhZUB5nqTAJzKADFbieg8lybtlxDReS5pMVtZHx4OOIn/7vf+mgti2jAtNI1bQlYww7OPaG9BwGGLygTeErKCaaFpXBjTKvgsAJE6ppkBIoVmzZpFfn4+N910EwkJCWX2bdKkSYlt27dv54ILLiA2NpZbb72VgwcP8vrrr/svqC+55JIS+8ybN4/333+fESNGcOedd5KdnV3qOa21XHHFFaxcuZKLLrqI22+/ndDQUL777juWL1/OxRdfTL9+/Sr8ugHGjBnDa6+9RkJCAr/85S+JjIxk165dfPLJJ7z//vtceumlAf0PHz7MwIEDCQ8PZ9SoUeTm5jJv3jzGjh2Ly+XyX+gH06pVKyZPnsy6det4++23ufbaa/2JA3v37s3kyZOZMmUK3bp1C0jKWPyibdasWaSkpNCkSROuueYaunbtyqZNm/jXv/7Fu+++y2effcYZZ5zh779y5UouvfRS8vLyuOGGG+jevTvr1q1jyJAhDB06tNzv0/Hjx3nttdcAmDx58in7h4YG/xW7ZcsWEhMTiY+P55ZbbiEnJ4cWLVoAzjKVyZMn06ZNG37605/Svn17vvrqK/7+97/z3nvv8emnn/r7Aqxdu5bhw4dz8OBBLr/8cm644Qb279/PggULGDRoEG+99RZXXnlliTE8++yzvPPOO1xzzTUkJSWRmZnJ66+/zpdffsm6deuC/owXN2bMGIYMGVLis6qOBHwVGdu2bdu45JJL2L59O/369eM3v/kNPp+PrKwsnnzySe68807/z9zs2bPZvn17wGd3qvHm5eVx+eWXk56eTo8ePfjtb3/L8ePHmTdvHjfeeCPr1q3jkUceKbFfZX4fiIhI7apMZQCyD7K0+zxiVSZQGgJrrR4N9AGs6du3rz2VDRs22A0bNpyyX3U4nn/cvrvlXfv8uuftwi0LbU5+Tq2ctzyGDh1qAZuWllah/bZt22YBC9jU1NSAtvfff98CdsSIEQHbZ82aZQFrjLGLFy8OelzAJiUl+b//6quvLGCvu+66En0LCgrswYMHKzTuIocPH7bGGNuvXz/r9XpLtO/fv7/EuAD7q1/9KqD/119/bUNCQuw555wT0H/ZsmUWsJMnTw7YXvQezJo1q8Q5T37txf3vf/+zYWFhNi4uzu7YsSOgbenSpdblcgW8Rz6fz5599tkWsAsWLAjo/9RTT/lfz7Jly4Ker7j09HQL2C5dupyybzDFf1buu+++Eu3//e9/LWAvuugie+jQoYC2ovfrD3/4g39bfn6+jYuLs02aNLHLly8P6L9z507bqVMn26FDB5ubm+vfPnnyZAvY5s2b26+++ipgn5///OcWsK+//nq5X1Npn1VZn29p+1VmbAMGDLCAfeSRR0qcY9++fTYn58TvmKSkJOv8txdct27dbLdu3QK2PfLII/5/w/n5+f7tHo/HduvWzQI2IyPDv70yvw9KU5u/m0VEGoxvFlpbUGCttfZ/e36wMz/Zaqd/lGVnfrLV/m/PD06fggJrv1loZ36y1XabsNB2m7DQdn/4rzZhdkKpj+4P/9V2m7DQ3n5fqrWTW/gfr//5ahsz4R3/cbpNWGhjJrxjX//z1QH97DcL6/BNkYasb9++FlhjK3G9qPCU1Jr1+9cz4s0R3LfiPmasm8HEFRO54s0rWL9/fV0PDXDWggN06dKlUvt369aNSZMmBWy7/PLLOeOMM1i1alXQfa699lquuOKKCp0nMjKyxDaXy0Xr1mUnsSlN0VTvJk2a4AoSsY6Oji6xrWnTpjzxxBOEhJyInvfs2ZOBAwfyzTffcOTIkUqNpTyee+458vPzefrpp+ncuXNA29ChQ7nmmmt49913/WNYuXIl//vf/xg8eDDXXnttQP9x48ZVaJ34nj17AEqct8js2bNJTU0NeAQrs+d2u4POLJg+fToAaWlptGrVKqBtzJgx9O7dm1deecW/bdGiRWzZsoXf/e53JCUlBfTv1KkT9957L3v27AmaGG/8+PH85Cc/CdiWkpICUOrPa20p79jWrFnDypUr6d27NxMmTChxnKLp+VUxc+ZMjDE88cQTATM92rdvz1/+8hcA/vWvf5XYrzK/D0REpIqWPQpzbsbzSgo3Pp/B8Cc/Zsq7G3h8SRZT3t3A8Cc/5sbnM/C8kgJzbqbn//7h37W8lQGW+PqTeYbzf5LKBMrpTssEpFbkenMZt3QcB3IPBGw/kHuAcUvH8f7I94kIrdtSfdaZTRGwbr8ievfuHXBxXKRr166lrk2/4IILyn38nj170rt3b1577TW2b9/Otddey6BBg+jfvz/hhWvZKqNFixZcffXVvPvuu/Tu3ZuRI0dy8cUXk5iYWGo1g7POOitgqnqRrl27As4ygubNa2ZtXNF7mZ6eHnRN/N69eykoKCArK4t+/fqxdu1agBIXywAhISEMGjSILVu2lOvcp/oZmT17tn9depGYmBj/MogivXr1CjoN/9NPPyUsLIw33niDN954o0R7Xl4e+/bt48CBA0RHR/vfi+3btwctIblp0ybAqUxx8lKB/v37l+hf9PkdOlT2H0Q1rbxj++yzzwDnIjtYIKuqjhw5wubNm+ncuXPQJJhFS0y++OKLEm2V+X0gIiJVUIuVATac/VsSB1yiMoFy2lMwQGrF0m+XlggEFDmQe4Cl3y7lqti6/UXZqVMnNm7cyI4dOyq1/8l3couEhobi8/mCtlWkHntISAj//e9/+etf/8q8efP8d0KbN2/O6NGjefTRR0tNZncqr7/+OtOmTePVV1/137GOiIhg1KhR/P3vf8ftdgf0L+u1AhQUFARtrw4HDjg/R3/729/K7Hf06FEAvv/+e4ASr6FIRT6Djh07ApSayK54EsBJkybx8MMPV+icBw4cwOv1MmXKlDLHcfToUaKjo/3vRbDAwcn9TxbsM6yNz688yju2ooSKpc3UqKqin52iz/1kRduDJXaszO8DERGpgtquDOBWmUA5/WmZgNSKHUfKvsA+VXttGDRoEFC7tcYrOguhdevWPPnkk3z33Xf+hHk9evRgxowZ/OY3v6n0OCIjI0lNTSUrK4tvv/2Wl19+mUGDBvHyyy8zatSoSh+3JrRs2RJwLtTKWgNVNBOgqL/H4wl6vKKp/+XRv39/mjRp4n//K6u0z71ly5a0bt36lOu7unXr5u8P8Pbbb5fZvzzJDqtb0Z16r9dboq20qggVVXTBXd4KCBVV9P6W9jNStLSoqJ+IiNQhVQYQqTAFA6RWdGle9jr8U7XXhttuu42wsDDefPNNNmzYUGbfH3/8sZZGVbru3bvzq1/9ivT0dJo1a8bbb79dLcft2rUrt9xyCx988AFnnXUWn3zyif8OdG1xuVyl3p2+8MILAVixYkXQ9pP17dsXoMT0fXDuMn/yySflHlfTpk35+c9/DjhZ/6vbhRdeyKFDh/j666/L3R/K/17UpqIcFt99912JtpNLLlZW0ev/4IMPynW3vWjafnlnPhSV7ty5c2fQ4M+yZcuAEz9jIiJSd4oqA0zwpvBKwcWMc7crtTLAKwUXM8GbQmb2QR4N/SfJJ1UGyN2ZzI97LyN3ZzIp2bEk5OUBzmyDp6NmgmZ4SQOhYIDUimFnDCM6omQiOoDoiGiGnTGslkdUUkxMDKmpqeTl5XHVVVeVesFSVAqwtm3bti3oReKhQ4f48ccfgyYWLI99+/aRmZlZYvuxY8c4cuQIoaGhVcpJUBnR0dFBLyLBSfoXFhbG3XffTVZWVon2vLy8gIvjAQMGcPbZZ/Pxxx+XCJjMmDGj3PkCijz88MN06tSJl19+mbvvvptjx44F7Vc0xbwi7r77bsBJlrdr164S7ceOHfOvkwcnAWVcXBz/+Mc/eO+994Ie89NPP+X48eMVHktV9e/fH5fLxauvvhpw/oMHD3LvvfdWyzn69evHgAEDWLduHdOmTSvRfuDAAXJzc/3fFyXD/Pbbb8t9jrFjx2Kt5Z577gkIIuzfv58HH3zQ30dERGrAxkX+C+8szxFmZWzjmaWbmJWxjSxPYbJinw82LiJj837ASd6XGpkYdLo/OAGB1MhELC4uda0ldscCf9tcbxKT8u8g/4e+5B0YRv4PfZmUf4d/tgE4+QjIWlwzr1eklilngNSKiNAIZgybUSKJYHRENDOGzajz5IFF7r//fv+a7fPPP58BAwbQv39/mjVrhsfj4eOPP2bTpk1BE5zVtC+//JLrr7+efv36kZCQQKdOndi3bx9vv/02+fn5QbOpl8fOnTu58MILOeecc+jbty9du3blhx9+YOHChezZs4fx48fXWDLA0gwbNow5c+Zw9dVX069fP0JDQxk8eDCDBw+mR48ezJw5k7Fjx3LuuedyxRVXEB8fT35+Pt9++y0rVqygXbt2bNy4EXCm5P/73//msssuY+TIkdxwww10796dL7/8ko8++ogrrriC999/v9xj69SpE0uXLuWGG27gqaee4sUXX2To0KHExsbicrnweDxkZGSwadMm2rdvHzTxXFmve+rUqdx3332cddZZXHnllZx55pkcPXqU7du3k56ezqBBg/zjDQsLY/78+Vx++eVcddVVDBgwgN69e9O0aVO+++47Pv/8c7Zu3cru3btLTQZZUzp27Mgtt9zCf/7zH3r37s1VV13FDz/8wHvvvcfgwYODJt2rjJdffpkhQ4Zw//338+abbzJkyBCstWzatIkPP/yQjRs3EhMTAzjv7xtvvMENN9zAlVdeSWRkJN26dePWW28t9fh/+tOfWLx4MW+//Ta9evXiyiuv5Pjx47zxxhvs3buXe++917/ESEREqtGyRyF9Kp64UYw/NpbM7MMluiTGtGJ61EzcW+bR84wU4BKg4pUBEr9NcyoDHBuLPek8RZUBkqLaOYEAVQaQBkTBAKk1CW0TeH/k+yz9dik7juygS/MuDDtjWL0JBBR54IEH+NnPfsazzz7LsmXLmDVrFrm5uURHR/tLmP3iF7+o9XH179+f++67j/T0dN5//30OHTpEu3bt6NevH+PHj6/0bIWYmBimTJnC8uXLWbZsGfv376dNmzacffbZTJ06lZtuuqmaX8mpPf300xhjWLp0Ke+99x4+n4/JkyczePBgAH7xi1/Qq1cvHn/8cZYtW8aHH35IVFQUnTp1YtSoUdx4440Bxxs4cCArVqzgz3/+M4sXO9H8xMREli9fzgcffFChYABAjx49WLduHa+99hpvvvkmn376KQsXLsQYQ/v27f0/JzfeeGOFkzpOmDCBgQMHMn36dD755BPefvttWrZsSefOnfn1r3/NzTffHND/vPPO48svv+SJJ55g4cKFzJo1C5fLRceOHenTpw9Tpkyhbdu2FRpDdUlLS8PtdvPaa6/xj3/8gzPOOIPx48dzzz33MHfu3Go5x5lnnsnatWt57LHHWLBgATNmzCAiIoKYmBj++Mc/0r59e3/f22+/ne3btzNnzhwee+wxvF4vSUlJZQYDwsPDWbJkCU888QSvvvoqzzzzDKGhofTq1YunnnrKv2xERESqkSoDiNQKU1QqSxoeY8yavn379l2zZk2Z/b755hsAzjnnnNoYloiIlIN+N4tIo+Xz4XklxV8ZAOCVgotLVAa45aTKAMM2O0mPHwp7gbSYraVXBsiOZVL+HVhcfHj3YCUElNNaYSnttdbafhXdVzMDRERERESk/iisDDDSu4/k0HSnMoB7KxGh2/1d0rwF9PKEk5CXx1xvEvO9v+aCGBi5YxrJISvo5QkvkUSwqDJAQshOwqwz/V+BAGnMFAwQEREREZF6o6gywCpSyDc+0twl7/IXVQZIyY5lkjcFsg+ytPs8Yk+qDFB8NkFKTiYJIU452uTQdJKi2jnT/13KqS6Nk4IBFWSMiQauB64CfgJ0BvKA/wfMAmZZa8tVb8QYkw10K6XZY63tUOUBi4iIiIjUtY2LIH4ElLku3wdZi8k40BM4URmg+IyA4vyVAfJdXOZaXbIygDcFm3/iQn8SvQmzLn8pQacygPIASOOlYEDF/Qx4DtgNLAO+BdzADcC/gBHGmJ/Z8idj+B54Ksj2o1UfqoiIiIhIHVNlAJF6ScGAissCrgEWFZ8BYIy5H1gFjMQJDLxZzuMdttamVvcgRURERETqnCoDiNRbCgZUkLX2v6Vs32OMeR54GBhC+YMBIiIiIiINU/wIPHGj/JUBkkPTyTe+EpUBkk+qDPDR5r4YfKTmZJLmLSi9MkBOJpPojcXFwO5twX3iAj/e3Tx4gkCXS4EAERQMqG75hc/eCuzTxBjzC+AM4BjwFfCxtbagugcnIiKnB5X9FZEGQ5UBROotBQOqiTEmFPhl4bfvV2DXDsB/Ttq2zRhzm7U2vZznXlNKU49y7o+1Fp/Ph0vZVEVE6lxRMMAYU8cjERGpGlUGEKm/FAyoPlOBBOA9a+0H5dxnFrAC+Bo4AsQC44BfA4uNMRdZa7+sicEW16RJE3Jzczl27BjNmyuiKiJS144dOwY4v59FROodVQYQaRAUDKgGxpjxwB+BjcCt5d3PWjvlpE3rgTuNMUcLj5eKU8bwVMfpV8q41gB9T7V/8+bNyc3NZc+ePQBERUVhjNEdKRGRWmStxVrLsWPH/L+PFaAVkXpHlQFEGgwFA6rIGPNb4GlgAzDMWnuwGg77PE4wYHA1HOuU2rRpw7Fjxzh+/Dg7duyojVOKiMgpNG3alDZt2tT1MERETlBlAJEGRcGAKjDG/AF4EueO/jBr7d5qOnTRcaKq6XhlcrlcdO3alYMHD3LkyBF+/PFHJa8SEakDxhiaNGlC8+bNadOmjfK4iEj9osoAIg2KggGVZIyZgJMnYB1wmbV2fzUe/qLC563VeMwyuVwu2rZtS9u2bWvrlCIiIiJyOlFlAJEGRcGASjDG/AX4K7AGGF7W0gBjTBgQB+Rba7cU234usPvkfY0x3YAZhd++XN1jFxERERGpDFUGEGlYFAyoIGPMaJxAQAFOJYDxQRLtZVtrZxd+3Rn4BtgOxBTr8zNgojFmGbANp5pAHHAVEAG8B/y9Rl6EiIiIiAioMoBII6ZgQMWdWfgcAvyhlD7pwOxTHGcZcDbQB2dZQBRwGPgE+A/wH6uF+yIiIiJSU1QZQKRRUzCggqy1qTgl/8rbPxsoMXXAWpuOEzQQEREREaldqgwg0ugpGCAiIiIi0tioMoBIo6dggIiIiIhIY6PKACKNnoIBIiIiIiKNjCoDiIiCASIiIiIijUzG5v2AKgOINGYK0YmIiIiINAQbFzllAHHu/M/K2MYzSzcxK2MbWZ4jTh+fDzYu4miu179bRSsDAE5lgC4TAhIOwonKAJ64Uc4GVQYQqbc0M0BERERE5HRXwTKBg2Lv4HGSAFQZQKSRUjBAREREROR0VokygX22vsBlrig+8vVVZQCRRkrBABERERGR01klygR64kZx5OhQpu38myoDiDRSCgaIiIiIiJzOKlEm8K2jY3i62Wz/TAFVBhBpfBQMEBERERE5jVWmTOCl3/0Xd/g8f7sqA4g0PgrriYiIiIjUNxWoDHBymcBga/+hWJlAXCzx9eeL2DsAVQYQaaw0M0BEREREpD6pYGWAnmekAJcA5S8TCPBJ5xT6XJCkygAijZSCASIiIiIi9UUlKgMkfpvGZa7mLPH1r1CZwGYRoQEX+KoMINK4aJmAiIiIiEh9UVgZoEhyaDoPhb1AWIu1hEcvJazFWh4Ke8G/jh9ga5fr+MjXF4OP1JxMor0FQQ8d7S0gNScTg7P8YGD3tjX7WkSkXtPMABERERGR+qISlQHme3/NBTEwcsc0lQkUkXJTMEBEREREpJ6oTGUAsg+ytPs8YlUmUEQqQMEAEREREZF64uTKAMVnBBTnrwyQ7+Iy12pidyzwt6lMoIiUh0KBIiIiIiI1qQJlAo/mev27lbcywBJffzLPSAFUJlBEyk8zA0REREREakoFywQOir2Dx0kCqFBlgA1n/5bEAZeoTKCIlJuCASIiIiIiNaESZQL7bH2By1xRfOTrS2pOJmneghI5A8BJCJiSk8kkemNxOZUB3CoTKCLlp2CAiIiIiEhNKCwT6N4yD3AS9+UbX0Biv9ScTJJDVvh38cSN4sjRoUzb+TdVBhCRGqVggIiIiIhITahEmcC3jo7h6Waz/TMFVBlARGqKggEiIiIiIjWgMmUCL/3uv7jD5/nbVRlARGqKwociIiIiIjXg5DKBwdb+Q7EygbhY4uvPF7F3AKoMICI1SzMDRERERETKY+MiiB8BZWbr90HWYuhxVaXKBAJ80jmFPhckqTKAiNQoBQNERERERE6lgiUCSZpIs4ib/G0VKRPYLCI04AJflQFEpCZomYCIiIiISFlOLhG4YxoGX0AXf4nAwsoBpE9leMgaf1tqTibR3oKgh4/2FpCak+k/5sDubWvohYiInKCZASIiIiIiZalkicDOF9xA4rpPGbljmsoEiki9o2CAiIiIiEhZKlEicP6xscwBZ9mAygSKSD2kYICIiIiISBkqUyLQZh9m56r5dN6iMoEiUj8p5CgiIiIiUobKlAgE+LCgn1P2D5UJFJH6RzMDRERERKTxqUCZwKO58f7dKlIi8GiuF4bdBx3PU5lAEal3FAwQERERkcalgmUCB8XeweMkAZUoEQgqEygi9ZKWCYiIiIhI41GJMoF9tr7AZa7VKhEoIg2KZgaIiIiISONRyTKBR44OZdrOv6lEoIg0GAoGiIiIiEjjUYkygW8dHcPTzWarRKCINCgKBoiIiIhIo1GZMoGXfvdf3OEqESgiDYtClSIiIiJyetu4yMn8j3OxPytjG88s3cSsjG1keY44fXw+2LioUmUCl/j680XsHYBKBIpIw6GZASIiIiJy+qpgZYCeZ6QAlwAVKxP4SecU+lyQpBKBItJgKBggIiIiIqenkysDePexipSAu/b+ygCF0/cTv03jMldzlvj6V7xMoEoEikgDomUCIiIiInJ6KqwMUCQ5NJ2Hwl4grMVawqOXEtZiLQ+FveBfxw+wtct1fOTrqzKBItLoaWaAiIiIiJyeKlEZYL7311wQAyN3TFOZQBFp1BQMEBEREZHTUmUqA5B9kKXd5xGrMoEi0sgpGCAiIiIip6WTKwMUnxFQnL8yQL6Ly1yrid2xwN+mMoEi0lgpvCkiIiIi9UcFygQezfX6dytvZYAlvv5knpECqEygiDRumhkgIiIiIvVDBcsEDoq9g8dJAqhQZYANZ/+WxAGXqEygiDRqCgaIiIiISN2rRJnAPltf4DJXFB/5+pKak0mat6BEzgBwEgKm5GQyid5YXE5lALfKBIpI46ZlApVkjOlijJlpjNlljPnRGJNtjHnKGFN2WLqGjiMiIiJyWqtEmUBP3CiOdB3KtNA0bglZwQzPvhKlAosqA9wSsoJpoWlcGNNKlQFERNDMgEoxxsQBK4H2wNvARuAC4PfAFcaYgdbaA7V1HBEREZHTXiXKBL51dAxPN5vtnymgygAiIuWnYEDlPItzAT/eWvtM0UZjzBPA3cDDwJ21eBwRERGR01plygRe+t1/cYfP87erMoCISPkpJFpBxphYYDiQDfzjpObJwDHgVmNMVG0cR0RERKQhOLlMYLC1/1CsTCAulvj680XsHYAqA4iIVJRmBlTc0MLnD621vuIN1tojxpgMnIv8C4GltXAcERERkfpp4yKIHwFlZuz3QdZijubG+3crb5lAgE86p9DngiRVBhARqSAFAyru7MLnrFLaN+FcxMdT9kV8dR1HREREpP6ppTKBzSJCAy7wVRlARKR8tEyg4loWPn9fSnvR9la1dByMMWuCPYAep9pXREREpNqdXCZwxzQMARMhT5QJ3OKs+XfKBK7G4CM1J7NEVYAi0d4CUnMy/ccb2L1tDb4QEZGGSzMDqp8pfLb15DgiIiIitauwTGDRhX5yaDr5xheQ5T81J5PkkBX+XTxxozhydCjTdv6N5JAV9PKEM87dLiB3QFGZwISQnYRZJxeAygSKiFSOggEVV3THvmUp7S1O6lfTx8Fa2y/Y9sLZAX1Ptb+IiIhItVKZQBGRek/BgIr7X+FzfCntZxU+l5YLoLqPIyIiIlKvqEygiEj9pzBqxS0rfB5ujAl4/4wxzYGBQA7wWS0dR0RERKReUZlAEZH6TzMDKshau8UY8yFOpv/fAs8Ua54CRAEvWGuPARhjwoA4IN9au6WyxxERERGpUyoTKCLSoCgYUDl3ASuB6caYYcA3QCJwCc60/j8X69u5sH07EFOF44iIiIjUDZUJFBFpcLRMoBIK7/D3B2bjXLz/Eefu/3TgImvtgdo8joiIiEiNUZlAEZEGSTMDKsla+x1wWzn6ZXOiTGCljyMiIiJSJ1QmUESkQVIwQERERERKpzKBIiINkoIBIiIiIlIqlQkUEWmYFHoVERERkVKpTKCISMOkmQEiIiIijY3KBIqINHoKBoiIiIg0JioTKCIiaJmAiIiISOOhMoEiIlJIMwNEREREGguVCRQRkUIKBoiIiIg0FioTKCIihRQMEBEREWkkVCZQRESKKFwrIiIi0kioTKCIiBTRzAARERGR05nKBIqISCUoGCAiIiJyulKZQBERqSQtExARERE5HalMoIiIVIFmBoiIiIicjlQmUEREqkDBABEREZHTkcoEiohIFSgYICIiInIaUplAERGpCoV4RURERE5DKhMoIiJVoZkBIiIiIvWFygSKiEgtUTBAREREpD5QmUAREalFWiYgIiIiUtdUJlBERGqZZgaIiIiI1DWVCRQRkVqmYICIiIhIXVOZQBERqWUKBoiIiIjUMZUJFBGR2qawsIiIiEgdU5lAERGpbZoZICIiIlITVCZQRETqMQUDRERERKqbygSKiEg9p2UCIiIiItVJZQJFROQ0oJkBIiIiItVJZQJFROQ0oGCAiIiISHVSmUARETkNKBggIiIiUo1UJlBERE4HCiWLiIiIVCOVCRQRkdOBZgaIiIiIVKOjuV7/1yoTKCIi9ZWCASIiIiKnsnERxI+AMi/SfZC1mGYRPf27qUygiIjUVwoGiIiIiJRl2aOQPhVP3CjGHxtLZvbhEl0SY1oxPWom7i3zuKb/3UzhfH+ZwDRvQdClAtHeAlJyMplEbywulQkUEZFapWCAiIiISGk2LoL0qYCTsG+kdx+rSAlYz2/wMXLHNH8lgOjVT3JXhweI2Z+uMoEiIlJvKRggIiIiUpr4EXjiRjmZ+3FK+uUbX0DJv9ScTJJDVvh38cSOZDRf4z6sMoEiIlJ/KRggIiIiUhqXi/HHxjLSu4/k0HTWh4eT5t5KROh2f5c0bwG9POEk5OUx15vE9oM9uefwg/52lQkUEZH6SOFnERERkVJkeY6QmX2YCd4UXim4uMR0f3BKBI5zt+OVgouZ4E3hH3vO4UD/uwGVCRQRkfpLMwNERERESpGxeT/gXLynRiYGzAgo7kBoCKmRif67/++0Hs1tN52vMoEiIlJvKRggIiIijUcFSgTS4yqO5nr9u5qwQ2Ueunj70VyvygSKiEi9pmCAiIiINA4VLBFI0kSaRdzkb7P5rcs8fPH2ZhH6E0tEROo35QwQERGRhu/kEoE7pmHwBXTxlwgsrBxA+lSGh6zxt6XmZBLtLQh6+GhvAak5mf5jDuzetoZeiIiISPVQ2FpEREQavsqUCIwbRecLbiBx3aeM3DGN5JAV9PKEl0giGO0tYIZnHwkhOwmzTmLAoEsCRERE6hEFA0RERKThq0SJwPnHxjIHnGUDhSUAE/LySMmODQgipORkkhCyE3CCDElR7ZzEgC5NwBQRkfpLwQARERFp8IpKBK4ihXzjI829tdQSgSnZsUzypmCzD7Nz1Xw6Fy0bAOZ6k5y2/BMX+pPoTZh1kVwYMHBvmacKASIiUu8pZC0iIiIN3sklAk8OBBTxlwgs/BPpw4J+kDQRcJYNzO8ywd9WxOIsDfDEjXI2JE1UIEBEROo9zQwQERGRBq9KJQKH3Qcdz8MdP4I5ZZYkvEgzAkRE5LShYICIiIicnjYugvgRUOYFug+yFtMsoqd/t0qVCCx2gR/vbh48QaDLpUCAiIicNhQMqABjzFnADcDlwFmAGzgEfAY8Za1dVoFjxQDbyujyurX2pjLaRUREGq9lj0L6VDxxoxh/bCyZ2YdLdEmMaeUk/9syj2v6380UzveXCEzzFgRdKhDtLSAlJ5NJ9MbiUolAERFpsBQMqJgHgRuBDcB7wEHgbOAa4BpjzO+ttdMreMwvgQVBtq+vwjhFREQaro2LIH0q4CTrG+ndxypSAtbyG3yM3DHNXwUgevWT3NXhAWL2p6tEoIiICAoGVNT7wDRr7RfFNxpjkoAlwN+MMW9Ya3dX4JjrrLWp1ThGERGRhi1+BJ64UU7WfpxyfvnGF1DuLzUnk+SQFf5dPLEjGc3XuA+rRKCIiAgoGFAh1trZpWxPN8YsBy4DBgBv1uKwREREGheXi/HHxjLSu4/k0HTWh4eT5t5KROh2f5c0bwG9POEk5OUx15vE9oM9uefwg/52lQgUEZHGTsGA6pNf+Owts1dJnYwxdwDRwAHgU2vtV9U6MhERkQYky3OEzOzDrCKFfOMjzb21xPr/A6EhjHO3IyU71rno3+Ni7KC7iV79pFMi8NhY7El5BopKBCZFtXMCASoRKCIiDZiCAdXAGNMNGAYcBz6u4O6XFT6KH285MNpa+205z7+mlKYeFRyLiIhIvZexeT/gXLynRiYGzAgo7kBoCKmRif67/++0Hs1tN52vEoEiIiJUYzDAGGOAS3EubAcDZwBtgRxgL7AO+C/wjrV2Z3Wdt64ZY5oArwBNgHuttWUXLz7hOE5CwgXA1sJt5wGpwCXAUmNMb2vtsWodsIiIyGnuaO6JSXgmrOz/dou3H831qkSgiIhIoSoHA4wxTYHxwB04AQBT2JSLEwSIBGKBOGAk8LQx5l3gcWvtyqqevxLjzQa6VWCXV6y1vyjlWCHAf4CBwOvA38t7UGvtXuCBkzZ/bIwZDnwCJAK3A0+X41j9ShnfGqBvecckIiJSZzYugvgRUOYdex9kLaZZRE//bja/dZmHLd7eLEITIkVERIpU6X9FY8xtwENAR2AjMAXIAD631v5QrJ/BKcF3IXA5cC1wnTFmHnBPeafDV5MtOIGK8toVbGNhIOBl4GfAXOAX1lpb1cFZa73GmH/hBAMGU45ggIiIyGlt2aOQPhVP3CjGHxtL5klr+QESY1oxPWom7i3zuKb/3UzhfAw+UnMySfMWlMgZAE6pwJScTCbRG4uLgd3b1sKLEREROT1UNUT+b5xp7o9aaz8vrVPhRfLGwsdsY0wLYDQwERgD/LWK4yg3a+2wqh7DGBMKvIoTCHgV+KW1tqCqxy1mX+FzVDUeU0REpP7ZuAjSpwJO9v6R3n2sIgXLiSz/Bh8jd0zDXZjlP3r1k9zV4QFi9qeTHLKCXp5wxrnbBQQEor0FzPDsIyFkJ2HWSQwYdEmAiIhII1XVYEB/a+3aiu5UOGvgGWNMGhBTxTHUKmNMOM5MgGuBl4DbrLW+aj7NhYXPW8vsJSIicrqLH4EnbpSTvR9IDk0n3/hIjUzEhB3C5rcmNSeT5JAV/l08sSMZzde4DzvBgYS8PFKyYwP2ScnJJCFkp/+YSVHtnMSALlfJMYiIiDRCVQoGVCYQcNL+uTizBU4LhckC5wNX4syK+PWpAgHGmJY4yyi+t9buLrY9EfjCWpt3Uv+hwN2F375cjcMXERGpf1wuxh8by0jvPpJD01kfHk6ae2tAhYA0bwG9POEk5OUx15vE9oM9uefwg/72ud4kp3xg/okL/Un0Jsy6SC6cTeDeMk8VAkRERIpRJp2KeR4nELAf2Ak84KRDCLDcWru82PfXA7OAF3GWRBSZBpxbWEZwR+G284ChhV//pS4SLIqIiNSmLM8RMrMPs4oU8o2PNPfWEuv/D4SGMM7djpTsWOeif4+LsYPuJnr1k3jiRjH/2FjsSXkGLM7SgKSodk4gIGmiAgEiIiLFVHswwBjTBefOdm+gCxAWpJu11sZV97lrwZmFz20pWQmguOXlONZ/cAIF5wMjcN4nD84ShBnW2hVl7CsiItIgZGzeDzgX76mRiQEzAoo7EBpCamSi/+7/O61Hc9tN5+OOH8GcMisQXKQZASIiIkFUazDAGDMEeA+IALw4F7feYF2r87y1xVo7pBL7zAZmB9n+b5ylBiIiIg1LBcoEHs2N9+9mwg6Vedji7UdzvQEX+PHu5sETBLpcCgSIiIgEUd0zAx4DQoBfAq/WQGI9ERERqc8qWCZwUOwdPE4SADa/dZmHLt7eLEIrHUVERKqiulPq/gR4zVr7sgIBIiIijczJZQJ3TMMQ+OeAv0xgYfWAPltf4DLXagw+UnMyifYGr9Qb7S0gNSfTf7yB3dvW4AsRERFp+Ko7rH4IOFjNxxQREZHTQWXKBMaN4sjRoUzb+TeSQ1bQyxPOOHe7gCSC0d4CZnj2kRCykzDrJAYMuiRAREREyq26gwELoXCun4iIiDQulSgT+NbRMTzdbDbuwhKACXl5pGTHBgQQUnIySQjZCTgBhqSodk5iQFd1T3AUERFpPKo7GHA/8Jkx5h/AvdbaY9V8fBEREamnKlMm8NLv/os7fJ6/fa43ySkfmH/iQn8SvQmzLpILAwbuLfNUIUBERKSKqjWkbq3dD1wB3ATsMcasMcb8N8hjaXWeV0REROreyWUCTw4EFPGXCcTFEl9/voi9A3CWDMzvMgF70p8nFmdpgCdulLMhaaICASIiIlVU3aUFzwWWAUXpfvuU0tVW53lFRESk7h3NPVFNuCJlAj/pnEKfC5Jwx49gTpnlCC/SjAAREZFqUt3LBJ4AooEHgBeBXdba4GmBRUREpP7buAjiR0CZF+k+yFpMs4ie/t0qXCaw2AV+vLt58ASBLpcCASIiItWkuoMBFwHzrbUPVfNxRUREpLYtexTSp+KJG8X4Y2PJzD5coktiTCumR83EvWUe1/S/mymc7y8TmOYtCLpUINpbQEpOJpPojcWlMoEiIiJ1oLqDAXlAdjUfU0RERGrbxkWQPhVwEvaN9O5jFSkB6/kNPkbumOavBBC9+knu6vAAMfvTVSZQRESknqvuYMBy4IJqPqaIiIjUtvgReOJGOZn7cUr65RtfQMm/1JxMkkNW+HfxxI5kNF/jPqwygSIiIvVddQcD7gUyjTETgWnWWiUKFBEROR25XIw/NpaR3n0kh6azPjycNPdWIkK3+7ukeQvo5QknIS+Pud4kth/syT2HH/S3q0ygiIhI/VXdwYBJwHrgYSDFGLMO+D5IP2ut/VU1n1tERESqSZbnCJnZh1lFCvnGR5p7a4n1/wdCQxjnbkdKdqxz0b/HxdhBdxO9+kmnTOCxsdiT8gwUlQlMimrnBAJUJlBERKROVHcwYEyxr88sfARjAQUDRERE6qmMzfsB5+I9NTIxYEZAcQdCQ0iNTPTf/X+n9Whuu+l8lQkUERGp56o7GFDaxb+IiIicRo7mev1fm7BDZfYt3n4016sygSIiIqeBag0GWGuD3zYQERGRurdxEcSPgDLv2PsgazHNInr6d7P5rcs8bPH2ZhHVfZ9BREREakKV/8c2xjwFzAdWKGGgiIhIPbXsUUifiiduFOOPjSXzpLX8AIkxrZgeNRP3lnlc0/9upnA+Bh+pOZmkeQtK5AwAp1RgSk4mk+iNxcXA7m1r4cWIiIhIVVVH+H4c8DvggDHmHZzAwEfW2rxqOLaIiIhU1cZFkD4VcLL3j/TuYxUpWE5k+Tf4GLljGu7CLP/Rq5/krg4PELM/neSQFfTyhDPO3S4gIBDtLWCGZx8JITsJs05iwKBLAkRERKTeqY5gQCfgOuB64BfAbcAxY8x7wFvAe9baI9VwHhEREamM+BF44kY52fuB5NB08o2P1MhETNghbH5rUnMySQ5Z4d/FEzuS0XyN+7ATHEjIyyMlOzZgn5ScTBJCdvqPmRTVzkkM6HKVHIOIiIjUK1UOBlhr9wL/BP5pjGkB/BQnMHAlkAz8aIxZihMYeMdau6+q5xQREZEKcLkYf2wsI737SA5NZ314OGnurQEVAtK8BfTyhJOQl8dcbxLbD/bknsMP+tvnepOc8oH5Jy70J9GbMOsiuXA2gXvLPFUIEBEROU1Ua+jeWvuDtfZVa+3PgHY4MwbmAIlAGrDLGJNujPm9MaZbdZ5bREREgsvyHCEz+zATvCm8UnBxien+4JQIHOduxysFFzPBm8I/9pzDgf53A+CJG8X8LhMClhWAU3ZwfpcJeOJGORuSJioQICIicpqosZS/1tofgXeAd4wxLiAJuAG4FngSeMIYs85a26+mxiAiIiKQsXk/4Fy8p0YmBswIKO5AaAipkYn+u//vtB7NbTedjzt+BHPKrEBwkWYEiIiInGZqpf6PtdYHLCt8/M4Y0x8nMHBdbZxfRESkMTua6/V/bcIOldm3ePvRXG/ABX68u3nwBIEulwIBIiIip5kqLxMwxlxTeOe/3Ky1q62191tre566t4iIiFRFs4gTsX+b37rMvsXbi+8nIiIiDUt15AxYAGw3xvxVeQBERERqycZF4PMBTk6AWRnbeGbpJmZlbCPLU1jEx+eDjYsY2L0t4JQPTM3JJNpbEPSQ0d4CUnMyMTjHLdpPREREGp7qCPkvBYYCk4D7jTFLcKoLvGOtDf7XhoiIiFTeskchfSqeuFGMPzaWzOzDJbokxrRietRM3FvmEZ80kcSYwYzcMY3kkBX08oSXSCIY7S1ghmcfCSE7CbNOYsCgSwJERESkQaiO0oKXFc4IuB0YA1wODAc8xphZwL+ttVureh4RERHBmRGQPhVwSvmN9O5jFSkBmf4NPkbumIa7sOQf6VN5ocPHtApdCUBCXh4p2bGkRiZiwg5h81uTkpNJQshOAJJD00mKauckBnRVa+EhERERqSeq5X94a+12a+1fgG7ANcBCoC1wH5BljPnQGDPKGKPFhyIiIlURP+JEKT+cC/eHwl4grMVawqOXEtZiLQ+FvUByUSAAONxhAK32rPR/P9ebxKT8O8j/oS95B4aR/0NfJuXfwVxvkr+Pe8s8yFpcO69JREREal21hvuttT5r7UJr7bXAGThLB7KBS4HXgZ3GmGnGmLOq87wiIiKNhsvF+GNj/Rfu68PDSYvZSkTnuTRpv4SIznNJi9nK+vBwwLnwv5NJkDQRAE/cKOZ3mRAwkwCcsoPzu0w4EWhImqgKASIiIg1Yjd2pt9buAR4BHjHGDMNZRnAd8CfgjzV5bhERkYYqy3OEzOzDrCKFfOMjzb01YO0/wIHQEMa525GSHcskbwo2+zBZ148jvuN5uONHMMflIstzhIzN+zma66VZRCgDu7d1cgT4LoKsGxQIEBERaeBq64I8HWgDnAlcUEvnFBERaXAyNu8HnDv5qZGJRIRuD9rvQGgIqZGJ2HyXf7/4gScu8OPdzYMnCHS5FAgQERFpBGo0GGCMORtnRsAvcXIIGGAb8O+aPK+IiEhDdTTX6//ahB0qs2/x9uL7iYiIiFR7MMAYEwEk4wQBBuIEAPKB+UCatfbD6j6niIjIaW3jIogfAWVO3/dB1mKaRfT072bzW5d52OLtzSK0Ok9EREROqLa/DIwxvYEU4GagBU4QYAvwL2CWtXZvdZ1LRESkwVj2KKRPxRM3ivHHxpKZfbhEl8SYVkyPmol7yzyu6X83Uzgfg4/UnEzSvAUlcgYARHsLSMnJZBK9sbgY2L1tLbwYEREROV1UORhgjLkDJwjQBycAkAe8AfzTWvvfqh5fRESkwdq4CNKnAk4pv5HefawiJSDTv8HHyB3TcBeWCoxe/SR3dXiAmP3pJIesoJcnnHHudgEBgWhvATM8+0gI2UmYdaoEBM0PICIiIo1WdcwMeK7wOQtIA1601u6vhuOKiIg0bPEj8MSNwr1lHgDJoenkGx+pkYmYsEPY/Nak5mSSHLLCv4sndiSj+Rr3YSc4kJCXR0p2bMA+KTmZJITs9B8zKaqdUyXAVa0VhUVEROQ0Vh3BgNdwZgGkV8OxREREGg+Xi/HHxjLSu4/k0HTWh4eT5t4aUCEgzVtAL084CXl5zPUmsf1gT+45/KC/fa43ySkfmH/iQn8SvQmzLpILZxO4t8xTuUAREREJUOVggLX2luoYiIiISGOT5TlCZvZhVpFCvvGR5t5aYv3/gdAQxrnbkZId61z073ExdtDdRK9+Ek/cKOYfG4s9Kc+AxVkakBTVzgkEJE1UIEBEREQCVEfOgF9WZj9r7UtVPbeIiMjpLGOzs6rO4iI1MjFgRkBxB0JDSI1M9N/9f6f1aG676Xzc8SOYU2YFgos0I0BERESCqo5lArMBW4H+prC/ggEiItKoHc31+r82YYfK7Fu8/WiuN+ACP97dPHiCQJdLgQAREREJqrpKC3qBhcCGajqeiIhIg9cs4sR/wza/dZl9i7cX309ERESkMqrjr4l0YDBwHdAep6LAXGttbjUcW0RE5PSycRHEj4Ayp+/7IGsxA7sPBpzygak5maR5C0rkDACnVGBKTiaT6I3FxcDubWv7VYmIiEgDUx0JBC8xxnQHUoBfArOAp40xLwNp1tqvqnoOERGR08KyRyF9Kp64UYw/NpbMkxL7ASTGtGJ61EzcW+YRnzSRxJjBjNwxjeSQFfTyhDPO3S4gIBDtLWCGZx8JITsJs05iwKBLAkREREQqoFrmGVprNwMTjDF/Bq7FCQz8BrjLGLMGeAGYY609Vh3nExERqXc2LoL0qYBTym+kdx+rSMFyouSfwcfIHdNwF5b8I30qL3T4mFahKwFIyMsjJTuW1MhETNghbH5rUnIySQjZCUByaDpJUe2cxIAuFyIiIiKVVa2LDq21XuBN4E1jTDfgdmAM8E/gCWPMFdbaT6vznCIiIvVC/Ag8caOcUn44F+75xhdwYZ+ak0lyyAr/Loc7DKDVnpX+7+d6k5zygfknLvQn0Zsw6yK5MIDg3jJPFQJERESkymrstoK1dru19i/Ar4GdQDOgXU2dT0REpE65XIw/Npa53iQA1oeHkxazlYjOc2nSfgkRneeSFrOV9eHhgHPhfyeTIGkiAJ64UczvMiFgJgE4ZQfnd5mAJ26UsyFpogIBIiIiUmU1ko7YGNMJGFv46AbkAi8Da2vifCIiInUty3OEzOzDrCKFfOMjzb21RDLAA6EhjHO3IyU71pkBkH2YrOvHEd/xPNzxI5hTZtLBizQjQERERKpNtQUDjDEu4Kc4SwOuKDz2/wN+D/zHWvt9dZ1LRESkvsnYvB9w7uSnRiYSEbo9aL8DoSGkRib6lwJkbN5P/MATF/jx7ubBEwS6XAoEiIiISLWp8jIBY8yZxpiHgO+ABcAlwIvAhdbaXtbaGQ0lEGCMiTHG2DIecypxzAHGmPeMMQeNMceNMV8ZY/5gjClZW0pEROqto7le/9cm7FCZfYu3F99PREREpLZUx8yAzYXPq4HJwGuNoGrAlziBj5Otr8hBjDHX4iRczAVeBw4CVwNPAgOBn1VplCIiUmuaRZz4L9Xmty6zb/H24vuJiIiI1Jbq+AvEAPlAR+AB4AFjzKn2sdbabtVw7rqyzlqbWpUDGGNaAGlAATDEWru6cPtfgP8Co4wxN1lrKzzbQEREqsnGRRA/Aspcy++DrMUM7D4YcMoHpuZkkuYtKJEzACDaW0BKTiaT6I3FxcDubWv7VYmIiIhUW86AMKBLNR2rsRiFU13hpaJAAIC1NtcYMwlYCvwGUDBARKQuLHsU0qfiiRvF+GNjycw+XKJLYkwrpkfNxL1lHvFJE0mMGczIHdNIDllBL08449ztAgIC0d4CZnj2kRCykzDrVAkImh9AREREpIZVORhgra2x8oT1WCdjzB1ANHAA+NRa+1UFjzG08Pn9IG0fA8eBAcaYJtbaHys/VBERqbCNiyB9KgDuLfMY6d3HKlICyv4ZfIzcMQ13aLqzIX0qL3T4mFahKwFIyMsjJTuW1MhETNghbH5rUnIySQjZCUByaDpJUe2cKgGuxvhfqYiIiNQlLVSsnMsKH37GmOXAaGvtt+U8xtmFz1knN1hrvcaYbcC5QCzwTVkHMsasKaWpRznHIiIixcWPwBM3CveWeYBz4Z5vfAEX9qk5mSSHrPDvcrjDAFrtWen/fq43ySkfmH/iQn8SvQmzLpILAwjuLfNULlBERETqhG5FVMxx4EGgH9C68JEELAOGAEuNMVHlPFbLwufSKi0UbW9VmYGKiEgVuFyMPzaWud4kANaHh5MWs5WIznNp0n4JEZ3nkhazlfXh4YBz4X8nkyBpIgCeuFHM7zIhYCYBOGUH53eZgCdulLMhaaICASIiIlInqjQzwBgTaa3NqetjVPB82UBFkhe+Yq39BYC1di9OksTiPjbGDAc+ARKB24Gnq2Oohc/2VB2ttf2CHsCZMdC3GsYiItKoZHmOkJl9mFWkkG98pLm3lkgGeCA0hHHudqRkxzozALIPk3X9OOI7noc7fgRzykw6eJFmBIiIiEidquoygW3GmEeB5yu6rt0Y0wv4K05JwgerOI6K2IJTyq+8dp2qQ+G0/n/hBAMGU75gQNGd/5altLc4qZ+IiNSSjM37AedOfmpkIhGh24P2OxAaQmpkon8pQMbm/cQPPHGBH+9uHjxBoMulQICIiIjUqaoGAz4EngAmG2NeB+YCn5V2p98YEwtcDvwSuAD4DvhbFcdQIdbaYTV06H2Fz+VdJvA/oD8QDwSs+TfGhAJnAl5ga3UNUEREyudortf/tQk7VGbf4u3F9xMRERGpz6oUDLDW/tIYMx14BPh14aPAGPMNsBs4BETgZN0/G2iLM/3dA/wZeLIBZcq/sPC5vBfv/wVuAa4AXjupbTDQFPi4Ab0/IiJ1a+MiiB8BZU7f90HWYppF9PTvZvNbl3nY4u3NIpSXV0RERE4P1VFacDUw3BhzFvArYBjQG/jJSV33AfOBN4E3rbX5VT13bTPGJAJfWGvzTto+FLi78NuXT2prCXQEvrfW7i7WNA+YBtxkjHmm8H3EGBMBPFTY57nqfxUiIo3QskchfSqeuFGMPzaWzOzDJbokxrRietRM3FvmcU3/u5nC+Rh8pOZkkuYtKJEzACDaW0BKTiaT6I3FxcDubWvhxYiIiIhUXbXdwrDWbgImAhhjmgKdcWYE5AB7T7oQPl1NA84tLCO4o3DbecDQwq//Yq1dedI+1wOzgBeBMUUbrbU/GGNScIICy40xc4CDwDU4syjmAa/XzMsQEWlENi6C9KmAU8pvpHcfq0gJyPRv8DFyxzTchSX/olc/yV0dHiBmfzrJISvo5QlnnLtdQEAg2lvADM8+EkJ2EmadKgFB8wOIiIiI1EM1Mp/RWnsc2FT4aEj+g3Nxfz4wAgjDWfIwF5hhrV1Rxr4lWGsXGGOScJZMjMRZUrEZ+D9gurX2lJUERETkFOJH4IkbhXvLPACSQ9PJNz5SIxMxYYew+a1JzckkOeTEr3BP7EhG8zXuw05wICEvj5Ts2IB9UnIySQjZ6T9mUlQ7p0qAS1V7RUREpP7T4sYKsNb+G/h3BfeZDcwuoz0DuLJKAxMRkdK5XIw/NpaR3n0kh6azPjycNPfWgAoBad4CennCScjLY643ie0He3LP4ROFbuZ6k5zygfknLvQn0Zsw6yK5cDaBe8s8lQsUERGR04ZuX4iISIOW5TlCZvZhJnhTeKXg4hLT/cEpETjO3Y5XCi5mgjeFf+w5hwP9nVQwnrhRzO8yIWBZAThlB+d3mYAnbpSzIWmiAgEiIiJy2tDMABERadAyNu8HnIv31MjEgBkBxR0IDSE1MtF/9/+d1qO57abzccePYE6ZFQgu0owAEREROe0oGCAiIg3a0Vyv/2sTdqjMvsXbj+Z6Ay7w493NgycIdLkUCBAREZHTjpYJiIhIg9Ys4kTc2+a3LrNv8fbi+4mIiIg0NAoGiIjI6WXjIvD5ACcfwKyMbTyzdBOzMraR5Tni9PH5nH7AwO5tAad8YGpOJtHegqCHjfYWkJqTicEXsJ+IiIhIQ1Qrtz2MManAS9barbVxPhERaaCWPQrpU/HEjWL8sbFkZh8u0SUxphXTo2Y62f2TJhJ/yX0kxrRi5I5pJIesoJcnvEQSwWhvATM8+0gI2UmYdRIDBl0SICIiItJA1NYcyAeAFGNMkrV2c9FGY0wTYIC1dlktjUNERE5XGxdB+lTAKeM30ruPVaQEZPk3+Bi5YxruwnJ/pE+FDglMj1rg35aQl0dKdiypkYmYsEPY/Nak5GSSELITgOTQdJKi2jmJAV2aQCciIiINU20uiHwVWGaMGWKt3VK4rRXwERBS6l4iIiIA8SPwxI1y7vjjXLTnG1/ARX1qTibJISv8u3jiRuHG+PcBmOtNYpI3xV81AGASvQmzLpILAwbuLfNUIUBEREQatNq65WGBvwEzgOXGmDOLtZlaGoOIiJzOXC7GHxvLXG8SAOvDw0mL2UpE57k0ab+EiM5zSYvZyvrwcMC56P/9sbFwzk8haSLgBAfmd5kQMJsAnLKD87tMwBM3ytmQNFGBABEREWnQajVVsrV2mjHGhRMQSAJycAIFIiIiZcryHCEz+zCrSCHf+Ehzbw1Y9w9wIDSEce52pGTHOnf/sw+T5TlC/CX3QcfzcMePYI7LRZbnCBmb93M010uziFAGdm/r5AjwXaQZASIiItIo1FYwwH/331r7aFFAALipls4vIiKnuYzN+wHnLn5qZCIRoduD9jsQGkJqZKJ/GUDG5v3OhX6xC/x4d/PgCQJdLgUCREREpFGorWDABOBY0TfW2ocLAwLv1tL5RUTkNHc01+v/2oQdKrNv8fbi+4mIiIiIo8o5A4wx9xtjepTVx1r7N2vtsZO2PQg8BRyp6hhERKThaxZxIn5t81uX2bd4e/H9RERERMRRHQkEHwKSi28wxkSWZ0dr7cPW2lbVMAYRETkdbVwEPh/g5ASYlbGNZ5ZuYlbGNrI8hbFinw82LmJg97aAUz4wNSeTaG9B0ENGewtIzcnE4By3aD8REREROaGmbpfca4z5rbW2/ckNxpgOwJGTZwqIiEgjs+xRSJ+KJ24U44+NJTP7cIkuiTGtmB41E/eWecQnTSQxZjAjd0wjOWQFvTzhjHO3C0giGO0tYIZnHwkhOwmzToWAoLkBRERERBq5mpw7GV3K9juASUBYDZ5bRETqs42LIH0qAO4t8xjp3ccqUgJK/hl8jNwxDXdourMhfSovdPiYVqErAUjIyyMlO5bUyERM2CFsfmtScjJJCNkJQHJoOklR7ZwKAa7aqqQrIiIicnqoq4WU+qtMRKQxix+BJ24U7i3zAOfCPd/4Ai7sU3MySQ5Z4d/lcIcBtNqz0v/9XG+SUz4w/8R/KZPoTZh1kVwYQHBvmadSgSIiIiJB6KJcRERqn8vF+GNjmetNAmB9eDhpMVuJ6DyXJu2XENF5LmkxW1kfHg44F/53MgmSJgLgiRvF/C4TAmYSgFN2cH6XCXjiRjkbkiYqECAiIiIShFIsi4hIrcvyHCEz+zCrSCHf+Ehzbw1Y+w9wIDSEce52pGTHOjMAsg+Tdf044juehzt+BHNcLrI8R8jYvJ+juV6aRYQysHtbJ0eA7yLNCBAREREpQ3UFA2w1HUdERBqBjM37AedOfmpkIhGh24P2OxAaQmpkon8pQMbm/cQPPHGBH+9uHjxBoMulQICIiIhIGaorGDDJGHMt8Hnh44xqOq6IiDRAR3O9/q9N2KEy+xZvL76fiIiIiFRedQQDlgJ9gL6Fj18XNRhj0oEviz3+XzWcT0RETnPNIk7892PzW5fZt3h78f1EREREpPKq/FeVtfYyAGNMLNC/2KMPcHHho2gZgQ84WtVziohIPbRxEcSPgDLX8vsgazEDuw8GnPKBqTmZpHkLSuQMAIj2FpCSk8kkemNxMbB729p+VSIiIiINUrXdYrHWbgW2AnOLthlj4gkMEPQGWqIcAyIiDcuyRyF9Kp64UYw/NpbM7MMluiTGtGJ61EzcW+YRnzSRxJjBjNwxjeSQFfTyhDPO3S4gIBDtLWCGZx8JITsJs06VgKD5AURERESkwmp0vqW1NgvIAl4FMMYY4BygX02eV0REatHGRZA+FQD3lnmM9O5jFSkBZf8MPkbumIY7NN3ZkD6VFzp8TKvQlQAk5OWRkh1LamQiJuwQNr81KTmZJITsBCA5NJ2kqHZOlQCXquKKiIiIVFWtLr601lpgQ+FDREQagvgReOJG4d4yD3Au3PONL+DCPjUnk+SQFf5dDncYQKs9K/3fz/UmOeUD809c6E+iN2HWRXJhAMG9ZZ7KBYqIiIhUE91eERGRqnG5GH9sLHO9SQCsDw8nLWYrEZ3n0qT9EiI6zyUtZivrw8MB58L/TiZB0kQAPHGjmN9lQsBMAnDKDs7vMgFP3ChnQ9JEBQJEREREqonSMouISJVkeY6QmX2YVaSQb3ykubeWSAZ4IDSEce52pGTHOjMAsg+Tdf044juehzt+BHPKTDp4kWYEiIiIiFQzBQNERKRKMjbvB5w7+amRiUSEbg/a70BoCKmRif6lABmb9xM/8MQFfry7efAEgS6XAgEiIiIi1UzLBEREpEqO5nr9X5uwQ2X2Ld5efD8RERERqV0KBoiISJU0izgxyczmty6zb/H24vuJiIiISO1SMEBERErauAh8PsDJCTArYxvPLN3ErIxtZHmOOH18Pti4iIHd2wJO+cDUnEyivQVBDxntLSA1JxODc9yi/URERESk9um2jIiIBFr2KKRPxRM3ivHHxpKZfbhEl8SYVkyPmol7yzzikyaSGDOYkTumkRyygl6ecMa52wUkEYz2FjDDs4+EkJ2EWadKQND8ACIiIiJSKxQMEBGREzYugvSpALi3zGOkdx+rSAko+2fwMXLHNNyh6c6G9Km80OFjWoWuBCAhL4+U7FhSIxMxYYew+a1JyckkIWQnAMmh6SRFtXOqBLg0QU1ERESkLigYICIiJ8SPwBM3CveWeYBz4Z5vfAEX9qk5mSSHrPDvcrjDAFrtWen/fq43ySkfmH/iQn8SvQmzLpILAwjuLfNULlBERESkDumWjIiInOByMf7YWOZ6kwBYHx5OWsxWIjrPpUn7JUR0nktazFbWh4cDzoX/nUyCpIkAeOJGMb/LhICZBOCUHZzfZQKeuFHOhqSJCgSIiIiI1CHNDBAREb8szxEysw+zihTyjY8099aAtf8AB0JDGOduR0p2rDMDIPswWdePI77jebjjRzDH5SLLc4SMzfs5muulWUQoA7u3dXIE+C7SjAARERGRekDBABER8cvYvB9w7uSnRiYSEbo9aL8DoSGkRib6lwJkbN5P/MATF/jx7ubBEwS6XAoEiIiIiNQDWiYgIiJ+R3O9/q9N2KEy+xZvL76fiIiIiNR/CgaIiIhfs4gTE8Zsfusy+xZvL76fiIiIiNR/CgaIiDR0GxeBzwc4OQFmZWzjmaWbmJWxjSzPEaePzwcbFzGwe1vAKR+YmpNJtLcg6CGjvQWk5mRicI5btJ+IiIiInB50K0dEpCFb9iikT8UTN4rxx8aSmX24RJfEmFZMj5qJe8s84pMmkhgzmJE7ppEcsoJennDGudsFJBGM9hYww7OPhJCdhFmnSkDQ/AAiIiIiUm8pGCAi0lBtXATpUwFwb5nHSO8+VpESUPbP4GPkjmm4Q9OdDelTeaHDx7QKXQlAQl4eKdn/v737D48ruwv7/z6jkSJV9saOrEw2a4iwjLIlSuwSiPCarpKloYilbWIJkRZCEhNB+o3jBEKxaU1R29C1S6BhWQqLwmZTCI9rhAjfYhaSLhutcUAm2Qa6Ia5iObPBzmZiO1awFTnSSKd/3NFoJEuyZcv6Ne/X89znju45586d1Vl57ueecz7b6K5pIVReJo5vpmt0gOaK8wB0pvtpra1PsgSkHGwmSZK0VhgMkKT1qqmNXGMHmaFeILlxHw+TM27su0cH6Kw4UWwy/JL72PTlTxZ/PpZvTdIHjk/f6B9iJ5UxRWchgJAZ6jVdoCRJ0hrjYxxJWq9SKfaP7OVYvhWAZ6uq6Gk4S/U9x3jBiz9O9T3H6Gk4y7NVVUBy4/8ODkHrQQByjR30bT0wYyQBJGkH+7YeINfYkRxoPWggQJIkaY1xZIAkrVODuSsMZIc5RRfjYZKezNkZc/8BLqUr2Jeppyu7LRkBkB1m8I37aLr7VWSa2jiaSjGYu8LJMxe5ei3Phuo0u7dvSdYImNzliABJkqQ1ymCAJK1TJ89cBJIn+d01LVSnn5uz3qV0Bd01LcWpACfPXKRp9/QNflNm49wLBKZSBgIkSZLWKKcJLEII4fEQQrzB9uRNnqvhBuc5eqc/j6T17eq1fPF1qLy8YN3S8tJ2kiRJWp8cGbA4HwWy85S9GdgGPLHIc/514byzPbvI80jSDBuqp//Ex/HNC9YtLS9tJ0mSpPXJb3yLEGP8KHPcuIcQNgE/A4wBjy/ytJ+JMXbf3pVJ0vV2b98CJOkDu0cH6MlPXLdmAEBdfoKu0QEOsZNIqthOkiRJ65fBgKXxZqAGOBpjvLjSFyNpHTt9HJraYMGF/SZh8Ama7n2QloZNtJ87QmfFCXbkqtiXqZ8REKjLT/BI7gLNFeepjEmWgDnXB5AkSdK6YjBgaXQV9r95C21fGkL4CaAOuAT8RYzxb5bsyiStH089BP2HyTV2sH9kLwPZ4euqtDRs4uHax8gM9cL9B3i4dohMuh+A5rExurLb6K5pIVReJo5vpmt0gOaK8wB0pvtpra1PsgSkXFJGkiRpPTMYcJtCCLuAVwKDMcanbuEUry9spef8BPCWGOMXb/IaPj1P0b23cD2SVqPTx6H/MACZoV7a8xc4RRexZB3YwCTt544Ub/55+giZklMcy7cm6QPHp9scYieVMUVnoU1mqNd0gZIkSWXARz+378cL+55Ftvs68J+AVwObC1sr8BTwWuDJEELtEl2jpLWuqY1cY0fxx850P++rfJTKu56hqu5JKu96hvdVPlq8qQeS+vcfKL7u23pgRvAAkrSDfVsPTJ+79aCBAEmSpDJQdiMDQghZ4GWLaPKRGOOPzHOuFwKd3MLCgTHGrwD/ftbhp0MI3wv8OdACvB34lZs416vnub5PA9++mOuStEqlUuwf2Ut7/gKd6X6eraqiJ3OW6vRzxSo9+Ql25KpoHhvjWL6VvpG9HH1gN7x0B5mmNo4uuM7ALkcESJIklZGyCwYAQ8C1RdT/0gJlPwL8A5Zw4cAYYz6E8EGSYMD93EQwQNL6N5i7wkB2mFN0MR4m6cmcvS4zwKV0Bfsy9XRltyXTAbLDDOau0FRyg9+U2Tj3AoGplIEASZKkMlJ2wYAY4/cs4emmFg58dAnPCXChsHeagCQATp5J4o2RFN01LTNGBJS6lK6gu6aluC7AyTMXzQ4gSZKk67hmwC0KIbQAO0gWDvzEEp/+uwr7s0t8Xklr1NVr+eLrUHl5wbql5aXtJEmSpCkGA27d1MKBC6YTDCG8MIRwbwjh7lnHW0IIVXPUfwD4ycKPv7MkVyppzdtQPT2QK45vXrBuaXlpO0mSJGmK3xJvQQjhLuCHSBYO/PANqr8R+FCh3ltLjh8BXlFII3iucOxVwAOF1z8XY/zkEl2ypNXo9HFoaoMFF/abhMEn2L39fiBJH9g9OkBPfuK6NQMA6vITdI0OcIidRFLs3r5luT+VJEmS1gCDAbfmh0nm89/OwoG/TRIo+E6gDagEcsAx4JEY44mluFBJq9RTD0H/YXKNHewf2ctAdvi6Ki0Nm3i49jEyQ700tR6kpeF+2s8dobPiBDtyVezL1M8ICNTlJ3gkd4HmivNUxiRloOsFSJIkaS4GA25BjPHXgV+/ybqPM0fawRjjbwG/taQXJmltOH0c+g8DkBnqpT1/gVN0EUtmbgUmaT93hEy6PznQf5hHX/I0m9LJgKHmsTG6stvormkhVF4mjm+ma3SA5orzAHSm+2mtrU9SBqacESZJkqSZDAZI0nJraiPX2EFmqBdIbtzHw+SMG/vu0QE6K6YHCA2/5D42fXl65tCxfGuSPnB8+kb/EDupjCk6CwGEzFAvDO4xZaAkSZKu4+MiSVpuqRT7R/ZyLN8KwLNVVfQ0nKX6nmO84MUfp/qeY/Q0nOXZqmSN0WP5Vt7BIWg9CECusYO+rQdmjCSAJO1g39YD5Bo7kgOtBw0ESJIkaU6ODJCkZTaYu8JAdphTdDEeJunJnL1uMcBL6Qr2Zerpym5LRgBkhxl84z6a7n4VmaY2ji646OAuRwRIkiRpQQYDJGmZnTyTrDsaSdFd00J1+rk5611KV9Bd01KcCnDyzEWadk/f4DdlNs69QGAqZSBAkiRJC3KagCQts6vX8sXXofLygnVLy0vbSZIkSbfDYIAkLbMN1dODsuL45gXrlpaXtpMkSZJuh8EASVpmu7dvAZL0gd2jA9TlJ+asV5efoHt0gMDkjHaSJEnS7fIxkyQthdPHoakNFlzYbxIGn6Dp3gdpadhE+7kjdFacYEeuin2Z+hmLCNblJ3gkd4HmivNUxiRLwJzrA0iSJEm3wGCAJN2upx6C/sPkGjvYP7KXgezwdVVaGjbxcO1jZIZ64f4DPFw7RCbdD0Dz2Bhd2W1017QQKi8TxzfTNTpAc8V5ADrT/bTW1idZAlIO6JIkSdLtMxggSbfj9HHoPwxAZqiX9vwFTtFFLJmFFZik/dyR4s0/Tx8hU3KKY/nWJH3g+HSbQ+ykMqboLLTJDPWaLlCSJElLxkdMknQ7mtrINXYUf+xM9/O+ykepvOsZquqepPKuZ3hf5aPFm3ogqX//geLrvq0HZgQPIEk72Lf1wPS5Ww8aCJAkSdKScWSAJN2OVIr9I3tpz1+gM93Ps1VV9GTOUp1+rlilJz/BjlwVzWNjHMu30jeyl6MP7IaX7iDT1MbRBdcZ2OWIAEmSJC05gwGSdBsGc1cYyA5zii7GwyQ9mbMzFgIEuJSuYF+mnq7stmQ6QHaYwdwVmkpu8JsyG+deIDCVMhAgSZKkJec0AUm6DSfPXASSYf3dNS3XBQKmXEpX0F3TUpwOMNVOkiRJWgkGAyTpNly9li++DpWXF6xbWl7aTpIkSVpuBgMk6TZsqJ6ebRXHNy9Yt7S8tJ0kSZK03AwGSNJsp4/D5CSQrAnwoZNf4Fef/DwfOvkFBnNXkjqTk3D6OLu3bwGS9IHdowPU5SfmPGVdfoLu0QECyXmn2kmSJEkrwUdTklTqqYeg/zC5xg72j+xlIDt8XZWWhk08XPsYmaFemloP0tJwP+3njtBZcYIduSr2ZepnrB1Ql5/gkdwFmivOUxmTlIFzLhYoSZIkLRODAZI05fRx6D8MQGaol/b8BU7RVVz0D5IRAO3njpBJ9ycH+g/z6EueZlP6kwA0j43Rld1Gd00LofIycXwzXaMDNFecB6Az3U9rbX2SMjDl4CxJkiStDIMBkjSlqY1cYweZoV4guXEfD5Mzbuy7RwforDhRbDL8kvvY9OVPFn8+lm9N0geOT9/oH2InlTFFZyGAkBnqhcE9pgyUJEnSivGxlCRNSaXYP7KXY/lWAJ6tqqKn4SzV9xzjBS/+ONX3HKOn4SzPVlUByY3/OzgErQcByDV20Lf1wIyRBJCkHezbeoBcY0dyoPWggQBJkiStKEcGSFLBYO4KA9lhTtHFeJikJ3N2xtx/gEvpCvZl6unKbktGAGSHGXzjPprufhWZpjaOplIM5q5w8sxFrl7Ls6E6ze7tW5I1AiZ3OSJAkiRJq4LBAEkqOHnmIpA8ye+uaaE6/dyc9S6lK+iuaSlOBTh55iJNu6dv8JsyG+deIDCVMhAgSZKkVcFpApJUcPVavvg6VF5esG5peWk7SZIkaS0wGCBJBRuqpwdLxfHNC9YtLS9tJ0mSJK0FBgMkqWD39i1Akj6we3SAuvzEnPXq8hN0jw4QmJzRTpIkSVorfJwlaX07fRya2mDBhf0mYfAJmu59kJaGTbSfO0JnxQl25KrYl6mfsYhgXX6CR3IXaK44T2VMsgTMuT6AJEmStIoZDJC0fj31EPQfJtfYwf6RvQxkh6+r0tKwiYdrHyMz1Av3H+Dh2iEy6X4AmsfG6Mpuo7umhVB5mTi+ma7RAZorzgPQme6ntbY+yRKQcqCVJEmS1g6DAZLWp9PHof8wAJmhXtrzFzhFF7FkdlRgkvZzR4o3/zx9hEzJKY7lW5P0gePTbQ6xk8qYorPQJjPUa7pASZIkrTk+ypK0PjW1kWvsKP7Yme7nfZWPUnnXM1TVPUnlXc/wvspHizf1QFL//gPF131bD8wIHkCSdrBv64Hpc7ceNBAgSZKkNceRAZLWp1SK/SN7ac9foDPdz7NVVfRkzlKdfq5YpSc/wY5cFc1jYxzLt9I3spejD+yGl+4g09TG0QXXGdjliABJkiStWQYDJK1Lg7krDGSHOUUX42GSnszZGQsBAlxKV7AvU09XdlsyHSA7zGDuCk0lN/hNmY1zLxCYShkIkCRJ0prlNAFJ69LJMxeBZFh/d03LdYGAKZfSFXTXtBSnA0y1kyRJktYzgwGS1qWr1/LF16Hy8oJ1S8tL20mSJEnrlcEASevShurpWVBxfPOCdUvLS9tJkiRJ65XBAEnr0u7tW4AkfWD36AB1+Yk569XlJ+geHSAwOaOdJEmStJ75CEzSutSU2UhLwybazx2hs+IEO3JV7MvUz1g7oC4/wSO5CzRXnKcyJikD51wsUJIkSVpnDAZIWjtOH4emNlgw5d8kDD4BTW08XPsYmXQ/AM1jY3Rlt9Fd00KovEwc30zX6ADNFecB6Ez301pbn6QMTDloSpIkSeubwQBJa8NTD0H/YXKNHewf2ctAdvi6Ki0Nm5IAwFAvvGIPmaG+YtmxfGuSPnB8+kb/EDupjCk6CwGDzFAvDO4xZaAkSZLWPR9/SVr9Th+H/sNAcsPefu5IcY7/lMAk7eeOJDf0AJ/tg1fsASDX2EHf1gPF9IFTIsnUgFxjR3Kg9aCBAEmSJJUFRwZIWv2a2sg1dhRv9DvT/YyHyRlD/rtHB+isOFFskmvsINPeA6/sINPUxtEFpxbsckSAJEmSyorBAEmrXyrF/pG9tOcv0Jnu59mqKnoyZ6lOP1es0pOfYEeuiuaxMY7lW+kb2cvRVGrGDX5TZuPcCwTOqidJkiStdwYDJK16g7krDGSHOUUX42GSnszZGVkBAC6lK9iXqacruy1ZGyA7zGDuitkBJEmSpDm4ZoCkVe/kmYtAMse/u6blukDAlEvpCrprWoprA0y1kyRJkjSTwQBJq97Va/ni61B5ecG6peWl7SRJkiRNMxggadXbUD09oymOb16wbml5aTtJkiRJ0wwGSFr1dm/fAiTpA7tHB6jLT8xZry4/QffoQDHt4FQ7SZIkSTP52EzSqteU2UhLwybazx2hs+IEO3JV7MvUz1g7oC4/wSO5CzRXnKcypujbesDFAyVJkqR5lO3IgBBCZQjh3SGED4UQPhNCGAshxBDC22+i7VtCCKdCCFdDCF8LIXwihPADt3gdS3Yuac04fRwmk6f3g7krfOjkF/jVJz/Ph05+gcHclaTO5GRSr/D64drH6Ez3A9A8NkZXdhvXznfyja+8nmvnO+nKbqN5bAyAznQ/v1L7WPE9JEmSJM1UziMDaoEPFF7ngC8D33SjRiGE9wPvBc4BPUAV8Cbgf4YQ3hVjfORmL2ApzyWtGU89BP2HyTV2sH9kLwPZ4euqtDRs4uHax8gM9ULrQbj7VcnrgmP51iR94Ph0PPMQO6mMqWLAIDPUC4N74N4H7/hHkiRJktaash0ZAHwd+H7gpTHGlwCP3ahBCOE+kpv3IeBVMcafjDG+E3g18FXg/SGEhpt586U8l7RmnD4O/YeB5Ga9/dyR4vz+KYFJ2s8dmb75L9Sn9SAAucYO+rYeKKYPnBJJpgbkGjum6xsIkCRJkuZUtiMDYoxjwBOLbPaOwv4XYozF/GUxxmwI4deAnwPeBvz8Mp9LWhua2sg1dhRv9DvT/YyHSbprWgiVl4njm+keHaCz4kSxSa6xg0xTW3Jjf/eryDS1cTSVYjB3hZNnLnL1Wp4N1Wl2b9+SrBEwucsRAZIkSdINlG0w4BY9UNj/yRxlT5DcwD/Azd3AL+W5pLUhlWL/yF7a8xfoTPfzbFUVPZmzVKefK1bpyU+wI1dF89gYx/Kt9I3s5WiqMAqg5Aa/KbNx7gUCUykDAZIkSdINGAy4SSGEWuAe4GqM8fk5qny+sG9aznMVzvfpeYruvZn20nIZzF1hIDvMKboYD5P0ZM7OyAgAcCldwb5MPV3Zbcm6ANlhBnNXzAwgSZIkLaFyXjNgsV5Y2H9tnvKp45uW+VzSmnHyzEUgmd/fXdNyXSBgyqV0Bd01LcV1AabaSZIkSVoaa3pkQAghC7xsEU0+EmP8kTt0OVPicp8rxvjquY4XRgx8+xJej3Rbrl7LF1+HyssL1JxZXtpOkiRJ0u1b08EAkpX4ry2i/pdu472mnta/cJ7yGz3tv1PnktaMDdXTf3Li+OYF65aWl7aTJEmSdPvW9DfsGOP3LON7jYQQzgP3hBDunmOu/7cW9oPLeS5pLdm9fQuQpA/sHh2gJz8x51SBuvwEXaMDHGInkVSxnSRJkqSl4ZoBi/Nnhf33zVHWNqvOcp5LWjmnj8PkJJAsEPihk1/gV5/8PB86+QUGc1eSOpOTcPo4TZmNtDRs4ki6hx+uOMEjuQvU5SdmnK4uP8EjuQv8cMUJjqR7+K6GTS4eKEmSJC2xNT0yYAX8BvBm4N+FED4aY7wMEEJoAN4JfAP4UGmDEMLdJMP+n48xfu12ziWtOk89BP2HyTV2sH9kLwPZ4euqtDRs4uHax8gM9cL9B3i4dohMuh+A5rExurLb6K5pIVReJo5vpmt0gOaK8wB0pvtpra2HyV1JykBJkiRJS6KsgwEhhINMp9/bWdi/LYTw3YXXfx5j/OBU/RjjJ0MIvwz8FPA3IYReoAr4IeBFwLtijNlZb/MQ8BbgbcDjt3kuafU4fRz6DwOQGeqlPX+BU3QVMwBAMh2g/dyR4s0/Tx8hU3KKY/nWJH3g+HSbQ+ykMqboLLTJDPXC4B6498E7/pEkSZKkclHWwQCSIfqts47dV9imfLC0MMb43hDC3wD7gB8HJoFngF+MMf7RYt58Kc8lLbumNnKNHcnNOslT/PEwOeMpf/foAJ0VJ4pNco0dZO5phKePkGvsoG9kL3HWaIJIir6tB2itrU/O3XrQQIAkSZK0xMo6GBBjfO0ttvsw8OGbrPtW4K1LcS5pVUml2D+yl/b8BTrT/TxbVUVP5izV6eeKVXryE+zIVdE8NsaxfCt9I3s5+sBueOkOMk1tHE2lGMxd4eSZi1y9lmdDdZrd27ckawRM7nJEgCRJknSHlHUwQNKtG8xdYSA7zCm6GA+T9GTOXpcZ4FK6gn2Zerqy25LpANlhBnNXaCq5wW/KbJx7gcBUykCAJEmSdIe4IpekW3LyzEUgGdbfXdMyZ4pASAIC3TUtxbUEptpJkiRJWjkGAyTdkqvX8sXXofLygnVLy0vbSZIkSVoZBgMk3ZIN1dOzjOL45gXrlpaXtpMkSZK0MgwGSLolu7dvAZL0gd2jA9TlJ+asV5efoHt0gMDkjHaSJEmSVo6P6CTdkqbMRloaNtF+7gidFSfYkatiX6Z+xtoBdfkJHsldoLniPJUxSRk452KBkiRJkpaVwQBJ004fh6Y2WDDl3yQMPgFNbTxc+xiZdD8AzWNjdGW30V3TQqi8TBzfTNfoAM0V5wHoTPfTWlufpAxMOShJkiRJWkkGAyQlnnoI+g+Ta+xg/8heBrLD11VpadiUBACGeuEVe8gM9RXLjuVbk/SB49M3+ofYSWVM0VkIGGSGemFwjykDJUmSpBXm4zlJyYiA/sNAcsPefu5IcY7/lMAk7eeOJDf0AJ/tg1fsASDX2EHf1gPF9IFTIsnUgFxjR3Kg9aCBAEmSJGkVcGSAJGhqI9fYUbzR70z3Mx4mZwz57x4doLPiRLFJrrGDTHsPvLKDTFMbRxecWrDLEQGSJEnSKmIwQBKkUuwf2Ut7/gKd6X6eraqiJ3OW6vRzxSo9+Ql25KpoHhvjWL6VvpG9HE2lZtzgN2U2zr1A4Kx6kiRJklaWwQBJDOauMJAd5hRdjIdJejJnZ2QFALiUrmBfpp6u7LZkbYDsMIO5K2YHkCRJktYg1wyQxMkzF4Fkjn93Tct1gYApl9IVdNe0FNcGmGonSZIkaW0xGCCJq9fyxdeh8vKCdUvLS9tJkiRJWjsMBkhiQ/X0jKE4vnnBuqXlpe0kSZIkrR0GAySxe/sWIEkf2D06QF1+Ys56dfkJukcHimkHp9pJkiRJWlt8rCetV6ePQ1MbLJjybxIGn6Dp3gdpadhE+7kjdFacYEeuin2Z+hlrB9TlJ3gkd4HmivNUxhR9Ww+4eKAkSZK0RhkMkNajpx6C/sPkGjvYP7KXgezwdVVaGjbxcO1jZIZ64f4DPFw7RCbdD0Dz2Bhd2W1017QQKi8TxzfTNTpAc8V5ADrT/bTW1sPkriRtoCRJkqQ1xWCAtN6cPg79hwHIDPXSnr/AKbqKGQAgmQ7Qfu5I8eafp4+QKTnFsXxrkj5wfLrNIXZSGVN0FtpkhnphcA/c++Ad/0iSJEmSlpaP9KT1pqmNXGNH8cfOdD/vq3yUyrueoaruSSrveob3VT5avKkHkvr3Hyi+7tt6YEbwAJK0g31bD0yfu/WggQBJkiRpjXJkgLTepFLsH9lLe/4Cnel+nq2qoidzlur0c8UqPfkJduSqaB4b41i+lb6RvRx9YDe8dAeZpjaOLrjOwC5HBEiSJElrnMEAaZ0ZzF1hIDvMKboYD5P0ZM7OWAgQ4FK6gn2Zerqy25LpANlhBnNXaCq5wW/KbJx7gcBUykCAJEmStMY5TUBaZ06euQgkw/q7a1quCwRMuZSuoLumpTgdYKqdJEmSpPXPYIC0zly9li++DpWXF6xbWl7aTpIkSdL6ZjBAWmc2VE/P/onjmxesW1pe2k6SJEnS+mYwQFpndm/fAiTpA7tHB6jLT8xZry4/QffoAIHJGe0kSZIkrX8+CpTWmabMRloaNtF+7gidFSfYkatiX6Z+xtoBdfkJHsldoLniPJUxSRk452KBkiRJktYlgwHSWnD6ODS1wYIp/yZh8AloauPh2sfIpPsBaB4boyu7je6aFkLlZeL4ZrpGB2iuOA9AZ7qf1tr6JGVgysFCkiRJUjkwGCCtdk89BP2HyTV2sH9kLwPZ4euqtDRsSgIAQ73wij1khvqKZcfyrUn6wPHpG/1D7KQypugsBAwyQ70wuMeUgZIkSVKZ8DGgtJqdPg79h4Hkhr393JHiHP8pgUnazx1JbugBPtsHr9gDQK6xg76tB4rpA6dEkqkBucaO5EDrQQMBkiRJUhlxZIC0mjW1kWvsKN7od6b7GQ+TM4b8d48O0Flxotgk19hBpr0HXtlBpqmNowtOLdjliABJkiSpDBkMkFazVIr9I3tpz1+gM93Ps1VV9GTOUp1+rlilJz/BjlwVzWNjHMu30jeyl6Op1Iwb/KbMxrkXCJxVT5IkSVJ5MBggrWKDuSsMZIc5RRfjYZKezNkZWQEALqUr2Jeppyu7LVkbIDvMYO6K2QEkSZIkzcs1A6RV7OSZi0Ayx7+7puW6QMCUS+kKumtaimsDTLWTJEmSpLkYDJBWsavX8sXXofLygnVLy0vbSZIkSdJsBgOkVWxD9fRMnji+ecG6peWl7SRJkiRpNoMB0iq2e/sWIEkf2D06QF1+Ys56dfkJukcHimkHp9pJkiRJ0lx8fCitYk2ZjbQ0bKL93BE6K06wI1fFvkz9jLUD6vITPJK7QHPFeSpjir6tB1w8UJIkSdKCDAZIq9nkJA/XPkYm3Q9A89gYXdltdNe0ECovE8c30zU6QHPFeQA60/201tbD5K4kbaAkSZIkzcFggLTcTh+HpjZIpRjMXeHkmYtcvZZnQ3Wa3du3JE/1Jydh8AkAMkO9xabH8q1J+sDx6Rv9Q+ykMqboLAQMMkO9MLgH7n1weT+XJEmSpDXDYIC0nJ56CPoPk2vsYP/IXgayw9dVaWnYlIwGGOqF1oPJVmjTN7KXOKtNJJka0FpbP93GQIAkSZKkBRgMkJbL6ePQfxhInt635y9wii5iyTqegUnazx0pTgug/zC86XfhTb9LpqmNowuOJtjliABJkiRJN8VggLRcmtrINXYUh/13pvsZD5Mz5v93jw7QWXGi2CTX2EGmMKWgeJrMxrkXCEylDARIkiRJuikGA6Tlkkqxf2Qv7fkLdKb7ebaqip7MWarTzxWr9OQn2JGronlsjGP5VvpG9nLUhQAlSZIkLTGDAdIyGcxdYSA7zCm6GA+T9GTOzkgRCHApXcG+TD1d2W3JQoHZYQZzV0wVKEmSJGlJ+chRWiYnz1wEkgX/umtargsETLmUrqC7pqW4lsBUO0mSJElaKgYDpGVy9Vq++DpUXl6wbml5aTtJkiRJWgplGwwIIVSGEN4dQvhQCOEzIYSxEEIMIbx9gTa7Qwj/JYTwVyGECyGEb4QQvhBC+GAIYfsi3/+thfebb3vH7X9KrSYbqqdn5cTxzQvWLS0vbSdJkiRJS6Gc7zJqgQ8UXueALwPfdIM2vw/UA58EPgLkgV3AjwFvCiG8Psb4F4u8jj8EPjPH8U8t8jxa5XZv3wIk6QO7RwfoyU/MOVWgLj9B1+gAh9hJJFVsJ0mSJElLpZyDAV8Hvh/4TIzx+RBCN/DzN2jzX4HfjjF+qfRgCOHfAr8A/CbwykVex0djjI8vso3WoKbMRloaNtF+7gidFSfYkatiX6Z+RkCgLj/BI7kLNFecpzKm6Nt6wMUDJUmSJC25sg0GxBjHgCcW2ebIPEVHgENAcwihLsZ46XavT2vE6ePQ1AapFIO5K5w8c5Gr1/JsqE6ze/uW5EZ+chIGn4CmNh6ufYxMuh+A5rExurLb6K5pIVReJo5vpmt0gOaK8wB0pvtpra2HyV1gekFJkiRJS6hsgwFLLJJMGQCYWGTbnSGE9wDVwHngqRjjuSW8Nt0pTz0E/YfJNXawf2QvA9nh66q0NGxKAgBDvfCKPWSG+oplx/KtSfrA8ekb/UPspDKm6CwEDDJDvTC4B+598I5/HEmSJEnlw2DA0vhBYCPwlzHG4UW2ffesnydCCB8E3hNjvHYzJwghfHqeonsXeS26WaePQ/9hILlhb89f4BRdxXSAkKwN0H7uSHEkAJ/tg1fsgc/2kWvsoG9kL3FWACGSTA1ora1PAgGtBw0ESJIkSVpyBgNuUwjhW4BfJRkZ8N5FNP0C8C7gY8A54IXAdwMPAT8B3AX8qyW9WC2dpjZyjR3JDTvJkP7xMDljyH/36ACdFSeKTXKNHWTae+CVHWSa2ji64NSCXY4IkCRJknTHrOlgQAghC7xsEU0+EmP8kSV8/xeTrDtQD7wzxvjJm20bY+wH+ksOfR34vRDCXwJ/DfzLEMKRGONf38S5Xj3P9X0a+PabvSYtQirF/pG9tOcv0Jnu59mqKnoyZ6lOP1es0pOfYEeuiuaxMY7lW+kb2cvRVGrGDX5TZuPcCwTOqidJkiRJS2lNBwOAIeCmhtIXfOnGVW5OIRDwZ8DLgXfHGP/bUpw3xvh3IYQ/Bn4YuJ8kMKBVZjB3hYHsMKfoYjxM0pM5e12awEvpCvZl6unKbkvWBsgOM5i7YnYASZIkSStuTQcDYozfsxLvG0K4G3iSZE7+O5cqEFDiQmFfu8Tn1RI5eeYikMzx765pmTEioNSldAXdNS3FRQJPnrloMECSJEnSilvTwYCVEELYSjIiYDvwjhjjb96Bt2kp7M/egXNrCVy9li++DpWXF6xbWl7aTpIkSZJWisnLFyGE8M0k8/wbgR+7mUBACOHuEMK9IYQXzjr+j+eoG0IIPwvsAi4Cf7I0V66ltqF6Oo4WxzcvWLe0vLSdJEmSJK2Usr4zCSEcZDr93s7C/m0hhO8uvP7zGOMHS5r0Aw3Ap4GXhRC65zjt4zHGbMnPDwFvAd4GPF5y/OkQwiDwV8B5kmwCu4FmksUEfzjG+Pe38rl05+3evgVI0gd2jw7Qk5+4bs0AgLr8BF2jAxxiJ5FUsZ0kSZIkraSyDgYA3we0zjp2X2GbUhoMaCjsX13Y5vIJIHsT7/1+4DXAA8CLgEngi8CvAb8cY3SKwCrWlNlIS8Mm2s8dobPiBDtyVezL1M8ICNTlJ3gkd4HmivNUxhR9Ww+4XoAkSZKkVaGsgwExxtcusn64hfd4K/DWOY7/m8WeS3fY6ePQ1AapFIO5K5w8c5Gr1/JsqE6ze/uW5EZ+chIGn4CmNh6ufYxMOskO2Tw2Rld2G901LYTKy8TxzXSNDtBccR6AznQ/rbX1MLkrSRsoSZIkSSuorIMBUtFTD0H/YXKNHewf2ctAdvi6Ki0Nm5IAwFAvvGIPmaG+YtmxfGuSPnB8+kb/EDupjCk6CwGDzFAvDO6Bex+84x9HkiRJkhbiI0rp9HHoPwwkN+zt544QmJxRJTBJ+7kjyQ09wGf74BV7AMg1dtC39QBx1v9OkWRqQK6xIznQetBAgCRJkqRVwZEBUlMbucaO4o1+Z7qf8TA5Y8h/9+gAnRUnik1yjR1k2nvglR1kmto4uuDUgl2OCJAkSZK0qhgMkFIp9o/spT1/gc50P89WVdGTOUt1+rlilZ78BDtyVTSPjXEs30rfyF6OplIzbvCbMhvnXiBwVj1JkiRJWmkGA1T2BnNXGMgOc4ouxsMkPZmz16UJvJSuYF+mnq7stmRtgOwwg7krZgeQJEmStCa5ZoDK3skzF4Fkjn93Tct1gYApl9IVdNe0FNcGmGonSZIkSWuNwQCVvavX8sXXofLygnVLy0vbSZIkSdJaYjBAZW9D9fRsmTi+ecG6peWl7SRJkiRpLTEYoLK3e/sWIEkf2D06QF1+Ys56dfkJukcHimkHp9pJkiRJ0lrjo02VvabMRloaNtF+7gidFSfYkatiX6Z+xtoBdfkJHsldoLniPJUxRd/WAy4eKEmSJGnNMhggTU7ycO1jZNL9ADSPjdGV3UZ3TQuh8jJxfDNdowM0V5wHoDPdT2ttPUzuStIGSpIkSdIaYzBA69Pp49DUBqkUg7krnDxzkavX8myoTrN7+5bkqf7kJAw+AUBmqLfY9Fi+NUkfOD59o3+InVTGFJ2FgEFmqBcG98C9Dy7v55IkSZKkJWAwQOvPUw9B/2FyjR3sH9nLQHb4uiotDZuS0QBDvdB6MNkKbfpG9hJntYkkUwNaa+un2xgIkCRJkrRGGQzQ+nL6OPQfBpKn9+35C5yii1iyVmZgkvZzR4rTAug/DG/6XXjT75JpauPogqMJdjkiQJIkSdKaZzBA60tTG7nGjuKw/850P+Nhcsb8/+7RATorThSb5Bo7yBSmFBRPk9k49wKBqZSBAEmSJElrnsEArS+pFPtH9tKev0Bnup9nq6royZylOv1csUpPfoIduSqax8Y4lm+lb2QvR10IUJIkSVIZMRigdWUwd4WB7DCn6GI8TNKTOTsjRSDApXQF+zL1dGW3JQsFZocZzF0xVaAkSZKksuHjUK0rJ89cBJIF/7prWq4LBEy5lK6gu6aluJbAVDtJkiRJKgcGA7SuXL2WL74OlZcXrFtaXtpOkiRJktY7gwFaVzZUT898ieObF6xbWl7aTpIkSZLWO4MBWld2b98CJOkDu0cHqMtPzFmvLj9B9+gAgckZ7SRJkiSpHPg4VOtKU2YjLQ2baD93hM6KE+zIVbEvUz9j7YC6/ASP5C7QXHGeypiib+sBFw+UJEmSVFYMBmj1O30cmtoglWIwd4WTZy5y9VqeDdVpdm/fktzIT07C4BPQ1MbDtY+RSfcD0Dw2Rld2G901LYTKy8TxzXSNDtBccR6AznQ/rbX1MLkLTC8oSZIkqUwYDNDq9tRD0H+YXGMH+0f2MpAdvq5KS8OmJAAw1Auv2ENmqK9YdizfmqQPHJ++0T/ETipjis5CwCAz1AuDe+DeB+/4x5EkSZKk1cBHoVq9Th+H/sNAcsPefu5IcY7/lMAk7eeOJDf0AJ/tg1fsASDX2EHf1gPF9IFTIsnUgFxjR3Kg9aCBAEmSJEllxZEBWr2a2sg1dhRv9DvT/YyHyRlD/rtHB+isOFFskmvsINPeA6/sINPUxtEFpxbsckSAJEmSpLJkMECrVyrF/pG9tOcv0Jnu59mqKnoyZ6lOP1es0pOfYEeuiuaxMY7lW+kb2cvRVGrGDX5TZuPcCwTOqidJkiRJ5cJggFatwdwVBrLDnKKL8TBJT+bsjKwAAJfSFezL1NOV3ZasDZAdZjB3xewAkiRJkrQAgwFaXovIDHDy0rcByRz/7pqWGSMCSl1KV9Bd01JcJPDkmYsGAyRJkiRpAQYDtHwWmRng2765C3gdAKHy8oKnLi2/ei2/lFctSZIkSeuO2QS0PG4hM0DLF3t4fepTAMTxzQuevrR8Q7UxLkmSJElaiMEALY9CZoApnel+3lf5KJV3PUNV3ZNU3vUM76t8lM50f7HO2a1v4H9NfjuBSbpHB6jLT8x56rr8BN2jA8Xgwu7tW+7sZ5EkSZKkNc5HqFoet5IZIP/jvKYB2s8dobPiBDtyVezL1M9YRLAuP8EjuQs0V5ynMqbo23rA9QIkSZIk6QYMBmhZ3EpmALJf5cntvWwrjBZoHhujK7uN7poWQuVl4vhmukYHaK44DySjDVpr62FyV5I2UJIkSZI0J4MBWhYnz1wEFpcZ4PWpT7Ht3EeLZcfyrUn6wPHpG/1D7KQyporTCzJDvTC4B+598M59GEmSJEla43x8qmVRusL/zWYG+PjkdzDwzV0A5Bo76Nt6gDiry0aSqQHF9QhaDxoIkCRJkqQbcGSAlkXpCv+LyQzwty9/Jy33vY5MUxtHUykGc1c4eeYiV6/l2VCdZvf2LckaAZO7HBEgSZIkSTfJYICWxdQK/1OZAXryE9etGQDJgoBdowMcYieRVNIuM32D35TZOPcCgamUgQBJkiRJukkGA7QsmjIbaWnYZGYASZIkSVoFDAZoeUxO8nDtY2TMDCBJkiRJK85ggJbH4BPJSv8FZgaQJEmSpJXjI1ctj3sfTFb6x8wAkiRJkrTSHBmg5fO6n4W7X2VmAEmSJElaYQYDtLzuNTOAJEmSJK00pwlIkiRJklRmDAZIkiRJklRmDAZIkiRJklRmDAZIkiRJklRmyjYYEEKoDCG8O4TwoRDCZ0IIYyGEGEJ4+wJt3lqoM9/2jlu4jreEEE6FEK6GEL4WQvhECOEHbu/TSZIkSZI0v3LOJlALfKDwOgd8Gfimm2z7h8Bn5jj+qcVcQAjh/cB7gXNAD1AFvAn4nyGEd8UYH1nM+SRJkiRJuhnlHAz4OvD9wGdijM+HELqBn7/Jth+NMT5+O28eQriPJBAwBHxnjPFy4fgvAp8G3h9C+KMYY/Z23keSJEmSpNnKdppAjHEsxvhEjPH5FbqEqSkFvzAVCChcVxb4NeAFwNtW4LokSZIkSetc2QYDbtPOEMJ7QggHQwhvDiFsvYVzPFDY/8kcZU/MqiNJkiRJ0pIp52kCt+Pds36eCCF8EHhPjPHajRqHEGqBe4Cr84xM+Hxh33QzFxNC+PQ8RffeTHtJkiRJUnlxZMDifAF4F/BykgUIXwp0AlngJ4DHbvI8LyzsvzZP+dTxTbdykZIkSZIkLWRNjwwIIWSBly2iyUdijD9yq+8XY+wH+ksOfR34vRDCXwJ/DfzLEMKRGONf3+p7zH7Lm7yuV891vDBi4NuX6FokSZIkSevEmg4GkKzEf8Nh+SW+dCcuIsb4dyGEPwZ+GLifJDCwkKkn/y+cp/xGIwckSZIkSbplazoYEGP8npW+hhIXCvvaG1WMMY6EEM4D94QQ7p5j3YBvLewHl/ICJUmSJEkC1wxYSi2F/dmbrP9nhf33zVHWNquOJEmSJElLZk2PDFhuIYR/HGM8MetYAA4Cu4CLzEoVGEK4m2TY//MxxtJh/78BvBn4dyGEj8YYLxfqNwDvBL4BfOg2L7nhc5/7HK9+9ZxLCkiSJEmS1rDPfe5zAA230jbEeFNr1K1LIYSDTKff2wnsAD7JdGq/P48xfrCkfiQZuv9XwHmSm/zdQDPJYoJvjDF+bNZ7PA68BXhbjPHxWWW/BPwUcA7oBaqAHwLqgHfFGB+5zc/3BeAukmwHq9XUf//TK3oVWg/sS1oq9iUtFfuSlpL9SUvFvrS+NAB/H2P8lsU2LPeRAd8HtM46dl9hm/LBktfvB14DPAC8CJgEvgj8GvDLMcabnSIAQIzxvSGEvwH2AT9eON8zwC/GGP9oMeea5/yL7hDLrZDxYN6MCNLNsi9pqdiXtFTsS1pK9ictFfuSppR1MCDG+NpF1v83t/AebwXeukD5h4EPL/a8kiRJkiTdKhcQlCRJkiSpzBgMkCRJkiSpzBgMkCRJkiSpzBgMkCRJkiSpzJR1akFJkiRJksqRIwMkSZIkSSozBgMkSZIkSSozBgMkSZIkSSozBgMkSZIkSSozBgMkSZIkSSozBgMkSZIkSSozBgMkSZIkSSozBgO0IkIIW0MIj4UQvhRC+EYIIRtC+EAIYfNKX5uWXwihLoTw9hDCH4QQzoQQRkMIXwsh/HkI4cdCCHP+rQoh3BdC+OMQwldDCF8PIfxNCOE9IYSKBd7rLSGEUyGEq4X3+EQI4Qfu3KfTahBCeHMIIRa2t89Tx/6keYUQ/nEI4fdDCM8X/t16PoTwsRDC989R176kOYUQHiz0m3OFf+vOhhB+L4Swa5769qUyFkLoCCH8agjhRAjh7wv/hv3ODdrc8T4TQqgJIfyHEML/DSFcCyF8JYRwLITwD2/n82r5hRjjSl+DykwIoRH4JPBi4A+B08BrgNcB/xfYHWO8tHJXqOUWQngH8OvA88BTwBeBDLAHeCHw+8APxpI/WCGEf1E4fg34H8BXgX8GvBzojTH+4Bzv837gvcA5oBeoAt4EvAh4V4zxkTv0EbWCQgjfBPwfoALYAHTFGD84q479SfMKIRwC/hNwEfgjkr9VW4B/BDwVY/yZkrr2Jc0phHAE+BngEvBRkv60HfjnQBr40Rjj75TUty+VuRDCZ4AdwFWS3+m9wEdijD8yT/073mdCCC8AngR2A58C/gz4JuAHgTHggRjjwO18bi2jGKOb27JuwJ8CkeQPTOnxXy4c/42Vvka3Ze8TD5D8Y5WadfwlJIGBCLSXHL8L+ArwDeA7So5XkwSaIvCmWee6r3D8DLC55HgDyReza0DDSv+3cFvyvhWA/wUMAb9Y6ANvn1XH/uS2UB/6wcLv+uPAxjnKK+1LbjfRj14CTABfBl48q+x1hT5w1r7kNkff+NbCv2WvLfx+f2eeusvSZ4CfLbT5PUq+twH/onD8s8z6Pue2ejenCWhZhRC2Ad8LZIFfm1X888AI8OYQQu0yX5pWUIzxz2KM/zPGODnr+JeB3yj8+NqSog6gHjgaY/xUSf1rwKHCj/961tu8o7D/hRjj5ZI2WZK++ALgbbf3SbQK7ScJNr2N5O/LXOxPmlNhitIR4OvAv4oxXpldJ8Y4XvKjfUnzeRnJ9NyBGONXSgtijE8BV0j6zhT7kogxPhVj/HyM8WaGct/xPhNCCCVtfqb0e1uM8Q+BE8C3Aa03cb1aBQwGaLk9UNh/bI4bvyvASeAfAN+13BemVWvqi3a+5NhUP/qTOeo/TfLF/b7CULabafPErDpaBwpzFw8DvxJjfHqBqvYnzec+4FuAPwYuF+Z7HwghvHueOd72Jc3n8yRDqF8TQthSWhBCuB/YSDKKaYp9SYu1HH2mEfhmYDDG+IWbbKNVzGCAltvLC/vBeco/X9g3LcO1aJULIaSBHy38WPoP1bz9KMaYB75AMv9yW+E8tcA9wNUY4/NzvJX9bp0p9J3fJplm8m9vUN3+pPl8Z2GfA54hWS/gMPAB4JMhhP4QQunTXPuS5hRj/CpwgGQ9nL8NIfxmCOGhEMIx4GMk01B+oqSJfUmLtRx9xu/x60x6pS9AZeeFhf3X5imfOr7pzl+K1oDDQDPwxzHGPy05vth+ZL8rP/+eZHG3744xjt6grv1J83lxYf8Oki/S/wQYIBny/UvAPyWZN/vaQj37kuYVY/xACCELPAZ0lRSdAR6fNX3AvqTFWo4+Yz9bZxwZoNUmFPamuShzIYT9JKvbngbevNjmhf1i+5H9bh0IIbyGZDTAL8UY/2IpTlnY25/Kz1QqrgB0xBifjDFejTF+FngjyerbrfOlhZuDfamMhRB+hmS19sdJhlvXAq8GzgIfCSH8l8WcrrC3L+lmLUef8Xv8GmMwQMttKmL4wnnK75pVT2UohPBO4FeAvwVeVxheWWqx/ehG9W8U6dYaUTI9YBD4uZtsZn/SfKYW1DobY/zr0oLCiJOpEUuvKeztS5pTCOG1JItR/v8xxp+KMZ6NMX49xvgMSWDpPPDewkLLYF/S4i1Hn/F7/DpjMEDL7f8W9vPNJfrWwn6+uUha50II7wEeAZ4lCQR8eY5q8/ajws3gt5AsOHgWIMY4QvJFa0MI4e45zme/Wz82kPSLfwhcCyHEqY0kYwlAT+HYBwo/2580n6m+MTxP+VSwoGZWffuSZvuBwv6p2QUxxq8Dp0i+l/+jwmH7khZrOfqM3+PXGYMBWm5T/wh+byFlU1EIYSOwGxgF/nK5L0wrL4RwAPivwGdIAgFfmafqnxX23zdH2f0kGSk+GWP8xk22aZtVR2vXN4Dfmmf734U6f174eWoKgf1J83ma5Mvzt4YQquYoby7ss4W9fUnzmVrBvX6e8qnjY4W9fUmLtRx9ZohkYd6mEMK33GQbrWYxRje3Zd1IhlVG4F2zjv9y4fhvrPQ1uq1Iv/i5wu//U8CLblD3LuACyY3fd5QcrwY+WTjPm2a1ua9w/AywueR4A3AJuAY0rPR/B7c72se6C33g7bOO25/cFuo3v1P4Xb9v1vHXA5MkowY22ZfcbtCPOgu/5y8D98wqayv0pVGgzr7kNk8fem3h9/s785QvS58BfrbQ5veAVMnxf1E4/tnS426rewuFX560bEIIjSR/lF4M/CHwOaAFeB3JsKL7YoyXVu4KtdxCCG8hWVBpAvhV5p5rlo0xPl7S5g0kCzFdA44CXwX+OUnam16gM876AxdC+CXgp0gW/eoFqoAfAupIglOPLOHH0ioTQugmmSrQFWP84KyyN2B/0hxCCC8GTgLbgRMkw7lfRjLPOwL/Ksb4eyX134B9SbMURkP+KUlGiivAH5AEBv4hyRSCALwnxvgrJW3egH2prBX6wBsKP76EJIPJWZK/RQAXY4w/Pav+He0zIYQXkDz5v4/kAc6TwDcDP0gysuWBGOPA7X52LZOVjka4lecGfBPwIeB5kj8cz5EsGLfgE2G39bkx/cR2oe0Tc7TbDfwxybzdUeD/AD8JVCzwXm8B/goYIflC1g/8wEr/N3Bb1n729nnK7U9u8/2eX0Qyeu0LhX+zLpEEs7/LvuS2iH5UCbyHZCrk35NMQfkK8EfA99qX3Ob4Xd7o+1F2JfoMyTop/wH4PMlIhAskIwW+baX/m7ktbnNkgCRJkiRJZcYFBCVJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJ0qoWQvjvIYSvhBBqV/papoQQXh1CiCGEH1vpa5Ek6VaEGONKX4MkSdKcQgjfAZwCfjrG+MsrfT2lQgh/AHwX8K0xxqsrfT2SJC2GIwMkSdJq9p+Bvwd+faUvZA4PAS8B9q/0hUiStFiODJAkSatSCKEJOA18MMb44yt9PXMJIXwO+AfAthjjxEpfjyRJN8uRAZIk6Y4IIZwszKufb+u/wSn2AgH4H3Oc+7WFc3TP897ZEEJ21rGGQpvHQwiNIYTeEMKlEMKVEMLHQgjNhXr1IYTfDCE8H0K4FkL4qxDC6+a5xqPANwP/5AafRZKkVSW90hcgSZLWrT8APj7H8beR3EA/dYP2/wSYAP5yia+rARgAPgc8Xvj5jcAnQgi7gD8hmZrwP4AXAW8CngghNMUYvzjrXCcL+9cDf7rE1ylJ0h1jMECSJN0RMcb3zz4WQvhFkkDA48B/nK9tIXPATuBzMcaRJb60VuBQjPEXSt7v5wrXMwAcA/6/GONkoezjwH8HfrKwlfqrwv7+Jb5GSZLuKKcJSJKkOy4k/hvw08CvAXunbrbncQ9QATx/By4nCxyedezDhf0LgH8z69p+F8iTBCdmiDF+DbhGEuCQJGnNMBggSZLuqBBCBclIgH8N/JcY47544xWM6wr7y3fgkj4zx2J/XyrsB2OMV0oLCnVzwNZ5zvdVYMvSXqIkSXeWwQBJknTHhBAqSRbZ+1GgO8Z44Cabjhb21Xfgsr42+0CMMT9fWUEeqJynrIbp65UkaU0wGCBJku6IEEI1ySKCHcBPxxj/wyKaf6Wwr1uwVpJtYC41i3ivWxZCSAGbmL5eSZLWBIMBkiRpyRUWADwOfD/JYny/tMhTPA9cAF5+g3r3zPHedwEvXuT73aqXkwQkPrNM7ydJ0pIwGCBJkpZUCOGFwMdIVu1/a4zx1xd7jsKaAk8DW0II2xeouieEkJl17FBhvxxZk76rsL9RmkRJklYVUwtKkqSl9rvAfcApYFsIoXuOOg/FGL9xg/P8PtAO/FPgzDx18sCzIYQ/AK6Q3Jx/J/B3wDcVMhj8dozxLxb9KW7O9wITwB/eofNLknRHGAyQJElLpjCH/v7Cj68pbLN9JcbYfROn+32SVfx/lCQd4VweJRnp+DbgRcDfAv+MJEXgh4EfAH7rJi9/UQojIN4A/FGM8e/uxHtIknSnGAyQJElLJsY4CWxconONhRB+BfjPIYR/FGP833NUm4gx/hzw7+Yo2zzrfFnmX3CQGONCZQ1zHP5RkmwHi10PQZKkFeeaAZIkaTX7r8AXgf+40hdSKoRQA/ws8PsxxhMrfT2SJC2WwQBJkrRqxRivAW8GPlXIULBaNAC/Cfz0Cl+HJEm3xGkCkiRpVYsxPk2SWWDViDF+Duhe6euQJOlWhSRzjyRJkiRJKhdOE5AkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcz8P4mhfkM67cJzAAAAAElFTkSuQmCC\n", + "text/plain": [ + "
" + ] + }, + "metadata": { + "image/png": { + "height": 318, + "width": 513 + }, + "needs_background": "light" + }, + "output_type": "display_data" + } + ], + "source": [ + "fig, ax = plt.subplots(figsize=(8,5))\n", + "\n", + "isymbol = {1:'o', 2:'x', 3:'.'}\n", + "\n", + "for i, name in method.items():\n", + " zdat = IDAT[i]['z_line']\n", + " z = zdat['z']\n", + " Ez = zdat['Ez']\n", + " \n", + " ax.scatter(z/1e-6, Ez/1e6, label=name, marker=isymbol[i])\n", + " \n", + " ax.set_xlabel(r'$z$'+' (µm)')\n", + " ax.set_ylabel(r'$E_z$'+' (MV/m)') \n", + "plt.legend()" + ] + }, + { + "cell_type": "markdown", + "id": "pursuant-scott", + "metadata": {}, + "source": [ + "# Cleanup" + ] + }, + { + "cell_type": "code", + "execution_count": 17, + "id": "current-installation", + "metadata": {}, + "outputs": [], + "source": [ + "# Cleanup\n", + "!rm *in\n", + "!rm *dat" + ] + } + ], + "metadata": { + "kernelspec": { + "display_name": "Python 3", + "language": "python", + "name": "python3" + }, + "language_info": { + "codemirror_mode": { + "name": "ipython", + "version": 3 + }, + "file_extension": ".py", + "mimetype": "text/x-python", + "name": "python", + "nbconvert_exporter": "python", + "pygments_lexer": "ipython3", + "version": "3.9.2" + } + }, + "nbformat": 4, + "nbformat_minor": 5 +} From 8bd4bdba8eab24e4807ab77fbb615c5f6d8e90b4 Mon Sep 17 00:00:00 2001 From: ChristopherMayes <31023527+ChristopherMayes@users.noreply.github.com> Date: Thu, 18 Mar 2021 13:51:19 -0700 Subject: [PATCH 3/4] Add Bfield calc, corrected factors in _core mod. --- code/open_spacecharge_core_mod.f90 | 28 +-- code/open_spacecharge_mod.f90 | 306 +++++++++++++----------- code/test_opensc.f90 | 11 +- examples/benchmark.ipynb | 364 +++++++++++++++++++++++------ 4 files changed, 481 insertions(+), 228 deletions(-) diff --git a/code/open_spacecharge_core_mod.f90 b/code/open_spacecharge_core_mod.f90 index 96afddc..c5a672f 100644 --- a/code/open_spacecharge_core_mod.f90 +++ b/code/open_spacecharge_core_mod.f90 @@ -46,7 +46,7 @@ subroutine osc_freespace_solver(rho,gam0,delta,phi,efield,bfield,nlo,nhi,nlo_gbl complex(dp), allocatable, dimension(:,:,:) :: crho integer :: icomp,i,j,k,im1,ip1,jm1,jp1,km1,kp1 -real(dp) :: gb0,xfac,yfac,zfac +real(dp) :: beta0,xfac,yfac,zfac integer :: mprocs,myrank,ierr real(dp), parameter :: clight=299792458.d0 ! @@ -124,12 +124,12 @@ subroutine osc_freespace_solver(rho,gam0,delta,phi,efield,bfield,nlo,nhi,nlo_gbl endif ! set the magnetic field: -gb0=sqrt((gam0+1.d0)*(gam0-1.d0)) +beta0=sqrt(1-1/gam0**2) do k=lbound(phi,3),ubound(phi,3) do j=lbound(phi,2),ubound(phi,2) do i=lbound(phi,1),ubound(phi,1) - bfield(i,j,k,1)=-efield(i,j,k,2)/clight/gb0/gam0 - bfield(i,j,k,2)= efield(i,j,k,1)/clight/gb0/gam0 + bfield(i,j,k,1)=-efield(i,j,k,2)*beta0/clight + bfield(i,j,k,2)= efield(i,j,k,1)*beta0/clight bfield(i,j,k,3)=0.d0 enddo enddo @@ -554,7 +554,7 @@ subroutine osc_rectpipe_solver(rho,a,b,gam0,delta,umin,phi,efield,bfield,nlo,nhi integer :: icomp real(dp), parameter :: clight=299792458.d0 integer :: i,j,k,im1,ip1,jm1,jp1,km1,kp1 -real(dp) :: gb0,xfac,yfac,zfac +real(dp) :: beta0,xfac,yfac,zfac dx=delta(1); dy=delta(2); dz=delta(3) xmin=umin(1); ymin=umin(2); zmin=umin(3) @@ -610,12 +610,12 @@ subroutine osc_rectpipe_solver(rho,a,b,gam0,delta,umin,phi,efield,bfield,nlo,nhi endif ! set the magnetic field: -gb0=sqrt((gam0+1.d0)*(gam0-1.d0)) +beta0=sqrt(1-1/gam0**2) do k=lbound(phi,3),ubound(phi,3) do j=lbound(phi,2),ubound(phi,2) do i=lbound(phi,1),ubound(phi,1) - bfield(i,j,k,1)=-efield(i,j,k,2)/clight/gb0/gam0 - bfield(i,j,k,2)= efield(i,j,k,1)/clight/gb0/gam0 + bfield(i,j,k,1)=-efield(i,j,k,2)*beta0/clight + bfield(i,j,k,2)= efield(i,j,k,1)*beta0/clight bfield(i,j,k,3)=0.d0 enddo enddo @@ -924,7 +924,7 @@ subroutine osc_cathodeimages_solver(rho,gam0,umin,delta,phi,efield,bfield,nlo,nh complex(dp), allocatable, dimension(:,:,:) :: crho integer :: icomp,i,j,k,im1,ip1,jm1,jp1,km1,kp1 -real(dp) :: gb0,xfac,yfac,zfac +real(dp) :: beta0,xfac,yfac,zfac integer :: mprocs,myrank,ierr real(dp), parameter :: clight=299792458.d0 ! @@ -1067,14 +1067,14 @@ subroutine osc_cathodeimages_solver(rho,gam0,umin,delta,phi,efield,bfield,nlo,nh endif ! idirectfieldcalc ! set the magnetic field: -gb0=sqrt((gam0+1.d0)*(gam0-1.d0)) +beta0=sqrt(1-1/gam0**2) do k=lbound(phi,3),ubound(phi,3) do j=lbound(phi,2),ubound(phi,2) do i=lbound(phi,1),ubound(phi,1) -! bfield(i,j,k,1)=-efield(i,j,k,2)/clight/gb0/gam0 -! bfield(i,j,k,2)= efield(i,j,k,1)/clight/gb0/gam0 - bfield(i,j,k,1)=-(efield(i,j,k,2)+2.d0*efieldimg(i,j,k,2))/clight/gb0/gam0 !I subtracted efieldimg above, - bfield(i,j,k,2)= (efield(i,j,k,1)+2.d0*efieldimg(i,j,k,1))/clight/gb0/gam0 !so add it back 2x to get sum +! bfield(i,j,k,1)=-efield(i,j,k,2)*beta0/clight +! bfield(i,j,k,2)= efield(i,j,k,1)*beta0/clight + bfield(i,j,k,1)=-(efield(i,j,k,2)+2.d0*efieldimg(i,j,k,2))*beta0/clight !I subtracted efieldimg above, + bfield(i,j,k,2)= (efield(i,j,k,1)+2.d0*efieldimg(i,j,k,1))*beta0/clight !so add it back 2x to get sum bfield(i,j,k,3)=0.d0 enddo enddo diff --git a/code/open_spacecharge_mod.f90 b/code/open_spacecharge_mod.f90 index 25a5563..0d2b6c2 100644 --- a/code/open_spacecharge_mod.f90 +++ b/code/open_spacecharge_mod.f90 @@ -390,11 +390,9 @@ subroutine interpolate_field(x, y, z, mesh3d, E, B) end subroutine - - !------------------------------------------------------------------------ !+ -! Subroutine space_charge_3d(mesh3d, offset, at_cathode) +! Subroutine space_charge_3d(mesh3d, offset, at_cathode, calc_bfield) ! ! Performs the space charge calculation using the integrated Green function method ! and FFT-based convolutions. @@ -411,24 +409,39 @@ subroutine interpolate_field(x, y, z, mesh3d, E, B) ! at_cathode -- logical, optional: Maintain constant voltage at the cathode ! using image charges. Default is False. ! +! calc_bfield -- logical, optional: Calculate the magnetic field mesh3d%bfield +! +! Default: False +! +! ! Output: -! mesh3d -- mesh3d_struct: populated with %efield +! mesh3d -- mesh3d_struct: populated with %efield, and optionally %bfield ! ! ! ! Notes: ! The magnetic field components can be calculated by: -! Bx = -Ey/(c*beta*gamma^2) -! By = Ex/(c*beta*gamma^2) +! Bx = -(beta/c) * Ey +! By = (beta/c) * Ex ! Bz = 0 +! The image charges move in the opposite direction, so the signs are flipped. +! ! !- -subroutine space_charge_3d(mesh3d, offset, at_cathode) +subroutine space_charge_3d(mesh3d, offset, at_cathode, calc_bfield) type(mesh3d_struct) :: mesh3d real(dp), allocatable, dimension(:,:,:,:) :: image_efield ! electric field grid real(dp), optional :: offset(3) -real(dp) :: offset0(3) -logical, optional :: at_cathode +real(dp) :: offset0(3), beta +real(dp), parameter :: c_light = 299792458.0 +logical, optional :: at_cathode, calc_bfield +logical :: bcalc + +if (present(calc_bfield)) then + bcalc = calc_bfield +else + bcalc = .false. +endif if (.not. present(offset)) then offset0 = 0 @@ -439,6 +452,14 @@ subroutine space_charge_3d(mesh3d, offset, at_cathode) ! Free space field call osc_freespace_solver2(mesh3d%rho, mesh3d%gamma, mesh3d%delta, efield=mesh3d%efield, offset=offset0) +! Optional B field +if (bcalc) then + beta = sqrt(1-1/mesh3d%gamma**2) + mesh3d%bfield = 0 + mesh3d%bfield(:,:,:,1) = -(beta/c_light)*mesh3d%efield(:,:,:,2) + mesh3d%bfield(:,:,:,2) = (beta/c_light)*mesh3d%efield(:,:,:,1) +endif + ! Cathode calc if (.not. present(at_cathode)) return if (.not. at_cathode) return @@ -450,11 +471,20 @@ subroutine space_charge_3d(mesh3d, offset, at_cathode) ! The offset is the z width of the mesh, plus 2 times the distance of the mesh from the cathode. offset0(3) = offset0(3) + 2*mesh3d%min(3) + (mesh3d%max(3)-mesh3d%min(3)) -! Flip the charge mesh in z -call osc_freespace_solver2( mesh3d%rho(:,:,size(mesh3d%rho,3):1:-1), & +! Flip the charge mesh in z, with opposite charge sign +call osc_freespace_solver2(-mesh3d%rho(:,:,size(mesh3d%rho,3):1:-1), & mesh3d%gamma, mesh3d%delta, efield=image_efield, offset=offset0) -mesh3d%efield = mesh3d%efield - image_efield + +! Finally add fields + +if (bcalc) then + ! Opposite sign for beta, because image charges are moving in the negative z direction + mesh3d%bfield(:,:,:,1) = mesh3d%bfield(:,:,:,1) + (beta/c_light)*image_efield(:,:,:,2) + mesh3d%bfield(:,:,:,2) = mesh3d%bfield(:,:,:,2) - (beta/c_light)*image_efield(:,:,:,1) +endif + +mesh3d%efield = mesh3d%efield + image_efield end subroutine @@ -462,42 +492,110 @@ subroutine space_charge_3d(mesh3d, offset, at_cathode) !------------------------------------------------------------------------ !+ -! elemental real(dp) function xlafun2(x, y, z) +! Subroutine osc_freespace_solver2(rho, gamma, delta, efield, phi, offset) ! -! The indefinite integral: -! \int x/r^3 dx dy dz = x*atan((y*z)/(r*x)) -z*log(r+y) + y*log((r-z)/(r+z))/2 +! Deposits particle arrays onto mesh ! -! This corresponds to the electric field component Ex. -! Other components can be computed by permuting the arguments +! Input: +! rho -- REAL64(:,:,:): charge density array in x, y, z +! delta -- REAL64(3): vector of grid spacings dx, dy, dz +! gamma -- REAL64: relativistic gamma +! icomp -- integer: Field component requested: +! 0: phi (scalar potential) +! ! -!- -elemental real(dp) function xlafun2(x, y, z) - real(dp), intent(in) :: x, y, z - real(dp) :: r - r=sqrt(x**2+y**2+z**2) - xlafun2 = x*atan((y*z)/(r*x)) -z*log(r+y) + y*log((r-z)/(r+z))/2 -end function - -!------------------------------------------------------------------------ -!+ -! elemental real(dp) function lafun2(x,y,z) +! efield -- REAL64(:,:,:,3), optional: allocated electric field array to populate. +! +! The final index corresponds to components +! 1: Ex +! 2: Ey +! 3: Ez +! If present, all components will be computed. ! -! The indefinite integral: -! \int 1/r^3 dx dy dz = -! -z**2*atan(x*y/(z*r))/2 - y**2*atan(x*z/(y*r))/2 -x**2*atan(y*z/(x*r))/2 -! +y*z*log(x+r) + x*z*log(y+r) + x*y*log(z+r) +! phi -- REAL64(:,:,:), optional: allocated potential array to populate ! -! This corresponds to the scalar potential. -! Other components can be computed by permuting the arguments +! offset -- real(3), optional: Offset coordinates x0, y0, z0 to evaluate the field, +! relative to rho. +! Default: (0,0,0) +! For example, an offset of (0,0,10) can be used to compute +! the field at z=+10 m relative to rho. +! +! Output: +! efield -- REAL64(:,:,:,:) : electric field +! phi -- REAL64(:,:,:) : potential +! +! +! Notes: +! The magnetic field components can be calculated by: +! Bx = -(beta/c) * Ey +! By = (beta/c) * Ex +! Bz = 0 ! !- -elemental real(dp) function lafun2(x,y,z) - real(dp), intent(in) :: x, y, z - real(dp) :: r - r=sqrt(x**2+y**2+z**2) - lafun2 = -z**2*atan(x*y/(z*r))/2 - y**2*atan(x*z/(y*r))/2 -x**2*atan(y*z/(x*r))/2 & - +y*z*log(x+r) + x*z*log(y+r) + x*y*log(z+r) -end function +subroutine osc_freespace_solver2(rho, gamma, delta, efield, phi, offset) + + +real(dp), intent(in), dimension(:,:,:) :: rho +real(dp), intent(in) :: gamma, delta(3) +real(dp), optional, intent(out), dimension(:,:,:,:) :: efield +real(dp), optional, intent(out), dimension(:,:,:) :: phi +real(dp), intent(in), optional :: offset(3) +! internal arrays +complex(dp), allocatable, dimension(:,:,:) :: crho, cgrn +real(dp) :: factr, offset0=0 +real(dp), parameter :: clight=299792458.0 +real(dp), parameter :: fpei=299792458.0**2*1.00000000055d-7 ! this is 1/(4 pi eps0) after the 2019 SI changes + +integer :: nx, ny, nz, nx2, ny2, nz2 +integer :: icomp, ishift, jshift, kshift + +! Sizes +nx = size(rho, 1); ny = size(rho, 2); nz = size(rho, 3) +nx2 = 2*nx; ny2 = 2*ny; nz2 = 2*nz; + +! Allocate complex scratch arrays +allocate(crho(nx2, ny2, nz2)) +allocate(cgrn(nx2, ny2, nz2)) + +! rho -> crho -> FFT(crho) +crho = 0 +crho(1:nx, 1:ny, 1:nz) = rho ! Place in one octant +call ccfft3d(crho, crho, [1,1,1], nx2, ny2, nz2, 0) + +! Loop over phi, Ex, Ey, Ez +do icomp=0, 3 + if ((icomp == 0) .and. (.not. present(phi))) cycle + if ((icomp == 1) .and. (.not. present(efield))) exit + + call osc_get_cgrn_freespace(cgrn, delta, gamma, icomp, offset=offset) + + ! cgrn -> FFT(cgrn) + call ccfft3d(cgrn, cgrn, [1,1,1], nx2, ny2, nz2, 0) + + ! Multiply FFT'd arrays, re-use cgrn + cgrn=crho*cgrn + + ! Inverse FFT + call ccfft3d(cgrn, cgrn, [-1,-1,-1], nx2, ny2, nz2, 0) + + ! This is where the output is shifted to + ishift = nx-1 + jshift = ny-1 + kshift = nz-1 + + ! Extract field + factr = fpei/(nx2*ny2*nz2) + + if (icomp == 0) then + phi(:,:,:) = factr * real(cgrn(1+ishift:nx+ishift, 1+jshift:ny+jshift, 1+kshift:nz+kshift), dp) + else + efield(:,:,:,icomp) = factr * real(cgrn(1+ishift:nx+ishift, 1+jshift:ny+jshift, 1+kshift:nz+kshift), dp) + endif + +enddo + +end subroutine osc_freespace_solver2 + !------------------------------------------------------------------------ !+ @@ -601,112 +699,44 @@ subroutine osc_get_cgrn_freespace(cgrn, delta, gamma, icomp, offset) end subroutine osc_get_cgrn_freespace - !------------------------------------------------------------------------ !+ -! Subroutine osc_freespace_solver2(rho, gamma, delta, efield, phi, offset) -! -! Deposits particle arrays onto mesh -! -! Input: -! rho -- REAL64(:,:,:): charge density array in x, y, z -! delta -- REAL64(3): vector of grid spacings dx, dy, dz -! gamma -- REAL64: relativistic gamma -! icomp -- integer: Field component requested: -! 0: phi (scalar potential) -! -! -! efield -- REAL64(:,:,:,3), optional: allocated electric field array to populate. -! -! The final index corresponds to components -! 1: Ex -! 2: Ey -! 3: Ez -! If present, all components will be computed. +! elemental real(dp) function xlafun2(x, y, z) ! -! phi -- REAL64(:,:,:), optional: allocated potential array to populate +! The indefinite integral: +! \int x/r^3 dx dy dz = x*atan((y*z)/(r*x)) -z*log(r+y) + y*log((r-z)/(r+z))/2 ! -! offset -- real(3), optional: Offset coordinates x0, y0, z0 to evaluate the field, -! relative to rho. -! Default: (0,0,0) -! For example, an offset of (0,0,10) can be used to compute -! the field at z=+10 m relative to rho. +! This corresponds to the electric field component Ex. +! Other components can be computed by permuting the arguments ! -! Output: -! efield -- REAL64(:,:,:,:) : electric field -! phi -- REAL64(:,:,:) : potential +!- +elemental real(dp) function xlafun2(x, y, z) + real(dp), intent(in) :: x, y, z + real(dp) :: r + r=sqrt(x**2+y**2+z**2) + xlafun2 = x*atan((y*z)/(r*x)) -z*log(r+y) + y*log((r-z)/(r+z))/2 +end function + +!------------------------------------------------------------------------ +!+ +! elemental real(dp) function lafun2(x,y,z) ! +! The indefinite integral: +! \int 1/r^3 dx dy dz = +! -z**2*atan(x*y/(z*r))/2 - y**2*atan(x*z/(y*r))/2 -x**2*atan(y*z/(x*r))/2 +! +y*z*log(x+r) + x*z*log(y+r) + x*y*log(z+r) ! -! Notes: -! The magnetic field components can be calculated by: -! Bx = -Ey/(c*beta*gamma^2) -! By = Ex/(c*beta*gamma^2) -! Bz = 0 +! This corresponds to the scalar potential. +! Other components can be computed by permuting the arguments ! !- -subroutine osc_freespace_solver2(rho, gamma, delta, efield, phi, offset) - - -real(dp), intent(in), dimension(:,:,:) :: rho -real(dp), intent(in) :: gamma, delta(3) -real(dp), optional, intent(out), dimension(:,:,:,:) :: efield -real(dp), optional, intent(out), dimension(:,:,:) :: phi -real(dp), intent(in), optional :: offset(3) -! internal arrays -complex(dp), allocatable, dimension(:,:,:) :: crho, cgrn -real(dp) :: factr, offset0=0 -real(dp), parameter :: clight=299792458.0 -real(dp), parameter :: fpei=299792458.0**2*1.00000000055d-7 ! this is 1/(4 pi eps0) after the 2019 SI changes - -integer :: nx, ny, nz, nx2, ny2, nz2 -integer :: icomp, ishift, jshift, kshift - -! Sizes -nx = size(rho, 1); ny = size(rho, 2); nz = size(rho, 3) -nx2 = 2*nx; ny2 = 2*ny; nz2 = 2*nz; - -! Allocate complex scratch arrays -allocate(crho(nx2, ny2, nz2)) -allocate(cgrn(nx2, ny2, nz2)) - -! rho -> crho -> FFT(crho) -crho = 0 -crho(1:nx, 1:ny, 1:nz) = rho ! Place in one octant -call ccfft3d(crho, crho, [1,1,1], nx2, ny2, nz2, 0) - -! Loop over phi, Ex, Ey, Ez -do icomp=0, 3 - if ((icomp == 0) .and. (.not. present(phi))) cycle - if ((icomp == 1) .and. (.not. present(efield))) exit - - call osc_get_cgrn_freespace(cgrn, delta, gamma, icomp, offset=offset) - - ! cgrn -> FFT(cgrn) - call ccfft3d(cgrn, cgrn, [1,1,1], nx2, ny2, nz2, 0) - - ! Multiply FFT'd arrays, re-use cgrn - cgrn=crho*cgrn - - ! Inverse FFT - call ccfft3d(cgrn, cgrn, [-1,-1,-1], nx2, ny2, nz2, 0) - - ! This is where the output is shifted to - ishift = nx-1 - jshift = ny-1 - kshift = nz-1 - - ! Extract field - factr = fpei/(nx2*ny2*nz2) - - if (icomp == 0) then - phi(:,:,:) = factr * real(cgrn(1+ishift:nx+ishift, 1+jshift:ny+jshift, 1+kshift:nz+kshift), dp) - else - efield(:,:,:,icomp) = factr * real(cgrn(1+ishift:nx+ishift, 1+jshift:ny+jshift, 1+kshift:nz+kshift), dp) - endif - -enddo - +elemental real(dp) function lafun2(x,y,z) + real(dp), intent(in) :: x, y, z + real(dp) :: r + r=sqrt(x**2+y**2+z**2) + lafun2 = -z**2*atan(x*y/(z*r))/2 - y**2*atan(x*z/(y*r))/2 -x**2*atan(y*z/(x*r))/2 & + +y*z*log(x+r) + x*z*log(y+r) + x*y*log(z+r) +end function -end subroutine osc_freespace_solver2 end module diff --git a/code/test_opensc.f90 b/code/test_opensc.f90 index 29e6a45..8a05d73 100644 --- a/code/test_opensc.f90 +++ b/code/test_opensc.f90 @@ -181,7 +181,7 @@ program opensc_test !call space_charge_freespace(mesh3d, direct_field_calc, integrated_green_function) ! New method print *, "Chris' method" - call space_charge_3d(mesh3d) + call space_charge_3d(mesh3d, calc_bfield=.true.) endif if(.not.rectpipe.and.cathode_images)then !FREE SPACE BUT WITH CATHODE IMAGES @@ -191,7 +191,7 @@ program opensc_test if (image_method == 3) then print *, "Chris' method" - call space_charge_3d(mesh3d, at_cathode=.true.) + call space_charge_3d(mesh3d, at_cathode=.true., calc_bfield=.true.) else call space_charge_cathodeimages(mesh3d, direct_field_calc, integrated_green_function, image_method) @@ -277,17 +277,18 @@ subroutine write_lines(mesh3d,xcent,ycent,zcent) subroutine write_plane(mesh3d) type(mesh3d_struct) :: mesh3d -real(dp) :: x, y, z, Evec(3) +real(dp) :: x, y, z, Evec(3), Bvec(3) integer :: i, k, outfile -open(newunit=outfile, file = 'x_z_Ex_Ez.dat') +open(newunit=outfile, file = 'x_z_Ex_Ez_By.dat') y = 0 do k = mesh3d%nlo(3), mesh3d%nhi(3) -1 ! skip last point z = (k-1)*mesh3d%delta(3) + mesh3d%min(3) do i = mesh3d%nlo(1), mesh3d%nhi(1) -1 ! skip last point x = (i-1)*mesh3d%delta(1) + mesh3d%min(1) call interpolate_field(x, y, z, mesh3d, E=Evec) - write(outfile, *) x, z, Evec(1), Evec(3) + call interpolate_field(x, y, z, mesh3d, B=Bvec) + write(outfile, *) x, z, Evec(1), Evec(3), Bvec(2) enddo enddo close(outfile) diff --git a/examples/benchmark.ipynb b/examples/benchmark.ipynb index 7453ddb..39afd62 100644 --- a/examples/benchmark.ipynb +++ b/examples/benchmark.ipynb @@ -2,7 +2,7 @@ "cells": [ { "cell_type": "markdown", - "id": "compound-teens", + "id": "written-thesaurus", "metadata": {}, "source": [ "# OpenSpaceCharge tests\n", @@ -16,7 +16,7 @@ { "cell_type": "code", "execution_count": 1, - "id": "latter-pregnancy", + "id": "ambient-matthew", "metadata": {}, "outputs": [], "source": [ @@ -29,6 +29,7 @@ "\n", "import matplotlib.pyplot as plt\n", "import matplotlib\n", + "from mpl_toolkits.axes_grid1 import make_axes_locatable\n", "matplotlib.rcParams['figure.figsize'] = (8,6)\n", "%config InlineBackend.figure_format = 'retina'" ] @@ -36,7 +37,7 @@ { "cell_type": "code", "execution_count": 2, - "id": "plain-correction", + "id": "crude-liberal", "metadata": {}, "outputs": [], "source": [ @@ -47,7 +48,7 @@ { "cell_type": "code", "execution_count": 3, - "id": "physical-passport", + "id": "general-lobby", "metadata": {}, "outputs": [], "source": [ @@ -60,14 +61,14 @@ " NYLO=1 ,\n", " NYHI=64 ,\n", " NZLO=1 ,\n", - " NZHI=64 ,\n", + " NZHI=128 ,\n", " N_PARTICLE=1000000 ,\n", - " E_TOT= 0.51099891e6 ,\n", + " E_TOT= 5e6 ,\n", " BUNCH_CHARGE= 1e-9,\n", " DISTTYPE = 1, \n", " SIGMA_X= 1e-3,\n", " SIGMA_Y= 1e-3,\n", - " SIGMA_Z= 1e-3,\n", + " SIGMA_Z= 1e-4,\n", " GAUSSIANCUTOFF= 4 ,\n", " DIRECT_FIELD_CALC=T,\n", " INTEGRATED_GREEN_FUNCTION=T,\n", @@ -89,7 +90,7 @@ { "cell_type": "code", "execution_count": 4, - "id": "false-programmer", + "id": "quantitative-pavilion", "metadata": {}, "outputs": [ { @@ -103,13 +104,13 @@ " NYLO=1 ,\n", " NYHI=64 ,\n", " NZLO=1 ,\n", - " NZHI=64 ,\n", + " NZHI=128 ,\n", " N_PARTICLE=1000000 ,\n", - " E_TOT= 510998.90999999997 ,\n", + " E_TOT= 5000000.0000000000 ,\n", " BUNCH_CHARGE= 1.0000000000000001E-009,\n", " SIGMA_X= 1.0000000000000000E-003,\n", " SIGMA_Y= 1.0000000000000000E-003,\n", - " SIGMA_Z= 1.0000000000000000E-003,\n", + " SIGMA_Z= 1.0000000000000000E-004,\n", " GAUSSIANCUTOFF= 4.0000000000000000 ,\n", " DIRECT_FIELD_CALC=T,\n", " INTEGRATED_GREEN_FUNCTION=T,\n", @@ -123,22 +124,22 @@ " BPIPE= 1.2000000000000000E-002,\n", " /\n", " ------------------------\n", - " gamma= 1.0000000000000000 \n", - " beta0= 0.0000000000000000 \n", + " gamma= 9.7847566837275650 \n", + " beta0= 0.99476389387590491 \n", " particle xmin,xmax= -3.9826073840537940E-003 3.9869615736364229E-003\n", " particle ymin,ymax= -3.9509672876726944E-003 3.9790345163215803E-003\n", - " particle zmin,zmax= -3.8981835420025877E-003 3.9605290566242009E-003\n", + " particle zmin,zmax= -3.8981835420025880E-004 3.9605290566242015E-004\n", " added zcentroid to z particle data, where zcentroid= 0.0000000000000000 \n", " Done computing initial 3D Gaussian spatial distribution w/ cold velocity distribution\n", " mesh xmin,xmax= -4.1132560554917492E-003 4.1176102450743799E-003\n", " mesh ymin,ymax= -4.0809673172467788E-003 4.1090345458956682E-003\n", - " mesh zmin,zmax= -4.0270148960788394E-003 4.0893604107004574E-003\n", - " delta(1:3)= 1.3064867143755760E-004 1.3000002957368962E-004 1.2883135407586185E-004\n", + " mesh zmin,zmax= -3.9610532427919985E-004 4.0233987574136174E-004\n", + " delta(1:3)= 1.3064867143755760E-004 1.3000002957368962E-004 6.2869700789020598E-006\n", " Done with charge deposition\n", " Space charge field calc with free-space boundary condition...\n", " Chris' method\n", " ...done\n", - " Time for space charge calc (s): 3.2612119999999996 \n" + " Time for space charge calc (s): 6.4767380000000001 \n" ] } ], @@ -148,22 +149,24 @@ }, { "cell_type": "markdown", - "id": "cloudy-columbus", + "id": "academic-cambridge", "metadata": {}, "source": [ - "# Parsers" + "# Parsers\n", + "\n", + "Simple parsers for the line output and grid output text files" ] }, { "cell_type": "code", "execution_count": 5, - "id": "placed-experience", + "id": "green-corps", "metadata": {}, "outputs": [ { "data": { "text/plain": [ - "[]" + "[]" ] }, "execution_count": 5, @@ -172,7 +175,7 @@ }, { "data": { - "image/png": "iVBORw0KGgoAAAANSUhEUgAAA9gAAALfCAYAAACaWGp9AAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAACHKElEQVR4nOzddXiUV8L+8fvESQgJIcFdg7tr3bfuBnXZbtvd7Xbf3Xa3Xd/u1t2AUqpbdwWKu7u7hASIEp3z/jHDZJISCGSSZ+T7ua5ck+eMcPP7vdvk5jlirLUCAAAAAAA1E+F0AAAAAAAAQgEFGwAAAAAAP6BgAwAAAADgBxRsAAAAAAD8gIINAAAAAIAfULABAAAAAPADCjYAAAAAAH5AwQYAAAAAwA8o2AAAAAAA+AEFGwAAAAAAP6BgAwAAAADgBxRsAAAAAAD8gIINAAAAAIAfULABAAAAAPADCnYNGGMuM8Y8a4yZYYzJMcZYY8zkWvhzehpjJhljdhhjiowxGcaYn4wxN/j7zwIAAAAAnJwopwMEuYck9ZaUJ2mnpHR//wHGmLGSXpNUIOkLSVslJUvqIelcSZP8/WcCAAAAAE4cBbtm7pe7WG+UNFrSVH9+uDFmiNzleqWks621eys9H+3PPw8AAAAAcPKYIl4D1tqp1toN1lpb3fcYY642xkw1xhw0xhQaY9YYYx4yxsQe5eWPSYqUdF3lcu3580tqEB8AAAAA4Efcwa5DxpjXJd0k913vjyQdkjRE0l8lnWaMOcNaW+p5bUtJIyUtlLTKGHOKpP6SrKSlkqZaa111/XcAAAAAABwdBbuOeNZS3yTpY0nXWmsP+zz3iKQ/S7pb0tOe4YGexw2SpkgaU+kjVxhjLrHWbqy91AAAAACA6mKKeN25V1KppJt8y7XHXyVlSbrWZ6yx5/EKSV0lXSIpSVJHSW9K6inpS2NMTG2GBgAAAABUD3ew64AxJl7u3cYzJd1njDnay4rkLtJHRPo83mKt/cJznWOMudHz2gGSLpX0Tm3kBgAAAABUHwW7bjSUZCSlyT0VvDoOeh6LJH3l+4S11hpjPpW7YA8SBRsAAAAAHMcU8bqR7XlcYq01x/ryec86z2NuFZuZHSng9WotNQAAAACg2ijYdcBamydplaTuxpiUar5tudxTylONMU2O8nwPz+PWmicEAAAAANQUBbvuPCEpRtJ4Y0xy5SeNMQ2NMf2OXHuO63rZc/mYMSbC57U9JY2Ve9O0D2oxMwAAAACgmoy11ukMQcsYc5GkizyXTSWdJWmzpBmesUxr7W99Xv+8pLskHZD0raTtklIktZM0StIEa+0dPq+Pl/Sj3GdlL5E0Te513JfKPTX8N9baJ2rlLwcAAAAAOCEU7BrwOb+6KtustW0rved8SXfIvTlZstxle7uk7yRNttaurfT6eEm/k3SV3EW8UNICSY9ba7/2x98DAAAAAFBzFGwAAAAAAPyANdgAAAAAAPgBBRsAAAAAAD+gYAMAAAAA4AcUbAAAAAAA/CDK6QDBxhizRVIDSVsdjgIAAAAA8L+2knKste1O9I0U7BPXoF69eildu3ZNcToIAAAAAMC/1qxZo8OHD5/UeynYJ25r165dUxYtWuR0DgAAAACAn/Xv31+LFy/eejLvZQ02AAAAAAB+QMEGAAAAAMAPKNgAAAAAAPgBBRsAAAAAAD+gYAMAAAAA4AcUbAAAAAAA/ICCDQAAAACAHwREwTbGNDLG3GKM+dgYs9EYc9gYk22MmWmMudkYc0I5jTEtjTHjjTG7jTFFxpitxpinjDENa+vvAAAAAAAIb1FOB/C4XNKLkvZImippu6Qmki6R9Jqkc4wxl1tr7fE+yBjTQdJsSY0lfSppraRBku6VdLYxZri1NqtW/hYAAAAAgLAVKAV7vaRfSPrSWus6MmiM+YOk+ZIulbtsf1iNz3pB7nL9K2vtsz6f9YSk+yX9XdId/osOAAAAAECATBG31k6x1n7uW64943slveS5HHO8zzHGtJd0pqStkp6v9PSfJeVLut4Yk1DTzAAAAAAA+AqIgn0cJZ7H0mq89lTP43dHKeu5kmZJipc0xH/xAAAAAAAI8IJtjImSdIPn8ptqvKWL53F9Fc9v8Dx2rkkuAAAAAAAqC5Q12FX5l6Qekr6y1n5bjdcneR6zq3j+yHjy8T7IGLOoiqfSq5EDAAAAABBmAvYOtjHmV5J+I/cu4Nf762M9j8fdjRwAAAAAgBMRkHewjTF3S3pa0mpJp1lrD1TzrUfuUCdV8XyDSq+rkrW2fxXZFknqV808AAAAAIAwEXB3sI0x90l6TtJKSad4dhKvrnWex6rWWHfyPFa1RhsAAAAAgJMSUAXbGPOgpCclLZW7XGec4EdM9TyeaYyp8HczxiRKGi7psKS5NYwKAAAAAEAFAVOwjTEPy72p2SK5p4VnHuO10caYdGNMB99xa+0mSd9Jaivp7kpve1RSgqRJ1tp8f2YHAAAAACAg1mAbY26U9BdJZZJmSPqVMabyy7Zaayd6vm8haY2kbXKXaV93SZot6RljzGme1w2WdIrcU8P/6P+/AQAAAAAg3AVEwZbUzvMYKem+Kl7zk6SJx/sga+0mY8wAuQv72ZLOlbRH0jOSHj2BDdMAAAAAAKi2gCjY1tpHJD1yAq/fqvIjt472/A5J42qaCwAAAACA6gqYNdgAAAAAAAQzCjYAAAAAAH5AwQYAAAAAwA8o2AAAAAAA+EFAbHIGAACA4GetVVZ+sbYfKNAOz1duUak6pNZXerNEdWqcqHoxkU7HBIBaQ8EGAABAteUXlWrHwQLtOHDYW6R3HizwfH9Yh0vKqnxvhJHapiYovWmi0ps28D62bFhPERFVHhADAEGDgg0AAIBj2p5VoP9+t06zNmYqK7/4pD/HZaXN+/O1eX++vlqx1zueEBOpLk0Tld7MXbq7NWugPq2SFRXJakYAwYWCDQAAgKMqKC7VC1M36ZUZm1Vc6qrWexJjo9QqJV6tUuqpdUq86sVEaWNGrtbuydWWrHxZ+/P35BeXafH2Q1q8/ZB3rEVyPd04rI2uHNBaSfHRfvobAUDtomADAACgAmutPlu2W//8aq325hRWeC460qhFcj1PiY5X65R4tWpYXqiT6kXLmKNP9z5cXKYNnrK9Zm+O1u3N1Zo9OTpYUPKz1+46dFj/+Gqtnvx+gy7t30Jjh7VTx8b1a+XvCwD+QsEGAACA18pd2Xr081VasPVghfHerZL18Hld1bd1Q0We5HrpejGR6tUyWb1aJnvHrLXan1ukNXtztW5vjtbsydW0dRne0n24pEyT527X5LnbNapzmsYNb6vRndJYsw0gIFGwAQAAoKy8Iv33u/V6d8H2CtO4U+vH6sGzu+jSfi1rpdQaY9S4QZwaN4jT6M5pkqTCkjJ9unSXJszaqrV7c72vnb5+v6av36/2aQkaN6ytLunXUgmx/DoLIHAYe7SFMKiSMWZRv379+i1atMjpKAAAADVWUubS5Lnb9OT365VTWOodj440Gje8ne45taMS45xZA22t1ZzNWRo/c6t+XLvvZ+u3E+OidNXAVrphaFu1Sol3JCOA0NO/f38tXrx4sbW2/4m+l3/yAwAACFMzN2Tq0c9XaUNGXoXxMV3S9Kfzu6l9mrNrno0xGtYhVcM6pGpbVr7emL1N/1u4Q7lF7n8IyC0s1asztuj1mVt0Zremuvf0TurarIGjmQGENwo2AABAmNlxoEB/+3K1vl21r8J4u9QEPXx+V52a3sShZFVr0yhBf7qgm359Zmd9sHCHJs7eqq1ZBZLcx399s2qvpqzN0O/PSde44W2r3GgNAGoTBRsAACCMTFuXoTsnL9bhkjLvWEJMpO45rZPGDW+r2KhIB9MdX/3YKI0d3k43DG2raeszNH7mVs3cmClJKi5z6S9frNasjZn6z+W9lZIQ43BaAOEmwukAAAAAqBvfrNyjWyctrFCuL+nXQlN/O0Z3jO4Q8OXaV0SE0anpTTT5lsH6+t6R6tGifGr4j2szdM7T0zVnU5aDCQGEIwo2AABAGPho8U7d/fYSlZS5dwprkVxPH901TE9c0UeNG8Q5nK5mujZroA/vHKabR7Tzju3LKdI1r83V49+tU2mZy8F0AMIJBRsAACDEvTl3m379/jKVudzlun1qgv53x1D1a93Q4WT+ExsVqYfP76YJYwd6p4ZbKz07ZaOuemWudh067HBCAOGAgg0AABDCXv5pkx7+ZKX3Or1pot67faiaJ9dzMFXtOSW9sb6+d6SGdWjkHVu47aDOeWq6vlm5x8FkAMIBBRsAACAEWWv1xHfr9M+v13rHerdK1ru3DVFaYqyDyWpfkwZxevPmwXrgrC6KjHDvJp5TWKo7Ji/WQ5+sUKHPGnQA8CcKNgAAQIix1uqvX6zRM1M2eseGtE/RW7cMVnJ8eOysHRlhdPcpHfX+7UPUwudu/eS523Xhc7O0fl+ug+kAhCoKNgAAQAgpc1n930crNH7WFu/YmC5pmjhukOrHht8Jrf3bpOire0fq3J5NvWPr9uXqF8/N1Nvztsta62A6AKGGgg0AABAiSspcuu+9pXp3wQ7v2Lk9m+qV6wcoLjp4juDyt6R60Xr+mn76x8U9FRvl/vW3sMSlP3y8Qve+u1RFpUwZB+AfFGwAAIAQUFhSpjsnL9Lny3Z7xy7r31LPXNVXMVH8ymeM0TWDW+vze0aoc5P63vHPlu3WuAkLlFtY4mA6AKGC/9oCAAAEufyiUt38xgL9sCbDO3bj0DZ67NJeiork1z1fnZsk6rNfjtDVg1p5x2ZvytJVr8zV/twiB5MBCAX8FxcAACCIZR8u0Q3j52vWxizv2J1jOuiRX3RXhGcHbVQUFx2pf1zcUw+c1cU7tmp3ji57aba2ZeU7mAxAsKNgAwAABKnsghJd8+pcLdp20Dv2wFld9ODZ6TKGcn0sxrh3Gf/3pT115N8htmUV6NIXZ2vlrmxnwwEIWhRsAACAIPXHT1Zo1e4c7/UjF3TT3ad0dDBR8LlyYGu9fP0A7+ZnmXnFuuqVuZq9MdPhZACCEQUbAAAgCH22bLe+WL7He/3vS3tq7PB2DiYKXmd0a6LJtwxWgzj3MWZ5RaUaO2GBvvT5f18AqA4KNgAAQJDZm12ohz5e4b2+ckArXTmwtYOJgt/Atin63x3D1KRBrCSpuMylX76zWG/O2epsMABBhYINAAAQRKy1euCDZcopLJUktWxYTw9f0M3hVKGhS9NEfXjnMLVPS5AkWSs9/OkqPfHdOllrHU4HIBhQsAEAAILI5HnbNWODe32wMdLjl/dW/dgoh1OFjpYN4/XBHcPUu1Wyd+yZKRv1h49XqsxFyQZwbBRsAACAILElM1//+HKN9/rWke01uH0jBxOFppSEGL1z62CN7pzmHXtn/nbd9dYiFZaUOZgMQKCjYAMAAASB0jKXfv3+Uh32FLwuTRL16zM6O5wqdMXHROm1Gwfo4r4tvGPfrtqnG8bPV/bhEgeTAQhkFGwAAIAg8PL0zVqy/ZAkKTrS6IkreysuOtLZUCEuOjJCj1/eW7eOLN+dff6WA7rqlbk6kF/sYDIAgYqCDQAAEOBW7srWk9+v917fd3pndW+e5GCi8BERYfTH87rpD+eme8fW7MnRNa9SsgH8HAUbAAAggBWWlOnX7y9VqWeDrb6tk3X7qPYOpwo/t43qoP9c1kvGuK/X7s2lZAP4GQo2AABAAHv8u3Vavy9PklQvOlJPXNFHUZH8CueEywe00hNX9KZkA6gS/3UGAAAIUHM3Z+m1mVu81384r6vapSY4mAgX921JyQZQJQo2AABAAMotLNFv/7dM1nP08qjOabpucGtnQ0ESJRtA1SjYAAAAAeivX6zWzoOHJUlJ9aL12KW9ZI40OjiOkg3gaCjYAAAAAeb71fv0/sKd3uu/XtRDTZPiHEyEo6FkA6iMgg0AABBAsvKK9H8fLfden9+rmX7Ru7mDiXAsR0p2BCUbgCjYAAAAAcNaqz98vEKZee5y1jgxVn+7qIfDqXA8F/dtqccp2QBEwQYAAAgYHy3epW9X7fNeP3ZZLyXHxziYCNVFyQYgUbABAAACwq5Dh/XIZ6u819cObq0xXRo7mAgnipINgIINAAAQAB77Zq1yi0olSW0axesP53Z1OBFOBiUbCG8UbAAAAIet25urz5bt9l7/57LeSoiNcjARaqKqkp1dUOJsMAC1joINAADgsCe/Xy9r3d+flt5Yg9qlOBsINXa0kn3rmwtVWFLmbDAAtYqCDQAA4KAVO7P1zaq93uv7z+jsYBr408V9W+q/l/f2Xs/fckC/fn+pylzWwVQAahMFGwAAwEFPfL/O+/25PZuqR4skB9PA3y7p11J/9FlP/9WKvfrrF6tlLSUbCEUUbAAAAIcs2nZAU9ftlyQZI91/OnevQ9EtI9vppuHtvNcTZ2/VK9M3O5gIQG2hYAMAADjk8e/We7+/qE8LdWqS6GAa1BZjjB46r6vO69XMO/bPr9fqkyW7HEwFoDZQsAEAABwwe2OmZm/KkiRFRhjde1onhxOhNkVEGD1+eW8N9tnA7oEPlmnmhkwHUwHwNwo2AABAHbPW6vHvy+9eX96/pdqmJjiYCHUhLjpSr9wwQJ2b1JcklZRZ3TF5kVbtznY4GQB/oWADAADUsWnr92vRtoOSpJjICN3D3euwkVQvWm/cNEjNkuIkSXlFpRo7YYF2HChwOBkAf6BgAwAA1CFrrR7/rnzn8KsHtVKL5HoOJkJda5ZUTxPHDVJiXJQkaX9ukW6cMF8H84sdTgagpijYAAAAdejbVfu0cleOJCk2KkJ3n9LR4URwQpemiXr1hgGKiXT/Or55f75ufmOBCkvKHE4GoCYo2AAAAHWkzGUrnHt947C2atwgzsFEcNKQ9o305JV9ZIz7evH2Q7rnnSUqLXM5GwzASaNgAwAA1JEvlu/W+n15kqSEmEjdPqq9w4ngtPN6NdOfzu/mvf5+9T796bNVstY6mArAyaJgAwAA1IHSMpee+mGD9/qmEe3UqH6sg4kQKMYNb1fhH1venrddz0/d6GAiACeLgg0AAFAHPlqyS1sy8yVJDeKidMtI7l6j3INnp+vCPs291//9br3+t3CHg4kAnAwKNgAAQC0rLnXpaZ+717eNaq+ketEOJkKgiYgw+s9lvTW8YyPv2O8/WqFp6zIcTAXgRAVEwTbGXGaMedYYM8MYk2OMscaYySfxOVs97z3a197ayA4AAHA87y3coV2HDkuSUhJiNHZ4O4cTIRDFREXopev6q2uzBpLcm+Ld9dZirdyV7XAyANUV5XQAj4ck9ZaUJ2mnpPQafFa2pKeOMp5Xg88EAAA4KYUlZXpuSvnd6ztHd1D92ED5FQyBJjEuWhPHDdQlL8zWrkOHVVBcprETFujju4apVUq80/EAHEeg/Nf9frmL9UZJoyVNrcFnHbLWPuKPUAAAADU1ee427cspkiQ1TozVdUPaOJwIga5JgzhNHDdQl744WzmFpcrMK9KNE+brwzuGqWFCjNPxABxDQEwRt9ZOtdZusJxHAAAAQkh+UalenLbJe/3LUzuqXkykg4kQLDo1SdSrNwxQTKT71/XN+/N1y6SFKiwpczgZgGMJiILtZ7HGmOuMMX8wxtxrjDnFGMNPMgAAUOcmzt6qrPxiSVKL5Hq6cmArhxMhmAxu30hPXNnbe71o20Hd++4Slbm4JwUEqkCZIu5PTSW9WWlsizFmnLX2p+p+iDFmURVP1WR9OAAACBPZh0v08k/ld69/dVpHxUbxb/44Mef3aq692YX625drJEnfrtqnv36xWn++oJuMMQ6nA1BZqN3BniDpNLlLdoKknpJeltRW0tfGmN5VvxUAAMB/Xp+5RTmFpZKkto3idUm/lg4nQrC6ZWR73eSz8/zE2Vv16ozNDiYCUJWQuoNtrX200tBKSXcYY/Ik/UbSI5IuruZn9T/auOfOdr8axAQAACHuQH6xxs/c4r2+7/TOio4MtfsaqEsPnddV+3IK9eWKPZKkf3y1Vk2T6ukXvZs7nAyAr3D5L/1LnsdRjqYAAABh4fWZm5VX5L573alxfV1ACUINRUQYPX5Fbw1s29A79tv3l2nOpiwHUwGoLFwKdobnMcHRFAAAIOQVl7r07vwd3uv7Tu+syAjWyqLm4qIj9eoNA9SxcX1JUnGZS7e9uVDr9uY6nAzAEeFSsId6HlmsAgAAatW3q/Z6dw5vnhSns3s0dTgRQklyfIwmjhuotMRYSVJuYanGTpivvdmFDicDIAVhwTbGRBtj0o0xHSqNdzfGpBzl9W0kPee5nFwXGQEAQPh6a9427/dXDmzN3Wv4XcuG8Zo4bqASPGeq78ku1NgJ85VTWOJwMgABUbCNMRcZYyYaYyZK+r1neOiRMWPMf31e3kLSGkk/VvqYyyXtNsZ8bYx5wRjzb2PMB5LWSuoo6StJ/xUAAEAt2ZiRp7mbD0iSIiMM516j1nRvnqQXr+uvKM8/4Kzdm6s73lyk4lKXw8mA8BYQBVtSH0k3er7O8oy19xm7rBqfMVXSx5LaSbpG0q8ljZY00/MZ51tri/2aGgAAwMfb87Z7vz+9a2M1TYpzMA1C3ajOafrXpb2817M3Zel3HyyTy2UdTAWEt4A4psta+4jcR2hV57VbJf1srpW19idJP/kzFwAAQHUVlpTpw8U7vdfXDm7jYBqEi8v6t9Te7MP673frJUmfLN2tZsn19ODZ6Q4nA8JToNzBBgAACGpfLt+j7MPuNbCtU+I1omOqw4kQLu4+paOuHtTae/3itE16c+62Y7wDQG2hYAMAAPiB7+ZmVw9qrQg2N0MdMcborxd216npjb1jf/50pb5fvc/BVEB4omADAADU0Jo9OVq8/ZAkKTrS6PIBLZ0NhLATFRmh567pq14tkyRJLivd885iLd1xyNlgQJihYAMAANSQ7+ZmZ3VvqtT6sQ6mQbiKj4nS6zcOVKuUepKkwhKXbp64QNuy8h1OBoQPCjYAAEAN5BeV6uMlu7zXbG4GJ6UlxuqNcYPUMD5akpSVX6wbx89XVl6Rw8mA8EDBBgAAqIHPlu1WXlGpJKl9WoKGtE9xOBHCXfu0+nrtxgGKjXL/qr81q0C3TFqow8VlDicDQh8FGwAAoAZ8Nze7dnAbGcPmZnBe/zYpevqqPjryf45Lth/Sr95dojLOyAZqFQUbAADgJC3feUgrd+VIkmKiInRpvxYOJwLKnd2jmf50fjfv9fer9+nRz1fJWko2UFso2AAAACfprbnlm5ud36uZkuNjHEwD/Ny44e1068h23utJc7bplembHUwEhDYKNgAAwEnIPlyiz5bt9l6zuRkC1f+d01Xn9Wrmvf7n12sr/N8uAP+hYAMAAJyET5bs0uES96ZR6U0T1a91srOBgCpERBg9fnlvDWpXvgHfb99fprmbsxxMBYQmCjYAAMAJstZWOPv62sGt2dwMAS0uOlKvXN9fHRvXlyQVl7l026SFWr8v1+FkQGihYAMAAJygRdsOap2nmMTHROqivmxuhsCXHB+jieMGKi0xVpKUU1iqsePna19OocPJgNBBwQYAADhBb/ncvb6wT3MlxkU7mAaovpYN4zVh7EAlxERKknZnF2rshAXKLSxxOBkQGijYAAAAJ+BgfrG+XLHHe33NIDY3Q3Dp0SJJL1zXX5ER7mUNa/bk6PY3F6motMzhZEDwo2ADAACcgA8X71RxqUuS1Ktlknq2THI4EXDiRndO0z8v6em9nr0pS/e/t1RlLs7IBmqCgg0AAFBN1toK08OvHdzawTRAzVwxoJUeOKuL9/qrFXv1p09XylpKNnCyKNgAAADVNGdTlrZk5kuSEmOjdEHv5g4nAmrmrjEdNHZYW+/1W/O266kfNjgXCAhyFGwAAIBq8r17fXG/FoqPiXIwDVBzxhj96fxu+oXPPxY9/eMGvTl3m4OpgOBFwQYAAKiG/blF+nbVXu/1NUwPR4iIiDD67+W9NapzmnfsT5+u1JfL9xzjXQCOhoINAABQDe8v3KFSzwZQA9o0VHrTBg4nAvwnJipCL17bT71bJUuSrJXue2+JZm3MdDYYEGQo2AAAAMdR5rJ6Z77P5mZDuHuN0JMQG6UJYweqfVqCJKmkzOq2SQu1Yme2w8mA4EHBBgAAOI7pG/Zr58HDkqTk+Gid06OZw4mA2pGSEKM3bx6spg3iJEn5xWUaO2G+d3M/AMdGwQYAADiOt302N7usX0vFRUc6mAaoXS2S62nSzYOUVC9akpSVX6zrX5+nfTmFDicDAh8FGwAA4Bj2ZB/Wj2v2ea+vZnMzhIHOTRI1fuxAxUW768LOg4d14/j5yj5c4nAyILBRsAEAAI7h3fk75NnbTEPbN1KHtPrOBgLqSP82DfXitf0VGWEkSWv35uqWNxaosKTM4WRA4KJgAwAAVMFaq4+X7PJeczQXws0p6Y31n8t6ea8XbD2oX769RKVlLgdTAYGLgg0AAFCFVbtztP1AgSSpfmyUzujWxOFEQN27pF9L/fHcrt7rH9bs0x8+XiFrrYOpgMBEwQYAAKjCF8v3eL8/o1sTNjdD2Lp1VHvdPrq99/r9hTv19y/XULKBSijYAAAAR2Gt1Vcrygv2eT05mgvh7fdnp+uy/i2916/N3KL/fLuOkg34oGADAAAcxcpd5dPDE2OjNLJzqsOJAGcZY/SvS3rqrO7lSyVemLZJz/y40cFUQGChYAMAABzFFyt2e78/o1sTxUYxPRyIiozQs1f302npjb1jT/6wXi9O2+RgKiBwULABAAAq+dn08F5MDweOiImK0PPX9tPITuWzOv79zVq9NmOzg6mAwEDBBgAAqGTFrmztOHBYknt6+IhOTA8HfMVFR+rVGwZoaPtG3rG/fblGb87Z6lwoIABQsAEAACr50nf38O5MDweOJi46Uq+PHaCBbRt6xx7+dJXenb/dwVSAsyjYAAAAPqy1+tJnevj5TA8HqhQfE6XxYweqT6tk79j/fbxCHy7a6VwowEEUbAAAAB/Ld2Zr50HP9PC4KI3omOZwIiCwJcZF642bBqlHiwaSJGulBz5Yps+X7T7OO4HQQ8EGAADw4bu52Zndmiomil+XgONJqhetN28arPSmiZIkl5Xue2+pvlm55zjvBEILPzEAAAA8rLX6YjnTw4GT0TAhRpNvGaxOjetLkspcVve8s0Q/rtnncDKg7lCwAQAAPJbtzNauQ+7p4Q3iojS8I7uHAycitX6s3rplsNqlJkiSSsqs7py8WD+t3+9wMqBuULABAAA8KkwP7870cOBkNG4Qp7dvHazWKfGSpOIyl26btFCzN2Y6nAyoffzUAAAAkGf3cJ/p4ef1ZHo4cLKaJdXT27cOVovkepKkolKXbn5joeZvOeBwMqB2UbABAAAkLd1xiOnhgB+1bBivt28drCYNYiVJh0vKNHbCfM3bnOVwMqD2ULABAABUcXr4WUwPB/yiTaMEvX3rEKUlukt2QXGZxk1cQMlGyOInBwAACHuVp4efy+7hgN90SKuvdyqV7LETFmguJRshiIINAADC3pIdh7Q7u1CS+zzf4R2YHg74U8fGFUv24ZIyjZuwQHM2UbIRWijYAAAg7H213Hd6eBOmhwO1oGPj+nr3tiFq7FuyJ87X7E3sLo7QwU8PAAAQ1lwuW2H99bnsHg7Umg5p7pJ9ZOOzwhKXbpq4gCO8EDIo2AAAIKwt3Vlpeji7hwO1qn1afb1729CKJfuNBZpFyUYIoGADAICw5ru52dndmyo6kl+PgNrWLjVB7942VE0bxEkqv5NNyUaw4ycIAAAIWz+bHs7u4UCdcZfsIWqW5C7ZRaXukj1zAyUbwYuCDQAAwtaSHYe0xzM9PDk+WsM6NHI4ERBe2h6lZN/8xgLN2LDf4WTAyaFgAwCAsMX0cMB5bRq5S3bzCiV7oaavp2Qj+PBTBAAAhCV2DwcCh7tkD1WL5HqSpOJSl26ZtFA/UbIRZCjYAAAgLC3ZcVB7c9zTwxvGR2so08MBR7VuFK93bxtSoWTfOmmhpq7LcDgZUH0UbAAAEJa+8JkefhbTw4GA0Crl5yX7tkkL9e2qvQ4nA6qHnyQAACDsuFxWX68o/4X9PHYPBwLGkZLdsqG7ZJeUWd311mJ9unSXw8mA46NgAwCAsLN4e6Xp4e2ZHg4EklYp8Xr/9qFql5ogSSpzWd333lK9t2C7w8mAY6NgAwCAsOM7PfzsHk0VxfRwIOA0T66n924foi5NEiVJ1koPfrhCE2dtcTgZUDV+mgAAgLDicll9vbK8YJ/Xs7mDaQAcS+PEOL172xD1aNHAO/bI56v14rRNDqYCqkbBBgAAYWXR9oPal1MkSUpJiNGQ9ikOJwJwLA0TYvTWLUPUr3Wyd+zf36zVE9+tk7XWuWDAUVCwAQBAWPmy0u7hTA8HAl9SvWi9efPgCvslPDNlo/7+5RpKNgJKQPxEMcZcZox51hgzwxiTY4yxxpjJJ/lZLY0x440xu40xRcaYrcaYp4wxDf2dGwAABBeXy+qrFeUF+3x2DweCRkJslCaMG6gxXdK8Y6/N3KKHPlkpl4uSjcAQEAVb0kOSfimpj6ST3n/fGNNB0iJJ4yTNl/SkpM2S7pU0xxjDFqEAAISxhdsOKiPXPT28UUKMBrdjejgQTOKiI/Xy9f11Vvcm3rG35m3XAx8sV2mZy8FkgFugFOz7JXWW1EDSnTX4nBckNZb0K2vtRdba31trT5W7aHeR9PcaJwUAAEHry+W7vd+fxe7hQFCKjYrU89f004V9yjco/HDxTt377lIVl1Ky4ayA+KlirZ1qrd1ga7CAwhjTXtKZkrZKer7S03+WlC/pemNMwkkHBQAAQcvlsvpm1V7v9fk9mR4OBKuoyAg9cUUfXTWwlXfsyxV7dOfkRSosKXMwGcJdQBRsPznV8/idtbbCP11Za3MlzZIUL2lIXQcDAADOW7Er27t7eHJ8tAYxPRwIapERRv+8pKfGDmvrHftxbYZueWOhCopLnQuGsBZKBbuL53F9Fc9v8Dx2roMsAAAgwHy3uvzu9WnpTZgeDoQAY4z+fEE33TWmg3ds5sZMXffaPB3ML3YwGcJVlNMB/CjJ85hdxfNHxpOr82HGmEVVPJV+ApkAAECA+H71Pu/3Z/pskAQguBlj9Luz0xUfE6n/fue+17Z4+yFd+tJsvTFukFqlxDucEOEknP7p1nge2cMfAIAwsyUzX+v35UmSYqMiNLJTqsOJAPjbL0/tpD9f0E3G81v/5v35uuTF2Vq5q6r7b4D/hVLBPvK/nKQqnm9Q6XXHZK3tf7QvSWtrGhQAANSt732mh4/slKb4mFCaxAfgiHHD2+m5q/spxrMEZH9uka56Za5mbNjvcDKEi1Aq2Os8j1Wtse7keaxqjTYAAAhRFaaHd2N6OBDKzuvVTJNuHqTEOPc/pOUVlWrchAX6aPFOh5MhHIRSwZ7qeTzTGFPh72WMSZQ0XNJhSXPrOhgAAHBOZl6RFm47KEmKMNJpXRs7nAhAbRvSvpE+uGOYmiXFSZJKXVa/fn+ZXpy2STU4GRg4rqAr2MaYaGNMujGmg++4tXaTpO8ktZV0d6W3PSopQdIka21+nQQFAAABYcqaDB35fXpAmxQ1qh/rbCAAdaJL00R9dNcwdWmS6B379zdr9chnq1TmomSjdgTEAiRjzEWSLvJcNvU8DjXGTPR8n2mt/a3n+xaS1kjaJneZ9nWXpNmSnjHGnOZ53WBJp8g9NfyP/k8PAAACme/xXGcwPRwIK82S6un9O4bqtkkLNW/LAUnSG3O2aV9OkZ66qo/ioiMdTohQEyh3sPtIutHzdZZnrL3P2GXV+RDPXewBkibKXax/I6mDpGckDbXWZvkzNAAACGwFxaWasSHTe03BBsJPUr1oTbp5kM7r1cw79s2qvbr+9Xk6VMBZ2fCvgCjY1tpHrLXmGF9tfV67tfJYpc/aYa0dZ61tZq2Nsda2sdbea609UFd/HwAAEBimr89UUalLktS5SX21TU1wOBEAJ8RGRerZq/rq5hHtvGMLth7UZS/N0a5Dhx1MhlATEAUbAACgNvhODz+zW9NjvBJAqIuIMHr4/G566Lyu3rGNGXm65IVZWr07x8FkCCUUbAAAEJJKy1yasjbDe31md6aHA5BuGdlez1zdV9GRRpK0L6dIV7w8RzN9lpMAJ4uCDQAAQtKCrQd1qKBEktS0QZx6tkhyOBGAQPGL3s31xk2DlBhbflb2jRPma/zMLRzjhRqhYAMAgJD0/ep93u/P6NZExhgH0wAINMM6pOr9O4aqSQP30X1lLqu/fLFav/nfMhWWlDmcDsGKgg0AAEKOtZbjuQAcV9dmDfTp3SPUu1Wyd+yjxbt0xctztJvNz3ASKNgAACDkrNmTq50H3b8cJ8ZGaUj7Rg4nAhComibF6b3bhujy/i29Y8t3ZusXz83Ugq0cRIQTQ8EGAAAhx3d6+CnpjRUTxa88AKoWFx2pxy7rpb9c2F1REe7lJJl5xbr6lbmaPHcb67JRbfy0AQAAIYfp4QBOlDFGNwxtq8m3DFZKQowkqdRl9dAnK/WHj1eoqJR12Tg+CjYAAAgpuw4d1irPmbbRkUZjuqQ5nAhAMBnSvpE+v2eEujdv4B17Z/4OXf3KXO3LKXQwGYIBBRsAAISU71eV370e2iFViXHRDqYBEIxaJNfTB3cM00V9mnvHFm8/pAuenanF2w86mAyBjoINAABCync+66/PZHo4gJNULyZST17ZRw+d11WeZdnKyC3SVS/P1XsLtjsbDgGLgg0AAEJGdkGJ5m0p3/WX9dcAasIYo1tGttekmwYrOd49G6a4zKUHP1yhhz9ZqeJSl8MJEWgo2AAAIGRMWbdPZS73br+9WyWrSYM4hxMBCAUjOqXqs7tHKL1ponfszbnbdM2rc7WL87Lhg4INAABCxvdMDwdQS1o3itdHdw3Teb2aeccWbjuoc5+eoW999n5AeKNgAwCAkFBYUqZp6/Z7rynYAPwtPiZKz13dVw+ena5Iz8Ls7MMluv3NRfrzpytVWMJRXuGOgg0AAELC7E2ZKih2/3LbLjVBHRvXdzgRgFBkjNGdYzrovduGqHlS+TKUN+Zs08UvzNam/XkOpoPTKNgAACAkVJ4eboxxMA2AUDegbYq+undkhdkya/bk6IJnZ+qDRTsdTAYnUbABAEDQc7msvl+d4b1m93AAdSE5PkYvX99ff7mwu2Ki3NWqoLhMv/3fMt3/3lLlFZU6nBB1jYINAACC3pIdh5SZVyRJSq0fo76tGzqcCEC4MMbohqFt9fFdw9Q+LcE7/vGSXTr/mRlauSvbwXSoaxRsAAAQ9L5bXb6D72npTbybDwFAXenePEmf/3KELuvf0ju2NatAl7wwW+NnbpG11sF0qCsUbAAAEPS+X+Wz/ro708MBOCMhNkr/vby3nryytxJiIiVJxWUu/eWL1bp10kIdzC92OCFqGwUbAAAEtY0ZedqcmS9Jio+J1PCOqQ4nAhDuLu7bUl/8aqR6tGjgHfthTYbOeXqG5m7OcjAZahsFGwAABDXf6eGjOqUpLjrSwTQA4NYuNUEf3jlMNw1v5x3bm1Ooq1+dq79+sZozs0MUBRsAAAS1CsdzMT0cQACJjYrUny7optduGKDk+GhJkrXS6zO36NynZ2jRtoMOJ4S/UbABAEDQysgp1JLthyRJkRFGp6Y3djYQABzF6d2a6Ot7R2pU5zTv2ObMfF3+0mz986s13M0OIRRsAAAQtH5YU3729aC2KUqOj3EwDQBUrVlSPb0xbqD+dUlP1Y+NkiS5rPTy9M06/9mZWrrjkLMB4RcUbAAAELR8118zPRxAoDPG6KpBrfXNfSM1vGMj7/jGjDxd8sIsPfbNWhWVcjc7mFGwAQBAUMorKtXsjeW78Z7RjYINIDi0bBivyTcP1t8u6qF4z3FeLiu9MG2TfvHsLK3Yme1wQpwsCjYAAAhKP63br+IylySpW7MGatkw3uFEAFB9xhhdN6SNvr1vlIa0T/GOr9uXq4temKUnvlun4lKXgwlxMijYAAAgKPlOD+fuNYBg1SolXm/fMkSP/qK76nmOGSxzWT0zZaMufH6WVu/OcTghTgQFGwAABJ3SMpemri3f4Iz11wCCWUSE0Y3D2urre0dqYNuG3vE1e3L0i+dm6snv17PTeJCgYAMAgKCzZMch5RSWSpKaNohTt2YNHE4EADXXNjVB7942VA+f302xUe6qVuqyevrHDTrrqekV/mERgYmCDQAAgs5P6/Z7vx/TJU3GGAfTAID/REYY3Tyinb66d6T6tU72jm/LKtC4iQt066SF2nGgwLmAOCYKNgAACDrT1pffxRnTJc3BJABQOzqk1df/7himv17YXQ3iorzj36/ep9Of+EnP/LiBaeMBiIINAACCSkZuoVbucm/6ExVhNLxjqsOJAKB2REYYXT+0rab8doyuGNDSO15U6tIT36/XWU9N15S1+xxMiMoo2AAAIKhMX5/p/b5/m4ZKjIt2MA0A1L7U+rF67LLe+vDOYerevHzPiW1ZBbpp4kLd8gbTxgMFBRsAAASVaet8p4c3djAJANSt/m0a6rNfjtBfL+qhpHrl/7j4wxr3tPGnfmC3cadRsAEAQNAoLXNpxobyO9isvwYQbiIjjK4f0kZTfjNaVw1s5R0vKnXpqR826Mwnp+vHNUwbdwoFGwAABI1lOw8p+3CJJKlJg1ilN010OBEAOKNR/Vj969Je+viuYerZIsk7vv1AgW5+Y6FumrhAGzNyHUwYnijYAAAgaEzzOZ5rdGeO5wKAvq0b6pO7h+vvF1ecNj5lbYbOfHK6/u+jFcrIKXQwYXihYAMAgKAxrcL516y/BgDJPW382sFtNPW3Y3T1oFY68m+PLiu9M3+7Rv9nmp74fr3yikqdDRoGKNgAACAoZOYVacWubEnuXyY5ngsAKkpJiNE/L+mlL+4ZoZGdyv8bebikTM/8uEFj/jNVb87dppIyl4MpQxsFGwAABIXp68vvXvdv3bDCVEgAQLnuzZP05s2DNemmQerarPxYr8y8Yj38yUqd9eR0fbNyr6y1DqYMTRRsAAAQFCqsv2b3cAA4rlGd0/TFPSP0+OW91Twpzju+OTNfd0xepMtemqNF2w44mDD0ULABAEDAK3NZTd/gu/6agg0A1REZYXRp/5aa8tsx+v056UqMi/I+t2jbQV364hzd/uZCbdqf52DK0EHBBgAAAW/ZzkM6VOA+nistMVbdfKY8AgCOLy46UneM7qDpD5yim0e0U0xkeRX8dtU+nfnkdP3x4xXak33YwZTBj4INAAACHsdzAYB/NEyI0cPnd9OPvxmtC/s0946Xuazemrddox+bpj9/ulJ7szna62RQsAEAQMD7aV2G93umhwNAzbVKidfTV/XV578coaHtG3nHi8tcemPONo36z1Q98tkqivYJomADAICAlpVXpOWe47kijDSyIwUbAPylZ8skvX2re8fxvq2TvePFpS5NnL3VW7T35VC0q4OCDQAAAtqMDZk6cpJMv9YNlRTP8VwA4E/GGI3qnKaP7hymieMGqk+rZO9zR4r2yMfcRTuDon1MFGwAABDQpjE9HADqhDFGY7o01sd3DdOEcQPVu2WS9znfov3o5xTtqlCwAQBAwHK5rKZvyPRej+nS2ME0ABAejDE6pUtjfXL3cE0YO1C9fIp2UalLE2a5i/ZfPl+tjFyKti8KNgAACFjLd2XrQH6xJCm1PsdzAUBdMsbolPTG+vTu4Ro/dsDPivb4WVs08t9T9YePV2hLZr6DSQNH1PFfAgAA4Azf6eGjOqcqIoLjuQCgrhljdGp6E53SpbGmrM3QUz9s0ArP5pNFpS69PW+73pm/XWd2a6LbRrVX/zYpDid2DgUbAAAELN/zr5keDgDOMsbotK5NdGp6Y/24JkNP/1hetK2Vvl21T9+u2qf+bRrqtlHtdUbXJmH3D6MUbAAAEJAO5Bdr2c5DktzHc43qlOpsIACAJHfRPr1bE53WtbHmbM7SK9M3V/gH0UXbDur2NxepXWqCbhnZTpf2a6m46EgHE9cd1mADAICANGPDfu/xXH1aJSs5PsbZQACACowxGtYhVRPHDdK3943SZf1bKjqy/I71lsx8/fHjlRr+ryl6+ocN3j01QhkFGwAABKSfmB4OAEGjS9NE/ffy3pr54Km6Y3QHJcaVT5bOyi/Wkz+s17B//ag/fbpS27JCd0M0CjYAAAg4LpfVT+t9CzbnXwNAMGjSIE6/Pyddc/7vND10Xlc1T4rzPldY4tKkOdt0yn+n6e63Fqu0zOVg0tpBwQYAAAFn5e5sZXmmEjZKiFGP5knHeQcAIJDUj43SLSPb66ffnaKnr+pT4ZhFl5UKS8oUFRl6dZRNzgAAQMDx3SxnVOe0sNuFFgBCRXRkhC7s00K/6N1cszZm6ZUZmzV9/X7dNqq909FqBQUbAAAEHN/zr5keDgDBzxijEZ1SNaJTqjbtz1P71ASnI9UKCjYAAAgohwqKtXTHIUmSMdLIThRsAAglHdLqOx2h1gTUpHdjTEtjzHhjzG5jTJExZqsx5iljTMMT+Iytxhhbxdfe2swPAABqbvqGTLk8x3P1bpmslASO5wIABIeAuYNtjOkgabakxpI+lbRW0iBJ90o62xgz3FqbVc2Py5b01FHG8/wQFQAA1CKmhwMAglXAFGxJL8hdrn9lrX32yKAx5glJ90v6u6Q7qvlZh6y1j/g9IQAAqFUul9X09Znea86/BgAEk4CYIm6MaS/pTElbJT1f6ek/S8qXdL0xJjRXwgMAAEnS6j05yswrkiSlJMSoVwuO5wIABI9AuYN9qufxO2tthdPGrbW5xphZchfwIZJ+rMbnxRpjrpPUWu5yvlzSdGttmR8zAwAAP/OdHj6yUyrHcwEAgkqgFOwunsf1VTy/Qe6C3VnVK9hNJb1ZaWyLMWactfan6gQyxiyq4qn06rwfAACcON/zr1l/DQAINgExRVzSkflf2VU8f2Q8uRqfNUHSaXKX7ARJPSW9LKmtpK+NMb1POiUAAKg12QUlWrz9oCT38VyjOJ4LABBkAuUO9vEcmR9mj/dCa+2jlYZWSrrDGJMn6TeSHpF0cTU+p/9Rg7jvbPc73vsBAMCJmbFxv/d4rl4tktSofqyzgQAAOEGBcgf7yB3qqnYyaVDpdSfjJc/jqBp8BgAAqCW+08NHs3s4ACAIBUrBXud57FzF8508j1Wt0a6OI7umsBM5AAABxuWy+mk9668BAMEtUAr2VM/jmcaYCpmMMYmShks6LGluDf6MoZ7HzTX4DAAAUAtW78nR/lz38VzJ8dHq3TLZ2UAAAJyEgCjY1tpNkr6TeyOyuys9/ajcd50nWWvzJckYE22MSTfGdPB9oTGmuzEmpfLnG2PaSHrOcznZz/EBAEAN+d69HtkpTZEczwUACEKBtMnZXZJmS3rGGHOapDWSBks6Re6p4X/0eW0Lz/Pb5C7lR1wu6ffGmKmStkjKldRB0nmS4iR9Jem/tfq3AAAAJ+wn3+O5OjM9HAAQnAKmYFtrNxljBkj6i6SzJZ0raY+kZyQ9aq09UI2PmSr3mdp95Z4SniDpkKSZcp+L/aa19rg7kQMAgLqTfbhEizzHc0nSKAo2ACBIBUzBliRr7Q5J46rxuq0qP7rLd/wnST/5PxkAAKgtszZmqsxzPlfPFklKS+R4LgBAcAqINdgAACB8TV2b4f2e3cMBAMGMgg0AABxjbeXjuTj/GgAQvCjYAADAMav35CjD53iuPq2SnQ0EAEANULABAIBjpq3jeC4AQOigYAMAAMdwPBcAIJRQsAEAgCM4ngsAEGoo2AAAwBEczwUACDUUbAAA4Ajf47lO4XguAEAIoGADAIA6V/l4rtEczwUACAEUbAAAUOc4ngsAEIoo2AAAoM5xPBcAIBRRsAEAQJ3jeC4AQCiiYAMAgDpV+Xiu0WxwBgAIERRsAABQp2ZuKD+eq1fLJKXW53guAEBooGADAIA6NW1d+fFcTA8HAIQSCjYAAKgzHM8FAAhlFGwAAFBnOJ4LABDKKNgAAKDOcDwXACCUUbABAECd8T2e6xR2DwcAhBgKNgAAqBOVj+caxQZnAIAQQ8EGAAB1guO5AAChjoINAADqBMdzAQBCHQUbAADUOo7nAgCEAwo2AACodRzPBQAIBxRsAABQ63yP5xrF8VwAgBBFwQYAALXO93iuMRzPBQAIURRsAABQqzieCwAQLijYAACgVnE8FwAgXFCwAQBAreJ4LgBAuKBgAwCAWsPxXACAcELBBgAAtYbjuQAA4YSCDQAAag3HcwEAwgkFGwAA1JoK6685ngsAEOIo2AAAoFZkHy7R4u2HvNcczwUACHUUbAAAUCs4ngsAEG4o2AAAoFZUnB7O7uEAgNBHwQYAAH5X+Xgu1l8DAMIBBRsAAPid7/FcDeOj1btlsrOBAACoAxRsAADgd77Hc43keC4AQJigYAMAAL/jeC4AQDiiYAMAAL/ieC4AQLiiYAMAAL/yPZ6rN8dzAQDCCAUbAAD4le/08NEczwUACCMUbAAA4DcczwUACGcUbAAA4De+x3MlczwXACDMULABAIDf+B7PNYrjuQAAYYaCDQAA/MZ3/fUp6UwPBwCEFwo2AADwi+yC8uO5jHHfwQYAIJxQsAEAgF/M2LjfezxXrxZJasTxXACAMEPBBgAAfuG7/prjuQAA4YiCDQAAaszlqng81ykczwUACEMUbAAAUGOr9+Rov+d4robx0erF8VwAgDBEwQYAADXmu3v4qM4czwUACE8UbAAAUGO+669PYf01ACBMUbABAECNuI/nOijJczxXZ9ZfAwDCEwUbAADUyPQN++U5nUu9WiYrJSHG2UAAADiEgg0AAGrEd3r4GO5eAwDCGAUbAACctJ8dz5XO+msAQPiiYAMAgJO2aneOMvPcx3OlJMSoV4skhxMBAOAcCjYAADhpFY7n6pSqCI7nAgCEMQo2AAA4adOYHg4AgBcFGwAAnJRDBcVa4nM818hObHAGAAhvFGwAAHBSpm/I9B7P1ZvjuQAACKyCbYxpaYwZb4zZbYwpMsZsNcY8ZYxp6MTnAACAqvmuvx7ThbvXAABEOR3gCGNMB0mzJTWW9KmktZIGSbpX0tnGmOHW2qy6+hwAAFA1l8tquu/66y6svwYAIGAKtqQX5C7Fv7LWPntk0BjzhKT7Jf1d0h11+DkAAKAKK3dna2HpZVKc+9rV4pCjeQAACAQBMUXcGNNe0pmStkp6vtLTf5aUL+l6Y0xCXXwOAAA4tmnr9le45nguAAACpGBLOtXz+J211uX7hLU2V9IsSfGShtTR5wAAgGPwXX8NAADcAqVgd/E8rq/i+Q2ex8519Dkyxiw62pek9OO9FwCAUHYwv1hLdhxyOgYAAAEnUAp2kucxu4rnj4wn19HnAACAKkzfsF/WOp0CAIDAE0ibnB3LkYVdNf1xXu3Psdb2P+oHuO9i96thDgAAgtZPldZfAwAAt0C5g33kznJSFc83qPS62v4cAABwFC6X1U/rKdgAABxNoNzBXud5rGptdCfPY1Vrq/39OQAA4ChW7MpWVn6xJGlA1Aea/4fT2UEcAACPQLmDPdXzeKYxpkImY0yipOGSDkuaW0efAwAAjsL3eK5RndIo1wAA+AiIgm2t3STpO0ltJd1d6elHJSVImmStzZckY0y0MSbdGNOhJp8DAABOzLT15cdzjUlv7GASAAACT6BMEZekuyTNlvSMMeY0SWskDZZ0itxTuv/o89oWnue3yV2mT/ZzAABANR3IL9ZSz/FcEUYa1SnV2UAAAASYgLiDLXnvPg+QNFHuQvwbSR0kPSNpqLU2qy4/BwAAVDTD53iuPq2SlRwf42wgAAACTCDdwZa1doekcdV43VaVH7l10p8DAACqz3f99ZguTA8HAKCygLmDDQAAAlfl47lOoWADAPAzFGwAAHBcy3dl64DneK7U+jHq3ryBw4kAAAg8FGwAAHBc09aV7x4+qjPHcwEAcDQUbAAAcFysvwYA4Pgo2AAA4Jiy8oq0bOchSRzPBQDAsVCwAQDAMc3YkOk9nqtv64YczwUAQBUo2AAA4Jh811+P6ZzmYBIAAAIbBRsAAFSprPLxXOmsvwYAoCoUbAAAUKXlOw/pYEGJJCm1fqy6NeN4LgAAqkLBBgAAVfLdPXw0x3MBAHBMFGwAAFClaet9j+di/TUAAMdCwQYAAEeVlVek5RWO56JgAwBwLBRsAABwVDM3VjyeKyk+2tlAAAAEOAo2AAA4qhkbMr3fj+Z4LgAAjouCDQAAfsZaqxkbytdfj+yU6mAaAACCAwUbAAD8zIaMPO3LKZIkNYiLUq+Wyc4GAgAgCFCwAQDAz0z32T18eMdURXI8FwAAx0XBBgAAP+O7/noku4cDAFAtFGwAAFBBYUmZ5m3J8l6z/hoAgOqhYAMAgAoWbTuowhKXJKldaoJapcQ7nAgAgOBAwQYAABVMZ/dwAABOCgUbAABUMGM9668BADgZFGwAAOC1P7dIq/fkSJKiIoyGtE9xOBEAAMGDgg0AALxmbSy/e92vdUMlxkU7mAYAgOBCwQYAAF6svwYA4ORRsAEAgCTJWlvx/OvOrL8GAOBEULABAIAkad2+XO3PLZIkJdWLVs8WSQ4nAgAguFCwAQCApIq7h4/omKrICONgGgAAgg8FGwAASGL9NQAANUXBBgAAKiwp0/wtB7zXIyjYAACcMAo2AADQgq0HVFTqkiS1T0tQy4bxDicCACD4ULABAECF3cNHdWL3cAAATgYFGwAAaPp61l8DAFBTFGwAAMJcRk6h1u7NlSRFRxoNad/I4UQAAAQnCjYAAGFu5sby6eH9WjdUQmyUg2kAAAheFGwAAMJchfXXnVl/DQDAyaJgAwAQxlwuW6Fgs/4aAICTR8EGACCMrd2bq8y8IklSw/hodW+e5HAiAACCFwUbAIAwNmND+e7hwzumKjLCOJgGAIDgRsEGACCMcf41AAD+Q8EGACBMFZaUaf7WA97rEay/BgCgRijYAACEqflbDqi41CVJ6ti4vpon13M4EQAAwY2CDQBAmPJdf83u4QAA1BwFGwCAMMX6awAA/IuCDQBAGMrIKdTavbmSpOhIo8HtUxxOBABA8KNgAwAQhnzvXg9ok6L4mCgH0wAAEBoo2AAAhKEK6687s/4aAAB/oGADABBmXC6rmRtZfw0AgL9RsAEACDNr9uYoM69YkpSSEKNuzRo4nAgAgNBAwQYAIMz4rr8e0TFVERHGwTQAAIQOCjYAAGGG868BAKgdFGwAAMLI4eIyLdhy0Hs9kvXXAAD4DQUbAIAwMm9LlorLXJKkzk3qq2lSnMOJAAAIHRRsAADCiO/6a+5eAwDgXxRsAADCCOuvAQCoPRRsAADCxN7sQq3flydJiomM0OB2jRxOBABAaKFgAwAQJnzvXg9s11D1YiIdTAMAQOihYAMAECZYfw0AQO2iYAMAEAZcLquZG30LNuuvAQDwNwo2AABhYPWeHB3IL5YkpdaPUdemDRxOBABA6KFgAwAQBn5aX77+enjHVEVEGAfTAAAQmijYAACEgek+BXsU668BAKgVAVOwjTHDjDFfGWMOGGMKjDHLjTH3GWOqvcWpMaatMcYe4+vd2vw7AAAQiPKKSrVo20Hv9cjOrL8GAKA2RDkdQJKMMRdK+lBSoaT3JB2QdIGkJyUNl3T5CX7kMkmfHGV85cmnBAAgOM3ZlKVSl5UkdW3WQI0T4xxOBABAaHK8YBtjGkh6VVKZpDHW2oWe8YclTZF0mTHmKmvtidx9XmqtfcTvYQEACEK+51+PYvdwAABqTSBMEb9MUpqkd4+Ua0my1hZKeshzeacTwQAACAUV1l93Zv01AAC1xfE72JJO9Tx+c5TnpksqkDTMGBNrrS2q5mc2N8bcLqmRpCxJc6y1y2seFQCA4LI9q0BbswokSfWiIzWgbUOHEwEAELoCoWB38Tyur/yEtbbUGLNFUndJ7SWtqeZnnuH58jLGTJN0o7V2+8lHBQAguPzkMz18SPsUxUZVe+9QAABwggKhYCd5HrOreP7IeHI1PqtA0l/l3uBss2esl6RHJJ0i6UdjTB9rbf7xPsgYs6iKp9KrkQMAgIDA9HAAAOqOX9ZgG2O2Hud4rMpfk0/k4z2P9ngvtNZmWGv/ZK1dbK095PmaLulMSfMkdZR0y4n/DQEACD4lZS7N2ZTlvaZgAwBQu/x1B3uT3EdsVddun++P3KFOOtoLJTWo9LoT5plq/pqkwZJGSXq6Gu/pf7Rxz53tfiebBQCAurJk+yHlFZVKklok11P71ASHEwEAENr8UrCttafV4O3rJA2Q1FlShWnZxpgoSe0klap8yvfJOjJHLqR/u1i645CiIox6tKjq3ysAAOGi4vTwVBljjvFqAABQU4FwTNcUz+PZR3lulKR4SbNPYAfxqgzxPNa0qAe0f3y5Ruc/O1OXvDBLnyzZpaLSMqcjAQAcMr3C+ddMDwcAoLYFQsH+QFKmpKuMMQOODBpj4iT9zXP5ou8bjDFJxph0Y0yzSuODjTExlf8AY8ypku73XJ7I+u+gsmZPjuZvPSBJWrz9kO57b6mG/2uK/vvtOu0+dNjhdACAunQgv1grdrlXV0VGGA3rmOpwIgAAQp/jBdtamyPpVkmRkqYZY14zxjwmaamkoXIX8Pcqve1iuY/s+mel8X9L2mWM+Z8x5knP14+SfpQUK+lha+3s2vvbOCs2KkIX9Wmu6MjyKYCZecV6bupGjfj3FN3+5kLN2pgpa4+7XxwAIMjN3JipI/+579MqWUn1op0NBABAGAiEY7pkrf3EGDNa0h8lXSopTtJGSb+W9IytfiN8U+7yPVDSOZKiJe2T9L6k56y1M/ydPZC0T6uvp67qqz+e103vLdiut+Zt155s995zLit9u2qfvl21Tx0b19f1Q9rokn4tlBjHL1wAEIp811+P7MTdawAA6oLhbuaJMcYs6tevX79Fi6o6JjtwlJa59MOaDE2as1WzfY5pOSIhJlIX92uhG4a2VecmiQ4kBADUBmuthvzzR+3LcW9f8tFdw9SvdUOHUwEAEBz69++vxYsXL67qZKljCYg72KgdUZEROrtHU53do6k2ZuTqzTnb9OHiXd4jW/KLyzR57nZNnrtdQ9qnaOywdjqzWxNFRLDLLAAEs3X7cr3lOqletHq3THY2EAAAYYKCHSY6Nk7Uoxf20ANnp+vjxTs1ac42bcjI8z4/d/MBzd18QO1TE3TLyPa6pF8LxUVHOpgYAHCyfKeHj+iYqkj+4RQAgDrh+CZnqFv1Y6N0/dC2+u7+UXrn1iE6p0fTCr94bc7M1x8+XqER/56i56Zs0KGCYgfTAgBOxvT1md7vR3Vm/TUAAHWFO9hhyhijoR0aaWiHRtqTfViT5mzT5LnblFvonj6emVes/363Xi9M26QrBrTSzSPaqVVKvMOpAQDHc7i4zHtkoySN5PxrAADqDHewoWZJ9fTg2ema83+n6aHzuqpZUpz3uYLiMk2cvVVj/jtNv3pniVZ6zlQFAASmeVuyVFzqkiR1bFxfzZPrOZwIAIDwQcGGV/3YKN0ysr2m/+4UPXFFb6U3Ld9ZvMxl9dmy3Tr/2Zm67rV5mr5+P+dpA0AAqjA9nLvXAADUKaaI42eiIyN0Sb+WurhvC03fkKmXf9pU4ZivmRszNXNjpro2a6A7RrfX+b2as4EOAASI6RvKNzhj/TUAAHWLO9iokjFGozun6e1bh+jzX47QBb2by7dHr9mTo3vfXaozn/xJny7dpTIXd7QBwEm7Dx3WRs8JETFRERrcrpHDiQAACC8UbFRLz5ZJevbqvvrpgVM0dlhb1fM5wmvT/nzd++5SnfHkT/pkCUUbAJwyw+fu9eB2KaoXw3GLAADUJQo2TkirlHg98ovumv37U/WrUzsqMbZ8lcHm/fm67z2KNgA4hfXXAAA4i4KNk9IwIUa/PrOLZj54qn51WqejF+0nftLHS3aqtMzlYFIACA9lLquZG8sL9kjWXwMAUOco2KiRpPho/fqMzpr54Km6t3LRzszX/e8t0xlPTtdHiynaAFCblu08pOzDJZKkJg1i1aVJ4nHeAQAA/I2CDb9Iio/W/b5FO668aG/JzNev36doA0Btmr6+fP31yE5pMobTHQAAqGsUbPiVb9G+7/SjF+0zn5yub1bu5RxtAPAj34I9qjPrrwEAcAIFG7UiqV607jvdXbTvP71zhaK9OTNfd0xepMtemqNF2w44mBIAQkP24RIt3XFIkmSMNKIj668BAHACBRu1KqletO49vdNRi/aibQd16YtzdMebi7R5f56DKQEguM3emKkjBzf0bJGklIQYZwMBABCmKNioE0eK9k8PnKKbhrdTdGT52sBvVu3VGU9O18OfrNT+3CIHUwJAcJruc/41x3MBAOAcCjbqVEpCjP50QTf9+OsxuqB3c+94mcvqzbnbNOY/U/XMjxtUUFzqYEoACB7W2ornX7P+GgAAx1Cw4YjWjeL17NV99endwzW4XYp3PL+4TE98v16j/zNN78zfzo7jAHAcm/bna9ehw5Kk+rFR6ts62dlAAACEMQo2HNW7VbLevW2Ixo8doE6N63vH9+cW6f8+WqGzn56h71fvY8dxAKjCDJ/p4cM6NFJ0JD/aAQBwCj+F4ThjjE5Nb6Kv7x2pf1/aU40TY73PbczI062TFuqqV+Zq7d4cB1MCQGDieC4AAAIHBRsBIyoyQlcObK1pD4zRb8/srPqx5TuOz9tyQOc9M1N//WK1cgtLHEwJAIGjqLRMczeXH3fIBmcAADiLgo2AEx8TpV+e2knTHhijG4e2UVSEe8fxMpfV6zO36LTHf9KnS3cxbRxA2Fu49aAOl5RJkto2ilfrRvEOJwIAILxRsBGwUuvH6tELe+ire0dW2AgtI7dI9767VNe8Ok8b9uU6mBAAnMX0cAAAAgsFGwGvc5NEvXvbED19VR+l+azPnrM5S+c8PUP//GqN8os41gtA+Jm+wed4LqaHAwDgOAo2goIxRhf2aaEpvxmtm4a3U6Rn2nipy+rl6Zt12uM/6cvle5g2DiBsZOQWas0e9+aP0ZFGQzs0cjgRAACgYCOoJMZF608XdNMX94zQwLYNveN7cwp199uLdcP4+dq0P8/BhABQN2asL7973a91QyX4bAwJAACcQcFGUOrarIHev32oHr+8t1Lrx3jHZ2zI1NlPTdd/vl2rgmKmjQMIXdM3sP4aAIBAQ8FG0DLG6NL+LfXjb9y7jXtmjaukzOr5qZt0xhPTNdNnfSIAhAqXy2qGz3/fRlOwAQAICBRsBL2ketF69MIe+uyXI9S3dbJ3fNehw7ru9Xl66JMVbIIGIKSs2p2jA/nFkqRGCTHq1qyBw4kAAIBEwUYI6dEiSR/eMUyPXdpLyfHR3vHJc7fr7Kena+7mLAfTAYD/TFmb4f1+ZKdURRyZwgMAABxFwUZIiYgwumJgK313/yid0a2Jd3zHgcO66pW5evTzVTpcXOZgQgCoue/X7PV+f2rXJsd4JQAAqEsUbISkxolxeuX6/nryyt5qEFe+s+6EWVt17jMztGjbAQfTAcDJ233osFbuKj+ea0wX1l8DABAoKNgIWcYYXdy3pb67f3SFX0C3ZObrspfm6B9frVFhCXezAQSXH9bs834/pH0jNYiLPsarAQBAXaJgI+Q1TYrThLED9dilvVTfc06stdIr0zfrvGdmaOmOQ84GBIAT8P3q8oLtuxQGAAA4j4KNsGCMe232t/eP0oiOqd7xTfvzdckLs/Sfb9eqqJS72QACW05hSYUNG09n/TUAAAGFgo2w0iK5nt68eZD+fnEPxcdESpJcVnp+6iZd+NwsrdyV7XBCAKjatHX7VVJmJUk9WjRQ8+R6DicCAAC+KNgIO8YYXTu4jb69b5SGtE/xjq/dm6uLnp+lV6ZvkrXWwYQAcHS+08PP7NbUwSQAAOBoKNgIW61S4vX2LUP0yAXdFBft/p9CqcvqH1+t1a2TFupQQbHDCQGgXHGpS9N8zr9m/TUAAIGHgo2wFhFhNHZ4O3197yj1bpXsHf9hTYbOe2amFm8/6Fw4APAxb0uWcotKJUktG9ZTetNEhxMBAIDKKNiApHapCfrf7UN1y4h23rFdhw7ripfm6LUZm5kyDsBxlXcPN8Y4mAYAABwNBRvwiImK0EPnd9Mr1/dXgzj3cV6lLqu/fblGt05axJRxAI6x1uoHjucCACDgUbCBSs7s3lRf/mpkpSnj+3TeMzO1hCnjABywaneOdmcXSpKS6kVrUNuU47wDAAA4gYINHEWrlHj97/ahuml4pSnjL8/R6zO3MGUcQJ36zufu9anpjRUVyY9vAAACET+hgSrEREXoTxd008vX91eiZ8p4SZnVX79YrdveXKTsghKHEwIIF5XXXwMAgMBEwQaO46zuTfXVr0aqd8sk79j3q/fpvGdnaOmOQ84FAxAWdhwo0Jo9OZKkmMgIjeqc5nAiAABQFQo2UA2tUuL1vzuGadzwtt6xnQcP6/KXZms8U8YB1KIf1pTfvR7WsZHqx0Y5mAYAABwLBRuoppioCP35gu566bp+FaaM/+WL1frVu0t1uLjM4YQAQhHTwwEACB4UbOAEnd2jmb68Z6R6+UwZ/3zZbl364mztOFDgYDIAoSa7oETzthzwXp/elYINAEAgo2ADJ6F1o3j9746hunZwa+/Y6j05uvD5WZqzKcvBZABCydR1GSpzuZeg9G6VrCYN4hxOBAAAjoWCDZyk2KhI/f3invrnJT0VHWkkSQfyi3Xd6/M0cRbrsgHUnO/08DOZHg4AQMCjYAM1dPWg1nrn1iFKrR8rSSpzWT3y+Wo9+OFyFZWyLhvAySkqLdO0dRnea9ZfAwAQ+CjYgB8MaJuiz+8ZXuEor/cX7tSVL8/VvpxCB5MBCFZzNmUp37N5YptG8erUuL7DiQAAwPFQsAE/aZZUT+/dPlSX9GvhHVu645AueHamFm8/6GAyAMGowu7hXZvIGONgGgAAUB0UbMCP4qIj9fjlvfXw+d0UGeH+ZTgjt0hXvTxX7y3Y7nA6AMHC5bIVzr9mejgAAMGBgg34mTFGN49op0k3DVJyfLQkqbjMpQc/XKE/f7pSJWUuhxMCCHQrdmVrX06RJKlhfLT6t2nocCIAAFAdFGyglgzvmKrP7h6h9KaJ3rE35mzTda/NU1ZekYPJAAQ63+nhp6Y3UVQkP64BAAgG/MQGalHrRvH66K5hOq9nM+/YvC0H9IvnZmn17hwHkwEIZBXWXzM9HACAoEHBBmpZfEyUnrumrx44q4uO7FG069BhXf7SbE1dm3HsNwMIO9uy8rVuX64kKTYqQqM6pzqcCAAAVBcFG6gDxhjdfUpHvXbDACXGRkmS8ovLdPMbC/TG7K3OhgMQUHzvXo/omKr4mCgH0wAAgBNBwQbq0Gldm+jDu4apRXI9SZLLSn/+bJUe+WyVylzW4XQAAsF3TA8HACBoUbCBOta5SaI+uXu4erdK9o5NnL1Vt01aqPyiUueCAXDcgfxiLdx6QJJkjPsf5QAAQPCgYAMOSEuM1bu3DtE5PZp6x35cm6ErXp6jvdmFDiYD4KQpazN0ZDJL31bJSkuMdTYQAAA4IY4XbGNMtDHmXmPMBGPMUmNMsTHGGmNuqcFnDjPGfGWMOWCMKTDGLDfG3GeMifRndqAm6sVE6vlr+umO0R28Y6t25+ii52dp1e5sB5MBcMr3q/d6vz+jW9NjvBIAAAQixwu2pARJT0kaK6mppL3HevHxGGMulDRd0ihJH0t6XlKMpCclvVuTzwb8LSLC6PfnpOtfl/RUVIR7i/G9OYW6/KU5+nHNvuO8G0AoKSwp0/T1md7rM7szPRwAgGATCAW7QNK5kppba5tKGn+yH2SMaSDpVUllksZYa2+21j4gqY+kOZIuM8ZcVfPIgH9dNai1Jo4bpMQ4927BBcVlunXSQk2YtcXhZADqyqyNmTpcUiZJap+WoA5p9R1OBAAATpTjBdtaW2yt/dpau8cPH3eZpDRJ71prF/r8GYWSHvJc3umHPwfwuxGdUvXRncPUsmH5DuOPfr6aHcaBMPE9u4cDABD0HC/Yfnaq5/Gbozw3Xe675cOMMewag4DUqUmiPr5ruPpU2mH81kkLlccO40DIcrmsfliT4b0+k4INAEBQCrWC3cXzuL7yE9baUklbJEVJan+8DzLGLDral6R0vyYGKklLjNW7tw3ReT2becemrM3Q5S/N0Z7sww4mA1Bbluw4pMy8IklSav0Y9WnV0OFEAADgZIRawU7yPFa1BfOR8eTajwKcvLjoSD17dV/dNaZ8h/E1e3J02YtztHl/noPJANQG3+nhp6U3UaRn00MAABBc/FKwjTFbPUdrVfdrsj/+3JOJ6nk87oJWa23/o31JWlu7EQG3iAij352drscu7eXdYXzXocO64uU5HOMFhJiKx3MxPRwAgGAV5afP2SSp8ARev9tPf25lR1pHUhXPN6j0OiDgXTGwlZokxen2NxeqsMSlzLxiXfXyXI0fN1AD26Y4HQ9ADW3en6dN+/MlSfWiIzWiU6rDiQAAwMnyyx1sa+1p1tr0E/j6nT/+3KNY53nsXPkJY0yUpHaSSiVtrqU/H6gVozunafLNg73HeOUWler61+dp6tqM47wTQKD7dlX59PCRnVIVFx3pYBoAAFATobYGe4rn8eyjPDdKUryk2dbaorqLBPjHgLYpeu+2oUqt794Ev7DEpVsnLdRny2prQgiAuvDp0l3e78/u0dTBJAAAoKaCsmAbY5KMMenGmGaVnvpAUqakq4wxA3xeHyfpb57LF+soJuB33Zo30P/uGKoWye6zsktdVve+u0ST525zOBmAk7FmT47W7s2V5J4eflZ3CjYAAMEsIAq2Meb3xpiJxpiJki7yDI87MmaMuaXSWy6WtEbSP30HrbU5km6VFClpmjHmNWPMY5KWShoqdwF/r9b+IkAdaJeaoA/vHKaOjetLkqyVHvpkpZ6fulHWHnf/PgAB5BOfu9dndGuihFh/bY0CAACcEBAFW+4p3Td6vnp7xob5jI2o7gdZaz+RNFrSdEmXSrpHUomkX0u6ytJAEAKaJsXp/duHqnfL8v38/vPtOv3r67WUbCBIuFxWny0tX+JxUd/mDqYBAAD+EBD/VG6tHXOCr58oaeIxnp8l6dwahQICXEpCjN66dYhufWOh5mzOkiS9PH2zsg+X6O8X9+QcXSDAzdtyQHuy3QdwpCTEaGSnNIcTAQCAmgqUO9gATkL92ChNGDewwrm57y7YoV+9s0RFpWUOJgNwPJ8sKZ8efn6vZoqO5EcyAADBjp/mQJCLi47Ui9f20yX9WnjHvlyxR7e8sVAFxaUOJgNQlcKSMn21co/3+qK+LY7xagAAECwo2EAIiIqM0H8v662xw9p6x2ZsyNR1r81TdkGJc8EAHNXUtRnKLXT/A1ibRvHq2yrZ2UAAAMAvKNhAiIiIMPrzBd10/+mdvWOLtx/SNa/NpWQDAcZ39/AL+7SQMeyZAABAKKBgAyHEGKN7T++kP1/QzTu2aneObpgwX7mFlGwgEGQXlGjq2v3e64v6sHs4AAChgoINhKBxw9vp35f29F4v23FI4yYsUH4Ra7IBp321co+Ky1ySpN4tk9Q+rb7DiQAAgL9QsIEQdeXA1vrrRT281wu3HdTNbyzQ4WJ2Fwec9PGSitPDAQBA6KBgAyHs+iFt9PD55dPF524+oNveXKjCEko24IRdhw5r/pYDkqTICKMLejM9HACAUELBBkLczSPa6cGz073XMzZk6q63Fqu41OVgKiA8feqzudnwjqlKS4x1MA0AAPA3CjYQBu4c06HC7uJT1mbonncWq6SMkg3UFWutPvGZHn5xX+5eAwAQaijYQJj41WkddfcpHbzX367ap/vfW6pSSjZQJ9bsydX6fXmSpHrRkTqzW1OHEwEAAH+jYANhwhij357ZRbeObOcd+2L5Hv3ug+Uqc1kHkwHhwXd6+JndmyghNsrBNAAAoDZQsIEwYozRH87tqhuHtvGOfbRkl/748Qq5KNlArSlzWX26dLf3+iJ2DwcAICRRsIEwY4zRny/orqsHtfKOvbtgh/782SpZS8kGasO8LVnam1MoSWqUEKMRnVIdTgQAAGoDBRsIQxERRn+/qKcu7dfSO/bm3G3625drKNlALfDd3Oz8Xs0UHcmPXwAAQhE/4YEwFRFh9NhlvfQLn3N4X5+5RY99u46SDfhRYUmZvl6x13t9UV+mhwMAEKoo2EAYi4wweuKK3jqnR/luxi9O26Snf9zgYCogtExZm6HcolJJUptG8erTKtnZQAAAoNZQsIEwFxUZoaev6qvTuzb2jj31wwZNmLXFwVRA6PjYZ3r4RX1ayBjjYBoAAFCbKNgAFBMVoeev7adRndO8Y49+vlofLd7pYCog+B0qKNa0dRnea6aHAwAQ2ijYACRJsVGReum6furfpqF37IEPluv71fscTAUEty9X7FFJmXtPg96tktUuNcHhRAAAoDZRsAF4xcdEafyNA5XeNFGS++zeu99erDmbshxOBgSnT5f4nn3d/BivBAAAoYCCDaCCpPhoTbppkNo0ipckFZe6dOukhVqxM9vhZEBw2XmwQPO3HpDk3lDw/F4UbAAAQh0FG8DPNG4Qp8k3D1bjxFhJUl5RqW6cMF8bM/IcTgYEj0+Xlt+9HtExVWme/z0BAIDQRcEGcFStUuL15s2DlVQvWpJ0IL9YN7w+T7sOHXY4GRD4rLX6xGf38IvZ3AwAgLBAwQZQpS5NEzVh3EDFx0RKknZnF+r61+cpK6/I4WRAYFu9J0cbPDM+6kVH6oxuTRxOBAAA6gIFG8Ax9WvdUC9f31/Rke6zezfvz9eNE+Yrt7DE4WRA4PK9e31W9yZKiI1yMA0AAKgrFGwAxzWyU5qevqqvItwdWyt35eiWNxaqsKTM2WBAACpzWX22rHz99YVMDwcAIGxQsAFUy7k9m+kfF/f0Xs/bckC/fHuxSspcDqYCAs/czVnal+NeRtEoIUYjO6Y6nAgAANQVCjaAartqUGv93znp3usf1mTowQ+Wy+WyDqYCAovv9PALejdXVCQ/agEACBf81AdwQm4f3UF3jungvf5oyS795YvVspaSDRSWlOnrlXu91xcxPRwAgLBCwQZwwn53VhddPai193ri7K165seNDiYCAsOPazKUV1QqSWrbKF69WyY5nAgAANQlCjaAE2aM0d8u6qHzejbzjj35w3pNnrvNwVSA895buMP7/YV9WsgY42AaAABQ1yjYAE5KZITRk1f20chO5Rs4PfzpSn21Yo+DqQDnbM8q0IwN+yVJxkiX9W/pcCIAAFDXKNgATlpMVIReuq6/erdKliRZK9337lLN3pjpbDDAAe8s2K4jWxGM7pymVinxzgYCAAB1joINoEYSYqM0YexAtU9LkCQVl7l025uLtHJXtsPJgLpTXOrS/3ymh1/js0cBAAAIHxRsADWWkhCjSTcNUtMGcZKkvKJSjZ0wX1sz8x1OBtSN71fvU2ZesSSpaYM4nZre2OFEAADACRRsAH7RsmG83rhpkBrERUmSMvOKdcP4+crILXQ4GVD73ppXvsHflQNbcfY1AABhit8AAPhNl6aJGj92oGKj3P9p2X6gQDeOX6CcwhKHkwG1Z0tmvmZvypIkRRjpqkGtHE4EAACcQsEG4FcD2qbohWv7KTLCfTzRmj05uvWNhSosKXM4GVA73pm/3fv9qemN1SypnoNpAACAkyjYAPzutK5N9K9Lenqv5205oPveXaoyl3UwFeB/RaVlFTY3u3ZwGwfTAAAAp1GwAdSKywe00u/PSfdef7Nqrx76ZKWspWQjdHyzcq8OFriXQLRIrqdRndMcTgQAAJxEwQZQa24f1V63jGjnvX5n/nY9+f16BxMB/vXWvPLp4VcNbOVdGgEAAMITBRtArTHG6A/ndtXFfVt4x56ZslFvzN7qXCjATzZm5Gr+lgOSpMgIoysGsrkZAADhjoINoFZFRBg9dlkvjelSPnX2kc9X6Yvlux1MBdSc793rM7o2URPPOfAAACB8UbAB1LroyAi9cG0/9W2dLEmyVrr/vaWauSHT2WDASSosKdOHi3Z6r68Z3NrBNAAAIFBQsAHUifiYKI2/caA6Nq4vSSops7r9zYVauSvb4WTAifty+R7lFJZKklqnxGtEx1SHEwEAgEBAwQZQZxomxGjSTYPULMk9lTa/uExjJyzQjgMFDicDTsxb87Z5v796UGtFsLkZAAAQBRtAHWueXE+TbhqkBnFRkqTMvCLdMH6+DuQXO5wMqJ61e3O0ePshSVJ0pNHlA1o6GwgAAAQMCjaAOtepSaJeu3GgYqLc/wnakpmvmyYu0OHiMoeTAcf3ts/mZmd2b6rU+rEOpgEAAIGEgg3AEYPapeiZq/rIeGbWLt1xSL98e7FKy1zOBgOOoaC4VB8v3uW9vpbNzQAAgA8KNgDHnN2jmR79RXfv9Y9rM/TQJytlrXUwFVC1z5ftVm6Re3Oz9qkJGtq+kcOJAABAIKFgA3DUDUPb6q4xHbzX7y7Yoad/3OBgIqBqvtPDrx7UWsawuRkAAChHwQbguAfO6qJL+rXwXj/1wwa9M3/7Md4B1L2Vu7K1bKf7WLmYyAhd2p/NzQAAQEUUbACOM8bo35f20qjOad6xP368Qj+u2edgKqCit3zuXp/bs6lSEmIcTAMAAAIRBRtAQIiOjNAL1/ZTzxZJkiSXle5+e7EWbz/ocDJAyisq1WdLyzc3u2ZwGwfTAACAQEXBBhAw6sdGafzYgWqVUk+SVFji0s0TF2jT/jyHkyHcfbp0l/I9x8h1bFxfA9s2dDgRAAAIRBRsAAElLTFWk24a7J1+e7CgRDeOn6+M3EKHkyFcWWv11tzy6eHXDmZzMwAAcHQUbAABp11qgsaPHah60ZGSpJ0HD2vchAXKLSxxOBnC0bKd2Vq9J0eSFBsVoUv6srkZAAA4Ogo2gIDUp1Wynr+2ryIj3HcKV+3O0Z2TF6u41OVwMoSbt+dt835/fq/mSoqPdjANAAAIZBRsAAHr1PQm+ufFPb3XMzdm6sEPl8vlsg6mQjjJPlyiz5bt9l5fM7i1g2kAAECgo2ADCGhXDGylX5/R2Xv98ZJd+u936xxMhHDyyZJdKixxz5pIb5qofq2TnQ0EAAACGgUbQMC759SOunpQ+Z3DF6Zt0uS5247xDqDmrLV6ex6bmwEAgOpzvGAbY6KNMfcaYyYYY5YaY4qNMdYYc8tJfFZbz3ur+nq3Nv4OAGqXMUZ/vbC7Tktv7B3706cr9cPqfQ6mQqhbtO2g1u3LlSTVi47UhX1bOJwIAAAEuiinA0hKkPSU5/t9kvZKalXDz1wm6ZOjjK+s4ecCcEhUZISevaavrn5lrpbtzJbLSr98Z7HevW2o+rRKdjoeQtCE2Vu931/Yp7kaxLG5GQAAODbH72BLKpB0rqTm1tqmksb74TOXWmsfOcrXB374bAAOiY+J0ms3DlTrlHhJUmGJSzdPXKBtWfkOJ0Oo2bAvV1+t2OO9vm5IGwfTAACAYOF4wbbWFltrv7bW7jn+qwGEu7TEWE0cN1ANPUclZeUX68bx85WVV+RwMoSSZ6ZslPVsVn9qemP1aJHkbCAAABAUHC/YtaS5MeZ2Y8wfPI+9nA4EwH/ap9XXazcOUGyU+z9hW7MKdMukhTpcXOZwMoSCjRm5+mJ5+dFc957WycE0AAAgmIRqwT5D0kuS/u55XGaMmWqM4QBTIET0b5Oip6/qqyObOi/Zfkj3vrtEZZyRjRp65sfyu9endElTb9b4AwCAagq1gl0g6a+S+ktq6PkaLWmqpDGSfjTGJFTng4wxi472JSm9dqIDOFFn92iqP5/fzXv93ep9+svnq2QtJRsnZ2NGnj73vXt9eudjvBoAAKAivxRsY8zW4xyPVflrsj/+3MqstRnW2j9Zaxdbaw95vqZLOlPSPEkdJZ3w8V8AAtfY4e1068h23us35mzTqzM2O5gIwey5KRu8d6/HdEljh3oAAHBC/HVM1yZJhSfw+t3Hf4n/WGtLjTGvSRosaZSkp6vxnv5HG/fcxe7n34QAauL/zumq3dmF+nK5e6/Ef3y1Vk2T6ukXvZs7nAzBZNP+PH22jLXXAADg5PmlYFtrT/PH59Sy/Z7Hak0RBxA8IiKMHr+8t/bnFmn+lgOSpN++v0yNE2M1pH0jh9MhWDw3ZaOOLOEf1TlNfVs3dDYQAAAIOqG2BvtYhngemTsKhKC46Ei9cn1/dWxcX5JUXObSbZMWav2+XIeTIRhs3p+nT5fu8l5z9xoAAJyMoCzYxpgkY0y6MaZZpfHBxpiYo7z+VEn3ey5rZf03AOclx8do4riBSkuMlSTlFJZq7Pj52pdzIitYEI58716P7JSq/m24ew0AAE5cQBRsY8zvjTETjTETJV3kGR53ZMwYU3ljsoslrZH0z0rj/5a0yxjzP2PMk56vHyX9KClW0sPW2tm19zcB4LSWDeM1YexAJcRESpJ2Zxdq7IQFyikscTgZAtWWzHx94nP3+r7TuXsNAABOTkAUbElnS7rR89XbMzbMZ2xENT/nTbl3Cx8o6VZJd0nqJOl9SaOstX/zY2YAAapHiyS9cF1/RUa4D8lesydHt76xUIUlZQ4nQyB6dsqGSnevU5wNBAAAglZAFGxr7RhrrTnG19hKr59Yxfjr1trzrbVtrbX1rbWx1trW1torrbUz6vLvBMBZozun6Z+X9PRez9tyQPe8s0SlZS4HUyHQbM3M16dL2TkcAAD4R0AUbACoDVcMaKXfn5Puvf5+9T79/qMVskcOOkbYe27qRpV5bl+P6JiqAW25ew0AAE4eBRtASLtjdAfdPqq99/qDRTv1j6/WULKhbVn5+niJz87hrL0GAAA1RMEGEPJ+f066rhjQ0nv96owteuknTuwLd89NKb97PaxDIw3k7jUAAKghCjaAkGeM0T8u7qkzuzXxjv37m7V6Z/52B1PBSduzCvTREs69BgAA/kXBBhAWoiIj9MzVfTWkffldyj9+vEJfr9jjYCo45bmpG7x3r4e2b6TB7Rs5nAgAAIQCCjaAsBEXHalXbxigHi0aSJJcVrr33aWatTHT4WSoS9uzCvTRYtZeAwAA/6NgAwgriXHRmjhukNqnJkiSistcum3SQi3bccjZYKgzz0/dqFLP3esh7VM0hLvXAADATyjYAMJOav1YTbp5kJo2iJMk5ReXaeyE+dqYkedwMtS2HQcK9OHind7re0/r7GAaAAAQaijYAMJSy4bxevPmQUqOj5YkHSwo0fWvz9OuQ4cdToba9MK08rvXg9ulaGgH7l4DAAD/oWADCFudmiRqwtiBio+JlCTtyS7U9a/PU1ZekcPJUBt2HCjQ/xb63L1m7TUAAPAzCjaAsNa3dUO9fH1/RUcaSdLm/fkaN3GB8opKHU4Gf3th2ibv3etBbVM0lLXXAADAzyjYAMLeyE5peurKvjLujq3lO7N126SFKiwpczYY/GbnwQJ9sGiH9/q+0zvJHPn/cAAAAD+hYAOApPN6NdPfLurhvZ69KUt3TF5EyQ4RT36/QSVl7rvXA9s2ZO01AACoFRRsAPC4dnAbPXBWF+/1tHX7defkRSoqpWQHsylr9/1s53DuXgMAgNpAwQYAH3eN6aB7Tu3ovZ66br/ueJOSHawO5hfrwQ9XeK/P69VMIzqlOpgIAACEMgo2APgwxujXZ3TWL0+pWLLvnLyYkh2EHvp0pfbnuneFT0uM1d8u7HGcdwAAAJw8CjYAVGKM0W/O7Ky7T+ngHZuyNkN3UbKDymfLduvL5Xu81/++tKcaJsQ4mAgAAIQ6CjYAHIUxRr89s4vuGlNesn9cm6G736JkB4N9OYV6+JOV3usrB7TSqelNHEwEAADCAQUbAKpgjNEDZ3XRnT4l+4c17pJdXOpyMBmOxVqrBz9cruzDJZKkFsn19ND5XR1OBQAAwgEFGwCOwRij353VRXeMrliy76JkB6x3F+zQtHX7vdf/vby3EuOiHUwEAADCBQUbAI7DGKMHz+6i20e39479sGaf7n6bkh1odhwo0N++WO29vml4O868BgAAdYaCDQDVYIzR789O1+2jykv296v36ZeU7IDhcln95n/LlF/sXiPfIS1Bvzu7y3HeBQAA4D8UbACoJmOMfn9Oum7zKdnfrd6ne95ZrJIySrbTxs/aovlbDkiSIiOMHr+ij+KiIx1OBQAAwgkFGwBOgDFG/3dOum4d2c479u2qfbrn7SWUbAdtzMjVY9+u817fNaaD+rRKdi4QAAAISxRsADhBxhj94dyuFUr2N6v26lfvULKdUFLm0q/fX+adqt+9eQPdc2onh1MBAIBwRMEGgJNwpGTfMqK8ZH+9ci9rsh3wwtRNWr4zW5IUExmhJ67oo5gofrwBAIC6x28gAHCSjDH643lddfOIitPF75y8SEWlZQ4mCx8rdmbr2SkbvNe/PrOzujRNdDARAAAIZxRsAKgBY4weOq9rhY3PflybodsmLVJhCSW7NhWWlOnX7y9VqctKkga0aahbR7Y/zrsAAABqDwUbAGroyMZnd43p4B37af1+3fLGQh0upmTXlie+X68NGXmSpHrRkfrv5b0VGWEcTgUAAMIZBRsA/MAYowfO6qJ7TyvfXGvmxkyNmzhf+UWlDiYLTfO3HNCrMzZ7r/9wXle1TU1wMBEAAAAFGwD8xhij+8/orN+e2dk7NnfzAd04fr5yC0scTBZa8otK9dv/LZN1zwzXyE6pum5wa2dDAQAAiIINAH73y1M76ffnpHuvF247qBvGz1f2YUp2TblcVn/4eIW2HyiQJCXGRemxy3rJGKaGAwAA51GwAaAW3DG6gx4+v5v3esn2Q7r+9Xk6VFDsYKrg5nJZ/d9HK/Tp0t3esb9c2F3Nkuo5mAoAAKAcBRsAasnNI9rpLxd2914v35mta16dpwP5lOwT5XJZ/fGTlXpv4Q7v2NWDWuuiPi0cTAUAAFARBRsAatENQ9vqn5f01JEZzKv35OiaV+cqM6/I2WBBxFqrP322Uu/M3+4du6x/S/39oh5MDQcAAAGFgg0AtezqQa312KW9vCV77d5cXfXKXGXkFDobLAhYa/Xo56s1eW55ub6kbwv9+9JeiuBILgAAEGAo2ABQBy4f0EpPXNFbRzrhxow8XfXKXO3NpmRXxVqrv36xRhNnb/WOXdinuf7DedcAACBAUbABoI5c3Lelnr6qr7ccbs7M15WvzNGWzHyHkwUea63++fVajZ+1xTt2fq9mepxyDQAAAhgFGwDq0AW9m+v5a/oqylMSt2UV6LxnZuj9BTtkjxzsHOastfr3N+v0yvTN3rFzezbVU1f2UVQkP7YAAEDg4jcVAKhjZ/doppeu668YT1ksKC7T7z5crrvfXqzsgvA+K9taq8e/W6+XftrkHTurexM9fVVfyjUAAAh4/LYCAA44vVsTfXTXMHVIS/COfbVir85+errmbs5yMJmznv5xg56butF7fXrXJnr26n6KplwDAIAgwG8sAOCQHi2S9MU9I3XN4NbesT3Zhbr61bl67Ju1KilzOZiu7j374wY99cMG7/Wp6Y31/LV9FRPFjyoAABAc+K0FABxULyZS/7i4p16+vr8axkdLkqyVXpi2SZe9ODtsNkB7fupGPf79eu/16M5peuHafoqNinQwFQAAwImhYANAADire1N9c98oDe/YyDu2bGd2WGyA9vJPm/Sfb9d5r0d2StXL1/dXXDTlGgAABBcKNgAEiCYN4vTmTYP1h3PTFR3p3mX8yAZov3x7SchtgFZQXKp/fb1W//x6rXdsWIdGevWGAZRrAAAQlCjYABBAIiKMbhvVQR/fNVztfTZA+3LFHp0TIhugWWv16dJdOu3xnyrsFj6kfYpev3Eg5RoAAAQtCjYABKAeLZL0ZaUN0HZ7NkD7z7drVVhS5mC6k7d85yFd9tIc3fvuUu3JLvSOD23fSK/fOFD1YijXAAAgeEU5HQAAcHRHNkAb3TlND364XIcKSmSt9PzUTXp73nZdPai1bhjaVk2T4pyOelwZOYV67Nt1+mDRzgrjqfVj9MBZXXRZ/1aKjDAOpQMAAPAPCjYABLizujdVn1bJ+vX7SzVro3uK+MGCEr0wbZNemb5Z5/ZspnHD26pv64YOJ/25otIyjZ+5Vc9N2aD84vK77tGRRjcNb6dfntpRiXHRDiYEAADwHwo2AASBIxugvTVvm16evlk7Dx6WJJW6rD5btlufLdutvq2TddPwdjq7R1NFRzq7Ashaq+9W79Pfv1yj7QcKKjx3etfG+uN53dQuNaGKdwMAAAQnCjYABImICKPrh7bVNYPb6PvV+zRh1hbN23LA+/yS7Yd0z/YlatogTjcMa6OrB7ZWw4SYOs+5bm+u/vLFKu/d9iM6Na6vh8/vplGd0+o8EwAAQF2gYANAkImMMDq7R1Od3aOpVu7K1oRZW/X5st0qLnNJkvbmFOqxb9bpmR836OK+LXXT8Lbq1CSxVjO5XFab9udp0pxtemveNrl8ju1Oqhet+0/vpGuHtHH8zjoAAEBtMtba478KXsaYRf369eu3aNEip6MAgNf+3CK9NW+bJs/dpsy84p89P7xjI/Vvk6JOjeurY+P6apeaUKPjsPblFGrpjkNauuOQlu04pOU7s5VXVFrhNZERRtcObq37T+/syJ10AACAk9G/f38tXrx4sbW2/4m+lzvYABAC0hJjdd/pnXXnmA76YtkejZ+1Rat253ifn7Uxq8KU7QgjtU6JV8fGierYuL63eHdsXF8JsRV/NOQVlWrFzmxvmV6281CFI7aOZnjHRvrT+d3VpWnt3jkHAAAIJBRsAAghsVGRurR/S13Sr4XmbzmgCbO26rvVeytM2ZYkl5W2ZhVoa1aBflizr8JzzZPi1LFJoholxGj17hxtyMj92fuPJrV+jPq0aqgrB7bS6V0byxiO3QIAAOGFgg0AIcgYo8HtG2lw+0baebBAszdlaVNGnjZm5GlDRp52HCxQVSuEdmcXavdx7lDXi45UzxZJ6t0qSX1aNVTvVklqkVyPUg0AAMIaBRsAQlzLhvG6YkB8hbHCkjJt2u8u3Bsz8rRhX5427s/T1sx8lVa6XR1hpM5NEtW7ZbL6tE5W75bJ6tykvqLYsAwAAKACCjYAhKG46Eh1b56k7s2TKoyXlLm0LStfG/blKTOvSJ2aJKpni6SfrcsGAADAz/EbEwDAKzoywrPxGZuTAQAAnCjm9wEAAAAA4AcUbAAAAAAA/ICCDQAAAACAH1CwAQAAAADwA8cLtjGmkzHmQWPMFGPMDmNMsTFmnzHmU2PMKSf5mcOMMV8ZYw4YYwqMMcuNMfcZYyL9nR8AAAAAACkACrakv0r6l6Qmkr6S9LikWZLOkzTFGPOrE/kwY8yFkqZLGiXpY0nPS4qR9KSkd/0XGwAAAACAcoFwTNc3kv5trV3iO2iMGS3pe0n/Mcb8z1q753gfZIxpIOlVSWWSxlhrF3rGH5Y0RdJlxpirrLUUbQAAAACAXzl+B9taO7FyufaM/yRpmtx3n4dV8+Muk/T/7d1/rGRlfcfx97csP1bDjxW0oUvrrlhY2pggbtq6KG4g+KPBH0SNpFpZaYy2hVJt0jbVUGptUAtIMZZtlLr8jBYEoi2rbaUrhq1VSWppXFYXWZVFrMAKuyy7CPv0j+e5OFzn3jsz99x7zjPzfiUnc+f8eOaZ53PvnfOdOXPOc4FPTxXXpa29wPvL3d+fV4clSZIkSeqj9QJ7Dj8tt08OuP6p5fYLfZbdDuwB1kTEwfPtmCRJkiRJvbpwiHhfEfF84DRyUXz7gJsdX26/PX1BSunJiLgX+HXgBcCWOR7/zhkWrRqwL5IkSZKkCdLJArt8wnwdcDDwpymlnQNueni5fWSG5VPzjxi9d5IkSZIk/bxGCuyI2A48f4hNrkspvW2Gtg4ArgFOBj4DXDzvDvY0X27TXCumlF7St4H8yfZJDfZJkiRJkjQGmvoE+x5g7xDr399vZimurwXeDPwT8LaU0pzFcI+pT6gPn2H5YdPWkyRJkiSpEY0U2Cml0+bbRkQsAa4nF9fXA29PKT01ZDNbgdXAccAzvkNd2l9JPmHad+fbX0mSJEmSenXiLOIRcRBwI7m4vhr43RGKa8jXugZ4dZ9lpwDPAjanlPaN1FFJkiRJkmbQeoFdTmh2M/B64ErgHSml/XNsc3hErIqIo6ctuhF4EDgrIlb3rH8I8MFy94rGOi9JkiRJUtGFs4ivB36bXBjvAC6IiOnrbEopbeq5fybwKeAqYN3UzJTSoxHxTnKhvSkiPg08DLyOfAmvG8knTpMkSZIkqVFdKLBXltujgAtmWW/TII2llG6JiFcA7wPeCBwCbAPeC1w+5EnTJEmSJEkaSOsFdkpp7QjbbAA2zLL8DvKn4pIkSZIkLYrWv4MtSZIkSdI4sMCWJEmSJKkBFtiSJEmSJDXAAluSJEmSpAZYYEuSJEmS1AALbEmSJEmSGmCBLUmSJElSAyKl1HYfqhIRDy1duvQ5J5xwQttdkSRJkiQ1bMuWLTz++OMPp5SOHHZbC+whRcS9wGHA9pa70pRV5fbuVnuhKebRLebRLebRPWbSLebRLebRLebRLV3PYwXwaEpp5bAbWmBPuIi4EyCl9JK2+yLz6Brz6Bbz6B4z6Rbz6Bbz6Bbz6JZxzsPvYEuSJEmS1AALbEmSJEmSGmCBLUmSJElSAyywJUmSJElqgAW2JEmSJEkN8CzikiRJkiQ1wE+wJUmSJElqgAW2JEmSJEkNsMCWJEmSJKkBFtiSJEmSJDXAAluSJEmSpAZYYEuSJEmS1AALbEmSJEmSGmCBXbGIWBMRt0bEwxGxJyL+JyL+OCIOWIy2IuLsiPhaROyOiEciYlNEnDHg4x0XEY9FRIqIa4ftbxfVlEdEnBMRt0TEtoh4tGSxJSI+ERHHD9vfLqolj4g4MCLOjIgrI+J/Sx57IuKuiPhARBw6bH+7qpZMyrq/EREXRcTGiHig/K+6b9h+tikijomIf4yI+yNiX0Rsj4jLImLZQrez2K8ptaglk9L++yLihvI6sb/8DbxwlOfdVRXlcXJEfCQivh4RPy6PcW9EfHKcMqkoj1Mi4prIr9kPRcTeksfnIuK0UZ57F9WSR59tDy7ZtPe6nVJyqnACXg88CewGrgT+FrgbSMANC90WcHFZ/gPgo8DHgYfKvHPneLwlwH8Bu8r617Y9npOWB3AbsAW4DrikPMat5XH3Aa9pe0wnJQ9gVZm/G/g88OGy/rYyfytwVNtjOkmZlPUvK8ueAL5Zfr6v7XEcYoyOBX5U+n0L8KHyd5/KWB25UO0sRj41TjVlAryhLNsP3APsLPdf2PY4TmgeDwBPAV8p/5suBu7gZ68dL217PCcsjwuBHcBNwOXAReT9qan92r9uezwnKY8+21/Sk0Urr9utB+g0QmhwGPB/5EJodc/8Q4DN5RfqrIVqC1hT5m8DlvXMX0HeIdoLrJjlMS8oj/dHjEGBXWMewCEzPP7ppa1vtT2uk5IHsBz4A+DZ09o5CPjn0tbH2h7XScqkLDsReDFwULlfW4H9xdLn86bNv7TMX78Q7SxWPjVOlWVyDPBy4LByfxPjV2DXlMefAb/U57H/oqx/V9vjOWF5zLQPtZxcTD4FHN32mE5KHtO2X0t+Y/DdWGA7DRUanFN+aa7qs+zUsuzLC9UWcHWZ/44+23ygLPurGR5vNfBT4P3lj2AcCuxq85ihDzuBJ9oeV/N4RuFR9c7TOGTS5gv1COP9gtLfe4FfmLbsUPKnAo8x7U2dJtpp+2+mq1NtmfRZbxNjVGDXnkfP+gcAe8o2A32i2MVpXPIo29xctjm57XGdtDzIxfl24N/K/dZet/0Odp1OLbdf6LPsdvI/2zURcfACtTXbNhunrfO0iFhK3pH6b/IhIuOiyjz6iYiXAUcAdw2yfkeNTR7kN6MgHypVs3HKpAZTz+VfU0r7exeklHaRDy19FvBbC9CO+fRXWybjblzySPzs9eGpAdbvqrHIIyKeB/wm+dPXrXOt32G15nE5sAz4vTn6teAssOs0dRKqb09fkFJ6kvxO0RLyO0eNthURzyYfArM7pfTDPu19p9we12fZh0o7Z5e2x0WteRARb4qICyPiwxFxM/Al4GHg3AH62lXV5tHHOeW23wtNTcYpkxrMOEbFoM95lHbMp79qMpkQ45LHm8mfBH41pfSTAdbvqirziIjVZR/qgxGxgfw94ecB70kpPThHX7usujwi4kzgbOC9KaXvz9GvBbek7Q5oJIeX20dmWD41/4gFaGukxy5nVTwP+POU0rcG6FdNqsujx5uAt/Tc/w7wOymlb8zay26rOY+nRcTrgHcB9wEfmWv9jhuLTCrS1HMepR3z6a+mTCZB9XlExErgY+RPsP9ktnUrUGseq4G/7Lm/i/xVl2tm7WX3VZVHRPwi8A/AxpTSlXP0aVH4CXZLyinq0xDTMJeyinKbmujqiG09vX5EHAF8inzm8Esa6FPjJimPZ8xM6ayUUpD/oZ1MfmfwjohYN3IPGzCpeTzdaMQa4Hryd5PemFLaOULfGjXpmYyZpsZ7lHbMp78aMxlnnc6jHIq8EXgucH5KafNo3atGJ/NIKa0v+1BLgV8j7+teHRHr59XL7utaHp8ADgTeOc/+NMZPsNtzD/nMqIO6v+fnqXdvDu+3IvlL/r3rzWbYtuZav987T5cCRwGnp5S6+h2hScrj56SUHgU2R8RrgW8AV0TEv6eU2rru78TmEREvJe847SdfLu1rA/RzMUxsJhVqarxHacd8+qspk0lQbR6luL6NfCjt+Smlv5+jjzWoNg+AlNJe8qVPzy/fDX5X2Ye6cY7+dlU1eUTE24HXkr9+umOO/iwaC+yWpJTmcyH6reTDUo4D7uxdEBFLgJXkQ4a+23RbKaXHImIHsDwiju7znblfLbe93504ifzu3t0RQR9vjYi3At9MKZ04QJ8bN2F5zCil9EREfAl4EfmkE628OExqHhHxcuBfyMX1q1JKXx2gj4tiUjOp1NTJdWb6ftygz3mUdsynv2oymRBV5hERR5PPlbIK+MMxKa6h0jxmsJH89a61tLQP1YCa8jip3F4VEVf1eYzlETH1afeyxTpXgYeI1+m2cvvqPstOIZ+Rb3NKad8CtTXbNq+Ztg7ATeQLxU+fbi3L7yn3bxqgv11UWx5zWV5uaz0RXZV5RMSp5BfmJ8lHe3SmuG5AlZlU7D/K7Ssj4hmv8xFxKPnrII8Dc/2OjdKO+fRXWybjrro8IuIY4Mvk4vrdY1RcQ4V5zKL2fSioK4//pH+NMfVd7D099xfvf1wb1wZzmt9EPjzixwxxEXbyoRarmHbh+xHbmro27zbyu0FT81cAD5EPI10xwPNYy3hcB7uqPIAjgRfN8FzOIF8aaldvWzVNteVRlr2S/CLwIPDitsfQTPo+h0Ql18Eu/f1i6fN50+ZfWuav75l3YBnrY+fTTpv51DDVlEmfx9zEGF0Hu7Y8gF8hfxjxFH2uFz8OU2V5vIJp13Uu848FdpRtTm97TCclj1meQ2uv260H6DRicPAG8rtju4FPks8yfHf5ZboBiGnrryvLNsy3rbLNJWX5D4CPAh8nFwcJOHfA57CWMSiwa8sDOLHMv5N8XfKLgCvI7wIm4AngLW2P6QTlcTz5HdxEPpzswn5T22M6SZmU9VcBG3qmRD7pXO+8o9oe11nG+1jgR6Xft5S/89vK/a3AkT3rrijzt8+nncXMp8apwkx6f9cfKOt+tmfey9oe00nJg3wC0kQ+R8qFM0wr2h7TCcrjJ8B24DPAxcBlwOfJH1Ak4PK2x3OS8pjlOVhgO40QXj604lZgJ3kH/S7gPcABfdZdxww7q8O21bPN2cDXyTudu8iHLp0xRP/XMiYFdk15AMuAvwG+AvyQXFA/Rj5Bx3rghLbHcsLymPo7mHVqezwnKZMhclnR9pjOMd6/TD6r7dTf+feAvwOeM229FcywczRMO4uZT61TTZkM8Pu/ru3xnJQ8BsgiAWvbHs8JyuN88vlSvkc++mwf8H1y8feqtsdx0vKYpY3WCuwoHZAkSZIkSfPgSc4kSZIkSWqABbYkSZIkSQ2wwJYkSZIkqQEW2JIkSZIkNcACW5IkSZKkBlhgS5IkSZLUAAtsSZIkSZIaYIEtSZIkSVIDLLAlSZIkSWqABbYkSZIkSQ2wwJYkSZIkqQEW2JIkSZIkNcACW5IkSZKkBlhgS5IkSZLUAAtsSZIkSZIaYIEtSZIkSVIDLLAlSZIkSWrA/wPfMjV36ezwMQAAAABJRU5ErkJggg==\n", + "image/png": "iVBORw0KGgoAAAANSUhEUgAAA9gAAALfCAYAAACaWGp9AAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAACJQklEQVR4nOzdd3RcxeH28WdW1eqWZLn33nFvuGACmA6hV9uUUEMLIckvDZLwppAQeqgumN4CoYPBvRfce++WJdkqVtfO+4fWq5Vxka2V7pbv5xyd1Z3dvXp8QiQ9unNnjLVWAAAAAACgdlxOBwAAAAAAIBRQsAEAAAAA8AMKNgAAAAAAfkDBBgAAAADADyjYAAAAAAD4AQUbAAAAAAA/oGADAAAAAOAHFGwAAAAAAPyAgg0AAAAAgB9QsAEAAAAA8AMKNgAAAAAAfkDBBgAAAADADyjYAAAAAAD4AQUbAAAAAAA/oGDXgjHmSmPMs8aYWcaYPGOMNca84adzj/Kc72QfLf3x9QAAAAAAtRPpdIAg9ztJvSUVSNolqYsfz71N0mPHea6npJ9KWm2t3enHrwkAAAAAOE0U7Np5UJXFepOkkZKm+evE1tptkh491nPGmLc9n77sr68HAAAAAKgdpojXgrV2mrV2o7XW1vQ9xpjrjDHTjDEHjTHFxpi1xpjfGWNiavj+NEmXSyqSNOU0owMAAAAA/IyCXY+MMa9JektSB0kfSXpeUo6kP0v6yhhTkxkF4yTFSHrfWnuwjqICAAAAAE4RU8TriTFmnKRbJP1X0g3W2iKf5x6V9EdJ90h6+iSnus3z+JL/UwIAAAAAThdXsOvP/ZLKJd3iW649/iwpW9INJzqBMWakKhdSW22tnVsnKQEAAAAAp4Ur2PXAGBOnytXGsyQ9YIw51stKJHU9yal+5nnk6jUAAAAABBgKdv1oKMlIaqTKqeCnzBiTKukKsbgZAAAAAAQkpojXj1zP4w/WWnOijxOcY6wqFzd7z1p7qM4TAwAAAABOCQW7HlhrCyStltTdcyX6dNzueWTvawAAAAAIQBTs+vOkpGhJE4wxKUc/aYxpaIzpe6w3GmOGq/L+7FUsbgYAAAAAgYl7sGvBGHOZpMs8h008j0OMMZM8n2dZax+WJGvtBGNMP0l3S9psjPla0g5JqZLaShohaaKkO4/xpY4sbsbVawAAAAAIUMZa63SGoOWzf/XxbLfWtjnqPRepskQPlJQiKUeVRfsbSW9Ya9cd9fqGkvZIspKacf81AAAAAAQmCjYAAAAAAH7APdgAAAAAAPgBBRsAAAAAAD+gYAMAAAAA4AcUbAAAAAAA/IBtuk6RMWarpCRJ2xyOAgAAAADwvzaS8qy1bU/1jRTsU5fUoEGD1K5du6Y6HQQAAAAA4F9r165VUVHRab2Xgn3qtnXt2jV1yZIlTucAAAAAAPhZv379tHTp0m2n817uwQYAAAAAwA8o2AAAAAAA+AEFGwAAAAAAP6BgAwAAAADgBwFRsI0xacaY24wx/zXGbDLGFBljco0xs40xtxpjTimnMaaFMWaCMWaPMabEGLPNGPOUMaZhXf0bAAAAAADhLVBWEb9K0n8k7ZU0TdIOSY0l/VTSq5LON8ZcZa21JzuRMaa9pLmSMiR9ImmdpIGS7pc0xhgzzFqbXSf/CgAAAABA2AqUgr1B0iWSPrfWuo8MGmP+T9JCSVeosmx/WINzvaDKcn2ftfZZn3M9KelBSY9LutN/0QEAAAAACJAp4tba7621n/qWa8/4Pkkveg5Hnew8xph2ks6VtE3S80c9/UdJhyXdZIyJr21mAAAAAAB8BUTBPokyz2N5DV472vP4zTHKer6kOZLiJA32XzwAAAAAAAK8YBtjIiXd7Dn8qgZv6ex53HCc5zd6HjvVJhcAAAAAAEcLlHuwj+dvknpI+sJa+3UNXp/secw9zvNHxlNOdiJjzJLjPNWlBjkAAAAAAGEmYK9gG2Puk/QLVa4CfpO/Tut5POlq5AAAAAAAnIqAvIJtjLlH0tOS1kg621qbU8O3HrlCnXyc55OOet1xWWv7HSfbEkl9a5gHAAAAABAmAu4KtjHmAUnPSVol6SzPSuI1td7zeLx7rDt6Ho93jzYAAAAAAKcloAq2MeZXkv4taZkqy3XmKZ5imufxXGNMtX+bMSZR0jBJRZLm1zIqAAAAAADVBEzBNsb8XpWLmi1R5bTwrBO8NsoY08UY09533Fq7WdI3ktpIuueotz0mKV7S69baw/7MDgAAAABAQNyDbYwZK+lPkiokzZJ0nzHm6Jdts9ZO8nzeXNJaSdtVWaZ93S1prqRnjDFne143SNJZqpwa/lv//wsAAAAAAOEuIAq2pLaexwhJDxznNTMkTTrZiay1m40x/VVZ2MdIukDSXknPSHrsFBZMAwAAAACgxgKiYFtrH5X06Cm8fpuqttw61vM7JY2vbS4AAAAAAGoqYO7BBgAAAAAgmFGwAQAAAADwAwo2AAAAAAB+QMEGAAAAAMAPKNgAAAAAAPgBBRsAAAAAAD+gYAMAAAAA4AcBsQ82AAAAgp/bbXWgoEQ7cwq162CRduYUqqCkXK3T4tWxcYI6NEpQw/hop2MCQJ2hYAMAAKBGrLXKPlxaVaAPVhXp3QeLtOtQkUrL3Sc8R3pCtDpkJKhjRqLnMUEdMhLUKDFGxph6+pcAQN2gYAMAAOCE1u3L0xNfrdfczdkqKquo1bmyCkqVVZCj+Vtyqo0nxUaqY+NEdWiUoE5NEnV+jyZqltKgVl8LAOobBRsAAADHlFVQon99s0HvLtoht63ZexrGRalFwzi1TG2gFg3jFB8dqS1ZBdqUWflRcpwr3HnF5Vqy/aCWbD8oSfp/X6zVmO5NNH5YG/Vr3ZCr2wCCAgUbAAAA1ZSUV2jSnG167vtNyi8pr/ZcYkykWqTGqWXDBtWKdMvUBmqe0kCJsVHHPW+F22r3wSJtzMzXpswCbfR8bM4sUMFRX6fCbfX5yr36fOVe9WqRrPHD2ujCns0UHckavQACFwUbAAAAkirvsf569T79vy/WaUdOYbXnhndM1+8u7KbOTRJP+/wRLqNWaXFqlRans7s2rvZ19+UVa+P+ysI9dc1+zduS7X1+xa5cPfjucv2/L9bpxkGtdcPgVkpPiDntHABQV4y1NZzvA0mSMWZJ3759+y5ZssTpKAAAAH6zaneu/vzZGi3YWv3e6PaN4vW7C7tpVOdG9TpNe82ePE2au1UfL9vzo4XToiNcurh3M40f1kY9mifXWyYA4aFfv35aunTpUmttv1N9LwX7FFGwAQBAKMnMK9YTX6/XB0t3yffXwuQGUXrwJx11w+DWiopwblp2dkGJ3l64Q1Pmb9f+vJIfPT+wbapuGdZG53RroggX92kDqL3aFGymiAMAAISh4rIKvTZ7q56ftkmFpVUrg0e6jG4a0lr3n91RKXHO71mdlhCje0d31M9GtNeXq/ZqwpxtWr7zkPf5hVtztHBrjpqnNNAvz+usy/o0dy4sgLBHwQYAAAgzX6zcq8c/X6vdh4qqjZ/dJUP/d2FXtW+U4FCy44uOdOnSM5rr0jOaa+mOg5o4Z5u+XLlX5Z7lzXcfKtID7y7TnE1Z+tOlPdQgOsLhxADCEQUbAAAgTFhr9e9vN+iZ7zdVG+/UOEG/u7CbRnRq5FCyU9O3VUP1bdVQ+y7oqinzt+mtBTt0sLBMkvT+kl1avuuQXrihrzpknP6CbABwOtjnAAAAIAy43VaP/m91tXKdGh+tv1zWQ1/cNzxoyrWvJsmx+uV5XTT7V6N1uc/U8A37C3Txs3P00dJdDqYDEI4o2AAAACGurMKth95bpsnztnvHRnVupGkPj9KNg1sr0sFFzPwhPiZST17dW3+/oqdiPPtkF5VV6KH3lutXH6xQcVnFSc4AAP4R3N9NAQAAcELFZRW6c8oSfbxsj3fsol5N9fJN/ZXcIMrBZP5ljNE1A1rp43uGqV16vHf83cU7ddnzc7T5QIGD6QCECwo2AABAiMovLtPYCQv13bpM79gNg1rp6Wv7KDoyNH8N7No0Sf/7+Zm6pHcz79i6ffm6+NnZ+mTZbgeTAQgHofmdFQAAIMxlF5Toulfma8HWHO/Y3aPa6y+X9Qj5/aITYiL19LVn6P9d3tP7h4TC0grd/84y/eYjpowDqDsUbAAAgBCz51CRrnppnlbtzvOO/eb8LnpkTBcZE9rl+ghjjK4f1Eof3z1MbX2mjL+9cKcuf2GutjBlHEAdoGADAACEkM0HCnTlf+Zqy4HDkiSXkf720566Y2R7h5M5o1uzJP3v3mG6qFdT79javXm6+NnZ+t/yPSd4JwCcOgo2AABAiFi1O1dXvzhPe3KLJUlREUbPXd9X1w5s5XAyZyXGRunZ6/roL5f18E4ZP1xaofve/kF//GSVKtzW4YQAQgUFGwAAIAQs2JKt616er+zDpZKkBlERmjBugC7o2fQk7wwPxhjdOLi1PrprqNqkxXnHJ8/brnveXMp92QD8goINAAAQ5L5ft183T1io/JJySVJSbKTeuG2Qhnds5HCywNOjebI+/fmZuqBnE+/YV6v3adzEhcorLnMwGYBQQMEGAAAIYp8s262fvb5EJeVuSVKjxBi9d+cQ9Wvd0OFkgSsxNkrPXddXt57Z1js2f0uOrn1pvjLzix1MBiDYUbABAACC1Hdr9+uBd5ep3HMPccvUBvrgziHq0iTJ4WSBz+Uy+t2FXfWrMV28Y2v25unK/8zT9uzDDiYDEMwo2AAAAEEou6BEv/pwhaxnfa5OjRP0wZ1D1Tot/sRvhJcxRneNaq9/XNnLuzf4jpxCXfGfuVq1O9fhdACCEQUbAAAgyFhr9ZuPViqroHJBs8ZJMXrnZ0PUOCnW4WTB6er+LfXSjf0U41lhPKugVNe+PF9zN2c5nAxAsKFgAwAABJkPluzSN2v2e4//cWVvpcZHO5go+P2kW2O9cdsgJcVGSpIKSso1bsIifbFyr8PJAAQTCjYAAEAQ2ZlTqMc+XeM9vmlwa43sxGrh/jCgTarev3OoGifFSJJKK9y6562lemP+doeTAQgWFGwAAIAg4XZbPfz+chV4tuNqmx6v31zQ5STvwqno3CRRH941VO3SK+9lt1b63cer9NTUDbJHbngHgOOgYAMAAASJ12Zv1YKtOZKkCJfRk1f3Vlx0pMOpQk+LhnF6/84h6t0i2Tv21NSN+sMnq1XhpmQDOD4KNgAAQBBYvy9fT3y93nt8z6j26tOKva7rSlpCjN66fbCGd0z3jk2Zv10/f3upSsorHEwGIJBRsAEAAAJcablbD7y7TKUVbklSj+ZJ+vnZHR1OFfriYyL12tgBuqR3M+/YFyv36ZZJi1RUSskG8GMUbAAAgAD31NQNWrs3T5IUHenSv68+Q1ER/BpXH6IjXXrqmjM0bmgb79icTdm6/fXFKi6jZAOoju/MAAAAAWzJ9hy9OGOz9/hXY7qoY+NEBxOFH5fL6I8Xd9PD53byjs3elEXJBvAjFGwAAIAAdbikXA++u1xH1tUa2j5N432upKL+GGN07+iO+uV5nb1jszZm6c43lnBPNgAvCjYAAECAevyLtdqRUyhJSoyJ1BNX9ZbLZRxOFd7uOauDHvxJ1ZXs6esP6O43lqq03O1gKgCBgoINAAAQgKaty9RbC3Z4jx+7tLuapzRwMBGOuP8nHXXf6A7e4+/WZeqet5aqrIKSDYQ7CjYAAECAyTlcqkc+XOE9Pr9HE13ep7mDiXC0B8/ppLtHtfcef7tmv+57+wdKNhDmKNgAAAABxFqr3328UgfySyRJ6QkxevzynjKGqeGBxBijX57XWXeMaOcd+3LVPj3wzjKVU7KBsEXBBgAACCAfL9utL1bu8x7/48qeSo2PdjARjscYo1+f30W3ndnWO/b5yr168L3llGwgTFGwAQAAAsSeQ0X6wyervcfXDWyl0V0aO5gIJ2OM0W8v7Fptn+xPl+/RLz9YoYojy78DCBsUbAAAgADgdls9/P5y5ReXS5Jap8Xpdxd2dTgVasKYyn2ybxrc2jv23x9265EPVshNyQbCCgUbAAAgALyzaKfmbs6WJLmM9OTVvRUfE+lwKtSUMUaPXdJd1w9q5R37cOku/eajlZRsIIxQsAEAABxWVFqhp6Zu8B7fMbK9+rVOdTARTofLZfSXS3vomv4tvWPvLt6p3368ipINhAkKNgAAgMOmzN+mTM+q4Y2TYnT/2R0dToTT5XIZ/fWnPXVlvxbesbcX7tAf/7da1lKygVBHwQYAAHBQfnGZXpi+2Xt87+iOio2KcDARasvlMvr7Fb30U5+9y6fM366nv9voYCoA9YGCDQAA4KDXZm/VocIySVKLhg2qTS9G8IpwGT1xVW9d0ruZd+ypqRv13uKdDqYCUNco2AAAAA45eLhUr87a6j1+4CedFB3Jr2ehIsJl9K+re2t4x3Tv2G8+WqkZGw44mApAXeI7OAAAgENenLlZBSWV23J1yEjQ5T5TihEaoiJceuGGvurWNEmSVOG2uvuNJVq1O9fhZADqAgUbAADAAZl5xZo8d5v3+KFzOinCZZwLhDqTGBulieMHqHlKA0nS4dIKjZ+0SDtzCh1OBsDfKNgAAAAOeH7aJhWXuSVJ3ZslaUz3Jg4nQl1qnBSrSeMHKCm2cm/zA/klGjdxoQ4VljqcDIA/UbABAADq2a6DhXpr4Q7v8cPndpaLq9chr2PjRL1yc39FR1T+Cr75wGHd/vpiFZdVOJwMgL9QsAEAAOrZ01M3qqyick/kfq0balTnRg4nQn0Z1C5N/7q6t/d40baDeui9ZXK72SMbCAUUbAAAgHq0+UCBPly6y3v88LmdZQxXr8PJxb2b6bcXdPUef7Fynx7/Yq2DiQD4CwUbAACgHv372w06crHyzA7pGtI+zdlAcMRtw9tq3NA23uPXZm/Vq7O2OBcIgF9QsAEAAOrJmj15+mzFXu/xw+d1djANnGSM0e8v6lZtcbvHv1irz33++wAQfCjYAAAA9eTJb9d7Pz+nW2Od0TLFuTBwXITL6Klrz1C/1g0lSdZKD763TAu35jicDMDpomADAADUg6U7Dmrq2kxJkjHSL87t5HAiBILYqAi9enN/tUuPlySVlrt1++uLtSkz3+FkAE5HQBRsY8yVxphnjTGzjDF5xhhrjHnjNM6zzfPeY33sq4vsAAAANfGvb6quXl/cq5m6NElyMA0CScP4aE2+ZaDSE6IlSblFZRo7YZEy84odTgbgVEU6HcDjd5J6SyqQtEtSl1qcK1fSU8cYL6jFOQEAAE7b3E1ZmrMpW1LltOAHz+HqNaprmRqnCeMG6JqX5quorEK7DxVp/KRFeveOIUqICZRf2QGcTKD8v/VBVRbrTZJGSppWi3MdstY+6o9QAAAAtWWt1RM+V6+v7NtCbT3TgQFfvVqk6IUb+uq21xerwm21ek+e7npjiSaMG6CoiICYeArgJALi/6nW2mnW2o3WWut0FgAAAH/6fl2mfthxSJIUHeHSfT/p6GwgBLSzumTo8ct6eI9nbczSrz5cIX5NBoJDoFzB9qcYY8yNklpJOixphaSZ1toKZ2MBAIBw43Zb/fObDd7j6we1UvOUBg4mQjC4dmAr7c0t1tPfbZQkfbR0t5okxeqRMbW5ixJAfQjFgt1E0pSjxrYaY8Zba2fU9CTGmCXHeYrvbAAAoEa+WLVXa/fmSZIaREXo7rPaO5wIweKBn3TUvtxivbt4pyTphemb1SQ5VjcPaeNsMAAnFBBTxP1ooqSzVVmy4yX1lPSSpDaSvjTG9HYuGgAACCflFW49+W3V1etxw9ooIzHWwUQIJsYYPX55D43ukuEd++P/VuurVWyMAwSykCrY1trHrLXfW2v3W2sLrbWrrLV3SnpSUgNJj57Cufod60PSujqKDwAAQsh/f9itLQcOS5ISYyJ1x4h2DidCsImMcOm56/uod8sUSZK10n3v/KBF23KcDQbguEKqYJ/Ai57HEY6mAAAAYaGkvEJPTd3oPb59RDulxEU7mAjBKi46UhPG9lebtDhJUmm5W7dNXqxNmfkOJwNwLOFSsDM9j+yJAQAA6tx7i3dp96EiSVJqfLRuObOtw4kQzNISYjT5loFKT6j8I01uUZnGTlik/XnFDicDcLRwKdhDPI9bHE0BAABCnrVWE+ds9R7fNbK9EmJCcV1Z1KfWafGaMG6A4qIjJEm7DxVp7ISFyisuczgZAF9BV7CNMVHGmC7GmPZHjXc3xqQe4/WtJT3nOXyjPjICAIDwNX9Ljvfe64SYSF0/qJXDiRAqerVI0Qs39FWEy0iS1u3L151Tlqi03O1wMgBHBETBNsZcZoyZZIyZJOnXnuEhR8aMMf/0eXlzSWslfXfUaa6StMcY86Ux5gVjzN+NMR+oclGyDpK+kPRPAQAA1KE3F2z3fn5Zn2aK5+o1/GhU5wz97ac9vcdzN2frlx8sl9ttHUwF4IhA+Y5/hqSxR42183xI0nZJD5/kHNMkdZbUR5VTwuMlHZI0W5X7Yk+x1vKdBwAA1JmsghJ9vbpqG6XrB7Z2MA1C1VX9W2p/XrH++U3lNnCfLNujJkmx+s0FXR1OBiAgCra19lHVcAsta+02SeYY4zMkzfBnLgAAgFPxwZJdKquo/Ht+n1Yp6tYsyeFECFX3nNVB+/KK9cb8HZKkl2ZuUeOkWBbUAxwWEFPEAQAAgp3bbfXWgh3e4+sHcu816o4xRo9d0kPndmvsHfvz52v02Yo9DqYCQMEGAADwgzmbs7Qjp1CSlBQbqYt6NXM4EUJdhMvomev6qF/rhpIka6WH3l2uBVuyHU4GhC8KNgAAgB+8Ob/q6vVP+7ZQA892SkBdio2K0Ks391e7RvGSpNIKt342ZYk2ZRY4nAwITxRsAACAWtqfV6xv1+73Ht/A1lyoRw3jozV5/EClJ8RIknKLyjRu4kIdyC9xOBkQfijYAAAAtfTeop2q8GyTNLBNqjo2TnQ4EcJNy9Q4TRjXXw2iKmdO7DpYpNsmL1JhabnDyYDwQsEGAACohQq31TuLdnqPbxjM1Ws4o1eLFD13fR+5PPvtLN+Vq/ve/sH7xx8AdY+CDQAAUAszNxzQ7kNFkqSGcVEa06OJw4kQzs7u2liPXdrDezx1baYe+3S1rKVkA/WBgg0AAFALby7Y7v38qv4tFRPJ4mZw1k2DW+uOEe28x6/P265XZ211MBEQPijYAAAAp2nPoSJ9vy7Te3wde18jQPxqTBdd2Kup9/jxL9bqi5V7HUwEhAcKNgAAwGl6Z9FOHbm9dWj7NLVNj3c2EODhchn966reGtCmoXfsgXeXacn2HAdTAaGPgg0AAHAayivcendR1d7XNwxq7WAa4MdioyL08k391c7zh5/Scrdum7xYW7MOO5wMCF0UbAAAgNPw3bpM7c+r3Gc4PSFa53Rr7HAi4Mcaxkdr0viBSouPliQdLKzcIzu7gD2ygbpAwQYAADgNby2ounp9df+Wio7k1yoEplZpcXp1bH/FRlX+N7o9u1C3vb5YxWUVDicDQg8/CQAAAE7RzpxCzdx4QJJkDIubIfD1adVQT1/bR8azR/YPOw7pgXeWsUc24GcUbAAAgFP09sIdOrKt8IiOjdQyNc7ZQEANnNe9if5wUTfv8Ver9+n/fbHWwURA6KFgAwAAnILScrfeW7zLe3z9IK5eI3iMH9ZWtwxr6z1+bfZWTZzDHtmAv1CwAQAATsG3a/Yry7NAVOOkGJ3dJcPhRMCp+e2FXTWmexPv8Z8+W6OvVrFHNuAPFGwAAIBT8NbC7d7PrxnQSpER/DqF4BLhMnrq2jPUp1WKJMla6b53lmn+lmxngwEhgJ8IAAAANbQ167DmbKosIS4jXTugpcOJgNMTGxWhV2/ur7Y+e2TfPnmx1uzJczgZENwo2AAAADX09sKqrblGd8lQs5QGDqYBaictIUav3zJQjRJjJEn5JeUaO3GhduYUOpwMCF4UbAAAgBooKa/Q+4t3eo9vGNTawTSAf7RMjdPk8QOVGBMpSTqQX6KbJyxUtmedAQCnhoINAABQA1+t2qeDhWWSpOYpDTSiUyOHEwH+0a1Zkl4Z21/RkZXVYGvWYY2ftEiHS8odTgYEHwo2AABADby5oGp6+HUDWyrCZRxMA/jX4HZpeubaM2Q8/1mv2JWrO99YotJyt7PBgCBDwQYAADiJjfvztXBrjiQp0mV0dX8WN0PoGdOjqf58aQ/v8ayNWXrkg+Vyu62DqYDgQsEGAAA4ibd8Fjf7SdfGykiKdTANUHduHNxaD/yko/f442V79PgXa2UtJRuoCQo2AADACRSXVejDJbu8xzcMbuVgGqDu3X92R10/qOq/89dmb9XLM7c4mAgIHhRsAACAE/hsxV7lFVcu9tQqNU7D2qc7nAioW8YY/fnSHhrTvYl37K9frtMHPn9oAnBsFGwAAIATeM9na67rB7WSi8XNEAYiXEZPXXuGBrZN9Y796sMV+n7dfgdTAYGPgg0AAHAcmXnFWrStcnEzl5F+2re5w4mA+hMbFaFXbu6vLk0SJUkVbqu731yqpTsOOpwMCFwUbAAAgOP4ctU+HVnbaVDbNGUksrgZwktygyhNvmWgWjRsIEkqLnPrlkmLtCkz3+FkQGCiYAMAABzH5yv3ej+/oFdTB5MAzmmcFKvXbxmo1PhoSdKhwjLd/NpC7TlU5HAyIPBQsAEAAI7h6Onhvgs+AeGmXaMETRw3QHHREZKkPbnFuuHVBcrMK3Y4GRBYKNgAAADHcPT08EaJMc4GAhzWu2WKXryxn6IiKhf625p1WNe/ukBZBSUOJwMCBwUbAADgGD5fUTU9/EKmhwOSpBGdGunZ6/oqwrOa/qbMAt346gIdPFzqcDIgMFCwAQAAjpKZV6xF232mh/dgejhwxJgeTfTUNWfoyI516/bl68bXFii3sMzZYEAAoGADAAAc5ejp4ekJTA8HfF3cu5n+dXVvGU/JXr0nTzdPWKC8Yko2whsFGwAA4ChMDwdO7vI+LfT3n/byHi/flavxExepoKTcwVSAsyjYAAAAPvYzPRyosasHtNRfLuvhPV6y/aBunbRIRaUVDqYCnEPBBgAA8PHlyr3e6eGD2zE9HDiZGwe31h8v7uY9XrA1R7e/vljFZZRshB8KNgAAgI8vVu7zfn5BT6aHAzUxflhb/eb8Lt7j2ZuydMeUJSopp2QjvFCwAQAAPJgeDpy+O0a218PndvIez9hwQPe8+YNKy90OpgLqFwUbAADAg+nhQO3cO7qj7hvdwXs8de1+3f/ODyqvoGQjPFCwAQAAPJgeDtTeg+d00h0j23mPv1y1Tw++t1wVbutgKqB+ULABAADE9HDAX4wx+vWYLrplWFvv2KfL9+iXHyyXm5KNEEfBBgAAENPDAX8yxuj3F3XVTYNbe8c+Wrpbv/5oBSUbIY2CDQAAIOnzlXu9n1/Yi+nhQG0ZY/TYJd117YCW3rH3Fu+iZCOkUbABAEDY259XrMXbD0qqnB5+XnemhwP+4HIZ/b/Le+rKfi28Y+8t3qVHPlzBPdkISRRsAAAQ9pgeDtQdl8vo71f00lU+JfuDJbv0yAeUbIQeCjYAAAh7TA8H6lbEMUr2h0t36ZcfsLo4QgsFGwAAhLV9uUwPB+rDkSvZ1/Svuif7o6W79cv3KdkIHRRsAAAQ1r5cVTU9fEh7pocDdcnlMvrrT3tWW/jsox8o2QgdFGwAABDWvvCZHn5BT6aHA3XtyMJn1w2sXrIfpmQjBFCwAQBA2GJ6OOAMl8vo8ct66rqBrbxj//1ht37x3jJKNoIaBRsAAIQtpocDzqks2T10/aCqkv3xsj166L1lKq9wO5gMOH0UbAAAELaYHg44y+Uy+sulPXSDT8n+ZNkePfTecko2ghIFGwAAhKV9ucVatK1qevgYpocDjnC5jP58aQ/dOLiqZP9v+R49SMlGEKJgAwCAsPTlqqqr10PapymN6eGAY45Vsj+lZCMIUbABAEBYYno4EFiMqSzZNw1u7R37dPke3ffODyotp2QjOFCwAQBA2GF6OBCYjDH606XddfOQqpL9xcp9uuuNJSouq3AwGVAzFGwAABB2mB4OBC5jjB67pLvGD2vjHftuXaZum7xYhaXlzgUDaoCCDQAAws7nK6oK9oU9mzmYBMCxGGP0h4u66a5R7b1jszdladyERcovLnMwGXBiFGwAABBW9uUWa/H2yunhES6j87o3djgRgGMxxuiR8zrrF+d08o4t3JajG19bqNxCSjYCEwUbAACEFd/p4YPbpTI9HAhgxhj9/OyO+t2FXb1jy3ce0nWvzFd2QYmDyYBjC4iCbYy50hjzrDFmljEmzxhjjTFvnOa5WhhjJhhj9hhjSowx24wxTxljGvo7NwAACD5MDweCz23D2+nPl/XwHq/Zm6drXp6vzLxiB1MBPxYQBVvS7yTdK+kMSbtP9yTGmPaSlkgaL2mhpH9L2iLpfknzjDFptU4KAACCFtPDgeB10+DWeuLKXnKZyuNNmQW6+qV52n2oyNlggI9AKdgPSuokKUnSXbU4zwuSMiTdZ629zFr7a2vtaFUW7c6SHq91UgAAELR8974e0o7Vw4Fgc1X/lnr62j6K9LTsbdmFuvrFedqefdjhZEClgCjY1tpp1tqN1lp7uucwxrSTdK6kbZKeP+rpP0o6LOkmY0z8aQcFAABBzff+6wt6NnUwCYDTdXHvZnrhhr6KjqisMrsPFemqF+dpU2a+w8mAACnYfjLa8/iNtdbt+4S1Nl/SHElxkgbXdzAAAOC8rIIS7/RwlxHTw4Egdm73JnplbH/FRFbWmcz8El3z0nyt2ZPncDKEu1Aq2J09jxuO8/xGz2On4zxfjTFmybE+JHWpbVAAAFD/vlu7X0fmyvVvzerhQLAb2amRJt8yUHHREZKk7MOluu6V+Vq285CzwRDWQqlgJ3sec4/z/JHxlLqPAgAAAs23a/Z7Pz+nG1evgVAwuF2a3rhtkBJjIyVJuUVluvHVBVq4NcfhZAhXoVSwT8az3qBqdJ+3tbbfsT4krau7iAAAoC4UlpZr1sYs7zEFGwgdfVs11Nu3D1bDuChJUkFJuW56bYG+WrXP4WQIR6FUsI9coU4+zvNJR70OAACEiVkbs1RSXrlES6fGCWqTzpqnQCjp0TxZ794xRI0SK2/9KCl36+43l+iN+dsdToZwE0oFe73n8Xj3WHf0PB7vHm0AABCimB4OhL5OjRP14Z1D1SYtTpLkttLvPl6lf32zXrXYrAg4JaFUsKd5Hs81xlT7dxljEiUNk1QkaX59BwMAAM4pr3Dru7W+BbuJg2kA1KVWaXH68K6h6t2ialLrs99v0q8+XKHyCvcJ3gn4R9AVbGNMlDGmizGmve+4tXazpG8ktZF0z1Fve0xSvKTXrbXsQg8AQBhZsv2gDhaWSZIyEmPUq/nx7iYDEArSEmL01u2DNapzI+/Ye4t36WdTlqiwtNzBZAgHAVGwjTGXGWMmGWMmSfq1Z3jIkTFjzD99Xt5c0lpJ3x3jVHdLypT0jDHmY2PMX40x30t6UJVTw39bd/8KAAAQiI6eHu5ymRO8GkAoiI+J1Cs399eV/Vp4x75fl6nrXlmgnMOlDiZDqAuIgi3pDEljPR/necba+YxdWZOTeK5i95c0SdIgSb+Q1F7SM5KGWGuz/RkaAAAENmutvl3L/ddAOIqKcOmJK3vp3rM6eMeW7zykK/8zVztzCh1MhlAWEAXbWvuotdac4KONz2u3HT121Ll2WmvHW2ubWmujrbWtrbX3W2vZDA8AgDCzMbNA27Mrf5FOiInUkPZpDicCUJ+MMXr4vM7686XdZTyTV7ZkHdZP/zNXq3azuRD8LyAKNgAAQF34ZnXVPrgjOzVSTGSEg2kAOOWmIW30nxv6Kjqysv4cyC/RtS/P1+yNWQ4nQ6ihYAMAgJDF9lwAjhjTo6neuHWQkmIjJUkFJeUaP2mhPlm22+FkCCUUbAAAEJL25xVr+a7KKaARLqOzOmc4nAiA0wa2TdUHdw1V0+RYSVJZhdX97yzTKzO3OJwMoYKCDQAAQpLv1evB7VKVHBflYBoAgaJT40R9eNdQdWqc4B17/Iu1evR/q9krG7VGwQYAACHpG9/p4V2ZHg6gSrOUBnr/jqEa2CbVOzZp7jbdPGGhDrKNF2qBgg0AAEJOfnGZ5m2uWrzoJ9x/DeAoyXFRev3WgbqgZxPv2NzN2br4udlasyfPwWQIZhRsAAAQcmZsOKCyCitJ6tY0SS0axjmcCEAgio2K0HPX9dVD53Tyju06WKQr/jNXn63Y42AyBCsKNgAACDmsHg6gplwuo/vO7qhXbu6vhJjKFcaLyip071s/6B9frVOF2zqcEMGEgg0AAEJKWYVb36/L9B6f252CDeDkzunWWB/fM1Rt0+O9Yy9M36zbJi9SblGZg8kQTCjYAAAgpCzYkqP84nJJUvOUBurWNMnhRACCRYeMRH18zzCN6tzIOzZt/QFd9vwcbcrMdzAZggUFGwAAhJRv1+zzfn5Ot8YyxjiYBkCwSW4QpdfGDtBdo9p7x7ZmHdZlz8+tdvsJcCwUbAAAEDKstdx/DaDWIlxGvxrTRc9d30cNoiIkSQUl5br99cV65ruNcnNfNo6Dgg0AAELG6j152pNbLElKio3UwLapJ3kHABzfRb2a6cO7hqpFwwbesSe/3aC73lyigpJyB5MhUFGwAQBAyPC9ej26S4aiIvhVB0DtdGuWpP/de6aGtk/zjn29er9++sIcbcs67GAyBCJ+6gAAgJDxTbXp4U0cTAIglKTGR+v1WwZq/LA23rEN+wt08bOz9ely9stGFQo2AAAICTtzCrV2b54kKTrCpZE+qwADQG1FRrj0x4u7659X9VZ0ZGWNyi8p18/f/kG/+WiFikorHE6IQEDBBgAAIWHq2qqr10PapykhJtLBNABC1ZX9WuiDO4eoZWrVfdlvL9ypS56brfX72Mor3FGwAQBASGD1cAD1pVeLFH1+33Bd1Kupd2xjZoEueW623lywXdayyni4omADAICgl1tYpgVbc7zHFGwAdS0pNkrPXtdHf7+ip2KjKmtVSblbv/3vKt3z1lLlFpU5nBBOoGADAICg9/36/arw7Evbu2WKGifFOpwIQDgwxuiaAa306b1nqnPjRO/4Fyv36YKnZ2npjoMOpoMTKNgAACDo+U4PP5er1wDqWcfGifrk3mG6YVAr79juQ0W6+sV5+s/0zXK7mTIeLijYAAAgqJWUV2jG+gPeY6aHA3BCbFSEHr+8p164oa8SYysXWSx3W/39q3UaO3GhDuSXOJwQ9YGCDQAAgtrczdk67Nkep3VanDpmJDicCEA4u6BnU31x33D1aZXiHZu1MUvnPz1LszYeOP4bERIo2AAAIKhVWz28a2MZYxxMAwBSy9Q4vXfHEN01qr2OfEvKKijRTa8t1F+/XKuScvbMDlUUbAAAELTcblv9/uvuTRxMAwBVoiJc+tWYLnr9loFKT4j2jr80Y4sufna2Vuw65Fw41BkKNgAACFrLdx3y3teYGh+tfq0bOpwIAKob3rGRvrx/hIZ3TPeObdhfoMtfmKt/fr2eq9khhoINAACClu/V69FdMhThYno4gMDTKDFGk8cP1J8u7a4GURGSpAq31XPTNunS5+Zo1e5chxPCXyjYAAAgaFW7/5rVwwEEMJfL6OYhbfTVA8M1sG2qd3zdvnxd9vwcPfntBpWWux1MCH+gYAMAgKC0NeuwNmYWSJJiIl3Vpl8CQKBqnRavd24frD9e3E2xUZV1rNxt9cx3G3Xp83O0Zk+ewwlRGxRsAAAQlL5ds8/7+fCOjRQXHelgGgCoOZfLaPywtvry/hHq77N2xNq9ebrkudl65ruNKqvganYwomADAICgVG31cKaHAwhCbdPj9e4dQ/S7C7sqJrLqavaT327Q5S/M0fp9+Q4nxKmiYAMAgKCTW1imJdsPSpKMkUZ3zXA4EQCcngiX0W3D2+mL+4erb6sU7/iq3Xm66NlZen7aJpVzNTtoULABAEDQmb0pS25b+XmvFilKT4hxNhAA1FL7Rgl6/86h+r8LuijaczW7rMLqia/X67IX5uiHHQcdToiaoGADAICgM2NDpvfzkZ0aOZgEAPwnwmX0sxHt9cV9Z6p3yxTv+Krdebr8hbn61QcrlF1Q4lxAnBQFGwAABBVrrWZsOOA9pmADCDUdMhL14Z1D9MiYzt6r2ZL07uKdOuuf0/X6vG2qODKNBwGFgg0AAILK+v352p9XeQUnuUGUerdIdjgRAPhfZIRLd4/qoKkPjtRPfNaZyCsu1x8+Wa2Ln52tJdtzHEyIY6FgAwCAoDLT5+r1mR3SFRnBrzMAQlertDi9OnaAJozrr9Zpcd7xNXvzdMV/5ukX7y3XgXymjQcKfiIBAICgwvRwAOFodJfG+vqBEfrFOZ0UG1VV4z5cukuj/zldE2ZvZbXxAEDBBgAAQeNwSbkWba1aSXcEBRtAGImNitDPz+6oqQ+N1HndG3vH80vK9afP1uiiZ2drwZZsBxOCgg0AAILG/C3ZKvVcoenSJFFNkmMdTgQA9a9Fwzi9dFN/Tb5loNqlx3vH1+3L1zUvz9cD7/ygzLxiBxOGLwo2AAAIGkwPB4AqIzs10pcPDNcjYzqrQVSEd/zjZXs06p/T9fTUjTpcUu5gwvBDwQYAAEGDgg0A1cVERujuUR303S9G6sJeTb3jhaUV+vfUDRr5xHS9uWA792fXEwo2AAAICtuyDmt7dqEkKS46Qv3aNHQ4EQAEjmYpDfT89X315m2D1Llxonc8q6BEv/3vKp371Ex9vXqfrGX/7LpEwQYAAEHB9+r10PZpiomMOMGrASA8DeuQri/uH65/XNlLTZKq1qnYcuCw7piyRFe9OE9Lth88wRlQGxRsAAAQFJgeDgA1E+Eyurp/S017eJQeGdNZiTGR3ucWbz+oK/4zV3dOWaItBwocTBmaKNgAACDgFZdVaN7mqq1nRnbKcDANAASHBtGV92fPeOQsjR/WRlERxvvcV6v36Zx/z9TvPl6pA/klDqYMLRRsAAAQ8BZvO6iisgpJUtv0eLVKi3M4EQAEj9T4aP3x4u767qFRuqR3M+94hdvqjfk7NOqJaXpq6gZWHPcDCjYAAAh4MzZkej9nejgAnJ5WaXF65ro++t+9wzSkXZp3/HBphZ6aulEjn5iuV2dtUVFphYMpgxsFGwAABLyZG7K8n4/olO5gEgAIfr1apOit2wdp4vgBP1px/C+fr9WIJ6bptdlbVVxG0T5VFGwAABDQ9uYWaf3+fElSdIRLg32uugAATo8xRmd1ztAX9w/XE1f2UtPkqhXHD+SX6M+frdHwf0zTBIr2KaFgAwCAgDbTZ/XwgW1TFRcdeYJXAwBORYTL6Kr+LTX9l6P050u7V9va60B+if5E0T4lFGwAABDQ2J4LAOpeTGSEbhrSRjMeGaU/Hadoj/jHNE2cQ9E+EQo2AAAIWOUVbs3aWHX/9cjOFGwAqEsxkRG6eUgbTf/lKD12SXc1TorxPpeZX6LHPl2jkU9M0ySK9jFRsAEAQMBatvOQ8osrt41pmhyrjhkJDicCgPAQGxWhsUPbaMYvz9KjF3dTRmJV0d6fV6JHfYo2q45XoWADAICAdfT0cGOMg2kAIPzERkVo3LC2mvnIWfrjcYr20L99pye/Wa+sghIHkwYGCjYAAAhY3H8NAIEhNipC4z1F+w8XdVMjn6J9sLBMz3y/SUP/9r1+89FKbT5Q4GBSZ1GwAQBAQMoqKNGKXbmSKle5HdqB/a8BwGmxURG65cy2muW5ot2iYQPvc6Xlbr29cIfO/tcM3TZ5sRZty5G11sG09Y99LgAAQECa7bO4Wd9WKUpuEOVgGgCAryNXtG8a3Fpfrtqnl2du0crdud7np67dr6lr9+uMlin62Yh2Oq97E0W4Qv82Hwo2AAAISEwPB4DAFxnh0sW9m+miXk21YGuOXpm5Rd+ty/Q+v2znId395lK1So3TbcPb6sp+LRQXHbo1NHT/ZQAAIGi53VYzqxXsDAfTAABOxhijwe3SNLhdmjbuz9ers7bqvz/sVmmFW5K0I6dQf/hktZ78doNuGtxaNw9pU+0+7lDBPdgAACDgrNmbp+zDpZKktPhodW+W5HAiAEBNdWycqL9f2Uuzf32W7j2rQ7VbfA4VlunZ7zfpgmdmqdxTvkMJBRsAAAQc3+nhwzumyxUG9+0BQKjJSIzVw+d11rzfjNajRy2IdlW/FoqMCL06yhRxAAAQcGas95ke3pn7rwEgmMVFR2rcsLa6cXBrfb16vybO2apxQ9s4HatOBNSfDIwxLYwxE4wxe4wxJcaYbcaYp4wxDU/hHNuMMfY4H/vqMj8AAKi9vOIyLdlx0Hs8vCMFGwBCQWSESxf2aqoP7hqqjKRYp+PUiYC5gm2MaS9prqQMSZ9IWidpoKT7JY0xxgyz1mbX8HS5kp46xnj47ngOAECQmLspSxXuyn1TezZPVnpC6C2CAwAITQFTsCW9oMpyfZ+19tkjg8aYJyU9KOlxSXfW8FyHrLWP+j0hAACoc2zPBQAIVgExRdwY007SuZK2SXr+qKf/KOmwpJuMMfH1HA0AANQjay33XwMAglagXMEe7Xn8xlpbba12a22+MWaOKgv4YEnf1eB8McaYGyW1UmU5XyFpprW2wo+ZAQCAn23KLNCe3GJJUmJspPq0THE2EAAApyBQCnZnz+OG4zy/UZUFu5NqVrCbSJpy1NhWY8x4a+2M04sIAADqmu/08DM7pIfkFi4AgNAVKAU72fOYe5znj4yn1OBcEyXNkrRaUr6kdpLulfQzSV8aY4ZYa5ef7CTGmCXHeapLDTIAAIDTwP3XAIBgFigF+2SM59Ge7IXW2seOGlol6U5jTIGkX0h6VNLlfk0HAABqrbC0XAu25HiPR1CwAQBBJlAK9pEr1MnHeT7pqNedjhdVWbBH1OTF1tp+xxr3XNnuW4scAADgGBZsyVFpReVSLB0zEtQspYHDiQAAODWBcmPTes9jp+M839HzeLx7tGsi0/PISuQAAAQgpocDAIJdoBTsaZ7Hc40x1TIZYxIlDZNUJGl+Lb7GEM/jllqcAwAA1JGZG9ieCwAQ3AKiYFtrN0v6RlIbSfcc9fRjqrzq/Lq19rAkGWOijDFdjDHtfV9ojOlujEk9+vzGmNaSnvMcvuHn+AAAoJZ2ZBdqS9ZhSVJslEsD2vzoxzkAAAEvUO7BlqS7Jc2V9Iwx5mxJayUNknSWKqeG/9bntc09z29XZSk/4ipJvzbGTJO0VZWriLeXdKGkWElfSPpnnf4rAADAKZuxserq9ZB2aYqNinAwDQAApydgCra1drMxpr+kP0kaI+kCSXslPSPpMWttzone7zFNlXtq91HllPB4SYckzVblvthTrLUnXYkcAADUrxnruf8aABD8AqZgS5K1dqek8TV43TZVbd3lOz5D0gz/JwMAAHWlpLxCczdneY9Hds5wMA0AAKcvIO7BBgAA4WvxtoMqLK2QJLVKjVObtDiHEwEAcHoo2AAAwFHT1mV6Pz+rcyMZ86NJagAABAUKNgAAcNR0n+25RjE9HAAQxCjYAADAMTtzCrUps0CSFBPp0uB2aQ4nAgDg9FGwAQCAY3yvXg9pn6YG0WzPBQAIXhRsAADgmOk+91+PYnsuAECQo2ADAABHFJdVaI7P9lzcfw0ACHYUbAAA4IiFW3NUXOaWJLVLj1eb9HiHEwEAUDsUbAAA4Ihp66umh4/szPRwAEDwo2ADAABHTF9ftcDZWUwPBwCEAAo2AACod9uyDmtr1mFJUoOoCA1sm+pwIgAAao+CDQAA6t10n+nhQ9unKTaK7bkAAMGPgg0AAOqd7/7Xo7owPRwAEBoo2AAAoF4VlVZo3uZs7zH7XwMAQgUFGwAA1Kv5W7JVUl65PVeHjAS1TI1zOBEAAP5BwQYAAPXK9/7rs9ieCwAQQijYAACg3lhrNc1ne65RbM8FAAghFGwAAFBvtmYd1o6cQklSfHSE+rdp6HAiAAD8h4INAADqje/V62Ed0hUTyfZcAIDQQcEGAAD1xvf+a6aHAwBCDQUbAADUi8LSci3YkuM9HsUCZwCAEEPBBgAA9WLupmyVVlRuz9W5caKapTRwOBEAAP5FwQYAAPVimu/08C5cvQYAhB4KNgAAqHPWWk33WeDsLO6/BgCEIAo2AACoc5syC7T7UJEkKTEmUv1asz0XACD0ULABAECd8716fWbHdEVF8CsIACD08NMNAADUOd/7r5keDgAIVRRsAABQpwpKyrVoW9X2XCPZngsAEKIo2AAAoE7N2ZSlsgorSerWNEmNk2IdTgQAQN2gYAMAgDo13Xd7Lq5eAwBCGAUbAADUGWutpq3z2Z6rC/dfAwBCFwUbAADUmfX787Uvr1iSlBQbqT4tU5wNBABAHaJgAwCAOuN79Xp4p0aKZHsuAEAI46ccAACoM9PZngsAEEYo2AAAoE7kFZdp8faD3uORnVjgDAAQ2ijYAACgTszemKUKd+X2XD2bJ6tRYozDiQAAqFsUbAAAUCeqTw/n6jUAIPRRsAEAgN9ZazVtfdUCZ6PYngsAEAYo2AAAwO9W78nTgfwSSVLDuCj1bpHibCAAAOoBBRsAAPjdjA1VV69HdGqkCJdxMA0AAPWDgg0AAPxu2rqq+69Hcf81ACBMULABAIBf5RaWaemOyu25jJFGdKRgAwDCAwUbAAD41cyNB+TZnUu9W6QoLYHtuQAA4YGCDQAA/GraeqaHAwDCEwUbAAD4jdttNdNngbOzOrM9FwAgfFCwAQCA36zak6usglJJUlp8tHo2T3Y4EQAA9YeCDQAA/Gbauqqr1yM7N5KL7bkAAGGEgg0AAPym+v3XTA8HAIQXCjYAAPCL7IISLd91SJLkMtKIjunOBgIAoJ5RsAEAgF/M2pgl69meq2+rhkqJi3Y2EAAA9YyCDQAA/MJ3evhZXZgeDgAIPxRsAABQaxVuqxk+23Ox/zUAIBxRsAEAQK0t23lIhwrLJEkZiTHq1jTJ4UQAANQ/CjYAAKi16b7TwztnyBi25wIAhB8KNgAAqLXq918zPRwAEJ4o2AAAoFYy84q1aneeJCnSZTSsA9tzAQDCEwUbAADUynSfxc36t2moxNgoB9MAAOAcCjYAAKiVo++/BgAgXFGwAQDAaSurcGvWxizvMftfAwDCGQUbAACctqXbDyq/uFyS1DylgTpmJDicCAAA51CwAQDAaZu2vur+61GdG7E9FwAgrFGwAQDAaeP+awAAqlCwAQDAadlzqEjr9uVLkqIjXBraIc3hRAAAOIuCDQAATst0n+nhg9qlKi460sE0AAA4L6AKtjGmhTFmgjFmjzGmxBizzRjzlDGmoRPnAQAAxzfNZ3r4KKaHAwCggPlTszGmvaS5kjIkfSJpnaSBku6XNMYYM8xam11f5wEAAMdXUl6hOZt8tufq3MjBNAAABIZAuoL9gipL8X3W2sustb+21o6W9G9JnSU9Xs/nAQAAx7Fo60EVllZIklqnxalterzDiQAAcF5AFGxjTDtJ50raJun5o57+o6TDkm4yxpzwp7e/zgMAAE7s6NXD2Z4LAIAAKdiSRnsev7HWun2fsNbmS5ojKU7S4Ho6DwAAOIHq918zPRwAAClwCnZnz+OG4zy/0fPYqZ7OI2PMkmN9SOpysvcCABDKdmQXavOBw5Kk2CiXBrdjey4AAKTAKdjJnsfc4zx/ZDylns4DAACOY/qGqqvXQ9qlKTYqwsE0AAAEjoBZRfwkjtzYZevrPNbafsc8QeVV7L61zAEAQNCats7n/usubM8FAMARgXIF+8iV5eTjPJ901Ovq+jwAAOAYissqNHdz1W6XozpRsAEAOCJQCvZ6z+Px7o3u6Hk83r3V/j4PAAA4hnlbslVSXrmOaPtG8WqVFudwIgAAAkegFOxpnsdzjTHVMhljEiUNk1QkaX49nQcAABzD9HXVt+cCAABVAqJgW2s3S/pGUhtJ9xz19GOS4iW9bq09LEnGmChjTBdjTPvanAcAANSctVbT1h/wHnP/NQAA1QXSImd3S5or6RljzNmS1koaJOksVU7p/q3Pa5t7nt+uyjJ9uucBAAA1tDXrsHbkFEqS4qMj1L9NQ4cTAQAQWALiCrbkvfrcX9IkVRbiX0hqL+kZSUOstdnHf7f/zwMAAKrzvXo9rEO6YiLZngsAAF+BdAVb1tqdksbX4HXbVLXl1mmfBwAA1Nz09VX3X4/i/msAAH4kYK5gAwCAwHW4pFwLtuR4j0d1buRgGgAAAhMFGwAAnNTczdkqrajcnqtLk0Q1S2ngcCIAAAIPBRsAAJzUNKaHAwBwUhRsAABwQtbao/a/Zno4AADHQsEGAAAntGF/gfbkFkuSEmMj1bc123MBAHAsFGwAAHBCvquHj+jYSFER/PoAAMCx8BMSAACcUPX7r5keDgDA8VCwAQDAceUVl2nxtoPe45EUbAAAjouCDQAAjmvOxiyVu60kqUfzJGUkxjqcCACAwEXBBgAAx+U7PfwstucCAOCEKNgAAOCYrLWatv6A95j9rwEAODEKNgAAOKY1e/N0IL9EkpQSF6UzWqY4GwgAgABHwQYAAMc0a2OW9/PhHRspwmUcTAMAQOCjYAMAgGOatbFqevjwjukOJgEAIDhQsAEAwI8UlVZo0daq7bko2AAAnBwFGwAA/MiCrdkqrXBLkjpmJKhpcgOHEwEAEPgo2AAA4EdmH3X/NQAAODkKNgAA+JFqC5x1Yno4AAA1QcEGAADV7M8r1vr9+ZKk6AiXBrVNdTgRAADBgYINAACq8b163a91Q8VFRzqYBgCA4EHBBgAA1VTbnovp4QAA1BgFGwAAeLndttoCZyNY4AwAgBqjYAMAAK81e/OUfbhUkpQaH61uTZMcTgQAQPCgYAMAAK/Zm6quXp/ZIV0ul3EwDQAAwYWCDQAAvKrdf92R+68BADgVFGwAACBJKiqt0KKtB73Hw7n/GgCAU0LBBgAAkqQFW7NVWuGWJHXMSFCT5FiHEwEAEFwo2AAAQFL1/a+5eg0AwKmjYAMAAEnsfw0AQG1RsAEAgPblFmvD/gJJUnSES4PapjqcCACA4EPBBgAA1bbn6t+moeKiIx1MAwBAcKJgAwCAo7bn4v5rAABOBwUbAIAw53Zbza62wBn3XwMAcDoo2AAAhLk1e/OUfbhUkpQaH61uTZMcTgQAQHCiYAMAEOZ8t+c6s0O6XC7jYBoAAIIXBRsAgDBX/f5rpocDAHC6KNgAAISxotIKLd520HvMAmcAAJw+CjYAAGFswdZslVa4JUmdGieoSXKsw4kAAAheFGwAAMLYrGqrh3P1GgCA2qBgAwAQxnzvvz6T+68BAKgVCjYAAGFqX26xNuwvkCRFR7g0qG2qw4kAAAhuFGwAAMKU79Xr/m0aKi460sE0AAAEPwo2AABhivuvAQDwLwo2AABhyO22mrPJt2Bz/zUAALVFwQYAIAyt2Zun7MOlkqS0+Gh1a5rkcCIAAIIfBRsAgDDkOz38zI7pcrmMg2kAAAgNFGwAAMJQte25OjA9HAAAf6BgAwAQZgpLy7V420HvMQucAQDgHxRsAADCzIKtOSqtcEuSOjVOUJPkWIcTAQAQGijYAACEmVkb2J4LAIC6QMEGACDMzN5Udf8123MBAOA/FGwAAMLIvtxibdhfIEmKjnBpUNs0hxMBABA6KNgAAIQR39XDB7RtqAbREQ6mAQAgtFCwAQAII9X2v+7A/dcAAPgTBRsAgDDhdlvN3uS7wBn3XwMA4E8UbAAAwsSavXnKOVwqSUqLj1a3pkkOJwIAILRQsAEACBPVpod3TJfLZRxMAwBA6KFgAwAQJnwXOGP/awAA/I+CDQBAGCgsLdfibQe9x9x/DQCA/1GwAQAIAwu25qi0wi1J6tQ4QY2TYh1OBABA6KFgAwAQBmZuYHo4AAB1jYINAEAY8F3gbEQnCjYAAHWBgg0AQIjbc6hImzILJEnRkS4NbJPqcCIAAEJTwBRsY8xQY8wXxpgcY0yhMWaFMeYBY0zEKZyjjTHGnuDjnbr8NwAAEIh8Vw8f1DZVDaJr/KMVAACcgkinA0iSMeZSSR9KKpb0rqQcSRdL+rekYZKuOsVTLpf08THGV51+SgAAgtNMn+nhrB4OAEDdcbxgG2OSJL0iqULSKGvtYs/47yV9L+lKY8y11tpTufq8zFr7qN/DAgAQZCrcVrOrFWzuvwYAoK4EwhTxKyU1kvTOkXItSdbaYkm/8xze5UQwAACC3crducotKpMkNUqMUZcmiQ4nAgAgdDl+BVvSaM/jV8d4bqakQklDjTEx1tqSGp6zmTHmDklpkrIlzbPWrqh9VAAAgsusattzpcsY42AaAABCWyAU7M6exw1HP2GtLTfGbJXUXVI7SWtreM5zPB9expjpksZaa3fU5ATGmCXHeapLDTMAAOC4mT4LnI1key4AAOpUIEwRT/Y85h7n+SPjKTU4V6GkP0vqJ6mh52OkpGmSRkn6zhgTf7pBAQAIJvnFZVq645D3eFgHFjgDAKAu+eUKtjFmm6TWp/CWN621N9b09J5He7IXWmszJf3hqOGZxphzJc2WNEjSbZKersG5+h0zTOWV7b4ne79TDuSXKKlBpGIi2YIFAMLd3M3ZqnBX/vjs3ixJ6QkxDicCACC0+WuK+GZVbrFVU3t8Pj9yhTr5WC+UlHTU606ZZ6r5q6os2CNUg4IdrB77dLXmbs7WNQNa6oZBrdSiYZzTkQAADvHd/3oE08MBAKhzfinY1tqza/H29ZL6S+okqdp9z8aYSEltJZVL2lKLryFJR37LCNkp4pl5xfpq1T6Vu63+M32zXpqxWaO7NNbNQ1rrzA7pcrlY2AYAwsks9r8GAKBeBcI92N97Hscc47kRkuIkzT2FFcSPZ7DnsbZFPWBtzylU46RY77HbSlPX7tfNExbq7Cdn6NVZW5RbWOZgQgBAfdmefVjbswslSXHREerXuqHDiQAACH2BULA/kJQl6VpjTP8jg8aYWEl/8Rz+x/cNxphkY0wXY0zTo8YHGWOij/4CxpjRkh70HL7hz/CBZECbVM185Cy9fFO/H12p2Jp1WH/5fK0G/XWqfv3hCq3ec9oz7gEAQWCmz9Xrwe3SWJsDAIB64Pg2XdbaPGPM7aos2tONMe9IypF0iSq38PpA0rtHve1ySRMlTZY0zmf875K6e7bk2uUZ66WqvbZ/b62dWwf/jIAR4TI6t3sTndu9ibYcKNCU+dv1wZJdyi8ulyQVl7n1zqKdemfRTvVr3VA3DW6t83s24RcvAAgxM4/a/xoAANQ9xwu2JFlrPzbGjJT0W0lXSIqVtEnSQ5KesdaedAVxjymqLN8DJJ0vKUrSfknvSXrOWjvL39kDWbtGCfrjxd31y/M665Nle/T6vO1auzfP+/yS7Qe1ZPtB/eXzaF0zoKVuHNxaTZMbOJgYAOAPZRVuzduc7T1mgTMAAOqHqXl3hVS5TVffvn37Llmy5OQvDjDWWi3ZflCvz9uuL1ftVVlF9f/tI11Gl5zRTD8b0U5dmiQd5ywAgEC3aFuOrnpxniSpeUoDzf7VWTKGhS4BAKiJfv36aenSpUuPt3XziQTEFWzUD2OM+rdJVf82qcrM76p3F+7UWwt3aG9u5Q5r5W6rj5bu1kdLd2tkp0a6Y2Q7DWmXxi9lABBkfKeHj+iUzvdxAADqCQU7TGUkxurnZ3fUXaPaa+ra/Zowe5sWbsvxPj9jwwHN2HBAPZsn62cj2un8Hk0UGREIa+IBAE5mZrXtuZgeDgBAfaFgh7nICJfG9GiqMT2aaumOg3p5xhZ9vWafjtw5sHJ3rn7+9g9qmdpAtw5rq6sHtFRcNP/ZAECgOni4VCt2HZIkuYw0rD0LnAEAUF+4JAmvvq0a6sWb+un7X4zSDYNaKTqy6j+PnTlFevTTNRr6t+/15DfrlVVQ223JAQB1Yc7mLO8fSXu3TFFyXJSzgQAACCMUbPxI2/R4PX55T8399WjdN7qDUnx+OTtUWKZnvt+kYX/7Xv/335XalnXYwaQAgKPN2sD0cAAAnELBxnGlJ8TooXM7a+6vR+uxS7qrRcOqLbxKyt16a8EOnf3kDD303jJtpWgDgOOstZq5sWqBs5GdmB4OAEB9omDjpOKiIzV2aBtNf3iUnr2uj3o2T/Y+V+FZefzsf03XQ+8u05YDBQ4mBYDwtvlAgXdniMSYSPVukeJsIAAAwgyrVaHGIiNcurh3M13Uq6nmbcnW89M2ac6mbEmS20of/bBbHy/brUt6N9O9ozuqQ0aCw4kBILzM8JkePrRDGrs/AABQzyjYOGXGGA1tn66h7dO1eFuOnv5uo2Z5toRxW+njZXv0yfI9uqR3M/18dAd1yEh0ODEAhIdZG333v+b+awAA6ht/2kat9G+Tqim3DtKHdw3R8I5V9/pZK32ybI/O+fdM/fztH7Rxf76DKQEg9JWUV2j+lmzv8QgWOAMAoN5RsOEX/VofKdpDNdLnqom10qfL9+jcp2bqnreWav0+ijYA1IXF2w6quMwtqXI3iJapcQ4nAgAg/FCw4Vf9WjfU5FsG6r93D9WoztWL9ucr9uo8T9Fmey8A8C/f1cN9ZxQBAID6Q8FGnejTqqEmjR+oj+8ZptFdMqo99/mKvfrJkzP0x09WKaugxKGEABBaZrL/NQAAjqNgo06d0TJFE8YN0Cf3DNPZPkW73G01ed52jXpiup79bqMKS8sdTAkAwS0zv1hr9+ZJkiJdRkPapzmcCACA8ETBRr3o3TJFr40boI/uHqqBbVK94wUl5frXtxs06onpenvhDpVXuB1MCQDBac6mqqvXfVs3VEIMm4QAAOAECjbqVd9WDfXuHYP1ys39q+2TnZlfot98tFJjnp6lb9fsl7XWwZQAEFx8p4ePZHsuAAAcQ8FGvTPG6JxujfXV/cP115/2VEZijPe5TZkFuv31xbr6pXlauuOggykBIDi43VazNvref80CZwAAOIWCDcdERrh03cBWmv7LUXr43E7VpjQu2nZQP31hru56Y4m2HChwMCUABLa1+/K8C0Y2jItS92bJDicCACB8UbDhuLjoSN07uqNm/HKUxg1to0iX8T735ap9OvffM/WHT1bpUGGpgykBIDD5Xr0+s2MjRfh8DwUAAPWLgo2AkZYQo0cv6a6pD43Uhb2aesfL3Vavz9uu0f+aofcW7ZTbzf3ZAHDELPa/BgAgYFCwEXDapMfr+ev76pN7hmlwu6oVx3MOl+qRD1foihfnatXuXAcTAkBgKCwt16KtVetVjGD/awAAHEXBRsDq3TJFb98+WC/e2E/NUxp4x3/YcUiXPDdbf/hklXILyxxMCADOWrA1R6We7Q07NU5Qk+RYhxMBABDeKNgIaMYYjenRRFMfGql7z+qg6IjK/2TdVp5p49P1/mKmjQMITzM3+E4P5+o1AABOo2AjKDSIjtDD53XWVw8Mr3aPYfbhUv3ygxW66qV5Wr2HaeMAwovvAmcj2P8aAADHUbARVNo1StDrtwzUf27oq6Y+UyGXbD+oi5+drUf/t1q5RUwbBxD69hwq0qbMym0MoyNdGtgm9STvAAAAdY2CjaBjjNH5PZvqu1+M1F2j2isqonJLGreVJs3dprP/NV0fLtkla5k2DiB0+a4ePqhtqhpERziYBgAASBRsBLG46Ej9akwXfXn/CJ3ZoWraeFZBqX7x/nJd89J8bTlQ4GBCAKg7M32mh7M9FwAAgYGCjaDXISNBU24dqOev76smSVXTxhduy9EFz8zShNlbWQQNQEipcFvNrlawuf8aAIBAQMFGSDDG6MJeldPG7xjZTpGuymnjxWVu/emzNbr2lfnakV3ocEoA8I+Vu3O96000SoxRlyaJDicCAAASBRshJj4mUr85v6s+uXdYtV84F27N0ZinZ2rKvG1czQYQ9L5fl+n9fHjHdBljHEwDAACOoGAjJHVvlqz/3Xumfj66gyI8V7MLSyv0+09W66YJC7TrIFezAQSvqWv2ez8/u0tjB5MAAABfFGyErOhIl35xbmd9dNdQdcxI8I7P2ZStMU/N0jsLd7DSOICgs/tQkdbszZMkRUe4NLIz918DABAoKNgIeb1bpujTn5+pO0e2l+ditgpKyvXrj1Zq3MRF2ptb5GxAADgF362tuno9uH2aEmIiHUwDAAB8UbARFmKjIvTr87vo/TuHql16vHd8xoYDOvffM9k3G0DQ+NZnevg5XTMcTAIAAI5GwUZY6de6ob64f7huPbOtjqwJlF9crl+8v1y3v75YmfnFzgYEgBPILy7T/C3Z3uOzu3L/NQAAgYSCjbATGxWh31/UTe/+bIhap8V5x6euzdS5/55Z7eoQAASSmRuyVFZROdume7MkNUtp4HAiAADgi4KNsDWwbaq+vH+4xg5p7R07VFim219frMc/X6OyCreD6QDgx6b63H/9E65eAwAQcCjYCGtx0ZF67NIeeuu2QWqWHOsdf2XWVl390jztPsQCaAACQ1mFu9r+1+d0o2ADABBoKNiApKEd0vX5fcM1ukvVgkE/7DikC5+Zpe/XMWUcgPMWbzuo3KIySVKTpFh1b5bkcCIAAHA0Cjbg0TA+Wq/e3F+/Ob+LIjz7eR0qLNMtkxbrr1+uZco4AEdVmx7eLUPmyEqNAAAgYFCwAR8ul9EdI9vr3Z8NVpOkqinjL83Youtens+e2QAcYa3l/msAAIIABRs4hv5tUvXF/cM1slMj79ji7Qd1wdOzNG195gneCQD+tymzQNuzCyVJ8dERGtI+zeFEAADgWCjYwHGkxkdr4rgBemRMZ++U8YOFZRo/cZH+8dU6lTNlHEA9+dbn6vXIzo0UExnhYBoAAHA8FGzgBFwuo7tHddDbtw9W46QY7/gL0zfr+lcWaF9usYPpAISLqWuYHg4AQDCgYAM1MLBtqj6/b7iGd0z3ji3clqMLn5mlmRsOOJgMQKg7kF+iH3YekiS5jHRW54wTvwEAADiGgg3UUHpCjCaPH6iHz+0kz4xxZR8u1diJC/XsdxtlrXU2IICQNG1dpo58e+nfJlUN46OdDQQAAI6Lgg2cApfL6N7RHfXmbYPVKLFyyri10r++3aC731yqwyXlDicEEGq+8Zkefg7TwwEACGgUbOA0DGmfpi/uG67B7VK9Y1+u2qcr/jNXO3MKHUwGIJQUlVZo9qaq21B+0o2CDQBAIKNgA6epUWKMptw6SOOGtvGOrduXr0uem625m7KcCwYgZMzZlKXissodC9o3ilfb9HiHEwEAgBOhYAO1EBXh0qOXdNffr+ipqIiqrbxumrBQk+Zs5b5sALUy1Wd7Lq5eAwAQ+CjYgB9cM6CV3vnZEO992RVuq0c/XaNffbhCJeUVDqcDEIzcbqupazO9x9x/DQBA4KNgA37Sr3VDfXrvmerdItk79t7iXbr25fnKzGO/bACnZvmuQ8oqKJEkpcVHq0+rhg4nAgAAJ0PBBvyoSXKs3r1jiH7at7l37Icdh3Txc7O1zLOPLQDUhO/08NFdMhRxZH9AAAAQsCjYgJ/FRkXoX1f11u8v6ubdL3t/XomufmmePliyy9lwAILG1DVV08O5/xoAgOBAwQbqgDFGt57ZVpNvGajkBlGSpNJytx5+f7n+9OkalVe4HU4IIJDtyC7U+v35kqToSJeGd0x3OBEAAKgJCjZQh4Z3bKT/3TtMnRoneMcmzNmqsRMX6lBhqYPJAAQy3+nhZ3ZIV1x0pINpAABATVGwgTrWOi1eH909TOf6TPGcsylbl78wV1uzDjuYDECg+naNz/ZcrB4OAEDQoGAD9SAhJlIv3thPD/yko3dsa9ZhXf7CHM3fku1gMgCBJrewTAu35XiPz+6a4WAaAABwKijYQD1xuYwe+EknvXBDX8VEVv5f71BhmW56bQGLnwHwmr4hUxVuK0nq3SJZjZNiHU4EAABqioIN1LMLejbVu3cMUXpCjCSprMLq4feX659fr5fb80s1gPDF9HAAAIIXBRtwwBktU/TxPUPVpUmid+y5aZv087d/UHFZhYPJADiptNytGesPeI/ZngsAgOBCwQYc0qJhnN6/c4hGdW7kHft85V5d+/J8HcgvcTAZAKcs3Jqj/JJySVKLhg2q/REOAAAEPgo24KDE2Ci9enN/jR3S2ju2bOchXfb8HK3fl+9gMgBO8N2e6yddG8sY42AaAABwqhwv2MaYKGPM/caYicaYZcaYUmOMNcbcVotzDjXGfGGMyTHGFBpjVhhjHjDGRPgzO+APkREuPXZpDz16cTe5PL9L7z5UpCv+M1czNhw48ZsBhAxrbbX7r89hejgAAEHH8YItKV7SU5LGSWoiaV9tTmaMuVTSTEkjJP1X0vOSoiX9W9I7tTk3UJfGDWur18YOUHx05d+BCkrKdcukRZoyf7vDyQDUh3X78rX7UJEkKTE2UgPbpjqcCAAAnKpAKNiFki6Q1Mxa20TShNM9kTEmSdIrkiokjbLW3mqt/aWkMyTNk3SlMeba2kcG6sZZXTL0wV1D1Sy5clueCrfV7z9epcc+Xe3dtgdAaPK9ej2qc4aiIgLhRzQAADgVjv/0ttaWWmu/tNbu9cPprpTUSNI71trFPl+jWNLvPId3+eHrAHWma9MkfXzPMPVqkewdmzhnm372+mIVeBY/AhB6qt9/neFgEgAAcLocL9h+Ntrz+NUxnpupyqvlQ40xMfUXCTh1GUmxevdnQzSmexPv2HfrMnX9K/OVc7jUwWQA6sK+3GKt2JUrSYp0GY3qRMEGACAYhVrB7ux53HD0E9backlbJUVKalefoYDT0SA6Qi/c0Fd3jmzvHVuxK1fXvDRP+3KLHUwGwN++W1d19Xpg21Qlx0U5mAYAAJyuUCvYR+bU5h7n+SPjKSc7kTFmybE+JHXxQ06gRlwuo1+f30WPX95DR3br2ZhZoCtfnKvt2YedDQfAb6auqb49FwAACE5+KdjGmG2erbVq+vGGP77u6UT1PLJaFILKDYNa6+lr+yjSs4/XroNFuvLFeVq3L8/hZABq63BJueZszvYesz0XAADBK9JP59ks6VTmrO7x09c92pEr1MnHeT7pqNcdl7W237HGPVex+556NKB2LundTAkxEbrrjaUqKXfrQH6JrnlpviaNH6A+rRo6HQ/AaZq18YBKy92SpC5NEtUyNc7hRAAA4HT55Qq2tfZsa22XU/h4xB9f9xjWex47Hf2EMSZSUltJ5ZK21NHXB+rU6C6N9fotA5UQU/m3sdyiMt3w6gLN2ZTlcDIAp+vTFVWbaDA9HACA4BZq92B/73kcc4znRkiKkzTXWltSf5EA/xrULk1v3z5YqfHRkqTC0gqNn7hIX63a53AyAKcqv7is2v3XF/Vu6mAaAABQW0FZsI0xycaYLsaYo38T+UBSlqRrjTH9fV4fK+kvnsP/1FNMoM70bJGs9+4YoqbJsZKk0gq37n5ziT5YssvhZABOxder96vEZ3p4lyZJJ3kHAAAIZAFRsI0xvzbGTDLGTJJ0mWd4/JExY8xtR73lcklrJf3Vd9BamyfpdkkRkqYbY141xvxD0jJJQ1RZwN+ts38IUI86ZCTo/TuHqE1a5f2abis9/P5yTZyz1eFkAGrqk2W7vZ9f1qe5g0kAAIA/BETBVuWU7rGej96esaE+Y2fW9ETW2o8ljZQ0U9IVkn4uqUzSQ5KutdaygjhCRouGcXrvziHq0iTRO/bYp2v09NSN4j91ILBl5hd7108wpnIhQwAAENz8tYp4rVhrR53i6ydJmnSC5+dIuqBWoYAgkZEYq3d/NkTjJy3U0h2HJEn/nrpBuUVl+t2FXeVymROfAIAjPl2+V27P38EGtklVs5QGzgYCAAC1FihXsAHUQnJclN64bZCGd0z3jk2Ys1WPfLhC5RVuB5MBOB6mhwMAEHoo2ECIiIuO1Ktj++v8Hk28Yx8s2aX7311GyQYCzJYDBVqxK1eSFB3h0gU9WD0cAIBQQMEGQkhMZISeva6PrurXwjv2+Yq9euTDFXK7uScbCBQfL9vj/XxU50ZKjotyMA0AAPAXCjYQYiIjXPr7Fb00dkhr79hHS3frd5+sYuEzIABYa5keDgBAiKJgAyHI5TJ69JLuum5gS+/YWwt26M+fraVkAw5btvOQtmcXSpISYyI1ukuGw4kAAIC/ULCBEGWM0V8u66nLfa6OTZizVf/8Zr2DqQB84jM9fEyPJoqNinAwDQAA8CcKNhDCIlxGT1zZq9rCZ89P26znvt/oYCogfJVXuPXZiqqCzfRwAABCCwUbCHGRES49fW2fatNQ//nNBr06a4uDqYDwNHtTlrIKSiVJGYkxGtwuzeFEAADAnyjYQBiIjnTphRv66swOVftk/+XztZoyf7uDqYDw4zs9/JLezRThMg6mAQAA/kbBBsJEbFSEXr65nwa2SfWO/f7jVfpgyS4HUwHho7C0XF+v3uc9Zno4AAChh4INhJG46Ei9Nq6/erdM8Y498sFyfbp8z/HfBMAvvl2zX4WlFZKk9o3i1b1ZksOJAACAv1GwgTCTGBul18cPVLemlb/cu6304LvL9I3PlTUA/uc7PfyyM5rLGKaHAwAQaijYQBhKjovSlFsHqkNGgiSp3G1171s/aMaGAw4nA0JTzuFSzfT5/9elZzA9HACAUETBBsJUWkKM3rptkNqkxUmSSivc+tnrizVvc7bDyYDQ8/mKPSp3W0lS31YpauX5/x0AAAgtFGwgjGUkxerN2wereUoDSVJJuVu3Tl6kJdsPOpwMCC0fL2PvawAAwgEFGwhzzVMa6K3bB6lxUowkqbC0QuMmLtSaPXkOJwNCw86cQu8frSJcRhf2bOpwIgAAUFco2ADUOi1eb942WOkJ0ZKk/OJy3TxhobZmHXY4GRD8Plm22/v5iI7pSkuIcTANAACoSxRsAJKkDhkJmnzLQCXGRkqSsgpKdOOrC7Qvt9jhZEDwstYyPRwAgDBCwQbg1b1ZsiaOG6DYqMpvDbsPFenG1xYo53Cpw8mA4LR6T542ZRZIkuKiI3ROt8YOJwIAAHWJgg2gmv5tUvXijf0UFVG5R++mzAKNm7hQBSXlDicDgo/v9PBzuzVWXHSkg2kAAEBdo2AD+JFRnTP05NVnyFR2bK3YlavbJy9WcVmFs8GAIFLhtvrf8qrp4ZcyPRwAgJBHwQZwTBf3bqbHL+vpPZ63JVs/f/sHlVe4HUwFBI8FW7K1P69EkpQWH63hHdIdTgQAAOoaBRvAcV0/qJV+NaaL9/jbNfv1yIcr5HZbB1MBweFjn+nhF/VqqsgIfuQCABDq+GkP4ITuGtVed4xs5z3+aOlu/emzNbKWkg0cT3FZhb5cuc97zPRwAADCAwUbwEn9ekwXXTewpfd40txtevq7jQ4mAgLbtHWZyvcsDNg6LU59WqY4GwgAANQLCjaAkzLG6C+X9dSFPZt6x56aulET52x1MBUQuHynh1/au5nMkRUDAQBASKNgA6iRCJfRv685Q8M7Vi3U9Nina/Thkl0OpgICT25hmaatO+A9Zno4AADhg4INoMaiI1166aZ+6te6oXfskQ9X6JvV+07wLiC8fLlqr0o9q+33bJ6s9o0SHE4EAADqCwUbwCmJi47UhLED1KVJoqTKvX7vffsHzd2c5XAyIDBUmx5+RjMHkwAAgPpGwQZwypLjovT6rQPVJi1OklRa7tbtkxdr1e5ch5MBztqbW6QFW3MkSS4jXdKbgg0AQDihYAM4LRmJsZpy6yA1ToqRJB0urdC4iQu1Leuww8kA53yybI+O7GA3tH26MpJinQ0EAADqFQUbwGlrmRqnKbcOUnKDKElSVkGpbpqwQJl5xQ4nA+qf2231zsId3uPLWNwMAICwQ8EGUCudGidqwrj+io2q/HayM6dIYycuUl5xmcPJgPo1b0u2tmUXSpISYyOrbWsHAADCAwUbQK31a52qF27oqwhX5V6/a/fm6fbJi1VcVuFwMqD+vLlgu/fzK/q2UIPoCAfTAAAAJ1CwAfjF6C6N9fcrenmPF2zN0f3v/KAKt3UwFVA/MvOL9c3q/d7j6we1cjANAABwCgUbgN9c2a+FfnN+F+/x16v363cfr5S1lGyEtvcX71K5549JA9o0VKfGiQ4nAgAATqBgA/CrO0a21+3D23qP3164U09+u8HBREDdqnBbve2zuBlXrwEACF8UbAB+95vzu+qnPisoP/v9Jk2as9XBREDdmbnxgHYdLJIkpcRF6fweLG4GAEC4omAD8DuXy+jvV/bSWZ0becce+2yNPl2+x8FUQN14a0HV1esr+7ZQbBSLmwEAEK4o2ADqRFSES8/f0Fd9WqVIkqyVHnpvmWZtPOBsMMCP9uYW6ft1md7j65geDgBAWKNgA6gzcdGRmjB2gDpkJEiSyiqs7piyRCt2HXI2GOAn7y7a6V0pf0i7NLVvlOBwIgAA4CQKNoA61TA+Wq/fMlBNk2MlSYWlFRo3cZG2HChwOBlQO+UVbr27aKf3mMXNAAAABRtAnWuW0kBTbh2olLgoSVLO4VLd9NpC7c8rdjgZcPqmrT+gvbmV/w2nxUfrvO5NHE4EAACcRsEGUC86ZCRqwrgBauBZAGr3oSKNnbBQuUVlDicDTs9bC7Z7P7+qf0tFR/IjFQCAcMdvAwDqTd9WDfXCjX0V4TKSpHX78nXHlMUqKa9wOBlwanYdLNT0DVUL9l03sKWDaQAAQKCgYAOoV2d1ztATV/byHs/fkqOH318ht2ehKCAYvLNwp6znP9nhHdPVOi3e2UAAACAgULAB1Luf9m2hX57X2Xv86fI9+ttX6xxMBNRcWYVb7y6uWtzsBhY3AwAAHhRsAI64e1R73Ti4qpi8PHOLJs7Z6mAioGamrtmvA/klkqSMxBid3bWxw4kAAECgoGADcIQxRo9d0kPndKsqJ3/6bI2+XLnXwVTAyb21cIf382sGtFRUBD9KAQBAJX4rAOCYCJfRM9f2UZ9WKZIka6X7312mhVtznA0GHMe2rMOatTFLkmRMZcEGAAA4goINwFENoiP02tgBapteuUhUablbt7++WJsy8x1OBvzY24uqrl6f1TlDLRrGOZgGAAAEGgo2AMelxkdr8viBSk+IkSTlFpVp7IRF2p9X7HAyoEpJeYU+WLzLe3z9QBY3AwAA1VGwAQSEVmlxmjhugOKiIyRJuw8VadzERcovLnM4GVDp69X7lX24VJLULDlWZ3XJcDgRAAAINBRsAAGjZ4tkvXBDX0W4jCRp7d483fXGUpWWux1OBkhvLdju/fyaAa28/50CAAAcQcEGEFBGdc7Q337a03s8e1OWfvXhCllrHUyFcLcps0Dzt1QuvhfhMixuBgAAjomCDSDgXNW/pR46p5P3+L8/7NY/vl7vYCKEu7d9tuY6u0uGmiTHOpgGAAAEKgo2gID089EddN3AqquE/5m+WVPmbXMuEMJWcVmFPljis7jZIBY3AwAAx0bBBhCQjDH686U9dLbPQlJ/+N9qfb16n4OpEI6+WLlXuUWVi+21aNhAIzo2cjgRAAAIVBRsAAErMsKlZ6/vo94tUyRJ1kr3vf2Dlmw/6GwwhJW3FlRND79uYCu5WNwMAAAcBwUbQECLi47Ua2P7q3VanCSppNyt2yYv0tasww4nQzhYvy9fiz1/0Il0GV3Vv4XDiQAAQCCjYAMIeOkJMZo8fqBS46MlSQcLyzRu4kJlF5Q4nAyhzndrrvO6N1FGIoubAQCA46NgAwgKbdLj9erY/oqNqvy2tT27ULdOXqyi0gqHkyFUFZaW66Olu73HLG4GAABOhoINIGj0bdVQT1/bR8ZzC+yynYd0/zs/qMLNHtnwv8+W71V+SbkkqU1anIa0S3M4EQAACHQUbABB5bzuTfTHi7p5j79Zs19//myNrKVkw38q3FYvzdzsPb5+EIubAQCAk3O8YBtjoowx9xtjJhpjlhljSo0x1hhz22mcq43nvcf7eKcu/g0A6te4YW11+/C23uNJc7fptdlbHUyEUPPp8j3afKByIb2EmEhd3b/lSd4BAAAgRTodQFK8pKc8n++XtE9SbX+TWS7p42OMr6rleQEEiN+c31V7DhXr85V7JUl/+XytmiY30IW9mjqcDMGuvMKtZ77b6D2+ZVgbpcRFO5gIAAAEi0Ao2IWSLpC0zFq71xjzqKQ/1vKcy6y1j9Y2GIDA5XIZ/evq3tqfV+zdRunB95YpIylGA9qkOpwOwex/y/doi2cbuMTYSN16ZjuHEwEAgGDh+BRxa22ptfZLa+1ep7MACC6xURF65eb+atcoXpJUWu7W7a8v1uYDBQ4nQ7D68dXrtkqOi3IwEQAACCaOF+w60swYc4cx5v88j72cDgSgbjSMj9bk8QOVnlA5hfeQZ4/sA/nskY1T98myPdqWXSip8ur1LWe2Pck7AAAAqoRqwT5H0ouSHvc8LjfGTDPG1HgTU2PMkmN9SOpSR5kBnKaWqXGaMG6AGkRFSJJ25hTp1smLVFha7nAyBJPyCree/b7q6vVtZ7ZTcgOuXgMAgJoLtYJdKOnPkvpJauj5GClpmqRRkr4zxsQ7lg5AnenVIkXPXd9HR3ZSWrErVz9/6weVV7idDYag8d8fdnuvXifFRmr8mW2cDQQAAIKOXwq2MWbbSbbHOvrjDX983aNZazOttX+w1i611h7yfMyUdK6kBZI6SKrR9l/W2n7H+pC0ri6yA6i9s7s21p8u7eE9/m5dph79dDV7ZOOkyircevb7Td7j24e3U1IsV68BAMCp8dcq4pslFZ/C6/f46evWiLW23BjzqqRBkkZIero+vz6A+nPj4NbadbBIL87YLEl6Y/4ONU+J012j2jucDIHsv0t3a0dO5dXrlLgojRvWxtlAAAAgKPmlYFtrz/bHeerYAc8jU8SBEPfIeZ2151CR/re88m95f/9qnTISY3RFvxYOJ0MgKqtw69lpVfde3z68nRK5eg0AAE5DqN2DfSKDPY9bHE0BoM65XEZPXNVLg9pW7Yf9yIcr9P26/Q6mQqD6cMku7cwpkiQ1jIvS2KFtnA0EAACCVlAWbGNMsjGmizGm6VHjg4wx0cd4/WhJD3oO6+T+bwCBJSYyQi/f3F9dmiRKkircVne/uVRLtuc4nAyBpLT8qHuvR7RTQoy/7p4CAADhJiAKtjHm18aYScaYSZIu8wyPPzJmjDl6YbLLJa2V9Nejxv8uabcx5n1jzL89H99J+k5SjKTfW2vn1t2/BEAgSW4Qpcm3DFSLhg0kScVlbo2fuEjr9+U7nAyB4oMlu7T7UNXV65uHtHE2EAAACGoBUbAljZE01vPR2zM21GfszBqeZ4oqVwsfIOl2SXdL6ijpPUkjrLV/8WNmAEGgcVKsptw6SGnxlZNb8orLdfOEBdp1sNDhZHBaablbz0+runr9sxHtuXoNAABqJSAKtrV2lLXWnOBj3FGvn3Sc8destRdZa9tYaxOstTHW2lbW2mustbPq898EIHC0TY/X5FsGesvT/rwS3fzaQmUXlDicDE56f8lO79Xr1Pho3TyktcOJAABAsAuIgg0Ada1H82S9fFM/RUdUftvbknVY4yctUkFJucPJ4ISS8go973Pv9R0j2imeq9cAAKCWKNgAwsbQDul6+tozZEzl8YpdubpjymKVlFc4Gwz17r3Fu7Qnt1iSlJ4QrZu4eg0AAPyAgg0grJzfs6n+clkP7/GcTdl66N3lqnBbB1OhPpWUV+iFab5Xr9srLpqr1wAAoPYo2ADCzg2DWusX53TyHn++cq8e/d9qWUvJDgfvLtqpvd6r1zG6cTBXrwEAgH9QsAGEpXtHd9C4oW28x1Pmb9fT3210LhDqRXFZRbWVw+8c2U4NoiMcTAQAAEIJBRtAWDLG6A8XddMlvZt5x56aulFT5m1zLhTq3DsLd2h/XuXq8Y0SuXoNAAD8i4INIGy5XEb/vKq3RnRq5B37w/9W67MVexxMhbpSXFahF6Zv9h7fNbK9YqO4eg0AAPyHgg0grEVHuvTijX11RssUSZK10oPvLtPsjVnOBoPfvb1whzLzK69eZyTG6PpBrRxOBAAAQg0FG0DYi4uO1MRxA9QhI0GSVFZh9bMpi7V0x0GHk8Ffjr56ffcorl4DAAD/o2ADgKSG8dF6/ZaBapocK0kqLK3Q2NcWavnOQ84Gg1+8MX+7DniuXjdOitG1A7l6DQAA/I+CDQAezVIaaMqtA5UWHy1Jyi8p102vLdCq3bkOJ0NtbM8+rCe/3eA9vntUB65eAwCAOkHBBgAfHTIS9cZtg5QSFyVJyisu142vLdDavXkOJ8PpqHBbPfTechWWVkiSOmQk6NqBLR1OBQAAQhUFGwCO0rVpkt64dZCSYiMlSYcKy3TDqwu0YX++w8lwql6csVlLtlfeSx/pMvr31WcoJpKr1wAAoG5QsAHgGHo0T9Ybtw1Soqdk5xwu1fWvLNCmzAKHk6GmVu/J1VNTq6aG33d2R/VskexgIgAAEOoo2ABwHL1apOj1WwYqIaayZGcVlOj6V+Zra9Zhh5PhZIrLKvTQu8tVVmElSWe0TNHdo9o7nAoAAIQ6CjYAnECfVg01afwAxUVXTivOzC/RdS/P1/ZsSnYge/LbDVrvmdIfG+XSk1f3VmQEP/IAAEDd4rcNADiJ/m1SNWHcAMVGVX7L3JdXrOtfWaCdOYUOJ8OxzN+SrVdmbfEe//aCrmrXKMHBRAAAIFxQsAGgBga3S9NrYwcoJrLy2+buQ0W6/tX52nOoyOFk8JVfXKZfvLdctnJmuEZ0aqQbB7d2NhQAAAgbFGwAqKFhHdL18s39Fe2Zarwzp0jXvTJf+3KLHU6GI/706Rrt9vzRI7lBlP5xRS8ZYxxOBQAAwgUFGwBOwchOjfTSTf0UFVFZ2rZnF+r6V+YrM5+S7bRvVu/T+0t2eY//fFkPNUmOdTARAAAINxRsADhFZ3XJ0PPX91Wkq7Jkb8k6rOtfWaCsghKHk4WvrIIS/eajld7ji3s30yW9mzmYCAAAhCMKNgCchnO7N9Gz1/VRhKdkb8os0A2vLFA2JbveWWv1m49WKvtwqSSpcVKM/nxpd4dTAQCAcETBBoDTdH7PpnrqmjPk6dhavz9f17+yQAfyKdn16f0lu/Ttmv3e4yeu7K2UuGgHEwEAgHBFwQaAWri4dzP96+reMj4l+9qX5ykzj3uy68POnEL96dM13uObh7TWiE6NHEwEAADCGQUbAGrp8j4tql3J3nzgsK59mdXF65rbbfWL95eroKRcktQ2PV6/Pr+Lw6kAAEA4o2ADgB9cekZzPeNzT/aWrMO65uV53i2j4H+vzd6qhVtzJEkRLqMnr+6tuOhIh1MBAIBwRsEGAD+5qFczPX99H+/q4tuzC3XNS/O0M6fQ4WShZ/2+fD3x9Xrv8T2j2qtPq4YOJgIAAKBgA4BfjenRVC/e2E/REZXfXncdLNI1L83T9uzDDicLHaXlbj3w7jKVVrglST2bJ+vnZ3d0OBUAAAAFGwD87ifdGuulm/spOrLyW+ye3GJd/dI8bTlQ4HCy4Get1V+/XKu1e/MkSTGRLv37mt6KiuDHGQAAcB6/kQBAHTirc4ZeG9tfMZ6SvT+vRNe8PF+bMvMdThbcnv5uoybO2eY9/tWYLuqQkehcIAAAAB8UbACoI8M7NtLE8QPUICpCknQgv0TXvDRf6/dRsk/HizM266mpG73H53RrrHFD2zgXCAAA4CgUbACoQ0Pbp2vyLQMVH11ZsrMPl+ral+dpzZ48h5MFl4lztupvX67zHo/o1EjPXd9HriN7owEAAAQACjYA1LGBbVP1+q0DlRBTuYXUwcIyXffKfK3cletwsuDw1oIdeuzTNd7jwe1S9dKN/RQTGeFgKgAAgB+jYANAPejXOlVv3DZIibGVJTu3qEzXvzpfy3YecjZYgPtwyS799uOV3uN+rRvqtbED1CCacg0AAAIPBRsA6skZLVP09u2DldwgSpKUX1yuG19doGnrMh1OFpg+Xb5Hv/xguaytPO7VIlkTxw9QvGcmAAAAQKChYANAPerRPFlv3z5YqfHRkqSCknKNn7RIj/5vtYrLKhxOFzi+Wb1PD7y7TG5Pue7SJFGv3zJQSbFRzgYDAAA4AQo2ANSzbs2S9Pbtg9U4KcY7NmnuNl32/BxWGJc0fX2m7n3rB1V42nWHjAS9edsgpcRFO5wMAADgxCjYAOCAzk0S9eX9I/STro29Y+v25euS52br9XnbZI/Miw4zczdl6Y4pS1Ra4ZYktUmL01u3DVJaQsxJ3gkAAOA8CjYAOCQ1Plqv3NxPf7msh2IiK78dl5S79YdPVuu2yYuVXVDicML6tXhbjm6dvFgl5ZXlunlKA715+2BlJMU6nAwAAKBmKNgA4CBjjG4c3Fqf/fxMdWmS6B3/bl2mxjw9SzM3HHAwXf1ZvvOQxk1cpCLPfehNkmL19u2D1TylgcPJAAAAao6CDQABoGPjRH18zzDdMqytd+xAfolunrBQf/lsjUrKQ3cBtDV78nTzhIUqKCmXJKUnxOjN2wepVVqcw8kAAABODQUbAAJEbFSE/nBxN00aP0DpPvccvzp7qy5/fq42ZYbeAmhr9uTpxtcWKLeoTJLUMC5Kb942SO0bJTicDAAA4NRRsAEgwIzqnKGvHhiuszo38o6t2Zuni56drTcXbA+JBdAOFZbqsU9X65LnZivncKkkKSk2UlNuHaTOPlPlAQAAggkFGwACUHpCjCaMG6BHL+6maM8CaMVlbv32v6t0x5Ql2plT6HDC01NW4dbkuds06p/TNXHONpV7tuJKiInU5FsGqkfzZIcTAgAAnL5IpwMAAI7NGKNxw9pqcPs03f/2Mq3fXzlF/Js1+zV17X6d172JbhveVn1bNZQxxuG0JzdjwwH9+bM12pRZUG18YNtU/enS7urSJMmhZAAAAP5BwQaAANelSZI+uXeY/vrFWk2et12S5LbSl6v26ctV+9S7ZYpuO7Otzu/RRJERgTcxaVNmgR7/fI2mra++InrL1Ab6v/O7akyPJkHxBwIAAICToWADQBCIjYrQY5f20Hk9mug/0zdr1sYs73PLdx7Sz9/+Qc1TGmjc0Da6ZmBLJcVGOZi20qHCUj01daOmzN+uCnfVfeMJMZG656wOGj+sjWKjIhxMCAAA4F8UbAAIIkPbp2to+3St35ev12Zv0cc/7FFphVuStPtQkR7/Yq2emrpBVw9oqfFD2zqy1VVZhVtvzt+uf0/d6F0dXJKMka7p31IPndtJGYmx9Z4LAACgrplQWI22PhljlvTt27fvkiVLnI4CADqQX6I35m/XG/O3K9uzGvcRLiOd263yPu1+revnPu1p6zP1l8/WaPOBw9XGB7VN1R8u7qbuzVjEDAAABLZ+/fpp6dKlS621/U71vVzBBoAg1igxRg+e00l3jWqvj3/Yrddmb9VGzyJibit9tXqfvlq9Tz2bJ2tg21R1apygDhmJ6tg4oVbTyK212nWwSKv35GnNnlyt3pOn1XvytC+vuNrrWqXG6f8u6KrzujfmPmsAABDyKNgAEAJioyJ07cBWumZAS83cmKVXZ22pdp/2yt25Wrk7t9p7miTFqmPjBP3/9u4+WK66vuP4+0sCSSQPREhoEloTHkKAYQqYaWtQSGFQaFFkxJGpViIdR9uCKJ0pnWopVTuA8lQcSjpIDY+DhQKtbcBa04ADtQjTKi0BEiDKU8JDkCSEJCT59Y/zu7Bc9t67d++59+zZfb9mzuzd8/Db3/4+997d754958zfdwoHzZzMQfs2L7x37NzFmhc380guov/vuVd55LmNbNy6Y8D+TJ4wnrOPO5AlR89lwniPs5YkSb3BAluSukhEcOz8GRw7f0bT47Qbrdu4lXUbt76tEIe3Cu+ZUyay+oVNPLpuE9t3vHP7ZibuvhunHrkf554wnxlTJpTynCRJkurCAluSutTBvzKFb5z265x34gIeeGoDq1/YzOPrN7F6/WaefGkzb+xsfg6OvsJ7KNMm7c5hs6fmaRqHzZ7KvH327MhLhUmSJI0FC2xJ6nJ7T57ASYfP4qSGeTt27mLty1tYvX5TS4X37GkTOTQX0YfNnsphc6Yxe9pEj6uWJElqYIEtST1o/LjdOHDmZA6cOblp4b3mhU28uGkb+8+YzKGzpjJ9zz0q66skSVJdWGBLkt7UWHhLkiRpeDxQTpIkSZKkElhgS5IkSZJUAgtsSZIkSZJKYIEtSZIkSVIJLLAlSZIkSSqBBbYkSZIkSSWwwJYkSZIkqQSVF9gRcVBEnBcRKyLi6YjYHhHrI+KfIuK322xzUUQsj4gNEbElIn4WEV+MiHFl91+SJEmSJOiAAhv4GnARsC+wHLgUuA/4XWBFRHxhOI1FxCnAvcAxwB3AVcAewOXALeV1W5IkSZKkt4yvugPA3cDFKaX/bpwZEccCPwC+GRG3ppSeH6qhiJgKXAPsBBanlB7M8/8CWAGcFhGnp5QstCVJkiRJpap8D3ZKaVn/4jrPvwdYSbH3eVGLzZ0GzABu6Suuc1tbga/ku384og5LkiRJktRE5QX2EN7ItztaXP+4fHt3k2X3AluARRExYaQdkyRJkiSpUSd8RbypiHgPcDxFUXxvi5sdnG8f778gpbQjIp4CDgP2B1YN8fgPDbBoQYt9kSRJkiT1kI4ssPMe5puACcCfppReaXHTafn21QGW983fq/3eSZIkSZL0TqUU2BGxFnjPMDa5KaX0qQHaGgfcABwNfBe4ZMQdbGg+36ahVkwpvbdpA8We7aNK7JMkSZIkqQuUtQf7CWDrMNZ/rtnMXFzfCHwc+AfgUymlIYvhBn17qKcNsHxqv/UkSZIkSSpFKQV2Sun4kbYREeOBmymK65uBT6eUdg6zmceAhcB84G3HUOf251GcMO3JkfZXkiRJkqRGHXEW8YjYA7iNori+Hvj9NoprKK51DXBik2XHAO8C7k8pbWuro5IkSZIkDaDyAjuf0OwO4BTgWuAzKaVdQ2wzLSIWRMSsfotuA14CTo+IhQ3rTwS+nu9eXVrnJUmSJEnKOuEs4kuB36EojJ8Fzo+I/uusTCmtbLh/KvAd4DpgSd/MlNLGiPgsRaG9MiJuATYAH6G4hNdtFCdOkyRJkiSpVJ1QYM/Lt/sA5w+y3spWGksp3RkRxwJfBj4GTATWAOcCVw7zpGmSJEmSJLWk8gI7pbS4jW2WAcsGWX4fxV5xSZIkSZLGROXHYEuSJEmS1A0ssCVJkiRJKoEFtiRJkiRJJbDAliRJkiSpBOFJtYcnIl6eNGnSuw855JCquyJJkiRJKtmqVat4/fXXN6SU9h7uthbYwxQRTwFTgbUVd6UsC/Lto5X2Qn3Mo7OYR2cxj85jJp3FPDqLeXQW8+gsnZ7HXGBjSmneUCv2Z4Hd4yLiIYCU0nur7ovMo9OYR2cxj85jJp3FPDqLeXQW8+gs3ZyHx2BLkiRJklQCC2xJkiRJkkpggS1JkiRJUgkssCVJkiRJKoEFtiRJkiRJJfAs4pIkSZIklcA92JIkSZIklcACW5IkSZKkElhgS5IkSZJUAgtsSZIkSZJKYIEtSZIkSVIJLLAlSZIkSSqBBbYkSZIkSSWwwK6xiFgUEcsjYkNEbImIn0XEFyNi3Fi0FRFnRMQDEbE5Il6NiJURcXKLjzc/Il6LiBQRNw63v52oTnlExJkRcWdErImIjTmLVRFxTUQcPNz+dqK65BERu0fEqRFxbUT8b85jS0Q8HBFfjYgpw+1vp6pLJnnd34iICyPirohYl/9XPTPcflYpIvaLiL+PiOciYltErI2IKyJi+mi3M9avKXVRl0xy+1+OiFvz68Su/DdwYDvPu1PVKI+jI+IbEfGTiHgxP8ZTEfHtbsqkRnkcExE3RPGa/XJEbM15/HNEHN/Oc+9EdcmjybYTcjbVvW6nlJxqOAGnADuAzcC1wDeBR4EE3DrabQGX5OVPA5cDVwEv53lnDfF444H/Ajbl9W+sejx7LQ9gBbAKuAm4ND/G8vy424CTqh7TXskDWJDnbwa+B1yc11+T5z8G7FP1mPZSJnn9K/Ky7cBP88/PVD2OwxijA4D1ud93Ahflv/uUx2rv0WpnLPKp41SnTICP5mW7gCeAV/L9A6sexx7NYx2wE/hR/t90CXAfb712vK/q8eyxPC4AngVuB64ELqR4P9X3vvZrVY9nL+XRZPtLG7Ko5HW78gCd2ggNpgIvUBRCCxvmTwTuz79Qp49WW8CiPH8NML1h/lyKN0RbgbmDPOb5+fG+QBcU2HXMA5g4wOOfkNt6pOpx7ZU8gDnAHwF79mtnD+BfclvfqnpceymTvOwI4Ehgj3y/bgX293Ofz+43/7I8f+lotDNW+dRxqlkm+wEfAKbm+yvpvgK7TnmcB8xu8th/ntd/uOrx7LE8BnoPNYeimNwJzKp6THslj37bL6b4YPDzWGA7DSs0ODP/0lzXZNlxedk9o9UWcH2e/5km23w1L/urAR5vIfAG8JX8R9ANBXZt8xigD68A26seV/N4W+FR6zdP3ZBJlS/UbYz3/rm/TwG79Vs2hWKvwGv0+1CnjHaq/pvp1KlumTRZbyVdVGDXPY+G9ccBW/I2Le1R7MSpW/LI29yRtzm66nHttTwoivO1wA/y/cpetz0Gu56Oy7d3N1l2L8U/20URMWGU2hpsm7v6rfOmiJhE8Ubqfyi+ItItaplHMxHxfmAv4OFW1u9QXZMHxYdRUHxVqs66KZM66Hsu/5ZS2tW4IKW0ieKrpe8CfmsU2jGf5uqWSbfrljwSb70+7Gxh/U7VFXlExEzgNyn2vj421PodrK55XAlMB/5giH6NOgvseuo7CdXj/ReklHZQfFI0nuKTo1Lbiog9Kb4Cszml9HyT9lbn2/lNll2U2zkjt90t6poHEXFaRFwQERdHxB3AD4ENwFkt9LVT1TaPJs7Mt81eaOqkmzKpgwHHKGv1ObfTjvk0V5tMekS35PFxij2BP04p/bKF9TtVLfOIiIX5PdTXI2IZxXHCM4EvpZReGqKvnax2eUTEqcAZwLkppV8M0a9RN77qDqgt0/LtqwMs75u/1yi01dZj57Mqng38WUrpkRb6VSe1y6PBacAnGu6vBn4vpfTgoL3sbHXO400R8RHgc8AzwDeGWr/DdUUmNVLWc26nHfNprk6Z9ILa5xER84BvUezB/pPB1q2BuuaxEPjLhvubKA51uWHQXna+WuUREfsCfwfclVK6dog+jQn3YFckn6I+DWMazqWsIt+mMrraZltvrh8RewHfoThz+KUl9Kl0vZTH22amdHpKKSj+oR1N8cngfRGxpO0elqBX83iz0YhFwM0UxyZ9LKX0Sht9K1WvZ9Jlyhrvdtoxn+bqmEk36+g88leR7wJmAOeklO5vr3u10ZF5pJSW5vdQk4BDKd7rXh8RS0fUy87XaXlcA+wOfHaE/SmNe7Cr8wTFmVFb9VzDz32f3kxrtiLFQf6N6w1muG0NtX6zT54uA/YBTkgpdeoxQr2UxzuklDYC90fEh4EHgasj4t9TSlVd97dn84iI91G8cdpFcbm0B1ro51jo2UxqqKzxbqcd82muTpn0gtrmkYvrFRRfpT0npfS3Q/SxDmqbB0BKaSvFpU/PyccGfy6/h7ptiP52qtrkERGfBj5Mcfjps0P0Z8xYYFckpTSSC9E/RvG1lPnAQ40LImI8MI/iK0NPlt1WSum1iHgWmBMRs5ocM3dQvm08duIoik/3Ho0ImvhkRHwS+GlK6YgW+ly6HstjQCml7RHxQ+BwipNOVPLi0Kt5RMQHgH+lKK4/lFL6cQt9HBO9mklN9Z1cZ6Dj41p9zu20Yz7N1SaTHlHLPCJiFsW5UhYAf9wlxTXUNI8B3EVxeNdiKnoPVYI65XFUvr0uIq5r8hhzIqJvb/f0sTpXgV8Rr6cV+fbEJsuOoTgj3/0ppW2j1NZg25zUbx2A2ykuFN9/Wp6XP5Hv395CfztR3fIYypx8W9cT0dUyj4g4juKFeQfFtz06prguQS0zqbH/yLcfjIi3vc5HxBSKw0FeB4b6HWunHfNprm6ZdLva5RER+wH3UBTXn++i4hpqmMcg6v4eCuqVx3/SvMboOxZ7S8P9sfsfV8W1wZxGNlF8PeJFhnERdoqvWiyg34Xv22yr79q8ayg+DeqbPxd4meJrpHNbeB6L6Y7rYNcqD2Bv4PABnsvJFJeG2tTYVp2muuWRl32Q4kXgJeDIqsfQTJo+h0RNroOd+/v93Oez+82/LM9f2jBv9zzWB4yknSrzqcNUp0yaPOZKuug62HXLA/g1ip0RO2lyvfhumGqWx7H0u65znn8A8Gze5oSqx7RX8hjkOVT2ul15gE5tBgcfpfh0bDPwbYqzDD+af5luBaLf+kvysmUjbStvc2le/jRwOXAVRXGQgLNafA6L6YICu255AEfk+Q9RXJf8QuBqik8BE7Ad+ETVY9pDeRxM8Qluovg62QXNpqrHtJcyyesvAJY1TInipHON8/apelwHGe8DgPW533fmv/MV+f5jwN4N687N89eOpJ2xzKeOUw0zafxdX5fX/ceGee+vekx7JQ+KE5AminOkXDDANLfqMe2hPH4JrAW+C1wCXAF8j2IHRQKurHo8eymPQZ6DBbZTG+EVX61YDrxC8Qb9YeBLwLgm6y5hgDerw22rYZszgJ9QvOncRPHVpZOH0f/FdEmBXac8gOnAXwM/Ap6nKKhfozhBx1LgkKrHssfy6Ps7GHSqejx7KZNh5DK36jEdYrx/leKstn1/5z8H/gZ4d7/15jLAm6PhtDOW+dR1qlMmLfz+L6l6PHsljxaySMDiqsezh/I4h+J8KT+n+PbZNuAXFMXfh6oex17LY5A2KiuwI3dAkiRJkiSNgCc5kyRJkiSpBBbYkiRJkiSVwAJbkiRJkqQSWGBLkiRJklQCC2xJkiRJkkpggS1JkiRJUgkssCVJkiRJKoEFtiRJkiRJJbDAliRJkiSpBBbYkiRJkiSVwAJbkiRJkqQSWGBLkiRJklQCC2xJkiRJkkpggS1JkiRJUgkssCVJkiRJKoEFtiRJkiRJJbDAliRJkiSpBP8PGogGPwDeZ6UAAAAASUVORK5CYII=\n", "text/plain": [ "
" ] @@ -195,20 +198,19 @@ " return {name:rdat[:,i] for i, name in enumerate(columns)}\n", "\n", "dat = parse_lineout('x_lineout.dat')\n", - "plt.plot(dat['x'], dat['Ex'])\n", - "plt.plot(dat['z'], dat['Ez'])" + "plt.plot(dat['x'], dat['Ex'])" ] }, { "cell_type": "code", "execution_count": 6, - "id": "hairy-automation", + "id": "complete-concord", "metadata": {}, "outputs": [ { "data": { "text/plain": [ - "[]" + "[]" ] }, "execution_count": 6, @@ -217,7 +219,7 @@ }, { "data": { - "image/png": "iVBORw0KGgoAAAANSUhEUgAAA9gAAALfCAYAAACaWGp9AAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAACIIUlEQVR4nOzdd3hUVeLG8fdk0kgnIaH33nuXqqJrb2sXrNjL7rrdXd3221236NrdVQQruta1oFjoIL0jEEroLYSEkJ7M+f2RYTIgJSGT3Cnfz/PkmblnZm5enl0hb+655xhrrQAAAAAAQO1EOB0AAAAAAIBQQMEGAAAAAMAPKNgAAAAAAPgBBRsAAAAAAD+gYAMAAAAA4AcUbAAAAAAA/ICCDQAAAACAH1CwAQAAAADwAwo2AAAAAAB+QMEGAAAAAMAPKNgAAAAAAPgBBRsAAAAAAD+gYAMAAAAA4AcUbAAAAAAA/ICCXQvGmKuMMU8bY+YYYw4bY6wx5vU6+D49jTGvGmN2GGNKjDH7jTGzjDHj/f29AAAAAABnJtLpAEHuEUm9JR2RtFNSF39/A2PMzZJeklQo6RNJWZJSJPWQdIGkV/39PQEAAAAANUfBrp0fqbJYb5I0StIMf57cGDNEleV6jaTzrbV7j3s9yp/fDwAAAABw5pgiXgvW2hnW2kxrra3uZ4wx1xljZhhjDhljio0x3xljHjHGxJzg7Y9Lckm68fhy7fn+ZbWIDwAAAADwI65g1yNjzMuSblXlVe/3JeVKGiLpD5LONsaca60t97y3haQRkpZIWmuMGSOpvyQraYWkGdZad33/GQAAAAAAJ0bBrieee6lvlfSBpBustUU+rz0m6VFJ90r6l2d4oOcxU9I3kkYfd8rVxpgrrLWb6i41AAAAAKC6mCJefx6UVC7pVt9y7fEHSQcl3eAzluF5vFpSV0lXSEqW1EHSa5J6SvrUGBNdl6EBAAAAANXDFex6YIyJU+Vq49mSHjLGnOhtJaos0ke5fB5vt9Z+4jk+bIyZ4HnvAElXSnqrLnIDAAAAAKqPgl0/GkoyktJVORW8Og55Hkskfeb7grXWGmM+UmXBHiQKNgAAAAA4jini9SPP87jcWmtO9eXzmQ2ex/yTLGZ2tIA3qLPUAAAAAIBqo2DXA2vtEUlrJXU3xqRW82OrVDmlvJExpvEJXu/hecyqfUIAAAAAQG1RsOvPPyVFS5pkjEk5/kVjTENjTL+jx57tul70HD5ujInweW9PSTerctG0d+swMwAAAACgmoy11ukMQcsYc5mkyzyHTSSdJ2mLpDmesWxr7cM+739W0j2SciR9IWm7pFRJbSWNlPSKtfYun/fHSfpalXtlL5c0U5X3cV+pyqnhP7HW/rNO/nAAAAAAgBqhYNeCz/7VJ7PNWtvmuM9cJOkuVS5OlqLKsr1d0nRJr1tr1x/3/jhJP5N0rSqLeLGkxZL+Ya2d5o8/BwAAAACg9ijYAAAAAAD4AfdgAwAAAADgBxRsAAAAAAD8gIINAAAAAIAfULABAAAAAPCDSKcDBBtjzFZJSZKyHI4CAAAAAPC/NpIOW2vb1vSDFOyaS2rQoEFq165dU50OAgAAAADwr++++05FRUVn9FkKds1lde3aNXXp0qVO5wAAAAAA+Fn//v21bNmyrDP5LPdgAwAAAADgBxRsAAAAAAD8gIINAAAAAIAfULABAAAAAPADCjYAAAAAAH5AwQYAAAAAwA8o2AAAAAAA+AEFGwAAAAAAP6BgAwAAAADgBwFRsI0xacaY240xHxhjNhljiowxecaYucaY24wxNcppjGlhjJlkjNltjCkxxmQZY540xjSsqz8DAAAAACC8RTodwOOHkp6XtEfSDEnbJTWWdIWklyT9wBjzQ2utPd2JjDHtJc2XlCHpI0nrJQ2S9KCk840xw621B+vkTwEAAAAACFuBUrA3SrpE0qfWWvfRQWPMryQtknSlKsv2e9U413OqLNcPWGuf9jnXPyX9SNKfJN3lv+gAAAAAAATIFHFr7TfW2o99y7VnfK+kFzyHo093HmNMO0njJGVJeva4lx+VVCDpJmNMfG0zAwAAAADgKyAK9mmUeR7Lq/HesZ7H6Sco6/mS5kmKkzTEf/EAAAAAAAicKeInZIyJlDTec/h5NT7S2fO48SSvZ6ryCncnSV+f5nsvPclLXaqRAwAAAAAQZgL9CvZfJPWQ9Jm19otqvD/Z85h3ktePjqfUMhcAAAAAAMcI2CvYxpgHJP1ElauA3+Sv03oeT7saubW2/0lyLZXUz095AAAAAAAhIiCvYBtj7pX0L0nrJI2x1uZU86NHr1Ann+T1pOPeBwAAAACAXwRcwTbGPCTpGUlrVFmu99bg4xs8j51O8npHz+PJ7tEGAAAAAOCMBFTBNsb8XNITklaoslzvr+EpZngexxljjvmzGWMSJQ2XVCTp21pGBQAAAADgGAFTsI0xv1HlomZLJZ1trc0+xXujjDFdjDHtfcettZslTZfURtK9x33sd5LiJb1qrS3wZ3YAAAAAAAJikTNjzARJv5dUIWmOpAeMMce/LctaO9nzvLmk7yRtU2WZ9nWPpPmSnjLGnO1532BJY1Q5NfzX/v8TAAAAAADCXUAUbEltPY8uSQ+d5D2zJE0+3YmstZuNMQNUWdjPl3SBpD2SnpL0uxosmAYAAAAAQLUFRMG21j4m6bEavD9LVVtunej1HZJuqW0uAAAAAACqK2DuwQYAAAAAIJhRsAEAAAAA8IOAmCIOAACA4GetVW5hmbbnFGpbTqF25BSqsLRcA1qnaki7NDWIdjkdEQDqFAUbAAAA1VZe4daevOLKEn2wUNtzCrU9p8D7PL+4/ASf2qzoyAgNbpuq0Z0zNKpTutqnx+sEu8YAQFCjYAMAAOCUcgpK9c8vN2hOZrZ2HSpSudvW+Byl5W7NyczWnMxs/UFSi4YNNLpzukZ1ytCw9mmKj+HHUgDBj7/JAAAAcELWWn26eo8e/WitDhaUVuszDaJcap0Wp5apcWqVGidrpTmZB5S5/8gx79t5qEivf7tdr3+7XdGuCA1s21CjOqVrdOcMdcxI4Oo2gKBEwQYAAMD37DtcrEc+XKMv1+373msZiTFqlRqnVmmVJbq157FVarwaJUSfsBzvPFSo2RuzNXPDfs3blK2C0grva6UVbs3bdFDzNh3U/322Xs2SY3XNwFYaP7S1GsZH1+mfEwD8yVhb8yk+4cwYs7Rfv379li5d6nQUAAAAv7PW6p0lO/THT7875n7qJkmx+t2l3TWyY3qtFysrLXdr6bZDmrlxv2ZtOKD1e/NP+L64aJeuHdhKt49oq2YpDWr1PQGguvr3769ly5Yts9b2r+lnKdg1RMEGAAChavvBQv3i/VWav/ngMePXD26lX/ygi5Jio+rk++7NK9asjfs1c8MBzc3MVn7JsQulRUYYXdKnme4a1V6dGifWSQYAOKo2BZsp4gAAAGGuwm01eX6W/v7FBhWVVU3dbp0Wp79c0UtD26fV6fdv4pkSfs3AViqrcOuz1Xv0/MzN3ivb5W6r95ft0vvLdunsLhm6a3R7DWyTWqeZAOBMULABAADCWOa+fP3svVVavj3XOxZhpNtHtNOPzulU73tXR7kidGmf5rqkdzPN3HhAL8zcrIVbc7yvf71+v75ev18DWjfUXaPaa2yXDEVEsCAagMBAwQYAAAhDpeVuvTBrs575ZpNKK9ze8S5NEvXXK3upd8sU58JJMsZoTOcMjemcoWXbD+mFmZs13WfBtSXbDun2V5eoY0aC7hzVXpf0bqboyAgHEwMA92DXGPdgAwCAYLdqZ65+9u6qYxYXi3IZ3Temo+4e3T5gi+qm/Uf079mb9cHyXSqrOPZn2KbJsXp4XGdd0a85W3wBqJXa3IMdmH97AgAAoE58umqPrnhu/jHlunfLFH36wAg9eE7HgC3XktQhI0GPX9Vbc342VneMaKt4n+nre/KK9ZP/rtR9by5XXmGZgykBhLPA/RsUAAAAfvXRil16YOpylbsrr/7GRkXokQu76v27hwXV6txNkmP16wu7af4vztZPz+usRglVe2V/unqPzv/XbC04biV0AKgPFGwAAIAw8MHynfrR2ytU4SnX7dPj9cVDI3X7iHZyBekiYclxUbp3TAfN/tkYXTeolXd8T16xrn/pW/1l2nqVlrtPcQYA8C8KNgAAQIh7Z8kO/fidlfJ0a3XMSNDUiUPVOi3e2WB+EhcdqT9f0VMv3tRfDeMq9+q2Vnph1mZd8fw8bT5wxOGEAMIFBRsAACCEvbVou3727iodXde2S5NETZ04ROmJMc4GqwPndW+izx8aqREdG3nH1uw6rIuemqu3Fm0Xi/sCqGsUbAAAgBD12rfb9Mv3V3uPuzVN0pt3DFFaQuiV66MaJ8Vqyi2D9MiFXRXtqvxRt6isQr98f7XufG2pcgpKHU4IIJRRsAEAAELQ5Hlb9ZsP13iPezZP1pt3DFZqfPQpPhUaIiKMbh/RTh/eO1wdMxK849PX7dP5T87WnMwDDqYDEMoo2AAAACHmpTlb9NjH67zHfVqm6PXbByslLvTLta9uzZL08f1nacLQ1t6x/fkluunlRfrjJ+tUUl7hYDoAoYiCDQAAEEKen7lZf/z0O+9x/9YN9dptg5TcIMrBVM6JjXLpd5f20KSbBxyznddLc7fqsmfnK3Nf/ik+DQA1Q8EGAAAIEc98k6m/fr7eezyoTaqm3DpIibHhWa59je3SWNMeHKnRndO9Y9/tOazLn5uv+ZuyHUwGIJRQsAEAAIKctVZPfrVRf5++0Ts2pF2qJt86UAkxkQ4mCyzpiTF65eaB+t0l3RUdWflj8JGSck14ZZE+Xrnb4XQAQgEFGwAAIIhZa/WP6Rv15FeZ3rGzOjTSKzcPUlw05fp4xhhNGNZGH94zXI2TKldTL6uwemDqcr0yb6vD6QAEOwo2AABAkLLW6q+fb9AzMzZ5x0Z1StdLEwaoQbTLwWSBr1uzJL139zC1T4+XJFkr/e7jdfrLtPXslw3gjFGwAQAAgtSkeVl6YdZm7/HYLhl68ab+io2iXFdHi4ZxeveuYerXKsU79sKszfrJf1eqrMLtXDAAQYuCDQAAEISWZOXoz59VrRZ+brfGev7GfpTrGmoYH603bh+is7tkeMfeX7ZLd7y6RIWl5Q4mAxCMKNgAAABBJvtIie59c5nK3ZVTmXu3TNEz1/dVTCTl+kw0iHbpxZv66+oBLbxjMzcc0HX/WaicglIHkwEINhRsAACAIFLhtnpw6nLtO1wiSWoYF6XnbuhHua6lSFeE/nplL90/toN3bOWOXF31/HztyCl0MBmAYELBBgAACCJPfLlR8zYdlCQZIz15bV81T2ngcKrQYIzRT8Z11u8v7S5jKse2ZBfoiufna93uw86GAxAUKNgAAABB4pv1+45ZMfyBsR01qlO6g4lC0/ihbfTs9f0U7ar8UflAfomueXGBFmw+6HAyAIGOgg0AABAEduQU6kdvr/Qej+jYSA+c3dHBRKHtgp5NNeXWQUqMqdxLPL+kXBMmLdJnq/c4nAxAIKNgAwAABLiS8grd88Yy5RWVSZKaJsfqX9f2lSvCOJwstA1tn6Z37hqqjMQYSVJphVv3vrlMry7IcjYYgIBFwQYAAAhwv/94nVbvypMkRbmMnr2hn1Ljox1OFR66Nk3S+/cMU7v0eEmStdJvP1qrf8/efJpPAghHFGwAAIAA9sHynXpj4Xbv8a8v6Kp+rRo6mCj8tGgYp3fvGqY+LVO8Y//32Xo963M/PABIFGwAAICAtWFvvn75/mrv8YW9mmrCsDbOBQpjqfHReuP2wRrUNtU79rcvNuhfX2U6mApAoKFgAwAABKD84jLd/fpSFZe5JUnt0+P11yt7yRjuu3ZKfEykJt8yUMPap3nHnvhqo/45fYOstQ4mAxAoKNgAAAABxlqrX7y3WluyCyRJDaJcev7G/krwrGgN58RFR+rlCQM1omMj79hT32zS376gZAOgYAMAAAScV+Zl6VOf7aD+fEVPdWqc6GAi+GoQ7dJ/xg/Q6M5Ve5A/N3Oz/jxtPSUbCHMUbAAAgACydFuO/u+z77zHNw5ppcv6NncwEU4kNsqlF2/qr7O7ZHjH/j17i/7wyXeUbCCMUbABAAACRPaREt37xnKVuysLWq8WyfrNRd0cToWTiYmsnLo/rltj79ikeVv12P/WUrKBMEXBBgAACAAVbqsHpy7X3sPFkqTkBlF69vp+iol0OZwMpxIdGaFnb+inC3o28Y5NWbBNj3y4Rm43JRsINxRsAACAAPDy3C2at+mg9/jJa/qoZWqcg4lQXVGuCD11bV9d3LuZd+yNhdv1qw9WU7KBMEPBBgAAcFj2kRI99fUm7/F9YzpojM+9vQh8ka4IPXF1b13Wp6pkT128Qz99d5UqKNlA2KBgAwAAOOyJLzfqSEm5JKlderwePKejw4lwJiJdEfrH1X10Vf8W3rH3lu3UT95ZofIKt4PJANQXCjYAAICDNuzN11uLtnuPf31BV0W5+BEtWLkijB6/speuHdjSO/bhit360TsrKdlAGOBvbwAAAIdYa/XHT9fp6Aziszo00limhge9iAij/7u8p24Y3Mo79vHK3frVB6tZXRwIcRRsAAAAh8zceEBzMrMlSRFGeuSirjLGOJwK/hARYfTHy3po/NDW3rF3luzUnz5ln2wglFGwAQAAHFBW4dafPv3Oe3zNwJbq0iTJwUTwN2OMHru4+zH3ZL80d6uenbHpFJ8CEMwo2AAAAA54a9F2bdp/RJKUEBOpH5/b2eFEqAsREUZ/uaKnzu9etU/236dv1KsLspwLBaDOULABAADqWV5RmZ74cqP3+J4x7ZWeGONgItSlSFeE/nVdH53VoZF37LcfrdWHy3c5mApAXaBgAwAA1LNnvsnUocIySVLzlAa6dXhbhxOhrsVEuvTiTf3Vt1WKd+wn/12pr9btcy4UAL+jYAMAANSjrOwCTZ6f5T3+xQ+6KDbK5Vwg1Jv4mEi9cvNAdW6cKEmqcFvd8+YyLdh80OFkAPyFgg0AAFCP/jJtvcoqKleR7t+6oS7q1dThRKhPKXHReu22QWqVGidJKi136/Ypi7VqZ66zwQD4BQUbAACgnny75aA+X7vXe/zIhWzLFY4ykmL1xu2DleG5776gtEITJi1S5r58h5MBqC0KNgAAQD1wu63++Ok67/GlfZqpb6uGDiaCk1qmxun12wcrJS5KknSosEw3vbxIO3IKHU4GoDYo2AAAAPXgvWU7tWbXYUlSTGSEfnZ+F4cTwWmdGidq8i2DFB9deQ/+3sPFuvHlhdqfX+xwMgBnioINAABQxwpLy/W3LzZ4jyeObKfmKQ0cTIRA0adliv4zfoCiIyt/LN92sFDjX16kPM8q8wCCCwUbAACgjr0wa4v255dIktITY3TXqPYOJ0IgGdahkZ65rq9cEZX346/fm69bJi9SYWm5w8kA1BQFGwAAoA7tySvSv2dv9h7/dFxnxcdEOpgIgWhc9yZ6/Mpe3uNl23N152tLVVrudjAVgJqiYAMAANShv32+QcVllSWpW9MkXdm/hcOJEKiu7N9Cj17czXs8JzNbD/93pdxu62AqADUREAXbGHOVMeZpY8wcY8xhY4w1xrx+BufJ8nz2RF97T38GAAAA/1m5I1fvL9/lPX7koq7eacDAidwyvK0eOqej9/h/K3frj59+J2sp2UAwCJT5SY9I6i3piKSdkmqzrGaepCdPMH6kFucEAACoEWut/vBJ1bZc53ZrrGHtGzmYCMHiwbM76uCRUr327TZJ0qR5W9U4KUZ3cu8+EPACpWD/SJXFepOkUZJm1OJcudbax/wRCgAA4ExNW7NXS7YdkiRFuYx+dUFXhxMhWBhj9Ngl3XUgv0Sfr62chPnnaeuVnhijK/pxiwEQyAJiiri1doa1NtMy9wUAAISA4rIK/Xnad97j8UPbqG2jeAcTIdi4IoyevLaPBrVN9Y797N1Vmrlhv4OpAJxOQBRsP4sxxtxojPmVMeZBY8wYY4zL6VAAACB8vP7tNu3IKZIkpcRF6YGxHU/zCeD7YqNc+s/4AercOFGSVO62uueNZVq5I9fZYABOKhQLdhNJr0n6kyrvxf5GUqYxZlRNTmKMWXqiL9Xu/nAAABDiKtxWr8zL8h4/dHZHJcdFORcIQS25QZSm3DpIzVMaSJIKSyt0y+TF2ppd4HAyACcSagX7FUlnq7Jkx0vqKelFSW0kTTPG9HYuGgAACAffrN+vXbmVV69T46N17aBWDidCsGuSHKsptw5SiucXNTkFpRo/aaH25xc7nAzA8UKqYFtrf2et/cZau89aW2itXWOtvUvSPyU1kPRYDc7V/0RfktbXUXwAABACjq78LElXD2ip2CjuVEPtdchI0MsTBio2qvLH9x05Rbp50mLlF5c5nAyAr5Aq2KfwgudxpKMpAABASMvKLtDsjQckScZINwzm6jX8p3/rhnr2+n7evdTX7Tmsu15fqpLyCoeTATgqXAr20eUWWb4TAADUmdd9rl6P7ZyhlqlxDqZBKDq7a2P9+fKe3uN5mw7qJ++slNvNZjxAIAiXgj3U87jF0RQAACBkFZVW6L9Ld3qPbxza2sE0CGVXD2yph8d18h5/smqP/vDpOrHjLeC8oCvYxpgoY0wXY0z748a7G2NST/D+1pKe8Ry+Xh8ZAQBA+Pl45W7lFVXeD9sqNU6jOqY7nAih7N4xHTTe55c4r8zL0ouzuZYEOC3S6QCSZIy5TNJlnsMmnsehxpjJnufZ1tqHPc+bS/pO0jZVrg5+1A8l/cIYM0PSVkn5ktpLulBSrKTPJP29Tv4AAAAgrFlr9eq3Wd7jG4e0UoTnPlmgLhhj9OjF3ZV9pESfrd4rSfrLtPVKT4jRlf1bOJwOCF8BUbAl9ZE04bixdp4vqbJMP6xTmyGps6S+qpwSHi8pV9JcVe6L/Zpl3gwAAKgDK3bkas2uw5KkmMgI/bB/S4cTIRy4Ioz+eXUfHTyySAu35kiSfv7eKqUmRGtM5wyH0wHhKSCmiFtrH7PWmlN8tfF5b9bxY57xWdba66y1Xay1KdbaKGtturX2XGvtq5RrAABQV3y35rq4dzM1jI92MA3CSWyUS/+ZMEBdmiRKksrdVve8vkzLtx9yOBkQngKiYAMAAASrnIJSfbJqj/f4piEsbob6lRQbpSm3DlLzlAaSpKKyCt06ebE2HzjicDIg/FCwAQAAauGdJTtUWu6WJPVukazeLVOcDYSw1DgpVq/eNkgN46IkSYcKyzT+5UXam1fscDIgvFCwAQAAzlCF2+qNhVXTw2/k6jUc1D49Qa/cMkgNolySpF25RZowaZF3dXsAdY+CDQAAcIZmbdyvHTlFkqSUuChd3LuZw4kQ7vq0TNHzN/ZTpGcV+w378nXHlCUqLqtwOBkQHijYAAAAZ+i1BVVXr68e0FKxniuHgJNGd87Q337Yy3u8KCtHD7y1XBVu1vwF6hoFGwAA4AxsP1iomRsPSJKMkW4Y3MrhRECVy/u20K8v6Oo9nr5unx75cI3YWAeoWxRsAACAM/DGwm062lVGdUpX67R4ZwMBx7ljZDvdMaKt9/itRdv15FeZDiYCQh8FGwAAoIaKyyr09pId3mO25kKg+uUPuuryvs29x//6OvOYfdsB+BcFGwAAoIY+WbVHuYWVKzO3aNhAoztnOJwIOLGICKPHr+qlUZ3SvWO//WiNpq3ec4pPAThTFGwAAIAa8r0CeMPg1nJ5VmwGAlGUK0LP3dBPvVskS5KslR6cukILNh90OBkQeijYAAAANbBqZ65W7siVJEVHRuiagS2dDQRUQ3xMpCbdPFDtGlWuFVBa4dbEV5do3e7DDicDQgsFGwAAoAZ8t+a6qGdTpcZHO5gGqL60hBhNuXWQMhJjJEn5JeWa8Moi7cgpdDgZEDoo2AAAANWUW1iq/63c7T2+aSiLmyG4tEyN05RbBykxJlKSdCC/ROMnLdLBIyUOJwNCAwUbAACgmv67ZKdKyt2SpB7Nk9SnZYqzgYAz0LVpkv4zYYCiIyurwNbsAt06ZYkKS8sdTgYEPwo2AABANbjdVq8vrJoeftOQ1jKGxc0QnIa0S9NT1/bR0f8Lr9yRq/veXK7yCrezwYAgR8EGAACohjmbsrXtYOW9qkmxkbqkd/PTfAIIbOf3aKrfXdLde/zN+v369QdrZK11MBUQ3CjYAAAA1fDagizv8x8OaKkG0S7nwgB+Mn5oG90zur33+O0lO/TkV5kOJgKCGwUbAADgNHbkFOrr9fu9xzcOYXEzhI6fntdZV/SrmpHxr68z9dai7Q4mAoIXBRsAAOA03ly0XUdnzY7o2EhtPXsJA6HAGKO/XtlLIzule8d+/cFqff3dPgdTAcGJgg0AAHAKJeUVenvxDu/x+KFtnAsD1JEoV4Seu6GfejRPkiS5rXTvm8u0bPshh5MBwYWCDQAAcArTVu9VTkGpJKl5SgON7ZLhcCKgbiTERGrSzQPVMrWBJKm4zK3bJi/WlgNHHE4GBA8KNgAAwCn43ot6/eBWckWwNRdCV0ZirKbcMkgN46IkSYcKyzThlUXan1/scDIgOFCwAQAATmJvXrEWZeVIkiKM9MMBLRxOBNS9dukJmnTzQMVGVVaFHTlFunXyYh0pKXc4GRD4KNgAAAAn8enqPd7FzYa1b6SMxFhnAwH1pG+rhnr2+n46OmFjza7Duvv1pSqrcDsbDAhwFGwAAICT+Hjlbu/zi3s3dTAJUP/O7tpYf7q8p/d4Tma2fv7eKtmjv3UC8D0UbAAAgBPYkVOoFTtyJUlRLqPzujdxNhDggOsGtdKDZ3f0Hr+/bJf+9sUGBxMBgY2CDQAAcAIfr6q6ej2yY7pS4qIdTAM456FzOuqaAS29x8/N3KxXF2Q5FwgIYBRsAACAE/h45R7v84t7N3MwCeAsY4z+dHkPjemc7h179H9r9dnqPaf4FBCeKNgAAADH2bQ/X9/tOSxJiomM0DndGjucCHBWpCtCz97QT71bpkiSrJUenLpcszYecDYYEGAo2AAAAMfxvXo9tkuGEmIiHUwDBIa46EhNmjBA7RrFS5LKKqzufG2Jlni2sgNAwQYAADiGtfaY+6+ZHg5USUuI0eu3D1bzlAaSpOIyt26ZvFhrd+c5nAwIDBRsAAAAH+v2HNaWAwWSpPhol8Z0znA4ERBYmqU00Gu3DVKjhMqF//KLyzX+5UXacuCIw8kA51GwAQAAfPhODz+3W2M1iHY5mAYITO3SE/TqrYOVGFt5+8TBglLd+NJC7cotcjgZ4CwKNgAAgIe1Vh+vZHo4UB3dmiVp8i0D1SCq8pdQu/OKddNLC3Ugv8ThZIBzKNgAAAAey3fkeq/AJcVGakTH9NN8Aghv/Vun6t/j+yvaVVkrtmQXaPykRcorKnM4GeAMCjYAAICH79XrH/RoquhIflQCTmdEx3Q9dV0fRZjK4+/2HNatkxersLTc2WCAA/hXAwAAQFKF2+rTVVX3XzM9HKi+83s01eNX9fYeL912SHe+tlQl5RUOpgLqHwUbAABA0qKtOdrvuXe0UUK0hrRLdTgREFyu6t9Cj17czXs8JzNbD01dofIKt4OpgPpFwQYAAJCO2fv6gp5NFenixySgpm4Z3lY/PreT93jamr36xfur5XZbB1MB9Yd/OQAAQNgrq3Br2mqmhwP+cP/YDrr9rLbe43eX7tQfPl0naynZCH0UbAAAEPbmbcrWocLKVY+bJseqf6uGDicCgpcxRr++sKuuGdDSO/bKvCz96+tMB1MB9YOCDQAAwt7HK6uuXl/Uq6kiji6HDOCMGGP0f1f01IU9m3rHnvwqUy/O2uxgKqDuUbABAEBYKy6r0PS1e73HTA8H/MMVYfTENX00qlPVfvJ/nrZeT3MlGyGMgg0AAMLarI0HlF9SuV9v67Q49Wye7HAiIHRER0bohRv7H7Mq/z++3Ki/f7GBe7IRkijYAAAgrH28smr18It7NZMxTA8H/KlBtEuv3DxIIzo28o49M2OT/jxtPSUbIYeCDQAAwlZhabm+/m6/95jp4UDdaBDt0n/GD9DYLhnesX/P3qLH/reWLbwQUijYAAAgbH313X4VlVVIkjo1TlDnJokOJwJCV2yUSy/c2F/ndW/sHZuyYJt+9QH7ZCN0ULABAEDYOn56OIC6FR0ZoWeu73fMbJGpi3fo4f+uVHmF28FkgH9QsAEAQFjKKyrTrA0HvMcXMT0cqBdRrgg9eU0fXdmvhXfs/eW79NDbK1RGyUaQo2ADAICwNH3tXpV6fpjv2TxZbRvFO5wICB+uCKO/XdVL1w1q6R37ZNUe3fvGMpWUVziYDKgdCjYAAAhLH6/a431+ce+mDiYBwlNEhNH/Xd5TNw9r4x2bvm6f7nptqYrLKNkIThRsAAAQdg4eKdG8Tdne4wu5/xpwhDFGj17cTRNHtvOOzdhwQLdPWaKiUko2gg8FGwAAhJ1pa/aqwrNq8YDWDdU8pYHDiYDwZYzRL3/QRfeP7eAdm7spWxNeWaQjJeUOJgNqjoINAADCzjGrh7O4GeA4Y4x+Mq6zfnJuJ+/Yoq05Gv/yQuUVlTmYDKgZCjYAAAgre/OKtSgrR5IUYaQf9GzicCIAR91/dkf96oIu3uNl23N1/X++VfaREgdTAdVHwQYAAGHl09V7ZCtnh2to+zRlJMY6GwjAMSaObK/fXdLde7x292Fd/cIC7cotcjAVUD0UbAAAEFZ8p4dfxOJmQECaMKyNHr+ylyJM5fGW7AJd9fx8bdp/xNlgwGlQsAEAQNjYkVOoFTtyJUmREUbnd2d6OBCorh7YUs9e30/RrsrKsievWFe/uECrd+Y5nAw4OQo2AAAIGx+vqrp6PaJjIzWMj3YwDYDT+UHPpnr55gGKi3ZJknIKSnXdf77Vt1sOOpwMODEKNgAACBsfr9zjfc7q4UBwGNExXa/fPljJDaIkSUdKyjVh0iJ9/d0+h5MB30fBBgAAYWFrdoG+23NYkhQdGaFzuzV2OBGA6urXqqHeuXOoMhJjJEkl5W5NfG2pPly+y+FkwLEo2AAAICx8trrq6vXIjulKjI1yMA2AmurcJFHv3jVMrVLjJEkVbquH3l6hKfOznA0G+AiIgm2MucoY87QxZo4x5rAxxhpjXj/Dc7Uwxkwyxuw2xpQYY7KMMU8aYxr6OzcAAAgen66qKtgX9mJxMyAYtUqL07t3DVXnxonesUf/t1ZPfZ0pe3T/PcBBAVGwJT0i6T5JfSSd8TwPY0x7SUsl3SJpkaQnJG2R9KCkBcaYtFonBQAAQScru0Drjk4Pd0Xo7K5MDweCVUZSrN6+c4j6tkrxjv3zy436wyffye2mZMNZgVKwfySpk6QkSXfX4jzPScqQ9IC19jJr7S+stWNVWbQ7S/pTrZMCAICg86nv9PBOjZTE9HAgqKXEReuN2wdrRMdG3rFJ87bqp++uUnmF28FkCHcBUbCttTOstZm2FvM6jDHtJI2TlCXp2eNeflRSgaSbjDHxZxwUAAAEJd/7ry/o2dTBJAD8JS46Ui9NGKALff6bfm/ZTt39xjIVl1U4mAzhLCAKtp+M9TxOt9Ye82sra22+pHmS4iQNqe9gAADAOdsOFmjt7qrp4eewejgQMmIiXXrqur66dmBL79iX6/Zp/KRFyissczAZwlUoFezOnseNJ3k90/PYqR6yAACAAOE7PXxER6aHA6HGFWH05yt66s5R7bxji7bm6MoX5mtHTqGDyRCOQqlgJ3se807y+tHxlOqczBiz9ERfkrrUMicAAKhHTA8HQp8xRr/8QVf98gdVP6pv2n9Elz83X6t25joXDGEnlAr26RjPI0sLAgAQJrYfLNSaXZXTw6NchunhQIi7c1R7PX1dX0W7KmtO9pESXfPit/r6u30OJ0O4CKWCffQKdfJJXk867n2nZK3tf6IvSetrGxQAANSPY6eHpyu5AdPDgVB3ce9mev32wd7/3ovKKnTHq0v02rfbHE6GcBBKBXuD5/Fk91h39Dye7B5tAAAQYqatYXo4EI4GtU3Ve3cPU8vUBpIkt5V+8+Ea/Xkae2WjboVSwZ7heRxnjDnmz2WMSZQ0XFKRpG/rOxgAAKh/O3IKtWpn5cS1KJfRuUwPB8JKh4wEvX/3cPVuUTXB9cVZW/TA1OVs44U6E3QF2xgTZYzpYoxp7zturd0sabqkNpLuPe5jv5MUL+lVa21BvQQFAACO8l3c7KwOjZgeDoSh9MQYvTVxiM7pmuEd+2TVHt308kLlFpY6mAyhKiAKtjHmMmPMZGPMZEm/8AwPPTpmjPm7z9ubS/pO0tcnONU9kvZLesoY86Ex5s/GmG8k/UiVU8N/XXd/CgAAEEhYPRyAJMVFR+rFmwZo/NDW3rHFWYd0xfPztf0g23jBvwKiYEvqI2mC5+s8z1g7n7GrqnMSz1XsAZImSxos6SeS2kt6StJQa+1Bf4YGAACBaUdOoVb6TA8f162Jw4kAOMkVYfS7S7rr1xd09Y5tOVCgK56fp5U7cp0LhpATEAXbWvuYtdac4quNz3uzjh877lw7rLW3WGubWmujrbWtrbUPWmtz6uvPAwAAnOW7uNnwDo2UHMf0cCDcGWN0x8h2evb6foqOPLqNV6mu+fcCfbmObbzgHwFRsAEAAPzp09V7vc+ZHg7A14W9murN2wcrxfOLt+Iyt+58bYkmzd0qa1lhHLVDwQYAACFl56FC75TPyAijcaweDuA4A9qk6v27h6lVapykym28fv/JOv3o7RUqLC13OB2CGQUbAACElGk+V6+Hd2iklLhoB9MACFTt0hP0/j3D1KdlinfswxW7dcVz85WVzcZDODMUbAAAEFI+9Vk9/EKmhwM4hUYJMZo6cYiuHdjSO7Z+b74ufmauvuK+bJwBCjYAAAgZu3KLtMJ3enh3pocDOLXYKJf+cmUv/eWKnt7Fz/KLy3X7q0v0j+kbVOHmvmxUHwUbAACEjGk+V6+HMT0cQA1cO6iV3r1rqJqnNPCOPf3NJt0yebEOFZQ6mAzBhIINAABCxrHTw9n7GkDN9GqRoo/vP0sjOjbyjs3eeEAXPzNXa3blOZgMwYKCDQAAQsLu3CIt354rSXJFGI3rRsEGUHOp8dGafMsg3TumvXds56EiXfH8fL2zZIeDyRAMKNgAACAkfOY7Pbx9mhrGMz0cwJlxRRj99Lwu+vdN/ZUYEylJKi1362fvrtIv31+tkvIKhxMiUFGwAQBASPiM1cMB+Nm47k300X3D1alxgnfsrUXbdfULC7Q7t8jBZAhUFGwAABD0ducWaZnv9PDuTA8H4B/t0hP04b3DdXHvZt6xlTvzdNHTczU3M9vBZAhEFGwAABD0pq3Z630+rH2aUpkeDsCP4qIj9dS1ffTbi7opMsJIknIKSnXTpIX66+frVVbhdjghAgUFGwAABD3f6eEXMD0cQB0wxujWs9rqzTuGKD0xRpJkrfT8zM266oUF2nawwOGECAQUbAAAENT25BVp6bZDkiqnh5/H9HAAdWhQ21R9+sCxW3mt3JGrC5+aqw+W73QwGQIBBRsAAAS1aaurpocPbcf0cAB1LyMxVlNuGaRfXdBFUa7KKeNHSsr1o7dX6kdvr1B+cZnDCeEUCjYAAAhqTA8H4ISICKOJI9vrvbuHqU1anHf8g+W7dOFTc7ViR65z4eAYCjYAAAhae/OKteSY6eGNHU4EINz0apGiTx4YoSv7tfCObc8p1FXPz9dzMzfJ7bYOpkN9o2ADAICgNW1N1dXrIe1SlZYQ42AaAOEqISZS/7i6t/51bR8lxkRKksrdVo9/vkE3TVqofYeLHU6I+kLBBgAAQYvp4QACyaV9muuzB0eob6sU79i8TQd1/pOz9dW6fc4FQ72hYAMAgKC073DV9PAII1YPBxAQWqbG6Z07h+q+MR1kKtc/06HCMt3+6hI9+tEaFZdVOBsQdYqCDQAAgtLna/bKem5tHNw2TY2YHg4gQES5IvTweZ315u1D1CQp1js+ZcE2XfLMXK3emedgOtQlCjYAAAhKn/pOD+/F9HAAgWdo+zRNe3CExnWrWoBx474juuy5efrH9A0qLXc7mA51gYINAACCTvaREi3JypEkGSOdz/RwAAGqYXy0Xrypv/54WQ81iHJJkircVk9/s0mXPDNXa3ZxNTuUULABAEDQ+ea7/Tq6883A1qlKT2R6OIDAZYzRjUNa6/OHRmhQm1Tv+Pq9+brs2Xl68quNKqvganYooGADAICgM33dXu/zcex9DSBItE6L19SJQ/Toxd0UG1VZxcrdVk9+lalLn5mndbsPO5wQtUXBBgAAQaWgpFyzM7O9x+d2o2ADCB4REUa3DG+raQ+O1IDWDb3j6/Yc1qXPztVTX2dyNTuIUbABAEBQmZN5wLswUJcmiWqdFu9wIgCoubaN4vX2nUP1yIVdFRNZWcvKKqz++eVGXf7cPG3Ym+9wQpwJCjYAAAgq09fu8z4fx9VrAEHMFWF0+4h2+uzBEerbKsU7vmbXYV309Bw9O2OTyrmaHVQo2AAAIGiUVbj19fr93uNzu7F6OIDg1z49Qe/eNUy/uqCLon2uZv/tiw268vn52riPq9nBgoINAACCxuKtOcorKpMkNU2OVY/mSQ4nAgD/cEUYTRzZXp89cJZ6t0zxjq/cmacLn5qjv36+XoWl5c4FRLVQsAEAQNCYvu7Y6eHGGAfTAID/dchI1Ht3DdXPz++iaFfV1eznZ27WOf+Ypc9W75G11uGUOBkKNgAACArWWn3pW7C7Mz0cQGiKdEXo7tHt9ckDZx2z0vjuvGLd88YyjZ+0SJsPHHEwIU6Ggg0AAILC2t2HtSu3SJKUFBupQW1THU4EAHWrU+NEvXPnUP39h72VFh/tHZ+Tma3zn5ytx5k2HnAo2AAAICj4Tg8/u2tjRbn4MQZA6IuIMLqqfwt98/BoTRjaWhGeO2PKKqye80wb/3wN08YDBf8yAQCAoDB97V7vc7bnAhBukhtE6XeX9tD/7jtL/Xy29NqdV6y7Xl+mCa8s1hamjTuOgg0AAALe9oOFWr+3cpua6MgIjeyU7nAiAHBGj+bJeveuYXr8ql5K9Zk2PnvjAZ3/5Bz97Yv1KiqtcDBheKNgAwCAgDd9XdXV6xEdGik+JtLBNADgrIgIo6sHtNSMn4zWTUOqpo2XVrj17IzNOuefTBt3CgUbAAAEPN/7r89lejgASJKS46L0h8sqp4338dk7e1duke56fZmufnGBlm0/5FzAMETBBgAAAe3gkRItycqRJBlTucAZAKBKj+bJev/uYfrrlT3VMC7KO74465CueG6+7n59Kfdn1xMKNgAACGhfr98vt2eWY/9WDZWeGONsIAAIQBERRtcMbKUZD4/WzcPaKPLovHFJ09bs1bgnZus3H67RgfwSB1OGPgo2AAAIaF/6TA8f152r1wBwKilx0Xrsku766sejdGGvpt7xcrfVa99u0+i/zdBTX2eyf3YdoWADAICAVVRaoTmZB7zH53Zr4mAaAAgebRrF69nr++nDe4drUNtU73hBaYX++eVGjf7bTL21aLvKK9wOpgw9FGwAABCwZmceUHFZ5Q9/nRonqG2jeIcTAUBw6dMyRW9PHKKXJwxQx4wE7/j+/BL98v3VOv9fc/Tlun2sOO4nFGwAABCwpq/1mR7O1WsAOCPGGJ3dtbGmPThCf7mipzJ81rLYtP+I7nh1ia558VtWHPcDCjYAAAhI5RVufb2e+68BwF8iXRG6dlArzfzpaD08rpMSYiK9ry3KytEVz83XrZMXa+WOXOdCBjkKNgAACEiLsw4pt7BMktQkKVY9myc7nAgAQkNcdKTuG9tRs376/RXHv1m/X5c+O4+ifYYo2AAAICBNX7fX+/zcbo1ljDnFuwEANZWWEONdcfzi3s3k+9csRfvMULABAEDAsdYee/8108MBoM60aRSvp6/rq+kPjaRo1xIFGwAABJzv9uRrV26RJCkxNlKD26Y5nAgAQl/HxokU7VqiYAMAgIDjOz18bJcMRUfyIwsA1BeK9pnjXysAABBw2J4LAJxXnaJ9yyuLtHDLQfbR9qBgAwCAgLIjp1Dr9hyWJEW7IjSqc7rDiQAgvJ2qaM/YcEDX/PtbXfbcfH26ao8q3OFdtCnYAAAgoHy5rurq9fAOacfs0woAcM6pivbKHbm6981lGvP3mXp1QZYKS8udC+ogCjYAAAgovvdfj+vO9HAACDRHi/ZXPx6l6wa1PGadjO05hfrtR2s17C/f6J/TN+hAfomDSesfBRsAAASMQwWlWrQ1R5JkjHR21wyHEwEATqZ9eoL+fEUvzfv5WN0/toNS4qK8r+UWlumpbzZp+F+/0S/fX63NB444mLT+ULABAEDA+Hr9fh29fa9fq4bKSIx1NhAA4LTSE2P0k3GdNf8XY/W7S7qrZWoD72ul5W69tWi7zvnnLN3x6hItzsoJ6QXRuKkJAAAEjOlrq6aHn9utsYNJAAA1FRcdqQnD2uiGwa30+dq9+vfsLVq1M0+SZG3lGhtfrtunvq1SdOfIdhrXrYkiIsxpzhpcuIINAAACQlFphWZnHvAej6NgA0BQinRF6KJezfTRvcM1deIQje1y7O0+y7fn6q+fb3AoXd3iCjYAAAgIczdlq7jMLUnqkJGgdukJDicCANSGMUZD2qVpSLs0Ze7L13/mbNGHy3ertMKt20e0Dbmr1xIFGwAABAjf6eFcvQaA0NKxcaIev6q3Hh7XWW8u2q4r+7VwOlKdoGADAADHlVe49dV3Vftfsz0XAISmjKRYPXROJ6dj1BnuwQYAAI5buu2QDhWWSZIaJ8WoV/NkhxMBAFBzFGwAAOC46euqrl6f261xSN6XBwAIfQFVsI0xLYwxk4wxu40xJcaYLGPMk8aYhjU4R5Yxxp7ka+/pzwAAAOqTtVbT1/nef830cABAcAqYe7CNMe0lzZeUIekjSeslDZL0oKTzjTHDrbUHq3m6PElPnmD8iB+iAgAAP9p84Ih25BRJkhJiIjWkXZrDiQAAODMBU7AlPafKcv2Atfbpo4PGmH9K+pGkP0m6q5rnyrXWPub3hAAAwO9mrK/a+3pEx0aKjgyoCXYAAFRbQPwLZoxpJ2mcpCxJzx738qOSCiTdZIyJr+doAACgjs3YsN/7fEznDAeTAABQO4FyBXus53G6tdbt+4K1Nt8YM0+VBXyIpK+rcb4YY8yNklqpspyvkjTbWlvhx8wAAKCW8ovLtDgrx3s8qnO6g2kAAKidQCnYnT2PG0/yeqYqC3YnVa9gN5H02nFjW40xt1hrZ1UnkDFm6Ule6lKdzwMAgNObt+mgyiqsJKl7syQ1Top1OBEAAGcuIKaISzq62WXeSV4/Op5SjXO9IulsVZbseEk9Jb0oqY2kacaY3mecEgAA+NVMpocDAEJIoFzBPp2jm2Ha073RWvu744bWSLrLGHNE0k8kPSbp8mqcp/8Jg1Re2e53us8DAIBTs9Yee/91F6aHAwCCW6BcwT56hTr5JK8nHfe+M/GC53FkLc4BAAD85Ls9+dp3uESSlNwgSn1aNnQ4EQAAtRMoBXuD57HTSV7v6Hk82T3a1XH0V+SsRA4AQACYubHq6vXITulyRZhTvBsAgMAXKAV7hudxnDHmmEzGmERJwyUVSfq2Ft9jqOdxSy3OAQAA/GSmz/7XY1g9HAAQAgKiYFtrN0uarsqFyO497uXfqfKq86vW2gJJMsZEGWO6GGPa+77RGNPdGJN6/PmNMa0lPeM5fN3P8QEAQA3lFZZp6fZDkiRjKq9gAwAQ7AJpkbN7JM2X9JQx5mxJ30kaLGmMKqeG/9rnvc09r29TZSk/6oeSfmGMmSFpq6R8Se0lXSgpVtJnkv5ep38KAABwWnM2HVCFu3Lt0l4tUtQoIcbhRAAA1F7AFGxr7WZjzABJv5d0vqQLJO2R9JSk31lrc6pxmhmq3FO7ryqnhMdLypU0V5X7Yr9mrT3tSuQAAKBuzWB6OAAgBAVMwZYka+0OSbdU431Zqtq6y3d8lqRZ/k8GAAD8xe22mrWR/a8BAKEnIO7BBgAA4WPN7jxlHymVJKXFR6tn85Pt0gkAQHChYAMAgHrlOz18VKd0RbA9FwAgRFCwAQBAvfLd/3p0F6aHAwBCBwUbAADUm5yCUq3YkStJijDSyI6NnA0EAIAfUbABAEC9mb3xgI7u59GvVUOlxEU7GwgAAD+iYAMAgHozY4PP6uFMDwcAhBgKNgAAqBcVbqtZG6sWOBvN/tcAgBBDwQYAAPVixY5c5RaWSZIyEmPUrWmSw4kAAPAvCjYAAKgXM32mh4/unC5j2J4LABBaKNgAAKBeHHP/dWfuvwYAhB4KNgAAqHP784u1ZtdhSVJkhNFwtucCAIQgCjYAAKhzszZULW42oE1DJcVGOZgGAIC6QcEGAAB1bqZPwWZ6OAAgVFGwAQBAnSqrcGt2pk/BZv9rAECIomADAIA6tWzbIeUXl0uSmqc0UMeMBIcTAQBQNyjYAACgTs3wmR4+iu25AAAhjIINAADq1Ey25wIAhAkKNgAAqDO7c4u0fm++JCnaFaFh7dMcTgQAQN2hYAMAgDoza2PV9PDB7VIVHxPpYBoAAOoWBRsAANSZGeurpoePZno4ACDEUbABAECdKCmv0LxN2d7jMZ3THUwDAEDdo2ADAIA6sSTrkApKKyRJrdPi1LZRvMOJAACoWxRsAABQJ46ZHt6J7bkAAKGPgg0AAOrEDJ/tuUZ34f5rAEDoo2ADAAC/236wUJsPFEiSYiIjNLQd23MBAEIfBRsAAPjdzI1VV6+HtU9TbJTLwTQAANQPCjYAAPC7mRuq9r8ew/RwAECYoGADAAC/Ki6r0PzNVdtzje5EwQYAhAcKNgAA8KtvtxxUcZlbktQ+PV6t0uIcTgQAQP2gYAMAAL/ynR4+ujNXrwEA4YOCDQAA/MZaq2989r8eQ8EGAIQRCjYAAPCbrdkF2p5TKEmKi3ZpYNuGDicCAKD+ULABAIDfzPCZHj6sfSPFRLI9FwAgfFCwAQCA38zcUDU9fCzbcwEAwgwFGwAA+EVhabkWbsnxHo/unO5gGgAA6h8FGwAA+MX8TQdVWlG5PVeXJolqltLA4UQAANQvCjYAAPCLGT7Tw9meCwAQjijYAACg1qy1x+x/PYbp4QCAMETBBgAAtZa5/4h25RZJkhJjI9WvNdtzAQDCDwUbAADU2oz1VdPDR3RspCgXP2IAAMIP//oBAIBa4/5rAAAo2AAAoJYOF5dpSdYh7/HoTtx/DQAITxRsAABQK/Mys1XutpKkHs2TlJEU63AiAACcQcEGAAC14js9fAzTwwEAYYyCDQAAztjx23Nx/zUAIJxRsAEAwBlbt+ew9ueXSJJS4qLUp2WKs4EAAHAQBRsAAJwx36vXozqlyxVhHEwDAICzKNgAAOCM+e5/zf3XAIBwR8EGAABnJLewVMu2V27PZYw0ku25AABhjoINAADOyOzMbHl251LvFilKjY92NhAAAA6jYAMAgDMyk+nhAAAcg4INAABqzO22mrmxaoGzMV2YHg4AAAUbAADU2KpdecopKJUkNUqIVo9myQ4nAgDAeRRsAABQY76rh4/qlKEItucCAICCDQAAao7p4QAAfB8FGwAA1Ej2kRKt2pkrSXJFGI3oQMEGAECiYAMAgBqavfGArGd7rv6tGio5LsrZQAAABAgKNgAAqJEZG6qmh49mejgAAF4UbAAAUG3lFW7N9rn/enQn9r8GAOAoCjYAAKi2FTtylVdUJklqnBSjrk0THU4EAEDgoGADAIBqm7GhanuuMZ0zZAzbcwEAcBQFGwAAVNuM9T7TwzszPRwAAF8BVbCNMS2MMZOMMbuNMSXGmCxjzJPGmIZOnAcAAFTZm1esdXsOS5KiXEbDO6Q5nAgAgMAS6XSAo4wx7SXNl5Qh6SNJ6yUNkvSgpPONMcOttQfr6zwAAOBYszZWTQ8f2CZVibFszwUAgK9AuoL9nCpL8QPW2sustb+w1o6V9ISkzpL+VM/nAQAAPmb6bM81hunhAAB8T0AUbGNMO0njJGVJeva4lx+VVCDpJmNMfH2cBwAAHKuswq05mdne4zHsfw0AwPcERMGWNNbzON1a6/Z9wVqbL2mepDhJQ+rpPAAAwMeSrEM6UlIuSWrRsIHapyc4nAgAgMATKAW7s+dx40lez/Q8dqqn88gYs/REX5K6nO6zAACEmplszwUAwGkFSsFO9jzmneT1o+Mp9XQeAADgw3f/69GdmR4OAMCJBMwq4qdx9Nfktr7OY63tf8ITVF7F7lfLHAAABI2dhwq1cd8RSVJ0ZISGtmd7LgAATiRQrmAfvbKcfJLXk457X12fBwAAePiuHj6kXZriooPl9/MAANSvQCnYGzyPJ7s3uqPn8WT3Vvv7PAAAwOPY+6+ZHg4AwMkESsGe4XkcZ4w5JpMxJlHScElFkr6tp/MAAABJxWUVmrfpoPeY/a8BADi5gCjY1trNkqZLaiPp3uNe/p2keEmvWmsLJMkYE2WM6WKMaV+b8wAAgFNbtDVHRWUVkqS2jeLVplG8w4kAAAhcgXQT1T2S5kt6yhhztqTvJA2WNEaVU7p/7fPe5p7Xt6myTJ/peQAAwCn43n/N6uEAAJxaQFzBlrxXnwdImqzKQvwTSe0lPSVpqLX24Mk/7f/zAACA7+9/DQAATi6QrmDLWrtD0i3VeF+WqrbcOuPzAACAk9t2sEBbsivvqmoQ5dKgtqkOJwIAILAFzBVsAAAQWGZnZnufD22fptgol4NpAAAIfBRsAABwQvN8CvZZHRo5mAQAgOBAwQYAAN9T4baav7mqYI/oSMEGAOB0KNgAAOB7Vu3M1eHicklS46QYdchIcDgRAACBj4INAAC+Z+4x08PTZcxJ1xYFAAAeFGwAAPA9czYxPRwAgJqiYAMAgGMUlJRr+fZD3uNhHdIcTAMAQPCgYAMAgGMs3HpQZRVWktSlSaIyEmMdTgQAQHCgYAMAgGPMzTzofc72XAAAVB8FGwAAHGPupgPe52dx/zUAANVGwQYAAF77Dhdr474jkqRoV4QGt+X+awAAqouCDQAAvHy35+rfuqEaRLscTAMAQHChYAMAAK+5PttzMT0cAICaoWADAABJkrX22ILNAmcAANQIBRsAAEiSNu47ogP5JZKk5AZR6tE82eFEAAAEFwo2AACQJM3JrFo9fHiHNLkijINpAAAIPhRsAAAg6bj7rzukO5gEAIDgRMEGAAAqKa/Qwi053uMRLHAGAECNUbABAICWbctVUVmFJKl1WpxapsY5nAgAgOBDwQYAAJq7yff+a65eAwBwJijYAABAczcd9D4fQcEGAOCMULABAAhzeYVlWr0zV5IUYaRh7SnYAACcCQo2AABhbv7mbLlt5fOeLVKUHBflbCAAAIIUBRsAgDA3x2d7LqaHAwBw5ijYAACEubmZPvtfsz0XAABnjIINAEAY236wUNtzCiVJDaJc6tsqxdlAAAAEMQo2AABhbK7P9PDB7VIVE+lyMA0AAMGNgg0AQBjz3f/6LO6/BgCgVijYAACEqQq31Tzf/a87pjuYBgCA4EfBBgAgTK3Zlae8ojJJUkZijDo1TnA4EQAAwY2CDQBAmPK9//qsDo1kjHEwDQAAwY+CDQBAmJqT6XP/NdtzAQBQaxRsAADCUGFpuZZuO+Q9Hs4CZwAA1BoFGwCAMLRoa47KKqwkqVPjBDVOinU4EQAAwY+CDQBAGJqb6Xv/NauHAwDgDxRsAADCkO8CZyO4/xoAAL+gYAMAEGb25xdr/d58SVKUy2hwu1SHEwEAEBoo2AAAhJl5Plev+7VqqLjoSAfTAAAQOijYAACEmTmZx+5/DQAA/IOCDQBAGLHWHnMFm/2vAQDwHwo2AABhZNP+I9p3uESSlBQbqV4tUpwNBABACKFgAwAQRnynhw9r30iuCONgGgAAQgsFGwCAMDKX6eEAANQZCjYAAGGitNytb7cc9B6z/zUAAP5FwQYAIEws335IhaUVkqQWDRuoVWqcw4kAAAgtFGwAAMKE7+rhIzo2kjHcfw0AgD9RsAEACBNzfO+/7pDuYBIAAEITBRsAgDCQV1SmlTtyJUnGSMPapzkbCACAEETBBgAgDCzYnC23rXzes3myGsZHOxsIAIAQRMEGACAMzNp47P3XAADA/yjYAACEOGutZm884D0e2ZH7rwEAqAsUbAAAQtyW7ALtyi2SJCXERKpf64YOJwIAIDRRsAEACHG+V6+Htk9TlIt//gEAqAv8CwsAQIg7Znp4J6aHAwBQVyjYAACEsOKyCi3YctB7PIr7rwEAqDMUbAAAQtiSrEMqLnNLkto2ilertDiHEwEAELoo2AAAhLDZmb6rh7M9FwAAdYmCDQBACOP+awAA6g8FGwCAELXvcLHW782XJEW5jIa0S3M4EQAAoY2CDQBAiPK9ej2gdariYyIdTAMAQOijYAMAEKJmZ2Z7nzM9HACAukfBBgAgBFW4reb4LnDWiQXOAACoawFTsI0xw4wxnxljcowxhcaYVcaYh4wxrhqco40xxp7ia2pd/hkAAAgUq3flKbewTJKUnhijbk2THE4EAEDoC4ibsYwxl0p6T1KxpLcl5Ui6WNITkoZL+mENT7lS0ocnGF9z5ikBAAgevvdfj+jYSMYYB9MAABAeHC/YxpgkSf+RVCFptLV2iWf8N5K+kXSVMeZaa21Nrj6vsNY+5vewAAAECd+CPYr7rwEAqBeBMEX8KknpkqYeLdeSZK0tlvSI5/BuJ4IBABCMDheXafmOXEmSMdJZHbj/GgCA+uD4FWxJYz2Pn5/gtdmSCiUNM8bEWGtLqnnOZsaYOyWlSTooaYG1dlXtowIAEPjmb8pWhdtKkno0S1ZaQozDiQAACA+BULA7ex43Hv+CtbbcGLNVUndJ7SR9V81znuv58jLGzJQ0wVq7/cyjAgAQ+GZt9N2ei6vXAADUl0Ao2Mmex7yTvH50PKUa5yqU9AdVLnC2xTPWS9JjksZI+toY08daW3C6Exljlp7kpS7VyAEAgCOstcfcfz2yI/dfAwBQX/xyD7YxJus022Md//V6TU7vebSne6O1dr+19rfW2mXW2lzP12xJ4yQtlNRB0u01/xMCABAcNh8o0K7cIklSQkyk+rVu6HAiAADCh7+uYG9W5RZb1bXb5/nRK9TJJ3qjpKTj3ldjnqnmL0kaLGmkpH9V4zP9TzTuubLd70yzAABQl3yvXg9rn6YoVyCsZwoAQHjwS8G21p5di49vkDRAUidJx0zLNsZESmorqVxVU77P1NGfOOJreR4AAALW7Eyf6eFszwUAQL0KhF9rf+N5PP8Er42UFCdpfg1WED+ZIZ7H2hZ1AAACUnFZhb7dctB7zP7XAADUr0Ao2O9KypZ0rTFmwNFBY0yspD96Dp/3/YAxJtkY08UY0/S48cHGmOjjv4ExZqykH3kOa3L/NwAAQWNJ1iEVl7klSW0bxatlapzDiQAACC+OryJurT1sjLlDlUV7pjFmqqQcSZeocguvdyW9fdzHLpf0iqQpkm72Gf+rpO6eLbl2esZ6qWqv7d9Ya+fXwR8DAADHHTM9vCPbcwEAUN8cL9iSZK390BgzStKvJV0pKVbSJkk/lvSUtfa0K4h7vKbK8j1Q0g8kRUnaJ+kdSc9Ya+f4O3ug+ddXmdp04IhuO6ut+rRMcToOAKAezdrA/dcAADgpIAq2JFlr50m6oJrvnSxp8gnGX5b0sl+DBZHisgpNWZClnIJSfbxyt/q1StGtZ7XV+d2bKJJVZAEgpO3NK9aGffmSpGhXhIa0S3M4EQAA4SdgCjZqb05mtnIKSr3Hy7bnatmby9UsOVYThrXRtQNbKTkuysGEAIC64js9fECbhoqP4Z94AADqG5c1Q8i53Rrrk/vP0pX9WijKZbzju/OK9edp6zX0L1/rtx+t0ZYDRxxMCQCoC777XzM9HAAAZ1CwQ0yP5sn6x9W9Ne8XY/XA2R2VFl+1qHphaYVeXbBNY/8xS7dNXqx5m7JV/dvbAQCBqsJtNXdTtvd4ZEcKNgAATmD+WIjKSIzVj8/tpHtGt9f/VuzWpHlbtX5vvvf1r9fv19fr96tLk0TdOrytLunTTLFRLgcTAwDO1OpdecotLJMkpSfGqGvTRIcTAQAQnriCHeJio1y6emBLTXtwhN68fbDO7pJxzOvr9+brZ++t0vC/fKMnv9qoPM8PaACA4OE7PXxEx0Yyxpzi3QAAoK5wBTtMGGM0rEMjDevQSFsOHNHk+Vn675KdKiqrkCQdLCjVk19l6qU5W3XjkNa67ay2Sk+McTg1AKA6ZvkU7FHcfw0AgGO4gh2G2qUn6PeX9tC3vzxbv/xBFzVLjvW+dqSkXC/M2qyz/vqNHvvfWu3OLXIwKQDgdPKKyrRiR64kyRjprA6NnA0EAEAYo2CHseS4KN05qr1m/2yMnrymjzpmJHhfKyl3a/L8LI362wz9/N1VysoucDApAOBk5m/KVoW7csHKns2TlZbA7CMAAJxCwYYiXRG6rG9zffHQSL1wYz/1aJ7kfa2swurtJTs09h8z9eDU5drgs1AaAMB5vvtfs3o4AADO4h5seEVEGJ3fo6nO695EszYe0LMzNmlx1iFJkttKH63YrY9W7Na4bo1139gO6tUixdnAABDmrLWavdFney7uvwYAwFEUbHyPMUajO2dodOcMLdxyUM/M2KQ5mVU/wE1ft0/T1+3TiI6N9ODZHTWgTaqDaQEgfG0+UKBdnrUyEmIi1bdVirOBAAAIcxRsnNLgdmka3C5NK3fk6pkZm/Tlun3e1+ZkZmtOZrZGd07Xw+M6q0fzZAeTAkD48d2ea1j7NEW5uPMLAAAn8S8xqqV3yxT9Z/wAff7QCF3Su5kifLZYnbnhgC56eq7ufWOZNu0/4lxIAAgzvttzMT0cAADnUbBRI12aJOmp6/rq65+M1hV9m8v4FO1PV+/RuCdm6eH/rtSOnELnQgJAGCguq9DCrQe9x+x/DQCA8yjYOCNtG8Xrn9f00RcPjdT53Zt4x91WenfpTo39x0w9+tEa7c8vdjAlAISuxVk5Ki5zS5LaNYpXy9Q4hxMBAAAKNmqlU+NEvXBTf31073CN6NjIO15WYTVlwTaNfHyG/jJtvXILSx1MCQChZzbTwwEACDgUbPhF75Ypeu22wZo6cYgGtG7oHS8uc+uFWZs14q8z9PTXmTpSUu5gSgAIHcduz9XoFO8EAAD1hYINvxrSLk3/vWuoXrl5oLo1TfKO55eU6x9fbtTIx2do0tytKi13O5gSAILb3rxibdiXL0mKdkVoSLs0hxMBAACJgo06YIzRmC4Z+uT+s/Ts9f3ULj3e+1pOQal+/8k6nf/kbH2zfp+stQ4mBYDgNGvjfu/zAW0aKi6aXTcBAAgEFGzUmYgIowt7NdX0h0bq8at6qXlKA+9rW7ILdOvkJRo/aZE2eq7CAACqZ/rafd7nYzpnOJgEAAD4omCjzkW6InT1gJb65uFReuTCrkqMrbrSMiczWz/41xz95sM1yilgITQAOJ2CknLN2VR1//W47o0dTAMAAHxRsFFvYiJdun1EO818eLRuGNxKEZ49tCvcVq99u02j/1Z5f3ZZBfdnA8DJzMk84F3HonPjRLVOiz/NJwAAQH2hYKPepSXE6E+X99RnD47Q8A5VC/McLi7X7z9Zp/O4PxsATsp3ejhXrwEACCwUbDimS5MkvX7bYP1n/AC1SYvzjm85UHV/dib3ZwOAV3mFW1+vr1rg7NxuFGwAAAIJBRuOMsbo3G6N9cWPRurXF3RVYsyx92ef/685evSjNTrE/dkAoEVZOcorKpMkNUmKVc/myQ4nAgAAvijYCAgxkS7dMbKdZvx0tK4/7v7sKQu2afTfZ+qdJTuYNg4grB0/PdwY42AaAABwPAo2AkqjhBj93+U99ekDIzS0XdX92XlFZfrZu6t0/X8Wamt2gYMJAcAZ1lp9uc6nYHdr4mAaAABwIhRsBKSuTZP05h2D9e+b+qtFw6r9sxdsOajznpytZ2ds8q6iCwDhYN2ew9qVWyRJSoyN1OB2qQ4nAgAAx6NgI2AZYzSuexNN/9FITRzZzjttvLTcrb99sUEXPz1Xy7YfcjYkANQT3+nhY7tkKMrFP+EAAAQa/nVGwIuLjtSvLuiq/913lno0T/KOb9iXryufn69HP1qj/OIyBxMCQN2bzvRwAAACHgUbQaNH82R9eM9wPXJhVzWIckmSrJWmLNimc/85W9PX7nU4IQDUjR05hfpuz2FJUrQrQqM6pzucCAAAnAgFG0El0hWh20e00/QfjdSoTlU/YO49XKyJry3V3a8v1b7DxQ4mBAD/813cbFiHNCX4bGkIAAACBwUbQallapwm3zJQ/7q2j9Lio73j09bs1Tn/mKXXv90mt5stvQCEhunrqmboMD0cAIDARcFG0DLG6NI+zfX1T0bp6gEtvOP5JeV65MM1uvrFBWzpBSDoHSoo1aKtOd7jc7pmOJgGAACcCgUbQS8lLlqPX9Vbb94xWG3S4rzjS7Yd0gX/mqNXF2RxNRtA0Ppm/X4d/Susb6sUZSTFOhsIAACcFAUbIWNY+0b6/KGRum9MB0V69vQqKqvQbz9aqwmvLNKevCKHEwJAzTE9HACA4EHBRkiJjXLp4fM668N7h6tT4wTv+JzMbI17YrbeX7ZT1nI1G0BwKC6r0OyN2d7jc7s1djANAAA4HQo2QlKP5sn6331n6c6R7WQqL2Yrv7hcP35npe5+fZkOHilxNiAAVMPczGwVlVVIktqlx6tDRsJpPgEAAJxEwUbIio1y6ZcXdNXbE4eqZWoD7/jna/fqvCfZNxtA4GN6OAAAwYWCjZA3qG2qpj04UtcNauUdyz5SqomvLdXD/12pw8VlDqYDgBOrcFt99d1+7/G47kwPBwAg0FGwERYSYiL15yt66pVbBiojMcY7/u7SnfrBk3M0f1P2KT4NAPVv6bZDyikolSSlJ8aoT4sUZwMBAIDTomAjrIzpnKHpPxqpS3o3847tyi3S9S8t1GP/W6ui0goH0wFAlS99poef07WxIjy7IwAAgMBFwUbYSYmL1lPX9dUz1/dVSlyUd3zy/Cxd+NQcrdmV52A6AJCstZq+bp/3mOnhAAAEBwo2wtZFvZpp+kMjNaZzundsS3aBrnhuvl77dhvbeQFwzMZ9R7TtYKEkKT7apWHt0xxOBAAAqoOCjbCWkRSrSTcP1F+u6Kn4aJckqbTCrd98uEb3vbmcBdAAOMJ3evjozhmKiXQ5mAYAAFQXBRthzxijawe10sf3n6WuTZO845+u3qOLn56r1TuZMg6gfjE9HACA4ETBBjzapSfog3uG6YbBVdt5bTtYqCufn68p87OYMg6gXuzOLdIqzy/2IiOMRnfOcDgRAACoLgo24CM2yqU/Xd5TT1/XVwkxkZIqp4w/+r+1uueNZUwZB1Dnvvqu6ur1kHZpSm4QdYp3AwCAQELBBk7g4t7N9PH9Z6l7s6op49PW7NVFT83Vqp25zgUDEPK+ZHo4AABBi4INnETbRvF67+5humlIa+/Y9pzKKeOvzNvKlHEAfpdXVKYFmw96j8/pSsEGACCYULCBU4iNcukPl/XQs9f3804ZL6uw+t3H63TX60uVV8SUcQD+M3PDfpW7K39517N5spqlNHA4EQAAqAkKNlANF/Zqqk8fOEs9mldNGf9i7T5d+NQcrdiR61wwACHlmNXDu3H1GgCAYEPBBqqpdVrllPGbh7Xxju08VKQfvjBfr3+7zblgAEJCSXmFZq7f7z0e172Jg2kAAMCZoGADNRAT6dJjl3TX8zf0U2Js1ZTxRz5co19/sFql5W6HEwIIVvM3H1RBaYUkqVVqnDo1TnA4EQAAqCkKNnAGftCzqT69f8QxU8bfWLhdN768UAePlDiYDECwmr722OnhxhgH0wAAgDNBwQbOUKu0OP33zmG6uHcz79iirTm65Jl5Wrs7z8FkAIKN222P2f+a6eEAAAQnCjZQCw2iXXrq2j762fmddfRi067cIl31/AJ9umqPs+EABI0VO3N1IL9y9ktqfLT6t27ocCIAAHAmKNhALRljdM/oDnp5wgAlerbyKiqr0L1vLtM/pm+Q281+2QBOzXd6+NldMuSKYHo4AADBiIIN+MnYLo31wb3D1CYtzjv29DebNPG1pcovZr9sACf35bq93udMDwcAIHhRsAE/6pCRqI/uPUsjOjbyjn313T5d8dx8bTtY4GAyAIFq0/4j2nyg8u+H2KgIndWh0Wk+AQAAAhUFG/Cz5LgovXLzQN0xoq13LHP/EV3yzDzNzcx2MBmAQDTd5+r1yI7pahDtcjANAACoDQo2UAciXRH69YXd9I8f9lZ0ZOV/ZnlFZZrwyiJNmrtV1nJfNoBKn62uWhDxPKaHAwAQ1CjYQB26sn8LvT1xiDISYyRJFW6r33+yTj97d5VKyiscTgfAadsOFmjNrsOSpCiX0TndGjucCAAA1IbjBdsYE2WMedAY84oxZoUxptQYY40xt9finMOMMZ8ZY3KMMYXGmFXGmIeMMcy7Q73r26qhPr7/LPVumeId++/SnRr/8iLlFbH4GRDOPvW5ej2yY7qSG0Q5mAYAANSW4wVbUrykJyXdLKmJpL2nevPpGGMulTRb0khJH0h6VlK0pCckTa3NuYEz1TgpVm9PHKIr+jX3ji3cmqMfvjBfe/KKHEwGwEm+08Mv6NnUwSQAAMAfAqFgF0q6QFIza20TSZPO9ETGmCRJ/5FUIWm0tfY2a+1PJfWRtEDSVcaYa2sfGai52CiX/vHD3vr5+V28Yxv3HdEVz83Xhr35DiYD4ASmhwMAEHocL9jW2lJr7TRr7Z7Tv/u0rpKULmmqtXaJz/colvSI5/BuP3wf4IwYY3T36PZ64preiowwkqQ9ecW66oX5+nbLQYfTAahPvtPDRzA9HACAkOB4wfazsZ7Hz0/w2mxVXi0fZoyJqb9IwPdd3reFXrlloOI92/HkF5dr/MuL9Mmq3Q4nA1BffKeHX8j0cAAAQkKoFezOnseNx79grS2XtFVSpKR2pzuRMWbpib4kdTndZ4HqGNExXW/fOVTpnhXGSyvcuv+t5Xp57laHkwGoa9sPFjI9HACAEBRqBTvZ85h3ktePjqfUfRTg9Ho0T9b7dw9Tu/R4SZK10h8+Wac/fbpObjd7ZQOhiunhAACEJr8UbGNMlmdrrep+ve6P73smUT2Pp20u1tr+J/qStL5uIyLctEyN03t3DVO/Vinesf/M2aoH317BXtlAiGJ6OAAAoSnST+fZLKm4Bu+vqxtNj16hTj7J60nHvQ8ICA3jo/XmHUP0wFvLNX3dPknSxyt3Kzu/RC+O76+kWK5uAaFi+8FCrd5V+c8Q08MBAAgtfrmCba0921rbpQZfP/PH9z2BDZ7HTse/YIyJlNRWUrmkLXX0/YEzFhvl0vM39teNQ1p5xxZsOairX1igvXk1+f0VgEDG9HAAAEJXqN2D/Y3n8fwTvDZSUpyk+dbakvqLBFSfK8LoD5f20E/P6+wdW783X1c8N0+Z+9grGwgFvtPDL2B6OAAAISUoC7YxJtkY08UYc/xPJu9KypZ0rTFmgM/7YyX90XP4fD3FBM6IMUb3jumgv/+waq/s3XnFuvL5+VqSleNwOgC1cfz08HOZHg4AQEgJiIJtjPmFMWayMWaypMs8w7ccHTPG3H7cRy6X9J2kP/sOWmsPS7pDkkvSTGPMS8aYxyWtkDRUlQX87Tr7gwB+dFX/Fnr55oGK8+yVfbi4XOMnLdKirZRsIFgxPRwAgNAWEAVblVO6J3i+envGhvmMnVXdE1lrP5Q0StJsSVdKul9SmaQfS7rWWsveRwgaozql6507h6pRQrQkqbC0Qje/skjfbjnocDIAZ4Lp4QAAhLaAKNjW2tHWWnOKr5uPe//kE437vD7PWnuBtbahtbaBtbantfYJay17HiHo9GierKkThyo9MUZSZcm+5ZXFWrCZkg0EE6aHAwAQ+gKiYAM4tQ4ZCZo6cYgyPCW7qKxCt0xepPmbsh1OBqC6PlvD9HAAAEIdBRsIEu3TK0t246TKkl1c5tYtkxdrbiYlGwgGTA8HACD0UbCBINIuPUFTJw5Vk6RYSVJJuVu3TVmsOZkHHE4G4FS2HyzUqp1MDwcAINRRsIEg07ZRvKZOHKKmyb4le4lmbaRkA4HKd3r4WR0aMT0cAIAQRcEGglAbT8lu5inZpeVu3fHqEs3csN/hZABOxHd6+IW9mjmYBAAA1CUKNhCkWqfFa+rEoWqe0kBSZcme+OpSzVhPyQYCyY4cpocDABAuKNhAEGuVFqepE4dUlewKt+58bam+Wb/P4WQAjvp0NdPDAQAIFxRsIMi1TI3T23cOUYuGx5bsr9ZRsoFAwOrhAACEDwo2EAJaNIzT23cOVcvUypJdVmF19xtL9SUlG3DU8dPDx3Vr4nAiAABQlyjYQIhontJAb08cqlapcZIqS/Y9byzV9LV7HU4GhK/Pjp8eHsf0cAAAQhkFGwghzVIa6O07h6h1WlXJvvfNZZrB6uKAI5geDgBAeKFgAyGmaXLllew2PiX7rteWav6mbIeTAeFlR06hVjI9HACAsELBBkJQk+RYvXlH1cJnJeVu3TZliRZn5TicDAgfTA8HACD8ULCBENUspYHeumOImiTFSpKKyip0yyuLtXJHrrPBgDDB9HAAAMIPBRsIYS1T4/TmHYPVKCFGknSkpFzjJy3Sut2HHU4GhDamhwMAEJ4o2ECIa5eeoDduH6yGnumpeUVluvHlhcrcl+9wMiB0MT0cAIDwRMEGwkDnJol67bbBSoyNlCTlFJTq+pcWamt2gcPJgNDE9HAAAMITBRsIEz2aJ2vKrYMUH+2SJB3IL9EN//lWO3IKHU4GhBamhwMAEL4o2EAY6deqoSbdPFCxUZX/6e/OK9YNLy3U3rxih5MBoWPamqqr18OZHg4AQFihYANhZnC7NP1n/ABFR1b+5789p1DXv/StDuSXOJwMCA2frt7rfX4h08MBAAgrFGwgDI3omK7nb+inyAgjSdpyoEA3vrRQOQWlDicDgtuOnELvVnhMDwcAIPxQsIEwdXbXxnr6ur5yeUr2hn35Gj9pofKKyhxOBgQv38XNmB4OAED4oWADYewHPZvqHz/sLVPZsbVm12Hd/MoiHSkpdzYYEISstXp78Q7vMdPDAQAIPxRsIMxd1re5/nJFT+/x8u25um3yYhWXVTiYCgg+C7fmaItn67vEmEhd2IuCDQBAuKFgA9A1A1vp95d29x4v3Jqje95YptJyt4OpgODy5sLt3ueX9W2uuOhIB9MAAAAnULABSJLGD22jX/6gi/f4m/X79eN3VqjCbR1MBQSHnIJSfb6mavXw6wa1cjANAABwCgUbgNedo9rr3jHtvcefrNqjRz5cI2sp2cCpvLd0p0orKmd89G6Zom7NkhxOBAAAnEDBBnCMh8d11vihrb3Hby3arr9MW0/JBk7CWqu3FlVND7+Bq9cAAIQtCjaAYxhj9NjF3XV53+besRdnb9FzMzc7mAoIXMcvbnZRbxY3AwAgXFGwAXxPRITR367qpXO7NfaO/e2LDXp1QZZzoYAAxeJmAADgKAo2gBOKdEXo6ev6aniHNO/Ybz9aq/eX7XQwFRBYWNwMAAD4omADOKnYKJf+fdMA9WmZ4h376bur9MXavSf/EBBGWNwMAAD4omADOKX4mEhNvmWgujRJlCRVuK3uf3O55mZmO5wMcBaLmwEAgONRsAGcVkpctF69bZDapMVJkkor3Jr42hIt3XbI4WSAc1jcDAAAHI+CDaBaMhJj9frtg9U0OVaSVFhaoVteWaTv9hx2OBngDBY3AwAAx6NgA6i2Fg3j9Nptg5UWHy1JOlxcrpteXqStnqt4QLhgcTMAAHAiFGwANdIhI0FTbh2kxJjKq3XZR0p040sLtTu3yOFkQP1hcTMAAHAiFGwANdajebIm3TJQsVGVf4Xsyi3SjS8vVE5BqcPJgLrH4mYAAOBkKNgAzsjANql68aYBinIZSdKWAwW6bcpiFZVWOJwMqFvfbmFxMwAAcGIUbABnbFSndD15TV+Zyo6t5dtzdd+by1TumToLhCLfq9csbgYAAHxRsAHUyoW9murRi7p5j79ev1+PfLhG1loHUwF1g8XNAADAqVCwAdTazcPb6q5R7b3HUxfv0BNfZTqYCKgbLG4GAABOhYINwC9+fn5nXdGvuff4qa8z9cbCbQ4mAvyLxc0AAMDpULAB+IUxRn+9spdGdkr3jv3mwzX6Yu3eU3wKCB6+i5slsLgZAAA4AQo2AL+JckXo+Rv6qVeLZEmS20oPvLVcS7JyHE4G1N6xi5s1Y3EzAADwPRRsAH4VHxOpSTcPVOu0OElSSblbt01Zosx9+Q4nA87c8YubXT+otYNpAABAoKJgA/C7RgkxevXWQWqUEC1Jyisq04RJi7Q3r9jhZMCZYXEzAABQHRRsAHWidVq8Jt08UHHRLknS7rxiTZi0SHlFZQ4nA2qGxc0AAEB1UbAB1JleLVL0/I39FRlhJEkb9uVr4qtLVFxW4XAyoPpY3AwAAFQXBRtAnRrVKV2PX9XLe7xwa45+/M4KVbitg6mA6mNxMwAAUF0UbAB17op+LfSLH3TxHn+2eq9+//FaWUvJRmBjcTMAAFATFGwA9eLOke1087A23uMpC7bp+VmbnQsEVAOLmwEAgJqgYAOoF8YY/faibrqwV9X9q49/vkHvLt3pYCrg5FjcDAAA1BQFG0C9iYgw+ufVvTWkXap37OfvrdLMDfsdTAWcGIubAQCAmqJgA6hXMZEu/Xv8AHVpkihJqnBb3fPGMq3cketsMOA4U+ZneZ+zuBkAAKgOCjaAepcUG6Uptw5S85QGkqTC0grdOnmxsjxXCwGnbdibr8/XVi1uduMQFjcDAACnR8EG4IjGSbGacutApcRFSZIOFpRq/KRFOpBf4nAyQHpmxibv83O6NlaXJixuBgAATo+CDcAxHTIS9fKEAYqJrPyraHtOoW6dvFhHSsodToZwtvnAEX2yarf3+IGzOziYBgAABBMKNgBH9W+dqmeu76cIU3m8elee7n59qUrL3c4GQ9h6dsYmHd2ifXTndPVqkeJoHgAAEDwo2AAcd263xvrjZT29x3Mys/WL91bJHm05QD3ZdrBAH62ounp9/9iODqYBAADBhoINICBcP7iVHjy7qsy8v3yX/vr5BgcTIRw9N2OzKtyVv9gZ3iFN/Vs3dDgRAAAIJhRsAAHjoXM66rpBLb3HL8zarFfmbXUwEcLJzkOFem/ZTu8xV68BAEBNOV6wjTFRxpgHjTGvGGNWGGNKjTHWGHP7GZyrjeezJ/uaWhd/BgD+YYzRHy7toXO6NvaO/f6TdccsOAXUlRdmbVa55+r1oDapGtIuzeFEAAAg2EQ6HUBSvKQnPc/3SdorqeVJ3109KyV9eILxNbU8L4A6FumK0NPX9dUNL32rZdtzZa3047dXKi0+RkPbU3hQN/bmFeudxT5Xr1k5HAAAnAHHr2BLKpR0gaRm1tomkib54ZwrrLWPneDrXT+cG0AdaxDt0ssTBqpderwkqbTCrYmvLtF3ew47nAyh6sXZm1VaUblyfZ+WKTqrQyOHEwEAgGDkeMG21pZaa6dZa/c4nQVA4GgYH61Xbx2kjMQYSVJ+SblufmWRduUWOZwMoeZAfoneXLjde/zA2R1kjHEwEQAACFaOF+w60swYc6cx5leex15OBwJQcy0axmnyLYOUGFN5N8u+wyUa//JCHSoodTgZQslLc7aoxLPveo/mSRrTOcPhRAAAIFiFasE+V9ILkv7keVxpjJlhjGlV3RMYY5ae6EtSlzrKDOAEujVL0ovj+yvaVfnX1eYDBbp58mIVlJQ7nAyhIKegVK99u817fN+Yjly9BgAAZyzUCnahpD9I6i+poedrlKQZkkZL+toYE+9YOgBnZFj7RvrnNb11tPes3JGru15fqpLyCmeDIehNmrtVhaWV/z/q3DhR47o1Ps0nAAAATs4vBdsYk3Wa7bGO/3rdH9/3eNba/dba31prl1lrcz1fsyWNk7RQUgdJ1dr+y1rb/0RfktbXRXYAp3ZRr2b6/aU9vMdzMrP147dXqsKzrRJQU3lFZZoyP8t7fN/YDoqI4Oo1AAA4c/7apmuzpOIavL9eN7W11pYbY16SNFjSSEn/qs/vD8A/bhrSWrkFpfrHlxslSZ+u3qPkuCj96bIeTOtFjU2el6V8z60G7dLjdUHPpg4nAgAAwc4vBdtae7Y/zlPHDngemSIOBLH7xnZQTmGpXpmXJUl6c+F2pcZF6+HzOjsbDEElv7hMk+Zt9R7fP7aDXFy9BgAAtRRq92CfyhDP4xZHUwCoFWOMfnNhN13et7l37JkZm/Ty3K2n+BRwrNe+3aa8ojJJUuu0OF3cq5nDiQAAQCgIyoJtjEk2xnQxxjQ9bnywMSb6BO8fK+lHnsM6uf8bQP2JiDB6/KpeGtulajulP3yyTu8v2+lgKgSLwtJyvTSn6hcy947uoEhXUP5zCAAAAoy/7sGuFWPML1S1/VUfz+MtxpizPM/nWmtf8vnI5ZJekTRF0s0+43+V1N0YM1PS0Z+0e0ka63n+G2vtfL+GB+CIKFeEnr2+n256eaGWbDskSfrpu6uUFBulc1gJGqfwxrfblePZS715SgNd3q/5aT4BAABQPYHyK/vzJU3wfPX2jA3zGTvrJJ873muqXC18oKQ7JN0jqaOkdySNtNb+0Y+ZATisQbRLL988UF2aJEqSKtxW9765TIu25jicDIGquKxCL86uulPo7tHtFcXVawAA4CcB8VOFtXa0tdac4uvm494/+STjL1trL7LWtrHWJlhrY6y1ray111hr59TnnwlA/UhuEKVXbx2kVqlxkqSScrdum7xYa3fnOZwMgWjqou3KPlIiSWqSFKsfDmjhcCIAABBKAqJgA0BtZCTF6vXbBis9MUaSlF9SrgmTFisru8DhZAgkJeUVemFW1dXrO0e1U0yky8FEAAAg1FCwAYSEVmlxevXWQUqMrVxaIvtIiW58eaH2HS52OBkCxbtLd2qv5/8PjRJidN2gVg4nAgAAoYaCDSBkdG2apEk3D1RsVOVfbTsPFWn8y4uUV1jmcDI4razCrednbvYeTxzZVrFRXL0GAAD+RcEGEFIGtknV8zf0V2SEkSRt2JevW6csVmFpucPJ4KQPlu/SzkNFkqSGcVG6YXBrhxMBAIBQRMEGEHLGdMnQ33/Y23u8dNsh3fHqEhWXVTiYCk7JKyzT459v8B7fPqKd4mMCYpdKAAAQYijYAELSZX2b69GLu3mP5206qHveWKbScreDqeCEP366zrtyeHpijMYP5eo1AACoGxRsACHrluFt9dPzOnuPv1m/Xw9OXa7yCkp2uJiTeUD/XbrTe/zHy3ooMTbKwUQAACCUUbABhLR7x3TQfWM6eI+nrdmrh/+7UhVu62Aq1IeCknL98v3V3uMLezbVed2bOJgIAACEOgo2gJD3k3GddNtZbb3HH67YrV9/sFrWUrJD2d+nb/AubJYSF6XHLunucCIAABDqKNgAQp4xRo9c2FU3DK7a93jq4h363cfrKNkhaum2HE2en+U9/u1F3ZSeGONcIAAAEBYo2ADCgjFGf7i0h67o19w7Nnl+lv76+QZKdogpLqvQz95dpaP/s47qlK7L+zY/9YcAAAD8gIINIGxERBg9fmUvXdirqXfshVmb9fQ3mxxMBX97dsYmbT5QIEmKj3bpT5f3kDHG4VQAACAcULABhJVIV4SevKaPzuna2Dv2zy836t+zNzuYCv6ybvdhPT+z6n/Ln/+gi1o0jHMwEQAACCcUbABhJ8oVoWeu76sRHRt5x/7vs/V6bUGWc6FQa+UVbv38vVUq96wQP7BNQ904mD2vAQBA/aFgAwhLsVEu/fumARrUNtU79puP1uqdJTscTIXaeGnuVq3elSdJio6M0F+u7KWICKaGAwCA+kPBBhC2GkS7NOnmgerTMsU79vP3VumjFbucC4UzsuXAET3x5Ubv8UPndFT79AQHEwEAgHBEwQYQ1hJiIjXl1kHq3ixJkmSt9ON3VurzNXsdTobqcrutfvH+apWUuyVJ3Zsl6Y4R7RxOBQAAwhEFG0DYS24QpdduG6yOGZVXPCvcVve/tUxff7fP4WSojjcXbdeirTmSJFeE0V+v7KUoF/+8AQCA+sdPIAAgKTU+Wm/cPlhtG8VLksoqrO56fammr+VKdiDbnVukv0xb7z2+a1Q79Wie7GAiAAAQzijYAOCRkRSrN24frFaplds6lVVY3fPGMqaLByhrrR75cI2OlJRLktqlx+v+sR0dTgUAAMIZBRsAfDRLaaCpE4eodVplyS53W9335jJNW73H4WQ43kcrduub9fslScZIj1/ZS7FRLodTAQCAcEbBBoDjNEtpoLcnDvVOFy93W9331nJ9uoqSHSiyj5Todx+v9R6PH9JaA9qknuITAAAAdY+CDQAn0CQ5VlMnDlG79MqSXeG2emDqcn28crfDySBJv/t4nQ4VlkmSmqc00E/P7+JwIgAAAAo2AJxU46RYTb1jiNr7lOwHpy5nn2yHfblu3zG/6Pi/K3oqISbSwUQAAACVKNgAcAoZSbGaOnGodwsvt5V+9PYKfbB8p8PJwtO63Yf147dXeI+v7NdCozqlOxcIAADABwUbAE4jPTFGb00cok6Nq0r2j99ZqXeXUrLr046cQk14ZZHyPauGN06K0W8u6upwKgAAgCoUbACohkYJMXrrjiHq0iRRkmSt9NN3V+qdxTscThYeso+UaPykRTqQXyJJSoyJ1ORbBiklLtrhZAAAAFUo2ABQTWkJMXrzjiHq2jRJUmXJ/tl7qzR10XaHk4W2IyXlunXyYm3NLpAkRUdG6KUJA7z/OwAAAAQKCjYA1EBqfLTevH2wujerKne/eH+13lxIya4LpeVu3f36Uq3amSdJijDS09f11eB2aQ4nAwAA+D4KNgDUUMP4aL1x+2D1bJ7sHfvVB6v12rfbHEwVetxuq4f/u1JzMrO9Y3+8rKfO697EwVQAAAAnR8EGgDOQEhet128brN4tqkr2bz5co2dnbJK11sFkocFaqz98uk7/89mO68fndtL1g1s5mAoAAODUKNgAcIaS46L06m2D1adlinfsb19s0E/fXaXScrdzwULA87M265V5Wd7jm4a01v1jOzgXCAAAoBoo2ABQC8kNovTqbYM01Oee4HeX7tT4SQuVW1jqYLLg9c6SHXr88w3e4wt6NtFjl3SXMcbBVAAAAKdHwQaAWkqKjdKUWwfph/1beMe+3ZKjK56bryzPyteonq/W7dMv31/tPR7aLk1PXNNHrgjKNQAACHwUbADwg+jICD1+VS/99LzO3rEt2QW6/Ll5WpyV42Cy4LEkK0f3vrlMFe7Ke9i7NU3Sv8f3V0yky+FkAAAA1UPBBgA/Mcbo3jEd9Oz1/RQTWfnX66HCMt3wn4X6aMUuh9MFto378nXr5MUq8dy73io1TpNvHajE2CiHkwEAAFQfBRsA/OzCXk311sQhapQQLUkqrXDrwakr9ORXG1lh/AR25RZp/MuLdLi4XJLUKCFar946SBmJsQ4nAwAAqBkKNgDUgX6tGuqDe4arY0aCd+zJrzL143dWqqS8wsFkgeVQQanGv7xQew8XS5Lio12afMsgtWkU73AyAACAmqNgA0AdaZkap3fvHqYRHRt5xz5Yvks3vrRQOQWsML4jp1DX/edbbT5QuRBclMvo3+MHqEfz5NN8EgAAIDBRsAGgDiU3iNKkmwfqukGtvGOLsw7p8ufmacuBIw4mc9bCLQd16bPztH5vviTJGOmJa/poeIdGp/kkAABA4KJgA0Adi3JF6P8u76FfXdBFR7dy3nawUJc/N1/fbjnobDgHvLVou27wuYof7YrQ36/qrYt6NXM4GQAAQO1QsAGgHhhjNHFkez1/Q3/FRlX+1ZtXVKabXl6oJ7/aqOKy0L8vu6zCrUc/WqNfvr9a5Z6tuBolROutiYN1pc8e4gAAAMGKgg0A9ej8Hk309sShSk+MkSSVVVg9+VWmxj0xW19/t8/hdHXnUEGpJkxapCkLtnnHujdL0kf3naX+rVMdTAYAAOA/FGwAqGe9W6bow3uHq3eLqsW8tucU6rYpS3T7lMXakVPoYDr/y9yXr8uem6f5m6umw1/Ys6n+e9dQNU9p4GAyAAAA/6JgA4ADmqc00Pv3DNefLu+h5AZR3vGvvtuvc/45K2SmjX/93T5d/tx8bTtY9UuDn5zbSc9c31dx0ZEOJgMAAPA/CjYAOMQVYXTD4Naa8fBoXTuwpXe8pNztnTb+zfrgnDZurdXzMzfr9leX6EhJuSQpLtqlF27sr/vP7ihzdLU3AACAEELBBgCHpcZH6y9X9tIH9wxTz+bHThu/dfIS3T5lSVBNGy8uq9CP3l6hv36+XrZyLTM1T2mg9+4epvN7NHE2HAAAQB2iYANAgOjbqqE+vHe4/njZ8dPG9+mcf87Sv77KDPhp43vzinXNiwv04Yrd3rFBbVP1v/uGq2vTJAeTAQAA1D0KNgAEEFeE0Y1DTjxt/ImvNnqnjdujl4YDhLVW8zZl65Jn5mrlzjzv+HWDWun12wYrLSHGwXQAAAD1gxVmACAAHZ02fs3AlvrtR2u1eldlaT06bbxLk0TdMLiVLu3bXEmxUac5W92pcFt9sXavXpy9RSt35HrHXRFGv72om8YPbc391gAAIGyYQLsKEuiMMUv79evXb+nSpU5HARAmKtxWby3arr99sUF5RWXHvNYgyqVLejfTdYNbqXeL5Hors0WlFXp36Q69NHfrMSuES1Jygyg9d0M/De/QqF6yAAAA+FP//v21bNmyZdba/jX9LFewASDAHZ02/oMeTfTEVxv17tKdKi5zS5KKyir09pIdenvJDnVrmqTrB7fSpX2aKbGOrmofPFKiVxds02vfblNOQekxr0W7InRFv+a6b2wHtWgYVyffHwAAIJBxBbuGuIINwGl5RWX6cPkuvblwuzbsy//e63HRlVe1rx/cSr1apPjle2ZlF+iluVv03yU7VVLuPua15AZRunFIK00Y1kYZibF++X4AAABO4Qo2AISR5AZRmjCsjcYPba1l23P15sLt+mTVbm/xLSyt0NTFOzR18Q71aJ6k6we11iV9mikhpuZ/5S/ffkj/nr1Fn6/dq+N/H9s8pYFuO6utrhnYUvFncG4AAIBQwxXsGuIKNoBAlFdYpveX79SbC7crc/+R770e5TJKiIlUdGSEYiJdiomMUEyUz/Oj41FVzzfszdeirJzvnat7syRNHNlOF/ZsqkgXm1EAAIDQwhVsAAhzyXFRumV4W908rI2WbDukNxdu16er96jUc1W7rMLqUGHZac5yaiM7pevOke00rH0aK4MDAACcAAUbAEKI+f/27j1IsrK84/j3cZfLSrHLAmItS5JZUFissoK4JnFBWKHwkiBIiSUVE0EoSpOAqKmKqWgIUVOAchOLsCkkLhcJBgIkJgvGuFmwIAahjJIS0EVWYLlELnJbWNjdN3+870AzdM/0zJyZc07391N1qqfP5e2339/MdD99Tp8TwdtGduZtIztz6uFv4pofbuAfbr2PdV32avdj7muCI35zd048aE/2XTS/4t5KkiQNFgtsSRpQC3fYlhMOXMIJBy7h2U2b2bR5K5s2b2HTi1tf/nnz1nJ/y6uWz50TvHOf3dh9p3l1PxVJkqRWsMCWpCGww3Zz2WG7unshSZI02Dw7jSRJkiRJFbDAliRJkiSpAhbYkiRJkiRVoPYCOyLeGBGfiYg1EXF/RLwQEY9ExD9HxDun2ObyiFgdEY9HxMaI+HFEfDIi5lTdf0mSJEmSoAEFNvAF4Azg9cBq4GzgZuD3gDUR8YnJNBYRRwI3AQcB1wIXANsC5wJXVtdtSZIkSZJe1oSziN8AnJlS+mHnzIg4GPgO8OWIuCql9NBEDUXEfOAiYAuwIqV0W5n/l8Aa4OiIOCalZKEtSZIkSapU7XuwU0qrxhbXZf6NwFry3uflfTZ3NPA64MrR4rq09TzwuXL3j6bVYUmSJEmSuqi9wJ7Ai+V2c5/rH1Jub+iy7CZgI7A8IrwarCRJkiSpUo0tsCPiN4BDyUXxTX1utk+5/enYBSmlzcC95MPi96yij5IkSZIkjWrCd7Bfpexh/gawHfBnKaUn+tx0Qbl9ssfy0fk79dGH23ssWtpnXyRJkiRJQ6SSPdgRsT4i0iSmy8dpaw5wGXAA8E3grCr6ONp8uU0VtilJkiRJUmV7sO8Bnp/E+g92m1mK68uBDwL/CPxBSmkyxfDoHuoFPZbPH7NeTymlt/bo4+3A/pPokyRJkiRpCFRSYKeUDp1uGxExF7iCXFxfAXwkpbRlks3cDSwD9gZecYh3aX8J+YRpP59ufyVJkiRJ6tSIk5xFxLbA1eTi+lLgD6dQXEO+1jXAe7osOwh4LXBLSmnTlDoqSZIkSVIPtRfY5YRm1wJHAhcDH00pbZ1gmwURsTQiFo1ZdDXwKHBMRCzrWH974Ivl7oWVdV6SJEmSpKIJZxFfCfwuuTDeAJwaEWPXWZtSWttx/yjg68AlwHGjM1NKT0XEieRCe21EXAk8DhxBvoTX1eQTp0mSJEmSVKkmFNhLyu2uwKnjrLe2n8ZSStdFxMHAZ4EPANsD64BPA+dP8qRpkiRJkiT1pfYCO6W0YgrbrAJWjbP8ZvJecUmSJEmSZkXt38GWJEmSJGkQWGBLkiRJklQBC2xJkiRJkipggS1JkiRJUgUssCVJkiRJqoAFtiRJkiRJFbDAliRJkiSpAhbYkiRJkiRVIFJKdfehVSLisXnz5u2877771t0VSZIkSVLF7rzzTp577rnHU0q7THZbC+xJioh7gfnA+pq70o+l5fauWnuhscylecykmcylmcylecykmcylmcyleZqYyQjwVEppyWQ3tMAeYBFxO0BK6a1190UvM5fmMZNmMpdmMpfmMZNmMpdmMpfmGbRM/A62JEmSJEkVsMCWJEmSJKkCFtiSJEmSJFXAAluSJEmSpApYYEuSJEmSVAHPIi5JkiRJUgXcgy1JkiRJUgUssCVJkiRJqoAFtiRJkiRJFbDAliRJkiSpAhbYkiRJkiRVwAJbkiRJkqQKWGBLkiRJklQBC+yGiojlEbE6Ih6PiI0R8eOI+GREzJmNtiLi2Ii4NSKeiYgnI2JtRBze5+PtHRHPRkSKiMsn298ma1MuEXF8RFwXEesi4qmSyZ0RcVFE7DPZ/jZZW3KJiG0i4qiIuDgi/rfksjEi7oiIz0fEjpPtb1O1JZOy7m9FxOkRcX1EPFz+dz0w2X42QUTsERF/HxEPRsSmiFgfEedFxMKZbme2X2vapC25lPY/GxFXldeOreXv4Q1Ted5N16JcDoiIL0XEDyLil+Ux7o2Irw1aNi3K5KCIuCzya/ljEfF8yeRfIuLQqTz3JmtLLl223a5kNLuv6yklp4ZNwJHAZuAZ4GLgy8BdQAKumum2gLPK8vuBc4ELgMfKvJMmeLy5wH8DT5f1L697PIc1F2ANcCfwDeDs8hiry+NuAt5b95gOWy7A0jL/GeBbwJll/XVl/t3ArnWP6TBlUtY/ryx7AfhR+fmBusdxCuO+F/BI6f91wBnl/0AqY7bLTLUzGzm1dWpTLsD7y7KtwD3AE+X+G+oexyHP5WFgC/C98v/qLOBmXn49eXvd4zmEmZwGbACuAc4HTie/3xp9//uFusdzGHPpsv3ZHZnM2ut67aE5veoXYT7wf+QCaFnH/O2BW8ovyDEz1RawvMxfByzsmD9CfuPzPDAyzmOeWh7vEwxQgd3GXIDtezz+YaWtn9Q9rsOWC7AY+GNghzHtbAv8a2nrq3WP6zBlUpbtB7wF2Lbcb2uB/e3S95PHzD+nzF85E+3MVk5tnVqWyx7AO4D55f5aBrfAblMunwF27/LYf1HWv6Pu8RzCTHq9x1pMLiK3AIvqHtNhy2XM9ivIHxZ+HAvs4Z6A48svwSVdlh1Slt04U20Bl5b5H+2yzefLsr/u8XjLgBeBz5Vf6kEqsFubS48+PAG8UPe4mssr1h8tOFr9RmkQMpntF+KKxn3P0u97gdeMWbYj+dP/Zxnz4U4V7dT9t9PkqW25dFlvLQNYYLc9l4715wAbyzZ97UVs6jQomZRtri3bHFD3uA5rLuTifD3wnXJ/Vl/X/Q528xxSbm/osuwm8j/S5RGx3Qy1Nd42149Z5yURMY/8hul/yId8DJpW5tJNRBwI7ATc0c/6DTcwuZA/nIJ8KFSbDVImbTL6nP49pbS1c0FK6Wny4aSvBX5nBtoxp97alsuwGJRcEi+/ZmzpY/0mG4hMImI34LfJe13vnmj9FmhrLucDC4ETJujXjLDAbp7Rk0/9dOyClNJm8ic/c8mfBFXaVkTsQD605ZmU0kNd2vtZud27y7IzSjvHlrYHTVtzISKOjojTIuLMiLgW+C7wOHBSH31tutbm0sXx5bbbC0mbDFImbdJzrIp+n/tU2jGn3lqTy5AZlFw+SN779/2U0q/6WL/JWplJRCwr77G+GBGryN8P3g34VErp0Qn62gatyyUijgKOBT6dUrpvgn7NiLl1PKjGtaDcPtlj+ej8nWagrSk9djlb4snAn6eUftJHv9qodbl0OBr4UMf9nwG/n1K6bdxetkObc3lJRBwBfAx4APjSROs33EBk0kJVPfeptGNOvbUpl2HS+lwiYgnwVfIe7D8db92WaGsmy4C/6rj/NPmrL5eN28v2aFUuEfF64O+A61NKF0/QpxnjHuwZUE45nyYxTeZSVlFuUxVdnWJbL60fETsBXyefOfzsCvo0Y4Ypl1fMTOmYlFKQ/1EdQP7E7+aIOG7KPazQsObyUqMRy4EryN89+kBK6Ykp9K1Sw57JgKpq3KfSjjn11sZchkGjcymHIV8PvA44JaV0y9S61yqNzCSltLK8x5oHvIn8nvjSiFg5rV62R9NyuQjYBjhxmv2ZFvdgz4x7yGdA7deDHT+PfhqzoNuK5C/td643nsm2NdH63T5JOgfYFTgspdT07/8MUy6vklJ6CrglIt4H3AZcGBH/kVKq+3q/Q5tLRLyd/CZpK/myabf20c/ZMLSZtFhV4z6VdsyptzblMkxam0sprteQD589JaX0txP0sS1amwlASul58qVRTynfCf5YeY919QT9bbrW5BIRHwHeR/666oYJ+jOjLLBnQEppOheYv5t8uMnewO2dCyJiLrCEfDjQz6tuK6X0bERsABZHxKIu3417Y7nt/C7E/uRP7e6KCLr4cER8GPhRSmm/Pvo8Y4Ysl55SSi9ExHeBN5NPJlHrP/9hzSUi3gH8G7m4fndK6ft99HFWDGsmLTd6Mp1e34Pr97lPpR1z6q01uQyZVuYSEYvI51FZCvzJABXX0NJMerie/LWvFdT8HqsCbcpl/3J7SURc0uUxFkfE6N7uhTN53gIPEW+eNeX2PV2WHUQ+w94tKaVNM9TWeNu8d8w6ANeQL/w+dlpdlt9T7l/TR3+brG25TGRxuW37CelamUtEHEJ+Ad5MPvqjMcV1BVqZyQD4z3L7roh4xWt7ROxI/nrIc8BEv2tTacecemtbLsOidblExB7AjeTi+uMDVlxDCzMZx6C8x4J25fJfdK9JRr+LvbHj/sz+35ut64E59TeRD3f4JZO72P0C8j/cRRW0NXot3nXkT3dG548Aj5EPGx3p43msYLCug92qXIBdgDf3eC6Hky8J9XRnW22c2pZLWfYu8j/5R4G31D2GZtL1OSRadh3s0u9vl76fPGb+OWX+yo5525Qx32s67dSZU1umNuXS5THXMoDXwW5bLsCvk3dYbKHLteMHZWpZJgcz5nrOZf5ewIayzWF1j+mw5TLOc5jV1/XaQ3Pq+kvwfvKnXs8AXyOfVfiu8stxFRBj1j+uLFs13bbKNmeX5fcD5wIXkIuBBJzU53NYwQAV2G3LBdivzL+dfH3y04ELyZ/uJeAF4EN1j+kQ5rIP+RPaRD5s7LRuU91jOkyZlPWXAqs6pkQ+6VznvF3rHtc+xn0v4JHS/+vK3/2acv9uYJeOdUfK/PXTaWc2c2rr1MJcOn/vHy7r/lPHvAPrHtNhy4V8ctJEPn/KaT2mkbrHdMgy+RWwHvgmcBZwHvAt8g6MBJxf93gOYy7jPAcLbKcE+VCJ1cAT5DfkdwCfAuZ0Wfc4erw5nWxbHdscC/yA/CbzafJhSYdPov8rGLACu025AAuBvwG+BzxELqifJZ+AYyWwb91jOaS5jP5djDvVPZ7DlMkkchmpe0z7HPdfI5/FdvTv/hfAV4Cdx6w3Qo83QZNpZzZzavPUplz6+Fs4ru7xHLZc+sgkASvqHs8hy+QU8nlUfkE+Km0TcB+56Ht33eM4rLmM08asFthRHlSSJEmSJE2DJzmTJEmSJKkCFtiSJEmSJFXAAluSJEmSpApYYEuSJEmSVAELbEmSJEmSKmCBLUmSJElSBSywJUmSJEmqgAW2JEmSJEkVsMCWJEmSJKkCFtiSJEmSJFXAAluSJEmSpApYYEuSJEmSVAELbEmSJEmSKmCBLUmSJElSBSywJUmSJEmqgAW2JEmSJEkVsMCWJEmSJKkC/w+Imo7E3DMmMQAAAABJRU5ErkJggg==\n", + "image/png": "iVBORw0KGgoAAAANSUhEUgAAA9gAAALfCAYAAACaWGp9AAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAACL8UlEQVR4nOzddXhUV+LG8ffEPSGE4G7BKU5xaCm1rbtQgfrWtt3tb7Xr2+5u3QuUttSoe0sFd3eH4BYgQkL8/P6YYTKwSCCT3JHv53nyzNwzM5eX3bbJm3vuOcZaKwAAAAAAUDVhTgcAAAAAACAYULABAAAAAPABCjYAAAAAAD5AwQYAAAAAwAco2AAAAAAA+AAFGwAAAAAAH6BgAwAAAADgAxRsAAAAAAB8gIINAAAAAIAPULABAAAAAPABCjYAAAAAAD5AwQYAAAAAwAco2AAAAAAA+AAFGwAAAAAAH6BgV4Ex5kpjzPPGmOnGmFxjjDXGTKiGP6eTMeYtY8w2Y0yRMWavMWaqMeZmX/9ZAAAAAIAzE+F0gAD3e0ldJB2StF1Shq//AGPMLZLGSCqQ9JWkTEkpkjpKukDSW77+MwEAAAAAp4+CXTUPyVWsN0gaJGmyL09ujOkjV7leIWmEtXb3Ma9H+vLPAwAAAACcOaaIV4G1drK1dr211lb2M8aY64wxk40xB40xhcaY1caY3xtjoo/z9iclhUu68dhy7f7zS6oQHwAAAADgQ1zBrkHGmLGSbpPrqvcnkrIl9ZH0V0nDjDHnWmtL3e9tJGmApAWSVhpjhkjqLslKWiJpsrW2vKb/DgAAAACA46Ng1xD3vdS3SfpU0g3W2sNerz0u6U+S7pX0rHu4p/txvaSfJQ0+5pTLjTGXW2s3VF9qAAAAAEBlMUW85jwgqVTSbd7l2u2vkvZLusFrLN39eLWkdpIul5QsqZWktyV1kvS1MSaqOkMDAAAAACqHK9g1wBgTJ9dq41mSHjTGHO9tRXIV6SPCvR5HWWu/ch/nGmNGut/bQ9IVkt6rjtwAAAAAgMqjYNeMWpKMpDpyTQWvjIPuxyJJ33i/YK21xpjP5SrYvUTBBgAAAADHMUW8ZuS4Hxdba83Jvrw+s9b9mHeCxcyOFPDYaksNAAAAAKg0CnYNsNYekrRSUgdjTGolP7ZMrinlacaYusd5vaP7MbPqCQEAAAAAVUXBrjlPSYqSNM4Yk3Lsi8aYWsaYbkeO3dt1veo+fNIYE+b13k6SbpFr0bSPqjEzAAAAAKCSjLXW6QwByxhzqaRL3Yf1JJ0naZOk6e6xLGvtI17vf1HSPZIOSPpe0lZJqZKaSxoo6Q1r7V1e74+T9JNce2UvljRFrvu4r5BravivrLVPVctfDgAAAABwWijYVeC1f/WJbLHWNjvmMxdJukuuxclS5CrbWyVNkjTBWrvmmPfHSfq1pGvlKuKFkuZL+q+19ltf/D0AAAAAAFVHwQYAAAAAwAe4BxsAAAAAAB+gYAMAAAAA4AMUbAAAAAAAfICCDQAAAACAD0Q4HSDQGGM2S0qSlOlwFAAAAACA7zWTlGutbX66H6Rgn76k2NjY1Hbt2qU6HQQAAAAA4FurV6/W4cOHz+izFOzTl9muXbvUhQsXOp0DAAAAAOBj3bt316JFizLP5LPcgw0AAAAAgA9QsAEAAAAA8AEKNgAAAAAAPkDBBgAAAADAByjYAAAAAAD4AAUbAAAAAAAfoGADAAAAAOADFGwAAAAAAHyAgg0AAAAAgA9QsAEAAAAA8AEKNgAAAAAAPkDBBgAAAADAByjYAAAAAAD4AAUbAAAAAAAfoGADAAAAAOADFGwAAAAAAHzALwq2Maa2MWaUMeZTY8wGY8xhY0yOMWaGMeZ2Y8xp5TTGNDLGjDPG7DTGFBljMo0xzxhjalXX3wEAAAAAENoinA7gdpWklyXtkjRZ0lZJdSVdLmmMpPONMVdZa+2pTmSMaSlplqR0SZ9LWiOpl6QHJI0wxvSz1u6vlr8FAAAAACBk+UvBXifpF5K+ttaWHxk0xvxW0jxJV8hVtj+uxLlekqtc32+tfd7rXE9JekjS3yXd5bvoAAAAAAD4yRRxa+3P1tovvcu1e3y3pFfch4NPdR5jTAtJwyVlSnrxmJf/JClf0k3GmPiqZgYAAAAAwJtfFOxTKHE/llbivUPdj5OOU9bzJM2UFCepj+/iAQAAAADg5wXbGBMh6Wb34XeV+Ehb9+O6E7y+3v3Ypiq5AAAAAAA4lr/cg30i/5LUUdI31trvK/H+ZPdjzglePzKecqoTGWMWnuCljErkAAAAAACEGL+9gm2MuV/Sr+RaBfwmX53W/XjK1cgBAAAAADgdfnkF2xhzr6RnJa2SNMxae6CSHz1yhTr5BK8nHfO+E7LWdj9BtoWSulUyDwAAAAAgRPjdFWxjzIOSXpC0QtIQ90rilbXW/Xiie6xbux9PdI82AAAAAABnxK+uYBtjfiPXfddLJJ1rrc06zVNMdj8ON8aEHbOndqKkfpIOS5rjg7gAAAAhKbewRDPXZ2nZjhzVjo9SyzoJalEnXo1qxSk8zJz6BAAQpPymYBtj/iDpL5IWShp+smnhxphISS0llVhrNx4Zt9ZuNMZMkmsv7HslPe/1sT9Lipf0qrU2vxr+CgAAAEHJWqt1ew5pytq9mrx2rxZkHlRp+f8uaRMVEaZmtePUsk6C2tRNVLemtdS1cYqSYyMdSA0ANc8vCrYxZqRc5bpM0nRJ9xvzP7/9zLTWjnc/byhptaQtkpod8757JM2S9JwxZpj7fb0lDZFravjvfP83AAAACD45h0v04uQN+mrpTu3MKTzl+4tLy7VuzyGt23NI365w3eVnjNSqToK6N62lbk1qqVvTWmpZJ17H+VkPAAKeXxRsSc3dj+GSHjzBe6ZKGn+qE7mvYveQq7CPkHSBpF2SnpP059NYMA0AACAkWWv1zfLdevzLldqXV3Tc93RsmKR+LdOUV1SqTfsOaeO+/OO+11pp/d5DWr/3kN6fv02SVCcxWv1bpalfqzT1b5Wmeskx1fr3AYCa4hcF21r7uKTHT+P9marYcut4r2+TdGtVcwEAAISa7QcL9MfPV+rnNXuPGk+MidDA1nU0uG0dDWpbR+mJ/1uKcwtLtGlfvjbuPaRl27O1aGu2Vu3KVdkx08n35RXp08U79OniHZKkVukJ6t8qTUMz0tW/VZrCuI8bQIDyi4INAAAAZ5WWlWv8rEw99cM6FRSXecbTE6P1h4vaa0THeooMP/kGNEkxkeraOEVdG6foiu6NJEkFxaVatj1Hi7Ye1KItBzU/86ByDpcc9bkNew9pw95DGj8rU01S43Rjnya6qntj1YqP8v1fFACqEQUbAAAgxK3bk6eHJy7Rih25njFjpBt6N9GvR2QoKebMFymLi4pQnxa11adFbUlSWbnVyp05mrEhSzPWZ2lB5kEVl3k2ftHWAwX6xzdr9J9J63Rx5wa6qW9TdW2ccsZ/PgDUJAo2AABACPt5zR798t3Fyve6at2mboL+eXkndW+a6vM/LzzMqHOjFHVulKJ7BrfS4eIyLdhyQD+t3qtPF+/wXN0uLi3Xx4u26+NF29WpYbLuHNRCF3Ssz/RxAH7NWPu/WyzgxIwxC7t169Zt4cKFTkcBAAA4Y9ZajZuZqb9/vUpHbpGOigjTA8Naa/SAFoqKOPl08OpwuLhMXy7bqbdnb9HyHTn/83rbuol68JzWOq9DPYo2gGrTvXt3LVq0aJG1tvvpfpYr2AAAACGmpKxcf/pipd6du9Uz1jAlVmNG9lC7+kmO5YqNCtfVPRrr6h6NtXRbtt6es0VfLt2polLXFPK1e/J09zuLlFEvUQ+e00bndajLdl8A/AoFGwAAIITkFJTonncXauaG/Z6xs5qk6LWbeqhOYrSDyY7WpXGKujRO0W8vaKexMzbpjZmZnsXX1uzO010TFqp9/SQ9fG4bDWuXTtEG4Bdqfu4PAAAAHJGZla/LXp55VLn+RZcGem90H78q195S46P06HkZmvGbobprUEvFRoZ7Xlu1K1ej3lqga16bo6Xbsp0LCQBuFGwAAIAQMHNDli59aaY27cv3jD18bhs9e21XxXiVVn+VGh+lx87P0PTfDNEdA1soJrLix9h5mw/okhdn6r53F2nr/gIHUwIIdRRsAACAIGat1bgZm3XzuHnKLnCt0B0dEaYXrj9L9w9rHXBTq9MSovXbC9pp+q+H6pazmynCa7Gzr5bt0rCnpugvX67SwfxiB1MCCFUUbAAAgCBVWFKmRz5cpr98tUpl7qXC0xOj9cGdfXVR5wYOp6uaOonRevwXHfTDw4N0Qad6nvGSMqtxMzdr4L8n6525W8SOOQBqEgUbAAAgCO3JLdQ1r83Rx4u2e8a6Nk7Rl7/sr66NU5wL5mPN0+L10g3d9fHdZ6t701qe8bzCUv3u0xW6edw87cg+7GBCAKGEgg0AABBkFm09qIufn3HUwl9Xdm+k9+/oo7pJMc4Fq0bdm9bSR3f11Ss3dlez2nGe8enrs3Te09P0/rytXM0GUO0o2AAAAEHkq2U7de2rc7Q3r0iSFB5m9KeL2+vfV3YOiMXMqsIYoxEd6+m7Bwdq9IDmOnJ7+aGiUj32yXKNfGO+duVwNRtA9aFgAwAABIkPF2zT/e8tVnFZuSQpJS5Sb93WS7f2ax5wi5lVRUxkuH53YXt9dFdfNU+L94xPW7dPw5+apk8Xbz/JpwHgzFGwAQAAgsDbc7bo0Y+Wyb2WmVqlJ+iLe/urX6s0Z4M5qHvTVH1z/wDd3r/ianZeUake+mCpxkzf5Gw4AEGJgg0AABDgxkzfpD98tsJz3K5+kj64o4+aeN2LHKpio8L1h4vaa+KdfY+6N/tvX6/Wi5M3OJgMQDCiYAMAAASwFydv0N++Xu057tI4Re+P7qPaCdEOpvI/PZul6qv7B6hXs1TP2L+/X6unJq1l8TMAPkPBBgAACEDWWv3n+7X69/drPWM9m9XShNt7KTku0sFk/ishOkLjb+upfq1qe8ae+3mD/vXtGko2AJ+gYAMAAASgf327Ri94TXHu16q23rytlxJjKNcnExcVobEje2pI2zqesVenbdKfv1xFyQZQZRRsAACAAPP+vK16dVrFIl1D2tbR2JE9FRcV4WCqwBETGa5Xbuqu4e3resbGz8rUbz9dofJySjaAM0fBBgAACCBLtmXrj5+v9Byf276uXr2pR9Dvce1r0RHhevGGbrqoc33P2HvzturXHy9TGSUbwBmiYAMAAASIrENFunvCQs8+1xn1EvXstV0VFcGPdGciMjxMz157li7v1tAz9tHC7Xrkw6Uqdf9vDACng/8aAwAABIDSsnL98t3F2pVTKElKionQqzd1Z1p4FYWHGf3nyi66pkdjz9ini3fooYmUbACnj4INAAAQAJ78fq1mb9ovSTJGevbas9S0drzDqYJDWJjRPy/vpBt6N/GMfbl0p+5/f7FKKNkATgMFGwAAwM99tWynXvNa1OzBYW00JCPdwUTBJyzM6G+XdtTIvk09Y98s36373l2k4lJKNoDKoWADAAD4sXV78vTrj5Z5jodlpOuXQ1s5mCh4GWP0+C866LZ+zT1j36/co3veWaii0jIHkwEIFBRsAAAAP5VbWKI7316ogmJXuWtWO05PXdNVYWHG4WTByxijP1zUTncObOEZ+3H1Xo1+a6EOFZU6mAxAIKBgAwAA+CFrrX794TJtzsqXJMVGhuvVm3ooOTbS4WTBzxijx87P0D2DW3rGpq3bp2tena09uYUOJgPg7yjYAAAAfuit2Vv03crdnuMnr+ystvUSHUwUWowxevS8tnronDaesZU7c3XZizO1dneeg8kA+DMKNgAAgJ9Zvj1Hf/96tef45r5NdXGXBg4mCk3GGD1wTms9eUVnhbun5e/MKdSVL8/SrA1ZDqcD4I8o2AAAAH4kt7BE9767SMXu7aE6NEjSby9o53Cq0HZ1z8Yad0tPxUeFS5Lyiko18o15+mTRdoeTAfA3FGwAAAA/Ya3V/328XFsPFEiSEqIj9OL13RQTGe5wMgxqU0cT7+qruknRkqSSMquHJy7Vcz+tl7XW4XQA/AUFGwAAwE9MmLtVXy/f5Tn+1xWd1Cwt3sFE8NahQbI+vaefMrzuhX/qh3X6zcfLVFLGXtkAKNgAAAB+YcWOHP31y1We4xt6N9FFnbnv2t80SInVxLv6qn+rNM/YxAXbddv4+corLHEwGQB/QMEGAABwWF5hie7zuu+6Xf0k/eGi9g6nwokkxURq3C09dUW3Rp6x6euzdPWrc9jGCwhxFGwAAAAHWWv1u09XKHO/677r+KhwvXQD9137u6iIMP3nqs56YFhrz9jqXWzjBYQ6CjYAAICDvli6U18s3ek5/sflndSc+64DgjFGD53bRk9e2VkRbOMFQBRsAAAAx+zOKdQfPlvhOb66RyNd0rWhg4lwJq7ucfxtvD5fssPhZABqGgUbAADAAdZaPfrRUuUWlkqSGtWK1R8v7uBwKpypgcfZxuuhD5boS6/ZCQCCHwUbAADAARPmbNH09a5pxMZIT13dVQnREQ6nQlUc2carTd0ESVK5lR78YIkmrdztcDIANYWCDQAAUMM2Z+Xr79+s9hzfMaCFejVPdTARfKVBSqzeG91HrdJdJbus3Oq+dxdrytq9DicDUBMo2AAAADWotKxcD09cosIS15Zcbesm6qFz2zicCr5UOyFa747qrWa14yRJxWXluvPthSx8BoQACjYAAEANenXaJi3emi1Jigw3euqaLmzJFYTSk2L0zug+apgSK0kqKi3X7W8u0PzMAw4nA1CdKNgAAAA1ZMWOHD39wzrP8YPntFGHBskOJkJ1auieLl4vKUaSdLikTLe+MV9LtmU7GwxAtaFgAwAA1IDCkjI9PHGJSsutJKlbkxTdObCFw6lQ3ZrUjtM7o3srLcG1uviholLdPHau1u7OczgZgOpAwQYAAKgBr0zdqHV7DkmSYiPD9d+ruyoinB/FQkHLOgl6Z1Rv1YqLlCTlFpbqljfmaVfOYYeTAfA1/qsOAABQzXZkH9YrUzd6jv/vggw1T4t3MBFqWtt6iXr79t6Kj3Ldb78rp1C3vjFfuYUlDicD4EsUbAAAgGr2z29We1YN79AgSTf0bupwIjihY8NkvXJTd0WEGUnSmt15uvOthSoqLXM4GQBfoWADAABUo7mb9uurZbs8x3+6uIPC3QULoWdA6zp68srOnuPZm/brkQ+Xqdx9bz6AwEbBBgAAqCZl5VZ//nKV5/jiLg3Uq3mqg4ngDy7v1kiPntfWc/zl0p3613drHEwEwFco2AAAANXkg/nbtGpXriQpJjJM/3d+hsOJ4C/uGdxSN/Zp4jl+bdomvTFzs4OJAPgCBRsAAKAa5BSU6D+T1nqO7x7USg1SYh1MBH9ijNGff9FR57av6xn7y1er9LXX7QQAAg8FGwAAoBo8+9N6HcgvliQ1TInVnYPY8xpHCw8zeu7as9StSYokyVrpoQ+WaPbG/c4GA3DGKNgAAAA+tmFvnt6anek5/u0F7RQTGe5cIPit2KhwjR3ZUy3c27YVl5XrjrcWaNXOXIeTATgTFGwAAAAfsta1sFmpe1Xo3s1TdUGneg6ngj+rFR+lN2/rpfTEaElSXlGpRr4xT9sOFDicDMDpomADAAD40E+r92r6+ixJUphxbctlDNty4eQap8bpzdt6KTEmQpK0L69IN4+bp/2HihxOBuB0ULABAAB8pKzc6h/frvYcX9erido3SHIwEQJJu/pJGnNzD0VFuH5E35yVr1vHz1d+UanDyQBUFgUbAADAR35YtVub9uVLkhKjI/Sr4W1P8QngaL1b1NZz13ZVmHvSw7LtObprwkIVl5Y7GwxApVCwAQAAfMBaq5enbvIc39i3qVLjoxxMhEA1omN9/fXSjp7j6euz9OhHS1Xuvq8fgP+iYAMAAPjAnE0HtHRbtiQpKiJMt/Zr5mgeBLYbejfVg+e09hx/vmSnHv9ypaylZAP+jIINAADgAy9P3eh5fmX3RkpPjHEwDYLBA8Na64beTTzHb83eon9/v9bBRABOxS8KtjHmSmPM88aY6caYXGOMNcZMOIPzZLo/e7yv3dWRHQAAYOXOHE1bt0+Sa+XwOwa0cDgRgoExRn+5pKMu7tLAM/bSlI16ecrGk3wKgJMinA7g9ntJXSQdkrRdUkYVzpUj6ZnjjB+qwjkBAABO6FWve6/P71hfzdLiHUyDYBIeZvTU1V1UUFSqn9bslSQ98d0aJcRE6KY+TR1OB+BY/lKwH5KrWG+QNEjS5CqcK9ta+7gvQgEAAJzK1v0F+mrZTs/xXYNaOpgGwSgyPEwv3tBNt74xX7M37Zck/fHzFUqIDtdlZzVyOB0Ab34xRdxaO9lau96yagMAAAgwr0/fpCOLO/dvlaZOjZKdDYSgFBMZrtdH9lCXximSJGulRz5cpkkruQsS8Cd+UbB9LNoYc6Mx5rfGmAeMMUOMMeFOhwIAAMEn61CRJi7Y5jnm6jWqU0J0hN68tafa1k2UJJWVW9337mLN3JDlcDIARwRjwa4n6W1Jf5frXuyfJa03xgw6nZMYYxYe70tVuz8cAAAEkTdnZaqotFyS1LFhkvq1qu1wIgS7lLgovX17LzWtHSdJKi4r1+i3Fmjx1oMOJwMgBV/BfkPSMLlKdrykTpJeldRM0rfGmC7ORQMAAMHkUFGp3pq9xXN816CWMsY4mAihIj0pRhNu7616Sa6t4AqKy3Tr+PlauzvP4WQAgqpgW2v/bK392Vq7x1pbYK1dYa29S9JTkmIlPX4a5+p+vC9Ja6opPgAACCDvz9uqnMMlkqSmteN0fsf6DidCKGmcGqcJo3qpVlykJCm7oEQ3jZ2rbQcKHE4GhLagKtgn8Yr7caCjKQAAQFAoLi3XmOmbPcd3DGyh8DCuXqNmtUpP1Ju39VJ8lGu5ob15RbphzFztzS10OBkQukKlYO91P7IpJQAAqLJvV+zSbneJSUuI1hXd2CoJzujcKEVjRvZUVITrx/qtBwp087h5yi4odjgZEJpCpWD3dT9ucjQFAAAICt4rh9/ct6liItmwBM7p27K2Xry+m2cWxZrdebp1/HwVFJc6nAwIPQFXsI0xkcaYDGNMy2PGOxhjUo/z/qaSXnAfTqiJjAAAIHhtO1CgmRv2S5LCjHRVD65ew3nntq+r/1zV2XO8eGu27nx7oYpKyxxMBYSeCKcDSJIx5lJJl7oP67kf+xpjxrufZ1lrH3E/byhptaQtcq0OfsRVkh4zxkyWtFlSnqSWki6UFCPpG0n/qZa/AAAACBkfel29HtimjuonxzqYBqhw2VmNlFNQose/XCVJmr4+Sw+8t0QvXH+WIsID7roaEJD8omBL6ipp5DFjLdxfkqtMP6KTmyypraSz5JoSHi8pW9IMufbFfttaa30TFwAAhKKycquPFm73HF/To7GDaYD/dUu/5so5XKqnf1wnSfpu5W795uPl+veVnRXGQnxAtfOLgm2tfVyV3ELLWpsp6X/+62CtnSppqi9zAQAAeJuxIUs7c1yLm6XGR2lYu7oOJwL+1/3DWim3sERjZ7hWuv940XYlxkToTxe3Z692oJoxVwQAAKCSJs6vmB5+2VkNPSs3A/7EGKPfX9juqBkW42dl6qkf1jmYCggNfFcAAACohAP5xZq0arfn+JqeTA+H/zLG6B+Xd9KFnet7xp7/eYNem7bRwVRA8KNgAwAAVMJni3eopMy1nEvXxilqUzfR4UTAyYWHGT19dVcNblvHM/aPb9bo3blbHUwFBDcKNgAAwClYa4/a+/pqFjdDgIiKCNPLN3RXr+YVu9n+7rPl+nLpTgdTAcGLgg0AAHAKy7bnaM3uPElSbGS4Lu5S/xSfAPxHbFS4xo7soU4NkyVJ1koPT1yiaev2OZwMCD4UbAAAgFP4wOvq9QWd6isxJtLBNMDpS4yJ1Ju39VKr9ARJUkmZ1V0TFmrJtmxngwFBhoINAABwEoeLy/TlkorptCxuhkCVGh+lt27rpQbJMZKkguIy3frGPG3Ym+dwMiB4ULABAABO4tsVu5RXVCpJap4Wr57NajmcCDhzDVJi9dbtvVUrzjUL42BBiW4aO087sw87nAwIDhRsAACAk/jAa+/rq3o0kjHGwTRA1bVKT9Abt/ZSXFS4JGlXTqFuGjtXB/OLHU4GBD4KNgAAwAlkZuVr7uYDklxbHl3ZrZHDiQDf6No4Ra/e1F2R4a5fGG3cl69bxs9Xvnu2BoAzQ8EGAAA4gQ8XVly9HtK2jtKTYhxMA/jWgNZ19PQ1XXVkUsbSbdm6a8JCFZeWOxsMCGAUbAAAgOMoL7f6ZNEOz/FV7H2NIHRR5wb6yy86eI6nr8/Sbz5epvJy62AqIHBRsAEAAI5jzqb92pVTKMm1+vLQjHSHEwHV46a+zfTAsNae408X79AT369xMBEQuCjYAAAAx/HJ4oqr1xd3rq/IcH5sQvB68JzWuq5XE8/xq1M3aeyMzQ4mAgIT3ykAAACOcbi4TN+t2O05vozFzRDkjDH66yUddG77up6xv361Sl8s3XmSTwE4FgUbAADgGD+s3qND7tWUW6TFq0ujZIcTAdUvIjxMz193lro3rdjr/VcTl2jWhiwHUwGBhYINAABwjE8Xbfc8v/Sshux9jZARExmusSN7qFV6giSppMzqjrcXauXOHIeTAYGBgg0AAOBlX16Rpq2vuGJ32VkNHUwD1LyUuCi9eVsv1U2KliQdKirVLW/M17YDBQ4nA/wfBRsAAMDLl0t3qsy9RVHPZrXUODXO4URAzWuYEqs3b+ulxJgISa5fPN08bp72HypyOBng3yjYAAAAXj71Wj38srNY3AyhK6Neksbc3ENREa7KsDkrX7eNn6989/oEAP4XBRsAAMBtw948Ld/hutc0KjxMF3aq73AiwFm9W9TWc9d2VZh7GYKl23N09zuLVFxa7mwwwE9RsAEAANy8r14Pa5eu5LhIB9MA/mFEx/r6yyUdPcfT1u3Tbz5epnL3rRQAKlCwAQAAJJWXW322uGLP30tZ3AzwuLFPUz0wrLXn+NPFO/Sv79Y4mAjwTxRsAAAASfMyD2hH9mFJUkpcpIa0TXc4EeBfHjynta7r1cRz/Nq0TRozfZODiQD/Q8EGAACQ9OmiiunhF3Wu71nYCYCLMUZ/u7Sjhrev6xn729er9ZnXrRVAqOM7BwAACHmFJWX6ZvkuzzGrhwPHFx5m9Nx1Z6lXs1TP2CMfLtXUdfscTAX4Dwo2AAAIeT+u3qM899ZDTWvHqVuTFGcDAX4sJjJcr4/sobZ1EyVJpeVWd09YqCXbsp0NBvgBCjYAAAh53tPDL+3aUMYYB9MA/i85NlJv3tZLDVNiJUkFxWW6bfx8bdp3yOFkgLMo2AAAIKQdyC8+anrrZaweDlRKveQYvXlbL9Vyb2d3IL9YN42dpz25hQ4nA5xDwQYAACHtuxW7Verez/esJilqlhbvcCIgcLRKT9C4W3oqNjJckrQj+7BGjpunnMMlDicDnEHBBgAAIc17cbOLOzdwMAkQmM5qUksv3dhNEWGuWyvW7M7T6LcWqLCkzOFkQM2jYAMAgJB1IL9Yszft9xyf36meg2mAwDWkbbqeuKKz53je5gN64P3FKi0rdzAVUPMo2AAAIGRNWrlbZe7p4d2apKh+cqzDiYDAdUX3RvrtBRme4+9X7tED7y9RCSUbIYSCDQAAQtbXXtPDL+hU38EkQHC4Y2BLjR7Q3HP89fJduuedRSoqZbo4QgMFGwAAhKSD+cWatdF7ejgFG/CF317QTrf2a+Y5/mHVHt319kLuyUZIoGADAICQ9MOqPZ7p4V0bp3j28wVQNcYY/fGi9rpzYAvP2OS1+zT6rQU6XEzJRnCjYAMAgJDkPT38Qq5eAz5ljNFj52foviGtPGPT12fptvHzVVBc6mAyoHpRsAEAQMjJLijWzA1ZnmNWDwd8zxijR85rq4fPbeMZm71pv0aOm6e8QvbJRnCiYAMAgJAzadUelbqnh3dplKxGteIcTgQEr/uHtdavR7T1HM/PPKjrX5+rfXlFDqYCqgcFGwAAhJxvWT0cqFH3DG6l31/YznO8fEeOrnh5ljKz8h1MBfgeBRsAAISUnMMlmuE1PZyCDdSMUQNa6B+XdVKYcR1vPVCgK16epaXbsh3NBfgSBRsAAISUH1btUUmZa3p450bJapzK9HCgplzfu4leubG7oiNcNWR/frGufW2OJq/d63AywDco2AAAIKR4Tw8/vyNXr4GaNrxDPb07urdS4iIlSYdLyjTqzQX6cME2h5MBVUfBBgAAISO3sETT11dMD2d7LsAZ3Zum6qO7zvbsP19WbvXoR8v04uQNstY6nA44cxRsAAAQMn5ctUfFZeWSpI4Nk9SkNtPDAae0Sk/QJ/ecrYx6iZ6xf3+/Vn/9arXKyynZCEwUbAAAEDK+YXo44FfqJsVo4l19dXbL2p6xcTM365GPlqrU/cswIJBQsAEAQEjIKyzRtHVMDwf8TVJMpN64tafO71jPM/bJoh26a8IiFZaUOZgMOH0UbAAAEBJ+Wr3XMz28ff0kNUuLdzgRgCOiI8L1wvXddG3Pxp6xH1fv0chx85RbWOJgMuD0ULABAEBI8J4efmFnrl4D/iY8zOifl3fSXYNaesbmbj6g616bo6xDRQ4mAyqPgg0AAILeoaJSTVm3z3M8wmsqKgD/YYzRY+dn6LHzMzxjK3fm6qpXZmv7wQIHkwGVQ8EGAABBb/KavSoudU0Pz6iXqJZ1EhxOBOBk7hrUUk9c0UlhxnW8OStfV78yW5v2HXI2GHAKFGwAABD0vl3B6uFAoLmmZxO9dEM3RYW7KsvOnEJd/epsrd6V63Ay4MQo2AAAIKgVFJdq8pqK6eEXdGJ6OBAoRnSsr7G39FBsZLgkKetQsa55dbYWbz3ocDLg+CjYAAAgqE1du0+H3Vv9tEpPUOu6iQ4nAnA6BrSuo7dv76XE6AhJUm5hqW4YM1ezNmad4pNAzaNgAwCAoPbtit2e5xewuBkQkHo0S9V7d/RRanyUJKmguEy3vDFfP63e43Ay4GgUbAAAELQKS8qO+gH8/E7cfw0Eqo4NkzXxzj6qlxQjSSouLdedby/UF0t3OpwMqEDBBgAAQWv6+izlF7umhzdPi1dGPaaHA4GsVXqiPryrr5qkxkmSSsutHnh/sd6anelsMMCNgg0AAILWt8u9Vw+vJ2OMg2kA+ELj1Dh9eFdftU53bbdnrfTHz1fqqUlrZa11OB1CHQUbAAAEpaLSMv3gNT38AqaHA0GjblKMJt7ZV10bp3jGnvt5g3776QqVlVOy4RwKNgAACEqzNuxXXmGpJKlxaqw6NEhyOBEAX6oVH6V3R/fW4LZ1PGPvzduqe95ZqEL3zgFATfOLgm2MudIY87wxZroxJtcYY40xE87wXI2MMeOMMTuNMUXGmExjzDPGmFq+zg0AAPzXN17Twy/oWJ/p4UAQiouK0Os399BlZzX0jH2/co9Gjpun3MISB5MhVPlFwZb0e0n3SeoqaceZnsQY01LSQkm3Spon6WlJmyQ9IGm2MaZ2lZMCAAC/V1JWrkmrKqaHj2B7LiBoRYaH6b9XddGo/s09Y3M3H9A1r87RntxCB5MhFPlLwX5IUhtJSZLursJ5XpKULul+a+2l1trHrLVD5SrabSX9vcpJAQCA35uzab9yDruuXjVIjjnqPk0AwScszOj3F7XX/52f4RlbvStXl704U2t35zmYDKHGLwq2tXaytXa9rcKyf8aYFpKGS8qU9OIxL/9JUr6km4wx8WccFAAABIRvlu/2PB/B9HAgZNw5qKX+fWVnhYe5/p3fmVOoK1+epZkbshxOhlDhFwXbR4a6HydZa8u9X7DW5kmaKSlOUp+aDgYAAGpOaVm5Jq2sKNgXdGJ6OBBKrurRWGNH9lB8VLgkKa+oVCPHzdNHC7c7nAyhIJgKdlv347oTvL7e/dimMiczxiw83pekjFN+GAAAOGZe5gHtzy+WJKUnRqtbE9Y5BULN4LbpmnhXX9VNipYklZZbPfLhUj3z4zr2yka1CqaCnex+zDnB60fGU6o/CgAAcMq3XtPDz+9YT2FhTA8HQlGHBsn69J5+yqiX6Bl75sf1evSjZSouLT/JJ4EzF0wF+1SOfHet1K+srLXdj/claU31RQQAAFVRVm71ndf08PM71XcwDQCnNUiJ1cS7+mpA6zTP2EcLt2vkuHk66J7pAvhSMBXsI1eok0/wetIx7wMAAEFm7qb92pdXJElKS4hSz2apDicC4LSkmEiNu6WnrureyDM2e9N+XfLiTK3bwwrj8K1gKthr3Y8nuse6tfvxRPdoAwCAAPfZkh2e5xd2qu9ZSRhAaIsMD9OTV3bWI8MrqsLWAwW67MWZ+nHVHgeTIdgEU8Ge7H4cbow56u9ljEmU1E/SYUlzajoYAACofoUlZUfdf33pWQ0dTAPA3xhjdN/Q1nrlxu6Kc68wnl9cptFvL9CLkzew+Bl8IuAKtjEm0hiTYYxp6T1urd0oaZKkZpLuPeZjf5YUL+kta21+jQQFAAA1avKavcorKpUkNa0dp66NU5wNBMAvjehYT5/cc7Ya1YqVJFkr/fv7tbr//SU6XFzmcDoEuginA0iSMeZSSZe6D49sVtnXGDPe/TzLWvuI+3lDSaslbZGrTHu7R9IsSc8ZY4a539db0hC5pob/zvfpAQCAP/CeHn5J14YyhunhAI4vo16Svrivv+6esFBzNx+QJH25dKcys/L18o3d1KhWnMMJEaj85Qp2V0kj3V/nucdaeI1dWZmTuK9i95A0Xq5i/StJLSU9J6mvtXa/L0MDAAD/kFNQoslr9nmOL+3awME0AAJBanyUJozqrRv7NPGMLd+Ro4ufn6Fp6/ad5JPAiflFwbbWPm6tNSf5aub13sxjx4451zZr7a3W2vrW2ihrbVNr7QPW2gM19fcBAAA165sVu1Rc5trXtnOjZLWok+BwIgCBIDI8TH+7tJP+emlHRbgXRTxYUKKRb8zT8z+tV3k592Xj9PhFwQYAAKiKzxZXTA+/tCuLmwE4PTf1aar37+ijuknRklz3Zf/3h3Ua/dYC5RSUOJwOgYSCDQAAAtrO7MOeeyjDjHRRl/oOJwIQiHo0S9WXv+yv3s1TPWM/rdmri1+YoZU7cxxMhkBCwQYAAAHti6U7Pc/7tUpTemKMg2kABLL0xBi9M6q37hjYwjO29UCBLn9plibO38ZWXjglCjYAAAhoTA8H4EsR4WH67QXt9NIN3RTv3i+7qLRcv/54me5/f4lyC5kyjhOjYAMAgIC1Zneu1uzOkyTFRIbpvI71TvEJAKicCzrV1+f39Vfr9IpFE79culMXPDtdi7YedDAZ/BkFGwAABKzPFldMDz+3fT0lREc4mAZAsGmVnqDP7+un63o19oxtP3hYV70yWy9O3qAyVhnHMSjYAAAgIJWXW32xxHt6OHtfA/C9uKgI/fPyznrx+m5KjHH9Eq+s3Orf36/VTWPnak9uocMJ4U8o2AAAICDNzzygnTmuH2xrxUVqYJs6DicCEMwu7Fxf3z4wQN2b1vKMzdq4XyOemaZJK3c7mAz+hIINAAAC0mdeV68v7FxfkeH8WAOgejWqFacP7uij+4e2kjGusYMFJbrj7YX67afLdbi4zNmAcBzfiQAAQMApKi3T18t2eY5ZPRxATYkID9PDw9vqvdF9VD+5YlvAd+du1UXPT9eKHeyZHcoo2AAAIOBMWbtPuYWlkqRGtWKPmrIJADWhT4va+vaBATrfa/eCjfvyddlLM/XatI0qZwG0kETBBgAAAeeLpRWrh1/ataHMkbmaAFCDUuKi9NIN3fTkFZ0V594zu6TM6h/frNHN4+axAFoIomADAICAkl9Uqp9W7/EcX8Lq4QAcZIzR1T0b6+v7B6hzo2TP+IwNWRrxzDT9sGrPST6NYEPBBgAAAeXH1XtUWFIuScqol6jWdRMdTgQAUvO0eH1019m6e3DLoxZAG/3WAv3hsxUqLGEBtFBAwQYAAAHlS6/p4Rd34eo1AP8RFRGm34zI0DujeqteUsUCaG/P2aJfvDBDa3bnOpgONYGCDQAAAkZ2QbGmrtvnOb64MwUbgP85u2Wavn1ggIa3r+sZW7fnkH7xwky9OStT1rIAWrCiYAMAgIDx/crdKilz/WDapXGKmtSOczgRABxfrfgovXpTd/3jsk6KiXTVruLScv3pi5W6/c0FLIAWpCjYAAAgYHivHn5x5/oOJgGAUzPG6PreTfTVL/urXf0kz/jPa/bq3Kem6pNF27maHWQo2AAAICDszSvU7I37JUnGSBcxPRxAgGiVnqhP7zlbt/Vr7hnLLSzVwxOXavRbC7SXq9lBg4INAAACwrfLd6vcfaGnV7NU1UuOOfkHAMCPxESG648Xt9e7o3urUa1Yz/iPq/fqHK5mBw0KNgAACAhfsHo4gCBwdss0ff/gQN3Up6lnrOJq9kLtzuFqdiCjYAMAAL+3/WCBFm45KEkKDzO6oBP3XwMIXPHREfrrpR2PczV7j855aqrGz9yssnKuZgciCjYAAPB7Xy/b5Xnev1WaUuOjHEwDAL5xvKvZh4pK9fiXq3TZSzO1YkeOg+lwJijYAADA7zE9HECwOnI1+/07+qhlnXjP+LLtOfrFCzP0t69WKb+o1MGEOB0UbAAA4Nc27juklTtzJUlREWEa3qGuw4kAwPf6tKitbx4YoIfPbaOoCFdNK7fSmBmbde5TU/XDqj0OJ0RlULABAIBf+2ppxfTwIW3rKCkm0sE0AFB9oiPCdf+w1vrugQE6u2Vtz/jOnEKNfmuBRr25QNsPFjiYEKdCwQYAAH7LWqsvlu7wHDM9HEAoaFEnQe+M6q2nru5y1JoTP67eo3OfmqaXp2xUSVm5gwlxIhRsAADgt1bvytPGffmSpLiocA3LYHo4gNBgjNHl3Rrpp4cH6bpejT3jh0vK9MR3a3TBs9M1d9N+BxPieCjYAADAb3kvbnZu+7qKjQp3MA0A1Lxa8VH65+Wd9fHdfZVRL9Ezvn7vIV3z2hz9auJS7csrcjAhvFGwAQCAX7LW6qtlXquHd2Z6OIDQ1b1pqr78ZX/97oJ2ivP6ZePHi7ZryH+m6LVpG1VcyrRxp1GwAQCAX1q5M1fbDx6WJCXGRGhAmzSHEwGAsyLDwzR6YAv9+PAgjehQzzN+qKhU//hmjc57Zpp+Wr1H1loHU4Y2CjYAAPBLk7y2pBmWka7oCKaHA4AkNUiJ1Ss3ddf4W3uqhdfe2Zuz8nX7mws08o352rA3z8GEoYuCDQAA/JL3nq/Dva7UAABcBrdN1/cPDtQfLmqvxJgIz/i0dfs04pnp+tPnK5R1iPuzaxIFGwAA+J1tBwq0eleuJCkqPEwD29RxOBEA+KfI8DDd3r+5pjwyWNf3biJjXOOl5VZvzt6iQU9O1nM/rVdBcamzQUMEBRsAAPgd7+nh/VrVVkJ0xEneDQConRCtf1zWSV/9sr96N0/1jOcXl+mpH9Zp0L+n6J25W9g/u5pRsAEAgN+ZtHK35znTwwGg8jo0SNb7d/TRmJt7qHV6gmd8X16RfvfpCp339DR9t2IXC6FVEwo2AADwKwfyizU/84AkyRhpWLt0hxMBQGAxxuic9nX17QMD9MQVnVQ3Kdrz2qasfN01YZEufWmWZm3IcjBlcKJgAwAAv/Lzmr0qd19Y6dakltITY5wNBAABKiI8TNf0bKIpjwzRr0e0PWohtKXbsnX9mLm6ccxcLd2W7VzIIEPBBgAAfsV7evi57es6mAQAgkNsVLjuGdxK0x4dolH9mysqoqIGztiQpUtenKm7JyzUhr2HHEwZHCjYAADAbxwuLtO09fs8x8Mp2ADgM7Xio/T7i9pryiODdW3PxgozFa99u2K3hj89VQ9PXKLMrHznQgY4CjYAAPAb09fvU2GJa4XbVukJalEn4RSfAACcrgYpsfrXFZ016aFBuqBTxUKS5Vb6ZNEODXtqqh75cClF+wxQsAEAgN/w3p6Lq9cAUL1apSfopRu664v7+mlA6zTPeFm51UcLt3uK9pb9FO3KomADAAC/UFpWrp9WexVstucCgBrRuVGK3r69tz68q6/6t/rfoj30v1P1q4lLtXEf92ifCgUbAAD4hYVbDupgQYkkKT0xWp0bJjucCABCS89mqZow6vhF++NF23XOU1N17zuLtGJHjoMp/RsFGwAA+AXv6eHntq+rMO/VdwAANeZI0Z54Z1/1a1XbM26t9PXyXbro+Rm65Y15mp95wMGU/ini1G8BAACoXtZaTVpVsT0X08MBwHm9mqfqnVF9tHDLAb04eaN+XrPX89qUtfs0Ze0+9WqWqruHtNTgNnVkDL8YpWADAADHrdmdp20HDkuSEqMj1LdF7VN8AgBQU7o3TdW4W1K1cmeOXpqyUd8s3yVrXa/NyzygeW8cULv6Sbp7cEtd0LGeIsJDd6J06P7NAQCA35i0smJ6+OCMdEVF8CMKAPibDg2S9eL13fTTw4N0dY9GivC6lWf1rlzd/95iDXtqqt6Zu0WFJWUOJnUO370AAIDjflhdMT38XLbnAgC/1qJOgp68soum/nqIbu3XTLGR4Z7Xtuwv0O8+XaEBT07WS1M2KLug2MGkNY+CDQAAHLUj+7BW7MiVJEWGGw1uW8fhRACAymiYEqs/XdxBMx8bqvuHtVZybKTntX15RXryu7Xq88+f9LtPl2vD3tDY4ouCDQAAHPWj1+rhfVumKSkm8iTvBgD4m9T4KD18bhvNemyofn9hO9VNiva8VlhSrnfmbtU5T03VLW/M0/T1+2SP3MAdhFjkDAAAOGry2opVac9pl+5gEgBAVcRHR2jUgBa6qW9Tfbl0l8bO2KzVu3I9rx9ZebxN3QTd1q+5rurRWOFBtiUjV7ABAIBjCkvKNHvjfs/xkLYUbAAIdNER4bqyeyN9c39/vTe6j85pV1feO3it23NI42dlKsi6tSSuYAMAAAfN3rRfRaXlkqSWdeLVODXO4UQAAF8xxqhvy9rq27K2MrPyNX5Wpj5csE35xWW6vX/zoNw3m4INAAAcM2VNxfRwrl4DQPBqlhavx3/RQQ+d20afLNqui7s0cDpStaBgAwAAR1hrNXntPs/xkAwKNgAEu+TYSN3ar7nTMaoN92ADAABHbMrK19YDBZKk+Khw9WhWy+FEAABUDQUbAAA4YorX1et+rdIUHRHuYBoAAKqOgg0AABwxxWt7rsHcfw0ACAIUbAAAUOPyi0o1d9MBz/HgtnUcTAMAgG/4VcE2xjQyxowzxuw0xhQZYzKNMc8YYyp9U5b7M/YEX7urMz8AAKicWRv3q7jMtT1XRr1ENUiJdTgRAABV5zeriBtjWkqaJSld0ueS1kjqJekBSSOMMf2stfsrebocSc8cZ/yQD6ICAIAqYno4ACAY+U3BlvSSXOX6fmvt80cGjTFPSXpI0t8l3VXJc2Vbax/3eUIAAFBl1tqjFjhjejgAIFj4xRRxY0wLScMlZUp68ZiX/yQpX9JNxpj4Go4GAAB8bP3eQ9qRfViSlBgdoe5N2Z4LABAc/OUK9lD34yRrbbn3C9baPGPMTLkKeB9JP1XifNHGmBslNZGrnC+TNM1aW+bDzAAA4AxMXlMxPXxAmzRFhvvF7/sBAKgyfynYbd2P607w+nq5CnYbVa5g15P09jFjm40xt1prp55ZRAAA4AtHTw/n/msAQPDwl4Kd7H7MOcHrR8ZTKnGuNyRNl7RSUp6kFpLuk3SHpG+NMX2ttUtPdRJjzMITvJRRiQwAAOA48gpLND/Ta3uuNtx/DQAIHv5SsE/FuB/tqd5orf3zMUMrJN1ljDkk6VeSHpd0mU/TAQCASpm5IUul5a5v5x0aJCk9KcbhRAAA+I6/FOwjV6iTT/B60jHvOxOvyFWwB1bmzdba7scbd1/Z7laFHAAAhKzJayqmhw9hejgAIMj4y6oia92PbU7wemv344nu0a6MIyuqsBI5AAAOsNZqyrqKBc6GZDA9HAAQXPylYE92Pw43xhyVyRiTKKmfpMOS5lThz+jrftxUhXMAAIAztHpXnvbkFkmSUuIi1bUx23MBAIKLXxRsa+1GSZMkNZN07zEv/1muq85vWWvzJckYE2mMyTDGtPR+ozGmgzEm9djzG2OaSnrBfTjBx/EBAEAlTF5bcfV6YOs6Cg8zJ3k3AACBx1/uwZakeyTNkvScMWaYpNWSeksaItfU8N95vbeh+/UtcpXyI66S9JgxZrKkzXKtIt5S0oWSYiR9I+k/1fq3AAAAxzXFq2APbsv0cABA8PGbgm2t3WiM6SHpL5JGSLpA0i5Jz0n6s7X2wMk+7zZZrj21z5JrSni8pGxJM+TaF/tta+0pVyIHAAC+lVNQokVbsyVJxkgD2Z4LABCE/KZgS5K1dpukWyvxvkxVbN3lPT5V0lTfJwMAAFUxfcM+lbm35+rcKEVpCdEOJwIAwPf84h5sAAAQ3I7enour1wCA4ETBBgAA1aq83Gqq9/Zc7H8NAAhSFGwAAFCtVuzMUdahYklS7fgodWqY7HAiAACqBwUbAABUK+/p4YPa1lEY23MBAIIUBRsAAFSryUdtz8X0cABA8KJgAwCAarP/UJGWbs+WJIUZaWDrNGcDAQBQjSjYAACg2kxbv0/WtTuXujWppZS4KGcDAQBQjSjYAACg2hy1PVcG08MBAMGNgg0AAKpFWbnVtPUVBXsw+18DAIIcBRsAAFSLJduylV1QIklKT4xW+/pJDicCAKB6UbABAEC1mOK1eviQtukyhu25AADBjYINAACqhff2XEMymB4OAAh+FGwAAOBze3MLtWJHriQpIsyoXyu25wIABD8KNgAA8Lkp6yoWN+vZLFWJMZEOpgEAoGZQsAEAgM9533/N6uEAgFBBwQYAAD5VUlau6euyPMfsfw0ACBUUbAAA4FMLtxxUXlGpJKlhSqxapyc4nAgAgJpBwQYAAD41+Zjp4WzPBQAIFRRsAADgU1PWVCxwNqQt08MBAKGDgg0AAHxmZ/Zhrd2TJ0mKCg/T2a1qO5wIAICaQ8EGAAA+M2VtxdXr3i1SFRcV4WAaAABqFgUbAAD4zM9rKu6/Zno4ACDUULABAIBPFJWWaeYGtucCAIQuCjYAAPCJeZsP6HBJmSSpWe04NU+LdzgRAAA1i4INAAB8YrLX6uGDmR4OAAhBFGwAAOATU7z2v2Z6OAAgFFGwAQBAlWVm5WtTVr4kKSYyTL2bpzqcCACAmkfBBgAAVeZ99bpfyzTFRIY7mAYAAGdQsAEAQJVN9tr/ejDTwwEAIYqCDQAAquRwcZlmb9rvOR7cpo6DaQAAcA4FGwAAVMnsTVkqLi2XJLVOT1Dj1DiHEwEA4AwKNgAAqBLv7blYPRwAEMoo2AAA4IxZazXZa4GzwW2ZHg4ACF0UbAAAcMY27juk7QcPS5ISoiPUoynbcwEAQhcFGwAAnLGf11Rcve7fKk1REfxoAQAIXXwXBAAAZ8z7/uuh3H8NAAhxFGwAAHBG8gpLND/zgOd4EPdfAwBCHAUbAACckZkbslRabiVJHRokqW5SjMOJAABwFgUbAACckaO252rL9HAAACjYAADgtB27PdeQDKaHAwBAwQYAAKdt1a5c7c0rkiSlxEWqa+NaDicCAMB5FGwAAHDapqytmB4+sHUdhYcZB9MAAOAfKNgAAOC0/bR6j+c508MBAHChYAMAgNOyN69Qi7dlS5LCjDSoDQucAQAgUbABAMBp+mn1XlnX7lzq2SxVqfFRzgYCAMBPULABAMBpmbRyt+f58A71HEwCAIB/oWADAIBKO1RUqpkb9nuOh7ev62AaAAD8CwUbAABU2tS1+1RcVi5Jalc/SY1T4xxOBACA/6BgAwCASpu0ymt6OFevAQA4CgUbAABUSnFpuX5es9dzPLwDBRsAAG8UbAAAUClzN+9XXmGpJKlhSqza109yOBEAAP6Fgg0AACpl0so9nufDO9SVMcbBNAAA+B8KNgAAOKXycqsfVnkV7PZszwUAwLEo2AAA4JSW78jR7txCSVJKXKR6NqvlcCIAAPwPBRsAAJyS9+rhwzLqKiKcHyEAADgW3x0BAMApHXv/NQAA+F8UbAAAcFKb9h3S+r2HJEkxkWEa2LqOw4kAAPBPFGwAAHBS3oubDWhdR7FR4Q6mAQDAf1GwAQDASU06avVwpocDAHAiFGwAAHBCe/MKtWjrQUlSmJGGtaNgAwBwIhRsAABwQj+t3itrXc97NktVanyUs4EAAPBjflWwjTGNjDHjjDE7jTFFxphMY8wzxpjT2mzTV+cBACDUTVpZsT3X8A71HEwCAID/i3A6wBHGmJaSZklKl/S5pDWSekl6QNIIY0w/a+3+mjoPAACh7lBRqWZuqPiWyf3XAACcnD9dwX5JrlJ8v7X2UmvtY9baoZKeltRW0t9r+DwAAIS0aev2qbisXJKUUS9RjVPjHE4EAIB/84uCbYxpIWm4pExJLx7z8p8k5Uu6yRgTXxPnAQAAR08PP4/p4QAAnJJfFGxJQ92Pk6y15d4vWGvzJM2UFCepTw2dBwCAkFZSVq6f1+z1HJ/L9HAAAE7JXwp2W/fjuhO8vt792KaGziNjzMLjfUnKONVnAQAIdPM2H1BuYakkqWFKrDo0SHI4EQAA/s9fCnay+zHnBK8fGU+pofMAABDSfli1x/P83PZ1ZYxxMA0AAIHBb1YRP4Uj39VtTZ3HWtv9uCdwXcXuVsUcAAD4LWvtUfdfMz0cAIDK8Zcr2EeuLCef4PWkY95X3ecBACBkrdyZq505hZKkpJgI9Wqe6nAiAAACg78U7LXuxxPdG93a/Xiie6t9fR4AAEKW9/TwoRnpigz3lx8XAADwb/7yHXOy+3G4MeaoTMaYREn9JB2WNKeGzgMAQMiadNT912zPBQBAZflFwbbWbpQ0SVIzSfce8/KfJcVLestamy9JxphIY0yGMaZlVc4DAACOtu1AgVbvypUkRYWHaVDbOg4nAgAgcPjTImf3SJol6TljzDBJqyX1ljRErindv/N6b0P361vkKtNneh4AAODFe3r42a1qKyHan35UAADAv/nFFWzJc/W5h6TxchXiX0lqKek5SX2ttftr8jwAAISiY7fnAgAAledXv5a21m6TdGsl3pepii23zvg8AACgQnZBseZlHvAcn9uOgg0AwOnwmyvYAADAWT+v2auycitJ6to4RelJMQ4nAgAgsFCwAQCApKOnhw/vwNVrAABOFwUbAACosKRMU9ft8xwP5/5rAABOGwUbAABo1sYsFRSXSZKap8WrZZ0EhxMBABB4KNgAAECTVnpND29fV8accC1RAABwAhRsAABCXHm51Y+r93qO2Z4LAIAzQ8EGACDELd6WraxDRZKktIQondWklsOJAAAITBRsAABCnPfq4cMy6io8jOnhAACcCQo2AAAhbuaGLM/zYe3SHUwCAEBgo2ADABDCcg6XaOXOHElSmJF6t6jtcCIAAAIXBRsAgBC2IPOAyq3reYcGyUqOjXQ2EAAAAYyCDQBACJuzab/neZ8WqQ4mAQAg8FGwAQAIYbO9CnbflkwPBwCgKijYAACEKNf917mSXPdf92jGFWwAAKqCgg0AQIiav/mArPv+644Nk5UUw/3XAABUBQUbAIAQNfuo+6+ZHg4AQFVRsAEACFHeC5z1pWADAFBlFGwAAEJQTkGJVu3yvv+6lsOJAAAIfBRsAABC0LzMivuvOzVMViL3XwMAUGUUbAAAQtDsjV73X7M9FwAAPkHBBgAgBM1hgTMAAHyOgg0AQIjJLijW6t2u+6/Dw4x6NOX+awAAfIGCDQBAiJl7zP7X3H8NAIBvULABAAgxbM8FAED1oGADABBi5mw64Hnep0Wqg0kAAAguFGwAAEJIdkGx1njff92Mgg0AgK9QsAEACCFzNlXcf925UbISoiOcDQQAQBChYAMAEELYngsAgOpDwQYAIIRQsAEAqD4UbAAAQsSB/GKt2Z0nSYpg/2sAAHyOgg0AQIiYt7ni6nXnRsmK5/5rAAB8ioINAECIOHp7LqaHAwDgaxRsAABCBPdfAwBQvSjYAACEgP+5/7oZ918DAOBrFGwAAELAsfdfx0Vx/zUAAL5GwQYAIAR433/dm+nhAABUCwo2AAAhYO5mr4LdPNXBJAAABC8KNgAAQS6noERrdudKksLDjHo0o2ADAFAdKNgAAAS5eZkHZK3reccGSUpg/2sAAKoFBRsAgCA312t7Lu6/BgCg+lCwAQAIctx/DQBAzaBgAwAQxHILS7RyZ44kyRhx/zUAANWIgg0AQBBbmHlQ5e77r9vXT1JybKSzgQAACGIUbAAAgticzV73Xzfn/msAAKoTBRsAgCA2d5PX/dctmB4OAEB1omADABCk8otKtXxHjue4F/dfAwBQrSjYAAAEqYVbDqrMfQN2Rr1E1YqPcjgRAADBjYINAECQmnvU/ddcvQYAoLpRsAEACFJH33/NAmcAAFQ3CjYAAEHocHGZlm7P9hz34go2AADVjoINAEAQWrz1oErKXPdft0pPUFpCtMOJAAAIfhRsAACC0JzNXtPDuXoNAECNoGADABCE5m7yWuCM+68BAKgRFGwAAIJMYUmZFm/L9hz34Qo2AAA1goINAECQWbotW8Wl5ZKk5mnxSk+KcTgRAAChgYINAECQmcv91wAAOIKCDQBAkJm72fv+awo2AAA1hYINAEAQKS4t18ItBz3HvZuzwBkAADWFgg0AQBBZviNbhSWu+68bp8aqQUqsw4kAAAgdFGwAAILInE3e919z9RoAgJrkNwXbGHO2MeYbY8wBY0yBMWaZMeZBY0z4aZyjmTHGnuTr/er8OwAA4LSpa/d5nvdl/2sAAGpUhNMBJMkYc4mkjyUVSvpA0gFJF0t6WlI/SVed5imXSvrsOOMrzjwlAAD+LedwiRZurbj/elDbOg6mAQAg9DhesI0xSZJel1QmabC1doF7/A+SfpZ0pTHmWmvt6Vx9XmKtfdznYQEA8GMz1meprNxKkro0SlZaQrTDiQAACC3+MEX8Skl1JL1/pFxLkrW2UNLv3Yd3OxEMAIBAMnntXs/zwW3THUwCAEBocvwKtqSh7sfvjvPaNEkFks42xkRba4sqec4Gxpg7JdWWtF/SbGvtsqpHBQDAP5WXW03xuv96MNPDAQCocf5QsNu6H9cd+4K1ttQYs1lSB0ktJK2u5DnPdX95GGOmSBpprd1amRMYYxae4KWMSmYAAKDGrNqVq6xDrt9Dp8ZHqXOjFGcDAQAQgvxhiniy+zHnBK8fGU+pxLkKJP1VUndJtdxfgyRNljRY0k/GmPgzDQoAgL+avKZievigNnUUHmYcTAMAQGjyyRVsY0ympKan8ZF3rLU3Vvb07kd7qjdaa/dK+uMxw9OMMcMlzZDUW9IoSc9W4lzdjxvGdWW726k+DwBATTr6/mumhwMA4ARfTRHfKNcWW5W10+v5kSvUycd7o6SkY9532txTzcfIVbAHqhIFGwCAQHEwv1iLt2VLksKMNLA1BRsAACf4pGBba4dV4eNrJfWQ1EbSUfc9G2MiJDWXVCppUxX+DEk6svILU8QBAEFl2vp9su55Xl0bp6hWfJSzgQAACFH+cA/2z+7HEcd5baCkOEmzTmMF8RPp436salEHAMCveK8ePoTtuQAAcIw/FOyPJGVJutYY0+PIoDEmRtLf3Icve3/AGJNsjMkwxtQ/Zry3MeZ/fm1vjBkq6SH34QRfhgcAwEll5VZT13kV7AwKNgAATnF8my5rba4xZrRcRXuKMeZ9SQck/UKuLbw+kvTBMR+7TNIbkt6UdIvX+BOSOri35NruHuusir22/2CtnVUNfw0AAByxbHu2DuQXS5LSEqLVvn7SKT4BAACqi+MFW5KstZ8ZYwZJ+p2kKyTFSNog6WFJz1lrT7mCuNvbcpXvnpLOlxQpaY+kiZJesNZO93V2AACc5D09fHDbOgpjey4AABzjFwVbkqy1MyVdUMn3jpc0/jjjYyWN9WkwAAD82BSv7bm4/xoAAGf5wz3YAADgDOzLK9LS7a5dLMPDjPq3TnM4EQAAoY2CDQBAgJrmtbhZ9ya1lBwb6WAaAABAwQYAIEBN9poePjijjoNJAACARMEOOj+v2aNPFm1XcWm501EAANWotKxc09dneY65/xoAAOf5zSJnqDprrZ78bq3W7M7TE9+t0cizm+n6Xk2UEvc/W4MDAALckm3ZyjlcIkmqlxSjjHqJDicCAABcwQ4iszbu15rdeZKkPblFevK7ter7z5/1x89XaHNWvsPpAAC+dNT08LZ1ZAzbcwEA4DQKdhBpXz9JjwxvozqJ0Z6xwyVlemv2Fg397xSNfmuB5m0+oMpvKw4A8FeT13jvf830cAAA/AFTxINIrfgo3Te0tUYPbKEvl+7SmOmbPFe0rZV+WLVHP6zao25NUnTXoJY6p11dhYVxxQMAAs32gwVatStXkhQZbtSvVW2HEwEAAImCHZSiI8J1ZfdGuqJbQ83auF9jpm/S5LUVVzoWbc3WHW8vVKv0BN01qKV+0aWBoiKYzAAAgWLSyj2e52e3TFNiDNtzAQDgD2hVQcwYo36t0vTGrb3048MDdW3PxooKr/i/fMPeQ3rkw6Ua/O/JGjtjswqKSx1MCwCorO9W7vY8P69DPQeTAAAAbxTsENEqPVH/uqKzpv9miO4c2EIJ0RWTF3bmFOqvX61S/ycm6+UpG3WoiKINAP4q61CRFmQekCQZI53bvq7DiQAAwBEU7BBTNylG/3dBO818bKgePa+t0hIqtvA6kF+sJ75bo/5P/Kznf1qv3MISB5MCAI7nx1V7VO5eq7JH01pHLWwJAACcRcEOUcmxkbp3SCvN+M1Q/fXSjmqYEut5LbugRP/9YZ36/etnPfXDOmUXFDuYFADg7XumhwMA4Lco2CEuJjJcN/VpqimPDtaTV3RWk9Q4z2t5haV67qf16v/EZD01aa1yCriiDQBOyiss0cwN+z3HFGwAAPwLBRuSpMjwMF3ds7F+/tUgPXV1F7VIi/e8dqioVM/9vEH9n/xZT/+wTjmHKdoA4ITJa/epuKxcktShQZIae/1SFAAAOI+CjaNEhIfp8m6N9MPDg/TstV3VKj3B81peYame/Wm9Bjzxs577ab3yuEcbAGoU08MBAPBvFGwcV3iY0SVdG+r7Bwfq2Wu7qkWdiivauYWleuqHder/xGS9NGUD23sBQA0oLCnTlDV7PccjOlKwAQDwNxRsnNSRov3DQ4P09DVd1Kx2xXTEnMMlevK7tRr45BSNn7lZRaVlDiYFgOA2c0OW8otd/51tnhav1l4zjAAAgH+gYKNSwsOMLjurkX58eJD+c1UXNfUq2lmHivT4l6s09D9TNXH+NpW67w8EAPjOdyuOnh5ujHEwDQAAOB4KNk5LRHiYruzuKtr/vLyT6ifHeF7bkX1Yv/54mYY/PU1fLdspa62DSQEgeJSWlevH1Xs8x+d1qOtgGgAAcCIUbJyRyPAwXderiSY/Mlh/uKi9asdHeV7blJWv+95drEtfnKk5m/af5CwAgMqYl3lAB91bJdZLilGXRinOBgIAAMdFwUaVxESG6/b+zTXt10P06HltlRQT4Xlt6fYcXfvaHI16c77W78lzMCUABLZJKyuuXg/vUFdhYUwPBwDAH1Gw4RPx0RG6d0grTf/1UN01qKWiIir+0fpx9V6d98w0/d8ny7Qnt9DBlAAQeKy1R23PNYLtuQAA8FsUbPhUclykHjs/Q5MfGawrujXSkTV4yq303rxtGvzvKXr2x/U6XMyK4wBQGcu252hXjuuXkylxkerVPNXhRAAA4EQo2KgWDVNi9d+ru+irX/bXgNZpnvHDJWV6+sd1GvbfKfpiKQuhAcCpfOd19fqcdnUVEc63bgAA/BXfpVGtOjRI1tu399Zbt/VSu/pJnvGdOYW6/73FuuqV2Vq2Pdu5gADgx6y1+v6Y7bkAAID/omCjRgxsU0df/bK//nl5p6NWHF+w5aB+8cJMPfLhUu3l/mwAOMqGvYe0KStfkhQXFX7UjCAAAOB/KNioMeFhxrW116ODdcfAFooMr1gF96OF2zX0v1M1bsZmlZaVO5gSAPzHd15Xrwe3raOYyHAH0wAAgFOhYKPGJcVE6rcXtNOkhwbpnHbpnvFDRaX6y1erdPELM7VwywEHEwKAf/iW6eEAAAQUCjYc0zwtXmNG9tTbt/dSizrxnvHVu3J1xcuz9ZuPlulAfrGDCQHAOVv3F2jVrlxJUlR4mIZmpJ/iEwAAwGkUbDhuQOs6+vaBAXr0vLaKiaz4R/KDBds09L9T9N68rSovZ7VxAKHlu5W7PM8HtE5TYkykg2kAAEBlULDhF6IjwnXvkFb64aFBOrd9Xc94dkGJ/u+T5brmtdnasPeQgwkBoGZ5Tw8f0ZHp4QAABAIKNvxK49Q4vX5zD40d2UONasV6xudnHtQFz07X8z+tV3Epi6ABCG67cg5r8dZsSa4FIs9pV/fkHwAAAH6Bgg2/NKxdXf348CDdO6SlIsJcq40Xl5Xrvz+s08XPz9CirQcdTggA1cd77+u+LWqrltf2hgAAwH9RsOG3YiLD9eh5Gfryl/3VpVGyZ3ztnjxd8fIsPf7FSh0qKnUwIQBUD6aHAwAQmCjY8Hvt6ifpk3v66Q8XtVesew9Ya6XxszJ13tPTNHNDlsMJAcB3sg4VaX6ma6tCY6ThHZgeDgBAoKBgIyCEhxnd3r+5Jj00UIPa1PGM78g+rBvGzNVvP12uvMISBxMCgG/8sGqPjmyc0LNpqtITY5wNBAAAKo2CjYDSODVO42/tqWeu6aqUuIota96du1Ujnpmu6ev3OZgOAKrOe3r4eUwPBwAgoFCwEXCMMbr0rIaa9NBADffa0mtH9mHdNHae/u+TZVzNBhCQcgpKNMvrthfuvwYAILBQsBGw0hNj9OpN3fXcdWepltfV7PfmbdN5T0/TjPXcmw0gsPy4eo9K3fPDuzRKVsOU2FN8AgAA+BMKNgKaMUa/6NJAkx4apBEdKq707Mwp1I1j5+rxL1bqcHGZgwkBoPK+W+m9enh9B5MAAIAzQcFGUKiTGK2Xb+ym54+5mj1+VqYufG66FrNvNgA/l19UqmnrKtaRYHo4AACBh4KNoGGM0cVdGuj7hwZqWEa6Z3xTVr6ueHmW/jtprYpLyx1MCAAnNnntXhW5/xuVUS9RzdPiHU4EAABOFwUbQSc9MUZjRvbQk1d0VnyUa9/scis9//MGXfbSTK3dnedwQgD4X96rh3P1GgCAwETBRlAyxujqno313YMD1at5qmd85c5cXfzCDI2ZvknlRzaaBQCHFZaUafKavZ7j87n/GgCAgETBRlBrnBqn90f30e8vbKeoCNc/7sWl5frb16t149i52pl92OGEACBNX5+lAveCjC3S4tWmboLDiQAAwJmgYCPohYUZjRrQQl//sr86NEjyjM/auF/nPTNNny/Z4WA6AJC+XbHL8/y8jvVkjHEwDQAAOFMUbISM1nUT9ek9/XTvkJYKc//smldYqgfeX6JfvrdY2QXFzgYEEJJKysr102rv6eHcfw0AQKCiYCOkREWE6dHzMjTxzr5qnBrrGf9y6U6NeGa65m0+4GA6AKFofuYB5RwukSTVT45Rp4bJDicCAABnioKNkNSjWaq+fWCgrunR2DO2O7dQ1742W8/9tF5lLIAGoIZMWrnH83x4+7pMDwcAIIBRsBGyEqIj9MSVnfXaTd1VKy5Skms7r6d+WKebxs7V3txChxMCCHbWWv2wqqJgn9ue6eEAAAQyCjZC3vAO9fTNAwPUq1nFdl6zNu7X+c9O19R1+xxMBiDYrdqVqx3u3QwSYyLUu0XqKT4BAAD8GQUbkFQ/OVbvju6t+4e20pHZmfvzizVy3Dz969s1KikrdzYggKDkPT18aEa6IsP5tgwAQCDjOzngFhEepoeHt9WE23urTmK0Z/yVqRt1w5i5yjpU5GA6AMHIe3r4cKaHAwAQ8CjYwDH6tUrTN/cP0IDWaZ6xeZsP6OLnZ2jptmznggEIKtsOFGjVrlxJUlR4mAa1reNwIgAAUFUUbOA46iRG681be+mR4W08U8Z35RTqqldn68MF25wNByAo/Li64ur12a1qKyE6wsE0AADAFyjYwAmEhRndN7S1xt3SU0kxrh98i0vL9ehHy/THz1eouJT7sgGcOe/7r89tX9fBJAAAwFco2MApDGmbri/u66+2dRM9Y2/N3qIbxszR3jy28gJw+rILijUv84Dn+Nx2FGwAAIIBBRuohGZp8frknrN1Yaf6nrH5mQd18fMztIT7sgGcpp/X7FVZuZUkdW2covSkGIcTAQAAX6BgA5UUHx2hF64/S4+dn6Ew933Ze3KLdPWrs/XRwu3OhgMQUI5aPbwDV68BAAgWjhdsY0ykMeYBY8wbxpglxphiY4w1xoyqwjnPNsZ8Y4w5YIwpMMYsM8Y8aIwJ92V2hB5jjO4a1FLjb+2l5NhISa77sh/5cKke/2Il+2UDOKXCkjJNXbfPc8z2XAAABA/HC7akeEnPSLpFUj1Ju6tyMmPMJZKmSRoo6VNJL0qKkvS0pPercm7giIFt6uiL+/oddV/2+FmZunnsPB3IL3YwGQB/N2tjlgqKyyRJLdLi1So9weFEAADAV/yhYBdIukBSA2ttPUnjzvRExpgkSa9LKpM02Fp7u7X2UUldJc2WdKUx5tqqRwakprVd92WP6FBx9Wn2pv26+PkZWrkzx8FkAPzZUauHMz0cAICg4njBttYWW2u/tdbu8sHprpRUR9L71toFXn9GoaTfuw/v9sGfA0hy3Zf90g3d9PC5bTxjO7IP64qXZ+nrZb74RxpAMCkrt0ftfz2c7bkAAAgqjhdsHxvqfvzuOK9Nk+tq+dnGmOiai4RgFxZmdP+w1nr95h5KiHbtl11YUq57312k535aL2utwwkB+Isl2w4q65DrNpK0hGh1bVzL4UQAAMCXgq1gt3U/rjv2BWttqaTNkiIktajJUAgN57avq8/uPVvN0+I9Y0/9sE73v79EhSVlDiYD4C8mea0efk67dIUf2ZIAAAAEhWAr2MnuxxPdAHtkPOVUJzLGLDzel6QMH+REkGqVnqhP7zlb/VrV9ox9uXSnrnl1tvbmFjqYDIA/+GEl23MBABDMfFKwjTGZ7q21Kvs1wRd/7plEdT8yZxfVJiUuSuNv7aUb+zTxjC3dnqNfvDBTK3aw+BkQqjbsPaRNWfmSpLiocJ3dMs3hRAAAwNcifHSejZJO5/LcTh/9ucc60l6ST/B60jHvOyFrbffjjbuvYnc7/WgIJZHhYfrbpZ3Upm6i/vzlKpWVW+3OLdSVr8zS01d31fmd6jsdEUAN+25FxcKHg9rUUUxkuINpAABAdfBJwbbWDvPFeXxgraQektpIWuj9gjEmQlJzSaWSNtV8NISim/s2U/O0eN3zziLlFZaqsKRc97y7SL89v51GDWguY7j/EggV3yzf7XnOL9kAAAhOwXYP9s/uxxHHeW2gpDhJs6y1RTUXCaFuQOs6+uzefp7Fz6yV/v7Nav3x85UqLSt3OB2AmpCZla9Vu3IlSVERYRqake5wIgAAUB0CsmAbY5KNMRnGmGMvAXwkKUvStcaYHl7vj5H0N/fhyzUUE/BoWSdBn9x9tno2q9iS5+05W3Tn2wuVX1TqYDIANeHbFRVXrwe2ruPZ0g8AAAQXvyjYxpjHjDHjjTHjJV3qHr71yJgxZtQxH7lM0mpJ//QetNbmShotKVzSFGPMGGPMk5KWSOorVwH/oNr+IsBJ1IqP0tu399bFXRp4xn5as1fXvMYK40Cw+9br/usLOtVzMAkAAKhOflGw5ZrSPdL91cU9drbXWP/Knsha+5mkQZKmSbpC0i8llUh6WNK11lpWEIdjYiLD9ew1XXX34JaesRU7cnXZS7O0bk+eg8kAVJdtBwq0bLtrbc3IcKNh7dieCwCAYOUXc9SstYNP8/3jJY0/yeszJV1QpVBANQkLM/rNiAw1rhWnP3y+QmXlVjuyD+uKl2dpzM091LtF7VOfBEDA+M5renj/VmlKjo10MA0AAKhO/nIFGwg51/duojEjeyg+yrVVT15hqW4eN0+T1+x1OBkAX/rGa3o4q4cDABDcKNiAg4a0TdfEu/qqTmK0JKmotFyj31qgz5fscDgZAF/YmX1Yi7dmS5IiwoyGt2d6OAAAwYyCDTisQ4NkfXRXXzVOjZUklZZbPfjBEk2Ys8XhZACqynt6eN+WtZUSF+VgGgAAUN0o2IAfaFo7Xh/eebZapydIcu2V/fvPVuilKRscTgagKo5ePZzp4QAABDsKNuAn6iXHaOKdfdWlUbJn7Mnv1uqf364Wi98DgWdPbqEWbDkoSQozYno4AAAhgIIN+JFa8VF6Z3Qf9fVaSfzVqZv0u89WqLyckg0Eku9X7taR3431aVFbtROinQ0EAACqHQUb8DMJ0RF649aeOtfrate7c7fqt58up2QDAeSb5aweDgBAqKFgA34oJjJcL9/QTZed1dAz9v78bfrNx8so2UAAyDpUpHmbD0iSjJHO68D0cAAAQgEFG/BTEeFh+s9VXXRFt0aesQ8XbtejHy1TGSUb8GuTVu7RkX9NezZLVXpijLOBAABAjaBgA34sPMzoySs766ruFSX740Xb9eiHSynZgB/zXj38/I71HEwCAABqEgUb8HPhYUZPXNFZ1/Ro7Bn7ZPEO/WriEpWWlTuYDMDxHMwv1qyN+z3HIyjYAACEDAo2EADCwoz+eXknXderomR/tmSnHp64lJIN+JkfVu3xzDDp1iRF9ZNjHU4EAABqCgUbCBBhYUZ/v7STru/dxDP2xdKd3JMN+JmvvFYPv4DVwwEACCkUbCCAhIUZ/e2SjrqpT1PP2KeLd+i3n7CFF+APsg4VaeaGLM8x08MBAAgtFGwgwISFGf3lkg66rlfFlewPFmzTH79YIWsp2YCTvlm+yzOjpGezWmpUK87hRAAAoCZRsIEAZIzR3y/tqCu9VhefMGer/vrVako24KAvluz0PP9FlwYOJgEAAE6gYAMBKsy9urj3D/HjZm7WE9+tpWQDDth+sEALthyU5Fr9n/uvAQAIPRRsIICFhxk9dXWXo/bZfWXqRj3z43oHUwGh6culFYub9W+VptoJ0Q6mAQAATqBgAwEuIjxMz157ls5pl+4Ze/an9Xpx8gYHUwGh5/MlOzzPL+nK9HAAAEIRBRsIAlERYXrxhm4a1KaOZ+zf36/VuBmbHUwFhI51e/K0ZneeJCk6IkzDO7B6OAAAoYiCDQSJ6IhwvXpTd53dsrZn7C9frdK7c7c6mAoIDd6Lm53Trq4SoiMcTAMAAJxCwQaCSExkuF6/uYd6NK3lGfvdZ8v16eLtDqYCgpu1Vl8s9Vo9nOnhAACELAo2EGTioyM07tae6twoWZJkrfSriUv1zfJdp/gkgDOxZFu2th4okCQlxkRocNs6p/gEAAAIVhRsIAglxUTqzVt7KaNeoiSp3Er3v7dYP6/Z43AyIPh87jU9/PyO9RQdEe5gGgAA4CQKNhCkasVH6e3be6tFnXhJUmm51V0TFmnmhiyHkwHBo6zc6qtlFbNDftGloYNpAACA0yjYQBCrkxitd0f1UePUWElScWm5Rr25QHM27Xc4GRAcZm/cr6xDRZKktIRo9fVaZBAAAIQeCjYQ5Oolx+jdUX1UPzlGknS4pEy3vjFfcynZQJV57319Uef6Cg8zDqYBAABOo2ADIaBxapzeHd1H6YnRktwle/x8zdt8wOFkQOAqLCnTdyt3e44vYfVwAABCHgUbCBHN0+L13h0VJbuguEy3vDGPkg2coSlr9ymvsFSS1CQ1Tl0bpzgbCAAAOI6CDYSQlnUS9N4dfVTnmJI9P5OSDZyuL733vu7SQMYwPRwAgFBHwQZCTMs6CXpv9DEle9w8LaBkA5WWV1iiH1dXbHvH9HAAACBRsIGQ1CrdVbLTElwlO7+4TCPHzdPCLZRsoDK+WLpTRaXlkqSMeolqXTfR4UQAAMAfULCBENUqPUHv39FbaQlRko6U7PlauOWgw8kA//f+vG2e51f3aOxgEgAA4E8o2EAIa5We6L6S7SrZh4pKNXLcPC3aSskGTmTFjhwt35EjSYqKCNPl3Ro6nAgAAPgLCjYQ4lrXTdS7o/uodrxXyR47T4sp2cBxvT9/q+f5+R3rKSUuysE0AADAn1CwAaiNu2Snukt2XlGpbh47T0u2ZTsbDPAzBcWl+nxxxerh1/Zs4mAaAADgbyjYACRJbesl6t3RvVUrLlKSq2TfNHaulm3PdjYY4Ee+XrZLeUWuva+bp8WrT4tUhxMBAAB/QsEG4JFRL0nvju5TUbILS3XjmLlavj3H4WSAf3h/fsXiZtf0bMze1wAA4CgUbABHaVc/Se+M6qMUd8nOLSzVjWPnas3uXIeTAc5atyfPs8p+RJjRFd0aOZwIAAD4Gwo2gP/RvkGS3hnVW8mxrpKdc7hEN42dp8ysfIeTAc7x3ppreIe6qpMY7WAaAADgjyjYAI6rQ4NkTbi9txKiIyRJ+/KKdOPYudqdU+hwMqDmFZaU6ZPF2z3HLG4GAACOh4IN4IQ6NUrW2JE9FB3h+k/F9oOHdePYuTqQX+xwMqBmfb9yt7ILSiRJjWrFqn+rNIcTAQAAf0TBBnBSvVvU1is3dldEmGsxpw17D2nkuHnKKyxxOBlQc7ynh1/To7HCwljcDAAA/C8KNoBTGpKRrqev6aojCyYv35GjUW8uUGFJmbPBgBqQmZWv2Zv2S5LCjHRVj8YOJwIAAP6Kgg2gUi7u0kD/uKyT53ju5gO6551FKikrdzAVUP28t+YampGueskxDqYBAAD+jIINoNKu69VEv70gw3P885q9+t2ny2WtdTAVUH2KS8v10cKKgs3iZgAA4GQo2ABOyx0DW+q+Ia08xxMXbNer0zY5mAioPj+t3qOsQ65F/eomRWtw2zoOJwIAAP6Mgg3gtP1qeBtd2b2R5/iJ79bouxW7HUwEVI/xszI9z6/u0VgR4XzbBAAAJ8ZPCgBOmzFG/7isk3o1T5UkWSs9+MFiLd+e43AywHeWbsvW3M0HJEkRYUbX9WJ6OAAAODkKNoAzEhURpldv7K6mteMkSYUl5br9zfnalXPY4WSAb7zmdevDxV0aqEFKrINpAABAIKBgAzhjteKjNO6WnkqKiZAk7c0r0u3jFyi/qNThZEDVbN1foG9X7PIcjx7QwsE0AAAgUFCwAVRJyzoJeuXG7ooIc22SvWpXrh54f4nKyllZHIFr7IxNOvKP8IDWaWrfIMnZQAAAICBQsAFU2dmt0vS3Szt6jn9cvUf//Ga1g4mAM3cwv1gTF2z3HN8xkKvXAACgcijYAHzi2l5NjioiY2Zs1hszNzuYCDgzb8/ZosMlZZKkdvWT1L9VmsOJAABAoKBgA/CZ34zI0PD2dT3Hf/lqlb5dvusknwD8S2FJmd702prrjoHNZYxxLhAAAAgoFGwAPhMeZvTstWfprCYpklzbdz3wwRLNzzzgbDCgkj5ZtEP784slSQ2SY3RR5wYOJwIAAIGEgg3Ap2KjwjV2ZE81T4uXJBWXlmvUmwu0Ye8hh5MBJ1debjVmesXWXLf1b67IcL5NAgCAyuMnBwA+lxofpTdv7aW0hChJUs7hEo0cN097cwsdTgac2A+r92hTVr4kKTEmQtf2auJwIgAAEGgo2ACqRZPacRp3S0/FRoZLknZkH9at4+frEHtkw0+9Pq3i6vX1vZsoITrCwTQAACAQUbABVJvOjVL00g3dFO7eI3vlzlzdPWGhikvLHU4GHG3hloNasOWgJCky3Oi2fs0dTgQAAAIRBRtAtRqSka6/e+2RPX19lu59dxElG37ltWkbPc8v6dpQdZNiHEwDAAACleMF2xgTaYx5wBjzhjFmiTGm2BhjjTGjzuBczdyfPdHX+9XxdwBwctf2aqL7h7X2HP+wao/ueWehikrLHEwFuGzYm6dJq/Z4jr33cwcAADgd/nCDWbykZ9zP90jaLalxFc+5VNJnxxlfUcXzAjhDD53TWkUlZXrVfZ/rj6v36q63F+rlG7srxn2fNuCElyZvlLWu50Mz0tWmbqKzgQAAQMDyh4JdIOkCSUustbuMMY9L+lMVz7nEWvt4VYMB8B1jjB47P0NhYUYvT3FNx528dp/ufHuhXr2Jkg1nbNmfr8+X7vQc3zuklYNpAABAoHN8iri1ttha+621dpfTWQBUL2OMfn1eW/1yaEWJmbpun0a/tUCHi5kujpr3ytSNKit3Xb7u16q2ujet5XAiAAAQyBwv2NWkgTHmTmPMb92PnZ0OBMDFGKNfDW+rB8+puCd7+vos3f7mfEo2atTO7MP6aOF2z/F9Q1qf5N0AAACn5g9TxKvDue4vD2PMFEkjrbVbK3MCY8zCE7yUUbVoACTpwXPaKMwYPfXDOknSrI37dfub8zXulp5MF0eNeG3aJpWUua5e92haS31apDqcCAAABLpgu4JdIOmvkrpLquX+GiRpsqTBkn4yxsQ7lg7AUe4f1lqPntfWczxr437d+84ilZSxhReq1968Qr03r+L3rfcNbSVjjIOJAABAMPBJwTbGZJ5ie6xjvyb44s89lrV2r7X2j9baRdbabPfXNEnDJc2V1EpSpbb/stZ2P96XpDXVkR0IVfcOaXVUyf5pzV499MESz32xQHUYO32zitx7sXdqmKxBbeo4nAgAAAQDX00R3yip8DTev/PUb/Eda22pMWaMpN6SBkp6tib/fAAnd++QVsovKtVL7tXFv1q2S/FREfrXFZ24qgifO5hfrLfnbPEcc/UaAAD4ik8KtrV2mC/OU832uR+ZIg74oUfPa6v8olK9OdtVfD5YsE3x0RH6w0XtKD/wqTdmblaBe0G9tnUTdW67ug4nAgAAwSLY7sE+mT7ux02OpgBwXMYY/eniDrqyeyPP2LiZm/X0j+sdTIVgk1tYojdmZXqO7x3aSmFh/AIHAAD4RkAWbGNMsjEmwxhT/5jx3saYqOO8f6ikh9yH1XL/N4CqCwsz+tflnXRBp3qesed+Wq/Xpm10MBWCyduztyivsFSS1DwtXhd2qn+KTwAAAFSeX2zTZYx5TBXbX3V1P95qjOnvfj7DWjvG6yOXSXpD0puSbvEaf0JSB/eWXEc2N+0saaj7+R+stbN8Gh6AT0WEh+mZa85SQfECTVnrurPjH9+sUWp89FFXt4HTVVBcqjHTKyYx3TO4pcK5eg0AAHzILwq2pBFybafl7Wz31xFjdGpvy1W+e0o6X1KkpD2SJkp6wVo7vepRAVS3qIgwvXJjd40cN09zNx+QJD328TI1SI7R2a3SHE6HQPX27C06WFAiSWqYEqtLz2rocCIAABBs/GKKuLV2sLXWnOTrlmPeP/4E42OttRdZa5tZaxOstdHW2ibW2mso10BgiYkM15iRPZRRL1GSVFpudeeEhVq/J8/hZAhEOYdLPKvUS9Ldg1sqMtwvvgUCAIAgwk8XAPxWYkykxt3SU+mJ0ZKkvMJS3fLGfO3NO51dAQHp9WmblHPYdfW6SWqcru7R2OFEAAAgGFGwAfi1BimxGndLT8VFhUuSdmQf1qg3F6iguNThZAgUe/MKNXbGZs/xr4a3UVQE3/4AAIDv8RMGAL/XsWGyXry+m46sR7Vse47uf2+Jysqts8EQEF74eYMOl7j2vc6ol6iLOzdwOBEAAAhWFGwAAWFIRrr+cklHz/GPq/for1+tcjARAsHW/QV6b95Wz/GvR7Rl32sAAFBtKNgAAsaNfZrqzoEtPMfjZ2Xq9WmbTvIJhLqnf1ynkjLXTIeezWppSNt0hxMBAIBgRsEGEFB+MyJDF3aq7zn++zer9b7XFUrgiNW7cvXZkh2e41+PyJAxXL0GAADVh4INIKCEhRn99+ou6tmslmfs/z5dri+W7nQwFfzRf75fK+u+TX9YRrp6Nkt1NhAAAAh6FGwAAScmMlxjb+mpTg2TJUnWSg9/sEQ/rtrjcDL4iwWZB/TTmr2SJGOkR85r63AiAAAQCijYAAJSUkyk3rytl1qnJ0iSSsut7nl3kWZuyHI4GZxmrdUT363xHF/SpYHa1U9yMBEAAAgVFGwAASs1PkrvjOqtprXjJEnFpeUa/dYCLdxy0OFkcNKUtfs0P9P1z0BEmNHD53L1GgAA1AwKNoCAlp4Uowm391b95BhJUkFxmW55Y55W7sxxOBmcUFZ+9NXr63s3URP3L2AAAACqGwUbQMBrnBqnCaN6q3Z8lCQpr7BUN42dp7W78xxOhpo2ccE2rXH//x4bGa77hrZyOBEAAAglFGwAQaFlnQS9fXtvJcVESJIO5BfrutfnaM3uXIeToabkFpboP9+v9RzfPbil0hNjHEwEAABCDQUbQNBo3yBJb97WS4nRFSX7+tfnavUuSnYoeHHyBu3PL5YkNUiO0egBLRxOBAAAQg0FG0BQOatJLb11+9El+4YxlOxgt2V/vt6Ykek5/s35GYqNCncuEAAACEkUbABB53gl+/rX51Cyg9g/v1mj4rJySdJZTVL0iy4NHE4EAABCEQUbQFA6q0ktvT2qt6dkHywo0fWvz9GqnZTsYDN74359t3K35/iPF7WXMcbBRAAAIFRRsAEEra6NU1wlO6aiZN8whpIdTMrKrf761SrP8WVnNdRZTWo5mAgAAIQyCjaAoNa1cYom3H50yb5+zBz2yQ4SHy3cplXuqf8xkWH69Yi2DicCAAChjIINIOh1OaZkZxeU6PrX52rFDkp2IMsrLNG/v1/nOb5rUEvVT451MBEAAAh1FGwAIaFL4xS9M6pin+ycwyW6YQwlO5C9NGWjsg4VSZLqJ8fozoEtHU4EAABCHQUbQMjo3ChF74zqo+TYSEmukn3963O0fDslO9Bs3HdIY6dv9hz/ZgTbcgEAAOdRsAGElE6NkvXOqN6ekp1bWKobxszR0m3ZzgZDpeUXleruCQs923J1bcy2XAAAwD9QsAGEnI4NXSU7Ja6iZN84dq6WULL9nrVWv/l4mdbtOSRJio4I098v66iwMLblAgAAzqNgAwhJHRsm691RfVTLXbLzCkt105i5WrjlgMPJcDJjZ2zWV8t2eY7/dmlHdWiQ7GAiAACAChRsACGrfYMkveNdsotKddPYeZqzab/DyXA8czbt1z+/XeM5vqF3E13Vo7GDiQAAAI5GwQYQ0to3SNJ7d/RRWkKUJKmguEy3vDFPM9ZnOZwM3nbnFOq+dxeprNxKct13/ceL2zucCgAA4GgUbAAhL6Nekt6/o4/SE6MlSYUl5brtzfmavGavw8kgSUWlZbr7nYXKOlQsSUpLiNLLN3ZTdASrhgMAAP9CwQYASa3SEzXxzr5qkBwjSSouLdcdby/Q9yt3O5wMf/1qlRZvzZYkhYcZPX9dN9VPjnU2FAAAwHFQsAHArVlavD64s68ap7rKW0mZ1T3vLNKXS3c6nCx0fTB/qybM2eo5fmxEhvq2rO1gIgAAgBOjYAOAl8apcfrgjr5qnhYvSSort3rg/cX6aOF2h5OFno8Xbtdjnyz3HF/Yub5GDWjuYCIAAICTo2ADwDEapMTqgzv6qFV6giSp3EqPfLhUb8/OdDZYCPlwwTY98tFSWdeaZmpXP0lPXtFZxrDfNQAA8F8UbAA4jvSkGL1/Rx+1q5/kGfvD5yv18pSNDqYKDRPnb9OvP17mKdcZ9RL1zqjeio+OcDYYAADAKVCwAeAE0hKi9f7oPuraOMUz9sR3a/Sf79fKHml/8Kn35209qly3r5+k90b3UWp8lLPBAAAAKoGCDQAnkRwXqQmjeqtPi1TP2AuTN+jPX65SeTkl25fenbv1qHuuOzRI0ruje6sW5RoAAAQICjYAnEJCdITG39pLQ9rW8YyNn5Wpxz5ZpjJKtk+8M3eLfvtpRbnu1DBZ74zqrZQ4yjUAAAgcFGwAqISYyHC9elMPXdipvmds4oLtuv/9xSouLXcwWeD7bsVu/e7TFZ7jzo2SNeF2yjUAAAg8FGwAqKSoiDA9d91Zuqp7I8/Y18t26fY35yu/qNTBZIFr9a5cPTxxiee4S6NkvX17byXHRToXCgAA4AxRsAHgNISHGT1xRWfdcnYzz9j09Vm6YcxcHcwvdi5YAMo6VKRRby5QQXGZJKlp7TiNv7WXkmMp1wAAIDBRsAHgNIWFGf3p4vZ6+Nw2nrEl27J11auztSvnsIPJAkdxabnumbBIO7Jd/3slREdozM09WNAMAAAENAo2AJwBY4zuH9Zaf720o4xxjW3Ye0hXvjxbG/cdcjacn7PW6o+fr9C8zAOSJGOk5687S63rJjqcDAAAoGoo2ABQBTf1aarnrj1LkeGulr0j+7CuemW2lm3PdjaYHxs/K1Pvz9/mOX5sRIaGZKQ7mAgAAMA3KNgAUEUXd2mgsSN7KjYyXJJ0IL9Y1702Rz+t3uNwMv8zbd0+/fWrVZ7jy89qqDsGtnAwEQAAgO9QsAHABwa2qaN3RvdWinv16/ziMo16a4FenbpR1rJXtiRt2Jun+95dpCNbh5/VJEX/uLyTzJE59gAAAAGOgg0APtKtSS19eGdfNUyJlSRZK/3z2zV65MNlKiotczids6as3avLXpql3ELXdmb1kmL06o3dFeO+6g8AABAMKNgA4EOt6ybq8/v6qWezWp6xjxdt13WvzdG+vCIHkznDWqtXp27UbePnK89drmMjw/X6zT2UnhTjcDoAAADfomADgI+lJURrwqjeuqp7I8/Yoq3ZuuSFGVq5M8fBZDWrsKRMD32wRP/8do1nWnj95BhNvLOvOjVKdjYcAABANaBgA0A1iI4I15NXdtbvL2ynMPctxjtzCnXly7P13rytKisP7vuyd+W4VlP/bMlOz1iPprX0xX39KdcAACBoUbABoJoYYzRqQAuNvaWnEqMjJEmHS8r0f58s14XPTdf09fscTlg95m7ar4ufn6nlOyqu1l/Xq7HeHd1HdRKjHUwGAABQvSjYAFDNhrRN16f3nq1mteM8Y2t25+mmsfM0ctw8rduT52A631mxI0e3j5+va16bo6xDrvvNI8KM/npJB/3jsk6KiuBbDgAACG4RTgcAgFDQKj1R3zwwQK9P26xXp21UQbFrVfGp6/Zp+vp9uqZnEz10bmulJwbewl+rd+XqmR/X6fuVR+/7XSsuUi/d0F19W9Z2KBkAAEDNomADQA2Ji4rQA+e01nW9Guu/k9Zp4sJtslYqt9J787bqo4XbNDQjXZd3a6QhbdP9/orv+j15eubH9fp6+a6jxo2RLurcQL8Z0VaNasWd4NMAAADBh4INADUsPSlGT1zZWbf0a6Z/fLNa09dnSZJKyqy+X7lH36/co9T4KP2iSwNd3q2hOjVMljHG4dQVysutXpi8Qc/8uE7HrtV2fsd6evCcNmpbL9GZcAAAAA6iYAOAQ9rVT9Jbt/XSlHX79OyP67VkW7bntQP5xRo/K1PjZ2WqdXqCbu/fXJd1a6joiHDnAkvaf6hID36wxPNLgSPObV9XD57TWh0asEL4/7d379FyVuUdx78PCSSBhAQSIIJIYrgE6iUGVAwWCYiKi0tVrLQot2JrFRRbV+sNGrUuoIqoFKWiiChUJQJrtSJWgcglohIiopBgQsL9Hsj9QpLdP959YHIyc86Zk/dk3jPz/aw1azLvu/ee/c4v58x55rJfSZLUuSywJamFIoLp++3K9P12ZcFTK7jmrke4du6jPL50zYtt/vzUCj55zT1c+Mv7+eBfvpK/ecMr2GHY1v/1fefiJZxx1VyeWPbS3F4/YSfOPvoAXvPyMVt9PpIkSVUTKbX3uVjLFhFzpk6dOnXOnDmtnoqkNrVhY+KOB57lJ3Me4Wd/fILVL2zYZP+Y7bfl1GkTOXnaXozZfrsBn09KiW/fuojzb5jH+prPhH9k+iQ+/tZ9GTqk2t8VlyRJasaBBx7IXXfddVdK6cBm+1pgN8kCW9LWtHzNC/z3bx/i0lsX8fTytZvs22G7IZx48F6c/uaJ7LrjwKw+vnTVC3xi5t384t6XVggfs/22XPjXU5g+edcBuU9JkqRW2pIC24+IS1KFjRq+LX9/6CROetMEZs55hP+6ZSEPL1kNwMp1G/jWLQ9w+ezFvPfAl/Oht0xiz53LWbV76eoX+N7sxVx2+yKeX/XCi9un7DmGi0+cyh5jRpRyP5IkSe3EAluSBoHh2w7h/QfvxQmv35Of3vM437h5IfOfXA7AuvUbufI3D/HD3z3Msa/dnQ8fNol9duvfKt7Pr1rHZbct4ruzF7N8zfpN9p16yAQ+ddT+lT99mCRJUqtYYEvSIDJ0yDYcN2UPjnnN7tw47yn+8+YF3J1XH9+wMXHt3Ee5du6jTN9vFw6asDOTx49iv/Gj2GPMiIan+tqwMfHksjV8/44HuWL2Ylau2/Q733vuPILPvPMA3vGq8QN9eJIkSYNaywvsiNgHeDfwdmAfYDfgOeAO4KsppZv7MeY04LPAwcBwYAFwGXBRSmlDT30laTDYZpvgyAN2463778qvFz7LxbMWcPuCZ1/cf/P8p7l5/tMv3h41bCj7jh/F3ruMZO36DTyzYh3PrFjLMyvWsWTl2s3OZw0wcdwOfGT63hw3ZXe2dSEzSZKkXrW8wAa+ALwPuBe4HlgC7AccCxwbER9LKX29r4NFxHHAT4A1wI/yeMcAFwKHAO8tdfaS1EIRwbS9xzFt73HMfeg5vjFr4SYLknVZvnY9cx58jjkPPtfrmHvvOpIzD9+bo1+zO0O2qf+utyRJkjZXhQL7BuD8lNLc2o0R8RbgF8CXIuLqlNLjvQ0UETsClwIbgMNSSnfm7WcDNwHHR8QJKaUfln0QktRqr3vFTlx60kEsfHoFv3lgCfOfWMa8J5Yz/8nlmyxUVs+Ow4eyz26jOO2QiRz1qvFsY2EtSZLUtJYX2Cmlyxts/1VEzAKOBKZRvCvdm+OBXYAruorrPNaaiPgscCPwj4AFtqS2NWmXkUzaZeSLt1NKPLlsLfOeWMaDz65ih2FDGTtyO3YZOYyxI7dj7A7DXLhMkiSpBC0vsHvR9ZbL+h5bveTwfH1DnX23AKuAaRExLKW0tk4bSWo7EcH40cMZP3pgzpUtSZKkQmUL7IjYCziCoii+pY/d9svX93ffkVJaHxGLgL8AXgnc18v9z2mwa3If5yJJkiRJ6iCVLLAjYhhwJTAM+JeUUu+r8hRG5+ulDfZ3bR/T/9lJkiRJkrS5UgrsiFgM7NVElytTSu9vMNYQ4PsUK37/CPjyFk+wZvh8XeeENJtKKR1Yd4Dine2pJc5JkiRJktQGynoHeyHFabH66rF6G3Nx/QOKU2n9GHh/SqnXYrhG1zvUoxvs37FbO0mSJEmSSlFKgZ1SOmJLx4iIocBVFMX1VcBJKaUNTQ4zHzgI2BfY5DvUefyJFAumPbCl85UkSZIkqVYlzssSEdsBMymK6yuAD/SjuIbiXNcA76iz71Bge2C2K4hLkiRJksrW8gI7L2h2LXAc8B3g1JTSxl76jI6IyRHxsm67ZgLPACdExEE17YcD/55vfrO0yUuSJEmSlFVhFfFLgHdSFMaPAudERPc2s1JKs2puvwv4LvA94JSujSmlZRHxQYpCe1ZE/BBYAhxLcQqvmRQLp0mSJEmSVKoqFNgT8/U44Jwe2s3qy2Appesi4i3AZ4D3AMOBBcA/AV9vctE0SZIkSZL6pOUFdkrpsH70uRy4vIf9t1O8Ky5JkiRJ0lbR8u9gS5IkSZLUDiywJUmSJEkqgQW2JEmSJEklsMCWJEmSJKkEFtiSJEmSJJXAAluSJEmSpBJYYEuSJEmSVAILbEmSJEmSSmCBLUmSJElSCSywJUmSJEkqgQW2JEmSJEklsMCWJEmSJKkEFtiSJEmSJJXAAluSJEmSpBJYYEuSJEmSVAILbEmSJEmSShAppVbPYVCJiGdHjBix8/7779/qqUiSJEmSSnbfffexevXqJSmlsc32tcBuUkQsAnYEFrd4Kl0m5+t5LZ2F6jGbajKX6jKbajKX6jKbajKX6jKbaqpiLhOAZSmlic12tMAe5CJiDkBK6cBWz0WbMptqMpfqMptqMpfqMptqMpfqMptqardc/A62JEmSJEklsMCWJEmSJKkEFtiSJEmSJJXAAluSJEmSpBJYYEuSJEmSVAJXEZckSZIkqQS+gy1JkiRJUgkssCVJkiRJKoEFtiRJkiRJJbDAliRJkiSpBBbYkiRJkiSVwAJbkiRJkqQSWGBLkiRJklQCC+ytICKmRcT1EbEkIlZFxB8i4qyIGLI1xoqIkyPitxGxIiKWRsSsiDi6h/YjIuJzETE/ItZExFMR8eOI2L+Pc/xARKR8Ob3ZY9ya2j2biDg/Im6MiIcjYnWe29yI+LeIGNvsMW4t7ZxLRIyNiNMj4tqIWJBzWRoRt0XE30VEpX8vt3M2uf3xEXFRRNwaEcvy77EfNHtsAyEiXh4Rl0XEYxGxNiIWR8RXI2KngR6nillVRTvnEhFviIhzI+JnEfFE/nl4pJnjaqV2zSYito2Id0XEdyLij/l31aqIuCciPh8Ro5o5vq2tXXPJbU+LiOuieH5fFhErI+K+iLg0IvZr5vhaoZ2zqdN335xP+c/zKSUvA3gBjgPWAyuA7wBfAuYBCbh6oMcCvpz3PwxcCFwMPJu3nVGn/TDgtrz/d8D5wFXAC8BK4I29zHFP4HlgeR7j9FZn0MnZAOuAO4DLgPOAi3LfBDwK7NnqHDotF+BDue1jwJXAuTmf5/P2mUC0OodOzCb3+X1uvxy4L//7BxV47CcBT+b5XJd/nm/Kt+cBYwdqnKpmVYVLB+Ty1bxvHXB3/vcjrX7cOz0bYHLevgL4n/zzcjGwIG+fD4xrdQadlktufxPFc8eVwAX5Pq7P97sWOKrVGXRqNt36DgV+w0v1SqnP8y0Ps50vwI7AU/kH6qCa7cOB2TnQEwZqLGBa3r4A2Klm+4T8H3ANMKFbn091/WcGtqnZflze/qfa7d36BvBLYGH+wUhUtMDulGyA4Q3m/MXc5xutzqLTcgEOB46pk9V44KHc5z2tzqITs8n7pgP7UPw+O4zqFNg/z3M5s9v2r+TtlwzEOFXOqgqXDshlCvA6YLt8OzF4Cuy2zQbYA/gwsEO3cbYD/jePdVGrM+i0XLrGazDfI/NY97Y6g07Nplv/c/L9fRQL7MF1AU7LoX2vzr7D875fDdRYwBV5+6l1+nw+7/tczbYAHszbJ9bpc0veN73BHD8GbAQOBWZQ7QK7o7Kp0/61uf0vWp2FuWzS/tNU9A+jTsyGihTYwCvzPBax+QsCoyhe8V9Jtz+2yxhnsGRlLuXn0mCuiUFQYHdiNjXtuwqPe1qdg7ls1uc5YF2rc+j0bICDKD4d9VkG6Hm+0t/1awOH5+sb6uy7BVgFTIuIYQM0Vk99ftatDRQf6XgFcH9KaVEf+wAQxXfkzgO+llK6pe4RVEvHZNPAMfn6D31sv7V0ei4v5Ov1fWy/NXV6Nq3UNcf/SyltrN2RUloO3A5sDxw8AOOYVWPtnstg1snZDIbnkY7LJSLeDIwB7ulL+xboiGwiYgRFcf57irplQFhgD6yuxQzu774jpbSe4tWdoRSv9pQ6VkTsQPERohUppcfrjPfnfL1vX+6jhz5ExFDg+xQfb/10j0dRHR2RTZeI+EREzIiICyPiVuALFMX1gP1y6aeOyqVW/jk6Kd+s94TRah2bTQWUdSz9GcesGmv3XAazTs7mtHw9qJ5HsrbJJYoFM2dEsdjstcCNwBLgjAZzbrVOyea8PM7JeewBMXSgBhYAo/P10gb7u7aPGYCx+nPf/Z3vORTf0XpzSml1g75V0ynZdPkEsFvN7RuAU1JKTzdo3yqdlkut84BXAdenlH7eh/ZbWydn02plHcvWeBw7Kat2z2Uw68hsIuJY4B+AR4D/6K19C3RSLscD76u5/Wfgb1NKdzZo32ptn01EHAGcCXwypXRvg76l8B3sXuRl5VMTl2aWeY98ncqYaj/Haqb9ZvcREW+geNf6gpTSr5u87y1iNn2/j5TS+JRSUCyk9W6KV+/mRsTUJufU+0TMpen7iIiPAv9MsWLmB5qcT98nYzZl3EcVlXUs/RnHrBpr91wGs7bLJiKmUay8v5Jiocznmhy/Ctoml5TSCfnvrtHAIRTvwt4eEac0OX5VDOpsImIM8F2KlcMvaHKcpvkOdu8WUqxE11eP1fy76xWU0fUaUqyaV9uuJ82O1Vv7eq/+NHUfNR8Nvx84u0GfgWQ2je+jrpTSk8C1EXEXRW5XULxrWiZzaXwfm4mIjwBfA+4FjkgpLWnUtgRm0/g+qqysY+nPOGbVWLvnMph1VDYR8SaK751upDgN1G8btW2xjsoFIKW0DJgdEccAdwLfjIhfppSqdj75ds/mK8A44MiU0oYG/Upjgd2LlNIRW9B9PsVKdfsCc2p35OJ0IsUiFA+UPVZKaWVEPArsEREvq/MdhX3yde33Hebn60bfr+jeZ2RN2zURsXkPuDQiLqVY/OysBuP2i9n02qehlNKDEXEvMCUixqWUnulLvz6ObS4996mdx1kU5278I0Vx/VQvx7RFzKbXPlVV1rH0ZxyzaqzdcxnMOiabiPhL4KcUxfXbU0p39HJMrdQxuXSXUloXETcCr6ZY4GtmX/ptRe2ezVRgBDCvQb1yYkScCNydUprSYO595kfEB9ZN+foddfYdSrGK3uyU0toBGqunPkd1awPFu1sPAftGxMQ+9FlLcTL4epe5uc1t+fZW/fh4H7R7Nn2xe74e8FfymtAxuUTEv1IU17+nOP3QgBbXJeiYbCro5nz9tojY5Hk7IkZRfPxwNdDbH9b9GcesGmv3XAazjsgmIg6neOd6PcU7c1UurqFDcunBHvm6iiu8t3s211C/Xrk+71+Yb19T96iaVca5vrw0PBfcjsDTNHfi9NHAZOBlJYzV9EnYgU/lPldTc/464Li8/U90O69dg2OfkdtX9TzYbZ9Nnuv4Ose+DfDF3Of2VmfRabnkfWfnfXcCO7f6cTebhsd8GANwfsx+Pv4/z3M5s9v2r+Ttl9Rs2zY/7pO2ZJzBlJW5DEwudeaZGATnwe6EbIC3UZy+6Bngda1+vM0lAYwFXt3guI+mOIXa8tqxqnRp52x6OObDGIDn+ZaH2e4X4K8oXqlaAXybYlXHebz0h0R0a39K3nf5lo6V+1yQ9z9M8W7ZxRS/jBNwRp32wyjOUZeA31GsbHxV/qWwEnhjH497BhUusDshG+CsvO9G4FvAucBlFK/SJeBx4IBW59CBuZyc267P48+oczml1Tl0YjY187o8X27IfRfWbPtyix77ScCTeT7XUfw835RvzwfG1rSdkLcv3pJxqp5VFS4dkMvkmv/7l+d2K7ttG9fqHDotG4rTGq3O+2ZS/3lkRqsz6MBcpuTtcyjWuDkX+CbFpzgTsA54X6sz6MRsejjmw7DAHpwXio9DXA88R/EL8R7g48CQOm1PocEfpM2OVdPnZIo/WFZSvHL2K+DoHtqPAD5HcUqBtRSvKl1NE8UYg6DAbvdsKBYvu5jiI8jP5F9cS/P9zaDC75y2eS5dPxs9XWa1OoNOzKaP+Sxu4WO/J8UqqI9T/KH2IMUCeTt3azehp7n2dZyqZ1WVSzvnwkt/fPZ0mdDqDDotmz7mklr9+HdgLjtRfELw1po5rQTuAy4B9m/1Y9+p2fTQv+tnqdQCO/LgkiRJkiRpC7jImSRJkiRJJbDAliRJkiSpBBbYkiRJkiSVwAJbkiRJkqQSWGBLkiRJklQCC2xJkiRJkkpggS1JkiRJUgkssCVJkiRJKoEFtiRJkiRJJbDAliRJkiSpBBbYkiRJkiSVwAJbkiRJkqQSWGBLkiRJklQCC2xJkiRJkkpggS1JkiRJUgkssCVJkiRJKoEFtiRJkiRJJfh/5qcBauRHZzMAAAAASUVORK5CYII=\n", "text/plain": [ "
" ] @@ -237,9 +239,82 @@ "plt.plot(dat['z'], dat['Ez'])" ] }, + { + "cell_type": "code", + "execution_count": 7, + "id": "appreciated-pension", + "metadata": {}, + "outputs": [], + "source": [ + "# Simple parser\n", + "def parse_plane(file):\n", + " \"\"\"\n", + " \n", + " \n", + " \"\"\"\n", + " rdat = np.loadtxt(file)\n", + " columns = ['x', 'z', 'Ex', 'Ez', 'By']\n", + " pdat = {name:rdat[:,i] for i, name in enumerate(columns)}\n", + " \n", + " zvec = sorted(list(set(pdat['z'])))\n", + " xvec = sorted(list(set(pdat['x']))) \n", + " nx, nz = len(xvec), len(zvec)\n", + " dat = {}\n", + " dat['zvec'] = np.array(zvec)\n", + " dat['xvec'] = np.array(zvec) \n", + " dat['Ex'] = pdat['Ex'].reshape(nz, nx).T\n", + " dat['Ez'] = pdat['Ez'].reshape(nz, nx).T\n", + " dat['By'] = pdat['By'].reshape(nz, nx).T\n", + " return dat\n", + " \n", + "\n", + "dat = parse_plane('x_z_Ex_Ez_By.dat')" + ] + }, + { + "cell_type": "code", + "execution_count": 8, + "id": "handed-jesus", + "metadata": {}, + "outputs": [ + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAACEEAAAIqCAYAAADBmMawAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAADuxElEQVR4nOzdeZwsWVnn/+8TWXXvpRu6GxCEAWVpgZ5Bhn3tkXVskR1tBlQQ2lEGQUBsZuQnMNAqOg4ICoLbCM0ii+AIowK2QrPYPYiAA6I0S8NFVlmarRvuvVUZz++PiLr5xMmMU5FZkVW5fN6vV91czjnPOREZmflE3JMR5u4CAAAAAAAAAAAAAABYdsVBDwAAAAAAAAAAAAAAAKAPTIIAAAAAAAAAAAAAAAArgUkQAAAAAAAAAAAAAABgJTAJAgAAAAAAAAAAAAAArAQmQQAAAAAAAAAAAAAAgJXAJAgAAAAAAAAAAAAAALASmAQBAAAAAAAAAAAAAABWApMgAAAAAAAAAAAAAADASmASBAAAAAAAAAAAAAAAWAlMggAAAAAAAAAAAAAAACuBSRAAAAAAAAAAAAAAAGAlMAkCAAAAAAAAAAAAAACsBCZBAAAAAAAAAAAAAACAlcAkCAAAAAAAAAAAAGDJmNnPmJmb2QU9xnx6HfMJfcUEgP3GJAgA2Gdm9rdmtm1m33fQY+mLmRVmdpmZXWlm333Q4wEAAMDiMrPn1AdVzzvosfTJzP6wXq77H/RYAAAAsHdmdmGd36V/QzO7oj7O+wtmdrUDGt/VJD1L0rck/Xb93GNaxtzl7zF16BdJ+rqkZ5rZqQexbACwV0yCALByMsnppL+f3+exPUjS2ZJe6+6fqJ87rx7Ltpldv2OcW4ZluG9LnSfX5b/d3xJM5u6lpF+XdKqkZ867PwAAAOxuEfNiM7uepJ+XdFTSK+vnbmpmZT2O/9QxzsDMvlC3+R8tdW5dl3+wp+Hv5tclDSX9mplxvAUAAGB1bEn61/D3LUnXVHWc9zclvc/MrnMA43qSpBtIeom7X1E/951krDt/XwntvtZS5zuS5O7flPQ7kr5bVe4OAEuHnXIAqyxNTif9XbVfg6kPhP6aJJf0nFD0+nocA0k/0THcT9a3X5D01y11HlDf/sV0I53ZH0v6lKTHmtlN9qlPAAAA7G6R8uJnSTpF0m+4+7YkufsnJb27Lv/JtoaJcyRdr77/8pY6+5oP18vxGkn/XtKP7UefAAAA2BeXuvv1wt8Zks6Q9FRJpaR/J2nixNx5MbOBqkkQkvSHO8+7++uSsV7P3a8n6Y6h+Y9MquPurwt1/ld9+0Qz25jv0gBA/5gEAWCVpcnppL8/3D1Mb35I0i0l/a27f2TnSXe/UtL/rh8+arcg9WSKnckSr3L34YQ615B0d1Wzkt+5x3F3Uh/EfrmkTUk/tx99AgAAoJOFyIvN7JqSHqPqF2avSop3JjL8kJldt0O4nckSfx9z68R+TwqWRgeLf2Ef+wQAAMA+c/dvuPtvSvqj+qkH7vMQ7ifp36jKhy/vO7i7f1rS/1V1NogH7FIdABYOkyAAYP/8dH372gllOwd9/72Z3XqXOPdRdZqz2C51jqRDkv7a3U9MNcq9eU19+ygz29zHfgEAALD4HinpiKS/qCcCR6+X9G1JG9rlLApmdpqkB9cPJ+bD9emI7yTpy5L+bg9jnta7JX1O0u3M7Db72C8AAAAOxofq21Pjk2b20vrSbG/INTazC+p6l07Z73n17Z9M2W4aO7HPy9YCgAXEJAgAqJnZf6kTzmNm9v0tdf6grvMvZnbGFLGvrWo2sKs6wJu6WNJn6vu7nQJ4p/z97v5PLXXGfvVmZjfeueZz/fhOZvYmM/uymX3LzC41s/uF+ofM7BfN7MNm9m0z+1cz+30zu1bbwNz9Y5I+KOk6YoYwAADAUjKzC3fyxl3+LpwydOuBWnf/lqQ/qx/ulg8/TNLVJJ3Q5AnGUvXLuELSW9y93HnSzI7WY7+nmV3fzH7PzD5jZt8xs4+Y2VPqM6/t1H+Ymb3bzL5uZt80s79s21eol6OUtHOgm4PFAAAAq+9W9e0nkud3zhD2wPrY8BgzM0mPrh++tGuHdb567/rhJV3bzWAn9r25JAaAZcMkCACoufvvq5o0cFjSH5vZoVhuZg+Q9DOqJjI8xt2/PkX4e6m6TMTH3f3LE/ouJb2yfvjj9TXdxpjZ1SU9tH7Y9qs3k/TD9Tjf3FLnQZL+VtXEjE1JV5d0V0l/Xh/oPSLpr1Rdy+7Mutl1JT1W0t+k6yaxkxyfk6kDAACAxfUNSf+a+Ru7HNtuzOy7JN22fth2oHYnv72dmd0yE25nksRfuPtXW+rsdimMm0j6gKT/Iuk0VTnxWZKeL+m36zH/D1UTNu6q6vjJNVRNrni3md0sMz7yYQAAgBVnZqeZ2c9rdPbfF8Ryd79U0j+rOlvvT2iy+0i6kaSrJL1uiu5vJel0VXn5B6doN60Pqpp4fHVJt5ljPwDQOyZBAEDTf5b0JUn/XtKv7jxZn053Z/buC9z97VPGPbu+fX+mzs5B3+tJ+sGWOj+q6tRqWxpdeiJ1J1XXavt7d//XljqvqP+u7+5nqJrg8CZV3wsvkPQ8VQeBH6Aqyb2GqlMOf0vVweufHg950vvq2x/I1AEAAMCCcvcnu/v1Jv1J+ilJVld96xRhd/LhL7j7F1rqvE3SZ+v7j5pUwcxurFGe2TYpeFPVBIQtVRN7J3mBpE9JurW7n65qIsQz67InmNkvSfoFST8v6XR3P03VweaPSjpD0nNa4kqjfPisej8CAAAAy+1uZvbF8Pd1VROHX6BqosBPuvuFE9rtHE9uO0PYT9W3b6jPjNbVnerbT7j7t6doN5X6MssfrR/eeV79AMA8MAkCwCpLk9NJf6fFBu7+JY3+g/98M7tHff8PVE0s+LCkX5phLDuJ6YfaKtSXknhP/bDtFMA7z/+lu3+lpc5uv3qTpA+4+0/vTJKoz07xE5K+KekGkp4g6RHu/pfuPqz//o+k59btz83E3pl9/O/M7BqZegAAANgfU+fFk5jZLSS9WtWxhP/p7m2XopikSz5cSnpV/fAn4mUpgkepmoTxZUlvaQl1d1WTGt7t7t9sqVNKup+7f6ju+9vu/quS3l7Hf46kX3X333b3q+o6H1Z1ZjhJelDb2dHc/VOq8mpptNwAAABYXpuqjg3v/J0eyq4l6br12XlTr1B1JoXbmNltY4GZna7RGX87Xwqjdv36tu34cJ92+rh+thYALBgmQQBYZWlyOulv7HPQ3f9c1aSHQtIrzOwpkh6iKmF9pLsfn2EsXRPTnV+zPSSdQGBmN5R0z6TeJF0mQfyP9In64O7OJIxL3f2dE9q9rb5tvQ6yRstoqtYxAAAADtZMeXFUH6T9P6oO+L5F0v835RimzYdvqNF1jqOdM0S82t23WmJ0yYd/r+Xydn9T355QdWmM1CWSjqm6hN73ZeLvXKaDg8UAAADL753ubjt/kjYk3VTS41WdRfd5Gp314aT60m1vrB+mZ4P4cUlHVF0++V1Tjue76tuvTdluFjt9fFe2FgAsGCZBAFhljeS05e/rLW1/QdLHJX2vRgc/n+nus15jrWti+lpJxyVdTeNnW3iUqs/tr0r6y0mNzewGqq7P9jl3/4dMP//Y8vyX6tsPt5TvXF7jmpnYcRlJjnGgzOxcM3uRmb3bzL5pZm5mr9q9ZafY96zj7fb3PX30BwDAHuwlL1Z9RobXSLq5qtPh/lh91oZpdMqH3f0ySe+tHzYuiWFmd5V0s/rhKzJh7l/f5iZB7JYPH3X3KyeMr9RoIkeXnJh8GAdunjlx0s+tzOwVZvYZMztuZl8ys3eaWduZDgEAWEr1WXM/5e6/q+rsupL0U2b2HyZU35kc8ePJmcR2LoXxshmGcLi+PTFD22kdq2+vtg99AUBvNg56AACwiNz9KjP7OY2uIfweVTN6Z9UpMXX3r5vZmyT9J1WXvohJ8M5B4Nfs8VdvylyHeVjf7lae+/44Fu6THOOgPUPSrSVdqeoa42f1GPuopAtaym4l6Uck/ZO7f6bHPgEAOAj/Q9IPS/q6pAe5+zdmiDHNgdoLVV1G4kfM7PE7l6PQ6NJwH3b3D0xqWF+y42aSPuruH8/0MWs+HOtsZupwsBiLZJ45sSTJzB6j6j95vq1qf/SopDNUnUXwfspPXAIAYGm5+1+Z2RclXU/VMd2/Tar8jaRPSbqJpAdJeoOZ3VLSHVTllbkz/ra5or49Y5YxT2ln4u9Xs7UAYMEwCQIA2sVTlN1M1WmCcwdDc65QlQif0aHuy1UlzPcws+91938xsztK+rehvM0D69vsJIg5i7+IIznGQXuKqgO9n5B0D0kX9xXY3Y9KevakMjN7TX33D/rqDwCAg2BmPy7pv6o6QPsId//YjKGmOVD7WkkvUHVq4R+R9Mr6V3P/qS5f9HxY4mAxFsvccmJJMrO7qJoA8WFJ93X3LybluQlDAACsgn9Rdez3pmmBu7uZvVTSr6g63vwGSf+5Lv4rd//8DP11OTNZX3b62O2ydgCwULgcBgBMYGY/IekRkrZVnfL32pJeuoeQ0ySmfyXpi5JM0iPr53Z+9fbP7v6+SY3M7Gqqrpv8HUlvm32oexaXkeQYB8rdL3b3j7u7d21jZj9mZheb2dfM7JiZfcTMnmFmh3dvLZnZtSU9VNV78ZUzDh0AgANnZrfX6PS9v+juf5Wrv4vO+bC7f03Sn9cPd86G9kBJ11I1GeOPM807nRltH3CwGAtjH3Li/ylpIOmR6QSIuv+2MxkCALAqblDftn3nvUxVHvtDZnYjjY75znq8+aP17Y1nbD+NnT4u24e+AKA3TIIAgISZfY+k36kf/rKkh6j6z8z7mtnjZwy7k5jeZLeK7h4P7D6q/tXMI+rHuV+93UfV6Xbf7u7fmXGcfbhxffsNVZM5gKVhZn8k6dWSvk/S/5b0YlW/XP0VSW81sy5n0XqMqlN+v77+TxwAAJaOmX23pDeqyi9f6e6/uceQnfPh2k7eex8zu4FGk4Ivaru0m5mdIelsVZftSE9DvG/M7BRJ16kfcrAYS2eanNjMbijpByS9T9I/mdm9zOypZna+md3HzDj2CABYaWZ2tkaTICZess3dPyfpLaomDf6xqlzxy5L+z4zdXirJJV3TzM6cMcau6u/569UPDyy/BoBZsCMCAIGZmaprEJ8h6T2Sfs3dL5P0i3WV55rZzWcIfUl9e4eO9XcO+p6l6nT73yWplPSqTJtF+dXbHevbS9y9PNCRAFOor2P8U5L+TNLN3f0/u/v57n62pAsk3VPSEzqE+un69vfnMU4AAOatvvTEn0q6oaT3SnpsD2F38uHvN7MjHeq/VdK/qjpu8WRJP1w/n5sUfF9Vl/38K3ffnnWgPbidqgPc35L0wQMcBzC1GXLinf2/j0t6e/33XEnPU3UN9P9nZt+3P6MHAGD/mNnVzOwhknYuifpt5c/ssHOGtbPr21fNerYkd79C0kfqh3fM1d2jndgfdfcvzbEfAOgdkyAAoOkpqi4pcZWkR9VnZZCqM0P8taRTVF2TuMuvwaOdmbK3NbPBbpXd/R8l/UP98Gn17V/vco24+9e3izIJ4t0HOgpgek9WdQmcn5pwNpVfUXVN75/IBTCze6iavPRP7n7pXEYJAMD8vVDVwdnPS3qoux/rIeaHJH1T1SSF2+xWuZ7E8Or64fmSNlWdaexNmWaLNin40rA/ASyLaXPi69a3/0nSv5X0I5JOV3UWiVdKupWkv6wnVwEAsKzuZmZfDH9fVnX8+M8kfU99/+H1GR/a/KWkeEazvVx6WZJeV9/eP1trb3Zivy5bCwAW0LT/iQcAy+RuZrbb5Rhe5+5PliQz+35Jv1Y/f767f2Knkru7mZ0n6R8l3UnSM1SdoaGr90n6pKSbqvrlzNs6tHm5pNtqNGGt9VdvZnYbVb/U+6C7f3aKcfWq/lXfvVSdju31BzUOYFr1aatvreq63T9fnRRmzHFVB3Zzdn4py1kgAACLZKq8WNUZFaTq7GgfaPleTNtkufvQzP5U0nmqDqa+p0Ozl6uapLyTD7+ubUJGPdH4vqqutfyWLmOaIw4WYynNmBMPwu1Pu/vOJKRvmtmj67p3kPSjGv1SFgCAZbMp6buT565Udbz3ryW9yN0/nQvg7ttm9ueqjh39vbt/eI9jepmkZ0l6sJkd6Wni8kn1JZofquo478v6jA0A+4FJEABW2aTkNHW6dPKUv6+SdFjSX7r72H9guvvnzOwJqn6R9nQze7O7v7fLQOpJFC+V9KuSHqFukyBereo0opuqfjX3xkzdRfnV2wMkXUPSxe5++QGPBZjGNSWZqmsyPmuWAGZ2LVUHd7+j6ldvAAAsis55ceKU+m+aNjl/pGoSxMMlPXO3yu7+QTP7oKr/lJWkV2Sq31XStVVdku2rU46rN2Z2XVWTnq+U9CcHNQ5gRrPkxF+rb49LenMsqPeD36RqEsSdxCQIAMCScffHSHpMjyHvVd/u9SwQcvfPmNlbVE3AfYCkN+xS/6iq7/mu7ivpWpIuqtsCwFJhEgSAlTNLcuruJ9TttLyv0ewHbnZm5/6Imf2cux/fpa8vS+p6ytBdJ0F0SXR3W3cdYvxYffuHuX6ABfSN+vYf3P12M8Z4tKqJVC9396/3MioAAPZg1oO27n7jvsdSx73EzP5J0i3N7A7u/r4ObW7TMXynScG7LZu7Xyjpwj3EeLiqX8S/2t2vysUBFtAsOfFH69tvuXs5oXxnksTV9jQyAACWnJndR9LNVF0649W7VO/q2ZLup+rycdlJEDN4an0704+FAOCgFbtXAQD0wd0/r+oU+ddS9Qu4XpjZdVRdd/jLkjqdmWIezOz7JD1Y0j+LU/9iybj7lZJ2/lPmWjOG+Zn69g/6GRUAACtp5yDqU7O1pnfgZ0arL8nxZFW/iP+1XaoDC2fGnPhDqi6f8V1mNumMM99f3x7d+wgBAFhOZvZdqs74K0kvdfdv9hG3nlT8ekl3MbP/2EdMSTKz/yDp7pLe5O5dLmMHAAuHSRAAsL9+RdWpcX/RzPo6G88167hPbvnlzX75/1T96u3pBzwOYFbPV3X2lZea2RlpoZld08wm/iLOzH5A1fWOP+zul851lAAALDF3/1NJfyfpYWZ28z5i1pe2e72kX+rh2sp78eOSzpT0e7tdExpYYFPlxO6+rWqyvyT9TzMrQt1bqTobzbb6/3UqAAALz8yeZ2b/Iunzkm6rauLgr/bczdMkXSDp6j3GPKOO+V97jAkA+8rc/aDHAABrxcwequq6xheuyvXU6gNdT5N0wt2fd9DjAXaY2UMkPaR+eD1JPyTpk5LeXT/3FXd/aqj/YkmPl3SFpL+S9C+qzt5yE1Uz4F/m7o+b0M8rJT1S0pPc/UXzWBYAAFaFmd1W1RnE3uHu7zjg4fTGzB4p6fskvbi+tB2wEOadE5vZKZLeJukukv5B0jskXUfSj6q6DMb57v78uSwcAAALzMwuVHX51G9Keo+kp7r7Px7ooABgTTAJAgAArCwze7by1y78dHpdbzN7gKTHSbqTqpnvV6g68HuRpFe5+2VJ/WuqmtHvkv6Nu3+9n9EDAAAAe7dPOfEpkv6bpEeomixxTNLfS/pNd39LH8sBAAAAAF0xCQIAAAAAAAAAAAAAAKyEYvcqAAAAAAAAAAAAAAAAi49JEAAAAAAAAAAAAAAAYCUwCQIAAAAAAAAAAAAAAKwEJkEAAAAAAAAAAAAAAICVsHHQA8DyMbNPSTpN0tEDHgoAALO6saRvuvtN0gIz+2NJZ82p38vc/SfmFBvAPiInBgCsgBuLnBjAHpATAwBWwI1FTrySmASBWZymzc1rbV7/uteSJNl+d++damWHte9j7qj3cbWvq5m7mvO66yW8ddtGZg4/1+j7a75rSpLvfW3Nf4zzaNbzVjL3lTCjzLi6D3mf31H1wLa+8CVpa6ut1lmSbne7Wx3utesP/OPxXuMBOHCn2ebmtQ5d57uvddADmdl+fr+sUgI1B1O9FMuwLuecj89kzustu8TL8JotqnVZdwf0liEnBtADjhPPC8eJOU68zzhOPHsHHCcWx4mnRE68P5gEgVkc3bz+da91/f/+pOrRNIlE18+wXL2O/VkPMXLjsFyMbLtcf5NjZptkx5FJbmdctuz4O8fof1wz1etUa1yxiAd1Z1TOmHx2XQPeMX6unucSqAOMn2uXS+qzMWeKlxtHpii37jq/wDOOq2OM7uPoWC/094VffqG2/uVzR9uq3e5Wh/X3F33vFIF3d8dz/oUEF1gtRw9d57uv9b0/+5SDHsfsejgI1dkC5U+9LHYf+zXBVGNqqzvrV2p2ZyMTc9b9rZZ2Y/FmGNdUY5plubPrY7b9w5nq7Rpn7/u73fvqIUY2/uJ8dszVfn4eB+TEAHrAcWJxnHg3HCdeDhwn5jjxtO2a9ThOPA1y4v3BJAgAAICEy1Wq7D0mAAAAsCzIiQEAALDuyImXV3HQAwAAAAAAAAAAAAAAAOgDkyAAAAAmGHrZ6x8AAACwbMiJAQAAsO4WNSc2sxua2UvN7PNmdtzMjprZb5nZNecdxyqPNrN3mNkVZvYdM/uUmf2Jmd1870u3d1wOAwAAIOGSyp5PS8ZJzgAAALBMyIkBAACw7hY1JzazMyVdKum6kt4k6TJJd5L0ZEn3NbOz3f2r84hjZkckvV7SAyR9VNKrJX1L0r+R9AOSbi7pYz0s5p4wCQIAAAAAAAAAAAAAgOXwElUTF57k7i/aedLMni/pKZKeI+lxc4rzm6omQPy6pGe4N09vYWabUy/NHDAJArMxSdZhrpJNGXPi893nRFmuv7Y4mTaW6zvbboZxZELmx5GJ13HZutabrmwOMVueL6baRrrV7VpvGsU074cplTMON3dNJPduA87V63piJ8+s71x8zyx3LEtfzxgz3VabZWm7+CgzrsxczuxabVnW3Pqx7DjaHuS3cc+NMjaLMZKxx/Wae53GPsNinBgyGyMzxrb+dt28XWXnLbgrfvcGrK2O36mLpPdUKFkHB7lKrIfP475XzzSrY5a+c7n52Pd02/dvEiOTBiTf5/P9/stuS137zsbI9T3b/uJUL/jJNlOsx67xZ30fzvk1nXlci26anHjeOn8IkxMD6IDjxBwn3rVsDjFbnuc4MceJdyvjOHH6gOPEy3ic2MxuKukcSUclvTgpfpakx0p6lJmd7+5X9RmnPnPE4yT9vaSnu4+/qu6+NcNi9Y5JEAAAAAAAAAAAAAAA7I+zzOz9kwrc/fa7tL13fXtRehYGd/+WmV2ianLDXSS9rec4P6Zq3tTLJZ1mZg+U9D2Svirp7e7+iV3Gvm+YBAEAAJBwScPs1OTZYgIAAADLgpwYAAAA625Bc+Jb1Lcfayn/uKrJCzdXfhLELHHuWN+eLulySdcO9d3MflfVpTWGmX73BZMgAAAAJig5RAsAAIA1R04MAACAdTennPiyDmd8aHN6ffuNlvKd58+YQ5zr1re/LOlvJD1V1eU07iTp9yU9XtKXJT17l77nLneZHwAAAAAAAAAAAAAAsBysvt3r7I1JcQb17RckPdTdP+zuV7r72yWdK6mU9AtmdmiPfe8ZZ4IAAABIuKRhzzN8+Q0dAAAAlgk5MQAAANbdgubEO2doOL2l/LSkXp9xvlbfvtXdvxMru/sHzexTks6U9G8lfXCX/ueKM0EAAAAAAAAAAAAAALD4Plrf3ryl/Gb17cfmEGenzddb2uxMkrjaLn3PHWeCQP9s9yq71rNu86Bs1hiZdjZDu1nHkTZr7TsXw9LH3eu2tZklRtouG6M9hIps35PLcn0VXbfHXeI0Y/Y7669rv5LkPnmBBhOf3V3ZEq/ureM4mvXK8DCdadc2/rbnpercSa3jyKy7GDONH9e5JyGaZWPv0o4xJo9DkjyzXlvXwliM2CiJ53GMLW3G4ifjyK2Dtpe+4ziqmJmxxDix73TlZGN0rLcLrn8MYFeusc/oafWcVvRnzuPqvNx7W72TxRxhxviW+w5s9DWx2z1pCzPVS5b7ivXJ9cY6iDHa04DFMc2YWuqO5Z7Z/cAp+jvZZrZ92Jnrdn0jzuP1XMRtZB7a3k/73Xdq57XvMCZyYgB7wnHizuPgOPE4jhPncZw4acdxYo4TT4zRsd4uFjAnvri+PcfMCnc/+fYws2tIOlvSdyS9Zw5x3ibpiZK+Pw1mZoc1mjhxtPPSzAlnggAAAAAAAAAAAAAAYMG5++WSLpJ0Y0lPSIovkHSqpFe4+1WSZGabZnaWmZ25lzi1t0j6pKQfMrMfTNo8U9WlNd7p7l+cben6w5kgAAAAEi7XMDsVebaYAAAAwLIgJwYAAMC6W+Cc+PGSLpX0QjO7j6SPSLqzpHupunzF00PdG9Tln1Y14WHWOHL3E2b2aFWTJ95iZn9Wx72jpLtL+rKkx/axgHvFmSAAAAAmKHv+AwAAAJYNOTEAAADW3SLmxPVZHO4g6UJVkxbOl3SmpBdKuqu7f3Vecdz9b+s2fyrpHpKeJOmmkv5A0u3c/WN7WLTecCYIAAAAAAAAAAAAAACWhLt/RtJ5HeodlWR7jZO0+WdJD5+mzX5jEgQAAEDCJQ17PlUvJ/4FAADAMiEnBgAAwLojJ15eXA4DAAAAAAAAAAAAAACsBM4Egf3VerKVKULkYlhm/lRLO5uhzdg4MjGyw03btcRJlzk35lg3X8/D/e5jzMYM94vOfbfXK6YYV7Ndt76nadeI0alWXte+ckrf+0i6jiLXlydlg2y7UY/Nds2RlOFhOlsvtkv7bsSIbTLrO40RH6fbi/vk8afvodyyxbpjfbe8ImNLmXs92j5HlC5npoNQNr4O4ofM5DZVWXgiGW9zHUwc7u5yffdkyJRcAB308JXedFCfPYv6mdd1XDOmRdnXr2vM9Pu8bb8jtzBJ0Sxp3tjX+Yzfla3f05l8Yar1P2u7Lsb2r3J1u9Vr5FZd4+2mbcObNX7XD6KpxjhF3dYYi/rBsp/63sgzxvLxfsKSEwOYG44T5/vmOHEDx4nzOE7MceJJOE7cH3Li5cQkCAAAgISruYPUV0wAAABgWZATAwAAYN2REy8vLocBAAAAAAAAAAAAAABWAmeCAAAAmGC4n6cvBgAAABYQOTEAAADWHTnxcuJMEAAAAAAAAAAAAAAAYCVwJggAAICEu1T2fHE252JvAAAAWCLkxAAAAFh35MTLi0kQAAAAY2wOpznjtGkAAABYJuTEAAAAWHfkxMuKSRDYu77eqzZ56pPl4re0qcoyRR3bzdp3bJbvq1nW1l8aw6y9rO926ZCKru3C/WKK16Jr/Gy99u6y7drKsq/hjH3NW+mzvTG9pV0uXq4stwZiu7TfQSZ+c5Zks4c4I9My8RttksceXre0XXwPxXHkZm6m7+tmzLTh5HF6Ui/76sblbjRKY3R83ZIhWtv6ScPFdul7IbQbXz8t7WbcprPjAoA+zePzZc6fWQeYqvRvxmXJfr3kYuby28Z3WXtnub4t8z3adVFbx5HGyHxXtuU+Y+3SfKFRlHRwUBteupyZ9R/zwebO3TT9ddxXncP+budxzvhaZPeT0ZDm8f13kMnHAeAgcJw42zXHiTlOfBA4Tsxx4rHoHCceHxdWEpMgAAAAEi71PsOXvBoAAADLhJwYAAAA646ceHkVBz0AAAAAAAAAAAAAAACAPnAmCAAAgAlmPV0gAAAAsCrIiQEAALDuyImXE5MgAAAAEpzmDAAAAOuOnBgAAADrjpx4eXE5DAAAAAAAAAAAAAAAsBI4EwQAAMAY07D3uaKcNg0AAADLhJwYAAAA646ceFkxCQLzlXsfW/sJX2zGdrn+rK2dpfW69Z2tFvuaYjlju9w4mvU8KWsZx4THJ59PHhfZ+B7qdRtjkY2RWT+ZcWXbdayXLcuckKh1W9pFrr+9mvWaVJ5pV2a28lx/sSwbP5Sl8eKaGkwR3xplbRGlsvEWTfqO40r6jlHidpCOI/bt2Zc9GX8jZns9z22fjYrt69/j9piux/BwrKe47jLroDGQNEjXvhsrPAkS26WLyfnEAOwnT2571EvqcJCfiQfZd8fUqPM6nuK7xtu+A9Ovylzfje/iNN9peZD5qsyE7/wypfsnnlm23qV999yfpy+GtdxPdd037RojW2/GccRqPcTId7D3EAdqHp/jjTdb/ysot1/QNQIA7BuOE3OcWBwn7tLfXnGcuMJxYo4TT+wPa4VJEAAAAAnX7DuNuZgAAADAsiAnBgAAwLojJ15efZ+/AwAAAAAAAAAAAAAA4EBwJggAAIAJhkt/TmcAAABgb8iJAQAAsO7IiZcTkyAAAAASLmno/Z4wq4/TnJnZuZLuIek2km4t6RqS/tjdHzllnKOSbtRS/K/ufr09DBMAAAArYFFzYgAAAGC/kBMvLyZBAAAALI9nqJr8cKWkz0o6aw+xviHptyY8f+UeYgIAAAAAAAAAcKCYBIHZLfjZX8wyc6ks1ssFacZoqzrWV3ici5+2M5tc1rXervHD/SIb30O99phFtl2I3zrC8Ri5cRUt8YvMvLlcjNxYsvVmnKdXWDlTu1mUHWcmlplXp3SbeD9XL+VJWewvF98zZYPw2oy1axlXOg5rlDXHXIYnrOu4su/D5uPYnyedN8cZ76fxM+tck997Y+sglqXjD3XHxt/yIH2vpf0tjM7DMpXqd4ZvT1+cT1E1+eETqs4IcfEeYn3d3Z/dx6CAtdbyFZBLRWeJt+8xgpmX5SD1MGbPfRVntOb/ma+Bsa/NxndsJk7MadK8PQQZG37H+LnFju3SfKolXB2zZcXO+jVpmRhtqZWS/CfXrq2vXeJn3zi5di0xptlv7dTvblX7fuPPOzXs5ZRbU3Q3S647lnNPH2Is5IwrNveeTXtY0JwYwKJZ8Lc2x4k5TrxbjNxYOE7MceK0XnZcHCfmOHG/nWMPmAQBAACwJNz95KQHyx6dAQAAAAAAAABgPTEJAgAAIOGShj3PyF3AH1IfNrNHSvpeSVdJ+pCkd7n78GCHBQAAgEWwJjkxAAAA0IqceHkxCQIAACDhkoYdTxc4TUxJZ5nZ+yeWu9++1w53dz1Jr0ye+5SZnefu79znsQAAAGDBzDEnBgAAAJYCOfHy6vsiJgAAAFh8L5N0H1UTIU6VdCtJvy/pxpLeYma3PrihAQAAAAAAAAAwO84EAQAAMMZU9nyaM1XxLjuAMz6McfcLkqc+LOlxZnalpPMlPVvSQ/d7XAAAAFgkc8uJ9xbB7FxJ95B0G0m3lnQNSX/s7o+cMs5RSTdqKf5Xd7/eHoYJAACAlbCYOTF2t7ZngjCzG5rZS83s82Z23MyOmtlvmdk15x3HzO5mZm82syvM7Ntm9iEz+3kzG2TaPNrM3mtmV5rZN8zsHWb2gJa6P2VmbzSzT5jZN83sKjP7iJn9oZndYprlAwAAa+X36tu7H+gosG/IiQEAwBJ6hqSfUzUJ4nN7jPUNSRdM+HveHuNiiZATAwAArJ61PBOEmZ0p6VJJ15X0JkmXSbqTpCdLuq+Zne3uX51HHDN7sKQ/lXRM0uskXSHpgZJeIOlsSQ+b0M/zVP0q87OS/lDSIUmPkPTnZvZEd/+dpMkjJV1f0t9J+qKkUtItJZ0n6SfN7CHu/pbdlm9muQlM1n6lG2trl2kz1WSprnVDf9lFieNKxhiXxaZY5li3eb9bPak55mJsXJPbFZn4uRhjZS19TxOj0U7d2k0To7BSbXIx2+qNlS3g1ZxysxRL71aWr9ecTxf7S9t1jemxXjL+7XLUX5GJH0s83QZDPU9iNMua4yrDE7kYcSvLbxHpOmir3bVes66HemMRWtaVlKyvzOvUXMmdhjReN30/xXGFdulrodwYu44rwyUNe54runifDhN9qb499UBHgX1BTtxPTtyaFsz6pp+hXS5dnme/q27m9dry1Zn9Ss3ueHSLMxajsVOSlo0WrutXeLZeOsZM3dYY7SnB7GIukXZgLffHYsT9vvb4YwuQi5/Z12vte6ws3O26sU6xTrPj6hykhw+WrhtCD+Mdyzdz3bUt2zSL3Mh1Z12A2dax1Z3v1usC58RPUZUPfELVGSEu3kOsr7v7s/sYFJYTOTHHifP1OE7McWKOE6dlHCfeic9x4tZhcZy4U0zM31pOgpD0ElUJ6ZPc/UU7T5rZ81XtSD1H0uP6jmNmp6lKToeS7unu76uff6akt0s618we4e6vDW3upiqxvVzSHd39a/Xzz5X0fknPM7O/cPejYVz3c/dj6WDN7AclXSTpNyXNL7kFAGDZuTT0nk+YtRzZ7V3r208e6CiwX8iJyYkBAGi3oDmxu5+c9GC9zNjBmiMnJicGAKDdgubE2N3aXQ7DzG4q6RxJRyW9OCl+lqSrJD3KzLK/gJwxzrmSriPptTuJrSTViegz6oc/m8TaSY6fs5PY1m12+j2sauauQtlYYls//9eSvi7p+3LLBgAAlp+ZbZrZWfUvkuLztzSza02ofyNJO78aetV+jBEHh5yYnBgAgAN0lpm9f9LfAYzlsJk90sx+ycyebGb3yl2GAKuFnJicGAAArK51PBPEvevbi9y9cb4jd/+WmV2iKmm9i6S39Rxnp81bJ8R7l6RvS7qbmR129+Md2rxF0jPrOs/KjFWSZGb/QdIZkj6wW926ftvO51ld2gMAsKxcprL305zt/VdqZvYQSQ+pH16vvr2rmV1Y3/+Kuz+1vn8DSR+R9GlJNw5hHibpaWZ2saRPSfqWpDMl3V/SEUlvFtdAXgfkxOTEAABkLWpO3LPrSXpl8tynzOw8d3/nQQwI+4qcmJwYAICsNcmJV9I6ToK4RX37sZbyj6tKSm+ufHI7S5zWNu6+bWafUnVNtptK+kg9O/gGkq509y+09KG6jzFmdq6k75d0tbrO/VRdW+7n2hcLAAAssNtIenTy3E3rP6ma8PBU5V2sKie5rarLX5yq6hdAf6vqAPAr3ae5KjaWFDkxOTEAAAflMne//UEPQtLLJL1b0j+pmhh8U1X5wWMlvcXM7uruHzzA8WH+yInJiQEAwIpax0kQp9e332gp33n+jDnEmbbNXsd6rqSHh8cfl/Tj8RRrOW07pPXM39t1iQEAwLIa+uLNyHX3Z0t6dse6R6XxacX1L9r4VRvIicmJAQDY1SLmxH1x9wuSpz4s6XFmdqWk81Xl3Q/d73FhX5ETkxMDALCrVc6JV1m/5+9YDTtb8l5/ATlLnFn7nljf3R/h7qYqST5b1SmvLzGzx0wZHwAAAOuFnBgAAKyr36tv736go8AiICcGAABYUut4JoidWbGnt5SfltTrM860bXarv9sMYEmSu39T0qVm9kBJ75P0u2b2N+7+2Vy7hZWZcGXWbb/AYoyObcbih/tmmXqZvtN61hIzV2+QjdEsK1piFlPELzq2y9UbWNlalmtXKJb1ESNt17hsYxhve4ycNH5XbeOQpNKnn7tWZmYplskbqm1GY9pvjJnGaJR5rmwUc5oYcfsZ5sYV7ntmHOkyW6ZdsyzG80y9ZB0rJ9bNbT+TxyGl7/tQL4nX6Ck3kzV9n2f6bhvHWPyui3mAXNKw92u9AQuFnLiPnNjV/uae8U3fOX3Yxw+VGVOa1f7gy3x1ti32VOsxxB/7Gm3rO3k+thtr09jZSMvCd3jRXm3ml7frD2gmpzT5eF3r7Va3iPt9sU2aeOXit+8vNuJk9vta+0qLssud2TfNNOuq6z74rPqOns2wcyuk6y+/0vdhxwUYW48d281+LeG6g12ar3FO/KX69tQDHQX2Azkxx4k5TpyUcZx4PGZzvBwn5jjxpLIYj+PEY804TjwxJuZvHc8E8dH6duL10STdrL5tu4bbXuK0tjGzDUk3kbQt6ZOS5O5XSfqcpKub2fX3MFbV8U6ouu7cEUl36dIGAID1ZCq96PWvn/9qAHpDTkxODADALtY2J75rffvJAx0F9gM5MTkxAAC7WNuceOmt4ySIi+vbc8yssfxmdg1VpwP7jqT3zCHO2+vb+06Id3dJp0i61N2Pd2zzw0mdLm5Q325P0QYAAACrhZy4Qk4MAMAKM7NNMzvLzM5Mnr+lmV1rQv0bSfqd+uGr9mOMOFDkxBVyYgAAsHLWbhKEu18u6SJJN5b0hKT4AlWnuntFPbu2dWdp2ji1N0j6iqRHmNkddp40syOSfrV++LtJrJ3rED7dzK4Z2uz0e1zSy8Lz1zazW01adjN7gKSHSrpS0jsn1QEAAKPTnPX5x2nOsEjIicmJAQDYzaLmxGb2EDO70MwulPS0+um77jxnZs8L1W8g6SOqfvEePUzS583sLWb2EjP7DTN7g6TLJH2fpDdLep6w0siJyYkBANjNoubE2N3GQQ/ggDxe0qWSXmhm91G1M3RnSfdSdcqwp4e6OztLn1aVyM4aR+7+TTP7GVVJ7jvM7LWSrpD0IEm3qJ9/XdLmUjN7vqRfkPSheofskKSHS7qWpCe6+9HQ5Hsk/YOZfUDSP6k6TdoZkm6j6tRmW5J+2t2/1mlNAQAAYFWRE5MTAwCwjG4j6dHJczet/6QqX3nqLjEuVpV33FbV5S9OlfR1SX8r6ZWSXumeu7o1Vgg5MTkxAABYQWs5CcLdL69n2P6yqtOH3U/SFyS9UNIF7n7FvOK4+xvN7B6qEt8fVXXdtU+oSl5fOGkHy93PN7MPSfo5SY+VVEr6gKTnuvtfJNU/LenXVJ027QclXVtVQvsvkn5f0m+7+0e6LB8AAOts6FybDauNnJicGACA3SxiTuzuz5b07I51j2rCRZfd/Z3i1+8QOTE5MQAAu1vEnBi7W8tJEJLk7p+RdF6Hekc1YWdp2jhJm0tUJcLTtHm5pJd3qPc1JTOLAQDAdFymsuerhnl7OgEcGHJiAADQhpwY64KcGAAAtCEnXl5rOwkCC856OONg8hliHT9TYjVLxxEed443Ng6feF+SimJyWdpVkYkRHw+KJH5LuyKJMciUxXYbRdmMr8nxx+rF+ErHOKrbtV06xhhjkJbN0C53habYZlLMNgOVu1faxbDjF2+ZzFIsvb1dGba2OLsxbRNjlskWOku7dIzbZRHKkhiNds31GNt5iLmdxLBQVoytn8nrIG0X46tMx9i+HQwa9Zo8bD8xfpndXJpjbDtha/pZ5Gr/jFFczlzPoeH4z1MyDQFglbR97nb9HJzD5+W8+97XZTvI75OuxyTSfL+lWvaHI2Pf06Eo+2XcHr/x3Z/Gt5Z6krwYPWFlyE3S+CH9SYfYyBHad6maB37G9r3Urm2ljC2nt5Y1FJm+i0yM3P5hpm9rKcvGSItaSybsx3aINx6jc9W5MsX8uId4U/yCq5HvZ9Zd13w5/yGQNozjyMVvvKE646ArgKXCcWKOE0/RjuPEeRwn5jixxHFirA8mQQAAAEwwzOwIAgAAAOuAnBgAAADrjpx4OfGqAQAAAAAAAAAAAACAlcCZIAAAABKu8VP49RETAAAAWBbkxAAAAFh35MTLi0kQAAAAKbf+T3M2zXWgAQAAgINGTgwAAIB1R068tLgcBgAAAAAAAAAAAAAAWAmcCQIAACDhkoY9zxXlNGcAAABYJuTEAAAAWHfkxMuLSRBYamYzflSEdn2cdCYdh1muzCfWGysLzxeZGIOivSxtNyjKifE3wvO7xdiwcmK9NE5st2HDRr1GWdJ3oVjWbDeI45qhXtX35DFK0kCTy3L1UrHuwNrrNdpkvvJmvdZUPD1TmTm1UvrlHevG+/l6SVkY8zDpe7scdKtnk+tVMdqXrYjtQpmVzXXsoWw7Gb/FmGVSFmNkPn9iDE+qDcNmkaZOjeVpfFakr2Hus68xyjCO2balsZ7jcneMmX5WZMcyQ3wAOEitXwc97NF2TnWn6KuX8XasO4/xz9LX3L9OusbP1RvbLxjdHxv/5K/68fiZGI3UIjuuUJjsd3jIaSxJamL+k6Yxnhtzi+xr2FhOby0bE5cnrddSZkUavz1GrDuWyrXs92X3bzP7nGNVW+Lk2nSNMQ+z5qnNGP3W27Vy3NfIhpic34/Vy8Swjm+UaRbNOOwKYAVxnJjjxNPUq/rmOHGjHseJOU68C44TY9kwCQIAAGCC3I4hAAAAsA7IiQEAALDuyImXU7/n7wAAAAAAAAAAAAAAADggnAkCAAAg4bI5XOuNGcMAAABYHuTEAAAAWHfkxMuLM0EAAABMUHrR6x8AAACwbMiJAQAAsO4WNSc2sxua2UvN7PNmdtzMjprZb5nZNfczjpn9kZl5/fd9sy1N/zgTBAAAAAAAAAAAAAAAS8DMzpR0qaTrSnqTpMsk3UnSkyXd18zOdvevzjuOmT1Q0k9JulLS1fe0UD1jEgQAAEDCJQ17Pi2Z9xoNAAAAmC9yYgAAAKy7Bc6JX6Jq4sKT3P1FO0+a2fMlPUXScyQ9bp5xzOw6kv5Q0uskXU/SPWZakjlhEgRWSw+fQ2bh48c8KZtcz5J+m2XdYkjN4ReZGIMiV1ZOjCFJg/A4lsU2Y2XWLNvIxN+wYcd6o7LNYtgoK8LH/0ZSFscf+0rjb2bKBsqtn1Cm9nWQLUseN/ue3+Ge3JdwenqlYXhcJu3ayoZJjNJDmdrLtnzQLCu2T97fDmVDb45jO6zHdIxbNmq3nYxrw0fttstRWWHJOEJ/VjZfl7is6TYyDDFjDCXvIcV6zRINwpCHSWFcmsYYLd124jrJbVe5ehZK2j+L3Gf8YO06RABYdjN8xo19rM8QOxtj1rI9xu+8XFOMo4/vkGLGGLN+BbalZek+Q7Yva7mfK5sxRtp34ys87rukQcKK9SSnacTInOkzbjNTvUyzrIN0Q8iVNfa32us19vuS5cztEyqzL9keY4r4jXrt8dvizUM+p+zWt08xxLb+posxfVn6fGO9ZtZBWtIYf4iRz/y7f2iRngNYCxwn5jixOE6c4jgxx4kn1+M48bIxs5tKOkfSUUkvToqfJemxkh5lZue7+1VzjPMH9e0TJP3plIsxd0yCAAAAGGNzuGZxvzOGAQAAgPkiJwYAAMC6W8ic+N717UXuzZ8luPu3zOwSVZMb7iLpbfOIY2aPkfQQSQ91969a1xn4+4hJEAAAAIkFPs0ZAAAAsC/IiQEAALDu5pgTn2Vm759Y7n77XULcor79WEv5x1VNXri58pMgZopjZjeS9NuSXuXub9xlrAem76krAAAAAAAAAAAAAACgf6fXt99oKd95/oy+45hZIenlkq6U9KRd4h8ozgQBAAAwQf+nOQMAAACWCzkxAAAA1t2ccuLLOpzxYVY7p67Y64nYJsV5iqR7SLq/u39tj/Hnij0ZAAAAAAAAAAAAAAAW384ZGk5vKT8tqddLHDO7maTnSHqZu7+5wzgPFGeCAAAASLibhj3P8HXv99pxAAAAwDyREwMAAGDdLWhO/NH69uYt5Terbz/Wc5xbSjos6TwzO6+lzcfNTJIe6u5v3KX/uWISBFaWHeB+tZmH+7my5ploipayQdGs1ywrW2MMMvFjuw1rxohlRRIj1t0ohs2ylpibaT2L8Zt9b2bib9rocRxXfD59PEjiF+GsPZvFdqNsEMriuAZK12Msy6z/pKyrdMxR1y/bYTjRT5l8oTbLiqTMJpbF5yVpqxx9fZRpmQ9axxvLtsvR6zRMTky0HdbBVhIjvoZFUhbHHF+Lomy+htvlaBzpOZEKH9Udlmlh7CzzWoT3gqXrP7QbJCGG4aWPRflzVqUfdqPa+3mAMf2s872eaGsBpNs2AOTYNJ97mbqtcXLxZ4k3j3b7PY6cHr6HOn8LdKw49rVsE++O1R3br7Fu9WKalCvLpBKNhCRdpRYbJvsrjTwgaRjH0iia8TXzuJGMratMWRxzur8VHsf7aYxYlu43xb6Lsf25eL99/7Ct3lg7dTM2xgOU7qO0yX50ZGO05cSZbXWK+G3t8vG6lzVe7zCOsbdr40MgWbb27prv312QEwNYBRwn5jixxHFiiePEEseJ9wPHiffFxfXtOWZWuPvJLcbMriHpbEnfkfSenuMclfRHLbHuL+l6kl4v6Zt13QPFJAgAAAAAAAAAAAAAABacu19uZhdJOkfSEyS9KBRfIOlUSb/v7ldJkpltSjpT0pa7Xz5rHHf/f5J+etKYzOwdqiZB/JK7f6KHxdwzJkEAAAAkXN1n1E8TEwAAAFgW5MQAAABYdwucEz9e0qWSXmhm95H0EUl3lnQvVZeveHqoe4O6/NOSbryHOEul31cNAAAAAAAAAAAAAADMRX1GhztIulDVpIXzVZ3t4YWS7uruX93POIuIM0EAAACMsc7Xqp4mJgAAALA8yIkBAACw7hY3J3b3z0g6r0O9o7lOu8bZpY977qX9PHAmCAAAAAAAAAAAAAAAsBI4EwQAAEDCJQ17nivK9Y8BAACwTMiJAQAAsO7IiZcXkyAwu5136bKcydD2/rFiIYbZ5OenipGNP/m+JBXhcZGUDXJlRXny/oaVE5+XpI1GvWGmLG03qrsZyuLzu5cNJ96XpM1ictlYvfC4SMaYazdQWCehXa5eGr9Zr327GGTazWLozS/hYeaNWYa6J3zQLAtf5jHmVlJvy0ZfH2lfse5W2fyaKUPdrSLWS+OPHm8kfW/H7SdZ7u0QpwhlhZoxGu+hMomR9JcsQAgSn++eBHnoO90KrOVls/R0WyGGZ07F1fzsSOt1i7Fypvgq6P80ZwBWjSl8JGc+X7Kp4oxlXWP20fesMTq3y8bo+ME9xed7D7sFza47fl2k3/Pe9sWf1h1rN7mep+lItzRg7PyQMU4uZW2Gb3YQ8510fXvrg0wHqcz6aYjLViQBw2MbNMssloX76f5VXLgiiR8fj+3PtZSli1Jk9glz+6BFW07Z98a/i645ZpkZVi5GrqyRx8Xcear4uXFNzqXH3ueNMk/KwhAz7TzzZsiu4dyy7Yylw0tETgygE44TT3x+qhjZ+Bwn5jhxdxwnrss4TpzE4zjxGI4TrzwuhwEAAAAAAAAAAAAAAFYCZ4IAAABIuKwx472vmAAAAMCyICcGAADAuiMnXl6cCQIAAAAAAAAAAAAAAKwEzgQBAAAwwZBrvQEAAGDNkRMDAABg3ZETLycmQQAAACTcpbLn5Na913AAAADAXJETAwAAYN2REy8vLocBAACwJMzsXDN7kZm928y+aWZuZq+aMdYNzeylZvZ5MztuZkfN7LfM7Jp9jxsAAAAAAAAAgP3CmSDQvziDKZ0cFWdL2WJMdbJ0HOGxzTi5K7Ybix8U2bL2ejFmOsRYd1CUjbINKyeWbYzVG2bKRo8PD7ZbyzaLECPEk6TDxajdZlIW26Vlh4utiWVjMcLjgcqkbNT3oVy7sCxFEiO2S8uiGKMay/y2+eHYlhDKvDnfrQzz3074oFNZmcSIZVve/CrZimWWKWvUa47jWLl58n6RTIuMr2mRjH8Qtv+ibJY1xJcmnQ6YK+scY/REOks0vn/TZh4+PIZhsdPPgHj6rfHPmFFZ1xml6WfdUsxEzc2+7Wn86Xa/IJ4h6daSrpT0WUlnzRLEzM6UdKmk60p6k6TLJN1J0pMl3dfMznb3r/YyYmCVuU5+5mRT2ynKWuN0rZfWzdTrGmOsXucxZjrIxe/S1x7a9Z2SZXcZcoWZBYhfQelXXvze9rDTkKSe+RjF5HqSFNOrRlm3l7MeY8hH0uVs218c+26f4YXK7NupSPapBmGfKikrilhWTnw+fZyWNXK+ZFxxX8wa+2/d9x1z8Rv1WkvmL/cK5n5J5aGsa73x+JPrjbUJ6y7ta2zbbek7+1EXCtO+G+/lzPafrWcxflIUx5+2m+KXbAuaEwNYFhwn5jixOE6cxqjGwnFijhNznLg363ucGLvgVQMAAFgeT5F0c0mnSfrZPcR5iaoJEE9y94e4+9Pc/d6SXiDpFpKes+eRAgAAAAAAAABwADgTBAAAQMJl2Znzs8bccwz3i3fu24w/QzGzm0o6R9JRSS9Oip8l6bGSHmVm57v7VbONFAAAAMtuUXNiAAAAYL+QEy8vJkEAAABMkDv98pK7d317kbs3zsfo7t8ys0tUTZK4i6S37ffgAAAAsDhWOCcGAAAAOiEnXk5cDgMAAGD/nGVm75/0t49juEV9+7GW8o/Xtzffh7EAAAAAUzGzc83sRWb2bjP7ppm5mb1qxlg3NLOXmtnnzey4mR01s98ys2v2PW4AAAAA+2dtJ0H0tZMzSxwzu5uZvdnMrjCzb5vZh8zs581skGnzaDN7r5ldaWbfMLN3mNkDJtTbNLOHmtkfmdmH653Bb5vZP5rZL5vZNaZZPgAA1lXpRa9/C+T0+vYbLeU7z58x/6HgoJETAwCAnAXNiZ8h6eck3UbS52YNYmZnSnq/pPMkvVfSCyR9UtKTJf1fM7v2nkeKpUBODAAAchY0J8Yu1vJyGPVOzqWSrivpTZIuk3QnVTs59zWzs939q/OIY2YPlvSnko5Jep2kKyQ9UNWO1tmSHjahn+dJOl/SZyX9oaRDkh4h6c/N7Inu/juh+pmS/rekqyRdLOkvJV1d0g9Jeqakh9fj+spuywcAAHp3mbvf/qAHsYud87v5gY4Cc0dOTE4MAMCSeoqqfOATku6h6rt+Fi9Rlb88yd1ftPOkmT2/7uM5kh63t6Fi0ZETkxMDAIDVtJaTINTfTs5UcczsNFXJ6VDSPd39ffXzz5T0dknnmtkj3P21oc3dVCW2l0u6o7t/rX7+uapmqz/PzP7C3Y/WTb4l6QmSXu7uV4U4h1QlvfeX9CxJT+ywfN2k/0XSx6Vx4vV1bLb/g/GkmWlyTE+u5WMz9tdVbvXEvtvuS1IRHhdJmc1QtmHDRr2NogxlZVI2bC3bDGWHiu3R80n8w5myI8VWa1l8fDjUO2TbrfU2k7JDmbJNjcoGYdnScQyUK2vfftrK0tcpp+3aU8Nky0ofR1s+CPWK9rIwI3FLg6Te6OvjhLeXbSVlx8rNTvWKsK7SsuPhq6tI3ujp407K5HHRXlaahfvh/ZS8tmXmfRgfDTOfP6Gr8c+plngHaZZVPzlQz9dXm3FcLqns5Qttz0OZh50zPZzeUn5aUg+ri5y4h5z45Ed3+ibPvOmzX/2hrGu9tK+Z4nftS5LFD/1Zxrtb3y1xxuJ3Xcc9fADPuouQ/VqL3/VJPcuUxVzF435N8mOSRoyiGaRRt/V3pmquu7TeUO2s5X7yuLFsuZWclrXFT39QEx5bkewbhcdFUlYMRkngINwfqxf2mwbpPlssS9oNQlnMFcde6o77dqm2/Ytp9jtyul4PN1cv5re5erEsHf0s8dO8umx8hnWLJzV3EzyzXr3Rd1oW+k73GVrGPF4vPsqMX23bT36bWNSc2N1PTnowm218ZnZTSedIOirpxUnxsyQ9VtKjzOz8mEtgJZETc5w41OM4MceJ68ccJ+Y4cdV5axnHidtxnHhuQ8GU1u6cGx12cq5StZNz6hzinCvpOpJeu5PYSpK7H1N1Kj9J+tkk1k5y/JydxLZus9PvYVWn7dt5/nPu/pJ0B83dT0j6tfrhPXPLBgAAVtpH69ubt5TfrL792D6MBQeEnFgSOTEAAOvs3vXtRe7e+G8Nd/+WpEsknSLpLvs9MOwfcmJJ5MQAAGBFrd0kCPW3kzNLnJ02b50Q712Svi3pbmZ2uGObtyR1drMzJXI7W6tmZu+f9CfprI79AQCwpExD7/evn5/A9GLnl3PnmFkjF6yvCXu2pO9Ies9+Dwz7ipyYnBgAgF3MLSc+K/P9ul9uUd+2Tfz9eH3bNnEYq4GcmJwYAIBdrPRx4pW2jpMg+trJmSVOaxt335b0KVWXKLmpJNWzg28g6Up3/8Iexrrjp+rbSYkyAACouUulF73+9XYquI7MbNPMzqqvTRuWzS+XdJGkG6s6NWp0gaRTJb2C0/6uPHJicmIAALJWISfO2Lk0XNsl4HaeP2P+Q8EBIicmJwYAIGvFc+KVtrF7lZXT107OLHGmbdPbDpmZPUjSf5H0WUn/c7f6kuTut2+J9X5Jt+sSAwAA9MfMHiLpIfXD69W3dzWzC+v7X3H3p9b3byDpI5I+rWrCQ/R4SZdKeqGZ3aeud2dJ91J1EO7p/Y8eC4acmJwYAICDclnb9+sC2fl5HoeoVxs5MTkxAABYUes4CWI3fe3kzBJn1r6z9c3sbpJerer6cz8arxkHAAAmK30hT0t2G0mPTp67af0nVRMenqpduPvlZnYHSb8s6b6S7ifpC5JeKOkCd7+irwFjaZETAwCARc2J+7DzH8ant5SfltTDeiInBgAAq5wTr7R1nATR107OLHGmbbNb/d1mAMvM7qrqmnClpB929/e21Z2LNO3OfE7E079Y7vPE491mRYuFs34mxQ8zm++Ef5sxfly0IokRHxdqL9uwcuLzY/WKYaNsM7TbTMo2bBjqje4fLpqXFzxSbE2sV9VtLztisWwUM8aTpEONcTT73tRwYr20buz7kMqkXlh3yToehHU3SNe/uhlktt1hyyZTJo+HYSsZJl/QZVjOLW+O6oSNHpeh7IQGjXpbPgj3m18lx3xz1M6b7eJ6PVaO6m0l9Yqwjo+HepI0CGXHkrLGisis8EbSktQry1FZ+t6I75syfFC5t7+HPIkR+x77DGhJprrWm9VcTr8VP6tnHG/nca3Rb7Pc/dmSnt2x7lFlvg3d/TOSzutjXFhK5MR98eR2p8/cZ1NMWdN6be1y8WfsuzmO9LsmE6+trOuy7NKurSw/jkxnXceR08d3TW5fKCnzIu6TpGWT23ma+8R6RXMBGjHSXDGu12Ly85KUpIet8XNiz+P5QvtKb+RX8X6ynBYeW1JWhMeDjeZ+wWBQTqy3UTSz7iI83hw0ywahbJDZ34r1xvbLNLleKm3XtWxWbQcA0+dzBwrj612qvV3nGJm+veX53WI0y5JtK8bPjDG+aul+gWdixPw/7muM99W+b9Eccst+xsRn18ZH69u2SwfcrL5tu7wBVgM58X7iOHEWx4k5TjwJx4k5TpziOHH3voCun7WrpK+dnFnitLYxsw1JN5G0LemTklRfi/tzkq5uZtefdqxm9gOS/krV2/4cd7+kZawAACBwVQfk+/wjB8eCIScGAABZK54TX1zfnmNmjeOjZnYNSWdL+o6k9+z3wLCvyIkBAEDWiufEK20dJ0H0tZMzS5y317f3nRDv7pJOkXSpux/v2OaHkzpxDPdWNbN3W9IPujs7bQAAdGYqvd+/tf+tHRYNOTEAANjF8ufEZrZpZmeZ2ZnxeXe/XNJFkm4s6QlJswsknSrpFfV/PGN1kRMDAIBdLH9OvK7WbhLEtDs5Pe8svUHSVyQ9or4Ot+o+jkj61frh7yaxfq++fbqZXTO02en3uKSXxQZmdo6kv5B0TNJ93P3v0/UAAACA9UVODAAAlpWZPcTMLjSzCyU9rX76rjvPmdnzQvUbSPqIpLdNCPV4SV+S9EIze6OZ/bqZvV3SU1T9mv7p81sKLAJyYgAAgNW1sXuVlfR4SZeq2sm5j6qdoTtLupfGd3J2dpY+rSqRnTWO3P2bZvYzqpLcd5jZayVdIelBkm5RP/+6pM2lZvZ8Sb8g6UNm9gZJhyQ9XNK1JD2xvua3JMnMbiHpTZKOSHqzpAeb2YPTFVBfUxwAALQou17QHFhe5MTkxAAAZC1oTnwbSY9Onrtp/SdV+cpTdwvi7pfX//n8y6p+WX8/SV+Q9EJJF7j7FX0NGAuNnJicGACArAXNibGLtZwE0ddOzixx3P2NZnYPVYnvj6pKQj+hKnl9obuPXQrG3c83sw9J+jlJj5VUSvqApOe6+18k1a9fx1Qd/0dbhv/sLssIAACA1UROLImcGACApVP/h+2zO9Y9qsz5ht39M5LO62NcWE7kxJLIiQEAwApay0kQUvednHnsLLn7JaoS4WnavFzSyzvUe4e4mAwAAHviUn19tn5jAouGnBgAALQhJ8a6ICcGAABtyImX19pOgsAeuaSdN735eNmO9HOhUTUpDHHiPGfL1Ju38fnWo7HYPo5jGkUYVzrGomXM6fNFeKEGSdlGMRzdt2GjbDM8brs/TdkR22qUHSm2JpZt2nazXig7lMRvtkv7Lkf3NbqfroPNxvpRUqZQ1ixsO2HSILM/Oky/DluqlsnjYdh4h8n4t8LDMlkHJ8JpnbZsdH/Tm/W2NBi1SWIUZViPNmiUHSvDuitG9Y75ZqNeY4HSFRfKhtYsLMM6j4lJofbtuCybK3UjbAdl+hqGsiL0XWbeQ821szi858Rtus7j/eY4xj93J9fLZorZMtu9Tq3kWBGADiz9Et4R89lpPrPa2qUpQaYsF9/iB21ujB3LGvWSdTHr+HsfY6LZd3vFmdP9tnbpV1l8nOQcHveN0lwoVI1lXiQxisn3JclDilYm66AIA4v1MinZ+K5dTIDGxtXt9c2ufutwX5JCXzZIlnMQ8v1Bc+PdiGUhZ91I6m0ORgs6ts8wiPtNzXYxZtwXS+s1c8/2fbu2/bxUmhPPmuu0HQBMn4+P09PHxr7z7cL2mNbrGMNb4o3VU9OwHI3ZMjlr+h6KLDv+EC95DZt14/1mPWscR0lfl/Z20yAnBrArjhNznFgcJ67KlJQplHGcmOPEHCee3Hm8z3Fi9IuLmAAAAAAAAAAAAAAAgJXAmSAAAAAS7tb/ac4OclY1AAAAMCVyYgAAAKw7cuLlxZkgAAAAAAAAAAAAAADASuBMEAAAABP0PcMXAAAAWDbkxAAAAFh35MTLiTNBAAAAAAAAAAAAAACAlcCZIAAAACZghi8AAADWHTkxAAAA1h058XJiEgT2Ln3zm4eypG6smpbFQhsrbOmvWc9DDBsriz2N6nnaV4hvmXF4KDLrXtas1yzM9ddmljaSVFiZKRvFLJL1OIhlSd8bxSjmZjEMbZp9xb43bdgoi483bTsp2554/4htNeodKUaPD6kZ/0gjRpmUxb7DeNV0KLyoadmmjZ4ZqPn6FqH2ILdhZAzDxlWq/TUchtem9ObrtBXKhklZXCdbPrp/IlnS44rbSDKOWDUpGob1Pwzrp/B0GxnFH4yNcfQ6Da05ri0bTIyRbu/xtUm38UWUflbk6073/G79jTWLZbEw/SiNY06DdF2eXIxGvY4xpuDqP7ld/C0NwNRcrW9uy3xGxsdjqVyXeGm9pMziB/RYWbgfvx5nHGNrvLF66RdFe7u2dTc+Ds+U5dq1jCvzQZ1JnfP7PLlmMY1JBukhV/Q04Yxfj0Wsl8QI7cpBc1CN1CtZNi9jHtn+XZxJ+Zr7QMOkLDQcW7ZGxZb7mTJL1kF8XBTNUW5sjAa2MUjKBqOyQ6HeZhJjcxDLmgsa9402kg1oI9Q9FO5vJDEGmX29mMOm+2WNeqHvMrvCm7rmQWV4AYZJm+1ykFaf2G67bI4r9h3HXCYbQqyXxoi5aGyXLtcwtEvLLLyG6RouGzlxe/z4EZPul1lLjGrMIUZ4fdN6njk+0uhr7JhF/cQuLzM5MYCpcZyY48Q1jhNznLh+YoTjxL3gOPGkgbT3PVNfE0KSEy8nLocBAAAAAAAAAAAAAABWAmeCAAAAmCD9tSEAAACwbsiJAQAAsO7IiZcTZ4IAAAAAAAAAAAAAAAArgTNBAAAAJFw2h2u9MWMYAAAAy4OcGAAAAOuOnHh5MQkCAAAg5eo9uZX3Gw4AAACYK3JiAAAArDty4qXF5TAAAAAAAAAAAAAAAMBK4EwQmF3rTKUwI8qSSj652ng8C083Y1huwpXHu82KFgobw8jGaxbGscR2ntSzsNxpmafrZI/S+DlFS99tz/elSF7DQXhcWJmUjR4PrL3dwMqJ99MYafy4rJtJ2WZYlZuN5y2pN5o/Nki2syLMLdu0QVK299mCGyFEGdZHqWQ5PZQlyymP6yfpILSLwx0mr+Fm6G+YbIOHNAx9N+falWH9bPnoK2jstfb211DeXK+Ndhbb+cT7VYzWEL2YdWZofD/n3ttx+Nl62bL4oPt4m+0yfXVcx57Wi3FyMbJlHWPsovcZvgBW0smvmCk+s6zlszRbNlbPM2WZduXksrF0MJYlX8Vt8a301nppjK7t8uPIrIOW5cy2y67H9he4ayo99rWS2RHxIuxPpAlb/JobtNfzkIYlaWkjnbKNZrvmyxHzzfZxpIsS17+nr1s5qhxfi8wqzv98w9o3ZAvrcTBolg0Go4FtDIaNskMbo8eHB/H+dqPeZig7MthqlG0UIX6y8R4utkO9UYx0/6RoyW2l5j5Pquv+XS7XGWZWemxXhg0t3Ua2ysHENmndYbLtbsd2od52mexbhJgbyX7HdhxXY7zJ/ltYV2nZsJwcQ2oezoj7+JaJke4Plpkvjrg0jb6zr23uuESm2S7IiQF0wnHi0fMcJ873y3HiuozjxBwnzuM4cTIWjhNjBpwJAgAAAAAAAAAAAAAArATOBAEAAJBw9T/Dl0u9AQAAYJmQEwMAAGDdkRMvLyZBAAAATDDNaSQBAACAVURODAAAgHVHTrycuBwGAAAAAAAAAAAAAABYCZwJAgAAYIypVN8zfJkxDAAAgGVCTgwAAIB1R068rDgTBAAAAAAAAAAAAAAAWAmcCQKz8/o2nbDk8UFuNpM3H1pbUTOGh0JL45vHikm7UV2Lhcm1fNzayxpDbMRvdta8PlB7WalEGecljUoLax9jmYxxO8QoCu9UVnoyEiahaRDW+SBZIfFxkcwl27RBKEvaWb/zzgbh/layvcvCa+rNfouw/Qw9bTjLOJoxtrq2a4yxe39DxfdQcx0Pw7LG90b6Phl6e4y0brNscvz0mmC5vuOiDsvma1O2rIexGI2+1als7LplmfF7S720sNEu9xqOjb9b/OzzueuwZceSKUuq5baFWez93QZgIXlyW7OOn0Vj9bylXvIlYS31di0rJ5el42irl47FGmNs1suOP9Qd7zvEH3YbR24dpH2rZfzjMXLxp/9U9ySnz+XcsW6SyskHsSwESXL/WGbJnr+HRDJ93ZqvfYiRLHPMycYWrZh8X0rzAM0mvnCNvpoBi2K0MINBc0E3QtmhjWGj7MjG9sn7hwej+4cGSb3B1sT7knS4GIb720nZqG4cxyDZQ4x5+6Y1+x6MveGmN0w3riDmyGm9mCMNNTk/lqQybINbcaNTM6/eSuOHdbcd61kawybWk6SNWFaO2qW5/3b4PEjHX2T2u2MeH8vG3tbh9U1zbsvk9KV7S71kHYf7nnyYNutmD9y0IicG0BnHidsGzHHiFcBx4mnGwXFijhOnjRIcJ56ma+wRZ4IAAAAAAAAAAAAAAAArgTNBAAAApHzCrOgeYgIAAABLg5wYAAAA646ceGkxCQIAAGCCvk9zBgAAACwbcmIAAACsO3Li5cTlMAAAAAAAAAAAAAAAWBJmdkMze6mZfd7MjpvZUTP7LTO75rzimNnNzOwXzeztZvYZMzthZv9qZm8ys3v1t3R7x5kgAAAAEq7+T3PGWc4AAACwTMiJAQAAsO4WNSc2szMlXSrpupLeJOkySXeS9GRJ9zWzs939q3OI8yuSHi7pnyW9WdIVkm4h6UGSHmRmT3b3F/awiHvGJAgAAAAAAAAAAAAAAJbDS1RNXHiSu79o50kze76kp0h6jqTHzSHOWyX9hrv/QwxiZveQ9NeSnmtmr3f3L8y0VD1iEgRmd3Lm0xRzluJkqbGZU13jjNp52ibEtLGJWR7uhcIyiREbFu3xVYbnkwvLlKGsyJTlLkhjoa9hmalYlM2Hod22N9uZ+8SyIolf2KhekcQoysHofrL+B2GlbCnUS9bjwEf1Cm+Of9OGJ+8Pk21kGF6bYRjXMFmRQxs93tRQXQ3DMIdh2YpkW4rLnb4yZW7DCMs6sNmuRjRM1ld7vdEYm2OSSu/2Xhtmqg3De2goay074YNGWXwc76ev9VYo20pilPG1T7bPeG2usvFeaMbYLtv7LsP4t5P3RnzflJn3WpwZOrYdh5jpDFJved+n1xwrS5vYJlfmZXtfYy91o11SFPuLDceWJQ3aUjet19YuN9u2a4zd4jTYHK71xrXjgJVUf+ZY5rMoV5Z+ZsV8rWsMS9ODTLtG3UyMOI6xstYY3lpvfBwh/rC9LKYxY/FDspJf/+m4usVXy2sxKeYsPO53pF8RoSz9OvKNkEuERNXT1HMQ9o2G1l429vo2dtpO3ktzvrjPEOOlMbPbYE7mfRKHYmFfwwbJfkd4PEj2mzYGo8eHB82N8PBg++T9UzZOnLx/JDyf1rvaYKtRdrXiRGtZ3Odp3C+2W+sNkpVQdFyRZbphBOlr2tYurRfLtho5fZKbh3ZbZTMfj+02xvL9yXn8RrLMMQffSN4oMd+P22qa38d91TSnj58PRbquQtW4716kb9iY+ydvhtw+f+yvzCS3sdVY7jr2wdgoDP/mkBMD6IjjxKFesxrHiTlOPLGU48QcJxbHicfqcpy4e2uzm0o6R9JRSS9Oip8l6bGSHmVm57v7VX3GcfcLJ8Vy93ea2Tsk/aCku0n606kWag5m+3QFAABYce79/gEAAADLhpwYAAAA624Bc+J717cXuTenp7j7tyRdIukUSXfZpzg7dn4BsJ2ttU+YBAEAAAAAAAAAAAAAwP44y8zeP+mvQ9tb1Lcfayn/eH17832KIzO7kaT7SPq2pHftVn8/cDkMAACAhKt5yru+YgIAAADLgpwYAAAA625Bc+LT69tvtJTvPH/GfsQxs8OS/ljSYUn/zd2/tku/+4JJEAAAAAAAAAAAAAAA7I/L3P32c4q9M2tjr/Mtdo1jZgNJr5R0tqTXSXreHvvsDZMgAAAAUi659zvDl5+9AQAAYKmQEwMAAGDdLWZOvHOGhtNbyk9L6s0lTj0B4lWSHibpTyQ90t0XJuNnEgQAAMAEZd/JLQAAALBkyIkBAACw7hYwJ/5ofXvzlvKb1bcfm1ccM9uQ9GpVEyBeLekn3X24S3/7ikkQ2Lvsm3+aCT9tcTIx0r7DQ0/aWSO+h3uW1AtlZS7+SFHmh9UIYbEwaVjEoqK9XqPi3hU2aD4u49Lt78fEIK7ZdDHjaghlA2uun4Gn66ubYeigDPc3k21pM3yOb471baGsuQBFHHQPc+HiGIdJwDJMtkvLtkLZVhJzK1Q94UWo11yWYz4I9zeTGKOyLQ2SstH2dKwctTvmh1rrHS+b8WO742Vz+4yPY7utMh3HaHlOJDFODEd1t73Zbju8L2PMYVm01kvLho0yay2LiVWZ1PNMWeNxqJfOVvVGmZp8cr20TNkYLR+YqVy7XL1ZYgDAHNjOZ5C3PD+hLD629AO0URbup+lNJn6sa5myRl+lt9bLxYjt0jE2yobtZWmq22zXNX66Hn1ivfG+2+s1vtzSvmNZ7kcO1u07ydN6MX0omrmEb48G44VNvC9JvjFq54MkX9gYPbZ0n8djf5P3odL+xl7fkEKlZY30MPf9bi3308fFKEiR7JgNBqPHG4PmQA6Fx4cH242yUzZOhPujjPlqg2b2fLXBidayU4oQY3C8UXbERv1tNu43xxj3c4pkIxykb8wOhpkcqUzy/WHYDoZJWcz3y7jPkOTOw/BCbVkz527sM3iaq4d8vBytk41kvzXm6mm+H9dPEcqKZL1tZz6LioGHes11ED8D4rpK622EbTJ74DTZdhs5eNxHyLxpxnafY4wZthcAmAnHiTlO3COOE3fHcWKOE08q4zhxJsbyu7i+PcfMCvfRh52ZXUPVpSm+I+k984hjZodUnfnhwZJeIem82HZR9PsNCQAAsCLc+/0DAAAAlg05MQAAANbdouXE7n65pIsk3VjSE5LiCySdKukV7n6VJJnZppmdZWZn7iVOHeuwpD9TNQHij7SgEyAkzgQBAACwVMzshpJ+WdJ9JV1b0hckvVHSBe7+tY4xjkq6UUvxv7r79fY+UgAAAAAAAADAHDxe0qWSXmhm95H0EUl3lnQvVZeveHqoe4O6/NOqJjzMGkeSfk/S/SR9RdLnJP13Gz8L5jvc/R2zL1o/mAQBAACQcE04xVsPMfeqnq17qaTrSnqTpMsk3UnSkyXd18zOdvevdgz3DUm/NeH5K3sYKgAAAJbcoubEAAAAwH5Z1JzY3S83szto9GO5+6n6sdwLVf1Y7oo5xblJfftdkv57JvQ7Oi7K3Kzt5TDM7IZm9lIz+7yZHTezo2b2W2Z2zXnHMbO7mdmbzewKM/u2mX3IzH7eLLngVrPNo83svWZ2pZl9w8zeYWYPaKl7JzP7dTN7i5l90czczD47zXIBAICF9BJVEyCe5O4Pcfenufu9Jb1A0i0kPWeKWF9392dP+HvePAaOxURODAAAllEfOUzdxlv+vjjP8WOxkBMDAIBl5O6fcffz3P367n7I3W/k7k9OJy64+1F3N3e/8V7i1HXvWcfK/T17Pks8nbU8E0Rfv6KcJY6ZPVjSn0o6Jul1kq6Q9EBV/3lxtqSHTejneZLOl/RZSX8o6ZCkR0j6czN7orv/TtLkx+sxbKk6bcl377YsAAAgst5n+Ep7i2dmN5V0jqSjkl6cFD9L0mMlPcrMzo/XaQPakBMDAIC8xcuJJc6Ohn6REwMAgLzFzImxu7WcBKHmryhftPOkmT1f0lNU/YrycX3HMbPTVCWnQ0n3dPf31c8/U9LbJZ1rZo9w99eGNndTldheLumOO9f6NrPnSnq/pOeZ2V+4+9EwrgslvVzSP7n7CTPjbIMAAEzDpbLv5Hbv38b3rm8vcveyEdr9W2Z2iapJEneR9LYO8Q6b2SMlfa+kqyR9SNK73H2455FiWZATAwCAdouZE0v95TBSfXa0XkaFZUVODAAA2i1uToxdrN0kiL5+RTljnHMlXUfSK3YSW0ly92Nm9gxV/2Hxs5JeG2LtJMfP2Uls6zZHzezFkp4p6by6z52y/9c27n2XfjDEN3aaczfK1PYgHyPTd+NhuG9p+JZ6Y/2FhmWRVgtlKptljZjNhu6j+F6E+8kwYr0yKcx9GLeVpbPYysHo8SHfbo1RetFeFlbeMFnO+LhMVvIwxNzy5pn/yiLGDzGScWwVo4+2I7bVLAtnEzxmzf/nO6TR402L95uv4WZ4TQ+lZWEbKZr/R6m4NIN0w5vBMGwH6f9Yxp63km1kGNb5VrruwuMTYR0f882k3qC17Fh5KFO2ObHseNle77hvtJeVzbIT4fHx4Uam3mj8J4btZcPkzd1WNkzeQ1vDWC95f2XaxbLw8jaerx7bxHqS5DFGoyD5TAwbydhM1tgwbZcpa4+Rls3YrmuMxXaWmb1/UoG7336Xtreobz/WUv5xVbnJzdVtEsT1JL0yee5TZnaeu7+zQ3ssMXLinrhOflaNpaWZzzOLH6ZjZeF+/ELPxE/SkfYYY+28tV58bEnC2SzL1BtmynLttn1imQ3TGPHLMu27nFxPkoYxfjnxeSl9ndIv3MyXVNpfm5DbWiY39KKZB1jI1RtlG0m+EJbHB834Vrbn0h42oFhkw2aMIu4mFMkyh2VLUvrm9tnDgZ/4fzlFMo5BMXp9NwdJ3j4YbaCHN5r7PEcGo8enbhw/ef9qg+a+xdUHo7JTihONslMyZacWo7JNG/V1KNk/KUJWP7B036LbyhtmfmEU973KdJ8ts18W9+di2Ykkb49lW8myNcrKXLvR/Y1k/2q7HMUs1NyfKML4i7CuimR7L8JeWpFskNsxB0/2+Rtlce8rqdfYB08PHGTEJY3bcRqjzGwHjRGmufPOsi7h/4VydjT0iZx4n3GcmOPE4jjxDo4Tc5xY4jjxntp1jYG11n0PbHVkf0Up6RJJp6j6FWXfcXbavHVCvHdJ+raku5nZ4Y5t3pLUAQAAPXHv968Hp9e332gp33n+jA6xXibpPqomQpwq6VaSfl/SjSW9xcxuPfMosSzIiQEAwK4WMCfuK4fZcdjMHmlmv2RmTzaze5nZYPdmWBHkxAAAYFcLmBOjg7U7E4T6+xXlLHFa27j7tpl9StItJd1U0kfM7FRJN5B0pbt/oaUP1X30ru2XqpLOmkd/AACsgcs6nPFhVjvTnndNpd39guSpD0t6nJldqer0qs+W9NBeR4dFQ07cETkxAAC94+xoWBTkxB2REwMAgGWzjmeC6OtXlLPEmbZNn7/4BAAAHbmq07/1+rf3Ye1875/eUn5aUm8Wv1ff3n0PMbAcyIkBAEDWgubEnB0NfSInBgAAWQuaE6ODdTwTxG46/4pyDnFm7Xsu75e22ff1zN/bzaNPAAAWxdg18A7eR+vbtl/23Ky+bfv1URdfqm9P3UMMrAZy4p2g5MQAgDU2p5yYs6NhWZAT7wQlJwYArLEFPE6MDtbxTBB9/YpyljjTttmt/m4zgAEAwOq4uL49x8waOZyZXUPS2ZK+I+k9e+jjrvXtJ/cQA8uBnBgAACwjzo6GPpETAwAArKh1nATR168oZ4nT2sbMNiTdRNK26v94cPerJH1O0tXN7Pp7GCsAAJiS9/y35/G4Xy7pIlWn531CUnyBqrM3vKLOH2Rmm2Z2lpmdGSua2S3N7FppfDO7kaTfqR++qochY7GREwMAgF0tWk4szo6GfpETAwCAXS1gTowO1vFyGI1fUbp7uVMw5a8oZ4nzdkk/Iem+kl6TxLu7pFMkvcvdjydtHlW3eVnS5odDnf3X5Z2aO0NM9vQxPvHuWMw0RnxomQGGdmPDCI8tKWvUbYwjiRGmF3nZnGvUaDbabOr+wrjcw/1kHMXoCUsWIMZMT9EzKEZlw1C2WTTHse2jMW8XzfEfGgxHZcmybQ9Gj7dCjMPFoFkvPE7jb4WyLW+2O1Zunrx/pNgK8bca9Y6UWxPrSdKmbZ+8f8iGrWWbGnaqN0he/MLK1rLNTFlXw5Y3VZm81rFe2iau1y1vfg2ciGVqrxdfixPp6+SHTt4/HupVZRsTy3Kv9fEyGWN4fHzYLIvbXax3YtiMH8u2krK4/adl8X0zDNv/MHkvDMtRvfR9UobH6Xs7lpWltdaLnytjW5K3tBuLEbaLsc+RyfEmd9jyfO4zPjOuzjFyVjuTfLykSyW90MzuI+kjku4s6V6qDnY9PdS9QV3+aVUTJ3Y8TNLTzOxiSZ+S9C1JZ0q6v6Qjkt4s6XlzXQosAnLieQufRTb2QR7L2tvlPi9DWjEWI5aNt/OJ9azsVm+8Xag3TOoNfWK9tKwYJmUx5nYoG4tRTryfxlfZsSyJ0fhC9PYxjn9Rd/wissyORzRIfrsQ6loo80Ezbyk2R4/9cLMsLmn6y4j49esxflIxpm8+bI4/vm62kcklGp21rzdPN/K4PxTGVRTNehth3yXux0jS1TbCPsOguc9w6saJUb1QdvXB8Ua9awyOnbx/SnEiKfvO6H5xrFF2JNTN7Xc09y2a22fX/Ym2/YeqLO6/pXlvKFOzLO4bNOolMeJ+QtxHSOtuJcsd9xMGYf92kOw/p+OKihB/ELefZP+h8QZIPgK6ljX2xdJ6oWKZbMeN8EneW4S6MaSNxbBQr32bSN/naX9Lpq8cJoezo60PcuK+cJy4fYwcJ+Y48YQyjhNznFjiOPFYXY4To2drdyaIvn5FOW2c2hskfUXSI8zsDjtPmtkRSb9aP/zdJNbOKfiebmbXDG12+j2u8aQXAADskbv1+tfPmPxySXeQdKGqyQ/nq5rA8EJJd3X3r3YIc7GkP1P1y6Ifl/QLku4h6W8lPVrSA9z9RHtzrAJyYgAA0MWi5cScHQ19IicGAABdLFpOjG7W8UwQUj+/opw2jtz9m2b2M6qS3HeY2WslXSHpQZJuUT//uqTNpWb2fFX/QfEhM3uDpEOSHi7pWpKe6O5HYxszO0vS05KxXtPMLgyPn+ruX5m8egAAWHPzODdZT/Hc/TOSzutQ76gm/NbG3d8p6Z39jAZLjpyYnBgAgHaLmxNzdjT0iZyYnBgAgHaLmxNjF2s5CcLdL69n2P6yqtOH3U/SF1T9ivICd79iXnHc/Y1mdg9Vie+Pqtqx+oSq5PWF7uPnAHX3883sQ5J+TtJjVZ0N8QOSnuvufzFhaNdT9UvO6JTkuWermm0MAACANUROLImcGACApdNTDnOxqv9ovq2qy1+cKunrqs6O9kpJr5yUj2D1kBNLIicGAAAraC0nQUh7/xXltHGSNpeoSoSnafNySS/vWPcdyl9lDQAAZM3j1GR8NWPxkBMDAIB2i5sTc3Y09ImcGAAAtFvcnBh5xUEPAAAAAAAAAAAAAAAAoA9reyYIAACANi6p75Pfci5dAAAALBNyYgAAAKw7cuLlxSQIzMbV/7s0nv0ld2qZ2K95piyJ0RYyjRHajQ3DJlYbqxc/ENNhxLqWnIylsQrKUZCyaAYpilGZJeMviyLUKxtlA5tctlU0Y2wOhqMyGzTKtspR2YY14x8bjh4fKkK9cD8tOzzYTspGjzeT+IeLrXA/1Evib9pwYpu0LN5PHx+y7Uy9UdkgeSMMwpgLNcffVi+NkTNs2ZCH3tyWyrBtpWUxxpY3vwa2fPR6nwhl8fn08fFys1F2LDxO2x0vJ8fcLtvrHU/KYt0THcuGZXMd5MqG4U26NWzGH5ajsrIsJrZJy8qyWRZPnTVWFh7HeukWEuulhY1Tc8UyT8fRXtZsp3ZtfU3TrqtpvnO61O1Qp//TnAFYNaaQSk7xOWWZz9m2srGUNZalKUejrNkw1m3e71YvrVtsh3Zd6yVllisL+aUNk5WwHcua+VqjbpkMLMbcHrbXi1+Ww0xZ2q6tXk660zAYhKK0LOQuIffXRnMcFvpOR1iUmbK4PxT2EzzZJ4lpXpkcWchtn7ltq1mx5X6uSfJGGYTxx30cqblPcmTQ3Ge42uDEyftXHxw/ef8ag2ONelcPj69RfKdRdsbg26P41ox/JOyjHFJu/6R9n6Ho+KFTZlbeVthPOGHJ/kQsU/u+QNyfOJHk/puhbJC8F2KMY8n+RHzdjoUYRfI5lT23adu21RyiimR/ojVG2lco2w5Bi2Qb9LDcG8n++XbYZ8iVxZie7v83hpjsk4RtZC95LTkxgF1xnJjjxOI4scRxYonjxGmbtIzjxLu064rjxOiIy2EAAAAAAAAAAAAAAICVwJkgAAAAJmGGLwAAANYdOTEAAADWHTnxUuJMEAAAAAAAAAAAAAAAYCVwJggAAICUd7+M+zQxAQAAgKVBTgwAAIB1R068tDgTBAAAAAAAAAAAAAAAWAmcCQIAAGASZuQCAABg3ZETAwAAYN2REy8lJkFgJibJShs9aJN8MLhlPiliUS5mLPNMxbSrtr4tidGx70bXYzG8U5mXzTJraWfJuXbKYahWlEmM0f2iaJ7sZTvEL4p4vxlja3vQWjYoNsL9pCzE3whlab3NYjixniRt2OjxocF2a9lGiLFpSYzOZcNG2eFi1N8gtEvrFWHjGiTxi/B4kPlm7FovZxg2yNKL7mXh8ZYPGmVlaLdVDlrrxcfbZVpWTF22nYxxuxw9PlFutJYNM+22hoNQr/leG8YYyfuwbMRvlnl4XJY2sU1alp4qy0Pd9JVvfCaEQk8/62LDsTG2lI111h6jtd6kx11i5OQ2/45vDZum7zpmlxZj6x0AJvHkttbI3zKfpWMpaltZ9nO8ve80vrXEz9Yrm4WN1KjM1fP2su1M2bAM9Sbfr/rOlIUYGjZzuRhf26Fsu5l7xi9VHybxG/WSsrbzZJaZL7Yi3WcIj62ZZ9ggPN4Y5UlWNsfhYRzpKSDLcCigyPTtG+H+dnP8MUUrklVXbrZ/hzbS57idtbaYUNiyLzMYpPsuYf8hydvjvsbhon2/4JTixMn7Vx8ca9S7RvGdk/fPGHy7UXZqcfzk/SO21Sg7Ytvhfvu+y2Zjv6NRNNNpPbeSTXAr9Hc4yXu2wna36c31s6VRnn0ijj/ZZzgW3huD5H1yrNw8eT/d5zwW30OxKFnomHNnV0jm7TsM2/tmuu8eY6YfP6FuEd9r6YdpXLZknyHWTYfYKAuvjSXxY8R03yVqa0dODKAPHCfmOHF1n+PEHCfmOHHaJi3jOPEuOE6MnnE5DAAAAAAAAAAAAAAAsBI4EwQAAMAknOYMAAAA646cGAAAAOuOnHgpcSYIAAAAAAAAAAAAAACwEjgTBAAAwARc6w0AAADrjpwYAAAA646ceDkxCQIAACDl6v80Z5w2DQAAAMuEnBgAAADrjpx4aTEJArPz5HZHZkKU5WZLxaLMB4BbpjA3GSv23bEvjfXVEmOs39ETY+O1lhhJ3VhtPEYM1wxi4SI3w6RdY8ixryKp1zIOSSqKMtxvtitCu0GoN0jqNcvKZlmIUVh7uw0b3bek3kZLvaps2Bo/1o1lm6GNJBVqH2OjXtJ3NMhtxx0NM++n0otwv1mvDFvCVjlI2tnEettl0V7Pm2Xbmb6HIU4ufqyXLmejbGxc4X4mRpy5WZbJ+oljLNN24X6oN/ZqhviebAaNWaNpw9jOJz8/1i4TI/v5li3rOLO162ac+9juu6++2gHAXoXPn+zX/tjneLcY1ihLCrPfE/G+t9az8KWapjSNsjiOYZJTlvF+WhZiDJsd2HY58b7K9nrabuZrsa6lZbG/7e2Tdz2JH8tUpuu4bC3zuF7TmB3ZIORoRZKPxPzN42uR5vRxn8Ray8b6DmXFVsiZNpMYuZyj8donZd5SlttWx8YY7od9jXSpYs69OWhuB4dCjn+42G6UxcenDI6fvH9qcbxR70ixNbpvW42yU+3EKEbRLNsMK+hIWAnJKtah+Fo0izTI7vxOtpV8kAzDNpOWbYVt/ETS+1Ycs4/W47HMIaZB+oLGkMk2Umq0/suwDobpMmdiDMOOcdw/TPcfNsOylNYsi2MuM/ucyeAbtsMg0xhxvzLdb4r7mbEs3f+M+znpfnER1lep9HOKX7IB6BnHiTP9cpyY48QcJ57UN8eJOU6c4jgx+sYkCAAAgDGm/BGTWWMCAAAAy4KcGAAAAOuOnHhZpT8mAAAAAAAAAAAAAAAAWEqcCQIAAGASTpEGAACAdUdODAAAgHVHTryUmAQBAAAwCcktAAAA1h05MQAAANYdOfFS4nIYAAAAAAAAAAAAAABgJXAmCAAAgEncDnoEAAAAwMEiJwYAAMC6IydeSkyCwOzaTv+SOy1M7nOirV3Sxrp+2HSs5pYZsGWCdP7MG1uATv1lFzPEGKtnk+sl4Ztl6RBzZYW3FcmKcmJfloyjCDHi/bRu2i72V2TqDULMQRhTWrfoGH+sXqYsfdwoCxt52X0Daig7bv+xnmfapPEa7TL1Ysx8WdJfWYSyyX2lMdLxl2XXshiwfYxjfYcYaWGjv2z89rJmu7Tztvhq1/UzcZpTduU+pvrur49TiXE6MgAHqf4MMu/+YZRNB7vm2B1jpPHaysb6zX5fxfshJ0v7iolAMyVrflmmCUMsi/GHSb1hCFomOd/2cHI9SdreHoWP7cLzVbtRDE9jhLK0b88tW6NiaDcYJGXxxWl+91pLzPRZC+3Gvr1jzEESPyyrhdzNhkrqxTElZV3zmNj1NN/nLW+UNPfP5fSbxWgBNormwh0ptkb1woJuJivh1OL4xDZj7ZI3wKGwwo6EdXDEmifrLMLrtKnmNjLI7KsOw/ZThr6LZCWX4fEgKYt1i2T8ad2T/Wo48fnJdUfjHybLPQwnLY1lw8zJTMs0hk3e7xgky1KG9VgkG3Lh3cq6SrfB+FmRlg0bffvE56Vk3zTpL63b1g4AesFx4o44Tsxx4rqM48QcJx5rl3bOceKZkOYi6G0ShJldXdLd67/vlfRdkr4j6UuS/p+ki939n/vqDwAAYF5cyU5KTzGx+siJAQDAqiAnxqzIiQEAwKogJ15ee54EYWZ3kfR4SedKOqz2eY9uZh+V9LuSLnT3b+21bwAAAGARkBMDAABg3ZETAwAAYFHMPAnCzG4u6XmS7q/q5KbvlnSJpL+X9EVJV0i6mqRrSzpL0l0l3VvSb0t6ppk9S9Lvu3t6YlQAAICD5ep/Si5TfFcSOTEAAFhZ5MToiJwYAACsLHLipbWXM0F8WNUpzJ4m6VXu/oVM3XdI+j2rLkr6g5L+i6TfkXSGpF/fwxgAAADmY4ZrPWMtkRMDAIDVRU6MbsiJAQDA6iInXkp7mQTxNEkvcfdjXRu4u0u6SNJFZnZrSdffQ/8AAADAQSMnBgAAwLojJwYAAMBCmXkShLs/fy8du/sHJX1wLzEAAADmwSRZz6clY77waiInBgAAq4qcGF2REwMAgFVFTry89nImCKwz12ynf5nlg6KvT5eW4Vru42bWT6JMu86rLVfPZhuYt61LS+vFsqSNtdwfizlqNzbcGDMps0xZs177GBtFue0nU5ZbxZZbtq59Bz6HUyl5D2+bOK6xeI2y5vizXbfFTBpl10mjXdJ3W+dpvEzf2Tdprl3XGG3xpiizPuLPUm/eMaT9O7UY110DsJ9m/MzpnAaPfZflyrxbvcY4MjlTJkajXRojpnxp+Hg18GyMkJMNy9Yylc0yj4+Hw8n3JfmwpZ4kz7UrW9ZX5jLn6bdfjGCDQWvfVoSWaWIaHw+KpIPQwzDJpcvJZVa217PSkrLYl1p5bt+iY0qQy7mLUFZkBjJQ87WJdTdtGO5vN+ptalR2SM3t4Ehod8ia8Q+HZdsMr1ORvIabGoR6ze2gyKygjVC0HcZVJO+hMo4r3T4b4ZN2Ic5mXHeZ12zLm4ef4robJut1GAINwzoZqrkdlz56XCTreBAeN7aDZHuJr/XA0vXT8nmZaMZPt6XR+MtMnpuOq9n3qN00mbK1xACA3nGceKa+JI4Tj8XkODHHiSc04jhxvozjxH30sz/dYP8xCQIAAGASEmAAAACsO3JiAAAArDty4qXU6yQIM7uTpF+UdBtJN2yJ7+7O5AsAALDY+MUcZkRODAAAVgY5MWZETgwAAFYGOfFS6i3JNLNzJb1WUiHpqKT3StrOtQEAAABWCTkxAAAA1h05MQAAAA5anzNtny3pKkn3d/e/7TEuAADA/nL1f5ozTpu2Lp4tcmIAALAKyIkxu2eLnBgAAKwCcuKlVfQY6/skvYbEFgAAAGuMnBgAAADrjpwYAAAAB6rPM0F8UdJWj/EAAAAODjNyMRtyYgAAsDrIiTEbcmIAALA6yImXUp+TIF4v6YFmdsjdT/QYFwvKyr0G6FjPu1bcX7MOy7ouuM3hU9VmGPQ0TTrW9cyyZdfrYm4KSM2y6Wba2BRvtpneNrO+1ead+OzjZ988Pm721bzGv+zrBQeFnBjTWdDPmlyuP8v3RtrGPDzh3l4Wx5HUG3sclTFGZmEafSXxQjsfDtvj55TD3etMiG82OmmjKykbDCaPI1kfHh5bOt5YlrbrNOLu0vhtSf08Uh+bMckZhDfAIGyEh6z5WsTHReZNk56Cc9C4bxPvS9KmjWoWSdnA2k/sOfTRWDZib8n45aMYRbKuNsPDYbJVxJ4HoV2ZvNaD0G5s/fhAByFdzrhoRWbrHyTttvsc1KJb0O8pLDxy4jXDceLZ2nGcmOPEK4/jxP3gOHF3HCdG0OflMJ4l6euS/sTMbtRjXAAAAGBZkBMDAABg3ZETAwAA4ED1diYId/+2mT1W0sWSPmlmX5f0jclV/cy++gUAAJiLBf2FCRYbOTEAAFgp5MSYATkxAABYKeTES6m3M0GY2X+QdKmka0oaSvq2qpMSpX99nn0CAAAAWBjkxAAAAFh35MQAAAA4aH0mmr8haVPST0o64u7f4+43mfTXY58zM7MbmtlLzezzZnbczI6a2W+Z2TXnHcfM7mZmbzazK8zs22b2ITP7eTNrvSimmT3azN5rZlea2TfM7B1m9oBM/auZ2QVm9lEzO2ZmXzKzPzGzfzvN8gEAsK7M+/3rbVwHmMOgE3JicmIAAFYGOTFmRE5MTgwAwMogJ57YZuocZr/1OQni1pJe4+6vcveyx7i9M7MzJb1f0nmS3ivpBZI+KenJkv6vmV17XnHM7MGS3iXp7pL+TNKLJR2q2762pZ/nSbpQ0vUl/aGkV0m6laQ/N7Ofm1D/sKS/lvTfJX1T0m9L+htJD5X0PjO7c5flAwAAi+Ugcxh0Rk5MTgwAAOaInHgpkBOTEwMAgDlathzmIPQ5CeJKSVf0GG+eXiLpupKe5O4Pcfenufu9Vb04t5D0nHnEMbPTVCWnQ0n3dPf/7O7/VdJtJP1fSeea2SOSNneTdL6kyyX9e3d/irs/QdLtVa3v55nZjZNx/YKksyW9QdKd3f0X3f3HJZ0r6RRJLzUzTjcHAEAbn9Pf3h1IDoOpkBOTEwMAsBrIicmJZ0dOTE4MAMBqICfecw5zUDZ6jPVmSffoMd5cmNlNJZ0j6aiqmSnRsyQ9VtKjzOx8d7+q5zjnSrqOpFe4+/t2Krv7MTN7hqS3SfpZNWfJPK6+fY67fy20OWpmL5b0TFWzc55Vj8tCm/8WZ1u7+5vM7N2SfkDVa3Vx2/J1stc3aY+nfNmLWU89Y310nu17xh587yPr83Q8kmZ/rTu2m2qJu45l1u2iY7vGyzTNAswwrj5ez7HNKjfmUDaXt3nX9dXDm7SHt9Mc3lBp/PmGn1Uv6w4NB5zDoDty4t3jrFZOvO7KBUnqp9HzmD2N18cPXmOMMvl/iXhiyaL9C7d6G+xeb7zvlvWTWW+eDDGXB1jZcr/D0CZVjos5KPp5bYdhgYbhtyPDZEGHMyZigzDoIt7P/E5lMOP/T5UdM/JBsixd20Xp+ph1/QA55MRLg5x49zirlRNznHjvOE7cSzuOE+dxnHh2HCeeHceJ+7eEOcyB6HOW59MknWZmLzazU3uM27d717cXpadjc/dvSbpE1SzYu8whzk6bt06I9y5J35Z0t/o0ZV3avCWpI0lnSvpeSR9z9091bAMAABbfQeYw6I6cePc45MQAAGBW5MTLgZx49zjkxAAAYFbLlsMciD7PBPFaSd9SNbv0J83sY5K+MaGeu/t9eux3Wreobz/WUv5xVbNebq5qtkqfcVrbuPu2mX1K0i0l3VTSR+qdhBtIutLdv9DSh+o+phlX2mYiM3t/S9FZu7UFAGDZzWly9llt36/ufvtd2h5kDoPuyIl3j0NODADAkiAnJieeETnx7nHIiQEAWBLkxLPnMJm+567PSRD3DPdPlXTblnoHfXKr0+vbSYl3fP6MOcSZts1+9AEAAJbDQeYw6O6e4T45MTkxAADoFznxcrhnuE9OTE4MAAD6tUw5zIHpbRKEe3oV0KW1c3WavSbhs8SZte+59NE206iemXS7KfoEAGDJ2BwuWGeSdFmHmbx76kAHk8OgRk7cSxxyYgAAFgI5cQ9x1hI5cS9xyIkBAFgI5MRTxlmYPLrPM0Esi50ZKKe3lJ+W1OszzrRtdqs/abZNX8sHAMB6O/A0bcxB5jBYPeTE420AAECKnJhcYbWRE4+3AQAAKXLipcwvVmVW7jQ+Wt+2XevsZvVt2/VP9hKntY2ZbUi6iaRtSZ+UJHe/StLnJF3dzK6/1z4ybQAAwOI7yBwGq4eceLwNAABYfOTE6BM58XgbAACw+JYmhzlIM58Jwszu4O7v20P7I5Ju4u4fmTXGjC6ub88xs8LdyzCma0g6W9J3JL1nDnHeLuknJN1X0muSeHeXdIqkd7n78aTNo+o2L0va/HCos+NySf8i6eZmdhN3/1SHNjOxLjOf5j07qvdT0HRcrrFx9FO3dWly8XPxurabJkZY57PGt1zf3lJvUt0WXceVjT/rOPrfJA9M4+2VLld4nJ7ksvPbMsbIxE/7zo6rc/z2FzE7/ray3BjTwlniJ7JvhRnWf7avGbfpbLOZPmj76nwKizfD9yBzGLQgJyYn3rP0M2tBPnvi97uVSVkYsxXhQTnF96uFnNIsqRvKYp5Rpt+pNvm+JMVxFUmyUoQFigMrkhjDGD4ZY1w/ycJ52Ri0Wlm33yTYIKk3GLRUzKyfDB+k6y4unLXXi6u/j+02m2Nntq1QlG6CRceB5ept+WDi/erxRntZeO1LGzbKToRBb4YFL5M3WxlW8la6bJmEp4wxwziG7km9UJa8AOnjNsOw/ZfJe6Hs4Wz4ZfjtThp/OEPSl8Zo9tVeNpzDsYdG33OOvycL8r0UkBMvIHJicmKOE8dx9FOX48TNxxwnPlgcJ87HzD3PcWKOE8/JsuUwB2Ive6TvNbM/M7M7T9PIzE43syermgHysD30PxN3v1zSRZJuLOkJSfEFkk6V9Ip6dq3MbNPMzjKzM/cSp/YGSV+R9Agzu8POk3Wi/6v1w99NYv1efft0M7tmaLPT73GFpNfdPbT5n2ajI2tm9mBJPyDpnyW9UwAAYGkccA6DduTE5MQAAGCfkBMvLHJicmIAALBPljCHORAznwlC0k9L+hVJl5rZxyW9VtIlkt7n7l/bqWRmA0m3kHQXST8k6YGSjkh6vcZnrO6Xx0u6VNILzew+kj4i6c6S7qXqlB5PD3VvUJd/WtVGMGscufs3zexnVG0g7zCz10q6QtKDVK2jN0h6XdLmUjN7vqRfkPQhM3uDpEOSHi7pWpKe6O5Hk3E9X9IDJJ0r6e/M7G2SvlfVzsS3Jf1UnM0DAADGzXsi8owOJIdBFjkxOTEAACuLnBgdkROTEwMAsLLIiUdmyWEOysxngnD3l6q63sczJV1N0n+X9FZJXzGzY2b2BTP7mqQTkv5R0v+S9CN1nbPd/eHu/pm9LsCMY79c0h0kXajqhTxf0pmSXijpru7+1XnFcfc3SrqHpHdJ+lFJT5S0pSp5fUQ9Qzdtc76kx0j6oqTHSvpJSf8k6YHu/jsT6h+X9B8l/bKkMyQ9RdIPSnqjpDu6+991WT4AANaWz+lvr8M6wBwGk5ETkxMDALCyyInJiTsiJyYnBgBgZZET95LDHIS9nAlC9ekvfs3M/oeq5Ok/SvoPqmaTXlvVdUI+IelDkt4h6Y3u/rm99NmXOrE+r0O9o8pdgqtjnKTNJZLuN2Wbl0t6+RT1vyPpWfUfAABYEQeZw2AycmJyYgAAsL/IiRcPOTE5MQAA2F/LlsPstz1NgthRnzLrr+o/AACA5bcQ81WxTMiJAQDAyiEnxpTIiQEAwMohJ15KM18OAwAAAAAAAAAAAAAAYJH0ciYIrCE3qWw9c8pMbJaZVNO06Vg3u1RtMTKxs8uVlrXUHYvhlilrj2dtZV3rzVhmZfsYs2Vp/HJyvbFxlKMncuun67qbKkZbvETX7d1nfZuFdmMxMjEbddvu5+pJ8iLWSwpb2nkyJa8RP1OWtmuNOTb+zErouu5mqDdWN9kQWl/vdDV2fQ0zMTqXdTVNjNwCtJjqvdDl/dUh4EzfSwAwSfqRM0MekP1MmuJ7qPEZHINmv1uahRYWoDHGzPft2Ee/TY4hSRa/w8tMB+GxF8kYM+2sGHXQWK3JJStjq3T123A4KhsMkmGF2o0V1P03CDYIddP4sWxjo7WewnI27kvSxqC1zAdhvW7YxOelfD7VXAWZfDCzXee+qq3lDeFJo2E5WrYys5GXSbtYd8tH6+qYbzbqxcdHfKvZt22fvH8iSVoLjXZsjoX7w2SFxMebSl7fjFLpTtbk+I02yfa/FR5vJXW34voJyfqJJHEftqzHqt0glDUPTcXHw7Duhkn8MpSVyToeNsps4v1Jj7uWzVu6LZ98vocY0yInBrArjhN3js1xYo4TT8Jx4mSMHCeeHKclBseJd6vcT0By4uXEmSAAAAAAAAAAAAAAAMBK4EwQAAAAkxzgr/8AAACAhUBODAAAgHVHTryUmAQBAAAwCac5AwAAwLojJwYAAMC6IydeSlwOAwAAAAAAAAAAAAAArATOBAEAAJAwr/76jgkAAAAsC3JiAAAArDty4uW172eCMDMmXgAAAGCtkRMDAABg3ZETAwAAYF56SzTN7A8kPcndj2Xq3ETSayTdpa9+cXBmmqnUtU3HetZH38nz2eWaJYa3j3KsL598f6xe2S1G57KyWS2WWVKW67tRN9YrmxU7x0/H1dL3WPyOMeTt4+q+HpMYw8n1JtWdhVvYnjJvAI9T3LL1moWNzdVanpekMI60LPbtRboSJvftyZS8ZoxpykIHuXpxzJmytF0jZq5elK6fRt/d1n/2NUzKLGywmY+fzvHHyqb64J2s81shbu65Nj2MaSJm5GIG5MRrqP4M8uTDKPe975nPt9ay3OdxJka2XS6t6Bwj5gTJQML33Nj6KG1ivSpQMemuNEjyLg3UJrfq1FLmG+27x2MxBqHv4bBZNkvOZ0kPxWjBLR3XoKUsrbcxGqNvJOsqxPdBko8M4vpv30i65mtjuVZbnprZtxhLx8NG3nZfksrwuEzKtsrROtny5vqJj8sw4BPeXMfHys2T96+yQ42yTd8+eX+QSSrKsAO0mdTb9NG2tTm247R3MeIw2W6PhYdbyYt/zOO6K8L9dD1uTLw/Xta+/odhAyqTDW0YxtU1xjDZIGPMuE1IUimbWG+8LFMvsw22xUjlyjwTPyd9r+Qrd68K7CAnXj8cJ+4Yg+PEHCduqTsLjhNznDjFcWL1MqaJyImXUp9ngvhpSe81s7MmFZrZuZI+IOmOPfYJAAAwFzunOuvrD2uDnBgAAKwMcmLMiJwYAACsDHLi5dTnJIjnSPp3kt5nZuftPGlmh8zsJZJeJ2ko6aE99gkAAAAsEnJiAAAArDtyYgAAAByo3iZBuPszJf2QpG9J+l9m9kozu4Ok90p6nKRLJd3G3f9PX30CAADMjff8h7VATgwAAFYKOTFmQE4MAABWCjnxUurzTBBy97dJurWkv5H045L+TtItJf2qpHu4+2f77A8AAABYNOTEAAAAWHfkxAAAADhIG3OIeaWkL0uy+vE3JL3L3cs59AUAADAfzMrF3pATAwCA5UdOjL0hJwYAAMuPnHgp9XomCDO7taQPSPoxSX+l6vRmhyS91cyeY2a99gcAADAXLlnPfyTL64OcGAAArARyYuwBOTEAAFgJ5MRLq7czQZjZEyQ9t475S+7+G/XzF0t6naSnSbqnmf2Yu/9LX/3iALW9STu+eW33KrvHy5RZ13bTxHCbXDbFGBvtykxZblyh3dgYM2Wx3Sz1qjKfXE+SDVvGOBZjcjxJKlpi5PpOY9h2pizXbhgeh7vmaYzwOP3tQqg7vv20vKjTfOG1vXGsWeDWXhanv3nargiPLdZrhvDB6IlGmzR+UuaD0f2yESOJX2TKBpPrVTE9lE0eU1o2Vd8tMcfq2eR6aVnazloepOu/ETMtC69p+tK3jjHZWGNZLkbug3xszLFZ15iZ94a3PsjEA/YBOTFOip/jaZFPrpeLkQbJfddbI5HJxLT4nTc2ytBZpvNYNkjG4fF7uT1fGJ+bP0qwLJSNf9wPQ73BWGlbO7PJX3RWpslnXD9J/DL0PWjvuzmQzI9e0/8HGoTHSXwrWso2m7v3Hh+PlY3a+aDZdyMXCq9puZHmdaFskJaF+1238Vy9NEgZxhhe4GFSLz7eLpvLuR0SseNlc/0cKzdP3j+lOHHy/pY3X4tjPqq3GbYJSboqbJ/pJj4MC7sVtvfNZBs5FHZeirZ9iQkGHfOfYWa35lhY1q0kaT0RFiiug3T9bPnGxHpScx2fSNqdCO2Ol5n44XVLy8qW1367TMdYTGwjNbeftKxsKSvVXs8zMVJtZbk24/Hby4B5IydeQxwn7hSD48QcJ55U1nx+8tMTcZyY48RpTI4Tc5wYDX3OuH2RpC+puqbbb+w86e4fl3QXSS+RdFdJ/9BjnwAAAMAiIScGAADAuiMnBgAAwIHqcxLEmyTd1t3/b1rg7ifc/YmSfqTH/gAAAIBFQ04MAACAdUdODAAAgAPV2+Uw3P2hHeq80cze31efAAAAc8O12TADcmIAALBSyIkxA3JiAACwUsiJl1KfZ4LoxN0/s999AgAAAIuEnBgAAADrjpwYAAAA89LbmSAAAABWiTHDFwAAAGuOnBgAAADrjpx4OTEJAgAAYBKSWwAAAKw7cmIAAACsO3LipcQkCMyuftPbDG32Uq8x4yoXr3MMay/LxQz3x9qUmbJcu7ayslktlllS1ug7bdco80710r6LYSb+cHLM2Gas76Ss2PaJ9dK6tl2Gepn422V72Vj88LgM7cbihyc8eREbr31SFh/H++UU36BF2F4t8+4LZZ7WG7TH8FhWFJOfl+RhHPF+Gr8cNK+65BuxLPbVDFFutMf3QRxH0q6lbHz8k9tUY/GJ9XJjTj5Gmu2K9rK0XWvM9OJVcTvL9R3K0r4a7ZIg8dHYGMMH0FhZa/ykML4VMmW5LxhrfZCJN/4QAPau5TPIQ8FYThA/n9NwbZ+RyXdBI/9JvwviE2nC2fb5PPZ5H/tu/7BujDcJUoa9zWI7CRH3RNOysLAeOki/DhtLliSEjZGkuUQR8sj4hVWmie+oR9tI1uMwJKbp6xv7ypRFNpavhQSlSJY85Fe+EeoNkqQmlPlmsyw+TsvKzVH8mPuM5WSNXKvZdVtOJqk9P5ni+7xZFvLLstnZMDweJgM5MRwN8sSgeWjkeNh4j5WbJ+8XYztf7YZhgcpk692yrZP3N2073G/uHB3yUX/FFD89GnTc7hpjTJKyE2HMW8kLfMw3Q9loXZ1I6sWy2CaNecLT9b85sV58LSTpeGi3lST18TWMMcpkQ9sO7baSbSSWbY+VFaFsMPF5qble075jmXumLDyfq5fT1o7cGEBvOE7c3objxBwnFseJJY4Tp/XGxsVxYo4To3dMggAAAJiETBgAAADrjpwYAAAA646ceCmlc4YAAAAAAAAAAAAAAACWEmeCAAAASPkup72cMSYAAACwNMiJAQAAsO7IiZcWkyAAAAAmIRkFAADAuiMnBgAAwLojJ15KXA4DAAAAAAAAAAAAAACsBM4EgZnZzp1pZkBl6raeTiZ9vmsMt4712uOPjamlXa5etqzsVpbWy5WpUdbsvK3dWPxhe1kx9In1xspi/GFzHMV2ewzbHjUsknbWaDeqN7acIYbSGMNhuJ+8OGVsV05+PulbnsTIlaWPW+J3VoR5bJZs7+GxFUlZaOeD5lw4izFjWdGs5xvFxPtpXUvKfDAayyDcL5NxFBuxrDn+GMMHybbViBnbNIfocdWNxZ9cT2puM7FsPL5NrCc1X6q0rPE4jrHM1Es/6rylLK2XKYsfn+mm1Xii/WO28eGX+TieED8OZPKY9mKsv7Z66v80Zz0tAoAF4hp9Po29x9s+j/NFrR8WYx9JsV76XVO21NP4d097x7kPwfB9G/Yo07wuKpM9z0a+mXw4FzGfCvXKZEEbzcr2XCgts7ZcaJh84Zbt+WYj0ciwtvxvrGL3fK2Rl20MQr00pwllm0lOtjkqKw81y+JjDzlZmu/E1zRdHTEXSrfPRt2uP8tI0+ph2AZDkjCemo862Bo2B3liMFqA7ww3G2Ub4U00CDtYZebbvEzeXMPwOC07UmydvL9p26PnbatRbzO8UQY+4z5DxjDzAmyFF3zLm2/gEy1lW8lG0lZPko75ZihrtouPj5eZemWs14wf627HeMO03mgdbCcb8najrEjKwnvIJ2+PUrodJO/RTLu4KefiN2OotWxW5MQAuuI4cbd6HCfmOHHr45b4nXGcmOPEEseJp8Rx4tXHmSAAAAAAAAAAAAAAAMBK4EwQAAAAk3CtNwAAAKw7cmIAAACsO3LipcQkCAAAgElIbgEAALDuyIkBAACw7siJlxKXwwAAAAAAAAAAAAAAACuBM0EAAACkXLK+Z/gyYxgAAADLhJwYAAAA646ceGlxJggAAAAAAAAAAAAAALASOBMEZufJ7QTZ2VEzljVius3WX7g/1qal3njf3WKMlZWhrGwWNerm6jXKPFOWtBu21Bsm9ULMIi0bdizb9vB8Um971HkxTMbfaFcmZeXEsvj82OMyWQnbw1AvGVisG/seNut5rJesf5XD9jJPxtJWLzbx9jKzsP0XlhSGOW6DZL7bYBCqtZc12sXnJWkjxEjie6g72EjKwuN43wbN5fShhbI0xqisHCTLXYTtJ9TzZPhleJy+T+LL68l6jXE8DCt9aT0sjyeruBGz42dH8lHXbJdOZ7QO95PHaXzLtIt1c/WaFdO+w/pJiv7/9u49XJaqvvP/59v7HEBJOBrHRDQq6AROxsswimNyjIAQM+ioxBF/8iQm4C2XSZygThJHRMhMkonR8T6jE1EPRkdw8JFMjJpfBoKgOGYgIcQoIMjRn4KiYiCIB87u/v7+qNrsVatrra6urt67u/r9ep5++rLW+q5VVd3V3669dlXlhTBEXDGMGX/U4v7aYkYugFlUdvdRzqrMfjDYr8ffUaHK90tcr/LdEPU9Sn9HVWV2tI3r5b4LgheiXGgULIBZ4stRquQ/HufEQZmNolwiyD+tkv9FMYI8zOOcsjLg+Iuo4RdINpcLlm0sX0uURXlRmGuNopxsdNBmUjPaWW03CnOtoGwY1wvHEeVa4Xsw9z7zQeazEMp8t/soGG+0rdeHm88PRGX3DDcPh+yIPmzh853hj571at/DYOEODO6tlB0IVsqBaAUd4gc24wc/lnZatYODMmVdG0YbKvwc3huN/4DvCB6vBfWqh5hGQVK233dGMYL1M9qRLsusx/Vgm94ziuMPgnprta/HZetjZUGMqO9w2cJ6Y+sxqDccZcqiBDYs88Tjop6SZeHzUVymKZATA2iC48SNYnCcmOPEQUPV4jgxx4lrnnOcuNqO48RoijNBAAAAAAAAAAAAAACAXuBMEAAAAHWY4QsAAIBVR04MAACAVUdOvJSYBAEAAFAje+pMAAAAYAWQEwMAAGDVkRMvp5W8HIaZ7TGzj5vZ7WZ2t5lda2Znmll8JdO5xDKz083sr8zsLjO7w8wuM7NnZerfz8x+x8yuN7P9ZnabmX3YzH48Uf9UM3u7mV1hZneamZvZB6ZdNgAAAPQXOTEAAFhVXeRBZnZEmV+kbhfMcxnQDXJiAACAflq5M0GY2SmSPiJpv6QLJd0u6dmS3izpKZKeP89YZvZGSa+S9DVJ75Z0kKTTJP2pmb3c3d8R1T9Y0l+U8a6S9FZJDy9j/2szO9HdPxd181pJ/1zSXWU/u5suEwAAKDHDFz1GTgwAABrpYU7cZR5U+ltJF9e8/vn2o8RWICcGAACN9DAnXgUrNQnCzA5TkVAOJZ3g7leVr58t6VJJp5rZae4+caZ2m1hmtkdFYnuTpCe5+3fL198g6WpJbzSzj7n7vqCrV6pIbC+S9AJ3H5VtLlTxA+u9Zva4jddLr1CR1N4o6XhJf9l8LQEAgD4r85HXSvoJSYeoyBfeK+nt7j5sGOMISTdnqlzo7qfNOFTMCTkxAABYVV3mQYFr3P3czgeLuSInBgAA6LeVmgQh6VRJD5b0/o1kVJLcfb+ZvVbSJZJ+VVKTHzptYv1Kef97G4lt2Wafmf1XSWdLepGkcyTJzCxo81thAuvuf2JmV0h6qqIE1t3ve1yEmAPXfTOfstfCaVlWienpZRjr2xOPx2K2qJfp20ZRYcuy8HmlbKye19fLxZBkw/qywdCT9bJl63GZ1z7O1lsfJcsGB6p/i6vUDR7bMPqb3frmc1tPl2lU7dvX1zefhDGH0YoMytw9WTYWP6w7yn04Mgabn4cwwthnfRBc7WitetZFW9ss86hMg7XaetpR/bqwcNkG0ZWVdgRloyj+KKg7DPraUV0fo6DeYK1a5kGZrVWXe7Rj8/kgaOZjn8NgPcbbMCyL+w43Ydj3NPu6MEi0fwv3K5Vh5S5eFccP61ri9ajZ2L40XLTorVV5q2XqhWVxkQevjPftQb12ct98PvYgXbHza70twIxh/usNJXLirpju2+lkdqVjKvvBqGXlWbDvHsspwzbx90RYd+w7JPX9lUt84y+D8LFn6gVlw3SZR+3Cp5X8dRB/b4Y5cTT+9fR3faXuMFhBUb1q7lYNb5Xv8ziXSKzL3PswKvMwz4jLwnxwx6D2dUlSEGO0o/pGGO0cBGVRPnXQ5vPhzjAvqoYPn8dlYQoYvz/D55X8YZqPaeI32zB6n60HeeO969V8di14D65FH7BB4gN3IMqdh8EH7EC0Eu7xHcmy/X7gvsc7gzd5+FiS1oI33k5br5aF44/eoMMWVz4dRsncKIgxjDZiuDwHMss5DDbqgVF1/VdjrCXLwm0Y11sPY4ziskFt2Xq0LGH8UbQO1hPjiOuG6yeu50G9OP4wUxa2G1bGqGQ9j7dhWFZttlk3c7xlo2EPc+Iu8yAsN3LirnCcmOPE4jixxHHisb4kjhPHOE7MceKmfaIT0/8yXm4nlvefrCm7XNLdkvaUpxabR6xcm09EdSTp0ZIeIekGd7+5YRsAANAF7/i2zWr+O+kl7v6bko6R9FmV/500Zdhr3P3cmttF3Y4eHSMnBgAAzfQsJ1a3edCGh5rZL5vZa8r7x888SmwFcmIAANBM/3LilbBqZ4I4ury/IS5w93Uzu1nSYyQ9StIXu4xlZodKepiku9z91pp4Xyrvj2rSR6ZNZ8zs6kQR144DAGD58F9v2EBOPAVyYgAAOrc79f3q7k+cc99d5kEbnl7e7mNml0k63d2/2n6omDNy4imQEwMAgGWzapMgdpX3dyTKN15/wBxitem7y/ECAIBp9G9WbuP/TnL3exrGfKiZ/bKkB0n6jqTPuvu1sw8Vc0ZODAAAmulfTtxlXnG3pP+k4vJwXy5fe7ykcyU9TdIlZnaMu3+vzUAxd+TEAACgmf7lxCth6SZBmNk+SY+coskH3f2FTcOX9128ndvGmqZ+l+MdH0hi9n058/cJ8+gTAICe47/e0Aly4k76aDYQcmIAALp23Sy576LkQe5+m6TXRS9fbmY/I+nTkp4s6aWS3tp0oJjOorwX5hiLnBgAAKClpZsEIekmSfunqH9L8HhjRuyuuoqSDovq5Uwba1L9utm8XY4XAABMwSZXWTb811u/kBOn+wAAAB1Z0Jx4UfKgWuUE4/NUTII4TkyCmKdFeS+QEwMA0GMLmhNjgqWbBOHuJ83Q/HpJx6q4NlrlvzDNbIekIyWta/Ngfmex3P17ZvZ1SQ8zs8Nrrvf2Y+V9+N+Z15f3qWu51bUBAABdmM9pzvivN3SCnHhiGwAA0IUFPPXvAuVBOd8q7w+dMQ4yFui9QE4MAECfLWBOjMmWbhLEjC6V9POSTpb0oajsOEn3l3R5w+tgt4l1qaRfKNu8L2rzjKDOhpskfVXSUWZ2pLvf3KDNljBJtvGhz334M2WWbWfpeg37y7ZrWi9io0Q7T9fLlVXqxc8r9TxZLxfDhumywdCT9bJl62FZNK7gebbe+iioN0qWWVSmsGwYDOzAehQjKFuPFmB9s64P4/hBnCC+D6MYlbIoho+Ch54sq74ev0ky8wptEDzcrOfB63FMG1X79dFaUBb1vbb53D3oKzfmHWuVorBu/HGysN0oXS9cmpGiZQsbRmWDRK1YtZ5FZZ4sC+U2U/OpoR49C/Z9TSNEqyf8nIdl8b4i7CCOUdlHpotS4bL1pGj/GTWsroN0lLZ5p0X3S2hR/tOpFv/1tjTIiTu0kbbm9oO5fY5HpeG+r7Kvy+2r43RkUF+vpvNKz9WB1H9nS5VUXRZ8IVqUWFfKMt9Xcb5ZyREG6d8FYR4zlm8Ogudxu7DujiDG2O+CTIxKTtPwW2mQfid4nFhU8ryo8lpQNqh/LEmjHUHZWlS2M102DMpGO+vjFc+D8UcxPEgPx/KM8HnDL2QbRfGDleKj8HG1s+Fw8/n6oFp272BzkAPbqZRRsACjaGOEz9fXDlTKwv4ODKr58sGDzf52Bh+AtejDHJbtjD4og7HkbrLR2MZIGwYbJ253INjAw6AsfF2q5tIHRtWyYfBGWB+l468Hj+MY60Hfw2jbrI/WauvFfYXLtu5x2WbMYdwuWLYwpo+NIyhTVS5+GCfcxcTxq/WiskS9uucrpss8KOcnyvtZJ1NgfsiJO8JxYo4TF2UcJ+Y4sThOXFuYKavgODHHidG15r+A++EiSd+WdJqZHbvxopkdIul3y6fvDBuY2S4z221mh88aS9K7yvuzzOyBQZsjJP2apHsUJL3u7kGbPzTb/PYys1MkPVXSFyR9Kr/YAABgGhsHcTq9dTAudz/J3XdPcfutoHnyP4f4r7eVQ04MAAAmWtSceEad5UFm9mQzOyjuwMxOlPSK8ukHuhw8OkVODAAAJuppTrwSVupMEO5+p5m9TEViepmZXSDpdknPkXR0+fqFUbPnqkg4z5d0xiyx3P1KM3uTpFdKutbMLpJ0kKQXSPohSS93931R/2+S9CxJp0r6nJldIukRkp6v4nrcL3avThs0s5+V9LPl04eU9z9pZnvLx99293+fWVUAAKB/+K83SCInJicGAGB1dZkHSXq9pMeY2WWSvla+9nhJJ5aPz3b3K+ewGOgAOTE5MQAA6LeVmgQhSe5+sZkdL+ksSc+TdIikG1UknG8rZ9XOLZa7v8rMrpX065J+ScWZeP5a0hvc/WM19e8xs5+W9GpJP6diJvmdki6WdI67f6FmaMdIOj167VHlTZK+IonkFgCAFFf313rrOt70LlJxoPY0M3u7u18lTf5PJ0mHS7ojvE6tmT1Z0t+4+71Rff7rbUmQE0siJwYAIK+fOXGXedAfq/ij+JNUXIpgp6RvSvqwpHe4+xVdjx3dIieWRE4MAEBeT3PiVbBykyAkyd0/I+mZDevulbS3i1hBm/NVzBhuWv/7ks4pb03qnyvp3GnGBAAA+o3/ekOMnBgAAKyqLvIgd3+PpPd0OjBsOXJiAACwqsxsj6TXqjiz78YEzvdKeru7D+cVy8yeIukUSU+TdISkwyTdIukSSX/g7je2X6pNKzkJAgAAYKIezsjlv94AAAAwlR7mxAAAAMBUepgTm9kpkj4iab+Kf4y7XdKzJb1Z0lNUXG5rXrE+IunBkq6U9EFJ65J+UtJLVJzF+Onu/tm2y7aBSRAAAAA1rIfJrcR/vQEAAKC5vubEAAAAQFN9y4nN7DBJ75Y0lHRCcNnksyVdKulUMzvN3S+YU6w3S/pjd78livUaSb8n6Y8kPW7GxWQSBGaQ+tAHr2d3DG7Jokq7OEYmZtN22XphvFGz+HG9XFnleXaMHjxOjyMXf7zME/WiDhLjGBtzPK5hGN9rX59UpvD5qLoAFj4fjoLX4zE2/EbyeMOFITx8ki4bCxm2i+I3HlemXnDWIA8/Q9GbxLS2WW9QDRFu03hZLBxzEN+H0bawoO9h9FkOy0bpMhukt3U4DItPujRYCyrG2yaIn96E2fd4KkYxzqBd5YNoyXpjwqpj4wq3jSXrje1zwhCD+npj74PwSfxWDevGfaeLWtXLt8t8TwRRx75OvFIxXQYAXSj3M/HupbI/y+yL4u+ayvdQkFdk449914fxlJbbXwbf4fH4K7lXWBZ9H1a/k6Kco5ITxPHrxxjnBJV6a9W+q/lytBISOXGskiOM5eOZFRvGHCRryeP8ISwbBOs/iuFrVlsv7issG+2Itk2QTsVlox31ZaOdiuqF8eO+6x9L2Z+BUcXEY6myjj18r0bBR0HZ+qg6kMFw87nZmlLCmKPog7IeLNyBaEEPHuwIHq9XynYMhrVla1FStjOoN4hWwlruzdvCMN5QgXi5h5Xl3lx3o3j9B8/DekVZet2FZZV1PIpjWG29sbKg3dg2DN4X8fjD5RwrS7Qbj5F5f2bLVFuWjaGqXLuNXRipMYDOcJw4WY/jxBwnro3PcWKOE0scJ56A48RzdaqKMzG8f2PSgiS5+34ze62Ky1L8qqSJkyDaxHL31ydivV7FJTUea2YPcvfvTLdYVUyCAAAAqLPaiTAAAABATgwAAAD0Lyc+sbz/ZE3Z5ZLulrTHzA5293u2MJaruDSGVJxZYiZMggAAAAAAAAAAAAAAYGvsNrOr6wrc/Ylz7vvo8v6Gmr7XzexmSY+R9ChJX9zCWM+X9IOS/o+7/8OEuhMxCQIAAKBG3671BgAAAEyLnBgAAACrroc58a7y/o5E+cbrD9iqWGZ2pKS3qzgTxKsa9DsRkyAAAABiru5Pc9a/ZBkAAAB9Rk4MAACAVTe/nPi6Wc74YGb7JD1yiiYfdPcXNg1f3nex5BNjmdkPS/qEpAdL+jV3v7KDfpkEAQAAAAAAAAAAAADAkrhJ0v4p6t8SPN44O8OuuoqSDovq5cwUq5wAcamKy2r8hrv/twZ9NsIkCAAAgBo9PM0ZAAAAMBVyYgAAAKy6RcyJ3f2kGZpfL+lYSUdJujosMLMdko5UcVmKL88zlpkdLukSSbtVnAGiswkQEpMgMIvEhz67M3BLFlXapR5P6ivTLhk/E7Nx/Gn66iB+47JIalzxOHLjN/f6ei3Fb4n0OyQTY1BtZaNMFAvKbFAtGwTLFtRzi+KvrW2WaVgt02ZZvHA+8vBJeoyVRvEGqF82G7RZc0tii5ctfF97vP6Dd2i1XlQtux/M1Gv4GfXkk2hcDcc0tobDGHFhOK5m4cfie8OGlWqZIJYJsoD5KYC+SXxN5fZ1ud1gpSz8Dhz7zkjt8JX/rmlYLxy/xWlLmCeF3wvRF1blO2ksX6uvN9ZfGD9K3bI56zBRT6ouXOPcOb1sOZmfP1FnUd4YPo2WO1yXvlb/evE8XTbaET6OysKYlXrROCp9Ny+rvMnbpnnhCgpy/9GwGnBomwOJ0+j4/drEKBrwKBjH+qi6oPeubb4J7xmsVcp2Bm/y7w82661FY9oRvJEHUdmaRsmyNkaZN+swehOGdUfBBo7Xz7CyfqrrIKw7jPoO64b14jGG63wUvdHWw3F5OsYwUS9+Phyl14EnXpckz8aorxc/T/VV1y5VFv9eybUDgFY4TtyuL44TV3CceAKOE3OcWOOfNY4TV1/gOHFjl0r6eUknS/pQVHacpPtLutzd75lXLDP70bLtP5X0K+7+R9MuxCTx4QgAAABIuu96b13dAAAAgGVDTgwAAIBV17+c+CJJ35Z0mpkdu/GimR0i6XfLp+8MG5jZLjPbXZ69YdZYj5D0KUmPlvSSeUyAkDgTBAAAQL3FSEgBAACA7UNODAAAgFXXs5zY3e80s5epmMBwmZldIOl2Sc+RdHT5+oVRs+dKep+k8yWdMWOsT0k6QsXlMx5pZufWDHOvu+9rvZBiEgQAAAAAAAAAAAAAACvB3S82s+MlnSXpeZIOkXSjpFdKepuPXwOmy1hHlPdPLG91LpO0r+kY6jAJAgAAoEYX17MEAAAAlhk5MQAAAFZdX3Nid/+MpGc2rLtX0t6OYlmTerMabEUnAAAAAAAAAAAAAAAA88aZIAAAAGKu7q/11tMZwwAAAOgpcmIAAACsOnLipcUkCMwsexqY6Iwm+bqJx7n+4nqeqJeJ2bTexPgz1ivqevA4E6PhDtIaXrInPvFM7jw0bkFpNDAbbJb5KHw9GscoiDGIelsLnnv1ZDXhU1sLYsbLOQgqrkVl4TqOyirPdgZ9RWP04ebCmUXjHw6DrqL3f7i+ujjbjwXLOYj7CtdxdNKftbXNemvpMg0y9SrrOFMWr5/wPVJ5L8Vvwi05G1I5kNnrxp81Dz9FbfdTQcyxs0OlP4bVj0OuXiLe2BjjImtYT2mVEA0bZvdLcanV70tr+0swNd+HNrWF72oAW+i+/Up6VzTeJqyXKcvv73PfNZ4uC2MG+drYLi8zSE99l0Xf39V60XdlmC6MKkXV3Kvh9+ZYjLXKs3S7zLqqxkzHyMrs/Cupbhy+kiel23mYWw1y9aployDn9rWoLDhKEJaNdkTbN1FvrL/cuMKQ8bpq+sUZ/rYYxe/BzefDYZwvR4Nu0lWUSKyPNhfmwKAa797R5u+Cg6KyHYPNN9eO4I02iN7kg6BsZ/QmD+sO4g9AB0bxm6ZStrkeRsGGGkbrJ4wRr7uwXW69VmIojm+1baTqts/1NRxlxhg8jz/ylTJPx6+WKVkW5/upvuN61Rjp+LGmZ58lJwYwLY4Td1OvqMtxYo4TT4HjxN3gODHHiRP9kRMvJy6HAQAAAAAAAAAAAAAAeoEzQQAAANThtGQAAABYdeTEAAAAWHXkxEuJM0EAAAAAAAAAAAAAAIBe4EwQAAAANbLX6gQAAABWADkxAAAAVh058XLiTBAAAAAAAAAAAAAAAKAXOBMEAABAHWb4AgAAYNWREwMAAGDVkRMvJSZBoLXk6V/cmgVouNMY68cTj9uKYliL+NOcCmcrT5vjVt0WFi5QZjOFm9DiepZ4nGkXj6NyDpr4/TIInq9F4w/rehAk2pOFqzj7bozXjw03Y4zSK8HWgh6Gw0qZ1taCgUQbezRKlzU1tkFKg0FULag3iNqEY4zjBWUWxgzbSNJauszDsh1Ru0rMzb492tYejNmj8XvuvWX19bJvhMz7eFLd5DgWRLi/yS5XvB8Mi7pYtMzbPQ6f7C+OkV2e8PNbbdh4H+xz2F+TLAP9Y0p/N0TVxtpt1MvkupX9eDrEeN+VRCwu9KBefV9j7TJl4fjHvpYr9eK8LiiLzk9oXr/g42O0TFmm3Yz1ptIw545XXi6PCddX5XEcI1FPknyt/rEkjSo5Wq5euizb96DZb5Jqo8zz8O0yqgYcDcM3eXUgcRqf7DrYGMO1UaVsbbD5fBjl4+vBgh+w6goK2+0IHg+iBR1Yfb2irNmbMo7ZxiizoUbB+hlFn/NqWXX9hDHz7YL3Y1yvYQxvOMZ4TWX7TsavxvCmMaK+c+2q9erbNG436e1BTgygIY4TJ9p0WHdWHCfmOHFRxnFijhNznDjxNBODnHhZcTkMAAAAAAAAAAAAAADQC5wJAgAAoA4zcgEAALDqyIkBAACw6siJlxJnggAAAAAAAAAAAAAAAL3AmSAAAABqbOW1OQEAAIBFRE4MAACAVUdOvJyYBAEAAFCH5BYAAACrjpwYAAAAq46ceClxOQwAAAAAAAAAAAAAANALnAkCs3NLFo2dIiY3Wyooa3tqmUq7TIxOTl3TcFkWSWVThY8H1W1ovrkAHpUpKLNRVBTU9bWwoOmgJO1oODfLgnbr0fiDMrdhtV0wRhtEC7C22bcNg7Id0a5yuBnT47JRsH48ih/yDt4klv7syYL1GG/fsN3aWqVMg0S7QXW7+NogWaYdmzF9rGzzua+F75coflgvGn+2LIwZlsVv42CxPV6Plc9JFN/qH2fF9drE6EL8lmvad9QubFYZf9N6E4T750rIOIZninKdT/EFwGnOADThG19L0+wHM/uwSrXMflaZvLey/xpL5cIvokpB4/ipvD1ezly6k8vbLTHGaX5bhPlsvl5ifcxDvH5Submi/CQuG4T16l+P23mU8lVijOVT9Y9HcYywXtz3IFOWWO5svpDb9qOg4SiqGJT5qNrBqOH/hIT55XBUbbNjbVhbT5KGwQKtRW/eQfB8LfhNMojqrVm6LH7epGyQeZOPGieH0iixsVKv15WF+6K476bxKzE8HcMTr0+KUS1Tsiz3emoccd1UvKIsHb9tu2mQEwOYCseJpyvbRhwnFseJxXHiol7wmOPEU7XjODEWHWeCAAAAAAAAAAAAAAAAvcCZIAAAAGLu3czEj2MCAAAAy4KcGAAAAKuOnHhpMQkCAAAgYur+NGdbeVY7AAAAYFbkxAAAAFh15MTLi8thAAAAAAAAAAAAAACAXuBMEAAAAHU4KxkAAABWHTkxAAAAVh058VLiTBAAAAAAAAAAAAAAAKAXOBME2nFJXn/VmsbXxmlbbxtnXHVx3Z9wteXiVVZvtKotU6Y2ZVE9HwQveDTIoGwU7UEG65t1R0HQsdlWw0qrqCyzUsJxDYJ6Fi3AKKxXjW+j0X2PfTiqlCkoC5fb4nq+ueAWr59R8Dwui5/X9TvJIDF3LV4H4fNBrqwar7LtM/W0tvncx8osXbYjaFepVx2jr9XXG2sXlY3C50HXY/EHYd/VIYafvbis6Weo7UW9ErvVuQj3P1vZb9Fhpiw1lrhNZszZZdt4ocH+3Kb4aAJYYYn9UdNd3fh+KqjXNFecJl9OxPd4IF77sGy3+Yo3HG92jA1TprH4mf6s8oWeGVcufgey37HhEDO5xFjZIFE2ltOHj+NcqP5xHH+0FtRbq1bLxag8j1fs9JtmTLh9Xekvfg+/y4dR3lh5lv7/kPCzsbZWbRWOfzSqxhgMNuuuDapLOgjWyVpQb2xTJ+rFBpaOnzMIlmDUMoEdZd7kubJwvTaNES9Vm/jxvm6U289m26XH1TRGtd7s7aaJf9/ryRabyIkBTMRx4tY4TiyOE8c4Tsxx4pq+543jxJkxbMQhJ15KnAkCAAAAAAAAAAAAAAD0AmeCAAAAiLm6/48Srh0HAACAZUJODAAAgFVHTry0VvJMEGa2x8w+bma3m9ndZnatmZ1pZmuTW88ey8xON7O/MrO7zOwOM7vMzJ6VqX8/M/sdM7vezPab2W1m9mEz+/Gaug8ys5ea2UfN7EYz+37Zx6fN7CVmtpLbHACAaZl3ewMWDTkxAACYhJwYfUdODAAAJiEnXk4rl+iY2SmSLpd0nKSPSvqvkg6S9GZJF8w7lpm9UdJeSYdLerekD0h6nKQ/NbNfr6l/sKS/kPQ6SXdKequk/y3puZKuMrMnR02eX8Z9sqTPSXqLpI9Ieqyk8yR92Cy+KBQAAABWCTkxOTEAAKvIzHaa2W+Y2fvM7Bozu9fM3MxeOkPMzv6Ijq1FTkxODAAA+mulLodhZoepSPyGkk5w96vK18+WdKmkU83sNHefmOS2iWVmeyS9StJNkp7k7t8tX3+DpKslvdHMPubu+4KuXinpKZIukvQCdx+VbS6UdLGk95rZ4zZel3SDpOdI+rPgNZnZayT9laTnSfo3KhJeAACQ4kzLRT+RE5MTAwDQWP9y4kNV/CFYkr4p6RuSHt42WPmH749I2i/pQkm3S3q2ij98P0XFH6GxgMiJyYkBAGisfznxSli1M0GcKunBki7YSEYlyd33S3pt+fRX5xjrV8r739tIbMs2+1TMDj5Y0os2Xi9n4m60+a0wWXX3P5F0haR/Jun44PVL3f1Pw7rl69+Q9K7y6QkNlxEAAAD9Q05cOKHhMgIAgP64W9IzJT3U3R8i6b1tA9X84fsl7v6bko6R9FmVf/iefciYE3LiwgkNlxEAAGCprNSZICSdWN5/sqbschU/hPaY2cHufs8cYuXafELS2WWdc8rXHi3pEZJucPebE22eWrb5ywnjlaQD5f16g7rdmGJyVJvr4CzstXPCE8lNMUYPzkBn4cyy+MR0wXPPlI1Pc2o4sLAoO1Wq2vko2KMM1jeDjKJ64Yn2skMcVEt9uBnTBsHjtWglDIN2o1HzsuCpBWUez/IbBhXjssyMQBvN7w3rg2gdhCs5PrNhZQNEZcE6D9+PitdxUOZxWRgjKgvHWRlz03qSRjvSZeEbKiwL2xRl9Y/H+o7Ce+Wz17RetazyHs+cdNJ7dEbKeF89tk4atMu2iT9aHa26hf2OAWZHTlzoJCfe2D+N7XoyaZdnyqxpvfB5/D2U2395g8eRsf14Yqcc92uZgVRS3TbjzdWbUHWa/LyVpt9DDfOFsTwjzH8yeUUl34njZ3OhyY8lydcyZbl2qfUzzRdv6n0RpfdK5G6xuFm4gsK/G3m0MIMw3xxUx2+jzbqDaNnWBpsxw8uxx6ltpd4o/cMsjp9a0rhezqhpwpaR6y0XP7WPiduk6hV1m9ULy7JjyrTLx59+HO1jJItyH7xMo7JGz3Jid79XRe7QhY0/fL8//sO3mb1W0iUq/vA91WUVsGXIiQscJ543jhNznLgGx4k5TiyJ48TiODHma9UmQRxd3t8QF7j7upndLOkxkh4l6YtdxjKzQyU9TNJd7n5rTbwvlfdHNekj06aWme2Q9Ivl07rkuq7N1Ymi3U3aAwCw1HqW3JrZTkn/VsV/pv0LFf8ltFPSy9z9vJYx96j4z6afkHSIpBtV/Dfd29192MGwMR/kxAVyYgAAJplPTrw79f3q7k+cS4/z0eUf0bH1yIkL5MQAAEzSs+PEq2LVLoexq7y/I1G+8foD5hCrTd9djvcPJD1W0sfd/c8b1AcAAP2ycf3jMyQ9RMX1j1srr398uaTjJH1UxSlbD1Jx/WP+222xkROTEwMAgNll//At6WYV/4D2qK0cFBojJyYnBgAAPbZ0Z4Iws32SHjlFkw+6+wubhi/vu5jT0zbWNPUb9WFm/07SqyRdJ+kXGg8kMfu+nPn7hKZxAABYOj6H05xt/4zhjesfX+Put5rZudo8tepUaq5/fFX5+tmSLlV5/WN3ZzLEnJATT98HOTEAAFOaX0583ZKd8SGlyz9KowVy4un7ICcGAGBK/TxOvBKWbhKEpJsk7Z+i/i3B440fH7vqKko6LKqXM22sSfXrfjjNPF4z+zVJb5X0BUknufvtqboAAKC/uP5x75ATp/sYQ04MAEB/zPkP313q8o/oqEdOnO5jDDkxAABYJUs3CcLdT5qh+fWSjlVxbbTKdczKa6EdKWld0pe7juXu3zOzr0t6mJkdXnO9tx8r78NT6F1f3qeu5VbXJhzHmSpOSf15FYntbROWCQAAbHCOVWZw/eNtRk48sU04jjNFTgwAQDuLmRPP8ofvLnX5R3S0QE48sU04jjNFTgwAQDuLmRNjgqWbBDGjSyX9vKSTJX0oKjtO0v0lXd7wYH2bWJeqOM3YyZLeF7V5RlBnw02SvirpKDM70t1vbtBGkmRmv63i+m7XSHq6u3+7wTK10vlpYBaY2+ZjqxQ0ayNF6ysqq1bMhA/HEcXwQfBklG5XaRhvxDDG2CBzG3yz7ijYu9gwPY5RtAA22oxvw2pfNgieB/U8Wk5bC+sNqmXDzcrma9WGo80yH60F9aJlDp/HZcFY4naVZ118acYbPwwflg2iQku/gSrt1jL1gjKPxzEIy6K+w3aD+sdj8eOygdJla/VlHq2DbIxB/eNczFz8+CMUrpOx9WMNHkfPx2KkZMbRZ/HurelyW03bmcdS3O0uTxc6ZslOCZy9/rGZ3SzpMSquf/zFrRwYGiEn7orpvg93swxpssp+Kpc35joMysb2ZeF3SMMYTfsaL8sseSadCoX51Fi1hvvpef9eaf9dnGmYyQMqOUjTfGGaXCURPxtjrCx8E0bjyvRdDRI+znwAcvXC3wnxcipdVm0WrpAovw+ej0bVskGwDirrQ9IoGKcFb9CxVWWD2nrx80HurbQgP9g980EZZYaYa5ePWV+W3WVFbfJ9zy9Grt1Ym5brp+m7Yo458Uxm/MN3l7r8Izq2HjnxHCzI186W4Dhx7Whq63KcmOPERVnUN8eJOU68xRbwODHmLN7l9d1Fkr4t6TQzO3bjRTM7RNLvlk/fGTYws11mttvMDp81lqR3lfdnmdkDgzZHSPo1SfcoSHq9OKKy0eYPzTaPgJjZKZKequL0ZZ+Kxny2isT2ahUze+eW2AIAgJXE9Y+XGzkxAADA7Db+2HxyTdnGH76v5MxoC4ucGAAAoMdW6kwQ7n6nmb1MRWJ6mZldIOl2Sc9R8R+NF0m6MGr2XBUJ5/mSzpgllrtfaWZvkvRKSdea2UWSDpL0Akk/JOnl7r4v6v9Nkp6l4trbnzOzSyQ9QtLzVZxq+sXum/Mbzex0Sf9R0lDSFZL+nY3PAtzn7nsnrC4AAFbbfP6D5bpZzvjA9Y/RBXLi+5ATAwAwCdmczGyXpMMl3RFdtuAiSa9X8Yfvt7v7VWX93B++sSDIie9DTgwAwCTkxEtppSZBSJK7X2xmx0s6S9LzJB0i6UYVCefb3Jufe6hNLHd/lZldK+nXJf2SipMi/bWkN7j7x2rq32NmPy3p1ZJ+TtIrJN0p6WJJ57j7F6ImR5b3a5LOTAz9U5L2Nl1OAACwMLj+MTpBTiyJnBgAgJVkZq+WtLt8ekx5/yIz+6ny8afd/bygSWd/+MZiISeWRE4MAAB6auUmQUiSu39G0jMb1t2rTCI4Taygzfkqfjg1rf99SeeUt0l1z5V07jTjAQAA4xbxWqZc/xhdIicGAACTLGJO3IGTJR0fvbanvG04Tw10+Ud0bA9yYgAAMElPc+LeW8lJEAAAAJjJpZJ+XsUB5A9FZRvXP76c6x8DAABg0bj7CVPW36uO//ANAAAAYL4G2z0AAACAheOSRt7tbQlnDJvZLjPbbWaHR0UXSfq2iusfHxvU5/rHAAAAfUFODAAAgFVHTry0OBMEtlZPP9hu1eeVp/EyW6MiuVnwuicrejSVyUapgYzXTVYMz+0TFSkY13iZ19bLjdGGmbJBvACb8W0YPB5Vq1lYb1Rddz4KBhOdldIqZfXxJBVfUveVVYvCmI3PejmaXOU+TaeuVbZTdT1W3q+DuCyxfeMYYbtoTGGZj7ULHq9lxhjWi8e4li5LfTbGYgzqH4+VZcdV329uHGN147e4xYE2Xq99uV7Y9zTtlk348ZrXcvbwO4vrHwPdcm3ua3O7orH9cWYfZqmyaJ/kmbJcu+Q44hCeqZZqF48xEW+acTT+MsvEmPvuvOkQc/XGcoJM/MR3/VQ5RyXfycTP5EyqlGV+r8R9p8Y4jaYbNaw3SneWfY8Hj0dRTln53RG9ycPfAqPoN0k1VU/HSNUba6e0wYKet3XU8LPdeFNn4uXLuo3ZPl66XW7nkY2ZCXlfzCYreDHfQgD6oKf7F44T17XjODHHiTlOXBef48Qd4TgxEpgEAQAAsDq4/jEAAAAAAAAAoNeYBAEAAFBjQf9xciZc/xgAAADT6GNODAAAAEyDnHg5NT1hDgAAAAAAAAAAAAAAwELjTBAAAAB1uJoDAAAAVh05MQAAAFYdOfFSYhIEAABAzOdwmjNyZQAAACwTcmIAAACsOnLipcXlMAAAAAAAAAAAAAAAQC9wJghg3qz61NNF1TILX49qDjZr2iiKkZvalJpdFg9kFL5QbeRBkUXtLHjBgnHYyOOKm/Gi8YbLEy9b+NwHQV/xcgWnJrJhtbBSNx5WeEojT7wuSeG4PBM/Ns9TJsUbI+w2LsrUDafGeWU7xRs7Hd/X0m+SyvYOYwzS9bJ9R++fsK5n69XHG4sRt0vFHIvRrMzHPkQNY1i6DB1iRi6AKYx932bkqiZ3PfFXRsOkcmxcuXaNBpIuy+VBY0UN97Ft06eu/0tjmu3b+Ls5k09ly0KVvKKj+KmYY/mU19eL4s87V7Ggcx97wwSdx79JMgOr1MzEr/zmifO6oO4gfkMGzyu/oaJ6ubTdKjHSb/imMbaaT/Wh2mgze/xp+s31l47fOHz2w52MP0X4fPxp4kzTKQAgi+PEHCdO1O0Ux4nH6nKcGDMjJ15KnAkCAAAAAAAAAAAAAAD0AmeCAAAAGOPjs/s7iAkAAAAsD3JiAAAArDpy4mXFJAgAAIA6o8lVAAAAgF4jJwYAAMCqIydeSlwOAwAAAAAAAAAAAACAFWFme8zs42Z2u5ndbWbXmtmZZra2lbHM7GAz+7yZuZl9rd3SjONMEAAAABFzdX6aM+MsZwAAAFgi5MQAAABYdX3Nic3sFEkfkbRf0oWSbpf0bElvlvQUSc/fwli/L+mR0y3BZJwJAgAAAAAAAAAAAACAnjOzwyS9W9JQ0gnu/hJ3/01Jx0j6rKRTzey0rYhlZidIeoWk32y7PCmcCQJLza36vOnsqbCdxWVKlzWt1ybGWN1MQw8LB9UoFlybyKNpTuH6qbTKrDe36kDC+GMrPKgaToyzOEY4Lo/Hv1l3LHzYtydej577WrQiw3bxcgdjqZSNojHm3meZsq5nC1a6tcwbJvdeissGVl8Wxa+WpfvzQdRu0LBeJr6nxpiNH9ULlicuy7cLngwSr0/Rd27dVWI0rDdWt+MYtXEaaNNmISzAjFwASyC1j8vmV83i5XKOSoxsUhkVpWJGr2fHmIgxNoym+9EO9rdxX13swlt/fyXaNd3u8fNsntEw5lR5QDKfqq7VVF6Ui5Ed1xTv20panXo8HqX6tJLjpzvP/nb0+npSNX0eDeLC4HdHpU32x0QUP/jdlGmX+5lQrbd9iY93kCw2/ak1TV+Nf75lYjbtL9tV0xjTbMJ51QWAbcRxYnGcOH49es5xYnGcOH5dHCduG6M2TgMcJ14Yp0p6sKT3u/tVGy+6+34ze62kSyT9qqQL5hmrnECxV9Il7v4uM3tn+0Uax5kgAAAAAAAAAAAAAADovxPL+0/WlF0u6W5Je8zs4DnHepukB0p6SYN+psaZIAAAAOrMcVY+AAAAsBTIiQEAALDq5pMT7zazq+u78yfOo8PA0eX9DTV9r5vZzZIeI+lRkr44j1hm9lxJp0t6qbt/deolaIBJEAAAADW28azQAAAAwEIgJwYAAMCq62FOvKu8vyNRvvH6A+YRy8x+RNJ/l/QJd39Pgz5aYRIEAAAAAAAAAAAAAABb47pZzvhgZvskPXKKJh909xc2DV/edzH9oy7WuyXtlPSyDuInMQkCAACgDqf+BQAAwKojJwYAAMCqW8yc+CZJ+6eof0vweOPsDLvqKko6LKqXM1UsM/tFSc+WdLq7f71B/NaYBAEAAAAAAAAAAAAAwBJw95NmaH69pGMlHSXp6rDAzHZIOlLSuqQvzyHWE8r7883s/Jp4DzO77wIkD3T3f2gwhlpMgsDWsuBx24lTXcRoyK363OqrjQ0jN8RUjLG6g3QQG4VFUcSBh4XJDipjjOqFyx32FTf0aAVZ2C4I6gNV643CetUYYd34OkuVsXi6XrgANrZwiXi5dvEbIREv1vo6UWHflnvHZEI0bRbXC7dvZYNG8cNtGpfl2oXPLfG6JB80ixG/t1Ljz9eL+66vl2vXdBxjMTN9p9ZVbhzZsky9LddF3/Mev9fsIzqICaB/Ut+5jXdTmX1D2+/zXA5SiRnWm2K/2jTH6eQfJZr21UFXY9p+1yTaZbdnLmdq2FcuJ8jGH2TKgo09Fj+Vt8TjUrqskwurVn4XRL8tUj+ApCiZi8YxCsqC31c+ij9swcNczhr/rklsNxvLG9O/SSqrMbceG67jsb6XQKt9TOMP1/jv3UZt5jCWxss5ReeNl42cGMA8cZyY48RRTI4T18XkODHHiTlOvCUxcvqZE18q6eclnSzpQ1HZcZLuL+lyd79nDrE+K+kHErFeIunuIE6T/pOYBAEAAFBnMU9zBgAAAGwdcmIAAACsuv7lxBdJer2k08zs7e5+lSSZ2SGSfres886wgZntknS4pDvc/da2sdz9QkkX1g3KzF4i6bvu/tIZl0/S2P98AAAAAAAAAAAAAACAvnH3OyW9TNKapMvM7Dwz+0NJ10j6SRUTG+KJCs+V9EVJ/7mDWFuCM0EAAADU6d0EXwAAAGBK5MQAAABYdT3Mid39YjM7XtJZkp4n6RBJN0p6paS3uTc//UWXsbrEJAgAAAAAAAAAAAAAAFaEu39G0jMb1t0raW8XsTIxbJb2MSZBAAAAjHFZ5xNUezhlGAAAAD1GTgwAAIBVR068rJgEAQAAEHNJXSe35LYAAABYJuTEAAAAWHXkxEuLSRBYGOFJTqyLHUB80pREzPjkKpWnTccRxfB0UbascYxBUBaNsXK2mHj8o+CFIEZcL4wZr59wX2+jKH7YddBwbIzh+EfVwkrf8bgG9cs29n4JGtrYAiipEqcy/kyjXLx4/TQ2+xl/wnU8TXi3RGG8Gq1pmWXKEq9PUzboIH68rtqMK14H4bhar7sW9SaUpUy1/lM6PVHVlH0DwHZK7Ksap7NxLtq0YS496WDfnRtH4/hb+KO+k/FO1WGzal1si9z3dON2U+VaXl8W5UzZfCTRV2dSPx7j3w9B52OXIA3HNYoGOfD6sviNFuS6ue0Up9jJnDUO0XQbjv2ozfygS4Rs+3G1Tn68N9PxmVGLmK0bNhtL62OlDdu1XiccdAWw4DhOPEUMjhNznHgCjhNPE6Nl3xwnTrbpCseJ0QaTIAAAAOq0/oEKAAAA9AQ5MQAAAFYdOfFSys0BAwAAAAAAAAAAAAAAWBqcCQIAAKBG9hSHAAAAwAogJwYAAMCqIydeTpwJAgAAAAAAAAAAAAAA9AJnggAAAKjDDF8AAACsOnJiAAAArDpy4qXEJAgAAICYq/vkllwZAAAAy4ScGAAAAKuOnHhpMQkCi8+i55mdgwd1La4Xxmm6g4n69lRRpq9phhEvapcxJMkH4cCClnEQTzxWdb16vH48US8XY2DJsvG+68c8tq2DgY2VVeqlx9Wq3oR2Wyr3RgjE27AawxrWy8RsWOYWVayUpftrXNZFjLEyq329q/idxMi8nl0/TWXaZd8zDWMAwMIzdb4fa5w+5PLeDjprvB/P2cJ9/EIdP0gs9zT5VK6s8Xd4Nl/wTFnTGNOPozZOw3ZJuY3f9Ddg3Nco8QHL5KxjH8RcLm211cZk8+pKV5lfhbn4lRjpejme26Ctd06pzua7U+nkuGbLGNn1OIf+7luXC7XzBIAGOE7MceL7yjhO3BjHiTlOHOM4MVYEkyAAAADqjLZ7AAAAAMA2IycGAADAqiMnXkqD7R4AAAAAAAAAAAAAAABAF1ZyEoSZ7TGzj5vZ7WZ2t5lda2ZnmtnaVsQys9PN7K/M7C4zu8PMLjOzZ2Xq38/MfsfMrjez/WZ2m5l92Mx+PFH/9WZ2iZn9f2b2/XJsf2Nm55jZg6ZdRgAAVo3JZd7xjfMNY8GQEwMAgBxyYqwCcmIAAJBDTry8Vm4ShJmdIulyScdJ+qik/yrpIElvlnTBvGOZ2Rsl7ZV0uKR3S/qApMdJ+lMz+/Wa+gdL+gtJr5N0p6S3Svrfkp4r6Soze3JNN6+QdGjZ7q2SPihpXdK5kq41s4dPs5wAAKwk925vwAIhJyYnBgCgkZ7lxGa208x+w8zeZ2bXmNm9ZuZm9tIWsY4o26ZuU+VU2HrkxOTEAAA00rOceFXs2O4BbCUzO0xFQjmUdIK7X1W+frakSyWdamanufvEJLdNLDPbI+lVkm6S9CR3/275+hskXS3pjWb2MXffF3T1SklPkXSRpBe4+6hsc6GkiyW918wet/F66TB3318z5t+T9BpJ/0HSv520jAAAAOgfcmJyYgAAVtihkt5SPv6mpG9ImvWPwH+rIh+JfX7GuJgjcmJyYgAA0G+rdiaIUyU9WNIFG8moJJWJ4GvLp786x1i/Ut7/3kZiW7bZp2J28MGSXrTxuplZ0Oa3wgTW3f9E0hWS/pmk48NO6hLb0ofL+x+bsGwAAKw2V/czfJnki8VBTlwgJwYAIKefOfHdkp4p6aHu/hBJ7+0g5jXufm7N7aIOYmN+yIkL5MQAAOT0MydeCSt1JghJJ5b3n6wpu1zFD6E9Znawu98zh1i5Np+QdHZZ55zytUdLeoSkG9z95kSbp5Zt/nLCeCXp2eX9tQ3qLgeLngc7Do/KrOFOJWw31iYo8/qXJxbm2iXL4hhhxXiMmbJwedwTCxN30Dq+ksKyeB3ny6y2bKyrSozcQKpPk++R+M3UpE2D/jqVHuKYzOIk40zTxs2SZcmYYzHalaXGNTb+xmXxjqTb+GNS7ea8DmLZ7d2mTYt4AOaKnLjQSU6c2v9t5a5vbAxNc46Gg5wq3+mRNt+HktLrte13b8Pv8PHvek+XNYyfzTkyPyfafABar+9s0M2HFg3Kcx+UsGplYLkPQ+7HaVx1s27TbROnpZWeusjD5vFBzw163ua83/Iu3rBdjLHlODZ+Jq/i7t3d71WROwDkxAWOE2dwnDjqgOPEHCeesg3HiZuXjeE4MTCzVZsEcXR5f0Nc4O7rZnazpMdIepSkL3YZy8wOlfQwSXe5+6018b5U3h/VpI9Mm/uY2b+X9AOSdkk6VtJPqUhs/yARL25/daJod5P2AAAsNa7Phv4iJyYnBgCgGXLiJh5qZr8s6UGSviPps+7enz8s9xc5MTkxAADNkBMvpVWbBLGrvL8jUb7x+gPmEKtN37OO999L+pHg+SclneHu30rUBwAAG0aTqwBLipyYnBgAgGbmkxPvTv1B1d2fOJce5+vp5e0+ZnaZpNPd/avbMiI0QU5MTgwAQDMcJ15Kg+0ewLTMbJ+Z+RS3D0wTvrzvYkpP21jT1M/24e4P8eK8UA+R9G9UzDb+GzN7QqOBuD+x7ibpuinGCAAAFoCZ7TSz3zCz95nZNWZ2b5krvbRFrCMm5F8XzGMZsImcuHkf5MQAAGBO7pb0nyQ9UdIDy9vxKi5FcIKkS8r/+MeckBM374OcGAAArJplPBPETZL2T1H/luDxxozYXXUVJR0W1cuZNtak+nWzeTsZr7t/U9JHzeyvVZwy7f2SHptrAwDAqsteK3I5HSrpLeXjb0r6hqSHzxjzbyVdXPP652eMi8nIidN91CInBgBgenPKia+b5YwPZrZP0iOnaPJBd39h2/5S3P02Sa+LXr7czH5G0qclPVnSSyW9teu+cR9y4nQftciJAQCYXg+PE6+EpZsE4e4nzdD8ehXXPDtKUuW0e2a2Q9KRktYlfbnrWO7+PTP7uqSHmdnhNdd7+7HyPryu2/Xlfe213BJtktz9K2b2BUnHmNk/cfdvN2kHAAB64W5Jz5R0jbvfambnSjpnxpjXuPu5sw4M0yMnntgmiZwYAIClN8sfvufO3dfN7DwVkyCOE5Mg5oaceGKbJHJiAADQd0t3OYwZXVren1xTdpyk+0u60t3vmVOsXJtnRHWk4kfdVyUdZWZHNmwzyUPL++EUbQAAWC3u87lt6yL5ve7+iZoDbFg95MTkxAAATLagObG7n+Tuu6e4/VYHa2Na3yrvuRzG4iInJicGAGCyBc2JMdnSnQliRhdJer2k08zs7e5+lSSZ2SGSfres886wgZntknS4pDuiPxpMHUvSuyT9gqSzzOxid/9u2eYISb8m6R5J79uo7O5uZu+S9PuS/tDMXuDuo7LNKZKeKukLkj4VjHe3pH9w929EyzFQcZ3CH1aRdH+3wfqanUXPvVmZB2UW7wvCdlOUVWKmxhQPKRqjJcafG0ZOdviZZcnFr1TNrf/gcbyO3dMLV1kF0Y7aUzHj8XuyqPo+aNouWy9aCbnlzsRM6eQ0SG1DNH2jxd1Zw4aZapX3Z9N6mbpN68VluXa5MWbXQbZdw3Gk4k1q12b9zGM75bRd7oZlyZht+8K8PdTMflnSgyR9R9Jn3f3abR4TJiMn7jInTlx9eap9a1081eTBLWJ0cRXrxsuySL/hu/5umCJe4/XVNt+p1Euv9Gwe0CZ/SKfVU+Y7XluvtdwPpwwLOvdcu+SPtKi7eFuE+Wb2d3FmfQT9tc27mqb+rfdZuXEs0j6hja7H38lKjkIu+zrut58o75ucRQDbg5yY48TjXXOcmOPEDWKmcJx4inqZuhwnTtRtUo/jxBwnRsVKTYJw9zvN7GUqEtPLzOwCSbdLeo6ko8vXL4yaPVdFwnm+pDNmieXuV5rZmyS9UtK1ZnaRpIMkvUDSD0l6ubvvi/p/k6RnSTpV0ufM7BJJj5D0fBWntX7xRsJbOlnSG8zschUzhL8j6UckHS/pUSqu//2yhqsMAIDVNZrLUeXdZnZ1XcEs10XeRk8vb/cxs8skne7uX92WEWEicmJyYgAAGptPTrxUUn/4NrMnS/obd783qn+ipFeUTz+wZQPFVMiJyYkBAGiMnHgprdQkCEly94vN7HhJZ0l6nqRDJN2oIuF8m3vz6XptYrn7q8zsWkm/LumXJI0k/bWkN7j7x2rq32NmPy3p1ZJ+TsWPqDslXSzpHHf/QtTkf0v6I0lPkfTPJT1A0vdUXA/uj8tx3d50GQEAWFn8a13O3Sr+c+hibf532+MlnSvpaZIuMbNj3P172zI6TEROTE4MAEAjPcyJzezVknaXT48p719kZj9VPv60u58XNKn9w7eK//x/TDkJ+Gvla4+XdGL5+Gx3v7LTwaNT5MTkxAAANNLDnHgVrNwkCEly989IembDunsl7e0iVtDmfBU/nJrW/76kc8rbpLqfV3HKNAAAsHium+WMD2a2T9Ijp2jyQXd/Ydv+Utz9Nkmvi16+3Mx+RtKnJT1Z0kslvbXrvtEdcmIAALCiTlbxn/ChPeVtw3ma7I9VTJB4kqRnSNop6ZuSPizpHe5+xexDxbyREwMAAPTTSk6CAAAAmGgxZ/jeJGn/FPVvmddA6rj7upmdp2ISxHFiEgQAAMByW8yceCbufsKU9feq5g/f7v4eSe/pZFAAAABYXD3MiVcBkyAAAACWhLuftN1jaOBb5f2h2zoKAAAAAAAAAMBKYhIEAABAzNX9DN/VmTD8E+X9l7d1FAAAAJgNOTEAAABWHTnx0mISBGbmVn1ubT+8YZwgRjZ+VKamZal+c/VqxtIixFjdZPwgSDZ+bv1EA0m2iwcc9p1bH/EKqfSdbugN4+fGlXs9930U9jdWreF7txojt0XbxW9limGEUu/paeJnY8RlibrTxKjUzY7L0vWaLk+u71y84HnrZZtD/EZ9TRGjcb2u3j8tNF7O8ZbSqOsP7fJlt2a2S9Lhku5w91uD158s6W/c/d6o/omSXlE+/cCWDRRYBB3ssyRl8+BWusrVW/S1DFqv43nnUJUY1Y3WOF/IlDXNpyo5xzT9zZl1/DmxKIinvrMb/5grotQ9HI+TWcm5Hy+V33PxBz0oyv44bbciLVV1+VKdLTWXM+jO/AGY1J6cGMB0OE7MceLaOBwnHreAv8s4TjxhLBwn5jhxp8iJtwKTIAAAAFaEmb1a0u7y6THl/YvM7KfKx5929/OCJs+V9D5J50s6I3j99ZIeY2aXSfpa+drjJZ1YPj7b3a/sdPAAAAAAAAAAADTAJAgAAIA6PtruEczDyZKOj17bU942nKfJ/ljFBIknSXqGpJ2Svinpw5Le4e5XzD5UAAAAbLt+5sQAAABAc+TES4lJEAAAACvC3U+Ysv5eSXtrXn+PpPd0MigAAAAAAAAAADrEJAgAAIA6c7lwMwAAALBEyIkBAACw6siJlxKTIAAAAGIuadRxckuuDAAAgGVCTgwAAIBVR068tJgEga1lweOWH3IPYlgcIxff0kWpEE3H6FZ9notRGX+z8OPDyKwDT9Qbqxs8jsevRL1JAwvje26Fe7rIPF3olXrNx9W4rGE9Tz5ZQk3fhJl6Y++fjtu5ZSo2jtFyXG3jZ/pqXLeTdZepl9Px+pmLeccHgKaWbH+U/G5YlZxmC2Im13E2gW0YQ0qPa5rcoWkukamWi9c6B0nJ/e6bpl3K2O+mzRe8aZCx31S5QSZ+8+Ri5H6z5X4UZofRLs9u/E9QU7zne6vzD0Our63rCgA6wXFijhPHfUdFHCfeYhwnzo+L48T5vjlOjAXEJAgAAIAxPofTnC37r2EAAACsFnJiAAAArDpy4mU12O4BAAAAAAAAAAAAAAAAdIEzQQAAANTpfIYvAAAAsGTIiQEAALDqyImXEmeCAAAAAAAAAAAAAAAAvcCZIAAAAOowwxcAAACrjpwYAAAAq46ceCkxCQIAACDmkkaj7mMCAAAAy4KcGAAAAKuOnHhpMQkCnXPbfGy5D7JFzz1R1nZn0DJ+Zfy5+JlxNY0xzeppHCOz/r1hvbBsbIJbaj3WDqb+9dz7wj2z5F77UDbFLLxc1ez7NRmwRZtF0vCNltss08R0SxTm4mfjNaubHX/DGNk40etT9Zcoaxuj8bZqG6PhOsjZ1vgA0LFZ9zm5PGxLNc3rttoWro/W27JhEtk6P2hYt7N8p4MY1Xpb+GaKV0L2h0cmTuW30uYTH/thk4mX/SGYKmy5rsaWOxFymm2R+93XOEam4arka9u5L12U/TiAlcZxYo4Tj+E48eLiODHHiaeNwXFiLDgmQQAAAIzxOZzmbNl/DQMAAGC1kBMDAABg1ZETL6vBdg8AAAAAAAAAAAAAAACgC5wJAgAAoE7nM3wBAACAJUNODAAAgFVHTryUmAQBAAAQc0mjjpNbcmUAAAAsE3JiAAAArDpy4qXF5TAAAAAAAAAAAAAAAEAvcCYIAACAGu6j7R4CAAAAsK3IiQEAALDqyImXE5Mg0I5JsvJ8LW7JanGR5U7xEtb1xOtR2bbGT8WLw6VXz1jXiWGMVUyOI2o4NqygrmWWM7d+cus4eVkkTz/NbrNMWWX88SCbnkooM65qX3M+N9E04XNvmg64Neyg6Tgy9XKfjU5iWOJx2xgdtQvL5tJ31/Hali1K/LGYPlVsAMgKc+KcKfLlRTHvYW3rcjfZZhN0kce0qpfru21ekeusi3xqirHMVbygTX+MVX5DWVSt5Xsp1Xd2RXbwm2TsB27TdtHzDj5D2cVZ0P3izDjlLYC+4jgxx4lrcJy4JY4TzycGx4m7icdxYiwZJkEAAACM8e6v9caRbwAAACwVcmIAAACsOnLiZcUkCAAAgDrznt0PAAAALDpyYgAAAKw6cuKlNNjuAQAAAAAAAAAAAAAAAHSBM0EAAADEXNJo1H1MAAAAYFmQEwMAAGDVkRMvLc4EAQAAAAAAAAAAAADAijCzPWb2cTO73czuNrNrzexMM1vbilhm9gNmdraZ/a2Z3WVm/2hmf29mf2RmO2dbOs4EAQAAUI9rvQEAAGDVkRMDAABg1fUwJzazUyR9RNJ+SRdKul3SsyW9WdJTJD1/nrHM7AhJfyHpn0q6QtI7JZmkIySdKumVkg60WLT7MAkCs7Pow++WrBoWxc2qMcNGzcsyXVf76zh+ptvsaW2y420XstouDhI09IbrILt5m7ZrOo5YbkGbfudM8d2Uek96fgu37m/LTDH8lOx2atlf45i5epmybPyu2231OHK6WP8tyubxHslp/v5ZxA8lgJWzSPuihjvQ1t9DKQu0DjpZti7ymEAn36O5vKJNvEkxs+22bntb7rdF0x+gTX8TRvEtiO9jP5zS7ZIbJPvbaJo3yZzXf2W9ziN+8HiB9h1bqvOdcKqfrekGwArhODHHiSe14zjx9uI48fzbcZyY48RLwMwOk/RuSUNJJ7j7VeXrZ0u6VNKpZnaau18wj1jlWR4+KumRkk5x9/8VxVyTNPM1SLgcBgAAQMTl8tGo29tC/voFAAAA6pETAwAAYNX1NCc+VdKDJV2wMWlBktx9v6TXlk9/dY6xfkHSMZLeGk+AKNsO3Wc//QZnggAAAIi5uj/N2bbntgAAAMAUyIkBAACw6uaXE+82s6tri92f2G2HY04s7z9ZU3a5pLsl7TGzg939njnE+rnyfm95WYxnSHqApK9K+qS7f6fRUkzAmSAAAAAAAAAAAAAAAOi/o8v7G+ICd1+XdLOKEyk8ak6xniRpv4rJD1+S9N8k/b6kD0j6ipm9uNFSTMCZIAAAAOqM+Dc1AAAArDhyYgAAAKy6+eTE123BGR9SdpX3dyTKN15/QNexzOxgSYdJGkp6Q3l7h6S7JJ0i6W2SzjOzfe5+aYP+kzgTBAAAAAAAAAAAAAAAS8DM9pmZT3H7wDThy/suZn/EsdaC+4+4+2+5+1fd/XZ3f5+k15RtfnvWjjkTBAAAwBiXfNR9TAAAAGBpkBMDAABg1S1sTnyTiktKNHVL8Hjj7Ay76iqqOFNDWC9nqljufreZ3SvpIEkfran/URVng/iXDfrOYhIEumfBh9ctWS0ustRnPg7hDcsy/VnTGOnhV+pll6VhjLGiTLuWIdPtMutgbByZZWu46bODbLruvOl3xBTfJZWu531cpsv5c3OS3YY5Tds1rDfVOBJ1szHalnUQv/U67iJ+B9up8fjnvY7HYnbwAXPJuz7NGcd7gV7qZF/eQutd3dyTnGa2a71J6iaHahGji5xmmr6zW7pF/HxekUvw00Xb+j5o85swXszKb8zMb9/sD6BM/FS9SRqv2MXYH+Rt55tkCWzB71ZyYgAz4Tgxx4nr2qVixEPhOHFzHCduHJPjxNO16yR+0744TjxdCPeTZmh+vaRjJR0l6eqwwMx2SDpS0rqkL88p1vWSHifpH2rifbe8v1+DvrO4HAYAAAAAAAAAAAAAAP13aXl/ck3ZcZLuL+lKd79nTrEuKe8fW9Nm47V9DfrOYhIEAABAHR91ewMAAACWDTkxAAAAVl3/cuKLJH1b0mlmduzGi2Z2iKTfLZ++M2xgZrvMbLeZHT5rLEn/XcXZIV5hZj8atfm98ukFbRYsxCQIAAAAAAAAAAAAAAB6zt3vlPQySWuSLjOz88zsDyVdI+knVUxsuDBq9lxJX5T0n2eN5e7XSfptST8i6W/N7D1m9jZJfyvpJEmfk/T6WZdzx6wBAAAA+qjza70BAAAAS4acGAAAAKuujzmxu19sZsdLOkvS8yQdIulGSa+U9DZ3b7zQbWK5+5vM7HpJr5J0qqSDJX1Z0uskvdHdvz/L8klMggAAAKjhczg1Wf+SZQAAAPQZOTEAAABWXX9zYnf/jKRnNqy7V9LeLmIFbf5M0p9N02YaNsVEDkCSZGbfsZ07f+igB//I5MrL+PZagjFbrnAJxr8UY5y3LtZB9o2wohZxnWTGtBQfhUVcp5M0GPO93/qm/MCB2939QWPNza4eaO0Jh+oHOx3W9/SPGmn41+7+xE4DA9gWU+XEgKb83l+2719bgqxmG9dpdu0s27ZGrxy49TaJnBjADDhOvP04TtwDHCeej0VcJxwn3nocJ15pnAkCbdzpBw7onlu+tm+7B4JGdpf3123rKDAtttvyYZstlyMk3Zkou26kof5R/zCPfnl/AP1BTrxc+J5eTmy35cM2Wy5HiJwYwGzIiZcL39PLie22fNhmy+UIkRP3EmeCAHrOzK6WJGaULRe22/JhmwEAsLj4nl5ObLflwzYDAGBx8T29nNhuy4dtBiyGwXYPAAAAAAAAAAAAAAAAoAtMggAAAAAAAAAAAAAAAL3AJAgAAAAAAAAAAAAAANALTIIAAAAAAAAAAAAAAAC9wCQIAAAAAAAAAAAAAADQC+bu2z0GAAAAAAAAAAAAAACAmXEmCAAAAAAAAAAAAAAA0AtMggAAAAAAAAAAAAAAAL3AJAgAAAAAAAAAAAAAANALTIIAAAAAAAAAAAAAAAC9wCQIAAAAAAAAAAAAAADQC0yCAAAAAAAAAAAAAAAAvcAkCAAAAAAAAAAAAAAA0AtMggAWgJntMbOPm9ntZna3mV1rZmea2dpWxDKz083sr8zsLjO7w8wuM7NnZerfz8x+x8yuN7P9ZnabmX3YzH68pu6DzOylZvZRM7vRzL5f9vFpM3uJmS3sfsjMftTM3mtmt5jZPWa2z8zeYmYPnHecRduOy6Sv283MdprZc83sPWb2eTO7s+zj78zsP5rZD06zfAAALBpy4sXU19wqqE9O3HEccmIAANojJ15Mfc2tgvrkxB3HIScGtp+5+3aPAVhpZnaKpI9I2i/pQkm3S3q2pKMlXeTuz59nLDN7o6RXSfqapIskHSTpNEk/JOnl7v6OqP7Bki6R9BRJV0m6VNLDJT1f0r2STnT3zwX1f0XSOyXdKukvJX1V0o9I+jeSdpXjfb4v2M7IzB4t6UpJPyzpTyRdJ+lfSnqapOslPcXdvzOPOIu4HZdFn7ebme2W9EVJ31PxWfqCpB+Q9K8kPVrSDeW4vj1p+QAAWDTkxOTE5MTd6fN2IycGAPQZOTE5MTlxd/q83ciJgYbcnRs3btt0k3SYpNsk3SPp2OD1Q1R8sbqk0+YVS9Ke8vUbJT0weP0ISd9R8SV9RNTmP5Rt/qekQfD6KeXrfx+9fqKKL/hBFOchKhJdl/S87d4WNevzz8uxvTx6/U3l6++aR5xF3Y7LcuvzdpP0MEn/VtKhUZyDJH2sjPX27d4G3Lhx48aN27S3Nt+jXcbailxK5MQLl1u12Y7LcuvzdhM5MTdu3Lhx6+mtzfdol7G2IpcSOfHC5VZttuOy3Pq83UROzI1bo9u2D4Abt1W+SXpx+YV0fk3ZiWXZp+YVS9L7y9dfVNPmP5ZlvxO8ZpK+Ur5+ZE2by8uypzUc82sW8QtZ0qPKcd0cJ3iSflDSXSpmWR7adZxl3I6Lcuv7dpsw5o1E+e+2eztw48aNGzdu097IicmJyYnZbuTE3Lhx48Zt1W/kxOTE5MRsN3Jibty6vS3sNZaAFXFief/JmrLLJd0taU95Sqp5xMq1+URURypOpfQISTe4+80N2+QcKO/XG9bfKhvj/3/dfRQWuPs/SvqMpPtL+ok5xFnG7bgo+r7dchb1swQAQBPkxIVF+x7ve25FTtx9HHJiAADaIycuLNr3eN9zK3Li7uOQEwMLgkkQwPY6ury/IS5w93UVMwx3qJhx2GksMztUxWmT7nL3W2vifam8P6pJH5k2tcxsh6RfLJ/Wfblvp66Ws02cpdqOC6bv2y3nxeX9on2WAABogpy4sGjf433PrciJu49DTgwAQHvkxIVF+x7ve25FTtx9HHJiYEEwCQLYXrvK+zsS5RuvP2AOsdr03eV4/0DSYyV93N3/vEH9rdTVcm7FOt7u7bhI+r7dapnZcyT9sqSvSfrDSfUBAFhA5MTkxHGcZduOi6Tv260WOTEAoAfIicmJ4zjLth0XSd+3Wy1yYqCKSRDAjMxsn5n5FLcPTBO+vPcuhtoy1jT1G/VhZv9O0qskXSfpF6YczyLoaru0ibMw23EJ9W67mdkeSf9DxbXnnufu350yPgAAnSAnnr4PcuKZ4izMdlxCvdtu5MQAgEVBTjx9H+TEM8VZmO24hHq33ciJgXE7tnsAQA/cJGn/FPVvCR5vzOLbVVdR0mFRvZxpY02qXzcDcebxmtmvSXqrpC9IOsndb0/V3UZdbZc2cZZiOy6ovm+3CjP7SRXXhBtJeoa7/1WqLgAAW4CcON3HGHLiiXGWYjsuqL5vtwpyYgDAgiEnTvcxhpx4Ypyl2I4Lqu/brYKcGKjHJAhgRu5+0gzNr5d0rIrrOV0dFpTXQjtS0rqkL3cdy92/Z2Zfl/QwMzu85npTP1beh9euur68T11/qq5NOI4zJb1Z0udVJLa3TVim7TLTcs4YZ+G34wLr+3YLYz5V0p+pSGz/lbv/nwnLBADAXJETT2wTjuNMkRNPirPw23GB9X27hTHJiQEAC4WceGKbcBxnipx4UpyF344LrO/bLYxJTgwkcDkMYHtdWt6fXFN2nKT7S7rS3e+ZU6xcm2dEdaRiNvNXJR1lZkc2bCNJMrPfVpHYXiPpaQuc2ErSX5b3P2Nmlf2kmf2gpKdI+r6kSQlFmzgLvR0XXN+328YYTlQxs3dd0tNJbAEAPUBOvJj6nluRE3cfh5wYAID2yIkXU99zK3Li7uOQEwOLwt25ceO2TTcVpz76lqR7JB0bvH6IpCtVXOfptKjNLkm7JR3eQaw95es3Snpg8PoRkr6j4vRtR0Rt/kPZ5n9KGgSvn1K+/vfh62XZ2WXZVZJ+aLvXe8Nt8+flmF8evf6m8vV3Ba/tLLfJo2eJs+jbcRluK7DdfkbS3ZK+LelfbPf65saNGzdu3Lq4tfweJSfemm3T99yKnHg5txs5MTdu3Lhx692t5fcoOfHWbJu+51bkxMu53ciJuXGbcDN3F4DtY2Y/K+kiFV9kF0i6XdJzJB1dvv7/ePBBNbMzJL1P0vnufsYssco2/0XSKyV9raxzkKQXSHqQii/2d0T1D1Yx63CPimT1EkmPkPR8SfdKOtHdPxfUP13SXklDSW9X/bWr9rn73tx62mpm9mgVSckPS/oTSV+U9GRJT1Nx6qk97v6dsu4Rkm6W9BV3P6JtnKDNz2rBtuOy6PN2M7OjVcyQP0TSR1ScLnCMu587aT0BALBoyIklkROTE3ekz9uNnBgA0GfkxJLIicmJO9Ln7UZODDS03bMwuHHj5lJx2qSPS/quitMn/Z2kV0haq6l7hopZgXtnjRW0OV3S/5X0PUn/KOlTkp6VqX8/Sb8j6UsqZjR+S8VM0X9WU/fccry522XbvQ0Sy/lwFT8kblWR8H1F0lsVzVJWMSPTVSTpreMs8nZcpltft5ukExp8lny71z83bty4cePW9jbN96jIibdyu/Qyt2qzHZfp1tftJnJibty4cePW89s036MiJ97K7dLL3KrNdlymW1+3m8iJuXFrdONMEAAAAAAAAAAAAAAAoBcG2z0AAAAAAAAAAAAAAACALjAJAgAAAAAAAAAAAAAA9AKTIAAAAAAAAAAAAAAAQC8wCQIAAAAAAAAAAAAAAPQCkyAAAAAAAAAAAAAAAEAvMAkCAAAAAAAAAAAAAAD0ApMgAAAAAAAAAAAAAABALzAJAgAAAAAAAAAAAAAA9AKTIAAAAAAAAAAAAAAAQC8wCQIAAAAAAAAAAAAAAPQCkyAAAAAAAAAAAAAAAEAvMAkCAAAAAAAAAAAAAAD0ApMgAGABmNllZvZ3ZjaX/bIVrjGzK+YRHwAAAJgVOTEAAABWHTkxAHSDSRAAsM3M7FRJx0s6x91H8+jD3V3SOZJ+quwPAAAAWBjkxAAAAFh15MQA0B0r9ncAgO1gZibpi5JM0m6f807ZzL4gaW0r+gIAAACaICcGAADAqiMnBoBucSYIANhePy3paEnnb1Gyeb6koySdtAV9AQAAAE2QEwMAAGDVkRMDQIeYBAEALZjZPjPzzG1vw1AvKe8vrOnjjDLWGWb2dDO7wszuMrNvmdn7zOwBZb1/YWYfM7PvluX/y8yOSPR3QdQvAAAA0Ao5MQAAAFYdOTEALKYd2z0AAFhSb5H0gJrXny3pCZLunhSgPMXZiZK+4e43Zao+R9KzJH1M0rsk7ZF0hqQjzezVki6RdIWk90h6XDmGR5vZ4+Jrx7n7V8zs65J+2syMU50BAABgBm8ROTEAAABW21tETgwAC4dJEADQgru/JX7NzJ4u6SxJN0p6XYMwR0t6sIqkNec5kk5y90+V/Qwk/bmKU6R9XNIvufsHg3G8R9KLVSS5f1IT7/9K+llJPy7pCw3GCQAAAIwhJwYAAMCqIycGgMXE5TAAoANm9lhJF0m6Q9Iz3f3bDZo9ory/dUK9D20ktpJUztr94/Lp58PEtvT+8v6YRLxvRP0DAAAAMyMnBgAAwKojJwaAxcCZIABgRmZ2uKQ/k3SwpGe5+5caNn1Qef/dCfWuqnntlvL+6pqyr5f3P5qId3t5/08m9AsAAAA0Qk4MAACAVUdODACLg0kQADADMztUxWnKHi7p5939iimaf7+8P2RCvTtqXltvULYzEe9+Uf8AAABAa+TEAAAAWHXkxACwWJgEAQAtlddc+5CkJ0g6y90/NGWI28r7B2VrdW+jv9uytQAAAIAJyIkBAACw6siJAWDxDLZ7AACwxN4i6dmS3uvuv9+i/d9LGkra3eWgGtgtaSTp77a4XwAAAPTPW0RODAAAgNX2FpETA8BCYRIEALRgZmdKermkSyT9SpsY7n6HpGskPd7M7jeheifM7GBJx0j6G3f/h63oEwAAAP1ETgwAAIBVR04MAIuJy2EAwJTM7CGS/oskVzFL9iwzi6td4+4XNwj3EUlPlHSipD/rcJgpJ0g6qOwXAAAAaIWcGAAAAKuOnBgAFheTIABgeodo80w6ZybqnC/p4gax3iPpXEm/qK1Jbk+XdG/ZLwAAANAWOTEAAABWHTkxACwoc/ftHgMArDQz++8qks4j3P0bc+znhyXtk/Q/3P2l8+oHAAAAmBY5MQAAAFYdOTEAdGcwuQoAYM5ep2LW7Vlz7uc1koaSzp5zPwAAAMC0yIkBAACw6siJAaAjTIIAgG3m7t+U9EJJt5jZXPbLVlyM7lZJv+Dut86jDwAAAKAtcmIAAACsOnJiAOgOl8MAAAAAAAAAAAAAAAC9wJkgAAAAAAAAAAAAAABALzAJAgAAAAAAAAAAAAAA9AKTIAAAAAAAAAAAAAAAQC8wCQIAAAAAAAAAAAAAAPQCkyAAAAAAAAAAAAAAAEAvMAkCAAAAAAAAAAAAAAD0ApMgAAAAAAAAAAAAAABALzAJAgAAAAAAAAAAAAAA9AKTIAAAAAAAAAAAAAAAQC8wCQIAAAAAAAAAAAAAAPQCkyAAAAAAAAAAAAAAAEAvMAkCAAAAAAAAAAAAAAD0ApMgAAAAAAAAAAAAAABAL/z/dPKhFw+noakAAAAASUVORK5CYII=\n", + "text/plain": [ + "
" + ] + }, + "metadata": { + "image/png": { + "height": 277, + "width": 1056 + }, + "needs_background": "light" + }, + "output_type": "display_data" + } + ], + "source": [ + "def plot_plane(dat):\n", + " zmin, zmax, xmin, xmax = dat['zvec'].min(), dat['zvec'].max(), dat['xvec'].min(), dat['xvec'].max()\n", + " \n", + " fig, axes = plt.subplots(1,3, figsize=(18,4))\n", + " \n", + " for ax, name, unit in zip(axes, ['Ex', 'Ez', 'By'], ['V/m', 'V/m', 'T']):\n", + " im = ax.imshow(dat[name], origin='lower', extent=[xmin, xmax, zmin, zmax])\n", + " divider = make_axes_locatable(ax)\n", + " cax = divider.append_axes('right', size='5%', pad=0.05)\n", + " fig.colorbar(im, cax=cax, orientation='vertical')\n", + " \n", + " ax.set_title(f'{name} ({unit})')\n", + " ax.set_xlabel('z (m)')\n", + " ax.set_ylabel('x (m)') \n", + "plot_plane(dat)" + ] + }, { "cell_type": "markdown", - "id": "looking-evening", + "id": "green-activity", "metadata": {}, "source": [ "# Paper results\n", @@ -252,8 +327,8 @@ }, { "cell_type": "code", - "execution_count": 7, - "id": "willing-sleep", + "execution_count": 9, + "id": "under-glory", "metadata": {}, "outputs": [], "source": [ @@ -269,7 +344,7 @@ " N_PARTICLE=10000000 ,\n", " E_TOT= 0.51099891e6 ,\n", " BUNCH_CHARGE= 1e-9,\n", - " DISTTYPE = 1, \n", + " DISTTYPE = 1,\n", " SIGMA_X= {sigma_x},\n", " SIGMA_Y= 1.0000000000000000E-003,\n", " SIGMA_Z= {sigma_z},\n", @@ -293,8 +368,8 @@ }, { "cell_type": "code", - "execution_count": 8, - "id": "experienced-mission", + "execution_count": 10, + "id": "generic-necklace", "metadata": {}, "outputs": [ { @@ -343,9 +418,25 @@ " Space charge field calc with free-space boundary condition...\n", " Chris' method\n", " ...done\n", - " Time for space charge calc (s): 26.045808000000001 \n", + " Time for space charge calc (s): 26.418604000000002 \n", "\n" ] + }, + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAACEEAAAIqCAYAAADBmMawAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAAEAAElEQVR4nOzde5xrWVnn/++TnDqnoaWbiyIMjHIR6BEdUJBbz3D9iS0KoqKiiMioiCAigr/hN8hAozjjiKggCl64qzDiDIwo2A40F2kZBRXGGe7SCtgq0Fwbuk9V8vz+2CnqWWtnrdrZtVNJJZ/363VelWStvfbKTip5krNrfc3dBQAAAAAAAAAAAAAAcNKNVj0BAAAAAAAAAAAAAACAIXASBAAAAAAAAAAAAAAA2AicBAEAAAAAAAAAAAAAADYCJ0EAAAAAAAAAAAAAAICNwEkQAAAAAAAAAAAAAABgI3ASBAAAAAAAAAAAAAAA2AicBAEAAAAAAAAAAAAAADYCJ0EAAAAAAAAAAAAAAICNwEkQAAAAAAAAAAAAAABgI3ASBAAAAAAAAAAAAAAA2AicBAEAAAAAAAAAAAAAADYCJ0EAAAAAAAAAAAAAAICNwEkQAAAAAAAAAAAAAABgI3ASBAAAAAAAAAAAALBCZvZDZuZmdvGAYz5pNuajhxoTAE4CToIAgCMwsz81sz0z+4pVz2UoZjYys3eb2WfN7EtXPR8AAACsLzN7+uxL1Yevei5DMrPfmN2vb1r1XAAAAHB0ZvbCWX2X/5uY2ZWz73l/wsyutaL5XUvSUyR9RtIvz277/sKcu/z7/tnQz5b0SUlPNrNzV3HfAGAVOAkCwFqrFKfz/v34Mc/tAZIulPQyd3//7LaHz+ayZ2Y37jjObcN9uKjQ57Gz9l8e7h7M5+5TSf9J0rmSnrzs/QEAAOBw61gXm9mNJP24pMslvWR22y3MbDqbx3d2HGdsZlfMtvnPhT63m7W/Y6DpH+Y/SZpI+lkz47sTAACAzbEr6Z/Cv89Iup6a73l/QdLbzOxLVjCvH5N0E0m/6u5Xzm77fDbX/X8fC9t9otDn85Lk7p+W9CuSvlRN7Q4AW4EP8gBOirw4nffvquOazOyL0J+V5JKeHpp+bzaPsaSHdBzu+2Y/r5D0J4U+3zz7+erFZtrbb0v6oKRHmNnNj2mfAAAAONw61cVPkXRtST/n7nuS5O5/K+nNs/bvK22Yua+kG80uv6jQ51jr4dn9+F1J/1rSdx/HPgEAAHAsLnP3G4V/15V0XUlPkDSV9JWS5p6YuyxmNlZzEoQk/cb+7e7+8myuN3L3G0n6urD5t83r4+4vD31+c/bzMWZ2arn3BgDWAydBADgp8uJ03r/fOHyYwXyDpNtK+lN3f9f+je7+WUn/bXb1oYcNMjuZYv9kiZe6+2ROn+tIuruas5LfeMR5dzL7EvtFknYk/ehx7BMAAACdrEVdbGbXk/T9av7C7KVZ8/6JDN9gZjfsMNz+yRJ/EWvrzHGfFCwdfFn8E8e4TwAAABwzd/+Uu/+CpN+a3XT/Y57C/ST9CzX18AeGHtzd/07Sn6lZDeKbD+kOABuBkyAAoJ8fnP182Zy2/S99/7WZ3e6Qce6jZpmzuF3uvpJOS/oTdz+70CyP5ndnPx9qZjvHuF8AAACsv++VdI6kV89OBI5+T9LnJJ3SIasomNl5kr5ldnVuPTxbjvhOkj4q6X8dYc6LerOkj0j6WjO7/THuFwAAAKvxztnPc+ONZvb8WTTbK2obm9nFs36XLbjfh89+/tcFt1vE/tgPr/YCgA3BSRAANpKZ/fCs4LzazL6q0OfXZ33+3syuu8DYN1BzNrCr+YI3d6mkD80uH7YE8H772939/xT6tP7qzcxutp/5PLt+JzN7lZl91Mw+Y2aXmdn9Qv/TZvbvzexvzOxzZvZPZvY8M7t+aWLu/l5J75D0JeIMYQAAgBPJzF64Xzce8u+FCw5d/KLW3T8j6b/Prh5WD3+HpGtJOqv5JxhLzV/GjSS9xt2n+zea2eWzud/TzG5sZs81sw+Z2efN7F1m9rjZymv7/b/DzN5sZp80s0+b2R+WPivM7sdU0v4X3XxZDAAAsPm+evbz/dnt+yuE3X/23XCLmZmkh82uPr/rDmf16r1nV9/Sdbse9se+N5EYALYBJ0EA2Eju/jw1Jw2ckfTbZnY6tpvZN0v6ITUnMny/u39ygeHvpSYm4n3u/tE5+55Kesns6vfMMt1azOyLJH3r7Grpr95M0jfO5vlHhT4PkPSnak7M2JH0RZLuKukPZl/0niPpj9Vk2d1yttkNJT1C0v/Mj01mvzi+b6UPAAAA1tenJP1T5V8rju0wZvbFkr5mdrX0Re1+ffu1ZnbbynD7J0m82t0/XuhzWBTGzSX9paQflnSempr4AknPlPTLszn/ZzUnbNxVzXch11FzcsWbzexWlflRDwMAAGw4MzvPzH5cB6v//mJsd/fLJP1fNav1PkTz3UfSl0u6StLLF9j9V0s6X01d/o4FtlvUO9ScePxFkm6/xP0AwFrgJAgAm+wHJP2zpH8t6Wf2b5wtp7t/9u4vuvvrFxz3wtnPt1f67H/peyNJX1/o8+1qllbb1UH0RO5OarLa/sLd/6nQ58Wzfzd29+uqOcHhVWpe439R0jPUfAn8zWqK3OuoWXL4M2q+vP7B9pBf8LbZz39b6QMAAIA15e6Pdfcbzfsn6d9JslnX1y4w7H49fIW7X1Ho8zpJH55dfui8DmZ2Mx3UmaWTgnfUnICwq+bE3nl+UdIHJd3O3c9XcyLEk2dtjzaz/yDpJyT9uKTz3f08NV82v0fSdSU9vTCudFAPXzD7HAEAAICT7W5m9o/h3yfVnDj8i2pOFPg+d3/hnO32v08urRD272Y/XzFbGa2rO81+vt/dP7fAdguZxSy/Z3b1zsvaDwCsC06CAHBS5MXpvH/nxQ3c/Z918B/8jzeze8wu/7qaEwv+RtJ/6DGX/cL0naUOsyiJt86ulpYA3r/9D939Y4U+h/3VmyT9pbv/4P5JErPVKR4i6dOSbiLp0ZIe7O5/6O6T2b//IennZ9s/qDL2/tnHX2lm16n0AwAAwPFYuC6ex8xuI+l31Hwv8F/cvRRFMU+Xengq6aWzqw+JsRTBQ9WchPFRSa8pDHV3NSc1vNndP13oM5V0P3d/52zfn3P3n5H0+tn4T5f0M+7+y+5+1azP36hZGU6SHlBaHc3dP6imrpYO7jcAAABOrh013w3v/zs/tF1f0g1nq/PmXqxmJYXbm9nXxAYzO18HK/52jsKYufHsZ+n74SHt7+PG1V4AsAE4CQLASZEXp/P+tV7T3P0P1Jz0MJL0YjN7nKQHqilYv9fdr+kxl66F6f5fsz0wP4HAzG4q6Z5Zv3m6nATxn/MbZl/u7p+EcZm7v3HOdq+b/SzmIOvgPpqaYwwAAIDV6lUXR7Mvaf+Hmi98XyPp/1twDovWwzfVQc5xtL9CxO+4+25hjC718HML8Xb/c/bzrJpojNxbJF2tJkLvKyrj78d08GUxAADAyfdGd7f9f5JOSbqFpEepWUX3GTpY9eELZtFtr5xdzVeD+B5J56iJT37TgvP54tnPTyy4XR/7+/jiai8A2ACcBAHgpEiK08K/Txa2/QlJ75P0ZTr48vPJ7t43Y61rYfoySddIupbaqy08VM1r8Mcl/eG8jc3sJmry2T7i7n9V2c//Ltz+z7Off1No34/XuF5l7HgfKY6xcmb2IDN7tpm92cw+bWZuZi89fMuF9/PVZvZiM/uQmV1jZv9sZm80s9LKLgAAHJej1MWarcjwu5JurWY53O+erdqwiE71sLu/W9Kfz64mkRhmdldJt5pdfXFlmG+a/aydBHFYPXy5u392zvymOjiRo0tNTD2MtUBNDADAcGar5n7Q3X9Nzeq6kvTvzOzfzOm+f3LE92Qrie1HYbygxxTOzH6e7bHtoq6e/bzWMewLAFaKkyAAbLzZqgg/Gm56q5ozevvqVJjOvnx+1exq/iXR/pfAv3vEv3pTJYd5Mvt5WPupyvBXh8sUx1gHP6Xm9/n2kj6yjB2Y2fdL+is1q8a8WdIvSHqFmhVR7reMfQIAcIz+s6RvlPRJSQ9w90/1GGORL2pfOPv5bWZ2brh9vz7+G3f/y3kbziI7biXpPe7+vso++tbDsc9OpQ9fFmPdUBMDALAE7v7Hkv5xdvU753T5n5I+KOkGkh4gSWZ2W0l3VFNX1lb8Lbly9vO6PbZd1P6Jvx+v9gKADVD7jy8A2CRxibJbqVkmuPZlaM2Vkm6kboXpi9QUzPcwsy9z9783s6+T9K9Ce8n9Zz+rJ0EsWfyLOIpjrIPHSfqwpPdLuoekS4cc3Mzuouas/r+RdJG7/2PWXvsPEgAA1pqZfY+kn1TzBe2D3f29PYda5Ival0n6RTVLC3+bpJfM/mpu/0vlda+HJb4sxvqhJgYAYHn+Xs13v7fIG9zdzez5kn5azffNr5D0A7PmP3b3f+ixvy4rkw1lfx+HxdoBwInHShAANp6ZPUTSgyXtqVny9waSnn+EIRcpTPfPHjZJ3zu7bf+v3v6vu79t3kZmdi01ucmfl/S6/lM9sngfKY6xcu5+qbu/z9296zZm9t1mdqmZfcLMrjazd5nZT5nZmTnd/4uksaTvzb/sne2/tHILAABrzczuoIPle//97K/c+upcD7v7JyT9wezq/mpo95d0fTUnY/x2ZfNOK6MdA74sxlqhJgYAYKluMvtZer97gZo69hvM7Mt18J1v3++b3zP7ebOe2y9ifx/vPoZ9AcBKcRIEgI1mZv9S0q/Mrj5NzVKen5d0kZk9quew+4XpzQ/r6O7xi92Hzv5i5sGz67W/eruPmuV2X+/un+85zyHcbPbzUzpYCg44MczstyT9jqSvkPTfJD1HzV+v/rSk15rZqdD3ppL+raS3Sfo/ZnYvM3uCmT3ezO4zy1AHAODEMbMvlfRKNfXlS9z9F444ZOd6eGa/7r2Pmd1EBycFX1KKdjOz60q6UE1sx5/2m+bRmdm1JX3J7CpfFuNEoiYGAKAbM7tQBydBzI1sc/ePSHqNmhMGf1tNrfhRSf+j524vk+SSrmdmt+w5xqFm7/E3ml1dWX0NAMeFDy4ANpaZmZoM4utKequkn3X3d0v697MuP29mt+4x9FtmP+/Ysf/+l74XSHqqpC+WNJX00so26/JXb183+/kWd5+udCbAgmY5xv9O0n+XdGt3/wF3f7y7XyjpYkn3lPTosMn+8/19kl4/+/fzkp6hJvPxr83sK45n9gAADGMWPfH7km4q6c8lPWKAYffr4a8ys3M69H+tpH9S8x3EYyV94+z22knBF6mJ8Pxjd9/rO9EBfK2aL7g/I+kdK5wH0As1MQAAhzOza5nZAyX97uymz6m+ssP+CmsXzn6+tO9KSe5+paR3za5+Xa3vEe2P/R53/+cl7gcA1gInQQDYZI9TEylxlaSHzlZlkJqVIf5E0rXVZBKfKmxfsn+m7NeY2fiwzu7+vyX91ezqE2c//+SQjLhvmv1cl5Mg3rzSWQD9PFZNDM6/m7Oiyk+ryfV+SLjthrOf3ynpX6nJLT9fzV/MvUTSV0v6w9l/JgEAcFI8S82Xs/8g6Vvd/eoBxnynpE+rOUnh9od1np3E8Duzq4+XtKNmpbFXVTZbt5OCLwufJ4CThJoYAIDU3czsH8O/j6r5/vi/S/qXs8vfNVvxoeQPJcUVzY4SvSxJL5/9/KZqr6PZH/vl1V4AsCEW/Y8/AFiVu5nZYXEML3f3x0qSmX2VpJ+d3f54d3//fid3dzN7uKT/LelOkn5KzQoNXb1N0t9KuoWav5p5XYdtXiTpa3Rw8lnxr97M7PZq/lLvHe7+4QXmNajZX/XdS81ybL+3qnkAfcyWrr6dmuzuH28Whmm5Rs0Xu/vG4ecPuvv+f7p82sweNut7R0nfroO/DAAA4LgtVBerWVFBalZH+8vCe2K+TZW7T8zs9yU9XM2XqW/tsNmL1JykvF8Pv7x0QsbsROOL1GQtv6bLnJaIL4txYlETAwAw146kL81u+6ya73v/RNKz3f3vagO4+56Z/YGaVdb+wt3/5ohzeoGkp0j6FjM7Z6ATl79gFtH8rWq+533BkGMDwLriJAgAJ8W84jR3vvSFJX9fKumMpD909+flHd39I2b2aDV/kfYkM/sjd//zLhOZnUTxfEk/I+nB6nYSxO+oWUJ0R81fzb2y0ndd/urtmyVdR9Kl7v6BFc8FWNT1JJmaXMandNzmE7Of10j6o9gw+71/lZovfO8kvvAFAKxO57o4c+3Zv0W2qfktNSdBfJekJx/W2d3fYWbvUPMfspL04kr3u0q6gZpIto8vOK/BmNkN1Zz0/FlJ/3VV8wCOgJoYAIAZd/9+Sd8/4JD3mv086ioQcvcPmdlr1JyA+82SXnFI/8vVvMd3dZGk60u6ZLYtAGw8ToIAsNb6FKfuflbdluX9XfX/0mb/7NxvM7MfdfdrDtnXRyV1XS700JMguhS6hx27DmN89+znb9T2A6ypT81+/pW7f23Hbd4z+/kZd5/Oad//QvhaR5oZAAA99P3S1t1vNvRcZuO+xcz+j6Tbmtkd3f1tHba5fcfhO50UfNh9c/cXSnrhEcb4LjV/Df877n5VbRxgTVETAwCwBGZ2H0m3UhOd8TuHdO/qqZLupyY+rnoSRA9PmP3selIkAJx4o8O7AABy7v4Pkp6n5gzahw81rpl9iZrc4Y9K6rQyxTKY2VdI+hZJ/1cs/YsTyN0/K2n/P2au33Gzd6pZKviLzWzeX9h+1ezn5UefIQAAG2H/S9QnVHstbuUro80iOR6r5q/hf/aQ7sBaoiYGAGB4ZvbFalb8laTnu/unhxh3dlLx70m6i5n9P0OMKUlm9m8k3V3Sq9y9S4wdAGwEToIAgP5+Ws3SuP/ezIZaWed6s3EfW/irm+Py/6n5q7cnrXgewFE8U80KLM83s+vmjWZ2PTP7wl/EufuempObJOm/mNko9P1qNX99u6fhz8YHAOBEcvffl/S/JH2Hmd16iDFn0Xa/J+k/DJCtfBTfI+mWkp57WCY0sOaoiQEAGICZPcPM/l7SP0j6GjUnDf7MwLt5oqSLJX3RgGNedzbmTw44JgCsPXP3Vc8BAE4sM/tWNbnGL9yUPLXZl1xPlHTW3Z+x6vkAkZk9UNIDZ1dvJOkbJP2tpDfPbvuYuz8h9H+OpEdJulLSH0v6ezUruNxczVnwL3D3R4b+15b0Okl3kfRXkt6gJkP529Us+ft4d3/mUu4cAAAnkJl9jZoVxN7g7m9Y8XQGY2bfK+krJD1nFm0HrA1qYgAAjp+ZvVDSwyR9WtJbJT3B3f/3SicFACjiJAgAAHBimNlTVc8v/Ls829vMvlnSIyXdSc3Z71eq+eL3Ekkvdfd3Z/2vLen/lfRgNV8MXy3pLyT9gru/Zoj7AQAAAPRFTQwAAAAAdZwEAQAAAAAAAAAAAADAipjZTSU9TdJFkm4g6QpJr5R0sbt/ouMYD5J0D0m3V7OK+XUk/ba7f+8h291N0k+pWQ3uHEnvl/R8Sc9290lhm4dJerSkr5Q0UbOK3DPc/dVd5rpsnAQBAAAAAAAAAAAAAMAKmNktJV0m6YaSXiXp3WpWcbuXpPdIutDdP95hnL9Wc/LDZyV9WNIFOuQkCDP7Fkm/r2b1t5erWTXu/pJuI+kV7v4dc7Z5hqTHz/bxCkmn1awid31Jj3H3X+lyv5eJkyAAAAAAAAAAAAAAAFgBM/tjSfeV9GPu/uxw+zMlPU7S89z9kR3GuZeaExPer2ZFiEtVOQnCzM6b9T1fzYkWb5vdfo6k10u6q6TvdveXhW3uJuktkj4g6ev2V6kws5tJerukcyVd4O6XL3AIBjda5c4BAAAAAAAAAAAAANhGZnYLNSdAXC7pOVnzUyRdJemhZnbuYWO5+6Xu/j7vvgrCgyR9iaSX7Z8AMRvnajXxGJL0I9k2+ydjPD3GdMxOeniOpDOSHt5x/0vDSRAAAAAAAAAAAAAAABy/e89+XuLu09jg7p9Rs+rCtSXdZYn7fu2ctjdJ+pyku5nZmY7bvCbrszKnVj0BrJaZfVDSeWrOLgIA4CS6maRPu/vN8wYz+201uWfL8G53f8iSxgZwjKiJAQAb4GaiJgZwBNTEAIANcDOtpia+mQrvn+5+hw7b32b2872F9vepWSni1pJet+Dceu/b3fdm9cFtJd1C0rtmq1HcRNJn3f2Kwlw1m+tKcRIEztPOzvV3bnTD6x/a045hNttgpcex6+o3qd5T5jmznRZ4mh3zM3J4/e4ABj5uu//4z9Lubqn5Aklf+7VffabU3stf/u9rBh0PwMqdZzs719+54ZceXhMDJ4ltYbGyRqXi0I710dzg47h0K/q1oyYGMICmJv7SDt8TAwCwhnb/6Z/lq6mJP3fEYc6f/fxUoX3/9usecT9D7HuVc10IJ0Hg8p0b3fD6N/4Pjz285xBfghz3Fyl9vvRbZI597s8ic+o6fud+Pf/Lue/jtuzjXxtmC7/wdR/g4A1x2BaYR+dUqp7jd74/fe9317n0Hn/geSxDr8dw2Clc8bO/rN0PfeTyUvvXfvUZ/cUlXzboPr/uvn/Pl77AZrl854Zfev1/+WOPG3bU7StHhnHMb2uDPEzH+Flpobf9rjXx0Ptewmeq7vse9j6vfLvAj/MzDidB9Lei135qYgADuHznS294/X/xhIFrYgAAjsk/POMXdfbDK6mJ391xxYe+9j+hreLTRt99r/xbMU6CAAAAG83lmmp6eMcFxwQAAABOCmpiAAAAbLs1ron3V084v9B+XtZvSIvu+7D+h60UcWw4CQJ1J231h75/GbOMv2hKtlvCXyMN/JdQS1/tYYDnwVJWdzgJf+HU9RB3PD7VFSMWOR6l3eXzqOyv9rwrrhKxwPjJ/akdnq79anMZYh59dZ3HusinyHenANYdr1PHa6H34qPvrjZE56l0rTMGsEgplDTWasXYdAJKiZZ1XP2h576WvtrDSXx8T5q+x5j3GgAAAGBbvWf289aF9lvNfr53Sfu+42zfb48NZnZK0s0l7Un6W0ly96vM7COSbmJmN3b3K45xrgsZrXoCAAAAyzbx6aD/AAAAgJOGmhgAAADbbk1r4ktnP+9rZsn/3ZvZdSRdKOnzkt461A6D189+XjSn7e6Sri3pMnePOXi1bb4x67MynAQBAAA2mkuaygf9xx/qAQAA4CShJgYAAMC2W9ea2N0/IOkSSTeT9Ois+WJJ50p6sbtfJUlmtmNmF5jZLQfY/SskfUzSg83sjvs3mtk5kn5mdvXXsm2eO/v5JDO7Xthmf/7XSHrBAHM7EuIwAAAAAAAAAAAAAABYjUdJukzSs8zsPpLeJenOku6lJlriSaHvTWbtf6fmxIkvMLMHSnrg7OqNZj/vamYvnF3+mLs/Yb+/u3/azH5IzckQbzCzl0m6UtIDJN1mdvvL4z7c/TIze6akn5D0TjN7haTTkr5L0vUlPcbdL+9xDAbFSRDYXsvOQh06l7Zzv+7nndnQY/Y8ptY39/YY82w7H6sFeNe7PcS+w74WOd5eC5kuNeXDV/Ony+PHY149VnH8ReZbGrNrv74WGT/25c+sjsA11dDL9fKAABuJX+2TZ8n11CBvxXHD2jy69tsStbJu6RbZ9wDz9L6fhwaeB1as6+tDb9TEAAAA2HbrWxO7+wdmKzE8TU3MxP0kXSHpWZIudvcrOw51e0kPy267xeyf1Jw48YTY6O6vNLN7qDnR4tslnSPp/WpOcniWe/t/aNz98Wb2Tkk/KukRkqaS/lLSz7v7qzvOdak4CQIAAAAAAAAAAAAAgBVx9w9JeniHfpercBq1uz9V0lN77Pstak68WGSbF0l60aL7Oi6cBAEAADaaS5p0Xnql+5gAAADASUFNDAAAgG1HTbxdOAkCy3GcS3EOsXRodfyu/ZYQGTHAvk9c5MVAz51lxFcMbeg51iMjug6SbVZ53IpRGYss49oxKqN2rJL7nY/XNR5jiEiKRfa9TMc9jxMS2TFd58kBQFeb/FK27LfNAeqkQVaqb9VCR+yn7slgSWPPz1DrUu4sZPD4wX7TOPGRFyfhse7rJLy2djn+HfpQEwMAAGDbURNvj9GqJwAAAAAAAAAAAAAAADAEVoIAAAAbzSVNBj7Dl/OFAQAAcJJQEwMAAGDbURNvF1aCAAAAAAAAAAAAAAAAG4GVILA9lpHx2jXX9Rj3bSucvy2Sc9t5zO5DlgfZ4HPxQhBz32Pl8fAsEHZdery9Fg6dN1XzubsFXMf77a387MoOklzsrnPKx6j17RjQ3Wffm/aUPob7RtYbgLXCS1Jb32MyRK24yHt/h24L3ZU+ddgQ93mV1qW+X/Jx9L5zXPbje9KfP8vQ55ic0NdxamIAAABsO2ri7cFKEAAAAAAAAAAAAAAAYCOwEgQAANhoLtektUzI0ccEAAAATgpqYgAAAGw7auLtwkkQSJ2UpTGHjqEYer+L7Ltzv/K+O8cg1OZ/EiIvBlj29qQ8xUtaR6DPMcmiGWrHv09URu050orK6Lzs8+LRGM3+KuOXxlwo8qJrvx7RGLUxlxHLseGmq54AgO3A597j1/WY930L7BFDscjb9NDyMqzXW38rXqzvbFZkGfPtOOZKIzBO2uN00i1yvNfovYGaGAAAANuOmnh7EIcBAAAAAAAAAAAAAAA2AitBAACAjeaSJgP/Cd4a/UEfAAAAcChqYgAAAGw7auLtwkoQAAAAAAAAAAAAAABgI7ASBIZx0vNHjzODdZF9VTJlrTTOIjm0lblY13G6ZiN3Pj7d5z/Iw9Y3t/cYeQhzHiLOunqMs+Do2uPmXTOyQ7/a8fY8tDpeTfbVb/5ee6jjmF3n0Rojn0ul76Za42MwWaO5ADiBTthryAkobxaSvzX3G6TS1nX8nmN0LSXUo7Y6tG9xjLzeWY8nTfWxHmKOS/jM5gN/blr6GDh+Q7zGDISaGAAAANuOmnh7cBIEAADYaC5puoQxAQAAgJOCmhgAAADbjpp4uxCHAQAAAAAAAAAAAAAANgIrQeBkWMYSo0uIZ1jmvqpxEgMcn2osxBCRFx3n2HeF10FiLdZkGeBc7wiMHjEanZfzlWSFUVuxEz2jMpJ4jM6RFFljPAbZPKrxGMXxs+u9xijPsbq/rktw9zw+m27C+tEADuNay9P317Q8OVZ9jsFCb3FDR2V0fGuv7rpnPZX3qyV+bZRjjJpYevzFJj9OqFskBqcnamIAAABsO2ri7cFKEAAAAAAAAAAAAAAAYCOwEgQAANho7tJ04L+k7rWSCAAAALAi1MQAAADYdtTE24WTIICjGGTZ1ZMVgVGdU6tz5b51HaLz/Tz6O81C922J2nES/e5b59WbO8ZmtGZRmFcpJqPZV6tzcQfxsS9GY7R2kI9fXgM6Pt7JvIaKq+gTUbHR61R3NETkyJxBh1/mjMcKwGKItTheixzv6ttvaZy+y9bncRUdN+sat4E5SsdrgeM4eAQGjyEWNUhUBjUxAAAAth018TYhDgMAAAAAAAAAAAAAAGwEVoIAAAAbzaXBz/DlD7oBAABwklATAwAAYNtRE28XVoIAAAAAAAAAAAAAAAAbgZUg0MTVrGNkzdDByZ3zWSv7XeQ4FbNny+NbbfwB5mU9x+g7r86HvDqvbs+D6hyHmMcxyu+LV4Oqy7zjOYidR6/MI9lTfhzDdu37VplIaKs9NsnxqYzRdV6e7ypu1/Ox6B74PcAYtWPQ6jvAfasZ4n4PZLqM+wcAmTUpJVb+mrsyfd+mK8er+PaxyHtxbbtCGVN9CCtjVMevve17oeMq9f38M8Bbvg/xmXBdS491eXyXbZtqvwXuKjUxAAAAth018fbgJAgAALDRWOYMAAAA246aGAAAANuOmni7EIcBAAAAAAAAAAAAAAA2AitBoL91WTFmiHkMsSRo38iIgY/jpkVedD0+faMshj7+yzFEfkJt9G5rQFePcS0qo/r86RixUWmI82pFh1SXh56/JnQ9sqMcqbFQDEVJbXwcgWky+HmfPDbAtlrpSvL8eUFd1+OzwEt46fGuvkXX4ipqfQcuKwZTiy8bYvjjfEut7OvERWBsS6xFX4scn62puamJAQAAsO2oibcJK0EAAAAAAAAAAAAAAICNwEoQAABgo7mk6cB/4cffXgIAAOAkoSYGAADAtqMm3i6sBAEAAAAAAAAAAAAAADYCK0Fgsw1xQtcq43w65tJaz/xaq923wpjVTarzKLfV5lEds+MYfcZbJ/G++UJnKR49GNtrY4S5xOOazzFea40WH498u+R+FwbMBs0f32Quxx2uXbrjQ8xjrYLCT4YJ2WwAFnDs5cK6vI6vyzwW0eflfZH7WRg/f45US7RaHdCxX7We6lpnxLJokfmfBNUPKfNv9p6foY7Ut9N4S/5FPImP9dLr9o47OPG/KNTEAAAAADXx9uAkCAAAsNFc0sSHXfzqJP4/IQAAALYXNTEAAAC2HTXxdiEOAwAAAAAAAAAAAAAAbARWgsDJNEjMxQDnZ/WJk+ixzaH76tiv777jZscdeTF0zMUy4jBqc/SVngbY9UlTm+TiURnVvVaWkG0tSZzEbYSb891W1oeuxXSkHXvEchyy3SCGGL+6fvbA+1pbpung530e/RiZ2YMk3UPS7SXdTtJ1JP22u3/vguNcLunLC83/5O43OsI0ga1hWsIq9KuqA7bpzxCGiJXqM34eV9EtQax72VWpd6qpWLU6aQmOtXwYYPxBIjBOwmfRTbPs2JuuTnxsBjXxEaYJAACAjbCeNTGWg5MgAAAAVuOn1HzR+1lJH5Z0wRHG+pSkX5pz+2ePMCYAAACwbNTEAAAAAAbHSRAAAGCjuaTJwGfkDvTHhY9T80Xv+9X89dulRxjrk+7+1CEmBQAAgM1DTQwAAIBtt8Y1MZaAkyAAAMBGc0kTH3aZsyGKW3f/whe81jX7BwAAAOiBmhgAAADbbl1rYiwHJ0FgfQwewtxT7TN3ta08/+rn+J65tBa3q/brtu9qt+ocwxhd59tq67tdt+dM3+9Ruo4/xL69Y25sPievPTShb338WlvX4Oq4RbZN2Hd7/qEtH6cQMp0f0+QYVEOyM6Xc7fxx77zv8nZdM76pmHAEZ8zseyV9maSrJL1T0pvcfbLaaQFb4Dhfu1f4PrEupXpNx3JqseNYGnOBEqlQ0tTHrNU0ff+PsOsY+SSHePC7zrnrvvqWtn31GbPvcVuX+R+3oV9jFrnPg++7MmDnFyr0RE0MAAAAQBInQQAAgI1nmg7+7b9J0gVm9vZ5re5+h4F3eJgbSXpJdtsHzezh7v7GY54LAAAA1g418THPBQAAAGtnaTUx1tCwa34AAADguL1A0n3UfOl7rqSvlvQ8STeT9Bozu93qpgYAAAAcC2piAAAAAF/AShDYLCfhhKsh4i8qfReJ3ugcgTFAlMUyIi/6jtmn37LV5lGLsojHoB550fd+9hnTsl6VxzD2y+aftFXWkU6PQXkHls3DO8dVdF3Deslq8zgJkRornKNLmgx83ufsLrx7BX/d1uLuF2c3/Y2kR5rZZyU9XtJTJX3rcc8L2FjLeA07xtfFNSl9lqLvfetVQi2yTSw5uq6SX4vPqjS1hu8YgbEu5U5ikXlU+nrpoC8jUmOIOI9lbHcS9LlvQ72eLSNKp7iv1f2yURNTEwMAAGy7JdbEgzCzm0p6mqSLJN1A0hWSXinpYnf/xDLGMbMXSnrYIUO+3t3vE7b5fjUnIZf8iLs/t+t8l4WTIAAAwGZzaeIDL351Mv4T8blqvvC9+6onAgAAgBWjJqYmBgAA2HZrXBOb2S0lXSbphpJeJendku4k6bGSLjKzC93940sY55WSLi8M91BJt5D0mkL7qyT99Zzb33bYPI8DJ0EAAABspn+e/Tx3pbMAAAAAVoeaGAAAACfBr6o5ceHH3P3Z+zea2TMlPU7S0yU9cuhx3P2Vak6ESJjZdSX9v5LOSnphYV+vdPdS28pxEgS6W+XSm0Psu2cMRb2tX1RD1/G7RzrUGkMkRXWMPG5j/r7zfXWNq+gaebGM2IykX6debaMlrB097bj8abxvtVnkxyDGPdRiM5LxF7qbpfl3X785RmXkvZL5x9vzx6JwP5sxirvO7nchGqOZZGWMyr5KS93Wxl9g370se/w15TJNB1/m7ESsR33X2c+/XeksgJPoBEZeLD3mYm0yEnqq1ZEdj101riIZMN+wW9/qKvldx+i62QJxG4Nsd4yK8RfSMBEYy4i8WPbn3ZOgz2vMIpsMEmUx8Pid83GGQU1MTQwAALDt1rUmNrNbSLqvmhUZnpM1P0XSIyQ91Mwe7+5XLXucmYdKupakl7n7xzrelbUy8JofAAAAGJqZ7ZjZBbPlzOLttzWz68/p/+WSfmV29aXHMUcAAABgmaiJAQAAsKHuPft5ibtPY4O7f0bSWyRdW9JdjmkcSfqh2c9fr/S5vZn9uJk90cweamY37TDusWElCAAAsPEma/gXzGb2QEkPnF290eznXc3shbPLH3P3J8wu30TSuyT9naSbhWG+Q9ITzexSSR+U9BlJt5T0TZLOkfRHkp6xlDsAAACAE4WaGAAAANtuSTXxBWb29nkN7n6HDtvfZvbzvYX296lZ4eHWkl637HHM7K6SvlrSe9390sr+Hptdn5jZb0r6cXe/urLdseAkCAAAgNW4vaSHZbfdYvZPar7cfYLqLlVT3H6NmqV+z5X0SUl/Kuklkl7ivljQDQAAAHCMbi9qYgAAAGy382c/P1Vo37/9usc0ziNmP3+j0P5BSY+RdImkD8/2+28k/SdJPyzpPEnfc8g+lm5rT4KYLcnxNEkXSbqBpCskvVLSxe7+iWWOY2Z3k/RTapYbOUfS+yU9X9Kz3X1yyP7OSHq7pNtK+oi7r9XSIijomM9qC+TXWulktWyMauxt7JtvV9gwn2NxHlnfrtvVjkG1rTwNjXqOuWzjjvv2ypmJ00pbvG/d72U6XjJG50HKadT5fYnPA1f5uRu3a41eCdBOxy9OK7uftSd1NkqcV7bZif6KrXI/TyKXNBk8622AMdyfKumpHfterjkvde7+RklvHGA62FLUxJmj/nIv4bV/6aXKmrzGd72fvafbd8NYz1bmmAxfuy/lMilpW+ituDBG735L1vsxtMLlRbbrcvvcvt0/px293wqLyK7P46Xse8kvAl0363u/u/7udR6v6wtOd9TEQBk1MQAA22GJNfG7O6740Nd+DXzUEvzQcczsfEnfKemspBfO6zOn/v6cpN8zs7dKeoek7zazn3P3dxxxvkeylSdBzLIDL5N0Q0mvkvRuSXdSs2zHRWZ2obt/fBnjmNm3SPp9SVdLermkKyXdX9IvSrpQzRJ+NT8r6cu73VMAACCZpj5scbvS/z0CBkJNDADANqEmBuahJgYAYJusbU28v0LD+YX287J+yxzneyVdW9LL3P1jh+wv4e4fMrM/kvQQSXdXc0LEygz9SJ8Uv6qmIP0xd3+guz/R3e+tpsC8jaSnL2McMztPzdIhE0n3dPcfcPefVLP0359JepCZPbi0MzO7p6THSfrJrncUAAAAKKAmBgAAwLajJgYAAKv2ntnPWxfabzX7+d5jGOeHZj+fd8i+Sj46+3luz+0Hs3UnQZjZLSTdV9Llkp6TNT9F0lWSHmpm1Qen5zgPkvQlas6eedv+je5+tZplzyTpRwr7O0/NsiOvc/fn1uZ2opgf/Os9Rvi3bHG+c+Id4r/yGOo+5879DuZUG97Mk3/JdpX5p9vl9/WgbTSaJv+6blf7Nwr/8vs2Nv/Cv1H2bzyafuFf9zmm/8aj4/tXPQaV+cb7mf8rHbv8WHV9LPo+ht23yZ6DyfMzPG9rvyaV39H+v18d+1XHqMypNn7xl7lyPxd5jdkS+8ucDfnvJKedABI18aA8/Ospf1k/cons1v3fAHMc4t/azqPjcew8pqv8nKk8l5Lxuo7h/UqC1vx7PF8WcuQnfBOPtv+v/oGocHttTovUWnlb11qua6247H+r2u9RnqCDvngONMfamEPoeV+piYE2amIAALbLGtfEl85+3tfMkv+7N7PrqFkh6vOS3rrMcczszpJuJ+m97v6GRe5AcOfZz7/tuf1gtu4kCEn3nv28xN2nscHdPyPpLWqW+bjLEsbZ3+a1c8Z7k5rMlLvN8txyz5J0PUk/cMi8AAAAgMNQEwMAAGDbURMDAICVc/cPSLpE0s0kPTprvljNqgovdverJMnMdszsglkcV+9x5njE7Oev1+ZrZv92zm1mZv+fpLtK+pjm1zjH6tSqJ7ACt5n9LC318T41Z+7eWtLrBh6nuI2775nZByXdVtItJL1rv83MvlXSwyT9oLv/fWVORWb29kLTBX3GAwDgJJks669XgZOLmjhFTQwA2HjUxEALNXGKmhgAsPHWuCZ+lKTLJD3LzO6j5v3/zpLupaZeeFLoe5NZ+9+pOeGh7zhfMFtp6rsknZX0okPm+iYze6+kv5D0EUnnq1ll4qvUnMj5EHf/9KH3eMm28SSI82c/P1Vo37/9uksYZ+FtzOxL1eSuvMbdf+uQOQEAgIzLNB148SsnawQnHzUxAABbhJoYmIuaGACALbLONbG7f8DM7ijpaZIuknQ/SVeoWQHqYne/csnjPETNShEvc/ePHbKbZ0i6k5qVra4vaSrp79XEgj3T3VcehSFt50kQh9l/th41xqXPOPO2+Q1JO5J+6CiTcfc7zN1hc+bv1x5l7LVWy8csvS4NmdPZpVvnfgOMn20Tx6zNo9YvXm/NsTSPfLvyZhol49fmmLaNOj6OXY//6Ci5sgXTcMbhuON8vTKNaR5XHI9d2JdXznScZtdr9zo+3umY1a3S8ePTs3WMw5xVfr7EfbfakudZed+xybL5145X8juV9UuPT3kIAFhT1MTJhkfZ62wfQ7wXLOGvFZZQ4qTW8T2w41t7TeuhqDw2eW2RbNZtd2mtkm3khX5V3cu142WFy/Ou9xmz2q/jZ8ehx+trXf/vue/v/BDP3WS8BSbS9bW11q3zvAYYozXmOr7QAhuDmhgAABwbd/+QpId36He5Kp8uuo6TbfNrkn6tY9+fXGTsVdnGkyD2z6I9v9B+XtZvyHEW2sbMvk/S/SU9zN0/csh8AABAwcSHPcMX2ADUxAAAbBlqYqCFmhgAgC1DTbw9tvGRfs/s560L7bea/SxluB1lnOI2ZnZK0s0l7UnaXyZk/8zbF5mZx3+z228SbrvuIfMFAAAA9lETAwAAYNtREwMAAGyobVwJ4tLZz/ua2cjdv7D6u5ldR9KFkj4v6a1LGOf1ajJVLpL0u9l4d5d0bUlvcvdrZrf9maQvKuz/ByR9LoxzTaEfjqpjTER9jH79uo6frM6az7cSV9EnAqMda1Eeb4jIi9ocR5V9l8bPrTIOwzouu5rEMWTzqEVqxO2mKh/j2C8/My6O39quOOPW+tDFnknkRSXOoxSNke+tc3SF0niMWlxFnEcr36vP06K1hvUK1zLummJywrmk6cBrRm/w4cL2oCauGeiXvFf5MMD7wlJWRj/psRlDvOdVIimialRGXo+UkrX6xlVUa5puw58E3vrMU7hcUxuj1XeBcRadx6J9O423hEd4iMiI6vgd+w0dmyGVj9cir8cDv8Ys45eUmhiYi5oYAIAtQk28XbbuJAh3/4CZXSLpvpIeLenZofliSedKep67XyVJZrYj6ZaSdt39A33HmXmFpJ+T9GAze7a7v222j3Mk/cyszxfyVtz95ZJePu9+mNkPSPqEu//ggocAAIDt4jb8MmerPHkFGAA1MQAAW4aaGGihJgYAYMtQE2+VrTsJYuZRki6T9Cwzu4+kd0m6s6R7qVmW7Emh701m7X8n6WZHGEfu/mkz+yE1Re4bzOxlkq6U9ABJt5ndPreYBQAAAAZGTQwAAIBtR00MAACwgQY+3eVkmJ2pe0dJL1RTjD5ezVm8z5J0V3f/+LLGcfdXSrqHpDdJ+nZJj5G0K+knJD3YvbYoOwAAWJRLmmg06D/erLEJqIkBANge1MTAfNTEAABsD2ri7bKtK0HI3T8k6eEd+l2uSupk13Gybd4i6X6LbDNnjM1fX+U47+EQ++qYu2qLZM9Wxk9ib2Nb3q9rdKvl171wuVu/fI6j1rzK20WjGKGc9cvHLI1f7Vdsyecx/FtZ5zjb2vzDS0HrZSEe4479ptnn69p200q+dbaDcLl7wHWcSvrYZ/3CmK1jGudf2XNlGgvkE2cd+7xM9903APRETZwPuPgmg5QIPe/GMPtekzGW7RjnWHs0vdJqYZKtp0Rl/kmltfmfEo8m+dxU61fZ7rC+XcZv9T0Bv0RDzLH2BO384ahjv/ovYscxetb3g+x7gDEAdEZNDAAAsHm29iQIAACwPaZ8JwQAAIAtR00MAACAbUdNvD22Mg4DAAAAAAAAAAAAAABsHlaCwMnU50StAU7u6hot0Xd/rfGtssx/D624ikrURCkCo9ov29+oFpWRxFWUx6+N0TXmotava8xFLbKjr1HHMw5rZyamyx/3i82I44+yR3FaWWs1nkXXLxpD6hqP0TcFM3ncsvvtyXO3277y50GypHV1u9Ct71OplipSuZ+d00g2mMs0Gfi8z9py5gA2W++S4DgjL9Yo4uIkrPLf1RB3pWtUhlX2NkSllX/uqNY/yXjlWLXerMNlZbVu63NTbfweERiLRBgW4zD6HZuFPnOuoWqt2/WYLDs2o2/URG3+faIyhvhcsMA41MQAAADYdtTE24WTIAAAwMabOotfAQAAYLtREwMAAGDbURNvDx5pAAAAAAAAAAAAAACwEVgJAptlkOVYFxijT5TCQCvjpGPOj67I+9XbukVltPqFy+PRtDj+qLLvrpEXtUOXx1rUxqxt17VtaNXIi0pbjNToG5tRi8pI29Ixp+GGatxG4fKcmbVau/UL+87beiw93loeunjlsIEqERV9+qE3lzQZeFmyDVrdHcAcg5UAfd6HFtn3iqIy+keCHH3fqzTEKvxdx6/FTuTHv1cFtcqSY+gIjcPGL8ZVVLZbJP6icH8Wi1I84b8c4bWub5xH8llj2bEZfT921PSp6fvOcZFxsiGpiQEAALDNqIm3CytBAAAAAAAAAAAAAACAjcBKEAAAYMPZErLeWLUDAAAAJwk1MQAAALYdNfE24SQIAACw0VjmDAAAANuOmhgAAADbjpp4u3ASBDCUnq+bSWZqln2aNLWybUMusJX71dvmj9FuO7g8ro6Rto0q+x4Vthtl/fL9dRkjb0suV96SWse4o3zOJdNKNuw4NHneL1ydZk+0OKZVxh+FtnweSextfl+mB2dFTvMxw5bTynGtnVeZjpnPvzRmrZ9lLV5oUZLV630yfBeZFgDgROhVCvR43+hZcnR/b+k5/tLnddRtTojaM6Lr3W6XFbGwHuDg5R8tklr0kMmUxhn4j19adekQ41c+e6Vt+Xa1zxClhgUep5P2h0Ot50jH+1p5vSweR815TnbZb+21ue/Hji7bSP3nVdv3Br9mAgAAAMAycBIEAADYeMMvcwYAAACcLNTEAAAA2HbUxNuDRxoAAAAAAAAAAAAAAGwEVoLA9uq6CmXvmIuwXuUKlzetxVV0jcoYV8eIsRPpvsej6dx+Td/5MQV5tES8HsfL27rGXNTGr+nar69aVEYt8mKULI2cbRfjKmqxGTHyImtLHsOsLYntSGIzhojGkLKgjsqWIdZi2cvEtpJKDnbYijEpDZF1q8656yFAlbtpMvAZvl0fbwAbqOfvf+dSYsmRFOsyj9ySS61hLCE9qzB8dTvPRknqkc5j9JxYz/vd+XjV+lXbKp+9ShEYXfvpkM+EpSdvLY3hRDzhU0nts8jzIHn+9IvNKB3/eh2dNS4Sj/GFbWrjL9A32a7nC8kAnwuoiQEAALDtqIm3CydBAACAjTdd5dloAAAAwBqgJgYAAMC2oybeHsRhAAAAAAAAAAAAAACAjcBKEAAAYKO5NPwyZ4OOBgAAACwXNTEAAAC2HTXxduEkCOCYtfJMQyZoqynJrC3n0sZ+tbzavC3dLhu/Y79R6DgeTYvjj7LtxoW2fPxTYcyR8mNQHn9UaUv6KfablvstIbd3WsjVnWZvwtPKgxrHmObZueH6KOygNt4oGyOOmW81CZfjY2/ZGJPyYU2WI6of4XIIbszcaucrH7R5/vxJBgn9Wr8Loa3v06Bv9i8AYD10fO3uXS503a5jv4XmMfC+c72OyQn4BqFScrTm75U2zS8Hq4cgfza6Yr2W1UndBzlosmLTcpR+vWq/dvkDYIXLed+O/Wqf2WrzateipY7duq1Ufog73rdWHm7X+xqHr+0rqf1r88hu6Dhmuk3erzxE9X6Wtsvn1PVzwiLzAgAAAIAtxUkQAABgw1nrJKEhxgQAAABODmpiAAAAbDtq4m0y7JofAAAAAAAAAAAAAAAAK8JKEMAiasuuHrNSBEYr1qIWeVGJ4kjiDZJoiW79pHLkRb5dLbpibPP7HbZdKeaiNkaua4xGV9OOT5ipT7Pr5ciLaTiXLY+5KG2Xx1XE0+FqkRqals+bSyIk8n7hai0aozWvwvHPl9hNn3fltWFbS/MuW9c1rZNtOi6JyxK4C3FJk4HP++SQAxtugfeMpcc9DBGBcRLiNgbWN5qkd7lQ2V+tVOm6Sn7crlUyhbc4z3YQ4zFqaQPJ1VrcQ8/V+7NJFeWxZL3G7BiVYaOuD1q2XW2OC0QTdtbnmAxQ9/ZOgeu45UKxGccZlVE7dn0iL/Ltqv16Ruh17EpNDAAAgG1HTbxdOAkCAABsvOGXOQMAAABOFmpiAAAAbDtq4u1BHAYAAAAAAAAAAAAAANgIrASBZq2W/fVaFlne8SScLNV1jn2XXY1D9IzKSFZnbY0xP/JikXnUtotNefRDKQIjxljk/caVqIl8u9h2ysqRGqcKsRnNdpNiWykqI4+xqMdhlLMb8vvaxaRyhuHUwzlplreFWIusMUZntKIywvU9Hxf7jcJ6sJMsyiKP2Ei3C+OH7fLHOsZjeB7ZofmPU2ueye9C9ywIryyJ62G7pCk7PnFZZsuOf7q6dTqPY4/fWHcrXBfMZUl0zFBjAtgwrk7Ljy8lCmLoGIoBojFWGXnRuzQfYB6d912NdKhsVy73q5EXtV3HJDXL3u7i+1USjVH7bNd1Wf+8qedK/sUx89vjDhZqCxdjBMYikRd9Yi4WeCIPXlVU9t39Kd5vVtXx4+GvzbFrVEbPWIvW54IecRvtQSvz6tVviOyZbAhqYgAAAGw5auLtwkoQAAAAAAAAAAAAAABgI7ASBAAA2Hi1lVgAAACAbUBNDAAAgG1HTbw9OAkCAABsNPd2DMwQYwIAAAAnBTUxAAAAth018XbhJAjgGCSZo71Djstj1vJUY1veb1RtO7g8Hk2L/cbh+qnQL++bt41CAGocv9bv1GhSnP8om9cpm4a2g8vj/H5WgljT8afFfn1NPSYSTcLt6ZvwNGRK5WcpxjHy7fZC2yi8E+9Nx+kYxSBjyeKYWYDS3vTghvi4xdul9Hkwzh5fxb6Vtni/28/3g7a84EjvWtrYyhrGeqBoBLCGOpdvQ/c7bN8D7G/w+1YxyH1ZZMxlyvYby4pKqdIeJraF7fJNanczGSIrpyyUWklOaVY0xTmvtESq7dsKlw9ps1E8sOWDbNW2eKXy2avYUv/Mdqy6PsDZfKuzT2r1SrfqGGHXlWOV1PC1X5Ta8c6OgZV/NVJdf1G6/gIv9Iu+Lr+kAAAAAHAycBIEAADYeOlJRwAAAMD2oSYGAADAtqMm3h480gAAACtgZg8ys2eb2ZvN7NNm5mb20p5j3dTMnm9m/2Bm15jZ5Wb2S2Z2vaHnDQAAAAyFmhgAAADAMrASBJCpLd953PpFXlTaKtuNR15sS/otEKkRIxLGWZxEbItjnLJJp35N3/mRF5K0Y/O3y/vF+1OPxlh2HEa4PXukYhREvs00rHm8m7UlERgxGiM7jkl8RTalJGIjPwShbykao9kuxFpkQ1hy/NP77fG5VVlj2qtRGfP7NX1Dm1a3vGzn5XfRm8s0qS5Q3W/MAfyUpNtJ+qykD0u6oM8gZnZLSZdJuqGkV0l6t6Q7SXqspIvM7EJ3//gQEwa2xUKr1g8cJ9E7MmLZ4/cds+P4q4wc6SWvubvmVdTaktqkMn42XiwBW6vrlxIe8jgPL7dVa5VqDojmt+XzL7Xl43Vss1HeNn/8vF8t8qJzzEXHJ/KyP3PWaspWvdy19q308673u3Ik+0RltOLtanelFpVRiPPoHI2RjdHuW5hH7379HkNqYmpiAACAbbfGNTGWgJMgAADAxpuuZ3by49R80ft+SfeQdGnPcX5VzZe9P+buz96/0cyeOdvH0yU98mhTBQAAwElHTUxNDAAAsO3WtCbGEhCHAQAAsALufqm7v8+9/xogZnYLSfeVdLmk52TNT5F0laSHmtm5vScKAAAALAk1MQAAAIBlYCUIAACw8UrxMxvg3rOfl7h7kkXj7p8xs7eo+UL4LpJed9yTAwAAwPqgJqYmBgAA2HYbXBMjw0kQwIp1zZDNc2NbWa6F2+Nmo7wtXM+3i31LlyVpPDr4fuHUaJq2WbntVNI2KY5f6idJO6Et324njqk4/3Qecbuxym25WltJbZml2DbJFumJbfkb9DQ8wqPpONsuHJ+w3V7WbzQOx2ea3q+kb14bxMMV2vamacd4rFpHLTwvJtl28Tkfx8iPY/rcTduSHOw8f7rwENZykgeJF++bw4wWmx27FR7BC8zs7fMa3P0OxzSH28x+vrfQ/j41X/jeWnzhCxyq09v7Im8GpfeaAcY4lvELquNX2vpu13WOPcqzhcZP3nAW2FfyVp/X9KUyJq9bYpmU7TuWt/l3OcW2vP4IhVGrVCmXWmVDvDnnY8SJ5XVp5TOVjWJbuFj5fFX6rDV3/MJ9rY7R6tutX9e/k2/XvZUdxFq9drdrO6yMnwwZj0mrpg9N+TxKx7jyi9i6z7Xf38K8ao9Le47l+9Z5HqV+h/b1+dscH2piAAAAYABmdlNJT5N0kaQbSLpC0islXezun1jGOGZ2M0kfrAz3cnd/cGE/D5P0aElfKWki6a8kPcPdX911rsvESRAAAGCjudIThoYac02cP/v5qUL7/u3XXf5UAAAAsK6oiSVREwMAAGy1da6JzeyWki6TdENJr5L0bkl3kvRYSReZ2YXu/vEljvMONSdK5P6msJ9nSHq8pA9L+g1JpyU9WNIfmNlj3P1XDpvrsnESBAAAQD/vPsa/butrv6pfo++oAQAAsEGoiQEAAICj+1U1Jy78mLs/e/9GM3umpMdJerqkRy5xnL9296d2maiZ3U3NCRAfkPR1+6tLmNnPS3q7pGeY2avd/fIu4y0LJ0EAh+m9ru78MRY5x6y2hGq6XOvi20jSqBA3IKUxF+MYGZHHWiT9ym2nWm2TTv1irEXeFqMtdirjx5iL/H7G6zuWxm1E+X1Lxqh8j1I7q3BSyJ7K4x5iPEYeNRHb8nmUojLG2THYrUVepAOmRoW26hjlRs/m5eGJHdvyEeJW+bK3lizv272tqBU3E+bYdTlbvnZbAdNk8NiRtYkx2f+rtvML7edl/QD00fW1u28URNd9LSNqYuDxlhF50WfMIUr4rvtqdesaeVHZrhqPkEcdxKasXivFaLSOT1zJf+DnUksr5qJHv0rkRRJ/kW2X9MuHr0VqVD5vDRGH0VX32Ixa3dtt/HacRHmMPlEZee2fjleJ16j9PiVReNlni+QXrLxd11iLatRe1/i7hSIvOvaroiYWNTEAAMCWW8+a2MxuoSa+7XJJz8manyLpEZIeamaPd/erlj1OB/snUTw9xmu4++Vm9hxJT5b08Nk+V4aTIAAAwEZzl6aFk46OMuaaeM/s560L7bea/SzlIwMAAGALUBNLoiYGAADYakusiS8ws7fPb++0atq9Zz8vcffkzxvc/TNm9hY1JzfcRdLrljTOvzCzH5Z0A0kfl/Rn7v7OQ/bz2jltr1FzEsS9teKTIIZ9pAEAAHCcLp39vK+ZJXWdmV1H0oWSPi/prcc9MQAAAOCYUBMDAADgJLvN7GfppN33zX6WTvodYpyvl/RcNXEZz5X0DjO71My+LHYys3Ml3UTSZ939iiPMdelYCQIAAGy8PGbmpDGzHUm3lLTr7h/Yv93dP2Bml6g5g/fRkp4dNrtY0rmSnnfE5c0AAACwAaiJqYkBAAC23ZJq4nd3XPGhZD/WrRTftn/7dZcwzuck/bSkV0r629lt/1rSUyXdS9LrzOz2oZYeaq5Lx0kQSOVLGdZeCzpm226UBbJ5u+a1dt2mlilbaxuFtnZ+baWtMMYo6zdSue1UCCU+NZqkbaPp3H47eb9q28H1HSuPP1Z5jDj/cRaiXGsbwiQsuzQNR3ySLceUtKV/1KJdH3/hcryfkjQJi/0kj1M2fmzTNHtbqK0XFHcX+vkkfSLH50We/RsLjvrzM4yfZxwXtsn71tvi7eonfw0Ix7WVqbwtuh7L9VlG91iZ2QMlPXB29Uazn3c1sxfOLn/M3Z8wu3wTSe+S9HeSbpYN9ShJl0l6lpndZ9bvzmqK1PdKetLwswc23CKvS5W+lRKt+/76jN/zdTUZr+/9ytsKfRcaY4DtjvO9pvWub7XGI/aT0jos7xrrtVq945XGyue++Hj0PsTJ/fb5l7N+rc9NlWNno8LnlVbtGS8v0jb/nvf5PHgU8WHrWvfmbVlLZW/lJ0L+9Ckehkp9nH9mUNe6PQ6ZzyOZY6twn79dZR65+rziL0rtQ39hHhuOmhgAAAA41P6nhaN+UmiN4+7/LOk/Zv3eZGb3lfSnamrqH5T0ywvua+WfajgJAgAAbDRXejLRUGMO4PaSHpbddovZP6n5cvcJOsTsL9/uKOlpki6SdD9JV0h6lqSL3f3KYaYLAACAk4qamJoYAABg261xTby/esL5hfbzsn7LHkfuvmdmv6nmJIi76+AkiMP2cdhKEceGkyAAAMCGsyUsc3b08dz9qWqWFevS9/LaTt39Q5IefuRJAQAAYENREwMAAGDbrWdNLOk9s5+3LrTfavbzvcc0zr6Pzn6eu3+Du19lZh+RdBMzu7G7X3HEfSwNJ0FgteKLTWupyXB5TVeSr8VQdB+k3xil5VVbK8MmURZpWzXmohCVcSqLhRjHWItRFidh5bY4zpnRXuiXxlXsVCI1dipxGDH2IraNsvPydsK+x8qPwbTYNoRJeLSmIaJikj2KsS3GX0jS2A/m2DkqY7qTTqQaeRHeJir9ptODOY+zxzrZdfbETaIysjHjMrgetqstj5urLUtbbFtg/I21pvfZ1nReALbMECXBcUdBDDBG16iM1hL0HSM7ho65GOJYDaby9pV8HOoYh1FbyT+v15K7GmqyamRHx0iTQ5qK47dqudI8Wh9swnajdIwYeWFZW/K5JvarRF6Msnq2a2zhIJ8PO2pFxNXi42pxFYWYiHpsRveoDC/0zQ9psu+8rRQ5ku+r9h1Cx7iQ6u9C11iLmkHGyK6vfJFZAAAAAEd06eznfc1s5H7wHz9mdh1JF0r6vKS3HtM4++4y+/m32e2vl/RQNSuwvSBr+8bQZ6Vq//UFAACwEaY+GvQfAAAAcNJQEwMAAGDbrWNN7O4fkHSJpJtJenTWfLGalRhe7O5XSZKZ7ZjZBWZ2y6OMMxvrzmZ2Op+Tmd1b0uNmV1+aNT939vNJZna9sM3+fq9R++SIY8dKEAAAAAAAAAAAAAAArMajJF0m6Vlmdh9J75J0Z0n3UhMt8aTQ9yaz9r9Tc8JD33Ek6eck3dbM3iDpw7Pb/rWke88uP9ndL4sbuPtlZvZMST8h6Z1m9gpJpyV9l6TrS3rMLMpupTgJAidT16iMExCpUVNbdjXtV461qC3PmrRlY8ZxYpRFPkbSL4ukiNvlMRqlCIx4u5RGWeSRGrHtnNFusS3GWrRiM8L1JDJC6X3L24YwCYvxxByqicqxFjs+KbbVojKuVozASI/VKNuuaJq9ZYRpTuO8spMf433LH8O49GyexVV67ua/F9VIjWRJ38qytxWlJYI3wpYsnetqP7+GGBPABuoY3VAydKTDkcbsMUbnfS0y365xFcsev8M2R+rb9W2mFfEw/3Ir8iLOoxJ50ZpG7BvKsNbbYnL8WzkI8/stQyUOoxplEdpan4diW2WMWlvXz001XaMyutabtU8ntciRfPxSvZzHZkSLRWXMvz95TEb1Xofxk63yx6kyihevVOr92u9JJUKvfXwKk6rF8C0SedHx9YeaGAAAANtunWtid/+Amd1R0tPUxEzcT9IVkp4l6WJ3v3JJ47xE0rdK+jo1URY7kv5J0n+V9Cvu/ubCfh5vZu+U9KOSHqHmY+pfSvp5d3915zu+RJwEAQAANt70JJ4JBwAAAAyImhgAAADbbp1rYnf/kKSHd+h3uSqnQ3cdZ9b3tyT9Vscp5tu+SNKL+mx7HAjwAwAAAAAAAAAAAAAAG4GVIAAAwEZzt+GXOdu0aBQAAABsNGpiAAAAbDtq4u3CSRCoqwbMFvod1nfLdc2CPWy7PuPkebXxeis7N7ap3O+UHaTRnhpNi207o0naFq7vxH6W9jsz2iuOccZi217SFscpXZakseK+0zHGlWM8rqbwzjepLL4zCW+Uu56+NMc57/o4aRv5dO5lSRpNw/zDrneVjpHclcr6QK1losJ209FB23SSDhKfFz5JxxiHtrz4SKOpQ05vFrIbp9+K2S7l+/bstzaWkWU+hK77WmBOdhIeDwBbrVqSldoq2/Qa7whjFPvmt4frvccvXc60xu+z7+r4lcZlvG/W3spiXRP75TVZx7fD2seyWEZaXspa4fKcMbs3FrQKtsIDnD/Y8VBlxyd+RrFR9pknXB+F2nOU9Yv1YD7F8ahc+yefmwYpW9J5TQvHuFYj5fVsrLPzz5FerIPTMdJ6ubjr1nblJ0le+5cHTXqGOba2iPfN8/lXZhSfdrXPBckvVM99932Nqe0bAAAAANDCSRAAAGDjDX2GLwAAAHDSUBMDAABg21ETb4/K3/wCAAAAAAAAAAAAAACcHKwEAayR3lEZlTFqS7ImK+7mMRdhydc4ZivyIkRUtMc4aDuVrbkbIzDOjHbD5SzWIoxxJourOCdsl8dcxGiL2G+UxVicrkVltNYJPpCP08W0Godx0Lbr6TxijEYeh3E2RGdcM91J2sZxid8w3Xzp32yS6dWw1vA0Ox6TsK7rqXB5msWWTKfl5XdrUStdz8i0ytKzwD7O8AWwkGXEVaxJBEYtaqJ2ezHW4rB5FLYbJPKitZ2X+yn2W2D8jmN0fpupRkFUBqwthd8x3SNZkj8vS2uPb8fHvtpWidsoteWxFvF6KyowibxI28bjGIERPuNk0xgXPv9I6Weqdtv8O177bLdI/Fqs/mM9U4tVmGaNlmxX3nes9j2PzahEZdQe/DQKoponEfrlTYWokkqcXu2XNEvXS7crRGM08yrE1+SDdNx37X5WX1S6H/4WamIAAABsO2ri7cFJEAAAYKO5hi9uiWIGAADASUJNDAAAgG1HTbxdiMMAAAAAAAAAAAAAAAAbgZUgAADAxpu21g0GAAAAtgs1MQAAALYdNfH24CQIyHSQEZrnfibKkZ3DaOXeVjJ9S/uujdF1Gnn+cS2Ad8mvlbUc2T5j1MZrZduG+xpzbkfZMYhtp2yatO2E6zujSdJ2Klw/NSr3O2N7X7h8zmg3bQvXdyzd7hw7+4XLp0Nb3m8njD/O56+0b5T37WMSwpindnD5rI+Tfrt+8FI9VrrfUbgec4wl6Wrfmb/jbOrTEHI8yRYImoRjkBcHcdmoOP88Fzk+Z05lc/RJzMctP7dqz+M807ck7xfHWSSXeS0NMf9lH4POGesn/LEAcLIVXqt6l2R9xltgX8Vx8pLVy22l7Vpjd2zrPOYic0zG8Epbtzn1nX9N53evVj0SdmXx9nTHnpRoPd8rrXBZSupDz9aLrH0sG2TdzziXkc+/XZKFNstqylFoG4/ztlAvx8812RjjMEZez8bHo9WmHiovArVDWquTYj2b94u/NtPsdyhuFx/61hKx1Reuck2f/8rO22bWs9iWjBE/F+RDhjm3dps8kSuPWu3jf+3zQ2W70r7zzyel+5lvBwAAAAA4HCdBAACAjeayJWS98UU0AAAATg5qYgAAAGw7auLtwkkQAABgs/mcv2YcYEwAAADgxKAmBgAAwLajJt4qnASB5SivZLmekrVnu79iJUuODhBdUVNbyr8UG5BrxRTUlnUttI2yGIjYVo28aMVQzI+oiPEXUhqBcSaLwzjHduf2a8bcm9vvdC0OoxX1cXBfT1eiMfJjEk3z9YSDSXhQY+TFTnYMdv1g33lUxihEXozztWbjtMrTqPZLIy/SJ+EkxGjEqIy8iJiG58F0mrbVlhaORzy2lR+J9hjJqtirXEI2mUhled81iaRY+ZgAcJIM8TrYOTKo2xirjavoN36vyIve46tskRiNHlpv9aWIilpSQOv4dM0GK4+ffBzKSts0ZqFca3Xed6stfpYJN4/S0ZPPJHlbiLbIYy5iHFuMvMij5OL1fLpdPzcNIa9ZY20d4zzymjtGW7bjMBaPyqiNkX/6iftu19y1nIiu/ULMRSUyItlzPv+kY75dafxsGvF1pBX7scLPGifhOxcAAAAAOGacBAEAADbe4Gf4AgAAACcMNTEAAAC2HTXx9qj9bTAAAAAAAAAAAAAAAMCJwUoQAABgo7mGP8OXFBAAAACcJNTEAAAA2HbUxNuFkyCQaOV+1vJNa1mZx6nrPLrGj26YPLO21Na136k8YzeEBo+ygxwza3dskrTF6+eMdg9uH+0V++VjJNtZut05tjv38unWPPbC5bRtHO7POLtv8ZjkbdEkBBvnb66T8MSL+971cXEeo1YC7/x+s84HpoXbs3lMp+kcz4THI5//1A4G2lP5uZQ8zyrHsbbdJOw77zdZ01/gQXKB+1RQ61R1dc6473msFrivK81pBnDi1Erg6mtPpa06Zl8xn77r+Fm/ZLvaeIV+tTGqba1+Xm6bxn7d5lXrt1BbaV89WeXtyEON1nrbqszRw7Gb1uqiUOrm41vcd+X4t9rmT7E9/2SjyiCjgzYbpf3i9VHWNh4fTLL1eSW0jUPbOJtH3M5q9WzeNsATo/a4xRo8Xh7ltXm43nr6hDm3PvPH7cLlSfljR2tJ0eRzQvWXqPSMqfXL+x605c/HuO/WEQ1zbO052a42fmFKrfHyfc/fV/6LEl8favet/gtWR00MAACAbUdNvD2IwwAAAAAAAAAAAAAAABtha0+CMLObmtnzzewfzOwaM7vczH7JzK637HHM7G5m9kdmdqWZfc7M3mlmP25m4zl9LzSz/2Jmf2FmH53t44Nm9ptm9hV97jsAANvFNB3430YvIYStQk0MAMC2oCYGSqiJAQDYFtTE22Qr4zDM7JaSLpN0Q0mvkvRuSXeS9FhJF5nZhe7+8WWMY2bfIun3JV0t6eWSrpR0f0m/KOlCSd+R7eb3JX3JbD+/LWlP0l0l/YCkB5vZ17v7ny16DI5V39iM2pKanSMwui7LOYDaUplrYpEplSIM2pEF02LbqRDxkLftjEJbGD+PpDgzirEWZ9MxQpRFjLzIr8fYjNPKIjXCGK05qrxcbi0Co2SSrX8cIx52wzlp+dhJHIZl69KGq+NKW9z3JDv/LR6DGHEhSbvhM3e+tPCux2WHY5xHOsYojNmav1qf6eeqPXdHobGyau/yLTuGYinLqPd4oVpl3MY6RX0AG4CaeCB9IjAWeD3rHDVRG79PFMRQcRKluIppFnXQ9X5OK22VeSQlyAJRHMV9DST5uBJjJ0bpe7THtrx8CvPKoxmSmIXCvmYdD9qy8sBrz4uOkpjFvPyIERi12InQL8ZfSGmtfipvCzXszmh+NIaU1rp5Xd01RrC0jVTPne3aFpdtzSM0pkmUxajYVovKUNwu+5OZ+DyY5lkNYbvWfSker1pmRK1v+cuAVoRE7FmJkyjOsPa7UBm/tbxu1xiNrlrfj6zhlw/ACUJNDAAAsJm28iQISb+qpiD9MXd/9v6NZvZMSY+T9HRJjxx6HDM7T9JvqEljvae7v212+5MlvV7Sg8zswe7+srCPX5T0Enf/h7hjM/sPs/F/XdJXd7zfAABsHVf9Pxf6jglsAGpiAAC2BDUxUERNDADAlqAm3i5bF4dhZreQdF9Jl0t6Ttb8FElXSXqomZ27hHEepOZs3ZftF7aS5O5XS/qp2dUfiQO5+8/lhe3Mz0n6vKSvMrMb1OYKAAAARNTEAAAA2HbUxAAAAJtrG1eCuPfs5yXunqxx6e6fMbO3qCla7yLpdQOPs7/Na+eM9yZJn5N0NzM74+7XHHI/XM2SZ5Ky9f3nMLO3F5ouqG4Xl96sLft5AqIgjltcKjMuo5kvjWkDr6s7WuDYWyHyohmnEsEQjCv94hh5zEUSgTHaK/Y7HaIaTlseZbE797KURmDEttPZGspnwph55MVOmOM4O67xDLJaoEM643T83XA9zutsdn7aNTEOI18DOnbNmiYxLiQ8MabTcuRFfvzj9d3snsbHd1y43Eyx/Bwvxa5Iw/9ubJRFzlY9zsPYcV923Ev2+pxliQcYEzjhqIlTF0jDxFcUdX6N7LnvrnESXduGGENZ7EXPuIo0RqPbvtv9ypEXfe9bsV9FdZX8UKLlcSGxLX9Pm1aK0aSemoRIhDzqIB6vbDyrPG5pVEbHNf/zYxBjOuIxGKVjjEJcRSuGb1yOuTgznsxti/F8UhqH0YriqMTTdY3HiPK/PJp6+e9T9nx+1EReT43CgR2N0znthfp/lG0X2+LxycePERuj/EGMx7wSxVH/RemaGVHrF76/yNsqtWAyYiU2o7hRNpX8c0yxDq3EWiwSxdEZNTEwDzVxqvo9MQAAJx418VbZupUgJN1m9vO9hfb3zX7eegnjFLdx9z1JH1RzYsotDtm31GTCXUfSW939kx36AwCwtaZug/4DNgA1MQAAW4aaGGihJgYAYMtQE2+PbVwJ4vzZz08V2vdvv+4Sxhlk32Z2c0nPVnOG7+Nrffe5+x0KY71d0td2GQMAAAAbg5o4HYuaGAAAYPtQE6djURMDAICNsY0nQRxm/7Sdoy5g0mecQ7cxsxtKeo2azLhHu/tl/aYHAMB2cA2/zBmrnGELUBMDALBBqImBXqiJAQDYINTE22UbT4LYP4v2/EL7eVm/Icc50r5nhe3r1SyX9lh3/9VD5jioPBPUe2SfViI7D9kuD44t7Lv3+OWNYpaotQJst+PlLebcjrKDHK/vZPm4Y5VzdXdscujlZvxpse10uH46bwsRiKfDGGdaY8TxkybthMvjLJQ1ZgmNK0+0SeUtcBza4qzifc7lxz+aZuHO0zDLXT94uc+PY7y+a2kIdJp/nO47eXxVfo4k453A35laUdQnm7e1TRy/7+HpnBffs8Ab4GHL30OOc98A5qImrqm99lTa+r7Ndd2u1c8Ll/uKmfaVfVXbpnnG/fztLC93erZZad/ZNOJ2i903n9/W97Gu3JAkiGe1p4cybzrO6/GDvvmhG4VhpuEO2CQdP5aR+TFO5pW/n3cthuJm+UGO84qfO0ZZ7Tk+mMipcVrPxutnsradcH1ndHD51Ci9o6es3Fb7PNTHtPVMONh3vpzqaDoKbeFyNsZe6Nequ+Lzp1KTVZdyDcdkMk0/d8TnoLJjp2T+oV/1hS+fR6lvrV/tc322Vel+Z3OM3wf0+RzQ2nnr+4v4Gpb9jsbXiuJ2FM5AD9TEAAAAG2p0eJeN857Zz1KW261mP0sZbkcZp7iNmZ2SdHM1S5f97Zz2G0t6g6SvVHNm77MOmR8AAJAkDZvz1nyBT94bTjxqYgAAtgo1MTAHNTEAAFuFmnibbONJEJfOft7XLP2zaTO7jqQLJX1e0luXMM7rZz8vmjPe3SVdW9Jl7n5NNt5NJb1R0gWSHsmZvQAALMZ92H/ABqAmBgBgy1ATAy3UxAAAbBlq4u2xdXEY7v4BM7tE0n0lPVrSs0PzxZLOlfQ8d79KksxsR9ItJe26+wf6jjPzCkk/J+nBZvZsd3/bbB/nSPqZWZ9fi/M1sy9TU0jfTNIPuPsLjnD3y/Z/UYc6Yam8CuXwuu6rtcRlXPf26Pt25ctVFpayrCz7mS/DGV9AveOrab4C8Xh+t94WiTOIfcd5VEa4HmMhxtkivqeTqIy9dPwkKiNtOydcP5PEZqTjnwmH/HS27PBOeExHWVstAiMd40AejRHv9251PetpsSkugzu13aRtEtp2QszFrqfPinjMx/kc4+Nk5WWBa2r9VhmPEX/fOueALRLpkDykA0RBdJ5jv131NvT+KByBY0FNPJzqW1mf17RyUkBnfaMsOs8jb6vFUMR9J7EK+RiFflnfdhyGz22rj5EtcV8ZPz12lQdjgKXxPdSbnkVBxPFHrc8Mhc8dSuMxYjmbpahVj53Vnj9dWeGyJAv3NY3DyD8/HLTtjNO2ndB3J4/DCBEYp+Plcfr54VS446dG6RjjJcdhTMLjFiMvpLRenoZskr08kiIcx718jPAcyaMs4p/GJDEaeb9km/T4xzFH+QMc+5aiMZqdF3c3dGZvrvTZvfZIZx8P077561sYf9n3BcBiqIkBAAA219adBDHzKEmXSXqWmd1H0rsk3VnSvdQsS/ak0Pcms/a/U1Ng9h1H7v5pM/shNUXuG8zsZZKulPQANfltr5D08mwfb5zt9+2SvtzMnjrn/rzQ3S/vdM8BANgyrnnZ20cfE9gA1MQAAGwJamKgiJoYAIAtQU28XbbyJIjZ2bl3lPQ0NUuO3U/SFZKeJelid79yWeO4+yvN7B5qCt9vl3SOpPdL+glJz/L2n/vfbPbzDrN/87xB0uVd5gwAAABI1MQAAAAANTEAAMBm2sqTICTJ3T8k6eEd+l2uSlhC13Gybd6iphDu0pe1EgEAOApfwtLDnOKLDUFNDADAlqAmBoqoiQEA2BLUxFtla0+CQEH+y1p5LYh5oV4Lh41N+Xi1tpr4ItV338tW2HfrEHe9L/nwPbfratRxzM79sns+Cpm78fI4CyGutZ22g6zeHUtze+O8kvzg7HlwOoS57mRPkh2L2bZpJu44D4HtYJSdwD+N98djEHO+ZcgBVnoMdhXnmOUmezwG84/3YW3J49R6DH1+vyU8H2umtZeA+DrVdVo9i6Bj/S5ikUPcZ14D5dtb1333fcossF0rdxoAcq7y60rn95Bu3Xq/VebbhevJmHkefaWtNEZrjj3GkKSktPDC7ZV+eZtlb/xJW3V8L7al8yqPn97PbJJ9H9P4OSFeHmfDj0JNM0p3ltYg+cGL24WbszFsfNCvdnyqz61ODWrXuvFjTZjXKJvjqfHBxE6N0knujMPnglH6ueCc8e4XLp8O/U6P9tIxLI6fjhE/T+Q1cVdxydVJVpdMw4Mz9aweT9pC7Z8d473w3B1lY+zlT6h0Ygf94mee7Bhrmn4eSid50HeS9Rtp/vcG+WixVmt9Zk4OV+34V34X4jzytq51YjzmtW1q33t07Zf/DoX95R9FO3/OETUxAAAAQE28PSqfYgEAAAAAAAAAAAAAAE4OVoIAAAAbb5G/kAMAAAA2ETUxAAAAth018fbgJAjUdYyTyJc8L8Zj1OI2FojiKFpkjNqysYVB8mUzLVm7tTxGfFGtpSi0VtXt+GIcl++pLe+yyGt71yWBav36xCK0Ih3CrMfZPcijG7pslx+feD3GXzRto9A2ztp6xGFkx2M3XE1iOrLlayeV+Xc9Pkk0Rt4vHPOxysd0GYZeemoZS1lVn8XV2IhCFEc+x+ry4kuOkxh4jHWKvwCAZVlK6lPXGIoBxu8clVGNvMhq4q7bVSIv6lEZ5SiLUlRG136HtZXnX35gFnmOJAl3MQ4jm3+MsvDsU3zsmteoSfxAjNTI0hFispzlbbXHt4/sAJUiMPLaeRwiF2L8hSSdGR9EW8T4i+b63tx+C8VhhKPc9TNOrS6dZFV97JtHV4ym49AvzMPzzy4H/faytuxJUlaKxmgmEvp1i8aQ0niM2mfhOGL9CC/+OV6qfyaPn/PT5I1sjNre4u9vLQ0mPH+ONU4PAAAAALYMcRgAAGCjuZovmQf9N+D8zOymZvZ8M/sHM7vGzC43s18ys+stMMblZuaFf/844HQBAABwAlETUxMDAABsu3WviTEsVoIAAABYETO7paTLJN1Q0qskvVvSnSQ9VtJFZnahu3+843CfkvRLc27/7ABTBQAAAJaCmhgAAADA0DgJAgAAbDhbwnLDg433q2q+7P0xd3/2F0Y3e6akx0l6uqRHdhzrk+7+1KEmBgAAgE1CTQwAAIBtt9Y1sczsppKeJukiSTeQdIWkV0q62N0/sYxxzOxWkr5N0jdIupWkL5X0CUlvlfRL7n7pnPG/X9ILKlP4EXd/btf5LgsnQaC7fE2Xyu91zIX3vsHJcbPaa0gSpFvO8G0Z+nWuteuDHcTcz1quqFWOVf7CnOSMVnJFY75sFu+b9J1WDkgco5ZtO4Rpz5SeceXBHiX98u3K92ccgl3zfOWx9ZhnFu48ToJj43jlfvn9HIUnQt6WZBdnYw5tGuafP0f6Pmfi8zPes3y8WtGSjFH5HUov18YrNg2TkV3TNY97Gb+jtVzjrvvre3yGOK6+hNeuAeZlZreQdF9Jl0t6Ttb8FEmPkPRQM3u8u1919D0C6GwJr+l9S+JENoYV3hsW2lfH7Sx5s6yMkZccpTlm/eJ1m3qlLd/OF+432it/Zqhtp7iv2jGoFgzZZjb/s4yPs7ollIqt4eMUs6ZRGD+OMdrLhhjHQdJ9J8e1er/ViWVvyfHqaHSws1PjSdLvVGg7PUrb4vXT2XZnxgd39lrj3bBNehB2bDL3siSNwp0bt57k8028/Hkhr0t2/eBTyih7gE+FuezFftP0k804PgCT7Kue8keNckhq1m8vdFzkM37SN+xrUjmMrfqysL9Fvry0ymfmXlrfPdS+IIn9amN27NcXNTEAAAC23ZrWxNJwq6P1GOenJX2XpP8r6Y8kXSnpNpIeIOkBZvZYd39WYXevkvTXc25/22HzPA6cBAEAALAa9579vMQ9PUvK3T9jZm9R84XwXSS9rsN4Z8zseyV9maSrJL1T0pvcfVLfDAAAAFgZamIAAABguNXRFh3ntZJ+zt3/Kg5iZveQ9CeSft7Mfs/dr5izr1e6+ws7zGklOAkCAABsvAX+KHcRF5jZ2+fvz+/QYfvbzH6+t9D+PjVf+N5a3b7wvZGkl2S3fdDMHu7ub+ywPQAAADYYNTE1MQAAwLZbUk18JEOtjtZnnNJJDO7+RjN7g6Svl3Q3Sb+/0J1aA5wEgcb+L/0iq8B0jKuoRmN0jbzoPKduy2a29t1rfUrJQ1/L70ASgVEcIm3quFx/cz0s55ncXo4KqMUUdI0wqMVmtPpW4jamleVho8nguSVlo2wt2Pz6Mvc30dH/KCU/VpMwfteYkUmlX/sxXPyxqT4HO0ayVOMqKvuu/W5Ul69N+tXHTNu6jaFSv3l9izvr+XtSGn+I+ItDxhl0m5Pr/NnPTxXa92+/boexXiDpzZL+j6TPSLqFpB9VU9i+xszu6u7v6D9VAEUDvNaVYi0WUR2ja2RBzzFq+y5FVHSNtWhvV47KGE3CGFlplcZapG3pdrWojBiHkfWLYy7wjYrFbIgYeTHJ6pZxuW4fdfz4Ev8G2kdZ5EVoq0aa1NpqrPwEshBzMQp3ZpzdsZ0Qc7GTRV6cc+og5iJGXuTXrzU6+4XLZ7I4jHg9j7wYhTvaNw4j1rp52074LLCbxVzUojKyHRwYp/ctj84oblf7yFDrNy1H48UYiriZZ7ko8VdvlD1Hks8Cydj5JPtmTcTxfc6t+43z59HaU17SD1HfViI29/d3fJ+cB0dNDAAAgG031OpoQ6+ytv+Beq/Qfnsz+3FJ50j6iKRL3f3DHcY9FpwEAQAANpproOznbExJ7+7412197U/60K/O3f3i7Ka/kfRIM/uspMdLeqqkbx10dgAAADgxqImpiQEAALbdEmvidVkdbbBV1szsyyXdR9LnJL2p0O2x2fWJmf2mpB9396tr4x+H5f6ZMwAAwBpwt0H/DWT/r9rOL7Sfl/Xr47mzn3c/whgAAADYANTE1MQAAADbbk1r4qFWRxtkHDM7I+m3JZ2R9FR3/0TW5YOSHqPmpItzJf0LSd+pJobjhyU9/5B5HgtWgkCqvCrkINu14h5KkRH5GL3nVRmkNEbrRau2Lnxt3/FiXIc2W/41aSqvm9mOw5gfD5AvzhpX/s3H7xqHEaMrpukKOtoNbWcqcQn5kq+TZMxRsV+yTSVSY9JeC/WgX7FFmoQHapr1TOMZsnmF4zC2bueTTbPnUtxfvu9kjuHBz1dorkdIxLgNm3u5GWP+Y9Eao9U2P8qiFZuh+c+l1hjZc3AvLKubxrok3Yq/C831+ZfbbeWlbavL19aiLIY2xL663pdM5wiMvkv9blcERvSe2c9bF9pvNftZOnO3i3+e/Tz3CGMAW68aIbGE7RK1KIuO41fjKgptedxDkmZQiUSoRWVYz/FrURmlCIw81qIaqbHn5bZJoa1VWIRteq59H+MBbJTXNPFDwyhrC1fyjxNhnJj+4FnUxDTEb1TjSPo+p61wWennoRiDkEdenB5NwuW9rO3geisOI0RgxLZzRmm/M+H6TpanMu5RrFQ/u2Rtu9ODr2ZG2WMTIzBqcRgxskPTU3ljN+Gxnmafr6ZJrIWX27InSSlNxfJYlOpn6/D8rDwJh/6LroVU4iqKm+THapXzXy1qYgAAAJx0a7M62lHHMbOxpJdIulDSyyU9I+/j7m+U9MZw0+ck/Z6ZvVXSOyR9t5n93Kqj6FgJAgAAbDwf+N9ALp39vK9ZejaVmV1HTaH5eUlvPcI+7jr7+bdHGAMAAAAbgJqYmhgAAGDbrWlNPNTqaEcaZ3YCxEslfYek/yrpe927/6WHu39I0h/Nrq58FTZOggAAAFgBd/+ApEsk3UzSo7Pmi9X8pdqL3f0qSTKzHTO7wMxuGTua2W3N7Pr5+LPctl+ZXX3pwNMHAAAAjoyaGAAAABhsdbTe45jZKUm/K+nBkn5H0ve4+17er4OPzn6ufBU24jAAAMDGW+PlhR8l6TJJzzKz+0h6l6Q7S7qXmmL0SaHvTWbtf6fmS+J93yHpiWZ2qZo8ts9IuqWkb5J0jpqzb1vLlgEAAGC7UBNTEwMAAGy7Na2Jk9XR3A/y2BdcHa3XOGZ2Ws3KD98i6cWSHh63XdCdZz9XvgobJ0GgrpIvO8R2MWfe82zP2hh951UaI5nUImOE+WcDWhwoyQetjJHnosa2/PAkkcTlMWLbNHtx90K//PpeyK89lfWL2ba703HSdsoOrp/KXi+n4fjs+nju5eb6qXA5zead2EFu7zTLRt4NC93shCDj3ewBiHvbrbym77SeF2F/YbtpZQGkqdLx4/2J+87nuJtcTicyKRzHvG0SHydPX/rPhuutfOIwZv78mWj+Y58/D/amB/2mKj/Pas/PafK7kD8Hy21eaUt/f+ffnjdWx6j8bqe/bB37zbveR22MQpstUgj2meNQ64R1HWfgtckW2vdhw7h/wMzuKOlpki6SdD9JV0h6lqSL3f3KDsNcKuk2kr5GzVK/50r6pKQ/VZPf9pJFli0DtlqX35S+v01hu0qk/UKs9P5SGb+171LfWr8B2iwru+L1fI5JW77dJF72cr+9abFtNAk3TNKd29TnX876ZcW5+jALdcUoey8O9dRonNf7B22eriSvUTiYsVy2aTp+eozzY1CuVTo/l+NHo1G60ShcH48OJjLOBt8ZHzzYp8fp54Izo4Pr1xqdTdq+6NQ1B/3s4I9YzhntJv3OhOs7lo4/VvlzwjgcvFhzT7KFN2PNmtfj43gMss8kyfXYtMi6ntOwv2y7pAYfxdvzX5S4kYptXb9QbH1uDc///DNVfB5PSzW8JEt2XX5ydv7SM/98ngxS/uxSH7PjRtXvQPLXn473h5qYmhgAAGDbrWlNPKuHL5F0XzWroz07NO+vjva8uDqamhN+d2crq/UaZzbWGUn/TU0N/luSHnHYCRBm9m/d/c3ZbSbpiWpq8Y9Jem33I7AcnAQBAACwQrOstId36He55pyq5+5vlPTG4WcGAAAAHA9qYgAAAGy5IVZHW3QcSXqumhMgPibpI5L+o1mr3H6Du78hXH+Tmb1X0l/MtjlfzSoTXyXpc5Ie4u6f7n7Xl4OTIAAAwIazJSxztpbLpgEAAAAF1MQAAADYdutbEw+0OlqfcW4++/nFkv5jZeg3hMvPkHQnSfeWdH016wX+vaTnSHqmu688CkPiJAgsorXWZI/tOkZjSNnymLV9d43GyF/YauN32lmtXxqPke4qX04/9GuNMb9ffnUalqjNz9CKL+iTbNnbUVguN19uNkZgxCVY9/Kog7Bk7V4WSbGXRCnsJW2lCIx8adjYdjaLe7jadw7m2Foy9WBeO15buzWuy5w3haVtWzEaB51HinEP5VWC8jGm4UGMERhXZ4/1rsfL6TG+OhyTeDyavqfmtrUjR2pxJOW2+FyYFuJTWm3T/DkSlgyelrerxVpMK5EU8XejHSkTl3bu2i9vi1fKMRrq0y+3yDK3Pdo6R2AMsAz8sWwHACdJ5b2gGHnRd/xKm8W6dIHYA/Nyv2LMQtd+h7bNj8CI8ReSNEqiMrIx9mJhndWUcZxpiNRYJA6ja4SBVWr6UyHWIq+14vD5X2vEOIxQZk8n2eeCkP4wzcvZSlRJWp9U6uo4paxtFCMwQizEThZ5cXp08HniWuM0yuJa47PFthiBce3xQTTGtbPYjNOhXy0OY5TnqQTTShzGJInDSMffrdT0o8IqpHlsRk0SSZdtNgkPfqydT43SOca2USuCcX6kSbNh+Kzk8Tme/R4mH5qtU1s+Rjqn8pOw/UdN879UGCo4Ie6vNma8P2uaUwwAAABgiY66Otqi48z63rPj9OI2P7noNqvASRAAAGCjuYb7EjuOCQAAAJwU1MQAAADYdtTE24WTIAAAwMbjr+kAAACw7aiJAQAAsO2oibdHbTFOAAAAAAAAAAAAAACAE4OVINDYX69lkROgamu8lMbJt6llxYazsTzP+pwf2bnQ+EnOaJIxWtmmNWDHg5B0y/JTQ7aqRtl4yRSzXOBC7HDMapWkScwWzsaImayTrG0UslsndnB5L3ss9kK/XRsnbadCXu41lr7cxBzZUTgmef7u1dOd0C/Nlx2H7cbZsStl556jSXbLwfVJtg7STpjjOHtoxuG4jlpjHqgl9Z4N+9sN4+9mz7Ork4zgcda2M/eyJF01PXPQFo5jvCxJ14Tr12Rtu9OD/e1m+75memru5fickKSzoW2StcXr+XMwaZuWn6vxzM1pNn5yVme+XdKv0NDqmL0GeOn3vLJdrV+u61mpHbPec/lrQq/x+/Rb9hhzx+UMXwDdVWLml7LdIMK+q/Po2rbIGHHfWfFj4U3WKv3im3FrjGloy8uuaaFfbYy99A7YZBouZ3duL7RNw6BZv6QtX1tzWjmYo1jwFy7nY2bjJ9VPtp2HRts7qOVGp9Ix4vRtko5hledFra3YMXuCximPRwcTOZU9iKdC2+nRXtJ2rfHuFy6fM9pN2q49vubg8ujsFy6fO7om6bdjB2Oezp5o8XPIuPXkPTAJB3ya/c3J2VBLj7PHcBw+u4yytqQ+j0Nm04if2abZ8yC5nv0pTPxMOA33LR/jVDgm7fHnf7ZrtYXLrZeR2JaNH3/d4hj554Io/xWKe1z6X361vr9Yozp0neYCAAAArAI18dZgJQgAAAAAAAAAAAAAALARWAkCAABsNm//Ue4QYwIAAAAnBjUxAAAAth018VbhJAik+kRcHDZONZKi2/5aURCl+IpaWkWfaIzD5ljN4ggtYSl/a62/Uo7iiNtlq/wrrAabrIRq+dKkMVKgOMN0WVEpvWcWYi4s63c2xFzkY4zCcqqjShzGOFle9nRllt1NFJd1jUvDpsvj7oa2c/Jlb8O74els2dt8mdou8oVz4xx3w9K5eeTFbhKHkcZVxOsx/iJvu9pPz71dOiwq4+Bx+/wkbzuY19nkcvpYx3iM2C9va0dl2Ny2PPIiRsDkD0vyO9QxysKn5X6th70ao1GIwNik+ItF+x5lGwBYpb6vW10jKvqO0XHM2r5LcRWLzKMaiVBoa40xnd8vb7MsWiKNygjL7k/SyitGYFirbTr3sqQkJyJpy8bI8umKc8x5xzgMi/VhpQ61UbrdKERbeDgG0zzyouvx7/s8trkXmznGCIxwOUZjSNLp0UGtfiaLw4gRGDHyIr8eIzBqcRg72SenGIExrvzixSjCGI3RjB9j5rpHABYjMHqu6zmdpBvGz2U74RjntXOMwMijSmKb53EtMb6iMq/4OTP/zNmOtpjdnte2MVKjGpWRP4alz/V5nJ4XWpR+ZijuubLbwzbs9tUDAAAAAGCGkyAAAMDm48tiAAAAbDtqYgAAAGw7auKtwUkQAABg49X+GhAAAADYBtTEAAAA2HbUxNuj5wKKAAAAAAAAAAAAAAAA64WVINBd13zKZWzXivqcv6H3Xccmydcs54rWh+8W6OnTLH93FNuyEUdx31kma7gc43KnpcDUpmexZXfS7diNegcBD28S7s80u2+7ITd5d3TwUneO7Sb94vWrLc0Wjnm/OzYptnWfrxWvJ/P19KX5bGi72neStnj9c9Mzadt0ftvnpqeTfp+bnC62nZ0ezOXzk51i29lJvDxO+u1Ow33L2vamo9CWPoZ7oW/MJJ5mv0Pxet6WnNWZ/Q7F37fk9zLvFx/qbPw057zWprKuZ552HS9Ter1caJwBcuwHUbovXfazPi9dANB+TQrX+5Za1vl955DrpXnUxk/mnzbGcSwWsNV+WVu4bnm9PPG5/ZTXtnGMrM32YjE9LbftTcr9JrGwyPYdr+f3bRTe22IdP0rrIg9jmKf1VNxuNErn5WF8G4d+e9lnkknolx3jro99OmDhdkmWPbli1/hZ4/Qorb/PjPbmXpakMxbb0nr/3NE1cy/XPhfsVD4XjFoH6MDUDx63s5Y+TuNQfOafJeLjNsrq/fSD38HFSV4Thw+WExtlbeFzR3Zcp+ERmIbnQf65L17Pj8Eo7G+ab5ccu4PL0wX++ir+msRf33yOkzBm/jxbl7/2ir/m+UtF/0FnA3W5i9TEAAAA2HbUxFuDlSAAAAAAAAAAAAAAAMBGYCUIAACw8dblr/8AAACAVaEmBgAAwLajJt4enASBZumX/V/6vuvvLiHyos/4+bLvXouySCIwKvOoviB2vePlfnEZ/mzV0iweo7x0btJtki/wUl6utddiMHvpy8Z03O8NIy4Vm1zOxouRF7vZ0r/XTiIk0ra4nO05vjv3dimNuciXvT0d2kbZcRxbeTnbklYcRrjfuyrHYcRYi7PZ/bzay1EW14Tt0miMtF+MubhmeqrYdnUehxEiMK4Ol2P8hSRdE54zMf5CSiMw9rKojLhE7iT0q8dh5L9EB2153EwpAiOPrKkvAW2VtkK/mkWWLw+qkRddx+/Tb6jtkjGWUIS6lhDNMfB4ANbCGqV+dTP063rlPS+Jq6i0dY36qMVt1OIY2lEZ89ta/WJcxV62gxBtYXlbiMCwShyGJuVIjdb1khiBkcVhWKhxWh9rwvr6nm936uD6KOQITKuRI1Zsq8Z/1VTe3schCiJePpXFNsTreRzGOSECI0ZeSGn9f227Zu42eb/TyuMeDu5oXvvHGn8atttROv+rw9cvtc8PecxfjLmYai/c3j0OYzdEc+Qxf0lURuyXx2bEeLps32lURh5RcXDZKv3S0rlbzEX+5WXtE/hSYii6ssrvUGmTZcR5UBMDAABg21ETbxXiMAAAAAAAAAAAAAAAwEZgJQgAALDhTPXlhvqOCQAAAJwU1MQAAADYdtTE24STIJCqLbG47KiMJURq1JaI965r1FT33ecOdIvGOHTfybrAYWnSfH2XECPgni+pWZlL0i+Mn8VVlPq1tsva9sIStrFtz9M7sBfiH64ZZTERo4N4hnw52zMh2iK25cu/nglt42zZ2xiPcTrbbtRap/lw0+y+laI+zmZxGLEtRlzkbVdnbTHaIkZgnM0iL64JURafzyMvQrRFHoexG+IrYr+zWaxF7DfJnuN7SVu29G/oG+Mw8t+TaSXKIo28UKq03SKxFl2jMmpqYwSDR14s2vco27TGoDAEsDmONUKja/lafT/JYhCGeC+o7i/2K0fVVaMsYtlViXGI6+63x4htaR1ncb3+vbTmSyIwJvFyHodx0OatOIx4vys15PigLjLLa45TxTYP12P8hSSN9mINdXA5K22zWJEF2jrWMck2o+yxCYOcSuIw0p3FCIxaTZ/H350zOhsuV/rFmLzsc8HpjrX/WcXoivRxihEYVy9SUIWHNNbLeeRFPCaTUbrvnRgjaGmtHmMpYgTGdNI98mKkxdvyyItpIfKidX2AOjIfPxoidqKVsHnkEQEAAAAAi+IkCAAAsPn49hkAAADbjpoYAAAA246aeGtwEgQAANh8FLcAAADYdtTEAAAA2HbUxFsjXzgfAAAAAAAAAAAAAADgRGIlCHS3SDZm13DhWre4u6H7SbJwf5I80kXOAkv2nef2JjsLl/OJFPplfVvTivsblec/DXmweQa0h0xi9/ScqBBJnOSi5hmp8fp0nGbzxlzXvWz8vdEotB3s7Ow0zai9ZnLwMnVmvJe0nQ65wGdGO0lbzMRN8oNHk2K/PFt4FLJ/87Zxj9MFJ9mTcBqOyW7M6fX0GExCv2um6ct27Ju3xeP6+cnB8YnHVEqP+dlsjLOTMK/ssdlN2sLjOUn77U1CdnH2/JmEtul0lLWF511oaz0HQ0RzK8N3Gp+7aVPyOzQt3C6lv1O1MWpqT5dqjnph/EWefl37DnEG7AAZyotYKMf+mOcGYEvlpVyf19a+Y/R8rynuq/WeV9vOw+Xydla4LEmWvBfnY/j8fvm+p+HyJBskXs/b9kKdN812EK9PwuW9tC712DZN60aFeSWFSy6M4eO0Lqq9i1n8fLGX1mG+czCm7c0/Vs11Fdvie2jt8a0KG1o2yDh8lhmHiZzKHuxYj58z2k3azrHdbm3h8rmWPoY7sfbP7thOxzJiFIrKyiMtaa/Ykn9miNd37ODxnWSfK2Nb/nliXPlcsxf+NmYU7vcoe5ziZ6ORjYptyj73Wd/P2h3kz6XkuZq1tT4nFMdMtspbQ4sXWrrvq73zyq5L/Q7rm6MmBgAAwLajJt4arAQBAAAAAAAAAAAAAAA2wmArQZjZF0m6++zfl0n6Ykmfl/TPkv5a0qXu/n+H2h8AAEAXrjkrgQwwJjAPNTEAAFhH1MQ4TtTEAABgHVETb5cjnwRhZneR9ChJD5J0RuWVOt3M3iPp1yS90N0/c9R9Yzj7K0UOtgpMaaBF1gQeIgKjI6stMBtX71xk/qWojNaKmh2jMvJplY5Btr5LfEHPVi2Vxc6tqIyDHYzCErUxXkNK4w1i7IEk7Y0PlkXdzaIOxnbw8rMTYjROj9KXpaRtki4be2p0MP7pPOYiXI9L6eZxGKfCcrD5kq87lbZofMhit/sm2YMT40Li5Xz52hhrkcdJxPiKPK4iRpDEWIs88mJ3Uo4jmYTHLX8MY+zFJMRO7GX9YszFZJK3xciLPC5kflveL/kdbbVVfvemhbbqcuLdXisWaStGXtS26/u6dwIiL3otHQ+sAWriDbOM16LKe03f174h4jb67Ku63673rRarUBkjj3dLoi2SMfK4h+ncy3lfm2RtMSojRGB4FoeRRGVM0nrT41zyfYeIuDQ2IO2XJO3lnxli/ZbNP4kFqcSFpJEmlrUVJtJTPv1YZ8fLrbp9VI502AnRFjtZzEUahxGj8KZZv7DvbM47+aSDOEqMzNtt9Zy0bjloCVEf2ZYxGu90mP+uZZ+bKjF/O8l2ab0fj+uux8iL9PiMbX5sRtO3HKNR6jdtxW0cXG8n0IW28FjkyTZxjPxzU/z96h1XAeBQ1MQAAABYF71PgjCzW0t6hqRvUvO5/82S3iLpLyT9o6QrJV1L0g0kXSDprpLuLemXJT3ZzJ4i6XnutVBUAACAI3IN/x+anKyBGWpiAABwIlATY4moiQEAwIlATbxVjrISxN+oWcLsiZJe6u5XVPq+QdJzrfmTla+X9MOSfkXSdSX9pyPMAQAA4HD8xR+Wh5oYAACcDNTEWB5qYgAAcDJQE2+No5wE8URJv+ruV3fdwJt1QC+RdImZ3U7SjY+wfwAAAGDVqIkBAACw7aiJAQAAsFZ6nwTh7s88yo7d/R2S3nGUMTC8RXKFe50stchGtcl0nWfc3RD5tXmUYYztzeebBPcWLjcbzt9GSo9BfuwKY7byTZMxsl1PD/r6qJwLPA2RsjZKx59OD7JhJ6N01cK90Dbay7JnxweDnp0ctJ0dp/m1472DeYyz8ZNc4Epm8KmQgXsqGyPJr61m25ZXZBx3/MXJc2mnId832stun4bt4jFt+o6LbZNwPY65O0kfizivVlt4jkzzfYfr00q/2Bafc1J63/K25LoXbpfqv0OFMVrXu742LZSBXhhzkdeirn2HWHJryWfA9s27H2TfS9g/5wtjHzUx1lLf95pweaHXzR7vV7HWzLX2PS3Xs7GvTUK9Nsk6xuv5vqfT+Zezvp6Mn/WbTEK/tC5N9pePH7cbhRpqnNZkFmpRt3R8i/XzqWzfYX/J8cmPY6z387K3Y/1Te280i5ezzx3heqzV89p8rFD7Z8fgdLi+o7TtHNsLbdNwu2f9LPRL783Iur3zT8Ocx5Xic6L0IE/C/naz52e8b7sK98XS58huuJ5/donXa8c1fv7p+hknV/tM5ZXf++OUP5xrMq2loybGMlETAwCAk4CaeLvM/x84AAAAAAAAAAAAAACAE+YocRgAAAAnw5b8hR8AAABQRE0MAACAbUdNvDUGPQnCzO4k6d9Lur2kmxbGd3fn5IsN0GfJmIVWW++zNHstkmLJWkvfF6I4WrEZ1bvZMSrDav1CUx4jEK9mcRhxnhbbpumyq9OwPPHI0sVl4najbPy9yWhu2zWWvjwkkRRZlMU4bJdHZYwLy+rmy+/G8U9VIi/y7UpGWb9p5Xkco0um4cHIt0kiI7K2GEmRzzDGYaSXrdivte8eMRf5HD2JvFCxTXkcRrxD1ViLASIvFoi5iIqRF7XtlrG8eLLN5sZaHMmSjwsQURNjaXq+BteiJ4aeR+t9Iuw7aWvFWpTjKpKyN78vhfHzfsn1LMoiiYmYZuPHaItYyGSRF0kERt6WxGHUIv/CfcnbYr2fxdPF/VkrpqNwfPJ5dK2FllAH5PVz6fYYf5fHPcR4jNNZVMZO6Hs6XN7J9hcjMHayzzWjjoto7oZ9j7LnYNzfJDuQk0rUx1kdfP4ahzHzuI1RGGOcxW3EvuNazJ/KbTHmIn9sSo9hTb7NpNCvJv+MFj9btFIoe4y/bCuJ5aAmxjGiJgYAAGuJmnhrDFZkmtmDJL1MTcTG5ZL+XAqBlQAAAMCGoyYGAADAtqMmBgAAwKoNeabtUyVdJemb3P1PBxwXAACgP9fwf/63jn9OiHXxVFETAwCAdUNNjOP1VFETAwCAdUNNvFW6renYzVdI+l0KWwAAAGwxamIAAABsO2piAAAArNSQK0H8o6TdAcfDcdo/U2nJUThDZckXI3t6Z/l0nFjerba72Df0s3yOlTG8dsBigGj1bic7LzZ5fkpUGD+ZcjZGnMZ0lLeFDOLW+IVM2TxfNoyZZ6aORtNimxXGz7Nnkzm2sm3VSb5d5JXnZCkSOt8mXp/mbZXtplOb2xZvz9s8a0v2l+87RAYn+26NH6/kwbeFy3nfrv1yHfOtW7+XPcao6vvaN3A+2VCvwUu1rDmehPuOTUFNjJXo+hrf+72gVpYO8Rrb9f12WuyVbePl67W26TRrCm2T6fzbszF8kk0yFE1eKgCV1iOtXqHYtfE4Gz7UxPm8pknBVuxncV7LeM+s1NzRKOx8ZzQpto2zJ8LYDq7vWLra+jiOGUqrnewDxE74wLJj6TEeVf5+ZBrn4mE7K/cbZwc5Xh973naw3SiOYfkxKH/mGVkcI2+b/3h07dfaLpvXKBzXSd65MH7+maf4mW2gWjmOWfv8thGoiXF8qIkBAMB6oibeGkOeBPF7ku5vZqfd/eyA4wIAABwNxS2ODzUxAABYT9TEOD7UxAAAYD1RE2+NIeMwniLpk5L+q5l9+YDjAgAAACcFNTEAAAC2HTUxAAAAVmqwlSDc/XNm9ghJl0r6WzP7pKRPze/qtxxqvxjYss+AGmhlyaGXdPe+E0siLyqTqs23smtLoiy6jdE5QiM3rU2kkO2hPCpDWVvYrhKHkey6EtnRWjo3aVNZXD41b6pEcaT9KuN3lK9OXO5Yjqtoda1uN79ja7xKXEUyRv4cKW3XiqtQWZ8Yiupy3JU51gwRedHa7uhPmrWMr1jHOXWx6UsbY21QE2NwS37dtUK90P/9r1ubVWItFnr/S7PBOm7TPQ4jyS+LWWB5bMZkMr+fsggML99xnx4UzK261ytjJOPncRiFtnwalZK4Y7ncW3yHzqMUohj/0Ip7qERNxFiH+JFknH0yiJEXefzFqPphLPQNc8wjHUaFy81cylEWMR4jOQbZ8yCPCOmqdlxLapEXNWmURadNMDNYZAc1MY4JNTEAAFhb1MRbY7CVIMzs30i6TNL11EQ9fk7N9xn5vyFXnwAAAADWBjUxAAAAth01MQAAAFZtyELz5yTtSPo+See4+79095vP+zfgPgEAAA5lPuw/oIKaGAAArKV1ronN7KZm9nwz+wczu8bMLjezXzKz661iHBwZNTEAAFhL1MTFbe5mZn9kZlea2efM7J1m9uNmNq5s8zAz+3Mz+6yZfcrM3mBm37zIXJdpsDgMSbeT9Lvu/tIBx8SmWaf/OIpRCkPMq+MSOq1uffddmLTV8zX6tVViOXrHb1TSE9J+YdnPyhhVHaMyFtquq2N8bnWOdOi73FPX5a37RFwcpW/PmJE+Vvqf3+v0+olBmdlNJT1N0kWSbiDpCkmvlHSxu3/iuMfBkVETA8EQ752WREFUBqz165xLlo9ZiBhYZLw4RnW72C+rW2L8xrQyRt5Wi8AoaR27cg1VfHwHqKNHleJnkeiHcZhk/OZmlH1WGYfrefzFuBb3kDxHYqRGFmtRiexI+2VxHjF6ouPTLj8+ccxxHjlSGLMWTYIjSCJBWIZ3n5ndUs2qATeU9CpJ75Z0J0mPlXSRmV3o7h8/rnEwCGpiAACABayyJjazb5H0+5KulvRySVdKur+kX5R0oaTvmLOfZ0h6vKQPS/oNSaclPVjSH5jZY9z9VxY9BkMb8iSIz6o5KAAAAOvDNfxJJAONxxe+G4maGAAArJ81rokl/aqaOvbH3P3Z+zea2TMlPU7S0yU98hjHwdFREwMAgPVDTdwax8zOU3MSw0TSPd39bbPbnyzp9ZIeZGYPdveXhW3upuYEiA9I+rr9P8Azs5+X9HZJzzCzV7v75YsehCENGYfxR5LuMeB4AAAAmy4WpQ909ye6+73VnGV7GzVF6XGOg6OjJgYAAOjIzG4h6b6SLpf0nKz5KZKukvRQMzv3OMbBYKiJAQAAOlpxTfwgSV8i6WX7J0BIkrtfLemnZld/JBtr/ySKp8cViGcnPTxH0hlJD6/N9TgMeRLEEyWdZ2bP4QMFAABAHV/4bixqYgAAgO7uPft5iXuaQeTun5H0FknXlnSXYxoHw6AmBgAA6G6VNfH+Nq+dM96bJH1O0t3M7EzHbV6T9VmZIeMwXibpM2rO/vg+M3uvpE/N6efufp8B99vLKvO3Z8uE/JSaJ9k5kt4v6fmSnu3uk8I2D5P0aElfqWZJkr+S9Ax3f3XXuVad5Kz5vjGaK7rPQ+Qiz0YaaqAjsTiP9ZjSQo4zhnW4x34NbfJ92yRb/Dgt6ffvAjN7+7wGd79Dh+2rRamZvUXNyQ13kfS6YxgHw6AmPsk1MU4c82N8c5tW9hXaPO83wBw9jDFI+ZrNqe/75NC19KjnRMZ28PY3smmlZ9hmoA8vYzv425Lp/JeuQ3X965RxKObGHe8nFmPhOejH+WHxmKxpTXyb2c/3Ftrfp6aWvbXqtexQ42AY1MTUxAAArCVq4tY4xW3cfc/MPijptpJuIeldsxNcbyLps+5+RWEfmu1jpYY8CeKe4fK5kr6m0G/l/wWzyvxtM/sWSb8v6WpJL1eTj3d/NctVXyjpO+bs5xlqslU+rCaX5bSkB0v6AzN7jLv/yqLHAAAArBxf+G6me4bL1MTUxAAAoO782c95/0Eeb7/uMY2DYdwzXKYmpiYGAAB1q6yJF93mxNTdg50E4e5DRmssW8zNfvb+jWb2TEmPU5Ob/cjCtr3HMbPz1BSnE0n33M9WMbMnS3q9pAeZ2YPd/WVhm7upKWw/IOnr9s8aNrOfl/R2Sc8ws1fPclYAAECLLWHZF5Okd3c8k7eEL3w3EDUxNTEAAOtpbWviTjvR0f+zfKhx0AE1MTUxAADriZq4xzh9973yunvIlSBOhA652Y9Qk5v9eHe/auBxHiTpSyS9eL+wlSR3v9rMfkrNX2f+iJol4/btF8dPj8umufvlZvYcSU+W9PDZPrfTwL9GaxVZMMRcer6gdz4OA/erzrY2Rtfx+x7Trtsd84qpnR/eWr9KW+fD1XP8ZF99j93Qv7QrXPV2A1fcXR/r9NreHV/4YmmoibEp3A7ePNf2bTTMsW80hlnPe9d3uxNs2vH/3SbZ2+JOz/1NfDWxFJMT9f+LJ8cmRmAk1rMa3D9h9/xC+3lZv2WPgy1CTQwAwBaiJs7HWXSbw/of9gd7x2YbPzVXc7MlvUXStdXksA09zv42r50z3pskfU7S3czsTMdtXpP1AQAAJwdf+GKVqIkBAMA6eM/sZykz+Fazn6Xot6HHwXahJgYAAOtglTVxcRszOyXp5pL2JP2tJM1O6PyIpC8ysxsfYa5L1/skCDO741F2bGbnmNm/OsoYPXXJzZbKT5CjjFPcxt33JH1Qzeoct5AkMztX0k0kfdbdrzjCXGVmb5/3T9IFh20LAMCJ5wP/GwZf+G4AamJqYgAAToz1rIkvnf28r5kl31Oa2XUkXSjp85LeekzjoAdqYmpiAABODGrifJzXz35eNGe8u6s5kfMyd7+m4zbfmPVZmaOsBPHnZvbfzezOi2xkZueb2WPVnDHyHUfYf1+rzN9edBsyvgEA2Fx84bsZqIkXH4eaGAAASJLc/QOSLpF0M0mPzpovlnSumriAqyTJzHbM7AIzu+VRxsHgqIkXH4eaGAAASFp5TfwKSR+T9OB4YquZnSPpZ2ZXfy0b67mzn08ys+uFbfb3e42kF1Tv9DE4dYRtf1DST0u6zMzepyaf7C2S3hYzycxsrObM1rtI+gZJ95d0jqTf0xocgDlWmb/dd9+H9nf3O8zdYXOW79cuuL+F2Hrm65QNNd8eWaILHatS38oY1Rnl2xXGac3RC5cP3c7mt1XGr+47V9uu6xhB3+fx4JGy2XjV8W3+5dY2hX6tvpWD4JUxqvuO3Wrzivtqb3noNoe2xfH7PmYDvNi1hjgBkcQnJTZ5Hd+L3P0DZnaJmuzYR0t6dmjeL0qfF4tbSbeUtDsraHuNg8FREw8/zkbWxOjPQ5FgrYIhFn02//JQRpXxQ5tlb44+WeI8FmmLsvl3rimXbNqxsJhkf88x8fLfd0zCmJMlFwRTTedePny7A5PsgE/DfcvblmlaOaY4ghUXz+tYE888StJlkp5lZveR9C5Jd5Z0LzV/Jf+k0Pcms/a/U/Plbt9xMCxq4uHHoSYGAGAJqInTmtjdP21mP6TmZIg3mNnLJF0p6QFq6rZXSHp5ts1lZvZMST8h6Z1m9gpJpyV9l6TrS3qMu1/e90AMpfdJEO7+fDN7uaTHSvphSf9RsyLLzHYlfUJNEbufQ22SJpL+QNLPu/ufHWHeR7HK/O1Ftzms/2FnAAMAgGGXJjsYcxh84XvCURNTEwMAcCKscU08O6n3jpKepmZJ3ftJukLSsyRd7O5XHuc4WBw1MTUxAAAnAjXx3HHc/ZVmdg813yF/u5q67f1qTnJ4lru37qW7P97M3inpRyU9Qs35/X+pprZ79UJ3fkmOshKEZn9R+LNm9p8lfb2k/0fSv5H0ZZJuoGbp5fdLeqekN0h6pbt/5Cj7HMAq87ffI+mOs23eHjub2SlJN5e0p2YJOLn7VWb2EUk3MbMbz8l7I+MbAIATjC98NwM18cLjUBMDAICEu39I0sM79LtclTVquo6D4VETLzwONTEAAEissiZ297eo+U55kW1eJOlFi2xznI50EsQ+d59K+uPZv3WX5GbP5i7paPnbHcd5vaSHqPnPid/Nxru7pGtLepO7X5Nt89DZNvmycN8Y+hzJGi//Mt/gZ2odfUnKzsewZzRDa4Yd4zCqUROdtwvL++arunaMq+i83QLzT8bsul1tjMwgj2kyYGWIWpxEqZ+kuBJwLeYiactWto1t1VVv82WTY9+OcRut8cNBrsZ0lKfROYojf5xKD1t19exaW+V1pP9LzMAvdktYfXeV7x8LHdc1fp/jC9/NQU188mvibRRfSwdJkKi8T1ulJrAQGZG/vg/y9lWLyojXR/nERvMvZ/1iTIdbPkZ8E8qKz7xv6fbxeH4/qXNMR1IDtmqyeHkZNc3iptkjHyMv8tiMabhDrTiJcD0e/Wn2hyyTUCyM8gLHyx8apmG7SRhzovL4eUJKn5iLaR4JkhyDvC1EgmS/fLUokeK+s226xpj4SclRW0ODHbs1romxOaiJqYkBAFhr1MRbY+tCHmcZ2peoWUb60Vnzfm72i2P+tpldYGa3PMo4M6+Q9DFJD579taZm+zhH0s/Mrv5aNtZzZz+fZGbXC9vs7/carWdmHgAAANYUNTEAAAC2HTUxAADA5hpkJYgTaCX52+7+aTP7ITVF7hvM7GWSrpT0AEm3md3+8myby8zsmWpyV95pZq+QdFrSd0m6vqTHzP4yFAAAFJy4FY+A40FNDADAFqEmBuaiJgYAYItQE2+PrTwJYpX52+7+SjO7h5rC99slnaMmD+8nJD3L3Vu/fu7+eDN7p6QflfQINat4/qWkn3f3Vy9051dt2S8uPZeI7P2i1yPaojrDSpxEa5yucQ+FWItWW74yb2HMReIwkr75+OF6dR7T+Zfb80p33nn8nlEcgyhFSCwQ9xBXom1HTcQ2K/YrxVocOn6hrXMsh5Qs0dw56qP1RCtcPmTfVrxS1n6F7jZG38Vrvc+WtRe0IZ7Ha7SKMQUrcDTUxCdEJdopSmInOvar9u0YU9Xad7lbXdc4qq4xDrXIi0XakjiJEBHXigmLhUtWlypEWdQ+r4QIDBtndzSOn0VjWGzrGPXhrX7dpjiEfFn/pFQPReWkFXkRIh3yuIe4XTUK4uD23ezJP4ohFdnvxbgSERIjMKbhw0Yet7Ebru9m48f7upvHVRSiLNqxFiH2Iz92HSMvarEWXSMvuu6rNn7rY/GSn5TEdADbjZoYAABgM23lSRDSavO33f0tagrhRbZ5kaQXLbINAACY4cttYC5qYgAAtgg1MTAXNTEAAFuEmnhrbO1JEAAAYIuwagQAAAC2HTUxAAAAth018dbot04hAAAAAAAAAAAAAADAmmElCHR33GdHDbAkTee8+AH6VWdbGz+0tebrhct533CsamPYtGdbrd+03Bav26TSNvW5ty82Rt5WGLNyHNvHwOf2mzdOUcf87JjX3Hrqx4zm7NS1eN1HVmnzube3+o3zNpvbr7ZdKwa44/zzqOVSW34/k7bWsYsPcHle1RzsWs55JafdS1cWeGnr2jWZc9/Xzq4vmEO8FxzzimPmC7wfLDAmAJwUbrFWHOAFbJHX8aTG8Xk3V7eZbRnGyOuAQg2VjxGPQaUt385GBwWJj0LBM87f+MN9UyYUmV55n07mNU6LMhuHwmiUFWyhr4/TYsvj/Au1T9NWLnhq2xW1aufyhtPQNg07mGaF4yRcz9t2QzG6mxW0u6HvbrifZ7PfhVHywaY8x9wk3NlpGHM3Owjxo0z+sWM3/H3KJNv5rp8K/cbFftNkjOzYaf4xbuZsod+o2K+v0rGrHdOa2u9Q0q/X6JuNmhgAAADbjpp4uxz7ShBmxokXAAAA2GrUxAAAANh21MQAAABYlsFOgjCzXzezcw7pc3NJfzrUPgEAADrxgf8BBdTEAABgbVET45hQEwMAgLVFTbw1hjzb9gcl3cXMvtPd3503mtmDJP2GpPMG3CeGcly/qANEXEg9l5fpGElR3e8i4xfGHCLyotU2LdyejblIHEYpaqLVb1Jrq8RcFLarRV6MJumdS8fI2orz7z5GNaok6VfLSSk/a0pLC+dxD0lbJa5imi3LnERZVOIqpuNK5EUYs73v2K82RnnfaWSHssZwOR6S/Hk8KvSTpHgsK1EZ8bFoPWS1qIxKzEXpoR9iFfLWvromWdRexLq+Pg+xvlffIY7wFsKyZDhG1MRYntr70CpV3iu7RzvFN+Ospqm8Tydt8X0/rytCraJpFhkRrtu0XMjEKBHPChcL11sPS9c4kthvXI68sCzyQklURt4W68EY7ZHFqMV6rRYhluvx3pzHGcTr08JlqR55cTZcv9p3su3OhssHxf+u0g8eYxU+YKkeDZHEYSRzSh/ra8LVq2uRHZX7VosEqbXF65N8uxiBEaMxsuOfRpWUIzVqx2qoiI19XaMx2tsNOo3eVjEPamIcI2piAACwlqiJt8eQcRhPl/SVkt5mZg/fv9HMTpvZr0p6uZoYzG8dcJ8AAADAOqEmBgAAwLajJgYAAMBKDXYShLs/WdI3SPqMpN80s5eY2R0l/bmkR0q6TNLt3f1/DLVPAACATljmDMeEmhgAAKwtamIcE2piAACwtqiJt8aQK0HI3V8n6XaS/qek75H0vyTdVtLPSLqHu394yP0BAAAA64aaGAAAANuOmhgAAACrdGoJY35W0kd1kA76KUlvcvc8xR2bpGcWZ9Q7h6frdh37Ve9JPkYt0je2lS63+lmlLdtuOr/N8t+02FYZwyblthhuO8r6pW3pDuKY+fijpM3n3r5IW2v+yXY+93ZJsmm4nh+fSeUBDgGutedu9VcjhlqHU9JaGc2jmOWc5e+G63k89PTU/O2mWcT0KFzP22rbJdnR4Th6HqU9LY9hyf3Otiu15afvec+2JHs83t49hzzJQM+akhtqYxQ2mX9DD+WI9fI8as/bRV7vhw5YO8pwnJWL40dNjKXz0mt8/lJda7P5l1sv94V+ratZW+l91LM3RIt3IB8j1CP5b5CFcWLNZKPsjT8ZP9tB7JtvN461Yix+ym8slhfkcdLTyhtSrAHHWdF06tT8y3nfU+l2nty3ck2ZPPatmqlweSDT8CTZmx7sfDebSNqW3s9dPzX3siRd7TtfuLzjBx8aRq3i4OBxmmRt40ohET+GxEc+/yhx1sv3Ld6ffP5Tjea2nW0dg4Prk+yBmnj52MXjPw39ptkcJ7FfNv60Uh+W2tzLY+Tb1Mbv2i/f39aiJsbxoyYGAADrhZp4awy6EoSZ3U7SX0r6bkl/rGZ5s9OSXmtmTzezQfcHAABwKG/+72vIfxTLqKEmBgAAa4eaGMeMmhgAAKwdauKtMlixaWaPlvRnkm4h6T+4+ze6+69LuoOkd0p6oqQ3m9mXDbVPAAAAYJ1QEwMAAGDbURMDAABg1YaMw3i2pL+X9N3u/mf7N7r7+8zsLpJ+QdKjJf2VpBsMuF8s08BLRq5L5IVUWcl1iMiLynbtSIrKevqVKIu41morAkPz2/J+SVxFx7Y8ImJUibyI1/OojNHe/DHzyIvRbiXKIm63V26zvYM7YNkSxPF6K/4iLnOcL3kcj0llOeRkuNbSy3Ei85dyliQ/NSq2japtMYbC5t4uSdPwTmDZu0JcLdeyVZmTuI1wPDzvF47PKHtNSVbZzbYrxcjkvwvJGJW22nbJQ9N6nELUh8pav6OlX+1Kv85RGdWJ1DY8pO/+zZVtFnpb6Np56NgMYLWoiTfBIq+lFUkURK1fZded9x03rLzXLOMvFGKNY618sdgv3JxHXsT35by2TSKs0vFjrEOsq1txD7HmnqZtFnbu01HWFvYXagLLIyliLVeLw6jVjfF+ZnEYyf7yyItw3fM4j0KtWItfa8WRxIiyRaLB4hiVsjrGFHgSjVGOe8gjHWLkxdXTnbTNYhzGwYeQWsTFVOljWPvrkSQCIxyQSXawdsMoZ7MRz4ZCOI+5iPetFpsxUSXyIsyrFjVR7zfq1eaVmIs+aokyQ8sjNJLnbuV+9t/hwP2A1aImBgAAwEoNuezYqyR9TSxs97n7WXd/jKRvG3B/AAAAwLqhJgYAAMC2oyYGAADASg22EoS7f2uHPq80s7cPtU8AAIBO+Is5HBNqYgAAsLaoiXFMqIkBAMDaoibeGkOuBNGJu3/ouPcJAAAArBNqYgAAAGw7amIAAAAsy2ArQeAEc1sw5P1wveLdF9mmY9/qvSqNkccYV8NtO24Xjm9rvNoY025tccxWhvK03GaTbm2jic+9vdVvL22rbTfa80MvS5JV2kZ707n9mv3FtvmXJUnT0DZpBRQfXJ7k2c6VYONkIuGxz8OvY/ZyyG9uZVjHtlPpuWteyHmWJN85aLNxyOnNc7An87O0JWka3iXytpiRHcfMc3pHyaFKG6fj8u9GFgN9MEZ2PZlVfmrftNQxG7NySmByv1s52Aezqb2Mds2Br8mfPsUxagN2zbiv3ZfK+L3fSqoHb5hTcwcaBgDqur7OLiC+RC7jtSx5CY77ar3nFS5n11sv6cmYFvpltVsyRjZIfL/N6iQLhUdSC2UTsaTWyuYY6+VTaWOcZTLiNJ9jrPmywjcUGnktlA4Rxhxnkwzz8lOVtp20bRprxVPh+Ge1T7zeqikrj33n9/7Q0bONYu24Fyayl01yLzxwV093krbd2OZpW7y+49kHlmAS7tyu0tp/3PGXOY4xze7n2VCotuYY7k/edjbct3h5N3six+u701Pltsp2kzDnqfLHqXzfSv1qbXm/5GNx3lYYs3T7YW21vrWPdp3HO/oQS0NNDAAAgG1HTbw9OAkCAABsPopbAAAAbDtqYgAAAGw7auKtcexxGAAAAAAAAAAAAAAAAMvAShDobemRFx2367zIZcdYi87xF4dtV4rA6Bl5UYvbSPrlsRZxed88yqLSVoqyyCMvSrEZed9WlMVuGD9GXuRj7Ia4it30zo0qMRfJ9dhvkt3RvUloK0dltNZFjev2dl0zNV/aOURUxMiL5PasrbVE86lKVEbMkzgVjvc07Tc9FZeOTtvicyRbdbgS5ZIvXxvGaEVlxOWts7a4nHAcPX8ointWcqpfK0Yjj44pDBIPSXuV8/B7nu2h+Kwor/Dd/SUyH6PStRqVUdpwkUiN2LTOURmc4Qugg/2XnIVeXpYcV5Ho+IKfv3Qm7zVZPWKlOqYWe1B7H+oYlZGXRUkEwziLyojzzxPKku1KE05jNCw/QDGuIm1J7k4SjTHJD0LtzoU6TBVJHEYegRbu3M6prC30zevBcL9jDFkr8mIU21Ruq92Bju/1rbI61KaTcPnsJL2f14Tr14yzthgnYVnURLg+ipVj5U9CJko/M9TiMCaFO96OnTiY89msLUZgxH759av9dKVfJfIifC7IYyim4QGPlyd5v0rUR9e2IVQjMAYYYyl67G9pc6QmBgAAwLajJt4arAQBAAAAAAAAAAAAAAA2AitBAACAzeZL+OtszhgGAADASUJNDAAAgG1HTbxVOAkCVYO8GHRek7L7kMWFIReJsojjVeIqamOk2+VLC8/frrUEf23flbiNUgRGPn6Mq6i15TEUyXaFy/l2eVRGjMCI8RdSFoERYi7asRkxDiPdeYzHyGMukr4x8mIvuwMx8iJvC2N6NQ6jlKuQsSxqIi5zHJY/tlPZS3Po55N0aVvbKy+NnKz2G+bbXvU6ziu9L/9/e/ceLs9V1/n+8+39ywVQgiIOES/BC2R09DCARw0KmSAKDJfhITzmiA4BRXGUI+LxDAoIOjojihBuinJLFDRxgk88IjjjIQbQIBoU0YOABDLKNWgwQEKS3979PX907exVq3qtvaq6qi9V79fz9LN391r1rVWru6u/vX/1W9950NZcOsiW/hq/WMMlcOPVoevb1ZtSS2Y3lqnOtYV34qWdw35h5ZOoX7atFi86BwR7KD29NcptpNbgbhEkGyIVs7i+xjF9w25DlsooCUAyCmDksmU5ch8Gqc/ijiVBGh/2wWBqn9mz+IN/eb9F/OCB+PO8VgIj2O1ePYiHH+Jxfa6ghESz9JWWtsVlRTQP8p1ZPMhMGbVEGQ2Py6MF5TB8LyqPdkpQ6iAuh5EoneZx2hiEjPOd2oHn2nIy35vC8gn7QTmM/WggJ4P7cbmHW4JyGKfN6uUwbpqfVjTEgyBXPzX60jNL1lGrq5WTiCanazmM8NjyJS9OpNty2/nyOd+f1/uFz9M8em7C5y0u4xBu57UY6X7NNi0V9wvF4yitYDi0QcZxe05c0neA/QMAAAC7hJx4MiiHAQAAAAAAAAAAAAAARoGVIAAAwKiZ+l/mrOviFQAAAMAmkBMDAABg6siJp4WVIAAAAAAAAAAAAAAAwCiwEgRqOl8BNfB22SupcjEybbVjLYzRmJ+gzmizreD3OH5UajY7xsR2jRjZNs+0Hf0+Owgfrw8kLJdrB3GbJ9tmwf3ZfvD7yfpA7ORB8Huubb9+AAeJtv2DZD8/iCZhfrC036LtaMxeWNjVotrRtXrOYd3neXScJ45O1RbvK1Ugt4VZ5p5mR/Hn0RsxKJsclbOud5zVXqxRfd9awCi+pberd0w3pep4VwNb2i973oheImE55GYN8eD8EARthM/UX6/XHs+MsbAtV+c825A7CedegoWXwYZPdaa082qo9QZgFbnzbOF22c+kTPjsKT41ltwJP9NWOwc3PpczMQrbSuP7LGrcC3LK6Jg9DDrz5Y9L9RTnRJTv7M+TbbX5Dz/3Z1GMIH/zOD8L87c4l6snUUe/79XjezCuWg4pyffCtjjftOD3YLhxv9ny3xttuee+0DwKEt4/CH7fn9cHctv8xNLfJenm+am3/35KlLfvBS/yvTCZi1P/4Dk9qfp3i73CfP9A4bHUxz8PXoS3ef05vGV+ytG+vX5st/hR261Bv3AbSbo12O5kFD+8vx+17c+P7p8Mfp9HT274fMRt4XOYbQt+b3y9DdsyCWHXtpz6W9SWPr54oGyM5TtePcRO7BMAAADYJuTEk8FFEAAAYPxIbgEAADB15MQAAACYOnLiyaAcBgAAAAAAAAAAAAAAGAVWgoCkjmUwBt6mUwmM0vIXLWLUS1JYpi0dp7aEfi5+ZizZMheFJTUapSzCvvF2iRIYs6gqRK2sRVzyIihz0SiVEbYFSxBbVJIivG/R0ra1+3FbogSG70dlM8L7UYxaeYxGOYxgyePM8rhhaQiPl00OS3bUSmPU58BrZUuiJ+po5d8l5R7C5aG1/PeoX1x1wjJttZWqM8tbz4MNG6/BcH7i12AtZmYd79wS3JnVp1NLg+dKXjTkzjm1bstLYzRCZMafLI0RB2nRljrPNg6rdA33HrbLnRM7rzrsK5R7ysQEgFh8nur93BMrPJGH42p8TFjiM6q0rEXct9G2vFxFo6xFmFjEH9pBW+NzOewbln6I5772zTfz4Z4rNXaQSxiCtkY+XvZC8Fo5jKhcRa0cRlQq45S94PeoBMMJW/p7o2xGZo5r96PnN1niJFsqMNp3WA4jKLkQlmaQpNsOju5/7qBeCuLU2VFOf7OdWmsLS2DMgt8PrH6gB8Hr4hSr73uv8IM/LIcx93T8uFzFbUEpi1ujMhdh33rZjKjkRTBfcSmRVMmLRZygzEWmHEl4PHGbJ0pe5NpyZVFiqdIT2a/SmdI5vZSyyI1liPpufXyekBMDAABg6siJJ4WVIAAAAAAAAAAAAAAAwCiwEgQAABg/rsgFAADA1JETAwAAYOrIiSeDlSAAAAAAAAAAAAAAAMAosBIEyrW5Oqqwb3GlzGyxz0z8Wu3ZshiNekBBPc9mWzp+qq5QLkbclh1/eH+e6Re0xaWLLdfmhf3CtoPMvg/qA5sdHDVaUHs57mf786W/S5L2D4K2g2Sb7+8Hj+/X+508uu8H9Ri17eL60D4Pfs28uML61lHdYSVqX+feF/GebBbEtGjLcH7CtrhfEMNm6ecpHv9BMP7wuY8PM/v6yZTWTtUXb5TYTb0X4hiF769cPffG/Gfa0sOwqM2DtuyGSx+WojE3BlnYlnnYk3fK4jW261gmuVE/vk0crvAF0ELus2AXNMZfa1S6MfN5qEwqkfrMzrV57nL8zHz7XvzA8g+DOCWYhSlg41twmE/Vd+7BwdosiDqP9hvmsI0xlr2Awn1prx7fTxyN0ffqkzc/5ej+vLHd0X0P2uL5D+e18dwE95uvi8I3R7BhPB3zYC4Par/XB3Lb/OiJu/Wg/iR+bnbK7b+fEn0p2bNTb/99FiSc8yhpPRlMQhzjFIu+QyTMM//P5DY/GvM8msiTQdstXj+2k8Fxh2O8dV7vd2ui3+L+0bj2oyd4nmiLx5hrmwdv7kZb+NwHj3smkWt89fJ0/FS/bVJ4CljP+Hfs8wwAAADoHTnxZHARBAAAGL1d+wdMAAAAoG/kxAAAAJg6cuLpoBwGAAAAAAAAAAAAAAA7yMzOMbM3mtkNZnazmb3bzJ5mZvF6lb3GMrMHmNkvmtlfmNknzexWM/uQmb3SzL46Ef9iM/PM7ewucxBjJQjUdb0Cqu/yF8fFLC01URi/vix+i1Fmy2gU/J6Jd1x8S7Q1+2XW689tN09sF6/lmSsJEpa5iNckni/vp3nUMdzfQb3NwvtRm8LSFqnfVS+B4XGpjLAtUw6jNsZofWgPdxdNsoVrJQcTFJflsFrZjMxxzurXtYVLNnu4fHPUL5xzm8fjTy/tXH/ewsfjfuHvUSmImSfbaiv11l6r8RrK4frcitqUbPPEazdbCiLTmN0uGyJYZjvaKrnv+L0WNuUG0qatbNfpeLmYXUtqxF0HKNMEAMcqPeFntis9XcZ9i0/juXISmVIZtdIPuQ+b+DM1Vw5jlujYSD7DbdJH2lgu/kQQZz89yWHlgLiEWy0zinPWWi4XlKSIhz+LNwyUPh/BcXs0B+H9sDSGJM2DkhdhaYxGW5DLzaO8Lsy7Gvsufe5zMt8ZwnIY86AExsmoHMbJg6NB37ZXP4CwVMbnDk6ttc0SCcN8dlvt/imWLocxs6NyG3uNF8mRg8z/MwnLTjTLVeyVtc3T5TBypTL258tjSPUyF/vzsDRGvV+trEWu5EWmLfV7vF2uLERpSY24zTMlWZJtmRid9ZGTrjIOcmIAAABM3QhzYjN7tKTXS7pF0mWSbpD0SEkvlPQASY8bMNbrJd1N0tWSXidpX9K3SPo+SReY2UPc/e2J3b1I0r8sefyfSsebw0UQAAAAO8rMzpH0LEnfLOl0SR+Q9GpJL3H3g9y2QYyzJH0o0+Uyd79gxaECAAAAgyAnBgAAwFSZ2Z0lvUKL/8ZxrrtfUz3+bElXSjrfzC5w90sHivVCSb/p7h+NYv2UpJ+X9OuSvj6xy4vc/brig22JiyAAAMC4+QC13rbgiuE+r/Ct/LWkK5Y8/rfdRwkAAICtQE5cipwYAABgrMaZE5+vxUoMv3F40YIkufstZvYsSW+W9EOSjr0Iokssd39eItbztLhQ+d+Y2V3d/Z/bHdbquAgCAACM3+aT0V71eYVv4F3u/tzeBwsAAIDtQE5cgpwYAABgzEaWE0s6r/r5h0va3irpZknnmNlp7n7rGmO5FqUxpHqx0dDDqpz+QIvV3K50908fE7cYF0FgocubvnCb4mqVuXiZtuxVW5nas6Wsa4ygb26MluuX23eqLdOvUXq5dLug7G0zhgf9PGpb3q/Rt/Z7FP8gaGsWb022eaptnokRtXl436OBxWM57vHFDqK+y+vexnNVG1fmOJvbzZf+3ugXzLHvtXgOk7Vz6+H7fn02prjnfedK7MZjzJ4SeigZXBtXYezGGGvF3uPOibZc/Oh+dg4KY2YD9jCPI9XnFb4ADh2ec3r6Qhyeg3v/nwY50bkzezpONeY+T6IgFtz3WRQ/TH9qbeWfKLWcY5b5oNjLHGlt/PW2eTBIi9os3F8mZ9Us/YHlufww2F9tjvfq8TyIP4/a5qccTayfiNqC+763/PfF/eBO9ByGz2kuT6pvlGmKgoT3D8Lf5/WB3DbfC36v/ynjcwdHT8gs2vks+DIzr+2rHv/02cnbfz/F6n+fCWPsRfEPCpOVebC/k7UJr48lbgvv7wdzcuv8lKjfLOhXj3FrMF/70XGHMee1GPV+4fMRx6i1RdvV0vHE95/Fvpf3W7Qtn+Pma2lpt0E0dlX85ui6AySQEwMAAGAbnG1m71zW4O73G3jf965+vn/JvvfN7EOSvk7SV0r6uzXGepykz5f0Z+7+L4k+vxLd/4yZ/aS7v+yY2EW4CAIAAIzf+P6Q3OdVuYe+xMx+UNJdJf2zpLe7+7tXHyoAAAC2AjlxCXJiAACAMRtfTnxG9fPGRPvh43dZVywzu6ekl2ixEsSPL+nyVklvlPRnkq6X9CWSHiPpOZJeamYn3f3XC8abxUUQAAAA3YzlCt9DD6lutzOzqyQ9wd3/oftQAQAAMGLkxAAAAJi6966S+5rZdZK+osUmr3P37ykNX/3s4/KPY2OZ2RdLepMWK7b9sLtfHfdx91dHD31Q0i+b2fsk/b6knzezV7l7qoxGES6CQLkWb4+NlcBoM8baupy2/PE4ZptyEqXjKoyfG1duHMUlL0r3nZufWG1N03S3XMmFvmWXI95Snik5EnUsDZhsypZ7iDerPb/BeyguaVL4Oistc5EbY5u2ZImNeIzppnpbvOp22cs/ip8JolrHsoDxOHIrj5ceaKap99IYq2wXGWFVjT6v8L1Z0n+RdIUWCackfYOk50r6d5LebGb3cfebugwUGIOhy1rU4uf6Rfc7VDXKlrmof65FZSFqH8ZRjGD1+zgPqJehyAwy01Zfeb/wwyx+og7SbW5HO2iUdwu+bltQkiLuFy/LX4sRJBrxvNY7BvGi8hph+Yq4HEZYAmN+Sma74Nt/VC2hdr9R0iS8n3nestUAwumaR2MM7s+DUgonD+oDOXXv6P5tB/UDOGF7we/1P3PMgtJvYbmHuMRCeH8WvUbi8hhdzIPJiktxhCUv4nHVy2HsBY/H5UKOjvtk9ATvZ8pchDH3c/MTjD83d82vDMu3a1YpTMdPldSI5cpt1KslZspoZGKUKv9a1k+Geri/kt2SE2eREwMAAEzAlubE10q6pUX/jwa/H+a8ZyzrKOnOUb+clWJVF0BcqcXFyj/q7nG5iyx3f4OZfUTSPSR9raS/abN9jIsgAADA+A1z/dMorvB19+sl/XT08FvN7Dsk/Ymkb5L0/ZJeVDpQAAAAbCFy4iRyYgAAgInYwv8n6+4PXmHz90m6v6R7Saqt0GZmJyTdU4uyFB9sbtpfLDM7U9KbJZ2txQoQrS6ACHxSi4sg7tRx+9txEQQAAMBmbMsVvktVSwi/Uos/+D5Q/MEXAAAA/SMnBgAAALq7UtLjJT1U0m9HbQ+UdEdJb3X3W4eKZWZfWm371ZKe4u6/3vYgqjhnaHERhUu6rkuMEBdBIK/wiqheyl90VVhqYoili3PjSO0vVw6gn/i5egaZGKXPdTyOcMnjLbyCLmaWXlpV0bLDFi6FOo/XBQ4OPLfeabg/i2OUqY15tubFmoYuH1L4+syWqwiXmFb8HCZixHFy5TZKp7xFiYpiYZmRYAfFy01H+84eW24d9cI11nObZRu6znHhdqb+PwP6eCdu0RW+OZ+sfq585S2wU4pPaFHfXNWqXMmLNeZQjfJNiWHEVRs884FiyTtLSiskFRdYKtwu/STGpSZqlQ4a419eAsPiicyVLMt9agTxayHjnDWYR4/KYczDchhxmYtaCYxgX1G/8Djj56w+LnVTKzEQjTEsg5AojSFJJ8NSGdGBhqUgwvIXsdq+ooMJy07E5S9uDUpsxKUySqXKQkjSgcJyFfVjC8d5MlG64ri2sARGHD9VKiMu2VFri56b7LEFffPlKtqXuVh3pcN6qcAWb4aO3/nrbatnn+TEKyEnBgAAGIFtzYlXdLmk50m6wMxe4u7XSJKZnS7p56o+vxpuUF1scKakG939YyvG+nJJfyzpLEnf5+6vyQ3WzO4u6fPc/QPR458n6WJJp0v6I3f/+PGHnsdFEAAAALunzyt8c765+rnqH44BAACAvpETAwAAYNLc/dNm9mQtLmC4yswulXSDpEdJunf1+GXRZo+R9BpJl0i6cMVYb9HiAoh3SvoKM3vukmFe7O7XVb+fLemPzeztkv5O0vValL94iKS7a5Fzf3+bOUjhIggAADBurv7/l/XmV77p7QpfM/smSX/l7rdF/c+T9GPV3dcOchQAAABYD3JiVW3kxAAAAFM1zpxY7n6FmT1I0jMlPVaL1RQ+IOnpkl7sXr6OXodYZ1U/71fdlrlKR+UtrpX065K+UYuLK+4i6WYtVnl7abWPz5SON4eLIAAAAHZMn1f4avGH468zs6skfbh67BsknVf9/mx3v3qAwwAAAAA6IycGAAAAFtz9TyU9vLDvxVqUnugjVquKIO7+j5J+sM02XXERBOqGuGKph/qXxTV62ow/eF/W4scxgvuNcWRrdrZ8/Jh9Zw0yPy36rihX/zi83ziThn2j7Sy472FbVANae0c1cW0+j8Z1VL/WZlFbWAe38BRv8b7D+JljqY05c5y5ucvNVVabviUaFwmG78N6m5dObOH7t7Oy8uLZ10F47mhTMbw4fSgcRy/ST2E/MdvE29Jz2rr0eIXvb2rxx+BvlPQwSadI+oSk35H0Und/W99jB3ZZfG7uu5ZkI36ub6Jfm1N1LUbp+Thq80xbbVzhnZkych+4UUstxQnyiuiJqbXV07r6gR9kDi4Yc+MM2+47f7Dv5b97lIP5Xvh7vW0etM1PxG1BTlyLEY0jPLbouQnvNw6zy2HHQYL78/nR7wdRv/2Do0GfjHLzWfAczjJvynm4r2jwJ+wo/v7soB5fYfz4BVRmHk9s4GTQFvfbD+6Hc7I/30v225/XY4Qx9+P48zB+Okb4d6159NyE44r//lXfbvnjcczG26sWPx0j1e+4NmXGX6o06+oavzfkxDnkxAAAAFMwwpwYy3ERBAAAGL2+/5FyW/Rxha+7v0rSq3odGAAAALYOOTE5MQAAwNSNNSdGU/b/3wAAAAAAAAAAAAAAAOwKVoLAQocrn3pZxLFrCYzC8a7ziq7O++p7uzVfxRauptqonFAr4xCVOgibwn65S7PiZYGD7RqlJoIyFzqYL39ckgVrsnrcFu4rWrY0XmK5yCyOEdwPy3JE4wjLZtR+XwQJYmTaUuVBovubXp11UNFTliqDk6nY0Xife2FbL8ISPkq/n5rbBb9nlnCvxeip5EUuZNIQ5TZaDQDAZJmOzjm5c1GrukbLu2VLXrQ5X4XlEwqH0TitJhqzUxCX5wp6N1b8D9KwMI3xuKJAYXmMxtzNUxOWmeQ4Lw0/Yxuflb68X64iQovPstp85cphhHOXKYcRl7lIlcCY52Lknou4VEanchjR3WAuw3IY86gcw0FQuu5k1DYLSmXM4h0k/urRLIdxFD8uGVEvh5F+k4alMnLlL+JyEuFYGmVAgicn7NcseRG0RS+EsG+zlMXyEhjx95962Yx0GYqDxriW94vHUUvNC19YzXIY7WNk4zce6FCur2u/zL6Kizu03ScAAAAwBeTEk8FKEAAAAAAAAAAAAAAAYBRYCQIAAIwetd4AAAAwdeTEAAAAmDpy4ungIggAADBurv6XOSNZBgAAwC4hJwYAAMDUkRNPChdBoFiriprrfNMX19uMahfXio523FfhdqVXlsX9Oo2xL4knPFvDOqNROzq4H7ZZXIg5rFcc1ZdVUBdYs6gtqMdre0Ft23hge0ePNOpnBzHt4CDaLjGOWDyuWoyjILXj3ouKOZ84OlWHx9LoG+3Lw77h7/GQwvuzqK5urX52vJ0tbcvWkY6f39q+yl5N8ftka3OMxMAKy8U3+haXNW5Tx75LzFaF5suG0XnfALAFwvNzL/+bIDrXZU+DPe+v+HQffdb7PMjlokHV8oIgZWrGCO7kconGMSeegPgAgviNvDTYzGf1Hdh8+YdP47kufS4yn2XhXMWf+x7kXb4Xtx39Pj9R33AefOOfh9tl88HycSU1DiCc5LgpOLYg3z84qHfcD3LdvYP6JMyCJ8QsmqD9o1/nwXeLE1EOf2J2lO/vRwntLBj0LHryZxbGifYdmAcx55mJnEcvkv358u3m0Rj3M/EPwhiZ+AeJfUnSQfg8RW31cdWa6s9v+LvK+i3uL+/XRhgjfn3mxlUU79i+JLEAAAAAsG5cBAEAAEaPZc4AAAAwdeTEAAAAmDpy4unI/R8bAAAAAAAAAAAAAACAncFKEMgqXrSxazmJcF+5GD2XncjKlaTowS5eZVZb5jluzJRLqG3XKKWQihEtTRqWeIiXJw7afC9qi9cJvn1X+7X7Hp4Go1IQtRIYuTIOmbVQG+U9QrVSFkG/WX3stRIYJ6LT9omjvh6XygjnLhxHXKIjnMdoDpQoW7K4H/ZTUnb11x1YGba2RPaWjrePMfZynIXlNtqUBOnNDp57AWxQm9I/xXWN0t1KS2qUliXrozJSqxi1khpRPhX0TpXGkOrlMTyuNBZul/3OkB5lbo7DVM7iZfLDdKq2JH9PHyy1XGv5fuP7cb4Wpr3zuFRGcD/crtFvtvz3xRjD3+MvS5m2lPiFHJQcCSPMo1Ik86BUw35UKqNRAqPAPJrHsEzEflTTISx50SyH0f61EJeayJXH2A+exHrZiXSMg+hJzG2XKoFxkCkZcTCP4y/v19guW/IibFOmrbSfosYOCW6bbXr4m0huf9lTzu3bFYyXnBgAAABTR048GVwEAQAAxo/kFgAAAFNHTgwAAICpIyeeDMphAAAAAAAAAAAAAACAUWAlCAAAMHq7WIoIAAAA6BM5MQAAAKaOnHg6uAgCwxvihFJcb7NrYfsOpnLijKbUE3WMJdXWmnGL6zIHnYN6vL4X1ZEOg87jnadr/+ZKd9fi28HRNnH8WVhEOSpOHRRlLX6VWdQzLH4dzIHNokV69oJxnIiOOezb2O7ovp8Ifo/muHbf0m3N+tDhcx/GiPsF8Xp4Sw7+ti4tlt7Xdl00isLnCsiH/Vq0lcRrs10fNrlvACiQPT2HbbnTdhyj1lg4kDhlSjcVfxRkYwQ5gsUpU9DbgiiNvCLYQSO+L++XG6RHOU34XHgUw4IHmm2p7dLxG8PKJqPL+/ks/UKYR+lgOJdxepxsm2X6ZXK5hi75QzRX4byG+Xj8HB4cHA1yNqu/0Cxsi56Mk7V9HcXci/L7g/nR/b0o/szS8Wv9Mi/QeWay5pkXSdgW/n4QvYlS/aT6ccdtB4k2j/vNZ0G/+hg9t12iLe5Xex1kxp/vpyKN7co2Kz4XxfEBAAAAAOvHRRAAAGDcXP1fqDaVC98AAAAwDuTEAAAAmDpy4kmJ///NJJjZOWb2RjO7wcxuNrN3m9nTzCz938p7jGVmTzCzPzezz5rZjWZ2lZk9Ykm/U8zsMWb2KjP7WzP7dLWPvzGznzWzz287XgAApsa0+F++vd42fVBAD8iJAQCYDnJiYDlyYgAApoOceFomtxKEmT1a0usl3SLpMkk3SHqkpBdKeoCkxw0Zy8yeL+nHJX1Y0isknSrpAkm/b2ZPdfeXBt2/StLvSrpJ0h9L+gNJnyfpOyU9W9J3mdkD3P2fSsd87DG16dzD1U3Z2js9Xz01RJ2fXmL2Pa4Wy9WGq3TGlRpSbY0lmsP7uTIIcQmGYIVZC0suNEpSBPdPpK/bCpcxjtWWb44PNCgZYQfR+s0HR6Uy4jWbvXSt1dy+w/thyYvMGD1XDiNqq5XAmIXlMKJjCcuRREsv1+432oI7tddI1C/zGilu2xYtyjHUls/ueiyJpcFz8eLzUpd99xFjsWEYNLO/xCat4gNohZx4ucPzXSPHy52oMm21fKqPc1ZpmYuO5Ta6lMZoxIjStdrnYZDnWRSldi9XKiOe49SdeJDZNku21eakMN9sI1VSLJ7HWrmKXFtcDiNR2iwXo/E6y5XK6CIz/+FrZB7lnha0haUxpPqQTx7Ud1Ar8ZB4PN7fLJqgsARGXPLCenhz58onhGU0upa8SM2BFJe5SJerCEtg5EplNJ7eZDmMsn5x3+JSE7mSGoXbtfnKlx1XKk5mm+y+t/KLErCbyIkBAADGa1IXQZjZnbVIKA8knevu11SPP1vSlZLON7ML3P3SIWKZ2TlaJLbXSvpGd/9U9fgvSXqnpOeb2Rvc/bpqk89I+mFJl7j7TUGcU7VIev+9pOdIemrHKQEAYBq4YAK4HTkxAAATRU4M3I6cGACAiSInnoyplcM4X9LdJF16mIxKkrvfIulZ1d0fGjDWU6qfP3+Y2FbbXCfpZZJOk/TE4PGPuPuvhIlt9fhtkv5rdffcwvECAAAAEjkxAAAAQE4MAAAwYpNaCULSedXPP1zS9lZJN0s6x8xOc/dbB4iV2+ZNWixddp4WV+0e52T1c7+g7/qt8UqqzquP5pbELdmm677WrdtqockSGHFJBw+egHj5XQurS8TbzYLtwh1Ey97WylXES6aGl3GdiJelXX7gcakGO8jUBAnLRsyj+B3KYTTizxL7nkXlKsJxRG31UhnxdsETcqKwHEZctmS2vN9izKl+ivoF8TMlU7JalHnZSpmXS7YURN/H1qKcR6eYPcSLQ/R1+hyiJBKww8iJj9HIi3LnutK2WsDCftFYcueyWr90t3zJjsyQSstjZKcnzBfiSa7l5pmaFFFTbcyZfvWyFlFbptxGvV//H3Sp0mCNXRWXw4hKGOyFbYUxGrlc4neVf05brsRArdZB+HiUl4alMub1QR5knhr3+dLH57P642EpiFn0Qgjvx+Uv4r5dxOUrQrkyF6kY8YjyZS6CMiPzdL/cODzRL76fK2uRK5WR0nwtpcefD1T6pbk8ZJd9dfmK2RY5MVBDTgwAwASRE0/H1C6CuHf18/1xg7vvm9mHJH2dpK+U9Hd9xjKzO0m6h6TPuvvHlsT7++rnvY49ioUnVT+XJcoNZvbORNPZhfsDAADAOJATN5ETAwAATAs5cRM5MQAAGI2pXQRxRvXzxkT74eN3GSBWb/s2s0dJ+kFJH5b0i8f1BwBg8rjCFwiREwMAMEXkxECInBgAgCkiJ56MnbsIwsyuk/QVLTZ5nbt/T2n46mcfb4GusbL9zewcSb8l6SZJjw1rxmWDut8vEe+dku7bcowAAOwOH2CZM5JlbBg5MTkxAACtkBNjhMiJyYkBAGiFnHhSdu4iCEnXSrqlRf+PBr8fXkV7xrKOku4c9ctpG+u4/sddASwz+xYtasLNJT3M3f+8YJxFiipg9vBGzp5curbV+q1ep7cxxqFPYLniy0PuK77fqE989EBY97ZRI7tWuziq6xqW6o0LnAb1imtNJ+IixPPgt3pbLXy0lSyo8Rsey8FBNMYgyjyqFxwMzOaZ4tGlGvNjy9tm0RzsHd33Rpul24K5nAe/x7WiPddWi18PH46/fixRv8LXWePtm3o791COe3RKC8ZnYwS/x+/zsH5z1/nPFYwH0AU58QA58ZCyp+rCfLCRh9UaC/s1gi7fLt6m9DReemj5GPVWC7ZsTE82IQxihMeZyfcb4+85P8/mO5buF+ZhtbxLqs1BnK+l2hr9svlauq0X8yAfrP3uUbcgp59Hr5Fanh0f3HIeTbLPjr4LWPTEz4L78RTMen6RzDPJlmf6xceTihn3m9feG7l+QVs8rsx2Xhg/9/Wqvl3YUD4HtfC5frX4ZWPK76wn694fsDvIiXcsJwYAAFiXnbsIwt0fvMLm75N0fy3qqdVqn5nZCUn3lLQv6YN9x3L3m8zsI5LuYWZnLqn39jXVz0btuCrmt0n6Ay0S2+909z8rGCMAAJD44zBGh5yYnBgAgNbIiTEy5MTkxAAAtEZOPBll/0ViPK6sfj50SdsDJd1R0tXufutAsXLbPCzqczszO0+LK3v3JT2ExBYAAAArICcGAADA1JETAwAAjNjOrQSxosslPU/SBWb2Ene/RpLM7HRJP1f1+dVwAzM7Q9KZkm6MrsptHUvSyyV9r6RnmtkVh3XazOwsST8s6VZJr4n2/x2SrpB0sxaJ7V91O3TsvOKlc9Pr2DeWNc4seZxajjcOX1uON1rD1PcSO5Pqyw7vLX9ckiwsxxANMSyPEY9LQdWLWjmP6NIvOwgHEtd7CLYboByGEuUwGmUtwrtRW61cxV7clihzEZe8CMta5NqipZfD5622vHLmtVq6BHSjb271V8u8kEdadiFedbmHSkD9yK2B3lHhCvHHx+EKXyBETpxyeNLJnGdblbJItDXKVeTqRBSWx0iVxsj2awRcvk28XZvTfa1vLkhwv/E5Fw6muQ5/ui01kMKyGceF7KI4T8rl3LlSGXvptlzZjNoUN0plpEvjpZ785nO4vN+icflAPC55EY4/ajuoJcxRibugrbaraFBhuh9XHAm/T8TlL+LSGX1LlV1oVw4j3S+8X1ryIjfG+LlOlcDI9WvGD++kS2rUtmk8UBg/o3MJjMR2+ffFMAk+OTFQQ04MAMAEkRNPx6QugnD3T5vZk7VITK8ys0sl3SDpUZLuXT1+WbTZY7RIOC+RdOEqsdz9ajN7gaSnS3q3mV0u6VRJ3yXpCyU91d2vO+xvZveW9HuSTpf0RkmPNrNHLzmu53aYDgAApoPkFrgdOTEAABNFTgzcjpwYAICJIieejEldBCFJ7n6FmT1I0jMlPVaLxPEDWiScL/b4v4P0HMvdf9zM3i3pRyT9gBb/TeUvJf2Su78h6n5mFVNV/McmhvLc0jEDAAAA5MQAAACYOnJiAACA8ZrcRRCS5O5/KunhhX0vlnRxH7GCbS7R4orh4/pdpdEu5g4AwPqwzBnQRE4MAMC0kBMDTeTEAABMCznxdEzyIgi0UHoyWPNJo/Qktesns2z96RXjSZKlahBLta9VtX5xjeBwXHFt4TDoXlQ7N7g7D3YWh58HjzTr7Qb1fi3aMizkOwt3Fh1o2NYsTLt0V5Jk5f8Z4CicxfsOAyYmXJLvhccyS7Z5VLw4vO8nZul+J9IxarWj4xrTtTEv3+/ivpb2W8RY/nsjZq5fqdLtRvYnhfBt00dp4UaN7y4x2xSTB4At08inwnNafD5LtWXOpV1zPl/+sdzYX2P8pfEz2+TaUsed+yhoTEFmfmr5Zm7ucrlbblwdno/sZ2OmrZZbxXl1Lh+fpds81RaPozBf6+UzO55TT/0e5ZTzo8Z5lC/Pglw9bqsLDnRWT/DnB0fJ7ix64sPvIfF3kjh9TvUr5YXJ1Tz3XsjEnMfzWjiO8H7za1PZvsPt8tvED4QxMtsltjk2fiJI9rnIxui471I7/ncOAAAAAFgHLoIAAADj5t7TX5yjmAAAAMCuICcGAADA1JETTwoXQQAAgFEz9b8yEItXAAAAYJeQEwMAAGDqyImnhYsgMLjsCaVr267Jru/bTWpZ2sbqr7nlawvbauUN4qvaghVlLV4ytVZqot42D84+s/2jfo0lR8Oz1EE0xnDnB9G4gheeh8vXxvE7lsPocnVfH+UwmjEy5TASpTLC8heNtrjkRS7+LNUvipEplZF9DZb261gqo4/SEDuvcJn2bcnkcsuvA0Cv+jrhpM6tmfjZchWF42gTI1lGI/NZkC1lkTm23MeJZz6HsqWdfHm/RvyOy9r38llTmOPkyk5ky4uVlsPI5EylJcqysk9w4vfGzn3Zrwvz1ItVms8S/XJDiiZrFnwvaJZFOYoZl8oIvyZYtj7O6nKv47jMRW27wpi5khe5cXTZLl+SIh2/9vgx29Vj5PZ3/L6W77Bs38W67hsAAAAA0MBFEAAAYPz4wzEAAACmjpwYAAAAU0dOPBmz47sAAAAAAAAAAAAAAABsP1aCAAAAo2dxSRsAAABgYsiJAQAAMHXkxNPBRRDojiVjeteo31xYOzofM6ydGxdYDn6P14VJ7XtWH4iFdXsba8ssr+8bt9W3q/cLx2/RHNQ2i+cn/CAL6wLPo/izsABsNMJwzNF2XV7/jRKvwVzWn6eon4VzlZ6EuC2873tHv8/3ymPMT6Sep0z96Uad6vA4o7Y+6k9nlJbmLS7h239p53LDlpgeRumYd/HYAExLeG6KU4JMqtV7/Hi74nwwEyMRrs3pODeM5KHl8t44fmZ+kjvI9Yubev5ek80rMm217eK8K8yZ4pw705bM1zIxst8ZBsjXauaZF2t4nJk/Wnl0cPPgi4EHEzmbRd8LgtzfojkIU/V5oy38PhF8d0kPsbPSl6pnXoRxW+NrWrJfLmb7frk3SjZG7U7hvrJBeuh3XJhUnOIvIcftoJ8wAAAAADAmlMMAAADj5gPdAAAAgF1BTgwAAICpG3FObGbnmNkbzewGM7vZzN5tZk8zs70hY5nZhWbmmdtTEvu4g5n9jJm9z8xuMbPrzex3zOxfdzn+ZVgJAgAAjF7f/8sXAAAA2DXkxAAAAJi6MebEZvZoSa+XdIukyyTdIOmRkl4o6QGSHreGWL8n6V1LHr9myT5Ok/RHVbxrJL1I0pdVsf+9mZ3n7u8oHXMKF0GgboRv/tttybFlS17Eckv/pvq1KZuR2S5cLjdXlqNZAiMhM46w5EJcj2m2H5TbiHY+D85gFk2sHQTL2QalLOKlVcN+jXVKw77R9W2eXV81Ia7nkdhV3C8sZdGq1ESwXa3MRWOZ5KBUxolo36kllON9Z/oVL6FcWCrD43nMxU/1a6GvVWrXptVJBgBQc3gKLc2for7Fpc36ip+KUVpaQukxthliTqoERvzxVFwqo3R+2nz8bbIcRqo0WCYv6loqI7mvaLtc+bI+xHm7155ELf9dkgelMuJyFbUQ8YDny7/YxBU1atXponwz3F8jFU3k+I0x9iBXJqLer1uM4lIWme3yZSjK9p2duR5KYJTOY1bncZTW62s3HAAAAADTZGZ3lvQKSQeSznX3a6rHny3pSknnm9kF7n7pwLGucPeLC4f9dC0ugLhc0ne5L4pemtllkq6Q9Goz+/rDx7uiHAYAABg/935vAAAAwK4hJwYAAMDUjS8nPl/S3SRdenjRgiS5+y2SnlXd/aENxFrKFv+T4LBExv8dXujg7r8n6W2SvlbSg1bZj8RFEAAAAAAAAAAAAAAA7Jrzqp9/uKTtrZJulnROVYJiyFj3MbOnmdkzzOx7zexLE/v4KklfLun97v6hJe1visbSGeUwMIi1rr6+c2vVRwqX7W0sXZzYLtsvXto2NY5ou3zJi8wBhHdn8fOUOthMyYuDdNf4grvacrbBdo2Vc4NxWRQkvBu3da6tEMavDTLxeKMtilErlZErZREsLxuX9kiUtcjFaLRlxp8qa9G4X1oqo80SzV3advyUsm6WOf8Mvu82fbfiotz+mNkpkv6TpPtI+rdaXB17iqQnu/srO8Y8R4srer9Z0umSPiDp1ZJe4u7xGRgYt67lxTKVtUpLOqw7furc3Xi4S1mOjMaQcqUycvly6Rxkdt7L51fpCvcdy2GUlrLIla6r9WuUzQgTXyV1/jgtLFNQf73HB3PUMSyNcezOwlw3fDhaVLP2fsp8N8qVyoi2KuzXTZuSDl3KXHQtjVFa8qLRlgkZxiwtedFm38Uv7G0pgbHCS4mcuCgmOTEAAMCIDZQTn21m71zW4O73G2SPR+5d/Xz/kn3vm9mHJH2dpK+U9HcDxvrR6P6Bmb1S0tOqlSSO3Ufl76uf9zpmrMfiIggAADB+I/uDr6Q7Sbqo+v0Tkj4u6cu6BjOzR0t6vaRbJF0m6QZJj5T0Qi3qsz1uhbECAABgG5ATZ5ETAwAATMD4cuIzqp83JtoPH7/LQLE+JOmpkv6npA9XMb5V0n+T9IOS7izpuwcabxblMAAAAHbPzZIeLulL3P3uWvzvtE7M7M6SXiHpQNK57v597v4TWvyPurdLOt/MLlh9yAAAAECvyIkBAACwDd7r7vdbdivZ2MyuMzNvcXtti7EdLk3Xx+UfjVju/hZ3f6m7v9/db3b3j7n7f5f07yR9StL/YWb/2ybGy0oQAABg3HyAZc42fMWwu9+mo/poqzpf0t0k/Ya7XxPs4xYze5akN0v6IUmX9rQ/AAAArBs58XHIiQEAAMZue3Pia7VYjazUR4PfD1dOOGNZRy1WYgj75fQWy93/0czeKOnxkh4o6a/73sdxuAgC2CYd60PX6tdm+0V1acMd9FCfuFE8d9ahwHUjfqZA9EE4yHR4D+oAxyFsHtQWjncetFkvxaLrkiFnluznUZsyz03Y1/fSMerxMzEabV361duUafPUazdXzrdjW6di5hhG5r2MwZxX/fzDJW1v1eJ/2J1jZqe5+63rGxawRRJpS7Zf1NczKU32XBf27SN+4Zfz+HOzdIixLqfx7BDjcSXmoPdBtdEmH0nkcrl+Xdty/Yrz/Ugyv8rNf9wW3q8lgF7WL2qLN6vl9EHOOo+6WeZNVGuKX4OJOYgf9wG+T6Q05iDbd/m4sjEyx5I7zuywsjHbB8zOd+n8dBnTMdt1Gkfbvuu3yfrHfSInBgAAwEa4+4NX2Px9ku4v6V6Sanm5mZ2QdE9J+5I+uOZYkvTJ6uedon2o2scyX1P9fH/hPpIohwEAAMbPvd/bwtlm9s5lt00eagf3rn42Ekt339eirtsJSV+5zkEBAACgZ8PkxGNBTgwAADAF48uJr6x+PnRJ2wMl3VHS1YUX8vYZS5K+qfoZXjRxraR/kHQvM7vnkm0eFo2lMy6CAAAAo2Za/IfOXm+bPqh+HS49llpi7PDxuww/FAAAAAxhwJx4pfrHW4ScGAAAYORG+nfiyyX9k6QLzOz+hw+a2emSfq66+6vhBmZ2hpmdbWZn9hDr2+IB2cJPSvqWKt7tq625u0t6eXX3F81sFmz3aEnfJuk9kt5yzHEfi3IYWCi5WKmPC5q24qKoFaRXXW2e6ILGbLmKzJwUb5dZ+je3dGut/EOjTsTy7RrlDLIyA0uV0YjXpQ22a5TzqA0/ip8qlRH1q5WGiIcYlnhoDKvDizm1Vq7KlyCO50CZ56Z2bF1LXnTYrvEayZXs6GH55lz8rqUzOsktK70l4rd58RizJ7s1xtg+713lj7tmdp2kr2ixyevc/Xu67m8Fh8/Yrn+KA8c6PC9m60NmSlJk+yZyw1b7i/t1id+xrkXuM6NLyOxHQYs5TpbA2ORnTYsSXMl5bVGuotaWyeXqOVM6N2+Vaw0pft4zpTLCuzavD7KWm87Djpm8Otp1aamM2jZbmu/0UcZhrSUvWuygcwmM4uNePUZ5KY7CfuG+dzRTIycGAAAAunP3T5vZk7W4gOEqM7tU0g2SHqXFameXS7os2uwxkl4j6RJJF64Y661m9n5JfyHpI1pcXPwASf9Gi5Jyj3f3T0fbvEDSIySdL+kdZvZmSV8u6XHVNk9y98a/FrbFRRAAAGD8tvNPlddKuqVF/48ONI7D/9V2RqL9zlE/AAAA7CJy4hxyYgAAgCnYzpx4Je5+hZk9SNIzJT1W0umSPiDp6ZJeXK2+MFSs50v63yWdJ+kLtfivzv8g6WWSXuDuH4z6y91vNbNvl/QMSd8t6cckfVrSFZKe4+7vKR1vDhdBAAAAbIC7P3jTY6i8T9L9Jd1L0jvDBjM7IemekvZVr90GAAAArIycGAAAAFidu/+ppIcX9r1Y0sU9xfqJkn5LtvucpOdUt0G0WtgeAABgF/Vd621krqx+PnRJ2wMl3VHS1e5+6/qGBAAAgL6RE2eREwMAAEwAOfF0sBIEcJxcHeYe1MrLNhoLt8vVgE7eiWRq/4Z1dC2uwpPod+wOClff8aCYrs2jbcKQce3f2vwcbRfXia0dTxS+Vla6Md5+i/yGx9mYqnBeGzWgy7arlVCeZeofZ+pIx9vV4ufGmOoX921xbKkxZttKy/Tm3gtdn/YtrQldsy111DEYMztD0pmSbnT3jwVNl0t6nqQLzOwl7n5N1f90ST9X9fnVtQ4W2LBGPpVLW0pzxUy/VF6XjRHHKYzfCFkYIycbP7VNefjyj6WB8/bkvo5Rmo9k84xcPpLI+XJtuXxnELWd158cC9rqq2pmvj/Ez2/wXcBnUfxaWxi93q++5/i7Reb7RHDfav2UNvRfyjomrfGxJfv1sO/s/OS+B5ceWzZ+H2NscxLoux/J+irIiQEAAIBp4CIIAAAwbi4pvoiqj5gbZmbPkHR2dfc+1c8nmtm3Vr//ibu/MtjkMZJeI+kSSRcePujunzazJ2vxh9+rzOxSSTdIepSke1ePXzbQYQAAAGAdyIkPkRMDAABM1UhzYizHRRAAAGD8xpmMPlTSg6LHzqluh16pAu5+hZk9SNIzJT1W0umSPiDp6ZJe7F64fA8AAAC21zgzOnJiAAAAlCOjmwwugsD2yJx4elktNLd88LYKV42Nm0qXri8slVErPSBJwTKytZIRmVIHcamMbHmM2mB8+cONfUeNQZtHL5JaiZBwidp4eehw/Jm/ZxQvu9pGImTjuShcurjZtnzp32yMRjmM5TEa93NlUbIlL5bvqxEzt4x01yWmO5TK6AWr16In7n5uy/4XS7o40/6nkh6+0qCAkeqlXEVhv+LSFXGcDrlhvL8u+eVxksfTouRIIm3MW/fnbdeyW4kYbfKWXJ5Ub/Nkv+S+FE15Y1xr/FIV7qoxQek3kSv8XmOpbtEcx2X4bNmvzWEprbbZFpUz6PQMZsZf/E/Ebc4jqf21GXwvY+6hFEeXfsgiJwYAAACwDBdBAACA0Vvnv9EAAAAA24icGAAAAFNHTjwduf+nDQAAAAAAAAAAAAAAsDNYCQIAAIwf5XsBAAAwdeTEAAAAmDpy4sngIgggEpf57HtpnN7ihzWDlz/c2F+uTHWztm2iQHS0fozNg21atClo0yxxMPED2RrWUe3fsORxGCL6gKu3pWu8DrFEUmmN7Hot50wt22iOU/Wh4/36LP0iCfs2nsNUWyN+t32nal/nSvFmazvvujEdSxul9emPidH7e5hcGZisVrlc2LeHftl9586Rhf2yQ+yyrxZyn++1cXQL37vS8TaU5jGZnCab7zTajp6QXPzsvofmid9zX2waf7QK2uZRW5BverADy3w78qjNwrbMrsMxNr9fhdtsUSLR4cXc6m+GhX1z38WKzyuFx1I8/jZzUxyzPGR9ux7emOTEAAAAmDpy4kmhHAYAAAAAAAAAAAAAABgFVoIAAADjxxW5AAAAmDpyYgAAAEwdOfFkcBEEdsLQJSr60BhjrTGzYaYSRPGqxn3Ez60+OsstLxuEmNebaiUScmNMLYEr1deRjfed2y7VFpfNCHeVW356iDpRidIW2ZVOWyxdnC6HEc1BrpRFYTmMZGmMY8aYW765tu/SGJFOy0rn5jHWx6q027Kudw/i99CYjg3ABJjSyUDmhFYvz3VM/Ns3KuzX2FnZsBrjGLhURumuOgWMN9uFz5Y+Sne1KVeRK3tWWuaih3yn+LkpfX1my07kdhBPwvIXuUdBLLODWqmGxve+5YPJDjFXhm/g13gvX2taxMiWuegSs++SFx3jtzqHdRnLEKU4AAAAAGBCuAgCAACMnMt6v5CJvzYDAABgl5ATAwAAYOrIiaeEiyAAAMD4zY/vAgAAAIwaOTEAAACmjpx4MrgIArsvXO+36/q4xUur9rRd3zqW1FBm6pLbxavLhnficglBY3GpjExZi7iMQxizcdzB1XzhhX2N5aF96a9L+g67Lm1pyYV2pTKWL9vbWCa5sBxGoy2xXW6Z51pplRbblZbNGPhpyipe3hotT1QAsAUK883iEm4tSl5ktyus3lFcpiMXu3DMpen4IKf+PvLxjgPrXD6rS56XzYWiSUiWR0vvKlvFbuDPbAt2EJerqH/3KnwzZJuiEnGZ0jD1ryGFpTLi4RfWdMz+p6Su89/zd9XiEhd9jaPvEhhDlLzost265xEAAAAAJoSLIAAAwKiZq/dlzgr/HQMAAADYCuTEAAAAmDpy4mmJ/982AAAAAAAAAAAAAADATmIlCAAAMH5ckQsAAICpIycGAADA1JETTwYXQaAXvSz30qKs68YMMMZUCdk4fGnp6DYxuuzbZ3ER4uD3eX1C6tvVN6uV1g43i+c015apuVs7uFqM8nrB2XK8HZ774pKvuRrNFhcoLoyf6Vd7buIYufiptkb89Astu13ieIrHEccs3Pcgta57eO7L95V+cQ5dxxsAJiE+z2ZOrqmmbB7RJt9M7bp8iOmxlCafx/VNbDfEZ1LxMHr5vO2nbzIXKt1Gqj2JuWPL5V3Z4+lhviz33PfxpSentsPSJL6+Aw+2s1ZvjqAl9+WrVBDeWnwh8aGTwC7fizuOqXjl2q7HXBy/W/jBxwUAAAAAkMRFEAAAYAp6rvUGAAAA7BxyYgAAAEwdOfFkcBEEAAAYvV5WLAIAAAB2GDkxAAAApo6ceDq4CAJ5O34yqK042vFYusZIrnY6xJx2WeE12q600kR28ddGqYxw3du4cxBznomZGlTcWFhGw6Mg2ee0vHLG6toseZzYLlsKIhevQ8kIqV5Go1amo4+SGseMa2MKS3YMjbIWADCMw/Nrq7wxu85/fj/LQjTj5wKtvk3pZ4qVJoS5/W1yRf6+990iXmkuV17mrH6knctclIxp3cLvCHFJitwbpbjkxepfnBr/aSgYV75URmj1bxONEhfdqnT0b+gyFz3sq3spi67bdRjnjv8tBgAAAAA2jYsgAADA+LHMGQAAAKaOnBgAAABTR048GbPjuwAAAAAAAAAAAAAAAGw/VoIAAADj5vmyO11jAgAAADuDnBgAAABTR048KVwEgenqWg62JF7HmLmyro3Ss4l9dY4Rj6WXGBb0i2oXh3dmqYao5HGuhnU8sNT8l/Y7brs+FJaGLa0j3aXedGO7Vm22vK2n+Mlj6yPGcW1d9PF8dozZi03W/14HljkD0EIjnyo9heQ6Zj4Acp8N2X2ntuuyzTHblX5+Ncbb9+dL12Pr0i83jL4+z4tzOU/365Inxf0yu87qMpdd32Clz31jglIbdnwzZOLU0o3McdkgiVfHZ7GXRDgTvo8UrMsYu+6383Z9nFjWsB05MQAAAKaOnHgyKIcBAAAAAAAAAAAAAABGgZUgAADA+HGBLwAAAKaOnBgAAABTR048GVwEgV50XjJ4G7Upa1FYUiOcn8YimcXLK6c361LWYv0xcnU6wnoemR3kSmXE85PaLjePrZYRbdE3se/iXXUsc5GM0aacRK1f5jnsWnaiw7g6x+iqa4w1LskNABhW53IVqY4tPqBqeWTHvLEesON2hTG6fvb2cmyF1p4fFOdo6UnoXP6rB6Vj7L6Dwn5djy1bQy8RP1dSo/QLUa4ETg9/dYtT850oa1ELuMHyEX3E6Tr+XsqD9BADAAAAAEaOiyAAAMDIuaz/v9z3HA8AAAAYEjkxAAAApo6ceEq4CAIAAIybq///vkhuCwAAgF1CTgwAAICpIyeelNmmBwAAAAAAAAAAAAAAANAHVoIAWojLfmZL4haWni3dXx91kuMQuSGmwmRj5ErnxhuGZbGDKBbtIVvC1zNtpXPXrTx3t+e0a9nb0jrSme3K+8Uv8vQ4kjFz/drUsE61ZfpllY4/IzfGVtth/eabHgCAseqWr2U6Zj40cp8nfeSK9Z31EKNFzI1+VnbZd4tt8nnY8knJ5hxtxpvYrrHXrvHXyIJJ8dyLKTf+7JeL7N47blcSr81mR/vufQXXVQz9Bu7jWLvE6Ou4NjX+ZciJAQAAMHXkxJPBShAAAAAAAAAAAAAAAGAUWAkCAACMnm3Vf5cEAAAA1o+cGAAAAFNHTjwdXASBcYmXkw2XTM2VsuhjddNMKYjEkJqbtVgiODXk4hId8Xbx/jJtyXFF+y4utxEuzRsfaFhSo02pjESMVm0ZxUtO53bdsYxDcYxEW7bkRSZGcbmK3DhalMrIlsBI6DzGxDatDL0KcIeltNeNsh8Adl5pPbBUt17KVfRfKqPbOAr7SeX51C58TnQcY9fP6dLyYsX73oU5HkKX8i3ZWn65+NlvR2Xj6FyJY8ef4L5T1r7i9TGv21TyAgAAAADARRAAAGACuMIXAAAAU0dODAAAgKkjJ54MLoIAAADj5uo/uSVXBgAAwC4hJwYAAMDUkRNPChdBYL0KS0YcJ1ytcvBV4PsuldFmqdYOSwtny05kGnPblZbGiGXLbSR20IhfWCoj3jCs65Qtm9Fx6ei+V6LtpzRGbg3uspi5chLN/SX6tSnf0WXfPZTNOC5m7/EL9zXEEta9vFZ3fOVlAFhZD/lgL/lrx1IZHbq1G+OIPyfKc7SyCetaQqw4RiZmcUWHbZGtLFE/AM++N2obZvr1UOcv++QUvql6+s6804Y45t6/wG1JDGn3y6QAAAAAwABmmx4AAADA4OY93wAAAIBdQ04MAACAqRtpTmxm55jZG83sBjO72czebWZPM7O9IWOZ2XVm5sfcnh1tc/Ex/c9eZS4OsRIEAAAAAAAAAAAAAAA7xsweLen1km6RdJmkGyQ9UtILJT1A0uMGjHWRpLssCyXpJyWdIulNid29SNK/LHn8n0rHm8NFEAAAYNRMXiuR01dMAAAAYFeQEwMAAGDqxpgTm9mdJb1C0oGkc939murxZ0u6UtL5ZnaBu186RCx3vygR6zu1uADirw7jLHGRu19XdKAdcBEEsIJsbefC2tFd60Mnt4vKgWZL4HbYLjfE4hK7UaBsGd1Ev+MG5pYogJwZZO7Db51lVmtjP05pXela/PJtutSt7hy/cLs2z0WX561rne0+9o0B9ZzcApiwbMJTFiL3GdEmHyzesMOHUl+fY52Pp2e9HE/hwbTJhUrbuuRkrXTMtXpR22Eu+U+zIIbHb8Qux5P7UlKqEaLwjd/He2aTeegm3/N9v3j7Opa+52SV4yQnBgAAwNSNLyc+X9LdJP1GeLGBu99iZs+S9GZJPyTp2Isgeo71A9XPXys6igHMNrXjTdpUXZRgmyeY2Z+b2WfN7EYzu8rMHlG4v3uZ2U1VTZTXth0vAAAAIJETAwAAAOTEAABgx51X/fzDJW1vlXSzpHPM7LR1xTKzf6VFCY3PSvqtTNeHmdl/NrP/y8z+Q7USRW8mtxLEhuuiyMyeL+nHJX1YiyVFTpV0gaTfN7OnuvtLM/s7Iek3Jc1LxwgAwOS5+r/Cd3QXDGNqyIkBAJgYcmKggZwYAICJGS4nPtvM3rm02f1+/e6w4d7Vz/cv2fe+mX1I0tdJ+kpJf7emWE/SohTGxe7+mUy/X4nuf8bMftLdX3bMOItM6iKITddFMbNztEhsr5X0je7+qerxX5L0TknPN7M3ZOqf/JSk+0j6CUkvann43ZTWQdjWfdeWFa0vGVlaTiJbSqHLuNrE6KOkRqIqRGMohdu1WQG6dJHO4ilo8dxkn9NEjFZlKFLjiPWy9HLhMDa4vHJpWYvGvvoogdF1+ebSvkM/h5ssqUHJDmCSyIkH1EOu2ObcX1xqoktNip4+hHaiPFSH+ekt5+ihfFk2lygdR07PNU3icJ1eI22+eKSG32a/uS9cfdQRLJ2E0udi1/9heugTx9DzM0T8nTiZAruFnBgAAIzEGdXPGxPth4/fZR2xzMwkfX9199cT3d4q6Y2S/kzS9ZK+RNJjJD1H0kvN7KS7p7YtNrVyGIe1TC6Na5lIelZ194cGjPWU6ufPHya21TbXSXqZpNMkPXHZzszs/pKeLem/SHp34RgBAIC0uMK3zxuw28iJAQCYopHlxGZ2ipn9qJm9xszeZWa3VWUBvv/4rRuxzqq2Td1K6h5jt5ATAwAwRcPkxO919/stu5UMycyuOyYXjW9tymAdXlHdRwJfEuvbtVgp4i/DvCjk7q92999x939w91vc/YPu/suSvrvq8vNdSpPFpnYRxKbrouS2eVPU53ZmdgdJvyHpXZJ+oWBsAAAgNO/5tmH8wRcrIicGAGCKRpYTS7qTpIskXSjp7pI+3kPMv5b0M0tul/cQG9uFnBgAgCnazpz4Wknva3H7aLDt4eoMZ2i5O0f9cvqI9QPVz9YrObj7GyR9RNIXSfrattvHJlUOQxusi2Jmd5J0D0mfdfePLYn399XPey1p+4Uqzn2r2McMrSlVi0bS2a2DAQCATTv8g68kfUKLP/h+2Yox/1rSFUse/9sV42L7kBM3kRMDALB7bpb0cEnvcvePmdlztVhCdxXvcvfnrjow7ARy4iZyYgAANsDdH7zC5u+TdH8t8obaZ7yZnZB0T0n7kj44dCwz+2JJj5b0WUm/1eYgAp/UIk+6U8ftbze1iyA2WRel077N7MGSnirpGe7+noJxTU6uPOumxiFFY8nVhrVMUyrGss5txxGFKP3K1Kq0bWnfzPxkn9Jcad4O9Xg7v356Ls/aW43p0piFbaUx+thXNk5pvxb7XmuMPmzyZNeHDZQ0ti1Yrrdn/MEXqyAnTkmdn/rOEXo6JaU+e3r5mBj6s6bNB+caP/c6f54PnUuU5nyFw+j8WbyBz/DbFX55sWgiPfX6yXwvy48j84Wr9AtQm5d0bbs1PgG5991aE9+Ohj5tDBF/DfM6tpzY3W/T0f+YB9oiJwYAYILGlhNLulLS4yU9VNJvR20PlHRHSW9191vXEOuJkk6RdLG7f6Zs+EfM7AwtLsp0Sde13T62cxdBmNl1kr6ixSavc/fvKQ1f/VxXXZRlbu9vZneR9BpJ75D0y6sMJlV3prry976rxAYAAOvFH3xBTtwNOTEAADjGl5jZD0q6q6R/lvR2d3/3hseEBHLibsiJAQAYlcslPU/SBWb2Ene/RpLM7HRJP1f1+dVwg+pigzMl3RitStU6VhDTJB2Wav611GDN7O6SPs/dPxA9/nmSLpZ0uqQ/cveVS93t3EUQWtRFuaVF/22pi3Jc/2VXAL9Ai7onD3H3g4IxAQCAmPvi1ndM6ezUMqKpPyptOf7gu1vIiQEAQDly4lIPqW63M7OrJD3B3f9hIyNCDjkxAAAoN1xOvDHu/mkze7IWFzBcZWaXSrpB0qO0KNl1uaTLos0eo8XFlZdIunDFWIfOk/TVkv7S3VOlt6TFSg9/bGZv16Lk2PValL94iKS7a1Fq4/vTm5fbuYsgdrUuirvfZGYfkXQPMztzSb23r6l+hrXj7ivpDpLem6jv9ngze7ykv3b3+xSMGQnZkhqFpSwaZRx6KLPQeVwdYrQqxVHbwfJ9tdgsv03pcWb2VVryotXqo12e0x5WN+2lVMYAyzAXb9dDjL7KhZSW28jpNF8Dr3K7C6sTY2vxB98dQk5cM3xO3CWp6Rqvh/hdPwvWWm1pzaWdevl87KHkRaxTPrLu0mmb0qZcRYfvLtlafq3eo4V1adrUFSzdrjRGF9v0oljn6WLwMhpbNK+I3Szpv0i6Qkc50DdIeq6kfyfpzWZ2H3e/aSOjw1LkxDX8nRgAgIly9yvM7EGSninpsVqspvABSU+X9GL38is1Voj1A9XPXz9mF9dWfb5Ri4sr7qJFLv4+SS+t9tG6lMYyO3cRxIo2XRflSknfW23zmmibhwV9Dv2upGuW7PtMLeqAXyvpKkn8wwQAADnzQf6i/d4d/d9tMf7gOz3kxAAATNEW5sQDlzMo5u7XS/rp6OG3mtl3SPoTSd+kxf9Ie1Hf+8bGkBMDADBFw+TEG+fuf6pFTlDS92ItSk+sHCvY5rskfVdBv3+U9INtYnc1tYsgNl0X5eVaJLfPNLMr3P1T1TZnSfphSbcqSHrd/WeXHYSZnavFi+/P3L2XJUEAABi1DS9Ltgx/8MUGkRMDADBFW5gTa7VyBoNz930ze6UWOfEDRU48JuTEAABM0XbmxBjApC6C2HRdFHe/2sxeoMWSIe82s8slnarFlTFfKOmp7n5dn8e8KcWlIApLHWSXKi3VWI50Q8tQtll2NVdqIrVdi3IPuZIXXtgvp8uKr11XiS19jTSe9q6fd+t8+fS89PLgJS+6xuy670JDjL9v+TGuMTljld514Q++2Ahy4p71XSqjTfye9zXZVdq7HHdf5bNKY+bypNKBbPL5LS5XUVrHLrqfiWlBTA9jdi2DWCr3xLcplVE6Dv6Ol7fWkhpTPZl2s2I5g3X5ZPXzThsdBXpFTgwAADBuk7oIQtp8XRR3/3Eze7ekH9GiPspc0l9K+iV3f8NKBwcAAJbbwit8+YMvNomcGACACdrCnHhHfHP184PZXtg55MQAAEwQOfFkTO4iCGkr6qJcosUVw524+1Xi/+kCAIDh8QffESMnBgAAU5MqZ2Bm3yTpr9z9tqj/eZJ+rLr72rUNFGtDTgwAADBOk7wIAgAATIir/yt8d/CCYf7gCwAAMGEjzYnN7BmSzq7u3qf6+UQz+9bq9z9x91cGmywtZyDpeZK+zsyukvTh6rFvkHRe9fuz3f3qXgcPAACA9RppTozluAgCoxKX3syVke0UI76uurAtW9q2tPZsXDY2FTM3xripcFy5aex6qXkqZl9lbovHlZv/Tek4qX3Um87G6FqneojtCuN12vea56cPvdQaH3rfG+XSvO83+OZPGPzBF9gBqXPkEKeQ0vPx5k9f69HX51OHOK0+G7vkI13itdHlS9Q2yXyvseDJ8fg4u37v6yL3IsnNf+lTsxP5WQ82+VLdjSQ4Ms6cWNJDJT0oeuyc6nbolTreb2qRL3+jpIdJOkXSJyT9jqSXuvvbVh8qAAAANmu0OTGW4CIIAACA3cQffAEAADBp7n5uy/4Xa0k5A3d/laRX9TIoAAAAABvHRRAAAGD8fL7pEfSOP/gCAACglRHmxAAAAEAr5MSTwUUQmK5wmdEhlrJMlFnYqnIbYVPpuErLcsTbFeqr9IYXHnduB+tcCbiXl2BhjM4lHQr7Dl7+YpvKefQgP2aW0gKAdXGlz8m9n45bJTUb3PdUDF3yonRfXUtgdNhfX/nNWisC9PC9KVUaQ4rKY3T8TrXRUhm1GD2MY6p2sswFAAAAACDGRRAAAGD8nH8NAAAAwMSREwMAAGDqyIkng4sgAADAuLmkec/JLbkyAAAAdgk5MQAAAKaOnHhSZpseAAAAAAAAAAAAAAAAQB9YCQLlcrVV1x2/sCar12q+dhjTcTFKa8N2lYufaItLmFppfdy4KVUTO71J/inLjb9Q1ynuWtU1Ww62y2AGKC/bqWRtx1rUxfvO1bMeoH52NubQJX077HvtZYZL9zfq8sc+wDJnXOILTEnu3N01xyxWen7mtFS3ybyrzb77GOeOf4Zb5rvMesdxtHOP39i571Rd+nVVOkGDn5h20CZfXFuDnBgAAABTR048JawEAQAAAAAAAAAAAAAARoGVIAAAwPj1foUvAAAAsGPIiQEAADB15MSTwUUQGFwfJSkG18carLlSE5myFsXzM0T8DuU8WpXbKAxfGqOrQV52hc/b4Kuu9l0OI9JHqYm+S2D0Vv6i7/i9LGdd9mrdydV8d3HMAFBga1an7+M8uy25+po/M3r5XO25VEb2qeiYj+RznMweN/UZnvvi0eZ7Taqtc828TPwu/YbQx4t6m76872TyCwAAAADYJC6CAAAA48cVvgAAAJg6cmIAAABMHTnxZHARBAAAGDeXNJ/3HxMAAADYFeTEAAAAmDpy4kmZbXoAAAAAAAAAAAAAAAAAfWAlCOy+XP3XsClTUrZUHzEatWDD0rabjJ/ZLidXnjUbv/2uNlaO+DhbU6K2tMZ0m/EOEbPDvvI1rLckfsbWvEZ6sPZj6WV/PsAyZ1ziC6Cd4pxpk0b0eRUbOlfpY7vsy2DEz83GxBMezLFFLxjPvUkLv/Nkn+BtfH7HlMCOTefPDHJiAAAATB058ZSwEgQAAAAAAAAAAAAAABgFVoIAAADj1/sVvgAAAMCOIScGAADA1JETTwYXQWB7FZa56H+/0c4yy4B6bcnUOE7YMbe/dL/i+LWN1hw/o49SGblyHjnF8fuwJUvbdl6xdktKXhTvr6dyHkPHL49R9qYqnv91j38XuKR5zx8k5MrA+JiOzotrfo93/YzdmjIaazT4Cv0D51OxXp7CqXye55SW+SstV9EoI3j0QHFpjNiYSmVgeEOc38mJAQAAMHXkxJNCOQwAAAAAAAAAAAAAADAKrAQBAABGz32+6SEAAAAAG0VODAAAgKkjJ54OLoJAdx3KVcTL1/a+hG9u6dPMWLLjsI71GGoxysaUG3/x3LVZ/rXw0LKlJTo+h6VTWTzj5VVMOsm/RrrF3MblnAcZU5eSFC1i7Fw5jxYGf40AAJZrc/7d4LKHfE50tOacIFT8cunpuU2X/9rB9TqLv8DlYgS/dy5DU98wWx6jj32Xfu/DbtjBtx4AAAAA7CIuggAAACPn/dd64y/YAAAA2CnkxAAAAJg6cuIp4SIIAAAwfk4yCgAAgIkjJwYAAMDUkRNPxmzTAwAAAAAAAAAAAAAAAOgDK0FgN8T1TrfwQq243m6yNGybYwn7Rv2KS+JmYmTryAZ9s/sqjNFVaa3rQUriJuZgEAPH35bxtxpHsoZ1eYji/eX69X1sQ9Tg7uM4Mzq/fralVrVLms/7jwkA0uC5EFoY4nOnh5jFL4OBP8+LbfDz2/rIv9t8X+khhiUG6rmcr/T7W06b88u25GRjtgvne3JiAAAATB058aSwEgQAAAAAAAAAAAAAABgFVoIAAADjR603AAAATB05MQAAAKaOnHgyuAgCC4fLY47tvZ8rBRE2FZeWyNSk6Bwz3KiwX9S3077a7K9wWdp1l8qoheu4xGur+dqQwUtZlFpnyYtN7nuQchtlL/heyncAALZHH8vwY72fe11LRw29vyFyoanr+t2ltFxf9GRky2Ok9tUIWhaiVcw+4o8V52MAAAAA2FlcBAEAAEbN5fKea705fxUHAADADiEnBgAAwNSRE08LF0EAAIBxc/W/zBm5LQAAAHYJOTEAAACmjpx4UmabHgAAAAAAAAAAAAAAAEAfWAkC/Yhrh5aWOw22Ky2R2thf3xdtRceSHVfYmCnAW3ycbeYxMQe5OsCNffdR93aIfafGMQDqJqt77euea1gPUut6o/vekktAOzy/G31fDLXv+ZY8HwBwnKHPwUOcDnctn+phvJ2nse/8qdW+t+SzsOv3glqMFl/aOnyvKe53XN+wWzBm7/pctPku2Xf8PvT9ut6Sl/TapY67ZD7IiQEAADB15MSTwUoQAAAAAAAAAAAAAABgFFgJAgAAjJxLPu8/JgAAALAzyIkBAAAwdeTEU8JFEJiOjiU7yuNHARPrybcrtxFuuHq/wffd2GF638lwW1o2Yyf1sdTz0Es2912GYoBSGUOXhhh8jtdpW8fokve9zBnnHGCcDs9jY36Pb+u5ug8DHFsvL4VtySV2bF87o7SMRtgtW0pxS0tl9GHM59a+DTFX5MQAAACYOnLiSaEcBgAAAAAAAAAAAAAAO8jMzjGzN5rZDWZ2s5m928yeZmZ7LWKcYmY/amavMbN3mdltZuZm9v0F2z7BzP7czD5rZjea2VVm9ohM/zuY2c+Y2fvM7BYzu97MfsfM/nXpeI/DShAAAGD8el/mDAAAANgx5MQAAACYuhHmxGb2aEmvl3SLpMsk3SDpkZJeKOkBkh5XGOpOki6qfv+EpI9L+rKC/T9f0o9L+rCkV0g6VdIFkn7fzJ7q7i+N+p8m6Y+qsV0j6UXVfh4n6d+b2Xnu/o7CMSexEgQAAAAAAAAAAAAAADvEzO6sxYUHB5LOdffvc/efkHQfSW+XdL6ZXVAY7mZJD5f0Je5+d0mvLtj/OVpcAHGtpG9w9x9z9x+WdD8tLsZ4vpmdFW32dC0ugLhc0je5+3929++WdL6kO0p6tZmtfA0DF0Fga7jVb8UsuA08ro3GN5Uda2k/Nec8OZY4Zumcd9guN6bOY+x6W6c1jn+QOe56bBmd3httxlGw33bnIq/f+o5fPA6Vz0liXGPkc+/1BmDkdiF3mJI1zr9Ht066jqtDjnR8nnR8btJm3+tUmFotlE5I6ZPb9YWw8otHMrfarRfx8aRuGEbp/K/huSAnBgAAwNSNMCc+X9LdJF3q7tccPujut0h6VnX3h0oCuftt7v4md/9Yi/0/pfr58+7+qSDWdZJeJuk0SU88fNzMLNjm/3Y/WprD3X9P0tskfa2kB7UYw1JcBAEAAEbOF8uc9XnjXwoAAACwU8iJAQAAMHWjzInPq37+4ZK2t2qxusM5VQmKde//TVEfSfoqSV8u6f3u/qHCbTo5sWoA7LyzTl7/Cf3ji1/Yb9Qe3vNb9J+Qutn4eW9NpnKc6G7n38yFdvw4e3krb2gOTl7/CUk6K9V+kz6jd/j/2+s+b9Jneo0HYOOGyYmBTTt2CYUR2vGcLLbWZ3Bkc7c11vQknvz49RI5MYDVnHXyE9fro88nJwYA7KaTn9hYTny2mb1zWbu736/XHTbdu/r5/iX73jezD0n6OklfKenv+tyxmd1J0j0kfTaxesTfVz/vFTyWHG9mm064CAKf9pMnddtHPnzdpgfSg7Orn+/d6Ch2G3O4OuZwdczhaqY4f2dJ+nSi7b1zHegz+pch9julOQbGjpwYIeZwdczh6pjD1Uxx/s4SOTGA1Sxy4g9/5LpND6QHU/wc6BtzuDrmcHXM4WqmOH9naTM58VlDBC10RvXzxkT74eN32ZJ9r228XAQxce5+z02PoS+HV1mt4aqq0WIOV8ccro45XA3zV+fuj9/0GABsP3JihJjD1TGHq2MOV8P81ZETAyhBTowQc7g65nB1zOFqmL+6bc6Jzew6SV/RYpPXufv3lIavfm5yqcg2++5tvFwEAQAAAAAAAAAAAADA+l0r6ZYW/T8a/H64csIZyzpKunPUr0/H7XvZqg9rGy8XQQAAAAAAAAAAAAAAsGbu/uAVNn+fpPtLupekd4YNZnZC0j0l7Uv64Ar7WMrdbzKzj0i6h5md6e4fi7p8TfXz/dF4VY13mWXbdDJbNQAAAAAAAAAAAAAAAFirK6ufD13S9kBJd5R0tbvfuoH9PyzqIy1WvfgHSfcys2WluJZt0wkXQQAAAAAAAAAAAAAAsFsul/RPki4ws/sfPmhmp0v6uerur4YbmNkZZna2mZ3Zw/5fXv18ppl9QbCPsyT9sKRbJb3m8HF392CbXzSzWbDNoyV9m6T3SHrLqgOjHAYAAAAAAAAAAAAAADvE3T9tZk/W4mKIq8zsUkk3SHqUpHtXj18WbfYYLS5MuETShWGDmT1D0tnV3ftUP59oZt9a/f4n7v7KYP9Xm9kLJD1d0rvN7HJJp0r6LklfKOmp7n5dtP8XSHqEpPMlvcPM3izpyyU9TtLNkp7k7vN2M9FkiwsuAAAAAAAAAAAAAADALjGzB0h6pqRvkXS6pA9IerWkF7v7QdT3QlUXQbj7hVHbVZIelNlVY5tquydI+hFJWY5KKgAAEFtJREFUXytpLukvJf2Su78hMd47SHqGpO/W4gKIT0u6StJz3P09uWMtxUUQAAAAAAAAAAAAAABgFGbHdwEAAAAAAAAAAAAAANh+XAQBAAAAAAAAAAAAAABGgYsgAAAAAAAAAAAAAADAKHARBAAAAAAAAAAAAAAAGAUuggAAAAAAAAAAAAAAAKPARRAAAAAAAAAAAAAAAGAUuAgCW8HMzjGzN5rZDWZ2s5m928yeZmZ764hlZk8wsz83s8+a2Y1mdpWZPaJwf/cys5vMzM3stW3H25ddmUMzO8XMHmNmrzKzvzWzT1f7+Bsz+1kz+/y24215bF9qZq82s4+a2a1mdp2ZXWRmXzB0nHW/NoewK/NnZg8ws180s78ws09W+/iQmb3SzL66y7H3ZVfmcMm2p1XvWTezD7cZKwCgzK7kc4ltyYlFTjxUPrLKa3MIuzJ/Rk6c2oacGAC22K7kc4ltyYlFTjxUPrLKa3MIuzJ/Rk6c2oacGOPn7ty4bfQm6dGS9iV9VtKrJP2SpPdKckn/fehYkp5ftf+jpBdKepmkf64e+5Fj9ndC0jskfabq/1rmMD+Hks6uHv+spN+X9Lyq/weqx98n6YsGmqevkvSJaj9XSPoFSVdW998r6a5DxVn3a3Pq8yfp45IOJL1N0kXVXP5p8Nr7lnXP367N4ZLtf1lH57oPb2L+uHHjxm3Mt1XP06vGWiXvEDlx6zkUOTE5MTnxTszhku3Jiblx48ZtwNuq5+lVY62Sd4icuPUcipyYnJiceCfmcMn25MTcduK28QFwm/ZN0p0lXS/pVkn3Dx4/XdLV1Un0gqFiSTqnevwDkr4gePysKom4RdJZmX3+dLW//1MbSm53bQ4l3UPSf5J0pyjOqZLeUMV6yUBz9T+q+E+NHn9B9fjLh4izidcm86f/LOlLluz7p6r+f7POudvFOYy2P1fSXNJTRHLLjRs3br3fVj1Prxpr1bxD5MSt51DkxOTE5MQ7MYfR9ueKnJgbN27cBrutep5eNdaqeYfIiVvPociJyYnJiXdiDqPtzxU5MbcduW18ANymfZP0pOpEecmStvOqtrcMFUvSb1SPP3HJNj9btf1MYn/3l3RS0rOqE/+mktudncMl/Q8Tut4TD0lfWcX+kKRZ1Pb5Wlz1eJOipLuPOJue1ynOX2b/e5JurrYpupp26nOoRWJ8naQ/qu6T3HLjxo1bz7eeP+vIiXdsDpf0JyceYF6nOH+Z/ZMTt5xDkRNz48aN2+C3nj/ryIl3bA6X9CcnHmBepzh/mf2TE7ecQ5ETc9ux20zAZp1X/fzDJW1v1eJD6BwzO22gWLlt3hT1uZ2Z3UGL5ONdWiwvtEk7OYcJJ6uf+4X92zgcw/9093nY4O6f0WIJrDtK+uYB4mx6Xvuwa/OX4jp6fR0U9O/Trs7hiyV9gaTvO2ZcAIDudjKfIycmJ24ZZ9Pz2oddm78UcuImcmIA2LydzOfIicmJW8bZ9Lz2YdfmL4WcuImcGKPCRRDYtHtXP98fN7j7vhZXsJ3Q4oq2XmOZ2Z20WHLrs+7+sSXx/r76ea8lbb9QxXlCFXuTdnUOl3lS9XPZB/CqksdWKR1rlzibntc+7Mz8HeNxWlwF+2fu/i8F/fu0c3NoZo+R9ARJT3f3fzhmXACA7nY1nyMnFjlxizibntc+7Mz8HYOcOEJODABbYVfzOXJikRO3iLPpee3DzszfMciJI+TEGJsTmx4AJu+M6ueNifbDx+8yQKxO+zazB0t6qqRnuPt7CsY1tJ2bw2XM7FGSflDShyX94nH9O+hrrF3ibGxee7RL87eUmd1T0ku0uML3x3N9B7JTc2hm/0rSr0l6k7u/6pgxAQBWs3P5HDlxLRY5cVkccuLV4pATrx6HnBgAttvO5XPkxLVY5MRlcciJV4tDTrx6HHJiTAYrQWBlZnadmXmL22vbhK9+eh9D7Rjr9v5mdhdJr5H0Dkm/3MOYDuNOZg6XBjU7R9JvaVGf6rHu/qkOY1tVX/PUJc4g87pmWz1/ZvbFWiwPdzdJP+ruV3cb3qC2bQ5fIekUSU9ecTwAMAlTyufIicmJB4pDTrxaHHLi1eOQEwPAiqaUz5ETkxMPFIeceLU45MSrxyEnxmiwEgT6cK2kW1r0/2jw++FVZWcs6yjpzlG/nLaxjuu/7Iq4F0j6IkkPcfc+60RNaQ5rzOxbtEg65pIe5u5/XjDOLvqapy5x1j6vA9il+aupEtsrtVjq60fd/VeOGeNQdmYOzew/SnqkFks5fuSY8QAAFqaUz5ET1/uRE5fFISdeLQ458epxyIkBYHhTyufIiev9yInL4pATrxaHnHj1OOTEmAwugsDK3P3BK2z+Pkn316Im0TvDBjM7IemeWixJ9MG+Y7n7TWb2EUn3MLMzl9TU+prqZ1gb6b6S7iDpvWamJR5vZo+X9Nfufp+CMasay5TmMIz5bZL+QIvE9jvd/c8KxtjV+6qfqTpa2bGuGGet8zqQnZm/qP1MSW+WdLakH95gYivt1hzet/p5iZldsmQf9zCzw6uBv2ADdfMAYOtMLJ8jJyYnJidebmvmL2onJz7ahpwYAAY0sXyOnJicmJx4ua2Zv6idnPhoG3JiTALlMLBpV1Y/H7qk7YGS7ijpane/daBYuW0eFvWRpN+V9KoltzdW7ddW93+3YLx92bU5lCSZ2XlaXNm7r8UV00MmtpL0x9XP7zCz2rnPzD5f0gMkfU7ScePoEmdt8zqgXZs/mdmXSnqLFontUzac2Eq7NYdv1/Jz3WHNt5uD+yXnFgBA3q7lc+TE5MTkxLsxf+TE5MQAsEt2LZ8jJyYnJifejfkjJyYnxlS5OzduG7tpsbTOJ7U4Od4/ePx0SVdrUXfogmibM7T4sDqzh1jnVI9/QIur1A4fP0vSP2ux9NhZBcdxbhXntczh8XMo6Tu0+HD8J0n/do1z9T+qsT41evwF1eMvDx47pZqjr1olzqZfmxOevy/X4svmgaQnrnOexjKHmWNwSR/e9Fxy48aN25huHT/ryIl3fA5FTry21+aE54+ceMU5zBwDOTE3bty49Xzr+FlHTrzjcyhy4rW9Nic8f+TEK85h5hjIiblt9W3jA+DGTdJ/0OIqz89KeqWkX5T03uoE+t8lWdT/wqrt4lVjVdv8ctX+j5JeKOllWiRdLulHCo/hXG0oud21OdSi3tbnqrbLJT132W2gefoqSZ+o9n2FpP+mxZWPrsUyUHcN+p5VPX7dKnE2/dqc6vxJ+lDVdk3qNaY1fznYtTnMHAPJLTdu3LgNcOvwWXehyIl3dg5FTkxOTE68E3OYOQZyYm7cuHEb4Nbhs+5CkRPv7ByKnJicmJx4J+YwcwzkxNy2+rbxAXDj5u7SYlmeN0r6lBaJz99I+jFJe0v6XqhEYtY2VrDNEyT9haSbJH1Gi6WRHtFi/Odqg8ntLs1hMFfZ24Dz9GWSXiPpY5Juk/S/JL1I0hdG/ZKJRZs4m35tTnX+Sl5jks5lDo9/DSbmluSWGzdu3Aa4tfysu1DkxDs7hyInJidew/yVvMZETkxOzI0bN25bdmv5WXehyIl3dg5FTkxOvIb5K3mNiZyYnJjbKG/m7gIAAAAAAAAAAAAAANh1s00PAAAAAAAAAAAAAAAAoA9cBAEAAAAAAAAAAAAAAEaBiyAAAAAAAAAAAAAAAMAocBEEAAAAAAAAAAAAAAAYBS6CAAAAAAAAAAAAAAAAo8BFEAAAAAAAAAAAAAAAYBS4CAIAAAAAAAAAAAAAAIwCF0EAAAAAAAAAAAAAAIBR4CIIAAAAAAAAAAAAAAAwClwEAQAAAAAAAAAAAAAARoGLIAAAAAAAAAAAAAAAwChwEQQAAAAAAAAAAAAAABgFLoIAgJ6Z2VVm9jdmNsg51hbeZWZvGyI+AAAAsCpyYgAAAEwdOTEAbA4XQQBAj8zsfEkPkvQcd58PsQ93d0nPkfSt1f4AAACArUFODAAAgKkjJwaAzbLFORIAsCozM0l/J8kkne0Dn2DN7D2S9taxLwAAAKAEOTEAAACmjpwYADaPlSAAoD/fLuneki5ZU7J5iaR7SXrwGvYFAAAAlCAnBgAAwNSREwPAhnERBIDJM7PrzMwzt4sLQ31f9fOyJfu4sIp1oZk9xMzeZmafNbNPmtlrzOwuVb9/a2ZvMLNPVe3/j5mdldjfpdF+AQAAgE7IiQEAADB15MQAMB4nNj0AANgCF0m6y5LHHynpvpJuPi5AtcTZeZI+7u7XZro+StIjJL1B0sslnSPpQkn3NLNnSHqzpLdJepWkr6/G8FVm9vVx7Th3/19m9hFJ325mxlJnAAAAWMFFIicGAADAtF0kcmIAGAUuggAwee5+UfyYmT1E0jMlfUDSTxeEubeku2mRtOY8StKD3f0t1X5mkv6HFkukvVHSD7j764JxvErSk7RIcn9vSby/kPQfJP1rSe8pGCcAAADQQE4MAACAqSMnBoDxoBwGAETM7N9IulzSjZIe7u7/VLDZl1c/P3ZMv98+TGwlqbpq9zeru38bJraV36h+3icR7+PR/gEAAICVkRMDAABg6siJAWB3sRIEAATM7ExJfyDpNEmPcPe/L9z0rtXPTx3T75olj320+vnOJW0fqX5+aSLeDdXPLzpmvwAAAEARcmIAAABMHTkxAOw2LoIAgIqZ3UmLZcq+TNLj3f1tLTb/XPXz9GP63bjksf2CtlMS8e4Q7R8AAADojJwYAAAAU0dODAC7j4sgAEC311z7bUn3lfRMd//tliGur37eNdurf4f7uz7bCwAAADgGOTEAAACmjpwYAMZhtukBAMCWuEjSIyW92t3/a4ft/z9JB5LO7nNQBc6WNJf0N2veLwAAAMbnIpETAwAAYNouEjkxAOw8LoIAMHlm9jRJT5X0ZklP6RLD3W+U9C5J32Bmdzimey/M7DRJ95H0V+7+L+vYJwAAAMaJnBgAAABTR04MAONBOQwAk2Zmd5f0y5Jci6tkn2lmcbd3ufsVBeFeL+l+ks6T9Ac9DjPlXEmnVvsFAAAAOiEnBgAAwNSREwPAuHARBICpO11Hq+I8LdHnEklXFMR6laTnSvqPWk9y+wRJt1X7BQAAALoiJwYAAMDUkRMDwIiYu296DAAwGmb2a1oknWe5+8cH3M8XS7pO0m+5+/cPtR8AAACgLXJiAAAATB05MQBs1uz4LgCAFn5ai6tunznwfn5K0oGkZw+8HwAAAKAtcmIAAABMHTkxAGwQF0EAQI/c/ROSvkfSR81skHOsLYrRfUzS97r7x4bYBwAAANAVOTEAAACmjpwYADaLchgAAAAAAAAAAAAAAGAUWAkCAAAAAAAAAAAAAACMAhdBAAAAAAAAAAAAAACAUeAiCAAAAAAAAAAAAAAAMApcBAEAAAAAAAAAAAAAAEaBiyAAAAAAAAAAAAAAAMAocBEEAAAAAAAAAAAAAAAYBS6CAAAAAAAAAAAAAAAAo8BFEAAAAAAAAAAAAAAAYBS4CAIAAAAAAAAAAAAAAIwCF0EAAAAAAAAAAAAAAIBR4CIIAAAAAAAAAAAAAAAwClwEAQAAAAAAAAAAAAAARoGLIAAAAAAAAAAAAAAAwCj8/5mpWxwI9pvtAAAAAElFTkSuQmCC\n", + "text/plain": [ + "
" + ] + }, + "metadata": { + "image/png": { + "height": 277, + "width": 1056 + }, + "needs_background": "light" + }, + "output_type": "display_data" } ], "source": [ @@ -363,23 +454,26 @@ " \n", " dat['x_line'] = parse_lineout(os.path.join(tdir.name, 'x_lineout.dat'))\n", " dat['z_line'] = parse_lineout(os.path.join(tdir.name, 'z_lineout.dat'))\n", + " dat['xz_plane'] = parse_plane(os.path.join(tdir.name, 'x_z_Ex_Ez_By.dat'))\n", + "\n", " return dat\n", "\n", - "DAT = run_test(verbose=True) " + "DAT = run_test(verbose=True) \n", + "plot_plane(DAT['xz_plane'])" ] }, { "cell_type": "code", - "execution_count": 9, - "id": "norman-silence", + "execution_count": 11, + "id": "cross-macintosh", "metadata": {}, "outputs": [ { "name": "stdout", "output_type": "stream", "text": [ - "CPU times: user 20.7 ms, sys: 23.1 ms, total: 43.8 ms\n", - "Wall time: 2min\n" + "CPU times: user 535 ms, sys: 33.4 ms, total: 569 ms\n", + "Wall time: 2min 1s\n" ] } ], @@ -395,8 +489,8 @@ }, { "cell_type": "code", - "execution_count": 10, - "id": "surface-cooperation", + "execution_count": 12, + "id": "unnecessary-newark", "metadata": {}, "outputs": [], "source": [ @@ -407,17 +501,17 @@ }, { "cell_type": "code", - "execution_count": 11, - "id": "first-service", + "execution_count": 13, + "id": "sorted-politics", "metadata": {}, "outputs": [ { "data": { "text/plain": [ - "" + "" ] }, - "execution_count": 11, + "execution_count": 13, "metadata": {}, "output_type": "execute_result" }, @@ -465,17 +559,17 @@ }, { "cell_type": "code", - "execution_count": 12, - "id": "tough-howard", + "execution_count": 14, + "id": "extended-collaboration", "metadata": {}, "outputs": [ { "data": { "text/plain": [ - "" + "" ] }, - "execution_count": 12, + "execution_count": 14, "metadata": {}, "output_type": "execute_result" }, @@ -522,7 +616,7 @@ }, { "cell_type": "markdown", - "id": "systematic-emperor", + "id": "systematic-lincoln", "metadata": {}, "source": [ "# Cathode images\n", @@ -532,8 +626,8 @@ }, { "cell_type": "code", - "execution_count": 13, - "id": "allied-afghanistan", + "execution_count": 15, + "id": "female-institute", "metadata": {}, "outputs": [], "source": [ @@ -547,7 +641,7 @@ " NZLO=1 ,\n", " NZHI=64 ,\n", " N_PARTICLE=10000000 ,\n", - " E_TOT= 0.51099891e6 ,\n", + " E_TOT= 1e6 ,\n", " BUNCH_CHARGE= 1e-9,\n", " DISTTYPE = 0, \n", " SIGMA_X= {sigma_x},\n", @@ -573,16 +667,16 @@ }, { "cell_type": "code", - "execution_count": 14, - "id": "statistical-allocation", + "execution_count": 16, + "id": "strong-ribbon", "metadata": {}, "outputs": [ { "name": "stdout", "output_type": "stream", "text": [ - "CPU times: user 11.9 ms, sys: 16.3 ms, total: 28.2 ms\n", - "Wall time: 37.8 s\n" + "CPU times: user 127 ms, sys: 23.7 ms, total: 150 ms\n", + "Wall time: 36.5 s\n" ] } ], @@ -598,17 +692,17 @@ }, { "cell_type": "code", - "execution_count": 15, - "id": "banned-jacket", + "execution_count": 17, + "id": "matched-haven", "metadata": {}, "outputs": [ { "name": "stdout", "output_type": "stream", "text": [ - "14.140 s for convolution/correlation \n", - "14.210 s for shifted Green function \n", - "9.461 s for Chris' shifted Green function \n" + "13.635 s for convolution/correlation \n", + "13.893 s for shifted Green function \n", + "8.793 s for Chris' shifted Green function \n" ] } ], @@ -620,23 +714,23 @@ }, { "cell_type": "code", - "execution_count": 16, - "id": "growing-bullet", + "execution_count": 18, + "id": "separated-passion", "metadata": {}, "outputs": [ { "data": { "text/plain": [ - "" + "" ] }, - "execution_count": 16, + "execution_count": 18, "metadata": {}, "output_type": "execute_result" }, { "data": { - "image/png": "iVBORw0KGgoAAAANSUhEUgAABAMAAAJ8CAYAAACLGmgAAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAADAnElEQVR4nOzdeXxU1f3/8deZLCSEPcCwSkwwIqayahSQICiK1hUardaC1FRrKa3fVkFLJdQNbN2QujQtoHVBREQFUZFCxKBBQPSHSMMWlG3YlSUxmcz5/XGTIUMmIXtC8n4+HvOY5J5z7z0zE0Lu557z+RhrLSIiIiIiIiLSeLjqegAiIiIiIiIiUrsUDBARERERERFpZBQMEBEREREREWlkFAwQERERERERaWQUDBARERERERFpZBQMEBEREREREWlkFAwQERERERERaWQUDBARERERERFpZBQMEBEREREREWlkFAwQERERERERaWQUDBARERERERFpZBQMEBEREREREWlkQut6AFJzjDHbgBZAdh0PRURERERERKpfDPCDtfbMiu6oYEDD1iIyMrLNOeec06auByIiIiIiIiLV65tvviEnJ6dS+yoY0LBln3POOW3WrFlT1+MQERERERGRatavXz/Wrl2bXZl9lTNAREREREREpJFRMEBERERERESkkVEwQERERERERKSRUTBAREREREREpJFRMEBERERERESkkVEwQERERERERKSRUTBAREREREREpJEJresBSP3g8/k4ePAgR44c4ccff8RaW9dDEhFpdIwxNGnShObNm9OmTRtcLsXsRUREpGYoGCD4fD6+++47jh8/XtdDERFp1Ky15Obmkpuby7Fjx+jatasCAiIiIlIjFAwQDh48yPHjxwkNDaVDhw5ERUXpj08RkTrg8/k4duwYe/bs4fjx4xw8eJC2bdvW9bBERESkAdIVn3DkyBEAOnToQPPmzRUIEBGpIy6Xi+bNm9OhQwfgxO9nERERkeqmqz7hxx9/BCAqKqqORyIiInDi93HR72cRERGR6qZggPiTBWpGgIhI/WCMAVAyVxEREakxuvoTERGpZ4qCASIiIiI1RcEAERERERERkUZGwQARERERERGRRkbBAJFGyhjDkCFDavw8MTExxMTE1Ph5Gqvs7GyMMYwZM6ZGzzN79myMMcyePbtGzyMiIiJSZzYuAp8PgCzPEWZlbOOZpZuYlbGNLE9hhR+fz+nXACgYICJVMmTIkHq/vvmNN97AGMP8+fPreij11vLlyzHGkJqaWtdDEREREal9yx6FOTfjeSWFG5/PYPiTHzPl3Q08viSLKe9uYPiTH3Pj8xl4XkmBOTc7/U9zoXU9ABFp2JYuXVrXQ+Ctt94iMjKSyy+/vK6Hctq6/vrrufDCC+nYsWNdD0VERESkem1cBOlTAXBvmcdI7z5WkYItdu/c4GPkjmm4Q9OdDelToeN50OOquhhxtVAwQGpVlucIGZv3czTXS7OIUAZ2b0u8u3ldD0tqUFxcXJ2ePy8vj0WLFjF8+HB/7XapuJYtW9KyZcu6HoaIiIhI9YsfgSduFO4t8wBIDk0n3/hIjUzEhB3C5rcmNSeT5JAV/l08caNwx4+oqxFXCy0TkFqRsXk/yS98GnS6TfILn5KxeX9dD9Fv1apV3HjjjXTu3JkmTZrQsWNHhg8fzty5cwP6zZ07l8GDB9OyZUsiIyP5yU9+wqOPPsqPP/5Y4phF6+aPHz/OPffcwxlnnEGTJk3o3r0706ZNC6gl/umnn2KM4YYbbih1jOeccw5NmjTh4MGD/m0+n4/nn3+e888/n2bNmhEVFcX555/Pc889h69w7dOpjBkzBmMM2dnZJdpOnkZetFY9Pd2Jjhpj/I/iuQhKyxnw448/MnXqVM477zyaNm1KixYtuPjii0u8z8XPNWbMGLKzs7npppto27YtERER9O/fn4ULF5b6mpYuXcoPP/zA9ddfH7D9+PHjTJs2jf79+9O8eXOaNWvGOeecw/jx4/F4PAF9d+/ezW9/+1tiYmIIDw+nXbt23HDDDaxZs6bE+YqvrX///fcZMmQILVu29C+lOFU7gNfr5dlnn+XCCy+kRYsWNG3alD59+jBjxoxyf5ZZWVlMnDiR/v37065dO5o0aUK3bt349a9/zY4dOwL6jhkzhksuuQSAKVOmBHyWy5cvLzHuk61Zs4aRI0fSvn17/3nuuusudu/eXaJv8Z+xF154gZ/85CdERETgdrv59a9/zffff1+u1yciIiJSbVwuxh8by1xvEgDrw8NJi9lKROe5NGm/hIjOc0mL2cr68HAA5nqT+P2xseA6vS+nNTNAatzrn3/LffP/Hz4bvH3VtoPc+u9Mpt5wHsnnd63dwZ0kLS2N3/zmN4SEhHDNNddw1llnsXfvXlavXs2zzz5LcnIyAPfffz+PPvoobdu25eabb6ZZs2YsXryY+++/nw8++IAlS5YQFhYWcOz8/HyGDx/Orl27GDFiBKGhoSxYsICJEyeSm5vL5MmTAbjooos4++yzWbhwIQcOHCA6OjrgOKtWrWLjxo2MHDmSNm3a+LffeuutvPrqq3Tt2pXbb78dYwxvvfUWd911F5988gmvvPJKtb5XrVq1YvLkycyePZvt27f7xw+cMmFgXl4el19+Oenp6fTo0YPf/va3HD9+nHnz5nHjjTeybt06HnnkkRL7bd++nQsuuIDY2FhuvfVWDh48yOuvv861117LRx995L+gLe6tt94iNDSUq6++2r/t0KFDXHLJJXz55ZecffbZjB07lvDwcLZs2cLMmTO54YYbcLvdAGzbto1Bgwaxa9cuhg4dys9//nO+++473njjDRYtWsSbb77JT3/60xLnnTdvHu+//z4jRozgzjvvLBFgKa09Pz+fq6++mg8++ICzzz6bm2++mYiICJYtW8bvfvc7MjMz+c9//lPm+wswf/58nn/+eS655BIGDBhAeHg4X3/9Nf/617949913Wb16NZ07dwbguuuuA+DFF18kKSmpRDCnLAsXLmTkyJFYaxk1ahTdunVjzZo1PPfcc7z99ttkZGQEPca9997LBx98wNVXX83w4cNZtmwZaWlpbN68mf/+97+nfH0iIiIiZdq4COJHgMtV+uxknw+yFpPVejCZ2YdZRQr5xkeaeysHQkMCDncgNIRx7nakZMcyyZuCzT5MlufI6T3L2VqrRwN9AGv69u1rT2XDhg12w4YNp+xXGZ9s2mfPnLjQdptw6seZExfaTzbtq5FxlMfXX39tQ0NDbevWre369etLtH/33XfWWmtXrlxpAdu1a1e7e/duf3t+fr796U9/agH78MMPB+zbrVs3C9gRI0bY48eP+7d7PB7bsmVL27JlS5uXl+ff/sgjj1jAPvPMMyXGcdddd1nAvvPOO/5tr776qgVsnz597JEjR/zbjx49avv162cB+8orrwQcB7BJSUkB20aPHm0Bu23bthLnXbZsmQXs5MmTA7YnJSVZ51dJcN26dbPdunUL2Fb0+kaMGGHz8/P92z0ej/+9ysjI8G/ftm2bBSxgU1NTA471/vvv+491soKCAut2u+2wYcMCtv/85z+3gL3zzjttQUFBQNsPP/xgDx8+7P9++PDhFrAPPfRQQL+MjAwbEhJi27RpE/Cez5o1ywLWGGMXL15cYkynap88ebIF7Lhx46zX6/Vv93q9duzYsRawCxYsKPHejB49OuA4O3bssLm5uSWO/8EHH1iXy2XvvPPOgO2lfb4nj3vWrFn+bUeOHLHR0dHW5XLZjz/+OKD/1KlTLWAvu+yygO1FP2Ndu3a127dv92/Pz8+3F198sQVsZmZm0DE0NjX5u1lERKRB++8j1k5uYfe8NNYmP/dJ0GuP5Oc+sXteGmvt5BZ27Yv3+Ld3f/ivNmF2QqmP7g//1d935idb6/qV2r59+1pgja3E9eLpPa9B6r2nl24qdUbAyXwWpi/dVLMDKsNzzz2H1+vlL3/5C+eee26J9i5dugAwc+ZMACZNmkSHDh387aGhoTz++OO4XC7+9a9/BT3H9OnTiYyM9H/fvn17rr32Wr7//nv+97//+bffeuutuFwuXnzxxYD98/LymDNnDu3bt2fEiBNrlIrGNHXqVJo1a+bfHhUVxbRp0wBKHVNdmDlzJsYYnnjiCUJDT0xQat++PX/5y1+A4OPt1q0bkyZNCth2+eWXc8YZZ7Bq1aoS/VeuXInH4wlYIrB3715ef/11OnbsyN///ndcJ03vat68uX9t/I4dO/jwww8544wzuPfeewP6DRgwgJ///OccPHgwaJWCa6+9liuuuKLU9yBYu8/nY8aMGXTo0IEnn3ySkJATEemQkBAef/xxjDHlmuVRtMzlZMOHD+fcc8/lgw8+OOUxTuXtt9/mwIED3HjjjVx88cUBbX/84x+JiYlhyZIlfPvttyX2feCBBzjjjDP834eGhnLbbbcBBP0sRURERMrl5GSAO6ZhCFxm6U8GWJgjoM/WF7jMtdppCztU5uGLtx/N9VbnyGudlglIjcnyHGHVtoOn7lhM5raDdTbd5rPPPgMIuMgOZu3atQAMHTq0RFt8fDxdunRh27ZtHD58mFatWvnbWrZsSffu3Uvs07WrszTi0KETv1i6dOnCsGHDWLJkCRs2bKBnz54AvPvuuxw8eJC777474CJ67dq1uFyugOndRZKSkggJCeGLL74o83XVliNHjrB582Y6d+5Mjx49SrQXva/Bxtu7d++AC+QiXbt25dNPPy2xff78+Rhj/NPgAT7//HN8Ph+DBw8+ZULBojFcfPHFJZZ9FI315Zdf5osvvuCXv/xlQNsFF1xQ5rGDtWdlZXHgwAHOOussHnrooaD7RUZG8s0335R5bHBmfb3yyivMnj2bL7/8kkOHDlFQUOBvDy9c81YVZf1bCA0NZfDgwWRnZ/PFF18EXPgD9O/fv8Q+wf4tiIiIiFRIJZIBrmlzFR/t6guAzW9d5uGLtzeLOL0vp0/v0Uu9VtmkgBmb99dJMODw4cMA/nXUpSlKcFZaibWOHTvy7bff8v333wcEA4p/XVzRRX3xCzVwEq0tWbKEF1980X93v2imwOjRo0uMqU2bNkEv8EJDQ2nbti179+4t83XVlvK8f3Di8yiurPcwWGK9BQsWcMEFFwR8puX9nKs61uKzRoIJ1n7gwAEANm3axJQpU0rd9+jRo2UeG+D//u//eOqpp+jYsSOXX345nTt39s9KKcrzUFXV/VmW9m9BREREpNwKkwGO9O4jOTTdSQbo3kpE6Im/fdK8BfTyhJOQl8dcbxIvcweWoxh8pOZkkuYtKJEzACDaW0BKTiaT6I3FxcDubWvzlVU7BQOkxlR22kxdTbcpujjZuXNn0DvWRYqmkO/Zsydo2byiDOpVLcN2/fXX06JFC15++WUeeeQRDh48yOLFi+nVqxe9evUqMaaDBw+Sn59f4g621+tl//79tGjR4pTnLJoy7/WW/AyCXdBVRvH3L5jqev/WrVvHtm3buOOOOwK2F/+cT6UqYy1eHSCYYO1Fx7n++uuDLj0or7179zJ9+nQSEhJYuXIlzZsHBtdee+21Sh+7uNr6LEVERETKK8tzpOLJAHcd5bxOzfnF3r+THLKCXp5wxrnbBewX7S1ghmcfCSE7CbMu5neZcHonD0SlBaUGVXbaTF1Nt7nwwgsBWLx4cZn9+vTpA+AvuVbc5s2b2bFjB2eeeWapd7HLKzIykuTkZHbt2sVHH33EK6+8gtfrLTEroGhMPp+Pjz/+uETbxx9/TEFBAX379j3lOVu3dqY9fffddyXaVq9eHXSfomn75b2b27x5c+Li4ti5cyebNpXMEbFs2TKAco23LG+99RZAiZKCF1xwAS6Xi48//phjx46VeYyiz/qTTz4JGiCprrEW6dGjB61ateKzzz4jPz+/0sfZunUrPp+P4cOHlwgE7Nixg61bt5bYp6KfI5T9b8Hr9fLJJ58A1ff+iIiISCO1cZGT+R/nYn9WxjaeWbqJWRnbyPIccfr4fLBxkX92ssVFamRi0Dv84AQEUiMTsbgw+JjMcySHOiWzE/LySMmOJXdnMj/uvYzcncmkZMeSkJcHOEsPno6a6R/T6UrBAKkxlZ02U1fTbX7zm98QGhrKgw8+yIYNG0q0F9VmHzt2LAAPPfQQ+/bt87cXFBTwpz/9CZ/Px69+9atqGdOYMWMAeOmll3jppZcIDQ3llltuKdGvaEz33Xcfx48f928/fvw4EydOBCjXmIrWsaelpQVs/3//7//x9NNPB92nqPRhsCRxpRk7dizWWu65556Ai8/9+/fz4IMP+vtUxfz58+nZsyfx8fEB29u1a8dNN93E7t27/Z9XcUePHvVPf+/SpQuXXXYZ2dnZPPXUUwH9MjMzefXVV2ndunWJgENlhYaG8rvf/Y7du3czfvx4cnJySvTZvXt30J/P4opK+X3yyScB7+/Ro0dJSUkJGtiozOd43XXX0aZNG1577TV/zo0iTz31FFu3buXSSy8tkS9AREREpNyWPQpzbsbzSgo3Pp/B8Cc/Zsq7G3h8SRZT3t3A8Cc/5sbnM/C8kgJzbqbn//7h37W8yQAvda2l38H3/NvnepOYlH8H+T/0Je/AMPJ/6Muk/DuY603y93FvmQdZZd9ErO+0TKASjDHZQLdSmj3W2rIXCwceqwvwV+AKIBrYDSwAplhrT+ssWvHu5lxwZpsKJRFMPLNNnU236dmzJ88++yx33nknffr04dprr+Wss87iwIEDrF69mubNm7Ns2TIGDBjAvffey2OPPUZCQgKjRo0iKiqKxYsXs379egYNGsQ999xTLWMaOHAg3bt354033vDXn2/fvn2JfjfffDNvv/02c+fO5dxzz+W6667DGMOCBQvYtm0bycnJQYMIJyt6za+99ho7duwgMTGRb7/9lrfffptrr72WuXPnlthn2LBhvPHGG9xwww1ceeWVREZG0q1bN2699dZSz/OnP/2JxYsX8/bbb9OrVy+uvPJKjh8/zhtvvMHevXu59957GTRoUMXerGI2b97M+vXrS1QeKDJjxgzWr1/P888/z/Lly7n88ssJDw9n27ZtfPDBB7zzzjv+ZIzPP/88AwcO5J577uHDDz+kf//+fPfdd7zxxhu4XC5mzZpV4u57VfzlL3/hyy+/5Pnnn+fdd99l6NChdO7cmb1797Jp0yYyMjJ4+OGH/Uklg+nQoQM33XQTc+bMoXfv3gwfPpzvv/+eJUuWEBERQe/evVm3bl3APmeffTadO3dmzpw5hIeHc8YZZ2CM4dZbb6Vbt+C/7po1a8bMmTP52c9+RlJSEj/72c8444wzWLNmDR9++CEdOnTghRdeqLb3RkRERBqZkysDePexihSKF8XzVwYovKuf+G0al7mas8TXv9zJAJf4+vNF7B302foCnrhRzD82Fpt9OLAvztKApKh2TiAgaSL0uKoaX2ztUzCg8r4Hngqy/dSZvQoZY+KAlUB74G1gI3AB8HvgCmPMQGvtgaoPte78fthZ3PrvzHKVF3QZGD/srJofVBlSUlJISEjg73//O8uXL2fBggW0bduW8847j9tvv93fb9q0afTp04cZM2bw0ksvkZ+fT1xcHA899BB//OMfqyVTe5HRo0f7y+0FWyJQ5LXXXiMpKYmZM2f6L8DOOecc/vjHP/Kb3/ymXOeKiIhg6dKl/OlPf2LJkiV8/vnnJCQk8Oqrr9KmTZugwYDbb7+d7du3M2fOHB577DG8Xi9JSUllBgPCw8NZsmQJTzzxBK+++irPPPMMoaGh9OrVi6eeeoqf//zn5RpvaUpbIlCkdevWrFy5kqeeeorXX3+df/7zn4SEhNC1a1fGjh0bcKEdGxvL6tWreeihh3jvvfdYvnw5LVq04IorruDPf/4z559/fpXGerKwsDAWLFjAyy+/zOzZs1m4cCFHjx6lXbt2nHnmmTz44IPlCuz8+9//JjY2ltdff51//OMftGvXjmuuuYa//vWvjBw5skT/kJAQ3nrrLSZOnMjcuXM5cuQI1loGDRpUajAAnABSRkYGjzzyCB988AHff/89HTp04M477+Qvf/kLnTp1qtL7ISIiIo1YJSoDbO1yHR9t7lvhZIBRl/8FDiXhjh/BHJeLLM8RMjbv52iul2YRoQzs3ta5aem7CLJuOO0DAQDG2nIWgRe/wpkBWGtjqnicD4DhwHhr7TPFtj8B3A28YK29swrHX9O3b9++a9asKbNfUZmyc845p7KnKtPrn3/LffP/X5kBAZeBqTecR/L5XWtkDNK4DBgwgJ07d1ZLxnyRulLTv5tFREROBzc+n8HIHdP8lQFKTexXWBlgfpcJWKjwPnPuHFgHr67q+vXrx9q1a9daa/tVdF/NDKgjxphYnEBANvCPk5onA78GbjXG/NFaW3aWs3ruxvPPoEvrpkxfuonMIEsGEs9sw/hhZ532pTmkfti9ezefffYZ48ePr+uhiIiIiEgVVKYyANkHWdp9HrEnJQMsPpsgJSeThBCnslRyaDpJUe2cO/6uxpVST8GAymtijPkFcAZwDPgK+NhaW95U3EMLnz+01gZkMLPWHjHGZOAECy4EllbTmOvMwO5tGdi9benTbUSqSceOHUskBRQRERGRemLjIogfAWVOxfdB1mIyDjhLN4sqA0SEBp/16a8MkO/iMtdqYncs8LfN9SY55QPzT1zoT6I3Ydblrx7gJANsGFP/K0LBgMrrAPznpG3bjDG3WWvTy7H/2YXPWaW0b8IJBsRzimCAMaa0dQA9yjGOWhXvbq6LfxERERGRxmjZo5A+FU/cKMYfG0vmSUn6ABJjWjE9aibuLfPoeUYKcAlQ/soAS3z9yTwjhcRv0xpVMsDKUDCgcmYBK4CvgSNALDAOZ2r/YmPMRdbaL09xjJaFz9+X0l60vVXVhioiIiIiIlLHaqkyAMCGs39L4oBLGlUywMpQMKASrLVTTtq0HrjTGHMU+COQClS18LgpOl05xhM0WUThjIG+VRyHiIiIiIhI1dRiZYCB3duC+8QFfqmzk12uRhsIAAUDqtvzOMGAweXoW3Tnv2Up7S1O6iciIiIiInJ6crkYf2wsI737/Fn+09xbA/IApHkL6OUJP5Hl3/trLogprAwQsoJenjIqA4TsJMw60/+1LLl8FAyoXnsLn6PK0fd/hc/xpbSfVfhcWk4BERERERGR04IqA9Q/CgZUr4sKn7eWo++ywufhxhhX8YoCxpjmwEAgB/iseocoIiIiIiJSDVQZ4LSmYEAFGWPOBXZbaw+etL0bMKPw25eLbQ8D4oB8a+2Wou3W2i3GmA9xKgb8Fnim2OGm4MwueMFae6xGXoiIiIiIiEhlqTLAaU/BgIr7GTDRGLMM2IZTTSAOuAqIAN4D/l6sf2fgG2A7EHPSse4CVgLTjTHDCvsl4vwryQL+XGOvQkREREREpDJUGaBBUDCg4pYBZwN9cJYFRAGHgU+A/wD/sdaesgIA+GcH9Af+ClwBXAnsBqYDU06efSAiIiIiIlLnVBmgQVAwoIKstelAegX6Z3OiTGCw9u+A26o+MhERERERkVqgygANgoIBIiIiIiIiUm6qDNAw6F0VqYQhQ4ZgTKkTPoIyxjBkyJAS2/fs2cPo0aPp0qULISEhGGM4fPhw9Qy0nJYvX44xhtTU1Fo9b0Myffp0evbsSWRkJMYYnnrqqboeUqWMGTMGYwzZ2dl1PRQRERGpTRsXOZn/cS72Z2Vs45mlm5iVsY0szxGnj88HGxeRsXk/cKIyQLDp/lCsMgAuLnWtLVkZIP8O8n/oS96BYeT/0JdJ+Xcw15vk7+NUBlhcM69XNDNApK6NGTOGDz/8kJ///Od0794dYwwREREMGTKE9PR0ypmCos4sW7aM2bNn8+mnn7J7925+/PFH2rRpw7nnnstll13GL37xC7p06VLXw6xRc+bM4fe//z19+vThD3/4A02aNOHCCy+s62EFlZqaypQpU1i2bFnQ4JSIiIg0QqoM0CgpGCBSS7755huaNm0asC0vL48lS5Zw6aWX8sorr9TRyCrnhx9+YPTo0SxYsICwsDAGDx7MlVdeSVRUFPv27WPVqlXcd999TJ48mc8++4w+ffrU9ZBrzMKFC/3PnTp1quPRVM2jjz7KxIkT6dy5c10PRURERGqDKgM0WgoGSM3buAjiR5S91sfnc6YANeB/8D169Cixbc+ePfh8vtPuArKgoICRI0fy0UcfkZSUxH/+8x+6du1aot+GDRt44IEH+OGHH+pglLVn165dAKfd5xhMx44d6dixY10PQ0RERGqLKgM0WsoZIDVr2aMw52Z453f+NUgl+HxO+5ybnf516J133mHYsGF07NiRJk2a0KlTJ5KSknj22WeD9vd6vTzyyCOcddZZNGnShK5duzJhwgTy8vJK9D05Z0BMTAzdunUD4MUXX8QYgzHGv2Y7PT3dv1/R4+Rp3Tt27GDcuHHExsbSpEkToqOjueaaa/j888+Djtfj8fCrX/0Kt9tNZGQkvXv35sUXX6zw+/Tyyy/z0UcfcdZZZ7Fo0aKggQCAnj17Mm/ePAYOHBiwPSYmhpiYGH744Qf+7//+j5iYGMLCwgJyFmzcuJExY8bQtWtXmjRpgtvt5uabb+Z///tf0HMdP36cRx99lN69exMVFUWzZs246KKLeO2110r0LZ4jYd26dVx11VW0atWKpk2bkpSUxMqVK8v1PqSmpmKMYdmyZUDgZwWQnZ3t/0yDCZZ7orJjKygo4Pnnn2fgwIG0bNmSyMhIunfvzu23386mTZsA532fMmUKAJdcckmJ8ULZOQPmzp3L4MGD/cf/yU9+wqOPPsqPP/5Yom/RZ3z8+HHuuecezjjjDJo0aUL37t2ZNm1avV/+IiIi0mgUVgYoWqu/PjyctJitRHSeS5P2S4joPJe0mK2sDw8HnLX+93t/zQUxbZgWmsYtISuY4dlHtLcg4LBFlQFuCVnBtNA0LoxppcoA9YxmBkjNKTbliHUvO8/XPBM4Q6AoEFDUnj4VOp5XJ5HAf/7zn9xxxx106NCBq6++mrZt27J3716++uorZs2axV133VVin5tvvpkVK1YwYsQIWrRowXvvvcdjjz3G3r17mTVrVpnn+8Mf/kB2djZPP/00vXr14rrrrgOgd+/exMTEMHv2bLZv387kyZP9+8TExPi/Xrt2LcOHD+fgwYNcfvnl3HDDDezfv58FCxYwaNAg3nrrLa688kp//wMHDjBgwAC2bt3KoEGDGDRoELt37+bOO+9k+PDhFXqv/vWvfwFwzz33EBUVdcr+oaElf9Xk5eUxdOhQDh48yPDhw2nRogVnnnkmAO+//z433HAD+fn5XH311XTv3p0dO3Ywf/58Fi1axLJly+jbt6//WIcPH2bo0KF88cUX9O3bl7Fjx+Lz+fjggw+4+eab+frrr3nooYdKjGH16tU89thjXHTRRdx+++18++23vPnmmwwbNox169Zx9tlnl/m6ioIzwT6rqqrI2PLy8rjqqqv46KOP6Nq1KzfffDMtWrQgOzubt956i0GDBnHWWWfxhz/8gQULFpCens7o0aMDfp5O5f777+fRRx+lbdu23HzzzTRr1ozFixdz//3388EHH7BkyRLCwsIC9snPz2f48OHs2rWLESNGEBoayoIFC5g4cSK5ubnV+n6JiIhIMcVm5pY+Fd+ZmZvVerAqAzRW1lo9GugDWNO3b197Khs2bLAbNmw4Zb8KKyiw9q27rJ3c4sTjrbuc7eVpr2V9+/a14eHh1uPxlGjbt29fwPdJSUkWsH379rUHDhzwbz969KiNi4uzLpfL7t69O2AfwCYlJQVs27ZtmwXs6NGjS5yz6BzB5Ofn27i4ONukSRO7fPnygLadO3faTp062Q4dOtjc3Fz/9pSUFAvYP/zhDwH9P//8cxsaGmoBO3ny5KDnO/ncYWFhFrCbN28+Zf9gunXrZgE7bNgwe/To0YC2gwcP2latWtno6Gj79ddfB7StX7/eRkVF2T59+gRsHz16tAXstGnTArbn5OTYyy+/3Bpj7BdffOHfvmzZMgtYwM6aNStgn+eff94C9je/+U25X09pn1VZn29p+1VmbPfdd58F7NVXXx3wmVtrbW5urt27d6//+8mTJ1vALlu2LOiYit7Lbdu2+betXLnSArZr164BP9f5+fn2pz/9qQXsww8/HHCcos94xIgR9vjx4/7tHo/HtmzZ0rZs2dLm5eUFHYM4aux3s4iINGz/fcTayS3snpfG2uTnPrHdJiws8Uh+7hO756Wx1k5uYde+eI9/e/eH/2oTZieU+uj+8F9ttwkL7e33pQb8Df/6n6+2MRPeCThHzIR37Ot/vjrwb/1vFtb1u9Pg9O3b1wJrbCWuFxWWkZrjcjkzAXr/4sS2dS87MwEKvIEzAsDpd/LMgVoWGhpa4u4mQNu2bYP2nzZtGm3atPF/HxUVxS233ILP52P16tU1Ns5FixaxZcsWfve735GUlBTQ1qlTJ+6991727NnD0qVLAecO7SuvvELz5s1LlA/s378/t9xyS7nPffDgQfLz8wGCJplbvnw5qampAY8FCxYEPdbjjz9eYmbBSy+9xOHDh5kyZQo9e/YMaDv33HNJSUnhiy++YMOGDYAz4+Hll1+mf//+3HvvvQH9IyIi/FPSX3311RLnHzhwYIkp/GPHjiU0NJRVq1aV+T7UtPKOraCggGeffZbIyEief/55mjRpErBPkyZNaNeuXZXGMnPmTAAmTZpEhw4d/NtDQ0N5/PHHcblc/tkiJ5s+fTqRkZH+79u3b8+1117L999/X+qSDxEREamkk5MB7piGIXCprj8ZYGGOgD5bX+Ayl/N3a0UrAwBOZYAuEzj50rKoMoAnbpSzQZUB6h0tE5CaVRQQgBMX/uteDgwCQL0IBNxyyy388Y9/5Nxzz+XGG28kKSmJgQMHlnkh1b9//xLbitbPHzpU9i/Tqvj0008B2L59e4mLe8C/Rvybb77hyiuvZOPGjRw/fpyLL76Yli1blug/ZMiQcucOsLbstd7Lly/3r0svMnr0aP8yiCIRERGcd955JfYvem1ffvll0NeWlZUFOK+tZ8+efP755xQUFPjX2Z+sKHDxzTfflGgL9vmFhYXhdrtr9PMrj/KObePGjXz//fckJibWWALDtWvXAjB06NASbfHx8XTp0oVt27Zx+PBhWrVq5W9r2bIl3bt3L7FPbfwbERERaZQqkQxwTZur+GiXs/xSlQEaFwUDpOYFCwgUVw8CAQD/93//R9u2bXn22WeZPn06Tz31FMYYkpKS+Nvf/hb04qz4hU+RovXxBQUFJdqqy4EDBwB44403yux39OhRAL7//nsA3G530H7F7/aeSnR0NGFhYeTn57Nr1y5iY2MD2otmAwB89NFHXHbZZUGP0759+xLJ8+DEa0tLSytzHEWvraj/559/XmrixOL9iwv2+YHzGdbk51ce5R3b4cOHgeCzNKpL0c9PaVUGOnbsyLfffsv3338fMO6yXgPU7L8RERGRRqkwGeBI7z6SQ9OdZIDurUSEbvd3SfMW0MsTTkJeHnO9SbzMHViOqjJAI6RlAlI7XC64+ungbVc/XeeBgCK//OUv+eyzzzhw4ACLFi3iV7/6FR9//DGXX345e/furevh+RXd3X/77bfLXAdUlKCtqL/H4wl6vD179pT73KGhoSQmJgL4lyFURrBAAJwY65dfflnmaxs9enRA/7vvvrvM/kUZ/2uTq/Dn2uv1Bm0vupCviqIL7p07d1b5WKUpeo9L+znZvXt3QD8RERGpG1meI2RmH2aCN4VXCi5mnLtdqckAXym4mAneFL7adZTzOjVXZYBGqH5cgUnD5/PBu78P3vbu70svO1hHWrVqxZVXXklaWhpjxozh4MGDrFix4tQ7VqOQEOcXd7C7pxdeeCFAucfUo0cPmjZtyrp16/x3eYtbvnx5hcZ2++23A86a/+PHj1do31Op6Gu74IILcLlctf75lEfr1s5Uuu+++65E2w8//OBf8lAVPXr0oFWrVnz11Vfs2rXrlP3L+rkqTZ8+fYDgPyebN29mx44dnHnmmaXOBBAREZEq2LjI/7dylucIszK28czSTczK2EaW54jTx+eDjYvI2LwfcNbrp0YmBr3DD05AIDUyEYsLg4/JPEfySZUBcncm8+Pey8jdmUxKdiwJhaWzk0PTeTpqZr37+10qTsEAqXknlw88WVFSwTr+hfL+++8HvYNbNCOgadOmtTqe6OhoAL799tsSbddeey1xcXH84x//4L333gu6/6effuq/UA8LC+OWW27hyJEjJdbVr169mldeeaVCY/vFL37BsGHD+N///sfVV1/Njh07gvarzJ3v2267jVatWjFlypSgSfx8Pl/ARWn79u255ZZbWL16NQ8++GDQz3DLli1s27atwmOpqubNm9OjRw8yMjL8CQ/BuRD/v//7P3Jycqp8jpCQEO666y5ycnK48847+fHHHwPa8/Ly2Ldvn//7sn6uSjN27FgAHnrooYBjFRQU8Kc//Qmfz8evfvWrqrwMERERCWbZozDnZjyvpHDj8xkMf/Jjpry7gceXZDHl3Q0Mf/Jjbnw+A88rKTDnZnr+7x/+XcubDPBS11r6HTzx9+RcbxKT8u8g/4e+5B0YRv4PfZmUfwdzvSeSVru3zIOsxdX8YqW2KWeA1KxggYDev3CWBrz7+8CkglCnuQNuuukmIiIiGDRoEDExMVhrWbFiBZ9//jn9+vXj0ksvrdXxDBs2jDfeeIMbbriBK6+8ksjISLp168att95KWFgY8+fP5/LLL+eqq65iwIAB9O7dm6ZNm/Ldd9/x+eefs3XrVnbv3u0PYjzyyCMsXbqUp556itWrVzNo0CB2797N66+/zpVXXsk777xT7rGFhIQwf/58fvnLX/L2228TGxtLUlISCQkJNG3alH379vH111+zcuVKwsPD/csKyiM6Opp58+Zx/fXXc+GFFzJs2DDOPfdcXC4X3377LZ9++ikHDhwgNzfXv8+MGTPYtGkTDzzwAP/5z38YNGgQbrebXbt28c033/D555/z2muvceaZZ5b/A6gm99xzD7/61a8YOHAgP/vZz4iIiGDZsmXk5+fTq1cvvvzyyyqfY/LkyWRmZvLuu+8SHx/PT3/6U5o3b853333Hhx9+yN/+9jd/ZYJLLrkEl8vFfffdx/r16/2zFyZNmlTq8QcMGMC9997LY489RkJCAqNGjSIqKorFixezfv16Bg0axD333FPl1yEiIiLFnFwZwLuPVaQEZO33VwYovKuf+G0al7mas8TXv9zJAJf4+vNF7B302fqCUxng2Fhs9uHAvoWVAZKi2jmBAFUGaBAUDJCaU1ogoOiCP1iVAaizgMDUqVP54IMPWLt2Le+99x4RERF069aNadOm8Zvf/CZoycGadPvtt7N9+3bmzJnDY489htfrJSkpiVtvvRWA8847jy+//JInnniChQsXMmvWLFwuFx07dqRPnz5MmTIloCRi27ZtycjI4P777+fdd99l9erVnH322Tz33HPExMRUKBgA0KJFCxYsWMDSpUt58cUXWblyJStXriQ/P5/WrVtz7rnn8vDDD/PLX/6SLl26VOjYw4YN46uvvuLvf/87H3zwAStWrCA8PJxOnToxdOhQRo4cWWIs6enp/POf/+TVV1/lzTffJDc3F7fbzVlnncWTTz5ZaiLDmjZ27FistTzxxBO8+OKLtG7dmmuvvZZHHnmkxOuorPDwcN5//32ef/55XnrpJV588UWstXTq1Inrr7+eQYMG+fuec845vPjii/z973/n2Wef9QdVygoGgFNGs0+fPsyYMYOXXnqJ/Px84uLieOihh/jjH/9IeHh4tbwWERERKVSJygBbu1zHR5v7VjgZYNTlf4FDSaoM0MiYU5UJk9OXMWZN3759+65Zs6bMfkUl184555zqHcDGRTDn5hPfB6saECxgcNOr+gUjIo1ejf1uFhGR08aNz2cwcsc0f2WAkxMCFiX2K6oMML/LBCxUeJ85dw6sg1cn1aFfv36sXbt2rbW2X0X31cwAqTk9rnKmEKVPLb184MkzBDTlSEREREQaoo2LIH4ElHnn3eesxe9xlb8ywCpSyDc+0txbS60MkJIdyyRvCmQfZGn3ecSelAyw+GyClJxMEkKcKkTJoekkRbVz7vjXk+peUnsUDJCadcl90PE8/y++oIoCAj2uVCBARERERBqeZY9C+lQ8caMYf2wsmSetyQdIjGnF9KiZ/jX5GeE3AScqA0SEbg96aH9lgHwXl7lWE7tjgb9trjeJSd4UbP6Jv8Mn0Zsw6/JXD3CSAWrqf2Ok8I/UvB5XnTrS6HLpF5CIiIiINDwnJwLcMQ1DYBUtfyLAwvwApE+l3c6PTrSXszLAEl9/Ms9IAXCSAXaZEJBwEE4kA/TEjXI2aGZuo6WZASIiIiIiIjWlEokAPXGj2NdpKKzdCFDuygAAG87+LYkDLlEyQDklBQNERERERERqisvF+GNjGend50/ql+beGjDtP81bQC9P+ImkfsfG8tez2gMbK1wZYGD3tuA+cYEf727uXPwHGZcCAY2bggEiIiIiIiI1pDKJAG1hToHEmFZOZYCQFfTylFEZIGQnYdaZ/h/0wl8kCAUDREREREREakjG5v1AxRIBAmRs2uskFFRlAKkhCgaIiIiIiIhURAXKBB7NjffvVt5EgADtdv33REJBVBlAqp+CASIiIiIiIuVVwTKBg2Lv4HGSgIolAtzX+VJoN9F/rvnHxvqXD/j7F1YGSIpq5y9JqECAlJeCASIiIiIiIuVxcplA7z5WkRJQvs9fJrDwbn2frS9wmSuKj3x9K5EI8D7oeJ4qA0iNUDBARERERESkPCpZJvDI0aFM2/m3yiUC7KHKAFIzFAwQEREREREpj0qUCXzr6BiebjZbiQCl3lEwQEREREREpBwqUybw0u/+iztciQCl/lGoSaSKsrOzMcYwZsyYaj2uMYYhQ4ZU6zGrQ0XHtXz5cowxpKamlmhbvXo1l112GW3btsUYQ+/evattnOWVmpqKMYbly5fX+rkbgh9++IHx48cTExNDaGgoxhjWrVtX18OqlJiYGGJiYup6GCIiUts2LnIy/+Nc7M/K2MYzSzcxK2MbWZ4jTh+fDzYuKlEmMNjafyhWJhAXS3z9+SL2DsBZMjC/y4SAHANFx5vfZQKeuFHOBiUClFqgmQEiQWzcuJF//OMfLFu2jO+++46cnBzatm1Lnz59uOGGG7jllluIiIio62GWKjs7mzPPPJPJkycHvQivD3744QeuuuoqcnNzufXWW2nbti0dOnQAnIBDUlJSvb5Az8/P57XXXmP+/PmsWbOG/fv3Y4zB7XbTu3dvrrrqKn7+858TFRVV10OtUffeey8vvPACP/3pT7n11lsJCQnxf471zZAhQ0hPT8daW9dDERGR+qKClQF6npECXAJUrEzgJ51T6HNBkhIBSr2iYIDISf76178yZcoUfD4fF154IaNHj6ZZs2Z4PB6WL1/O7bffznPPPcfq1atrdBzffPMNTZs2rdFz1IYLLriAb775hrZt2wZsX7VqFXv37uXhhx/m/vvvr6PRVc7GjRsZOXIkGzZsoFWrVgwdOpQzzzyT0NBQdu7cyccff8yCBQu477772LdvX10Pt0YtXLiQ+Ph43n333boeSpUtXbq0rocgIiK1qRKVARK/TeMyV3OW+PpXqExgs4hQJQKUekfBAJFiHnnkESZPnkzXrl154403SExMLNFn4cKFPP744zU+lh49etT4OWpD06ZNg76WXbt2AdCpU6faHlKV7N69m2HDhrFr1y5+97vf8cgjj9CsWbMS/ZYsWcI999xTByOsXbt27WLw4MF1PYxqERcXV9dDEBGR2lSJygBbu1zHR5v7YvBVvEygSD2jnAEihbKzs0lNTSUsLIz33nsvaCAA4Kc//Snvv/9+qce46aabaNu2LREREfTv35+FCxeW6Dd79myMMcyePZv333+fIUOG0LJlS4wx/j7B1uYfOXKEBx98kISEBFq0aEHz5s2Ji4vjxhtvZM2aNZV+7Xl5eUyfPp2+ffvSunVrmjZtSkxMDNdeey0fffRR0H3279/Pr3/9azp27EiTJk0499xzmTVrVol+J+cMKMqxMHr0aABuu+02jDH+96PoPUhPT/dvD5ZzIDMzk1GjRtGhQwfCw8Pp2rUrd9xxhz/IcLI1a9ZwxRVX0Lx5c1q0aMGll17Kp59+WuH36v7772fXrl3cfPPNTJ8+PWggAOCyyy4rMXukeH6JrKwsbrzxRtq3b4/L5QpYEvHBBx9w5ZVX0rZtW5o0aUJcXBz33HMPhw8fDnquHTt2MG7cOGJjY2nSpAnR0dFcc801fP755yX6Fs+RMG/ePC644AKaNm1KmzZtuOmmm9i5c2e53ochQ4ZgjMFaG/BZFf3MFv8ZDybYz3dlx3bw4EH+/Oc/k5CQQNOmTWnZsiW9evVi4sSJHDt2zP++p6en+8998nih9JwBP/74I1OnTuW8886jadOmtGjRgosvvpi5c+eW6Fv8My7v7wMREakjhZUB5nqTAJzKADFbieg8lybtlxDReS5pMVtZHx4OOIn/7vf+mgti2jAtNI1bQlYww7OPaG9BwGGLygTeErKCaaFpXBjTKvgsAJE6ppkBIoVmzZpFfn4+N910EwkJCWX2bdKkSYlt27dv54ILLiA2NpZbb72VgwcP8vrrr/svqC+55JIS+8ybN4/333+fESNGcOedd5KdnV3qOa21XHHFFaxcuZKLLrqI22+/ndDQUL777juWL1/OxRdfTL9+/Sr8ugHGjBnDa6+9RkJCAr/85S+JjIxk165dfPLJJ7z//vtceumlAf0PHz7MwIEDCQ8PZ9SoUeTm5jJv3jzGjh2Ly+XyX+gH06pVKyZPnsy6det4++23ufbaa/2JA3v37s3kyZOZMmUK3bp1C0jKWPyibdasWaSkpNCkSROuueYaunbtyqZNm/jXv/7Fu+++y2effcYZZ5zh779y5UouvfRS8vLyuOGGG+jevTvr1q1jyJAhDB06tNzv0/Hjx3nttdcAmDx58in7h4YG/xW7ZcsWEhMTiY+P55ZbbiEnJ4cWLVoAzjKVyZMn06ZNG37605/Svn17vvrqK/7+97/z3nvv8emnn/r7Aqxdu5bhw4dz8OBBLr/8cm644Qb279/PggULGDRoEG+99RZXXnlliTE8++yzvPPOO1xzzTUkJSWRmZnJ66+/zpdffsm6deuC/owXN2bMGIYMGVLis6qOBHwVGdu2bdu45JJL2L59O/369eM3v/kNPp+PrKwsnnzySe68807/z9zs2bPZvn17wGd3qvHm5eVx+eWXk56eTo8ePfjtb3/L8ePHmTdvHjfeeCPr1q3jkUceKbFfZX4fiIhI7apMZQCyD7K0+zxiVSZQGgJrrR4N9AGs6du3rz2VDRs22A0bNpyyX3U4nn/cvrvlXfv8uuftwi0LbU5+Tq2ctzyGDh1qAZuWllah/bZt22YBC9jU1NSAtvfff98CdsSIEQHbZ82aZQFrjLGLFy8OelzAJiUl+b//6quvLGCvu+66En0LCgrswYMHKzTuIocPH7bGGNuvXz/r9XpLtO/fv7/EuAD7q1/9KqD/119/bUNCQuw555wT0H/ZsmUWsJMnTw7YXvQezJo1q8Q5T37txf3vf/+zYWFhNi4uzu7YsSOgbenSpdblcgW8Rz6fz5599tkWsAsWLAjo/9RTT/lfz7Jly4Ker7j09HQL2C5dupyybzDFf1buu+++Eu3//e9/LWAvuugie+jQoYC2ovfrD3/4g39bfn6+jYuLs02aNLHLly8P6L9z507bqVMn26FDB5ubm+vfPnnyZAvY5s2b26+++ipgn5///OcWsK+//nq5X1Npn1VZn29p+1VmbAMGDLCAfeSRR0qcY9++fTYn58TvmKSkJOv8txdct27dbLdu3QK2PfLII/5/w/n5+f7tHo/HduvWzQI2IyPDv70yvw9KU5u/m0VEGoxvFlpbUGCttfZ/e36wMz/Zaqd/lGVnfrLV/m/PD06fggJrv1loZ36y1XabsNB2m7DQdn/4rzZhdkKpj+4P/9V2m7DQ3n5fqrWTW/gfr//5ahsz4R3/cbpNWGhjJrxjX//z1QH97DcL6/BNkYasb9++FlhjK3G9qPCU1Jr1+9cz4s0R3LfiPmasm8HEFRO54s0rWL9/fV0PDXDWggN06dKlUvt369aNSZMmBWy7/PLLOeOMM1i1alXQfa699lquuOKKCp0nMjKyxDaXy0Xr1mUnsSlN0VTvJk2a4AoSsY6Oji6xrWnTpjzxxBOEhJyInvfs2ZOBAwfyzTffcOTIkUqNpTyee+458vPzefrpp+ncuXNA29ChQ7nmmmt49913/WNYuXIl//vf/xg8eDDXXnttQP9x48ZVaJ34nj17AEqct8js2bNJTU0NeAQrs+d2u4POLJg+fToAaWlptGrVKqBtzJgx9O7dm1deecW/bdGiRWzZsoXf/e53JCUlBfTv1KkT9957L3v27AmaGG/8+PH85Cc/CdiWkpICUOrPa20p79jWrFnDypUr6d27NxMmTChxnKLp+VUxc+ZMjDE88cQTATM92rdvz1/+8hcA/vWvf5XYrzK/D0REpIqWPQpzbsbzSgo3Pp/B8Cc/Zsq7G3h8SRZT3t3A8Cc/5sbnM/C8kgJzbqbn//7h37W8lQGW+PqTeYbzf5LKBMrpTssEpFbkenMZt3QcB3IPBGw/kHuAcUvH8f7I94kIrdtSfdaZTRGwbr8ievfuHXBxXKRr166lrk2/4IILyn38nj170rt3b1577TW2b9/Otddey6BBg+jfvz/hhWvZKqNFixZcffXVvPvuu/Tu3ZuRI0dy8cUXk5iYWGo1g7POOitgqnqRrl27As4ygubNa2ZtXNF7mZ6eHnRN/N69eykoKCArK4t+/fqxdu1agBIXywAhISEMGjSILVu2lOvcp/oZmT17tn9depGYmBj/MogivXr1CjoN/9NPPyUsLIw33niDN954o0R7Xl4e+/bt48CBA0RHR/vfi+3btwctIblp0ybAqUxx8lKB/v37l+hf9PkdOlT2H0Q1rbxj++yzzwDnIjtYIKuqjhw5wubNm+ncuXPQJJhFS0y++OKLEm2V+X0gIiJVUIuVATac/VsSB1yiMoFy2lMwQGrF0m+XlggEFDmQe4Cl3y7lqti6/UXZqVMnNm7cyI4dOyq1/8l3couEhobi8/mCtlWkHntISAj//e9/+etf/8q8efP8d0KbN2/O6NGjefTRR0tNZncqr7/+OtOmTePVV1/137GOiIhg1KhR/P3vf8ftdgf0L+u1AhQUFARtrw4HDjg/R3/729/K7Hf06FEAvv/+e4ASr6FIRT6Djh07ApSayK54EsBJkybx8MMPV+icBw4cwOv1MmXKlDLHcfToUaKjo/3vRbDAwcn9TxbsM6yNz688yju2ooSKpc3UqKqin52iz/1kRduDJXaszO8DERGpgtquDOBWmUA5/WmZgNSKHUfKvsA+VXttGDRoEFC7tcYrOguhdevWPPnkk3z33Xf+hHk9evRgxowZ/OY3v6n0OCIjI0lNTSUrK4tvv/2Wl19+mUGDBvHyyy8zatSoSh+3JrRs2RJwLtTKWgNVNBOgqL/H4wl6vKKp/+XRv39/mjRp4n//K6u0z71ly5a0bt36lOu7unXr5u8P8Pbbb5fZvzzJDqtb0Z16r9dboq20qggVVXTBXd4KCBVV9P6W9jNStLSoqJ+IiNQhVQYQqTAFA6RWdGle9jr8U7XXhttuu42wsDDefPNNNmzYUGbfH3/8sZZGVbru3bvzq1/9ivT0dJo1a8bbb79dLcft2rUrt9xyCx988AFnnXUWn3zyif8OdG1xuVyl3p2+8MILAVixYkXQ9pP17dsXoMT0fXDuMn/yySflHlfTpk35+c9/DjhZ/6vbhRdeyKFDh/j666/L3R/K/17UpqIcFt99912JtpNLLlZW0ev/4IMPynW3vWjafnlnPhSV7ty5c2fQ4M+yZcuAEz9jIiJSd4oqA0zwpvBKwcWMc7crtTLAKwUXM8GbQmb2QR4N/SfJJ1UGyN2ZzI97LyN3ZzIp2bEk5OUBzmyDp6NmgmZ4SQOhYIDUimFnDCM6omQiOoDoiGiGnTGslkdUUkxMDKmpqeTl5XHVVVeVesFSVAqwtm3bti3oReKhQ4f48ccfgyYWLI99+/aRmZlZYvuxY8c4cuQIoaGhVcpJUBnR0dFBLyLBSfoXFhbG3XffTVZWVon2vLy8gIvjAQMGcPbZZ/Pxxx+XCJjMmDGj3PkCijz88MN06tSJl19+mbvvvptjx44F7Vc0xbwi7r77bsBJlrdr164S7ceOHfOvkwcnAWVcXBz/+Mc/eO+994Ie89NPP+X48eMVHktV9e/fH5fLxauvvhpw/oMHD3LvvfdWyzn69evHgAEDWLduHdOmTSvRfuDAAXJzc/3fFyXD/Pbbb8t9jrFjx2Kt5Z577gkIIuzfv58HH3zQ30dERGrAxkX+C+8szxFmZWzjmaWbmJWxjSxPYbJinw82LiJj837ASd6XGpkYdLo/OAGB1MhELC4uda0ldscCf9tcbxKT8u8g/4e+5B0YRv4PfZmUf4d/tgE4+QjIWlwzr1eklilngNSKiNAIZgybUSKJYHRENDOGzajz5IFF7r//fv+a7fPPP58BAwbQv39/mjVrhsfj4eOPP2bTpk1BE5zVtC+//JLrr7+efv36kZCQQKdOndi3bx9vv/02+fn5QbOpl8fOnTu58MILOeecc+jbty9du3blhx9+YOHChezZs4fx48fXWDLA0gwbNow5c+Zw9dVX069fP0JDQxk8eDCDBw+mR48ezJw5k7Fjx3LuuedyxRVXEB8fT35+Pt9++y0rVqygXbt2bNy4EXCm5P/73//msssuY+TIkdxwww10796dL7/8ko8++ogrrriC999/v9xj69SpE0uXLuWGG27gqaee4sUXX2To0KHExsbicrnweDxkZGSwadMm2rdvHzTxXFmve+rUqdx3332cddZZXHnllZx55pkcPXqU7du3k56ezqBBg/zjDQsLY/78+Vx++eVcddVVDBgwgN69e9O0aVO+++47Pv/8c7Zu3cru3btLTQZZUzp27Mgtt9zCf/7zH3r37s1VV13FDz/8wHvvvcfgwYODJt2rjJdffpkhQ4Zw//338+abbzJkyBCstWzatIkPP/yQjRs3EhMTAzjv7xtvvMENN9zAlVdeSWRkJN26dePWW28t9fh/+tOfWLx4MW+//Ta9evXiyiuv5Pjx47zxxhvs3buXe++917/ESEREqtGyRyF9Kp64UYw/NpbM7MMluiTGtGJ61EzcW+bR84wU4BKg4pUBEr9NcyoDHBuLPek8RZUBkqLaOYEAVQaQBkTBAKk1CW0TeH/k+yz9dik7juygS/MuDDtjWL0JBBR54IEH+NnPfsazzz7LsmXLmDVrFrm5uURHR/tLmP3iF7+o9XH179+f++67j/T0dN5//30OHTpEu3bt6NevH+PHj6/0bIWYmBimTJnC8uXLWbZsGfv376dNmzacffbZTJ06lZtuuqmaX8mpPf300xhjWLp0Ke+99x4+n4/JkyczePBgAH7xi1/Qq1cvHn/8cZYtW8aHH35IVFQUnTp1YtSoUdx4440Bxxs4cCArVqzgz3/+M4sXO9H8xMREli9fzgcffFChYABAjx49WLduHa+99hpvvvkmn376KQsXLsQYQ/v27f0/JzfeeGOFkzpOmDCBgQMHMn36dD755BPefvttWrZsSefOnfn1r3/NzTffHND/vPPO48svv+SJJ55g4cKFzJo1C5fLRceOHenTpw9Tpkyhbdu2FRpDdUlLS8PtdvPaa6/xj3/8gzPOOIPx48dzzz33MHfu3Go5x5lnnsnatWt57LHHWLBgATNmzCAiIoKYmBj++Mc/0r59e3/f22+/ne3btzNnzhwee+wxvF4vSUlJZQYDwsPDWbJkCU888QSvvvoqzzzzDKGhofTq1YunnnrKv2xERESqkSoDiNQKU1QqSxoeY8yavn379l2zZk2Z/b755hsAzjnnnNoYloiIlIN+N4tIo+Xz4XklxV8ZAOCVgotLVAa45aTKAMM2O0mPHwp7gbSYraVXBsiOZVL+HVhcfHj3YCUElNNaYSnttdbafhXdVzMDRERERESk/iisDDDSu4/k0HSnMoB7KxGh2/1d0rwF9PKEk5CXx1xvEvO9v+aCGBi5YxrJISvo5QkvkUSwqDJAQshOwqwz/V+BAGnMFAwQEREREZF6o6gywCpSyDc+0twl7/IXVQZIyY5lkjcFsg+ytPs8Yk+qDFB8NkFKTiYJIU452uTQdJKi2jnT/13KqS6Nk4IBFWSMiQauB64CfgJ0BvKA/wfMAmZZa8tVb8QYkw10K6XZY63tUOUBi4iIiIjUtY2LIH4ElLku3wdZi8k40BM4URmg+IyA4vyVAfJdXOZaXbIygDcFm3/iQn8SvQmzLn8pQacygPIASOOlYEDF/Qx4DtgNLAO+BdzADcC/gBHGmJ/Z8idj+B54Ksj2o1UfqoiIiIhIHVNlAJF6ScGAissCrgEWFZ8BYIy5H1gFjMQJDLxZzuMdttamVvcgRURERETqnCoDiNRbCgZUkLX2v6Vs32OMeR54GBhC+YMBIiIiIiINU/wIPHGj/JUBkkPTyTe+EpUBkk+qDPDR5r4YfKTmZJLmLSi9MkBOJpPojcXFwO5twX3iAj/e3Tx4gkCXS4EAERQMqG75hc/eCuzTxBjzC+AM4BjwFfCxtbagugcnIiKnB5X9FZEGQ5UBROotBQOqiTEmFPhl4bfvV2DXDsB/Ttq2zRhzm7U2vZznXlNKU49y7o+1Fp/Ph0vZVEVE6lxRMMAYU8cjERGpGlUGEKm/FAyoPlOBBOA9a+0H5dxnFrAC+Bo4AsQC44BfA4uNMRdZa7+sicEW16RJE3Jzczl27BjNmyuiKiJS144dOwY4v59FROodVQYQaRAUDKgGxpjxwB+BjcCt5d3PWjvlpE3rgTuNMUcLj5eKU8bwVMfpV8q41gB9T7V/8+bNyc3NZc+ePQBERUVhjNEdKRGRWmStxVrLsWPH/L+PFaAVkXpHlQFEGgwFA6rIGPNb4GlgAzDMWnuwGg77PE4wYHA1HOuU2rRpw7Fjxzh+/Dg7duyojVOKiMgpNG3alDZt2tT1MERETlBlAJEGRcGAKjDG/AF4EueO/jBr7d5qOnTRcaKq6XhlcrlcdO3alYMHD3LkyBF+/PFHJa8SEakDxhiaNGlC8+bNadOmjfK4iEj9osoAIg2KggGVZIyZgJMnYB1wmbV2fzUe/qLC563VeMwyuVwu2rZtS9u2bWvrlCIiIiJyOlFlAJEGRcGASjDG/AX4K7AGGF7W0gBjTBgQB+Rba7cU234usPvkfY0x3YAZhd++XN1jFxERERGpDFUGEGlYFAyoIGPMaJxAQAFOJYDxQRLtZVtrZxd+3Rn4BtgOxBTr8zNgojFmGbANp5pAHHAVEAG8B/y9Rl6EiIiIiAioMoBII6ZgQMWdWfgcAvyhlD7pwOxTHGcZcDbQB2dZQBRwGPgE+A/wH6uF+yIiIiJSU1QZQKRRUzCggqy1qTgl/8rbPxsoMXXAWpuOEzQQEREREaldqgwg0ugpGCAiIiIi0tioMoBIo6dggIiIiIhIY6PKACKNnoIBIiIiIiKNjCoDiIiCASIiIiIijUzG5v2AKgOINGYK0YmIiIiINAQbFzllAHHu/M/K2MYzSzcxK2MbWZ4jTh+fDzYu4miu179bRSsDAE5lgC4TAhIOwonKAJ64Uc4GVQYQqbc0M0BERERE5HRXwTKBg2Lv4HGSAFQZQKSRUjBAREREROR0VokygX22vsBlrig+8vVVZQCRRkrBABERERGR01klygR64kZx5OhQpu38myoDiDRSCgaIiIiIiJzOKlEm8K2jY3i62Wz/TAFVBhBpfBQMEBERERE5jVWmTOCl3/0Xd/g8f7sqA4g0PgrriYiIiIjUNxWoDHBymcBga/+hWJlAXCzx9eeL2DsAVQYQaaw0M0BEREREpD6pYGWAnmekAJcA5S8TCPBJ5xT6XJCkygAijZSCASIiIiIi9UUlKgMkfpvGZa7mLPH1r1CZwGYRoQEX+KoMINK4aJmAiIiIiEh9UVgZoEhyaDoPhb1AWIu1hEcvJazFWh4Ke8G/jh9ga5fr+MjXF4OP1JxMor0FQQ8d7S0gNScTg7P8YGD3tjX7WkSkXtPMABERERGR+qISlQHme3/NBTEwcsc0lQkUkXJTMEBEREREpJ6oTGUAsg+ytPs8YlUmUEQqQMEAEREREZF64uTKAMVnBBTnrwyQ7+Iy12pidyzwt6lMoIiUh0KBIiIiIiI1qQJlAo/mev27lbcywBJffzLPSAFUJlBEyk8zA0REREREakoFywQOir2Dx0kCqFBlgA1n/5bEAZeoTKCIlJuCASIiIiIiNaESZQL7bH2By1xRfOTrS2pOJmneghI5A8BJCJiSk8kkemNxOZUB3CoTKCLlp2CAiIiIiEhNKCwT6N4yD3AS9+UbX0Biv9ScTJJDVvh38cSN4sjRoUzb+TdVBhCRGqVggIiIiIhITahEmcC3jo7h6Waz/TMFVBlARGqKggEiIiIiIjWgMmUCL/3uv7jD5/nbVRlARGqKwociIiIiIjXg5DKBwdb+Q7EygbhY4uvPF7F3AKoMICI1SzMDRERERETKY+MiiB8BZWbr90HWYuhxVaXKBAJ80jmFPhckqTKAiNQoBQNERERERE6lgiUCSZpIs4ib/G0VKRPYLCI04AJflQFEpCZomYCIiIiISFlOLhG4YxoGX0AXf4nAwsoBpE9leMgaf1tqTibR3oKgh4/2FpCak+k/5sDubWvohYiInKCZASIiIiIiZalkicDOF9xA4rpPGbljmsoEiki9o2CAiIiIiEhZKlEicP6xscwBZ9mAygSKSD2kYICIiIiISBkqUyLQZh9m56r5dN6iMoEiUj8p5CgiIiIiUobKlAgE+LCgn1P2D5UJFJH6RzMDRERERKTxqUCZwKO58f7dKlIi8GiuF4bdBx3PU5lAEal3FAwQERERkcalgmUCB8XeweMkAZUoEQgqEygi9ZKWCYiIiIhI41GJMoF9tr7AZa7VKhEoIg2KZgaIiIiISONRyTKBR44OZdrOv6lEoIg0GAoGiIiIiEjjUYkygW8dHcPTzWarRKCINCgKBoiIiIhIo1GZMoGXfvdf3OEqESgiDYtClSIiIiJyetu4yMn8j3OxPytjG88s3cSsjG1keY44fXw+2LioUmUCl/j680XsHYBKBIpIw6GZASIiIiJy+qpgZYCeZ6QAlwAVKxP4SecU+lyQpBKBItJgKBggIiIiIqenkysDePexipSAu/b+ygCF0/cTv03jMldzlvj6V7xMoEoEikgDomUCIiIiInJ6KqwMUCQ5NJ2Hwl4grMVawqOXEtZiLQ+FveBfxw+wtct1fOTrqzKBItLoaWaAiIiIiJyeKlEZYL7311wQAyN3TFOZQBFp1BQMEBEREZHTUmUqA5B9kKXd5xGrMoEi0sgpGCAiIiIip6WTKwMUnxFQnL8yQL6Ly1yrid2xwN+mMoEi0lgpvCkiIiIi9UcFygQezfX6dytvZYAlvv5knpECqEygiDRumhkgIiIiIvVDBcsEDoq9g8dJAqhQZYANZ/+WxAGXqEygiDRqCgaIiIiISN2rRJnAPltf4DJXFB/5+pKak0mat6BEzgBwEgKm5GQyid5YXE5lALfKBIpI46ZlApVkjOlijJlpjNlljPnRGJNtjHnKGFN2WLqGjiMiIiJyWqtEmUBP3CiOdB3KtNA0bglZwQzPvhKlAosqA9wSsoJpoWlcGNNKlQFERNDMgEoxxsQBK4H2wNvARuAC4PfAFcaYgdbaA7V1HBEREZHTXiXKBL51dAxPN5vtnymgygAiIuWnYEDlPItzAT/eWvtM0UZjzBPA3cDDwJ21eBwRERGR01plygRe+t1/cYfP87erMoCISPkpJFpBxphYYDiQDfzjpObJwDHgVmNMVG0cR0RERKQhOLlMYLC1/1CsTCAulvj680XsHYAqA4iIVJRmBlTc0MLnD621vuIN1tojxpgMnIv8C4GltXAcERERkfpp4yKIHwFlZuz3QdZijubG+3crb5lAgE86p9DngiRVBhARqSAFAyru7MLnrFLaN+FcxMdT9kV8dR1HREREpP6ppTKBzSJCAy7wVRlARKR8tEyg4loWPn9fSnvR9la1dByMMWuCPYAep9pXREREpNqdXCZwxzQMARMhT5QJ3OKs+XfKBK7G4CM1J7NEVYAi0d4CUnMy/ccb2L1tDb4QEZGGSzMDqp8pfLb15DgiIiIitauwTGDRhX5yaDr5xheQ5T81J5PkkBX+XTxxozhydCjTdv6N5JAV9PKEM87dLiB3QFGZwISQnYRZJxeAygSKiFSOggEVV3THvmUp7S1O6lfTx8Fa2y/Y9sLZAX1Ptb+IiIhItVKZQBGRek/BgIr7X+FzfCntZxU+l5YLoLqPIyIiIlKvqEygiEj9pzBqxS0rfB5ujAl4/4wxzYGBQA7wWS0dR0RERKReUZlAEZH6TzMDKshau8UY8yFOpv/fAs8Ua54CRAEvWGuPARhjwoA4IN9au6WyxxERERGpUyoTKCLSoCgYUDl3ASuB6caYYcA3QCJwCc60/j8X69u5sH07EFOF44iIiIjUDZUJFBFpcLRMoBIK7/D3B2bjXLz/Eefu/3TgImvtgdo8joiIiEiNUZlAEZEGSTMDKsla+x1wWzn6ZXOiTGCljyMiIiJSJ1QmUESkQVIwQERERERKpzKBIiINkoIBIiIiIlIqlQkUEWmYFHoVERERkVKpTKCISMOkmQEiIiIijY3KBIqINHoKBoiIiIg0JioTKCIiaJmAiIiISOOhMoEiIlJIMwNEREREGguVCRQRkUIKBoiIiIg0FioTKCIihRQMEBEREWkkVCZQRESKKFwrIiIi0kioTKCIiBTRzAARERGR05nKBIqISCUoGCAiIiJyulKZQBERqSQtExARERE5HalMoIiIVIFmBoiIiIicjlQmUEREqkDBABEREZHTkcoEiohIFSgYICIiInIaUplAERGpCoV4RURERE5DKhMoIiJVoZkBIiIiIvWFygSKiEgtUTBAREREpD5QmUAREalFWiYgIiIiUtdUJlBERGqZZgaIiIiI1DWVCRQRkVqmYICIiIhIXVOZQBERqWUKBoiIiIjUMZUJFBGR2qawsIiIiEgdU5lAERGpbZoZICIiIlITVCZQRETqMQUDRERERKqbygSKiEg9p2UCIiIiItVJZQJFROQ0oJkBIiIiItVJZQJFROQ0oGCAiIiISHVSmUARETkNKBggIiIiUo1UJlBERE4HCiWLiIiIVCOVCRQRkdOBZgaIiIiIVKOjuV7/1yoTKCIi9ZWCASIiIiKnsnERxI+AMi/SfZC1mGYRPf27qUygiIjUVwoGiIiIiJRl2aOQPhVP3CjGHxtLZvbhEl0SY1oxPWom7i3zuKb/3UzhfH+ZwDRvQdClAtHeAlJyMplEbywulQkUEZFapWCAiIiISGk2LoL0qYCTsG+kdx+rSAlYz2/wMXLHNH8lgOjVT3JXhweI2Z+uMoEiIlJvKRggIiIiUpr4EXjiRjmZ+3FK+uUbX0DJv9ScTJJDVvh38cSOZDRf4z6sMoEiIlJ/KRggIiIiUhqXi/HHxjLSu4/k0HTWh4eT5t5KROh2f5c0bwG9POEk5OUx15vE9oM9uefwg/52lQkUEZH6SOFnERERkVJkeY6QmX2YCd4UXim4uMR0f3BKBI5zt+OVgouZ4E3hH3vO4UD/uwGVCRQRkfpLMwNERERESpGxeT/gXLynRiYGzAgo7kBoCKmRif67/++0Hs1tN52vMoEiIlJvKRggIiIijUcFSgTS4yqO5nr9u5qwQ2Ueunj70VyvygSKiEi9pmCAiIiINA4VLBFI0kSaRdzkb7P5rcs8fPH2ZhH6E0tEROo35QwQERGRhu/kEoE7pmHwBXTxlwgsrBxA+lSGh6zxt6XmZBLtLQh6+GhvAak5mf5jDuzetoZeiIiISPVQ2FpEREQavsqUCIwbRecLbiBx3aeM3DGN5JAV9PKEl0giGO0tYIZnHwkhOwmzTmLAoEsCRERE6hEFA0RERKThq0SJwPnHxjIHnGUDhSUAE/LySMmODQgipORkkhCyE3CCDElR7ZzEgC5NwBQRkfpLwQARERFp8IpKBK4ihXzjI829tdQSgSnZsUzypmCzD7Nz1Xw6Fy0bAOZ6k5y2/BMX+pPoTZh1kVwYMHBvmacKASIiUu8pZC0iIiIN3sklAk8OBBTxlwgs/BPpw4J+kDQRcJYNzO8ywd9WxOIsDfDEjXI2JE1UIEBEROo9zQwQERGRBq9KJQKH3Qcdz8MdP4I5ZZYkvEgzAkRE5LShYICIiIicnjYugvgRUOYFug+yFtMsoqd/t0qVCCx2gR/vbh48QaDLpUCAiIicNhQMqABjzFnADcDlwFmAGzgEfAY8Za1dVoFjxQDbyujyurX2pjLaRUREGq9lj0L6VDxxoxh/bCyZ2YdLdEmMaeUk/9syj2v6380UzveXCEzzFgRdKhDtLSAlJ5NJ9MbiUolAERFpsBQMqJgHgRuBDcB7wEHgbOAa4BpjzO+ttdMreMwvgQVBtq+vwjhFREQaro2LIH0q4CTrG+ndxypSAtbyG3yM3DHNXwUgevWT3NXhAWL2p6tEoIiICAoGVNT7wDRr7RfFNxpjkoAlwN+MMW9Ya3dX4JjrrLWp1ThGERGRhi1+BJ64UU7WfpxyfvnGF1DuLzUnk+SQFf5dPLEjGc3XuA+rRKCIiAgoGFAh1trZpWxPN8YsBy4DBgBv1uKwREREGheXi/HHxjLSu4/k0HTWh4eT5t5KROh2f5c0bwG9POEk5OUx15vE9oM9uefwg/52lQgUEZHGTsGA6pNf+Owts1dJnYwxdwDRwAHgU2vtV9U6MhERkQYky3OEzOzDrCKFfOMjzb21xPr/A6EhjHO3IyU71rno3+Ni7KC7iV79pFMi8NhY7El5BopKBCZFtXMCASoRKCIiDZiCAdXAGNMNGAYcBz6u4O6XFT6KH285MNpa+205z7+mlKYeFRyLiIhIvZexeT/gXLynRiYGzAgo7kBoCKmRif67/++0Hs1tN52vEoEiIiJUYzDAGGOAS3EubAcDZwBtgRxgL7AO+C/wjrV2Z3Wdt64ZY5oArwBNgHuttWUXLz7hOE5CwgXA1sJt5wGpwCXAUmNMb2vtsWodsIiIyGnuaO6JSXgmrOz/dou3H831qkSgiIhIoSoHA4wxTYHxwB04AQBT2JSLEwSIBGKBOGAk8LQx5l3gcWvtyqqevxLjzQa6VWCXV6y1vyjlWCHAf4CBwOvA38t7UGvtXuCBkzZ/bIwZDnwCJAK3A0+X41j9ShnfGqBvecckIiJSZzYugvgRUOYdex9kLaZZRE//bja/dZmHLd7eLEITIkVERIpU6X9FY8xtwENAR2AjMAXIAD631v5QrJ/BKcF3IXA5cC1wnTFmHnBPeafDV5MtOIGK8toVbGNhIOBl4GfAXOAX1lpb1cFZa73GmH/hBAMGU45ggIiIyGlt2aOQPhVP3CjGHxtL5klr+QESY1oxPWom7i3zuKb/3UzhfAw+UnMySfMWlMgZAE6pwJScTCbRG4uLgd3b1sKLEREROT1UNUT+b5xp7o9aaz8vrVPhRfLGwsdsY0wLYDQwERgD/LWK4yg3a+2wqh7DGBMKvIoTCHgV+KW1tqCqxy1mX+FzVDUeU0REpP7ZuAjSpwJO9v6R3n2sIgXLiSz/Bh8jd0zDXZjlP3r1k9zV4QFi9qeTHLKCXp5wxrnbBQQEor0FzPDsIyFkJ2HWSQwYdEmAiIhII1XVYEB/a+3aiu5UOGvgGWNMGhBTxTHUKmNMOM5MgGuBl4DbrLW+aj7NhYXPW8vsJSIicrqLH4EnbpSTvR9IDk0n3/hIjUzEhB3C5rcmNSeT5JAV/l08sSMZzde4DzvBgYS8PFKyYwP2ScnJJCFkp/+YSVHtnMSALlfJMYiIiDRCVQoGVCYQcNL+uTizBU4LhckC5wNX4syK+PWpAgHGmJY4yyi+t9buLrY9EfjCWpt3Uv+hwN2F375cjcMXERGpf1wuxh8by0jvPpJD01kfHk6ae2tAhYA0bwG9POEk5OUx15vE9oM9uefwg/72ud4kp3xg/okL/Un0Jsy6SC6cTeDeMk8VAkRERIpRJp2KeR4nELAf2Ak84KRDCLDcWru82PfXA7OAF3GWRBSZBpxbWEZwR+G284ChhV//pS4SLIqIiNSmLM8RMrMPs4oU8o2PNPfWEuv/D4SGMM7djpTsWOeif4+LsYPuJnr1k3jiRjH/2FjsSXkGLM7SgKSodk4gIGmiAgEiIiLFVHswwBjTBefOdm+gCxAWpJu11sZV97lrwZmFz20pWQmguOXlONZ/cAIF5wMjcN4nD84ShBnW2hVl7CsiItIgZGzeDzgX76mRiQEzAoo7EBpCamSi/+7/O61Hc9tN5+OOH8GcMisQXKQZASIiIkFUazDAGDMEeA+IALw4F7feYF2r87y1xVo7pBL7zAZmB9n+b5ylBiIiIg1LBcoEHs2N9+9mwg6Vedji7UdzvQEX+PHu5sETBLpcCgSIiIgEUd0zAx4DQoBfAq/WQGI9ERERqc8qWCZwUOwdPE4SADa/dZmHLt7eLEIrHUVERKqiulPq/gR4zVr7sgIBIiIijczJZQJ3TMMQ+OeAv0xgYfWAPltf4DLXagw+UnMyifYGr9Qb7S0gNSfTf7yB3dvW4AsRERFp+Ko7rH4IOFjNxxQREZHTQWXKBMaN4sjRoUzb+TeSQ1bQyxPOOHe7gCSC0d4CZnj2kRCykzDrJAYMuiRAREREyq26gwELoXCun4iIiDQulSgT+NbRMTzdbDbuwhKACXl5pGTHBgQQUnIySQjZCTgBhqSodk5iQFd1T3AUERFpPKo7GHA/8Jkx5h/AvdbaY9V8fBEREamnKlMm8NLv/os7fJ6/fa43ySkfmH/iQn8SvQmzLpILAwbuLfNUIUBERKSKqjWkbq3dD1wB3ATsMcasMcb8N8hjaXWeV0REROreyWUCTw4EFPGXCcTFEl9/voi9A3CWDMzvMgF70p8nFmdpgCdulLMhaaICASIiIlVU3aUFzwWWAUXpfvuU0tVW53lFRESk7h3NPVFNuCJlAj/pnEKfC5Jwx49gTpnlCC/SjAAREZFqUt3LBJ4AooEHgBeBXdba4GmBRUREpP7buAjiR0CZF+k+yFpMs4ie/t0qXCaw2AV+vLt58ASBLpcCASIiItWkuoMBFwHzrbUPVfNxRUREpLYtexTSp+KJG8X4Y2PJzD5coktiTCumR83EvWUe1/S/mymc7y8TmOYtCLpUINpbQEpOJpPojcWlMoEiIiJ1oLqDAXlAdjUfU0RERGrbxkWQPhVwEvaN9O5jFSkB6/kNPkbumOavBBC9+knu6vAAMfvTVSZQRESknqvuYMBy4IJqPqaIiIjUtvgReOJGOZn7cUr65RtfQMm/1JxMkkNW+HfxxI5kNF/jPqwygSIiIvVddQcD7gUyjTETgWnWWiUKFBEROR25XIw/NpaR3n0kh6azPjycNPdWIkK3+7ukeQvo5QknIS+Pud4kth/syT2HH/S3q0ygiIhI/VXdwYBJwHrgYSDFGLMO+D5IP2ut/VU1n1tERESqSZbnCJnZh1lFCvnGR5p7a4n1/wdCQxjnbkdKdqxz0b/HxdhBdxO9+kmnTOCxsdiT8gwUlQlMimrnBAJUJlBERKROVHcwYEyxr88sfARjAQUDRERE6qmMzfsB5+I9NTIxYEZAcQdCQ0iNTPTf/X+n9Whuu+l8lQkUERGp56o7GFDaxb+IiIicRo7mev1fm7BDZfYt3n4016sygSIiIqeBag0GWGuD3zYQERGRurdxEcSPgDLv2PsgazHNInr6d7P5rcs8bPH2ZhHVfZ9BREREakKV/8c2xjwFzAdWKGGgiIhIPbXsUUifiiduFOOPjSXzpLX8AIkxrZgeNRP3lnlc0/9upnA+Bh+pOZmkeQtK5AwAp1RgSk4mk+iNxcXA7m1r4cWIiIhIVVVH+H4c8DvggDHmHZzAwEfW2rxqOLaIiIhU1cZFkD4VcLL3j/TuYxUpWE5k+Tf4GLljGu7CLP/Rq5/krg4PELM/neSQFfTyhDPO3S4gIBDtLWCGZx8JITsJs05iwKBLAkRERKTeqY5gQCfgOuB64BfAbcAxY8x7wFvAe9baI9VwHhEREamM+BF44kY52fuB5NB08o2P1MhETNghbH5rUnMySQ5Z4d/FEzuS0XyN+7ATHEjIyyMlOzZgn5ScTBJCdvqPmRTVzkkM6HKVHIOIiIjUK1UOBlhr9wL/BP5pjGkB/BQnMHAlkAz8aIxZihMYeMdau6+q5xQREZEKcLkYf2wsI737SA5NZ314OGnurQEVAtK8BfTyhJOQl8dcbxLbD/bknsMP+tvnepOc8oH5Jy70J9GbMOsiuXA2gXvLPFUIEBEROU1Ua+jeWvuDtfZVa+3PgHY4MwbmAIlAGrDLGJNujPm9MaZbdZ5bREREgsvyHCEz+zATvCm8UnBxien+4JQIHOduxysFFzPBm8I/9pzDgf53A+CJG8X8LhMClhWAU3ZwfpcJeOJGORuSJioQICIicpqosZS/1tofgXeAd4wxLiAJuAG4FngSeMIYs85a26+mxiAiIiKQsXk/4Fy8p0YmBswIKO5AaAipkYn+u//vtB7NbTedjzt+BHPKrEBwkWYEiIiInGZqpf6PtdYHLCt8/M4Y0x8nMHBdbZxfRESkMTua6/V/bcIOldm3ePvRXG/ABX68u3nwBIEulwIBIiIip5kqLxMwxlxTeOe/3Ky1q62191tre566t4iIiFRFs4gTsX+b37rMvsXbi+8nIiIiDUt15AxYAGw3xvxVeQBERERqycZF4PMBTk6AWRnbeGbpJmZlbCPLU1jEx+eDjYsY2L0t4JQPTM3JJNpbEPSQ0d4CUnMyMTjHLdpPREREGp7qCPkvBYYCk4D7jTFLcKoLvGOtDf7XhoiIiFTeskchfSqeuFGMPzaWzOzDJbokxrRietRM3FvmEZ80kcSYwYzcMY3kkBX08oSXSCIY7S1ghmcfCSE7CbNOYsCgSwJERESkQaiO0oKXFc4IuB0YA1wODAc8xphZwL+ttVureh4RERHBmRGQPhVwSvmN9O5jFSkBmf4NPkbumIa7sOQf6VN5ocPHtApdCUBCXh4p2bGkRiZiwg5h81uTkpNJQshOAJJD00mKauckBnRVa+EhERERqSeq5X94a+12a+1fgG7ANcBCoC1wH5BljPnQGDPKGKPFhyIiIlURP+JEKT+cC/eHwl4grMVawqOXEtZiLQ+FvUByUSAAONxhAK32rPR/P9ebxKT8O8j/oS95B4aR/0NfJuXfwVxvkr+Pe8s8yFpcO69JREREal21hvuttT5r7UJr7bXAGThLB7KBS4HXgZ3GmGnGmLOq87wiIiKNhsvF+GNj/Rfu68PDSYvZSkTnuTRpv4SIznNJi9nK+vBwwLnwv5NJkDQRAE/cKOZ3mRAwkwCcsoPzu0w4EWhImqgKASIiIg1Yjd2pt9buAR4BHjHGDMNZRnAd8CfgjzV5bhERkYYqy3OEzOzDrCKFfOMjzb01YO0/wIHQEMa525GSHcskbwo2+zBZ148jvuN5uONHMMflIstzhIzN+zma66VZRCgDu7d1cgT4LoKsGxQIEBERaeBq64I8HWgDnAlcUEvnFBERaXAyNu8HnDv5qZGJRIRuD9rvQGgIqZGJ2HyXf7/4gScu8OPdzYMnCHS5FAgQERFpBGo0GGCMORtnRsAvcXIIGGAb8O+aPK+IiEhDdTTX6//ahB0qs2/x9uL7iYiIiFR7MMAYEwEk4wQBBuIEAPKB+UCatfbD6j6niIjIaW3jIogfAWVO3/dB1mKaRfT072bzW5d52OLtzSK0Ok9EREROqLa/DIwxvYEU4GagBU4QYAvwL2CWtXZvdZ1LRESkwVj2KKRPxRM3ivHHxpKZfbhEl8SYVkyPmol7yzyu6X83Uzgfg4/UnEzSvAUlcgYARHsLSMnJZBK9sbgY2L1tLbwYEREROV1UORhgjLkDJwjQBycAkAe8AfzTWvvfqh5fRESkwdq4CNKnAk4pv5HefawiJSDTv8HHyB3TcBeWCoxe/SR3dXiAmP3pJIesoJcnnHHudgEBgWhvATM8+0gI2UmYdaoEBM0PICIiIo1WdcwMeK7wOQtIA1601u6vhuOKiIg0bPEj8MSNwr1lHgDJoenkGx+pkYmYsEPY/Nak5mSSHLLCv4sndiSj+Rr3YSc4kJCXR0p2bMA+KTmZJITs9B8zKaqdUyXAVa0VhUVEROQ0Vh3BgNdwZgGkV8OxREREGg+Xi/HHxjLSu4/k0HTWh4eT5t4aUCEgzVtAL084CXl5zPUmsf1gT+45/KC/fa43ySkfmH/iQn8SvQmzLpILZxO4t8xTuUAREREJUOVggLX2luoYiIiISGOT5TlCZvZhVpFCvvGR5t5aYv3/gdAQxrnbkZId61z073ExdtDdRK9+Ek/cKOYfG4s9Kc+AxVkakBTVzgkEJE1UIEBEREQCVEfOgF9WZj9r7UtVPbeIiMjpLGOzs6rO4iI1MjFgRkBxB0JDSI1M9N/9f6f1aG676Xzc8SOYU2YFgos0I0BERESCqo5lArMBW4H+prC/ggEiItKoHc31+r82YYfK7Fu8/WiuN+ACP97dPHiCQJdLgQAREREJqrpKC3qBhcCGajqeiIhIg9cs4sR/wza/dZl9i7cX309ERESkMqrjr4l0YDBwHdAep6LAXGttbjUcW0RE5PSycRHEj4Ayp+/7IGsxA7sPBpzygak5maR5C0rkDACnVGBKTiaT6I3FxcDubWv7VYmIiEgDUx0JBC8xxnQHUoBfArOAp40xLwNp1tqvqnoOERGR08KyRyF9Kp64UYw/NpbMkxL7ASTGtGJ61EzcW+YRnzSRxJjBjNwxjeSQFfTyhDPO3S4gIBDtLWCGZx8JITsJs05iwKBLAkREREQqoFrmGVprNwMTjDF/Bq7FCQz8BrjLGLMGeAGYY609Vh3nExERqXc2LoL0qYBTym+kdx+rSMFyouSfwcfIHdNwF5b8I30qL3T4mFahKwFIyMsjJTuW1MhETNghbH5rUnIySQjZCUByaDpJUe2cxIAuFyIiIiKVVa2LDq21XuBN4E1jTDfgdmAM8E/gCWPMFdbaT6vznCIiIvVC/Ag8caOcUn44F+75xhdwYZ+ak0lyyAr/Loc7DKDVnpX+7+d6k5zygfknLvQn0Zsw6yK5MIDg3jJPFQJERESkymrstoK1dru19i/Ar4GdQDOgXU2dT0REpE65XIw/Npa53iQA1oeHkxazlYjOc2nSfgkRneeSFrOV9eHhgHPhfyeTIGkiAJ64UczvMiFgJgE4ZQfnd5mAJ26UsyFpogIBIiIiUmU1ko7YGNMJGFv46AbkAi8Da2vifCIiInUty3OEzOzDrCKFfOMjzb21RDLAA6EhjHO3IyU71pkBkH2YrOvHEd/xPNzxI5hTZtLBizQjQERERKpNtQUDjDEu4Kc4SwOuKDz2/wN+D/zHWvt9dZ1LRESkvsnYvB9w7uSnRiYSEbo9aL8DoSGkRib6lwJkbN5P/MATF/jx7ubBEwS6XAoEiIiISLWp8jIBY8yZxpiHgO+ABcAlwIvAhdbaXtbaGQ0lEGCMiTHG2DIecypxzAHGmPeMMQeNMceNMV8ZY/5gjClZW0pEROqto7le/9cm7FCZfYu3F99PREREpLZUx8yAzYXPq4HJwGuNoGrAlziBj5Otr8hBjDHX4iRczAVeBw4CVwNPAgOBn1VplCIiUmuaRZz4L9Xmty6zb/H24vuJiIiI1Jbq+AvEAPlAR+AB4AFjzKn2sdbabtVw7rqyzlqbWpUDGGNaAGlAATDEWru6cPtfgP8Co4wxN1lrKzzbQEREqsnGRRA/Aspcy++DrMUM7D4YcMoHpuZkkuYtKJEzACDaW0BKTiaT6I3FxcDubWv7VYmIiIhUW86AMKBLNR2rsRiFU13hpaJAAIC1NtcYMwlYCvwGUDBARKQuLHsU0qfiiRvF+GNjycw+XKJLYkwrpkfNxL1lHvFJE0mMGczIHdNIDllBL08449ztAgIC0d4CZnj2kRCykzDrVAkImh9AREREpIZVORhgra2x8oT1WCdjzB1ANHAA+NRa+1UFjzG08Pn9IG0fA8eBAcaYJtbaHys/VBERqbCNiyB9KgDuLfMY6d3HKlICyv4ZfIzcMQ13aLqzIX0qL3T4mFahKwFIyMsjJTuW1MhETNghbH5rUnIySQjZCUByaDpJUe2cKgGuxvhfqYiIiNQlLVSsnMsKH37GmOXAaGvtt+U8xtmFz1knN1hrvcaYbcC5QCzwTVkHMsasKaWpRznHIiIixcWPwBM3CveWeYBz4Z5vfAEX9qk5mSSHrPDvcrjDAFrtWen/fq43ySkfmH/iQn8SvQmzLpILAwjuLfNULlBERETqhG5FVMxx4EGgH9C68JEELAOGAEuNMVHlPFbLwufSKi0UbW9VmYGKiEgVuFyMPzaWud4kANaHh5MWs5WIznNp0n4JEZ3nkhazlfXh4YBz4X8nkyBpIgCeuFHM7zIhYCYBOGUH53eZgCdulLMhaaICASIiIlInqjQzwBgTaa3NqetjVPB82UBFkhe+Yq39BYC1di9OksTiPjbGDAc+ARKB24Gnq2Oohc/2VB2ttf2CHsCZMdC3GsYiItKoZHmOkJl9mFWkkG98pLm3lkgGeCA0hHHudqRkxzozALIPk3X9OOI7noc7fgRzykw6eJFmBIiIiEidquoygW3GmEeB5yu6rt0Y0wv4K05JwgerOI6K2IJTyq+8dp2qQ+G0/n/hBAMGU75gQNGd/5altLc4qZ+IiNSSjM37AedOfmpkIhGh24P2OxAaQmpkon8pQMbm/cQPPHGBH+9uHjxBoMulQICIiIjUqaoGAz4EngAmG2NeB+YCn5V2p98YEwtcDvwSuAD4DvhbFcdQIdbaYTV06H2Fz+VdJvA/oD8QDwSs+TfGhAJnAl5ga3UNUEREyudortf/tQk7VGbf4u3F9xMRERGpz6oUDLDW/tIYMx14BPh14aPAGPMNsBs4BETgZN0/G2iLM/3dA/wZeLIBZcq/sPC5vBfv/wVuAa4AXjupbTDQFPi4Ab0/IiJ1a+MiiB8BZU7f90HWYppF9PTvZvNbl3nY4u3NIpSXV0RERE4P1VFacDUw3BhzFvArYBjQG/jJSV33AfOBN4E3rbX5VT13bTPGJAJfWGvzTto+FLi78NuXT2prCXQEvrfW7i7WNA+YBtxkjHmm8H3EGBMBPFTY57nqfxUiIo3QskchfSqeuFGMPzaWzOzDJbokxrRietRM3FvmcU3/u5nC+Rh8pOZkkuYtKJEzACDaW0BKTiaT6I3FxcDubWvhxYiIiIhUXbXdwrDWbgImAhhjmgKdcWYE5AB7T7oQPl1NA84tLCO4o3DbecDQwq//Yq1dedI+1wOzgBeBMUUbrbU/GGNScIICy40xc4CDwDU4syjmAa/XzMsQEWlENi6C9KmAU8pvpHcfq0gJyPRv8DFyxzTchSX/olc/yV0dHiBmfzrJISvo5QlnnLtdQEAg2lvADM8+EkJ2EmadKgFB8wOIiIiI1EM1Mp/RWnsc2FT4aEj+g3Nxfz4wAgjDWfIwF5hhrV1Rxr4lWGsXGGOScJZMjMRZUrEZ+D9gurX2lJUERETkFOJH4IkbhXvLPACSQ9PJNz5SIxMxYYew+a1JzckkOeTEr3BP7EhG8zXuw05wICEvj5Ts2IB9UnIySQjZ6T9mUlQ7p0qAS1V7RUREpP7T4sYKsNb+G/h3BfeZDcwuoz0DuLJKAxMRkdK5XIw/NpaR3n0kh6azPjycNPfWgAoBad4CennCScjLY643ie0He3LP4ROFbuZ6k5zygfknLvQn0Zsw6yK5cDaBe8s8lQsUERGR04ZuX4iISIOW5TlCZvZhJnhTeKXg4hLT/cEpETjO3Y5XCi5mgjeFf+w5hwP9nVQwnrhRzO8yIWBZAThlB+d3mYAnbpSzIWmiAgEiIiJy2tDMABERadAyNu8HnIv31MjEgBkBxR0IDSE1MtF/9/+d1qO57abzccePYE6ZFQgu0owAEREROe0oGCAiIg3a0Vyv/2sTdqjMvsXbj+Z6Ay7w493NgycIdLkUCBAREZHTjpYJiIhIg9Ys4kTc2+a3LrNv8fbi+4mIiIg0NAoGiIjI6WXjIvD5ACcfwKyMbTyzdBOzMraR5Tni9PH5nH7AwO5tAad8YGpOJtHegqCHjfYWkJqTicEXsJ+IiIhIQ1Qrtz2MManAS9barbVxPhERaaCWPQrpU/HEjWL8sbFkZh8u0SUxphXTo2Y62f2TJhJ/yX0kxrRi5I5pJIesoJcnvEQSwWhvATM8+0gI2UmYdRIDBl0SICIiItJA1NYcyAeAFGNMkrV2c9FGY0wTYIC1dlktjUNERE5XGxdB+lTAKeM30ruPVaQEZPk3+Bi5YxruwnJ/pE+FDglMj1rg35aQl0dKdiypkYmYsEPY/Nak5GSSELITgOTQdJKi2jmJAV2aQCciIiINU20uiHwVWGaMGWKt3VK4rRXwERBS6l4iIiIA8SPwxI1y7vjjXLTnG1/ARX1qTibJISv8u3jiRuHG+PcBmOtNYpI3xV81AGASvQmzLpILAwbuLfNUIUBEREQatNq65WGBvwEzgOXGmDOLtZlaGoOIiJzOXC7GHxvLXG8SAOvDw0mL2UpE57k0ab+EiM5zSYvZyvrwcMC56P/9sbFwzk8haSLgBAfmd5kQMJsAnLKD87tMwBM3ytmQNFGBABEREWnQajVVsrV2mjHGhRMQSAJycAIFIiIiZcryHCEz+zCrSCHf+Ehzbw1Y9w9wIDSEce52pGTHOnf/sw+T5TlC/CX3QcfzcMePYI7LRZbnCBmb93M010uziFAGdm/r5AjwXaQZASIiItIo1FYwwH/331r7aFFAALipls4vIiKnuYzN+wHnLn5qZCIRoduD9jsQGkJqZKJ/GUDG5v3OhX6xC/x4d/PgCQJdLgUCREREpFGorWDABOBY0TfW2ocLAwLv1tL5RUTkNHc01+v/2oQdKrNv8fbi+4mIiIiIo8o5A4wx9xtjepTVx1r7N2vtsZO2PQg8BRyp6hhERKThaxZxIn5t81uX2bd4e/H9RERERMRRHQkEHwKSi28wxkSWZ0dr7cPW2lbVMAYRETkdbVwEPh/g5ASYlbGNZ5ZuYlbGNrI8hbFinw82LmJg97aAUz4wNSeTaG9B0ENGewtIzcnE4By3aD8REREROaGmbpfca4z5rbW2/ckNxpgOwJGTZwqIiEgjs+xRSJ+KJ24U44+NJTP7cIkuiTGtmB41E/eWecQnTSQxZjAjd0wjOWQFvTzhjHO3C0giGO0tYIZnHwkhOwmzToWAoLkBRERERBq5mpw7GV3K9juASUBYDZ5bRETqs42LIH0qAO4t8xjp3ccqUgJK/hl8jNwxDXdourMhfSovdPiYVqErAUjIyyMlO5bUyERM2CFsfmtScjJJCNkJQHJoOklR7ZwKAa7aqqQrIiIicnqoq4WU+qtMRKQxix+BJ24U7i3zAOfCPd/4Ai7sU3MySQ5Z4d/lcIcBtNqz0v/9XG+SUz4w/8R/KZPoTZh1kVwYQHBvmadSgSIiIiJB6KJcRERqn8vF+GNjmetNAmB9eDhpMVuJ6DyXJu2XENF5LmkxW1kfHg44F/53MgmSJgLgiRvF/C4TAmYSgFN2cH6XCXjiRjkbkiYqECAiIiIShFIsi4hIrcvyHCEz+zCrSCHf+Ehzbw1Y+w9wIDSEce52pGTHOjMAsg+Tdf044juehzt+BHNcLrI8R8jYvJ+juV6aRYQysHtbJ0eA7yLNCBAREREpQ3UFA2w1HUdERBqBjM37AedOfmpkIhGh24P2OxAaQmpkon8pQMbm/cQPPHGBH+9uHjxBoMulQICIiIhIGaorGDDJGHMt8Hnh44xqOq6IiDRAR3O9/q9N2KEy+xZvL76fiIiIiFRedQQDlgJ9gL6Fj18XNRhj0oEviz3+XzWcT0RETnPNIk7892PzW5fZt3h78f1EREREpPKq/FeVtfYyAGNMLNC/2KMPcHHho2gZgQ84WtVziohIPbRxEcSPgDLX8vsgazEDuw8GnPKBqTmZpHkLSuQMAIj2FpCSk8kkemNxMbB729p+VSIiIiINUrXdYrHWbgW2AnOLthlj4gkMEPQGWqIcAyIiDcuyRyF9Kp64UYw/NpbM7MMluiTGtGJ61EzcW+YRnzSRxJjBjNwxjeSQFfTyhDPO3S4gIBDtLWCGZx8JITsJs06VgKD5AURERESkwmp0vqW1NgvIAl4FMMYY4BygX02eV0REatHGRZA+FQD3lnmM9O5jFSkBZf8MPkbumIY7NN3ZkD6VFzp8TKvQlQAk5OWRkh1LamQiJuwQNr81KTmZJITsBCA5NJ2kqHZOlQCXquKKiIiIVFWtLr601lpgQ+FDREQagvgReOJG4d4yD3Au3PONL+DCPjUnk+SQFf5dDncYQKs9K/3fz/UmOeUD809c6E+iN2HWRXJhAMG9ZZ7KBYqIiIhUE91eERGRqnG5GH9sLHO9SQCsDw8nLWYrEZ3n0qT9EiI6zyUtZivrw8MB58L/TiZB0kQAPHGjmN9lQsBMAnDKDs7vMgFP3ChnQ9JEBQJEREREqonSMouISJVkeY6QmX2YVaSQb3ykubeWSAZ4IDSEce52pGTHOjMAsg+Tdf044juehzt+BHPKTDp4kWYEiIiIiFQzBQNERKRKMjbvB5w7+amRiUSEbg/a70BoCKmRif6lABmb9xM/8MQFfry7efAEgS6XAgEiIiIi1UzLBEREpEqO5nr9X5uwQ2X2Ld5efD8RERERqV0KBoiISJU0izgxyczmty6zb/H24vuJiIiISO1SMEBERErauAh8PsDJCTArYxvPLN3ErIxtZHmOOH18Pti4iIHd2wJO+cDUnEyivQVBDxntLSA1JxODc9yi/URERESk9um2jIiIBFr2KKRPxRM3ivHHxpKZfbhEl8SYVkyPmol7yzzikyaSGDOYkTumkRyygl6ecMa52wUkEYz2FjDDs4+EkJ2EWadKQND8ACIiIiJSKxQMEBGREzYugvSpALi3zGOkdx+rSAko+2fwMXLHNNyh6c6G9Km80OFjWoWuBCAhL4+U7FhSIxMxYYew+a1JyckkIWQnAMmh6SRFtXOqBLg0QU1ERESkLigYICIiJ8SPwBM3CveWeYBz4Z5vfAEX9qk5mSSHrPDvcrjDAFrtWen/fq43ySkfmH/iQn8SvQmzLpILAwjuLfNULlBERESkDumWjIiInOByMf7YWOZ6kwBYHx5OWsxWIjrPpUn7JUR0nktazFbWh4cDzoX/nUyCpIkAeOJGMb/LhICZBOCUHZzfZQKeuFHOhqSJCgSIiIiI1CHNDBAREb8szxEysw+zihTyjY8099aAtf8AB0JDGOduR0p2rDMDIPswWdePI77jebjjRzDH5SLLc4SMzfs5muulWUQoA7u3dXIE+C7SjAARERGRekDBABER8cvYvB9w7uSnRiYSEbo9aL8DoSGkRib6lwJkbN5P/MATF/jx7ubBEwS6XAoEiIiIiNQDWiYgIiJ+R3O9/q9N2KEy+xZvL76fiIiIiNR/CgaIiIhfs4gTE8Zsfusy+xZvL76fiIiIiNR/CgaIiDR0GxeBzwc4OQFmZWzjmaWbmJWxjSzPEaePzwcbFzGwe1vAKR+YmpNJtLcg6CGjvQWk5mRicI5btJ+IiIiInB50K0dEpCFb9iikT8UTN4rxx8aSmX24RJfEmFZMj5qJe8s84pMmkhgzmJE7ppEcsoJennDGudsFJBGM9hYww7OPhJCdhFmnSkDQ/AAiIiIiUm8pGCAi0lBtXATpUwFwb5nHSO8+VpESUPbP4GPkjmm4Q9OdDelTeaHDx7QKXQlAQl4eKdn/v737D48ruwv7/z6jkSJV9saOrEw2a4iwjLIlSuwSiPCarpKloYilbWIJkRZCEhNB+o3jBEKxaU1R29C1S6BhWQqLwmZTCI9rhAjfYhaSLhutcUAm2Qa6Ia5iObPBzmZiO1awFTnSSKd/3NFoJEuyZcv6Ne/X89znju45586d1Vl57ueecz7b6K5pIVReJo5vpmt0gOaK8wB0pvtpra1PsgSkHGwmSZK0VhgMkKT1qqmNXGMHmaFeILlxHw+TM27su0cH6Kw4UWwy/JL72PTlTxZ/PpZvTdIHjk/f6B9iJ5UxRWchgJAZ6jVdoCRJ0hrjYxxJWq9SKfaP7OVYvhWAZ6uq6Gk4S/U9x3jBiz9O9T3H6Gk4y7NVVUBy4/8ODkHrQQByjR30bT0wYyQBJGkH+7YeINfYkRxoPWggQJIkaY1xZIAkrVODuSsMZIc5RRfjYZKezNkZc/8BLqUr2Jeppyu7LRkBkB1m8I37aLr7VWSa2jiaSjGYu8LJMxe5ei3Phuo0u7dvSdYImNzliABJkqQ1ymCAJK1TJ89cBJIn+d01LVSnn5uz3qV0Bd01LcWpACfPXKRp9/QNflNm49wLBKZSBgIkSZLWKKcJLEII4fEQQrzB9uRNnqvhBuc5eqc/j6T17eq1fPF1qLy8YN3S8tJ2kiRJWp8cGbA4HwWy85S9GdgGPLHIc/514byzPbvI80jSDBuqp//Ex/HNC9YtLS9tJ0mSpPXJb3yLEGP8KHPcuIcQNgE/A4wBjy/ytJ+JMXbf3pVJ0vV2b98CJOkDu0cH6MlPXLdmAEBdfoKu0QEOsZNIqthOkiRJ65fBgKXxZqAGOBpjvLjSFyNpHTt9HJraYMGF/SZh8Ama7n2QloZNtJ87QmfFCXbkqtiXqZ8REKjLT/BI7gLNFeepjEmWgDnXB5AkSdK6YjBgaXQV9r95C21fGkL4CaAOuAT8RYzxb5bsyiStH089BP2HyTV2sH9kLwPZ4euqtDRs4uHax8gM9cL9B3i4dohMuh+A5rExurLb6K5pIVReJo5vpmt0gOaK8wB0pvtpra1PsgSkXFJGkiRpPTMYcJtCCLuAVwKDMcanbuEUry9spef8BPCWGOMXb/IaPj1P0b23cD2SVqPTx6H/MACZoV7a8xc4RRexZB3YwCTt544Ub/55+giZklMcy7cm6QPHp9scYieVMUVnoU1mqNd0gZIkSWXARz+378cL+55Ftvs68J+AVwObC1sr8BTwWuDJEELtEl2jpLWuqY1cY0fxx850P++rfJTKu56hqu5JKu96hvdVPlq8qQeS+vcfKL7u23pgRvAAkrSDfVsPTJ+79aCBAEmSpDJQdiMDQghZ4GWLaPKRGOOPzHOuFwKd3MLCgTHGrwD/ftbhp0MI3wv8OdACvB34lZs416vnub5PA9++mOuStEqlUuwf2Ut7/gKd6X6eraqiJ3OW6vRzxSo9+Ql25KpoHhvjWL6VvpG9HH1gN7x0B5mmNo4uuM7ALkcESJIklZGyCwYAQ8C1RdT/0gJlPwL8A5Zw4cAYYz6E8EGSYMD93EQwQNL6N5i7wkB2mFN0MR4m6cmcvS4zwKV0Bfsy9XRltyXTAbLDDOau0FRyg9+U2Tj3AoGplIEASZKkMlJ2wYAY4/cs4emmFg58dAnPCXChsHeagCQATp5J4o2RFN01LTNGBJS6lK6gu6aluC7AyTMXzQ4gSZKk67hmwC0KIbQAO0gWDvzEEp/+uwr7s0t8Xklr1NVr+eLrUHl5wbql5aXtJEmSpCkGA27d1MKBC6YTDCG8MIRwbwjh7lnHW0IIVXPUfwD4ycKPv7MkVyppzdtQPT2QK45vXrBuaXlpO0mSJGmK3xJvQQjhLuCHSBYO/PANqr8R+FCh3ltLjh8BXlFII3iucOxVwAOF1z8XY/zkEl2ypNXo9HFoaoMFF/abhMEn2L39fiBJH9g9OkBPfuK6NQMA6vITdI0OcIidRFLs3r5luT+VJEmS1gCDAbfmh0nm89/OwoG/TRIo+E6gDagEcsAx4JEY44mluFBJq9RTD0H/YXKNHewf2ctAdvi6Ki0Nm3i49jEyQ700tR6kpeF+2s8dobPiBDtyVezL1M8ICNTlJ3gkd4HmivNUxiRloOsFSJIkaS4GA25BjPHXgV+/ybqPM0fawRjjbwG/taQXJmltOH0c+g8DkBnqpT1/gVN0EUtmbgUmaT93hEy6PznQf5hHX/I0m9LJgKHmsTG6stvormkhVF4mjm+ma3SA5orzAHSm+2mtrU9SBqacESZJkqSZDAZI0nJraiPX2EFmqBdIbtzHw+SMG/vu0QE6K6YHCA2/5D42fXl65tCxfGuSPnB8+kb/EDupjCk6CwGEzFAvDO4xZaAkSZKu4+MiSVpuqRT7R/ZyLN8KwLNVVfQ0nKX6nmO84MUfp/qeY/Q0nOXZqmSN0WP5Vt7BIWg9CECusYO+rQdmjCSAJO1g39YD5Bo7kgOtBw0ESJIkaU6ODJCkZTaYu8JAdphTdDEeJunJnL1uMcBL6Qr2Zerpym5LRgBkhxl84z6a7n4VmaY2ji646OAuRwRIkiRpQQYDJGmZnTyTrDsaSdFd00J1+rk5611KV9Bd01KcCnDyzEWadk/f4DdlNs69QGAqZSBAkiRJC3KagCQts6vX8sXXofLygnVLy0vbSZIkSbfDYIAkLbMN1dODsuL45gXrlpaXtpMkSZJuh8EASVpmu7dvAZL0gd2jA9TlJ+asV5efoHt0gMDkjHaSJEnS7fIxkyQthdPHoakNFlzYbxIGn6Dp3gdpadhE+7kjdFacYEeuin2Z+hmLCNblJ3gkd4HmivNUxiRLwJzrA0iSJEm3wGCAJN2upx6C/sPkGjvYP7KXgezwdVVaGjbxcO1jZIZ64f4DPFw7RCbdD0Dz2Bhd2W1017QQKi8TxzfTNTpAc8V5ADrT/bTW1idZAlIO6JIkSdLtMxggSbfj9HHoPwxAZqiX9vwFTtFFLJmFFZik/dyR4s0/Tx8hU3KKY/nWJH3g+HSbQ+ykMqboLLTJDPWaLlCSJElLxkdMknQ7mtrINXYUf+xM9/O+ykepvOsZquqepPKuZ3hf5aPFm3ogqX//geLrvq0HZgQPIEk72Lf1wPS5Ww8aCJAkSdKScWSAJN2OVIr9I3tpz1+gM93Ps1VV9GTOUp1+rlilJz/BjlwVzWNjHMu30jeyl6MP7IaX7iDT1MbRBdcZ2OWIAEmSJC05gwGSdBsGc1cYyA5zii7GwyQ9mbMzFgIEuJSuYF+mnq7stmQ6QHaYwdwVmkpu8JsyG+deIDCVMhAgSZKkJec0AUm6DSfPXASSYf3dNS3XBQKmXEpX0F3TUpwOMNVOkiRJWgkGAyTpNly9li++DpWXF6xbWl7aTpIkSVpuBgMk6TZsqJ6ebRXHNy9Yt7S8tJ0kSZK03AwGSNJsp4/D5CSQrAnwoZNf4Fef/DwfOvkFBnNXkjqTk3D6OLu3bwGS9IHdowPU5SfmPGVdfoLu0QECyXmn2kmSJEkrwUdTklTqqYeg/zC5xg72j+xlIDt8XZWWhk08XPsYmaFemloP0tJwP+3njtBZcYIduSr2ZepnrB1Ql5/gkdwFmivOUxmTlIFzLhYoSZIkLRODAZI05fRx6D8MQGaol/b8BU7RVVz0D5IRAO3njpBJ9ycH+g/z6EueZlP6kwA0j43Rld1Gd00LofIycXwzXaMDNFecB6Az3U9rbX2SMjDl4CxJkiStDIMBkjSlqY1cYweZoV4guXEfD5Mzbuy7RwforDhRbDL8kvvY9OVPFn8+lm9N0geOT9/oH2InlTFFZyGAkBnqhcE9pgyUJEnSivGxlCRNSaXYP7KXY/lWAJ6tqqKn4SzV9xzjBS/+ONX3HKOn4SzPVlUByY3/OzgErQcByDV20Lf1wIyRBJCkHezbeoBcY0dyoPWggQBJkiStKEcGSFLBYO4KA9lhTtHFeJikJ3N2xtx/gEvpCvZl6unKbktGAGSHGXzjPprufhWZpjaOplIM5q5w8sxFrl7Ls6E6ze7tW5I1AiZ3OSJAkiRJq4LBAEkqOHnmIpA8ye+uaaE6/dyc9S6lK+iuaSlOBTh55iJNu6dv8JsyG+deIDCVMhAgSZKkVcFpApJUcPVavvg6VF5esG5peWk7SZIkaS0wGCBJBRuqpwdLxfHNC9YtLS9tJ0mSJK0FBgMkqWD39i1Akj6we3SAuvzEnPXq8hN0jw4QmJzRTpIkSVorfJwlaX07fRya2mDBhf0mYfAJmu59kJaGTbSfO0JnxQl25KrYl6mfsYhgXX6CR3IXaK44T2VMsgTMuT6AJEmStIoZDJC0fj31EPQfJtfYwf6RvQxkh6+r0tKwiYdrHyMz1Av3H+Dh2iEy6X4AmsfG6Mpuo7umhVB5mTi+ma7RAZorzgPQme6ntbY+yRKQcqCVJEmS1g6DAZLWp9PHof8wAJmhXtrzFzhFF7FkdlRgkvZzR4o3/zx9hEzJKY7lW5P0gePTbQ6xk8qYorPQJjPUa7pASZIkrTk+ypK0PjW1kWvsKP7Yme7nfZWPUnnXM1TVPUnlXc/wvspHizf1QFL//gPF131bD8wIHkCSdrBv64Hpc7ceNBAgSZKkNceRAZLWp1SK/SN7ac9foDPdz7NVVfRkzlKdfq5YpSc/wY5cFc1jYxzLt9I3spejD+yGl+4g09TG0QXXGdjliABJkiStWQYDJK1Lg7krDGSHOUUX42GSnszZGQsBAlxKV7AvU09XdlsyHSA7zGDuCk0lN/hNmY1zLxCYShkIkCRJ0prlNAFJ69LJMxeBZFh/d03LdYGAKZfSFXTXtBSnA0y1kyRJktYzgwGS1qWr1/LF16Hy8oJ1S8tL20mSJEnrlcEASevShurpWVBxfPOCdUvLS9tJkiRJ65XBAEnr0u7tW4AkfWD36AB1+Yk569XlJ+geHSAwOaOdJEmStJ75CEzSutSU2UhLwybazx2hs+IEO3JV7MvUz1g7oC4/wSO5CzRXnKcyJikD51wsUJIkSVpnDAZIWjtOH4emNlgw5d8kDD4BTW08XPsYmXQ/AM1jY3Rlt9Fd00KovEwc30zX6ADNFecB6Ez301pbn6QMTDloSpIkSeubwQBJa8NTD0H/YXKNHewf2ctAdvi6Ki0Nm5IAwFAvvGIPmaG+YtmxfGuSPnB8+kb/EDupjCk6CwGDzFAvDO4xZaAkSZLWPR9/SVr9Th+H/sNAcsPefu5IcY7/lMAk7eeOJDf0AJ/tg1fsASDX2EHf1gPF9IFTIsnUgFxjR3Kg9aCBAEmSJJUFRwZIWv2a2sg1dhRv9DvT/YyHyRlD/rtHB+isOFFskmvsINPeA6/sINPUxtEFpxbsckSAJEmSyorBAEmrXyrF/pG9tOcv0Jnu59mqKnoyZ6lOP1es0pOfYEeuiuaxMY7lW+kb2cvRVGrGDX5TZuPcCwTOqidJkiStdwYDJK16g7krDGSHOUUX42GSnszZGVkBAC6lK9iXqacruy1ZGyA7zGDuitkBJEmSpDm4ZoCkVe/kmYtAMse/u6blukDAlEvpCrprWoprA0y1kyRJkjSTwQBJq97Va/ni61B5ecG6peWl7SRJkiRNMxggadXbUD09oymOb16wbml5aTtJkiRJ0wwGSFr1dm/fAiTpA7tHB6jLT8xZry4/QffoQDHt4FQ7SZIkSTP52EzSqteU2UhLwybazx2hs+IEO3JV7MvUz1g7oC4/wSO5CzRXnKcypujbesDFAyVJkqR5lO3IgBBCZQjh3SGED4UQPhNCGAshxBDC22+i7VtCCKdCCFdDCF8LIXwihPADt3gdS3Yuac04fRwmk6f3g7krfOjkF/jVJz/Ph05+gcHclaTO5GRSr/D64drH6Ez3A9A8NkZXdhvXznfyja+8nmvnO+nKbqN5bAyAznQ/v1L7WPE9JEmSJM1UziMDaoEPFF7ngC8D33SjRiGE9wPvBc4BPUAV8Cbgf4YQ3hVjfORmL2ApzyWtGU89BP2HyTV2sH9kLwPZ4euqtDRs4uHax8gM9ULrQbj7VcnrgmP51iR94Ph0PPMQO6mMqWLAIDPUC4N74N4H7/hHkiRJktaash0ZAHwd+H7gpTHGlwCP3ahBCOE+kpv3IeBVMcafjDG+E3g18FXg/SGEhpt586U8l7RmnD4O/YeB5Ga9/dyR4vz+KYFJ2s8dmb75L9Sn9SAAucYO+rYeKKYPnBJJpgbkGjum6xsIkCRJkuZUtiMDYoxjwBOLbPaOwv4XYozF/GUxxmwI4deAnwPeBvz8Mp9LWhua2sg1dhRv9DvT/YyHSbprWgiVl4njm+keHaCz4kSxSa6xg0xTW3Jjf/eryDS1cTSVYjB3hZNnLnL1Wp4N1Wl2b9+SrBEwucsRAZIkSdINlG0w4BY9UNj/yRxlT5DcwD/Azd3AL+W5pLUhlWL/yF7a8xfoTPfzbFUVPZmzVKefK1bpyU+wI1dF89gYx/Kt9I3s5WiqMAqg5Aa/KbNx7gUCUykDAZIkSdINGAy4SSGEWuAe4GqM8fk5qny+sG9aznMVzvfpeYruvZn20nIZzF1hIDvMKboYD5P0ZM7OyAgAcCldwb5MPV3Zbcm6ANlhBnNXzAwgSZIkLaFyXjNgsV5Y2H9tnvKp45uW+VzSmnHyzEUgmd/fXdNyXSBgyqV0Bd01LcV1AabaSZIkSVoaa3pkQAghC7xsEU0+EmP8kTt0OVPicp8rxvjquY4XRgx8+xJej3Rbrl7LF1+HyssL1JxZXtpOkiRJ0u1b08EAkpX4ry2i/pdu472mnta/cJ7yGz3tv1PnktaMDdXTf3Li+OYF65aWl7aTJEmSdPvW9DfsGOP3LON7jYQQzgP3hBDunmOu/7cW9oPLeS5pLdm9fQuQpA/sHh2gJz8x51SBuvwEXaMDHGInkVSxnSRJkqSl4ZoBi/Nnhf33zVHWNqvOcp5LWjmnj8PkJJAsEPihk1/gV5/8PB86+QUGc1eSOpOTcPo4TZmNtDRs4ki6hx+uOMEjuQvU5SdmnK4uP8EjuQv8cMUJjqR7+K6GTS4eKEmSJC2xNT0yYAX8BvBm4N+FED4aY7wMEEJoAN4JfAP4UGmDEMLdJMP+n48xfu12ziWtOk89BP2HyTV2sH9kLwPZ4euqtDRs4uHax8gM9cL9B3i4dohMuh+A5rExurLb6K5pIVReJo5vpmt0gOaK8wB0pvtpra2HyV1JykBJkiRJS6KsgwEhhINMp9/bWdi/LYTw3YXXfx5j/OBU/RjjJ0MIvwz8FPA3IYReoAr4IeBFwLtijNlZb/MQ8BbgbcDjt3kuafU4fRz6DwOQGeqlPX+BU3QVMwBAMh2g/dyR4s0/Tx8hU3KKY/nWJH3g+HSbQ+ykMqboLLTJDPXC4B6498E7/pEkSZKkclHWwQCSIfqts47dV9imfLC0MMb43hDC3wD7gB8HJoFngF+MMf7RYt58Kc8lLbumNnKNHcnNOslT/PEwOeMpf/foAJ0VJ4pNco0dZO5phKePkGvsoG9kL3HWaIJIir6tB2itrU/O3XrQQIAkSZK0xMo6GBBjfO0ttvsw8OGbrPtW4K1LcS5pVUml2D+yl/b8BTrT/TxbVUVP5izV6eeKVXryE+zIVdE8NsaxfCt9I3s5+sBueOkOMk1tHE2lGMxd4eSZi1y9lmdDdZrd27ckawRM7nJEgCRJknSHlHUwQNKtG8xdYSA7zCm6GA+T9GTOXpcZ4FK6gn2Zerqy25LpANlhBnNXaCq5wW/KbJx7gcBUykCAJEmSdIe4IpekW3LyzEUgGdbfXdMyZ4pASAIC3TUtxbUEptpJkiRJWjkGAyTdkqvX8sXXofLygnVLy0vbSZIkSVoZBgMk3ZIN1dOzjOL45gXrlpaXtpMkSZK0MgwGSLolu7dvAZL0gd2jA9TlJ+asV5efoHt0gMDkjHaSJEmSVo6P6CTdkqbMRloaNtF+7gidFSfYkatiX6Z+xtoBdfkJHsldoLniPJUxSRk452KBkiRJkpaVwQBJ004fh6Y2WDDl3yQMPgFNbTxc+xiZdD8AzWNjdGW30V3TQqi8TBzfTNfoAM0V5wHoTPfTWlufpAxMOShJkiRJWkkGAyQlnnoI+g+Ta+xg/8heBrLD11VpadiUBACGeuEVe8gM9RXLjuVbk/SB49M3+ofYSWVM0VkIGGSGemFwjykDJUmSpBXm4zlJyYiA/sNAcsPefu5IcY7/lMAk7eeOJDf0AJ/tg1fsASDX2EHf1gPF9IFTIsnUgFxjR3Kg9aCBAEmSJGkVcGSAJGhqI9fYUbzR70z3Mx4mZwz57x4doLPiRLFJrrGDTHsPvLKDTFMbRxecWrDLEQGSJEnSKmIwQBKkUuwf2Ut7/gKd6X6eraqiJ3OW6vRzxSo9+Ql25KpoHhvjWL6VvpG9HE2lZtzgN2U2zr1A4Kx6kiRJklaWwQBJDOauMJAd5hRdjIdJejJnZ2QFALiUrmBfpp6u7LZkbYDsMIO5K2YHkCRJktYg1wyQxMkzF4Fkjn93Tct1gYApl9IVdNe0FNcGmGonSZIkaW0xGCCJq9fyxdeh8vKCdUvLS9tJkiRJWjsMBkhiQ/X0jKE4vnnBuqXlpe0kSZIkrR0GAySxe/sWIEkf2D06QF1+Ys56dfkJukcHimkHp9pJkiRJWlt8rCetV6ePQ1MbLJjybxIGn6Dp3gdpadhE+7kjdFacYEeuin2Z+hlrB9TlJ3gkd4HmivNUxhR9Ww+4eKAkSZK0RhkMkNajpx6C/sPkGjvYP7KXgezwdVVaGjbxcO1jZIZ64f4DPFw7RCbdD0Dz2Bhd2W1017QQKi8TxzfTNTpAc8V5ADrT/bTW1sPkriRtoCRJkqQ1xWCAtN6cPg79hwHIDPXSnr/AKbqKGQAgmQ7Qfu5I8eafp4+QKTnFsXxrkj5wfLrNIXZSGVN0FtpkhnphcA/c++Ad/0iSJEmSlpaP9KT1pqmNXGNH8cfOdD/vq3yUyrueoaruSSrveob3VT5avKkHkvr3Hyi+7tt6YEbwAJK0g31bD0yfu/WggQBJkiRpjXJkgLTepFLsH9lLe/4Cnel+nq2qoidzlur0c8UqPfkJduSqaB4b41i+lb6RvRx9YDe8dAeZpjaOLrjOwC5HBEiSJElrnMEAaZ0ZzF1hIDvMKboYD5P0ZM7OWAgQ4FK6gn2Zerqy25LpANlhBnNXaCq5wW/KbJx7gcBUykCAJEmStMY5TUBaZ06euQgkw/q7a1quCwRMuZSuoLumpTgdYKqdJEmSpPXPYIC0zly9li++DpWXF6xbWl7aTpIkSdL6ZjBAWmc2VE/P/onjmxesW1pe2k6SJEnS+mYwQFpndm/fAiTpA7tHB6jLT8xZry4/QffoAIHJGe0kSZIkrX8+CpTWmabMRloaNtF+7gidFSfYkatiX6Z+xtoBdfkJHsldoLniPJUxSRk452KBkiRJktYlgwHSWnD6ODS1wYIp/yZh8AloauPh2sfIpPsBaB4boyu7je6aFkLlZeL4ZrpGB2iuOA9AZ7qf1tr6JGVgysFCkiRJUjkwGCCtdk89BP2HyTV2sH9kLwPZ4euqtDRsSgIAQ73wij1khvqKZcfyrUn6wPHpG/1D7KQypugsBAwyQ70wuMeUgZIkSVKZ8DGgtJqdPg79h4Hkhr393JHiHP8pgUnazx1JbugBPtsHr9gDQK6xg76tB4rpA6dEkqkBucaO5EDrQQMBkiRJUhlxZIC0mjW1kWvsKN7od6b7GQ+TM4b8d48O0Flxotgk19hBpr0HXtlBpqmNowtOLdjliABJkiSpDBkMkFazVIr9I3tpz1+gM93Ps1VV9GTOUp1+rlilJz/BjlwVzWNjHMu30jeyl6Op1Iwb/KbMxrkXCJxVT5IkSVJ5MBggrWKDuSsMZIc5RRfjYZKezNkZWQEALqUr2Jeppyu7LVkbIDvMYO6K2QEkSZIkzcs1A6RV7OSZi0Ayx7+7puW6QMCUS+kKumtaimsDTLWTJEmSpLkYDJBWsavX8sXXofLygnVLy0vbSZIkSdJsBgOkVWxD9fRMnji+ecG6peWl7SRJkiRpNoMB0iq2e/sWIEkf2D06QF1+Ys56dfkJukcHimkHp9pJkiRJ0lx8fCitYk2ZjbQ0bKL93BE6K06wI1fFvkz9jLUD6vITPJK7QHPFeSpjir6tB1w8UJIkSdKCDAZIq9nkJA/XPkYm3Q9A89gYXdltdNe0ECovE8c30zU6QHPFeQA60/201tbD5K4kbaAkSZIkzcFggLTcTh+HpjZIpRjMXeHkmYtcvZZnQ3Wa3du3JE/1Jydh8AkAMkO9xabH8q1J+sDx6Rv9Q+ykMqboLAQMMkO9MLgH7n1weT+XJEmSpDXDYIC0nJ56CPoPk2vsYP/IXgayw9dVaWnYlIwGGOqF1oPJVmjTN7KXOKtNJJka0FpbP93GQIAkSZKkBRgMkJbL6ePQfxhInt635y9wii5iyTqegUnazx0pTgug/zC86XfhTb9LpqmNowuOJtjliABJkiRJN8VggLRcmtrINXYUh/13pvsZD5Mz5v93jw7QWXGi2CTX2EGmMKWgeJrMxrkXCEylDARIkiRJuikGA6Tlkkqxf2Qv7fkLdKb7ebaqip7MWarTzxWr9OQn2JGronlsjGP5VvpG9nLUhQAlSZIkLTGDAdIyGcxdYSA7zCm6GA+T9GTOzkgRCHApXcG+TD1d2W3JQoHZYQZzV0wVKEmSJGlJ+chRWiYnz1wEkgX/umtargsETLmUrqC7pqW4lsBUO0mSJElaKgYDpGVy9Vq++DpUXl6wbml5aTtJkiRJWgplGwwIIVSGEN4dQvhQCOEzIYSxEEIMIbx9gTa7Qwj/JYTwVyGECyGEb4QQvhBC+GAIYfsi3/+thfebb3vH7X9KrSYbqqdn5cTxzQvWLS0vbSdJkiRJS6Gc7zJqgQ8UXueALwPfdIM2vw/UA58EPgLkgV3AjwFvCiG8Psb4F4u8jj8EPjPH8U8t8jxa5XZv3wIk6QO7RwfoyU/MOVWgLj9B1+gAh9hJJFVsJ0mSJElLpZyDAV8Hvh/4TIzx+RBCN/DzN2jzX4HfjjF+qfRgCOHfAr8A/CbwykVex0djjI8vso3WoKbMRloaNtF+7gidFSfYkatiX6Z+RkCgLj/BI7kLNFecpzKm6Nt6wMUDJUmSJC25sg0GxBjHgCcW2ebIPEVHgENAcwihLsZ46XavT2vE6ePQ1AapFIO5K5w8c5Gr1/JsqE6ze/uW5EZ+chIGn4CmNh6ufYxMuh+A5rExurLb6K5pIVReJo5vpmt0gOaK8wB0pvtpra2HyV1gekFJkiRJS6hsgwFLLJJMGQCYWGTbnSGE9wDVwHngqRjjuSW8Nt0pTz0E/YfJNXawf2QvA9nh66q0NGxKAgBDvfCKPWSG+oplx/KtSfrA8ekb/UPspDKm6CwEDDJDvTC4B+598I5/HEmSJEnlw2DA0vhBYCPwlzHG4UW2ffesnydCCB8E3hNjvHYzJwghfHqeonsXeS26WaePQ/9hILlhb89f4BRdxXSAkKwN0H7uSHEkAJ/tg1fsgc/2kWvsoG9kL3FWACGSTA1ora1PAgGtBw0ESJIkSVpyBgNuUwjhW4BfJRkZ8N5FNP0C8C7gY8A54IXAdwMPAT8B3AX8qyW9WC2dpjZyjR3JDTvJkP7xMDljyH/36ACdFSeKTXKNHWTae+CVHWSa2ji64NSCXY4IkCRJknTHrOlgQAghC7xsEU0+EmP8kSV8/xeTrDtQD7wzxvjJm20bY+wH+ksOfR34vRDCXwJ/DfzLEMKRGONf38S5Xj3P9X0a+PabvSYtQirF/pG9tOcv0Jnu59mqKnoyZ6lOP1es0pOfYEeuiuaxMY7lW+kb2cvRVGrGDX5TZuPcCwTOqidJkiRJS2lNBwOAIeCmhtIXfOnGVW5OIRDwZ8DLgXfHGP/bUpw3xvh3IYQ/Bn4YuJ8kMKBVZjB3hYHsMKfoYjxM0pM5e12awEvpCvZl6unKbkvWBsgOM5i7YnYASZIkSStuTQcDYozfsxLvG0K4G3iSZE7+O5cqEFDiQmFfu8Tn1RI5eeYikMzx765pmTEioNSldAXdNS3FRQJPnrloMECSJEnSilvTwYCVEELYSjIiYDvwjhjjb96Bt2kp7M/egXNrCVy9li++DpWXF6xbWl7aTpIkSZJWisnLFyGE8M0k8/wbgR+7mUBACOHuEMK9IYQXzjr+j+eoG0IIPwvsAi4Cf7I0V66ltqF6Oo4WxzcvWLe0vLSdJEmSJK2Usr4zCSEcZDr93s7C/m0hhO8uvP7zGOMHS5r0Aw3Ap4GXhRC65zjt4zHGbMnPDwFvAd4GPF5y/OkQwiDwV8B5kmwCu4FmksUEfzjG+Pe38rl05+3evgVI0gd2jw7Qk5+4bs0AgLr8BF2jAxxiJ5FUsZ0kSZIkraSyDgYA3we0zjp2X2GbUhoMaCjsX13Y5vIJIHsT7/1+4DXAA8CLgEngi8CvAb8cY3SKwCrWlNlIS8Mm2s8dobPiBDtyVezL1M8ICNTlJ3gkd4HmivNUxhR9Ww+4XoAkSZKkVaGsgwExxtcusn64hfd4K/DWOY7/m8WeS3fY6ePQ1AapFIO5K5w8c5Gr1/JsqE6ze/uW5EZ+chIGn4CmNh6ufYxMOskO2Tw2Rld2G901LYTKy8TxzXSNDtBccR6AznQ/rbX1MLkrSRsoSZIkSSuorIMBUtFTD0H/YXKNHewf2ctAdvi6Ki0Nm5IAwFAvvGIPmaG+YtmxfGuSPnB8+kb/EDupjCk6CwGDzFAvDO6Bex+84x9HkiRJkhbiI0rp9HHoPwwkN+zt544QmJxRJTBJ+7kjyQ09wGf74BV7AMg1dtC39QBx1v9OkWRqQK6xIznQetBAgCRJkqRVwZEBUlMbucaO4o1+Z7qf8TA5Y8h/9+gAnRUnik1yjR1k2nvglR1kmto4uuDUgl2OCJAkSZK0qhgMkFIp9o/spT1/gc50P89WVdGTOUt1+rlilZ78BDtyVTSPjXEs30rfyF6OplIzbvCbMhvnXiBwVj1JkiRJWmkGA1T2BnNXGMgOc4ouxsMkPZmz16UJvJSuYF+mnq7stmRtgOwwg7krZgeQJEmStCa5ZoDK3skzF4Fkjn93Tct1gYApl9IVdNe0FNcGmGonSZIkSWuNwQCVvavX8sXXofLygnVLy0vbSZIkSdJaYjBAZW9D9fRsmTi+ecG6peWl7SRJkiRpLTEYoLK3e/sWIEkf2D06QF1+Ys56dfkJukcHimkHp9pJkiRJ0lrjo02VvabMRloaNtF+7gidFSfYkatiX6Z+xtoBdfkJHsldoLniPJUxRd/WAy4eKEmSJGnNMhggTU7ycO1jZNL9ADSPjdGV3UZ3TQuh8jJxfDNdowM0V5wHoDPdT2ttPUzuStIGSpIkSdIaYzBA69Pp49DUBqkUg7krnDxzkavX8myoTrN7+5bkqf7kJAw+AUBmqLfY9Fi+NUkfOD59o3+InVTGFJ2FgEFmqBcG98C9Dy7v55IkSZKkJWAwQOvPUw9B/2FyjR3sH9nLQHb4uiotDZuS0QBDvdB6MNkKbfpG9hJntYkkUwNaa+un2xgIkCRJkrRGGQzQ+nL6OPQfBpKn9+35C5yii1iyVmZgkvZzR4rTAug/DG/6XXjT75JpauPogqMJdjkiQJIkSdKaZzBA60tTG7nGjuKw/850P+Nhcsb8/+7RATorThSb5Bo7yBSmFBRPk9k49wKBqZSBAEmSJElrnsEArS+pFPtH9tKev0Bnup9nq6royZylOv1csUpPfoIduSqax8Y4lm+lb2QvR10IUJIkSVIZMRigdWUwd4WB7DCn6GI8TNKTOTsjRSDApXQF+zL1dGW3JQsFZocZzF0xVaAkSZKksuHjUK0rJ89cBJIF/7prWq4LBEy5lK6gu6aluJbAVDtJkiRJKgcGA7SuXL2WL74OlZcXrFtaXtpOkiRJktY7gwFaVzZUT898ieObF6xbWl7aTpIkSZLWO4MBWld2b98CJOkDu0cHqMtPzFmvLj9B9+gAgckZ7SRJkiSpHPg4VOtKU2YjLQ2baD93hM6KE+zIVbEvUz9j7YC6/ASP5C7QXHGeypiib+sBFw+UJEmSVFYMBmj1O30cmtoglWIwd4WTZy5y9VqeDdVpdm/fktzIT07C4BPQ1MbDtY+RSfcD0Dw2Rld2G901LYTKy8TxzXSNDtBccR6AznQ/rbX1MLkLTC8oSZIkqUwYDNDq9tRD0H+YXGMH+0f2MpAdvq5KS8OmJAAw1Auv2ENmqK9YdizfmqQPHJ++0T/ETipjis5CwCAz1AuDe+DeB+/4x5EkSZKk1cBHoVq9Th+H/sNAcsPefu5IcY7/lMAk7eeOJDf0AJ/tg1fsASDX2EHf1gPF9IFTIsnUgFxjR3Kg9aCBAEmSJEllxZEBWr2a2sg1dhRv9DvT/YyHyRlD/rtHB+isOFFskmvsINPeA6/sINPUxtEFpxbsckSAJEmSpLJkMECrVyrF/pG9tOcv0Jnu59mqKnoyZ6lOP1es0pOfYEeuiuaxMY7lW+kb2cvRVGrGDX5TZuPcCwTOqidJkiRJ5cJggFatwdwVBrLDnKKL8TBJT+bsjKwAAJfSFezL1NOV3ZasDZAdZjB3xewAkiRJkrQAgwFaXovIDHDy0rcByRz/7pqWGSMCSl1KV9Bd01JcJPDkmYsGAyRJkiRpAQYDtHwWmRng2765C3gdAKHy8oKnLi2/ei2/lFctSZIkSeuO2QS0PG4hM0DLF3t4fepTAMTxzQuevrR8Q7UxLkmSJElaiMEALY9CZoApnel+3lf5KJV3PUNV3ZNU3vUM76t8lM50f7HO2a1v4H9NfjuBSbpHB6jLT8x56rr8BN2jA8Xgwu7tW+7sZ5EkSZKkNc5HqFoet5IZIP/jvKYB2s8dobPiBDtyVezL1M9YRLAuP8EjuQs0V5ynMqbo23rA9QIkSZIk6QYMBmhZ3EpmALJf5cntvWwrjBZoHhujK7uN7poWQuVl4vhmukYHaK44DySjDVpr62FyV5I2UJIkSZI0J4MBWhYnz1wEFpcZ4PWpT7Ht3EeLZcfyrUn6wPHpG/1D7KQyporTCzJDvTC4B+598M59GEmSJEla43x8qmVRusL/zWYG+PjkdzDwzV0A5Bo76Nt6gDiry0aSqQHF9QhaDxoIkCRJkqQbcGSAlkXpCv+LyQzwty9/Jy33vY5MUxtHUykGc1c4eeYiV6/l2VCdZvf2LckaAZO7HBEgSZIkSTfJYICWxdQK/1OZAXryE9etGQDJgoBdowMcYieRVNIuM32D35TZOPcCgamUgQBJkiRJukkGA7QsmjIbaWnYZGYASZIkSVoFDAZoeUxO8nDtY2TMDCBJkiRJK85ggJbH4BPJSv8FZgaQJEmSpJXjI1ctj3sfTFb6x8wAkiRJkrTSHBmg5fO6n4W7X2VmAEmSJElaYQYDtLzuNTOAJEmSJK00pwlIkiRJklRmDAZIkiRJklRmDAZIkiRJklRmDAZIkiRJklRmyjYYEEKoDCG8O4TwoRDCZ0IIYyGEGEJ4+wJt3lqoM9/2jlu4jreEEE6FEK6GEL4WQvhECOEHbu/TSZIkSZI0v3LOJlALfKDwOgd8Gfimm2z7h8Bn5jj+qcVcQAjh/cB7gXNAD1AFvAn4nyGEd8UYH1nM+SRJkiRJuhnlHAz4OvD9wGdijM+HELqBn7/Jth+NMT5+O28eQriPJBAwBHxnjPFy4fgvAp8G3h9C+KMYY/Z23keSJEmSpNnKdppAjHEsxvhEjPH5FbqEqSkFvzAVCChcVxb4NeAFwNtW4LokSZIkSetc2QYDbtPOEMJ7QggHQwhvDiFsvYVzPFDY/8kcZU/MqiNJkiRJ0pIp52kCt+Pds36eCCF8EHhPjPHajRqHEGqBe4Cr84xM+Hxh33QzFxNC+PQ8RffeTHtJkiRJUnlxZMDifAF4F/BykgUIXwp0AlngJ4DHbvI8LyzsvzZP+dTxTbdykZIkSZIkLWRNjwwIIWSBly2iyUdijD9yq+8XY+wH+ksOfR34vRDCXwJ/DfzLEMKRGONf3+p7zH7Lm7yuV891vDBi4NuX6FokSZIkSevEmg4GkKzEf8Nh+SW+dCcuIsb4dyGEPwZ+GLifJDCwkKkn/y+cp/xGIwckSZIkSbplazoYEGP8npW+hhIXCvvaG1WMMY6EEM4D94QQ7p5j3YBvLewHl/ICJUmSJEkC1wxYSi2F/dmbrP9nhf33zVHWNquOJEmSJElLZk2PDFhuIYR/HGM8MetYAA4Cu4CLzEoVGEK4m2TY//MxxtJh/78BvBn4dyGEj8YYLxfqNwDvBL4BfOg2L7nhc5/7HK9+9ZxLCkiSJEmS1rDPfe5zAA230jbEeFNr1K1LIYSDTKff2wnsAD7JdGq/P48xfrCkfiQZuv9XwHmSm/zdQDPJYoJvjDF+bNZ7PA68BXhbjPHxWWW/BPwUcA7oBaqAHwLqgHfFGB+5zc/3BeAukmwHq9XUf//TK3oVWg/sS1oq9iUtFfuSlpL9SUvFvrS+NAB/H2P8lsU2LPeRAd8HtM46dl9hm/LBktfvB14DPAC8CJgEvgj8GvDLMcabnSIAQIzxvSGEvwH2AT9eON8zwC/GGP9oMeea5/yL7hDLrZDxYN6MCNLNsi9pqdiXtFTsS1pK9ictFfuSppR1MCDG+NpF1v83t/AebwXeukD5h4EPL/a8kiRJkiTdKhcQlCRJkiSpzBgMkCRJkiSpzBgMkCRJkiSpzBgMkCRJkiSpzJR1akFJkiRJksqRIwMkSZIkSSozBgMkSZIkSSozBgMkSZIkSSozBgMkSZIkSSozBgMkSZIkSSozBgMkSZIkSSozBgMkSZIkSSozBgO0IkIIW0MIj4UQvhRC+EYIIRtC+EAIYfNKX5uWXwihLoTw9hDCH4QQzoQQRkMIXwsh/HkI4cdCCHP+rQoh3BdC+OMQwldDCF8PIfxNCOE9IYSKBd7rLSGEUyGEq4X3+EQI4Qfu3KfTahBCeHMIIRa2t89Tx/6keYUQ/nEI4fdDCM8X/t16PoTwsRDC989R176kOYUQHiz0m3OFf+vOhhB+L4Swa5769qUyFkLoCCH8agjhRAjh7wv/hv3ODdrc8T4TQqgJIfyHEML/DSFcCyF8JYRwLITwD2/n82r5hRjjSl+DykwIoRH4JPBi4A+B08BrgNcB/xfYHWO8tHJXqOUWQngH8OvA88BTwBeBDLAHeCHw+8APxpI/WCGEf1E4fg34H8BXgX8GvBzojTH+4Bzv837gvcA5oBeoAt4EvAh4V4zxkTv0EbWCQgjfBPwfoALYAHTFGD84q479SfMKIRwC/hNwEfgjkr9VW4B/BDwVY/yZkrr2Jc0phHAE+BngEvBRkv60HfjnQBr40Rjj75TUty+VuRDCZ4AdwFWS3+m9wEdijD8yT/073mdCCC8AngR2A58C/gz4JuAHgTHggRjjwO18bi2jGKOb27JuwJ8CkeQPTOnxXy4c/42Vvka3Ze8TD5D8Y5WadfwlJIGBCLSXHL8L+ArwDeA7So5XkwSaIvCmWee6r3D8DLC55HgDyReza0DDSv+3cFvyvhWA/wUMAb9Y6ANvn1XH/uS2UB/6wcLv+uPAxjnKK+1LbjfRj14CTABfBl48q+x1hT5w1r7kNkff+NbCv2WvLfx+f2eeusvSZ4CfLbT5PUq+twH/onD8s8z6Pue2ejenCWhZhRC2Ad8LZIFfm1X888AI8OYQQu0yX5pWUIzxz2KM/zPGODnr+JeB3yj8+NqSog6gHjgaY/xUSf1rwKHCj/961tu8o7D/hRjj5ZI2WZK++ALgbbf3SbQK7ScJNr2N5O/LXOxPmlNhitIR4OvAv4oxXpldJ8Y4XvKjfUnzeRnJ9NyBGONXSgtijE8BV0j6zhT7kogxPhVj/HyM8WaGct/xPhNCCCVtfqb0e1uM8Q+BE8C3Aa03cb1aBQwGaLk9UNh/bI4bvyvASeAfAN+13BemVWvqi3a+5NhUP/qTOeo/TfLF/b7CULabafPErDpaBwpzFw8DvxJjfHqBqvYnzec+4FuAPwYuF+Z7HwghvHueOd72Jc3n8yRDqF8TQthSWhBCuB/YSDKKaYp9SYu1HH2mEfhmYDDG+IWbbKNVzGCAltvLC/vBeco/X9g3LcO1aJULIaSBHy38WPoP1bz9KMaYB75AMv9yW+E8tcA9wNUY4/NzvJX9bp0p9J3fJplm8m9vUN3+pPl8Z2GfA54hWS/gMPAB4JMhhP4QQunTXPuS5hRj/CpwgGQ9nL8NIfxmCOGhEMIx4GMk01B+oqSJfUmLtRx9xu/x60x6pS9AZeeFhf3X5imfOr7pzl+K1oDDQDPwxzHGPy05vth+ZL8rP/+eZHG3744xjt6grv1J83lxYf8Oki/S/wQYIBny/UvAPyWZN/vaQj37kuYVY/xACCELPAZ0lRSdAR6fNX3AvqTFWo4+Yz9bZxwZoNUmFPamuShzIYT9JKvbngbevNjmhf1i+5H9bh0IIbyGZDTAL8UY/2IpTlnY25/Kz1QqrgB0xBifjDFejTF+FngjyerbrfOlhZuDfamMhRB+hmS19sdJhlvXAq8GzgIfCSH8l8WcrrC3L+lmLUef8Xv8GmMwQMttKmL4wnnK75pVT2UohPBO4FeAvwVeVxheWWqx/ehG9W8U6dYaUTI9YBD4uZtsZn/SfKYW1DobY/zr0oLCiJOpEUuvKeztS5pTCOG1JItR/v8xxp+KMZ6NMX49xvgMSWDpPPDewkLLYF/S4i1Hn/F7/DpjMEDL7f8W9vPNJfrWwn6+uUha50II7wEeAZ4lCQR8eY5q8/ajws3gt5AsOHgWIMY4QvJFa0MI4e45zme/Wz82kPSLfwhcCyHEqY0kYwlAT+HYBwo/2580n6m+MTxP+VSwoGZWffuSZvuBwv6p2QUxxq8Dp0i+l/+jwmH7khZrOfqM3+PXGYMBWm5T/wh+byFlU1EIYSOwGxgF/nK5L0wrL4RwAPivwGdIAgFfmafqnxX23zdH2f0kGSk+GWP8xk22aZtVR2vXN4Dfmmf734U6f174eWoKgf1J83ma5Mvzt4YQquYoby7ss4W9fUnzmVrBvX6e8qnjY4W9fUmLtRx9ZohkYd6mEMK33GQbrWYxRje3Zd1IhlVG4F2zjv9y4fhvrPQ1uq1Iv/i5wu//U8CLblD3LuACyY3fd5QcrwY+WTjPm2a1ua9w/AywueR4A3AJuAY0rPR/B7c72se6C33g7bOO25/cFuo3v1P4Xb9v1vHXA5MkowY22ZfcbtCPOgu/5y8D98wqayv0pVGgzr7kNk8fem3h9/s785QvS58BfrbQ5veAVMnxf1E4/tnS426rewuFX560bEIIjSR/lF4M/CHwOaAFeB3JsKL7YoyXVu4KtdxCCG8hWVBpAvhV5p5rlo0xPl7S5g0kCzFdA44CXwX+OUnam16gM876AxdC+CXgp0gW/eoFqoAfAupIglOPLOHH0ioTQugmmSrQFWP84KyyN2B/0hxCCC8GTgLbgRMkw7lfRjLPOwL/Ksb4eyX134B9SbMURkP+KUlGiivAH5AEBv4hyRSCALwnxvgrJW3egH2prBX6wBsKP76EJIPJWZK/RQAXY4w/Pav+He0zIYQXkDz5v4/kAc6TwDcDP0gysuWBGOPA7X52LZOVjka4lecGfBPwIeB5kj8cz5EsGLfgE2G39bkx/cR2oe0Tc7TbDfwxybzdUeD/AD8JVCzwXm8B/goYIflC1g/8wEr/N3Bb1n729nnK7U9u8/2eX0Qyeu0LhX+zLpEEs7/LvuS2iH5UCbyHZCrk35NMQfkK8EfA99qX3Ob4Xd7o+1F2JfoMyTop/wH4PMlIhAskIwW+baX/m7ktbnNkgCRJkiRJZcYFBCVJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJkiRJKjMGAyRJ0qoWQvjvIYSvhBBqV/papoQQXh1CiCGEH1vpa5Ek6VaEGONKX4MkSdKcQgjfAZwCfjrG+MsrfT2lQgh/AHwX8K0xxqsrfT2SJC2GIwMkSdJq9p+Bvwd+faUvZA4PAS8B9q/0hUiStFiODJAkSatSCKEJOA18MMb44yt9PXMJIXwO+AfAthjjxEpfjyRJN8uRAZIk6Y4IIZwszKufb+u/wSn2AgH4H3Oc+7WFc3TP897ZEEJ21rGGQpvHQwiNIYTeEMKlEMKVEMLHQgjNhXr1IYTfDCE8H0K4FkL4qxDC6+a5xqPANwP/5AafRZKkVSW90hcgSZLWrT8APj7H8beR3EA/dYP2/wSYAP5yia+rARgAPgc8Xvj5jcAnQgi7gD8hmZrwP4AXAW8CngghNMUYvzjrXCcL+9cDf7rE1ylJ0h1jMECSJN0RMcb3zz4WQvhFkkDA48B/nK9tIXPATuBzMcaRJb60VuBQjPEXSt7v5wrXMwAcA/6/GONkoezjwH8HfrKwlfqrwv7+Jb5GSZLuKKcJSJKkOy4k/hvw08CvAXunbrbncQ9QATx/By4nCxyedezDhf0LgH8z69p+F8iTBCdmiDF+DbhGEuCQJGnNMBggSZLuqBBCBclIgH8N/JcY47544xWM6wr7y3fgkj4zx2J/XyrsB2OMV0oLCnVzwNZ5zvdVYMvSXqIkSXeWwQBJknTHhBAqSRbZ+1GgO8Z44Cabjhb21Xfgsr42+0CMMT9fWUEeqJynrIbp65UkaU0wGCBJku6IEEI1ySKCHcBPxxj/wyKaf6Wwr1uwVpJtYC41i3ivWxZCSAGbmL5eSZLWBIMBkiRpyRUWADwOfD/JYny/tMhTPA9cAF5+g3r3zPHedwEvXuT73aqXkwQkPrNM7ydJ0pIwGCBJkpZUCOGFwMdIVu1/a4zx1xd7jsKaAk8DW0II2xeouieEkJl17FBhvxxZk76rsL9RmkRJklYVUwtKkqSl9rvAfcApYFsIoXuOOg/FGL9xg/P8PtAO/FPgzDx18sCzIYQ/AK6Q3Jx/J/B3wDcVMhj8dozxLxb9KW7O9wITwB/eofNLknRHGAyQJElLpjCH/v7Cj68pbLN9JcbYfROn+32SVfx/lCQd4VweJRnp+DbgRcDfAv+MJEXgh4EfAH7rJi9/UQojIN4A/FGM8e/uxHtIknSnGAyQJElLJsY4CWxconONhRB+BfjPIYR/FGP833NUm4gx/hzw7+Yo2zzrfFnmX3CQGONCZQ1zHP5RkmwHi10PQZKkFeeaAZIkaTX7r8AXgf+40hdSKoRQA/ws8PsxxhMrfT2SJC2WwQBJkrRqxRivAW8GPlXIULBaNAC/Cfz0Cl+HJEm3xGkCkiRpVYsxPk2SWWDViDF+Duhe6euQJOlWhSRzjyRJkiRJKhdOE5AkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcwYDJAkSZIkqcz8P4mhfkM67cJzAAAAAElFTkSuQmCC\n", + "image/png": "iVBORw0KGgoAAAANSUhEUgAAA/AAAAJ8CAYAAABZWkoZAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAACu20lEQVR4nOzdeXxU1fnH8c+dLATCHmBYJSYQUVNZNSpIVAQEXAmN1hWjKdZaWtsqaLHEFhWsK1qVxgJaF0REVBAVKEQEGwTE/hBp2IIGZNg1hMRkMuf3x80MGTKJmewJ3/frNS+Se8+598xMCDxzznkeyxiDiIiIiIiIiDRsjvoegIiIiIiIiIj8NAXwIiIiIiIiIo2AAngRERERERGRRkABvIiIiIiIiEgjoABeREREREREpBFQAC8iIiIiIiLSCCiAFxEREREREWkEFMCLiIiIiIiINAIK4EVEREREREQaAQXwIiIiIiIiIo2AAngRERERERGRRkABvIiIiIiIiEgjEFrfAxB/lmXtAloD2fU8FBEREREREal50cAPxpjTg+2oAL7had28efP2Z555Zvv6HoiIiIiIiIjUrK+//pr8/Pwq9VUA3/Bkn3nmme03bNhQ3+MQERERERGRGjZw4EA2btyYXZW+2gMvIiIiIiIi0ggogBcRERERERFpBBTAi4iIiIiIiDQCCuBrgGVZN1uWZUoed9T3eERERERERKTpUQBfTZZl9QCeBY7V91hERERERESk6VIAXw2WZVnAHOAQ8GI9D0dERERERESaMAXw1TMRuBS4Dcir57GIiIiIiIhIE6Y68FVkWdaZwHTgGWPMJ5ZlXVrXY/B4PBw+fJjc3Fx+/PFHjDF1PQQRkVOeZVk0a9aMVq1a0b59exwOfTYuIiIitUMBfBVYlhUK/Av4BnigitfYUM6pPpXp7/F4+Pbbbzl+/HhVbi8iIjXEGENBQQEFBQXk5eXRo0cPBfEiIiJSKxTAV82fgf7AEGNMfn0M4PDhwxw/fpzQ0FA6d+5MZGSk/sMoIlIPPB4PeXl57Nu3j+PHj3P48GE6dOhQ38MSERGRJkgBfJAsyzoPe9b9CWPMZ1W9jjFmYDnX3wAM+Kn+ubm5AHTu3JlWrVpVdRgiIlJNDofD93s4JyeH3NxcBfAiIiJSKzRlG4RSS+ezgAfrcyw//vgjAJGRkfU5DBERKeH9fez9/SwiIiJS0xTAB6clEAecCRRYlmW8D2BqSZv0kmNP1+ZAvAnrtGxeRKRhsCuLooSiIiIiUmu0hD44PwL/LOfcAOx98Z8C/wOqvLxeREQaH28ALyIiIlJbFMAHoSRh3R2BzlmWlYYdwL9sjHmpLsclIiIiIiIiTZ/WX4uIiIiIiIg0AgrgRRoRy7K4+OKLa/0+0dHRREdH1/p9TlXZ2dlYlsX48eNr9T5z587Fsizmzp1bq/cRERERqTdbl4DHA0CWK5c5a3bx7IptzFmziyyXXbkLj8du1wQogK8hxpg0Y4yl5fPSGFx88cUNfr/uW2+9hWVZLFy4sL6H0mCtWrUKy7JIS0ur76GIiIiI1L2Vj8K8G3C9lsp1L65hxFOf8ND7W3hiWRYPvb+FEU99wnUvrsH1WirMu8Fu38hpD7yIlLFixYr6HgLvvPMOzZs3Z+TIkfU9lEbr2muv5fzzz6dLly71PRQRERGRmrV1CWRMB8C5YwFJ7gOsIxVTao7awkNSzgycoRn2gYzp0OUc6DOmPkZcIxTAy0/KcuWyZvtBjhW4aRkRyuBeHYhztqrvYUktio2Nrdf7FxYWsmTJEkaMGOGrrS3Ba9OmDW3atKnvYYiIiIjUvLhRuGLH4dyxAIDk0AyKLA9pzROwwo5gitqRlp9JcshqXxdX7DiccaPqa8Q1QkvopVxrth8kedZnAZeiJM/6jDXbD9b3EH3WrVvHddddR7du3WjWrBldunRhxIgRzJ8/36/d/PnzGTp0KG3atKF58+b87Gc/49FHH+XHH38sc03vPvDjx49z7733ctppp9GsWTN69erFjBkz/Go9f/bZZ1iWxdixY8sd45lnnkmzZs04fPiw75jH4+HFF1/k3HPPpWXLlkRGRnLuuefywgsv4CnZy/NTxo8fj2VZZGdnlzl38hJr797rjAz7U0jLsnyP0nvry9sD/+OPPzJ9+nTOOeccWrRoQevWrbnooovKvM6l7zV+/Hiys7O5/vrr6dChAxEREQwaNIjFixeX+5xWrFjBDz/8wLXXXut3/Pjx48yYMYNBgwbRqlUrWrZsyZlnnsnEiRNxuVx+bb/77jt+/etfEx0dTXh4OB07dmTs2LFs2LChzP1K7xX/8MMPufjii2nTpo1vm8FPnQdwu908//zznH/++bRu3ZoWLVrQv39/nnvuuUq/l1lZWUyePJlBgwbRsWNHmjVrRs+ePfnlL39JTk6OX9vx48dzySWXAPDQQw/5vZerVq0qM+6TbdiwgaSkJDp16uS7z1133cV3331Xpm3pn7FZs2bxs5/9jIiICJxOJ7/85S/5/vvvK/X8RERERCoUzH52h4OJeSnMdycCsDk8nPTonUR0m0+zTsuI6Daf9OidbA4PB2C+O5Hf5qWAo3GHwJqBl4De/Pwb7l/4f3hM4PPrdh3m5n9mMn3sOSSf26NuB3eS9PR0fvWrXxESEsJVV11F79692b9/P+vXr+f5558nOTkZgAceeIBHH32UDh06cMMNN9CyZUuWLl3KAw88wEcffcSyZcsICwvzu3ZRUREjRoxg7969jBo1itDQUBYtWsTkyZMpKChg6tSpAFxwwQWcccYZLF68mEOHDhEVFeV3nXXr1rF161aSkpJo37697/jNN9/M66+/To8ePbjjjjuwLIt33nmHu+66i08//ZTXXnutRl+rtm3bMnXqVObOncvu3bt94wd+MmldYWEhI0eOJCMjgz59+vDrX/+a48ePs2DBAq677jo2bdrEI488Uqbf7t27Oe+884iJieHmm2/m8OHDvPnmm1x99dUsX77cF4SW9s477xAaGsqVV17pO3bkyBEuueQSvvzyS8444wxSUlIIDw9nx44dzJ49m7Fjx+J0OgHYtWsXQ4YMYe/evVx66aX84he/4Ntvv+Wtt95iyZIlvP3221xxxRVl7rtgwQI+/PBDRo0axZ133lnmQ5HyzhcVFXHllVfy0UcfccYZZ3DDDTcQERHBypUr+c1vfkNmZib/+te/Knx9ARYuXMiLL77IJZdcwoUXXkh4eDhfffUVL730Eu+//z7r16+nW7duAFxzzTUAvPzyyyQmJpb5AKYiixcvJikpCWMM48aNo2fPnmzYsIEXXniBd999lzVr1gS8xn333cdHH33ElVdeyYgRI1i5ciXp6els376df//73z/5/ERERETKtfJRyJiOK3YcE/NSyMw+WqZJQnRbZkbOxrljAYcG3UNm9rmsI5Uiy0O6cyeHQkP82h8KDeFuZ0dSs2OY4k7FZB8ly5XbuFcTG2P0aEAPYMOAAQPMT9myZYvZsmXLT7arik+3HTCnT15sek766cfpkxebT7cdqJVxVMZXX31lQkNDTbt27czmzZvLnP/222+NMcasXbvWAKZHjx7mu+++850vKioyV1xxhQHMww8/7Ne3Z8+eBjCjRo0yx48f9x13uVymTZs2pk2bNqawsNB3/JFHHjGAefbZZ8uM46677jKAee+993zHXn/9dQOY/v37m9zcXN/xY8eOmYEDBxrAvPbaa37XAUxiYqLfsVtvvdUAZteuXWXuu3LlSgOYqVOn+h1PTEw09l//wHr27Gl69uzpd8z7/EaNGmWKiop8x10ul++1WrNmje/4rl27DGAAk5aW5netDz/80HetkxUXFxun02mGDRvmd/wXv/iFAcydd95piouL/c798MMP5ujRo77vR4wYYQAzbdo0v3Zr1qwxISEhpn379n6v+Zw5cwxgLMsyS5cuLTOmnzo/depUA5i7777buN1u33G3221SUlIMYBYtWlTmtbn11lv9rpOTk2MKCgrKXP+jjz4yDofD3HnnnX7Hy3t/Tx73nDlzfMdyc3NNVFSUcTgc5pNPPvFrP336dAOY4cOH+x33/oz16NHD7N6923e8qKjIXHTRRQYwmZmZAcdwqqnN380iIiJN1teLjZna2vd4809XmuhJ7/nFHdGT3jNv/ulKv3Z33J9mek5abHo9/BcTPze+3Eevh//iu87sT3fW97M1AwYMMMAGU4V4sXGvH5Ba8cyKbeXOvJ/MY2Dmim21O6AKvPDCC7jdbh588EHOPvvsMue7d+8OwOzZswGYMmUKnTt39p0PDQ3liSeewOFw8NJLgQsIzJw5k+bNm/u+79SpE1dffTXff/89//vf/3zHb775ZhwOBy+//LJf/8LCQubNm0enTp0YNerEnhvvmKZPn07Lli19xyMjI5kxYwZAuWOqD7Nnz8ayLJ588klCQ08s3unUqRMPPvggEHi8PXv2ZMqUKX7HRo4cyWmnnca6devKtF+7di0ul8tv+fz+/ft588036dKlC48//jiOk5Y+tWrVyrfXOycnh48//pjTTjuN++67z6/dhRdeyC9+8QsOHz4cMLv91VdfzeWXX17uaxDovMfj4bnnnqNz58489dRThISc+OQ3JCSEJ554AsuyKrWawrsF5GQjRozg7LPP5qOPPvrJa/yUd999l0OHDnHddddx0UUX+Z37wx/+QHR0NMuWLeObb74p0/fPf/4zp512mu/70NBQbrvtNoCA76WIiIhIpZTsZ/dKDs1gWtgswlpvJDxqBWGtNzItbBbJ3mR0wLq2o1nuGQCAFXakwsuXPn+swF3Dg69bWkIvfrJcuazbdfinG5aSuetwvS1F+c9//gPgFxgHsnHjRgAuvfTSMufi4uLo3r07u3bt4ujRo7Rt29Z3rk2bNvTq1atMnx497G0DR46c+GXQvXt3hg0bxrJly9iyZQtnnXUWAO+//z6HDx/mnnvu8Qt8N27ciMPhCFjXPTExkZCQEL744osKn1ddyc3NZfv27XTr1o0+ffqUOe99XQONt1+/fn5BrVePHj347LPPyhxfuHAhlmX5logDfP7553g8HoYOHfqTSe28Y7jooovKbInwjvXVV1/liy++4JZbbvE7d95551V47UDns7KyOHToEL1792batGkB+zVv3pyvv/66wmuDvSLqtddeY+7cuXz55ZccOXKE4uJi3/nwkj1c1VHR34XQ0FCGDh1KdnY2X3zxhV+wDjBo0KAyfQL9XRARERFh6xKIGwUOR/lJsT0eyFoKfcYwMS+FJPcBkkMz7P3szp1EhO72XS7dXUxfVzjxhYXMdyfy/I93YCgAwBS1q3Aopc+3jGjcIXDjHr3UuKompluz/WC9BPBHjx4F8O0LLo83yVZ55bS6dOnCN998w/fff+8XwJf+ujRvIF46uAI72deyZct4+eWXfbPo3hn5W2+9tcyY2rdvHzAoCw0NpUOHDuzfv7/C51VXKvP6wYn3o7SKXsNAyd0WLVrEeeed5/eeVvZ9ru5YS6/OCCTQ+UOHDgGwbds2HnrooXL7Hjt2rMJrA/z+97/n6aefpkuXLowcOZJu3br5Vn948xZUV02/l+X9XRAREZFTWF3sZz9iB+8WHtLyM0l3F5fpAxDlLiY1P5Mp9MPgYHCvDrXylOuKAnjxU9UlJfW1FMUbUOzZsyfgzLCXd3n1vn37ApZI82berm7JrWuvvZbWrVvz6quv8sgjj3D48GGWLl1K37596du3b5kxHT58mKKiojIzxW63m4MHD9K6deufvKd3ObnbXfY9CBSEVUXp1y+Qmnr9Nm3axK5du5gwYYLf8dLv80+pzlhLZ5UPJNB573WuvfbagMvyK2v//v3MnDmT+Ph41q5dS6tW/h+IvfHGG1W+dml19V6KiIjIKaoK9dmj1j/FcMfvWeYZRFrzBL+Z99IOhYaQ1jwBU2RfK7pdBHflPkNyyGr6usK529nRL4iPchfznOsA8SF7CDMOFnaf1LgT2KEycnKSqi4pqa+lKOeffz4AS5curbBd//79AXzltUrbvn07OTk5nH766eXOFldW8+bNSU5OZu/evSxfvpzXXnsNt9tdZvbdOyaPx8Mnn3xS5twnn3xCcXExAwYM+Ml7tmtnLwn69ttvy5xbv359wD7eJe2VnTVt1aoVsbGx7Nmzh23byuY8WLlyJUClxluRd955B6BM+bjzzjsPh8PBJ598Ql5eXoXX8L7Xn376acAPNWpqrF59+vShbdu2/Oc//6GoqKjK19m5cycej4cRI0aUCd5zcnLYuXNnmT7Bvo9Q8d8Ft9vNp59+CtTc6yMiIiKnmDraz27h4bFmL/muE19YSGp2DAV7kvlx/3AK9iSTmh1DfGGhbxzPRM72lalrrBTAi5+qLimpr6Uov/rVrwgNDeWvf/0rW7ZsKXPeWzs7JSUFgGnTpnHgwAHf+eLiYv74xz/i8Xi4/fbba2RM48ePB+CVV17hlVdeITQ0lBtvvLFMO++Y7r//fo4fP+47fvz4cSZPngxQqTF592Wnp6f7Hf+///s/nnnmmYB9vGXuAiUqK09KSgrGGO69916/gPHgwYP89a9/9bWpjoULF3LWWWcRFxfnd7xjx45cf/31fPfdd773q7Rjx475loZ3796d4cOHk52dzdNPP+3XLjMzk9dff5127dqV+ZCgqkJDQ/nNb37Dd999x8SJE8nPzy/T5rvvvgv481mat2zbp59+6vf6Hjt2jNTU1IAfRlTlfbzmmmto3749b7zxhi+HhNfTTz/Nzp07ueyyy8rsfxcRERGplCrUZ7/vxzt8M/SV3c9+mWMj5x39wHd8vjuRKUUTKPphAIWHhlH0wwCmFE3wjQPsFQFkVTzx19BpCb34iXO24rzT2weVyC7h9Pb1thTlrLPO4vnnn+fOO++kf//+XH311fTu3ZtDhw6xfv16WrVqxcqVK7nwwgu57777eOyxx4iPj2fcuHFERkaydOlSNm/ezJAhQ7j33ntrZEyDBw+mV69evPXWW7764J06dSrT7oYbbuDdd99l/vz5nH322VxzzTVYlsWiRYvYtWsXycnJAQP/k3mf8xtvvEFOTg4JCQl88803vPvuu1x99dXMnz+/TJ9hw4bx1ltvMXbsWEaPHk3z5s3p2bMnN998c7n3+eMf/8jSpUt599136du3L6NHj+b48eO89dZb7N+/n/vuu48hQ4YE92KVsn37djZv3lwmY73Xc889x+bNm3nxxRdZtWoVI0eOJDw8nF27dvHRRx/x3nvv+RICvvjiiwwePJh7772Xjz/+mEGDBvnqwDscDubMmVNmlrs6HnzwQb788ktefPFF3n//fS699FK6devG/v372bZtG2vWrOHhhx/2JTYMpHPnzlx//fXMmzePfv36MWLECL7//nuWLVtGREQE/fr1Y9OmTX59zjjjDLp168a8efMIDw/ntNNOw7Isbr75Znr27BnwPi1btmT27Nn8/Oc/JzExkZ///OecdtppbNiwgY8//pjOnTsza9asGnttREREpAkIIiFdVruhZGYfrfX97Ms8gzg06B6i1j+FK3YcC/NSMCfttTfYy+YTIzvawXviZOgzptZeprqgAF7K+O2w3tz8z8xKlZJzWDBxWO/aH1QFUlNTiY+P5/HHH2fVqlUsWrSIDh06cM4553DHHXf42s2YMYP+/fvz3HPP8corr1BUVERsbCzTpk3jD3/4Q41k+Pa69dZbfaXVAi2f93rjjTdITExk9uzZvqDpzDPP5A9/+AO/+tWvKnWviIgIVqxYwR//+EeWLVvG559/Tnx8PK+//jrt27cPGMDfcccd7N69m3nz5vHYY4/hdrtJTEysMIAPDw9n2bJlPPnkk7z++us8++yzhIaG0rdvX55++ml+8YtfVGq85Slv+bxXu3btWLt2LU8//TRvvvkm//jHPwgJCaFHjx6kpKT4BccxMTGsX7+eadOm8cEHH7Bq1Spat27N5Zdfzp/+9CfOPffcao31ZGFhYSxatIhXX32VuXPnsnjxYo4dO0bHjh05/fTT+etf/1qpD2P++c9/EhMTw5tvvsnf//53OnbsyFVXXcVf/vIXkpKSyrQPCQnhnXfeYfLkycyfP5/c3FyMMQwZMqTcAB7sD33WrFnDI488wkcffcT3339P586dufPOO3nwwQfp2rVrtV4PERERaUKCTEiXFzMBSMTgqPX97FFXpEGvc3HGjWJehR8uXABZYxt98A5gGVPJgt9SJyzL2jBgwIABGzZsqLCdtyTVmWeeWSvjePPzb7h/4f9VGMQ7LJg+9hySz+1RK2OQU8uFF17Inj17aiTTukh9qe3fzSIiInVq6xKYd4Pv2/nuRCa5yyakmxGa7renPbXQTkgXHrWCZp2WlXv5H/cPp/DQMCw8vNn5db8l8a8VX0Ra8wSssCOYonak5WdyY8hq33lX7DicN6aDo/HtCh84cCAbN27caIwZGGxfzcBLQNedexrd27Vg5optZAZYTp9wensmDuvd6MswSMPw3Xff8Z///IeJEyfW91BERERExKskIZ1zxwLATgRXZHnKBNbJpQLrDe3HsHyvnZCuWvvZ3am+2XmAKfQjzDh8HxTY+9mbxqx6MBTAS7kG9+rA4F4dyl+KIlJDunTpErAmvIiIiIjUsCD2s9NnDBPzUkhyHyA5NMNOSOfc6bcsPt1dTF9XOPGFhcx3J/IqEzAc0372WqIAXn5SnLOVAnYRERERkcYuyP3shwbdQ2b2ucElpNt7jHO6tuKm/Y9rP3stUAAvIiIiIiLS1G1dAhnTAXv5eZL7AOsou589KWcGzpJl6lHrn2K4w97PXtmEdBYepvICA0+qz1562X1qfibxIXsAe1l+YmRHOzAvFZSXO4nocJyywTsogBcREREREWn6qrCffV3b0SzfZ+9nt8KOVHh57/nLHBsZeFj72WtL40vZJyIiIiIiIvasekkeoSxXLnPW7OLZFduYs2YXWa5cu43HY7dzOJiYl8J8dyKAvZ89eicR3ebTrNMyIrrNJz16J5tLSivPdydy3493+GboK5uQbplnEF/ETADsTPELu0/ym+WHE/vZXbHj7AOn6H72qtAMvIiIiIiISGNTF/vZjxQABJWQzuAgcuSDcCRR+9lrgQJ4ERERERGRxqSO9rMDRLeL4K7cZ4JKSBfnbAVO7WevDQrgRUREREREGpM62s9u4eGxZi9xXn4VEtI5tFu7NiiAFxERERERqW+1XJ/9+R/vwGAvia/sfvbLHBs576gS0jUkCuBFRERERETqUwPdz77MM4hDg+4hav1TdkK6vBTMSWPzJqRLjOxoB+9KSFerFMCLiIiIiIjUlwa+nz3qijToda4S0jUQCuBFRERERETqS2PYz95HCekaCmUWkFPGxRdfjGVZQfWxLIuLL764zPF9+/Zx66230r17d0JCQrAsi6NHj9bMQCtp1apVWJZFWlpand63KZk5cyZnnXUWzZs3x7Isnn766foeUpWMHz8ey7LIzs6u76GIiIgINMj67AH3sxdNoOiHARQeGkbRDwOYUjTBNw7w7mdfWjOvidQIzcCLVMH48eP5+OOP+cUvfkGvXr2wLIuIiAguvvhiMjIyMMbU9xArtHLlSubOnctnn33Gd999x48//kj79u05++yzGT58ODfddBPdu3ev72HWqnnz5vHb3/6W/v3787vf/Y5mzZpx/vnn1/ewAkpLS+Ohhx5i5cqVAT9QEhERkQZE+9mlFimAF6nA119/TYsWLfyOFRYWsmzZMi677DJee+21ehpZ1fzwww/ceuutLFq0iLCwMIYOHcro0aOJjIzkwIEDrFu3jvvvv5+pU6fyn//8h/79+9f3kGvN4sWLfX927dq1nkdTPY8++iiTJ0+mW7du9T0UERGRU5v2s0stUwAvgZUqY1GuUmUsmqo+ffqUObZv3z48Hk+jC/qKi4tJSkpi+fLlJCYm8q9//YsePXqUabdlyxb+/Oc/88MPP9TDKOvO3r17ARrd+xhIly5d6NKlS30PQ0RERLSfXWqZ9sBLWSsfhXk3wHu/8e3dKcPjsc/Pu8FuX4/ee+89hg0bRpcuXWjWrBldu3YlMTGR559/PmB7t9vNI488Qu/evWnWrBk9evRg0qRJFBYWlml78h746OhoevbsCcDLL7+MZVlYluXbg5yRkeHr532cvOQ5JyeHu+++m5iYGJo1a0ZUVBRXXXUVn3/+ecDxulwubr/9dpxOJ82bN6dfv368/PLLQb9Or776KsuXL6d3794sWbIkYPAOcNZZZ7FgwQIGDx7sdzw6Opro6Gh++OEHfv/73xMdHU1YWJjfHvytW7cyfvx4evToQbNmzXA6ndxwww3873//C3iv48eP8+ijj9KvXz8iIyNp2bIlF1xwAW+88UaZtqX3/G/atIkxY8bQtm1bWrRoQWJiImvXrq3U65CWloZlWaxcuRLwf68AsrOzfe9pIIFyKVR1bMXFxbz44osMHjyYNm3a0Lx5c3r16sUdd9zBtm3bAPt1f+ihhwC45JJLyowXKt4DP3/+fIYOHeq7/s9+9jMeffRRfvzxxzJtve/x8ePHuffeeznttNNo1qwZvXr1YsaMGQ1+a4iIiEi90352qWWagRd/pZb9sOlV+8+rnvWfifcG797zGdOhyzn18indP/7xDyZMmEDnzp258sor6dChA/v37+e///0vc+bM4a677irT54YbbmD16tWMGjWK1q1b88EHH/DYY4+xf/9+5syZU+H9fve735Gdnc0zzzxD3759ueaaawDo168f0dHRzJ07l927dzN16lRfn+joaN/XGzduZMSIERw+fJiRI0cyduxYDh48yKJFixgyZAjvvPMOo0eP9rU/dOgQF154ITt37mTIkCEMGTKE7777jjvvvJMRI0YE9Vq99NJLANx7771ERkb+ZPvQ0LK/HgoLC7n00ks5fPgwI0aMoHXr1px++ukAfPjhh4wdO5aioiKuvPJKevXqRU5ODgsXLmTJkiWsXLmSAQMG+K519OhRLr30Ur744gsGDBhASkoKHo+Hjz76iBtuuIGvvvqKadOmlRnD+vXreeyxx7jgggu44447+Oabb3j77bcZNmwYmzZt4owzzqjweXk/UAn0XlVXMGMrLCxkzJgxLF++nB49enDDDTfQunVrsrOzeeeddxgyZAi9e/fmd7/7HYsWLSIjI4Nbb73V7+fppzzwwAM8+uijdOjQgRtuuIGWLVuydOlSHnjgAT766COWLVtGWFiYX5+ioiJGjBjB3r17GTVqFKGhoSxatIjJkydTUFBQo6+XiIhIg1dqVWr5y81PrErNcuWSmX1U+9ml9hhj9GhAD2DDgAEDzE/ZsmWL2bJly0+2C1pxsTHv3GXM1NYnHu/cZR+vzPk6NmDAABMeHm5cLleZcwcOHPD7PjEx0QBmwIAB5tChQ77jx44dM7GxscbhcJjvvvvOrw9gEhMT/Y7t2rXLAObWW28tc0/vPQIpKioysbGxplmzZmbVqlV+5/bs2WO6du1qOnfubAoKCnzHU1NTDWB+97vf+bX//PPPTWhoqAHM1KlTA97v5HuHhYUZwGzfvv0n2wfSs2dPA5hhw4aZY8eO+Z07fPiwadu2rYmKijJfffWV37nNmzebyMhI079/f7/jt956qwHMjBkz/I7n5+ebkSNHGsuyzBdffOE7vnLlSgMYwMyZM8evz4svvmgA86tf/arSz6e896qi97e8flUZ2/33328Ac+WVV/q958YYU1BQYPbv3+/7furUqQYwK1euDDgm72u5a9cu37G1a9cawPTo0cPv57qoqMhcccUVBjAPP/yw33W87/GoUaPM8ePHfcddLpdp06aNadOmjSksLAw4BrHV2u9mERGpe/9+xJiprc2+V1JM8gufmp6TFpd5JL/wqdn3Sor9f+J/P2Jmf7rTd67Xw38x8XPjy330evgvvraJ05ebN/90pTFTW5v/e7iDSXzpTL+2iS+daf7v4Q7GTG1t3vzTlea6Fz61x/j1Yt//w/+37wcz+9OdZubyLDP7053mf/t+sNsUF9vtpMEYMGCAATaYKsSLWkIv/hwOe8a9300njm161Z5xL3b7z7yD3e7kGfo6FhoaWmYWEaBDhw4B28+YMYP27dv7vo+MjOTGG2/E4/Gwfv36WhvnkiVL2LFjB7/5zW9ITEz0O9e1a1fuu+8+9u3bx4oVKwB7JvS1116jVatWZUrFDRo0iBtvvLHS9z58+DBFRUUAAROdrVq1irS0NL/HokWLAl7riSeeKDOD/8orr3D06FEeeughzjrrLL9zZ599NqmpqXzxxRds2bIFsFcWvPrqqwwaNIj77rvPr31ERIRvufbrr79e5v6DBw8us7w9JSWF0NBQ1q1bV+HrUNsqO7bi4mKef/55mjdvzosvvkizZs38+jRr1oyOHTtWayyzZ88GYMqUKXTu3Nl3PDQ0lCeeeAKHw+FblXGymTNn0rx5c9/3nTp14uqrr+b7778vdzuEiIhIk3JyMrqcGVj4by31JaMr2e9OxnQ67ll+4nyQ+9mTQ/33sxfsSebH/cMp2JNManYM8SXbPZNDM3gmcrY9899njO//4XHOVtw2+HR+M6w3tw0+/cTedu1nb1K0hF7K8gbxcCJY3/Sqf+AODSJ4v/HGG/nDH/7A2WefzXXXXUdiYiKDBw+uMPgZNGhQmWPe/eBHjlT8i7Y6PvvsMwB2794dsHa7d8/z119/zejRo9m6dSvHjx/noosuok2bNmXaX3zxxZXeC29MxXuXV61a5dtn7XXrrbf6tgh4RUREcM4555Tp731uX375ZcDnlpWVBdjP7ayzzuLzzz+nuLi43Dr23g8bvv766zLnAr1/YWFhOJ3OWn3/KqOyY9u6dSvff/89CQkJtZZEb+PGjQBceumlZc7FxcXRvXt3du3axdGjR2nbtq3vXJs2bejVq1eZPnXxd0RERKTBqEIyOlfsOA50vRQ2bgWquZ/dnerLNg8whX6EGYcvyLf3sytL/KlIAbwEFiiIL60BBO8Av//97+nQoQPPP/88M2fO5Omnn8ayLBITE/nb3/4WMKAqHax4efd7FxcX19pYDx06BMBbb71VYbtjx44B8P333wPgdDoDtis9q/pToqKiCAsLo6ioiL179xITE+N33jvrDrB8+XKGDx8e8DqdOnUqk8ANTjy39PT0CsfhfW7e9p9//nm5yftKty8t0PsH9ntYm+9fZVR2bEePHgUCr4aoKd6fn/Ky03fp0oVvvvmG77//3m/cFT0HqN2/IyIiIrUqyP3sE/NSSHIfIDk0w05G59zpV+It3V1MX1c48YWFzHcnsjAvhb/07gRs1X52qTUK4KV8Dgdc+UzgAP7KZ+o9ePe65ZZbuOWWWzh69Chr167lnXfeYfbs2YwcOZKvv/6aTp061fcQAXyz6O+++y5XXXVVpdu7XK6A5/ft21fpe4eGhpKQkMCnn37KihUrygTwlRUoeIcTY/3yyy8DztCX1/6ee+7hySefrNJYaouj5Ofa7XYHPO8NvqvDGyTv2bOn2tcqj/c13rdvH7GxsWXOf/fdd37tREREmrSVj0LGdFyx45iYl0LmSQEyQEJ0W2ZGzsa5YwGHBt1DZva5wSWjK7lmQnRbknJmqD671IqGEYFJw+TxwPu/DXzu/d+WX2KunrRt25bRo0eTnp7O+PHjOXz4MKtXr/7pjjUoJMT+5RxolvL8888HqPSY+vTpQ4sWLdi0aZNvNrW0VatWBTW2O+64A7D3sB8/fjyovj8l2Od23nnn4XA46vz9qYx27ezlbN9++22Zcz/88INvO0B19OnTh7Zt2/Lf//7XV4++IhX9XJWnf//+QOCfk+3bt5OTk8Ppp59e7oy7iIhIk1GF/exR659iuGM9BgdpzRMCzqKDHcSnNU/wlYFbs20/MyNnaz+71BoF8BLYyaXiTuZNbFfPQfyHH34YcKZ0//79ALRo0aJOxxMVFQXAN998U+bc1VdfTWxsLH//+9/54IMPypwHey+5N7gOCwvjxhtvJDc3t8w+8fXr1/Paa68FNbabbrqJYcOG8b///Y8rr7ySnJycgO2qMsN822230bZtWx566KGAieQ8Ho9fINmpUyduvPFG1q9fz1//+teA7+GOHTvYtWtX0GOprlatWtGnTx/WrFnjS7oHdvD8+9//nvz8/GrfIyQkhLvuuov8/HzuvPPOMjXZCwsLOXDggO/7in6uypOSkgLAtGnT/K5VXFzMH//4RzweD7fffnt1noaIiEjjULKf3Ss5NINpYbMIa72R8KgVhLXeyLSwWb6gG2Bd29Es99jlbyubjA6g495/n0hqh+qzS83TEnopK1Dw3u8me9n8+7/1T2wH9boX/vrrryciIoIhQ4YQHR2NMYbVq1fz+eefM3DgQC677LI6Hc+wYcN46623GDt2LKNHj6Z58+b07NmTm2++mbCwMBYuXMjIkSMZM2YMF154If369aNFixZ8++23fP755+zcuZPvvvvO98HDI488wooVK3j66adZv369rw78m2++yejRo3nvvfcqPbaQkBAWLlzILbfcwrvvvktMTAyJiYnEx8fTokULDhw4wFdffcXatWsJDw8nISGh0teOiopiwYIFXHvttZx//vkMGzaMs88+G4fDwTfffMNnn33GoUOHKCgo8PV57rnn2LZtG3/+85/517/+xZAhQ3A6nezdu5evv/6azz//nDfeeMNXZ74u3Xvvvdx+++0MHjyYn//850RERLBy5UqKioro27cvX375ZbXvMXXqVDIzM3n//feJi4vjiiuuoFWrVnz77bd8/PHH/O1vf/NltL/kkktwOBzcf//9bN682bdKYMqUKeVe/8ILL+S+++7jscceIz4+nnHjxhEZGcnSpUvZvHkzQ4YM4d5776328xAREWnwHI6g97M//+MdGOz/t1Q2GR3AgW6XQcfJvuX62s8uNU0BvPgrL3j3BumBstNDvQXx06dP56OPPmLjxo188MEHRERE0LNnT2bMmMGvfvWrgOXlatMdd9zB7t27mTdvHo899hhut5vExERuvvlmAM455xy+/PJLnnzySRYvXsycOXNwOBx06dKF/v3789BDD/mVv+vQoQNr1qzhgQce4P3332f9+vWcccYZvPDCC0RHRwcVwAO0bt2aRYsWsWLFCl5++WXWrl3L2rVrKSoqol27dpx99tk8/PDD3HLLLXTv3j2oaw8bNoz//ve/PP7443z00UesXr2a8PBwunbtyqWXXkpSUlKZsWRkZPCPf/yD119/nbfffpuCggKcTie9e/fmqaeeKjeZXm1LSUnBGMOTTz7Jyy+/TLt27bj66qt55JFHyjyPqgoPD+fDDz/kxRdf5JVXXuHll1/GGEPXrl259tprGTJkiK/tmWeeycsvv8zjjz/O888/7/sgpKIAHuySif379+e5557jlVdeoaioiNjYWKZNm8Yf/vAHwsPDa+S5iIiI1LkgEtJltRtKZvbR4PazH7H/rQ0mGZ3BweBeHcB5P3Q5R/vZpVZYP1VeSuqWZVkbBgwYMGDDhg0VtvOW1zrzzDNrdgBbl8C8G058HyjbfKAg//rX9ctHRE55tfa7WURETggyId0XMRO4dou9ZD2s9UYius0v99IFe5Ip+sFeOh/dLoK7cp/xzdqXm4zOm4W++yTm3Tm4Zp+rNEkDBw5k48aNG40xA4Ptqz3w4q/PGHsZD5RfKs47E9/vJvt7LfsRERERkbpQhYR0/XfOYrhjvX2ukvvZLTw81uylqiWjE6lFWkIvZV1iL/vxLksKyBvE9xmt4F1ERERE6kZJQjpvcJ4cmkGR5SGteQJW2BFMUTvS8jNJDjlR6WZD+zEs32vPqld2P/tljo2cd/RE0uH57kR7aX3Rif8bT6EfYcbhC/LtZHRaEi+1SzPwElipMhblUhkLEREREalLJQnpvFncN4eHkx69k4hu82nWaRkR3eaTHr2TzSV5Xua7E3mICRgcvv3sUe7AZVmj3MWk5Wdi4WGZZxCHBt0DYCej6z7JVyrOy5uMzpfhXqtSpQ5oBl5EREREROpPbSek23uMc7q24qb9j5Mcspq+rgr2s4fsIczYgXnUFWnQ61wlo5MGRQG8iIiIiIjUjyAT0uXFTAASMThIa57gVwqutEOhIaQ1T8AU2TPvU3mBgSftZy+97D41P5P4kD2AvSw/MbKjHZiXCsrjnK3sgP1kWpUqdUgBvIiIiIiI1L2TE9K5D7COVL+l6r6EdCXBt52QLpJlnkGVTkh3mWMjAw9rP7s0DdoDLyIiIiIida8kIZ1XcmgG08JmEdZ6I+FRKwhrvZFpYbN8QTWUJKTzBJeQbplnEF/ETAC0n10aP83Ai4iIiIhI3StJSJfkPuCrtZ7u3Om3LD7dXUxfV7iv1vqrTMBwzJeQLt1dXGYPPNh72lPzM5lCPwwOIkc+CEcStZ9dGj0F8CIiIiIiUjMaaEK6OGcrcGo/uzR+CuBFRERERKT6GnpCup8qkSzSCCiAFxERERGR6lFCOpE6oY+hRERERESkepSQTqROaAZeRERERETKCmI/O33GKCGdSB3QDLyckrKzs7Esi/Hjx9fodS3L4uKLL67Ra9aEYMe1atUqLMsiLS2tzLn169czfPhwOnTogGVZ9OvXr8bGWVlpaWlYlsWqVavq/N5NwQ8//MDEiROJjo4mNDQUy7LYtGlTfQ+rSqKjo4mOjq7vYYiIND0rH4V5N+B6LZXrXlzDiKc+4aH3t/DEsiween8LI576hOteXIPrtVSYdwOHFqeRmX2USe5UXiu+qExiOTiRkO614ouY5E7lvyUJ6WaEpnNjyGqecx0gyl3s18ebkO7GkNXMCE3n/Oi2dnDeZ4xvT3ucsxW3DT6d3wzrzW2DTz+RnE4J6aQJUgAvTcbWrVv5zW9+Q3x8PG3atCE8PJyuXbsyZswY/vnPf1JQUFDfQ6yQ90OFQEFzQ/HDDz8wZswY1q1bx/XXX8/UqVO58847gYb74UVpRUVFvPLKK1xzzTX06NGD5s2b06JFC04//XSuvfZaXnrpJfLy8up7mLXuvvvu49lnn+VnP/sZ999/P1OnTqVz5871PayALr74YizLqu9hiIicWk7ez54zAwuPXxPffvYdCwCIWv8Uwx3rfQnpAs2kQ6mEdJxISJd8UkK6gj3J/Lh/OAV7kknNjiG+sBCwl+U/EznbnvUXOUVpCb00CX/5y1946KGH8Hg8nH/++dx66620bNkSl8vFqlWruOOOO3jhhRdYv359rY7j66+/pkWLFrV6j7pw3nnn8fXXX9OhQwe/4+vWrWP//v08/PDDPPDAA/U0uqrZunUrSUlJbNmyhbZt23LppZdy+umnExoayp49e/jkk09YtGgR999/PwcOHKjv4daqxYsXExcXx/vvv1/fQ6m2FStW1PcQRESanpL97N7gPDk0gyLL45fpPS0/k+SQ1b4u69qOZvk+ez+7EtKJ1B4F8NLoPfLII0ydOpUePXrw1ltvkZCQUKbN4sWLeeKJJ2p9LH369Kn1e9SFFi1aBHwue/fuBaBr1651PaRq+e677xg2bBh79+7lN7/5DY888ggtW7Ys027ZsmXce++99TDCurV3716GDh1a38OoEbGxsfU9BBGRpsfhCHo/+/M/3oHBXu0YbEK6/jtn2Qnp8lIwJ5We8yakS4zsaAfvSkgnpzgtoZdGLTs7m7S0NMLCwvjggw8CBu8AV1xxBR9++GG517j++uvp0KEDERERDBo0iMWLF5dpN3fuXCzLYu7cuXz44YdcfPHFtGnTxm95b6Bl5Lm5ufz1r38lPj6e1q1b06pVK2JjY7nuuuvYsGFDlZ97YWEhM2fOZMCAAbRr144WLVoQHR3N1VdfzfLlywP2OXjwIL/85S/p0qULzZo14+yzz2bOnDll2p28B967vP/WW28F4LbbbsOyLN/r4X0NMjIyfMcDbQfIzMxk3LhxdO7cmfDwcHr06MGECRN8HwycbMOGDVx++eW0atWK1q1bc9lll/HZZ58F/Vo98MAD7N27lxtuuIGZM2cGDN4Bhg8fXmaVRul8CVlZWVx33XV06tQJh8Phtwf/o48+YvTo0XTo0IFmzZoRGxvLvffey9GjRwPeKycnh7vvvpuYmBiaNWtGVFQUV111FZ9//nmZtqX3/C9YsIDzzjuPFi1a0L59e66//nr27NlTqdfBuxzdGOP3Xnl/Zkv/jAcS6Oe7qmM7fPgwf/rTn4iPj6dFixa0adOGvn37MnnyZPLy8nyve0ZGhu/eJ48Xyt8D/+OPPzJ9+nTOOeccWrRoQevWrbnooouYP39+mbal3+PK/j4QEWl0ti7xLT3PcuUyZ80unl2xjTlrdpHlyrXbeDywdQlZrtyg97NnH7GDd29CupP3sntFuYtJy8/0LcmPHPkgXP86zhvTmXfnYD6+ZyhTrzyLPwyPY+qVZ/HxPUOZd+dgnDemw/WvwyX319ILJNI4aAY+SJZlRQHXAmOAnwHdgELg/4A5wBxjjDbm1JE5c+ZQVFTE9ddfT3x8fIVtmzVrVubY7t27Oe+884iJieHmm2/m8OHDvPnmm74g+JJLLinTZ8GCBXz44YeMGjWKO++8k+zs7HLvaYzh8ssvZ+3atVxwwQXccccdhIaG8u2337Jq1SouuugiBg4cGPTzBhg/fjxvvPEG8fHx3HLLLTRv3py9e/fy6aef8uGHH3LZZZf5tT969CiDBw8mPDyccePGUVBQwIIFC0hJScHhcPiC80Datm3L1KlT2bRpE++++y5XX321L3ldv379mDp1Kg899BA9e/b0SwxYOtCaM2cOqampNGvWjKuuuooePXqwbds2XnrpJd5//33+85//cNppp/nar127lssuu4zCwkLGjh1Lr1692LRpExdffDGXXnpppV+n48eP88YbbwAwderUn2wfGhr41+KOHTtISEggLi6OG2+8kfz8fFq3bg3YWzimTp1K+/btueKKK+jUqRP//e9/efzxx/nggw/47LPPfG0BNm7cyIgRIzh8+DAjR45k7NixHDx4kEWLFjFkyBDeeecdRo8eXWYMzz//PO+99x5XXXUViYmJZGZm8uabb/Lll1+yadOmgD/jpY0fP56LL764zHtVE0ngghnbrl27uOSSS9i9ezcDBw7kV7/6FR6Ph6ysLJ566inuvPNO38/c3Llz2b17t99791PjLSwsZOTIkWRkZNCnTx9+/etfc/z4cRYsWMB1113Hpk2beOSRR8r0q8rvAxGRRmHlo5AxHVfsOCbmpZB50iw3QEJ0W2ZGzsa5YwF5MROARN9+9tIz76X59rOXLHmPbhfBXbnPkByymr6u8DKBvzchXXzIHsKMPbMe52wFzhMz6nHOVieS0JWmhHQiNmOMHkE8gDsBA+wFXgMeBWYDR0uOLwCsalx/w4ABA8xP2bJli9myZctPtqsJx4uOm/d3vG9e3PSiWbxjsckvyq+T+1bGpZdeagCTnp4eVL9du3aZkvfLpKWl+Z378MMPDWBGjRrld3zOnDkGMJZlmaVLlwa8LmASExN93//3v/81gLnmmmvKtC0uLjaHDx8OatxeR48eNZZlmYEDBxq3213m/MGDB8uMCzC33367X/uvvvrKhISEmDPPPNOv/cqVKw1gpk6d6nfc+xrMmTOnzD1Pfu6l/e9//zNhYWEmNjbW5OTk+J1bsWKFcTgcfq+Rx+MxZ5xxhgHMokWL/No//fTTvuezcuXKgPcrLSMjwwCme/fuP9k2kNI/K/fff3+Z8//+978NYC644AJz5MgRv3Pe1+t3v/ud71hRUZGJjY01zZo1M6tWrfJrv2fPHtO1a1fTuXNnU1BQ4Ds+depUA5hWrVqZ//73v359fvGLXxjAvPnmm5V+TuW9VxW9v+X1q8rYLrzwQgOYRx55pMw9Dhw4YPLzT/yOSUxMNPY/VYH17NnT9OzZ0+/YI4884vs7XFRU5DvucrlMz549DWDWrFnjO16V3wflqcvfzSIilfL1YmOmtvY93vzTlSZ60num56TFvkf0pPfMm3+60q/dHfenmZ6TFpvej91j4ufGl/vo/dg9vmtkPnW93zVenTLG9Hr4L6b3Y/eYXg//xbw6ZYzf+X2vpBhTXFzfr5BInRswYIABNpgqxItaQh+8LOAqoLsx5kZjzP3GmBSgD/AtkASMrc8B1qTNBzcz6u1R3L/6fp7b9ByTV0/m8rcvZ/PBzfU9NMDe2wzQvXv3KvXv2bMnU6ZM8Ts2cuRITjvtNNatWxewz9VXX83ll18e1H2aN29e5pjD4aBdu4r3iJXHuwy6WbNmOBxl/xpHRUWVOdaiRQuefPJJQkJOfBJ+1llnMXjwYL7++mtyc3OrNJbKeOGFFygqKuKZZ56hW7dufucuvfRSrrrqKt5//33fGNauXcv//vc/hg4dytVXX+3X/u677w5q3/O+ffsAytzXa+7cuaSlpfk9ApVUczqdAWfwZ86cCUB6ejpt27b1Ozd+/Hj69evHa6+95ju2ZMkSduzYwW9+8xsSExP92nft2pX77ruPffv2BUzONnHiRH72s5/5HUtNTQUo9+e1rlR2bBs2bGDt2rX069ePSZMmlbmOd+l6dcyePRvLsnjyySf9VlR06tSJBx98EICXXnqpTL+q/D4QEWnwShLSeSWHZjAtbBZhrTcSHrWCsNYbmRY2y5ckDmBD+zEs99gJ6Sq7n/0yx0bOO3pSQrqiCRT9MIDCQ8Mo+mEAU4omMN994t8+OyHd0hp5miKnCi2hD5Ix5t/lHN9nWdaLwMPAxcDbdTmu2lDgLuDuFXdzqOCQ3/FDBYe4e8XdfJj0IRGh1fuPdnUZe9VClctM9evXzy+g9erRo0e5e63PO++8Sl//rLPOol+/frzxxhvs3r2bq6++miFDhjBo0CDCw8OrNGaA1q1bc+WVV/L+++/Tr18/kpKSuOiii0hISCg3C37v3r39lnF79ejRA7CX2LdqFWDJWg3wvpYZGRkB93jv37+f4uJisrKyGDhwIBs3bgQoE+AChISEMGTIEHbs2FGpe//Uz8jcuXN9+6y9oqOjy9S379u3b8Al6p999hlhYWG89dZbvPXWW2XOFxYWcuDAAQ4dOkRUVJTvtdi9e3fAkoHbtm0D7IoGJy+jHzRoUJn23vfvyJGKM/7WtsqO7T//+Q9gB8aBPnyqrtzcXLZv3063bt0CJmL0br/44osvypyryu8DEZF6sXUJxI0Ch4MsVy5rth/kWIGblhGhDO7VwV6C7vHYwXGfMUEnpHuVCRiO+fazp7uLA5aFi3IXk5qfyRT6scwziEOD7iFq/VNKSCdSixTA16yikj/d9TqKGrLimxVlgnevQwWHWPHNCsbE1O8v3a5du7J161ZycnKq1P/kGVOv0NBQPOXUGA2mXnZISAj//ve/+ctf/sKCBQt8M46tWrXi1ltv5dFHHy03odpPefPNN5kxYwavv/66b2Y4IiKCcePG8fjjj+N0Ov3aV/RcAYqLAyebqQmHDtk/R3/7298qbHfs2DEAvv/+e4Ayz8ErmPegS5cuAOUmUyudiG7KlCk8/PDDQd3z0KFDuN1uHnrooQrHcezYMaKionyvRaBg/+T2Jwv0HtbF+1cZlR2bN6lfeSsiqsv7s+N930/mPR4ouWBVfh+IiNS5IPezHxp0D5nZ57KOVIosD+nOneUmpEvNjrHLuO09xjldW3HT/seD2s8edUUa9DoXZ9wo5lX44cIFKgUnUkUK4GuIZVmhwC0l3wZOd+7fvrz04w2mDllObsVB8U+drwtDhgzh3//+NytWrOD222+vk3sGO9vfrl07nnrqKZ566im2b99ORkYGs2bN4rnnnuPo0aP861//qtI4mjdv7lvy/e233/LJJ58wd+5cXn31VbKzs1m9evVPX6SOtGnTBrCDq0CrAMpr73K5Ap73LouvjEGDBtGsWTO+/fZbtm3bRu/evSvdt7Ty3vc2bdrg8Xg4fPhwpa7jfW7vvvsuV111VZXGUlu8M+Jud9nPIMvLph8sb5Bc2cz5wfK+vuX9jHi33XjbiYg0KluXQMZ0wF5+nuQ+wDpSKb0r1sJDUs4MnCVL4qPWP8Vwx+9Z5hlU6YR0Fh6m8gIDS64RX1hIanaMXx341PxM4kPs3+XJoRkkRna0A/M+SkgnUpu0B77mTAfigQ+MMR/V92BqQvdWFe8r/6nzdeG2224jLCyMt99+my1btlTY9scff6yjUZWvV69e3H777WRkZNCyZUvefffdGrlujx49uPHGG/noo4/o3bs3n376qW+mt644HI5yZ4HPP/98gEp/qDBggL3v7uSl7WDP5n766aeVHleLFi34xS9+AdjZ4mva+eefz5EjR/jqq68q3R4q/1rUJW9Ohm+//bbMuZPL61WV9/l/9NFHlZrV9i5pr+wKA2+Zxj179vi2I5S2cuVK4MTPmIhIo1KF/ezr2o727We3wirebuU9f5ljIwMPaz+7SEOkAL4GWJY1EfgDsBW4uTJ9jDEDAz1KrtEgDDttGFERZZOhAURFRDHstGF1PKKyoqOjSUtLo7CwkDFjxpQbZHjLvtW1Xbt2BQzsjhw5wo8//hgwuV1lHDhwgMzMzDLH8/LyyM3NJTQ0tFp77KsiKioqYOAHduK5sLAw7rnnHrKyssqcLyws9AtoL7zwQs444ww++eSTMh9yPPfcc5Xe/+718MMP07VrV1599VXuuece8vLyArbzLr8Oxj333APYCdsC1bPPy8vz7fsGOwlibGwsf//73/nggw/KtAd7X/3x48eDHkt1DRo0CIfDweuvv+53/8OHD3PffffVyD0GDhzIhRdeyKZNm5gxY0aZ84cOHaKgoMD3vTch4zfffFPpe6SkpGCM4d577/UL/A8ePMhf//pXXxsRkUbH4WBiXoovcN4cHk569E4ius2nWadlRHSbT3r0TjaX/B9gvjuR+368wzdDX9mEdMs8g/giZgKAvZ+9+yROzn3t3c/u+0BB+9lF6oSW0FeTZVm/Bp4BtgDDjDGVW0fbCESERvDcsOfKJLKLiojiuWHP1XsCO68HHnjAtwf53HPP5cILL2TQoEG0bNkSl8vFJ598wrZt2wIm2aptX375Jddeey0DBw4kPj6erl27cuDAAd59912KiooCZuGujD179nD++edz5plnMmDAAHr06MEPP/zA4sWL2bdvHxMnTqy1hHTlGTZsGPPmzePKK69k4MCBhIaGMnToUIYOHUqfPn2YPXs2KSkpnH322Vx++eXExcVRVFTEN998w+rVq+nYsSNbt9qfX1mWxT//+U+GDx9OUlKSrw78l19+yfLly7n88sv58MOf3Kni07VrV1asWMHYsWN5+umnefnll7n00kuJiYnB4XDgcrlYs2YN27Zto1OnTgGTn1X0vKdPn879999P7969GT16NKeffjrHjh1j9+7dZGRkMGTIEN94w8LCWLhwISNHjmTMmDFceOGF9OvXjxYtWvDtt9/y+eefs3PnTr777rtyExLWli5dunDjjTfyr3/9i379+jFmzBh++OEHPvjgA4YOHRow8VtVvPrqq1x88cU88MADvP3221x88cUYY9i2bRsff/wxW7du9dV6HzZsGG+99RZjx45l9OjRNG/enJ49e3LzzeV/VvrHP/6RpUuX8u6779K3b19Gjx7N8ePHeeutt9i/fz/33XcfQ4YMqZHnIiJSbUEkpMtqN5TM7KPB7Wc/Yn8oGkxCOoODyJEPwpFE7WcXaWAUwFeDZVm/A54CNmMH7/vrd0Q1L75DPB8mfciKb1aQk5tD91bdGXbasAYTvHv9+c9/5uc//znPP/88K1euZM6cORQUFBAVFeUrV3XTTTfV+bgGDRrE/fffT0ZGBh9++CFHjhyhY8eODBw4kIkTJ1Z5VUB0dDQPPfQQq1atYuXKlRw8eJD27dtzxhlnMH36dK6//voafiY/7ZlnnsGyLFasWMEHH3yAx+Nh6tSpDB06FICbbrqJvn378sQTT7By5Uo+/vhjIiMj6dq1K+PGjeO6667zu97gwYNZvXo1f/rTn1i61F6Sl5CQwKpVq/joo4+CCuAB+vTpw6ZNm3jjjTd4++23+eyzz1i8eDGWZdGpUyffz8l1110XdGLBSZMmMXjwYGbOnMmnn37Ku+++S5s2bejWrRu//OUvueGGG/zan3POOXz55Zc8+eSTLF68mDlz5uBwOOjSpQv9+/fnoYceokOHDkGNoaakp6fjdDp54403+Pvf/85pp53GxIkTuffee5k/f36N3OP0009n48aNPPbYYyxatIjnnnuOiIgIoqOj+cMf/kCnTp18be+44w52797NvHnzeOyxx3C73SQmJlYYwIeHh7Ns2TKefPJJXn/9dZ599llCQ0Pp27cvTz/9tG9LhYhIvQsyIV1ezAQgEYOj0vvZAaLbRXBX7jNBJaSLc7YCp/azizQ0lrfEkgTHsqxJ2PveNwHDjTEHa+i6GwYMGDBgw4byctzZvv76awDOPPPMmritiIjUAP1uFpFK27oE5p34gHe+O5FJ7rIJ6WaEpvvtaU8ttBPShUetoFmnZeVe/sf9wyk8NAwLD292ft2vRvtrxRf5JaRLy8/kxpATW9lcseNw3phuB+ciUuNKyiZvLNlCHRTNwFeBZVkPAn8BNgAjmtKyeRERERGpAyUJ6Zw7FgB2Qroiy1MmsE4uFVhvaD+G5XvthHSV3c9+mWOjX/A+351oL60vOhGcT6EfYcbh+6DATkinZfEiDZEC+CBZlnUrdvBeDKwGJgYoL5VtjJlbx0MTERERkcaiJCFdkvsAyaEZdkI6506/ZfHp7mL6usKJLyxkvjuRV5mA4VhQ+9mXeQZxaNA9RK1/yk5Il5eCOWmpvjchXWJkRzt4V0I6kQZLAXzwTi/5MwT4XTltMoC5dTEYEREREWkgajsh3d5jnNO1FTftfzyo/exRV6RBr3OVkE6kCVAAHyRjTBqQVs/DEBEREZGGpA4S0ll4mMoLDCxZ6h5fWEhqdozfsvvU/EziQ/YA9rL8xMiOdmDeRwnpRJoCBfAiIiIiItWxdQlkTAfs/eNJ7gOso2xCuqScGThLgu/+O2cx3BHJMs8grLAjFV7ee/4yx0YGHtZ+dpFTmVJLioiIiIhUR0lCOq/k0Aymhc0irPVGwqNWENZ6I9PCZvllk9/QfgzLPcElpFvmGcQXMRMAO1P8wu6T/D4kgBP72X3j0X52kSZFM/AiIiI1QGVZRU5hdZSQzuAgcuSDcCRR+9lFTlEK4Bspy7IwxuDxeHCoRqeISL3zBvABKpOISGPUQBPSxTlbgVP72UVOVQrgG6lmzZpRUFBAXl4erVoF+KUtIiJ1Ki8vD7B/P4tII9fQE9Jp8kbklKUAvpFq1aoVBQUF7Nu3D4DIyEgsy9LMj4hIHTLGYIwhLy/P9/tYH6qKNHJKSCciDZgC+Eaqffv25OXlcfz4cXJycup7OCIiArRo0YL27dvX9zBEpDpKEtI5dywA7JnvIsvjNzOelp9JcshqX5cN7cewfG/VEtL13znLTkiXl4I5aabfm5AuMbKjPR4lpBM55SmAb6QcDgc9evTg8OHD5Obm8uOPPyqBkohIPbAsi2bNmtGqVSvat2+vvCQijZ0S0olIA6YAvhFzOBx06NCBDh061PdQRERERJqELFeuEtKJSIOlAF5EREREmq4gssnTZwxrth8EUEI6EWmQFMCLiIiISNMUZDZ5EidzzDPOd04J6USkodFHfiIiIiLS9JycTT5nBhYevya+bPIlCevImM5ZP5xIThdsQjrATkjXfZJf1no4kZDOFVvyAYES0olIFWgGXkRERESanipkk3fFjqPHBUmQ+akS0olIg6QAXkRERESanipkk1+Yl8K8zm1IiG5LUs4MJaQTkQZHAbyIiIiINA5BJKTLajc0+Gzy2UfJ2ve9vSdeCelEpAFSAC8iIiIiDV+QCenyYiYAiUFlkwf49rO3ifPuiUcJ6USkYdHHhCIiIiLSsFUhIV3/nbMY7lhvn6tkNnmALa0vshPMoYR0ItLwaAZeRERERBq2KiSk29B+DMv3DgAqn00eoGVEKAy+H7qco4R0ItLgKIAXERERkYatCgnpXmUChmNBZ5Mf3KuDfaKPEtKJSMOjAF5EREREGrQsV27wCen2HuOcrq24af/jwWeTFxFpoBTAi4iIiEjdCyKj/JpDZwEElZDOwsNUXmCgssmLSBOiAF5ERERE6laQGeXPOi0VuASofEK6yxwbGXj4A99xZZMXkaZAHy+KiIiISN2pQkb5hG/SfRnlK5uQbplnEF/ETACUTV5Emg7NwIuIiIhI3alCRvmd3a9h+fYBQSekixz5IBxJVDZ5EWkyFMCLiIiISN2pQkb5he5fcl40JOXMCD4hnVPZ5EWk6VAALyIiIiLVE0RCuqx2Q4POKE/2YVb0WkCMEtKJyClOAbyIiIiIVF2QCenyYiYAiUFllB/uWE9MziLfOSWkE5FTlT6SFBEREZGqqUJCuv47Z/kS0lU2o/wyzyAyT0sFlJBORE5tmoEXERERkaqpQkK6De3HsHzvAKDyGeUBtpzxaxIuvEQJ6UTklKYAXkRERESqpgoJ6V5lAoZjQWeUH9yrgxLSicgpTwG8iIiIiJxQywnpzN5jnNO1FTftfzz4jPIiIqc4BfAiIiIiYquDhHQWHqbyAgOVUV5EJGgK4EVERESkbEI69wHWkeqXLM6XkK4k+LYT0kWyzDOo0gnpLnNsZODhD3zHlVFeRKTy9DGmiIiIiPgS0nklh2YwLWwWYa03Eh61grDWG5kWNssXVENJQjpPcAnplnkG8UXMBEAZ5UVEgqUZeBERERGp04R0kSMfhCOJyigvIhIkBfAiIiIiQpYrt24T0imjvIhI0BTAi4iIiDRVQWSUX3PoLAAlpBMRacAUwIuIiIg0RUFmlD/rtFTgEgAlpBMRaaD00aeIiIhIU3NyRvmcGVh4/Jr4MsrvWABAwjfpDHesB5SQTkSkodIMvIiIiEhTU5JR3hucJ4dmUGR5/Ja2p+Vnkhyy2tdlZ/drWL59gBLSiYg0YArgRURERJqaKmSUX+j+JedFQ1LODCWkExFpoBTAi4iIiDQxVckoT/ZhVvRaQIwS0omINFgK4EVEREQag1rOKD/csZ6YnEW+c0pIJyLS8CiAFxEREWno6iCj/DLPIDJPSyXhm3Q7IV1eCuak+3gT0iVGdrSDdyWkExGpUwrgRURERBqykzPKuw+wjlS/bO++jPIlM+N2RvlWLPMMqnRGeYAtZ/yahAsvUUI6EZEGSgG8iIiISENWhxnlB/fqoIR0IiINmAJ4ERERkYasrjPKi4hIg6UAXkRERKQBU0Z5ERHxUgAvIiIiUteUUV5ERKpAAbyIiIhIXVJGeRERqSIF8CIiIiJ1RRnlRUSkGhTAi4iIiNQVZZQXEZFqUAAvIiIiUleUUV5ERKpBAbyIiIhIdQSRkC6r3VBllBcRkSpTAC8iIiJSVUEmpMuLmQAkKqO8iIhUiT6WFREREamKkxPS5czAwuPXxJeQrmTPe/+dsxjuWG+fCzKjPGBnlO8+yS/pHZzIKO+KHWcfUEZ5EZEmSTPwIiIiIlVRhYR0G9qPYfneAQDKKC8iIkFTAC8iIiJSFVVISPcqEzAcU0Z5ERGpEgXwIiIiIlWQ5coNOiGd2XuMc7q24qb9jyujvIiIBE0BvIiIiIhXEBnl1xw6CyCohHQWHqbyAgOVUV5ERKpAAbyIiIgIBJ1R/qzTUoFLgMonpLvMsZGBhz/wHVdGeRERCYY+yq0iy7K6W5Y127KsvZZl/WhZVrZlWU9bllVxRhoRERFpeKqQUT7hm3RfRvnKJqRb5hnEFzETAGWUFxGR4GkGvgosy4oF1gKdgHeBrcB5wG+Byy3LGmyMOVSPQxQREZFgVCGj/M7u17B8+4CgE9JFjnwQjiQqo7yIiARNAXzVPI8dvE80xjzrPWhZ1pPAPcDDwJ31NDYREREJVhUyyi90/5LzoiEpZ0bwCemUUV5ERKpAAXyQLMuKAUYA2cDfTzo9FfglcLNlWX8wxuTV8fBERESkCqqSUZ7sw6zotYAYJaQTEZE6on89gndpyZ8fG2P8NscZY3KBNUAL4Py6HpiIiIhUzZrtB4ETGeUDLYWHUhnlcXCZYyMxOYt85+a7E5lSNIGiHwZQeGgYRT8MYErRBOa7E31t7IR0S2v1uYiISNOlGfjgnVHyZ1Y557dhz9DHASvKu4hlWRvKOdWn6kMTERERnyBKwh0riPN1q2xG+WWeQWSelkrCN+l2Qrq8FMxJmeu9CekSIzvawbsS0omISDUogA9em5I/vy/nvPd429ofioiIiAQUZEm4ITETeAJ7pryyGeUBtpzxaxIuvEQJ6UREpE4ogK95VsmfpqJGxpiBATvbM/MDanpQIiIip4yTS8K5D7COVL9ybb6ScCX71/vvnMVwRyTLPQOCyig/uFcHJaQTEZE6owA+eN4Z9jblnG99UjsRERGpS1UoCeeKHUfusUuZsedvwWeUFxERqSMK4IP3v5I/48o537vkz/L2yIuIiEhtqkJJuHeOjeeZlnN9M/LKKC8iIg2RAvjgrSz5c4RlWY7Smegty2oFDAbygf/Ux+BEREROdVUpCXfZt//GGb7Ad36+O5Ep7lRM0YngfAr9CDMOkkuCfDujvPa1i4hI3dFHxkEyxuwAPgaigV+fdPohIBJ4RTXgRUREasjWJXa2eOzgfM6aXTy7Yhtz1uwiy5Vrt/F47HZUrSTcMs8gvoiZANjL6Rd2n+S3Z957vYXdJ+GKHWcfUEZ5ERGpY5qBr5q7gLXATMuyhgFfAwnAJdhL5/9Uj2MTERFpOoLMJk/iZI55xvnOVbYkHMCn3VLpf16iMsqLiEiDpQC+CowxOyzLGgT8BbgcGA18B8wEHjLGHK7P8YmIiDQJVcgmT8Z0zurrBJxAcCXhWkaE+gXlyigvIiINjZbQV5Ex5ltjzG3GmC7GmHBjTE9jzG8VvIuIiNSQkmzyXsmhGUwLm0VY642ER60grPVGpoXN8u1JB3v5e48LkgA7uE/LzyTKXRzw8lHuYtLyM7Gwl+cP7tWhFp+MiIhI9WkGXkRERBqmKmSTX5iXwrzObUiIbktSzgyVhBMRkSZFAbyIiIg0SFXJJm+yj5K173t7T7xKwomISBOjAF5ERETqztYlEDcKKkwS54Gspaw5dBZwIpt86Zn30nzZ5EtKvn372dvE7VBJOBERaXoUwIuIiEjdCDKj/FmnpWIXeAkum/yW1hcxLHGy714L81IwJ93LWxIuMbKjL3u9gncREWnoFMCLiIhI7atCRvmEb9IZ7mjFMs+g4LPJD74fupyjknAiItKkKIAXERGR2leSUd5ZsrQ9OTSDIsvjty89LT+T5JDVvi47u1/D8u0DfNnk093FZfbAg52QLjU/kyn0w+A4kU1eJeFERKSJUQAvIiIita8qGeXdv+S8aJRNXkREpIQCeBEREal1VckoT/ZhVvRaQIyyyYuIiAAK4EVERKQOrNl+EAguo/xwx3pichb5zimbvIiInOr08bSIiIhUzdYldsk37Bn2OWt28eyKbcxZs4ssV67dxuOBrUs4VuD2datsRvllnkFknpYKYGeT7z7JL+kdnMgm74odZx9QNnkREWnCNAMvIiIiwQuyJNyQmAk8QSJAUBnlt5zxaxIuvETZ5EVERFAALyIiIsGqQkm4/jtnMdwRyXLPgOAzyjuVTV5ERAQUwIuIiEiwqlASzhU7jtxjlzJjz9+UUV5ERKSKFMCLiIhIcKpQEu6dY+N5puVc34y8MsqLiIgETwG8iIiIBKUqJeEu+/bfOMMX+M4ro7yIiEjw9JG2iIiIBJVR/uSScIH2skOpknA4WOYZxBcxEwBllBcREakqzcCLiIic6oLMKH/WaanAJUDlS8IBfNotlf7nJSqjvIiISBUpgBcRETmVVSGjfMI36Qx3tGKZZ1BQJeFaRoT6BeXKKC8iIhIcLaEXERE5lZVklPdKDs1gWtgswlpvJDxqBWGtNzItbJZvXzrAzu7XsNwzAAsPafmZRLmLA146yl1MWn4mFvbS/MG9OtTucxEREWniNAMvIiJyKqtCRvmF7l9yXjQk5cxQSTgREZE6pABeRETkFFaVjPJkH2ZFrwXEqCSciIhInVIALyIicgo7OaN86Zn30nwZ5YscDHesJyZnke+cSsKJiIjUDX0MLiIi0tQEURLuWIHb162yGeWXeQaReVoqoJJwIiIidUkz8CIiIk1JkCXhhsRM4AkSAYLKKL/ljF+TcOElKgknIiJShxTAi4iINBVVKAnXf+cshjsiWe4ZQFp+Junu4jJ74MFOSpean8kU+mFw2BnlnSoJJyIiUpcUwIuIiDQVJSXhnDsWAHbyuCLL45dcLi0/k+SQ1b4urthx5B67lBl7/qaM8iIiIg2cAngREZGmogol4d45Np5nWs71zcgro7yIiEjDpQBeRESkiahKSbjLvv03zvAFvvPKKC8iItJw6aNzERGRJuLkknCB9rJDqZJwOFjmGcQXMRMAZZQXERFp6DQDLyIi0kRUpSQcwKfdUul/XqIyyouIiDRwCuBFREQasq1LIG4UVBhYeyBrKS0jzvJ1C6YkXMuIUL+gXBnlRUREGiYF8CIiIg1VkDXdrxp0Dw9xLhae4EvCiYiISIOnAF5ERKQhqkJN96j1T3FX5z8TfTBDJeFERESaIAXwIiIiDVFVarrHJHErX+E8qpJwIiIiTZECeBERkYaoCjXddx8+i3uP/tV3XiXhREREmhZ93C4iItIAeWu6T3Kn8lrxRWWWwsOJmu6vFV/EJHcqf993JocG3QOoJJyIiEhTpBl4ERGRBujkmu6lZ95L89V0L5llf6/drdx2/bkqCSciItIEKYAXERFpgKpa0/1YgVsl4URERJooBfAiIiJ1pa5quouIiEiTpH/lRURE6oJquouIiEg1KYAXERGpbarpLiIiIjVAAbyIiEhtU013ERERqQEK4EVERGqbarqLiIhIDdBH9CIiIrVMNd1FRESkJmgGXkREpJappruIiIjUBAXwIiIiVRFESbhjBXG+bqrpLiIiIlWlAF5ERCRYQZaEGxIzgSdIBFTTXURERKpOe+BFRESCcXJJuJwZWHj8mvhKwpVkne+/cxbDHet9Nd2j3MUBLx3lLiYtP9N3PdV0FxERkdL00b6IiEgwqlISLnYcuccuZcaev6mmu4iIiFSZAngREZFgVKEk3DvHxvNMy7k4Q1XTXURERKpOAbyIiEgQvCXh1pFKkeUh3bmz3JJwqdkxTHGnctm3/8YZvsB3XjXdRUREpCr0sb6IiEgQTi4Jd3Lw7uUrCYeDZZ5BfBEzAVBNdxEREak6zcCLiIgE4ViB2/d1MCXhPu2WSv/zElXTXURERKqsxgJ4y7Is4DJgODAUOA3oAOQD+4FNwL+B94wxe2rqviIiItUWRE33lhFn+boFXRJONd1FRESkGqodwFuW1QKYCEzADtqtklMF2IF7cyAGiAWSgGcsy3ofeMIYs7a69xcREamWIGu6XzXoHh7iXF9JuHR3ccBl9FHuYlLzM5lCPwwOlYQTERGRaqtWAG9Z1m3ANKALsBV4CFgDfG6M+aFUOws4AzgfGAlcDVxjWdYC4F5jzDfVGYeIiEiVnFzT3X2AdaT67U/31XQvSS4Xtf4p7ur8Z6IPZqgknIiIiNSp6s7A/xNYBDxqjPm8vEbGGIMd4G8F5lqW1Rq4FZgMjAf+Us1xiIiIBK8qNd1jkriVr3AeVUk4ERERqVvVDeAHGWM2BtupZHb+Wcuy0oHoao5BRESkaqpQ03334bO49+hffedVEk5ERETqSrWmAqoSvJ/Uv8AYs7U61xAREakqb033Se5UXiu+qMxSeDhR0/214ouY5E7l7/vO5NCgewCVhBMREZG6pTJyIiJyyjq5pnvpmffSfDXdS2bZ32t3K7ddf65KwomIiEidqvEA3rKs7sA9QD+gOxAWoJkxxsTW9L1FRESCUdWa7scK3CoJJyIiInWuRgN4y7IuBj4AIgA34Cr5s0zTmrxvXbEsqzcwFjuTfm/ACRwB/gM8bYxZWY/DExERqLua7iIiIiJ1rKb/B/IYEALcArxujPHU8PXr21+B64At2B9UHMYuj3cVcJVlWb81xsysx/GJiJzaVNNdREREmrCaDuB/BrxhjHm1hq/bUHwIzDDGfFH6oGVZicAy4G+WZb1ljPmuXkYnInIqU013ERERaeJqOoA/gj0r3SQZY+aWczzDsqxVwHDgQuDtOhyWiIiAarqLiIhIk1fTAfxiILGGr9lYFJX8GWjPv4iI1DbVdBcREZEmrqYD+AeA/1iW9XfgPmNMXg1fv0GyLKsnMAw4DnxSyT4byjnVp6bGJSJyKvHWdF9HKkWWh3TnznJruqdmx9iB+j4HKUPuIWr9U3ZN97wUzEn75r013RMjO9rBu2q6i4iISD2p0QDeGHPQsqzLgUzgFsuysoDvAzc1w2ry3vXFsqxmwGtAM+wPLSquQyQiIrVCNd1FRESkqavpMnJnAysBb62d/uU0NTV532BYlpUN9Ayiy2vGmJvKuVYI8C9gMPAm8HhlL2qMGVjONTcAA4IYn4iIoJruIiIi0vTV9BL6J4Eo4M/Ay8BeY0xxDd+junYABUG03xvoYEnw/irwc2A+cJMxpt4+mBARaZJU011ERETEp6b/13IBsNAYM62Gr1tjamLpvmVZocDr2MH768AtDfCDChGRxk013UVERET81HQAXwhk1/A1GxTLssKxZ9yvBl4BbjPGeOp3VCIiTYxquouIiIiUUdMB/CrgvBq+ZoNRkrBuITAa+CfwSwXvIiK1QDXdRURERMqo6QD+PiDTsqzJwIwmuCf8Rezg/SCwB/izZVknt1lljFlVx+MSEWlaVNNdREREpIyaDuCnAJuBh4FUy7I2UX4Zudtr+N514fSSPztgJ+orz6raH4qISNOlmu4iIiIiZdV0AD++1NencyLgPZkBGl0Ab4y5uL7HICJyKlBNdxEREZGyajqALy9gFxERqTTVdBcREREpq0YDeGNM4CkSERGRIJSuza6a7iIiIiK2aqfdtSzracuyhloBsrmJiIgAdlk4j120I8uVy5w1u3h2xTbmrNlFlivXbuPx2O3AV5vdW9M9yl0c8LJR7mLS8jOx8Pj1ExEREWmKamKq4m7gN8Ahy7Lewy6zttwYU1gD1xYRkcZu5aOQMR1X7Dgm5qWQeVJiOYCE6LbMjJztSywXd8n9JES3JSlnhmq6i4iIiJSoiQC+K3ANcC1wE3AbkGdZ1gfAO8AHxpjcGriPiIg0NluXQMZ0wC7ZluQ+wDpSMaUWgFl4SMqZgbOktBsZ06FzPDMjF/mOqaa7iIiISA0E8MaY/cA/gH9YltUauAI7mB8NJAM/Wpa1AjuYf88Yc6C69xQRkUYibhSu2HH2zDp2oF1kefwC8bT8TJJDVvu6uGLH4cTy9QHVdBcRERGBGtgDX5ox5gdjzOvGmJ8DHbFn5ucBCUA6sNeyrAzLsn5rWVbPmry3iIg0QA4HE/NSmO9OBGBzeDjp0TuJ6DafZp2WEdFtPunRO9kcHg7Ygfpv81LgzCvsGu3YAf3C7pP8Zu3hRE13V+w4+4BquouIiEgTV2vpeo0xPwLvAe9ZluUAEoGxwNXAU8CTlmVtMsYMrK0xiIhI/cpy5ZKZfZR1pFJkeUh37vTbxw52Lfe7nR1JzY6xZ9mzj5LlyiXukvuhyzmq6S4iIiJSok7q7RhjPMDKksdvLMsahB3MX1MX9xcRkfqxZvtBwJ4tT2ueQERo4Gqjh0JDSGue4Fsiv2b7QTs4V013EREREZ+aKCN3VckMe6UZY9YbYx4wxpxV3fuLiEjDdazA7fvaCjtSYdvS50v3ExERERFbTeyBXwTstizrL9rXLiIipbWMOLHQyxS1q7Bt6fOl+4mIiIiIrSYC+BXYpeSmADssy1pqWda1lmWF/EQ/ERFpjLYuAY8HsPe4z1mzi2dXbGPOml1kuUqqhno8sHUJg3t1AOxScWn5mUS5iwNeMspdTFp+Jhb2db39REREROSEmigjN7xk5v0OYDwwEhgBuCzLmgP80xizs7r3ERGRBmDlo5AxHVfsOCbmpZCZfbRMk4TotsyMnI1zxwLiEieTED2UpJwZJIespq8rnLudHf0S2UW5i3nOdYD4kD2EGTuzfMC97iIiIiKnuBopI2eM2W2MeRDoCVwFLAY6APcDWZZlfWxZ1jjLsrQmUkSksdq6BDKmA3bN9aScGb4Zcy8LD0k5M07UcM+Yziym+Wq1xxcWkpodQ8GeZH7cP5yCPcmkZscQX1gI2HXin4mc7ZvhFxEREZETajSgLsk2vxhYbFlWZyCl5HEZMAw4aFnWXOAlY8y2mry3iIjUsrhRuGLH+YLz5NAMiiwPac0TsMKOYIrakZafSXLIal+Xo50vpO2+tb7v57sT7VJxRSc+P55CP8KMwxfkO3csUFk4ERERkQBqZAY+EGPMPmPMI8aYXsBwYD7QGvgj8HVt3VdERGqJw8HEvBTmuxMB2BweTnr0TiK6zadZp2VEdJtPevRONoeHA3awfidTIHEyAK7YcSzsPglz0j89BnvZvCt2nH0gcbKCdxEREZEA6mpJewbQHjgdOK+O7ikiIjUoy5VLZvZR1pFKkeUh3bnTby872PXc73Z2JDU7xp5pzz5K1rV3E9flHJxxo5jncJDlymXN9oMcK3DTMiKUwb062HvePRdo5l1ERESkArUawFuWdQZ2crtbsPfEW8Au4J+1eV8REal5a7YfBOwZ87TmCUSE7g7Y7lBoCGnNE3zL5NdsP0jc4BNBeZyzVeAkdQ6HgncRERGRCtR4AG9ZVgSQjB24D8YO2ouAhUC6Mebjmr6niIjUvmMFbt/XVtiRCtuWPl+6n4iIiIhUXY0F8JZl9QNSgRuw97pbwA7gJWCOMWZ/Td1LRETqXsuIE/9kmKJ2FbYtfb50PxERERGpumr/r8qyrAnYgXt/7KC9EHgL+Icx5t/Vvb6IiNSirUsgbhRUuDfdA1lLGdxrKGCXikvLzyTdXVxmDzzYdd1T8zOZQj8MDgb36lDXz0pERESkSaqJaZEXSv7MAtKBl40xB2vguiIiUptWPgoZ03HFjmNiXgqZ2UfLNEmIbsvMyNk4dywgLnEyCdFDScqZQXLIavq6wrnb2dEviI9yF/Oc6wDxIXsIM3Z2+YD73UVEREQkaDURwL+BPdueUQPXEhGRurB1CWRMB+y660nuA6wj1a/Em4WHpJwZOEvqs5MxnVmdP6FtqF3XPb6wkNTsGL868Kn5mcSH7AHsOvGJkR3t7PKOWqtaKiIiInLKqHYAb4y5sSYGIiIidShuFK7YcTh3LADsYLvI8vgF42n5mSSHrPZ1Odr5QtruW+v7fr470S4VV3QiOJ9CP8KMg+SSoN+5Y4FKw4mIiIjUkJrYA39LVfoZY16p7r1FRKSKHA4m5qWQ5D5AcmgGm8PDSXfu9CsNl+4upq8rnPjCQua7E1nIJOYlfuJbdr8wLwVz0rJ7g71sPjGyox28J05W8C4iIiJSQ2piCf1cwATR3ipprwBeRKSeZLlyycw+yjpSKbI8pDt3lklIdyg0hLudHUnNjrFn2rOPknXt3cR1OQdn3CjmVZj47gLNvIuIiIjUsJqq7eMGFgNbauh6IiJSi9Zst3ONGhykNU/wm3kv7VBoCGnNE3zL5NdsP0jc4BNBeZyzVeAkdQ6HgncRERGRGlYTAXwGMBS4BuiEnYl+vjGmoAauLSIiteBYgdv3tRV2pMK2pc+X7iciIiIidavaaYGNMZcAZwCPA72AOcB3lmU9a1nWOdW9voiI1LyWESc+vzVF7SpsW/p86X4iIiIiUrdqpK6PMWa7MWYS0ANIBjKBXwFfWJa1zrKs2y3LiqyJe4mISDm2LgGPB7D3uM9Zs4tnV2xjzppdZLly7TYeD2xdwuBeHQC7VFxafiZR7uKAl4xyF5OWn4mFfV1vPxERERGpezU6lWKMcQNvA29bltUTuAMYD/wDeNKyrMuNMZ/V5D1FRARY+agvO/zEvBQyT8oOD5AQ3ZaZkbNx7lhAXOJkEqKHkpQzg+SQ1fR1hXO3s6NfIrsodzHPuQ4QH7KHMGNnlw+4311ERERE6kStrYU0xuwGHrQsay0wC+gGdKyt+4mInLK2LoGM6YBddz3JfYB1pGJKLbKy8JCUMwNnSX12MqYzq/MntA2167rHFxaSmh3jVwc+NT+T+JA9gF0nPjGyo51d3lEji7dEREREJEi1EsBbltUVSCl59AQKgFeBjbVxPxGRU1rcKFyx4+y669jBdpHl8QvG0/IzSQ5Z7etytPOFtN231vf9fHeiXSqu6ERwPoV+hBkHySVBv3PHApWGExEREalHNTaNYlmWw7KsqyzLeg/IBv4C5AK/BboaY241xuTU1P1ERKSEw8HEvBTmuxMB2BweTnr0TiK6zadZp2VEdJtPevRONoeHA3awfidTIHEyAK7YcSzsPslvxh7sEnMLu0/CFTvOPpA4WcG7iIiISD2q9gy8ZVmnA7cDtwFdgDzgZSDdGLOuutcXEZGKZblyycw+yjpSKbI8pDt3+u1lB7ue+93OjqRmx9gz7dlHybr2buK6nIMzbhTzHA6yXLms2X6QYwVuWkaEMrhXB3vPu+cCzbyLiIiINAA1sYR+e8mf64GpwBvGmLwauK6IiFTCmu0HAXvGPK15AhGhuwO2OxQaQlrzBN8y+TXbDxI3+ERQHudsFThJncOh4F1ERESkAaiJAN4CirBn3/8M/NmyrJ/qY4wxPWvg3iIip7xjBW7f11bYkQrblj5fup+IiIiINHw1lcQuDOheQ9cSEZEgtIw48avcFLWrsG3p86X7iYiIiEjDV+0kdsYYR1UeNTF4ERGBwb06AHapuLT8TKLcxQHbRbmLScvPxMLj109EREREGgdNv4iINERbl0DcKKgwuZwHspYS12cMCdFtScqZQXLIavq6wrnb2dEvkV2Uu5jnXAeID9lDmLGzywfc7y4iIiIiDZYCeBGRhmblo5AxHVfsOCbmpZCZfbRMk4TotsyMnG3XZh86iZmRO3CW1GuPLywkNTvGrw58an4m8SF7ALtOfGJkRzu7vEMLokREREQai2oF8JZlNTfG5Nf3NUREmoytSyBjOgDOHQtIch9gHal+NdotPCTlzPAF7HwyA2epS8x3J9ql4opO9JlCP8KMg+SSPs4dC1QaTkRERKSRqe7Uyy7Lsn5rWVazYDtaltXXsqx3gT9WcwwiIk1H3ChcseN83yaHZjAtbBZhrTcSHrWCsNYbmRY2yxeIA3b7oZN8Xy/sPskv4Ae7xNzC7pNOXDtxsoJ3ERERkUamukvoPwaeBKZalvUmMB/4T3kz6pZlxQAjgVuA84Bvgb9VcwwiIk2Hw8HEvBSS3AdIDs1gc3g46c6dfrXd093F9HWFE19YyHx3IgvzUph36WDo2hdn3CjmVbhv/gLNvIuIiIg0UtUK4I0xt1iWNRN4BPhlyaPYsqyvge+AI0AEEAWcAXTArhvvAv4EPGWM+bE6YxARaUqyXLlkZh9lHakUWR7SnTv9ktEBHAoN4W5nR1KzY+yl8tlHyXLlElcqKI9ztgqcpM7hUPAuIiIi0khVO4mdMWY9MMKyrN7A7cAwoB/ws5OaHgAWAm8Dbxtjiqp7bxGRpmbN9oOAveQ9rXmC38x7aYdCQ0hrnuDb575m+0FllRcRERFp4mosC70xZhswGcCyrBZAN+yZ93xgvzHmu5q6l4hIU3WswO372go7UmHb0udL9xMRERGRpqlWysgZY44D20oeIiJSSS0jTvxaNkXtKmxb+nzpfiIiIiLSNKkAsIhIAzK4VwfALhWXlp9JlLs4YLsodzFp+ZlYePz6iYiIiEjTpSkbEZEGJM7ZioTotiTlzCA5ZDV9XeHc7ezol8guyl3Mc64DxIfsIczY5eG0/11ERESk6VMALyJS27YugbhRUGF5Nw9kLYW4UcyMnI2zpM57fGEhqdkxpDVPwAo7gilqR2p+JvEhewC7TnxiZEe7PJxDi6pEREREmjIF8CIitWnlo5AxHVfsOCbmpZCZfbRMk4TotnbQvmMBnD0W546FvnPz3Yl2qbiiE8H5FPoRZhwklwT5zh0LVNtdRERE5BSg6RoRkdqydQlkTAfsIDspZ4Zvz7qXhYeknBl2EA7w1UI4eywArthxLOw+CXPSr2qDvWzeFTvOPpA4WcG7iIiIyClAM/AiIrUlbhSu2HG+4Dw5NIMiy+O3HD4tP5PkkNW+Lq7YcTiT0uFn43DGjWJehcvuL9DMu4iIiMgppE4CeMuy0oBXjDE76+J+IiINgsPBxLwUktwHSA7NYHN4OOnOnUSE7vY1SXcX09cVTnxhIfPdiSzMS2Gew+EXlMc5WwVOUndSOxERERFp2upqBv7PQKplWYnGmO3eg5ZlNQMuNMasrKNxiIjUmSxXLpnZR1lHKkWWh3TnTr9s8gCHQkO429mR1OwYe6979lGyXLnKKi8iIiIiZdTlHvjXgZWWZcWWOtYWWF6HYxARqTNrth8E7D3rac0TygTvXodCQ0hrnuDb6+7tJyIiIiJSWl3NwBvgb8BBYJVlWUONMbtKzll1NAYRkTp1rMDt+9oKO1Jh29LnS/cTEREREfGq0yR2xpgZlmU5sIP4RCAfO7gXEWlyWkac+BVritpV2Lb0+dL9RERERES86moJvW+W3RjzKPAPYBVweh3dX0Skzg3u1QGwS8Wl5WcS5S4O2C7KXUxafqavxJy3n4iIiIhIaXU1zTMJyPN+Y4x5uGQm/v06un+tsSzrn0BKybe9SyfpE5EmaOsSiBsFFZZ380DWUuL6jCEhui1JOTNIDllNX1c4dzs7+u2Fj3IX85zrAPEhewgzdn13JbATERERkUCqHcBblvUAsNAYs7W8NsaYvwU49lfLsjzAvdUdQ32xLOtK7OD9GNCynocjIrVt5aOQMR1X7Dgm5qWQmX20TJOE6LbMjJxt134fOomZkTtwhmYAEF9YSGp2jF8d+NT8TOJD9gB2nfjEyI52fXdHXeYYFREREZHGoCZm4KeVXOcv3gOWZTU3xuT/VEdjzMPAwzUwhjpnWVZHIB14E+gMJNbviESkVm1dAhnTAXDuWECS+wDrSPVljgd7qXxSzgxfwM4nM3CWusR8d6JdKq7oRJ8p9CPMOEgu6ePcsQCyxqq+u4iIiIiUUVtTPPdZlrU/0AnLsjpblhVZS/etS/8o+fPX9ToKEakbcaNwxY7zfZscmsG0sFmEtd5IeNQKwlpvZFrYLF8gDtjth07yfb2w+yS/gB/sEnMLu086ce3EyQreRURERCSg2twDH1XO8QnAFCCsFu9dqyzLGg9cA1xrjDlkWaqEJ9LkORxMzEshyX2A5NAMNoeHk+7cSUTobl+TdHcxfV3hxBcWMt+dyMK8FOZdOhi69sUZN4p5Fe6bv0Az7yIiIiJSofqqVdRoN3daltUTeAZ41RizqJ6HIyJ1JMuVS2b2UdaRSpHlId250y8ZHcCh0BDudnYkNTvGXiqffZQsVy5xpYLyOGerwEnqHA4F7yIiIiJSIRUbDkJJ5vyXsZPWTazmtTaUc6pPda4rIrVjzfaDgL3kPa15gt/Me2mHQkNIa57g2+e+ZvtBZZUXERERkRrRaGfCq8qyrGzLskwQj1dLdb8HO1ldqjHmSD09BRGpB8cK3L6vrbCK//qXPl+6n4iIiIhIddTUDLypoevUhR1AQRDt9wJYltUbO2P+HGPMB9UdhDFmYKDjJTPzA6p7fRGpWS0jTvy6NEXtKmxb+nzpfiIiIiIi1VFT/7OcYlnW1cDnJY/Taui6Nc4YM6yKXc8GmgG3WZZ1WzlttpUktLtW++NFmpbBvToAdqm4tPxM0t3FZfbAA0S5i0nNz2QK/TA4fP1ERERERKqrJgL4FUB/7FnjAcAvvScsy8oAviz1+L8auF99yQb+Wc65Mdi14N8CfihpKyJNSJyzFQnRbUnKmUFyyGr6usK529nRL4iPchfznOsA8SF7CDN2eTjtfxcRERGRmlLtAN4YMxzAsqwYYFCpR3/gopKHd4m9BzsBXKNjjNkE3BHonGVZq7AD+AeMMdvrcFgiUh1bl0DcKKiwvJsHspZC3ChmRs7GWVLnPb6wkNTsGNKaJ2CFHcEUtSM1P5P4kD2AXSc+MbKjXR7OccqlGxERERGRWlBjmzONMTuBncB87zHLsuLwD+r7AW1oXHvmRaQpWvkoZEzHFTuOiXkpZGYfLdMkIbqtHbTvWABnj8W5Y6Hv3Hx3ol0qruhEcD6FfoQZB8klQb5zxwLVdhcRERGRGlOr00LGmCxjzOvGmN8bY4ZiB+/xwPjavK+ISIW2LoGM6YAdZCflzMDC49fEwkNSzgw7CAf4aiGcPRYAV+w4FnafhDnpV6jBXjbvih1nH0icrOBdRERERGpMnaZHNsYYYEvJo8kwxlxc32MQkSDEjcIVO84XnCeHZlBkefyWw6flZ5IcstrXxRU7DmdSOvxsHM64UcyrcNn9BZp5FxEREZEap/pGInLqcTiYmJdCkvsAyaEZbA4PJ925k4jQ3b4m6e5i+rrCiS8sZL47kYV5KcxzOPyC8jhnq8BJ6k5qJyIiIiJSExTAi8gpJ8uVS2b2UdaRSpHlId25s0xJuEOhIdzt7Ehqdoy91z37KFmuXGWVFxEREZF6o9TIInLKWbP9IGDvWU9rnhCwnjvYQXxa8wTfXndvPxERERGR+qAAXkROOccK3L6vrbAjFbYtfb50PxERERGRuqYAXkROOS0jTuweMkXtKmxb+nzpfiIiIiIidU0BvIiccgb36gDYpeLS8jOJchcHbBflLiYtP9NXYs7bT0RERESkPmg6SUROOXHOViREtyUpZwbJIavp6wrnbmdHv73wUe5innMdID5kD2HGru+uBHYiIiIiUp8UwItI07B1CcSNggrrs3sgaynEjWJm5GycoRkAxBcWkpod41cHPjU/k/iQPYBdJz4xsqNd392hhUsiIiIiUj8UwItI47fyUciYjit2HBPzUsjMPlqmSUJ0Wzto37EAzh6Lc8dC37n57kS7VFzRieB8Cv0IMw6SS4J8544FkDVW9d1FREREpN5oKklEGretSyBjOmAH2Uk5M3x71r0sPCTlzLCDcICvFsLZYwFwxY5jYfdJvlJxXgZ72bwrdpx9IHGygncRERERqVeagReRxi1uFK7Ycb7gPDk0gyLL47ccPi0/k+SQ1b4urthxOJPS4WfjcMaNYl6Fy+4v0My7iIiIiDQICuBFpHFzOJiYl0KS+wDJoRlsDg8n3bmTiNDdvibp7mL6usKJLyxkvjuRhXkpzHM4/ILyOGerwEnqTmonIiIiIlJfFMCLSKOW5colM/so60ilyPKQ7tzpl00e4FBoCHc7O5KaHWPvdc8+SpYrV1nlRURERKRR0R54EWnU1mw/CNh71tOaJ5QJ3r0OhYaQ1jzBt9fd209EREREpLFQAC8ijdqxArfvayvsSIVtS58v3U9EREREpDFQAC8ijVrLiBM7gUxRuwrblj5fup+IiIiISGOgAF5EGrXBvToAdqm4tPxMotzFAdtFuYtJy8/0lZjz9hMRERERaSw0BSUijVqcsxUJ0W1JyplBcshq+rrCudvZ0W8vfJS7mOdcB4gP2UOYseu7K4GdiIiIiDQ2CuBFpHHzeJgZORtnaAYA8YWFpGbH+NWBT83PJD5kD2DXiU+M7GjXd3doEZKIiIiINB4K4EWk4dm6BOJGgcNBliuXNdsPcqzATcuIUAb36mDPnns8kLUUAOeOBb6u892Jdqm4ohPB+RT6EWYcJJcE+c4dCyBrrOq7i4iIiEijogBeRBqWlY9CxnRcseOYmJdCZvbRMk0Sotvas+47FkDiZPtR0mdhXgrmpD4Ge9l8YmTHE30UvIuIiIhII6MAXkQajq1LIGM6YM+SJ7kPsI5UX+12sJPVJeXM8C2ZJ2M6XP86XP86zrhRzKtw1v4CzbyLiIiISKOlAF5EGo64Ubhix/mWxCeHZlBkefz2s6flZ5IcstrXxRU7DmfJcnvfZZytAiepczgUvIuIiIhIo6UAXkQaDoeDiXkpJLkPkByawebwcNKdO4kI3e1rku4upq8rnPjCQua7E1mYl8I8JaMTERERkVOAAngRaTCyXLlkZh9lHakUWR7SnTv9ysEBHAoN4W5nR1KzY+xkddlHyXLlqiyciIiIiDR5mrYSkQZjzfaDgJ10Lq15Qpng3etQaAhpzRN8e+O9/UREREREmjIF8CLSYBwrcPu+tsKOVNi29PnS/UREREREmioF8CLSYLSMOLGrxxS1q7Bt6fOl+4mIiIiINFUK4EWkwRjcqwNgl4pLy88kyl0csF2Uu5i0/EwsPH79RERERESaMk1biUiDEedsRUJ0W5JyZpAcspq+rnDudnb02wsf5S7mOdcB4kP2EGYcLOw+SQnsREREROSUoABeRBoOj4eZkbNxhmYAEF9YSGp2jF8d+NT8TOJD9gB2nfjEyI7gucCvDryIiIiISFOkAF5EGo6spTh3LPB9O9+daJeKKzoRnE+hH2HGQXJJkO/csQCyxkKfMXU+XBERERGRuqQpKxGpXVuXgMfeq57lymXOml08u2Ibc9bsIsuVa7fxeOx2fcZA4mQAXLHjWNh9kq9UnJfBXjbvih1nH0icrOBdRERERE4JmoEXkdqz8lHImI4rdhwT81LIzD5apklCdFt72fyOBXYwfsn90OUcnHGjmOdwkOXKZc32gxwrcNMyIpTBvTrYe949F2jmXUREREROKQrgRaR2bF0CGdMBe5l7kvsA60j1m1G38JCUM8O3552M6dDlHL+gPM7ZKnCSOodDwbuIiIiInFIUwItI7YgbhSt2nG9Pe3JoBkWWxy8hXVp+Jskhq31dXLHjcMaNqq8Ri4iIiIg0aArgRaR2OBxMzEshyX2A5NAMNoeHk+7cSUTobl+TdHcxfV3hxBcWMt+dyMK8FOYpm7yIiIiISEAK4EWkVmS5csnMPso6UimyPKQ7d/rVcwc4FBrC3c6OpGbH2Nnms4+S5cpVXXcRERERkQA01SUitWLN9oOAnTU+rXlCmeDd61BoCGnNE3x74739RERERETEnwJ4EakVxwrcvq+tsCMVti19vnQ/ERERERE5QQG8iNSKlhEnduiYonYVti19vnQ/ERERERE5QQG8iNSKwb06AHapuLT8TKLcxQHbRbmLScvPxMLj109ERERERPxpqktEakWcsxUJ0W1JyplBcshq+rrCudvZ0W8vfJS7mOdcB4gP2UOYcbCw+yQlsBMRERERKYcCeBGpHR4PMyNn4wzNACC+sJDU7Bi/OvCp+ZnEh+wB7DrxiZEdwXMBqJSciIiIiEgZCuBFpHZkLcW5Y4Hv2/nuRLtUXNGJ4HwK/QgzDpJLgnznjgWQNRb6jKnz4YqIiIiINHSa5hKRytm6BDz2PvUsVy5z1uzi2RXbmLNmF1muXLuNx2O3AzsIT5wMgCt2HAu7T/KVivMy2MvmXbHj7AOJkxW8i4iIiIiUQzPwIvLTVj4KGdNxxY5jYl4KmdlHyzRJiG5rL5nfscAOxC+53350OQdn3CjmORxkuXJZs/0gxwrctIwIZXCvDvaed88FmnkXEREREfkJCuBFpGJbl0DGdMBe4p7kPsA6Uv1m0y08JOXM8O13J2M6dDnHDshLBeVxzlaBk9Q5HAreRURERER+ggJ4EalY3ChcseN8+9mTQzMosjx+yejS8jNJDlnt6+KKHYczblR9jVhEREREpElSAC8iFXM4mJiXQpL7AMmhGWwODyfduZOI0N2+JunuYvq6wokvLGS+O5GFeSnMUyZ5EREREZEapQBeRCqU5colM/so60ilyPKQ7tzpV8sd4FBoCHc7O5KaHWNnms8+SpYrVzXdRURERERqkKbIRKRCa7YfBOyM8WnNE8oE716HQkNIa57g2xvv7SciIiIiIjVDAbyIVOhYgdv3tRV2pMK2pc+X7iciIiIiItWnAF5EKtQy4sROG1PUrsK2pc+X7iciIiIiItWnAF5EKjS4VwfALhWXlp9JlLs4YLsodzFp+ZlYePz6iYiIiIhIzdAUmYhUKM7ZioTotiTlzCA5ZDV9XeHc7ezotxc+yl3Mc64DxIfsIcw4WNh9khLYiYiIiIjUMAXwIlIxj4eZkbNxhmYAEF9YSGp2jF8d+NT8TOJD9gB2nfjEyI7guQBUSk5EREREpMYogBeRimUtxbljge/b+e5Eu1Rc0YngfAr9CDMOkkuCfOeOBZA1FvqMqfPhioiIiIg0VZoeEzkVbV0CHnuvepYrlzlrdvHsim3MWbOLLFeu3cbjsdv1GQOJkwFwxY5jYfdJvlJxXgZ72bwrdpx9IHGygncRERERkRqmGXiRU83KRyFjOq7YcUzMSyEz+2iZJgnRbe1l8zsW2MH4JfdDl3Nwxo1insNBliuXNdsPcqzATcuIUAb36mDvefdcoJl3EREREZFaogBe5FSydQlkTAfsZe5J7gOsI9VvRt3CQ1LODN+edzKmQ5dz/ILyOGerwEnqHA4F7yIiIiIitURL6KvAst1qWdYqy7IOW5aVb1nWLsuy5luWFVff4xMpV9yoE8vcsRPOTQubRVjrjYRHrSCs9Uamhc3y7WUHe9k8caPqY7QiIiIiIlKKZuCDZFlWBPAWcAXwP+B14P/bu//4OLP6sPef72gs7NgGL7YZtpjiWEZx8lJ3NyVBGKcRhoTUMWlgLZTcNoHiolxaHOcXN/Y2plXSm6zdhBSWzQ2J6QItaR1jTLmNYwKBjXBMq4VQSDZZR9hGm9osg23WIBsZaTSnfzyj8UiWZGktazTW5/16Pa9n5jnnzBxZx9J8dZ5zvoPA3wP+EdAK9Netg9J0cjl2X93JjtIFuvK9PN7czMHCWZbmn6xWOVga5d5iM23DwxwudXD06k4OuZu8JEmSVHcG8LP3DrLg/UFgX0qpXFsYEUvq0itpBvqLg/QNXOYxuhmJMgcLZ8flcwe4lG9iV2Et3QMbst3mBy7TXxw0r7skSZJUZ06rzUJEtABvAT4L/MrE4B0gpTQy7x2TZujk6YtAtmt8z7L2G4L3MZfyTfQsa6+ujR9rJ0mSJKl+nIGfnf+L7I8eHwCeHRE/BrwQuAR8KqV0up6dk27myrVS9XEseXraurXlte0kSZIk1YcB/Ox8f+X8HOAMsLqmLEXE7wK7U0qjN3uhiPiLKYo23VoXpamtWHr9v3wauWvaurXlte0kSZIk1Ye30M/O8yrnXwM+B/wDYCXwKrKA/l8Bb69P16Sb27JxDZCliusZ6mN1afK/Na0ujdIz1EdQHtdOkiRJUv0summ1iBgAXjSLJn+QUvqpyuOxBcNPAa9LKQ1Vnn8qIjqBzwO/GBG/kVIanu5FU0ovmaJ/fwH8w1n0T5qx1sJK2tevYse5A3Q1neDeYjO7CmvHrYVfXRrl4eIF2prOsyTlOLpujxvYSZIkSQvAogvgyWbKr82i/ldqHo8tCv5YTfAOQErpixHxZaAF+G7gi7fUS+l2KJd5aPkjFCp53tuGh+ke2EDPsnZiydOkkbvoHuqjrek8kOWJ71i+FsqbwVRykiRJUl0tugA+pfSqW2j+t8CrgctTlI8F+Mtu4T2k26f/OIUzR6pPD5c6slRxI9eD833cx5KUo6sS5BfOHIH++2HT9nnvriRJkqTrnFKbnU9Wzm0TCyLiWcCLK08H5qtDEqeOQTlbq95fHOR9J7/Muz/5Jd538sv0FwezOuVyVm/TdujYC0CxpZOj6/ZUU8WNSWS3zRdbOrMLHXsN3iVJkqQFYNHNwN+i48BZ4Eci4odTSp+oKXs72e70vSmlr9ald1p8Hn0QevdTbOlk99Wd9A1cvqFK+/pV2W3zZ45kwfjWB+Dueyi0buNQLkd/cZCTpy9y5VqJFUvzbNm4JlvzXt7szLskSZK0gBjAz0JKaTgi3gh8HDgeER8BniRLL/eDwAXgZ+rYRS0mp45B734gu819R+kCj9E9bkY9KLPj3IHqmnd698Pd94wLylsLKyffpC6XM3iXJEmSFhAD+FlKKf15RHwf8G+BrcAqoAj8PvDvUkrn6tg9LSat2yi2dFbXtHflexmJ8rgN6XqG+uhqOlFtUmzppNC6rV49liRJknQLDOCfgZTS3wA/Ue9+aJHL5dh9dSc7ShfoyvfyeHMzBwtnWZp/slrlYGmUe4vNtA0Pc7jUwdGrOznkbvKSJElSQzKAlxpUf3GQvoHLPEY3I1HmYOHsuHzuAJfyTewqrKV7YEO22/zAZfqLg+Z1lyRJkhqQU3FSgzp5+iKQ7Rrfs6z9huB9zKV8Ez3L2qtr48faSZIkSWosBvBSg7pyrVR9HEuenrZubXltO0mSJEmNwwBealArll5fAZNG7pq2bm15bTtJkiRJjcMAXmpQWzauAbJUcT1DfawujU5ab3VplJ6hPoLyuHaSJEmSGotTcVKDai2spH39KnacO0BX0wnuLTazq7B23Fr41aVRHi5eoK3pPEtSjqPr9riBnSRJktSgDOClRlUu89DyRyjkewFoGx6me2DDuDzw3UN9tDWdB7I88R3L10J5M5hKTpIkSWo4BvBSo+o/TuHMkerTw6WOLFXcyPXgfB/3sSTl6KoE+YUzR6D/fti0fd67K0mSJOnWOA0nNapN26FjLwDFlk6OrttTTRU3JpHdNl9s6cwudOw1eJckSZIalDPw0kJy6hi0boNcjv7iICdPX+TKtRIrlubZsnFNtn69XIb+41kgvvUBuPseCq3bODRtm83OvEuSJEkNzgBeWigefRB691Ns6WT31Z30DVy+oUr7+lXZuvczR7LZ9K0PjAvKWwsrJ9+kLpczeJckSZIanLfQSwvBqWPQux/I1qnvOHegmvZtTFBmx7kD19e99+7P2kmSJElaFJyBlxaC1m0UWzqrwXlXvpeRKI/bUb5nqI+uphPVJsWWTgqt2+rVY0mSJEnzzABeWghyOXZf3cmO0gW68r083tzMwcJZluafrFY5WBrl3mIzbcPDHC51cPTqTg6ZDk6SJElaNAzgpQWgvzhI38BlHqObkShzsHCWS/mmcXUu5ZvYVVhL98CGLF3cwGX6i4OTr3mXJEmSdMdx+k5aAE6evghkad96lrXfELyPuZRvomdZezVd3Fg7SZIkSXc+A3hpAbhyrVR9HEuenrZubXltO0mSJEl3NgN4aQFYsfT6apY0cte0dWvLa9tJkiRJurMZwEsLwJaNa4AsVVzPUB+rS6OT1ltdGqVnqK+aYm6snSRJkqQ7n9N30gLQWlhJ+/pV7Dh3gK6mE9xbbGZXYe24tfCrS6M8XLxAW9N5lqQcR9ftcQM7SZIkaRExgJcWgnKZh5Y/QiHfC0Db8DDdAxvG5YHvHuqjrek8kOWJ71i+FsqbwVRykiRJ0qJgAC8tBP3HKZw5Un16uNSRpYobuR6c7+M+lqQcXZUgv3DmCPTfD5u2z3t3JUmSJM0/p+6khWDTdujYC0CxpZOj6/ZUU8WNSWS3zRdbOrMLHXsN3iVJkqRFxBl4aaHY+gDcfQ+F1m0cyuXoLw5y8vRFrlwrsWJpni0b12Rr3subnXmXJEmSFiEDeOl2OXUMWrfBtMF4GfqPXw/Ga4Ly1sLKyTepy+UM3iVJkqRFyABeuh0efRB691Ns6WT31Z30DVy+oUr7+lXZxnVnjmS3w299YP77KUmSJKlhuAZemmunjkHvfiDbaG7HuQPVvO1jgjI7zh24vnFd7/6snSRJkiRNwRl4aa61bqPY0lkNzrvyvYxEeVxKuJ6hPrqaTlSbFFs6KbRuq1ePJUmSJDUAA3hpruVy7L66kx2lC3Tle3m8uZmDhbMszT9ZrXKwNMq9xWbahoc5XOrg6NWdHDKfuyRJkqRpGMBLc6y/OEjfwGUeo5uRKHOwcJZL+aZxdS7lm9hVWEv3wIYs3/vAZfqLg5NvWidJkiRJuAZemnMnT18EsrztPcvabwjex1zKN9GzrL2a732snSRJkiRNxgBemmNXrpWqj2PJ09PWrS2vbSdJkiRJExnAS3NsxdLrK1PSyF3T1q0tr20nSZIkSRMZwEtzbMvGNUCWKq5nqI/VpdFJ660ujdIz1FdNMTfWTpIkSZIm45SfNMdaCytpX7+KHecO0NV0gnuLzewqrB23Fn51aZSHixdoazrPkpTj6Lo9bmAnSZIkaVoG8NJcK5d5aPkjFPK9ALQND9M9sGFcHvjuoT7ams4DWZ74juVrobwZTCUnSZIkaQoG8NJc6z9O4cyR6tPDpY4sVdzI9eB8H/exJOXoqgT5hTNHoP9+2LR93rsrSZIkqTE43SfNtU3boWMvAMWWTo6u21NNFTcmkd02X2zpzC507DV4lyRJkjQtZ+Cl22HrA3D3PRRat3Eol6O/OMjJ0xe5cq3EiqV5tmxck615L2925l2SJEnSjBjASzNx6hi0boNpg/Ey9B+/HozXBOWthZWTb1KXyxm8S5IkSZoRA3jpZh59EHr3U2zpZPfVnfQNXL6hSvv6VdnGdWeOZLfDb31g/vspSZIk6Y7mGnhpOqeOQe9+INtobse5A9W87WOCMjvOHbi+cV3v/qydJEmSJM0hZ+Cl6bRuo9jSWQ3Ou/K9jER5XEq4nqE+uppOVJsUWzoptG6rV48lSZIk3aEM4KXp5HLsvrqTHaULdOV7eby5mYOFsyzNP1mtcrA0yr3FZtqGhzlc6uDo1Z0cMp+7JEmSpDlmAC9No784SN/AZR6jm5Eoc7Bwlkv5pnF1LuWb2FVYS/fAhizf+8Bl+ouDk29aJ0mSJEnPkNOE0jROnr4IZHnbe5a13xC8j7mUb6JnWXs13/tYO0mSJEmaKwbw0jSuXCtVH8eSp6etW1te206SJEmS5oIBvDSNFUuvrzJJI3dNW7e2vLadJEmSJM0FA3hpGls2rgGyVHE9Q32sLo1OWm91aZSeob5qirmxdpIkSZI0V5wmlKbRWlhJ+/pV7Dh3gK6mE9xbbGZXYe24tfCrS6M8XLxAW9N5lqQcR9ftcQM7SZIkSXPOAF6aTrnMQ8sfoZDvBaBteJjugQ3j8sB3D/XR1nQeyPLEdyxfC+XNYCo5SZIkSXPIAF6aTv9xCmeOVJ8eLnVkqeJGrgfn+7iPJSlHVyXIL5w5Av33w6bt895dSZIkSXcupwil6WzaDh17ASi2dHJ03Z5qqrgxiey2+WJLZ3ahY6/BuyRJkqQ55wy8dDNbH4C776HQuo1DuRz9xUFOnr7IlWslVizNs2XjmmzNe3mzM++SJEmSbhsDeGkmaoLy1sLKyTepy+UM3iVJkiTdNgbwWnxOHYPWbTDtbHoZ+o8bkEuSJElaMAzgtbg8+iD07qfY0snuqzvpG7h8Q5X29auynefPHMnWs299YP77KUmSJEkTuImdFo9Tx6B3P5DtFL/j3AGC8rgqQZkd5w5c33m+d3/WTpIkSZLqzBl4LR6t2yi2dFaD8658LyNRHpfTvWeoj66mE9UmxZZOCq3b6tVjSZIkSaoygNfikcux++pOdpQu0JXv5fHmZg4WzrI0/2S1ysHSKPcWm2kbHuZwqYOjV3dyKOeNKpIkSZLqzwBei0Z/cZC+gcs8RjcjUeZg4SyX8k3j6lzKN7GrsJbugQ3sK3WTBi7TXxycfNd5SZIkSZpHTi3OUkQ8KyLeGhGPRcTFiLgSEU9ExEMR8aJ6909TO3n6IgCJHD3L2m8I3sdcyjfRs6ydVPnvMdZOkiRJkurJAH4WIiIPfBJ4GFgJ/FfgPcDXgJ8FvhgR31O/Hmo6V66Vqo9jydPT1q0tr20nSZIkSfXiLfSz8zpgC1kQ/+qUUnUL84j4VeDfAG8Ddtane5rOiqXXh3sauWvaurXlte0kSZIkqV6cgZ+dDZXzsdrgveKjlfPaeeyPZmHLxjVAliquZ6iP1aXRSeutLo3SM9RXTTE31k6SJEmS6skAfnb+unLeFhET/+1eUzn/6Tz2R7PQWlhJ+/pVHMgf5J81neDh4oUbgvjVpVEeLl7gnzWd4ED+IC9bv8oN7CRJkiQtCN4bPDvHgKPA/cBfRcSfAsPAS4AfAN5Ntj7+piLiL6Yo2jQH/dRkymUeWv4IhXwvAG3Dw3QPbBiXB757qI+2pvNAlie+Y/laKG8GU8lJkiRJqjMD+FlIKaWI6CRb6/52oHbDuk8C/yWlNPl92aq//uMUzhypPj1c6shSxY1cD873cR9LUo6uSpBfOHME+u+HTdvnvbuSJEmSVGvRTStGxEBEpFkcH6xpuxT4Q7KN6t4K3A08B/hR4EXApyPix2fSj5TSSyY7gFNz/kUrs2k7dOwFoNjSydF1e6qp4sYkchxdt4diS2d2oWOvwbskSZKkBWExzsCfAa7Nov5Xah7vBV4P/FxK6fdqrh+vzMx/AXgX1ze000Kz9QG4+x4Krds4lMvRXxzk5OmLXLlWYsXSPFs2rsnWvJc3O/MuSZIkaUFZdAF8SulVt9B8bKO6Ryd53S9GxNeBF0XE6pTSpVt4H91ONUF5a2Hl5JvU5XIG75IkSZIWlEUXwN+iZ1XON6SKi4hnAc+uPB2etx4tdqeOQes2mHY2vQz9xw3IJUmSJDU0A/jZOQG0Af86Ik6mlL5dU9ZD9u/52ZTSYD06t+g8+iD07qfY0snuqzvpG7h8Q5X29auynefPHMnWs299YP77KUmSJElzwAB+dn4d+DHgVcCpiPgYMARsAV5aefxz9eveInLqGPTuB7Kd4neULvAY3eM2pQvK7Dh3oJo2jt79cPc9zsRLkiRJakgG8LOQUjofEf8Q2ANsB95EtpP/U8D7gQMpJXeRnw+t2yi2dFbTwnXlexmJ8ric7j1DfXQ1nag2KbZ0UmjdVq8eS5IkSdItMYCfpZTSBbI0cm+rd18WtVyO3Vd3sqN0ga58L483N3OwcJal+SerVQ6WRrm32Ezb8DCHSx0cvbqTQ7lFlzlRkiRJ0h3CAF4Nqb84SN/AZR6jm5Eoc7Bwlkv5pnF1LuWb2FVYS/fABvaVukkDl+kvDk6+67wkSZIkLXBOR6ohnTx9EYBEjp5l7TcE72Mu5ZvoWdZeXRs/1k6SJEmSGo0BvBrSlWul6uNY8vS0dWvLa9tJkiRJUiMxgFdDWrH0+uqPNHLXtHVry2vbSZIkSVIjMYBXQ9qycQ2QpYrrGepjdWl00nqrS6P0DPURlMe1kyRJkqRG43SkGlJrYSXt61ex49wBuppOcG+xmV2FtePWwq8ujfJw8QJtTedZknIcXbfHDewkSZIkNSwDeDWmcpmHlj9CId8LQNvwMN0DG8blge8e6qOt6TyQ5YnvWL4WypvBVHKSJEmSGpABvBpT/3EKZ45Unx4udWSp4kauB+f7uI8lKUdXJcgvnDkC/ffDpu3z3l1JkiRJulVORaoxbdoOHXsBKLZ0cnTdnmqquDGJ7Lb5YktndqFjr8G7JEmSpIblDLwa19YH4O57KLRu41AuR39xkJOnL3LlWokVS/Ns2bgmW/Ne3uzMuyRJkqSGZwCvxlYTlLcWVk6+SV0uZ/AuSZIkqeEZwGvhOHUMWrfBtLPpZeg/bkAuSZIkadExgNfC8OiD0LufYksnu6/upG/g8g1V2tevynaeP3MkW8++9YH576ckSZIk1Ymb2Kn+Th2D3v1AtlP8jnMHCMrjqgRldpw7cH3n+d79WTtJkiRJWiScgVf9tW6j2NJZDc678r2MRHlcTveeoT66mk5UmxRbOim0bqtXjyVJkiRp3hnAq/5yOXZf3cmO0gW68r083tzMwcJZluafrFY5WBrl3mIzbcPDHC51cPTqTg7lvIFEkiRJ0uJhAK+66y8O0jdwmcfoZiTKHCyc5VK+aVydS/kmdhXW0j2wgX2lbtLAZfqLg5PvOi9JkiRJdyCnMFV3J09fBCCRo2dZ+w3B+5hL+SZ6lrWTKsN2rJ0kSZIkLQYG8Kq7K9dK1cex5Olp69aW17aTJEmSpDudAbzqbsXS6ys50shd09atLa9tJ0mSJEl3OgN41d2WjWuALFVcz1Afq0ujk9ZbXRqlZ6ivmmJurJ0kSZIkLQZOYaruWgsraV+/ih3nDtDVdIJ7i83sKqwdtxZ+dWmUh4sXaGs6z5KU4+i6PW5gJ0mSJGlRMYBX/ZXLPLT8EQr5XgDahofpHtgwLg9891AfbU3ngSxPfMfytVDeDKaSkyRJkrRIGMCr/vqPUzhzpPr0cKkjSxU3cj0438d9LEk5uipBfuHMEei/HzZtn/fuSpIkSVI9OH2p+tu0HTr2AlBs6eTouj3VVHFjEtlt88WWzuxCx16Dd0mSJEmLijPwWhi2PgB330OhdRuHcjn6i4OcPH2RK9dKrFiaZ8vGNdma9/JmZ94lSZIkLUoG8Fo4aoLy1sLKyTepy+UM3iVJkiQtSt5CL0mSJElSA3AGXrfHqWPQug2mvR2+DP3HnVGXJEmSpBkwgNfce/RB6N1PsaWT3Vd30jdw+YYq7etXZanjzhzJNqTb+sD891OSJEmSGoi30GtunToGvfuBLNXbjnMHCMrjqgRldpw7cD11XO/+rJ0kSZIkaUrOwGtutW6j2NJZDc678r2MRJmeZe3EkqdJI3fRM9RHV9OJapNiSyeF1m316rEkSZIkNQQDeM2tXI7dV3eyo3SBrnwvjzc3c7BwlqX5J6tVDpZGubfYTNvwMIdLHRy9upNDOW8GkSRJkqTpGMBrTvUXB+kbuMxjdDMSZQ4WznIp3zSuzqV8E7sKa+ke2MC+Ujdp4DL9xcHJ08ZJkiRJkgDXwGuOnTx9EYBEjp5l7TcE72Mu5ZvoWdZOqgzBsXaSJEmSpMkZwGtOXblWqj6OJU9PW7e2vLadJEmSJOlGBvCaUyuWXl+VkUbumrZubXltO0mSJEnSjQzgdXOnjkE5SwXXXxzkfSe/zLs/+SXed/LL9BcHszrlMpw6xpaNa4AsVVzPUB+rS6OTvuTq0ig9Q33VFHNj7SRJkiRJk3PaU9N79EHo3U+xpZPdV3fSN3D5hirt61fx0PJHKJw5QmvHXtrX/yA7zh2gq+kE9xab2VVYO24t/OrSKA8XL9DWdJ4lKcfRdXvcwE6SJEmSbsIAXlM7dQx69wNQOHOEHaULPEZ3deM5yGbad5w7QCHfm13o3c/vPf/TrMp/BoC24WG6BzaMywPfPdRHW9N5IMsT37F8LZQ3g6nkJEmSJGlKBvCaWus2ii2dFM4cAbJgeyTK44LxnqE+uppOVJtcfv7LWfXVz1SfHy51ZKniRq4H5/u4jyUpR1cl6C+cOQL998Om7fP0hUmSJElS43HKU1PL5dh9dSeHSx0APN7czMH1Z1n6gsM863mfYOkLDnNw/Vkeb24GsmD9LeyDjr0AFFs6Obpuz7gZe8hSzB1dt4diS2d2oWOvwbskSZIk3YQz8JpSf3GQvoHLPEY3I1HmYOHsDXndL+Wb2FVYS/fAhmymfeAy/a/bRevd91Bo3cahXI7+4iAnT1/kyrUSK5bm2bJxTbbmvbzZmXdJkiRJmiEDeE3p5OmLQDZj3rOsnaX5JyetdynfRM+y9upt8idPX6R1y/WgvLWwcvJN6nI5g3dJkiRJmiFvodeUrlwrVR/HkqenrVtbXttOkiRJkjQ3DOA1pRVLr9+gkUbumrZubXltO0mSJEnS3DCA15S2bFwDZKnieob6WF0anbTe6tIoPUN9BOVx7SRJkiRJc8epUk2ptbCS9vWr2HHuAF1NJ7i32MyuwtpxG9mtLo3ycPECbU3nWZKy3eUnXe8uSZIkSbolBvCaWrnMQ8sfoVDJ1942PEz3wIZxeeC7h/poazoPZHniO5avzXaXz3lzhyRJkiTNJQN4Ta3/OIUzR6pPD5c6slRxI9eD833cx5KUo6sS5BfOHDE1nCRJkiTdBk6TamqbtkPHXgCKLZ0cXbeHNGHIJLLb5ostndmFjr0G75IkSZJ0GzgDr+ltfQDuvodC6zYO5XL0Fwc5efoiV66VWLE0z5aNa7I17+XNzrxLkiRJ0m1kAK+bqwnKWwsrJ9+kLpczeJckSZKk28hb6CVJkiRJagAG8JIkSZIkNQADeEmSJEmSGoABvCRJkiRJDcAAXpIkSZKkBmAAL0mSJElSAzCAlyRJkiSpARjAS5IkSZLUABZtAB8RSyLi5yLifRHxhYgYjogUEW+eQds3RsRjEXElIr4REX8WEa+Zj35LkiRJkhanRRvAA8uBdwL/HHg+8NWZNIqI3wLeD9wNHAQ+CPwD4L9HxK7b0E9JkiRJkhZ1AP8t4EeBv5dSej7wyM0aRMTLgV8CzgD3pJR+IaX0VuAlwNeB34qI9bevy5IkSZKkxWrRBvAppeGU0vGU0lOzaPaWyvnXU0pP17zWAPA7wLOAN81dLyVJkiRJyizaAP4ZemXl/LFJyo5PqCNJkiRJ0pzJ17sDjSIilgMvAK5MMWv/pcq5dYav9xdTFG16Bt2TJEmSJN3hnIGfuedUzt+Yonzs+qrb3xVJkiRJ0mLT0DPwETEAvGgWTf4gpfRTt6k7Y9KMKqX0ksmuR8SlJ5544jte8pJJiyVJkiRJDeyJJ54AWP9M2jZ0AE+2G/y1WdT/yi2819gM+3OmKL/ZDP1MfXNoaIjPf/7zA7f4OrfT2G3+p+raC90JHEuaK44lzRXHkuaS40lzxbF0Z1kPfPOZNGzoAD6l9Kp5fK+rEXEeeEFE3D3JOvgXV879t/g+33kr7efD2Pr9qe4ikGbKsaS54ljSXHEsaS45njRXHEsa4xr42flU5fyPJynbNqGOJEmSJElzxgB+dt5TOf9KRNw1djEi1gNvBb4NvK8O/ZIkSZIk3eEa+hb6WxURe7m+nuS+yvlNEfEDlcd/nlJ671j9lNJnIuK3gV8E/jIijgDNwE8AzwV+NqU0MB99lyRJkiQtLos6gCe7Fb5jwrWXV44x760tTCn9UkT8JbAL+BmgDHwe+M2U0h/dxr5KkiRJkhaxRR3Ap5Re8QzbfQD4wNz2RpIkSZKkqUVKM0pbLkmSJEmS6shN7CRJkiRJagAG8JIkSZIkNQADeEmSJEmSGoABvCRJkiRJDcAAXpIkSZKkBmAAL0mSJElSAzCAlyRJkiSpARjAa8YiYl1EPBIRX4mIb0fEQES8MyLuqnffNP8iYnVEvDkiPhIRpyNiKCK+ERF/HhH/IiIm/fkSES+PiD+OiK9HxLci4i8j4ucjomma93pjRDwWEVcq7/FnEfGa2/fVaSGIiJ+OiFQ53jxFHceTphQR/ygiPhwRT1V+bz0VER+PiB+dpK5jSZOKiO2VcXOu8rvubER8KCI2T1HfsbSIRURnRLw7Ik5ExDcrv8M+eJM2t33MRMSyiPjViPjbiLgWEV+LiMMR8d238vVq/kVKqd59UAOIiBbgM8DzgI8Cp4CXAluBvwW2pJQu1a+Hmm8R8Rbgd4GngEeBvwMKwP3Ac4APA69PNT9kIuLHK9evAX8IfB34MeC7gCMppddP8j6/BfwScA44AjQDPwk8F/jZlNLDt+lLVB1FxAuBvwKagBVAd0rpvRPqOJ40pYjYB/w74CLwR2Q/q9YA3ws8mlL65Zq6jiVNKiIOAL8MXAL+G9l42gj8EyAPvCGl9MGa+o6lRS4ivgDcC1wh+55uAv4gpfRTU9S/7WMmIp4FfBLYAnwO+BTwQuD1wDDwypRS36183ZpHKSUPj5sewJ8AieyHQu31365cf0+9++gx72PilWS/YHITrj+fLJhPwI6a688GvgZ8G/i+mutLyf44lICfnPBaL69cPw3cVXN9PdmHqWvA+nr/W3jM+dgK4E+BM8BvVsbAmyfUcTx5TDeGXl/5Xn8CWDlJ+RLHkscMxtHzgVHgq8DzJpRtrYyBs44lj0nGxosrv8teUfn+fnCKuvMyZoAHKm0+RM3nNuDHK9f/mgmf5zwW7uEt9LqpiNgAvBoYAH5nQvG/Ba4CPx0Ry+e5a6qjlNKnUkr/PaVUnnD9q8B7Kk9fUVPUCawFDqWUPldT/xqwr/L0X054m7dUzr+eUnq6ps0A2Vh8FvCmW/tKtADtJvsD0ZvIfr5MxvGkSVWW7xwAvgX805TS4MQ6KaWRmqeOJU3lRWTLTftSSl+rLUgpPQoMko2dMY4lkVJ6NKX0pZTSTG5zvu1jJiKips0v135uSyl9FDgBfA/QMYP+agEwgNdMvLJy/vgkwdogcBL4DuBl890xLVhjH45LNdfGxtHHJqn/abIP2y+v3OY1kzbHJ9TRHaCyFm8/8K6U0qenqep40lReDnwn8MfA05X1y3si4uemWLPsWNJUvkR2e/FLI2JNbUFE/CCwkuxuoTGOJc3WfIyZFuDvA/0ppS/PsI0WMAN4zcR3Vc79U5R/qXJunYe+aIGLiDzwhsrT2l8uU46jlFIJ+DLZesINlddZDrwAuJJSemqSt3Lc3WEqY+c/ky3B+Nc3qe540lS+v3IuAp8nW/++H3gn8JmI6I2I2llTx5ImlVL6OrCHbH+Xv4mI34+IByPiMPBxsiUa/3dNE8eSZms+xoyf4+8w+Xp3QA3hOZXzN6YoH7u+6vZ3RQ1gP9AG/HFK6U9qrs92HDnuFp9/Q7bB2A+klIZuUtfxpKk8r3J+C9mH3x8C+shuh34H8CNk60BfUannWNKUUkrvjIgB4BGgu6boNPD+CbfWO5Y0W/MxZhxndxhn4DUXonI2pcEiFxG7yXZFPQX89GybV86zHUeOuztARLyUbNb9HSml/zEXL1k5O54Wn7G0SwF0ppQ+mVK6klL6a+B1ZLs2d0yVAmwSjqVFLCJ+mWyX7/eT3Yq8HHgJcBb4g4j497N5ucrZsaSZmo8x4+f4BmMAr5kY+8vcc6Yof/aEelqEIuKtwLuAvwG2Vm49rDXbcXSz+jf7i7IaRM2t8/3A22fYzPGkqYxt6nQ2pfTF2oLKnR1jdwa9tHJ2LGlSEfEKsg0R//+U0i+mlM6mlL6VUvo82R+DzgO/VNnsFxxLmr35GDN+jr/DGMBrJv62cp5qbcyLK+ep1tboDhcRPw88DDxOFrx/dZJqU46jSgD3nWSb3p0FSCldJftwtCIi7p7k9Rx3d44VZOPiu4FrEZHGDrJMFwAHK9feWXnueNJUxsbG5SnKxwL8ZRPqO5Y00Wsq50cnFqSUvgU8RvZZ+nsrlx1Lmq35GDN+jr/DGMBrJsZ+cb26kp6nKiJWAluAIeB/znfHVH8RsQf4D8AXyIL3r01R9VOV8z+epOwHyTIZfCal9O0Zttk2oY4a17eB/zjF8b8qdf688nzs9nrHk6byabIPvC+OiOZJytsq54HK2bGkqYzt/L12ivKx68OVs2NJszUfY+YM2eawrRHxnTNso4Ws3onoPRrjILvlMAE/O+H6b1euv6feffSoy7h4e+X7/znguTep+2zgAlmw9n0115cCn6m8zk9OaPPyyvXTwF0119cDl4BrwPp6/zt43NYx1lMZA2+ecN3x5DHduPlg5Xv9/064/sNAmWx2fpVjyeMm46ir8n3+KvCCCWXbKmNpCFjtWPKYYgy9ovL9/eAU5fMyZoAHKm0+BORqrv945fpf1173WNhHVL550rQiooXsB8nzgI8CTwDtwFayW25enlK6VL8ear5FxBvJNvUZBd7N5GunBlJK769p81qyzYCuAYeArwP/hCzFyRGgK034oRQR7wB+kWzjqSNAM/ATwGqyPyg9PIdflhaYiOghu42+O6X03gllr8XxpElExPOAk8BG4ATZrc4vIlu3nIB/mlL6UE391+JY0gSVuw7/hCyTwSDwEbJg/rvJbq8P4OdTSu+qafNaHEuLWmUMvLby9PlkmS/Okv0sAriYUnrbhPq3dcxU8sh/iiz4/xzwSbLc8K8nu4PklSmlvlv92jVP6v0XBI/GOYAXAu8DniL7z/4k2aZl0868etyZB9dnRqc7/mySdluAPyZbhzoE/BXwC0DTNO/1RuCzwFWyD1G9wGvq/W/gMa/j7M1TlDuePKb6Pj+X7C6xL1d+Z10i+wP0yxxLHrMYR0uAnydbJvhNsuUZXwP+CHi1Y8ljku/lzT4fDdRjzJDt+/GrZHnfv0028/8h4Hvq/W/mMbvDGXhJkiRJkhqAm9hJkiRJktQADOAlSZIkSWoABvCSJEmSJDUAA3hJkiRJkhqAAbwkSZIkSQ3AAF6SJEmSpAZgAC9JkiRJUgMwgJckSZIkqQEYwEuSJEmS1AAM4CVJkiRJagAG8JIkSZIkNQADeEmSJEmSGoABvCRJkiRJDcAAXpIkzbmI+E8R8bWIWF7vvoyJiJdERIqIf1HvvkiS9ExESqnefZAkSXeQiPg+4DHgbSml3653f2pFxEeAlwEvTildqXd/JEmaDWfgJUnSXPsN4JvA79a7I5N4EHg+sLveHZEkabacgZckSXMmIlqBU8B7U0o/U+/+TCYingC+A9iQUhqtd38kSZopZ+AlSVJVRJysrBOf6ui9yUvsBAL4w0le+xWV1+iZ4r0HImJgwrX1lTbvj4iWiDgSEZciYjAiPh4RbZV6ayPi9yPiqYi4FhGfjYitU/TxEPD3gR+6ydciSdKCkq93ByRJ0oLyEeATk1x/E1nQ++hN2v8QMAr8zznu13qgD3gCeH/l+euAP4uIzcDHyG7b/0PgucBPAscjojWl9HcTXutk5fzDwJ/McT8lSbptDOAlSVJVSum3Jl6LiN8kC97fD/zaVG0rO87fBzyRUro6x13rAPallH695v3eXulPH3AY+FcppXKl7BPAfwJ+oXLU+mzl/INz3EdJkm4rb6GXJEmTisz/B7wN+B1g51iAPIUXAE3AU7ehOwPA/gnXPlA5Pwv4fyb07b8AJbI/KIyTUvoGcI3sjxKSJDUMA3hJknSDiGgim3H/l8C/TyntSjff+XZ15fz0bejSFybZcO4rlXN/SmmwtqBStwism+L1vg6smdsuSpJ0exnAS5KkcSJiCdlGb28AelJKe2bYdKhyXnobuvWNiRdSSqWpyipKwJIpypZxvb+SJDUEA3hJklQVEUvJNrLrBN6WUvrVWTT/WuW8etpa2S71k1k2i/d6xiIiB6zien8lSWoIBvCSJAmobkJ3DPhRsg3h3jHLl3gKuAB8103qvWCS93428LxZvt8z9V1kf0T4wjy9nyRJc8IAXpIkERHPAT5Ottv7P08p/e5sX6OyRv7TwJqI2DhN1fsjojDh2r7KeT4y5Lyscr5ZSjxJkhYU08hJkiTIdm1/OfAYsCEieiap82BK6ds3eZ0PAzuAHwFOT1GnBDweER8BBskC6u8H/jfwwsrO9/85pfQ/Zv1VzMyryXLVf/Q2vb4kSbeFAbwkSYtcZU34WE70l1aOib6WUuqZwct9mGz39zeQpZ6bzO+R3QX4JuC5wN8AP0aWDu4DwGuA/zjD7s9K5U6D1wJ/lFL637fjPSRJul0M4CVJWuQq+dNXztFrDUfEu4DfiIjvTSn9r0mqjaaU3g78yiRld014vQGm3vSOlNJ0ZesnufwGsl3yZ7u+X5KkunMNvCRJmmv/Afg74Nfq3ZFaEbEMeAD4cErpRL37I0nSbBnAS5KkOZVSugb8NPC5ys72C8V64PeBt9W5H5IkPSPeQi9JkuZcSunTZDvSLxgppSeAnnr3Q5KkZyqyjC+SJEmSJGkh8xZ6SZIkSZIagAG8JEmSJEkNwABekiRJkqQGYAAvSZIkSVIDMICXJEmSJKkBGMBLkiRJktQADOAlSZIkSWoABvCSJEmSJDUAA3hJkiRJkhqAAbwkSZIkSQ3AAF6SJEmSpAZgAC9JkiRJUgMwgJckSZIkqQEYwEuSJEmS1AAM4CVJkiRJagD/B+GZN5hA/b91AAAAAElFTkSuQmCC\n", "text/plain": [ "
" ] @@ -644,7 +738,7 @@ "metadata": { "image/png": { "height": 318, - "width": 513 + "width": 504 }, "needs_background": "light" }, @@ -668,9 +762,137 @@ "plt.legend()" ] }, + { + "cell_type": "code", + "execution_count": 19, + "id": "express-boutique", + "metadata": {}, + "outputs": [ + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAACDAAAAIqCAYAAADYEygWAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAADQD0lEQVR4nOzdeZx8V1ng/89T/e0krAEExB8om0AcdURAQDIDARQRBEFhxAUURUdlZB2VEZVFcRkRBFyYQdlEJIIjuABGgQgSEUEFFcISiCCLCkEICd+lq57fH1VNOp06T3ffvrX25/161au+3zp1nnPurVv3Pvf2qXMjM5EkSZIkSZIkSZIkSVqkwaI7IEmSJEmSJEmSJEmS5AAGSZIkSZIkSZIkSZK0cA5gkCRJkiRJkiRJkiRJC+cABkmSJEmSJEmSJEmStHAOYJAkSZIkSZIkSZIkSQvnAAZJkiRJkiRJkiRJkrRwDmCQJEmSJEmSJEmSJEkL5wAGSZIkSZIkSZIkSZK0cA5gkCRJkiRJkiRJkiRJC+cABkmSJEmSJEmSJEmStHAOYJAkSZIkSZIkSZIkSQvnAAZJkiRJkiRJkiRJkrRwDmCQJEmSJEmSJEmSJEkL5wAGSZIkSZIkSZIkaY4i4vsjIiPiKT3GfOIk5iP7iilJ8+YABkk6gIj4y4jYiogvXXRf+hIRg4i4MCI+GxFfuOj+SJIkaXlFxNMmF0Qfvui+9CkinjdZrvsuui+SJEk6vIh44SS/2/0YRsQlk+u8j4uIqy2of1cDngRcCjxr8tr3NPq8n8f3TEI/B/gP4Kci4hqLWDZJOiwHMEhaKkViOe3xmDn37f7A2cDLMvP9k9cePunLVkR80T7jfPmOZbh34z2PnpQ/q78lmC4zR8DPA9cAfmrW7UmSJGlvy5gXR8SNgMcAFwO/PXntFhExmvTjv+0zzkZEfGxS5xca7/mqSfk7eur+Xn4eGAI/FxFeK5EkSVofp4B/3fG4FLgu4+u8vwy8LSJusIB+PQq4MfDrmXnJ5LXP7err9uMTO+p9qvGezwFk5meAXwW+kHHuLkkrx5NySctqd2I57XHZvDozuYj5c0ACT9tR9PJJPzaA79xnuIdNnj8G/FnjPd80ef7jg/W0s98BPgj8QETcfE5tSpIkaW/LlBc/Cbg68IuZuQWQmR8A3jQpf1ir4i73Am40+feLGu+Zaz48WY7fBf4z8O3zaFOSJElzcUFm3mjH4zrAdYD/CYyA/wRMHVQ7KxGxwXgAA8Dztl/PzHN39fVGmXkj4Gt2VP+Wae/JzHN3vOc3J88/EhHHZrs0ktQ/BzBIWla7E8tpj+ftHaY33wB8OfCXmfnu7Rcz87PA/5v896F7BZkMhNge6PCSzBxOec+1gLsyHg38F4fs975MLkC/CNgE/sc82pQkSdK+LEVeHBHXBb6H8S+7XrKreHsQwjdExA33EW57oMPf7Mytd5n3gF644kLv4+bYpiRJkuYsMz+dmb8M/NbkpfvNuQv3Af4/xvnwRX0Hz8x/Bv6K8SwM37TH2yVp6TiAQZL25xGT55dNKdu+YPufI+Kr9ohzT8ZTg+2st9u9gNOAP8vMkwfq5eH87uT5oRGxOcd2JUmStPy+CzgD+OPJIN6dXg5cDhxjj9kLIuLawDdP/js1H55M4XtH4N+Bvz5Enw/qTcBHgNtFxG3n2K4kSZIW452T52vsfDEinj+5ndkrqsoR8ZTJ+y44YLsPnzz/3gHrHcR27IeX75KkJeQABklrISL++yRZPB4RX9F4z/+dvOdDEXGdA8T+AsajcJPxxdnd3gB8ePLvvabN3S5/e2b+U+M9V/m1WUTcbPsex5P/3zEiXhUR/x4Rl0bEBRFxnx3vPy0ifjwi/jEiLo+If42I/xMR12t1LDPfC7wDuAGOzJUkSVpJEfHC7bxxj8cLDxi6eZE1My8F/mDy373y4QcDVwNOMn1wMIx/kTYAXpOZo+0XI+LiSd/PiYgviojnRsSHI+JzEfHuiHjsZMaz7fc/OCLeFBH/ERGfiYg/aZ0rTJZjBGxfpPZCryRJ0vr7ysnz+3e9vj0z1/0m14avIiIC+O7Jf5+/3wYn+eo9Jv99837rdbAd+x7eRkLSqnEAg6S1kJn/h/Ef/E8HficiTttZHhHfBHw/40EI35OZ/3GA8HdnfGuF92Xmv09pewT89uS/3zG5h9lVRMQ1gQdO/tv6tVkA3zjp56sb77k/8JeMB1VsAtcEvhb4o8lF2jOAP2V877ZbTqrdEPgB4M93r5tdthPbexXvkSRJ0vL6NPCvxeMqtzDbS0RcH/jqyX9bF1m389vbRcSXF+G2Bzj8cWZ+svGevW4fcXPgb4H/DlybcU58FvAM4FmTPv8C48EWX8v42se1GA+MeFNE3Kron/mwJEnSmouIa0fEY7hi1t1n7izPzAuAdzGeJfc7me6ewE2By4BzD9D8VwJnMs7L33GAegf1DsaDhq8J3HaG7UhS7xzAIGmdfB/wb8B/Bn52+8XJFLTbo2afmZmvP2DcsyfPby/es33B9kbA1zfe862MpyM7xRW3a9jtjozvTfY3mfmvjfe8ePL4osy8DuPBCa9ivE9/JvB0xhdwv4lxgnotxtP0Xsr4wvMjrhry8942ef6vxXskSZK0pDLz0Zl5o2kP4HuBmLz1tQcIu50PfywzP9Z4z+uAf5n8+6HT3hARN+OKPLM1oHeT8eCBU4wH5U7zTOCDwFdl5pmMBzH81KTskRHxE8DjgMcAZ2bmtRlfKH4PcB3gaY24cEU+fNbkPEKSJEmr7S4R8fEdj/9gPOj3mYz/yP+wzHzhlHrb15NbM3N97+T5FZMZyfbrjpPn92fm5QeodyCTWxO/Z/LfO82qHUmaBQcwSFpWuxPLaY9r76yQmf/GFX+cf3xE3G3y7//LeFDAPwI/0aEv20nlO1tvmNx+4S2T/7amzd1+/U8y8xON9+z1azOAv83MR2wPcJjMCvGdwGeAGwOPBB6SmX+SmcPJ4w+BX5rUf1ARe3vU73+KiGsV75MkSdJ8HDgvniYibgO8lPF1gP+dma3bN0yzn3x4BLxk8t/v3Hkrhx0eyngAxb8Dr2mEuivjAQlvyszPNN4zAu6Tme+ctH15Zv4s8PpJ/KcBP5uZz8rMyybv+UfGM7IB3L81K1lmfpBxXg1XLLckSZJW1ybja8PbjzN3lF0PuOFkVtzdXsx4BoPbRsRX7yyIiDO5Yqbdfd8+YuKLJs+t68N92m7ji8p3SdKScQCDpGW1O7Gc9rjKPiwz/4jxgIUB8OKIeCzwAMbJ5ndl5okOfdlvUrn9K7IH7P7jf0TcBDhn1/um2c8Ahl/Y/cLkwuz2AIoLMvMvptR73eS5ed9frljGYLyOJUmStFid8uKdJhdY/5DxxdrXAP/rgH04aD58E664r+9O2zMzvDQzTzVi7Ccffm7jlnB/Pnk+yfh2Eru9GTjO+LZzX1rE3761hRd6JUmSVt9fZGZsP4BjwC2AH2Y8e+3TuWK2hc+b3O7slZP/7p6F4TuAMxjfcviNB+zP9SfPnzpgvS6227h++S5JWjIOYJC0rK6UWDYe/9Go+zjgfcCXcMWFy5/KzK73FNtvUvky4ARwNa46y8FDGe9zPwn8ybTKEXFjxvcj+0hm/l3Rzj80Xv+3yfM/Nsq3b0lx3SL2zmU0sdXCRcSDIuI5EfGmiPhMRGREvGTvmgdu5ysj4sUR8eGIOBER/xYRfxERrRlVJEmal8PkxUxmQvhd4NaMp5D99slsCQexr3w4My8E3jr575VuIxERXwvcavLfFxdh7jt5rgYw7JUPX5yZn53SvxFXDMLYT05sPqylYE4sSVJ/JrPVfjAzf4PxrLYA3xsR/2XK27cHNnzHrhm8tm8f8YIOXTh98nyyQ92DOj55vtoc2pKk3jiAQdLamcxG8D92vPQWxiNpu9pXUjm5cPyqyX93X+DZvoD7u4f8tRnFfYeHk+e9yo8V4Y/v+LeJrZbBTzL+Pt8W+MgsGoiI7wH+jvFsLW8Cfhl4BeOZSO4zizYlSZqjXwC+EfgP4P6Z+ekOMQ5ykfWFk+dviYhr7Hh9Oz/+x8z822kVJ7e5uBXwnsx8X9FG13x453s2i/d4oVfLxpxYkqQZyMw/BT4++e9/m/KWPwc+CHwBcH+AiPhy4A6M88pqpt2WSybP1+lQ96C2B+1+snyXJC2Z6o9YkrTKdk7rdSvGU+tWFzIrlwA3Yn9J5YsYJ7t3i4gvycwPRcTXAF+2o7zlfpPncgDDjO38JZqJrZbBY4F/Ad4P3A14Q5/BI+LOjEfT/yNw78z8+K7y6o8bkiQttYj4DuBHGV9cfUhmvrdjqINcZH0Z8EzG0/F+C/Dbk1+rbV8QXvZ8GLzQq+VjTixJ0ux8iPG131vsLsjMjIjnAz/D+HrzK4DvmxT/aWZ+tEN7+5kRrC/bbex1KzhJWirOwCBp7UTEdwIPAbYYT5P7BcDzDxHyIEnl9qjdAL5r8tr2r83elZlvm1YpIq7G+D7BnwNe172rh7ZzGU1stXCZ+YbMfF9m5n7rRMS3R8QbIuJTEXE8It4dET8ZEadPefv/BjaA79p9oXbSfmvGFEmSllpE3J4rprz98cmvy7radz6cmZ8C/mjy3+1ZyO4HXI/xQIrfKarva0ayOfBCr5aKObEkSTN148lz63j3AsZ57DdExE254ppv1+vN75k836xj/YPYbuPCObQlSb1xAIOktRIRXwz86uS/T2U8/eXngHtHxA93DLudVN58rzdm5s6Lsg+d/FLlIZP/V782uyfjKWpfn5mf69jPPtxs8vxprpg+TVoZEfFbwEuBLwX+H/BrjH81+jPAayPi2I733gT4r8DbgH+KiLtHxP+MiMdHxD0n9wyXJGnlRMQXAq9knF/+dmb+8iFD7jsfntjOe+8ZETfmigG957VuhxYR1wHOZnyri7/s1s3Di4irAzeY/NcLvVpJ5sSSJO1PRJzNFQMYpt7mLDM/AryG8WC/32GcK/478Icdm70ASOC6EXHLjjH2NDnG32jy34Xl15LUhSchktZGRATje+5eB3gL8HOZeSHw45O3/FJE3LpD6DdPnu+wz/dvX7A9C3gycH1gBLykqLMsvzb7msnzmzNztNCeSAc0uW/v9wJ/ANw6M78vMx+fmWcDTwHOAR65o8r29v4+4PWTxy8BT2d8j8O/j4gvnU/vJUnqx+R2Db8P3AR4K/ADPYTdzoe/IiLO2Mf7Xwv8K+NrDo8GvnHyejWg996Mb3P5p5m51bWjPbgd44vTlwLvWGA/pE7MiSVJ2ltEXC0iHgD87uSly6lnVNie2ezsyfNLus5QlJmXAO+e/Pdrqvce0nbs92Tmv82wHUnqnQMYJK2TxzK+DcNlwEMnsyHAeEaGPwOuzvgevMca9Vu2R6h+dURs7PXmzPwH4O8m/33C5PnP9rgn2n0nz8sygOFNC+2F1M2jGd865nunzGTyM4zvY/2dO1674eT5vwFfxvg+3Wcy/qXabwNfCfzJ5A9BkiStimczvrD6UeCBmXm8h5jvBD7DeIDBbfd682QAwksn/308sMl4hq9XFdWWbUDvBTvOJ6RVYk4sSdKV3SUiPr7j8e+Mrx//AfDFk39/22SmhZY/AXbOJHaY2xUDnDt5vm/5rsPZjn1u+S5JWkIH/SOeJM3LXSJir1sYnJuZjwaIiK8Afm7y+uMz8/3bb8rMjIiHA/8A3BH4ScYzI+zX24APALdg/GuV1+2jzouAr+aKgWLNX5tFxG0Z/0LuHZn5LwfoV68mv6a7O+MpzF6+qH5IXUyme/4qxveqfsx4QparOMH4ouy2jR3Pj8jM7T+YfCYivnvy3jsA38oVI/IlSZq3A+XFjGcygPGsZH/bOCburlPKzGFE/D7wcMYXQt+yj2ovYjzAeDsfPrc1mGIySPjejO8t/Jr99GmGvNCrlWVOLEnSVJvAF+567bOMr/f+GfCczPznKkBmbkXEHzGe3exvMvMfD9mnFwBPAr45Is7oadDx501ua/xAxtd5X9BnbEmaBwcwSFpW0xLL3c6Ez0+T+xLgdOBPMvP/7H5jZn4kIh7J+JdgT4yIV2fmW/fTkckAiOcDPws8hP0NYHgp42k3Nxn/Wu2VxXuX5ddm3wRcC3hDZl604L5IB3VdIBjfh/BJ+6zzqcnzCeDVOwsm3/tXMb5Ye0e8WCtJWpx958W7XH3yOEidym8xHsDwbcBP7fXmzHxHRLyD8R9TAV5cvP1rgS9gfBuzTx6wX72JiBsyHrD8WeD3FtUP6RDMiSVJmsjM7wG+p8eQd588H3b2BTLzwxHxGsaDZ78JeMUe77+Y8TF+v+4NXA84b1JXklaKAxgkLZUuiWVmnmR/U9n+Lt0vuGyPiv2WiPgfmXlij7b+HdjvFJt7DmDYT5K617rbR4xvnzw/r2pHWlKfnjz/XWbebp913jN5vjQzR1PKty/mXu1QPZMkqYOuF1wz82Z992US980R8U/Al0fEHTLzbfuoc9t9ht/XgN69li0zXwi88BAxvo3xr9BfmpmXVXGkJWVOLEnSDETEPYFbMb7dxEv3ePt+PRm4D+NbrpUDGDr4n5Pn/Q5olKSlMtj7LZKkzPwo8H8Yj1x9eF9xI+IGjO+z++/AvmaEmIWI+FLgm4F34XS5WkGZ+Vlg+48q19tntXcynl73+hEx7ZetXzF5vvjwPZQkaS1sXwD9n+W7Dm7hM5JNbmPxaMa/Qv+5Pd4uLSVzYkmS+hcR12c80y7A8zPzM33EnQwIfjlw54j4uj5iAkTEfwHuCrwqM/dz6zdJWjoOYJCk/fsZxtPJ/nhE9DWDzXUncR/d+LXLvPwvxr82e+KC+yEdxjMYz3zy/Ii4zu7CiLhuRHz+l2iZucV4YBLA/46IwY73fiXjX71u0f8oeEmSVlJm/j7w18CDI+LWfcSc3A7u5cBP9HAv4cP4DuCWwHP3ugeytOTMiSVJ6kFEPD0iPgR8FPhqxgP+frbnZp4APAW4Zo8xrzOJ+aM9xpSkuYrMXHQfJGllRMQDGd/H94Xrcv+wyQWqJwAnM/Ppi+6PtFNEPAB4wOS/NwK+AfgA8KbJa5/IzP+54/2/BvwwcAnwp8CHGM+ccnPGo89fkJk/uOP9VwdeB9wZ+DvgfMb3DP5WxtPkPj4znzGThZMkaQVFxFcznrnr/Mw8f8Hd6U1EfBfwpcCvTW4HJy0Nc2JJkuYvIl4IfDfwGeAtwP/MzH9YaKck6YhwAIMkSVpaEfFk6vv1/fPue1lHxDcBPwjckfGo80sYX7Q9D3hJZl646/1XB34MeAjji7rHgb8BfjkzX9PHckiSJEldmRNLkiRJOkocwCBJkiRJkiRJkiRJkhZusPdbJEmS1JeIuG9EnBcR/xIRn4uID0TEyyPiaxfdN0mSJEmSJEmSFskZGCRJkuYkIn6R8dS8nwReCXyC8f227w8cAx6WmS9ZWAclSZIkSZIkSVogBzBIkiTNQUTcCPgI8O/Af87Mf9tRdnfg9cAHM/MWC+qiJEmSJEmSJEkL5S0kJEmS5uOmjHOvv945eAEgM98AXArcYBEdkyRJkiRJkiRpGRxbdAc0XxHxQeDawMUL7ookSV3dDPhMZt58d0FE/A5w1ozavTAzv/MQ9d8HnATuGBHXz8xPbBdExF2BazG+rYSkGTMnliStgZuxmjmxpCVhTixJWgM3w5x4LTmA4ei5dmxuXm/zC294vWmFudGuONgYNcs2Bu1bkWxEVW96WVmHjm0VZdEx5qCoN+har1EWzRp7lXW7TUxUQVdA17vjVNWyXNP9x+xab5TTy2bRVpd+HCZm9bmOOsecXlbHa2vF27MfnWP2X6+1V6nWf9d+VFoxT3z4E+TJrVa1s4Db3e4rT+/UZsvf/sMJgLMi4u3TyjPz9nvFyMxLIuLHgWcA74qIVwKfBG4J3B/4M+C/99VnSaVrx7HN651x3S+cmhNXyl1ax/ypGXOebQFExwSqiFlG7LR87Yid89eiXplLl/WKso7ruarX3ITKdXLweHv1o1Kty66fXRnzgK+PC7utkzJk1/OxsnAGMXu24qeTS6X1aX/yg5eydXzYqjbLnFjS+rj21c6I633ZrU47cE68CrLjMXjeuvWyXavrUtf1urXXuS/l9aeDX+ua97XZztfxul6D7XAttfO12Xlft22H7H4NtsPn03W5Z7FslXnGnEUf64rT2zvxL/++qOvEmjEHMBw9F29+4Q2v9/89/rFTC0fXaX7ROeNa7S/lta5+vFl25hntsuuefvn0OpvtOtc+9rmirOjHseltAVx9cLIdc9Bu7+qD9jq5RlF2RpwqyqZ/BpvFgIhN2mWnlQMp2jY6XnGaxX1p2kvQNiwTpqJekVScyvbSzaZee0TRqWzvvo/n5tTXT3aMV/Wj1da4vXbME6N2veNVX0ZFzGqdFO1tjaZ/PlUfTxT92Co+7xPDbvVOdqx3atj+7Kp6w8Y6OdV4vaqzd1n7O9Cq9/7HPY/jF3384la9233l6fzNeV/SjNvF19zrQ70kp5n5KxFxMfB84Pt3FL0feOHuW0tImpmLz7juF17v1g+enhPnoLg4VJxBFYeiul5jd123VVxELAYlj4qyrjHrekVSViWOxxoZWxEvirJBVdYYVD2uVwyQLsoGxQDvY0V7x8pB4wcv2+xQB+BYh0HosMeyRfMPrWW9QfHH+qqfm4Pp7dWD0NtlrXh7x+y2bBvFWUtVr9KlXtWPvtvSdK2B4S/89tfzr+/+j4tb9ZY5J5a0NC7+sluddr2/Oe+LF92PmRhmt2NYV6OOf5YbdTjWDou/mFbxhkUfR0XMsl6zBE6W/Ww7VazKk8X1rNYfyatrsyeLk5Ku12bLa7D0H7O67tmK2fV6b7lOOl63PVWcpFbt1ddni3rFddbWtrJV9PFkUVbVq67Ntq5XAwy71itjHvz6bN/Xe6Ee3DBq1Pvg4/8vxz/wsYtb9cyJV5cDGCRJ0lpJstMFgL1iMp4abM+ZFioR8WPAzwHPBn4V+Djj0cA/D/xORNw2M3/skN2VJEnSETfDnFiSJElaCebEq2sWP5aWJEnSLhFxDvCLwB9m5uMy8wOZeXlm/i3wQOAjwOMj4hYL7KYkSZIkSZIkSQvjDAySJGntzHuqyH36psnzG3YXZOblEfFWxgMZvhr4wDw7JkmSpPWzpDmxJEmSNDfmxKvJAQySJGmtJN3vPVnF7MHpk+cbNMq3Xz/ZT3OSJEk6qpY4J5YkSZLmwpx4dXkLCUmSpPl40+T5ByLixjsLIuIbgbOB48AF8+6YJEmSJEmSJEnLwBkYdGXF0KHRKJplw6Jsa9QeJ9Mq28p2nVO50XvZKItlK8b5jIqyYbEMtJtr2ig+nNOiPQXOZtHWZtHeZrQrbhQLMOhYr2/DYn2Nsl1W1TuVw6Je26nie3WqWCenyu/BqWbZ8UbZSdrfgeOj9tZwqqi3OWov+fFsx9ygvc0OiimdTkW7vY1REbP4XE/0fSgcFfE2ttplw3a90aC93NW+eWPQXidVvVFMX18bjderOgBRljWLGDTq7b0nSUbFNtZNL2NrXwH8OfB1wLsj4g+AjwNfxvj2EgE8ITM/2UdjkmoxhM3LppeNjhW5wmntmNW+tdqNFKlJu61yb9htv8uwKCz25XW9dlFWMVvrsur/oB2vWsdZnAt0LZv3bzK6ZNmt4yzUx+6qXpVzlfWKsmPFuc6gKmv0pWprs8i56mWr+tiuV+bEHddX15jNeMWydVWty1VQ739nYfp54QrnxJKWSJJLM7V237+QrdtajmWehUFxvbr6NeuoQ161l82iXnkNtig7vehnq6S6pnuyuv5aXIc8le1rfNXfIarrpSeLK8yb0Y5Z/d2gtexVPwbFydOJ4hryRnE+Vn3lBh3r1Rt0UdZele3rs0VbXXPD6vpBlbdn8fmU9arrusW5bevcsO/rvQDDDv3YmznxqnIAgyRJ0hxk5igi7gM8EngI8EDg6sAlwKuBZ2fmeQvsoiRJkiRJkiRJC+UABkmStFYSGHb5OfMeMXuJk3kK+JXJQ5IkSZqJZc6JJUmSpHkwJ15dDmCQJElrZ55TT0qSJEnLyJxYkiRJR5058Wqq7hIjSZIkSZIkSZIkSZJ6FBE3iYjnR8RHI+JERFwcEb8SEdedVZyI+OKI+PWI+OuI+Pjk/R+NiDdFxMMjYrO/JezOGRgkSdJaSWDY88hax+lKkiRplZgTS5Ik6ahb5pw4Im4JXADcEHgVcCFwR+DRwL0j4uzM/OQM4twS+E7gr4FXApcAXwB8I/B84GER8fWZudXHcnblAAZJkiRJkiRJkiRJkubj1xkPOnhUZj5n+8WIeAbwWOBpwA/OIM4FwHUzc7QzyGTmhfOAc4BvAX7v4IvUHwcw6MqG0S4atu84cnKrvSkd3xo2yy4bnD719WOD0dTXAQbF+KZBtMs2oh2zMizutDLMYn0N2vVOsdEsu0acnF4nTrXjRXsg1OnRXv9nlOukGEfWXmwGVWFhM9rrZFB8Bp3a69bF8l5Jp7K9nk9RlGX7MzhexSzKTm+UnSrW4/Fi+zqe7RmDNotl2ywG6G0W2+zmqF12PE9rlm2swu+BRu195XDQXpejYqMdFdtCdaOoUbH/GsX0siz3se2yql422tqr3l68t5mkvUQmx45P31cUu2so9p+R1b6n2O+2apQ5V1trPz6O2S3Hq84Tyv11Ua9avuZqHhTHlFHRVlWv3Q2qjzSLbaEqK4/BRXvtbLmt/LwL1XlVXVacx1X1ynO8dszNDu1tFjlX1Y9jRb2N5re4+7rsGrPreW+17H23teq6fBcBhtntLq6Dxjl97OMzMyeWtJcRyedy+rXIrvr+pWtXozI3X1/Lsv73UmURG+WJQpU/TTcowlX5ZHXd9mRxRnaqyl+L63jHs30ieqoo2yjOdU7m9LUyKJat6mOVo1bXkCsbRV9KVbXyhLldNGxtLEWdUZUTl9dm+7+mW+X0o0NcZ52X6pLEYXq/jDlxRNwCuBdwMfBru4qfBPwA8NCIeHxmXtZnnMzpB/7MPBURr2Q8gOFWB1ui/nU7e5IkSZIkSZIkSZIk6Wg5KyLePu2xz/r3mDyft3smhMy8FHgzcHXgznOKQ0RsAPeZ/Pede71/1pyBQZIkrZUkGfb8S4tcwpG6kiRJUos5sSRJko66Jc6JbzN5fm+j/H2MZ1a4NfC6WcSJiOsD/4Px5Bc3AL4e+FLgpcAf192fPQcwSJKktXM0JzSWJEmSrmBOLEmSpKNuRjnxhZl5+0PUP3Py/OlG+fbr15lhnOszvs3EtgSeDvxE5uLvw+QtJCRJkiRJkiRJkiRJWryYPB92IEEzTmZemJnBeLKDmwKPBX4AeGNEXO+Q7R6aMzBIkqS1ksCw5+ltFz7kVJIkSToAc2JJkiQddUucE2/PjHBmo/zau943sziZOQQ+BDwrIv4V+F3gqYxvL7EwzsAgSZIkSZIkSZIkSdLsvWfyfOtG+a0mz++dU5xtr5k8n7PP98+MMzDoykbRLMphu2xra6NZdrIoO7ExfRO8fOu0Zp1BtMc3VWUbHe90M8pu43xOZfvrdY1sr5PhYHp7J6NYx4NTzbIzaJedYtipbLO4/c1mtOudFu1taDPbn8+gqsf09bJZrK8B7Xgb0f682xHr9obFso2Kbfbq2e3zOdFo73huNescL9oqy6K9fV0+Or1ZdloR87RiG9oY9f8dH8T0ehuN1xeh2g+NBu3tuVolVb3xzFFT6hTfxWr/G53LmkV7GvrzMEl7GcHGiek7yijy3sYuclKxqlftmBr1ql18URbtQ36ZV1V5SdWXan1RxCxSpPZQ+3LB20XZsV75mRY5cXW3yGpLaB2DAUZFWStmFW8Wup6rledxHettDqbnlMeKXLOM17FelaPWy13UK7airjlsFbPvtlbdsOM1gkGxDY3KHVF35sSS9jIiuXRUJI9Lrr1nXS5H84g5G/M8tlVH/NOKPGijytWKss0iZnV9drO85rs5vR/Fydjx6vrroFjuImaVE7f6eCjVNdHqgmOHNK/K40bFufKxYl2Ohu2OVPWqv+F1PR9rnmtWdbpeG5nR+euS5sRvmDzfKyIGmVd8gSLiWsDZwOeAt8wpzrYbT54Xnhw4A4MkSVoryfg8pc/Hcua5kiRJ0nTmxJIkSTrqljUnzsyLgPOAmwGP3FX8FOAawIsz8zKAiNiMiLMi4paHiTOJdaeIuPruPkXENYFnTf77J92WrD/OwCBJkiRJkiRJkiRJ0nz8MHAB8OyIuCfwbuBOwN0Z3/LhiTvee+NJ+T8zHqzQNQ7A/wLOiYi/AD4EXA58MfCNwHUmsX6+jwU8DAcwSJKktTOc0TS8kiRJ0qowJ5YkSdJRt6w5cWZeFBF3AJ4K3Bu4D/Ax4NnAUzLzkhnFeR5wGfA1wDnA1YFPAW8Hfg94fmZxb5o5cQCDJEmSJEmSJEmSJElzkpkfBh6+j/ddDO2RGPuNM3nvn7AEt4jYiwMYJEnSWsmEUc836E1v+CtJkqQVYk4sSZKko86ceHU5gEGSJK2ZmMHUYMs51ZgkSZI0nTmxJEmSjjpz4lXlAAbtWw4HzbLhsP2FPTXcaJadaJRtDtub5rEYdSobFGWljt+S0aBYXxy8rIo3GhVl0S47Fe3b2ByPYbPsjKJsM9vr+bTiM9iM9rC1zWJE20Yj5iBPFW2118lmtrfXjWhv54PiMx0UB7Sq7PRob3ynFxtm6/M5vbht0RnF53a8qHfZqPi8B+2yy4qYm0XZgHbMjaqs2jeMTm+WzdOo2BZG2S0pquoNiu9cNMqOFZ9pdmwryzKTQUmzEwkbJ6bvg4pUh2wf8stz2HKf1tgX5qBdpwxX7T6LZYuiYg6q40bRXpGC56hYvka98pBY9LFsq6hXHUujKKuOi7Moa/Wz6n/XslmoztUGFOcJg/YGfazxRa7yks3qPKcoq2KWeWixbLOoV+lyvrxR9GMdtC50dr22MCoOIO2zUBg26sWar39J8zFMuHTOx/1VNnRdLbXq2tqy6PqH1NPK655FbtjIF8q8tzhpPJ6bzbJBcX25VFWrzr9nodGX6m8soyI3HBbnK6PiHPVYx3qta7pQn0NU5zOtc8OqrbqsWVRfQ24GNCdeVw5gkCRJayXpfkJYxZQkSZJWhTmxJEmSjjpz4tU17/FLkiRJkiRJkiRJkiRJV+EMDJIkae3Me+prSZIkadmYE0uSJOmoMydeTQ5gkCRJa8WpwSRJknTUmRNLkiTpqDMnXl3eQkKSJEmSJEmSJEmSJC3cSg5giIibRMTzI+KjEXEiIi6OiF+JiOvOOk5E3CUiXh0Rl0TE5RHxzoh4TERsNOI/MSJeHhHvj4hRRGREfOke/bpaRDwlIt4TEccj4t8i4vci4ssOsnySJB1NwZBBrw96Hqkr9cGcWJIktZkT62gwJ5YkSW3mxKtq5W4hERG3BC4Abgi8CrgQuCPwaODeEXF2Zn5yFnEi4puB3weOA+cClwD3A54JnA08eFczdwB+lvGMIh8EPg1cZ49+nQ782STe24BnAV88iX3fiLhHZv71XsvXWTH3SY7aX8rRqD0WZjhsl20Nr5LPA3Biq71pbsSoWXZsMGyWDYp6G1Es+Fa7aLhRLHcWZcUOrnU/nmFxn56Tg+nrEeDkVc+ZPu+0aK+vzWgv+Kk4VdRrxzwt25/BZvH5VGUbOf2zq0ZnVX3coCiL9mewWXymg6LeRlFvs/jsKoPG0p8R7e/VZvHlP71YX2cUn81lo2I7KbaFy7L6fNr9rPYNg1G7rG/Vd7+sV2y11fd/VGxDW0VfRsV6Hg2mx8xhu60o9qNVSlfVk9RmTtxDTpzJxonGvrDYf24ca5dlY/8JUKSNzcSlPKR0LCtSeqKoV6QD5Y6+OoeIUfsY0EwVquWuFq6oV/axY71qW8jquF6WFX1p1KvjzaKP3S7kjKqNvcjxuqjOBaqyQZGzlOcXVY7aNbetzo+KmFW9LvHWQXVu3iWrr7bljWI7KfvR+NyK00zpyDAnPnxOPCK4fLRyfyKYqb6nGtf8+Nnt3wbtvPCMQfuablGtzF8rgyLooHHtf96q67bVtdny3KlYX6Mi0avOIY4N2jG7XtdtnQdV16ulPqziDAy/zjiZfFRmPiAzn5CZ92CcHN4GeNos4kTEtYHnAUPgnMz8vsz8UeC2wF8BD4qIh+xq423AXYHrZOYtgXfso1+PY5yUvgK4U2b+eGZ+B/Ag4OrA8yOqy2iSJB1tyfgEoc/HcpwuSVdiTmxOLElSkzmxjghzYnNiSZKazIlX10olOBFxC+BewMXAr+0qfhJwGfDQiLjGDOI8CLgB8LLMfNv2i5l5HPjJyX9/aGegzPyXzHxTZn5mz4Ub9yuAH5z898cyr/jdUWa+CngT8J+Au+0nniRJktaPObE5sSRJ0lFnTmxOLEmS1tdKDWAA7jF5Pm9n0gaQmZcCb2Y8+vTOM4izXee1U+K9EbgcuMtkaq+ubgl8CfDezPzglPLX7OqLJEmaYkj0+pCWjDnxlfsiSZKmMCfWmjMnvnJfJEnSFObEq2nVbnB1m8nzexvl72M8YvbWwOt6jtOsk5lbEfFB4MuBWwDvLtqu7KdfTPpVioi3N4rOOminJElaJQkMyxvHd4spLRFz4jFzYkmSGsyJdQSYE4+ZE0uS1GBOvLpWbQaGMyfPn26Ub79+nRnE6avtyjzakCRJ0mozJz58G5IkSVpt5sSHb0OSJGkprdoMDHvZnrvjsANgusTpq+1e2sjM208NMB5xe7tOrVetZnvalNGoPU7m5NbG1NePbQybdU4M25vtscGoWTaI9gJsFGWzMCqmmTk1mL5OhsV4o1PZXienBu2yzdhqlp0Rp9oxo1vMzWh/rqdlu6yqt9HYMKvPezPb20m1LWxmt21oUGxe0z/t7Zjt5a5Gn200tq9BtLe7Vp29yk6Pdk8Gxfdxo/q8q8+n2BENOtZbFtV3fFTtY4sRpMeivU5Ggyrm9Hpb1eddfQeKsuqTiUa9YlPefgej3sdoOj2YVoo58fYbipw4RtxucLK9n2zG3GjvDwYbxf6uOOiPGjEHRRKRxX682F3XZe3Dc5lHjIp+VjGrXXWOprdXHNqqUxIYFZtLsS6zyP+yPAcqtpNqudtFnZSncFX/i+Ne17yklV8A5WG26suw6Muxng/dG8XGV56vdKw3KOp1zW3rmAffH3ZV5YbV9jULgw45Y7WdV+dw1XSzVS/a7e21HZgT68gzJ95+Q5ETj4jbXZabvXZsFVTXYHRV1bFP66fKWarcttpOqr81bFQXz6sUdQabZevc43Taf/OoVOcrnc+5Bu18szoPbV1nhT2u3TbKutQZl1XrZBbMiVfVqh15tkeWntkov/au9/UZp6+2++6XJEmSjhZz4sO3IUmSpNVmTnz4NiRJkpbSqg1geM/kuXVvr1tNnlv3BjtMnGadiDgG3BzYAj6wR9t990uSJO2QjEeL9/lY/jk8dMSYE1+1X5IkaQdzYh0B5sRX7ZckSdrBnHh1rdoAhjdMnu8VceXJTyPiWsDZwOeAt8wgzusnz/eeEu+uwNWBCzLzxF4LUbgI+BBw64i4+ZTyb9zVF0mStEsCwxz0+jAx1ZIxJ75yXyRJ0i7mxDoCzImv3BdJkrSLOfHqWqkBDJl5EXAecDPgkbuKnwJcA3hxZl4GEBGbEXFWRNzyMHEmXgF8AnhIRNxh+8WIOAP42cl/f6Pzwo37lcBzJ//93zuT5oj4ZuC/Au8C/uIw7UiSJGl1mRObE0uSJB115sTmxJIkaX0dW3QHOvhh4ALg2RFxT+DdwJ2AuzOeMuuJO95740n5PzNOQrvGITM/ExHfzzhBPT8iXgZcAtwfuM3k9XN3dzYiXrjjv2dNnn8xIi6d/Ps3M/Mvd7znGcA3AQ8C/joiXgd8CfBg4HLgezNz1Fg3kiSJYET0HlNaMubE5sSSJBXMiXUkmBObE0uSVDAnXlUrN4AhMy+ajGx9KuNpuu4DfAx4NvCUzLxkVnEy85URcTfGSeu3AmcA7wceBzx7MjJ2t++e8tq37Pj3+cDnE9PMPBERXwc8AfgO4LHAZ4BXAk/KzHftZ/kkSZK0vsyJzYklSZKOOnNic2JJkrSeVm4AA0Bmfhh4+D7edzHFUJj9xtlV582Mk9j9vv/AQ3Ey83PAkyaP+apu3lKUVWN9h8P2KhhuTL+LycmtjWadjWh35MSgvUkPinrzNio2i2FOXyejxusApwbt9XUq22WbMWyWHY/NZtlpRb0zBqeK9rbaZbRjbkR7A2stw0axUVbLvTH1/HK7XjtmVa+6K1K1Pdcx21oxB8VXoL2V1Dai22jDM4p65foanGyXjap68/tBQvVdHQ2KsmLk5taoXW9r0N6et6q+FPuhrca2fqxYj619F9T732HRj3a9en+ewLDnu2QtzxFEuoI58SFlEqem70OrPchgs126cbK9t8iNYn/XOBAXaRxFOlOXFQtXHdaL3TwUh9mqvRy1G4zGcb38jWHVx2ITnP73hYmij1kkV2XI4rg+KGO2+9I6rkeHOrNStTeLvrRysrKtGaySQXEOUZWV5yzFl67Ku6p6zTpFH2ei42dQ5aKV6jy0lU+OOqxHgEGxk6rOITYa28Jeq8qcWEeFOfHhjHLAZaPTZxH6wEardbfrhRr669+5qPKLuedIHXXNkeapWpfV3xrKlKzjYjfXVxGvPM8ZVOdA7aDD4npvfQ25+HtCcZ5QlY0aZbPYC0XRj+rctmJOvLpWcgCDJElSU87gBK3nzDQi/ivwGOAuwPUYTzf6D8CvZOar+21NkiRJR86S5sQR8QXAA4H7Al/JeFr/k4xz4RcAL3BKfEmSJPViSXNi7c0BDJIkSXMUET8J/AzwCeCPGU9Nen3gq4FzAAcwSJIkaV09GPgNxjnwG4APAV/IeBr93wS+MSIe3Jh+X5IkSdIR4AAGSZK0VpLoferJ7GlitIh4MOPBC38OfEtmXrqrvH3/HkmSJGmfljgnfi9wf+BPds60EBE/AbwV+FbGgxl+v4/GJEmSdHQtcU6sPSz/DXAkSZLWQEQMgF8ELge+Y/fgBYDMLG7uJ0mSJK22zHx9Zv7R7ttEZObHgedO/nvO3DsmSZIkaWk4A4MkSVo7w1zKkbB3AW4OvAL4VETcF/gK4Djw1sz8q0V2TpIkSetlSXPiyvZg3q2F9kKSJElrYwVzYuEABkmSpP06KyLePq0gM2+/j/pfM3n+V+Bvga/cWRgRbwQelJn/fqheSpIkSbNz2Jx4qog4Bjxs8t/Xdo0jSZIkafU5gEFXEsVIpKzKRlVZ+04lo9Fo6utbw41mna2N6XUAThX1BmSzrDKIbvUqw+LuLa2yUXFfnVPZXu5Tg3bZZgw7lZ0R7RnOTxZ9Oa1jexvR/sw3Y/oPMzbpFm+j2E4GZb2qj0Vfst1e1ZdKa5stl60o2yi+A1X/u96jaKMYEFnFvPqg/SOdQdHPvg2z+n63F66qV32Py/1Jsd+uyo41+rJVba/F92Mr2n2cxfjXpF4vXWP24IaT5x8EPgh8HfDXwE2BXwa+AXg5TpkrzUdCnGrvu1oGp4rc9lh7rxbD4pjZSBVyq8ixN9rxclj0o9g9lmXtdIbBoN3eaNDuZ3HooJVaVecdVMf7sq0q+SjWc1UvqvOqImbX87Gef1EyKuKVZR2P7FW9KmcZFflTvYE12iryh+r8outyVzqfXxTLPShitnL+qh/zVn4+xTrp+ourjUZ7XfPM6pxrVKzndnt1hrrEOXHLLzCenezVmfmns21K0rYhwaWjqy26G0ulunbT9Vpd1/Y0e2U+qaVWXbM+rZjMaVScq9G6BFucDw8HxTWCIg/dal0I2KtesR86VsWszrmKv+G1VH83ixn8Ta2rFcyJNeEABkmStGZiBiegAXDhYX5VxhWnQcF4poV3TP7/TxHxQOC9wN0i4mu9nYQkSZIOZ2lz4qtGjXgU8HjgQuChfcaWJEnSUTaznFgz5vAySZKk+fjU5PkDOwYvAJCZnwO2f2l2x7n2SpIkSVqQiHgk8CzgXcDdM/OSBXdJkiRJ0oI5A4MkSVorSzw12Hsmz//RKN8e4OD8nZIkSTqUJc6JPy8iHgM8E/hH4J6Z+W89NyFJkqQjbBVyYk3nDAySJEnz8UZgC7hVRJw2pfwrJs8Xz61HkiRJ0gJExI8zHrzw94xnXnDwgiRJkiTAGRgkSdIaGuby3YssMz8REecC3wn8NPCT22UR8fXANwCfBl67mB5KkiRpnSxjTgwQET8FPBV4O3AvbxshSZKkWVnWnFg1BzBIkqS1kgSj3qcG6y3RfRxwJ+CJEXFX4K3ATYEHAkPg+zPzP/pqTJIkSUfTsubEEfHdjAcvDIE3AY+KuErcizPzhYduTJIkSUfasubE2psDGLR/xY1dctT+wmYxumk4nL7j2NgYNeucatQB2Bi0yyI22mXD9sIN2GyWVapRXacP2n3ZapRtFct2+mCrWXYq222dHu16m0XMUbT7slms5+PRXs+nVX2JYbNso/H5lHWivX0NaJdV9Tbp1l5lo/jSDYqYGzm9rHu8dr0qZmVQbAtVe11V/bxGnJpe0DGvGWW7YnW/rape9T2uyraK7+PJ4jNofT6DchvqvyyKslWVmf8WEXdiPPvCA4E7A5cCfwL8fGa+ZZH9k46UTOJU+/jdEqeKPGKzvS8fbLX3aaNj0/PGIp3pXtY+NFClLFVZI/UYq2JW5xeNsvLQUJ2TVMf1IveoznNiUNQrzgXqsmYRo6LeqFGvaquO163/XWPOwqhxUanKx44VG+yw2Iiqc495q85nTiv62VqGrucyXZXruTjnGhYXETeLTa/O3ad/sarPu7oOsFFse9V22crBV/iy6c0nzxvAYxrv+QvghfPojHTUjRhw2WjaHQ41Td9/BJu36jhbmXc+0Leuy70qqjyii43qJG4NVNciW/nmGYPG9WPa5x1QnwNVn1uVUx4rtuetoqy6rrsxKK5zNGJWZ0Ddr/eucIar3jmAQZIkrZ1lPjmdTJH7uMlDkiRJmollzIkz88nAkxfcDUmSJB0Ry5gTa29+apIkSZIkSZIkSZIkaeGcgUGSJK2VpJ6+rWtMSZIkaVWYE0uSJOmoMydeXQ5gkCRJ6yWj/6nB5nzfbkmSJOlQzIklSZJ01JkTryxvISFJkiRJkiRJkiRJkhbOGRgkSdJaSWDY8xhNpwaTJEnSKjEnliRJ0lFnTry6HMCgK6u+eWVZe8qUHBXVRtPrDYftHcpWbDTLTg3anawmdRlE/7uc0Ua7xVExZc2osS6r+/ScyvY6OT23mmXDQbsfm0XMU9HedWwO2u1txrBZdoLNot7BY25Ee8Mb0C7bKLaFjaLeoGjvtGK5K3U/i7LGl7XveHup1slGtWMoVH2p2uu7rTPiVLPsWhufa5ZVyVLruw/1d7xr2bFRe30da6zLY4P2trxV7Neqfews9r+StB+RSZxq5BjFuW0M23lQbBX7uw5lxW6c0bB93BgM221lUa9Is6l219UhOBr5PkCOity9Ua+q0/lcpuhjtS1kdQ5UNJjVIpQxD16vyi+6xIPu9w+tz4HaG1HXeu061XlasWxFUTUladV/ivOEKm/cpNv5RaV1PlCdi3U9T6gMo9v21XVa2FG067ViDouNYaP43IbVuUx1rtaIaR4tqQ+jDC4fnd5rzL7/UKSDKXMPraUqN+liFjnequiyLqu/eWwW11I3s7jOWpycbxUn4F3LBkVO3Mo5q1x02PEWC2F+qx0cwCBJktZO+QcISZIk6QgwJ5YkSdJRZ068mhyOJ0mSJEmSJEmSJEmSFs4ZGCRJ0lpJYgb3NnOkriRJklaHObEkSZKOOnPi1eUABkmStHa856MkSZKOOnNiSZIkHXXmxKvJT02SJEmSJEmSJEmSJC2cMzBIkqS1ksCw56m8stdokiRJ0myZE0uSJOmoMydeXQ5g0P5l8SXP9lc2i3qtstGoXWdUxNsaticVGUSxW9kqvgodvyWjYqdYLUOrrIp3LDaKeO11cirb9TZj2K0s2yusqjcodvubg60Dx9wo4g1idOB445jtehtFzONlvXY/q/aqZWjHK9rqEA9g0HGdVMrPrmivjNnz+qqSnk3a29A1BieaZdX38Xie6lTvxKj4Pg7a/dxq7DdOjtptVfvY6vtdacX0LmOSejOcvi+MrSKn3GofU3LYLhtVeepw+v5uNGzv8YrdOFkc9qpD4tzLisNDaxnqOt3OV8rDVOeyqi8HPz86TNk8Vec58z6ADxt9OVb0o8t5GtB52cqpTIvzkuoerhvlRJvFjqODrucCVZ5dqXLwrve1HRX1hjG9vVPFOe+w47lM9bm1YoaXTiX1YMSAS0dnLLoba8/py7Uuhku0LXe99lzpe/nKv3kU+f6p4oT/WNHHrmVbxflyaxmiODmvTo+qa8h9DzTQanMAgyRJWjMxg4sDJtCSJElaJebEkiRJOurMiVfV8gyXkiRJ6sH21GB9Pvx9myRJklaJObEkSZKOumXPiSPiJhHx/Ij4aESciIiLI+JXIuK6s4oTEbeKiB+PiNdHxIcj4mRE/GtEvCoi7t7f0h2OMzBIkiRJkiRJkiRJkjQHEXFL4ALghsCrgAuBOwKPBu4dEWdn5idnEOdngG8D3gW8GrgEuA1wf+D+EfHozHx2P0vZnQMYJEnS2vH+kpIkSTrqzIklSZJ01C1xTvzrjAcdPCozn7P9YkQ8A3gs8DTgB2cQ57XAL2bm3+0MEhF3A/4M+KWIeHlmfqzTUvVkaT81SZIkSZIkSZIkSZLWRUTcArgXcDHwa7uKnwRcBjw0Iq7Rd5zMfOHuwQuT1/8COB84DbjL/pdmNpyBQZIkrZXMYNjzyNrM6DWeJEmSNEvmxJIkSTrqZpgTnxURb59enrffR5h7TJ7Py8zRrvqXRsSbGQ9MuDPwujnE2XZq8ry1j/fOlAMYdGU5g3qj9glu6+R3VNQZDts7m4h2R2JYlBX1Tg03mmWzMGqtE9rr5FiMmmWteADHih33VrSX+9Rg2CzbzHbZoFjPm1HFbPdlo7Hsg2Kj3By0970bRb1BsZ6712uXVeurqtdaJ5VBEa+yUfSxrFcud8e+dNyBtbehbv3o6ow41Sy7+uBks+xU8f04fbDZLDsxaqcAg0Z6UG2T1Xeu3Dd33Ib2Uu0zJQmATGJrev6Rg+Lkdqt9fIitYn9X1WvkmzEq4hWHqRi294FlzKIeVUpc7crL84R2USsVzeI8IbJorDonqa5lVDGLPDuL9ZxRnR9VXWnXa+X8XerMrKw4Ns8i5rKoLpZV50DlNKdFva5a/dzsuIqr3Hwzup2PVYbF92pYTD5areeTjTy7Ogeq+nEq2/n3sDqfbOws9/PRrMJ3RNJijTK4fHj6oruxFtznal30/cfeddDlejt0X5fVeUL1d5uT1bXbnq/rVvGWzZLun28zeX5vo/x9jAce3Jp64EFfcYiImwL3BC4H3li9dx4cwCBJkiRJkiRJkiRJ0t4u3OdMCy1nTp4/3Sjffv0684gTEacDvwOcDvxYZn5qj3ZnzgEMkiRprST9jxZfnTHFkiRJkjmxJEmStMI58fa0EYdtbs84EbEB/DZwNnAu8PRDttkL54KRJEmSJEmSJEmSJGn2tmdGOLNRfu1d75tJnMnghZcADwZ+D/iuzOrmlvPjDAySJGnNRHm/7K4xJUmSpNVhTixJkqSjbmlz4vdMnm/dKL/V5Pm9s4oTEceAlzIevPBS4GGZOdyjvblxBgZJkiRJkiRJkiRJkmbvDZPne0XElf5WHxHXYnw7h88Bb5lFnIg4DXgF48ELLwYeukyDF8ABDJIkac0kMGTQ62Mp5s2SJEmS9smcWJIkSUfdsubEmXkRcB5wM+CRu4qfAlwDeHFmXgYQEZsRcVZE3PIwcSaxTgf+APhm4LeAh2fmqIfF6pW3kND+Vd/KYgqW6nYpra9ERntszWjUjjcatettNUtgsESzII4anRlle9mODdoDo6rpcY4VMU9Gez2flu21eTLau5Vj0e7niaLeZlFv0OhnVWcj221Vh5+NaO/DO9cryjaKmF3rdYlX2aBbvdbnNqv26s+u32PzRsdlK2MWfay29ars9EH7e3xiMP07cmzUbVvu6jC75v6nBpO0dhLYmr6fjEE7R4phMSB91M4xqt1kDKcfO2LU3pcVu/i6rWp3XRzCyphd6xXLl42cvzhNoLxLY9eyso9FveIEI4sGszyvajfXKipOncq2quNoVVbFnLfW+VN1XlV+saq2OmYtw6LeZtVetZ6LomHxG5ZNpi/7sFhfVa7ZVXkeV3x3qnVZlY2KddLKb6tt6GRuNMuq84STFPUafYx9nPeZE0vay4jg8tFpi+5GZ133c9V1KfedWkZ9b+tu56urugZ7rGNZFbPLdfyu1/5nZYm39x8GLgCeHRH3BN4N3Am4O+NbPjxxx3tvPCn/Z8aDFbrGAXgucB/gE8BHgJ+OuMo6Oj8zz+++aIfnAAZJkiRJkiRJkiRJkuYgMy+KiDsATwXuzXhQwceAZwNPycxLZhTn5pPn6wM/XYQ+f5+LMhMOYJAkSWslifLXdF1jSpIkSavCnFiSJElH3bLnxJn5YeDh+3jfxRTz7e03zuS95+yzewvV76cmSZIkSZIkSZIkSZLUgTMwSJKktTNc3nubSZIkSXNhTixJkqSjzpx4NTmAQZIkrZVMGPWcmGb2Gk6SJEmaKXNiSZIkHXXmxKvLW0hIkiRJkiRJkiRJkqSFcwYGXVk1cqhzWXt0UzbKqhFMo1E73nDYHpMT0Q66VdTrqhrVNdooliFH0+sMhu14FG0V/TiW7eU+FtP7AXBqtNEs2yz6OSh2OceKeiejqBfT650o6mzQXrZBsZ1UZV1jbhTreVB+sdpaMat4VT8qg471Njou27zb66J7H/tftjMGp5plJ0bt78hmaxuqtteO352q7DBGxf5NksYSho38o8opt4p9YVGWw3bZaDS9vcGwvY+scuLqUNRInfauN4uy4hDQKqvOE6q2yl9IzL2sOj8qqnX41UhVp+9foeylPD+qyopznWoq0GNHdJbQYZEDbVY7gBVQ5Y2bHXPpU8XvejaZvr5O0T4frvLlKj8dFP1vtRf7OMcxJ5a0l2EOuGzr9Lm11+Waifuy1VXlcbPQ9Vpqy7z7L81S39d1Z3VNdxY8jqwmPzVJkiRJkiRJkiRJkrRwzsAgSZLWShIMex4ln466lyRJ0goxJ5YkSdJRZ068uhzAIEmS1s68p8WWJEmSlo05sSRJko46c+LV5C0kJEmSJEmSJEmSJEnSwjkDgyRJWjujdIymJEmSjjZzYkmSJB115sSryU9NkiRpQSLioRGRk8cjFt0fSZIkSZIkSZIWyRkY1I/sWDaafu+ZHLQr5ag97mYUo2bZcDjf8To5aPelrNe4H091n57hqN3W1qC93MeyXe9YDJtlg2h/PlvFaLZBsTEcK+ptFO0NGruxqo+DYjup2+oWs+rLBt3qVWVd2qp0aQtgo1on5Y6hW8y+LVMfq+2re8yDb8/l96Pn7fUwEhjR773NZrEEEfHFwHOAzwLXnEETkiqZ5Nb0fCc2Ntr1hsU+ucjJGLb3JDGaXhbD9r6sVWdc1u4GRU5ZxazqlSlGeS5w8LLqkJLlOUmx3J1jdltf2bnewcuqOpV6sdsxq+Pvstx3tOrjsPiNR1W2SfvcqWtOMizqbXaK2L9R+ZuY9jqpdF3uKnevctjNYod5qnGOulGdFxY7tlMUx5ZKo7m9tqxVyYklLVZm8LnhshxZNGvVcaHrdbC+jzWS5m+Zruv2zZx4dTkDgyRJ0pxFRAAvAD4JPHfB3ZEkSZIkSZIkaSk4A4MkSVozwbD3X3n2/ouCRwH3AM6ZPEuSJEk9WomcWJIkSZohc+JV5QAGSZK0VjJhVNyWpmvMvkTElwG/ADwrM98YEQ5gkCRJUq+WPSeWJEmSZs2ceHU5gEGSJGl/zoqIt08ryMzb7ydARBwDfhv4EPATPfZNkiRJkiRJkqSV5wAGSZK0dka9Tw3Wm58Gvhr4L5n5uUV3RpIkSetriXNiSZIkaS7MiVeTAxi0b1F8ycspU0btombIUdFWsa/Jot4oqp1Uv1PIAIyKdVLtMFv349kYtfs4HLRX8ka2y4ajdtnWoN3eINoLd6yIOYiibLTRqb1W2YCD1xmXFeuyqtexvcos+tKlra7936i+/GVf+l+XXcyi/11tFJ/PLGzGcOrrXbatNXPhfmdamCYi7sh41oVfzsy/6q9bkjpJYDR9f8ew8TpAkevEVlFWJIcxnF5W1iny3uqwMZOy4vDQd1l53lHk2FFUXJXpH6t+ZocLMl3qzEo1peeoOJ+pY85v+YZF/1t5FewxlWlRbxaGjfu4bs61F7OxUeSwm8Vmssn0z+BUsUPcLD7T40U/qj62ztVijudGktbXiOBzw+l7+1Fxj2+vDyxW9dlo8WaRh/Z9vbFrH7v2Y97tVbr0ZZ7XpFeFxwHNmgMYJEnSWkn6P5k/bEq+49YR7wV+6vA9kiRJktqWMSeWJEmS5smceHU5gEGSJK2ZmMFo90PHuyZw68m/j8f0WYGeFxHPA56VmY85bIOSJEk6ypYyJ5YkSZLmyJx4VfU/b/4cRMRNIuL5EfHRiDgRERdHxK9ExHVnHSci7hIRr46ISyLi8oh4Z0Q8JiKa899HxHdHxFsj4rMR8emIOD8ivql4/1dGxO9ExPsj4nMR8ZGIeENEfFtErORnJknSEXcC+K3G4+8m7/nLyf+9vYT2xZxYkiRJR505sSRJ0vpZuRkYIuKWwAXADYFXARcCdwQeDdw7Is7OzE/OIk5EfDPw+8Bx4FzgEuB+wDOBs4EHT2nn6cDjgX8BngecBjwE+KOI+JHM/NVd778f8P+AEfCHwCuA6wMPBF4GfB3w/XstnyRJR1l5T+kFyMzPAY+YVhYRTwa+GnhRZv7mPPul1WVObE4sSdJeli0nlvpmTmxOLEnSXsyJV9Mqfmq/zjiZfFRmPiAzn5CZ92CcHN4GeNos4kTEtRknlkPgnMz8vsz8UeC2jH8p+aCIeMiuOndhnJReBPznzHxsZj4SuD3jpPbpEXGzXf36BcYDS+6VmQ+e9OsRwJcD/wY8IiK+ZJ/LKEmSpPVkTmxOLEnSyurrV/M68syJzYklSdIaWqkBDBFxC+BewMXAr+0qfhJwGfDQiLjGDOI8CLgB8LLMfNv2i5l5HPjJyX9/aFesH5w8Py0zP7Wjzna7pwMP31XnFsBnMvMvdr6YmR8H/nry3xtUyydJ0lGWwCij10cueqGkHcyJzYklSdrLMufEk1+7v53x8f+tjP9I/AHGv3b/q4j4gp6a0hozJzYnliRpL8ucE6u2areQuMfk+bzMHO0syMxLI+LNjBPOOwOv6znOdp3XTon3RuBy4C4RcXpmnthHndcAPzV5z5N2vP5PwO0j4r9k5l9uvxgRN2Q8ddlHgXcVy3Y4GUVZ8bWsvrFdykbtfmS0A446jsnJatnKeu1+bhRluza7fcXMQVGnWQJbo/Y6GRYxN4o+DorP4FTRmyjqHSv6UrU3aLQ3iI7xirJKlz4eKmaxfBsdlqHqY9d1UrbXc/+h+3ru1FbR/7refNObDbr181ROv13nLL47lcNEHFEcz5ZMZj4ZePKCu6HVYk7cV048mr6nyVF7/xnDIicbFnlQo62yrNiNl7vdoqw8hHWs1zVmXdbYjxd5e7VOynS/7z5Sn1/U/ex2/Go1N+oYr6rXNWbZXsfjdjkVaId8rfNyzzntGBbnvZsMe22rPsdutzUsVspm177M+TM4oxFzs9gxnOi4/jeqnU2jaD/nP0ucE+/8tftztl+MiGcAj2X8a/cfbNSVtpkT95ATjzK4fOu0w4SQlt4SHw91CFUutCyfedfr1cvSf+h2/tf1OnF1PnxUrhPrCis1AwPjKbsA3tsof9/k+dYziNOsk5lbwAcZDwi5BcBkVO6Ngc9m5scO0NfHAp8B/jwizo2In4+I5zFOWC8FHjC5j3YpIt4+7QGctVddSZIkLTVzYnNiSZJWUl+/mpcwJzYnliRJa2vVZmA4c/L86Ub59uvXmUGcg9bp1NfMfFNEfC3we8B/21F0KfAC4B8a8SRJEuPRun3/OrTrL2KlGTEnNieWJKm0xDlxX7+al8yJzYklSSotcU6sPazaAIa9bG81h53Hukucrm1f6f0R8fXAy4C3AQ8DLgRuBPwPxlPo3Tci7jYZzdsOmnn7qZ0cj6693QH7KEmSpNVhTrwd1JxYkqS+nTU5jl5F67i7y35+7X4vxr9EdwCDDsOceDuoObEkSVoxqzaAYXs06pmN8mvvel+fcQ5aZ6/3X2XkbURcDziX8X3SHpiZl0+KPgA8LiJuDjwA+C7ghY24kiQdebO4P7e0RMyJzYklSdrTkubEff1qXjInNieWJGlPS5oTaw+DRXfggN4zeW7du+xWk+fWKO7DxGnWiYhjwM2BLcZJJJl5GfAR4JoR8UX7bOMuwHWBv96RlO70hsnzfka0S5IkaT2ZE4+ZE0uSNH8XZubtpz16it/Xr+a1/syJx8yJJUnS2lm1AQzbidm9IuJKfY+IawFnA58D3jKDOK+fPN97Sry7AlcHLsjME/us84273gNw+uT5Bo1+b79+slEuSZIYj6zt8yEtGXPiMXNiSZIKS5oT9/WrecmceMycWJKkwpLmxNrDSt1CIjMviojzGN8L75HAc3YUPwW4BvB/JqNaiYhN4JbAqcy8qGuciVcAvwg8JCKek5lvm7RxBvCzk/f8xq4uPxd4KPDEiHhlZn5qUudmk3ZPAC/Y8f6/Yjw69+yIuFdmnrddEBFfDPz3yX9X6x6A1Zj5RlmOip1AVDuIdmOjot5g1I44LMb5ZLbbK4rKndxwNL3ixqBdZ2PQ7uNGsXDDoh8bo3bMQbQXriqLouxUY7kBjkXxATVUy131sVIud7HtDTr0f6/2utTrHK/jD1+697/b+qpsdOxLy7zXybJYlQQt6b+vq/3Jad2YE/eUE2fCcDi9bFiM8x61j1NRJIAxLMoaeVB12GjVGZe194F1zHZZl5z+MO216lXxqvy7a/9LZcz2Z5BVWRG0qtdFsQkdIma7j12PzX0f06tzoGMzSHWG2d6fbEZjHwSMinoU9eq+tBdwczXSvLnaaFxD2KjqVOeFtD+34x12RLFHnSXOifv61byOOHPifnLiUQbHhyv1JwKtkL7zV6ivL3dpr4pXmcWySatkRP/nfpXmd26PtpY4J9YeVjE7+WHgAuDZEXFP4N3AnYC7Mz65eeKO9954Uv7PwM0OEYfM/ExEfD/jBPX8iHgZcAlwf+A2k9fP3VXngoh4BvA44J0R8QrgNODbgOsBP5KZF+94/0cj4mcYJ8eviYg/Bi4EbgR8C3BN4A8y89UHWF+SJElaP+bE5sSSJK2iK/3aPTM/P5ztgL+al8Cc2JxYkiStpVW7hQSTEbJ3AF7IOJF8POPRs88GvjYzPzmrOJn5SuBuwBuBbwV+BDjFOPF8SE75OX5mPh74HuDjwA8ADwP+CbhfZv7qlPc/FXgAcB7je509Hngg8A+Mk+kH72f5JEk6ykZErw9p2ZgTmxNLkrSXZcyJJ7nHeYz/gPzIXcXbv3Z/8a5fu0tTmRObE0uStJdlzIm1t1WcgYHM/DDw8H2872Job037jbOrzpuB+xywzouAFx3g/a8CXnWQNiRJknS0mBNLkqQVdaBfu0sVc2JJkqT1s5IDGCRJklqSmMG9zRxdK0mSpNWxzDlxZl4UEXcAngrcm/EfgD/G+NfuT8nMS3ppSJIkSUfaMufEqjmAQZIkrZek98SUq0z+KUmSJC2xJc+Ju/zaXZIkSTqQJc+J1TZYdAckSZIkSZIkSZIkSZKcgUH7V40qKsuK0U2jxuvRDpijIl41kKrVFjAqhvIMqnpFc/X4oHbNjOkLUa7ibJeOioqDYn0Ni89gUJRF13rtrnCqQ8woFrzqR1lWfArVcle69qXvtsp6HYcUDqL+hrTrzXcI47Ks52XS5TPvOpK1qtcq20/veh9ZK2ntJEkOh1PLIovTpCLvYlQljgdPKqt8psqxq0NR95jd6pUJc5fzi47nJNU6yar/1XJ3NYuQhzhmHiQeLNcxtswjnNZz5obFOt4s67XPlTeZvl9eJtWZ/mZ0uw6w19WFg/bj81GX6PsqaTklcGLonwjUXZlLF6prqV1jdmlrHfS9vqTD6nK9F2a3LZsTryZnYJAkSZIkSZIkSZIkSQvn8EpJkrRWkv5H1q73WH1JkiStG3NiSZIkHXXmxKvLAQySJGntOH2eJEmSjjpzYkmSJB115sSryVtISJIkSZIkSZIkSZKkhXMGBkmStGaCEX2PrHWkriRJklaJObEkSZKOOnPiVeUMDJIkSZIkSZIkSZIkaeGcgUG9iOIeMkm2K7aKRsUIpmpw0+jgTe1lVAzzGRTtDavFznbQaCxfFvGq1TUoPptqVQ6i3WAUZRuDbvUqXfpS1unYVqVrvWqdzLsvzXgdvz1dP++uel/uOfd/Fua5LVQjWbeKHWl1D7Ku9ydLYNTzvc1Wf2uQNFUrwRoO23WGRQI4qhK2dlG06hXxouhiMx5AlRtWO7uirKrX+VDUqle1VYXr2I/yPKcK2nm5q/Y6xmzGa7fV93F0r/ZWXbm+iqJhcV64WX3JC8PidyqbnSIeXcPGl27QOmnfo+yM8jdExUGiURZ77GjMiSXtR2Zwcrix6G6ooct+fBbXs7oeT7r2ZRa5qHQUzOKcq8s1/q7Xe6vvvteJjx5nYJAkSZIkSZIkSZIkSQvnDAySJGm95AxGHDu0VpIkSavEnFiSJElHnTnxynIAgyRJWjtONyhJkqSjzpxYkiRJR5058WryFhKSJEmSJEmSJEmSJGnhnIFBkiStlaT/qcGcGUySJEmrxJxYkiRJR5058epyBgZJkiRJkiRJkiRJkuYkIm4SEc+PiI9GxImIuDgifiUirjurOBGxGRGPjogXRMTfR8TJiMiIeER/S3Z4zsCg2SuHIzVGPmVRaVQ0VQykiiJkjrqNwBpFu14UDY6q5WvUy2yPNyq6wahYtqqPVczBoP0hDIvPZ1B9CIW6n9PLBh0H1VVtVWaxbF3b6/uOTl2XrWu9Stf11bdZLNu8LcsyVPcgG46m7/f2HjUbM7i3mfdKk9ZOAqNG4jKqEscqT20nQlHVa5RFkVfV8Yr8r9r9HzxF3bNepYrZKitz+rKP1TppVywXrTrWdPx8yhaLeq1jY9+/NNlLefytzlmKevO8X+moOOfqumxH1bBYl5sx7L290Qp8CJvR9TdE0w8Ge5/zmhNL2tsog5Nb/olgkapTjy66XhPtux+SavM+V5un6hp+tdzVbqj1d669d13LmxNHxC2BC4AbAq8CLgTuCDwauHdEnJ2Zn5xBnGsAvzL5978CHwe+uI9l6pMzMEiSpLWT2e9DkiRJWjXmxJIkSTrqljgn/nXGgw4elZkPyMwnZOY9gGcCtwGeNqM4lwP3Af6/zLwR8PwelqV3DmCQJEmSJEmSJEmSJGnGIuIWwL2Ai4Ff21X8JOAy4KERcY2+42Tmycx8TWZ+7DDLMGsOYJAkSWslGU8j3OfDH5xJkiRplZgTS5Ik6ahb4pz4HpPn8zLzSveMy8xLgTcDVwfuPKc4S8cBDJIkSZIkSZIkSZIk7e2siHj7tMc+699m8vzeRvn7Js+3nlOcpXNs0R2QJEnqVUJm9B5TkiRJWhnmxJIkSTrqljcnPnPy/OlG+fbr15lTnKXjAAZJkrR2Rn0nppIkSdKKMSeWJEnSUTejnPjCzLz9LAJPbHf6sMMl+oozdw5g0JVEsQln1827qtfab1R1qp3NqF1UdqMIWS52scKyCBpVg62Y1QdQ9KNqK8p67eZGo24xK+Uq6RCzcz+KskHnZev/2FDFHDQWYhb96LpOuprFMnTRdbmrZGkW63IVLlcOi3UyLPY1knR4SQ4byWORd8WoSjiLfXlRL0bT60UVr1tquFT1Sq161blA1xOWWfS/o87nXJ3a6nacXY5sbGxUZDutHGOUxZ00o/h+d1T1sXPMchmG/cbsGG9jButy1Q2Ku7ieHtUdXremvhorke1LWnYJnNzaWHQ31t4886fq6LBMeZwOpmvuvizXUo+q3n/5v4eun3eXfs5i2xqN2jnxvNflHGzPjHBmo/zau9436zhLxwEMkiRp7czzD0CSJEnSMjInliRJ0lG3pDnxeybPt26U32ry/N45xVk61RBvSZIkSZIkSZIkSZLUjzdMnu8VceXp2CLiWsDZwOeAt8wpztJxAIMkSVoryXhasV4fi14oSZIk6QDMiSVJknTULWtOnJkXAecBNwMeuav4KcA1gBdn5mUAEbEZEWdFxC0PE2eVeAsJSZIkSZIkSZIkSZLm44eBC4BnR8Q9gXcDdwLuzviWD0/c8d4bT8r/mfFgha5xAIiIJwBnTf5728nzwyPiv0z+/ZeZ+ZuHWLZDcwCDJElaM+PRsH3HPHSEiC8AHgjcF/hKxonnSeAfgBcAL8jM0aEbkiRJkpY0J5YkSZLmZ3lz4sy8KCLuADwVuDdwH+BjwLOBp2TmJTOMc2/gbrteu8vksc0BDJIkSb1JGPWdmPYzX+6Dgd9gnEC+AfgQ8IXAtzBOCL8xIh6cmc7OK0mSpMNZ3pxYkiRJmo8lz4kz88PAw/fxvospRk7sN86O95+z3/cuigMY1I/iCxvFaKT232iKHcqo2jsU9YpqOShCls0V7UW7YrW/jEZfRh3bqnbNUdQrVe11PBZUfSkXvesy9BxvFsvdVZeYVfcHM+hjV7NYX13a6n/U5nyXbRYGHVdJtUsfjqbvEFd4Tb0XuD/wJztnWoiInwDeCnwr48EMv7+Y7klHTAKtSU9G7clQsiiLYqfWaX6VaofXsaw83HStV+jaXqtsFv0oQ3Y96BS5QjVObVl+2zyLXEfaj1F1ch7rO1HVZmw0y0ZMX26/pZL6kBlsDasLo/23twy6XoNZlv7r6Ol721v165Crwn1Gf4bD6evSn4Gtr/llJ5IkSXOS2e+jnz7l6zPzj3bfJiIzPw48d/Lfc/ppTZIkSUfdMubEkiRJ0jyZE68mBzBIkiQt3qnJ89ZCeyFJkiRJkiRJ0gJ5CwlJkrRWkv6naJsMrj0rIt4+tTzz9l1jR8Qx4GGT/762axxJkiRp2wxzYkmSJGklmBOvLgcwSJKktbNi95j7BeArgFdn5p8uujOSJElaDyuWE0uSJEm9MydeTQ5gkCRJ2p8LDzPTwjQR8Sjg8cCFwEP7jC1JkiRJkiRJ0qpxAIMkSVo7qzCVV0Q8EngW8C7gnpl5yYK7JEmSpDWyCjmxJEmSNEvmxKvJAQzav2qaley2C4jR9Jg5qOIV/RgW1QZFWcfmsopZ1IsOq7Ke5aZdGFEsXNGRqo9UMatqnWrttQz9Hn7K5S7r9X8Y7NqXbm21+z+LZZu3ea7LZbLqn92odYxYg2m/IuIxwDOBf2Q8eOHfFtsj6WjK0fT9ZHTMbbvmxHToR50eFYXFPrTzYaNjvb4PU1W8sqllOlxWy9Dh+DfvY2bV3qjz2cDyGxYnm5vlSaq0t9Njc+rrgzX+Tkman0w4dWpj0d2QBPUfALqePHU5H5j39cRVuM5XnmyuQP/XQPtc0/W/rhzAIEmS1s4yD3KIiB8HfgH4e+DrM/MTi+2RJEmS1tEy58SSJEnSPJgTryYHMEiSpPWS9P9r2p7iRcRPAU8F3g7cy9tGSJIkaSaWOCeWJEmS5sKceGU5gEGSJGkOIuK7GQ9eGAJvAh4VV72/ycWZ+cI5d02SJEmSJEmSpKXgAAZJkrRmYgZTg/US7+aT5w3gMY33/AXwwj4akyRJ0lG2tDmxJEmSNCfmxKtqsOgOSJIkHQWZ+eTMjD0e5yy6n5IkSZIkSZIkLYozMEiSpLWSQPZ8LzJvbSZJkqRVYk4sSZKko86ceHU5gEFXVn3zqllR+v7Gdo1X9XFUFEbR4FXvT36Fqp/F/Cbl4lXtNet07H9Rr2sfo3PMzoWNfhy4yqRi/4efeU8o1PoMqqmSqs+tbszDdV86b7Mz0Hl76Flzm91H9/qfGkzS+knI0fSiUeN1gFG3fWQUZ8yddrvVGXh1zK/amndZodXPzkeoWRzaluNwCfR/QaYymsExdhYxuxgVmfuwOME7RrHPWCKjchLO4dz6MW/D4nPdXJIv8mBGZ43mxJL2lMFouLHoXqhHVV64TNeedDDzzPelpdT6DnideG15CwlJkiRJkiRJkiRJkrRwzsAgSZLWjyNrJUmSdNSZE0uSJOmoMydeSc7AIEmSJEmSJEmSJEmSFs4ZGCRJ0nrJGdwb0HsNSpIkaZWYE0uSJOmoMydeWc7AIEmSJEmSJEmSJEmSFs4ZGCRJ0vpxJKwkSZKOOnNiSZIkHXXmxCvJAQzatyi+5EkUNQ++d4hREa8oyqqTVRfLoFW1aqWUDXbqSpdK9Trpv49lex116WbZi7KP8/zcZiM6fQarv9y9JyJzXrauX8ejKPexf93PeySpJYv5BSNHVcV+y4qmZpBy1aqUsly2jnl2lzody8qUvut6LvtS5O7l8avfD320IsfKUbYnjhxV30f1Ylis/83V2IRKw+JrtSzLtxHTP4PYxwmLObGkPSWMTi35JM1zT3xXXJVrzqK9WXw+Hr80Q73fTqAjrwX3ZB+fpznxalry7ESSJEmSJEmSJEmSJB0FDmCQJEnrJ3t+SJIkSatmzXLiiLhVRPx4RLw+Ij4cEScj4l8j4lURcfdF90+SJElLaM1y4qPCW0hIkiRJkiRJWnY/A3wb8C7g1cAlwG2A+wP3j4hHZ+azF9g/SZIkST1wAIMkSVo73ttMkiRJR90a5sSvBX4xM/9u54sRcTfgz4BfioiXZ+bHFtI7SZIkLZ01zImPBG8hIUmS1kvf04I5PZgkSZJWzRrmxJn5wt2DFyav/wVwPnAacJd590uSJElLag1z4qPCGRi0WD1/0aMaSVUUZXTsSHRrb6669qNz//tfJ+Wn0+mz69iRZflMod6e59eLWtfvlQ6k2g2tLTctSX3JnncoSxIvRt1i1ofuo3jA2YPHo6U2yum/1xhl9QVZHsPiO7c5x35slDuUtmFj/QNsVF+eGLZjLsk6mYVRsU425tiPFXdq8ry10F5IKyYJcquxf513+tfcFa5IHjrPbi5VHroin490GDP4BX/nv0npStJ90NpyAIMkSVozQf8n0CbDkiRJWiUzy4nPioi3TyvNzNv33OC+RMRNgXsClwNvXEQfJEmStIy8TryqHMAgSZIkSZIkaeVExOnA7wCnAz+WmZ9acJckSZIkHZIDGCRJ0vpxFjZJkiQddbPJiS88zEwLEXExcNMDVPmdzPyuRqwN4LeBs4Fzgad37ZckSZLWlNeJV5IDGCRJ0voxMZUkSdJRt5w58UXA8QO8/6PTXpwMXngJ8GDg94DvyszlXGJJkiQtjhniSnIAgyRJkiRJkqSZy8x7HjZGRBwDXsp48MJLgYdl5vCwcSVJkiQth8GiO9BFRNwkIp4fER+NiBMRcXFE/EpEXHfWcSLiLhHx6oi4JCIuj4h3RsRjJiO/W3W+OyLeGhGfjYhPR8T5EfFNe/TtZhHxGxHxgYg4HhGfjIi/jojHH2QZJUk6kjL6fUhLyJxYkiSV1jAnjojTgFcwHrzwYuChDl442syJJUlSaQ1z4qNg5WZgiIhbAhcANwReBVwI3BF4NHDviDg7Mz85izgR8c3A7zOe6u5c4BLgfsAzGd9v78FT2nk68HjgX4DnAacBDwH+KCJ+JDN/dUqdbwD+H+PP548nbV0TuA3wQOCX91q+eYtiCpak+EK3KlZTulRl1b6jqBfRcaczg31VViuzi67LNgsz6coSLV9L35/pylie79U6m8nWteSfQZooSubEs86JR1Vy23HPW9VbgRmvj2w6s0RW4SMYeYyWNEMRcTrj3OA+wG8BP5CZo8X2SotkTtxDTpzA1hx/49glqTS/kLSW3Lf1YhVOlNVJbwMYIuKawF0njy8Brg98Dvg34O+BN2Tmu3po6tcZJ5OPyszn7Gj/GcBjgacBP9h3nIi4NuPEcgick5lvm7z+U8DrgQdFxEMy82U76tyFcVJ6EfA1mfmpyeu/BLwdeHpE/HFmXryjzi0YjyT/JPB1mfnenZ2OiM19LJskSUdW0v/fAs2FtV/mxObEkiQtgzXNiZ/LePDCJ4CPAD895Qcp52fm+XPul3YxJzYnliRpGaxpTnwkHHp4ZUTcOSJezDgB/SPgxxiPHP06xqNOvw94DvAPEfGuiPiRiLhWx7ZuAdwLuBj4tV3FTwIuAx4aEdeYQZwHATcAXradlAJk5nHgJyf//aFdsbYT26dtJ6WTOtvtng48fFedJzMeRftDu5PSSd1T1bJJkiRp/syJzYklSdLM3XzyfH3gpxnnK7sf5yykZwLMic2JJUmS+tF5AENE3Doi/hB4M/DtwFuAnwMeANwZuDXwVcA9gB8GXgJcC3gWcFFE/FBEHLT9e0yez9s9RVxmXjrpy9Un7fcdZ7vOa6fEeyNwOXCXyXR2+6nzml3v2R41+yDGSf6rI+KOEfHYiPjRiPimGN/nT5IkVXJGD2kKc+IrMSeWJGlZrGFOnJnnZGbs8XjyYnt5NJkTX4k5sSRJy2INc+Kj4jC3kPhHxgnUE4CXZObHiveeDzw3xvO6fT3w34FfBa4D/PwB2rzN5PkqI04n3sd4xOytgdf1HKdZJzO3IuKDwJcDtwDePRmVe2Pgs411877J8613vPYVwNWAvwJeBvy3XXU+FBEPysy/aS3Ytoh4e6PorL3qSpK08rxHpubHnHjCnFiSpCVjTqz5MSeeMCeWJGnJmBOvpMMMYHgC8OuTqbH2JTMTOA84LyK+CviiA7Z55uT5043y7devM4M4B63TpY0bTp7vxvi+cN8HvJLxVGGPZDzt2qsj4ssy8xONuJIkSZofc+K6jjmxJEnS+jMnruuYE0uSJB1A5wEMmfmMwzScme8A3nGYGFNsD6M57AQeXeJ0bXvn+zd2PP+vzHz+5P+XAD8eEV8KfAvw/ewxIjkzbz+1k+MRt7c7YB8lSVoZAUTPU3k5Tlct5sS9tW1OLElSj8yJNU/mxL21bU4sSVKPzIlX12FmYFiE7dGoZzbKr73rfX3GOWidvd4/beTtp3b8+w+m1PkDxonpHRsxZ6vjl7z8Mjembuk8o0vXHVHfe7BDGM+gd9BKHRurFnuZ9sLL1JdO2guQHbe9WPFpj7out9bQam/K0qKYEy8yJ14WoxkcS5fp8LxMfVkB2Tqvcj1qCQ1itPeblsCw8fpG43VJc2dO3ENOHAkxnOeJuRcBpJU2i/OLZdotdFm+Ve9/V0uy3P6ZYX0NFt2BA3rP5PnWjfJbTZ5b9yw7TJxmnYg4Btwc2AI+AJCZlwEfAa4ZEdOmQKvaAPiPKXW2E9erNfotSZJgnLD3+ZCWiznxmDmxJEkVc2KtN3PiMXNiSZIq5sQrqdcBDBFxx4j4/Yi4KCJORMRwymPrEE28YfJ8r4i4Ut8j4lrA2YzvCfaWGcR5/eT53lPi3RW4OnBBZp7YZ51v3PUeMvMS4O8n//2KKXW2X7t4SpkkSdqW0e9DOgBzYnNiSZKWgjmxFsic2JxYkqSlYE68knobwBARDwIuAB7IePKQtwJvnPJ4U9c2MvMi4DzgZsAjdxU/BbgG8OLJqFYiYjMizoqIWx4mzsQrgE8AD4mIO2y/GBFnAD87+e9v7Ir13MnzEyPiujvqbLd7AnjBrjq/Nnl+2iT2dp2bAI+d/PdlSJIkaemYEwPmxJIkSUeaOTFgTixJktTZsR5jPRm4DLhvZv5lj3F3+2HGCfCzI+KewLuBOwF3ZzzN1hN3vPfGk/J/ZpyEdo1DZn4mIr6fcYJ6fkS8DLgEuD9wm8nr5+6qc0FEPAN4HPDOiHgFcBrwbcD1gB/JzIt39ev5wH2BBwDviIg/ZZwoP2BS59mZef6ea0mSpKNqFtN5OT2Y9u/JmBObE0uStGjmxFqsJ2NObE4sSdKimROvrD5vIfGlwO/OOCndHhV7B+CFjBPJxwO3BJ4NfG1mfnJWcTLzlcDdGI8Q/lbgR4BTjBPPh2TmVTbbzHw88D3Ax4EfAB4G/BNwv8z81SnvHwEPBh7DeHqyRzBOZC8EHpqZj97P8kmSJGkhzInNiSVJko46c2JzYkmSpM76nIHh44yTtJnLzA8DD9/H+y5mPE3ZoeLsqvNm4D4HrPMi4EUHeP8W8KzJQ5IkHZQjYbU45sTtOubEkiTNkzmxFsecuF3HnFiSpHkyJ15JfQ5geDlwv4g4LTNP9hhX87QkX+To2o/macgesmvF+enaxc7rckWswEdXis4b7Wo7qsutfsRoH29a832flpo58VE2OqI7n3Ve7DLZXOcF1zyMViAnHmZ74s7N5e++3E1pccyJV0UCW/3u0Ktrkat+HU9SW9e/Q8x7v7AKfy+ZxTpZ2+Xez3KtwLLrqvq8hcSTgP8Afi8ibtpjXEmSJGlVmBNLkiTpqDMnliRJUme9zcCQmZdHxA8AbwA+EBH/AXx6+lvzln21K0mSdBX+rEMLYk4sSZKWhjmxFsScWJIkLQ1z4pXU2wwMEfFfgAuA6wJD4HLGE/rvfvQ564MkSZK0NMyJJUmSdNSZE0uSJOkwepuBAfhFYBN4GPDSzNzPHaolSZJ6twr3ddPaMieWJElLwZxYC2ROLEmSlsIy58QRcRPgqcC9gS8APga8EnhKZn5qlnEi4i7ATwJ3Bs4A3g88H3hOZg67LVF/+hzl+lXA72bmS0xKJUmSpouIm0TE8yPioxFxIiIujohfiYjrLrpv6oU5sSRJko46c2JJkqRCRNwSeDvwcOCtwDOBDwCPBv4qIr5gVnEi4puBNwJ3Bf4A+DXgtEndlx1qwXrS5wwMnwUu6TGeJEnSweXk0XfMHkwSyguAGwKvAi4E7sg4obx3RJydmZ/spzUtiDmxJElavCXOiXUkmBNLkqTFW+6c+NcZXyN+VGY+Z/vFiHgG8FjgacAP9h0nIq4NPI/xbb7Oycy3TV7/KeD1wIMi4iGZudCBDH0OYHg1cLce42ldzPMEd84n012nnsno0Fa3ppZ6epwr6djPTuulqjTv9dX1g62syme+rqov+Mp8IXvWZacH67q++kpMtbzMibV4q5LPrMJufj2PRdJCjbKYDDQWPlOppH6YE6+QwVajYAZpUO/X8bR41XYyi2uwXWLOexvquk6OqHKVzOJ0rMtnMO+/O823uaVxlJY7Im4B3Au4mPHsBzs9CfgB4KER8fjMvKznOA8CbgC8eHvwAkBmHo+InwReB/wQC56Joc9bSDwBuHZE/FpEXKPHuJIkSStvHwnlZYwTSvOo1WZOLEmSpKPOnFiSJKntHpPn83bfbiszLwXeDFwduPMM4mzXee2UeG8ELgfuEhGn77UQs9TnDAwvAy5l/KvBh0XEe4FPT3lfZuY9e2xXkiTpSmb0g9mzIuLt0woy8/b7qF8mlBHxZsYDHO7MeKSrVpM5sSRJWgpOIqMFMieWJElLYUmvE99m8vzeRvn7GF8nvjX1deIucZp1MnMrIj4IfDlwC+DdRdsz1ecAhnN2/PsawFc33ufpkyRJOor6Sky13M7Z8W9zYkmSJB1F5+z4tzmxJEnSlZ05eZ42wHPn69eZQZy+2p6p3gYwZFY3MZQkSZqXgOz7rmkBcOE+R9C2rERyqMMxJ5YkScthZjmxtCdzYkmStByW9jrxvhrh8IM9u8Tpq+1D6XMGBkmSpOWwmr/jWYrkUJIkSWvCrFKSJElH3XLmxNs/ZDuzUX7tXe/rM05fbc+Uo2ElSZLmYyWSQ0mSJEmSJEnSzLxn8nzrRvmtJs+tWxEfJk6zTkQcA24ObAEf2KPtmeo8A0NE3CEz33aI+mcAN8/Md3eNoeURyzKCaRb96H16mf4nXZzJ+l+Wz3Qvq9LPnlXbUGuVzGKyz2r1O7noFDPYn6y3xvraz3pczn1DX4mplog5sa5ksCT7+a7dWJLuaz2NZpAHDZbmRLSbQZGwbCxpMqMV42akOTEnXmEZxKk1TQK7Lta8952rsPo9nqyu1vbV9TOd9wVmaS+re534DZPne0XEIDNH2wURcS3gbOBzwFtmEOf1wHcC9wZ+d1e8uwJXB96YmScOtkj9OswMDG+NiD+IiDsdpFJEnBkRj2Y8cuPBh2hfkiRplVwpodxZcMDEVMvFnFiSJElHnTmxJEnSPmXmRcB5wM2AR+4qfgpwDeDFmXkZQERsRsRZEXHLw8SZeAXwCeAhEXGH7RcnA0p/dvLf3+i8cD3pPAMD8AjgZ4ALIuJ9wMuANwNvy8xPbb8pIjaA2wB3Br4BuB9wBvBy4AWHaF+SJGmqZfxBZmZeFBHnAfdinFA+Z0fxdkL5f3YllFp+5sSSJGkpLWNOrLVlTixJkpbSEufEPwxcADw7Iu4JvBu4E3B3xjP0PnHHe288Kf9nxoMVusYhMz8TEd/PeCDD+RHxMuAS4P6M87RXAOf2tpQddR7AkJnPj4hzgUcD/x34aSYTcUTEKeBTjBPQ7fs5BzAE/gj4pcz8q0P0W5Ikabqk/6nB+ot3oIRSy8+cWJIkLaXlzom1ZsyJJUnSUlrinHjyY7c7AE9lfDuH+wAfA54NPCUzL5lVnMx8ZUTcjfG16G9lnKe9H3gc8OzMXHjmf5gZGJj8QvDnIuIXgK8Hvg74L8CXAF/AeBrk9wPvBM4HXpmZHzlMm5IkSauqr8RUy8WcWJIkSUedObEkSdLBZOaHgYfv430XMx4Aeqg4u+q8mfG16aV0qAEM2zJzBPzp5CFJkrRYCx8j2tYlodRqMCeWJElLZYlzYq0vc2JJkrRUzIlX0mDRHZAkSZIkSZIkSZIkSeplBgapsy4jn7I5SwrRdSTVvOt10F7qQ5hF/+c8mq3TZ75MI+669qXYIDptKx37MZPtsqPO3/8Oit1QaZ59XGf7WY+ua0mHMlimI9waczX3JlbgwDeYQR9HVVLm9qUZWaVfAq3ArkHSgkXCYLjoXkiS1I3XidfXKp13SZIkSZIkSZIkSZKkNeUMDJIkaf10nSZDkiRJWhfmxJIkSTrqzIlXkgMYJEnS+nFqMEmSJB115sSSJEk66syJV5K3kJAkSZIkSZIkSZIkSQvnDAySJGmtRI4ffceUJEmSVoU5sSRJko46c+LVNfcZGCLCQROSJEk60syJJUmSdNSZE0uSJGma3pLEiPi/wKMy83jxnpsDvwvcua92NT+dRxVV9TLm2Fa7aHov9hGzq6ovfbc3i3VZmMnos8Z20tXcR8it+oi8Ve//Hhwx2ZNZrMfWV38/bfm5akHMiY+A6Dcv6Www3370nI7N3yz6vwLrZN6b62AFEquqjwMTiLkYxGjRXTg63KS1IObEKyQhtlYgqZEkaRqvE6+tPmdgeATw1og4a1phRDwI+Fvga3psU5Ik6Sq2pwfr6yEdgDmxJElaCubEWiBzYkmStBTMiVdTnwMYngb8J+BtEfHw7Rcj4rSI+HXgXGAIPLDHNiVJkqRlYk4sSZKko86cWJIkSZ31NoAhM38K+AbgUuA3I+K3I+IOwFuBHwQuAG6bmX/YV5uSJElTZc8PaZ/MiSVJ0tIwJ9aCmBNLkqSlYU68kvqcgYHMfB3wVcCfA98B/DXw5cDPAnfLzH/psz1JkiRp2ZgTS5Ik6agzJ5YkSVJXx2YQ87PAvwMx+f+ngTdm5mgGbUmSJF2Vo2G1eObEkiRpscyJtXjmxJIkabHMiVdSrzMwRMRXAX8LfDvwp4ynBDsNeG1EPC0iem1PkiTpKhKi54eJrg7CnFiSJC2cObEWzJxYkiQtnDnxyuptBoaIeCTwS5OYP5GZvzh5/Q3AucATgHMi4tsz80N9taslUX1hM5pF0apXxmsXtVs6RMyuO6N5tles48pMlm0G9Tr3s2UWB5g5H7R6XycVD8hLba7bwpI4isus1WFOvGKiWw7VKV6Xso79y+rPAUXM7Ht9HEaXrnTsfsdUulbF7Hgg67ubgxU5oA7CH+n2ZcD81uXGDD63DU9MpJVhTrxaBluL7oEkSdKV9TnS9TnAvzG+h9kvbr+Yme8D7gz8OvC1wN/12KYkSZK0TMyJJUmSdNSZE0uSJKmzPgcwvAr46sz8q90FmXkyM38E+JYe25MkSZKWjTmxJEmSjjpzYkmSJHXW2y0kMvOB+3jPKyPi7X21KUmSNJUzDGtBzIklSdLSMCfWgpgTS5KkpWFOvJL6nIFhXzLzw/NuU5IkSVom5sSSJEk66syJJUmSNE1vMzBIkiQti3BkrSRJko44c2JJkiQddebEq8kBDJIkaf2YmEqSJOmoMyeWJEnSUWdOvJIcwKAr6TwSKaNbzFZZUafdUl2vjFnVG3Ws13WdNON1K+v+mXYsK8ykL3O0Kv3vfUThkqz/uZvBclefTbHLOLKjRJvr5IiuD0nzE1HtlDveha+K2UF13JhFvTpmtb6Kil36MoP+L1N7sQIH/cES9bHqyyCKEzlphQxz+racJsUARMRvAd87+e+tMvP9i+yPtHISYmvRnZAkaQ9eJz5yHMAgSZLWj8mrJEmSjro1z4kj4n6MBy98FrjmgrsjSZKkZbTmOfG66vjzIUmSJEmSJEmav4i4AfA84Fzg7QvujiRJkqQeOQODJElaL+mtVCRJknTErX9O/H8nz48Efn+RHZEkSdKSWv+ceG05gEGSJK0fE0lJkiQddWuaE0fE9wAPAB6YmZ+MaN0UWZIkSUfemubE684BDJIkSZIkSZL246yImHrLhsy8/awbj4ibAs8CXpKZr5x1e5IkSZLmzwEM2r+uo5SKes2pW6q2usTbq96oqtceyV+2V8Ts1M+O67/rOulqFu11muJnBttrpfdpiGC5+tIy5/XMLH5Y06Evc13Hy6Ra7hl8Ns3d7x7rP+j/M/I3XdI6CohBzyE77i1a9aruVW113WlV9ea8IyxS8G51ZrFsHhyOlI3iBK8qW3Ub5cmy5mGL4dTX90p31zEnjogB8CLgs8CjFtwdaS1EwmCrS8WODS7L9ZRV778OZhaf96IPivvVWoYlucZ6KKvyGagXrfP9vfLddcyJjwoHMEiSJEmSJEnajwsPM9NCRFwM3PQAVX4nM79r8u/HAncD7puZn+raB0mSJEnLzQEMkiRp/firCEmSJB11y5kTXwQcP8D7PwoQEbcCnga8IDNfPYuOSZIkaQ0tZ06sPTiAQZIkrR8TU0mSJB11S5gTZ+Y9O1b9cuB04OER8fDGe94X41ssPTAzX9mxHUmSJK2TJcyJtTcHMEiSJEmSJElaZhcDv9Uouy9wI+DlwGcm75UkSZK0ohzAIEmS1ktC9D2y1pG6kiRJWiVrlhNn5t8Dj5hWFhHnMx7A8BOZ+f45dkuSJEnLbM1y4qNksOgOSJIkSZIkSZIkSZIkOQOD9i+jWVSOYOpSVtSJUbeyzv2v2uu43HU/i7K++9H1c6t0ba9jzE5tzbEfMIMRftD/OulqVWL2LHIFOnkY81y89q6Z3JheuK9tec0/Ikn9iEFjJzQoxnm36gBEuyzLsoPXqZT1qv1u1dwMyrq0V9aZha7tFQerjh9r3VwjZnRMALvW62ow5/bmabAiScmgPEldX410c1w2v24wKi48nMrh1NdzP9vWamx+khYpYbC16E5I/WidK6xxqgl0O0da93WyCrqe23b97OZ+Lt23wyTnbu8ryQEMkiRJkiRJklZSZp6z6D5IkiRJ6o8DGCRJ0vpxZK0kSZKOOnNiSZIkHXXmxCvJAQySJGntOBWeJEmSjjpzYkmSJB115sSrqbi5qyRJkpZBRNwqIn48Il4fER+OiJMR8a8R8aqIuPui+ydJkiRJkiRJUh+cgUGSJK2f9RtZ+zPAtwHvAl4NXALcBrg/cP+IeHRmPnuB/ZMkSdKyWb+cWJIkSToYc+KV5AAGSZKk5fda4Bcz8+92vhgRdwP+DPiliHh5Zn5sIb2TJEmSJEmSJKkHDmDQlRUjkcr7xIyKeh3aiypeUUa2W+secwb1qnXZWicd6syiH4fqS2We66tjP2ZRL7JjxZ5HDc59fRVmck+qVR9luQL97/q55Ua7bNR1wXMG29GCP4PMfGHj9b+IiPOBrwfuAvz+HLslrbYAonFHvShyyqIsB0XmW928r1WvCFekvWtRr5Nl6cdhFH2Jng9ufcfbK+Zg0QfTNTIoT0TnZ2MGn+myLNu8DYvzwuM5nPp67rX+1zAnljQDCbE1vWgW12fKnKxnq95/HdxR/XiO6nKvuuLSwmyuufddcRb72Oq6SbPS3uXmxKvJAQySJGn9zCaRPCsi3j61uczbz6TF/Tk1eW5cdpIkSdKR5MVVSZIkHXXmxCupy3iWhYuIm0TE8yPioxFxIiIujohfiYjrzjpORNwlIl4dEZdExOUR8c6IeExENH9DGhHfHRFvjYjPRsSnI+L8iPimffbx1hFxWURkRLzkIMsnSZLWW0TcFLgncDnwxgV3R3NmTixJkqSjzpxYkiRp/azcDAwRcUvgAuCGwKuAC4E7Ao8G7h0RZ2fmJ2cRJyK+mfHUzMeBc4FLgPsBzwTOBh48pZ2nA48H/gV4HnAa8BDgjyLiRzLzV4s+HgN+m/IGDZIk6SpmM7L2wgXPtHAlEXE68DvA6cCPZeanFtwlzZE5sSRJ2pO/NtOaMyeWJEl7MideSas4A8OvM04mH5WZD8jMJ2TmPRgnh7cBnjaLOBFxbcaJ5RA4JzO/LzN/FLgt8FfAgyLiIbvq3IVxUnoR8J8z87GZ+Ujg9oyT2qdHxM2KPv7EJP4T97lMkiRpSU1+wZMHeDR/UTP5Rc9vM74wdi7w9Hkth5aGObEkSZKOOnNiSZKkNbRSAxgi4hbAvYCLgV/bVfwk4DLgoRFxjRnEeRBwA+Blmfm27Rcz8zjwk5P//tCuWD84eX7azl9FZuZ2u6cDD2/08Q7ATwE/A7yzWh5JknRl0fOjJxcB7znA46NTl208eOEljH/R83vAd2WmY4mPEHNiSZK0H0uaE0u9MCeWJEn7YU68mlZqAANwj8nzeZl5pemyMvNS4M3A1YE7zyDOdp3XTon3Rsb3nr7LZDrn/dR5za73fF5EXA14MfD3wC80l0KSJE2XPT/66FLmPTPzrAM8fmx3jMm0ob/LeJrRlwLfkZlb/fRQK8ScWJIk7W0Jc2KpR+bEkiRpb+bEK+nYojtwQLeZPL+3Uf4+xiNmbw28ruc4zTqZuRURHwS+HLgF8O7JqNwbA5/NzI812mDSxm6/MIlzu0nsYlGmi4i3N4rOOnCwwyq+0NEqq3YC2V4fMSzaqu4Q16WPe9Ur2itjNupVdbou20yWu+sOvHN7jcJ597Ew7/b6PoiuzPqqLEliMZNlm6eu/S8OY9XuK1rDLFd9PXYUEacxnnHhmxlfwHr47gtsOjLMifepzokDBtNjxsZGFbT3smyUtV4HyqHoRbpc7pNXot68D6az+HlFsQzlZl7Wm996WaZfnAyKpGCjsU4G5cnTfG0sUV80e6Mi8z1VpHTHG+e8bj2SOfF+VTlxJAxOHc08oouy/1XhKlzHWPUPR1J5DaH5d5Q5K69zVFbt5/g6tFUbwHDm5PnTjfLt168zgzgHrdOprxFxT+BHgCdk5rsadSVJUkPQ/9+3Fn0eP/nlzv8D7gP8FvADDl440syJJUlSaR1zYmkXc2JJklQyJ15dqzaAYS/b281hN8cucbq2/fn3R8R1gBcAfw388gHjXDlo5u2nvT4ZcXu7w8SWJElz91zGgxc+AXwE+Okpv7w5PzPPn3O/tJzMibeDmhNLkiQdVebE20HNiSVJWjsRcRfgJxnf5uoM4P3A84HnZGYxX/3hYkXETYDvBm4LfDXjmaICuFVmvv8Qi3QlqzaAYXs06pmN8mvvel+fcQ5aZ6/3Txt5+wzg+sDXH3TjkiRJE7O4H9niZ1m7+eT5+sBPF+87f/Zd0RIwJ5YkSbX1zImlncyJJUlSbU1z4oj4ZuD3gePAucAlwP2AZwJnAw+eYaw7AD/LeE18kHH+cp3OC9OwancNec/kedr9wABuNXlu3bPsMHGadSLiGOM/LGwBHwDIzMsY/0LymhHxRfts43bA1YALIyK3H8AbJuXfOXnt71sLJkmS1k9mnpOZscfjyYvup+bGnNicWJIk6agzJzYnliTpyImIawPPA4bAOZn5fZn5o4xnRPgr4EER8ZAZxnobcFfgOpl5S+Adh1+qq1q1GRi2E7R7RcRg572fI+JajEeCfA54ywzivB74TuDewO/uindX4OrAGzPzxK46D53UecGuOt+44z3b/h/jD363L2I8bfRFjH9Z+aFi2SRJ0hKMhJVmyJzYnFiSpL2ZE2u9mRObE0uStLf1y4kfBNwAeHFmfj5XyMzjEfGTwOuAHwJeNotYmfkvwL/0sSCVlZqBITMvAs4DbgY8clfxU4BrMF7JlwFExGZEnBURtzxMnIlXML7v9EMi4g7bL0bEGYynygD4jV2xnjt5fmJEXHdHne12T7AjYc3Mp2bmI3Y/gF+avOUtk9eeepWVI0mSPi+y34e0TMyJzYklSdoPc2KtM3Nic2JJkvZjDXPie0yeXzul7I3A5cBdIuL0Ocfq1arNwADww8AFwLMj4p7Au4E7AXdnPM3WE3e898aT8n9mnIR2jUNmfiYivp9xgnp+RLyM8X1A7g/cZvL6ubvqXBARzwAeB7wzIl4BnAZ8G3A94Ecy8+KuK2KZRFVYfaEbZTFqR4xRs6jeeRRlXWNW9Tq31yqb83KX9bIoLOt1ba9bvd7bWqKYld4Pop370bHinJOAZVlfs7AkCRWjjaJwoziCLEn/pSVlTnxYAbHR2EENin1Tqw5AtOvloBg73mqv2kUWbdX12mWVst4c2+vaj+qg2LWP9YlCx5g9i47JwGAGSUTVl6q9WfSl3Vb7BGme/TiMjerE8YjaWJKk8lS2P5vjRdmJRve7nm5Ja8acuAeDrUW0qiNvFvly69i4JLm5NGtZnLPM83SmPMceFB0prsUsYe57VkS8fVpBZt5+xm3fZvJ8ldtkZeZWRHwQ+HLgFoxzmnnF6tVKzcAAnx8VewfghYwTyccDtwSeDXxtZn5yVnEy85XA3RiPOvlW4EeAU4wTz4dkXvUrlJmPB74H+DjwA8DDgH8C7peZv7qvhZYkSQeTPT+kJWNOLEmS9mROrDVnTixJkva0fjnxmZPnTzfKt1+/zpxj9WoVZ2AgMz8MPHwf77uYYnzdfuPsqvNmxvcZO0idFwEvOkidXfXPx3GCkiRJ2sGcWJIkSUedObEkSVqACw8z00JEXAzc9ABVficzv2u/4SfPfQy36DPWgazkAAZJkqTKiszyLEmSJM2MObEkSZKOuiXNiS8Cjh/g/R/d8e/tWRHOnPZG4Nq73lfpM1avHMAgSZLWyyym81rORFeSJEmazpxYkiRJR92S5sSZec9DVH8P41tf3Rp4+86CiDgG3BzYAj4w51i9Gsy7QUmSJEmSJEmSJEmSdCCvnzzfe0rZXYGrAxdk5ok5x+qVAxgkSdLaiez3IUmSJK0ac2JJkiQddWuYE78C+ATwkIi4w/aLEXEG8LOT//7GzgoRcWZEnBURX3TYWPPiLSS0f9UXsyirvtAx6q8OAEVZVa9sb9gxZtd+NvrSPV574cqYHT/TWWwnnep1bavSsV71Gcyknx3aqsx7fVVmkiBUn08HS5LEjM2xL1kMiYxBtMvm+R2QpN2isX/a2Dh4HYCNYmdYFGUjZG4UbRVFWex363rtsrJeUVbV61RW9aMIV7fVrpmzOBh17Eu16UWHfnaps5fBET14z2K5B+XJ2mrbqE5gOxosyb0NTmV72U4V5x3Hi+6fbOycs9yZSNL+RMJga9G9kBanPJeRVszSbM5dry10/bvTEZOZn4mI72c8+OD8iHgZcAlwf+A2k9fP3VXtgcALgBcB33PIWETEC3f896zJ8y9GxKWTf/9mZv7lIRbTAQySJGkNmdRKkiTpqDMnliRJ0lG3hjlxZr4yIu4GPBH4VuAM4P3A44BnZ+7/V5sdY333lNe+Zce/zwccwCBJknQla5iYSpIkSQdiTixJkqSjbk1z4sx8M3Cffb73hcAL+4g1ef//3969h8tSVnce/63qvc8BjaASHI1GUCJgxsxF0CTgBWEkakBkxNF54gxqTGLi3TiZRLygE6O5eMMkGo0KxgvGG2RUjBE8aiRRg4PXgIIco4A3QLkezt5da/7o2rLPPv2u7n67qrur+vt5nnr6nF693nrr7e6q1XXeU9X4BT+iC3kAAAAAAAAAAAAAAADMBFdgAAAAnbOkt+AGAAAAfoKaGAAAAMuOmriduAIDAAAAAAAAAAAAAACYO67AAAAAusVV/73NmKkLAACANqEmBgAAwLKjJm4tJjBgT26ZeUGszFhflBPEbNaxfv1tpsbSyvQg172uUbHokju56wsv4xPmJYKNrCvIi2Tmxf2cvNGF6n+uBtrM+Qy1Rfh9zODBdZvK1QaOH7mfPQXva6bMrQOwwEwm6/USweBb3wt2hlFeEeT1hudFpbknuj4yL+pjA3lxmxl5Tawrkrm+RTlwZG92UMgVXH9zIr26C7Ip9DLeuyL8cb6cohHZHdSga8Hw7woK7VsTO/xR7ww1MYCxuKuIdlAp0Q6hDaVCEzu03O2uuy+L0o+OC38fAUsgOk8c/jaf8b/NUBO3F7eQAAAAAAAAAAAAAAAAc8cVGAAAQPe04X98AAAAAE2iJgYAAMCyoyZuJa7AAAAAAAAAAAAAAAAA5o4rMAAAgM7h9twAAABYdtTEAAAAWHbUxO3EFRgAAAAAAAAAAAAAAMDccQUGAADQPcysBQAAwLKjJgYAAMCyoyZuJSYwYHyZX/Lo8ixWTvb8yPYy1iVJ1s/My4310x3NGRPl9iN6T7PHOQhmtpmVl72u4L1pYLxC2d+5jMTM705um7mytk2qvy8zLnpmfZkrt0RgJRVYMN7AmFHoAt1jJvV6w2Op5yWpSF/EzqNYL70PdRse82LyHElSEPLoGnzRbj7Ii9rMXV/qWJQ8Ro1oLzsWCdsMasooFjUZthkkJgQfr0YUQf+L4EAb5mW02cttj+uOLp3UaYK14DfJWvAx2eXpY8tasLPc5cNP3fmonRc1MYBxuFSsz7sTWHgtOR00S05tiGWR+P6XwY4hKHvzZfw70EacmriduIUEAAAAAAAAAAAAAACYO67AAAAAuoeZsAAAAFh21MQAAABYdtTErcQVGAAAAAAAAAAAAAAAwNxxBQYAANA53IoQAAAAy46aGAAAAMuOmridmMAAAAC6h8IUAAAAy46aGAAAAMuOmriVuIUEAAAAAAAAAAAAAACYO67AgFqEl2BxC2ITPj8iZmUDsX5um+mO5rTZyLYFfcwe59z3Llzf5P3MvixQ2Me89zR3hl+0vlDO9yrsR16ecvsfCPsSfU5m2Y9cM/6ceJHeN5erw+c3lsG0x2hXn22KzzKXBgMwkknqDd+xWZHe4XkiR5LUS+8Mo/1uMhbtd2cdi/bzUbmfmZfckTeyrtxYUBvmtlmzooEDYtRmE+trg170AylQZOb1lJcXt1nve1d3e1Izn69+0GTqJ95a8CXe5b1kbC3Yya4Febs1PFaOsTNZ0q8kgAmYS8U6OwuMMMP6ddZyz2cVLfnaNHK+Dt0T/IAt02Vq/d0IznP7FDsiauJ24goMAAAAAAAAAAAAAABg7rgCAwAA6Bb3+q8A0sAVRQAAAIDGUBMDAABg2VETtxYTGAAAQKeY6r80GFfcAwAAQJtQEwMAAGDZURO3F7eQAAAAAAAAAAAAAAAAc8cEBgAA0D1e8wIAAAC0TUdrYhs41cx2mNm1ZnaLmV1hZn9rZofOu38AAABYIB2tibuOW0gAAAAAAAAAWHhmto+k90o6QdKlkt4l6QZJPyPpwZIOlfT1uXUQAAAAwNSYwICxNXFfl9S9Z6wMcoKYorx+ZixsMz3dqgjaDPuZiEXtWRlM+wpCueMcrS+8n1BuX3zy7Qs/J1E/MtY1us0oL3MsI4n3J7u9zLxwLBdpfdFnJUduPwK5750X6T23rwaxVKhFN/gK9wEAIEkyqdcbHko9L0lF+iJ2vhLEon1yIi0nZy6xzONDzvrCdeUeMHOPbw30xYI8C9YX5eXkFJn9L4JCLrdNTKbX8iKo18B/aeoHX9boZ/taYkeUel6SdgcXOl3z9LFlzdOn53Yn8nyMnW/LPw4pr9Jg8sIrJL3Q3ffYSjNbnUuvgLZyqVjnGA3l18TRx6dF55EwHo9+lCyQ3PPEbdm+LMGmlb3oHzcSiTMequS/JY6T282auPOYwAAAAAAAAABgoZnZIZKeJunzkk5z3/tfJ9x9beYdAwAAAFArJjAAAIBuaeJ+ZAv4H1LM7C2SnlL99T7uftk8+wMAAIAF0lxNfLiZXTQ07H5EzWvc6r9LKiSdJWk/MztR0s9KukbSBdTDAAAA2MOSnCfuIiYwAACAzun6Vaqrk7VPkXSjpJ+ac3cAAACwgDpYEz+getxf0uWSDtgUczN7g6RnuXt0dxAAAAAskQ7WxEuBCQwAAAAtYmYHSnqzpPdIuqukh863RwAAAFgil8zgSgspd6keXybp45KeL2mnpAdK+itJvyPpB5JOn0PfAAAAANSkmHcHAAAAaude77JY3lQ9Pn2uvQAAAMBiW8Ca2Mx2mplPsLxjU3qverxa0snu/hV3v9HdL5B0iqRS0vPMbFstnQUAAED7LWBNjNG4AgMAAEBLmNmTJD1GgxO215jZfDsEAAAATOZySbsmeP1Vm/58XfX4UXe/ZfOL3P2LZnaFpEMk3VfSF6fqJQAAAIC5YQID6hFMOgrvL5MxWcnKGcf66U4WwV0VLTeW6IuV6X7kb3cDbQYz0KLtDj9DQT9TefHnLuhjlBeNV82f80Gbk2+3FH9m0+3VP3Mw9z0INTGWOaLPZNiPershSd5L/wO2W3ChpejfvRMxj/6xPIj5HP6NvaF7mx1uZhcNC8ziMrpmdpCk10l6h7uf0/T6gM4zyYrEfrIX7D+jWKo9SYr21yvD87w39OlBrAjaC2LR/j/cz0fX7gtiHuVlHIuyciR5kT4weHTQCGNBXwLh3LNgfZYRi3IiYRcbOMgWwQ+MIlhfTl4RFJQ9BT90MkXri/SCvGhM4jbr3b6igfHKVQaf2jIoRteCnVQ/0eZasHPerXQsyusH/VhLtDnOp2AR7/fr7sdNkX6ppOMl/SgR35jgsO8U6wCWirlUrC3gzgLLLSpGcz6u/N+PGnV9f7EY2xf+No8EaeVK3nndLljEmhijcQsJAADQPV7zMmdmVkg6S9KNkp415+4AAACgDTpWE0s6v3q839aAmW2XdJ/qrztn1SEAAAAsuO7VxEuBKzAAAACM55JprrRgZjslHTRByjvd/YnVn58r6aGSftXdrwtyAAAAgK46T9I3Jf2KmT3c3f9hU+xFkvaX9El3/+5cegcAAACgFkxgAAAA3eINXBqsnvay7vdrZveR9HJJb3P3j9TSEwAAAHTb4tbE+at3321mp0r6mKTzzOyDkr4l6QGSHiLpB5J+c45dBAAAwCLpYE28LJjAAAAAMANT3O/330vaLunJZvbkxGu+YYP71Z3s7udkrgcAAABYaO7+j2Z2pKSXSHqYpDtK+p6kN0n6P+7+nTl2DwAAAEANmMAAAAC6xzs1FXanpLckYr8q6a6S3ivpenG/XwAAAGzoVk38E+7+NUmPn3c/AAAA0AIdrYm7jgkM2EN4KZUgZmWQF8RSeVF7Yayfm5feuGI9b31F2Jf0+lJtxmMStBfkFcF2R9sWfxaCYGZe+LlM5IXjFR2woj5GedF3IBK0mTuWyfbC/ucdxLMvvxS+B5mN5r4HCeF4RRooiHylCGLpQ3mY17N0rEjE0inyIBbKzRvRZN2XBmugm2Nz94slPXVYzMx2aDCB4QXuftkMuwV0gEm93vBQ6nk1sG+V5Ikmc3JGxtKbFseiY0CwvvDYUaR31sk2G+hHGIvajITrC+q/IM8yDm5RTlH7dTTz1xfGgsK318A2JNcVFJtRH+M2OZG2VT/48vSCHdFa8GWN2iyDHcduDd8phjnBjrQM+piT5yMq1K7VxACaU6xn7CwyzyPFHVmQvUwT25ZrUcak5bLPWQFzEv0ujH/vZ55DyDjnm5MzD9TE7ZV7OgYAAAAAAAAAAAAAAKA2XIEBAAB0zwL9hwkAAABgLqiJAQAAsOyoiVuJCQwAAAAt5e7HzLsPAAAAAAAAAADUhQkMAACgc2Z4S2wAAABgIVETAwAAYNlRE7dTMe8OAAAAAAAAAAAAAAAAcAUGAADQLS6prHlqLTN1AQAA0CbUxAAAAFh21MStxQQG7Cn64oUxS4bCy7MkYlamU7Jj/XRHin6Ul47FeZnrS2xD1F48JkE/1oM3J2ozSIvWF21D9PkK2/RELOi/Ujka9XmN3oNoLOtfXxiLtj3Zj8x1RXLzws/ejPtSd3uW3lf6SnBRpCBPRdBmECt7QV4v8XzQDeXGIqm8cdqjkAQwiklaGb7D816wTy7SsSgv3O8m9tdlYn88WFcQC7rfSCzYL+fmpfb1XkRF4+TtjY5F6wtqvCgWrS7z2pY5h9poXUVmbJEU0Y+kGerNuB9Fzo+BwKz7XwY7jV3BRUT7wbegH+RF69ud2NGWmf1Y8/QpuH7Qj1SbPs43vx1fVwDzVLqK3YtxzMzaaeWeb2jN/rHmjuaOV0t44vxZFzY7+5xohtQ4ombR7+jw9/7k53RHrS8r1qaPSWv2+diMW0gAAAAAAAAAAAAAAIC54woMAACgc1ryn0MBAACAxlATAwAAYNlRE7cTV2AAAAAAAAAAAAAAAABzxxUYAABA98zw3oAAAADAQqImBgAAwLKjJm4lJjAAAIBu8QYuDUadCwAAgDahJgYAAMCyoyZuLW4hAQAAAAAAAAAAAAAA5o4rMGBs0SylcAZTGeQlYqnnJcn6s40VYV56w+vOszKdY+vBuqK8aJzX08EwL1pfdKmeYEyiNlOz3cJ1hX1Mp6kMNjwak6gvubFgfbPtR+Z0w9zLNs0wL/rceWHpxCKYG7jSS7fZS8fK1SBvJd2XKBZOYUykeZDjwarcgj4GeVNhJiyAUczkqf1ytL9eSe8M431ylJd4PjjehLF090ccw4K8sM10LDze5BxXwuNNsK4wFv3QCUJFZl6wvuCQGcaKRJvR2x1JtTdVLDg4N9Fmur2MQnoO2tLPHGupnZ6ktSCvH3yx+uGOKK0MdkSp9UX9j/oR9b8M84bHxvr0UxMDGMFcKnanTkY29YMdTWrsPEsLLPGm12rm45i7r4nO9y7I/st70e/2zN/7TcQyz+sm5f42b0pHa2IzO0rSCyX9kqR9JF0m6a2SXu/uwb9QTteWmR0t6SRJD5N0sKT9JF0l6XxJr3T3y/K36jZcgQEAAAAAAAAAAAAAgAVnZidJ+pSkh0j6oKS/kLRN0msknd1wW++X9LuSdkl6p6TXazCB4dclXWxmvzz5Fu2NKzAAAICO8fiKI5ltAgAAAO1BTQwAAIBl172a2Mz2k/RmSX1Jx7j7v1TPv0jSBZJOMbMnuPvIiQyZbb1G0t+4+1Vb2nqBpJdLepOkX5hyM7kCAwAA6KCy5gUAAABoG2piAAAALLvu1cSnSDpQ0tkbEw4kyd13aXAbCEn67abacvc/3jp5ofLHkm6RdD8zO2DM9ScxgQEAAAAAAAAAAAAAgMV2bPX40SGxT0m6WdJRZrZ9xm25pPXqz/0xXh9q5QQGM7uHmb3VzK4ys1vNbKeZvdbM7tR0O2Z2lJl9xMyuNbObzexLZvYcM+sFOaea2efM7EYz+7GZ7TCzE4a8btXMTjazt5jZV8zs+modXzazl5nZHSbZPgAAlpG5ZO41L/PeKmBv1MQAACCFmhjLgpoYAACkNFgTH25mFw1bZrBZh1WPX98acPd1SVdIWpF07xm39ThJd5D0z+7+ozFeH2rdBAYzO0TSRZKeLOlzGtxr45uSni3pn8a9LEVOO2Z2kgYzTh4i6YOS/kLStip36L1EzOzPJJ0p6W4a3EfkHRrc++P/mtkztrz8EEkfkPR4DT4Ub5D0Nkn7SnqRpH8xs58eZ/sAAADQXdTE1MQAAADLjpqYmhgAgCW0f/X440R84/k7zqotM7uXpNdrcAWG3x1jvSOt1NHIjP2lpLtIepa7v37jSTN7taTnSnq5pKfV3Y6Z7adBYdmXdMzGvUDM7EWSLpB0ipk9wd3P3pRzlAZv1OWSHuDu11XP/6kGRfGfmdmH3H1nlXKDpKdLOsvdb9rUzjYNCtZflfQSSc8cY/vqF820D+77YhkxCy4uErVX9NOdDNsMY+k2i/VkKL8v5fC8Yr3e9iTJojajvGjbgjyFbabf2LBNT8TCz10QTLU3qs0oLzcWbXck1WZmP7LGf1QsVxPjlVJYMmRK/mcKeS+d56tB3mp6TmHUZtkL8oJtyIpZOkdBKIw1hf8dhu6jJq6jJu4N3y9H++syioX75HQ3ysR+3tOrUhnEonU10WY0Ld6DY0AUSx074n6kd/4exLKPYdFhMVxfUHdlxnJyigX6r9RN9KWX0WbUjyjWi36khuvLy+s1cOPVnG0ogy//rvDLmtbPLBz7meuLtiHVZtTHMuhHP1xX0GYiz8cZq8X5mgNNoSaetiZ2V7G2GDf0zhHWk10WnrPqgNxzfMG4dJlH5+syhOe5Zyx/22rehuh3bfS5C/ofnkPO/E1f9+/vKNbE/rfuz/JtDTfS6iXufkRuspntlHTQBCnvdPcnjtt89VjHlo9sy8zuIuk8SQdKerq7X1jDett1BQYzu7ek4yXt1GBW62YvkXSTpP9hZrdvoJ1TNBj8szeKUkly912SXlj99be3tLVR2L58oyitcjbWu12Dmb0bz1/p7n+5uSitnt8t6Y+qvx4TbRsAAAC6jZpYEjUxAADAUqMmlkRNDABAW10u6dIJlqs25W5cFWF/DbffltdFpmqrmrxwgQa3oni2u//lGOscS6smMEg6tnr8mLvvMTXU3W+Q9BlJt5P0Sw20s5Hz0SHtfUrSzZKOMrPtY+act+U1o6xVj8H/+QcAAJIGV+uocwEWCzUxNTEAAKNRE6PbqImpiQEAGG0Ba2J3P87dD59g+b1N6ZdWj4dubdfMViTdS4Ma4ZtjdCW7LTO7m6Qdkn5egysvnDHG+sbWtgkMh1WPX0/Ev1E97jXQNbSTzHH3dQ3uRbYi6d6SVM3KvbukG9396in6uuEp1eOwIncvZnbRsEXS4WOuDwCA1jKvdwEWDDUxNTEAACNRE6PjqImpiQEAGKmDNfEF1eMjhsQeosHEywvd/dam2jKze0j6pAa1xNPqvPLChrZNYNi4hEXqshcbz9+xgXYmzamrrzKzR0v6LUnfkfQno14PAACATqMmpiYGAABYdtTE1MQAACyj90n6oaQnmNmRG0+a2T6S/rD66xs2J5jZ/mZ2eHXVhGnbuqcGkxcOkfTr7v6m6TdpbytNNDpHVj1OOwcmp53cdYevN7OjJL1Lg/utPXbzPdLCRt2PSLR3kaT7T9hHAADahUvcYrlRE280Sk0MAFhm1MRYbtTEG41SEwMAllnHamJ3v97MfkODyQc7zOxsSddKerQGV4l6n6T3bEk7WdLbJJ0l6UlTtvVJSQdLukjSQWZ2+pBununuO7M3Uu2bwLAxG3X/RHy/La+rs51Jc0a9ftTMW5nZL2twD7RS0iPd/XOp1wIAAGBpUBMDAABg2VETAwCApeTu55jZQyWdJumxkvaRdJmk50k6w338WRsZbR1cPR5RLcPskLRz3D4M07YJDJdWj6n7gd2nekzds2yadi6VdGSVc9HmF5vZiqR7SVqX9E1JcvebzOxKSXc3s7sNub9Z2Fcze7CkD2tQlP6Ku//ziG2qR/SRDmLRfV/CWDnZ85Jk/XSD1k/nFVFsPd1mmBf0JWoz6mdq+6LtjteVGSuDNy6IWT/95oVthn0JPhCp8Yr2z1F7UR9zZ+pFeUEsHK+cNsMxqXldUjzOizTrcSVxKLT0XZZ8pZeObU8fWn01yFuJ1hfFLB0LbhSVEwtz0t0IY8qNRTw+juS2CSwQauIauJl8dfg+23vB/roX7HeDfXK5GuQl2iyjdQX75Ny88AaD0X4+PKYEO9CcvCaOKWEsqNWiWNRkEAzbzIgV2X0MfnsEB8VofUXmwTk3L91eXv/z11d3UdKMfvKLnK5t12bajxF5mYVjGayvn3HX1X5Q+JZBe9F2p/pRhkW2qImxDKiJ6+CSrQUnKhdc7mmDiEfFGvY265uUR8e2tt0wvSZW92d2gc7bZm9Z/KMrGUr9Nvci+HAFv7+j3+bx7/bcWDKU/5s+ldfEOd0mdLgmdvfPSHrUmK89U9KZNbU1k3e4bbv0T1SPx5vt+S9LZnYHSUdLukXSqCIup50LqsdHDGnvIZJuJ+lCd791zJxHbnnN5j4cq8GM2nVJD5/Z5AUAALrCvd4FWCzUxAAAYDRqYnQbNTEAABiNmriVWjWBwd0vl/QxDS5P8fQt4ZdKur2kt7v7TZJkZqtmdriZHTJNO5X3SfqhpCeY2ZEbT5rZPpL+sPrrG7a09cbq8TQzu9OmnI313qrBPUe0KXa8pA9J2iXpOHf//NZxAAAAwPKiJgYAAMCyoyYGAADorrbdQkKSfkfShZLOMLPjJP2rpF+U9DANLrN12qbX3r2Kf0u33ZMjpx25+/Vm9hsaFKg7zOxsSddKerSkw6rn37Ml50Ize7UG9wn5kpm9T9I2SY+XdGdJz3T3nRuvN7PDJJ2rwf1FPiLpJDM7aesAuPvpI8YIAIDlxmRYdB81MTUxAAAxamJ0HzUxNTEAADFq4lZq3QQGd7+8mtn6Mg0uufUoSVdLOkPSS9392qbacfdzzOyhGhStj9WggLxMg8LzDPe9rx3i7r9rZl+S9AxJv6nBXZq+IOlP3f1DW15+t6pNVe0/NtH908fZRgAAAHQTNbEkamIAAIClRk0siZoYAAB0UOsmMEiSu39b0pPHeN1OSTZtO1tyPqNBETtJzlmSzhrjdTsU9BcAAIzDZbXfj4ypulg81MQAACCNmhjLgZoYAACkURO3VSsnMAAAACS5pLoLU+pSAAAAtAk1MQAAAJYdNXFrMYEB9Yi+sEHM+pM9L0nFem4s3ZEiXF+QF8Qssy+2Xg7P6Qc5ZdReEOsPX9cgFrxx5eLkKbXtUU5wwIrGJDzQRbHg/ck+ePaDD22izSFXL7xN1MeIZ45XJOpLEfzng6KXDNlKOqZEzLetJlPC2Gp6XWUQ814RxNLb7cGYZMcSodTzkuL/FxLEojbD9QHAtMyS+2xfDfbJQaxcCfatwb68TBwePDh8NRJLb1p2TFFedAxI5HmRrhOimCyqL4LaMGwzCAXrK6L1RW2mQ8n1hf3IjOUK1xf8aOzlbkOizZ6C+jXQs7y8RdIPvpD9xJeuF9X7Mxb1P8zLLCrLxPpSYzWyH0H/y6CPqTzOmwKog7nL1oJzTEso91SER4Uc9hYdThel/Mg75GNWgu+cF8GbF/1uT5wvjc6jlpnndMPfypm/2+MxCdrM/SGagfO9GBcTGAAAQPcsyo9dAAAAYF6oiQEAALDsqIlbiTlkAAAAAAAAAAAAAABg7rgCAwAA6Byr+95mAAAAQMtQEwMAAGDZURO3E1dgAAAAAAAAAAAAAAAAc8cVGAAAQPcwsxYAAADLjpoYAAAAy46auJWYwAAAALrFVX9hSp0LAACANqEmBgAAwLKjJm4tJjBgDxbFynTUyihv8pj103sA6wftBbFiPYql1xfG1oJ+5ra5nhiUcEwy2pOkMh2L2lTQpgVtqp/Xl+gAY6k2o/bKYNuig1k/+IAFeR61GfYlb0ySbUbtRf0IhNsWMAv2NkUQs/Rhy1Z66bzt25Ih37Y60fOS5KvpdYWxXnrbfCUdK4OYB5sdxoKbSHnqPQjeGg/eU48OLgAwLyb56vCdYbQvLxM5g1jevjwVK4P9ePaxIdz/B7GwzaAOylxf8pgT5eS0N0UsKmdkQf2aGSvCWNCXmuX2sQlF9GMzQ0957RUzPoO1Fnwh+8EXoRf9Hkjl1DzGTemHO5TMNhNjWWYWt9F7U2b1nyIbQA3cpbXgpOkiyP2Hp7BYq99M1zbjbVtasyyyuy76zIbnFIO84DexgnOw5Uq67vJe4hxB9Ps7/G0exILPVxxLhuJY5u/eVF7UXhPngpP9qH9VWBD1/8IDAACYt7LmZUHYwKlmtsPMrjWzW8zsCjP7WzM7dN79AwAAwALpaE0MAAAAjI2auJW4AgMAAEALmNk+kt4r6QRJl0p6l6QbJP2MpAdLOlTS1+fWQQAAAAAAAAAApsQEBgAA0Ckml9V8bzNbjAuSvUqDyQuvkPRC9z2vA21m6fueAAAAYKl0uCYGAAAAxkJN3F5MYAAAAN1Tc2E6b2Z2iKSnSfq8pNPc995Ad1+beccAAACwuDpWEwMAAAAToyZuJSYwAAAALL7/LqmQdJak/czsREk/K+kaSRe4+2Xz7BwAAAAAAAAAAHVgAgMAAOgWV/0zawfNHW5mFw0Nux9R7wr38oDqcX9Jl0s6YPPqzewNkp7l7v2G+wEAAIA2aK4mBgAAANqBmri1mMCAPQVfPIu+lFFe8E8pVg5/vohygljRT3fEglixHsTWgjYz84p+YsMl2drwmK0HOVF7wXYrarNMx7QevAlBXtTPKE9lsA2pvH66j0OuvD7muqLtDvI8vW2eOyaR1PYF7YVjEjCzdLDXS8dWg8PP6rb0+ratpvOCmAfr80Ser6b776tFOtYLYivpWNlLj6UXmbGwzWRISqRFOTntTRVbPnepHl8m6eOSni9pp6QHSvorSb8j6QeSTp9D34B2Mkvu68tgP1+upHdOcSzdlVTMgxwPDrPZsdz9fHZeuv5I5uUeG4J1WRQLfgTFsXRX8tucPFYEOY3Egh+GTbQZKRI/NqN1NaEMvgRlsG3RfaHK4EtXKF3zrym9A+gl8tainUagiXEuvf7isB/twJL9mDxnsK68/qfWx3lTALVwl+1ekLsRpgqo3H94igqytuvyti2Q6JybReeCZyzqZ+3iHzrpWHC+NMwLzqWG51mj87rR+dLEb/pmztsmQyPOswZtZp5nzSqzcz92nAvGmJjAAAAAuqeZe5tdMs2VFsxsp6SDJkh5p7s/sfrzxs+aqyWd7O63VH+/wMxOkfQFSc8zsz9y9925fQQAAECHcL9fAAAALDtq4lZiAgMAAOiezAuYNOxySbsmeP1Vm/58XfX40U2TFyRJ7v5FM7tC0iGS7ivpi1P1EgAAAN2wmDXxVMxsu6SnSjpV0r0l7SPp25L+QdKr3P1bc+weAAAAFk0Ha+JlwAQGAACAGXD346ZIv1TS8ZJ+lIhvTHDYd4p1AAAAAAvLzFYknS/paEmXSHq3pFslPUDSMyX9TzM7yt2/Nr9eAgAAAJgWExgAAEDnWPcuDXa+Bidl77c1UP0vtPtUf905wz4BAABggXWwJj5Zg8kL50s63t1/8v/pzOylkl4s6fmSnjKf7gEAAGDRdLAmXgrFvDsAAACAkc6T9E1Jv2JmD98Se5Gk/SV90t2/O/OeAQAAALNx7+rxw5snL1TOrR4PnGF/AAAAADSAKzAAAIBucR8sdbc5R+6+28xOlfQxSeeZ2QclfUuDy+U+RNIPJP3mHLsIAACARdLBmljSV6vHR5rZ67ZMYjihevz4jPsEAACARdXNmngpMIEBe4q+d1vntm9iubH+8BVaP51TJHIkqVgP8qLYWrpNWw/WF+QVa+kNt/V0rEjFghzrpwcsWpfWg4Euo/XV32YU8ygvte3RQSQYL5XpPI/ygvWFecH6tNd/KNkcmvwgaYVFwXSoF1ysZ3U1nbctiAV5UZtaTR+2PDvWSzyf3u5UjiSVUV4v/R74SmZeuivy4K3z4POQynOLPkPBuoJYdt4Scvd/NLMjJb1E0sMk3VHS9yS9SdL/cffvzLF7QOt4IZXbhu/won15uS29cypX8mKeOEyFOdH+P/fYEOYFtU72sSgdU2J9UT9SOZLC440s+C0Q9NGCvCLoS+bhNF5fIpbdXvDDMLWuQSz4nZOZF+kFbc7SWvAlKIN3oR98CXrhWKZjveB3SZS3puHb0AtPEgQW460ZqR9+SyZXhju2uvsxt2L5cDO7aFjA3Y9oeN0flvQBSf9V0pfN7OOSdks6QtKDJL1e0p833AegW9ylteCkaVdFBVnbdXnbZqwtIxn2M3X+L/qcFHnnKKM2vRf8aIzOiQaxMjg/m30ONjFe8XnbZGjEb+XJz81OFcv+IVpjDjABJjAAAIDuyZjk0wbu/jVJj593PwAAANACHauJ3d3N7BRJL9bgNmo/vyl8vqR3uXvwPwgAAACwdDpWEy8LJjAAAIDu4VJeAAAAWHbN1MSXTHOlBTPbKemgCVLe6e5PrHL3kfR2SY+U9HRJ50q6WdLRks6Q9Ckze5y7n5vbPwAAAHQM54lbiQkMAAAAAAAAAGbhckm7Jnj9VZv+/PuSHifp2e7+V5ueP6+6MsPFkl6nwcQGAAAAAC3FBAYAANA9zKwFAADAslvAmtjdj5si/YTq8RND2v2imV0r6SAzO8Ddr5liPQAAAOiKBayJMVox7w4AAAAAAAAAwAjbq8cDtwbMbLuk/aq/7p5ZjwAAAADUjiswAACAbnHVP7OWiboAAABok27WxJ+WdD9JLzCzz7j7rZtip2twnvPz7n7DPDoHAACABdPNmngpMIEBY7MyM9ZPx4r1yZ4fHUvvOYq1dMwy84rd6Y0r1tODYlFsbXibUY7Wg0Hup2MW5gXrK4NYsD4P28zbhmSbTfTR0zEvg6NWkJd98DRLh3q94YHU85JsJX04sG3b0v0I81bTeavpPF9J9zPMW03nebDtvjr8YkRheyvp8fdeOlaGeclQHCuCNtMheXANpmRe1F4Qy87L5lL0ncxtE0C3mKm/ffgONtpf91eD/Xxw6OsHsTJxeIv2/6kcSSpzjym99L4uzIv25UXQZnQ9wFQsc11RzKI8y8uzKC+IFWEsGUq2GbdXfx/bYC36MEeCkj4akzL40BZBfRHmBV+eMvpxHmx7kchbS7emXsfro364w5lcGe70gn4k8kb/lOxkTfxySSdKOk7SJWb2UUm3SDpa0gOrPz97ft0DWshdfuuto19XF2vBBaGjomtJWXAeEjWKxrkIvjvh+5OIBTneC9YVnLeNz78GNfhKUNsGsegcrGfmpc4FhOdRo3OzYSzdZvj+ZJ6DzT0/m3PuNm4v+mE7+bpG62RNvBRaUDEAAAAAAAAAWGbufqWk+0t6laRdkp4s6RmS7irpTEn3d/d/mlsHAQAAANSCKzAAAIDuia58AgAAACyDDtbE7v4DSc+vFgAAACDWwZp4GXAFBgAAAAAAAAAAAAAAMHdcgQEAAHTP6JsCAwAAAN1GTQwAAIBlR03cSkxgAAAA3eKSypoLU+pcAAAAtAk1MQAAAJYdNXFrMYEBe7Dgi2fBbWKsn44V6+lGbX3ynGItiO2O8tIb0NudjlmQV+xOb3iUZ/0oLxFbD3KCWJSn9cQbIMnL4A0P+q9+Xp6HbUZ5ifUF9zUK1zXr2XhFLxmyXhQL7gC0ujo8ZyXY5QcxW0n3I8rTajrmYZvpmK8GsZX0mHgwXqk2fcWSOWWwrjLI814QK3JjyVCYpyCUyovWFbVXeyzKAYAxuUn97cN3KNG+vFxNx/pBzINDZmp95fBD+sj2wmNDcAiOjylRm+n6KTx2FFFeIhbkRMcHy81Lh2TBj6dZx4pELPX8NLFIbl4ZfFDKoM21MvhAJ5pcUfq3wJqC9gJFcAar9PSnKBqvMvj0hevLLJSK8MuaWFd0kqDD+hljNUrO++YUxQDqULq0e23evRiIzmEsClvOO3KHFV4b3rdclrltweckPKcbKYK86Lxn6jxrcN45PDcbndsM24zOpUbndKPf2Hl5Oeduw3Ozub+xw3OzuW0G/az5/GzYXhM4T7x0mMAAAAA6xhuYjMTUWgAAALQJNTEAAACWHTVxWy3nlEEAAAAAAAAAAAAAALBQuAIDAADonlnfDgYAAABYNNTEAAAAWHbUxK3EFRgAAAAAAAAAAAAAAMDccQUGAADQPcysBQAAwLKjJgYAAMCyoyZuJSYwAACAbnFJZVl/mwAAAEBbUBMDAABg2VETtxYTGLCn4HtsQaxYrzdWrKX3AMV6EFtLd7K3Ox0rgpit9YNY1Gaw4etRm4m8fjonas/Xo34EsWB9nurjqLx+8CHydMzL4IgQ5GUxC2Lpu+5YrxfEgrv1hHnpmFaD3XcxPM9WgvZWgvaCPA/bDPKibVtJj5fnxoL3wFeGv+dl0F6ZyBmsKy8Wt5kMyYsgL/joRTElmvTg69FMLAgCwLQKqb99+M6wDA6L69uDffm2dF65GuStJp4P+hHu44O8speuq6LjTXTzwbAv4fqCGi81XEWQE8XCEi+dZ0XwOyFqM4qlQzILfusEsVSbUXtNKIMDexgLRqUf5BVB3lqZ+EAHn9ci+p85UUkf/CYpgw9DEZz5isYr+ixEYxmJ+lL3upZVPyzAAWA+3F2+e/e8uzF7RQP7ZM5hTCbzPbCccQ7OnUXnexWcxwvP6UbbFp4TDWJBm+H52cQ50fDcbHRuM/v8axCLzm2G68s8PxueSx0ea+bcbF5e/IMyLxadn03/2Ky/H8BmTGAAAAAd4w1cGoyptQAAAGgTamIAAAAsO2ritmL6NwAAAAAAAAAAAAAAmDuuwAAAALqn9pm1AAAAQMtQEwMAAGDZURO3EhMYAABAt7iksubClDoXAAAAbUJNDAAAgGVHTdxa3EICAAAAAAAAAAAAAIAWMLOjzOwjZnatmd1sZl8ys+eYWa/JtszsIWb2N2b2FTO7xsx2mdkVZvZ3ZnZcPVvHFRgAAEAHuZfz7gIAAAAwV9TEAAAAWHZdrInN7CRJ75e0S9J7JF0r6URJr5F0tKTHNdjWsdXyWUkXSLpJ0j0lPVrSiWb2h+7+otxt28AEBuyh6FsyZutB3lr6minFWjqvt3t4Xi9qL5EzaC+9IyrCWD8Zs93pDbe1dJ7Wgrz1jLz1dHsexNQPds79dD88iIV5ufcTsvQFYcL5YsXkuzGz9OdcvWBlRdTH4II2YZvpWHabK4lY0H9P5YzIS65Lkq8E6wvbTMfKqM1e+n0N+5LIK1eC9qJ1FVFeMiQPhiRsM8wLYsH3IJkXfHVmHgOAKbmZ1vdJHAOC/XW5LR3rb0vvuMrVoC+JciY6bpRBCeS9dD2WfSwK2gyv65cdS6wvyLFUzqhY0I2obDQL2gxiRRgLOpPBPa/BMsgLY8EbVAa/E8pgoMvggxn81NSqhv8OWgu+4KtF+nfOepAX9b8Iri/aC06k5bYZvT/RZy+15T0L+hjtUAJR/9ugnHGR2k98B5xiGUAdvFR5662zW19w/m9RWN0F2egVzm5dmdsWnksN1xdsWxmcs47yom1IjWXmOVaL+pFzblaKz89G/cw9P5s4h+lR/3PPsYbnRDPP6WbGyiAW/aZMlbe552ajH5TxedsoFrQZ5qVjUVmZ+ZMyyyzX1WZmtp+kN2vwM+4Yd/+X6vkXaTCh4BQze4K7n91QW69099OHtHV3SV+Q9AIz+0t3v3qa7Vz8igEAAGAiPri3WZ1Ly0+0AwAAYNlQEwMAAGDZdbImPkXSgZLO3phwIEnuvkvSC6u//nZTbVWxvbj7lZIu1GDuwb3HXH8SV2AAAADdk3s1GAAAAKArqIkBAACw7LpXEx9bPX50SOxTkm6WdJSZbXf3UZdZqq0tM7uLpF+UdKukS0esdyQmMAAAAAAAAAAAAAAAMNrhZnbRsIC7H9Hwug+rHr8+ZN3rZnaFpH+vwVUQ/rWptszsSEknaDDX4B6SHi1pP0nPdPcfjr01CUxgAAAA3eKK76WY2yYAAADQFtTEAAAAWHbdrIn3rx5/nIhvPH/Hhts6UtJLNv39BklPdve/GWO9IzGBAQAAAAAAAAAAAACA0S6Z5koLZrZT0kETpLzT3Z84bvPVYx1TLZJtufsbJb3RzPaRdC9JT5P0djM72t2fNu2KmcAAAAC6p3v3NgMAAAAmQ00MAACAZbeYNfHlknZN8PqrNv1546oI+w97oQa3cdj8usjUbbn7Lg1uL/FsM9su6bfM7OPu/r4x1p/EBAbsKfgeW3CVlTDWj/KGrzDKKfrpTqbakySFsWADop1bE7EUs3Ss15u8PUkq0m1a1KanxyvoZTOsGP58sG3hWKbaG9GmFVFeZqyXl+epvGhdK+n323vp7fbocxLlrQT9D8Y5uW2SfCXIC9osE3nhdkd9DI6sZdhmOi8/lrm+RFrq+dz2BrGZ7zUAQNJgv7V2u1QsOG6sBm1Gx4Ag5onDaZizkq4nw7xof91Lt5mfF/3ACGKpvCgnt/wL2syNzVpOT8rgAF0EgxnllcFAh3lBbF3pD190QqNMvT/BYK2V6dp2tQh+pEZfEEU/lqMvVt5lTkult6EINr6X6GeZ2kGNUATfj2AkMUTq+7E4eyAArTfLf9jxGR4FMs83ZHcxOq6HaRnH/Nzzl9GYROcNM/MsOrcZbUOUF5yLTG5fdP5yludmp1ifh+d1o74kxiRorwzaiz5f8fnSes/bjsoLfkJktdnE+dfwH1JmHcuQfb43sx/R+trI3Y+bIv1SDW7fcKikizYHzGxFg6shrEv65ozbkqTzJP2WpGMkTTWBIe+oCgAAsKBcLi/LehdOEQMAAKBFqIkBAACw7DpaE19QPT5iSOwhkm4n6UJ3v3XGbUnS3avH9TFfn8QEBgAA0C2uwf8gqXWZ90YBAAAAE6AmBgAAwLLrZk38Pkk/lPQEMzty40kz20fSH1Z/fcPmBDPb38wON7O71dDWQ832voyOmR0i6bTqrx+eeKu24BYSAAAAAAAAAAAAAAAsMHe/3sx+Q4PJBzvM7GxJ10p6tKTDquffsyXtZElvk3SWpCdN2da5kn5kZp+V9G0N5hocosFVHFYkvd7d/2Ha7WQCAwAA6J5y/lNhAQAAgLmiJgYAAMCy62BN7O7nmNlDNbjiwWMl7SPpMknPk3SGu4+90RltvUTS8ZJ+SdKJknqSvifpHEl/7e5/P8Wm/QQTGAAAAAAAAAAAAAAAaAF3/4ykR4352jMlnVlTW6+T9LpxXjsNJjAAAICOccnL+tsEAAAAWoOaGAAAAMuOmritmMCAPXgRxHrpWLliQSz9ZU7llavpdVk/vS6V6Q0Iuq8y+CoUFqwviFmR7ov3+uk2V4fvTK2f3slaGeyAgzxFV5EZ/woze4r6kisYy6TofcvN6wX9yPyceNRmtN1BnqfyekE/wnVFeUFsJepjNM7B/iTc7nSTcV8Sz0fbHe0Pw/FK54VjGealY4q+BkEs2WYD6wrl5rnkdV8abAHqUjPbLumpkk6VdG8NLuf1bUn/IOlV7v6tOXYPaB0vpPXbJXY00T4yPAbE65u0TQ/q6KgfuTV9nBfsCKPjQ83HjrjkCvqYG8sU9iUQHb6i3zPp9oLfK0GsjH7nRHlRLPgwlJm/PcrgQ7SW+EKuFsFvsaAbqfYkqbD0b6Be0Mci2O7oPSiCjvaU7kv4/mT8fiqCz3k//Cw38Jux5frhzjJTR2tiAHUz2UpH/4nAGti3RuezAhYdZ6Nzcqm8ICdeV1RMR+co8857qpeun8J+BnlZ525zxlgzPm8rzfTcbRPnbeNzm9G/H+XlReVTbl+S54mjdUXnD3LOv6qZ88RRX7LO6y7SueAINXFrNXAUBwAAQJ3MbEXS+ZL+XNIdJL1b0hslfV/SMyV90cx+fn49BAAAAAAAAABgeh2dXgkAAJZa7ZcGm7uTJR2twSSG491v20Aze6mkF0t6vqSnzKd7AAAAWDjdq4kBAACAyVATtxJXYAAAAFh8964eP7x58kLl3OrxwBn2BwAAAAAAAACA2nEFBgAA0Dm139ts/r5aPT7SzF63ZRLDCdXjx2fcJwAAACywDtbEAAAAwESoiduJCQwAAKBjvIFLg7kkHW5mFw2Nuh9R8wq3+rCkD0j6r5K+bGYfl7Rb0hGSHiTp9ZL+vOE+AAAAoDUaq4kBAACAlqAmbitzZ6CXiZldY6urd179d3cZHu9bOjf4jkcxhXnDP38WfCzDdQWf56jNcH8TfUey15fxvQtToj5OvqopExdE+rM8+yaDxNw2LZ2YfOfCdc22j7ltehN9yVlXdj+C9WXmZa8wpy8NbHeOXdd9T76+dq27H7DXqswuKtS7/+11h1rXeZNuUKn+zZIuGRafwQQGmZlJerGkF0nqbQqdL+mF7v7PTfcB6Aozu8ZWVu+8/c7/LvGCvHbzj1MTPt9YP6IiPK/JusfEoiNm9rE7qOmjtOgwG4xlfjlTb5uL1Mfc9zXuZ+K3ZtiPKJj3+yj/KzDb9eVsXwO/uDCBa664Qeu7+vOoib8wi9oXQPPM7JpCvTvfXvvNuyvNaORAtSjnG4Nz+Nnryty2RWqz5rGc6XnbkeuruZ8tP287yEuHaj/Pmruu7H7UfE53qr7UmDNCzmfo1mvndp6YmrhhXIFh+Vzva2va/Z0rd867Iy10ePU49B+vEGLs8jF2+Ri7fIs+dgdLuj4Ru6RUXzfoR02s9xJ3/7XcZDPbKemgCVLe6e5PrHL3kfR2SY+U9HRJ50q6WdLRks6Q9Ckze5y7n5vbP2DJXO/ra9r1/e/snHdHWmjRjxGLjLHLx9jlY+zyLfrYHaw51cRNNApgLq4f7Cuu2znvjjSi2f+bVd8xou3/h2xyi358XWSMXT7GLt+ij93BoibuJK7AAIxp47LhzKqaHGOXj7HLx9jlY+yaYWbnS7r7BCl/5+6/V+WeLuklkp7t7mdsafc/SrpY0rfc/eBaOgsACRwj8jF2+Ri7fIxdPsYOAJDCMSIfY5ePscvH2OVj7DAvXIEBAABgBtz9uCnST6gePzGk3S+a2bWSDjKzA9z9minWAwAAAAAAAADA3BTz7gAAAABG2l49Hrg1YGbbpZ/ctHT3zHoEAAAAAAAAAEDNmMAAAACw+D5dPb6gmrCw2ekaXFXr8+5+w0x7BQAAAAAAAABAjbiFBAAAwOJ7uaQTJR0n6RIz+6ikWyQdLemB1Z+fPb/uAQAAAAAAAAAwPa7AAAAAsODc/UpJ95f0Kkm7JD1Z0jMk3VXSmZLu7+7/NLcOAgAAAAAAAABQA3P3efcBAAAAAAAAAAAAAAAsOa7AAAAAAAAAAAAAAAAA5o4JDAAAAAAAAAAAAAAAYO6YwAAAAAAAAAAAAAAAAOaOCQwAAAAAAAAAAAAAAGDumMAAAAAAAAAAAAAAAADmjgkMAAAAAAAAAAAAAABg7pjAAAAAAAAAAAAAAAAA5o4JDGgdM7uHmb3VzK4ys1vNbKeZvdbM7tR0O2Z2lJl9xMyuNbObzexLZvYcM+sFOaea2efM7EYz+7GZ7TCzE4a8btXMTjazt5jZV8zs+modXzazl5nZHSbZvrq2ua52mhy7RO6hZnaTmbmZvWOS7Uu01/mxM7ODzewNZvZNM9tlZteY2WfN7Hcn2cZpt7eudmYxbmb2C2b2TjO7zMxuMbMrzewTZvZ4M5vqGNuWsavaP83M3luNQ1l9735uRL/2NbOXmtml1eft+2b2t2Z230m2DwCWVVuOE5tyqIlFTTxNO7MaO6Mmpia+LYeaGAAWXFuOE5tyqIlFTTxNO7MaO6Mmpia+LYeaGPPh7iwsrVkkHSLpe5Jc0jmSXinpgurvl0g6oKl2JJ0kaV3SjZLeIulPq9e6pPcm1vNnVfzbkl4j6S8kXVM994wtrz28ev5GSf9X0h9Xr7+sev5SST/N2O09dkNyVyR9VtIN1evfwecuHjtJvyLpJkm3Snq/pFdIer2kj0n6R8Zt73GTdKKktWrM3lv166835bx5GT5zkh5TxUpJl0u6rvr7zwX92i7pH6vXfV6D/d27qvG8SdIvTvOdZWFhYen60qbjRJVDTTyDsRuSS01MTUxNPKOxEzUxCwsLy8yXNh0nqhxq4hmM3ZBcamJqYmriGY2dqIlZalzm3gEWlkkWSX9f7cieueX5V1fPv7GJdiTtJ+n71QHoyE3P7yPpwirnCVtyjqqev0zSnTY9f3B14Nol6eBNz99d0u9Iuv2WdrZJ+lDV1usZu73HbkgfX1yt71mqpzDt9NhJurcGRfy/STp0SL9XGbeh4/bVKuehW56/q24rBu+5BGN3D0kPlrRf9fcdGl2Y/kH1mvdKKjY9f1L1/Fc3P8/CwsLCsufSsuMENfGMxm5IH6mJqYmpiWc3dtTELCwsLDNeWnacoCae0dgN6SM1MTUxNfHsxo6amKW2Ze4dYGEZd6kOni7piq07LEl30GAW2E3aUtjV0Y6kp1Q5Zw1p79gq9sktz7+9ev7JQ3JeVsVeOua2bxw0v8zYxWMn6UgNZue9UNIxmrIwXYax25Tzq7njtKTjdoukHyf6/XdVzhFdH7shr9uhoDCVZJK+Vb3mXkPin6piD6vr88jCwsLSpaVtx4mcY2zQZ2riMcdO1MTUxNTEMx27Ia/bIWpiFhYWlsaWth0nco6xQZ+picccO1ETUxNTE8907Ia8boeoiVkyl6nuuwLM2LHV48fcvdwccPcbJH1G0u0k/VID7WzkfHRIe5+SdLOko8xs+5g55215zShr1eP6mK/fainGzsz21aDAuFiDSyDVodNjZ2arkk7RYDblR8zsgWb2XDP7X2Z2gpltG7FdKZ0et8pXJe1nZg/a/KSZ3UXSAyVdJelrQ9obpW1jN6lDJN1T0tfd/Yoh8Un3jwCwbNp2nKAm3jOHmnjydqiJF3TcKtTEeaiJAWA6bTtOUBPvmUNNPHk71MQLOm4VauI81MRIYgID2uSw6vHrifg3qsdDG2gnmePu6xrMXFvRYCabzOz2Glzq60Z3v3qKvm54SvU47GAxjmUZu1dW7ZxatV2Hro/d/STtK+krks7W4J5wr5b0JxrcY+8bZvaA5FaldX3cJOm5kq6X9HEze4+ZvcLM3qxBwXqDpMe4+y2pDQu0Zuwy1bV9ALCsWnOcoCamJq6pHWrixR03iZo4FzUxAEynNccJamJq4praoSZe3HGTqIlzURMjaWXeHQAmsH/1+ONEfOP5OzbQzqQ5dfVVZvZoSb8l6TsaFAs5Oj92ZnacpGdK+n13z5nNmNL1sbtL9fhQDS519euSzpH0U5KeLun3NJhxe193/2Gi3WG6Pm5y90+b2S9L+ltJ/21T6AZJb5P05UR7o7Rp7HLMYh0A0GVtOk5QE+fnUBPn51AT5+VQE9e/7gg1MQBMp03HCWri/Bxq4vwcauK8HGri+tcdoSZGEldgQJdY9ehzaCd33eHrzewoSe/S4P5Dj3X36yZsf1ytHjszu6MGhcBnJb1qwnam1eqxk9Tb9PgH7v5Wd7/W3f/N3f+3pA9I+mlJvzHhOkZp+7jJzB4u6dOSrpR0hKTba3DZq7+W9HJJ55tZExMF2zh2k5jFOgCgy9p4nKAmpiaeph1qYmriWbdDTQwAi6+NxwlqYmriadqhJqYmnnU71MRoFBMY0CYbs632T8T32/K6OtuZNGfU60fNLFM1Y+88SaWkR7j751KvHUPXx+7VGhRPT3L3fiIvV9fHbvOPnQ8Oydl47oGJNlM6PW5mdmdJ79FgNvLJ7v4Fd7/Z3b/p7s/TYHbyUZKemGgz0qaxyzGLdQBAl7XpOEFNnJ9DTZyfQ02cl0NNXP+66+4XAOA2bTpOUBPn51AT5+dQE+flUBPXv+66+4UlwQQGtMml1WPqfjf3qR5T98uZpp1kTjVz7l6S1iV9U5Lc/SYNZtv9lJndbdK+mtmDJf29BjPLjnf3zyT6Oq6uj939Nbg/1yVm5huLpE9U8V+rnrs4tWGBro/dpZv+/KMhORuF676Jfqd0fdyOknQnSZ9195uH5Gx89o5I9DvSmrHLVNf2AcCyas1xgpqYmrimdqiJF3fcqInzURMDwHRac5ygJqYmrqkdauLFHTdq4nzUxEhiAgPaZGNHf7yZ7fHZNbM7SDpag1lu/9xAOxdUj48Y0t5DJN1O0oXufuuYOY/c8prNfThWgxm165Ie7u6jtmccXR+7D0h6y5DlI1X88urvHxi6VbFOj527Xyvp4uqv9xuSs/HcziGxSKfHTdL26vHARL83nt+diEfaNnaTulzSv0k61MzuNSSe3D8CACS17zhBTTxATZzfDjXxgo6bqImpiQFgftp2nKAmHqAmzm+HmnhBx03UxNTEaIa7s7C0ZtFts02fueX5V1fPv3HTc6uSDpd0yDTtVM/vJ+kHkm6VdOSm5/eRdGGV84QtOUdVz18m6U6bnj9Y0jWSdkk6eEvO8ZJulvRDSf+ZsRt/7BLbfEzVzjsYu/Bz99Qq5+OS9tn0/D0kfbeKHcO43TZukn5G0pqkvgaz3ze39bOSvl+196iuf+aGrHNH9bqfC17zB9Vr3iup2PT8SdXzX938PAsLCwvLnkubjhOTHmOrGDVx5tgltvkYUROP87mjJqYmzh67IevcIWpiFhYWlkaXNh0nJj3GVjFq4syxS2zzMaImHudzR01MTZw9dkPWuUPUxCyZy9w7wMIyySLpEEnfq3Zc50h6hQazr1yDy80csOm1B1fP75ymnU05j9FgtuuNkv5a0p9IumTTztWG5Lyqin9b0msk/YUGRadLesaW1x6mwSw3l/Q+SacPWxi7vccu2OZjVE9h2umx0+BqPB/c1I8zNJiJfE313OsYt6Hj9uIq1pd0rqQ/lnSWpBuq5z+wRJ+5MzctGz9m3r/puQdtef12SZ+pXvd5Sa+U9C4Niv2bJP3iNN9ZFhYWlq4vLTxOUBPPYOyCbT5G1MTUxNTE1MQsLCwsHVtaeJygJp7B2AXbfIyoiamJqYmpiVlas8y9Aywsky4azFp7m6SrNbjszrckvU7Snbe8LrmznqSdLTlHa3C5qes0KCK/LOm5knpBzqnVjvem6oD1SUknDHndMVV/w4Wx23vsgvyNMZ2qMF2GsZO0IunZGlwm7GYNipLPSHoi4xaO20kaXMrvBxoUc9drMAP1t6P1dG3sNHrf9aQhOftKeqmkb2gwk/cHGhS+Pz/t95WFhYVlGZY2HSeqHGrihscuyN8YU2piamJqYmpiFhYWlk4tbTpOVDnUxA2PXZC/MabUxNTE1MTUxCwtWKz6cAAAAAAAAAAAAAAAAMxNMe8OAAAAAAAAAAAAAAAAMIEBAAAAAAAAAAAAAADMHRMYAAAAAAAAAAAAAADA3DGBAQAAAAAAAAAAAAAAzB0TGAAAAAAAAAAAAAAAwNwxgQEAAAAAAAAAAAAAAMwdExgAAAAAAAAAAAAAAMDcMYEBAAAAAAAAAAAAAADMHRMYAAAAAAAAAAAAAADA3DGBAQAAAAAAAAAAAAAAzB0TGAAAAAAAAAAAAAAAwNwxgQEAAAAAAAAAAAAAAMwdExgAYEpmtsPMvmxmjexTbeBiM/t0E+0DAAAA06ImBgAAwLKjJgaAejCBAQCmYGanSHqopJe4e9nEOtzdJb1E0oOq9QEAAAALg5oYAAAAy46aGADqY4P9HQBgUmZmkv5Vkkk63BveoZrZ1yT1ZrEuAAAAYBzUxAAAAFh21MQAUC+uwAAA+f6LpMMknTWjQvEsSYdKOm4G6wIAAADGQU0MAACAZUdNDAA1YgIDgKVjZjvNzIPlzDGb+vXq8T1D1vGkqq0nmdnDzezTZnajmf3AzN5mZnesXvefzexDZnZdFf87Mzs4sb6zt6wXAAAAyEJNDAAAgGVHTQwAi2ll3h0AgDl4raQ7Dnn+REn3l3TzqAaqy4IdK+m77n558NJHSzpB0ockvVHSUZKeJOleZvb7ks6X9GlJb5H0C1UfDjGzX9h6rzR3/5aZXSnpv5iZcXkwAAAATOG1oiYGAADAcnutqIkBYOEwgQHA0nH31259zsweLuk0SZdJevEYzRwm6UANCs7IoyUd5+6frNZTSPp7DS4r9hFJv+nu79zUj7dIeooGBeq5Q9r7vKTHSLqvpK+N0U8AAABgL9TEAAAAWHbUxACwmLiFBIClZ2b3k/Q+ST+W9Ch3/+EYafesHq8e8bp3bxSlklTNlv2b6q9f2VyUVt5ePf6nRHvf3bJ+AAAAYGrUxAAAAFh21MQAsBi4AgOApWZmd5P0YUnbJZ3g7t8YM/WA6vG6Ea/7lyHPXVU9XjQkdmX1eI9Ee9dWjz89Yr0AAADAWKiJAQAAsOyoiQFgcTCBAcDSMrPba3Bpr5+V9Gvu/ukJ0m+pHvcZ8bofD3lufYzYaqK9fbesHwAAAMhGTQwAAIBlR00MAIuFCQwAllJ1j7F3S7q/pNPc/d0TNvH96vGA8FX121jf98NXAQAAACNQEwMAAGDZURMDwOIp5t0BAJiT10o6UdJb3f2PMvK/Kqkv6fA6OzWGwyWVkr484/UCAACge14ramIAAAAst9eKmhgAFgoTGAAsHTN7jqRnSjpf0tNy2nD3H0u6WNJ/MLN9R7y8Fma2XdJ/kvT/3P1Hs1gnAAAAuomaGAAAAMuOmhgAFhO3kACwVMzsrpJeJck1mJ16mpltfdnF7n7OGM29X9IRko6V9OEau5lyjKRt1XoBAACALNTEAAAAWHbUxACwuJjAAGDZ7KPbrj7znMRrzpJ0zhhtvUXS6ZL+p2ZTmJ4qaXe1XgAAACAXNTEAAACWHTUxACwoc/d59wEAWsvM/kqDgvFgd/9ug+u5i6Sdkt7l7k9taj0AAADApKiJAQAAsOyoiQGgPsXolwAAAi/WYLbraQ2v5wWS+pJe1PB6AAAAgElREwMAAGDZURMDQE2YwAAAU3D370l6oqSrzKyRfaoNbr52taT/4e5XN7EOAAAAIBc1MQAAAJYdNTEA1IdbSAAAAAAAAAAAAAAAgLnjCgwAAAAAAAAAAAAAAGDumMAAAAAAAAAAAAAAAADmjgkMAAAAAAAAAAAAAABg7pjAAAAAAAAAAAAAAAAA5o4JDAAAAAAAAAAAAAAAYO6YwAAAAAAAAAAAAAAAAOaOCQwAAAAAAAAAAAAAAGDumMAAAAAAAAAAAAAAAADmjgkMAAAAAAAAAAAAAABg7pjAAAAAAAAAAAAAAAAA5o4JDAAAAAAAAAAAAAAAYO6YwAAAAAAAAAAAAAAAAOaOCQwAAAAAAAAAAAAAAGDu/j/ltCsc0B9H8wAAAABJRU5ErkJggg==\n", + "text/plain": [ + "
" + ] + }, + "metadata": { + "image/png": { + "height": 277, + "width": 1048 + }, + "needs_background": "light" + }, + "output_type": "display_data" + } + ], + "source": [ + "# Method 1\n", + "plot_plane(IDAT[1]['xz_plane'])" + ] + }, + { + "cell_type": "code", + "execution_count": 20, + "id": "neither-guide", + "metadata": {}, + "outputs": [ + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAACDAAAAIqCAYAAADYEygWAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAADQD0lEQVR4nOzdeZx8V1ng/89T/e0krAEExB8om0AcdURAQDIDARQRBEFhxAUURUdlZB2VEZVFcRkRBFyYQdlEJIIjuABGgQgSEUEFFcISiCCLCkEICd+lq57fH1VNOp06T3ffvrX25/161au+3zp1nnPurVv3Pvf2qXMjM5EkSZIkSZIkSZIkSVqkwaI7IEmSJEmSJEmSJEmS5AAGSZIkSZIkSZIkSZK0cA5gkCRJkiRJkiRJkiRJC+cABkmSJEmSJEmSJEmStHAOYJAkSZIkSZIkSZIkSQvnAAZJkiRJkiRJkiRJkrRwDmCQJEmSJEmSJEmSJEkL5wAGSZIkSZIkSZIkSZK0cA5gkCRJkiRJkiRJkiRJC+cABkmSJEmSJEmSJEmStHAOYJAkSZIkSZIkSZIkSQvnAAZJkiRJkiRJkiRJkrRwDmCQJEmSJEmSJEmSJEkL5wAGSZIkSZIkSZIkaY4i4vsjIiPiKT3GfOIk5iP7iilJ8+YABkk6gIj4y4jYiogvXXRf+hIRg4i4MCI+GxFfuOj+SJIkaXlFxNMmF0Qfvui+9CkinjdZrvsuui+SJEk6vIh44SS/2/0YRsQlk+u8j4uIqy2of1cDngRcCjxr8tr3NPq8n8f3TEI/B/gP4Kci4hqLWDZJOiwHMEhaKkViOe3xmDn37f7A2cDLMvP9k9cePunLVkR80T7jfPmOZbh34z2PnpQ/q78lmC4zR8DPA9cAfmrW7UmSJGlvy5gXR8SNgMcAFwO/PXntFhExmvTjv+0zzkZEfGxS5xca7/mqSfk7eur+Xn4eGAI/FxFeK5EkSVofp4B/3fG4FLgu4+u8vwy8LSJusIB+PQq4MfDrmXnJ5LXP7err9uMTO+p9qvGezwFk5meAXwW+kHHuLkkrx5NySctqd2I57XHZvDozuYj5c0ACT9tR9PJJPzaA79xnuIdNnj8G/FnjPd80ef7jg/W0s98BPgj8QETcfE5tSpIkaW/LlBc/Cbg68IuZuQWQmR8A3jQpf1ir4i73Am40+feLGu+Zaz48WY7fBf4z8O3zaFOSJElzcUFm3mjH4zrAdYD/CYyA/wRMHVQ7KxGxwXgAA8Dztl/PzHN39fVGmXkj4Gt2VP+Wae/JzHN3vOc3J88/EhHHZrs0ktQ/BzBIWla7E8tpj+ftHaY33wB8OfCXmfnu7Rcz87PA/5v896F7BZkMhNge6PCSzBxOec+1gLsyHg38F4fs975MLkC/CNgE/sc82pQkSdK+LEVeHBHXBb6H8S+7XrKreHsQwjdExA33EW57oMPf7Mytd5n3gF644kLv4+bYpiRJkuYsMz+dmb8M/NbkpfvNuQv3Af4/xvnwRX0Hz8x/Bv6K8SwM37TH2yVp6TiAQZL25xGT55dNKdu+YPufI+Kr9ohzT8ZTg+2st9u9gNOAP8vMkwfq5eH87uT5oRGxOcd2JUmStPy+CzgD+OPJIN6dXg5cDhxjj9kLIuLawDdP/js1H55M4XtH4N+Bvz5Enw/qTcBHgNtFxG3n2K4kSZIW452T52vsfDEinj+5ndkrqsoR8ZTJ+y44YLsPnzz/3gHrHcR27IeX75KkJeQABklrISL++yRZPB4RX9F4z/+dvOdDEXGdA8T+AsajcJPxxdnd3gB8ePLvvabN3S5/e2b+U+M9V/m1WUTcbPsex5P/3zEiXhUR/x4Rl0bEBRFxnx3vPy0ifjwi/jEiLo+If42I/xMR12t1LDPfC7wDuAGOzJUkSVpJEfHC7bxxj8cLDxi6eZE1My8F/mDy373y4QcDVwNOMn1wMIx/kTYAXpOZo+0XI+LiSd/PiYgviojnRsSHI+JzEfHuiHjsZMaz7fc/OCLeFBH/ERGfiYg/aZ0rTJZjBGxfpPZCryRJ0vr7ysnz+3e9vj0z1/0m14avIiIC+O7Jf5+/3wYn+eo9Jv99837rdbAd+x7eRkLSqnEAg6S1kJn/h/Ef/E8HficiTttZHhHfBHw/40EI35OZ/3GA8HdnfGuF92Xmv09pewT89uS/3zG5h9lVRMQ1gQdO/tv6tVkA3zjp56sb77k/8JeMB1VsAtcEvhb4o8lF2jOAP2V877ZbTqrdEPgB4M93r5tdthPbexXvkSRJ0vL6NPCvxeMqtzDbS0RcH/jqyX9bF1m389vbRcSXF+G2Bzj8cWZ+svGevW4fcXPgb4H/DlybcU58FvAM4FmTPv8C48EWX8v42se1GA+MeFNE3Kron/mwJEnSmouIa0fEY7hi1t1n7izPzAuAdzGeJfc7me6ewE2By4BzD9D8VwJnMs7L33GAegf1DsaDhq8J3HaG7UhS7xzAIGmdfB/wb8B/Bn52+8XJFLTbo2afmZmvP2DcsyfPby/es33B9kbA1zfe862MpyM7xRW3a9jtjozvTfY3mfmvjfe8ePL4osy8DuPBCa9ivE9/JvB0xhdwv4lxgnotxtP0Xsr4wvMjrhry8942ef6vxXskSZK0pDLz0Zl5o2kP4HuBmLz1tQcIu50PfywzP9Z4z+uAf5n8+6HT3hARN+OKPLM1oHeT8eCBU4wH5U7zTOCDwFdl5pmMBzH81KTskRHxE8DjgMcAZ2bmtRlfKH4PcB3gaY24cEU+fNbkPEKSJEmr7S4R8fEdj/9gPOj3mYz/yP+wzHzhlHrb15NbM3N97+T5FZMZyfbrjpPn92fm5QeodyCTWxO/Z/LfO82qHUmaBQcwSFpWuxPLaY9r76yQmf/GFX+cf3xE3G3y7//LeFDAPwI/0aEv20nlO1tvmNx+4S2T/7amzd1+/U8y8xON9+z1azOAv83MR2wPcJjMCvGdwGeAGwOPBB6SmX+SmcPJ4w+BX5rUf1ARe3vU73+KiGsV75MkSdJ8HDgvniYibgO8lPF1gP+dma3bN0yzn3x4BLxk8t/v3Hkrhx0eyngAxb8Dr2mEuivjAQlvyszPNN4zAu6Tme+ctH15Zv4s8PpJ/KcBP5uZz8rMyybv+UfGM7IB3L81K1lmfpBxXg1XLLckSZJW1ybja8PbjzN3lF0PuOFkVtzdXsx4BoPbRsRX7yyIiDO5Yqbdfd8+YuKLJs+t68N92m7ji8p3SdKScQCDpGW1O7Gc9rjKPiwz/4jxgIUB8OKIeCzwAMbJ5ndl5okOfdlvUrn9K7IH7P7jf0TcBDhn1/um2c8Ahl/Y/cLkwuz2AIoLMvMvptR73eS5ed9frljGYLyOJUmStFid8uKdJhdY/5DxxdrXAP/rgH04aD58E664r+9O2zMzvDQzTzVi7Ccffm7jlnB/Pnk+yfh2Eru9GTjO+LZzX1rE3761hRd6JUmSVt9fZGZsP4BjwC2AH2Y8e+3TuWK2hc+b3O7slZP/7p6F4TuAMxjfcviNB+zP9SfPnzpgvS6227h++S5JWjIOYJC0rK6UWDYe/9Go+zjgfcCXcMWFy5/KzK73FNtvUvky4ARwNa46y8FDGe9zPwn8ybTKEXFjxvcj+0hm/l3Rzj80Xv+3yfM/Nsq3b0lx3SL2zmU0sdXCRcSDIuI5EfGmiPhMRGREvGTvmgdu5ysj4sUR8eGIOBER/xYRfxERrRlVJEmal8PkxUxmQvhd4NaMp5D99slsCQexr3w4My8E3jr575VuIxERXwvcavLfFxdh7jt5rgYw7JUPX5yZn53SvxFXDMLYT05sPqylYE4sSVJ/JrPVfjAzf4PxrLYA3xsR/2XK27cHNnzHrhm8tm8f8YIOXTh98nyyQ92DOj55vtoc2pKk3jiAQdLamcxG8D92vPQWxiNpu9pXUjm5cPyqyX93X+DZvoD7u4f8tRnFfYeHk+e9yo8V4Y/v+LeJrZbBTzL+Pt8W+MgsGoiI7wH+jvFsLW8Cfhl4BeOZSO4zizYlSZqjXwC+EfgP4P6Z+ekOMQ5ykfWFk+dviYhr7Hh9Oz/+x8z822kVJ7e5uBXwnsx8X9FG13x453s2i/d4oVfLxpxYkqQZyMw/BT4++e9/m/KWPwc+CHwBcH+AiPhy4A6M88pqpt2WSybP1+lQ96C2B+1+snyXJC2Z6o9YkrTKdk7rdSvGU+tWFzIrlwA3Yn9J5YsYJ7t3i4gvycwPRcTXAF+2o7zlfpPncgDDjO38JZqJrZbBY4F/Ad4P3A14Q5/BI+LOjEfT/yNw78z8+K7y6o8bkiQttYj4DuBHGV9cfUhmvrdjqINcZH0Z8EzG0/F+C/Dbk1+rbV8QXvZ8GLzQq+VjTixJ0ux8iPG131vsLsjMjIjnAz/D+HrzK4DvmxT/aWZ+tEN7+5kRrC/bbex1KzhJWirOwCBp7UTEdwIPAbYYT5P7BcDzDxHyIEnl9qjdAL5r8tr2r83elZlvm1YpIq7G+D7BnwNe172rh7ZzGU1stXCZ+YbMfF9m5n7rRMS3R8QbIuJTEXE8It4dET8ZEadPefv/BjaA79p9oXbSfmvGFEmSllpE3J4rprz98cmvy7radz6cmZ8C/mjy3+1ZyO4HXI/xQIrfKarva0ayOfBCr5aKObEkSTN148lz63j3AsZ57DdExE254ppv1+vN75k836xj/YPYbuPCObQlSb1xAIOktRIRXwz86uS/T2U8/eXngHtHxA93DLudVN58rzdm5s6Lsg+d/FLlIZP/V782uyfjKWpfn5mf69jPPtxs8vxprpg+TVoZEfFbwEuBLwX+H/BrjH81+jPAayPi2I733gT4r8DbgH+KiLtHxP+MiMdHxD0n9wyXJGnlRMQXAq9knF/+dmb+8iFD7jsfntjOe+8ZETfmigG957VuhxYR1wHOZnyri7/s1s3Di4irAzeY/NcLvVpJ5sSSJO1PRJzNFQMYpt7mLDM/AryG8WC/32GcK/478Icdm70ASOC6EXHLjjH2NDnG32jy34Xl15LUhSchktZGRATje+5eB3gL8HOZeSHw45O3/FJE3LpD6DdPnu+wz/dvX7A9C3gycH1gBLykqLMsvzb7msnzmzNztNCeSAc0uW/v9wJ/ANw6M78vMx+fmWcDTwHOAR65o8r29v4+4PWTxy8BT2d8j8O/j4gvnU/vJUnqx+R2Db8P3AR4K/ADPYTdzoe/IiLO2Mf7Xwv8K+NrDo8GvnHyejWg996Mb3P5p5m51bWjPbgd44vTlwLvWGA/pE7MiSVJ2ltEXC0iHgD87uSly6lnVNie2ezsyfNLus5QlJmXAO+e/Pdrqvce0nbs92Tmv82wHUnqnQMYJK2TxzK+DcNlwEMnsyHAeEaGPwOuzvgevMca9Vu2R6h+dURs7PXmzPwH4O8m/33C5PnP9rgn2n0nz8sygOFNC+2F1M2jGd865nunzGTyM4zvY/2dO1674eT5vwFfxvg+3Wcy/qXabwNfCfzJ5A9BkiStimczvrD6UeCBmXm8h5jvBD7DeIDBbfd682QAwksn/308sMl4hq9XFdWWbUDvBTvOJ6RVYk4sSdKV3SUiPr7j8e+Mrx//AfDFk39/22SmhZY/AXbOJHaY2xUDnDt5vm/5rsPZjn1u+S5JWkIH/SOeJM3LXSJir1sYnJuZjwaIiK8Afm7y+uMz8/3bb8rMjIiHA/8A3BH4ScYzI+zX24APALdg/GuV1+2jzouAr+aKgWLNX5tFxG0Z/0LuHZn5LwfoV68mv6a7O+MpzF6+qH5IXUyme/4qxveqfsx4QparOMH4ouy2jR3Pj8jM7T+YfCYivnvy3jsA38oVI/IlSZq3A+XFjGcygPGsZH/bOCburlPKzGFE/D7wcMYXQt+yj2ovYjzAeDsfPrc1mGIySPjejO8t/Jr99GmGvNCrlWVOLEnSVJvAF+567bOMr/f+GfCczPznKkBmbkXEHzGe3exvMvMfD9mnFwBPAr45Is7oadDx501ua/xAxtd5X9BnbEmaBwcwSFpW0xLL3c6Ez0+T+xLgdOBPMvP/7H5jZn4kIh7J+JdgT4yIV2fmW/fTkckAiOcDPws8hP0NYHgp42k3Nxn/Wu2VxXuX5ddm3wRcC3hDZl604L5IB3VdIBjfh/BJ+6zzqcnzCeDVOwsm3/tXMb5Ye0e8WCtJWpx958W7XH3yOEidym8xHsDwbcBP7fXmzHxHRLyD8R9TAV5cvP1rgS9gfBuzTx6wX72JiBsyHrD8WeD3FtUP6RDMiSVJmsjM7wG+p8eQd588H3b2BTLzwxHxGsaDZ78JeMUe77+Y8TF+v+4NXA84b1JXklaKAxgkLZUuiWVmnmR/U9n+Lt0vuGyPiv2WiPgfmXlij7b+HdjvFJt7DmDYT5K617rbR4xvnzw/r2pHWlKfnjz/XWbebp913jN5vjQzR1PKty/mXu1QPZMkqYOuF1wz82Z992US980R8U/Al0fEHTLzbfuoc9t9ht/XgN69li0zXwi88BAxvo3xr9BfmpmXVXGkJWVOLEnSDETEPYFbMb7dxEv3ePt+PRm4D+NbrpUDGDr4n5Pn/Q5olKSlMtj7LZKkzPwo8H8Yj1x9eF9xI+IGjO+z++/AvmaEmIWI+FLgm4F34XS5WkGZ+Vlg+48q19tntXcynl73+hEx7ZetXzF5vvjwPZQkaS1sXwD9n+W7Dm7hM5JNbmPxaMa/Qv+5Pd4uLSVzYkmS+hcR12c80y7A8zPzM33EnQwIfjlw54j4uj5iAkTEfwHuCrwqM/dz6zdJWjoOYJCk/fsZxtPJ/nhE9DWDzXUncR/d+LXLvPwvxr82e+KC+yEdxjMYz3zy/Ii4zu7CiLhuRHz+l2iZucV4YBLA/46IwY73fiXjX71u0f8oeEmSVlJm/j7w18CDI+LWfcSc3A7u5cBP9HAv4cP4DuCWwHP3ugeytOTMiSVJ6kFEPD0iPgR8FPhqxgP+frbnZp4APAW4Zo8xrzOJ+aM9xpSkuYrMXHQfJGllRMQDGd/H94Xrcv+wyQWqJwAnM/Ppi+6PtFNEPAB4wOS/NwK+AfgA8KbJa5/IzP+54/2/BvwwcAnwp8CHGM+ccnPGo89fkJk/uOP9VwdeB9wZ+DvgfMb3DP5WxtPkPj4znzGThZMkaQVFxFcznrnr/Mw8f8Hd6U1EfBfwpcCvTW4HJy0Nc2JJkuYvIl4IfDfwGeAtwP/MzH9YaKck6YhwAIMkSVpaEfFk6vv1/fPue1lHxDcBPwjckfGo80sYX7Q9D3hJZl646/1XB34MeAjji7rHgb8BfjkzX9PHckiSJEldmRNLkiRJOkocwCBJkiRJkiRJkiRJkhZusPdbJEmS1JeIuG9EnBcR/xIRn4uID0TEyyPiaxfdN0mSJEmSJEmSFskZGCRJkuYkIn6R8dS8nwReCXyC8f227w8cAx6WmS9ZWAclSZIkSZIkSVogBzBIkiTNQUTcCPgI8O/Af87Mf9tRdnfg9cAHM/MWC+qiJEmSJEmSJEkL5S0kJEmS5uOmjHOvv945eAEgM98AXArcYBEdkyRJkiRJkiRpGRxbdAc0XxHxQeDawMUL7ookSV3dDPhMZt58d0FE/A5w1ozavTAzv/MQ9d8HnATuGBHXz8xPbBdExF2BazG+rYSkGTMnliStgZuxmjmxpCVhTixJWgM3w5x4LTmA4ei5dmxuXm/zC294vWmFudGuONgYNcs2Bu1bkWxEVW96WVmHjm0VZdEx5qCoN+har1EWzRp7lXW7TUxUQVdA17vjVNWyXNP9x+xab5TTy2bRVpd+HCZm9bmOOsecXlbHa2vF27MfnWP2X6+1V6nWf9d+VFoxT3z4E+TJrVa1s4Db3e4rT+/UZsvf/sMJgLMi4u3TyjPz9nvFyMxLIuLHgWcA74qIVwKfBG4J3B/4M+C/99VnSaVrx7HN651x3S+cmhNXyl1ax/ypGXOebQFExwSqiFlG7LR87Yid89eiXplLl/WKso7ruarX3ITKdXLweHv1o1Kty66fXRnzgK+PC7utkzJk1/OxsnAGMXu24qeTS6X1aX/yg5eydXzYqjbLnFjS+rj21c6I633ZrU47cE68CrLjMXjeuvWyXavrUtf1urXXuS/l9aeDX+ua97XZztfxul6D7XAttfO12Xlft22H7H4NtsPn03W5Z7FslXnGnEUf64rT2zvxL/++qOvEmjEHMBw9F29+4Q2v9/89/rFTC0fXaX7ROeNa7S/lta5+vFl25hntsuuefvn0OpvtOtc+9rmirOjHseltAVx9cLIdc9Bu7+qD9jq5RlF2RpwqyqZ/BpvFgIhN2mWnlQMp2jY6XnGaxX1p2kvQNiwTpqJekVScyvbSzaZee0TRqWzvvo/n5tTXT3aMV/Wj1da4vXbME6N2veNVX0ZFzGqdFO1tjaZ/PlUfTxT92Co+7xPDbvVOdqx3atj+7Kp6w8Y6OdV4vaqzd1n7O9Cq9/7HPY/jF3384la9233l6fzNeV/SjNvF19zrQ70kp5n5KxFxMfB84Pt3FL0feOHuW0tImpmLz7juF17v1g+enhPnoLg4VJxBFYeiul5jd123VVxELAYlj4qyrjHrekVSViWOxxoZWxEvirJBVdYYVD2uVwyQLsoGxQDvY0V7x8pB4wcv2+xQB+BYh0HosMeyRfMPrWW9QfHH+qqfm4Pp7dWD0NtlrXh7x+y2bBvFWUtVr9KlXtWPvtvSdK2B4S/89tfzr+/+j4tb9ZY5J5a0NC7+sluddr2/Oe+LF92PmRhmt2NYV6OOf5YbdTjWDou/mFbxhkUfR0XMsl6zBE6W/Ww7VazKk8X1rNYfyatrsyeLk5Ku12bLa7D0H7O67tmK2fV6b7lOOl63PVWcpFbt1ddni3rFddbWtrJV9PFkUVbVq67Ntq5XAwy71itjHvz6bN/Xe6Ee3DBq1Pvg4/8vxz/wsYtb9cyJV5cDGCRJ0lpJstMFgL1iMp4abM+ZFioR8WPAzwHPBn4V+Djj0cA/D/xORNw2M3/skN2VJEnSETfDnFiSJElaCebEq2sWP5aWJEnSLhFxDvCLwB9m5uMy8wOZeXlm/i3wQOAjwOMj4hYL7KYkSZIkSZIkSQvjDAySJGntzHuqyH36psnzG3YXZOblEfFWxgMZvhr4wDw7JkmSpPWzpDmxJEmSNDfmxKvJAQySJGmtJN3vPVnF7MHpk+cbNMq3Xz/ZT3OSJEk6qpY4J5YkSZLmwpx4dXkLCUmSpPl40+T5ByLixjsLIuIbgbOB48AF8+6YJEmSJEmSJEnLwBkYdGXF0KHRKJplw6Jsa9QeJ9Mq28p2nVO50XvZKItlK8b5jIqyYbEMtJtr2ig+nNOiPQXOZtHWZtHeZrQrbhQLMOhYr2/DYn2Nsl1W1TuVw6Je26nie3WqWCenyu/BqWbZ8UbZSdrfgeOj9tZwqqi3OWov+fFsx9ygvc0OiimdTkW7vY1REbP4XE/0fSgcFfE2ttplw3a90aC93NW+eWPQXidVvVFMX18bjderOgBRljWLGDTq7b0nSUbFNtZNL2NrXwH8OfB1wLsj4g+AjwNfxvj2EgE8ITM/2UdjkmoxhM3LppeNjhW5wmntmNW+tdqNFKlJu61yb9htv8uwKCz25XW9dlFWMVvrsur/oB2vWsdZnAt0LZv3bzK6ZNmt4yzUx+6qXpVzlfWKsmPFuc6gKmv0pWprs8i56mWr+tiuV+bEHddX15jNeMWydVWty1VQ739nYfp54QrnxJKWSJJLM7V237+QrdtajmWehUFxvbr6NeuoQ161l82iXnkNtig7vehnq6S6pnuyuv5aXIc8le1rfNXfIarrpSeLK8yb0Y5Z/d2gtexVPwbFydOJ4hryRnE+Vn3lBh3r1Rt0UdZele3rs0VbXXPD6vpBlbdn8fmU9arrusW5bevcsO/rvQDDDv3YmznxqnIAgyRJ0hxk5igi7gM8EngI8EDg6sAlwKuBZ2fmeQvsoiRJkiRJkiRJC+UABkmStFYSGHb5OfMeMXuJk3kK+JXJQ5IkSZqJZc6JJUmSpHkwJ15dDmCQJElrZ55TT0qSJEnLyJxYkiRJR5058Wqq7hIjSZIkSZIkSZIkSZJ6FBE3iYjnR8RHI+JERFwcEb8SEdedVZyI+OKI+PWI+OuI+Pjk/R+NiDdFxMMjYrO/JezOGRgkSdJaSWDY88hax+lKkiRplZgTS5Ik6ahb5pw4Im4JXADcEHgVcCFwR+DRwL0j4uzM/OQM4twS+E7gr4FXApcAXwB8I/B84GER8fWZudXHcnblAAZJkiRJkiRJkiRJkubj1xkPOnhUZj5n+8WIeAbwWOBpwA/OIM4FwHUzc7QzyGTmhfOAc4BvAX7v4IvUHwcw6MqG0S4atu84cnKrvSkd3xo2yy4bnD719WOD0dTXAQbF+KZBtMs2oh2zMizutDLMYn0N2vVOsdEsu0acnF4nTrXjRXsg1OnRXv9nlOukGEfWXmwGVWFhM9rrZFB8Bp3a69bF8l5Jp7K9nk9RlGX7MzhexSzKTm+UnSrW4/Fi+zqe7RmDNotl2ywG6G0W2+zmqF12PE9rlm2swu+BRu195XDQXpejYqMdFdtCdaOoUbH/GsX0siz3se2yql422tqr3l68t5mkvUQmx45P31cUu2so9p+R1b6n2O+2apQ5V1trPz6O2S3Hq84Tyv11Ua9avuZqHhTHlFHRVlWv3Q2qjzSLbaEqK4/BRXvtbLmt/LwL1XlVXVacx1X1ynO8dszNDu1tFjlX1Y9jRb2N5re4+7rsGrPreW+17H23teq6fBcBhtntLq6Dxjl97OMzMyeWtJcRyedy+rXIrvr+pWtXozI3X1/Lsv73UmURG+WJQpU/TTcowlX5ZHXd9mRxRnaqyl+L63jHs30ieqoo2yjOdU7m9LUyKJat6mOVo1bXkCsbRV9KVbXyhLldNGxtLEWdUZUTl9dm+7+mW+X0o0NcZ52X6pLEYXq/jDlxRNwCuBdwMfBru4qfBPwA8NCIeHxmXtZnnMzpB/7MPBURr2Q8gOFWB1ui/nU7e5IkSZIkSZIkSZIk6Wg5KyLePu2xz/r3mDyft3smhMy8FHgzcHXgznOKQ0RsAPeZ/Pede71/1pyBQZIkrZUkGfb8S4tcwpG6kiRJUos5sSRJko66Jc6JbzN5fm+j/H2MZ1a4NfC6WcSJiOsD/4Px5Bc3AL4e+FLgpcAf192fPQcwSJKktXM0JzSWJEmSrmBOLEmSpKNuRjnxhZl5+0PUP3Py/OlG+fbr15lhnOszvs3EtgSeDvxE5uLvw+QtJCRJkiRJkiRJkiRJWryYPB92IEEzTmZemJnBeLKDmwKPBX4AeGNEXO+Q7R6aMzBIkqS1ksCw5+ltFz7kVJIkSToAc2JJkiQddUucE2/PjHBmo/zau943sziZOQQ+BDwrIv4V+F3gqYxvL7EwzsAgSZIkSZIkSZIkSdLsvWfyfOtG+a0mz++dU5xtr5k8n7PP98+MMzDoykbRLMphu2xra6NZdrIoO7ExfRO8fOu0Zp1BtMc3VWUbHe90M8pu43xOZfvrdY1sr5PhYHp7J6NYx4NTzbIzaJedYtipbLO4/c1mtOudFu1taDPbn8+gqsf09bJZrK8B7Xgb0f682xHr9obFso2Kbfbq2e3zOdFo73huNescL9oqy6K9fV0+Or1ZdloR87RiG9oY9f8dH8T0ehuN1xeh2g+NBu3tuVolVb3xzFFT6hTfxWr/G53LmkV7GvrzMEl7GcHGiek7yijy3sYuclKxqlftmBr1ql18URbtQ36ZV1V5SdWXan1RxCxSpPZQ+3LB20XZsV75mRY5cXW3yGpLaB2DAUZFWStmFW8Wup6rledxHettDqbnlMeKXLOM17FelaPWy13UK7airjlsFbPvtlbdsOM1gkGxDY3KHVF35sSS9jIiuXRUJI9Lrr1nXS5H84g5G/M8tlVH/NOKPGijytWKss0iZnV9drO85rs5vR/Fydjx6vrroFjuImaVE7f6eCjVNdHqgmOHNK/K40bFufKxYl2Ohu2OVPWqv+F1PR9rnmtWdbpeG5nR+euS5sRvmDzfKyIGmVd8gSLiWsDZwOeAt8wpzrYbT54Xnhw4A4MkSVoryfg8pc/Hcua5kiRJ0nTmxJIkSTrqljUnzsyLgPOAmwGP3FX8FOAawIsz8zKAiNiMiLMi4paHiTOJdaeIuPruPkXENYFnTf77J92WrD/OwCBJkiRJkiRJkiRJ0nz8MHAB8OyIuCfwbuBOwN0Z3/LhiTvee+NJ+T8zHqzQNQ7A/wLOiYi/AD4EXA58MfCNwHUmsX6+jwU8DAcwSJKktTOc0TS8kiRJ0qowJ5YkSdJRt6w5cWZeFBF3AJ4K3Bu4D/Ax4NnAUzLzkhnFeR5wGfA1wDnA1YFPAW8Hfg94fmZxb5o5cQCDJEmSJEmSJEmSJElzkpkfBh6+j/ddDO2RGPuNM3nvn7AEt4jYiwMYJEnSWsmEUc836E1v+CtJkqQVYk4sSZKko86ceHU5gEGSJK2ZmMHUYMs51ZgkSZI0nTmxJEmSjjpz4lXlAAbtWw4HzbLhsP2FPTXcaJadaJRtDtub5rEYdSobFGWljt+S0aBYXxy8rIo3GhVl0S47Fe3b2ByPYbPsjKJsM9vr+bTiM9iM9rC1zWJE20Yj5iBPFW2118lmtrfXjWhv54PiMx0UB7Sq7PRob3ynFxtm6/M5vbht0RnF53a8qHfZqPi8B+2yy4qYm0XZgHbMjaqs2jeMTm+WzdOo2BZG2S0pquoNiu9cNMqOFZ9pdmwryzKTQUmzEwkbJ6bvg4pUh2wf8stz2HKf1tgX5qBdpwxX7T6LZYuiYg6q40bRXpGC56hYvka98pBY9LFsq6hXHUujKKuOi7Moa/Wz6n/XslmoztUGFOcJg/YGfazxRa7yks3qPKcoq2KWeWixbLOoV+lyvrxR9GMdtC50dr22MCoOIO2zUBg26sWar39J8zFMuHTOx/1VNnRdLbXq2tqy6PqH1NPK655FbtjIF8q8tzhpPJ6bzbJBcX25VFWrzr9nodGX6m8soyI3HBbnK6PiHPVYx3qta7pQn0NU5zOtc8OqrbqsWVRfQ24GNCdeVw5gkCRJayXpfkJYxZQkSZJWhTmxJEmSjjpz4tU17/FLkiRJkiRJkiRJkiRJV+EMDJIkae3Me+prSZIkadmYE0uSJOmoMydeTQ5gkCRJa8WpwSRJknTUmRNLkiTpqDMnXl3eQkKSJEmSJEmSJEmSJC3cSg5giIibRMTzI+KjEXEiIi6OiF+JiOvOOk5E3CUiXh0Rl0TE5RHxzoh4TERsNOI/MSJeHhHvj4hRRGREfOke/bpaRDwlIt4TEccj4t8i4vci4ssOsnySJB1NwZBBrw96Hqkr9cGcWJIktZkT62gwJ5YkSW3mxKtq5W4hERG3BC4Abgi8CrgQuCPwaODeEXF2Zn5yFnEi4puB3weOA+cClwD3A54JnA08eFczdwB+lvGMIh8EPg1cZ49+nQ782STe24BnAV88iX3fiLhHZv71XsvXWTH3SY7aX8rRqD0WZjhsl20Nr5LPA3Biq71pbsSoWXZsMGyWDYp6G1Es+Fa7aLhRLHcWZcUOrnU/nmFxn56Tg+nrEeDkVc+ZPu+0aK+vzWgv+Kk4VdRrxzwt25/BZvH5VGUbOf2zq0ZnVX3coCiL9mewWXymg6LeRlFvs/jsKoPG0p8R7e/VZvHlP71YX2cUn81lo2I7KbaFy7L6fNr9rPYNg1G7rG/Vd7+sV2y11fd/VGxDW0VfRsV6Hg2mx8xhu60o9qNVSlfVk9RmTtxDTpzJxonGvrDYf24ca5dlY/8JUKSNzcSlPKR0LCtSeqKoV6QD5Y6+OoeIUfsY0EwVquWuFq6oV/axY71qW8jquF6WFX1p1KvjzaKP3S7kjKqNvcjxuqjOBaqyQZGzlOcXVY7aNbetzo+KmFW9LvHWQXVu3iWrr7bljWI7KfvR+NyK00zpyDAnPnxOPCK4fLRyfyKYqb6nGtf8+Nnt3wbtvPCMQfuablGtzF8rgyLooHHtf96q67bVtdny3KlYX6Mi0avOIY4N2jG7XtdtnQdV16ulPqziDAy/zjiZfFRmPiAzn5CZ92CcHN4GeNos4kTEtYHnAUPgnMz8vsz8UeC2wF8BD4qIh+xq423AXYHrZOYtgXfso1+PY5yUvgK4U2b+eGZ+B/Ag4OrA8yOqy2iSJB1tyfgEoc/HcpwuSVdiTmxOLElSkzmxjghzYnNiSZKazIlX10olOBFxC+BewMXAr+0qfhJwGfDQiLjGDOI8CLgB8LLMfNv2i5l5HPjJyX9/aGegzPyXzHxTZn5mz4Ub9yuAH5z898cyr/jdUWa+CngT8J+Au+0nniRJktaPObE5sSRJ0lFnTmxOLEmS1tdKDWAA7jF5Pm9n0gaQmZcCb2Y8+vTOM4izXee1U+K9EbgcuMtkaq+ubgl8CfDezPzglPLX7OqLJEmaYkj0+pCWjDnxlfsiSZKmMCfWmjMnvnJfJEnSFObEq2nVbnB1m8nzexvl72M8YvbWwOt6jtOsk5lbEfFB4MuBWwDvLtqu7KdfTPpVioi3N4rOOminJElaJQkMyxvHd4spLRFz4jFzYkmSGsyJdQSYE4+ZE0uS1GBOvLpWbQaGMyfPn26Ub79+nRnE6avtyjzakCRJ0mozJz58G5IkSVpt5sSHb0OSJGkprdoMDHvZnrvjsANgusTpq+1e2sjM208NMB5xe7tOrVetZnvalNGoPU7m5NbG1NePbQybdU4M25vtscGoWTaI9gJsFGWzMCqmmTk1mL5OhsV4o1PZXienBu2yzdhqlp0Rp9oxo1vMzWh/rqdlu6yqt9HYMKvPezPb20m1LWxmt21oUGxe0z/t7Zjt5a5Gn200tq9BtLe7Vp29yk6Pdk8Gxfdxo/q8q8+n2BENOtZbFtV3fFTtY4sRpMeivU5Ggyrm9Hpb1eddfQeKsuqTiUa9YlPefgej3sdoOj2YVoo58fYbipw4RtxucLK9n2zG3GjvDwYbxf6uOOiPGjEHRRKRxX682F3XZe3Dc5lHjIp+VjGrXXWOprdXHNqqUxIYFZtLsS6zyP+yPAcqtpNqudtFnZSncFX/i+Ne17yklV8A5WG26suw6Muxng/dG8XGV56vdKw3KOp1zW3rmAffH3ZV5YbV9jULgw45Y7WdV+dw1XSzVS/a7e21HZgT68gzJ95+Q5ETj4jbXZabvXZsFVTXYHRV1bFP66fKWarcttpOqr81bFQXz6sUdQabZevc43Taf/OoVOcrnc+5Bu18szoPbV1nhT2u3TbKutQZl1XrZBbMiVfVqh15tkeWntkov/au9/UZp6+2++6XJEmSjhZz4sO3IUmSpNVmTnz4NiRJkpbSqg1geM/kuXVvr1tNnlv3BjtMnGadiDgG3BzYAj6wR9t990uSJO2QjEeL9/lY/jk8dMSYE1+1X5IkaQdzYh0B5sRX7ZckSdrBnHh1rdoAhjdMnu8VceXJTyPiWsDZwOeAt8wgzusnz/eeEu+uwNWBCzLzxF4LUbgI+BBw64i4+ZTyb9zVF0mStEsCwxz0+jAx1ZIxJ75yXyRJ0i7mxDoCzImv3BdJkrSLOfHqWqkBDJl5EXAecDPgkbuKnwJcA3hxZl4GEBGbEXFWRNzyMHEmXgF8AnhIRNxh+8WIOAP42cl/f6Pzwo37lcBzJ//93zuT5oj4ZuC/Au8C/uIw7UiSJGl1mRObE0uSJB115sTmxJIkaX0dW3QHOvhh4ALg2RFxT+DdwJ2AuzOeMuuJO95740n5PzNOQrvGITM/ExHfzzhBPT8iXgZcAtwfuM3k9XN3dzYiXrjjv2dNnn8xIi6d/Ps3M/Mvd7znGcA3AQ8C/joiXgd8CfBg4HLgezNz1Fg3kiSJYET0HlNaMubE5sSSJBXMiXUkmBObE0uSVDAnXlUrN4AhMy+ajGx9KuNpuu4DfAx4NvCUzLxkVnEy85URcTfGSeu3AmcA7wceBzx7MjJ2t++e8tq37Pj3+cDnE9PMPBERXwc8AfgO4LHAZ4BXAk/KzHftZ/kkSZK0vsyJzYklSZKOOnNic2JJkrSeVm4AA0Bmfhh4+D7edzHFUJj9xtlV582Mk9j9vv/AQ3Ey83PAkyaP+apu3lKUVWN9h8P2KhhuTL+LycmtjWadjWh35MSgvUkPinrzNio2i2FOXyejxusApwbt9XUq22WbMWyWHY/NZtlpRb0zBqeK9rbaZbRjbkR7A2stw0axUVbLvTH1/HK7XjtmVa+6K1K1Pdcx21oxB8VXoL2V1Dai22jDM4p65foanGyXjap68/tBQvVdHQ2KsmLk5taoXW9r0N6et6q+FPuhrca2fqxYj619F9T732HRj3a9en+ewLDnu2QtzxFEuoI58SFlEqem70OrPchgs126cbK9t8iNYn/XOBAXaRxFOlOXFQtXHdaL3TwUh9mqvRy1G4zGcb38jWHVx2ITnP73hYmij1kkV2XI4rg+KGO2+9I6rkeHOrNStTeLvrRysrKtGaySQXEOUZWV5yzFl67Ku6p6zTpFH2ei42dQ5aKV6jy0lU+OOqxHgEGxk6rOITYa28Jeq8qcWEeFOfHhjHLAZaPTZxH6wEardbfrhRr669+5qPKLuedIHXXNkeapWpfV3xrKlKzjYjfXVxGvPM8ZVOdA7aDD4npvfQ25+HtCcZ5QlY0aZbPYC0XRj+rctmJOvLpWcgCDJElSU87gBK3nzDQi/ivwGOAuwPUYTzf6D8CvZOar+21NkiRJR86S5sQR8QXAA4H7Al/JeFr/k4xz4RcAL3BKfEmSJPViSXNi7c0BDJIkSXMUET8J/AzwCeCPGU9Nen3gq4FzAAcwSJIkaV09GPgNxjnwG4APAV/IeBr93wS+MSIe3Jh+X5IkSdIR4AAGSZK0VpLoferJ7GlitIh4MOPBC38OfEtmXrqrvH3/HkmSJGmfljgnfi9wf+BPds60EBE/AbwV+FbGgxl+v4/GJEmSdHQtcU6sPSz/DXAkSZLWQEQMgF8ELge+Y/fgBYDMLG7uJ0mSJK22zHx9Zv7R7ttEZObHgedO/nvO3DsmSZIkaWk4A4MkSVo7w1zKkbB3AW4OvAL4VETcF/gK4Djw1sz8q0V2TpIkSetlSXPiyvZg3q2F9kKSJElrYwVzYuEABkmSpP06KyLePq0gM2+/j/pfM3n+V+Bvga/cWRgRbwQelJn/fqheSpIkSbNz2Jx4qog4Bjxs8t/Xdo0jSZIkafU5gEFXEsVIpKzKRlVZ+04lo9Fo6utbw41mna2N6XUAThX1BmSzrDKIbvUqw+LuLa2yUXFfnVPZXu5Tg3bZZgw7lZ0R7RnOTxZ9Oa1jexvR/sw3Y/oPMzbpFm+j2E4GZb2qj0Vfst1e1ZdKa5stl60o2yi+A1X/u96jaKMYEFnFvPqg/SOdQdHPvg2z+n63F66qV32Py/1Jsd+uyo41+rJVba/F92Mr2n2cxfjXpF4vXWP24IaT5x8EPgh8HfDXwE2BXwa+AXg5TpkrzUdCnGrvu1oGp4rc9lh7rxbD4pjZSBVyq8ixN9rxclj0o9g9lmXtdIbBoN3eaNDuZ3HooJVaVecdVMf7sq0q+SjWc1UvqvOqImbX87Gef1EyKuKVZR2P7FW9KmcZFflTvYE12iryh+r8outyVzqfXxTLPShitnL+qh/zVn4+xTrp+ourjUZ7XfPM6pxrVKzndnt1hrrEOXHLLzCenezVmfmns21K0rYhwaWjqy26G0ulunbT9Vpd1/Y0e2U+qaVWXbM+rZjMaVScq9G6BFucDw8HxTWCIg/dal0I2KtesR86VsWszrmKv+G1VH83ixn8Ta2rFcyJNeEABkmStGZiBiegAXDhYX5VxhWnQcF4poV3TP7/TxHxQOC9wN0i4mu9nYQkSZIOZ2lz4qtGjXgU8HjgQuChfcaWJEnSUTaznFgz5vAySZKk+fjU5PkDOwYvAJCZnwO2f2l2x7n2SpIkSVqQiHgk8CzgXcDdM/OSBXdJkiRJ0oI5A4MkSVorSzw12Hsmz//RKN8e4OD8nZIkSTqUJc6JPy8iHgM8E/hH4J6Z+W89NyFJkqQjbBVyYk3nDAySJEnz8UZgC7hVRJw2pfwrJs8Xz61HkiRJ0gJExI8zHrzw94xnXnDwgiRJkiTAGRgkSdIaGuby3YssMz8REecC3wn8NPCT22UR8fXANwCfBl67mB5KkiRpnSxjTgwQET8FPBV4O3AvbxshSZKkWVnWnFg1BzBIkqS1kgSj3qcG6y3RfRxwJ+CJEXFX4K3ATYEHAkPg+zPzP/pqTJIkSUfTsubEEfHdjAcvDIE3AY+KuErcizPzhYduTJIkSUfasubE2psDGLR/xY1dctT+wmYxumk4nL7j2NgYNeucatQB2Bi0yyI22mXD9sIN2GyWVapRXacP2n3ZapRtFct2+mCrWXYq222dHu16m0XMUbT7slms5+PRXs+nVX2JYbNso/H5lHWivX0NaJdV9Tbp1l5lo/jSDYqYGzm9rHu8dr0qZmVQbAtVe11V/bxGnJpe0DGvGWW7YnW/rape9T2uyraK7+PJ4jNofT6DchvqvyyKslWVmf8WEXdiPPvCA4E7A5cCfwL8fGa+ZZH9k46UTOJU+/jdEqeKPGKzvS8fbLX3aaNj0/PGIp3pXtY+NFClLFVZI/UYq2JW5xeNsvLQUJ2TVMf1IveoznNiUNQrzgXqsmYRo6LeqFGvaquO163/XWPOwqhxUanKx44VG+yw2Iiqc495q85nTiv62VqGrucyXZXruTjnGhYXETeLTa/O3ad/sarPu7oOsFFse9V22crBV/iy6c0nzxvAYxrv+QvghfPojHTUjRhw2WjaHQ41Td9/BJu36jhbmXc+0Leuy70qqjyii43qJG4NVNciW/nmGYPG9WPa5x1QnwNVn1uVUx4rtuetoqy6rrsxKK5zNGJWZ0Ddr/eucIar3jmAQZIkrZ1lPjmdTJH7uMlDkiRJmollzIkz88nAkxfcDUmSJB0Ry5gTa29+apIkSZIkSZIkSZIkaeGcgUGSJK2VpJ6+rWtMSZIkaVWYE0uSJOmoMydeXQ5gkCRJ6yWj/6nB5nzfbkmSJOlQzIklSZJ01JkTryxvISFJkiRJkiRJkiRJkhbOGRgkSdJaSWDY8xhNpwaTJEnSKjEnliRJ0lFnTry6HMCgK6u+eWVZe8qUHBXVRtPrDYftHcpWbDTLTg3anawmdRlE/7uc0Ua7xVExZc2osS6r+/ScyvY6OT23mmXDQbsfm0XMU9HedWwO2u1txrBZdoLNot7BY25Ee8Mb0C7bKLaFjaLeoGjvtGK5K3U/i7LGl7XveHup1slGtWMoVH2p2uu7rTPiVLPsWhufa5ZVyVLruw/1d7xr2bFRe30da6zLY4P2trxV7Neqfews9r+StB+RSZxq5BjFuW0M23lQbBX7uw5lxW6c0bB93BgM221lUa9Is6l219UhOBr5PkCOity9Ua+q0/lcpuhjtS1kdQ5UNJjVIpQxD16vyi+6xIPu9w+tz4HaG1HXeu061XlasWxFUTUladV/ivOEKm/cpNv5RaV1PlCdi3U9T6gMo9v21XVa2FG067ViDouNYaP43IbVuUx1rtaIaR4tqQ+jDC4fnd5rzL7/UKSDKXMPraUqN+liFjnequiyLqu/eWwW11I3s7jOWpycbxUn4F3LBkVO3Mo5q1x02PEWC2F+qx0cwCBJktZO+QcISZIk6QgwJ5YkSdJRZ068mhyOJ0mSJEmSJEmSJEmSFs4ZGCRJ0lpJYgb3NnOkriRJklaHObEkSZKOOnPi1eUABkmStHa856MkSZKOOnNiSZIkHXXmxKvJT02SJEmSJEmSJEmSJC2cMzBIkqS1ksCw56m8stdokiRJ0myZE0uSJOmoMydeXQ5g0P5l8SXP9lc2i3qtstGoXWdUxNsaticVGUSxW9kqvgodvyWjYqdYLUOrrIp3LDaKeO11cirb9TZj2K0s2yusqjcodvubg60Dx9wo4g1idOB445jtehtFzONlvXY/q/aqZWjHK9rqEA9g0HGdVMrPrmivjNnz+qqSnk3a29A1BieaZdX38Xie6lTvxKj4Pg7a/dxq7DdOjtptVfvY6vtdacX0LmOSejOcvi+MrSKn3GofU3LYLhtVeepw+v5uNGzv8YrdOFkc9qpD4tzLisNDaxnqOt3OV8rDVOeyqi8HPz86TNk8Vec58z6ADxt9OVb0o8t5GtB52cqpTIvzkuoerhvlRJvFjqODrucCVZ5dqXLwrve1HRX1hjG9vVPFOe+w47lM9bm1YoaXTiX1YMSAS0dnLLoba8/py7Uuhku0LXe99lzpe/nKv3kU+f6p4oT/WNHHrmVbxflyaxmiODmvTo+qa8h9DzTQanMAgyRJWjMxg4sDJtCSJElaJebEkiRJOurMiVfV8gyXkiRJ6sH21GB9Pvx9myRJklaJObEkSZKOumXPiSPiJhHx/Ij4aESciIiLI+JXIuK6s4oTEbeKiB+PiNdHxIcj4mRE/GtEvCoi7t7f0h2OMzBIkiRJkiRJkiRJkjQHEXFL4ALghsCrgAuBOwKPBu4dEWdn5idnEOdngG8D3gW8GrgEuA1wf+D+EfHozHx2P0vZnQMYJEnS2vH+kpIkSTrqzIklSZJ01C1xTvzrjAcdPCozn7P9YkQ8A3gs8DTgB2cQ57XAL2bm3+0MEhF3A/4M+KWIeHlmfqzTUvVkaT81SZIkSZIkSZIkSZLWRUTcArgXcDHwa7uKnwRcBjw0Iq7Rd5zMfOHuwQuT1/8COB84DbjL/pdmNpyBQZIkrZXMYNjzyNrM6DWeJEmSNEvmxJIkSTrqZpgTnxURb59enrffR5h7TJ7Py8zRrvqXRsSbGQ9MuDPwujnE2XZq8ry1j/fOlAMYdGU5g3qj9glu6+R3VNQZDts7m4h2R2JYlBX1Tg03mmWzMGqtE9rr5FiMmmWteADHih33VrSX+9Rg2CzbzHbZoFjPm1HFbPdlo7Hsg2Kj3By0970bRb1BsZ6712uXVeurqtdaJ5VBEa+yUfSxrFcud8e+dNyBtbehbv3o6ow41Sy7+uBks+xU8f04fbDZLDsxaqcAg0Z6UG2T1Xeu3Dd33Ib2Uu0zJQmATGJrev6Rg+Lkdqt9fIitYn9X1WvkmzEq4hWHqRi294FlzKIeVUpc7crL84R2USsVzeI8IbJorDonqa5lVDGLPDuL9ZxRnR9VXWnXa+X8XerMrKw4Ns8i5rKoLpZV50DlNKdFva5a/dzsuIqr3Hwzup2PVYbF92pYTD5areeTjTy7Ogeq+nEq2/n3sDqfbOws9/PRrMJ3RNJijTK4fHj6oruxFtznal30/cfeddDlejt0X5fVeUL1d5uT1bXbnq/rVvGWzZLun28zeX5vo/x9jAce3Jp64EFfcYiImwL3BC4H3li9dx4cwCBJkiRJkiRJkiRJ0t4u3OdMCy1nTp4/3Sjffv0684gTEacDvwOcDvxYZn5qj3ZnzgEMkiRprST9jxZfnTHFkiRJkjmxJEmStMI58fa0EYdtbs84EbEB/DZwNnAu8PRDttkL54KRJEmSJEmSJEmSJGn2tmdGOLNRfu1d75tJnMnghZcADwZ+D/iuzOrmlvPjDAySJGnNRHm/7K4xJUmSpNVhTixJkqSjbmlz4vdMnm/dKL/V5Pm9s4oTEceAlzIevPBS4GGZOdyjvblxBgZJkiRJkiRJkiRJkmbvDZPne0XElf5WHxHXYnw7h88Bb5lFnIg4DXgF48ELLwYeukyDF8ABDJIkac0kMGTQ62Mp5s2SJEmS9smcWJIkSUfdsubEmXkRcB5wM+CRu4qfAlwDeHFmXgYQEZsRcVZE3PIwcSaxTgf+APhm4LeAh2fmqIfF6pW3kND+Vd/KYgqW6nYpra9ERntszWjUjjcatettNUtgsESzII4anRlle9mODdoDo6rpcY4VMU9Gez2flu21eTLau5Vj0e7niaLeZlFv0OhnVWcj221Vh5+NaO/DO9cryjaKmF3rdYlX2aBbvdbnNqv26s+u32PzRsdlK2MWfay29ars9EH7e3xiMP07cmzUbVvu6jC75v6nBpO0dhLYmr6fjEE7R4phMSB91M4xqt1kDKcfO2LU3pcVu/i6rWp3XRzCyphd6xXLl42cvzhNoLxLY9eyso9FveIEI4sGszyvajfXKipOncq2quNoVVbFnLfW+VN1XlV+saq2OmYtw6LeZtVetZ6LomHxG5ZNpi/7sFhfVa7ZVXkeV3x3qnVZlY2KddLKb6tt6GRuNMuq84STFPUafYx9nPeZE0vay4jg8tFpi+5GZ133c9V1KfedWkZ9b+tu56urugZ7rGNZFbPLdfyu1/5nZYm39x8GLgCeHRH3BN4N3Am4O+NbPjxxx3tvPCn/Z8aDFbrGAXgucB/gE8BHgJ+OuMo6Oj8zz+++aIfnAAZJkiRJkiRJkiRJkuYgMy+KiDsATwXuzXhQwceAZwNPycxLZhTn5pPn6wM/XYQ+f5+LMhMOYJAkSWslifLXdF1jSpIkSavCnFiSJElH3bLnxJn5YeDh+3jfxRTz7e03zuS95+yzewvV76cmSZIkSZIkSZIkSZLUgTMwSJKktTNc3nubSZIkSXNhTixJkqSjzpx4NTmAQZIkrZVMGPWcmGb2Gk6SJEmaKXNiSZIkHXXmxKvLW0hIkiRJkiRJkiRJkqSFcwYGXVk1cqhzWXt0UzbKqhFMo1E73nDYHpMT0Q66VdTrqhrVNdooliFH0+sMhu14FG0V/TiW7eU+FtP7AXBqtNEs2yz6OSh2OceKeiejqBfT650o6mzQXrZBsZ1UZV1jbhTreVB+sdpaMat4VT8qg471Njou27zb66J7H/tftjMGp5plJ0bt78hmaxuqtteO352q7DBGxf5NksYSho38o8opt4p9YVGWw3bZaDS9vcGwvY+scuLqUNRInfauN4uy4hDQKqvOE6q2yl9IzL2sOj8qqnX41UhVp+9foeylPD+qyopznWoq0GNHdJbQYZEDbVY7gBVQ5Y2bHXPpU8XvejaZvr5O0T4frvLlKj8dFP1vtRf7OMcxJ5a0l2EOuGzr9Lm11+Waifuy1VXlcbPQ9Vpqy7z7L81S39d1Z3VNdxY8jqwmPzVJkiRJkiRJkiRJkrRwzsAgSZLWShIMex4ln466lyRJ0goxJ5YkSdJRZ068uhzAIEmS1s68p8WWJEmSlo05sSRJko46c+LV5C0kJEmSJEmSJEmSJEnSwjkDgyRJWjujdIymJEmSjjZzYkmSJB115sSryU9NkiRpQSLioRGRk8cjFt0fSZIkSZIkSZIWyRkY1I/sWDaafu+ZHLQr5ag97mYUo2bZcDjf8To5aPelrNe4H091n57hqN3W1qC93MeyXe9YDJtlg2h/PlvFaLZBsTEcK+ptFO0NGruxqo+DYjup2+oWs+rLBt3qVWVd2qp0aQtgo1on5Y6hW8y+LVMfq+2re8yDb8/l96Pn7fUwEhjR773NZrEEEfHFwHOAzwLXnEETkiqZ5Nb0fCc2Ntr1hsU+ucjJGLb3JDGaXhbD9r6sVWdc1u4GRU5ZxazqlSlGeS5w8LLqkJLlOUmx3J1jdltf2bnewcuqOpV6sdsxq+Pvstx3tOrjsPiNR1W2SfvcqWtOMizqbXaK2L9R+ZuY9jqpdF3uKnevctjNYod5qnGOulGdFxY7tlMUx5ZKo7m9tqxVyYklLVZm8LnhshxZNGvVcaHrdbC+jzWS5m+Zruv2zZx4dTkDgyRJ0pxFRAAvAD4JPHfB3ZEkSZIkSZIkaSk4A4MkSVozwbD3X3n2/ouCRwH3AM6ZPEuSJEk9WomcWJIkSZohc+JV5QAGSZK0VjJhVNyWpmvMvkTElwG/ADwrM98YEQ5gkCRJUq+WPSeWJEmSZs2ceHU5gEGSJGl/zoqIt08ryMzb7ydARBwDfhv4EPATPfZNkiRJkiRJkqSV5wAGSZK0dka9Tw3Wm58Gvhr4L5n5uUV3RpIkSetriXNiSZIkaS7MiVeTAxi0b1F8ycspU0btombIUdFWsa/Jot4oqp1Uv1PIAIyKdVLtMFv349kYtfs4HLRX8ka2y4ajdtnWoN3eINoLd6yIOYiibLTRqb1W2YCD1xmXFeuyqtexvcos+tKlra7936i+/GVf+l+XXcyi/11tFJ/PLGzGcOrrXbatNXPhfmdamCYi7sh41oVfzsy/6q9bkjpJYDR9f8ew8TpAkevEVlFWJIcxnF5W1iny3uqwMZOy4vDQd1l53lHk2FFUXJXpH6t+ZocLMl3qzEo1peeoOJ+pY85v+YZF/1t5FewxlWlRbxaGjfu4bs61F7OxUeSwm8Vmssn0z+BUsUPcLD7T40U/qj62ztVijudGktbXiOBzw+l7+1Fxj2+vDyxW9dlo8WaRh/Z9vbFrH7v2Y97tVbr0ZZ7XpFeFxwHNmgMYJEnSWkn6P5k/bEq+49YR7wV+6vA9kiRJktqWMSeWJEmS5smceHU5gEGSJK2ZmMFo90PHuyZw68m/j8f0WYGeFxHPA56VmY85bIOSJEk6ypYyJ5YkSZLmyJx4VfU/b/4cRMRNIuL5EfHRiDgRERdHxK9ExHVnHSci7hIRr46ISyLi8oh4Z0Q8JiKa899HxHdHxFsj4rMR8emIOD8ivql4/1dGxO9ExPsj4nMR8ZGIeENEfFtErORnJknSEXcC+K3G4+8m7/nLyf+9vYT2xZxYkiRJR505sSRJ0vpZuRkYIuKWwAXADYFXARcCdwQeDdw7Is7OzE/OIk5EfDPw+8Bx4FzgEuB+wDOBs4EHT2nn6cDjgX8BngecBjwE+KOI+JHM/NVd778f8P+AEfCHwCuA6wMPBF4GfB3w/XstnyRJR1l5T+kFyMzPAY+YVhYRTwa+GnhRZv7mPPul1WVObE4sSdJeli0nlvpmTmxOLEnSXsyJV9Mqfmq/zjiZfFRmPiAzn5CZ92CcHN4GeNos4kTEtRknlkPgnMz8vsz8UeC2jH8p+aCIeMiuOndhnJReBPznzHxsZj4SuD3jpPbpEXGzXf36BcYDS+6VmQ+e9OsRwJcD/wY8IiK+ZJ/LKEmSpPVkTmxOLEnSyurrV/M68syJzYklSdIaWqkBDBFxC+BewMXAr+0qfhJwGfDQiLjGDOI8CLgB8LLMfNv2i5l5HPjJyX9/aFesH5w8Py0zP7Wjzna7pwMP31XnFsBnMvMvdr6YmR8H/nry3xtUyydJ0lGWwCij10cueqGkHcyJzYklSdrLMufEk1+7v53x8f+tjP9I/AHGv3b/q4j4gp6a0hozJzYnliRpL8ucE6u2areQuMfk+bzMHO0syMxLI+LNjBPOOwOv6znOdp3XTon3RuBy4C4RcXpmnthHndcAPzV5z5N2vP5PwO0j4r9k5l9uvxgRN2Q8ddlHgXcVy3Y4GUVZ8bWsvrFdykbtfmS0A446jsnJatnKeu1+bhRluza7fcXMQVGnWQJbo/Y6GRYxN4o+DorP4FTRmyjqHSv6UrU3aLQ3iI7xirJKlz4eKmaxfBsdlqHqY9d1UrbXc/+h+3ru1FbR/7refNObDbr181ROv13nLL47lcNEHFEcz5ZMZj4ZePKCu6HVYk7cV048mr6nyVF7/xnDIicbFnlQo62yrNiNl7vdoqw8hHWs1zVmXdbYjxd5e7VOynS/7z5Sn1/U/ex2/Go1N+oYr6rXNWbZXsfjdjkVaId8rfNyzzntGBbnvZsMe22rPsdutzUsVspm177M+TM4oxFzs9gxnOi4/jeqnU2jaD/nP0ucE+/8tftztl+MiGcAj2X8a/cfbNSVtpkT95ATjzK4fOu0w4SQlt4SHw91CFUutCyfedfr1cvSf+h2/tf1OnF1PnxUrhPrCis1AwPjKbsA3tsof9/k+dYziNOsk5lbwAcZDwi5BcBkVO6Ngc9m5scO0NfHAp8B/jwizo2In4+I5zFOWC8FHjC5j3YpIt4+7QGctVddSZIkLTVzYnNiSZJWUl+/mpcwJzYnliRJa2vVZmA4c/L86Ub59uvXmUGcg9bp1NfMfFNEfC3we8B/21F0KfAC4B8a8SRJEuPRun3/OrTrL2KlGTEnNieWJKm0xDlxX7+al8yJzYklSSotcU6sPazaAIa9bG81h53Hukucrm1f6f0R8fXAy4C3AQ8DLgRuBPwPxlPo3Tci7jYZzdsOmnn7qZ0cj6693QH7KEmSpNVhTrwd1JxYkqS+nTU5jl5F67i7y35+7X4vxr9EdwCDDsOceDuoObEkSVoxqzaAYXs06pmN8mvvel+fcQ5aZ6/3X2XkbURcDziX8X3SHpiZl0+KPgA8LiJuDjwA+C7ghY24kiQdebO4P7e0RMyJzYklSdrTkubEff1qXjInNieWJGlPS5oTaw+DRXfggN4zeW7du+xWk+fWKO7DxGnWiYhjwM2BLcZJJJl5GfAR4JoR8UX7bOMuwHWBv96RlO70hsnzfka0S5IkaT2ZE4+ZE0uSNH8XZubtpz16it/Xr+a1/syJx8yJJUnS2lm1AQzbidm9IuJKfY+IawFnA58D3jKDOK+fPN97Sry7AlcHLsjME/us84273gNw+uT5Bo1+b79+slEuSZIYj6zt8yEtGXPiMXNiSZIKS5oT9/WrecmceMycWJKkwpLmxNrDSt1CIjMviojzGN8L75HAc3YUPwW4BvB/JqNaiYhN4JbAqcy8qGuciVcAvwg8JCKek5lvm7RxBvCzk/f8xq4uPxd4KPDEiHhlZn5qUudmk3ZPAC/Y8f6/Yjw69+yIuFdmnrddEBFfDPz3yX9X6x6A1Zj5RlmOip1AVDuIdmOjot5g1I44LMb5ZLbbK4rKndxwNL3ixqBdZ2PQ7uNGsXDDoh8bo3bMQbQXriqLouxUY7kBjkXxATVUy131sVIud7HtDTr0f6/2utTrHK/jD1+697/b+qpsdOxLy7zXybJYlQQt6b+vq/3Jad2YE/eUE2fCcDi9bFiM8x61j1NRJIAxLMoaeVB12GjVGZe194F1zHZZl5z+MO216lXxqvy7a/9LZcz2Z5BVWRG0qtdFsQkdIma7j12PzX0f06tzoGMzSHWG2d6fbEZjHwSMinoU9eq+tBdwczXSvLnaaFxD2KjqVOeFtD+34x12RLFHnSXOifv61byOOHPifnLiUQbHhyv1JwKtkL7zV6ivL3dpr4pXmcWySatkRP/nfpXmd26PtpY4J9YeVjE7+WHgAuDZEXFP4N3AnYC7Mz65eeKO9954Uv7PwM0OEYfM/ExEfD/jBPX8iHgZcAlwf+A2k9fP3VXngoh4BvA44J0R8QrgNODbgOsBP5KZF+94/0cj4mcYJ8eviYg/Bi4EbgR8C3BN4A8y89UHWF+SJElaP+bE5sSSJK2iK/3aPTM/P5ztgL+al8Cc2JxYkiStpVW7hQSTEbJ3AF7IOJF8POPRs88GvjYzPzmrOJn5SuBuwBuBbwV+BDjFOPF8SE75OX5mPh74HuDjwA8ADwP+CbhfZv7qlPc/FXgAcB7je509Hngg8A+Mk+kH72f5JEk6ykZErw9p2ZgTmxNLkrSXZcyJJ7nHeYz/gPzIXcXbv3Z/8a5fu0tTmRObE0uStJdlzIm1t1WcgYHM/DDw8H2872Job037jbOrzpuB+xywzouAFx3g/a8CXnWQNiRJknS0mBNLkqQVdaBfu0sVc2JJkqT1s5IDGCRJklqSmMG9zRxdK0mSpNWxzDlxZl4UEXcAngrcm/EfgD/G+NfuT8nMS3ppSJIkSUfaMufEqjmAQZIkrZek98SUq0z+KUmSJC2xJc+Ju/zaXZIkSTqQJc+J1TZYdAckSZIkSZIkSZIkSZKcgUH7V40qKsuK0U2jxuvRDpijIl41kKrVFjAqhvIMqnpFc/X4oHbNjOkLUa7ibJeOioqDYn0Ni89gUJRF13rtrnCqQ8woFrzqR1lWfArVcle69qXvtsp6HYcUDqL+hrTrzXcI47Ks52XS5TPvOpK1qtcq20/veh9ZK2ntJEkOh1PLIovTpCLvYlQljgdPKqt8psqxq0NR95jd6pUJc5fzi47nJNU6yar/1XJ3NYuQhzhmHiQeLNcxtswjnNZz5obFOt4s67XPlTeZvl9eJtWZ/mZ0uw6w19WFg/bj81GX6PsqaTklcGLonwjUXZlLF6prqV1jdmlrHfS9vqTD6nK9F2a3LZsTryZnYJAkSZIkSZIkSZIkSQvn8EpJkrRWkv5H1q73WH1JkiStG3NiSZIkHXXmxKvLAQySJGntOH2eJEmSjjpzYkmSJB115sSryVtISJIkSZIkSZIkSZKkhXMGBkmStGaCEX2PrHWkriRJklaJObEkSZKOOnPiVeUMDJIkSZIkSZIkSZIkaeGcgUG9iOIeMkm2K7aKRsUIpmpw0+jgTe1lVAzzGRTtDavFznbQaCxfFvGq1TUoPptqVQ6i3WAUZRuDbvUqXfpS1unYVqVrvWqdzLsvzXgdvz1dP++uel/uOfd/Fua5LVQjWbeKHWl1D7Ku9ydLYNTzvc1Wf2uQNFUrwRoO23WGRQI4qhK2dlG06hXxouhiMx5AlRtWO7uirKrX+VDUqle1VYXr2I/yPKcK2nm5q/Y6xmzGa7fV93F0r/ZWXbm+iqJhcV64WX3JC8PidyqbnSIeXcPGl27QOmnfo+yM8jdExUGiURZ77GjMiSXtR2Zwcrix6G6ooct+fBbXs7oeT7r2ZRa5qHQUzOKcq8s1/q7Xe6vvvteJjx5nYJAkSZIkSZIkSZIkSQvnDAySJGm95AxGHDu0VpIkSavEnFiSJElHnTnxynIAgyRJWjtONyhJkqSjzpxYkiRJR5058WryFhKSJEmSJEmSJEmSJGnhnIFBkiStlaT/qcGcGUySJEmrxJxYkiRJR5058epyBgZJkiRJkiRJkiRJkuYkIm4SEc+PiI9GxImIuDgifiUirjurOBGxGRGPjogXRMTfR8TJiMiIeER/S3Z4zsCg2SuHIzVGPmVRaVQ0VQykiiJkjrqNwBpFu14UDY6q5WvUy2yPNyq6wahYtqqPVczBoP0hDIvPZ1B9CIW6n9PLBh0H1VVtVWaxbF3b6/uOTl2XrWu9Stf11bdZLNu8LcsyVPcgG46m7/f2HjUbM7i3mfdKk9ZOAqNG4jKqEscqT20nQlHVa5RFkVfV8Yr8r9r9HzxF3bNepYrZKitz+rKP1TppVywXrTrWdPx8yhaLeq1jY9+/NNlLefytzlmKevO8X+moOOfqumxH1bBYl5sx7L290Qp8CJvR9TdE0w8Ge5/zmhNL2tsog5Nb/olgkapTjy66XhPtux+SavM+V5un6hp+tdzVbqj1d669d13LmxNHxC2BC4AbAq8CLgTuCDwauHdEnJ2Zn5xBnGsAvzL5978CHwe+uI9l6pMzMEiSpLWT2e9DkiRJWjXmxJIkSTrqljgn/nXGgw4elZkPyMwnZOY9gGcCtwGeNqM4lwP3Af6/zLwR8PwelqV3DmCQJEmSJEmSJEmSJGnGIuIWwL2Ai4Ff21X8JOAy4KERcY2+42Tmycx8TWZ+7DDLMGsOYJAkSWslGU8j3OfDH5xJkiRplZgTS5Ik6ahb4pz4HpPn8zLzSveMy8xLgTcDVwfuPKc4S8cBDJIkSZIkSZIkSZIk7e2siHj7tMc+699m8vzeRvn7Js+3nlOcpXNs0R2QJEnqVUJm9B5TkiRJWhnmxJIkSTrqljcnPnPy/OlG+fbr15lTnKXjAAZJkrR2Rn0nppIkSdKKMSeWJEnSUTejnPjCzLz9LAJPbHf6sMMl+oozdw5g0JVEsQln1827qtfab1R1qp3NqF1UdqMIWS52scKyCBpVg62Y1QdQ9KNqK8p67eZGo24xK+Uq6RCzcz+KskHnZev/2FDFHDQWYhb96LpOuprFMnTRdbmrZGkW63IVLlcOi3UyLPY1knR4SQ4byWORd8WoSjiLfXlRL0bT60UVr1tquFT1Sq161blA1xOWWfS/o87nXJ3a6nacXY5sbGxUZDutHGOUxZ00o/h+d1T1sXPMchmG/cbsGG9jButy1Q2Ku7ieHtUdXremvhorke1LWnYJnNzaWHQ31t4886fq6LBMeZwOpmvuvizXUo+q3n/5v4eun3eXfs5i2xqN2jnxvNflHGzPjHBmo/zau9436zhLxwEMkiRp7czzD0CSJEnSMjInliRJ0lG3pDnxeybPt26U32ry/N45xVk61RBvSZIkSZIkSZIkSZLUjzdMnu8VceXp2CLiWsDZwOeAt8wpztJxAIMkSVoryXhasV4fi14oSZIk6QDMiSVJknTULWtOnJkXAecBNwMeuav4KcA1gBdn5mUAEbEZEWdFxC0PE2eVeAsJSZIkSZIkSZIkSZLm44eBC4BnR8Q9gXcDdwLuzviWD0/c8d4bT8r/mfFgha5xAIiIJwBnTf5728nzwyPiv0z+/ZeZ+ZuHWLZDcwCDJElaM+PRsH3HPHSEiC8AHgjcF/hKxonnSeAfgBcAL8jM0aEbkiRJkpY0J5YkSZLmZ3lz4sy8KCLuADwVuDdwH+BjwLOBp2TmJTOMc2/gbrteu8vksc0BDJIkSb1JGPWdmPYzX+6Dgd9gnEC+AfgQ8IXAtzBOCL8xIh6cmc7OK0mSpMNZ3pxYkiRJmo8lz4kz88PAw/fxvospRk7sN86O95+z3/cuigMY1I/iCxvFaKT232iKHcqo2jsU9YpqOShCls0V7UW7YrW/jEZfRh3bqnbNUdQrVe11PBZUfSkXvesy9BxvFsvdVZeYVfcHM+hjV7NYX13a6n/U5nyXbRYGHVdJtUsfjqbvEFd4Tb0XuD/wJztnWoiInwDeCnwr48EMv7+Y7klHTAKtSU9G7clQsiiLYqfWaX6VaofXsaw83HStV+jaXqtsFv0oQ3Y96BS5QjVObVl+2zyLXEfaj1F1ch7rO1HVZmw0y0ZMX26/pZL6kBlsDasLo/23twy6XoNZlv7r6Ol721v165Crwn1Gf4bD6evSn4Gtr/llJ5IkSXOS2e+jnz7l6zPzj3bfJiIzPw48d/Lfc/ppTZIkSUfdMubEkiRJ0jyZE68mBzBIkiQt3qnJ89ZCeyFJkiRJkiRJ0gJ5CwlJkrRWkv6naJsMrj0rIt4+tTzz9l1jR8Qx4GGT/762axxJkiRp2wxzYkmSJGklmBOvLgcwSJKktbNi95j7BeArgFdn5p8uujOSJElaDyuWE0uSJEm9MydeTQ5gkCRJ2p8LDzPTwjQR8Sjg8cCFwEP7jC1JkiRJkiRJ0qpxAIMkSVo7qzCVV0Q8EngW8C7gnpl5yYK7JEmSpDWyCjmxJEmSNEvmxKvJAQzav2qaley2C4jR9Jg5qOIV/RgW1QZFWcfmsopZ1IsOq7Ke5aZdGFEsXNGRqo9UMatqnWrttQz9Hn7K5S7r9X8Y7NqXbm21+z+LZZu3ea7LZbLqn92odYxYg2m/IuIxwDOBf2Q8eOHfFtsj6WjK0fT9ZHTMbbvmxHToR50eFYXFPrTzYaNjvb4PU1W8sqllOlxWy9Dh+DfvY2bV3qjz2cDyGxYnm5vlSaq0t9Njc+rrgzX+Tkman0w4dWpj0d2QBPUfALqePHU5H5j39cRVuM5XnmyuQP/XQPtc0/W/rhzAIEmS1s4yD3KIiB8HfgH4e+DrM/MTi+2RJEmS1tEy58SSJEnSPJgTryYHMEiSpPWS9P9r2p7iRcRPAU8F3g7cy9tGSJIkaSaWOCeWJEmS5sKceGU5gEGSJGkOIuK7GQ9eGAJvAh4VV72/ycWZ+cI5d02SJEmSJEmSpKXgAAZJkrRmYgZTg/US7+aT5w3gMY33/AXwwj4akyRJ0lG2tDmxJEmSNCfmxKtqsOgOSJIkHQWZ+eTMjD0e5yy6n5IkSZIkSZIkLYozMEiSpLWSQPZ8LzJvbSZJkqRVYk4sSZKko86ceHU5gEFXVn3zqllR+v7Gdo1X9XFUFEbR4FXvT36Fqp/F/Cbl4lXtNet07H9Rr2sfo3PMzoWNfhy4yqRi/4efeU8o1PoMqqmSqs+tbszDdV86b7Mz0Hl76Flzm91H9/qfGkzS+knI0fSiUeN1gFG3fWQUZ8yddrvVGXh1zK/amndZodXPzkeoWRzaluNwCfR/QaYymsExdhYxuxgVmfuwOME7RrHPWCKjchLO4dz6MW/D4nPdXJIv8mBGZ43mxJL2lMFouLHoXqhHVV64TNeedDDzzPelpdT6DnideG15CwlJkiRJkiRJkiRJkrRwzsAgSZLWjyNrJUmSdNSZE0uSJOmoMydeSc7AIEmSJEmSJEmSJEmSFs4ZGCRJ0nrJGdwb0HsNSpIkaZWYE0uSJOmoMydeWc7AIEmSJEmSJEmSJEmSFs4ZGCRJ0vpxJKwkSZKOOnNiSZIkHXXmxCvJAQzatyi+5EkUNQ++d4hREa8oyqqTVRfLoFW1aqWUDXbqSpdK9Trpv49lex116WbZi7KP8/zcZiM6fQarv9y9JyJzXrauX8ejKPexf93PeySpJYv5BSNHVcV+y4qmZpBy1aqUsly2jnl2lzody8qUvut6LvtS5O7l8avfD320IsfKUbYnjhxV30f1Ylis/83V2IRKw+JrtSzLtxHTP4PYxwmLObGkPSWMTi35JM1zT3xXXJVrzqK9WXw+Hr80Q73fTqAjrwX3ZB+fpznxalry7ESSJEmSJEmSJEmSJB0FDmCQJEnrJ3t+SJIkSatmzXLiiLhVRPx4RLw+Ij4cEScj4l8j4lURcfdF90+SJElLaM1y4qPCW0hIkiRJkiRJWnY/A3wb8C7g1cAlwG2A+wP3j4hHZ+azF9g/SZIkST1wAIMkSVo73ttMkiRJR90a5sSvBX4xM/9u54sRcTfgz4BfioiXZ+bHFtI7SZIkLZ01zImPBG8hIUmS1kvf04I5PZgkSZJWzRrmxJn5wt2DFyav/wVwPnAacJd590uSJElLag1z4qPCGRi0WD1/0aMaSVUUZXTsSHRrb6669qNz//tfJ+Wn0+mz69iRZflMod6e59eLWtfvlQ6k2g2tLTctSX3JnncoSxIvRt1i1ofuo3jA2YPHo6U2yum/1xhl9QVZHsPiO7c5x35slDuUtmFj/QNsVF+eGLZjLsk6mYVRsU425tiPFXdq8ry10F5IKyYJcquxf513+tfcFa5IHjrPbi5VHroin490GDP4BX/nv0npStJ90NpyAIMkSVozQf8n0CbDkiRJWiUzy4nPioi3TyvNzNv33OC+RMRNgXsClwNvXEQfJEmStIy8TryqHMAgSZIkSZIkaeVExOnA7wCnAz+WmZ9acJckSZIkHZIDGCRJ0vpxFjZJkiQddbPJiS88zEwLEXExcNMDVPmdzPyuRqwN4LeBs4Fzgad37ZckSZLWlNeJV5IDGCRJ0voxMZUkSdJRt5w58UXA8QO8/6PTXpwMXngJ8GDg94DvyszlXGJJkiQtjhniSnIAgyRJkiRJkqSZy8x7HjZGRBwDXsp48MJLgYdl5vCwcSVJkiQth8GiO9BFRNwkIp4fER+NiBMRcXFE/EpEXHfWcSLiLhHx6oi4JCIuj4h3RsRjJiO/W3W+OyLeGhGfjYhPR8T5EfFNe/TtZhHxGxHxgYg4HhGfjIi/jojHH2QZJUk6kjL6fUhLyJxYkiSV1jAnjojTgFcwHrzwYuChDl442syJJUlSaQ1z4qNg5WZgiIhbAhcANwReBVwI3BF4NHDviDg7Mz85izgR8c3A7zOe6u5c4BLgfsAzGd9v78FT2nk68HjgX4DnAacBDwH+KCJ+JDN/dUqdbwD+H+PP548nbV0TuA3wQOCX91q+eYtiCpak+EK3KlZTulRl1b6jqBfRcaczg31VViuzi67LNgsz6coSLV9L35/pylie79U6m8nWteSfQZooSubEs86JR1Vy23HPW9VbgRmvj2w6s0RW4SMYeYyWNEMRcTrj3OA+wG8BP5CZo8X2SotkTtxDTpzA1hx/49glqTS/kLSW3Lf1YhVOlNVJbwMYIuKawF0njy8Brg98Dvg34O+BN2Tmu3po6tcZJ5OPyszn7Gj/GcBjgacBP9h3nIi4NuPEcgick5lvm7z+U8DrgQdFxEMy82U76tyFcVJ6EfA1mfmpyeu/BLwdeHpE/HFmXryjzi0YjyT/JPB1mfnenZ2OiM19LJskSUdW0v/fAs2FtV/mxObEkiQtgzXNiZ/LePDCJ4CPAD895Qcp52fm+XPul3YxJzYnliRpGaxpTnwkHHp4ZUTcOSJezDgB/SPgxxiPHP06xqNOvw94DvAPEfGuiPiRiLhWx7ZuAdwLuBj4tV3FTwIuAx4aEdeYQZwHATcAXradlAJk5nHgJyf//aFdsbYT26dtJ6WTOtvtng48fFedJzMeRftDu5PSSd1T1bJJkiRp/syJzYklSdLM3XzyfH3gpxnnK7sf5yykZwLMic2JJUmS+tF5AENE3Doi/hB4M/DtwFuAnwMeANwZuDXwVcA9gB8GXgJcC3gWcFFE/FBEHLT9e0yez9s9RVxmXjrpy9Un7fcdZ7vOa6fEeyNwOXCXyXR2+6nzml3v2R41+yDGSf6rI+KOEfHYiPjRiPimGN/nT5IkVXJGD2kKc+IrMSeWJGlZrGFOnJnnZGbs8XjyYnt5NJkTX4k5sSRJy2INc+Kj4jC3kPhHxgnUE4CXZObHiveeDzw3xvO6fT3w34FfBa4D/PwB2rzN5PkqI04n3sd4xOytgdf1HKdZJzO3IuKDwJcDtwDePRmVe2Pgs411877J8613vPYVwNWAvwJeBvy3XXU+FBEPysy/aS3Ytoh4e6PorL3qSpK08rxHpubHnHjCnFiSpCVjTqz5MSeeMCeWJGnJmBOvpMMMYHgC8OuTqbH2JTMTOA84LyK+CviiA7Z55uT5043y7devM4M4B63TpY0bTp7vxvi+cN8HvJLxVGGPZDzt2qsj4ssy8xONuJIkSZofc+K6jjmxJEnS+jMnruuYE0uSJB1A5wEMmfmMwzScme8A3nGYGFNsD6M57AQeXeJ0bXvn+zd2PP+vzHz+5P+XAD8eEV8KfAvw/ewxIjkzbz+1k+MRt7c7YB8lSVoZAUTPU3k5Tlct5sS9tW1OLElSj8yJNU/mxL21bU4sSVKPzIlX12FmYFiE7dGoZzbKr73rfX3GOWidvd4/beTtp3b8+w+m1PkDxonpHRsxZ6vjl7z8Mjembuk8o0vXHVHfe7BDGM+gd9BKHRurFnuZ9sLL1JdO2guQHbe9WPFpj7out9bQam/K0qKYEy8yJ14WoxkcS5fp8LxMfVkB2Tqvcj1qCQ1itPeblsCw8fpG43VJc2dO3ENOHAkxnOeJuRcBpJU2i/OLZdotdFm+Ve9/V0uy3P6ZYX0NFt2BA3rP5PnWjfJbTZ5b9yw7TJxmnYg4Btwc2AI+AJCZlwEfAa4ZEdOmQKvaAPiPKXW2E9erNfotSZJgnLD3+ZCWiznxmDmxJEkVc2KtN3PiMXNiSZIq5sQrqdcBDBFxx4j4/Yi4KCJORMRwymPrEE28YfJ8r4i4Ut8j4lrA2YzvCfaWGcR5/eT53lPi3RW4OnBBZp7YZ51v3PUeMvMS4O8n//2KKXW2X7t4SpkkSdqW0e9DOgBzYnNiSZKWgjmxFsic2JxYkqSlYE68knobwBARDwIuAB7IePKQtwJvnPJ4U9c2MvMi4DzgZsAjdxU/BbgG8OLJqFYiYjMizoqIWx4mzsQrgE8AD4mIO2y/GBFnAD87+e9v7Ir13MnzEyPiujvqbLd7AnjBrjq/Nnl+2iT2dp2bAI+d/PdlSJIkaemYEwPmxJIkSUeaOTFgTixJktTZsR5jPRm4DLhvZv5lj3F3+2HGCfCzI+KewLuBOwF3ZzzN1hN3vPfGk/J/ZpyEdo1DZn4mIr6fcYJ6fkS8DLgEuD9wm8nr5+6qc0FEPAN4HPDOiHgFcBrwbcD1gB/JzIt39ev5wH2BBwDviIg/ZZwoP2BS59mZef6ea0mSpKNqFtN5OT2Y9u/JmBObE0uStGjmxFqsJ2NObE4sSdKimROvrD5vIfGlwO/OOCndHhV7B+CFjBPJxwO3BJ4NfG1mfnJWcTLzlcDdGI8Q/lbgR4BTjBPPh2TmVTbbzHw88D3Ax4EfAB4G/BNwv8z81SnvHwEPBh7DeHqyRzBOZC8EHpqZj97P8kmSJGkhzInNiSVJko46c2JzYkmSpM76nIHh44yTtJnLzA8DD9/H+y5mPE3ZoeLsqvNm4D4HrPMi4EUHeP8W8KzJQ5IkHZQjYbU45sTtOubEkiTNkzmxFsecuF3HnFiSpHkyJ15JfQ5geDlwv4g4LTNP9hhX87QkX+To2o/macgesmvF+enaxc7rckWswEdXis4b7Wo7qsutfsRoH29a832flpo58VE2OqI7n3Ve7DLZXOcF1zyMViAnHmZ74s7N5e++3E1pccyJV0UCW/3u0Ktrkat+HU9SW9e/Q8x7v7AKfy+ZxTpZ2+Xez3KtwLLrqvq8hcSTgP8Afi8ibtpjXEmSJGlVmBNLkiTpqDMnliRJUme9zcCQmZdHxA8AbwA+EBH/AXx6+lvzln21K0mSdBX+rEMLYk4sSZKWhjmxFsScWJIkLQ1z4pXU2wwMEfFfgAuA6wJD4HLGE/rvfvQ564MkSZK0NMyJJUmSdNSZE0uSJOkwepuBAfhFYBN4GPDSzNzPHaolSZJ6twr3ddPaMieWJElLwZxYC2ROLEmSlsIy58QRcRPgqcC9gS8APga8EnhKZn5qlnEi4i7ATwJ3Bs4A3g88H3hOZg67LVF/+hzl+lXA72bmS0xKJUmSpouIm0TE8yPioxFxIiIujohfiYjrLrpv6oU5sSRJko46c2JJkqRCRNwSeDvwcOCtwDOBDwCPBv4qIr5gVnEi4puBNwJ3Bf4A+DXgtEndlx1qwXrS5wwMnwUu6TGeJEnSweXk0XfMHkwSyguAGwKvAi4E7sg4obx3RJydmZ/spzUtiDmxJElavCXOiXUkmBNLkqTFW+6c+NcZXyN+VGY+Z/vFiHgG8FjgacAP9h0nIq4NPI/xbb7Oycy3TV7/KeD1wIMi4iGZudCBDH0OYHg1cLce42ldzPMEd84n012nnsno0Fa3ppZ6epwr6djPTuulqjTv9dX1g62syme+rqov+Mp8IXvWZacH67q++kpMtbzMibV4q5LPrMJufj2PRdJCjbKYDDQWPlOppH6YE6+QwVajYAZpUO/X8bR41XYyi2uwXWLOexvquk6OqHKVzOJ0rMtnMO+/O823uaVxlJY7Im4B3Au4mPHsBzs9CfgB4KER8fjMvKznOA8CbgC8eHvwAkBmHo+InwReB/wQC56Joc9bSDwBuHZE/FpEXKPHuJIkSStvHwnlZYwTSvOo1WZOLEmSpKPOnFiSJKntHpPn83bfbiszLwXeDFwduPMM4mzXee2UeG8ELgfuEhGn77UQs9TnDAwvAy5l/KvBh0XEe4FPT3lfZuY9e2xXkiTpSmb0g9mzIuLt0woy8/b7qF8mlBHxZsYDHO7MeKSrVpM5sSRJWgpOIqMFMieWJElLYUmvE99m8vzeRvn7GF8nvjX1deIucZp1MnMrIj4IfDlwC+DdRdsz1ecAhnN2/PsawFc33ufpkyRJOor6Sky13M7Z8W9zYkmSJB1F5+z4tzmxJEnSlZ05eZ42wHPn69eZQZy+2p6p3gYwZFY3MZQkSZqXgOz7rmkBcOE+R9C2rERyqMMxJ5YkScthZjmxtCdzYkmStByW9jrxvhrh8IM9u8Tpq+1D6XMGBkmSpOWwmr/jWYrkUJIkSWvCrFKSJElH3XLmxNs/ZDuzUX7tXe/rM05fbc+Uo2ElSZLmYyWSQ0mSJEmSJEnSzLxn8nzrRvmtJs+tWxEfJk6zTkQcA24ObAEf2KPtmeo8A0NE3CEz33aI+mcAN8/Md3eNoeURyzKCaRb96H16mf4nXZzJ+l+Wz3Qvq9LPnlXbUGuVzGKyz2r1O7noFDPYn6y3xvraz3pczn1DX4mplog5sa5ksCT7+a7dWJLuaz2NZpAHDZbmRLSbQZGwbCxpMqMV42akOTEnXmEZxKk1TQK7Lta8952rsPo9nqyu1vbV9TOd9wVmaS+re534DZPne0XEIDNH2wURcS3gbOBzwFtmEOf1wHcC9wZ+d1e8uwJXB96YmScOtkj9OswMDG+NiD+IiDsdpFJEnBkRj2Y8cuPBh2hfkiRplVwpodxZcMDEVMvFnFiSJElHnTmxJEnSPmXmRcB5wM2AR+4qfgpwDeDFmXkZQERsRsRZEXHLw8SZeAXwCeAhEXGH7RcnA0p/dvLf3+i8cD3pPAMD8AjgZ4ALIuJ9wMuANwNvy8xPbb8pIjaA2wB3Br4BuB9wBvBy4AWHaF+SJGmqZfxBZmZeFBHnAfdinFA+Z0fxdkL5f3YllFp+5sSSJGkpLWNOrLVlTixJkpbSEufEPwxcADw7Iu4JvBu4E3B3xjP0PnHHe288Kf9nxoMVusYhMz8TEd/PeCDD+RHxMuAS4P6M87RXAOf2tpQddR7AkJnPj4hzgUcD/x34aSYTcUTEKeBTjBPQ7fs5BzAE/gj4pcz8q0P0W5Ikabqk/6nB+ot3oIRSy8+cWJIkLaXlzom1ZsyJJUnSUlrinHjyY7c7AE9lfDuH+wAfA54NPCUzL5lVnMx8ZUTcjfG16G9lnKe9H3gc8OzMXHjmf5gZGJj8QvDnIuIXgK8Hvg74L8CXAF/AeBrk9wPvBM4HXpmZHzlMm5IkSauqr8RUy8WcWJIkSUedObEkSdLBZOaHgYfv430XMx4Aeqg4u+q8mfG16aV0qAEM2zJzBPzp5CFJkrRYCx8j2tYlodRqMCeWJElLZYlzYq0vc2JJkrRUzIlX0mDRHZAkSZIkSZIkSZIkSeplBgapsy4jn7I5SwrRdSTVvOt10F7qQ5hF/+c8mq3TZ75MI+669qXYIDptKx37MZPtsqPO3/8Oit1QaZ59XGf7WY+ua0mHMlimI9waczX3JlbgwDeYQR9HVVLm9qUZWaVfAq3ArkHSgkXCYLjoXkiS1I3XidfXKp13SZIkSZIkSZIkSZKkNeUMDJIkaf10nSZDkiRJWhfmxJIkSTrqzIlXkgMYJEnS+nFqMEmSJB115sSSJEk66syJV5K3kJAkSZIkSZIkSZIkSQvnDAySJGmtRI4ffceUJEmSVoU5sSRJko46c+LVNfcZGCLCQROSJEk60syJJUmSdNSZE0uSJGma3pLEiPi/wKMy83jxnpsDvwvcua92NT+dRxVV9TLm2Fa7aHov9hGzq6ovfbc3i3VZmMnos8Z20tXcR8it+oi8Ve//Hhwx2ZNZrMfWV38/bfm5akHMiY+A6Dcv6Www3370nI7N3yz6vwLrZN6b62AFEquqjwMTiLkYxGjRXTg63KS1IObEKyQhtlYgqZEkaRqvE6+tPmdgeATw1og4a1phRDwI+Fvga3psU5Ik6Sq2pwfr6yEdgDmxJElaCubEWiBzYkmStBTMiVdTnwMYngb8J+BtEfHw7Rcj4rSI+HXgXGAIPLDHNiVJkqRlYk4sSZKko86cWJIkSZ31NoAhM38K+AbgUuA3I+K3I+IOwFuBHwQuAG6bmX/YV5uSJElTZc8PaZ/MiSVJ0tIwJ9aCmBNLkqSlYU68kvqcgYHMfB3wVcCfA98B/DXw5cDPAnfLzH/psz1JkiRp2ZgTS5Ik6agzJ5YkSVJXx2YQ87PAvwMx+f+ngTdm5mgGbUmSJF2Vo2G1eObEkiRpscyJtXjmxJIkabHMiVdSrzMwRMRXAX8LfDvwp4ynBDsNeG1EPC0iem1PkiTpKhKi54eJrg7CnFiSJC2cObEWzJxYkiQtnDnxyuptBoaIeCTwS5OYP5GZvzh5/Q3AucATgHMi4tsz80N9taslUX1hM5pF0apXxmsXtVs6RMyuO6N5tles48pMlm0G9Tr3s2UWB5g5H7R6XycVD8hLba7bwpI4isus1WFOvGKiWw7VKV6Xso79y+rPAUXM7Ht9HEaXrnTsfsdUulbF7Hgg67ubgxU5oA7CH+n2ZcD81uXGDD63DU9MpJVhTrxaBluL7oEkSdKV9TnS9TnAvzG+h9kvbr+Yme8D7gz8OvC1wN/12KYkSZK0TMyJJUmSdNSZE0uSJKmzPgcwvAr46sz8q90FmXkyM38E+JYe25MkSZKWjTmxJEmSjjpzYkmSJHXW2y0kMvOB+3jPKyPi7X21KUmSNJUzDGtBzIklSdLSMCfWgpgTS5KkpWFOvJL6nIFhXzLzw/NuU5IkSVom5sSSJEk66syJJUmSNE1vMzBIkiQti3BkrSRJko44c2JJkiQddebEq8kBDJIkaf2YmEqSJOmoMyeWJEnSUWdOvJIcwKAr6TwSKaNbzFZZUafdUl2vjFnVG3Ws13WdNON1K+v+mXYsK8ykL3O0Kv3vfUThkqz/uZvBclefTbHLOLKjRJvr5IiuD0nzE1HtlDveha+K2UF13JhFvTpmtb6Kil36MoP+L1N7sQIH/cES9bHqyyCKEzlphQxz+racJsUARMRvAd87+e+tMvP9i+yPtHISYmvRnZAkaQ9eJz5yHMAgSZLWj8mrJEmSjro1z4kj4n6MBy98FrjmgrsjSZKkZbTmOfG66vjzIUmSJEmSJEmav4i4AfA84Fzg7QvujiRJkqQeOQODJElaL+mtVCRJknTErX9O/H8nz48Efn+RHZEkSdKSWv+ceG05gEGSJK0fE0lJkiQddWuaE0fE9wAPAB6YmZ+MaN0UWZIkSUfemubE684BDJIkSZIkSZL246yImHrLhsy8/awbj4ibAs8CXpKZr5x1e5IkSZLmzwEM2r+uo5SKes2pW6q2usTbq96oqtceyV+2V8Ts1M+O67/rOulqFu11muJnBttrpfdpiGC5+tIy5/XMLH5Y06Evc13Hy6Ra7hl8Ns3d7x7rP+j/M/I3XdI6CohBzyE77i1a9aruVW113WlV9ea8IyxS8G51ZrFsHhyOlI3iBK8qW3Ub5cmy5mGL4dTX90p31zEnjogB8CLgs8CjFtwdaS1EwmCrS8WODS7L9ZRV778OZhaf96IPivvVWoYlucZ6KKvyGagXrfP9vfLddcyJjwoHMEiSJEmSJEnajwsPM9NCRFwM3PQAVX4nM79r8u/HAncD7puZn+raB0mSJEnLzQEMkiRp/firCEmSJB11y5kTXwQcP8D7PwoQEbcCnga8IDNfPYuOSZIkaQ0tZ06sPTiAQZIkrR8TU0mSJB11S5gTZ+Y9O1b9cuB04OER8fDGe94X41ssPTAzX9mxHUmSJK2TJcyJtTcHMEiSJEmSJElaZhcDv9Uouy9wI+DlwGcm75UkSZK0ohzAIEmS1ktC9D2y1pG6kiRJWiVrlhNn5t8Dj5hWFhHnMx7A8BOZ+f45dkuSJEnLbM1y4qNksOgOSJIkSZIkSZIkSZIkOQOD9i+jWVSOYOpSVtSJUbeyzv2v2uu43HU/i7K++9H1c6t0ba9jzE5tzbEfMIMRftD/OulqVWL2LHIFOnkY81y89q6Z3JheuK9tec0/Ikn9iEFjJzQoxnm36gBEuyzLsoPXqZT1qv1u1dwMyrq0V9aZha7tFQerjh9r3VwjZnRMALvW62ow5/bmabAiScmgPEldX410c1w2v24wKi48nMrh1NdzP9vWamx+khYpYbC16E5I/WidK6xxqgl0O0da93WyCrqe23b97OZ+Lt23wyTnbu8ryQEMkiRJkiRJklZSZp6z6D5IkiRJ6o8DGCRJ0vpxZK0kSZKOOnNiSZIkHXXmxCvJAQySJGntOBWeJEmSjjpzYkmSJB115sSrqbi5qyRJkpZBRNwqIn48Il4fER+OiJMR8a8R8aqIuPui+ydJkiRJkiRJUh+cgUGSJK2f9RtZ+zPAtwHvAl4NXALcBrg/cP+IeHRmPnuB/ZMkSdKyWb+cWJIkSToYc+KV5AAGSZKk5fda4Bcz8+92vhgRdwP+DPiliHh5Zn5sIb2TJEmSJEmSJKkHDmDQlRUjkcr7xIyKeh3aiypeUUa2W+secwb1qnXZWicd6syiH4fqS2We66tjP2ZRL7JjxZ5HDc59fRVmck+qVR9luQL97/q55Ua7bNR1wXMG29GCP4PMfGHj9b+IiPOBrwfuAvz+HLslrbYAonFHvShyyqIsB0XmW928r1WvCFekvWtRr5Nl6cdhFH2Jng9ufcfbK+Zg0QfTNTIoT0TnZ2MGn+myLNu8DYvzwuM5nPp67rX+1zAnljQDCbE1vWgW12fKnKxnq95/HdxR/XiO6nKvuuLSwmyuufddcRb72Oq6SbPS3uXmxKvJAQySJGn9zCaRPCsi3j61uczbz6TF/Tk1eW5cdpIkSdKR5MVVSZIkHXXmxCupy3iWhYuIm0TE8yPioxFxIiIujohfiYjrzjpORNwlIl4dEZdExOUR8c6IeExENH9DGhHfHRFvjYjPRsSnI+L8iPimffbx1hFxWURkRLzkIMsnSZLWW0TcFLgncDnwxgV3R3NmTixJkqSjzpxYkiRp/azcDAwRcUvgAuCGwKuAC4E7Ao8G7h0RZ2fmJ2cRJyK+mfHUzMeBc4FLgPsBzwTOBh48pZ2nA48H/gV4HnAa8BDgjyLiRzLzV4s+HgN+m/IGDZIk6SpmM7L2wgXPtHAlEXE68DvA6cCPZeanFtwlzZE5sSRJ2pO/NtOaMyeWJEl7MideSas4A8OvM04mH5WZD8jMJ2TmPRgnh7cBnjaLOBFxbcaJ5RA4JzO/LzN/FLgt8FfAgyLiIbvq3IVxUnoR8J8z87GZ+Ujg9oyT2qdHxM2KPv7EJP4T97lMkiRpSU1+wZMHeDR/UTP5Rc9vM74wdi7w9Hkth5aGObEkSZKOOnNiSZKkNbRSAxgi4hbAvYCLgV/bVfwk4DLgoRFxjRnEeRBwA+Blmfm27Rcz8zjwk5P//tCuWD84eX7azl9FZuZ2u6cDD2/08Q7ATwE/A7yzWh5JknRl0fOjJxcB7znA46NTl208eOEljH/R83vAd2WmY4mPEHNiSZK0H0uaE0u9MCeWJEn7YU68mlZqAANwj8nzeZl5pemyMvNS4M3A1YE7zyDOdp3XTon3Rsb3nr7LZDrn/dR5za73fF5EXA14MfD3wC80l0KSJE2XPT/66FLmPTPzrAM8fmx3jMm0ob/LeJrRlwLfkZlb/fRQK8ScWJIk7W0Jc2KpR+bEkiRpb+bEK+nYojtwQLeZPL+3Uf4+xiNmbw28ruc4zTqZuRURHwS+HLgF8O7JqNwbA5/NzI812mDSxm6/MIlzu0nsYlGmi4i3N4rOOnCwwyq+0NEqq3YC2V4fMSzaqu4Q16WPe9Ur2itjNupVdbou20yWu+sOvHN7jcJ597Ew7/b6PoiuzPqqLEliMZNlm6eu/S8OY9XuK1rDLFd9PXYUEacxnnHhmxlfwHr47gtsOjLMifepzokDBtNjxsZGFbT3smyUtV4HyqHoRbpc7pNXot68D6az+HlFsQzlZl7Wm996WaZfnAyKpGCjsU4G5cnTfG0sUV80e6Mi8z1VpHTHG+e8bj2SOfF+VTlxJAxOHc08oouy/1XhKlzHWPUPR1J5DaH5d5Q5K69zVFbt5/g6tFUbwHDm5PnTjfLt168zgzgHrdOprxFxT+BHgCdk5rsadSVJUkPQ/9+3Fn0eP/nlzv8D7gP8FvADDl440syJJUlSaR1zYmkXc2JJklQyJ15dqzaAYS/b281hN8cucbq2/fn3R8R1gBcAfw388gHjXDlo5u2nvT4ZcXu7w8SWJElz91zGgxc+AXwE+Okpv7w5PzPPn3O/tJzMibeDmhNLkiQdVebE20HNiSVJWjsRcRfgJxnf5uoM4P3A84HnZGYxX/3hYkXETYDvBm4LfDXjmaICuFVmvv8Qi3QlqzaAYXs06pmN8mvvel+fcQ5aZ6/3Txt5+wzg+sDXH3TjkiRJE7O4H9niZ1m7+eT5+sBPF+87f/Zd0RIwJ5YkSbX1zImlncyJJUlSbU1z4oj4ZuD3gePAucAlwP2AZwJnAw+eYaw7AD/LeE18kHH+cp3OC9OwancNec/kedr9wABuNXlu3bPsMHGadSLiGOM/LGwBHwDIzMsY/0LymhHxRfts43bA1YALIyK3H8AbJuXfOXnt71sLJkmS1k9mnpOZscfjyYvup+bGnNicWJIk6agzJzYnliTpyImIawPPA4bAOZn5fZn5o4xnRPgr4EER8ZAZxnobcFfgOpl5S+Adh1+qq1q1GRi2E7R7RcRg572fI+JajEeCfA54ywzivB74TuDewO/uindX4OrAGzPzxK46D53UecGuOt+44z3b/h/jD363L2I8bfRFjH9Z+aFi2SRJ0hKMhJVmyJzYnFiSpL2ZE2u9mRObE0uStLf1y4kfBNwAeHFmfj5XyMzjEfGTwOuAHwJeNotYmfkvwL/0sSCVlZqBITMvAs4DbgY8clfxU4BrMF7JlwFExGZEnBURtzxMnIlXML7v9EMi4g7bL0bEGYynygD4jV2xnjt5fmJEXHdHne12T7AjYc3Mp2bmI3Y/gF+avOUtk9eeepWVI0mSPi+y34e0TMyJzYklSdoPc2KtM3Nic2JJkvZjDXPie0yeXzul7I3A5cBdIuL0Ocfq1arNwADww8AFwLMj4p7Au4E7AXdnPM3WE3e898aT8n9mnIR2jUNmfiYivp9xgnp+RLyM8X1A7g/cZvL6ubvqXBARzwAeB7wzIl4BnAZ8G3A94Ecy8+KuK2KZRFVYfaEbZTFqR4xRs6jeeRRlXWNW9Tq31yqb83KX9bIoLOt1ba9bvd7bWqKYld4Pop370bHinJOAZVlfs7AkCRWjjaJwoziCLEn/pSVlTnxYAbHR2EENin1Tqw5AtOvloBg73mqv2kUWbdX12mWVst4c2+vaj+qg2LWP9YlCx5g9i47JwGAGSUTVl6q9WfSl3Vb7BGme/TiMjerE8YjaWJKk8lS2P5vjRdmJRve7nm5Ja8acuAeDrUW0qiNvFvly69i4JLm5NGtZnLPM83SmPMceFB0prsUsYe57VkS8fVpBZt5+xm3fZvJ8ldtkZeZWRHwQ+HLgFoxzmnnF6tVKzcAAnx8VewfghYwTyccDtwSeDXxtZn5yVnEy85XA3RiPOvlW4EeAU4wTz4dkXvUrlJmPB74H+DjwA8DDgH8C7peZv7qvhZYkSQeTPT+kJWNOLEmS9mROrDVnTixJkva0fjnxmZPnTzfKt1+/zpxj9WoVZ2AgMz8MPHwf77uYYnzdfuPsqvNmxvcZO0idFwEvOkidXfXPx3GCkiRJ2sGcWJIkSUedObEkSVqACw8z00JEXAzc9ABVficzv2u/4SfPfQy36DPWgazkAAZJkqTKiszyLEmSJM2MObEkSZKOuiXNiS8Cjh/g/R/d8e/tWRHOnPZG4Nq73lfpM1avHMAgSZLWyyym81rORFeSJEmazpxYkiRJR92S5sSZec9DVH8P41tf3Rp4+86CiDgG3BzYAj4w51i9Gsy7QUmSJEmSJEmSJEmSdCCvnzzfe0rZXYGrAxdk5ok5x+qVAxgkSdLaiez3IUmSJK0ac2JJkiQddWuYE78C+ATwkIi4w/aLEXEG8LOT//7GzgoRcWZEnBURX3TYWPPiLSS0f9UXsyirvtAx6q8OAEVZVa9sb9gxZtd+NvrSPV574cqYHT/TWWwnnep1bavSsV71Gcyknx3aqsx7fVVmkiBUn08HS5LEjM2xL1kMiYxBtMvm+R2QpN2isX/a2Dh4HYCNYmdYFGUjZG4UbRVFWex363rtsrJeUVbV61RW9aMIV7fVrpmzOBh17Eu16UWHfnaps5fBET14z2K5B+XJ2mrbqE5gOxosyb0NTmV72U4V5x3Hi+6fbOycs9yZSNL+RMJga9G9kBanPJeRVszSbM5dry10/bvTEZOZn4mI72c8+OD8iHgZcAlwf+A2k9fP3VXtgcALgBcB33PIWETEC3f896zJ8y9GxKWTf/9mZv7lIRbTAQySJGkNmdRKkiTpqDMnliRJ0lG3hjlxZr4yIu4GPBH4VuAM4P3A44BnZ+7/V5sdY333lNe+Zce/zwccwCBJknQla5iYSpIkSQdiTixJkqSjbk1z4sx8M3Cffb73hcAL+4g1ef//3969h8tSVnce/63qvc8BjaASHI1GUCJgxsxF0CTgBWEkakBkxNF54gxqTGLi3TiZRLygE6O5eMMkGo0KxgvGG2RUjBE8aiRRg4PXgIIco4A3QLkezt5da/7o2rLPPv2u7n67qrur+vt5nnr6nF693nrr7e6q1XXeU9X4BT+iC3kAAAAAAAAAAAAAAADMBFdgAAAAnbOkt+AGAAAAfoKaGAAAAMuOmriduAIDAAAAAAAAAAAAAACYO67AAAAAusVV/73NmKkLAACANqEmBgAAwLKjJm4tJjBgT26ZeUGszFhflBPEbNaxfv1tpsbSyvQg172uUbHokju56wsv4xPmJYKNrCvIi2Tmxf2cvNGF6n+uBtrM+Qy1Rfh9zODBdZvK1QaOH7mfPQXva6bMrQOwwEwm6/USweBb3wt2hlFeEeT1hudFpbknuj4yL+pjA3lxmxl5Tawrkrm+RTlwZG92UMgVXH9zIr26C7Ip9DLeuyL8cb6cohHZHdSga8Hw7woK7VsTO/xR7ww1MYCxuKuIdlAp0Q6hDaVCEzu03O2uuy+L0o+OC38fAUsgOk8c/jaf8b/NUBO3F7eQAAAAAAAAAAAAAAAAc8cVGAAAQPe04X98AAAAAE2iJgYAAMCyoyZuJa7AAAAAAAAAAAAAAAAA5o4rMAAAgM7h9twAAABYdtTEAAAAWHbUxO3EFRgAAAAAAAAAAAAAAMDccQUGAADQPcysBQAAwLKjJgYAAMCyoyZuJSYwYHyZX/Lo8ixWTvb8yPYy1iVJ1s/My4310x3NGRPl9iN6T7PHOQhmtpmVl72u4L1pYLxC2d+5jMTM705um7mytk2qvy8zLnpmfZkrt0RgJRVYMN7AmFHoAt1jJvV6w2Op5yWpSF/EzqNYL70PdRse82LyHElSEPLoGnzRbj7Ii9rMXV/qWJQ8Ro1oLzsWCdsMasooFjUZthkkJgQfr0YUQf+L4EAb5mW02cttj+uOLp3UaYK14DfJWvAx2eXpY8tasLPc5cNP3fmonRc1MYBxuFSsz7sTWHgtOR00S05tiGWR+P6XwY4hKHvzZfw70EacmriduIUEAAAAAAAAAAAAAACYO67AAAAAuoeZsAAAAFh21MQAAABYdtTErcQVGAAAAAAAAAAAAAAAwNxxBQYAANA53IoQAAAAy46aGAAAAMuOmridmMAAAAC6h8IUAAAAy46aGAAAAMuOmriVuIUEAAAAAAAAAAAAAACYO67AgFqEl2BxC2ITPj8iZmUDsX5um+mO5rTZyLYFfcwe59z3Llzf5P3MvixQ2Me89zR3hl+0vlDO9yrsR16ecvsfCPsSfU5m2Y9cM/6ceJHeN5erw+c3lsG0x2hXn22KzzKXBgMwkknqDd+xWZHe4XkiR5LUS+8Mo/1uMhbtd2cdi/bzUbmfmZfckTeyrtxYUBvmtlmzooEDYtRmE+trg170AylQZOb1lJcXt1nve1d3e1Izn69+0GTqJ95a8CXe5b1kbC3Yya4Febs1PFaOsTNZ0q8kgAmYS8U6OwuMMMP6ddZyz2cVLfnaNHK+Dt0T/IAt02Vq/d0IznP7FDsiauJ24goMAAAAAAAAAAAAAABg7rgCAwAA6Bb3+q8A0sAVRQAAAIDGUBMDAABg2VETtxYTGAAAQKeY6r80GFfcAwAAQJtQEwMAAGDZURO3F7eQAAAAAAAAAAAAAAAAc8cEBgAA0D1e8wIAAAC0TUdrYhs41cx2mNm1ZnaLmV1hZn9rZofOu38AAABYIB2tibuOW0gAAAAAAAAAWHhmto+k90o6QdKlkt4l6QZJPyPpwZIOlfT1uXUQAAAAwNSYwICxNXFfl9S9Z6wMcoKYorx+ZixsMz3dqgjaDPuZiEXtWRlM+wpCueMcrS+8n1BuX3zy7Qs/J1E/MtY1us0oL3MsI4n3J7u9zLxwLBdpfdFnJUduPwK5750X6T23rwaxVKhFN/gK9wEAIEkyqdcbHko9L0lF+iJ2vhLEon1yIi0nZy6xzONDzvrCdeUeMHOPbw30xYI8C9YX5eXkFJn9L4JCLrdNTKbX8iKo18B/aeoHX9boZ/taYkeUel6SdgcXOl3z9LFlzdOn53Yn8nyMnW/LPw4pr9Jg8sIrJL3Q3ffYSjNbnUuvgLZyqVjnGA3l18TRx6dF55EwHo9+lCyQ3PPEbdm+LMGmlb3oHzcSiTMequS/JY6T282auPOYwAAAAAAAAABgoZnZIZKeJunzkk5z3/tfJ9x9beYdAwAAAFArJjAAAIBuaeJ+ZAv4H1LM7C2SnlL99T7uftk8+wMAAIAF0lxNfLiZXTQ07H5EzWvc6r9LKiSdJWk/MztR0s9KukbSBdTDAAAA2MOSnCfuIiYwAACAzun6Vaqrk7VPkXSjpJ+ac3cAAACwgDpYEz+getxf0uWSDtgUczN7g6RnuXt0dxAAAAAskQ7WxEuBCQwAAAAtYmYHSnqzpPdIuqukh863RwAAAFgil8zgSgspd6keXybp45KeL2mnpAdK+itJvyPpB5JOn0PfAAAAANSkmHcHAAAAaude77JY3lQ9Pn2uvQAAAMBiW8Ca2Mx2mplPsLxjU3qverxa0snu/hV3v9HdL5B0iqRS0vPMbFstnQUAAED7LWBNjNG4AgMAAEBLmNmTJD1GgxO215jZfDsEAAAATOZySbsmeP1Vm/58XfX4UXe/ZfOL3P2LZnaFpEMk3VfSF6fqJQAAAIC5YQID6hFMOgrvL5MxWcnKGcf66U4WwV0VLTeW6IuV6X7kb3cDbQYz0KLtDj9DQT9TefHnLuhjlBeNV82f80Gbk2+3FH9m0+3VP3Mw9z0INTGWOaLPZNiPershSd5L/wO2W3ChpejfvRMxj/6xPIj5HP6NvaF7mx1uZhcNC8ziMrpmdpCk10l6h7uf0/T6gM4zyYrEfrIX7D+jWKo9SYr21yvD87w39OlBrAjaC2LR/j/cz0fX7gtiHuVlHIuyciR5kT4weHTQCGNBXwLh3LNgfZYRi3IiYRcbOMgWwQ+MIlhfTl4RFJQ9BT90MkXri/SCvGhM4jbr3b6igfHKVQaf2jIoRteCnVQ/0eZasHPerXQsyusH/VhLtDnOp2AR7/fr7sdNkX6ppOMl/SgR35jgsO8U6wCWirlUrC3gzgLLLSpGcz6u/N+PGnV9f7EY2xf+No8EaeVK3nndLljEmhijcQsJAADQPV7zMmdmVkg6S9KNkp415+4AAACgDTpWE0s6v3q839aAmW2XdJ/qrztn1SEAAAAsuO7VxEuBKzAAAACM55JprrRgZjslHTRByjvd/YnVn58r6aGSftXdrwtyAAAAgK46T9I3Jf2KmT3c3f9hU+xFkvaX9El3/+5cegcAAACgFkxgAAAA3eINXBqsnvay7vdrZveR9HJJb3P3j9TSEwAAAHTb4tbE+at3321mp0r6mKTzzOyDkr4l6QGSHiLpB5J+c45dBAAAwCLpYE28LJjAAAAAMANT3O/330vaLunJZvbkxGu+YYP71Z3s7udkrgcAAABYaO7+j2Z2pKSXSHqYpDtK+p6kN0n6P+7+nTl2DwAAAEANmMAAAAC6xzs1FXanpLckYr8q6a6S3ivpenG/XwAAAGzoVk38E+7+NUmPn3c/AAAA0AIdrYm7jgkM2EN4KZUgZmWQF8RSeVF7Yayfm5feuGI9b31F2Jf0+lJtxmMStBfkFcF2R9sWfxaCYGZe+LlM5IXjFR2woj5GedF3IBK0mTuWyfbC/ucdxLMvvxS+B5mN5r4HCeF4RRooiHylCGLpQ3mY17N0rEjE0inyIBbKzRvRZN2XBmugm2Nz94slPXVYzMx2aDCB4QXuftkMuwV0gEm93vBQ6nk1sG+V5Ikmc3JGxtKbFseiY0CwvvDYUaR31sk2G+hHGIvajITrC+q/IM8yDm5RTlH7dTTz1xfGgsK318A2JNcVFJtRH+M2OZG2VT/48vSCHdFa8GWN2iyDHcduDd8phjnBjrQM+piT5yMq1K7VxACaU6xn7CwyzyPFHVmQvUwT25ZrUcak5bLPWQFzEv0ujH/vZ55DyDjnm5MzD9TE7ZV7OgYAAAAAAAAAAAAAAKA2XIEBAAB0zwL9hwkAAABgLqiJAQAAsOyoiVuJCQwAAAAt5e7HzLsPAAAAAAAAAADUhQkMAACgc2Z4S2wAAABgIVETAwAAYNlRE7dTMe8OAAAAAAAAAAAAAAAAcAUGAADQLS6prHlqLTN1AQAA0CbUxAAAAFh21MStxQQG7Cn64oUxS4bCy7MkYlamU7Jj/XRHin6Ul47FeZnrS2xD1F48JkE/1oM3J2ozSIvWF21D9PkK2/RELOi/Ujka9XmN3oNoLOtfXxiLtj3Zj8x1RXLzws/ejPtSd3uW3lf6SnBRpCBPRdBmECt7QV4v8XzQDeXGIqm8cdqjkAQwiklaGb7D816wTy7SsSgv3O8m9tdlYn88WFcQC7rfSCzYL+fmpfb1XkRF4+TtjY5F6wtqvCgWrS7z2pY5h9poXUVmbJEU0Y+kGerNuB9Fzo+BwKz7XwY7jV3BRUT7wbegH+RF69ud2NGWmf1Y8/QpuH7Qj1SbPs43vx1fVwDzVLqK3YtxzMzaaeWeb2jN/rHmjuaOV0t44vxZFzY7+5xohtQ4ombR7+jw9/7k53RHrS8r1qaPSWv2+diMW0gAAAAAAAAAAAAAAIC54woMAACgc1ryn0MBAACAxlATAwAAYNlRE7cTV2AAAAAAAAAAAAAAAABzxxUYAABA98zw3oAAAADAQqImBgAAwLKjJm4lJjAAAIBu8QYuDUadCwAAgDahJgYAAMCyoyZuLW4hAQAAAAAAAAAAAAAA5o4rMGBs0SylcAZTGeQlYqnnJcn6s40VYV56w+vOszKdY+vBuqK8aJzX08EwL1pfdKmeYEyiNlOz3cJ1hX1Mp6kMNjwak6gvubFgfbPtR+Z0w9zLNs0wL/rceWHpxCKYG7jSS7fZS8fK1SBvJd2XKBZOYUykeZDjwarcgj4GeVNhJiyAUczkqf1ytL9eSe8M431ylJd4PjjehLF090ccw4K8sM10LDze5BxXwuNNsK4wFv3QCUJFZl6wvuCQGcaKRJvR2x1JtTdVLDg4N9Fmur2MQnoO2tLPHGupnZ6ktSCvH3yx+uGOKK0MdkSp9UX9j/oR9b8M84bHxvr0UxMDGMFcKnanTkY29YMdTWrsPEsLLPGm12rm45i7r4nO9y7I/st70e/2zN/7TcQyz+sm5f42b0pHa2IzO0rSCyX9kqR9JF0m6a2SXu/uwb9QTteWmR0t6SRJD5N0sKT9JF0l6XxJr3T3y/K36jZcgQEAAAAAAAAAAAAAgAVnZidJ+pSkh0j6oKS/kLRN0msknd1wW++X9LuSdkl6p6TXazCB4dclXWxmvzz5Fu2NKzAAAICO8fiKI5ltAgAAAO1BTQwAAIBl172a2Mz2k/RmSX1Jx7j7v1TPv0jSBZJOMbMnuPvIiQyZbb1G0t+4+1Vb2nqBpJdLepOkX5hyM7kCAwAA6KCy5gUAAABoG2piAAAALLvu1cSnSDpQ0tkbEw4kyd13aXAbCEn67abacvc/3jp5ofLHkm6RdD8zO2DM9ScxgQEAAAAAAAAAAAAAgMV2bPX40SGxT0m6WdJRZrZ9xm25pPXqz/0xXh9q5QQGM7uHmb3VzK4ys1vNbKeZvdbM7tR0O2Z2lJl9xMyuNbObzexLZvYcM+sFOaea2efM7EYz+7GZ7TCzE4a8btXMTjazt5jZV8zs+modXzazl5nZHSbZPgAAlpG5ZO41L/PeKmBv1MQAACCFmhjLgpoYAACkNFgTH25mFw1bZrBZh1WPX98acPd1SVdIWpF07xm39ThJd5D0z+7+ozFeH2rdBAYzO0TSRZKeLOlzGtxr45uSni3pn8a9LEVOO2Z2kgYzTh4i6YOS/kLStip36L1EzOzPJJ0p6W4a3EfkHRrc++P/mtkztrz8EEkfkPR4DT4Ub5D0Nkn7SnqRpH8xs58eZ/sAAADQXdTE1MQAAADLjpqYmhgAgCW0f/X440R84/k7zqotM7uXpNdrcAWG3x1jvSOt1NHIjP2lpLtIepa7v37jSTN7taTnSnq5pKfV3Y6Z7adBYdmXdMzGvUDM7EWSLpB0ipk9wd3P3pRzlAZv1OWSHuDu11XP/6kGRfGfmdmH3H1nlXKDpKdLOsvdb9rUzjYNCtZflfQSSc8cY/vqF820D+77YhkxCy4uErVX9NOdDNsMY+k2i/VkKL8v5fC8Yr3e9iTJojajvGjbgjyFbabf2LBNT8TCz10QTLU3qs0oLzcWbXck1WZmP7LGf1QsVxPjlVJYMmRK/mcKeS+d56tB3mp6TmHUZtkL8oJtyIpZOkdBKIw1hf8dhu6jJq6jJu4N3y9H++syioX75HQ3ysR+3tOrUhnEonU10WY0Ld6DY0AUSx074n6kd/4exLKPYdFhMVxfUHdlxnJyigX6r9RN9KWX0WbUjyjWi36khuvLy+s1cOPVnG0ogy//rvDLmtbPLBz7meuLtiHVZtTHMuhHP1xX0GYiz8cZq8X5mgNNoSaetiZ2V7G2GDf0zhHWk10WnrPqgNxzfMG4dJlH5+syhOe5Zyx/22rehuh3bfS5C/ofnkPO/E1f9+/vKNbE/rfuz/JtDTfS6iXufkRuspntlHTQBCnvdPcnjtt89VjHlo9sy8zuIuk8SQdKerq7X1jDett1BQYzu7ek4yXt1GBW62YvkXSTpP9hZrdvoJ1TNBj8szeKUkly912SXlj99be3tLVR2L58oyitcjbWu12Dmb0bz1/p7n+5uSitnt8t6Y+qvx4TbRsAAAC6jZpYEjUxAADAUqMmlkRNDABAW10u6dIJlqs25W5cFWF/DbffltdFpmqrmrxwgQa3oni2u//lGOscS6smMEg6tnr8mLvvMTXU3W+Q9BlJt5P0Sw20s5Hz0SHtfUrSzZKOMrPtY+act+U1o6xVj8H/+QcAAJIGV+uocwEWCzUxNTEAAKNRE6PbqImpiQEAGG0Ba2J3P87dD59g+b1N6ZdWj4dubdfMViTdS4Ma4ZtjdCW7LTO7m6Qdkn5egysvnDHG+sbWtgkMh1WPX0/Ev1E97jXQNbSTzHH3dQ3uRbYi6d6SVM3KvbukG9396in6uuEp1eOwIncvZnbRsEXS4WOuDwCA1jKvdwEWDDUxNTEAACNRE6PjqImpiQEAGKmDNfEF1eMjhsQeosHEywvd/dam2jKze0j6pAa1xNPqvPLChrZNYNi4hEXqshcbz9+xgXYmzamrrzKzR0v6LUnfkfQno14PAACATqMmpiYGAABYdtTE1MQAACyj90n6oaQnmNmRG0+a2T6S/rD66xs2J5jZ/mZ2eHXVhGnbuqcGkxcOkfTr7v6m6TdpbytNNDpHVj1OOwcmp53cdYevN7OjJL1Lg/utPXbzPdLCRt2PSLR3kaT7T9hHAADahUvcYrlRE280Sk0MAFhm1MRYbtTEG41SEwMAllnHamJ3v97MfkODyQc7zOxsSddKerQGV4l6n6T3bEk7WdLbJJ0l6UlTtvVJSQdLukjSQWZ2+pBununuO7M3Uu2bwLAxG3X/RHy/La+rs51Jc0a9ftTMW5nZL2twD7RS0iPd/XOp1wIAAGBpUBMDAABg2VETAwCApeTu55jZQyWdJumxkvaRdJmk50k6w338WRsZbR1cPR5RLcPskLRz3D4M07YJDJdWj6n7gd2nekzds2yadi6VdGSVc9HmF5vZiqR7SVqX9E1JcvebzOxKSXc3s7sNub9Z2Fcze7CkD2tQlP6Ku//ziG2qR/SRDmLRfV/CWDnZ85Jk/XSD1k/nFVFsPd1mmBf0JWoz6mdq+6LtjteVGSuDNy6IWT/95oVthn0JPhCp8Yr2z1F7UR9zZ+pFeUEsHK+cNsMxqXldUjzOizTrcSVxKLT0XZZ8pZeObU8fWn01yFuJ1hfFLB0LbhSVEwtz0t0IY8qNRTw+juS2CSwQauIauJl8dfg+23vB/roX7HeDfXK5GuQl2iyjdQX75Ny88AaD0X4+PKYEO9CcvCaOKWEsqNWiWNRkEAzbzIgV2X0MfnsEB8VofUXmwTk3L91eXv/z11d3UdKMfvKLnK5t12bajxF5mYVjGayvn3HX1X5Q+JZBe9F2p/pRhkW2qImxDKiJ6+CSrQUnKhdc7mmDiEfFGvY265uUR8e2tt0wvSZW92d2gc7bZm9Z/KMrGUr9Nvci+HAFv7+j3+bx7/bcWDKU/5s+ldfEOd0mdLgmdvfPSHrUmK89U9KZNbU1k3e4bbv0T1SPx5vt+S9LZnYHSUdLukXSqCIup50LqsdHDGnvIZJuJ+lCd791zJxHbnnN5j4cq8GM2nVJD5/Z5AUAALrCvd4FWCzUxAAAYDRqYnQbNTEAABiNmriVWjWBwd0vl/QxDS5P8fQt4ZdKur2kt7v7TZJkZqtmdriZHTJNO5X3SfqhpCeY2ZEbT5rZPpL+sPrrG7a09cbq8TQzu9OmnI313qrBPUe0KXa8pA9J2iXpOHf//NZxAAAAwPKiJgYAAMCyoyYGAADorrbdQkKSfkfShZLOMLPjJP2rpF+U9DANLrN12qbX3r2Kf0u33ZMjpx25+/Vm9hsaFKg7zOxsSddKerSkw6rn37Ml50Ize7UG9wn5kpm9T9I2SY+XdGdJz3T3nRuvN7PDJJ2rwf1FPiLpJDM7aesAuPvpI8YIAIDlxmRYdB81MTUxAAAxamJ0HzUxNTEAADFq4lZq3QQGd7+8mtn6Mg0uufUoSVdLOkPSS9392qbacfdzzOyhGhStj9WggLxMg8LzDPe9rx3i7r9rZl+S9AxJv6nBXZq+IOlP3f1DW15+t6pNVe0/NtH908fZRgAAAHQTNbEkamIAAIClRk0siZoYAAB0UOsmMEiSu39b0pPHeN1OSTZtO1tyPqNBETtJzlmSzhrjdTsU9BcAAIzDZbXfj4ypulg81MQAACCNmhjLgZoYAACkURO3VSsnMAAAACS5pLoLU+pSAAAAtAk1MQAAAJYdNXFrMYEB9Yi+sEHM+pM9L0nFem4s3ZEiXF+QF8Qssy+2Xg7P6Qc5ZdReEOsPX9cgFrxx5eLkKbXtUU5wwIrGJDzQRbHg/ck+ePaDD22izSFXL7xN1MeIZ45XJOpLEfzng6KXDNlKOqZEzLetJlPC2Gp6XWUQ814RxNLb7cGYZMcSodTzkuL/FxLEojbD9QHAtMyS+2xfDfbJQaxcCfatwb68TBwePDh8NRJLb1p2TFFedAxI5HmRrhOimCyqL4LaMGwzCAXrK6L1RW2mQ8n1hf3IjOUK1xf8aOzlbkOizZ6C+jXQs7y8RdIPvpD9xJeuF9X7Mxb1P8zLLCrLxPpSYzWyH0H/y6CPqTzOmwKog7nL1oJzTEso91SER4Uc9hYdThel/Mg75GNWgu+cF8GbF/1uT5wvjc6jlpnndMPfypm/2+MxCdrM/SGagfO9GBcTGAAAQPcsyo9dAAAAYF6oiQEAALDsqIlbiTlkAAAAAAAAAAAAAABg7rgCAwAA6Byr+95mAAAAQMtQEwMAAGDZURO3E1dgAAAAAAAAAAAAAAAAc8cVGAAAQPcwsxYAAADLjpoYAAAAy46auJWYwAAAALrFVX9hSp0LAACANqEmBgAAwLKjJm4tJjBgDxbFynTUyihv8pj103sA6wftBbFiPYql1xfG1oJ+5ra5nhiUcEwy2pOkMh2L2lTQpgVtqp/Xl+gAY6k2o/bKYNuig1k/+IAFeR61GfYlb0ySbUbtRf0IhNsWMAv2NkUQs/Rhy1Z66bzt25Ih37Y60fOS5KvpdYWxXnrbfCUdK4OYB5sdxoKbSHnqPQjeGg/eU48OLgAwLyb56vCdYbQvLxM5g1jevjwVK4P9ePaxIdz/B7GwzaAOylxf8pgT5eS0N0UsKmdkQf2aGSvCWNCXmuX2sQlF9GMzQ0957RUzPoO1Fnwh+8EXoRf9Hkjl1DzGTemHO5TMNhNjWWYWt9F7U2b1nyIbQA3cpbXgpOkiyP2Hp7BYq99M1zbjbVtasyyyuy76zIbnFIO84DexgnOw5Uq67vJe4hxB9Ps7/G0exILPVxxLhuJY5u/eVF7UXhPngpP9qH9VWBD1/8IDAACYt7LmZUHYwKlmtsPMrjWzW8zsCjP7WzM7dN79AwAAwALpaE0MAAAAjI2auJW4AgMAAEALmNk+kt4r6QRJl0p6l6QbJP2MpAdLOlTS1+fWQQAAAAAAAAAApsQEBgAA0Ckml9V8bzNbjAuSvUqDyQuvkPRC9z2vA21m6fueAAAAYKl0uCYGAAAAxkJN3F5MYAAAAN1Tc2E6b2Z2iKSnSfq8pNPc995Ad1+beccAAACwuDpWEwMAAAAToyZuJSYwAAAALL7/LqmQdJak/czsREk/K+kaSRe4+2Xz7BwAAAAAAAAAAHVgAgMAAOgWV/0zawfNHW5mFw0Nux9R7wr38oDqcX9Jl0s6YPPqzewNkp7l7v2G+wEAAIA2aK4mBgAAANqBmri1mMCAPQVfPIu+lFFe8E8pVg5/vohygljRT3fEglixHsTWgjYz84p+YsMl2drwmK0HOVF7wXYrarNMx7QevAlBXtTPKE9lsA2pvH66j0OuvD7muqLtDvI8vW2eOyaR1PYF7YVjEjCzdLDXS8dWg8PP6rb0+ratpvOCmAfr80Ser6b776tFOtYLYivpWNlLj6UXmbGwzWRISqRFOTntTRVbPnepHl8m6eOSni9pp6QHSvorSb8j6QeSTp9D34B2Mkvu68tgP1+upHdOcSzdlVTMgxwPDrPZsdz9fHZeuv5I5uUeG4J1WRQLfgTFsXRX8tucPFYEOY3Egh+GTbQZKRI/NqN1NaEMvgRlsG3RfaHK4EtXKF3zrym9A+gl8tainUagiXEuvf7isB/twJL9mDxnsK68/qfWx3lTALVwl+1ekLsRpgqo3H94igqytuvyti2Q6JybReeCZyzqZ+3iHzrpWHC+NMwLzqWG51mj87rR+dLEb/pmztsmQyPOswZtZp5nzSqzcz92nAvGmJjAAAAAuqeZe5tdMs2VFsxsp6SDJkh5p7s/sfrzxs+aqyWd7O63VH+/wMxOkfQFSc8zsz9y9925fQQAAECHcL9fAAAALDtq4lZiAgMAAOiezAuYNOxySbsmeP1Vm/58XfX40U2TFyRJ7v5FM7tC0iGS7ivpi1P1EgAAAN2wmDXxVMxsu6SnSjpV0r0l7SPp25L+QdKr3P1bc+weAAAAFk0Ha+JlwAQGAACAGXD346ZIv1TS8ZJ+lIhvTHDYd4p1AAAAAAvLzFYknS/paEmXSHq3pFslPUDSMyX9TzM7yt2/Nr9eAgAAAJgWExgAAEDnWPcuDXa+Bidl77c1UP0vtPtUf905wz4BAABggXWwJj5Zg8kL50s63t1/8v/pzOylkl4s6fmSnjKf7gEAAGDRdLAmXgrFvDsAAACAkc6T9E1Jv2JmD98Se5Gk/SV90t2/O/OeAQAAALNx7+rxw5snL1TOrR4PnGF/AAAAADSAKzAAAIBucR8sdbc5R+6+28xOlfQxSeeZ2QclfUuDy+U+RNIPJP3mHLsIAACARdLBmljSV6vHR5rZ67ZMYjihevz4jPsEAACARdXNmngpMIEBe4q+d1vntm9iubH+8BVaP51TJHIkqVgP8qLYWrpNWw/WF+QVa+kNt/V0rEjFghzrpwcsWpfWg4Euo/XV32YU8ygvte3RQSQYL5XpPI/ygvWFecH6tNd/KNkcmvwgaYVFwXSoF1ysZ3U1nbctiAV5UZtaTR+2PDvWSzyf3u5UjiSVUV4v/R74SmZeuivy4K3z4POQynOLPkPBuoJYdt4Scvd/NLMjJb1E0sMk3VHS9yS9SdL/cffvzLF7QOt4IZXbhu/won15uS29cypX8mKeOEyFOdH+P/fYEOYFtU72sSgdU2J9UT9SOZLC440s+C0Q9NGCvCLoS+bhNF5fIpbdXvDDMLWuQSz4nZOZF+kFbc7SWvAlKIN3oR98CXrhWKZjveB3SZS3puHb0AtPEgQW460ZqR9+SyZXhju2uvsxt2L5cDO7aFjA3Y9oeN0flvQBSf9V0pfN7OOSdks6QtKDJL1e0p833AegW9ylteCkaVdFBVnbdXnbZqwtIxn2M3X+L/qcFHnnKKM2vRf8aIzOiQaxMjg/m30ONjFe8XnbZGjEb+XJz81OFcv+IVpjDjABJjAAAIDuyZjk0wbu/jVJj593PwAAANACHauJ3d3N7BRJL9bgNmo/vyl8vqR3uXvwPwgAAACwdDpWEy8LJjAAAIDu4VJeAAAAWHbN1MSXTHOlBTPbKemgCVLe6e5PrHL3kfR2SY+U9HRJ50q6WdLRks6Q9Ckze5y7n5vbPwAAAHQM54lbiQkMAAAAAAAAAGbhckm7Jnj9VZv+/PuSHifp2e7+V5ueP6+6MsPFkl6nwcQGAAAAAC3FBAYAANA9zKwFAADAslvAmtjdj5si/YTq8RND2v2imV0r6SAzO8Ddr5liPQAAAOiKBayJMVox7w4AAAAAAAAAwAjbq8cDtwbMbLuk/aq/7p5ZjwAAAADUjiswAACAbnHVP7OWiboAAABok27WxJ+WdD9JLzCzz7j7rZtip2twnvPz7n7DPDoHAACABdPNmngpMIEBY7MyM9ZPx4r1yZ4fHUvvOYq1dMwy84rd6Y0r1tODYlFsbXibUY7Wg0Hup2MW5gXrK4NYsD4P28zbhmSbTfTR0zEvg6NWkJd98DRLh3q94YHU85JsJX04sG3b0v0I81bTeavpPF9J9zPMW03nebDtvjr8YkRheyvp8fdeOlaGeclQHCuCNtMheXANpmRe1F4Qy87L5lL0ncxtE0C3mKm/ffgONtpf91eD/Xxw6OsHsTJxeIv2/6kcSSpzjym99L4uzIv25UXQZnQ9wFQsc11RzKI8y8uzKC+IFWEsGUq2GbdXfx/bYC36MEeCkj4akzL40BZBfRHmBV+eMvpxHmx7kchbS7emXsfro364w5lcGe70gn4k8kb/lOxkTfxySSdKOk7SJWb2UUm3SDpa0gOrPz97ft0DWshdfuuto19XF2vBBaGjomtJWXAeEjWKxrkIvjvh+5OIBTneC9YVnLeNz78GNfhKUNsGsegcrGfmpc4FhOdRo3OzYSzdZvj+ZJ6DzT0/m3PuNm4v+mE7+bpG62RNvBRaUDEAAAAAAAAAWGbufqWk+0t6laRdkp4s6RmS7irpTEn3d/d/mlsHAQAAANSCKzAAAIDuia58AgAAACyDDtbE7v4DSc+vFgAAACDWwZp4GXAFBgAAAAAAAAAAAAAAMHdcgQEAAHTP6JsCAwAAAN1GTQwAAIBlR03cSkxgAAAA3eKSypoLU+pcAAAAtAk1MQAAAJYdNXFrMYEBe7Dgi2fBbWKsn44V6+lGbX3ynGItiO2O8tIb0NudjlmQV+xOb3iUZ/0oLxFbD3KCWJSn9cQbIMnL4A0P+q9+Xp6HbUZ5ifUF9zUK1zXr2XhFLxmyXhQL7gC0ujo8ZyXY5QcxW0n3I8rTajrmYZvpmK8GsZX0mHgwXqk2fcWSOWWwrjLI814QK3JjyVCYpyCUyovWFbVXeyzKAYAxuUn97cN3KNG+vFxNx/pBzINDZmp95fBD+sj2wmNDcAiOjylRm+n6KTx2FFFeIhbkRMcHy81Lh2TBj6dZx4pELPX8NLFIbl4ZfFDKoM21MvhAJ5pcUfq3wJqC9gJFcAar9PSnKBqvMvj0hevLLJSK8MuaWFd0kqDD+hljNUrO++YUxQDqULq0e23evRiIzmEsClvOO3KHFV4b3rdclrltweckPKcbKYK86Lxn6jxrcN45PDcbndsM24zOpUbndKPf2Hl5Oeduw3Ozub+xw3OzuW0G/az5/GzYXhM4T7x0mMAAAAA6xhuYjMTUWgAAALQJNTEAAACWHTVxWy3nlEEAAAAAAAAAAAAAALBQuAIDAADonlnfDgYAAABYNNTEAAAAWHbUxK3EFRgAAAAAAAAAAAAAAMDccQUGAADQPcysBQAAwLKjJgYAAMCyoyZuJSYwAACAbnFJZVl/mwAAAEBbUBMDAABg2VETtxYTGLCn4HtsQaxYrzdWrKX3AMV6EFtLd7K3Ox0rgpit9YNY1Gaw4etRm4m8fjonas/Xo34EsWB9nurjqLx+8CHydMzL4IgQ5GUxC2Lpu+5YrxfEgrv1hHnpmFaD3XcxPM9WgvZWgvaCPA/bDPKibVtJj5fnxoL3wFeGv+dl0F6ZyBmsKy8Wt5kMyYsgL/joRTElmvTg69FMLAgCwLQKqb99+M6wDA6L69uDffm2dF65GuStJp4P+hHu44O8speuq6LjTXTzwbAv4fqCGi81XEWQE8XCEi+dZ0XwOyFqM4qlQzILfusEsVSbUXtNKIMDexgLRqUf5BVB3lqZ+EAHn9ci+p85UUkf/CYpgw9DEZz5isYr+ixEYxmJ+lL3upZVPyzAAWA+3F2+e/e8uzF7RQP7ZM5hTCbzPbCccQ7OnUXnexWcxwvP6UbbFp4TDWJBm+H52cQ50fDcbHRuM/v8axCLzm2G68s8PxueSx0ea+bcbF5e/IMyLxadn03/2Ky/H8BmTGAAAAAd4w1cGoyptQAAAGgTamIAAAAsO2ritmL6NwAAAAAAAAAAAAAAmDuuwAAAALqn9pm1AAAAQMtQEwMAAGDZURO3EhMYAABAt7iksubClDoXAAAAbUJNDAAAgGVHTdxa3EICAAAAAAAAAAAAAIAWMLOjzOwjZnatmd1sZl8ys+eYWa/JtszsIWb2N2b2FTO7xsx2mdkVZvZ3ZnZcPVvHFRgAAEAHuZfz7gIAAAAwV9TEAAAAWHZdrInN7CRJ75e0S9J7JF0r6URJr5F0tKTHNdjWsdXyWUkXSLpJ0j0lPVrSiWb2h+7+otxt28AEBuyh6FsyZutB3lr6minFWjqvt3t4Xi9qL5EzaC+9IyrCWD8Zs93pDbe1dJ7Wgrz1jLz1dHsexNQPds79dD88iIV5ufcTsvQFYcL5YsXkuzGz9OdcvWBlRdTH4II2YZvpWHabK4lY0H9P5YzIS65Lkq8E6wvbTMfKqM1e+n0N+5LIK1eC9qJ1FVFeMiQPhiRsM8wLYsH3IJkXfHVmHgOAKbmZ1vdJHAOC/XW5LR3rb0vvuMrVoC+JciY6bpRBCeS9dD2WfSwK2gyv65cdS6wvyLFUzqhY0I2obDQL2gxiRRgLOpPBPa/BMsgLY8EbVAa/E8pgoMvggxn81NSqhv8OWgu+4KtF+nfOepAX9b8Iri/aC06k5bYZvT/RZy+15T0L+hjtUAJR/9ugnHGR2k98B5xiGUAdvFR5662zW19w/m9RWN0F2egVzm5dmdsWnksN1xdsWxmcs47yom1IjWXmOVaL+pFzblaKz89G/cw9P5s4h+lR/3PPsYbnRDPP6WbGyiAW/aZMlbe552ajH5TxedsoFrQZ5qVjUVmZ+ZMyyyzX1WZmtp+kN2vwM+4Yd/+X6vkXaTCh4BQze4K7n91QW69099OHtHV3SV+Q9AIz+0t3v3qa7Vz8igEAAGAiPri3WZ1Ly0+0AwAAYNlQEwMAAGDZdbImPkXSgZLO3phwIEnuvkvSC6u//nZTbVWxvbj7lZIu1GDuwb3HXH8SV2AAAADdk3s1GAAAAKArqIkBAACw7LpXEx9bPX50SOxTkm6WdJSZbXf3UZdZqq0tM7uLpF+UdKukS0esdyQmMAAAAAAAAAAAAAAAMNrhZnbRsIC7H9Hwug+rHr8+ZN3rZnaFpH+vwVUQ/rWptszsSEknaDDX4B6SHi1pP0nPdPcfjr01CUxgAAAA3eKK76WY2yYAAADQFtTEAAAAWHbdrIn3rx5/nIhvPH/Hhts6UtJLNv39BklPdve/GWO9IzGBAQAAAAAAAAAAAACA0S6Z5koLZrZT0kETpLzT3Z84bvPVYx1TLZJtufsbJb3RzPaRdC9JT5P0djM72t2fNu2KmcAAAAC6p3v3NgMAAAAmQ00MAACAZbeYNfHlknZN8PqrNv1546oI+w97oQa3cdj8usjUbbn7Lg1uL/FsM9su6bfM7OPu/r4x1p/EBAbsKfgeW3CVlTDWj/KGrzDKKfrpTqbakySFsWADop1bE7EUs3Ss15u8PUkq0m1a1KanxyvoZTOsGP58sG3hWKbaG9GmFVFeZqyXl+epvGhdK+n323vp7fbocxLlrQT9D8Y5uW2SfCXIC9osE3nhdkd9DI6sZdhmOi8/lrm+RFrq+dz2BrGZ7zUAQNJgv7V2u1QsOG6sBm1Gx4Ag5onDaZizkq4nw7xof91Lt5mfF/3ACGKpvCgnt/wL2syNzVpOT8rgAF0EgxnllcFAh3lBbF3pD190QqNMvT/BYK2V6dp2tQh+pEZfEEU/lqMvVt5lTkult6EINr6X6GeZ2kGNUATfj2AkMUTq+7E4eyAArTfLf9jxGR4FMs83ZHcxOq6HaRnH/Nzzl9GYROcNM/MsOrcZbUOUF5yLTG5fdP5yludmp1ifh+d1o74kxiRorwzaiz5f8fnSes/bjsoLfkJktdnE+dfwH1JmHcuQfb43sx/R+trI3Y+bIv1SDW7fcKikizYHzGxFg6shrEv65ozbkqTzJP2WpGMkTTWBIe+oCgAAsKBcLi/LehdOEQMAAKBFqIkBAACw7DpaE19QPT5iSOwhkm4n6UJ3v3XGbUnS3avH9TFfn8QEBgAA0C2uwf8gqXWZ90YBAAAAE6AmBgAAwLLrZk38Pkk/lPQEMzty40kz20fSH1Z/fcPmBDPb38wON7O71dDWQ832voyOmR0i6bTqrx+eeKu24BYSAAAAAAAAAAAAAAAsMHe/3sx+Q4PJBzvM7GxJ10p6tKTDquffsyXtZElvk3SWpCdN2da5kn5kZp+V9G0N5hocosFVHFYkvd7d/2Ha7WQCAwAA6J5y/lNhAQAAgLmiJgYAAMCy62BN7O7nmNlDNbjiwWMl7SPpMknPk3SGu4+90RltvUTS8ZJ+SdKJknqSvifpHEl/7e5/P8Wm/QQTGAAAAAAAAAAAAAAAaAF3/4ykR4352jMlnVlTW6+T9LpxXjsNJjAAAICOccnL+tsEAAAAWoOaGAAAAMuOmritmMCAPXgRxHrpWLliQSz9ZU7llavpdVk/vS6V6Q0Iuq8y+CoUFqwviFmR7ov3+uk2V4fvTK2f3slaGeyAgzxFV5EZ/woze4r6kisYy6TofcvN6wX9yPyceNRmtN1BnqfyekE/wnVFeUFsJepjNM7B/iTc7nSTcV8Sz0fbHe0Pw/FK54VjGealY4q+BkEs2WYD6wrl5rnkdV8abAHqUjPbLumpkk6VdG8NLuf1bUn/IOlV7v6tOXYPaB0vpPXbJXY00T4yPAbE65u0TQ/q6KgfuTV9nBfsCKPjQ83HjrjkCvqYG8sU9iUQHb6i3zPp9oLfK0GsjH7nRHlRLPgwlJm/PcrgQ7SW+EKuFsFvsaAbqfYkqbD0b6Be0Mci2O7oPSiCjvaU7kv4/mT8fiqCz3k//Cw38Jux5frhzjJTR2tiAHUz2UpH/4nAGti3RuezAhYdZ6Nzcqm8ICdeV1RMR+co8857qpeun8J+BnlZ525zxlgzPm8rzfTcbRPnbeNzm9G/H+XlReVTbl+S54mjdUXnD3LOv6qZ88RRX7LO6y7SueAINXFrNXAUBwAAQJ3MbEXS+ZL+XNIdJL1b0hslfV/SMyV90cx+fn49BAAAAAAAAABgeh2dXgkAAJZa7ZcGm7uTJR2twSSG491v20Aze6mkF0t6vqSnzKd7AAAAWDjdq4kBAACAyVATtxJXYAAAAFh8964eP7x58kLl3OrxwBn2BwAAAAAAAACA2nEFBgAA0Dm139ts/r5aPT7SzF63ZRLDCdXjx2fcJwAAACywDtbEAAAAwESoiduJCQwAAKBjvIFLg7kkHW5mFw2Nuh9R8wq3+rCkD0j6r5K+bGYfl7Rb0hGSHiTp9ZL+vOE+AAAAoDUaq4kBAACAlqAmbitzZ6CXiZldY6urd179d3cZHu9bOjf4jkcxhXnDP38WfCzDdQWf56jNcH8TfUey15fxvQtToj5OvqopExdE+rM8+yaDxNw2LZ2YfOfCdc22j7ltehN9yVlXdj+C9WXmZa8wpy8NbHeOXdd9T76+dq27H7DXqswuKtS7/+11h1rXeZNuUKn+zZIuGRafwQQGmZlJerGkF0nqbQqdL+mF7v7PTfcB6Aozu8ZWVu+8/c7/LvGCvHbzj1MTPt9YP6IiPK/JusfEoiNm9rE7qOmjtOgwG4xlfjlTb5uL1Mfc9zXuZ+K3ZtiPKJj3+yj/KzDb9eVsXwO/uDCBa664Qeu7+vOoib8wi9oXQPPM7JpCvTvfXvvNuyvNaORAtSjnG4Nz+Nnryty2RWqz5rGc6XnbkeuruZ8tP287yEuHaj/Pmruu7H7UfE53qr7UmDNCzmfo1mvndp6YmrhhXIFh+Vzva2va/Z0rd867Iy10ePU49B+vEGLs8jF2+Ri7fIs+dgdLuj4Ru6RUXzfoR02s9xJ3/7XcZDPbKemgCVLe6e5PrHL3kfR2SY+U9HRJ50q6WdLRks6Q9Ckze5y7n5vbP2DJXO/ra9r1/e/snHdHWmjRjxGLjLHLx9jlY+zyLfrYHaw51cRNNApgLq4f7Cuu2znvjjSi2f+bVd8xou3/h2xyi358XWSMXT7GLt+ij93BoibuJK7AAIxp47LhzKqaHGOXj7HLx9jlY+yaYWbnS7r7BCl/5+6/V+WeLuklkp7t7mdsafc/SrpY0rfc/eBaOgsACRwj8jF2+Ri7fIxdPsYOAJDCMSIfY5ePscvH2OVj7DAvXIEBAABgBtz9uCnST6gePzGk3S+a2bWSDjKzA9z9minWAwAAAAAAAADA3BTz7gAAAABG2l49Hrg1YGbbpZ/ctHT3zHoEAAAAAAAAAEDNmMAAAACw+D5dPb6gmrCw2ekaXFXr8+5+w0x7BQAAAAAAAABAjbiFBAAAwOJ7uaQTJR0n6RIz+6ikWyQdLemB1Z+fPb/uAQAAAAAAAAAwPa7AAAAAsODc/UpJ95f0Kkm7JD1Z0jMk3VXSmZLu7+7/NLcOAgAAAAAAAABQA3P3efcBAAAAAAAAAAAAAAAsOa7AAAAAAAAAAAAAAAAA5o4JDAAAAAAAAAAAAAAAYO6YwAAAAAAAAAAAAAAAAOaOCQwAAAAAAAAAAAAAAGDumMAAAAAAAAAAAAAAAADmjgkMAAAAAAAAAAAAAABg7pjAAAAAAAAAAAAAAAAA5o4JDGgdM7uHmb3VzK4ys1vNbKeZvdbM7tR0O2Z2lJl9xMyuNbObzexLZvYcM+sFOaea2efM7EYz+7GZ7TCzE4a8btXMTjazt5jZV8zs+modXzazl5nZHSbZvrq2ua52mhy7RO6hZnaTmbmZvWOS7Uu01/mxM7ODzewNZvZNM9tlZteY2WfN7Hcn2cZpt7eudmYxbmb2C2b2TjO7zMxuMbMrzewTZvZ4M5vqGNuWsavaP83M3luNQ1l9735uRL/2NbOXmtml1eft+2b2t2Z230m2DwCWVVuOE5tyqIlFTTxNO7MaO6Mmpia+LYeaGAAWXFuOE5tyqIlFTTxNO7MaO6Mmpia+LYeaGPPh7iwsrVkkHSLpe5Jc0jmSXinpgurvl0g6oKl2JJ0kaV3SjZLeIulPq9e6pPcm1vNnVfzbkl4j6S8kXVM994wtrz28ev5GSf9X0h9Xr7+sev5SST/N2O09dkNyVyR9VtIN1evfwecuHjtJvyLpJkm3Snq/pFdIer2kj0n6R8Zt73GTdKKktWrM3lv166835bx5GT5zkh5TxUpJl0u6rvr7zwX92i7pH6vXfV6D/d27qvG8SdIvTvOdZWFhYen60qbjRJVDTTyDsRuSS01MTUxNPKOxEzUxCwsLy8yXNh0nqhxq4hmM3ZBcamJqYmriGY2dqIlZalzm3gEWlkkWSX9f7cieueX5V1fPv7GJdiTtJ+n71QHoyE3P7yPpwirnCVtyjqqev0zSnTY9f3B14Nol6eBNz99d0u9Iuv2WdrZJ+lDV1usZu73HbkgfX1yt71mqpzDt9NhJurcGRfy/STp0SL9XGbeh4/bVKuehW56/q24rBu+5BGN3D0kPlrRf9fcdGl2Y/kH1mvdKKjY9f1L1/Fc3P8/CwsLCsufSsuMENfGMxm5IH6mJqYmpiWc3dtTELCwsLDNeWnacoCae0dgN6SM1MTUxNfHsxo6amKW2Ze4dYGEZd6kOni7piq07LEl30GAW2E3aUtjV0Y6kp1Q5Zw1p79gq9sktz7+9ev7JQ3JeVsVeOua2bxw0v8zYxWMn6UgNZue9UNIxmrIwXYax25Tzq7njtKTjdoukHyf6/XdVzhFdH7shr9uhoDCVZJK+Vb3mXkPin6piD6vr88jCwsLSpaVtx4mcY2zQZ2riMcdO1MTUxNTEMx27Ia/bIWpiFhYWlsaWth0nco6xQZ+picccO1ETUxNTE8907Ia8boeoiVkyl6nuuwLM2LHV48fcvdwccPcbJH1G0u0k/VID7WzkfHRIe5+SdLOko8xs+5g55215zShr1eP6mK/fainGzsz21aDAuFiDSyDVodNjZ2arkk7RYDblR8zsgWb2XDP7X2Z2gpltG7FdKZ0et8pXJe1nZg/a/KSZ3UXSAyVdJelrQ9obpW1jN6lDJN1T0tfd/Yoh8Un3jwCwbNp2nKAm3jOHmnjydqiJF3TcKtTEeaiJAWA6bTtOUBPvmUNNPHk71MQLOm4VauI81MRIYgID2uSw6vHrifg3qsdDG2gnmePu6xrMXFvRYCabzOz2Glzq60Z3v3qKvm54SvU47GAxjmUZu1dW7ZxatV2Hro/d/STtK+krks7W4J5wr5b0JxrcY+8bZvaA5FaldX3cJOm5kq6X9HEze4+ZvcLM3qxBwXqDpMe4+y2pDQu0Zuwy1bV9ALCsWnOcoCamJq6pHWrixR03iZo4FzUxAEynNccJamJq4praoSZe3HGTqIlzURMjaWXeHQAmsH/1+ONEfOP5OzbQzqQ5dfVVZvZoSb8l6TsaFAs5Oj92ZnacpGdK+n13z5nNmNL1sbtL9fhQDS519euSzpH0U5KeLun3NJhxe193/2Gi3WG6Pm5y90+b2S9L+ltJ/21T6AZJb5P05UR7o7Rp7HLMYh0A0GVtOk5QE+fnUBPn51AT5+VQE9e/7gg1MQBMp03HCWri/Bxq4vwcauK8HGri+tcdoSZGEldgQJdY9ehzaCd33eHrzewoSe/S4P5Dj3X36yZsf1ytHjszu6MGhcBnJb1qwnam1eqxk9Tb9PgH7v5Wd7/W3f/N3f+3pA9I+mlJvzHhOkZp+7jJzB4u6dOSrpR0hKTba3DZq7+W9HJJ55tZExMF2zh2k5jFOgCgy9p4nKAmpiaeph1qYmriWbdDTQwAi6+NxwlqYmriadqhJqYmnnU71MRoFBMY0CYbs632T8T32/K6OtuZNGfU60fNLFM1Y+88SaWkR7j751KvHUPXx+7VGhRPT3L3fiIvV9fHbvOPnQ8Oydl47oGJNlM6PW5mdmdJ79FgNvLJ7v4Fd7/Z3b/p7s/TYHbyUZKemGgz0qaxyzGLdQBAl7XpOEFNnJ9DTZyfQ02cl0NNXP+66+4XAOA2bTpOUBPn51AT5+dQE+flUBPXv+66+4UlwQQGtMml1WPqfjf3qR5T98uZpp1kTjVz7l6S1iV9U5Lc/SYNZtv9lJndbdK+mtmDJf29BjPLjnf3zyT6Oq6uj939Nbg/1yVm5huLpE9U8V+rnrs4tWGBro/dpZv+/KMhORuF676Jfqd0fdyOknQnSZ9195uH5Gx89o5I9DvSmrHLVNf2AcCyas1xgpqYmrimdqiJF3fcqInzURMDwHRac5ygJqYmrqkdauLFHTdq4nzUxEhiAgPaZGNHf7yZ7fHZNbM7SDpag1lu/9xAOxdUj48Y0t5DJN1O0oXufuuYOY/c8prNfThWgxm165Ie7u6jtmccXR+7D0h6y5DlI1X88urvHxi6VbFOj527Xyvp4uqv9xuSs/HcziGxSKfHTdL26vHARL83nt+diEfaNnaTulzSv0k61MzuNSSe3D8CACS17zhBTTxATZzfDjXxgo6bqImpiQFgftp2nKAmHqAmzm+HmnhBx03UxNTEaIa7s7C0ZtFts02fueX5V1fPv3HTc6uSDpd0yDTtVM/vJ+kHkm6VdOSm5/eRdGGV84QtOUdVz18m6U6bnj9Y0jWSdkk6eEvO8ZJulvRDSf+ZsRt/7BLbfEzVzjsYu/Bz99Qq5+OS9tn0/D0kfbeKHcO43TZukn5G0pqkvgaz3ze39bOSvl+196iuf+aGrHNH9bqfC17zB9Vr3iup2PT8SdXzX938PAsLCwvLnkubjhOTHmOrGDVx5tgltvkYUROP87mjJqYmzh67IevcIWpiFhYWlkaXNh0nJj3GVjFq4syxS2zzMaImHudzR01MTZw9dkPWuUPUxCyZy9w7wMIyySLpEEnfq3Zc50h6hQazr1yDy80csOm1B1fP75ymnU05j9FgtuuNkv5a0p9IumTTztWG5Lyqin9b0msk/YUGRadLesaW1x6mwSw3l/Q+SacPWxi7vccu2OZjVE9h2umx0+BqPB/c1I8zNJiJfE313OsYt6Hj9uIq1pd0rqQ/lnSWpBuq5z+wRJ+5MzctGz9m3r/puQdtef12SZ+pXvd5Sa+U9C4Niv2bJP3iNN9ZFhYWlq4vLTxOUBPPYOyCbT5G1MTUxNTE1MQsLCwsHVtaeJygJp7B2AXbfIyoiamJqYmpiVlas8y9Aywsky4azFp7m6SrNbjszrckvU7Snbe8LrmznqSdLTlHa3C5qes0KCK/LOm5knpBzqnVjvem6oD1SUknDHndMVV/w4Wx23vsgvyNMZ2qMF2GsZO0IunZGlwm7GYNipLPSHoi4xaO20kaXMrvBxoUc9drMAP1t6P1dG3sNHrf9aQhOftKeqmkb2gwk/cHGhS+Pz/t95WFhYVlGZY2HSeqHGrihscuyN8YU2piamJqYmpiFhYWlk4tbTpOVDnUxA2PXZC/MabUxNTE1MTUxCwtWKz6cAAAAAAAAAAAAAAAAMxNMe8OAAAAAAAAAAAAAAAAMIEBAAAAAAAAAAAAAADMHRMYAAAAAAAAAAAAAADA3DGBAQAAAAAAAAAAAAAAzB0TGAAAAAAAAAAAAAAAwNwxgQEAAAAAAAAAAAAAAMwdExgAAAAAAAAAAAAAAMDcMYEBAAAAAAAAAAAAAADMHRMYAAAAAAAAAAAAAADA3DGBAQAAAAAAAAAAAAAAzB0TGAAAAAAAAAAAAAAAwNwxgQEAAAAAAAAAAAAAAMwdExgAYEpmtsPMvmxmjexTbeBiM/t0E+0DAAAA06ImBgAAwLKjJgaAejCBAQCmYGanSHqopJe4e9nEOtzdJb1E0oOq9QEAAAALg5oYAAAAy46aGADqY4P9HQBgUmZmkv5Vkkk63BveoZrZ1yT1ZrEuAAAAYBzUxAAAAFh21MQAUC+uwAAA+f6LpMMknTWjQvEsSYdKOm4G6wIAAADGQU0MAACAZUdNDAA1YgIDgKVjZjvNzIPlzDGb+vXq8T1D1vGkqq0nmdnDzezTZnajmf3AzN5mZnesXvefzexDZnZdFf87Mzs4sb6zt6wXAAAAyEJNDAAAgGVHTQwAi2ll3h0AgDl4raQ7Dnn+REn3l3TzqAaqy4IdK+m77n558NJHSzpB0ockvVHSUZKeJOleZvb7ks6X9GlJb5H0C1UfDjGzX9h6rzR3/5aZXSnpv5iZcXkwAAAATOG1oiYGAADAcnutqIkBYOEwgQHA0nH31259zsweLuk0SZdJevEYzRwm6UANCs7IoyUd5+6frNZTSPp7DS4r9hFJv+nu79zUj7dIeooGBeq5Q9r7vKTHSLqvpK+N0U8AAABgL9TEAAAAWHbUxACwmLiFBIClZ2b3k/Q+ST+W9Ch3/+EYafesHq8e8bp3bxSlklTNlv2b6q9f2VyUVt5ePf6nRHvf3bJ+AAAAYGrUxAAAAFh21MQAsBi4AgOApWZmd5P0YUnbJZ3g7t8YM/WA6vG6Ea/7lyHPXVU9XjQkdmX1eI9Ee9dWjz89Yr0AAADAWKiJAQAAsOyoiQFgcTCBAcDSMrPba3Bpr5+V9Gvu/ukJ0m+pHvcZ8bofD3lufYzYaqK9fbesHwAAAMhGTQwAAIBlR00MAIuFCQwAllJ1j7F3S7q/pNPc/d0TNvH96vGA8FX121jf98NXAQAAACNQEwMAAGDZURMDwOIp5t0BAJiT10o6UdJb3f2PMvK/Kqkv6fA6OzWGwyWVkr484/UCAACge14ramIAAAAst9eKmhgAFgoTGAAsHTN7jqRnSjpf0tNy2nD3H0u6WNJ/MLN9R7y8Fma2XdJ/kvT/3P1Hs1gnAAAAuomaGAAAAMuOmhgAFhO3kACwVMzsrpJeJck1mJ16mpltfdnF7n7OGM29X9IRko6V9OEau5lyjKRt1XoBAACALNTEAAAAWHbUxACwuJjAAGDZ7KPbrj7znMRrzpJ0zhhtvUXS6ZL+p2ZTmJ4qaXe1XgAAACAXNTEAAACWHTUxACwoc/d59wEAWsvM/kqDgvFgd/9ug+u5i6Sdkt7l7k9taj0AAADApKiJAQAAsOyoiQGgPsXolwAAAi/WYLbraQ2v5wWS+pJe1PB6AAAAgElREwMAAGDZURMDQE2YwAAAU3D370l6oqSrzKyRfaoNbr52taT/4e5XN7EOAAAAIBc1MQAAAJYdNTEA1IdbSAAAAAAAAAAAAAAAgLnjCgwAAAAAAAAAAAAAAGDumMAAAAAAAAAAAAAAAADmjgkMAAAAAAAAAAAAAABg7pjAAAAAAAAAAAAAAAAA5o4JDAAAAAAAAAAAAAAAYO6YwAAAAAAAAAAAAAAAAOaOCQwAAAAAAAAAAAAAAGDumMAAAAAAAAAAAAAAAADmjgkMAAAAAAAAAAAAAABg7pjAAAAAAAAAAAAAAAAA5o4JDAAAAAAAAAAAAAAAYO6YwAAAAAAAAAAAAAAAAOaOCQwAAAAAAAAAAAAAAGDu/j/ltCsc0B9H8wAAAABJRU5ErkJggg==\n", + "text/plain": [ + "
" + ] + }, + "metadata": { + "image/png": { + "height": 277, + "width": 1048 + }, + "needs_background": "light" + }, + "output_type": "display_data" + } + ], + "source": [ + "# Method 2\n", + "plot_plane(IDAT[2]['xz_plane'])" + ] + }, + { + "cell_type": "code", + "execution_count": 21, + "id": "downtown-belfast", + "metadata": {}, + "outputs": [ + { + "data": { + "image/png": "iVBORw0KGgoAAAANSUhEUgAACDAAAAIqCAYAAADYEygWAAAAOXRFWHRTb2Z0d2FyZQBNYXRwbG90bGliIHZlcnNpb24zLjMuNCwgaHR0cHM6Ly9tYXRwbG90bGliLm9yZy8QVMy6AAAACXBIWXMAABYlAAAWJQFJUiTwAADQD0lEQVR4nOzdeZx8V1ng/89T/e0krAEExB8om0AcdURAQDIDARQRBEFhxAUURUdlZB2VEZVFcRkRBFyYQdlEJIIjuABGgQgSEUEFFcISiCCLCkEICd+lq57fH1VNOp06T3ffvrX25/161au+3zp1nnPurVv3Pvf2qXMjM5EkSZIkSZIkSZIkSVqkwaI7IEmSJEmSJEmSJEmS5AAGSZIkSZIkSZIkSZK0cA5gkCRJkiRJkiRJkiRJC+cABkmSJEmSJEmSJEmStHAOYJAkSZIkSZIkSZIkSQvnAAZJkiRJkiRJkiRJkrRwDmCQJEmSJEmSJEmSJEkL5wAGSZIkSZIkSZIkSZK0cA5gkCRJkiRJkiRJkiRJC+cABkmSJEmSJEmSJEmStHAOYJAkSZIkSZIkSZIkSQvnAAZJkiRJkiRJkiRJkrRwDmCQJEmSJEmSJEmSJEkL5wAGSZIkSZIkSZIkaY4i4vsjIiPiKT3GfOIk5iP7iilJ8+YABkk6gIj4y4jYiogvXXRf+hIRg4i4MCI+GxFfuOj+SJIkaXlFxNMmF0Qfvui+9CkinjdZrvsuui+SJEk6vIh44SS/2/0YRsQlk+u8j4uIqy2of1cDngRcCjxr8tr3NPq8n8f3TEI/B/gP4Kci4hqLWDZJOiwHMEhaKkViOe3xmDn37f7A2cDLMvP9k9cePunLVkR80T7jfPmOZbh34z2PnpQ/q78lmC4zR8DPA9cAfmrW7UmSJGlvy5gXR8SNgMcAFwO/PXntFhExmvTjv+0zzkZEfGxS5xca7/mqSfk7eur+Xn4eGAI/FxFeK5EkSVofp4B/3fG4FLgu4+u8vwy8LSJusIB+PQq4MfDrmXnJ5LXP7err9uMTO+p9qvGezwFk5meAXwW+kHHuLkkrx5NySctqd2I57XHZvDozuYj5c0ACT9tR9PJJPzaA79xnuIdNnj8G/FnjPd80ef7jg/W0s98BPgj8QETcfE5tSpIkaW/LlBc/Cbg68IuZuQWQmR8A3jQpf1ir4i73Am40+feLGu+Zaz48WY7fBf4z8O3zaFOSJElzcUFm3mjH4zrAdYD/CYyA/wRMHVQ7KxGxwXgAA8Dztl/PzHN39fVGmXkj4Gt2VP+Wae/JzHN3vOc3J88/EhHHZrs0ktQ/BzBIWla7E8tpj+ftHaY33wB8OfCXmfnu7Rcz87PA/5v896F7BZkMhNge6PCSzBxOec+1gLsyHg38F4fs975MLkC/CNgE/sc82pQkSdK+LEVeHBHXBb6H8S+7XrKreHsQwjdExA33EW57oMPf7Mytd5n3gF644kLv4+bYpiRJkuYsMz+dmb8M/NbkpfvNuQv3Af4/xvnwRX0Hz8x/Bv6K8SwM37TH2yVp6TiAQZL25xGT55dNKdu+YPufI+Kr9ohzT8ZTg+2st9u9gNOAP8vMkwfq5eH87uT5oRGxOcd2JUmStPy+CzgD+OPJIN6dXg5cDhxjj9kLIuLawDdP/js1H55M4XtH4N+Bvz5Enw/qTcBHgNtFxG3n2K4kSZIW452T52vsfDEinj+5ndkrqsoR8ZTJ+y44YLsPnzz/3gHrHcR27IeX75KkJeQABklrISL++yRZPB4RX9F4z/+dvOdDEXGdA8T+AsajcJPxxdnd3gB8ePLvvabN3S5/e2b+U+M9V/m1WUTcbPsex5P/3zEiXhUR/x4Rl0bEBRFxnx3vPy0ifjwi/jEiLo+If42I/xMR12t1LDPfC7wDuAGOzJUkSVpJEfHC7bxxj8cLDxi6eZE1My8F/mDy373y4QcDVwNOMn1wMIx/kTYAXpOZo+0XI+LiSd/PiYgviojnRsSHI+JzEfHuiHjsZMaz7fc/OCLeFBH/ERGfiYg/aZ0rTJZjBGxfpPZCryRJ0vr7ysnz+3e9vj0z1/0m14avIiIC+O7Jf5+/3wYn+eo9Jv99837rdbAd+x7eRkLSqnEAg6S1kJn/h/Ef/E8HficiTttZHhHfBHw/40EI35OZ/3GA8HdnfGuF92Xmv09pewT89uS/3zG5h9lVRMQ1gQdO/tv6tVkA3zjp56sb77k/8JeMB1VsAtcEvhb4o8lF2jOAP2V877ZbTqrdEPgB4M93r5tdthPbexXvkSRJ0vL6NPCvxeMqtzDbS0RcH/jqyX9bF1m389vbRcSXF+G2Bzj8cWZ+svGevW4fcXPgb4H/DlybcU58FvAM4FmTPv8C48EWX8v42se1GA+MeFNE3Kron/mwJEnSmouIa0fEY7hi1t1n7izPzAuAdzGeJfc7me6ewE2By4BzD9D8VwJnMs7L33GAegf1DsaDhq8J3HaG7UhS7xzAIGmdfB/wb8B/Bn52+8XJFLTbo2afmZmvP2DcsyfPby/es33B9kbA1zfe862MpyM7xRW3a9jtjozvTfY3mfmvjfe8ePL4osy8DuPBCa9ivE9/JvB0xhdwv4lxgnotxtP0Xsr4wvMjrhry8942ef6vxXskSZK0pDLz0Zl5o2kP4HuBmLz1tQcIu50PfywzP9Z4z+uAf5n8+6HT3hARN+OKPLM1oHeT8eCBU4wH5U7zTOCDwFdl5pmMBzH81KTskRHxE8DjgMcAZ2bmtRlfKH4PcB3gaY24cEU+fNbkPEKSJEmr7S4R8fEdj/9gPOj3mYz/yP+wzHzhlHrb15NbM3N97+T5FZMZyfbrjpPn92fm5QeodyCTWxO/Z/LfO82qHUmaBQcwSFpWuxPLaY9r76yQmf/GFX+cf3xE3G3y7//LeFDAPwI/0aEv20nlO1tvmNx+4S2T/7amzd1+/U8y8xON9+z1azOAv83MR2wPcJjMCvGdwGeAGwOPBB6SmX+SmcPJ4w+BX5rUf1ARe3vU73+KiGsV75MkSdJ8HDgvniYibgO8lPF1gP+dma3bN0yzn3x4BLxk8t/v3Hkrhx0eyngAxb8Dr2mEuivjAQlvyszPNN4zAu6Tme+ctH15Zv4s8PpJ/KcBP5uZz8rMyybv+UfGM7IB3L81K1lmfpBxXg1XLLckSZJW1ybja8PbjzN3lF0PuOFkVtzdXsx4BoPbRsRX7yyIiDO5Yqbdfd8+YuKLJs+t68N92m7ji8p3SdKScQCDpGW1O7Gc9rjKPiwz/4jxgIUB8OKIeCzwAMbJ5ndl5okOfdlvUrn9K7IH7P7jf0TcBDhn1/um2c8Ahl/Y/cLkwuz2AIoLMvMvptR73eS5ed9frljGYLyOJUmStFid8uKdJhdY/5DxxdrXAP/rgH04aD58E664r+9O2zMzvDQzTzVi7Ccffm7jlnB/Pnk+yfh2Eru9GTjO+LZzX1rE3761hRd6JUmSVt9fZGZsP4BjwC2AH2Y8e+3TuWK2hc+b3O7slZP/7p6F4TuAMxjfcviNB+zP9SfPnzpgvS6227h++S5JWjIOYJC0rK6UWDYe/9Go+zjgfcCXcMWFy5/KzK73FNtvUvky4ARwNa46y8FDGe9zPwn8ybTKEXFjxvcj+0hm/l3Rzj80Xv+3yfM/Nsq3b0lx3SL2zmU0sdXCRcSDIuI5EfGmiPhMRGREvGTvmgdu5ysj4sUR8eGIOBER/xYRfxERrRlVJEmal8PkxUxmQvhd4NaMp5D99slsCQexr3w4My8E3jr575VuIxERXwvcavLfFxdh7jt5rgYw7JUPX5yZn53SvxFXDMLYT05sPqylYE4sSVJ/JrPVfjAzf4PxrLYA3xsR/2XK27cHNnzHrhm8tm8f8YIOXTh98nyyQ92DOj55vtoc2pKk3jiAQdLamcxG8D92vPQWxiNpu9pXUjm5cPyqyX93X+DZvoD7u4f8tRnFfYeHk+e9yo8V4Y/v+LeJrZbBTzL+Pt8W+MgsGoiI7wH+jvFsLW8Cfhl4BeOZSO4zizYlSZqjXwC+EfgP4P6Z+ekOMQ5ykfWFk+dviYhr7Hh9Oz/+x8z822kVJ7e5uBXwnsx8X9FG13x453s2i/d4oVfLxpxYkqQZyMw/BT4++e9/m/KWPwc+CHwBcH+AiPhy4A6M88pqpt2WSybP1+lQ96C2B+1+snyXJC2Z6o9YkrTKdk7rdSvGU+tWFzIrlwA3Yn9J5YsYJ7t3i4gvycwPRcTXAF+2o7zlfpPncgDDjO38JZqJrZbBY4F/Ad4P3A14Q5/BI+LOjEfT/yNw78z8+K7y6o8bkiQttYj4DuBHGV9cfUhmvrdjqINcZH0Z8EzG0/F+C/Dbk1+rbV8QXvZ8GLzQq+VjTixJ0ux8iPG131vsLsjMjIjnAz/D+HrzK4DvmxT/aWZ+tEN7+5kRrC/bbex1KzhJWirOwCBp7UTEdwIPAbYYT5P7BcDzDxHyIEnl9qjdAL5r8tr2r83elZlvm1YpIq7G+D7BnwNe172rh7ZzGU1stXCZ+YbMfF9m5n7rRMS3R8QbIuJTEXE8It4dET8ZEadPefv/BjaA79p9oXbSfmvGFEmSllpE3J4rprz98cmvy7radz6cmZ8C/mjy3+1ZyO4HXI/xQIrfKarva0ayOfBCr5aKObEkSTN148lz63j3AsZ57DdExE254ppv1+vN75k836xj/YPYbuPCObQlSb1xAIOktRIRXwz86uS/T2U8/eXngHtHxA93DLudVN58rzdm5s6Lsg+d/FLlIZP/V782uyfjKWpfn5mf69jPPtxs8vxprpg+TVoZEfFbwEuBLwX+H/BrjH81+jPAayPi2I733gT4r8DbgH+KiLtHxP+MiMdHxD0n9wyXJGnlRMQXAq9knF/+dmb+8iFD7jsfntjOe+8ZETfmigG957VuhxYR1wHOZnyri7/s1s3Di4irAzeY/NcLvVpJ5sSSJO1PRJzNFQMYpt7mLDM/AryG8WC/32GcK/478Icdm70ASOC6EXHLjjH2NDnG32jy34Xl15LUhSchktZGRATje+5eB3gL8HOZeSHw45O3/FJE3LpD6DdPnu+wz/dvX7A9C3gycH1gBLykqLMsvzb7msnzmzNztNCeSAc0uW/v9wJ/ANw6M78vMx+fmWcDTwHOAR65o8r29v4+4PWTxy8BT2d8j8O/j4gvnU/vJUnqx+R2Db8P3AR4K/ADPYTdzoe/IiLO2Mf7Xwv8K+NrDo8GvnHyejWg996Mb3P5p5m51bWjPbgd44vTlwLvWGA/pE7MiSVJ2ltEXC0iHgD87uSly6lnVNie2ezsyfNLus5QlJmXAO+e/Pdrqvce0nbs92Tmv82wHUnqnQMYJK2TxzK+DcNlwEMnsyHAeEaGPwOuzvgevMca9Vu2R6h+dURs7PXmzPwH4O8m/33C5PnP9rgn2n0nz8sygOFNC+2F1M2jGd865nunzGTyM4zvY/2dO1674eT5vwFfxvg+3Wcy/qXabwNfCfzJ5A9BkiStimczvrD6UeCBmXm8h5jvBD7DeIDBbfd682QAwksn/308sMl4hq9XFdWWbUDvBTvOJ6RVYk4sSdKV3SUiPr7j8e+Mrx//AfDFk39/22SmhZY/AXbOJHaY2xUDnDt5vm/5rsPZjn1u+S5JWkIH/SOeJM3LXSJir1sYnJuZjwaIiK8Afm7y+uMz8/3bb8rMjIiHA/8A3BH4ScYzI+zX24APALdg/GuV1+2jzouAr+aKgWLNX5tFxG0Z/0LuHZn5LwfoV68mv6a7O+MpzF6+qH5IXUyme/4qxveqfsx4QparOMH4ouy2jR3Pj8jM7T+YfCYivnvy3jsA38oVI/IlSZq3A+XFjGcygPGsZH/bOCburlPKzGFE/D7wcMYXQt+yj2ovYjzAeDsfPrc1mGIySPjejO8t/Jr99GmGvNCrlWVOLEnSVJvAF+567bOMr/f+GfCczPznKkBmbkXEHzGe3exvMvMfD9mnFwBPAr45Is7oadDx501ua/xAxtd5X9BnbEmaBwcwSFpW0xLL3c6Ez0+T+xLgdOBPMvP/7H5jZn4kIh7J+JdgT4yIV2fmW/fTkckAiOcDPws8hP0NYHgp42k3Nxn/Wu2VxXuX5ddm3wRcC3hDZl604L5IB3VdIBjfh/BJ+6zzqcnzCeDVOwsm3/tXMb5Ye0e8WCtJWpx958W7XH3yOEidym8xHsDwbcBP7fXmzHxHRLyD8R9TAV5cvP1rgS9gfBuzTx6wX72JiBsyHrD8WeD3FtUP6RDMiSVJmsjM7wG+p8eQd588H3b2BTLzwxHxGsaDZ78JeMUe77+Y8TF+v+4NXA84b1JXklaKAxgkLZUuiWVmnmR/U9n+Lt0vuGyPiv2WiPgfmXlij7b+HdjvFJt7DmDYT5K617rbR4xvnzw/r2pHWlKfnjz/XWbebp913jN5vjQzR1PKty/mXu1QPZMkqYOuF1wz82Z992US980R8U/Al0fEHTLzbfuoc9t9ht/XgN69li0zXwi88BAxvo3xr9BfmpmXVXGkJWVOLEnSDETEPYFbMb7dxEv3ePt+PRm4D+NbrpUDGDr4n5Pn/Q5olKSlMtj7LZKkzPwo8H8Yj1x9eF9xI+IGjO+z++/AvmaEmIWI+FLgm4F34XS5WkGZ+Vlg+48q19tntXcynl73+hEx7ZetXzF5vvjwPZQkaS1sXwD9n+W7Dm7hM5JNbmPxaMa/Qv+5Pd4uLSVzYkmS+hcR12c80y7A8zPzM33EnQwIfjlw54j4uj5iAkTEfwHuCrwqM/dz6zdJWjoOYJCk/fsZxtPJ/nhE9DWDzXUncR/d+LXLvPwvxr82e+KC+yEdxjMYz3zy/Ii4zu7CiLhuRHz+l2iZucV4YBLA/46IwY73fiXjX71u0f8oeEmSVlJm/j7w18CDI+LWfcSc3A7u5cBP9HAv4cP4DuCWwHP3ugeytOTMiSVJ6kFEPD0iPgR8FPhqxgP+frbnZp4APAW4Zo8xrzOJ+aM9xpSkuYrMXHQfJGllRMQDGd/H94Xrcv+wyQWqJwAnM/Ppi+6PtFNEPAB4wOS/NwK+AfgA8KbJa5/IzP+54/2/BvwwcAnwp8CHGM+ccnPGo89fkJk/uOP9VwdeB9wZ+DvgfMb3DP5WxtPkPj4znzGThZMkaQVFxFcznrnr/Mw8f8Hd6U1EfBfwpcCvTW4HJy0Nc2JJkuYvIl4IfDfwGeAtwP/MzH9YaKck6YhwAIMkSVpaEfFk6vv1/fPue1lHxDcBPwjckfGo80sYX7Q9D3hJZl646/1XB34MeAjji7rHgb8BfjkzX9PHckiSJEldmRNLkiRJOkocwCBJkiRJkiRJkiRJkhZusPdbJEmS1JeIuG9EnBcR/xIRn4uID0TEyyPiaxfdN0mSJEmSJEmSFskZGCRJkuYkIn6R8dS8nwReCXyC8f227w8cAx6WmS9ZWAclSZIkSZIkSVogBzBIkiTNQUTcCPgI8O/Af87Mf9tRdnfg9cAHM/MWC+qiJEmSJEmSJEkL5S0kJEmS5uOmjHOvv945eAEgM98AXArcYBEdkyRJkiRJkiRpGRxbdAc0XxHxQeDawMUL7ookSV3dDPhMZt58d0FE/A5w1ozavTAzv/MQ9d8HnATuGBHXz8xPbBdExF2BazG+rYSkGTMnliStgZuxmjmxpCVhTixJWgM3w5x4LTmA4ei5dmxuXm/zC294vWmFudGuONgYNcs2Bu1bkWxEVW96WVmHjm0VZdEx5qCoN+har1EWzRp7lXW7TUxUQVdA17vjVNWyXNP9x+xab5TTy2bRVpd+HCZm9bmOOsecXlbHa2vF27MfnWP2X6+1V6nWf9d+VFoxT3z4E+TJrVa1s4Db3e4rT+/UZsvf/sMJgLMi4u3TyjPz9nvFyMxLIuLHgWcA74qIVwKfBG4J3B/4M+C/99VnSaVrx7HN651x3S+cmhNXyl1ax/ypGXOebQFExwSqiFlG7LR87Yid89eiXplLl/WKso7ruarX3ITKdXLweHv1o1Kty66fXRnzgK+PC7utkzJk1/OxsnAGMXu24qeTS6X1aX/yg5eydXzYqjbLnFjS+rj21c6I633ZrU47cE68CrLjMXjeuvWyXavrUtf1urXXuS/l9aeDX+ua97XZztfxul6D7XAttfO12Xlft22H7H4NtsPn03W5Z7FslXnGnEUf64rT2zvxL/++qOvEmjEHMBw9F29+4Q2v9/89/rFTC0fXaX7ROeNa7S/lta5+vFl25hntsuuefvn0OpvtOtc+9rmirOjHseltAVx9cLIdc9Bu7+qD9jq5RlF2RpwqyqZ/BpvFgIhN2mWnlQMp2jY6XnGaxX1p2kvQNiwTpqJekVScyvbSzaZee0TRqWzvvo/n5tTXT3aMV/Wj1da4vXbME6N2veNVX0ZFzGqdFO1tjaZ/PlUfTxT92Co+7xPDbvVOdqx3atj+7Kp6w8Y6OdV4vaqzd1n7O9Cq9/7HPY/jF3384la9233l6fzNeV/SjNvF19zrQ70kp5n5KxFxMfB84Pt3FL0feOHuW0tImpmLz7juF17v1g+enhPnoLg4VJxBFYeiul5jd123VVxELAYlj4qyrjHrekVSViWOxxoZWxEvirJBVdYYVD2uVwyQLsoGxQDvY0V7x8pB4wcv2+xQB+BYh0HosMeyRfMPrWW9QfHH+qqfm4Pp7dWD0NtlrXh7x+y2bBvFWUtVr9KlXtWPvtvSdK2B4S/89tfzr+/+j4tb9ZY5J5a0NC7+sluddr2/Oe+LF92PmRhmt2NYV6OOf5YbdTjWDou/mFbxhkUfR0XMsl6zBE6W/Ww7VazKk8X1rNYfyatrsyeLk5Ku12bLa7D0H7O67tmK2fV6b7lOOl63PVWcpFbt1ddni3rFddbWtrJV9PFkUVbVq67Ntq5XAwy71itjHvz6bN/Xe6Ee3DBq1Pvg4/8vxz/wsYtb9cyJV5cDGCRJ0lpJstMFgL1iMp4abM+ZFioR8WPAzwHPBn4V+Djj0cA/D/xORNw2M3/skN2VJEnSETfDnFiSJElaCebEq2sWP5aWJEnSLhFxDvCLwB9m5uMy8wOZeXlm/i3wQOAjwOMj4hYL7KYkSZIkSZIkSQvjDAySJGntzHuqyH36psnzG3YXZOblEfFWxgMZvhr4wDw7JkmSpPWzpDmxJEmSNDfmxKvJAQySJGmtJN3vPVnF7MHpk+cbNMq3Xz/ZT3OSJEk6qpY4J5YkSZLmwpx4dXkLCUmSpPl40+T5ByLixjsLIuIbgbOB48AF8+6YJEmSJEmSJEnLwBkYdGXF0KHRKJplw6Jsa9QeJ9Mq28p2nVO50XvZKItlK8b5jIqyYbEMtJtr2ig+nNOiPQXOZtHWZtHeZrQrbhQLMOhYr2/DYn2Nsl1W1TuVw6Je26nie3WqWCenyu/BqWbZ8UbZSdrfgeOj9tZwqqi3OWov+fFsx9ygvc0OiimdTkW7vY1REbP4XE/0fSgcFfE2ttplw3a90aC93NW+eWPQXidVvVFMX18bjderOgBRljWLGDTq7b0nSUbFNtZNL2NrXwH8OfB1wLsj4g+AjwNfxvj2EgE8ITM/2UdjkmoxhM3LppeNjhW5wmntmNW+tdqNFKlJu61yb9htv8uwKCz25XW9dlFWMVvrsur/oB2vWsdZnAt0LZv3bzK6ZNmt4yzUx+6qXpVzlfWKsmPFuc6gKmv0pWprs8i56mWr+tiuV+bEHddX15jNeMWydVWty1VQ739nYfp54QrnxJKWSJJLM7V237+QrdtajmWehUFxvbr6NeuoQ161l82iXnkNtig7vehnq6S6pnuyuv5aXIc8le1rfNXfIarrpSeLK8yb0Y5Z/d2gtexVPwbFydOJ4hryRnE+Vn3lBh3r1Rt0UdZele3rs0VbXXPD6vpBlbdn8fmU9arrusW5bevcsO/rvQDDDv3YmznxqnIAgyRJ0hxk5igi7gM8EngI8EDg6sAlwKuBZ2fmeQvsoiRJkiRJkiRJC+UABkmStFYSGHb5OfMeMXuJk3kK+JXJQ5IkSZqJZc6JJUmSpHkwJ15dDmCQJElrZ55TT0qSJEnLyJxYkiRJR5058Wqq7hIjSZIkSZIkSZIkSZJ6FBE3iYjnR8RHI+JERFwcEb8SEdedVZyI+OKI+PWI+OuI+Pjk/R+NiDdFxMMjYrO/JezOGRgkSdJaSWDY88hax+lKkiRplZgTS5Ik6ahb5pw4Im4JXADcEHgVcCFwR+DRwL0j4uzM/OQM4twS+E7gr4FXApcAXwB8I/B84GER8fWZudXHcnblAAZJkiRJkiRJkiRJkubj1xkPOnhUZj5n+8WIeAbwWOBpwA/OIM4FwHUzc7QzyGTmhfOAc4BvAX7v4IvUHwcw6MqG0S4atu84cnKrvSkd3xo2yy4bnD719WOD0dTXAQbF+KZBtMs2oh2zMizutDLMYn0N2vVOsdEsu0acnF4nTrXjRXsg1OnRXv9nlOukGEfWXmwGVWFhM9rrZFB8Bp3a69bF8l5Jp7K9nk9RlGX7MzhexSzKTm+UnSrW4/Fi+zqe7RmDNotl2ywG6G0W2+zmqF12PE9rlm2swu+BRu195XDQXpejYqMdFdtCdaOoUbH/GsX0siz3se2yql422tqr3l68t5mkvUQmx45P31cUu2so9p+R1b6n2O+2apQ5V1trPz6O2S3Hq84Tyv11Ua9avuZqHhTHlFHRVlWv3Q2qjzSLbaEqK4/BRXvtbLmt/LwL1XlVXVacx1X1ynO8dszNDu1tFjlX1Y9jRb2N5re4+7rsGrPreW+17H23teq6fBcBhtntLq6Dxjl97OMzMyeWtJcRyedy+rXIrvr+pWtXozI3X1/Lsv73UmURG+WJQpU/TTcowlX5ZHXd9mRxRnaqyl+L63jHs30ieqoo2yjOdU7m9LUyKJat6mOVo1bXkCsbRV9KVbXyhLldNGxtLEWdUZUTl9dm+7+mW+X0o0NcZ52X6pLEYXq/jDlxRNwCuBdwMfBru4qfBPwA8NCIeHxmXtZnnMzpB/7MPBURr2Q8gOFWB1ui/nU7e5IkSZIkSZIkSZIk6Wg5KyLePu2xz/r3mDyft3smhMy8FHgzcHXgznOKQ0RsAPeZ/Pede71/1pyBQZIkrZUkGfb8S4tcwpG6kiRJUos5sSRJko66Jc6JbzN5fm+j/H2MZ1a4NfC6WcSJiOsD/4Px5Bc3AL4e+FLgpcAf192fPQcwSJKktXM0JzSWJEmSrmBOLEmSpKNuRjnxhZl5+0PUP3Py/OlG+fbr15lhnOszvs3EtgSeDvxE5uLvw+QtJCRJkiRJkiRJkiRJWryYPB92IEEzTmZemJnBeLKDmwKPBX4AeGNEXO+Q7R6aMzBIkqS1ksCw5+ltFz7kVJIkSToAc2JJkiQddUucE2/PjHBmo/zau943sziZOQQ+BDwrIv4V+F3gqYxvL7EwzsAgSZIkSZIkSZIkSdLsvWfyfOtG+a0mz++dU5xtr5k8n7PP98+MMzDoykbRLMphu2xra6NZdrIoO7ExfRO8fOu0Zp1BtMc3VWUbHe90M8pu43xOZfvrdY1sr5PhYHp7J6NYx4NTzbIzaJedYtipbLO4/c1mtOudFu1taDPbn8+gqsf09bJZrK8B7Xgb0f682xHr9obFso2Kbfbq2e3zOdFo73huNescL9oqy6K9fV0+Or1ZdloR87RiG9oY9f8dH8T0ehuN1xeh2g+NBu3tuVolVb3xzFFT6hTfxWr/G53LmkV7GvrzMEl7GcHGiek7yijy3sYuclKxqlftmBr1ql18URbtQ36ZV1V5SdWXan1RxCxSpPZQ+3LB20XZsV75mRY5cXW3yGpLaB2DAUZFWStmFW8Wup6rledxHettDqbnlMeKXLOM17FelaPWy13UK7airjlsFbPvtlbdsOM1gkGxDY3KHVF35sSS9jIiuXRUJI9Lrr1nXS5H84g5G/M8tlVH/NOKPGijytWKss0iZnV9drO85rs5vR/Fydjx6vrroFjuImaVE7f6eCjVNdHqgmOHNK/K40bFufKxYl2Ohu2OVPWqv+F1PR9rnmtWdbpeG5nR+euS5sRvmDzfKyIGmVd8gSLiWsDZwOeAt8wpzrYbT54Xnhw4A4MkSVoryfg8pc/Hcua5kiRJ0nTmxJIkSTrqljUnzsyLgPOAmwGP3FX8FOAawIsz8zKAiNiMiLMi4paHiTOJdaeIuPruPkXENYFnTf77J92WrD/OwCBJkiRJkiRJkiRJ0nz8MHAB8OyIuCfwbuBOwN0Z3/LhiTvee+NJ+T8zHqzQNQ7A/wLOiYi/AD4EXA58MfCNwHUmsX6+jwU8DAcwSJKktTOc0TS8kiRJ0qowJ5YkSdJRt6w5cWZeFBF3AJ4K3Bu4D/Ax4NnAUzLzkhnFeR5wGfA1wDnA1YFPAW8Hfg94fmZxb5o5cQCDJEmSJEmSJEmSJElzkpkfBh6+j/ddDO2RGPuNM3nvn7AEt4jYiwMYJEnSWsmEUc836E1v+CtJkqQVYk4sSZKko86ceHU5gEGSJK2ZmMHUYMs51ZgkSZI0nTmxJEmSjjpz4lXlAAbtWw4HzbLhsP2FPTXcaJadaJRtDtub5rEYdSobFGWljt+S0aBYXxy8rIo3GhVl0S47Fe3b2ByPYbPsjKJsM9vr+bTiM9iM9rC1zWJE20Yj5iBPFW2118lmtrfXjWhv54PiMx0UB7Sq7PRob3ynFxtm6/M5vbht0RnF53a8qHfZqPi8B+2yy4qYm0XZgHbMjaqs2jeMTm+WzdOo2BZG2S0pquoNiu9cNMqOFZ9pdmwryzKTQUmzEwkbJ6bvg4pUh2wf8stz2HKf1tgX5qBdpwxX7T6LZYuiYg6q40bRXpGC56hYvka98pBY9LFsq6hXHUujKKuOi7Moa/Wz6n/XslmoztUGFOcJg/YGfazxRa7yks3qPKcoq2KWeWixbLOoV+lyvrxR9GMdtC50dr22MCoOIO2zUBg26sWar39J8zFMuHTOx/1VNnRdLbXq2tqy6PqH1NPK655FbtjIF8q8tzhpPJ6bzbJBcX25VFWrzr9nodGX6m8soyI3HBbnK6PiHPVYx3qta7pQn0NU5zOtc8OqrbqsWVRfQ24GNCdeVw5gkCRJayXpfkJYxZQkSZJWhTmxJEmSjjpz4tU17/FLkiRJkiRJkiRJkiRJV+EMDJIkae3Me+prSZIkadmYE0uSJOmoMydeTQ5gkCRJa8WpwSRJknTUmRNLkiTpqDMnXl3eQkKSJEmSJEmSJEmSJC3cSg5giIibRMTzI+KjEXEiIi6OiF+JiOvOOk5E3CUiXh0Rl0TE5RHxzoh4TERsNOI/MSJeHhHvj4hRRGREfOke/bpaRDwlIt4TEccj4t8i4vci4ssOsnySJB1NwZBBrw96Hqkr9cGcWJIktZkT62gwJ5YkSW3mxKtq5W4hERG3BC4Abgi8CrgQuCPwaODeEXF2Zn5yFnEi4puB3weOA+cClwD3A54JnA08eFczdwB+lvGMIh8EPg1cZ49+nQ782STe24BnAV88iX3fiLhHZv71XsvXWTH3SY7aX8rRqD0WZjhsl20Nr5LPA3Biq71pbsSoWXZsMGyWDYp6G1Es+Fa7aLhRLHcWZcUOrnU/nmFxn56Tg+nrEeDkVc+ZPu+0aK+vzWgv+Kk4VdRrxzwt25/BZvH5VGUbOf2zq0ZnVX3coCiL9mewWXymg6LeRlFvs/jsKoPG0p8R7e/VZvHlP71YX2cUn81lo2I7KbaFy7L6fNr9rPYNg1G7rG/Vd7+sV2y11fd/VGxDW0VfRsV6Hg2mx8xhu60o9qNVSlfVk9RmTtxDTpzJxonGvrDYf24ca5dlY/8JUKSNzcSlPKR0LCtSeqKoV6QD5Y6+OoeIUfsY0EwVquWuFq6oV/axY71qW8jquF6WFX1p1KvjzaKP3S7kjKqNvcjxuqjOBaqyQZGzlOcXVY7aNbetzo+KmFW9LvHWQXVu3iWrr7bljWI7KfvR+NyK00zpyDAnPnxOPCK4fLRyfyKYqb6nGtf8+Nnt3wbtvPCMQfuablGtzF8rgyLooHHtf96q67bVtdny3KlYX6Mi0avOIY4N2jG7XtdtnQdV16ulPqziDAy/zjiZfFRmPiAzn5CZ92CcHN4GeNos4kTEtYHnAUPgnMz8vsz8UeC2wF8BD4qIh+xq423AXYHrZOYtgXfso1+PY5yUvgK4U2b+eGZ+B/Ag4OrA8yOqy2iSJB1tyfgEoc/HcpwuSVdiTmxOLElSkzmxjghzYnNiSZKazIlX10olOBFxC+BewMXAr+0qfhJwGfDQiLjGDOI8CLgB8LLMfNv2i5l5HPjJyX9/aGegzPyXzHxTZn5mz4Ub9yuAH5z898cyr/jdUWa+CngT8J+Au+0nniRJktaPObE5sSRJ0lFnTmxOLEmS1tdKDWAA7jF5Pm9n0gaQmZcCb2Y8+vTOM4izXee1U+K9EbgcuMtkaq+ubgl8CfDezPzglPLX7OqLJEmaYkj0+pCWjDnxlfsiSZKmMCfWmjMnvnJfJEnSFObEq2nVbnB1m8nzexvl72M8YvbWwOt6jtOsk5lbEfFB4MuBWwDvLtqu7KdfTPpVioi3N4rOOminJElaJQkMyxvHd4spLRFz4jFzYkmSGsyJdQSYE4+ZE0uS1GBOvLpWbQaGMyfPn26Ub79+nRnE6avtyjzakCRJ0mozJz58G5IkSVpt5sSHb0OSJGkprdoMDHvZnrvjsANgusTpq+1e2sjM208NMB5xe7tOrVetZnvalNGoPU7m5NbG1NePbQybdU4M25vtscGoWTaI9gJsFGWzMCqmmTk1mL5OhsV4o1PZXienBu2yzdhqlp0Rp9oxo1vMzWh/rqdlu6yqt9HYMKvPezPb20m1LWxmt21oUGxe0z/t7Zjt5a5Gn200tq9BtLe7Vp29yk6Pdk8Gxfdxo/q8q8+n2BENOtZbFtV3fFTtY4sRpMeivU5Ggyrm9Hpb1eddfQeKsuqTiUa9YlPefgej3sdoOj2YVoo58fYbipw4RtxucLK9n2zG3GjvDwYbxf6uOOiPGjEHRRKRxX682F3XZe3Dc5lHjIp+VjGrXXWOprdXHNqqUxIYFZtLsS6zyP+yPAcqtpNqudtFnZSncFX/i+Ne17yklV8A5WG26suw6Muxng/dG8XGV56vdKw3KOp1zW3rmAffH3ZV5YbV9jULgw45Y7WdV+dw1XSzVS/a7e21HZgT68gzJ95+Q5ETj4jbXZabvXZsFVTXYHRV1bFP66fKWarcttpOqr81bFQXz6sUdQabZevc43Taf/OoVOcrnc+5Bu18szoPbV1nhT2u3TbKutQZl1XrZBbMiVfVqh15tkeWntkov/au9/UZp6+2++6XJEmSjhZz4sO3IUmSpNVmTnz4NiRJkpbSqg1geM/kuXVvr1tNnlv3BjtMnGadiDgG3BzYAj6wR9t990uSJO2QjEeL9/lY/jk8dMSYE1+1X5IkaQdzYh0B5sRX7ZckSdrBnHh1rdoAhjdMnu8VceXJTyPiWsDZwOeAt8wgzusnz/eeEu+uwNWBCzLzxF4LUbgI+BBw64i4+ZTyb9zVF0mStEsCwxz0+jAx1ZIxJ75yXyRJ0i7mxDoCzImv3BdJkrSLOfHqWqkBDJl5EXAecDPgkbuKnwJcA3hxZl4GEBGbEXFWRNzyMHEmXgF8AnhIRNxh+8WIOAP42cl/f6Pzwo37lcBzJ//93zuT5oj4ZuC/Au8C/uIw7UiSJGl1mRObE0uSJB115sTmxJIkaX0dW3QHOvhh4ALg2RFxT+DdwJ2AuzOeMuuJO95740n5PzNOQrvGITM/ExHfzzhBPT8iXgZcAtwfuM3k9XN3dzYiXrjjv2dNnn8xIi6d/Ps3M/Mvd7znGcA3AQ8C/joiXgd8CfBg4HLgezNz1Fg3kiSJYET0HlNaMubE5sSSJBXMiXUkmBObE0uSVDAnXlUrN4AhMy+ajGx9KuNpuu4DfAx4NvCUzLxkVnEy85URcTfGSeu3AmcA7wceBzx7MjJ2t++e8tq37Pj3+cDnE9PMPBERXwc8AfgO4LHAZ4BXAk/KzHftZ/kkSZK0vsyJzYklSZKOOnNic2JJkrSeVm4AA0Bmfhh4+D7edzHFUJj9xtlV582Mk9j9vv/AQ3Ey83PAkyaP+apu3lKUVWN9h8P2KhhuTL+LycmtjWadjWh35MSgvUkPinrzNio2i2FOXyejxusApwbt9XUq22WbMWyWHY/NZtlpRb0zBqeK9rbaZbRjbkR7A2stw0axUVbLvTH1/HK7XjtmVa+6K1K1Pdcx21oxB8VXoL2V1Dai22jDM4p65foanGyXjap68/tBQvVdHQ2KsmLk5taoXW9r0N6et6q+FPuhrca2fqxYj619F9T732HRj3a9en+ewLDnu2QtzxFEuoI58SFlEqem70OrPchgs126cbK9t8iNYn/XOBAXaRxFOlOXFQtXHdaL3TwUh9mqvRy1G4zGcb38jWHVx2ITnP73hYmij1kkV2XI4rg+KGO2+9I6rkeHOrNStTeLvrRysrKtGaySQXEOUZWV5yzFl67Ku6p6zTpFH2ei42dQ5aKV6jy0lU+OOqxHgEGxk6rOITYa28Jeq8qcWEeFOfHhjHLAZaPTZxH6wEardbfrhRr669+5qPKLuedIHXXNkeapWpfV3xrKlKzjYjfXVxGvPM8ZVOdA7aDD4npvfQ25+HtCcZ5QlY0aZbPYC0XRj+rctmJOvLpWcgCDJElSU87gBK3nzDQi/ivwGOAuwPUYTzf6D8CvZOar+21NkiRJR86S5sQR8QXAA4H7Al/JeFr/k4xz4RcAL3BKfEmSJPViSXNi7c0BDJIkSXMUET8J/AzwCeCPGU9Nen3gq4FzAAcwSJIkaV09GPgNxjnwG4APAV/IeBr93wS+MSIe3Jh+X5IkSdIR4AAGSZK0VpLoferJ7GlitIh4MOPBC38OfEtmXrqrvH3/HkmSJGmfljgnfi9wf+BPds60EBE/AbwV+FbGgxl+v4/GJEmSdHQtcU6sPSz/DXAkSZLWQEQMgF8ELge+Y/fgBYDMLG7uJ0mSJK22zHx9Zv7R7ttEZObHgedO/nvO3DsmSZIkaWk4A4MkSVo7w1zKkbB3AW4OvAL4VETcF/gK4Djw1sz8q0V2TpIkSetlSXPiyvZg3q2F9kKSJElrYwVzYuEABkmSpP06KyLePq0gM2+/j/pfM3n+V+Bvga/cWRgRbwQelJn/fqheSpIkSbNz2Jx4qog4Bjxs8t/Xdo0jSZIkafU5gEFXEsVIpKzKRlVZ+04lo9Fo6utbw41mna2N6XUAThX1BmSzrDKIbvUqw+LuLa2yUXFfnVPZXu5Tg3bZZgw7lZ0R7RnOTxZ9Oa1jexvR/sw3Y/oPMzbpFm+j2E4GZb2qj0Vfst1e1ZdKa5stl60o2yi+A1X/u96jaKMYEFnFvPqg/SOdQdHPvg2z+n63F66qV32Py/1Jsd+uyo41+rJVba/F92Mr2n2cxfjXpF4vXWP24IaT5x8EPgh8HfDXwE2BXwa+AXg5TpkrzUdCnGrvu1oGp4rc9lh7rxbD4pjZSBVyq8ixN9rxclj0o9g9lmXtdIbBoN3eaNDuZ3HooJVaVecdVMf7sq0q+SjWc1UvqvOqImbX87Gef1EyKuKVZR2P7FW9KmcZFflTvYE12iryh+r8outyVzqfXxTLPShitnL+qh/zVn4+xTrp+ourjUZ7XfPM6pxrVKzndnt1hrrEOXHLLzCenezVmfmns21K0rYhwaWjqy26G0ulunbT9Vpd1/Y0e2U+qaVWXbM+rZjMaVScq9G6BFucDw8HxTWCIg/dal0I2KtesR86VsWszrmKv+G1VH83ixn8Ta2rFcyJNeEABkmStGZiBiegAXDhYX5VxhWnQcF4poV3TP7/TxHxQOC9wN0i4mu9nYQkSZIOZ2lz4qtGjXgU8HjgQuChfcaWJEnSUTaznFgz5vAySZKk+fjU5PkDOwYvAJCZnwO2f2l2x7n2SpIkSVqQiHgk8CzgXcDdM/OSBXdJkiRJ0oI5A4MkSVorSzw12Hsmz//RKN8e4OD8nZIkSTqUJc6JPy8iHgM8E/hH4J6Z+W89NyFJkqQjbBVyYk3nDAySJEnz8UZgC7hVRJw2pfwrJs8Xz61HkiRJ0gJExI8zHrzw94xnXnDwgiRJkiTAGRgkSdIaGuby3YssMz8REecC3wn8NPCT22UR8fXANwCfBl67mB5KkiRpnSxjTgwQET8FPBV4O3AvbxshSZKkWVnWnFg1BzBIkqS1kgSj3qcG6y3RfRxwJ+CJEXFX4K3ATYEHAkPg+zPzP/pqTJIkSUfTsubEEfHdjAcvDIE3AY+KuErcizPzhYduTJIkSUfasubE2psDGLR/xY1dctT+wmYxumk4nL7j2NgYNeucatQB2Bi0yyI22mXD9sIN2GyWVapRXacP2n3ZapRtFct2+mCrWXYq222dHu16m0XMUbT7slms5+PRXs+nVX2JYbNso/H5lHWivX0NaJdV9Tbp1l5lo/jSDYqYGzm9rHu8dr0qZmVQbAtVe11V/bxGnJpe0DGvGWW7YnW/rape9T2uyraK7+PJ4jNofT6DchvqvyyKslWVmf8WEXdiPPvCA4E7A5cCfwL8fGa+ZZH9k46UTOJU+/jdEqeKPGKzvS8fbLX3aaNj0/PGIp3pXtY+NFClLFVZI/UYq2JW5xeNsvLQUJ2TVMf1IveoznNiUNQrzgXqsmYRo6LeqFGvaquO163/XWPOwqhxUanKx44VG+yw2Iiqc495q85nTiv62VqGrucyXZXruTjnGhYXETeLTa/O3ad/sarPu7oOsFFse9V22crBV/iy6c0nzxvAYxrv+QvghfPojHTUjRhw2WjaHQ41Td9/BJu36jhbmXc+0Leuy70qqjyii43qJG4NVNciW/nmGYPG9WPa5x1QnwNVn1uVUx4rtuetoqy6rrsxKK5zNGJWZ0Ddr/eucIar3jmAQZIkrZ1lPjmdTJH7uMlDkiRJmollzIkz88nAkxfcDUmSJB0Ry5gTa29+apIkSZIkSZIkSZIkaeGcgUGSJK2VpJ6+rWtMSZIkaVWYE0uSJOmoMydeXQ5gkCRJ6yWj/6nB5nzfbkmSJOlQzIklSZJ01JkTryxvISFJkiRJkiRJkiRJkhbOGRgkSdJaSWDY8xhNpwaTJEnSKjEnliRJ0lFnTry6HMCgK6u+eWVZe8qUHBXVRtPrDYftHcpWbDTLTg3anawmdRlE/7uc0Ua7xVExZc2osS6r+/ScyvY6OT23mmXDQbsfm0XMU9HedWwO2u1txrBZdoLNot7BY25Ee8Mb0C7bKLaFjaLeoGjvtGK5K3U/i7LGl7XveHup1slGtWMoVH2p2uu7rTPiVLPsWhufa5ZVyVLruw/1d7xr2bFRe30da6zLY4P2trxV7Neqfews9r+StB+RSZxq5BjFuW0M23lQbBX7uw5lxW6c0bB93BgM221lUa9Is6l219UhOBr5PkCOity9Ua+q0/lcpuhjtS1kdQ5UNJjVIpQxD16vyi+6xIPu9w+tz4HaG1HXeu061XlasWxFUTUladV/ivOEKm/cpNv5RaV1PlCdi3U9T6gMo9v21XVa2FG067ViDouNYaP43IbVuUx1rtaIaR4tqQ+jDC4fnd5rzL7/UKSDKXMPraUqN+liFjnequiyLqu/eWwW11I3s7jOWpycbxUn4F3LBkVO3Mo5q1x02PEWC2F+qx0cwCBJktZO+QcISZIk6QgwJ5YkSdJRZ068mhyOJ0mSJEmSJEmSJEmSFs4ZGCRJ0lpJYgb3NnOkriRJklaHObEkSZKOOnPi1eUABkmStHa856MkSZKOOnNiSZIkHXXmxKvJT02SJEmSJEmSJEmSJC2cMzBIkqS1ksCw56m8stdokiRJ0myZE0uSJOmoMydeXQ5g0P5l8SXP9lc2i3qtstGoXWdUxNsaticVGUSxW9kqvgodvyWjYqdYLUOrrIp3LDaKeO11cirb9TZj2K0s2yusqjcodvubg60Dx9wo4g1idOB445jtehtFzONlvXY/q/aqZWjHK9rqEA9g0HGdVMrPrmivjNnz+qqSnk3a29A1BieaZdX38Xie6lTvxKj4Pg7a/dxq7DdOjtptVfvY6vtdacX0LmOSejOcvi+MrSKn3GofU3LYLhtVeepw+v5uNGzv8YrdOFkc9qpD4tzLisNDaxnqOt3OV8rDVOeyqi8HPz86TNk8Vec58z6ADxt9OVb0o8t5GtB52cqpTIvzkuoerhvlRJvFjqODrucCVZ5dqXLwrve1HRX1hjG9vVPFOe+w47lM9bm1YoaXTiX1YMSAS0dnLLoba8/py7Uuhku0LXe99lzpe/nKv3kU+f6p4oT/WNHHrmVbxflyaxmiODmvTo+qa8h9DzTQanMAgyRJWjMxg4sDJtCSJElaJebEkiRJOurMiVfV8gyXkiRJ6sH21GB9Pvx9myRJklaJObEkSZKOumXPiSPiJhHx/Ij4aESciIiLI+JXIuK6s4oTEbeKiB+PiNdHxIcj4mRE/GtEvCoi7t7f0h2OMzBIkiRJkiRJkiRJkjQHEXFL4ALghsCrgAuBOwKPBu4dEWdn5idnEOdngG8D3gW8GrgEuA1wf+D+EfHozHx2P0vZnQMYJEnS2vH+kpIkSTrqzIklSZJ01C1xTvzrjAcdPCozn7P9YkQ8A3gs8DTgB2cQ57XAL2bm3+0MEhF3A/4M+KWIeHlmfqzTUvVkaT81SZIkSZIkSZIkSZLWRUTcArgXcDHwa7uKnwRcBjw0Iq7Rd5zMfOHuwQuT1/8COB84DbjL/pdmNpyBQZIkrZXMYNjzyNrM6DWeJEmSNEvmxJIkSTrqZpgTnxURb59enrffR5h7TJ7Py8zRrvqXRsSbGQ9MuDPwujnE2XZq8ry1j/fOlAMYdGU5g3qj9glu6+R3VNQZDts7m4h2R2JYlBX1Tg03mmWzMGqtE9rr5FiMmmWteADHih33VrSX+9Rg2CzbzHbZoFjPm1HFbPdlo7Hsg2Kj3By0970bRb1BsZ6712uXVeurqtdaJ5VBEa+yUfSxrFcud8e+dNyBtbehbv3o6ow41Sy7+uBks+xU8f04fbDZLDsxaqcAg0Z6UG2T1Xeu3Dd33Ib2Uu0zJQmATGJrev6Rg+Lkdqt9fIitYn9X1WvkmzEq4hWHqRi294FlzKIeVUpc7crL84R2USsVzeI8IbJorDonqa5lVDGLPDuL9ZxRnR9VXWnXa+X8XerMrKw4Ns8i5rKoLpZV50DlNKdFva5a/dzsuIqr3Hwzup2PVYbF92pYTD5areeTjTy7Ogeq+nEq2/n3sDqfbOws9/PRrMJ3RNJijTK4fHj6oruxFtznal30/cfeddDlejt0X5fVeUL1d5uT1bXbnq/rVvGWzZLun28zeX5vo/x9jAce3Jp64EFfcYiImwL3BC4H3li9dx4cwCBJkiRJkiRJkiRJ0t4u3OdMCy1nTp4/3Sjffv0684gTEacDvwOcDvxYZn5qj3ZnzgEMkiRprST9jxZfnTHFkiRJkjmxJEmStMI58fa0EYdtbs84EbEB/DZwNnAu8PRDttkL54KRJEmSJEmSJEmSJGn2tmdGOLNRfu1d75tJnMnghZcADwZ+D/iuzOrmlvPjDAySJGnNRHm/7K4xJUmSpNVhTixJkqSjbmlz4vdMnm/dKL/V5Pm9s4oTEceAlzIevPBS4GGZOdyjvblxBgZJkiRJkiRJkiRJkmbvDZPne0XElf5WHxHXYnw7h88Bb5lFnIg4DXgF48ELLwYeukyDF8ABDJIkac0kMGTQ62Mp5s2SJEmS9smcWJIkSUfdsubEmXkRcB5wM+CRu4qfAlwDeHFmXgYQEZsRcVZE3PIwcSaxTgf+APhm4LeAh2fmqIfF6pW3kND+Vd/KYgqW6nYpra9ERntszWjUjjcatettNUtgsESzII4anRlle9mODdoDo6rpcY4VMU9Gez2flu21eTLau5Vj0e7niaLeZlFv0OhnVWcj221Vh5+NaO/DO9cryjaKmF3rdYlX2aBbvdbnNqv26s+u32PzRsdlK2MWfay29ars9EH7e3xiMP07cmzUbVvu6jC75v6nBpO0dhLYmr6fjEE7R4phMSB91M4xqt1kDKcfO2LU3pcVu/i6rWp3XRzCyphd6xXLl42cvzhNoLxLY9eyso9FveIEI4sGszyvajfXKipOncq2quNoVVbFnLfW+VN1XlV+saq2OmYtw6LeZtVetZ6LomHxG5ZNpi/7sFhfVa7ZVXkeV3x3qnVZlY2KddLKb6tt6GRuNMuq84STFPUafYx9nPeZE0vay4jg8tFpi+5GZ133c9V1KfedWkZ9b+tu56urugZ7rGNZFbPLdfyu1/5nZYm39x8GLgCeHRH3BN4N3Am4O+NbPjxxx3tvPCn/Z8aDFbrGAXgucB/gE8BHgJ+OuMo6Oj8zz+++aIfnAAZJkiRJkiRJkiRJkuYgMy+KiDsATwXuzXhQwceAZwNPycxLZhTn5pPn6wM/XYQ+f5+LMhMOYJAkSWslifLXdF1jSpIkSavCnFiSJElH3bLnxJn5YeDh+3jfxRTz7e03zuS95+yzewvV76cmSZIkSZIkSZIkSZLUgTMwSJKktTNc3nubSZIkSXNhTixJkqSjzpx4NTmAQZIkrZVMGPWcmGb2Gk6SJEmaKXNiSZIkHXXmxKvLW0hIkiRJkiRJkiRJkqSFcwYGXVk1cqhzWXt0UzbKqhFMo1E73nDYHpMT0Q66VdTrqhrVNdooliFH0+sMhu14FG0V/TiW7eU+FtP7AXBqtNEs2yz6OSh2OceKeiejqBfT650o6mzQXrZBsZ1UZV1jbhTreVB+sdpaMat4VT8qg471Njou27zb66J7H/tftjMGp5plJ0bt78hmaxuqtteO352q7DBGxf5NksYSho38o8opt4p9YVGWw3bZaDS9vcGwvY+scuLqUNRInfauN4uy4hDQKqvOE6q2yl9IzL2sOj8qqnX41UhVp+9foeylPD+qyopznWoq0GNHdJbQYZEDbVY7gBVQ5Y2bHXPpU8XvejaZvr5O0T4frvLlKj8dFP1vtRf7OMcxJ5a0l2EOuGzr9Lm11+Waifuy1VXlcbPQ9Vpqy7z7L81S39d1Z3VNdxY8jqwmPzVJkiRJkiRJkiRJkrRwzsAgSZLWShIMex4ln466lyRJ0goxJ5YkSdJRZ068uhzAIEmS1s68p8WWJEmSlo05sSRJko46c+LV5C0kJEmSJEmSJEmSJEnSwjkDgyRJWjujdIymJEmSjjZzYkmSJB115sSryU9NkiRpQSLioRGRk8cjFt0fSZIkSZIkSZIWyRkY1I/sWDaafu+ZHLQr5ag97mYUo2bZcDjf8To5aPelrNe4H091n57hqN3W1qC93MeyXe9YDJtlg2h/PlvFaLZBsTEcK+ptFO0NGruxqo+DYjup2+oWs+rLBt3qVWVd2qp0aQtgo1on5Y6hW8y+LVMfq+2re8yDb8/l96Pn7fUwEhjR773NZrEEEfHFwHOAzwLXnEETkiqZ5Nb0fCc2Ntr1hsU+ucjJGLb3JDGaXhbD9r6sVWdc1u4GRU5ZxazqlSlGeS5w8LLqkJLlOUmx3J1jdltf2bnewcuqOpV6sdsxq+Pvstx3tOrjsPiNR1W2SfvcqWtOMizqbXaK2L9R+ZuY9jqpdF3uKnevctjNYod5qnGOulGdFxY7tlMUx5ZKo7m9tqxVyYklLVZm8LnhshxZNGvVcaHrdbC+jzWS5m+Zruv2zZx4dTkDgyRJ0pxFRAAvAD4JPHfB3ZEkSZIkSZIkaSk4A4MkSVozwbD3X3n2/ouCRwH3AM6ZPEuSJEk9WomcWJIkSZohc+JV5QAGSZK0VjJhVNyWpmvMvkTElwG/ADwrM98YEQ5gkCRJUq+WPSeWJEmSZs2ceHU5gEGSJGl/zoqIt08ryMzb7ydARBwDfhv4EPATPfZNkiRJkiRJkqSV5wAGSZK0dka9Tw3Wm58Gvhr4L5n5uUV3RpIkSetriXNiSZIkaS7MiVeTAxi0b1F8ycspU0btombIUdFWsa/Jot4oqp1Uv1PIAIyKdVLtMFv349kYtfs4HLRX8ka2y4ajdtnWoN3eINoLd6yIOYiibLTRqb1W2YCD1xmXFeuyqtexvcos+tKlra7936i+/GVf+l+XXcyi/11tFJ/PLGzGcOrrXbatNXPhfmdamCYi7sh41oVfzsy/6q9bkjpJYDR9f8ew8TpAkevEVlFWJIcxnF5W1iny3uqwMZOy4vDQd1l53lHk2FFUXJXpH6t+ZocLMl3qzEo1peeoOJ+pY85v+YZF/1t5FewxlWlRbxaGjfu4bs61F7OxUeSwm8Vmssn0z+BUsUPcLD7T40U/qj62ztVijudGktbXiOBzw+l7+1Fxj2+vDyxW9dlo8WaRh/Z9vbFrH7v2Y97tVbr0ZZ7XpFeFxwHNmgMYJEnSWkn6P5k/bEq+49YR7wV+6vA9kiRJktqWMSeWJEmS5smceHU5gEGSJK2ZmMFo90PHuyZw68m/j8f0WYGeFxHPA56VmY85bIOSJEk6ypYyJ5YkSZLmyJx4VfU/b/4cRMRNIuL5EfHRiDgRERdHxK9ExHVnHSci7hIRr46ISyLi8oh4Z0Q8JiKa899HxHdHxFsj4rMR8emIOD8ivql4/1dGxO9ExPsj4nMR8ZGIeENEfFtErORnJknSEXcC+K3G4+8m7/nLyf+9vYT2xZxYkiRJR505sSRJ0vpZuRkYIuKWwAXADYFXARcCdwQeDdw7Is7OzE/OIk5EfDPw+8Bx4FzgEuB+wDOBs4EHT2nn6cDjgX8BngecBjwE+KOI+JHM/NVd778f8P+AEfCHwCuA6wMPBF4GfB3w/XstnyRJR1l5T+kFyMzPAY+YVhYRTwa+GnhRZv7mPPul1WVObE4sSdJeli0nlvpmTmxOLEnSXsyJV9Mqfmq/zjiZfFRmPiAzn5CZ92CcHN4GeNos4kTEtRknlkPgnMz8vsz8UeC2jH8p+aCIeMiuOndhnJReBPznzHxsZj4SuD3jpPbpEXGzXf36BcYDS+6VmQ+e9OsRwJcD/wY8IiK+ZJ/LKEmSpPVkTmxOLEnSyurrV/M68syJzYklSdIaWqkBDBFxC+BewMXAr+0qfhJwGfDQiLjGDOI8CLgB8LLMfNv2i5l5HPjJyX9/aFesH5w8Py0zP7Wjzna7pwMP31XnFsBnMvMvdr6YmR8H/nry3xtUyydJ0lGWwCij10cueqGkHcyJzYklSdrLMufEk1+7v53x8f+tjP9I/AHGv3b/q4j4gp6a0hozJzYnliRpL8ucE6u2areQuMfk+bzMHO0syMxLI+LNjBPOOwOv6znOdp3XTon3RuBy4C4RcXpmnthHndcAPzV5z5N2vP5PwO0j4r9k5l9uvxgRN2Q8ddlHgXcVy3Y4GUVZ8bWsvrFdykbtfmS0A446jsnJatnKeu1+bhRluza7fcXMQVGnWQJbo/Y6GRYxN4o+DorP4FTRmyjqHSv6UrU3aLQ3iI7xirJKlz4eKmaxfBsdlqHqY9d1UrbXc/+h+3ru1FbR/7refNObDbr181ROv13nLL47lcNEHFEcz5ZMZj4ZePKCu6HVYk7cV048mr6nyVF7/xnDIicbFnlQo62yrNiNl7vdoqw8hHWs1zVmXdbYjxd5e7VOynS/7z5Sn1/U/ex2/Go1N+oYr6rXNWbZXsfjdjkVaId8rfNyzzntGBbnvZsMe22rPsdutzUsVspm177M+TM4oxFzs9gxnOi4/jeqnU2jaD/nP0ucE+/8tftztl+MiGcAj2X8a/cfbNSVtpkT95ATjzK4fOu0w4SQlt4SHw91CFUutCyfedfr1cvSf+h2/tf1OnF1PnxUrhPrCis1AwPjKbsA3tsof9/k+dYziNOsk5lbwAcZDwi5BcBkVO6Ngc9m5scO0NfHAp8B/jwizo2In4+I5zFOWC8FHjC5j3YpIt4+7QGctVddSZIkLTVzYnNiSZJWUl+/mpcwJzYnliRJa2vVZmA4c/L86Ub59uvXmUGcg9bp1NfMfFNEfC3we8B/21F0KfAC4B8a8SRJEuPRun3/OrTrL2KlGTEnNieWJKm0xDlxX7+al8yJzYklSSotcU6sPazaAIa9bG81h53Hukucrm1f6f0R8fXAy4C3AQ8DLgRuBPwPxlPo3Tci7jYZzdsOmnn7qZ0cj6693QH7KEmSpNVhTrwd1JxYkqS+nTU5jl5F67i7y35+7X4vxr9EdwCDDsOceDuoObEkSVoxqzaAYXs06pmN8mvvel+fcQ5aZ6/3X2XkbURcDziX8X3SHpiZl0+KPgA8LiJuDjwA+C7ghY24kiQdebO4P7e0RMyJzYklSdrTkubEff1qXjInNieWJGlPS5oTaw+DRXfggN4zeW7du+xWk+fWKO7DxGnWiYhjwM2BLcZJJJl5GfAR4JoR8UX7bOMuwHWBv96RlO70hsnzfka0S5IkaT2ZE4+ZE0uSNH8XZubtpz16it/Xr+a1/syJx8yJJUnS2lm1AQzbidm9IuJKfY+IawFnA58D3jKDOK+fPN97Sry7AlcHLsjME/us84273gNw+uT5Bo1+b79+slEuSZIYj6zt8yEtGXPiMXNiSZIKS5oT9/WrecmceMycWJKkwpLmxNrDSt1CIjMviojzGN8L75HAc3YUPwW4BvB/JqNaiYhN4JbAqcy8qGuciVcAvwg8JCKek5lvm7RxBvCzk/f8xq4uPxd4KPDEiHhlZn5qUudmk3ZPAC/Y8f6/Yjw69+yIuFdmnrddEBFfDPz3yX9X6x6A1Zj5RlmOip1AVDuIdmOjot5g1I44LMb5ZLbbK4rKndxwNL3ixqBdZ2PQ7uNGsXDDoh8bo3bMQbQXriqLouxUY7kBjkXxATVUy131sVIud7HtDTr0f6/2utTrHK/jD1+697/b+qpsdOxLy7zXybJYlQQt6b+vq/3Jad2YE/eUE2fCcDi9bFiM8x61j1NRJIAxLMoaeVB12GjVGZe194F1zHZZl5z+MO216lXxqvy7a/9LZcz2Z5BVWRG0qtdFsQkdIma7j12PzX0f06tzoGMzSHWG2d6fbEZjHwSMinoU9eq+tBdwczXSvLnaaFxD2KjqVOeFtD+34x12RLFHnSXOifv61byOOHPifnLiUQbHhyv1JwKtkL7zV6ivL3dpr4pXmcWySatkRP/nfpXmd26PtpY4J9YeVjE7+WHgAuDZEXFP4N3AnYC7Mz65eeKO9954Uv7PwM0OEYfM/ExEfD/jBPX8iHgZcAlwf+A2k9fP3VXngoh4BvA44J0R8QrgNODbgOsBP5KZF+94/0cj4mcYJ8eviYg/Bi4EbgR8C3BN4A8y89UHWF+SJElaP+bE5sSSJK2iK/3aPTM/P5ztgL+al8Cc2JxYkiStpVW7hQSTEbJ3AF7IOJF8POPRs88GvjYzPzmrOJn5SuBuwBuBbwV+BDjFOPF8SE75OX5mPh74HuDjwA8ADwP+CbhfZv7qlPc/FXgAcB7je509Hngg8A+Mk+kH72f5JEk6ykZErw9p2ZgTmxNLkrSXZcyJJ7nHeYz/gPzIXcXbv3Z/8a5fu0tTmRObE0uStJdlzIm1t1WcgYHM/DDw8H2872Job037jbOrzpuB+xywzouAFx3g/a8CXnWQNiRJknS0mBNLkqQVdaBfu0sVc2JJkqT1s5IDGCRJklqSmMG9zRxdK0mSpNWxzDlxZl4UEXcAngrcm/EfgD/G+NfuT8nMS3ppSJIkSUfaMufEqjmAQZIkrZek98SUq0z+KUmSJC2xJc+Ju/zaXZIkSTqQJc+J1TZYdAckSZIkSZIkSZIkSZKcgUH7V40qKsuK0U2jxuvRDpijIl41kKrVFjAqhvIMqnpFc/X4oHbNjOkLUa7ibJeOioqDYn0Ni89gUJRF13rtrnCqQ8woFrzqR1lWfArVcle69qXvtsp6HYcUDqL+hrTrzXcI47Ks52XS5TPvOpK1qtcq20/veh9ZK2ntJEkOh1PLIovTpCLvYlQljgdPKqt8psqxq0NR95jd6pUJc5fzi47nJNU6yar/1XJ3NYuQhzhmHiQeLNcxtswjnNZz5obFOt4s67XPlTeZvl9eJtWZ/mZ0uw6w19WFg/bj81GX6PsqaTklcGLonwjUXZlLF6prqV1jdmlrHfS9vqTD6nK9F2a3LZsTryZnYJAkSZIkSZIkSZIkSQvn8EpJkrRWkv5H1q73WH1JkiStG3NiSZIkHXXmxKvLAQySJGntOH2eJEmSjjpzYkmSJB115sSryVtISJIkSZIkSZIkSZKkhXMGBkmStGaCEX2PrHWkriRJklaJObEkSZKOOnPiVeUMDJIkSZIkSZIkSZIkaeGcgUG9iOIeMkm2K7aKRsUIpmpw0+jgTe1lVAzzGRTtDavFznbQaCxfFvGq1TUoPptqVQ6i3WAUZRuDbvUqXfpS1unYVqVrvWqdzLsvzXgdvz1dP++uel/uOfd/Fua5LVQjWbeKHWl1D7Ku9ydLYNTzvc1Wf2uQNFUrwRoO23WGRQI4qhK2dlG06hXxouhiMx5AlRtWO7uirKrX+VDUqle1VYXr2I/yPKcK2nm5q/Y6xmzGa7fV93F0r/ZWXbm+iqJhcV64WX3JC8PidyqbnSIeXcPGl27QOmnfo+yM8jdExUGiURZ77GjMiSXtR2Zwcrix6G6ooct+fBbXs7oeT7r2ZRa5qHQUzOKcq8s1/q7Xe6vvvteJjx5nYJAkSZIkSZIkSZIkSQvnDAySJGm95AxGHDu0VpIkSavEnFiSJElHnTnxynIAgyRJWjtONyhJkqSjzpxYkiRJR5058WryFhKSJEmSJEmSJEmSJGnhnIFBkiStlaT/qcGcGUySJEmrxJxYkiRJR5058epyBgZJkiRJkiRJkiRJkuYkIm4SEc+PiI9GxImIuDgifiUirjurOBGxGRGPjogXRMTfR8TJiMiIeER/S3Z4zsCg2SuHIzVGPmVRaVQ0VQykiiJkjrqNwBpFu14UDY6q5WvUy2yPNyq6wahYtqqPVczBoP0hDIvPZ1B9CIW6n9PLBh0H1VVtVWaxbF3b6/uOTl2XrWu9Stf11bdZLNu8LcsyVPcgG46m7/f2HjUbM7i3mfdKk9ZOAqNG4jKqEscqT20nQlHVa5RFkVfV8Yr8r9r9HzxF3bNepYrZKitz+rKP1TppVywXrTrWdPx8yhaLeq1jY9+/NNlLefytzlmKevO8X+moOOfqumxH1bBYl5sx7L290Qp8CJvR9TdE0w8Ge5/zmhNL2tsog5Nb/olgkapTjy66XhPtux+SavM+V5un6hp+tdzVbqj1d669d13LmxNHxC2BC4AbAq8CLgTuCDwauHdEnJ2Zn5xBnGsAvzL5978CHwe+uI9l6pMzMEiSpLWT2e9DkiRJWjXmxJIkSTrqljgn/nXGgw4elZkPyMwnZOY9gGcCtwGeNqM4lwP3Af6/zLwR8PwelqV3DmCQJEmSJEmSJEmSJGnGIuIWwL2Ai4Ff21X8JOAy4KERcY2+42Tmycx8TWZ+7DDLMGsOYJAkSWslGU8j3OfDH5xJkiRplZgTS5Ik6ahb4pz4HpPn8zLzSveMy8xLgTcDVwfuPKc4S8cBDJIkSZIkSZIkSZIk7e2siHj7tMc+699m8vzeRvn7Js+3nlOcpXNs0R2QJEnqVUJm9B5TkiRJWhnmxJIkSTrqljcnPnPy/OlG+fbr15lTnKXjAAZJkrR2Rn0nppIkSdKKMSeWJEnSUTejnPjCzLz9LAJPbHf6sMMl+oozdw5g0JVEsQln1827qtfab1R1qp3NqF1UdqMIWS52scKyCBpVg62Y1QdQ9KNqK8p67eZGo24xK+Uq6RCzcz+KskHnZev/2FDFHDQWYhb96LpOuprFMnTRdbmrZGkW63IVLlcOi3UyLPY1knR4SQ4byWORd8WoSjiLfXlRL0bT60UVr1tquFT1Sq161blA1xOWWfS/o87nXJ3a6nacXY5sbGxUZDutHGOUxZ00o/h+d1T1sXPMchmG/cbsGG9jButy1Q2Ku7ieHtUdXremvhorke1LWnYJnNzaWHQ31t4886fq6LBMeZwOpmvuvizXUo+q3n/5v4eun3eXfs5i2xqN2jnxvNflHGzPjHBmo/zau9436zhLxwEMkiRp7czzD0CSJEnSMjInliRJ0lG3pDnxeybPt26U32ry/N45xVk61RBvSZIkSZIkSZIkSZLUjzdMnu8VceXp2CLiWsDZwOeAt8wpztJxAIMkSVoryXhasV4fi14oSZIk6QDMiSVJknTULWtOnJkXAecBNwMeuav4KcA1gBdn5mUAEbEZEWdFxC0PE2eVeAsJSZIkSZIkSZIkSZLm44eBC4BnR8Q9gXcDdwLuzviWD0/c8d4bT8r/mfFgha5xAIiIJwBnTf5728nzwyPiv0z+/ZeZ+ZuHWLZDcwCDJElaM+PRsH3HPHSEiC8AHgjcF/hKxonnSeAfgBcAL8jM0aEbkiRJkpY0J5YkSZLmZ3lz4sy8KCLuADwVuDdwH+BjwLOBp2TmJTOMc2/gbrteu8vksc0BDJIkSb1JGPWdmPYzX+6Dgd9gnEC+AfgQ8IXAtzBOCL8xIh6cmc7OK0mSpMNZ3pxYkiRJmo8lz4kz88PAw/fxvospRk7sN86O95+z3/cuigMY1I/iCxvFaKT232iKHcqo2jsU9YpqOShCls0V7UW7YrW/jEZfRh3bqnbNUdQrVe11PBZUfSkXvesy9BxvFsvdVZeYVfcHM+hjV7NYX13a6n/U5nyXbRYGHVdJtUsfjqbvEFd4Tb0XuD/wJztnWoiInwDeCnwr48EMv7+Y7klHTAKtSU9G7clQsiiLYqfWaX6VaofXsaw83HStV+jaXqtsFv0oQ3Y96BS5QjVObVl+2zyLXEfaj1F1ch7rO1HVZmw0y0ZMX26/pZL6kBlsDasLo/23twy6XoNZlv7r6Ol721v165Crwn1Gf4bD6evSn4Gtr/llJ5IkSXOS2e+jnz7l6zPzj3bfJiIzPw48d/Lfc/ppTZIkSUfdMubEkiRJ0jyZE68mBzBIkiQt3qnJ89ZCeyFJkiRJkiRJ0gJ5CwlJkrRWkv6naJsMrj0rIt4+tTzz9l1jR8Qx4GGT/762axxJkiRp2wxzYkmSJGklmBOvLgcwSJKktbNi95j7BeArgFdn5p8uujOSJElaDyuWE0uSJEm9MydeTQ5gkCRJ2p8LDzPTwjQR8Sjg8cCFwEP7jC1JkiRJkiRJ0qpxAIMkSVo7qzCVV0Q8EngW8C7gnpl5yYK7JEmSpDWyCjmxJEmSNEvmxKvJAQzav2qaley2C4jR9Jg5qOIV/RgW1QZFWcfmsopZ1IsOq7Ke5aZdGFEsXNGRqo9UMatqnWrttQz9Hn7K5S7r9X8Y7NqXbm21+z+LZZu3ea7LZbLqn92odYxYg2m/IuIxwDOBf2Q8eOHfFtsj6WjK0fT9ZHTMbbvmxHToR50eFYXFPrTzYaNjvb4PU1W8sqllOlxWy9Dh+DfvY2bV3qjz2cDyGxYnm5vlSaq0t9Njc+rrgzX+Tkman0w4dWpj0d2QBPUfALqePHU5H5j39cRVuM5XnmyuQP/XQPtc0/W/rhzAIEmS1s4yD3KIiB8HfgH4e+DrM/MTi+2RJEmS1tEy58SSJEnSPJgTryYHMEiSpPWS9P9r2p7iRcRPAU8F3g7cy9tGSJIkaSaWOCeWJEmS5sKceGU5gEGSJGkOIuK7GQ9eGAJvAh4VV72/ycWZ+cI5d02SJEmSJEmSpKXgAAZJkrRmYgZTg/US7+aT5w3gMY33/AXwwj4akyRJ0lG2tDmxJEmSNCfmxKtqsOgOSJIkHQWZ+eTMjD0e5yy6n5IkSZIkSZIkLYozMEiSpLWSQPZ8LzJvbSZJkqRVYk4sSZKko86ceHU5gEFXVn3zqllR+v7Gdo1X9XFUFEbR4FXvT36Fqp/F/Cbl4lXtNet07H9Rr2sfo3PMzoWNfhy4yqRi/4efeU8o1PoMqqmSqs+tbszDdV86b7Mz0Hl76Flzm91H9/qfGkzS+knI0fSiUeN1gFG3fWQUZ8yddrvVGXh1zK/amndZodXPzkeoWRzaluNwCfR/QaYymsExdhYxuxgVmfuwOME7RrHPWCKjchLO4dz6MW/D4nPdXJIv8mBGZ43mxJL2lMFouLHoXqhHVV64TNeedDDzzPelpdT6DnideG15CwlJkiRJkiRJkiRJkrRwzsAgSZLWjyNrJUmSdNSZE0uSJOmoMydeSc7AIEmSJEmSJEmSJEmSFs4ZGCRJ0nrJGdwb0HsNSpIkaZWYE0uSJOmoMydeWc7AIEmSJEmSJEmSJEmSFs4ZGCRJ0vpxJKwkSZKOOnNiSZIkHXXmxCvJAQzatyi+5EkUNQ++d4hREa8oyqqTVRfLoFW1aqWUDXbqSpdK9Trpv49lex116WbZi7KP8/zcZiM6fQarv9y9JyJzXrauX8ejKPexf93PeySpJYv5BSNHVcV+y4qmZpBy1aqUsly2jnl2lzody8qUvut6LvtS5O7l8avfD320IsfKUbYnjhxV30f1Ylis/83V2IRKw+JrtSzLtxHTP4PYxwmLObGkPSWMTi35JM1zT3xXXJVrzqK9WXw+Hr80Q73fTqAjrwX3ZB+fpznxalry7ESSJEmSJEmSJEmSJB0FDmCQJEnrJ3t+SJIkSatmzXLiiLhVRPx4RLw+Ij4cEScj4l8j4lURcfdF90+SJElLaM1y4qPCW0hIkiRJkiRJWnY/A3wb8C7g1cAlwG2A+wP3j4hHZ+azF9g/SZIkST1wAIMkSVo73ttMkiRJR90a5sSvBX4xM/9u54sRcTfgz4BfioiXZ+bHFtI7SZIkLZ01zImPBG8hIUmS1kvf04I5PZgkSZJWzRrmxJn5wt2DFyav/wVwPnAacJd590uSJElLag1z4qPCGRi0WD1/0aMaSVUUZXTsSHRrb6669qNz//tfJ+Wn0+mz69iRZflMod6e59eLWtfvlQ6k2g2tLTctSX3JnncoSxIvRt1i1ofuo3jA2YPHo6U2yum/1xhl9QVZHsPiO7c5x35slDuUtmFj/QNsVF+eGLZjLsk6mYVRsU425tiPFXdq8ry10F5IKyYJcquxf513+tfcFa5IHjrPbi5VHroin490GDP4BX/nv0npStJ90NpyAIMkSVozQf8n0CbDkiRJWiUzy4nPioi3TyvNzNv33OC+RMRNgXsClwNvXEQfJEmStIy8TryqHMAgSZIkSZIkaeVExOnA7wCnAz+WmZ9acJckSZIkHZIDGCRJ0vpxFjZJkiQddbPJiS88zEwLEXExcNMDVPmdzPyuRqwN4LeBs4Fzgad37ZckSZLWlNeJV5IDGCRJ0voxMZUkSdJRt5w58UXA8QO8/6PTXpwMXngJ8GDg94DvyszlXGJJkiQtjhniSnIAgyRJkiRJkqSZy8x7HjZGRBwDXsp48MJLgYdl5vCwcSVJkiQth8GiO9BFRNwkIp4fER+NiBMRcXFE/EpEXHfWcSLiLhHx6oi4JCIuj4h3RsRjJiO/W3W+OyLeGhGfjYhPR8T5EfFNe/TtZhHxGxHxgYg4HhGfjIi/jojHH2QZJUk6kjL6fUhLyJxYkiSV1jAnjojTgFcwHrzwYuChDl442syJJUlSaQ1z4qNg5WZgiIhbAhcANwReBVwI3BF4NHDviDg7Mz85izgR8c3A7zOe6u5c4BLgfsAzGd9v78FT2nk68HjgX4DnAacBDwH+KCJ+JDN/dUqdbwD+H+PP548nbV0TuA3wQOCX91q+eYtiCpak+EK3KlZTulRl1b6jqBfRcaczg31VViuzi67LNgsz6coSLV9L35/pylie79U6m8nWteSfQZooSubEs86JR1Vy23HPW9VbgRmvj2w6s0RW4SMYeYyWNEMRcTrj3OA+wG8BP5CZo8X2SotkTtxDTpzA1hx/49glqTS/kLSW3Lf1YhVOlNVJbwMYIuKawF0njy8Brg98Dvg34O+BN2Tmu3po6tcZJ5OPyszn7Gj/GcBjgacBP9h3nIi4NuPEcgick5lvm7z+U8DrgQdFxEMy82U76tyFcVJ6EfA1mfmpyeu/BLwdeHpE/HFmXryjzi0YjyT/JPB1mfnenZ2OiM19LJskSUdW0v/fAs2FtV/mxObEkiQtgzXNiZ/LePDCJ4CPAD895Qcp52fm+XPul3YxJzYnliRpGaxpTnwkHHp4ZUTcOSJezDgB/SPgxxiPHP06xqNOvw94DvAPEfGuiPiRiLhWx7ZuAdwLuBj4tV3FTwIuAx4aEdeYQZwHATcAXradlAJk5nHgJyf//aFdsbYT26dtJ6WTOtvtng48fFedJzMeRftDu5PSSd1T1bJJkiRp/syJzYklSdLM3XzyfH3gpxnnK7sf5yykZwLMic2JJUmS+tF5AENE3Doi/hB4M/DtwFuAnwMeANwZuDXwVcA9gB8GXgJcC3gWcFFE/FBEHLT9e0yez9s9RVxmXjrpy9Un7fcdZ7vOa6fEeyNwOXCXyXR2+6nzml3v2R41+yDGSf6rI+KOEfHYiPjRiPimGN/nT5IkVXJGD2kKc+IrMSeWJGlZrGFOnJnnZGbs8XjyYnt5NJkTX4k5sSRJy2INc+Kj4jC3kPhHxgnUE4CXZObHiveeDzw3xvO6fT3w34FfBa4D/PwB2rzN5PkqI04n3sd4xOytgdf1HKdZJzO3IuKDwJcDtwDePRmVe2Pgs411877J8613vPYVwNWAvwJeBvy3XXU+FBEPysy/aS3Ytoh4e6PorL3qSpK08rxHpubHnHjCnFiSpCVjTqz5MSeeMCeWJGnJmBOvpMMMYHgC8OuTqbH2JTMTOA84LyK+CviiA7Z55uT5043y7devM4M4B63TpY0bTp7vxvi+cN8HvJLxVGGPZDzt2qsj4ssy8xONuJIkSZofc+K6jjmxJEnS+jMnruuYE0uSJB1A5wEMmfmMwzScme8A3nGYGFNsD6M57AQeXeJ0bXvn+zd2PP+vzHz+5P+XAD8eEV8KfAvw/ewxIjkzbz+1k+MRt7c7YB8lSVoZAUTPU3k5Tlct5sS9tW1OLElSj8yJNU/mxL21bU4sSVKPzIlX12FmYFiE7dGoZzbKr73rfX3GOWidvd4/beTtp3b8+w+m1PkDxonpHRsxZ6vjl7z8Mjembuk8o0vXHVHfe7BDGM+gd9BKHRurFnuZ9sLL1JdO2guQHbe9WPFpj7out9bQam/K0qKYEy8yJ14WoxkcS5fp8LxMfVkB2Tqvcj1qCQ1itPeblsCw8fpG43VJc2dO3ENOHAkxnOeJuRcBpJU2i/OLZdotdFm+Ve9/V0uy3P6ZYX0NFt2BA3rP5PnWjfJbTZ5b9yw7TJxmnYg4Btwc2AI+AJCZlwEfAa4ZEdOmQKvaAPiPKXW2E9erNfotSZJgnLD3+ZCWiznxmDmxJEkVc2KtN3PiMXNiSZIq5sQrqdcBDBFxx4j4/Yi4KCJORMRwymPrEE28YfJ8r4i4Ut8j4lrA2YzvCfaWGcR5/eT53lPi3RW4OnBBZp7YZ51v3PUeMvMS4O8n//2KKXW2X7t4SpkkSdqW0e9DOgBzYnNiSZKWgjmxFsic2JxYkqSlYE68knobwBARDwIuAB7IePKQtwJvnPJ4U9c2MvMi4DzgZsAjdxU/BbgG8OLJqFYiYjMizoqIWx4mzsQrgE8AD4mIO2y/GBFnAD87+e9v7Ir13MnzEyPiujvqbLd7AnjBrjq/Nnl+2iT2dp2bAI+d/PdlSJIkaemYEwPmxJIkSUeaOTFgTixJktTZsR5jPRm4DLhvZv5lj3F3+2HGCfCzI+KewLuBOwF3ZzzN1hN3vPfGk/J/ZpyEdo1DZn4mIr6fcYJ6fkS8DLgEuD9wm8nr5+6qc0FEPAN4HPDOiHgFcBrwbcD1gB/JzIt39ev5wH2BBwDviIg/ZZwoP2BS59mZef6ea0mSpKNqFtN5OT2Y9u/JmBObE0uStGjmxFqsJ2NObE4sSdKimROvrD5vIfGlwO/OOCndHhV7B+CFjBPJxwO3BJ4NfG1mfnJWcTLzlcDdGI8Q/lbgR4BTjBPPh2TmVTbbzHw88D3Ax4EfAB4G/BNwv8z81SnvHwEPBh7DeHqyRzBOZC8EHpqZj97P8kmSJGkhzInNiSVJko46c2JzYkmSpM76nIHh44yTtJnLzA8DD9/H+y5mPE3ZoeLsqvNm4D4HrPMi4EUHeP8W8KzJQ5IkHZQjYbU45sTtOubEkiTNkzmxFsecuF3HnFiSpHkyJ15JfQ5geDlwv4g4LTNP9hhX87QkX+To2o/macgesmvF+enaxc7rckWswEdXis4b7Wo7qsutfsRoH29a832flpo58VE2OqI7n3Ve7DLZXOcF1zyMViAnHmZ74s7N5e++3E1pccyJV0UCW/3u0Ktrkat+HU9SW9e/Q8x7v7AKfy+ZxTpZ2+Xez3KtwLLrqvq8hcSTgP8Afi8ibtpjXEmSJGlVmBNLkiTpqDMnliRJUme9zcCQmZdHxA8AbwA+EBH/AXx6+lvzln21K0mSdBX+rEMLYk4sSZKWhjmxFsScWJIkLQ1z4pXU2wwMEfFfgAuA6wJD4HLGE/rvfvQ564MkSZK0NMyJJUmSdNSZE0uSJOkwepuBAfhFYBN4GPDSzNzPHaolSZJ6twr3ddPaMieWJElLwZxYC2ROLEmSlsIy58QRcRPgqcC9gS8APga8EnhKZn5qlnEi4i7ATwJ3Bs4A3g88H3hOZg67LVF/+hzl+lXA72bmS0xKJUmSpouIm0TE8yPioxFxIiIujohfiYjrLrpv6oU5sSRJko46c2JJkqRCRNwSeDvwcOCtwDOBDwCPBv4qIr5gVnEi4puBNwJ3Bf4A+DXgtEndlx1qwXrS5wwMnwUu6TGeJEnSweXk0XfMHkwSyguAGwKvAi4E7sg4obx3RJydmZ/spzUtiDmxJElavCXOiXUkmBNLkqTFW+6c+NcZXyN+VGY+Z/vFiHgG8FjgacAP9h0nIq4NPI/xbb7Oycy3TV7/KeD1wIMi4iGZudCBDH0OYHg1cLce42ldzPMEd84n012nnsno0Fa3ppZ6epwr6djPTuulqjTv9dX1g62syme+rqov+Mp8IXvWZacH67q++kpMtbzMibV4q5LPrMJufj2PRdJCjbKYDDQWPlOppH6YE6+QwVajYAZpUO/X8bR41XYyi2uwXWLOexvquk6OqHKVzOJ0rMtnMO+/O823uaVxlJY7Im4B3Au4mPHsBzs9CfgB4KER8fjMvKznOA8CbgC8eHvwAkBmHo+InwReB/wQC56Joc9bSDwBuHZE/FpEXKPHuJIkSStvHwnlZYwTSvOo1WZOLEmSpKPOnFiSJKntHpPn83bfbiszLwXeDFwduPMM4mzXee2UeG8ELgfuEhGn77UQs9TnDAwvAy5l/KvBh0XEe4FPT3lfZuY9e2xXkiTpSmb0g9mzIuLt0woy8/b7qF8mlBHxZsYDHO7MeKSrVpM5sSRJWgpOIqMFMieWJElLYUmvE99m8vzeRvn7GF8nvjX1deIucZp1MnMrIj4IfDlwC+DdRdsz1ecAhnN2/PsawFc33ufpkyRJOor6Sky13M7Z8W9zYkmSJB1F5+z4tzmxJEnSlZ05eZ42wHPn69eZQZy+2p6p3gYwZFY3MZQkSZqXgOz7rmkBcOE+R9C2rERyqMMxJ5YkScthZjmxtCdzYkmStByW9jrxvhrh8IM9u8Tpq+1D6XMGBkmSpOWwmr/jWYrkUJIkSWvCrFKSJElH3XLmxNs/ZDuzUX7tXe/rM05fbc+Uo2ElSZLmYyWSQ0mSJEmSJEnSzLxn8nzrRvmtJs+tWxEfJk6zTkQcA24ObAEf2KPtmeo8A0NE3CEz33aI+mcAN8/Md3eNoeURyzKCaRb96H16mf4nXZzJ+l+Wz3Qvq9LPnlXbUGuVzGKyz2r1O7noFDPYn6y3xvraz3pczn1DX4mplog5sa5ksCT7+a7dWJLuaz2NZpAHDZbmRLSbQZGwbCxpMqMV42akOTEnXmEZxKk1TQK7Lta8952rsPo9nqyu1vbV9TOd9wVmaS+re534DZPne0XEIDNH2wURcS3gbOBzwFtmEOf1wHcC9wZ+d1e8uwJXB96YmScOtkj9OswMDG+NiD+IiDsdpFJEnBkRj2Y8cuPBh2hfkiRplVwpodxZcMDEVMvFnFiSJElHnTmxJEnSPmXmRcB5wM2AR+4qfgpwDeDFmXkZQERsRsRZEXHLw8SZeAXwCeAhEXGH7RcnA0p/dvLf3+i8cD3pPAMD8AjgZ4ALIuJ9wMuANwNvy8xPbb8pIjaA2wB3Br4BuB9wBvBy4AWHaF+SJGmqZfxBZmZeFBHnAfdinFA+Z0fxdkL5f3YllFp+5sSSJGkpLWNOrLVlTixJkpbSEufEPwxcADw7Iu4JvBu4E3B3xjP0PnHHe288Kf9nxoMVusYhMz8TEd/PeCDD+RHxMuAS4P6M87RXAOf2tpQddR7AkJnPj4hzgUcD/x34aSYTcUTEKeBTjBPQ7fs5BzAE/gj4pcz8q0P0W5Ikabqk/6nB+ot3oIRSy8+cWJIkLaXlzom1ZsyJJUnSUlrinHjyY7c7AE9lfDuH+wAfA54NPCUzL5lVnMx8ZUTcjfG16G9lnKe9H3gc8OzMXHjmf5gZGJj8QvDnIuIXgK8Hvg74L8CXAF/AeBrk9wPvBM4HXpmZHzlMm5IkSauqr8RUy8WcWJIkSUedObEkSdLBZOaHgYfv430XMx4Aeqg4u+q8mfG16aV0qAEM2zJzBPzp5CFJkrRYCx8j2tYlodRqMCeWJElLZYlzYq0vc2JJkrRUzIlX0mDRHZAkSZIkSZIkSZIkSeplBgapsy4jn7I5SwrRdSTVvOt10F7qQ5hF/+c8mq3TZ75MI+669qXYIDptKx37MZPtsqPO3/8Oit1QaZ59XGf7WY+ua0mHMlimI9waczX3JlbgwDeYQR9HVVLm9qUZWaVfAq3ArkHSgkXCYLjoXkiS1I3XidfXKp13SZIkSZIkSZIkSZKkNeUMDJIkaf10nSZDkiRJWhfmxJIkSTrqzIlXkgMYJEnS+nFqMEmSJB115sSSJEk66syJV5K3kJAkSZIkSZIkSZIkSQvnDAySJGmtRI4ffceUJEmSVoU5sSRJko46c+LVNfcZGCLCQROSJEk60syJJUmSdNSZE0uSJGma3pLEiPi/wKMy83jxnpsDvwvcua92NT+dRxVV9TLm2Fa7aHov9hGzq6ovfbc3i3VZmMnos8Z20tXcR8it+oi8Ve//Hhwx2ZNZrMfWV38/bfm5akHMiY+A6Dcv6Www3370nI7N3yz6vwLrZN6b62AFEquqjwMTiLkYxGjRXTg63KS1IObEKyQhtlYgqZEkaRqvE6+tPmdgeATw1og4a1phRDwI+Fvga3psU5Ik6Sq2pwfr6yEdgDmxJElaCubEWiBzYkmStBTMiVdTnwMYngb8J+BtEfHw7Rcj4rSI+HXgXGAIPLDHNiVJkqRlYk4sSZKko86cWJIkSZ31NoAhM38K+AbgUuA3I+K3I+IOwFuBHwQuAG6bmX/YV5uSJElTZc8PaZ/MiSVJ0tIwJ9aCmBNLkqSlYU68kvqcgYHMfB3wVcCfA98B/DXw5cDPAnfLzH/psz1JkiRp2ZgTS5Ik6agzJ5YkSVJXx2YQ87PAvwMx+f+ngTdm5mgGbUmSJF2Vo2G1eObEkiRpscyJtXjmxJIkabHMiVdSrzMwRMRXAX8LfDvwp4ynBDsNeG1EPC0iem1PkiTpKhKi54eJrg7CnFiSJC2cObEWzJxYkiQtnDnxyuptBoaIeCTwS5OYP5GZvzh5/Q3AucATgHMi4tsz80N9taslUX1hM5pF0apXxmsXtVs6RMyuO6N5tles48pMlm0G9Tr3s2UWB5g5H7R6XycVD8hLba7bwpI4isus1WFOvGKiWw7VKV6Xso79y+rPAUXM7Ht9HEaXrnTsfsdUulbF7Hgg67ubgxU5oA7CH+n2ZcD81uXGDD63DU9MpJVhTrxaBluL7oEkSdKV9TnS9TnAvzG+h9kvbr+Yme8D7gz8OvC1wN/12KYkSZK0TMyJJUmSdNSZE0uSJKmzPgcwvAr46sz8q90FmXkyM38E+JYe25MkSZKWjTmxJEmSjjpzYkmSJHXW2y0kMvOB+3jPKyPi7X21KUmSNJUzDGtBzIklSdLSMCfWgpgTS5KkpWFOvJL6nIFhXzLzw/NuU5IkSVom5sSSJEk66syJJUmSNE1vMzBIkiQti3BkrSRJko44c2JJkiQddebEq8kBDJIkaf2YmEqSJOmoMyeWJEnSUWdOvJIcwKAr6TwSKaNbzFZZUafdUl2vjFnVG3Ws13WdNON1K+v+mXYsK8ykL3O0Kv3vfUThkqz/uZvBclefTbHLOLKjRJvr5IiuD0nzE1HtlDveha+K2UF13JhFvTpmtb6Kil36MoP+L1N7sQIH/cES9bHqyyCKEzlphQxz+racJsUARMRvAd87+e+tMvP9i+yPtHISYmvRnZAkaQ9eJz5yHMAgSZLWj8mrJEmSjro1z4kj4n6MBy98FrjmgrsjSZKkZbTmOfG66vjzIUmSJEmSJEmav4i4AfA84Fzg7QvujiRJkqQeOQODJElaL+mtVCRJknTErX9O/H8nz48Efn+RHZEkSdKSWv+ceG05gEGSJK0fE0lJkiQddWuaE0fE9wAPAB6YmZ+MaN0UWZIkSUfemubE684BDJIkSZIkSZL246yImHrLhsy8/awbj4ibAs8CXpKZr5x1e5IkSZLmzwEM2r+uo5SKes2pW6q2usTbq96oqtceyV+2V8Ts1M+O67/rOulqFu11muJnBttrpfdpiGC5+tIy5/XMLH5Y06Evc13Hy6Ra7hl8Ns3d7x7rP+j/M/I3XdI6CohBzyE77i1a9aruVW113WlV9ea8IyxS8G51ZrFsHhyOlI3iBK8qW3Ub5cmy5mGL4dTX90p31zEnjogB8CLgs8CjFtwdaS1EwmCrS8WODS7L9ZRV778OZhaf96IPivvVWoYlucZ6KKvyGagXrfP9vfLddcyJjwoHMEiSJEmSJEnajwsPM9NCRFwM3PQAVX4nM79r8u/HAncD7puZn+raB0mSJEnLzQEMkiRp/firCEmSJB11y5kTXwQcP8D7PwoQEbcCnga8IDNfPYuOSZIkaQ0tZ06sPTiAQZIkrR8TU0mSJB11S5gTZ+Y9O1b9cuB04OER8fDGe94X41ssPTAzX9mxHUmSJK2TJcyJtTcHMEiSJEmSJElaZhcDv9Uouy9wI+DlwGcm75UkSZK0ohzAIEmS1ktC9D2y1pG6kiRJWiVrlhNn5t8Dj5hWFhHnMx7A8BOZ+f45dkuSJEnLbM1y4qNksOgOSJIkSZIkSZIkSZIkOQOD9i+jWVSOYOpSVtSJUbeyzv2v2uu43HU/i7K++9H1c6t0ba9jzE5tzbEfMIMRftD/OulqVWL2LHIFOnkY81y89q6Z3JheuK9tec0/Ikn9iEFjJzQoxnm36gBEuyzLsoPXqZT1qv1u1dwMyrq0V9aZha7tFQerjh9r3VwjZnRMALvW62ow5/bmabAiScmgPEldX410c1w2v24wKi48nMrh1NdzP9vWamx+khYpYbC16E5I/WidK6xxqgl0O0da93WyCrqe23b97OZ+Lt23wyTnbu8ryQEMkiRJkiRJklZSZp6z6D5IkiRJ6o8DGCRJ0vpxZK0kSZKOOnNiSZIkHXXmxCvJAQySJGntOBWeJEmSjjpzYkmSJB115sSrqbi5qyRJkpZBRNwqIn48Il4fER+OiJMR8a8R8aqIuPui+ydJkiRJkiRJUh+cgUGSJK2f9RtZ+zPAtwHvAl4NXALcBrg/cP+IeHRmPnuB/ZMkSdKyWb+cWJIkSToYc+KV5AAGSZKk5fda4Bcz8+92vhgRdwP+DPiliHh5Zn5sIb2TJEmSJEmSJKkHDmDQlRUjkcr7xIyKeh3aiypeUUa2W+secwb1qnXZWicd6syiH4fqS2We66tjP2ZRL7JjxZ5HDc59fRVmck+qVR9luQL97/q55Ua7bNR1wXMG29GCP4PMfGHj9b+IiPOBrwfuAvz+HLslrbYAonFHvShyyqIsB0XmW928r1WvCFekvWtRr5Nl6cdhFH2Jng9ufcfbK+Zg0QfTNTIoT0TnZ2MGn+myLNu8DYvzwuM5nPp67rX+1zAnljQDCbE1vWgW12fKnKxnq95/HdxR/XiO6nKvuuLSwmyuufddcRb72Oq6SbPS3uXmxKvJAQySJGn9zCaRPCsi3j61uczbz6TF/Tk1eW5cdpIkSdKR5MVVSZIkHXXmxCupy3iWhYuIm0TE8yPioxFxIiIujohfiYjrzjpORNwlIl4dEZdExOUR8c6IeExENH9DGhHfHRFvjYjPRsSnI+L8iPimffbx1hFxWURkRLzkIMsnSZLWW0TcFLgncDnwxgV3R3NmTixJkqSjzpxYkiRp/azcDAwRcUvgAuCGwKuAC4E7Ao8G7h0RZ2fmJ2cRJyK+mfHUzMeBc4FLgPsBzwTOBh48pZ2nA48H/gV4HnAa8BDgjyLiRzLzV4s+HgN+m/IGDZIk6SpmM7L2wgXPtHAlEXE68DvA6cCPZeanFtwlzZE5sSRJ2pO/NtOaMyeWJEl7MideSas4A8OvM04mH5WZD8jMJ2TmPRgnh7cBnjaLOBFxbcaJ5RA4JzO/LzN/FLgt8FfAgyLiIbvq3IVxUnoR8J8z87GZ+Ujg9oyT2qdHxM2KPv7EJP4T97lMkiRpSU1+wZMHeDR/UTP5Rc9vM74wdi7w9Hkth5aGObEkSZKOOnNiSZKkNbRSAxgi4hbAvYCLgV/bVfwk4DLgoRFxjRnEeRBwA+Blmfm27Rcz8zjwk5P//tCuWD84eX7azl9FZuZ2u6cDD2/08Q7ATwE/A7yzWh5JknRl0fOjJxcB7znA46NTl208eOEljH/R83vAd2WmY4mPEHNiSZK0H0uaE0u9MCeWJEn7YU68mlZqAANwj8nzeZl5pemyMvNS4M3A1YE7zyDOdp3XTon3Rsb3nr7LZDrn/dR5za73fF5EXA14MfD3wC80l0KSJE2XPT/66FLmPTPzrAM8fmx3jMm0ob/LeJrRlwLfkZlb/fRQK8ScWJIk7W0Jc2KpR+bEkiRpb+bEK+nYojtwQLeZPL+3Uf4+xiNmbw28ruc4zTqZuRURHwS+HLgF8O7JqNwbA5/NzI812mDSxm6/MIlzu0nsYlGmi4i3N4rOOnCwwyq+0NEqq3YC2V4fMSzaqu4Q16WPe9Ur2itjNupVdbou20yWu+sOvHN7jcJ597Ew7/b6PoiuzPqqLEliMZNlm6eu/S8OY9XuK1rDLFd9PXYUEacxnnHhmxlfwHr47gtsOjLMifepzokDBtNjxsZGFbT3smyUtV4HyqHoRbpc7pNXot68D6az+HlFsQzlZl7Wm996WaZfnAyKpGCjsU4G5cnTfG0sUV80e6Mi8z1VpHTHG+e8bj2SOfF+VTlxJAxOHc08oouy/1XhKlzHWPUPR1J5DaH5d5Q5K69zVFbt5/g6tFUbwHDm5PnTjfLt168zgzgHrdOprxFxT+BHgCdk5rsadSVJUkPQ/9+3Fn0eP/nlzv8D7gP8FvADDl440syJJUlSaR1zYmkXc2JJklQyJ15dqzaAYS/b281hN8cucbq2/fn3R8R1gBcAfw388gHjXDlo5u2nvT4ZcXu7w8SWJElz91zGgxc+AXwE+Okpv7w5PzPPn3O/tJzMibeDmhNLkiQdVebE20HNiSVJWjsRcRfgJxnf5uoM4P3A84HnZGYxX/3hYkXETYDvBm4LfDXjmaICuFVmvv8Qi3QlqzaAYXs06pmN8mvvel+fcQ5aZ6/3Txt5+wzg+sDXH3TjkiRJE7O4H9niZ1m7+eT5+sBPF+87f/Zd0RIwJ5YkSbX1zImlncyJJUlSbU1z4oj4ZuD3gePAucAlwP2AZwJnAw+eYaw7AD/LeE18kHH+cp3OC9OwancNec/kedr9wABuNXlu3bPsMHGadSLiGOM/LGwBHwDIzMsY/0LymhHxRfts43bA1YALIyK3H8AbJuXfOXnt71sLJkmS1k9mnpOZscfjyYvup+bGnNicWJIk6agzJzYnliTpyImIawPPA4bAOZn5fZn5o4xnRPgr4EER8ZAZxnobcFfgOpl5S+Adh1+qq1q1GRi2E7R7RcRg572fI+JajEeCfA54ywzivB74TuDewO/uindX4OrAGzPzxK46D53UecGuOt+44z3b/h/jD363L2I8bfRFjH9Z+aFi2SRJ0hKMhJVmyJzYnFiSpL2ZE2u9mRObE0uStLf1y4kfBNwAeHFmfj5XyMzjEfGTwOuAHwJeNotYmfkvwL/0sSCVlZqBITMvAs4DbgY8clfxU4BrMF7JlwFExGZEnBURtzxMnIlXML7v9EMi4g7bL0bEGYynygD4jV2xnjt5fmJEXHdHne12T7AjYc3Mp2bmI3Y/gF+avOUtk9eeepWVI0mSPi+y34e0TMyJzYklSdoPc2KtM3Nic2JJkvZjDXPie0yeXzul7I3A5cBdIuL0Ocfq1arNwADww8AFwLMj4p7Au4E7AXdnPM3WE3e898aT8n9mnIR2jUNmfiYivp9xgnp+RLyM8X1A7g/cZvL6ubvqXBARzwAeB7wzIl4BnAZ8G3A94Ecy8+KuK2KZRFVYfaEbZTFqR4xRs6jeeRRlXWNW9Tq31yqb83KX9bIoLOt1ba9bvd7bWqKYld4Pop370bHinJOAZVlfs7AkCRWjjaJwoziCLEn/pSVlTnxYAbHR2EENin1Tqw5AtOvloBg73mqv2kUWbdX12mWVst4c2+vaj+qg2LWP9YlCx5g9i47JwGAGSUTVl6q9WfSl3Vb7BGme/TiMjerE8YjaWJKk8lS2P5vjRdmJRve7nm5Ja8acuAeDrUW0qiNvFvly69i4JLm5NGtZnLPM83SmPMceFB0prsUsYe57VkS8fVpBZt5+xm3fZvJ8ldtkZeZWRHwQ+HLgFoxzmnnF6tVKzcAAnx8VewfghYwTyccDtwSeDXxtZn5yVnEy85XA3RiPOvlW4EeAU4wTz4dkXvUrlJmPB74H+DjwA8DDgH8C7peZv7qvhZYkSQeTPT+kJWNOLEmS9mROrDVnTixJkva0fjnxmZPnTzfKt1+/zpxj9WoVZ2AgMz8MPHwf77uYYnzdfuPsqvNmxvcZO0idFwEvOkidXfXPx3GCkiRJ2sGcWJIkSUedObEkSVqACw8z00JEXAzc9ABVficzv2u/4SfPfQy36DPWgazkAAZJkqTKiszyLEmSJM2MObEkSZKOuiXNiS8Cjh/g/R/d8e/tWRHOnPZG4Nq73lfpM1avHMAgSZLWyyym81rORFeSJEmazpxYkiRJR92S5sSZec9DVH8P41tf3Rp4+86CiDgG3BzYAj4w51i9Gsy7QUmSJEmSJEmSJEmSdCCvnzzfe0rZXYGrAxdk5ok5x+qVAxgkSdLaiez3IUmSJK0ac2JJkiQddWuYE78C+ATwkIi4w/aLEXEG8LOT//7GzgoRcWZEnBURX3TYWPPiLSS0f9UXsyirvtAx6q8OAEVZVa9sb9gxZtd+NvrSPV574cqYHT/TWWwnnep1bavSsV71Gcyknx3aqsx7fVVmkiBUn08HS5LEjM2xL1kMiYxBtMvm+R2QpN2isX/a2Dh4HYCNYmdYFGUjZG4UbRVFWex363rtsrJeUVbV61RW9aMIV7fVrpmzOBh17Eu16UWHfnaps5fBET14z2K5B+XJ2mrbqE5gOxosyb0NTmV72U4V5x3Hi+6fbOycs9yZSNL+RMJga9G9kBanPJeRVszSbM5dry10/bvTEZOZn4mI72c8+OD8iHgZcAlwf+A2k9fP3VXtgcALgBcB33PIWETEC3f896zJ8y9GxKWTf/9mZv7lIRbTAQySJGkNmdRKkiTpqDMnliRJ0lG3hjlxZr4yIu4GPBH4VuAM4P3A44BnZ+7/V5sdY333lNe+Zce/zwccwCBJknQla5iYSpIkSQdiTixJkqSjbk1z4sx8M3Cffb73hcAL+4g1ef//3969h8tSVnce/63qvc8BjaASHI1GUCJgxsxF0CTgBWEkakBkxNF54gxqTGLi3TiZRLygE6O5eMMkGo0KxgvGG2RUjBE8aiRRg4PXgIIco4A3QLkezt5da/7o2rLPPv2u7n67qrur+vt5nnr6nF693nrr7e6q1XXeU9X4BT+iC3kAAAAAAAAAAAAAAADMBFdgAAAAnbOkt+AGAAAAfoKaGAAAAMuOmriduAIDAAAAAAAAAAAAAACYO67AAAAAusVV/73NmKkLAACANqEmBgAAwLKjJm4tJjBgT26ZeUGszFhflBPEbNaxfv1tpsbSyvQg172uUbHokju56wsv4xPmJYKNrCvIi2Tmxf2cvNGF6n+uBtrM+Qy1Rfh9zODBdZvK1QaOH7mfPQXva6bMrQOwwEwm6/USweBb3wt2hlFeEeT1hudFpbknuj4yL+pjA3lxmxl5Tawrkrm+RTlwZG92UMgVXH9zIr26C7Ip9DLeuyL8cb6cohHZHdSga8Hw7woK7VsTO/xR7ww1MYCxuKuIdlAp0Q6hDaVCEzu03O2uuy+L0o+OC38fAUsgOk8c/jaf8b/NUBO3F7eQAAAAAAAAAAAAAAAAc8cVGAAAQPe04X98AAAAAE2iJgYAAMCyoyZuJa7AAAAAAAAAAAAAAAAA5o4rMAAAgM7h9twAAABYdtTEAAAAWHbUxO3EFRgAAAAAAAAAAAAAAMDccQUGAADQPcysBQAAwLKjJgYAAMCyoyZuJSYwYHyZX/Lo8ixWTvb8yPYy1iVJ1s/My4310x3NGRPl9iN6T7PHOQhmtpmVl72u4L1pYLxC2d+5jMTM705um7mytk2qvy8zLnpmfZkrt0RgJRVYMN7AmFHoAt1jJvV6w2Op5yWpSF/EzqNYL70PdRse82LyHElSEPLoGnzRbj7Ii9rMXV/qWJQ8Ro1oLzsWCdsMasooFjUZthkkJgQfr0YUQf+L4EAb5mW02cttj+uOLp3UaYK14DfJWvAx2eXpY8tasLPc5cNP3fmonRc1MYBxuFSsz7sTWHgtOR00S05tiGWR+P6XwY4hKHvzZfw70EacmriduIUEAAAAAAAAAAAAAACYO67AAAAAuoeZsAAAAFh21MQAAABYdtTErcQVGAAAAAAAAAAAAAAAwNxxBQYAANA53IoQAAAAy46aGAAAAMuOmridmMAAAAC6h8IUAAAAy46aGAAAAMuOmriVuIUEAAAAAAAAAAAAAACYO67AgFqEl2BxC2ITPj8iZmUDsX5um+mO5rTZyLYFfcwe59z3Llzf5P3MvixQ2Me89zR3hl+0vlDO9yrsR16ecvsfCPsSfU5m2Y9cM/6ceJHeN5erw+c3lsG0x2hXn22KzzKXBgMwkknqDd+xWZHe4XkiR5LUS+8Mo/1uMhbtd2cdi/bzUbmfmZfckTeyrtxYUBvmtlmzooEDYtRmE+trg170AylQZOb1lJcXt1nve1d3e1Izn69+0GTqJ95a8CXe5b1kbC3Yya4Febs1PFaOsTNZ0q8kgAmYS8U6OwuMMMP6ddZyz2cVLfnaNHK+Dt0T/IAt02Vq/d0IznP7FDsiauJ24goMAAAAAAAAAAAAAABg7rgCAwAA6Bb3+q8A0sAVRQAAAIDGUBMDAABg2VETtxYTGAAAQKeY6r80GFfcAwAAQJtQEwMAAGDZURO3F7eQAAAAAAAAAAAAAAAAc8cEBgAA0D1e8wIAAAC0TUdrYhs41cx2mNm1ZnaLmV1hZn9rZofOu38AAABYIB2tibuOW0gAAAAAAAAAWHhmto+k90o6QdKlkt4l6QZJPyPpwZIOlfT1uXUQAAAAwNSYwICxNXFfl9S9Z6wMcoKYorx+ZixsMz3dqgjaDPuZiEXtWRlM+wpCueMcrS+8n1BuX3zy7Qs/J1E/MtY1us0oL3MsI4n3J7u9zLxwLBdpfdFnJUduPwK5750X6T23rwaxVKhFN/gK9wEAIEkyqdcbHko9L0lF+iJ2vhLEon1yIi0nZy6xzONDzvrCdeUeMHOPbw30xYI8C9YX5eXkFJn9L4JCLrdNTKbX8iKo18B/aeoHX9boZ/taYkeUel6SdgcXOl3z9LFlzdOn53Yn8nyMnW/LPw4pr9Jg8sIrJL3Q3ffYSjNbnUuvgLZyqVjnGA3l18TRx6dF55EwHo9+lCyQ3PPEbdm+LMGmlb3oHzcSiTMequS/JY6T282auPOYwAAAAAAAAABgoZnZIZKeJunzkk5z3/tfJ9x9beYdAwAAAFArJjAAAIBuaeJ+ZAv4H1LM7C2SnlL99T7uftk8+wMAAIAF0lxNfLiZXTQ07H5EzWvc6r9LKiSdJWk/MztR0s9KukbSBdTDAAAA2MOSnCfuIiYwAACAzun6Vaqrk7VPkXSjpJ+ac3cAAACwgDpYEz+getxf0uWSDtgUczN7g6RnuXt0dxAAAAAskQ7WxEuBCQwAAAAtYmYHSnqzpPdIuqukh863RwAAAFgil8zgSgspd6keXybp45KeL2mnpAdK+itJvyPpB5JOn0PfAAAAANSkmHcHAAAAaude77JY3lQ9Pn2uvQAAAMBiW8Ca2Mx2mplPsLxjU3qverxa0snu/hV3v9HdL5B0iqRS0vPMbFstnQUAAED7LWBNjNG4AgMAAEBLmNmTJD1GgxO215jZfDsEAAAATOZySbsmeP1Vm/58XfX4UXe/ZfOL3P2LZnaFpEMk3VfSF6fqJQAAAIC5YQID6hFMOgrvL5MxWcnKGcf66U4WwV0VLTeW6IuV6X7kb3cDbQYz0KLtDj9DQT9TefHnLuhjlBeNV82f80Gbk2+3FH9m0+3VP3Mw9z0INTGWOaLPZNiPershSd5L/wO2W3ChpejfvRMxj/6xPIj5HP6NvaF7mx1uZhcNC8ziMrpmdpCk10l6h7uf0/T6gM4zyYrEfrIX7D+jWKo9SYr21yvD87w39OlBrAjaC2LR/j/cz0fX7gtiHuVlHIuyciR5kT4weHTQCGNBXwLh3LNgfZYRi3IiYRcbOMgWwQ+MIlhfTl4RFJQ9BT90MkXri/SCvGhM4jbr3b6igfHKVQaf2jIoRteCnVQ/0eZasHPerXQsyusH/VhLtDnOp2AR7/fr7sdNkX6ppOMl/SgR35jgsO8U6wCWirlUrC3gzgLLLSpGcz6u/N+PGnV9f7EY2xf+No8EaeVK3nndLljEmhijcQsJAADQPV7zMmdmVkg6S9KNkp415+4AAACgDTpWE0s6v3q839aAmW2XdJ/qrztn1SEAAAAsuO7VxEuBKzAAAACM55JprrRgZjslHTRByjvd/YnVn58r6aGSftXdrwtyAAAAgK46T9I3Jf2KmT3c3f9hU+xFkvaX9El3/+5cegcAAACgFkxgAAAA3eINXBqsnvay7vdrZveR9HJJb3P3j9TSEwAAAHTb4tbE+at3321mp0r6mKTzzOyDkr4l6QGSHiLpB5J+c45dBAAAwCLpYE28LJjAAAAAMANT3O/330vaLunJZvbkxGu+YYP71Z3s7udkrgcAAABYaO7+j2Z2pKSXSHqYpDtK+p6kN0n6P+7+nTl2DwAAAEANmMAAAAC6xzs1FXanpLckYr8q6a6S3ivpenG/XwAAAGzoVk38E+7+NUmPn3c/AAAA0AIdrYm7jgkM2EN4KZUgZmWQF8RSeVF7Yayfm5feuGI9b31F2Jf0+lJtxmMStBfkFcF2R9sWfxaCYGZe+LlM5IXjFR2woj5GedF3IBK0mTuWyfbC/ucdxLMvvxS+B5mN5r4HCeF4RRooiHylCGLpQ3mY17N0rEjE0inyIBbKzRvRZN2XBmugm2Nz94slPXVYzMx2aDCB4QXuftkMuwV0gEm93vBQ6nk1sG+V5Ikmc3JGxtKbFseiY0CwvvDYUaR31sk2G+hHGIvajITrC+q/IM8yDm5RTlH7dTTz1xfGgsK318A2JNcVFJtRH+M2OZG2VT/48vSCHdFa8GWN2iyDHcduDd8phjnBjrQM+piT5yMq1K7VxACaU6xn7CwyzyPFHVmQvUwT25ZrUcak5bLPWQFzEv0ujH/vZ55DyDjnm5MzD9TE7ZV7OgYAAAAAAAAAAAAAAKA2XIEBAAB0zwL9hwkAAABgLqiJAQAAsOyoiVuJCQwAAAAt5e7HzLsPAAAAAAAAAADUhQkMAACgc2Z4S2wAAABgIVETAwAAYNlRE7dTMe8OAAAAAAAAAAAAAAAAcAUGAADQLS6prHlqLTN1AQAA0CbUxAAAAFh21MStxQQG7Cn64oUxS4bCy7MkYlamU7Jj/XRHin6Ul47FeZnrS2xD1F48JkE/1oM3J2ozSIvWF21D9PkK2/RELOi/Ujka9XmN3oNoLOtfXxiLtj3Zj8x1RXLzws/ejPtSd3uW3lf6SnBRpCBPRdBmECt7QV4v8XzQDeXGIqm8cdqjkAQwiklaGb7D816wTy7SsSgv3O8m9tdlYn88WFcQC7rfSCzYL+fmpfb1XkRF4+TtjY5F6wtqvCgWrS7z2pY5h9poXUVmbJEU0Y+kGerNuB9Fzo+BwKz7XwY7jV3BRUT7wbegH+RF69ud2NGWmf1Y8/QpuH7Qj1SbPs43vx1fVwDzVLqK3YtxzMzaaeWeb2jN/rHmjuaOV0t44vxZFzY7+5xohtQ4ombR7+jw9/7k53RHrS8r1qaPSWv2+diMW0gAAAAAAAAAAAAAAIC54woMAACgc1ryn0MBAACAxlATAwAAYNlRE7cTV2AAAAAAAAAAAAAAAABzxxUYAABA98zw3oAAAADAQqImBgAAwLKjJm4lJjAAAIBu8QYuDUadCwAAgDahJgYAAMCyoyZuLW4hAQAAAAAAAAAAAAAA5o4rMGBs0SylcAZTGeQlYqnnJcn6s40VYV56w+vOszKdY+vBuqK8aJzX08EwL1pfdKmeYEyiNlOz3cJ1hX1Mp6kMNjwak6gvubFgfbPtR+Z0w9zLNs0wL/rceWHpxCKYG7jSS7fZS8fK1SBvJd2XKBZOYUykeZDjwarcgj4GeVNhJiyAUczkqf1ytL9eSe8M431ylJd4PjjehLF090ccw4K8sM10LDze5BxXwuNNsK4wFv3QCUJFZl6wvuCQGcaKRJvR2x1JtTdVLDg4N9Fmur2MQnoO2tLPHGupnZ6ktSCvH3yx+uGOKK0MdkSp9UX9j/oR9b8M84bHxvr0UxMDGMFcKnanTkY29YMdTWrsPEsLLPGm12rm45i7r4nO9y7I/st70e/2zN/7TcQyz+sm5f42b0pHa2IzO0rSCyX9kqR9JF0m6a2SXu/uwb9QTteWmR0t6SRJD5N0sKT9JF0l6XxJr3T3y/K36jZcgQEAAAAAAAAAAAAAgAVnZidJ+pSkh0j6oKS/kLRN0msknd1wW++X9LuSdkl6p6TXazCB4dclXWxmvzz5Fu2NKzAAAICO8fiKI5ltAgAAAO1BTQwAAIBl172a2Mz2k/RmSX1Jx7j7v1TPv0jSBZJOMbMnuPvIiQyZbb1G0t+4+1Vb2nqBpJdLepOkX5hyM7kCAwAA6KCy5gUAAABoG2piAAAALLvu1cSnSDpQ0tkbEw4kyd13aXAbCEn67abacvc/3jp5ofLHkm6RdD8zO2DM9ScxgQEAAAAAAAAAAAAAgMV2bPX40SGxT0m6WdJRZrZ9xm25pPXqz/0xXh9q5QQGM7uHmb3VzK4ys1vNbKeZvdbM7tR0O2Z2lJl9xMyuNbObzexLZvYcM+sFOaea2efM7EYz+7GZ7TCzE4a8btXMTjazt5jZV8zs+modXzazl5nZHSbZPgAAlpG5ZO41L/PeKmBv1MQAACCFmhjLgpoYAACkNFgTH25mFw1bZrBZh1WPX98acPd1SVdIWpF07xm39ThJd5D0z+7+ozFeH2rdBAYzO0TSRZKeLOlzGtxr45uSni3pn8a9LEVOO2Z2kgYzTh4i6YOS/kLStip36L1EzOzPJJ0p6W4a3EfkHRrc++P/mtkztrz8EEkfkPR4DT4Ub5D0Nkn7SnqRpH8xs58eZ/sAAADQXdTE1MQAAADLjpqYmhgAgCW0f/X440R84/k7zqotM7uXpNdrcAWG3x1jvSOt1NHIjP2lpLtIepa7v37jSTN7taTnSnq5pKfV3Y6Z7adBYdmXdMzGvUDM7EWSLpB0ipk9wd3P3pRzlAZv1OWSHuDu11XP/6kGRfGfmdmH3H1nlXKDpKdLOsvdb9rUzjYNCtZflfQSSc8cY/vqF820D+77YhkxCy4uErVX9NOdDNsMY+k2i/VkKL8v5fC8Yr3e9iTJojajvGjbgjyFbabf2LBNT8TCz10QTLU3qs0oLzcWbXck1WZmP7LGf1QsVxPjlVJYMmRK/mcKeS+d56tB3mp6TmHUZtkL8oJtyIpZOkdBKIw1hf8dhu6jJq6jJu4N3y9H++syioX75HQ3ysR+3tOrUhnEonU10WY0Ld6DY0AUSx074n6kd/4exLKPYdFhMVxfUHdlxnJyigX6r9RN9KWX0WbUjyjWi36khuvLy+s1cOPVnG0ogy//rvDLmtbPLBz7meuLtiHVZtTHMuhHP1xX0GYiz8cZq8X5mgNNoSaetiZ2V7G2GDf0zhHWk10WnrPqgNxzfMG4dJlH5+syhOe5Zyx/22rehuh3bfS5C/ofnkPO/E1f9+/vKNbE/rfuz/JtDTfS6iXufkRuspntlHTQBCnvdPcnjtt89VjHlo9sy8zuIuk8SQdKerq7X1jDett1BQYzu7ek4yXt1GBW62YvkXSTpP9hZrdvoJ1TNBj8szeKUkly912SXlj99be3tLVR2L58oyitcjbWu12Dmb0bz1/p7n+5uSitnt8t6Y+qvx4TbRsAAAC6jZpYEjUxAADAUqMmlkRNDABAW10u6dIJlqs25W5cFWF/DbffltdFpmqrmrxwgQa3oni2u//lGOscS6smMEg6tnr8mLvvMTXU3W+Q9BlJt5P0Sw20s5Hz0SHtfUrSzZKOMrPtY+act+U1o6xVj8H/+QcAAJIGV+uocwEWCzUxNTEAAKNRE6PbqImpiQEAGG0Ba2J3P87dD59g+b1N6ZdWj4dubdfMViTdS4Ma4ZtjdCW7LTO7m6Qdkn5egysvnDHG+sbWtgkMh1WPX0/Ev1E97jXQNbSTzHH3dQ3uRbYi6d6SVM3KvbukG9396in6uuEp1eOwIncvZnbRsEXS4WOuDwCA1jKvdwEWDDUxNTEAACNRE6PjqImpiQEAGKmDNfEF1eMjhsQeosHEywvd/dam2jKze0j6pAa1xNPqvPLChrZNYNi4hEXqshcbz9+xgXYmzamrrzKzR0v6LUnfkfQno14PAACATqMmpiYGAABYdtTE1MQAACyj90n6oaQnmNmRG0+a2T6S/rD66xs2J5jZ/mZ2eHXVhGnbuqcGkxcOkfTr7v6m6TdpbytNNDpHVj1OOwcmp53cdYevN7OjJL1Lg/utPXbzPdLCRt2PSLR3kaT7T9hHAADahUvcYrlRE280Sk0MAFhm1MRYbtTEG41SEwMAllnHamJ3v97MfkODyQc7zOxsSddKerQGV4l6n6T3bEk7WdLbJJ0l6UlTtvVJSQdLukjSQWZ2+pBununuO7M3Uu2bwLAxG3X/RHy/La+rs51Jc0a9ftTMW5nZL2twD7RS0iPd/XOp1wIAAGBpUBMDAABg2VETAwCApeTu55jZQyWdJumxkvaRdJmk50k6w338WRsZbR1cPR5RLcPskLRz3D4M07YJDJdWj6n7gd2nekzds2yadi6VdGSVc9HmF5vZiqR7SVqX9E1JcvebzOxKSXc3s7sNub9Z2Fcze7CkD2tQlP6Ku//ziG2qR/SRDmLRfV/CWDnZ85Jk/XSD1k/nFVFsPd1mmBf0JWoz6mdq+6LtjteVGSuDNy6IWT/95oVthn0JPhCp8Yr2z1F7UR9zZ+pFeUEsHK+cNsMxqXldUjzOizTrcSVxKLT0XZZ8pZeObU8fWn01yFuJ1hfFLB0LbhSVEwtz0t0IY8qNRTw+juS2CSwQauIauJl8dfg+23vB/roX7HeDfXK5GuQl2iyjdQX75Ny88AaD0X4+PKYEO9CcvCaOKWEsqNWiWNRkEAzbzIgV2X0MfnsEB8VofUXmwTk3L91eXv/z11d3UdKMfvKLnK5t12bajxF5mYVjGayvn3HX1X5Q+JZBe9F2p/pRhkW2qImxDKiJ6+CSrQUnKhdc7mmDiEfFGvY265uUR8e2tt0wvSZW92d2gc7bZm9Z/KMrGUr9Nvci+HAFv7+j3+bx7/bcWDKU/5s+ldfEOd0mdLgmdvfPSHrUmK89U9KZNbU1k3e4bbv0T1SPx5vt+S9LZnYHSUdLukXSqCIup50LqsdHDGnvIZJuJ+lCd791zJxHbnnN5j4cq8GM2nVJD5/Z5AUAALrCvd4FWCzUxAAAYDRqYnQbNTEAABiNmriVWjWBwd0vl/QxDS5P8fQt4ZdKur2kt7v7TZJkZqtmdriZHTJNO5X3SfqhpCeY2ZEbT5rZPpL+sPrrG7a09cbq8TQzu9OmnI313qrBPUe0KXa8pA9J2iXpOHf//NZxAAAAwPKiJgYAAMCyoyYGAADorrbdQkKSfkfShZLOMLPjJP2rpF+U9DANLrN12qbX3r2Kf0u33ZMjpx25+/Vm9hsaFKg7zOxsSddKerSkw6rn37Ml50Ize7UG9wn5kpm9T9I2SY+XdGdJz3T3nRuvN7PDJJ2rwf1FPiLpJDM7aesAuPvpI8YIAIDlxmRYdB81MTUxAAAxamJ0HzUxNTEAADFq4lZq3QQGd7+8mtn6Mg0uufUoSVdLOkPSS9392qbacfdzzOyhGhStj9WggLxMg8LzDPe9rx3i7r9rZl+S9AxJv6nBXZq+IOlP3f1DW15+t6pNVe0/NtH908fZRgAAAHQTNbEkamIAAIClRk0siZoYAAB0UOsmMEiSu39b0pPHeN1OSTZtO1tyPqNBETtJzlmSzhrjdTsU9BcAAIzDZbXfj4ypulg81MQAACCNmhjLgZoYAACkURO3VSsnMAAAACS5pLoLU+pSAAAAtAk1MQAAAJYdNXFrMYEB9Yi+sEHM+pM9L0nFem4s3ZEiXF+QF8Qssy+2Xg7P6Qc5ZdReEOsPX9cgFrxx5eLkKbXtUU5wwIrGJDzQRbHg/ck+ePaDD22izSFXL7xN1MeIZ45XJOpLEfzng6KXDNlKOqZEzLetJlPC2Gp6XWUQ814RxNLb7cGYZMcSodTzkuL/FxLEojbD9QHAtMyS+2xfDfbJQaxcCfatwb68TBwePDh8NRJLb1p2TFFedAxI5HmRrhOimCyqL4LaMGwzCAXrK6L1RW2mQ8n1hf3IjOUK1xf8aOzlbkOizZ6C+jXQs7y8RdIPvpD9xJeuF9X7Mxb1P8zLLCrLxPpSYzWyH0H/y6CPqTzOmwKog7nL1oJzTEso91SER4Uc9hYdThel/Mg75GNWgu+cF8GbF/1uT5wvjc6jlpnndMPfypm/2+MxCdrM/SGagfO9GBcTGAAAQPcsyo9dAAAAYF6oiQEAALDsqIlbiTlkAAAAAAAAAAAAAABg7rgCAwAA6Byr+95mAAAAQMtQEwMAAGDZURO3E1dgAAAAAAAAAAAAAAAAc8cVGAAAQPcwsxYAAADLjpoYAAAAy46auJWYwAAAALrFVX9hSp0LAACANqEmBgAAwLKjJm4tJjBgDxbFynTUyihv8pj103sA6wftBbFiPYql1xfG1oJ+5ra5nhiUcEwy2pOkMh2L2lTQpgVtqp/Xl+gAY6k2o/bKYNuig1k/+IAFeR61GfYlb0ySbUbtRf0IhNsWMAv2NkUQs/Rhy1Z66bzt25Ih37Y60fOS5KvpdYWxXnrbfCUdK4OYB5sdxoKbSHnqPQjeGg/eU48OLgAwLyb56vCdYbQvLxM5g1jevjwVK4P9ePaxIdz/B7GwzaAOylxf8pgT5eS0N0UsKmdkQf2aGSvCWNCXmuX2sQlF9GMzQ0957RUzPoO1Fnwh+8EXoRf9Hkjl1DzGTemHO5TMNhNjWWYWt9F7U2b1nyIbQA3cpbXgpOkiyP2Hp7BYq99M1zbjbVtasyyyuy76zIbnFIO84DexgnOw5Uq67vJe4hxB9Ps7/G0exILPVxxLhuJY5u/eVF7UXhPngpP9qH9VWBD1/8IDAACYt7LmZUHYwKlmtsPMrjWzW8zsCjP7WzM7dN79AwAAwALpaE0MAAAAjI2auJW4AgMAAEALmNk+kt4r6QRJl0p6l6QbJP2MpAdLOlTS1+fWQQAAAAAAAAAApsQEBgAA0Ckml9V8bzNbjAuSvUqDyQuvkPRC9z2vA21m6fueAAAAYKl0uCYGAAAAxkJN3F5MYAAAAN1Tc2E6b2Z2iKSnSfq8pNPc995Ad1+beccAAACwuDpWEwMAAAAToyZuJSYwAAAALL7/LqmQdJak/czsREk/K+kaSRe4+2Xz7BwAAAAAAAAAAHVgAgMAAOgWV/0zawfNHW5mFw0Nux9R7wr38oDqcX9Jl0s6YPPqzewNkp7l7v2G+wEAAIA2aK4mBgAAANqBmri1mMCAPQVfPIu+lFFe8E8pVg5/vohygljRT3fEglixHsTWgjYz84p+YsMl2drwmK0HOVF7wXYrarNMx7QevAlBXtTPKE9lsA2pvH66j0OuvD7muqLtDvI8vW2eOyaR1PYF7YVjEjCzdLDXS8dWg8PP6rb0+ratpvOCmAfr80Ser6b776tFOtYLYivpWNlLj6UXmbGwzWRISqRFOTntTRVbPnepHl8m6eOSni9pp6QHSvorSb8j6QeSTp9D34B2Mkvu68tgP1+upHdOcSzdlVTMgxwPDrPZsdz9fHZeuv5I5uUeG4J1WRQLfgTFsXRX8tucPFYEOY3Egh+GTbQZKRI/NqN1NaEMvgRlsG3RfaHK4EtXKF3zrym9A+gl8tainUagiXEuvf7isB/twJL9mDxnsK68/qfWx3lTALVwl+1ekLsRpgqo3H94igqytuvyti2Q6JybReeCZyzqZ+3iHzrpWHC+NMwLzqWG51mj87rR+dLEb/pmztsmQyPOswZtZp5nzSqzcz92nAvGmJjAAAAAuqeZe5tdMs2VFsxsp6SDJkh5p7s/sfrzxs+aqyWd7O63VH+/wMxOkfQFSc8zsz9y9925fQQAAECHcL9fAAAALDtq4lZiAgMAAOiezAuYNOxySbsmeP1Vm/58XfX40U2TFyRJ7v5FM7tC0iGS7ivpi1P1EgAAAN2wmDXxVMxsu6SnSjpV0r0l7SPp25L+QdKr3P1bc+weAAAAFk0Ha+JlwAQGAACAGXD346ZIv1TS8ZJ+lIhvTHDYd4p1AAAAAAvLzFYknS/paEmXSHq3pFslPUDSMyX9TzM7yt2/Nr9eAgAAAJgWExgAAEDnWPcuDXa+Bidl77c1UP0vtPtUf905wz4BAABggXWwJj5Zg8kL50s63t1/8v/pzOylkl4s6fmSnjKf7gEAAGDRdLAmXgrFvDsAAACAkc6T9E1Jv2JmD98Se5Gk/SV90t2/O/OeAQAAALNx7+rxw5snL1TOrR4PnGF/AAAAADSAKzAAAIBucR8sdbc5R+6+28xOlfQxSeeZ2QclfUuDy+U+RNIPJP3mHLsIAACARdLBmljSV6vHR5rZ67ZMYjihevz4jPsEAACARdXNmngpMIEBe4q+d1vntm9iubH+8BVaP51TJHIkqVgP8qLYWrpNWw/WF+QVa+kNt/V0rEjFghzrpwcsWpfWg4Euo/XV32YU8ygvte3RQSQYL5XpPI/ygvWFecH6tNd/KNkcmvwgaYVFwXSoF1ysZ3U1nbctiAV5UZtaTR+2PDvWSzyf3u5UjiSVUV4v/R74SmZeuivy4K3z4POQynOLPkPBuoJYdt4Scvd/NLMjJb1E0sMk3VHS9yS9SdL/cffvzLF7QOt4IZXbhu/won15uS29cypX8mKeOEyFOdH+P/fYEOYFtU72sSgdU2J9UT9SOZLC440s+C0Q9NGCvCLoS+bhNF5fIpbdXvDDMLWuQSz4nZOZF+kFbc7SWvAlKIN3oR98CXrhWKZjveB3SZS3puHb0AtPEgQW460ZqR9+SyZXhju2uvsxt2L5cDO7aFjA3Y9oeN0flvQBSf9V0pfN7OOSdks6QtKDJL1e0p833AegW9ylteCkaVdFBVnbdXnbZqwtIxn2M3X+L/qcFHnnKKM2vRf8aIzOiQaxMjg/m30ONjFe8XnbZGjEb+XJz81OFcv+IVpjDjABJjAAAIDuyZjk0wbu/jVJj593PwAAANACHauJ3d3N7BRJL9bgNmo/vyl8vqR3uXvwPwgAAACwdDpWEy8LJjAAAIDu4VJeAAAAWHbN1MSXTHOlBTPbKemgCVLe6e5PrHL3kfR2SY+U9HRJ50q6WdLRks6Q9Ckze5y7n5vbPwAAAHQM54lbiQkMAAAAAAAAAGbhckm7Jnj9VZv+/PuSHifp2e7+V5ueP6+6MsPFkl6nwcQGAAAAAC3FBAYAANA9zKwFAADAslvAmtjdj5si/YTq8RND2v2imV0r6SAzO8Ddr5liPQAAAOiKBayJMVox7w4AAAAAAAAAwAjbq8cDtwbMbLuk/aq/7p5ZjwAAAADUjiswAACAbnHVP7OWiboAAABok27WxJ+WdD9JLzCzz7j7rZtip2twnvPz7n7DPDoHAACABdPNmngpMIEBY7MyM9ZPx4r1yZ4fHUvvOYq1dMwy84rd6Y0r1tODYlFsbXibUY7Wg0Hup2MW5gXrK4NYsD4P28zbhmSbTfTR0zEvg6NWkJd98DRLh3q94YHU85JsJX04sG3b0v0I81bTeavpPF9J9zPMW03nebDtvjr8YkRheyvp8fdeOlaGeclQHCuCNtMheXANpmRe1F4Qy87L5lL0ncxtE0C3mKm/ffgONtpf91eD/Xxw6OsHsTJxeIv2/6kcSSpzjym99L4uzIv25UXQZnQ9wFQsc11RzKI8y8uzKC+IFWEsGUq2GbdXfx/bYC36MEeCkj4akzL40BZBfRHmBV+eMvpxHmx7kchbS7emXsfro364w5lcGe70gn4k8kb/lOxkTfxySSdKOk7SJWb2UUm3SDpa0gOrPz97ft0DWshdfuuto19XF2vBBaGjomtJWXAeEjWKxrkIvjvh+5OIBTneC9YVnLeNz78GNfhKUNsGsegcrGfmpc4FhOdRo3OzYSzdZvj+ZJ6DzT0/m3PuNm4v+mE7+bpG62RNvBRaUDEAAAAAAAAAWGbufqWk+0t6laRdkp4s6RmS7irpTEn3d/d/mlsHAQAAANSCKzAAAIDuia58AgAAACyDDtbE7v4DSc+vFgAAACDWwZp4GXAFBgAAAAAAAAAAAAAAMHdcgQEAAHTP6JsCAwAAAN1GTQwAAIBlR03cSkxgAAAA3eKSypoLU+pcAAAAtAk1MQAAAJYdNXFrMYEBe7Dgi2fBbWKsn44V6+lGbX3ynGItiO2O8tIb0NudjlmQV+xOb3iUZ/0oLxFbD3KCWJSn9cQbIMnL4A0P+q9+Xp6HbUZ5ifUF9zUK1zXr2XhFLxmyXhQL7gC0ujo8ZyXY5QcxW0n3I8rTajrmYZvpmK8GsZX0mHgwXqk2fcWSOWWwrjLI814QK3JjyVCYpyCUyovWFbVXeyzKAYAxuUn97cN3KNG+vFxNx/pBzINDZmp95fBD+sj2wmNDcAiOjylRm+n6KTx2FFFeIhbkRMcHy81Lh2TBj6dZx4pELPX8NLFIbl4ZfFDKoM21MvhAJ5pcUfq3wJqC9gJFcAar9PSnKBqvMvj0hevLLJSK8MuaWFd0kqDD+hljNUrO++YUxQDqULq0e23evRiIzmEsClvOO3KHFV4b3rdclrltweckPKcbKYK86Lxn6jxrcN45PDcbndsM24zOpUbndKPf2Hl5Oeduw3Ozub+xw3OzuW0G/az5/GzYXhM4T7x0mMAAAAA6xhuYjMTUWgAAALQJNTEAAACWHTVxWy3nlEEAAAAAAAAAAAAAALBQuAIDAADonlnfDgYAAABYNNTEAAAAWHbUxK3EFRgAAAAAAAAAAAAAAMDccQUGAADQPcysBQAAwLKjJgYAAMCyoyZuJSYwAACAbnFJZVl/mwAAAEBbUBMDAABg2VETtxYTGLCn4HtsQaxYrzdWrKX3AMV6EFtLd7K3Ox0rgpit9YNY1Gaw4etRm4m8fjonas/Xo34EsWB9nurjqLx+8CHydMzL4IgQ5GUxC2Lpu+5YrxfEgrv1hHnpmFaD3XcxPM9WgvZWgvaCPA/bDPKibVtJj5fnxoL3wFeGv+dl0F6ZyBmsKy8Wt5kMyYsgL/joRTElmvTg69FMLAgCwLQKqb99+M6wDA6L69uDffm2dF65GuStJp4P+hHu44O8speuq6LjTXTzwbAv4fqCGi81XEWQE8XCEi+dZ0XwOyFqM4qlQzILfusEsVSbUXtNKIMDexgLRqUf5BVB3lqZ+EAHn9ci+p85UUkf/CYpgw9DEZz5isYr+ixEYxmJ+lL3upZVPyzAAWA+3F2+e/e8uzF7RQP7ZM5hTCbzPbCccQ7OnUXnexWcxwvP6UbbFp4TDWJBm+H52cQ50fDcbHRuM/v8axCLzm2G68s8PxueSx0ea+bcbF5e/IMyLxadn03/2Ky/H8BmTGAAAAAd4w1cGoyptQAAAGgTamIAAAAsO2ritmL6NwAAAAAAAAAAAAAAmDuuwAAAALqn9pm1AAAAQMtQEwMAAGDZURO3EhMYAABAt7iksubClDoXAAAAbUJNDAAAgGVHTdxa3EICAAAAAAAAAAAAAIAWMLOjzOwjZnatmd1sZl8ys+eYWa/JtszsIWb2N2b2FTO7xsx2mdkVZvZ3ZnZcPVvHFRgAAEAHuZfz7gIAAAAwV9TEAAAAWHZdrInN7CRJ75e0S9J7JF0r6URJr5F0tKTHNdjWsdXyWUkXSLpJ0j0lPVrSiWb2h+7+otxt28AEBuyh6FsyZutB3lr6minFWjqvt3t4Xi9qL5EzaC+9IyrCWD8Zs93pDbe1dJ7Wgrz1jLz1dHsexNQPds79dD88iIV5ufcTsvQFYcL5YsXkuzGz9OdcvWBlRdTH4II2YZvpWHabK4lY0H9P5YzIS65Lkq8E6wvbTMfKqM1e+n0N+5LIK1eC9qJ1FVFeMiQPhiRsM8wLYsH3IJkXfHVmHgOAKbmZ1vdJHAOC/XW5LR3rb0vvuMrVoC+JciY6bpRBCeS9dD2WfSwK2gyv65cdS6wvyLFUzqhY0I2obDQL2gxiRRgLOpPBPa/BMsgLY8EbVAa/E8pgoMvggxn81NSqhv8OWgu+4KtF+nfOepAX9b8Iri/aC06k5bYZvT/RZy+15T0L+hjtUAJR/9ugnHGR2k98B5xiGUAdvFR5662zW19w/m9RWN0F2egVzm5dmdsWnksN1xdsWxmcs47yom1IjWXmOVaL+pFzblaKz89G/cw9P5s4h+lR/3PPsYbnRDPP6WbGyiAW/aZMlbe552ajH5TxedsoFrQZ5qVjUVmZ+ZMyyyzX1WZmtp+kN2vwM+4Yd/+X6vkXaTCh4BQze4K7n91QW69099OHtHV3SV+Q9AIz+0t3v3qa7Vz8igEAAGAiPri3WZ1Ly0+0AwAAYNlQEwMAAGDZdbImPkXSgZLO3phwIEnuvkvSC6u//nZTbVWxvbj7lZIu1GDuwb3HXH8SV2AAAADdk3s1GAAAAKArqIkBAACw7LpXEx9bPX50SOxTkm6WdJSZbXf3UZdZqq0tM7uLpF+UdKukS0esdyQmMAAAAAAAAAAAAAAAMNrhZnbRsIC7H9Hwug+rHr8+ZN3rZnaFpH+vwVUQ/rWptszsSEknaDDX4B6SHi1pP0nPdPcfjr01CUxgAAAA3eKK76WY2yYAAADQFtTEAAAAWHbdrIn3rx5/nIhvPH/Hhts6UtJLNv39BklPdve/GWO9IzGBAQAAAAAAAAAAAACA0S6Z5koLZrZT0kETpLzT3Z84bvPVYx1TLZJtufsbJb3RzPaRdC9JT5P0djM72t2fNu2KmcAAAAC6p3v3NgMAAAAmQ00MAACAZbeYNfHlknZN8PqrNv1546oI+w97oQa3cdj8usjUbbn7Lg1uL/FsM9su6bfM7OPu/r4x1p/EBAbsKfgeW3CVlTDWj/KGrzDKKfrpTqbakySFsWADop1bE7EUs3Ss15u8PUkq0m1a1KanxyvoZTOsGP58sG3hWKbaG9GmFVFeZqyXl+epvGhdK+n323vp7fbocxLlrQT9D8Y5uW2SfCXIC9osE3nhdkd9DI6sZdhmOi8/lrm+RFrq+dz2BrGZ7zUAQNJgv7V2u1QsOG6sBm1Gx4Ag5onDaZizkq4nw7xof91Lt5mfF/3ACGKpvCgnt/wL2syNzVpOT8rgAF0EgxnllcFAh3lBbF3pD190QqNMvT/BYK2V6dp2tQh+pEZfEEU/lqMvVt5lTkult6EINr6X6GeZ2kGNUATfj2AkMUTq+7E4eyAArTfLf9jxGR4FMs83ZHcxOq6HaRnH/Nzzl9GYROcNM/MsOrcZbUOUF5yLTG5fdP5yludmp1ifh+d1o74kxiRorwzaiz5f8fnSes/bjsoLfkJktdnE+dfwH1JmHcuQfb43sx/R+trI3Y+bIv1SDW7fcKikizYHzGxFg6shrEv65ozbkqTzJP2WpGMkTTWBIe+oCgAAsKBcLi/LehdOEQMAAKBFqIkBAACw7DpaE19QPT5iSOwhkm4n6UJ3v3XGbUnS3avH9TFfn8QEBgAA0C2uwf8gqXWZ90YBAAAAE6AmBgAAwLLrZk38Pkk/lPQEMzty40kz20fSH1Z/fcPmBDPb38wON7O71dDWQ832voyOmR0i6bTqrx+eeKu24BYSAAAAAAAAAAAAAAAsMHe/3sx+Q4PJBzvM7GxJ10p6tKTDquffsyXtZElvk3SWpCdN2da5kn5kZp+V9G0N5hocosFVHFYkvd7d/2Ha7WQCAwAA6J5y/lNhAQAAgLmiJgYAAMCy62BN7O7nmNlDNbjiwWMl7SPpMknPk3SGu4+90RltvUTS8ZJ+SdKJknqSvifpHEl/7e5/P8Wm/QQTGAAAAAAAAAAAAAAAaAF3/4ykR4352jMlnVlTW6+T9LpxXjsNJjAAAICOccnL+tsEAAAAWoOaGAAAAMuOmritmMCAPXgRxHrpWLliQSz9ZU7llavpdVk/vS6V6Q0Iuq8y+CoUFqwviFmR7ov3+uk2V4fvTK2f3slaGeyAgzxFV5EZ/woze4r6kisYy6TofcvN6wX9yPyceNRmtN1BnqfyekE/wnVFeUFsJepjNM7B/iTc7nSTcV8Sz0fbHe0Pw/FK54VjGealY4q+BkEs2WYD6wrl5rnkdV8abAHqUjPbLumpkk6VdG8NLuf1bUn/IOlV7v6tOXYPaB0vpPXbJXY00T4yPAbE65u0TQ/q6KgfuTV9nBfsCKPjQ83HjrjkCvqYG8sU9iUQHb6i3zPp9oLfK0GsjH7nRHlRLPgwlJm/PcrgQ7SW+EKuFsFvsaAbqfYkqbD0b6Be0Mci2O7oPSiCjvaU7kv4/mT8fiqCz3k//Cw38Jux5frhzjJTR2tiAHUz2UpH/4nAGti3RuezAhYdZ6Nzcqm8ICdeV1RMR+co8857qpeun8J+BnlZ525zxlgzPm8rzfTcbRPnbeNzm9G/H+XlReVTbl+S54mjdUXnD3LOv6qZ88RRX7LO6y7SueAINXFrNXAUBwAAQJ3MbEXS+ZL+XNIdJL1b0hslfV/SMyV90cx+fn49BAAAAAAAAABgeh2dXgkAAJZa7ZcGm7uTJR2twSSG491v20Aze6mkF0t6vqSnzKd7AAAAWDjdq4kBAACAyVATtxJXYAAAAFh8964eP7x58kLl3OrxwBn2BwAAAAAAAACA2nEFBgAA0Dm139ts/r5aPT7SzF63ZRLDCdXjx2fcJwAAACywDtbEAAAAwESoiduJCQwAAKBjvIFLg7kkHW5mFw2Nuh9R8wq3+rCkD0j6r5K+bGYfl7Rb0hGSHiTp9ZL+vOE+AAAAoDUaq4kBAACAlqAmbitzZ6CXiZldY6urd179d3cZHu9bOjf4jkcxhXnDP38WfCzDdQWf56jNcH8TfUey15fxvQtToj5OvqopExdE+rM8+yaDxNw2LZ2YfOfCdc22j7ltehN9yVlXdj+C9WXmZa8wpy8NbHeOXdd9T76+dq27H7DXqswuKtS7/+11h1rXeZNuUKn+zZIuGRafwQQGmZlJerGkF0nqbQqdL+mF7v7PTfcB6Aozu8ZWVu+8/c7/LvGCvHbzj1MTPt9YP6IiPK/JusfEoiNm9rE7qOmjtOgwG4xlfjlTb5uL1Mfc9zXuZ+K3ZtiPKJj3+yj/KzDb9eVsXwO/uDCBa664Qeu7+vOoib8wi9oXQPPM7JpCvTvfXvvNuyvNaORAtSjnG4Nz+Nnryty2RWqz5rGc6XnbkeuruZ8tP287yEuHaj/Pmruu7H7UfE53qr7UmDNCzmfo1mvndp6YmrhhXIFh+Vzva2va/Z0rd867Iy10ePU49B+vEGLs8jF2+Ri7fIs+dgdLuj4Ru6RUXzfoR02s9xJ3/7XcZDPbKemgCVLe6e5PrHL3kfR2SY+U9HRJ50q6WdLRks6Q9Ckze5y7n5vbP2DJXO/ra9r1/e/snHdHWmjRjxGLjLHLx9jlY+zyLfrYHaw51cRNNApgLq4f7Cuu2znvjjSi2f+bVd8xou3/h2xyi358XWSMXT7GLt+ij93BoibuJK7AAIxp47LhzKqaHGOXj7HLx9jlY+yaYWbnS7r7BCl/5+6/V+WeLuklkp7t7mdsafc/SrpY0rfc/eBaOgsACRwj8jF2+Ri7fIxdPsYOAJDCMSIfY5ePscvH2OVj7DAvXIEBAABgBtz9uCnST6gePzGk3S+a2bWSDjKzA9z9minWAwAAAAAAAADA3BTz7gAAAABG2l49Hrg1YGbbpZ/ctHT3zHoEAAAAAAAAAEDNmMAAAACw+D5dPb6gmrCw2ekaXFXr8+5+w0x7BQAAAAAAAABAjbiFBAAAwOJ7uaQTJR0n6RIz+6ikWyQdLemB1Z+fPb/uAQAAAAAAAAAwPa7AAAAAsODc/UpJ95f0Kkm7JD1Z0jMk3VXSmZLu7+7/NLcOAgAAAAAAAABQA3P3efcBAAAAAAAAAAAAAAAsOa7AAAAAAAAAAAAAAAAA5o4JDAAAAAAAAAAAAAAAYO6YwAAAAAAAAAAAAAAAAOaOCQwAAAAAAAAAAAAAAGDumMAAAAAAAAAAAAAAAADmjgkMAAAAAAAAAAAAAABg7pjAAAAAAAAAAAAAAAAA5o4JDGgdM7uHmb3VzK4ys1vNbKeZvdbM7tR0O2Z2lJl9xMyuNbObzexLZvYcM+sFOaea2efM7EYz+7GZ7TCzE4a8btXMTjazt5jZV8zs+modXzazl5nZHSbZvrq2ua52mhy7RO6hZnaTmbmZvWOS7Uu01/mxM7ODzewNZvZNM9tlZteY2WfN7Hcn2cZpt7eudmYxbmb2C2b2TjO7zMxuMbMrzewTZvZ4M5vqGNuWsavaP83M3luNQ1l9735uRL/2NbOXmtml1eft+2b2t2Z230m2DwCWVVuOE5tyqIlFTTxNO7MaO6Mmpia+LYeaGAAWXFuOE5tyqIlFTTxNO7MaO6Mmpia+LYeaGPPh7iwsrVkkHSLpe5Jc0jmSXinpgurvl0g6oKl2JJ0kaV3SjZLeIulPq9e6pPcm1vNnVfzbkl4j6S8kXVM994wtrz28ev5GSf9X0h9Xr7+sev5SST/N2O09dkNyVyR9VtIN1evfwecuHjtJvyLpJkm3Snq/pFdIer2kj0n6R8Zt73GTdKKktWrM3lv166835bx5GT5zkh5TxUpJl0u6rvr7zwX92i7pH6vXfV6D/d27qvG8SdIvTvOdZWFhYen60qbjRJVDTTyDsRuSS01MTUxNPKOxEzUxCwsLy8yXNh0nqhxq4hmM3ZBcamJqYmriGY2dqIlZalzm3gEWlkkWSX9f7cieueX5V1fPv7GJdiTtJ+n71QHoyE3P7yPpwirnCVtyjqqev0zSnTY9f3B14Nol6eBNz99d0u9Iuv2WdrZJ+lDV1usZu73HbkgfX1yt71mqpzDt9NhJurcGRfy/STp0SL9XGbeh4/bVKuehW56/q24rBu+5BGN3D0kPlrRf9fcdGl2Y/kH1mvdKKjY9f1L1/Fc3P8/CwsLCsufSsuMENfGMxm5IH6mJqYmpiWc3dtTELCwsLDNeWnacoCae0dgN6SM1MTUxNfHsxo6amKW2Ze4dYGEZd6kOni7piq07LEl30GAW2E3aUtjV0Y6kp1Q5Zw1p79gq9sktz7+9ev7JQ3JeVsVeOua2bxw0v8zYxWMn6UgNZue9UNIxmrIwXYax25Tzq7njtKTjdoukHyf6/XdVzhFdH7shr9uhoDCVZJK+Vb3mXkPin6piD6vr88jCwsLSpaVtx4mcY2zQZ2riMcdO1MTUxNTEMx27Ia/bIWpiFhYWlsaWth0nco6xQZ+picccO1ETUxNTE8907Ia8boeoiVkyl6nuuwLM2LHV48fcvdwccPcbJH1G0u0k/VID7WzkfHRIe5+SdLOko8xs+5g55215zShr1eP6mK/fainGzsz21aDAuFiDSyDVodNjZ2arkk7RYDblR8zsgWb2XDP7X2Z2gpltG7FdKZ0et8pXJe1nZg/a/KSZ3UXSAyVdJelrQ9obpW1jN6lDJN1T0tfd/Yoh8Un3jwCwbNp2nKAm3jOHmnjydqiJF3TcKtTEeaiJAWA6bTtOUBPvmUNNPHk71MQLOm4VauI81MRIYgID2uSw6vHrifg3qsdDG2gnmePu6xrMXFvRYCabzOz2Glzq60Z3v3qKvm54SvU47GAxjmUZu1dW7ZxatV2Hro/d/STtK+krks7W4J5wr5b0JxrcY+8bZvaA5FaldX3cJOm5kq6X9HEze4+ZvcLM3qxBwXqDpMe4+y2pDQu0Zuwy1bV9ALCsWnOcoCamJq6pHWrixR03iZo4FzUxAEynNccJamJq4praoSZe3HGTqIlzURMjaWXeHQAmsH/1+ONEfOP5OzbQzqQ5dfVVZvZoSb8l6TsaFAs5Oj92ZnacpGdK+n13z5nNmNL1sbtL9fhQDS519euSzpH0U5KeLun3NJhxe193/2Gi3WG6Pm5y90+b2S9L+ltJ/21T6AZJb5P05UR7o7Rp7HLMYh0A0GVtOk5QE+fnUBPn51AT5+VQE9e/7gg1MQBMp03HCWri/Bxq4vwcauK8HGri+tcdoSZGEldgQJdY9ehzaCd33eHrzewoSe/S4P5Dj3X36yZsf1ytHjszu6MGhcBnJb1qwnam1eqxk9Tb9PgH7v5Wd7/W3f/N3f+3pA9I+mlJvzHhOkZp+7jJzB4u6dOSrpR0hKTba3DZq7+W9HJJ55tZExMF2zh2k5jFOgCgy9p4nKAmpiaeph1qYmriWbdDTQwAi6+NxwlqYmriadqhJqYmnnU71MRoFBMY0CYbs632T8T32/K6OtuZNGfU60fNLFM1Y+88SaWkR7j751KvHUPXx+7VGhRPT3L3fiIvV9fHbvOPnQ8Oydl47oGJNlM6PW5mdmdJ79FgNvLJ7v4Fd7/Z3b/p7s/TYHbyUZKemGgz0qaxyzGLdQBAl7XpOEFNnJ9DTZyfQ02cl0NNXP+66+4XAOA2bTpOUBPn51AT5+dQE+flUBPXv+66+4UlwQQGtMml1WPqfjf3qR5T98uZpp1kTjVz7l6S1iV9U5Lc/SYNZtv9lJndbdK+mtmDJf29BjPLjnf3zyT6Oq6uj939Nbg/1yVm5huLpE9U8V+rnrs4tWGBro/dpZv+/KMhORuF676Jfqd0fdyOknQnSZ9195uH5Gx89o5I9DvSmrHLVNf2AcCyas1xgpqYmrimdqiJF3fcqInzURMDwHRac5ygJqYmrqkdauLFHTdq4nzUxEhiAgPaZGNHf7yZ7fHZNbM7SDpag1lu/9xAOxdUj48Y0t5DJN1O0oXufuuYOY/c8prNfThWgxm165Ie7u6jtmccXR+7D0h6y5DlI1X88urvHxi6VbFOj527Xyvp4uqv9xuSs/HcziGxSKfHTdL26vHARL83nt+diEfaNnaTulzSv0k61MzuNSSe3D8CACS17zhBTTxATZzfDjXxgo6bqImpiQFgftp2nKAmHqAmzm+HmnhBx03UxNTEaIa7s7C0ZtFts02fueX5V1fPv3HTc6uSDpd0yDTtVM/vJ+kHkm6VdOSm5/eRdGGV84QtOUdVz18m6U6bnj9Y0jWSdkk6eEvO8ZJulvRDSf+ZsRt/7BLbfEzVzjsYu/Bz99Qq5+OS9tn0/D0kfbeKHcO43TZukn5G0pqkvgaz3ze39bOSvl+196iuf+aGrHNH9bqfC17zB9Vr3iup2PT8SdXzX938PAsLCwvLnkubjhOTHmOrGDVx5tgltvkYUROP87mjJqYmzh67IevcIWpiFhYWlkaXNh0nJj3GVjFq4syxS2zzMaImHudzR01MTZw9dkPWuUPUxCyZy9w7wMIyySLpEEnfq3Zc50h6hQazr1yDy80csOm1B1fP75ymnU05j9FgtuuNkv5a0p9IumTTztWG5Lyqin9b0msk/YUGRadLesaW1x6mwSw3l/Q+SacPWxi7vccu2OZjVE9h2umx0+BqPB/c1I8zNJiJfE313OsYt6Hj9uIq1pd0rqQ/lnSWpBuq5z+wRJ+5MzctGz9m3r/puQdtef12SZ+pXvd5Sa+U9C4Niv2bJP3iNN9ZFhYWlq4vLTxOUBPPYOyCbT5G1MTUxNTE1MQsLCwsHVtaeJygJp7B2AXbfIyoiamJqYmpiVlas8y9Aywsky4azFp7m6SrNbjszrckvU7Snbe8LrmznqSdLTlHa3C5qes0KCK/LOm5knpBzqnVjvem6oD1SUknDHndMVV/w4Wx23vsgvyNMZ2qMF2GsZO0IunZGlwm7GYNipLPSHoi4xaO20kaXMrvBxoUc9drMAP1t6P1dG3sNHrf9aQhOftKeqmkb2gwk/cHGhS+Pz/t95WFhYVlGZY2HSeqHGrihscuyN8YU2piamJqYmpiFhYWlk4tbTpOVDnUxA2PXZC/MabUxNTE1MTUxCwtWKz6cAAAAAAAAAAAAAAAAMxNMe8OAAAAAAAAAAAAAAAAMIEBAAAAAAAAAAAAAADMHRMYAAAAAAAAAAAAAADA3DGBAQAAAAAAAAAAAAAAzB0TGAAAAAAAAAAAAAAAwNwxgQEAAAAAAAAAAAAAAMwdExgAAAAAAAAAAAAAAMDcMYEBAAAAAAAAAAAAAADMHRMYAAAAAAAAAAAAAADA3DGBAQAAAAAAAAAAAAAAzB0TGAAAAAAAAAAAAAAAwNwxgQEAAAAAAAAAAAAAAMwdExgAYEpmtsPMvmxmjexTbeBiM/t0E+0DAAAA06ImBgAAwLKjJgaAejCBAQCmYGanSHqopJe4e9nEOtzdJb1E0oOq9QEAAAALg5oYAAAAy46aGADqY4P9HQBgUmZmkv5Vkkk63BveoZrZ1yT1ZrEuAAAAYBzUxAAAAFh21MQAUC+uwAAA+f6LpMMknTWjQvEsSYdKOm4G6wIAAADGQU0MAACAZUdNDAA1YgIDgKVjZjvNzIPlzDGb+vXq8T1D1vGkqq0nmdnDzezTZnajmf3AzN5mZnesXvefzexDZnZdFf87Mzs4sb6zt6wXAAAAyEJNDAAAgGVHTQwAi2ll3h0AgDl4raQ7Dnn+REn3l3TzqAaqy4IdK+m77n558NJHSzpB0ockvVHSUZKeJOleZvb7ks6X9GlJb5H0C1UfDjGzX9h6rzR3/5aZXSnpv5iZcXkwAAAATOG1oiYGAADAcnutqIkBYOEwgQHA0nH31259zsweLuk0SZdJevEYzRwm6UANCs7IoyUd5+6frNZTSPp7DS4r9hFJv+nu79zUj7dIeooGBeq5Q9r7vKTHSLqvpK+N0U8AAABgL9TEAAAAWHbUxACwmLiFBIClZ2b3k/Q+ST+W9Ch3/+EYafesHq8e8bp3bxSlklTNlv2b6q9f2VyUVt5ePf6nRHvf3bJ+AAAAYGrUxAAAAFh21MQAsBi4AgOApWZmd5P0YUnbJZ3g7t8YM/WA6vG6Ea/7lyHPXVU9XjQkdmX1eI9Ee9dWjz89Yr0AAADAWKiJAQAAsOyoiQFgcTCBAcDSMrPba3Bpr5+V9Gvu/ukJ0m+pHvcZ8bofD3lufYzYaqK9fbesHwAAAMhGTQwAAIBlR00MAIuFCQwAllJ1j7F3S7q/pNPc/d0TNvH96vGA8FX121jf98NXAQAAACNQEwMAAGDZURMDwOIp5t0BAJiT10o6UdJb3f2PMvK/Kqkv6fA6OzWGwyWVkr484/UCAACge14ramIAAAAst9eKmhgAFgoTGAAsHTN7jqRnSjpf0tNy2nD3H0u6WNJ/MLN9R7y8Fma2XdJ/kvT/3P1Hs1gnAAAAuomaGAAAAMuOmhgAFhO3kACwVMzsrpJeJck1mJ16mpltfdnF7n7OGM29X9IRko6V9OEau5lyjKRt1XoBAACALNTEAAAAWHbUxACwuJjAAGDZ7KPbrj7znMRrzpJ0zhhtvUXS6ZL+p2ZTmJ4qaXe1XgAAACAXNTEAAACWHTUxACwoc/d59wEAWsvM/kqDgvFgd/9ug+u5i6Sdkt7l7k9taj0AAADApKiJAQAAsOyoiQGgPsXolwAAAi/WYLbraQ2v5wWS+pJe1PB6AAAAgElREwMAAGDZURMDQE2YwAAAU3D370l6oqSrzKyRfaoNbr52taT/4e5XN7EOAAAAIBc1MQAAAJYdNTEA1IdbSAAAAAAAAAAAAAAAgLnjCgwAAAAAAAAAAAAAAGDumMAAAAAAAAAAAAAAAADmjgkMAAAAAAAAAAAAAABg7pjAAAAAAAAAAAAAAAAA5o4JDAAAAAAAAAAAAAAAYO6YwAAAAAAAAAAAAAAAAOaOCQwAAAAAAAAAAAAAAGDumMAAAAAAAAAAAAAAAADmjgkMAAAAAAAAAAAAAABg7pjAAAAAAAAAAAAAAAAA5o4JDAAAAAAAAAAAAAAAYO6YwAAAAAAAAAAAAAAAAOaOCQwAAAAAAAAAAAAAAGDu/j/ltCsc0B9H8wAAAABJRU5ErkJggg==\n", + "text/plain": [ + "
" + ] + }, + "metadata": { + "image/png": { + "height": 277, + "width": 1048 + }, + "needs_background": "light" + }, + "output_type": "display_data" + } + ], + "source": [ + "# Method 3\n", + "plot_plane(IDAT[3]['xz_plane'])" + ] + }, + { + "cell_type": "code", + "execution_count": 39, + "id": "utility-yacht", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "1.4142942337258546e-06" + ] + }, + "execution_count": 39, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "# Max relative difference 3 vs 1\n", + "np.abs(IDAT[3]['xz_plane']['Ez']/IDAT[1]['xz_plane']['Ez']-1).max()" + ] + }, + { + "cell_type": "code", + "execution_count": 40, + "id": "latest-dylan", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "1.001019045432372e-09" + ] + }, + "execution_count": 40, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "# Max relative difference 2 vs 1\n", + "np.abs(IDAT[2]['xz_plane']['Ez']/IDAT[1]['xz_plane']['Ez']-1).max()" + ] + }, { "cell_type": "markdown", - "id": "pursuant-scott", + "id": "connected-single", "metadata": {}, "source": [ "# Cleanup" @@ -678,8 +900,8 @@ }, { "cell_type": "code", - "execution_count": 17, - "id": "current-installation", + "execution_count": 22, + "id": "optional-prototype", "metadata": {}, "outputs": [], "source": [ From b06a4880eeebcc1d588d517971a281676b2d91ad Mon Sep 17 00:00:00 2001 From: ChristopherMayes <31023527+ChristopherMayes@users.noreply.github.com> Date: Thu, 18 Mar 2021 13:54:26 -0700 Subject: [PATCH 4/4] Remove files --- OpticsJan2020/MLI_light_optics/00readme | 1 - .../MLI_light_optics/Includes/actpar.inc | 2 - .../MLI_light_optics/Includes/aimdef.inc | 8 - .../MLI_light_optics/Includes/amdiip.inc | 8 - .../MLI_light_optics/Includes/bfield.inc | 4 - .../MLI_light_optics/Includes/buffer.inc | 6 - .../MLI_light_optics/Includes/codes.inc | 35 - .../MLI_light_optics/Includes/combs.inc | 1 - .../MLI_light_optics/Includes/const.inc | 9 - .../Includes/copy_of_stubs.inc | 445 - .../MLI_light_optics/Includes/core.inc | 10 - .../MLI_light_optics/Includes/core_old.inc | 6 - .../MLI_light_optics/Includes/deriv.inc | 8 - .../MLI_light_optics/Includes/dip.inc | 4 - .../MLI_light_optics/Includes/dr.inc | 2 - .../MLI_light_optics/Includes/drl.inc | 2 - .../MLI_light_optics/Includes/ebdata.inc | 32 - .../MLI_light_optics/Includes/expon.inc | 7 - .../MLI_light_optics/Includes/extalk.inc | 1 - .../MLI_light_optics/Includes/files.inc | 8 - .../MLI_light_optics/Includes/fitbuf.inc | 6 - .../MLI_light_optics/Includes/fitdat.inc | 12 - .../MLI_light_optics/Includes/frnt.inc | 3 - .../MLI_light_optics/Includes/gronax.inc | 4 - .../MLI_light_optics/Includes/hmflag.inc | 1 - .../MLI_light_optics/Includes/id.inc | 3 - .../MLI_light_optics/Includes/impli.inc | 1 - .../MLI_light_optics/Includes/incmif.inc | 12 - .../MLI_light_optics/Includes/ind.inc | 1 - .../MLI_light_optics/Includes/ind3.inc | 1 - .../MLI_light_optics/Includes/infin.inc | 2 - .../MLI_light_optics/Includes/iprod.inc | 3 - .../MLI_light_optics/Includes/ja3.inc | 1 - .../MLI_light_optics/Includes/keyset.inc | 7 - .../MLI_light_optics/Includes/labpnt.inc | 5 - .../MLI_light_optics/Includes/len.inc | 1 - .../MLI_light_optics/Includes/len3.inc | 1 - .../MLI_light_optics/Includes/lims.inc | 3 - .../MLI_light_optics/Includes/linbuf.inc | 7 - .../MLI_light_optics/Includes/loop.inc | 5 - .../MLI_light_optics/Includes/map.inc | 3 - .../MLI_light_optics/Includes/maxcat.inc | 5 - .../MLI_light_optics/Includes/merit.inc | 2 - .../MLI_light_optics/Includes/minvar.inc | 5 - .../MLI_light_optics/Includes/mliinc.tar | Bin 112640 -> 0 bytes .../MLI_light_optics/Includes/mpi_stubs.inc | 12 - .../Includes/mpi_stubs_placeholder.inc | 12 - .../MLI_light_optics/Includes/multipole.inc | 14 - .../MLI_light_optics/Includes/nlsvar.inc | 6 - .../MLI_light_optics/Includes/nnprint.inc | 1 - .../MLI_light_optics/Includes/nturn.inc | 2 - .../MLI_light_optics/Includes/order.inc | 3 - .../MLI_light_optics/Includes/param.inc | 6 - .../MLI_light_optics/Includes/parset.inc | 3 - .../MLI_light_optics/Includes/pbkh.inc | 1 - .../MLI_light_optics/Includes/pbkh_bck.inc | 1 - .../MLI_light_optics/Includes/pie.inc | 2 - .../MLI_light_optics/Includes/pq.inc | 1 - .../MLI_light_optics/Includes/previous.inc | 3 - .../MLI_light_optics/Includes/prodex.inc | 3 - .../MLI_light_optics/Includes/psflag.inc | 2 - .../MLI_light_optics/Includes/quadp.inc | 1 - .../MLI_light_optics/Includes/quadpn.inc | 1 - .../MLI_light_optics/Includes/recmul.inc | 1 - .../MLI_light_optics/Includes/setref.inc | 3 - .../MLI_light_optics/Includes/sigbuf.inc | 4 - .../MLI_light_optics/Includes/sincos.inc | 4 - .../MLI_light_optics/Includes/sol.inc | 5 - .../MLI_light_optics/Includes/sr.inc | 2 - .../MLI_light_optics/Includes/srl.inc | 2 - .../MLI_light_optics/Includes/stack.inc | 13 - .../MLI_light_optics/Includes/status.inc | 7 - .../MLI_light_optics/Includes/stmap.inc | 8 - .../MLI_light_optics/Includes/supres.inc | 1 - .../MLI_light_optics/Includes/symp.inc | 3 - .../MLI_light_optics/Includes/talk.inc | 2 - .../MLI_light_optics/Includes/taylor.inc | 5 - .../MLI_light_optics/Includes/time.inc | 2 - .../MLI_light_optics/Includes/usrdat.inc | 1 - .../MLI_light_optics/Includes/vblist.inc | 3 - .../MLI_light_optics/Includes/vecpot.inc | 2 - .../MLI_light_optics/Includes/xvary.inc | 8 - .../MLI_light_optics/Includes/zeroes.inc | 2 - .../MLI_light_optics/Includes/zz.inc | 6 - .../MLI_light_optics/Makedir/makefile | 295 - OpticsJan2020/MLI_light_optics/Src/afro.f | 8787 ----------------- .../MLI_light_optics/Src/afro_mod.f90 | 177 - OpticsJan2020/MLI_light_optics/Src/anal.f | 4813 --------- OpticsJan2020/MLI_light_optics/Src/base.f | 1032 -- OpticsJan2020/MLI_light_optics/Src/bessjm.f | 723 -- OpticsJan2020/MLI_light_optics/Src/book.f | 1032 -- OpticsJan2020/MLI_light_optics/Src/boundp3d.f | 72 - OpticsJan2020/MLI_light_optics/Src/cfbdang.f | 177 - OpticsJan2020/MLI_light_optics/Src/cfqd.f | 826 -- OpticsJan2020/MLI_light_optics/Src/coil.f | 700 -- OpticsJan2020/MLI_light_optics/Src/comm.f | 932 -- OpticsJan2020/MLI_light_optics/Src/cons.f | 59 - .../MLI_light_optics/Src/constants_mod.f90 | 151 - .../MLI_light_optics/Src/curve_fit.f90 | 604 -- .../MLI_light_optics/Src/depositrho.f | 95 - .../MLI_light_optics/Src/diagnostics.f | 905 -- OpticsJan2020/MLI_light_optics/Src/dist.f | 2255 ----- OpticsJan2020/MLI_light_optics/Src/dummy.f | 87 - OpticsJan2020/MLI_light_optics/Src/dumpin.f | 4190 -------- .../MLI_light_optics/Src/e_gengrad_mod.f | 1222 --- OpticsJan2020/MLI_light_optics/Src/ebcomp.f | 1138 --- OpticsJan2020/MLI_light_optics/Src/elem.f | 2480 ----- OpticsJan2020/MLI_light_optics/Src/env.f | 844 -- OpticsJan2020/MLI_light_optics/Src/euclid.f | 114 - OpticsJan2020/MLI_light_optics/Src/fftessl.f | 65 - OpticsJan2020/MLI_light_optics/Src/fftpkgq.f | 372 - .../MLI_light_optics/Src/fftw_dummy.f | 17 - .../MLI_light_optics/Src/fparser.f90 | 737 -- OpticsJan2020/MLI_light_optics/Src/gendip5.f | 641 -- .../MLI_light_optics/Src/gengrad_mod.f | 37 - OpticsJan2020/MLI_light_optics/Src/genm.f | 526 - OpticsJan2020/MLI_light_optics/Src/gensol.f | 511 - .../MLI_light_optics/Src/greenfn_mod.f90 | 573 -- OpticsJan2020/MLI_light_optics/Src/hamdrift.f | 58 - OpticsJan2020/MLI_light_optics/Src/imkmpak.f | 1380 --- OpticsJan2020/MLI_light_optics/Src/inpu.f | 1857 ---- OpticsJan2020/MLI_light_optics/Src/integ.f | 803 -- OpticsJan2020/MLI_light_optics/Src/iron.f | 2264 ----- OpticsJan2020/MLI_light_optics/Src/liea.f | 1900 ---- .../MLI_light_optics/Src/liea_mod.f90 | 4 - OpticsJan2020/MLI_light_optics/Src/linpak.f | 1187 --- .../MLI_light_optics/Src/linpak_all.f | 1615 --- .../MLI_light_optics/Src/linpak_old.f | 1187 --- OpticsJan2020/MLI_light_optics/Src/magnet.f | 3985 -------- OpticsJan2020/MLI_light_optics/Src/makeit | 2 - OpticsJan2020/MLI_light_optics/Src/math.f | 2037 ---- OpticsJan2020/MLI_light_optics/Src/meri.f | 793 -- OpticsJan2020/MLI_light_optics/Src/mpi.f | 161 - OpticsJan2020/MLI_light_optics/Src/mpif.h | 29 - .../MLI_light_optics/Src/multitrack_mod.f90 | 62 - OpticsJan2020/MLI_light_optics/Src/myblas.f | 932 -- .../MLI_light_optics/Src/mygenrec5.f | 554 -- OpticsJan2020/MLI_light_optics/Src/myprot5.f | 83 - OpticsJan2020/MLI_light_optics/Src/opti.f | 1798 ---- OpticsJan2020/MLI_light_optics/Src/optics.f | 299 - .../MLI_light_optics/Src/parallel_mod.f90 | 57 - .../MLI_light_optics/Src/parameters.f90 | 10 - OpticsJan2020/MLI_light_optics/Src/proc.f | 3328 ------- OpticsJan2020/MLI_light_optics/Src/pure.f | 576 -- OpticsJan2020/MLI_light_optics/Src/rfgap.f | 809 -- OpticsJan2020/MLI_light_optics/Src/setbound.f | 229 - .../MLI_light_optics/Src/sfft3d_dummy.f | 13 - .../MLI_light_optics/Src/sfft3d_essl.f | 119 - OpticsJan2020/MLI_light_optics/Src/sif.f | 5735 ----------- OpticsJan2020/MLI_light_optics/Src/spch2d.f | 960 -- OpticsJan2020/MLI_light_optics/Src/spch3d.f | 1274 --- .../MLI_light_optics/Src/spch3d_chombo.f | 435 - .../Src/spch3d_chombo_dummy.f | 13 - .../MLI_light_optics/Src/spch3d_dummy.f | 29 - .../MLI_light_optics/Src/spch3d_essl.f | 529 - .../MLI_light_optics/Src/spch3d_mod.f90 | 43 - OpticsJan2020/MLI_light_optics/Src/sss.f | 580 -- .../MLI_light_optics/Src/timer_mod.f90 | 138 - OpticsJan2020/MLI_light_optics/Src/trac.f | 1674 ---- OpticsJan2020/MLI_light_optics/Src/user.f | 1667 ---- OpticsJan2020/MLI_light_optics/Src/user7.f | 51 - OpticsJan2020/MLI_light_optics/Src/usubs.f | 1185 --- OpticsJan2020/MLI_light_optics/Src/wakefld.f | 1732 ---- OpticsJan2020/MLI_light_optics/Src/xerbla.f | 43 - OpticsJan2020/MLI_light_optics/Src/xtra.f | 95 - .../MLI_light_optics/Src/xtra_notgnu.f | 95 - 166 files changed, 82449 deletions(-) delete mode 100644 OpticsJan2020/MLI_light_optics/00readme delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/actpar.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/aimdef.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/amdiip.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/bfield.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/buffer.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/codes.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/combs.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/const.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/copy_of_stubs.inc delete mode 100644 OpticsJan2020/MLI_light_optics/Includes/core.inc delete mode 100644 OpticsJan2020/MLI_light_optics/Includes/core_old.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/deriv.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/dip.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/dr.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/drl.inc delete mode 100644 OpticsJan2020/MLI_light_optics/Includes/ebdata.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/expon.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/extalk.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/files.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/fitbuf.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/fitdat.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/frnt.inc delete mode 100644 OpticsJan2020/MLI_light_optics/Includes/gronax.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/hmflag.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/id.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/impli.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/incmif.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/ind.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/ind3.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/infin.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/iprod.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/ja3.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/keyset.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/labpnt.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/len.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/len3.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/lims.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/linbuf.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/loop.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/map.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/maxcat.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/merit.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/minvar.inc delete mode 100644 OpticsJan2020/MLI_light_optics/Includes/mliinc.tar delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/mpi_stubs.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/mpi_stubs_placeholder.inc delete mode 100644 OpticsJan2020/MLI_light_optics/Includes/multipole.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/nlsvar.inc delete mode 100644 OpticsJan2020/MLI_light_optics/Includes/nnprint.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/nturn.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/order.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/param.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/parset.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/pbkh.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/pbkh_bck.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/pie.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/pq.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/previous.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/prodex.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/psflag.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/quadp.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/quadpn.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/recmul.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/setref.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/sigbuf.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/sincos.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/sol.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/sr.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/srl.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/stack.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/status.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/stmap.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/supres.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/symp.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/talk.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/taylor.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/time.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/usrdat.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/vblist.inc delete mode 100644 OpticsJan2020/MLI_light_optics/Includes/vecpot.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/xvary.inc delete mode 100755 OpticsJan2020/MLI_light_optics/Includes/zeroes.inc delete mode 100644 OpticsJan2020/MLI_light_optics/Includes/zz.inc delete mode 100644 OpticsJan2020/MLI_light_optics/Makedir/makefile delete mode 100755 OpticsJan2020/MLI_light_optics/Src/afro.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/afro_mod.f90 delete mode 100644 OpticsJan2020/MLI_light_optics/Src/anal.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/base.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/bessjm.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/book.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/boundp3d.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/cfbdang.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/cfqd.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/coil.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/comm.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/cons.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/constants_mod.f90 delete mode 100644 OpticsJan2020/MLI_light_optics/Src/curve_fit.f90 delete mode 100644 OpticsJan2020/MLI_light_optics/Src/depositrho.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/diagnostics.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/dist.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/dummy.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/dumpin.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/e_gengrad_mod.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/ebcomp.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/elem.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/env.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/euclid.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/fftessl.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/fftpkgq.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/fftw_dummy.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/fparser.f90 delete mode 100755 OpticsJan2020/MLI_light_optics/Src/gendip5.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/gengrad_mod.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/genm.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/gensol.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/greenfn_mod.f90 delete mode 100755 OpticsJan2020/MLI_light_optics/Src/hamdrift.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/imkmpak.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/inpu.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/integ.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/iron.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/liea.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/liea_mod.f90 delete mode 100755 OpticsJan2020/MLI_light_optics/Src/linpak.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/linpak_all.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/linpak_old.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/magnet.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/makeit delete mode 100644 OpticsJan2020/MLI_light_optics/Src/math.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/meri.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/mpi.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/mpif.h delete mode 100644 OpticsJan2020/MLI_light_optics/Src/multitrack_mod.f90 delete mode 100644 OpticsJan2020/MLI_light_optics/Src/myblas.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/mygenrec5.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/myprot5.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/opti.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/optics.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/parallel_mod.f90 delete mode 100644 OpticsJan2020/MLI_light_optics/Src/parameters.f90 delete mode 100755 OpticsJan2020/MLI_light_optics/Src/proc.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/pure.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/rfgap.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/setbound.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/sfft3d_dummy.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/sfft3d_essl.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/sif.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/spch2d.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/spch3d.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/spch3d_chombo.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/spch3d_chombo_dummy.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/spch3d_dummy.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/spch3d_essl.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/spch3d_mod.f90 delete mode 100755 OpticsJan2020/MLI_light_optics/Src/sss.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/timer_mod.f90 delete mode 100755 OpticsJan2020/MLI_light_optics/Src/trac.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/user.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/user7.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/usubs.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/wakefld.f delete mode 100644 OpticsJan2020/MLI_light_optics/Src/xerbla.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/xtra.f delete mode 100755 OpticsJan2020/MLI_light_optics/Src/xtra_notgnu.f diff --git a/OpticsJan2020/MLI_light_optics/00readme b/OpticsJan2020/MLI_light_optics/00readme deleted file mode 100644 index 11ee904..0000000 --- a/OpticsJan2020/MLI_light_optics/00readme +++ /dev/null @@ -1 +0,0 @@ -This was copied from ~/IncludesUSPAS/MLIstuff/MLIwithoptics/ diff --git a/OpticsJan2020/MLI_light_optics/Includes/actpar.inc b/OpticsJan2020/MLI_light_optics/Includes/actpar.inc deleted file mode 100755 index 8d32961..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/actpar.inc +++ /dev/null @@ -1,2 +0,0 @@ -c six active parameters for general use - common/actpar/aapar,bbpar,ccpar,ddpar,eepar,ffpar diff --git a/OpticsJan2020/MLI_light_optics/Includes/aimdef.inc b/OpticsJan2020/MLI_light_optics/Includes/aimdef.inc deleted file mode 100755 index 30a40c5..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/aimdef.inc +++ /dev/null @@ -1,8 +0,0 @@ -c------------------------------------------------------------------- -c aim definitions for inner and outer loops -c - parameter (maxa=100) - common/aimdef/maim,nsq(3),ksq(3),lsq(3,3),kyf(maxa,3), - * nsf(maxa,3),idf(maxa,3),jdf(maxa,3),target(maxa,3),wts(maxa,3) - character*8 qname - common/qlabel/qname(maxa,3) diff --git a/OpticsJan2020/MLI_light_optics/Includes/amdiip.inc b/OpticsJan2020/MLI_light_optics/Includes/amdiip.inc deleted file mode 100755 index 022c3ba..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/amdiip.inc +++ /dev/null @@ -1,8 +0,0 @@ -c-------------------------------------------------------------- -c Adaptive Multidimensional Inverse Interpolation (AMDII) Pool -c C. T. Mottershead LANL AT-3 June 93 -c - parameter (maxv=40, mxvp = maxv + 1) - common/amdiip/ic,maxcut,ncut,npts,level,mdii,errtol,antmin,antol, - * delta,slo,fultgt(maxv),partgt(maxv),err(mxvp),xx(maxv,mxvp), - * ff(maxv,mxvp),ga(maxv*mxvp), xbar(maxv), yy(maxv) diff --git a/OpticsJan2020/MLI_light_optics/Includes/bfield.inc b/OpticsJan2020/MLI_light_optics/Includes/bfield.inc deleted file mode 100755 index a5e4e30..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/bfield.inc +++ /dev/null @@ -1,4 +0,0 @@ -c Magnetic Field and Derivatives ( Tesla/ meter ) for -c general midplane symmetric Dipole. F. Neri June 3 1989. - double precision b(0:6,0:6) - common/bfield/b diff --git a/OpticsJan2020/MLI_light_optics/Includes/buffer.inc b/OpticsJan2020/MLI_light_optics/Includes/buffer.inc deleted file mode 100755 index 624692f..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/buffer.inc +++ /dev/null @@ -1,6 +0,0 @@ - common/buffer/buf1a(monoms),buf2a(monoms),buf3a(monoms), - # buf4a(monoms),buf5a(monoms), - # buf1m(6,6),buf2m(6,6),buf3m(6,6), - # buf4m(6,6),buf5m(6,6) - dimension bfa(monoms,5),bma(6,6,5) - equivalence (bfa,buf1a), (bma,buf1m) diff --git a/OpticsJan2020/MLI_light_optics/Includes/codes.inc b/OpticsJan2020/MLI_light_optics/Includes/codes.inc deleted file mode 100755 index 91600bd..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/codes.inc +++ /dev/null @@ -1,35 +0,0 @@ -c names of components of the Master Input File -c 9 types of input: -c 1=comments, 2=beam, 3=elements, 4=lines, 5=lumps,6=loops, -c 7=labor, 8=include 9=constants -c 10th component will be added shortly (wakes) -c -c Also, kinds of data in the menu, i.e. 9 kinds of "menu elements" -c 1=simple elements (drift, quadrupole,...) -c 2=user-supplied elements (usr1, usr2,...) -c 3=parameter sets (ps1, ps2,...) -c 4=random elements -c 5=random user-supplied elements -c 6=random parameter sets -c 7=simple commands -c 8=advanced commands -c 9=procedures and fitting & optimization -c -c The following is somewhat wasteful of memory (e.g. 75 simple elements -c but far fewer other kinds of data), but I am leaving as-is for simplicity. -c Eventually, instead of ltc(9,nrpmax), there could be 9 1D arrays. - parameter (nintypes=9) - parameter(nrpmax=75) - common/sharp/ling(nintypes) - character*8 ling -c type-codes of menu elements (note: eventually ltc should be char*16) -cryne Dec 1, 2002 character*8 ltc - character*16 ltc - common/monics/ltc(9,nrpmax) -c nrp=number of "real" (i.e. numeric) parameters -c ncp=number of character*16 parameters -c that are associated with elements and commands in monics - integer nrp,ncp,nrpold - common/nparm/nrp(9,nrpmax),ncp(9,nrpmax),nrpold(9,nrpmax) -cryne 7/28/2002 added nrpold for backward compatability w/ original -c MaryLie input parameters diff --git a/OpticsJan2020/MLI_light_optics/Includes/combs.inc b/OpticsJan2020/MLI_light_optics/Includes/combs.inc deleted file mode 100755 index f6c2340..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/combs.inc +++ /dev/null @@ -1 +0,0 @@ - common/combs/cmp2,qbyp,ptg diff --git a/OpticsJan2020/MLI_light_optics/Includes/const.inc b/OpticsJan2020/MLI_light_optics/Includes/const.inc deleted file mode 100755 index 91e1d08..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/const.inc +++ /dev/null @@ -1,9 +0,0 @@ -cryne 7/7/2002 -cryne this common block is used to store strings that have constant -cryne values assigned to them. -cryne nconst is equal to the number that have been assigned -cryne This info should really be included in elments.inc, but I am -cryne keeping it separate to avoid changes to the existing MaryLie - parameter (nconmax=1000) - character*16 constr - common/conarray/constr(nconmax),conval(nconmax),nconst diff --git a/OpticsJan2020/MLI_light_optics/Includes/copy_of_stubs.inc b/OpticsJan2020/MLI_light_optics/Includes/copy_of_stubs.inc deleted file mode 100755 index 4e8efc2..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/copy_of_stubs.inc +++ /dev/null @@ -1,445 +0,0 @@ - interface MPI_ALLGATHERV - module procedure MPI_ALLGATHERV1,MPI_ALLGATHERV2 - end interface - interface MPI_ALLTOALLV - module procedure MPI_ALLTOALLV1,MPI_ALLTOALLV2,MPI_ALLTOALLV3 - end interface - interface MPI_ALLGATHER - module procedure MPI_ALLGATHER1,MPI_ALLGATHER2,MPI_ALLGATHER3,& - MPI_ALLGATHER4,MPI_ALLGATHER5,MPI_ALLGATHER6 - end interface - interface MPI_GATHER - module procedure MPI_GATHER1,MPI_GATHER2,MPI_GATHER3,MPI_GATHER4 - end interface - interface MPI_ISEND - module procedure MPI_ISEND1,MPI_ISEND2,MPI_ISEND3,MPI_ISEND4 - end interface - interface MPI_SEND - module procedure MPI_SEND1,MPI_SEND2,MPI_SEND3,MPI_SEND4,& - MPI_SEND5,MPI_SEND6,MPI_SEND7,MPI_SEND8 - end interface - interface MPI_IRECV - module procedure MPI_IRECV1,MPI_IRECV2,MPI_IRECV3,MPI_IRECV4,& - MPI_IRECV5,MPI_IRECV6 - end interface - interface MPI_RECV - module procedure MPI_RECV1,MPI_RECV2,MPI_RECV3,MPI_RECV4, & - & MPI_RECV5 - end interface - interface MPI_REDUCE - module procedure MPI_REDUCE1,MPI_REDUCE2,MPI_REDUCE3,MPI_REDUCE4 - end interface - interface MPI_ALLREDUCE - module procedure MPI_ALLREDUCE1,MPI_ALLREDUCE2,MPI_ALLREDUCE3,MPI_ALLREDUCE4,MPI_ALLREDUCE5,MPI_ALLREDUCE6 - end interface - interface MPI_BCAST - module procedure MPI_BCAST1,MPI_BCAST2,MPI_BCAST3,MPI_BCAST4,& - MPI_BCAST5,MPI_BCAST6 - end interface -! -contains -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! HERE ARE THE MPI STUBS -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - !mpi initialization - subroutine MPI_INIT(ierr) - end subroutine MPI_INIT - - !mpi end - subroutine MPI_Finalize(ierr) - end subroutine MPI_Finalize - - !mpi test for initialization - subroutine MPI_INITIALIZED(flag,ierr) - integer ierr - logical flag - end subroutine MPI_INITIALIZED - - !global sum - subroutine MPI_ALLREDUCE1(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& - MPI_SUM,MPI_COMM_WORLD,ierr) - double precision, dimension(:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_ALLREDUCE1 - - subroutine MPI_ALLREDUCE2(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& - MPI_SUM,MPI_COMM_WORLD,ierr) - double precision :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_ALLREDUCE2 - - subroutine MPI_ALLREDUCE3(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& - MPI_SUM,MPI_COMM_WORLD,ierr) - integer, dimension(:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_ALLREDUCE3 - - subroutine MPI_ALLREDUCE4(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& - MPI_SUM,MPI_COMM_WORLD,ierr) - integer :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_ALLREDUCE4 - - subroutine MPI_ALLREDUCE5(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& - MPI_SUM,MPI_COMM_WORLD,ierr) - double precision, dimension(:,:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_ALLREDUCE5 - - subroutine MPI_ALLREDUCE6(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& - MPI_SUM,MPI_COMM_WORLD,ierr) - double precision, dimension(:,:,:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_ALLREDUCE6 - - !synchronize communication - subroutine MPI_BARRIER(comm2d,ierr) - integer :: comm2d - end subroutine MPI_BARRIER - - !processor ID - subroutine MPI_COMM_RANK(MPI_COMM_WORLD,my_rank,ierr) - my_rank = 0 - end subroutine MPI_COMM_RANK - -!ryne 12/29/2004 !mpi timing -!ryne 12/29/2004 double precision function MPI_WTIME() -!ryne 12/29/2004 MPI_WTIME = 0.0 -!ryne 12/29/2004 end function MPI_WTIME - - !mpi broadcast - subroutine MPI_BCAST1(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) - double precision, dimension(:) :: rffile - integer :: comm2d - end subroutine MPI_BCAST1 - - subroutine MPI_BCAST2(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) - double precision :: rffile - integer :: comm2d - end subroutine MPI_BCAST2 - - subroutine MPI_BCAST3(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) - integer, dimension(:) :: rffile - integer :: comm2d - end subroutine MPI_BCAST3 - - subroutine MPI_BCAST4(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) - integer :: rffile - integer :: comm2d - end subroutine MPI_BCAST4 - - subroutine MPI_BCAST5(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) - double precision, dimension(:,:) :: rffile - integer :: comm2d - end subroutine MPI_BCAST5 - - subroutine MPI_BCAST6(rffile,num1,MPI_INTEGER,num2,comm2d,ierr) - double precision, dimension(:,:,:) :: rffile - integer :: comm2d - end subroutine MPI_BCAST6 - - !total number of processors - subroutine MPI_COMM_SIZE(MPI_COMM_WORLD,np,ierr) - np = 1 - end subroutine MPI_COMM_SIZE - - !sum to local processor - subroutine MPI_REDUCE1(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& - MPI_SUM,num2,MPI_COMM_WORLD,ierr) - double precision, dimension(:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_REDUCE1 - - subroutine MPI_REDUCE2(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& - MPI_SUM,num2,MPI_COMM_WORLD,ierr) - double precision :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_REDUCE2 - - subroutine MPI_REDUCE3(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& - MPI_SUM,num2,MPI_COMM_WORLD,ierr) - integer, dimension(:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_REDUCE3 - - subroutine MPI_REDUCE4(tmplc,tmpgl,num,MPI_DOUBLE_PRECISION,& - MPI_SUM,num2,MPI_COMM_WORLD,ierr) - integer :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_REDUCE4 - - !mpi send command - subroutine MPI_SEND1(tmplc,num,MPI_DOUBLE_PRECISION,& - num1,num2,MPI_COMM_WORLD,ierr) - double precision, dimension(:) :: tmplc - end subroutine MPI_SEND1 - - subroutine MPI_SEND2(tmplc,num,MPI_DOUBLE_PRECISION,& - num1,num2,MPI_COMM_WORLD,ierr) - double precision :: tmplc - end subroutine MPI_SEND2 - - subroutine MPI_SEND3(tmplc,num,MPI_INTEGER,& - num1,num2,MPI_COMM_WORLD,ierr) - integer, dimension(:) :: tmplc - end subroutine MPI_SEND3 - - subroutine MPI_SEND4(tmplc,num,MPI_INTEGER,& - num1,num2,MPI_COMM_WORLD,ierr) - integer :: tmplc - end subroutine MPI_SEND4 - - subroutine MPI_SEND5(tmplc,num,MPI_DOUBLE_COMPLEX,& - num1,num2,MPI_COMM_WORLD,ierr) - double complex, dimension(:,:) :: tmplc - end subroutine MPI_SEND5 - - subroutine MPI_SEND6(tmplc,num,MPI_DOUBLE_COMPLEX,& - num1,num2,MPI_COMM_WORLD,ierr) - double complex, dimension(:,:,:) :: tmplc - end subroutine MPI_SEND6 - - subroutine MPI_SEND7(tmplc,num,MPI_DOUBLE_COMPLEX,& - num1,num2,MPI_COMM_WORLD,ierr) - double precision, dimension(:,:,:) :: tmplc - end subroutine MPI_SEND7 - - subroutine MPI_SEND8(tmplc,num,MPI_DOUBLE_COMPLEX,& - num1,num2,MPI_COMM_WORLD,ierr) - double precision, dimension(:,:) :: tmplc - end subroutine MPI_SEND8 - - !mpi isend command - subroutine MPI_ISEND1(tmplc,num,MPI_DOUBLE_PRECISION,& - num1,num2,MPI_COMM_WORLD,num3,ierr) - double precision, dimension(:) :: tmplc - end subroutine MPI_ISEND1 - - subroutine MPI_ISEND2(tmplc,num,MPI_DOUBLE_PRECISION,& - num1,num2,MPI_COMM_WORLD,num3,ierr) - double precision :: tmplc - end subroutine MPI_ISEND2 - - subroutine MPI_ISEND3(tmplc,num,MPI_INTEGER,& - num1,num2,MPI_COMM_WORLD,num3,ierr) - integer, dimension(:) :: tmplc - end subroutine MPI_ISEND3 - - subroutine MPI_ISEND4(tmplc,num,MPI_INTEGER,& - num1,num2,MPI_COMM_WORLD,num3,ierr) - integer :: tmplc - end subroutine MPI_ISEND4 - - !mpi wait command - subroutine MPI_WAIT(num3,status,ierr) - integer, dimension(:) :: status - end subroutine MPI_WAIT - - !mpi wait all command - subroutine MPI_WAITALL(num3,req,status,ierr) - integer, dimension(:) :: req - integer, dimension(:,:) :: status - end subroutine MPI_WAITALL - - !mpi recv command - subroutine MPI_RECV1(tmplc,num,MPI_DOUBLE_PRECISION,& - num1,num2,MPI_COMM_WORLD,status,ierr) - double precision :: tmplc - integer, dimension(:) :: status - end subroutine MPI_RECV1 - - subroutine MPI_RECV2(tmplc,num,MPI_INTEGER,& - num1,num2,MPI_COMM_WORLD,status,ierr) - integer :: tmplc - integer, dimension(:) :: status - end subroutine MPI_RECV2 - - subroutine MPI_RECV3(tmplc,num,MPI_DOUBLE_PRECISION,& - num1,num2,MPI_COMM_WORLD,status,ierr) - double precision, dimension(:) :: tmplc - integer, dimension(:) :: status - end subroutine MPI_RECV3 - - subroutine MPI_RECV4(tmplc,num,MPI_DOUBLE_PRECISION,& - num1,num2,MPI_COMM_WORLD,status,ierr) - integer, dimension(:) :: tmplc - integer, dimension(:) :: status - end subroutine MPI_RECV4 - - subroutine MPI_RECV5(tmplc,num,MPI_DOUBLE_PRECISION,& - num1,num2,MPI_COMM_WORLD,status,ierr) - double precision, dimension(:,:) :: tmplc - integer, dimension(:) :: status - end subroutine MPI_RECV5 - - - !mpi irecv command - subroutine MPI_IRECV1(tmplc,num,MPI_DOUBLE_PRECISION,& - num1,num2,MPI_COMM_WORLD,msid,ierr) - double precision :: tmplc - end subroutine MPI_IRECV1 - - subroutine MPI_IRECV2(tmplc,num,MPI_INTEGER,& - num1,num2,MPI_COMM_WORLD,msid,ierr) - integer :: tmplc - end subroutine MPI_IRECV2 - - subroutine MPI_IRECV3(tmplc,num,MPI_DOUBLE_COMPLEX,& - num1,num2,MPI_COMM_WORLD,msid,ierr) - double complex, dimension(:,:) :: tmplc - end subroutine MPI_IRECV3 - - subroutine MPI_IRECV4(tmplc,num,MPI_DOUBLE_COMPLEX,& - num1,num2,MPI_COMM_WORLD,msid,ierr) - double complex, dimension(:,:,:) :: tmplc - end subroutine MPI_IRECV4 - - subroutine MPI_IRECV5(tmplc,num,MPI_DOUBLE_PRECISION,& - num1,num2,MPI_COMM_WORLD,msid,ierr) - double precision, dimension(:,:,:) :: tmplc - end subroutine MPI_IRECV5 - - subroutine MPI_IRECV6(tmplc,num,MPI_INTEGER,& - num1,num2,MPI_COMM_WORLD,msid,ierr) - integer, dimension(:) :: tmplc - end subroutine MPI_IRECV6 - - !mpi gather command - subroutine MPI_GATHER1(tmplc,num,MPI_DOUBLE_PRECISION,& - tmpgl,num1,MPI_DOUBLE_PRECISION2,num2,MPI_COMM_WORLD,ierr) - double precision, dimension(:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_GATHER1 - - subroutine MPI_GATHER2(tmplc,num,MPI_DOUBLE_PRECISION,& - tmpgl,num1,MPI_DOUBLE_PRECISION2,num2,MPI_COMM_WORLD,ierr) - double precision :: tmplc - double precision, dimension(:) :: tmpgl - tmpgl = tmplc - end subroutine MPI_GATHER2 - - subroutine MPI_GATHER3(tmplc,num,MPI_INTEGER,& - tmpgl,num1,MPI_INTEGER2,num2,MPI_COMM_WORLD,ierr) - integer, dimension(:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_GATHER3 - - subroutine MPI_GATHER4(tmplc,num,MPI_INTEGER,& - tmpgl,num1,MPI_INTEGER2,num2,MPI_COMM_WORLD,ierr) - integer :: tmplc - integer, dimension(:) :: tmpgl - tmpgl = tmplc - end subroutine MPI_GATHER4 - - !mpi allgather command - subroutine MPI_ALLGATHER1(tmplc,num,MPI_DOUBLE_PRECISION,& - tmpgl,num1,MPI_DOUBLE_PRECISION2,MPI_COMM_WORLD,ierr) - double precision, dimension(:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_ALLGATHER1 - - subroutine MPI_ALLGATHER2(tmplc,num,MPI_DOUBLE_PRECISION,& - tmpgl,num1,MPI_DOUBLE_PRECISION2,MPI_COMM_WORLD,ierr) - double precision :: tmplc - double precision, dimension(:) :: tmpgl - tmpgl = tmplc - end subroutine MPI_ALLGATHER2 - - subroutine MPI_ALLGATHER3(tmplc,num,MPI_INTEGER,& - tmpgl,num1,MPI_INTEGER2,MPI_COMM_WORLD,ierr) - integer, dimension(:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_ALLGATHER3 - - subroutine MPI_ALLGATHER4(tmplc,num,MPI_INTEGER,& - tmpgl,num1,MPI_INTEGER2,MPI_COMM_WORLD,ierr) - integer :: tmplc - integer, dimension(:) :: tmpgl - tmpgl = tmplc - end subroutine MPI_ALLGATHER4 - - subroutine MPI_ALLGATHER5(tmplc,num,MPI_DOUBLE_PRECISION,& - tmpgl,num1,MPI_DOUBLE_PRECISION2,MPI_COMM_WORLD,ierr) - double precision, dimension(:,:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_ALLGATHER5 - - subroutine MPI_ALLGATHER6(tmplc,num,MPI_INTEGER,& - tmpgl,num1,MPI_INTEGER2,MPI_COMM_WORLD,ierr) - integer, dimension(:,:) :: tmplc,tmpgl - tmpgl = tmplc - end subroutine MPI_ALLGATHER6 - - subroutine MPI_CART_CREATE(comm,num1,dims,period,tt, & - comm_2d,ierr) - integer :: comm,comm_2d - integer, dimension(:) :: dims - logical, dimension(:) :: period - logical :: tt - - comm_2d = 1 - - end subroutine MPI_CART_CREATE - - subroutine MPI_CART_COORDS(comm_2d,myrank,num,local,ierr) - integer :: comm_2d - integer, dimension(:) :: local - - local = 0 - end subroutine MPI_CART_COORDS - - subroutine MPI_CART_SUB(comm_2d,remaindims,col_comm,ierr) - integer :: comm_2d,col_comm - logical, dimension(:) :: remaindims - - col_comm = 1 - end subroutine MPI_CART_SUB - - !mpi alltoallv1 command - subroutine MPI_ALLTOALLV1(sendbuf,sendcount,senddisp,MPI_DOUBLE_COMPLEX,& - recvbuf,recvcount,recvdisp,MPI_DOUBLE_COMPLEX2,comm,ierr) - double complex, dimension(:) :: sendbuf,recvbuf - integer, dimension(:) :: sendcount,recvcount,senddisp,recvdisp - integer :: comm - end subroutine MPI_ALLTOALLV1 - - subroutine MPI_ALLTOALLV2(sendbuf,sendcount,senddisp,MPI_DOUBLE_COMPLEX,& - recvbuf,recvcount,recvdisp,MPI_DOUBLE_COMPLEX2,comm,ierr) - double precision, dimension(:) :: sendbuf,recvbuf - integer, dimension(:) :: sendcount,recvcount,senddisp,recvdisp - integer :: comm - end subroutine MPI_ALLTOALLV2 - - subroutine MPI_ALLTOALLV3(sendbuf,sendcount,senddisp,MPI_DOUBLE_COMPLEX,& - recvbuf,recvcount,recvdisp,MPI_DOUBLE_COMPLEX2,comm,ierr) - integer, dimension(:) :: sendbuf,recvbuf - integer, dimension(:) :: sendcount,recvcount,senddisp,recvdisp - integer :: comm - end subroutine MPI_ALLTOALLV3 - - !mpi allgatherv command - subroutine MPI_ALLGATHERV1(rhoz,innz,MPI_DOUBLE_PRECISION,recvrhoz,& - ztable,zdisp,MPI_DOUBLE_PRECISION2,commrow,ierr) - double precision, dimension(:) :: rhoz,recvrhoz - integer, dimension(:) :: ztable,zdisp - integer :: commrow - - end subroutine MPI_ALLGATHERV1 - - subroutine MPI_ALLGATHERV2(rhoz,innz,MPI_INTEGER,recvrhoz,& - ztable,zdisp,MPI_INTEGER2,commrow,ierr) - integer, dimension(:) :: rhoz,recvrhoz - integer, dimension(:) :: ztable,zdisp - integer :: commrow - - end subroutine MPI_ALLGATHERV2 - - subroutine MPI_GET_COUNT(mpistat,mreal,nraysw,ierr) - integer :: mreal,nraysw,ierr - integer, dimension(:) :: mpistat - write(6,*)'(mpi_get_count) code should not get here' - write(6,*)'when running a serial job!!!!!!!!!!!!!!!' - call myexit - end subroutine MPI_GET_COUNT diff --git a/OpticsJan2020/MLI_light_optics/Includes/core.inc b/OpticsJan2020/MLI_light_optics/Includes/core.inc deleted file mode 100644 index f7b2dcb..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/core.inc +++ /dev/null @@ -1,10 +0,0 @@ -c maxlum = maximum number of lumps in /core/ - parameter (maxlum=20) -c storage for lumps -c common/core/thl(monoms,maxlum),tmhl(6,6,maxlum), -c # dfl(6,monoms,maxlum),rdfl(3,monom1+1,maxlum), -c # rrjacl(3,3,monom2+1,maxlum),inuse(maxlum) -c storage for lumps - common/core/thl(monoms,maxlum),tmhl(6,6,maxlum), - # dfl(6,monoms,maxlum),rdfl(3,monoms,maxlum), - # rrjacl(3,3,monoms,maxlum),inuse(maxlum) diff --git a/OpticsJan2020/MLI_light_optics/Includes/core_old.inc b/OpticsJan2020/MLI_light_optics/Includes/core_old.inc deleted file mode 100644 index bd5b0be..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/core_old.inc +++ /dev/null @@ -1,6 +0,0 @@ -c maxlum = maximum number of lumps in /core/ - parameter (maxlum=20) -c storage for lumps - common/core/thl(monoms,maxlum),tmhl(6,6,maxlum), - # dfl(6,monom1,maxlum),rdfl(3,monom1+1,maxlum), - # rrjacl(3,3,monom2+1,maxlum),inuse(maxlum) diff --git a/OpticsJan2020/MLI_light_optics/Includes/deriv.inc b/OpticsJan2020/MLI_light_optics/Includes/deriv.inc deleted file mode 100755 index 042a362..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/deriv.inc +++ /dev/null @@ -1,8 +0,0 @@ -c additional characteristics of the current map: - double precision df,rjac,rdf,rrjac - common/deriv/ df(6,monoms) - common/rjacob/rjac(3,3,monoms) -c common/rderiv/rdf(3,84) -c common/rrjac/ rrjac(3,3,28) - common/rderiv/rdf(3,monoms) - common/rrjac/ rrjac(3,3,monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/dip.inc b/OpticsJan2020/MLI_light_optics/Includes/dip.inc deleted file mode 100755 index e4da8ab..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/dip.inc +++ /dev/null @@ -1,4 +0,0 @@ -c parameters for gendip - double precision By,za,zb,gap - common/dip/ By,za,zb,gap,s - diff --git a/OpticsJan2020/MLI_light_optics/Includes/dr.inc b/OpticsJan2020/MLI_light_optics/Includes/dr.inc deleted file mode 100755 index 464b22d..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/dr.inc +++ /dev/null @@ -1,2 +0,0 @@ - integer drexp - common /dr/drexp(0:3,monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/drl.inc b/OpticsJan2020/MLI_light_optics/Includes/drl.inc deleted file mode 100755 index 34cc4ed..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/drl.inc +++ /dev/null @@ -1,2 +0,0 @@ - character*7 dln - common /drl/dln(monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/ebdata.inc b/OpticsJan2020/MLI_light_optics/Includes/ebdata.inc deleted file mode 100644 index d0acecf..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/ebdata.inc +++ /dev/null @@ -1,32 +0,0 @@ -c maxm = maximum multipole order -c maxa = maximum number of points around cylinder axis -c maxz = maximum number of points along cylinder axis -c maxz2 = maximum number of points along cylinder axis, -c after making field "symmetric" -c maxk = maximum number of points along k (wave number) axis -c -c Notes: -c 1. The k axis will comprise nfilonK intervals---and thus a total of -c nfilonK+1 points. Hence, in order to use the subroutine filonarr, -c we must make nfilonK even. -c 2. We ought to make maxm a user-definable parameter; or, rather, have -c a variable 'maxnm' added to the harmonics common block to record -c the maximum harmonic desired by the user. -c -c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! - parameter(maxm=0) - parameter(maxa=601) - parameter(maxz=2001) - parameter(maxz2=2*maxz-1) - parameter(maxk=2001) - parameter(nfilonA=500) - parameter(nfilonK=1000) - parameter(nfilonZ=2001) - common/zv/zvec(maxz) - common/fittA/phin(maxa),aia(maxa),bia(maxa),cia(maxa),maxna - common/fittZ/zn(maxz2),aiz(maxz2),biz(maxz2),ciz(maxz2),maxnz - common/harmonics/frfourier(2,0:maxm,maxz), & - & fphifourier(2,0:maxm,maxz), & - & fzfourier(2,0:maxm,maxz) - common/harmonics2/harm1(2,0:maxm,maxz2),harm2(2,0:maxm,maxz2) - common/edata/Ez0j(0:3,maxz2),Er0j(0:2,maxz2) diff --git a/OpticsJan2020/MLI_light_optics/Includes/expon.inc b/OpticsJan2020/MLI_light_optics/Includes/expon.inc deleted file mode 100755 index e98c006..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/expon.inc +++ /dev/null @@ -1,7 +0,0 @@ -c expon = table of exponents - integer expon(6,0:monoms) - common/expon/expon - integer nxp135(monoms),nxp246(monoms) -cryne Nov 6, 2003: added nxp13 - integer nxp13(monoms),nxp24(monoms),nxp5(monoms),nxp6(monoms) - common/expsum/nxp135,nxp246,nxp13,nxp24,nxp5,nxp6 diff --git a/OpticsJan2020/MLI_light_optics/Includes/extalk.inc b/OpticsJan2020/MLI_light_optics/Includes/extalk.inc deleted file mode 100755 index e06e84f..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/extalk.inc +++ /dev/null @@ -1 +0,0 @@ - common/extalk/fa(monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/files.inc b/OpticsJan2020/MLI_light_optics/Includes/files.inc deleted file mode 100755 index 59a6de2..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/files.inc +++ /dev/null @@ -1,8 +0,0 @@ -c files: lf = master input file -c jif = terminal input unit number -c jof = terminal output unit number -c jodf= general output disk file unit number -c ibrief = flag to control output level -c iquiet = flag to suppress output from within procedures - integer lf,icf,jfcf,mpi,mpo,jif,jof,jodf,ibrief,iquiet - common/files/lf,icf,jfcf,mpi,mpo,jif,jof,jodf,ibrief,iquiet diff --git a/OpticsJan2020/MLI_light_optics/Includes/fitbuf.inc b/OpticsJan2020/MLI_light_optics/Includes/fitbuf.inc deleted file mode 100755 index d501219..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/fitbuf.inc +++ /dev/null @@ -1,6 +0,0 @@ -c------------------------------------------------------------------- -c aim, fit and optimization parameters -c - parameter (maxf=100) - common/fitbuf/iter,ier,nfit,kfit,errtol,reach,fval,auxtol, - * aims(maxf),fvzero(maxf),partgt(maxf) diff --git a/OpticsJan2020/MLI_light_optics/Includes/fitdat.inc b/OpticsJan2020/MLI_light_optics/Includes/fitdat.inc deleted file mode 100755 index d4ee88f..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/fitdat.inc +++ /dev/null @@ -1,12 +0,0 @@ - common/fitdat/dz(4),tux,tuy,tus,cx,cy,qx,qy,hh,vv,tt,hv,ht,vt, - *ax,bx,gx,ay,by,gy,at,bt,gt,ex,ey,et,wex,wey,wet,fx,xb,xa,xu,xd, -c *fy,yb,ya,yu,yd,ft,tb,ta,tu,td -c AJD 6/5/93 - *fy,yb,ya,yu,yd,fte,teb,tea,teu,ted - dimension fitval(47) - equivalence (fitval,dz) -c Note: The quantities ft,ta,tb,tu,td have been changed to fte,tea,teb,teu,ted -c in order to avoid name conflicts with with various "ta" arrays in various -c analysis routines. However, these quantities are still referenced by the keys -c 'ft','tb','ta','tu','td' defined in the include file keyset.inc - AJD -c 6/5/93. diff --git a/OpticsJan2020/MLI_light_optics/Includes/frnt.inc b/OpticsJan2020/MLI_light_optics/Includes/frnt.inc deleted file mode 100755 index 8a1984a..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/frnt.inc +++ /dev/null @@ -1,3 +0,0 @@ -c table of parameters for cfbd fringe fields - common/frnt/ cfbgap, cfblk1, cfbtk1 - diff --git a/OpticsJan2020/MLI_light_optics/Includes/gronax.inc b/OpticsJan2020/MLI_light_optics/Includes/gronax.inc deleted file mode 100644 index bd9b852..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/gronax.inc +++ /dev/null @@ -1,4 +0,0 @@ -c gradients on axis ( for combined function everything ) -c gn : normal gradients ( sin(mTh) ) gs: skew gradients ( cos(mTh) ) - double precision gn(0:10,0:10), gs(0:10,0:10) - common/gronax/gn,gs diff --git a/OpticsJan2020/MLI_light_optics/Includes/hmflag.inc b/OpticsJan2020/MLI_light_optics/Includes/hmflag.inc deleted file mode 100755 index 90d3775..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/hmflag.inc +++ /dev/null @@ -1 +0,0 @@ - common/hmflag/iflag diff --git a/OpticsJan2020/MLI_light_optics/Includes/id.inc b/OpticsJan2020/MLI_light_optics/Includes/id.inc deleted file mode 100755 index 688277e..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/id.inc +++ /dev/null @@ -1,3 +0,0 @@ -c ident = identity - double precision ident(6,6) - common /id/ident diff --git a/OpticsJan2020/MLI_light_optics/Includes/impli.inc b/OpticsJan2020/MLI_light_optics/Includes/impli.inc deleted file mode 100755 index 5d03e89..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/impli.inc +++ /dev/null @@ -1 +0,0 @@ - implicit double precision (a-h,o-z) diff --git a/OpticsJan2020/MLI_light_optics/Includes/incmif.inc b/OpticsJan2020/MLI_light_optics/Includes/incmif.inc deleted file mode 100755 index 7fb1823..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/incmif.inc +++ /dev/null @@ -1,12 +0,0 @@ -c storage for #include function in main Marylie input file -c na1 = real menu count before the includes -c na2 = real menu count after the includes -c nb1 = real item count before the includes -c nb2 = real item count after the includes -c noble1 = real task count before the includes -c noble2 = real task count after the includes -c ninc = number of include files used -c MIF fragment include file names for #include - character*80 incfil - common/mifrag/incfil(32) - common/mainum/ninc,na1,na2,nb1,nb2,noble1,noble2 diff --git a/OpticsJan2020/MLI_light_optics/Includes/ind.inc b/OpticsJan2020/MLI_light_optics/Includes/ind.inc deleted file mode 100755 index daf9cda..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/ind.inc +++ /dev/null @@ -1 +0,0 @@ - common /ind/ imaxi,jv(monoms),index1(monoms),index2(monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/ind3.inc b/OpticsJan2020/MLI_light_optics/Includes/ind3.inc deleted file mode 100755 index 22436b8..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/ind3.inc +++ /dev/null @@ -1 +0,0 @@ - common /ind3/ jv3(84),ind31(84),ind32(84) diff --git a/OpticsJan2020/MLI_light_optics/Includes/infin.inc b/OpticsJan2020/MLI_light_optics/Includes/infin.inc deleted file mode 100755 index 6131696..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/infin.inc +++ /dev/null @@ -1,2 +0,0 @@ -c common block for storing various infinities - common/infin/xinf,yinf,tinf,ginf diff --git a/OpticsJan2020/MLI_light_optics/Includes/iprod.inc b/OpticsJan2020/MLI_light_optics/Includes/iprod.inc deleted file mode 100755 index 3ed0bde..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/iprod.inc +++ /dev/null @@ -1,3 +0,0 @@ -c Table of products - integer iprod(0:monom1,0:monom1) - common/iprod/iprod diff --git a/OpticsJan2020/MLI_light_optics/Includes/ja3.inc b/OpticsJan2020/MLI_light_optics/Includes/ja3.inc deleted file mode 100755 index b3a4a0b..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/ja3.inc +++ /dev/null @@ -1 +0,0 @@ - common /ja3/ ja3(3,84) diff --git a/OpticsJan2020/MLI_light_optics/Includes/keyset.inc b/OpticsJan2020/MLI_light_optics/Includes/keyset.inc deleted file mode 100755 index 91ccbe8..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/keyset.inc +++ /dev/null @@ -1,7 +0,0 @@ -c -c keyword data for aimset -c - parameter (nkeys=57,maxjlen=13) - common/keys/key(nkeys) - character*2 key - common/kasks/kask(nkeys),maxj(maxjlen) diff --git a/OpticsJan2020/MLI_light_optics/Includes/labpnt.inc b/OpticsJan2020/MLI_light_optics/Includes/labpnt.inc deleted file mode 100755 index 5460272..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/labpnt.inc +++ /dev/null @@ -1,5 +0,0 @@ -c labor pointers -c lp is the running index, pointing to the element in latt (labor) -c which is currently being treated -c /labpnt/ is also used in "procedures" to set up do loops in #labor - common/labpnt/lp,jbipnt,jbopnt,jicnt,jocnt,nitms,notms diff --git a/OpticsJan2020/MLI_light_optics/Includes/len.inc b/OpticsJan2020/MLI_light_optics/Includes/len.inc deleted file mode 100755 index d371f24..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/len.inc +++ /dev/null @@ -1 +0,0 @@ - common /len/ len(16) diff --git a/OpticsJan2020/MLI_light_optics/Includes/len3.inc b/OpticsJan2020/MLI_light_optics/Includes/len3.inc deleted file mode 100755 index 36e5b66..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/len3.inc +++ /dev/null @@ -1 +0,0 @@ - common /len3/ len3(16) diff --git a/OpticsJan2020/MLI_light_optics/Includes/lims.inc b/OpticsJan2020/MLI_light_optics/Includes/lims.inc deleted file mode 100755 index 6eb2415..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/lims.inc +++ /dev/null @@ -1,3 +0,0 @@ -c bottom, top = lowest and highest monomial number for each order - integer bottom(0:12),top(0:12) - common/lims/bottom,top diff --git a/OpticsJan2020/MLI_light_optics/Includes/linbuf.inc b/OpticsJan2020/MLI_light_optics/Includes/linbuf.inc deleted file mode 100755 index 57ee727..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/linbuf.inc +++ /dev/null @@ -1,7 +0,0 @@ - parameter (maxel=400) - common/linbuf/nbgn,nend,npsu,npst,mltyp1(maxel),mltyp2(maxel) - * ,lintyp(maxel),elong(maxel),strong(maxel),pssext(maxel) - * ,psoctu(maxel),radius(maxel),aap(maxel),bbp(maxel),ccp(maxel) - * ,ddp(maxel),eep(maxel),ffp(maxel) - character*8 cname - common/liname/cname(maxel) diff --git a/OpticsJan2020/MLI_light_optics/Includes/loop.inc b/OpticsJan2020/MLI_light_optics/Includes/loop.inc deleted file mode 100755 index 3adf841..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/loop.inc +++ /dev/null @@ -1,5 +0,0 @@ -c mim(i) points to entities (lumps, elements, user routines, etc.) in a loop -c joy is the number of things in mim -c nloop is the index of the actual loop in /items/ - parameter (joymax=1000) - common/loop/mim(joymax),joy,nloop diff --git a/OpticsJan2020/MLI_light_optics/Includes/map.inc b/OpticsJan2020/MLI_light_optics/Includes/map.inc deleted file mode 100755 index 5872a1e..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/map.inc +++ /dev/null @@ -1,3 +0,0 @@ -c total transfer map - real*8 th ,tmh ,reftraj , arclen - common/map/th(monoms),tmh(6,6),reftraj(6), arclen diff --git a/OpticsJan2020/MLI_light_optics/Includes/maxcat.inc b/OpticsJan2020/MLI_light_optics/Includes/maxcat.inc deleted file mode 100755 index 70d3ce1..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/maxcat.inc +++ /dev/null @@ -1,5 +0,0 @@ -c ordlib, toplib, ordcat, topcat -c = highest order & last monomial of library and concatenation - integer ordlib,toplib,ordcat,topcat - common/maxcat/ordcat,topcat - common/maxlib/ordlib,toplib diff --git a/OpticsJan2020/MLI_light_optics/Includes/merit.inc b/OpticsJan2020/MLI_light_optics/Includes/merit.inc deleted file mode 100755 index f48fe5e..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/merit.inc +++ /dev/null @@ -1,2 +0,0 @@ -c block common for storing value of merit function - common/merit/val(0:5) diff --git a/OpticsJan2020/MLI_light_optics/Includes/minvar.inc b/OpticsJan2020/MLI_light_optics/Includes/minvar.inc deleted file mode 100755 index d9c6ac0..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/minvar.inc +++ /dev/null @@ -1,5 +0,0 @@ - parameter ( maxdat = 1000) - parameter (maxv = 10, maxq = (maxv+1)*(maxv+2)/2 ) - common /minvar/ jtyp, modu, ntot, nomin, minpt, maxpt, fmin, fmax, - * regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), fdat(maxdat) - save /minvar/ diff --git a/OpticsJan2020/MLI_light_optics/Includes/mliinc.tar b/OpticsJan2020/MLI_light_optics/Includes/mliinc.tar deleted file mode 100644 index 101504ab801fb9e11b920745b77191b016b34837..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 112640 zcmeHQTXWkuvd*)A1(L0rk+X;?Qnw_h{NR~nce6XmY-K!WPwh*Jq9~a*MJgm^OZxTa zYXAf@du0OIX9HzA@>xgie z{KVdZ*-ql!x(x7OPu;|gVm1yVHgN+tvVAs>-4mJC38&LAFpwNc4co>y9}el;ap-$A zqHouw@9`MlCw26sspBCdV0+V%JAPXH?^&P)CH!yq8~lIBeBL*Y^Xl=Rlaz=Mc>q8$ zK$I7Fi5CWvgm?i+2(yC`3+JFK%n!p^eBvl_0sL=6Ryxa2d#ejntct> z&@^5W!LPnObbUj-(K+us2~U{bo{l_k_O$rl?_kX@;eV&y;C~%p@ksm^sDClCXM%J1 zIQJ88KJjd1Y`1e%4uO*DbEE@dENM>$Q|glPAZ$2JE9X5FKeeeI z1XV)!>l}p6cLT>|Eu^L1nl@J87LtmG>FFPu@HpYfjjLV$A|Fa)5a_uGl=zOVc-UdcuKBZa0W4L*FOZac>?ahcd_ojVaakPGk6sL z7IEe|i3BMpXV&@9wWpkQ&RySCaouy@3tYVHo%{3YEav@lAp+pYJ2=M9h&hU~X`z_|Ev7Udm_22_Yu{3JcKix8l5koS=s8}pJVRmc zZvlgI+xM54V?YpXB+&{#aawP95Y4c=LUB}wi+<0+>;jP9F!LR=qsU&yDRY{QVJq+g z0q^H;(j`N`Y{?SO2YNN3v4mhehRA4U0OTh+dz#tFNs}l68coH&5@cA8SPl?bD+m+! zEyE5~^^5vKK(E?P#l1B9r+|7ozhLiNKrV0)CoO7W&)1iv61S`sW}iw_i=k>hy5Kpn zQ5ZF}6TLkT=F=ff)0n-8T-$%aS^||24L097%^e+31}C4PP^TV40!I2I1UWXQ#g609 z@$3YUdFKJ~H7*f6rm#xbEL*8sj!AMSXc*dvojv|Y*f1(~D?p`F18;J$fVBB1kt>T( zgE}y**M=BUNpoc30{n)yb8}}$qGdAx>(KK7itNr{VdPCbh(OT4k9M^D#dFbUBBQyk z*FoR+)qx=$KJohBZgg9p$|u6OwQVU@)BN%;H~%%Nd^~lRq@`dz2CU zz6%kY*3s;~`ZMH_%QXPSQ(Q zOnM4nIH(EsZRlY!zp{e~+OFE<`-gfz`%Y zfY})|^1oWp|CwC>8Sn)={jm)(*vEf=_;T^fFMq$d{Kxyx|Epk@l1;#dwXeInc9~DtE+0Gm zhg?bN80+7{Ky}lG%dEZPV_%nZNIwqigiIxSAj7ixGTadjkm2sVYX9)t`%mw5jx8f7 z63MznP*yF1vStyyU&V*iOKD`a6q2=4NLEUr?*2)mWO9Ni)E6T~p@9y)*8M+ZzCL_@ z|MOmm7m3t}QF=9E6jUQd!2?<^3X;ti!TZ71Ax)(;vZWM~4W*E5CxyD4us~tQ4;mx# z0m2SS+Pl|Ket!S%_n+VEEL)&Yrb?SgInqW_IBh0{?+1aPT!%G4CzNf_kFpv1QMN=s zY8oLc(KJFn-ftd%`uXCw%YEY{63HftplqH9%BG265$0&#M6_(42=-}Wb!A1Aczyy- zC$S-@J9&Qc{3xH3=XpTN!dS`PvkUxTO{3+8{dW2LPrn_lQr*Gl)0u~*4ytdqpGr&9 zR>bpR1obxv!o`C3;nRo9mIsZIR5ZvK4bO&DC&l8CN=KAZ|BWP0-pbuyZkn=GcH+hm z$3m`pcppAo{PN+y@87k?zCGc^{-jbliq%c_!-?mB;ivREa!b!u*||ne{BVfO@qDWD z=Efl9Bovmn5=ihJj_--jv9l0F`rWU;|MbiIFaHLG`S9C^Uq9_8`fBnBw14~kqbT6# zUq62Q@}FNn|MITXUB=2v4V-CZsMgz4_Vz8ywMcgW(obq3l$XR?9lv2vG(j-4G1=OG z>&g3n%pO|@^te-dj}?elH_@E~y4`)MZXa`gy9ac%S9?cyVl+Q4PWKKNf&RBP0!JQ$ zel`Zr<7MDnML3LFk#K1`o#R+aDv)XtnWKGz`?&c0`NR9qElO>T*2r_Z9)S+a6uO)Z zr1mFSR<1qba1_T=I1tZvIi(he#o_bCr+>AmJ-MY~y8MD;-J7*Gsdy0o_O90Ga!*d4 z3;CI88P*$;*>zL?Lhv4RN{ds)ZE4Ej%*OKomwuprN6r1u<%f^&Tc=xdLsc+MMeRLn zZ%s+#xn6W`EQwD7J7kX>oEGbjmj+XCkY+0ykD+=%3%F!RKYY4;|M&NwDZ+xVY~xgy zJGxGwWvRMqDFLA~#KWM2nCQ)mumD7QZ5^fM)Se@>b@TG6+uC_hTeq%$M`-Zog-UeB$6gI zw-OciXf0Ue(;R!#=m_%*vuH|9;C=sM-L7j^&F~{ zX+Mp6y01^$tYmapwEq3e`~N#gLU-`sEB*?23hmxSVPBBn%kG;|(Idlud_bMBZq_59(nY-xxe?5 zhi}C;yy&d)&^xy@hjm&uea8|c5>&ee9n`mjNTO`)zTQ-_7H#ar!xtpclU*F2NKna| zw5unF&q8ix5}0&nLnUkn6GzO}e=cxzC#uIKm1G{T0sPkSl<9Y2Hdl_;-3*TcGjwv>8;%f7d}dZ9MM&>^UlNNpLHGMQQjqRoSH z;E<3?0|W_rgv*N&y)P56qp+V_x~qV+f?n?6v8j_~y7r(GS)kwM?a!9pmM6CW)*IHK zM^E)GqDZ4qrirzT!dAjmJb8X}=W|qb6PRz|_m9MbJOlzZGL(-V2HGTOe3y*cK_pOW zd{s&Vr?IzwKvqVQb=t5&I3OFF>u7n#MS@Bw+s008rEA;TzJpwerf;EFN7?sm?17qw z$81q$!}m?f78>+KJ==(b+a_%Xg%N$Pmc;Cuw#V*SW%Ktu0woOz{ zs30id#1?macd*!k3sgGFkEVe_wJJM1F0ZoIF-53S(@Ycmd+2qk-e&A_nTE;)Wg=Sc z&3;K)CBw14OdNQsH1QukSi4SFgkEkBgN*_KIC8ghylWW{e!lp8`Q_)& z?=LRj3w2Y;VnW?N<}=tr2}eAEt)M-}#>51FSyNP1kWD~O351FxQfcJg3i(vKPNnWy z6oyC0xn%Ro=>&=;83|BL6Ut9I?FJq{Hx60m++c}G6l3-4ubwvQcnA5--Y1zcMR@wq%tGy=%a*Ln0!j@2YvKu1x5*15~oE zWG$mO(XzCOxmhaBrGA4fISx=uXRA@|w^qXlzI!al(b>g7X;0{4yB-8zT+U`9P zpL~<|99Is4re z%-uxu0A>ea<`A}NBHScq*Ws{qJvyHqI_5r`E@7r7yGgSF@boAZEXg=9=2NlxCt?4! zzr+92z*@8a4wEsB{nt7yz&PYF0Y+KDOd{Y-5du%Hj64cst+)%$V52B<4F$3}!$&gj zxdp37FiQ!;Q1*n(g2KZKnR!*V9f{PyDyAqRx$>1^X>!DXRHxXTB94qQrx7w+!Kn0T zOi54*EK=)q5yf_7toc_{$8X3VMc1}NiB)ndm)r|r*^1mPP-`}JL+bb5yBi|g{koBL zPL6dUcexW;;$j!>1vWG*UtlYLBNAGmIEodz&4dot(pSN45ZS_cxv`WC7{gV z(4e1enHC1!37gYIvKZ8XG_Sj~TIb(VW`l{^MH$xXawYlvlA9=}D3_6@s$(vmqK;A3 z&fgBee-n#+5&zA;)%bs`1st55L2|*l!>towLSgTkMI-jplCNyO8uE#)6Qwxr&5Xi( z9-kEUnzeMOspMWGFsj)16E$Yv`VX_OW&H0p>;Ju`@xh730xGPtlI@dGBEMqp{}B8y`+qZ={eMkhBJp1{{x1h?~*C2mQb5ln(?vR`;RZ9Yd{EvA2w$+D)eDDKizdwM_clojU{XXo!x6J_@L0T4Q zfoWMV3D4Sf48R-*MiFDr$g0||`fSI6cU0TimF7EqC**%qmJ|O^$%!+$H-ir&?3b~} zhHTu1p8>KF2Vf?KYbJl`=Bo~z-v z;zqoa&gsB7%_0w8uLIbv3xj_N?ka*yhxpa2SLDVjxte3lU?7SNSA}EMbd~zACX=HI z4|V?_zm(+4Oil%vl)_nsaFmfdF&4GJl|(uQcW`qDsHXmBZ6Ft7PQC#SlJ!{|D7`1|JzXxa5r7a;PTT?AFEsB_;k5Wdze7 zm0LdLIpYc*w}dk>CBRY6MDP~p*MKfn3_1Qlc5(QWW?^tk=|%7xGF*!OQrpn}6Y^KS zc=i0%D-!{P@Ue8LqeERC>giBlhX${nt0hjKWzhl9^jv%ID8$?6{kC=}UU;*@(bu+D z*17c(g|1$0&U&*Ys|16KbNIqcWm8#|3PuW!M#^vhTPRrV%~!X^>eh9rm#ef`^@^PQ zT^O?~4+}gH{gm4tT&9Z9P>0}>O~v6&U>6t!gG%_Xu@d=L78S4(6(Kmxf=(8sGFHVh z(s_@KaWoF+5j5#q7TiH2>6A|PR&d<6<+Ih8{1~0OS6SOjT5T?8OCKzQx?>hQfYG2> zs~lS_!=>fec)x02%l#I5j*Rak@ob5au#UO?!p1HPs$Kr~?*F@;KKB2Ep4A_i0}HYM ztp8>s|Eq0DpZnHAt{Fd0tQ37Oh4vAQ%i4}O71%X zWLo>F{lE4*J?#HG9XNmMTOE=Q!2f%r|8w7|d{BA^`(r@BTjr0&mRmS{m!690h1#Kk zN?d!C0Q+hfn8&tNCV@%*MD31qDZxVIQo`pA`90o}bTmGPPHf;tv=x>qq3wMmTD3Wk zH^kk>Fn`QFXUwn1_=1`*{z8sn;nyMkLGeL0jms*F%#j#n!?3;fx$otfbctEvSHOP$7qo zVk9salU!q6Isy1JpkE)+9S;r(NWyRE3r?ky(8skh+qvRnh}XD1Ur>xJ`z5s`7R8?8 z^~#Mx^?*u~Ng^Nq1RVZuu)s({;_#&SZ^GT{I{r8E|J@UJq_=XF%tV0z24l2pb)lC( zU*KF_S6BS@mTos+-SVr1-zF)-*$X~g@X3PPOFmrk$&%wH&M@H< z;Oc_AOYSE84xu{)?+_j@_+rQxHeby7Vw6g+Uyhf2Ipj;5FXwzY;^TxTL!Q`Z2Tw)} zwC3WU?^xgH8E;@>k3Q=;T%Ned<06xbTyA=IT6<$70!2QSyMvV6zzem97!tU%mVC=c z5S2<<|63vChokBsfvzN6LsP3zIw}#Z%3M`T-_elqhe$*1pf*rjWILRKFkiZx4j^SG zCT8q=4h~a@6_H;gTn}+n@FKBa;EaWCGg0<58f~+|iY;S!!&aUJV>&bl@4x{;P!F*> z4hwRPwuRqr54VLPcZ@qo=&P2m-?&RUviWhG{K$VyhV*6A*POmaKSCUjV*w;b{Uoke zezql>MtNO9L)a^t9h4*I=j=~UUXO&O)fF?2f{LmCe*F)#W0vWE8&|>_{;#@e*Cjid z*jF=SAaA(B<&1}L;uYZt6<50G3^f%8r`p&AItC?!Dk!I4|Hc%*$qhVX=^C2Aw>$z9 zIM}ln)$@P5?tgV~*keLS+!^$76$E!dO{>$f8vL&VZX7m=?2$*OJq&IDNppj>B>sof zp;+>@BR^s*mLw;cFmd%_60o-{2%{-vH(4ny7SmDk<<%)WWo!b`Qhejy6%sfhHfAD$ z+6S&(Cz%8|{xsV-YBJk6`JKeMN0mqMtP+5YNx&y@Lv-#9GFMX)qg9XpgB|z3+d%fR z{HMA9eebD!P=><(PXdGC3E$igDz3@&osEE3>CJCB82iqDO%uAH1^KT@S3(>9zXn*s zIf*x-%bn-)*Grb$)?|^6EH$Ju6S)F2!yDm0%4n9~8Yb+>Rd{fN=2g4=@74cm_tw^b zD2O-sf8?p&Se#t{1r#_qv{_@sTlT9f9=?JkbYu1=@;e^^2y&<1)1LpD?Jntm_PQ_x zF~EPZ|F?P#{?`FoLQf)Zx#=%jv_B7=#Dh!#B7d@U%0Ai=E_jgapY%C0?U2AW!99@0 zH8ypFImCmoe8z?@goyI4f+|tjg9>cA+)++0uWaOw7Shy1T{zBwr+W(@>cVr$w-z4a z>Vhsmv7vXeukn;aSCPxHwF-0|-OcW>=;0-`8@h6#Zb5wf@Ha?X?Foi3DITxT`H&RJ zrgM`@K%h@tpgjS>y{s?~wwcwxIovr3Avc+WA3_=AswA%2JW z6+5m3{?jh=f3W}2$bV~rhde>RPA(W3%!4Y9$FFa-UOipv zTbRX1D}8KeLoM@ERVA3)PSpfppZurYFYEuAgGT;a)r=R*UBmy5!LDyREm+rr{pL}} z)FF#P4Yn7D@4J8UpiueL_y0_6_DcId6C|OL|JDFqj?(5(SF=g+gLZ>-#+&My2@nx# zZ^i9{h&LAa;Y<2T=xc(nhDg*faYw4c!~1nL*!&aatX{?$eelp2OeWr*(v{dbP|xApScuAKeffBu8} ze?|N^dyW2AJ#bRw{{anP|Lu-4uUk(Onp&Q41Tx+I>Kd_c{kOVw|F;YCAFu*Kwm_i& ziDRIK|F3RJbjh%A3!4(6B`*`5))pLBK3O*UQA3kYD&djqmWbB*gV=VqsLsz3=0 ze6>VU{ZgM*SX5ncCvk(57v#aW$|Ops8+uelBXrQSb^L&D4`)^10NIEC9WeXF^&j>> zn*IOrCwoJQ4g&;W(=Tk!xe=YZ`ZES4a5{=j9Z`t`04~#zWI&mBbA4BxR-%w3VJ%S< zsfOQOdCnD;qFe{~OPmLboH+NT`*;pBB;?_^0k-h`SXj0b*UMgHm+)UuO&~;UK7(co z{A7kRaRcrzqM{-VQN{T)em(R6()bC*kLS=sNZ+tl0RKU7!v#O78^+?#7zO%TwfO%4 z{=e-1%k1MyShN1u0FXugAJAYhe6>s{dDc*SQ^iw{04BR~0l>cXzrDWyA2jy=>Vb?k z{D%O5V4|S_^^E^h*WzQRS2Y8$5C5%pS^j6W;S#V}|7!pa?EZ&gl7ukYlY}#9D*7-V z0prnRz30lCz=Q-0Nt3lt@VkwJ1`CO1wIN&QR4N zNyBN>FwtA8fW`JFxBt~^uj_xqBv6C@TjuPT(Gq#J=?7tl%k|G;l1)qQq%N@p6eAeo zrgZ=xVLX5pUHXEzZ9iGgpdV;2T>n%)K|N4BNxXl_II<&An#Lsy{^>&u>wVeNERJE5 zww!$yhfXq2bI^_Txv=d;7238gcR18R$4P^_4Wm&S#a&ki$Ky1Z5-BaJe9atEzE0!y zKp@T#Z_;KSb4Kbdi)1QKz5bK1za;;oEkT3-HGl$qVR+M)cdDFDkiZQW5Tuc-mhj@u znUeFxTzH7kwx;kRan4TZeuyn(bCBv?hfAU;N`9E#dJtA4gzOI0AzeUlr_%}fB3T|M zp(AcI%)x7j1SpzJ|AAXjIG7_;s0uWu;0i(MB2ZR?x+RmGLi)GlqQ-{PD1#Jyx>k+; zd*y$`|C{Yzr)zd$0Y>@xIkpR+wR{Vf-zr1_^ zD>zDsa8Fdo4`9<01-OAQ|Eq{YDke~sV)svVsw(kBHOl(bVlDyH*qs7pPzowame?%x z2SUcwjl8N2K<<!$e%ou#3?DZcPmmkl9B|L0+AY97{NH5%A1Z;({=WuzkZWyjTTPxAp$CYQ02t%f zLcm-CyuTH1IVJsyAW6Y)|7xDTlmYA1uwWoEzlt+##|h4$Tns57GUBEIX92bz_{P~n zfGC)iz!Qq1pRtG=<0-W+4vP_!&>z7Mr8|LD3J$#>7f*6~N@=`N{LY;S7+Zb#Ti{CxfsI8*B3e>U+U{Lk5c?z9{I-+JI+ZT-j6>4csiO9ntJ$nljubMf5QtNNOmIGgg&+AH#s zWX~_gsKs|JvFWsvUhSHey>_ z?f8o9;6o7_UeIK?z~vZJOl*kKFaok{IS`zQj;ij#ptWcC{W?1hEHv(B@B5Z8-mJ?7!9m15*D3x*X^7HU~*?#odnd(ua~4r1BI2FR4;jQI;TH zks5{@H8i4@$vZ+N;$W{r*)KJ5-}>L_uC4!OWB=s{lY2lB(Ep~}T_oXWcY2Ng-$#x4p_zgI(73?)XdbsSL;`H2 z_8_xJl8zzEIdCh#ePD(JCWGN6biHM&2LBG7iYG}o8{S-1y!`K7|4IH=-2a<{M*p)O zaL6ODLBN2o^wI{$74C+UuV)^fsur5^FGJ_1N*b_t{co?`|L8*{q>=yC02KT1pMxCq z)qWqIKgFY1+y!gikcS$ksM0ECo?9jAi?;8>|8}oz{~h+<8vei1c~1)`{|`Z&*n#Hr z)x9eKhB5Q_%rjrNIrj21uVDq!LHh&!&c0TT{s-{?W%<9^1541X|24o_e*MP={wrKK zq|$xveNBT6>enz8Pg2D!a&NtGUghoum-pi+Tec;5aBQ_*MlAA7-p6{ zGSHmejz|F{wE}bE{OjYt-?EF*2&rHLg5I;1PK6lUo(LRx{)KS}*MTpoTfHcEISHLL>uAoR6z>X$!vhw~)z9qYmF)X>`P8j)zBi~V_qdi$1 z;%WK+cE5c72mEjD{~dRtx0F`Ee+dl6I9>!1$9H_g z$8em6aOfZ$`xgE>4XSS$%kME73Z9U>J}v%Rxa_;O{x|afTEI!-zuw`urVD^WS+kdf z^SCf?(=XkIm#Ih{2nL+9h*Lg<$R5w~{i!JX2Pq!-flusd_KKd&+~d$q?Ci0jFtyA* zRT6uXC-?u->8`K;jsKT=K%j*G!j|JKIfvqJfisX`Vgzu}44*Ga%oht7ZM5lYMqkS% zJ<`{VzE&%Gq%T>_OE#kil+tc>dH0k;V;LGDn1w7ET&=_%16XiO^Dh=@jIBd69a=8+ zTOFFEp@y35041E|IANuy|NHO%S?#j^56=G@`TvetJKn2J_`kxvxylyGrgcD^um~dELo!>3+x8y6EFmMHqK%g!HDdsu?OA!&L0Y_ja#i+nZgQCZq(fgGY zhZS%B(VTtqKRW-1{!g!C^-cUkdg%W)=l}Pc$Oon_=>G`o?;%ugLN7hlTeBhf_AMK( z+T8JZ;`5QG*o4$P0N#4xEGbzToWj4mZxr%znXEzl2hQ8Evc**!|3E|c;Xlkim-heA z|83-d$C~1u<;e9vMc+7b7peQF)OcSU86p}E9xQoN9~wP7%WPhLKO+!FPrv@J%m2-O zWB;Qb7*e}@ZP2&RV!!CfjRF0A1F_9zfO@8+)>?4&tJ=%I=*^z>pIkqb)_=?FH}=13 zfdkn85Fh~cU+mw#>3qsY?hO7Oq53OcCwU&7BUNolZYsu z44Wff{GcqjWm9RCH(8|dgj>l}?-+?*peXvIkNAbrK`+6*gb1<+WSEu;Rjy)VKNPCU zC=ZFQ%cZI!MS=Lj|5C9570|jlMRQ9f-k>bmv#izRU6v9fb>z-m@|6q67h~jv;xsz3 zF%K0YYan+Qo0G|YYqpCJ6Q&p;Z=qgubdHPub99i)Cd-*P<)TUILCsgb7=tliG@z73 z6MeHU6EtjHEjafrRRXw3s=fWSm;SfA*82UA#{Nq^P~s4M0|W?%oo*C?hS7z9n8>s1 zO}c$@17wRhq5VBvGK!YTy-6Q_E^s3xa-m1ShD4+3Ej)vZS7Q&Zyy!hdLT7k)fjcA0 zr(hdi1>td+x$qpc6yCw9qVPthx3h$%Oo-gc73|WZU>BamP>S#-F4}@NQ+@1?{Pv8) zIVzOSg~G9PDLxN8@?+|F?VA7o3XZ zFbn}eMm#pt?IDlHRxaGpVVUnQlFd=y@wlts$K#$3Z%jKir3dkNYNdgW3~Wx`O;hzm zK(%}1p+~}5Sv^Poe9|`v|L)?$@~oQX_7&wvZS-Gm)-^ggl;Vvy;Vv z02k!A62Y@+<8 z!;rvWV6l8`u}%K(WCY^nwCd|$`{X}h4|-+!Pa7s-oAtj27{dMU>nTJTSeqhm!Tzb3 z#1Bri}V7(V_Z)gYEi>PRa8Y{`<2>$q-O8q|4q|c!~b@p|5ee97mJ0w^v;Ht z7i_+13y*#CS>T?viPd+(`^FJ`RE`!b^UK#32)Z_8eqtQTnwMzutBvaBt47Rr2q-og>=Vb&+)MRhcqymGMo}z%p$Vk zWHQ!?AQB)~FKKcpjzFGAMTJsRc1BD)HMRP zL*I*^82@qdS6=@+js9mn5CHC9f&l4iku^usO-e00;y~VU=I{?bA(bg{p5@uT;_FkL zahV;`!7cV4<$FW^G~}b6X+5}>Ti2O|HQ;|A23^~2tB;F?kO!K5ob=;ae$1{o|8I8& zNCn4lIREc7_rDIF!bc^P>;Ia#|6+mb9`XPiC*Bv!!qX~yD(>+COpqhYjEe>3!QZOE z_eaf6^_dr-^~-A6|Go16Zh!6k4;R3j{eShd|LmFb>KGp>M3l5da}Q7?AA8WegG>+t zL`5m`dgS)v_S{^%Xf7bqfR10QbIOB}_<4&ZkqlXMW4^&KrpfCGVMjOzBpp0&P*dp`4w*f#Opb7`LRZ9UJmhTGk(lsIA;6d}{q4 z)7-%SH~arO(EnM<{90r zCi&kk{=bXOKJYTTNVlyNgNTYHO z{m{9Q>Ern@LhT;PL=t-(g=gbG(#pRP9Gb{x1ey_OMxYsiW(1lMXhxtJfo24n5okuB z8G&X5nh|J5pc#Q?1ey_OMxYsiW(1lMXhxtJfo24n5okuB8G&X5nh|J5pc#ShYy|!v D?MHi% diff --git a/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs.inc b/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs.inc deleted file mode 100755 index e39f94c..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs.inc +++ /dev/null @@ -1,12 +0,0 @@ -!R. Ryne Jan 5, 2005 -!This is the file mpi_stubs.inc -! -!For the serial version of ML/I, the file copy_of_stubs.inc -!needs to be renamed mpi_stubs.inc -! -!For the parallel version of ML/I, the file mpi_stubs.inc -!needs to contain just one line of code with the word "contains" -!Here it is: -! -contains -! diff --git a/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs_placeholder.inc b/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs_placeholder.inc deleted file mode 100755 index e39f94c..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/mpi_stubs_placeholder.inc +++ /dev/null @@ -1,12 +0,0 @@ -!R. Ryne Jan 5, 2005 -!This is the file mpi_stubs.inc -! -!For the serial version of ML/I, the file copy_of_stubs.inc -!needs to be renamed mpi_stubs.inc -! -!For the parallel version of ML/I, the file mpi_stubs.inc -!needs to contain just one line of code with the word "contains" -!Here it is: -! -contains -! diff --git a/OpticsJan2020/MLI_light_optics/Includes/multipole.inc b/OpticsJan2020/MLI_light_optics/Includes/multipole.inc deleted file mode 100644 index d04a97b..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/multipole.inc +++ /dev/null @@ -1,14 +0,0 @@ - parameter (maxcoils = 100, maxshape = 6 ) - double precision acoil(maxcoils), alcoil(maxcoils) - double precision zcoil(maxcoils), shape(maxcoils,maxshape) - double precision glprod(maxcoils) - integer itype(maxcoils) - integer ncoil, mcoil(maxcoils) - double precision ashield, permshield - common/coils/mcoil, acoil, alcoil, zcoil, shape, glprod, itype - common/coiln/ztotal, ncoil - common/shield/ashield, permshield, shflag - double precision xldr - common/ldr/ xldr - common/coilbl/lblcoil(maxcoils) - character*8 lblcoil diff --git a/OpticsJan2020/MLI_light_optics/Includes/nlsvar.inc b/OpticsJan2020/MLI_light_optics/Includes/nlsvar.inc deleted file mode 100755 index b473a6e..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/nlsvar.inc +++ /dev/null @@ -1,6 +0,0 @@ - parameter (maxdat = 1000) - parameter (maxv = 10, maxf = 15, maxq = maxv+1 ) - common /nlsvar/ modu, ntot, nomin, minpt, maxpt, nlsi, fmin, - * fmax, regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), - * fdat(maxf,maxdat), fmdat(maxdat), fvmin(maxf), xcen(maxv) - save /nlsvar/ diff --git a/OpticsJan2020/MLI_light_optics/Includes/nnprint.inc b/OpticsJan2020/MLI_light_optics/Includes/nnprint.inc deleted file mode 100644 index 99d4037..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/nnprint.inc +++ /dev/null @@ -1 +0,0 @@ - common/nnprint/nnprint,lun diff --git a/OpticsJan2020/MLI_light_optics/Includes/nturn.inc b/OpticsJan2020/MLI_light_optics/Includes/nturn.inc deleted file mode 100755 index eadb455..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/nturn.inc +++ /dev/null @@ -1,2 +0,0 @@ - common/nnturn/ nturn -c Turn number in cqlate diff --git a/OpticsJan2020/MLI_light_optics/Includes/order.inc b/OpticsJan2020/MLI_light_optics/Includes/order.inc deleted file mode 100755 index 4022c58..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/order.inc +++ /dev/null @@ -1,3 +0,0 @@ -c order = order of each monomial - integer order(monoms) - common/order/order diff --git a/OpticsJan2020/MLI_light_optics/Includes/param.inc b/OpticsJan2020/MLI_light_optics/Includes/param.inc deleted file mode 100755 index 0618092..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/param.inc +++ /dev/null @@ -1,6 +0,0 @@ -c monoms = number of monomials used -c monom1 = number of monomials one order less; monom2 two order less - integer monoms,monom1,monom2 - parameter (monoms=923) - parameter (monom1=461) - parameter (monom2=209) diff --git a/OpticsJan2020/MLI_light_optics/Includes/parset.inc b/OpticsJan2020/MLI_light_optics/Includes/parset.inc deleted file mode 100755 index 2f16a9e..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/parset.inc +++ /dev/null @@ -1,3 +0,0 @@ -c maxpst = number of parameter sets - parameter (maxpst=9) - common /parset/ pst(6,maxpst) diff --git a/OpticsJan2020/MLI_light_optics/Includes/pbkh.inc b/OpticsJan2020/MLI_light_optics/Includes/pbkh.inc deleted file mode 100755 index 318db48..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/pbkh.inc +++ /dev/null @@ -1 +0,0 @@ - common/pbkh/pbh(monoms,12) diff --git a/OpticsJan2020/MLI_light_optics/Includes/pbkh_bck.inc b/OpticsJan2020/MLI_light_optics/Includes/pbkh_bck.inc deleted file mode 100755 index 9f3b08f..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/pbkh_bck.inc +++ /dev/null @@ -1 +0,0 @@ - common/pbkh/pbh(monoms,12),pbh6(monoms,6),pbh6t(6,monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/pie.inc b/OpticsJan2020/MLI_light_optics/Includes/pie.inc deleted file mode 100755 index 2cda659..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/pie.inc +++ /dev/null @@ -1,2 +0,0 @@ -c constants - common/pie/pi,pi180,twopi diff --git a/OpticsJan2020/MLI_light_optics/Includes/pq.inc b/OpticsJan2020/MLI_light_optics/Includes/pq.inc deleted file mode 100755 index a55f3a6..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/pq.inc +++ /dev/null @@ -1 +0,0 @@ - common /pq/ip(monoms),iq(monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/previous.inc b/OpticsJan2020/MLI_light_optics/Includes/previous.inc deleted file mode 100755 index 6e0657d..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/previous.inc +++ /dev/null @@ -1,3 +0,0 @@ -c parameters associated with the previous element -cKMP: Added refprev (previous reference trajectory) - 6 Nov 2006 - common/previous/refprev(6),prevlen,rhoprev,nt2prev diff --git a/OpticsJan2020/MLI_light_optics/Includes/prodex.inc b/OpticsJan2020/MLI_light_optics/Includes/prodex.inc deleted file mode 100755 index 6317ee6..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/prodex.inc +++ /dev/null @@ -1,3 +0,0 @@ -c prodex = index for product of argument-index and single variable - integer prodex(6,0:monoms) - common/prodex/prodex diff --git a/OpticsJan2020/MLI_light_optics/Includes/psflag.inc b/OpticsJan2020/MLI_light_optics/Includes/psflag.inc deleted file mode 100755 index e919f4b..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/psflag.inc +++ /dev/null @@ -1,2 +0,0 @@ -c common block indicating whether a parameter set has been captured - common/psflag/icapt(maxpst) diff --git a/OpticsJan2020/MLI_light_optics/Includes/quadp.inc b/OpticsJan2020/MLI_light_optics/Includes/quadp.inc deleted file mode 100755 index 24cf7f6..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/quadp.inc +++ /dev/null @@ -1 +0,0 @@ - common/quadp3/g1,g2,g3,zz1,zz2,zz3,hw1,hw2,hw3,r1,r2 diff --git a/OpticsJan2020/MLI_light_optics/Includes/quadpn.inc b/OpticsJan2020/MLI_light_optics/Includes/quadpn.inc deleted file mode 100755 index 0344e14..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/quadpn.inc +++ /dev/null @@ -1 +0,0 @@ - common/quadpn/ga(6),wd(6),ra(6),rb(6),dr(6),di,nr(6),maxq,nqt,ncyc diff --git a/OpticsJan2020/MLI_light_optics/Includes/recmul.inc b/OpticsJan2020/MLI_light_optics/Includes/recmul.inc deleted file mode 100755 index e9e212f..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/recmul.inc +++ /dev/null @@ -1 +0,0 @@ - common/recmul/fsxnr,fsxsk,focnr,focsk,sl2,sl3 diff --git a/OpticsJan2020/MLI_light_optics/Includes/setref.inc b/OpticsJan2020/MLI_light_optics/Includes/setref.inc deleted file mode 100755 index 75992fb..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/setref.inc +++ /dev/null @@ -1,3 +0,0 @@ - parameter(mxref=9) - common/refdata/refsave(mxref,6),arcsave(mxref),brhosav(mxref) & - &,gamsav(mxref),gam1sav(mxref),betasav(mxref) diff --git a/OpticsJan2020/MLI_light_optics/Includes/sigbuf.inc b/OpticsJan2020/MLI_light_optics/Includes/sigbuf.inc deleted file mode 100755 index e5fa059..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/sigbuf.inc +++ /dev/null @@ -1,4 +0,0 @@ - parameter (maxpt=2) - common/sigbuf/nask,npts,xxin,axin,pxin,yyin,ayin,pyin,zzin,azin, - * pzin,sig0(4,4),sigf(4,4),dsig(4,4),dsig2(4,4),zz(maxpt), - * xx(maxpt),ax(maxpt),px(maxpt),yy(maxpt),ay(maxpt),py(maxpt) diff --git a/OpticsJan2020/MLI_light_optics/Includes/sincos.inc b/OpticsJan2020/MLI_light_optics/Includes/sincos.inc deleted file mode 100755 index ef06c36..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/sincos.inc +++ /dev/null @@ -1,4 +0,0 @@ - parameter (maxz=2000) - common/csrays/jp,npos,nang,mu,uwx,uwy,za(maxz),az(maxz), - * cx(maxz),sx(maxz),cy(maxz),sy(maxz) - diff --git a/OpticsJan2020/MLI_light_optics/Includes/sol.inc b/OpticsJan2020/MLI_light_optics/Includes/sol.inc deleted file mode 100755 index ec60bb1..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/sol.inc +++ /dev/null @@ -1,5 +0,0 @@ -c parameters for solenoid - double precision :: bz0,cl,tl,di - integer :: ioptr - common/mlsol/ bz0,cl,tl,di,ioptr - diff --git a/OpticsJan2020/MLI_light_optics/Includes/sr.inc b/OpticsJan2020/MLI_light_optics/Includes/sr.inc deleted file mode 100755 index 3f0a33b..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/sr.inc +++ /dev/null @@ -1,2 +0,0 @@ - integer srexp - common /sr/srexp(0:2,monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/srl.inc b/OpticsJan2020/MLI_light_optics/Includes/srl.inc deleted file mode 100755 index 5b27320..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/srl.inc +++ /dev/null @@ -1,2 +0,0 @@ - character*6 sln - common /srl/sln(monoms) diff --git a/OpticsJan2020/MLI_light_optics/Includes/stack.inc b/OpticsJan2020/MLI_light_optics/Includes/stack.inc deleted file mode 100755 index 95e1838..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/stack.inc +++ /dev/null @@ -1,13 +0,0 @@ -c mstack = maximum depth of stack - parameter (mstack=20) -c np = stack pointer -c ntype = type of top stack element -c ith = index of " " " in its array -c mtype = type of actual slot of ith -c jth = index of " " " " in its array -c nslot(k) = actual slot of kth stack element -c loop(k) = repetition factor of kth stack element -c lstac(k) = name of kth stack element - common /stack/ np,ntype,ith,mtype,jth,nslot(mstack),loop(mstack) - common /stac/ lstac(mstack) - character*16 lstac diff --git a/OpticsJan2020/MLI_light_optics/Includes/status.inc b/OpticsJan2020/MLI_light_optics/Includes/status.inc deleted file mode 100755 index 44b05d4..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/status.inc +++ /dev/null @@ -1,7 +0,0 @@ -c status and error flags -c ieig46 is a flag set by eig4 and eig6, and reset by -c eig4, eig6, fit, and opt. -c A value of 0 means everything is ok, and a value of 1 means -c that eigenvalues in eig4 or eig6 were found to be off the unit -c circle. - common /status/ imbad diff --git a/OpticsJan2020/MLI_light_optics/Includes/stmap.inc b/OpticsJan2020/MLI_light_optics/Includes/stmap.inc deleted file mode 100755 index 5896d2c..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/stmap.inc +++ /dev/null @@ -1,8 +0,0 @@ -! 12/15/2004: Original version commented out by RDR -! common/stmap/sf1(monoms),sf2(monoms),sf3(monoms), -! # sf4(monoms),sf5(monoms), -! # sm1(6,6),sm2(6,6),sm3(6,6), -! # sm4(6,6),sm5(6,6) -! dimension sfa(monoms,5), sma(6,6,5) -! equivalence (sfa,sf1), (sma,sm1) - common/stmap/storedpoly(monoms,20),storedmat(6,6,20) diff --git a/OpticsJan2020/MLI_light_optics/Includes/supres.inc b/OpticsJan2020/MLI_light_optics/Includes/supres.inc deleted file mode 100755 index 0da7a71..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/supres.inc +++ /dev/null @@ -1 +0,0 @@ - common/supres/it diff --git a/OpticsJan2020/MLI_light_optics/Includes/symp.inc b/OpticsJan2020/MLI_light_optics/Includes/symp.inc deleted file mode 100755 index 081b6c2..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/symp.inc +++ /dev/null @@ -1,3 +0,0 @@ -c jm = matrix J - double precision jm(6,6) - common/symp/jm diff --git a/OpticsJan2020/MLI_light_optics/Includes/talk.inc b/OpticsJan2020/MLI_light_optics/Includes/talk.inc deleted file mode 100755 index 90f8620..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/talk.inc +++ /dev/null @@ -1,2 +0,0 @@ -c jwarn is set to .ne.0 by evalsr, if ray is lost - common/talk/jwarn diff --git a/OpticsJan2020/MLI_light_optics/Includes/taylor.inc b/OpticsJan2020/MLI_light_optics/Includes/taylor.inc deleted file mode 100755 index 7da2cb9..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/taylor.inc +++ /dev/null @@ -1,5 +0,0 @@ -c -c Storage for Taylor coefficients -ctm 16 Apr 2001 3rd order Taylor expansion matrix -c - common/taylor/tumat(83,6) diff --git a/OpticsJan2020/MLI_light_optics/Includes/time.inc b/OpticsJan2020/MLI_light_optics/Includes/time.inc deleted file mode 100755 index 42e7c60..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/time.inc +++ /dev/null @@ -1,2 +0,0 @@ - real tstart - common /lietime/ tstart diff --git a/OpticsJan2020/MLI_light_optics/Includes/usrdat.inc b/OpticsJan2020/MLI_light_optics/Includes/usrdat.inc deleted file mode 100755 index f4f0bee..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/usrdat.inc +++ /dev/null @@ -1 +0,0 @@ - common/usrdat/nuvar,kusr,ucalc(250),wa(15) diff --git a/OpticsJan2020/MLI_light_optics/Includes/vblist.inc b/OpticsJan2020/MLI_light_optics/Includes/vblist.inc deleted file mode 100755 index dfc8b37..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/vblist.inc +++ /dev/null @@ -1,3 +0,0 @@ -c vblist = table of variables occuring in monomial - integer vblist(6,0:monoms) - common/vblist/vblist diff --git a/OpticsJan2020/MLI_light_optics/Includes/vecpot.inc b/OpticsJan2020/MLI_light_optics/Includes/vecpot.inc deleted file mode 100644 index 69d6dee..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/vecpot.inc +++ /dev/null @@ -1,2 +0,0 @@ - double precision Ax(0:monoms), Ay(0:monoms), Az(0:monoms) - common/vectorp/Ax, Ay, Az diff --git a/OpticsJan2020/MLI_light_optics/Includes/xvary.inc b/OpticsJan2020/MLI_light_optics/Includes/xvary.inc deleted file mode 100755 index f0662c4..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/xvary.inc +++ /dev/null @@ -1,8 +0,0 @@ -c--------------------------------------------------------------------- -c variable definitions -c - parameter (maxv=100) - common/xvary/nva(3),nda(3),ivar,jdep,mm(maxv,3),idx(maxv,3), - * idv(maxv,3),xbase(maxv,3),xslope(maxv,3) - character*12 varnam - common/vnames/varnam(maxv,3) diff --git a/OpticsJan2020/MLI_light_optics/Includes/zeroes.inc b/OpticsJan2020/MLI_light_optics/Includes/zeroes.inc deleted file mode 100755 index f1bfac7..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/zeroes.inc +++ /dev/null @@ -1,2 +0,0 @@ -c common block for storing various zeroes - common/zeroes/fzer,detz diff --git a/OpticsJan2020/MLI_light_optics/Includes/zz.inc b/OpticsJan2020/MLI_light_optics/Includes/zz.inc deleted file mode 100644 index 7e0bc21..0000000 --- a/OpticsJan2020/MLI_light_optics/Includes/zz.inc +++ /dev/null @@ -1,6 +0,0 @@ - double precision zinitial(6),zfinal(6) - common/zz/zinitial, zfinal -cryneneriwalstrom data zinitial/0.,0.,0.,0.,0.,0./ -cryne I commented this out because zinitial appears to be unused. -cryne To put it back, the data needs to be initialized in the -cryne block data subroutine in afro.f diff --git a/OpticsJan2020/MLI_light_optics/Makedir/makefile b/OpticsJan2020/MLI_light_optics/Makedir/makefile deleted file mode 100644 index f03f7ac..0000000 --- a/OpticsJan2020/MLI_light_optics/Makedir/makefile +++ /dev/null @@ -1,295 +0,0 @@ -VPATH=../Src - -.SUFFIXES: -.SUFFIXES: .o .f .f90 - - -# implicit compile rules -.f.o: - $(Fortran) $< - - -.f90.o: - $(FortranFree) $< - -Fortran = gfortran -c -I../Includes -FortranFree = gfortran -c -I../Includes -FortranMain = gfortran -o ../mli.x -I../Includes - -OBJS = afro_mod.o parallel_mod.o constants_mod.o liea_mod.o spch3d_mod.o \ - e_gengrad_mod.o gengrad_mod.o timer_mod.o multitrack_mod.o \ - curve_fit.o greenfn_mod.o \ - afro.o anal.o base.o bessjm.o book.o boundp3d.o \ - cfbdang.o cfqd.o coil.o comm.o cons.o \ - diagnostics.o dist.o dummy.o dumpin.o \ - ebcomp.o elem.o env.o euclid.o fftpkgq.o fparser.o \ - genm.o gensol.o hamdrift.o inpu.o integ.o iron.o \ - liea.o linpak_old.o myblas.o xerbla.o \ - magnet.o math.o meri.o mygenrec5.o opti.o \ - parameters.o proc.o pure.o rfgap.o \ - setbound.o sif.o spch2d.o spch3d.o sss.o trac.o \ - user.o user7.o usubs.o wakefld.o xtra_notgnu.o \ - spch3d_dummy.o spch3d_chombo_dummy.o mpi.o optics.o - -# explicit rule to build executable -../mli.x: $(OBJS) - $(FortranMain) $(OBJS) - -# other targets -.PHONY: clean -clean: - @\rm -f *.o *.mod *.d - - -# module dependencies -afro.o anal.o book.o boundp3d.o cfbdang.o cfqd.o coil.o comm.o diagnostics.o dist.o dumpin.o elem.o env.o gensol.o hamdrift.o inpu.o integ.o liea.o math.o mygenrec5.o proc.o rfgap.o setbound.o sif.o spch2d.o spch3d.o spch3d_essl.o trac.o user.o usubs.o wakefld.o : afro_mod.o - -ebcomp.o e_gengrad_mod.o : constants_mod.o - -afro.o ebcomp.o : e_gengrad_mod.o - -sif.o : fparser.o - -e_gengrad_mod.o : gengrad_mod.o - -afro.o anal.o base.o book.o cfbdang.o comm.o cons.o diagnostics.o dist.o dumpin.o elem.o env.o genm.o gensol.o hamdrift.o inpu.o liea.o math.o mygenrec5.o proc.o pure.o rfgap.o spch3d.o sss.o trac.o user.o user7.o usubs.o : liea_mod.o - -afro.o afro_mod.o anal.o book.o diagnostics.o dist.o dumpin.o env.o fftpkgq.o inpu.o pure.o rfgap.o sif.o spch3d.o spch3d_essl.o timer_mod.o : parallel_mod.o - -fparser.o sif.o : parameters.o - -afro.o spch3d.o : spch3d_mod.o - -afro.o diagnostics.o fftpkgq.o spch3d.o spch3d_essl.o trac.o : timer_mod.o - - -# include file dependencies -- use the following target to regenerate the dependencies -make.depends: - @grep -i '^[ \t]*include[ \t]' ../Src/*.f | grep -v 'mpif.h' | sort | uniq | awk '{sub("../Src/","");sub(".f:",".o:")gsub("'\''","");$$2=""; print $$1,"../Includes/" $$3}' - @grep -i '^[ \t]*include[ \t]' ../Src/*.f90 | grep -v 'mpif.h' | sort | uniq | awk '{sub("../Src/","");sub(".f90:",".o:")gsub("'\''","");$$2=""; print $$1,"../Includes/" $$3}' - -afro.o: ../Includes/codes.inc -afro.o: ../Includes/core.inc -afro.o: ../Includes/deriv.inc -afro.o: ../Includes/expon.inc -afro.o: ../Includes/files.inc -afro.o: ../Includes/fitbuf.inc -afro.o: ../Includes/frnt.inc -afro.o: ../Includes/impli.inc -afro.o: ../Includes/ind.inc -afro.o: ../Includes/infin.inc -afro.o: ../Includes/labpnt.inc -afro.o: ../Includes/lims.inc -afro.o: ../Includes/loop.inc -afro.o: ../Includes/map.inc -afro.o: ../Includes/maxcat.inc -afro.o: ../Includes/nturn.inc -afro.o: ../Includes/parset.inc -afro.o: ../Includes/pie.inc -afro.o: ../Includes/previous.inc -afro.o: ../Includes/setref.inc -afro.o: ../Includes/stack.inc -afro.o: ../Includes/talk.inc -afro.o: ../Includes/time.inc -afro.o: ../Includes/zeroes.inc -anal.o: ../Includes/buffer.inc -anal.o: ../Includes/codes.inc -anal.o: ../Includes/core.inc -anal.o: ../Includes/extalk.inc -anal.o: ../Includes/files.inc -anal.o: ../Includes/fitdat.inc -anal.o: ../Includes/hmflag.inc -anal.o: ../Includes/impli.inc -anal.o: ../Includes/loop.inc -anal.o: ../Includes/param.inc -anal.o: ../Includes/parset.inc -anal.o: ../Includes/pie.inc -anal.o: ../Includes/supres.inc -anal.o: ../Includes/usrdat.inc -book.o: ../Includes/dr.inc -book.o: ../Includes/drl.inc -book.o: ../Includes/expon.inc -book.o: ../Includes/files.inc -book.o: ../Includes/frnt.inc -book.o: ../Includes/id.inc -book.o: ../Includes/impli.inc -book.o: ../Includes/ind.inc -book.o: ../Includes/ind3.inc -book.o: ../Includes/iprod.inc -book.o: ../Includes/ja3.inc -book.o: ../Includes/len.inc -book.o: ../Includes/len3.inc -book.o: ../Includes/lims.inc -book.o: ../Includes/maxcat.inc -book.o: ../Includes/order.inc -book.o: ../Includes/pie.inc -book.o: ../Includes/pq.inc -book.o: ../Includes/prodex.inc -book.o: ../Includes/sr.inc -book.o: ../Includes/srl.inc -book.o: ../Includes/symp.inc -book.o: ../Includes/time.inc -book.o: ../Includes/vblist.inc -cfbdang.o: ../Includes/impli.inc -cfbdang.o: ../Includes/parset.inc -comm.o: ../Includes/expon.inc -comm.o: ../Includes/files.inc -comm.o: ../Includes/impli.inc -comm.o: ../Includes/lims.inc -comm.o: ../Includes/maxcat.inc -comm.o: ../Includes/param.inc -comm.o: ../Includes/stmap.inc -cons.o: ../Includes/impli.inc -cons.o: ../Includes/parset.inc -diagnostics.o: ../Includes/files.inc -diagnostics.o: ../Includes/impli.inc -diagnostics.o: ../Includes/map.inc -dist.o: ../Includes/buffer.inc -dist.o: ../Includes/files.inc -dist.o: ../Includes/impli.inc -dist.o: ../Includes/parset.inc -dumpin.o: ../Includes/codes.inc -dumpin.o: ../Includes/files.inc -dumpin.o: ../Includes/impli.inc -dumpin.o: ../Includes/incmif.inc -ebcomp.o: ../Includes/ebdata.inc -ebcomp.o: ../Includes/impli.inc -elem.o: ../Includes/files.inc -elem.o: ../Includes/impli.inc -elem.o: ../Includes/parset.inc -elem.o: ../Includes/pie.inc -elem.o: ../Includes/symp.inc -env.o: ../Includes/impli.inc -euclid.o: ../Includes/impli.inc -genm.o: ../Includes/hmflag.inc -genm.o: ../Includes/impli.inc -genm.o: ../Includes/lims.inc -gensol.o: ../Includes/combs.inc -gensol.o: ../Includes/files.inc -gensol.o: ../Includes/hmflag.inc -gensol.o: ../Includes/impli.inc -gensol.o: ../Includes/parset.inc -gensol.o: ../Includes/sol.inc -hamdrift.o: ../Includes/impli.inc -inpu.o: ../Includes/buffer.inc -inpu.o: ../Includes/codes.inc -inpu.o: ../Includes/core.inc -inpu.o: ../Includes/drl.inc -inpu.o: ../Includes/expon.inc -inpu.o: ../Includes/files.inc -inpu.o: ../Includes/impli.inc -inpu.o: ../Includes/incmif.inc -inpu.o: ../Includes/loop.inc -inpu.o: ../Includes/parset.inc -inpu.o: ../Includes/pbkh.inc -inpu.o: ../Includes/srl.inc -liea.o: ../Includes/expon.inc -liea.o: ../Includes/impli.inc -liea.o: ../Includes/ind.inc -liea.o: ../Includes/iprod.inc -liea.o: ../Includes/len.inc -liea.o: ../Includes/lims.inc -liea.o: ../Includes/pbkh.inc -liea.o: ../Includes/prodex.inc -liea.o: ../Includes/symp.inc -liea.o: ../Includes/vblist.inc -math.o: ../Includes/buffer.inc -math.o: ../Includes/expon.inc -math.o: ../Includes/id.inc -math.o: ../Includes/impli.inc -math.o: ../Includes/len.inc -math.o: ../Includes/vblist.inc -mygenrec5.o: ../Includes/combs.inc -mygenrec5.o: ../Includes/files.inc -mygenrec5.o: ../Includes/hmflag.inc -mygenrec5.o: ../Includes/impli.inc -mygenrec5.o: ../Includes/parset.inc -mygenrec5.o: ../Includes/quadpn.inc -mygenrec5.o: ../Includes/recmul.inc -myprot5.o: ../Includes/impli.inc -myprot5.o: ../Includes/param.inc -myprot5.o: ../Includes/parm.inc -myprot5.o: ../Includes/pie.inc -opti.o: ../Includes/impli.inc -opti.o: ../Includes/minvar.inc -opti.o: ../Includes/nlsvar.inc -proc.o: ../Includes/aimdef.inc -proc.o: ../Includes/amdiip.inc -proc.o: ../Includes/buffer.inc -proc.o: ../Includes/codes.inc -proc.o: ../Includes/files.inc -proc.o: ../Includes/fitbuf.inc -proc.o: ../Includes/fitdat.inc -proc.o: ../Includes/impli.inc -proc.o: ../Includes/keyset.inc -proc.o: ../Includes/labpnt.inc -proc.o: ../Includes/map.inc -proc.o: ../Includes/merit.inc -proc.o: ../Includes/parset.inc -proc.o: ../Includes/psflag.inc -proc.o: ../Includes/status.inc -proc.o: ../Includes/stmap.inc -proc.o: ../Includes/usrdat.inc -proc.o: ../Includes/xvary.inc -pure.o: ../Includes/dr.inc -pure.o: ../Includes/impli.inc -pure.o: ../Includes/sr.inc -rfgap.o: ../Includes/files.inc -rfgap.o: ../Includes/fitbuf.inc -rfgap.o: ../Includes/impli.inc -rfgap.o: ../Includes/map.inc -rfgap.o: ../Includes/usrdat.inc -setbound.o: ../Includes/impli.inc -sif.o: ../Includes/codes.inc -sif.o: ../Includes/files.inc -sif.o: ../Includes/impli.inc -sif.o: ../Includes/pie.inc -spch3d.o: ../Includes/files.inc -spch3d.o: ../Includes/impli.inc -spch3d.o: ../Includes/map.inc -sss.o: ../Includes/files.inc -trac.o: ../Includes/deriv.inc -trac.o: ../Includes/expon.inc -trac.o: ../Includes/files.inc -trac.o: ../Includes/impli.inc -trac.o: ../Includes/ind.inc -trac.o: ../Includes/ind3.inc -trac.o: ../Includes/ja3.inc -trac.o: ../Includes/len.inc -trac.o: ../Includes/len3.inc -trac.o: ../Includes/lims.inc -trac.o: ../Includes/pbkh.inc -trac.o: ../Includes/talk.inc -trac.o: ../Includes/vblist.inc -user.o: ../Includes/expon.inc -user.o: ../Includes/files.inc -user.o: ../Includes/fitdat.inc -user.o: ../Includes/impli.inc -user.o: ../Includes/linbuf.inc -user.o: ../Includes/map.inc -user.o: ../Includes/parset.inc -user.o: ../Includes/sigbuf.inc -user.o: ../Includes/sincos.inc -user.o: ../Includes/taylor.inc -user.o: ../Includes/usrdat.inc -user7.o: ../Includes/impli.inc -user7.o: ../Includes/ind.inc -user7.o: ../Includes/prodex.inc -usubs.o: ../Includes/actpar.inc -usubs.o: ../Includes/codes.inc -usubs.o: ../Includes/core.inc -usubs.o: ../Includes/expon.inc -usubs.o: ../Includes/files.inc -usubs.o: ../Includes/impli.inc -usubs.o: ../Includes/linbuf.inc -usubs.o: ../Includes/loop.inc -usubs.o: ../Includes/map.inc -usubs.o: ../Includes/parset.inc -usubs.o: ../Includes/pbkh.inc -usubs.o: ../Includes/sigbuf.inc -usubs.o: ../Includes/taylor.inc -usubs.o: ../Includes/usrdat.inc -usubs.o: ../Includes/vblist.inc -xtra_notgnu.o: ../Includes/files.inc -xtra_notgnu.o: ../Includes/impli.inc -xtra_notgnu.o: ../Includes/time.inc diff --git a/OpticsJan2020/MLI_light_optics/Src/afro.f b/OpticsJan2020/MLI_light_optics/Src/afro.f deleted file mode 100755 index 5f7144d..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/afro.f +++ /dev/null @@ -1,8787 +0,0 @@ -************************************************************************ -* header AFRONT * -* Front end of MARYLIE * -************************************************************************ -* -************************************************************************ -* MARYLIE and all its subroutines are copyrighted (1987) by * -* Alex J. Dragt. * -* All rights to MARYLIE and its subroutines are reserved. * -************************************************************************ -* -* Version Date: 5/25/98 -* -*********************************************************************** -* All of MARYLIE 3.0 is believed to conform to Fortran 77 standards. -* In addition, all of MARYLIE 3.0 is self contained save for -* -* 1) the time functions called in the MARYLIE -* subroutine cputim -* -* and -* -* 2) the 'exit' subroutine called (and only called) in the -* MARYLIE subroutine myexit. -* -* The two subroutines cputim and myexit and the subroutine mytime -* (which is the only one that calls cputim) are kept separately -* under the heading "XTRA". -********************************************************************* -c -********************************************************************* -c -* Main program for MARYLIE 3.0 -* Written originally by Rob Ryne ca 1984 and revised by -* Petra Schuett November 1987 -* - program mainmary -c - use rays - use acceldata - use lieaparam, only : monoms - use ml_timer - include 'impli.inc' - include 'files.inc' - include 'time.inc' - include 'ind.inc' - include 'codes.inc' -c - dimension p(6) - common/xtrajunk/jticks1,iprinttimers -c - call init_parallel - call init_ml_timers - call system_clock(count=jticks1) -c -c -c initiate starting time -c nint(p(1)).ne.0 resets a variable called tstart in common/mltime/ -c which is contained in the file time.inc rdr 08/25/2001 - p(1)=1.d0 - p(2)=12.d0 - p(3)=0.d0 - call mytime(p) -c -c write out copyright message at terminal - call cpyrt -c -c initialize commons (other than those in block data's) -c initialize lie algebraic things -c - call new_acceldata -! call new_particledata !do this for now for ML30 compat. RDR 8/10/02 -c - call setup -c -c read master input file -c - call dumpin -c -c======================================================================== -c print debug info on file 79 - write(79,*)'nconst=',nconst - write(79,*)' n constr conval' - do n=1,nconst - write(79,*)n,constr(n),conval(n) -c call flush(79) - enddo -c - write(79,*)' ' - write(79,*)'na=',na - write(79,*)'listing of n,nt1(n),nt2(n) for n=1,...,na' - do n=1,na - k1=nt1(n) - k2=nt2(n) - call lookup(lmnlbl(n),ntype,ith) - nn0=mpp(ith)+1 - nn1=mppc(ith)+1 - write(79,1236)n, & - & nt1(n),nt2(n),ltc(k1,k2),lmnlbl(n),nn0,nn1,nrp(k1,k2),ncp(k1,k2) -c call flush(79) - 1236 format(3(i4,1x),2(a16,1x),2(i5,1x),6x,2(i4,1x)) - enddo -c - write(79,*)' ' - write(79,*)'mpprpoi=',mpprpoi - write(79,*)'listing of n,pmenu(n) for n=1,...,mpprpoi' - do n=1,mpprpoi -c the following loop makes this whole thing very inefficent, -c but I am going to do it anyway in order to make this info -c more readable: -! do mmm=1,na -! k1=nt1(mmm) -! k2=nt2(mmm) -! call lookup(lmnlbl(mmm),ntype,ith) -! nn0=mpp(ith)+1 -! if(nn0.eq.n.and.nrp(k1,k2).ne.0)then -! write(79,*)lmnlbl(mmm),ltc(k1,k2) -! endif -! enddo - write(79,*)n,pmenu(n) -c call flush(79) - enddo - write(79,*)' ' - write(79,*)'mppcpoi=',mppcpoi - write(79,*)'listing of n,cmenu(n) for n=1,...,mppcpoi' - do n=1,mppcpoi - write(79,*)n,cmenu(n) -c call flush(79) - enddo -c======================================================================== - -c -c debug output -c call dump(jodf) -c call dump(jof) -c -c write out status at terminal - if(idproc.eq.0)then - write(jof,100) - 100 format(1h ,'Data input complete; going into #labor.') - endif -c -c begin actual calculations - call tran -c -c the end of the program is reached in MYEXIT -cryne ...but call myexit here in case the user forgot to use an "end" command - call myexit - end -c -*********************************************************************** - block data misc -c----------------------------------------------------------------------- -c initialize miscellaneous common variables -c Written by Petra Schuett, November 1987 based on earlier work of -c Rob Ryne and Liam Healy -c----------------------------------------------------------------------- - use acceldata - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' -c-------------------- - include 'core.inc' - include 'files.inc' - include 'lims.inc' - include 'maxcat.inc' - include 'infin.inc' - include 'zeroes.inc' -c-------------------- - data ordcat/6/,topcat/monoms/ - data ordlib/6/,toplib/monoms/ -c-------------------- - data bottom/0,1, 7,28, 84,210,462, 924,1716,3003,5005, 8008,12376/ - data top /0,6,27,83,209,461,923,1715,3002,5004,8007,12375,18563/ -c-------------------- - data lf,icf,jfcf,mpi,mpo,jif,jof,jodf,ibrief,iquiet/ & - & 11, 13, 14, 15, 16, 5, 6, 12, 2, 0/ -c-------------------- - data inuse/maxlum*0/ -c-------------------- - data xinf, yinf, tinf, ginf/ & - & 1000., 1000., 1000., 1000./ -c-------------------- - data fzer, detz/ & - & 0.d0, 0.d0/ -c -c-------------------- -c -cryne 8/15/2001 initialize parameters for poisson calculation: - common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0 - data nxsave,nysave,nzsave,noresize,nadj0/0,0,0,0,0/ - common/poiblock1/nspchset,nsckick - data nspchset,nsckick/0,-1/ - common/autotrk/lautotrk,ntrktype,ntrkorder - data lautotrk,ntrktype,ntrkorder/0,2,5/ -cryne 8/15/2001 parameters for automatic application of commands - character*16 autostr - common/autopnt/autostr(3) - common/autolog/lautoap1,lautoap2,lautoap3,lrestrictauto - common/autocon/lautocon - data autostr & - &/'xxxxxxxxxxxxxxxx','yyyyyyyyyyyyyyyy','zzzzzzzzzzzzzzzz'/ - data lautoap1,lautoap2,lautoap3/0,0,0/ - data lautocon/1/ -c - common/bfileinfo/ifileinfo - data ifileinfo/0/ -c -cryne 12 Nov 2003 - character*16 cparams - common/scparams/rparams(60),cparams(60) - data rparams/60*-9999999.d0/ - data cparams/60*'xxxxxxxxxxxxxxxx'/ -c - common/accum/at10,at21,at32,at43,at54,at65,at76,at70 - data at10,at21,at32,at43,at54,at65,at76,at70/0.,0.,0.,0.,0.,0.,0.,& - & 0./ - common/ffttime/ft10,ft21,ft32,ft30 - data ft10,ft21,ft32,ft30/0.,0.,0.,0./ -c -cryneneriwalstrom: - parameter(maxcof=35) - common /bicof/ bcoeff(maxcof,maxcof) - data (bcoeff(k,1),k=1,2) /1.d0,1.d0/ - data (bcoeff(k,2),k=1,3) /1.d0,2.d0,1.d0/ - end -c -************************************************************************ -c - block data names -c----------------------------------------------------------------------- -c define type codes allowed in MARYLIE -c Written by Petra Schuett in November 1987 based on earlier -c work of Rob Ryne -c----------------------------------------------------------------------- - include 'impli.inc' -c--------- -c commons -c--------- - include 'codes.inc' -c----------------------------------------------------------------------- -c components of master input file - data ling/'#comment', & - & '#beam ', & - & '#menu ', & - & '#lines ', & - & '#lumps ', & - & '#loops ', & - & '#labor ', & - & '#call ', & - & '#const'/ -c -c menu entries -c -c 1: simple elements -cryne 7/14/2002 added various elements to be compatible w/ MAD input. -cryne Also added some commonly used synonyms (e.g 'kick' for 'kicker') -cryne Need to work on the thin multipole. -c - data (ltc(1,j),j=1,75)/ - & 'drft ','nbnd ','pbnd ','gbnd ','prot ', & - & 'gbdy ','frng ','cfbd ','quad ','sext ', & - & 'octm ','octe ','srfc ','arot ','twsm ', & - & 'thlm ','cplm ','cfqd ','dism ','sol ', & - & 'mark ','jmap ','dp ','recm ','spce ', & - & 'cfrn ','coil ','intg ','rmap ','arc ', & - & 'rfgap ','confoc ','transit ','interface','rootmap', & - & 'optirot ','spare5 ','spare6 ','spare7 ','spare8 ', & - & 'marker ','drift ','rbend ','sbend ','gbend ', & - & 'quadrupole','sextupole','octupole','multipole','solenoid', & - & 'hkicker ','vkicker ','kicker ','rfcavity','elsepararator', & - & 'hmonitor','vmonitor','monitor ','instrument','sparem1 ', & - & 'rcollimator','ecollimator','yrot ','srot ','prot3 ', & - & 'beambeam','matrix ','profile1d','yprofile','tprofile', & - & 'hkick ','vkick ','kick ','hpm ','nlrf '/ - data (nrp(1,j),j=1,75)/ & - & 1,6,4,6,2, & - & 4,5,6,4,2, & - & 2,2,2,1,4, & - & 6,5,4,5,6, & - & 0,0,0,6,1, & - & 4,11,6,6,0, & - & 11,5,3,5,4, & - & 2,0,0,0,0, & - & 0,3,13,21,0, & - & 6,3,3, 6,13, & - & 4,4,5,8,4, & - & 2,2,2,2,0, & - & 3,3,1,1,2, & - & 0,0,7,6,6, & - & 4,4,5,3,7/ - data (ncp(1,j),j=1,75)/ & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 2,0,0,0,1, & - & 0,0,0,0,0, & - & 0,1,0,0,0, & - & 1,1,1,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,3,1,1, & - & 0,0,0,0,2/ - data (nrpold(1,j),j=1,75)/ & - & 1,6,4,6,2, & - & 4,5,6,4,2, & - & 2,2,2,1,4, & - & 6,5,4,5,6, & - & 0,0,0,6,1, & - & 4,11,6,6,0, & - & 7,4,0,0,0, & - & 0,0,0,0,0, & - & 0,2,0,21,0, & - & 5,3,3, 6,2, & - & 3,3,4,8,3, & - & 1,1,1,1,0, & - & 3,3,1,1,0, & - & 0,0,0,0,0, & - & 3,3,4,3,0/ -c -c 2: user-supplied elements -c - data (ltc(2,j),j=1,20)/ & - & 'usr1 ','usr2 ','usr3 ','usr4 ','usr5 ', & - & 'usr6 ','usr7 ','usr8 ','usr9 ','usr10 ', & - & 'usr11 ','usr12 ','usr13 ','usr14 ','usr15 ', & - & 'usr16 ','usr17 ','usr18 ','usr19 ','usr20 '/ - data (nrp(2,j),j=1,20)/20*6/ - data (ncp(2,j),j=1,20)/20*0/ - data (nrpold(2,j),j=1,20)/20*6/ -c -c 3: parameter sets -c - data (ltc(3,j),j=1,9)/ & - & 'ps1 ','ps2 ','ps3 ','ps4 ','ps5 ', & - & 'ps6 ','ps7 ','ps8 ','ps9 '/ - data (nrp(3,i),i=1,9)/9*6/ - data (ncp(3,i),i=1,9)/9*0/ - data (nrpold(3,i),i=1,9)/9*6/ -c -c 4: random elements -c Note: The j indices for these entries must be aligned with -c the j indices for their "simple element" counterparts. -c This is done by using "dummy" entries. -c - data (ltc(4,j),j=1,24)/ & - & 'rdrft ','rnbnd ','rpbnd ','rgbnd ','rprot ', & - & 'rgbdy ','rfrng ','rcfbd ','rquad ','rsext ', & - & 'roctm ','rocte ','rsrfc ','rarot ','rtwsm ', & - & 'rthlm ','rcplm ','rcfqd ','rdism ','rsol ', & - & 'dummark ','dumjmap ','dumdp ','rrecm '/ - data (nrp(4,i),i=1,24)/24*2/ - data (ncp(4,i),i=1,24)/24*0/ - data (nrpold(4,i),i=1,24)/24*2/ -c -c 5: random user-supplied elements -c - data (ltc(5,j),j=1,9)/ & - & 'rusr1 ','rusr2 ','rusr3 ','rusr4 ','rusr5 ', & - & 'rusr6 ','rusr7 ','rusr8 ','rusr9 '/ - data (nrp(5,i),i=1,9)/9*2/ - data (ncp(5,i),i=1,9)/9*0/ - data (nrpold(5,i),i=1,9)/9*2/ -c -c 6: random parameter sets -c - data (ltc(6,j),j=1,9)/ & - & 'rps1 ','rps2 ','rps3 ','rps4 ','rps5 ', & - & 'rps6 ','rps7 ','rps8 ','rps9 '/ - data (nrp(6,i),i=1,9)/9*2/ - data (ncp(6,i),i=1,9)/9*0/ - data (nrpold(6,i),i=1,9)/9*2/ -c -c 7: simple commands -cKMP: Replaced 'sparec5' with 'wrtmap' -cKMP: Replaced 'spacec6' with 'rdmap' -c - data (ltc(7,j),j=1,75)/ & - & 'rt ','sqr ','symp ','tmi ','tmo ', & - & 'pmif ','circ ','stm ','gtm ','end ', & - & 'ptm ','iden ','whst ','inv ','tran ', & - & 'revf ','rev ','mask ','num ','rapt ', & - & 'eapt ','of ','cf ','wnd ','wnda ', & - & 'ftm ','wps ','time ','cdf ','bell ', & - & 'wmrt ','wcl ','paws ','inf ','dims ', & - & 'zer ','sndwch ','tpol ','dpol ','cbm ', & - & 'poisson ','preapply','midapply','autoapply','autoconcat', & - & 'rayscale','beam ','units ','autoslice','verbose ', & - & 'mask6 ','arcreset','symbdef ','particledump','raytrace', & - & 'autotrack','sckick','moments ','maxsize ','reftraj', & - & 'initenv ','envelopes','contractenv','setreftraj','setarclen', & - & 'wakedefault','emittance','matchenv','fileinfo','egengrad', & - & 'wrtmap ','rdmap ','sparec7','sparec8','sparec9'/ - data (nrp(7,i),i=1,75)/ & - & 6,0,2,4,1, & - & 3,6,1,2,0, & - & 5,0,2,0,0, & - & 1,0,6,4,4, & - & 3,6,6,5,6, & - & 4,2,3,1,0, & - & 2,3,0,5,6, & - & 3,1,6,5,3, & - & 12,0,0,0,0, & - & 6,10,5,2,1, & - & 6,0,0,7,12, & - & 0,0,5,6,3, & - & 15,5,0,10,2, & - & 4,3,2,1,10, & - & 0,0,0,0,0/ - data (ncp(7,i),i=1,75)/ & - & 2,0,0,0,0, & - & 1,0,0,0,1, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 17,2,2,2,1, & - & 0,1,2,3,0, & - & 0,0,0,4,5, & - & 4,0,9,9,2, & - & 1,7,0,2,1, & - & 1,6,1,0,7, & - & 3,2,0,0,0/ - data (nrpold(7,i),i=1,75)/ & - & 6,0,2,4,1, & - & 3,6,1,2,0, & - & 5,0,2,0,0, & - & 1,0,6,4,4, & - & 3,6,6,5,6, & - & 4,2,3,1,4, & - & 2,3,0,5,6, & - & 3,1,6,5,3, & - & 6,0,0,0,1, & - & 6,10,4,1,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0/ -c -c 8: advanced commands -c - data (ltc(8,j),j=1,39)/ & - & 'cod ','amap ','dia ','dnor ','exp ', & - & 'pdnf ','psnf ','radm ','rasm ','sia ', & - & 'snor ','tadm ','tasm ','tbas ','gbuf ', & - & 'trsa ','trda ','smul ','padd ','pmul ', & - & 'pb ','pold ','pval ','fasm ','fadm ', & - & 'sq ','wsq ','ctr ','asni ','pnlp ', & - & 'csym ','psp ','mn ','bgen ','tic ', & - & 'ppa ','moma ','geom ','fwa '/ - data (nrp(8,i),i=1,39)/ & - & 6,6,5,5,3, & - & 5,5,5,5,5, & - & 5,4,6,1,2, & - & 6,6,6,3,3, & - & 3,5,3,6,6, & - & 4,6,4,6,4, & - & 1,3,2,12,6, & - & 6,6,6,6/ - data (ncp(8,i),i=1,39)/ & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0,2,0, & - & 0,0,0,0/ - data (nrpold(8,i),i=1,39)/ & - & 6,6,5,5,3, & - & 5,5,5,5,5, & - & 5,4,6,1,2, & - & 6,6,6,3,3, & - & 3,5,3,6,6, & - & 4,6,4,6,4, & - & 1,3,2,6,6, & - & 6,6,6,6/ -c -c 9: procedures and fitting and optimization -c - data (ltc(9,j),j=1,37)/ & - & 'bip ','bop ','tip ','top ', & - & 'aim ','vary ','fit ','opt ', & - & 'con1 ','con2 ','con3 ','con4 ','con5 ', & - & 'mrt0 ', & - & 'mrt1 ','mrt2 ','mrt3 ','mrt4 ','mrt5 ', & - & 'fps ', & - & 'cps1 ','cps2 ','cps3 ','cps4 ','cps5 ', & - & 'cps6 ','cps7 ','cps8 ','cps9 ', & - & 'dapt ','grad ','rset ','flag ','scan ', & - & 'mss ','spare1 ','spare1 '/ - data (nrp(9,i),i=1,37)/ & - & 1,1,1,1, & - & 6,6,6,6, & - & 6,6,6,6,6, & - & 1, & - & 6,6,6,6,6, & - & 1, & - & 6,6,6,6,6, & - & 6,6,6,6, & - & 4,6,5,6,6, & - & 6,6,6/ - data (ncp(9,i),i=1,37)/ & - & 0,1,1,1, & - & 0,0,0,0, & - & 0,0,0,0,0, & - & 0, & - & 0,0,0,0,0, & - & 0, & - & 0,0,0,0,0, & - & 0,0,0,0, & - & 0,0,0,0,0, & - & 0,0,0/ - data (nrpold(9,i),i=1,37)/ & - & 1,1,1,1, & - & 6,6,6,6, & - & 6,6,6,6,6, & - & 1, & - & 6,6,6,6,6, & - & 1, & - & 6,6,6,6,6, & - & 6,6,6,6, & - & 4,6,5,6,6, & - & 6,6,6/ -c - end -c -c********************************************************************** -c - subroutine buffin(th,tmh,thsave,tmhsav,lumpno) -c----------------------------------------------------------------------- -c stores a map and polynomial coeffs into a buffer -c Written by J. Howard, Fall 1986 -c----------------------------------------------------------------------- - use lieaparam, only : monoms - include 'impli.inc' - include 'stack.inc' -c - dimension th(monoms),tmh(6,6) - dimension thsave(monoms,mstack),tmhsav(6,6,mstack) -c - do 100 i = 1,6 - do 100 j = 1,6 - tmhsav(i,j,lumpno) = tmh(i,j) -100 continue -c - do 200 i = 1,monoms - thsave(i,lumpno) = th(i) -200 continue - return - end -************************************************************************ - subroutine bufout(thsave,tmhsav,th,tmh,lumpno) -c----------------------------------------------------------------------- -c reads a map and polynomial coefficients out of a buffer -c Written by J. Howard, Fall 1986 -c----------------------------------------------------------------------- - use lieaparam, only : monoms - include 'impli.inc' - include 'stack.inc' -c - dimension th(monoms),tmh(6,6) - dimension thsave(monoms,mstack),tmhsav(6,6,mstack) -c - do 100 i = 1,6 - do 100 j = 1,6 - tmh(i,j) = tmhsav(i,j,lumpno) -100 continue -c - do 200 i = 1,monoms - th(i) = thsave(i,lumpno) -200 continue -c - return - end -************************************************************************ - subroutine cnumb(string,num,lnum) -c----------------------------------------------------------------------- -c This routine finds out, whether string codes an integer number. -c if so, it converts it to num -c -c Input: string character*16 input string -c Output:num integer correspondent number -c lnum logical =.true. if string is a number -c -c Author: Petra Schuett -c October 19, 1987 -c----------------------------------------------------------------------- - include 'impli.inc' - include 'files.inc' -c -cryne 5/5/2006 declared slen an integer - integer num,slen -cryne 8/5/2004 character string*16 - character (LEN=*) :: string - logical lnum -c - character*10 digits -cryne data digits /'0123456789'/ -cryne save digits - digits='0123456789' -cryne 8/5/2004: - slen = LEN(string) -c----------------- -c The first char may be minus or digit -c write(jodf,*)'cnumb: string= ',string - if(index(digits,string(1:1)).eq.0 .and. string(1:1).ne.'-') then - lnum=.false. -c write(jodf,*)'first char is no digit' - return - endif -c All other characters must be digits... -cryne 8/5/2004 do 1 k=2,16 - do 1 k=2,slen - if(index(digits,string(k:k)).eq.0) then -c ...or trailing blanks -cryne 8/5/2004 if(string(k:16).ne.' ') then - if( string(k:k).ne.' ') then -c write(jodf,*)'string(',k,':16) is not blank' -c write(jodf,*)'string(',k,':slen) is not blank' - lnum=.false. - return - else - goto 11 - endif - endif - 1 continue -c string is a number - 11 read(string,*,err=999) num - lnum=.true. - return -c----------------- -c error exit - 999 write(jof ,99) string - write(jodf,99) string - 99 format(' ---> error in cnumb: string ',a16,' could not be', & - & ' converted to number') - call myexit - end -c -************************************************************************ -c - subroutine comwtm(j,jrep) -c----------------------------------------------------------------------- -c routine to combine the jth lump with the total map n times -c Written by J. Howard, Fall 1986 -c Modified by Alex Dragt, 15 June 1988, to save storage -c----------------------------------------------------------------------- - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' - include 'map.inc' - include 'core.inc' -c---------- -c start -c---------- -c make n positive in case lump has a negative repetition number - n=iabs(jrep) -c - do 100 i=1,n - call concat(th,tmh,thl(1,j),tmhl(1,1,j),th,tmh) - 100 continue - return - end -c -******************************************************************* -c - subroutine cqlate(icfile,norder,ntimes,nwrite,isend) -c -c----------------------------------------------------------------------- -c circulate ntimes times; print every nwrite -c -c input : icfile (integer) = filenumber for reading input rays -c norder (integer) = NOT USED -c ntimes (integer) = number of turns through actual line -c nwrite (integer) = modulo for writing coordinates to jfcf -c isend (integer) = 1 output only to jof -c = 2 output only to jodf -c = 3 both -c in common /files/: jfcf < 0 full precision coordinates -c > 0 standard format coordinates -c -c Written by Rob Ryne ca 1984 -c slightly changed by Petra Schuett (labels, if-then-else ...) -c October 30,1987 -c------------------------------------------------------------------------ - use parallel - use acceldata - use rays - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- - include 'talk.inc' - include 'files.inc' - include 'loop.inc' - include 'map.inc' - include 'deriv.inc' - include 'core.inc' - include 'nturn.inc' -c----------------------------------------------------------------------- -c local variables -c----------------------------------------------------------------------- - character*16 string(5),str,ubuf - logical ljof,ljodf -cryne: -cryne dimension zi(6),zf(6) this is defined in rays.inc -c----------------------------------------------------------------------- -c start routine -c----------------------------------------------------------------------- -c see if a loop exists - if(nloop.le.0) then - write(jof ,*) ' error from cqlate: no loop has been specified' - write(jodf,*) ' error from cqlate: no loop has been specified' - return - endif -c -c read initial conditions, if requested: -c if(icfile.gt.0) call raysin(icfile) - if(icfile.gt.0)then - scaleleni=0.d0 - scalefrqi=0.d0 - scalemomi=0.d0 - call raysin(icfile,scaleleni,scalefrqi,scalemomi,ubuf,jerror) - call rbcast(scaleleni) - call rbcast(scalefrqi) - call rbcast(scalemomi) - endif -c check for initial conditions: - if(nrays.eq.0)then - if(idproc.eq.0)then - write(6,*)'error(cqlate) : nrays=0' - write(6,*)'forgot to generate or read initial conditions?' - endif - call myexit - endif -c-------------------- -c write items in loop, if requested: - ljof = isend.eq.1 .or. isend.eq.3 - ljodf = isend.eq.2 .or. isend.eq.3 - if (ljof .or. ljodf) then -c write loop name - if(ljof ) write(jof ,510) ilbl(nloop) - if(ljodf) write(jodf,510) ilbl(nloop) - 510 format(1h ,'circulating through ',a16,' :') -c write loop contents - do 1 jtot=0,joy,5 - kmax=min(5,joy-jtot) - do 2 k=1,kmax - jk1=jtot+k -c element - if(mim(jk1).lt.0) then - string(k)=lmnlbl(-mim(jk1)) -c user supplied element - else if(mim(jk1).gt.5000) then - string(k)=lmnlbl(mim(jk1)-5000) -c lump - else - string(k)=ilbl(inuse(mim(jk1))) - endif - 2 continue - if(ljof) write(jof ,511)(string(k),k=1,kmax) - if(ljodf) write(jodf,511)(string(k),k=1,kmax) - 511 format(' ',5(1x,a16)) - 1 continue - endif -c-------------------- -c circulation procedure -c -c set up control indices - ibrief=0 - kwrite=nwrite - if(kwrite.eq.0)kwrite=1 -c-------------------- -c circulation through loop - do 1000 nturn=1,ntimes -c---------- -c handle each loop-element - do 100 kk=1,joy -c check to see if all particles lost -c Go at least one turn... - if(nturn.gt.1) then - if(nlost.ge.nraysp) then - write(jof,*) 'all particles lost on processor ',idproc - return - endif - endif -c -c check to see if item is a lump, user routine, or element - ip = mim(kk) - if(ip.gt.5000)then -c procedure for a user routine - nip=ip-5000 - if(nt2(nip).eq.1) call user1(pmenu(1+mpp(nip))) - if(nt2(nip).eq.2) call user2(pmenu(1+mpp(nip))) - if(nt2(nip).eq.3) call user3(pmenu(1+mpp(nip))) - if(nt2(nip).eq.4) call user4(pmenu(1+mpp(nip))) - if(nt2(nip).eq.5) call user5(pmenu(1+mpp(nip))) -c - else if(ip.lt.0) then -c procedure for turtling thru elements (which may be in lines): -cryne 08/15/2001 autoslicing does not apply when cirulating thru a loop -cryne note: this has not been tested as of 8/15/2001: - jslice=1 - nslices=1 - slfrac=1. -c ntrk=0 -c if(nspchset.eq.1)ntrk=1 -c----------------------------------------------------- -c call isthick(kt1,kt2,ithick,thlen,0) -c if(iautosl.lt.0.and.ithick.eq.1)nslices=pmenu(nrp(1,kt2)) -c if(iautosl.gt.0.and.ithick.eq.1)nslices=iautosl -c slfrac=1./nslices -c if(lautoap2.eq.1 .or. nspchset.eq.1)slfrac=slfrac*0.5d0 -c----------------------------------------------------- - narg1=1+mpp(-ip) - narg2=1+mppc(-ip) - call lmnt(nt1(-ip),nt2(-ip),pmenu(narg1),cmenu(narg2), & - & 1,jslice,nslices,slfrac,0) -c - else -c procedure for a lump - do 110 nn=1,nraysp -c check to see if particle has already been lost - if (istat(nn).eq.0) then - do 112 l=1,6 - 112 zi(l)=zblock(l,nn) -c call symplectic tracker - jwarn=0 - call evalsr_old(tmhl(1,1,ip),zi,zf,dfl(1,1,ip), & - & rdfl(1,1,ip),rrjacl(1,1,1,ip)) -c check to see if particle was 'lost' by the symplectic ray tracer - if (jwarn.ne.0) then - istat(nn)=nturn - nlost=nlost + 1 - ihist(1,nlost)=nturn - ihist(2,nlost)=nn - endif -c copy results of ray trace into storage array - do 114 l=1,6 - 114 zblock(l,nn)=zf(l) - endif - 110 continue - endif - 100 continue -c -c end of one turn -c---------- -c check to see if results should be written out - if(mod(nturn,kwrite).eq.0) then - do 200 m1=1,nraysp - if(istat(m1).eq.0) then -c procedure for writing out results of ray trace -c -c procedure for standard format - if(jfcf.gt.0) then - write(jfcf,520)(zblock(m2,m1),m2=1,6) - 520 format(6(1x,1pe12.5)) -c -c procedure for full precision - else if(jfcf.lt.0) then - do 525 m2=1,6 - write(-jfcf,*) zblock(m2,m1) - 525 continue - endif -c - endif - 200 continue - endif -c - 1000 continue -c end of loop thru turns -c----------------------------------------------------------------------- - return - end -c -*********************************************************************** -c - subroutine cread(kbeg,msegm,line,string,lfound) -c----------------------------------------------------------------------- -c This routine searches line(kbeg:) for the next string; strings are -c delimited by ' ','*' or ','. -c -c Input: line character*(*)input line -c kbeg integer line is only searched behind kbeg -c if a string is found, kbeg is set to -c possible start of next string -c msegm integer segment number. for msegm=1 (comment -c section), the length of a string is not -c checked. -c output:string character*(*)found string -c lfound logical =.true. if a string was found -c -c Written by Rob Ryne ca 1984 -c Rewritten by Petra Schuett -c October 19, 1987 -cryne -c Modified by Rob Ryne July 2002 to parse lines (with some exceptions) -c in the Standard Input Format -c Modified by David Serafini to allow lines longer than 80 chars -c----------------------------------------------------------------------- - include 'impli.inc' - include 'files.inc' -c - integer kbeg,msegm - character line*(*), string*(*) - logical lfound - integer llen,slen - - llen = LEN(line) - slen = LEN(string) -c -c look for first character of string -cryne 3/6/2004 but first check for *( -cryne 5/4/2006 but don't do this if in #comment - if(msegm.eq.1)goto 666 -cryne 5/4/2006 and only do this if the word 'line' appears: - if( index(line,'line').eq.0 ) goto 666 -c - do k=kbeg,llen-2 -cryne this version of the parser cannot handle lines defined as -cryne repeated quantities between parenthesese - if( line(k:k+1).eq.'*(' .or. - & line(k:k+2).eq.'* (' )then - write(6,*)'error in cread:' - write(6,*)'this version cannot parse a line of the form:' - write(6,*)'N*(...) or N* (...)' - call myexit - endif - enddo - 666 continue -c - do 1 k=kbeg,llen - if( (line(k:k).ne.' ') - & .and.(line(k:k).ne.'*') -cryne- - & .and.(line(k:k).ne.';') - & .and.(line(k:k).ne.':') - & .and.(line(k:k).ne.'=') - & .and.(line(k:k).ne.'(') - & .and.(line(k:k).ne.')') -cryne- - & .and.(line(k:k).ne.',')) then -c found: - lfound=.true. -c dont run off the end of either char variable - lmax = min(k+slen,llen) -c look for delimiter - do 2 l=k,lmax - if(( line(l:l).eq.' ') - & .or.(line(l:l).eq.'*') -cryne- - & .or.(line(l:l).eq.':') - & .or.(line(l:l).eq.';') - & .or.(line(l:l).eq.'=') - & .or.(line(l:l).eq.'(') - & .or.(line(l:l).eq.')') -cryne- - & .or.(line(l:l).eq.',')) then -c if found, string is known - string=line(k:l-1) - kbeg =l+1 -c done. - return - endif - 2 continue -c no delimiter behind string found... - string=line(k:lmax) -c ...end of line - if(lmax.eq.llen) then - kbeg=llen -c ...or string too long (ignored for comment section) - else if (msegm.ne.1) then - write(jof,99) kbeg - 99 format(' ---> warning from cread:'/, - & ' the following line has a very long string at ', - & 'position ',i2,' :') - write(jof,*) line - kbeg=lmax+1 - endif -c ...anyway, its done. - return - endif - 1 continue -c No string was found after all. - lfound=.false. - return - end -c -************************************************************************ - subroutine dump(iu) -c----------------------------------------------------------------------- -c this subroutine dumps the status of the common-blocks -c as they are filled by dumpin -c input: iu output-file -c -c written by Petra Schuett -c October 26, 1987 -c----------------------------------------------------------------------- - use beamdata - use acceldata - use lieaparam, only : monoms - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- - include 'codes.inc' - include 'files.inc' -c----------------------------------------------------------------------- -c start routine -c----------------------------------------------------------------------- -c comments - if(np.ne.0) then - write(iu,500) ling(1) - write(iu,*) (mline(i),i=1,npcom) - endif -c-------------------- -c beam - write(iu,500) ling(2) - write(iu,*) brho - write(iu,*) gamm1 - write(iu,*) achg - write(iu,*) sl -c-------------------- -c menu - write(iu,500) ling(3) - do 10 k=1,na - write(iu,520) lmnlbl(k),ltc(nt1(k),nt2(k)) - imax=nrp(nt1(k),nt2(k)) - if(imax.ne.0) then - write(iu,522)(pmenu(i+mpp(k)),i=1,imax) - endif - 10 continue -c-------------------- -c lines,lumps,loops - if(nb.ne.0) then - do 40 ii=2,4 - write(iu,500) ling(ii+2) - do 40 k=1,nb - if(ityp(k).eq.ii) then - write(iu,530) ilbl(k) - write(iu,532)(irep(l,k),icon(l,k),l=1,ilen(k)) - endif - 40 continue - endif -c-------------------- -c labor - if(noble.ne.0) then - write(iu,500) ling(7) - do 100 j=1,noble - write(iu,540) num(j),latt(j) - 100 continue - endif - return -c----------------------------------------------------------------------- -c format -c----------------------------------------------------------------------- - 500 format(1h ,a8) -! 510 format(1h ,a80) - 520 format(1h ,1x,a16,1x,a16) - 522 format((1h ,3(1x,1pg22.15))) - 530 format(1h ,1x,a8) - 532 format((1h ,1x,5(i5,'*',a8),1x,:'&')) - 540 format(1h ,1x,i4,'*',a8) - end -************************************************************************ - subroutine initst(string,nrept) -c----------------------------------------------------------------------- -c initialize stack, putting element 'string' with rep. factor nrept -c on top -c -c input: string character*(*) initial stack element (loop,line or lump!) -c nrept integer rep. factor -c -c Petra Schuett, October 30,1987 -c----------------------------------------------------------------------- - use acceldata - use lieaparam, only : monoms - use parallel, only : idproc - include 'impli.inc' -c-------- -c commons -c-------- - include 'stack.inc' - include 'files.inc' -c--------------- -c parameter type -c--------------- - character string*(*) -c------- -c start -c------- - np = 1 - lstac(1) = string - loop (1) = nrept - call lookup(string,ntype,ith) - if(ntype.eq.1 .or. ntype.eq.5) then - if(idproc.eq.0)write(jof,510) string - 510 format(' >>>>warning from initst: stack element',a ,' is an', & - & ' element or an unused label') - else - nslot(1) = newsl(1,ith) - call lookup(icon(nslot(np),ith),mtype,jth) - endif -c----------------------------------------------------------------------- - return - end -************************************************************************ -c - subroutine lmnt(nt1,nt2,prms,crms,ntrk,jslice,jsltot,slfrac,ihalf) -c----------------------------------------------------------------------- -c this routine actually switches to the routines that handle single -c elements, commands, etc. -c -c input: nt1 = group type code of element -c nt2 = index of element in its group -c prms = array of numerical (double) params for this element -c crms = array of character params for this element -c ntrk = 0 if accumulated transfer map is to be constructed -c = 1 if tracking -c Modified by Rob Ryne 08/15/2001 to handle sliced elements -c jslice=present slice number; jsltot=total number of slices, -c slfrac=fraction by which the element length is multiplied for slicing -c ihalf = 1 (first half) or 2 (second half) if a slice is split in half, -c as when performing space-charge kicks or "midapply" operations -c ihalf = 0 if slices are not split in half. -c -cryne: this routine should be cleaned up in order to (among other things) -c have some consistency regarding the units of angles. Most of the -c inconsistency is historical: MaryLie uses degrees in the argument lists -c for most (all?) bending magnet routines, but the arot is in radians. -c MAD uses radians for everything, but, rather than change the MaryLie -c routines, the normal MAD input is converted to degrees. -c -c Written by Rob Ryne ca 1984 -c modified by J. Howard 7-87 -c P. Schuett 11-87 -c A. Dragt 6/15/88 -c----------------------------------------------------------------------- - use beamdata - use acceldata, only : slicetype,sliceprecedence,slicevalue - use rays - use lieaparam, only : monoms - use spchdata - use e_gengrad - use multitrack - include 'impli.inc' -c-------- -c commons -c-------------------- - include 'map.inc' - include 'parset.inc' - include 'files.inc' - include 'codes.inc' - include 'pie.inc' - include 'infin.inc' - include 'zeroes.inc' - include 'frnt.inc' - include 'previous.inc' - include 'setref.inc' - include 'fitbuf.inc' - common/rfxtra/zedge,gaplen,thetastore - common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0 - common/poiblock1/nspchset,nsckick - common/gxyzsave/xmin0,xmax0,ymin0,ymax0,zmin0,zmax0,kfixbdy,madegr - integer idirectfieldcalc,idensityfunction,isolve - & ,anagpatchsize,anagrefratio,anagsmooth - common/newpoisson/idirectfieldcalc,idensityfunction,isolve - & ,anagpatchsize,anagrefratio,anagsmooth - character*256 chombofilename - common/chombochar/chombofilename - common/dirichlet/idirich - common/autotrk/lautotrk,ntrktype,ntrkorder - common/envstuff/nenvtrk - character*16 fname,fname1,fname2,fname3,fname4 - character*16 estrng,autostr,icname,fcname - character*5 anum - common/autopnt/autostr(3) - common/autolog/lautoap1,lautoap2,lautoap3,lrestrictauto - common/autocon/lautocon - common/showme/iverbose - real*8 mhprev - common/prevmap/hprev(monoms),mhprev(6,6) - common/bfileinfo/ifileinfo - common/xtrajunk/jticks1,iprinttimers -cryne - character*3 kynd -c-------------------------------- -c parameter types and dimensions -c-------------------------------- - integer nt1,nt2,ntrk - character*16 crms,cparams - character*5 aseq - dimension prms(*),crms(*) -c----------------- -c local variables -c----------------- -c maps - double precision h(monoms),ht1(monoms),ht2(monoms),ht3(monoms) - double precision mh(6,6),mht1(6,6),mht2(6,6),mht3(6,6) - double precision dreftraj(6) -c -c leading .. and trailing fringe field: lfrn (tfrn) .ne.0, if it is -c to be taken into account - integer lfrn,tfrn -c Input args nt1,nt2,prms must not be changed. work with kt1,kt2,p. -c dimension p(6),ptmp(6) - dimension p(60),ptmp(6) -cryne 7/13/2002 - dimension coefpset(6) -cryne 12 Nov 2003 added common/scparams/ - common/scparams/rparams(60),cparams(60) - equivalence (p1,p(1)),(p2,p(2)),(p3,p(3)),(p4,p(4)),(p5,p(5)), & - & (p6,p(6)) - data imsg1/0/ - save imsg1 - logical, save :: first_entry = .true. -cKMP: 8 Noc 2006 - added clinestrng - character*132 clinestrng -c----------------------------------------------------------------------- -c start -c---------------- - if(iverbose.eq.2.and.idproc.eq.0) & - &write(6,*)'inside LMNT with nt1,nt2=',nt1,nt2 -c write(6,*)'(LMNT) nt1,nt2,ntrk,jslice,jsltot,slfrac,ihalf=' -c write(6,*) nt1,nt2,ntrk,jslice,jsltot,slfrac,ihalf -c write(6,*)'reftraj(5),reftraj(6)=',reftraj(5),reftraj(6) -c----------------------------------------------------------------------- - multitrac=0 !cryne May 21, 2006 -c -c first-entry initializations -c - if (first_entry) then - first_entry = .false. - nullify(eggrdata%zvals) - nullify(eggrdata%G1c); nullify(eggrdata%G1s) - nullify(eggrdata%G2c); nullify(eggrdata%G2s) - nullify(eggrdata%G3c); nullify(eggrdata%G3s) - endif -c -c Preliminary procedure for random elements or commands -c - if(nt1.eq.4 .or. nt1.eq.5 .or. nt1.eq.6) then - nfile = nint(prms(1)) - iecho = nint(prms(2)) - kt1 = nt1 - 3 - kt2 = nt2 - call randin(nfile,kt1,kt2,p) -c -c Echo back if requested - if( iecho.eq.1 .or. iecho.eq.3) then - write(jof, 7005) nfile,kt1,kt2 - write(jof ,*)(p(i),i=1,nrp(kt1,kt2)) - endif - if( iecho.eq.2 .or. iecho.eq.3) then - write(jodf,7005) nfile,kt1,kt2 - write(jodf,*)(p(i),i=1,nrp(kt1,kt2)) - endif - 7005 format(' random lmnt check:nfile,kt1,kt2=',3i5/ - & ' parameters found:') -c -c - else -c -c Preliminary procedure for all other type codes -c -c - kt1 = nt1 - kt2 = nt2 - nparams=nrp(nt1,nt2) - ncparams=ncp(nt1,nt2) -c write(6,*)'nparams=',nparams - if(nparams.gt.0)then - p(1:nparams)=prms(1:nparams) - endif - endif -c -c Select appropriate action depending on value of kt1,kt2 -c - go to (11,12,13,14,15,16,17,18,19), kt1 -c -c 1: simple elements ************************************* -c -11 continue -c 'drft ','nbnd ','pbnd ','gbnd ','prot ', - go to(101, 102, 103, 104, 105, -c 'gbdy ','frng ','cfbd ','quad ','sext ', - & 106, 107, 108, 109, 110, -c 'octm ','octe ','srfc ','arot ','twsm ', - & 111, 112, 113, 114, 115, -c 'thlm ','cplm ','cfqd ','dism ','sol ', - & 116, 117, 118, 119, 120, -c 'mark ','jmap ','dp ','recm ','spce ', - & 121, 122, 123, 124, 125, -c 'cfrn ','coil ','intg ','rmap ','arc ', - & 126, 127, 128, 129, 130, -c 'rfgap ','confoc ','transit','interface','rootmap', - & 1135, 1136, 133, 134, 135, -c 'spare4 ','spare5 ','spare6 ','spare7 ','spare8 ', - & 136, 137, 138, 139, 140, -c 'marker ','drift ','rbend ','sbend ','gbend ', - & 141, 142, 143, 1045, 145, -c 'quadrupo','sextupol','octupole','multipol','solenoid', - & 146, 147, 148, 149, 150, -c 'hkicker ','vkicker ','kicker ','rfcavity','elsepara', - & 151, 152, 153, 154, 155, -c 'hmonitor','vmonitor','monitor ','instrume','sparem1 ', - & 156, 157, 158, 159, 160, -c 'rcollima','ecollima','yrot ','srot ','prot3 ', - & 161, 162, 163, 164, 165, -c 'beambeam','matrix ','profile1d','yprofile','tprofile', - & 166, 167, 168, 169, 170, -c 'hkick ','vkick ','kick ','hpm ','nlrf '/ - & 171, 172, 173, 174, 175),kt2 -c -c 'drft ': drift -c -101 continue - if(slfrac.ne.1.0)p1=p1*slfrac -c write(6,*)'DRFT:jslice,jsltot,slfrac=',jslice,jsltot,slfrac - call drift3(p1,h,mh) -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 -c note: under the assumption that omega*sl/c=1, it follows that omega=c/sl -c therefore, multiplying by c/sl is the correct thing to do -c to make reftraj(5) dimensionless under this assumption. - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -c -c 'nbnd ': normal entry bend -c the map for this element is of the form -c gfrngg*nbend*gfrngg with the leading and trailing fringe field -c maps optional -c -102 continue -c angdeg=p1 - gap=p2 - xk1=p3 - rho=brho/p4 - lfrn=nint(p5) - tfrn=nint(p6) -c compute nbend - if(slfrac.ne.1.0)p1=p1*slfrac - call nbend(rho,p1,h,mh) -c put on leading fringe field -cryne - azero=0. - if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then - if(lfrn.ne.0)then -cryne call gfrngg(0.d0,rho,1,ht1,mht1,gap,xk1) - call gfrngg(azero,rho,1,ht1,mht1,gap,xk1) - call concat(ht1,mht1,h,mh,h,mh) - endif - endif -c put on trailing fringe field - if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then - if(tfrn.ne.0)then -cryne call gfrngg(0.d0,rho,2,ht1,mht1,gap,xk1) - call gfrngg(azero,rho,2,ht1,mht1,gap,xk1) - call concat(h,mh,ht1,mht1,h,mh) - endif - endif -c============== - call set_pscale_mc(h,mh) - arclen=arclen+rho*p1*(pi/180.) - refprev=reftraj - reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) - prevlen=rho*p1*(pi/180.) - nt2prev=nt2 - rhoprev=rho -c============== - goto 2000 -c -c 'pbnd ': -c parallel faced bend, including leading and trailing -c pole face rotations and fringe fields. -c Symmetric bends only are permitted under this option. -c For parallel-faced magnet with asymmetric entry and exit, -c use the general bending magnet. -c The map for the parallel faced bend is of the form -c prot*gfrng*pbend*gfrng*prot -c -103 continue - psideg=p1/2.d0 - gap=p2 - xk1=p3 - rho=brho/p4 -c -cryne Jan 5, 2005 if(jsltot.eq.1)then - if(jsltot.eq.1 .and. ihalf.eq.0)then -c procedure for a complete pbnd (no slices): [Jan 5, 2005 and not split in half] -c -cryne 3/17/2004 -c but it still could be cut in half due to space charge or autoapply. So... -cryne Jan 5, 2005 if(slfrac.ne.1.0)p1=p1*slfrac -c - call pbend(rho,p1,h,mh) -c put on the leading fringe field - call gfrngg(psideg,rho,1,ht1,mht1,gap,xk1) - call concat(ht1,mht1,h,mh,h,mh) -c put on leading prot - call prot(psideg,1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c put on trailing fringe field - call gfrngg(psideg,rho,2,ht1,mht1,gap,xk1) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing prot - call prot(psideg,2,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - else -c -c procedure for a pbnd in slices. -c This follows the approach due to Dragt that is described -c in Exhibit 6.6.3 and section 10.9 of the MaryLie manual. - if(slfrac.ne.1.0)p1=p1*slfrac - azero=0. - call nbend(rho,p1,h,mh) - if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then -c put on the leading gbody - call gbend(rho,azero,psideg,azero,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c put on the leading fringe field - call gfrngg(psideg,rho,1,ht1,mht1,gap,xk1) - call concat(ht1,mht1,h,mh,h,mh) -c put on leading prot - call prot(psideg,1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) - endif - if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then -c put on trailing gbody - call gbend(rho,azero,azero,psideg,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing fringe field - call gfrngg(psideg,rho,2,ht1,mht1,gap,xk1) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing prot - call prot(psideg,2,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - endif - endif -c============== -cryne 08/15/2001 - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+rho*p1*(pi/180.) - reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) - prevlen=rho*p1*(pi/180.) - nt2prev=nt2 - rhoprev=rho -c============== - goto 2000 -c -c 'gbnd ': general bending magnet -c -c The map for the general bend is of the form -c prot*gfrng*gbend*gfrng*prot -c -104 continue - if(jsltot.ne.1)then - write(6,*)'error: gbnd not yet available with slices!' - stop - endif - gap=p4 - xk1=p5 - if(p6.eq.0.d0)then - write(6,*)'Error (gbnd): B field equal zero not allowed' - stop - endif - rho=brho/p6 -c compute gbend - call gbend(rho,p1,p2,p3,h,mh) -c -c put on the leading fringe field - call gfrngg(p2,rho,1,ht1,mht1,gap,xk1) - call concat(ht1,mht1,h,mh,h,mh) -c put on leading prot - call prot(p2,1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c put on trailing fringe field - call gfrngg(p3,rho,2,ht1,mht1,gap,xk1) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing prot - call prot(p3,2,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+rho*p1*(pi/180.) - reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) - prevlen=rho*p1*(pi/180.) - nt2prev=nt2 - rhoprev=rho -c============== - goto 2000 -c -c 'sbend ': MAD sector bend -c similar to MaryLie cfbd, but with arbitrary entrance/exit angles -c -c The map for this element is treated as the following: -c prot*cgfrngg*cgbend*cgfrngg*prot -c where: -c prot is a pole face rotation -c cgfrngg is a fringe field (analgous to that used in cfbd) -c cgbend is a gbend but w/ multipole coefficients -c note that, in analogy with the fact that gbend=hpf1*nbend*hpf2, -c in this case we set cgbend=hpf1*(cfbd w/ no fringe fields)*hpf2, -c i.e. cgbend=hpf1*cfbend*hpf2 -c -1045 continue - bndang=p1 - rho=brho/p2 - psideg=p(3) - phideg=p(4) - lfrn=nint(p5) - tfrn=nint(p6) - gap1=prms(7) - gap2=prms(8) - fint1=prms(9) - fint2=prms(10) - iopt=nint(prms(11)) - ipset=nint(prms(12)) -c - do j=1,6 - coefpset(j)=0.d0 - enddo - if( (ipset.gt.0).and.(ipset.le.maxpst))then - do j=1,6 - coefpset(j)=pst(j,ipset) -c write(6,*)j,coefpset(j) - enddo - else -c write(6,*)'In lmnt at sbend; j,coefpset(j)=' - do j=1,6 - if(prms(j+12).ne.0.d0)coefpset(j)=prms(j+12) -c write(6,*)j,coefpset(j) - enddo - endif -c - tiltang=prms(19) - if(tiltang.ne.0. .and. idproc.eq.0)then - write(6,*)'WARNING(sbend): tilt keyword being tested' - endif - myorder=nint(prms(20)) - if(idproc.eq.0)then - if(myorder.ne.5)write(6,*)'(sbend) order = ',myorder - endif - azero=0.d0 -c---------------- -c compute gbend -c call cgbend(rho,bndang,psideg,phideg,iopt,coefpset,h,mh) - aldeg=bndang-psideg-phideg - ptmp(1)=aldeg+psideg+phideg ! = bndang - if(slfrac.ne.1.0)ptmp(1)=ptmp(1)*slfrac - ptmp(2)=brho/rho - ptmp(3)=0. - ptmp(4)=0. - ptmp(5)=iopt -cryne 1 August 2004 ptmp(6)=0. !not used - ptmp(6)=myorder -c -c ptmp(1)=psideg -c call cfbend(ptmp,coefpset,ht2,mht2) -c ptmp(1)=aldeg -c call cfbend(ptmp,coefpset,ht3,mht3) -c call concat(ht2,mht2,ht3,mht3,ht3,mht3) -c ptmp(1)=phideg -c call cfbend(ptmp,coefpset,ht2,mht2) -c call concat(ht2,mht2,ht3,mht3,ht3,mht3) -c if(idproc.eq.0)then -c write(6,*)'call cfbend:aldeg,slfrac,ptmp(1)=',aldeg,slfrac,ptmp(1) -c endif -c*** -cryne 12/22/2004 mods per Marco Venturini bypass the slow cfbend routines -c if there are no multipole coefficients (note that, at the moment, the -c cfbend routine is only third order) - scpset=0.d0 - do ii=1,6 - scpset=scpset+coefpset(ii) - enddo - if(scpset.eq.0.d0)then ! use nbend if field is pure dipole - slang=bndang - if(slfrac.ne.1.0)slang=slang*slfrac - call nbend(rho,slang,h,mh) - else - call cfbend(ptmp,coefpset,h,mh) - endif -c*** -c---------------- -c - if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then -c put on the leading gbend - call gbend(rho,azero,psideg,azero,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c put on the leading fringe field - call cgfrngg(1,psideg,rho,lfrn,gap1,fint1,iopt,coefpset,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c put on leading prot - call prot(psideg,1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c put on leading arot - call arot(tiltang,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) - endif -c - if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then -c put on the trailing gbend - call gbend(rho,azero,azero,phideg,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing fringe field - call cgfrngg(2,phideg,rho,tfrn,gap2,fint2,iopt,coefpset,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing prot - call prot(phideg,2,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing arot - tiltang=-tiltang - call arot(tiltang,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - endif -c============== -cryne*** 3/16/2004 - if(slfrac.ne.1.0)p1=p1*slfrac -cryne*** - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+rho*p1*(pi/180.) - reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) - prevlen=rho*p1*(pi/180.) - nt2prev=nt2 - rhoprev=rho -c============== - goto 2000 -c -c -c 'prot ': rotation of reference plane -c -105 continue -cryne Aug 5, 2003: now this is the 5th order version: - ijkind=nint(p2) - call prot(p1,ijkind,h,mh) - goto 2000 -cryne 9/25/2007 return -c -c 'gbdy ': body of a general bending magnet -c -106 continue - rho=brho/p4 - call gbend(rho,p1,p2,p3,h,mh) -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+rho*p1*(pi/180.) - reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) - prevlen=rho*p1*(pi/180.) - nt2prev=nt2 - rhoprev=rho -c============== - goto 2000 -c -c 'frng ': hard edge dipole fringe fields -c -107 continue - rho=brho/p4 - iedge=nint(p5) - gap = p2 - xk1 = p3 - call gfrngg(p1,rho,iedge,h,mh,gap,xk1) - goto 2000 -c -c 'cfbdy ': body of a combined function bending magnet -c -1075 continue - write(6,*)'cfbdy not implemented' - return -c -c 'cfbd ': combined function bend (normal entry and exit) -c -c The map for the combined function bend is of the form -c [(arot*frquad*arotinv)frquad*gfrngg]* -c cfbend* -c [gfrngg*frquad*(arot*frquad*arotinv)] -c with the leading and trailing fringe fields optional. -c The gap size cfbgap and normalized leading and trailing -c field integrals cfblk1 and cfbtk1 for the dipole -c are taken from the table in block common frnt. -c These entries are initialized to 0, .5, .5, respectively -c at the beginning of a Marylie run, and can be changed using -c the type code cfrn. -c The factors of the form (arot*frquad*arotinv) give skew -c quad fringe fields. -c -108 continue - if(jsltot.ne.1)then - write(6,*)'error: cfbd not yet available with slices!' - stop - endif - rho=brho/p2 - lfrn=nint(p3) - tfrn=nint(p4) - ijopt=nint(p5) - iopt=mod(ijopt,10) -c write(6,*) 'iopt=',iopt - if ((iopt.lt.1) .or. (iopt.gt.3)) then - write(jof,*) 'WARNING: parameter iopt outside allowed range in', & - & ' element with type code cfbd' - endif - ipset=nint(p6) - do j=1,6 - coefpset(j)=0.d0 - enddo - if( (ipset.gt.0).and.(ipset.le.maxpst))then - do j=1,6 - coefpset(j)=pst(j,ipset) - enddo - endif -c compute cfbend - call cfbend(p,coefpset,h,mh) -c put on leading dipole and quad fringe fields - if(lfrn.ne.0) then -c compute and put on leading dipole fringe field - gap=cfbgap - xk1=cfblk1 - call gfrngg(0.d0,rho,1,ht1,mht1,gap,xk1) -c call nfrng(rho,1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c compute and put on leading quad fringe fields - if((ipset.gt.0) .and. (ipset.le.maxpst)) then - if(iopt.eq.1) then - bqd=coefpset(1) - aqd=coefpset(2) - endif - if(iopt.eq.2) then - bqd=coefpset(1) - aqd=coefpset(2) - endif - if(iopt.eq.3) then - bqd=brho*coefpset(1) - aqd=brho*coefpset(2) - endif -c compute and put on normal quad fringe field - call frquad(bqd,-1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c compute and put on skew quad fringe field - angr=-pi/4.d0 - call arot(angr,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) - call frquad(aqd,-1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) - angr=-angr - call arot(angr,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) - endif - endif -c put on trailing dipole and quad fringe fields - if(tfrn.ne.0) then -c compute and put on trailing dipole fringe field - gap=cfbgap - xk1=cfbtk1 - call gfrngg(0.d0,rho,2,ht1,mht1,gap,xk1) -cryne 7/11/2002 call gfrngg(0.d0,rho,1,ht1,mht1,gap,xk1) - write(6,*)'7/11/2002 fixed 2nd call to gfrngg for cfbd. RDR' -c call nfrng(rho,2,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c compute and put on trailing quad fringe fields - if((ipset.gt.0) .and. (ipset.le.maxpst)) then - if(iopt.eq.1) then - bqd=coefpset(1) - aqd=coefpset(2) - endif - if(iopt.eq.2) then - bqd=coefpset(1) - aqd=coefpset(2) - endif - if(iopt.eq.3) then - bqd=brho*coefpset(1) - aqd=brho*coefpset(2) - endif -c compute and put on normal quad fringe field - call frquad(bqd,1,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c compute and put on skew quad fringe field - angr=pi/4.d0 - call arot(angr,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - call frquad(aqd,1,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - angr=-angr - call arot(angr,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - endif - endif -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+rho*p1*(pi/180.) - reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) - prevlen=rho*p1*(pi/180.) - nt2prev=nt2 - rhoprev=rho -c============== - goto 2000 -c -c 'quad ': quadrupole -c -c the map for this element is of the form -c frquad*quad*frquad -c with the leading and trailing fringe field maps optional -c -109 continue -c write(6,*)'QUAD:jslice,jsltot,slfrac=',jslice,jsltot,slfrac - lfrn=nint(p3) - tfrn=nint(p4) - if(slfrac.ne.1.0)p1=p1*slfrac -c compute the map for the quad - if(p2.lt.0.d0) call dquad3(p1,-p2,h,mh) - if(p2.eq.0.d0) call drift3(p1,h,mh) - if(p2.gt.0.d0) call fquad3(p1,p2,h,mh) -c put on leading fringe field - if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then - if(lfrn.ne.0)then - call frquad(p2,-1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) - endif - endif -c put on trailing fringe field - if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then - if(tfrn.ne.0)then - call frquad(p2,1,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - endif - endif -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -c -c 'sext ': sextupole -c -110 continue - if(slfrac.ne.1.0)p1=p1*slfrac - call sext3(p1,p2,h,mh) -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -c -c 'octm ': mag. octupole -c -111 continue - if(slfrac.ne.1.0)p1=p1*slfrac - call octm3(p1,p2,h,mh) -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -c -c 'octe ': elec. octupole -c -112 continue - if(jsltot.ne.1)then - write(6,*)'error: octe not yet available with slices!' - stop - endif - call octe(p1,p2,h,mh) - goto 2000 -c -c 'srfc ': short rf cavity -c -113 omega=twopi*p2 - call srfc(p1,omega,h,mh) - goto 2000 -c -c 'rfgap ': rf gap -c -1135 continue -c write(6,*)'RFGAP:jslice,jsltot,slfrac=',jslice,jsltot,slfrac -c---------------------------------------------- - if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then - nseq=prms(5) - if(nseq.eq.0 .and. crms(1).eq.' ')then - if(idproc.eq.0)write(6,*)'ERROR(RFGAP):no data file specified' - call myexit - endif - if(crms(1).eq.' ')then - fname1='rfdata' - ndigits=nseq/10+1 - call num2string(nseq,aseq,ndigits) - j=len_trim(fname1) - fname=fname1(1:j)//aseq(1:ndigits) - else - fname=crms(1) - endif - nunit=0 - estrng='rfgap' - call fnamechk(fname,nunit,ierr,estrng) - if(ierr.eq.1)then - write(6,*)'(rfgap)leaving lmnt due to problem w/ fname' - return - endif - call read_RFdata(nunit,numdata,gaplen) -c Set zedge, which defines where the field is located in space: - zedge=arclen -cryne 5/2/2006: -c determine theta for this cavity now, while jslice=1 - if(prms(7).eq.0.d0)then - thetastore=p(4)*asin(1.0d0)/90. - if(idproc.eq.0)then - write(6,*)'found rfgap absolute phase (deg) =',prms(4) - write(6,*)'found rfgap absolute phase (rad) =',thetastore - endif - else - thetastore=prms(7)*asin(1.0d0)/90.d0 - reftraj(5) - if(idproc.eq.0)then - write(6,*)'found rfgap phase entrance argument (deg) =',prms(7) - write(6,*)'=',prms(7)*asin(1.0d0)/90.d0,' rad' - write(6,*)'computed rfgap absolute phase (rad)=',thetastore - write(6,*)'=',thetastore*90./asin(1.0d0),' deg' - endif - endif - endif -c---------------------------------------------- -cryne 8/12/2001 did this in trlmnt zedge=arclen -cryne 8/12/2001 zmap=p(1) -cryne 8/12/2001 also added the following 2 lines: - zedgg=zedge - if(p1.le.0)zmap=gaplen*slfrac - if(p1.gt.0)then - if(p1.lt.gaplen)zmap=p1*slfrac - if(p1.gt.gaplen)write(6,*)'error:integration length > gap length' - if(p1.gt.gaplen)stop - endif - rffreq=p(2)*4.0*asin(1.0d0) - escale=p(3) -cryne 5/2/2006 theta0=p(4)*asin(1.0d0)/90. - theta0=thetastore - itfile=nint(p(5)) - nstep=nint(p(6)) -cryne 8/11/2001 itype not used for now - itype=0 -cryne-abell Mon Nov 24 18:23:05 PST 2003 - if(lflagmagu)then - if(idproc.eq.0)then - write(6,*)'ERROR: The code is being run with static units, but' - write(6,*)'an rf cavity has been encountered. Simulations that' - write(6,*)'include rf cavities must utilize dynamic units.' - write(6,*)'Re-run using dynamic units.' - endif - call myexit - endif -cryne 5/1/2006 useful constants: - gscal=-omegascl*sl*p0sc/pmass - tscal= omegascl*sl/c -cryne 5/1/2006 for future mods, save reference phase and energy at entry: - refentry5=reftraj(5) !common block variable used in trac - refentry6=reftraj(6) !common block variable used in trac -cryne========================== -cryne 5/5/2006 new code for rfgap multiple reference trajectories - multitrac=0 - imap5=prms(9) - jmap6=prms(10) - if(imap5.ne.1 .or. jmap6.ne.1)multitrac=1 !flag for multitrack - if(multitrac.eq.1)then - call multirfsetup(imap5,jmap6) - do i=1,imap5 - do j=1,jmap6 - t00=tlistin(i) - gam00=ptlistin(j)*gscal - sltemp=sl - sl=c/omegascl - call rfgap(zedgg,zmap,nstep,rffreq,escale,theta0,t00,gam00, & - & itype,h,mh) - sl=sltemp -c Ensure rf cavity map is in correct units for ML/I. Then store it. - call set_rfscale(h,mh) - tmhlist(1:6,1:6,i,j)=mh(1:6,1:6) - hlist(1:923,i,j)=h(1:923) ! h irrelevant for rfgap (rfgap is linear) -c Store the final values of t and pt: - tlistfin(i,j)=t00 - ptlistfin(i,j)=gam00/gscal - enddo - enddo - endif -cryne========================== -c If multiple maps are being used, that have now all been computed. -c But, regardless, ML/I needs to compute the evolution of the reference traj: -c -cryne 5/1/2006 rfgap code was originally written assuming omegascl*sl/c=1. -c This is not necessarily the case for ML/I. -c Temporarily set sl to satisfy this, then reset upon return. - t00=refentry5 - gam00=refentry6*gscal - sltemp=sl - sl=c/omegascl - call rfgap(zedgg,zmap,nstep,rffreq,escale,theta0,t00,gam00,itype, & - &h,mh) - sl=sltemp -c-- -cryne 5/1/2006 moved these from rfgap.f ; The philosophy is that rfgap does not -c make global changes, it just computes a map and the ref traj - gamma=gam00 - gamm1=gamma-1.0 - beta=sqrt((gamma+1.0)*(gamma-1.0))/gamma - brho=pmass*gamma*beta/c -c-- - call set_rfscale(h,mh) - refprev=reftraj - reftraj(5)=t00 - reftraj(6)=gam00/gscal - arclen=arclen+zmap - prevlen=zmap - nt2prev=nt2 - goto 2000 -c -c 'confoc ': "constant focusing" element rdr 08/29/2001 -c -1136 continue -c p1 is the length, p2,p3,p4 are the 3 focusing constants -c if(idproc.eq.0)write(6,*)'at confoc with slfrac=',slfrac - if(slfrac.ne.1.0)p1=p1*slfrac - call confoc(p1,p2,p3,p4,h,mh) -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -cryne 5/1/2006 reftraj(5)=reftraj(5)+p1 -c============== - goto 2000 -c -c 'arot ': axial rotation -c -114 p1rad=pi180*p1 - call arot(p1rad,h,mh) - goto 2000 -c -c 'twsm ': linear matrix via twiss parameters -c -115 iplane=nint(p1) - call twsm(iplane,p2,p3,p4,h,mh) - goto 2000 -c -c 'thlm ': thin lens low order multipole -c -116 continue - call thnl(p1,p2,p3,p4,p5,p6,h,mh) - goto 2000 -c -c 'cplm ': "compressed" low order multipole -c -117 call cplm (p,h,mh) -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -c -c 'cfqd ': combined function quadrupole -c -118 continue - if(jsltot.ne.1)then - write(6,*)'error: cfqd not yet available with slices!' - stop - endif -c call cfdrvr(p,h,mh) -c replaced cfdrvr with cfqd in new (this) afro. rdr and ctm 5/22/02 -c***** - call cfqd(p,h,mh) -c quad fringe fields: - eangle=0.d0 !not needed - rho=1.d0 !not needed - gap=0.d0 !not needed - fint=0.d0 !not needed - iopt=1 !standard MaryLie interpretation of multipole coeffs - kfrn=2 !no dipole fringe fields (1=dipole, 2=quad, 3=both) - ipset=nint(p(2)) - coefpset(1:6)=pst(1:6,ipset) -c leading fringe: - ilfrn=nint(p(3)) - if(ilfrn.ne.0)then -c if(idproc.eq.0)write(6,*)'adding leading fringe to cfqd' - iw=1 - call cgfrngg(iw,eangle,rho,kfrn,gap,fint,iopt,coefpset,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) - endif -c trailing fringe: - itfrn=nint(p(4)) - if(itfrn.ne.0)then -c if(idproc.eq.0)write(6,*)'adding trailing fringe to cfqd' - iw=2 - call cgfrngg(iw,eangle,rho,kfrn,gap,fint,iopt,coefpset,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - endif -c***** -c -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -c -c dispersion matrix (dism) -c -119 call dism(p,h,mh) - go to 2000 -c -c 'sol ': solenoid -c -120 continue - write(6,*) ' == afro::lmnt::sol ==' - write(6,*) ' jslice=',jslice - write(6,*) ' jsltot=',jsltot - write(6,*) ' slfrac=',slfrac - if(jsltot.ne.1)then - write(6,*)'error: sol not yet available with slices!' - stop - endif - call gensol(p,h,mh,jslice,jsltot,slfrac) -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p2-p1 - prevlen=p2-p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+(p2-p1)/(beta*c)*(omegascl) -c============== - go to 2000 -c -c 'mark ': MaryLie marker -c -121 continue - return -c -c 'jmap ': j mapping -c -122 call jmap(h,mh) - go to 2000 -c -c 'dp ': data point -c -123 continue - return -c -c REC multiplet (recm) -c -124 continue - if(jsltot.ne.1)then - write(6,*)'error: recm not yet available with slices!' - stop - endif - call gnrec3(p,h,mh) - go to 2000 -c -c 'spce ': space -c -125 continue - return -c -c 'cfrn ': change or write out fringe field parameters -c for combined function dipole -c -126 continue - mode=nint(p1) - if (mode .eq. 0) then -c change fringe field parameters - cfbgap=p2 - cfblk1=p3 - cfbtk1=p4 - return - endif -c write out values of fringe field parameters - isend=mode - if( isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) - & 'values of fringe field parameters gap, ennfi, exnfi are:' - write(jof,*) cfbgap,cfblk1,cfbtk1 - endif - if( isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) - & 'values of fringe field parameters gap, ennfi, exnfi are:' - write(jodf,*) cfbgap,cfblk1,cfbtk1 - endif - return -c -c 'coil' -c -127 continue - if(jsltot.ne.1)then - write(6,*)'error: coil not yet available with slices!' - stop - endif - call coil(prms) - return -c -c 'intg' -c -128 continue - if(jsltot.ne.1)then - write(6,*)'error: intg not yet available with slices!' - stop - endif - call integ(p,h,mh) - go to 2000 -c -c 'rmap' -c -129 continue - call rmap(p,h,mh) - go to 2000 -c -c 'arc' -c -130 continue - write(6,*)'(lmnt) arc: not implemented' - return -c -c 'transit' -133 continue - write(6,*)'(lmnt) transit' - write(6,*)'p1,p2=',p1,p2 - if(slfrac.ne.1.0)p1=p1*slfrac - call transit(p1,p2,h,mh) - arclen=arclen+p1 - goto 2000 -c 'interface' -134 continue - write(6,*)'(lmnt) interface' - write(6,*)'p1,p2,p3,p4,p5=',p1,p2,p3,p4,p5 - call interface(p1,p2,p3,p4,p5,h,mh) - goto 2000 -c 'rootmap' -135 continue - write(6,*)'(lmnt) rootmap' - write(6,*)'p1,p2,p3,p4=',p1,p2,p3,p4 - write(6,*)'crms(1)=',crms(1) - call rootmap(p1,p2,p3,p4,h,mh) - if(crms(1).eq.'true')then - write(6,*)'computing inverse of rootmap' - call inv(h,mh) - endif - goto 2000 -c -c 'optiprot ': rotation of reference plane for optics calculations -136 continue - write(6,*)'(lmnt) optirot' - ijkind=nint(p2) - call optirot(p1,ijkind,h,mh) - goto 2000 -c -c 'spare5' -137 continue - write(6,*)'(lmnt) spare5' - return -c 'spare6' -138 continue - write(6,*)'(lmnt) spare6' - return -c 'spare7' -139 continue - write(6,*)'(lmnt) spare7' - return -c 'spare8' -140 continue - write(6,*)'(lmnt) spare8' - return -c -c -141 continue -c 'marker': MAD marker - write(6,*)'MAD marker not implemented' - return -c -142 continue -c 'drift': MAD drift - if(slfrac.ne.1.0)p1=p1*slfrac -c write(6,*)'DRIFT:jslice,jsltot,slfrac=',jslice,jsltot,slfrac - isssflag=nint(p2) - if(isssflag.eq.1)then - call drift(p1,h,mh) - else - call drift3(p1,h,mh) - endif - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) - goto 2000 -c -143 continue -c 'rbend': MAD rectangular bend -c write(6,*)'computing a MAD rbend' -c write(6,*)'computing a MAD rbend; jslice,jsltot=',jslice,jsltot -c based on a MaryLie gbnd: -c if(jsltot.ne.1 .and. idproc.eq.0)then -c write(6,*)'WARNING: rbend slices being tested' -c endif - if(p2.eq.0.d0)then - write(6,*)'Error (gbnd): B field equal zero not allowed' - stop - endif - rho=brho/p2 -! -cryne Jan 3, 2005 -c p3 and p4 and the pole face rotation angles in MAD notation, e1 and e2: - e1=p(3) - e2=p(4) -cryne Jan 3, 2005 -c The arguments to gbend, gfrngg, and prot are angles between the -c pole face and the reference trajectory , *not* angles between the -c pole face and reference plane (vertical line for rbends, radial line -c for sbends). The latter is the convention used in MAD. -c These angles need to be checked!!! At this point the RBEND -c implemented here is highly dubious!!! - bndang=p1 - psideg=0.5d0*bndang+e1 - phideg=0.5d0*bndang+e2 - if( abs(psideg-phideg).gt.1.d-6 )then - write(6,*)'ERROR (RBEND): The present RBEND impelmentation' - write(6,*)'requires equal entry and exit angles.' - call myexit - endif -c - lfrn=nint(p5) - tfrn=nint(p6) - gap1=prms(7) - gap2=prms(8) - fint1=prms(9) - fint2=prms(10) - tiltang=prms(11) - if(tiltang.ne.0. .and. idproc.eq.0)then - write(6,*)'WARNING(rbend): tilt keyword being tested' - endif -c*********************************************************** -c*********************************************************** - if(jsltot.eq.1 .and. ihalf.eq.0)then -c procedure for a complete pbnd (no slices, no splitting) - call pbend(rho,p1,h,mh) -c put on the leading fringe field - call gfrngg(psideg,rho,1,ht1,mht1,gap1,fint1) - call concat(ht1,mht1,h,mh,h,mh) -c put on leading prot - call prot(psideg,1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c put on leading arot - call arot(tiltang,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c put on trailing fringe field - call gfrngg(psideg,rho,2,ht1,mht1,gap2,fint2) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing prot - call prot(psideg,2,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing arot - tiltang=-tiltang - call arot(tiltang,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - else -c -c procedure for a sliced and/or split pbnd -c This follows the approach due to Dragt that is described -c in Exhibit 6.6.3 and section 10.9 of the MaryLie manual. - if(slfrac.ne.1.0)p1=p1*slfrac - azero=0. - call nbend(rho,p1,h,mh) - if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then -c put on the leading gbody - call gbend(rho,azero,psideg,azero,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c put on the leading fringe field - call gfrngg(psideg,rho,1,ht1,mht1,gap1,fint1) - call concat(ht1,mht1,h,mh,h,mh) -c put on leading prot - call prot(psideg,1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c put on leading arot - call arot(tiltang,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) - endif - if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then -c put on trailing gbody - call gbend(rho,azero,azero,psideg,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing fringe field - call gfrngg(psideg,rho,2,ht1,mht1,gap2,fint2) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing prot - call prot(psideg,2,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c put on trailing arot - tiltang=-tiltang - call arot(tiltang,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - endif - endif -c*********************************************************** -c*********************************************************** -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+rho*p1*(pi/180.) - reftraj(5)=reftraj(5)+p1*rho*(pi/180.)/(beta*c)*(omegascl) - prevlen=rho*p1*(pi/180.) - nt2prev=nt2 - rhoprev=rho -c============== - goto 2000 -c -145 continue -c 'gbend ': MAD general bend - write(6,*)'MAD gbend not implemented' - return -c -146 continue -c 'quadrupo': MAD quadrupole -c 7/14/2002: need to modify 'quadrupo' to handle tilt -c write(6,*)'QUADRUPOLE:jslice,jsltot,slfrac=',jslice,jsltot,slfrac - lfrn=nint(p3) - tfrn=nint(p4) - if(slfrac.ne.1.0)p1=p1*slfrac -c compute the map for the quad - isssflag=nint(p5) -! write(6,*)'QUAD: isssflag=',isssflag - if(isssflag.eq.1)then - if(p2.lt.0.d0) call dquad(p1,-p2,h,mh) - if(p2.eq.0.d0) call drift(p1,h,mh) - if(p2.gt.0.d0) call fquad(p1,p2,h,mh) - else - if(p2.lt.0.d0) call dquad3(p1,-p2,h,mh) - if(p2.eq.0.d0) call drift3(p1,h,mh) - if(p2.gt.0.d0) call fquad3(p1,p2,h,mh) - endif -c put on leading fringe field - if(jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then - if(lfrn.ne.0)then - call frquad(p2,-1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) - endif - endif -c put on trailing fringe field - if(jslice.eq.jsltot.and.(ihalf.eq.0.or.ihalf.eq.2))then - if(tfrn.ne.0)then - call frquad(p2,1,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - endif - endif -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -c -147 continue -c 'sextupol': MAD sextupole -c 7/14/2002: need to modify 'sextupol' to handle tilt - goto 110 -c -148 continue -c 'octupole': MAD octupole -c 7/14/2002: need to modify 'octupole' to handle tilt - goto 111 -c -149 continue -c 'multipol': MAD general thin multipole - if(imsg1.eq.0)then - imsg1=1 -c write(6,*)'MULTIPOLE MULTIPLIER CORRECT?' - endif - p1b=p1*brho - p2b=p2*brho - p3b=p3*brho/2.d0 - p4b=p4*brho/2.d0 - p5b=p5*brho/6.d0 - p6b=p6*brho/6.d0 - call thnl(p1b,p2b,p3b,p4b,p5b,p6b,h,mh) -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+0.d0 - prevlen=0.d0 - nt2prev=nt2 - reftraj(5)=reftraj(5)+0.d0/(beta*c)*(omegascl) -c============== - goto 2000 -c -c 'solenoid': MAD solenoid -c -150 continue - write(6,*) ' == afro::lmnt::solenoid ==' - write(6,*) ' jslice=',jslice - write(6,*) ' jsltot=',jsltot - write(6,*) ' slfrac=',slfrac - call gensol(p,h,mh,jslice,jsltot,slfrac) -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - prevlen=(p2-p1)*slfrac - arclen=arclen+prevlen - nt2prev=nt2 - reftraj(5)=reftraj(5)+prevlen/(beta*c)*(omegascl) -c============== - go to 2000 - return -c -151 continue -c 'hkicker': MAD hkicker - if(p2.ne.0.d0)then - write(6,*)'error: hkicker strength, kick = ',p2 - write(6,*)'but hkicker currently implemented only w/ kick=0.' - write(6,*)'kick will be ignored (i.e. treat like a drift)' - endif -c - isssflag=nint(p3) -! write(6,*)'HKICKER: isssflag=',isssflag - if(isssflag.eq.1)then - call drift(p1,h,mh) - else - call drift3(p1,h,mh) - endif -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -c -152 continue -c 'vkicker': MAD vkicker - if(p2.ne.0.d0)then - write(6,*)'error: vkicker strength, kick = ',p2 - write(6,*)'but vkicker currently implemented only w/ kick=0.' - write(6,*)'kick will be ignored (i.e. treat like a drift)' - endif -c - isssflag=nint(p3) -! write(6,*)'VKICKER: isssflag=',isssflag - if(isssflag.eq.1)then - call drift(p1,h,mh) - else - call drift3(p1,h,mh) - endif -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -c -153 continue -c 'kicker': MAD kicker - if(p2.ne.0.d0)then - write(6,*)'error: kicker strength hkick = ',p2 - write(6,*)'but kicker currently implemented only w/ hkick=0.' - write(6,*)'hkick will be ignored (i.e. treat like a drift)' - endif - if(p3.ne.0.d0)then - write(6,*)'error: kicker strength vkick = ',p3 - write(6,*)'but kicker currently implemented only w/ vkick=0.' - write(6,*)'vkick will be ignored (i.e. treat like a drift)' - endif - isssflag=nint(p4) -! write(6,*)'KICKER: isssflag=',isssflag - if(isssflag.eq.1)then - call drift(p1,h,mh) - else - call drift3(p1,h,mh) - endif -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -c -154 continue -c 'rfcavity': MAD RF cavity - write(6,*)'MAD RF cavity commented out' - zlen=p1 - volt=p2 - phlagrad=p3 - nharm=nint(p4) -! call rfcavmad(zlen,volt,phlagrad,nharm,h,mh) - call ident(h,mh) -! call set_pscale_mc(h,mh) -c============== -! call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -c -155 continue -c 'elsepara': MAD electrostatic separator - zlen=p1 - efield=p2 -c tilt is parameter 3; not used for now. - isssflag=nint(p4) - if(efield.ne.0.d0)then - write(6,*)'MAD elec separator: zlen,efield=',zlen,efield - call elsepmad(zlen,efield,h,mh) - else - if(isssflag.eq.1)then - write(6,*)'MAD elsep has zero field; treat as 5th order drift' - call drift(p1,h,mh) - else - write(6,*)'MAD elsep has zero field; treat as 3rd order drift' - call drift3(p1,h,mh) - endif - endif -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -cryne 12/27/02 return -c -156 continue -c 'hmonitor': MAD hmonitor - zlen=p1 - if(zlen.eq.0.d0)return - isssflag=nint(p2) - if(isssflag.eq.1)then - call drift(p1,h,mh) - else - call drift3(p1,h,mh) - endif - call hmonitor -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -cryne 12/27/02 return -c -157 continue -c 'vmonitor': MAD vmonitor - zlen=p1 - if(zlen.eq.0.d0)return - isssflag=nint(p2) - if(isssflag.eq.1)then - call drift(p1,h,mh) - else - call drift3(p1,h,mh) - endif - call vmonitor -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -cryne 12/27/02 return -c -158 continue -c 'monitor': MAD monitor - zlen=p1 - if(zlen.eq.0.d0)return - isssflag=nint(p2) - if(isssflag.eq.1)then - call drift(p1,h,mh) - else - call drift3(p1,h,mh) - endif - call monitor -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -cryne 12/27/02 return -c -159 continue -c 'instrument': MAD instrument - zlen=p1 - if(zlen.eq.0.d0)return - isssflag=nint(p2) - if(isssflag.eq.1)then - call drift(p1,h,mh) - else - call drift3(p1,h,mh) - endif - call instrument -c============== - call set_pscale_mc(h,mh) - refprev=reftraj - arclen=arclen+p1 - prevlen=p1 - nt2prev=nt2 - reftraj(5)=reftraj(5)+p1/(beta*c)*(omegascl) -c============== - goto 2000 -cryne 12/27/02 return -c -160 continue -c 'sparem1' - write(6,*)'(lmnt) sparem1' - return -c -161 continue -c 'rcollima': MAD rectangular collimator - write(6,*)'MAD rectangular collimator not implemented' - return -c -162 continue -c 'ecollima': elliptic collimator - write(6,*)'MAD elliptic collimator not implemented' - return -c -163 continue -c 'yrot': MAD yrot -cryne 7/14/2002 same as MaryLie prot? Check this. (sign, etc.) - goto 105 -c -164 continue -c 'srot': MAD srot -cryne 7/14/2002 same as MaryLie arot? Check this. (sign, etc.) - goto 114 -c -165 continue -c 'prot3 ': (original 3rd order version of) rotation of reference plane - ijkind=nint(p2) - call prot3(p1,ijkind,h,mh) - goto 2000 -c -166 continue -c 'beambeam:' MAD beam-beam kick - write(6,*)'MAD beambeam element not implemented' - return -c -167 continue -c 'matrix': input a matrix using the MAD syntax - write(6,*)'matrix input (MAD syntax) element not implemented' - return -c -168 continue -c 'profile1d' - ncol=nint(p1) - nbins=nint(p2) -!p3 is the max number of file names in a sequence of output files - nprecision=nint(p4)-1 - nunit=nint(p5) - rwall=prms(7) - if(idproc.eq.0)write(6,*)'(lmnt) profile1d, rwall=',rwall -!p6 is a counter that gets incremented and appended to a sequence of file names - fname1=crms(1) - fname=fname1 - if(p3.ne.0)then - xdigits=log(p3)/log(10.d0) - ndigits=1+int(xdigits) - prms(6)=prms(6)+1.d0 - nseq=nint(prms(6)) !nseq is the counter that gets converted to a string - call num2string(nseq,aseq,ndigits) - j=len_trim(fname1) - fname=fname1(1:j)//aseq(1:ndigits) - endif - if(nunit.eq.0)then - estrng='profile1d' - call fnamechk(fname,nunit,ierr,estrng) - if(ierr.eq.1)then - write(6,*)'(profile1d)leaving lmnt due to problem w/ fname' - return - endif - endif - call ibcast(nunit) - if(nunit.gt.0)prms(5)=nunit -! call pwritez(nunit,idmin,idmax,nprecision) - if(ncol.gt.0)then - call profile1d(ncol,nbins,rwall,arclen,nunit,fname,nprecision) - else - call profilerad(ncol,nbins,rwall,arclen,nunit,fname,nprecision) - endif - if(crms(2).eq.'true' .or. p3.ne.0)then - if(idproc.eq.0)write(6,*)'closing file connected to unit ',nunit - close(nunit) - prms(5)=0.d0 - endif - if(crms(3).eq.'true')then -! if(idproc.eq.0)write(6,*)'flushing file unit ',nunit - call myflush(nunit) - endif - if(idproc.eq.0)then - write(6,*)'s=',arclen,' ;profile1d output to file ',fname - endif - return -c -169 continue -c 'yprofile' - if(idproc.eq.0)write(6,*)'(lmnt) yprofile' - return -c -170 continue -c 'tprofile' - if(idproc.eq.0)write(6,*)'(lmnt) tprofile' - return -c -171 continue -c 'hkick': synonym for MAD hkicker - goto 151 -c -172 continue -c 'vkick': synonym for MAD vkicker - goto 152 -c -173 continue -c 'kick': synonym for MAD kicker - goto 153 -c -174 continue -c 'hpm' - write(6,*)'(hpm) half parallel faced magnet' - write(6,*)'(hpm) b,phideg,iwhich=',p1,p2,p3 - rho=brho/p1 - phideg=p2 - iwhich=p3 - call hpf(rho,iwhich,phideg,h,mh) - goto 2000 -c -175 continue -c 'nlrf': non-linear RF cavity - if (idproc.eq.0) then - write(6,*) '(lmnt) nlrf: ntrk jslice jsltot slfrac ihalf = ', & - & ntrk,jslice,jsltot,slfrac,ihalf - write(6,*)' ...under construction...' - endif - if (jslice.eq.1.and.(ihalf.eq.0.or.ihalf.eq.1))then - ! for the first slice, read or compute generalized gradients - ! (for now assume pre-computed generalized gradients) - nunit=0 - estrng='nlrf' - call fnamechk(crms(2),nunit,ierr,estrng) - if (ierr.eq.1) then - if (idproc.eq.0) then - write(6,*) '<*** ERROR ***> (lmnt) nlrf: ' - write(6,*) 'leaving because of problems with file ',crms(2) - endif - call myexit() - endif - call read_egengrads(nunit) - ! also record element length and z at entrance of element - gaplen=eggrdata%zmax-eggrdata%zmin - zedge=arclen - endif - if (idproc.eq.0) then - write(6,*) 'zedge, gaplen =',zedge,gaplen; call myflush(6) - end if - ! for all slices: - ! compute and check slice length - zedgg=zedge - zlen=p2-p1 - if (zlen.le.0) then - zmap=gaplen*slfrac - else - if (zlen.le.gaplen) then - zmap=zlen*slfrac - else - if (idproc.eq.0) then - write(6,*) '<*** ERROR ***> (lmnt) nlrf:' - write(6,*) ' Integration length exceeds gap length!' - endif - call myexit() - endif - endif - ! note parameters - zlc=arclen-zedge - rffreq=twopi*p(3) - rf_phase=p(4)*pi180 - rf_escale=p(5) - nstep=nint(p(6)) - !nstep=eggrdata%nz_intrvl - nslices=nint(p(7)) - if(lflagmagu)then - if(idproc.eq.0)then - write(6,*) '<*** ERROR ***> (lmnt) nlrf:' - write(6,*) ' Simulations that contain RF cavities must use' - write(6,*) ' dynamic units! Re-run using dynamic units.' - endif - call myexit - endif - ! note initial time-of flight and initial gamma - t00=reftraj(5) - gam00=(-reftraj(6)*omegascl*sl*p0sc)/pmass - if (idproc.eq.0) then - write(6,*) 'calling subroutine nlrfcav():' - write(6,*) ' zedge =',zedge - write(6,*) ' zedgg, zlc, zmap, nstep =',zedgg,zlc,zmap,nstep - write(6,*) ' rffreq =',rffreq - write(6,*) ' t00, gam00 =',t00,gam00 - write(6,*) ' reftraj(5), reftraj(6) =',reftraj(5),reftraj(6) - endif - call nlrfcav(zedgg,zlc,zmap,nstep,t00,gam00,h,mh) - if (idproc.eq.0) then - write(6,*) 'returned from subroutine nlrfcav():' - write(6,*) ' zedge =',zedge - write(6,*) ' zedgg, zlc, zmap, nstep =',zedgg,zlc,zmap,nstep - write(6,*) ' rffreq =',rffreq - write(6,*) ' t00, gam00 =',t00,gam00 - endif - refprev=reftraj - ! rescale map - !call set_rfscale(h,mh) - ! update reftraj(5:6) and current arc length, - reftraj(5)=t00 - reftraj(6)=-gam00*pmass/(omegascl*sl*p0sc) - if (idproc.eq.0) then - write(6,*) ' reftraj(5), reftraj(6) =',reftraj(5),reftraj(6) - endif - arclen=arclen+zmap - ! and update length and index code of previous element - prevlen=zmap - nt2prev=nt2 - goto 2000 -c - return -c -c -c 2: user-supplied elements ************************************ -c -c 'usr1 ','usr2 ','usr3 ','usr4 ','usr5 ', -12 go to (201, 202, 203, 204, 205, -c 'usr6 ','usr7 ','usr8 ','usr9 ','usr10 ', - & 206, 207, 208, 209, 210, -c 'usr11 ','usr12 ','usr13 ','usr14 ','usr15 ', - & 211, 212, 213, 214, 215, -c 'usr16 ','usr17 ','usr18 ','usr19 ','usr20 ' - & 216, 217, 218, 219, 220),kt2 -c -201 call user1(p) - return -202 call user2(p) - return -203 call user3(p) - return -204 call user4(p) - return -205 call user5(p) - return -206 call user6(p,th,tmh) - return -207 call user7(p,th,tmh) - return -208 call user8(p,th,tmh) - return -209 call user9(p,th,tmh) - return -210 call user10(p,th,tmh) - return -211 call user11(p,th,tmh) - return -212 call user12(p,th,tmh) - return -213 call user13(p,th,tmh) - return -214 call user14(p,th,tmh) - return -215 call user15(p,th,tmh) - return -216 call user16(p,th,tmh) - return -217 call user17(p,th,tmh) - return -218 call user18(p,th,tmh) - return -219 call user19(p,th,tmh) - return -220 call user20(p,th,tmh) - return -c -c -c 3: parameter sets ********************************************** -c -c 'ps1 ','ps2 ','ps3 ','ps4 ','ps5 ', -13 go to (301, 302, 303, 304, 305, & -c 'ps6 ','ps7 ','ps8 ','ps9 '/ - & 306, 307, 308, 309),kt2 -c -301 call pset(p,1) - return -302 call pset(p,2) - return -303 call pset(p,3) - return -304 call pset(p,4) - return -305 call pset(p,5) - return -306 call pset(p,6) - return -307 call pset(p,7) - return -308 call pset(p,8) - return -309 call pset(p,9) - return -c -c 4-6: random elements -c -14 continue -15 continue -16 continue - write(jof ,9014) - write(jodf,9014) - 9014 format(' error in lmnt: random element reached') - call myexit -c -c 7: simple commands ************************************* -c -17 continue -c 'rt ','sqr ','symp ','tmi ','tmo ', - go to (701, 702, 703, 704, 705, -c 'pmif ','circ ','stm ','gtm ','end ', - & 706, 707, 708, 709, 710, -c 'ptm ','iden ','whst ','inv ','tran ', - & 711, 712, 713, 714, 715, -c 'revf ','rev ','mask ','num ','rapt ', - & 716, 717, 718, 719, 720, -c 'eapt ','of ','cf ','wnd ','wnda ', - & 721, 722, 723, 724, 725, -c 'ftm ','wps ','time ','cdf ','bell ', - & 726, 727, 728, 729, 730, -c 'wmrt ','wcl ','paws ','inf ','dims ', - & 731, 732, 733, 734, 735, -c 'zer ','sndwch ','tpol ','dpol ','cbm ', - & 736, 737, 738, 739, 740, -c 'poisson ','preapply','midapply','autoapply','autoconc' - & 741, 742, 743, 744, 745, -c 'rayscale','beam ','units ','autoslic','verbose ' - & 746, 747, 748, 749, 750, -c 'mask6 ','arcreset','symbdef ','particledump','raytrace' - & 751, 752, 753, 754, 755, -c 'autotrack','sckick','moments ','maxsize','reftraj', - & 756, 757, 758, 759, 760, -c 'initenv','envelopes','contractenv','setreftraj','setarclen', - & 761, 762, 763, 764, 765, -c 'wakedefault','emittance','matchenv','fileinfo','egengrad', - & 766, 767, 768, 769, 770, -c 'wrtmap ','rdmap ','sparec7','sparec8','sparec9'/ - & 771, 772, 773, 774, 775),kt2 -c -c 'rt ': ray trace -c -701 continue - icfile=nint(p1) - nfcfle=nint(p2) - norder=nint(p3) - ntrace=nint(p4) - nwrite=nint(p5) - fname1=crms(1) - fname2=crms(2) - iotemp=jof - jfctmp=jfcf - jfcf=nfcfle -cryne 3/27/04 ntaysym=1 for taylor, =2 for symplectic -cryne note: originally MaryLie code did symplectic if norder=5 - ntaysym=1 - if(norder.ge.5)ntaysym=2 - if(p6.lt.0.)jof=jodf - ibrief=iabs(nint(p6)) - estrng='rt' - if(icfile.gt.0)then - if(fname1.ne.' ')then - call fnamechk(fname1,icfile,ierr,estrng) - if(ierr.eq.1)then - write(6,*)'(rt) leaving lmnt due to problem w/ fname1' - return - endif - endif - endif -!bug fix on jan 3 if(jfcfile.gt.0)then - if(nfcfle.gt.0)then - if(fname2.ne.' ')then - call fnamechk(fname2,nfcfle,ierr,estrng) - if(ierr.eq.1)then - write(6,*)'(rt) leaving lmnt due to problem w/ fname2' - return - endif - endif - endif - call trace(icfile,jfcf,ntaysym,norder,ntrace,nwrite,0,0,5,0, & - & th,tmh) - jof=iotemp - jfcf=jfctmp - return -c -c square the existing map: -c -702 call concat(th,tmh,th,tmh,th,tmh) - write(jof,5702) - 5702 format(1h ,'existing map concatenated with itself') - if(ntrk.eq.1)write(jof,9702) - 9702 format(1h ,'warning: map squared in turtle mode') - return -c -c symplectify matrix in transfer map -c -703 continue - iopt=nint(p1) - ijkind=nint(p2) - call sympl(iopt,ijkind,th,tmh) - return -c -c input transfer map from an external file: -c -704 continue - iopt=nint(p1) - ifile=nint(p2) - nopt=nint(p3) - nskp=nint(p4) -c rewind only option - if (nopt.eq.1 .and. nskp.eq.-1) then - rewind ifile - write(jof,5704) ifile - 5704 format(1x,'file unit ',i3,' rewound') - return - endif -c -c other options -c - mpitmp=mpi - mpi=ifile - call mapin(nopt,nskp,h,mh) - mpi=mpitmp -c option when tracking (procedure at end) - if(ntrk.eq.1) goto 2000 -c options when not tracking - if(iopt.eq.1) call concat(th,tmh,h,mh,th,tmh) - if(iopt.eq.2) call mapmap(h,mh,th,tmh) - return -c -c output transfer map to an external file (tmo): -c -705 ifile=nint(p1) - mpotmp=mpo - mpo=ifile - call mapout(0,th,tmh) - mpo=mpotmp - return -c -c print contents of file master input file: -c -706 continue - itype=nint(p1) - ifile=nint(p2) - isend=nint(p3) - fname=crms(1) - if((ifile.eq.5).or.(ifile.eq.11).or.(ifile.eq.13))then - write(6,*)'Error: cannot write to unit 5, 11, or 13 w/ PMIF.' - write(6,*)'PMIF command will be ignored' - return - endif - estrng='PMIF' - if((ifile.ne.6).and.(fname.ne.' ')) & - & call fnamechk(fname,ifile,ierr,estrng) - if(ierr.eq.1)return -c - jtmp=jodf - jodf=ifile - if(isend.eq.1.or.isend.eq.3)call pmif(jof,itype,fname) - if(isend.eq.2.or.isend.eq.3)call pmif(jodf,itype,fname) - jodf=jtmp - return -c -c Note: the program should never get here. -c (cqlate is called directly from tran) -c -707 write(jof ,9707) - write(jodf,9707) - 9707 format(' error: reached element "circ" in routine lmnt') - call myexit -c -c store the existing transfer map -c -708 continue - kynd='stm' - nmap=nint(p1) - if ((nmap.gt.20).or.(nmap.lt.1)) then - write(jof,9708) nmap - 9708 format(1x,'nmap=',i3,1x,'trouble with stm:nmap < 1 or > 20') - call myexit - else - call strget(kynd,nmap,th,tmh) - return - endif -c -c get transfer map from storage -c -709 continue - kynd='gtm' - iopt=nint(p1) - nmap=nint(p2) -c - if ((nmap.gt.20).or.(nmap.lt.1)) then - write(jof,9709) nmap - 9709 format(1x,'nmap=',i3,1x,'trouble with gtm:nmap < 1 or > 20') - call myexit - return - endif -c - call strget(kynd,nmap,h,mh) -cryne--- 08/21/2001 - call mapmap(h,mh,hprev,mhprev) -c option when tracking(procedure at end) - if(ntrk .eq. 1) goto 2000 -c options when not tracking - if(iopt.eq.1) call concat(th,tmh,h,mh,th,tmh) - if(iopt.eq.2) call mapmap(h,mh,th,tmh) - return -c -c end of job: -c -710 continue - if(idproc.eq.0)then - write(jof,5710) - 5710 format(/1x,'end of MARYLIE run') -! write(6,*)'total length=',arclen - endif - iprinttimers=0 - if(crms(1).eq.'true')iprinttimers=1 - call myexit - return -c -c print transfer map: -c -711 continue - n1=nint(p1) - n2=nint(p2) - n3=nint(p3) - n4=nint(p4) - n5=nint(p5) - if(n5.eq.1)then - if(lautotrk.eq.0)then - call pcmap(n1,n2,n3,n4,th,tmh) - else - call pcmap(n1,n2,n3,n4,hprev,mhprev) - endif - endif - if(n5.eq.2)then - if(lautotrk.eq.0)then - call psrmap(n1,n2,th,tmh) - else - call psrmap(n1,n2,hprev,mhprev) - endif - endif - if(n5.eq.3)then - if(lautotrk.eq.0)then - call pdrmap(n1,n2,th,tmh) - else - call pdrmap(n1,n2,hprev,mhprev) - endif - endif - return -c -c identity mapping: -c -712 continue - call ident(th,tmh) -cryne 08/16/2001 - call ident(hprev,mhprev) - return -c -c write history of beam loss -c -713 call whst(p) - goto 2000 -c -c inverse: -c -714 continue - call inv(th,tmh) - return -c -c transpose: -c -715 call mtran(tmh) - return -c -c reverse factorization: -c -716 iord=nint(p1) - call revf(iord,th,tmh) - return -c -c Dragt's reversal -c -717 call rev(th,tmh) - return -c -c mask off selected portions of transfer map: -c -718 call mask(p,th,tmh) - return -c -c number lines in a file -c -719 call numfile(p) - return -c -c aperture particle distribution -c -720 call rapt(p) - return -c -721 continue - mode=nint(p1) - if (mode .eq. 1) call eapt(p) - return -c -c open files -c -722 call of(p) - return -c -c close files -c -723 call cf(p) - return -c -c window particle distribution -c -724 call wnd(p) - return -725 call wnda(p) - return -c -c filter transfer map -c -726 call ftm(p,th,tmh) - return -c -c write parameter set -c -727 ipset = nint(p(1)) - isend = nint(p(2)) - call wps(ipset,isend) - return -c -c write time -c -728 call mytime(p) - return -c -c change output drop file -c -729 jodf = nint(p(1)) - return -c -c ring bell -c -730 continue -cryne call bell - if(idproc.eq.0)write(6,*)'BELL BELL BELL BELL BELL BELL BELL ' - return -c -c write value of merit function -c -731 ifn = nint(p(1)) - isend = nint(p(2)) - call wmrt(ifn,isend) - return -c -c write contents of loop -c -732 call wcl(p) - return -c -c pause (paws) -c -733 continue - write(jof,*) ' press return to continue' - read(5,7330) iwxyz -7330 format(a1) - return -c -c change or write out infinities (inf) -c -734 continue - mode=nint(p1) - if (mode .eq. 0) then -c change infinities - xinf=p2 - yinf=p3 - tinf=p4 - ginf=p5 - return - endif -c write out values of infinities - isend=mode - if( isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) - & 'values of infinities xinf, yinf, tinf, ginf are:', - & xinf,yinf,tinf,ginf - endif - if( isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) - & 'values of infinities xinf, yinf, tinf, ginf are:', - & xinf,yinf,tinf,ginf - endif - return -c -c get dimensions (dims) -c -735 continue - return -c -c change or write out values of zeroes (zer) -c -736 continue - mode=nint(p1) - if (mode .eq. 0) then -c change values of zeroes - fzer=p2 - detz=p3 - return - endif -c write out values of zeroes - isend=mode - if( isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) - & 'values of zeroes fzero, detzero are:', - & fzer,detz - endif - if( isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) - & 'values of zeroes fzero, detzero are:', - & fzer,detz - endif - return -c -c sndwch -c -737 continue - n1=nint(p1) - if(n1.eq.0)then - call sndwch(hprev,mhprev,th,tmh,th,tmh) - else - call sndwchi(hprev,mhprev,th,tmh,th,tmh) - endif - return -c -c twiss polynomial (tpol) -c -738 continue - call tpol(p,th,tmh) - return -c -c dispersion polynomial (dpol) -c -739 continue - call dpol(p,th,tmh) - return -c -c change or write out beam parameters (cbm) -c -740 continue - job=nint(p1) - if (job .eq. -1) then - prms(1)=0.d0 - prms(2)=brho - prms(3)=gamm1 - endif - if (job .eq. 0) then - brho=p2 - gamm1=p3 -c recomputation of relativistic beta and gamma factors: - gamma=gamm1+1.d0 - stuff2=gamm1*(gamma+1.d0) - stuff1=sqrt(stuff2) - beta=stuff1/gamma - endif - if ((job .eq. 1) .or. (job .eq. 3)) then - write(jof,*) ' beam parameters are: ', brho,gamm1 - endif - if ((job .eq. 2) .or. (job .eq. 3)) then - write(jodf,*) ' beam parameters are: ', brho,gamm1 - endif - return -c -c POISSON -c set parameters for poisson solver -c -741 continue -! Here are the real (array p) and character (array cparams) parameters: -! array p and cparam are dimensioned p(60) and cparams(60), but only -! the first few elements (12 and 17, resp) are used in this case. -! Somehow these need to be made available to spch3d. -! For now they are stored in common, then passed to spch3d through -! its argument list: - rparams(1:nparams)=prms(1:nparams) - cparams(1:ncparams)=crms(1:ncparams) -! -! this needs a lot of cleaning up. RDR 12 Nov 2003 -! -! p(1-3)=nx,ny,nz -! p(4-5)=xmin,xmax -! p(6-7)=ymin,ymax -! p(8-9)=zmin,zmax -! p(10-11)=anag_patchsize,anag_refineratio -! cparam(1) : solver [i.e. solver type] -! cparam(2) : geometry [not currently used] -! cparam(3) : gridsize [fixed or variable] -! cparam(4) : [determines whether # of gridpoints is fixed or variable] -! cparam(5-7) : xboundary,yboundary,zboundary [open,dirichlet,periodic] -! cparam(8) : boundary [not currently used; will specify x,y,z together] -! cparam(9) : solving_for [determines whether solving for phi or E] -! cparam(10): densityfunction ["delta" (old method); "linear" (new)] -! cparam(11): chombo_input_file [default: 'undefined'] -! cparam(12): anag_smooth [default: 'none'] -! cparam(13-17)= 5 spares -! - nxsave=nint(prms(1)) - nysave=nint(prms(2)) - nzsave=nint(prms(3)) -c - noresize=1 - if(crms(4).eq.'variable')noresize=0 - nadj0=0 - if(crms(7).eq.'periodic')nadj0=1 -cryne--- Dec 29, 2002 - if(crms(5).eq.'dirichlet' .and. & - & crms(6).eq.'dirichlet' .and. & - & crms(7).eq.'dirichlet')then - idirich=1 - else - idirich=0 - endif -cryne--- - kfixbdy=0 - if(crms(3).eq.'fixed')kfixbdy=1 - xmin0=prms(4) - xmax0=prms(5) - ymin0=prms(6) - ymax0=prms(7) - zmin0=prms(8) - zmax0=prms(9) -c Dec 29, 2002 -c initialize the green function to "not made" - madegr=0 -c--------------------------------------- -cryne Nov 12, 2003 Removed code dealing with ntrkorder and ntrktype -cryne because that has to do with dynamics, and this type code -cryne has to do with the Poisson solver. -cryne The dynamics info should be specified in the autotrack command -c--------------------------------------- -cryne April 23, 2003 - if (crms(9).eq.'e'.or.crms(9).eq.'E') then - idirectfieldcalc=1 - else if (crms(9).eq.'phi'.or.crms(9).eq.'Phi' & - & .or.crms(9).eq.'PHI') then - idirectfieldcalc=0 - else - if (idproc.eq.0) then - write(6,*) ' <*** ERROR ***> unrecognized value ',crms(9) - write(6,*) ' for parameter \"solving_for\" in POISSSON.' - end if - call myexit() - end if - if (crms(10).eq.'delta'.or.crms(9).eq.'Delta') then - idensityfunction=0 - else if (crms(10).eq.'linear'.or.crms(10).eq.'Linear') then - idensityfunction=1 - else - if (idproc.eq.0) then - write(6,*) ' <*** ERROR ***> unrecognized value ',crms(9) - write(6,*) ' for parameter \"densityfunction\" in POISSSON.' - end if - call myexit() - end if - if (idproc.eq.0) then - write(6,*) 'idirectfieldcalc=',idirectfieldcalc - if (idirectfieldcalc.eq.0) then - write(6,*) ' solving for the scalar potential phi' - else - write(6,*) ' solving for the electric field' - end if - write(6,*) 'idensityfunction=',idensityfunction - if (idensityfunction.eq.0) then - write(6,*) ' using delta \"interpolation\" for charges' - else - write(6,*) ' using linear interpolation charge distribution,' - write(6,*) ' (i.e. using integrated Green function technique)' - end if - endif -c -c--------------------------------------- -!dbs Nov03 - if(crms(1).eq.'fft')then - isolve=1 - elseif(crms(1).eq.'fft2')then - if(idirich.eq.0)then - isolve=10 !alternate (ANAG) infinite domain solver - else - isolve=20 !alternate (ANAG) homogenous Dirichlet solver - endif - elseif(crms(1).eq.'chombo')then - if(idirich.eq.0)then - isolve=30 !Chombo infinite domain solver - else - isolve=40 !Chombo homogenous Dirichlet solver - endif - else - if(idproc.eq.0) - & write(6,*) '(poisson) error: solver=' ,TRIM(crms(1)) - & ,' is invalid. Use fft, fft2 or chombo' - call myexit - endif - - ! set extra paramters for ANAG Poisson solver (James algorithm) - if( isolve .NE. 1 )then - ! parameters for James algorithm - if( crms(5).eq.'open' .AND. crms(6).eq.'open' .AND. - & crms(7).eq.'open' )then - ! anag_patchsize: size of grid blocks in FFT2 solver (must be multiple of 4) - ! anag_refineratio: to create MLC global coarse grid from MLI grid - anagpatchsize = prms(10) - anagrefratio = prms(11) - endif - - !mehrstellen smoothing on phi after MLC solve - !anag_smooth= - if( crms(12).eq.' ' .OR. crms(12).eq.'none' .OR. - & crms(12).eq.'off' )then - anagsmooth = 0 - else - anagsmooth = 1 - endif - endif - - !chombo_file= (see spch3d_chombo.f::CH_READINFILE()) - if( crms(11).eq.'undefined')then - chombofilename = ' ' - else - if( LEN_TRIM(crms(11)) .GT. LEN( chombofilename ) )then - if(idproc.eq.0) - & write(6,*)'(poisson) error: chombo_input_file is too long' - call myexit - endif - chombofilename = crms(11) - endif - - if( idproc.eq.0 .and. iverbose.gt.3 )then - write(6,*) 'lmnt: (poisson) input solver ',TRIM(crms(1)) - & ,', isolve = ',isolve - endif -!dbs -c--------------------------------------- -c -c set the flag to indicate that s.c. parameters have been set: -cryne Nov 12, 2003: this was commented out Dec 2, 2002, but -cryne it belongs here so I am putting it back. - nspchset=1 - if(idproc.eq.0)then - write(6,*)'setting poisson parameters:' - write(6,*)'nx,ny,nz=',nxsave,nysave,nzsave - write(6,*)'noresize,nadj=',noresize,nadj0 -cryne Nov 12, 2003: this really *is* wrong, so I am commenting out: -c if(nspchset.eq.1)then -c write(6,*)'autotracking w/ space charge from this point on' -c write(6,*)'order=',ntrkorder -c endif - endif -cryne Dec 29, 2002: added module spchdata - nx=nxsave - ny=nysave - nz=nzsave - n1=2*nx - n2=2*ny - n3=2*nz - nadj=nadj0 - n3a=2*nz-nadj*nz -cryne Dec 29, 2002: for Dirichlet case, double grid in all 3 dimensions - if(idirich.eq.1)n3a=2*nz - call new_spchdata(nx,ny,nz,n1,n2,n3a,isolve) - if(idproc.eq.0)then - write(6,*)'DONE ALLOCATING SPACE CHARGE ARRAYS' - endif - return -c -c preapply commands automatically -c -742 continue -c n1=nint(p1) -c autostr(1)=cmenu(n1) - autostr(1)=crms(1) - if(iverbose.ge.1)write(6,*)'(lmnt)autostr(1)=',autostr(1) - lautoap1=1 - if(autostr(1).eq.'off')then - if(iverbose.ge.1)write(6,*)'turning off pre-autoapply' - lautoap1=0 - endif -c restrict automatic application unless "applyto=all" : - lrestrictauto=1 - if(crms(2).eq.'all')lrestrictauto=0 - return -c -c midapply commands automatically -c -743 continue -c n1=nint(p1) -c autostr(2)=cmenu(n1) - autostr(2)=crms(1) - if(iverbose.ge.1)write(6,*)'(lmnt)autostr(2)=',autostr(2) - lautoap2=1 - if(autostr(2).eq.'off')then - if(iverbose.ge.1)write(6,*)'turning off mid-autoapply' - lautoap2=0 - endif -c restrict automatic application unless "applyto=all" : - lrestrictauto=1 - if(crms(2).eq.'all')lrestrictauto=0 - return -c -c autoapply (actually, this is 'post-apply') commands automatically -c -744 continue -c n1=nint(p1) -c autostr(3)=cmenu(n1) - autostr(3)=crms(1) - if(iverbose.ge.1 .and. idproc.eq.0) & - & write(6,*)'(lmnt/posapply)autostr(3)=',autostr(3) - lautoap3=1 - if(autostr(3).eq.'off')then - if(iverbose.ge.1 .and. idproc.eq.0) & - & write(6,*)'turning off post-autoapply' - lautoap3=0 - endif -c restrict automatic application unless "applyto=all" : - lrestrictauto=1 - if(crms(2).eq.'all')lrestrictauto=0 - return -c -c autoconc ('auto-concatenate') -c -745 continue - if(crms(1).eq.'true')then - lautocon=1 - lautotrk=0 - if(idproc.eq.0)write(6,*)'lautocon=1, lautotrk=0' - elseif(crms(1).eq.'false')then - lautocon=0 - lautotrk=1 - if(idproc.eq.0)write(6,*)'lautocon=0, lautotrk=1' - elseif(crms(1).eq.'sandwich')then - lautocon=2 - lautotrk=0 - if(idproc.eq.0)write(6,*)'lautocon=2, lautotrk=0' - if(idproc.eq.0)write(6,*)'using sndwch instead of concat' - elseif(crms(1).eq.'revsandwich')then - lautocon=-2 - lautotrk=0 - if(idproc.eq.0)write(6,*)'lautocon=-2, lautotrk=0' - if(idproc.eq.0)write(6,*)'using sndwchi instead of concat' - else - if(idproc.eq.0)then - write(6,*)'error(autoconc): do not understand parameter' - endif - call myexit - endif - return -c -c rayscale ('scale zblock array') -c -746 continue -c if(idproc.eq.0.and.iverbose.gt.0)write(6,*)'scaling zblock array' - if(idproc.eq.0)then - write(6,*)'scaling zblock array; p(1)-p(6)=' - write(6,*)p(1),p(2) - write(6,*)p(3),p(4) - write(6,*)p(5),p(6) - endif - do 7462 j=1,nraysp - do 7461 i=1,6 - zblock(i,j)=zblock(i,j)*p(i) - 7461 continue - 7462 continue - - return -c -c spare1c -c -747 continue - write(6,*)'(lmnt) BEAM type code codes here' - return -c -c spare2c -c -748 continue - write(6,*)'(lmnt) UNITS type code codes here' - return -c -c autoslice: -749 continue - if(crms(1).ne.'local' .and. crms(1).ne.'global' .and. & - & crms(1).ne.'none')then - if(idproc.eq.0)then - write(6,*)'Error(autoslice):' - write(6,*)'Invalid slice control (local/global/none):',crms(1) - write(6,*)'This autoslice command will be ignored' - endif - return - endif - if(prms(1).ne.0.d0 .and. prms(2).ne.0.d0)then - if(idproc.eq.0)then - write(6,*)'Error(autoslice): Cannot specify both' - write(6,*)'# of slices and length between slices.' - write(6,*)'Current values are:' - write(6,*)'# of slices= ',prms(1) - write(6,*)'length between slices= ',prms(2) - write(6,*)'This autoslice command will be ignored' - endif - return - endif -! input values are all valid; set autoslice parameters: -! default: - slicetype='slices' -! set parameters: - if(crms(1).eq.'none')then - slicetype='none' - slicevalue=0.d0 - endif - if(prms(1).gt.0.d0)then - slicetype='slices' - slicevalue=prms(1) - endif - if(prms(2).gt.0.d0)then - slicetype='interval' - slicevalue=prms(2) - endif - sliceprecedence=crms(1) -c space charge kick: -c--------------------------------------- -cryne Nov 14, 2003 -cryne should probably get rid of this code eventually. -cryne does not make sense to specify whether or not to sckick -cryne when specifying the autoslice command. -cryne sckick info should be specified in the autotrack command, -cryne and in fact it should be enabled by default if autotracking -cryne is enabled, unless the user explicitly prevents it. -c if(crms(2).eq.'true')nsckick=1 -c inefficient, but works. fix later. rdr dec 9 2002 -c n1=index(crms(2),'1') -c n2=index(crms(2),'2') -c n3=index(crms(2),'3') -c n4=index(crms(2),'4') -c n5=index(crms(2),'5') -c n6=index(crms(2),'6') -c n7=index(crms(2),'7') -c n8=index(crms(2),'8') -c n9=index(crms(2),'9') -c if(n1.ne.0)ntrkorder=1 -c if(n2.ne.0)ntrkorder=2 -c if(n3.ne.0)ntrkorder=3 -c if(n4.ne.0)ntrkorder=4 -c if(n5.ne.0)ntrkorder=5 -c for now 6, 7, 8, or 9 are all the same as order 5: -c if(n6.ne.0)ntrkorder=5 -c if(n7.ne.0)ntrkorder=5 -c if(n8.ne.0)ntrkorder=5 -c if(n9.ne.0)ntrkorder=5 -c ntay=index(crms(2),'tay') -c nsym=index(crms(2),'sym') -c if(ntay.ne.0)ntrktype=1 -c if(nsym.ne.0)ntrktype=2 -c if(n1+n2+n3+n4+n5+n6+n7+n8+n9+ntay+nsym.ne.0)nspchset=1 -c--------------------------------------- - if(idproc.eq.0)then - write(6,*)'autoslice;' - write(6,*)'crms(1)=',crms(1) - write(6,*)'crms(2)=',crms(2) - write(6,*)'crms(3)=',crms(3) - write(6,*)'slicetype=',slicetype - write(6,*)'sliceprecedence=',sliceprecedence - write(6,*)'slicevalue=',slicevalue -c write(6,*)'nsckick=',nsckick -c if(nspchset.ne.0)write(6,*)'ntrktype=',ntrktype -c if(nspchset.ne.0)write(6,*)'ntrkorder=',ntrkorder - endif - return -c -c verbose: -750 continue - iverbose=p(1) - return -c -c mask6: -751 continue - write(6,*)'(LMNT) Performing MASK6 command' - call mask6(p,th,tmh) - return -c -c arcreset: -752 continue - if(idproc.eq.0)write(6,*)'resetting arc length to zero' - arclen=0.d0 - return -c symbdef (="symbolic default"): -c this does not have any meaning in this routine; it only affects -c how the parser interprets in arithmentic expressions -c symbolic names that have not been define. Simply return from here. -753 continue - return -c -c particledump: -754 continue - idmin=nint(p1) - idmax=nint(p2) - if(idmax.eq.0)idmax=maxray - nphysunits=nint(prms(7)) -!p3 is the max number of file names in a sequence of output files - nprecision=nint(p4)-1 - nunit=nint(p5) -!p6 is a counter that gets incremented and appended to a sequence of file names - fname1=crms(1) - fname=fname1 - if(p3.ne.0)then - xdigits=log(p3)/log(10.d0) - ndigits=1+int(xdigits) - prms(6)=prms(6)+1.d0 - nseq=nint(prms(6)) !nseq is the counter that gets converted to a string - call num2string(nseq,aseq,ndigits) - j=len_trim(fname1) - fname=fname1(1:j)//aseq(1:ndigits) - endif - estrng='particledump' - if(nunit.eq.0)then - call fnamechk(fname,nunit,ierr,estrng) - if(ierr.eq.1)then - write(6,*)'(particledump)leaving lmnt due to problem w/ fname' - return - endif - call ibcast(nunit) - prms(5)=nunit - endif - iprintarc=0 - if(crms(4).eq.'true')iprintarc=1 - call pwritez(nunit,idmin,idmax,nprecision,nphysunits,iprintarc) - if(crms(2).eq.'true' .or. p3.ne.0)then - if(idproc.eq.0)write(6,*)'closing file connected to unit ',nunit - close(nunit) - prms(5)=0.d0 - endif - if(crms(3).eq.'true')then -! if(idproc.eq.0)write(6,*)'flushing file unit ',nunit - call myflush(nunit) - endif - if(idproc.eq.0)then - write(6,*)'s=',arclen,' ;particledump to file ',fname - endif - return -c -c raytrace: (has more parameters than original rt command) -755 continue - idmin=nint(p1) - idmax=nint(p2) - if(idmax.eq.0)idmax=maxray -c - if(nint(p3).eq.0 .and. crms(5).eq.'undefined')then -c Since the default value of p(3)=5, the user must have set it to zero. -c In this case, he/she is probably just reading in some rays. - if(idproc.eq.0)then - write(6,*)'Error: you are using old style to specify raytrace' - write(6,*)'order=0. Instead, if you only want to read particles,' - write(6,*)'use type=readonly' - endif - call myexit - endif - if(crms(5).eq.'undefined')then - if(idproc.eq.0)then - write(6,*)'Error: you are using old style method to specify' - write(6,*)'raytrace order.' - write(6,*)'Instead use type=taylorN or type=symplecticN' - endif - call myexit - endif -c - if(crms(5).eq.'readonly' .or. crms(5).eq.'readwrite')then - if(crms(5).eq.'readonly') norder=-1 - if(crms(5).eq.'readwrite') norder=0 - ntaysym=1 !irrelevent in this case -c note: when the user specifies readonly or readwrite, the default -c should be ntrace=0,nwrite=0; this is taken care of in sif.f - else - call getordtyp(crms(5),ntaysym,norder) - endif - ntrace=nint(p4) - nwrite=nint(p5) - ibrief=iabs(nint(p6)) -!prms(7) is the max number of file names in a sequence of output files - nprecision=nint(prms(8))-1 - icunit=nint(prms(9)) !assigned unit number for input file - nunit=nint(prms(10)) !assigned unit number for output file - nraysinp=nint(prms(12)) !# of rays to read from data file (optional) -!p11 is a counter that gets incremented and appended to a sequence of file names - icname=crms(1) - fcname=crms(2) - fname=fcname -c - if(prms(7).ne.0)then - xdigits=log(prms(7))/log(10.d0) - ndigits=1+int(xdigits) - prms(11)=prms(11)+1.d0 - nseq=nint(prms(11)) !nseq is the counter that gets converted to a string - call num2string(nseq,aseq,ndigits) - j=len_trim(fcname) - fname=fcname(1:j)//aseq(1:ndigits) - endif -c - estrng='raytrace' - if(icunit.eq.0 .and. icname.ne.' ')then - call fnamechk(icname,icunit,ierr,estrng) - if(ierr.eq.1)then - if(idproc.eq.0)then - write(6,*)'(rt) leaving lmnt due to problem w/ icunit' - write(6,*)'icunit=',icunit - write(6,*)'icname=',icname - endif - return - endif - call ibcast(icunit) - prms(9)=icunit - endif -! - if(nunit.eq.0 .and. fcname.ne.' ')then - call fnamechk(fname,nunit,ierr,estrng) - if(ierr.eq.1)then - write(6,*)'(rt) leaving lmnt due to problem w/ fcname' - return - endif - call ibcast(nunit) - prms(10)=nunit - endif -! - call trace(icunit,nunit,ntaysym,norder,ntrace,nwrite,idmin,idmax, & - & nprecision,nraysinp,th,tmh) -!close? - if(icunit.ne.0)then - if(idproc.eq.0)then - write(6,*)'closing particle initial condition file connected to',& - & ' unit ',icunit - endif - close(icunit) - prms(9)=0.d0 - endif - if(crms(3).eq.'true' .or. prms(7).ne.0)then - write(6,*)'closing particle final condition file connected to', & - & ' unit ',nunit - close(nunit) - prms(10)=0.d0 - endif -!flush? - if(crms(4).eq.'true')then - if(idproc.eq.0)write(6,*)'flushing file unit ',nunit - call myflush(nunit) - endif - return -c -c autotrack: -756 continue -c--------------------------------------- -cryne 4/14/04 crms(1) is no longer used -c crms(1) is 'set=' -c if(crms(1).eq.'true')then -c lautotrk=1 -c lautocon=0 -c if(idproc.eq.0)write(6,*)'lautotrk=1, lautocon=0' -c elseif(crms(1).eq.'false')then -c lautotrk=0 -c lautocon=1 -c if(idproc.eq.0)write(6,*)'lautotrk=0, lautocon=1' -c else -c if(idproc.eq.0)then -c write(6,*)'error(autotrack): do not understand parameter' -c endif -c call myexit -c endif - if(crms(2).ne.'undefined' .or. crms(4).eq.'true')then - lautotrk=1 - lautocon=0 - else - if(idproc.eq.0)then - write(6,*)'error: autotrack has been invoked, but neither' - write(6,*)'a particle tracking algorithm nor the envelope' - write(6,*)'option have been specified' - endif - call myexit - endif -c -c crms(2) is 'type=' [specifies particle tracking algorithm] - ntrktype=0 - ntrkorder=0 - if(crms(2).ne.'undefined')then - call getordtyp(crms(2),ntrktype,ntrkorder) - endif -c -c crms(4) is 'env=' - if(crms(4).eq.'true')then - nenvtrk=1 - else - nenvtrk=0 - endif -c -c crms(3) is 'sckick=' -c 1 means it has been turned on; 0 means it has been turned off; -c -1 means it has not been set. done this way for future use. - if(crms(3).eq.'true')then - nsckick=1 - elseif(crms(3).eq.'false')then - nsckick=0 - else - nsckick=-1 - endif -c write results of parsing this command for debug: - if(idproc.eq.0)then - if(ntrktype.ne.0)then - write(6,*)'autotracking particles' - if(ntrktype.eq.1)write(6,*)'ntrktype=1 (taylor)' - if(ntrktype.eq.2)write(6,*)'ntrktype=2 (symplectic)' - write(6,*)'ntrkorder=',ntrkorder - write(6,*)'nsckick=',nsckick - endif - if(nenvtrk.eq.1)write(6,*)'autotracking envelopes' - endif - return -c -c sckick: -757 continue - if(idproc.eq.0)write(6,*)'sckick command not implemented yet' - return -c -c moments (write some 2nd order moments): -758 continue - nfile1=nint(prms(1)) !assigned unit number for output xfile - nfile2=nint(prms(2)) !assigned unit number for output yfile - nfile3=nint(prms(3)) !assigned unit number for output tfile - nprecision=nint(prms(4))-1 - nunits=nint(prms(5)) - fname1=crms(1) - fname2=crms(2) - fname3=crms(3) - estrng='moments' -c1: - if(nfile1.eq.0)then - call fnamechk(fname1,nfile1,ierr,estrng) - if(ierr.eq.1)write(6,*)'moments error, problem w/ xfile' - if(ierr.eq.1)return - endif - call ibcast(nfile1) - if(nfile1.gt.0)prms(1)=nfile1 -c2: - if(nfile2.eq.0)then - call fnamechk(fname2,nfile2,ierr,estrng) - if(ierr.eq.1)write(6,*)'moments error, problem w/ yfile' - if(ierr.eq.1)return - endif - call ibcast(nfile2) - if(nfile2.gt.0)prms(2)=nfile2 -c3: - if(nfile3.eq.0)then - call fnamechk(fname3,nfile3,ierr,estrng) - if(ierr.eq.1)write(6,*)'moments error, problem w/ tfile' - if(ierr.eq.1)return - endif - call ibcast(nfile3) - if(nfile3.gt.0)prms(3)=nfile3 -c7: - if(crms(7).eq.'ratio')then - ncorr=1 - else - ncorr=0 - endif -c8: - if(crms(8).eq.'true')then - includepi=1 - else - includepi=0 - endif -c9: - if(crms(9).eq.'remove')then - ncent=0 - elseif(crms(9).eq.'keep')then - ncent=1 - else - if(idproc.eq.0) - & write(6,*) 'error(emittance): centroid=',TRIM(crms(4)), - & ' is invalid. Use keep or remove.' - call myexit() - endif -c=== - call writemom2d(arclen,nfile1,nfile2,nfile3,nprecision,nunits, & - &ncorr,includepi,ncent) -c=== - if(crms(4).eq.'true')call myflush(nfile1) - if(crms(5).eq.'true')call myflush(nfile2) - if(crms(6).eq.'true')call myflush(nfile3) - return -c -c -c maxsize (write max beam sizes) -759 continue - nfile1=nint(prms(1)) !assigned unit number for output file 1 - nfile2=nint(prms(2)) !assigned unit number for output file 2 - nfile3=nint(prms(3)) !assigned unit number for output file 3 - nfile4=nint(prms(4)) !assigned unit number for output file 4 - nprecision=nint(prms(5))-1 - nunits=nint(prms(6)) - if(crms(9).eq.'automatic'.or.crms(9).eq.'auto')then -c if(idproc.eq.0.and.nfile1.eq.0) & -c & write(6,*)'(maxsize) automatic file names' - fname1='xmax.out' - fname2='ymax.out' - fname3='tmax.out' - fname4='zmax.out' - else - fname1=crms(1) - fname2=crms(2) - fname3=crms(3) - fname4=crms(4) - endif - estrng='maxsize' -c1: - if(nfile1.eq.0)then - call fnamechk(fname1,nfile1,ierr,estrng) - if(ierr.eq.1)write(6,*)'maxsize error, problem w/ fname1' - if(ierr.eq.1)return - endif - call ibcast(nfile1) - if(nfile1.gt.0)prms(1)=nfile1 -c2: - if(nfile2.eq.0)then - call fnamechk(fname2,nfile2,ierr,estrng) - if(ierr.eq.1)write(6,*)'maxsize error, problem w/ fname2' - if(ierr.eq.1)return - endif - call ibcast(nfile2) - if(nfile2.gt.0)prms(2)=nfile2 -c3: - if(nfile3.eq.0)then - call fnamechk(fname3,nfile3,ierr,estrng) - if(ierr.eq.1)write(6,*)'maxsize error, problem w/ fname3' - if(ierr.eq.1)return - endif - call ibcast(nfile3) - if(nfile3.gt.0)prms(3)=nfile3 -c4: - if(nfile4.eq.0)then - call fnamechk(fname4,nfile4,ierr,estrng) - if(ierr.eq.1)write(6,*)'maxsize error, problem w/ fname4' - if(ierr.eq.1)return - endif - call ibcast(nfile4) - if(nfile4.gt.0)prms(4)=nfile4 -c=== -!XXX -- nunits arg is not in subroutine WRITEMAXSIZE() - call writemaxsize(arclen,nfile1,nfile2,nfile3,nfile4,nprecision) !XXX, & -!XXX &nunits) -c=== - if(crms(5).eq.'true')call myflush(nfile1) - if(crms(6).eq.'true')call myflush(nfile2) - if(crms(7).eq.'true')call myflush(nfile3) - if(crms(8).eq.'true')call myflush(nfile4) -c if(idproc.eq.0)then -c write(6,*)'s=',arclen,'; maximum beam sizes written' -c endif - return -c -c reftraj: -760 continue - nfile1=nint(prms(1)) !assigned unit number for output file - nprecision=nint(prms(2))-1 - nunits=nint(prms(3)) - fname1=crms(1) - estrng='reftraj' - if(nfile1.eq.0)then - call fnamechk(fname1,nfile1,ierr,estrng) - if(ierr.eq.1)write(6,*)'(reftraj) problem w/ fname1:',fname1 - if(ierr.eq.1)call myexit - endif - call ibcast(nfile1) - prms(1)=nfile1 -c=== - call writereftraj(arclen,nfile1,nprecision,nunits) -c=== - if(crms(2).eq.'true')call myflush(nfile1) - return -c -c initenv: -761 continue - if(crms(1).eq.'ratio')then - ncorr=1 - else - ncorr=0 - endif - call initenv(prms,ncorr) - return -c -c envelopes: (write the envelopes stored in the env array) -762 continue -c write(6,*)'here I am at envelopes' - nfile1=nint(prms(1)) !assigned unit number for output file 1 - nfile2=nint(prms(2)) !assigned unit number for output file 2 - nfile3=nint(prms(3)) !assigned unit number for output file 3 -c write(6,*)'nfile1,nfile2,nfile3=',nfile1,nfile2,nfile3 - nprecision=nint(prms(4))-1 - nunits=nint(prms(5)) - if(crms(7).eq.'ratio')then - ncorr=1 - else - ncorr=0 - endif - fname1=crms(1) - fname2=crms(2) - fname3=crms(3) -c write(6,*)'fname1,fname2,fname3=',fname1,fname2,fname3 - estrng='envelopes' -c1: - if(nfile1.eq.0)then - call fnamechk(fname1,nfile1,ierr,estrng) - if(ierr.eq.1)write(6,*)'envelopes error, problem w/ fname1' - if(ierr.eq.1)return - endif - call ibcast(nfile1) - if(nfile1.gt.0)prms(1)=nfile1 -c2: - if(nfile2.eq.0)then - call fnamechk(fname2,nfile2,ierr,estrng) - if(ierr.eq.1)write(6,*)'envelopes error, problem w/ fname2' - if(ierr.eq.1)return - endif - call ibcast(nfile2) - if(nfile2.gt.0)prms(2)=nfile2 -c3: - if(nfile3.eq.0)then - call fnamechk(fname3,nfile3,ierr,estrng) - if(ierr.eq.1)write(6,*)'envelopes error, problem w/ fname3' - if(ierr.eq.1)return - endif - call ibcast(nfile3) - if(nfile3.gt.0)prms(3)=nfile3 -c write(6,*)'done checking file names' -c=== - call writeenv2d(arclen,nfile1,nfile2,nfile3,nprecision,nunits, & - &ncorr) -c write(6,*)'returned from writeenv2d' -c=== -c=== - if(crms(4).eq.'true')call myflush(nfile1) - if(crms(5).eq.'true')call myflush(nfile2) - if(crms(6).eq.'true')call myflush(nfile3) - return -c contractenv (apply contraction map to envelopes): -763 continue - if(idproc.eq.0)then - write(6,*)'(lmnt) warning: user is calling contractenv directly,' - write(6,*)'but this is normally called by ML/I when the user' - write(6,*)'specifies a matchenv command. Make sure you know' - write(6,*)'what you are doing!' - endif - call contractenv(delta) - return -c -c setreftraj: -764 continue - nsto=nint(p(8)) - nget=nint(p(9)) - nwrt=nint(p(10)) -c reset from initial values? : -c crms(1) corresponds to "restart=' which refers to data in location 9 - if(crms(1).eq.'true')nget=9 -c include arc length? : - includearc=1 ! default is to include arc length - if(crms(2).eq.'false')includearc=0 -c - if(nsto.gt.0. or. nget.gt.0)then - if(nsto.gt.0)then - if(idproc.eq.0)then - if(nwrt.gt.0)then - write(6,*)'storing ref particle data in location',nsto - endif - endif - refsave(nsto,1:6)=reftraj(1:6) - if(includearc.eq.1)arcsave(nsto)=arclen - brhosav(nsto)=brho - gamsav(nsto)=gamma - gam1sav(nsto)=gamm1 - betasav(nsto)=beta - else - if(idproc.eq.0)then - if(nwrt.gt.0)then - write(6,*)'getting ref particle data from location ',nsto - endif - endif - reftraj(1:6)=refsave(nget,1:6) - if(includearc.eq.1)arclen=arcsave(nget) - brho=brhosav(nget) - gamma=gamsav(nget) - gamma1=gam1sav(nget) - beta=betasav(nget) - endif - else - if(idproc.eq.0 .and. nwrt.gt.0)then - write(6,*)'setting ref particle data' - write(6,*)'x,px=',p(1),p(2) - write(6,*)'y,py=',p(3),p(4) - write(6,*)'t,pt=',p(5),p(6) - endif - reftraj(1)=p(1) - reftraj(2)=p(2) - reftraj(3)=p(3) - reftraj(4)=p(4) - reftraj(5)=p(5) - reftraj(6)=p(6) -c only change arc length if the user has provided it (set to -9999 in sif.f): - if(p(7).ne.-9999.d0)arclen=p(7) - gamma=-reftraj(6)/pmass*omegascl*sl*p0sc - gamm1=gamma-1.d0 - gbet=sqrt(gamm1*(gamma+1.d0)) - clite=299792458.d0 - brho=gbet/clite*pmass - beta=gbet/gamma - endif - return -c -c setarclen: -765 continue -c crms(1) corresponds to "restart=' - if(crms(1).eq.'true')then - arclen=0.d0 - else - arclen=p(1) - endif - nwrt=nint(p(2)) - if(nwrt.gt.0 .and. idproc.eq.0)then - write(6,*)'setting arc length to ',arclen - endif - return -c -c wakedefault: (actually, not needed here; dealt with in sif.f) -766 continue - return -c -c emittance (write 2D, 4D, and/or 6D 2nd order moments): -767 continue - nfile=nint(prms(1)) !assigned unit number for output file - nprecision=nint(prms(2))-1 - nunits=nint(prms(3)) - fname=crms(5) - estrng='emittance' -c - if(nfile.eq.0)then - call fnamechk(fname,nfile,ierr,estrng) - if(ierr.eq.1)write(6,*)'error(emittance): problem w/ file' - if(ierr.eq.1)return - endif - call ibcast(nfile) - if(nfile.gt.0)prms(1)=nfile - ne2=1 - if(crms(1).eq.'false')ne2=0 - ne4=1 - if(crms(2).eq.'false')ne4=0 - ne6=1 - if(crms(3).eq.'false')then - ne6=0 - else - write(6,*) 'warning(emittance): 6d=true not yet implemented!' - ne6=0 - endif - if(crms(4).eq.'remove')then - ncent=0 - elseif(crms(4).eq.'keep')then - ncent=1 - else - if(idproc.eq.0) - & write(6,*) 'error(emittance): centroid=',TRIM(crms(4)), - & ' is invalid. Use keep or remove.' - call myexit() - endif -c=== - if(ne2.eq.1.or.ne4.eq.1.or.ne6.eq.1) then - call writeemit(arclen,nfile,nprecision,nunits,ne2,ne4,ne6,ncent) - endif -c=== - if(crms(6).eq.'true')call myflush(nfile) - return -c -c matchenv -768 continue - if(idproc.eq.0)then - write(6,*)'error (lmnt): at matchenv in subroutine lmnt' - write(6,*)'but the code should not get here.' - write(6,*) & - & 'a matchenv command can ONLY be placed under #labor in mli.in' - endif - call myexit -c stop -c -c fileinfo: -769 continue - ifileinfo=nint(p1) - return -c -c egengrad: compute generalized gradients from E-field surface data -770 continue - nfile=nint(prms(1)) !assigned unit number for output file - zst=prms(2) - zen=prms(3) - nz=nint(prms(4)) - f=prms(5) - r=prms(6) - fkmx=prms(7) - nk=nint(prms(8)) - infiles=nint(prms(9)) - nprec=nint(prms(10))-1 - !fnin=crms(1) ! filename for input data (E-field) - !fnout=crms(2) ! filename for output data (genlzd grads) - estrng='egengrad' - kfile=0 - jfile=0 -c - if(nfile.eq.0)then - call fnamechk(crms(2),nfile,ierr,estrng) - if(ierr.eq.1)write(6,*)'error(egengrad): problem w/ input file' - if(ierr.eq.1)return - endif - call ibcast(nfile) - if(nfile.gt.0)prms(1)=nfile - if(crms(5).eq.'true')then - call fnamechk(crms(4),kfile,ierr,estrng) - if(ierr.eq.1)write(6,*)'error(egengrad): problem w/ char file' - if(ierr.eq.1)return - endif - call ibcast(kfile) - if(crms(7).ne.' ')then - call fnamechk(crms(7),jfile,ierr,estrng) - if(ierr.eq.1)write(6,*)'error(egengrad): problem w/ diagn file' - if(ierr.eq.1)return - endif - call ibcast(jfile) - call cegengrad(crms(1),crms(6),infiles,nfile,kfile,jfile, & - & zst,zen,nz,f,r,fkmx,nk,nprec) - if(crms(3).eq.'true')then - call myflush(nfile) - if(kfile.ne.0) call myflush(kfile) - if(jfile.ne.0) call myflush(jfile) - end if - return -c -c wrtmap: Write a map to file -771 continue -c -c crms(1) : filename for write -c crms(2) : kind of map to write ('accumulated', 'lastslice') -c crms(3) : i/o status for write ('overwrite','append') -c - ifile=0 - estrng='wrtmap' - call fnamechk(crms(1),ifile,ierr,estrng) - if(ierr.eq.1)then - if(idproc.eq.0)write(6,*)'error(wrtmap): problem w/ file' - return - endif -c -c If overwriting file, rewind... -c KMP: This is a hack, and this should be passed to the fnamechk routine -c in order to be implemented properly. - if(crms(3).eq.'overwrite')then - close(ifile) - open(unit=ifile, file=crms(1), status='unknown', err=7710) - goto 7711 -7710 if(idproc.eq.0)write(6,*)'error(wrtmap): problem overwriting' - ierr=1 - return -7711 continue - endif -c -c Only write file from processor 0 - if(idproc.eq.0)then - if(crms(2).eq.'accumulated')then -! call wrtmap(ifile,refsave(9,1),reftraj,arclen,th,tmh) - call wrtmap(ifile,refprev,reftraj,arclen,th,tmh) - elseif(crms(2).eq.'lastslice')then - call wrtmap(ifile,refprev,reftraj,prevlen,hprev,mhprev) - else - ierr=1 - write(6,*)'error(wrtmap): invalid kind of map [',crms(2),']' - endif - endif - return -c rdmap: -772 continue -c -c crms(1) : filename to read from -c crms(2) : rewind file or not -c - ifile=0 - estrng='rdmap' - call fnamechk(crms(1),ifile,ierr,estrng) - if(ierr.eq.1)then - if(idproc.eq.0)write(6,*)'error(rdmap): problem w/ file' - return - endif - if(idproc.eq.0)write(6,*)'rdmap: reading map from ',crms(1) - if(crms(2).eq.'true')then - if(idproc.eq.0)write(6,*)' rewinding file before use' - rewind ifile - endif - - mpitmp=mpi - mpi=ifile - call rdmap(ifile,darclen,dreftraj,h,mh) - mpi=mpitmp - - refprev=reftraj - arclen=arclen+darclen - prevlen=darclen - nt2prev=nt2 - reftraj=reftraj+dreftraj - goto 2000 - -c sparec7: -773 continue - return -c sparec8: -774 continue - return -c sparec9: -775 continue - return -c -c -c 8: advanced commands ******************************** -c -c 'cod ','amap ','dia ','dnor ','exp ', -18 go to (801, 802, 803, 804, 805, -c 'pdnf ','psnf ','radm ','rasm ','sia ', - & 806, 807, 808, 809, 810, -c 'snor ','tadm ','tasm ','tbas ','gbuf ', - & 811, 812, 813, 814, 815, -c 'trsa ','trda ','smul ','padd ','pmul ', - & 816, 817, 818, 819, 820, -c 'pb ','pold ','pval ','fasm ','fadm ', - & 821, 822, 823, 824, 825, -c 'sq ','wsq ','ctr ','asni ','pnlp ', - & 826, 827, 828, 829, 830, -c 'csym ','psp ','mn ','bgen ','tic ', - & 831, 832, 833, 834, 835, -c 'ppa ','moma ','geom ','fwa '/ - & 836, 837, 838, 839),kt2 -c -c off-momentum closed orbit analysis -c -801 call cod(p,th,tmh) - return -c -c apply map to a function or moments -c -802 call amap(p,th,tmh) - return -c -c dynamic invariant analysis -c -803 call dia(p,th,tmh) - return -c -c dynamic normal form analysis -c -804 call dnor(p,th,tmh) - return -c -c compute exponential -c -805 call cex(p,th,tmh) - return -c -c compute power of dynamic normal form -c -806 call pdnf(p,th,tmh) - return -c -c compute power of static normal form -c -807 call psnf(p,th,tmh) - return -c -c resonance analyze dynamic map -c -808 call radm(p,th,tmh) - return -c -c resonance analyze static map -c -809 call rasm(p,th,tmh) - return -c -c static invariant ayalysis -c -810 call sia(p,th,tmh) - return -c -c static normal form analysis -c -811 call snor(p,th,tmh) - return -c -c twiss analyze dynamic map -c -812 call tadm(p,th,tmh) - return -c -c twiss analyze static map -c -813 call tasm(p,th,tmh) - return -c -c translate basis -c -814 call tbas(p,th,tmh) - return -c -c get buffer contents -c -815 continue -c -c test control parameters -c - nmap=nint(p2) - if (nmap.gt.5 .or. nmap.lt.1) then - write(jof,9815) nmap - 9815 format(1x,'nmap=',i3,1x,'trouble with gbuf:nmap < 1 or > 5') - call myexit - endif -c option when tracking (procedure at end) - if(ntrk .eq. 1) then -c if(idproc.eq.0)write(6,*)'at gbuf w/ ntrk=',ntrk - p1temp=p(1) - p(1)=2 - call gbuf(p,h,mh) - p(1)=p1temp - goto 2000 - endif -c options when not tracking -c if(idproc.eq.0)write(6,*)'at gbuf w/ ntrk.ne.1, ntrk=',ntrk - call gbuf(p,th,tmh) - return -c -c transport static (script) A -c -816 call trsa(p,th,tmh) - return -c -c transport dynamic script A -c -817 call trda(p,th,tmh) - return -c -c multiply polynomial by a scalar -c -818 call smul(p,th,tmh) - return -c -c add two polynomials -c -819 call padd(p,th,tmh) - return -c -c multiply two polynomials -c -820 call pmul(p,th,tmh) - return -c -c Poisson bracket two polynomials -c -821 call pbpol(p,th,tmh) - return -c -c polar decompose matrix portion of transfer map -c -822 call pold(p,th,tmh) - return -c -c evaluate a polynomial -c -823 call pval(p,th,tmh) - return -c -c fourier analyze static map -c -824 call fasm(p,th,tmh) - return -c -c fourier analyze dynamic map -c -825 call fadm(p,th,tmh) - return -c -c select quantities -c -826 call sq(p) - return -c -c write selected quantities -c -827 call wsq(p) - return -c -c change tune ranges -c -828 continue - call subctr(p) - return -c -c apply script N inverse -c -829 continue - call asni(p) - return -c -c compute power of nonlinear part -c -830 continue - call pnlp(p,th,tmh) - return -c -c check for symplecticity -c -831 continue - isend=nint(p1) - call csym(isend,tmh,ans) - return -c -c (psp) compute scalar product of two polynomials -c -832 call psp(p,th,tmh) - return -c -c (mn) compute matrix norm -c -833 call submn(p,th,tmh) - return -c -c (bgen) generate a beam -c -834 call bgen(p,th,tmh) - return -c -c (tic) translate (move) initial conditions -c -835 call tic(prms) - return -c -c (ppa) principal planes analysis -c -836 call ppa(p,th,tmh) - return -c -c (moma) moment and map analysis -c -837 call moma(p) - return -c -c (geom) compute geometry of a loop -c -838 call geom(p) - return -c -c (fwa) copy file to working array -c -839 call fwa(p) - return -c -c 9: procedures and fitting and optimization ************************* -c -c 'bip ','bop ','tip ','top ', -19 go to (901, 902, 903, 904, -c 'aim ','vary ','fit ','opt ', - & 905, 906, 907, 908, -c 'con1 ','con2 ','con3 ','con4 ','con5 ', - & 909, 910, 911, 912, 913, -c 'mrt0 ', - & 914, -c 'mrt1 ','mrt2 ','mrt3 ','mrt4 ','mrt5 ', - & 915, 916, 917, 918, 919, -c 'fps ', - & 920, -c 'cps1 ','cps2 ','cps3 ','cps4 ','cps5 ', - & 921, 922, 923, 924, 925, -c 'cps6 ','cps7 ','cps8 ','cps9 ', - & 926, 927, 928, 929, -c 'dapt ','grad ','rset ','flag ','scan ', - & 930, 931, 932, 933, 934, -c 'mss ','spare1 ','spare2 '/ - & 935, 936, 937),kt2 -c begin procedures -c -901 continue -cryne make sure that the code knows it has not converged yet -cryne (supresses printing until convergence is achieved) - kfit=0 - call bip(p) - return -902 call bop(p) - return -c -c end procedures -c -903 continue - call subtip(p) - return -904 call subtop(p) - return -c -c specify aims -c -905 call aim(p) - return -c -c specify quantities to be varied -c -906 call vary(p) - return -c -c fit to achieve aims -c -907 continue -cryne -ctm write(6,*)'(lmnt)calling fit; kfit=',kfit - call fit(p) -ctm write(6,*)'(lmnt)back from fit; kfit=',kfit - return -c -c optimize -c -908 call opt(p) - return -c -c constraints -c -909 call con1(p) - return -910 call con2(p) - return -911 call con3(p) - return -912 call con4(p) - return -913 call con5(p) - return -c -c merit functions -c -c least squares merit function -c -914 call mrt0 - return -c -c user supplied merit functions -c -915 call mrt1(p) - return -916 call mrt2(p) - return -917 call mrt3(p) - return -918 call mrt4(p) - return -919 call mrt5(p) - return -c -c free parameter sets -c -920 ipset=nint(p1) - call fps(ipset) - return -c -c capture parameter sets -c -921 ipset=1 - call cps(prms,p,ipset) - return -922 ipset=2 - call cps(prms,p,ipset) - return -923 ipset=3 - call cps(prms,p,ipset) - return -924 ipset=4 - call cps(prms,p,ipset) - return -925 ipset=5 - call cps(prms,p,ipset) - return -926 ipset=6 - call cps(prms,p,ipset) - return -927 ipset=7 - call cps(prms,p,ipset) - return -928 ipset=8 - call cps(prms,p,ipset) - return -929 ipset=9 - call cps(prms,p,ipset) - return -c -c compute dynamic aperture (dapt) -c -930 continue - call dapt(p) - return -c -c gradient (grad) -c -931 continue - call grad(p) - return -c -c rset -c -932 continue - call rset(p) - return -c -c flag -c -933 continue - call flag(p) - return -c -c scan -c -934 continue - call scan(p) - return -c -c mss -c -935 continue - call mss(p) - return -c -c spare1 -c -936 continue - write(6,*) 'spare1 not yet available' - return -c -c spare2 -c -937 continue - write(6,*) 'spare2 not yet available' - return -c -c ......... concatenate or track before exiting ........ -c - 2000 continue -cryne--- 08/16/2001 -cryne This statement has been added because h and mh disappear after -cryne leaving the routine, and there may be times when we would like -cryne to make use of the last map that was constructed. - call mapmap(h,mh,hprev,mhprev) -cryne--- -cryne 08/16/2001 note well: now the user can turn off auto-concatenation -cryne Use with care!!! - if(ntrk.eq.0)then - if(lautocon.eq.0)write(6,*)'WARNING: not concatenating!' - if(lautocon.eq.1)call concat(th,tmh,h,mh,th,tmh) - if(lautocon.eq.2)call sndwchi(h,mh,th,tmh,th,tmh) - if(lautocon.eq.-2)call sndwch(h,mh,th,tmh,th,tmh) - return - else -cryne 3/27/04 ntaysym=1 for taylor, =2 for symplectic - if(ntrktype.ne.0)then - ntaysym=ntrktype - call trace(0,jfcf,ntaysym,ntrkorder,1,0,0,0,5,0,h,mh) - endif - if(nenvtrk.eq.1)then -c write(6,*)'calling envtrace(mh) with mh(1:6,1:6)=' -c write(6,51)mh(1:6,1:6) - 51 format(6(1x,1pe12.5)) - call envtrace(mh) - endif -c write(6,*)'returning from bottom of lmnt' - return - endif - end -c -************************************************************************ -c - subroutine lookup(string,itype,index) -c----------------------------------------------------------------------- -c this subroutine determines whether the input string 'string' -c is an element,line,lump,loop, or unused label. -c -c input: string character*(*) item name -c output: itype integer =1, if string is a menu entry -c =2, .... line -c =3, .... lump -c =4, .... loop -c =5, .... unknown label -c index integer index of 'string' in its array -c -c Written by Rob Ryne ca 1984 -c rewritten by Petra Schuett -c October 30, 1987 -c----------------------------------------------------------------------- - use acceldata - use lieaparam, only : monoms - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- -c----------------------------------------------------------------------- -c parameter types -c----------------------------------------------------------------------- - character string*(*) - integer itype,index -c----------------------------------------------------------------------- -c start routine -c----------------------------------------------------------------------- -c element? - do 10 n=1,na - if(string.eq.lmnlbl(n)) then - itype = 1 - index = n - return - endif - 10 continue -c item? - do 20 n=1,nb - if(string.eq.ilbl(n)) then - itype = ityp(n) - index = n - return - endif - 20 continue -c not found: - itype=5 - return - end -c -*********************************************************************** -c - subroutine low(line) -c Converts all uppercase characters to lowercase. -c Written by Liam Healy, Feb. 28, 1985. -c - character line*(*) -c - character*26 lower,upper - character*1 blank - data lower/'abcdefghijklmnopqrstuvwxyz'/ - data upper/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ - data blank/' '/ - save lower,upper,blank -c - lnbc=1 - do 100 i=1,LEN(line) - loc=index(upper,line(i:i)) - if(loc.gt.0) then - line(i:i)=lower(loc:loc) - endif - if (line(i:i).ne.blank) lnbc=i - 100 continue - return - end -c -*********************************************************************** - subroutine lumpit(mth) -c----------------------------------------------------------------------- -c translate map of mth lump to special format and save it in core -c -c input mth (integer) : index of lump in /items/ -c -c Written by Rob Ryne ca 1984 -c changed by Petra Schuett -c October 30,1987 -c----------------------------------------------------------------------- - use acceldata - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- - include 'map.inc' - include 'deriv.inc' - include 'core.inc' - include 'files.inc' -c----------------------------------------------------------------------- -c local variables -c----------------------------------------------------------------------- -c inew keeps track of the lump to be deleted next, if core is full - integer inew - save inew - data inew /0/ -c----------------------------------------------------------------------- -c start routine -c----------------------------------------------------------------------- -c find vacant space in core - icore = 0 - do 1 i=maxlum,1,-1 - if(inuse(i).eq.0) icore=i - 1 continue -c if core is full, destroy oldest lump - if(icore.eq.0) then - inew=inew+1 - if(inew.eq.maxlum)inew=1 - icore=inew - lmade(inuse(icore))=0 - write(jof,510) ilbl(inuse(icore)) - 510 format(1h ,'lump ',a16,' deleted;') - endif -c-------------------- -c calculate rjac,df,.. - call canx(tmh,th,5) -c ..rrjac and rdf - call rearr -c-------------------- -c now store all the info - do 10 n1=1,6 -!!!!! do 10 n2=1,83 - do 10 n2=1,monoms - dfl(n1,n2,icore)=df(n1,n2) - 10 continue - do 20 n1=1,3 -!!!!! do 20 n2=1,84 -!!!!! do 20 n2=1,monom1+1 - do 20 n2=1,monoms - 20 rdfl(n1,n2,icore)=rdf(n1,n2) - do 30 n1=1,3 - do 30 n2=1,3 -!!!!! do 30 n3=1,28 -!!!!! do 30 n3=1,monom2+1 - do 30 n3=1,monoms - 30 rrjacl(n1,n2,n3,icore)=rrjac(n1,n2,n3) - do 40 n1=1,6 - do 40 n2=1,6 - 40 tmhl(n1,n2,icore)=tmh(n1,n2) - do 50 n1=1,monoms - 50 thl(n1,icore)=th(n1) -c-------------------- -c set pointers - inuse(icore) = mth - lmade(mth) = icore -c-------------------- - write(jof,520) ilbl(mth),icore - write(jodf,520) ilbl(mth),icore - 520 format(1h ,'lump ',a16,' constructed and stored.','(',i2,')') -c-------------------- -! ifile=50+icore -! write(ifile,*)'DFL:' -! do n1=1,6 -! do n2=1,monoms -! if(dfl(n1,n2,icore).eq.0.d0)cycle -! write(ifile,*)n1,n2,dfl(n1,n2,icore) -! enddo -! enddo -! write(ifile,*)'RDFL:' -! do n1=1,6 -! do n2=1,monoms -! if(rdfl(n1,n2,icore).eq.0.d0)cycle -! write(ifile,*)n1,n2,rdfl(n1,n2,icore) -! enddo -! enddo -! write(ifile,*)'RRJACL:' -! do n1=1,3 -! do n2=1,3 -! do n3=1,monoms -! if(rrjacl(n1,n2,n3,icore).eq.0.d0)cycle -! write(ifile,*)n1,n2,n3,rrjacl(n1,n2,n3,icore) -! enddo -! enddo -! enddo -! write(ifile,*)'TMHL:' -! do n1=1,6 -! do n2=1,6 -! if(tmhl(n1,n2,icore).eq.0.d0)cycle -! write(ifile,*)n1,n2,tmhl(n1,n2,icore) -! enddo -! enddo -! write(ifile,*)'THL:' -! do n1=1,monoms -! if(thl(n1,icore).eq.0.d0)cycle -! write(ifile,*)n1,thl(n1,icore) -! enddo -c-------------------- - return - end -c -************************************************************************ -c - function newsl(mp,kth) -c----------------------------------------------------------------------- -c newsl is the first icon to be treated. Depending on the sign of the -c repetition factor loop(mp), it is either the first or the last one. -c -c Petra Schuett, November 6,1987 -c----------------------------------------------------------------------- - use acceldata - use lieaparam, only : monoms -c-------- -c commons -c-------- - include 'stack.inc' -c------- -c start -c------- - if(loop(mp).ge.0) then - newsl = 1 - else - newsl = ilen(kth) - endif - return - end -************************************************************************ - function npm1(number) -c Petra Schuett, November 6,1987 -c - if (number .ge. 0) then - npm1 = 1 - else - npm1 = -1 - endif - return - end -************************************************************************ - subroutine pop(lempty) -c----------------------------------------------------------------------- -c pop stack -c -c output: lempty = .true. if stack is empty -c -c Petra Schuett October 30,1987 -c----------------------------------------------------------------------- - use acceldata - use lieaparam, only : monoms - include 'impli.inc' -c-------- -c commons -c-------- - include 'stack.inc' - include 'files.inc' -c--------------- -c parameter type -c--------------- - logical lempty -c------- -c start -c------- - np = np - 1 - if(np .le. 0) then - lempty = .true. - else - lempty = .false. - call lookup(lstac(np),ntype,ith) - call lookup(icon(nslot(np),ith),mtype,jth) - endif - return - end -************************************************************************ - subroutine push -c----------------------------------------------------------------------- -c push stack: add actual icon on top of it -c -c Petra Schuett October 30,1987 -c----------------------------------------------------------------------- - use acceldata - use lieaparam, only : monoms - include 'impli.inc' -c-------- -c commons -c-------- - include 'stack.inc' - include 'files.inc' -c------- -c start -c------- - np = np + 1 - if(np .gt. mstack) then - write(jof ,510) - write(jodf,510) - 510 format(' error in push: stack overflow') - call myexit - else - lstac(np) =icon(nslot(np-1),ith) - loop(np) =irep(nslot(np-1),ith) * npm1(loop(np-1)) - nslot(np) =newsl(np,jth) - nslot(np-1)=nslot(np-1) + npm1(loop(np-1)) - ith = jth - ntype = mtype - call lookup(icon(nslot(np),ith),mtype,jth) - endif - return - end -************************************************************************ - subroutine readin(line,leof) -c----------------------------------------------------------------------- -c Reads a line from file lf, puts it in the character variable 'line'. -c Designed so that filters may put on, such as the routine to convert -c all uppercase characters to lower case. -c Written by Liam Healy, May 1, 1985. -c -c Changed by Petra Schuett, October 19, 1987 : -c use logical: leof=.true. , if end of file is encountered -c----------------------------------------------------------------------- - include 'files.inc' - character line*(*) - logical leof -c----Routine---- - read(lf,800,end=100,err=200) line - 800 format(a) -cryne 9/11/2002 uncommented the following: - call low(line) - return - 100 continue - leof=.true. - return - 200 continue -cryne 08/26/2001 error exit added by ryne - write(6,*)'error reading data in routine readin' - stop - end -c -************************************************************************ -c - subroutine rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -c----------------------------------------------------------------------- -c This routine reads a new line and interprets it partly: -c - if a line starts with '!' (comment line), it is skipped and -c another line is read -c - if a #... code is read, it sets msegm, indicating the start of -c a new input component (segment). -c - lines in the comment component (segment) are not interpreted. -c - all other lines are cut into stings and numbers assuming a form: -c n1*str1 n2*str2 ... n3*str3 n4*str4,n5*str5 (etc) -c the numbers n1,n2,... are optional -c the strings and numbers are separated by blanks and/or commas -c - a line ending with & is continued on the next line (lcont=true) -c - anything after a '!' is ignored -c -c Input: msegm integer input component (segment) currently -c being read -c -c Output:line character*(*)line read -c leof logical =.true. if end of file is encountered -c msegm integer future component (segment) to be read -c strarr(40) character*(*)array of strings str1,str2,... -c narr(40) integer array of numbers n1,n2,... -c itot integer number of strings found -c lcont logical =.true. if line to be continued -c -c Author: Petra Schuett -c October 19, 1987 -c----------------------------------------------------------------------- - include 'impli.inc' -c - include 'files.inc' - include 'codes.inc' -c arguments: - integer msegm,narr(40),itot - character strarr(40)*(*) - character line*(*) - logical leof,lcont,npound -c local variables: - character*16 string - logical lnum,lfound - logical defcon,defelem,defline - external defcon,defelem,defline -cryne 5/4/2006 - logical MAD8,MADX - common/mad8orx/MAD8,MADX -c----------------- -c init - lcont=.false. - npound=.false. -c -ctm 9/01 skip read if coming from #include -c - if(itot.eq.-1) go to 3 -c read new line - 1 call readin(line,leof) -c check for end of file - if (leof) return -c----------------------------------------- -c check for blank lines or comment lines -c find the first nonblank character: - do n=1,LEN(line) - nfirst=n - if(line(n:n).ne.' ')goto 100 - enddo -c blank line: - goto 1 - 100 continue -c is the first character a '!' ? - if(line(nfirst:nfirst).eq.'!')goto 1 - -c----------------------------------------- -c write(6,*)'(rearec got)',line -c skip this check if entering the routine in #comment or #beam -! if((msegm.eq.1).or.(msegm.eq.2))goto 123 -cryne+++ August 5, 2004 : some time ago I commented out the previous line. -cryne However, it should be present for the case msegm.eq.1, so I am -cryne putting it back now. The reason is that the parser could find -cryne symbolic expressions in the comments, and it should not interpret -cryne these as symbolic constants whose values need to be calculated. -cryne Due to the following if test, the only way to get out of -cryne the #comments section is by finding #something (normally #beam) - if(msegm.eq.1)goto 123 -cryne+++ -c - if(msegm.ne.9)then - if(defcon(line))msegm=9 - endif - if(msegm.ne.3)then - if(defelem(line))msegm=3 - endif - if(msegm.ne.4)then - if(defline(line))msegm=4 - endif - 123 continue -c -cryne 5/4/2006 -cryne I am struggling w/ MADX input (originally wrote for MAD8). -cryne Deal with this by deciding here if the line is to be continued, -cryne First blank out everything to the right of and including '!' - lenline=len(line) - n123=index(line,'!') - if(n123.ne.0)line(n123:lenline)=' ' -cryne in MADX style, there could be space between ; and !, so deal with it: - if(MADX)then - if(n123.ne.0)iqtop=n123-1 - if(n123.eq.0)iqtop=lenline - do iq=iqtop,1,-1 - ilast=iq - if(line(ilast:ilast).ne.' ')exit - enddo -c write(6,*)'ilast,line(ilast:ilast)=',ilast,line(ilast:ilast) - if(line(ilast:ilast) .NE. ';' )lcont=.true. - endif -cryne -c -c - 3 continue - itot = 0 -c convert to lower case, except for comment component (segment) - if (msegm.ne.1) call low(line) -c find first string - kbeg=1 - call cread(kbeg,msegm,line,string,lfound) -c empty line is ignored, except in comment component (segment) - if(.not.lfound) then - if(msegm.eq.1) then - return - else -cryne 7/7/2002 write(6,*) msegm,'= segment with blank line' - goto 1 - endif - endif -c new component (segment) starts... - if(string(1:1).eq.'#')then -c in case previous component (segment) was comment, conv to lower case - call low(line) -c ...which one? -cryne do 2 k=1,8 !July 7, 2002 - do 2 k=1,nintypes - if(string(1:8).eq.ling(k)) then - msegm = k - npound=.true. -c write(6,*)'found a ',ling(k) -ctm if(msegm.eq.8)then -ctm call cread(kbeg,msegm,line,string,lfound) -ctm if(.not.lfound)then -ctm not any more-- write(6,*)'error(rearec): file name must follow #include' -ctm endif -ctm strarr(1)=string(1:8) -ctm return -ctm endif -c write(jodf,*) msegm -cryne 5/4/2006 a ";" on the line with #comment means "use MADX style" - if(msegm.eq.1)then - if(index(line,';').ne.0)then - MAD8=.false. - MADX=.true. - endif - endif -c------------------ - return - endif - 2 continue -c ... no match: -c default is #beam after #comment - if(msegm.eq.1) then - msegm = 2 - return - else -c but in all other cases, this should not happen! - write(jof,99) string - 99 format(' ---> warning from rearec:'/ & - & ' user name ',a,' begins with #') - endif - endif -c if #comment line is read, no interpretation - if(msegm.eq.1) return -c comment line - if (string(1:1).eq.'!') goto 1 -c......................................................... -c now interpret line -c first init itot - itot = 0 - do 10 i=1,40 -c end of line - if((.not.lfound).or.(string(1:1).eq.'!')) return -c line to be continued - if((MAD8) .and. string(1:1).eq.'&') then - lcont = .true. - return - endif -ccc if((MADX).and.len_trim(string).eq.1.and.string(1:1).ne.';') then -ccc lcont = .true. -ccc return -ccc endif -c so we found another string - itot=itot+1 -c is it a number? - call cnumb(string,num,lnum) -c write(jodf,*)string,'=',num,'lnum=',lnum - if((.not.lnum).and.(string(1:1).ne.'-')) then -c.. this must be "string" - narr(i)=1 - strarr(i)=string(1:16) - else if(.not.lnum) then -c.. it is "-string" - narr(i)=-1 -cryne rhs should say string(2:29)??? - strarr(i)=string(2:16) - else -c.. it is the number of "n*string" - narr(i)=num - call cread(kbeg,msegm,line,string,lfound) -c write(jodf,*)kbeg,string,lfound -cryne 08/14/2001 normally this would indicate a problem, but due to -cryne changes in the #beam component, it could be ok. So skip warning. - if (.not.lfound .and. msegm.eq.2)return -c.. error - if (.not.lfound) then - write(jof ,98) line - write(jodf,98) - 98 format(' ---> warning from rearec:'/, & - & ' the following line contains a number which is', & - & ' not followed by a string:') - write(jodf,*) ' ',line - call myexit - endif -c.. normal way - strarr(i)=string(1:16) - endif -cryne July 4, 2002 -cryne if using the Standard Input Format to read menu items, -cryne it is only necessary to see if there are at least 3 strings -cryne on this record - if(msegm.eq.3 .and. itot.eq.3)return -cryne July 14/2002 -cryne if reading the definition of a constant (msegm=9), only need one. - if(msegm.eq.9 .and. itot.eq.1)return -c find next string and start over again - call cread(kbeg,msegm,line,string,lfound) -c write(jodf,*)kbeg,string,lfound - 10 continue -c -c more than 40 strings, which are separated by single characters, -c cannot occur in a line of 80 characters. - end -c -c*********************************************************************** -c - subroutine tran -c----------------------------------------------------------------------- -c organizes translation of input into work to be done -c -c Written by Rob Ryne ca 1984 -c adapted to new version 9 Nov 87 by -c Petra Schuett -c Modified 31 Aug 88 by Alex Dragt -c Modified 20 Aug 98 to use a home-made do loop. AJD -c 4/1/00: Home-made loop re-inserted into Mottershead version. RDR -c----------------------------------------------------------------------- - use parallel - use acceldata - use beamdata - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- - include 'map.inc' - include 'core.inc' - include 'loop.inc' - include 'files.inc' - include 'labpnt.inc' - include 'fitbuf.inc' - include 'setref.inc' ! added by RDR, April 18, 2004 - real*8 mhprev - character*16 strng - dimension reftmp(6) - common/prevmap/hprev(monoms),mhprev(6,6) - common/envdata/env(6),envold(6),emap(6,6) - common/envstuff/nenvtrk - common/autotrk/lautotrk,ntrktype,ntrkorder -c -cryne 5/4/2006 added this to allowing printing of messages from #labor: - integer, parameter :: lmaxmsg=1000 - character*256 lattmsg(lmaxmsg) - common/lattmsgb/lattmsg,lmsgpoi - character*80 linestar -c -c----------------------------------------------------------------------- -c local variables -c----------------------------------------------------------------------- - dimension rh(monoms),rmh(6,6) -c----------------------------------------------------------------------- -c start -c----------------------------------------------------------------------- -c initialize - call ident(th,tmh) -cryne 08/17/201: - call ident(hprev,mhprev) -ctm reftraj(1:5)=0. - do k = 1,5 - reftraj(k)=0. - enddo -c -cryne 5/4/2006 - linestar='********************************************************& - &*************************' -c -c if(idproc.eq.0)write(6,*)'setting reference trajectory' -c if(idproc.eq.0)write(6,*)'sl=',sl -c if(idproc.eq.0)write(6,*)'omegascl=',omegascl -c if(idproc.eq.0)write(6,*)'p0sc=',p0sc -c if(idproc.eq.0)write(6,*)'gamma=',gamma -c if(idproc.eq.0)write(6,*)'pmass=',pmass -cryne fixed 4/18/04 : set reftraj(6) correctly for all choices of units: - reftraj(6)=-gamma*pmass/(omegascl*sl*p0sc) -cryne reftraj(6)=-gamma -c if(idproc.eq.0)write(6,*)'reftraj(6)=',reftraj(6) - arclen=0. -c -c save the initial reftraj data in location #9: - refsave(9,1:6)=reftraj(1:6) - arcsave(9)=arclen -cryne -cryne initialize this here because of a test on kfit in eintrp (gapmap) - kfit=0 -cryne - jicnt=0 - jocnt=0 -c main loop through latt (labor) -c -c Program changes made 20 August 98 by AJD. -c Change Fortran do loop into a home-made do loop because -c various other routines change the control index lp. -c -c do 5 lp=1,noble - lp=1 - 4 continue -c write(6,*)'AT START OF MAIN LABOR LOOP; lp=',lp -c For remaining changes, see end of this subroutine -c -cryne 5/4/2006: - strng=latt(lp) - if(strng(1:1).eq.'>')then -ccc msglen=len_trim(lattmsg(num(lp))) -ccc write(6,*)linestar(1:min(msglen,80)) -ccc write(6,*)trim(lattmsg(num(lp))) -ccc write(6,*)linestar(1:min(msglen,80)) -c -c msgout =1 (>), =2 (>>), or =3 (>>>) - msgout=1 - if(strng(1:2).eq.'>>')msgout=2 - if(strng(1:3).eq.'>>>')msgout=3 - msglen=len_trim(lattmsg(num(lp)))-msgout !length w/out > or >> or >>> - if(msgout.eq.1 .or. msgout.eq.3)then -c write to terminal: - if(idproc.eq.0)then - write(jof,*)linestar(1:min(msglen,80)) - write(jof,*)lattmsg(num(lp))(msgout+1:msglen+msgout) - write(jof,*)linestar(1:min(msglen,80)) - endif - endif - if(msgout.eq.2 .or. msgout.eq.3)then -c write to output file: - if(idproc.eq.0)then - write(jodf,*)linestar(1:min(msglen,80)) - write(jodf,*)lattmsg(num(lp))(msgout+1:msglen+msgout) - write(jodf,*)linestar(1:min(msglen,80)) - endif - endif - lp=lp+1 - goto 4 - endif -c - call lookup(latt(lp),ntype,ith) - if (ntype.eq.1) then -c command 'circ' ... - if(nt1(ith).eq.7 .and. nt2(ith).eq.7 ) then - icfile=nint(pmenu(1+mpp(ith))) - nfcfle=nint(pmenu(2+mpp(ith))) - norder=nint(pmenu(3+mpp(ith))) - ntimes=nint(pmenu(4+mpp(ith))) - nwrite=nint(pmenu(5+mpp(ith))) - isend =nint(pmenu(6+mpp(ith))) - jfctmp=jfcf - jfcf =nfcfle - call cqlate(icfile,norder,ntimes,nwrite,isend) - jfcj=jfctmp -c command 'contractenv' - elseif(nt1(ith).eq.7 .and. nt2(ith).eq.68) then - write(6,*)'**********************************************' - write(6,*)'**********************************************' - write(6,*)'*********IN TRAN; found matchenv**************' - write(6,*)'**********************************************' - write(6,*)'**********************************************' - niter=nint(pmenu(1+mpp(ith))) - tolerance=pmenu(2+mpp(ith)) - strng=cmenu(1+mppc(ith)) -c write(6,*)'niter,tolerance,strng=',niter,tolerance,strng -c note: this assumes that env(:) has been set. should check! - envold(:)=env(:) -c check that tracking variables nenvtrk,lautotrk,ntrktype make sense: - nenvtrkold=nenvtrk - lautotrkold=lautotrk - ntrktypeold=ntrktype - if(nenvtrk.ne.1)then - nenvtrk=1 - if(idproc.eq.0)then - write(6,*)'Envelope tracking turned on for rms matching.' - write(6,*)'It will be turned off when finished matching.' - endif - endif - if(lautotrk.ne.1)then - lautotrk=1 !confusing; this really means "don't concatenate" - if(idproc.eq.0)then - write(6,*)'autoconcatenation turned off for rms matching.' - write(6,*)'it will be turned on when finished matching.' - endif - endif - if(ntrktype.ne.0)then - ntrktype=0 !this, plus lautotrk=1, means "don't call trace" - if(idproc.eq.0)then - write(6,*)'particle tracking turned off for rms matching.' - write(6,*)'it will be turned on when finished matching.' - endif - endif -c start of do loop for rms matching: - do iii=1,niter -c store reference energy, etc. - reftmp(1:6)=reftraj(1:6) - arctmp=arclen - brhotmp=brho - gammatmp=gamma - gamm1tmp=gamm1 - betatmp=beta - call trobj(strng,1,0) - call contractenv(delta) -c check for convergence; if converged, break. - if(idproc.eq.0)write(6,*) & - & 'rms matching: iteration,delta=',iii,delta - if(delta.lt.tolerance)then - if(idproc.eq.0)write(6,*)'SEARCH CONVERGED' - exit - endif -c if not converged, restore reference energy, etc. and keep looping - reftraj(1:6)=reftmp(1:6) - arclen=arctmp - brho=brhotmp - gamma=gammatmp - gamm1=gamm1tmp - beta=betatmp - enddo - nenvtrk=nenvtrkold - lautotrk=lautotrkold - ntrktype=ntrktypeold - else -c ... or other element/command - call trlmnt(ith,num(lp)) - endif - else if (ntype.eq.2) then -c line - call trobj(latt(lp),num(lp),0) - else if (ntype.eq.3) then -c lump -c -c ignore or destroy lump with zero repetition number - if( num(lp).eq.0) then -c if lump is unmade, ignore it - if( lmade(ith).eq.0 ) then - write(jof, 510) ilbl(ith) - write(jodf,510) ilbl(ith) - 510 format(1x,'unmade lump ',a16, & - & ' in #labor with rep no. = 0 ignored') - else -c if lump is made, destroy it - do 30 k = 1,maxlum - if(inuse(k).eq.ith) then - inuse(k) = 0 - write(jof, 520) ilbl(ith) - write(jodf,520) ilbl(ith) - 520 format(1x,'lump ',a16, & - & ' in #labor with rep n. = 0 destroyed') - endif - 30 continue - lmade(ith) = 0 - endif - endif -c -c otherwise - if( num(lp).ne.0) then - call trobj(latt(lp),num(lp),0) - endif -c - else if (ntype.eq.4) then -c loop - if( num(lp).ne.0) nloop=ith - call trloop(ilbl(ith),num(lp)) -c store unmade lumps and replace lump-number by number in core - do 40 i=1,joy - if(mim(i).ge.0.and.mim(i).le.5000) then - jth=mim(i) - if(lmade(jth).eq.0) then - call mapmap(th,tmh,rh,rmh) - call ident(th,tmh) - call trobj(ilbl(jth),1,0) -c call lumpit(jth) - call mapmap(rh,rmh,th,tmh) - endif - mim(i)=lmade(jth) - endif - 40 continue - else -c unused label - if(idproc.eq.0)then - write(jof,610) latt(lp) - 610 format(1h ,'warning from tran: ',a16,' not found.') - endif - endif -c -c Further modifications required to produce home-made do loop. -c -c 5 continue -c - lp=lp+1 -c write(6,*)'AT BOTTOM OF MAIN LABOR LOOP; lp=',lp - if(lp .le. noble) go to 4 -c -c End of modifications. AJD 20 August 98 -c write(6,*)'returning from tran' -c - return - end -c -c*********************************************************************** -c - subroutine trlmnt(ith,mrep) -c----------------------------------------------------------------------- -c handle single item (element/command) in the menu -c -c input: ith index of the item in menu -c mrep repetition factor -c -c Petra Schuett, Nov.9,1987 -c----------------------------------------------------------------------- - use acceldata - use lieaparam, only : monoms - use beamdata, only : bcurr - use parallel, only : idproc - use ml_timer - include 'impli.inc' - include 'map.inc' - include 'codes.inc' - include 'previous.inc' - logical ldoit -c - common/rfxtra/zedge,gaplen,thetastore - common/showme/iverbose - common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0 - common/poiblock1/nspchset,nsckick - common/autotrk/lautotrk,ntrktype,ntrkorder - common/envstuff/nenvtrk - common/autolog/lautoap1,lautoap2,lautoap3,lrestrictauto -c -c iverbose=2 -cryne 8/31/2001 - kt1=nt1(ith) - kt2=nt2(ith) -cryne 1/11/2005 new code to only pre/post apply after "physical" elements. -c the following is just a first attempt at this: - ldoit=.false. - if(lrestrictauto.eq.1 .and. & - &(kt1.eq.1 .or. kt1.eq.2 .or. kt1.eq.4 .or. kt1.eq.5))ldoit=.true. -c -c------ Put ith in inmenu common variable ------------ -cryne 8/31/2001 I don't know who put this statement here or -cryne what it is good for: - inmenu = ith -c---------- -cryne 8/31/2001 -c check to see whether or not this is a thick element: -c write(6,*)' === afro::trlmnt(ith,mrep) ===' -c write(6,*)' ith =',ith,' mrep =',mrep -c write(6,*)' calling isthick from trlmnt with kt1,kt2=',kt1,kt2 - call isthick(kt1,kt2,ithick,thlen,ith) -c write(6,*)' done: ithick, thlen=', ithick,thlen - if(iverbose.eq.2)then - if(idproc.eq.0)write(6,*)'lmnlbl(ith)=',lmnlbl(ith) - if(idproc.eq.0)then - write(6,*)'kt1,kt2,ithick,thlen=',kt1,kt2,ithick,thlen - endif - endif -c -cryne 08/25/2001 -c autotrack if the user has so specified (w/ autotrack command) -c also, for now the code is set to autotrack even if the user has NOT -c specified, but if the user HAS in fact set the poisson parameters. -c This is consistent with the code further down in this routine, -c where slices are split in half on the basis of whether or not -c nspchset has been set to 1. -c It would perhaps be better to do on the basis of nsckick, not nspchset. - ntrk=0 - if(lautotrk.eq.1)ntrk=1 - if(nspchset.eq.1 .and. nsckick.ne.0)ntrk=1 !???we should omit this. rdr -cryne 11/15/2003 don't let the user mistakenly autotrack if the -cryne current is nonzero but the poisson params have not been set: -cryne this only applies if the code is about to track through a -cryne "thick" beamline element - if(ntrk.eq.1 .and. ithick.eq.1 .and. ntrktype.ne.0)then - if(bcurr.ne.0 .and. nspchset.eq.0)then - if(idproc.eq.0)then - write(6,*)'error: the code is about to track particles,' - write(6,*)'but the current is nonzero and the Poisson' - write(6,*)'solver has not been specified.' - write(6,*)'Use the poisson type code and re-run' - endif - call myexit - endif - endif -c----------------------------------------------------- - nslices=1 - slfrac=1. -c if autoslicing, get the number of slices: -c THIS ASSUMES THAT, IF THE CODE IS RUNNING IN THE MODE WHERE THE # OF -c SLICES IF EXPLICITLY SPECIFIED FOR EACH THICK ELEMENT, THEN IT IS -c ALWAYS THE LAST PARAMETER IN THE LIST: -c if(idproc.eq.0)write(6,*)'sliceprecedence=',sliceprecedence -c if(idproc.eq.0)write(6,*)'slicetype=',slicetype -c if(idproc.eq.0)write(6,*)'slicevalue=',slicevalue - if(ithick.eq.1 .and. slicetype.ne.'none')then - if(sliceprecedence.eq.'local')then -c if(idproc.eq.0)write(6,*)'determining slices locally' -! determine the number of slices locally: - if(slicetype.eq.'slices')then - nn0=mpp(ith)+nrp(1,kt2) - nslices=pmenu(nn0) -c if(idproc.eq.0)write(6,*)'thlen,nslices=',thlen,nslices - if(nslices.le.0)then - write(6,*)'error: nslices .le. 0; nslices=',nslices - call myexit - endif - else - nn0=mpp(ith)+nrp(1,kt2) - if(pmenu(nn0).le.0)then - write(6,*)'something wrong; slices/meter .le. 0' - write(6,*)'pmenu(nn0)=',pmenu(nn0) - call myexit - endif -!!!!!!!!!!! elementlength=pmenu(mpp(ith)+1) - elementlength=thlen - nslices=nint(elementlength/pmenu(nn0)) -c if(idproc.eq.0)write(6,*)'thlen,nslices=',thlen,nslices - if(nslices.eq.0)then - write(6,*)'computed value of nslices =0; resetting to 1' - nslices=1 - endif -ccc write(6,*)'elementlength,slices/m,nslices=', & -ccc & elementlength,pmenu(nn0),nslices - endif - else -! determine the number of slices from the globally set value: -c if(idproc.eq.0)write(6,*)'determining slices globally' - if(slicetype.eq.'slices')then - nslices=nint(slicevalue) -ccc write(6,*)'global_nslices=',nslices - else -!!!!!!!!!!! elementlength=pmenu(mpp(ith)+1) - elementlength=thlen - nslices=nint(elementlength/slicevalue) - if(nslices.eq.0)then - write(6,*)'computed value of nslices =0; resetting to 1' - nslices=1 - endif -ccc write(6,*)'elementlength,global_slices/m,nslices=', & -ccc & elementlength,slicevalue,nslices - endif - endif - endif - kspchset=0 - if(nspchset.eq.1 .or. nenvtrk.eq.1)kspchset=1 - slfrac=1.d0/nslices - if(lautoap2.eq.1 .or. kspchset.eq.1)slfrac=slfrac*0.5d0 -c----------------------------------------------------- -c this is a repeat counter that is usually equal to one: - do 20 i = 1,iabs(mrep) -c write(6,991)lmnlbl(ith),nslices,slfrac,ntrk,arclen - if(iverbose.eq.1)write(6,991)lmnlbl(ith),nslices,ntrk,arclen - if(iverbose.eq.2)write(6,992) & - & lmnlbl(ith),(pmenu(m),m=1+mpp(ith),nrp(kt1,kt2)+mpp(ith)) -c main loop: "tlmt,spch,lmnt" analogous to "map1,map2,map1" -c------------------ - nn1=1+mpp(ith) - nn2=1+mppc(ith) - do 15 j=1,nslices - call init_step_timer - call increment_timer('step',0) -cryne if(lautoap1.eq.1)call autoapp(1) - if(lautoap1.eq.1 .and. (kt1.ne.7.or.kt2.ne.42) .and. ldoit) & - & call autoapp(1) - if((ithick.eq.1).and.((lautoap2.eq.1).or.(kspchset.eq.1)))then - call lmnt(kt1,kt2,pmenu(nn1),cmenu(nn2),ntrk,j,nslices,slfrac,1) -cryne8/21 if(lautoap2.eq.1)call autoapp(2) - if(lautoap2.eq.1 .and. (kt1.ne.7.or.kt2.ne.43) .and. ldoit) & - & call autoapp(2) - tau=2.d0*prevlen - if(kspchset.eq.1)call autospch(tau,ntrk) - call lmnt(kt1,kt2,pmenu(nn1),cmenu(nn2),ntrk,j,nslices,slfrac,2) - else - call lmnt(kt1,kt2,pmenu(nn1),cmenu(nn2),ntrk,j,nslices,slfrac,0) - endif -cryne821if(lautoap3.eq.1)call autoapp(3) - if(lautoap3.eq.1 .and. (kt1.ne.7.or.kt2.ne.44) .and. ldoit) & - & call autoapp(3) -! Short range wakefield forces - if(cmenu(nn2).eq.'wake')then - if(idproc.eq.0)then - write(6,*)'short-range wakes temporarly commented out' - write(6,*)'for debugging. RDR' - endif -cryne call wkfld_srange(nslices,lmnlbl(ith),tau) - endif - call increment_timer('step',1) - call increment_timer('step',1) - call step_timer(lmnlbl(ith),iverbose) - 15 continue -! Long range wakefield forces - if(cmenu(nn2).eq.'wake')then - if(idproc.eq.0)then - write(6,*)'long-range wakes temporarly commented out' - write(6,*)'for debugging. RDR' - endif -cryne call wkfld_lrange - endif -c------------------ - 20 continue - 991 format(a16,' nslices=',i5,' slfrac=',1pe14.7,' ntrk=',i1, & - & ' arclen_in=',1pe14.7) - 992 format(a16,1x,9(1pe10.3,1x)) - return - end -c - subroutine isthick(kt1,kt2,ithick,thlen,ith) -c This routine determines if an element of type "kt1,kt2" is thick. -c If so, and if ith .ne.0, then it also returns its thickness. -c The routine is used in the autoslicing capability of MaryLie/IMPACT. -c It is necessary to return the length only if the user has requested -c that slicing be done N times per meter, i.e. the code needs to -c determine the number of slices based on the length. -c If the user specifies the number of slices, that all that is -c required is to determine whether the element is thick or not. -c Robert Ryne Nov. 30, 2002. - use beamdata - use acceldata - integer kt1,kt2,ithick,ith - integer itfile,numdata - real*8 thlen,p1,p2,rho,gaplen - character*16 estrng,fname,fname1 - character*5 aseq - ithick=0 - thlen=0. - if(kt1.ne.1)return -c 'drft ','nbnd ','pbnd ','gbnd ','prot ', - go to(101, 102, 103, 104, 105, -c 'gbdy ','frng ','cfbd ','quad ','sext ', - & 106, 107, 108, 109, 110, -c 'octm ','octe ','srfc ','arot ','twsm ', - & 111, 112, 113, 114, 115, -c 'thlm ','cplm ','cfqd ','dism ','sol ', - & 116, 117, 118, 119, 120, -c 'mark ','jmap ','dp ','recm ','spce ', - & 121, 122, 123, 124, 125, -c 'cfrn ','coil ','intg ','rmap ','arc ', - & 126, 127, 128, 129, 130, -c 'rfgap ','confoc ','transit','interface','rootmap', - & 1135, 1136, 133, 134, 135, -c 'optirot ','spare5 ','spare6 ','spare7 ','spare8 ', - & 136, 137, 138, 139, 140, -c 'marker ','drift ','rbend ','sbend ','gbend ', - & 141, 142, 143, 1045, 145, -c 'quadrupo','sextupol','octupole','multipol','solenoid', - & 146, 147, 148, 149, 150, -c 'hkicker ','vkicker ','kicker ','rfcavity','elsepara', - & 151, 152, 153, 154, 155, -c 'hmonitor','vmonitor','monitor ','instrume','sparem1 ', - & 156, 157, 158, 159, 160, -c 'rcollima','ecollima','yrot ','srot ','sparem2 ', - & 161, 162, 163, 164, 165, -c 'beambeam','matrix ','profile1d','yprofile','tprofile', - & 166, 167, 168, 169, 170, -c 'hkick ','vkick ','kick ','hpm ','nlrf '/ - & 171, 172, 173, 174, 175),kt2 - -!drft 1: - 101 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 -! write(6,*)'isthick: drft length=',thlen - return -!nbnd 2: - 102 continue - ithick=1 - if(ith.eq.0)return - rho=brho/pmenu(4+mpp(ith)) - p1=pmenu(1+mpp(ith)) - thlen=p1*rho*asin(1.d0)/90.d0 - return -!pbnd 3: - 103 continue - ithick=1 - if(ith.eq.0)return - rho=brho/pmenu(4+mpp(ith)) - p1=pmenu(1+mpp(ith)) - thlen=p1*rho*asin(1.d0)/90.d0 - return -!gbnd 4: - 104 continue - ithick=1 - if(ith.eq.0)return - rho=brho/pmenu(6+mpp(ith)) - p1=pmenu(1+mpp(ith)) - thlen=p1*rho*asin(1.d0)/90.d0 - return -!prot 5: - 105 continue - return -!gbdy 6: - 106 continue - ithick=1 - if(ith.eq.0)return - rho=brho/pmenu(4+mpp(ith)) - p1=pmenu(1+mpp(ith)) - thlen=p1*rho*asin(1.d0)/90.d0 - return -!frng 7: - 107 continue - return -!cfbd 8: - 108 continue - ithick=1 - if(ith.eq.0)return - rho=brho/pmenu(2+mpp(ith)) - p1=pmenu(1+mpp(ith)) - thlen=p1*rho*asin(1.d0)/90.d0 - return -!quad 9: - 109 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 -! write(6,*)'isthick: quad length=',thlen - return -!sext 10: - 110 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!octm 11: - 111 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!octe 12: - 112 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!srfc 13: - 113 continue - return -!arot 14: - 114 continue - return -!twsm 15: - 115 continue - return -!thlm 16: - 116 continue - return -!cplm 17: - 117 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!cfqd 18: - 118 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!dism 19: - 119 continue - return -!sol 20: - 120 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - p2=pmenu(2+mpp(ith)) - thlen=p2-p1 - return -!mark 21: - 121 continue - return -!jmap 22: - 122 continue - return -!dp 23: - 123 continue - return -!recm 24: - 124 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - p2=pmenu(2+mpp(ith)) - thlen=p2-p1 - return -!spce 25: - 125 continue - return -!cfrn 26: - 126 continue - return -!coil 27: - 127 continue - return -!intg 28: - 128 continue - return -!rmap 29: - 129 continue - return -!arc 30: - 130 continue - return -!rfgap 31: - 1135 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - if(p1.ge.0)then - thlen=p1 - return - endif - if(p1.lt.0)then - nseq=pmenu(5+mpp(ith)) - if(nseq.eq.0 .and. cmenu(1+mppc(ith)).eq.' ')then - if(idproc.eq.0)write(6,*)'ISTHICK ERROR(rfgap):no data file' - call myexit - endif - if(cmenu(1+mppc(ith)).eq.' ')then - fname1='rfdata' - ndigits=nseq/10+1 - call num2string(nseq,aseq,ndigits) - j=len_trim(fname1) - fname=fname1(1:j)//aseq(1:ndigits) - else - fname=cmenu(1+mppc(ith)) - endif - nunit=0 - estrng='rfgap' - call fnamechk(fname,nunit,ierr,estrng) - if(ierr.eq.1)then - write(6,*)'(isthick/rfgap) exiting due to problem w/ fname' - call myexit - endif -c write(6,*)'calling read_RFdata from isthick' - call read_RFdata(nunit,numdata,gaplen) - thlen=gaplen -! write(6,*)'isthick: rf gap length=',thlen - return - endif -! -!confoc 32: - 1136 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!transit: - 133 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!interface: - 134 continue - return -!rootmap: - 135 continue - return -!optirot: - 136 continue - return -!spare5: - 137 continue - return -!spare6: - 138 continue - return -!spare7: - 139 continue - return -!spare8: - 140 continue - return -!marker: - 141 continue - return -! -!drift 42: - 142 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 -! write(6,*)'isthick: drift length=',thlen - return -!rbend 43: - 143 continue -cryne 12/21/2004 - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - p2=pmenu(2+mpp(ith)) - rho=brho/p2 - thlen=p1*rho*asin(1.d0)/90.d0 - return -!sbend: 44 - 1045 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - p2=pmenu(2+mpp(ith)) - rho=brho/p2 - thlen=p1*rho*asin(1.d0)/90.d0 - return -!gbend: 45 - 145 continue - return -!quadrupo 46: - 146 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 -! write(6,*)'isthick: quadrupole length=',thlen - return -!sextupol 47: - 147 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!octupole 48: - 148 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!multipol 49: - 149 continue - return -!solenoid 50: - 150 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - p2=pmenu(2+mpp(ith)) - thlen=p2-p1 - return -!hkicker 51: - 151 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!vkicker 52: - 152 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!kicker 53: - 153 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!rfcavity 54: - 154 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!elsepara 55: - 155 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!hmonitor 56 - 156 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!vmonitor 57 - 157 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!monitor 58 - 158 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!instrume 59 - 159 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!sparem1 60 - 160 continue - return -!rcollima 61 - 161 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!ecollima 62 - 162 continue - ithick=1 - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - thlen=p1 - return -!yrot - 163 continue - return -!srot - 164 continue - return -!sparem2 - 165 continue - return -!beambeam - 166 continue - return -!matrix - 167 continue - return -!profile1d 68 - 168 continue - return -!yprofile 69 - 169 continue - return -!tprofile 70 - 170 continue - return -!hkick 71 - 171 continue - goto 151 -!vkick 72 - 172 continue - goto 152 -!kick 73 - 173 continue - goto 153 -!hpm 74 -!fix hpm later - 174 continue - return -!nlrf 75 - 175 continue - ithick=1 -c write(6,*) " === afro::isthick ===" -c write(6,*) " ith = ",ith -c write(6,*) " ithick = ",ithick - if(ith.eq.0)return - p1=pmenu(1+mpp(ith)) - p2=pmenu(2+mpp(ith)) - thlen=p2-p1 - return - end -c -c*********************************************************************** -c - subroutine trloop(string,nrept) -c----------------------------------------------------------------------- -c interprets loops -c Written by Rob Ryne ca 1984 -c adapted to use of strings and slightly simplified in logic -c by Petra Schuett 11-10-87 -c Fixed by Filippo Neri and Alex Dragt 8-29-88 -c----------------------------------------------------------------------- - use acceldata - use lieaparam, only : monoms - include 'impli.inc' -c-------- -c commons -c-------- - include 'stack.inc' - include 'files.inc' - include 'loop.inc' -c--------------- -c parameter type -c--------------- - character string*(*) -c----------------- -c local variables -c----------------- -c lempty = .true. , when stack is empty - logical lempty - save lempty -c----------------------------------------------------------------------- -c start -c----------------------------------------------------------------------- -c??????????????????????????????????????????????????????????????????????? -c printout counters: prints out first nm icons -c -c nm = 100 -c nc = 0 -c write(jof, 700) -c write(jodf,700) -c 700 format(/' entering trloop:'/) -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c -c procedure when nrept=0 -c - if(nrept.eq.0) then - write(jodf,508) string - write(jof, 508) string - 508 format(1x,'loop ',a16,' with rep no. = 0 has been ignored') - return - endif -c -c procedure when nrept .ne. 0 -c - lnrept=npm1(nrept) - joy=1 -c initialize the stacks - call initst(string,lnrept) -c -c----------------------------------------------------------------------- -c here we start with a stack element, either a new one or one that -c just has been popped -c - 1000 continue -c - if(ntype .eq. 1) then -c menu entry should never occur here ... - write(jodf,910) lstac(np) - write(jof ,910) lstac(np) - 910 format(1x,'error in trloop: menu entry ',a16, - & ' found at start of routine.') - call myexit - else if (ntype.eq.3) then -c ... neither should a lump - write(jodf,920) lstac(np) - write(jof ,920) lstac(np) - 920 format(1x,'error in trloop: lump ',a16, - & ' found at start of routine.') - call myexit - else if (ntype.eq.5) then -c unknown label is ignored - write(jodf,930) lstac(np) - write(jof, 930) lstac(np) - 930 format(1x,'warning from trloop: object ',a16,' not found.') -c -c main part is loops or lines (should be the only part used) -c - else if (ntype.eq.2 .or. ntype.eq.4) then -c -c here we begin a computational loop, handling simple -c entries in lines or loops -c - 2000 continue -c - if((ntype.eq.2 .or. ntype.eq.4) .and. - & (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith))) then -c end of a line or loop - loop(np) = loop(np) - npm1(loop(np)) - if(loop(np).ne.0) then - nslot(np) = newsl(np,ith) - call lookup(icon(nslot(np),ith),mtype,jth) - goto 1000 - endif - else if (mtype.eq.2 .and. irep(nslot(np),ith).eq.0) then -c if a line and rep no. = 0 ignore line - write(jodf,509) icon(nslot(np),ith) - write(jof, 509) icon(nslot(np),ith) - 509 format(1x,'line ',a16,' with rep no. = 0 has been ignored') - nslot(np) = nslot(np) + npm1(loop(np)) - if (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith)) goto 2000 - call lookup(icon(nslot(np),ith),mtype,jth) - goto 2000 - else if (mtype.eq.4 .and. irep(nslot(np),ith).eq.0) then -c if a loop and rep no. = 0 ignore loop - write(jodf,510) icon(nslot(np),ith) - write(jof, 510) icon(nslot(np),ith) - 510 format(1x,'loop ',a16,' with rep no. = 0 has been ignored') - nslot(np) = nslot(np) + npm1(loop(np)) - if (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith)) goto 2000 - call lookup(icon(nslot(np),ith),mtype,jth) - goto 2000 - else if (mtype.eq.5) then -c ignore unknown label - write(jodf,930) icon(nslot(np),ith) - write(jof, 930) icon(nslot(np),ith) - nslot(np) = nslot(np) + npm1(loop(np)) - if (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith)) goto 2000 - call lookup(icon(nslot(np),ith),mtype,jth) - goto 2000 - else if (mtype.eq.1 .or. mtype.eq.3) then -c line or loop points to a menu entry or lump - do 10 i=1,iabs(irep(nslot(np),ith)) - if(mtype.eq.1 .and. nt1(jth).eq.2) then -c user supplied element - if(nt2(jth).gt.5) then - write(jof ,940) icon(nslot(np),ith) - write(jodf,940) icon(nslot(np),ith) - 940 format(/' warning from trloop: ',a16,' is a usern', - & ' with n>5') - endif - mim(joy) = 5000+jth - elseif (mtype.eq.1) then -c other menu entry - mim(joy)=-jth - elseif (mtype.eq.3) then -c lump - mim(joy)=jth - endif - joy=joy+1 - 10 continue - if(joy.gt.joymax)then - write(jodf,950) joymax - write(jof ,950) joymax - 950 format(1x,'error: array length >= joymax (', & - & i6,') in trloop') - call myexit - endif -c - next item: - nslot(np) = nslot(np) + npm1(loop(np)) - if (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith)) goto 2000 - call lookup(icon(nslot(np),ith),mtype,jth) - goto 2000 - else if (mtype.eq.2 .or. mtype.eq.4) then -c line or loop points to line or loop - call push - goto 1000 - endif -c -c end of interpretation of a line/loop -c - endif -c end of main way through stack-element -c----------------------------------------------------------------------- -c pop stack; see what's there. this is the normal way to return -c - call pop(lempty) - if (lempty) then - joy = joy-1 - return - endif - goto 1000 -c - end -c -c*********************************************************************** -c - subroutine trobj(string,nrept,ntrk) -c----------------------------------------------------------------------- -c interprets lines and lumps -c Written by Rob Ryne ca 1984 -c Modified to store unmade lumps (tro5) -c -c New features: -c 1. Stores and retrieves unmade lumps in lines -c 2. Stores and retrieves nested lumps -c 3. Ignores lumps with nrept = 0 -c 4. Ignores lines with nrept = 0 -c -c Jim Howard CDG 7-7-87 -c -c adapted to use of strings and slightly simplified in logic -c Petra Schuett 11-9-87 -c -c modified by Alex Dragt 31 August 1988 -c----------------------------------------------------------------------- - use acceldata - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' -c-------- -c commons -c-------- - include 'stack.inc' - include 'core.inc' - include 'map.inc' - include 'files.inc' -c--------------- -c parameter type -c--------------- - character*16 string -c----------------- -c local variables -c----------------- - dimension thsave(monoms,mstack),tmhsav(6,6,mstack) -c making(np) = 1 while this lump is under construction - dimension making(mstack) -c lempty = .true. , when stack is empty - logical lempty - save thsave,tmhsav,making,lempty -c----------------------------------------------------------------------- -c start -c----------------------------------------------------------------------- -c initialize arrays -c - do 5 k = 1,mstack - making(k) = 0 - 5 continue - call initst(string,nrept) -c??????????????????????????????????????????????????????????????????????? -c printout counters: prints out first nm calls to lmnt -c -c nm = 100 -c nc = 0 -c write(jof, 700) -c write(jodf,700) -c 700 format(/' entering trobj:'/) -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c -c ignore incoming line with zero repetition number -c - if(ntype.eq.2.and.nrept.eq.0) then - write(jof , 510) ilbl(ith) - write(jodf, 510) ilbl(ith) - 510 format(1x,'line ',a16,' with rep no. = 0 has been ignored') - return - endif -c -c----------------------------------------------------------------------- -c here we start with a stack element, either a new one or one that -c just has been popped -c - 1000 continue -c - if(ntype .eq. 1) then -c menu element should never occur here ... - write(jodf,910) lstac(np) - write(jof ,910) lstac(np) - 910 format(1x,'error in trobj: menu element ',a16, & - & ' found at beginning of routine.') - call myexit - else if (ntype.eq.4) then -c ... neither should a loop - write(jodf,920) lstac(np) - write(jof ,920) lstac(np) - 920 format(1x,'error in trobj: loop ',a16, & - & ' found at beginning of routine.') - call myexit - else if (ntype.eq.5) then -c unknown label is ignored - write(jodf,930) lstac(np) - write(jof, 930) lstac(np) - 930 format(1x,'warning from trobj: object ',a16,' not found.') -c -c main part is lumps or lines (should be the only part used) -c - else if (ntype.eq.3 .and. loop(np).eq.0) then -c ignore lump with rep factor 0 - write(jof, 520) ilbl(ith) - write(jodf,520) ilbl(ith) - 520 format(1x,'lump ',a16,' with rep no. = 0 has been ignored') - else if (ntype.eq.3 .and. lmade(ith).ne.0) then -c a lump which is already in the core -c??????????????????????????????????????????????????????????????????????? -c write(jof, 710) ith -c write(jodf,710) ith -c 710 format(/' picking up old lump, no.',i4) -c if(nc.lt.nm) write(jodf,715) jth,lmade(jth),loop(np),np -c if(nc.lt.nm) write(jof, 715) jth,lmade(jth),loop(np),np -c 715 format(/5x,'jth =',i4,' lmade(jth) =',i4, -c & 5x,'lumprep =',i3,' np =',i3/) -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c - combine previously made lump with the total map - call comwtm(lmade(ith),loop(np)) -c - else if (ntype.eq.2 .or. ntype.eq.3) then -c all other lines and lumps -c -c first, lumps need special handling, if they are new - if (ntype.eq.3 .and. making(np).ne.1) then - making(np) = 1 -c??????????????????????????????????????????????????????????????????????? -c write(jodf,720) ith,np,loop(np) -c write(jof, 720) ith,np,loop(np) -c 720 format(/' starting lump no. ',i3, -c 1 ' np =',i3,' loop(np) =',i3/) -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c - save current map and initialize a new lump - call buffin(th,tmh,thsave,tmhsav,np) - call ident(th,tmh) - endif -c -c here we begin a computational loop, handling simple elements -c in lines or lumps -c - 2000 continue -c - if(ntype.eq.2 .and. & - & (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith))) then -c end of a line -c???????????????????????????????????????????????????????????????????????? -c if(nc.lt.nm) write(jodf,730) -c if(nc.lt.nm) write(jof, 730) -c 730 format(/' *********************** end of line') -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - loop(np) = loop(np) - npm1(loop(np)) - if(loop(np).ne.0) then - nslot(np) = newsl(np,ith) - call lookup(icon(nslot(np),ith),mtype,jth) - goto 1000 - endif - else if (ntype.eq.3 .and. & - & (nslot(np).eq.0 .or. nslot(np).gt.ilen(ith))) then -c end of a lump -c???????????????????????????????????????????????????????????????????????? -c if(nc.lt.nm) write(jodf,740) -c if(nc.lt.nm) write(jof, 740) -c 740 format(/' *********************** end of lump') -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c - store lump - call lumpit(ith) -c - recall running total map - call bufout(thsave,tmhsav,th,tmh,np) -c - combine new lump with total map: -c??????????????????????????????????????????????????????????????????????? -c write(jof, 750) loop(np) -c write(jodf,750) loop(np) -c 750 format(/' combine new lump with total map: lumprep =',i3/) -c write(jof, 755) ith,lmade(ith) -c write(jodf,755) ith,lmade(ith) -c 755 format(/' ith =',i3,' lmade =',i3/) -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - call comwtm(lmade(ith),loop(np)) - making(np) = 0 - else if (mtype.eq.4) then -c lump or line points to a loop; error - write(jof, 940) lstac(np),icon(nslot(np),ith) - write(jodf,940) lstac(np),icon(nslot(np),ith) - 940 format(1x,'error in trobj: ',a16, & - & ' contains a loop (',a16,').') - call myexit - else if (mtype.eq.2 .and. irep(nslot(np),ith).eq.0) then -c if rep no. = 0 ignore line - write(jof ,510) icon(nslot(np),ith) - write(jodf,510) icon(nslot(np),ith) - nslot(np) = nslot(np) + npm1(loop(np)) - call lookup(icon(nslot(np),ith),mtype,jth) -c??????????????????????????????????????????????????????????????????????? -c if(nc.lt.nm) write(jodf,760) ith,mtype,jth -c if(nc.lt.nm) write(jof, 760) ith,mtype,jth -c 760 format(/' 0*line: ith, mtype, jth:'/5x,3i7) -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - goto 2000 - else if (mtype.eq.5) then -c ignore unknown label - write(jodf,930) icon(nslot(np),ith) - write(jof, 930) icon(nslot(np),ith) - nslot(np) = nslot(np) + npm1(loop(np)) - call lookup(icon(nslot(np),ith),mtype,jth) -c??????????????????????????????????????????????????????????????????????? -c if(nc.lt.nm) write(jodf,762) ith,mtype,jth -c if(nc.lt.nm) write(jof, 762) ith,mtype,jth -c 762 format(/' unkn. : ith, mtype, jth:'/5x,3i7) -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - goto 2000 - else if (mtype.eq.1) then -c line or lump points to an element -c??????????????????????????????????????????????????????????????????????? -c nc = nc + 1 -c if(nc.lt.nm) write(jodf,770) np -c if(nc.lt.nm) write(jof, 770) np -c 770 format(/' element in line or lump: np =',i3/) -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - call trlmnt(jth,irep(nslot(np),ith)) -c - next element: - nslot(np) = nslot(np) + npm1(loop(np)) -cryne Jan 6, 2005 added "if" test: - if(nslot(np).ge.1)then - call lookup(icon(nslot(np),ith),mtype,jth) - endif -c??????????????????????????????????????????????????????????????????????? -c if(nc.lt.nm) write(jodf,764) ith,mtype,jth -c if(nc.lt.nm) write(jof, 764) ith,mtype,jth -c 764 format(/' next icon: ith, mtype, jth:'/7x,3i7) -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - goto 2000 - else if (mtype.eq.2 .or. mtype.eq.3) then -c line or lump points to line or lump - call push -c??????????????????????????????????????????????????????????????????????? -c if(nc.lt.nm) write(jof, 780) np -c if(nc.lt.nm) write(jodf,780) np -c780 format(/' *********************** pushing stack: new np =',i3) -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - goto 1000 - endif -c -c end of interpretation of a line/lump -c - endif -c end of main way through stack-element -c----------------------------------------------------------------------- -c pop stack; see what's there. this is the normal way to return -c - call pop(lempty) - if (lempty) return -c -c??????????????????????????????????????????????????????????????????????? -c write(jof, 790) np -c write(jodf,790) np -c790 format(/' *************************** popping stack: new np =',i3) -c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c - goto 1000 - end -c -c end of file -c - subroutine old_set_pscale_mc(h,mh) -c scale a map to use mc as the scale momentum (instead of p0) - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'expon.inc' - double precision h(monoms),mh(6,6) -c -c This routine is needed if we want to use "dynamic" units, which -c makes sense, e.g., if the beam is being accelerated. -c It converts maps from the "usual" units (in which MaryLie lets the user -c specify any scale length and assumes a scale momentum p0) -c to units where -c THE REST OF THIS COMMENT IS WRONG. FIX LATER. RDR -cthe new scale length is given by l=c/w (where w is a scale -c frequency = 2pi*the freq specified by the user in the new #beam component) -c and where the new scale momentum is m*c -c -c Skip this routine if we are using magnetostatic units (the "usual" units) -c write(6,*)'****************************************************' -c write(6,*)'**************HERE I AM IN SETPSCALEMC**************' -c write(6,*)'****************************************************' -c -c exit if "magnetic" units (i.e. standard MaryLie units) are being used: - if(lflagmagu)return -c see if "dynamic" units are being used; change only affects the momenta -c since the MaryLie library routines include the effect of sl: - if(lflagdynu)then -c write(6,*)'dynamic units.' - x2ovrx1=1. - p2ovrp1=1./(beta*gamma) - else -c some other units are being used: -c write(6,*)'general units.' - x2ovrx1=1. - p2ovrp1=p0sc/(beta*gamma*pmass/c) - endif - - x1ovrx2=1./x2ovrx1 - p1ovrp2=1./p2ovrp1 -cdebug -c write(6,*)'inside set_pscale' - -c bg=beta*gamma -c bgi=1./bg -c -ctm mh(1,2:6:2)=mh(1,2:6:2)/bg -ctm mh(3,2:6:2)=mh(3,2:6:2)/bg -ctm mh(5,2:6:2)=mh(5,2:6:2)/bg -c -ctm mh(2,1:5:2)=mh(2,1:5:2)*bg -ctm mh(4,1:5:2)=mh(4,1:5:2)*bg -ctm mh(6,1:5:2)=mh(6,1:5:2)*bg -ctm replace f90 array code with f77 do loops: -crdr replace beta*gamma with more general form: - do 100 i = 2, 6, 2 - do 70 j = 1, 5, 2 - mh(j,i) = mh(j,i)*p2ovrp1*x1ovrx2 - mh(i,j) = mh(i,j)*p1ovrp2*x2ovrx1 - 70 continue - 100 continue -c -cryne 08/26/2001 -c now change the units of the nonlinear part of the map: - do 200 i=28,209 -c h(i)=h(i)*bgi**(expon(2,i)+expon(4,i)+expon(6,i)) -c h(i)=h(i)*bgi**exp246(i) - h(i)=h(i)*(p2ovrp1**nxp246(i))*(x2ovrx1**nxp135(i)) - 200 continue - return - end -c - subroutine set_pscale_mc(h,mh) -c scale a map to use mc as the scale momentum (instead of p0) - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'expon.inc' - double precision h(monoms),mh(6,6) -c -c write(6,*)'=== afro::set_pscale_mc() ===' -c write(6,*) 'beta, gamma, pmass, brho = ',beta,gamma,pmass,brho -c write(6,*) 'scale l, p, t, w, f= ',sl,p0sc,ts,omegascl,freqscl -c -cryne Jan 30,2003 -c this routine does 2 things: -c (1) convert from static to dynamic units (if needed), -c (2) convert variables 5 and 6 to take into account the fact that the -c scale varables omega and l are independent and do not need to -c satisfy omega*l/c=1 (as is assumed in the MaryLie library routines) -c - clite=299792458.d0 -c dynamic units: -calsowrong p2ovrp1=1.d0 - p2ovrp1=p0sc/(gamma*beta*pmass/clite) -c write(6,*)'initializing p2ovrp1 to ',p2ovrp1 -c - if(lflagdynu)then - p2ovrp1=1./(beta*gamma) -c write(6,*)'lflagdynu is true; resetting p2ovrp1 to ',p2ovrp1 - endif -cwrong: if(lflagdynu)p2ovrp1=(pmass/clite)/p0sc -cryne the reason this was wrong is that the MaryLie library -cryne routines use brho, the p0sc.In other words, everything -cryne is computed relative to the present momentum. - p1ovrp2=1.d0/p2ovrp1 -c omega*l/c: - scal5=1.d0 - scal6=1.d0 - wlbyc=omegascl*sl/clite -c write(6,*)'initializing wlbyc to ',wlbyc - if(wlbyc.ne.1.d0)then -c write(6,*)'scal5 being set to wlbyc, scal6 set to 1/wlbyc' - scal5=wlbyc - scal6=1.d0/wlbyc - endif -c - mh(1,2)=mh(1,2)*p2ovrp1 - mh(1,4)=mh(1,4)*p2ovrp1 - mh(1,5)=mh(1,5)/wlbyc - mh(1,6)=mh(1,6)*p2ovrp1*wlbyc -c - mh(2,1)=mh(2,1)*p1ovrp2 - mh(2,3)=mh(2,3)*p1ovrp2 - mh(2,5)=mh(2,5)*p1ovrp2/wlbyc - mh(2,6)=mh(2,6)*wlbyc -c - mh(3,2)=mh(3,2)*p2ovrp1 - mh(3,4)=mh(3,4)*p2ovrp1 - mh(3,5)=mh(3,5)/wlbyc - mh(3,6)=mh(3,6)*p2ovrp1*wlbyc -c - mh(4,1)=mh(4,1)*p1ovrp2 - mh(4,3)=mh(4,3)*p1ovrp2 - mh(4,5)=mh(4,5)*p1ovrp2/wlbyc - mh(4,6)=mh(4,6)*wlbyc -c - mh(5,1)=mh(5,1)*wlbyc - mh(5,2)=mh(5,2)*p2ovrp1*wlbyc - mh(5,3)=mh(5,3)*wlbyc - mh(5,4)=mh(5,4)*p2ovrp1*wlbyc - mh(5,6)=mh(5,6)*p2ovrp1*wlbyc**2 -c - mh(6,1)=mh(6,1)*p1ovrp2/wlbyc - mh(6,2)=mh(6,2)/wlbyc - mh(6,3)=mh(6,3)*p1ovrp2/wlbyc - mh(6,4)=mh(6,4)/wlbyc - mh(6,5)=mh(6,5)*p1ovrp2/wlbyc**2 -c -c now change the units of the nonlinear part of the map: -cryne 12/21/2004 changed "i=28,209" to "i=28,monoms" !!!!!!!!!!!!!! -c write(6,*)'modified set_pscale_mc do loop to use monoms=',monoms - do 200 i=28,monoms -ccc h(i)=h(i)*(p2ovrp1**nxp246(i))*(x2ovrx1**nxp135(i)) -!!! h(i)=h(i)*(p2ovrp1**nxp24(i))*(scal5**nxp5(i))*(scal6**nxp6(i)) -cryne 12/21/2004 note that this is a minus 1 only in nxp13 and nxp24 -cryne note that we are assuming that the scale length has been done already -! h(i)=h(i)*(p2ovrp1**(nxp24(i)+nxp6(i)))*(scal5**(nxp5(i)-nxp6(i))) - h(i)=h(i)*(p2ovrp1**(nxp24(i)+nxp6(i)))*(scal5**(nxp6(i)-nxp5(i))) - 200 continue - return - end -c - subroutine set_rfscale(h,mh) -c Nov 5, 2003 -c scale the map produced by subroutine rfgap (if needed) -c note that the rf gap routine returns a map assuming -c dynamic units, with a scale length l=c/omega - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'expon.inc' - double precision h(monoms),mh(6,6) -c -c switch to static units if needed: -c rf gap routine works in "dynamic" units, with p1=mc; -c If MLI is using "static" units, this routine transforms -c to p2=the scale momentum p0sc -c therefore p2ovrp1=p0sc/mc if shifting to static mode - clite=299792458.d0 - p2ovrp1=1.d0 - if(.not.lflagdynu)p2ovrp1=p0sc/(pmass/clite) - p1ovrp2=1.d0/p2ovrp1 -c -c Use this if the rfgap routine works internally assuming q1=c/omega, -c with the scale ang freq (internally) equal to the MLI scale ang freq: -c In this case, q2 is the MLI scale length, therefore q2ovrq1=sl/(c/omega) -cryne 5/1/2006 uncommented these: - q2ovrq1=sl/(clite/omegascl) - q1ovrq2=1.d0/q2ovrq1 - w2ovrw1=1.d0 - w1ovrw2=1.d0/w2ovrw1 -c -c Use this if the rfgap routine works internally assuming a -c scale ang freq given by omega=c/sl, with the scale length -c (internally) equal to the MLI scale length: In this case -c w2 is the MLI scale ang freq, therefore w2ovrw1=omegascl/(c/sl) -cryne 5/1/2006 commented out the following: -c w2ovrw1=omegascl/(clite/sl) -c w1ovrw2=1.d0/w2ovrw1 -c q2ovrq1=1.d0 -c q1ovrq2=1.d0/q2ovrq1 -c -c Scale linear part of the map. - mh(1,2)=mh(1,2)*p2ovrp1*q1ovrq2 - mh(1,4)=mh(1,4)*p2ovrp1*q1ovrq2 - mh(1,5)=mh(1,5)*w1ovrw2*q1ovrq2 - mh(1,6)=mh(1,6)*p2ovrp1*w2ovrw1 -c - mh(2,1)=mh(2,1)*p1ovrp2*q2ovrq1 - mh(2,3)=mh(2,3)*p1ovrp2*q2ovrq1 - mh(2,5)=mh(2,5)*p1ovrp2*w1ovrw2 - mh(2,6)=mh(2,6)*w2ovrw1*q2ovrq1 -c - mh(3,2)=mh(3,2)*p2ovrp1*q1ovrq2 - mh(3,4)=mh(3,4)*p2ovrp1*q1ovrq2 - mh(3,5)=mh(3,5)*w1ovrw2*q1ovrq2 - mh(3,6)=mh(3,6)*p2ovrp1*w2ovrw1 -c - mh(4,1)=mh(4,1)*p1ovrp2*q2ovrq1 - mh(4,3)=mh(4,3)*p1ovrp2*q2ovrq1 - mh(4,5)=mh(4,5)*p1ovrp2*w1ovrw2 - mh(4,6)=mh(4,6)*w2ovrw1*q2ovrq1 -c - mh(5,1)=mh(5,1)*w2ovrw1*q2ovrq1 - mh(5,2)=mh(5,2)*w2ovrw1*p2ovrp1 - mh(5,3)=mh(5,3)*w2ovrw1*q2ovrq1 - mh(5,4)=mh(5,4)*w2ovrw1*p2ovrp1 - mh(5,6)=mh(5,6)*q2ovrq1*p2ovrp1*w2ovrw1**2 -c - mh(6,1)=mh(6,1)*w1ovrw2*p1ovrp2 - mh(6,2)=mh(6,2)*w1ovrw2*q1ovrq2 - mh(6,3)=mh(6,3)*w1ovrw2*p1ovrp2 - mh(6,4)=mh(6,4)*w1ovrw2*q1ovrq2 - mh(6,5)=mh(6,5)*q1ovrq2*p1ovrp2*w1ovrw2**2 -c -cryne 08/26/2001 -cryne 11/06/2003 -c now change the units of the nonlinear part of the map: - scal6=w2ovrw1*q2ovrq1*p2ovrp1 -cryne 12/21/2004 changed "i=28,209" to "i=28,monoms" -cryne (this does not matter now, but will matter when we do nonlinear rf maps) -c write(6,*)'(subroutine set_rfscale): need to fix scaling of the' -c write(6,*)'nonlinear part of rfgap map; it is probably wrong!!' -cabell =Tue Dec 28 08:32:15 PST 2004= Think I've fixed scaling here. -cccryne 22 May 2006 -- Since this is only called by rfgap (i.e. only the linear -ccc map is produced), skip the scaling of the nonlinear part -ccc write(6,*)'(subroutine set_rfscale): still need to verify scaling' -ccc write(6,*)'of nonlinear part of rfcavity!! **********************' -ccc do 200 i=28,monoms -ccc h(i)=h(i)*(q2ovrq1**(nxp13(i)+nxp6(i))) & -ccc & *(p2ovrp1**(nxp24(i)+nxp6(i))) & -ccc & *(w2ovrw1**(nxp6(i)-nxp5(i))) -cabell this is equivalent to above -c h(i)=h(i)*(p2ovrp1**nxp24(i))*(q2ovrq1**nxp13(i)) & -c & *(w1ovrw2**nxp5(i))*(scal6**nxp6(i)) -cabell this is ok if scale lengths are equal -c h(i)=h(i)*(p2ovrp1**(nxp24(i)+nxp6(i))) & -c & *(w2ovrw1**(nxp6(i)-nxp5(i))) -ccc200 continue - return - end -c - -c\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -c============================================================================== -c////////////////////////////////////////////////////////////////////////////// - - subroutine rescale_map(lsold,psold,fsold,h,mh,lsnew,psnew,fsnew) -c------------------------------------------------------------------------------ -c -c rescale_map: Takes given values for the scale factors of a given map -c and rescales the map to the currently defined scale factors. -c Optionally, it can take a list of new scale factors, instead -c of assuming the currently defined scale factors. -c -c input: -c -c lsold - given length scale of map -c psold - given momentum scale of map -c fsold - given frequency scale of map -c h - non-linear coefficients of given map -c mh - matrix part of given map -c -c OPTIONAL input: (all must be present to work!!!) -c -c lsnew - length scale to scale map TO -c psnew - momentum scale to scale map TO -c fsnew - frequency scale to scale map TO -c -c output: -c -c h - rescaled map -c mh - rescaled map -c -c KMP - 15 Dec 2006 -c -c------------------------------------------------------------------------------ - use lieaparam, only : monoms - use beamdata, only : sl,p0sc,freqscl - implicit none - include 'expon.inc' - double precision, intent(in) :: lsold,psold,fsold ! scale factors of given map - double precision, optional, intent(in) :: lsnew,psnew,fsnew ! new scale factors to use in scaling - double precision, intent(inout), dimension(1:6,1:6) :: mh - double precision, intent(inout), dimension(1:monoms) :: h - double precision p2ovrp1,p1ovrp2 - double precision q2ovrq1,q1ovrq2 - double precision w2ovrw1,w1ovrw2 - integer i,j -c - if(psold.eq.0.)then - write(*,*) 'error (rescale_map): zero momentum scale given' - call myexit - elseif(lsold.eq.0.)then - write(*,*) 'error (rescale_map): zero length scale given' - call myexit - elseif(fsold.eq.0.)then - write(*,*) 'error (rescale_map): zero frequency scale given' - call myexit - endif - - if(present(lsnew).and.present(psnew).and.(present(fsnew)))then - if(psnew.eq.0.)then - write(*,*) 'error (rescale_map): zero momentum scale given' - call myexit - elseif(lsnew.eq.0.)then - write(*,*) 'error (rescale_map): zero length scale given' - call myexit - elseif(fsnew.eq.0.)then - write(*,*) 'error (rescale_map): zero frequency scale given' - call myexit - endif - p1ovrp2 = psold / psnew - p2ovrp1 = psnew / psold - q1ovrq2 = lsold / lsnew - q2ovrq1 = lsnew / lsold - w1ovrw2 = fsold / fsnew - w2ovrw1 = fsnew / fsold - else - p1ovrp2 = psold / p0sc - p2ovrp1 = p0sc / psold - q1ovrq2 = lsold / sl - q2ovrq1 = sl / lsold - w1ovrw2 = fsold / freqscl - w2ovrw1 = freqscl / fsold - endif -c - mh(1,2)=mh(1,2)*p2ovrp1*q1ovrq2 - mh(1,4)=mh(1,4)*p2ovrp1*q1ovrq2 - mh(1,5)=mh(1,5)*w1ovrw2*q1ovrq2 - mh(1,6)=mh(1,6)*p2ovrp1*w2ovrw1 -c - mh(2,1)=mh(2,1)*p1ovrp2*q2ovrq1 - mh(2,3)=mh(2,3)*p1ovrp2*q2ovrq1 - mh(2,5)=mh(2,5)*p1ovrp2*w1ovrw2 - mh(2,6)=mh(2,6)*w2ovrw1*q2ovrq1 -c - mh(3,2)=mh(3,2)*p2ovrp1*q1ovrq2 - mh(3,4)=mh(3,4)*p2ovrp1*q1ovrq2 - mh(3,5)=mh(3,5)*w1ovrw2*q1ovrq2 - mh(3,6)=mh(3,6)*p2ovrp1*w2ovrw1 -c - mh(4,1)=mh(4,1)*p1ovrp2*q2ovrq1 - mh(4,3)=mh(4,3)*p1ovrp2*q2ovrq1 - mh(4,5)=mh(4,5)*p1ovrp2*w1ovrw2 - mh(4,6)=mh(4,6)*w2ovrw1*q2ovrq1 -c - mh(5,1)=mh(5,1)*w2ovrw1*q2ovrq1 - mh(5,2)=mh(5,2)*w2ovrw1*p2ovrp1 - mh(5,3)=mh(5,3)*w2ovrw1*q2ovrq1 - mh(5,4)=mh(5,4)*w2ovrw1*p2ovrp1 - mh(5,6)=mh(5,6)*q2ovrq1*p2ovrp1*w2ovrw1**2 -c - mh(6,1)=mh(6,1)*w1ovrw2*p1ovrp2 - mh(6,2)=mh(6,2)*w1ovrw2*q1ovrq2 - mh(6,3)=mh(6,3)*w1ovrw2*p1ovrp2 - mh(6,4)=mh(6,4)*w1ovrw2*q1ovrq2 - mh(6,5)=mh(6,5)*q1ovrq2*p1ovrp2*w1ovrw2**2 -c - do i=28,monoms - h(i)=h(i)*(q2ovrq1**(nxp13(i)+nxp6(i))) - & *(p2ovrp1**(nxp24(i)+nxp6(i))) - & *(w2ovrw1**(nxp6(i)-nxp5(i))) - enddo - return - end - - -************************************************************************ - subroutine mlfinc(incnam) -c----------------------------------------------------------------------- - use beamdata - use acceldata - use lieaparam, only : monoms - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- -c - include 'codes.inc' - include 'files.inc' -c----------------------------------------------------------------------- -c arguments: - character incnam*(*) -c local variables: - character*16 strarr(40),string - character*100 line - integer narr(40) - logical leof,lcont,npound -cryne 8/15/2001 new code to read in a character string instead of numbers: -c----------------------------------------------------------------------- -c start - lfold=lf - lf=98 -cryne----- 15 Sept 2000 modified to check for input file: - open(lf,file=incnam,status='old',err=357) - itot = 0 - leof = .false. - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm write(6,333) line -ctm 333 format(' first line in include file:',/,a) - if(leof)then - write(6,*)'error: empty file:',incnam - stop - endif - goto 4320 -ctm 357 write(6,*)'error: empty file:', incnam -c -ctm error opening include file -c - 357 continue - write(jof,358) incnam - write(jodf,358) incnam - 358 format(' ERROR: cannot open #include file: ',/,a) - call myexit -cryne----- -c----------------------------------------------------------------------- - 4320 continue - leof = .false. - rewind lf - msegm = -1 -c-------------------- -c read first line of master input file (should set msegm) -c - 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 -c-------------------- -c new component (segment) begins, branch to appropriate part of code -c - 1 goto(100,200,300,400,500,600,700,800),msegm -c -c error exit: - write(jof ,99) msegm - write(jodf,99) msegm - 99 format(1x,i6,'=msegm problem at big goto of routine mlfinc') - call myexit -c-------------------- -c #comment -c - 100 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 1) goto 1 -c - npcom=npcom+1 - if(npcom.gt.maxcmt) then - write(jof ,199) maxcmt - write(jodf,199) maxcmt - 199 format(1x,'error in dumpin:', & - & ' too many comment lines (>= maxcmt = ',i6,') in #comment') - call myexit - endif - mline(npcom)=line - goto 100 -c-------------------- -c #beam -c - 200 continue - write(6,*)'error: cannot have #beam when using mlfinc' - stop -c-------------------- -c #menu -c - 300 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 3) goto 1 -c - na=na+1 - if(na.gt.mnumax) then - write(jof ,399) mnumax - write(jodf,399) mnumax - 399 format(1h ,'error in dumpin:', & - & ' too many items (>= mnumax = ',i6,') elements in #menu') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,396) strarr(1) - write(jodf,396) strarr(1) - 396 format(' error detected by dumpin in #menu: name ', & - & a8,' is doubly defined'/ & - & ' the second definition will be ignored') - na = na-1 - goto 300 - endif -c check if element/command name is present ( F. Neri 4/14/89 ): - if ( itot .lt. 2 ) then - write(jof ,1396) strarr(1) - write(jodf ,1396) strarr(1) - 1396 format(' error in #menu: ',a8,' has no type code!') - call myexit - endif - if ( itot .gt. 2 ) then - write(jof ,1397) strarr(1) - write(jodf ,1397) strarr(1) - 1397 format(' error in #menu: ',a8,' has more than one type code!') - call myexit - endif -c new item in menu: - lmnlbl(na)=strarr(1) -c string is name of element/command type, look up element indices - string=strarr(2) - do 325 m = 1,9 -cryne do 325 n = 1,40 -cryne 7/3/02 do 325 n = 1,45 - do 325 n = 1,nrpmax - if(string.eq.ltc(m,n)) then - nt1(na) = m - nt2(na) = n -c read parameters. Number of parameters is given in nrp - imax=nrp(m,n) - if(imax.eq.0)goto 300 - mpp(na) = mpprpoi -cryne---8/15/2001 - if((m.eq.1).and.(n.eq.42.or.n.eq.43.or.n.eq.44))then -c read a character string -cryne 08/24/2001 - mpp1=mppc(na)+1 -cryne read(lf,*,err=390)(cmenu(1+mppc(na))) - read(lf,*,err=390)cmenu(mpp1) - pmenu(1+mpp(na))=1+mpp(na) - mpprpoi=mpprpoi+1 - goto 300 - else -cryne--- - read(lf,*,err=390)(pmenu(i+mpp(na)),i=1,imax) - mpprpoi = mpprpoi + imax - goto 300 - endif -c normal end of a menu element/command - endif - 325 continue -c -c error: unknown element/command name - write(jof ,398)(strarr(j),j=1,2) - write(jodf,398)(strarr(j),j=1,2) - 398 format(1h ,'dumpin error in ',a8,': type code ',a8,' not found.'/ & - & 1h ,'this item will be ignored') - na=na-1 - goto 300 -c -c error in parameter input - 390 write(jof ,397)lmnlbl(na) - write(jodf,397)lmnlbl(na) - 397 format(1h ,'dumpin data input error at item ',a8) - call myexit -c-------------------- -c #lines,#lumps,#loops -c - 400 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 4) goto 1 - goto 410 - 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 5) goto 1 - goto 410 - 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 6) goto 1 -c - 410 nb=nb+1 - if(nb.gt.itmno)then - write(jof ,499) itmno - write(jodf,499) itmno - 499 format(1h ,'error in dumpin:', & - & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,497) ling(msegm),strarr(1) - write(jodf,497) ling(msegm),strarr(1) - 497 format(1x,'dumpin error in ', & - & a8,': name ',a8,' is doubly defined'/ & - & ' the second definition will be ignored') - na = na-1 - if(msegm .eq.4) then - goto 400 - else if(msegm.eq.5) then - goto 500 - else if(msegm.eq.6) then - goto 600 - endif - endif -c new item - ilbl(nb)=strarr(1) -c read components of item - imin=0 -c-- -c repeat... - 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if(imin+itot.gt.itmln)then - write(jof ,498) itmln,ilbl(nb) - write(jodf,498) itmln,ilbl(nb) - 498 format(1h ,'error in dumpin:', & - & ' too many entries (> itmln = ',i6,') in ',a16) - call myexit - endif -c store names and rep rates of components - do 425 i=1,itot - icon(imin+i,nb)=strarr(i) - irep(imin+i,nb)=narr(i) - 425 continue - imin=imin+itot - if(lcont) goto 420 -c ... until no more continuation lines -c-- -c now set length and type of element - ilen(nb)=imin - ityp(nb)=msegm-2 -c go back to appropriate component (segment) - if(msegm .eq.4) then - goto 400 - else if(msegm.eq.5) then - goto 500 - else if(msegm.eq.6) then - goto 600 - endif -c-------------------- -c #labor -c - 700 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 7) goto 1 -c - noble=noble+1 - if(noble.gt.mlabor) then - write(jof ,799) mlabor - write(jodf,799) mlabor - 799 format(1h ,'error in dumpin:', & - & ' too many entries (>= mlabor = ',i6,') in #labor array') - call myexit - endif -c new task - latt(noble)=strarr(1) - num(noble)=narr(1) - goto 700 -c-------------------- -c #include - 800 continue - write(6,*)'error: cannot use #include with mlfinc' - stop -c normal return at end of file - 1000 continue - close(98) - lf=lfold - return - end -c -c*********************************************************************** - subroutine autoapp(n) - use parallel, only : idproc - use acceldata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'map.inc' - character*16 string - character*16 autostr - real*8 thlen - common/autopnt/autostr(3) - common/autolog/lautoap1,lautoap2,lautoap3,lrestrictauto - common/showme/iverbose -c---dummy variables needed in calls to lmnt: - jslice=1 - jsltot=1 - slfrac=1. - ntrk=0 -c--- -c string is the value of parameter "name" in the autoapply command - string=autostr(n) - if(iverbose.eq.2)write(6,*)'(inside autoapp) n,string=',n,string -c this version works only if the object is a either menu element or a line - call lookup(string,itype,ith) - if(iverbose.eq.2)write(6,*)'back from lookup; string,itype,ith=' - if(iverbose.eq.2)write(6,*)string,itype,ith -cryne Oct 30, 2003 - if(itype.eq.5)then - if(idproc.eq.0)then - write(6,*)'error: trying to perform autoapply, but the item' - write(6,*)string(1:16) - write(6,*)'has not been successfuly defined in the menu' - endif - call myexit - endif - mt1=nt1(ith) - mt2=nt2(ith) - l1=1+mpp(ith) - l2=1+mppc(ith) -c element: - if(itype.eq.1)then - if(iverbose.eq.2)write(6,*)'string ',string,' is a menu item' -c don't allow automatic application of thick elements - call isthick(mt1,mt2,ithick,thlen,0) - if(ithick.eq.1)write(6,*)'error: thick element found!:',string - if(ithick.eq.1)return - call lmnt(mt1,mt2,pmenu(l1),cmenu(l2),ntrk,jslice,jsltot,slfrac,0) - if(iverbose.eq.2)write(6,*)'normal return from autoapp' - return - endif -c step through the line: - if(itype.eq.2)then - if(iverbose.eq.2)write(6,*)'string ',string,' is a line' - if(iverbose.eq.2) & - & write(6,*)'ith,ilbl(ith),ilen(ith)=',ith,ilbl(ith),ilen(ith) - do 100 k=1,ilen(ith) - call lookup(icon(k,ith),ktype,kth) - if(ktype.ne.1)then - if(idproc.eq.0)then - write(6,*)'error in autoapp:',string,icon(k,ith) - if(ktype.eq.2)write(6,*)'cannot handle nested lines' - if(ktype.eq.3)write(6,*)'cannot handle lumps' - if(ktype.eq.4)write(6,*)'cannot handle loops' - if(ktype.eq.5)write(6,*)'cannot find entry: ',icon(k,ith) - endif - call myexit - endif - kt1=nt1(kth) - kt2=nt2(kth) - l1=1+mpp(kth) - l2=1+mppc(kth) - call isthick(kt1,kt2,ithick,thlen,0) - if(ithick.eq.1)write(6,*)'error:thick lmnt in line!:',icon(k,2) - if(ithick.eq.1)return - do 99 iii=1,iabs(irep(k,ith)) - if(iverbose.eq.2)write(6,*)'icon(k,ith)=',icon(k,ith) - call lmnt(kt1,kt2,pmenu(l1),cmenu(l2),ntrk,jslice,jsltot,slfrac,0) - 99 continue - 100 continue - if(iverbose.eq.1)write(6,*)'normal return from autoapp' - return - endif -c can autoapply only menu entries or simple lines. -c complain that you cannot autoapply lumps or loops - if(itype.eq.3 .or. itype.eq.4)then - write(6,*)'autoapp: error: lump or loop not allowed:',string - return - endif - if(itype.eq.5)then - write(6,*)'autoapp:string not found:',string - return - endif - end -c -************************************************************************ - subroutine autospch(tau,ntrk) - use beamdata - use rays - use lieaparam, only : monoms - use ml_timer - include 'impli.inc' - include 'map.inc' - include 'files.inc' - logical msk,straight - character*16 cparams -!3/6/03 dimension c4(4,maxray),c6(6,maxray),msk(maxray) -!3/6/03 dimension ex(maxray),ey(maxray),ez(maxray) -!3/6/03 dimension tmp(maxray),tmpr(maxray) - dimension c4(4,maxrayp),c6(6,maxrayp),msk(maxrayp) - dimension ex(maxrayp),ey(maxrayp),ez(maxrayp) - dimension tmp(maxrayp),tmpr(maxrayp) -!hpf$ distribute (*,block) :: c6 -!hpf$ align (*,:) with c6(*,:) :: c4 -!hpf$ align (:) with c6(*,:) :: ex,ey,ez,tmp,tmpr,msk - common/robhack/zlocate - common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0 - common/poiblock1/nspchset,nsckick - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - common/newpoisson/idirectfieldcalc,idensityfunction,idummy(4) - common/scparams/rparams(60),cparams(60) - common/showme/iverbose - common/envstuff/nenvtrk - common/autotrk/lautotrk,ntrktype,ntrkorder -c -c write(6,*)'inside autospch' -cryne-April 8, 2004 new code for integrating envelope equations - if(nenvtrk.eq.1)then -c write(6,*)'calling envkick' - call envkick(tau) -c write(6,*)'returned from envkick' - endif - if(ntrktype.eq.0)return -c write(6,*)'still inside autospch, performing space charge calc' -cryne-Now continue with the usual space-charge calculation -c -c check that space charge parameters have been set: -c note that the elements of rparams are initialized to -9999999. -c - if(rparams(1).lt.-1.d6)then - if(idproc.eq.0)then - write(6,*)'ERROR: ATTEMPT TO TRACK WITH SPACE CHARGE,' - write(6,*)'BUT POISSON SOLVER PARAMETERS HAVE NOT BEEN SET.' - write(6,*)'RERUN WITH INPUT MODIFIED TO INCLUDE POISSON' - endif - call myexit - endif -c -c -c if(curr0.eq.-99999.)then -c write(6,*) & -c & 'error:entered space charge routine but current has not been set' -c stop -c endif -cryne 1/6/03 tau=2.d0*prevlen - curr=bcurr -! if(idproc.eq.0)write(12,*)'[autospch]curr,tau=',curr,tau - if(curr.eq.0.)then - if(iverbose.eq.2)write(6,*)'returning from sc routine (curr=0)' - return - endif -ccc - straight=.true. -c if(nt2prev.eq.2 .or. nt2prev.eq.4)straight=.false. - - nx0=nxsave - ny0=nysave - nz0=nzsave -c write(6,*)'nx0,ny0,nz0=',nx0,ny0,nz0 -c - clite=299792458.d0 - fpei=clite*clite*1.d-7 - vz0=beta*clite - perv=2.d0*curr*fpei/(brho*vz0*vz0*gamma*gamma) -c write(6,*)'perv=',perv -c write(6,*)'curr,brho,gamma=',curr,brho,gamma -c write(6,*)'fpei,beta,vz0=',fpei,beta,vz0 -cryne 11/19/02 if(nraysp.ne.maxrayp)then -cryne 11/19/02 write(6,*)'error:autospch works only w/ nrays=maxrayp' -cryne 11/19/02 write(6,*)'nraysp,maxrayp=',nraysp,maxrayp -cryne 11/19/02 stop -cryne 11/19/02 endif - if(nz0.eq.0)then - do j=1,nraysp - c4(1,j)=sl*zblock(1,j) - c4(2,j)= zblock(2,j) - c4(3,j)=sl*zblock(3,j) - c4(4,j)= zblock(4,j) - enddo -!******************************************************* - do j=1,nraysp - if(istat(j).eq.0)then - msk(j)=.true. - else - msk(j)=.false. - endif - enddo - if(nraysp.lt.maxrayp)then - do j=nraysp+1,maxrayp - msk(j)=.false. - enddo - endif -!******************************************************* - nx=nx0 - ny=ny0 - n1=2*nx - n2=2*ny -! if(idproc.eq.0)then -! write(6,*)'Note: 2D space charge only works in static units' -! endif - if(idirectfieldcalc.eq.0)then -! if(idproc.eq.0)write(6,*)'calling spch2dphi' - call spch2dphi(c4,ex,ey,msk,nraysp,nrays,nx,ny,n1,n2) - else -! if(idproc.eq.0)write(6,*)'calling slic2d' - call spch2ddirect(c4,ex,ey,msk,nraysp,nrays,nx,ny,n1,n2) - endif -!4/28/03 put 1/nrays in spch2d -!4/28/03 also put 1/2pi in spch2d, which means need *2pi here -!4/28/03xycon=perv/nrays - twopi=4.d0*asin(1.d0) - xycon=twopi*perv -c 4/26/03 case of dynamic units not yet tested, but this should work: - if(.not.lflagmagu)then - xycon=xycon*gamma*beta - endif - do i=1,nraysp - ex(i)=ex(i)*xycon - ey(i)=ey(i)*xycon - enddo -c - do j=1,nraysp - zblock(2,j)=zblock(2,j)+tau*ex(j) - zblock(4,j)=zblock(4,j)+tau*ey(j) - enddo - zlocate=zlocate+tau - return - endif -c - if(nz0.ne.0)then - if(iverbose.eq.2.and.idproc.eq.0)write(6,*)'3D spchrg' - do j=1,nraysp - do i=1,6 - c6(i,j)=zblock(i,j) - enddo - enddo -c -c -cryne bbyk=beta*sl !Jan 31, 2003 - bbyk=beta*clite/omegascl -c use ex as a temporary to hold beta of the nth particle: -cryne 3/4/2004 do j=1,nraysp -cryne 3/4/2004 ex(j)=(gamma-c6(6,j))**2-1.-c6(2,j)**2-c6(4,j)**2 -cryne 3/4/2004 ex(j)=sqrt(ex(j))/(gamma-c6(6,j)) -cryne 3/4/2004 enddo -c gamma (not gamma of the nth particle) takes us to the bunch frame: -c this converts phases to z-positions relative to the fiducial ptcl: -c Rob: need to check signs!!! -c Also, convert x and y to their values at the fixed time: -c c6(5,1:nraysp)=c6(5,1:nraysp)*ex(1:nraysp)*sl*gamma -c c6(1,1:nraysp)=(c6(1,1:nraysp)+c6(2,1:nraysp)*c6(5,1:nraysp))*sl -c c6(3,1:nraysp)=(c6(3,1:nraysp)+c6(4,1:nraysp)*c6(5,1:nraysp))*sl -c same formulae as Impact code: -c 09/04/01 commented out code to treat space charge in bending magnets. -c will fix later. rdr and ctm -c if(.not.straight)then -c rho=rhoprev -c theta0=arclen/rho+3.*asin(1.0d0) -c write(6,*)'****************** NT2PREV,RHO=',nt2prev,rho -c 0th order approximation for theta: -c tmp(1:nraysp)=-zblock(5,1:nraysp)*sl*beta/rho -c 1st order approximation for theta: -c tmp(:)=tmp(:)-sl/rho*sin(tmp(:))*c6(1,:) -c tmpr(:)=zblock(1,:)*cos(tmp(:))+ -c & zblock(2,:)*(rho/sl)/(beta*gamma)*sin(tmp(:))- -c & zblock(6,:)*(rho/sl)/(beta*gamma)/beta*(1.-cos(tmp(:))) -c c6(1,:)=(rho/sl+tmpr(:))*sl*sin(theta0+tmp(:)) -c c6(5,:)=(rho/sl+tmpr(:))*sl*cos(theta0+tmp(:)) -c c6(3,1:nraysp)=zblock(3,1:nraysp)*sl -c else - if(nadj0.ne.0)then - toopi=4.d0*asin(1.d0) - do j=1,nraysp - c5j=c6(5,j) - ac5j=abs(c5j) - if(c5j.gt.0.)c6(5,j)=mod(c5j,toopi) - if(c5j.lt.0.)c6(5,j)=toopi-mod(ac5j,toopi) - enddo -c?! endif -c place the value which is in(-pi,pi) back in the zblock array: - do j=1,nraysp - zblock(5,j)=c6(5,j)-0.5d0*toopi - enddo - endif -c convert phase to z (bbyk) and transform to the beam frame (gamma) -c also multiply by scale length (sl) to convert x and y to units of meters - do j=1,nraysp - c6(5,j)=c6(5,j)*gamma*bbyk - c6(1,j)=c6(1,j)*sl - c6(3,j)=c6(3,j)*sl - enddo -c endif -c -cryne Feb 3, 2003: -c this is the "bunch length" in the beam frame when it extends from 0 to 2pi: -c gblam=gamma*beta*4.*asin(1.0d0)*sl - gblam=gamma*beta*299792458.d0/bfreq -c if(idproc.eq.0)write(96,*)'gblam=',gblam -cryne 11/19/02 mask off lost particles - do j=1,nraysp - msk(j)=.true. - enddo - if(nraysp.lt.maxrayp)then - do j=nraysp+1,maxrayp - msk(j)=.false. - enddo - endif -c if(idproc.eq.0)then -c zmintmp=minval(c6(5,:),msk) -c zmaxtmp=maxval(c6(5,:),msk) -c write(6,*)'zmintmp,zmaxtmp=',zmintmp,zmaxtmp -c endif -c write(6,*)'calling setbound' - call setbound(c6,msk,nraysp,gblam,gamma,nx0,ny0,nz0,noresize, & - & nadj0) - gaminv=1.d0/gamma - if(idproc.eq.0)then - write(91,891)arclen,xmin,xmax,hx,nx0 - write(92,891)arclen,ymin,ymax,hy,ny0 -cryne 11/27/03 write(93,891)arclen,zmin*gaminv,zmax*gaminv,hz*gaminv,nz0 - write(93,892)arclen,zmin,zmax,hz,nz0 - 891 format(4(1pe14.7,1x),i5) - 892 format(1x,'(bunch frame) ',4(1pe14.7,1x),i5) - endif -c - nxsave=nx0 - nysave=ny0 - nzsave=nz0 - nx=nx0 - ny=ny0 - nz=nz0 - n1=2*nx - n2=2*ny - n3=2*nz - nadj=nadj0 - n3a=2*nz-nadj*nz - if(perv.ne.0)then - if (iverbose.ge.2) write(6,*) 'calling spch3d' -! rob: this will not work until the units are dealt with - call increment_timer('spch3d',0) - call spch3d(c6,ex,ey,ez,msk,nraysp,nrays, & - & nx,ny,nz,n1,n2,n3,n3a,nadj,rparams,cparams) - call increment_timer('spch3d',1) - if (iverbose.ge.2) write(6,*) 'returned from spch3d' - else -cryne Due to code near the top, the following will never be executed: - write(6,*)'code should not get here' -c ex=0. -c ez=0. -c ey=0. - endif - do j=1,nraysp - ex(j)=ex(j)*gamma - ey(j)=ey(j)*gamma - enddo -c if(idproc.eq.0)then -c write(96,*)'premult: ex(1),ey(1),ez(1)=',ex(1),ey(1),ez(1) -c endif -c - twopi=4.*asin(1.0d0) -c xycon=0.5*perv*gamma*beta*(bbyk*twopi) -cc xycon=0.5*perv*gamma*beta*(beta*sl*twopi) -ccc wrf=twopi*bfreq -cccc xycon=0.5*perv*gamma*beta*(twopi*beta*clite/wrf) -c (bfreq is in module beamdata) -c******** -c 3/21/2003 factor of 1/(4pi) now appears in G, so *4pi is needed here: - fourpi=8.d0*(asin(1.d0)) -c******** -c3/21/03xycon=0.5*perv*gamma*beta*(beta*clite/bfreq) - xycon=fourpi*0.5*perv*gamma*beta*(beta*clite/bfreq) -cryne 11/6/03triedthis,no good:xycon=fourpi*0.5*perv*gamma*beta*(beta*clite/freqscl) - tcon=beta*xycon*gamma**2 -c---------- -cryne Jan 28, 2003 - ratio3=omegascl*sl/299792458.d0 -c if(idproc.eq.0)write(6,*)'ratio3,ratio3inv=',ratio3,1.d0/ratio3 -c if(idproc.eq.0)write(96,*)'ratio3,r3inv=',ratio3,1.d0/ratio3 -ccc xycon=xycon*ratio3 - tcon=tcon/ratio3 -c---------- -c write(6,*),'xycon,tcon,perv=',xycon,tcon,perv -c if(idproc.eq.0)then -c write(96,*)'post:*xytcon=',xycon*ex(1),xycon*ey(1),tcon*ez(1) -c endif - gbi=1./(gamma*beta) -cryne 12/24/2002 - if(lflagmagu)then -c if(idproc.eq.0)write(6,*)'magnetic conversion for sc kick' -c if(idproc.eq.0)write(96,*)'magnetic conversion for sc kick' -c if(idproc.eq.0)write(6,*)'gamma*beta,gbi=',gamma*beta,gbi -c if(idproc.eq.0)write(96,*) & -c & 'post:*con*gbi=',xycon*ex(1)*gbi,xycon*ey(1)*gbi,tcon*ez(1)*gbi -! xycon=xycon*gamma*beta -! tcon= tcon*gamma*beta - xycon=xycon*gbi - tcon=tcon*gbi -! -! if(idproc.eq.0)write(6,*) 'TCON SET TO ZERO!!!!!!!!!!!!!!!!!!!!' -! if(idproc.eq.0)write(96,*)'TCON SET TO ZERO!!!!!!!!!!!!!!!!!!!!' -! tcon=tcon*0.d0 - endif -c -cccc zblock(2,1:nraysp)=zblock(2,1:nraysp)+tau*xycon*ex(1:nraysp)*gbi -cccc zblock(4,1:nraysp)=zblock(4,1:nraysp)+tau*xycon*ey(1:nraysp)*gbi -cccc zblock(6,1:nraysp)=zblock(6,1:nraysp)+tau* tcon*ez(1:nraysp)*gbi -c if(straight)then - do j=1,nraysp - zblock(2,j)=zblock(2,j)+tau*xycon*ex(j) - zblock(4,j)=zblock(4,j)+tau*xycon*ey(j) - zblock(6,j)=zblock(6,j)+tau* tcon*ez(j) - enddo -c else -c zblock(2,1:nraysp)=zblock(2,1:nraysp)+ -c & tau*xycon*sqrt(ex(1:nraysp)**2+ey(1:nraysp)**2) -c zblock(4,1:nraysp)=zblock(4,1:nraysp)-tau*xycon*ey(1:nraysp) -c zblock(6,1:nraysp)=zblock(6,1:nraysp)+tau* tcon*ez(1:nraysp) -c endif - zlocate=zlocate+tau - endif - if(iverbose.eq.2)write(6,*)'returning from space charge routine' - return - end -c - subroutine confoc(l,kx,ky,kz,h,mh) - use beamdata - use lieaparam, only : monoms - double precision kx,ky,kz,l - double precision h,mh,gb - dimension h(monoms),mh(6,6) - call ident(h,mh) - gb=gamma*beta - mh(1,1)=cos(kx*l) - if(kx.ne.0.d0)then - mh(1,2)=1./kx/sl*sin(kx*l) - else - mh(1,2)=l/sl - endif - mh(2,1)=-kx*sl*sin(kx*l) - mh(2,2)=cos(kx*l) - mh(3,3)=cos(ky*l) - if(ky.ne.0.d0)then - mh(3,4)=1./ky/sl*sin(ky*l) - else - mh(3,4)=l/sl - endif - mh(4,3)=-ky*sl*sin(ky*l) - mh(4,4)=cos(ky*l) - mh(5,5)=cos(kz*l) - if(kz.ne.0.d0)then - mh(5,6)=1./kz/sl/gb**2*sin(kz*l) - else - mh(5,6)=l/sl - endif - mh(6,5)=-kz*sl*gb**2*sin(kz*l) - mh(6,6)=cos(kz*l) - return - end -c - logical function defcon(line) -cryne 09/21/02 modified to deal with the issue that a symbol may be -c defined using ":=" or "=" -c The original version of this routine could not handle "=" -c Now it can, and as a result MaryLie/IMPACT can parse both cases. -c (Note, however, that MaryLie/IMPACT treats them identically; -c MAD parses both but treats them differently) - character (len=*) line - character*16 symb(50) - integer istrtsym(50) -c write(6,*)'INSIDE DEFCON; line =' -c write(6,*)line - defcon=.false. -c find the first nonblank character: - do n=1,LEN(line) - nfirst=n - if(line(n:n).ne.' ')goto 100 - enddo -c blank line: - return - 100 continue -c is the first character a "!" ? - if(line(nfirst:nfirst).eq.'!')return -c is the first character a '#' ? - if(line(nfirst:nfirst).eq.'#')return -c now inspect the contents of the line: -c check for ':' and '=' : - n1=index(line,':') - n2=index(line,'=') -c if((n1.eq.0).or.(n2.eq.0))return - if(n2.eq.0)return -c If both are present, there can be nothing in between: - if(n1.ne.0)then - if(n2.ne.n1+1)return - endif -c Set ncheck equal to the starting point of "=" or ":=" - if(n1.ne.0)then - ncheck=n1 - else - ncheck=n2 - endif -c -c there must be at least one symbol, and ":=" or "=" must occur after it: - call getsymb(line,LEN(line),symb,istrtsym,nsymb) - if(nsymb.eq.0)return - m1=istrtsym(1) -c m11=index(line,symb(1)) -c write(6,*)'(defcon) m1,m11=',m1,m11 - m2=len_trim(symb(1)) -c n0=location of last character of first string: - n0=m1+m2-1 -c if(n0.lt.n1)defcon=.true. - if(ncheck.eq.n0+1)defcon=.true. - if(ncheck.gt.n0+1)then - do mmm=n0+1,ncheck-1 - if(line(mmm:mmm).ne.' ')return - enddo - defcon=.true. - endif -c write(6,*)'**FOUND A DEFCON**' -c if(defcon)then -c if(ncheck.eq.n2)then -c write(6,*)'*****FOUND A DEFCON defined with an equal sign in' -c else -c write(6,*)'*****FOUND A DEFCON defined with a := in' -c endif -c write(6,*)line -c endif - return - end -c - logical function defline(line) - character (len=*) line - character*16 symb(50) - integer istrtsym(50) -c write(6,*)'INSIDE DEFLINE; line =' -c write(6,*)line - defline=.false. -c find the first nonblank character: - do n=1,LEN(line) - nfirst=n - if(line(n:n).ne.' ')goto 100 - enddo -c blank line: - return - 100 continue -c is the first character a '!' ? - if(line(nfirst:nfirst).eq.'!')return -c is the first character a '#' ? - if(line(nfirst:nfirst).eq.'#')return -c now check the contents of the line: -c '=' must be present - n1=index(line,'=') - if(n1.eq.0)return -c write(6,*)'n1 (location of equal sign) is',n1 -c and 'line' must be present - call getsymb(line,LEN(line),symb,istrtsym,nsymb) -c write(6,*)'(defline) nsymb=',nsymb -c if(nsymb.gt.0)then -c do ijk=1,nsymb -c write(6,*)'i,symb(i)= ',ijk,symb(ijk) -c enddo -c endif - if(nsymb.lt.2)return - if((trim(symb(2)).ne.'line').and.(trim(symb(2)).ne.'LINE'))return -c and there can only be blanks (or nothing) between 'line' and '=' - m1=istrtsym(2) -c m11=index(line,trim(symb(2))) -c write(6,*)'(defline)m1,m11=',m1,m11 -c write(6,*)'m1 (start of second symbol)=',m1 -c n0=location of last character of second string: - n0=m1+3 -c write(6,*)'n0 (end of second symbol)=',n0 - if(n1.eq.n0+1)then - defline=.true. -c write(6,*)'*****(1)FOUND A DEFLINE*****,line=' -c write(6,*)line - return - endif - do n=n0+1,n1-1 - if(line(n:n).ne.' ')return - enddo - defline=.true. -c write(6,*)'*****(2)FOUND A DEFLINE*****' -c write(6,*)line - return - end -c - logical function defelem(line) - include 'codes.inc' - character (len=*) line - character*16 symb(50) - integer istrtsym(50) - character*16 str - dimension nstrmax(9) - nstrmax(1)=75 - nstrmax(2)=10 - nstrmax(3)=9 - nstrmax(4)=24 - nstrmax(5)=9 - nstrmax(6)=9 - nstrmax(7)=50 - nstrmax(8)=39 - nstrmax(9)=37 -c write(6,*)'INSIDE DEFELEM; line =' -c write(6,*)line - defelem=.false. -c find the first nonblank character: - do n=1,LEN(line) - nfirst=n - if(line(n:n).ne.' ')goto 100 - enddo -c blank line: - return - 100 continue -c is the first character a '!' ? - if(line(nfirst:nfirst).eq.'!')return -c is the first character a '#' ? - if(line(nfirst:nfirst).eq.'#')return -c now check the contents of the line -c first obtain the symbols on the line: - call getsymb(line,LEN(line),symb,istrtsym,nsymb) -c it must contain at least TWO symbols - if(nsymb.lt.2)return -c write(6,*)'symb(1),symb(2) =',symb(1),'----',symb(2),'----' -c check for 'beam' or 'units' - if((trim(symb(1)).eq.'beam').or.(trim(symb(1)).eq.'units').or. & - & (trim(symb(1)).eq.'BEAM').or.(trim(symb(1)).eq.'UNITS'))then -c write(6,*)'FOUND A BEAM OR UNITS DEFELEM' - defelem=.true. - return - endif -c -c a ':' must occur between them - m0=index(line,':') -c write(6,*)'m0=',m0 - if(m0.eq.0)return - ms1=istrtsym(1) -c ms11=index(line,trim(symb(1))) -c write(6,*)'(defelem) ms1,ms11=',ms1,ms11 - ms2=istrtsym(2) -c ms22=index(line,trim(symb(2))) -c write(6,*)'(defelem) ms2,ms22=',ms2,ms22 -c write(6,*)'m0,ms1,ms2 =',m0,ms1,ms2 - if((m0.lt.ms1).or.(m0.gt.ms2))return -c '=' must not occur between them - k0=index(line,'=') -c write(6,*)'k0=',k0 - if(k0.ne.0)then - if((k0.gt.ms1).and.(k0.lt.ms2))return - endif -c the second symbol must match a type code name: - str=symb(2)(1:16) -c write(6,*)'str=',str - do i=1,9 - do j=1,nstrmax(i) - if(str(1:16).eq.ltc(i,j))then - defelem=.true. -c write(6,*)'***FOUND A DEFELEM***; i,j,ltc(i,j)=',i,j,ltc(i,j) - endif - enddo - enddo - return - end -c - subroutine rfcavmad(zlen,volt,phlagrad,nharm,h,mh) -c MAD RF CAVITY routine -c note that the length,zlen, is not used. -c -c trevi is the inverse revolution frequency. -c how/where is this info obtained??? - use lieaparam, only : monoms - use beamdata - include 'impli.inc' - double precision mh - double precision omega - dimension h(monoms),mh(6,6) -c-------- - write(6,*)'Inside routine for MAD RF CAVITY; do not know T_rev.' - write(6,*)'This needs to be fixed. Setting 1./T_rev = 0' - trevi=0.d0 -c-------- - omega=4.d0*asin(1.d0)*nharm*trevi - call ident(h,mh) - mh(6,5)=-omega*volt/brho*cos(phlagrad) - return - end -c - subroutine elsepmad(zlen,efield,h,mh) -c MAD ELECTROSTATIC SEPARATOR routine - use lieaparam, only : monoms - use beamdata - include 'impli.inc' - double precision mh - double precision omega - double precision xk - dimension h(monoms),mh(6,6) - xk=efield/brho - co=cosh(xk*zlen) - si=sinh(xk*zlen) - write(6,*)'in elsepmad w/ zlen,efield,brho=',zlen,efield - write(6,*)'and brho,beta=',brho,beta - write(6,*)'and xk,co,si=',xk,co,si - call ident(h,mh) - mh(1,2)=zlen - mh(3,3)=co-xk*zlen*si/beta**2 - mh(3,4)=si/xk - mh(3,6)=(co-1.d0)/xk - zlen*si/beta**2 - mh(4,3)=xk*(si-xk*zlen*co/beta**2) - mh(4,4)=co - mh(4,6)=si-xk*zlen*co/beta**2 - mh(5,3)=-(si-xk*zlen*co/beta**2) - mh(5,4)=-(co-1.d0)/xk - mh(5,6)=-si/xk + zlen*co/beta**2 - return - end -c - subroutine hmonitor - include 'impli.inc' -c write(6,*)'MAD hmonitor not implemented' - return - end -c - subroutine vmonitor - include 'impli.inc' -c write(6,*)'MAD vmonitor not implemented' - return - end -c - subroutine monitor - include 'impli.inc' -c write(6,*)'MAD monitor not implemented' - return - end -c - subroutine instrument - include 'impli.inc' -c write(6,*)'MAD instrument not implemented' - return - end -c -c*********************************************************************** -c - subroutine sliceml -c the routine augments the nrp ("number of required parameters") values -c of thick elements associated with original MaryLie type codes. -c By putting this in the menu first, users with original MaryLie -c input files can add a parameter to the parameter lists of the -c thick elements in order to do autoslicing. - use parallel - include 'codes.inc' - nrp(1,1)=nrp(1,1)+1 !drft - nrp(1,2)=nrp(1,2)+1 !nbnd - nrp(1,3)=nrp(1,3)+1 !pbnd - nrp(1,4)=nrp(1,4)+1 !gbnd - nrp(1,6)=nrp(1,6)+1 !gbdy - nrp(1,8)=nrp(1,8)+1 !cfbd - nrp(1,9)=nrp(1,9)+1 !quad - nrp(1,10)=nrp(1,10)+1 !sext - nrp(1,11)=nrp(1,11)+1 !octm - nrp(1,12)=nrp(1,12)+1 !octe - nrp(1,18)=nrp(1,18)+1 !cfqd - nrp(1,20)=nrp(1,20)+1 !sol - nrp(1,24)=nrp(1,24)+1 !recm - nrpold(1,1)=nrpold(1,1)+1 !drft - nrpold(1,2)=nrpold(1,2)+1 !nbnd - nrpold(1,3)=nrpold(1,3)+1 !pbnd - nrpold(1,4)=nrpold(1,4)+1 !gbnd - nrpold(1,6)=nrpold(1,6)+1 !gbdy - nrpold(1,8)=nrpold(1,8)+1 !cfbd - nrpold(1,9)=nrpold(1,9)+1 !quad - nrpold(1,10)=nrpold(1,10)+1 !sext - nrpold(1,11)=nrpold(1,11)+1 !octm - nrpold(1,12)=nrpold(1,12)+1 !octe - nrpold(1,18)=nrpold(1,18)+1 !cfqd - nrpold(1,20)=nrpold(1,20)+1 !sol - nrpold(1,24)=nrpold(1,24)+1 !recm - if(idproc.eq.0)then -! write(6,*)'Enabling slicing of original MaryLie thick elements.' -! write(6,*)'For each thick element, the MaryLie parser will' -! write(6,*)'expect 1 more parameter than is shown in the MaryLie' -! write(6,*)'manual. The extra (last) parameter = the # of slices.' - write(12,*)'Enabling slicing of original MaryLie thick elements.' - write(12,*)'For each thick element, the MaryLie parser will' - write(12,*)'expect 1 more parameter than is shown in the MaryLie' - write(12,*)'manual. The extra (last) parameter = the # of slices.' - endif - return - end -c -!*********************************************************************** -! subroutine myflush(nfile) -! integer nfile -! double precision x -! close(nfile) -! open(nfile,position='append') -c open(nfile) -c 100 read(nfile,*,end=123,err=999)x -c goto 100 -c 123 continue -c return -c 999 continue -c if(idproc.eq.0)write(6,*)'trouble in routine myflush' -c call myexit -! return -! end -!*********************************************************************** - subroutine num2string(num,a,ndigits) -c converts an integer "num" with at most "ndigits" digits -c into a character string "a" - integer num,ndigits - character a*(*) - integer n,m,k - m=num - do n=1,ndigits - k=m/10**(ndigits-n) - if(k.eq.0)a(n:n)='0' - if(k.eq.1)a(n:n)='1' - if(k.eq.2)a(n:n)='2' - if(k.eq.3)a(n:n)='3' - if(k.eq.4)a(n:n)='4' - if(k.eq.5)a(n:n)='5' - if(k.eq.6)a(n:n)='6' - if(k.eq.7)a(n:n)='7' - if(k.eq.8)a(n:n)='8' - if(k.eq.9)a(n:n)='9' - m=m-k*10**(ndigits-n) - enddo - return - end -c*********************************************************************** - subroutine ibcast(ival) - use parallel - integer ival - if(idproc.eq.0)then - do l=1,nvp-1 - call MPI_SEND(ival,1,mntgr,l,99,lworld,ierr) -! write(6,*)'processor ',idproc,' sending ival=',ival,' to PE',l - enddo - else - call MPI_RECV(ival,1,mntgr,0,99,lworld,mpistat,ierr) -c? call MPI_GET_COUNT(mpistat,mreal,nraysp,ierr) -! write(6,*)'processor ',idproc,' received ival=',ival - endif - return - end -c*********************************************************************** - subroutine rbcast(rval) - use parallel - real*8 rval - if(idproc.eq.0)then - do l=1,nvp-1 - call MPI_SEND(rval,1,mreal,l,99,lworld,ierr) -! write(6,*)'processor ',idproc,' sending rval=',rval,' to PE',l - enddo - else - call MPI_RECV(rval,1,mreal,0,99,lworld,mpistat,ierr) -c? call MPI_GET_COUNT(mpistat,mreal,nraysp,ierr) -! write(6,*)'processor ',idproc,' received rval=',rval - endif - return - end -*********************************************************************** -c - subroutine myexit -! use parallel - use acceldata - use spchdata - use ml_timer - use rays - common/xtrajunk/jticks1,iprinttimers -c -c Written by Rob Ryne ca 1984 -c -c Exit the program (may be replaced by STOP, if exit is not available). -c This is the only place in MaryLie where exit is called. -c - call system_clock(count=jticks2) - elapsed=(jticks2-jticks1)/hertz - write(6,*)'ELAPSED TIME=',elapsed - if(iprinttimers.eq.1)call end_ml_timers -c write(6,*)'deallocating...' - call del_acceldata - if(allocated(zblock))call del_particledata - if(allocated(grnxtr))call del_spchdata - call end_parallel - stop - end -c -c - subroutine getordtyp(cstring,ntaysym,norder) - use parallel - include 'impli.inc' - character*16 cstring - ntay=index(cstring,'tay') - nsym=index(cstring,'sym') - if(ntay.ne.0)ntaysym=1 - if(nsym.ne.0)ntaysym=2 -c inefficient, but works. fix later. rdr dec 9 2002 & march 27 2004 - n0=index(cstring,'0') - if(n0.ne.0)then - norder=0 - return - endif - n1=index(cstring,'1') - if(n1.ne.0)then - norder=1 - return - endif - n2=index(cstring,'2') - if(n2.ne.0)then - norder=2 - return - endif - n3=index(cstring,'3') - if(n3.ne.0)then - norder=3 - return - endif - n4=index(cstring,'4') - if(n4.ne.0)then - norder=4 - return - endif - n5=index(cstring,'5') - if(n5.ne.0)then - norder=5 - return - endif - n6=index(cstring,'6') - if(n6.ne.0)then - norder=6 - return - endif - n7=index(cstring,'7') - if(n7.ne.0)then - norder=7 - return - endif - n8=index(cstring,'8') - if(n8.ne.0)then - norder=8 - return - endif - n9=index(cstring,'9') - if(n9.ne.0)then - norder=9 - return - endif - if(idproc.eq.0)then - write(6,*)'(GETORDTYP)Unable to determine tracking type & order' - endif - call myexit - end -c diff --git a/OpticsJan2020/MLI_light_optics/Src/afro_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/afro_mod.f90 deleted file mode 100755 index 5f8dc44..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/afro_mod.f90 +++ /dev/null @@ -1,177 +0,0 @@ -module beamdata - implicit none -! beam parameters and scaling parameters - real*8 :: brho,gamma,gamm1,beta,achg,pmass,bfreq,bcurr,c - real*8 :: sl,p0sc,ts,omegascl,freqscl - logical :: lflagmagu=.true.,lflagdynu=.false. - save -end module beamdata - -module acceldata - implicit none - -! lmnlbl(i) = name of ith element (numbered as they occur in #menu) -! p(k,i) = kth parameter of ith element -! nt1(i) = group index of the elements type (see /monics/) -! nt2(i) = type index ..... -! mppr(i) = menu parameters (real data) for ith element -! note: for compatibility w/ existing MaryLie, I call this "mpp" not "mppr" -! mppc(i) = menu parameters (char*16 data) for ith element - character(len=16), dimension(:), allocatable :: lmnlbl,cmenu -! if there are, on average, -! 6 real parameters/element and 1 character parameter/element, -! then this is enough memory to store the parameters of mnumax elements - real*8, dimension(:), allocatable :: pmenu -! atarray added by RDR 9/16/2004: - real*8, dimension(:), allocatable :: atarray -! - integer, dimension(:), allocatable :: mpp,mppc,nt1,nt2 - -! mnumax = maximum number of elements in #menu (default=5000) -! itmno = maximum number of items (default=5000) -! itmnln = maximum number of elements per item (default=100) -! mlabor = maximum number of tasks in #labor (default=1000) -! maxcmt = maximum number of comment lines (default=250) -! nconmax = maximum number of defined constants (default=1000) - integer :: mnumax=5000,itmno=5000,itmln=100 - integer :: mlabor=1000,maxcmt=250,nconmax=1000 -! - integer :: inmenu - -! na = actual number of elements -! nb = actual number of items -! noble = actual number of tasks -! npcom = actual number of comment lines -! mpprpoi = menu parameter pointer to "real" (i.e. numeric) data -! mppcpoi = menu parameter pointer to character*16 data - integer :: na=0,nb=0,noble=0,npcom=0,mpprpoi=0,mppcpoi=0 - - -! lines,lumps and loops -! ilbl(i) = name of ith item -! icon(k,i) = name of kth element/item in ith item -! irep(k,i) = repetition factor of icon(k,i) -! ityp(k,i) = type code = 2,3,4 if item=line,lump,loop resp. -! ilen(i) = number of elements/items in ith item (=max k for ith item) -! lmade(i) = flag, telling whether map of lump is in buffer and where. -! preset to zero - character(len=16), dimension(:), allocatable :: ilbl - character(len=16), dimension(:,:), allocatable :: icon - integer, dimension(:), allocatable :: ityp,ilen,lmade - integer, dimension(:,:), allocatable :: irep - -! latt(i) = the name of the ith task -! num(i) = the repetition factor of this task - character(len=16), dimension(:), allocatable :: latt - integer, dimension(:), allocatable :: num - - character(len=80), dimension(:), allocatable :: mline - -!ryne 7/7/2002 -!ryne this common block is used to store strings that have constant -!ryne values assigned to them. -!ryne nconst is equal to the number that have been assigned -!ryne This info should really be included in elments.inc, but I am -!ryne keeping it separate to avoid changes to the existing MaryLie - character(len=16), dimension(:), allocatable :: constr - real*8, dimension(:), allocatable :: conval - integer :: nconst -! -!11/29/02 autoslicing info: -! defaults: - character*16 :: slicetype='slices',sliceprecedence='local' - real*8 :: slicevalue=1.0 - - save - -contains - subroutine new_acceldata - allocate(lmnlbl(mnumax)) - allocate(pmenu(6*mnumax),cmenu(1*mnumax), & - & mpp(mnumax),mppc(mnumax),nt1(mnumax),nt2(mnumax)) - allocate(atarray(1*mnumax)) -! write (6,*) 'pmenu size=',size(pmenu) -! write (6,*) 'pmenu start,end=',loc(pmenu(1)),loc(pmenu(6*mnumax)) - - allocate(ilbl(itmno),icon(itmln,itmno)) - allocate(irep(itmln,itmno),ityp(itmno),ilen(itmno),lmade(itmno)) - allocate(latt(mlabor),num(mlabor)) - allocate(mline(maxcmt)) - allocate(constr(nconmax),conval(nconmax)) - mpp(:)=0 - mppc(:)=0 - cmenu(:)=' ' - lmade(:)=0 - mline(:)=' ' - latt(:)=' ' - num(:)=1 - atarray(:)=-99999.d0 - end subroutine new_acceldata - - subroutine del_acceldata - deallocate(lmnlbl) - deallocate(pmenu,cmenu,mpp,mppc,nt1,nt2) - deallocate(atarray) - deallocate(ilbl,icon) - deallocate(irep,ityp,ilen,lmade) - deallocate(latt,num) - deallocate(mline) - deallocate(constr,conval) - end subroutine del_acceldata - - -end module acceldata - - -module rays - use parallel - implicit none -! eventually make leading dimension "idimp" instead of 6 -! zblock(k,i) kth coordinate of ray index i -! tblock(k,i) temporary array; might move out of this module later. -! zi (k) initial coordinates -! zf (k) final coordinates -! nrays number of rays -! istat(i) iturn, in which ray index i was lost, 0 otherwise -! ihist(1,j) iturn, in which the jth lost particle was lost -! ihist(2,j) index (i) of jth lost particle -! iturn turn index (not used in cqlate) -! nlost number of rays lost so far - real*8, dimension(:,:), allocatable :: zblock,tblock - real*8, dimension(:,:), allocatable :: pbh6t,uvect,tvect - integer, dimension(:), allocatable :: istat - integer, dimension(:,:), allocatable :: ihist - real*8, dimension(6) :: zi,zf -! maxray is the initial size of the global particle array (default=30000) - integer :: maxray=30000,nrays=0,nlost=0,iturn=0 -! values per processor: - integer, parameter :: nchunk=100 - integer :: maxrayp,nraysp=0 -save - -contains - - subroutine new_particledata -!cryne May 19, 2006 maxrayp=(maxray-1)/nvp + 1 - maxrayp=maxray/nvp + 1 -!cryne May 19, 2006 commented out the following until particle mgr is installed: -! maxrayp=2*maxrayp -! - allocate(zblock(6,maxrayp),tblock(6,maxrayp), & - & pbh6t(6,923),uvect(923,nchunk),tvect(923,nchunk)) -! if(nvp.gt.1)allocate(tblock(6,maxrayp)) - allocate(istat(maxrayp),ihist(2,maxrayp)) - end subroutine new_particledata - - subroutine del_particledata -! print *, 'zblock=',allocated(zblock),size(zblock) -! print *, 'istat=',allocated(istat),size(istat) -! print *, 'ihist=',allocated(ihist),size(ihist) - integer status - deallocate(zblock,tblock,pbh6t,uvect,tvect,stat=status) - if(status.ne.0) print *,'del_particledata: deallocate1 returned ',status -! if(allocated(tblock))deallocate(tblock) - deallocate(istat,ihist,stat=status) - if(status.ne.0) print *,'del_particledata: deallocate2 returned ',status - end subroutine del_particledata -end module rays diff --git a/OpticsJan2020/MLI_light_optics/Src/anal.f b/OpticsJan2020/MLI_light_optics/Src/anal.f deleted file mode 100644 index 4387fa2..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/anal.f +++ /dev/null @@ -1,4813 +0,0 @@ -*********************************************************************** -* header ANALYSIS (advanced commands) * -* Routines for advanced commands and advanced analysis * -*********************************************************************** -c - subroutine amap(p,fa,fm) -c subroutine for applying a map to a function or a set of moments -c Written by Alex Dragt, Fall 1986 - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'usrdat.inc' - character*3 kynd -c - dimension p(6) - dimension fa(monoms),fm(6,6) -c - dimension ga(monoms),gm(6,6) - dimension ha(monoms),hm(6,6) - dimension t1a(monoms) - dimension t2a(monoms) -c -c set up control indices - mode=nint(p(1)) - isend=nint(p(2)) - ifile=nint(p(3)) - nopt=nint(p(4)) - nskip=nint(p(5)) - nmpo=nint(p(6)) -c -c procedure for reading in function or moments when mode = 1, 2, or 3: - if (mode.eq.1 .or. mode.eq.2 .or. mode.eq.3) then -c test for file read or internal map fetch - if(ifile.lt.0) then - nmap=-ifile - kynd='gtm' - call strget(kynd,nmap,ga,gm) - else - mpit=mpi - mpi=ifile - call mapin(nopt,nskip,ga,gm) - mpi=mpit - endif - endif -c -c procedure for reading in moments when mode = 4 or 5: - if (mode.eq.4 .or. mode.eq.5) then -c Filippo provide this procedure - continue - endif -c -c procedure for letting map act on a function: - if(mode.eq.1) then -c let map characterized by fa,fm act on ga -c the result is the array ha -c this amounts to computing ha = (Dtranspose)*ga -c where D = D(fa,fm) - call fxform(fa,fm,ga,ha) - endif -c -c procedure for letting map act on moments: -c letting the map act on moments amounts to computing ha = D*ga -c -c procedure for mode = 2 or 3: - if (mode.eq.2 .or. mode.eq.3) then -c -c clear arrays - do 10 i=1,monoms - t1a(i)=0.d0 - 10 ha(i)=0.d0 -c -c when mode = 3, compute all transformed moments through 4'th moments - imax=209 -c when mode = 2, compute transformed moments only through 2'nd moments - if (mode.eq.2) imax=27 -c -c perform calculation - do 20 i=7,imax - t1a(i)=1.d0 - call fxform(fa,fm,t1a,t2a) - t1a(i)=0.d0 - do 30 j=1,209 - 30 ha(i)=ha(i)+t2a(j)*ga(j) - 20 continue - endif -c -c procedure for mode = 4 or 5: - if (mode.eq.4 .or. mode.eq.5) then -c when mode = 5, compute all transformed moments through 4'th moments - imax=209 -c when mode = 4, compute transformed moments only through 2'nd moments - if (mode.eq.4) imax=27 -c Filippo put in code here for dealing with 6'th order moments: -c clear arrays -c perform calculation - continue - endif -c -c if map has been applied to moments, compute squares of rms emittances: - if (mode.ne.1) then - xemit2=ha(7)*ha(13)-ha(8)*ha(8) - yemit2=ha(18)*ha(22)-ha(19)*ha(19) - if (isend.eq.1.or.isend.eq.3) then - write (jof,*) 'xemit2=',xemit2 - write (jof,*) 'yemit2=',yemit2 - endif - if (isend.eq.2.or.isend.eq.3) then - write (jodf,*) 'xemit2=',xemit2 - write (jodf,*) 'yemit2=',yemit2 - endif - endif -c -c write out result ha if nmpo > 0 - mpot=mpo - mpo=nmpo - if (nmpo.gt.0) call mapout(0,ha,hm) - mpo=mpot -c -c write results into the array ucalc -c first clear the array - do 40 i=1,250 - 40 ucalc(i)=0.d0 -c complete the task - nuvar=211 - do 50 i=1,209 - 50 ucalc(i)=ha(i) - if (mode.ne.1) then - ucalc(210)=xemit2 - ucalc(211)=yemit2 - endif -c - return - end -c -*********************************************************************** -c - subroutine asni(p) - use rays - use lieaparam, only : monoms -c This subroutine applies powers of script N inverse to phase space data. -c It does this using analytic formulas. -c - include 'impli.inc' -c - character*3 kynd -c calling array - dimension p(6) -c -c local array - dimension fa(monoms), fr(monoms) - dimension fm(6,6) -c -c set up control parameters - iopt=nint(p(1)) - nmap=nint(p(2)) - nfcf=nint(p(3)) - istart=nint(p(4)) - igroup=nint(p(5)) - nwrite=nint(p(6)) -c -c begin calculation -c -c get script N from storage - kynd='gtm' - call strget(kynd,nmap,fa,fm) -c -c procedure for a static map -c - if( iopt.eq.1) then -c compute linear phase advances and linear time of flight - cwx=fm(1,1) - swx=fm(1,2) - wx=atan2(swx,cwx) - cwy=fm(3,3) - swy=fm(3,4) - wy=atan2(swy,cwy) - wt=fm(5,6) -c -c transform nonlinear part of map to the static resonance basis - call ctosr(fa,fr) -c -c begin outer loop over the sets of particles - nset=nint(float(nrays)/float(igroup)) - do 10 i=1,nset -c begin inner loop over the particles within a set - do 20 j=1,igroup -c -c get phase-space coordinates - iray=(i-1)*igroup+j - do 30 k=1,6 - 30 zi(k)=zblock(k,iray) -c -c compute emittances - ex2=zi(1)**2 + zi(2)**2 - ey2=zi(3)**2 + zi(4)**2 - pt=zi(6) -c -c compute phase advances and time of flight terms -c incorporate - sign needed for inverse in the definition of an - an=-float(istart+(i-1)*nwrite) -c compute x and y phase advances - phix = wx - 2.*pt*fr(28) - 2.*pt*pt*fr(84) - & - 4.*ex2*fr(87) - 2.*ey2*fr(89) - phiy = wy - 2.*pt*fr(29) - 2.*pt*pt*fr(85) - & - 4.*ey2*fr(88) - 2.*ex2*fr(89) -c compute time-like drift terms - drt = pt*wt - ex2*fr(28) - ey2*fr(29) - & - 2.*pt*ex2*fr(84) -2.*pt*ey2*fr(85) - & - 3.*pt*pt*fr(30) - 4.*pt*pt*pt*fr(86) -c -c set up matrix quantities - cx=cos(an*phix) - sx=sin(an*phix) - cy=cos(an*phiy) - sy=sin(an*phiy) - tof=an*drt -c -c apply matrix to transverse coordinates - zf(1)= cx*zi(1)+sx*zi(2) - zf(2)=-sx*zi(1)+cx*zi(2) - zf(3)= cy*zi(3)+sy*zi(4) - zf(4)=-sy*zi(3)+cy*zi(4) -c transform time deviation and energy deviation - zf(5)= zi(5)+tof - zf(6)= zi(6) -c -c write out results - write (nfcf,100) zf(1),zf(2),zf(3),zf(4),zf(5),zf(6) - 100 format(6(1x,1pe12.5)) -c - 20 continue - 10 continue -c - endif -c -c procedure for a dynamic map -c - if( iopt.eq.2) then -c compute linear phase advances - cwx=fm(1,1) - swx=fm(1,2) - wx=atan2(swx,cwx) - cwy=fm(3,3) - swy=fm(3,4) - wy=atan2(swy,cwy) - cwt=fm(5,5) - swt=fm(5,6) - wt=atan2(swt,cwt) -c -c transform nonlinear part of map to the dynamic resonance basis - call ctodr(fa,fr) -c -c begin outer loop over the sets of particles - nset=nint(float(nrays)/float(igroup)) - do 40 i=1,nset -c begin inner loop over the particles within a set - do 50 j=1,igroup -c -c get phase-space coordinates - iray=(i-1)*igroup+j - do 60 k=1,6 - 60 zi(k)=zblock(k,iray) -c -c compute emittances - ex2=zi(1)**2 + zi(2)**2 - ey2=zi(3)**2 + zi(4)**2 - et2=zi(5)**2 + zi(6)**2 -c -c compute phase advances -c incorporate - sign needed for inverse in the definition of an - an=-float(istart+(i-1)*nwrite) -c this part of code not yet complete - phix=wx - phiy=wy - phit=wt -c -c set up matrix quantities - cx=cos(an*phix) - sx=sin(an*phix) - cy=cos(an*phiy) - sy=sin(an*phiy) - ct=cos(an*phit) - st=sin(an*phit) -c -c apply matrix to coordinates - zf(1)= cx*zi(1)+sx*zi(2) - zf(2)=-sx*zi(1)+cx*zi(2) - zf(3)= cy*zi(3)+sy*zi(4) - zf(4)=-sy*zi(3)+cy*zi(4) - zf(5)= ct*zi(5)+st*zi(6) - zf(6)=-st*zi(5)+ct*zi(6) -c -c write out results - write (nfcf,100) zf(1),zf(2),zf(3),zf(4),zf(5),zf(6) -c - 50 continue - 40 continue -c - endif -c - return - end -c -*********************************************************************** -c - subroutine betmap(ana,anm,ba,bm) -c This is a subroutine for finding the betatron portion of a map. -c The map ana, anm is assumed to be a map about the fixed point. -c Written by Alex Dragt, 4 August 1986 - use lieaparam, only : monoms - include 'impli.inc' -c - dimension ana(monoms),anm(6,6) - dimension ba(monoms),bm(6,6) -c - dimension tempa(monoms),tempm(6,6) - dimension ca(monoms),cm(6,6) -c -c Extraction of betatron term b. -c First pass: terms linear in pt. - call clear(tempa,tempm) - call matmat(anm,tempm) - tempa(33)=ana(33) - tempa(38)=ana(38) - tempa(42)=ana(42) - tempa(45)=ana(45) - tempa(53)=ana(53) - tempa(57)=ana(57) - tempa(60)=ana(60) - tempa(67)=ana(67) - tempa(70)=ana(70) - tempa(76)=ana(76) - call mapmap(tempa,tempm,ba,bm) -c Second pass: terms quadratic in pt. - call inv(ba,bm) - call concat(ba,bm,ana,anm,ca,cm) - tempa(104)=ca(104) - tempa(119)=ca(119) - tempa(129)=ca(129) - tempa(135)=ca(135) - tempa(154)=ca(154) - tempa(164)=ca(164) - tempa(170)=ca(170) - tempa(184)=ca(184) - tempa(190)=ca(190) - tempa(200)=ca(200) - call mapmap(tempa,tempm,ba,bm) - return - end -c -*********************************************************************** -c - subroutine cex(p,ga,gm,myorder) -c this routine computes t=exp(:f) -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' -c - include 'extalk.inc' - include 'hmflag.inc' - include 'buffer.inc' - character*3 kynd -c - dimension p(6),ga(monoms),gm(6,6) -c - dimension ta(monoms) - dimension tm(6,6),em(6,6),fm(6,6) -cryne 3AM 7/11/2002 dimension y(224) - dimension y(monoms+15) - -c-------------------------------------------- -c write(6,*)'inside routine cex' -c write(6,*)'input 6-vector p:' -c do i=1,6 -c write(6,*)p(i) -c enddo -c write(6,*)'input matrix:' -c do i=1,6 -c do j=1,6 -c if(gm(i,j).ne.0.d0)write(69,*)i,j,gm(i,j) -c enddo -c enddo -c -c write(6,*)'input polynomial:' -c do i=1,209 -c if(ga(i).ne.0.d0)write(69,*)i,ga(i) -c enddo -c if(p(1).ne.12345)stop -c-------------------------------------------- -c -c set up power and control indices - power=p(1) - nmapf=nint(p(2)) - nmapg=nint(p(3)) -c -c get map and clear arrays - if (nmapf.eq.0) call mapmap(ga,gm,fa,fm) - if (nmapf.ge.1 .and. nmapf.le.5) then - kynd='gtm' - call strget(kynd,nmapf,fa,fm) - endif - call clear(ta,tm) -c -c perform calculation -c -c set up exponent - call csmul(power,fa,fa) -c -c compute a scaling factor to bring exponent within range of a -c taylor expansion or GENMAP - call matify(em,fa) - call mnorm(em,res) - kmax=1 - scale=.5d0 - 10 continue - test=res*scale - if (test.lt..1d0) goto 20 - kmax=kmax+1 - scale=scale/2.d0 - go to 10 - 20 continue -c -c select procedure - itest=1 - do 30 i=28,monoms - if (fa(i).ne.0.d0) itest=2 - if (itest.ne.1) go to 40 - 30 continue - 40 continue - if (itest.eq.1) go to 50 - if (itest.eq.2) go to 80 -c -c procedure using taylor series - 50 continue - write (12,*) 'exp(:f:) computed using taylor series' -c rescale em - call smmult(scale,em,em) -c compute taylor series result fm=exp(scale*em) - call exptay(em,fm) -c raise the result to the 2**kmax (= 1/scale) power - do 60 i=1,kmax - call mmult(fm,fm,tm) - call matmat(tm,fm) - 60 continue - goto 200 -c -c procedure using genmap - 80 continue - write(12,*) 'exp(:f:) computed using GENMAP' -c rescale fa - call csmul(scale,fa,fa) -c setup and initialize for GENMAP routines - iflag=1 - t=0.d0 - ns=50.d0 - h=.02d0 -cryne 3AM 7/11/2002 ne=224 -cryne 1 August 2004 ne=monoms+15 -cryne 1 August 2004 Initialize: -cryne do 90 i=1,ne - do 90 i=1,monoms+15 - 90 y(i)=0.d0 - do 100 i=1,6 - j=7*i - 100 y(j)=1.d0 -c call GENMAP routines -cryne there is a better way to do this; fix later. -c y(7-42) = matrix -c y(43-98) = f3 -c y(99-224) = f4 -c y(225-476) = f5 -c y(477-938) = f6 - if(myorder.eq.1)ne=42 !36+6 - if(myorder.eq.2)ne=98 !83+15 - if(myorder.eq.3)ne=224 !209+15 - if(myorder.eq.4)ne=476 !461+15 - if(myorder.eq.5)ne=938 !923+15 -c - call adam11(h,ns,'start',t,y,ne) - call putmap(y,fa,fm) -c -c raise the result to the 2**kmax (= 1/scale) power - do 110 i=1,kmax - call concat(fa,fm,fa,fm,ta,tm) - call mapmap(ta,tm,fa,fm) - 110 continue - go to 200 -c -c decide where to put results -c - 200 continue - if (nmapg.ge.1 .and. nmapg.le.5) then - kynd='stm' - call strget(kynd,nmapg,ta,tm) - endif -c - if (nmapg.eq.0) call mapmap(ta,tm,ga,gm) -c - if (nmapg.eq.-1) call mapmap(ta,tm,buf1a,buf1m) - if (nmapg.eq.-2) call mapmap(ta,tm,buf2a,buf2m) - if (nmapg.eq.-3) call mapmap(ta,tm,buf3a,buf3m) - if (nmapg.eq.-4) call mapmap(ta,tm,buf4a,buf4m) - if (nmapg.eq.-5) call mapmap(ta,tm,buf5a,buf5m) -c - return - end -c -******************************************************************************* -c - subroutine chrexp(iopt,delta,ta,tm,am1,am2,am3) -c -c This subroutine computes the chromatic expansion of the map ta,tm -c for the case in which the f3 and f4 parts of ta contain only terms -c linear and quadratic in pt, respectively. -c Written by Alex Dragt, Spring 1987 -c - use lieaparam, only : monoms - include 'impli.inc' -c - dimension ta(monoms),tm(6,6) - dimension am1(6,6),am2(6,6),am3(6,6) -c - dimension t1a(monoms),t1m(6,6),t2m(6,6) -c-------- -c procedure when IOPT = 1 (delta=pt). - if (iopt.eq.1) then -c Calculation of matrix associated with pt*f2 terms in ta. -c Set up f2a in t1a. - call clear(t1a,am1) - t1a(7)=ta(33) - t1a(8)=ta(38) - t1a(9)=ta(42) - t1a(10)=ta(45) - t1a(13)=ta(53) - t1a(14)=ta(57) - t1a(15)=ta(60) - t1a(18)=ta(67) - t1a(19)=ta(70) - t1a(22)=ta(76) -c Compute matrix t1m corresponding to :f2a:. - call matify(t1m,t1a) -c write(6,*) 'result from chrexp' -c call pcmap(1,0,0,0,t1a,t1m) -c Compute am1=t1m*tm - call mmult(t1m,tm,am1) -c Calculation of matrix associated with (pt**2)*f2 terms in ta. -c Set up f2a in t1a. - call clear(t1a,am2) - t1a(7)=ta(104) - t1a(8)=ta(119) - t1a(9)=ta(129) - t1a(10)=ta(135) - t1a(13)=ta(154) - t1a(14)=ta(164) - t1a(15)=ta(170) - t1a(18)=ta(184) - t1a(19)=ta(190) - t1a(22)=ta(200) -c Compute matrix t2m corresponding to :f2a:. - call matify(t2m,t1a) -c write(6,*) 'result from chrexp' -c call pcmap(1,0,0,0,t1a,t2m) -c Compute am3=t2m+t1m*t1m/2. - call mmult(t1m,t1m,am3) - call smmult(.5d0,am3,am3) - call madd(t2m,am3,am3) -c Compute am2=(t2m+t1m*t1m/2.)*tm - call mmult(am3,tm,am2) -c Compute am3=tm+delta*am1+delta2*am2 for specific value of delta. - delta2=delta*delta - call matmat(tm,am3) - call smmult(delta,am1,t1m) - call madd(am3,t1m,am3) - call smmult(delta2,am2,t1m) - call madd(am3,t1m,am3) - endif -c -c procedure when IOPT = 2 (delta=dp/p0). - if (iopt.eq.2) then - continue - endif -c - return - end -c - subroutine cod(p,th,tmh) -c This is a subroutine for computing closed orbit data. -c Written by Alex Dragt, 6 November 1985 - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'buffer.inc' -c - dimension p(6) - dimension th(monoms),tmh(6,6) -c - dimension ana(monoms),anm(6,6) - dimension ta(monoms),tm(6,6) - dimension tempa(monoms),tempm(6,6) - dimension ba(monoms),bm(6,6) - dimension ca(monoms),cm(6,6) - dimension am1(6,6),am2(6,6),am3(6,6) -c -c Set up control indices: - iopt=nint(p(1)) - delta=p(2) - idata=nint(p(3)) - ipmaps=nint(p(4)) - isend=nint(p(5)) - iwmaps=nint(p(6)) -c -c Write headings - if (isend.eq.1 .or. isend.eq.3) write(jof,90) - if (isend.eq.2 .or. isend.eq.3) write(jodf,90) - 90 format(/,1x,'closed orbit analysis for static map') -c -c Computation of fixed point and map about it. - call fxpt(th,tmh,ana,anm,ta,tm) -c -c Procedure for output of closed orbit location. - if(idata.eq.1 .or. idata.eq.3) then -c Procedure when IOPT = 1: - if (iopt.eq.1) then -c Compute location of closed orbit for given delta value - delta2=delta*delta - delta3=delta*delta2 - xc=delta*tm(1,6)-delta2*ta(63)-delta3*ta(174) - pxc=delta*tm(2,6)+delta2*ta(48)+delta3*ta(139) - yc=delta*tm(3,6)-delta2*ta(79)-delta3*ta(204) - pyc=delta*tm(4,6)+delta2*ta(73)+delta3*ta(194) -c Write out results - do 5 i=1,2 - if (i.eq.1) then - iflag=1 - if (isend.eq.2) iflag=0 - ifile=jof - endif - if (i.eq.2) then - iflag=1 - if (isend.eq.1) iflag=0 - ifile=jodf - endif - if (iflag.eq.0) goto 5 - write(ifile,100) - 100 format(/,1x,'closed orbit data for delta defined in terms of', - & 1x,'energy deviation:') - write(ifile,120) - 120 format(1x,'location of closed orbit (x,px,y,py)') - write(ifile,130) - 130 format(/,1x,'terms linear in delta') - write(ifile,140) tm(1,6),tm(2,6),tm(3,6),tm(4,6) - 140 format(1x,4(d15.8,2x)) - write(ifile,150) - 150 format(/,1x,'terms quadratic in delta') - write(ifile,140) -ta(63),ta(48),-ta(79),ta(73) - write(ifile,160) - 160 format(/,1x,'terms cubic in delta') - write(ifile,140) -ta(174),ta(139),-ta(204),ta(194) - write(ifile,110) delta - 110 format(/,1x,'location of closed orbit when delta = ',d15.8) - write(ifile,140) xc,pxc,yc,pyc - 5 continue - endif -c Procedure when IOPT = 2 - if (iopt.eq.2) then -c Compute location of closed orbit for given delta value -c -c the code below needs to be modified - delta2=delta*delta - delta3=delta*delta2 - xc=delta*tm(1,6)-delta2*ta(63)-delta3*ta(174) - pxc=delta*tm(2,6)+delta2*ta(48)+delta3*ta(139) - yc=delta*tm(3,6)-delta2*ta(79)-delta3*ta(204) - pyc=delta*tm(4,6)+delta2*ta(73)+delta3*ta(194) -c end of code to be modified -c -c Write out results - do 7 i=1,2 - if (i.eq.1) then - iflag=1 - if (isend.eq.2) iflag=0 - ifile=jof - endif - if (i.eq.2) then - iflag=1 - if (isend.eq.1) iflag=0 - ifile=jodf - endif - if (iflag.eq.0) goto 7 - write(ifile,102) - 102 format(/,1x,'closed orbit data for delta defined in terms of', - & 1x,'momentum deviation:') -c -c the code below needs to be modified - write(ifile,120) - write(ifile,130) - write(ifile,140) tm(1,6),tm(2,6),tm(3,6),tm(4,6) - write(ifile,150) - write(ifile,140) -ta(63),ta(48),-ta(79),ta(73) - write(ifile,160) - write(ifile,140) -ta(174),ta(139),-ta(204),ta(194) - write(ifile,110) delta - write(ifile,140) xc,pxc,yc,pyc -c end of code to be modified -c - 7 continue - write(6,*) 'IOPT = 2 case not yet installed completely' - endif - endif -c -c Factorization of map into betatron and remaining terms. -c Computation of betatron term script B. - call betmap(ana,anm,ba,bm) -c Computation of remaining nonlinear correction map script C. - call mapmap(ba,bm,tempa,tempm) - call inv(tempa,tempm) - call concat(tempa,tempm,ana,anm,ca,cm) -c Computation of B for specific value of delta. - call chrexp(iopt,delta,ba,bm,am1,am2,am3) -c -c Procedure for output of twiss matrix and corrections. - if(idata.eq.2 .or. idata.eq.3) then -c Procedure when IOPT =1 - if (iopt.eq.1) then -c Print out matrices bm, am1, and am2. - do 9 i=1,2 - if (i.eq.1) then - iflag=1 - if (isend.eq.2) iflag=0 - ifile=jof - endif - if (i.eq.2) then - iflag=1 - if (isend.eq.1) iflag=0 - ifile=jodf - endif - if (iflag.eq.0) goto 9 - write(ifile,198) - 198 format(//,1x,'twiss matrix for delta defined in terms of energy', - &1x,'deviation:') - write(ifile,200) - 200 format(/,1x,'on energy twiss matrix') - call pcmap(i,0,0,0,ba,bm) - write(ifile,300) - 300 format(//,1x,'matrix for delta correction') - call pcmap(i,0,0,0,ba,am1) - write(ifile,400) - 400 format(//,1x,'matrix for delta**2 correction') - call pcmap(i,0,0,0,ba,am2) -c Print out value of twiss matrix - write(ifile,402) delta - 402 format(//,1x,'value of twiss matrix when delta= ',d15.8) - call pcmap(i,0,0,0,ba,am3) - 9 continue - endif -c Procedure when IOPT = 2 - if (iopt.eq.2) then -c Print out matrices bm, am1, and am2. - do 11 i=1,2 - if (i.eq.1) then - iflag=1 - ifile=jof - if (isend.eq.2) iflag=0 - endif - if (i.eq.2) then - iflag=1 - if (isend.eq.1) iflag=0 - ifile=jodf - endif - if (iflag.eq.0) goto 11 - write(ifile,199) - 199 format(//,1x,'twiss matrix for delta defined in terms of', - &1x,'momentum deviation:') - write(ifile,202) - 202 format(/,1x,'on momentum twiss matrix') - call pcmap(i,0,0,0,ba,bm) - write(ifile,300) - call pcmap(i,0,0,0,ba,am1) - write(ifile,400) - call pcmap(i,0,0,0,ba,am2) -c Print out value of twiss matrix - write(ifile,402) delta - call pcmap(i,0,0,0,ba,am3) - 11 continue - endif - endif -c -c Procedure for output of the maps BC, B, and C. - if (ipmaps.eq.1 .or. ipmaps.eq.3) then - do 13 i=1,2 - if (i.eq.1) then - iflag=1 - if (isend.eq.2) iflag=0 - ifile=jof - endif - if (i.eq.2) then - iflag=1 - if (isend.eq.1) iflag=0 - ifile=jodf - endif - if (iflag.eq.0) goto 13 - write(ifile,600) - 600 format(//,1x,'total transfer map about the closed orbit') - call pcmap(i,i,0,0,ana,anm) - write(ifile,700) - 700 format(//,1x,'betatron factor of transfer map') - call pcmap(i,i,0,0,ba,bm) - write(ifile,800) - 800 format(//,1x,'nonlinear factor of transfer map') - call pcmap(i,i,0,0,ca,cm) - 13 continue - endif -c -c Procedure for output of script T. - if (ipmaps.eq.2 .or. ipmaps.eq.3) then - do 15 i=1,2 - if (i.eq.1) then - iflag=1 - if (isend.eq.2) iflag=0 - ifile=jof - endif - if (i.eq.2) then - iflag=1 - if (isend.eq.1) iflag=0 - ifile=jodf - endif - if (iflag.eq.0) goto 15 - write(ifile,900) - 900 format(//,1x,'transfer map script T to the closed orbit') - call pcmap(i,i,0,0,ta,tm) - 15 continue - endif - -c -c Put maps in buffers - call mapmap(ana,anm,buf1a,buf1m) - call mapmap(ba,bm,buf2a,buf2m) - call mapmap(ca,cm,buf3a,buf3m) - call clear(buf4a,buf4m) - call mapmap(buf4a,am3,buf4a,buf4m) - call mapmap(ta,tm,buf5a,buf5m) -c -c Procedure for writing of maps. - if(iwmaps.gt.0) then - mpot=mpo - mpo=iwmaps - call mapout(0,ana,anm) - call mapout(0,ba,bm) - call mapout(0,ca,cm) - call mapout(0,buf4a,buf4m) - call mapout(0,ta,tm) - mpo=mpot - endif -c - return - end -c -*********************************************************************** -c - subroutine csym(isend,fm,ans) -c -c This subroutine checks the symplectic condition for the matrix fm -c Written by Alex Dragt, 4 October 1989 -c - include 'impli.inc' - include 'files.inc' -c -c Calling arrays - dimension fm(6,6) -c -c Temporary arrays - dimension tm(6,6) -c -c-----Procedure -c - call matmat(fm,tm) - call minv(tm) - call mmult(tm,fm,tm) - do 10 i=1,6 - 10 tm(i,i)=tm(i,i)-1.d0 - call mnorm(tm,ans) -c -c Write out results if desired -c - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) ' symplectic violation = ',ans - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) ' symplectic violation = ',ans - endif -c - return - end -c -*********************************************************************** -c - subroutine dia(p,fa,fm) -c this is a routine for computing invariants in the dynamic case -c Written by Alex Dragt, Spring 1987 - use rays - use lieaparam, only : monoms - include 'impli.inc' -c - include 'files.inc' - include 'buffer.inc' -c - dimension p(6),fa(monoms),fm(6,6) -c - dimension ga(monoms),g1a(monoms) - dimension ta(monoms),t1a(monoms),t2a(monoms) - dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6),t2m(6,6) -c -c set up control indices - iopt=nint(p(1)) - idata=nint(p(2)) - ipmaps=nint(p(3)) - isend=nint(p(4)) - iwmaps=nint(p(5)) - iwnum=nint(p(6)) -c -c write headings - if (isend.eq.1 .or. isend.eq.3) then - write (jof,*) - write (jof,*) 'dynamic invariant analysis' - endif - if (isend.eq.2 .or. isend.eq.3) then - write (jodf,*) - write (jodf,*) 'dynamic invariant analysis' - endif -c -c begin calculation -c -c find the transforming (conjugating) map script A -c remove offensive terms from matrix part of map: - call dpur2(fa,fm,ga,gm,ta,tm) -c remove offensive terms from f3 part of map: - call dpur3(ga,gm,g1a,g1m,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,ta,tm,t2a,t2m) -c remove offensive terms from f4 part of map: - call dpur4(g1a,g1m,ga,gm,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,t2a,t2m,ta,tm) -c put script A in buffer 1 and script N in buffer 2 - call mapmap(ta,tm,buf1a,buf1m) - call mapmap(ga,gm,buf2a,buf2m) -c -c procedure for computing invariant -c invert script A - call inv(ta,tm) - call clear(t1a,t1m) -c computation of x invariant - if(iopt.eq.1) then - t1a(7)=1.d0 - t1a(13)=1.d0 - endif -c computation of y invariant - if(iopt.eq.2) then - t1a(18)=1.d0 - t1a(22)=1.d0 - endif -c computation of t invariant - if(iopt.eq.3) then - t1a(25)=1.d0 - t1a(27)=1.d0 - endif -c computation of mixed invariant - if(iopt.ge.4) then - read(iopt,*) anx,any,ant - if (isend.eq.1 .or. isend.eq.3) then - write(jof,*) 'parameters read in from file',iopt - endif - if (isend.eq.2 .or. isend.eq.3) then - write(jof,*) 'parameters read in from file',iopt - endif - t1a(7)=anx - t1a(13)=anx - t1a(18)=any - t1a(22)=any - t1a(25)=ant - t1a(27)=ant - endif -c put invariant in buffer 3 - call ident(buf3a,buf3m) - call fxform(ta,tm,t1a,buf3a) -c -c procedure for putting out data - if (idata.eq.1 .or. idata.eq.3) then - do 10 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 10 - write(ifile,*) - write(ifile,*) 'invariant polynomial' - call pcmap(0,j,0,0,buf3a,buf3m) - 10 continue - endif - if (idata.eq.2 .or. idata.eq.3) then - mpot=mpo - mpo=18 - call mapout(0,buf3a,buf3m) - mpo=mpot - endif -c -c procedure for printing out maps - do 20 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 20 - if (ipmaps.eq.1 .or. ipmaps.eq.3) then - write(ifile,*) - write(ifile,*) 'normalizing map script A' - call pcmap(j,j,0,0,buf1a,buf1m) - endif - if (ipmaps.eq.2 .or. ipmaps.eq.3) then - write(ifile,*) - write(ifile,*) 'normal form map script N' - call pcmap(j,j,0,0,buf2a,buf2m) - endif - 20 continue -c -c procedure for writing out maps - if (iwmaps.gt.0) then - mpot=mpo - mpo=iwmaps - call mapout(0,buf1a,buf1m) - call mapout(0,buf2a,buf2m) - call mapout(0,buf3a,buf3m) - mpo=mpot - endif -c -c procedure for computing values of invariant and writing them out - if (iwnum.gt.0) then - write(jof,*) - write(jof,*) 'values of invariant written on file ',iwnum - do 30 k=1,nraysp - do 40 j=1,6 - 40 zi(j)=zblock(j,k) - call evalf(zi,buf3a,val2,val3,val4) - write(iwnum,60) k,val2,val3,val4,0.,0. - 60 format(1x,i12,5(1x,1pe12.5)) - 30 continue - endif -c -c put maps in buffers -c buffers 1 and 2 already contain the transforming map script A -c and the normal form map script N, respectively. -c buffer 3 contains the map which has for its matrix the identity -c matrix and for its array the invariant polynomial. -c clear buffers 4 and 5 - call clear(buf4a,buf4m) - call clear(buf5a,buf5m) -c - return - end -c -*********************************************************************** -c - subroutine dnor_old(p,fa,fm) -c this is a subroutine for normal form analysis of dynamic maps -c Written by Alex Dragt, Spring 1987 - use parallel, only : idproc - use lieaparam, only : monoms - include 'impli.inc' -c - include 'files.inc' - include 'buffer.inc' -c - dimension p(6),fa(monoms),fm(6,6) -c - dimension ga(monoms),g1a(monoms) - dimension ta(monoms),t1a(monoms),t2a(monoms) - dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6),t2m(6,6) -c -c set up control indices - idata=nint(p(1)) - ipmaps=nint(p(2)) - isend=nint(p(3)) - iwmaps=nint(p(4)) -c -c write headings - if ((isend.eq.1 .or. isend.eq.3) .and. idproc.eq.0) then - write (jof,*) - write (jof,*) 'dynamic normal form analysis' - endif - if ((isend.eq.2 .or. isend.eq.3) .and. idproc.eq.0) then - write (jodf,*) - write (jodf,*) 'dynamic normal form analysis' - endif -c -c begin calculation -c -c remove offensive terms from matrix part of map: - call dpur2(fa,fm,ga,gm,ta,tm,t2m) -c remove offensive terms from f3 part of map: - call dpur3(ga,gm,g1a,g1m,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,ta,tm,t2a,t2m) -c remove offensive terms from f4 part of map: - call dpur4(g1a,g1m,ga,gm,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,t2a,t2m,ta,tm) -c put transforming map in buffer 1 - call mapmap(ta,tm,buf1a,buf1m) -c put transformed map in buffer 2 - call mapmap(ga,gm,buf2a,buf2m) -c -c procedure for computing normal form exponent and pseudo hamiltonian - call ident(buf3a,buf3m) - if (idata.eq.1 .or. idata.eq.2 .or. idata.eq.3) then -c compute phase advances - cwx=gm(1,1) - swx=gm(1,2) - wx=atan2(swx,cwx) - cwy=gm(3,3) - swy=gm(3,4) - wy=atan2(swy,cwy) - cwt=gm(5,5) - swt=gm(5,6) - wt=atan2(swt,cwt) -c set up normal form for exponent - do 10 i=1,27 - 10 ga(i)=0. - ga(7)=-wx/2.d0 - ga(13)=-wx/2.d0 - ga(18)=-wy/2.d0 - ga(22)=-wy/2.d0 - ga(25)=-wt/2.d0 - ga(27)=-wt/2.d0 - endif -c transform exponent to get pseudo hamiltonian - if (idata.eq.2 .or. idata.eq.3) then - call inv(ta,tm) - call fxform(ta,tm,ga,g1a) -c store results in buffer 3 - call mapmap(g1a,buf3m,buf3a,buf3m) - endif -c -c procedure for putting out data - do 20 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 20 - if (idata.eq.1 .or. idata.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'exponent for normal form' - call pcmap(0,j,0,0,ga,gm) - endif - if (idata.eq.2. .or. idata.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'pseudo hamiltonian' - call pcmap(0,j,0,0,buf3a,buf3m) - endif - 20 continue -c -c procedure for printing out maps - do 30 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 30 - if (ipmaps.eq.1 .or. ipmaps.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'normalizing map script A' - call pcmap(j,j,0,0,buf1a,buf1m) - endif - if (ipmaps.eq.2. .or. ipmaps.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0) - &write(ifile,*) 'normal form script N for transfer map' - call pcmap(j,j,0,0,buf2a,buf2m) - endif - 30 continue -c -c procedure for writing out maps - if (iwmaps.gt.0) then - mpot=mpo - mpo=iwmaps - call mapout(0,buf1a,buf1m) - call mapout(0,buf2a,buf2m) - call mapout(0,buf3a,buf3m) - mpo=mpot - endif -c -c put maps in buffers -c buffers 1 and 2 already contain the transforming map script A -c and the normal form map script N, respectively. -c buffer 3 contains the map which has for its matrix the identity -c matrix and for its array the pseudo hamiltonian. -c clear buffers 4 and 5 - call clear(buf4a,buf4m) - call clear(buf5a,buf5m) -c - return - end -c -******************************************************************* -c - subroutine dnor(p,fa,fm) -c this is a subroutine for normal form analysis of dynamic maps -c Written by Alex Dragt, Spring 1987 -c - use parallel, only : idproc - use lieaparam, only : monoms - include 'impli.inc' -c - include 'files.inc' - include 'buffer.inc' -c -c Calling arrays - dimension p(6),fa(monoms),fm(6,6) -c -c Local arrays - dimension ga(monoms),g1a(monoms) - dimension ta(monoms),t1a(monoms) - dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6) -c -c set up control indices - keep= nint(p(1)) - idata= nint(p(2)) - ipmaps=nint(p(3)) - isend= nint(p(4)) - iwmaps=nint(p(5)) -c -c write headings - if (isend.eq.1 .or. isend.eq.3) then - if(idproc.eq.0)write (jof,*) - if(idproc.eq.0)write (jof,*) 'dynamic normal form analysis' - endif - if (isend.eq.2 .or. isend.eq.3) then - if(idproc.eq.0)write (jodf,*) - if(idproc.eq.0)write (jodf,*) 'dynamic normal form analysis' - endif -c -c begin calculation -c -c remove offensive terms from matrix part of map: - call dpur2(fa,fm,ga,gm,ta,tm,t1m) -c remove offensive terms from f3 part of map: - call dpur3(ga,gm,g1a,g1m,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,ta,tm,ta,tm) -c remove offensive terms from f4 part of map: - call dpur4(g1a,g1m,ga,gm,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,ta,tm,ta,tm) -c put transforming map in buffer 1 - call mapmap(ta,tm,buf1a,buf1m) -c put transformed map in buffer 2 - call mapmap(ga,gm,buf2a,buf2m) -c -c procedure for computing normal form exponent and pseudo hamiltonian - call ident(buf3a,buf3m) - if (idata.eq.1 .or. idata.eq.2 .or. idata.eq.3) then -c compute phase advances - cwx=gm(1,1) - swx=gm(1,2) - wx=atan2(swx,cwx) - cwy=gm(3,3) - swy=gm(3,4) - wy=atan2(swy,cwy) - cwt=gm(5,5) - swt=gm(5,6) - wt=atan2(swt,cwt) -c set up normal form for exponent - do 10 i=1,27 - 10 ga(i)=0. - ga(7)=-wx/2.d0 - ga(13)=-wx/2.d0 - ga(18)=-wy/2.d0 - ga(22)=-wy/2.d0 - ga(25)=-wt/2.d0 - ga(27)=-wt/2.d0 - endif -c transform exponent to get pseudo hamiltonian - if (idata.eq.2 .or. idata.eq.3) then - call inv(ta,tm) - call fxform(ta,tm,ga,g1a) -c store results in buffer 3 - call mapmap(g1a,buf3m,buf3a,buf3m) - endif -c -c procedure for putting out data - do 20 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 20 - if (idata.eq.1 .or. idata.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'exponent for normal form' - call pcmap(0,j,0,0,ga,gm) - endif - if (idata.eq.2. .or. idata.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'pseudo hamiltonian' - call pcmap(0,j,0,0,buf3a,buf3m) - endif - 20 continue -c -c procedure for printing out maps - do 30 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 30 - if (ipmaps.eq.1 .or. ipmaps.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'normalizing map script A' - call pcmap(j,j,0,0,buf1a,buf1m) - endif - if (ipmaps.eq.2. .or. ipmaps.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0) - & write(ifile,*) 'normal form script N for transfer map' - call pcmap(j,j,0,0,buf2a,buf2m) - endif - 30 continue -c -c procedure for writing out maps - if (iwmaps.gt.0) then - mpot=mpo - mpo=iwmaps - call mapout(0,buf1a,buf1m) - call mapout(0,buf2a,buf2m) - call mapout(0,buf3a,buf3m) - mpo=mpot - endif -c -c put maps in buffers -c buffers 1 and 2 already contain the transforming map script A -c and the normal form map script N, respectively. -c buffer 3 contains the map which has for its matrix the identity -c matrix and for its array the pseudo hamiltonian. -c clear buffers 4 and 5 - call clear(buf4a,buf4m) - call clear(buf5a,buf5m) -c - return - end -c -******************************************************************* -c - subroutine fadm(p,fa,fm) -c this subroutine fourier analyzes a dynamic transfer map - use lieaparam, only : monoms - include 'impli.inc' - dimension p(6),fa(monoms),fm(6,6) -c - write(6,*) 'fadm not yet available' - return - end -c -******************************************************************* -c - subroutine fasm(p,fa,fm) -c this subroutine fourier analyzes a static transfer map - use lieaparam, only : monoms - include 'impli.inc' - dimension p(6),fa(monoms),fm(6,6) -c - write(6,*) 'fasm not yet available' - return - end -c -******************************************************************* -c - subroutine gbuf_old(p,fa,fm) -c this subroutine gets a map from an auxiliary buffer and -c concatenates it with the map in the main buffer. -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' - include 'buffer.inc' -c - dimension p(6),fa(monoms),fm(6,6) -c - dimension ta(monoms),tm(6,6) -c -c set up and test control index - i=nint(p(1)) - if (i.lt.1 .or. i.gt.5) then - write(6,*) 'trouble with index nmap in gbuf' - return - endif -c -c concatenate the map in bufi with the existing map - if(i.eq.1) call scncat(fa,fm,buf1a,buf1m,ta,tm) - if(i.eq.2) call scncat(fa,fm,buf2a,buf2m,ta,tm) - if(i.eq.3) call scncat(fa,fm,buf3a,buf3m,ta,tm) - if(i.eq.4) call scncat(fa,fm,buf4a,buf4m,ta,tm) - if(i.eq.5) call scncat(fa,fm,buf5a,buf5m,ta,tm) - call mapmap(ta,tm,fa,fm) -c - return - end -c -c***************************************************************************** -c - subroutine gbuf(p,fa,fm) -c this subroutine gets a map from an auxiliary buffer and -c either concatenates it with the map in the main buffer, -c or uses it to replace the map in the main buffer. -c Written by Alex Dragt, Spring 1987 -c Modified by Alex Dragt, 17 June 1988 -c Modified by Alex Dragt, 13 October 1988 -c - include 'impli.inc' - include 'param.inc' - include 'buffer.inc' -c -c Calling arrays - dimension p(6),fa(monoms),fm(6,6) -c -c set up and test control indices - iopt=nint(p(1)) - i=nint(p(2)) - if (i.lt.1 .or. i.gt.5) then - write(6,*) 'trouble with index nmap in gbuf' - return - endif -c -c if iopt=1, concatenate the existing map with the map in bufi - if(iopt.eq.1) then - if(i.eq.1) call concat(fa,fm,buf1a,buf1m,fa,fm) - if(i.eq.2) call concat(fa,fm,buf2a,buf2m,fa,fm) - if(i.eq.3) call concat(fa,fm,buf3a,buf3m,fa,fm) - if(i.eq.4) call concat(fa,fm,buf4a,buf4m,fa,fm) - if(i.eq.5) call concat(fa,fm,buf5a,buf5m,fa,fm) - return - endif -c -c if iopt=2, replace the existing map with the map in bufi - if(iopt.eq.2) then - if(i.eq.1) call mapmap(buf1a,buf1m,fa,fm) - if(i.eq.2) call mapmap(buf2a,buf2m,fa,fm) - if(i.eq.3) call mapmap(buf3a,buf3m,fa,fm) - if(i.eq.4) call mapmap(buf4a,buf4m,fa,fm) - if(i.eq.5) call mapmap(buf5a,buf5m,fa,fm) - return - endif -c - write(6,*) 'trouble with index iopt in gbuf' - return - end -c -c***************************************************************************** -c - subroutine geom(pp) -c -c Routine to compute geometry of a loop. -c Written by A. Dragt 8/27/92. -c Modified 5/27/98 AJD. -c Modified 1/8/99 AJD. -c Based on the subroutines cqlate and pmif -c - use beamdata - use lieaparam - use acceldata - include 'impli.inc' -c -c common blocks -c - include 'codes.inc' - include 'files.inc' - include 'loop.inc' - include 'core.inc' - include 'pie.inc' - include 'parset.inc' - include 'usrdat.inc' -c - dimension pp(6) -c -c local variables -c - character*8 string(5),str - dimension ex(3), ey(3), ez(3) - dimension exl(3), eyl(3), ezl(3) - dimension exlt(3), eylt(3), ezlt(3) - dimension dims(6) -c -c set up control indices -c - iopt=nint(pp(1)) - si=pp(2) - ti=pp(3) - ipset1=nint(pp(4)) - ipset2=nint(pp(5)) - isend=nint(pp(6)) -c -c get contents of psets -c - if (ipset1.gt.0 .and. ipset1.le.maxpst) then - xi=pst(1,ipset1) - yi=pst(2,ipset1) - zi=pst(3,ipset1) - phid=pst(4,ipset1) - thetad=pst(5,ipset1) - psid=pst(6,ipset1) - phir=phid*pi180 - thetar=thetad*pi180 - psir=psid*pi180 - endif - if (ipset2.gt.0 .and. ipset2.le.maxpst) then - ifile=nint(pst(1,ipset2)) - jfile=nint(pst(2,ipset2)) - kfile=nint(pst(3,ipset2)) - lfile=nint(pst(4,ipset2)) - mfile=nint(pst(5,ipset2)) - ndpts=nint(pst(6,ipset2)) - endif -c -c set up variables and constants -c - ss=si - tt=ti - vr=1.d0/(beta*c) - x=xi - y=yi - z=zi - do i=1,6 - dims(i)=0.d0 - end do - do i=1,3 - ex(i)=0.d0 - ey(i)=0.d0 - ez(i)=0.d0 - end do - ex(1)=1.d0 - ey(2)=1.d0 - ez(3)=1.d0 -c write(6,*) ' thetar =', thetar - call erotv(phir,thetar,psir,ex,exl) - call erotv(phir,thetar,psir,ey,eyl) - call erotv(phir,thetar,psir,ez,ezl) -c -c start routine -c -c write out header - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) ' ' - write(jof,*) ' Geometrical Analysis' - write(jof,*) ' ' - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) ' ' - write(jodf,*) ' Geometrical Analysis' - write(jodf,*) ' ' - endif -c -c see if a loop exists - if(nloop.le.0) then - write(jof ,*) ' error from geom: no loop has been specified' - write(jodf,*) ' error from geom: no loop has been specified' - return - endif -c -c write out starting values - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) ' initial s,x,y,z,t;ex,ey,ez:' - write(jof,237) si,xi,yi,zi,ti - write(jof,*) exl(1),exl(2),exl(3) - write(jof,*) eyl(1),eyl(2),eyl(3) - write(jof,*) ezl(1),ezl(2),ezl(3) - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jof,*) ' initial s,x,y,z,t;ex,ey,ez:' - write(jodf,237) si,xi,yi,zi,ti - write(jodf,*) exl(1),exl(2),exl(3) - write(jodf,*) eyl(1),eyl(2),eyl(3) - write(jodf,*) ezl(1),ezl(2),ezl(3) - endif -c -c scan the loop -c - do 137 jk1=1,joy -c -c initialize various quantities - icat=0 - grad = 0.d0 -c -c record element category and set various quantities -c -c element - if(mim(jk1).lt.0) then - string(1)=lmnlbl(-mim(jk1))(1:8) -c user supplied element - else if(mim(jk1).gt.5000) then - string(1)=lmnlbl(mim(jk1)-5000)(1:8) -c lump - else - string(1)=ilbl(inuse(mim(jk1)))(1:8) - endif - call lookup(string(1),itype,item) -c write(6,513) string(1) -c 513 format(1x,a8) -c write(6,*) 'itype and item are ',itype, item -c -c procedure for a menu item -c - if(itype.eq.1) then - k=item - imax=nrp(nt1(k),nt2(k)) -c -c see if item is a simple command -c - if (nt1(k) .eq. 7) then -c dims - if (nt2(k) .eq. 35) then - do ii=1,6 - dims(ii)=pmenu(ii+mpp(k)) - end do - endif -c - endif -c -c see if item is a simple element -c - if (nt1(k) .eq. 1) then -c -c drift - if (nt2(k) .eq. 1) then - icat=1 - aleng = pmenu(1+mpp(k)) - endif -c spce - if (nt2(k) .eq. 25) then - icat=1 - aleng = pmenu(1+mpp(k)) - endif -c arc - if (nt2(k) .eq. 30) then - icat=4 - d1 = pmenu(1+mpp(k)) - d2 = pmenu(2+mpp(k)) - aleng = pmenu(3+mpp(k)) - angd = pmenu(4+mpp(k)) - endif -c quad - if (nt2(k) .eq. 9) then - icat=1 - aleng = pmenu(1+mpp(k)) - grad = pmenu(2+mpp(k)) - endif -c cfqd - if (nt2(k) .eq. 18) then - icat=1 - aleng = pmenu(1+mpp(k)) - ipst = nint(pmenu(2+mpp(k))) - if (ipst.gt.0 .and. ipst.le.maxpst) then - grad = pst(1,ipst) - endif - endif -c sext - if (nt2(k) .eq. 10) then - icat=1 - aleng = pmenu(1+mpp(k)) - endif -c octm - if (nt2(k) .eq. 11) then - icat=1 - aleng = pmenu(1+mpp(k)) - endif -c recm - if (nt2(k) .eq. 24) then - icat=1 - aleng = pmenu(2+mpp(k)) - pmenu(1+mpp(k)) -c -c computing the gradient for recm is complicated -c and so it is not done for the time being -c - endif -c sol - if (nt2(k) .eq. 20) then - icat=1 - aleng = pmenu(2+mpp(k)) - pmenu(1+mpp(k)) - endif -c nbend - if (nt2(k) .eq. 2) then - icat=2 - angd=pmenu(1+mpp(k)) - b=pmenu(4+mpp(k)) - endif -c pbend - if (nt2(k) .eq. 3) then - icat=2 - angd=pmenu(1+mpp(k)) - b=pmenu(4+mpp(k)) - endif -c gbend - if (nt2(k) .eq. 4) then - icat=2 - angd=pmenu(1+mpp(k)) - b=pmenu(6+mpp(k)) - endif -c gbdy - if (nt2(k) .eq. 6) then - icat=2 - angd=pmenu(1+mpp(k)) - b=pmenu(4+mpp(k)) - endif -c cfbd - if (nt2(k) .eq. 8) then - icat=2 - angd=pmenu(1+mpp(k)) - b=pmenu(2+mpp(k)) - ipst = nint(pmenu(6+mpp(k))) - if (ipst.gt.0 .and. ipst.le.maxpst) then - grad = pst(1,ipst) - endif - endif -c arot - if (nt2(k) .eq. 14) then - icat=3 - angd=pmenu(1+mpp(k)) - endif -c prot -c if (nt2(k) .eq. 5) then -c angd=pmenu(1+mpp(k)) -c kind=nint(pmenu(2+mpp(k))) -c endif -c -c carry out computations for items dims thru prot above -c -c compute and write out local geometry - if( iopt .eq. 2 .or. iopt .eq. 3 - & .or. iopt .eq. 12 .or. iopt .eq. 13) then -c -c procedure for a straight element - if(icat .eq. 1) then -c -c write all descriptive information to external file mfile - if (mfile .gt. 0) then - write(mfile,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - 605 format(1h ,1x,a8,1x,a8,1x,i5,1x,i5,1x,i5) - if(imax.eq.0)goto 137 - write(mfile,607)(pmenu(i+mpp(k)),i=1,imax) -c Output using Mottershead's favorite pg format - 607 format((1h ,3(1x,1pg22.15))) - write(mfile,611) lmnlbl(k), aleng - 611 format(2x,a,f9.4) - write(mfile,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) - 608 format(1x,6f12.4) - endif -c -c write all descriptive information to terminal and/or drop file - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - if(imax.eq.0)goto 137 - write(jof,607)(pmenu(i+mpp(k)),i=1,imax) -c Output using Mottershead's favorite pg format - write(jof,609) lmnlbl(k), aleng - 609 format(2x,a,'length =',f9.4,2x,'dimensions:') - write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) - write(jof,*) ' s,x,y,z,t;ex,ey,ez along element:' - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - if(imax.eq.0)goto 137 - write(jodf,607)(pmenu(i+mpp(k)),i=1,imax) - write(jodf,609) lmnlbl(k), aleng - write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) - write(jodf,*) ' s,x,y,z,t;ex,ey,ez along element:' - endif -c -c subdivide element - ndptst=ndpts - if(ndpts .lt. 1) ndptst=1 - daleng=aleng/float(ndptst) - if( dabs(aleng) .lt. 1.0d-10) ndptst=0 - do i=0,ndptst - sst = ss + daleng*float(i) - ttt = tt + daleng*float(i)*vr - xt = x + daleng*float(i)*ezl(1) - yt = y + daleng*float(i)*ezl(2) - zt = z + daleng*float(i)*ezl(3) -c -c write simple element descriptive information -c and pathlength information to external file kfile - if (kfile .gt. 0) then - write(kfile,610) lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad - 610 format (1x,a8,2(i3),4(1x,1pe12.5)) - endif -c -c write simple element descriptive information and pathlength -c and coordinate information to external file lfile - if (lfile .gt. 0) then - write(lfile,710) - & lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad,xt,yt,zt,ttt - 710 format (1x,a8,2(i3),8(1x,1pe12.5)) - endif -c -c write coordinate information to external file mfile - if (mfile .gt. 0) then - write(mfile,236) sst,xt,yt,zt,ttt,0.0 - 236 format(6(1x,1pe12.5)) - endif -c -c write coordinate information to terminal and/or drop file - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,237) sst,xt,yt,zt,ttt - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,237) sst,xt,yt,zt,ttt - endif - 237 format(5(1x,1pe12.5)) -c -c write orientation information to external file mfile - if (mfile .gt. 0) then - write(mfile,*) exl(1), exl(2), exl(3) - write(mfile,*) eyl(1), eyl(2), eyl(3) - write(mfile,*) ezl(1), ezl(2), ezl(3) - endif -c -c write orientation information to terminal and/or drop file - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) exl(1), exl(2), exl(3) - write(jof,*) eyl(1), eyl(2), eyl(3) - write(jof,*) ezl(1), ezl(2), ezl(3) - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) exl(1), exl(2), exl(3) - write(jodf,*) eyl(1), eyl(2), eyl(3) - write(jodf,*) ezl(1), ezl(2), ezl(3) - endif -c - end do - endif -c -c procedure for a bending (dipole) element - if(icat .eq. 2) then - angr=angd*pi180 - rho=brho/b - aleng=rho*angr -c -c write all descriptive information to external file mfile - if (mfile .gt. 0) then - write(mfile,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - if(imax.eq.0)goto 137 - write(mfile,607)(pmenu(i+mpp(k)),i=1,imax) -c Output using Mottershead's favorite pg format - write(mfile,611) lmnlbl(k), aleng - write(mfile,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) - endif -c -c write all descriptive information to terminal and/or drop file - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - if(imax.eq.0)goto 137 - write(jof,607)(pmenu(i+mpp(k)),i=1,imax) - write(jof,609) lmnlbl(k), aleng - write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) - write(jof,*) ' s,x,y,z,t;ex,ey,ez along element:' - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - if(imax.eq.0)goto 137 - write(jodf,607)(pmenu(i+mpp(k)),i=1,imax) - write(jodf,609) lmnlbl(k), aleng - write(jodf,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) - write(jodf,*) ' s,x,y,z,t;ex,ey,ez along element:' - endif -c -c subdivide element - ndptst=ndpts - if(ndpts .lt. 1) ndptst=1 - daleng=aleng/float(ndptst) - dangr=angr/float(ndptst) - if( dabs(aleng) .lt. 1.0d-10) ndptst=0 - do i=0,ndptst - sst = ss + daleng*float(i) - ttt = tt + daleng*float(i)*vr - angrt=dangr*float(i) - sfact=rho*dsin(angrt) - cfact=rho*(1.d0 - dcos(angrt)) -c Note: signs have been adjusted to take into account that -c the rotation axis is - eyl. - xt = x -cfact*exl(1) + sfact*ezl(1) - yt = y -cfact*exl(2) + sfact*ezl(2) - zt = z -cfact*exl(3) + sfact*ezl(3) - angrt=-angrt - call rotv(eyl,angrt,exl,exlt) - call rotv(eyl,angrt,ezl,ezlt) -c -c write simple element descriptive information -c and pathlength information to external file kfile - if (kfile .gt. 0) then - write(kfile,610) lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad - endif -c -c -c write simple element descriptive information and pathlength -c and coordinate information to external file lfile - if (lfile .gt. 0) then - write(lfile,710) - & lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad,xt,yt,zt,ttt - endif -c -c write coordinate information to external file mfile - if (mfile .gt. 0) then - write(mfile,236) sst,xt,yt,zt,ttt,0.0 - endif -c -c write coordinate information to terminal and/or drop file - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,237) sst,xt,yt,zt,ttt - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,237) sst,xt,yt,zt,ttt - endif -c -c write orientation information to external file mfile - if (mfile .gt. 0) then - write(mfile,*) exlt(1), exlt(2), exlt(3) - write(mfile,*) eyl(1), eyl(2), eyl(3) - write(mfile,*) ezlt(1), ezlt(2), ezlt(3) - endif -c -c write orientation information to terminal and/or drop file - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) exlt(1), exlt(2), exlt(3) - write(jof,*) eyl(1), eyl(2), eyl(3) - write(jof,*) ezlt(1), ezlt(2), ezlt(3) - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) exlt(1), exlt(2), exlt(3) - write(jodf,*) eyl(1), eyl(2), eyl(3) - write(jodf,*) ezlt(1), ezlt(2), ezlt(3) - endif - end do - endif -c -c procedure for an arc (arc) - if(icat .eq. 4) then -c -c write all descriptive information to external file mfile - if (mfile .gt. 0) then - write(mfile,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - if(imax.eq.0)goto 137 - write(mfile,607)(pmenu(i+mpp(k)),i=1,imax) -c Output using Mottershead's favorite pg format - write(mfile,611) lmnlbl(k), aleng - write(mfile,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) - endif -c -c write all descriptive information to terminal and/or drop file - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - if(imax.eq.0)goto 137 - write(jof,607)(pmenu(i+mpp(k)),i=1,imax) - write(jof,609) lmnlbl(k), aleng - write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) - write(jof,*) ' s,x,y,z,t;ex,ey,ez along element:' - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - if(imax.eq.0)goto 137 - write(jodf,607)(pmenu(i+mpp(k)),i=1,imax) - write(jodf,609) lmnlbl(k), aleng - write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) - write(jodf,*) ' s,x,y,z,t;ex,ey,ez along element:' - endif -c -c subdivide element - ndptst=ndpts - if(ndpts .lt. 1) ndptst=1 - daleng=aleng/float(ndptst) - dd1=d1/float(ndptst) - dd2=d2/float(ndptst) - hypot=dsqrt(d1**2 + d2**2) - angt=0.d0 - if (hypot .gt. 0.d0) then - sin=d2/hypot - cos=d1/hypot - angt=atan2(sin,cos) - endif - call rotv(eyl,angt,exl,exlt) - call rotv(eyl,angt,ezl,ezlt) - if( dabs(aleng) .lt. 1.0d-10) ndptst=0 - do i=0,ndptst - sst = ss + daleng*float(i) - ttt = tt + daleng*float(i)*vr - xt = x + (dd1*ezl(1)+dd2*exl(1))*float(i) - yt = y + (dd1*ezl(2)+dd2*exl(2))*float(i) - zt = z + (dd1*ezl(3)+dd2*exl(3))*float(i) -c -c write simple element descriptive information -c and pathlength information to external file kfile - if (kfile .gt. 0) then - write(kfile,610) lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad - endif -c -c write simple element descriptive information and pathlength -c and coordinate information to external file lfile - if (lfile .gt. 0) then - write(lfile,710) - & lmnlbl(k),nt1(k),nt2(k),sst,dims(1),dims(2),grad,xt,yt,zt,ttt - endif -c -c write coordinate information to external file mfile - if (mfile .gt. 0) then - write(mfile,236) sst,xt,yt,zt,ttt,0.0 - endif -c -c write coordinate information to terminal and/or drop file - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,237) sst,xt,yt,zt,ttt - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,237) sst,xt,yt,zt,ttt - endif -c -c write orientation information to external file mfile - if (mfile .gt. 0) then - write(mfile,*) exlt(1), exlt(2), exlt(3) - write(mfile,*) eyl(1), eyl(2), eyl(3) - write(mfile,*) ezlt(1), ezlt(2), ezlt(3) - endif -c -c write orientation information to terminal and/or drop file - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) exlt(1), exlt(2), exlt(3) - write(jof,*) eyl(1), eyl(2), eyl(3) - write(jof,*) ezlt(1), ezlt(2), ezlt(3) - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) exlt(1), exlt(2), exlt(3) - write(jodf,*) eyl(1), eyl(2), eyl(3) - write(jodf,*) ezlt(1), ezlt(2), ezlt(3) - endif -c - end do - endif -c - endif -c -c update geometry for items dims thru prot above -c -c procedure for a straight element - if(icat .eq. 1) then - ss = ss + aleng - tt = tt + aleng*vr - x = x + aleng*ezl(1) - y = y + aleng*ezl(2) - z = z + aleng*ezl(3) - endif -c -c procedure for a bending (dipole) element - if(icat .eq. 2) then - angr=angd*pi180 - rho=brho/b - aleng=rho*angr - ss = ss + aleng - tt = tt + aleng*vr - sfact=rho*dsin(angr) - cfact=rho*(1.d0 - dcos(angr)) -c Note: signs have been adjusted to take into account that -c the rotation axis is - eyl. - x = x -cfact*exl(1) + sfact*ezl(1) - y = y -cfact*exl(2) + sfact*ezl(2) - z = z -cfact*exl(3) + sfact*ezl(3) - angr=-angr - call rotv(eyl,angr,exl,exl) - call rotv(eyl,angr,ezl,ezl) - endif -c -c procedure for an arot - if(icat .eq. 3) then - angr=angd*pi180 -c Note: sign of angr has been adjusted in accord with Figure 6.14c -c of the MaryLie manual. - angr=-angr - call rotv(ezl,angr,exl,exl) - call rotv(ezl,angr,eyl,eyl) - endif -c -c procedure for an arc - if(icat .eq. 4) then - ss = ss + aleng - tt = tt + aleng*vr - x = x + d1*ezl(1) + d2*exl(1) - y = y + d1*ezl(2) + d2*exl(2) - z = z + d1*ezl(3) + d2*exl(3) - angr=angd*pi180 - call rotv(eyl,angr,exl,exl) - call rotv(eyl,angr,ezl,ezl) - endif -c -c -c response to a data point -c - if( iopt .eq. 1 .or. iopt .eq. 3 - & .or. iopt .eq. 11 .or. iopt .eq. 13) then -c - if (nt2(k) .eq. 23) then -c -c write all information to terminal and/or drop file - if (isend .eq. 1 .or. isend .eq. 3) then - write(jof,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - write(jof,*) ' dimensions:' - write(jof,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) - write(jof,*) ' s,x,y,z,t;ex,ey,ez:' - write(jof,237) ss,x,y,z,tt - write(jof,*) exl(1), exl(2), exl(3) - write(jof,*) eyl(1), eyl(2), eyl(3) - write(jof,*) ezl(1), ezl(2), ezl(3) - endif - if (isend .eq. 2 .or. isend .eq. 3) then - write(jodf,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - write(jodf,*) ' dimensions:' - write(jodf,608) dims(1),dims(2),dims(3),dims(4),dims(5),dims(6) - write(jodf,*) ' s,x,y,z,t;ex,ey,ez:' - write(jodf,237) ss,x,y,z,tt - write(jodf,*) exl(1), exl(2), exl(3) - write(jodf,*) eyl(1), eyl(2), eyl(3) - write(jodf,*) ezl(1), ezl(2), ezl(3) - endif -c -c write to external files -c write coordinate information to file ifile - if(ifile .gt. 0) then - write(ifile,520) ss,x,y,z,tt,0. - 520 format(6(1x,1pe12.5)) - endif -c write coordinate and orientation information to file jfile - if(jfile .gt. 0) then - write(jfile,520) ss,x,y,z,tt,0. - write(jfile,*) exl(1), exl(2), exl(3) - write(jfile,*) eyl(1), eyl(2), eyl(3) - write(jfile,*) ezl(1), ezl(2), ezl(3) - endif -c -c put result in ucalc - if( iopt .eq. 11 .or. iopt .eq. 13) then - ucalc(1)=ss - ucalc(2)=x - ucalc(3)=y - ucalc(4)=z - ucalc(5)=tt - ucalc(6)= exl(1) - ucalc(7)= exl(2) - ucalc(8)= exl(3) - ucalc(9)= eyl(1) - ucalc(10)=eyl(2) - ucalc(11)=eyl(3) - ucalc(12)=ezl(1) - ucalc(13)=ezl(2) - ucalc(14)=ezl(3) - endif -c - endif -c - endif -c - endif -c - endif -c -c procedure for a lump -c - if(itype .eq. 3) then -c write(ifile,515) string(1),mim(jk1) - 515 format(1x,1x,a8,1x,'lump',9x,'0',4x,'-1',2x,i4) - endif -c - 137 continue -c - return - end -c -************************************************************************ -c - subroutine hmltn1(h) -c this subroutine is used to specify a constant hamiltonian -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' - include 'extalk.inc' - include 'hmflag.inc' - dimension h(monoms) -c -c begin computation - iflag=0 - do 10 i=1,monoms - 10 h(i)=-fa(i) -c - return - end -c -******************************************************************** -c - subroutine lnf(p,fa,fm) -c this is a subroutine that takes the log of a map -c in normal form -c written by Alex Dragt 1/30/99 -c - use lieaparam, only : monoms - include 'impli.inc' -c - include 'files.inc' - include 'buffer.inc' -c -c Calling arrays - dimension p(6),fa(monoms),fm(6,6) -c -c Local arrays -c -c set up parameters -c - job=nint(p(1)) - iopt=nint(p(2)) - mult=nint(p(3)) -c -c compute exponent in the static case -c - if(job .eq. 1) then - call ident(buf1a,buf1m) -c horizontal plane f2 - cos = fm(1,1) - sin = fm(1,2) - ang = datan2(sin,cos) - buf1a(7) = -ang/2.d0 - buf1a(13) = -ang/2.d0 -c vertical plane f2 - cos = fm(3,3) - sin = fm(3,4) - ang = datan2(sin,cos) - buf1a(18) = -ang/2.d0 - buf1a(22) = -ang/2.d0 -c temporal plane f2 - endif -c -c compute exponent in the dynamic case -c - if(job .eq. 2) then - call ident(buf1a,buf1m) -c horizontal plane f2 - cos = fm(1,1) - sin = fm(1,2) - ang = datan2(sin,cos) - buf1a(7) = -ang/2.d0 - buf1a(13) = -ang/2.d0 -c vertical plane f2 - cos = fm(3,3) - sin = fm(3,4) - ang = datan2(sin,cos) - buf1a(18) = -ang/2.d0 - buf1a(22) = -ang/2.d0 -c temporal plane f2 - endif -c -c higher-order f's - if(iopt .eq. 2) then - do i=28,monoms - buf1a(i)=fa(i) - enddo - endif -c -c scale by (-1/pi) - if(mult .eq. 2) then - pi=4.d0*datan(1.d0) - scale=-1.d0/pi - call csmul(scale,buf1a,buf1a) - endif -c - return - end -c -*********************************************************************** -c - subroutine moma(p) -c this subroutine is for moment analysis -c - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'usrdat.inc' - include 'buffer.inc' - include 'fitdat.inc' -c - character*3 kynd -c Calling arrays - dimension p(6),fm(6,6),gm(6,6),hm(6,6) -cryne 8/9/2002 dimension ga(monoms5) -cryne 8/9/2002 dimension ha(monoms5) -cryne 8/9/2002 dimension t1a(monoms5) -cryne 8/9/2002 dimension t2a(monoms5) - dimension ga(monoms) - dimension ha(monoms) - dimension t1a(monoms) - dimension t2a(monoms) -c -c set up control indices - job=nint(p(1)) - isend=nint(p(2)) - ifile=nint(p(3)) - nopt=nint(p(4)) - nskip=nint(p(5)) - nmpo=nint(p(6)) -c -c procedure for reading in function or moments when job = 11,21, or 31: - if(job.eq.11 .or. job.eq.21 .or. job.eq.31) then -c test for file read or internal map fetch - if(ifile.lt.0) then - nmap=-ifile - call ident(ga,gm) - kynd='gtm' - call strget(kynd,nmap,ga,gm) - else - mpit=mpi - mpi=ifile - call mapin(nopt,nskip,ga,gm) - mpi=mpit - endif - endif -c -c procedure for reading in moments when job = 4,5, or 6: -c if (job.eq.4 .or. job.eq.5 .or. job.eq.6) then -c test for file read or internal map fetch -c if(ifile.lt.0) then -c nmap=-ifile -c kynd='gtm' -c call strget5(kynd,nmap,ga,gm) -c else -c mpit=mpi -c mpi=ifile -c call mapin5(nopt,nskip,ga,gm) -c mpi=mpit -c endif -c endif -c continue -c -c compute eigen emittances - if(job .eq. 11) call eigemt(2,ga) - if(job. eq. 21) call eigemt(4,ga) - if(job .eq. 31) call eigemt(6,ga) -c compute mean square eigen-emittances and put results in fitbuf - wex=buf1a(7)**2 - wey=buf1a(18)**2 - wet=buf1a(25)**2 -c -c write out results if desired -c code needs to be modified to write out eigen emittances - if (isend.eq.1.or.isend.eq.3) then - write (jof,*) 'xee2=',wex - write (jof,*) 'yee2=',wey - write (jof,*) 'tee2=',wet - endif - if (isend.eq.2.or.isend.eq.3) then - write (jodf,*) 'xee2=',wex - write (jodf,*) 'yee2=',wey - write (jodf,*) 'tee2=',wet - endif -c - return - end -c -*********************************************************************** -c - subroutine padd(p,ha,hm) -c this subroutine adds two polynomials -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' - include 'buffer.inc' - character*3 kynd -c - dimension p(6),ha(monoms),hm(6,6) -c - dimension fa(monoms),ga(monoms),ta(monoms) - dimension fm(6,6),gm(6,6),tm(6,6) -c -c set up control indices - nmapf=nint(p(1)) - nmapg=nint(p(2)) - nmaph=nint(p(3)) -c -c get maps and clear arrays - kynd='gtm' - if (nmapf.eq.0) call mapmap(ha,hm,fa,fm) - if (nmapf.ge.1 .and. nmapf.le.5) call strget(kynd,nmapf,fa,fm) - if (nmapg.eq.0) call mapmap(ha,hm,ga,gm) - if (nmapg.ge.1 .and. nmapg.le.5) call strget(kynd,nmapg,ga,gm) - call ident(ta,tm) -c -c perform calculation - call cpadd(fa,ga,ta) -c -c decide where to put results -c - if (nmaph.ge.1 .and. nmaph.le.5) then - kynd='stm' - call strget(kynd,nmaph,ta,tm) - endif -c - if (nmaph.eq.0) call mapmap(ta,tm,ha,hm) -c - if (nmaph.eq.-1) call mapmap(ta,tm,buf1a,buf1m) - if (nmaph.eq.-2) call mapmap(ta,tm,buf2a,buf2m) - if (nmaph.eq.-3) call mapmap(ta,tm,buf3a,buf3m) - if (nmaph.eq.-4) call mapmap(ta,tm,buf4a,buf4m) - if (nmaph.eq.-5) call mapmap(ta,tm,buf5a,buf5m) -c - return - end -c -******************************************************************** -c - subroutine pbpol(p,fa,fm) -c this subroutine poisson brackets two polynomials -c written 5/22/02 AJD - use lieaparam, only : monoms - include 'impli.inc' - include 'buffer.inc' - dimension p(6),fa(monoms),fm(6,6) - dimension ta(monoms),tm(6,6) - dimension t1a(monoms) - dimension t2a(monoms) - character*3 kynd -c - write (6,*) 'in subroutine pbpol' -c -c set up and test parameters - map1in=nint(p(1)) - map2in=nint(p(2)) - mapout=nint(p(3)) - if((map1in .lt. 0) .or. (map1in .gt. 9)) go to 100 - if((map2in .lt. 0) .or. (map2in .gt. 9)) go to 100 - if((mapout .lt. -6) .or. (mapout .gt. 9)) go to 100 -c -c get maps - if(map1in .eq. 0) then - call mapmap(fa,fm,t1a,tm) - else - kynd='gtm' - call strget(kynd,map1in,t1a,tm) - endif - if(map2in .eq. 0) then - call mapmap(fa,fm,t2a,tm) - else - kynd='gtm' - call strget(kynd,map2in,t2a,tm) - endif -c -c compute Poisson bracket - call mclear(tm) - call cppb(t1a,t2a,ta) -c -c deposit result and return - if(mapout .lt. 0) then - kbuf=-mapout - if(kbuf .eq. 1) call mapmap(ta,tm,buf1a,buf1m) - if(kbuf .eq. 2) call mapmap(ta,tm,buf2a,buf2m) - if(kbuf .eq. 3) call mapmap(ta,tm,buf3a,buf3m) - if(kbuf .eq. 4) call mapmap(ta,tm,buf4a,buf4m) - if(kbuf .eq. 5) call mapmap(ta,tm,buf5a,buf5m) - if(kbuf .eq. 6) call mapmap(ta,tm,buf6a,buf6m) - endif - if(mapout .eq. 0) call mapmap(ta,tm,fa,fm) - if(mapout .gt. 0) then - kynd='stm' - call strget(kynd,mapout,ta,tm) - endif - return -c - 100 continue -c error return - write(6,*) 'control parameters out of bounds in pbpol' - write(6,*)'map1in=',map1in - write(6,*)'map2in=',map2in - write(6,*)'mapout=',mapout - return - end -c -********************************************************************** -c - subroutine pdnf(p,ha,hm) -c this subroutine computes powers of a dynamic normal form -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - character*3 kynd -c - dimension p(6),ha(monoms),hm(6,6) -c - dimension fa(monoms),ta(monoms) - dimension fm(6,6),tm(6,6) -c -c set up control indices - jinopt=nint(p(1)) - if (jinopt.eq.1) pow=p(2) - if (jinopt.eq.2) npowf=nint(p(2)) - nmapi=nint(p(3)) - joutop=nint(p(4)) - nmapo=nint(p(5)) -c -c get map and clear arrays - kynd='gtm' - if (nmapi.eq.0) call mapmap(ha,hm,fa,fm) - if (nmapi.ge.1 .and. nmapi.le.5) call strget(kynd,nmapi,fa,fm) - call ident(ta,tm) -c -c perform calculation -c -c procedure when jinopt=1 - if (jinopt.eq.1) then - call cpdnf(pow,fa,fm,ta,tm) - call mapsnd(joutop,nmapo,ta,tm,ha,hm) - endif -c -c procedure when jinopt=2 - if (jinopt.eq.2) then -c -c procedure when npowf .lt. 0 - if (npowf.lt.0) then - do 10 k=1,6 - pow=0.d0 -c if (npowf.eq.-1) pow=pst1(k) -c if (npowf.eq.-2) pow=pst2(k) -c if (npowf.eq.-3) pow=pst3(k) -c if (npowf.eq.-4) pow=pst4(k) -c if (npowf.eq.-5) pow=pst5(k) - pow=pst(-npowf,k) - if (pow.ne.0.d0) then - call cpdnf(pow,fa,fm,ta,tm) - call mapsnd(joutop,nmapo,ta,tm,ha,hm) - endif - 10 continue - endif -c procedure when npowf .gt.0 - if (npowf.gt.0) then - 20 continue - read(npowf,*,end=30) pow - call cpdnf(pow,fa,fm,ta,tm) - call mapsnd(joutop,nmapo,ta,tm,ha,hm) - goto 20 - 30 continue - endif -c - endif -c - return - end -c -******************************************************************** -c - subroutine pmul(p,ha,hm) -c this subroutine multiplies two polynomials -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' - include 'buffer.inc' - character*3 kynd -c - dimension p(6),ha(monoms),hm(6,6) -c - dimension fa(monoms),ga(monoms),ta(monoms) - dimension fm(6,6),gm(6,6),tm(6,6) -c -c set up control indices - nmapf=nint(p(1)) - nmapg=nint(p(2)) - nmaph=nint(p(3)) -c -c get maps and clear arrays - kynd='gtm' - if (nmapf.eq.0) call mapmap(ha,hm,fa,fm) - if (nmapf.ge.1 .and. nmapf.le.5) call strget(kynd,nmapf,fa,fm) - if (nmapg.eq.0) call mapmap(ha,hm,ga,gm) - if (nmapg.ge.1 .and. nmapg.le.5) call strget(kynd,nmapg,ga,gm) - call ident(ta,tm) -c -c perform calculation - call cpmul(fa,ga,ta) -c -c decide where to put results -c - if (nmaph.ge.1 .and. nmaph.le.5) then - kynd='stm' - call strget(kynd,nmaph,ta,tm) - endif -c - if (nmaph.eq.0) call mapmap(ta,tm,ha,hm) -c - if (nmaph.eq.-1) call mapmap(ta,tm,buf1a,buf1m) - if (nmaph.eq.-2) call mapmap(ta,tm,buf2a,buf2m) - if (nmaph.eq.-3) call mapmap(ta,tm,buf3a,buf3m) - if (nmaph.eq.-4) call mapmap(ta,tm,buf4a,buf4m) - if (nmaph.eq.-5) call mapmap(ta,tm,buf5a,buf5m) -c - return - end -c -*********************************************************************** -c - subroutine pnlp(p,ga,gm) -c this subroutine raises the nonlinear part of a map to a power -c Written by Alex Dragt, Fall 1988 -c Fifth order by F. Neri (1989). -c - use lieaparam, only : monoms - include 'impli.inc' - include 'buffer.inc' - character*3 kynd -c -c Calling arrays - dimension p(6),ga(monoms),gm(6,6) -c -c Local arrays - dimension fa(monoms) - dimension fm(6,6) - dimension t5(461),t6(923),ff(monoms) -c -c set up scalar and control indices - iopt=nint(p(1)) - power=p(2) - nmapf=nint(p(3)) - nmapg=nint(p(4)) -c -c get map - if (nmapf.eq.0) call mapmap(ga,gm,fa,fm) - if (nmapf.ge.1 .and. nmapf.le.5) then - kynd='gtm' - call strget(kynd,nmapf,fa,fm) - endif -c -c perform calculation - if(iopt.eq.0) then - call mclear(fm) - do 10 i=1,6 - 10 fm(i,i)=1.d0 - endif - call csmul(power,fa,ff) -c -c f5 commutator: - call pbkt1(fa,3,fa,4,t5) - call pmadd(t5,5,(power*(1.d0-power)/2.d0),ff) -c f6 commutators: - call pbkt1(fa,3,t5,5,t6) - call pmadd(t6,6,(power-3.d0*power**2+2.d0*power**3)/12.d0,ff) - call pbkt1(fa,3,fa,5,t6) - call pmadd(t6,6,(power*(1.d0-power)/2.d0),ff) -c -c copy result back to fa: - call mapmap(ff,fm,fa,fm) -c -c decide where to put results -c - if (nmapg.ge.1 .and. nmapg.le.5) then - kynd='stm' - call strget(kynd,nmapg,fa,fm) - endif -c - if (nmapg.eq.0) call mapmap(fa,fm,ga,gm) -c - if (nmapg.eq.-1) call mapmap(fa,fm,buf1a,buf1m) - if (nmapg.eq.-2) call mapmap(fa,fm,buf2a,buf2m) - if (nmapg.eq.-3) call mapmap(fa,fm,buf3a,buf3m) - if (nmapg.eq.-4) call mapmap(fa,fm,buf4a,buf4m) - if (nmapg.eq.-5) call mapmap(fa,fm,buf5a,buf5m) -c - return - end -c -******************************************************************************** -c - subroutine pold(p,fa,fm) -c this is a subroutine for polar decomposition -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' -c - include 'files.inc' - include 'buffer.inc' -c - dimension p(6),fa(monoms),fm(6,6) -c - dimension ta(monoms) - dimension tm(6,6),rm(6,6),pdsm(6,6),revec(6,6) - dimension reval(6) -c -c set up control indices - mapin=nint(p(1)) - isend=nint(p(2)) - idata=nint(p(3)) - ipmaps=nint(p(4)) - iwmaps=nint(p(5)) -c -c write heading(s) -c -c begin calculation - call polr(fa,fm,rm,pdsm,reval,revec) -c put out data - call ident(ta,tm) -c -c put out maps -c -c put maps in buffers - call ident(ta,tm) - call mapmap(ta,pdsm,buf1a,buf1m) - call mapmap(ta,rm,buf2a,buf2m) - call mapmap(fa,tm,buf3a,buf3m) - do 10 i=1,6 - tm(i,i)=reval(i) - 10 continue - call mapmap(ta,tm,buf4a,buf4m) - call mapmap(ta,revec,buf5a,buf5m) -c -c write out maps -c - return - end -c -********************************************************************** -c - subroutine ppa(p,fa,fm) -c -c This routine computes focal lengths and principal planes for the -c current map. -c C. T. Mottershead LANL AT-3 / 2 Oct 89 -c--------------------------------------------------------------------- - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'fitdat.inc' - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c - isend = int(p(1)) - if(iquiet.eq.1) isend = 0 - eps = 1.e-9 -c -c x-plane -c - finv = fm(2,1) - if(abs(finv).lt.eps) finv = eps - f = -1.0/finv - z2 = f*(1.0 - fm(1,1)) - z1 = f*(1.0 - fm(2,2)) - fx = f - xb = z1 - xa = z2 - xu = f - z1 - xd = f - z2 -c -c y-plane -c - finv = fm(4,3) - if(abs(finv).lt.eps) finv = eps - f = -1.0/finv - z2 = f*(1.0 - fm(3,3)) - z1 = f*(1.0 - fm(4,4)) - fy = f - yb = z1 - ya = z2 - yu = f - z1 - yd = f - z2 -c -c print the matrix and focal lengths -c - if(isend.lt.2) go to 400 - lun = jodf - 300 continue - write(lun,17) fx,fy - 17 format(' * PPA Focal lengths : fx =',1pg15.7,' fy =',1pg15.7) - write(lun,33) - 33 format(' * Principal Planes (before and after):') - write(lun,37) xb,xa,yb,ya - 37 format(1x,' xb=',1pg15.7,' xa=',1pg15.7,' yb=',1pg15.7,' ya=', - & 1pg15.7) - write(lun,27) xu,yu - 27 format(' * Focal points (upstream): xu =',1pg15.7, - & ' yu =',1pg15.7) - write(lun,29) xd,yd - 29 format(' (downstream): xd =',1pg15.7, - & ' yd =',1pg15.7) - 400 if((isend.eq.1).or.(isend.eq.3)) then - lun = jof - isend = 0 - go to 300 - endif -c - return - end -c -********************************************************************** -c - subroutine psnf(p,ha,hm) -c this subroutine computes powers of a static normal form -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - character*3 kynd -c - dimension p(6),ha(monoms),hm(6,6) -c - dimension fa(monoms),ta(monoms) - dimension fm(6,6),tm(6,6) -c -c set up control indices - jinopt=nint(p(1)) - if (jinopt.eq.1) pow=p(2) - if (jinopt.eq.2) npowf=nint(p(2)) - nmapi=nint(p(3)) - joutop=nint(p(4)) - nmapo=nint(p(5)) -c -c get map and clear arrays - kynd='gtm' - if (nmapi.eq.0) call mapmap(ha,hm,fa,fm) - if (nmapi.ge.1 .and. nmapi.le.5) call strget(kynd,nmapi,fa,fm) - call ident(ta,tm) -c -c perform calculation -c -c procedure when jinopt=1 - if (jinopt.eq.1) then - call cpsnf(pow,fa,fm,ta,tm) - call mapsnd(joutop,nmapo,ta,tm,ha,hm) - endif -c -c procedure when jinopt=2 - if (jinopt.eq.2) then -c -c procedure when npowf .lt. 0 - if (npowf.lt.0) then - do 10 k=1,6 - pow=0.d0 -c if (npowf.eq.-1) pow=pst1(k) -c if (npowf.eq.-2) pow=pst2(k) -c if (npowf.eq.-3) pow=pst3(k) -c if (npowf.eq.-4) pow=pst4(k) -c if (npowf.eq.-5) pow=pst5(k) - pow = pst(-npowf,k) - if (pow.ne.0.d0) then - call cpsnf(pow,fa,fm,ta,tm) - call mapsnd(joutop,nmapo,ta,tm,ha,hm) - endif - 10 continue - endif -c procedure when npowf .gt.0 - if (npowf.gt.0) then - 20 continue - read(npowf,*,end=30) pow - call cpsnf(pow,fa,fm,ta,tm) - call mapsnd(joutop,nmapo,ta,tm,ha,hm) - goto 20 - 30 continue - endif -c - endif -c - return - end -c -*********************************************************************** -c - subroutine psp(p,ha,hm) -c this subroutine computes the scalar product of two polynomials -c Written by Alex Dragt, 10/23/89 -c - use lieaparam, only : monoms - include 'impli.inc' - include 'buffer.inc' - include 'usrdat.inc' -c - character*3 kynd -c Calling arrays - dimension p(6),ha(monoms),hm(6,6) -c -c Local arrays - dimension fa(monoms),ga(monoms) - dimension tm(6,6) -c -c set up control indices - job=nint(p(1)) - nmapf=nint(p(2)) - nmapg=nint(p(3)) - isend=nint(p(4)) -c -c clear arrays and get maps - if (nmapf.eq.0) call mapmap(ha,hm,fa,tm) - if (nmapf.ge.1 .and. nmapf.le.9) then - kynd='gtm' - call strget(kynd,nmapf,fa,tm) - endif - if (nmapg.eq.0) call mapmap(ha,hm,ga,tm) - if (nmapg.ge.1 .and. nmapg.le.9) then - kynd='gtm' - call strget(kynd,nmapg,ga,tm) - endif -c -c perform calculation - call cpsp(job,fa,ga,ans1,ans2,ans3,ans4) -ccccc call old_cpsp(fa,ga,ans1,ans2,ans3,ans4) -c -c decide where to send and put results -c -c write(6,*) ' ans1=',ans1,' ans2=',ans2 -c write(6,*) ' ans3=',ans3,' ans4=',ans4 - write(6,"('ans1234=',4(1pe15.8,1x))")ans1,ans2,ans3,ans4 - ucalc(141)=ans1 - ucalc(142)=ans2 - ucalc(143)=ans3 - ucalc(144)=ans4 - ucalc(145)=ans1+ans2+ans3+ans4 -c - return - end -c -******************************************************************** -c - subroutine pval(p,ga,gm) -c this is a routine for evaluating a polynomial -c Written by Alex Dragt, Spring 1987 - use rays - use lieaparam, only : monoms - include 'impli.inc' -c - include 'files.inc' - include 'parset.inc' - character*3 kynd -c - dimension p(6),ga(monoms),gm(6,6) -c - dimension fa(monoms),fm(6,6) - dimension zit(6) -c -c set up control indices - mapin=nint(p(1)) - idata=nint(p(2)) - iwnum=nint(p(3)) -c -c get polynomial -c - if (mapin.eq.0) call mapmap(ga,gm,fa,fm) - if (mapin.ge.1 .and. mapin.le.5) then - kynd='gtm' - call strget(kynd,mapin,fa,fm) - endif -c -c compute value(s) of polynomial and write them out -c - if (iwnum.gt.0) then - write(jof,*) - write(jof,*) 'value(s) of polymomial written on file ',iwnum -c -c procedure when idata > 0 - if (idata.gt.0) then - ipset=idata -c get phase space data from the parameter set ipset -c -c do 5 i=1,6 -c 5 zit(i)=0.d0 -c goto (10,20,30,40,50),ipset -c goto 60 -c 10 do 11 i=1,6 -c 11 zit(i)=pst1(i) -c goto 60 -c 20 do 21 i=1,6 -c 21 zit(i)=pst2(i) -c goto 60 -c 30 do 31 i=1,6 -c 31 zit(i)=pst3(i) -c goto 60 -c 40 do 41 i=1,6 -c 41 zit(i)=pst4(i) -c goto 60 -c 50 do 51 i=1,6 -c 51 zit(i)=pst5(i) -c 60 continue - if(ipset.lt.1 .or. ipset.gt.maxpst) then - do 50 i=1,6 - 50 zit(i) = 0.0d0 - else - do 60 i=1,6 - 60 zit(i) = pst(ipset,i) - endif -c carry out computation - call evalf(zit,fa,val2,val3,val4) - k=1 - write(iwnum,100) k,val2,val3,val4,0.,0. - 100 format(1x,i12,5(1x,1pe12.5)) - endif -c -c procedure when idata = 0 - if (idata.eq.0) then - do 70 k=1,nraysp -c check on status of k'th ray; skip this ray if its status is 'lost' - if (istat(k).ne.0) goto 70 - do 80 j=1,6 - 80 zit(j)=zblock(j,k) - call evalf(zit,fa,val2,val3,val4) - write(iwnum,100) k,val2,val3,val4,0.,0. - 70 continue - endif -c - endif -c - return - end -c -********************************************************************** -c - subroutine radm(p,fa,fm) -c this is a subroutine for resonance analysis of dynamic maps -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'buffer.inc' -c - dimension p(6),fa(monoms),fm(6,6) -c - dimension ta(monoms),t1a(monoms),t2a(monoms) - dimension tm(6,6),t1m(6,6),t2m(6,6) - dimension look(3),pmask(6) -c -c set up control indices - iopt=nint(p(1)) - i2=nint(p(2)) - i3=nint(p(3)) - i4=nint(p(4)) - iwmaps=nint(p(5)) -c -c compute isend - do 10 j=1,3 - look(j)=0 - if (i2.eq.j .or. i3.eq.j .or. i4.eq.j) look(j)=1 - 10 continue - isend=0 - if (look(1).eq.1) isend=1 - if (look(2).eq.1) isend=2 - if (look(1).eq.1 .and. look(2).eq.1) isend=3 - if (look(3).eq.1) isend=3 -c -c write headings - if (isend.eq.1 .or. isend.eq.3) then - write(jof,*) - write(jof,*) 'resonance analysis of dynamic map' - endif - if (isend.eq.2 .or. isend.eq.3) then - write(jodf,*) - write(jodf,*) 'resonance analysis of dynamic map' - endif -c -c beginning of calculation -c -c remove offensive terms from matrix part of map: - call dpur2(fa,fm,buf2a,buf2m,ta,tm) -c -c procedure for removing third order terms - if(iopt.eq.1) then - if (isend.eq.1 .or. isend.eq.3) then - write (jof,*) - write (jof,*) 'third order terms removed' - endif - if (isend.eq.2 .or. isend.eq.3) then - write (jodf,*) - write (jodf,*) 'third order terms removed' - endif - call dpur3(buf2a,buf2m,buf3a,buf3m,t1a,t1m) -c accumulate transforming map - call concat(t1a,t1m,ta,tm,t2a,t2m) -c put maps in proper places - call mapmap(buf3a,buf3m,buf2a,buf2m) - call mapmap(t2a,t2m,ta,tm) - endif -c -c resonance decompose purified map: - call matmat(buf2m,buf3m) - call ctodr(buf2a,buf3a) -c -c procedure for writing resonance driving terms at terminal (file jof) - if (isend.eq.1 .or. isend.eq.3) then - call mapmap(buf3a,buf3m,buf4a,buf4m) -c compute masking parameters pmask(j) - pmask(1)=1. - pmask(2)=0. - pmask(3)=0. - pmask(4)=0. - if (i2.eq.1 .or. i2.eq.3) pmask(2)=1. - if (i3.eq.1 .or. i3.eq.3) pmask(3)=1. - if (i4.eq.1 .or. i4.eq.3) pmask(4)=1. -c mask of unwanted portions of buf4a - call mask(pmask,buf4a,buf4m) -c display result in sr basis - write(jof,*) - write(jof,*) 'requested resonance driving terms written as a map' - call pdrmap(0,1,buf4a,buf4m) - endif -c -c procedure for writing resonance driving terms on external file -c (file jodf) - if (isend.eq.2 .or. isend.eq.3) then - call mapmap(buf3a,buf3m,buf4a,buf4m) -c compute masking parameters pmask(j) - pmask(1)=1. - pmask(2)=0. - pmask(3)=0. - pmask(4)=0. - if (i2.eq.2 .or. i2.eq.3) pmask(2)=1. - if (i3.eq.2 .or. i3.eq.3) pmask(3)=1. - if (i4.eq.2 .or. i4.eq.3) pmask(4)=1. -c mask of unwanted portions of buf4a - call mask(pmask,buf4a,buf4m) -c display result in sr basis - write(jodf,*) - write(jodf,*) 'requested resonance driving terms written as a map' - call pdrmap(0,2,buf4a,buf4m) - endif -c -c procedure for writing out maps - if (iwmaps.gt.0) then - mpot=mpo - mpo=iwmaps - call mapout(0,ta,tm) - call mapout(0,buf2a,buf2m) - call mapout(0,buf3a,buf3m) - mpo=mpot - endif -c -c put maps in buffers -c put the transforming map in buffer 1 - call mapmap(ta,tm,buf1a,buf1m) -c buffers 2 and 3 already contain the purified map in the cartesian -c and dynamic resonance bases, respectively -c clear the remaining buffers - call clear(buf4a,buf4m) - call clear(buf5a,buf5m) -c - return - end -c -*********************************************************************** -c - subroutine rasm(p,fa,fm) -c this is a subroutine for resonance analysis of static maps -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' -c - include 'files.inc' - include 'buffer.inc' -c - dimension p(6),fa(monoms),fm(6,6) -c - dimension ta(monoms),t1a(monoms),t2a(monoms) - dimension tm(6,6),t1m(6,6),t2m(6,6) - dimension look(3),pmask(6) - -c -c set up control indices - iopt=nint(p(1)) - i2=nint(p(2)) - i3=nint(p(3)) - i4=nint(p(4)) - iwmaps=nint(p(5)) -c -c compute isend - do 10 j=1,3 - look(j)=0 - if (i2.eq.j .or. i3.eq.j .or. i4.eq.j) look(j)=1 - 10 continue - isend=0 - if (look(1).eq.1) isend=1 - if (look(2).eq.1) isend=2 - if (look(1).eq.1 .and. look(2).eq.1) isend=3 - if (look(3).eq.1) isend=3 -c -c write headings - if (isend.eq.1 .or. isend.eq.3) then - write(jof,*) - write(jof,*) 'resonance analysis of static map' - endif - if (isend.eq.2 .or. isend.eq.3) then - write(jodf,*) - write(jodf,*) 'resonance analysis of static map' - endif -c -c beginning of calculation -c -c remove offensive terms from matrix part of map: - call spur2(fa,fm,buf2a,buf2m,ta,tm,t2m) -c -c procedure for removing third order terms - if(iopt.eq.1) then - if (isend.eq.1 .or. isend.eq.3) then - write (jof,*) - write (jof,*) 'third order terms removed' - endif - if (isend.eq.2 .or. isend.eq.3) then - write (jodf,*) - write (jodf,*) 'third order terms removed' - endif -c remove offensive chromatic terms from f3 part of map: - call scpur3(buf2a,buf2m,buf3a,buf3m,t1a,t1m) -c accumulate transforming map - call concat(t1a,t1m,ta,tm,t2a,t2m) -c remove offensive geometric terms from f3 part of map: - call sgpur3(buf3a,buf3m,buf2a,buf2m,t1a,t1m) -c accumulate transforming map - call concat(t1a,t1m,t2a,t2m,ta,tm) - endif -c -c resonance decompose purified map: - call matmat(buf2m,buf3m) - call ctosr(buf2a,buf3a) -c -c procedure for writing resonance driving terms at terminal (file jof) - if (isend.eq.1 .or. isend.eq.3) then - call mapmap(buf3a,buf3m,buf4a,buf4m) -c compute masking parameters pmask(j) - pmask(1)=1. - pmask(2)=0. - pmask(3)=0. - pmask(4)=0. - if (i2.eq.1 .or. i2.eq.3) pmask(2)=1. - if (i3.eq.1 .or. i3.eq.3) pmask(3)=1. - if (i4.eq.1 .or. i4.eq.3) pmask(4)=1. -c mask of unwanted portions of buf4a - call mask(pmask,buf4a,buf4m) -c display result in sr basis - write(jof,*) - write(jof,*) 'requested resonance driving terms written as a map' - call psrmap(0,1,buf4a,buf4m) - endif -c -c procedure for writing resonance driving terms on external file (file jodf) - if (isend.eq.2 .or. isend.eq.3) then - call mapmap(buf3a,buf3m,buf4a,buf4m) -c compute masking parameters pmask(j) - pmask(1)=1. - pmask(2)=0. - pmask(3)=0. - pmask(4)=0. - if (i2.eq.2 .or. i2.eq.3) pmask(2)=1. - if (i3.eq.2 .or. i3.eq.3) pmask(3)=1. - if (i4.eq.2 .or. i4.eq.3) pmask(4)=1. -c mask of unwanted portions of buf4a - call mask(pmask,buf4a,buf4m) -c display result in sr basis - write(jodf,*) - write(jodf,*) 'requested resonance driving terms written as a map' - call psrmap(0,2,buf4a,buf4m) - endif -c -c procedure for writing out maps - if (iwmaps.gt.0) then - mpot=mpo - mpo=iwmaps - call mapout(0,ta,tm) - call mapout(0,buf2a,buf2m) - call mapout(0,buf3a,buf3m) - mpo=mpot - endif -c -c put maps in buffers -c put the transforming map in buffer 1 - call mapmap(ta,tm,buf1a,buf1m) -c buffers 2 and 3 already contain the purified map in the cartesian -c and static resonance bases, respectively -c clear the remaining buffers - call clear(buf4a,buf4m) - call clear(buf5a,buf5m) -c - return - end -c -*********************************************************************** -c - subroutine sia(p,fa,fm) -c this is a routine for computing invariants in the static case -c Written by Alex Dragt, Spring 1987 - use rays - use lieaparam, only : monoms - include 'impli.inc' -c - include 'files.inc' - include 'buffer.inc' -c - dimension p(6),fa(monoms),fm(6,6) -c - dimension ga(monoms),g1a(monoms) - dimension ta(monoms),t1a(monoms),t2a(monoms) - dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6),t2m(6,6) -c -c set up control indices - iopt=nint(p(1)) - idata=nint(p(2)) - ipmaps=nint(p(3)) - isend=nint(p(4)) - iwmaps=nint(p(5)) - iwnum=nint(p(6)) -c -c write headings - if (isend.eq.1 .or. isend.eq.3) then - write (jof,*) - write (jof,*) 'static invariant analysis' - endif - if (isend.eq.2 .or. isend.eq.3) then - write (jodf,*) - write (jodf,*) 'static invariant analysis' - endif -c -c begin calculation -c -c find the transforming (conjugating) map script A -c remove offensive terms from matrix part of map: - call spur2(fa,fm,ga,gm,t1a,t1m,t2m) -c remove offensive chromatic terms from f3 part of map: - call scpur3(ga,gm,g1a,g1m,t2a,t2m) -c accumulate transforming map: - call concat(t2a,t2m,t1a,t1m,ta,tm) -c remove offensive geometric terms from f3 part of map: - call sgpur3(g1a,g1m,ga,gm,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,ta,tm,t2a,t2m) -c remove offensive terms from f4 part of map: - call spur4(ga,gm,g1a,g1m,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,t2a,t2m,ta,tm) -c put script A in buffer 1 and script N in buffer 2 - call mapmap(ta,tm,buf1a,buf1m) - call mapmap(g1a,g1m,buf2a,buf2m) -c -c procedure for computing invariant -c invert script A - call inv(ta,tm) - call clear(t1a,t1m) -c computation of x invariant - if(iopt.eq.1) then - t1a(7)=1.d0 - t1a(13)=1.d0 - endif -c computation of y invariant - if(iopt.eq.2) then - t1a(18)=1.d0 - t1a(22)=1.d0 - endif -c computation of mixed invariant - if(iopt.ge.3) then - read(iopt,*) anx,any - if (isend.eq.1 .or. isend.eq.3) then - write(jof,*) 'parameters read in from file',iopt - endif - if (isend.eq.2 .or. isend.eq.3) then - write(jof,*) 'parameters read in from file',iopt - endif - t1a(7)=anx - t1a(13)=anx - t1a(18)=any - t1a(22)=any - endif -c put invariant in buffer 3 - call ident(buf3a,buf3m) - call fxform(ta,tm,t1a,buf3a) -c -c procedure for putting out data - if (idata.eq.1 .or. idata.eq.3) then - do 10 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 10 - write(ifile,*) - write(ifile,*) 'invariant polynomial' - call pcmap(0,j,0,0,buf3a,buf3m) - 10 continue - endif - if (idata.eq.2 .or. idata.eq.3) then - mpot=mpo - mpo=18 - call mapout(0,buf3a,buf3m) - mpo=mpot - endif -c -c procedure for printing out maps - do 20 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 20 - if (ipmaps.eq.1 .or. ipmaps.eq.3) then - write(ifile,*) - write(ifile,*) 'normalizing map script A' - call pcmap(j,j,0,0,buf1a,buf1m) - endif - if (ipmaps.eq.2 .or. ipmaps.eq.3) then - write(ifile,*) - write(ifile,*) 'normal form map script N' - call pcmap(j,j,0,0,buf2a,buf2m) - endif - 20 continue -c -c procedure for writing out maps - if (iwmaps.gt.0) then - mpot=mpo - mpo=iwmaps - call mapout(0,buf1a,buf1m) - call mapout(0,buf2a,buf2m) - call mapout(0,buf3a,buf3m) - mpo=mpot - endif -c -c procedure for computing values of invariant and writing them out - if (iwnum.gt.0) then - write(jof,*) - write(jof,*) 'values of invariant written on file ',iwnum - do 30 k=1,nraysp - do 40 j=1,6 - 40 zi(j)=zblock(j,k) - call evalf(zi,buf3a,val2,val3,val4) - write(iwnum,60) k,val2,val3,val4,0.,0. - 60 format(1x,i12,5(1x,1pe12.5)) - 30 continue - endif -c -c put maps in buffers -c buffers 1 and 2 already contain the transforming map script A -c and the normal form map script N, respectively. -c buffer 3 contains the map which has for its matrix the identity -c matrix and for its array the invariant polynomial. -c clear buffers 4 and 5 - call clear(buf4a,buf4m) - call clear(buf5a,buf5m) -c - return - end -c -*********************************************************************** -c - subroutine smul(p,ga,gm) -c this subroutine multiplies a polynomial by a scalar -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' - include 'buffer.inc' - character*3 kynd -c - dimension p(6),ga(monoms),gm(6,6) -c - dimension fa(monoms),ta(monoms) - dimension fm(6,6),tm(6,6) -c -c set up scalar and control indices - scalar=p(1) - nmapf=nint(p(2)) - nmapg=nint(p(3)) -c -c get map and clear arrays - if (nmapf.eq.0) call mapmap(ga,gm,fa,fm) - if (nmapf.ge.1 .and. nmapf.le.5) then - kynd='gtm' - call strget(kynd,nmapf,fa,fm) - endif - call clear(ta,tm) -c -c perform calculation - call csmul(scalar,fa,ta) -c -c decide where to put results -c - if (nmapg.ge.1 .and. nmapg.le.5) then - kynd='stm' - call strget(kynd,nmapg,ta,tm) - endif -c - if (nmapg.eq.0) call mapmap(ta,tm,ga,gm) -c - if (nmapg.eq.-1) call mapmap(ta,tm,buf1a,buf1m) - if (nmapg.eq.-2) call mapmap(ta,tm,buf2a,buf2m) - if (nmapg.eq.-3) call mapmap(ta,tm,buf3a,buf3m) - if (nmapg.eq.-4) call mapmap(ta,tm,buf4a,buf4m) - if (nmapg.eq.-5) call mapmap(ta,tm,buf5a,buf5m) -c - return - end -c -*********************************************************************** -c - subroutine snor_old(p,fa,fm) -c this is a subroutine for normal form analysis of static maps -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' -c - include 'files.inc' - include 'buffer.inc' -c - dimension p(6),fa(monoms),fm(6,6) -c - dimension ga(monoms),g1a(monoms) - dimension ta(monoms),t1a(monoms),t2a(monoms) - dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6),t2m(6,6) -c -c set up control indices - idata=nint(p(1)) - ipmaps=nint(p(2)) - isend=nint(p(3)) - iwmaps=nint(p(4)) -c -c write headings - if (isend.eq.1 .or. isend.eq.3) then - write (jof,*) - write (jof,*) 'static normal form analysis' - endif - if (isend.eq.2 .or. isend.eq.3) then - write (jodf,*) - write (jodf,*) 'static normal form analysis' - endif -c -c begin calculation -c -c remove offensive terms from matrix part of map: - call spur2(fa,fm,ga,gm,t1a,t1m,t2m) -c remove offensive chromatic terms from f3 part of map: - call scpur3(ga,gm,g1a,g1m,t2a,t2m) -c accumulate transforming map: - call concat(t2a,t2m,t1a,t1m,ta,tm) -c remove offensive geometric terms from f3 part of map: - call sgpur3(g1a,g1m,ga,gm,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,ta,tm,t2a,t2m) -c remove offensive terms from f4 part of map: - call spur4(ga,gm,g1a,g1m,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,t2a,t2m,ta,tm) -c put transforming map in buffer 1 - call mapmap(ta,tm,buf1a,buf1m) -c put transformed map in buffer 2 - call mapmap(g1a,g1m,buf2a,buf2m) -c -c procedure for computing normal form exponent and pseudo hamiltonian - call ident(buf3a,buf3m) - if (idata.eq.1 .or. idata.eq.2 .or. idata.eq.3) then -c compute phase advances - cwx=g1m(1,1) - swx=g1m(1,2) - wx=atan2(swx,cwx) - cwy=g1m(3,3) - swy=g1m(3,4) - wy=atan2(swy,cwy) -c compute momentum compaction - wt=g1m(5,6) -c set up normal form for exponent - do 10 i=1,27 - 10 g1a(i)=0. - g1a(7)=-wx/2.d0 - g1a(13)=-wx/2.d0 - g1a(18)=-wy/2.d0 - g1a(22)=-wy/2.d0 - g1a(27)=-wt/2.d0 - endif -c transform exponent to get pseudo hamiltonian - if (idata.eq.2 .or.idata.eq.3) then - call inv(ta,tm) - call fxform(ta,tm,g1a,ga) -c store results in buffer 3 - call mapmap(ga,buf3m,buf3a,buf3m) - endif -c -c procedure for putting out data - do 20 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 20 - if (idata.eq.1 .or. idata.eq.3) then - write(ifile,*) - write(ifile,*) 'exponent for normal form' - call pcmap(0,j,0,0,g1a,g1m) - endif - if (idata.eq.2. .or. idata.eq.3) then - write(ifile,*) - write(ifile,*) 'pseudo hamiltonian' - call pcmap(0,j,0,0,buf3a,buf3m) - endif - 20 continue -c -c procedure for printing out maps - do 30 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 30 - if (ipmaps.eq.1 .or. ipmaps.eq.3) then - write(ifile,*) - write(ifile,*) 'normalizing map script A' - call pcmap(j,j,0,0,buf1a,buf1m) - endif - if (ipmaps.eq.2. .or. ipmaps.eq.3) then - write(ifile,*) - write(ifile,*) 'normal form script N for transfer map' - call pcmap(j,j,0,0,buf2a,buf2m) - endif - 30 continue -c -c procedure for writing out maps - if (iwmaps.gt.0) then - mpot=mpo - mpo=iwmaps - call mapout(0,buf1a,buf1m) - call mapout(0,buf2a,buf2m) - call mapout(0,buf3a,buf3m) - mpo=mpot - endif -c -c put maps in buffers -c buffers 1 and 2 already contain the transforming map script A -c and the normal form map script N, respectively. -c buffer 3 contains the map which has for its matrix the identity -c matrix and for its array the pseudo hamiltonian. -c clear buffers 4 and 5 - call clear(buf4a,buf4m) - call clear(buf5a,buf5m) -c - return - end -c -*********************************************************************** -c - subroutine snor(p,fa,fm) -c this is a subroutine for normal form analysis of static maps -c Written by Alex Dragt, Spring 1987 -c Modified 20 June 1988 -c - use parallel, only : idproc - use lieaparam, only : monoms - include 'impli.inc' -c - include 'files.inc' - include 'buffer.inc' -c -c Calling arrays - dimension p(6),fa(monoms),fm(6,6) -c -c Local arrays - dimension ga(monoms),g1a(monoms) - dimension ta(monoms),t1a(monoms) - dimension gm(6,6),g1m(6,6) - dimension tm(6,6),t1m(6,6) -c -c set up control indices - keep= nint(p(1)) - idata= nint(p(2)) - ipmaps=nint(p(3)) - isend= nint(p(4)) - iwmaps=nint(p(5)) -c -c write headings - if ((isend.eq.1 .or. isend.eq.3) .and. idproc.eq.0) then - write (jof,*) - write (jof,*) 'static normal form analysis' - endif - if ((isend.eq.2 .or. isend.eq.3) .and. idproc.eq.0) then - write (jodf,*) - write (jodf,*) 'static normal form analysis' - endif -c -c begin calculation -c -c remove offensive terms from matrix part of map: - call spur2(fa,fm,ga,gm,ta,tm,t1m) -c remove offensive chromatic terms from f3 part of map: - call scpur3(ga,gm,g1a,g1m,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,ta,tm,ta,tm) -c remove offensive geometric terms from f3 part of map: - call sgpur3(g1a,g1m,ga,gm,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,ta,tm,ta,tm) -c remove offensive terms from f4 part of map: - call spur4(ga,gm,g1a,g1m,t1a,t1m) -c accumulate transforming map: - call concat(t1a,t1m,ta,tm,ta,tm) -c put transforming map in buffer 1 - call mapmap(ta,tm,buf1a,buf1m) -c put transformed map in buffer 2 - call mapmap(g1a,g1m,buf2a,buf2m) -c -c procedure for computing normal form exponent and pseudo hamiltonian - call ident(buf3a,buf3m) - if (idata.eq.1 .or. idata.eq.2 .or. idata.eq.3) then -c compute phase advances - cwx=g1m(1,1) - swx=g1m(1,2) - wx=atan2(swx,cwx) - cwy=g1m(3,3) - swy=g1m(3,4) - wy=atan2(swy,cwy) -c compute momentum compaction - wt=g1m(5,6) -c set up normal form for exponent - do 10 i=1,27 - 10 g1a(i)=0. - g1a(7)=-wx/2.d0 - g1a(13)=-wx/2.d0 - g1a(18)=-wy/2.d0 - g1a(22)=-wy/2.d0 - g1a(27)=-wt/2.d0 - endif -c transform exponent to get pseudo hamiltonian - if (idata.eq.2 .or.idata.eq.3) then - call inv(ta,tm) - call fxform(ta,tm,g1a,ga) -c store results in buffer 3 - call mapmap(ga,buf3m,buf3a,buf3m) - endif -c -c procedure for putting out data - do 20 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 20 - if (idata.eq.1 .or. idata.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'exponent for normal form' - call pcmap(0,j,0,0,g1a,g1m) - endif - if (idata.eq.2. .or. idata.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'pseudo hamiltonian' - call pcmap(0,j,0,0,buf3a,buf3m) - endif - 20 continue -c -c procedure for printing out maps - do 30 j=1,2 - ifile=0 - if (j.eq.1) then - if (isend.eq.1 .or. isend.eq.3) ifile=jof - endif - if (j.eq.2) then - if (isend.eq.2 .or. isend.eq.3) ifile=jodf - endif - if (ifile.eq.0) goto 30 - if (ipmaps.eq.1 .or. ipmaps.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'normalizing map script A' - call pcmap(j,j,0,0,buf1a,buf1m) - endif - if (ipmaps.eq.2. .or. ipmaps.eq.3) then - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0) - &write(ifile,*) 'normal form script N for transfer map' - call pcmap(j,j,0,0,buf2a,buf2m) - endif - 30 continue -c -c procedure for writing out maps - if (iwmaps.gt.0) then - mpot=mpo - mpo=iwmaps - call mapout(0,buf1a,buf1m) - call mapout(0,buf2a,buf2m) - call mapout(0,buf3a,buf3m) - mpo=mpot - endif -c -c put maps in buffers -c buffers 1 and 2 already contain the transforming map script A -c and the normal form map script N, respectively. -c buffer 3 contains the map which has for its matrix the identity -c matrix and for its array the pseudo hamiltonian. -c clear buffers 4 and 5 - call clear(buf4a,buf4m) - call clear(buf5a,buf5m) -c - return - end -c -c -*********************************************************************** -c - subroutine submn(p,ha,hm) -c This subroutine computes the norm of a matrix -c Written by Alex Dragt, 10/20/90 -c - use parallel, only : idproc - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' -c -c Calling arrays - dimension p(6),ha(monoms),hm(6,6) -c -c Local arrays - dimension tm(6,6) -c -c set up control indices - iopt=nint(p(1)) - isend=nint(p(2)) -c -c copy matrix - call matmat(hm,tm) -c -c perform calculation -c -c modify matrix if required - if (iopt .eq. 1) then - do 10 i=1,6 - 10 tm(i,i) = tm(i,i) -1.d0 - endif -c -c compute norm - call mnorm(tm,ans) -c -c decide where to send and put results -c - if(idproc.eq.0)write(6,*) ' matrix norm = ',ans -c - return - end -c -*********************************************************************** -c - subroutine tadm(p,fa,fm) -c this is a subroutine for twiss analysis of dynamic maps -c Written by Alex Dragt, Spring 1987 -c this program will eventually have to be rewritten to improve the -c output data and its format - use parallel, only : idproc - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'buffer.inc' -c - dimension p(6),fa(monoms),fm(6,6) -c - dimension ga(monoms),g1a(monoms) - dimension ta(monoms),t1a(monoms),t2a(monoms) - dimension gm(6,6),g1m(6,6),tm(6,6),t1m(6,6),t2m(6,6) -c -c set up control indices - idata=nint(p(1)) - ipmaps=nint(p(2)) - isend=nint(p(3)) - iwmaps=nint(p(4)) -c -c write headings - if ((isend.eq.1 .or. isend.eq.3) .and. idproc.eq.0) then - write(jof,*) - write(jof,*) 'twiss analysis of dynamic map' - endif - if ((isend.eq.2 .or. isend.eq.3) .and. idproc.eq.0) then - write(jodf,*) - write(jodf,*) 'twiss analysis of dynamic map' - endif -c -c beginning of calculation -c remove offensive terms from matrix part of map: - call dpur2(fa,fm,ga,gm,ta,tm) -c store purifying map script A2 in buffer 1 - call mapmap(ta,tm,buf1a,buf1m) -c -c compute tunes: - cwx=gm(1,1) - swx=gm(1,2) - cwy=gm(3,3) - swy=gm(3,4) - cwt=gm(5,5) - swt=gm(5,6) - pi=4.*atan(1.d0) - wx=atan2(swx,cwx) - if (wx.lt.0.) wx=wx+2.*pi - wy=atan2(swy,cwy) - if (wy.lt.0.) wy=wy+2.*pi - wt=atan2(swt,cwt) -c if (wt.lt.0.) wt=wt+2.*pi - tnx=wx/(2.*pi) - tny=wy/(2.*pi) - tnt=wt/(2.*pi) -c -c remove f3 part of map: - call dpur3(ga,gm,g1a,g1m,t1a,t1m) -c accumulate transforming map - call concat(t1a,t1m,ta,tm,t2a,t2m) -c resonance decompose purified map: - call ctodr(g1a,ga) -c -c compute dependence of tune on betatron amplitude: - hh=ga(84) - vv=ga(85) - tt=ga(86) - hv=ga(87) - ht=ga(88) - vt=ga(89) - hhn=-2.d0*hh/pi - vvn=-2.d0*vv/pi - ttn=-2.d0*tt/pi - hvn=-hv/pi - htn=-ht/pi - vtn=-vt/pi -c -c remove f4 part of map - call dpur4(g1a,g1m,ga,gm,t1a,t1m) -c accumulate transforming map - call concat(t1a,t1m,t2a,t2m,ta,tm) -c -c compute envelopes and twiss parameters -c use the map in buffer 1 - call mapmap(buf1a,buf1m,t1a,t1m) -c compute envelopes - exh2=t1m(1,1)**2+t1m(1,2)**2 - exv2=t1m(1,3)**2+t1m(1,4)**2 - ext2=t1m(1,5)**2+t1m(1,6)**2 - epxh2=t1m(2,1)**2+t1m(2,2)**2 - epxv2=t1m(2,3)**2+t1m(2,4)**2 - epxt2=t1m(2,5)**2+t1m(2,6)**2 - eyh2=t1m(3,1)**2+t1m(3,2)**2 - eyv2=t1m(3,3)**2+t1m(3,4)**2 - eyt2=t1m(3,5)**2+t1m(3,6)**2 - epyh2=t1m(4,1)**2+t1m(4,2)**2 - epyv2=t1m(4,3)**2+t1m(4,4)**2 - epyt2=t1m(4,5)**2+t1m(4,6)**2 - eth2=t1m(5,1)**2+t1m(5,2)**2 - etv2=t1m(5,3)**2+t1m(5,4)**2 - ett2=t1m(5,5)**2+t1m(5,6)**2 - epth2=t1m(6,1)**2+t1m(6,2)**2 - eptv2=t1m(6,3)**2+t1m(6,4)**2 - eptt2=t1m(6,5)**2+t1m(6,6)**2 - exh=sqrt(exh2) - exv=sqrt(exv2) - ext=sqrt(ext2) - epxh=sqrt(epxh2) - epxv=sqrt(epxv2) - epxt=sqrt(epxt2) - eyh=sqrt(eyh2) - eyv=sqrt(eyv2) - eyt=sqrt(eyt2) - epyh=sqrt(epyh2) - epyv=sqrt(epyv2) - epyt=sqrt(epyt2) - eth=sqrt(eth2) - etv=sqrt(etv2) - ett=sqrt(ett2) - epth=sqrt(epth2) - eptv=sqrt(eptv2) - eptt=sqrt(eptt2) -c compute twiss parameters - call inv(t1a,t1m) -c compute invariants using buffers 2 thru 5 -c computation of x invariant - call clear(buf2a,buf2m) - buf2a(7)=1.d0 - buf2a(13)=1.d0 - call fxform(t1a,t1m,buf2a,buf3a) -c computation of y invariant - call clear(buf2a,buf2m) - buf2a(18)=1.d0 - buf2a(22)=1.d0 - call fxform(t1a,t1m,buf2a,buf4a) -c computation of t invariant - call clear(buf2a,buf2m) - buf2a(25)=1.d0 - buf2a(27)=1.d0 - call fxform(t1a,t1m,buf2a,buf5a) -c get twiss parameters from the invariants -c terms for horizontal (x) plane -c 'diagonal' terms - ax=buf3a(8)/2.d0 - bx=buf3a(13) - gx=buf3a(7) -c skew terms -c remove diagonal terms, and later print buf3a as a map - buf3a(8)=0. - buf3a(13)=0. - buf3a(7)=0. -c terms for vertical (y) plane -c 'diagonal' terms - ay=buf4a(19)/2.d0 - by=buf4a(22) - gy=buf4a(18) -c skew terms -c remove diagonal terms, and later print buf4a as a map - buf4a(19)=0. - buf4a(22)=0. - buf4a(18)=0. -c terms for temporal (t) plane -c 'diagonal' terms - at=buf5a(26)/2.d0 - bt=buf5a(27) - gt=buf5a(25) -c skew terms -c remove diagonal terms, and later print buf5a as a map - buf5a(26)=0. - buf5a(27)=0. - buf5a(25)=0. -c -c procedure for writing out tunes and anharmonicities - if (idata.eq.1 .or. idata.eq.12 .or. - & idata.eq.13 .or. idata.eq.123) then - do 10 i=1,2 - if (i.eq.1) then - ifile=jof - iflag=1 - if (isend.eq.2) iflag=0 - endif - if (i.eq.2) then - ifile=jodf - iflag=1 - if (isend.eq.1) iflag=0 - endif - if (isend.eq.0) goto 10 - if (iflag.eq.0) goto 10 -c write out tunes: - if(idproc.eq.0)then - write (ifile,*) - write (ifile,*) 'horizontal tune =',tnx - write (ifile,*) 'vertical tune =',tny - write (ifile,*) 'temporal tune =',tnt -c write out normalized anharmonicities - write(ifile,*) - write(ifile,*) 'normalized anharmonicities' - write(ifile,*) ' hhn=',hhn - write(ifile,*) ' vvn=',vvn - write(ifile,*) ' ttn=',ttn - write(ifile,*) ' hvn=',hvn - write(ifile,*) ' htn=',htn - write(ifile,*) ' vtn=',vtn - endif - 10 continue - endif -c -c procedure for printing out twiss parameters and envelopes - if (idata.eq.2 .or. idata.eq.12 .or. - & idata.eq.23 .or. idata.eq.123) then - do 20 i=1,2 - if (i.eq.1) then - ifile=jof - iflag=1 - if (isend.eq.2) iflag=0 - endif - if (i.eq.2) then - ifile=jodf - iflag=1 - if (isend.eq.1) iflag=0 - endif - if (isend.eq.0) goto 20 - if (iflag.eq.0) goto 20 - if(idproc.eq.0)then - write(ifile,*) - write(ifile,*) 'horizontal twiss parameters' - write(ifile,*) 'diagonal terms (alpha,beta,gamma)' - write(ifile,*) ax,bx,gx - write(ifile,*) 'skew terms written as a map' - endif - call pcmap(0,i,0,0,buf3a,buf3m) - if(idproc.eq.0)then - write(ifile,*) - write(ifile,*) 'vertical twiss parameters' - write(ifile,*) 'diagonal terms (alpha,beta,gamma)' - write(ifile,*) ay,by,gy - write(ifile,*) 'skew terms written as a map' - endif - call pcmap(0,i,0,0,buf4a,buf4m) - if(idproc.eq.0)then - write(ifile,*) - write(ifile,*) 'temporal twiss parameters' - write(ifile,*) 'diagonal terms (alpha,beta,gamma)' - write(ifile,*) at,bt,gt - write(ifile,*) 'skew terms written as a map' - endif - call pcmap(0,i,0,0,buf5a,buf5m) - if(idproc.eq.0)then - write(ifile,*) - write(ifile,*) 'horizontal envelopes (exh,exv,ext;epxh,epxv,epxt)' - write(ifile,*) exh,exv,ext - write(ifile,*) epxh,epxv,epxt - write(ifile,*) - write(ifile,*) 'vertical envelopes (eyh,eyv,eyt;epyh,epyv,epyt)' - write(ifile,*) eyh,eyv,eyt - write(ifile,*) epyh,epyv,epyt - write(ifile,*) - write(ifile,*) 'temporal envelopes (eth,etv,ett;epth,eptv,eptt)' - write(ifile,*) eth,etv,ett - write(ifile,*) epth,eptv,eptt - endif - 20 continue - endif -c -c procedure for printing out eigenvectors - if (idata.eq.3 .or. idata.eq.13 .or. - & idata.eq.23 .or. idata.eq.123) then - do 30 i=1,2 - if (i.eq.1) then - ifile=jof - iflag=1 - if (isend.eq.2) iflag=0 - endif - if (i.eq.2) then - ifile=jodf - iflag=1 - if (isend.eq.1) iflag=0 - endif - if (isend.eq.0) goto 30 - if (iflag.eq.0) goto 30 -c write out the matrix buf1m - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'matrix of eigenvectors' - call pcmap (i,0,0,0,buf1a,buf1m) - 30 continue - endif -c -c procedure for printing of maps -c -c put out script A - if (ipmaps.eq.1 .or. ipmaps.eq.3) then - do 40 i=1,2 - if (i.eq.1) then - ifile=jof - iflag=1 - if (isend.eq.2) iflag=0 - endif - if (i.eq.2) then - ifile=jodf - iflag=1 - if (isend.eq.1) iflag=0 - endif - if (isend.eq.0) goto 40 - if (iflag.eq.0) goto 40 - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'transforming map script A' - call pcmap(i,i,0,0,ta,tm) - 40 continue - endif -c -c put out script N - if (ipmaps.eq.2 .or. ipmaps.eq.3) then - do 50 i=1,2 - if (i.eq.1) then - ifile=jof - iflag=1 - if (isend.eq.2) iflag=0 - endif - if (i.eq.2) then - ifile=jodf - iflag=1 - if (isend.eq.1) iflag=0 - endif - if (isend.eq.0) goto 50 - if (iflag.eq.0) goto 50 - if(idproc.eq.0)write(ifile,*) - if(idproc.eq.0)write(ifile,*) 'normal form map script N' - call pcmap(i,i,0,0,ga,gm) - 50 continue - endif -c -c procedure for writing of maps - if (iwmaps.gt.0) then - mpot=mpo - mpo=iwmaps - call mapout(0,buf1a,buf1m) - call mapout(0,ta,tm) - call mapout(0,ga,gm) - mpo=mpot - endif -c -c put maps in buffers -c buffer 1 already contains script A2 - call mapmap(ta,tm,buf2a,buf2m) - call mapmap(ga,gm,buf3a,buf3m) - call clear(buf4a,buf4m) - call clear(buf5a,buf5m) -c - return - end -c -*********************************************************************** - subroutine tasm(p,fa,fm) -c this is a subroutine for twiss analysis of static maps -c Written by Alex Dragt, Spring 1987 -c Modified by Alex Dragt, 20 June 1988 -c Again modified by Alex Dragt, 19 August 1988 -c - use parallel, only : idproc - use beamdata - use lieaparam, only : monoms - include 'impli.inc' -c - include 'files.inc' - include 'buffer.inc' - include 'fitdat.inc' -c -c Calling arrays - dimension p(6),fa(monoms),fm(6,6) -c -c Local arrays - dimension ga(monoms),g1a(monoms) - dimension ta(monoms),t1a(monoms),t2a(monoms) - dimension gm(6,6),g1m(6,6) - dimension tm(6,6),t1m(6,6),t2m(6,6) - dimension am1(6,6),am2(6,6),am3(6,6) -c -c temporary local arrays - dimension temp1a(monoms),temp2a(monoms),temp3a(monoms) - dimension temp1m(6,6),temp2m(6,6),temp3m(6,6) - dimension bm1(6,6),bm2(6,6),bm3(6,6) - dimension rm1(6,6),rm2(6,6),rm3(6,6) - dimension em3(6,6) - dimension pm1(6,6),pm2(6,6),pm3(6,6) - dimension um1(6,6) - dimension dm1(6,6) -c -c set up control indices - iopt=nint(p(1)) - delta=p(2) - idata=nint(p(3)) - ipmaps=nint(p(4)) - isend=nint(p(5)) - iwmaps=nint(p(6)) -c -c write headings - if (isend.eq.1.or.isend.eq.3) then - write(jof,*) - write(jof,*) 'twiss analysis of static map' - endif - if (isend.eq.2.or.isend.eq.3) then - write(jodf,*) - write(jodf,*) 'twiss analysis of static map' - endif -c -c first compute closed orbit to get dispersion functions -c this routine does not put out dispersions (subroutine cod does) -c but does put them in common /fitdat/ array for possible fitting -c or plotting - call fxpt(fa,fm,temp1a,temp1m,temp3a,temp3m) - dz(1)=temp3m(1,6) - dz(2)=temp3m(2,6) - dz(3)=temp3m(3,6) - dz(4)=temp3m(4,6) -c -c preparatory steps for starting main calculation -c one objective of this calculation is to find script Ac, -c the transforming map with respect to the closed orbit -c remove offensive terms from matrix part of map: - call clear(buf5a,buf5m) - call spur2(fa,fm,ga,gm,t1a,t1m,buf5m) -c temporarily save the transforming map associated with sa2 in -c buffer 5 for later use -c -c compute tunes: - cwx=gm(1,1) - swx=gm(1,2) - cwy=gm(3,3) - swy=gm(3,4) - pi=4.*atan(1.d0) - wx=atan2(swx,cwx) - if (wx.lt.0.) wx=wx+2.*pi - wy=atan2(swy,cwy) - if (wy.lt.0.) wy=wy+2.*pi - tx=wx/(2.*pi) - ty=wy/(2.*pi) -c put results in commom/fitdat/ array - tux=tx - tuy=ty -c -c preparatory steps for continuing calculation -c remove offensive chromatic terms from f3 part of map: - call scpur3(ga,gm,g1a,g1m,t1a,t1m) -c accumulate transforming map - call concat(t1a,t1m,buf5a,buf5m,ta,tm) -c resonance decompose purified map: - call ctosr(g1a,t2a) -c -c compute chromaticities -c -c procedure when IOPT = 1 - if (iopt.eq.1) then -c compute first order chromaticities: - chrox1=-(1.d0/pi)*t2a(28) - chroy1=-(1.d0/pi)*t2a(29) -c compute second order chromaticities: - chrox2=-(2.d0/pi)*t2a(84) - chroy2=-(2.d0/pi)*t2a(85) -c put results in commom/fitdat/ array - cx=chrox1 - cy=chroy1 - qx=chrox2 - qy=chroy2 -c -c compute tunes about closed orbit - delta2=delta*delta - txc=tx+delta*chrox1+delta2*chrox2 - tyc=ty+delta*chroy1+delta2*chroy2 - tsc=txc-tyc -c - endif -c -c procedure when IOPT = 2 - if (iopt.eq.2) then -c compute first order chromaticities: - chrox1=(beta/pi)*t2a(28) - chroy1=(beta/pi)*t2a(29) -c compute second order chromaticities: - beta2=beta*beta - beta3=beta*beta2 - chrox2=(t2a(28)*(beta-beta3)-2.d0*t2a(84)*beta2)/pi - chroy2=(t2a(29)*(beta-beta3)-2.d0*t2a(85)*beta2)/pi -c put results in commom/fitdat/ array - cx=chrox1 - cy=chroy1 - qx=chrox2 - qy=chroy2 -c -c compute tune about closed orbit - delta2=delta*delta - txc=tx+delta*chrox1+delta2*chrox2 - tyc=ty+delta*chroy1+delta2*chroy2 - tsc=txc-tyc -c - endif -c -c write out tunes and chromaticities - if (idata.eq.1 .or. idata.eq.12 .or. - # idata.eq.13 .or. idata.eq.123) then - if(isend.eq.0) goto 11 - do 10 i=1,2 - if (i.eq.1) then - ifile=jof - iflag=1 - if (isend.eq.2) iflag=0 - endif - if (i.eq.2) then - ifile=jodf - iflag=1 - if (isend.eq.1) iflag=0 - endif - if (iflag.eq.0) goto 10 - write (ifile,*) - if(iopt.eq.1) then - write (ifile,*) 'tunes and chromaticities for delta defined in', - #' terms of P sub tau:' - endif - if(iopt.eq.2) then - write (ifile,*) 'tunes and chromaticities for delta defined in', - #' terms of momentum deviation:' - endif - write (ifile,*) - write (ifile,*) 'horizontal tune =',tx - write (ifile,*) 'first order horizontal chromaticity =',chrox1 - write (ifile,*) 'second order horizontal chromaticity =',chrox2 - write (ifile,*) 'horizontal tune when delta =',delta - write (ifile,*) txc - write (ifile,*) - write (ifile,*) 'vertical tune =',ty - write (ifile,*) 'first order vertical chromaticity =',chroy1 - write (ifile,*) 'second order vertical chromaticity =',chroy2 - write (ifile,*) 'vertical tune when delta =',delta - write (ifile,*) tyc - write (ifile,*) - write (ifile,*) 'tune separation when delta=',delta - write (ifile,*) tsc - 10 continue - 11 continue - endif -c -c preparatory steps for continuing calculation -c remove offensive geometric terms from f3 part of map: - call sgpur3(g1a,g1m,ga,gm,t2a,t2m) -c accumulate transforming map - call concat(t2a,t2m,ta,tm,t1a,t1m) -c resonance decompose purified map: - call ctosr(ga,t2a) -c -c compute dependence of tune on betatron amplitude: - hhi=t2a(87) - vvi=t2a(88) - hvi=t2a(89) - hhn=-2.d0*hhi/pi - vvn=-2.d0*vvi/pi - hvn=-hvi/pi -c put results in commom/fitdat/ array - hh=hhn - vv=vvn - hv=hvn -c -c write out normalized anharmonicities - if (idata.eq.1 .or. idata.eq.12 .or. - # idata.eq.13 .or. idata.eq.123) then - if(isend.eq.0) goto 21 - do 20 i=1,2 - if (i.eq.1) then - ifile=jof - iflag=1 - if (isend.eq.2) iflag=0 - endif - if (i.eq.2) then - ifile=jodf - iflag=1 - if (isend.eq.1) iflag=0 - endif - if (iflag.eq.0) goto 20 - write(ifile,*) - write(ifile,*) 'normalized anharmonicities' - write(ifile,*) ' hhn=',hhn - write(ifile,*) ' vvn=',vvn - write(ifile,*) ' hvn=',hvn - 20 continue - 21 continue - endif -c -c complete computation of script Ac and script N -c store script Ac in buffer 1 and script N in buffer 2 - call spur4(ga,gm,buf2a,buf2m,t2a,t2m) -c accumulate transforming map to get script Ac - call concat(t2a,t2m,t1a,t1m,buf1a,buf1m) -c -c compute twiss parameter expansions (invariants) and envelopes -c -c preparatory steps for continuing calculation -c compute fixed point and map around it, and put the transforming -c map to the closed orbit in buffer 3 - call fxpt(fa,fm,g1a,g1m,buf3a,buf3m) -c extract the betatron factor of the map and store it in buffer 4 - call betmap(g1a,g1m,buf4a,buf4m) -c find the transforming (conjugating) map script Ab for the betatron factor -c use the map in buffer 5 to purify the f2 part of the betatron factor - call sndwch(buf5a,buf5m,buf4a,buf4m,g1a,g1m) -c remove offensive chromatic terms from f3 part of betatron factor - call scpur3(g1a,g1m,ga,gm,ta,tm) -c accumulate transforming map: - call concat(ta,tm,buf5a,buf5m,t2a,t2m) -c remove offensive terms from f4 part of betatron factor - call spur4(ga,gm,g1a,g1m,t1a,t1m) -c accumulate transforming map to get script Ab: - call concat(t1a,t1m,t2a,t2m,ta,tm) -c store script Ab in buffer 5 - call mapmap(ta,tm,buf5a,buf5m) -c invert script Ab - call inv(ta,tm) -c -c compute invariants -c computation of x invariant - call clear(ga,gm) - ga(7)=1.d0 - ga(13)=1.d0 - call fxform(ta,tm,ga,t1a) -c computation of y invariant - call clear(ga,gm) - ga(18)=1.d0 - ga(22)=1.d0 - call fxform(ta,tm,ga,t2a) -c -c preliminary calculations required for envelopes and eigenvalues - if (idata.eq.2 .or. idata.eq.3 .or. - # idata.eq.12 .or. idata.eq.13 .or. - # idata.eq.23 .or. idata.eq.123) then -c put script Ab in ta,tm - call mapmap(buf5a,buf5m,ta,tm) -c make chromatic expansion of ta,tm -c the result will be used to compute both envelopes and eigenvectors - call chrexp(iopt,delta,ta,tm,am1,am2,am3) - endif -c -c see if output of twiss parameters and envelopes is desired - if (idata.eq.2 .or. idata.eq.12 .or. - # idata.eq.23 .or. idata.eq.123) then -c -c continue with calculation -c -c terms for horizontal (x) plane -c 'diagonal terms' - ax0=t1a(8)/2.d0 - bx0=t1a(13) - gx0=t1a(7) -c all terms: later print t1a as a map -c terms for vertical (y) plane -c 'diagonal'terms - ay0=t2a(19)/2.d0 - by0=t2a(22) - gy0=t2a(18) -c all terms: later print t2a as a map -c -c put horizontal and vertical results in commom/fitdat/ array - ax=ax0 - bx=bx0 - gx=gx0 - ay=ay0 - by=by0 - gy=gy0 -c -c compute envelopes - exhc2=am3(1,1)**2+am3(1,2)**2 - exvc2=am3(1,3)**2+am3(1,4)**2 - epxhc2=am3(2,1)**2+am3(2,2)**2 - epxvc2=am3(2,3)**2+am3(2,4)**2 - eyhc2=am3(3,1)**2+am3(3,2)**2 - eyvc2=am3(3,3)**2+am3(3,4)**2 - epyhc2=am3(4,1)**2+am3(4,2)**2 - epyvc2=am3(4,3)**2+am3(4,4)**2 - exhc=sqrt(exhc2) - exvc=sqrt(exvc2) - epxhc=sqrt(epxhc2) - epxvc=sqrt(epxvc2) - eyhc=sqrt(eyhc2) - eyvc=sqrt(eyvc2) - epyhc=sqrt(epyhc2) - epyvc=sqrt(epyvc2) -c -c write out twiss functions invariants, and envelopes - if(isend.eq.0) goto 31 - do 30 i=1,2 - if (i.eq.1) then - ifile=jof - iflag=1 - if (isend.eq.2) iflag=0 - endif - if (i.eq.2) then - ifile=jodf - iflag=1 - if (isend.eq.1) iflag=0 - endif - if (iflag.eq.0) goto 30 - write (ifile,*) - write (ifile,*) 'twiss parameters, invariants, and envelopes' -c -c write twiss functions and invariants - write (ifile,*) - write (ifile,*) 'horizontal parameters' - write (ifile,*) 'on energy diagonal terms (alpha,beta,gamma)' - write (ifile,*) ax0,bx0,gx0 - write (ifile,*) 'full twiss invariant written as a map' - call pcmap(0,i,0,0,t1a,t1m) - write (ifile,*) - write (ifile,*) 'vertical parameters' - write (ifile,*) 'on energy diagonal terms (alpha,beta,gamma)' - write (ifile,*) ay0,by0,gy0 - write (ifile,*) 'full twiss invariant written as a map' - call pcmap(0,i,0,0,t2a,t2m) -c -c write out envelopes - if(iopt.eq.1) then - write (ifile,*) - write (ifile,*) 'envelopes for delta defined in terms of', - #' P sub tau with delta =',delta - endif - if(iopt.eq.2) then - write (ifile,*) 'envelopes for delta defined in terms of', - #' momentum deviation with delta =',delta - endif - write (ifile,*) - write (ifile,*) 'normalized horizontal envelope coefficients' - #,' (exhc,exvc;epxhc,epxvc)' - write (ifile,*) exhc,exvc - write (ifile,*) epxhc,epxvc - write (ifile,*) - write (ifile,*) 'normalized vertical envelope coefficients' - #,' (eyhc,eyvc;epyhc,epyvc)' - write (ifile,*) eyhc,eyvc - write (ifile,*) epyhc,epyvc -c - 30 continue - 31 continue - endif -c -c Procedure for output of eigenvectors. - if (idata.eq.3 .or. idata.eq.13 .or. - # idata.eq.23 .or. idata.eq.123) then -c Print out matrices tm, am1, and am2. - if(isend.eq.0) goto 41 - do 40 i=1,2 - if (i.eq.1) then - iflag=1 - if (isend.eq.2) iflag=0 - ifile=jof - endif - if (i.eq.2) then - iflag=1 - if (isend.eq.1) iflag=0 - ifile=jodf - endif - if (iflag.eq.0) goto 40 -c -c procedure when IOPT = 1 - if (iopt.eq.1) then - write(ifile,198) - 198 format(//,1x,'eigenvector expansion for delta defined', - #1x,'in terms of P sub tau:') - write(ifile,200) - 200 format(/,1x,'on energy matrix of eigenvectors') - endif -c -c procedure when IOPT = 2 - if (iopt.eq.2) then - write(ifile,199) - 199 format(//,1x,'eigenvector expansion for delta defined', - #1x,'in terms of momentum deviation:') - write(ifile,201) - 201 format(/,1x,'on momentum matrix of eigenvectors') - endif -c - call pcmap(i,0,0,0,ta,tm) - write(ifile,300) - 300 format(//,1x,'delta correction') - call pcmap(i,0,0,0,ta,am1) - write(ifile,400) - 400 format(//,1x,'delta**2 correction') - call pcmap(i,0,0,0,ta,am2) -c Print out value of twiss matrix - write(ifile,402) delta - 402 format(//,1x,'matrix of eigenvectors when delta= ',d15.8) - call pcmap(i,0,0,0,ta,am3) -c -c test results -c - write(ifile,*) 'test results' -************************************************************************** -*************************************************************************** -c compute matrix for betatron portion of map - call chrexp(iopt,delta,buf4a,buf4m,bm1,bm2,bm3) -c compute tune matrix - call spur2(fa,fm,ga,gm,t1a,t1m,t2m) - call scpur3(ga,gm,g1a,g1m,t1a,t1m) - call clear(temp1a,temp1m) - call clear(temp3a,temp3m) - call matmat(gm,temp1m) - call ctosr(g1a,temp2a) - temp3a(28)=temp2a(28) - temp3a(29)=temp2a(29) - temp3a(84)=temp2a(84) - temp3a(85)=temp2a(85) - call srtoc(temp3a,temp1a) - call chrexp(iopt,delta,temp1a,temp1m,rm1,rm2,rm3) -c set up matrix of eigenvectors - call matmat(am3,em3) -c form the product pm1=em3*rm3 - call mmult(em3,rm3,pm1) -c invert pm1 - call inv(t1a,pm1) -c form the product pm2=bm3*em3 - call mmult(bm3,em3,pm2) -c form the product pm3=(pm1 inverse)*pm2 - call mmult(pm1,pm2,pm3) -c form the negative identity matrix - call ident(temp1a,um1) - call smmult(-1.d0,um1,um1) -c form the difference dm1=pm3-um1 - call madd(pm3,um1,dm1) -c print the results bm3 and dm1 - call pcmap(i,0,0,0,ta,bm3) - call pcmap(i,0,0,0,ta,dm1) -************************************************************** -************************************************************** -c - 40 continue - 41 continue - endif -c -c Procedure for printing of maps. -c - if (ipmaps.eq.1 .or. ipmaps.eq.3) then -c print out script Ac and script N - if(isend.eq.0) goto 51 - do 50 i=1,2 - if (i.eq.1) then - iflag=1 - if (isend.eq.2) iflag=0 - ifile=jof - endif - if (i.eq.2) then - iflag=1 - if (isend.eq.1) iflag=0 - ifile=jodf - endif - if (iflag.eq.0) goto 50 - write(ifile,600) - 600 format(//,1x,'transforming map with respect to - # the closed orbit') - call pcmap(i,i,0,0,buf1a,buf1m) - write(ifile,700) - 700 format(//,1x,'normal form for transfer map') - call pcmap(i,i,0,0,buf2a,buf2m) - 50 continue - 51 continue - endif -c - if (ipmaps.eq.2 .or. ipmaps.eq.3) then -c print out betatron portion of map and script Ab - if(isend.eq.0) goto 61 - do 60 i=1,2 - if (i.eq.1) then - iflag=1 - if (isend.eq.2) iflag=0 - ifile=jof - endif - if (i.eq.2) then - iflag=1 - if (isend.eq.1) iflag=0 - ifile=jodf - endif - if (iflag.eq.0) goto 60 - write(ifile,610) - 610 format(//,1x,'betatron factor of transfer map') - call pcmap(i,i,0,0,buf4a,buf4m) - write(ifile,710) - 710 format(//,1x,'transforming map for betatron factor') - call pcmap(i,i,0,0,buf5a,buf5m) - 60 continue - 61 continue - endif -c -c Procedure for writing of maps. - if (iwmaps.gt.0) then - mpot=mpo - mpo=iwmaps - call mapout(0,buf1a,buf1m) - call mapout(0,buf2a,buf2m) - call mapout(0,buf3a,buf3m) - call mapout(0,buf4a,buf4m) - call mapout(0,buf5a,buf5m) - mpo=mpot - endif -c - return - end -*********************************************************************** -c - subroutine tbas(p,fa,fm) -c this routine translates bases -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' - dimension p(6),fa(monoms),fm(6,6) - dimension ga(monoms),gm(6,6) -c - call mapmap(fa,fm,ga,gm) - iopt=nint(p(1)) - if (iopt.eq.1) call ctosr(ga,fa) - if (iopt.eq.2) call ctodr(ga,fa) - if (iopt.eq.3) call srtoc(ga,fa) - if (iopt.eq.4) call drtoc(ga,fa) - return - end -c -******************************************************************* -c - subroutine trda(p,fa,fm) -c this subroutine transports a dynamic script A - use lieaparam, only : monoms - include 'impli.inc' - dimension p(6),fa(monoms),fm(6,6) -c - write(6,*) 'trda not yet available' - return - end -c -******************************************************************* -c - subroutine trsa(p,fa,fm) -c this subroutine transports a static script A - use lieaparam, only : monoms - include 'impli.inc' - dimension p(6),fa(monoms),fm(6,6) -c - write(6,*) 'trsa not yet available' - return - end -c -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/base.f b/OpticsJan2020/MLI_light_optics/Src/base.f deleted file mode 100755 index b1c499e..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/base.f +++ /dev/null @@ -1,1032 +0,0 @@ -************************************************************************ -* header: CHANGE OF BASIS ROUTINES (BASE) -* ctosr,srtoc,ctodr,drtoc -************************************************************************ -c - subroutine ctosr(f,g) -c This is a subroutine for transforming from a cartesian basis -c to a static resonance basis. -c f is the cartesion vector, -c g is the vector in the static resonance basis. -c Written by F. Neri, Spring 1986 - use lieaparam, only : monoms -c implicit none - double precision f(monoms),g(monoms) -c - g(1) = f(6) - g(2) = f(1) - g(3) = f(2) - g(4) = f(3) - g(5) = f(4) - g(6) = f(5) - g(7) = .5d0*f(7)+.5d0*f(13) - g(8) = .5d0*f(18)+.5d0*f(22) - g(9) = f(27) - g(10) = f(12) - g(11) = f(17) - g(12) = f(21) - g(13) = f(24) - g(14) = .5d0*f(7)-.5d0*f(13) - g(15) = .5d0*f(8) - g(16) = .5d0*f(18)-.5d0*f(22) - g(17) = .5d0*f(19) - g(18) = .5d0*f(9)-.5d0*f(15) - g(19) = .5d0*f(10)+.5d0*f(14) - g(20) = .5d0*f(9)+.5d0*f(15) - g(21) = -.5d0*f(10)+.5d0*f(14) - g(22) = f(11) - g(23) = f(16) - g(24) = f(20) - g(25) = f(23) - g(26) = f(25) - g(27) = f(26) - g(28) = .5d0*f(33)+.5d0*f(53) - g(29) = .5d0*f(67)+.5d0*f(76) - g(30) = f(83) - g(31) = f(48) - g(32) = f(63) - g(33) = f(73) - g(34) = f(79) - g(35) = .5d0*f(33)-.5d0*f(53) - g(36) = .5d0*f(38) - g(37) = .5d0*f(67)-.5d0*f(76) - g(38) = .5d0*f(70) - g(39) = .5d0*f(42)-.5d0*f(60) - g(40) = .5d0*f(45)+.5d0*f(57) - g(41) = .5d0*f(42)+.5d0*f(60) - g(42) = -.5d0*f(45)+.5d0*f(57) - g(43) = .75d0*f(28)+.25d0*f(34) - g(44) = .25d0*f(29)+.75d0*f(49) - g(45) = .75d0*f(64)+.25d0*f(68) - g(46) = .25d0*f(65)+.75d0*f(74) - g(47) = .5d0*f(39)+.5d0*f(43) - g(48) = .5d0*f(54)+.5d0*f(58) - g(49) = .5d0*f(30)+.5d0*f(50) - g(50) = .5d0*f(31)+.5d0*f(51) - g(51) = .25d0*f(28)-.25d0*f(34) - g(52) = .25d0*f(29)-.25d0*f(49) - g(53) = .25d0*f(64)-.25d0*f(68) - g(54) = .25d0*f(65)-.25d0*f(74) - g(55) = .25d0*f(30)-.25d0*f(36)-.25d0*f(50) - g(56) = .25d0*f(31)+.25d0*f(35)-.25d0*f(51) - g(57) = .25d0*f(39)-.25d0*f(43)-.25d0*f(55) - g(58) = .25d0*f(40)+.25d0*f(54)-.25d0*f(58) - g(59) = .25d0*f(30)+.25d0*f(36)-.25d0*f(50) - g(60) = -.25d0*f(31)+.25d0*f(35)+.25d0*f(51) - g(61) = .25d0*f(39)-.25d0*f(43)+.25d0*f(55) - g(62) = .25d0*f(40)-.25d0*f(54)+.25d0*f(58) - g(63) = f(32) - g(64) = f(37) - g(65) = f(41) - g(66) = f(44) - g(67) = f(46) - g(68) = f(47) - g(69) = f(52) - g(70) = f(56) - g(71) = f(59) - g(72) = f(61) - g(73) = f(62) - g(74) = f(66) - g(75) = f(69) - g(76) = f(71) - g(77) = f(72) - g(78) = f(75) - g(79) = f(77) - g(80) = f(78) - g(81) = f(80) - g(82) = f(81) - g(83) = f(82) - g(84) = .5d0*f(104)+.5d0*f(154) - g(85) = .5d0*f(184)+.5d0*f(200) - g(86) = f(209) - g(87) = .375d0*f(84)+.125d0*f(90)+.375d0*f(140) - g(88) = .375d0*f(175)+.125d0*f(179)+.375d0*f(195) - g(89) = .25d0*f(95)+.25d0*f(99)+.25d0*f(145)+.25d0*f(149) - g(90) = f(139) - g(91) = f(174) - g(92) = f(194) - g(93) = f(204) - g(94) = .5d0*f(104)-.5d0*f(154) - g(95) = .5d0*f(119) - g(96) = .5d0*f(184)-.5d0*f(200) - g(97) = .5d0*f(190) - g(98) = .5d0*f(129)-.5d0*f(170) - g(99) = .5d0*f(135)+.5d0*f(164) - g(100) = .5d0*f(129)+.5d0*f(170) - g(101) = -.5d0*f(135)+.5d0*f(164) - g(102) = .75d0*f(89)+.25d0*f(109) - g(103) = .25d0*f(94)+.75d0*f(144) - g(104) = .75d0*f(178)+.25d0*f(187) - g(105) = .25d0*f(181)+.75d0*f(197) - g(106) = .5d0*f(123)+.5d0*f(132) - g(107) = .5d0*f(158)+.5d0*f(167) - g(108) = .5d0*f(98)+.5d0*f(148) - g(109) = .5d0*f(101)+.5d0*f(151) - g(110) = .25d0*f(89)-.25d0*f(109) - g(111) = .25d0*f(94)-.25d0*f(144) - g(112) = .25d0*f(178)-.25d0*f(187) - g(113) = .25d0*f(181)-.25d0*f(197) - g(114) = .25d0*f(98)-.25d0*f(116)-.25d0*f(148) - g(115) = .25d0*f(101)+.25d0*f(113)-.25d0*f(151) - g(116) = .25d0*f(123)-.25d0*f(132)-.25d0*f(161) - g(117) = .25d0*f(126)+.25d0*f(158)-.25d0*f(167) - g(118) = .25d0*f(98)+.25d0*f(116)-.25d0*f(148) - g(119) = -.25d0*f(101)+.25d0*f(113)+.25d0*f(151) - g(120) = .25d0*f(123)-.25d0*f(132)+.25d0*f(161) - g(121) = .25d0*f(126)-.25d0*f(158)+.25d0*f(167) - g(122) = .5d0*f(84)-.5d0*f(140) - g(123) = .25d0*f(85)+.25d0*f(105) - g(124) = .5d0*f(175)-.5d0*f(195) - g(125) = .25d0*f(176)+.25d0*f(185) - g(126) = .25d0*f(95)+.25d0*f(99)-.25d0*f(145)-.25d0*f(149) - g(127) = .25d0*f(110)+.25d0*f(114) - g(128) = .25d0*f(95)-.25d0*f(99)+.25d0*f(145)-.25d0*f(149) - g(129) = .25d0*f(96)+.25d0*f(146) - g(130) = .375d0*f(86)-.125d0*f(92)+.125d0*f(106)-.375d0*f(142) - g(131) = .375d0*f(87)+.125d0*f(91)+.125d0*f(107)+.375d0*f(141) - g(132) = .375d0*f(120)+.125d0*f(124)-.125d0*f(156)-.375d0*f(165) - g(133) = .125d0*f(121)+.375d0*f(130)+.375d0*f(155)+.125d0*f(159) - g(134) = .375d0*f(86)+.125d0*f(92)+.125d0*f(106)+.375d0*f(142) - g(135) = -.375d0*f(87)+.125d0*f(91)-.125d0*f(107)+.375d0*f(141) - g(136) = .375d0*f(120)+.125d0*f(124)+.125d0*f(156)+.375d0*f(165) - g(137) = .125d0*f(121)+.375d0*f(130)-.375d0*f(155)-.125d0*f(159) - g(138) = .125d0*f(84)-.125d0*f(90)+.125d0*f(140) - g(139) = .125d0*f(85)-.125d0*f(105) - g(140) = .125d0*f(175)-.125d0*f(179)+.125d0*f(195) - g(141) = .125d0*f(176)-.125d0*f(185) - g(142) = .125d0*f(86)-.125d0*f(92)-.125d0*f(106)+.125d0*f(142) - g(143) = .125d0*f(87)+.125d0*f(91)-.125d0*f(107)-.125d0*f(141) - g(144) = .125d0*f(120)-.125d0*f(124)-.125d0*f(156)+.125d0*f(165) - g(145) = .125d0*f(121)-.125d0*f(130)+.125d0*f(155)-.125d0*f(159) - g(146) = .125d0*f(86)+.125d0*f(92)-.125d0*f(106)-.125d0*f(142) - g(147) = -.125d0*f(87)+.125d0*f(91)+.125d0*f(107)-.125d0*f(141) - g(148) = .125d0*f(120)-.125d0*f(124)+.125d0*f(156)-.125d0*f(165) - g(149) = .125d0*f(121)-.125d0*f(130)-.125d0*f(155)+.125d0*f(159) - g(150) = .125d0*f(95)-.125d0*f(99)-.125d0*f(111) - &-.125d0*f(145)+.125d0*f(149) - g(151) = .125d0*f(96)+.125d0*f(110)-.125d0*f(114)-.125d0*f(146) - g(152) = .125d0*f(95)-.125d0*f(99)+.125d0*f(111) - &-.125d0*f(145)+.125d0*f(149) - g(153) = -.125d0*f(96)+.125d0*f(110)-.125d0*f(114)+.125d0*f(146) - g(154) = f(88) - g(155) = f(93) - g(156) = f(97) - g(157) = f(100) - g(158) = f(102) - g(159) = f(103) - g(160) = f(108) - g(161) = f(112) - g(162) = f(115) - g(163) = f(117) - g(164) = f(118) - g(165) = f(122) - g(166) = f(125) - g(167) = f(127) - g(168) = f(128) - g(169) = f(131) - g(170) = f(133) - g(171) = f(134) - g(172) = f(136) - g(173) = f(137) - g(174) = f(138) - g(175) = f(143) - g(176) = f(147) - g(177) = f(150) - g(178) = f(152) - g(179) = f(153) - g(180) = f(157) - g(181) = f(160) - g(182) = f(162) - g(183) = f(163) - g(184) = f(166) - g(185) = f(168) - g(186) = f(169) - g(187) = f(171) - g(188) = f(172) - g(189) = f(173) - g(190) = f(177) - g(191) = f(180) - g(192) = f(182) - g(193) = f(183) - g(194) = f(186) - g(195) = f(188) - g(196) = f(189) - g(197) = f(191) - g(198) = f(192) - g(199) = f(193) - g(200) = f(196) - g(201) = f(198) - g(202) = f(199) - g(203) = f(201) - g(204) = f(202) - g(205) = f(203) - g(206) = f(205) - g(207) = f(206) - g(208) = f(207) - g(209) = f(208) - return - end -c -*********************************************************************** -c - subroutine srtoc(g,f) -c This is a subroutine for transforming from a static -c resonance basis to a cartesian basis. -c g = static resonance basis array, -c f = cartesian array. -c Written by F. Neri, Spring 1986 - use lieaparam, only : monoms -c implicit none - double precision f(monoms),g(monoms) -c - f(1) = g(2) - f(2) = g(3) - f(3) = g(4) - f(4) = g(5) - f(5) = g(6) - f(6) = g(1) - f(7) = g(7)+g(14) - f(8) = 2.d0*g(15) - f(9) = g(18)+g(20) - f(10) = g(19)-g(21) - f(11) = g(22) - f(12) = g(10) - f(13) = g(7)-g(14) - f(14) = g(19)+g(21) - f(15) = -g(18)+g(20) - f(16) = g(23) - f(17) = g(11) - f(18) = g(8)+g(16) - f(19) = 2.d0*g(17) - f(20) = g(24) - f(21) = g(12) - f(22) = g(8)-g(16) - f(23) = g(25) - f(24) = g(13) - f(25) = g(26) - f(26) = g(27) - f(27) = g(9) - f(28) = g(43)+g(51) - f(29) = g(44)+3.d0*g(52) - f(30) = g(49)+g(55)+g(59) - f(31) = g(50)+g(56)-g(60) - f(32) = g(63) - f(33) = g(28)+g(35) - f(34) = g(43)-3.d0*g(51) - f(35) = 2.d0*g(56)+2.d0*g(60) - f(36) = -2.d0*g(55)+2.d0*g(59) - f(37) = g(64) - f(38) = 2.d0*g(36) - f(39) = g(47)+g(57)+g(61) - f(40) = 2.d0*g(58)+2.d0*g(62) - f(41) = g(65) - f(42) = g(39)+g(41) - f(43) = g(47)-g(57)-g(61) - f(44) = g(66) - f(45) = g(40)-g(42) - f(46) = g(67) - f(47) = g(68) - f(48) = g(31) - f(49) = g(44)-g(52) - f(50) = g(49)-g(55)-g(59) - f(51) = g(50)-g(56)+g(60) - f(52) = g(69) - f(53) = g(28)-g(35) - f(54) = g(48)+g(58)-g(62) - f(55) = -2.d0*g(57)+2.d0*g(61) - f(56) = g(70) - f(57) = g(40)+g(42) - f(58) = g(48)-g(58)+g(62) - f(59) = g(71) - f(60) = -g(39)+g(41) - f(61) = g(72) - f(62) = g(73) - f(63) = g(32) - f(64) = g(45)+g(53) - f(65) = g(46)+3.d0*g(54) - f(66) = g(74) - f(67) = g(29)+g(37) - f(68) = g(45)-3.d0*g(53) - f(69) = g(75) - f(70) = 2.d0*g(38) - f(71) = g(76) - f(72) = g(77) - f(73) = g(33) - f(74) = g(46)-g(54) - f(75) = g(78) - f(76) = g(29)-g(37) - f(77) = g(79) - f(78) = g(80) - f(79) = g(34) - f(80) = g(81) - f(81) = g(82) - f(82) = g(83) - f(83) = g(30) - f(84) = g(87)+g(122)+g(138) - f(85) = 2.d0*g(123)+4.d0*g(139) - f(86) = g(130)+g(134)+g(142)+g(146) - f(87) = g(131)-g(135)+g(143)-g(147) - f(88) = g(154) - f(89) = g(102)+g(110) - f(90) = 2.d0*g(87)-6.d0*g(138) - f(91) = g(131)+g(135)+3.d0*g(143)+3.d0*g(147) - f(92) = -g(130)+g(134)-3.d0*g(142)+3.d0*g(146) - f(93) = g(155) - f(94) = g(103)+3.d0*g(111) - f(95) = g(89)+g(126)+g(128)+g(150)+g(152) - f(96) = 2.d0*g(129)+2.d0*g(151)-2.d0*g(153) - f(97) = g(156) - f(98) = g(108)+g(114)+g(118) - f(99) = g(89)+g(126)-g(128)-g(150)-g(152) - f(100) = g(157) - f(101) = g(109)+g(115)-g(119) - f(102) = g(158) - f(103) = g(159) - f(104) = g(84)+g(94) - f(105) = 2.d0*g(123)-4.d0*g(139) - f(106) = g(130)+g(134)-3.d0*g(142)-3.d0*g(146) - f(107) = g(131)-g(135)-3.d0*g(143)+3.d0*g(147) - f(108) = g(160) - f(109) = g(102)-3.d0*g(110) - f(110) = 2.d0*g(127)+2.d0*g(151)+2.d0*g(153) - f(111) = -4.d0*g(150)+4.d0*g(152) - f(112) = g(161) - f(113) = 2.d0*g(115)+2.d0*g(119) - f(114) = 2.d0*g(127)-2.d0*g(151)-2.d0*g(153) - f(115) = g(162) - f(116) = -2.d0*g(114)+2.d0*g(118) - f(117) = g(163) - f(118) = g(164) - f(119) = 2.d0*g(95) - f(120) = g(132)+g(136)+g(144)+g(148) - f(121) = g(133)+g(137)+3.d0*g(145)+3.d0*g(149) - f(122) = g(165) - f(123) = g(106)+g(116)+g(120) - f(124) = g(132)+g(136)-3.d0*g(144)-3.d0*g(148) - f(125) = g(166) - f(126) = 2.d0*g(117)+2.d0*g(121) - f(127) = g(167) - f(128) = g(168) - f(129) = g(98)+g(100) - f(130) = g(133)+g(137)-g(145)-g(149) - f(131) = g(169) - f(132) = g(106)-g(116)-g(120) - f(133) = g(170) - f(134) = g(171) - f(135) = g(99)-g(101) - f(136) = g(172) - f(137) = g(173) - f(138) = g(174) - f(139) = g(90) - f(140) = g(87)-g(122)+g(138) - f(141) = g(131)+g(135)-g(143)-g(147) - f(142) = -g(130)+g(134)+g(142)-g(146) - f(143) = g(175) - f(144) = g(103)-g(111) - f(145) = g(89)-g(126)+g(128)-g(150)-g(152) - f(146) = 2.d0*g(129)-2.d0*g(151)+2.d0*g(153) - f(147) = g(176) - f(148) = g(108)-g(114)-g(118) - f(149) = g(89)-g(126)-g(128)+g(150)+g(152) - f(150) = g(177) - f(151) = g(109)-g(115)+g(119) - f(152) = g(178) - f(153) = g(179) - f(154) = g(84)-g(94) - f(155) = g(133)-g(137)+g(145)-g(149) - f(156) = -g(132)+g(136)-3.d0*g(144)+3.d0*g(148) - f(157) = g(180) - f(158) = g(107)+g(117)-g(121) - f(159) = g(133)-g(137)-3.d0*g(145)+3.d0*g(149) - f(160) = g(181) - f(161) = -2.d0*g(116)+2.d0*g(120) - f(162) = g(182) - f(163) = g(183) - f(164) = g(99)+g(101) - f(165) = -g(132)+g(136)+g(144)-g(148) - f(166) = g(184) - f(167) = g(107)-g(117)+g(121) - f(168) = g(185) - f(169) = g(186) - f(170) = -g(98)+g(100) - f(171) = g(187) - f(172) = g(188) - f(173) = g(189) - f(174) = g(91) - f(175) = g(88)+g(124)+g(140) - f(176) = 2.d0*g(125)+4.d0*g(141) - f(177) = g(190) - f(178) = g(104)+g(112) - f(179) = 2.d0*g(88)-6.d0*g(140) - f(180) = g(191) - f(181) = g(105)+3.d0*g(113) - f(182) = g(192) - f(183) = g(193) - f(184) = g(85)+g(96) - f(185) = 2.d0*g(125)-4.d0*g(141) - f(186) = g(194) - f(187) = g(104)-3.d0*g(112) - f(188) = g(195) - f(189) = g(196) - f(190) = 2.d0*g(97) - f(191) = g(197) - f(192) = g(198) - f(193) = g(199) - f(194) = g(92) - f(195) = g(88)-g(124)+g(140) - f(196) = g(200) - f(197) = g(105)-g(113) - f(198) = g(201) - f(199) = g(202) - f(200) = g(85)-g(96) - f(201) = g(203) - f(202) = g(204) - f(203) = g(205) - f(204) = g(93) - f(205) = g(206) - f(206) = g(207) - f(207) = g(208) - f(208) = g(209) - f(209) = g(86) - return - end -c -************************************************************ - subroutine ctodr(f,g) -* -* go from cartesian to static resonance frame -* f(*) : cartesian basis coefficients (input). -* g(*) : dynamic resonance basis coefficients (output). -* -* F. Neri 6/2/1986 -* -************************************************************ - use lieaparam, only : monoms -c implicit none - double precision f(monoms),g(monoms) -c - g(1) = 1.d0*f(1) - g(2) = 1.d0*f(2) - g(3) = 1.d0*f(3) - g(4) = 1.d0*f(4) - g(5) = 1.d0*f(5) - g(6) = 1.d0*f(6) - g(7) = .5d0*f(7)+.5d0*f(13) - g(8) = .5d0*f(18)+.5d0*f(22) - g(9) = .5d0*f(25)+.5d0*f(27) - g(10) = .5d0*f(25)-.5d0*f(27) - g(11) = .5d0*f(26) - g(12) = .5d0*f(11)-.5d0*f(17) - g(13) = .5d0*f(12)+.5d0*f(16) - g(14) = .5d0*f(11)+.5d0*f(17) - g(15) = -.5d0*f(12)+.5d0*f(16) - g(16) = .5d0*f(20)-.5d0*f(24) - g(17) = .5d0*f(21)+.5d0*f(23) - g(18) = .5d0*f(20)+.5d0*f(24) - g(19) = -.5d0*f(21)+.5d0*f(23) - g(20) = .5d0*f(7)-.5d0*f(13) - g(21) = .5d0*f(8) - g(22) = .5d0*f(18)-.5d0*f(22) - g(23) = .5d0*f(19) - g(24) = .5d0*f(9)-.5d0*f(15) - g(25) = .5d0*f(10)+.5d0*f(14) - g(26) = .5d0*f(9)+.5d0*f(15) - g(27) = -.5d0*f(10)+.5d0*f(14) - g(28) = .5d0*f(32)+.5d0*f(52) - g(29) = .5d0*f(33)+.5d0*f(53) - g(30) = .5d0*f(66)+.5d0*f(75) - g(31) = .5d0*f(67)+.5d0*f(76) - g(32) = .25d0*f(80)-.25d0*f(82) - g(33) = .25d0*f(81)-.25d0*f(83) - g(34) = .75d0*f(80)+.25d0*f(82) - g(35) = .25d0*f(81)+.75d0*f(83) - g(36) = .5d0*f(46)+.5d0*f(48) - g(37) = .5d0*f(61)+.5d0*f(63) - g(38) = .5d0*f(71)+.5d0*f(73) - g(39) = .5d0*f(77)+.5d0*f(79) - g(40) = .25d0*f(46)-.25d0*f(48)-.25d0*f(62) - g(41) = .25d0*f(47)+.25d0*f(61)-.25d0*f(63) - g(42) = .25d0*f(46)-.25d0*f(48)+.25d0*f(62) - g(43) = -.25d0*f(47)+.25d0*f(61)-.25d0*f(63) - g(44) = .25d0*f(71)-.25d0*f(73)-.25d0*f(78) - g(45) = .25d0*f(72)+.25d0*f(77)-.25d0*f(79) - g(46) = .25d0*f(71)-.25d0*f(73)+.25d0*f(78) - g(47) = -.25d0*f(72)+.25d0*f(77)-.25d0*f(79) - g(48) = .25d0*f(32)-.25d0*f(38)-.25d0*f(52) - g(49) = .25d0*f(33)+.25d0*f(37)-.25d0*f(53) - g(50) = .25d0*f(32)+.25d0*f(38)-.25d0*f(52) - g(51) = -.25d0*f(33)+.25d0*f(37)+.25d0*f(53) - g(52) = .25d0*f(66)-.25d0*f(70)-.25d0*f(75) - g(53) = .25d0*f(67)+.25d0*f(69)-.25d0*f(76) - g(54) = .25d0*f(66)+.25d0*f(70)-.25d0*f(75) - g(55) = -.25d0*f(67)+.25d0*f(69)+.25d0*f(76) - g(56) = .25d0*f(41)-.25d0*f(45)-.25d0*f(57)-.25d0*f(59) - g(57) = .25d0*f(42)+.25d0*f(44)+.25d0*f(56)-.25d0*f(60) - g(58) = .25d0*f(41)+.25d0*f(45)+.25d0*f(57)-.25d0*f(59) - g(59) = -.25d0*f(42)+.25d0*f(44)+.25d0*f(56)+.25d0*f(60) - g(60) = .25d0*f(41)+.25d0*f(45)-.25d0*f(57)+.25d0*f(59) - g(61) = .25d0*f(42)-.25d0*f(44)+.25d0*f(56)+.25d0*f(60) - g(62) = .25d0*f(41)-.25d0*f(45)+.25d0*f(57)+.25d0*f(59) - g(63) = -.25d0*f(42)-.25d0*f(44)+.25d0*f(56)-.25d0*f(60) - g(64) = .75d0*f(28)+.25d0*f(34) - g(65) = .25d0*f(29)+.75d0*f(49) - g(66) = .75d0*f(64)+.25d0*f(68) - g(67) = .25d0*f(65)+.75d0*f(74) - g(68) = .5d0*f(39)+.5d0*f(43) - g(69) = .5d0*f(54)+.5d0*f(58) - g(70) = .5d0*f(30)+.5d0*f(50) - g(71) = .5d0*f(31)+.5d0*f(51) - g(72) = .25d0*f(28)-.25d0*f(34) - g(73) = .25d0*f(29)-.25d0*f(49) - g(74) = .25d0*f(64)-.25d0*f(68) - g(75) = .25d0*f(65)-.25d0*f(74) - g(76) = .25d0*f(30)-.25d0*f(36)-.25d0*f(50) - g(77) = .25d0*f(31)+.25d0*f(35)-.25d0*f(51) - g(78) = .25d0*f(39)-.25d0*f(43)-.25d0*f(55) - g(79) = .25d0*f(40)+.25d0*f(54)-.25d0*f(58) - g(80) = .25d0*f(30)+.25d0*f(36)-.25d0*f(50) - g(81) = -.25d0*f(31)+.25d0*f(35)+.25d0*f(51) - g(82) = .25d0*f(39)-.25d0*f(43)+.25d0*f(55) - g(83) = -.25d0*f(40)+.25d0*f(54)-.25d0*f(58) - g(84) = .375d0*f(84)+.125d0*f(90)+.375d0*f(140) - g(85) = .375d0*f(175)+.125d0*f(179)+.375d0*f(195) - g(86) = .375d0*f(205)+.125d0*f(207)+.375d0*f(209) - g(87) = .25d0*f(95)+.25d0*f(99)+.25d0*f(145)+.25d0*f(149) - g(88) = .25d0*f(102)+.25d0*f(104)+.25d0*f(152)+.25d0*f(154) - g(89) = .25d0*f(182)+.25d0*f(184)+.25d0*f(198)+.25d0*f(200) - g(90) = .25d0*f(102)-.25d0*f(104)+.25d0*f(152) - & -.25d0*f(154) - g(91) = .25d0*f(103)+.25d0*f(153) - g(92) = .25d0*f(182)-.25d0*f(184)+.25d0*f(198) - & -.25d0*f(200) - g(93) = .25d0*f(183)+.25d0*f(199) - g(94) = .125d0*f(205)-.125d0*f(207)+.125d0*f(209) - g(95) = .125d0*f(206)-.125d0*f(208) - g(96) = .5d0*f(205)-.5d0*f(209) - g(97) = .25d0*f(206)+.25d0*f(208) - g(98) = .125d0*f(136)-.125d0*f(138)-.125d0*f(172) - & +.125d0*f(174) - g(99) = .125d0*f(137)-.125d0*f(139)+.125d0*f(171) - & -.125d0*f(173) - g(100) = .125d0*f(136)-.125d0*f(138)+.125d0*f(172) - & -.125d0*f(174) - g(101) = -.125d0*f(137)+.125d0*f(139)+.125d0*f(171) - & -.125d0*f(173) - g(102) = .125d0*f(191)-.125d0*f(193)-.125d0*f(202) - & +.125d0*f(204) - g(103) = .125d0*f(192)-.125d0*f(194)+.125d0*f(201) - & -.125d0*f(203) - g(104) = .125d0*f(191)-.125d0*f(193)+.125d0*f(202) - & -.125d0*f(204) - g(105) = -.125d0*f(192)+.125d0*f(194)+.125d0*f(201) - & -.125d0*f(203) - g(106) = .375d0*f(136)+.125d0*f(138)-.125d0*f(172) - & -.375d0*f(174) - g(107) = .125d0*f(137)+.375d0*f(139)+.375d0*f(171) - & +.125d0*f(173) - g(108) = .375d0*f(136)+.125d0*f(138)+.125d0*f(172) - & +.375d0*f(174) - g(109) = -.125d0*f(137)-.375d0*f(139)+.375d0*f(171) - & +.125d0*f(173) - g(110) = .375d0*f(191)+.125d0*f(193)-.125d0*f(202) - & -.375d0*f(204) - g(111) = .125d0*f(192)+.375d0*f(194)+.375d0*f(201) - & +.125d0*f(203) - g(112) = .375d0*f(191)+.125d0*f(193)+.125d0*f(202) - & +.375d0*f(204) - g(113) = -.125d0*f(192)-.375d0*f(194)+.375d0*f(201) - & +.125d0*f(203) - g(114) = .25d0*f(102)+.25d0*f(104)-.25d0*f(152) - & -.25d0*f(154) - g(115) = .25d0*f(117)+.25d0*f(119) - g(116) = .25d0*f(182)+.25d0*f(184)-.25d0*f(198) - & -.25d0*f(200) - g(117) = .25d0*f(188)+.25d0*f(190) - g(118) = .125d0*f(102)-.125d0*f(104)-.125d0*f(118) - & -.125d0*f(152)+.125d0*f(154) - g(119) = .125d0*f(103)+.125d0*f(117)-.125d0*f(119) - & -.125d0*f(153) - g(120) = .125d0*f(102)-.125d0*f(104)+.125d0*f(118) - & -.125d0*f(152)+.125d0*f(154) - g(121) = -.125d0*f(103)+.125d0*f(117)-.125d0*f(119) - & +.125d0*f(153) - g(122) = .125d0*f(182)-.125d0*f(184)-.125d0*f(189) - & -.125d0*f(198)+.125d0*f(200) - g(123) = .125d0*f(183)+.125d0*f(188)-.125d0*f(190) - & -.125d0*f(199) - g(124) = .125d0*f(182)-.125d0*f(184)+.125d0*f(189) - & -.125d0*f(198)+.125d0*f(200) - g(125) = -.125d0*f(183)+.125d0*f(188)-.125d0*f(190) - & +.125d0*f(199) - g(126) = .25d0*f(127)+.25d0*f(129)-.25d0*f(168) - & -.25d0*f(170) - g(127) = .25d0*f(133)+.25d0*f(135)+.25d0*f(162)+.25d0*f(164) - g(128) = .25d0*f(127)+.25d0*f(129)+.25d0*f(168)+.25d0*f(170) - g(129) = -.25d0*f(133)-.25d0*f(135)+.25d0*f(162)+.25d0*f(164) - g(130) = .125d0*f(127)-.125d0*f(129)-.125d0*f(134) - & -.125d0*f(163)-.125d0*f(168)+.125d0*f(170) - g(131) = .125d0*f(128)+.125d0*f(133)-.125d0*f(135) - & +.125d0*f(162)-.125d0*f(164)-.125d0*f(169) - g(132) = .125d0*f(127)-.125d0*f(129)+.125d0*f(134) - & +.125d0*f(163)-.125d0*f(168)+.125d0*f(170) - g(133) = -.125d0*f(128)+.125d0*f(133)-.125d0*f(135) - & +.125d0*f(162)-.125d0*f(164)+.125d0*f(169) - g(134) = .125d0*f(127)-.125d0*f(129)+.125d0*f(134) - & -.125d0*f(163)+.125d0*f(168)-.125d0*f(170) - g(135) = .125d0*f(128)-.125d0*f(133)+.125d0*f(135) - & +.125d0*f(162)-.125d0*f(164)+.125d0*f(169) - g(136) = .125d0*f(127)-.125d0*f(129)-.125d0*f(134) - & +.125d0*f(163)+.125d0*f(168)-.125d0*f(170) - g(137) = -.125d0*f(128)-.125d0*f(133)+.125d0*f(135) - & +.125d0*f(162)-.125d0*f(164)-.125d0*f(169) - g(138) = .375d0*f(88)-.125d0*f(94)+.125d0*f(108) - & -.375d0*f(144) - g(139) = .375d0*f(89)+.125d0*f(93)+.125d0*f(109) - & +.375d0*f(143) - g(140) = .375d0*f(88)+.125d0*f(94)+.125d0*f(108) - & +.375d0*f(144) - g(141) = -.375d0*f(89)+.125d0*f(93)-.125d0*f(109) - & +.375d0*f(143) - g(142) = .375d0*f(177)-.125d0*f(181)+.125d0*f(186) - & -.375d0*f(197) - g(143) = .375d0*f(178)+.125d0*f(180)+.125d0*f(187) - & +.375d0*f(196) - g(144) = .375d0*f(177)+.125d0*f(181)+.125d0*f(186) - & +.375d0*f(197) - g(145) = -.375d0*f(178)+.125d0*f(180)-.125d0*f(187) - & +.375d0*f(196) - g(146) = .25d0*f(122)+.25d0*f(131)-.25d0*f(158) - & -.25d0*f(167) - g(147) = .25d0*f(123)+.25d0*f(132)+.25d0*f(157)+.25d0*f(166) - g(148) = .25d0*f(122)+.25d0*f(131)+.25d0*f(158)+.25d0*f(167) - g(149) = -.25d0*f(123)-.25d0*f(132)+.25d0*f(157)+.25d0*f(166) - g(150) = .25d0*f(97)-.25d0*f(101)+.25d0*f(147) - & -.25d0*f(151) - g(151) = .25d0*f(98)+.25d0*f(100)+.25d0*f(148)+.25d0*f(150) - g(152) = .25d0*f(97)+.25d0*f(101)+.25d0*f(147)+.25d0*f(151) - g(153) = -.25d0*f(98)+.25d0*f(100)-.25d0*f(148)+.25d0*f(150) - g(154) = .125d0*f(88)-.125d0*f(94)-.125d0*f(108) - & +.125d0*f(144) - g(155) = .125d0*f(89)+.125d0*f(93)-.125d0*f(109) - & -.125d0*f(143) - g(156) = .125d0*f(88)+.125d0*f(94)-.125d0*f(108) - & -.125d0*f(144) - g(157) = -.125d0*f(89)+.125d0*f(93)+.125d0*f(109) - & -.125d0*f(143) - g(158) = .125d0*f(177)-.125d0*f(181)-.125d0*f(186) - & +.125d0*f(197) - g(159) = .125d0*f(178)+.125d0*f(180)-.125d0*f(187) - & -.125d0*f(196) - g(160) = .125d0*f(177)+.125d0*f(181)-.125d0*f(186) - & -.125d0*f(197) - g(161) = -.125d0*f(178)+.125d0*f(180)+.125d0*f(187) - & -.125d0*f(196) - g(162) = .125d0*f(97)-.125d0*f(101)-.125d0*f(113) - & -.125d0*f(115)-.125d0*f(147)+.125d0*f(151) - g(163) = .125d0*f(98)+.125d0*f(100)+.125d0*f(112) - & -.125d0*f(116)-.125d0*f(148)-.125d0*f(150) - g(164) = .125d0*f(97)+.125d0*f(101)+.125d0*f(113) - & -.125d0*f(115)-.125d0*f(147)-.125d0*f(151) - g(165) = -.125d0*f(98)+.125d0*f(100)+.125d0*f(112) - & +.125d0*f(116)+.125d0*f(148)-.125d0*f(150) - g(166) = .125d0*f(122)-.125d0*f(126)-.125d0*f(131) - & -.125d0*f(158)-.125d0*f(160)+.125d0*f(167) - g(167) = .125d0*f(123)+.125d0*f(125)-.125d0*f(132) - & +.125d0*f(157)-.125d0*f(161)-.125d0*f(166) - g(168) = .125d0*f(122)+.125d0*f(126)-.125d0*f(131) - & +.125d0*f(158)-.125d0*f(160)-.125d0*f(167) - g(169) = -.125d0*f(123)+.125d0*f(125)+.125d0*f(132) - & +.125d0*f(157)+.125d0*f(161)-.125d0*f(166) - g(170) = .125d0*f(97)+.125d0*f(101)-.125d0*f(113) - & +.125d0*f(115)-.125d0*f(147)-.125d0*f(151) - g(171) = .125d0*f(98)-.125d0*f(100)+.125d0*f(112) - & +.125d0*f(116)-.125d0*f(148)+.125d0*f(150) - g(172) = .125d0*f(97)-.125d0*f(101)+.125d0*f(113) - & +.125d0*f(115)-.125d0*f(147)+.125d0*f(151) - g(173) = -.125d0*f(98)-.125d0*f(100)+.125d0*f(112) - & -.125d0*f(116)+.125d0*f(148)+.125d0*f(150) - g(174) = .125d0*f(122)-.125d0*f(126)-.125d0*f(131) - & +.125d0*f(158)+.125d0*f(160)-.125d0*f(167) - g(175) = -.125d0*f(123)-.125d0*f(125)+.125d0*f(132) - & +.125d0*f(157)-.125d0*f(161)-.125d0*f(166) - g(176) = .125d0*f(122)+.125d0*f(126)-.125d0*f(131) - & -.125d0*f(158)+.125d0*f(160)+.125d0*f(167) - g(177) = .125d0*f(123)-.125d0*f(125)-.125d0*f(132) - & +.125d0*f(157)+.125d0*f(161)-.125d0*f(166) - g(178) = .5d0*f(84)-.5d0*f(140) - g(179) = .25d0*f(85)+.25d0*f(105) - g(180) = .5d0*f(175)-.5d0*f(195) - g(181) = .25d0*f(176)+.25d0*f(185) - g(182) = .25d0*f(95)+.25d0*f(99)-.25d0*f(145)-.25d0*f(149) - g(183) = .25d0*f(110)+.25d0*f(114) - g(184) = .25d0*f(95)-.25d0*f(99)+.25d0*f(145)-.25d0*f(149) - g(185) = .25d0*f(96)+.25d0*f(146) - g(186) = .375d0*f(86)-.125d0*f(92)+.125d0*f(106) - & -.375d0*f(142) - g(187) = .375d0*f(87)+.125d0*f(91)+.125d0*f(107) - & +.375d0*f(141) - g(188) = .375d0*f(120)+.125d0*f(124)-.125d0*f(156) - & -.375d0*f(165) - g(189) = .125d0*f(121)+.375d0*f(130)+.375d0*f(155) - & +.125d0*f(159) - g(190) = .375d0*f(86)+.125d0*f(92)+.125d0*f(106) - & +.375d0*f(142) - g(191) = -.375d0*f(87)+.125d0*f(91)-.125d0*f(107) - & +.375d0*f(141) - g(192) = .375d0*f(120)+.125d0*f(124)+.125d0*f(156) - & +.375d0*f(165) - g(193) = -.125d0*f(121)-.375d0*f(130)+.375d0*f(155) - & +.125d0*f(159) - g(194) = .125d0*f(84)-.125d0*f(90)+.125d0*f(140) - g(195) = .125d0*f(85)-.125d0*f(105) - g(196) = .125d0*f(175)-.125d0*f(179)+.125d0*f(195) - g(197) = .125d0*f(176)-.125d0*f(185) - g(198) = .125d0*f(86)-.125d0*f(92)-.125d0*f(106) - & +.125d0*f(142) - g(199) = .125d0*f(87)+.125d0*f(91)-.125d0*f(107) - & -.125d0*f(141) - g(200) = .125d0*f(120)-.125d0*f(124)-.125d0*f(156) - & +.125d0*f(165) - g(201) = .125d0*f(121)-.125d0*f(130)+.125d0*f(155) - & -.125d0*f(159) - g(202) = .125d0*f(86)+.125d0*f(92)-.125d0*f(106) - & -.125d0*f(142) - g(203) = -.125d0*f(87)+.125d0*f(91)+.125d0*f(107) - & -.125d0*f(141) - g(204) = .125d0*f(120)-.125d0*f(124)+.125d0*f(156) - & -.125d0*f(165) - g(205) = -.125d0*f(121)+.125d0*f(130)+.125d0*f(155) - & -.125d0*f(159) - g(206) = .125d0*f(95)-.125d0*f(99)-.125d0*f(111) - & -.125d0*f(145)+.125d0*f(149) - g(207) = .125d0*f(96)+.125d0*f(110)-.125d0*f(114) - & -.125d0*f(146) - g(208) = .125d0*f(95)-.125d0*f(99)+.125d0*f(111) - & -.125d0*f(145)+.125d0*f(149) - g(209) = -.125d0*f(96)+.125d0*f(110)-.125d0*f(114) - & +.125d0*f(146) - return - end -c -************************************************** - subroutine drtoc(g,f) -* -* change from dynamic resonance basis to cartesian -* g(*) : dynamic basis coefficints (input). -* f(*) : cartesion coefficients (output). -* -* F. Neri 6/2/1986 -* -************************************************** - use lieaparam, only : monoms -c implicit none - double precision f(monoms),g(monoms) -c - f(1) = 1.d0*g(1) - f(2) = 1.d0*g(2) - f(3) = 1.d0*g(3) - f(4) = 1.d0*g(4) - f(5) = 1.d0*g(5) - f(6) = 1.d0*g(6) - f(7) = 1.d0*g(7)+1.d0*g(20) - f(8) = 2.d0*g(21) - f(9) = 1.d0*g(24)+1.d0*g(26) - f(10) = 1.d0*g(25)-1.d0*g(27) - f(11) = 1.d0*g(12)+1.d0*g(14) - f(12) = 1.d0*g(13)-1.d0*g(15) - f(13) = 1.d0*g(7)-1.d0*g(20) - f(14) = 1.d0*g(25)+1.d0*g(27) - f(15) = -1.d0*g(24)+1.d0*g(26) - f(16) = 1.d0*g(13)+1.d0*g(15) - f(17) = -1.d0*g(12)+1.d0*g(14) - f(18) = 1.d0*g(8)+1.d0*g(22) - f(19) = 2.d0*g(23) - f(20) = 1.d0*g(16)+1.d0*g(18) - f(21) = 1.d0*g(17)-1.d0*g(19) - f(22) = 1.d0*g(8)-1.d0*g(22) - f(23) = 1.d0*g(17)+1.d0*g(19) - f(24) = -1.d0*g(16)+1.d0*g(18) - f(25) = 1.d0*g(9)+1.d0*g(10) - f(26) = 2.d0*g(11) - f(27) = 1.d0*g(9)-1.d0*g(10) - f(28) = 1.d0*g(64)+1.d0*g(72) - f(29) = 1.d0*g(65)+3.d0*g(73) - f(30) = 1.d0*g(70)+1.d0*g(76)+1.d0*g(80) - f(31) = 1.d0*g(71)+1.d0*g(77)-1.d0*g(81) - f(32) = 1.d0*g(28)+1.d0*g(48)+1.d0*g(50) - f(33) = 1.d0*g(29)+1.d0*g(49)-1.d0*g(51) - f(34) = 1.d0*g(64)-3.d0*g(72) - f(35) = 2.d0*g(77)+2.d0*g(81) - f(36) = -2.d0*g(76)+2.d0*g(80) - f(37) = 2.d0*g(49)+2.d0*g(51) - f(38) = -2.d0*g(48)+2.d0*g(50) - f(39) = 1.d0*g(68)+1.d0*g(78)+1.d0*g(82) - f(40) = 2.d0*g(79)-2.d0*g(83) - f(41) = 1.d0*g(56)+1.d0*g(58)+1.d0*g(60)+1.d0*g(62) - f(42) = 1.d0*g(57)-1.d0*g(59)+1.d0*g(61)-1.d0*g(63) - f(43) = 1.d0*g(68)-1.d0*g(78)-1.d0*g(82) - f(44) = 1.d0*g(57)+1.d0*g(59)-1.d0*g(61)-1.d0*g(63) - f(45) = -1.d0*g(56)+1.d0*g(58)+1.d0*g(60)-1.d0*g(62) - f(46) = 1.d0*g(36)+1.d0*g(40)+1.d0*g(42) - f(47) = 2.d0*g(41)-2.d0*g(43) - f(48) = 1.d0*g(36)-1.d0*g(40)-1.d0*g(42) - f(49) = 1.d0*g(65)-1.d0*g(73) - f(50) = 1.d0*g(70)-1.d0*g(76)-1.d0*g(80) - f(51) = 1.d0*g(71)-1.d0*g(77)+1.d0*g(81) - f(52) = 1.d0*g(28)-1.d0*g(48)-1.d0*g(50) - f(53) = 1.d0*g(29)-1.d0*g(49)+1.d0*g(51) - f(54) = 1.d0*g(69)+1.d0*g(79)+1.d0*g(83) - f(55) = -2.d0*g(78)+2.d0*g(82) - f(56) = 1.d0*g(57)+1.d0*g(59)+1.d0*g(61)+1.d0*g(63) - f(57) = -1.d0*g(56)+1.d0*g(58)-1.d0*g(60)+1.d0*g(62) - f(58) = 1.d0*g(69)-1.d0*g(79)-1.d0*g(83) - f(59) = -1.d0*g(56)-1.d0*g(58)+1.d0*g(60)+1.d0*g(62) - f(60) = -1.d0*g(57)+1.d0*g(59)+1.d0*g(61)-1.d0*g(63) - f(61) = 1.d0*g(37)+1.d0*g(41)+1.d0*g(43) - f(62) = -2.d0*g(40)+2.d0*g(42) - f(63) = 1.d0*g(37)-1.d0*g(41)-1.d0*g(43) - f(64) = 1.d0*g(66)+1.d0*g(74) - f(65) = 1.d0*g(67)+3.d0*g(75) - f(66) = 1.d0*g(30)+1.d0*g(52)+1.d0*g(54) - f(67) = 1.d0*g(31)+1.d0*g(53)-1.d0*g(55) - f(68) = 1.d0*g(66)-3.d0*g(74) - f(69) = 2.d0*g(53)+2.d0*g(55) - f(70) = -2.d0*g(52)+2.d0*g(54) - f(71) = 1.d0*g(38)+1.d0*g(44)+1.d0*g(46) - f(72) = 2.d0*g(45)-2.d0*g(47) - f(73) = 1.d0*g(38)-1.d0*g(44)-1.d0*g(46) - f(74) = 1.d0*g(67)-1.d0*g(75) - f(75) = 1.d0*g(30)-1.d0*g(52)-1.d0*g(54) - f(76) = 1.d0*g(31)-1.d0*g(53)+1.d0*g(55) - f(77) = 1.d0*g(39)+1.d0*g(45)+1.d0*g(47) - f(78) = -2.d0*g(44)+2.d0*g(46) - f(79) = 1.d0*g(39)-1.d0*g(45)-1.d0*g(47) - f(80) = 1.d0*g(32)+1.d0*g(34) - f(81) = 3.d0*g(33)+1.d0*g(35) - f(82) = -3.d0*g(32)+1.d0*g(34) - f(83) = -1.d0*g(33)+1.d0*g(35) - f(84) = 1.d0*g(84)+1.d0*g(178)+1.d0*g(194) - f(85) = 2.d0*g(179)+4.d0*g(195) - f(86) = 1.d0*g(186)+1.d0*g(190)+1.d0*g(198)+1.d0*g(202) - f(87) = 1.d0*g(187)-1.d0*g(191)+1.d0*g(199)-1.d0*g(203) - f(88) = 1.d0*g(138)+1.d0*g(140)+1.d0*g(154)+1.d0*g(156) - f(89) = 1.d0*g(139)-1.d0*g(141)+1.d0*g(155)-1.d0*g(157) - f(90) = 2.d0*g(84)-6.d0*g(194) - f(91) = 1.d0*g(187)+1.d0*g(191)+3.d0*g(199)+3.d0*g(203) - f(92) = -1.d0*g(186)+1.d0*g(190)-3.d0*g(198)+3.d0*g(202) - f(93) = 1.d0*g(139)+1.d0*g(141)+3.d0*g(155)+3.d0*g(157) - f(94) = -1.d0*g(138)+1.d0*g(140)-3.d0*g(154)+3.d0*g(156) - f(95) = 1.d0*g(87)+1.d0*g(182)+1.d0*g(184)+1.d0*g(206) - & +1.d0*g(208) - f(96) = 2.d0*g(185)+2.d0*g(207)-2.d0*g(209) - f(97) = 1.d0*g(150)+1.d0*g(152)+1.d0*g(162)+1.d0*g(164) - & +1.d0*g(170)+1.d0*g(172) - f(98) = 1.d0*g(151)-1.d0*g(153)+1.d0*g(163)-1.d0*g(165) - & +1.d0*g(171)-1.d0*g(173) - f(99) = 1.d0*g(87)+1.d0*g(182)-1.d0*g(184)-1.d0*g(206) - & -1.d0*g(208) - f(100) = 1.d0*g(151)+1.d0*g(153)+1.d0*g(163)+1.d0*g(165) - & -1.d0*g(171)-1.d0*g(173) - f(101) = -1.d0*g(150)+1.d0*g(152)-1.d0*g(162)+1.d0*g(164) - & +1.d0*g(170)-1.d0*g(172) - f(102) = 1.d0*g(88)+1.d0*g(90)+1.d0*g(114)+1.d0*g(118) - & +1.d0*g(120) - f(103) = 2.d0*g(91)+2.d0*g(119)-2.d0*g(121) - f(104) = 1.d0*g(88)-1.d0*g(90)+1.d0*g(114)-1.d0*g(118) - & -1.d0*g(120) - f(105) = 2.d0*g(179)-4.d0*g(195) - f(106) = 1.d0*g(186)+1.d0*g(190)-3.d0*g(198)-3.d0*g(202) - f(107) = 1.d0*g(187)-1.d0*g(191)-3.d0*g(199)+3.d0*g(203) - f(108) = 1.d0*g(138)+1.d0*g(140)-3.d0*g(154)-3.d0*g(156) - f(109) = 1.d0*g(139)-1.d0*g(141)-3.d0*g(155)+3.d0*g(157) - f(110) = 2.d0*g(183)+2.d0*g(207)+2.d0*g(209) - f(111) = -4.d0*g(206)+4.d0*g(208) - f(112) = 2.d0*g(163)+2.d0*g(165)+2.d0*g(171)+2.d0*g(173) - f(113) = -2.d0*g(162)+2.d0*g(164)-2.d0*g(170)+2.d0*g(172) - f(114) = 2.d0*g(183)-2.d0*g(207)-2.d0*g(209) - f(115) = -2.d0*g(162)-2.d0*g(164)+2.d0*g(170)+2.d0*g(172) - f(116) = -2.d0*g(163)+2.d0*g(165)+2.d0*g(171)-2.d0*g(173) - f(117) = 2.d0*g(115)+2.d0*g(119)+2.d0*g(121) - f(118) = -4.d0*g(118)+4.d0*g(120) - f(119) = 2.d0*g(115)-2.d0*g(119)-2.d0*g(121) - f(120) = 1.d0*g(188)+1.d0*g(192)+1.d0*g(200)+1.d0*g(204) - f(121) = 1.d0*g(189)-1.d0*g(193)+3.d0*g(201)-3.d0*g(205) - f(122) = 1.d0*g(146)+1.d0*g(148)+1.d0*g(166)+1.d0*g(168) - & +1.d0*g(174)+1.d0*g(176) - f(123) = 1.d0*g(147)-1.d0*g(149)+1.d0*g(167)-1.d0*g(169) - & -1.d0*g(175)+1.d0*g(177) - f(124) = 1.d0*g(188)+1.d0*g(192)-3.d0*g(200)-3.d0*g(204) - f(125) = 2.d0*g(167)+2.d0*g(169)-2.d0*g(175)-2.d0*g(177) - f(126) = -2.d0*g(166)+2.d0*g(168)-2.d0*g(174)+2.d0*g(176) - f(127) = 1.d0*g(126)+1.d0*g(128)+1.d0*g(130)+1.d0*g(132) - & +1.d0*g(134)+1.d0*g(136) - f(128) = 2.d0*g(131)-2.d0*g(133)+2.d0*g(135)-2.d0*g(137) - f(129) = 1.d0*g(126)+1.d0*g(128)-1.d0*g(130)-1.d0*g(132) - & -1.d0*g(134)-1.d0*g(136) - f(130) = 1.d0*g(189)-1.d0*g(193)-1.d0*g(201)+1.d0*g(205) - f(131) = 1.d0*g(146)+1.d0*g(148)-1.d0*g(166)-1.d0*g(168) - & -1.d0*g(174)-1.d0*g(176) - f(132) = 1.d0*g(147)-1.d0*g(149)-1.d0*g(167)+1.d0*g(169) - & +1.d0*g(175)-1.d0*g(177) - f(133) = 1.d0*g(127)-1.d0*g(129)+1.d0*g(131)+1.d0*g(133) - & -1.d0*g(135)-1.d0*g(137) - f(134) = -2.d0*g(130)+2.d0*g(132)+2.d0*g(134)-2.d0*g(136) - f(135) = 1.d0*g(127)-1.d0*g(129)-1.d0*g(131)-1.d0*g(133) - & +1.d0*g(135)+1.d0*g(137) - f(136) = 1.d0*g(98)+1.d0*g(100)+1.d0*g(106)+1.d0*g(108) - f(137) = 3.d0*g(99)-3.d0*g(101)+1.d0*g(107)-1.d0*g(109) - f(138) = -3.d0*g(98)-3.d0*g(100)+1.d0*g(106)+1.d0*g(108) - f(139) = -1.d0*g(99)+1.d0*g(101)+1.d0*g(107)-1.d0*g(109) - f(140) = 1.d0*g(84)-1.d0*g(178)+1.d0*g(194) - f(141) = 1.d0*g(187)+1.d0*g(191)-1.d0*g(199)-1.d0*g(203) - f(142) = -1.d0*g(186)+1.d0*g(190)+1.d0*g(198)-1.d0*g(202) - f(143) = 1.d0*g(139)+1.d0*g(141)-1.d0*g(155)-1.d0*g(157) - f(144) = -1.d0*g(138)+1.d0*g(140)+1.d0*g(154)-1.d0*g(156) - f(145) = 1.d0*g(87)-1.d0*g(182)+1.d0*g(184)-1.d0*g(206) - & -1.d0*g(208) - f(146) = 2.d0*g(185)-2.d0*g(207)+2.d0*g(209) - f(147) = 1.d0*g(150)+1.d0*g(152)-1.d0*g(162)-1.d0*g(164) - & -1.d0*g(170)-1.d0*g(172) - f(148) = 1.d0*g(151)-1.d0*g(153)-1.d0*g(163)+1.d0*g(165) - & -1.d0*g(171)+1.d0*g(173) - f(149) = 1.d0*g(87)-1.d0*g(182)-1.d0*g(184)+1.d0*g(206) - & +1.d0*g(208) - f(150) = 1.d0*g(151)+1.d0*g(153)-1.d0*g(163)-1.d0*g(165) - & +1.d0*g(171)+1.d0*g(173) - f(151) = -1.d0*g(150)+1.d0*g(152)+1.d0*g(162)-1.d0*g(164) - & -1.d0*g(170)+1.d0*g(172) - f(152) = 1.d0*g(88)+1.d0*g(90)-1.d0*g(114)-1.d0*g(118) - & -1.d0*g(120) - f(153) = 2.d0*g(91)-2.d0*g(119)+2.d0*g(121) - f(154) = 1.d0*g(88)-1.d0*g(90)-1.d0*g(114)+1.d0*g(118) - & +1.d0*g(120) - f(155) = 1.d0*g(189)+1.d0*g(193)+1.d0*g(201)+1.d0*g(205) - f(156) = -1.d0*g(188)+1.d0*g(192)-3.d0*g(200)+3.d0*g(204) - f(157) = 1.d0*g(147)+1.d0*g(149)+1.d0*g(167)+1.d0*g(169) - & +1.d0*g(175)+1.d0*g(177) - f(158) = -1.d0*g(146)+1.d0*g(148)-1.d0*g(166)+1.d0*g(168) - & +1.d0*g(174)-1.d0*g(176) - f(159) = 1.d0*g(189)+1.d0*g(193)-3.d0*g(201)-3.d0*g(205) - f(160) = -2.d0*g(166)-2.d0*g(168)+2.d0*g(174)+2.d0*g(176) - f(161) = -2.d0*g(167)+2.d0*g(169)-2.d0*g(175)+2.d0*g(177) - f(162) = 1.d0*g(127)+1.d0*g(129)+1.d0*g(131)+1.d0*g(133) - & +1.d0*g(135)+1.d0*g(137) - f(163) = -2.d0*g(130)+2.d0*g(132)-2.d0*g(134)+2.d0*g(136) - f(164) = 1.d0*g(127)+1.d0*g(129)-1.d0*g(131)-1.d0*g(133) - & -1.d0*g(135)-1.d0*g(137) - f(165) = -1.d0*g(188)+1.d0*g(192)+1.d0*g(200)-1.d0*g(204) - f(166) = 1.d0*g(147)+1.d0*g(149)-1.d0*g(167)-1.d0*g(169) - & -1.d0*g(175)-1.d0*g(177) - f(167) = -1.d0*g(146)+1.d0*g(148)+1.d0*g(166)-1.d0*g(168) - & -1.d0*g(174)+1.d0*g(176) - f(168) = -1.d0*g(126)+1.d0*g(128)-1.d0*g(130)-1.d0*g(132) - & +1.d0*g(134)+1.d0*g(136) - f(169) = -2.d0*g(131)+2.d0*g(133)+2.d0*g(135)-2.d0*g(137) - f(170) = -1.d0*g(126)+1.d0*g(128)+1.d0*g(130)+1.d0*g(132) - & -1.d0*g(134)-1.d0*g(136) - f(171) = 1.d0*g(99)+1.d0*g(101)+1.d0*g(107)+1.d0*g(109) - f(172) = -3.d0*g(98)+3.d0*g(100)-1.d0*g(106)+1.d0*g(108) - f(173) = -3.d0*g(99)-3.d0*g(101)+1.d0*g(107)+1.d0*g(109) - f(174) = 1.d0*g(98)-1.d0*g(100)-1.d0*g(106)+1.d0*g(108) - f(175) = 1.d0*g(85)+1.d0*g(180)+1.d0*g(196) - f(176) = 2.d0*g(181)+4.d0*g(197) - f(177) = 1.d0*g(142)+1.d0*g(144)+1.d0*g(158)+1.d0*g(160) - f(178) = 1.d0*g(143)-1.d0*g(145)+1.d0*g(159)-1.d0*g(161) - f(179) = 2.d0*g(85)-6.d0*g(196) - f(180) = 1.d0*g(143)+1.d0*g(145)+3.d0*g(159)+3.d0*g(161) - f(181) = -1.d0*g(142)+1.d0*g(144)-3.d0*g(158)+3.d0*g(160) - f(182) = 1.d0*g(89)+1.d0*g(92)+1.d0*g(116)+1.d0*g(122) - & +1.d0*g(124) - f(183) = 2.d0*g(93)+2.d0*g(123)-2.d0*g(125) - f(184) = 1.d0*g(89)-1.d0*g(92)+1.d0*g(116)-1.d0*g(122) - & -1.d0*g(124) - f(185) = 2.d0*g(181)-4.d0*g(197) - f(186) = 1.d0*g(142)+1.d0*g(144)-3.d0*g(158)-3.d0*g(160) - f(187) = 1.d0*g(143)-1.d0*g(145)-3.d0*g(159)+3.d0*g(161) - f(188) = 2.d0*g(117)+2.d0*g(123)+2.d0*g(125) - f(189) = -4.d0*g(122)+4.d0*g(124) - f(190) = 2.d0*g(117)-2.d0*g(123)-2.d0*g(125) - f(191) = 1.d0*g(102)+1.d0*g(104)+1.d0*g(110)+1.d0*g(112) - f(192) = 3.d0*g(103)-3.d0*g(105)+1.d0*g(111)-1.d0*g(113) - f(193) = -3.d0*g(102)-3.d0*g(104)+1.d0*g(110)+1.d0*g(112) - f(194) = -1.d0*g(103)+1.d0*g(105)+1.d0*g(111)-1.d0*g(113) - f(195) = 1.d0*g(85)-1.d0*g(180)+1.d0*g(196) - f(196) = 1.d0*g(143)+1.d0*g(145)-1.d0*g(159)-1.d0*g(161) - f(197) = -1.d0*g(142)+1.d0*g(144)+1.d0*g(158)-1.d0*g(160) - f(198) = 1.d0*g(89)+1.d0*g(92)-1.d0*g(116)-1.d0*g(122) - & -1.d0*g(124) - f(199) = 2.d0*g(93)-2.d0*g(123)+2.d0*g(125) - f(200) = 1.d0*g(89)-1.d0*g(92)-1.d0*g(116)+1.d0*g(122) - & +1.d0*g(124) - f(201) = 1.d0*g(103)+1.d0*g(105)+1.d0*g(111)+1.d0*g(113) - f(202) = -3.d0*g(102)+3.d0*g(104)-1.d0*g(110)+1.d0*g(112) - f(203) = -3.d0*g(103)-3.d0*g(105)+1.d0*g(111)+1.d0*g(113) - f(204) = 1.d0*g(102)-1.d0*g(104)-1.d0*g(110)+1.d0*g(112) - f(205) = 1.d0*g(86)+1.d0*g(94)+1.d0*g(96) - f(206) = 4.d0*g(95)+2.d0*g(97) - f(207) = 2.d0*g(86)-6.d0*g(94) - f(208) = -4.d0*g(95)+2.d0*g(97) - f(209) = 1.d0*g(86)+1.d0*g(94)-1.d0*g(96) - return - end -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/bessjm.f b/OpticsJan2020/MLI_light_optics/Src/bessjm.f deleted file mode 100644 index 5e71940..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/bessjm.f +++ /dev/null @@ -1,723 +0,0 @@ -c*********************************************************************** -c -c Bessel functions of the first kind. -c D.T.Abell, Tech-X Corp., November 2003. -c -c Updated December 2005---improved rational approximations, obtained by -c comparison with Mathematica's high-precision Bessel function values. -c -c*********************************************************************** - subroutine dbessj0(x,bj0) -c Bessel function of the first kind, order zero: bj0 = J_0(x). - implicit none - double precision x,bj0 -c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! - double precision Pi,Pid4 - double precision ax,t,pp,qq -c -c coefficients for rational approximations - double precision rabj0an(11),rabj0ad(11),rabj0bn(11),rabj0bd(11) - double precision rabj0cn(11),rabj0cd(11),rabj0dn(11),rabj0dd(11) - double precision rabj0en(11),rabj0ed(11),rabj0fn( 7),rabj0fd( 7) - data rabj0an / - &+1.0000000000000000000050179699999091D+00, - &-8.8230193349303631019069286292273592D-02, - &-2.2778858233747603162266489897356056D-01, - &+2.0341718595179019764036039758709466D-02, - &+1.0311930796055483981361241333992624D-02, - &-9.6558198466558060525000633951901562D-04, - &-1.4534545971264389949915743465588711D-04, - &+1.5385739184044285945395365895073623D-05, - &+5.0024280550288686235912958144335425D-07, - &-8.1837015732913880463394834114513691D-08, - &+1.8402156332042362862773578704341447D-09/ - data rabj0ad / - &+1.0000000000000000000000000000000000D+00, - &-8.8230193349303629919583311940311153D-02, - &+2.2211417662523928303822343473518375D-02, - &-1.7158297421463074264424446502031107D-03, - &+2.3978521168201685670512690979806517D-04, - &-1.5942649098416680654142008778904110D-05, - &+1.5752199434140609397499317066559390D-06, - &-8.4437977811612729526150890484969979D-08, - &+6.0918476815384520168977485010843715D-09, - &-2.1081214567148162491668339094873657D-10, - &+9.5689922998775932286006136295490244D-12/ - data rabj0bn / - &+0.9999947618451229408378453732245815D+00, - &-2.1079067749100990034907737987252581D-01, - &-2.1153610058761303594734319673660807D-01, - &+4.7914960041618770111290430390100304D-02, - &+6.4925682382712033512704530646438245D-03, - &-2.1181715676820241543828289838391954D-03, - &+3.5262828624115159195904623163278898D-05, - &+2.8964640803552355496585442664205909D-05, - &-3.1467459340839512757355221349774376D-06, - &+1.3056612961826745813193969076704308D-07, - &-1.9723613039425622244289372840306964D-09/ - data rabj0bd / - &+1.0000000000000000000000000000000000D+00, - &-2.1080954250115548577070508093772022D-01, - &+3.8495956449617845060277310851005345D-02, - &-4.8215559602633320002172981719561965D-03, - &+5.1704518623798707902299649434725156D-04, - &-4.3816500419579022209215618337287690D-05, - &+3.0961318132620954195784080539882816D-06, - &-1.6985374380267480945014770381800044D-07, - &+7.1683418472403236347208318913158728D-09, - &-2.0143582141730917107139467960886491D-10, - &+3.2401851766762590203597072719481002D-12/ - data rabj0cn / - &+4.8896470117798136933960119243767237D-02, - &-1.9199232842235873850450795814434952D-03, - &-5.7862889184410290524315292285640746D-02, - &+3.9102508961576130540892154545854854D-02, - &-1.1494590155653841967222931097121521D-02, - &+1.8803934283457853100848553874229646D-03, - &-1.8640431669347982491495399716692452D-04, - &+1.1474374355794768767774947971846314D-05, - &-4.2933509072418537179570698396689563D-07, - &+8.9528106522417889070362524823241969D-09, - &-7.9882819654637042538953026938994769D-11/ - data rabj0cd / - &+1.0000000000000000000000000000000000D+00, - &-1.1329555327217814998913315706968691D+00, - &+3.2591109585817699371371552353553638D-01, - &-5.7426238664400627746092218763981592D-02, - &+6.9805158757947823161383120930805137D-03, - &-6.1938100100437024756343054169434183D-04, - &+4.0427188509225439620395057691850240D-05, - &-1.9137212931564333474744008597798173D-06, - &+6.2684456139853366202327362897514514D-08, - &-1.2847022551902166826121217722839446D-09, - &+1.2563046316660055826508853359682238D-11/ - data rabj0dn / - &-1.2855106884992982411556047079499048D-02, - &+7.3122100400657976523877937106051494D-02, - &-5.3227204991088052536112979278795060D-02, - &+1.7018649354405257105380788618114423D-02, - &-3.0419674749227155566039454550406450D-03, - &+3.3475526134474814407534241200383970D-04, - &-2.3600739767436000858506331588751560D-05, - &+1.0701657071023291919125855988389812D-06, - &-3.0207072100726981004102397058083471D-08, - &+4.8321242798880922243680861245207648D-10, - &-3.3474933906957231905826150510301703D-12/ - data rabj0dd / - &+1.0000000000000000000000000000000000D+00, - &-3.2944072183253369366766487533934724D-01, - &+6.0965775940009661518427458794047474D-02, - &-7.5921317989016470654981426275636095D-03, - &+6.8802934300040013792164096446792849D-04, - &-4.6422034672029920649858016846729019D-05, - &+2.3380523557789858162629933228290598D-06, - &-8.6093073725985170178907421779610271D-08, - &+2.2141159560680130851824587967869377D-09, - &-3.5909539384246578384084604881458476D-11, - &+2.8364122289958662381014742871402263D-13/ - data rabj0en / - &+3.5224646241387634580428630255239534D-01, - &-2.7856689678561711255883463632505246D-01, - &+9.3729467733125313886079046699370299D-02, - &-1.7776325167929891943907611157376352D-02, - &+2.1156292810051315475968635296554389D-03, - &-1.6585801993726409351607592862093892D-04, - &+8.7086646940913853360940919270539488D-06, - &-3.0345030581942515926188590998173107D-07, - &+6.7356307310329723356037410610211086D-09, - &-8.6230544824987840642736370362678861D-11, - &+4.8463254940494631096363486040475736D-13/ - data rabj0ed / - &+1.0000000000000000000000000000000000D+00, - &-3.9437749159126193952363812178419292D-01, - &+7.7581865230995871051567171336090776D-02, - &-9.6726853312945266401280401225401609D-03, - &+8.3352527419529980773115111930086124D-04, - &-5.1371247731535664030011300083139149D-05, - &+2.2801094464620980467671861325928996D-06, - &-7.1714183814137341630980676930651847D-08, - &+1.5275616049573480145724295285266087D-09, - &-1.9906555330977615027102660888016815D-11, - &+1.2106511741132039245923717952671393D-13/ - data rabj0fn / - &-9.4845363290573921489820379821276979D-02, - &+2.8600548026603177758882128713536768D-02, - &-3.5476668104961868720495540952881358D-03, - &+2.3179029870614323398028994082351304D-04, - &-8.4165980090902303831222302065086657D-06, - &+1.6111527211980360198505293917220034D-07, - &-1.2708319802262517343077780038561572D-09/ - data rabj0fd / - &+1.0000000000000000000000000000000000D+00, - &-2.6409647927463548120030732742120998D-01, - &+2.9860012401515139424647801546743694D-02, - &-1.8401803786971692142522329594649180D-03, - &+6.5061344201723819188622837380416900D-05, - &-1.2504130549754413803085326308427806D-06, - &+1.0221043546656880551547140513637591D-08/ -c -c compute constants - Pi=2.d0*dasin(1.d0) - Pid4=0.25d0*Pi -c -c J_0(x) is even in x, so we use |x| - ax=dabs(x) -c -c use approximation appropriate to value of x: -c range (0,4): rational approximation of J_0(x) -c range [4,8): rational approximation of J_0(x) -c range [8,12): rational approximation of -c J_0(x)-sqrt(2/(pi*x))*cos(x-pi/4) -c range [12,15): rational approximation of -c J_0(x)-sqrt(2/(pi*x))*cos(x-pi/4) -c range [15,20): rational approximation of -c J_0(x)-sqrt(2/(pi*x))*cos(x-pi/4) -c range [20,21): rational approximation of -c J_0(x)-sqrt(2/(pi*x))*cos(x-pi/4) -c range [21,infinity): Hankel's asymptotic expansion -c - if (ax.eq.0.d0) then - bj0=1.d0 - else if (ax.lt.4.d0) then - call ratappr(ax,rabj0an,11,rabj0ad,11,bj0) - else if (ax.lt.8.d0) then - call ratappr(ax,rabj0bn,11,rabj0bd,11,bj0) - else if (ax.lt.12.d0) then - call ratappr(ax,rabj0cn,11,rabj0cd,11,bj0) - bj0=bj0+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pid4) - else if (ax.lt.15.d0) then - call ratappr(ax,rabj0dn,11,rabj0dd,11,bj0) - bj0=bj0+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pid4) - else if (ax.lt.20.d0) then - call ratappr(ax,rabj0en,11,rabj0ed,11,bj0) - bj0=bj0+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pid4) - else if (ax.lt.21.d0) then - call ratappr(ax,rabj0fn,7,rabj0fd,7,bj0) - bj0=bj0+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pid4) - else - t=ax-Pid4 - call HankelPQ(0,ax,pp,qq) - bj0=dsqrt(2.d0/(Pi*ax))*(pp*dcos(t)-qq*dsin(t)) - end if -c - return - end -c -c*********************************************************************** - subroutine dbessj1(x,bj1) -c Bessel function of the first kind, order one: bj1 = J_1(x). - implicit none - double precision x,bj1 -c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! - double precision Pi,Pi3d4 - double precision ax,t,pp,qq,sgn -c -c coefficients for rational approximations - double precision rabj1an(11),rabj1ad(11),rabj1bn(11),rabj1bd(11) - double precision rabj1cn(11),rabj1cd(11),rabj1dn(11),rabj1dd(11) - double precision rabj1en(11),rabj1ed(11),rabj1fn( 7),rabj1fd( 7) - data rabj1an / - &+1.3024604716812625136575985066550351D-21, - &+4.9999999999999999971769784794883053D-01, - &-2.7021475700860125161066293561710086D-02, - &-5.3285436029298919304319635517409686D-02, - &+2.9036486061909128531536930260765731D-03, - &+1.5368020011789656151354698315581584D-03, - &-8.5478332785495533785549719799392937D-05, - &-1.6331599044080528432091645493034297D-05, - &+9.4299064900371993501932762368482883D-07, - &+5.9154546709636257637272914412136624D-08, - &-3.6255546773750573374562132519289283D-09/ - data rabj1ad / - &+1.0000000000000000000000000000000000D+00, - &-5.4042951401720270639311664158490582D-02, - &+1.8429127941402451229391111842933448D-02, - &-9.4807171283539186854248011429003618D-04, - &+1.6891166170994095677427891725156792D-04, - &-7.9919244887708660985328880211035730D-06, - &+9.7266277426087547516841459653563922D-07, - &-3.9171386712324223695277101066676514D-08, - &+3.4953779352137137722880097405620162D-09, - &-9.4952410837245606026644100187155292D-11, - &+5.8322537268273354279510519335860106D-12/ - data rabj1bn / - &-9.6126582523756719172017705951900558D-06, - &+5.0003360984690369391627958263960859D-01, - &-1.0135247312540184243931882056358513D-01, - &-4.2699412675762871627685186040163278D-02, - &+1.0044781754253024712239985871722026D-02, - &+4.5619419956893940475029673398794519D-04, - &-2.4129439668031979459455941679644064D-04, - &+1.6016153674406627617877625760637880D-05, - &+2.1027192253057843266329778129856985D-07, - &-5.0707491857311754051124557929869265D-08, - &+1.2617640048087146823185552850801499D-09/ - data rabj1bd / - &+1.0000000000000000000000000000000000D+00, - &-2.0259445599160107275639117333790023D-01, - &+3.9487894299400709115590578713486066D-02, - &-5.1537400250629675578459531550226451D-03, - &+5.9728087755675845907468596531647125D-04, - &-5.4444672786583878044335341357153240D-05, - &+4.2045344283680687094812530071394440D-06, - &-2.5132379473265406943787755252580057D-07, - &+1.1653755299489430413597047842196229D-08, - &-3.5807396467498635498582625262060225D-10, - &+6.3908259113402294201974014102826536D-12/ - data rabj1cn / - &+6.0371438405985520492273239641094956D-01, - &-5.9666583821895112063164472546734882D-01, - &+2.6919847622163680583156066524301151D-01, - &-8.7672496487695919979136196550569105D-02, - &+2.1837199551259834491158951946045927D-02, - &-3.7370808859808720836608377144630291D-03, - &+4.1191847569201912836238278879683956D-04, - &-2.8438941172117570987518632348259140D-05, - &+1.1844617605399366234082982326828033D-06, - &-2.7169771614418824284498359366424714D-08, - &+2.6343527972027239886711798412892213D-10/ - data rabj1cd / - &+1.0000000000000000000000000000000000D+00, - &-1.6514728561739773326127601166782867D-01, - &+6.5774300517547309014897346964600873D-02, - &-1.5049813610294697551699714956373893D-02, - &+2.4206604468666677360733935930230549D-03, - &-2.6756346375625205474234901528281541D-04, - &+2.1308038490017812103019561719321294D-05, - &-1.2019599969650507783017925415454145D-06, - &+4.6774324464657799887986331519504851D-08, - &-1.1350580273767823974385743078813233D-09, - &+1.3694521779905435685524410856631591D-11/ - data rabj1dn / - &+4.2467609762315442400693029865795040D-01, - &-4.3083142135486853345320553054798065D-01, - &+1.6788517206101123528239344102761124D-01, - &-3.3796177537444951633168287614832691D-02, - &+3.8795047097080453256087993331777921D-03, - &-2.5515818965006319689426544517178161D-04, - &+8.3162429845444497107382145316229273D-06, - &-3.1934959167383968458778078011436116D-09, - &-9.3164847018358148213745655834193359D-09, - &+2.8746610644386035220167446103613304D-10, - &-2.8944287034616799451929693172577113D-12/ - data rabj1dd / - &+1.0000000000000000000000000000000000D+00, - &-3.6698450390768612683634161865311059D-01, - &+7.4884143212216256039432139181885445D-02, - &-1.0221916096061684403865100654999128D-02, - &+1.0074562131863317846318355992966287D-03, - &-7.3374157538561828451182655688029948D-05, - &+3.9570224775017050301357112675936376D-06, - &-1.5479721151459859100101554063875132D-07, - &+4.1934519331039533720220137503174087D-09, - &-7.1015545891050449440380478375745093D-11, - &+5.7826067387808782775528298874601191D-13/ - data rabj1en / - &-1.0727178100039883419848523490500134D+00, - &+7.0928196569351176003941921501759760D-01, - &-2.0244112729254919784586618692965949D-01, - &+3.2919122179062670197381146685815259D-02, - &-3.3846375280985925074645334995793181D-03, - &+2.3035146427123168406922044131847732D-04, - &-1.0526097486773898355270589440366091D-05, - &+3.1928037549687904672248561941454213D-07, - &-6.1569502122571540023308673784804519D-09, - &+6.8176863727717420052494188810057293D-11, - &-3.2903939595120148107005430367355315D-13/ - data rabj1ed / - &+1.0000000000000000000000000000000000D+00, - &-4.1294556742055131913125357418100254D-01, - &+8.2841362688762866622842985663978347D-02, - &-1.0382391872762524304804231048703553D-02, - &+8.9012846103463523752825990646025319D-04, - &-5.4163294972308871532368229256156985D-05, - &+2.3586205292066095764629097580766725D-06, - &-7.2385925159801043526475622512870661D-08, - &+1.4965837356032315825582092468612243D-09, - &-1.8825359032178275136083152292764955D-11, - &+1.0969526078193747331991670408293388D-13/ - data rabj1fn / - &-9.8075828607639007338780275479940338D-03, - &+6.2042628485312133436957794665065060D-03, - &-1.1711582212026499092489447079398142D-03, - &+1.0277604893169514981220012453729818D-04, - &-4.6894343161978861506416373649349031D-06, - &+1.0823475910761513088113165275317871D-07, - &-1.0009149629230385757860595107751339D-09/ - data rabj1fd / - &+1.0000000000000000000000000000000000D+00, - &-2.7630107315667408326367307184433078D-01, - &+3.2444450997756793186658519895099244D-02, - &-2.0654832225935412940479575463019885D-03, - &+7.5094528449918628311451893661611736D-05, - &-1.4778957595810851829028146021523979D-06, - &+1.2314771882129871146918134466632580D-08/ -c -c compute constants - Pi=2.d0*dasin(1.d0) - Pi3d4=0.75d0*Pi -c -c J_1(x) is odd in x, so we note the sign and use |x| - sgn=1.d0 - if(x.lt.0.d0) sgn=-1.d0 - ax=dabs(x) -c -c use approximation appropriate to value of x: -c range (0,4): rational approximation of J_1(x) -c range [4,8): rational approximation of J_1(x) -c range [8,12): rational approximation of -c J_1(x)-sqrt(2/(pi*x))*cos(x-3pi/4) -c range [12,15): rational approximation of -c J_1(x)-sqrt(2/(pi*x))*cos(x-3pi/4) -c range [15,20): rational approximation of -c J_1(x)-sqrt(2/(pi*x))*cos(x-3pi/4) -c range [20,21): rational approximation of -c J_1(x)-sqrt(2/(pi*x))*cos(x-3pi/4) -c range [21,infinity): Hankel's asymptotic expansion -c - if (ax.eq.0.d0) then - bj1=0.d0 - else if (ax.lt.4.d0) then - call ratappr(ax,rabj1an,11,rabj1ad,11,bj1) - else if (ax.lt.8.d0) then - call ratappr(ax,rabj1bn,11,rabj1bd,11,bj1) - else if (ax.lt.12.d0) then - call ratappr(ax,rabj1cn,11,rabj1cd,11,bj1) - bj1=bj1+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pi3d4) - else if (ax.lt.15.d0) then - call ratappr(ax,rabj1dn,11,rabj1dd,11,bj1) - bj1=bj1+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pi3d4) - else if (ax.lt.20.d0) then - call ratappr(ax,rabj1en,11,rabj1ed,11,bj1) - bj1=bj1+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pi3d4) - else if (ax.lt.21.d0) then - call ratappr(ax,rabj1fn,7,rabj1fd,7,bj1) - bj1=bj1+dsqrt(2.d0/(Pi*ax))*dcos(ax-Pi3d4) - else - t=ax-Pi3d4 - call HankelPQ(1,ax,pp,qq) - bj1=dsqrt(2.d0/(Pi*ax))*(pp*dcos(t)-qq*dsin(t)) - end if - bj1=sgn*bj1 -c - return - end -c -c*********************************************************************** - subroutine dbessjm(m,x,bjm) -c Bessel function of integer orders 0 through m-1: bjm(k) = J_{k-1}(x). - implicit none - integer m - double precision x - double precision bjm(*) -c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! - integer sgn,acc - integer kk,ms,k,p - double precision sd2,maxb,scl - double precision bj0,bj1,bjp,bjc,bjn - double precision ax,twovx,norm -c -c set sd2 to roughly sqr(# of desired significant digits) -c set maxb to renomalizing threshold - sd2=169.d0 - maxb=1.d+16 - scl=1.d0/maxb -c -c sanity check - if(m.le.0) then - write(6,*) ' ' - write(6,*) ' <*** ERROR: dbessjm ***> requires argument m > 0.' - write(6,*) ' Returning result array unchanged!' - return - end if -c -c note sgn(x) and use |x|; correct signs at end - sgn=1 - if(x.lt.0.d0) sgn=-1 - ax=dabs(x) - twovx=2.d0/ax -c -c clear result array - do kk=1,m - bjm(kk)=0.d0 - enddo -c -c treat x = 0 as a special case - if(ax.eq.0.d0) then - bjm(1)=1.d0 -c use upward recursion if |x| exceeds maximum order - else if(nint(ax).gt.m-1) then - call dbessj0(x,bj0) - bjm(1)=bj0 - if(m.eq.1) return - call dbessj1(x,bj1) - bjm(2)=bj1 - if(m.eq.2) return - bjp=bj0 - bjc=bj1 - do k=1,m-2 - bjn=k*twovx*bjc-bjp - bjp=bjc - bjc=bjn - bjm(k+2)=bjc - end do - else -c use downward recursion, starting well above desired maximum order -c make ms even, set alternating flag acc to accumulate even J_k's, -c and initialize variables - ms=2*((m+nint(dsqrt(sd2*(m+1))))/2) - acc=0 - norm=0.d0 - bjp=0.d0 - bjc=1.d0 - do k=ms,1,-1 - bjn=k*twovx*bjc-bjp - bjp=bjc - bjc=bjn -c if results get out of hand, renormalize them - if(dabs(bjc).gt.maxb) then - norm=scl*norm - bjp=scl*bjp - bjc=scl*bjc - do kk=1,m - bjm(kk)=scl*bjm(kk) - enddo - end if - if(k.le.m) bjm(k)=bjc - if(acc.eq.1) then - acc=0 - norm=norm+bjc - else - acc=1 - end if - end do -c recursion done; now normalize results using the identity -c 1 = J_0(x) + 2 J_2(x) + 2 J_4(x) + 2 J_6(x) + ... - norm=1.d0/(2.d0*norm-bjc) - do kk=1,m - bjm(kk)=norm*bjm(kk) - end do - end if -c -c correct signs - if(sgn.lt.0) then - do kk=2,m,2 - bjm(kk)=-bjm(kk) - end do - end if -c - return - end -c -c*********************************************************************** - subroutine HankelPQ(m,x,P,Q) -c Compute the asymptotic functions P(m,x) and Q(m,x) that appear in -c Hankel's expansions of the Bessel functions for large x. - implicit none - integer m - double precision x,P,Q -c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! - integer k,loopP,loopQ - double precision mu,x8,e,sq,t,tp0,tp1,tq0,tq1 - double precision eps -c -c set tolerance: -c this subroutine complains if the last term included in -c the asymptotic series for P or Q exceeds this value - eps=1.d-12 -c -c initialize computation - mu=4.d0*m*m - x8=8.d0*x - e=1.d0 - sq=e - t=(mu-sq)/x8 - tp0=1.d0 - tq0=t - P=tp0 - Q=tq0 - k=1 - loopP=1 - loopQ=1 -c -c main loop - 1 continue - tp1=-tp0*t - k=k+1 - e=e+2 - sq=sq+e - e=e+2 - sq=sq+e - t=(mu-sq)/(k*x8) - tp1=tp1*t - tq1=tp1 - k=k+1 - e=e+2 - sq=sq+e - e=e+2 - sq=sq+e - t=(mu-sq)/(k*x8) - tq1=tq1*t - if (loopP.eq.1.and.dabs(tp1).lt.dabs(tp0)) then - P=P+tp1 - tp0=tp1 - else - if(loopP.eq.1.and.dabs(tp0).gt.eps) then - write(6,10) eps - write(6,11) tp0 - endif - loopP=0 - end if - if (loopQ.eq.1.and.dabs(tq1).lt.dabs(tq0)) then - Q=Q+tq1 - tq0=tq1 - else - if(loopQ.eq.1.and.dabs(tq0).gt.eps) then - write(6,10) eps - write(6,12) tq0 - endif - loopQ=0 - end if - if(loopP.eq.1.or.loopQ.eq.1) go to 1 -c -c end main loop -c - 10 format('\n <*** WARNING: HankelPQ ***> tolerance ',1pe9.3) - 11 format(' not reached in HankelP series: last term = ',e10.3,'.') - 12 format(' not reached in HankelQ series: last term = ',e10.3,'.') -c - return - end -c -c*********************************************************************** - double precision function HankelP(m,x) -c Compute the asymptotic function P(m,x) that appears in Hankel's -c expansions of the Bessel functions for large x. - implicit none - integer m - double precision x -c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! - integer k2,loop - double precision mu,x82,t0,t1,e,sq,P -c -c initialize computation - mu=4.d0*m*m - x82=(8.d0*x)**2 - k2=2 - e=1 - sq=e - t0=1.d0 - P=t0 - loop=1 -c -c main loop - 1 continue - t1=-t0/((k2-1)*k2*x82) - t1=t1*(mu-sq) - e=e+2 - sq=sq+e - e=e+2 - sq=sq+e - t1=t1*(mu-sq) - if (dabs(t1).le.dabs(t0)) then - P=P+t1 - t0=t1 - k2=k2+2 - e=e+2 - sq=sq+e - e=e+2 - sq=sq+e - else - loop=0 - end if - if(loop.eq.1) go to 1 -c -c end main loop -c - HankelP=P - return - end -c -c*********************************************************************** - double precision function HankelQ(m,x) -c Compute the asymptotic function Q(m,x) that appears in Hankel's -c expansions of the Bessel functions for large x. - implicit none - integer m - double precision x -c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! - integer k2,loop - double precision mu,x82,t0,t1,e,sq,Q -c -c initialize computation - mu=4.d0*m*m - x82=(8.d0*x)**2 - k2=2 - e=1 - sq=e - t0=(mu-sq)/x82 - Q=t0 - loop=1 -c -c main loop - 1 continue - t1=-t0/(k2*(k2+1)*x82) - e=e+2 - sq=sq+e - e=e+2 - sq=sq+e - t1=t1*(mu-sq) - e=e+2 - sq=sq+e - e=e+2 - sq=sq+e - t1=t1*(mu-sq) - if (dabs(t1).le.dabs(t0)) then - Q=Q+t1 - t0=t1 - k2=k2+2 - else - loop=0 - end if - if(loop.eq.1) go to 1 -c -c end main loop -c - HankelQ=Q - return - end -c -c*********************************************************************** - subroutine ratappr(x,cfn,nn,cfd,nd,r) -c Compute the rational approximation for a function r(x)=rn(x)/rd(x), -c where the polynomials rn(x) and rd(x) are defined respectively by the -c nn coefficients in cfn and the nd coefficients in cfd. The -c coefficients must be listed in order of increasing powers. Thus, for -c the numerator, cfn(1) is the constant term, and cfn(nn) is the -c coefficient of the highest order term. The polynomials are computed -c using Horner's method. Return the result in r. - implicit none - integer nn,nd - double precision x,r - double precision cfn(*),cfd(*) -c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! - integer j - double precision rn,rd -c -c compute numerator - rn=cfn(nn) - do j=nn-1,1,-1 - rn=cfn(j)+rn*x - end do -c compute denominator - rd=cfd(nd) - do j=nn-1,1,-1 - rd=cfd(j)+rd*x - end do -c compute ratio - r=rn/rd -c - return - end -c -c*********************************************************************** diff --git a/OpticsJan2020/MLI_light_optics/Src/book.f b/OpticsJan2020/MLI_light_optics/Src/book.f deleted file mode 100755 index abb75d1..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/book.f +++ /dev/null @@ -1,1032 +0,0 @@ -************************************************************************ -* header: BOOKKEEP -* Index manipulation, table creation, block data, startup routines -************************************************************************ -c - subroutine binom -c -c computes the table of the binomial coefficients -c - implicit double precision (a-h,o-z) - integer bin(24,20) - common /bin/ bin - do 1 i=1,20 - bin(i,1)=i - do 1 k=2,20 - if (i-k) 2,3,4 - 2 bin(i,k)=0 - go to 1 - 3 bin(i,k)=1 - go to 1 - 4 ip=i-1 - kp=k-1 - bin(i,k)=bin(ip,kp)+bin(ip,k) - 1 continue - return - end -c - integer function ndexn(num,j) -c calculates the index of the long vector (dimension 209) -c for a given set of short indices that indicate a power of -c each variable, stored in the array j. -c This function is a combination of DRD's subroutines -c 'indice' and 'binom' in Marylie. -c Written by Liam Healy, June 8, 1984. -c -c 'bin(i,k)' is the binomial coefficient i select k (i>k) -cryne integer bin(24,20),j(6) - integer bin(24,20),j(*) - common/bin/ bin -c calculate the index - n=j(num) - m=j(num)-1 - do 100 i=2,num - ib=num+1-i - m=m+j(ib) - ib=m+i - n=n+bin(ib,i) - 100 continue - ndexn=n - return - end -c - integer function ndex(j) - integer j(6) - ndex=ndexn(6,j) -c - return - end -c -*********************************************************************** -c - subroutine setup -c - use lieaparam, only : monoms - include 'impli.inc' - include 'ind.inc' -cryne 5/3/2006 include 'files.inc' -cryne 5/3/2006 include 'time.inc' -c -c initialize commons (other than those in block data's) - imaxi = 6 - call initia -c -c initialize lie algebraic things - call binom - call tables - call init -c - return - end -c -*********************************************************************** -c - subroutine cpyrt -c - use parallel - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' -cryne 5/3/2006 include 'time.inc' - include 'ind.inc' -c -c write out copyright message at terminal -c - if(idproc.eq.0)then - write(jof,90) - 90 format( - &'***************************************************************', - &/, - &'* MARYLIE/IMPACT *', - &/, - &'* Parallel Lie Algebraic Beam Dynamics Code with Space Charge *', - &/, - &'* Last modified May 22, 2006 08:20PDT *', - &/, - &'* MaryLie copyright 1987, Alex J. Dragt, U. Maryland *', - &/, - &'* IMPACT copyright 2002, Robert D. Ryne, U. California *', - &/, - &'***************************************************************') - endif -c - return - end -c -****************************************************************************** -c - subroutine initia -c----------------------------------------------------------------------- -c This routine initializes some constants in common blocks, which are -c not initialized in block data -c -c Petra Schuett 10/30/87 -c Alex Dragt 6/20/88 -c----------------------------------------------------------------------- -c -cryne 7/23/2002 this is here because of the speed of light. fix later. - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' - include 'frnt.inc' -c -c set up constants -c -c pi = 3.14159265358979323846264d0 - pi = 4.d0*atan(1.d0) - pi180 = pi/180.d0 - twopi = 2.d0*pi - c = 2.99792458d+08 -c -c set up default values for cfbd fringe field parameters -c - cfbgap=0.d0 - cfblk1=.5 - cfbtk1=.5 -c - return - end -c -*********************************************************************** -c - subroutine tables -c This subroutine creates two tables used in bookkeeping: -c 1) expon(ind,psv) is the exponent of phase space variable -c 'psv' (1 to 6) for monomial index 'ind' (1 to top) -c 2) vblist(ind,vnum) is the variable list for each -c monomial index number 'ind' (1 to top). For nth -c order terms, there will be n non-zero variable -c numbers. -c For example, monomial number 109 is X.PX.PX.Pt. -c Thus, expon(109,1to6)=1,2,0,0,0,1 and vblist(109,1to4)=1,2,2,6. -c This subroutine was written by Liam Healy on June 20,1984, -c and is a replacement for Dave Douglas's subroutines 'addss' and 'sht' -c - use lieaparam, only : monoms,monom1 - implicit none -c ------Variables produced by subroutine------- - include 'expon.inc' - include 'vblist.inc' - include 'prodex.inc' - include 'order.inc' - include 'maxcat.inc' - include 'iprod.inc' -c ------Variables used internally-------- -c carry = carry amount from j(6) in counting for expon -c ind = monomial number index -c lnzj = last non-zero j -c psv = phase space variable 1...6 corresponds to X...Pt -c vnum = current postion for writing variable number in 'vblist' - integer carry,ind,lnzj,psv,vnum -c ord, pwr = order, exponent - integer ord,pwr -c indpr= index for product - integer indpr -c declaration for the integer function ndex(j) - integer ndex -c other needed integers - integer k,ind1,ind2 -c - include 'lims.inc' -c j = array of exponents - integer j(6) - save j - data j/6*0/ -c -c----------------------------------------------------- -c Sequentially create exponent table & calculate order & rearrangements - do 150 ind=1,topcat - carry=j(6) - j(6)=0 - lnzj=0 - do 100 psv=1,5 - if (j(psv).gt.0) lnzj=psv - 100 continue - if (lnzj.gt.0) j(lnzj)=j(lnzj)-1 - j(lnzj+1)=j(lnzj+1)+1+carry - ord=0 - do 120 psv=1,6 - pwr=j(psv) - expon(psv,ind)=pwr - ord=ord+pwr - 120 continue - order(ind)=ord -c -c------------------------------------------------------- -c Create variable list table, using exponent table - vnum=1 - do 220 psv=1,6 - do 200 k=1,j(psv) - vblist(vnum,ind)=psv - vnum=vnum+1 - 200 continue - 220 continue - 150 continue -c -c--------------------------------------------------------- -c Create product table, based on the idea of F. Neri and the -c method of C. Iselin. - do 380 psv=1,6 - 380 prodex(psv,0)=psv - do 300 ord=1,ordcat-1 - do 320 psv=1,6 - indpr=bottom(ord+1) - do 340 ind=bottom(ord),top(ord) - 360 if (expon(psv,indpr).eq.0) then - indpr=indpr+1 - if (indpr.le.top(ord+1)) goto 360 - endif - prodex(psv,ind)=indpr - indpr=indpr+1 - 340 continue - 320 continue - 300 continue -c -c Create table of products - do 401 ind1 = 1,monom1 - do 402 ind2 = 1,monom1 - do 403 psv = 1,6 - j(psv) = expon(psv,ind1)+expon(psv,ind2) - 403 continue - iprod(ind1,ind2) = ndex(j) - 402 continue - 401 continue - iprod(0,0) = 0 - do 500 ind1 = 1,monom1 - iprod(0,ind1) = ind1 - iprod(ind1,0) = ind1 - 500 continue -c -c--------------------------------------------------------- -cryne 6/21/2002 (based on ryne 8/26/2001) -c Create sum tables needed to convert maps from one set of -c scale variables to another. -cryne 08/26/2001 - do 600 ind=1,topcat - nxp135(ind)=expon(1,ind)+expon(3,ind)+expon(5,ind) -1 - nxp246(ind)=expon(2,ind)+expon(4,ind)+expon(6,ind) -1 - nxp13(ind)=expon(1,ind)+expon(3,ind) -1 - nxp24(ind)=expon(2,ind)+expon(4,ind) -1 -!cryne===== 12/21/2004 actually what is needed is: -! n1+n3+n6-1 for scale length [use nxp13+nxp6] -! n2+n4+n6-1 for scale momentum [use nxp24+nxp6] -! n6-n5 for scale angular freq [use nxp6-nxp5] -!!!!!!nxp5(ind)=expon(5,ind) -1 -!!!!!!nxp6(ind)=expon(6,ind) -1 -!cryne===== - nxp5(ind)=expon(5,ind) - nxp6(ind)=expon(6,ind) - 600 continue -c - return - end -c -*********************************************************************** -c - subroutine init -c -c produces the arrays index1 and index2 -c used to compute vector of monomials -c as follows: -c do 1 k = 7,length -c vector(k) = vector(index1(k))*vector(index2(k)) -c 1 continue -c the monomial of address k is product of -c monomial index1(k) and index2(k) -c -c also produces array pv(k), containing -c the sum -c 2 -c j(1)+j(2)*16+j(3)*16 +... -c -c of the exponents corresponding to monomial k. -c -c -c ind31 and ind32 are the equivalent of index1() and index2() -c for monomials in three variables. -c the monomials in 3 varibles are numbered in the same way the -c monomials in 6 are, except the start from 2, not from 1. -c 1 is used for the zeroth order monomial. -c this convention is use in ind31(), ind32(), ja3(), jv3() and ip- -c indecn(3,**,*), returns an index that starts from 1 for a first -c monomial so a 1 has to be added to the index returned by indecn( -c to convert the index to the convention used in the arrays built -c jv3() is the equivalent of jv() for third order monomials. -c ja3(i,n3) contains the ith exponent (i=1,3) of the -c n3 monomial in 3 varibles. -c -c Written by F. Neri, Spring 1985 -c - use lieaparam, only : monoms - include 'impli.inc' - include 'ind.inc' - include 'pq.inc' - include 'ind3.inc' - include 'ja3.inc' -c - integer j(6),j1(6),j2(6) - integer jp(3),jq(3) -c - call length - do 100 i1=0,imaxi - do 100 i2=0,imaxi-i1 - do 100 i3=0,imaxi-i1-i2 - j(1)=i1 - j(2)=i2 - j(3)=i3 - n3 = ndexn(3,j) - n3=n3+1 - jv3(n3)=0 - do 306 k=1,3 - jv3(n3)=jv3(n3)+j(k)*(16**(k-1)) - ja3(k,n3) = j(k) - 306 continue - ior3=i1+i2+i3 - ii2=ior3/2 - ii1=ior3-ii2 - itot=0 - do 2 k=1,3 - j1(k)=0 - j2(k)=0 - 2 continue - do 3 i=1,3 - j1(i)=j(i) - itot=itot+j(i) - if(itot-ii1) 3,31,32 - 3 continue - 32 continue - j1(i)=j1(i)+ii1-itot - j2(i)=itot-ii1 - 31 continue - if(i-3) 303,304,304 - 303 continue - do 305 ii=i+1,3 - j2(ii)=j(ii) - 305 continue - 304 continue - n1 = ndexn(3,j1) - n2 = ndexn(3,j2) - ind31(n3)=n1+1 - ind32(n3)=n2+1 - do 100 i4=0,imaxi-i1-i2-i3 - do 100 i5=0,imaxi-i1-i2-i3-i4 - do 100 i6=0,imaxi-i1-i2-i3-i4-i5 - iorder=i1+i2+i3+i4+i5+i6 - if(iorder-imaxi) 101,101,100 - 101 continue - if (iorder) 100,100,107 - 107 continue - j(1)=i1 - j(2)=i2 - j(3)=i3 - j(4)=i4 - j(5)=i5 - j(6)=i6 - jp(1)=j(2) - jp(2)=j(4) - jp(3)=j(6) - jq(1)=j(1) - jq(2)=j(3) - jq(3)=j(5) - n = ndex(j) - n1 = ndexn(3,jp) - n2 = ndexn(3,jq) - ip(n)=n1+1 - iq(n)=n2+1 - jv(n) = 0 - do 33 k = 1,6 - jv(n) = jv(n)+j(k)*(16**(k-1)) - 33 continue - ii2=iorder/2 - ii1=iorder-ii2 - itot=0 - do 55 k = 1,6 - j1(k) = 0 - j2(k) = 0 - 55 continue - do 200 i=1,6 - j1(i)=j(i) - itot=itot+j(i) - if(itot-ii1) 200,111,112 - 200 continue - 112 continue - j1(i)=j(i)+ii1-itot - j2(i)=itot-ii1 - 111 continue - if(i-6) 113,114,114 - 113 continue - do 115 ii=i+1,6 - j2(ii)=j(ii) - 115 continue - 114 continue - n1 = ndex(j1) - n2 = ndex(j2) - index1(n)=n1 - index2(n)=n2 - 100 continue - return - end -c -*********************************************************************** -c - subroutine length -c Written by F. Neri, Spring 1985 - use lieaparam, only : monoms - include 'impli.inc' - include 'len.inc' - include 'len3.inc' - include 'ind.inc' - dimension j(6),j3(3) -c - do 100 k =1,6 - 100 j(k) = 0 - do 103 k = 1,3 - 103 j3(k)=0 - do 200 k = 1, imaxi - j(6) = k - j3(3)=k - n=ndex(j) - len(k) = ndex(j) - len3(k) = ndexn(3,j3) - 200 continue - return - end -c -*********************************************************************** -c - block data matrcs -c Written by D. Douglas, ca 1982 -c implicit none - include 'id.inc' - include 'symp.inc' - data ident/1.,6*0.,1.,6*0.,1.,6*0.,1.,6*0.,1.,6*0.,1./ - data jm/0.,-1.,4*0.,1.,8*0.,-1.,4*0.,1.,8*0.,-1.,4*0.,1.,0./ - end -c -*********************************************************************** -c - block data spurex -c Written by F. Neri, Summer 1986 - use lieaparam, only : monoms -c implicit none - include 'sr.inc' -c - data (srexp(i,1),i=0,2)/0,0,0/ - data (srexp(i,2),i=0,2)/1,1,0/ - data (srexp(i,3),i=0,2)/0,0,0/ - data (srexp(i,4),i=0,2)/1,0,1/ - data (srexp(i,5),i=0,2)/0,0,0/ - data (srexp(i,6),i=0,2)/0,0,0/ - data (srexp(i,7),i=0,2)/0,0,0/ - data (srexp(i,8),i=0,2)/0,0,0/ - data (srexp(i,9),i=0,2)/0,0,0/ - data (srexp(i,10),i=0,2)/1,1,0/ - data (srexp(i,11),i=0,2)/0,0,0/ - data (srexp(i,12),i=0,2)/1,0,1/ - data (srexp(i,13),i=0,2)/0,0,0/ - data (srexp(i,14),i=0,2)/1,2,0/ - data (srexp(i,15),i=0,2)/0,0,0/ - data (srexp(i,16),i=0,2)/1,0,2/ - data (srexp(i,17),i=0,2)/0,0,0/ - data (srexp(i,18),i=0,2)/1,1,1/ - data (srexp(i,19),i=0,2)/0,0,0/ - data (srexp(i,20),i=0,2)/1,1,-1/ - data (srexp(i,21),i=0,2)/0,0,0/ - data (srexp(i,22),i=0,2)/0,0,0/ - data (srexp(i,23),i=0,2)/0,0,0/ - data (srexp(i,24),i=0,2)/0,0,0/ - data (srexp(i,25),i=0,2)/0,0,0/ - data (srexp(i,26),i=0,2)/0,0,0/ - data (srexp(i,27),i=0,2)/0,0,0/ - data (srexp(i,28),i=0,2)/0,0,0/ - data (srexp(i,29),i=0,2)/0,0,0/ - data (srexp(i,30),i=0,2)/0,0,0/ - data (srexp(i,31),i=0,2)/1,1,0/ - data (srexp(i,32),i=0,2)/0,0,0/ - data (srexp(i,33),i=0,2)/1,0,1/ - data (srexp(i,34),i=0,2)/0,0,0/ - data (srexp(i,35),i=0,2)/1,2,0/ - data (srexp(i,36),i=0,2)/0,0,0/ - data (srexp(i,37),i=0,2)/1,0,2/ - data (srexp(i,38),i=0,2)/0,0,0/ - data (srexp(i,39),i=0,2)/1,1,1/ - data (srexp(i,40),i=0,2)/0,0,0/ - data (srexp(i,41),i=0,2)/1,1,-1/ - data (srexp(i,42),i=0,2)/0,0,0/ - data (srexp(i,43),i=0,2)/1,1,0/ - data (srexp(i,44),i=0,2)/0,0,0/ - data (srexp(i,45),i=0,2)/1,0,1/ - data (srexp(i,46),i=0,2)/0,0,0/ - data (srexp(i,47),i=0,2)/1,1,0/ - data (srexp(i,48),i=0,2)/0,0,0/ - data (srexp(i,49),i=0,2)/1,0,1/ - data (srexp(i,50),i=0,2)/0,0,0/ - data (srexp(i,51),i=0,2)/1,3,0/ - data (srexp(i,52),i=0,2)/0,0,0/ - data (srexp(i,53),i=0,2)/1,0,3/ - data (srexp(i,54),i=0,2)/0,0,0/ - data (srexp(i,55),i=0,2)/1,2,1/ - data (srexp(i,56),i=0,2)/0,0,0/ - data (srexp(i,57),i=0,2)/1,1,2/ - data (srexp(i,58),i=0,2)/0,0,0/ - data (srexp(i,59),i=0,2)/1,2,-1/ - data (srexp(i,60),i=0,2)/0,0,0/ - data (srexp(i,61),i=0,2)/1,-1,2/ - data (srexp(i,62),i=0,2)/0,0,0/ - data (srexp(i,63),i=0,2)/0,0,0/ - data (srexp(i,64),i=0,2)/0,0,0/ - data (srexp(i,65),i=0,2)/0,0,0/ - data (srexp(i,66),i=0,2)/0,0,0/ - data (srexp(i,67),i=0,2)/0,0,0/ - data (srexp(i,68),i=0,2)/0,0,0/ - data (srexp(i,69),i=0,2)/0,0,0/ - data (srexp(i,70),i=0,2)/0,0,0/ - data (srexp(i,71),i=0,2)/0,0,0/ - data (srexp(i,72),i=0,2)/0,0,0/ - data (srexp(i,73),i=0,2)/0,0,0/ - data (srexp(i,74),i=0,2)/0,0,0/ - data (srexp(i,75),i=0,2)/0,0,0/ - data (srexp(i,76),i=0,2)/0,0,0/ - data (srexp(i,77),i=0,2)/0,0,0/ - data (srexp(i,78),i=0,2)/0,0,0/ - data (srexp(i,79),i=0,2)/0,0,0/ - data (srexp(i,80),i=0,2)/0,0,0/ - data (srexp(i,81),i=0,2)/0,0,0/ - data (srexp(i,82),i=0,2)/0,0,0/ - data (srexp(i,83),i=0,2)/0,0,0/ - data (srexp(i,84),i=0,2)/0,0,0/ - data (srexp(i,85),i=0,2)/0,0,0/ - data (srexp(i,86),i=0,2)/0,0,0/ - data (srexp(i,87),i=0,2)/0,0,0/ - data (srexp(i,88),i=0,2)/0,0,0/ - data (srexp(i,89),i=0,2)/0,0,0/ - data (srexp(i,90),i=0,2)/1,1,0/ - data (srexp(i,91),i=0,2)/0,0,0/ - data (srexp(i,92),i=0,2)/1,0,1/ - data (srexp(i,93),i=0,2)/0,0,0/ - data (srexp(i,94),i=0,2)/1,2,0/ - data (srexp(i,95),i=0,2)/0,0,0/ - data (srexp(i,96),i=0,2)/1,0,2/ - data (srexp(i,97),i=0,2)/0,0,0/ - data (srexp(i,98),i=0,2)/1,1,1/ - data (srexp(i,99),i=0,2)/0,0,0/ - data (srexp(i,100),i=0,2)/1,1,-1/ - data (srexp(i,101),i=0,2)/0,0,0/ - data (srexp(i,102),i=0,2)/1,1,0/ - data (srexp(i,103),i=0,2)/0,0,0/ - data (srexp(i,104),i=0,2)/1,0,1/ - data (srexp(i,105),i=0,2)/0,0,0/ - data (srexp(i,106),i=0,2)/1,1,0/ - data (srexp(i,107),i=0,2)/0,0,0/ - data (srexp(i,108),i=0,2)/1,0,1/ - data (srexp(i,109),i=0,2)/0,0,0/ - data (srexp(i,110),i=0,2)/1,3,0/ - data (srexp(i,111),i=0,2)/0,0,0/ - data (srexp(i,112),i=0,2)/1,0,3/ - data (srexp(i,113),i=0,2)/0,0,0/ - data (srexp(i,114),i=0,2)/1,2,1/ - data (srexp(i,115),i=0,2)/0,0,0/ - data (srexp(i,116),i=0,2)/1,1,2/ - data (srexp(i,117),i=0,2)/0,0,0/ - data (srexp(i,118),i=0,2)/1,2,-1/ - data (srexp(i,119),i=0,2)/0,0,0/ - data (srexp(i,120),i=0,2)/1,-1,2/ - data (srexp(i,121),i=0,2)/0,0,0/ - data (srexp(i,122),i=0,2)/1,2,0/ - data (srexp(i,123),i=0,2)/0,0,0/ - data (srexp(i,124),i=0,2)/1,0,2/ - data (srexp(i,125),i=0,2)/0,0,0/ - data (srexp(i,126),i=0,2)/1,2,0/ - data (srexp(i,127),i=0,2)/0,0,0/ - data (srexp(i,128),i=0,2)/1,0,2/ - data (srexp(i,129),i=0,2)/0,0,0/ - data (srexp(i,130),i=0,2)/1,1,1/ - data (srexp(i,131),i=0,2)/0,0,0/ - data (srexp(i,132),i=0,2)/1,1,1/ - data (srexp(i,133),i=0,2)/0,0,0/ - data (srexp(i,134),i=0,2)/1,1,-1/ - data (srexp(i,135),i=0,2)/0,0,0/ - data (srexp(i,136),i=0,2)/1,-1,1/ - data (srexp(i,137),i=0,2)/0,0,0/ - data (srexp(i,138),i=0,2)/1,4,0/ - data (srexp(i,139),i=0,2)/0,0,0/ - data (srexp(i,140),i=0,2)/1,0,4/ - data (srexp(i,141),i=0,2)/0,0,0/ - data (srexp(i,142),i=0,2)/1,3,1/ - data (srexp(i,143),i=0,2)/0,0,0/ - data (srexp(i,144),i=0,2)/1,1,3/ - data (srexp(i,145),i=0,2)/0,0,0/ - data (srexp(i,146),i=0,2)/1,3,-1/ - data (srexp(i,147),i=0,2)/0,0,0/ - data (srexp(i,148),i=0,2)/1,-1,3/ - data (srexp(i,149),i=0,2)/0,0,0/ - data (srexp(i,150),i=0,2)/1,2,2/ - data (srexp(i,151),i=0,2)/0,0,0/ - data (srexp(i,152),i=0,2)/1,2,-2/ - data (srexp(i,153),i=0,2)/0,0,0/ - data (srexp(i,154),i=0,2)/0,0,0/ - data (srexp(i,155),i=0,2)/0,0,0/ - data (srexp(i,156),i=0,2)/0,0,0/ - data (srexp(i,157),i=0,2)/0,0,0/ - data (srexp(i,158),i=0,2)/0,0,0/ - data (srexp(i,159),i=0,2)/0,0,0/ - data (srexp(i,160),i=0,2)/0,0,0/ - data (srexp(i,161),i=0,2)/0,0,0/ - data (srexp(i,162),i=0,2)/0,0,0/ - data (srexp(i,163),i=0,2)/0,0,0/ - data (srexp(i,164),i=0,2)/0,0,0/ - data (srexp(i,165),i=0,2)/0,0,0/ - data (srexp(i,166),i=0,2)/0,0,0/ - data (srexp(i,167),i=0,2)/0,0,0/ - data (srexp(i,168),i=0,2)/0,0,0/ - data (srexp(i,169),i=0,2)/0,0,0/ - data (srexp(i,170),i=0,2)/0,0,0/ - data (srexp(i,171),i=0,2)/0,0,0/ - data (srexp(i,172),i=0,2)/0,0,0/ - data (srexp(i,173),i=0,2)/0,0,0/ - data (srexp(i,174),i=0,2)/0,0,0/ - data (srexp(i,175),i=0,2)/0,0,0/ - data (srexp(i,176),i=0,2)/0,0,0/ - data (srexp(i,177),i=0,2)/0,0,0/ - data (srexp(i,178),i=0,2)/0,0,0/ - data (srexp(i,179),i=0,2)/0,0,0/ - data (srexp(i,180),i=0,2)/0,0,0/ - data (srexp(i,181),i=0,2)/0,0,0/ - data (srexp(i,182),i=0,2)/0,0,0/ - data (srexp(i,183),i=0,2)/0,0,0/ - data (srexp(i,184),i=0,2)/0,0,0/ - data (srexp(i,185),i=0,2)/0,0,0/ - data (srexp(i,186),i=0,2)/0,0,0/ - data (srexp(i,187),i=0,2)/0,0,0/ - data (srexp(i,188),i=0,2)/0,0,0/ - data (srexp(i,189),i=0,2)/0,0,0/ - data (srexp(i,190),i=0,2)/0,0,0/ - data (srexp(i,191),i=0,2)/0,0,0/ - data (srexp(i,192),i=0,2)/0,0,0/ - data (srexp(i,193),i=0,2)/0,0,0/ - data (srexp(i,194),i=0,2)/0,0,0/ - data (srexp(i,195),i=0,2)/0,0,0/ - data (srexp(i,196),i=0,2)/0,0,0/ - data (srexp(i,197),i=0,2)/0,0,0/ - data (srexp(i,198),i=0,2)/0,0,0/ - data (srexp(i,199),i=0,2)/0,0,0/ - data (srexp(i,200),i=0,2)/0,0,0/ - data (srexp(i,201),i=0,2)/0,0,0/ - data (srexp(i,202),i=0,2)/0,0,0/ - data (srexp(i,203),i=0,2)/0,0,0/ - data (srexp(i,204),i=0,2)/0,0,0/ - data (srexp(i,205),i=0,2)/0,0,0/ - data (srexp(i,206),i=0,2)/0,0,0/ - data (srexp(i,207),i=0,2)/0,0,0/ - data (srexp(i,208),i=0,2)/0,0,0/ - data (srexp(i,209),i=0,2)/0,0,0/ - end -c -*************************************************************** -c - block data dpurex -c Written by F. Neri, Summer 1986 - use lieaparam, only : monoms -c implicit none - include 'dr.inc' -c - data (drexp(i,1),i=0,3)/1,1,0,0/ - data (drexp(i,2),i=0,3)/0,0,0,0/ - data (drexp(i,3),i=0,3)/1,0,1,0/ - data (drexp(i,4),i=0,3)/0,0,0,0/ - data (drexp(i,5),i=0,3)/1,0,0,1/ - data (drexp(i,6),i=0,3)/0,0,0,0/ - data (drexp(i,7),i=0,3)/0,0,0,0/ - data (drexp(i,8),i=0,3)/0,0,0,0/ - data (drexp(i,9),i=0,3)/0,0,0,0/ - data (drexp(i,10),i=0,3)/1,0,0,2/ - data (drexp(i,11),i=0,3)/0,0,0,0/ - data (drexp(i,12),i=0,3)/1,1,0,1/ - data (drexp(i,13),i=0,3)/0,0,0,0/ - data (drexp(i,14),i=0,3)/1,1,0,-1/ - data (drexp(i,15),i=0,3)/0,0,0,0/ - data (drexp(i,16),i=0,3)/1,0,1,1/ - data (drexp(i,17),i=0,3)/0,0,0,0/ - data (drexp(i,18),i=0,3)/1,0,1,-1/ - data (drexp(i,19),i=0,3)/0,0,0,0/ - data (drexp(i,20),i=0,3)/1,2,0,0/ - data (drexp(i,21),i=0,3)/0,0,0,0/ - data (drexp(i,22),i=0,3)/1,0,2,0/ - data (drexp(i,23),i=0,3)/0,0,0,0/ - data (drexp(i,24),i=0,3)/1,1,1,0/ - data (drexp(i,25),i=0,3)/0,0,0,0/ - data (drexp(i,26),i=0,3)/1,1,-1,0/ - data (drexp(i,27),i=0,3)/0,0,0,0/ - data (drexp(i,28),i=0,3)/1,0,0,1/ - data (drexp(i,29),i=0,3)/0,0,0,0/ - data (drexp(i,30),i=0,3)/1,0,0,1/ - data (drexp(i,31),i=0,3)/0,0,0,0/ - data (drexp(i,32),i=0,3)/1,0,0,3/ - data (drexp(i,33),i=0,3)/0,0,0,0/ - data (drexp(i,34),i=0,3)/1,0,0,1/ - data (drexp(i,35),i=0,3)/0,0,0,0/ - data (drexp(i,36),i=0,3)/1,1,0,0/ - data (drexp(i,37),i=0,3)/0,0,0,0/ - data (drexp(i,38),i=0,3)/1,0,1,0/ - data (drexp(i,39),i=0,3)/0,0,0,0/ - data (drexp(i,40),i=0,3)/1,1,0,2/ - data (drexp(i,41),i=0,3)/0,0,0,0/ - data (drexp(i,42),i=0,3)/1,1,0,-2/ - data (drexp(i,43),i=0,3)/0,0,0,0/ - data (drexp(i,44),i=0,3)/1,0,1,2/ - data (drexp(i,45),i=0,3)/0,0,0,0/ - data (drexp(i,46),i=0,3)/1,0,1,-2/ - data (drexp(i,47),i=0,3)/0,0,0,0/ - data (drexp(i,48),i=0,3)/1,2,0,1/ - data (drexp(i,49),i=0,3)/0,0,0,0/ - data (drexp(i,50),i=0,3)/1,2,0,-1/ - data (drexp(i,51),i=0,3)/0,0,0,0/ - data (drexp(i,52),i=0,3)/1,0,2,1/ - data (drexp(i,53),i=0,3)/0,0,0,0/ - data (drexp(i,54),i=0,3)/1,0,2,-1/ - data (drexp(i,55),i=0,3)/0,0,0,0/ - data (drexp(i,56),i=0,3)/1,1,1,1/ - data (drexp(i,57),i=0,3)/0,0,0,0/ - data (drexp(i,58),i=0,3)/1,1,1,-1/ - data (drexp(i,59),i=0,3)/0,0,0,0/ - data (drexp(i,60),i=0,3)/1,1,-1,1/ - data (drexp(i,61),i=0,3)/0,0,0,0/ - data (drexp(i,62),i=0,3)/1,1,-1,-1/ - data (drexp(i,63),i=0,3)/0,0,0,0/ - data (drexp(i,64),i=0,3)/1,1,0,0/ - data (drexp(i,65),i=0,3)/0,0,0,0/ - data (drexp(i,66),i=0,3)/1,0,1,0/ - data (drexp(i,67),i=0,3)/0,0,0,0/ - data (drexp(i,68),i=0,3)/1,1,0,0/ - data (drexp(i,69),i=0,3)/0,0,0,0/ - data (drexp(i,70),i=0,3)/1,0,1,0/ - data (drexp(i,71),i=0,3)/0,0,0,0/ - data (drexp(i,72),i=0,3)/1,3,0,0/ - data (drexp(i,73),i=0,3)/0,0,0,0/ - data (drexp(i,74),i=0,3)/1,0,3,0/ - data (drexp(i,75),i=0,3)/0,0,0,0/ - data (drexp(i,76),i=0,3)/1,2,1,0/ - data (drexp(i,77),i=0,3)/0,0,0,0/ - data (drexp(i,78),i=0,3)/1,1,2,0/ - data (drexp(i,79),i=0,3)/0,0,0,0/ - data (drexp(i,80),i=0,3)/1,2,-1,0/ - data (drexp(i,81),i=0,3)/0,0,0,0/ - data (drexp(i,82),i=0,3)/1,1,-2,0/ - data (drexp(i,83),i=0,3)/0,0,0,0/ - data (drexp(i,84),i=0,3)/0,0,0,0/ - data (drexp(i,85),i=0,3)/0,0,0,0/ - data (drexp(i,86),i=0,3)/0,0,0,0/ - data (drexp(i,87),i=0,3)/0,0,0,0/ - data (drexp(i,88),i=0,3)/0,0,0,0/ - data (drexp(i,89),i=0,3)/0,0,0,0/ - data (drexp(i,90),i=0,3)/1,0,0,2/ - data (drexp(i,91),i=0,3)/0,0,0,0/ - data (drexp(i,92),i=0,3)/1,0,0,2/ - data (drexp(i,93),i=0,3)/0,0,0,0/ - data (drexp(i,94),i=0,3)/1,0,0,4/ - data (drexp(i,95),i=0,3)/0,0,0,0/ - data (drexp(i,96),i=0,3)/1,0,0,2/ - data (drexp(i,97),i=0,3)/0,0,0,0/ - data (drexp(i,98),i=0,3)/1,1,0,3/ - data (drexp(i,99),i=0,3)/0,0,0,0/ - data (drexp(i,100),i=0,3)/1,1,0,-3/ - data (drexp(i,101),i=0,3)/0,0,0,0/ - data (drexp(i,102),i=0,3)/1,0,1,3/ - data (drexp(i,103),i=0,3)/0,0,0,0/ - data (drexp(i,104),i=0,3)/1,0,1,-3/ - data (drexp(i,105),i=0,3)/0,0,0,0/ - data (drexp(i,106),i=0,3)/1,1,0,1/ - data (drexp(i,107),i=0,3)/0,0,0,0/ - data (drexp(i,108),i=0,3)/1,1,0,-1/ - data (drexp(i,109),i=0,3)/0,0,0,0/ - data (drexp(i,110),i=0,3)/1,0,1,1/ - data (drexp(i,111),i=0,3)/0,0,0,0/ - data (drexp(i,112),i=0,3)/1,0,1,-1/ - data (drexp(i,113),i=0,3)/0,0,0,0/ - data (drexp(i,114),i=0,3)/1,2,0,0/ - data (drexp(i,115),i=0,3)/0,0,0,0/ - data (drexp(i,116),i=0,3)/1,0,2,0/ - data (drexp(i,117),i=0,3)/0,0,0,0/ - data (drexp(i,118),i=0,3)/1,2,0,2/ - data (drexp(i,119),i=0,3)/0,0,0,0/ - data (drexp(i,120),i=0,3)/1,2,0,-2/ - data (drexp(i,121),i=0,3)/0,0,0,0/ - data (drexp(i,122),i=0,3)/1,0,2,2/ - data (drexp(i,123),i=0,3)/0,0,0,0/ - data (drexp(i,124),i=0,3)/1,0,2,-2/ - data (drexp(i,125),i=0,3)/0,0,0,0/ - data (drexp(i,126),i=0,3)/1,1,1,0/ - data (drexp(i,127),i=0,3)/0,0,0,0/ - data (drexp(i,128),i=0,3)/1,1,-1,0/ - data (drexp(i,129),i=0,3)/0,0,0,0/ - data (drexp(i,130),i=0,3)/1,1,1,2/ - data (drexp(i,131),i=0,3)/0,0,0,0/ - data (drexp(i,132),i=0,3)/1,1,1,-2/ - data (drexp(i,133),i=0,3)/0,0,0,0/ - data (drexp(i,134),i=0,3)/1,1,-1,2/ - data (drexp(i,135),i=0,3)/0,0,0,0/ - data (drexp(i,136),i=0,3)/1,1,-1,-2/ - data (drexp(i,137),i=0,3)/0,0,0,0/ - data (drexp(i,138),i=0,3)/1,1,0,1/ - data (drexp(i,139),i=0,3)/0,0,0,0/ - data (drexp(i,140),i=0,3)/1,1,0,-1/ - data (drexp(i,141),i=0,3)/0,0,0,0/ - data (drexp(i,142),i=0,3)/1,0,1,1/ - data (drexp(i,143),i=0,3)/0,0,0,0/ - data (drexp(i,144),i=0,3)/1,0,1,-1/ - data (drexp(i,145),i=0,3)/0,0,0,0/ - data (drexp(i,146),i=0,3)/1,1,0,1/ - data (drexp(i,147),i=0,3)/0,0,0,0/ - data (drexp(i,148),i=0,3)/1,1,0,-1/ - data (drexp(i,149),i=0,3)/0,0,0,0/ - data (drexp(i,150),i=0,3)/1,0,1,1/ - data (drexp(i,151),i=0,3)/0,0,0,0/ - data (drexp(i,152),i=0,3)/1,0,1,-1/ - data (drexp(i,153),i=0,3)/0,0,0,0/ - data (drexp(i,154),i=0,3)/1,3,0,1/ - data (drexp(i,155),i=0,3)/0,0,0,0/ - data (drexp(i,156),i=0,3)/1,3,0,-1/ - data (drexp(i,157),i=0,3)/0,0,0,0/ - data (drexp(i,158),i=0,3)/1,0,3,1/ - data (drexp(i,159),i=0,3)/0,0,0,0/ - data (drexp(i,160),i=0,3)/1,0,3,-1/ - data (drexp(i,161),i=0,3)/0,0,0,0/ - data (drexp(i,162),i=0,3)/1,2,1,1/ - data (drexp(i,163),i=0,3)/0,0,0,0/ - data (drexp(i,164),i=0,3)/1,2,1,-1/ - data (drexp(i,165),i=0,3)/0,0,0,0/ - data (drexp(i,166),i=0,3)/1,1,2,1/ - data (drexp(i,167),i=0,3)/0,0,0,0/ - data (drexp(i,168),i=0,3)/1,1,2,-1/ - data (drexp(i,169),i=0,3)/0,0,0,0/ - data (drexp(i,170),i=0,3)/1,2,-1,1/ - data (drexp(i,171),i=0,3)/0,0,0,0/ - data (drexp(i,172),i=0,3)/1,2,-1,-1/ - data (drexp(i,173),i=0,3)/0,0,0,0/ - data (drexp(i,174),i=0,3)/1,1,-2,-1/ - data (drexp(i,175),i=0,3)/0,0,0,0/ - data (drexp(i,176),i=0,3)/1,1,-2,1/ - data (drexp(i,177),i=0,3)/0,0,0,0/ - data (drexp(i,178),i=0,3)/1,2,0,0/ - data (drexp(i,179),i=0,3)/0,0,0,0/ - data (drexp(i,180),i=0,3)/1,0,2,0/ - data (drexp(i,181),i=0,3)/0,0,0,0/ - data (drexp(i,182),i=0,3)/1,2,0,0/ - data (drexp(i,183),i=0,3)/0,0,0,0/ - data (drexp(i,184),i=0,3)/1,0,2,0/ - data (drexp(i,185),i=0,3)/0,0,0,0/ - data (drexp(i,186),i=0,3)/1,1,1,0/ - data (drexp(i,187),i=0,3)/0,0,0,0/ - data (drexp(i,188),i=0,3)/1,1,1,0/ - data (drexp(i,189),i=0,3)/0,0,0,0/ - data (drexp(i,190),i=0,3)/1,1,-1,0/ - data (drexp(i,191),i=0,3)/0,0,0,0/ - data (drexp(i,192),i=0,3)/1,1,-1,0/ - data (drexp(i,193),i=0,3)/0,0,0,0/ - data (drexp(i,194),i=0,3)/1,4,0,0/ - data (drexp(i,195),i=0,3)/0,0,0,0/ - data (drexp(i,196),i=0,3)/1,0,4,0/ - data (drexp(i,197),i=0,3)/0,0,0,0/ - data (drexp(i,198),i=0,3)/1,3,1,0/ - data (drexp(i,199),i=0,3)/0,0,0,0/ - data (drexp(i,200),i=0,3)/1,1,3,0/ - data (drexp(i,201),i=0,3)/0,0,0,0/ - data (drexp(i,202),i=0,3)/1,3,-1,0/ - data (drexp(i,203),i=0,3)/0,0,0,0/ - data (drexp(i,204),i=0,3)/1,1,-3,0/ - data (drexp(i,205),i=0,3)/0,0,0,0/ - data (drexp(i,206),i=0,3)/1,2,2,0/ - data (drexp(i,207),i=0,3)/0,0,0,0/ - data (drexp(i,208),i=0,3)/1,2,-2,0/ - data (drexp(i,209),i=0,3)/0,0,0,0/ - end -c -*********************************************************************** -c - block data srlabl - use lieaparam, only : monoms -c implicit none - include 'srl.inc' -c -c Assignment of designation labels for static resonance basis: -c Written by F. Neri, Summer 1986 -c - data(sln(i),i=1,25)/ - &'R00001','R10000','I10000','R00100','I00100', - &'000010','R11000','R00110','R00002','R10001', - &'I10001','R00101','I00101','R20000','I20000', - &'R00200','I00200','R10100','I10100','R10010', - &'I10010','100010','010010','001010','000110'/ - data(sln(i),i=26,50)/ - &'000020','000011','R11001','R00111','R00003', - &'R10002','I10002','R00102','I00102','R20001', - &'I20001','R00201','I00201','R10101','I10101', - &'R10011','I10011','R21000','I21000','R00210', - &'I00210','R10110','I10110','R11100','I11100'/ - data(sln(i),i=51,75)/ - &'R30000','I30000','R00300','I00300','R20100', - &'I20100','R10200','I10200','R20010','I20010', - &'R01200','I01200','200010','110010','101010', - &'100110','100020','100011','020010','011010', - &'010110','010020','010011','002010','001110'/ - data(sln(i),i=76,100)/ - &'001020','001011','000210','000120','000111', - &'000030','000021','000012','R11002','R00112', - &'R00004','R22000','R00220','R11110','R10003', - &'I10003','R00103','I00103','R20002','I20002', - &'R00202','I00202','R10102','I10102','R10012'/ - data(sln(i),i=101,125)/ - &'I10012','R21001','I21001','R00211','I00211', - &'R10111','I10111','R11101','I11101','R30001', - &'I30001','R00301','I00301','R20101','I20101', - &'R10201','I10201','R20011','I20011','R01201', - &'I01201','R31000','I31000','R00310','I00310'/ - data(sln(i),i=126,150)/ - &'R20110','I20110','R11200','I11200','R21100', - &'I21100','R10210','I10210','R21010','I21010', - &'R01210','I01210','R40000','I40000','R00400', - &'I00400','R30100','I30100','R10300','I10300', - &'R30010','I30010','R01300','I01300','R20200'/ - data(sln(i),i=151,175)/ - &'I20200','R20020','I20020','300010','210010', - &'201010','200110','200020','200011','120010', - &'111010','110110','110020','110011','102010', - &'101110','101020','101011','100210','100120', - &'100111','100030','100021','100012','030010'/ - data(sln(i),i=176,200)/ - &'021010','020110','020020','020011','012010', - &'011110','011020','011011','010210','010120', - &'010111','010030','010021','010012','003010', - &'002110','002020','002011','001210','001120', - &'001111','001030','001021','001012','000310'/ - data(sln(i),i=201,209)/ - &'000220','000211','000130','000121','000112', - &'000040','000031','000022','000013'/ -c - end -c -************************************************************************ -c - block data drlabl - use lieaparam, only : monoms -c implicit none - include 'drl.inc' -c -c Assignment of designation labels for dynamic resonance basis: -c Written by F. Neri, Summer 1986 -c - data(dln(i),i=1,25)/ - &'R100000','I100000','R001000','I001000','R000010', - &'I000010','R110000','R001100','R000011','R000020', - &'I000020','R100010','I100010','R100001','I100001', - &'R001010','I001010','R001001','I001001','R200000', - &'I200000','R002000','I002000','R101000','I101000'/ - data(dln(i),i=26,50)/ - &'R100100','I100100','R110010','I110010','R001110', - &'I001110','R000030','I000030','R000021','I000021', - &'R100011','I100011','R001011','I001011','R100020', - &'I100020','R100002','I100002','R001020','I001020', - &'R001002','I001002','R200010','I200010','R200001'/ - data(dln(i),i=51,75)/ - &'I200001','R002010','I002010','R002001','I002001', - &'R101010','I101010','R101001','I101001','R100110', - &'I100110','R100101','I100101','R210000','I210000', - &'R002100','I002100','R101100','I101100','R111000', - &'I111000','R300000','I300000','R003000','I003000'/ - data(dln(i),i=76,100)/ - &'R201000','I201000','R102000','I102000','R200100', - &'I200100','R100200','I100200','R220000','R002200', - &'R000022','R111100','R110011','R001111','R110020', - &'I110020','R001120','I001120','R000040','I000040', - &'R000031','I000031','R100030','I100030','R100003'/ - data(dln(i),i=101,125)/ - &'I100003','R001030','I001030','R001003','I001003', - &'R100021','I100021','R100012','I100012','R001021', - &'I001021','R001012','I001012','R200011','I200011', - &'R002011','I002011','R200020','I200020','R200002', - &'I200002','R002020','I002020','R002002','I002002'/ - data(dln(i),i=126,150)/ - &'R101011','I101011','R100111','I100111','R101020', - &'I101020','R101002','I101002','R100120','I100120', - &'R100102','I100102','R210010','I210010','R210001', - &'I210001','R002110','I002110','R002101','I002101', - &'R101110','I101110','R101101','I101101','R111010'/ - data(dln(i),i=151,175)/ - &'I111010','R111001','I111001','R300010','I300010', - &'R300001','I300001','R003010','I003010','R003001', - &'I003001','R201010','I201010','R201001','I201001', - &'R102010','I102010','R102001','I102001','R200110', - &'I200110','R200101','I200101','R100201','I100201'/ - data(dln(i),i=176,200)/ - &'R100210','I100210','R310000','I310000','R003100', - &'I003100','R201100','I201100','R112000','I112000', - &'R211000','I211000','R102100','I102100','R210100', - &'I210100','R101200','I101200','R400000','I400000', - &'R004000','I004000','R301000','I301000','R103000'/ - data(dln(i),i=201,209)/ - &'I103000','R300100','I300100','R100300','I100300', - &'R202000','I202000','R200200','I200200'/ -c - end -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/boundp3d.f b/OpticsJan2020/MLI_light_optics/Src/boundp3d.f deleted file mode 100644 index 603d562..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/boundp3d.f +++ /dev/null @@ -1,72 +0,0 @@ - subroutine boundp3d(coord,msk,np,gblam,nx,ny,nz,nadj) - use rays - implicit double precision(a-h,o-z) - logical msk - dimension coord(6,np),msk(np) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - common/gridxtra/xsml,xbig,ysml,ybig,zsml,zbig - dimension bndy(6),rbndy(6) -!hpf$ distribute coord(*,block) -!hpf$ align (:) with coord(*,:) :: msk -! if(idproc.eq.0)write(6,*)'inside boundp' -! transverse: - bndy(1)=maxval(coord(1,:),1,msk) - bndy(2)=maxval(coord(3,:),1,msk) - bndy(3)=maxval(coord(5,:),1,msk) - bndy(4)=-minval(coord(1,:),1,msk) - bndy(5)=-minval(coord(3,:),1,msk) - bndy(6)=-minval(coord(5,:),1,msk) - call MPI_ALLREDUCE(bndy,rbndy,6,mreal,mpimax,lworld,ierror) - xbig=rbndy(1) - ybig=rbndy(2) - zbig=rbndy(3) - xsml=-rbndy(4) - ysml=-rbndy(5) - zsml=-rbndy(6) -! write(6,*)'xsml,xbig=',xsml,xbig -! write(6,*)'ysml,ybig=',ysml,ybig -! write(6,*)'zsml,zbig=',zsml,zbig -! note: this would be a good place to check which particles -! are inside the beampipe, then mask off those that are not. - eps=0.05 - xmin=xsml-eps*(xbig-xsml) - xmax=xbig+eps*(xbig-xsml) - ymin=ysml-eps*(ybig-ysml) - ymax=ybig+eps*(ybig-ysml) -! if(idproc.eq.0)then -! write(6,*)'xmin,xmax=',xmin,xmax -! write(6,*)'ymin,ymax=',ymin,ymax -! endif - hx=(xmax-xmin)/(nx-1) - hy=(ymax-ymin)/(ny-1) - hxi=1.d0/hx - hyi=1.d0/hy -! longitudinal: - delz=zbig-zsml -! if(idproc.eq.0)then -! write(6,*)'delz,gblam=',delz,gblam -! write(6,*)'nadj=',nadj -! endif - if(delz.gt.gblam .and. nadj.eq.1)then - if(idproc.eq.0)then - write(6,*)'error: delz.gt.gam*beta*lambda in routine boundp' - write(6,*)'zbig,zsml=',zbig,zsml - write(6,*)'delz,gblam=',zbig-zsml,gblam - endif - call myexit - endif - if(nadj.eq.0)then - zmin=zsml-eps*(zbig-zsml) - zmax=zbig+eps*(zbig-zsml) -! if(idproc.eq.0)write(6,*)'(nadj.eq.0) zmin,zmax=',zmin,zmax - else - zmin=zsml-0.5d0*(gblam-delz) - zmax=zbig+0.5d0*(gblam-delz) -! if(idproc.eq.0)write(6,*)'(nadj.ne.0) zmin,zmax=',zmin,zmax - endif - if(nadj.eq.0)hz=(zmax-zmin)/(nz-1) - if(nadj.eq.1)hz=gblam/nz - hzi=1.d0/hz -! if(idproc.eq.0)write(6,*)'leaving boundp3d with hz=',hz - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/cfbdang.f b/OpticsJan2020/MLI_light_optics/Src/cfbdang.f deleted file mode 100755 index 3795076..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/cfbdang.f +++ /dev/null @@ -1,177 +0,0 @@ -c - subroutine cgbend(rho,bndang,psideg,phideg,ijopt,coefpset,h,mh) - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - double precision mh(6,6),mht1(6,6),mht2(6,6),mht3(6,6) - double precision h(monoms),ht1(monoms),ht2(monoms),ht3(monoms) - double precision ptmp(6),coefpset(6) -c -c this routine is modeled on the Healy/Dragt subroutine gbend -c -c calculate each of the 3 individual pieces that make -c up the general bending magnet, and concatenate them: -c cgbend=hpf1*cfbend*hpf2 -c****NOV 7 "call hpf" replaced w/ calls to gbend+cfbend since routine hpf -c does not know about combined function magnets. RDR -c (note: "gbend" is the subroutine name for gbdy) -c (note: "cfbend" is the subroutine name for normal entry comb fxn magnet) -c -c 5 parameters and a 6-vector are passed to cfbend: -c bend angle, b field, ilfrn, itfrn, ijopt, coefpset(1-6) -c but note that, in the current implementation of cfbend, ilfrn and itfrn -c are not used. - aldeg=bndang-psideg-phideg -c write(6,*)'brho=',brho -c write(6,*)'rho=',rho - ptmp(2)=brho/rho - ptmp(3)=0. - ptmp(4)=0. - ptmp(5)=ijopt -c ( ptmp(6) is not used ) - ptmp(6)=0. -c compute hpf1 and nbend -c call hpf(rho,1,psideg,ht1,mht1) - azero=0.d0 -cryne 11/9/02 ptmp(1)=0.5d0*bndang - ptmp(1)=psideg - call gbend(rho,azero,psideg,azero,ht1,mht1) - call cfbend(ptmp,coefpset,ht2,mht2) - call concat(ht1,mht1,ht2,mht2,ht1,mht1) - ptmp(1)=aldeg - call cfbend(ptmp,coefpset,ht2,mht2) -c form the product hpf1*nbend - call concat(ht1,mht1,ht2,mht2,ht3,mht3) -c compute hpf2 -c call hpf(rho,-1,phideg,ht1,mht1) -c write(6,'(6(1pe12.5,1x))')((mht1(i,j),j=1,6),i=1,6) -c if(1.gt.0)call myexit -cryne 11/9/02 ptmp(1)=0.5d0*bndang - ptmp(1)=phideg - call cfbend(ptmp,coefpset,ht1,mht1) - call gbend(rho,azero,azero,phideg,ht2,mht2) - call concat(ht1,mht1,ht2,mht2,ht1,mht1) -c form the complete product hpf1*nbend*hpf2 - call concat(ht3,mht3,ht1,mht1,h,mh) - return - end -c -c------------------------------------------------------------------ -c - subroutine cgfrngg(iw,eangle,rho,kfrn,gap,fint,iopt,coefpset,h,mh) - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - include 'pie.inc' -cryne 7/13/2002 include 'frnt.inc' - double precision mh(6,6),mht1(6,6),mht2(6,6),mht3(6,6) - double precision h(monoms),ht1(monoms),ht2(monoms),ht3(monoms) - integer lfrn,tfrn,kfrn - dimension coefpset(6) -c write(6,*)'inside cgfrngg w/ coefpset=' -c write(6,*)coefpset -c write(6,*)'and kfrn=',kfrn -c kfrn = 1,2,or 3 for dipole and/or quad fringe fields -c iw denotes which fringe: =1 for leading, = 2 for trailing -c -c this is not the most efficient routine, but it is easy to follow. -c - call ident(h,mh) -c - if(iw.eq.2)goto 200 - lfrn=kfrn -c leading fringe (iw=1): -c put on leading dipole and quad fringe fields - if(lfrn.eq.0)return -c compute and put on leading dipole fringe field -cryne 7/13/2002 gap=cfbgap -cryne 7/13/2002 xk1=cfblk1 - xk1=fint - if((lfrn.eq.1).or.(lfrn.eq.3))then - call gfrngg(eangle,rho,1,ht1,mht1,gap,xk1) - call concat(ht1,mht1,h,mh,h,mh) - endif -c compute and put on leading quad fringe fields if lfrn=2 or 3 - if(lfrn.eq.1)return - if(iopt.eq.1) then - bqd=coefpset(1) - aqd=coefpset(2) - endif - if(iopt.eq.2) then - bqd=coefpset(1) - aqd=coefpset(2) - endif - if(iopt.eq.3) then - bqd=brho*coefpset(1) - aqd=brho*coefpset(2) - endif -c compute and put on normal quad fringe field -c write(6,*)'about to call frquad (1st time) w/ bqd=',bqd - call frquad(bqd,-1,ht1,mht1) -c write(6,*)'returned from 1st call to frqad w/ mht1=' -c do i=1,6 -c write(6,'(6(1pe12.5,1x))')(mht1(i,j),j=1,6) -c enddo - call concat(ht1,mht1,h,mh,h,mh) -c compute and put on skew quad fringe field -cryne 12/21/2004 write(6,*)'cgfrngg: check this IF test' - if(aqd.ne.0.d0)then - angr=-pi/4.d0 - call arot(angr,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) -c write(6,*)'about to call frquad (2nd time) w/ aqd=',aqd - call frquad(aqd,-1,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) - angr=-angr - call arot(angr,ht1,mht1) - call concat(ht1,mht1,h,mh,h,mh) - endif - return -c - 200 continue - tfrn=kfrn -c trailing fringe (iw=2): -c put on trailing dipole and quad fringe fields - if(tfrn.eq.0)return -c compute and put on trailing dipole fringe field -cryne 7/13/2002 gap=cfbgap -cryne 7/13/2002 xk1=cfbtk1 - xk1=fint - if((tfrn.eq.1).or.(tfrn.eq.3))then - call gfrngg(eangle,rho,2,ht1,mht1,gap,xk1) - call concat(h,mh,ht1,mht1,h,mh) - endif -c compute and put on trailing quad fringe fields if tfrn=2 or 3 - if(tfrn.eq.1)return - if(iopt.eq.1) then - bqd=coefpset(1) - aqd=coefpset(2) - endif - if(iopt.eq.2) then - bqd=coefpset(1) - aqd=coefpset(2) - endif - if(iopt.eq.3) then - bqd=brho*coefpset(1) - aqd=brho*coefpset(2) - endif -c compute and put on normal quad fringe field -c write(6,*)'about to call frquad (3rd time) w/ bqd=',bqd - call frquad(bqd,1,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c compute and put on skew quad fringe field -cryne 12/21/2004 write(6,*)'cgfrngg: also check this IF test' - if(aqd.ne.0.d0)then - angr=pi/4.d0 - call arot(angr,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) -c write(6,*)'about to call frquad (4th time) w/ aqd=',aqd - call frquad(aqd,1,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - angr=-angr - call arot(angr,ht1,mht1) - call concat(h,mh,ht1,mht1,h,mh) - endif - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/cfqd.f b/OpticsJan2020/MLI_light_optics/Src/cfqd.f deleted file mode 100644 index 8992719..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/cfqd.f +++ /dev/null @@ -1,826 +0,0 @@ -********************************************************************** -* header: COMBINED FUNCTION QUADRUPOLE ROUTINES (CFQD) * -* All routines for maps for combined function quadrupoles * -********************************************************************** -c - subroutine aarot(c, s, h, mh) -c - use lieaparam, only : monoms - include 'impli.inc' - double precision h(monoms),mh(6,6) -c - call clear(h,mh) -c Rotate coordinates - mh(1,1)=c - mh(1,3)=-s - mh(3,1)=s - mh(3,3)=c -c Rotate momenta - mh(2,2)=c - mh(2,4)=-s - mh(4,2)=s - mh(4,4)=c -c Don't touch flight time - mh(5,5)=1. - mh(6,6)=1. -c Polynomials are zero (bless those linear maps). - return - end -c -********************************************************************** -c - subroutine cfdrvr(pa,fa,fm) -c - use lieaparam, only : monoms - use beamdata - include 'impli.inc' -cryne include 'parm.inc' - include 'parset.inc' -c - dimension fa(monoms) - dimension fm(6,6) - dimension pa(6),pb(6) - dimension pc(6) - dimension a(10), b(10) -c - double precision gb0,k,k2,k3,k4,l,lk,lkm,lsc - double precision sinv,cosv,ev,bedo -c -c set up parameters and control indices -c - al=pa(1) - ilfrn=nint(pa(3)) - itfrn=nint(pa(4)) - ipset=nint(pa(2)) -c -c get multipole values from the parameter set ipset -c - if (ipset.lt.1 .or. ipset.gt.maxpst) then - do 50 i=1,6 - 50 pb(i) = 0.0d0 - else - do 60 i=1,6 - 60 pb(i) = pst(i,ipset) - endif -c -c compute multipole coefficients -c - bsex=pb(3) - asex=pb(4) - boct=pb(5) - aoct=pb(6) - a(3) = asex - a(4) = aoct - b(3) = bsex - b(4) = boct - a(2) = pb(2) - b(2) = pb(1) -c - call gcfqd(al, b, a, fa, fm, ilfrn, itfrn) -c - - return - end -c -********************************************************************** -c - subroutine gcfqd(al, b, a, qa, qm, ilfr, itfr) -c - use lieaparam, only : monoms - use beamdata - include 'impli.inc' -cryne include 'parm.inc' -c - dimension qa(*), qm(6,6) - dimension ha(monoms), hm(6,6) -c - dimension a(*), b(*) -c - absqd = b(2)**2 + a(2)**2 - if ( absqd .eq. 0.0d0 ) then - asex = a(3) - bsex = b(3) - aoct = a(4) - boct = b(4) - call xcfdr(al, bsex, asex, boct, aoct, qa, qm) - else - if (a(2) .eq. 0.0d0 ) then - if(b(2) .gt. 0 ) then - cos1 = 1.d0 - cos2 = 1.d0 - cos3 = 1.d0 - cos4 = 1.d0 - sin1 = 0.d0 - sin2 = 0.d0 - sin3 = 0.d0 - sin4 = 0.d0 - else if ( b(2) .lt. 0.d0 ) then - cos1 = 0.d0 - cos2 = -1.d0 - cos3 = 0.d0 - cos4 = 1.d0 - sin1 = 1.d0 - sin2 = 0.d0 - sin3 = -1.d0 - sin4 = 0.d0 - endif - else - phi2 = atan2(a(2), b(2)) - phi = phi2/2.d0 - phi3 = 3.d0*phi - phi4 = 4.d0*phi - cos1 = cos(phi) - cos2 = cos(phi2) - cos3 = cos(phi3) - cos4 = cos(phi4) - sin1 = sin(phi) - sin2 = sin(phi2) - sin3 = sin(phi3) - sin4 = sin(phi4) - endif -c - bqd = sqrt(absqd) -c - asex = a(3)*cos3 - b(3)*sin3 - aoct = a(4)*cos4 - b(4)*sin4 - bsex = b(3)*cos3 + a(3)*sin3 - boct = b(4)*cos4 + a(4)*sin4 -c - call aarot(cos1, sin1, qa, qm) - if (ilfr .ne. 0 ) then - call frquad(bqd,-1, ha, hm) - call concat (qa, qm, ha, hm, qa, qm) - endif - call xcffqd(al, bqd, bsex, asex, boct, aoct, ha, hm) - call concat (qa, qm, ha, hm, qa, qm) - if (itfr .ne. 0 ) then - call frquad(bqd, 1, ha, hm) - call concat(qa, qm, ha, hm, qa, qm) - endif - call aarot(cos1, -sin1, ha, hm) - call concat(qa, qm, ha, hm, qa, qm) -c - endif -c - return - end -c -********************************************************************** -c - subroutine xcfdr(al, bsex, asex, boct, aoct, fa, fm) -c -c - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' -c -c calling arrays - dimension fa(monoms) - dimension fm(6,6) - dimension pa(6) -c -c local arrays - dimension ha(monoms) - dimension hm(6,6) - dimension pb(6) -c - pb(1) = al - pb(2) = bsex*al - pb(3) = asex*al - pb(4) = boct*al - pb(5) = aoct*al -c -c put map for cplm in fa,fm - call cplm(pb,fa,fm) -c -c put map for a drift of length al/2 in ha,hm - alh=al/2.d0 - call drift(alh,ha,hm) -c -c preceed and follow map for cplm with map of half-length -c drift - call concat(ha,hm,fa,fm,fa,fm) - call concat(fa,fm,ha,hm,fa,fm) -c - return - end -c -********************************************************************** -c - subroutine xcffqd(al, bqd, bsex, asex, boct, aoct, fa, fm) -c -c This subroutine computes the map for a horizontally focusing -c combined function quadrupole. -c It uses analytic formulas produced by Johannes van Zeijts -c using the symbolic manipulation program Mathematica running -c on a MacII-ci. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' -cryne include 'parm.inc' - include 'parset.inc' -c - dimension fa(monoms) - dimension fm(6,6) - dimension pa(6),pb(6) - dimension pc(6) - dimension ha(monoms) - dimension hm(6,6) -c - double precision gb0,k,k2,k3,k4,l,lk,lkm,lsc - double precision B3,B4,A3,A4,lambda -c -c compute useful numbers -c - sl2=sl*sl - sl3=sl*sl2 - bet2=beta*beta - bet3=beta*bet2 - gam2=gamma*gamma -c - fqdnr=bqd/brho - B3=bsex/brho - A3=asex/brho - B4=boct/brho - A4=aoct/brho -c - lsc=al/sl - lambda = lsc -c -c evaluate k,lk -c - arg=(bqd*(sl**2))/brho - k=dsqrt(arg) - lk=lsc*k - lkm=(-1.0d0)*lk -c -c set coefficients of fm -c - chlk=(dexp(lk)+dexp(lkm))/(2.0d0) - shlk=(dexp(lk)-dexp(lkm))/(2.0d0) - clk=dcos(lk) - slk=dsin(lk) -c - call clear(fa,fm) -c - fm(3,3)=+chlk - fm(3,4)=+(shlk/k) - fm(4,4)=+chlk - fm(4,3)=+(k*shlk) - fm(1,1)=+clk - fm(1,2)=+(slk/k) - fm(2,2)=+clk - fm(2,1)=-(k*slk) - fm(5,5)=+1.0d0 - fm(5,6)=+(lsc/((gamma**2)*(beta**2))) - fm(6,6)=+1.0d0 -c - v = k*lsc -c F3 and F4 terms ( computed by Johannes et al) -c - v = k*lambda - fa(28)=-(B3*(9*Sin(v) + Sin(3*v)))/(36*k) - fa(29)=B3*(-4 + 3*Cos(v) + Cos(3*v))/(12*k**2) - fa(30)=A3*(2*Cosh(v)*Sin(2*v) + 5*Sinh(v) + - # Cos(2*v)*Sinh(v))/(10*k) - fa(31)=A3*(-6 + 5*Cosh(v) + Cos(2*v)*Cosh(v) + - # 2*Sin(2*v)*Sinh(v))/(10*k**2) - fa(33)=k*(-2*v + Sin(2*v))/(8*beta) - fa(34)=B3*(-3*Sin(v) + Sin(3*v))/(12*k**3) - fa(35)=A3*(2 - 2*Cos(2*v)*Cosh(v) + Sin(2*v)*Sinh(v))/ - # (5*k**2) - fa(36)=A3*(Cosh(v)*Sin(2*v) - 2*Cos(2*v)*Sinh(v))/ - # (5*k**3) - fa(38)=(1 - Cos(2*v))/(4*beta) - fa(39)=B3*(5*Sin(v) + Cosh(2*v)*Sin(v) + - # 2*Cos(v)*Sinh(2*v))/(10*k) - fa(40)=B3*(-2 + 2*Cos(v)*Cosh(2*v) + Sin(v)*Sinh(2*v))/ - # (5*k**2) - fa(43)=B3*(-5*Sin(v) + Cosh(2*v)*Sin(v) + - # 2*Cos(v)*Sinh(2*v))/(10*k**3) - fa(49)=B3*(-8 + 9*Cos(v) - Cos(3*v))/(36*k**4) - fa(50)=A3*(-2*Cosh(v)*Sin(2*v) + 5*Sinh(v) - - # Cos(2*v)*Sinh(v))/(10*k**3) - fa(51)=A3*(-4 + 5*Cosh(v) - Cos(2*v)*Cosh(v) - - # 2*Sin(2*v)*Sinh(v))/(10*k**4) - fa(53)=-(2*v + Sin(2*v))/(8*beta*k) - fa(54)=B3*(6 - 5*Cos(v) - Cos(v)*Cosh(2*v) + - # 2*Sin(v)*Sinh(2*v))/(10*k**2) - fa(55)=B3*(2*Cosh(2*v)*Sin(v) - Cos(v)*Sinh(2*v))/ - # (5*k**3) - fa(58)=B3*(-4 + 5*Cos(v) - Cos(v)*Cosh(2*v) + - # 2*Sin(v)*Sinh(2*v))/(10*k**4) - fa(64)=-(A3*(9*Sinh(v) + Sinh(3*v)))/(36*k) - fa(65)=A3*(4 - 3*Cosh(v) - Cosh(3*v))/(12*k**2) - fa(67)=k*(2*v - Sinh(2*v))/(8*beta) - fa(68)=A3*(3*Sinh(v) - Sinh(3*v))/(12*k**3) - fa(70)=(1 - Cosh(2*v))/(4*beta) - fa(74)=A3*(-8 + 9*Cosh(v) - Cosh(3*v))/(36*k**4) - fa(76)=-(2*v + Sinh(2*v))/(8*beta*k) - fa(83)=-lambda/(2*beta**3*gamma**2) - fa(84)=(-2700*k**7*lambda - 7920*v*A3**2 + 6000*v*B3**2 - - # 5400*k**3*lambda*B4 - 7200*B3**2*Sin(v) +1800*k**6*Sin(2*v)- - # 4320*A3**2*Sin(2*v) + 2400*B3**2*Sin(2*v) - - # 3600*k**2*B4*Sin(2*v) + 3456*A3**2*Cosh(v)*Sin(2*v) - - # 800*B3**2*Sin(3*v) - 225*k**6*Sin(4*v) - - # 180*A3**2*Sin(4*v) - 300*B3**2*Sin(4*v) - - # 450*k**2*B4*Sin(4*v) + 8640*A3**2*Sinh(v) + - # 1728*A3**2*Cos(2*v)*Sinh(v))/(57600*k**3) - fa(85)=(45*k**6 - 156*A3**2 + 60*B3**2 -150*k**2*B4 - - # 60*k**6*Cos(2*v) + 144*A3**2*Cos(2*v) - 80*B3**2*Cos(2*v) + - # 120*k**2*B4*Cos(2*v) + 15*k**6*Cos(4*v) + - # 12*A3**2*Cos(4*v) + 20*B3**2*Cos(4*v) + - # 30*k**2*B4*Cos(4*v) + 96*A3**2*Cosh(v) - - # 96*A3**2*Cos(2*v)*Cosh(v) + - # 96*A3**2*Sin(2*v)*Sinh(v))/(960*k**4) - fa(86)=(270*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v) - - # 380*A3*B3*Cosh(v)*Sin(v) + - # 36*A3*B3*Cosh(2*v)*Sin(v) + - # 64*A3*B3*Cosh(v)*Sin(2*v) + 10*A3*B3*Sin(3*v) + - # 45*k**2*A4*Cosh(v)*Sin(3*v) - - # 12*A3*B3*Cosh(v)*Sin(3*v) + 160*A3*B3*Sinh(v) + - # 225*k**2*A4*Cos(v)*Sinh(v) - - # 380*A3*B3*Cos(v)*Sinh(v) + - # 32*A3*B3*Cos(2*v)*Sinh(v) + - # 15*k**2*A4*Cos(3*v)*Sinh(v) - - # 4*A3*B3*Cos(3*v)*Sinh(v) + - # 72*A3*B3*Cos(v)*Sinh(2*v))/(600*k**3) - fa(87)=(-240*k**2*A4 + 384*A3*B3 - 90*A3*B3*Cos(v) - - # 30*A3*B3*Cos(3*v) + 40*A3*B3*Cosh(v) + - # 225*k**2*A4*Cos(v)*Cosh(v) - - # 380*A3*B3*Cos(v)*Cosh(v) + - # 8*A3*B3*Cos(2*v)*Cosh(v) + - # 15*k**2*A4*Cos(3*v)*Cosh(v) - - # 4*A3*B3*Cos(3*v)*Cosh(v) + - # 72*A3*B3*Cos(v)*Cosh(2*v) + - # 225*k**2*A4*Sin(v)*Sinh(v) - - # 380*A3*B3*Sin(v)*Sinh(v) + - # 16*A3*B3*Sin(2*v)*Sinh(v) + - # 45*k**2*A4*Sin(3*v)*Sinh(v) - - # 12*A3*B3*Sin(3*v)*Sinh(v) + - # 36*A3*B3*Sin(v)*Sinh(2*v))/(600*k**4) - fa(89)=B3*(-12*v - 9*v*Cos(v) - 3*v*Cos(3*v) - - # 3*Sin(v) + 6*Sin(2*v) + 5*Sin(3*v))/(144*beta*k) - fa(90)=(-2700*k**7*lambda - 7920*v*A3**2 + 6000*v*B3**2 - - # 5400*k**3*lambda*B4 - 3600*B3**2*Sin(v) + - # 576*A3**2*Cosh(v)*Sin(2*v) - 2000*B3**2*Sin(3*v) + - # 675*k**6*Sin(4*v) + 540*A3**2*Sin(4*v) + - # 900*B3**2*Sin(4*v) + 1350*k**2*B4*Sin(4*v) + - # 7200*A3**2*Sinh(v) - 2592*A3**2*Cos(2*v)*Sinh(v))/ - # (28800*k**5) - fa(91)=(360*k**2*A4 - 416*A3*B3 - 210*A3*B3*Cos(v) - - # 10*A3*B3*Cos(3*v) + 180*A3*B3*Cosh(v) - - # 225*k**2*A4*Cos(v)*Cosh(v) + - # 380*A3*B3*Cos(v)*Cosh(v) + - # 28*A3*B3*Cos(2*v)*Cosh(v) - - # 135*k**2*A4*Cos(3*v)*Cosh(v) + - # 36*A3*B3*Cos(3*v)*Cosh(v) + - # 12*A3*B3*Cos(v)*Cosh(2*v) + - # 225*k**2*A4*Sin(v)*Sinh(v) - - # 380*A3*B3*Sin(v)*Sinh(v) + - # 76*A3*B3*Sin(2*v)*Sinh(v) + - # 45*k**2*A4*Sin(3*v)*Sinh(v) - - # 12*A3*B3*Sin(3*v)*Sinh(v) + - # 96*A3*B3*Sin(v)*Sinh(2*v))/(600*k**4) - fa(92)=(-120*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v) - - # 380*A3*B3*Cosh(v)*Sin(v) + - # 96*A3*B3*Cosh(2*v)*Sin(v) + - # 4*A3*B3*Cosh(v)*Sin(2*v) - 80*A3*B3*Sin(3*v) + - # 45*k**2*A4*Cosh(v)*Sin(3*v) - - # 12*A3*B3*Cosh(v)*Sin(3*v) + 120*A3*B3*Sinh(v) - - # 225*k**2*A4*Cos(v)*Sinh(v) + - # 380*A3*B3*Cos(v)*Sinh(v) + - # 112*A3*B3*Cos(2*v)*Sinh(v) - - # 135*k**2*A4*Cos(3*v)*Sinh(v) + - # 36*A3*B3*Cos(3*v)*Sinh(v) + - # 12*A3*B3*Cos(v)*Sinh(2*v))/(600*k**5) - fa(94)=B3*(-2 + 4*Cos(v) + 2*Cos(2*v) - 4*Cos(3*v) - - # 3*v*Sin(v) - 3*v*Sin(3*v))/(48*beta*k**2) - fa(95)=(300*k**7*lambda + 1680*v*A3**2 - 1680*v*B3**2 + - # 1800*k**3*lambda*B4 + 2440*B3**2*Sin(v) + - # 272*B3**2*Cosh(2*v)*Sin(v) - 150*k**6*Sin(2*v) + - # 600*A3**2*Sin(2*v) - 440*B3**2*Sin(2*v) + - # 900*k**2*B4*Sin(2*v) - 544*A3**2*Cosh(v)*Sin(2*v) + - # 75*k**6*Cosh(2*v)*Sin(2*v) + - # 340*A3**2*Cosh(2*v)*Sin(2*v) + - # 140*B3**2*Cosh(2*v)*Sin(2*v) + - # 450*k**2*B4*Cosh(2*v)*Sin(2*v) + 120*B3**2*Sin(3*v) - - # 2440*A3**2*Sinh(v) - 272*A3**2*Cos(2*v)*Sinh(v) - - # 150*k**6*Sinh(2*v) + 440*A3**2*Sinh(2*v) - - # 600*B3**2*Sinh(2*v) + 900*k**2*B4*Sinh(2*v) + - # 544*B3**2*Cos(v)*Sinh(2*v) + - # 75*k**6*Cos(2*v)*Sinh(2*v) - - # 140*A3**2*Cos(2*v)*Sinh(2*v) - - # 340*B3**2*Cos(2*v)*Sinh(2*v) + - # 450*k**2*B4*Cos(2*v)*Sinh(2*v) - 120*A3**2*Sinh(3*v))/ - # (4800*k**3) - fa(96)=(15*k**6 - 60*A3**2 + 188*B3**2 - 270*k**2*B4 - - # 24*B3**2*Cos(v) - 8*B3**2*Cos(3*v) - 88*A3**2*Cosh(v) + - # 112*A3**2*Cos(2*v)*Cosh(v) - 30*k**6*Cosh(2*v) + - # 88*A3**2*Cosh(2*v) - 120*B3**2*Cosh(2*v) + - # 180*k**2*B4*Cosh(2*v) + 32*B3**2*Cos(v)*Cosh(2*v) + - # 15*k**6*Cos(2*v)*Cosh(2*v) - - # 28*A3**2*Cos(2*v)*Cosh(2*v) - - # 68*B3**2*Cos(2*v)*Cosh(2*v) + - # 90*k**2*B4*Cos(2*v)*Cosh(2*v) - 24*A3**2*Cosh(3*v) - - # 64*A3**2*Sin(2*v)*Sinh(v) + - # 16*B3**2*Sin(v)*Sinh(2*v) + - # 15*k**6*Sin(2*v)*Sinh(2*v) + - # 68*A3**2*Sin(2*v)*Sinh(2*v) + - # 28*B3**2*Sin(2*v)*Sinh(2*v) + - # 90*k**2*B4*Sin(2*v)*Sinh(2*v))/(480*k**4) - fa(98)=A3*(10*v + 5*v*Cosh(v) + - # 5*v*Cos(2*v)*Cosh(v) - 2*Sin(2*v) - - # 2*Cosh(v)*Sin(2*v) - Sinh(v) - - # 5*Cos(2*v)*Sinh(v) - 3*Sinh(2*v))/(40*beta*k) - fa(99)=(-300*k**7*lambda - 1680*v*A3**2 + 1680*v*B3**2 - - # 1800*k**3*lambda*B4 - 160*B3**2*Sin(v) - - # 112*B3**2*Cosh(2*v)*Sin(v) + 150*k**6*Sin(2*v) - - # 600*A3**2*Sin(2*v) + 440*B3**2*Sin(2*v) - - # 900*k**2*B4*Sin(2*v) - 256*A3**2*Cosh(v)*Sin(2*v) + - # 75*k**6*Cosh(2*v)*Sin(2*v) + - # 340*A3**2*Cosh(2*v)*Sin(2*v) + - # 140*B3**2*Cosh(2*v)*Sin(2*v) + - # 450*k**2*B4*Cosh(2*v)*Sin(2*v) - 80*B3**2*Sin(3*v) + - # 1160*A3**2*Sinh(v) + 1312*A3**2*Cos(2*v)*Sinh(v) - - # 150*k**6*Sinh(2*v) + 440*A3**2*Sinh(2*v) - - # 600*B3**2*Sinh(2*v) + 900*k**2*B4*Sinh(2*v) - - # 224*B3**2*Cos(v)*Sinh(2*v) + - # 75*k**6*Cos(2*v)*Sinh(2*v) - - # 140*A3**2*Cos(2*v)*Sinh(2*v) - - # 340*B3**2*Cos(2*v)*Sinh(2*v) + - # 450*k**2*B4*Cos(2*v)*Sinh(2*v) - 120*A3**2*Sinh(3*v))/ - # (4800*k**5) - fa(101)=A3*(-3 + 6*Cos(2*v) + 4*Cosh(v) - - # 4*Cos(2*v)*Cosh(v) - 3*Cosh(2*v) + - # 5*v*Sinh(v) + 5*v*Cos(2*v)*Sinh(v))/ - # (40*beta*k**2) - fa(104)=k*(-8*v + 4*beta**2*v + 2*v*Cos(2*v) + - # 3*Sin(2*v) - 2*beta**2*Sin(2*v))/(32*beta**2) - fa(105)=(75*k**6 - 132*A3**2 + 100*B3**2 - 90*k**2*B4 - - # 80*B3**2*Cos(v) - 60*k**6*Cos(2*v) + 144*A3**2*Cos(2*v) - - # 80*B3**2*Cos(2*v) + 120*k**2*B4*Cos(2*v) + - # 80*B3**2*Cos(3*v) - 15*k**6*Cos(4*v) - - # 12*A3**2*Cos(4*v) - 20*B3**2*Cos(4*v) - - # 30*k**2*B4*Cos(4*v) + 96*A3**2*Cosh(v) - - # 96*A3**2*Cos(2*v)*Cosh(v))/(960*k**6) - fa(106)=(90*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v) - - # 380*A3*B3*Cosh(v)*Sin(v) + - # 72*A3*B3*Cosh(2*v)*Sin(v) + - # 208*A3*B3*Cosh(v)*Sin(2*v) + 10*A3*B3*Sin(3*v) - - # 135*k**2*A4*Cosh(v)*Sin(3*v) + - # 36*A3*B3*Cosh(v)*Sin(3*v) + 60*A3*B3*Sinh(v) + - # 225*k**2*A4*Cos(v)*Sinh(v) - - # 380*A3*B3*Cos(v)*Sinh(v) - - # 76*A3*B3*Cos(2*v)*Sinh(v) - - # 45*k**2*A4*Cos(3*v)*Sinh(v) + - # 12*A3*B3*Cos(3*v)*Sinh(v) + - # 24*A3*B3*Cos(v)*Sinh(2*v))/(600*k**5) - fa(107)=(-180*k**2*A4 + 368*A3*B3 - 30*A3*B3*Cos(v)+ - # 70*A3*B3*Cos(3*v) - 60*A3*B3*Cosh(v) + - # 225*k**2*A4*Cos(v)*Cosh(v) - - # 380*A3*B3*Cos(v)*Cosh(v) - - # 4*A3*B3*Cos(2*v)*Cosh(v) - - # 45*k**2*A4*Cos(3*v)*Cosh(v) + - # 12*A3*B3*Cos(3*v)*Cosh(v) + - # 24*A3*B3*Cos(v)*Cosh(2*v) + - # 225*k**2*A4*Sin(v)*Sinh(v) - - # 380*A3*B3*Sin(v)*Sinh(v) + - # 232*A3*B3*Sin(2*v)*Sinh(v) - - # 135*k**2*A4*Sin(3*v)*Sinh(v) + - # 36*A3*B3*Sin(3*v)*Sinh(v) + - # 72*A3*B3*Sin(v)*Sinh(2*v))/(600*k**6) - fa(109)=B3*(-3*v*Cos(v) + 3*v*Cos(3*v) - - # 7*Sin(v) + 8*Sin(2*v) - 3*Sin(3*v))/(48*beta*k**3) - fa(110)=(-15*k**6 + 188*A3**2 - 60*B3**2 + 270*k**2*B4- - # 88*B3**2*Cos(v) + 30*k**6*Cos(2*v) - 120*A3**2*Cos(2*v) + - # 88*B3**2*Cos(2*v) - 180*k**2*B4*Cos(2*v) - - # 24*B3**2*Cos(3*v) - 24*A3**2*Cosh(v) + - # 32*A3**2*Cos(2*v)*Cosh(v) + - # 112*B3**2*Cos(v)*Cosh(2*v) - - # 15*k**6*Cos(2*v)*Cosh(2*v) - - # 68*A3**2*Cos(2*v)*Cosh(2*v) - - # 28*B3**2*Cos(2*v)*Cosh(2*v) - - # 90*k**2*B4*Cos(2*v)*Cosh(2*v) - 8*A3**2*Cosh(3*v) - - # 16*A3**2*Sin(2*v)*Sinh(v) + - # 64*B3**2*Sin(v)*Sinh(2*v) + - # 15*k**6*Sin(2*v)*Sinh(2*v) - - # 28*A3**2*Sin(2*v)*Sinh(2*v) - - # 68*B3**2*Sin(2*v)*Sinh(2*v) + - # 90*k**2*B4*Sin(2*v)*Sinh(2*v))/(480*k**4) - fa(111)=(-24*B3**2*Sin(v) + 16*B3**2*Cosh(2*v)*Sin(v) + - # 112*A3**2*Cosh(v)*Sin(2*v) + - # 15*k**6*Cosh(2*v)*Sin(2*v) - - # 28*A3**2*Cosh(2*v)*Sin(2*v) - - # 68*B3**2*Cosh(2*v)*Sin(2*v) + - # 90*k**2*B4*Cosh(2*v)*Sin(2*v) - 8*B3**2*Sin(3*v) - - # 24*A3**2*Sinh(v) + 16*A3**2*Cos(2*v)*Sinh(v) + - # 112*B3**2*Cos(v)*Sinh(2*v) - - # 15*k**6*Cos(2*v)*Sinh(2*v) - - # 68*A3**2*Cos(2*v)*Sinh(2*v) - - # 28*B3**2*Cos(2*v)*Sinh(2*v) - - # 90*k**2*B4*Cos(2*v)*Sinh(2*v) - 8*A3**2*Sinh(3*v))/ - # (240*k**5) - fa(113)=A3*(1 - Cosh(2*v) + 5*v*Cosh(v)*Sin(2*v) - - # 4*Sin(2*v)*Sinh(v))/(20*beta*k**2) - fa(114)=(45*k**6 - 52*A3**2 + 116*B3**2 - 90*k**2*B4 - - # 128*B3**2*Cos(v) - 30*k**6*Cos(2*v) + - # 120*A3**2*Cos(2*v) - 88*B3**2*Cos(2*v) + - # 180*k**2*B4*Cos(2*v) + 16*B3**2*Cos(3*v) - - # 24*A3**2*Cosh(v) + 32*A3**2*Cos(2*v)*Cosh(v) + - # 112*B3**2*Cos(v)*Cosh(2*v) - - # 15*k**6*Cos(2*v)*Cosh(2*v) - - # 68*A3**2*Cos(2*v)*Cosh(2*v) - - # 28*B3**2*Cos(2*v)*Cosh(2*v) - - # 90*k**2*B4*Cos(2*v)*Cosh(2*v) - 8*A3**2*Cosh(3*v) + - # 224*A3**2*Sin(2*v)*Sinh(v) - - # 32*B3**2*Sin(v)*Sinh(2*v) + - # 15*k**6*Sin(2*v)*Sinh(2*v) - - # 28*A3**2*Sin(2*v)*Sinh(2*v) - - # 68*B3**2*Sin(2*v)*Sinh(2*v) + - # 90*k**2*B4*Sin(2*v)*Sinh(2*v))/(480*k**6) - fa(116)=A3*(5*Sin(2*v) - 3*Cosh(v)*Sin(2*v) - - # 2*Cos(2*v)*Sinh(v) + 5*v*Sin(2*v)*Sinh(v) - - # Sinh(2*v))/(20*beta*k**3) - fa(119)=(2 - beta**2 - 2*Cos(2*v) + beta**2*Cos(2*v) + - # v*Sin(2*v))/(8*beta**2) - fa(120)=(-160*A3*B3*Sin(v) - 225*k**2*A4*Cosh(v)*Sin(v)+ - # 380*A3*B3*Cosh(v)*Sin(v) - - # 32*A3*B3*Cosh(2*v)*Sin(v) - - # 15*k**2*A4*Cosh(3*v)*Sin(v) + - # 4*A3*B3*Cosh(3*v)*Sin(v) - - # 72*A3*B3*Cosh(v)*Sin(2*v) - 270*A3*B3*Sinh(v) - - # 225*k**2*A4*Cos(v)*Sinh(v) + - # 380*A3*B3*Cos(v)*Sinh(v) - - # 36*A3*B3*Cos(2*v)*Sinh(v) - - # 64*A3*B3*Cos(v)*Sinh(2*v) - 10*A3*B3*Sinh(3*v) - - # 45*k**2*A4*Cos(v)*Sinh(3*v) + - # 12*A3*B3*Cos(v)*Sinh(3*v))/(600*k**3) - fa(121)=(360*k**2*A4 - 416*A3*B3 + 180*A3*B3*Cos(v)- - # 210*A3*B3*Cosh(v) - 225*k**2*A4*Cos(v)*Cosh(v) + - # 380*A3*B3*Cos(v)*Cosh(v) + - # 12*A3*B3*Cos(2*v)*Cosh(v) + - # 28*A3*B3*Cos(v)*Cosh(2*v) - 10*A3*B3*Cosh(3*v) - - # 135*k**2*A4*Cos(v)*Cosh(3*v) + - # 36*A3*B3*Cos(v)*Cosh(3*v) - - # 225*k**2*A4*Sin(v)*Sinh(v) + - # 380*A3*B3*Sin(v)*Sinh(v) - - # 96*A3*B3*Sin(2*v)*Sinh(v) - - # 76*A3*B3*Sin(v)*Sinh(2*v) - - # 45*k**2*A4*Sin(v)*Sinh(3*v) + - # 12*A3*B3*Sin(v)*Sinh(3*v))/(600*k**4) - fa(123)=B3*(10*v + 5*v*Cos(v) + - # 5*v*Cos(v)*Cosh(2*v) - Sin(v) - - # 5*Cosh(2*v)*Sin(v) - 3*Sin(2*v) - 2*Sinh(2*v) - - # 2*Cos(v)*Sinh(2*v))/(40*beta*k) - fa(124)=(60*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v) - - # 380*A3*B3*Cosh(v)*Sin(v) - - # 76*A3*B3*Cosh(2*v)*Sin(v) - - # 45*k**2*A4*Cosh(3*v)*Sin(v) + - # 12*A3*B3*Cosh(3*v)*Sin(v) + - # 24*A3*B3*Cosh(v)*Sin(2*v) + 90*A3*B3*Sinh(v) + - # 225*k**2*A4*Cos(v)*Sinh(v) - - # 380*A3*B3*Cos(v)*Sinh(v) + - # 72*A3*B3*Cos(2*v)*Sinh(v) + - # 208*A3*B3*Cos(v)*Sinh(2*v) + 10*A3*B3*Sinh(3*v) - - # 135*k**2*A4*Cos(v)*Sinh(3*v) + - # 36*A3*B3*Cos(v)*Sinh(3*v))/(600*k**5) - fa(126)=B3*(-1 + Cos(2*v) + 5*v*Cos(v)*Sinh(2*v) - - # 4*Sin(v)*Sinh(2*v))/(20*beta*k**2) - fa(130)=(-180*k**2*A4 + 368*A3*B3 - 180*A3*B3*Cos(v)+ - # 30*A3*B3*Cosh(v) + 225*k**2*A4*Cos(v)*Cosh(v) - - # 380*A3*B3*Cos(v)*Cosh(v) + - # 24*A3*B3*Cos(2*v)*Cosh(v) + - # 116*A3*B3*Cos(v)*Cosh(2*v) + 10*A3*B3*Cosh(3*v) - - # 45*k**2*A4*Cos(v)*Cosh(3*v) + - # 12*A3*B3*Cos(v)*Cosh(3*v) + - # 225*k**2*A4*Sin(v)*Sinh(v) - - # 380*A3*B3*Sin(v)*Sinh(v) + - # 48*A3*B3*Sin(2*v)*Sinh(v) - - # 32*A3*B3*Sin(v)*Sinh(2*v) - - # 15*k**2*A4*Sin(v)*Sinh(3*v) + - # 4*A3*B3*Sin(v)*Sinh(3*v))/(600*k**6) - fa(132)=B3*(-5*v*Cos(v) + 5*v*Cos(v)*Cosh(2*v) - - # 9*Sin(v) - 3*Cosh(2*v)*Sin(v) + 2*Sin(2*v) + - # 2*Sinh(2*v) + 2*Cos(v)*Sinh(2*v))/(40*beta*k**3) - fa(140)=(-2700*k**7*lambda - 7920*v*A3**2 + 6000*v*B3**2 - - # 5400*k**3*lambda*B4 - 4800*B3**2*Sin(v) -1800*k**6*Sin(2*v)+ - # 4320*A3**2*Sin(2*v) - 2400*B3**2*Sin(2*v) + - # 3600*k**2*B4*Sin(2*v) - 2304*A3**2*Cosh(v)*Sin(2*v) + - # 1600*B3**2*Sin(3*v) - 225*k**6*Sin(4*v) - - # 180*A3**2*Sin(4*v) - 300*B3**2*Sin(4*v) - - # 450*k**2*B4*Sin(4*v) + 5760*A3**2*Sinh(v) - - # 1152*A3**2*Cos(2*v)*Sinh(v))/(57600*k**7) - fa(141)=(180*k**2*A4 - 368*A3*B3 - 30*A3*B3*Cos(v) - - # 10*A3*B3*Cos(3*v) + 180*A3*B3*Cosh(v) - - # 225*k**2*A4*Cos(v)*Cosh(v) + - # 380*A3*B3*Cos(v)*Cosh(v) - - # 116*A3*B3*Cos(2*v)*Cosh(v) + - # 45*k**2*A4*Cos(3*v)*Cosh(v) - - # 12*A3*B3*Cos(3*v)*Cosh(v) - - # 24*A3*B3*Cos(v)*Cosh(2*v) + - # 225*k**2*A4*Sin(v)*Sinh(v) - - # 380*A3*B3*Sin(v)*Sinh(v) - - # 32*A3*B3*Sin(2*v)*Sinh(v) - - # 15*k**2*A4*Sin(3*v)*Sinh(v) + - # 4*A3*B3*Sin(3*v)*Sinh(v) + - # 48*A3*B3*Sin(v)*Sinh(2*v))/(600*k**6) - fa(142)=(-60*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v) - - # 380*A3*B3*Cosh(v)*Sin(v) + - # 48*A3*B3*Cosh(2*v)*Sin(v) - - # 8*A3*B3*Cosh(v)*Sin(2*v) + 20*A3*B3*Sin(3*v) - - # 15*k**2*A4*Cosh(v)*Sin(3*v) + - # 4*A3*B3*Cosh(v)*Sin(3*v) + 120*A3*B3*Sinh(v) - - # 225*k**2*A4*Cos(v)*Sinh(v) + - # 380*A3*B3*Cos(v)*Sinh(v) - - # 104*A3*B3*Cos(2*v)*Sinh(v) + - # 45*k**2*A4*Cos(3*v)*Sinh(v) - - # 12*A3*B3*Cos(3*v)*Sinh(v) - - # 24*A3*B3*Cos(v)*Sinh(2*v))/(600*k**7) - fa(144)=B3*(-20 + 30*Cos(v) - 12*Cos(2*v) + 2*Cos(3*v) - - # 9*v*Sin(v) + 3*v*Sin(3*v))/(144*beta*k**4) - fa(145)=(300*k**7*lambda + 1680*v*A3**2 - 1680*v*B3**2 + - # 1800*k**3*lambda*B4 + 1160*B3**2*Sin(v) + - # 1312*B3**2*Cosh(2*v)*Sin(v) + 150*k**6*Sin(2*v) - - # 600*A3**2*Sin(2*v) + 440*B3**2*Sin(2*v) - - # 900*k**2*B4*Sin(2*v) - 224*A3**2*Cosh(v)*Sin(2*v) - - # 75*k**6*Cosh(2*v)*Sin(2*v) - - # 340*A3**2*Cosh(2*v)*Sin(2*v) - - # 140*B3**2*Cosh(2*v)*Sin(2*v) - - # 450*k**2*B4*Cosh(2*v)*Sin(2*v) - 120*B3**2*Sin(3*v) - - # 160*A3**2*Sinh(v) - 112*A3**2*Cos(2*v)*Sinh(v) - - # 150*k**6*Sinh(2*v) + 440*A3**2*Sinh(2*v) - - # 600*B3**2*Sinh(2*v) + 900*k**2*B4*Sinh(2*v) - - # 256*B3**2*Cos(v)*Sinh(2*v) - - # 75*k**6*Cos(2*v)*Sinh(2*v) + - # 140*A3**2*Cos(2*v)*Sinh(2*v) + - # 340*B3**2*Cos(2*v)*Sinh(2*v) - - # 450*k**2*B4*Cos(2*v)*Sinh(2*v) - 80*A3**2*Sinh(3*v))/ - # (4800*k**5) - fa(146)=(45*k**6 - 116*A3**2 + 52*B3**2 - 90*k**2*B4 + - # 24*B3**2*Cos(v) + 8*B3**2*Cos(3*v) + - # 128*A3**2*Cosh(v) - 112*A3**2*Cos(2*v)*Cosh(v) - - # 30*k**6*Cosh(2*v) + 88*A3**2*Cosh(2*v) - - # 120*B3**2*Cosh(2*v) + 180*k**2*B4*Cosh(2*v) - - # 32*B3**2*Cos(v)*Cosh(2*v) - - # 15*k**6*Cos(2*v)*Cosh(2*v) + - # 28*A3**2*Cos(2*v)*Cosh(2*v) + - # 68*B3**2*Cos(2*v)*Cosh(2*v) - - # 90*k**2*B4*Cos(2*v)*Cosh(2*v) - 16*A3**2*Cosh(3*v) - - # 32*A3**2*Sin(2*v)*Sinh(v) + - # 224*B3**2*Sin(v)*Sinh(2*v) - - # 15*k**6*Sin(2*v)*Sinh(2*v) - - # 68*A3**2*Sin(2*v)*Sinh(2*v) - - # 28*B3**2*Sin(2*v)*Sinh(2*v) - - # 90*k**2*B4*Sin(2*v)*Sinh(2*v))/(480*k**6) - fa(148)=A3*(5*v*Cosh(v) - 5*v*Cos(2*v)*Cosh(v) - - # 2*Sin(2*v) - 2*Cosh(v)*Sin(2*v) + 9*Sinh(v) + - # 3*Cos(2*v)*Sinh(v) - 2*Sinh(2*v))/(40*beta*k**3) - fa(149)=(-300*k**7*lambda - 1680*v*A3**2 + 1680*v*B3**2 - - # 1800*k**3*lambda*B4 - 1040*B3**2*Sin(v) + - # 928*B3**2*Cosh(2*v)*Sin(v) - 150*k**6*Sin(2*v) + - # 600*A3**2*Sin(2*v) - 440*B3**2*Sin(2*v) + - # 900*k**2*B4*Sin(2*v) + 64*A3**2*Cosh(v)*Sin(2*v) - - # 75*k**6*Cosh(2*v)*Sin(2*v) - - # 340*A3**2*Cosh(2*v)*Sin(2*v) - - # 140*B3**2*Cosh(2*v)*Sin(2*v) - - # 450*k**2*B4*Cosh(2*v)*Sin(2*v) + 80*B3**2*Sin(3*v) + - # 1040*A3**2*Sinh(v) - 928*A3**2*Cos(2*v)*Sinh(v) - - # 150*k**6*Sinh(2*v) + 440*A3**2*Sinh(2*v) - - # 600*B3**2*Sinh(2*v) + 900*k**2*B4*Sinh(2*v) - - # 64*B3**2*Cos(v)*Sinh(2*v) - - # 75*k**6*Cos(2*v)*Sinh(2*v) + - # 140*A3**2*Cos(2*v)*Sinh(2*v) + - # 340*B3**2*Cos(2*v)*Sinh(2*v) - - # 450*k**2*B4*Cos(2*v)*Sinh(2*v) - 80*A3**2*Sinh(3*v))/ - # (4800*k**7) - fa(151)=A3*(-10 - 4*Cos(2*v) + 14*Cosh(v) + - # 2*Cos(2*v)*Cosh(v) - 2*Cosh(2*v) + - # 5*v*Sinh(v) - 5*v*Cos(2*v)*Sinh(v) - - # 4*Sin(2*v)*Sinh(v))/(40*beta*k**4) - fa(154)=(-12*v + 4*beta**2*v - 2*v*Cos(2*v) - - # 5*Sin(2*v) + 2*beta**2*Sin(2*v))/(32*beta**2*k) - fa(155)=(-240*k**2*A4 + 384*A3*B3 + 40*A3*B3*Cos(v) - - # 90*A3*B3*Cosh(v) + 225*k**2*A4*Cos(v)*Cosh(v) - - # 380*A3*B3*Cos(v)*Cosh(v) + - # 72*A3*B3*Cos(2*v)*Cosh(v) + - # 8*A3*B3*Cos(v)*Cosh(2*v) - 30*A3*B3*Cosh(3*v) + - # 15*k**2*A4*Cos(v)*Cosh(3*v) - - # 4*A3*B3*Cos(v)*Cosh(3*v) - - # 225*k**2*A4*Sin(v)*Sinh(v) + - # 380*A3*B3*Sin(v)*Sinh(v) - - # 36*A3*B3*Sin(2*v)*Sinh(v) - - # 16*A3*B3*Sin(v)*Sinh(2*v) - - # 45*k**2*A4*Sin(v)*Sinh(3*v) + - # 12*A3*B3*Sin(v)*Sinh(3*v))/(600*k**4) - fa(156)=(120*A3*B3*Sin(v) - 225*k**2*A4*Cosh(v)*Sin(v) + - # 380*A3*B3*Cosh(v)*Sin(v) + - # 112*A3*B3*Cosh(2*v)*Sin(v) - - # 135*k**2*A4*Cosh(3*v)*Sin(v) + - # 36*A3*B3*Cosh(3*v)*Sin(v) + - # 12*A3*B3*Cosh(v)*Sin(2*v) - 120*A3*B3*Sinh(v) + - # 225*k**2*A4*Cos(v)*Sinh(v) - - # 380*A3*B3*Cos(v)*Sinh(v) + - # 96*A3*B3*Cos(2*v)*Sinh(v) + - # 4*A3*B3*Cos(v)*Sinh(2*v) - 80*A3*B3*Sinh(3*v) + - # 45*k**2*A4*Cos(v)*Sinh(3*v) - - # 12*A3*B3*Cos(v)*Sinh(3*v))/(600*k**5) - fa(158)=B3*(3 - 4*Cos(v) + 3*Cos(2*v) - 6*Cosh(2*v) + - # 4*Cos(v)*Cosh(2*v) + 5*v*Sin(v) + - # 5*v*Cosh(2*v)*Sin(v))/(40*beta*k**2) - fa(159)=(180*k**2*A4 - 368*A3*B3 + 60*A3*B3*Cos(v) + - # 30*A3*B3*Cosh(v) - 225*k**2*A4*Cos(v)*Cosh(v) + - # 380*A3*B3*Cos(v)*Cosh(v) - - # 24*A3*B3*Cos(2*v)*Cosh(v) + - # 4*A3*B3*Cos(v)*Cosh(2*v) - 70*A3*B3*Cosh(3*v) + - # 45*k**2*A4*Cos(v)*Cosh(3*v) - - # 12*A3*B3*Cos(v)*Cosh(3*v) + - # 225*k**2*A4*Sin(v)*Sinh(v) - - # 380*A3*B3*Sin(v)*Sinh(v) + - # 72*A3*B3*Sin(2*v)*Sinh(v) + - # 232*A3*B3*Sin(v)*Sinh(2*v) - - # 135*k**2*A4*Sin(v)*Sinh(3*v) + - # 36*A3*B3*Sin(v)*Sinh(3*v))/(600*k**6) - fa(161)=B3*(2*Cosh(2*v)*Sin(v) + Sin(2*v) - - # 5*Sinh(2*v) + 3*Cos(v)*Sinh(2*v) + - # 5*v*Sin(v)*Sinh(2*v))/(20*beta*k**3) - fa(165)=(-120*A3*B3*Sin(v) + 225*k**2*A4*Cosh(v)*Sin(v)- - # 380*A3*B3*Cosh(v)*Sin(v) + - # 104*A3*B3*Cosh(2*v)*Sin(v) - - # 45*k**2*A4*Cosh(3*v)*Sin(v) + - # 12*A3*B3*Cosh(3*v)*Sin(v) + - # 24*A3*B3*Cosh(v)*Sin(2*v) + 60*A3*B3*Sinh(v) - - # 225*k**2*A4*Cos(v)*Sinh(v) + - # 380*A3*B3*Cos(v)*Sinh(v) - - # 48*A3*B3*Cos(2*v)*Sinh(v) + - # 8*A3*B3*Cos(v)*Sinh(2*v) - 20*A3*B3*Sinh(3*v) + - # 15*k**2*A4*Cos(v)*Sinh(3*v) - - # 4*A3*B3*Cos(v)*Sinh(3*v))/(600*k**7) - fa(167)=B3*(-10 + 14*Cos(v) - 2*Cos(2*v) - 4*Cosh(2*v) + - # 2*Cos(v)*Cosh(2*v) - 5*v*Sin(v) + - # 5*v*Cosh(2*v)*Sin(v) + 4*Sin(v)*Sinh(2*v))/ - # (40*beta*k**4) - fa(175)=(-2700*k**7*lambda - 6000*v*A3**2 + 7920*v*B3**2 - - # 5400*k**3*lambda*B4 - 8640*B3**2*Sin(v) - - # 1728*B3**2*Cosh(2*v)*Sin(v) + 7200*A3**2*Sinh(v) + - # 1800*k**6*Sinh(2*v) - 2400*A3**2*Sinh(2*v) + - # 4320*B3**2*Sinh(2*v) - 3600*k**2*B4*Sinh(2*v) - - # 3456*B3**2*Cos(v)*Sinh(2*v) + 800*A3**2*Sinh(3*v) - - # 225*k**6*Sinh(4*v) + 300*A3**2*Sinh(4*v) + - # 180*B3**2*Sinh(4*v) - 450*k**2*B4*Sinh(4*v))/(57600*k**3) - fa(176)=(-45*k**6 + 60*A3**2 - 156*B3**2 + 150*k**2*B4 + - # 96*B3**2*Cos(v) + 60*k**6*Cosh(2*v) - - # 80*A3**2*Cosh(2*v) + 144*B3**2*Cosh(2*v) - - # 120*k**2*B4*Cosh(2*v) - 96*B3**2*Cos(v)*Cosh(2*v) - - # 15*k**6*Cosh(4*v) + 20*A3**2*Cosh(4*v) + - # 12*B3**2*Cosh(4*v) - 30*k**2*B4*Cosh(4*v) - - # 96*B3**2*Sin(v)*Sinh(2*v))/(960*k**4) - fa(178)=A3*(-12*v - 9*v*Cosh(v) - 3*v*Cosh(3*v) - - # 3*Sinh(v) + 6*Sinh(2*v) + 5*Sinh(3*v))/(144*beta*k) - fa(179)=(2700*k**7*lambda + 6000*v*A3**2 - 7920*v*B3**2 + - # 5400*k**3*lambda*B4 + 7200*B3**2*Sin(v) - - # 2592*B3**2*Cosh(2*v)*Sin(v) - 3600*A3**2*Sinh(v) + - # 576*B3**2*Cos(v)*Sinh(2*v) - 2000*A3**2*Sinh(3*v) - - # 675*k**6*Sinh(4*v) + 900*A3**2*Sinh(4*v) + - # 540*B3**2*Sinh(4*v) - 1350*k**2*B4*Sinh(4*v))/(28800*k**5) - fa(181)=A3*(2 - 4*Cosh(v) - 2*Cosh(2*v) + 4*Cosh(3*v) - - # 3*v*Sinh(v) - 3*v*Sinh(3*v))/(48*beta*k**2) - fa(184)=k*(8*v - 4*beta**2*v - 2*v*Cosh(2*v) - - # 3*Sinh(2*v) + 2*beta**2*Sinh(2*v))/(32*beta**2) - fa(185)=(75*k**6 - 100*A3**2 + 132*B3**2 - 90*k**2*B4 - - # 96*B3**2*Cos(v) + 80*A3**2*Cosh(v) - 60*k**6*Cosh(2*v) + - # 80*A3**2*Cosh(2*v) - 144*B3**2*Cosh(2*v) + - # 120*k**2*B4*Cosh(2*v) + 96*B3**2*Cos(v)*Cosh(2*v) - - # 80*A3**2*Cosh(3*v) - 15*k**6*Cosh(4*v) + - # 20*A3**2*Cosh(4*v) + 12*B3**2*Cosh(4*v) - - # 30*k**2*B4*Cosh(4*v))/(960*k**6) - fa(187)=A3*(3*v*Cosh(v) - 3*v*Cosh(3*v) + - # 7*Sinh(v) - 8*Sinh(2*v) + 3*Sinh(3*v))/(48*beta*k**3) - fa(190)=(2 - beta**2 - 2*Cosh(2*v) + beta**2*Cosh(2*v) - - # v*Sinh(2*v))/(8*beta**2) - fa(195)=(-2700*k**7*lambda - 6000*v*A3**2 + 7920*v*B3**2 - - # 5400*k**3*lambda*B4 - 5760*B3**2*Sin(v) + - # 1152*B3**2*Cosh(2*v)*Sin(v) + 4800*A3**2*Sinh(v) - - # 1800*k**6*Sinh(2*v) + 2400*A3**2*Sinh(2*v) - - # 4320*B3**2*Sinh(2*v) + 3600*k**2*B4*Sinh(2*v) + - # 2304*B3**2*Cos(v)*Sinh(2*v) - 1600*A3**2*Sinh(3*v) - - # 225*k**6*Sinh(4*v) + 300*A3**2*Sinh(4*v) + - # 180*B3**2*Sinh(4*v) - 450*k**2*B4*Sinh(4*v))/(57600*k**7) - fa(197)=A3*(-20 + 30*Cosh(v) - 12*Cosh(2*v) + 2*Cosh(3*v) + - # 9*v*Sinh(v) - 3*v*Sinh(3*v))/(144*beta*k**4) - fa(200)=(-12*v + 4*beta**2*v - 2*v*Cosh(2*v) - - # 5*Sinh(2*v) + 2*beta**2*Sinh(2*v))/(32*beta**2*k) - fa(209)=(-5 + beta**2)*lambda/(8*beta**4*gamma**2) -c -c go from reverse to direct factorization: -c - call revf(1,fa,fm) -c -c fringe field effects are put on in the subroutine gcfqd -c - return - end -c -c end of file - diff --git a/OpticsJan2020/MLI_light_optics/Src/coil.f b/OpticsJan2020/MLI_light_optics/Src/coil.f deleted file mode 100644 index ce4ed7b..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/coil.f +++ /dev/null @@ -1,700 +0,0 @@ -c -c -c A few changes made (like changing .0 to 0.d0) by P. Walstrom 6/04 -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine coil(pa) -c -c Parse multipole input: -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - use acceldata - include 'impli.inc' - include 'multipole.inc' - include 'parset.inc' -cryneneriwalstrom include 'elmnts.inc' - parameter(maxgauss=100) - common/gauss/xgn(maxgauss,maxgauss),wgn(maxgauss,maxgauss) -c Gaussian nodes and weights- used with some thick coils - dimension xg(maxgauss),wg(maxgauss) - double precision pa(*) -c F. Neri 3/23/90 -c Revised 7/12/90 -c Version 6/26/91 -c Including spacers... -c F. Neri - integer np -ctm -ctm dump input parameters -ctm -cryne 8/5/2004 write(6,16) (pa(i),i=1,5) -cryne 8/5/2004 16 format(' coil: ',5f12.5) -cryne 8/5/2004 write(6,17) (pa(i),i=6,11) -cryne 8/5/2004 17 format(' shape: ',6f10.4) - it = nint(pa(5)) -c -c If itype == 0 initilize commons bincof,coeffs, and gauss -ctm /gauss/ initialization added for types 13 through 17 -c - if ( it .eq. 0 ) then - ncoil = 0 - ztotal = 0.0d0 - call bincof - call coeffs -c -c Precompute gaussian weights and nodes on [-1,1]- -c these are scaled linearily for other intervals.. -c - x1=-1.d0 - x2=1.d0 - do 13 ng=1,maxgauss - call gauleg(x1,x2,xg,wg,ng) - do 13 n=1,ng - xgn(n,ng)=xg(n) - wgn(n,ng)=wg(n) - 13 continue - return - endif -c -c If itype == -1 spacer. -c - if ( it .eq. -1 ) then - if ( ncoil .eq. 0 ) then - xldr = pa(1) - else - ztotal = ztotal + pa(1) - endif - return - endif -c Increase coil number - ncoil = ncoil + 1 - if ( ncoil .gt. maxcoils ) then - write (6,*) ' Exceeded maximum number of Coils!' - call myexit - endif -c Stack name: - lblcoil(ncoil) = lmnlbl(inmenu) -c Set Length, Strength and Multipole Number: - alcoil(ncoil) = pa(1) - glprod(ncoil) = -pa(2)*pa(1) - mcoil(ncoil) = nint(pa(3)) - acoil(ncoil) = pa(4) -c Set shape(*,1) -c For type 1: Quartic = slope -c type 2: Halback = a2 -c type 3: Lambertson = xlmin -c type 4 Lamb1rsth = xlmin -c type 5 Square = N.A. -c type 6 User = ifile -c type 7 FlatTop = wflat -c type 8 Thin Halbach = N.A. -c -ctm : load all 6 shape components from pa(6) through pa(11) (4/99) - do 20 j=1,6 - shape(ncoil,j) = pa(5+j) - 20 continue -c -c Increase length of String: - ztotal = ztotal + pa(1) -c Store position of center of coil: - zcoil(ncoil) = ztotal - pa(1)/2.d0 -c Get Type Number: - itype(ncoil) = nint(pa(5)) -c Move to position of next coil: -c ztotal = ztotal + pa(6) NOW done by spacers -c - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c -c Plot multipole configuration:::: -c Option -1 in integ. -c Tlie output in file 19(?) -c F. Neri 7/28/91 -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine mulplt(zint) - use acceldata - include 'impli.inc' - include 'files.inc' - include 'multipole.inc' -cryneneriwalstrom include 'elmnts.inc' - character*11 names(10) -c - character*11 types(10) -c -c F. Neri 3/28/90 -c Names output 7/26/91 -c F. Neri -c Tlie Output 7/27/91 -c - names(1) = ' dipole' - names(2) = ' quadrupole' - names(3) = ' sextupole' - names(4) = ' octupole' -c -c type 1: Quartic -c type 2: Halback -c type 3: Lambertson -c type 4 Lamb1rsth -c type 5 Square -c type 6 User -c type 7 FlatTop -c type 8 Thin Halbach -c - types(1) = ' Quartic' - types(2) = ' RECM' - types(3) = ' Lambertson' - types(4) = ' Lamb1sth' - types(5) = ' Square' - types(6) = ' User' - types(7) = ' Flattop' - types(8) = ' Halbach' -c - zi = -xldr - zf = zint-xldr - write(jof , 101) zi, zf - write(jodf, 101) zi, zf - 101 format(1x,' Integration from ',f16.8, ' to ', f16.8) - do 2 nc = 1, ncoil - mm = mcoil(nc) - z0 = zcoil(nc) - ar = acoil(nc) - al = alcoil(nc) - z1 = z0 - (al/2.d0) - z2 = z0 + (al/2.d0) - if (mm .lt. 0 ) then - mm = -mm - write(jof ,*) lblcoil(nc) - write(jodf,*) lblcoil(nc) -c - write(jof , 102) names(mm), ar - write(jodf, 102) names(mm), ar - 102 format(' Skew',a11,' of radius ', f16.8, ' from') - write(jof , 103) z1, z2 - write(jodf, 103) z1, z2 - 103 format(' z = ',f16.8, ' to z = ', f16.8) -c Write Tlie file - write(19,*) lblcoil(nc),': multipole, ',types(itype(nc)),',' - write(19,*) ' L = ',al,', Skew, K = ', -glprod(nc)/al,',' - write(19,*) ' position = ',z1,',' - write(19,*) ' radius = ',ar,', m = ',mm - else - write(jof ,*) lblcoil(nc) - write(jodf,*) lblcoil(nc) -c - write(jof , 104) names(mm), ar - write(jodf, 104) names(mm), ar - 104 format(' ',a11,' of radius ', f16.8, ' from') -c Write Tlie file - write(jof , 103) z1, z2 - write(jodf, 103) z1, z2 - write(19,*) lblcoil(nc),': multipole, ',types(itype(nc)),',' - write(19,*) ' L = ',al,', K = ', -glprod(nc)/al,',' - write(19,*) ' position = ',z1,',' - write(19,*) ' radius = ',ar,', m = ',mm -c - endif - 2 continue - write(19,*) ' : multipolelist =(',(lblcoil(nc),',',nc=1,ncoil) - 4 continue - write(19,*) ' zmin = ',zi,', zmax = ',zf,')' - return - end -c -ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine multcfq(zlength,fa,fm) -c -c option 0 in integ: translate coils to cfqd. -c this version by F. Neri, 6/27/91 -c -ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' -cryneneriwalstrom include 'parm.inc' -cryneneriwalstrom include 'param.inc' - include 'dip.inc' - include 'pie.inc' - include 'gronax.inc' - include 'multipole.inc' -c calling arrays - dimension fa(monoms), fm(6,6) -c internal arrays - parameter (MAXX = 1000) - parameter (TINY=1.d-10) - dimension xv(MAXX) - dimension a(100), b(100) -c - dimension qa(monoms), qm(6,6) -c - xv(1) = 0.d0 - nx = 1 -c - nx = nx+1 - if( nx.gt. MAXX) goto 111 - xv(nx) = zlength -c - do 1 j = 1, ncoil - do 12 i = 1,nx - if(abs(xldr+zcoil(j)-alcoil(j)/2.d0-xv(i)).lt.TINY) goto 100 - 12 continue -c - nx = nx+1 - if( nx.gt. MAXX) goto 111 - xv(nx) = xldr+zcoil(j)-alcoil(j)/2.d0 -c - 100 continue -c - do 22 i = 1,nx - if(abs(xldr+zcoil(j)+alcoil(j)/2.d0-xv(i)).lt.TINY) goto 200 - 22 continue -c - nx = nx+1 - if( nx.gt. MAXX) goto 111 - xv(nx) = xldr+zcoil(j)+alcoil(j)/2.d0 -c - 200 continue - 1 continue -c -c Sort xv -c - call piksrt(nx,xv) -c - call clear(fa,fm) -c - do 444 j = 1,6 - fm(j,j) = 1.d0 - 444 continue -c - - do 3 i = 1, nx-1 - alen = xv(i+1)-xv(i) - xpos = (xv(i+1)+xv(i))/2.d0 - do 32 m = 1, 4 - a(m) = 0.0d0 - b(m) = 0.0d0 - 32 continue -c - do 31 j = 1, ncoil - if(xpos.gt.zcoil(j)-alcoil(j)/2.d0+xldr - # .and.xpos.lt.zcoil(j)+alcoil(j)/2.d0+xldr) then - if (mcoil(j) .gt. 0 ) then - b(mcoil(j)) = b(mcoil(j))-glprod(j)/alcoil(j) - else - a(-mcoil(j)) = a(-mcoil(j))-glprod(j)/alcoil(j) - endif - endif - 31 continue - write(6,113) alen,b(2),b(3),b(4) - 113 format(1x,4(1x,1pg16.8)) - call gcfqd(alen, b, a, qa, qm, 1, 1) -c call pcmap(3, 0, 0 ,0, qa, qm) - call concat(fa,fm,qa,qm,fa,fm) - 3 continue - return - 111 write(6,*) ' MAXX exceeded in integ CFQD interpreter!' - call myexit - return - end -c -c -c - SUBROUTINE PIKSRT(N,ARR) - include 'impli.inc' - DIMENSION ARR(N) - DO 12 J=2,N - A=ARR(J) - DO 11 I=J-1,1,-1 - IF(ARR(I).LE.A)GO TO 10 - ARR(I+1)=ARR(I) -11 CONTINUE - I=0 -10 ARR(I+1)=A -12 CONTINUE - RETURN - END -c -c - subroutine a3(q,x0,y0) - use beamdata - use lieaparam, only : monoms - include 'impli.inc' -cryneneriwalstrom include 'parm.inc' -cryneneriwalstrom include 'param.inc' - include 'vecpot.inc' - include 'gronax.inc' - include 'prodex.inc' -c - double precision AAx(0:10,0:10),AAy(0:10,0:10),AAz(0:10,0:10) - double precision a(0:10,0:10) -c - do 101 i = 0,10 - do 101 j = 0,10 - AAx(i,j) = 0.0d0 - AAy(i,j) = 0.0d0 - AAz(i,j) = 0.0d0 - 101 continue -c - AAz(1,0)=-(q*gn(1,0)) - AAz(0,1)=q*gs(1,0) - AAx(2,0)=q*gn(1,1) - AAz(2,0)=-(q*gn(2,0)) - AAx(1,1)=-(q*gs(1,1)) - AAy(1,1)=q*gn(1,1) - AAz(1,1)=2*q*gs(2,0) - AAy(0,2)=-(q*gs(1,1)) - AAz(0,2)=q*gn(2,0) - AAx(3,0)=q*gn(2,1)/2 - AAz(3,0)=3*q*gn(1,2)/8 - q*gn(3,0) - AAx(2,1)=-(q*gs(2,1)) - AAy(2,1)=q*gn(2,1)/2 - AAz(2,1)=-3*q*gs(1,2)/8 + 3*q*gs(3,0) - AAx(1,2)=-(q*gn(2,1))/2 - AAy(1,2)=-(q*gs(2,1)) - AAz(1,2)=3*q*gn(1,2)/8 + 3*q*gn(3,0) - AAy(0,3)=-(q*gn(2,1))/2 - AAz(0,3)=-3*q*gs(1,2)/8 - q*gs(3,0) - AAx(4,0)=-(q*gn(1,3))/8 + q*gn(3,1)/3 - AAz(4,0)=q*gn(2,2)/6 - q*gn(4,0) - AAx(3,1)=q*gs(1,3)/8 - q*gs(3,1) - AAy(3,1)=-(q*gn(1,3))/8 + q*gn(3,1)/3 - AAz(3,1)=-(q*gs(2,2))/3 + 4*q*gs(4,0) - AAx(2,2)=-(q*gn(1,3))/8 - q*gn(3,1) - AAy(2,2)=q*gs(1,3)/8 - q*gs(3,1) - AAz(2,2)=6*q*gn(4,0) - AAx(1,3)=q*gs(1,3)/8 + q*gs(3,1)/3 - AAy(1,3)=-(q*gn(1,3))/8 - q*gn(3,1) - AAz(1,3)=-(q*gs(2,2))/3 - 4*q*gs(4,0) - AAy(0,4)=q*gs(1,3)/8 + q*gs(3,1)/3 - AAz(0,4)=-(q*gn(2,2))/6 - q*gn(4,0) - AAx(5,0)=-(q*gn(2,3))/24 + q*gn(4,1)/4 - AAz(5,0)=-5*q*gn(1,4)/192 + 5*q*gn(3,2)/48 - q*gn(5,0) - AAx(4,1)=q*gs(2,3)/12 - q*gs(4,1) - AAy(4,1)=-(q*gn(2,3))/24 + q*gn(4,1)/4 - AAz(4,1)=5*q*gs(1,4)/192 - 5*q*gs(3,2)/16 + 5*q*gs(5,0) - AAx(3,2)=-3*q*gn(4,1)/2 - AAy(3,2)=q*gs(2,3)/12 - q*gs(4,1) - AAz(3,2)=-5*q*gn(1,4)/96 - 5*q*gn(3,2)/24 + 10*q*gn(5,0) - AAx(2,3)=q*gs(2,3)/12 + q*gs(4,1) - AAy(2,3)=-3*q*gn(4,1)/2 - AAz(2,3)=5*q*gs(1,4)/96 - 5*q*gs(3,2)/24 - 10*q*gs(5,0) - AAx(1,4)=q*gn(2,3)/24 + q*gn(4,1)/4 - AAy(1,4)=q*gs(2,3)/12 + q*gs(4,1) - AAz(1,4)=-5*q*gn(1,4)/192 - 5*q*gn(3,2)/16 - 5*q*gn(5,0) - AAy(0,5)=q*gn(2,3)/24 + q*gn(4,1)/4 - AAz(0,5)=5*q*gs(1,4)/192 + 5*q*gs(3,2)/48 + q*gs(5,0) - AAx(6,0)=q*gn(1,5)/192 - q*gn(3,3)/48 + q*gn(5,1)/5 - AAz(6,0)=-(q*gn(2,4))/128 + 3*q*gn(4,2)/40 - q*gn(6,0) - AAx(5,1)=-(q*gs(1,5))/192 + q*gs(3,3)/16 - q*gs(5,1) - AAy(5,1)=q*gn(1,5)/192 - q*gn(3,3)/48 + q*gn(5,1)/5 - AAz(5,1)=q*gs(2,4)/64 - 3*q*gs(4,2)/10 + 6*q*gs(6,0) - AAx(4,2)=q*gn(1,5)/96 + q*gn(3,3)/24 - 2*q*gn(5,1) - AAy(4,2)=-(q*gs(1,5))/192 + q*gs(3,3)/16 - q*gs(5,1) - AAz(4,2)=-(q*gn(2,4))/128 - 3*q*gn(4,2)/8 + 15*q*gn(6,0) - AAx(3,3)=-(q*gs(1,5))/96 + q*gs(3,3)/24 + 2*q*gs(5,1) - AAy(3,3)=q*gn(1,5)/96 + q*gn(3,3)/24 - 2*q*gn(5,1) - AAz(3,3)=q*gs(2,4)/32 - 20*q*gs(6,0) - AAx(2,4)=q*gn(1,5)/192 + q*gn(3,3)/16 + q*gn(5,1) - AAy(2,4)=-(q*gs(1,5))/96 + q*gs(3,3)/24 + 2*q*gs(5,1) - AAz(2,4)=q*gn(2,4)/128 - 3*q*gn(4,2)/8 - 15*q*gn(6,0) - AAx(1,5)=-(q*gs(1,5))/192 - q*gs(3,3)/48 - q*gs(5,1)/5 - AAy(1,5)=q*gn(1,5)/192 + q*gn(3,3)/16 + q*gn(5,1) - AAz(1,5)=q*gs(2,4)/64 + 3*q*gs(4,2)/10 + 6*q*gs(6,0) - AAy(0,6)=-(q*gs(1,5))/192 - q*gs(3,3)/48 - q*gs(5,1)/5 - AAz(0,6)=q*gn(2,4)/128 + 3*q*gn(4,2)/40 + q*gn(6,0) - AAx(7,0)=q*gn(2,5)/768 - q*gn(4,3)/80 + q*gn(6,1)/6 - AAz(7,0)=7*q*gn(1,6)/9216 - 7*q*gn(3,4)/1920 + - - 7*q*gn(5,2)/120 - AAx(6,1)=-(q*gs(2,5))/384 + q*gs(4,3)/20 - q*gs(6,1) - AAy(6,1)=q*gn(2,5)/768 - q*gn(4,3)/80 + q*gn(6,1)/6 - AAz(6,1)=-7*q*gs(1,6)/9216 + 7*q*gs(3,4)/640 - - - 7*q*gs(5,2)/24 - AAx(5,2)=q*gn(2,5)/768 + q*gn(4,3)/16 - 5*q*gn(6,1)/2 - AAy(5,2)=-(q*gs(2,5))/384 + q*gs(4,3)/20 - q*gs(6,1) - AAz(5,2)=7*q*gn(1,6)/3072 + 7*q*gn(3,4)/1920 - - - 21*q*gn(5,2)/40 - AAx(4,3)=-(q*gs(2,5))/192 + 10*q*gs(6,1)/3 - AAy(4,3)=q*gn(2,5)/768 + q*gn(4,3)/16 - 5*q*gn(6,1)/2 - AAz(4,3)=-7*q*gs(1,6)/3072 + 7*q*gs(3,4)/384 + - - 7*q*gs(5,2)/24 - AAx(3,4)=-(q*gn(2,5))/768 + q*gn(4,3)/16 + 5*q*gn(6,1)/2 - AAy(3,4)=-(q*gs(2,5))/192 + 10*q*gs(6,1)/3 - AAz(3,4)=7*q*gn(1,6)/3072 + 7*q*gn(3,4)/384 - - - 7*q*gn(5,2)/24 - AAx(2,5)=-(q*gs(2,5))/384 - q*gs(4,3)/20 - q*gs(6,1) - AAy(2,5)=-(q*gn(2,5))/768 + q*gn(4,3)/16 + 5*q*gn(6,1)/2 - AAz(2,5)=-7*q*gs(1,6)/3072 + 7*q*gs(3,4)/1920 + - - 21*q*gs(5,2)/40 - AAx(1,6)=-(q*gn(2,5))/768 - q*gn(4,3)/80 - q*gn(6,1)/6 - AAy(1,6)=-(q*gs(2,5))/384 - q*gs(4,3)/20 - q*gs(6,1) - AAz(1,6)=7*q*gn(1,6)/9216 + 7*q*gn(3,4)/640 + - - 7*q*gn(5,2)/24 - AAy(0,7)=-(q*gn(2,5))/768 - q*gn(4,3)/80 - q*gn(6,1)/6 - AAz(0,7)=-7*q*gs(1,6)/9216 - 7*q*gs(3,4)/1920 - - - 7*q*gs(5,2)/120 - AAx(8,0)=-(q*gn(1,7))/9216 + q*gn(3,5)/1920 - q*gn(5,3)/120 - AAz(8,0)=q*gn(2,6)/5760 - q*gn(4,4)/480 + q*gn(6,2)/21 - AAx(7,1)=q*gs(1,7)/9216 - q*gs(3,5)/640 + q*gs(5,3)/24 - AAy(7,1)=-(q*gn(1,7))/9216 + q*gn(3,5)/1920 - q*gn(5,3)/120 - AAz(7,1)=-(q*gs(2,6))/2880 + q*gs(4,4)/120 - 2*q*gs(6,2)/7 - AAx(6,2)=-(q*gn(1,7))/3072 - q*gn(3,5)/1920 + - - 3*q*gn(5,3)/40 - AAy(6,2)=q*gs(1,7)/9216 - q*gs(3,5)/640 + q*gs(5,3)/24 - AAz(6,2)=q*gn(2,6)/2880 + q*gn(4,4)/120 - 2*q*gn(6,2)/3 - AAx(5,3)=q*gs(1,7)/3072 - q*gs(3,5)/384 - q*gs(5,3)/24 - AAy(5,3)=-(q*gn(1,7))/3072 - q*gn(3,5)/1920 + - - 3*q*gn(5,3)/40 - AAz(5,3)=-(q*gs(2,6))/960 + q*gs(4,4)/120 + 2*q*gs(6,2)/3 - AAx(4,4)=-(q*gn(1,7))/3072 - q*gn(3,5)/384 + q*gn(5,3)/24 - AAy(4,4)=q*gs(1,7)/3072 - q*gs(3,5)/384 - q*gs(5,3)/24 - AAz(4,4)=q*gn(4,4)/48 - AAx(3,5)=q*gs(1,7)/3072 - q*gs(3,5)/1920 - 3*q*gs(5,3)/40 - AAy(3,5)=-(q*gn(1,7))/3072 - q*gn(3,5)/384 + q*gn(5,3)/24 - AAz(3,5)=-(q*gs(2,6))/960 - q*gs(4,4)/120 + 2*q*gs(6,2)/3 - AAx(2,6)=-(q*gn(1,7))/9216 - q*gn(3,5)/640 - q*gn(5,3)/24 - AAy(2,6)=q*gs(1,7)/3072 - q*gs(3,5)/1920 - 3*q*gs(5,3)/40 - AAz(2,6)=-(q*gn(2,6))/2880 + q*gn(4,4)/120 + 2*q*gn(6,2)/3 - AAx(1,7)=q*gs(1,7)/9216 + q*gs(3,5)/1920 + q*gs(5,3)/120 - AAy(1,7)=-(q*gn(1,7))/9216 - q*gn(3,5)/640 - q*gn(5,3)/24 - AAz(1,7)=-(q*gs(2,6))/2880 - q*gs(4,4)/120 - 2*q*gs(6,2)/7 - AAy(0,8)=q*gs(1,7)/9216 + q*gs(3,5)/1920 + q*gs(5,3)/120 - AAz(0,8)=-(q*gn(2,6))/5760 - q*gn(4,4)/480 - q*gn(6,2)/21 - AAx(9,0)=-(q*gn(2,7))/46080 + q*gn(4,5)/3840 - - - q*gn(6,3)/168 - AAz(9,0)=-(q*gn(1,8))/81920 + q*gn(3,6)/15360 - - - 3*q*gn(5,4)/2240 - AAx(8,1)=q*gs(2,7)/23040 - q*gs(4,5)/960 + q*gs(6,3)/28 - AAy(8,1)=-(q*gn(2,7))/46080 + q*gn(4,5)/3840 - - - q*gn(6,3)/168 - AAz(8,1)=q*gs(1,8)/81920 - q*gs(3,6)/5120 + 3*q*gs(5,4)/448 - AAx(7,2)=-(q*gn(2,7))/23040 - q*gn(4,5)/960 + q*gn(6,3)/12 - AAy(7,2)=q*gs(2,7)/23040 - q*gs(4,5)/960 + q*gs(6,3)/28 - AAz(7,2)=-(q*gn(1,8))/20480 + 3*q*gn(5,4)/280 - AAx(6,3)=q*gs(2,7)/7680 - q*gs(4,5)/960 - q*gs(6,3)/12 - AAy(6,3)=-(q*gn(2,7))/23040 - q*gn(4,5)/960 + q*gn(6,3)/12 - AAz(6,3)=q*gs(1,8)/20480 - q*gs(3,6)/1920 - AAx(5,4)=-(q*gn(4,5))/384 - AAy(5,4)=q*gs(2,7)/7680 - q*gs(4,5)/960 - q*gs(6,3)/12 - AAz(5,4)=-3*q*gn(1,8)/40960 - q*gn(3,6)/2560 + - - 3*q*gn(5,4)/160 - AAx(4,5)=q*gs(2,7)/7680 + q*gs(4,5)/960 - q*gs(6,3)/12 - AAy(4,5)=-(q*gn(4,5))/384 - AAz(4,5)=3*q*gs(1,8)/40960 - q*gs(3,6)/2560 - - - 3*q*gs(5,4)/160 - AAx(3,6)=q*gn(2,7)/23040 - q*gn(4,5)/960 - q*gn(6,3)/12 - AAy(3,6)=q*gs(2,7)/7680 + q*gs(4,5)/960 - q*gs(6,3)/12 - AAz(3,6)=-(q*gn(1,8))/20480 - q*gn(3,6)/1920 - AAx(2,7)=q*gs(2,7)/23040 + q*gs(4,5)/960 + q*gs(6,3)/28 - AAy(2,7)=q*gn(2,7)/23040 - q*gn(4,5)/960 - q*gn(6,3)/12 - AAz(2,7)=q*gs(1,8)/20480 - 3*q*gs(5,4)/280 - AAx(1,8)=q*gn(2,7)/46080 + q*gn(4,5)/3840 + q*gn(6,3)/168 - AAy(1,8)=q*gs(2,7)/23040 + q*gs(4,5)/960 + q*gs(6,3)/28 - AAz(1,8)=-(q*gn(1,8))/81920 - q*gn(3,6)/5120 - - - 3*q*gn(5,4)/448 - AAy(0,9)=q*gn(2,7)/46080 + q*gn(4,5)/3840 + q*gn(6,3)/168 - AAz(0,9)=q*gs(1,8)/81920 + q*gs(3,6)/15360 + - - 3*q*gs(5,4)/2240 - AAx(10,0)=q*gn(1,9)/737280 - q*gn(3,7)/138240 + - - q*gn(5,5)/6720 - AAz(10,0)=-(q*gn(2,8))/442368 + q*gn(4,6)/32256 - - - 5*q*gn(6,4)/5376 - AAx(9,1)=-(q*gs(1,9))/737280 + q*gs(3,7)/46080 - - - q*gs(5,5)/1344 - AAy(9,1)=q*gn(1,9)/737280 - q*gn(3,7)/138240 + - - q*gn(5,5)/6720 - AAz(9,1)=q*gs(2,8)/221184 - q*gs(4,6)/8064 + - - 5*q*gs(6,4)/896 - AAx(8,2)=q*gn(1,9)/184320 - q*gn(5,5)/840 - AAy(8,2)=-(q*gs(1,9))/737280 + q*gs(3,7)/46080 - - - q*gs(5,5)/1344 - AAz(8,2)=-(q*gn(2,8))/147456 - q*gn(4,6)/10752 + - - 65*q*gn(6,4)/5376 - AAx(7,3)=-(q*gs(1,9))/184320 + q*gs(3,7)/17280 - AAy(7,3)=q*gn(1,9)/184320 - q*gn(5,5)/840 - AAz(7,3)=q*gs(2,8)/55296 - q*gs(4,6)/4032 - 5*q*gs(6,4)/672 - AAx(6,4)=q*gn(1,9)/122880 + q*gn(3,7)/23040 - q*gn(5,5)/480 - AAy(6,4)=-(q*gs(1,9))/184320 + q*gs(3,7)/17280 - AAz(6,4)=-(q*gn(2,8))/221184 - q*gn(4,6)/2304 + - - 5*q*gn(6,4)/384 - AAx(5,5)=-(q*gs(1,9))/122880 + q*gs(3,7)/23040 + - - q*gs(5,5)/480 - AAy(5,5)=q*gn(1,9)/122880 + q*gn(3,7)/23040 - q*gn(5,5)/480 - AAz(5,5)=q*gs(2,8)/36864 - 5*q*gs(6,4)/192 - AAx(4,6)=q*gn(1,9)/184320 + q*gn(3,7)/17280 - AAy(4,6)=-(q*gs(1,9))/122880 + q*gs(3,7)/23040 + - - q*gs(5,5)/480 - AAz(4,6)=q*gn(2,8)/221184 - q*gn(4,6)/2304 - - - 5*q*gn(6,4)/384 - AAx(3,7)=-(q*gs(1,9))/184320 + q*gs(5,5)/840 - AAy(3,7)=q*gn(1,9)/184320 + q*gn(3,7)/17280 - AAz(3,7)=q*gs(2,8)/55296 + q*gs(4,6)/4032 - 5*q*gs(6,4)/672 - AAx(2,8)=q*gn(1,9)/737280 + q*gn(3,7)/46080 + - - q*gn(5,5)/1344 - AAy(2,8)=-(q*gs(1,9))/184320 + q*gs(5,5)/840 - AAz(2,8)=q*gn(2,8)/147456 - q*gn(4,6)/10752 - - - 65*q*gn(6,4)/5376 - AAx(1,9)=-(q*gs(1,9))/737280 - q*gs(3,7)/138240 - - - q*gs(5,5)/6720 - AAy(1,9)=q*gn(1,9)/737280 + q*gn(3,7)/46080 + - - q*gn(5,5)/1344 - AAz(1,9)=q*gs(2,8)/221184 + q*gs(4,6)/8064 + - - 5*q*gs(6,4)/896 - AAy(0,10)=-(q*gs(1,9))/737280 - q*gs(3,7)/138240 - - - q*gs(5,5)/6720 - AAz(0,10)=q*gn(2,8)/442368 + q*gn(4,6)/32256 + - - 5*q*gn(6,4)/5376 -c -cryneneriwalstrom 16 July, 2004 changed "4" to maxorder -cryneneriwalstrom and set maxorder to 6 - maxorder=6 -c - call exp2f1(x0,y0,AAx,a,10) - ind1 = 0 - do 1 i = 0, maxorder - ind2 = ind1 - do 2 j = 0, maxorder-i - Ax(ind2) = a(i,j) - if (j .lt. maxorder-i) then - ind2 = prodex(3,ind2) - endif - 2 continue - if ( i .lt. maxorder ) ind1 = prodex(1,ind1) - 1 continue -c - call exp2f1(x0,y0,AAy,a,10) - ind1 = 0 - do 10 i = 0, maxorder - ind2 = ind1 - do 20 j = 0, maxorder-i - Ay(ind2) = a(i,j) - if (j .lt. maxorder-i) then - ind2 = prodex(3,ind2) - endif - 20 continue - if ( i .lt. maxorder ) ind1 = prodex(1,ind1) - 10 continue -c - call exp2f1(x0,y0,AAz,a,10) - ind1 = 0 - do 100 i = 0, maxorder - ind2 = ind1 - do 200 j = 0, maxorder-i - Az(ind2) = a(i,j) - if (j .lt. maxorder-i) then - ind2 = prodex(3,ind2) - endif - 200 continue - if ( i .lt. maxorder ) ind1 = prodex(1,ind1) - 100 continue -c - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c -c Reexpands a Polynomial in x and y where the coefficient -c of x^i y^j is a(i,j), and a() is dimensioned as a(0:md,0:md), -c around the point x0, y0. -c The coefficients of the reexpanded polynomial are in the array -c b(0:md,0:md). -c -c F. Neri 3/29/91. -c - subroutine exp2f1(x0,y0,a,b,md) - implicit double precision (a-h,o-z) - parameter (maxd = 100) - dimension a(0:md,0:md), b(0:md,0:md) -c - dimension c(0:maxd,0:maxd), d(0:maxd), e(0:maxd) -c - do 1 i = 0, md - call expoly(a(0,i), md, x0, c(0,i), md) - 1 continue -c - do 2 i = 0, md - do 20 j = 0, md - d(j) = c(i,j) - 20 continue - call expoly(d, md, y0 ,e, md) - do 200 j = 0, md - b(i,j) = e(j) - 200 continue - 2 continue - return - end -c -ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - SUBROUTINE EXPOLY(C,NC,X,PD,ND) -c -c Given the NC+1 coefficients of a polynomial of degree NC as an array C -c with C(0) being the constant term, and a given a value X, and given a -c value ND>0, this routine returns the polynomial evaluated at X as PD(0) -c and ND derivatives times ND!, as PD(1) . . . PD(ND). -c From Numerical Recipes, pag. 138 (1986 FORTRAN/Pascal version). -c - implicit double precision (a-h,o-z) - DIMENSION C(0:NC),PD(0:ND) - if ( x .ne. 0.d0 ) then - PD(0)=C(NC) - DO 11 J=1,ND - PD(J)=0.d0 - 11 CONTINUE - DO 13 I=NC-1,0,-1 - NND=MIN(ND,NC-I) - DO 12 J=NND,1,-1 - PD(J)=PD(J)*X+PD(J-1) - 12 CONTINUE - PD(0)=PD(0)*X+C(I) - 13 CONTINUE - else - do 14 i = 0, nd - pd(i) = c(i) - 14 continue - endif - RETURN - END -c -c************************************************** -c - subroutine gauleg(x1,x2,x,w,n) - implicit double precision(a-h,o-z) - dimension x(n),w(n) -c Routine from Numerical Recipes to calculate Gaussian weights and node -c for Gaussian quadrature on the interval [x1,x2]. -c x1=lower end of integration interval -c x2=upper " " " " -c x=array of gauss nodes -c w=array of gauss weights -c n=gaussian order - parameter (eps=3.d-14) - parameter( half=0.5d0) - pi=2.d0*dasin(1.d0) - m=(n+1)/2 - xm=half*(x2+x1) - xl=half*(x2-x1) - do 12 i=1,m - z=dcos(pi*(i-0.25d0)/(n+half)) - 1 continue - p1=1.d0 - p2=0.d0 - do 11 j=1,n - p3=p2 - p2=p1 - p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j - 11 continue - pp=n*(z*p1-p2)/(z*z-1.d0) - z1=z - z=z1-p1/pp - if(dabs(z-z1).gt.eps) go to 1 - x(i)=xm-xl*z - x(n+1-i)=xm+xl*z - w(i)=2.d0*xl/((1.d0-z*z)*pp*pp) - w(n+1-i)=w(i) - 12 continue - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/comm.f b/OpticsJan2020/MLI_light_optics/Src/comm.f deleted file mode 100755 index fde824d..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/comm.f +++ /dev/null @@ -1,932 +0,0 @@ -************************************************************************ -* header: COMMANDS (simple) -* These modules deal with simple commands that affect maps and phase -* space data. Ray trace related commands are found in TRAC, and input -* output related commands are found in INPU. -* -* Rob Ryne 7/28/2002 -* This file was generated by taking comm.f from the 5th order version -* that Tom Mottershead and I were using and including the following -* from the ML30dev version: -* cmom, cmom5, dpol, tpol -* also, wnda and wnd were added to replace swnd and dwnd -* Note that, in cmom5 (which is not used), monoms5 has been replaced by monom -* Note also that evalm and evalm5 (not used) have been added to liea.f -************************************************************************ -c - subroutine cmom(amom,am) -c this subroutine computes the moments of the particle distribution -c stored in zblock. The second moments are put in the matrix am, and -c all the moments are put in the array amom. -c Written by Alex Dragt, 1 July 1991. -c - use rays - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension am(6,6) - dimension amom(monoms) -c -c working arrays - dimension vmon(monoms) - dimension z(6) -c -c clear amom - do 5 i=1,monoms - 5 amom(i)=0.d0 -c -c computational loop - do 10 k=1,nraysp -c get a ray - do 20 i=1,6 - 20 z(i)=zblock(i,k) -c compute moments for the ray - call evalm(z,vmon) -c add results to moment sum - do 30 i=1,monoms - 30 amom(i)=amom(i)+vmon(i) - 10 continue -c -c normalize by the number of particles - fact=1.d0/float(nrays) - do 40 i=1,monoms - 40 amom(i)=fact*amom(i) -c -c also put second moments in the matrix part am -c - am(1,1)=amom(7) - am(1,2)=amom(8) - am(1,3)=amom(9) - am(1,4)=amom(10) - am(1,5)=amom(11) - am(1,6)=amom(12) - am(2,1)=amom(8) - am(2,2)=amom(13) - am(2,3)=amom(14) - am(2,4)=amom(15) - am(2,5)=amom(16) - am(2,6)=amom(17) - am(3,1)=amom(9) - am(3,2)=amom(14) - am(3,3)=amom(18) - am(3,4)=amom(19) - am(3,5)=amom(20) - am(3,6)=amom(21) - am(4,1)=amom(10) - am(4,2)=amom(15) - am(4,3)=amom(19) - am(4,4)=amom(22) - am(4,5)=amom(23) - am(4,6)=amom(24) - am(5,1)=amom(11) - am(5,2)=amom(16) - am(5,3)=amom(20) - am(5,4)=amom(23) - am(5,5)=amom(25) - am(5,6)=amom(26) - am(6,1)=amom(12) - am(6,2)=amom(17) - am(6,3)=amom(21) - am(6,4)=amom(24) - am(6,5)=amom(26) - am(6,6)=amom(27) -c -c write(6,*)'here I am in cmom; amom(1-27)=' -c do i=1,27 -c write(6,*)i,amom(i) -c enddo -c - return - end -c -****************************************************************** -c - subroutine dpol(p,fa,fm) -c This is a subroutine for setting up a quadratic polynomial -c described in terms of dispersion parameters. -c Written by Alex Dragt, 29 March 1991 -c - use lieaparam, only : monoms - include 'impli.inc' -c - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c -c set map to the identity - call ident(fa,fm) -c -c set up polynomial - fa(12)=p(2) - fa(17)=-p(1) - fa(21)=p(4) - fa(24)=-p(3) - fa(27)=-p(5)/2.d0 -c - return - end -c -********************************************************************* -c - subroutine eapt(p) -c this is a subroutine for an elliptic aperture -c Written by Alex Dragt, Spring 1987. - use rays - include 'impli.inc' - dimension p(6) -c - smas=p(2) - raxs=p(3) - iturn=iturn+1 - do 100 k=1,nraysp - if (istat(k).ne.0) goto 100 - x=zblock(1,k) - y=zblock(3,k) - x2=x*x - y2=y*y - test=x2+raxs*y2 -c examine particle location - if (test.ge.smas) goto 10 -c particle within aperture - goto 100 - 10 continue -c particle outside aperture - istat(k)=iturn - nlost=nlost+1 - ihist(1,nlost)=iturn - ihist(2,nlost)=k - 100 continue - return - end -c -********************************************************************* -c - subroutine ftm(p,fa,fm) -c this subroutine filters transfer maps -c Written by Alex Dragt, Spring 1987. - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - dimension p(6),fa(monoms),fm(6,6) - dimension ta(monoms),tm(6,6) -c - ifile=nint(p(1)) - nopt=nint(p(2)) - nskp=nint(p(3)) - kynd=nint(p(4)) - mpitmp=mpi - mpi=ifile - call mapin(nopt,nskp,ta,tm) - mpi=mpitmp -c determine procedure - if(kynd.eq.0) goto 5 - if(kynd.eq.1) goto 15 -c procedure for normal filter - 5 continue - do 10 i=1,monoms - if(ta(i).eq.0.) fa(i)=0. - 10 continue - return -c procedure for a reversed filter - 15 continue - do 20 i=1,monoms - if(ta(i).gt.0.) fa(i)=0. - 20 continue - return - end -c -*********************************************************************** -c - subroutine ident(h,xmh) -c Written by D. Douglas, ca 1982 - use lieaparam, only : monoms - include 'impli.inc' - dimension h(monoms),xmh(6,6) - do 10 i=1,6 - do 10 j=1,6 - 10 xmh(i,j)=0. - do 15 i=1,6 - 15 xmh(i,i)=1. - do 20 i=1,monoms - 20 h(i)=0. -c - return - end -c -*********************************************************************** -c - subroutine inv(ha,hm) -c Returns the inverse of the map represented by ha,hm -c based on the reverse to Marylie order factorization -c routine cfacrm. Written 2/2/96 AJD -c - include 'impli.inc' -c -c----Variables---- -c - dimension ha(*),hm(6,6) -c -c----Routine---- -c -c Invert matrix part of map. - call minv(hm) -c Reverse sign of polynomials: - do 100 ind=1,923 - 100 ha(ind)=-ha(ind) -c Now reverse order: - call cfacrm(ha,hm) -c - return - end -c -********************************************************************* -c - subroutine mask6(wipe,h,mh) -c -c Sets higher order monomial coefficients to zero as specified by wipe -c Written by Liam Healy, Spring 1985 -c -c implicit none -c Variables -c wipe = array of flags: if nth element is less than 0.5, nth order is -c set to the identity map - double precision wipe(*) -c h, mh = polynomial and matrix (input and output) - double precision h(*),mh(6,6) -c ord = order of polynomial - integer ord -c - include 'maxcat.inc' - include 'lims.inc' -c -c----Routine---- - if (wipe(1).le.0.5) then - do 100 i=1,6 - do 100 j=1,6 - 100 mh(i,j)=0. - do 120 i=1,6 - 120 mh(i,i)=1. - endif - do 200 ord=2,ordcat - if (wipe(ord).le.0.5) then - do 140 i=bottom(ord),top(ord) - 140 h(i)=0. - endif - 200 continue - return - end -c -********************************************************************* -c - subroutine mask(akeep,ha,hm) -c -c Keeps or removes portions of the map as specified by akeep. -c Written by A. Dragt 2/3/96 to work thru f6. -c - include 'impli.inc' - include 'maxcat.inc' - include 'lims.inc' -c -cryne 12/31/2004: - integer keep -c -c Variables -c -c akeep = array of flags: - dimension akeep(*) -c ha, hm = polynomial and matrix (input and output) - dimension ha(*),hm(6,6) -c keep = integer version of akeep - dimension keep(6) -c -c----Routine---- -c -c set up keep - do 10 i=1,6 - 10 keep(i) = nint(akeep(i)) -c -c mask the map order by order -c -c f1 contents: - if (keep(1) .eq. 0) then - do 100 i=1,6 - 100 ha(i) = 0.d0 - endif -c f2 and matrix contents: - if (keep(2) .eq. 0) then - do 200 i=7,27 - 200 ha(i) = 0.d0 - call mident(hm) - endif -c f3 contents: - if (keep(3) .eq. 0) then - do 300 i=28,83 - 300 ha(i) = 0.d0 - endif -c f4 contents: - if (keep(4) .eq. 0) then - do 400 i=84,209 - 400 ha(i) = 0.d0 - endif -c f5 contents: - if (keep(5) .eq. 0) then - do 500 i=210,461 - 500 ha(i) = 0.d0 - endif -c f6 contents: - if (keep(6) .eq. 0) then - do 600 i=462,923 - 600 ha(i) = 0.d0 - endif -c - return - end -c -*********************************************************************** -c - subroutine mtran(mh) -c Takes the transpose of the matrix mh. -c Written by Liam Healy, April 16, 1985. -c implicit none - double precision mh(6,6),hold - integer i,j -c -c----Routine---- - do 100 i=1,6 - do 100 j=1,i-1 - hold=mh(j,i) - mh(j,i)=mh(i,j) - mh(i,j)=hold - 100 continue - return - end -c -*********************************************************************** -c - subroutine rapt(p) -c this is a subroutine for a rectangular aperture -c Written by Alex Dragt, Spring 1987. - use beamdata - use rays - include 'impli.inc' - dimension p(*) -c -c if(idproc.eq.0)then -c write(6,*)'inside rectangular aperture routine' -c endif - xmin=p(1) - xmax=p(2) - ymin=p(3) - ymax=p(4) - iturn=iturn+1 - do 100 k=1,nraysp - if (istat(k).ne.0) goto 100 - x=sl*zblock(1,k) - y=sl*zblock(3,k) -c examine particle location - if (x.le.xmin) goto 10 - if (x.ge.xmax) goto 10 - if (y.le.ymin) goto 10 - if (y.ge.ymax) goto 10 -c particle within aperture - goto 100 - 10 continue -c particle outside aperture - write(6,*)'particle #',k,' from proc ',idproc,' is lost' - istat(k)=iturn - nlost=nlost+1 - ihist(1,nlost)=iturn - ihist(2,nlost)=k - 100 continue - return - end -c -*********************************************************************** -c - subroutine rev(h,mh) -c This is a subroutine for reversing a map. -c Written by Alex Dragt on Friday, 13 Sept 1985. - use lieaparam, only : monoms -c implicit none - include 'expon.inc' -c - double precision h(*),mh(6,6) - double precision temp(6,6) - double precision r(6,6) -c Define the reversing matrix r by a set of data statements: - data (r(1,j),j=1,6)/ 1.d0, 0.d0, 0.d0, 0.d0, 0.d0, 0.d0/ - data (r(2,j),j=1,6)/ 0.d0,-1.d0, 0.d0, 0.d0, 0.d0, 0.d0/ - data (r(3,j),j=1,6)/ 0.d0, 0.d0, 1.d0, 0.d0, 0.d0, 0.d0/ - data (r(4,j),j=1,6)/ 0.d0, 0.d0, 0.d0,-1.d0, 0.d0, 0.d0/ - data (r(5,j),j=1,6)/ 0.d0, 0.d0, 0.d0, 0.d0,-1.d0, 0.d0/ - data (r(6,j),j=1,6)/ 0.d0, 0.d0, 0.d0, 0.d0, 0.d0, 1.d0/ - save r -c----Routine---- -c Compute inverse map: - call inv(h,mh) -c Reverse matrix portion of map: - call mmult (r,mh,temp) - call mmult (temp,r,mh) -c Reverse polynomial portion of map: -c For now, work only with n in the interval [28,209]. -c Change range of n later when f1's are implemented. - do 10 n=28,209 - n2 = expon(2,n) - n4 = expon(4,n) - n5 = expon(5,n) - m = n2+n4+n5 - mm2 = mod(m,2) - if (mm2.eq.0) h(n)=-h(n) - 10 continue - return - end -c -*********************************************************************** -c - subroutine revf(iord,ha,hm) -c Changes the order of factorization. -c If iord=0, it is assumed that the map specified by ha,hm is in the -c standard MARYLIE order exp(:f2:)exp(:f3:)exp(:f4).... This -c routine will then return g3,g4... corresponding to the factorization -c ...exp(:g4:)exp(:g3:)exp(:f2:). -c If iord=1, it is assumed that the map specified by ha,hm is in -c reversed order. This routine then returns the standard -c MARYLIE order. Written by Alex Dragt 1/31/96 -c - include 'impli.inc' -c -c----Variables---- -c - dimension ha(*),hm(6,6) -c -c----Routine---- -c - if(iord.gt.0) then -c -c----Procedure for going from reversed order to MARYLIE order: -c - call cfacrm(ha,hm) -c - else -c -c----Procedure for going from MARYLIE order to reversed order: -c - call cfacmr(ha,hm) -c - endif -c - return - end -c -*********************************************************************** -c - subroutine cfacmr(ha,hm) -c Changes the order of factorization from Marylie to reversed order -c using the inversion routine. -c Written by Alex Dragt 1/31/96 -c -c----Variables---- -c - include 'impli.inc' -c - dimension ha(*),hm(6,6) - dimension ha1(923),hm1(6,6) - dimension ha2(923),hm2(6,6) -c -c----Routine---- -c -c----Procedure for going from MARYLIE order to reversed order: -c -c Clear ha1,hm1 - call clear(ha1,hm1) -c Copy hm into hm1 - call matmat(hm,hm1) -c Invert the map ha,hm - call inv(ha,hm) -c Concatenate with the map ha1,hm1 - call concat(ha1,hm1,ha,hm,ha2,hm2) -c Change signs of monomials - do 120 ind=1,923 - 120 ha(ind)=-ha2(ind) -c Replace current hm with its original version, hm1 - call matmat(hm1,hm) -c - return - end -c -*********************************************************************** -c - subroutine cfacrm(ha,hm) -c Changes the order of factorization from reversed to -c Marylie order using the concatenator. -c Written by Alex Dragt 1/31/96 -c -c----Variables---- -c - include 'impli.inc' -c - dimension ha(923),hm(6,6) - dimension ha1(923),hm1(6,6) - dimension ha2(923),hm2(6,6) - dimension ha3(923),hm3(6,6) - dimension akeep(6) -c -c----Routine---- -c -c----Procedure for going from reversed order to MARYLIE order: -c--- This should work thru 6th order (AJD) -c -c get only matrix part - call mapmap(ha,hm,ha1,hm1) - akeep(1)=0. - akeep(2)=1.d0 - akeep(3)=0. - akeep(4)=0. - akeep(5)=0. - akeep(6)=0. - call mask(akeep,ha1,hm1) -c get only g3 part - call mapmap(ha,hm,ha2,hm2) - akeep(1)=0. - akeep(2)=0. - akeep(3)=1.d0 - akeep(4)=0. - akeep(5)=0. - akeep(6)=0. - call mask(akeep,ha2,hm2) -c concatenate exp(:g3:)exp(:g2:) - call concat(ha2,hm2,ha1,hm1,ha3,hm3) -c store result in ha1,hm1 - call mapmap(ha3,hm3,ha1,hm1) -c get only g4 part - call mapmap(ha,hm,ha2,hm2) - akeep(1)=0. - akeep(2)=0. - akeep(3)=0. - akeep(4)=1.d0 - akeep(5)=0. - akeep(6)=0. - call mask(akeep,ha2,hm2) -c concatenate exp(:g4:)exp(:g3:)exp(:g2:) - call concat(ha2,hm2,ha1,hm1,ha3,hm3) -c store result in ha1,hm1 - call mapmap(ha3,hm3,ha1,hm1) -c write(6,*) 'result after g4' -c call pcmap(1,1,0,0,ha1,hm1) -c get only g5 part - call mapmap(ha,hm,ha2,hm2) - akeep(1)=0. - akeep(2)=0. - akeep(3)=0. - akeep(4)=0. - akeep(5)=1.d0 - akeep(6)=0. - call mask(akeep,ha2,hm2) -c write(6,*) 'first factor' -c call pcmap(1,1,0,0,ha2,hm2) -c write(6,*) 'second factor' -c call pcmap(1,1,0,0,ha1,hm1) -c concatenate exp(:g5:)exp(:g4:)exp(:g3:)exp(:g2:) - call concat(ha2,hm2,ha1,hm1,ha3,hm3) -c write(6,*) 'result after concat' -c call pcmap(1,1,0,0,ha3,hm3) -c store result in ha1,hm1 - call mapmap(ha3,hm3,ha1,hm1) -c write(6,*) 'result after g5 mapmap' -c call pcmap(1,1,0,0,ha1,hm1) -c get only g6 part - call mapmap(ha,hm,ha2,hm2) - akeep(1)=0. - akeep(2)=0. - akeep(3)=0. - akeep(4)=0. - akeep(5)=0. - akeep(6)=1.d0 - call mask(akeep,ha2,hm2) -c write(6,*) 'result after g6 mask' -c call pcmap(1,1,0,0,ha2,hm2) -c concatenate exp(:g6:)exp(:g5:)exp(:g4:)exp(:g3:)exp(:g2:) -c and put result in ha,hm. - call concat(ha2,hm2,ha1,hm1,ha,hm) -c - end -c -*********************************************************************** -c - subroutine strget(kynd,nmap,fa,fm) -cryne 12/15/2004 modified to use new common block structure of stmap.inc -c -c This is a subroutine for storing and getting maps. -c A total of 5 maps can be stored and retrieved. -c The incoming and outgoing maps are represented by fa,fm. -c In the store mode, the maps are stored in sf1,sm1 to sf5,sm5. -c In the retrieve mode, the map is gotten from sf1,sm1 to sf5,sm5. -c The maps sf1,sm1 to sf5,sm5 are stored in the block common stmap. -c Written by Alex Dragt, Spring 1987. Modified 10/13/88 AJD. -c - use lieaparam, only : monoms - use parallel - include 'impli.inc' - include 'files.inc' - include 'stmap.inc' - character*3 kynd -c -c Calling arrays - dimension fa(monoms),fm(6,6) -c -c -cryne fix later so that "20" is not hardwired - if(nmap.gt.20)then - if(idproc.eq.0)write(6,*)'ERROR: too many stored maps' - if(idproc.eq.0)write(6,*)'nmap=',nmap - call myexit - endif -c - if (kynd.eq.'gtm') goto 100 -c Procedure for storing maps: - write(jof,400) nmap - 400 format(1x,'map stored in location',2x,i2) -! goto(10,20,30,40,50),nmap -! 10 call mapmap(fa,fm,sf1,sm1) -! return -! 20 call mapmap(fa,fm,sf2,sm2) -! return -! 30 call mapmap(fa,fm,sf3,sm3) -! return -! 40 call mapmap(fa,fm,sf4,sm4) -! return -! 50 call mapmap(fa,fm,sf5,sm5) - call mapmap(fa,fm,storedpoly(1,nmap),storedmat(1,1,nmap)) - return -c -c Procedure for getting maps: - 100 continue -!!!!! write(jof,450) nmap -!!!!! 450 format(1x,'map gotten from location',2x,i2) -! goto(110,120,130,140,150),nmap -! 110 call mapmap(sf1,sm1,fa,fm) -! return -! 120 call mapmap(sf2,sm2,fa,fm) -! return -! 130 call mapmap(sf3,sm3,fa,fm) -! return -! 140 call mapmap(sf4,sm4,fa,fm) -! return -! 150 call mapmap(sf5,sm5,fa,fm) - call mapmap(storedpoly(1,nmap),storedmat(1,1,nmap),fa,fm) -c - return - end -c -********************************************************************* -c - subroutine sympl(itype,fa,fm) -c This is a symplectification subroutine -c Written by Alex Dragt, Spring 1987. - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),fm(6,6) -c - if (itype.eq.1) call sympl1(fm) - if (itype.eq.2) call sympl2(fm) - if (itype.eq.3) call sympl3(fm) -c - return - end -c -********************************************************************* -c - subroutine tpol(p,fa,fm) -c This is a subroutine for computing a quadratic polynomial -c described in terms of twiss parameters. -c Written by Alex Dragt, 21 December 1990 - include 'impli.inc' - include 'param.inc' - dimension p(6) - dimension fa(monoms),fm(6,6) -c----- -c set map to the identity - call ident(fa,fm) -c set up twiss parameters - ax=p(1) - bx=p(2) - ay=p(3) - by=p(4) - at=p(5) - bt=p(6) - if(bx .gt. 0.d0) gx=(1.+ax*ax)/bx - if(by .gt. 0.d0) gy=(1.+ay*ay)/by - if(bt .gt. 0.d0) gt=(1.+at*at)/bt - if (bx .le. 0.) then - ax=0. - bx=0. - gx=0. - endif - if (by .le. 0.) then - ay=0. - by=0. - gy=0. - endif - if (bt .le. 0.) then - at=0. - bt=0. - gt=0. - endif -c set up polynomial - fa(7)=gx - fa(8)=2.d0*ax - fa(13)=bx - fa(18)=gy - fa(19)=2.d0*ay - fa(22)=by - fa(25)=gt - fa(26)=2.d0*at - fa(27)=bt - return - end -c -c********************************************************************** -c - subroutine wnd(pp) -c this is a subroutine for windowing tracking results in -c all six variables. -c Written by Alex Dragt, 12 January 1991. - use rays - include 'impli.inc' - dimension pp(6) -c -c set up control parameters - iplane=nint(pp(1)) - if ((iplane .lt. 1) .or. (iplane .gt. 3)) then - write(6,*) 'iplane out of range in wnd' - return - endif - icon=2*(iplane - 1) - qmin=pp(2) - qmax=pp(3) - pmin=pp(4) - pmax=pp(5) -c - iturn=iturn+1 - do 100 k=1,nrays - if (istat(k).ne.0) goto 100 -c examine particle - q=zblock(1+icon,k) - p=zblock(2+icon,k) - if (q.lt.qmin .or. q.gt.qmax - & .or. p.lt.pmin .or. p.gt.pmax) - & then -c particle outside window - istat(k)=iturn - nlost=nlost+1 - ihist(1,nlost)=iturn - ihist(2,nlost)=k - endif - 100 continue - return - end -c -*********************************************************************** -c - subroutine wnda(p) -c this is a subroutine for windowing tracking results in all planes -c simultaneously. -c Written by Alex Dragt, Spring 1987. - use rays - include 'impli.inc' - dimension p(6) -c - iturn=iturn+1 - do 100 k=1,nraysp - if (istat(k).ne.0) goto 100 -c examine particle location - ax=abs(zblock(1,k)) - apx=abs(zblock(2,k)) - ay=abs(zblock(3,k)) - apy=abs(zblock(4,k)) - at=abs(zblock(5,k)) - apt=abs(zblock(6,k)) - if (ax.gt.p(1) .or. apx.gt.p(2) - & .or. ay.gt.p(3) .or. apy.gt.p(4) - & .or. at.gt.p(5) .or. apt.gt.p(6)) - & then -c particle outside window - istat(k)=iturn - nlost=nlost+1 - ihist(1,nlost)=iturn - ihist(2,nlost)=k - endif - 100 continue - return - end -c -c end of file -c -c *************the remaining routines are no longer needed************** -c - subroutine cmom5(amom) -c this subroutine computes the moments of the particle distribution -c stored in zblock. The moments are put in the array amom. -c Written by Alex Dragt, 1 July 1991. -c Modified to generate <5> and <6>, by Johannes van Zeijts, 11 November 1991. -c - use rays - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension amom(monoms) -c -c working arrays - dimension vmon(monoms) - dimension z(6) -c -c clear amom - do 5 i=1,monoms - 5 amom(i)=0.d0 -c -c computational loop - do 10 k=1,nraysp -c get a ray - do 20 i=1,6 - 20 z(i)=zblock(i,k) -c compute moments for the ray -cryne call evalm5(z,vmon) - call evalm(z,vmon) -c add results to moment sum - do 30 i=1,monoms - 30 amom(i)=amom(i)+vmon(i) - 10 continue -c -c normalize by the number of particles - fact=1.d0/float(nrays) - do 40 i=1,monoms - 40 amom(i)=fact*amom(i) -c - return - end -c -********************************************************************* -c - subroutine dwnd(p) -c this is a subroutine for windowing tracking results from a dynamic ma -c Written by Alex Dragt, Spring 1987. - use rays - include 'impli.inc' - dimension p(6) -c - iturn=iturn+1 - do 100 k=1,nraysp - if (istat(k).ne.0) goto 100 -c examine particle location - ax=abs(zblock(1,k)) - apx=abs(zblock(2,k)) - ay=abs(zblock(3,k)) - apy=abs(zblock(4,k)) - at=abs(zblock(5,k)) - apt=abs(zblock(6,k)) - if (ax.gt.p(1) .or. apx.gt.p(2) - & .or. ay.gt.p(3) .or. apy.gt.p(4) - & .or. at.gt.p(5) .or. apt.gt.p(6)) - & then -c particle outside window - istat(k)=iturn - nlost=nlost+1 - ihist(1,nlost)=iturn - ihist(2,nlost)=k - endif - 100 continue - return - end -c -********************************************************************* -c - subroutine swnd(p) -c this is a subroutine for windowing tracking results from a static map -c Written by Alex Dragt, Spring 1987. - use rays - include 'impli.inc' - dimension p(6) -c - iturn=iturn+1 - do 100 k=1,nraysp - if (istat(k).ne.0) goto 100 -c examine particle location - ax=abs(zblock(1,k)) - apx=abs(zblock(2,k)) - ay=abs(zblock(3,k)) - apy=abs(zblock(4,k)) - if (ax.gt.p(1) .or. apx.gt.p(2) - & .or. ay.gt.p(3) .or. apy.gt.p(4)) - & then -c particle outside window - istat(k)=iturn - nlost=nlost+1 - ihist(1,nlost)=iturn - ihist(2,nlost)=k - endif - 100 continue - return - end -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/cons.f b/OpticsJan2020/MLI_light_optics/Src/cons.f deleted file mode 100755 index a106c1c..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/cons.f +++ /dev/null @@ -1,59 +0,0 @@ -************************************************************************ -* header: CONSTRAINTS (CONS) * -* Constraint subroutines to be used in conjunction with fitting * -* routines. * -************************************************************************ - subroutine con1(p) -c impose constraints amoung parameters in the various parameter sets - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - write(6,*) 'con1 not yet installed' - return - end -c -************************************************************************ -c - subroutine con2(p) -c impose constraints amoung parameters in the various parameter sets - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - write(6,*) 'con2 not yet installed' - return - end -c -************************************************************************ -c - subroutine con3(p) -c impose constraints amoung parameters in the various parameter sets - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - write(6,*) 'con3 not yet installed' - return - end -c -************************************************************************ -c - subroutine con4(p) -c impose constraints amoung parameters in the various parameter sets - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - write(6,*) 'con4 not yet installed' - return - end -c -************************************************************************ -c - subroutine con5(p) -c impose constraints amoung parameters in the various parameter sets - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - write(6,*) 'con5 not yet installed' - return - end -c -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/constants_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/constants_mod.f90 deleted file mode 100644 index ca7af45..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/constants_mod.f90 +++ /dev/null @@ -1,151 +0,0 @@ -!*********************************************************************** -! -! constants_mod: This file contains definitions of the modules -! local, math_consts, and phys_consts -! -! Version: 0.1 -! Author: D.T.Abell, Tech-X Corp., Jan.2005 -! -! Comments -! This should have been written a long time ago! -! -! 13.Jan.2005 (DTA): The _right_ way to do this would be to have -! constants such as pi computed (eg., 2.d0*asin(1.d0)), so they're -! guaranteed to be machine precision. This, however, is a tough -! problem for compilers (which would have to emulate an arbitrary -! computer's floating point intrinsics). But since we don't want a -! user changing any of these constants (else why call them so?), we -! want them declared parameters, which means the compiler must know -! about them NOW. The values were generated through 21 digits using -! Mathematica. -! -!*********************************************************************** -!*********************************************************************** -! -! math_consts -! -! Description: This module defines some standard math constants. -! -!*********************************************************************** -! - module math_consts - implicit none -! -! data -! - double precision, parameter :: pi = 3.14159265358979323846d0 - double precision, parameter :: twopi = 6.28318530717958647693d0 - double precision, parameter :: fourpi = 12.5663706143591729539d0 - double precision, parameter :: euler_e = & - & 2.71828182845904523536d0 - double precision, parameter :: golden_ratio = & - & 1.61803398874989484820d0 - -! conversion factors between radians and degrees - double precision, parameter :: deg_per_rad = & - & 57.2957795130823208768d0 - double precision, parameter :: rad_per_deg = & - & 0.0174532925199432957692d0 - - end module math_consts -! -!*********************************************************************** -! -! phys_consts -! -! Description: This module defines the standard physical constants. For -! each constant, the comment states the units and (in parentheses) the -! expected error in the last digits. For more information, see the -! NIST web site: http://physics.nist.gov/cuu/index.html -! NB: The units are mostly SI, but some constants are given in alternate -! units. Two examples: (1) 'electron_mass' holds the value in kg, but -! 'electron_restE' holds the value in eV; (2) 'planck_h' holds the value -! in J.s, but 'planck_h_ev' holds the value in eV.s. -! -!*********************************************************************** -! - module phys_consts - implicit none -! -! data -! -! speed of light in vacuum /m.s^-1 (exact) - double precision, parameter :: c_light = 299792458.0d0 - -! permittivity of free space /F.m^-1 (exact to digits shown) - double precision, parameter :: epsilon_o = & - & 8.85418781762038985054d-12 - -! 4.pi.{permittivity of free space} /F.m^-1 (exact to digits shown) - double precision, parameter :: epsilon_o_4pi = & - & 1.11265005605361843217d-10 - -! permeability of free space /H.m^-1 (exact to digits shown) - double precision, parameter :: mu_o = 12.5663706143591729539d-7 - -! {permeability of free space}/4.pi /H.m^-1 (exact) - double precision, parameter :: mu_o_ovr_4pi = 1.0d-7 - -! elementary charge /C (63) - double precision, parameter :: elem_charge = 1.602176462d-19 - -! elementary charge /esu (19) - double precision, parameter :: elem_charge_esu = 4.80320420d-10 - -! alpha particle mass /kg (52) - double precision, parameter :: alpha_mass = 6.64465598d-27 - -! alpha particle rest energy /eV (15) - double precision, parameter :: alpha_restE = 3727.37904d+6 - -! electron mass /kg (72) - double precision, parameter :: electron_mass = 9.10938188d-31 - -! electron rest energy /eV (21) - double precision, parameter :: electron_restE = 0.510998902d+6 - -! muon mass /kg (16) - double precision, parameter :: muon_mass = 1.88353109d-28 - -! muon rest energy /eV (52) - double precision, parameter :: muon_restE = 105.6583568d+6 - -! neutron mass /kg (13) - double precision, parameter :: neutron_mass = 1.67492716d-27 - -! neutron rest energy /eV (38) - double precision, parameter :: neutron_restE = 939.565330d+6 - -! proton mass /kg (13) - double precision, parameter :: proton_mass = 1.67262158d-27 - -! proton rest energy /eV (38) - double precision, parameter :: proton_restE = 938.271998d+6 - -! fine-structure constant (27) - double precision, parameter :: fine_structure_a = 7.297352533d-3 - -! fine-structure constant (50) - double precision, parameter :: inv_fine_structure_a = & - & 137.03599976d0 - -! Planck constant /J.s (52) - double precision, parameter :: planck_h = 6.62606876d-34 - -! Planck constant /eV.s (16) - double precision, parameter :: planck_h_ev = 4.13566727d-15 - -! {Planck constant}/(2.pi) /J.s (82) - double precision, parameter :: planck_h_bar = 1.054571596d-34 - -! {Planck constant}/(2.pi) /eV.s (26) - double precision, parameter :: planck_hbar_ev = 6.58211889d-16 - -! Boltzmann constant /J.K^-1 (24) - double precision, parameter :: boltzmann_k = 1.3806503d-23 - -! Boltzmann constant /eV.K^-1 (15) - double precision, parameter :: boltzmann_k_ev = 8.617342d-5 - - end module phys_consts -! diff --git a/OpticsJan2020/MLI_light_optics/Src/curve_fit.f90 b/OpticsJan2020/MLI_light_optics/Src/curve_fit.f90 deleted file mode 100644 index 3a0030d..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/curve_fit.f90 +++ /dev/null @@ -1,604 +0,0 @@ -!*********************************************************************** -! -! curve_fit: module containing functions for fitting curves to data -! -! Description: -! This module implements subroutines for fitting curves to data. -! -! Version: 0.1 -! Author: D.T.Abell, Tech-X Corp., Apr.2005 -! -! Comments -! -! -!*********************************************************************** -! - module curve_fit - use parallel, only : idproc - implicit none -! -! functions and subroutines -! - contains -! -!*********************************************************************** - subroutine cf_polyInterp(xx,yy,x,y,ix,iorder,iorigin) -! -! Interpolate at abcissa x the ordinate value y determined by the -! polynomial of degree iorder that fits the (iorder+1) data points -! (xx,yy) nearest x. The interpolation uses Neville's algorithm, and -! iorder has a default value of three. -! NB: The values in xx MUST increase (or decrease) monotonically. - implicit none - double precision, dimension(:), intent(in) :: xx,yy ! input data - double precision, intent(in) :: x ! interpolate at this abcissa - double precision, intent(out) :: y ! interpolated ordinate value - integer, intent(inout) :: ix ! index of xx nearest x - integer, optional, intent(in) :: iorder ! polynomial order - integer, optional, intent(in) :: iorigin ! index origin of xx,yy -!-----!----------------------------------------------------------------! - integer :: ioff,iord - integer :: i,ii,il,m - double precision, dimension(:), allocatable :: p - - ! use iorder to set iord - iord=3 - if(present(iorder)) iord=iorder - ! use index origin to set index offset - ioff=0 - if(present(iorigin)) ioff=iorigin-1 - - ! allocate temporary array p(0:iord) - allocate(p(0:iord)) - - ! determine lower boundary of interpolation range [il,il+iord] - ! (within this subroutine, xx and yy have index origin one) - ix=ix-ioff - call cf_searchNrst(xx,x,ix) - il=ix-iord/2 - if (il.lt.1) then - il=1 - else if (il.gt.size(xx)-iord) then - il=size(xx)-iord - end if - - ! use array value or do interpolation using Neville's algorithm - if (x.eq.xx(ix)) then - y=yy(ix) - else - do i=0,iord - p(i)=yy(il+i) - end do - do m=1,iord - do i=0,iord-m - ii=il+i - p(i)=((x-xx(ii))*p(i+1)+(xx(ii+m)-x)*p(i))/(xx(ii+m)-xx(ii)) - end do - end do - y=p(0) - end if - - ! offset index for external value of index origin - ix=ix+ioff - - ! deallocate temporary array p(0:iord) - deallocate(p) - - return - end subroutine cf_polyInterp -! -!*********************************************************************** - subroutine cf_polyInterp3(xx,yy,x,y,ix,iorigin) -! -! Interpolate at abcissa x the ordinate value y determined by the -! third-order polynomial that fits the four data points (xx,yy) -! nearest x. The interpolation uses Neville's algorithm. -! NB: The values in xx MUST increase (or decrease) monotonically. - implicit none - double precision, dimension(:), intent(in) :: xx,yy ! input data - double precision, intent(in) :: x ! interpolate at this abcissa - double precision, intent(out) :: y ! interpolated ordinate value - integer, intent(inout) :: ix ! index of xx nearest x - integer, optional, intent(in) :: iorigin ! index origin of xx,yy -!-----!----------------------------------------------------------------! - integer :: ioff,iord - integer :: i,ii,il,m - double precision, dimension(0:3) :: p - - ! use cubic interpolation - iord=3 - ! use index origin to set index offset - ioff=0 - if(present(iorigin)) ioff=iorigin-1 - - ! determine lower boundary of interpolation range [il,il+iord] - ! (within this subroutine, xx and yy have index origin one) - ix=ix-ioff - call cf_search(xx,x,ix) - il=ix-1 ! il=ix-iorder/2=ix-3/2 - if (il.lt.1) then - il=1 - else if (il.gt.size(xx)-3) then - il=size(xx)-3 - end if - - ! use array value or do interpolation using Neville's algorithm - if (x.eq.xx(ix)) then - y=yy(ix) - else - do i=0,iord - p(i)=yy(il+i) - end do - !write(21,*) x,xx(il:il+iord) - !write(21,*) x,p(0:iord) - do m=1,iord - do i=0,iord-m - ii=il+i - p(i)=((x-xx(ii))*p(i+1)+(xx(ii+m)-x)*p(i))/(xx(ii+m)-xx(ii)) - end do - !write(21,*) x,p(0:iord-m) - end do - y=p(0) - end if - - ! offset index for external value of index origin - ix=ix+ioff - - return - end subroutine cf_polyInterp3 -! -!*********************************************************************** - subroutine cf_bivarInterp(ss,tt,ff,s,t,f,is,it,sorder,torder, & - & iorigin) -! -! The two-dimensional array ff records a set of data values over the -! points in the direct product of the one-dimensional arrays ss and tt. -! This subroutine performs bivariate polynomial interpolation of order -! sorder in s and torder in t to interpolate a value f = f(s,t) using -! the (sorder+1)*(torder+1) points nearest (s,t) and the corresponding -! data in ff. The interpolation uses Neville's algorithm in each -! variable, and sorder and torder both have default value three. The -! arrays are assumed to have an index origin of iorigin, which has a -! default value of one. -! NB: The values in ss and tt MUST increase (or decrease) monotonically. - implicit none - double precision, dimension(:), intent(in) :: ss,tt ! arg arrays - double precision, dimension(:,:), intent(in) :: ff ! ff(ss,tt) - double precision, intent(in) :: s,t ! interpolate at this point - double precision, intent(out) :: f ! interpolated value - integer, intent(inout) :: is,it ! indices of ss, tt nearest s,t - integer, optional, intent(in) :: sorder,torder ! polynomial orders - integer, optional, intent(in) :: iorigin ! index origin of arrays -!-----!----------------------------------------------------------------! - integer :: ioff,sord,tord - integer :: i,ii,isl - double precision, dimension(:), allocatable :: p,v - - ! use sorder and torder to set sord and tord - sord=3; tord=3 - if(present(sorder)) sord=sorder - if(present(torder)) tord=torder - - ! use index origin to set index offset - ioff=0 - if(present(iorigin)) ioff=iorigin-1 - ! adjust is and it for index origin (on entrance) - ! (within this subroutine, ss tt, and ff have index origin one) - is=is-ioff; it=it-ioff - - ! determine lower boundary of s interpolation range [isl,isl+sord] - call cf_search(ss,s,is) - isl=is-sord/2 - if (isl.lt.1) then - isl=1 - else if (isl.gt.size(ss)-sord) then - isl=size(ss)-sord - end if - - ! allocate temporary arrays p(0:sord) and v(0:sord) - allocate(p(0:sord)) - allocate(v(0:sord)) - - ! do polynomial interpolation in t for nearby s values - do i = 0,sord - v(i)=ss(isl+i) - call cf_polyInterp(tt,ff(isl+i,:),t,p(i),it,tord) - end do - ! do polynomial interpolation in s - ii=is-isl - call cf_polyInterp(v,p,s,f,ii,sord,0) - - ! adjust is and it for index origin (on exit) - is=is+ioff; it=it+ioff - - ! deallocate temporary arrays p and v - deallocate(p) - deallocate(v) - - return - end subroutine cf_bivarInterp -! -!*********************************************************************** - function cf_interp(xx,a,b,c,x) -! -! Interpolate at x the value of a function described by the n-element -! coefficient arrays a, b, and c. These arrays hold the quadratic -! fit parameters determined at locations xx by subroutine cf_parfit -! such that f = a + b*x + c*x**2. -! NB: The values in xx MUST increase (or decrease) monotonically. - implicit none - double precision :: cf_interp - double precision, dimension(:) :: a,b,c,xx - double precision :: x -!-----!----------------------------------------------------------------! - integer :: j,n - - n=size(xx) - call cf_search(xx,x,j) - if(j.lt.1) then - j=1 - else if(j.gt.(n-1)) then - j=n-1 - endif - cf_interp=a(j)+x*(b(j)+x*c(j)) - return - end function cf_interp -! -!*********************************************************************** - subroutine cf_interp2(xx,yy,x,y) -! -! Quadratic interpolation at x based on data pairs (xx,yy). -! NB: The data in xx MUST increase (or decrease) monotonically. - implicit none - double precision, dimension(0:2), intent(in) :: xx,yy - double precision, intent(in) :: x - double precision, intent(out) :: y -!-----!----------------------------------------------------------------! - double precision :: c1,c2 - - c1=(yy(1)-yy(0))/(xx(1)-xx(0)) - c2=((yy(2)-yy(0))/(xx(2)-xx(0))-c1)/(xx(2)-xx(1)) - y=yy(0)+(x-xx(0))*(c1+(x-xx(1))*c2) - return - end subroutine cf_interp2 -! -!*********************************************************************** - subroutine cf_parfit(xi,yi,ai,bi,ci) -! -! This subroutine takes data pairs (x(i),y(i)), i=1..npts, fits a -! quadratic form a+b*x+c*x**2 to each triple of adjacent points, and -! returns the lists of coefficients a(i), b(i), and c(i). -! Except at the ends, the coefficients reported for the i-th interval -! are computed as the average of those calculated using the points -! (i-1,i,i+1) and those calculated using the points (i,i+1,i+2). - implicit none - double precision, dimension(:), intent(in) :: xi,yi - double precision, dimension(:), intent(out) :: ai,bi,ci -!-----!----------------------------------------------------------------! - integer :: i,ip2,npts,npm1,npm2 - double precision :: x1,x2,x3,y1,y2,y3 - double precision :: d1,d2,d3,h1,h2,h3 - double precision :: a1,b1,c1,a2,b2,c2 -! - npts=size(xi) - npm1=npts-1 - npm2=npts-2 -! -! initialize the fitting - x1=xi(1) - x2=xi(2) - x3=xi(3) - y1=yi(1) - y2=yi(2) - y3=yi(3) - h1=x2-x1 - h2=x3-x2 - h3=x3-x1 - d1= y1/(h3*h1) - d2=-y2/(h1*h2) - d3= y3/(h2*h3) -! and fit a parabola to the first three points - a1= d1*x2*x3 + d2*x3*x1 + d3*x1*x2 - b1= -d1*(x2+x3) - d2*(x3+x1) - d3*(x1+x2) - c1= d1 + d2 + d3 - ai(1)=a1 - bi(1)=b1 - ci(1)=c1 -! -! compute the next set of quadratic coefficients, -! and average with the previous set - do i=2,npm2 - ip2=i+2 - x1=x2 - x2=x3 - x3=xi(ip2) - y1=y2 - y2=y3 - y3=yi(ip2) - h1=h2 - h2=x3-x2 - h3=x3-x1 - d1= y1/(h1*h3) - d2=-y2/(h1*h2) - d3= y3/(h2*h3) - a2= d1*x2*x3 + d2*x3*x1 + d3*x1*x2 - b2= -d1*(x2+x3) - d2*(x3+x1) - d3*(x1+x2) - c2= d1 + d2 + d3 - ai(i)=0.5d0*(a1+a2) - bi(i)=0.5d0*(b1+b2) - ci(i)=0.5d0*(c1+c2) - a1=a2 - b1=b2 - c1=c2 - end do -! -! rightmost interval - ai(npm1)=a2 - bi(npm1)=b2 - ci(npm1)=c2 -! - return - end subroutine cf_parfit -! -!*********************************************************************** - subroutine cf_search(xx,x,j,iorigin) -! -! Search array xx(1:n) and return index j such that x lies in range -! [xx(j),x(j+1)) or, if j=n-1, [xx(n-1),xx(n)]. If the value returned -! in j is either 0 or n=size(xx), then x lies outside the range of xx. -! Use the value of j on input as an initial guess for searching. -! If the array submitted to this routine has index origin other than 1, -! then one may specify it using the optional argument iorigin. In this -! case, of course, the values of j that indicate an out-of-range -! condition are (iorigin-1) and (size(xx)+iorigin-1). -! NB: The array xx must be monotonic, either increasing or decreasing. -! Cf. Numerical Recipes, 2nd ed. (1992), p.121. - implicit none - double precision, dimension(:), intent(in) :: xx - double precision, intent(in) :: x - integer, intent(inout) :: j - integer, optional, intent(in) :: iorigin -!-----!----------------------------------------------------------------! - integer jl,jm,ju,incr,n - logical ascend - double precision, parameter :: epsilon=1.d-13 - - ! get size of xx, and adjust for index origin - n=size(xx) - if(present(iorigin)) j=j-(iorigin-1) - ! do array values ascend or descend - ascend=(xx(n).gt.xx(1)) - ! use initial value of j to bracket binary search - if (j.lt.1.or.j.gt.n) then - ! bracket entire array - jl=0; ju=n+1 - else - ! hunt for smaller bracket - jl=j; ju=j - incr=1 - if ((x.gt.xx(jl).eqv.ascend).or.x.eq.xx(jl)) then - ! move bracket -=> - 1 ju=jl+incr - if (ju.gt.n) then - ju=n+1 - else if ((x.gt.xx(ju).eqv.ascend).or.x.eq.xx(ju)) then - jl=ju - incr=incr+incr - goto 1 - end if - else - ! move bracket <=- - 2 jl=ju-incr - if (jl.lt.1) then - jl=0 - else if ((x.lt.xx(jl).eqv.ascend).and.x.ne.xx(jl)) then - ju=jl - incr=incr+incr - goto 2 - end if - end if - end if - ! now do binary search - 3 if (ju-jl.gt.1) then - jm=(jl+ju)/2 - if(((x.gt.xx(jm)).eqv.ascend).or.(x.eq.xx(jm))) then - jl=jm - else - ju=jm - endif - goto 3 - end if - j=jl - ! be nice if within epsilon of edges - if (j.eq.0) then - if (abs(x-xx(1)).le.epsilon) j=1 - else if (j.eq.n) then - if (abs(x-xx(n)).le.epsilon) j=n-1 - end if - ! adjust for index origin - if(present(iorigin)) j=j+(iorigin-1) -! - return - end subroutine cf_search -! -!*********************************************************************** - subroutine cf_searchNrst(xx,x,j,iorigin) -! -! Search array xx(1:n) and return index j such that x lies in range -! [xx(j),x(j+1)) or, if j=n-1, [xx(n-1),xx(n)]. If the value returned -! in j is either 0 or n=size(xx), then x lies outside the range of xx. -! Use the value of j on input as an initial guess for searching. -! If the array submitted to this routine has index origin other than 1, -! then one may specify it using the optional argument iorigin. In this -! case, of course, the values of j that indicate an out-of-range -! condition are (iorigin-1) and (size(xx)+iorigin-1). -! NB: The array xx must be monotonic, either increasing or decreasing. -! Cf. Numerical Recipes, 2nd ed. (1992), p.121. - implicit none - double precision, dimension(:), intent(in) :: xx - double precision, intent(in) :: x - integer, intent(inout) :: j - integer, optional, intent(in) :: iorigin -!-----!----------------------------------------------------------------! - integer jl,jm,ju,incr,n - logical ascend - double precision, parameter :: epsilon=1.d-13 - - ! get size of xx, and adjust for index origin - n=size(xx) - if(present(iorigin)) j=j-(iorigin-1) - ! do array values ascend or descend - ascend=(xx(n).gt.xx(1)) - ! use initial value of j to bracket binary search - if (j.lt.1.or.j.gt.n) then - ! bracket entire array - jl=0; ju=n+1 - else - ! hunt for smaller bracket - jl=j; ju=j - incr=1 - if ((x.gt.xx(jl).eqv.ascend).or.x.eq.xx(jl)) then - ! move bracket -=> - 1 ju=jl+incr - if (ju.gt.n) then - ju=n+1 - else if ((x.gt.xx(ju).eqv.ascend).or.x.eq.xx(ju)) then - jl=ju - incr=incr+incr - goto 1 - end if - else - ! move bracket <=- - 2 jl=ju-incr - if (jl.lt.1) then - jl=0 - else if ((x.lt.xx(jl).eqv.ascend).and.x.ne.xx(jl)) then - ju=jl - incr=incr+incr - goto 2 - end if - end if - end if - ! now do binary search - 3 if (ju-jl.gt.1) then - jm=(jl+ju)/2 - if(((x.gt.xx(jm)).eqv.ascend).or.(x.eq.xx(jm))) then - jl=jm - else - ju=jm - endif - goto 3 - end if - j=jl - ! be nice if within epsilon of edges, - ! and be sure we return Nearest index - if (j.eq.0) then - if (abs(x-xx(1)).le.epsilon) j=1 - else if (j.eq.n) then - if (abs(x-xx(n)).le.epsilon) j=n - else - if (abs(x-xx(j)).gt.abs(x-xx(j+1))) j=j+1 - end if - ! adjust for index origin - if(present(iorigin)) j=j+(iorigin-1) -! - return - end subroutine cf_searchNrst -! -!*********************************************************************** - subroutine cf_locate(xx,x,j,iorigin) -! -! Search array xx(:) and return index j such that x lies in range -! [xx(j),x(j+1)) or, if j=n-1, [xx(n-1),xx(n)]. If the value returned -! in j is either 0 or n=size(xx), then x lies outside the range of xx. -! If the array submitted to this routine has index origin other than 1, -! then one may specify it using the optional argument iorigin. In this -! case, of course, the values of j that indicate an out-of-range -! condition are (iorigin-1) and (size(xx)+iorigin-1). -! NB: The array xx must be monotonic, either increasing or decreasing. -! Cf. Numerical Recipes, 2nd ed. (1992), p.121. - implicit none - double precision, dimension(:), intent(in) :: xx - double precision, intent(in) :: x - integer, intent(inout) :: j - integer, optional, intent(in) :: iorigin -!-----!----------------------------------------------------------------! - integer jl,jm,ju,incr,n - logical ascend - double precision, parameter :: epsilon=1.d-13 - - ! get size of xx - n=size(xx) - ! do array values ascend or descend? - ascend=(xx(n).gt.xx(1)) - ! now initialize and perform binary search - jl=0; ju=n+1 - 3 if (ju-jl.gt.1) then - jm=(jl+ju)/2 - if(((x.gt.xx(jm)).eqv.ascend).or.(x.eq.xx(jm))) then - jl=jm - else - ju=jm - endif - goto 3 - endif - j=jl - ! be nice if within epsilon of edges - if (j.eq.0) then - if (abs(x-xx(1)).le.epsilon) j=1 - else if (j.eq.n) then - if (abs(x-xx(n)).le.epsilon) j=n-1 - end if - ! adjust for index origin - if(present(iorigin)) j=j+(iorigin-1) -! - return - end subroutine cf_locate -! -!*********************************************************************** - subroutine cf_locate_nr(xx,x,j,iorigin) -! -! Search array xx(:) and return index j such that x lies in range -! [xx(j),x(j+1)). If the value j returned is either 0 or n=size(xx), -! then x lies outside the range of xx. -! If the array submitted to this routine has index origin other than 1, -! then one may specify it using the optional argument iorigin. In this -! case, of course, the values of j that indicate an out-of-range -! condition are (iorigin-1) and (size(xx)+iorigin-1). -! NB: The array xx must be monotonic, either increasing or decreasing. -! Cf. Numerical Recipes, 2nd ed. (1992), p.121. - implicit none - double precision, dimension(:), intent(in) :: xx - double precision, intent(in) :: x - integer, intent(inout) :: j - integer, optional, intent(in) :: iorigin -!-----!----------------------------------------------------------------! - integer jl,jm,ju,incr,n - logical ascend - double precision, parameter :: eps=1.d-13 - - ! get size of xx - n=size(xx) - ! do array values ascend or descend? - ascend=(xx(n).gt.xx(1)) - ! now initialize and perform binary search - jl=0; ju=n+1 - 3 if (ju-jl.gt.1) then - jm=(jl+ju)/2 - if(((x.gt.xx(jm)).eqv.ascend).or.(abs(x-xx(jm)).lt.eps)) then - jl=jm - else - ju=jm - endif - goto 3 - endif - !if (jl.eq.n.and.x.eq.xx(n)) jl=n-1 - j=jl - ! adjust for index origin - if(present(iorigin)) j=j+(iorigin-1) -! - return - end subroutine cf_locate_nr -! - end module curve_fit - diff --git a/OpticsJan2020/MLI_light_optics/Src/depositrho.f b/OpticsJan2020/MLI_light_optics/Src/depositrho.f deleted file mode 100644 index eb40307..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/depositrho.f +++ /dev/null @@ -1,95 +0,0 @@ -! IMPACT 3D space charge routines -! Copyright 2003 University of California -! -! subroutine depositrho( C,Msk,Np,NpTot,Nx,Ny,Nz,Nadj,rho,rhotmp ) -! -! Arguments: -! C :in (1:5:2,Np) are x,y,z coordinates of particles -! Note: in the rest of MLI column 5 is time-of-flight (i.e. phase), -! but prior to calling the space charge routines it is -! converted to longitudinal position z. -! (2:6:2,Np) are momenta and not used here. -! Msk :in flag indicating valid particles -! Np :in number of particles (both good and bad) on this processor -! Nptot :in number of (good) particles on all processors -! Nx,Ny,Nz :in dimensions of grid on the regular sized grid -! Nadj :in =0 for open or Dirichlet BCs, >=1 for longitudinally periodic BCs -! rho :out array of charge density -! rhotmp :tmp scratch space -! -! Globals: -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine depositrho( C,Msk,Np,NpTot,Nx,Ny,Nz,rho,rhotmp ) -!Modules - use parallel - use ml_timer - implicit none -!Arguments - real*8 C(6,Np) - logical Msk(Np) - integer Np,Nptot,Nx,Ny,Nz,Nadj - real*8 rho(Nx,Ny,Nz) ,rhotmp(Nx,Ny,Nz) -!Local variables - integer ierror -!Globals - integer IVerbose - common/SHOWME/IVerbose - real*8 xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - common/GRIDSZ3D/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi -!Externals - -!Execute - if( IVerbose .GT. 5 ) write(6,*) 'in DEPOSITRHO' - -! deposit charge on the grid: - call increment_timer('rhoslo3d',0) - call rhoslo3d(C,rho,Msk,Np,Nx,Ny,Nz,Nadj) - if( NVP .GT. 1 )then - call MPI_ALLREDUCE(rho,rhotmp,Nx*Ny*Nz,Mreal,Mpisum,Lworld,ierror) - if( ierror .NE. 0 ) write(6,*) - & 'depositrho: MPI_ALLREDUCE returned ',ierror - rho=rhotmp - endif - call increment_timer('rhoslo3d',1) - -!-------- -!XXX!-- for iexactrho case -!XXX glrhochk=sum(rho) -!XXX if(idproc.eq.0) & -!XXX & write(6,*)'(exact rho): global sum of rho = ',glrhochk -!XXX call getrms(c,xrms,yrms,zrms,np) -!XXX if(idproc.eq.0) & -!XXX & write(6,*)'(exact rho): xrms,yrms,zrms=',xrms,yrms,zrms -!XXX xmac=sqrt(5.d0)*xrms -!XXX ymac=sqrt(5.d0)*yrms -!XXX zmac=sqrt(5.d0)*zrms -!XXX if(idproc.eq.0) & -!XXX & write(6,*)'(exact rho): xmac,ymac,zmac=',xmac,ymac,zmac -!XXX rho=0.d0 -!XXX do k=1,nz -!XXX z=zmin+(k-1)*hz -!XXX do j=1,ny -!XXX y=ymin+(j-1)*hy -!XXX do i=1,nx -!XXX x=xmin+(i-1)*hx -!XXX! if((x/xbig)**2+(y/ybig)**2+(z/zbig)**2 .le.1.d0)rho(i,j,k)=1.d0 -!XXX if((x/xmac)**2+(y/ymac)**2+(z/zmac)**2 .le.1.d0)rho(i,j,k)=1.d0 -!XXX enddo -!XXX enddo -!XXX enddo -!XXX glrhonew=sum(rho) -!XXX if(idproc.eq.0) & -!XXX & write(6,*)'(exact rho): glrhonew=',glrhonew -!XXX rho=rho*glrhochk/glrhonew -!XXX glrhochk=sum(rho) -!XXX if(idproc.eq.0) & -!XXX & write(6,*)'(exact rho): new global sum of rho = ',glrhochk -!XXX!-- end - -!-------- -cryne august 1, 2002 -cryne moved normalization out of rhoslo to here: - rho=rho/(hx*hy*hz*ntot) - call system_clock(count=iticks1) diff --git a/OpticsJan2020/MLI_light_optics/Src/diagnostics.f b/OpticsJan2020/MLI_light_optics/Src/diagnostics.f deleted file mode 100755 index 585ff85..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/diagnostics.f +++ /dev/null @@ -1,905 +0,0 @@ -c******************* ML/I DIAGNOSTIC ROUTINES******************* - subroutine writereftraj(sarclen,nfile,nprecision,nunits) - use parallel, only: idproc - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'map.inc' - include 'usrdat.inc' - integer :: nfile,nprecision,nunits - real*8 sarclen - character*16 :: myformat='(9(1x,1pe12.5 ))' - character*2 :: a2 - common/envdata/env(6),envold(6),emap(6,6) -!---format: - nlength=nprecision+7 - call num2string(nlength,a2,2) - myformat(10:11)=a2 - call num2string(nprecision,a2,2) - myformat(13:14)=a2 -! - xl=sl - wld=omegascl*xl*p0sc - z=sarclen -! reference trajecory (t-pt portion): - energy=(gamma-1.)*pmass - if(idproc.eq.0)then - if(nunits.eq.0)then - write(nfile,myformat)z,reftraj(1:6),energy - write(17,myformat)z,env(1:6) - call myflush(17) - elseif(nunits.eq.1)then - write(nfile,myformat)z,reftraj(1)*xl,reftraj(2)*p0sc, & - & reftraj(3)*xl,reftraj(4)*p0sc, & - & reftraj(5)/omegascl,reftraj(6)*wld,energy - write(17,myformat)z,env(1:6) - call myflush(17) - endif - endif - ucalc(100)=energy - return - end -c - subroutine writemom2d(sarclen,nfile1,nfile2,nfile3, & - & nprecision,nunits,ncorr,includepi,ncent) -cryne 8/11/2001 routine to print some 2nd moments -c arguments: -c sarclen = current arclength -c nfile1 = unit # for output xfile -c nfile2 = unit # for output yfile -c nfile3 = unit # for output tfile -c nprecision = precision at which to write data -c nunits = 0/1 for dimensionless/physical variables in output -c ncorr = 0/1 to report cross-terms (,...) as is/as ratios -c includepi = 0/1 to no/yes divide emittances by pi -c ncent = 0/1 to remove/keep beam centroid in emittance computation - use beamdata - use rays - use ml_timer - include 'impli.inc' - include 'usrdat.inc' -! - integer :: nfile1,nfile2,nfile3,nprecision,nunits,ncorr,ncent - real*8 sarclen -! - logical msk - dimension msk(nraysp) - dimension avg(6),ravg(6) - dimension diag(9),rdiag(9) - character*16 :: myformat='(6(1x,1pe12.5 ))' - character*2 :: a2 - real*8 :: zero=0. -! - call increment_timer('moments',0) -! -c set up particle mask - msk(1:nraysp)=.true. - do j=1,nraysp - if(istat(j).ne.0)msk(j)=.false. - enddo -! -c compute moments -c scale factors - den1=1./nrays - den2=den1*den1 - slp0=sl*p0sc - slp1=slp0 - wld=omegascl*slp0 - clyte=299792458.d0 - pi=2.d0*asin(1.d0) - z=sarclen -c compute beam centroid - ravg(1:6)=0.d0 - if(ncent.eq.0)then - avg(1)=sum(zblock(1,1:nraysp),msk)*den1 - avg(2)=sum(zblock(2,1:nraysp),msk)*den1 - avg(3)=sum(zblock(3,1:nraysp),msk)*den1 - avg(4)=sum(zblock(4,1:nraysp),msk)*den1 - avg(5)=sum(zblock(5,1:nraysp),msk)*den1 - avg(6)=sum(zblock(6,1:nraysp),msk)*den1 - call MPI_ALLREDUCE(avg,ravg,6,mreal,mpisum,lworld,ierror) - endif -c give readable names to coordinate entries - xbar=ravg(1) - ybar=ravg(3) - tbar=ravg(5) -c compute second-order moments - diag(1)=sum((zblock(1,1:nraysp)-ravg(1)) & - & *(zblock(1,1:nraysp)-ravg(1)),msk) - diag(2)=sum((zblock(2,1:nraysp)-ravg(2)) & - & *(zblock(2,1:nraysp)-ravg(2)),msk) - diag(3)=sum((zblock(3,1:nraysp)-ravg(3)) & - & *(zblock(3,1:nraysp)-ravg(3)),msk) - diag(4)=sum((zblock(4,1:nraysp)-ravg(4)) & - & *(zblock(4,1:nraysp)-ravg(4)),msk) - diag(5)=sum((zblock(5,1:nraysp)-ravg(1)) & - & *(zblock(5,1:nraysp)-ravg(2)),msk) - diag(6)=sum((zblock(6,1:nraysp)-ravg(3)) & - & *(zblock(6,1:nraysp)-ravg(4)),msk) - diag(7)=sum((zblock(1,1:nraysp)-ravg(1)) & - & *(zblock(2,1:nraysp)-ravg(2)),msk) - diag(8)=sum((zblock(3,1:nraysp)-ravg(3)) & - & *(zblock(4,1:nraysp)-ravg(4)),msk) - diag(9)=sum((zblock(5,1:nraysp)-ravg(5)) & - & *(zblock(6,1:nraysp)-ravg(6)),msk) - call MPI_ALLREDUCE(diag,rdiag,9,mreal,mpisum,lworld,ierror) -c give readable names to entries, and divide by number of particles - sq1=rdiag(1)*den1 - sq2=rdiag(2)*den1 - sq3=rdiag(3)*den1 - sq4=rdiag(4)*den1 - sq5=rdiag(5)*den1 - sq6=rdiag(6)*den1 - xpx=rdiag(7)*den1 - ypy=rdiag(8)*den1 - tpt=rdiag(9)*den1 -c compute derived quantities - epsx2=(sq1*sq2-xpx*xpx) - epsy2=(sq3*sq4-ypy*ypy) - epst2=(sq5*sq6-tpt*tpt) - xrms=sqrt(sq1) - yrms=sqrt(sq3) - trms=sqrt(sq5) - pxrms=sqrt(sq2) - pyrms=sqrt(sq4) - ptrms=sqrt(sq6) - epsx=sqrt(max(epsx2,zero)) - epsy=sqrt(max(epsy2,zero)) - epst=sqrt(max(epst2,zero)) - if(includepi.eq.1)then - epsx=epsx/pi - epsy=epsy/pi - epst=epst/pi - endif - if(ncorr.eq.1)then - xpxfac=0.d0 - ypyfac=0.d0 - tptfac=0.d0 - if(xrms.ne.0. .and. pxrms.ne.0.)xpxfac=1./(xrms*pxrms) - if(yrms.ne.0. .and. pyrms.ne.0.)ypyfac=1./(yrms*pyrms) - if(trms.ne.0. .and. ptrms.ne.0.)tptfac=1./(trms*ptrms) - xpx=xpx*xpxfac - ypy=ypy*ypyfac - tpt=tpt*tptfac - slp1=1.d0 - endif -! -c output results - if(idproc.eq.0)then -c set format for amount of data and desired precision - nlength=nprecision+7 - call num2string(nlength,a2,2) - myformat(10:11)=a2 - call num2string(nprecision,a2,2) - myformat(13:14)=a2 -c write 2D (transverse 2nd moments) - if(nunits.eq.0)then - write(nfile1,myformat)z,xrms,pxrms,xpx,epsx,xbar - write(nfile2,myformat)z,yrms,pyrms,ypy,epsy,ybar - else - write(nfile1,myformat)z,xrms*sl,pxrms*p0sc,xpx*slp1,epsx*slp0,& - & xbar*sl - write(nfile2,myformat)z,yrms*sl,pyrms*p0sc,ypy*slp1,epsy*slp0,& - & ybar*sl - endif - endif - ucalc(1)=xrms - ucalc(2)=pxrms - ucalc(3)=xpx - ucalc(4)=yrms - ucalc(5)=pyrms - ucalc(6)=ypy -c write 3D (t-pt 2nd moments) - if(idproc.eq.0)then - if(nunits.eq.0)then - write(nfile3,myformat)z,trms,ptrms,tpt,epst,tbar - else - write(nfile3,myformat)z,trms*beta*clyte/omegascl,ptrms*wld, & - & tpt*slp1,epst*slp0,tbar/omegascl - endif - endif - ucalc(7)=trms - ucalc(8)=ptrms - ucalc(9)=tpt -! - call increment_timer('moments',1) - return - end -! - subroutine writeemit(sarclen,nfile,nprecision,nunits, - & ne2,ne4,ne6,ncent) -cabell 8/29/2004 routine to write 2- 4- and/or 6-d emittances -c arguments: -c sarclen = current arclength -c nfile = unit # for output file -c nprecision = precision at which to write data -c nunits = 0/1 for dimensionless/physical variables in output -c ne2 = flag to compute 2-d emittances -c ne4 = flag to compute 4-d transverse emittance -c ne6 = flag to compute 6-d emittance -c ncent = 0/1 to remove/keep beam centroid in emittance computation - use beamdata - use rays - use ml_timer - include 'impli.inc' -! - integer :: nfile,nprecision,nunits,ne2,ne4,ne6,ncent - real*8 sarclen -! - logical msk - dimension msk(nraysp) - dimension avg(6),ravg(6) - dimension diag(21),rdiag(21) - dimension sigma6(6,6) - character*16 :: myformat='(6(1x,1pe12.5 ))' - character*1 :: a1 - character*2 :: a2 - real*8 :: zero=0. -! - call increment_timer('moments',0) -! -! if(idproc.eq.0) then -! write(6,*) "writeemit()::" -! if(nunits.eq.0) write(6,*) " using scaled variables" -! if(nunits.eq.1) write(6,*) " using physical variables" -! if(ne2.eq.1) write(6,*) " --2-D" -! if(ne4.eq.1) write(6,*) " --4-D" -! if(ne6.eq.1) write(6,*) " --6-D" -! endif -! -c set up particle mask - msk(1:nraysp)=.true. - do j=1,nraysp - if(istat(j).ne.0)msk(j)=.false. - enddo -! -c compute emittances -c scale factors - den1=1./nrays - slp0=sl*p0sc - clyte=299792458.d0 - wld=omegascl*slp0 - z=sarclen -c compute beam centroid - ravg(1:6)=0.d0 - if(ncent.eq.0)then - avg(1)=sum(zblock(1,1:nraysp),msk)*den1 - avg(2)=sum(zblock(2,1:nraysp),msk)*den1 - avg(3)=sum(zblock(3,1:nraysp),msk)*den1 - avg(4)=sum(zblock(4,1:nraysp),msk)*den1 - avg(5)=sum(zblock(5,1:nraysp),msk)*den1 - avg(6)=sum(zblock(6,1:nraysp),msk)*den1 - call MPI_ALLREDUCE(avg,ravg,6,mreal,mpisum,lworld,ierror) - endif -c compute entries of beam sigma matrix -c entries of diag() follow diagonals of the beam matrix -c starting from the main diagonal and going out to UR corner -c compute only required entries - diag(1:21)=0 - diag( 1)=sum((zblock(1,1:nraysp)-ravg(1)) & - & *(zblock(1,1:nraysp)-ravg(1)),msk) - diag( 2)=sum((zblock(2,1:nraysp)-ravg(2)) & - & *(zblock(2,1:nraysp)-ravg(2)),msk) - diag( 3)=sum((zblock(3,1:nraysp)-ravg(3)) & - & *(zblock(3,1:nraysp)-ravg(3)),msk) - diag( 4)=sum((zblock(4,1:nraysp)-ravg(4)) & - & *(zblock(4,1:nraysp)-ravg(4)),msk) - diag( 7)=sum((zblock(1,1:nraysp)-ravg(1)) & - & *(zblock(2,1:nraysp)-ravg(2)),msk) - diag( 9)=sum((zblock(3,1:nraysp)-ravg(3)) & - & *(zblock(4,1:nraysp)-ravg(4)),msk) - if(ne2.eq.1.or.ne6.eq.1)then - diag( 5)=sum((zblock(5,1:nraysp)-ravg(5)) & - & *(zblock(5,1:nraysp)-ravg(5)),msk) - diag( 6)=sum((zblock(6,1:nraysp)-ravg(6)) & - & *(zblock(6,1:nraysp)-ravg(6)),msk) - diag(11)=sum((zblock(5,1:nraysp)-ravg(5)) & - & *(zblock(6,1:nraysp)-ravg(6)),msk) - endif - if(ne4.eq.1.or.ne6.eq.1)then - diag( 8)=sum((zblock(2,1:nraysp)-ravg(2)) & - & *(zblock(3,1:nraysp)-ravg(3)),msk) - diag(12)=sum((zblock(1,1:nraysp)-ravg(1)) & - & *(zblock(3,1:nraysp)-ravg(3)),msk) - diag(13)=sum((zblock(2,1:nraysp)-ravg(2)) & - & *(zblock(4,1:nraysp)-ravg(4)),msk) - diag(16)=sum((zblock(1,1:nraysp)-ravg(1)) & - & *(zblock(4,1:nraysp)-ravg(4)),msk) - endif - if(ne6.eq.1)then - diag(10)=sum((zblock(4,1:nraysp)-ravg(4)) & - & *(zblock(5,1:nraysp)-ravg(5)),msk) - diag(14)=sum((zblock(3,1:nraysp)-ravg(3)) & - & *(zblock(5,1:nraysp)-ravg(5)),msk) - diag(15)=sum((zblock(4,1:nraysp)-ravg(4)) & - & *(zblock(6,1:nraysp)-ravg(6)),msk) - diag(17)=sum((zblock(2,1:nraysp)-ravg(2)) & - & *(zblock(5,1:nraysp)-ravg(5)),msk) - diag(18)=sum((zblock(3,1:nraysp)-ravg(3)) & - & *(zblock(6,1:nraysp)-ravg(6)),msk) - diag(19)=sum((zblock(1,1:nraysp)-ravg(1)) & - & *(zblock(5,1:nraysp)-ravg(5)),msk) - diag(20)=sum((zblock(2,1:nraysp)-ravg(2)) & - & *(zblock(6,1:nraysp)-ravg(6)),msk) - diag(21)=sum((zblock(1,1:nraysp)-ravg(1)) & - & *(zblock(6,1:nraysp)-ravg(6)),msk) - endif - call MPI_ALLREDUCE(diag,rdiag,21,mreal,mpisum,lworld,ierror) -c give readable names to entries, and divide by number of particles - xx=rdiag( 1)*den1 - pxpx=rdiag( 2)*den1 - yy=rdiag( 3)*den1 - pypy=rdiag( 4)*den1 - tt=rdiag( 5)*den1 - ptpt=rdiag( 6)*den1 - xpx=rdiag( 7)*den1 - pxy=rdiag( 8)*den1 - ypy=rdiag( 9)*den1 - pyt=rdiag(10)*den1 - tpt=rdiag(11)*den1 - xy=rdiag(12)*den1 - pxpy=rdiag(13)*den1 - yt=rdiag(14)*den1 - pypt=rdiag(15)*den1 - xpy=rdiag(16)*den1 - pxt=rdiag(17)*den1 - ypt=rdiag(18)*den1 - xt=rdiag(19)*den1 - pxpt=rdiag(20)*den1 - xpt=rdiag(21)*den1 -c epsX2=det(2x2 beam sigma matrix for horizontal plane) -c epsY2=det(2x2 beam sigma matrix for vertical plane) -c epsT2=det(2x2 beam sigma matrix for longitudinal plane) - if(ne2.eq.1)then - epsX2=(xx*pxpx-xpx*xpx) - epsY2=(yy*pypy-ypy*ypy) - epsT2=(tt*ptpt-tpt*tpt) - epsX=sqrt(max(epsX2,zero)) - epsY=sqrt(max(epsY2,zero)) - epsT=sqrt(max(epsT2,zero)) - if(nunits.eq.1)then - epsX=epsX*slp0 - epsY=epsY*slp0 - epsT=epsT*slp0 - endif - endif -c epsXY2=det(4x4 beam sigma matrix for transverse planes) - if(ne4.eq.1)then - epsXY2=xx*yy*pxpx*pypy & - & + xpx**2*ypy**2 + xy**2*pxpy**2 + xpy**2*pxy**2 & - & - xx*(pxpx*ypy**2 + yy*pxpy**2 + pypy*pxy**2) & - & - pxpx*(yy*xpy**2 + pypy*xy**2) - yy*pypy*xpx**2 & - & + 2*(xx*pxy*pxpy + pxpx*xy*xpy)*ypy & - & + 2*(yy*xpy*pxpy + pypy*xy*pxy)*xpx & - & - 2*xpx*(xpy*pxy + xy*pxpy)*ypy - 2*xy*xpy*pxy*pxpy - epsXYth=max(epsXY2,zero)**0.25 - if(nunits.eq.1)then - epsXYth=epsXYth*slp0 - endif - endif -c epsXYT2=det(6x6 beam sigma matrix) -c this COULD be coded by hand, but the det contains 388 terms! - if(ne6.eq.1)then - sigma6(1,1)=xx - sigma6(2,1)=xpx - sigma6(3,1)=xy - sigma6(4,1)=xpy - sigma6(5,1)=xt - sigma6(6,1)=xpt - sigma6(2,2)=pxpx - sigma6(3,2)=pxy - sigma6(4,2)=pxpy - sigma6(5,2)=pxt - sigma6(6,2)=pxpt - sigma6(3,3)=yy - sigma6(4,3)=ypy - sigma6(5,3)=yt - sigma6(6,3)=ypt - sigma6(4,4)=pypy - sigma6(5,4)=pyt - sigma6(6,4)=pypt - sigma6(5,5)=tt - sigma6(6,5)=tpt - sigma6(6,6)=ptpt - do i=1,6 - do j=i+1,6 - sigma6(i,j)=sigma6(j,i) - enddo - enddo -cabell:need to compute epsXYT2=det(sigma6) - epsXYT2=0.0 - epsXYTth=(max(epsXYT2,zero))**(1.d0/6.d0) - if(nunits.eq.1)then - epsXYTth=epsXYTth*slp0 - endif - endif -! -c output results - if(idproc.eq.0)then -c set format for amount of data and desired precision - nout=1 - if(ne2.eq.1)nout=nout+3 - if(ne4.eq.1)nout=nout+1 - if(ne6.eq.1)nout=nout+1 - call num2string(nout,a1,1) - myformat(2:2)=a1 - nlength=nprecision+7 - call num2string(nlength,a2,2) - myformat(10:11)=a2 - call num2string(nprecision,a2,2) - myformat(13:14)=a2 -c write results - if(ne2.eq.1.and.ne4.eq.0.and.ne6.eq.0)then -c 2d only - write(nfile,myformat)z,epsX,epsY,epsT - else if(ne2.eq.0.and.ne4.eq.1.and.ne6.eq.0)then -c 4d only - write(nfile,myformat)z,epsXYth - else if(ne2.eq.0.and.ne4.eq.0.and.ne6.eq.1)then -c 6d only - write(nfile,myformat)z,epsXYTth - else if(ne2.eq.1.and.ne4.eq.1.and.ne6.eq.0)then -c 2d and 4d - write(nfile,myformat)z,epsX,epsY,epsT,epsXYth - else if(ne2.eq.1.and.ne4.eq.0.and.ne6.eq.1)then -c 2d and 6d - write(nfile,myformat)z,epsX,epsY,epsT,epsXYTth - else if(ne2.eq.0.and.ne4.eq.1.and.ne6.eq.1)then -c 4d and 6d - write(nfile,myformat)z,epsXYth,epsXYTth - else -c 2d and 4d and 6d - write(nfile,myformat)z,epsX,epsY,epsT,epsXYth,epsXYTth - endif - endif -! - call increment_timer('moments',1) - return - end -! -! - subroutine writemaxsize(sarclen,nfile1,nfile2,nfile3,nfile4, & - & nprecision) -cryne 8/11/2001 routine to print min/max beam size -cryne various mods on 11/26/03 - use beamdata - use rays - include 'impli.inc' - integer :: nfile1,nfile2,nfile3,nfile4,nprecision - real*8 sarclen - logical msk - dimension msk(nraysp) - dimension mloca(1),diag(16),rdiag(16) -! - character*16 :: myformat='(6(1x,1pe12.5 ))' - character*2 :: a2 - if(idproc.eq.0)then -!---format: - nlength=nprecision+7 - call num2string(nlength,a2,2) - myformat(10:11)=a2 - call num2string(nprecision,a2,2) - myformat(13:14)=a2 - endif - -! -! if(idproc.eq.0)write(6,*)'inside routine printmaxsize' - msk(1:nraysp)=.true. - do j=1,nraysp - if(istat(j).ne.0)msk(j)=.false. - enddo -! -!------------ min/max quantities1:nrays---------------- -! pxmax=maxval(abs(zblock(2,1:nrays)))/gambet*econ -! pymax=maxval(abs(zblock(4,1:nrays)))/gambet*econ -! minvals and maxvals: - diag(1)=maxval(zblock(1,1:nraysp)) - diag(2)=maxval(zblock(2,1:nraysp)) - diag(3)=maxval(zblock(3,1:nraysp)) - diag(4)=maxval(zblock(4,1:nraysp)) - diag(5)=maxval(zblock(5,1:nraysp)) - diag(6)=maxval(zblock(6,1:nraysp)) - diag(7)=-minval(zblock(1,1:nraysp)) - diag(8)=-minval(zblock(2,1:nraysp)) - diag(9)=-minval(zblock(3,1:nraysp)) - diag(10)=-minval(zblock(4,1:nraysp)) - diag(11)=-minval(zblock(5,1:nraysp)) - diag(12)=-minval(zblock(6,1:nraysp)) - call MPI_ALLREDUCE(diag,rdiag,12,mreal,mpimax,lworld,ierror) - clyte=299792458.d0 - xl=sl - xk=1./xl - z=sarclen - econ=1.0 - wld=omegascl*xl*p0sc - xmax=rdiag(1)*xl - pxmax=rdiag(2)*p0sc - ymax=rdiag(3)*xl - pymax=rdiag(4)*p0sc - tmax=rdiag(5)/omegascl - ptmax=rdiag(6)*wld -! zmax=rdiag(5)*beta/xk - zmax=rdiag(5)*beta*clyte/omegascl - emax=rdiag(6)/(gamma**3*beta**2)*econ - xmin=-rdiag(7)*xl - pxmin=-rdiag(8)*p0sc - ymin=-rdiag(9)*xl - pymin=-rdiag(10)*p0sc - tmin=-rdiag(11)/omegascl - ptmin=-rdiag(12)*wld -! zmin=-rdiag(11)*beta/xk - zmin=-rdiag(11)*beta*clyte/omegascl - emin=-rdiag(12)/(gamma**3*beta**2)*econ -! location of min/max -! diag(15)=diag(8) -! diag(13)=diag(7) -! diag(11)=diag(6) -! diag(9)=diag(5) -! diag(7)=diag(4) -! diag(5)=diag(3) -! diag(3)=diag(2) -! x min/max1:nrays -! mloca=maxloc(zblock(1,1:nraysp)) -! diag(2)=mloca(1)+maxrayp*idproc -! mloca=maxloc(zblock(3,1:nraysp)) -! diag(4)=mloca(1)+maxrayp*idproc -! mloca=maxloc(zblock(5,1:nraysp)) -! diag(6)=mloca(1)+maxrayp*idproc -! mloca=maxloc(zblock(6,1:nraysp)) -! diag(8)=mloca(1)+maxrayp*idproc -! mloca=minloc(zblock(1,1:nraysp)) -! diag(10)=mloca(1)+maxrayp*idproc -! mloca=minloc(zblock(3,1:nraysp)) -! diag(12)=mloca(1)+maxrayp*idproc -! mloca=minloc(zblock(5,1:nraysp)) -! diag(14)=mloca(1)+maxrayp*idproc -! mloca=minloc(zblock(6,1:nraysp)) -! diag(16)=mloca(1)+maxrayp*idproc -! call MPI_ALLREDUCE(diag,rdiag,8,m2real,mpimaxloc,lworld,ierror) -! maxpcl1=rdiag(2) -! maxpcl3=rdiag(4) -! maxpcl5=rdiag(6) -! maxpcl6=rdiag(8) -! minpcl1=rdiag(10) -! minpcl3=rdiag(12) -! minpcl5=rdiag(14) -! minpcl6=rdiag(16) - if(idproc.eq.0)then - write(nfile1,myformat)z,xmin,xmax,pxmin,pxmax - write(nfile2,myformat)z,ymin,ymax,pymin,pymax - write(nfile3,myformat)z,tmin,tmax,ptmin,ptmax - write(nfile4,myformat)z,zmin,zmax,emin,emax -!!! write(nfile4,myformat)z,gamma*zmin,gamma*zmax,minpcl5,maxpcl5 -! call myflush(nfile1) -! call myflush(nfile2) -! call myflush(nfile3) -! call myflush(nfile4) - endif - return - end -! - subroutine profile1d(ncol,nbins,rwall,sarclen,nfile,fname, & - & nprecision) - use beamdata - use rays - use lieaparam, only : monoms - use ml_timer - include 'impli.inc' - include 'map.inc' - real*8, dimension(nbins) :: rho1d,rhotmp - real*8, dimension(2) :: bndy,rbndy - character*16 fname - call increment_timer('profile1d',0) -! write(6,*)'PE#',idproc,' is in profile1d w/ nraysp=',nraysp -! - if(idproc.eq.0)then -! write(6,*)'s= ',sarclen,';writing 1D profile on file ',fname - endif - if(rwall.gt.0.d0)then - xmin=-rwall - xmax=+rwall - else -! determine the range from the particle coords: - bndy(1)= maxval(zblock(ncol,:)) - bndy(2)=-minval(zblock(ncol,:)) - call MPI_ALLREDUCE(bndy,rbndy,2,mreal,mpimax,lworld,ierr) - xmax=rbndy(1) - xmin=-rbndy(2) -!DO express in physical units (i.e. meters): - xmin=xmin*sl - xmax=xmax*sl -! write(6,1122)sl -!1122 format(1x,'sl=',d21.14) -! a little bigger to make sure nothing falls off the end: - xmin=xmin*(1.d0+1.d-8) - xmax=xmax*(1.d0+1.d-8) - endif -! write(6,*)'inside profile1d w/ min,max=',xmin,xmax -! note that nbins is REALLY the number of grid points, not bins: - hx=(xmax-xmin)/(nbins-1) - hxi=1.d0/hx - rho1d=0.d0 - do n=1,nraysp - indx=(zblock(ncol,n)*sl-xmin)*hxi + 1 - if(indx.lt.1 .or. indx.gt.nbins-1)then -! write(6,*)'particle #',n,' is out of range; indx=',indx -! write(6,*)'zblock(' ,ncol, ',' ,n, ')=' ,zblock(ncol,n) - cycle - endif - ab=((xmin-zblock(ncol,n)*sl)+indx*hx)*hxi - rho1d(indx)=rho1d(indx)+ab - rho1d(indx+1)=rho1d(indx+1)+(1.d0-ab) - enddo -! -!------------------------------------------- -! now that every processor has its own 1d profile, sum them together -! on processor 0: - if(idproc.eq.0)then - do l=1,nvp-1 - call MPI_RECV(rhotmp,nbins,mreal,l,95,lworld,mpistat,ierr) -! write(6,*)'PE#0 has received rhotmp data from proc# ',l - rho1d(:)=rho1d(:)+rhotmp(:) - enddo - else - call MPI_SEND(rho1d,nbins,mreal,0,95,lworld,ierr) -! write(6,*)'PE#',idproc,' has sent is rho1d data.' - endif -!------------------------------------------- -! - if(idproc.eq.0)then - do n=1,nbins - xval=xmin+(n-1)*hx -! write(nfile,999,err=1001)xval,rho1d(n),arclen - write(nfile,999)xval,rho1d(n) - enddo - 999 format(3(1pe14.7,1x)) - total=sum(rho1d) - write(6,*)'s= ',sarclen,' ;total deposited=',total, & - & '; 1D profile to file ',fname - call increment_timer('profile1d',1) - return - 1001 write(6,*)'PE 0: TROUBLE WITH WRITE STMT IN PROFILE1D' - return - endif - call increment_timer('profile1d',1) -! write(6,*)'PE# ',idproc,' is returning from profile1d' - return - end -! - subroutine profilerad(ncol,nbins,rwall,sarclen,nfile,fname, & - & nprecision) - use beamdata - use rays - use lieaparam, only : monoms - use ml_timer - include 'impli.inc' - include 'map.inc' - real*8, dimension(nbins) :: rho1d,rhotmp,rhotest - real*8, dimension(2) :: bndy,rbndy - real*8, dimension(nraysp) :: radii - character*16 fname - call increment_timer('profile1d',0) -! write(6,*)'PE#',idproc,' is in profile1d w/ nraysp=',nraysp -! - if(idproc.eq.0)then - write(6,*)'s= ',sarclen,';writing radial profile on file ',fname - endif - clyte=299792458.d0 - t2z=beta*clyte/omegascl - do n=1,nraysp - radii(n)=sqrt( & - & (sl*zblock(1,n))**2+(sl*zblock(3,n))**2+(t2z*zblock(5,n))**2 ) - enddo - if(rwall.gt.0.d0)then - xmin=0.d0 - xmax=+rwall - else -! determine the range from the particle coords: - bndy(1)=maxval(radii(1:nraysp)) - bndy(2)=0.d0 - if(idproc.eq.0)then - write(6,*)'ready to call MPI_ALLREDUCE' - endif - call MPI_ALLREDUCE(bndy,rbndy,2,mreal,mpimax,lworld,ierr) - if(idproc.eq.0)then - write(6,*)'returned from MPI_ALLREDUCE' - endif - xmax=rbndy(1) - xmin=0.d0 -!DO express in physical units (i.e. meters): -! xmin=xmin*sl -! xmax=xmax*sl -! write(6,1122)sl -!1122 format(1x,'sl=',d21.14) -! a little bigger to make sure nothing falls off the end: -!!!!!!!!xmin=xmin*(1.d0+1.d-8) - xmax=xmax*(1.d0+1.d-8) - endif -! write(6,*)'inside profilerad w/ min,max=',xmin,xmax -! (old comment) note that nbins is REALLY the number of grid points, not bins. -! ABOVE COMMENT IS WRONG: in this routine nbins really IS the # of bins -!!!!!!hx=(xmax-xmin)/(nbins-1) - hx=xmax/nbins - hxi=1.d0/hx - bcon=hx*8.*asin(1.d0)*nbins - rho1d=0.d0 -!cryne This routine is a hacked version of the 1d histogram routine. -!cryne As such, its treatment of the value at r=0 is fishy, since I -!cryne will end up dividing by the radial values. - do n=1,nraysp - indx=(radii(n)-xmin)*hxi + 1 - if(indx.lt.1 .or. indx.gt.nbins)then -! if(indx.lt.1 .or. indx.gt.nbins-1)then !applies for linear weighting??? -! write(6,*)'particle #',n,' is out of range; indx=',indx -! write(6,*)'zblock(' ,ncol, ',' ,n, ')=' ,zblock(ncol,n) - if(rwall.gt.0.d0)then - cycle - else - write(6,*)'TROUBLE IN PROFILERAD, PE=',idproc - write(6,*)'xmin,xmax=',xmin,xmax - write(6,*)'n,radii(n)=',n,radii(n) - write(6,*)'indx=',indx - call myexit - endif - endif -!nearest grid point: -! rho1d(indx)=rho1d(indx)+(radii(n))**2 -!! rho1d(indx)=rho1d(indx)+(hx*(n-1))**2 -!!! rho1d(indx)=rho1d(indx)+(hx*(n-1)+0.5*hx)**2 - rho1d(indx)=rho1d(indx)+1.d0 -!linear weighting: -! ab=((xmin-radii(n))+indx*hx)*hxi -! rho1d(indx)=rho1d(indx)+ab -! rho1d(indx+1)=rho1d(indx+1)+(1.d0-ab) - enddo -! -!------------------------------------------- -! now that every processor has its own 1d profile, sum them together -! on processor 0: - if(idproc.eq.0)then - do l=1,nvp-1 - call MPI_RECV(rhotmp,nbins,mreal,l,95,lworld,mpistat,ierr) -! write(6,*)'PE#0 has received rhotmp data from proc# ',l - rho1d(:)=rho1d(:)+rhotmp(:) - enddo - else - call MPI_SEND(rho1d,nbins,mreal,0,95,lworld,ierr) -! write(6,*)'PE#',idproc,' has sent is rho1d data.' - endif -!------------------------------------------- - if(idproc.eq.0)then - write(6,*)'done with SEND and RECV' - endif -! -!cryne Here is the code for dealing the the radial values; -!cryne For now, I simply use the radial value at the bin center: -!cryne (Also, use rhotmp to hold the unscaled values) -!cryne (Also, use rhotest to scale by the radial value at the bin edge) - do n=1,nbins - rhotmp(n)=rho1d(n) - redge=hx*(n-1) - rcent=hx*(n-1)+0.5*hx - rho1d(n)=rho1d(n)/(bcon*rcent**2) - if(n.eq.1)rhotest(n)=0.d0 - if(n.ne.1)rhotest(n)=rhotmp(n)/(bcon*redge**2) - enddo - if(idproc.eq.0)then - write(6,*)'done computing rval and recomputing rho1d' - endif -! - if(idproc.eq.0)then - do n=1,nbins - xedge=xmin+(n-1)*hx - xcent=xmin+(n-1)*hx+0.5*hx -! write(nfile,999,err=1001)xcent,rho1d(n),arclen - write(nfile,999)xcent,rho1d(n),xedge,rhotest(n),rhotmp(n) - enddo - 999 format(5(1pe14.7,1x)) - total=sum(rho1d) - write(6,*)'Comment from Ryne: the following is not correct' - write(6,*)'for the radial histogram calculation. Fix later.' - write(6,*)'s= ',sarclen,' ;total deposited=',total, & - & '; 1D profile to file ',fname - call increment_timer('profile1d',1) - return - 1001 write(6,*)'PE 0: TROUBLE WITH WRITE STMT IN PROFILE1D' - return - endif - call increment_timer('profile1d',1) -! write(6,*)'PE# ',idproc,' is returning from profile1d' - return - end -! - subroutine writeenv2d(sarclen,nfile1,nfile2,nfile3, & - & nprecision,nunits,ncorr) -cryne routine to print 2nd moments obtained from env array - use parallel, only: idproc - use beamdata - include 'impli.inc' - include 'usrdat.inc' - integer :: nfile1,nfile2,nfile3,nprecision,nunits - real*8 sarclen - common/envdata/env(6),envold(6),emap(6,6) - common/emitdata/emxn2,emyn2,emtn2 -! - character*16 :: myformat='(6(1x,1pe12.5 ))' - character*2 :: a2 - - if(idproc.eq.0)then -!---format: - nlength=nprecision+7 - call num2string(nlength,a2,2) - myformat(10:11)=a2 - call num2string(nprecision,a2,2) - myformat(13:14)=a2 - endif -! - xl=sl - xk=1./xl - xlp0=xl*p0sc - xlp1=xlp0 - gambet=gamma*beta - clyte=299792458.d0 - wld=omegascl*xl*p0sc - z=sarclen -! - xrms=env(1) - xpx=env(2)*xrms - pxrms=0.d0 - if(xrms.ne.0.d0)pxrms=sqrt(emxn2+xpx**2)/xrms - epsx=sqrt(emxn2) -! - yrms=env(3) - ypy=env(4)*yrms - pyrms=0.d0 - if(yrms.ne.0.d0)pyrms=sqrt(emyn2+ypy**2)/yrms - epsy=sqrt(emyn2) -! - trms=env(5) - tpt=env(6)*trms - ptrms=0.d0 - if(trms.ne.0.d0)ptrms=sqrt(emtn2+tpt**2)/trms - epst=sqrt(emtn2) - if(ncorr.eq.1)then - xpxfac=0. - ypyfac=0. - tptfac=0. - if(xrms.ne.0. .and. pxrms.ne.0.)xpxfac=1./(xrms*pxrms) - if(yrms.ne.0. .and. pyrms.ne.0.)ypyfac=1./(yrms*pyrms) - if(trms.ne.0. .and. ptrms.ne.0.)tptfac=1./(trms*ptrms) - xpx=xpx*xpxfac - ypy=ypy*ypyfac - tpt=tpt*tptfac - xlp1=1.d0 - endif - if(idproc.eq.0)then - if(nunits.eq.0)then - write(nfile1,myformat)z,xrms,pxrms,xpx,epsx - write(nfile2,myformat)z,yrms,pyrms,ypy,epsy - else - write(nfile1,myformat)z,xrms*xl,pxrms*p0sc,xpx*xlp1,epsx*xlp0 - write(nfile2,myformat)z,yrms*xl,pyrms*p0sc,ypy*xlp1,epsy*xlp0 - endif - endif - ucalc(31)=xrms - ucalc(32)=pxrms - ucalc(33)=xpx - ucalc(34)=yrms - ucalc(35)=pyrms - ucalc(36)=ypy -! -! 3D (t-pt 2nd moments) - if(idproc.eq.0)then - if(nunits.eq.0)then - write(nfile3,myformat)z,trms,ptrms,tpt,epst - else - write(nfile3,myformat)z, & - & trms*beta*clyte/omegascl,ptrms*wld,tpt*xlp1,epst*xlp0 - endif - endif - ucalc(37)=trms - ucalc(38)=ptrms - ucalc(39)=tpt - return - end -! diff --git a/OpticsJan2020/MLI_light_optics/Src/dist.f b/OpticsJan2020/MLI_light_optics/Src/dist.f deleted file mode 100755 index 7a1606f..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/dist.f +++ /dev/null @@ -1,2255 +0,0 @@ -******************************************************************************* -* header: DIST * -* A collection of programs for generating, modifying, and * -* evaluating particle distributions * -******************************************************************************* - subroutine bgen(p,fa,fm) -c -c subroutine corresponding to the type code bgen -c written by Alex Dragt 6/14/91 -c modified 10/14/98 AJD -c modified by RDR on 7/28/2002. The quantity "nray" which is a dummy -c argument to several routines could be eliminated, in which case -c it should be replaced by nraysp in the body of the routines. -c I have left it in place in order to minimize changes to these routines. -c Note that, except for this routine (bgen), the variable "nrays" -c should not appear anywhere, since it is the global # of particles, -c and the remaining routines all use the local number, nraysp, which is -c passed in the argument lists and corresponds to "nray" in the routines. -c -c - use lieaparam, only : monoms - use rays - include 'impli.inc' - include 'buffer.inc' - include 'files.inc' - include 'parset.inc' -c -c calling arrays - dimension p(*) - dimension fa(*), fm(6,6) -c -c working arrays -c use buf1 and buf2: put numerical moments in buf1 and analytic -c moments in buf2 -c use buf3 as working space to store desired eigen moments -c -c set up control indices -c - job=nint(p(1)) - iopt=nint(p(2)) - nrays=nint(p(3)) - iseed=nint(p(4)) - isend=nint(p(5)) - ipset=nint(p(6)) -c -c read contents of pset ipset -c - if(ipset.ne.0)then - x2mom=pst(1,ipset) - y2mom=pst(2,ipset) - t2mom=pst(3,ipset) - if (x2mom .lt. 0.) then -c get eigenmoments from current map - x2mom=fa(7) - y2mom=fa(18) - t2mom=fa(25) - endif - sigmax=pst(4,ipset) - nof1=nint(pst(5,ipset)) - nof2=nint(pst(6,ipset)) - else - x2mom=p(7) - y2mom=p(8) - t2mom=p(9) - if (x2mom .lt. 0.) then -c get eigenmoments from current map - x2mom=fa(7) - y2mom=fa(18) - t2mom=fa(25) - endif - sigmax=p(10) - nof1=nint(p(11)) - nof2=nint(p(12)) - endif -c write(6,*)'done setting bgen parameters' -c write(6,*)'job,iopt,nrays=',job,iopt,nrays -c write(6,*)'iseed,isend,ipset=',iseed,isend,ipset -c write(6,*)'x2mom,y2mom,t2mom=',x2mom,y2mom,t2mom -c write(6,*)'sigmax=',sigmax -c write(6,*)'nof1,nof2=',nof1,nof2 -c -c put eigen moments in buf3 -c - call clear(buf3a,buf3m) - buf3a(7)=x2mom - buf3a(13)=x2mom - buf3a(18)=y2mom - buf3a(22)=y2mom - buf3a(25)=t2mom - buf3a(27)=t2mom -c -c select job -c -c compute moments of particle distribution, and write them on -c an external file, the terminal and/or a drop file - if (job .eq. 0) then -c -c if (iopt .ne. 6) then -c -c compute moments of particle distribution - call cmom(buf1a,buf1m) -c write moments on file nof1 - mpt=mpo - mpo=nof1 - if(mpo .gt. 0) call mapout(0,buf1a,buf1m) - mpo=mpt -c -c else -c compute moments of particle distribution including <5> and <6> -c call cmom5(buf1a) -c write moments on file nof1 -c mpt=mpo -c mpo=nof1 -c call mapout5(0,buf1a,buf1m) -c mpo=mpt -c endif -c -c print selected numerical moments at terminal and/or write on drop file - if(isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) ' ' - write(jof,*) - & ' numerically computed values of selected moments' - write(jof,*) ' values of , , :' - write(jof,*) buf1a(7),buf1a(8),buf1a(13) - write(jof,*) ' values of , , :' - write(jof,*) buf1a(18),buf1a(19),buf1a(22) - write(jof,*) ' values of , , :' - write(jof,*) buf1a(25),buf1a(26),buf1a(27) - endif - if(isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) ' ' - write(jodf,*) - & ' numerically computed values of selected moments' - write(jodf,*) ' values of , , :' - write(jodf,*) buf1a(7),buf1a(8),buf1a(13) - write(jodf,*) ' values of , , :' - write(jodf,*) buf1a(18),buf1a(19),buf1a(22) - write(jodf,*) ' values of , , :' - write(jodf,*) buf1a(25),buf1a(26),buf1a(27) - endif - endif -c -c for other values of job generate various distributions -c and/or moments -c -cryne 7/28/2002 -c before particles can be generated, each processor needs to know -c how many it owns: - nraysp=(nrays-1)/nvp + 1 - 1221 continue - if(nraysp*(nvp-1).ge.nrays)then - nraysp=nraysp-1 - if(nraysp.eq.0)then - write(6,*)'trouble: nraysp=0. something wrong. halting.' - endif - goto 1221 - endif -c - if(idproc.eq.nvp-1)nraysp = nrays - nraysp*(nvp-1) -c has the zblock array been allocated? - if(.not.allocated(zblock))then - if(idproc.eq.0)write(6,*)'setting maxray=',nrays,' ;allocating' - maxray=nrays - call new_particledata - endif -c also, need a different seed on every processor: - seedfac=1.+float(idproc)/float(nvp) - iseed=iseed*seedfac -c write(6,*)'idproc,iseed=',idproc,iseed -c warm up the F90 random number generator because it is needed -c to generate big vectors of random numbers: - call f90ranset(iseed) -c -c uniformly filled ellipse or ellipsoids - if (job .eq. 1) then -c set up scaling factors - sx=sqrt(4.d0*x2mom) - sy=0.d0 - st=0.d0 - if(iopt .eq. 1) call re2d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 2) call cmre2d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call re2d(nraysp,iseed,sx,sy,st) - call cmre2d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call re2d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 123) then - call re2d(nraysp,iseed,sx,sy,st) - call cmre2d(buf2a,buf2m,sx,sy,st) - endif - endif -c - if (job .eq. 2) then -c set up scaling factors - sx=sqrt(6.d0*x2mom) - sy=sqrt(6.d0*y2mom) - st=0.d0 - if(iopt .eq. 1) call re4d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 2) call cmre4d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call re4d(nraysp,iseed,sx,sy,st) - call cmre4d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call re4d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 123) then - call re4d(nraysp,iseed,sx,sy,st) - call cmre4d(buf2a,buf2m,sx,sy,st) - endif - endif -c - if (job .eq. 3) then -c set up scaling factors - sx=sqrt(8.d0*x2mom) - sy=sqrt(8.d0*y2mom) - st=sqrt(8.d0*t2mom) - if(iopt .eq. 1) call re6d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 2) call cmre6d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call re6d(nraysp,iseed,sx,sy,st) - call cmre6d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call re6d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 123) then - call re6d(nraysp,iseed,sx,sy,st) - call cmre6d(buf2a,buf2m,sx,sy,st) - endif - endif -c -c gaussian distributions - if (job .eq. 4) then -c set up scaling factors - sx=sqrt(x2mom) - sy=0.d0 - st=0.d0 - if(iopt .eq. 1) call rg2d(nraysp,iseed,sigmax,sx,sy,st) - if(iopt .eq. 2) call cmrg2d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call rg2d(nraysp,iseed,sigmax,sx,sy,st) - call cmrg2d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call rg2d(nraysp,iseed,sigmax,sx,sy,st) - if(iopt .eq. 123) then - call rg2d(nraysp,iseed,sigmax,sx,sy,st) - call cmrg2d(buf2a,buf2m,sx,sy,st) - endif - endif -c - if (job .eq. 5) then -c set up scaling factors - sx=sqrt(x2mom) - sy=sqrt(y2mom) - st=0.d0 - if(iopt .eq. 1) call rg4d(nraysp,iseed,sigmax,sx,sy,st) - if(iopt .eq. 2) call cmrg4d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call rg4d(nraysp,iseed,sigmax,sx,sy,st) - call cmrg4d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call rg4d(nraysp,iseed,sigmax,sx,sy,st) - if(iopt .eq. 123) then - call rg4d(nraysp,iseed,sigmax,sx,sy,st) - call cmrg4d(buf2a,buf2m,sx,sy,st) - endif - endif -c - if (job .eq. 6) then -c set up scaling factors - sx=sqrt(x2mom) - sy=sqrt(y2mom) - st=sqrt(t2mom) - if(iopt .eq. 1) call rg6d(nraysp,iseed,sigmax,sx,sy,st) - if(iopt .eq. 2) call cmrg6d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call rg6d(nraysp,iseed,sigmax,sx,sy,st) - call cmrg6d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call rg6d(nraysp,iseed,sigmax,sx,sy,st) - if(iopt .eq. 123) then - call rg6d(nraysp,iseed,sigmax,sx,sy,st) - call cmrg6d(buf2a,buf2m,sx,sy,st) - endif - endif -c -c systematic uniform tori - if (job .eq. 7) then -c set up scaling factors - sx=sqrt(2.d0*x2mom) - sy=0.d0 - st=0.d0 - if(iopt .eq. 1) call st2d(nraysp,sx,sy,st) - if(iopt .eq. 2) call cmst2d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call st2d(nraysp,sx,sy,st) - call cmst2d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call st2d(nraysp,sx,sy,st) - if(iopt .eq. 123) then - call st2d(nraysp,sx,sy,st) - call cmst2d(buf2a,buf2m,sx,sy,st) - endif - endif -c - if (job .eq. 8) then -c set up scaling factors - sx=sqrt(2.d0*x2mom) - sy=sqrt(2.d0*y2mom) - st=0.d0 - if(iopt .eq. 1) call st4d(nraysp,sx,sy,st) - if(iopt .eq. 2) call cmst4d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call st4d(nraysp,sx,sy,st) - call cmst4d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call st4d(nraysp,sx,sy,st) - if(iopt .eq. 123) then - call st4d(nraysp,sx,sy,st) - call cmst4d(buf2a,buf2m,sx,sy,st) - endif - endif -c - if (job .eq. 9) then -c set up scaling factors - sx=sqrt(2.d0*x2mom) - sy=sqrt(2.d0*y2mom) - st=sqrt(2.d0*t2mom) - if(iopt .eq. 1) call st6d(nraysp,sx,sy,st) - if(iopt .eq. 2) call cmst6d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call st6d(nraysp,sx,sy,st) - call cmst6d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call st6d(nraysp,sx,sy,st) - if(iopt .eq. 123) then - call st6d(nraysp,sx,sy,st) - call cmst6d(buf2a,buf2m,sx,sy,st) - endif - endif -c -c random uniform tori - if (job .eq. 10) then -c set up scaling factors - sx=sqrt(2.d0*x2mom) - sy=0.d0 - st=0.d0 - if(iopt .eq. 1) call rt2d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 2) call cmst2d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call rt2d(nraysp,iseed,sx,sy,st) - call cmst2d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call rt2d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 123) then - call rt2d(nraysp,iseed,sx,sy,st) - call cmst2d(buf2a,buf2m,sx,sy,st) - endif - endif -c - if (job .eq. 11) then -c set up scaling factors - sx=sqrt(2.d0*x2mom) - sy=sqrt(2.d0*y2mom) - st=0.d0 - if(iopt .eq. 1) call rt4d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 2) call cmst4d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call rt4d(nraysp,iseed,sx,sy,st) - call cmst4d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call rt4d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 123) then - call rt4d(nraysp,iseed,sx,sy,st) - call cmst4d(buf2a,buf2m,sx,sy,st) - endif - endif -c - if (job .eq. 12) then -c set up scaling factors - sx=sqrt(2.d0*x2mom) - sy=sqrt(2.d0*y2mom) - st=sqrt(2.d0*t2mom) - if(iopt .eq. 1) call rt6d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 2) call cmst6d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call rt6d(nraysp,iseed,sx,sy,st) - call cmst6d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call rt6d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 123) then - call rt6d(nraysp,iseed,sx,sy,st) - call cmst6d(buf2a,buf2m,sx,sy,st) - endif - endif -c -c KV distribution in 4-D phase space - if (job .eq. 13) then -c set up scaling factors - sx=sqrt(4.d0*x2mom) - sy=sqrt(4.d0*y2mom) - st=0.d0 - if(iopt .eq. 1) call kv4d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 2) call cmkv4d(buf2a,buf2m,sx,sy,st) - if(iopt .eq. 12) then - call kv4d(nraysp,iseed,sx,sy,st) - call cmkv4d(buf2a,buf2m,sx,sy,st) - endif - if(iopt .eq. 13) call kv4d(nraysp,iseed,sx,sy,st) - if(iopt .eq. 123) then - call kv4d(nraysp,iseed,sx,sy,st) - call cmkv4d(buf2a,buf2m,sx,sy,st) - endif - endif -c -c write to files and write selected numerical/analytic moments -c at terminal and/or drop file -c - if (job .ne. 0) then -c - if (iopt .eq. 2 .or. iopt .eq. 12) then -c write analytic moments to an external file and to -c terminal and/or drop file - mpt=mpo - mpo=nof2 - if(mpo .gt. 0) call mapout (0,buf2a,buf2m) - mpo=mpt - if(isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) ' ' - write(jof,*) - & ' analytically computed values of selected moments' - write(jof,*) ' values of , , :' - write(jof,*) buf2a(7),buf2a(8),buf2a(13) - write(jof,*) ' values of , , :' - write(jof,*) buf2a(18),buf2a(19),buf2a(22) - write(jof,*) ' values of , , :' - write(jof,*) buf2a(25),buf2a(26),buf2a(27) - endif - if(isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) ' ' - write(jodf,*) - & ' analytically computed values of selected moments' - write(jodf,*) ' values of , , :' - write(jodf,*) buf2a(7),buf2a(8),buf2a(13) - write(jodf,*) ' values of , , :' - write(jodf,*) buf2a(18),buf2a(19),buf2a(22) - write(jodf,*) ' values of , , :' - write(jodf,*) buf2a(25),buf2a(26),buf2a(27) - endif - endif -c -c compute numerical moments and write numerical moments to -c an external file and to terminal and/or drop file - if (iopt .eq. 13) then - call cmom(buf1a,buf1m) - mpt=mpo - mpo=nof1 - if(mpo .gt. 0) call mapout(0,buf1a,buf1m) - mpo=mpt - if(isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) ' ' - write(jof,*) - & ' numerically computed values of selected moments' - write(jof,*) ' values of , , :' - write(jof,*) buf1a(7),buf1a(8),buf1a(13) - write(jof,*) ' values of , , :' - write(jof,*) buf1a(18),buf1a(19),buf1a(22) - write(jof,*) ' values of , , :' - write(jof,*) buf1a(25),buf1a(26),buf1a(27) - endif - if(isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) ' ' - write(jodf,*) - & ' numerically computed values of selected moments' - write(jodf,*) ' values of , , :' - write(jodf,*) buf1a(7),buf1a(8),buf1a(13) - write(jodf,*) ' values of , , :' - write(jodf,*) buf1a(18),buf1a(19),buf1a(22) - write(jodf,*) ' values of , , :' - write(jodf,*) buf1a(25),buf1a(26),buf1a(27) - endif - endif -c -c compute numerical moments and write numerical and analytic -c moments to external files and to terminal and/or drop file - if (iopt .eq. 123) then - call cmom(buf1a,buf1m) - mpt=mpo - mpo=nof1 - if(mpo .gt. 0) call mapout(0,buf1a,buf1m) - mpo=nof2 - if(mpo .gt. 0) call mapout(0,buf2a,buf2m) - mpo=mpt - if(isend .eq. 1 .or. isend .eq. 3) then - write(jof,*) ' ' - write(jof,*) - & ' numerically computed values of selected moments' - write(jof,*) ' values of , , :' - write(jof,*) buf1a(7),buf1a(8),buf1a(13) - write(jof,*) ' values of , , :' - write(jof,*) buf1a(18),buf1a(19),buf1a(22) - write(jof,*) ' values of , , :' - write(jof,*) buf1a(25),buf1a(26),buf1a(27) - write(jof,*) ' ' - write(jof,*) - & ' analytically computed values of selected moments' - write(jof,*) ' values of , , :' - write(jof,*) buf2a(7),buf2a(8),buf2a(13) - write(jof,*) ' values of , , :' - write(jof,*) buf2a(18),buf2a(19),buf2a(22) - write(jof,*) ' values of , , :' - write(jof,*) buf2a(25),buf2a(26),buf2a(27) - endif - if(isend .eq. 2 .or. isend .eq. 3) then - write(jodf,*) ' ' - write(jodf,*) - & ' numerically computed values of selected moments' - write(jodf,*) ' values of , , :' - write(jodf,*) buf1a(7),buf1a(8),buf1a(13) - write(jodf,*) ' values of , , :' - write(jodf,*) buf1a(18),buf1a(19),buf1a(22) - write(jodf,*) ' values of , , :' - write(jodf,*) buf1a(25),buf1a(26),buf1a(27) - write(jodf,*) ' ' - write(jodf,*) - & ' analytically computed values of selected moments' - write(jodf,*) ' values of , , :' - write(jodf,*) buf2a(7),buf2a(8),buf2a(13) - write(jodf,*) ' values of , , :' - write(jodf,*) buf2a(18),buf2a(19),buf2a(22) - write(jodf,*) ' values of , , :' - write(jodf,*) buf2a(25),buf2a(26),buf2a(27) - endif - endif -c - endif -c - return - end -c -******************************************************************************** -c - subroutine cmre2d(fa,fm,sx,sy,st) -c subroutine to compute analytic moments of a 2D random -c uniform distribution that fills a 2D ellipse in phase space -c written by Alex Dragt 7/15/91 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms), fm(6,6) -c -c procedure -c -c clear array - do 10 i=1,monoms - 10 fa(i)=0.d0 -c compute squares - sx2=sx*sx -c compute nonzero moments -c quadratic moments - fa(7)=sx2/4.d0 - fa(13)=sx2/4.d0 -c matrix of moments - call mclear(fm) - fm(1,1)=fa(7) - fm(2,2)=fa(13) -c quartic moments - fa(84)=sx2*sx2*(1.d0/8.d0) - fa(90)=sx2*sx2*(1.d0/24.d0) - fa(140)=sx2*sx2*(1.d0/8.d0) -c - return - end -c -******************************************************************************** -c - subroutine cmre4d(fa,fm,sx,sy,st) -c subroutine to compute analytic moments of a 4D random -c uniform distribution that fills a 4D ellipsoid in phase space -c written by Alex Dragt 7/15/91 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms),fm(6,6) -c -c procedure -c -c clear array - do 10 i=1,monoms - 10 fa(i)=0.d0 -c compute squares - sx2=sx*sx - sy2=sy*sy -c compute nonzero moments -c quadratic moments - fa(7)=sx2/6.d0 - fa(13)=sx2/6.d0 - fa(18)=sy2/6.d0 - fa(22)=sy2/6.d0 -c matrix of moments - call mclear(fm) - fm(1,1)=fa(7) - fm(2,2)=fa(13) - fm(3,3)=fa(18) - fm(4,4)=fa(22) -c quartic moments - fa(84)=sx2*sx2*(1.d0/16.d0) - fa(90)=sx2*sx2*(1.d0/48.d0) - fa(95)=sx2*sy2*(1.d0/48.d0) - fa(99)=sx2*sy2*(1.d0/48.d0) - fa(140)=sx2*sx2*(1.d0/16.d0) - fa(145)=sx2*sy2*(1.d0/48.d0) - fa(149)=sx2*sy2*(1.d0/48.d0) - fa(175)=sy2*sy2*(1.d0/16.d0) - fa(179)=sy2*sy2*(1.d0/48.d0) - fa(195)=sy2*sy2*(1.d0/16.d0) -c - return - end -c -******************************************************************************** -c - subroutine cmre6d(fa,fm,sx,sy,st) -c subroutine to compute analytic moments of a 6D random -c uniform distribution that fills a 6D ellipsoid in phase space -c written by Alex Dragt 7/15/91 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms),fm(6,6) -c -c procedure -c -c clear array - do 10 i=1,monoms - 10 fa(i)=0.d0 -c compute squares - sx2=sx*sx - sy2=sy*sy - st2=st*st -c compute nonzero moments -c quadratic moments - fa(7)=sx2/8.d0 - fa(13)=sx2/8.d0 - fa(18)=sy2/8.d0 - fa(22)=sy2/8.d0 - fa(25)=st2/8.d0 - fa(27)=st2/8.d0 -c matrix of moments - call mclear(fm) - fm(1,1)=fa(7) - fm(2,2)=fa(13) - fm(3,3)=fa(18) - fm(4,4)=fa(22) - fm(5,5)=fa(25) - fm(6,6)=fa(27) -c quartic moments - fa(84)=sx2*sx2*(3.d0/80.d0) - fa(90)=sx2*sx2*(1.d0/80.d0) - fa(95)=sx2*sy2*(1.d0/80.d0) - fa(99)=sx2*sy2*(1.d0/80.d0) - fa(102)=sx2*st2*(1.d0/80.d0) - fa(104)=sx2*st2*(1.d0/80.d0) - fa(140)=sx2*sx2*(3.d0/80.d0) - fa(145)=sx2*sy2*(1.d0/80.d0) - fa(149)=sx2*sy2*(1.d0/80.d0) - fa(152)=sx2*st2*(1.d0/80.d0) - fa(154)=sx2*st2*(1.d0/80.d0) - fa(175)=sy2*sy2*(3.d0/80.d0) - fa(179)=sy2*sy2*(1.d0/80.d0) - fa(182)=sy2*st2*(1.d0/80.d0) - fa(184)=sy2*st2*(1.d0/80.d0) - fa(195)=sy2*sy2*(3.d0/80.d0) - fa(198)=sy2*st2*(1.d0/80.d0) - fa(200)=sy2*st2*(1.d0/80.d0) - fa(205)=st2*st2*(3.d0/80.d0) - fa(207)=st2*st2*(1.d0/80.d0) - fa(209)=st2*st2*(3.d0/80.d0) -c - return - end -c -******************************************************************************** -c - subroutine cmrg2d(fa,fm,sx,sy,st) -c subroutine to compute analytic moments of a 2D random -c gaussian distribution -c written by Alex Dragt 7/15/91 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms),fm(6,6) -c -c procedure -c -c clear array - do 10 i=1,monoms - 10 fa(i)=0.d0 -c compute squares - sx2=sx*sx -c compute nonzero moments -c quadratic moments - fa(7)=sx2 - fa(13)=sx2 -c matrix of moments - call mclear(fm) - fm(1,1)=fa(7) - fm(2,2)=fa(13) -c quartic moments - fa(84)=sx2*sx2*(3.d0) - fa(90)=sx2*sx2 - fa(140)=sx2*sx2*(3.d0) -c - return - end -c -******************************************************************************** -c - subroutine cmrg4d(fa,fm,sx,sy,st) -c subroutine to compute analytic moments of a 4D random -c gaussian distribution -c written by Alex Dragt 7/15/91 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms),fm(6,6) -c -c procedure -c -c clear array - do 10 i=1,monoms - 10 fa(i)=0.d0 -c compute squares - sx2=sx*sx - sy2=sy*sy -c compute nonzero moments -c quadratic moments - fa(7)=sx2 - fa(13)=sx2 - fa(18)=sy2 - fa(22)=sy2 -c matrix of moments - call mclear(fm) - fm(1,1)=fa(7) - fm(2,2)=fa(13) - fm(3,3)=fa(18) - fm(4,4)=fa(22) -c quartic moments - fa(84)=sx2*sx2*(3.d0) - fa(90)=sx2*sx2 - fa(95)=sx2*sy2 - fa(99)=sx2*sy2 - fa(140)=sx2*sx2*(3.d0) - fa(145)=sx2*sy2 - fa(149)=sx2*sy2 - fa(175)=sy2*sy2*(3.d0) - fa(179)=sy2*sy2 - fa(195)=sy2*sy2*(3.d0) -c - return - end -c -******************************************************************************** -c - subroutine cmrg6d(fa,fm,sx,sy,st) -c subroutine to compute analytic moments of a 6D random -c gaussian distribution -c written by Alex Dragt 7/15/91 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms),fm(6,6) -c -c procedure -c -c clear array - do 10 i=1,monoms - 10 fa(i)=0.d0 -c compute squares - sx2=sx*sx - sy2=sy*sy - st2=st*st -c compute nonzero moments -c quadratic moments - fa(7)=sx2 - fa(13)=sx2 - fa(18)=sy2 - fa(22)=sy2 - fa(25)=st2 - fa(27)=st2 -c matrix of moments - call mclear(fm) - fm(1,1)=fa(7) - fm(2,2)=fa(13) - fm(3,3)=fa(18) - fm(4,4)=fa(22) - fm(5,5)=fa(25) - fm(6,6)=fa(27) -c quartic moments - fa(84)=sx2*sx2*(3.d0) - fa(90)=sx2*sx2 - fa(95)=sx2*sy2 - fa(99)=sx2*sy2 - fa(102)=sx2*st2 - fa(104)=sx2*st2 - fa(140)=sx2*sx2*(3.d0) - fa(145)=sx2*sy2 - fa(149)=sx2*sy2 - fa(152)=sx2*st2 - fa(154)=sx2*st2 - fa(175)=sy2*sy2*(3.d0) - fa(179)=sy2*sy2 - fa(182)=sy2*st2 - fa(184)=sy2*st2 - fa(195)=sy2*sy2*(3.d0) - fa(198)=sy2*st2 - fa(200)=sy2*st2 - fa(205)=st2*st2*(3.d0) - fa(207)=st2*st2 - fa(209)=st2*st2*(3.d0) -c - return - end -c -******************************************************************************** -c - subroutine cmst2d(fa,fm,sx,sy,st) -c subroutine to compute analytic moments of a 2D systematic -c distribution on a torus -c written by Alex Dragt 7/15/91 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms),fm(6,6) -c -c procedure -c -c clear array - do 10 i=1,monoms - 10 fa(i)=0.d0 -c compute squares - sx2=sx*sx -c compute nonzero moments -c quadratic moments - fa(7)=sx2/2.d0 - fa(13)=sx2/2.d0 -c matrix of moments - call mclear(fm) - fm(1,1)=fa(7) - fm(2,2)=fa(13) -c quartic moments - fa(84)=sx2*sx2*(3.d0/8.d0) - fa(90)=sx2*sx2*(1.d0/8.d0) - fa(140)=sx2*sx2*(3.d0/8.d0) -c - return - end -c -******************************************************************************** -c - subroutine cmst4d(fa,fm,sx,sy,st) -c subroutine to compute analytic moments of a 4D systematic -c distribution on a torus -c written by Alex Dragt 7/15/91 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms),fm(6,6) -c -c procedure -c -c clear array - do 10 i=1,monoms - 10 fa(i)=0.d0 -c compute squares - sx2=sx*sx - sy2=sy*sy -c compute nonzero moments -c quadratic moments - fa(7)=sx2/2.d0 - fa(13)=sx2/2.d0 - fa(18)=sy2/2.d0 - fa(22)=sy2/2.d0 -c matrix of moments - call mclear(fm) - fm(1,1)=fa(7) - fm(2,2)=fa(13) - fm(3,3)=fa(18) - fm(4,4)=fa(22) -c quartic moments - fa(84)=sx2*sx2*(3.d0/8.d0) - fa(90)=sx2*sx2*(1.d0/8.d0) - fa(95)=sx2*sy2*(1.d0/4.d0) - fa(99)=sx2*sy2*(1.d0/4.d0) - fa(140)=sx2*sx2*(3.d0/8.d0) - fa(145)=sx2*sy2*(1.d0/4.d0) - fa(149)=sx2*sy2*(1.d0/4.d0) - fa(175)=sy2*sy2*(3.d0/8.d0) - fa(179)=sy2*sy2*(1.d0/8.d0) - fa(195)=sy2*sy2*(3.d0/8.d0) -c - return - end -c -******************************************************************************** -c - subroutine cmst6d(fa,fm,sx,sy,st) -c subroutine to compute analytic moments of a 6D systematic -c distribution on a torus -c written by Alex Dragt 7/15/91 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms),fm(6,6) -c -c procedure -c -c clear array - do 10 i=1,monoms - 10 fa(i)=0.d0 -c compute squares - sx2=sx*sx - sy2=sy*sy - st2=st*st -c compute nonzero moments -c quadratic moments - fa(7)=sx2/2.d0 - fa(13)=sx2/2.d0 - fa(18)=sy2/2.d0 - fa(22)=sy2/2.d0 - fa(25)=st2/2.d0 - fa(27)=st2/2.d0 -c matrix of moments - call mclear(fm) - fm(1,1)=fa(7) - fm(2,2)=fa(13) - fm(3,3)=fa(18) - fm(4,4)=fa(22) - fm(5,5)=fa(25) - fm(6,6)=fa(27) -c quartic moments - fa(84)=sx2*sx2*(3.d0/8.d0) - fa(90)=sx2*sx2*(1.d0/8.d0) - fa(95)=sx2*sy2*(1.d0/4.d0) - fa(99)=sx2*sy2*(1.d0/4.d0) - fa(102)=sx2*st2*(1.d0/4.d0) - fa(104)=sx2*st2*(1.d0/4.d0) - fa(140)=sx2*sx2*(3.d0/8.d0) - fa(145)=sx2*sy2*(1.d0/4.d0) - fa(149)=sx2*sy2*(1.d0/4.d0) - fa(152)=sx2*st2*(1.d0/4.d0) - fa(154)=sx2*st2*(1.d0/4.d0) - fa(175)=sy2*sy2*(3.d0/8.d0) - fa(179)=sy2*sy2*(1.d0/8.d0) - fa(182)=sy2*st2*(1.d0/4.d0) - fa(184)=sy2*st2*(1.d0/4.d0) - fa(195)=sy2*sy2*(3.d0/8.d0) - fa(198)=sy2*st2*(1.d0/4.d0) - fa(200)=sy2*st2*(1.d0/4.d0) - fa(205)=st2*st2*(3.d0/8.d0) - fa(207)=st2*st2*(1.d0/8.d0) - fa(209)=st2*st2*(3.d0/8.d0) -c - return - end -c -******************************************************************************** -c - subroutine cmkv4d(fa,fm,sx,sy,st) -c subroutine to compute analytic moments of a 4-variable -c KV distribution -c written by Alex Dragt 7/15/91 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms),fm(6,6) -c -c procedure -c -c clear array - do 10 i=1,monoms - 10 fa(i)=0.d0 -c compute squares - sx2=sx*sx - sy2=sy*sy -c compute nonzero moments -c quadratic moments - fa(7)=sx2/4.d0 - fa(13)=sx2/4.d0 - fa(18)=sy2/4.d0 - fa(22)=sy2/4.d0 -c matrix of moments - call mclear(fm) - fm(1,1)=fa(7) - fm(2,2)=fa(13) - fm(3,3)=fa(18) - fm(4,4)=fa(22) -c quartic moments - fa(84)=sx2*sx2*(1.d0/8.d0) - fa(90)=sx2*sx2*(1.d0/24.d0) - fa(95)=sx2*sy2*(1.d0/24.d0) - fa(99)=sx2*sy2*(1.d0/24.d0) - fa(140)=sx2*sx2*(1.d0/8.d0) - fa(145)=sx2*sy2*(1.d0/24.d0) - fa(149)=sx2*sy2*(1.d0/24.d0) - fa(175)=sy2*sy2*(1.d0/8.d0) - fa(179)=sy2*sy2*(1.d0/24.d0) - fa(195)=sy2*sy2*(1.d0/8.d0) -c - return - end -c -******************************************************************************** -c - subroutine re2d(nray,iseed,sx,sy,st) -c -c subroutine to generate a 2D random uniform distribution that fills -c a 2D ellipse in phase space -c written by Alex Dragt 7/6/91 -c - use rays - include 'impli.inc' - include 'files.inc' -c -c working arrays - dimension z(2) -c -c proceedure -c -c initialize indices and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - call myexit - endif -cryne nrays=nray -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c -c fill zblock -c -c select and warmup random number generator -c - if (iseed .lt. 0) ktype=1 - if (iseed .eq. 0) then - write(jof,*) ' iseed = 0 in bgen call' - call myexit - return - endif - if (iseed .gt. 0) ktype=2 - iseed=-iabs(iseed) - call myrand(ktype,iseed,ans) -c - do 20 j=1,nray -c generate a ray - 5 sumsq=0.d0 - do 10 i=1,2 - call myrand(ktype,iseed,ans) - z(i)=2.d0*ans-1.d0 - 10 sumsq=sumsq+z(i)*z(i) - if(sumsq .gt. 1.d0) goto 5 -c scale and store ray in zblock - zblock(1,j)=sx*z(1) - zblock(2,j)=sx*z(2) - zblock(3,j)=0.d0 - zblock(4,j)=0.d0 - zblock(5,j)=0.d0 - zblock(6,j)=0.d0 - 20 continue - write(6,*) nray, ' rays generated by re2d on PE# ',idproc -c - return - end -c -******************************************************************************** -c - subroutine re4d(nray,iseed,sx,sy,st) -c -c subroutine to generate a 4D random uniform distribution that fills -c a 4D ellipsoid in phase space -c written by Alex Dragt 7/6/91 -c - use rays - include 'impli.inc' - include 'files.inc' -c -c working arrays - dimension z(4) -c -c proceedure -c -c initialize indices and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - call myexit - endif -cryne nrays=nray -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c -c fill zblock -c -c select and warmup random number generator -c - if (iseed .lt. 0) ktype=1 - if (iseed .eq. 0) then - write(jof,*) ' iseed = 0 in bgen call' - call myexit - return - endif - if (iseed .gt. 0) ktype=2 - iseed=-iabs(iseed) - call myrand(ktype,iseed,ans) -c - do 20 j=1,nray -c generate a ray - 5 sumsq=0.d0 - do 10 i=1,4 - call myrand(ktype,iseed,ans) - z(i)=2.d0*ans-1.d0 - 10 sumsq=sumsq+z(i)*z(i) - if(sumsq .gt. 1.d0) goto 5 -c scale and store ray in zblock - zblock(1,j)=sx*z(1) - zblock(2,j)=sx*z(2) - zblock(3,j)=sy*z(3) - zblock(4,j)=sy*z(4) - zblock(5,j)=0.d0 - zblock(6,j)=0.d0 - 20 continue - write(6,*) nray, ' rays generated by re4d on PE# ',idproc -c - return - end -c -******************************************************************************** -c - subroutine re6d(nray,iseed,sx,sy,st) -c -c subroutine to generate a 6D random uniform distribution that fills -c a 6D ellipsoid in phase space -c written by Alex Dragt 7/6/91 -c - use rays - include 'impli.inc' - include 'files.inc' - integer, parameter :: ichunk=10000 -c -c working arrays - dimension z(6),za(6*ichunk) -c -c procedure -c -c initialize indices and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - write(6,*) 'nray=',nray - write(6,*) 'maxrayp=',maxrayp - call myexit - endif -cryne nrays=nray -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c -c fill zblock -c -c select and warmup random number generator -c - if (iseed .lt. 0) ktype=1 - if (iseed .eq. 0) then - write(jof,*) ' iseed = 0 in bgen call' - call myexit - return - endif - if (iseed .gt. 0) ktype=2 - iseed=-iabs(iseed) - call myrand(ktype,iseed,ans) -c -c procedure to generate a small number (~few thousand) of rays: -cryne 1/11/2005 if(nray.gt.5000)goto 23 - if(nray.gt.500000)goto 23 - do 20 j=1,nray -c generate a ray - 5 sumsq=0.d0 - do 10 i=1,6 - call myrand(ktype,iseed,ans) - z(i)=2.d0*ans-1.d0 - 10 sumsq=sumsq+z(i)*z(i) - if(sumsq .gt. 1.d0) goto 5 -c scale and store ray in zblock - zblock(1,j)=sx*z(1) - zblock(2,j)=sx*z(2) - zblock(3,j)=sy*z(3) - zblock(4,j)=sy*z(4) - zblock(5,j)=st*z(5) - zblock(6,j)=st*z(6) - 20 continue - goto 999 -c - 23 continue -c procedure to generate a large number of rays: - j=0 - 24 continue - call random_number(za) - do i=1,6*ichunk-5,6 - sumsq=(2.d0*za(i) -1.d0)**2+(2.d0*za(i+1)-1.d0)**2 & - & +(2.d0*za(i+2)-1.d0)**2+(2.d0*za(i+3)-1.d0)**2 & - & +(2.d0*za(i+4)-1.d0)**2+(2.d0*za(i+5)-1.d0)**2 - if(sumsq .gt. 1.d0)cycle - j=j+1 - if(j.gt.nray)exit -c scale and store ray in zblock - zblock(1,j)=sx*za(i) - zblock(2,j)=sx*za(i+1) - zblock(3,j)=sy*za(i+2) - zblock(4,j)=sy*za(i+3) - zblock(5,j)=st*za(i+4) - zblock(6,j)=st*za(i+5) - enddo - if(j.lt.nray)goto 24 -c - 999 continue - write(6,*) nray, ' rays generated by re6d on PE# ',idproc -c - return - end -c -******************************************************************************** -c - subroutine rg2d(nray,iseed,sigmax,sx,sy,st) -c -c subroutine to generate a 2D gaussian distribution -c written by Alex Dragt 7/10/91 -c - use rays - include 'impli.inc' - include 'files.inc' -c -c working arrays - dimension z(2) -c -c proceedure -c -c initialize indices and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - call myexit - endif -cryne nrays=nray -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c -c fill zblock -c -c select and warmup random number generator -c - if (iseed .lt. 0) ktype=1 - if (iseed .eq. 0) then - write(jof,*) ' iseed = 0 in bgen call' - call myexit - return - endif - if (iseed .gt. 0) ktype=2 - iseed=-iabs(iseed) - call myrand(ktype,iseed,ans) -c - sigm2=sigmax**2 - do 20 j=1,nray -c generate a ray - 25 call normdv(z,1,ktype,iseed) - ssq = z(1)**2 +z(2)**2 - if(ssq .gt. sigm2) go to 25 -c scale and store ray in zblock - zblock(1,j)=sx*z(1) - zblock(2,j)=sx*z(2) - zblock(3,j)=0.d0 - zblock(4,j)=0.d0 - zblock(5,j)=0.d0 - zblock(6,j)=0.d0 - 20 continue - write(6,*) nray, ' rays generated by rg2d on PE# ',idproc -c - return - end -c -******************************************************************************** -c - subroutine rg4d(nray,iseed,sigmax,sx,sy,st) -c -c subroutine to generate a 4D gaussian distribution -c written by Alex Dragt 7/10/91 -c - use rays - include 'impli.inc' - include 'files.inc' -c -c working arrays - dimension z(4) -c -c proceedure -c -c initialize indices and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - call myexit - endif -cryne nrays=nray -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c -c fill zblock -c -c select and warmup random number generator -c - if (iseed .lt. 0) ktype=1 - if (iseed .eq. 0) then - write(jof,*) ' iseed = 0 in bgen call' - call myexit - return - endif - if (iseed .gt. 0) ktype=2 - iseed=-iabs(iseed) - call myrand(ktype,iseed,ans) -c - sigm2=sigmax**2 - do 20 j=1,nray -c generate a ray - 25 call normdv(z,2,ktype,iseed) - ssq = z(1)**2 + z(2)**2 + z(3)**2 + z(4)**2 - if(ssq .gt. sigm2) go to 25 -c scale and store ray in zblock - zblock(1,j)=sx*z(1) - zblock(2,j)=sx*z(2) - zblock(3,j)=sy*z(3) - zblock(4,j)=sy*z(4) - zblock(5,j)=0.d0 - zblock(6,j)=0.d0 - 20 continue - write(6,*) nray, ' rays generated by rg4d on PE# ',idproc -c - return - end -c -******************************************************************************** -c - subroutine rg6d(nray,iseed,sigmax,sx,sy,st) -c -c subroutine to generate a 6D gaussian distribution -c written by Alex Dragt 7/10/91 -c - use rays - include 'impli.inc' - include 'files.inc' - integer, parameter :: ichunk=10000 -c -c working arrays - dimension z(6),za(6*ichunk) -c -c proceedure -c -c write(6,*)'inside rg6d w/ sigmax,sx,sy,st=' -c write(6,*)sigmax,sx,sy,st -c initialize indices and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - write(6,*) 'nray=',nray - write(6,*) 'maxrayp=',maxrayp - call myexit - endif -cryne nrays=nray -c -c initialize arrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c -c fill zblock -c -c select and warmup random number generator -c - if (iseed .lt. 0) ktype=1 - if (iseed .eq. 0) then - write(jof,*) ' iseed = 0 in bgen call' - call myexit - return - endif - if (iseed .gt. 0) ktype=2 - iseed=-iabs(iseed) - call myrand(ktype,iseed,ans) -c - sigm2=sigmax**2 -c -c procedure to generate a small number (~few thousand) of rays: -cryne 1/11/2005 if(nray.gt.5000)goto 23 - if(nray.gt.500000)goto 23 - do 20 j=1,nray -c generate a ray - 21 call normdv(z,3,ktype,iseed) - ssq=z(1)**2+z(2)**2+z(3)**2+z(4)**2+z(5)**2+z(6)**2 - if(ssq .gt. sigm2) go to 21 -c scale and store ray in zblock - zblock(1,j)=sx*z(1) - zblock(2,j)=sx*z(2) - zblock(3,j)=sy*z(3) - zblock(4,j)=sy*z(4) - zblock(5,j)=st*z(5) - zblock(6,j)=st*z(6) - 20 continue - goto 999 -c - 23 continue -c procedure to generate a large number of rays: - j=0 - 24 continue - call normdv(za,3*ichunk,ktype,iseed) - do i=1,6*ichunk-5,6 - ssq= & - & za(i)**2+za(i+1)**2+za(i+2)**2+za(i+3)**2+za(i+4)**2+za(i+5)**2 - if(ssq .gt. sigm2)cycle - j=j+1 - if(j.gt.nray)exit -c scale and store ray in zblock - zblock(1,j)=sx*za(i) - zblock(2,j)=sx*za(i+1) - zblock(3,j)=sy*za(i+2) - zblock(4,j)=sy*za(i+3) - zblock(5,j)=st*za(i+4) - zblock(6,j)=st*za(i+5) - enddo - if(j.lt.nray)goto 24 -c - 999 continue - write(6,*) nray, ' rays generated by rg6d on PE# ',idproc - return - end -c -****************************************************************************** -c - subroutine rt2d(nray,iseed,sx,sy,st) -c subroutine to generate a 2D random uniform distribution on a 2-torus -c written by Alex Dragt 7/15/91 -c - use rays - include 'impli.inc' - include 'files.inc' -c -c working arrays - dimension z(2) -c -c proceedure -c -c initialize constants, indices, and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - call myexit - endif -cryne nrays=nray - twopi = 8.d0*atan(1.d0) -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c -c fill zblock -c -c select and warmup random number generator -c - if (iseed .lt. 0) ktype=1 - if (iseed .eq. 0) then - write(jof,*) ' iseed = 0 in bgen call' - call myexit - return - endif - if (iseed .gt. 0) ktype=2 - iseed=-iabs(iseed) - call myrand(ktype,iseed,ans) -c - do 20 j=1,nray -c generate a ray on the unit torus - call myrand(ktype,iseed,ans) - arg = twopi*ans - z(1) = cos(arg) - z(2) = sin(arg) -c scale and store ray in zblock - zblock(1,j)=sx*z(1) - zblock(2,j)=sx*z(2) - zblock(3,j)=0.d0 - zblock(4,j)=0.d0 - zblock(5,j)=0.d0 - zblock(6,j)=0.d0 - 20 continue - write(6,*) nray, ' rays generated by rt2d on PE# ',idproc -c - return - end -c -******************************************************************************** -c - subroutine rt4d(nray,iseed,sx,sy,st) -c subroutine to generate a 4D random uniform distribution on a 4-torus -c written by Alex Dragt 7/15/91 -c - use rays - include 'impli.inc' - include 'files.inc' -c -c working arrays - dimension z(4) -c -c proceedure -c -c initialize constants, indices, and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - call myexit - endif -cryne nrays=nray - twopi = 8.d0*atan(1.d0) -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c -c fill zblock -c -c select and warmup random number generator -c - if (iseed .lt. 0) ktype=1 - if (iseed .eq. 0) then - write(jof,*) ' iseed = 0 in bgen call' - call myexit - return - endif - if (iseed .gt. 0) ktype=2 - iseed=-iabs(iseed) - call myrand(ktype,iseed,ans) -c - do 20 j=1,nray -c generate a ray on the unit torus - call myrand(ktype,iseed,ans) - arg = twopi*ans - z(1) = cos(arg) - z(2) = sin(arg) - call myrand(ktype,iseed,ans) - arg = twopi*ans - z(3) = cos(arg) - z(4) = sin(arg) -c scale and store ray in zblock - zblock(1,j)=sx*z(1) - zblock(2,j)=sx*z(2) - zblock(3,j)=sy*z(3) - zblock(4,j)=sy*z(4) - zblock(5,j)=0.d0 - zblock(6,j)=0.d0 - 20 continue - write(6,*) nray, ' rays generated by rt4d on PE# ',idproc -c - return - end -c -******************************************************************************** -c - subroutine rt6d(nray,iseed,sx,sy,st) -c subroutine to generate a 6D random uniform distribution on a 6-torus -c written by Alex Dragt 7/15/91 -c - use rays - include 'impli.inc' - include 'files.inc' -c -c working arrays - dimension z(6) -c -c proceedure -c -c initialize constants, indices, and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - call myexit - endif -cryne nrays=nray - twopi = 8.d0*atan(1.d0) -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c -c fill zblock -c -c select and warmup random number generator -c - if (iseed .lt. 0) ktype=1 - if (iseed .eq. 0) then - write(jof,*) ' iseed = 0 in bgen call' - call myexit - return - endif - if (iseed .gt. 0) ktype=2 - iseed=-iabs(iseed) - call myrand(ktype,iseed,ans) -c - do 20 j=1,nray -c generate a ray on the unit torus - call myrand(ktype,iseed,ans) - arg = twopi*ans - z(1) = cos(arg) - z(2) = sin(arg) - call myrand(ktype,iseed,ans) - arg = twopi*ans - z(3) = cos(arg) - z(4) = sin(arg) - call myrand(ktype,iseed,ans) - arg = twopi*ans - z(5) = cos(arg) - z(6) = sin(arg) -c scale and store ray in zblock - zblock(1,j)=sx*z(1) - zblock(2,j)=sx*z(2) - zblock(3,j)=sy*z(3) - zblock(4,j)=sy*z(4) - zblock(5,j)=st*z(5) - zblock(6,j)=st*z(6) - 20 continue - write(6,*) nray, ' rays generated by rt6d on PE# ',idproc -c - return - end -c -******************************************************************************** -c - subroutine st2d(nray,sx,sy,st) -c subroutine to generate a 2D systematic uniform distribution on a 2-torus -c written by Alex Dragt 7/15/91 -c - use rays - include 'impli.inc' -c -c working arrays - dimension z(2) -c -c proceedure -c -c initialize constants, indices, and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - call myexit - endif - twopi = 8.d0*atan(1.d0) -c -c fill zblock -c -c compute number of points on circle - npts=nray -c - pidiv = twopi/float(npts) - ntot = 0 - do 20 i=1,npts -c generate ray on unit 2-torus - ai = float(i-1) - arg= ai*pidiv - z(1) = cos(arg) - z(2) = sin(arg) - ntot = ntot + 1 -c scale and store ray in zblock - zblock(1,ntot)=sx*z(1) - zblock(2,ntot)=sx*z(2) - zblock(3,ntot)=0.d0 - zblock(4,ntot)=0.d0 - zblock(5,ntot)=0.d0 - zblock(6,ntot)=0.d0 - 20 continue - nrays=ntot - write(6,*) ntot, ' rays generated by st2d on PE# ',idproc -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c - return - end -c -******************************************************************************** -c - subroutine st4d(nray,sx,sy,st) -c subroutine to generate a 4D systematic uniform distribution on a 4-torus -c written by Alex Dragt 7/15/91 -c - use rays - include 'impli.inc' -c -c working arrays - dimension z(4) - dimension c(100),s(100) -c -c proceedure -c -c initialize constants, indices, and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - if(maxrayp .gt. 10000) write(6,*) - & 'error: maxrayp exceeds 10000, subroutines st* need rewriting' - call myexit - endif - twopi = 8.d0*atan(1.d0) -c -c fill zblock -c -c compute number of points on each circle - pow=1.d0/2.d0 - aray=float(nray) - npts=int(aray**pow) - if (npts.gt.100) then - write(6,*) - & 'error: maxrayp exceeds 10000, subroutines st* need rewriting' - call myexit - endif -c -c compute needed sines and cosines -c - pidiv = twopi/float(npts) - do 10 i=1,npts - ai = float(i-1) - arg= ai*pidiv - c(i) = cos(arg) - s(i) = sin(arg) - 10 continue -c -c generate rays on unit 4-torus -c - ntot = 0 - do 20 i=1,npts - z(1) = c(i) - z(2) = s(i) - do 30 j=1,npts - z(3) = c(j) - z(4) = s(j) - ntot = ntot + 1 -c scale and store ray in zblock - zblock(1,ntot)=sx*z(1) - zblock(2,ntot)=sx*z(2) - zblock(3,ntot)=sy*z(3) - zblock(4,ntot)=sy*z(4) - zblock(5,ntot)=0.d0 - zblock(6,ntot)=0.d0 - 30 continue - 20 continue -c - nrays=ntot - write(6,*) ntot, ' rays generated by st4d on PE# ',idproc -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c - return - end -c -******************************************************************************** -c - subroutine st6d(nray,sx,sy,st) -c subroutine to generate a 6D systematic uniform distribution on a 6-torus -c written by Alex Dragt 7/15/91 -c - use rays - include 'impli.inc' -c -c working arrays - dimension z(6) - dimension c(21),s(21) -c -c proceedure -c -c initialize constants, indices, and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - if(maxrayp .gt. 10000) write(6,*) - & 'error: maxrayp exceeds 10000, subroutines st* need rewriting' - call myexit - endif - twopi = 8.d0*atan(1.d0) -c -c fill zblock -c -c compute number of points on each circle - pow=1.d0/3.d0 - aray=float(nray) - npts=int(aray**pow) - if (npts.gt.21) then - write(6,*) - & 'error: maxrayp exceeds 10000, subroutines st* need rewriting' - call myexit - endif -c -c compute needed sines and cosines -c - pidiv = twopi/float(npts) - do 10 i=1,npts - ai = float(i-1) - arg= ai*pidiv - c(i) = cos(arg) - s(i) = sin(arg) - 10 continue -c -c generate rays on unit 6-torus -c - ntot = 0 - do 20 i=1,npts - z(1) = c(i) - z(2) = s(i) - do 30 j=1,npts - z(3) = c(j) - z(4) = s(j) - do 40 k=1,npts - z(5) = c(k) - z(6) = s(k) - ntot = ntot + 1 -c scale and store ray in zblock - zblock(1,ntot)=sx*z(1) - zblock(2,ntot)=sx*z(2) - zblock(3,ntot)=sy*z(3) - zblock(4,ntot)=sy*z(4) - zblock(5,ntot)=st*z(5) - zblock(6,ntot)=st*z(6) - 40 continue - 30 continue - 20 continue -c - nrays=ntot - write(6,*) ntot, ' rays generated by st6d on PE# ',idproc -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c - return - end -c -*************************************************************************** -c - subroutine kv4d(nray,iseed,sx,sy,st) -c subroutine to compute a KV distribution in 4-D phase space -c -c written by Alex Dragt 7/15/91 -c - use rays - include 'impli.inc' - include 'files.inc' -c -c working arrays - dimension z(4) -c -c proceedure -c -c initialize indices and arrays - if(nray .gt. maxrayp) then - write(6,*) 'error: nray exceeds maxrayp' - call myexit - endif -cryne nrays=nray -c -c initialize arrrays and set up counters -c - do 115 k=1,nray - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 -c -c fill zblock -c -c select and warmup random number generator -c - if (iseed .lt. 0) ktype=1 - if (iseed .eq. 0) then - write(jof,*) ' iseed = 0 in bgen call' - call myexit - return - endif - if (iseed .gt. 0) ktype=2 - iseed=-iabs(iseed) - call myrand(ktype,iseed,ans) -c - do 20 j=1,nray -c generate a ray - 5 sumsq=0.d0 - do 10 i=1,4 - call myrand(ktype,iseed,ans) - z(i)=2.d0*ans-1.d0 - 10 sumsq=sumsq+z(i)*z(i) - if(sumsq .gt. 1.d0) goto 5 - if(sumsq .eq. 0.d0) goto 5 -c scale and store ray in zblock - rad=sqrt(sumsq) - zblock(1,j)=sx*z(1)/rad - zblock(2,j)=sx*z(2)/rad - zblock(3,j)=sy*z(3)/rad - zblock(4,j)=sy*z(4)/rad - zblock(5,j)=0.d0 - zblock(6,j)=0.d0 - 20 continue - write(6,*) nray, ' rays generated by kv4d on PE# ',idproc -c - return - end -c -*********************************************************************** -c - subroutine myrand(ktype,iseed,ans) -c -c this subroutine generates random numbers using either myran1 -c or myran2 -c written by Alex Dragt, 7/28/91 -c modified 7/3/98 AJD -c - double precision ans -c -c write(6,*) iseed -c - if(ktype .eq. 1) call myran1(iseed,ans) - if(ktype .eq. 2) call myran2(iseed,ans) -c - return - end -c -*********************************************************************** -c - subroutine myran1(idum,ans) -c -c This subroutine is a minor modification of the FUNCTION ran1(idum) -c given in the article by Press and Teukolosky in Computers in Physics, -c vol. 6, p. 522 (1992). See also W. Press, S. Teukolsky, W. Vettering, -c and B. Flannery, Numerical Recipes in Fortran, Second edition, page 271, -c Cambridge University Press (1992). -c It requires seeds IDUM that are .lt. 0 to be reset. -c Written by Alex Dragt 7/3/98. -c - INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV - REAL sans,arg1,AM,EPS,RNMX - double precision ans - PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, - &NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS) - INTEGER j,k,iv(NTAB),iy - SAVE iv,iy - DATA iv /NTAB*0/, iy /0/ -c -c warmup generator - if (idum.le.0.or.iy.eq.0) then - idum=max(-idum,1) - do 11 j=NTAB+8,1,-1 - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if (idum.lt.0) idum=idum+IM - if (j.le.NTAB) iv(j)=idum -11 continue - iy=iv(1) - endif -c - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if (idum.lt.0) idum=idum+IM - j=1+iy/NDIV - iy=iv(j) - iv(j)=idum - arg1=AM*iy - sans=amin1(arg1,RNMX) - ans=dble(sans) -c - return - END -c -************************************************************************* -c - subroutine myran2(idum,ans) -c -c This subroutine is a minor modification of the FUNCTION ran2(idum) -c given in the article by Press and Teukolosky in Computers in Physics, -c vol. 6, p. 522 (1992). See also W. Press, S. Teukolsky, W. Vettering, -c and B. Flannery, Numerical Recipes in Fortran, Second edition, page 272, -c Cambridge University Press (1992). -c It requires seeds IDUM that are .lt. 0 to be reset. -c Written by Alex Dragt 7/3/98. -c - INTEGER idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV - REAL sans,arg1,AM,EPS,RNMX - double precision ans - PARAMETER (IM1=2147483563,IM2=2147483399,AM=1./IM1,IMM1=IM1-1, - &IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791, - &NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-7,RNMX=1.-EPS) - INTEGER idum2,j,k,iv(NTAB),iy - SAVE iv,iy,idum2 - DATA idum2/123456789/, iv/NTAB*0/, iy/0/ -c -c warmup generator - if (idum.le.0) then - idum=max(-idum,1) - idum2=idum - do 11 j=NTAB+8,1,-1 - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum=idum+IM1 - if (j.le.NTAB) iv(j)=idum -11 continue - iy=iv(1) - endif -c - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum=idum+IM1 - k=idum2/IQ2 - idum2=IA2*(idum2-k*IQ2)-k*IR2 - if (idum2.lt.0) idum2=idum2+IM2 - j=1+iy/NDIV - iy=iv(j)-idum2 - iv(j)=idum - if(iy.lt.1)iy=iy+IMM1 - arg1=AM*iy - sans=amin1(arg1,RNMX) - ans=dble(sans) -c - return - END -c -******************************************************************************** -c - subroutine normdv(x,n,ktype,iseed) -c routine to generate 2n independent normal deviates -c Polar method for normal deviates -c written by Alex Dragt ca 1986, revised by Alex Dragt 7/15/91 -c modified by Rob Ryne July 28, 2002 to avoid a large number -c of calls to myrand -c -c References: -c 1)Knuth, The Art of Computer Programming (Vol. 2, page 117) -c 2)Irving Haber, NRL Memo Report #3705 -c - include 'impli.inc' - integer, parameter :: ichunk=10000 -c -c calling arrays - dimension x(*) - real*8, dimension(n) :: u1a,u2a -c -cryne 1/11/2005 if(n.gt.5000)goto 150 - if(n.gt.500000)goto 150 -c procedure to generate a small number (~few thousand) of random numbers: - do 100 k=1,n - 50 call myrand(ktype,iseed,ans) - u1=ans - call myrand(ktype,iseed,ans) - u2=ans - v1=2.d0*u1-1.d0 - v2=2.d0*u2-1.d0 - s=v1**2 + v2**2 - if(s .ge. 1.d0)goto 50 - arg=sqrt(-2.d0*log(s)/s) - ans1=v1*arg - ans2=v2*arg - x(k)=ans1 - x(k+n)=ans2 - 100 continue - return -c procedure to generate a large number of random numbers: - 150 continue -c write(6,*)'using packed version of normdv' - j=0 - 200 continue - call random_number(u1a) - call random_number(u2a) - do i=1,ichunk - v1=2.d0*u1a(i)-1.d0 - v2=2.d0*u2a(i)-1.d0 - s=v1**2 + v2**2 - if(s .gt. 1.d0)cycle - j=j+1 - if(j.gt.n)exit -c store results: - arg=sqrt(-2.d0*log(s)/s) - ans1=v1*arg - ans2=v2*arg - x(j)=ans1 - x(j+n)=ans2 - enddo - if(j.lt.n)goto 200 -c - return - end -c -*********************************************************************** -c - subroutine tic(p) -c -c Translation of initial conditions. -c This subroutine produces a translation in 6-dimensional phase space. -c The parameters p(j) are used to specify translations deltaz(j) -c according to the relations deltaz(j)=p(j). -c The suffixes 'i' and 'f' refer to 'initial' and 'final' respectively. -c Written by Alex Dragt, Fall 1986 -c - use rays - include 'impli.inc' - dimension p(6) -c - do 100 i=1,nraysp -c check to see if i'th ray has been lost - if (istat(i).ne.0) goto 100 -c if not, copy the i'th ray out of zblock - do 110 j=1,6 - 110 zi(j)=zblock(j,i) -c -c transform this ray -c - do 10 j=1,6 - 10 zf(j)=zi(j)+p(j) -c -c put the transformed ray back into zblock - do 120 j=1,6 - 120 zblock(j,i)=zf(j) -c - 100 continue - return - end -c -*********************************************************************** -c routine to setup/warmup the F90 random number generator - subroutine f90ranset(iseed) - implicit double precision(a-h,o-z) - call random_seed(size=iseedsize) -c write(6,*)'random number seed size equals ',iseedsize - call f90ranwarm(iseedsize,iseed) -c write(6,*)'here are a few numbers from random_number:' -c do n=1,50 -c call random_number(x) -c write(6,*)x -c enddo - return - end - - subroutine f90ranwarm(iseedsize,iseed) - implicit double precision(a-h,o-z) - dimension iputarray(iseedsize) - if(iseedsize.eq.1)return - iputarray(1)=iseed -c multiply the seed by a random number -c note: the generator has not been initialized, so this is -c a bit flaky - do n=2,iseedsize - call random_number(x) - iputarray(n)=iseed*x - enddo -c set the seed: - call random_seed(put=iputarray) - return - end - -c -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/dummy.f b/OpticsJan2020/MLI_light_optics/Src/dummy.f deleted file mode 100755 index 4c6c864..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/dummy.f +++ /dev/null @@ -1,87 +0,0 @@ -******************************************************************************* -* DUMMY * -* These are dummy routines to please AFRO and OPTI * -******************************************************************************* -c -***************************************************************************** -c Routines fo please AFRO -***************************************************************************** -c - subroutine bell - write(6,*)' BEEP' - return - end -c -**************************************************************************** -c - subroutine wmrt(p) - dimension p(*) - write(6,*)' in wmrt' - return - end -c -*********************************************************************** -c - subroutine subctr(p) - dimension p(*) - write(6,*)' in subctr' - return - end -c -***************************************************************************** -c - subroutine fwa(p) - write(6,*) 'in dummy routine fwa' - return - end -c -***************************************************************************** -c - subroutine dism(p,h,mh) - write(6,*) 'in dummy routine dism' - return - end -c -***************************************************************************** -c - subroutine rmap(p,h,mh) - write(6,*) 'in dummy routine rmap' - return - end -c -***************************************************************************** -c - subroutine flag(p) - write(6,*) 'in dummy routine flag' - return - end -c -************************************************************************ -c Routines to please OPTI -************************************************************************** -c -cryne 8/17/02 subroutine dcopy(nx,fu,maxf,y,i) -cryne 8/17/02 write(6,*) 'in dummy routine dcopy' -cryne 8/17/02 return -cryne 8/17/02 end -c -*************************************************************************** -c - subroutine dposl( fjac,maxf,nx,step) - write(6,*) 'in dummy routine dposl' - return - end -c -*************************************************************************** -c - subroutine dqrdc(fjac,maxf,nf,nx,qraux,jdum,dum,i) - write(6,*) 'in dummy routine dqrdc' - return - end -c -*************************************************************************** -c - subroutine dqrsl(fj,ma,nf,nx,qr,fc,du,r,sp,rs,d,i,in) - write(6,*) 'in dummy routine dqrsl' - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/dumpin.f b/OpticsJan2020/MLI_light_optics/Src/dumpin.f deleted file mode 100644 index 78d2504..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/dumpin.f +++ /dev/null @@ -1,4190 +0,0 @@ - subroutine dumpin -c----------------------------------------------------------------------- -c This routine organizes the data input from file lf, the master input -c file. -c This file is divided into "components" beginning with a code "#..." -c The available codes are given in common/sharp/. -c In dumpin, they are numbered as they occur in that common. The -c component (segment) currently being read has number "msegm". -c The entries of the component "#menu" will be called "elements". -c The term "item" is used for entries of the components "#lines", -c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". -c -c Output is transferred via several commons. They are explained below. -c -c Written by Rob Ryne ca 1984 -c rewritten by Petra Schuett -c October 21, 1987 -c----------------------------------------------------------------------- - use parallel, only : idproc - use beamdata - use acceldata - use lieaparam, only : monoms - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- -c - include 'incmif.inc' - include 'codes.inc' - include 'files.inc' -c -cryne 5/4/2006 added this to allowing printing of messages from #labor: - integer, parameter :: lmaxmsg=1000 - character*256 lattmsg(lmaxmsg) - common/lattmsgb/lattmsg,lmsgpoi -c -cryne 5/4/2006 Added MADX capability. Initialized to MAD8 below. -c MADX is enabled by putting ";" on the #comment line after #comment - logical MAD8,MADX - common/mad8orx/MAD8,MADX -c - common/mlunits/sclfreq,magunits - common/showme/iverbose - common/symbdef/isymbdef - dimension bufr(4) -c----------------------------------------------------------------------- -c local variables: - character*16 strarr(40),string -c character*80 line - character*256 line - character*16 fname - integer narr(40) - character*60 symb(40) - integer istrtsym(40) - logical leof,lcont,npound -c----------------------------------------------------------------------- - lmsgpoi=0 - MAD8=.true. - MADX=.false. -c Here are some things that need to be initialized before the data are read in: - isymbdef=-1 -c default units are "static" (="magnetic") with scale length=1 and omega*l/c=1 - sl=1.d0 - clite=299792458.d0 - ts=sl/clite - omegascl=1.d0/ts - freqscl=omegascl/( 4.d0*asin(1.d0) ) - p0sc=0.d0 - magunits=1 - iverbose=0 -c - slicetype='none' -cryne if(idproc.eq.0)write(6,*)'AUG8, set default slicetype to none' - -c -cryne 7/20/2002 initialize character array so that, even if input is -c in the original MaryLie format, the mppc array will be filled with ' ' -c so that files are opened properly. (code checks for name=' ') -cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' -cryne 7/7/2002 -cryne initialize #const -cryne this should go somewhere else (near start of afro.f), but I am -cryne trying not to change MaryLie too much. - call initcons -cryne 7/7/2002 additional mods to deal w/ huge number of comments -cryne eventually it would be a good idea to let the user specify whether -cryne or not comments should be printed in the pmif command -cryne -c start - ignorcom=0 -cryne----- 15 Sept 2000 modified to check for input file: -ctm open(lf,file='fort.11',status='old',err=357) - read(lf,2000,end=2001,err=2001) line - 2000 format(a) - if(idproc.eq.0) & - &write(6,*)'reading from file associated with unit 11' - goto 4320 - 2001 continue - open(lf,file='mli.in',status='old',err=357) - read(lf,2000,end=357,err=357) line - if(idproc.eq.0) & - &write(6,*)'reading from file mli.in' - goto 4320 - 357 continue - write(6,*)'master input file does not exist or is empty' - write(6,*)'type filename or to halt' - read(5,2002)fname - 2002 format(a16) - if(fname.eq.' ')call myexit - open(lf,file=fname,status='old',err=3000) - read(lf,2000,end=3000,err=3000) line - goto 4320 - 3000 continue - write(6,*)'file still does not exist or is empty. Halting.' - call myexit -c----------------------------------------------------------------------- - 4320 continue - leof = .false. - rewind lf - msegm = -1 - curr0=-99999. -c-------------------- -c read first line of master input file (should set msegm) -c - 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm write(6,*) itot,' = itot after first REAREC' - if (leof) goto 1000 -c-------------------- -c new component (segment) begins, branch to appropriate part of code -c - 1 goto(100,200,300,400,500,600,700,800,900),msegm -c -c error exit: - write(jof ,99) - write(jodf,99) - 99 format(1x,'problems at 1st goto of routine dumpin; line=') - write(jof,*)TRIM(line) - write(jodf,*)TRIM(line) - call myexit -c-------------------- -c #comment -c - 100 continue -! write(6,*)'here I am at #comment' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 1) goto 1 - if(ignorcom.eq.1)goto 100 -c - npcom=npcom+1 - if(npcom.gt.maxcmt) then - write(jof ,199) maxcmt - write(jodf,199) maxcmt - 199 format(1x,'warning (dumpin): ', & - & 'entries in #comment beyond line ',i6,' will be ignored') - ignorcom=1 - npcom=maxcmt - goto 100 - endif - mline(npcom)=line - goto 100 -c-------------------- -c #beam -c - 200 continue -! write(6,*)'here I am at #beam' - read(lf,*,err=290,end=1000)brho,gamm1,achg,sl -c computation of relativistic beta and gamma factors: - gamma=gamm1+1.d0 - stuff2=gamm1*(gamma+1.d0) - stuff1=sqrt(stuff2) - beta=stuff1/gamma - ts=sl/c -cryne--- 1 August, 2004: - omegascl=1.d0/ts - freqscl=omegascl/( 4.d0*asin(1.d0) ) - pmass=brho/(gamma*beta/clite) - p0sc=gamma*beta*pmass/clite - lflagmagu=.true. - lflagdynu=.false. -cryne--- -cryne 08/14/2001 the beam component may contain other info: -c first set defaults - magunits=1 - iverbose=0 - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -!? if(msegm.ne.2)goto 1 - if (npound) goto 1 - if(msegm.eq.3)goto 301 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if(msegm.ne.2) goto 1 -!? -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c need to delete the following code, which is no longer useful or works. - if(msegm.ne.12345)then - write(6,*)'reached bad section of code in DUMPIN. Stopping.' - stop - endif -cryne there is other info in the #beam component: -c call txtnum(line,80,4,nget,bufr) - call txtnum(line,LEN(line),4,nget,bufr) - if(nget.ne.4)then - write(6,*)'(dumpin)error: could not read 4 more #beam numbers' - stop - endif -c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) -cryne current: - curr0=bufr(1) - if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 -cryne units: - if(nint(bufr(3)).ne.0)then - magunits=0 - sclfreq=4.*asin(1.d0)*bufr(3) - write(6,*)'input frequency=',bufr(3),' Hz' - write(6,*)'scale frequency=',sclfreq,' rad/sec' - write(6,*)'dynamic units (not magnetostatic units) will be used' - slnew=c/sclfreq - write(6,*)'scale length specified in the input file is',sl,'m' - write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' - if(abs(sl-slnew)/sl .gt. 1.e-3)then - write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' - write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' - write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' - write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' - endif - sl=slnew - endif -cryne verbose to show progress: - iverbose=bufr(4) -cryne autoslicing (thick elements need an extra parameter): - iautosl=nint(bufr(2)) - if(iautosl.ne.0)then - write(6,*)'autoslicing of thick elements will be enabled.' - endif - if(iautosl.gt.0)then - write(6,*)'fixed # of slices/element will be = ',iautosl - endif - if(iautosl.lt.0)then - write(6,*)'variable # of slices/element will be used' - if(na.ne.0)then - write(6,*)'error: input file specifies variable # of' - write(6,*)'slices/element, but some elements have already' - write(6,*)'been read in. stopping.' - stop - endif - nrp(1,1)=nrp(1,1)+1 - nrp(1,2)=nrp(1,2)+1 - nrp(1,3)=nrp(1,3)+1 - nrp(1,4)=nrp(1,4)+1 - nrp(1,6)=nrp(1,6)+1 - nrp(1,8)=nrp(1,8)+1 - nrp(1,9)=nrp(1,9)+1 - nrp(1,10)=nrp(1,10)+1 - nrp(1,11)=nrp(1,11)+1 - nrp(1,12)=nrp(1,12)+1 - nrp(1,18)=nrp(1,18)+1 - nrp(1,20)=nrp(1,20)+1 - nrp(1,24)=nrp(1,24)+1 - nrp(1,30)=nrp(1,30)+1 - endif - goto 10 -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c -c error exit: - 290 continue - write(jof ,299) - write(jodf,299) - 299 format(1h ,'data input error detected by dumpin near #beam'/ & - &'Note: if using MAD-style input for beam info, it should be'/ & - &'preceded by #menu, not #beam') - call myexit -c-------------------- -c #menu -c - 300 continue -! write(6,*)'here I am at #menu' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if(iverbose.eq.2)write(6,*)'#menu;',line(1:70) - if(iverbose.eq.2)write(6,*)'#menu;',itot,strarr(1),strarr(2),msegm - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if (msegm .ne. 3) goto 1 - 301 continue - if(iverbose.eq.2)write(6,*)'got past 301' -c -c 11/4/02 new code to deal with 'call' statements: - if(trim(strarr(1)).eq.'call')then - write(6,*)'found a call statement in dumpin' -c call getsymb60(line,80,symb,istrtsym,nsymb) - call getsymb60(line,LEN(line),symb,istrtsym,nsymb) - write(6,*)'symb(1), symb(2), symb(3)=' - write(6,*)symb(1) - write(6,*)symb(2) - write(6,*)symb(3) - lftemp2=lf - lf=42 - write(6,*)'potential bug in dumpin! Need to replace hardwired' - write(6,*)'file unit # (42) with code-selected #. fix later' - call dumpin2(symb(3)) - close(lf) - lf=lftemp2 - write(6,*)'returned from dumpin2' - goto 300 - endif - na=na+1 - if(na.gt.mnumax) then - write(jof ,399) mnumax - write(jodf,399) mnumax - 399 format(1h ,'error in dumpin:', & - & ' too many items (>= mnumax = ',i6,') elements in #menu') - call myexit - endif -c check for doubly defined names - if(iverbose.eq.2)write(6,*)'checking for doubly defined names' - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,396) strarr(1) - write(jodf,396) strarr(1) - 396 format(' error detected by dumpin in #menu: name ', & - & a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! goto 300 - & ' the first definition will be ignored') - lmnlbl(indx)(1:1)='*' - endif -cryne - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then -c check if element/command name is present ( F. Neri 4/14/89 ): - if ( itot .lt. 2 ) then - write(jof ,1396) strarr(1) - write(jodf ,1396) strarr(1) - 1396 format(' error in #menu: ',a16,' has no type code!') - call myexit - endif - endif -cryne July 4 2002 if ( itot .gt. 2 ) then -cryne July 4 2002 write(jof ,1397) strarr(1) -cryne July 4 2002 write(jodf ,1397) strarr(1) -c1397 format(' error in #menu: ',a16,' has more than one type code!') -cryne July 4 2002 call myexit -cryne July 4 2002 endif -c new item in menu: - lmnlbl(na)=strarr(1) - initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse -c string is name of element/command type, look up element indices -cryne string=strarr(2) - if((trim(strarr(1)).eq.'beam').or. & - &(trim(strarr(1)).eq.'units'))then - string=strarr(1) - else - string=strarr(2) - endif - if(iverbose.eq.2)write(6,*)'starting do 325' - do 325 m = 1,9 - do 325 n = 1,nrpmax -cryne Dec 1, 2002 if(string(1:8).eq.ltc(m,n)) then -c eventually the max string length should not be hardwired like this - if(string(1:16).eq.ltc(m,n)) then - nt1(na) = m - nt2(na) = n - if(iverbose.eq.2)then - write(6,*)'(3344) ',na,nt1(na),nt2(na),string(1:16) - endif - goto 3344 - endif - 325 continue -c============= -cryne Sept 17, 2003 -c before declaring this an unknown element/command name, -c check to see if it is the name of an existing menu item -c since this is a functionality that MAD allows - call lookup(strarr(2),itype,indx) - if(itype.ne.1)goto 3226 -c this *is* the name of an existing menu item. - if(idproc.eq.0)then - write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) - endif - m = nt1(indx) - n = nt2(indx) - nt1(na) = m - nt2(na) = n - imax=nrp(m,n) - if(imax.ne.0)then - do i=1,imax - pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) - enddo - endif - icmax=ncp(m,n) - if(icmax.ne.0)then - do i=1,icmax - cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) - enddo - endif - initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f - goto 3344 - 3226 continue -c============= -c error: unknown element/command name - if(idproc.eq.0)then - write(jof ,398)(strarr(j),j=1,2) - write(jodf,398)(strarr(j),j=1,2) - 398 format(1h ,'dumpin error at ',a16,': type code ',a16, & - &' not found.'/ & - & 1h ,'this item will be ignored') - endif - na=na-1 - goto 300 - 3344 continue -c write(6,*)'menu element;string,m,n=',string(1:16),m,n -c read parameters. Number of parameters is given in nrp - imax=nrp(m,n) - icmax=ncp(m,n) - imaxold=nrpold(m,n) -c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax -cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 - if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. - & index(line,':').eq.0)goto 300 -cryne July 4, 2002 -c if using the Standard Input Format, the remaining parameters -c are stored in "line"; otherwise use the MaryLie input format: -c -c mpp(na) points to where the real parameters will be stored -c mppc(na) points to where the char*16 parameters will be stored - mpp(na) = mpprpoi - mppc(na) = mppcpoi -cryne 7/9/2002 if(itot.eq.2)then -c original MaryLie input format (icmax not relevant here): - if( (itot.eq.2) .and. (index(line,':').eq.0) )then -c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string -cryne 12/31/2005 imaxold is now incremented for thick elements if autoslicing. -cryne But note that mpprpoi is incremented by imax, not imaxold. -cryne This allows use of MaryLie names, but to have additional -cryne parameters if read in using the SIF (MAD) format. - if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) -c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) -c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax - goto 300 -c error in parameter input - 390 write(jof ,397)lmnlbl(na) - write(jodf,397)lmnlbl(na) - 397 format(1h ,'(dumpin) parameter input error at element ',a16) - call myexit - endif -cryne July 4, 2002 -c if the code gets here, the Standard Input Format is being used -c to specify the elements in the menu: -c first delete the element name and type from the character string: -cryne this could be more easily done with the f90 intrinsic len_trim() -c kkk1=len_trim(strarr(1))-1 - string=strarr(1) - kkk1=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk1=kkk1-1 - enddo - do i=1,80 - if(line(i:i+kkk1).eq.strarr(1))then - line(i:i+kkk1)=' ' - exit - endif - enddo -cryne kkk2=len_trim(strarr(2))-1 - string=strarr(2) - kkk2=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk2=kkk2-1 - enddo -c - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then - do i=1,80 - if(line(i:i+kkk2).eq.strarr(2))then - line(i:i+kkk2)=' ' - exit - endif - enddo - endif -c get rid of other unneccesary characters: - do i=1,80 -c if(line(i:i).eq.',')line(i:i)=' ' - if(line(i:i).eq.':')line(i:i)=' ' - enddo - call stdinf(line,na,m,n,initparms,strarr(1)) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax -c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax -c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi - goto 300 -c -c-------------------- -c #lines,#lumps,#loops -c - 400 continue -! write(6,*)'here I am at #lines,lumps,loops' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 4) goto 1 - goto 410 - 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 5) goto 1 - goto 410 - 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 6) goto 1 -c - 410 nb=nb+1 - if(nb.gt.itmno)then - write(jof ,499) itmno - write(jodf,499) itmno - 499 format(1h ,'error in dumpin:', & - & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,497) ling(msegm),strarr(1) - write(jodf,497) ling(msegm),strarr(1) - 497 format(1x,'dumpin error in ', & - & a8,': name ',a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! if(msegm .eq.4) then -! goto 400 -! else if(msegm.eq.5) then -! goto 500 -! else if(msegm.eq.6) then -! goto 600 -! endif - & ' the first definition will be ignored') - ilbl(indx)(1:1)='*' - endif -c new item - ilbl(nb)=strarr(1) - imin=0 -cryne July 2002 Standard Input Format option: components might be on -cryne this record; check now -cryne Note: this assume that the 2nd string after the name is 'line', -cryne and so the 2nd string is ignored - if( (itot.eq.2) .and. (.not.(lcont)) )then - write(6,*)'error parsing line:' - write(6,*)'this should be a name alone, or' - write(6,*)'a name followed by LINE= followed by the components' - write(6,*)'input line =' - write(6,*)line - stop - endif - if(itot.gt.2)then -c write(6,*)'ITOT=',itot -c do i=1,itot -c write(6,*)i,narr(i),strarr(i) -c enddo - do 424 i=3,itot - icon(imin+i-2,nb)=strarr(i) - irep(imin+i-2,nb)=narr(i) - 424 continue - imin=imin+itot-2 - if(lcont)then - goto 420 - else - goto 426 - endif - endif -cryne remaining code is from original version: -c read components of item -c repeat... - 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if(imin+itot.gt.itmln)then - write(jof ,498) itmln,ilbl(nb) - write(jodf,498) itmln,ilbl(nb) - 498 format(1h ,'error in dumpin:', & - & ' too many entries (> itmln = ',i6,') in ',a16) - call myexit - endif -c store names and rep rates of components - do 425 i=1,itot - icon(imin+i,nb)=strarr(i) - irep(imin+i,nb)=narr(i) - 425 continue - imin=imin+itot - if(lcont) goto 420 -c ... until no more continuation lines -c-- -c now set length and type of element - 426 continue - ilen(nb)=imin - ityp(nb)=msegm-2 -c go back to appropriate component (segment) - if(msegm .eq.4) then - goto 400 - else if(msegm.eq.5) then - goto 500 - else if(msegm.eq.6) then - goto 600 - endif -c-------------------- -c #labor -c - 700 continue -! write(6,*)'here I am at #labor' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 7) goto 1 -c - noble=noble+1 - if(noble.gt.mlabor) then - write(jof ,799) mlabor - write(jodf,799) mlabor - 799 format(1h ,'error in dumpin:', & - & ' too many entries (>= mlabor = ',i6,') in #labor array') - call myexit - endif -c new task -cryne 5/4/2006 - if(line(1:1).eq.'>')then - lmsgpoi=lmsgpoi+1 - if(lmsgpoi.gt.lmaxmsg)then - if(idproc.eq.0) & - & write(6,*)'error: too many output messages (>) ini #labor' - call myexit - endif -c latt(noble)='>' - latt(noble)=line(1:3) - num(noble)=lmsgpoi - lattmsg(lmsgpoi)=line - goto 700 - endif -c - latt(noble)=strarr(1) - num(noble)=narr(1) - goto 700 -c-------------------- -c #call (formerly #include) - 800 continue - write(6,*)' Start #call after user name: ',strarr(1) -c -ctm 9/01 modified to open and save up to 32 long #include file names -c - ninc = 0 - 810 read(lf,2000,end=1000) line -c -c check for next segment -c - if(index(line,'#').ne.0) then - itot = -1 - na2 = na - nb2 = nb - noble2 = noble - write(6,813) na2,nb2,noble2 - 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') - write(6,817) line - 817 format(' End #include with: ',a) - go to 10 - endif -c -ctm save file name and pointers before opening 1st include file -c - ninc = ninc + 1 - if(ninc.eq.1) then - na1 = na - nb1 = nb - noble1 = noble - write(6,877) na1,nb1,noble1 - 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') - endif -c -ctm skip leading blanks -c - lc = 1 - 880 if(line(lc:lc).eq.' ') then - lc = lc + 1 - go to 880 - endif - incfil(ninc) = line(lc:) - write(6,888) ninc,incfil(ninc) - 888 format(' include',i3,' : ',a) - call mlfinc(incfil(ninc)) - go to 810 -ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm if (leof) goto 1000 -ctm goto 1 -c-------------------- -c #const - 900 continue -! write(6,*)'here I am at #const' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if((msegm.eq.9).and.(itot.ne.1))then - write(6,*)'input error (#const)' - write(6,*)'trying to read a definition, but did not find a' - write(6,*)'character string at the beginning of this record:' - write(6,*)line(1:80) - stop - endif - if(msegm.eq.3)goto 301 - if(msegm.eq.4)goto 410 - if (msegm .ne. 9) goto 1 - 901 continue - call getconst(line,strval,nreturn) - if(nreturn.ne.1)then - write(6,*)'trouble parsing the following line:' - write(6,*)line - write(6,*)'continuing...' - goto 900 - endif - nconst=nconst+1 - if(nconst.gt.nconmax)then - write(6,*)'too many constants defined in the input file' - stop - endif - constr(nconst)=strarr(1) - conval(nconst)=strval -c write(6,*)'nconst,constr(nconst),conval(nconst)=' -c write(6,*)nconst,constr(nconst),conval(nconst) - goto 900 -c normal return at end of file - 1000 continue - return - end -c -************************************************************************ - subroutine dumpin2(uname) -c----------------------------------------------------------------------- -c This routine organizes the data input from file lf, the master input -c file. -c This file is divided into "components" beginning with a code "#..." -c The available codes are given in common/sharp/. -c In dumpin, they are numbered as they occur in that common. The -c component (segment) currently being read has number "msegm". -c The entries of the component "#menu" will be called "elements". -c The term "item" is used for entries of the components "#lines", -c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". -c -c Output is transferred via several commons. They are explained below. -c -c Written by Rob Ryne ca 1984 -c rewritten by Petra Schuett -c October 21, 1987 -c----------------------------------------------------------------------- - use beamdata - use acceldata - use lieaparam, only : monoms - use parallel, only : idproc - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- -c - include 'incmif.inc' - include 'codes.inc' - include 'files.inc' - common/mlunits/sclfreq,magunits - common/showme/iverbose - common/symbdef/isymbdef - dimension bufr(4) -c----------------------------------------------------------------------- -c local variables: - character*60 uname - character*16 strarr(40),string - character*80 line - character*16 fname - integer narr(40) - character*60 symb(40) - integer istrtsym(40) - logical leof,lcont,npound -cryne 8/15/2001 new code to read in a character string instead of numbers: -c----------------------------------------------------------------------- -cryne 9/26/02 -c this could go somewhere else too, but here is OK: -c isymbdef=-1 -c -cryne 7/20/2002 initialize character array so that, even if input is -c in the original MaryLie format, the mppc array will be filled with ' ' -c so that files are opened properly. (code checks for name=' ') -cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' -cryne 7/7/2002 -cryne initialize #const -cryne this should go somewhere else (near start of afro.f), but I am -cryne trying not to change MaryLie too much. -c call initcons -cryne 7/7/2002 additional mods to deal w/ huge number of comments -cryne eventually it would be a good idea to let the user specify whether -cryne or not comments should be printed in the pmif command -cryne -c start -c ignorcom=0 -cryne----- 15 Sept 2000 modified to check for input file: -ctm open(lf,file='fort.11',status='old',err=357) -c read(lf,2000,end=2001,err=2001) line - 2000 format(a) -c goto 4320 -c2001 continue -c write(6,*)'master input file does not exist or is empty' -c write(6,*)'type filename or to halt' -c read(5,2002)fname -c2002 format(a16) -c if(fname.eq.' ')call myexit - open(lf,file=uname,status='old',err=3000) - write(6,*)'successfully opened file ',uname - goto 4320 - 3000 continue - write(6,*)'(dumpin2) file does not exist. File name=.' - write(6,*)uname - write(6,*)'Halting.' - call myexit -c----------------------------------------------------------------------- - 4320 continue - leof = .false. -c rewind lf -cryne 11/04/02 msegm = -1 - msegm=3 -c curr0=-99999. -c-------------------- -c read first line of master input file (should set msegm) -c - 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm write(6,*) itot,' = itot after first REAREC' - write(6,*)'dumpin2: done reading line=' - write(6,*)line - write(6,*)'msegm,itot,leof=',msegm,itot,leof - if(strarr(1).eq.'call')then - write(6,*)'found call statement after 10 in dumpin2' - goto 301 - endif - if (leof) goto 1000 - if(msegm.eq.3)goto 301 - if(msegm.eq.4 .or. msegm.eq.5 .or. msegm.eq.6)goto 410 - if(msegm.eq.9)goto 901 -c check for the statement '#labor' - if(msegm.eq.7)goto 700 - write(6,*)'error: read the first line of input file but' - write(6,*)'cannot determine where to go in routine dumpin2' - call myexit -c-------------------- -c new component (segment) begins, branch to appropriate part of code -c - 1 goto(100,200,300,400,500,600,700,800,900),msegm -c -c error exit: - write(jof ,99) - write(jodf,99) - 99 format(1x,'problems at 1st goto of routine dumpin2; line=') - write(jof,*)line - write(jodf,*)line - call myexit -c-------------------- -c #comment -c - 100 continue -! write(6,*)'here I am at #comment' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 1) goto 1 - if(ignorcom.eq.1)goto 100 -c - npcom=npcom+1 - if(npcom.gt.maxcmt) then - write(jof ,199) maxcmt - write(jodf,199) maxcmt - 199 format(1x,'warning (dumpin2): ', & - & 'entries in #comment beyond line ',i6,' will be ignored') - ignorcom=1 - npcom=maxcmt - goto 100 - endif - mline(npcom)=line - goto 100 -c-------------------- -c #beam -c - 200 continue -! write(6,*)'here I am at #beam' - read(lf,*,err=290,end=1000)brho,gamm1,achg,sl -c computation of relativistic beta and gamma factors: - gamma=gamm1+1.d0 - stuff2=gamm1*(gamma+1.d0) - stuff1=sqrt(stuff2) - beta=stuff1/gamma - ts=sl/c -cryne 08/14/2001 the beam component may contain other info: -c first set defaults - magunits=1 - iverbose=0 - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -!? if(msegm.ne.2)goto 1 - if (npound) goto 1 - if(msegm.eq.3)goto 301 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if(msegm.ne.2) goto 1 -!? -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c need to delete the following code, which is no longer useful or works. - if(msegm.ne.12345)then - write(6,*)'reached bad section of code in DUMPIN. Stopping.' - stop - endif -cryne there is other info in the #beam component: - call txtnum(line,80,4,nget,bufr) - if(nget.ne.4)then - write(6,*)'(dumpin2)error: could not read 4 more #beam numbers' - stop - endif -c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) -cryne current: - curr0=bufr(1) - if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 -cryne units: - if(nint(bufr(3)).ne.0)then - magunits=0 - sclfreq=4.*asin(1.d0)*bufr(3) - write(6,*)'input frequency=',bufr(3),' Hz' - write(6,*)'scale frequency=',sclfreq,' rad/sec' - write(6,*)'dynamic units (not magnetostatic units) will be used' - slnew=c/sclfreq - write(6,*)'scale length specified in the input file is',sl,'m' - write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' - if(abs(sl-slnew)/sl .gt. 1.e-3)then - write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' - write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' - write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' - write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' - endif - sl=slnew - endif -cryne verbose to show progress: - iverbose=bufr(4) -cryne autoslicing (thick elements need an extra parameter): - iautosl=nint(bufr(2)) - if(iautosl.ne.0)then - write(6,*)'autoslicing of thick elements will be enabled.' - endif - if(iautosl.gt.0)then - write(6,*)'fixed # of slices/element will be = ',iautosl - endif - if(iautosl.lt.0)then - write(6,*)'variable # of slices/element will be used' - if(na.ne.0)then - write(6,*)'error: input file specifies variable # of' - write(6,*)'slices/element, but some elements have already' - write(6,*)'been read in. stopping.' - stop - endif - nrp(1,1)=nrp(1,1)+1 - nrp(1,2)=nrp(1,2)+1 - nrp(1,3)=nrp(1,3)+1 - nrp(1,4)=nrp(1,4)+1 - nrp(1,6)=nrp(1,6)+1 - nrp(1,8)=nrp(1,8)+1 - nrp(1,9)=nrp(1,9)+1 - nrp(1,10)=nrp(1,10)+1 - nrp(1,11)=nrp(1,11)+1 - nrp(1,12)=nrp(1,12)+1 - nrp(1,18)=nrp(1,18)+1 - nrp(1,20)=nrp(1,20)+1 - nrp(1,24)=nrp(1,24)+1 - nrp(1,30)=nrp(1,30)+1 - endif - goto 10 -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c -c error exit: - 290 continue - write(jof ,299) - write(jodf,299) - 299 format(1h ,'data input error detected by dumpin2 near #beam') - call myexit -c-------------------- -c #menu -c - 300 continue -! write(6,*)'here I am at #menu' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -! write(6,*)line(1:80) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if (msegm .ne. 3) goto 1 - 301 continue -c -c 11/4/02 new code to deal with 'call' statements: - if(trim(strarr(1)).eq.'call')then - write(6,*)'found a call statement in dumpin2' - call getsymb60(line,80,symb,istrtsym,nsymb) - write(6,*)'symb(1), symb(2), symb(3)=' - write(6,*)symb(1) - write(6,*)symb(2) - write(6,*)symb(3) - lftemp3=lf - lf=43 - call dumpin3(symb(3)) - close(lf) - lf=lftemp3 - goto 300 - endif - na=na+1 - if(na.gt.mnumax) then - write(jof ,399) mnumax - write(jodf,399) mnumax - 399 format(1h ,'error in dumpin:', & - & ' too many items (>= mnumax = ',i6,') elements in #menu') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,396) strarr(1) - write(jodf,396) strarr(1) - 396 format(' error detected by dumpin2 in #menu: name ', & - & a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! goto 300 - & ' the first definition will be ignored') - lmnlbl(indx)(1:1)='*' - endif -cryne - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then -c check if element/command name is present ( F. Neri 4/14/89 ): - if ( itot .lt. 2 ) then - write(jof ,1396) strarr(1) - write(jodf ,1396) strarr(1) - 1396 format(' error in #menu: ',a16,' has no type code!') - call myexit - endif - endif -cryne July 4 2002 if ( itot .gt. 2 ) then -cryne July 4 2002 write(jof ,1397) strarr(1) -cryne July 4 2002 write(jodf ,1397) strarr(1) -c1397 format(' error in #menu: ',a16,' has more than one type code!') -cryne July 4 2002 call myexit -cryne July 4 2002 endif -c new item in menu: - lmnlbl(na)=strarr(1) - initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse -c string is name of element/command type, look up element indices -cryne string=strarr(2) - if((trim(strarr(1)).eq.'beam').or. & - &(trim(strarr(1)).eq.'units'))then - string=strarr(1) - else - string=strarr(2) - endif - do 325 m = 1,9 - do 325 n = 1,nrpmax - if(string(1:16).eq.ltc(m,n)) then - nt1(na) = m - nt2(na) = n - goto 3344 - endif - 325 continue -c============= -cryne Sept 17, 2003 -c before declaring this an unknown element/command name, -c check to see if it is the name of an existing menu item -c since this is a functionality that MAD allows - call lookup(strarr(2),itype,indx) - if(itype.ne.1)goto 3226 -c this *is* the name of an existing menu item. - if(idproc.eq.0)then - write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) - endif - m = nt1(indx) - n = nt2(indx) - nt1(na) = m - nt2(na) = n - imax=nrp(m,n) - if(imax.ne.0)then - do i=1,imax - pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) - enddo - endif - icmax=ncp(m,n) - if(icmax.ne.0)then - do i=1,icmax - cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) - enddo - endif - initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f - goto 3344 - 3226 continue -c============= -c error: unknown element/command name - write(jof ,398)(strarr(j),j=1,2) - write(jodf,398)(strarr(j),j=1,2) - 398 format(1h ,'dumpin2 error at ',a16,': type code ',a16, & - &' not found.'/ & - & 1h ,'this item will be ignored') - na=na-1 - goto 300 - 3344 continue -! write(6,*)'found a menu element;string,m,n=',string(1:8),m,n -c read parameters. Number of parameters is given in nrp - imax=nrp(m,n) - icmax=ncp(m,n) - imaxold=nrpold(m,n) -c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax -cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 - if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. - & index(line,':').eq.0)goto 300 -cryne July 4, 2002 -c if using the Standard Input Format, the remaining parameters -c are stored in "line"; otherwise use the MaryLie input format: -c -c mpp(na) points to where the real parameters will be stored -c mppc(na) points to where the char*16 parameters will be stored - mpp(na) = mpprpoi - mppc(na) = mppcpoi -cryne 7/9/2002 if(itot.eq.2)then -c original MaryLie input format (icmax not relevant here): - if( (itot.eq.2) .and. (index(line,':').eq.0) )then -c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string - if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) -c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) -c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax - goto 300 -c error in parameter input - 390 write(jof ,397)lmnlbl(na) - write(jodf,397)lmnlbl(na) - 397 format(1h ,'(dumpin2) parameter input error at element ',a16) - call myexit - endif -cryne July 4, 2002 -c if the code gets here, the Standard Input Format is being used -c to specify the elements in the menu: -c first delete the element name and type from the character string: -c write(6,*)'USING STANDARD INPUT FORMAT. LINE=' -c write(6,*)line -c write(6,*)'strarr(1),strarr(2)=' -c write(6,*)strarr(1) -c write(6,*)strarr(2) -ccc write(6,*)'will read params using SIF; imax,icmax=',imax,icmax -ccc write(6,*)'current values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi -cryne this could be more easily done with the f90 intrinsic len_trim() -c kkk1=len_trim(strarr(1))-1 - string=strarr(1) - kkk1=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk1=kkk1-1 - enddo - do i=1,80 - if(line(i:i+kkk1).eq.strarr(1))then - line(i:i+kkk1)=' ' - exit - endif - enddo -cryne kkk2=len_trim(strarr(2))-1 - string=strarr(2) - kkk2=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk2=kkk2-1 - enddo -c - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then - do i=1,80 - if(line(i:i+kkk2).eq.strarr(2))then - line(i:i+kkk2)=' ' - exit - endif - enddo - endif -c get rid of other unneccesary characters: - do i=1,80 -c if(line(i:i).eq.',')line(i:i)=' ' - if(line(i:i).eq.':')line(i:i)=' ' - enddo -c write(6,*)'TRIMMED LINE=' -c write(6,*)line - call stdinf(line,na,m,n,initparms,strarr(1)) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax -c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax -c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi - goto 300 -c -c-------------------- -c #lines,#lumps,#loops -c - 400 continue -! write(6,*)'here I am at #lines,lumps,loops' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 4) goto 1 - goto 410 - 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 5) goto 1 - goto 410 - 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 6) goto 1 -c - 410 nb=nb+1 - if(nb.gt.itmno)then - write(jof ,499) itmno - write(jodf,499) itmno - 499 format(1h ,'error in dumpin2:', & - & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,497) ling(msegm),strarr(1) - write(jodf,497) ling(msegm),strarr(1) - 497 format(1x,'dumpin2 error in ', & - & a8,': name ',a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! if(msegm .eq.4) then -! goto 400 -! else if(msegm.eq.5) then -! goto 500 -! else if(msegm.eq.6) then -! goto 600 -! endif - & ' the first definition will be ignored') - ilbl(indx)(1:1)='*' - endif -c new item - ilbl(nb)=strarr(1) - imin=0 -cryne July 2002 Standard Input Format option: components might be on -cryne this record; check now -cryne Note: this assume that the 2nd string after the name is 'line', -cryne and so the 2nd string is ignored - if( (itot.eq.2) .and. (.not.(lcont)) )then - write(6,*)'error parsing line:' - write(6,*)'this should be a name alone, or' - write(6,*)'a name followed by LINE= followed by the components' - write(6,*)'input line =' - write(6,*)line - stop - endif - if(itot.gt.2)then -c write(6,*)'ITOT=',itot -c do i=1,itot -c write(6,*)i,narr(i),strarr(i) -c enddo - do 424 i=3,itot - icon(imin+i-2,nb)=strarr(i) - irep(imin+i-2,nb)=narr(i) - 424 continue - imin=imin+itot-2 - if(lcont)then - goto 420 - else - goto 426 - endif - endif -cryne remaining code is from original version: -c read components of item -c repeat... - 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if(imin+itot.gt.itmln)then - write(jof ,498) itmln,ilbl(nb) - write(jodf,498) itmln,ilbl(nb) - 498 format(1h ,'error in dumpin2:', & - & ' too many entries (> itmln = ',i6,') in ',a16) - call myexit - endif -c store names and rep rates of components - do 425 i=1,itot - icon(imin+i,nb)=strarr(i) - irep(imin+i,nb)=narr(i) - 425 continue - imin=imin+itot - if(lcont) goto 420 -c ... until no more continuation lines -c-- -c now set length and type of element - 426 continue - ilen(nb)=imin - ityp(nb)=msegm-2 -c go back to appropriate component (segment) - if(msegm .eq.4) then - goto 400 - else if(msegm.eq.5) then - goto 500 - else if(msegm.eq.6) then - goto 600 - endif -c-------------------- -c #labor -c - 700 continue -! write(6,*)'here I am at #labor' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 7) goto 1 -c - noble=noble+1 - if(noble.gt.mlabor) then - write(jof ,799) mlabor - write(jodf,799) mlabor - 799 format(1h ,'error in dumpin2:', & - & ' too many entries (>= mlabor = ',i6,') in #labor array') - call myexit - endif -c new task - latt(noble)=strarr(1) - num(noble)=narr(1) - goto 700 -c-------------------- -c #call (formerly #include) - 800 continue - write(6,*)' Start #call after user name: ',strarr(1) -c -ctm 9/01 modified to open and save up to 32 long #include file names -c - ninc = 0 - 810 read(lf,2000,end=1000) line -c -c check for next segment -c - if(index(line,'#').ne.0) then - itot = -1 - na2 = na - nb2 = nb - noble2 = noble - write(6,813) na2,nb2,noble2 - 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') - write(6,817) line - 817 format(' End #include with: ',a) - go to 10 - endif -c -ctm save file name and pointers before opening 1st include file -c - ninc = ninc + 1 - if(ninc.eq.1) then - na1 = na - nb1 = nb - noble1 = noble - write(6,877) na1,nb1,noble1 - 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') - endif -c -ctm skip leading blanks -c - lc = 1 - 880 if(line(lc:lc).eq.' ') then - lc = lc + 1 - go to 880 - endif - incfil(ninc) = line(lc:) - write(6,888) ninc,incfil(ninc) - 888 format(' include',i3,' : ',a) - call mlfinc(incfil(ninc)) - go to 810 -ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm if (leof) goto 1000 -ctm goto 1 -c-------------------- -c #const - 900 continue -! write(6,*)'here I am at #const' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if((msegm.eq.9).and.(itot.ne.1))then - write(6,*)'input error (#const)' - write(6,*)'trying to read a definition, but did not find a' - write(6,*)'character string at the beginning of this record:' - write(6,*)line(1:80) - stop - endif - if(msegm.eq.3)goto 301 - if(msegm.eq.4)goto 410 - if (msegm .ne. 9) goto 1 - 901 continue - call getconst(line,strval,nreturn) - if(nreturn.ne.1)then - write(6,*)'trouble parsing the following line:' - write(6,*)line - write(6,*)'continuing...' - goto 900 - endif - nconst=nconst+1 - if(nconst.gt.nconmax)then - write(6,*)'too many constants defined in the input file' - stop - endif - constr(nconst)=strarr(1) - conval(nconst)=strval -c write(6,*)'nconst,constr(nconst),conval(nconst)=' -c write(6,*)nconst,constr(nconst),conval(nconst) - goto 900 -c normal return at end of file - 1000 continue - close(44) - write(6,*)'returning from routine dumpin2' - return - end -c -c*********************************************************************** -************************************************************************ - subroutine dumpin3(uname) -c----------------------------------------------------------------------- -c This routine organizes the data input from file lf, the master input -c file. -c This file is divided into "components" beginning with a code "#..." -c The available codes are given in common/sharp/. -c In dumpin, they are numbered as they occur in that common. The -c component (segment) currently being read has number "msegm". -c The entries of the component "#menu" will be called "elements". -c The term "item" is used for entries of the components "#lines", -c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". -c -c Output is transferred via several commons. They are explained below. -c -c Written by Rob Ryne ca 1984 -c rewritten by Petra Schuett -c October 21, 1987 -c----------------------------------------------------------------------- - use beamdata - use acceldata - use lieaparam, only : monoms - use parallel, only : idproc - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- -c - include 'incmif.inc' - include 'codes.inc' - include 'files.inc' - common/mlunits/sclfreq,magunits - common/showme/iverbose - common/symbdef/isymbdef - dimension bufr(4) -c----------------------------------------------------------------------- -c local variables: - character*60 uname - character*16 strarr(40),string - character*80 line - character*16 fname - integer narr(40) - character*60 symb(40) - integer istrtsym(40) - logical leof,lcont,npound -cryne 8/15/2001 new code to read in a character string instead of numbers: -c----------------------------------------------------------------------- -cryne 9/26/02 -c this could go somewhere else too, but here is OK: -c isymbdef=-1 -c -cryne 7/20/2002 initialize character array so that, even if input is -c in the original MaryLie format, the mppc array will be filled with ' ' -c so that files are opened properly. (code checks for name=' ') -cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' -cryne 7/7/2002 -cryne initialize #const -cryne this should go somewhere else (near start of afro.f), but I am -cryne trying not to change MaryLie too much. -c call initcons -cryne 7/7/2002 additional mods to deal w/ huge number of comments -cryne eventually it would be a good idea to let the user specify whether -cryne or not comments should be printed in the pmif command -cryne -c start -c ignorcom=0 -cryne----- 15 Sept 2000 modified to check for input file: -ctm open(lf,file='fort.11',status='old',err=357) -c read(lf,2000,end=2001,err=2001) line - 2000 format(a) -c goto 4320 -c2001 continue -c write(6,*)'master input file does not exist or is empty' -c write(6,*)'type filename or to halt' -c read(5,2002)fname -c2002 format(a16) -c if(fname.eq.' ')call myexit - open(lf,file=uname,status='old',err=3000) - write(6,*)'successfully opened file ',uname - goto 4320 - 3000 continue - write(6,*)'(dumpin3) file does not exist. File name=.' - write(6,*)uname - write(6,*)'Halting.' - call myexit -c----------------------------------------------------------------------- - 4320 continue - leof = .false. -c rewind lf -cryne 11/04/02 msegm = -1 - msegm=3 -c curr0=-99999. -c-------------------- -c read first line of master input file (should set msegm) -c - 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm write(6,*) itot,' = itot after first REAREC' - write(6,*)'dumpin3: done reading line=' - write(6,*)line - write(6,*)'msegm,itot,leof=',msegm,itot,leof - if(strarr(1).eq.'call')then - write(6,*)'found call statement after 10 in dumpin3' - goto 301 - endif - if (leof) goto 1000 - if(msegm.eq.3)goto 301 - if(msegm.eq.4 .or. msegm.eq.5 .or. msegm.eq.6)goto 410 - if(msegm.eq.9)goto 901 -c check for the statement '#labor' - if(msegm.eq.7)goto 700 - write(6,*)'error: read the first line of input file but' - write(6,*)'cannot determine where to go in routine dumpin3' - call myexit -c-------------------- -c new component (segment) begins, branch to appropriate part of code -c - 1 goto(100,200,300,400,500,600,700,800,900),msegm -c -c error exit: - write(jof ,99) - write(jodf,99) - 99 format(1x,'problems at 1st goto of routine dumpin3; line=') - write(jof,*)line - write(jodf,*)line - call myexit -c-------------------- -c #comment -c - 100 continue -! write(6,*)'here I am at #comment' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 1) goto 1 - if(ignorcom.eq.1)goto 100 -c - npcom=npcom+1 - if(npcom.gt.maxcmt) then - write(jof ,199) maxcmt - write(jodf,199) maxcmt - 199 format(1x,'warning (dumpin3: ', & - & 'entries in #comment beyond line ',i6,' will be ignored') - ignorcom=1 - npcom=maxcmt - goto 100 - endif - mline(npcom)=line - goto 100 -c-------------------- -c #beam -c - 200 continue -! write(6,*)'here I am at #beam' - read(lf,*,err=290,end=1000)brho,gamm1,achg,sl -c computation of relativistic beta and gamma factors: - gamma=gamm1+1.d0 - stuff2=gamm1*(gamma+1.d0) - stuff1=sqrt(stuff2) - beta=stuff1/gamma - ts=sl/c -cryne 08/14/2001 the beam component may contain other info: -c first set defaults - magunits=1 - iverbose=0 - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -!? if(msegm.ne.2)goto 1 - if (npound) goto 1 - if(msegm.eq.3)goto 301 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if(msegm.ne.2) goto 1 -!? -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c need to delete the following code, which is no longer useful or works. - if(msegm.ne.12345)then - write(6,*)'reached bad section of code in DUMPIN. Stopping.' - stop - endif -cryne there is other info in the #beam component: - call txtnum(line,80,4,nget,bufr) - if(nget.ne.4)then - write(6,*)'(dumpin3)error: could not read 4 more #beam numbers' - stop - endif -c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) -cryne current: - curr0=bufr(1) - if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 -cryne units: - if(nint(bufr(3)).ne.0)then - magunits=0 - sclfreq=4.*asin(1.d0)*bufr(3) - write(6,*)'input frequency=',bufr(3),' Hz' - write(6,*)'scale frequency=',sclfreq,' rad/sec' - write(6,*)'dynamic units (not magnetostatic units) will be used' - slnew=c/sclfreq - write(6,*)'scale length specified in the input file is',sl,'m' - write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' - if(abs(sl-slnew)/sl .gt. 1.e-3)then - write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' - write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' - write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' - write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' - endif - sl=slnew - endif -cryne verbose to show progress: - iverbose=bufr(4) -cryne autoslicing (thick elements need an extra parameter): - iautosl=nint(bufr(2)) - if(iautosl.ne.0)then - write(6,*)'autoslicing of thick elements will be enabled.' - endif - if(iautosl.gt.0)then - write(6,*)'fixed # of slices/element will be = ',iautosl - endif - if(iautosl.lt.0)then - write(6,*)'variable # of slices/element will be used' - if(na.ne.0)then - write(6,*)'error: input file specifies variable # of' - write(6,*)'slices/element, but some elements have already' - write(6,*)'been read in. stopping.' - stop - endif - nrp(1,1)=nrp(1,1)+1 - nrp(1,2)=nrp(1,2)+1 - nrp(1,3)=nrp(1,3)+1 - nrp(1,4)=nrp(1,4)+1 - nrp(1,6)=nrp(1,6)+1 - nrp(1,8)=nrp(1,8)+1 - nrp(1,9)=nrp(1,9)+1 - nrp(1,10)=nrp(1,10)+1 - nrp(1,11)=nrp(1,11)+1 - nrp(1,12)=nrp(1,12)+1 - nrp(1,18)=nrp(1,18)+1 - nrp(1,20)=nrp(1,20)+1 - nrp(1,24)=nrp(1,24)+1 - nrp(1,30)=nrp(1,30)+1 - endif - goto 10 -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c -c error exit: - 290 continue - write(jof ,299) - write(jodf,299) - 299 format(1h ,'data input error detected by dumpin3 near #beam') - call myexit -c-------------------- -c #menu -c - 300 continue -! write(6,*)'here I am at #menu' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -! write(6,*)line(1:80) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if (msegm .ne. 3) goto 1 - 301 continue -c -c 11/4/02 new code to deal with 'call' statements: - if(trim(strarr(1)).eq.'call')then - write(6,*)'found a call statement in dumpin3' - call getsymb60(line,80,symb,istrtsym,nsymb) - write(6,*)'symb(1), symb(2), symb(3)=' - write(6,*)symb(1) - write(6,*)symb(2) - write(6,*)symb(3) - lftemp4=lf - lf=44 - call dumpin4(symb(3)) - close(lf) - lf=lftemp4 - goto 300 - endif - na=na+1 - if(na.gt.mnumax) then - write(jof ,399) mnumax - write(jodf,399) mnumax - 399 format(1h ,'error in dumpin:', & - & ' too many items (>= mnumax = ',i6,') elements in #menu') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,396) strarr(1) - write(jodf,396) strarr(1) - 396 format(' error detected by dumpin in #menu: name ', & - & a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! goto 300 - & ' the first definition will be ignored') - lmnlbl(indx)(1:1)='*' - endif -cryne - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then -c check if element/command name is present ( F. Neri 4/14/89 ): - if ( itot .lt. 2 ) then - write(jof ,1396) strarr(1) - write(jodf ,1396) strarr(1) - 1396 format(' error in #menu: ',a16,' has no type code!') - call myexit - endif - endif -cryne July 4 2002 if ( itot .gt. 2 ) then -cryne July 4 2002 write(jof ,1397) strarr(1) -cryne July 4 2002 write(jodf ,1397) strarr(1) -c1397 format(' error in #menu: ',a16,' has more than one type code!') -cryne July 4 2002 call myexit -cryne July 4 2002 endif -c new item in menu: - lmnlbl(na)=strarr(1) - initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse -c string is name of element/command type, look up element indices -cryne string=strarr(2) - if((trim(strarr(1)).eq.'beam').or. & - &(trim(strarr(1)).eq.'units'))then - string=strarr(1) - else - string=strarr(2) - endif - do 325 m = 1,9 - do 325 n = 1,nrpmax - if(string(1:16).eq.ltc(m,n)) then - nt1(na) = m - nt2(na) = n - goto 3344 - endif - 325 continue -c============= -cryne Sept 17, 2003 -c before declaring this an unknown element/command name, -c check to see if it is the name of an existing menu item -c since this is a functionality that MAD allows - call lookup(strarr(2),itype,indx) - if(itype.ne.1)goto 3226 -c this *is* the name of an existing menu item. - if(idproc.eq.0)then - write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) - endif - m = nt1(indx) - n = nt2(indx) - nt1(na) = m - nt2(na) = n - imax=nrp(m,n) - if(imax.ne.0)then - do i=1,imax - pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) - enddo - endif - icmax=ncp(m,n) - if(icmax.ne.0)then - do i=1,icmax - cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) - enddo - endif - initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f - goto 3344 - 3226 continue -c============= -c error: unknown element/command name - write(jof ,398)(strarr(j),j=1,2) - write(jodf,398)(strarr(j),j=1,2) - 398 format(1h ,'dumpin error at ',a16,': type code ',a16, & - &' not found.'/ & - & 1h ,'this item will be ignored') - na=na-1 - goto 300 - 3344 continue -! write(6,*)'found a menu element;string,m,n=',string(1:8),m,n -c read parameters. Number of parameters is given in nrp - imax=nrp(m,n) - icmax=ncp(m,n) - imaxold=nrpold(m,n) -c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax -cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 - if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. - & index(line,':').eq.0)goto 300 -cryne July 4, 2002 -c if using the Standard Input Format, the remaining parameters -c are stored in "line"; otherwise use the MaryLie input format: -c -c mpp(na) points to where the real parameters will be stored -c mppc(na) points to where the char*16 parameters will be stored - mpp(na) = mpprpoi - mppc(na) = mppcpoi -cryne 7/9/2002 if(itot.eq.2)then -c original MaryLie input format (icmax not relevant here): - if( (itot.eq.2) .and. (index(line,':').eq.0) )then -c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string - if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) -c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) -c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax - goto 300 -c error in parameter input - 390 write(jof ,397)lmnlbl(na) - write(jodf,397)lmnlbl(na) - 397 format(1h ,'(dumpin) parameter input error at element ',a16) - call myexit - endif -cryne July 4, 2002 -c if the code gets here, the Standard Input Format is being used -c to specify the elements in the menu: -c first delete the element name and type from the character string: -c write(6,*)'USING STANDARD INPUT FORMAT. LINE=' -c write(6,*)line -c write(6,*)'strarr(1),strarr(2)=' -c write(6,*)strarr(1) -c write(6,*)strarr(2) -ccc write(6,*)'will read params using SIF; imax,icmax=',imax,icmax -ccc write(6,*)'current values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi -cryne this could be more easily done with the f90 intrinsic len_trim() -c kkk1=len_trim(strarr(1))-1 - string=strarr(1) - kkk1=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk1=kkk1-1 - enddo - do i=1,80 - if(line(i:i+kkk1).eq.strarr(1))then - line(i:i+kkk1)=' ' - exit - endif - enddo -cryne kkk2=len_trim(strarr(2))-1 - string=strarr(2) - kkk2=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk2=kkk2-1 - enddo -c - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then - do i=1,80 - if(line(i:i+kkk2).eq.strarr(2))then - line(i:i+kkk2)=' ' - exit - endif - enddo - endif -c get rid of other unneccesary characters: - do i=1,80 -c if(line(i:i).eq.',')line(i:i)=' ' - if(line(i:i).eq.':')line(i:i)=' ' - enddo -c write(6,*)'TRIMMED LINE=' -c write(6,*)line - call stdinf(line,na,m,n,initparms,strarr(1)) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax -c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax -c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi - goto 300 -c -c-------------------- -c #lines,#lumps,#loops -c - 400 continue -! write(6,*)'here I am at #lines,lumps,loops' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 4) goto 1 - goto 410 - 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 5) goto 1 - goto 410 - 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 6) goto 1 -c - 410 nb=nb+1 - if(nb.gt.itmno)then - write(jof ,499) itmno - write(jodf,499) itmno - 499 format(1h ,'error in dumpin:', & - & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,497) ling(msegm),strarr(1) - write(jodf,497) ling(msegm),strarr(1) - 497 format(1x,'dumpin error in ', & - & a8,': name ',a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! if(msegm .eq.4) then -! goto 400 -! else if(msegm.eq.5) then -! goto 500 -! else if(msegm.eq.6) then -! goto 600 -! endif - & ' the first definition will be ignored') - ilbl(indx)(1:1)='*' - endif -c new item - ilbl(nb)=strarr(1) - imin=0 -cryne July 2002 Standard Input Format option: components might be on -cryne this record; check now -cryne Note: this assume that the 2nd string after the name is 'line', -cryne and so the 2nd string is ignored - if( (itot.eq.2) .and. (.not.(lcont)) )then - write(6,*)'error parsing line:' - write(6,*)'this should be a name alone, or' - write(6,*)'a name followed by LINE= followed by the components' - write(6,*)'input line =' - write(6,*)line - stop - endif - if(itot.gt.2)then -c write(6,*)'ITOT=',itot -c do i=1,itot -c write(6,*)i,narr(i),strarr(i) -c enddo - do 424 i=3,itot - icon(imin+i-2,nb)=strarr(i) - irep(imin+i-2,nb)=narr(i) - 424 continue - imin=imin+itot-2 - if(lcont)then - goto 420 - else - goto 426 - endif - endif -cryne remaining code is from original version: -c read components of item -c repeat... - 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if(imin+itot.gt.itmln)then - write(jof ,498) itmln,ilbl(nb) - write(jodf,498) itmln,ilbl(nb) - 498 format(1h ,'error in dumpin:', & - & ' too many entries (> itmln = ',i6,') in ',a16) - call myexit - endif -c store names and rep rates of components - do 425 i=1,itot - icon(imin+i,nb)=strarr(i) - irep(imin+i,nb)=narr(i) - 425 continue - imin=imin+itot - if(lcont) goto 420 -c ... until no more continuation lines -c-- -c now set length and type of element - 426 continue - ilen(nb)=imin - ityp(nb)=msegm-2 -c go back to appropriate component (segment) - if(msegm .eq.4) then - goto 400 - else if(msegm.eq.5) then - goto 500 - else if(msegm.eq.6) then - goto 600 - endif -c-------------------- -c #labor -c - 700 continue -! write(6,*)'here I am at #labor' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 7) goto 1 -c - noble=noble+1 - if(noble.gt.mlabor) then - write(jof ,799) mlabor - write(jodf,799) mlabor - 799 format(1h ,'error in dumpin:', & - & ' too many entries (>= mlabor = ',i6,') in #labor array') - call myexit - endif -c new task - latt(noble)=strarr(1) - num(noble)=narr(1) - goto 700 -c-------------------- -c #call (formerly #include) - 800 continue - write(6,*)' Start #call after user name: ',strarr(1) -c -ctm 9/01 modified to open and save up to 32 long #include file names -c - ninc = 0 - 810 read(lf,2000,end=1000) line -c -c check for next segment -c - if(index(line,'#').ne.0) then - itot = -1 - na2 = na - nb2 = nb - noble2 = noble - write(6,813) na2,nb2,noble2 - 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') - write(6,817) line - 817 format(' End #include with: ',a) - go to 10 - endif -c -ctm save file name and pointers before opening 1st include file -c - ninc = ninc + 1 - if(ninc.eq.1) then - na1 = na - nb1 = nb - noble1 = noble - write(6,877) na1,nb1,noble1 - 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') - endif -c -ctm skip leading blanks -c - lc = 1 - 880 if(line(lc:lc).eq.' ') then - lc = lc + 1 - go to 880 - endif - incfil(ninc) = line(lc:) - write(6,888) ninc,incfil(ninc) - 888 format(' include',i3,' : ',a) - call mlfinc(incfil(ninc)) - go to 810 -ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm if (leof) goto 1000 -ctm goto 1 -c-------------------- -c #const - 900 continue -! write(6,*)'here I am at #const' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if((msegm.eq.9).and.(itot.ne.1))then - write(6,*)'input error (#const)' - write(6,*)'trying to read a definition, but did not find a' - write(6,*)'character string at the beginning of this record:' - write(6,*)line(1:80) - stop - endif - if(msegm.eq.3)goto 301 - if(msegm.eq.4)goto 410 - if (msegm .ne. 9) goto 1 - 901 continue - call getconst(line,strval,nreturn) - if(nreturn.ne.1)then - write(6,*)'trouble parsing the following line:' - write(6,*)line - write(6,*)'continuing...' - goto 900 - endif - nconst=nconst+1 - if(nconst.gt.nconmax)then - write(6,*)'too many constants defined in the input file' - stop - endif - constr(nconst)=strarr(1) - conval(nconst)=strval -c write(6,*)'nconst,constr(nconst),conval(nconst)=' -c write(6,*)nconst,constr(nconst),conval(nconst) - goto 900 -c normal return at end of file - 1000 continue - close(44) - write(6,*)'returning from routine dumpin3' - return - end -c -c*********************************************************************** -************************************************************************ - subroutine dumpin4(uname) -c----------------------------------------------------------------------- -c This routine organizes the data input from file lf, the master input -c file. -c This file is divided into "components" beginning with a code "#..." -c The available codes are given in common/sharp/. -c In dumpin, they are numbered as they occur in that common. The -c component (segment) currently being read has number "msegm". -c The entries of the component "#menu" will be called "elements". -c The term "item" is used for entries of the components "#lines", -c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". -c -c Output is transferred via several commons. They are explained below. -c -c Written by Rob Ryne ca 1984 -c rewritten by Petra Schuett -c October 21, 1987 -c----------------------------------------------------------------------- - use beamdata - use acceldata - use lieaparam, only : monoms - use parallel, only : idproc - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- -c - include 'incmif.inc' - include 'codes.inc' - include 'files.inc' - common/mlunits/sclfreq,magunits - common/showme/iverbose - common/symbdef/isymbdef - dimension bufr(4) -c----------------------------------------------------------------------- -c local variables: - character*60 uname - character*16 strarr(40),string - character*80 line - character*16 fname - integer narr(40) - character*60 symb(40) - integer istrtsym(40) - logical leof,lcont,npound -cryne 8/15/2001 new code to read in a character string instead of numbers: -c----------------------------------------------------------------------- -cryne 9/26/02 -c this could go somewhere else too, but here is OK: -c isymbdef=-1 -c -cryne 7/20/2002 initialize character array so that, even if input is -c in the original MaryLie format, the mppc array will be filled with ' ' -c so that files are opened properly. (code checks for name=' ') -cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' -cryne 7/7/2002 -cryne initialize #const -cryne this should go somewhere else (near start of afro.f), but I am -cryne trying not to change MaryLie too much. -c call initcons -cryne 7/7/2002 additional mods to deal w/ huge number of comments -cryne eventually it would be a good idea to let the user specify whether -cryne or not comments should be printed in the pmif command -cryne -c start -c ignorcom=0 -cryne----- 15 Sept 2000 modified to check for input file: -ctm open(lf,file='fort.11',status='old',err=357) -c read(lf,2000,end=2001,err=2001) line - 2000 format(a) -c goto 4320 -c2001 continue -c write(6,*)'master input file does not exist or is empty' -c write(6,*)'type filename or to halt' -c read(5,2002)fname -c2002 format(a16) -c if(fname.eq.' ')call myexit - open(lf,file=uname,status='old',err=3000) - write(6,*)'successfully opened file ',uname - goto 4320 - 3000 continue - write(6,*)'(dumpin4) file does not exist. File name=.' - write(6,*)uname - write(6,*)'Halting.' - call myexit -c----------------------------------------------------------------------- - 4320 continue - leof = .false. -c rewind lf -cryne 11/04/02 msegm = -1 - msegm=3 -c curr0=-99999. -c-------------------- -c read first line of master input file (should set msegm) -c - 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm write(6,*) itot,' = itot after first REAREC' - write(6,*)'dumpin4: done reading line=' - write(6,*)line - write(6,*)'msegm,itot,leof=',msegm,itot,leof - if(strarr(1).eq.'call')then - write(6,*)'found call statement after 10 in dumpin4' - goto 301 - endif - if (leof) goto 1000 - if(msegm.eq.3)goto 301 - if(msegm.eq.4 .or. msegm.eq.5 .or. msegm.eq.6)goto 410 - if(msegm.eq.9)goto 901 -c check for the statement '#labor' - if(msegm.eq.7)goto 700 - write(6,*)'error: read the first line of input file but' - write(6,*)'cannot determine where to go in routine dumpin4' - call myexit -c-------------------- -c new component (segment) begins, branch to appropriate part of code -c - 1 goto(100,200,300,400,500,600,700,800,900),msegm -c -c error exit: - write(jof ,99) - write(jodf,99) - 99 format(1x,'problems at 1st goto of routine dumpin4; line=') - write(jof,*)line - write(jodf,*)line - call myexit -c-------------------- -c #comment -c - 100 continue -! write(6,*)'here I am at #comment' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 1) goto 1 - if(ignorcom.eq.1)goto 100 -c - npcom=npcom+1 - if(npcom.gt.maxcmt) then - write(jof ,199) maxcmt - write(jodf,199) maxcmt - 199 format(1x,'warning (dumpin4): ', & - & 'entries in #comment beyond line ',i6,' will be ignored') - ignorcom=1 - npcom=maxcmt - goto 100 - endif - mline(npcom)=line - goto 100 -c-------------------- -c #beam -c - 200 continue -! write(6,*)'here I am at #beam' - read(lf,*,err=290,end=1000)brho,gamm1,achg,sl -c computation of relativistic beta and gamma factors: - gamma=gamm1+1.d0 - stuff2=gamm1*(gamma+1.d0) - stuff1=sqrt(stuff2) - beta=stuff1/gamma - ts=sl/c -cryne 08/14/2001 the beam component may contain other info: -c first set defaults - magunits=1 - iverbose=0 - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -!? if(msegm.ne.2)goto 1 - if (npound) goto 1 - if(msegm.eq.3)goto 301 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if(msegm.ne.2) goto 1 -!? -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c need to delete the following code, which is no longer useful or works. - if(msegm.ne.12345)then - write(6,*)'reached bad section of code in DUMPIN. Stopping.' - stop - endif -cryne there is other info in the #beam component: - call txtnum(line,80,4,nget,bufr) - if(nget.ne.4)then - write(6,*)'(dumpin4)error: could not read 4 more #beam numbers' - stop - endif -c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) -cryne current: - curr0=bufr(1) - if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 -cryne units: - if(nint(bufr(3)).ne.0)then - magunits=0 - sclfreq=4.*asin(1.d0)*bufr(3) - write(6,*)'input frequency=',bufr(3),' Hz' - write(6,*)'scale frequency=',sclfreq,' rad/sec' - write(6,*)'dynamic units (not magnetostatic units) will be used' - slnew=c/sclfreq - write(6,*)'scale length specified in the input file is',sl,'m' - write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' - if(abs(sl-slnew)/sl .gt. 1.e-3)then - write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' - write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' - write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' - write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' - endif - sl=slnew - endif -cryne verbose to show progress: - iverbose=bufr(4) -cryne autoslicing (thick elements need an extra parameter): - iautosl=nint(bufr(2)) - if(iautosl.ne.0)then - write(6,*)'autoslicing of thick elements will be enabled.' - endif - if(iautosl.gt.0)then - write(6,*)'fixed # of slices/element will be = ',iautosl - endif - if(iautosl.lt.0)then - write(6,*)'variable # of slices/element will be used' - if(na.ne.0)then - write(6,*)'error: input file specifies variable # of' - write(6,*)'slices/element, but some elements have already' - write(6,*)'been read in. stopping.' - stop - endif - nrp(1,1)=nrp(1,1)+1 - nrp(1,2)=nrp(1,2)+1 - nrp(1,3)=nrp(1,3)+1 - nrp(1,4)=nrp(1,4)+1 - nrp(1,6)=nrp(1,6)+1 - nrp(1,8)=nrp(1,8)+1 - nrp(1,9)=nrp(1,9)+1 - nrp(1,10)=nrp(1,10)+1 - nrp(1,11)=nrp(1,11)+1 - nrp(1,12)=nrp(1,12)+1 - nrp(1,18)=nrp(1,18)+1 - nrp(1,20)=nrp(1,20)+1 - nrp(1,24)=nrp(1,24)+1 - nrp(1,30)=nrp(1,30)+1 - endif - goto 10 -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c -c error exit: - 290 continue - write(jof ,299) - write(jodf,299) - 299 format(1h ,'data input error detected by dumpin4 near #beam') - call myexit -c-------------------- -c #menu -c - 300 continue -! write(6,*)'here I am at #menu' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -! write(6,*)line(1:80) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if (msegm .ne. 3) goto 1 - 301 continue -c -c 11/4/02 new code to deal with 'call' statements: - if(trim(strarr(1)).eq.'call')then - write(6,*)'found a call statement in dumpin4' - call getsymb60(line,80,symb,istrtsym,nsymb) - write(6,*)'symb(1), symb(2), symb(3)=' - write(6,*)symb(1) - write(6,*)symb(2) - write(6,*)symb(3) - lftemp5=lf - lf=45 - call dumpin5(symb(3)) - close(lf) - lf=lftemp5 - goto 300 - endif - na=na+1 - if(na.gt.mnumax) then - write(jof ,399) mnumax - write(jodf,399) mnumax - 399 format(1h ,'error in dumpin4:', & - & ' too many items (>= mnumax = ',i6,') elements in #menu') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,396) strarr(1) - write(jodf,396) strarr(1) - 396 format(' error detected by dumpin4 in #menu: name ', & - & a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! goto 300 - & ' the first definition will be ignored') - lmnlbl(indx)(1:1)='*' - endif -cryne - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then -c check if element/command name is present ( F. Neri 4/14/89 ): - if ( itot .lt. 2 ) then - write(jof ,1396) strarr(1) - write(jodf ,1396) strarr(1) - 1396 format(' error in #menu: ',a16,' has no type code!') - call myexit - endif - endif -cryne July 4 2002 if ( itot .gt. 2 ) then -cryne July 4 2002 write(jof ,1397) strarr(1) -cryne July 4 2002 write(jodf ,1397) strarr(1) -c1397 format(' error in #menu: ',a16,' has more than one type code!') -cryne July 4 2002 call myexit -cryne July 4 2002 endif -c new item in menu: - lmnlbl(na)=strarr(1) - initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse -c string is name of element/command type, look up element indices -cryne string=strarr(2) - if((trim(strarr(1)).eq.'beam').or. & - &(trim(strarr(1)).eq.'units'))then - string=strarr(1) - else - string=strarr(2) - endif - do 325 m = 1,9 - do 325 n = 1,nrpmax - if(string(1:16).eq.ltc(m,n)) then - nt1(na) = m - nt2(na) = n - goto 3344 - endif - 325 continue -c============= -cryne Sept 17, 2003 -c before declaring this an unknown element/command name, -c check to see if it is the name of an existing menu item -c since this is a functionality that MAD allows - call lookup(strarr(2),itype,indx) - if(itype.ne.1)goto 3226 -c this *is* the name of an existing menu item. - if(idproc.eq.0)then - write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) - endif - m = nt1(indx) - n = nt2(indx) - nt1(na) = m - nt2(na) = n - imax=nrp(m,n) - if(imax.ne.0)then - do i=1,imax - pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) - enddo - endif - icmax=ncp(m,n) - if(icmax.ne.0)then - do i=1,icmax - cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) - enddo - endif - initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f - goto 3344 - 3226 continue -c============= -c error: unknown element/command name - write(jof ,398)(strarr(j),j=1,2) - write(jodf,398)(strarr(j),j=1,2) - 398 format(1h ,'dumpin4 error at ',a16,': type code ',a16, & - &' not found.'/ & - & 1h ,'this item will be ignored') - na=na-1 - goto 300 - 3344 continue -! write(6,*)'found a menu element;string,m,n=',string(1:8),m,n -c read parameters. Number of parameters is given in nrp - imax=nrp(m,n) - icmax=ncp(m,n) - imaxold=nrpold(m,n) -c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax -cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 - if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. - & index(line,':').eq.0)goto 300 -cryne July 4, 2002 -c if using the Standard Input Format, the remaining parameters -c are stored in "line"; otherwise use the MaryLie input format: -c -c mpp(na) points to where the real parameters will be stored -c mppc(na) points to where the char*16 parameters will be stored - mpp(na) = mpprpoi - mppc(na) = mppcpoi -cryne 7/9/2002 if(itot.eq.2)then -c original MaryLie input format (icmax not relevant here): - if( (itot.eq.2) .and. (index(line,':').eq.0) )then -c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string - if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) -c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) -c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax - goto 300 -c error in parameter input - 390 write(jof ,397)lmnlbl(na) - write(jodf,397)lmnlbl(na) - 397 format(1h ,'(dumpin4) parameter input error at element ',a16) - call myexit - endif -cryne July 4, 2002 -c if the code gets here, the Standard Input Format is being used -c to specify the elements in the menu: -c first delete the element name and type from the character string: -c write(6,*)'USING STANDARD INPUT FORMAT. LINE=' -c write(6,*)line -c write(6,*)'strarr(1),strarr(2)=' -c write(6,*)strarr(1) -c write(6,*)strarr(2) -ccc write(6,*)'will read params using SIF; imax,icmax=',imax,icmax -ccc write(6,*)'current values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi -cryne this could be more easily done with the f90 intrinsic len_trim() -c kkk1=len_trim(strarr(1))-1 - string=strarr(1) - kkk1=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk1=kkk1-1 - enddo - do i=1,80 - if(line(i:i+kkk1).eq.strarr(1))then - line(i:i+kkk1)=' ' - exit - endif - enddo -cryne kkk2=len_trim(strarr(2))-1 - string=strarr(2) - kkk2=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk2=kkk2-1 - enddo -c - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then - do i=1,80 - if(line(i:i+kkk2).eq.strarr(2))then - line(i:i+kkk2)=' ' - exit - endif - enddo - endif -c get rid of other unneccesary characters: - do i=1,80 -c if(line(i:i).eq.',')line(i:i)=' ' - if(line(i:i).eq.':')line(i:i)=' ' - enddo -c write(6,*)'TRIMMED LINE=' -c write(6,*)line - call stdinf(line,na,m,n,initparms,strarr(1)) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax -c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax -c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi - goto 300 -c -c-------------------- -c #lines,#lumps,#loops -c - 400 continue -! write(6,*)'here I am at #lines,lumps,loops' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 4) goto 1 - goto 410 - 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 5) goto 1 - goto 410 - 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 6) goto 1 -c - 410 nb=nb+1 - if(nb.gt.itmno)then - write(jof ,499) itmno - write(jodf,499) itmno - 499 format(1h ,'error in dumpin4:', & - & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,497) ling(msegm),strarr(1) - write(jodf,497) ling(msegm),strarr(1) - 497 format(1x,'dumpin4 error in ', & - & a8,': name ',a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! if(msegm .eq.4) then -! goto 400 -! else if(msegm.eq.5) then -! goto 500 -! else if(msegm.eq.6) then -! goto 600 -! endif - & ' the first definition will be ignored') - ilbl(indx)(1:1)='*' - endif -c new item - ilbl(nb)=strarr(1) - imin=0 -cryne July 2002 Standard Input Format option: components might be on -cryne this record; check now -cryne Note: this assume that the 2nd string after the name is 'line', -cryne and so the 2nd string is ignored - if( (itot.eq.2) .and. (.not.(lcont)) )then - write(6,*)'error parsing line:' - write(6,*)'this should be a name alone, or' - write(6,*)'a name followed by LINE= followed by the components' - write(6,*)'input line =' - write(6,*)line - stop - endif - if(itot.gt.2)then -c write(6,*)'ITOT=',itot -c do i=1,itot -c write(6,*)i,narr(i),strarr(i) -c enddo - do 424 i=3,itot - icon(imin+i-2,nb)=strarr(i) - irep(imin+i-2,nb)=narr(i) - 424 continue - imin=imin+itot-2 - if(lcont)then - goto 420 - else - goto 426 - endif - endif -cryne remaining code is from original version: -c read components of item -c repeat... - 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if(imin+itot.gt.itmln)then - write(jof ,498) itmln,ilbl(nb) - write(jodf,498) itmln,ilbl(nb) - 498 format(1h ,'error in dumpin4:', & - & ' too many entries (> itmln = ',i6,') in ',a16) - call myexit - endif -c store names and rep rates of components - do 425 i=1,itot - icon(imin+i,nb)=strarr(i) - irep(imin+i,nb)=narr(i) - 425 continue - imin=imin+itot - if(lcont) goto 420 -c ... until no more continuation lines -c-- -c now set length and type of element - 426 continue - ilen(nb)=imin - ityp(nb)=msegm-2 -c go back to appropriate component (segment) - if(msegm .eq.4) then - goto 400 - else if(msegm.eq.5) then - goto 500 - else if(msegm.eq.6) then - goto 600 - endif -c-------------------- -c #labor -c - 700 continue -! write(6,*)'here I am at #labor' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 7) goto 1 -c - noble=noble+1 - if(noble.gt.mlabor) then - write(jof ,799) mlabor - write(jodf,799) mlabor - 799 format(1h ,'error in dumpin4:', & - & ' too many entries (>= mlabor = ',i6,') in #labor array') - call myexit - endif -c new task - latt(noble)=strarr(1) - num(noble)=narr(1) - goto 700 -c-------------------- -c #call (formerly #include) - 800 continue - write(6,*)' Start #call after user name: ',strarr(1) -c -ctm 9/01 modified to open and save up to 32 long #include file names -c - ninc = 0 - 810 read(lf,2000,end=1000) line -c -c check for next segment -c - if(index(line,'#').ne.0) then - itot = -1 - na2 = na - nb2 = nb - noble2 = noble - write(6,813) na2,nb2,noble2 - 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') - write(6,817) line - 817 format(' End #include with: ',a) - go to 10 - endif -c -ctm save file name and pointers before opening 1st include file -c - ninc = ninc + 1 - if(ninc.eq.1) then - na1 = na - nb1 = nb - noble1 = noble - write(6,877) na1,nb1,noble1 - 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') - endif -c -ctm skip leading blanks -c - lc = 1 - 880 if(line(lc:lc).eq.' ') then - lc = lc + 1 - go to 880 - endif - incfil(ninc) = line(lc:) - write(6,888) ninc,incfil(ninc) - 888 format(' include',i3,' : ',a) - call mlfinc(incfil(ninc)) - go to 810 -ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm if (leof) goto 1000 -ctm goto 1 -c-------------------- -c #const - 900 continue -! write(6,*)'here I am at #const' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if((msegm.eq.9).and.(itot.ne.1))then - write(6,*)'input error (#const)' - write(6,*)'trying to read a definition, but did not find a' - write(6,*)'character string at the beginning of this record:' - write(6,*)line(1:80) - stop - endif - if(msegm.eq.3)goto 301 - if(msegm.eq.4)goto 410 - if (msegm .ne. 9) goto 1 - 901 continue - call getconst(line,strval,nreturn) - if(nreturn.ne.1)then - write(6,*)'trouble parsing the following line:' - write(6,*)line - write(6,*)'continuing...' - goto 900 - endif - nconst=nconst+1 - if(nconst.gt.nconmax)then - write(6,*)'too many constants defined in the input file' - stop - endif - constr(nconst)=strarr(1) - conval(nconst)=strval -c write(6,*)'nconst,constr(nconst),conval(nconst)=' -c write(6,*)nconst,constr(nconst),conval(nconst) - goto 900 -c normal return at end of file - 1000 continue - close(44) - write(6,*)'returning from routine dumpin4' - return - end -c -c*********************************************************************** -************************************************************************ - subroutine dumpin5(uname) -c----------------------------------------------------------------------- -c This routine organizes the data input from file lf, the master input -c file. -c This file is divided into "components" beginning with a code "#..." -c The available codes are given in common/sharp/. -c In dumpin, they are numbered as they occur in that common. The -c component (segment) currently being read has number "msegm". -c The entries of the component "#menu" will be called "elements". -c The term "item" is used for entries of the components "#lines", -c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". -c -c Output is transferred via several commons. They are explained below. -c -c Written by Rob Ryne ca 1984 -c rewritten by Petra Schuett -c October 21, 1987 -c----------------------------------------------------------------------- - use beamdata - use acceldata - use lieaparam, only : monoms - use parallel, only : idproc - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- -c - include 'incmif.inc' - include 'codes.inc' - include 'files.inc' - common/mlunits/sclfreq,magunits - common/showme/iverbose - common/symbdef/isymbdef - dimension bufr(4) -c----------------------------------------------------------------------- -c local variables: - character*60 uname - character*16 strarr(40),string - character*80 line - character*16 fname - integer narr(40) - character*60 symb(40) - integer istrtsym(40) - logical leof,lcont,npound -cryne 8/15/2001 new code to read in a character string instead of numbers: -c----------------------------------------------------------------------- -cryne 9/26/02 -c this could go somewhere else too, but here is OK: -c isymbdef=-1 -c -cryne 7/20/2002 initialize character array so that, even if input is -c in the original MaryLie format, the mppc array will be filled with ' ' -c so that files are opened properly. (code checks for name=' ') -cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' -cryne 7/7/2002 -cryne initialize #const -cryne this should go somewhere else (near start of afro.f), but I am -cryne trying not to change MaryLie too much. -c call initcons -cryne 7/7/2002 additional mods to deal w/ huge number of comments -cryne eventually it would be a good idea to let the user specify whether -cryne or not comments should be printed in the pmif command -cryne -c start -c ignorcom=0 -cryne----- 15 Sept 2000 modified to check for input file: -ctm open(lf,file='fort.11',status='old',err=357) -c read(lf,2000,end=2001,err=2001) line - 2000 format(a) -c goto 4320 -c2001 continue -c write(6,*)'master input file does not exist or is empty' -c write(6,*)'type filename or to halt' -c read(5,2002)fname -c2002 format(a16) -c if(fname.eq.' ')call myexit - open(lf,file=uname,status='old',err=3000) - write(6,*)'successfully opened file ',uname - goto 4320 - 3000 continue - write(6,*)'(dumpin5) file does not exist. File name=.' - write(6,*)uname - write(6,*)'Halting.' - call myexit -c----------------------------------------------------------------------- - 4320 continue - leof = .false. -c rewind lf -cryne 11/04/02 msegm = -1 - msegm=3 -c curr0=-99999. -c-------------------- -c read first line of master input file (should set msegm) -c - 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm write(6,*) itot,' = itot after first REAREC' - write(6,*)'dumpin5: done reading line=' - write(6,*)line - write(6,*)'msegm,itot,leof=',msegm,itot,leof - if(strarr(1).eq.'call')then - write(6,*)'found call statement after 10 in dumpin5' - goto 301 - endif - if (leof) goto 1000 - if(msegm.eq.3)goto 301 - if(msegm.eq.4 .or. msegm.eq.5 .or. msegm.eq.6)goto 410 - if(msegm.eq.9)goto 901 -c check for the statement '#labor' - if(msegm.eq.7)goto 700 - write(6,*)'error: read the first line of input file but' - write(6,*)'cannot determine where to go in routine dumpin5' - call myexit -c-------------------- -c new component (segment) begins, branch to appropriate part of code -c - 1 goto(100,200,300,400,500,600,700,800,900),msegm -c -c error exit: - write(jof ,99) - write(jodf,99) - 99 format(1x,'problems at 1st goto of routine dumpin5; line=') - write(jof,*)line - write(jodf,*)line - call myexit -c-------------------- -c #comment -c - 100 continue -! write(6,*)'here I am at #comment' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 1) goto 1 - if(ignorcom.eq.1)goto 100 -c - npcom=npcom+1 - if(npcom.gt.maxcmt) then - write(jof ,199) maxcmt - write(jodf,199) maxcmt - 199 format(1x,'warning (dumpin5): ', & - & 'entries in #comment beyond line ',i6,' will be ignored') - ignorcom=1 - npcom=maxcmt - goto 100 - endif - mline(npcom)=line - goto 100 -c-------------------- -c #beam -c - 200 continue -! write(6,*)'here I am at #beam' - read(lf,*,err=290,end=1000)brho,gamm1,achg,sl -c computation of relativistic beta and gamma factors: - gamma=gamm1+1.d0 - stuff2=gamm1*(gamma+1.d0) - stuff1=sqrt(stuff2) - beta=stuff1/gamma - ts=sl/c -cryne 08/14/2001 the beam component may contain other info: -c first set defaults - magunits=1 - iverbose=0 - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -!? if(msegm.ne.2)goto 1 - if (npound) goto 1 - if(msegm.eq.3)goto 301 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if(msegm.ne.2) goto 1 -!? -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c need to delete the following code, which is no longer useful or works. - if(msegm.ne.12345)then - write(6,*)'reached bad section of code in DUMPIN. Stopping.' - stop - endif -cryne there is other info in the #beam component: - call txtnum(line,80,4,nget,bufr) - if(nget.ne.4)then - write(6,*)'(dumpin5)error: could not read 4 more #beam numbers' - stop - endif -c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) -cryne current: - curr0=bufr(1) - if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 -cryne units: - if(nint(bufr(3)).ne.0)then - magunits=0 - sclfreq=4.*asin(1.d0)*bufr(3) - write(6,*)'input frequency=',bufr(3),' Hz' - write(6,*)'scale frequency=',sclfreq,' rad/sec' - write(6,*)'dynamic units (not magnetostatic units) will be used' - slnew=c/sclfreq - write(6,*)'scale length specified in the input file is',sl,'m' - write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' - if(abs(sl-slnew)/sl .gt. 1.e-3)then - write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' - write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' - write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' - write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' - endif - sl=slnew - endif -cryne verbose to show progress: - iverbose=bufr(4) -cryne autoslicing (thick elements need an extra parameter): - iautosl=nint(bufr(2)) - if(iautosl.ne.0)then - write(6,*)'autoslicing of thick elements will be enabled.' - endif - if(iautosl.gt.0)then - write(6,*)'fixed # of slices/element will be = ',iautosl - endif - if(iautosl.lt.0)then - write(6,*)'variable # of slices/element will be used' - if(na.ne.0)then - write(6,*)'error: input file specifies variable # of' - write(6,*)'slices/element, but some elements have already' - write(6,*)'been read in. stopping.' - stop - endif - nrp(1,1)=nrp(1,1)+1 - nrp(1,2)=nrp(1,2)+1 - nrp(1,3)=nrp(1,3)+1 - nrp(1,4)=nrp(1,4)+1 - nrp(1,6)=nrp(1,6)+1 - nrp(1,8)=nrp(1,8)+1 - nrp(1,9)=nrp(1,9)+1 - nrp(1,10)=nrp(1,10)+1 - nrp(1,11)=nrp(1,11)+1 - nrp(1,12)=nrp(1,12)+1 - nrp(1,18)=nrp(1,18)+1 - nrp(1,20)=nrp(1,20)+1 - nrp(1,24)=nrp(1,24)+1 - nrp(1,30)=nrp(1,30)+1 - endif - goto 10 -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c -c error exit: - 290 continue - write(jof ,299) - write(jodf,299) - 299 format(1h ,'data input error detected by dumpin5 near #beam') - call myexit -c-------------------- -c #menu -c - 300 continue -! write(6,*)'here I am at #menu' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -! write(6,*)line(1:80) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if (msegm .ne. 3) goto 1 - 301 continue -c -c 11/4/02 new code to deal with 'call' statements: - if(trim(strarr(1)).eq.'call')then - write(6,*)'found a call statement in dumpin5' - call getsymb60(line,80,symb,istrtsym,nsymb) - write(6,*)'symb(1), symb(2), symb(3)=' - write(6,*)symb(1) - write(6,*)symb(2) - write(6,*)symb(3) - lftemp6=lf - lf=46 - call dumpin6(symb(3)) - close(lf) - lf=lftemp6 - goto 300 - endif - na=na+1 - if(na.gt.mnumax) then - write(jof ,399) mnumax - write(jodf,399) mnumax - 399 format(1h ,'error in dumpin5:', & - & ' too many items (>= mnumax = ',i6,') elements in #menu') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,396) strarr(1) - write(jodf,396) strarr(1) - 396 format(' error detected by dumpin5 in #menu: name ', & - & a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! goto 300 - & ' the first definition will be ignored') - lmnlbl(indx)(1:1)='*' - endif -cryne - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then -c check if element/command name is present ( F. Neri 4/14/89 ): - if ( itot .lt. 2 ) then - write(jof ,1396) strarr(1) - write(jodf ,1396) strarr(1) - 1396 format(' error in #menu: ',a16,' has no type code!') - call myexit - endif - endif -cryne July 4 2002 if ( itot .gt. 2 ) then -cryne July 4 2002 write(jof ,1397) strarr(1) -cryne July 4 2002 write(jodf ,1397) strarr(1) -c1397 format(' error in #menu: ',a16,' has more than one type code!') -cryne July 4 2002 call myexit -cryne July 4 2002 endif -c new item in menu: - lmnlbl(na)=strarr(1) - initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse -c string is name of element/command type, look up element indices -cryne string=strarr(2) - if((trim(strarr(1)).eq.'beam').or. & - &(trim(strarr(1)).eq.'units'))then - string=strarr(1) - else - string=strarr(2) - endif - do 325 m = 1,9 - do 325 n = 1,nrpmax - if(string(1:16).eq.ltc(m,n)) then - nt1(na) = m - nt2(na) = n - goto 3344 - endif - 325 continue -c============= -cryne Sept 17, 2003 -c before declaring this an unknown element/command name, -c check to see if it is the name of an existing menu item -c since this is a functionality that MAD allows - call lookup(strarr(2),itype,indx) - if(itype.ne.1)goto 3226 -c this *is* the name of an existing menu item. - if(idproc.eq.0)then - write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) - endif - m = nt1(indx) - n = nt2(indx) - nt1(na) = m - nt2(na) = n - imax=nrp(m,n) - if(imax.ne.0)then - do i=1,imax - pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) - enddo - endif - icmax=ncp(m,n) - if(icmax.ne.0)then - do i=1,icmax - cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) - enddo - endif - initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f - goto 3344 - 3226 continue -c============= -c error: unknown element/command name - write(jof ,398)(strarr(j),j=1,2) - write(jodf,398)(strarr(j),j=1,2) - 398 format(1h ,'dumpin5 error at ',a16,': type code ',a16, & - &' not found.'/ & - & 1h ,'this item will be ignored') - na=na-1 - goto 300 - 3344 continue -! write(6,*)'found a menu element;string,m,n=',string(1:8),m,n -c read parameters. Number of parameters is given in nrp - imax=nrp(m,n) - icmax=ncp(m,n) - imaxold=nrpold(m,n) -c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax -cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 - if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. - & index(line,':').eq.0)goto 300 -cryne July 4, 2002 -c if using the Standard Input Format, the remaining parameters -c are stored in "line"; otherwise use the MaryLie input format: -c -c mpp(na) points to where the real parameters will be stored -c mppc(na) points to where the char*16 parameters will be stored - mpp(na) = mpprpoi - mppc(na) = mppcpoi -cryne 7/9/2002 if(itot.eq.2)then -c original MaryLie input format (icmax not relevant here): - if( (itot.eq.2) .and. (index(line,':').eq.0) )then -c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string - if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) -c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) -c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax - goto 300 -c error in parameter input - 390 write(jof ,397)lmnlbl(na) - write(jodf,397)lmnlbl(na) - 397 format(1h ,'(dumpin5) parameter input error at element ',a16) - call myexit - endif -cryne July 4, 2002 -c if the code gets here, the Standard Input Format is being used -c to specify the elements in the menu: -c first delete the element name and type from the character string: -c write(6,*)'USING STANDARD INPUT FORMAT. LINE=' -c write(6,*)line -c write(6,*)'strarr(1),strarr(2)=' -c write(6,*)strarr(1) -c write(6,*)strarr(2) -ccc write(6,*)'will read params using SIF; imax,icmax=',imax,icmax -ccc write(6,*)'current values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi -cryne this could be more easily done with the f90 intrinsic len_trim() -c kkk1=len_trim(strarr(1))-1 - string=strarr(1) - kkk1=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk1=kkk1-1 - enddo - do i=1,80 - if(line(i:i+kkk1).eq.strarr(1))then - line(i:i+kkk1)=' ' - exit - endif - enddo -cryne kkk2=len_trim(strarr(2))-1 - string=strarr(2) - kkk2=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk2=kkk2-1 - enddo -c - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then - do i=1,80 - if(line(i:i+kkk2).eq.strarr(2))then - line(i:i+kkk2)=' ' - exit - endif - enddo - endif -c get rid of other unneccesary characters: - do i=1,80 -c if(line(i:i).eq.',')line(i:i)=' ' - if(line(i:i).eq.':')line(i:i)=' ' - enddo -c write(6,*)'TRIMMED LINE=' -c write(6,*)line - call stdinf(line,na,m,n,initparms,strarr(1)) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax -c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax -c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi - goto 300 -c -c-------------------- -c #lines,#lumps,#loops -c - 400 continue -! write(6,*)'here I am at #lines,lumps,loops' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 4) goto 1 - goto 410 - 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 5) goto 1 - goto 410 - 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 6) goto 1 -c - 410 nb=nb+1 - if(nb.gt.itmno)then - write(jof ,499) itmno - write(jodf,499) itmno - 499 format(1h ,'error in dumpin5:', & - & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,497) ling(msegm),strarr(1) - write(jodf,497) ling(msegm),strarr(1) - 497 format(1x,'dumpin5 error in ', & - & a8,': name ',a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! if(msegm .eq.4) then -! goto 400 -! else if(msegm.eq.5) then -! goto 500 -! else if(msegm.eq.6) then -! goto 600 -! endif - & ' the first definition will be ignored') - ilbl(indx)(1:1)='*' - endif -c new item - ilbl(nb)=strarr(1) - imin=0 -cryne July 2002 Standard Input Format option: components might be on -cryne this record; check now -cryne Note: this assume that the 2nd string after the name is 'line', -cryne and so the 2nd string is ignored - if( (itot.eq.2) .and. (.not.(lcont)) )then - write(6,*)'error parsing line:' - write(6,*)'this should be a name alone, or' - write(6,*)'a name followed by LINE= followed by the components' - write(6,*)'input line =' - write(6,*)line - stop - endif - if(itot.gt.2)then -c write(6,*)'ITOT=',itot -c do i=1,itot -c write(6,*)i,narr(i),strarr(i) -c enddo - do 424 i=3,itot - icon(imin+i-2,nb)=strarr(i) - irep(imin+i-2,nb)=narr(i) - 424 continue - imin=imin+itot-2 - if(lcont)then - goto 420 - else - goto 426 - endif - endif -cryne remaining code is from original version: -c read components of item -c repeat... - 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if(imin+itot.gt.itmln)then - write(jof ,498) itmln,ilbl(nb) - write(jodf,498) itmln,ilbl(nb) - 498 format(1h ,'error in dumpin5:', & - & ' too many entries (> itmln = ',i6,') in ',a16) - call myexit - endif -c store names and rep rates of components - do 425 i=1,itot - icon(imin+i,nb)=strarr(i) - irep(imin+i,nb)=narr(i) - 425 continue - imin=imin+itot - if(lcont) goto 420 -c ... until no more continuation lines -c-- -c now set length and type of element - 426 continue - ilen(nb)=imin - ityp(nb)=msegm-2 -c go back to appropriate component (segment) - if(msegm .eq.4) then - goto 400 - else if(msegm.eq.5) then - goto 500 - else if(msegm.eq.6) then - goto 600 - endif -c-------------------- -c #labor -c - 700 continue -! write(6,*)'here I am at #labor' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 7) goto 1 -c - noble=noble+1 - if(noble.gt.mlabor) then - write(jof ,799) mlabor - write(jodf,799) mlabor - 799 format(1h ,'error in dumpin5:', & - & ' too many entries (>= mlabor = ',i6,') in #labor array') - call myexit - endif -c new task - latt(noble)=strarr(1) - num(noble)=narr(1) - goto 700 -c-------------------- -c #call (formerly #include) - 800 continue - write(6,*)' Start #call after user name: ',strarr(1) -c -ctm 9/01 modified to open and save up to 32 long #include file names -c - ninc = 0 - 810 read(lf,2000,end=1000) line -c -c check for next segment -c - if(index(line,'#').ne.0) then - itot = -1 - na2 = na - nb2 = nb - noble2 = noble - write(6,813) na2,nb2,noble2 - 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') - write(6,817) line - 817 format(' End #include with: ',a) - go to 10 - endif -c -ctm save file name and pointers before opening 1st include file -c - ninc = ninc + 1 - if(ninc.eq.1) then - na1 = na - nb1 = nb - noble1 = noble - write(6,877) na1,nb1,noble1 - 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') - endif -c -ctm skip leading blanks -c - lc = 1 - 880 if(line(lc:lc).eq.' ') then - lc = lc + 1 - go to 880 - endif - incfil(ninc) = line(lc:) - write(6,888) ninc,incfil(ninc) - 888 format(' include',i3,' : ',a) - call mlfinc(incfil(ninc)) - go to 810 -ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm if (leof) goto 1000 -ctm goto 1 -c-------------------- -c #const - 900 continue -! write(6,*)'here I am at #const' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if((msegm.eq.9).and.(itot.ne.1))then - write(6,*)'input error (#const)' - write(6,*)'trying to read a definition, but did not find a' - write(6,*)'character string at the beginning of this record:' - write(6,*)line(1:80) - stop - endif - if(msegm.eq.3)goto 301 - if(msegm.eq.4)goto 410 - if (msegm .ne. 9) goto 1 - 901 continue - call getconst(line,strval,nreturn) - if(nreturn.ne.1)then - write(6,*)'trouble parsing the following line:' - write(6,*)line - write(6,*)'continuing...' - goto 900 - endif - nconst=nconst+1 - if(nconst.gt.nconmax)then - write(6,*)'too many constants defined in the input file' - stop - endif - constr(nconst)=strarr(1) - conval(nconst)=strval -c write(6,*)'nconst,constr(nconst),conval(nconst)=' -c write(6,*)nconst,constr(nconst),conval(nconst) - goto 900 -c normal return at end of file - 1000 continue - close(44) - write(6,*)'returning from routine dumpin5' - return - end -c -c*********************************************************************** -************************************************************************ - subroutine dumpin6(uname) -c----------------------------------------------------------------------- -c This routine organizes the data input from file lf, the master input -c file. -c This file is divided into "components" beginning with a code "#..." -c The available codes are given in common/sharp/. -c In dumpin, they are numbered as they occur in that common. The -c component (segment) currently being read has number "msegm". -c The entries of the component "#menu" will be called "elements". -c The term "item" is used for entries of the components "#lines", -c "#lumps" and "#loops". Entries in "#labor" will be called "tasks". -c -c Output is transferred via several commons. They are explained below. -c -c Written by Rob Ryne ca 1984 -c rewritten by Petra Schuett -c October 21, 1987 -c----------------------------------------------------------------------- - use beamdata - use acceldata - use lieaparam, only : monoms - use parallel, only : idproc - include 'impli.inc' -c----------------------------------------------------------------------- -c common blocks -c----------------------------------------------------------------------- -c - include 'incmif.inc' - include 'codes.inc' - include 'files.inc' - common/mlunits/sclfreq,magunits - common/showme/iverbose - common/symbdef/isymbdef - dimension bufr(4) -c----------------------------------------------------------------------- -c local variables: - character*60 uname - character*16 strarr(40),string - character*80 line - character*16 fname - integer narr(40) - character*60 symb(40) - integer istrtsym(40) - logical leof,lcont,npound -cryne 8/15/2001 new code to read in a character string instead of numbers: -c----------------------------------------------------------------------- -cryne 9/26/02 -c this could go somewhere else too, but here is OK: -c isymbdef=-1 -c -cryne 7/20/2002 initialize character array so that, even if input is -c in the original MaryLie format, the mppc array will be filled with ' ' -c so that files are opened properly. (code checks for name=' ') -cryne 7/23/2002 done in new_acceldata cmenu(1:mnumax)=' ' -cryne 7/7/2002 -cryne initialize #const -cryne this should go somewhere else (near start of afro.f), but I am -cryne trying not to change MaryLie too much. -c call initcons -cryne 7/7/2002 additional mods to deal w/ huge number of comments -cryne eventually it would be a good idea to let the user specify whether -cryne or not comments should be printed in the pmif command -cryne -c start -c ignorcom=0 -cryne----- 15 Sept 2000 modified to check for input file: -ctm open(lf,file='fort.11',status='old',err=357) -c read(lf,2000,end=2001,err=2001) line - 2000 format(a) -c goto 4320 -c2001 continue -c write(6,*)'master input file does not exist or is empty' -c write(6,*)'type filename or to halt' -c read(5,2002)fname -c2002 format(a16) -c if(fname.eq.' ')call myexit - open(lf,file=uname,status='old',err=3000) - write(6,*)'successfully opened file ',uname - goto 4320 - 3000 continue - write(6,*)'(dumpin6) file does not exist. File name=.' - write(6,*)uname - write(6,*)'Halting.' - call myexit -c----------------------------------------------------------------------- - 4320 continue - leof = .false. -c rewind lf -cryne 11/04/02 msegm = -1 - msegm=3 -c curr0=-99999. -c-------------------- -c read first line of master input file (should set msegm) -c - 10 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm write(6,*) itot,' = itot after first REAREC' - write(6,*)'dumpin6: done reading line=' - write(6,*)line - write(6,*)'msegm,itot,leof=',msegm,itot,leof - if(strarr(1).eq.'call')then - write(6,*)'found call statement after 10 in dumpin6' - goto 301 - endif - if (leof) goto 1000 - if(msegm.eq.3)goto 301 - if(msegm.eq.4 .or. msegm.eq.5 .or. msegm.eq.6)goto 410 - if(msegm.eq.9)goto 901 -c check for the statement '#labor' - if(msegm.eq.7)goto 700 - write(6,*)'error: read the first line of input file but' - write(6,*)'cannot determine where to go in routine dumpin6' - call myexit -c-------------------- -c new component (segment) begins, branch to appropriate part of code -c - 1 goto(100,200,300,400,500,600,700,800,900),msegm -c -c error exit: - write(jof ,99) - write(jodf,99) - 99 format(1x,'problems at 1st goto of routine dumpin6; line=') - write(jof,*)line - write(jodf,*)line - call myexit -c-------------------- -c #comment -c - 100 continue -! write(6,*)'here I am at #comment' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 1) goto 1 - if(ignorcom.eq.1)goto 100 -c - npcom=npcom+1 - if(npcom.gt.maxcmt) then - write(jof ,199) maxcmt - write(jodf,199) maxcmt - 199 format(1x,'warning (dumpin6): ', & - & 'entries in #comment beyond line ',i6,' will be ignored') - ignorcom=1 - npcom=maxcmt - goto 100 - endif - mline(npcom)=line - goto 100 -c-------------------- -c #beam -c - 200 continue -! write(6,*)'here I am at #beam' - read(lf,*,err=290,end=1000)brho,gamm1,achg,sl -c computation of relativistic beta and gamma factors: - gamma=gamm1+1.d0 - stuff2=gamm1*(gamma+1.d0) - stuff1=sqrt(stuff2) - beta=stuff1/gamma - ts=sl/c -cryne 08/14/2001 the beam component may contain other info: -c first set defaults - magunits=1 - iverbose=0 - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -!? if(msegm.ne.2)goto 1 - if (npound) goto 1 - if(msegm.eq.3)goto 301 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if(msegm.ne.2) goto 1 -!? -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c need to delete the following code, which is no longer useful or works. - if(msegm.ne.12345)then - write(6,*)'reached bad section of code in DUMPIN. Stopping.' - stop - endif -cryne there is other info in the #beam component: - call txtnum(line,80,4,nget,bufr) - if(nget.ne.4)then - write(6,*)'(dumpin6)error: could not read 4 more #beam numbers' - stop - endif -c write(6,*)'bufr(1),bufr(2),bufr(3)=',bufr(1),bufr(2),bufr(3) -cryne current: - curr0=bufr(1) - if(curr0.ne.-99999.)write(6,*)'beam current = ',curr0 -cryne units: - if(nint(bufr(3)).ne.0)then - magunits=0 - sclfreq=4.*asin(1.d0)*bufr(3) - write(6,*)'input frequency=',bufr(3),' Hz' - write(6,*)'scale frequency=',sclfreq,' rad/sec' - write(6,*)'dynamic units (not magnetostatic units) will be used' - slnew=c/sclfreq - write(6,*)'scale length specified in the input file is',sl,'m' - write(6,*)'resetting the scale length to c/scalefreq=',slnew,'m' - if(abs(sl-slnew)/sl .gt. 1.e-3)then - write(6,*)'WARNING: YOU SPECIFIED A SCALE LENGTH THAT IS' - write(6,*)'SIGNIFICANTLY DIFFERENT FROM THE NEW VALUE.' - write(6,*)'MAKE SURE THAT YOUR INITIAL CONDITIONS ARE' - write(6,*)'SPECIFIED IN DYNAMIC UNITS PRIOR TO TRACING RAYS' - endif - sl=slnew - endif -cryne verbose to show progress: - iverbose=bufr(4) -cryne autoslicing (thick elements need an extra parameter): - iautosl=nint(bufr(2)) - if(iautosl.ne.0)then - write(6,*)'autoslicing of thick elements will be enabled.' - endif - if(iautosl.gt.0)then - write(6,*)'fixed # of slices/element will be = ',iautosl - endif - if(iautosl.lt.0)then - write(6,*)'variable # of slices/element will be used' - if(na.ne.0)then - write(6,*)'error: input file specifies variable # of' - write(6,*)'slices/element, but some elements have already' - write(6,*)'been read in. stopping.' - stop - endif - nrp(1,1)=nrp(1,1)+1 - nrp(1,2)=nrp(1,2)+1 - nrp(1,3)=nrp(1,3)+1 - nrp(1,4)=nrp(1,4)+1 - nrp(1,6)=nrp(1,6)+1 - nrp(1,8)=nrp(1,8)+1 - nrp(1,9)=nrp(1,9)+1 - nrp(1,10)=nrp(1,10)+1 - nrp(1,11)=nrp(1,11)+1 - nrp(1,12)=nrp(1,12)+1 - nrp(1,18)=nrp(1,18)+1 - nrp(1,20)=nrp(1,20)+1 - nrp(1,24)=nrp(1,24)+1 - nrp(1,30)=nrp(1,30)+1 - endif - goto 10 -c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -c -c error exit: - 290 continue - write(jof ,299) - write(jodf,299) - 299 format(1h ,'data input error detected by dumpin6 near #beam') - call myexit -c-------------------- -c #menu -c - 300 continue -! write(6,*)'here I am at #menu' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -! write(6,*)line(1:80) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.4)goto 410 - if (msegm .ne. 3) goto 1 - 301 continue -c -c 11/4/02 new code to deal with 'call' statements: - if(trim(strarr(1)).eq.'call')then - write(6,*)'found a call statement in dumpin6' - call getsymb60(line,80,symb,istrtsym,nsymb) - write(6,*)'symb(1), symb(2), symb(3)=' - write(6,*)symb(1) - write(6,*)symb(2) - write(6,*)symb(3) - write(6,*)'this exceeds the maximum amount of nested calls' - write(6,*)'in the dumpin subroutines; halting.' - call myexit -c for more nesting, uncomment the following and add routine dumpin7 -cccc lftemp7=lf -cccc lf=47 -cccc call dumpin7(symb(3)) -cccc close(lf) -cccc lf=lftemp7 -cccc goto 300 - endif - na=na+1 - if(na.gt.mnumax) then - write(jof ,399) mnumax - write(jodf,399) mnumax - 399 format(1h ,'error in dumpin6:', & - & ' too many items (>= mnumax = ',i6,') elements in #menu') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,396) strarr(1) - write(jodf,396) strarr(1) - 396 format(' error detected by dumpin6 in #menu: name ', & - & a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! goto 300 - & ' the first definition will be ignored') - lmnlbl(indx)(1:1)='*' - endif -cryne - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then -c check if element/command name is present ( F. Neri 4/14/89 ): - if ( itot .lt. 2 ) then - write(jof ,1396) strarr(1) - write(jodf ,1396) strarr(1) - 1396 format(' error in #menu: ',a16,' has no type code!') - call myexit - endif - endif -cryne July 4 2002 if ( itot .gt. 2 ) then -cryne July 4 2002 write(jof ,1397) strarr(1) -cryne July 4 2002 write(jodf ,1397) strarr(1) -c1397 format(' error in #menu: ',a16,' has more than one type code!') -cryne July 4 2002 call myexit -cryne July 4 2002 endif -c new item in menu: - lmnlbl(na)=strarr(1) - initparms=1 !cryne 12/17/2004 change to 0 in the case of element reuse -c string is name of element/command type, look up element indices -cryne string=strarr(2) - if((trim(strarr(1)).eq.'beam').or. & - &(trim(strarr(1)).eq.'units'))then - string=strarr(1) - else - string=strarr(2) - endif - do 325 m = 1,9 - do 325 n = 1,nrpmax - if(string(1:16).eq.ltc(m,n)) then - nt1(na) = m - nt2(na) = n - goto 3344 - endif - 325 continue -c============= -cryne Sept 17, 2003 -c before declaring this an unknown element/command name, -c check to see if it is the name of an existing menu item -c since this is a functionality that MAD allows - call lookup(strarr(2),itype,indx) - if(itype.ne.1)goto 3226 -c this *is* the name of an existing menu item. - if(idproc.eq.0)then - write(6,*)'Element ',strarr(1),' is derived from ',strarr(2) - endif - m = nt1(indx) - n = nt2(indx) - nt1(na) = m - nt2(na) = n - imax=nrp(m,n) - if(imax.ne.0)then - do i=1,imax - pmenu(i+mpprpoi)=pmenu(i+mpp(indx)) - enddo - endif - icmax=ncp(m,n) - if(icmax.ne.0)then - do i=1,icmax - cmenu(i+mppcpoi)=cmenu(i+mppc(indx)) - enddo - endif - initparms=0 !cryne 12/17/2004 skip parameter initialization in stdinf.f - goto 3344 - 3226 continue -c============= -c error: unknown element/command name - write(jof ,398)(strarr(j),j=1,2) - write(jodf,398)(strarr(j),j=1,2) - 398 format(1h ,'dumpin6 error at ',a16,': type code ',a16, & - &' not found.'/ & - & 1h ,'this item will be ignored') - na=na-1 - goto 300 - 3344 continue -! write(6,*)'found a menu element;string,m,n=',string(1:8),m,n -c read parameters. Number of parameters is given in nrp - imax=nrp(m,n) - icmax=ncp(m,n) - imaxold=nrpold(m,n) -c write(6,*)'ready to read parameters; imax,icmax=',imax,icmax -cryne 9/26/02 if(imax.eq.0.and.icmax.eq.0)goto 300 - if(imax.eq.0.and.icmax.eq.0.and.itot.eq.2.and. - & index(line,':').eq.0)goto 300 -cryne July 4, 2002 -c if using the Standard Input Format, the remaining parameters -c are stored in "line"; otherwise use the MaryLie input format: -c -c mpp(na) points to where the real parameters will be stored -c mppc(na) points to where the char*16 parameters will be stored - mpp(na) = mpprpoi - mppc(na) = mppcpoi -cryne 7/9/2002 if(itot.eq.2)then -c original MaryLie input format (icmax not relevant here): - if( (itot.eq.2) .and. (index(line,':').eq.0) )then -c write(6,*)'reading ',imax,' params for ',strarr(1),' - ',string - if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imaxold) -c if(imax.ne.0)read(lf,*,err=390) (pmenu(i+mpp(na)),i=1,imax) -c if(icmax.ne.0)read(lf,*,err=390)(cmenu(i+mppc(na)),ic=1,imax) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax - goto 300 -c error in parameter input - 390 write(jof ,397)lmnlbl(na) - write(jodf,397)lmnlbl(na) - 397 format(1h ,'(dumpin6) parameter input error at element ',a16) - call myexit - endif -cryne July 4, 2002 -c if the code gets here, the Standard Input Format is being used -c to specify the elements in the menu: -c first delete the element name and type from the character string: -c write(6,*)'USING STANDARD INPUT FORMAT. LINE=' -c write(6,*)line -c write(6,*)'strarr(1),strarr(2)=' -c write(6,*)strarr(1) -c write(6,*)strarr(2) -ccc write(6,*)'will read params using SIF; imax,icmax=',imax,icmax -ccc write(6,*)'current values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi -cryne this could be more easily done with the f90 intrinsic len_trim() -c kkk1=len_trim(strarr(1))-1 - string=strarr(1) - kkk1=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk1=kkk1-1 - enddo - do i=1,80 - if(line(i:i+kkk1).eq.strarr(1))then - line(i:i+kkk1)=' ' - exit - endif - enddo -cryne kkk2=len_trim(strarr(2))-1 - string=strarr(2) - kkk2=len(string)-1 - do i=1,len(string) - if(string(i:i).eq.' ')kkk2=kkk2-1 - enddo -c - if((trim(strarr(1)).ne.'beam').and. & - &(trim(strarr(1)).ne.'units'))then - do i=1,80 - if(line(i:i+kkk2).eq.strarr(2))then - line(i:i+kkk2)=' ' - exit - endif - enddo - endif -c get rid of other unneccesary characters: - do i=1,80 -c if(line(i:i).eq.',')line(i:i)=' ' - if(line(i:i).eq.':')line(i:i)=' ' - enddo -c write(6,*)'TRIMMED LINE=' -c write(6,*)line - call stdinf(line,na,m,n,initparms,strarr(1)) - mpprpoi = mpprpoi + imax - mppcpoi = mppcpoi + icmax -c write(6,*)'read parameters using SIF; imax,icmax=',imax,icmax -c write(6,*)'new values of mpprpoi,mppcpoi=',mpprpoi,mppcpoi - goto 300 -c -c-------------------- -c #lines,#lumps,#loops -c - 400 continue -! write(6,*)'here I am at #lines,lumps,loops' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 4) goto 1 - goto 410 - 500 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 5) goto 1 - goto 410 - 600 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if(msegm.eq.9)goto 901 - if(msegm.eq.3)goto 301 - if (msegm .ne. 6) goto 1 -c - 410 nb=nb+1 - if(nb.gt.itmno)then - write(jof ,499) itmno - write(jodf,499) itmno - 499 format(1h ,'error in dumpin6:', & - & ' too many lines, lumps, and loops (sum >= itmno = ',i6, ')') - call myexit - endif -c check for doubly defined names - call lookup(strarr(1),itype,indx) - if(itype.ne.5) then - write(jof ,497) ling(msegm),strarr(1) - write(jodf,497) ling(msegm),strarr(1) - 497 format(1x,'dumpin6 error in ', & - & a8,': name ',a16,' is doubly defined'/ & -! & ' the second definition will be ignored') -! na = na-1 -! if(msegm .eq.4) then -! goto 400 -! else if(msegm.eq.5) then -! goto 500 -! else if(msegm.eq.6) then -! goto 600 -! endif - & ' the first definition will be ignored') - ilbl(indx)(1:1)='*' - endif -c new item - ilbl(nb)=strarr(1) - imin=0 -cryne July 2002 Standard Input Format option: components might be on -cryne this record; check now -cryne Note: this assume that the 2nd string after the name is 'line', -cryne and so the 2nd string is ignored - if( (itot.eq.2) .and. (.not.(lcont)) )then - write(6,*)'error parsing line:' - write(6,*)'this should be a name alone, or' - write(6,*)'a name followed by LINE= followed by the components' - write(6,*)'input line =' - write(6,*)line - stop - endif - if(itot.gt.2)then -c write(6,*)'ITOT=',itot -c do i=1,itot -c write(6,*)i,narr(i),strarr(i) -c enddo - do 424 i=3,itot - icon(imin+i-2,nb)=strarr(i) - irep(imin+i-2,nb)=narr(i) - 424 continue - imin=imin+itot-2 - if(lcont)then - goto 420 - else - goto 426 - endif - endif -cryne remaining code is from original version: -c read components of item -c repeat... - 420 call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if(imin+itot.gt.itmln)then - write(jof ,498) itmln,ilbl(nb) - write(jodf,498) itmln,ilbl(nb) - 498 format(1h ,'error in dumpin6:', & - & ' too many entries (> itmln = ',i6,') in ',a16) - call myexit - endif -c store names and rep rates of components - do 425 i=1,itot - icon(imin+i,nb)=strarr(i) - irep(imin+i,nb)=narr(i) - 425 continue - imin=imin+itot - if(lcont) goto 420 -c ... until no more continuation lines -c-- -c now set length and type of element - 426 continue - ilen(nb)=imin - ityp(nb)=msegm-2 -c go back to appropriate component (segment) - if(msegm .eq.4) then - goto 400 - else if(msegm.eq.5) then - goto 500 - else if(msegm.eq.6) then - goto 600 - endif -c-------------------- -c #labor -c - 700 continue -! write(6,*)'here I am at #labor' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (leof) goto 1000 - if (msegm .ne. 7) goto 1 -c - noble=noble+1 - if(noble.gt.mlabor) then - write(jof ,799) mlabor - write(jodf,799) mlabor - 799 format(1h ,'error in dumpin6:', & - & ' too many entries (>= mlabor = ',i6,') in #labor array') - call myexit - endif -c new task - latt(noble)=strarr(1) - num(noble)=narr(1) - goto 700 -c-------------------- -c #call (formerly #include) - 800 continue - write(6,*)' Start #call after user name: ',strarr(1) -c -ctm 9/01 modified to open and save up to 32 long #include file names -c - ninc = 0 - 810 read(lf,2000,end=1000) line -c -c check for next segment -c - if(index(line,'#').ne.0) then - itot = -1 - na2 = na - nb2 = nb - noble2 = noble - write(6,813) na2,nb2,noble2 - 813 format(' After #include:',i5,' menu',i5,' items',i5,' tasks') - write(6,817) line - 817 format(' End #include with: ',a) - go to 10 - endif -c -ctm save file name and pointers before opening 1st include file -c - ninc = ninc + 1 - if(ninc.eq.1) then - na1 = na - nb1 = nb - noble1 = noble - write(6,877) na1,nb1,noble1 - 877 format(' Before #include:',i5,' menu',i5,' items',i5,' tasks') - endif -c -ctm skip leading blanks -c - lc = 1 - 880 if(line(lc:lc).eq.' ') then - lc = lc + 1 - go to 880 - endif - incfil(ninc) = line(lc:) - write(6,888) ninc,incfil(ninc) - 888 format(' include',i3,' : ',a) - call mlfinc(incfil(ninc)) - go to 810 -ctm call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) -ctm if (leof) goto 1000 -ctm goto 1 -c-------------------- -c #const - 900 continue -! write(6,*)'here I am at #const' - call rearec(line,leof,msegm,strarr,narr,itot,lcont,npound) - if (npound) goto 1 - if (leof) goto 1000 - if((msegm.eq.9).and.(itot.ne.1))then - write(6,*)'input error (#const)' - write(6,*)'trying to read a definition, but did not find a' - write(6,*)'character string at the beginning of this record:' - write(6,*)line(1:80) - stop - endif - if(msegm.eq.3)goto 301 - if(msegm.eq.4)goto 410 - if (msegm .ne. 9) goto 1 - 901 continue - call getconst(line,strval,nreturn) - if(nreturn.ne.1)then - write(6,*)'trouble parsing the following line:' - write(6,*)line - write(6,*)'continuing...' - goto 900 - endif - nconst=nconst+1 - if(nconst.gt.nconmax)then - write(6,*)'too many constants defined in the input file' - stop - endif - constr(nconst)=strarr(1) - conval(nconst)=strval -c write(6,*)'nconst,constr(nconst),conval(nconst)=' -c write(6,*)nconst,constr(nconst),conval(nconst) - goto 900 -c normal return at end of file - 1000 continue - close(44) - write(6,*)'returning from routine dumpin6' - return - end -c diff --git a/OpticsJan2020/MLI_light_optics/Src/e_gengrad_mod.f b/OpticsJan2020/MLI_light_optics/Src/e_gengrad_mod.f deleted file mode 100644 index 01f7e61..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/e_gengrad_mod.f +++ /dev/null @@ -1,1222 +0,0 @@ -!*********************************************************************** -! -! e_gengrad: module for E-field generalized gradients -! -! Description: This module implements the derived types and subroutines -! for computing generalized gradients from E-field data given on the -! surface of a cylinder. -! -! Version: 0.1 -! Author: D.T.Abell, Tech-X Corp., Jan.2005 -! -! Comments -! 12.Jan.05 DTA: Only azimuthally symmetric case implemented. -! -!*********************************************************************** -! - module e_gengrad - use parallel, only : idproc - use lieaparam, only : monoms - use gengrad_data - implicit none -! -! data -! - integer, parameter, private :: max_j = 3 ! (N+1)/2 for MaryLie-N - ! extra z values required by adam11 - integer, parameter, private :: rkxtra = 306 - !double precision :: radius !don't think this is used - double precision :: rf_phase - double precision :: rf_escale -! -! derived types -! - type Efield_data - integer :: nz_intrvl - double precision :: zmin, zmax - double precision :: radius - double precision :: freq - ! must allocate the following arrays dim(0:nz_intrvl) - double precision, dimension(:), pointer :: zvals - double precision, dimension(:), pointer :: Ezdata - !double precision, dimension(:), pointer :: Erdata - !double precision, dimension(:), pointer :: Btdata - end type Efield_data -! - type charfn - integer :: nk_intrvl - double precision :: w_ovr_c - double precision :: kmax, dk - ! must allocate e0r(0:nk_intrvl), e0i(0:nk_intrvl) - double precision, dimension(:), pointer :: e0r - double precision, dimension(:), pointer :: e0i - end type charfn -! - type vecpot - double precision, dimension(0:monoms) :: Ax,Ay,Az - end type vecpot -! -! generalized gradient data to share -! - type (gengrad), save :: eggrdata - ! set G1[c,s](iz,j,m) = Crmj^{c,s}(z) - ! G2[c,s](iz,j,m) = Cfmj^{c,s}(z) - ! G3[c,s](iz,j,m) = Czmj^{c,s}(z) -! -! vector potential data to share -! - type (vecpot), save :: vp -! -! functions and subroutines -! - contains -! -!*********************************************************************** - subroutine read_efield_t7(fn,nf,zi,zf,f,r,efield) -! Read one or more 't7' files and extract the field data at the surface -! of a cylinder of specified radius r. A t7 file contains rf data for -! Ez, Er, Etot, and Htheta on a uniform grid in r and z. For a more on -! the t7 format, see, for example, p.35 of the Parmela manual. If the -! input 'f', for rf cavity frequency, has a non-zero value, it will -! override the value in the field-data files; it is otherwise replaced -! by the value from the field-data files. - use math_consts - use parallel - implicit none - character(16), intent(in) :: fn ! file name or base file name - integer, intent(in) :: nf ! file number range; 0 => use 'fname' - double precision, intent(in) :: zi,zf ! initial and final z - double precision, intent(inout) :: f ! cavity frequency - double precision, intent(in) :: r ! extract data at this radius - type (Efield_data), intent(out) :: efield -!-----!----------------------------------------------------------------! - character(29), parameter :: estrng="e_gengrad_mod::read_efield_t7" - double precision, parameter :: tiny=1.d-6 - character(16) :: fname - logical :: singleF - integer :: ierr,lng0,lng,nfc,nfile,offset - integer :: i,iu,ii,jj,kk,ll,irad,ir,iz,izt - integer :: nr,nz,nvals,nztot - double precision :: frq,r1,r2,ri,z1,z2,dr,dz - double precision :: ez,er,et,hth -cccccc -c if (idproc.eq.0) then -c print *," " -c print *,"(read_efield_t7): ..." -c print *,"(",fn,nf,zi,zf,r,")" -c end if -cccccc - ! are we reading just a single file - ! with a given filename? - if (nf.eq.0) then - nfc=1 - singleF=.true. - else - nfc=nf - singleF=.false. - offset=int(log10(real(nfc))) - end if - - ! loop over the files to read - nztot=0 - do nfile=1,nfc - - ! first open the E-field data file - fname=fn - if (singleF) then ! use 'fname' as is - call fnamechk(fname,iu,ierr,estrng) - else ! build name of current 't7' file - lng0=len_trim(fname) ! DTA: should test length - if (nfile.ge.1.and.nfile.le.9) then - lng=lng0+offset - do i=1,offset - fname(lng0+i:lng0+i)="0" - end do - fname(lng+1:lng+1)=char(nfile+48) - fname(lng+2:lng+4)=".t7" - call fnamechk(fname,iu,ierr,estrng) - if(ierr.ne.0) then - fname(lng+2:lng+4)=".T7" - call fnamechk(fname,iu,ierr,estrng) - end if - else if (nfile.ge.10.and.nfile.le.99) then - lng=lng0+offset-1 - do i=1,offset-1 - fname(lng0+i:lng0+i)="0" - end do - ii = nfile/10 - jj = nfile - ii*10 - fname(lng+1:lng+1) = char(ii+48) - fname(lng+2:lng+2) = char(jj+48) - fname(lng+3:lng+5)=".t7" - call fnamechk(fname,iu,ierr,estrng) - if(ierr.ne.0) then - fname(lng+3:lng+5)=".T7" - call fnamechk(fname,iu,ierr,estrng) - end if - else if (nfile.ge.100.and.nfile.le.999) then - lng=lng0+offset-2 - do i=1,offset-2 - fname(lng0+i:lng0+i)="0" - end do - ii = nfile/100 - jj = nfile - 100*ii - kk = jj/10 - ll = jj - 10*kk - fname(lng+1:lng+1) = char(ii+48) - fname(lng+2:lng+2) = char(kk+48) - fname(lng+3:lng+3) = char(ll+48) - fname(lng+4:lng+6)=".t7" - call fnamechk(fname,iu,ierr,estrng) - if(ierr.ne.0) then - fname(lng+4:lng+6)=".T7" - call fnamechk(fname,iu,ierr,estrng) - end if - else if (nfile.gt.999) then - ierr=1 - if (idproc.eq.0) then - write(6,*) "<*** ERROR ***> in ",estrng,":" - write(6,*) " range of file numbers too large!" - end if - end if - end if - if(ierr.ne.0) then - if (idproc.eq.0) then - write(6,*) "<*** ERROR ***> in ",estrng,":" - write(6,*) " can't read data file",fname - write(6,*) " exiting now..." - end if - call myexit - end if - if (idproc.eq.0) print *,fname," opened" - ! file unit iu should now be open for reading - ! ---but only by processor zero - - ! now read data file - if (idproc.eq.0) then - ! read data description: first three lines of t7 file describe - ! longitudinal range, frequency, and radial range - ! longitudinal range given in cm; convert to m - read(iu,*) z1,z2,nz - print *,"z-in: ",z1,z2,nz - z1=z1*1.0d-2 - z2=z2*1.0d-2 - ! if argument f is non-zero, use that value; - ! else read frequency in MHz, and convert to Hz - read(iu,*) frq - print *,"frq: ",f - if (f.eq.0.d0) then - f=frq*1.0d6 - endif - ! radial range given in cm; convert to m - read(iu,*) r1,r2,nr - print *,"r-in: ",r1,r2,nr - r1=r1*1.0d-2 - r2=r2*1.0d-2 - print *,"frequency: ",f - print *,"z-range: ",z1,z2,nz - print *,"r-range: ",r1,r2,nr - end if - - call MPI_BCAST(nr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(nz,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(r1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(r2,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(z1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(z2,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(f,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - - if (nfile.eq.1) then - efield%zmin = z1 - efield%zmax = z2 - efield%radius = r - efield%freq = f - ! deallocate old data, then allocate space we need - ! === not sure this is the right approach (DTA) === - ! DTA: if (nz(file2) > nz(file1)) problem exists! - if(associated(efield%zvals)) deallocate(efield%zvals) - if(associated(efield%Ezdata)) deallocate(efield%Ezdata) - !if(associated(efield%Erdata)) deallocate(efield%Erdata) - !if(associated(efield%Btdata)) deallocate(efield%Btdata) - nvals=nfc*nz ! best guess for total number of intervals - allocate(efield%zvals(0:nvals)) - allocate(efield%Ezdata(0:nvals)) - !allocate(efield%Erdata(0:nvals)) - !allocate(efield%Btdata(0:nvals)) - else - ! DTA: should do some sanity checks here - efield%zmax=z2 - end if - - ! compute and test radial index - ri=nr*(r-r1)/(r2-r1) - irad=int(ri+0.5) - if (abs(ri-irad).gt.tiny.or. & - & irad.lt.0.or.irad.gt.nr) then - if (idproc.eq.0) then - print *,"<*** ERROR ***> in ",estrng,":" - print *," desired radius ",r," does not appear in ",fname - print *," r1, r2, nr, dr =",r1,r2,nr,(r2-r1)/nr - print *," ri, irad =",ri,irad - print *," exiting now..." - end if - call myexit - end if - - ! read field data at desired radius - if (idproc.eq.0) then - do ir=1,irad ! skip inner radii - do iz=0,nz - read(iu,*) ez,er,et - read(iu,*) hth - end do - end do - dz=(z2-z1)/nz - do iz=0,nz - read(iu,*) ez,er,et - read(iu,*) hth - izt=nztot+iz - efield%zvals(izt)=z1+iz*dz - ! E-field given in MV/m, convert to V/m - efield%Ezdata(izt)=ez*1.0d6 - !efield%Erdata(izt)=er*1.0d6 - ! H-field given in A/m, convert to B-field in T - !efield%Btdata(izt)=hth*mu_o - end do - close(iu) - end if - nztot=nztot+nz - - end do ! loop over nfile - efield%nz_intrvl = nztot - - ! check (zmin,zmax) v. (zi,zf) - if (idproc.eq.0) then - if (.not.(zi.eq.0.d0.and.zf.eq.0.d0)) then ! shift z values - if (abs((efield%zmax-efield%zmin)-(zf-zi)).gt.tiny) then - if (idproc.eq.0) then - print *," <*** WARNING ***> from ",estrng - print *," desired range of z values is incompatible" - print *," with the data in file(s) ",fn - end if - else - dz=efield%zmin-zi - if (dz.ne.0.d0) then - do iz=0,nztot - efield%zvals(iz)=efield%zvals(iz)-dz - end do - end if - end if - end if - end if -cccccc -c if (idproc.eq.0) then -c print *," " -c print *," Efield data at radius ",r -c do iz=0,nztot -c print *,efield%zvals(iz),efield%Ezdata(iz) -c end do -c end if -cccccc - - ! broadcast E-field information to other processors - ! zmin,zmax,nz_intrvl,freq,w_ovr_c already done; - ! need to broadcast just zvals and Ezdata - call MPI_BCAST(efield%zvals(0),efield%nz_intrvl+1, & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(efield%Ezdata(0),efield%nz_intrvl+1, & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - - end subroutine read_efield_t7 -! -!*********************************************************************** - subroutine read_efield_ez(fn,nf,jf,zi,zf,f,r,efield) -! -! Read one or more data files and extract the field data at the surface -! of a cylinder of specified radius r. This subroutine reads field data -! for Ez on a uniform grid in r and z. The first three lines contain -! meta-data describing the file: -! -! r_min/m r_max/m N_r (N_r := number of r intervals) -! z_min/m z_max/m N_z (N_z := number of z intervals) -! rf-freq/Hz -! -! The remaining lines contain the data E_z(r_i,z_j), where i denotes -! the faster changing index. -! -! If the input 'f', for rf cavity frequency, has a non-zero value, it -! will override the value in the field-data files; it is otherwise -! replaced by the value from the field-data files. -! - use math_consts - use parallel - implicit none - character(16), intent(in) :: fn ! file name or base file name - integer, intent(in) :: nf ! file number range; 0 => use 'fn' - integer, intent(in) :: jf ! unit number for E-field diagnostic - double precision, intent(inout) :: zi,zf ! initial and final z - double precision, intent(inout) :: f ! cavity frequency - double precision, intent(in) :: r ! extract data at this radius - type (Efield_data), intent(out) :: efield -!-----!----------------------------------------------------------------! - character(29), parameter :: estrng="e_gengrad_mod::read_efield_ez" - double precision, parameter :: tiny=1.d-6 - double precision, parameter :: eps=1.d-13 - character(16) :: fname,numstr - logical :: singleF - integer :: ierr,lng,ndig,nfc,nfile - integer :: i,iu,ii,jj,kk,ll,irad,ir,iz,izt - integer :: nr,nz,nvals,nztot - double precision :: dr,dz,frq,r1,r2,ri,z1,z2 - double precision :: ez,er,et,hth -cccccc -c if (idproc.eq.0) then -c print *," " -c print *,estrng,": ..." -c print *," (",fn,",",nf,",",jf,",",zi,",",zf,",",r,",efield)" -c end if -cccccc - ! are we reading just a single file with a given filename? - if (nf.eq.0) then - nfc=1 - singleF=.true. - else - nfc=nf - singleF=.false. - end if - - ! loop over the files to read - ndig=1+int(log10(real(nfc))) - nztot=0 - do nfile=1,nfc - - ! first open the E-field data file - fname=fn - if (singleF) then ! use 'fname' as is - call fnamechk(fname,iu,ierr,estrng) - else ! build name of current data file - lng=len_trim(fname) ! DTA: should test length - call num2string(nfile,numstr,ndig) - fname=fname(1:lng)//numstr(1:ndig)//".ez" - call fnamechk(fname,iu,ierr,estrng) - end if - if(ierr.ne.0) then - if (idproc.eq.0) then - write(6,*) "<*** ERROR ***> in ",estrng,":" - write(6,*) " can't read data file ",fname - write(6,*) " exiting now..." - end if - call myexit - end if - if (idproc.eq.0) print *,fname," opened" - ! file unit iu should now be open for reading - ! ---but only by processor zero - - ! now read data file - if (idproc.eq.0) then - ! read data description: first three lines of ez file describe - ! r_min/m r_max/m N_r_intrvls - ! z_min/m z_max/m N_z_intrvls - ! rf-frequency/Hz - read(iu,*) r1,r2,nr - read(iu,*) z1,z2,nz - read(iu,*) frq - ! if argument f is non-zero, use that value instead - if (f.eq.0.d0) then - f=frq - else - print *," NB: not using rf-frequency ",frq," from data file" - endif - print *,"r-range: ",r1,r2,nr - print *,"z-range: ",z1,z2,nz - print *,"frequency: ",f - end if - - call MPI_BCAST(nr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(nz,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(r1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(r2,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(z1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(z2,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(f,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - - if (nfile.eq.1) then - efield%zmin = z1 - efield%zmax = z2 - efield%radius = r ! fix (below) if requested and actual differ - efield%freq = f - ! deallocate old data, then allocate space we need - ! === not sure this is the right approach (DTA) === - ! DTA: if (nz(file_i) > nz(file_1)) problem exists! - if(associated(efield%zvals)) deallocate(efield%zvals) - if(associated(efield%Ezdata)) deallocate(efield%Ezdata) - !if(associated(efield%Erdata)) deallocate(efield%Erdata) - !if(associated(efield%Btdata)) deallocate(efield%Btdata) - nvals=nfc*nz ! best guess for total number of intervals - allocate(efield%zvals(0:nvals)) - allocate(efield%Ezdata(0:nvals)) - !allocate(efield%Erdata(0:nvals)) - !allocate(efield%Btdata(0:nvals)) - else - ! DTA: should do some sanity checks here - efield%zmax=z2 - end if - - ! compute and test radial index - if (nr.ne.0) then - dr=(r2-r1)/nr - ri=(r-r1)/dr - else ! we have data at a single radius - dr=0 - ri=0 - end if - irad=nint(ri) - efield%radius=abs(r1+irad*dr) ! here store actual radius - if (abs(ri-irad).gt.tiny.or. & - & irad.lt.0.or.irad.gt.nr) then - if (idproc.eq.0) then - print *,"<*** ERROR ***> in ",estrng,":" - print *," desired radius ",r," does not appear in ",fname - print *," r1, r2, nr, dr = ",r1,r2,nr,dr - print *," ri, irad = ",ri,irad - print *," exiting now..." - end if - call myexit - else - print *,"extracting E-field data a radius ",efield%radius - end if - - ! read field data at desired radius - if (idproc.eq.0) then - dz=(z2-z1)/nz - do iz=0,nz - ! skip inner radii - do ir=0,irad-1 - read(iu,*) ez - end do - ! read and store next value (but don't duplicate boundary) - read(iu,*) ez - izt=nztot+iz ! overwrites last value at file boundary (iz=0) - efield%zvals(izt)=z1+iz*dz - efield%Ezdata(izt)=ez - ! skip outer radii - do ir=irad+1,nr - read(iu,*) ez - end do - end do - close(iu) - end if - nztot=nztot+nz - - end do ! loop over nfile - efield%nz_intrvl = nztot - - ! check (zmin,zmax) v. (zi,zf) - if (zi.eq.0.d0.and.zf.eq.0.d0) then - ! assign zi and zf from file - zi=efield%zmin - zf=efield%zmax - else if (abs((zf-zi)-(efield%zmax-efield%zmin)).lt.eps) then - ! shift data - dz=zi-efield%zmin - if (dz.ne.0.d0) then - if (idproc.eq.0) then - do iz=0,nztot - efield%zvals(iz)=efield%zvals(iz)+dz - end do - end if - efield%zmin=efield%zmin+dz - efield%zmax=efield%zmax+dz - end if - ! at this point, zi.eq.efield%zmin - ! and zf lies within eps of efield%zmax - if (zf.gt.efield%zmax) zf=efield%zmax - else if ((zf-zi).gt.(efield%zmax-efield%zmin)) then - ! complain, and assign zi and zf from file - if (idproc.eq.0) then - print *," <*** WARNING ***> from ",estrng - print *," desired z-range [",zi,",",zf,"]" - print *," is incompatible with the data in file(s) ",fn - print *," using z-range [",efield%zmin,",",efield%zmax,"]" - end if - zi=efield%zmin - zf=efield%zmax - else - ! deal with cases (zf-zi).lt.(efield%zmax-efield%zmin) - if (zi.lt.efield%zmin) then - if (idproc.eq.0) then - print *," <*** WARNING ***> from ",estrng - print *," changing desired z-range from [",zi,",",zf,"]" - print *," to [",efield%zmin,",",zf,"]" - end if - zi=efield%zmin - else if (zf.lt.efield%zmax) then - if (idproc.eq.0) then - print *," <*** WARNING ***> from ",estrng - print *," changing desired z-range from [",zi,",",zf,"]" - print *," to [",zi,",",efield%zmin,"]" - end if - zf=efield%zmax - end if - end if - - ! write E-field(s) at radius r - if (idproc.eq.0) then - if (jf.ne.0) then - do iz=0,nztot - write(jf,*) efield%zvals(iz),efield%Ezdata(iz) - end do - end if - end if - - ! broadcast E-field information to other processors - ! zmin,zmax,nz_intrvl,freq,w_ovr_c already done; - ! need to broadcast just zvals and Ezdata - call MPI_BCAST(efield%zvals(0),efield%nz_intrvl+1, & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(efield%Ezdata(0),efield%nz_intrvl+1, & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - - end subroutine read_efield_ez -! -!*********************************************************************** - subroutine comp_charfn(efield,kmx,nk_intrvl,kfile,e0) -! Compute the characteristic function \tilde{e}_0(k) from a given set -! of electric field data at radius r. - use math_consts - use phys_consts - use parallel, only : idproc - implicit none - type (Efield_data), intent(in) :: efield - double precision, intent(in) :: kmx ! maximum value of k - integer, intent(in) :: nk_intrvl ! number of intervals in k - integer, intent(in) :: kfile ! file unit number for output of e0 - type (charfn), intent(out) :: e0 -!-----!----------------------------------------------------------------! - double precision, parameter :: tiny=1.d-6 - integer :: ik,iz,izb,izt - double precision :: bessR,ei,er,invrt2pi - double precision :: k,kapsq,klsq,kR,dz,dz1 - double precision, dimension(1) :: bv -cccccc -c if (idproc.eq.0) then -c print *,"(comp_charfn): ..." -c end if -cccccc - e0%nk_intrvl=nk_intrvl - e0%w_ovr_c=twopi*efield%freq/c_light - e0%kmax=kmx - e0%dk=kmx/nk_intrvl - klsq=e0%w_ovr_c**2 - invrt2pi=1.d0/sqrt(twopi) - - ! allocate memory for e0%e0r and e0%e0i - ! deallocate old data, then allocate space we need - ! === not sure this is the best approach (DTA) === - if(associated(e0%e0r)) deallocate(e0%e0r) - if(associated(e0%e0i)) deallocate(e0%e0i) - allocate(e0%e0r(0:nk_intrvl)) - allocate(e0%e0i(0:nk_intrvl)) - e0%e0r=0.d0 - e0%e0i=0.d0 - - ! dz may not be uniform across the E-field data files, but the - ! filon integrator requires dz = constant: perform z integration - ! in discrete sections - izt=0 ! top index of current section - - do while (izt < efield%nz_intrvl) - ! set izb, and initialize search for next izt - izb=izt; izt=izb+1 - dz=efield%zvals(izt)-efield%zvals(izb) - do while (izt.lt.efield%nz_intrvl.and. & - & dabs(efield%zvals(izt+1)-efield%zvals(izt)-dz).lt.tiny) - izt=izt+1 - end do - ! compute real and imaginary parts of e0(k), k in [0,kmax] -cccccc -c if (idproc.eq.0) then -c print *,"iz-range:",izb,izt,"(",izt-izb+1,")" -c end if -cccccc - do ik=0,nk_intrvl - k=ik*e0%dk - call besselR0(k,e0%w_ovr_c,efield%radius,bessR) - call filon_io(efield%zvals,efield%Ezdata,k, & - & izb,izt-izb+1,ei,er) - e0%e0r(ik)=e0%e0r(ik)+invrt2pi*er/bessR - e0%e0i(ik)=e0%e0i(ik)-invrt2pi*ei/bessR - end do ! loop over k - end do ! loop over sections w/ dz=constant - - ! if asked, write characteristic function to file - if (idproc.eq.0.and.kfile.ne.0) then - write(kfile,*) "# ",e0%nk_intrvl - write(kfile,*) "# ",e0%w_ovr_c - write(kfile,*) "# ",e0%kmax,e0%dk - do ik=0,nk_intrvl - k=ik*e0%dk - write(kfile,*) k,e0%e0r(ik),e0%e0i(ik) - end do - end if -! - end subroutine comp_charfn -! -!*********************************************************************** - subroutine read_charfn(iu,e0) -! Read characteristic function from file. - use parallel - implicit none - integer, intent(in) :: iu ! file unit number for data file - type (charfn), intent(out) :: e0 ! characteristic function -!-----!----------------------------------------------------------------! - character(26), parameter :: estrng="e_gengrad_mod::read_charfn" - character(90) :: string - integer :: ierr,ik,ist,len,myerr - real*8 :: k - -! if (idproc.eq.0) then -! print *," reading characteristic functions ..." -! end if - - ! check file unit number - ! NB: only PE0 knows the argument iu - myerr=0 - if (idproc.eq.0) then - if (iu.eq.0) then - myerr=1 - write(6,*) "<*** ERROR ***> in ",estrng,": iu=0" - write(6,*) '<**ERROR**> e_gengrad_mod::read_charfn: iu=0' - endif - endif - call ibcast(myerr) - if (myerr.ne.0) call myexit() - - ! read characteristic function from file - ! first read and broadcast parameters from top three lines - ! (skipping possible comment character '#' at start of line) - if (idproc.eq.0) then - read(iu,'(a)') string - len=len_trim(string) - ist=index(trim(string),'#') - read(string(ist+1:len),*) e0%nk_intrvl - read(iu,'(a)') string - len=len_trim(string) - ist=index(trim(string),'#') - read(string(ist+1:len),*) e0%w_ovr_c - read(iu,'(a)') string - len=len_trim(string) - ist=index(trim(string),'#') - read(string(ist+1:len),*) e0%kmax,e0%dk - end if - call MPI_BCAST(e0%nk_intrvl,1, & - & MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(e0%w_ovr_c,1, & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(e0%kmax,1, & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(e0%dk,1, & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - ! allocate arrays - if(associated(e0%e0r)) deallocate(e0%e0r) - if(associated(e0%e0i)) deallocate(e0%e0i) - allocate(e0%e0r(0:e0%nk_intrvl)) - allocate(e0%e0i(0:e0%nk_intrvl)) - ! then read data and close file - if (idproc.eq.0) then - do ik=0,e0%nk_intrvl - read(iu,*) k,e0%e0r(ik),e0%e0i(ik) - end do - close(iu) - end if - ! broadcast char. fn. information to other processors - call MPI_BCAST(e0%e0r(0:e0%nk_intrvl),(e0%nk_intrvl+1), & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(e0%e0i(0:e0%nk_intrvl),(e0%nk_intrvl+1), & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) -! - end subroutine read_charfn -! -!*********************************************************************** - subroutine comp_egengrads(iu,e0,zi,zf,nz_intrvl) -! Compute electric field generalized gradients and write to unit iu. -! [NB: currently handles only azimuthally symmetric case.] - use math_consts - use phys_consts - use parallel, only : idproc - implicit none - integer, intent(in) :: iu ! file unit number for output - type (charfn), intent(in) :: e0 - double precision, intent(in) :: zi,zf ! initial and final z - integer, intent(in) :: nz_intrvl ! number of z intervals -!-----!----------------------------------------------------------------! - double precision, parameter :: tiny=1.d-6 - integer :: ik,iz,j,nkpts - double precision :: rt2ovrpi,z - double precision :: cosint,sinint - double precision, allocatable, dimension(:) :: kvals,sk,skj,skjr, & - & integrand -cccccc -c if (idproc.eq.0) then -c print *,"(comp_egengrads): ..." -c end if - print *,idproc,": (comp_egengrads): ..." -cccccc - ! initialize constants in eggrdata - eggrdata%maxj=max_j - eggrdata%maxm=0 - eggrdata%zmin=zi - eggrdata%zmax=zf - eggrdata%nz_intrvl=nz_intrvl - eggrdata%dz=(zf-zi)/nz_intrvl - eggrdata%angfrq=e0%w_ovr_c*c_light -cccccc -c if (idproc.eq.0) then -c print *," allocating memory for zvals and gen.grad. arrays..." -c end if - print *," proc.",idproc, & - & ": allocating memory for zvals and gen.grad. arrays..." -cccccc - ! allocate memory for eggrdata%{zvals,G1c,G3c} - ! deallocate old data, then allocate space we need - ! === not sure this is the best approach (DTA) === - if(associated(eggrdata%zvals)) deallocate(eggrdata%zvals) - if(associated(eggrdata%G1c)) deallocate(eggrdata%G1c) - !if(associated(eggrdata%G2c)) deallocate(eggrdata%G2c) - if(associated(eggrdata%G3c)) deallocate(eggrdata%G3c) - allocate(eggrdata%zvals(0:nz_intrvl+rkxtra)) - allocate(eggrdata%G1c(0:nz_intrvl+rkxtra,1:eggrdata%maxj, & - & 0:eggrdata%maxm)) - !allocate(eggrdata%G2c(0:nz_intrvl+rkxtra,1:eggrdata%maxj,0:0)) - allocate(eggrdata%G3c(0:nz_intrvl+rkxtra,0:eggrdata%maxj, & - & 0:eggrdata%maxm)) -cccccc -c if (idproc.eq.0) then -c print *,": done allocating zvals and gen.grad. arrays..." -c end if - print *," proc.",idproc, & - & ": done allocating zvals and gen.grad. arrays..." -cccccc - - ! define scalar variables we need - nkpts=e0%nk_intrvl+1 - rt2ovrpi=sqrt(2.d0/pi) - - ! allocate vectors we need - allocate(kvals(0:e0%nk_intrvl)) - allocate(sk(0:e0%nk_intrvl)) - allocate(skj(0:e0%nk_intrvl)) - allocate(skjr(0:e0%nk_intrvl)) - allocate(integrand(0:e0%nk_intrvl)) - - ! initialize vectors - do ik=0,e0%nk_intrvl - kvals(ik)=ik*e0%dk - end do - sk=kvals**2-e0%w_ovr_c**2 - skj=1.d0 - - ! compute generalized gradients - call zs_adam11(zi,zf,nz_intrvl,eggrdata%zvals) - if (idproc.eq.0) then - print *," Computing E-field generalized gradients ..." - end if - do j=0,eggrdata%maxj - if (j.ne.0) then - ! compute Crc(0,j,z) = eggrdata%G1c(z,j,0) - if (idproc.eq.0) then - print *," ... Crc(0,",j,",z)" - end if - skjr=j*kvals*skj - integrand=skjr*e0%e0r - do iz=0,nz_intrvl+rkxtra - z=eggrdata%zvals(iz) - call filon_io(kvals,integrand,z,0,nkpts,sinint,cosint) - eggrdata%G1c(iz,j,0)=sinint - end do - integrand=skjr*e0%e0i - do iz=0,nz_intrvl+rkxtra - z=eggrdata%zvals(iz) - call filon_io(kvals,integrand,z,0,nkpts,sinint,cosint) - eggrdata%G1c(iz,j,0)=rt2ovrpi*(eggrdata%G1c(iz,j,0)+cosint) - end do - end if - ! compute Czc(0,j,z) = eggrdata%G3c(z,j,0) - if (idproc.eq.0) then - print *," ... Czc(0,",j,",z)" - end if - if (j.ne.0) then - skj=skj*sk - end if - integrand=skj*e0%e0r - do iz=0,nz_intrvl+rkxtra - z=eggrdata%zvals(iz) - call filon_io(kvals,integrand,z,0,nkpts,sinint,cosint) - eggrdata%G3c(iz,j,0)=cosint - end do - integrand=skj*e0%e0i - do iz=0,nz_intrvl+rkxtra - z=eggrdata%zvals(iz) - call filon_io(kvals,integrand,z,0,nkpts,sinint,cosint) - eggrdata%G3c(iz,j,0)=rt2ovrpi*(eggrdata%G3c(iz,j,0)-sinint) - end do - end do ! loop over j - - ! write generalized gradients to file - if(idproc.eq.0.and.iu.ne.0) then - write(iu,*) "# ",eggrdata%nz_intrvl,eggrdata%maxj,eggrdata%maxm - write(iu,*) "# ",eggrdata%zmin,eggrdata%zmax,eggrdata%dz - write(iu,*) "# ",eggrdata%angfrq - do iz=0,nz_intrvl+rkxtra - z=eggrdata%zvals(iz) - write(iu,*) z,eggrdata%G3c(iz,0,0), & - & (eggrdata%G1c(iz,j,0),eggrdata%G3c(iz,j,0), & - & j=1,eggrdata%maxj) - end do - end if - - ! write z, Ez, dEz/dz - !if(idproc.eq.0.and.iude.ne.0) then - if(idproc.eq.0) then - do iz=0,nz_intrvl+rkxtra - write(81,*) z,eggrdata%G3c(iz,0,0),-eggrdata%G1c(iz,1,0) - ! write(81,'(3(1x,1pe22.15))') z,eggrdata%G3c(iz,0,0), & - !& -eggrdata%G1c(iz,1,0) - end do - end if - - ! clean up - deallocate(kvals) - deallocate(sk) - deallocate(skj) - deallocate(skjr) - deallocate(integrand) -! - end subroutine comp_egengrads -! -!*********************************************************************** - subroutine read_egengrads(iu) -! Read generalized gradients from file. - use parallel - implicit none - integer, intent(in) :: iu ! file unit number for data file -!-----!----------------------------------------------------------------! - character(29), parameter :: estrng="e_gengrad_mod::read_egengrads" - character(90) :: string - integer :: ierr,ist,iz,j,len,myerr - double precision :: z - - if (idproc.eq.0) then - print *," reading generalized gradients ..." - end if - - ! check file unit number - ! NB: only PE0 knows the argument iu - myerr=0 - if (idproc.eq.0) then - if (iu.eq.0) then - myerr=1 - write(6,*) "<*** ERROR ***> in ",estrng,": iu=0" - endif - endif - call ibcast(myerr) - if (myerr.ne.0) call myexit() - - ! read generalized gradients from file - ! first read and broadcast parameters from top three lines - ! (skipping possible comment character '#' at start of line) - if(idproc.eq.0.and.iu.ne.0) then - read(iu,'(a)') string - len=len_trim(string) - ist=index(trim(string),'#') - read(string(ist+1:len),*) eggrdata%nz_intrvl,eggrdata%maxj, & - & eggrdata%maxm - read(iu,'(a)') string - len=len_trim(string) - ist=index(trim(string),'#') - read(string(ist+1:len),*) eggrdata%zmin,eggrdata%zmax, & - & eggrdata%dz - read(iu,'(a)') string - len=len_trim(string) - ist=index(trim(string),'#') - read(string(ist+1:len),*) eggrdata%angfrq - end if - call MPI_BCAST(eggrdata%nz_intrvl,1, & - & MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(eggrdata%maxj,1, & - & MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(eggrdata%maxm,1, & - & MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(eggrdata%zmin,1, & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(eggrdata%zmax,1, & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(eggrdata%dz,1, & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(eggrdata%angfrq,1, & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - ! allocate arrays - if(associated(eggrdata%zvals)) deallocate(eggrdata%zvals) - if(associated(eggrdata%G3c)) deallocate(eggrdata%G3c) - if(associated(eggrdata%G1c)) deallocate(eggrdata%G1c) - allocate(eggrdata%zvals(0:eggrdata%nz_intrvl+rkxtra)) - allocate(eggrdata%G1c(0:eggrdata%nz_intrvl+rkxtra, & - & 1:eggrdata%maxj,0:eggrdata%maxm)) - allocate(eggrdata%G3c(0:eggrdata%nz_intrvl+rkxtra, & - & 0:eggrdata%maxj,0:eggrdata%maxm)) - ! then read data and close file - if(idproc.eq.0.and.iu.ne.0) then - do iz=0,eggrdata%nz_intrvl+rkxtra - read(iu,*) eggrdata%zvals(iz),eggrdata%G3c(iz,0,0), & - & (eggrdata%G1c(iz,j,0),eggrdata%G3c(iz,j,0), & - & j=1,eggrdata%maxj) - end do - close(iu) - end if - ! broadcast gen. grad. information to other processors - call MPI_BCAST(eggrdata%zvals(0:eggrdata%nz_intrvl+rkxtra), & - & (eggrdata%nz_intrvl+rkxtra+1), & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(eggrdata%G1c(0:eggrdata%nz_intrvl+rkxtra, & - & 1:eggrdata%maxj,0:0), & - & (eggrdata%nz_intrvl+rkxtra+1)*(eggrdata%maxj), & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) - call MPI_BCAST(eggrdata%G3c(0:eggrdata%nz_intrvl+rkxtra, & - & 0:eggrdata%maxj,0:0), & - & (eggrdata%nz_intrvl+rkxtra+1)*(eggrdata%maxj+1), & - & MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr) -! - end subroutine read_egengrads -! -!*********************************************************************** - subroutine besselR0(k,kl,r,b) -! Compute, the values for the order zero "Bessel" function -! R_0(k,kl,r) := { J_0(sqrt(|k^2-kl^2|)*r), sgn(k^2-kl^2) < 0; -! { I_0(sqrt(|k^2-kl^2|)*r), otherwise. -! In words, R_0 switches from the regular to the modified Bessel -! function of the first kind as |k| crosses |kl|. - implicit none - double precision, intent(in) :: k,kl,r - double precision, intent(out) :: b -!-----!----------------------------------------------------------------! - double precision :: kapsq,kR - double precision, dimension(1) :: bv -! - kapsq=k**2-kl**2 - if (kapsq.lt.0.d0) then ! regular Bessel function - kR=sqrt(-kapsq)*r - call dbessj0(kR,b) - else ! modified Bessel function - kR=sqrt(kapsq)*r - call BESSIn(1,0,kR,bv,1) - b=bv(1) - endif -! - end subroutine besselR0 -! -!*********************************************************************** - subroutine besselR(m,k,kl,r,bv) -! Compute, for integer orders 0...m, values for the "Bessel" -! function R_m(k,kl,r) := { J_m(sqrt(|k^2-kl^2|)*r), sgn(k^2-kl^2) < 0; -! { I_m(sqrt(|k^2-kl^2|)*r), otherwise. -! In words, R_m switches from the regular to the modified Bessel -! function of the first kind as |k| crosses |kl|. - implicit none - integer, intent(in) :: m ! desired orders 0...m-1 - double precision, intent(in) :: k,kl,r - double precision, dimension(:), intent(out) :: bv ! bv(0:m) -!-----!----------------------------------------------------------------! - double precision :: kapsq,kR - double precision, dimension(:), allocatable :: bessR -! - allocate(bessR(m+1)) -! - kapsq=k**2-kl**2 - if (kapsq.lt.0.d0) then ! regular Bessel function - kR=sqrt(-kapsq)*r - call dbessjm(m+1,kR,bessR) - else ! modified Bessel function - kR=sqrt(kapsq)*r - call BESSIn(m+1,0,kR,bv,1) ! unscaled I_0 ... I_m - bessR=bv(1) - endif - bv=bessR -! - deallocate(bessR) -! - end subroutine besselR -! -!*********************************************************************** - subroutine filon_io(xn,fn,k,io,npts,sinint,cosint) -! -! Generic Filon integrator---array version with variable index origin: -! This subroutine uses Filon's method to evaluate the integrals from -! xn(io) to xn(io+npts-1) of -! -! fn(x) sin k*x dx -! and fn(x) cos k*x dx -! -! where fn is also an array of length npts with the same index origin -! io. Filon's method allows one to evaluate the integral of an -! oscillating function without having to follow every wiggle with many -! evaluation points. This version has only a single frequency, k. -! (See F.B.Hildebrand, Introduction to Numerical Analysis, 2nd ed., -! McGraw-Hill, 1974 (Dover reprint, 1987), Sect. 3.10. See, also, -! Abramowitz & Stegun, p.890.) For k=0, the cosine integral reduces to -! the extended form of Simpson's rule. -! -! NB: The input array xn must have equally spaced points. Moreover, it -! should contain an _odd_ number of points---or an even number of -! intervals. (If xn contains an even number of points, the rightmost -! point is ignored.) Also note that the usual definitions of Filon's -! formulas use index origin zero, so that the evaluation points are -! {x_0, x_1, ..., x_2n}. But many Fortran arrays have index origin -! one, which means the "even" points are those indexed 1, 3, 5, ..., -! while the "odd" points are those indexed 2, 4, 6, .... Sigh, ...! -! The implementation given here allows for an arbitrary index origin. -! -! Written by Peter Walstrom. -! Jan.2005 (DTA): Rewritten so that one may integrate over a portion -! of the data range. Also changed to implicit none. -!-----!----------------------------------------------------------------! - use parallel, only : idproc - implicit none -! -! arguments - double precision, dimension(0:), intent(in) :: xn,fn - double precision, intent(in) :: k - integer, intent(in) :: npts,io - double precision, intent(out) :: sinint,cosint -! -! local variables - double precision, parameter :: half=0.5d0,one=1.d0,zero=0.d0 - integer :: ii,ix,istart,iend,ievod,npoints - double precision :: h,theta,alf,bet,gam - double precision :: kx,coskx,sinkx,f,wt - double precision, dimension(3) :: dsinint,dcosint -! -! check parity of npts; if even, emit warning and reduce it by 1 - npoints=npts - if (2*(npts/2).eq.npts) then - if (idproc.eq.0) then - write(6,*) '<*** WARNING ***> from subroutine filon_io():' - write(6,*) ' must have an odd number of data points;' - write(6,*) ' ignoring last point!' - end if - npoints=npts-1 - end if -! -! set array endpoints - istart=io - iend=io+npoints-1 -! -! note step-size and get Filon weights - h=xn(istart+1)-xn(istart) - theta=h*k - call filon_wts(theta,alf,bet,gam) -c if (idproc.eq.0) then -c write(*,200) "filon weights:",theta,alf,bet,gam -c end if -c 200 format(1x,4(1pd11.4,1x)) -! -! initialize intermediate arrays to zero - do ievod=1,3 - dsinint(ievod)=zero - dcosint(ievod)=zero - end do -! -! perform Filon integration: -! -! ievod=1 --> odd points -! ievod=2 --> even points -! ievod=3 --> end points - ievod=2 - do ix=istart,iend - wt=one - if(ix.eq.istart.or.ix.eq.iend) wt=half - kx=k*xn(ix) - f=wt*fn(ix) - sinkx=dsin(kx) - coskx=dcos(kx) - dsinint(ievod)=dsinint(ievod)+f*sinkx - dcosint(ievod)=dcosint(ievod)+f*coskx - if(ievod.eq.2) then - ievod=1 - else - ievod=2 - endif - end do -! end points (upper end first) - do ii=1,2 - if(ii.eq.1) then - ix=iend - wt=one - else - ix=istart - wt=-one - endif - kx=k*xn(ix) - f=wt*fn(ix) - dsinint(3)=dsinint(3)-f*dcos(kx) - dcosint(3)=dcosint(3)+f*dsin(kx) - end do -! now sum the Filon-weighted contributions from ievod=1,2,3 - sinint=h*(alf*dsinint(3)+bet*dsinint(2)+gam*dsinint(1)) - cosint=h*(alf*dcosint(3)+bet*dcosint(2)+gam*dcosint(1)) -! - return - end subroutine filon_io -! -!*********************************************************************** - subroutine zs_adam11(zmin,zmax,nzsteps,zvals) -! Compute for given (zmin,zmax,nzsteps) the z-values required by adam11 -! Note: This routine requires size(zvals) >= nzsteps+rkxtra. - implicit none - double precision, intent(in) :: zmin,zmax ! end-points in z - integer, intent(in) :: nzsteps ! number of z integration steps - double precision, dimension(0:), intent(out) :: zvals -!-----!----------------------------------------------------------------! - double precision, dimension(7) :: rkvec - integer :: ih,ir,iz,nzvals - double precision :: dz,hq,z -c - ! define the step-size fractions used in the initial Runge-Kutta - ! steps required by the 11th-order Adams integration routine - rkvec(1)=0.d0 - rkvec(2)=1.d0/9.d0 - rkvec(3)=1.d0/6.d0 - rkvec(4)=1.d0/3.d0 - rkvec(5)=1.d0/2.d0 - rkvec(6)=2.d0/3.d0 - rkvec(7)=5.d0/6.d0 -c - ! compute z values - dz=(zmax-zmin)/nzsteps - hq=dz/5.d0 - nzvals=-1 - do iz=0,nzsteps - if (iz.lt.9) then - do ih=0,4 - do ir=1,7 - nzvals=nzvals+1 - zvals(nzvals)=zmin+iz*dz+(ih+rkvec(ir))*hq - end do - end do - else - nzvals=nzvals+1 - zvals(nzvals)=zmin+iz*dz - endif - end do -cccccc -c write(6,*) "size(zvals)=",size(zvals) -c write(6,*) "zmin, zmax, nzsteps =",zmin,zmax,nzsteps -c write(6,*) "dz, hq =",dz,hq -c do iz=0,nzvals -c write(6,*) iz,zvals(iz) -c end do -cccccc - return - end subroutine zs_adam11 - - end module e_gengrad - diff --git a/OpticsJan2020/MLI_light_optics/Src/ebcomp.f b/OpticsJan2020/MLI_light_optics/Src/ebcomp.f deleted file mode 100644 index eb971e6..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/ebcomp.f +++ /dev/null @@ -1,1138 +0,0 @@ -************************************************************************ - function angle(x,y) -c -c compute the angle defined by the points (x,y), (0,0), and (1,0) -c returns a value in [0,twopi) -c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! - use math_consts - implicit none - double precision angle,x,y - double precision t -c - t=datan2(y,x) - if(t.lt.0.d0) t=t+twopi - angle=t -c - return - end -c -************************************************************************ - subroutine cegengrad(fnin,ftype,infiles,nfile,kfile,jfile, & - & zi,zf,nz,f,r,kmx,nk,nprec) -c -c Compute generalized gradients for an rf cavity. - use parallel, only : idproc - use math_consts - use phys_consts - use e_gengrad - implicit none - character(80), intent(in) :: fnin ! filename or base filename - character(8), intent(in) :: ftype ! file type - integer, intent(in) :: infiles ! number of input files - integer, intent(in) :: nfile ! file unit number for output - integer, intent(in) :: kfile ! file unit number for output of e0 - integer, intent(in) :: jfile ! file unit number for output of efld - double precision, intent(inout) :: zi, zf ! initial and final z - integer, intent(in) :: nz ! number of z intervals - double precision, intent(inout) :: f ! cavity frequency - double precision, intent(in) :: r ! extract data at this radius - double precision, intent(in) :: kmx ! maximum wave number k - integer, intent(in) :: nk ! number of k intervals - integer, intent(in) :: nprec ! precision at which to write data -c-----!----------------------------------------------------------------! - type (Efield_data) efield - type (charfn) e0 -c - nullify(efield%zvals) - nullify(efield%Ezdata) - !nullify(efield%Erdata) - !nullify(efield%Btdata) - nullify(e0%e0r) - nullify(e0%e0i) -c - if (trim(ftype).eq."t7") then - call read_efield_t7(fnin,infiles,zi,zf,f,r,efield) - else if (trim(ftype).eq."ez") then - call read_efield_ez(fnin,infiles,jfile,zi,zf,f,r,efield) - else - if (idproc.eq.0) then - write(6,*) "<*** ERROR ***> in ebcomp::cegengrad:" - write(6,*) " File type ",trim(ftype)," not recognized!" - end if - call myexit() - end if - call comp_charfn(efield,kmx,nk,kfile,e0) - call comp_egengrads(nfile,e0,zi,zf,nz) - close(nfile) -c - if(associated(efield%zvals)) deallocate(efield%zvals) - if(associated(efield%Ezdata)) deallocate(efield%Ezdata) - !if(associated(efield%Erdata)) deallocate(efield%Erdata) - !if(associated(efield%Btdata)) deallocate(efield%Btdata) - if(associated(e0%e0r)) deallocate(e0%e0r) - if(associated(e0%e0i)) deallocate(e0%e0i) -c - return - end -c -************************************************************************ - subroutine nlrfcav(zed,zlc,zh,nst,tm,gm,h,mh) -c -c Compute nonlinear map for slice of an rf cavity. - use parallel, only : idproc - use math_consts - use phys_consts - use beamdata - use lieaparam, only : monoms - use e_gengrad - implicit none - double precision, intent(in) :: zed ! z at cavity entrance (edge) - double precision, intent(in) :: zlc ! z at slice entrance - double precision, intent(in) :: zh ! length of slice - integer, intent(in) :: nst ! number of z-steps for this slice - double precision, intent(inout) :: tm ! w_scl*t_g at slice - double precision, intent(inout) :: gm ! rel. gamma at slice - ! Lie generators, h, and linear map, mh, for slice - double precision, dimension(monoms), intent(out) :: h - double precision, dimension(6,6), intent(out) :: mh -c-----!----------------------------------------------------------------! - include 'map.inc' - integer :: i,j - double precision :: betgam,engin,engfin -c - if (idproc.eq.0) then - write (6,*) "ebcomp::nlrfcav" - write (6,*) " ...under construction..." - end if -c -c sanity check - if (zh.le.0.) then - if (idproc.eq.0) then - write(6,*) "<*** ERROR ***> in ebcomp::nlrfcav:" - write(6,*) " The slice length zh (=",zh,") must exceed zero!" - endif - call myexit() - endif -c -c initialize map to identity - do i=1,6 - do j=1,6 - mh(i,j)=0.d0 - end do - mh(i,i)=1.d0 - end do - do i=1,monoms - h(i)=0.d0 - end do -c -c print initial map - !if (idproc.eq.0) then - ! write(6,*) '%%%%%%%%%%%%%%%%%%%%%%%%%%' - ! write(6,*) '==initial transfer map==' - ! write(6,*) ' matrix part:' - ! do i=1,6 - ! write(6,*) (mh(i,j),j=1,6) - ! end do - ! write(6,*) ' nonlinear generators:' - ! do i=1,monoms - ! if (h(i).ne.0.d0) then - ! write(6,*) 'h(',i,')=',h(i) - ! end if - ! end do - ! write(6,*) '%%%%%%%%%%%%%%%%%%%%%%%%%%' - !end if -c - engin=gm*pmass - if (idproc.eq.0) then - write(36,*) arclen,engin - call myflush(36) - endif - if (idproc.eq.0) then - write (6,*) 'calling subroutine mapnlrfcav() ...' - write (6,*) 'zed,zlc,zh,nst,tm,gm=' - write (6,*) zed,zlc,zh,nst,tm,gm - end if - call mapnlrfcav(zed,zlc,zh,nst,tm,gm,h,mh) - if (idproc.eq.0) then - write (6,*) 'returned from subroutine mapnlrfcav() ...' - write (6,*) 'zed,zlc,zh,nst,tm,gm=' - write (6,*) zed,zlc,zh,nst,tm,gm - end if - ! update beamdata: gamma, gamm1, beta, and brho - gamma=gm - gamm1=gamma-1.d0 - betgam=sqrt(gamm1*(gamma+1.d0)) - beta=betgam/gamma - brho=pmass*betgam/c_light - engfin=pmass*gamma - if (idproc.eq.0) then - write(36,*) arclen,engfin - write(36,*) ' ' - call myflush(36) - endif -c - return - end -c -************************************************************************ - subroutine mapnlrfcav(zed,zlc,zh,nst,tm,gm,h,mh) -c -c Compute nonlinear map for slice of an rf cavity. - use parallel, only : idproc - use math_consts - use phys_consts - use beamdata - use lieaparam, only : monoms - use e_gengrad - implicit none - double precision, intent(in) :: zed ! z at cavity entrance (edge) - double precision, intent(in) :: zlc ! z at slice entrance - double precision, intent(in) :: zh ! length of slice - integer, intent(in) :: nst ! number of z-steps for this slice - double precision, intent(inout) :: tm ! w_scl*t_g at slice - double precision, intent(inout) :: gm ! rel. gamma at slice - ! Lie generators, h, and linear map, mh, for slice - double precision, dimension(monoms), intent(inout) :: h - double precision, dimension(6,6), intent(inout) :: mh -c-----!----------------------------------------------------------------! - !!!! module anyone? !!!! - integer iflag - include 'hmflag.inc' - !!!! ^^^^^^^^^^^^^^ !!!! - integer, parameter :: neqn=monoms+15 - integer :: i,j - character(len=6) :: stctd - double precision :: dz - double precision, dimension(neqn) :: y -c - if (idproc.eq.0) then - write (6,*) "ebcomp::mapnlrfcav" - write (6,*) " ...under construction..." - end if -c -c array y comprises the quantities to integrate -c y(1-6) = given (design) trajectory -c y(7-42) = matrix (6x6) -c y(43-98) = f3 coefficients -c y(99-224) = f4 coefficients -c y(225-476) = f5 coefficients -c y(477-938) = f6 coefficients - y=0.d0 -c initialize design trajectory -c x = p_x = y = p_y = 0 -c tau = omega_ref t -c p_tau = -m gamma c^2/(omega_ref sl p_ref) - y(1:4)=0.d0 - y(5)=tm - y(6)=-gm*pmass/(omegascl*sl*p0sc) -c initialize rest to identity - do i=1,6 - y(7*i)=1.d0 - end do -c -c set flag that says "rf cavity" (really!, this approach seems antique) -c the subroutine feval uses this flag to switch to the correct RHSs -c as the differential equations for the map - iflag=5 -c now integrate map equations of motion - !if (zlc.eq.zed) then - ! stctd='start ' - !else - ! stctd='cont ' - !end if - stctd='start ' - dz=zh/nst - if (idproc.eq.0) then - write (6,*) "calling adam11() with arguments" - write (6,*) " eggrdata%dz =",eggrdata%dz - write (6,*) " eggrdata%nz_intrvl =",eggrdata%nz_intrvl - write (6,*) " dz =",dz - write (6,*) " nst =",nst - write (6,*) " stctd =",stctd - write (6,*) " zlc =",zlc - write (6,*) " size(y) =",size(y) - write (6,*) " neqn =",neqn - endif - !call adam11(eggrdata%dz,eggrdata%nz_intrvl,stctd,zlc,y,neqn) - call adam11(dz,nst,stctd,zlc,y,neqn) - write (6,*) "...returned from adam11()" - call errchk(y(7)) - call putmap(y,h,mh) - tm=y(5) - gm=-y(6)*(omegascl*sl*p0sc)/pmass -c - return - end -c -************************************************************************ - subroutine nlrfvecpot(z,y) -c -c Use generalized gradients in eggr to compute vector potential at z. -c The vector potential is multiplied by rf_escale*(e/p_ref). - use parallel, only : idproc - use beamdata, only : sl,p0sc,omegascl,pmass - use math_consts - use phys_consts - use e_gengrad - use curve_fit - implicit none - double precision, intent(in) :: z ! determine vec. pot. here - double precision, intent(in) :: y(:) ! y(1:6)=ref. ptcl. (scaled) -c-----!----------------------------------------------------------------! - include 'map.inc' - integer, save :: iz=0 - integer :: i,j - double precision, parameter :: tiny=2.0d-16 - double precision :: wl,wr,mwr2,phiz,cphiz,sphiz,cfwrl,sfwl - double precision :: sclfac - double precision :: sl2,sl3,sl4,sl5,sl6 - double precision, dimension(:,:), allocatable :: Crc,Czc -c - !if (idproc.eq.0) then - ! write (6,*) "(ebcomp)::nlrfvecpot(",z,")" - ! write (6,*) " ...under construction..." - !end if - - ! allocate temporary arrays - allocate(Crc(0:eggrdata%maxj,0:eggrdata%maxm)) - allocate(Czc(0:eggrdata%maxj,0:eggrdata%maxm)) - -c find index iz ofzvals nearest z (zvals has index origin 0) - call cf_searchNrst(eggrdata%zvals,z,iz,iorigin=0) - if (dabs(eggrdata%zvals(iz)-z).le.tiny) then - Czc(0,0)=eggrdata%G3c(iz,0,0) - do j=1,eggrdata%maxj - Crc(j,0)=eggrdata%G1c(iz,j,0) - Czc(j,0)=eggrdata%G3c(iz,j,0) - end do - else - call cf_polyInterp3(eggrdata%zvals,eggrdata%G3c(:,0,0), - & z,Czc(0,0),iz,iorigin=0) - do j=1,eggrdata%maxj - call cf_polyInterp3(eggrdata%zvals,eggrdata%G1c(:,j,0), - & z,Crc(j,0),iz,iorigin=0) - call cf_polyInterp3(eggrdata%zvals,eggrdata%G3c(:,j,0), - & z,Czc(j,0),iz,iorigin=0) - end do - end if -c compute phase phi(z) and other factors - wl=eggrdata%angfrq - wr=wl/omegascl - mwr2=-wr**2 - phiz=wr*y(5)+rf_phase - cphiz=dcos(phiz); cfwrl=cphiz*wr/wl - sphiz=dsin(phiz); sfwl=sphiz/wl - sl2=sl**2; sl3=sl2*sl; sl4=sl3*sl; sl5=sl4*sl; sl6=sl5*sl -cryneabell:09.Nov.05 - write(44,*) z,phiz,y(5:6),y(7:12) - write(45,*) z,rf_escale*Czc(0,0),-rf_escale*Crc(1,0) -cryneabell---------- -c A_x - vp%Ax(1) = -Crc(1,0)*sfwl*sl/2.d0 - vp%Ax(11) = -Crc(1,0)*cfwrl*sl/2.d0 - vp%Ax(28) = -Crc(2,0)*sfwl*sl3/32.d0 - vp%Ax(39) = vp%Ax(28) - vp%Ax(46) = mwr2*vp%Ax(1)/2.d0 - vp%Ax(88) = -Crc(2,0)*cfwrl*sl3/32.d0 - vp%Ax(122) = vp%Ax(88) - vp%Ax(136) = mwr2*vp%Ax(11)/6.d0 - vp%Ax(210) = -Crc(3,0)*sfwl*sl5/1152.d0 - vp%Ax(221) = 2.d0*vp%Ax(210) - vp%Ax(228) = mwr2*vp%Ax(39)/2.d0 - vp%Ax(301) = vp%Ax(210) - vp%Ax(308) = vp%Ax(228) - vp%Ax(331) = mwr2*vp%Ax(46)/12.d0 - vp%Ax(466) = -Crc(3,0)*cfwrl*sl5/1152.d0 - vp%Ax(500) = 2.d0*vp%Ax(466) - vp%Ax(514) = mwr2*vp%Ax(122)/6.d0 - vp%Ax(660) = vp%Ax(466) - vp%Ax(674) = vp%Ax(514) - vp%Ax(708) = mwr2*vp%Ax(136)/20.d0 -c A_y - vp%Ay(3) = vp%Ax(1) - vp%Ay(20) = vp%Ax(11) - vp%Ay(30) = vp%Ax(28) - vp%Ay(64) = vp%Ax(39) - vp%Ay(71) = vp%Ax(46) - vp%Ay(97) = vp%Ax(88) - vp%Ay(177) = vp%Ax(122) - vp%Ay(191) = vp%Ax(136) - vp%Ay(212) = vp%Ax(210) - vp%Ay(246) = vp%Ax(221) - vp%Ay(253) = vp%Ax(228) - vp%Ay(406) = vp%Ax(301) - vp%Ay(413) = vp%Ax(308) - vp%Ay(436) = vp%Ax(331) - vp%Ay(475) = vp%Ax(466) - vp%Ay(555) = vp%Ax(500) - vp%Ay(569) = vp%Ax(514) - vp%Ay(842) = vp%Ax(660) - vp%Ay(856) = vp%Ax(674) - vp%Ay(890) = vp%Ax(708) -c A_z - vp%Az(0) = -Czc(0,0)*sfwl - vp%Az(5) = -Czc(0,0)*cfwrl - vp%Az(7) = -Czc(1,0)*sfwl*sl2/4.d0 - vp%Az(18) = vp%Az(7) - vp%Az(25) = mwr2*vp%Az(0)/2.d0 - vp%Az(32) = -Czc(1,0)*cfwrl*sl2/4.d0 - vp%Az(66) = vp%Az(32) - vp%Az(80) = mwr2*vp%Az(5)/6.d0 - vp%Az(84) = -Czc(2,0)*sfwl*sl4/64.d0 - vp%Az(95) = 2.d0*vp%Az(84) - vp%Az(102) = mwr2*vp%Az(18)/2.d0 - vp%Az(175) = vp%Az(84) - vp%Az(182) = vp%Az(102) - vp%Az(205) = mwr2*vp%Az(25)/12.d0 - vp%Az(214) = -Czc(2,0)*cfwrl*sl4/64.d0 - vp%Az(248) = 2.d0*vp%Az(214) - vp%Az(262) = mwr2*vp%Az(66)/6.d0 - vp%Az(408) = vp%Az(214) - vp%Az(422) = vp%Az(262) - vp%Az(456) = mwr2*vp%Az(80)/20.d0 - vp%Az(462) = -Czc(3,0)*sfwl*sl6/2304.d0 - vp%Az(473) = 3.d0*vp%Az(462) - vp%Az(480) = mwr2*vp%Az(175)/2.d0 - vp%Az(553) = vp%Az(473) - vp%Az(560) = 2.d0*vp%Az(480) - vp%Az(583) = mwr2*vp%Az(182)/12.d0 - vp%Az(840) = vp%Az(462) - vp%Az(847) = vp%Az(480) - vp%Az(870) = vp%Az(583) - vp%Az(917) = mwr2*vp%Az(205)/30.d0 -c scale vector potential by rf_escale/(p_ref/e) = rf_escale*c/(mc^2/e) - sclfac=rf_escale*c_light/pmass - vp%Ax=sclfac*vp%Ax - vp%Ay=sclfac*vp%Ay - vp%Az=sclfac*vp%Az -c - !if (idproc.eq.0) then - ! write(6,*) "nlrf vector potential components" - ! write(6,*) " =scale factors=" - ! write(6,*) " sclfac =",sclfac - ! write(6,*) " wl, wr =",wl,wr - ! write(6,*) " phiz =",phiz - ! write(6,*) " Crc0j(z) =",(Crc(j,0),j=1,3) - ! write(6,*) " Czc0j(z) =",(Czc(j,0),j=0,3) - ! write(6,*) " =x=" - ! do i=0,monoms - ! if (vp%Ax(i).ne.0.d0) then - ! write(6,*) 'Ax(',i,')=',vp%Ax(i) - ! end if - ! end do - ! write(6,*) " =y=" - ! do i=0,monoms - ! if (vp%Ay(i).ne.0.d0) then - ! write(6,*) 'Ay(',i,')=',vp%Ay(i) - ! end if - ! end do - ! write(6,*) " =z=" - ! do i=0,monoms - ! if (vp%Az(i).ne.0.d0) then - ! write(6,*) 'Az(',i,')=',vp%Az(i) - ! end if - ! end do - !end if -c - ! deallocate temporary arrays - deallocate(Crc) - deallocate(Czc) -c - return - end -c -!*********************************************************************** - subroutine hmltnRF(s,y,h) -! Given longitudinal position s and phase-space coordinates y(1:6) of -! the reference particle, compute an expansion of the Hamiltonian h for -! an RF cavity. -! Based on the approach used in hmltn3 (by F. Neri): compute the -! hamiltonian using a polynomial expansion of the square root. -! (Later, we can use this to test a hard-wired version.) - use math_consts - use phys_consts - use lieaparam, only : monoms - use beamdata - use e_gengrad - use parallel, only : idproc - implicit none - double precision, intent(in) :: s ! longitudinal coordinate - double precision, intent(inout) :: y(:) ! y(1:6)=ref. ptcl. - double precision, intent(out) :: h(:) ! rf cavity Hamiltonian -!-----!----------------------------------------------------------------! -************************************************************************ - interface - subroutine nlrfvecpot(s,y) - implicit none - double precision, intent(in) :: s ! longitudinal coordinate - double precision, intent(in) :: y(:) ! y(1:6)=ref. ptcl. data - end subroutine nlrfvecpot - end interface -************************************************************************ - include 'expon.inc' - integer, parameter :: maxord=6 - integer :: i,j - double precision :: bg,gammag,wlbyc - double precision, dimension(0:maxord) :: a - double precision, dimension(0:monoms) :: pkx1,pky1,pkx2,pky2 - double precision, dimension(0:monoms) :: x,yy -c - !if (idproc.eq.0) then - ! print '(a,1pe16.9,a)',"(ebcomp)::hmltnRF[ s=",s,"]=" - ! do j=1,monoms - ! if(h(j).ne.0.d0) then - ! print '(2x,a,i3,a,1pe16.9,2x,3(2i1,1x))', & - ! &! 'h(',j,')=',h(j),(expon(i,j),i=1,6) - ! end if - ! end do - ! do j=1,monoms - ! if(y(j).ne.0.d0) then - ! print '(2x,a,i3,a,1pe16.9,2x,3(2i1,1x))', & - ! &! 'y(',j,')=',y(j),(expon(i,j),i=1,6) - ! end if - ! end do - !end if -c -c coefficients in expansion of 1-sqrt(1+x) - a(0) = 0.d0 - a(1) = -1.d0/2.d0 - do j=2,maxord - a(j)=a(j-1)*(1.5d0/j-1.d0) - end do -c -c factors - wlbyc=omegascl*sl/c_light - gammag=-wlbyc*y(6) - bg=sqrt((gammag+1.d0)*(gammag-1.d0)) -c -c compute rf cavity vector potential - !write(6,*) "calling nlrfvecpot ..." - call nlrfvecpot(s,y) - !write(6,*) "returned from nlrfvecpot ..." -c -c construct Hamiltonian - pkx1=0.d0; pkx1(2)=1.d0; pkx1=pkx1-vp%Ax - pky1=0.d0; pky1(4)=1.d0; pky1=pky1-vp%Ay - call pmult(pkx1,pkx1,pkx2,maxord) - call pmult(pky1,pky1,pky2,maxord) - x=0.d0; x(6)=-2.d0*gammag*wlbyc; x(27)=wlbyc**2 - x=(x-pkx2-pky2)/(bg**2) -c yy = 1-sqrt(1+x) - call poly1(maxord,a,x,yy,maxord) -c h = {bg*[1-sqrt(1+x)]-Az}/sl, but don't include constant -c or linear terms because we've already removed them - h=0.d0 - do j=7,monoms - h(j)=(bg*yy(j)-vp%Az(j))/sl - end do -c - !if (idproc.eq.0) then - ! print '(a,1pe16.9,a)',"(ebcomp)::hmltnRF[ s=",s,"]=" - ! do j=1,monoms - ! if(h(j).ne.0.d0) then - ! print '(2x,a,i3,a,1pe16.9,2x,3(2i1,1x))', & - ! &! 'h(',j,')=',h(j),(expon(i,j),i=1,6) - ! end if - ! end do - !end if -c - return - end subroutine hmltnRF -c -************************************************************************ - function finterp(x,xx,a,b,c,n) -c -c This subroutine interpolates at x the value of a function described -c by the n-element arrays a, b, and c. These arrays hold the quadratic -c fit parameter determined at the n locations xx by subroutine parfit. -c NB: The values in xx MUST increase (or decrease) monotonically. -c-----!----------------------------------------------------------------! - implicit none - double precision finterp - integer n,k - double precision a(n),b(n),c(n),xx(n),x -c - call locate(xx,n,x,k) - if(k.lt.1) then - k=1 - else if(k.gt.(n-1)) then - k=n-1 - endif - finterp=a(k)+x*(b(k)+x*c(k)) -c - return - end -c -************************************************************************ - function finterA(ang) -c -c This subroutine interpolates in the azimuthal direction a field value -c for some component of E or B. It first uses 'locate' to find where -c ang lies in the array phin; it then uses coefficients determined by -c 'parfit' to interpolate a value for that field component. -c NB: The angles in phin must increase (or decrease) monotonically. -c-----!----------------------------------------------------------------! - include 'impli.inc' - include 'ebdata.inc' -c - call locate(phin,maxna,ang,n) - if(n.lt.1) then - n=1 - else if(n.gt.(maxna-1)) then - n=maxna-1 - endif - finterA=aia(n)+ang*(bia(n)+ang*cia(n)) -c - return - end -c -************************************************************************ - function finterZ(z) -c -c This subroutine interpolates in the longitudinal direction a field -c value for some component of E or B. It first uses 'locate' to find -c where z lies in the array zn; it then uses coefficients determined by -c 'parfit' to interpolate a value for that field component. -c NB: The z's in zn must increase (or decrease) monotonically. -c-----!----------------------------------------------------------------! - include 'impli.inc' - include 'ebdata.inc' -c - call locate(zn,maxnz,z,n) - if(n.lt.1) then - n=1 - else if(n.gt.(maxnz-1)) then - n=maxnz-1 - endif - finterZ=aiz(n)+z*(biz(n)+z*ciz(n)) -c - return - end -c -************************************************************************ - subroutine filonint(xmin,xmax,y,nsteps,fname,sinint,cosint) -c -c Generic Filon integrator: -c This subroutine uses Filon's method to evaluate the integrals from -c xmin to xmax of -c -c fname(x) sin y*x dx -c and fname(x) cos y*x dx -c -c Filon's method allows one to evaluate the integral of an oscillating -c function without having to follow every wiggle with many evaluation -c points. Here the number of function evaluations equals 2*nsteps+3. -c This version has only a single frequency, y. -c (See F.B.Hildebrand, Introduction to Numerical Analysis, 2nd ed., -c McGraw-Hill, 1974 (Dover reprint, 1987), Sect. 3.10. See, also, -c Abramowitz & Stegun, p.890.) For y=0, the cosine integral reduces -c to the extended form of Simpson's rule. -c -c Written by Peter Walstrom. -c-----!----------------------------------------------------------------! - include 'impli.inc' - external fname -c - parameter(half=0.5d0,one=1.d0,zero=0.d0) - dimension dsinint(3),dcosint(3) -c -c compute step-size - h=(xmax-xmin)*half/dfloat(nsteps) -c get Filon weights - theta=h*y - call filon_wts(theta,alf,bet,gam) -c write(20,200) theta,alf,bet,gam -c 200 format(1x,4(1pd11.4,1x)) -c -c initialize intermediate arrays to zero - do 111 ievod=1,3 - dsinint(ievod)=zero - 111 dcosint(ievod)=zero -c -c perform Filon integration: -c -c step through odd, then even, x values - do 2 ievod=1,2 -c ievod=1 --> odd points -c ievod=2 --> even points -c ievod=3 --> end points - nstp=nsteps -c extra x value in set of even points - if(ievod.eq.2) nstp=nsteps+1 - do 2 n=1,nstp - if(ievod.eq.2) go to 3 -c odd points - x=h*dfloat(2*n-1)+xmin - wt=one - go to 4 -c even points - 3 wt=one - if(n.eq.1) wt=half - if(n.eq.nstp) wt=half - x=h*dfloat(2*n-2)+xmin - 4 continue - f=wt*fname(x) - xy=x*y - cosxy=dcos(xy) - sinxy=dsin(xy) - dsinint(ievod)=dsinint(ievod)+f*sinxy - 2 dcosint(ievod)=dcosint(ievod)+f*cosxy -c end points (upper end first) - x=xmax - wt=one - do 5 iend=1,2 - xy=y*x - cosxy=dcos(xy) - sinxy=dsin(xy) - f=wt*fname(x) - dsinint(3)=dsinint(3)-f*cosxy - dcosint(3)=dcosint(3)+f*sinxy - x=xmin - 5 wt=-one -c now sum the Filon-weighted contributions from ievod=1,2,3 - sinint=h*(alf*dsinint(3)+bet*dsinint(2)+gam*dsinint(1)) - cosint=h*(alf*dcosint(3)+bet*dcosint(2)+gam*dcosint(1)) -c - return - end -c -************************************************************************ - subroutine filonarr(xn,fn,y,npts,sinint,cosint) -c -c Generic Filon integrator---array version: -c This subroutine uses Filon's method to evaluate the integrals from -c xn(1) to xn(npts) of -c -c fn(x) sin y*x dx -c and fn(x) cos y*x dx -c -c where fn is also an array of length npts. Filon's method allows one -c to evaluate the integral of an oscillating function without having to -c follow every wiggle with many evaluation points. This version has -c only a single frequency, y. (See F.B.Hildebrand, Introduction to -c Numerical Analysis, 2nd ed., McGraw-Hill, 1974 (Dover reprint, 1987), -c Sect. 3.10. See, also, Abramowitz & Stegun, p.890.) For y=0, the -c cosine integral reduces to the extended form of Simpson's rule. -c -c NB: The input array xn must have equally spaced points. Moreover, it -c should contain an _odd_ number of points. (If xn contains an even -c number of points, the rightmost point is ignored.) Also note that -c the usual definitions of Filon's formulas use index origin zero, so -c that the evaluation points are {x_0, x_1, ..., x_2n}. But the -c implementation below uses index origin one, so that the "even" points -c are those indexed 1, 3, 5, ..., while the "odd" points are those -c indexed 2, 4, 6, .... Sigh, ...! -c -c Written by Peter Walstrom. -c-----!----------------------------------------------------------------! - include 'impli.inc' -c -c calling arrays - parameter(maxpts=4001) - dimension xn(maxpts),fn(maxpts) -c - parameter(half=0.5d0,one=1.d0,zero=0.d0) - dimension dsinint(3),dcosint(3) -c -c -c check parity of npts; if even, reduce it by 1 - npoints=npts - if(2*(npts/2).eq.npts) then - write(6,*) 'WARNING from subroutine filonarr():' - write(6,*) ' must have an odd number of data points;' - write(6,*) ' ignoring last point!' - npoints=npts-1 - endif - nhalf=npoints/2 -c note step-size - h=xn(2)-xn(1) -c get Filon weights - theta=h*y - call filon_wts(theta,alf,bet,gam) -c write(20,200) theta,alf,bet,gam -c 200 format(1x,4(1pd11.4,1x)) -c -c initialize intermediate arrays to zero - do 111 ievod=1,3 - dsinint(ievod)=zero - 111 dcosint(ievod)=zero -c -c perform Filon integration: -c -c step through odd, then even, x values - do 2 ievod=1,2 -c ievod=1 --> odd points -c ievod=2 --> even points -c ievod=3 --> end points - nstp=nhalf -c extra x value in set of even points - if(ievod.eq.2) nstp=nhalf+1 - do 2 n=1,nstp - if(ievod.eq.2) go to 3 -c "odd" points (n=2,4,6,...,npts-1) - x=xn(2*n) - f=fn(2*n) - wt=one - go to 4 -c "even" points (n=1,3,5, ... npts) - 3 wt=one - if(n.eq.1) wt=half - if(n.eq.nstp) wt=half - x=xn(2*n-1) - f=fn(2*n-1) - 4 continue - f=wt*f - xy=x*y - cosxy=dcos(xy) - sinxy=dsin(xy) - dsinint(ievod)=dsinint(ievod)+f*sinxy - 2 dcosint(ievod)=dcosint(ievod)+f*cosxy -c end points (upper end first) - n=npoints - wt=one - do 5 iend=1,2 - x=xn(n) - xy=y*x - cosxy=dcos(xy) - sinxy=dsin(xy) - f=wt*fn(n) - dsinint(3)=dsinint(3)-f*cosxy - dcosint(3)=dcosint(3)+f*sinxy - n=1 - 5 wt=-one -c now sum the Filon-weighted contributions from ievod=1,2,3 - sinint=h*(alf*dsinint(3)+bet*dsinint(2)+gam*dsinint(1)) - cosint=h*(alf*dcosint(3)+bet*dcosint(2)+gam*dcosint(1)) -c - return - end -c -************************************************************************ - subroutine filonarr_io(xn,fn,k,io,npts,sinint,cosint) -c -c Generic Filon integrator---array version with variable index origin: -c This subroutine uses Filon's method to evaluate the integrals from -c xn(io) to xn(io+npts-1) of -c -c fn(x) sin k*x dx -c and fn(x) cos k*x dx -c -c where fn is also an array of length npts with the same index origin -C io. Filon's method allows one to evaluate the integral of an -c oscillating function without having to follow every wiggle with many -c evaluation points. This version has only a single frequency, k. -c (See F.B.Hildebrand, Introduction to Numerical Analysis, 2nd ed., -c McGraw-Hill, 1974 (Dover reprint, 1987), Sect. 3.10. See, also, -c Abramowitz & Stegun, p.890.) For k=0, the cosine integral reduces to -c the extended form of Simpson's rule. -c -c NB: The input array xn must have equally spaced points. Moreover, it -c should contain an _odd_ number of points---or an even number of -c intervals. (If xn contains an even number of points, the rightmost -c point is ignored.) Also note that the usual definitions of Filon's -c formulas use index origin zero, so that the evaluation points are -c {x_0, x_1, ..., x_2n}. But many Fortran arrays have index origin -c one, which means the "even" points are those indexed 1, 3, 5, ..., -c while the "odd" points are those indexed 2, 4, 6, .... Sigh, ...! -c The implementation given here allows for an arbitrary index origin. -c -c Written by Peter Walstrom. -c Jan.2005 (DTA): Modified to allow for arbitrary index origin, and -c changed to implicit none. -c-----!----------------------------------------------------------------! - implicit none -c -c arguments - double precision, dimension(:), intent(in) :: xn,fn - double precision, intent(in) :: k - integer, intent(in) :: npts,io - double precision, intent(out) :: sinint,cosint -c -c local variables - double precision, parameter :: half=0.5d0,one=1.d0,zero=0.d0 - integer :: ii,ix,istart,iend,ievod,npoints - double precision :: h,theta,alf,bet,gam - double precision :: kx,coskx,sinkx,f,wt - double precision, dimension(3) :: dsinint,dcosint -c -c check parity of npts; if even, emit warning and reduce it by 1 - npoints=npts - if(2*(npts/2).eq.npts) then - write(6,*) '<*** WARNING ***> from subroutine filonarr():' - write(6,*) ' must have an odd number of data points;' - write(6,*) ' ignoring last point!' - npoints=npts-1 - endif -c -c set array endpoints - istart=io - iend=io+npoints-1 -c note step-size and get Filon weights - h=xn(istart+1)-xn(istart) - theta=h*k - call filon_wts(theta,alf,bet,gam) -c write(*,200) "filon weights:",theta,alf,bet,gam -c 200 format(1x,4(1pd11.4,1x)) -c -c initialize intermediate arrays to zero - do ievod=1,3 - dsinint(ievod)=zero - dcosint(ievod)=zero - end do -c -c perform Filon integration: -c -c ievod=1 --> odd points -c ievod=2 --> even points -c ievod=3 --> end points - ievod=2 - do ix=istart,iend - wt=one - if(ix.eq.istart.or.ix.eq.iend) wt=half - kx=k*xn(ix) - f=wt*fn(ix) - sinkx=dsin(kx) - coskx=dcos(kx) - dsinint(ievod)=dsinint(ievod)+f*sinkx - dcosint(ievod)=dcosint(ievod)+f*coskx - if(ievod.eq.2) then - ievod=1 - else - ievod=2 - endif - end do -c end points (upper end first) - do ii=1,2 - if(ii.eq.1) then - ix=iend - wt=one - else - ix=istart - wt=-one - endif - kx=k*xn(ix) - f=wt*fn(ix) - dsinint(3)=dsinint(3)-f*dcos(kx) - dcosint(3)=dcosint(3)+f*dsin(kx) - end do -c now sum the Filon-weighted contributions from ievod=1,2,3 - sinint=h*(alf*dsinint(3)+bet*dsinint(2)+gam*dsinint(1)) - cosint=h*(alf*dcosint(3)+bet*dcosint(2)+gam*dcosint(1)) -c - return - end -c -************************************************************************ - subroutine filon_wts(theta,alpha,beta,gamma) -c -c This subroutine computes the weights for Filon's integration method. -c-----!----------------------------------------------------------------! - implicit none -c -c arguments - double precision :: theta - double precision :: alpha,beta,gamma -c -c local variables - double precision, parameter :: a1=2.d0/4.5d1,a2=2.d0/3.15d2, & - & a3=2.d0/4.725d3,a4=8.d0/4.67775d5 - double precision, parameter :: b0=2.d0/3.d0,b1=2.d0/1.5d1, & - & b2=4.d0/1.05d2,b3=2.d0/5.67d2, & - & b4=4.d0/2.2275d4,b5=4.d0/6.75675d5 - double precision, parameter :: c0=4.d0/3.0d0,c1=2.d0/1.5d1, & - & c2=1.d0/2.1d2,c3=1.d0/1.134d4, & - & c4=1.d0/9.9792d5,c5=1.d0/1.297296d8 - double precision, parameter :: one=1.d0,two=2.d0,smal1=1.d-1 - double precision :: t2,t3 - double precision :: onoth,tuoth2,costh,sinc,cs -c -c small-angle approximation - if(dabs(theta).gt.smal1) go to 11 - t2=theta**2 - t3=theta*t2 - alpha=t3*(a1-t2*(a2-t2*(a3-t2*a4))); - beta=b0+t2*(b1-t2*(b2-t2*(b3-t2*(b4-t2*b5)))); - gamma=c0-t2*(c1-t2*(c2-t2*(c3-t2*(c4-t2*c5)))); - return -c -c full computation - 11 onoth=one/theta - tuoth2=two*onoth*onoth - costh=dcos(theta) - sinc=dsin(theta)*onoth - cs=costh-two*sinc - alpha=onoth*(one+sinc*cs) - beta=tuoth2*(one+costh*cs) - gamma=two*tuoth2*(sinc-costh) - return -c - end -c -************************************************************************ - subroutine intsimpodd(n,f,out) -c -c Use Simpson's three-point rule to integrate a function whose values at -c n equally-spaced locations are given in array f; put result in "out". -c [Numerical Recipes (1992), p.128] -c Notes: 1) The array f must have an odd number of entries. -c 2) To obtain the desired integral, one MUST, after calling -c intsimpodd, multiply the result "out" by the stepsize. MV -c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! - include 'impli.inc' - integer n - double precision f(n),out -c - sum1=0 - sum2=0 - nhalf=n/2 -c - sum2=sum2+f(2) - do j=2,nhalf - sum2=sum2 + f(2*j) - sum1=sum1 + f(2*j-1) - enddo - out = (f(1) + 2.d0*sum1 + 4.d0*sum2 + f(n))/3.d0 -c - return - end -c -************************************************************************ - subroutine intsimp(n,f,out) -c -c Use Simpson's rule to integrate a function whose values at n equally- -c spaced locations are given in the array f; put result in "out". -c [Numerical Recipes (1992), p.128] -c -c For odd n, use the extended three-point rule (subroutine intsimpodd). -c For even n, apply the three-point rule to the interval i=1,2,...,n-3; -c apply the four-point rule to the remaining interval, i=n-3,...,n; and -c then add the results. Overall error ~ h^{-4}. MV -c -c NB: To obtain the desired integral, one MUST, after calling intsimp, -c multiply the result "out" by the stepsize. -c---x-!--1----x----2----x----3----x----4----x----5----x----6----x----7-! - include 'impli.inc' - integer n - double precision f(n),out -c - if(n.eq.(2*(n/2)+1)) then - call intsimpodd(n,f,out) - else - call intsimpodd(n-3,f,out) - xtra=3.d0*(f(n-3) + 3.d0*(f(n-2) + f(n-1)) + f(n))/8.d0 - out=out+xtra - endif -c - return - end -c -************************************************************************ - subroutine locate(xx,n,x,j) -c -c This subroutine takes an array xx(1..n) and a value x, and it returns -c the index j such that x lies between xx(j) and x(j+1). If the value -c returned is either j=0 or j=n, then x lies outside the range. -c NB: The array xx must be monotonic, either increasing or decreasing. -c From Press, et al., Numerical Recipes, 2nd ed. (1992), p.111. -c-----!----------------------------------------------------------------! - integer j,n - double precision x,xx(n) -c -c local variables - integer jl,jm,ju -c - jl=0 - ju=n+1 -c - 10 if(ju-jl.gt.1) then - jm=(ju+jl)/2 - if((xx(n).gt.xx(1)).eqv.(x.gt.xx(jm))) then - jl=jm - else - ju=jm - endif - goto 10 - endif - j=jl -c - return - end -c -************************************************************************ -cryne subroutine name changed to parfit_eb to avoid conflict -cryne with parfit in magnet.f ; fix later. R.D. Ryne June 16, 2004 - subroutine parfit_eb(npoint,xi,yi,ai,bi,ci) -c -c This subroutine takes data pairs (x(i),y(i)), i=1..npoint and fits a -c parabola of the form a+b*x+c*x**2 to each triple of adjacent points. -c It returns the lists of parabola coefficients a(i), b(i), and c(i). -c Except at the ends, the parabola coefficients a(i), b(i), c(i) are -c the average of those calculated using the points (i-1,i,i+1) and -c those calculated using the points (i,i+1,i+2). -c-----!----------------------------------------------------------------! - include 'impli.inc' -c -c calling arrays - dimension xi(npoint),yi(npoint),ai(npoint),bi(npoint),ci(npoint) -c -c local variables - npm1=npoint-1 - npm2=npoint-2 -c -c initialize the fitting - x1=xi(1) - x2=xi(2) - x3=xi(3) - y1=yi(1) - y2=yi(2) - y3=yi(3) - h1=x2-x1 - h2=x3-x2 - h3=x3-x1 - d1= y1/(h1*h3) - d2=-y2/(h1*h2) - d3= y3/(h2*h3) -c and fit a parabola to the first three points - a1= d1*x2*x3 + d2*x3*x1 + d3*x1*x2 - b1= -d1*(x2+x3) - d2*(x3+x1) - d3*(x1+x2) - c1= d1 + d2 + d3 - ai(1)=a1 - bi(1)=b1 - ci(1)=c1 -c -c compute the next set of parabola coefficients -c and average with the previous set - do 1 i=2,npm2 - ip2=i+2 - x1=x2 - x2=x3 - x3=xi(ip2) - y1=y2 - y2=y3 - y3=yi(ip2) - h1=h2 - h2=x3-x2 - h3=x3-x1 - d1= y1/(h1*h3) - d2=-y2/(h1*h2) - d3= y3/(h2*h3) - a2= d1*x2*x3 + d2*x3*x1 + d3*x1*x2 - b2= -d1*(x2+x3) - d2*(x3+x1) - d3*(x1+x2) - c2= d1 + d2 + d3 - ai(i)=0.5d0*(a1+a2) - bi(i)=0.5d0*(b1+b2) - ci(i)=0.5d0*(c1+c2) - a1=a2 - b1=b2 - c1=c2 - 1 continue -c -c rightmost interval - ai(npm1)=a2 - bi(npm1)=b2 - ci(npm1)=c2 -c - return - end -c -************************************************************************ diff --git a/OpticsJan2020/MLI_light_optics/Src/elem.f b/OpticsJan2020/MLI_light_optics/Src/elem.f deleted file mode 100755 index 047167e..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/elem.f +++ /dev/null @@ -1,2480 +0,0 @@ -*********************************************************************** -* header: ELEMENT LIBRARY * -* Common beamline elements * -*********************************************************************** -c - subroutine arot(ang,h,mh) -c -c Rotates axes counterclockwise in x-y plane by angle 'ang', -c looking in the direction of the beam. -c In order to get the map for an element, e.g., a quad, -c rotated on its axis by theta clockwise looking in the direction -c of the beam, the element map should be preceded a -c by arot(theta) and followed by arot(-theta). -c Written by Liam Healy, June 12, 1984. - use lieaparam, only : monoms - include 'impli.inc' - double precision h(monoms),mh(6,6) -c - call clear(h,mh) -c Rotate coordinates - mh(1,1)=cos(ang) - mh(1,3)=-sin(ang) - mh(3,1)=sin(ang) - mh(3,3)=cos(ang) -c Rotate momenta - mh(2,2)=cos(ang) - mh(2,4)=-sin(ang) - mh(4,2)=sin(ang) - mh(4,4)=cos(ang) -c Don't touch flight time - mh(5,5)=1. - mh(6,6)=1. -c Polynomials are zero (bless those linear maps). - return - end -c -*********************************************************************** -c - subroutine jmap(h,mh) -c Creates a map consisting of the matrix J (used in the definition of -c symplectic matrices), with polynomials = zero. -c Written by Liam Healy, April 16, 1985. -c -c----Variables---- - include 'impli.inc' - include 'symp.inc' - double precision h(*),mh(6,6) -c -c----Routine---- - call clear(h,mh) - do 100 i=1,6 - do 100 j=1,6 - mh(i,j)=jm(i,j) - 100 continue - return - end -c -********************************************************************** -c - subroutine dquad(qlength,qgrad,h,hm) -c -c subroutine for a horizontally defocussing quad -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - dimension h(monoms),hm(6,6) -c -c change sign of gradient - grad=-qgrad - call sssquad(qlength,grad,h,hm) -c - return - end -c -*********************************************************************** -c - subroutine sssquad(qlength,qgrad,h,hm) -c -c Computes matrix hm and polynomial array -c h of a quadrupole of length qlength (meters) and with field -c gradient qgrad (tesla/meter) using the SSS algorithm. -c If qgrad is positive the quad is focusing in the horizontal -c plane. -c -c MARYLIE5.0 upgrade. -c Written by M.Venturini 5 Aug 1997. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - dimension h(monoms),hm(6,6) -c - dimension p(6) -c - call clear(h,hm) -c - p(1) = qlength/sl - p(2) =0.d0 - p(3) =0.d0 -c p(4) =.1d0 - p(4) =.05d0 -c p(5) =1.d0 - p(5) =0.d0 -c p(6) =12 - p(6) = 0.d0 -c - call hamdrift(h) -cryne 6/21/2002 modified to multiply by sl**2: - Qbrho=qgrad/2.d0/brho*sl**2 -c - h(7)=Qbrho - h(18)=-Qbrho -c - write(jodf,*)'sssquad has been used' - write(jodf,*)'eps=',p(4) -c -c call unixtime(ti1) - call sss(p,h,hm) -c call unixtime(ti2) -c t3=ti2-ti1 -c write(jof,*) 'Execution time in seconds =',t3 -c write(jof,*) ' ' -c write(jodf,*) 'Execution time in seconds =',t3 -c write(jodf,*) ' ' -c - return - end -c -*********************************************************************** -c - subroutine drift(el,h,hm) -c -c Generates linear matrix hm and -c array h containing nonlinearities -c for the transfer map describing -c a drift section of length el meters -c Written by A. Dragt 3 January 1995. -c Modified by A. Dragt 12 April 1997 to add degree 5 and 6 terms. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - double precision hm(6,6),h(monoms) -c - call clear(h,hm) -c - elsc=el/sl -c -c compute matrix part -c - do 40 k=1,6 - hm(k,k)=+1.0d0 - 40 continue - hm(1,2)=+elsc - hm(3,4)=+elsc - hm(5,6)=+(elsc/((gamma**2)*(beta**2))) -c -c compute array part h -c -c degree 3 -c - h(53)=-(elsc/(2.0d0*beta)) - h(76)=-(elsc/(2.0d0*beta)) - h(83)=-(elsc/(2.0d0*(gamma**2)*(beta**3))) -c -c degree 4 -c - h(140)=-elsc/8.0d0 - h(149)=-elsc/4.0d0 - h(154)=+(elsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 - h(195)=-elsc/8.0d0 - h(200)=+(elsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 - h(209)=+elsc*(1.0d0-(5.0d0/beta**2))/(8.0d0*gamma**2*beta**2) -c -c degree 5 -c - h(340)=-3.d0*elsc/(8.d0*beta) - h(363)=-3.d0*elsc/(4.d0*beta) - h(370)=elsc*(-5.d0+3.d0*beta**2)/(4.d0*beta**3) - h(443)=-3.d0*elsc/(8.d0*beta) - h(450)=elsc*(-5.d0+3.d0*beta**2)/(4.d0*beta**3) - h(461)=elsc*(-7.d0+3.d0*beta**2)/ - &(8.d0*beta**5*gamma**2) -c -c degree 6 -c - h(714)=-elsc/(16.d0) - h(723)=-3.d0*elsc/(16.d0) - h(728)=3.d0*elsc*(-5.d0+beta**2)/(16.d0*beta**2) - h(769)=-3.d0*elsc/(16.d0) - h(774)=3.d0*elsc*(-5.d0+beta**2)/(8.d0*beta**2) - h(783)=-elsc*(35.d0-30.d0*beta**2+3.d0*beta**4)/ - &(16.d0*beta**4) - h(896)=-elsc/(16.d0) - h(901)=3.d0*elsc*(-5.d0+beta**2)/(16.d0*beta**2) - h(910)=-elsc*(35.d0-30.d0*beta**2+3.d0*beta**4)/ - &(16.d0*beta**4) - h(923)=-elsc*(21.d0-14.d0*beta**2+beta**4)/ - &(16.d0*beta**6*gamma**2) -c - return - end -c -*********************************************************************** -c - subroutine gfrngg(psideg,rho,iedge,ha,hm,gap,xk1) -c -c subroutine to generate lie transformation -c for fringe fields of a general bending magnet. -c "Gap" correction a la TRANSPORT added by F. Neri (5/7/89). -c -c psi is the angle between the design -c orbit and the normal to the pole face, -c rho is the magnet design orbit radius in meters. -c -c iedge=1 for leading edge transformation -c iedge=2 for trailing edge transformation -c -c the fringe field map is symplectic through -c all orders, but is guaranteed to match the physical -c map only through order 2. that is, the -c fringe map is a symplectic approximation -c to the exact map, accurate through order 2. -c Written by Liam Healy, ca 1985 -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' -c - dimension ha(monoms) - dimension hm(6,6) -c write(6,*)'inside gfrngg with gap=',gap -c - call clear(ha,hm) -c set up needed quantities - psi=psideg*pi180 -c AAARGH...................... - cpsi=dsin(psi) - spsi=dcos(psi) -c AAARGH...................... - cot=cpsi/spsi - cot2=cot*cot - csc=1.0d0/spsi - csc2=csc*csc - csc3=csc2*csc - csc4=csc2*csc2 - csc5=csc2*csc3 - rhosc=rho/sl - gsc = gap/sl -c -c choice of leading or trailing edge - if (iedge.gt.1) go to 1100 -c -c leading edge fringe field map -c -c matrix array (containing linear effects) -c - do 160 i=1,6 - hm(i,i)=1.0d0 - 160 continue - bet0 = datan(cot) - hm(4,3)= -tan(bet0-xk1*(1.d0+cpsi**2)*csc*gsc/rhosc)/rhosc -c -c arrays contaning generators of nonlinearities -c -c degree 3 -c - ha(54)=-csc3/(rhosc*2.0d0) - ha(67)=-cot*csc2/(rhosc*beta*2.0d0) -c -c degree 4 -c - ha(145)=-3.d0*cot*csc4/(4.d0*rhosc) - ha(158)=-cot2*csc3/(rhosc*beta)-csc5/(2.d0*rhosc*beta) - ha(184)=-3.d0*cot*csc4/(4.d0*beta**2*rhosc) - &+cot*csc2/(4.d0*rhosc) -c - return -c - 1100 continue -c -c trailing edge fringe field map -c -c matrix array (containing linear effects) -c - do 190 i=1,6 - hm(i,i)=+1.0d0 - 190 continue - bet0 = datan(cot) - hm(4,3)= -tan(bet0-xk1*(1.d0+cpsi**2)*csc*gsc/rhosc)/rhosc -c -c arrays containing nonlinearities -c -c degree 3 -c - ha(54)=+csc3/(rhosc*2.0d0) - ha(67)=-cot*csc2/(rhosc*beta*2.0d0) -c -c degree 4 -c - ha(145)=-3.d0*cot*csc4/(4.d0*rhosc) - ha(158)=+cot2*csc3/(beta*rhosc)+csc5/(2.d0*beta*rhosc) - ha(184)=-3.d0*cot*csc4/(4.d0*beta**2*rhosc) - &+cot*csc2/(4.d0*rhosc) -c - return - end -c -*********************************************************************** -c - subroutine nfrng(rho,iedge,h,mh) -c -c generates lie transformation for fringe fields -c of a normal entry bend with a design orbit -c radius of rho meters -c -c iedge=1 for leading edge -c -c iedge=2 for trailing edge -c -c the map here is the psi=pi/2 case -c of the map employed in gfrng -c Written by Alex Dragt, Fall 1986 -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - double precision mh(6,6),h(monoms),rho -c - call clear(h,mh) -c -c set coefficients of arrays -c -c set mh equal to the identity -c - do 40 i=1,6 - mh(i,i)=+1.0d0 - 40 continue -c -c set coefficients of h -c -c choose leading or trailing edge -c - if (iedge.eq.2) go to 100 -c -c leading edge coefficients -c -c degree 3 -c - h(54)=-(sl/(2.0d0*rho)) -c -c degree 4 -c - h(158)=-sl/(2.d0*beta*rho) - return -c - 100 continue -c trailing edge coefficients -c -c degree 3 -c - h(54)=+(sl/(2.0d0*rho)) -c -c degree 4 -c - h(158)=+sl/(2.d0*beta*rho) - return - end -c -*********************************************************************** -c - subroutine gfrng(psideg,rho,iedge,ha,hm) -c -c subroutine to generate lie transformation -c for fringe fields of a general bending magnet. -c -c psi is the angle between the design -c orbit and the normal to the pole face, -c rho is the magnet design orbit radius in meters. -c -c iedge=1 for leading edge transformation -c iedge=2 for trailing edge transformation -c -c the fringe field map is symplectic through -c all orders, but is guaranteed to match the physical -c map only through order 2. that is, the -c fringe map is a symplectic approximation -c to the exact map, accurate through order 2. -c Written by Liam Healy, ca 1985 -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' -c - dimension ha(monoms) - dimension hm(6,6) -c - call clear(ha,hm) -c set up needed quantities - psi=psideg*pi180 - cpsi=dsin(psi) - spsi=dcos(psi) - cot=cpsi/spsi - cot2=cot*cot - csc=1.0d0/spsi - csc2=csc*csc - csc3=csc2*csc - csc4=csc2*csc2 - csc5=csc2*csc3 - rhosc=rho/sl -c -c choice of leading or trailing edge - if (iedge.gt.1) go to 1100 -c -c leading edge fringe field map -c -c matrix array (containing linear effects) -c - do 160 i=1,6 - hm(i,i)=1.0d0 - 160 continue - hm(4,3)= -cot/rhosc -c -c arrays contaning generators of nonlinearities -c -c degree 3 -c - ha(54)=-csc3/(rhosc*2.0d0) - ha(67)=-cot*csc2/(rhosc*beta*2.0d0) -c -c degree 4 -c - ha(145)=-3.d0*cot*csc4/(4.d0*rhosc) - ha(158)=-cot2*csc3/(rhosc*beta)-csc5/(2.d0*rhosc*beta) - ha(184)=-3.d0*cot*csc4/(4.d0*beta**2*rhosc) - &+cot*csc2/(4.d0*rhosc) -c - return -c - 1100 continue -c -c trailing edge fringe field map -c -c matrix array (containing linear effects) -c - do 190 i=1,6 - hm(i,i)=+1.0d0 - 190 continue - hm(4,3)=-cot/rhosc -c -c arrays containing nonlinearities -c -c degree 3 -c - ha(54)=+csc3/(rhosc*2.0d0) - ha(67)=-cot*csc2/(rhosc*beta*2.0d0) -c -c degree 4 -c - ha(145)=-3.d0*cot*csc4/(4.d0*rhosc) - ha(158)=+cot2*csc3/(beta*rhosc)+csc5/(2.d0*beta*rhosc) - ha(184)=-3.d0*cot*csc4/(4.d0*beta**2*rhosc) - &+cot*csc2/(4.d0*rhosc) - return - end -c -*********************************************************************** -c - subroutine octe(l,phi0,h,mh) -c -c computes matrix mh and polynomial h for -c electric octupole with length l meters and scalar -c potential of the form phi0*(x**4-6*x**2*y**2+y**4) -c Written by D. Douglas, ca 1982 -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - double precision l,h(monoms),mh(6,6) - double precision lsc -c - call clear(h,mh) - lsc=l/sl -c -c enter matrix elements -c - do 40 i=1,6 - mh(i,i)=+1.0d0 - 40 continue - mh(1,2)=+lsc - mh(3,4)=+lsc - mh(5,6)=+(lsc/((gamma**2)*(beta**2))) -c -c set coefficients of h -c -c degree 3 -c - h(53)=-(lsc/(2.0d0*beta)) - h(76)=-(lsc/(2.0d0*beta)) - h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) -c -c degree 4 -c - ap=((sl**4)*phi0)/(c*beta*brho) - h(84)=+lsc*ap - h(85)=-2.0d0*(lsc**2)*ap - h(90)=+2.0d0*(lsc**3)*ap - h(95)=-6.0d0*lsc*ap - h(96)=+6.d0*lsc**2*ap - h(99)=-(2.0d0*(lsc**3)*ap) - h(105)=-(lsc**4)*ap - h(110)=+6.0d0*(lsc**2)*ap - h(111)=-(8.0d0*(lsc**3)*ap) - h(114)=+3.0d0*(lsc**4)*ap - h(140)=-lsc/8.0d0+(lsc**5)*ap/5.0d0 - h(145)=-(2.0d0*(lsc**3)*ap) - h(146)=+3.0d0*(lsc**4)*ap - h(149)=-lsc/4.0d0-(6.0d0*(lsc**5)*ap)/5.0d0 - h(154)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 - h(175)=+lsc*ap - h(176)=-2.0d0*(lsc**2)*ap - h(179)=+2.0d0*(lsc**3)*ap - h(185)=-(lsc**4)*ap - h(195)=-lsc/8.0d0+(lsc**5)*ap/5.0d0 - h(200)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 - h(209)=+(lsc*(1.d0-(5.d0/beta**2)))/(8.d0*gamma**2*beta**2) - return - end -c -*********************************************************************** -c - subroutine octm(el,gb0,h,hm) -c -c computes matrix hm and polynomial h for -c magnetic octupole with length l meters and vector -c potential of the form -(gb0/4.)*(+x**4-6*x**2*y**2+y**4) -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - dimension h(monoms),hm(6,6) -c - call sssoctm(el,gb0,h,hm) -c - return - end -c -*********************************************************************** -c - subroutine sssoctm(olength,oct,h,hm) -c -c computes matrix mh and polynomial array -c h of a octupole of length olength (meters) and with strength -c oct (tesla/meter^3) using the SSS algorithm. -c The vector potential is A_z=-(oct/4)(x^4 - 6x^2*y^2 + y^4). -c -c MARYLIE5.0 upgrade. -c Written by M.Venturini 5 Aug 1997. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - dimension h(monoms),hm(6,6) -c - dimension p(6) -c - call clear(h,hm) -c - p(1) = olength/sl - p(2) =0.d0 - p(3) =0.d0 -cryne 6/21/2002 p(4) =.1d0 - p(4) =1.d-4 - p(5) =0.d0 - p(6) =0.d0 -c - call hamdrift(h) -c -cryne 6/21/2002 modified to multiply by sl**4: - oct4brho=oct/4.d0/brho*sl**4 -c - h(84)=oct4brho - h(95)=-6*oct4brho - h(175)=oct4brho -c - write(jodf,*)'sssoctm has been used' - write(jodf,*)'eps=',p(4) - call sss(p,h,hm) -c - return - end -c -*********************************************************************** -c - subroutine pbend(rho,phideg,h,mh) -c -c computes generators for the lie transformation -c describing a parallel-faced bending magnet -c subtending an angle of phi radians -c with a design orbit radius of rho meters -c Written by D. Douglas, ca 1982 -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' - double precision h(monoms),mh(6,6) -c - call clear(h,mh) - phi=phideg*pi180 - alpha=phi/2.0d0 - rhosc=rho/sl - cal=dcos(alpha) - sal=dsin(alpha) - tan=sal/cal -c -c enter matrix elements into mh -c - do 40 i=1,6 - mh(i,i)=+1.0d0 - 40 continue - mh(1,2)=+rhosc*tan*2.0d0 - mh(3,4)=+phi*rhosc - mh(5,6)=-phi*rhosc+(2.0d0*rhosc*tan)/(beta**2) -c -c add coefficients of generators of nonlinearities to h -c -c degree 3 -c - h(53)=-(rhosc*tan)/((cal**2)*beta) - h(76)=-(rhosc*tan)/beta - h(83)=+(rhosc*tan)/beta-(tan+tan**3/3.d0)*rhosc/beta**3 -c -c degree 4 -c - sec=1.d0/cal - sec2=sec*sec - sec4=sec2*sec2 - h(140)=-rhosc*tan*sec4/4.d0 - h(149)=-rhosc*tan*sec2/2.d0 - h(154)=-3.d0*rhosc*tan*sec4/(2.d0*beta**2) - &+rhosc*tan*sec2/2.d0 - h(195)=-rhosc*tan/4.d0 - h(200)=-rhosc*tan*sec2/(2.d0*beta**2) - &-rhosc*tan/(2.d0*gamma**2*beta**2) - &-rhosc*tan/(2.d0*beta**2) - h(209)=-rhosc*tan*tan*tan*tan*tan/(4.d0*beta**4) - &-5.d0*rhosc*tan*tan*tan/(6.d0*beta**4) - &-5.d0*rhosc*tan/(4.d0*beta**4) - &+rhosc*tan*tan*tan/(2.d0*beta**2) - &+3.d0*rhosc*tan/(2.d0*beta**2) - &-rhosc*tan/4.d0 - return - end -c -*********************************************************************** -c - subroutine nbend(rho,phideg,h,mh) -c -c computes generators for normal entry dipole bending -c magnet subtending angle phi radians and having -c design orbit radius rho meters -c Written by D. Douglas, ca 1982 -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' - double precision h(monoms),mh(6,6) -c - call clear(h,mh) -c -c compute useful numbers -c - rhosc=rho/sl - phi=phideg*pi180 - cphi=dcos(phi) - sphi=dsin(phi) -c -c set coefficients of mh -c - mh(1,1)=+cphi - mh(1,2)=+(rhosc*sphi) - mh(1,6)=-(((1.0d0-cphi)*rhosc)/beta) - mh(2,1)=-(sphi/rhosc) - mh(2,2)=+cphi - mh(2,6)=-(sphi/beta) - mh(3,3)=+1.d0 - mh(3,4)=+rhosc*phi - mh(4,4)=+1.d0 - mh(5,1)=+sphi/beta - mh(5,2)=+(((1.d0-cphi)*rhosc)/beta) - mh(5,5)=+1.d0 - mh(5,6)=-(rhosc*phi)+((rhosc*sphi)/(beta**2)) - mh(6,6)=+1.d0 -c -c set coefficients of array h -c -c degree 3 -c - sphi2=sphi*sphi - sphi3=sphi2*sphi - cphi2=cphi*cphi - cphi3=cphi2*cphi - h(28)=-(sphi3/(6.0d0*(rhosc**2))) - h(29)=-((cphi*sphi2)/((2.0d0)*rhosc)) - h(33)=-(sphi3/(2.0d0*rhosc*beta)) - h(34)=-((sphi*cphi2)/2.0d0) - h(38)=-((sphi2*cphi)/beta) - h(43)=-(sphi/2.0d0) - h(48)=-(sphi/(2.0d0*(gamma**2)*(beta**2))) - &-(sphi3/(2.0d0*(beta**2))) - h(49)=+(((1.0d0-cphi3)*rhosc)/6.d0) - h(53)=-((sphi*cphi2*rhosc)/(beta*2.d0)) - h(58)=+(((1.0d0-cphi)*rhosc)/2.0d0) - h(63)=+(((1.0d0-cphi)*rhosc)/(2.0d0*(gamma**2)*(beta**2))) - &-((sphi2*cphi*rhosc)/(2.0d0*(beta**2))) - h(76)=-((rhosc*sphi)/(2.0d0*beta)) - h(83)=-((rhosc*sphi)/(2.0d0*(gamma**2)*(beta**3))) - &-((rhosc*sphi3)/(6.0d0*(beta**3))) -c -c degree 4 -c - h(89)=-sphi3/(6.d0*beta*rhosc**2) - h(90)=-sphi3/(8.d0*rhosc) - h(94)=-cphi*sphi2/(2.d0*beta*rhosc) - h(99)=-sphi3/(8.d0*rhosc) - h(104)=-sphi3*(5.d0-beta**2)/(8.d0*beta**2*rhosc) - h(105)=-cphi*sphi2/4.d0 - h(109)=+sphi3/(4.d0*beta)-sphi/(2.d0*beta) - h(114)=-cphi*sphi2/4.d0 - h(119)=-cphi*sphi2/(4.d0*beta**2*gamma**2) - &-cphi*sphi2/beta**2 - h(132)=-sphi3/(4.d0*beta)-sphi/(2.d0*beta) - h(139)=-sphi3/(4.d0*beta**3*gamma**2) - &-sphi3/(2.d0*beta**3)-sphi/(2.d0*beta**3*gamma**2) - h(140)=-rhosc*sphi*cphi2/8.d0 - h(144)=-rhosc*cphi*sphi2/(1.2d1*beta) - &+rhosc*(1.d0-cphi)/(6.d0*beta) - h(149)=+rhosc*sphi3/8.d0-rhosc*sphi/4.d0 - h(154)=+rhosc*sphi3*(4.d0-beta**2)/(8.d0*beta**2) - &-rhosc*sphi/(4.d0*beta**2*gamma**2) - &-rhosc*sphi/(2.d0*beta**2) - h(167)=-rhosc*cphi*sphi2/(4.d0*beta) - &+rhosc*(1.d0-cphi)/(2.d0*beta) - h(174)=-rhosc*cphi*sphi2/(4.d0*beta**3*gamma**2) - &-rhosc*cphi*sphi2/(2.d0*beta**3) - &+rhosc*(1.d0-cphi)/(2.d0*beta**3*gamma**2) - h(195)=-rhosc*sphi/8.d0 - h(200)=-rhosc*sphi3/(8.d0*beta**2) - &-rhosc*sphi/(4.d0*beta**2*gamma**2) - &-rhosc*sphi/(2.d0*beta**2) - h(209)=-rhosc*sphi3/(8.d0*beta**4*gamma**2) - &-rhosc*sphi3/(6.d0*beta**4)-rhosc*sphi/(2.d0*beta**4*gamma**2) - &-rhosc*sphi/(8.d0*beta**4*gamma**4) - return - end -c -*********************************************************************** -c -cryne Aug 6, 2003: routine name changed to prot3 -cryne The fifth order version by Johannes van Zeijts is now called 'prot' - subroutine prot3(psideg,kind,ha,hm) -c -c subroutine to generate lie transformation -c for rotation of reference plane. -c used primarily in connection with computing -c map for dipoles with rotated pole faces. -c -c psideg is the rotation angle angle in degrees. -c -c kind=1 for transition from the normal reference plane -c to a rotated reference plane -c kind=2 for transition from a rotated reference plane -c to a normal reference plane -c Written by Alex Dragt, Fall 1986 -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' - double precision ha(monoms),hm(6,6) -c - dimension ha1(monoms),ha2(monoms) - dimension hm1(6,6),hm2(6,6) -c - call clear(ha,hm) - call clear(ha1,hm1) - call clear(ha2,hm2) -c -c set up needed quantities -c - psi=psideg*pi180 - cpsi=dsin(psi) - spsi=dcos(psi) - cot=cpsi/spsi - cot2=cot*cot - cot3=cot2*cot - cot4=cot2*cot2 - cot5=cot2*cot3 - csc=1.0d0/spsi - csc2=csc*csc -c -c choice of kind - if (kind.gt.1) go to 100 -c -c transition from normal to rotated reference plane -c -c matrix arrays (containing linear effects) -c - do 40 i=1,6 - hm1(i,i)=+1.0d0 - 40 continue - hm1(2,6)=-cot/beta - hm1(5,1)=+cot/beta - do 50 i=3,6 - hm2(i,i)=+1.0d0 - 50 continue - hm2(1,1)=hm2(1,1)+1.0d0/spsi - hm2(2,2)=hm2(2,2)+spsi -c -c arrays containing generators of nonlinearities -c -c degree 3 -c - ha1(34)=-cot/2.0d0 - ha1(38)=-cot2/beta - ha1(43)=-cot/2.0d0 - ha1(48)=-cot/(gamma**2*beta**2*2.0d0) - &-cot3/(beta**2*2.0d0) -c -c degree 4 -c - ha1(105)=-cot2/4.d0 - ha1(109)=-cot/(2.d0*beta)-3.d0*cot3/(4.d0*beta) - ha1(114)=-cot2/4.d0 - ha1(119)=-cot2/beta**2-3.d0*cot4/(4.d0*beta**2) - &-cot2/(4.d0*gamma**2*beta**2) - ha1(132)=-cot/(2.d0*beta)-cot3/(4.d0*beta) - ha1(139)=-cot3/(2.d0*beta**3)-cot5/(4.d0*beta**3) - &-cot/(2.d0*gamma**2*beta**3) - &-cot3/(4.d0*gamma**2*beta**3) -c -c compute map - call concat(ha1,hm1,ha2,hm2,ha,hm) - return -c - 100 continue -c -c transition from a rotated to a normal reference plane -c -c matrix arrays (containing linear effects) -c - do 60 i=1,6 - hm1(i,i)=+1.0d0 - 60 continue - hm1(2,6)=-cpsi/beta - hm1(5,1)=+cpsi/beta - do 70 i=3,6 - hm2(i,i)=+1.0d0 - 70 continue - hm2(1,1)=hm2(1,1)+spsi - hm2(2,2)=hm2(2,2)+csc -c -c arrays containing generators of nonlinearties -c -c degree 3 -c - ha1(34)=-cot*csc/2.0d0 - ha1(43)=-cpsi/2.0d0 - ha1(48)=-cpsi/(gamma**2*beta**2*2.0d0) -c -c degree 4 -c - ha1(105)=+cot2*csc2/4.d0 - ha1(109)=-cot*csc/(2.d0*beta) - ha1(114)=+cot2/4.d0 - ha1(119)=+cot2/(4.d0*gamma**2*beta**2) - ha1(132)=-cpsi/(2.d0*beta) - ha1(139)=-cpsi/(2.d0*gamma**2*beta**3) -c -c compute map - call concat(ha1,hm1,ha2,hm2,ha,hm) - return - end -c -*********************************************************************** -c -cryne Aug 6, 2003: routine name changed from myprot5 to prot - subroutine prot(angdeg,ijkind,h,mh) -c -c High order PROT routine. -c Actual code generated by Johannes van Zeijts using -c REDUCE. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' -c include 'param.inc' -c include 'parm.inc' - double precision l,h(monoms),mh(6,6) -c - dimension j(6) -c - DOUBLE PRECISION B - DOUBLE PRECISION CO - DOUBLE PRECISION Si -c -cryne mods to allow for leading/trailing option: -cryne ijkind=1 for normal-to-rotated, =2 for rotated-to-normal - phideg=angdeg - if(ijkind.eq.2)phideg=-angdeg - -c - call clear(h,mh) -c - B = beta - phi = phideg*pi180 - SI = SIN(phi) - CO = COS(phi) -c - mh(1,1)=1.0d0/CO - mh(2,2)=CO - mh(2,6)=(-SI)/B - mh(3,3)=1.0d0 - mh(4,4)=1.0d0 - mh(5,1)=SI/(B*CO) - mh(5,5)=1.0d0 - mh(6,6)=1.0d0 -c - h(34) =(-SI)/(2.0d0*CO) - h(43) =(-SI)/(2.0d0*CO) - h(48) =(SI*(B**2-1))/(2.0d0*B**2*CO) - h(105) =SI**2/(4.0d0*(SI**2-1)) - h(109) =(-SI)/(2.0d0*B*CO) - h(114) =SI**2/(4.0d0*(SI**2-1)) - h(119) =(SI**2*(-B**2+1))/(4.0d0*B**2*(SI**2-1)) - h(132) =(-SI)/(2.0d0*B*CO) - h(139) =(SI*(B**2-1))/(2.0d0*B**3*CO) - h(266) =SI/(8.0d0*CO*(SI**2-1)) - h(270) =SI**2/(2.0d0*B*(SI**2-1)) - h(275) =(SI*(-2.0d0*SI**2+3))/(12.0d0*CO*(SI**2-1)) - h(280) =(SI*(2.0d0*B**2*SI**2-3.0d0*B**2-8.0d0*SI**2+9))/( - & 12.0d0*B**2*CO*(SI**2-1)) - h(293) =SI**2/(2.0d0*B*(SI**2-1)) - h(300) =(SI**2*(-B**2+1))/(2.0d0*B**3*(SI**2-1)) - h(321) =(SI*(-4.0d0*SI**2+3))/(24.0d0*CO*(SI**2-1)) - h(326) =(SI*(4.0d0*B**2*SI**2-3.0d0*B**2-10.0d0*SI**2+9))/( - & 12.0d0*B**2*CO*(SI**2-1)) - h(335) =(SI*(-4.0d0*B**4*SI**2+3.0d0*B**4+20.0d0*B**2*SI**2- - & 18.0d0*B**2-16.0d0*SI**2+15))/(24.0d0*B**4*CO*(SI**2-1)) - h(588) =(SI**2*(SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+1)) - h(592) =(SI*(SI**2+6))/(16.0d0*B*CO*(SI**2-1)) - h(597) =(SI**2*(3.0d0*SI**2-4))/(16.0d0*(SI**4-2.0d0*SI**2+ - & 1)) - h(602) =(SI**2*(-3.0d0*B**2*SI**2+4.0d0*B**2+15.0d0*SI**2-16.0d0 - & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) - h(615) =(3.0d0*SI*(-SI**2+2))/(8.0d0*B*CO*(SI**2-1)) - h(622) =(SI*(3.0d0*B**2*SI**2-6.0d0*B**2-7.0d0*SI**2+10))/( - & 8.0d0*B**3*CO*(SI**2-1)) - h(643) =(SI**2*(5.0d0*SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+ - & 1)) - h(648) =(SI**2*(-5.0d0*B**2*SI**2+4.0d0*B**2+17.0d0*SI**2-16.0d0 - & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) - h(657) =(SI**2*(5.0d0*B**4*SI**2-4.0d0*B**4-34.0d0*B**2*SI**2 - & +32.0d0*B**2+29.0d0*SI**2-28))/(32.0d0*B**4*(SI**4-2.0d0*SI**2+ - & 1)) - h(695) =(SI*(-7.0d0*SI**2+6))/(16.0d0*B*CO*(SI**2-1)) - h(702) =(SI*(7.0d0*B**2*SI**2-6.0d0*B**2-11.0d0*SI**2+10))/( - & 8.0d0*B**3*CO*(SI**2-1)) - h(713) =(SI*(-7.0d0*B**4*SI**2+6.0d0*B**4+22.0d0*B**2*SI**2- - & 20.0d0*B**2-15.0d0*SI**2+14))/(16.0d0*B**5*CO*(SI**2-1)) -c - call revf(1,h,mh) -c -cryne this line added Aug 6, 2003: - if(ijkind.eq.2)call inv(h,mh) - return - end -c -c end of file -c -*********************************************************************** -c - subroutine fquad(qlength,qgrad,h,hm) -c -c subroutine for a horizontally focussing quad -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - dimension h(monoms),hm(6,6) -c - grad=qgrad - call sssquad(qlength,grad,h,hm) -c - return - end -c -*********************************************************************** -c - subroutine frquad(gb0,ifr,h,mh) -c -c computes hard edge fringe field map for quads -c Written by E. Forest, ca 1984 -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - double precision gb0,h(monoms),mh(6,6) -c -c set up linear part as identity matrix - do 1 i=1,6 - do 2 j=1,6 - mh(i,j)=0.d0 - if(i.ne.j) goto 2 - mh(i,j)=1.d0 - 2 continue - 1 continue -c clear polynomial array - do 3 i=1,monoms - h(i)=0.d0 - 3 continue - gb=gb0 -c see if fringe field is leading or trailing - if(ifr.lt.0)gb=-gb0 -c compute nonlinear part of map - arg=(gb*(sl**2))/brho - h(85)=arg/12.d0 - h(176)=-arg/12.d0 - h(110)=arg/4.d0 - h(96)=-arg/4.d0 - return - end -c -*********************************************************************** -c - subroutine gbend (rho,bndang,psideg,phideg,h,mh) -c a dipole bending magnet with arbitrary entrance and -c exit angles (psi and phi respectively) and arbitrary -c bend andgle (bndang). -c written by L. Healy, April 19, 1984. -c modified by A. Dragt, 5 Oct 1986. - use lieaparam, only : monoms - include 'impli.inc' - double precision mh(6,6),mht1(6,6),mht2(6,6),mht3(6,6) - double precision h(monoms),ht1(monoms),ht2(monoms),ht3(monoms) -c -c calculate each of the 3 individual pieces that make -c up the general bending magnet, and concatenate them: -c gbend=hpf1*nbend*hpf2 -c -c compute hpf1 and nbend - call hpf(rho,1,psideg,ht1,mht1) - aldeg=bndang-psideg-phideg - call nbend(rho,aldeg,ht2,mht2) -c form the product hpf1*nbend - call concat(ht1,mht1,ht2,mht2,ht3,mht3) -c compute hpf2 - call hpf(rho,-1,phideg,ht1,mht1) -c form the complete product hpf1*nbend*hpf2 - call concat(ht3,mht3,ht1,mht1,h,mh) - return - end -c -*********************************************************************** -c - subroutine hpf(rho,which,phideg,h,mh) -c This generates matrix elements and monomial coeffs -c for half of a parallel face bending magnet. -c The bending angle is phi, and 'which' indicates -c whether it is the leading half (1) or trailing half (-1). -c Written by Liam Healy, April 19, 1984. - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - integer which - double precision mh(6,6),h(monoms) - include 'pie.inc' - call clear(h,mh) -c set trig functions and scale rho - phi=phideg*pi180 - rhosc=rho/sl - tn=tan(phi) - tn2=tn*tn - tn3=tn*tn2 - tn5=tn2*tn3 - sec=1./cos(phi) - sec2=sec*sec - sec3=sec*sec2 - sec4=sec2*sec2 - sec5=sec2*sec3 -c set matrix - do 120 i=1,6 - 120 mh(i,i)=1. - mh(1,2)=rhosc*tn - mh(1,6)=-which*rhosc*(1.-sec)/beta - mh(3,4)=rhosc*phi - mh(5,2)=-which*rhosc*(1.-sec)/beta - mh(5,6)=rhosc*(tn/beta**2-phi) -c set monomial coefficients - h(49)=which*rhosc*(1.-sec3)/6. - h(53)=-rhosc*tn*sec2/(2.*beta) - h(58)=which*rhosc*(1.-sec)/2. - h(63)=which*rhosc*(1./beta**2-1.+sec*(1.-sec2/beta**2))/2. - h(76)=-rhosc*tn/(2.*beta) - h(83)=-rhosc*tn*(1.-beta**2+tn2/3.)/(2.*beta**3) - h(140)=-rhosc*tn*sec4/8. - h(144)=which*rhosc*(sec3/3.-sec5/2.+1.d0/6.d0)/beta - h(149)=-rhosc*tn*sec2/4. - h(154)=rhosc*tn*sec2*(1.-3.*sec2/beta**2)/4. - h(167)=which*rhosc*(1.-sec3)/(2.*beta) - h(174)=-which*rhosc*((1.-sec3)/(2.*beta)-(1.-sec5)/(2.*beta**3)) - h(195)=-rhosc*tn/8. - h(200)=-tn*rhosc*((sec2+2.)/beta**2-1.)/4. - h(209)=rhosc*(-(2.5*tn+5.*tn3/3.+tn5/2.)/beta**4 - & +tn*(3.+tn2)/beta**2-tn/2.)/4. -c - return - end -c -*********************************************************************** -c - subroutine cfbend(pa,pb,fa,fm) -c This subroutine computes the map for a combined function bend -c numerically by use of the GENMAP exponentiation routine. -c It should eventually be replaced by a collection of analytic formulas. -c Written by Alex Dragt, 30 March 1987. -c Corrected by Alex Dragt, 9 Sept 1989, based on calculations in the -c paper "Third Order Transfer Map for Combined Function Dipole" by -c Dragt et al. (1989). -cryne modified by Rob Ryne 7/13/2002 to get multipole coeffcients from -cryne an array passed in the parameter list. (previously this argument -cryne was an integer that pointed to a pset) -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' - include 'parset.inc' - include 'files.inc' -c - dimension fa(monoms) - dimension fm(6,6) - dimension pa(6),pb(6) - dimension pc(6) - dimension ha(monoms) - dimension hm(6,6) -c -c set up parameters and control indices -c - phideg=pa(1) - b=pa(2) - ilfrn=nint(pa(3)) - itfrn=nint(pa(4)) - ijopt=nint(pa(5)) -cryne 7/13/2002 ipset=nint(pa(6)) -c -cryne 1 August 2004: - myorder=nint(pa(6)) -c -c compute iopt and iecho -c - iopt=mod(ijopt,10) -c write(6,*)'inside cfbend; ijopt,iopt=',ijopt,iopt -c write(6,*)'pb(1-6)=',pb(1),pb(2),pb(3),pb(4),pb(5),pb(6) - iecho=(ijopt-iopt)/10 -c write(6,*) ' iopt=',iopt,' iecho=',iecho -c -c compute useful numbers -c - rho=brho/b - rhosc=rho/sl - phi=phideg*pi180 -c write(6,*)'phi,phideg=',phi,phideg -c -cryne 7/13/2002 get multipole values from the parameter set ipset -cryne get multipole values from the array in the argument list -c -c if (ipset.lt.1 .or. ipset.gt.maxpst) then -c do 50 i=1,6 -c 50 pb(i) = 0.0d0 -c else -c do 60 i=1,6 -c 60 pb(i) = pst(i,ipset) -c endif -c -c compute multipole coefficients -c procedure when iopt=1 - if (iopt.eq.1) then -c write(6,*)'(cfbend) iopt is 1' - bqd=pb(1) - aqd=pb(2) - bsex=pb(3) - asex=pb(4) - boct=pb(5) - aoct=pb(6) - endif -c procedure when iopt=2 - if (iopt.eq.2) then -c write(6,*)'(cfbend) iopt is 2' - tay1=pb(1) - aqd=pb(2) - tay2=pb(3) - asex=pb(4) - tay3=pb(5) - aoct=pb(6) - bqd=tay1 - bsex=tay2+(5.d0*tay1)/(8.d0*rho) - boct=tay3-tay1/(48.d0*rho*rho)+(2.d0*tay2)/(3.d0*rho) - endif -c procedure when iopt=3 - if (iopt.eq.3) then -c write(6,*)'(cfbend) iopt is 3; brho,rho,sl=',brho,rho,sl - tay1=brho*pb(1) - aqd=brho*pb(2) - tay2=brho*pb(3) - asex=brho*pb(4) - tay3=brho*pb(5) - aoct=brho*pb(6) - bqd=tay1 -c write(6,*)'pb(1),tay1,bqd=',pb(1),tay1,bqd - bsex=tay2+(5.d0*tay1)/(8.d0*rho) - boct=tay3-tay1/(48.d0*rho*rho)+(2.d0*tay2)/(3.d0*rho) - endif -c -c write out multipole and taylor coefficients if desired -c - if (iecho .ne. 0) then - ttay1=bqd - ttay2=bsex-5.d0*bqd/(8.d0*rho) - ttay3=boct+7.d0*bqd/(16.d0*rho*rho)-2.d0*bsex/(3.d0*rho) - if (iecho .eq. 1 .or. iecho .eq. 3) then - write (jof,137) - 137 format(/,1x,'multipole strengths bqd,aqd,bsex,asex,boct,aoct') - write (jof,*) bqd,aqd,bsex,asex,boct,aoct - write (jof,138) - 138 format(1x,'taylor coefficients tay1,tay2,tay3') - write (jof,*) ttay1,ttay2,ttay3 - write (jof,*) - endif - if (iecho .eq. 2 .or. iecho .eq. 3) then - write (jodf,137) - write (jodf,*) bqd,aqd,bsex,asex,boct,aoct - write (jodf,138) - write (jodf,*) ttay1,ttay2,ttay3 - write (jodf,*) - endif - endif -c -c scale multipole strengths and compute scaled curvature feed up terms -c - sbqdf=1.d0/(2.d0*rhosc) - saqd=aqd*sl*rho/brho - sbqd=bqd*sl*rho/(2.d0*brho) -c write(6,*)'saqd,sbqd=',saqd,sbqd -c - sasexf=aqd*(sl**2)/(8.d0*brho) - sbsexf=bqd*(sl**2)/(8.d0*brho) - sasex=asex*(sl**2)*rho/(3.d0*brho) - sbsex=bsex*(sl**2)*rho/(3.d0*brho) -c - sscalf=-bqd*(sl**3)/(64.d0*rho*brho) - saoctf=(asex/6.d0-aqd/(16.d0*rho))*(sl**3)/brho - sboctf=(bsex/12.d0-bqd/(32.d0*rho))*(sl**3)/brho - saoct=aoct*(sl**3)*rho/brho - sboct=boct*(sl**3)*rho/(4.d0*brho) -c -c compute the Hamiltonian -c - call clear(ha,hm) -c -c degree 2 -c - ha(7)=sbqdf + sbqd - ha(9)=-saqd - ha(12)=1.d0/beta - ha(13)=rhosc/2.d0 - ha(18)=-sbqd - ha(22)=rhosc/2.d0 - ha(27)=rhosc/(2.d0*(beta*gamma)**2) -c -c degree 3 -c - ha(28)=sbsexf + sbsex - ha(30)=-sasexf - 3.d0*sasex - ha(34)=1.d0/2.0d0 - ha(39)=sbsexf - 3.d0*sbsex - ha(43)=1.d0/2.d0 - ha(48)=1.d0/(2.0d0*((gamma*beta)**2)) - ha(53)=rhosc/(2.d0*beta) - ha(64)=-sasexf+sasex - ha(76)=rhosc/(2.d0*beta) - ha(83)=rhosc/(2.d0*(gamma**2)*(beta**3)) -c -c degree 4 -c - ha(84)=sscalf + sboctf + sboct - ha(86)=-saoctf - saoct - ha(95)=2.d0*sscalf -6.d0*sboct - ha(109)=1.d0/(2.d0*beta) - ha(120)=-saoctf + saoct - ha(132)=1.d0/(2.d0*beta) - ha(139)=1.d0/(2.d0*(beta**3)*(gamma**2)) - ha(140)=rhosc/8.d0 - ha(149)=rhosc/4.d0 - ha(154)=rhosc/(4.d0*(beta**2)*(gamma**2))+rhosc/(2.d0*(beta**2)) - ha(175)=sscalf - sboctf + sboct - ha(195)=rhosc/8.d0 - ha(200)=rhosc/(4.d0*(beta**2)*(gamma**2))+rhosc/(2.d0*(beta**2)) - ha(209)=rhosc/(2.d0*(beta**4)*(gamma**2)) - &+rhosc/(8.d0*(beta**4)*(gamma**4)) -c -c call GENMAP exponentiation routine - pc(1)=-phi - pc(2)=0.d0 - pc(3)=0.d0 -c--------------------- -c write(6,*)'pc(1)=',pc(1) -c write(6,*)'pc(2)=',pc(2) -c write(6,*)'pc(3)=',pc(3) -c write(6,*)'calling cex from routine cfbend' -c--------------------- - call cex(pc,ha,hm,myorder) -c write(6,*)'returned from cex' -c write(6,*)'hm=' -c do i=1,6 -c write(6,1232)(hm(i,j),j=1,6) -c1232 format(6(1pe12.5,1x)) -c enddo - call mapmap(ha,hm,fa,fm) -c -c fringe field effects (both dipole and quadrupole) are put on -c in the subroutine lmnt -c - return - end -c -*********************************************************************** -c - subroutine cfbend_old(pa,fa,fm) -c This subroutine computes the map for a combined function bend -c numerically by use of the GENMAP exponentiation routine. -c It should eventually be replaced by a collection of analytic formulas -c Written by Alex Dragt, 30 March 1987. - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms) - dimension fm(6,6) - dimension pa(6),pb(6) - dimension pc(6) - dimension ha(monoms) - dimension hm(6,6) -c - include 'pie.inc' - include 'parset.inc' -c -c set up parameters and control indices -c - phideg=pa(1) - b=pa(2) - ilfrn=nint(pa(3)) - itfrn=nint(pa(4)) - iopt=nint(pa(5)) - ipset=nint(pa(6)) -c -c compute useful numbers -c - rho=brho/b - rhosc=rho/sl - phi=phideg*pi180 -c -c get multipole values from the parameter set ipset -c -c do 5 i=1,6 -c 5 pb(i)=0.d0 -c goto (10,20,30,40,50),ipset -c goto 60 -c 10 do 11 i=1,6 -c 11 pb(i)=pst1(i) -c goto 60 -c 20 do 21 i=1,6 -c 21 pb(i)=pst2(i) -c goto 60 -c 30 do 31 i=1,6 -c 31 pb(i)=pst3(i) -c goto 60 -c 40 do 41 i=1,6 -c 41 pb(i)=pst4(i) -c goto 60 -c 50 do 51 i=1,6 -c 51 pb(i)=pst5(i) -c 60 continue - if (ipset.lt.1 .or. ipset.gt.maxpst) then - do 50 i=1,6 - 50 pb(i) = 0.0d0 - else - do 60 i=1,6 - 60 pb(i) = pst(ipset,i) - endif -c -c compute multipole coefficients -c procedure when iopt=1 - if (iopt.eq.1) then -c pb(3)=-pb(3) -c pb(4)=-pb(4) - bqd=pb(1) - aqd=pb(2) - bsex=pb(3) - asex=pb(4) - boct=pb(5) - aoct=pb(6) - endif -c procedure when iopt=2 - if (iopt.eq.2) then - tay1=pb(1) - aqd=pb(2) - tay2=pb(3) - asex=pb(4) - tay3=pb(5) - aoct=pb(6) - bqd=tay1 - bsex=tay2-(5.d0*tay1)/(8.d0*rho) - boct=tay3-(41.d0*tay1)/(48.d0*rho*rho)+(2.d0*tay2)/(3.d0*rho) - endif -c procedure when iopt=3 - if (iopt.eq.3) then - tay1=brho*pb(1) - aqd=brho*pb(2) - tay2=brho*pb(3) - asex=brho*pb(4) - tay3=brho*pb(5) - aoct=brho*pb(6) - bqd=tay1 - bsex=tay2-(5.d0*tay1)/(8.d0*rho) - boct=tay3-(41.d0*tay1)/(48.d0*rho*rho)+(2.d0*tay2)/(3.d0*rho) - endif -c -c scale multipole strengths and compute scaled curvature feed up terms -c - sbqdf=1.d0/(2.d0*rhosc) - saqd=aqd*sl*rho/brho - sbqd=bqd*sl*rho/(2.d0*brho) -c - sasexf=aqd*(sl**2)/(8.d0*brho) - sbsexf=bqd*(sl**2)/(8.d0*brho) - sasex=asex*(sl**2)*rho/(3.d0*brho) - sbsex=bsex*(sl**2)*rho/(3.d0*brho) -c - sscalf=-bqd*(sl**3)/(64.d0*rho*brho) - saoctf=(asex/6.d0-aqd/(16.d0*rho))*(sl**3)/brho - sboctf=(bsex/12.d0-bqd/(32.d0*rho))*(sl**3)/brho - saoct=aoct*(sl**3)*rho/brho - sboct=boct*(sl**3)*rho/(4.d0*brho) -c -c compute the Hamiltonian -c - call clear(ha,hm) -c -c degree 2 -c - ha(7)=sbqdf + sbqd - ha(8)=saqd - ha(12)=1.d0/beta - ha(13)=rhosc/2.d0 - ha(18)=-sbqd - ha(22)=rhosc/2.d0 - ha(27)=rhosc/(2.d0*(beta*gamma)**2) -c -c degree 3 -c - ha(28)=sbsexf + sbsex - ha(30)=sasexf + 3.d0*sasex - ha(34)=1.d0/2.0d0 - ha(39)=sbsexf - 3.d0*sbsex - ha(43)=1.d0/2.d0 - ha(44)=sasexf-sasex - ha(48)=1.d0/(2.0d0*((gamma*beta)**2)) - ha(53)=rhosc/(2.d0*beta) - ha(76)=rhosc/(2.d0*beta) - ha(83)=rhosc/(2.d0*(gamma**2)*(beta**3)) -c -c degree 4 -c - ha(84)=sscalf + sboctf + sboct - ha(86)=saoctf + saoct - ha(95)=2.d0*sscalf -6.d0*sboct - ha(109)=1.d0/(2.d0*beta) - ha(120)=saoctf - saoct - ha(132)=1.d0/(2.d0*beta) - ha(139)=1.d0/(2.d0*(beta**3)*(gamma**2)) - ha(140)=rhosc/8.d0 - ha(149)=rhosc/4.d0 - ha(154)=rhosc/(4.d0*(beta**2)*(gamma**2))+rhosc/(2.d0*(beta**2)) - ha(175)=sscalf - sboctf + sboct - ha(195)=rhosc/8.d0 - ha(200)=rhosc/(4.d0*(beta**2)*(gamma**2))+rhosc/(2.d0*(beta**2)) - ha(209)=rhosc/(2.d0*(beta**4)*(gamma**2)) - &+rhosc/(8.d0*(beta**4)*(gamma**4)) -c -c call GENMAP exponentiation routine - pc(1)=-phi - pc(2)=0.d0 - pc(3)=0.d0 - call cex(pc,ha,hm) - call mapmap(ha,hm,fa,fm) -c -c add fringe field effects -c not yet implemented -c - return - end -c -*********************************************************************** -c - subroutine srfc(phi0,w,h,mh) -c -c computes matrix representation mh of linear -c portion of transfer map and an -c array h containing coefficients of polynomial -c generators of nonlinearities -c for transfer map of a short rf cavity with -c max potential drop phi0 and -c frequency w -c Written by Alex Dragt, ca 1983 -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - double precision mh - dimension h(monoms) - dimension mh(6,6) -c - call clear(h,mh) -c -c set coefficients of mh -c - do 40 k=1,6 - mh(k,k)=+1.0d0 - 40 continue - mh(6,5)=-(phi0*w*ts)/(brho*c) -c -c degree 4 only in short buncher limit -c - h(205)=+(phi0*(ts**3)*(w**3))/(24.d0*c*brho) - return - end -c -*********************************************************************** -c - subroutine ssssext(slength,sex,h,hm) -c -c computes matrix hm and polynomial array -c h of a sextupole of length slength (meters) and with strength -c sex (tesla/meter^2) using the SSS algorithm. -c The vector potential is A_z=-(sex/3)(x**3-3xy**2). -c -c MARYLIE5.0 upgrade. -c Written by M.Venturini 5 Aug 1997. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - dimension h(monoms),hm(6,6) -c - dimension p(6) -c - call clear(h,hm) -c - p(1) = slength/sl - p(2) =0.d0 - p(3) =0.d0 -cryne 6/21/2002 p(4) =.1d0 - p(4) =1.d-4 - p(5) =0.d0 - p(6) =0.d0 -cryne p(6) =12 -c - call hamdrift(h) -c -cryne 6/21/2002 modified to multiply by sl**3: - sex3brho=sex/3.d0/brho*sl**3 -c - h(28)=sex3brho - h(39)=-3*sex3brho -c - write(jodf,*)'ssssext has been used' - write(jodf,*)'eps=',p(4) -c -c call unixtime(ti1) - call sss(p,h,hm) -c call unixtime(ti2) -c t3=ti2-ti1 -c write(jof,*) 'Execution time in seconds =',t3 -c write(jof,*) ' ' -c write(jodf,*) 'Execution time in seconds =',t3 -c write(jodf,*) ' ' -c - return - end -c -************************************************************************ -c - subroutine sext(el,gb0,h,hm) -c -c computes matrix mh and polynomial h -c for sextupole of length l with strength -c gb0 (in tesla/meter**2). routine assumes -c a vector potential of the form -c (gb0/3)(x**3-3xy**2) -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - dimension h(monoms) - dimension hm(6,6) -c - call ssssext(el,gb0,h,hm) -c - return - end -c -*********************************************************************** -c - subroutine thnl (lsqdnr,lsqdsk,lssxnr,lssxsk,lsocnr,lsocsk,h,mh) -c Does the thin lens map up through octupole. -c The length-strength product may be given for normal and skew -c Quads, sextupoles, and octupoles. The skew elements are -c rotated clockwise looking in the direction of the beam -c by half the pole symmetry angle -c (45, 30, 22.5 degrees respectively). -c Written by Liam Healy, February 28, 1985. -c - use beamdata - use lieaparam, only : monoms -c----Variables---- -c h, mh = output array and matrix - double precision h(monoms),mh(6,6) -c ls, f = length*strength (l*gb0), factor (used in calculation) -c qd, sx, oc : quad, sextupole, octupole -c nr, sk : normal, skew - double precision lsqdnr,lsqdsk,lssxnr,lssxsk,lsocnr,lsocsk - double precision fqdnr,fqdsk,fsxnr,fsxsk,focnr,focsk -c common quantities -c double precision brho,c,gamma,gamm1,beta,achg,sl,ts -c -c----Routine---- - fqdnr=lsqdnr*sl/brho - fqdsk=lsqdsk*sl/brho - fsxnr=-lssxnr*sl**2/(3.*brho) - fsxsk=-lssxsk*sl**2/(3.*brho) - focnr=-lsocnr*sl**3/(4.*brho) - focsk=-lsocsk*sl**3/(4.*brho) - call ident(h,mh) -c Matrix (quadrupole) - mh(2,1)=-fqdnr - mh(2,3)=fqdsk - mh(4,3)=fqdnr - mh(4,1)=fqdsk -c Polynomials (sextupole) - h(28)=fsxnr - h(30)=-3.*fsxsk - h(39)=-3.*fsxnr - h(64)=fsxsk -c Polynomials (octupole) - h(84)=focnr - h(86)=-4.*focsk - h(95)=-6.*focnr - h(120)=4.*focsk - h(175)=focnr -c That's all folks - return - end -c -*********************************************************************** -c - subroutine twsm(iplane,phad,alpha,beta,fa,fm) -c this is a subroutine for computing a linear transfer map -c described in terms of twiss parameters. -c Written b y Alex Dragt, Fall 1986 - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' - dimension fa(monoms),fm(6,6) -c----- -c set map to the identity - call ident(fa,fm) -c compute entries -c w=phad*pi/(180.d0) - w=phad*pi180 - cw=cos(w) - sw=sin(w) - gam=(1.+alpha*alpha)/beta -c set up subscripts - k=2*(iplane-1) - isub1=1+k - isub2=2+k -c set up matrix - fm(isub1,isub1)=cw+alpha*sw - fm(isub1,isub2)=beta*sw - fm(isub2,isub1)=-gam*sw - fm(isub2,isub2)=cw-alpha*sw - return - end -c -*********************************************************************** -c - subroutine cplm(p,h,mh) -c compressed low order multipole -c Written by Alex Dragt and E. Forest, Fall 1986 - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - double precision l,lsc,l1,l2,l3,l4,l5,l6,l7,mh - dimension h(monoms),p(6) - dimension mh(6,6) -c - l=p(1) -c -c set up multipole strengths and normalizations -c eventually the division by l should be removed -c and correspondingly multiplications by l should be removed elsewhere -c in the code - gs=-p(2)/l - sgs=-p(3)/l - go=-p(4)/(4.d0*l) - sgo=-p(5)/(4.d0*l) -c - call clear(h,mh) - lsc=l/sl -c -c evaluate coefficients of h -c -c -c set coefficients of mh -c - do 40 i=1,6 - mh(i,i)=+1.0d0 - 40 continue -c -c set coefficients of h -c -c degree 3 -c - srs=(sgs*(sl**3))/brho - sro=(sgo*sl**4)/brho - rs=(gs*(sl**3))/brho - ro=(go*sl**4)/brho - l1=lsc - l2=lsc**2 - l3=lsc**3 - l4=lsc**4 - l5=lsc**5 - l6=lsc**6 - l7=lsc**7 - h(28)=l1*rs/3.d0 - h(34)=l3*rs/12.d0 - h(39)=-l1*rs - h(43)=-l3*rs/12.d0 - h(55)=-l3*rs/6.d0 - h(64)=l1*srs/3.d0 - h(68)=l3*srs/12.d0 - h(30)=-l1*srs - h(50)=-l3*srs/12.d0 - h(36)=-l3*srs/6.d0 -c -c degree 4 -c - sr2=srs**2 - r2=rs**2 - h(84)=l1*ro+l3*r2/12.d0+l3*sr2/12.d0 - h(90)=l3*ro/2.d0 - h(95)=l3*r2/6.d0+l3*sr2/6.d0-6.d0*l1*ro - h(99)=-l5*r2/30.d0-l5*sr2/30.d0-l3*ro/2.d0 - h(109)=l3*rs/6.d0/beta - h(111)=l5*r2/15.d0+l5*sr2/15.d0-2.d0*l3*ro - h(132)=-l3*rs/6.d0/beta - h(140)=l7*r2/1344.d0+l7*sr2/1344.d0+l5*ro/80.d0 - h(145)=-l5*r2/30.d0-l5*sr2/30.d0-l3*ro/2.d0 - h(149)=l7*r2/672.d0+l7*sr2/672.d0-3.d0*l5*ro/40.d0 - h(161)=-l3*rs/3.d0/beta - h(175)=l3*r2/12.d0+l3*sr2/12.d0+l1*ro - h(179)=l3*ro/2.d0 - h(195)=l7*r2/1344.d0+l7*sr2/1344.d0+l5*ro/80.d0 - h(142)=-l5*sro/20.d0 - h(120)=4.d0*l1*sro - h(156)=l3*sro - h(86)=-4.d0*l1*sro - h(124)=l3*sro - h(106)=-l3*sro - h(187)=l3*srs/beta/6.d0 - h(148)=-l3*srs/6.d0/beta - h(92)=-l3*sro - h(116)=-l3*srs/3.d0/beta - h(165)=l5*sro/20.d0 - return - end -c -*********************************************************************** -c - subroutine iftm(p,fa,fm) -c subroutine for a linear matrix via initial -c and final twiss parameters - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) - write(6,*) 'iftm not yet available' - return - end -c -*********************************************************************** -c - subroutine sol(p,fa,fm) -c subroutine for a solenoid - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) - write(6,*) 'sol not yet available' - return - end -c -*********************************************************************** -c - subroutine cfqd(pa,ha,hm) -c -c This subroutine computes the map for a combined function quadrupole. -c Written by A. Dragt on 9 January 1988. -c Modified by A. Dragt 8/28/97 to use SSS routine. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - dimension pa(6),pb(6) - dimension pc(6) - dimension ha(monoms) - dimension hm(6,6) -c - include 'parset.inc' -c---- -c set up parameters and control indices -c - al=pa(1) - ipset=nint(pa(2)) - ilfrn=nint(pa(3)) - itfrn=nint(pa(4)) -c -c compute useful numbers -c - sl2=sl*sl - sl3=sl*sl2 -c -c get multipole values from the parameter set ipset -c - if (ipset.lt.1 .or. ipset.gt.maxpst) then - do 50 i=1,6 - 50 pb(i) = 0.0d0 - else - do 60 i=1,6 - 60 pb(i) = pst(i,ipset) - endif -c -c compute multipole coefficients -c - bquad=pb(1) - aquad=pb(2) - bsex=pb(3) - asex=pb(4) - boct=pb(5) - aoct=pb(6) -c - fqdnr=bquad/brho - fqdsk=aquad/brho - fsxnr=bsex/(3.d0*brho) - fsxsk=asex/(3.d0*brho) - focnr=boct/(4.d0*brho) - focsk=aoct/(4.d0*brho) -c -c compute the Hamiltonian -c - call clear(ha,hm) -c -c drift part -c - call hamdrift(ha) -c -c quad terms -c - ha(7)=fqdnr*sl/2.d0 - ha(18)=-ha(7) - ha(9)=-fqdsk*sl -c -c sext terms -c - ha(28)=fsxnr*sl2 - ha(30)=-3.d0*fsxsk*sl2 - ha(39)=-3.d0*fsxnr*sl2 - ha(64)=fsxsk*sl2 -c -c oct terms -c - ha(84)=focnr*sl3 - ha(86)=-4.0d0*focsk*sl3 - ha(95)=-6.d0*focnr*sl3 - ha(120)=4.d0*focsk*sl3 - ha(175)=focnr*sl3 -c -c set up and call sss routine -c - pc(1)= al/sl - pc(2)= 0.d0 - pc(3)= 0.d0 - pc(4)= .05d0 - pc(5)= 0.d0 - pc(6)= 0.d0 -c - write(jodf,*) 'ssscfqd has been used' - write(jodf,*) 'eps=',pc(4) -c - call sss(pc,ha,hm) -c -c fringe field effects are put on in the subroutine lmnt -c - return - end -c -c******************************************************************* -c - subroutine thnh (p,h,mh) -c Does the thin lens map for decapoles and duodecapoles. -c The length-strength product may be given for normal and skew -c Decapoles and Duodecapoles. The skew elements are -c rotated clockwise looking in the direction of the beam -c by half the pole symmetry angle ( 18 degs. for decapoles, -c 15 degs. for duodecapoles). -c Written by F. Neri, July 29, 1988. -c - use beamdata - use lieaparam, only : monoms - implicit none -c----Variables---- -c h, mh = output array and matrix - double precision h(monoms),mh(6,6),p(6) -c ls, f = length*strength (l*gb0), factor (used in calculation) -c qd, sx, oc : quad, sextupole, octupole -c nr, sk : normal, skew - double precision lsdenr,lsdesk,lsdunr,lsdusk - double precision fdenr,fdesk,fdunr,fdusk -c common quantities -c double precision brho,c,gamma,gamm1,beta,achg,sl,ts - external ident -c -c----Routine---- - lsdenr = p(1) - lsdesk = p(2) - lsdunr = p(3) - lsdusk = p(4) - fdenr=-lsdenr*sl**4/(5.*brho) - fdesk=-lsdesk*sl**4/(5.*brho) - fdunr=-lsdunr*sl**5/(6.*brho) - fdusk=-lsdusk*sl**5/(6.*brho) - call ident(h,mh) -c Matrix is identity -c Polynomials (decapole) - h(210)=fdenr - h(212)=-5.*fdesk - h(221)=-10.*fdenr - h(246)=10.*fdesk - h(301)=5.*fdenr - h(406)=-fdesk -c Polynomials (duodecapole) - h(462)=fdunr - h(464)=-6.*fdusk - h(473)=-15.*fdunr - h(498)=20.*fdusk - h(553)=15.*fdunr - h(658)=-6.*fdusk - h(840)=-fdunr -c That's all folks - return - end -c====================================================================== -c THIRD ORDER ROUTINES -c====================================================================== -c - subroutine drift3(l,h,mh) -c -c generates linear matrix mh and -c array h containing nonlinearities -c for the transfer map describing -c a drift section of length l meters -c Written by D. Douglas, ca 1982 -c - use lieaparam, only : monoms - use beamdata - include 'impli.inc' - double precision l,h(monoms),mh(6,6) -c - double precision lsc -c dimension j(6) -c - call clear(h,mh) - lsc=l/sl -c -c add drift terms to mh -c - do 40 k=1,6 - mh(k,k)=+1.0d0 - 40 continue - mh(1,2)=+lsc - mh(3,4)=+lsc - mh(5,6)=+(lsc/((gamma**2)*(beta**2))) -c -c add drift terms to h -c -c degree 3 -c - h(53)=-(lsc/(2.0d0*beta)) - h(76)=-(lsc/(2.0d0*beta)) - h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) -c -c degree 4 -c - h(140)=-lsc/8.0d0 - h(149)=-lsc/4.0d0 - h(154)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 - h(195)=-lsc/8.0d0 - h(200)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 - h(209)=+lsc*(1.0d0-(5.0d0/beta**2))/(8.0d0*gamma**2*beta**2) -c - if(monoms.gt.209)h(210:monoms)=0.d0 - return - end -c -c====================================================================== -c - subroutine dquad3(l,gb0,h,mh) -c -c computes matrix mh and polynomial array -c h for horizontally defocussing quadrupole -c of length l meters and with field -c gradient of gb0 tesla/meter -c Written by D. Douglas, ca 1982 -c - use lieaparam, only : monoms - use beamdata - include 'impli.inc' - double precision h(monoms),mh(6,6) - double precision gb0,k,k2,k3,k4,l,lk,lkm,lsc -c -c write(6,*)'USING DQUAD3' - call clear(h,mh) - lsc=l/sl -c -c evaluate k,lk -c - arg=(gb0*(sl**2))/brho - k=dsqrt(arg) - lk=lsc*k - lkm=(-1.0d0)*lk -c -c set coefficients of mh -c - chlk=(dexp(lk)+dexp(lkm))/(2.0d0) - shlk=(dexp(lk)-dexp(lkm))/(2.0d0) - clk=dcos(lk) - slk=dsin(lk) - mh(1,1)=+chlk - mh(1,2)=+(shlk/k) - mh(2,2)=+chlk - mh(2,1)=+(k*shlk) - mh(3,3)=+clk - mh(3,4)=+(slk/k) - mh(4,4)=+clk - mh(4,3)=-(k*slk) - mh(5,5)=+1.0d0 - mh(5,6)=+(lsc/((gamma**2)*(beta**2))) - mh(6,6)=+1.0d0 -c -c set coefficients of h -c - tlk=(2.0d0)*lk - tlkm=(-1.0d0)*tlk - flk=(4.0d0)*lk - flkm=(-1.0d0)*flk - chtlk=(dexp(tlk)+dexp(tlkm))/2.0d0 - shtlk=(dexp(tlk)-dexp(tlkm))/2.0d0 - stlk=dsin(tlk) - ctlk=dcos(tlk) - chflk=(dexp(flk)+dexp(flkm))/2.0d0 - shflk=(dexp(flk)-dexp(flkm))/2.0d0 - sflk=dsin(flk) - cflk=dcos(flk) -c -c degree 3 -c - h(33)=+((k*(tlk-shtlk))/(8.0d0*beta)) - h(38)=-((1.0d0-chtlk)/(4.0d0*beta)) - h(53)=-((tlk+shtlk)/(8.0d0*k*beta)) - h(67)=-((k*(tlk-stlk))/(8.0d0*beta)) - h(70)=-((1.0d0-ctlk)/(4.0d0*beta)) - h(76)=-((tlk+stlk)/(8.0d0*beta*k)) - h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) -c -c degree 4 -c - k2=k*k - k3=k*k2 - k4=k2*k2 - c2=clk*clk - s2=slk*slk - c4=c2*c2 - s4=s2*s2 - ch2=chlk*chlk - sh2=shlk*shlk - ch4=ch2*ch2 - sh4=sh2*sh2 - h(84)=-k3*shflk/2.56d2+k3*shtlk/3.2d1-3.d0*k4*lsc/6.4d1 - h(85)=+k2*sh4/8.d0 - h(90)=-3.d0*k*shflk/1.28d2+3.d0*k2*lsc/3.2d1 - h(95)=+k3*(chtlk-2.d0)*stlk/6.4d1+k4*lsc/1.6d1 - &+k3*(ctlk-2.d0)*shtlk/6.4d1 - h(96)=-k2*shtlk*stlk/3.2d1+k2*(chtlk-2.d0)*ctlk/3.2d1 - &+k2/3.2d1 - h(99)=-k*(chtlk-2.d0)*stlk/6.4d1 - &-k*(ctlk+2.d0)*shtlk/6.4d1 - &+k2*lsc/1.6d1 - h(104)=3.d0*k*shtlk/(3.2d1*beta**2) - &-k2*lsc*(chtlk+2.d0)/(1.6d1*beta**2) - &+k*(1.d0-3.d0/beta**2)*(shtlk-tlk)/1.6d1 - h(105)=+(ch4-1.d0)/8.d0 - h(110)=-k2*shtlk*stlk/3.2d1-k2*chtlk*(ctlk-2.d0)/3.2d1 - &-k2/3.2d1 - h(111)=+k*chtlk*stlk/1.6d1-k*shtlk*ctlk/1.6d1 - h(114)=+shtlk*stlk/3.2d1-3.d0/3.2d1 - &+chtlk*(ctlk+2.d0)/3.2d1 - h(119)=-chflk/(6.4d1*beta**2) - &+lk*shtlk/(8.d0*beta**2) - &-chtlk/(1.6d1*beta**2)+ch4/(8.d0*beta**2)-ch2/(4.d0*beta**2) - &+1.3d1/(6.4d1*beta**2) - &+(1.d0-3.d0/beta**2)*(1.d0-ch2)/4.d0 - h(140)=-shflk/(2.56d2*k)-shtlk/(3.2d1*k)-3.d0*lsc/6.4d1 - h(145)=+k*(chtlk+2.d0)*stlk/6.4d1 - &+k*(ctlk-2.d0)*shtlk/6.4d1-k2*lsc/1.6d1 - h(146)=-shtlk*stlk/3.2d1-3.d0/3.2d1 - &+(chtlk+2.d0)*ctlk/3.2d1 - h(149)=-(chtlk+2.d0)*stlk/(6.4d1*k) - &-(ctlk+2.d0)*shtlk/(6.4d1*k)-lsc/1.6d1 - h(154)=+shtlk/(k*3.2d1*beta**2)-lsc*chtlk/(1.6d1*beta**2) - &+(1.d0-3.d0/beta**2)*(shtlk+tlk)/(1.6d1*k) - h(175)=-k3*sflk/2.56d2+k3*stlk/3.2d1-3.d0*k4*lsc/6.4d1 - h(176)=-k2*s4/8.d0 - h(179)=+3.d0*k*sflk/1.28d2-3.d0*k2*lsc/3.2d1 - h(184)=-k*(1.d0-3.d0/beta**2)*(stlk-tlk)/1.6d1 - &-3.d0*k*stlk/(3.2d1*beta**2) - &+k2*lsc*(ctlk+2.d0)/(1.6d1*beta**2) - h(185)=+(c4-1.d0)/8.d0 - h(190)=+(1.d0-3.d0/beta**2)*(1.d0-c2)/4.d0 - &-cflk/(6.4d1*beta**2)-lk*stlk/(8.d0*beta**2) - &-ctlk/(1.6d1*beta**2)+c4/(8.d0*beta**2) - &-c2/(4.d0*beta**2)+1.3d1/(6.4d1*beta**2) - h(195)=-sflk/(2.56d2*k)-stlk/(3.2d1*k)-3.d0*lsc/6.4d1 - h(200)=+(1.d0-3.d0/beta**2)*(tlk+stlk)/(1.6d1*k) - &+stlk/(k*3.2d1*beta**2)-lsc*ctlk/(1.6d1*beta**2) - h(209)=+lsc*(1.d0-5.d0/beta**2)/(8.d0*gamma**2*beta**2) -c - if(monoms.gt.209)h(210:monoms)=0.d0 - return - end -c -c====================================================================== -c - subroutine fquad3(l,gb0,h,mh) -c -c computes matrix mh and polynomial array -c h for horizontally focussing quadrupole -c of length l meters and with field -c gradient of gb0 tesla/meter -c Written by D. Douglas, ca 1982 -c - use lieaparam, only : monoms - use beamdata - include 'impli.inc' - double precision h(monoms),mh(6,6) -c - double precision gb0,k,k2,k3,k4,l,lk,lkm,lsc -c -c write(6,*)'USING FQUAD3' - call clear(h,mh) - lsc=l/sl -c -c evaluate k,lk -c - arg=(gb0*(sl**2))/brho - k=dsqrt(arg) - lk=lsc*k - lkm=(-1.0d0)*lk -c -c set coefficients of mh -c - chlk=(dexp(lk)+dexp(lkm))/(2.0d0) - shlk=(dexp(lk)-dexp(lkm))/(2.0d0) - clk=dcos(lk) - slk=dsin(lk) - mh(3,3)=+chlk - mh(3,4)=+(shlk/k) - mh(4,4)=+chlk - mh(4,3)=+(k*shlk) - mh(1,1)=+clk - mh(1,2)=+(slk/k) - mh(2,2)=+clk - mh(2,1)=-(k*slk) - mh(5,5)=+1.0d0 - mh(5,6)=+(lsc/((gamma**2)*(beta**2))) - mh(6,6)=+1.0d0 -c -c set coefficients of h -c - tlk=(2.0d0)*lk - tlkm=(-1.0d0)*tlk - flk=(4.0d0)*lk - flkm=(-1.0d0)*flk - chtlk=(dexp(tlk)+dexp(tlkm))/2.0d0 - shtlk=(dexp(tlk)-dexp(tlkm))/2.0d0 - stlk=dsin(tlk) - ctlk=dcos(tlk) - chflk=(dexp(flk)+dexp(flkm))/2.0d0 - shflk=(dexp(flk)-dexp(flkm))/2.0d0 - sflk=dsin(flk) - cflk=dcos(flk) -c -c degree 3 -c - h(67)=+((k*(tlk-shtlk))/(8.0d0*beta)) - h(70)=-((1.0d0-chtlk)/(4.0d0*beta)) - h(76)=-((tlk+shtlk)/(8.0d0*k*beta)) - h(33)=-((k*(tlk-stlk))/(8.0d0*beta)) - h(38)=-((1.0d0-ctlk)/(4.0d0*beta)) - h(53)=-((tlk+stlk)/(8.0d0*beta*k)) - h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) -c -c degree 4 -c - k2=k*k - k3=k*k2 - k4=k2*k2 - c2=clk*clk - s2=slk*slk - c4=c2*c2 - s4=s2*s2 - ch2=chlk*chlk - sh2=shlk*shlk - ch4=ch2*ch2 - sh4=sh2*sh2 - h(175)=-k3*shflk/2.56d2+k3*shtlk/3.2d1-3.d0*k4*lsc/6.4d1 - h(176)=+k2*sh4/8.d0 - h(179)=-3.d0*k*shflk/1.28d2+3.d0*k2*lsc/3.2d1 - h(95)=+k3*(chtlk-2.d0)*stlk/6.4d1+k4*lsc/1.6d1 - &+k3*(ctlk-2.d0)*shtlk/6.4d1 - h(110)=-k2*shtlk*stlk/3.2d1+k2*(chtlk-2.d0)*ctlk/3.2d1 - &+k2/3.2d1 - h(145)=-k*(chtlk-2.d0)*stlk/6.4d1 - &-k*(ctlk+2.d0)*shtlk/6.4d1 - &+k2*lsc/1.6d1 - h(184)=+3.d0*k*shtlk/(3.2d1*beta**2) - &-k2*lsc*(chtlk+2.d0)/(1.6d1*beta**2) - &+k*(1.d0-3.d0/beta**2)*(shtlk-tlk)/1.6d1 - h(185)=+(ch4-1.d0)/8.d0 - h(96)=-k2*shtlk*stlk/3.2d1-k2*chtlk*(ctlk-2.d0)/3.2d1 - &-k2/3.2d1 - h(111)=+k*chtlk*stlk/1.6d1-k*shtlk*ctlk/1.6d1 - h(146)=+shtlk*stlk/3.2d1-3.d0/3.2d1 - &+chtlk*(ctlk+2.d0)/3.2d1 - h(190)=-chflk/(6.4d1*beta**2) - &+lk*shtlk/(8.d0*beta**2) - &-chtlk/(1.6d1*beta**2)+ch4/(8.d0*beta**2)-ch2/(4.d0*beta**2) - &+1.3d1/(6.4d1*beta**2) - &+(1.d0-3.d0/beta**2)*(1.d0-ch2)/4.d0 - h(195)=-shflk/(2.56d2*k)-shtlk/(3.2d1*k)-3.d0*lsc/6.4d1 - h(99)=+k*(chtlk+2.d0)*stlk/6.4d1 - &+k*(ctlk-2.d0)*shtlk/6.4d1-k2*lsc/1.6d1 - h(114)=-shtlk*stlk/3.2d1-3.d0/3.2d1 - &+(chtlk+2.d0)*ctlk/3.2d1 - h(149)=-(chtlk+2.d0)*stlk/(6.4d1*k) - &-(ctlk+2.d0)*shtlk/(6.4d1*k)-lsc/1.6d1 - h(200)=+shtlk/(k*3.2d1*beta**2)-lsc*chtlk/(1.6d1*beta**2) - &+(1.d0-3.d0/beta**2)*(shtlk+tlk)/(1.6d1*k) - h(84)=-k3*sflk/2.56d2+k3*stlk/3.2d1-3.d0*k4*lsc/6.4d1 - h(85)=-k2*s4/8.d0 - h(90)=+3.d0*k*sflk/1.28d2-3.d0*k2*lsc/3.2d1 - h(104)=-k*(1.d0-3.d0/beta**2)*(stlk-tlk)/1.6d1 - &-3.d0*k*stlk/(3.2d1*beta**2) - &+k2*lsc*(ctlk+2.d0)/(1.6d1*beta**2) - h(105)=+(c4-1.d0)/8.d0 - h(119)=+(1.d0-3.d0/beta**2)*(1.d0-c2)/4.d0 - &-cflk/(6.4d1*beta**2)-lk*stlk/(8.d0*beta**2) - &-ctlk/(1.6d1*beta**2)+c4/(8.d0*beta**2) - &-c2/(4.d0*beta**2)+1.3d1/(6.4d1*beta**2) - h(140)=-sflk/(2.56d2*k)-stlk/(3.2d1*k)-3.d0*lsc/6.4d1 - h(154)=+(1.d0-3.d0/beta**2)*(tlk+stlk)/(1.6d1*k) - &+stlk/(k*3.2d1*beta**2)-lsc*ctlk/(1.6d1*beta**2) - h(209)=+lsc*(1.d0-5.d0/beta**2)/(8.d0*gamma**2*beta**2) -c - if(monoms.gt.209)h(210:monoms)=0.d0 - return - end -c -*********************************************************************** -c - subroutine sext3(l,gb0,h,mh) -c -c computes matrix mh and polynomial h -c for sextupole of length l with strength -c gb0 (in tesla/meter**2). routine assumes -c a vector potential of the form -c (gb0/3)(x**3-3xy**2) -c Written by D. Douglas, ca 1982 -c - use lieaparam, only : monoms - use beamdata - include 'impli.inc' - double precision l,lsc,lsc2,lsc3,lsc4,lsc5,lsc6,lsc7,mh - dimension h(monoms) - dimension mh(6,6) -c - call clear(h,mh) - lsc=l/sl -c -c evaluate coefficients of h -c -c -c set coefficients of mh -c - do 40 i=1,6 - mh(i,i)=+1.0d0 - 40 continue - mh(1,2)=+lsc - mh(3,4)=+lsc - mh(5,6)=+(lsc/((gamma**2)*(beta**2))) -c -c set coefficients of h -c -c degree 3 -c - rk=-(gb0*(sl**3))/(brho*3.0d0) - h(28)=+(lsc*rk) - h(29)=-((3.0d0*(lsc**2)*rk)/2.0d0) - h(34)=+((lsc**3)*rk) - h(39)=-(3.0d0*lsc*rk) - h(40)=+(3.0d0*(lsc**2)*rk) - h(43)=-((lsc**3)*rk) - h(49)=-(((lsc**4)*rk)/4.0d0) - h(53)=-(lsc/(2.0d0*beta)) - h(54)=+((3.0d0*(lsc**2)*rk)/2.0d0) - h(55)=-(2.0d0*(lsc**3)*rk) - h(58)=+((3.0d0*(lsc**4)*rk)/4.0d0) - h(76)=-(lsc/(2.0d0*beta)) - h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) -c -c degree 4 -c - lsc2=lsc**2 - lsc3=lsc**3 - lsc4=lsc**4 - lsc5=lsc**5 - lsc6=lsc**6 - lsc7=lsc**7 - rk2=rk**2 - h(84)=+7.5d-1*rk2*lsc3 - h(85)=-1.5d0*rk2*lsc4 - h(90)=+1.125d0*rk2*lsc5 - h(95)=+1.5d0*rk2*lsc3 - h(96)=-1.5d0*rk2*lsc4 - h(99)=+3.d0*rk2*lsc5/4.d1 - h(105)=-3.75d-1*rk2*lsc6 - h(109)=+rk*lsc3/(2.0d0*beta) - h(110)=-1.5d0*rk2*lsc4 - h(111)=+2.1d0*rk2*lsc5 - h(114)=-3.75d-1*rk2*lsc6 - h(132)=-rk*lsc3/(2.0d0*beta) - h(140)=+3.0d0*rk2*lsc7/5.6d1-lsc/8.0d0 - h(144)=-rk*lsc4/(4.0d0*beta) - h(145)=+3.0d0*rk2*lsc5/4.d1 - h(146)=-3.75d-1*rk2*lsc6 - h(149)=+3.0d0*rk2*lsc7/2.8d1-lsc/4.0d0 - h(154)=+lsc*(1.0d0-(3.0d0/(beta**2)))/4.0d0 - h(161)=-rk*lsc3/beta - h(167)=+7.5d-1*rk*lsc4/beta - h(175)=+7.5d-1*rk2*lsc3 - h(176)=-1.5d0*rk2*lsc4 - h(179)=+1.125d0*rk2*lsc5 - h(185)=-3.75d-1*rk2*lsc6 - h(195)=+3.0d0*rk2*lsc7/5.6d1-lsc/8.0d0 - h(200)=+lsc*(1.d0-(3.d0/(beta**2)))/4.d0 - h(209)=+(lsc*(1.d0-(5.0d0/beta**2)))/(8.0d0*gamma**2*beta**2) -c - if(monoms.gt.209)h(210:monoms)=0.d0 - return - end -c -*********************************************************************** -c - subroutine octm3(l,gb0,h,mh) -c -c computes matrix mh and polynomial h for -c magnetic octupole with length l meters and vector -c potential of the form (gb0/4.)*(+x**4-6*x**2*y**2+y**4) -c Written by D. Douglas, ca 1982 -c - use lieaparam, only : monoms - use beamdata - include 'impli.inc' - double precision l,h(monoms),mh(6,6) - double precision lsc -c - call clear(h,mh) - lsc=l/sl -c -c enter matrix elements -c - do 40 i=1,6 - mh(i,i)=+1.0d0 - 40 continue - mh(1,2)=+lsc - mh(3,4)=+lsc - mh(5,6)=+(lsc/((gamma**2)*(beta**2))) -c -c set coefficients of h -c -c degree 3 -c - h(53)=-(lsc/(2.0d0*beta)) - h(76)=-(lsc/(2.0d0*beta)) - h(83)=-(lsc/(2.0d0*(gamma**2)*(beta**3))) -c -c degree 4 -c - ap=-(sl**4)*gb0/(4.d0*brho) - h(84)=+lsc*ap - h(85)=-2.0d0*(lsc**2)*ap - h(90)=2.0d0*(lsc**3)*ap - h(95)=-6.0d0*lsc*ap - h(96)=6.d0*lsc**2*ap - h(99)=-(2.0d0*(lsc**3)*ap) - h(105)=-(lsc**4)*ap - h(110)=+6.0d0*(lsc**2)*ap - h(111)=-(8.0d0*(lsc**3)*ap) - h(114)=+3.0d0*(lsc**4)*ap - h(140)=-lsc/8.0d0+(lsc**5)*ap/5.0d0 - h(145)=-(2.0d0*(lsc**3)*ap) - h(146)=+3.0d0*(lsc**4)*ap - h(149)=-lsc/4.0d0-(6.0d0*(lsc**5)*ap)/5.0d0 - h(154)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 - h(175)=+lsc*ap - h(176)=-2.0d0*(lsc**2)*ap - h(179)=+2.0d0*(lsc**3)*ap - h(185)=-(lsc**4)*ap - h(195)=-lsc/8.0d0+(lsc**5)*ap/5.0d0 - h(200)=+(lsc*(1.0d0-(3.0d0/(beta**2))))/4.0d0 - h(209)=+(lsc*(1.d0-(5.d0/beta**2)))/(8.d0*gamma**2*beta**2) -c - if(monoms.gt.209)h(210:monoms)=0.d0 - return - end -c -*********************************************************************** diff --git a/OpticsJan2020/MLI_light_optics/Src/env.f b/OpticsJan2020/MLI_light_optics/Src/env.f deleted file mode 100644 index 0793386..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/env.f +++ /dev/null @@ -1,844 +0,0 @@ - subroutine initenv(p,icorrel) -c R. Ryne 4/7/2004 -c routine to initialize rms envelopes. -c this assumes that the units are those used in the current ML/I simulation. -c input parameters array elements: -c p(1)=x_rms, p(2)=px_rms, p(3)=xpx_rms, p(4)=x_emittance_normalized_rms -c p(5)=y_rms, p(6)=py_rms, p(7)=ypy_rms, p(8)=y_emittance_normalized_rms -c p(9)=t_rms, p(10)=pt_rms, p(11)=tpt_rms, p(12)=t_emittance_normalized_rms -c p(13-15)=canonical momenta conjugate to p(1-3), respectively -c icorrel describes whether xpx, ypy, tpt are scaled (i.e. correlations) or not -c e.g. if icorrel=0, then is really -c if icorrel=1, then is really /(xrms*pxrms)? -c and similary for and -c -c NOTE WELL: This routine assumes that, at the point the initial values -c are set, the beam is not inside an rf cavity. In this case, -c canonical mom. conjugate to x_rms = /xrms -c canonical mom. conjugate to y_rms = /yrms -c canonical mom. conjugate to t_rms = /trms -c If the beam is initialized inside an rf cavity, this does not hold. - use parallel, only : idproc - include 'impli.inc' - common/envdata/env(6),envold(6),emap(6,6) - common/emitdata/emxn2,emyn2,emtn2 - dimension p(*) - if(p(1).eq.0.d0)then - if(idproc.eq.0)then - write(6,*)'error(initenv): must specify rms beam sizes' - endif - call myexit - endif -c -c X-PX: - env(1)=p(1) - if(p(13).ne.0.d0)then -c user is specifying cpx (canonical px) and emittance: - env(2)=p(13) - emxn2=p(4)**2 - else -c user is specifying px & xpx, px & emit, or xpx & emit: - if(p(4).eq.0.d0)then !user specifying px & xpx - if(icorrel.eq.0)then - env(2)=p(3)/p(1) - emxn2=p(1)**2*p(2)**2-p(3)**2 - endif - if(icorrel.eq.1)then - env(2)=p(3)*p(2) - emxn2=p(1)**2*p(2)**2*(1.d0-p(3)**2) - endif - else - if(p(2).ne.0.d0)then !user specifying px & emit - emxn2=p(4)**2 - xpx2=p(1)**2*p(2)**2-emxn2 - env(2)=sqrt(xpx2)/p(1) - else !user specifying xpx & emit - env(2)=p(3)/p(1) - emxn2=p(4)**2 - endif - endif - endif -c -c Y-PY: - env(3)=p(5) - if(p(14).ne.0.d0)then -c user is specifying cpy (canonical py) and emittance: - env(4)=p(14) - emyn2=p(8)**2 - else -c user is specifying py & ypy, py & emit, or ypy & emit: - if(p(8).eq.0.d0)then !user specifying py & ypy - if(icorrel.eq.0)then - env(4)=p(7)/p(5) - emyn2=p(5)**2*p(6)**2-p(7)**2 - endif - if(icorrel.eq.1)then - env(4)=p(7)*p(6) - emyn2=p(5)**2*p(6)**2*(1.d0-p(7)**2) - endif - else - if(p(6).ne.0.d0)then !user specifying py & emit - emyn2=p(8)**2 - ypy2=p(5)**2*p(6)**2-emyn2 - env(4)=sqrt(ypy2)/p(5) - else !user specifying ypy & emit - env(4)=p(7)/p(5) - emyn2=p(8)**2 - endif - endif - endif -c -c T-PT: - env(5)=p(9) - if(p(15).ne.0.d0)then -c user is specifying cpt (canonical pt) and emittance: - env(6)=p(15) - emtn2=p(12)**2 - else -c user is specifying pt & tpt, pt & emit, or tpt & emit: - if(p(12).eq.0.d0)then !user specifying pt & tpt - if(icorrel.eq.0)then - env(6)=p(11)/p(9) - emtn2=p(9)**2*p(10)**2-p(11)**2 - endif - if(icorrel.eq.1)then - env(6)=p(11)*p(10) - emtn2=p(9)**2*p(10)**2*(1.d0-p(11)**2) - endif - else - if(p(10).ne.0.d0)then !user specifying pt & emit - emtn2=p(12)**2 - tpt2=p(9)**2*p(10)**2-emtn2 - env(6)=sqrt(tpt2)/p(9) - else !user specifying tpt & emit - env(6)=p(11)/p(9) - emtn2=p(12)**2 - endif - endif - endif -c initialize the matrix for the envelope map, -c in case the user wants to compute it: - emap(1:6,1:6)=0.d0 - do i=1,6 - emap(i,i)=1.d0 - enddo -c store the initial values of the envelopes, -c in case the user wants to perform a contraction mapping later: - envold(1:6)=env(1:6) - return - end -c - subroutine contractenv(delta) -c perform contraction map on envelopes to find fixed point (rms matched beam). -c delta is the residual, i.e. a metric to describe how close the beam is -c to a match. - use parallel, only : idproc - use beamdata - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' - include 'map.inc' - include 'setref.inc' - dimension d(6),v(6),ca(6),amat(6,6) - common/envdata/env(6),envold(6),emap(6,6) - dimension augm(6,7) -c Apply the contraction mapping, C, to the vector a : -c Ca = a + 1/(I-M) * (a-Na) -c where Na == Script m acting on a == numerical integration -c using a for initial values. -c -c if(idproc.eq.0)then -c write(6,*)'***********************entering contractenv' -c write(6,*)'***********************entering contractenv, env=' -c write(6,51)env(1:6) -c endif -c 51 format(6(1x,1pe12.5)) -c - d(:)=envold(:)-env(:) -c write(6,*)'***********************d(1:6)=' -c write(6,51)d(1:6) -c write(6,*)'***********************emap(1:6,1:6)=' -c write(6,51)emap(1:6,1:6) -c - amat(:,:)=-emap(:,:) - do i=1,6 - amat(i,i)=1.+amat(i,i) - enddo -c Compute 1/(I-M) * d by solving (I-M)v=d for v : -c write(6,*)'calling leshs, v(1-6)=',v(1:6) - call leshs(v,6,amat,d,augm,det) -c write(6,*)'returned from leshs, v(1-6)=',v(1:6) -c Now compute Ca: - ca(:)=envold(:)-v(:) -c check for convergence: - vnorm=sqrt(v(1)**2+v(2)**2+v(3)**2+v(4)**2+v(5)**2+v(6)**2) - anorm=sqrt(envold(1)**2+envold(2)**2+envold(3)**2+ & - & envold(4)**2+envold(5)**2+envold(6)**2) - delta=vnorm/anorm -c if(idproc.eq.0)write(6,*)'delta=',delta -c if(delta.lt.1.d-9)then -c if(idproc.eq.0)then -c write(6,*)'SEARCH CONVERGED' -c endif -c endif -c continue the contraction map procedure: - envold(:)=ca(:) - env(:)=envold(:) - emap(:,:)=0.d0 - do i=1,6 - emap(i,i)=1.d0 - enddo -ccccc reftraj(1:6)=refsave(1,1:6) -ccccc arclen=arcsave(1) -ccccc brho=brhosav(1) -ccccc gamma=gamsav(1) -ccccc gamm1=gam1sav(1) -ccccc beta=betasav(1) -c -c diagnostic for debug: -c if(idproc.eq.0)then -c write(6,*)'matrix:' -c write(6,51)(emap(1,j),j=1,6) -c write(6,51)(emap(2,j),j=1,6) -c write(6,51)(emap(3,j),j=1,6) -c write(6,51)(emap(4,j),j=1,6) -c write(6,51)(emap(5,j),j=1,6) -c write(6,51)(emap(6,j),j=1,6) -c endif -c write(6,*)'***********************leaving contractenv' -c write(6,*)'***********************leaving contractenv, env=' -c write(6,51)env(1:6) - return - end -c - subroutine envtrace(mh) -c "Envelope tracking" routine applies the linear map to the envelopes. -c This is used along with the split-operator symplectic integrator -c to advance the envelope equations. (The space-charge and emittance -c terms are handled in mid-step in subroutine envkick) -c R. Ryne 4/7/2004 - include 'impli.inc' - double precision mh(6,6) - double precision vec(6) - common/envdata/env(6),envold(6),emap(6,6) -c write(6,*)'here I am in *envtrace*; env(1:6)=' -c write(6,51)env(1:6) -c write(6,*)'mh(1:6,1:6)=' -c write(6,51)mh(1:6,1:6) -c 51 format(6(1x,1pe12.5)) -c initialize zlm - vec(1:6)=0.d0 -c - do 100 i=1,6 - do 90 j=1,6 - vec(i)=vec(i) + mh(i,j)*env(j) - 90 continue - 100 continue - env(1:6)=vec(1:6) -c write(6,*)'new values of env(1),env(2),env(5),env(6)=' -c write(6,*)env(1),env(2),env(5),env(6) -c code to advanced the momentum portion of the "envelope map," i.e. the -c linear map for envelope dynamics around the env reference envelope: - call mmult(mh,emap,emap) - return - end -c - subroutine envkick(tau) - use parallel, only : idproc - use beamdata -ccc real*8 :: brho,gamma,gamm1,beta,achg,pmass,bfreq,bcurr,c -ccc real*8 :: sl,p0sc,ts,omegascl,freqscl - include 'impli.inc' - dimension etmp(6,6) - common/envdata/env(6),envold(6),emap(6,6) - common/emitdata/emxn2,emyn2,emtn2 -c write(6,*)'here I am in envkick; env(1),env(3),env(5)=' -c write(6,*)env(1),env(3),env(5) -c formulas are coded in terms of xl,xp,xw; connect to parameters in acceldata: - clite=299792458.d0 - pi=2.d0*asin(1.d0) - fpei=(clite**2)*1.d-7 - q=1.d0 - xmc2=pmass - xl=sl - xp=p0sc - xw=omegascl -c The commented out statement below is probably wrong, because -c bfreq should only affect the total charge. -c The statement makes sense only if w is the scale ang freq. -c w=2.d0*pi*bfreq - w=xw - p0=gamma*beta*pmass/clite - xmp0=1./(gamma*beta*clite) -c - uu=env(1)**2 - vv=env(3)**2 - ww=(env(5)*gamma*beta*clite/(w*xl))**2 -c write(6,*)'new values of uu,vv,ww=',uu,vv,ww -cryne note: g311,g131,g113 all vary as ~1/[length**3]; g511 etc vary as 1/l**5 -cryne In other words, if env(1),env(3),and env(5) are doubled, then -cryne g311,g131,g113 are reduced by a factor of 8 (i.e. 8 times smaller) -c write(6,*)'calling scdrd' - call scdrd(uu,vv,ww,g311,g131,g113,g511,g151,g115,g331,g313,g133) -c write(6,*)'returned from scdrd' -cryne qtot=bcurr*2.*pi/w - qtot=bcurr/bfreq - xi0=xmc2*clite/(q*fpei) - xlam3=1.d0/(5.d0*sqrt(5.d0)) - qcon=1.5d0*qtot*xlam3*clite/(xi0*(beta*gamma*xl)**2)*p0/xp - tcon=qcon*(gamma*beta*clite/(w*xl))**2 -c - r11= qcon*g311*env(1) +emxn2*(xp/(p0*xl))/env(1)**3 - r33= qcon*g131*env(3) +emyn2*(xp/(p0*xl))/env(3)**3 - r55= tcon*g113*env(5)+emtn2/env(5)**3*(xl*xp*xw*xw*xmp0*xmp0/p0) -c - env(2)=env(2)+r11*tau - env(4)=env(4)+r33*tau - env(6)=env(6)+r55*tau -c write(6,*)'done updating env; preparing to update emap' -c -c Advance emap, which is transfer map around this envelope: -c Note: there is probably a bug in the original envelope code, fixsc3, -c which refers to the variable w0 (the cavity ang freq) in the formulas below. -c In fixsc3, w0 is set equal to the scale angular frequency. -c In other words, fixsc3 *only* works when the cav ang freq=scale ang freq. -c The two formulas are commented out below and replaced by the correct ones. -c - xyfac=xp/(p0*xl) -c xyfac=0.d0 -c - s11=3.*emxn2*xyfac/(uu**2)+qcon*(3.*uu*g511-g311) - s33=3.*emyn2*xyfac/(vv**2)+qcon*(3.*vv*g151-g131) -c s55=3.d0*(w0*xmp0*xl)**2*emtn2*xyfac/env(5)**4+ & - s55=3.d0*(xw*xmp0*xl)**2*emtn2*xyfac/env(5)**4+ & - & tcon*(3.d0*ww*g115-g113) - s13=qcon*env(1)*env(3)*g331 - s15=tcon*env(1)*env(5)*g313 - s35=tcon*env(3)*env(5)*g133 - s31=s13 - s51=s15 - s53=s35 - s22=xyfac - s44=s22 -c s66=(w0*xmp0*xl)**2*s22 - s66=(xw*xmp0*xl)**2*s22 -c - etmp(1:6,1:6)=0.d0 - do i=1,6 - etmp(i,i)=1.d0 - enddo - etmp(2,1)=-tau*s11 - etmp(4,3)=-tau*s33 - etmp(6,5)=-tau*s55 -c - etmp(2,3)=-tau*s13 - etmp(2,5)=-tau*s15 -c - etmp(4,1)=-tau*s13 - etmp(4,5)=-tau*s35 -c - etmp(6,1)=-tau*s15 - etmp(6,3)=-tau*s35 -c -c write(6,*)'calling mmult' - call mmult(etmp,emap,emap) !(left,right,out) -cxxx call mmult(emap,etmp,emap) -c write(6,*)'leaving envkick' - return - end - -c===================================================================== - subroutine scdrd(uu,vv,ww, & - &h311,h131,h113,h511,h151,h115,h331,h313,h133) - include 'impli.inc' - alpha=3.d0/(uu+vv+ww) - a=alpha*uu - b=alpha*vv - c=alpha*ww - fac5=sqrt(alpha**3) - fac7=sqrt(alpha**5) - eps=1.d-4 -c - result1=drd(b,c,a,ierr) - if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' - result1=2.d0/3.d0*result1 - h311=result1*fac5 -c - result2=drd(a,c,b,ierr) - if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' - result2=2.d0/3.d0*result2 - h131=result2*fac5 -c - result3=drd(a,b,c,ierr) - if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' - result3=2.d0/3.d0*result3 - h113=result3*fac5 -c----------------------------------------------------- - result1plus=drd(b*(1.d0+eps),c,a,ierr) - result1minus=drd(b*(1.d0-eps),c,a,ierr) - if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' - deriv=(result1plus-result1minus)/(2.d0*eps*b) - h331=-deriv*2.d0/3.d0*fac7*2.d0 -c - result1plus=drd(c*(1.d0+eps),b,a,ierr) - result1minus=drd(c*(1.d0-eps),b,a,ierr) - if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' - deriv=(result1plus-result1minus)/(2.d0*eps*c) - h313=-deriv*2.d0/3.d0*fac7*2.d0 -c - result1plus=drd(b*(1.d0+eps),a,c,ierr) - result1minus=drd(b*(1.d0-eps),a,c,ierr) - if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' - deriv=(result1plus-result1minus)/(2.d0*eps*b) - h133=-deriv*2.d0/3.d0*fac7*2.d0 -c----------------------------------------------------- - result1plus=drd(b,c,a*(1.d0+eps),ierr) - result1minus=drd(b,c,a*(1.d0-eps),ierr) - if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' - deriv=(result1plus-result1minus)/(2.d0*eps*a) - h511=-deriv*2.d0/3.d0*fac7*2.d0/3.d0 -c - result1plus=drd(a,c,b*(1.d0+eps),ierr) - result1minus=drd(a,c,b*(1.d0-eps),ierr) - if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' - deriv=(result1plus-result1minus)/(2.d0*eps*b) - h151=-deriv*2.d0/3.d0*fac7*2.d0/3.d0 -c - result1plus=drd(a,b,c*(1.d0+eps),ierr) - result1minus=drd(a,b,c*(1.d0-eps),ierr) - if(ierr.gt.0)write(6,*)'trouble: ierr>0 in routine scdrd' - deriv=(result1plus-result1minus)/(2.d0*eps*c) - h115=-deriv*2.d0/3.d0*fac7*2.d0/3.d0 -c----------------------------------------------------- - return - end -c -c==================================================================== -c - DOUBLE PRECISION FUNCTION DRD(X,Y,Z,IER) DRD 3 -C***BEGIN PROLOGUE DRD DRD 4 -C***DATE WRITTEN 790801 (YYMMDD) DRD 5 -C***REVISION DATE 861211 (YYMMDD) DRD 6 -C***CATEGORY NO. C14 DRD 7 -C***KEYWORDS LIBRARY=SLATEC,TYPE=DOUBLE PRECISION(RD-S DRD-D), DRD 8 -C COMPLETE ELLIPTIC INTEGRAL,DUPLICATION THEOREM, DRD 9 -C INCOMPLETE ELLIPTIC INTEGRAL,INTEGRAL OF THE SECOND KIND, DRD 10 -C TAYLOR SERIES DRD 11 -C***AUTHOR CARLSON, B.C., AMES LABORATORY-DOE DRD 12 -C IOWA STATE UNIVERSITY, AMES, IOWA 50011 DRD 13 -C NOTIS, E.M., AMES LABORATORY-DOE DRD 14 -C IOWA STATE UNIVERSITY, AMES, IOWA 50011 DRD 15 -C PEXTON, R.L., LAWRENCE LIVERMORE NATIONAL LABORATORY DRD 16 -C LIVERMORE, CALIFORNIA 94550 DRD 17 -C***PURPOSE Compute the INCOMPLETE or COMPLETE Elliptic integral of DRD 18 -C the 2nd kind. For X and Y nonnegative, X+Y and Z positive, DRD 19 -C DRD(X,Y,Z) = Integral from ZERO to INFINITY of DRD 20 -C -1/2 -1/2 -3/2 DRD 21 -C (3/2)(t+X) (t+Y) (t+Z) dt. DRD 22 -C If X or Y is zero, the integral is COMPLETE. DRD 23 -C***DESCRIPTION DRD 24 -C DRD 25 -C 1. DRD DRD 26 -C Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL DRD 27 -C of the second kind DRD 28 -C Standard FORTRAN function routine DRD 29 -C Double precision version DRD 30 -C The routine calculates an approximation result to DRD 31 -C DRD(X,Y,Z) = Integral from zero to infinity of DRD 32 -C -1/2 -1/2 -3/2 DRD 33 -C (3/2)(t+X) (t+Y) (t+Z) dt, DRD 34 -C where X and Y are nonnegative, X + Y is positive, and Z is DRD 35 -C positive. If X or Y is zero, the integral is COMPLETE. DRD 36 -C The duplication theorem is iterated until the variables are DRD 37 -C nearly equal, and the function is then expanded in Taylor DRD 38 -C series to fifth order. DRD 39 -C DRD 40 -C 2. Calling Sequence DRD 41 -C DRD 42 -C DRD( X, Y, Z, IER ) DRD 43 -C DRD 44 -C Parameters On Entry DRD 45 -C Values assigned by the calling routine DRD 46 -C DRD 47 -C X - Double precision,nonnegative variable DRD 48 -C DRD 49 -C Y - Double precision,nonnegative variable DRD 50 -C DRD 51 -C X + Y is positive DRD 52 -C DRD 53 -C Z - Double precision,positive variable DRD 54 -C DRD 55 -C DRD 56 -C DRD 57 -C On Return (values assigned by the DRD routine) DRD 58 -C DRD 59 -C DRD - Double precision approximation to the integral DRD 60 -C DRD 61 -C DRD 62 -C IER - Integer DRD 63 -C DRD 64 -C IER = 0 Normal and reliable termination of the DRD 65 -C routine. It is assumed that the requested DRD 66 -C accuracy has been achieved. DRD 67 -C DRD 68 -C IER > 0 Abnormal termination of the routine DRD 69 -C DRD 70 -C DRD 71 -C X, Y, Z are unaltered. DRD 72 -C DRD 73 -C 3. Error Messages DRD 74 -C DRD 75 -C Value of IER assigned by the DRD routine DRD 76 -C DRD 77 -C Value assigned Error message printed DRD 78 -C IER = 1 DMIN1(X,Y) .LT. 0.0D0 DRD 79 -C = 2 DMIN1(X + Y, Z ) .LT. LOLIM DRD 80 -C = 3 DMAX1(X,Y,Z) .GT. UPLIM DRD 81 -C DRD 82 -C DRD 83 -C 4. Control Parameters DRD 84 -C DRD 85 -C Values of LOLIM,UPLIM,and ERRTOL are set by the DRD 86 -C routine. DRD 87 -C DRD 88 -C LOLIM and UPLIM determine the valid range of X, Y, and Z DRD 89 -C DRD 90 -C LOLIM - Lower limit of valid arguments DRD 91 -C DRD 92 -C Not less than 2 / (machine maximum) ** (2/3). DRD 93 -C DRD 94 -C UPLIM - Upper limit of valid arguments DRD 95 -C DRD 96 -C Not greater than (0.1D0 * ERRTOL / machine DRD 97 -C minimum) ** (2/3), where ERRTOL is described below. DRD 98 -C In the following table it is assumed that ERRTOL will DRD 99 -C never be chosen smaller than 1.0D-5. DRD 100 -C DRD 101 -C DRD 102 -C Acceptable values for: LOLIM UPLIM DRD 103 -C IBM 360/370 SERIES : 6.0D-51 1.0D+48 DRD 104 -C CDC 6000/7000 SERIES : 5.0D-215 2.0D+191 DRD 105 -C UNIVAC 1100 SERIES : 1.0D-205 2.0D+201 DRD 106 -C CRAY : 3.0D-1644 1.69D+1640 DRD 107 -C VAX 11 SERIES : 1.0D-25 4.5D+21 DRD 108 -C DRD 109 -C DRD 110 -C ERRTOL determines the accuracy of the answer DRD 111 -C DRD 112 -C The value assigned by the routine will result DRD 113 -C in solution precision within 1-2 decimals of DRD 114 -C "machine precision". DRD 115 -C DRD 116 -C ERRTOL Relative error due to truncation is less than DRD 117 -C 3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2. DRD 118 -C DRD 119 -C DRD 120 -C DRD 121 -C The accuracy of the computed approximation to the integral DRD 122 -C can be controlled by choosing the value of ERRTOL. DRD 123 -C Truncation of a Taylor series after terms of fifth order DRD 124 -C introduces an error less than the amount shown in the DRD 125 -C second column of the following table for each value of DRD 126 -C ERRTOL in the first column. In addition to the truncation DRD 127 -C error there will be round-off error, but in practice the DRD 128 -C total error from both sources is usually less than the DRD 129 -C amount given in the table. DRD 130 -C DRD 131 -C DRD 132 -C DRD 133 -C DRD 134 -C Sample choices: ERRTOL Relative truncation DRD 135 -C error less than DRD 136 -C 1.0D-3 4.0D-18 DRD 137 -C 3.0D-3 3.0D-15 DRD 138 -C 1.0D-2 4.0D-12 DRD 139 -C 3.0D-2 3.0D-9 DRD 140 -C 1.0D-1 4.0D-6 DRD 141 -C DRD 142 -C DRD 143 -C Decreasing ERRTOL by a factor of 10 yields six moreDRD 144 -C decimal digits of accuracy at the expense of one orDRD 145 -C two more iterations of the duplication theorem. DRD 146 -C***LONG DESCRIPTION DRD 147 -C DRD 148 -C DRD Special Comments DRD 149 -C DRD 150 -C DRD 151 -C DRD 152 -C Check: DRD(X,Y,Z) + DRD(Y,Z,X) + DRD(Z,X,Y) DRD 153 -C = 3 / DSQRT(X * Y * Z), where X, Y, and Z are positive. DRD 154 -C DRD 155 -C DRD 156 -C On Input: DRD 157 -C DRD 158 -C X, Y, and Z are the variables in the integral DRD(X,Y,Z). DRD 159 -C DRD 160 -C DRD 161 -C On Output: DRD 162 -C DRD 163 -C DRD 164 -C X, Y, Z are unaltered. DRD 165 -C DRD 166 -C DRD 167 -C DRD 168 -C ******************************************************** DRD 169 -C DRD 170 -C WARNING: Changes in the program may improve speed at the DRD 171 -C expense of robustness. DRD 172 -C DRD 173 -C DRD 174 -C DRD 175 -C -------------------------------------------------------------------DRD 176 -C DRD 177 -C DRD 178 -C Special double precision functions via DRD and DRF DRD 179 -C DRD 180 -C DRD 181 -C Legendre form of ELLIPTIC INTEGRAL of 2nd kind DRD 182 -C DRD 183 -C ----------------------------------------- DRD 184 -C DRD 185 -C DRD 186 -C 2 2 2 DRD 187 -C E(PHI,K) = SIN(PHI) DRF(COS (PHI),1-K SIN (PHI),1) - DRD 188 -C DRD 189 -C 2 3 2 2 2 DRD 190 -C -(K/3) SIN (PHI) DRD(COS (PHI),1-K SIN (PHI),1) DRD 191 -C DRD 192 -C DRD 193 -C 2 2 2 DRD 194 -C E(K) = DRF(0,1-K ,1) - (K/3) DRD(0,1-K ,1) DRD 195 -C DRD 196 -C PI/2 2 2 1/2 DRD 197 -C = INT (1-K SIN (PHI) ) D PHI DRD 198 -C 0 DRD 199 -C DRD 200 -C Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind DRD 201 -C DRD 202 -C ----------------------------------------- DRD 203 -C DRD 204 -C 2 2 2 DRD 205 -C EL2(X,KC,A,B) = AX DRF(1,1+KC X ,1+X ) + DRD 206 -C DRD 207 -C 3 2 2 2 DRD 208 -C +(1/3)(B-A) X DRD(1,1+KC X ,1+X ) DRD 209 -C DRD 210 -C DRD 211 -C DRD 212 -C DRD 213 -C Legendre form of alternative ELLIPTIC INTEGRAL DRD 214 -C of 2nd kind DRD 215 -C DRD 216 -C ----------------------------------------- DRD 217 -C DRD 218 -C DRD 219 -C DRD 220 -C Q 2 2 2 -1/2 DRD 221 -C D(Q,K) = INT SIN P (1-K SIN P) DP DRD 222 -C 0 DRD 223 -C DRD 224 -C DRD 225 -C DRD 226 -C 3 2 2 2 DRD 227 -C D(Q,K) = (1/3) (SIN Q) DRD(COS Q,1-K SIN Q,1) DRD 228 -C DRD 229 -C DRD 230 -C DRD 231 -C DRD 232 -C Lemniscate constant B DRD 233 -C DRD 234 -C ----------------------------------------- DRD 235 -C DRD 236 -C DRD 237 -C DRD 238 -C DRD 239 -C 1 2 4 -1/2 DRD 240 -C B = INT S (1-S ) DS DRD 241 -C 0 DRD 242 -C DRD 243 -C DRD 244 -C B = (1/3) DRD (0,2,1) DRD 245 -C DRD 246 -C DRD 247 -C Heuman's LAMBDA function DRD 248 -C DRD 249 -C ----------------------------------------- DRD 250 -C DRD 251 -C DRD 252 -C DRD 253 -C (PI/2) LAMBDA0(A,B) = DRD 254 -C DRD 255 -C 2 2 DRD 256 -C = SIN(B) (DRF(0,COS (A),1)-(1/3) SIN (A) * DRD 257 -C DRD 258 -C 2 2 2 2 DRD 259 -C *DRD(0,COS (A),1)) DRF(COS (B),1-COS (A) SIN (B),1) DRD 260 -C DRD 261 -C 2 3 2 DRD 262 -C -(1/3) COS (A) SIN (B) DRF(0,COS (A),1) * DRD 263 -C DRD 264 -C 2 2 2 DRD 265 -C *DRD(COS (B),1-COS (A) SIN (B),1) DRD 266 -C DRD 267 -C DRD 268 -C DRD 269 -C Jacobi ZETA function DRD 270 -C DRD 271 -C ----------------------------------------- DRD 272 -C DRD 273 -C 2 2 2 2 DRD 274 -C Z(B,K) = (K/3) SIN(B) DRF(COS (B),1-K SIN (B),1) DRD 275 -C DRD 276 -C DRD 277 -C 2 2 DRD 278 -C *DRD(0,1-K ,1)/DRF(0,1-K ,1) DRD 279 -C DRD 280 -C 2 3 2 2 2 DRD 281 -C -(K /3) SIN (B) DRD(COS (B),1-K SIN (B),1) DRD 282 -C DRD 283 -C DRD 284 -C --------------------------------------------------------------------- DRD 285 -C Subroutines or functions needed DRD 286 -C - XERROR DRD 287 -C - D1MACH DRD 288 -C - FORTRAN DABS, DMAX1,DMIN1, DSQRT DRD 289 -C***REFERENCES CARLSON, B.C. AND NOTIS,E .M. DRD 290 -C ALGORITHMS FOR INCOMPLETE ELLIPTIC INTEGRALS DRD 291 -C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE,VOL.7,NO.3, DRD 292 -C SEPT, 1981, PAGES 398-403 DRD 293 -C CARLSON, B.C. DRD 294 -C COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION DRD 295 -C NUMER. MATH. 33, (1979), 1-16 DRD 296 -C CARLSON, B.C. DRD 297 -C ELLIPTIC INTEGRALS OF THE FIRST KIND DRD 298 -C SIAM J. MATH. ANAL. 8 (1977), 231-242 DRD 299 -C***ROUTINES CALLED D1MACH,XERROR DRD 300 -C***END PROLOGUE DRD DRD 301 - CHARACTER*176 MESSG DRD 302 - INTEGER IER,ITODO DRD 303 - DOUBLE PRECISION LOLIM, UPLIM, EPSLON, ERRTOL, D1MACH DRD 304 - DOUBLE PRECISION C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA DRD 305 - DOUBLE PRECISION MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV DRD 306 - DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, DRD 307 - * ZNROOT DRD 308 -C DRD 309 -C DRD 310 - SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,C4,ITODO DRD 311 -C DRD 312 -C DRD 313 - DATA ITODO/1/ DRD 314 -C DRD 315 -C DRD 316 -C DRD 317 -C***FIRST EXECUTABLE STATEMENT DRD DRD 318 - IF(ITODO.EQ.1)THEN DRD 319 -C DRD 320 -C DRD 321 -cryne ERRTOL=(D1MACH(3)/3.0D0)**(1.0D0/6.0D0) DRD 322 -c errtol=1.d-3 - errtol=1.d-4 -c errtol=1.d-5 -C DRD 323 -C DRD 324 -cryne LOLIM = 2.0D0/(D1MACH(2))**(2.0D0/3.0D0) DRD 325 - lolim=1.d-25 -C DRD 326 -cryne UPLIM = D1MACH(1)**(1.0E0/3.0E0) DRD 327 - uplim=1.d25 -cryne UPLIM = (0.10D0*ERRTOL)**(1.0E0/3.0E0)/UPLIM DRD 328 -cryne UPLIM = UPLIM**2.0D0 DRD 329 -C DRD 330 -C DRD 331 - C1 = 3.0D0/14.0D0 DRD 332 - C2 = 1.0D0/6.0D0 DRD 333 - C3 = 9.0D0/22.0D0 DRD 334 - C4 = 3.0D0/26.0D0 DRD 335 -C DRD 336 -C DRD 337 - ITODO=0 DRD 338 -C DRD 339 - END IF DRD 340 -C DRD 341 -C DRD 342 -C DRD 343 -C DRD 344 -C CALL ERROR HANDLER IF NECESSARY. DRD 345 -C DRD 346 -C DRD 347 - 5 DRD=0.0D0 DRD 348 - IF( DMIN1(X,Y).LT.0.0D0) THEN DRD 349 - IER=1 DRD 350 - WRITE (MESSG,6) X, Y DRD 351 - 6 FORMAT('DRD - ERROR: DMIN1(X,Y).LT.0.0D0 WHERE X=', 1PD20.12, DRD 352 - * ' AND Y=', D20.12) DRD 353 -cryne CALL XERROR(MESSG(1:100),100,1,1) DRD 354 - write(6,'(a100)')messg(1:100) - RETURN DRD 355 - ENDIF DRD 356 - IF (DMAX1(X,Y,Z).GT.UPLIM) THEN DRD 357 - IER=3 DRD 358 - MESSG(1:43) = 'DRD - ERROR: DMAX1(X,Y,Z).GT.UPLIM WHERE X=' DRD 359 - WRITE (MESSG(44:176),7) X, Y, Z, UPLIM DRD 360 - 7 FORMAT( 1PD20.12, DRD 361 - * 15X, 'Y=', D20.12, ' Z=', D20.12, ' AND', 23X, 'UPLIM=', D20.12)DRD 362 -cryne CALL XERROR(MESSG(1:176),176,3,1) DRD 363 - write(6,'(a176)')messg(1:176) - RETURN DRD 364 - ENDIF DRD 365 - IF (DMIN1(X+Y,Z).LT.LOLIM) THEN DRD 366 - IER=2 DRD 367 - MESSG(1:43)='DRD - ERROR: DMIN1(X+Y,Z).LT.LOLIM WHERE X=' DRD 368 - WRITE (MESSG(44:176),8) X, Y, Z, LOLIM DRD 369 - 8 FORMAT( 1PD20.12, DRD 370 - * 15X, 'Y=', D20.12, ' Z=', D20.12, ' AND', 23X, 'LOLIM=', D20.12)DRD 371 -cryne CALL XERROR(MESSG(1:176),176,2,1) DRD 372 - write(6,'(a176)')messg(1:176) - RETURN DRD 373 - ENDIF DRD 374 -C DRD 375 -C DRD 376 -C DRD 377 -C DRD 378 - 20 IER = 0 DRD 379 - XN = X DRD 380 - YN = Y DRD 381 - ZN = Z DRD 382 - SIGMA = 0.0D0 DRD 383 - POWER4 = 1.0D0 DRD 384 -C DRD 385 -C DRD 386 -C DRD 387 - 30 MU = (XN+YN+3.0D0*ZN)*0.20D0 DRD 388 - XNDEV = (MU-XN)/MU DRD 389 - YNDEV = (MU-YN)/MU DRD 390 - ZNDEV = (MU-ZN)/MU DRD 391 - EPSLON = DMAX1(DABS(XNDEV),DABS(YNDEV),DABS(ZNDEV)) DRD 392 - IF (EPSLON.LT.ERRTOL) GO TO 40 DRD 393 - XNROOT = DSQRT(XN) DRD 394 - YNROOT = DSQRT(YN) DRD 395 - ZNROOT = DSQRT(ZN) DRD 396 - LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT DRD 397 - SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA)) DRD 398 - POWER4 = POWER4*0.250D0 DRD 399 - XN = (XN+LAMDA)*0.250D0 DRD 400 - YN = (YN+LAMDA)*0.250D0 DRD 401 - ZN = (ZN+LAMDA)*0.250D0 DRD 402 - GO TO 30 DRD 403 -C DRD 404 -C DRD 405 -C DRD 406 -C DRD 407 - 40 EA = XNDEV*YNDEV DRD 408 - EB = ZNDEV*ZNDEV DRD 409 - EC = EA - EB DRD 410 - ED = EA - 6.0D0*EB DRD 411 - EF = ED + EC + EC DRD 412 - S1 = ED*(-C1+0.250D0*C3*ED-1.50D0*C4*ZNDEV*EF) DRD 413 - S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA)) DRD 414 - DRD = 3.0D0*SIGMA + POWER4*(1.0D0+S1+S2)/(MU*DSQRT(MU)) DRD 415 -C DRD 416 - 50 RETURN DRD 417 -C DRD 418 -C DRD 419 -C DRD 420 -C DRD 421 - END DRD 422 diff --git a/OpticsJan2020/MLI_light_optics/Src/euclid.f b/OpticsJan2020/MLI_light_optics/Src/euclid.f deleted file mode 100644 index f3c5869..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/euclid.f +++ /dev/null @@ -1,114 +0,0 @@ - subroutine rotv(a,theta,vin,vout) -c -c This subroutine rotates a vector by an angle theta about the axis a. -c - include 'impli.inc' -c - dimension aj1(3,3), aj2(3,3), aj3(3,3) - dimension adotj(3,3), adotj2(3,3), aiden(3,3) - dimension rotm(3,3) - dimension a(3), vin(3), vint(3), vout(3) -c -c set up j and identity matrices and store vin -c - do i=1,3 - do j=1,3 - aj1(i,j)=0.d0 - aj2(i,j)=0.d0 - aj3(i,j)=0.d0 - aiden(i,j)=0.d0 - rotm(i,j)=0.d0 - end do - end do - aj1(2,3)=-1.d0 - aj1(3,2)=1.d0 - aj2(1,3)=1.d0 - aj2(3,1)=-1.d0 - aj3(1,2)=-1.d0 - aj3(2,1)=1.d0 - do i=1,3 - aiden(i,i)=1.d0 - vint(i)=vin(i) - end do -c -c compute adotj -c - do i=1,3 - do j=1,3 - adotj(i,j)=a(1)*aj1(i,j)+a(2)*aj2(i,j)+a(3)*aj3(i,j) - end do - end do -c -c compute adotj2 -c - do i=1,3 - do j=1,3 - adotj2(i,j)=0.d0 - do k=1,3 - adotj2(i,j)=adotj2(i,j)+adotj(i,k)*adotj(k,j) - end do - end do - end do -c -c compute rotation matrix -c - do i=1,3 - do j=1,3 - rotm(i,j)=aiden(i,j)+(dsin(theta))*adotj(i,j) - rotm(i,j)=rotm(i,j)+(1.d0-dcos(theta))*adotj2(i,j) - end do - end do -c -c comput final result -c - do i=1,3 - vout(i)=0.d0 - do j=1,3 - vout(i)=vout(i)+rotm(i,j)*vint(j) - end do - end do -c - return - end -c -*************************************************************************** -c - subroutine erotv(phi,theta,psi,vin,vout) -c -c This subroutine rotates a vector by a rotation described by euler angles. -c - include 'impli.inc' -c -c - dimension vin(3), vout(3), vtemp1(3), vtemp2(3) - dimension ex(3), ey(3), ez(3) -c -c set up unit vectors -c - do i=1,3 - ex(i)=0.d0 - ey(i)=0.d0 - ez(i)=0.d0 - end do - ex(1)=1.d0 - ey(2)=1.d0 - ez(3)=1.d0 -c -c carry out rotations -c - call rotv(ez,psi,vin,vtemp1) - call rotv(ey,theta,vtemp1,vtemp2) - call rotv(ez,phi,vtemp2,vout) -c - return - end -c -****************************************************** -c - subroutine wrtdo -c -c This subroutine writes out points on the design orbit -c - return - end -c diff --git a/OpticsJan2020/MLI_light_optics/Src/fftessl.f b/OpticsJan2020/MLI_light_optics/Src/fftessl.f deleted file mode 100644 index b30d98e..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/fftessl.f +++ /dev/null @@ -1,65 +0,0 @@ -! for calling ESSL using new FFT*HPF interface - - -! implements FFTs using ESSL instead of Ryne's Num.Recipes versions - - subroutine fft3dhpf (N1, N2, N3, KSign, Scale, ICpy, NAdj, x, x3) - implicit none -!Constants -!Args - integer N1, N2, N3, KSign, ICpy, NAdj - real*8 Scale - complex*16 x,x3 - dimension x(N1,N2,N3) - dimension x3(N3,N2,N1) -!Locals - complex*16 aux !just a placeholder, not really used - integer i,j,k - -!ValidateArgs - - if( KSign .EQ. 0 )then - write(6,*) 'ERROR: FFT3DHPF/ESSL with zero ksign' - stop 'FFT3err1' - endif - if( NAdj .NE. 0 )then - write(6,*) 'ERROR: FFT3DHPF/ESSL with non-zero nadj' - stop 'FFT3err2' - endif - if( ICpy .NE. 0 )then - write(6,*) 'ERROR: FFT3DHPF/ESSL with non-zero icpy' - stop 'FFT3err3' - endif - - if( Scale .EQ. 0.0 )then - write(6,*) 'ERROR: FFT3DHPF/ESSL with zero scale' - stop 'FFT3err4' - endif - -!Execute - ! the ESSL routine doesn't leave the output transposed, so - ! do the FFT in-place and transpose into the output variable. - - call DCFT3( x, N1,N1*N2, x, N1,N1*N2, N1,N2,N3 - & ,KSign,Scale ,aux,0 ) - - do k = 1 ,N3 - do j = 1,N2 - do i = 1,N1 - x3(k,j,i) = x(i,j,k) - enddo - enddo - enddo - -!Done - - return - end - -!---------------------------------------------------------------- - - subroutine fft2dhpf() - stop 'FFT2Derr' - return - end - diff --git a/OpticsJan2020/MLI_light_optics/Src/fftpkgq.f b/OpticsJan2020/MLI_light_optics/Src/fftpkgq.f deleted file mode 100755 index f154042..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/fftpkgq.f +++ /dev/null @@ -1,372 +0,0 @@ -! 3D FFT package - subroutine fft3dhpf (n1, n2, n3, ksign, scale, icpy, nadj, x, x3) - use parallel !for idproc - use ml_timer - implicit none - integer n1, n2, n3, ksign, icpy, nadj, icpy2d, i,j,k - real*8 scale,scale2d,ezero - integer klen,k1,kn1,kn3,ierror - complex*16 x,x2,x3 - complex*16 x2t,x3t - dimension x(n1,n2,n3) - dimension x3(n3,n2,n1) - dimension x3t(n3,n2,n1) - dimension x2(n2,n1,n3) - real*8 alnum,rem - dimension x2t(n2,n1,n3) - - call increment_timer('fft',0) - -!!XXX Feb 2003 -- moved here from afro.f, because it applies only to this version of FFT -!---Jan 27, 2003 -! make sure that these are powers of 2 - alnum=log(1.d0*n1)/log(2.d0) - rem=abs(alnum-nint(alnum)) - if(rem.gt.1.d-8)then - if(idproc.eq.0)then - write(6,*)'(fft3dhpf) error: n1 has an input value of ',n1 - write(6,*)' but must be a power of 2. Halting.' - endif - call myexit - endif - alnum=log(1.d0*n2)/log(2.d0) - rem=abs(alnum-nint(alnum)) - if(rem.gt.1.d-8)then - if(idproc.eq.0)then - write(6,*)'(fft3dhpf) error: n2 has an input value of ',n2 - write(6,*)' but must be a power of 2. Halting.' - endif - call myexit - endif - if(n3.ne.0)then - alnum=log(1.d0*n3)/log(2.d0) - rem=abs(alnum-nint(alnum)) - if(rem.gt.1.d-8)then - if(idproc.eq.0)then - write(6,*)'(fft3dhpf) error: n3 has an input value of ',n3 - write(6,*)' but must be a power of 2. Halting.' - endif - call myexit - endif - endif - -!--- -! write(6,*)'starting fft' -! FFTs along all dimensions except the last: -! - scale2d=1.0 - icpy2d=0 -! - klen=n3/nvp -!logic goes here to decide whether to do serial or parallel fft. -!for example: -! if(klen.le.1000000)then !always do serial -! if(klen.le.256)then !do parallel if every proc has a lot of work - if(klen.eq.0)then !do parallel if every proc has some work to do - call increment_timer('timer1',0) - do k=1,n3 - call fft2dhpf(n1,n2,ksign,nadj,scale2d,icpy2d, & - & x(1,1,k),x2(1,1,k)) - enddo - call increment_timer('timer1',1) - else -! note to myself: check to see if this will work if n3, nvp are not -! both powers of 2 - k1=idproc*klen+1 - kn3=k1+klen-1 - call increment_timer('timer1',0) - do k=k1,kn3 - call fft2dhpf(n1,n2,ksign,nadj,scale2d,icpy2d, & - & x(1,1,k),x2t(1,1,k)) - enddo - call increment_timer('timer1',1) -! - call increment_timer('timer2',0) - call MPI_ALLGATHER(x2t(1,1,k1),n1*n2*klen,mcplx,x2(1,1,1), & - & n1*n2*klen,mcplx,lworld,ierror) - call increment_timer('timer2',1) - endif -! -! The 3D and higher, the previous call transposes the subarray of all but -! the last index; Now move the last index from the right-most position to -! the left-most position in preparation for final, in-place transformation: -! In 2D this is simply a tranpose of the entire array. -! write(6,*)'starting triple do to move x2 into x3' - call increment_timer('transp',0) -!2D x3=transpose(x) - do i = 1, n1 - do k = 1, n3 - do j = 1, n2 - x3(k,j,i) = x2(j,i,k) - end do - end do - end do -! x3(1:n3,1:n2,1:n1)=x2(1:n2,1:n1,1:n3) -! write(6,*)'finished triple-do' - call increment_timer('transp',1) -! -! Final transform along the left-most direction -! - klen=n1/nvp - if(klen.eq.0)then - call increment_timer('timer3',0) - call mfft_local13d(n3,n2,n1,ksign,nadj,1,n1,x3) - call increment_timer('timer3',1) - else - k1=idproc*klen+1 - kn1=k1+klen-1 - call increment_timer('timer3',0) - call mfft_local13d (n3,n2,n1,ksign,nadj,k1,kn1,x3) - call increment_timer('timer3',1) - x3t(:,:,k1:kn1)=x3(:,:,k1:kn1) - call increment_timer('timer4',0) - call MPI_ALLGATHER(x3t(1,1,k1),n3*n2*klen,mcplx,x3(1,1,1), & - & n3*n2*klen,mcplx,lworld,ierror) - call increment_timer('timer4',1) - endif -! -! -! - if(scale.ne.1.0)then - do k=1,n1 - do j=1,n2 - do i=1,n3 -! x3(:,:,:)=x3(:,:,:)*scale - x3(i,j,k)=x3(i,j,k)*scale - enddo - enddo - enddo - endif -! if icpy.eq.1, store the final result back in x -! if icpy.ne.1, store with zeros (ensure users know it's filled with junk) - if(icpy.eq.1)then - write(6,*)'error: should not get here! (icpy=1)' -!2D x=transpose(x3) - do k = 1, n3 - do j = 1, n2 - do i = 1, n1 - x(i,j,k) = x3(k,j,i) - end do - end do - end do - else - ezero=0. - do k = 1, n3 - do j = 1, n2 - do i = 1, n1 - x(i,j,k) = cmplx(ezero,ezero) - end do - end do - end do -! write(6,*)'...finished fft (without copying)' - endif - call increment_timer('fft',1) - return - end !subroutine fft3dhpf - -!======================================================================= -! -! HPF_Local subroutine to perform multiple FFTs on the inner dimension -! - subroutine mfft_local13d(n1,n2,n3,ksign,nadj,k1,kn3,x) - implicit none - integer n1,n2,n3,ksign,nadj,i,j,k,n3top,n2top - integer k1,kn3 - complex*16 x,tempi - dimension x(n1,n2,n3),tempi(n1) -! -! Perform multiple FFTs without scaling: - n3top=n3 - n2top=n2 -c this works for open bc's because it is not necessary to do the -c inverse transform over the complete (octupled) domain. -c Of the N^2 1D fft's performed over the ixj plane, only 1/4 are -c in the physical domain. However, for the periodic case, the -c full z-dimension has to be covered. At the time of the inverse -c transformation (when this routine is called with ksign=-1), -c the n2 and n3 dimensions are in fact y and z, respectively. -c So the full fft is needed along the third dimension in that case. - if(ksign.eq.-1 .and. nadj.eq.0)then -!dec28 n3top=n3/2 -!dec28 n2top=n2/2 - endif - if(ksign.eq.-1 .and. nadj.eq.1)then -! write(12,*)'8-29-01:testing needed for this part of fftpkgq.f' -!dec28 n2top=n2/2 - endif -cryne Nov 9, 2003 do k=1,n3top - do k=k1,kn3 - do j=1,n2top -cryne tempi(1:n1)=x(1:n1,j,k) -cryne call ccfftnr(tempi,n1,ksign) -cryne x(1:n1,j,k) = tempi(1:n1) - call ccfftnr(x(1,j,k),n1,ksign) - end do - end do - return - end -! end subroutine mfft_local13d -!======================================================================= -!======================================================================= -! 2D FFT package - subroutine fft2dhpf (n1,n2,ksign,nadj,scale,icpy,x,x3) - use parallel, only : idproc - implicit none - integer n1, n2, ksign, nadj, icpy, i,j,ihalf,itop - real*8 scale,ezero - complex*16 x,x3 - dimension x(n1,n2),x3(n2,n1) -! -! FFTs along all dimensions except the last: -! Note: In 3D and higher, this is accomplished with a routine mfft_local2 -! But in 2D this isn't necessary--just used mfft_local1 -! - ihalf=0 - call mfft_local1 (ksign,x,n1,n2,ihalf) -! -! The 3D and higher, the previous call transposes the subarray of all but -! the last index; Now move the last index from the right-most position to -! the left-most position in preparation for final, in-place transformation: -! In 2D this is simply a tranpose of the entire array. -cryne x3=transpose(x) - itop=n1 -!dec28 if(ksign.eq.-1.and.nadj.eq.0)itop=n1/2 - do i=1,itop - do j=1,n2 - x3(j,i)=x(i,j) - enddo - enddo -! -! Final transform along the left-most direction -! - if(ksign.eq.-1.and.nadj.eq.0)ihalf=1 -! if(ihalf.eq.1)write(6,*)'ihalf=1' - call mfft_local1 (ksign,x3,n2,n1,ihalf) -! -! if(scale.ne.1.0)x3=x3*scale - if(scale.ne.1.0)then - do j=1,n1 - do i=1,n2 - x3(i,j)=x3(i,j)*scale - enddo - enddo - endif -! if icpy.eq.1, store the final result back in x -! if icpy.ne.1, store with zeros (ensure users know it's filled with junk) - if(icpy.eq.1)then - write(6,*)'error:should not get here!(icpy.eq.1 in fft2dhpf)' -! x=transpose(x3) - do j=1,n2 - do i=1,n1 - x(i,j)=x3(j,i) - enddo - enddo - endif -! if(icpy.ne.1)x=(0.,0.) - ezero=0. - if(icpy.ne.1)then - do j=1,n2 - do i=1,n1 - x(i,j)=cmplx(ezero,ezero) - enddo - enddo - endif - return - end !subroutine fft2dhpf -! -!======================================================================= -! -! HPF_Local subroutine to perform multiple FFTs on the inner dimension -! - subroutine mfft_local1 (ksign,x,m1,m2,ihalf) - implicit none - integer ksign,j,m1,m2,m2top,ihalf - complex*16 x,tempi - dimension x(m1,m2),tempi(m1) -! complex tempo,table,work -! dimension tempo(m1),table(m1),work(2*m1) -! -! Initialize: -!!!!! call ccfft (0,m1,1.0,tempi,tempo,table,work,0) -! Perform multiple FFTs without scaling: - m2top=m2 -!dec28 if(ihalf.eq.1)m2top=m2/2 - do j = 1, m2top -c tempi = x(:,j) -!!!!! call ccfft(ksign,m1,1.0,tempi,tempo,table,work,0) -!!!!! x(:,j) = tempo -cryne call ccfftnr(tempi,m1,ksign) - call ccfftnr(x(1,j),m1,ksign) -c x(:,j) = tempi - end do - return - end -! end subroutine mfft_local1 -! - subroutine ccfftnr(cdata,nn,isign) - use ml_timer - implicit real*8(a-h,o-z) - complex*16 cdata - dimension cdata(nn),data(2*nn) - call increment_timer('ccfftnr',0) - do i=1,nn - data(2*i-1)=real(cdata(i)) - data(2*i) =aimag(cdata(i)) - enddo -! bit reversal: - n=2*nn - j=1 - do i=1,n,2 - if(j.gt.i)then - tempr=data(j) - tempi=data(j+1) - data(j)=data(i) - data(j+1)=data(i+1) - data(i)=tempr - data(i+1)=tempi - endif - m=n/2 - 1 if((m.ge.2).and.(j.gt.m))then - j=j-m - m=m/2 - goto 1 - endif - j=j+m - enddo -! Danielson-Lanczos: - twopi=4.0*asin(1.0d0) - mmax=2 - 2 if(n.gt.mmax)then - istep=2*mmax - theta=twopi/(isign*mmax) - wpr=-2.*sin(0.5*theta)**2 - wpi=sin(theta) - wr=1.0 - wi=0.0 - do m=1,mmax,2 - do i=m,n,istep - j=i+mmax - tempr=wr*data(j)-wi*data(j+1) - tempi=wr*data(j+1)+wi*data(j) - data(j)=data(i)-tempr - data(j+1)=data(i+1)-tempi - data(i)=data(i)+tempr - data(i+1)=data(i+1)+tempi - enddo - wtemp=wr - wr=wr*wpr-wi*wpi+wr - wi=wi*wpr+wtemp*wpi+wi - enddo - mmax=istep - goto 2 - endif -c ezero=0. -c eunit=1. - do i=1,nn - cdata(i)=data(2*i-1)+(0.,1.)*data(2*i) -c cdata(i)=data(2*i-1)+cmplx(ezero,eunit)*data(2*i) - enddo - call increment_timer('ccfftnr',1) - return - end -!======================================================================= diff --git a/OpticsJan2020/MLI_light_optics/Src/fftw_dummy.f b/OpticsJan2020/MLI_light_optics/Src/fftw_dummy.f deleted file mode 100644 index 48ce210..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/fftw_dummy.f +++ /dev/null @@ -1,17 +0,0 @@ - subroutine rfftw_f77_create_plan() - write(6,*) 'error: rfftw_f77_create_plan: FFTW is not included ' - & ,'in this version.' - stop 'NOFFTW' - end - - subroutine rfftw_f77_one() - write(6,*) 'error: rfftw_f77_one: FFTW is not included ' - & ,'in this version.' - stop 'NOFFTW' - end - - subroutine rfftw_f77_destroy_plan() - write(6,*) 'error: rfftw_f77_destroy_plan: FFTW is not included ' - & ,'in this version.' - stop 'NOFFTW' - end diff --git a/OpticsJan2020/MLI_light_optics/Src/fparser.f90 b/OpticsJan2020/MLI_light_optics/Src/fparser.f90 deleted file mode 100644 index 150dd60..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/fparser.f90 +++ /dev/null @@ -1,737 +0,0 @@ -MODULE fparser - !------- -------- --------- --------- --------- --------- --------- --------- ------- - ! Fortran 90 function parser v1.0 - !------- -------- --------- --------- --------- --------- --------- --------- ------- - ! - ! This public domain function parser module is intended for applications - ! where a set of mathematical expressions is specified at runtime and is - ! then evaluated for a large number of variable values. This is done by - ! compiling the set of function strings into byte code, which is interpreted - ! very efficiently for the various variable values. - ! - ! The source code is available from: - ! http://www.its.uni-karlsruhe.de/~schmehl/opensource/fparser-v1.0.tar.gz - ! - ! Please send comments, corrections or questions to the author: - ! Roland Schmehl - ! - !------- -------- --------- --------- --------- --------- --------- --------- ------- - ! The function parser concept is based on a C++ class library written by Warp - ! available from: - ! http://www.students.tut.fi/~warp/FunctionParser/fparser.zip - !------- -------- --------- --------- --------- --------- --------- --------- ------- - USE parameters, ONLY: rn,is ! Import KIND parameters - IMPLICIT NONE - !------- -------- --------- --------- --------- --------- --------- --------- ------- - PUBLIC :: initf, & ! Initialize function parser for n functions - parsef, & ! Parse single function string - evalf, & ! Evaluate single function - EvalErrMsg ! Error message (Use only when EvalErrType>0) - INTEGER, PUBLIC :: EvalErrType ! =0: no error occured, >0: evaluation error - !------- -------- --------- --------- --------- --------- --------- --------- ------- - PRIVATE - SAVE - INTEGER(is), PARAMETER :: cImmed = 1, & - cNeg = 2, & - cAdd = 3, & - cSub = 4, & - cMul = 5, & - cDiv = 6, & - cPow = 7, & - cAbs = 8, & - cExp = 9, & - cLog10 = 10, & - cLog = 11, & - cSqrt = 12, & - cSinh = 13, & - cCosh = 14, & - cTanh = 15, & - cSin = 16, & - cCos = 17, & - cTan = 18, & - cAsin = 19, & - cAcos = 20, & - cAtan = 21, & - VarBegin = 22 - CHARACTER (LEN=1), DIMENSION(cAdd:cPow), PARAMETER :: Ops = (/ '+', & - '-', & - '*', & - '/', & - '^' /) - CHARACTER (LEN=5), DIMENSION(cAbs:cAtan), PARAMETER :: Funcs = (/ 'abs ', & - 'exp ', & - 'log10', & - 'log ', & - 'sqrt ', & - 'sinh ', & - 'cosh ', & - 'tanh ', & - 'sin ', & - 'cos ', & - 'tan ', & - 'asin ', & - 'acos ', & - 'atan ' /) - TYPE tComp - INTEGER(is), DIMENSION(:), POINTER :: ByteCode - INTEGER :: ByteCodeSize - REAL(rn), DIMENSION(:), POINTER :: Immed - INTEGER :: ImmedSize - REAL(rn), DIMENSION(:), POINTER :: Stack - INTEGER :: StackSize, & - StackPtr - END TYPE tComp - TYPE (tComp), DIMENSION(:), POINTER :: Comp ! Bytecode - INTEGER, DIMENSION(:), ALLOCATABLE :: ipos ! Associates function strings - ! -CONTAINS - ! - SUBROUTINE initf (n) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Initialize function parser for n functions - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - INTEGER, INTENT(in) :: n ! Number of functions - INTEGER :: i - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ALLOCATE (Comp(n)) - DO i=1,n - NULLIFY (Comp(i)%ByteCode,Comp(i)%Immed,Comp(i)%Stack) - END DO - END SUBROUTINE initf - ! - SUBROUTINE parsef (i, FuncStr, Var) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Parse ith function string FuncStr and compile it into bytecode - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - INTEGER, INTENT(in) :: i ! Function identifier - CHARACTER (LEN=*), INTENT(in) :: FuncStr ! Function string - CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names - CHARACTER (LEN=LEN(FuncStr)) :: Func ! Function string, local use - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IF (i < 1 .OR. i > SIZE(Comp)) THEN - WRITE(*,*) '*** Parser error: Function number ',i,' out of range' - STOP - END IF - ALLOCATE (ipos(LEN_TRIM(FuncStr))) ! Char. positions in orig. string - Func = FuncStr ! Local copy of function string - CALL Replace ('**','^ ',Func) ! Exponent into 1-Char. format - CALL RemoveSpaces (Func) ! Condense function string - CALL CheckSyntax (Func,FuncStr,Var) - DEALLOCATE (ipos) - CALL Compile (i,Func,Var) ! Compile into bytecode - END SUBROUTINE parsef - ! - FUNCTION evalf (i, Val) RESULT (res) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Evaluate bytecode of ith function for the values passed in array Val(:) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - INTEGER, INTENT(in) :: i ! Function identifier - REAL(rn), DIMENSION(:), INTENT(in) :: Val ! Variable values - REAL(rn) :: res ! Result - INTEGER :: IP, & ! Instruction pointer - DP, & ! Data pointer - SP ! Stack pointer - REAL(rn), PARAMETER :: zero = 0._rn - !----- -------- --------- --------- --------- --------- --------- --------- ------- - DP = 1 - SP = 0 - DO IP=1,Comp(i)%ByteCodeSize - SELECT CASE (Comp(i)%ByteCode(IP)) - - CASE (cImmed); SP=SP+1; Comp(i)%Stack(SP)=Comp(i)%Immed(DP); DP=DP+1 - CASE (cNeg); Comp(i)%Stack(SP)=-Comp(i)%Stack(SP) - CASE (cAdd); Comp(i)%Stack(SP-1)=Comp(i)%Stack(SP-1)+Comp(i)%Stack(SP); SP=SP-1 - CASE (cSub); Comp(i)%Stack(SP-1)=Comp(i)%Stack(SP-1)-Comp(i)%Stack(SP); SP=SP-1 - CASE (cMul); Comp(i)%Stack(SP-1)=Comp(i)%Stack(SP-1)*Comp(i)%Stack(SP); SP=SP-1 - CASE (cDiv); IF (Comp(i)%Stack(SP)==0._rn) THEN; EvalErrType=1; res=zero; RETURN; ENDIF - Comp(i)%Stack(SP-1)=Comp(i)%Stack(SP-1)/Comp(i)%Stack(SP); SP=SP-1 - CASE (cPow); Comp(i)%Stack(SP-1)=Comp(i)%Stack(SP-1)**Comp(i)%Stack(SP); SP=SP-1 - CASE (cAbs); Comp(i)%Stack(SP)=ABS(Comp(i)%Stack(SP)) - CASE (cExp); Comp(i)%Stack(SP)=EXP(Comp(i)%Stack(SP)) - CASE (cLog10); IF (Comp(i)%Stack(SP)<=0._rn) THEN; EvalErrType=3; res=zero; RETURN; ENDIF - Comp(i)%Stack(SP)=LOG10(Comp(i)%Stack(SP)) - CASE (cLog); IF (Comp(i)%Stack(SP)<=0._rn) THEN; EvalErrType=3; res=zero; RETURN; ENDIF - Comp(i)%Stack(SP)=LOG(Comp(i)%Stack(SP)) - CASE (cSqrt); IF (Comp(i)%Stack(SP)<0._rn) THEN; EvalErrType=3; res=zero; RETURN; ENDIF - Comp(i)%Stack(SP)=SQRT(Comp(i)%Stack(SP)) - CASE (cSinh); Comp(i)%Stack(SP)=SINH(Comp(i)%Stack(SP)) - CASE (cCosh); Comp(i)%Stack(SP)=COSH(Comp(i)%Stack(SP)) - CASE (cTanh); Comp(i)%Stack(SP)=TANH(Comp(i)%Stack(SP)) - CASE (cSin); Comp(i)%Stack(SP)=SIN(Comp(i)%Stack(SP)) - CASE (cCos); Comp(i)%Stack(SP)=COS(Comp(i)%Stack(SP)) - CASE (cTan); Comp(i)%Stack(SP)=TAN(Comp(i)%Stack(SP)) - CASE (cAsin); IF ((Comp(i)%Stack(SP)<-1._rn).OR.(Comp(i)%Stack(SP)>1._rn)) THEN - EvalErrType=4; res=zero; RETURN; ENDIF - Comp(i)%Stack(SP)=ASIN(Comp(i)%Stack(SP)) - CASE (cAcos); IF ((Comp(i)%Stack(SP)<-1._rn).OR.(Comp(i)%Stack(SP)>1._rn)) THEN - EvalErrType=4; res=zero; RETURN; ENDIF - Comp(i)%Stack(SP)=ACOS(Comp(i)%Stack(SP)) - CASE (cAtan); Comp(i)%Stack(SP)=ATAN(Comp(i)%Stack(SP)) - CASE DEFAULT; SP=SP+1; Comp(i)%Stack(SP)=Val(Comp(i)%ByteCode(IP)-VarBegin+1) - END SELECT - END DO - EvalErrType = 0 - res = Comp(i)%Stack(1) - END FUNCTION evalf - ! - SUBROUTINE CheckSyntax (Func,FuncStr,Var) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Check syntax of function string, returns 0 if syntax is ok - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - CHARACTER (LEN=*), INTENT(in) :: Func ! Function string without spaces - CHARACTER (LEN=*), INTENT(in) :: FuncStr ! Original function string - CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names - INTEGER(is) :: n - CHARACTER (LEN=1) :: c - REAL(rn) :: r - LOGICAL :: err - INTEGER :: ParCnt, & ! Parenthesis counter - j,ib,in,lFunc - !----- -------- --------- --------- --------- --------- --------- --------- ------- - j = 1 - ParCnt = 0 - lFunc = LEN_TRIM(Func) - step: DO - IF (j > lFunc) CALL ParseErrMsg (j, FuncStr) - c = Func(j:j) - !-- -------- --------- --------- --------- --------- --------- --------- ------- - ! Check for valid operand (must appear) - !-- -------- --------- --------- --------- --------- --------- --------- ------- - IF (c == '-' .OR. c == '+') THEN ! Check for leading - or + - j = j+1 - IF (j > lFunc) CALL ParseErrMsg (j, FuncStr, 'Missing operand') - c = Func(j:j) - IF (ANY(c == Ops)) CALL ParseErrMsg (j, FuncStr, 'Multiple operators') - END IF - n = MathFunctionIndex (Func(j:)) - IF (n > 0) THEN ! Check for math function - j = j+LEN_TRIM(Funcs(n)) - IF (j > lFunc) CALL ParseErrMsg (j, FuncStr, 'Missing function argument') - c = Func(j:j) - IF (c /= '(') CALL ParseErrMsg (j, FuncStr, 'Missing opening parenthesis') - END IF - IF (c == '(') THEN ! Check for opening parenthesis - ParCnt = ParCnt+1 - j = j+1 - CYCLE step - END IF - IF (SCAN(c,'0123456789.') > 0) THEN ! Check for number - r = RealNum (Func(j:),ib,in,err) - IF (err) CALL ParseErrMsg (j, FuncStr, 'Invalid number format: '//Func(j+ib-1:j+in-2)) - j = j+in-1 - IF (j > lFunc) EXIT - c = Func(j:j) - ELSE ! Check for variable - n = VariableIndex (Func(j:),Var,ib,in) - IF (n == 0) CALL ParseErrMsg (j, FuncStr, 'Invalid element: '//Func(j+ib-1:j+in-2)) - j = j+in-1 - IF (j > lFunc) EXIT - c = Func(j:j) - END IF - DO WHILE (c == ')') ! Check for closing parenthesis - ParCnt = ParCnt-1 - IF (ParCnt < 0) CALL ParseErrMsg (j, FuncStr, 'Mismatched parenthesis') - IF (Func(j-1:j-1) == '(') CALL ParseErrMsg (j-1, FuncStr, 'Empty parentheses') - j = j+1 - IF (j > lFunc) EXIT - c = Func(j:j) - END DO - !-- -------- --------- --------- --------- --------- --------- --------- ------- - ! Now, we have a legal operand: A legal operator or end of string must follow - !-- -------- --------- --------- --------- --------- --------- --------- ------- - IF (j > lFunc) EXIT - IF (ANY(c == Ops)) THEN ! Check for multiple operators - IF (j+1 > lFunc) CALL ParseErrMsg (j, FuncStr) - IF (ANY(Func(j+1:j+1) == Ops)) CALL ParseErrMsg (j+1, FuncStr, 'Multiple operators') - ELSE ! Check for next operand - CALL ParseErrMsg (j, FuncStr, 'Missing operator') - END IF - !-- -------- --------- --------- --------- --------- --------- --------- ------- - ! Now, we have an operand and an operator: the next loop will check for another - ! operand (must appear) - !-- -------- --------- --------- --------- --------- --------- --------- ------- - j = j+1 - END DO step - IF (ParCnt > 0) CALL ParseErrMsg (j, FuncStr, 'Missing )') - END SUBROUTINE CheckSyntax - ! - FUNCTION EvalErrMsg () RESULT (msg) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Return error message - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - CHARACTER (LEN=*), DIMENSION(4), PARAMETER :: m = (/ 'Division by zero ', & - 'Argument of SQRT negative ', & - 'Argument of LOG negative ', & - 'Argument of ASIN or ACOS illegal' /) - CHARACTER (LEN=LEN(m(1))) :: msg - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IF (EvalErrType < 1 .OR. EvalErrType > SIZE(m)) THEN - msg = ' ' - ELSE - msg = m(EvalErrType) - ENDIF - END FUNCTION EvalErrMsg - ! - SUBROUTINE ParseErrMsg (j, FuncStr, Msg) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Print error message and terminate program - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - INTEGER, INTENT(in) :: j - CHARACTER (LEN=*), INTENT(in) :: FuncStr ! Original function string - CHARACTER (LEN=*), OPTIONAL, INTENT(in) :: Msg - INTEGER :: k - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IF (PRESENT(Msg)) THEN - WRITE(*,*) '*** Error in syntax of function string: '//Msg - ELSE - WRITE(*,*) '*** Error in syntax of function string:' - ENDIF - WRITE(*,*) - WRITE(*,'(A)') ' '//FuncStr - DO k=1,ipos(j) - WRITE(*,'(A)',ADVANCE='NO') ' ' ! Advance to the jth position - END DO - WRITE(*,'(A)') '?' - STOP - END SUBROUTINE ParseErrMsg - ! - FUNCTION OperatorIndex (c) RESULT (n) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Return operator index - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - CHARACTER (LEN=1), INTENT(in) :: c - INTEGER(is) :: n,j - !----- -------- --------- --------- --------- --------- --------- --------- ------- - n = 0 - DO j=cAdd,cPow - IF (c == Ops(j)) THEN - n = j - EXIT - END IF - END DO - END FUNCTION OperatorIndex - ! - FUNCTION MathFunctionIndex (str) RESULT (n) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Return index of math function beginnig at 1st position of string str - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - CHARACTER (LEN=*), INTENT(in) :: str - INTEGER(is) :: n,j - INTEGER :: k - CHARACTER (LEN=LEN(Funcs(cAbs))) :: fun - !----- -------- --------- --------- --------- --------- --------- --------- ------- - n = 0 - DO j=cAbs,cAtan ! Check all math functions - k = MIN(LEN_TRIM(Funcs(j)), LEN(str)) - CALL LowCase (str(1:k), fun) - IF (fun == Funcs(j)) THEN ! Compare lower case letters - n = j ! Found a matching function - EXIT - END IF - END DO - END FUNCTION MathFunctionIndex - ! - FUNCTION VariableIndex (str, Var, ibegin, inext) RESULT (n) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Return index of variable at begin of string str (returns 0 if no variable found) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - CHARACTER (LEN=*), INTENT(in) :: str ! String - CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names - INTEGER(is) :: n ! Index of variable - INTEGER, OPTIONAL, INTENT(out) :: ibegin, & ! Start position of variable name - inext ! Position of character after name - INTEGER :: j,ib,in,lstr - !----- -------- --------- --------- --------- --------- --------- --------- ------- - n = 0 - lstr = LEN_TRIM(str) - IF (lstr > 0) THEN - DO ib=1,lstr ! Search for first character in str - IF (str(ib:ib) /= ' ') EXIT ! When lstr>0 at least 1 char in str - END DO - DO in=ib,lstr ! Search for name terminators - IF (SCAN(str(in:in),'+-*/^) ') > 0) EXIT - END DO - DO j=1,SIZE(Var) - IF (str(ib:in-1) == Var(j)) THEN - n = j ! Variable name found - EXIT - END IF - END DO - END IF - IF (PRESENT(ibegin)) ibegin = ib - IF (PRESENT(inext)) inext = in - END FUNCTION VariableIndex - ! - SUBROUTINE RemoveSpaces (str) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Remove Spaces from string, remember positions of characters in old string - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - CHARACTER (LEN=*), INTENT(inout) :: str - INTEGER :: k,lstr - !----- -------- --------- --------- --------- --------- --------- --------- ------- - lstr = LEN_TRIM(str) - ipos = (/ (k,k=1,lstr) /) - k = 1 - DO WHILE (str(k:lstr) /= ' ') - IF (str(k:k) == ' ') THEN - str(k:lstr) = str(k+1:lstr)//' ' ! Move 1 character to left - ipos(k:lstr) = (/ ipos(k+1:lstr), 0 /) ! Move 1 element to left - k = k-1 - END IF - k = k+1 - END DO - END SUBROUTINE RemoveSpaces - ! - SUBROUTINE Replace (ca,cb,str) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Replace ALL appearances of character set ca in string str by character set cb - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - CHARACTER (LEN=*), INTENT(in) :: ca - CHARACTER (LEN=LEN(ca)), INTENT(in) :: cb ! LEN(ca) must be LEN(cb) - CHARACTER (LEN=*), INTENT(inout) :: str - INTEGER :: j,lca - !----- -------- --------- --------- --------- --------- --------- --------- ------- - lca = LEN(ca) - DO j=1,LEN_TRIM(str)-lca+1 - IF (str(j:j+lca-1) == ca) str(j:j+lca-1) = cb - END DO - END SUBROUTINE Replace - ! - SUBROUTINE Compile (i, F, Var) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Compile i-th function string F into bytecode - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - INTEGER, INTENT(in) :: i ! Function identifier - CHARACTER (LEN=*), INTENT(in) :: F ! Function string - CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names - INTEGER :: istat - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IF (ASSOCIATED(Comp(i)%ByteCode)) DEALLOCATE ( Comp(i)%ByteCode, & - Comp(i)%Immed, & - Comp(i)%Stack ) - Comp(i)%ByteCodeSize = 0 - Comp(i)%ImmedSize = 0 - Comp(i)%StackSize = 0 - Comp(i)%StackPtr = 0 - CALL CompileSubstr (i,F,1,LEN_TRIM(F),Var) ! Compile string to determine size - ALLOCATE ( Comp(i)%ByteCode(Comp(i)%ByteCodeSize), & - Comp(i)%Immed(Comp(i)%ImmedSize), & - Comp(i)%Stack(Comp(i)%StackSize), & - STAT = istat ) - IF (istat /= 0) THEN - WRITE(*,*) '*** Parser error: Memmory allocation for byte code failed' - STOP - ELSE - Comp(i)%ByteCodeSize = 0 - Comp(i)%ImmedSize = 0 - Comp(i)%StackSize = 0 - Comp(i)%StackPtr = 0 - CALL CompileSubstr (i,F,1,LEN_TRIM(F),Var) ! Compile string into bytecode - END IF - ! - END SUBROUTINE Compile - ! - SUBROUTINE AddCompiledByte (i, b) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Add compiled byte to bytecode - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - INTEGER, INTENT(in) :: i ! Function identifier - INTEGER(is), INTENT(in) :: b ! Value of byte to be added - !----- -------- --------- --------- --------- --------- --------- --------- ------- - Comp(i)%ByteCodeSize = Comp(i)%ByteCodeSize + 1 - IF (ASSOCIATED(Comp(i)%ByteCode)) Comp(i)%ByteCode(Comp(i)%ByteCodeSize) = b - END SUBROUTINE AddCompiledByte - ! - FUNCTION MathItemIndex (i, F, Var) RESULT (n) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Return math item index, if item is real number, enter it into Comp-structure - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - INTEGER, INTENT(in) :: i ! Function identifier - CHARACTER (LEN=*), INTENT(in) :: F ! Function substring - CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names - INTEGER(is) :: n ! Byte value of math item - !----- -------- --------- --------- --------- --------- --------- --------- ------- - n = 0 - IF (SCAN(F(1:1),'0123456789.') > 0) THEN ! Check for begin of a number - Comp(i)%ImmedSize = Comp(i)%ImmedSize + 1 - IF (ASSOCIATED(Comp(i)%Immed)) Comp(i)%Immed(Comp(i)%ImmedSize) = RealNum (F) - n = cImmed - ELSE ! Check for a variable - n = VariableIndex (F, Var) - IF (n > 0) n = VarBegin+n-1 - END IF - END FUNCTION MathItemIndex - ! - FUNCTION CompletelyEnclosed (F, b, e) RESULT (res) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Check if function substring F(b:e) is completely enclosed by a pair of parenthesis - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - CHARACTER (LEN=*), INTENT(in) :: F ! Function substring - INTEGER, INTENT(in) :: b,e ! First and last pos. of substring - LOGICAL :: res - INTEGER :: j,k - !----- -------- --------- --------- --------- --------- --------- --------- ------- - res=.false. - IF (F(b:b) == '(' .AND. F(e:e) == ')') THEN - k = 0 - DO j=b+1,e-1 - IF (F(j:j) == '(') THEN - k = k+1 - ELSEIF (F(j:j) == ')') THEN - k = k-1 - END IF - IF (k < 0) EXIT - END DO - IF (k == 0) res=.true. ! All opened parenthesis closed - END IF - END FUNCTION CompletelyEnclosed - ! - RECURSIVE SUBROUTINE CompileSubstr (i, F, b, e, Var) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Compile i-th function string F into bytecode - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - INTEGER, INTENT(in) :: i ! Function identifier - CHARACTER (LEN=*), INTENT(in) :: F ! Function substring - INTEGER, INTENT(in) :: b,e ! Begin and end position substring - CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var ! Array with variable names - INTEGER(is) :: n - INTEGER :: b2,j,k,io - CHARACTER (LEN=*), PARAMETER :: calpha = 'abcdefghijklmnopqrstuvwxyz'// & - 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Check for special cases of substring - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IF (F(b:b) == '+') THEN ! Case 1: F(b:e) = '+...' -! WRITE(*,*)'1. F(b:e) = "+..."' - CALL CompileSubstr (i, F, b+1, e, Var) - RETURN - ELSEIF (CompletelyEnclosed (F, b, e)) THEN ! Case 2: F(b:e) = '(...)' -! WRITE(*,*)'2. F(b:e) = "(...)"' - CALL CompileSubstr (i, F, b+1, e-1, Var) - RETURN - ELSEIF (SCAN(F(b:b),calpha) > 0) THEN - n = MathFunctionIndex (F(b:e)) - IF (n > 0) THEN - b2 = b+INDEX(F(b:e),'(')-1 - IF (CompletelyEnclosed(F, b2, e)) THEN ! Case 3: F(b:e) = 'fcn(...)' -! WRITE(*,*)'3. F(b:e) = "fcn(...)"' - CALL CompileSubstr(i, F, b2+1, e-1, Var) - CALL AddCompiledByte (i, n) - RETURN - END IF - END IF - ELSEIF (F(b:b) == '-') THEN - IF (CompletelyEnclosed (F, b+1, e)) THEN ! Case 4: F(b:e) = '-(...)' -! WRITE(*,*)'4. F(b:e) = "-(...)"' - CALL CompileSubstr (i, F, b+2, e-1, Var) - CALL AddCompiledByte (i, cNeg) - RETURN - ELSEIF (SCAN(F(b+1:b+1),calpha) > 0) THEN - n = MathFunctionIndex (F(b+1:e)) - IF (n > 0) THEN - b2 = b+INDEX(F(b+1:e),'(') - IF (CompletelyEnclosed(F, b2, e)) THEN ! Case 5: F(b:e) = '-fcn(...)' -! WRITE(*,*)'5. F(b:e) = "-fcn(...)"' - CALL CompileSubstr(i, F, b2+1, e-1, Var) - CALL AddCompiledByte (i, n) - CALL AddCompiledByte (i, cNeg) - RETURN - END IF - END IF - ENDIF - END IF - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Check for operator in substring: check only base level (k=0), exclude expr. in () - !----- -------- --------- --------- --------- --------- --------- --------- ------- - DO io=cAdd,cPow ! Increasing priority +-*/^ - k = 0 - DO j=e,b,-1 - IF (F(j:j) == ')') THEN - k = k+1 - ELSEIF (F(j:j) == '(') THEN - k = k-1 - END IF - IF (k == 0 .AND. F(j:j) == Ops(io) .AND. IsBinaryOp (j, F)) THEN - IF (ANY(F(j:j) == Ops(cMul:cPow)) .AND. F(b:b) == '-') THEN ! Case 6: F(b:e) = '-...Op...' with Op > - -! WRITE(*,*)'6. F(b:e) = "-...Op..." with Op > -' - CALL CompileSubstr (i, F, b+1, e, Var) - CALL AddCompiledByte (i, cNeg) - RETURN - ELSE ! Case 7: F(b:e) = '...BinOp...' -! WRITE(*,*)'7. Binary operator',F(j:j) - CALL CompileSubstr (i, F, b, j-1, Var) - CALL CompileSubstr (i, F, j+1, e, Var) - CALL AddCompiledByte (i, OperatorIndex(Ops(io))) - Comp(i)%StackPtr = Comp(i)%StackPtr - 1 - RETURN - END IF - END IF - END DO - END DO - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Check for remaining items, i.e. variables or explicit numbers - !----- -------- --------- --------- --------- --------- --------- --------- ------- - b2 = b - IF (F(b:b) == '-') b2 = b2+1 - n = MathItemIndex(i, F(b2:e), Var) -! WRITE(*,*)'8. AddCompiledByte ',n - CALL AddCompiledByte (i, n) - Comp(i)%StackPtr = Comp(i)%StackPtr + 1 - IF (Comp(i)%StackPtr > Comp(i)%StackSize) Comp(i)%StackSize = Comp(i)%StackSize + 1 - IF (b2 > b) CALL AddCompiledByte (i, cNeg) - END SUBROUTINE CompileSubstr - ! - FUNCTION IsBinaryOp (j, F) RESULT (res) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Check if operator F(j:j) in string F is binary operator - ! Special cases already covered elsewhere: (that is corrected in v1.1) - ! - operator character F(j:j) is first character of string (j=1) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - INTEGER, INTENT(in) :: j ! Position of Operator - CHARACTER (LEN=*), INTENT(in) :: F ! String - LOGICAL :: res ! Result - INTEGER :: k - LOGICAL :: Dflag,Pflag - !----- -------- --------- --------- --------- --------- --------- --------- ------- - res=.true. - IF (F(j:j) == '+' .OR. F(j:j) == '-') THEN ! Plus or minus sign: - IF (j == 1) THEN ! - leading unary operator ? - res = .false. - ELSEIF (SCAN(F(j-1:j-1),'+-*/^(') > 0) THEN ! - other unary operator ? - res = .false. - ELSEIF (SCAN(F(j+1:j+1),'0123456789') > 0 .AND. & ! - in exponent of real number ? - SCAN(F(j-1:j-1),'eEdD') > 0) THEN - Dflag=.false.; Pflag=.false. - k = j-1 - DO WHILE (k > 1) ! step to the left in mantissa - k = k-1 - IF (SCAN(F(k:k),'0123456789') > 0) THEN - Dflag=.true. - ELSEIF (F(k:k) == '.') THEN - IF (Pflag) THEN - EXIT ! * EXIT: 2nd appearance of '.' - ELSE - Pflag=.true. ! * mark 1st appearance of '.' - ENDIF - ELSE - EXIT ! * all other characters - END IF - END DO - IF (Dflag .AND. (k == 1 .OR. SCAN(F(k:k),'+-*/^(') > 0)) res = .false. - END IF - END IF - END FUNCTION IsBinaryOp - ! - FUNCTION RealNum (str, ibegin, inext, error) RESULT (res) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Get real number from string - Format: [blanks][+|-][nnn][.nnn][e|E|d|D[+|-]nnn] - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - CHARACTER (LEN=*), INTENT(in) :: str ! String - REAL(rn) :: res ! Real number - INTEGER, OPTIONAL, INTENT(out) :: ibegin, & ! Start position of real number - inext ! 1st character after real number - LOGICAL, OPTIONAL, INTENT(out) :: error ! Error flag - INTEGER :: ib,in,istat - LOGICAL :: Bflag, & ! .T. at begin of number in str - InMan, & ! .T. in mantissa of number - Pflag, & ! .T. after 1st '.' encountered - Eflag, & ! .T. at exponent identifier 'eEdD' - InExp, & ! .T. in exponent of number - DInMan, & ! .T. if at least 1 digit in mant. - DInExp, & ! .T. if at least 1 digit in exp. - err ! Local error flag - !----- -------- --------- --------- --------- --------- --------- --------- ------- - Bflag=.true.; InMan=.false.; Pflag=.false.; Eflag=.false.; InExp=.false. - DInMan=.false.; DInExp=.false. - ib = 1 - in = 1 - DO WHILE (in <= LEN_TRIM(str)) - SELECT CASE (str(in:in)) - CASE (' ') ! Only leading blanks permitted - ib = ib+1 - IF (InMan .OR. Eflag .OR. InExp) EXIT - CASE ('+','-') ! Permitted only - IF (Bflag) THEN - InMan=.true.; Bflag=.false. ! - at beginning of mantissa - ELSEIF (Eflag) THEN - InExp=.true.; Eflag=.false. ! - at beginning of exponent - ELSE - EXIT ! - otherwise STOP - ENDIF - CASE ('0':'9') ! Mark - IF (Bflag) THEN - InMan=.true.; Bflag=.false. ! - beginning of mantissa - ELSEIF (Eflag) THEN - InExp=.true.; Eflag=.false. ! - beginning of exponent - ENDIF - IF (InMan) DInMan=.true. ! Mantissa contains digit - IF (InExp) DInExp=.true. ! Exponent contains digit - CASE ('.') - IF (Bflag) THEN - Pflag=.true. ! - mark 1st appearance of '.' - InMan=.true.; Bflag=.false. ! mark beginning of mantissa - ELSEIF (InMan .AND..NOT.Pflag) THEN - Pflag=.true. ! - mark 1st appearance of '.' - ELSE - EXIT ! - otherwise STOP - END IF - CASE ('e','E','d','D') ! Permitted only - IF (InMan) THEN - Eflag=.true.; InMan=.false. ! - following mantissa - ELSE - EXIT ! - otherwise STOP - ENDIF - CASE DEFAULT - EXIT ! STOP at all other characters - END SELECT - in = in+1 - END DO - err = (ib > in-1) .OR. (.NOT.DInMan) .OR. ((Eflag.OR.InExp).AND..NOT.DInExp) - IF (err) THEN - res = 0.0_rn - ELSE - READ(str(ib:in-1),*,IOSTAT=istat) res - err = istat /= 0 - END IF - IF (PRESENT(ibegin)) ibegin = ib - IF (PRESENT(inext)) inext = in - IF (PRESENT(error)) error = err - END FUNCTION RealNum - ! - SUBROUTINE LowCase (str1, str2) - !----- -------- --------- --------- --------- --------- --------- --------- ------- - ! Transform upper case letters in str1 into lower case letters, result is str2 - !----- -------- --------- --------- --------- --------- --------- --------- ------- - IMPLICIT NONE - CHARACTER (LEN=*), INTENT(in) :: str1 - CHARACTER (LEN=*), INTENT(out) :: str2 - INTEGER :: j,k - CHARACTER (LEN=*), PARAMETER :: lc = 'abcdefghijklmnopqrstuvwxyz' - CHARACTER (LEN=*), PARAMETER :: uc = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - !----- -------- --------- --------- --------- --------- --------- --------- ------- - str2 = str1 - DO j=1,LEN_TRIM(str1) - k = INDEX(uc,str1(j:j)) - IF (k > 0) str2(j:j) = lc(k:k) - END DO - END SUBROUTINE LowCase - ! -END MODULE fparser diff --git a/OpticsJan2020/MLI_light_optics/Src/gendip5.f b/OpticsJan2020/MLI_light_optics/Src/gendip5.f deleted file mode 100755 index b516b03..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/gendip5.f +++ /dev/null @@ -1,641 +0,0 @@ -************************************************************************ -* header GENDIP (GENMAP for a "parallel" face dipole * -* magnet with soft fringe fields * -* All routines needed for this special GENMAP * -************************************************************************ -c - subroutine bderivs(z,y,b) -c This routine computes b(z) = Int(-Inf to z) By(z') dz -c and the second and fourth derivative b2(z) and b4(z) for -c (a dipole magnet.) - use beamdata - include 'impli.inc' - include 'dip.inc' -c---------------------------------------- - double precision z, y(*), b(0:6,0:6) -c---------------------------------------- - external amyf,f1,f2,f4,f6 -c---------------------------------------- - epsz2 = gap/sl - bb = (By*sl) - do 10 i=0,6 - do 10 j=0,6 - b(i,j) = 0.0d0 - 10 continue -c -c b = (amyf(z-za,epsz2) - amyf(z-zb,epsz2)) * bb - b(0,0)= (f1(z-za,epsz2) -f1(z-zb,epsz2)) * bb - b(0,1)= (f2(z-za,epsz2) -f2(z-zb,epsz2)) * bb - b(0,3)= (f4(z-za,epsz2) -f4(z-zb,epsz2)) * bb -c b6= (f6(z-za,epsz2)-f6(z-zb,epsz2)) * bb - return - end -c - function amyf(y,eps) - double precision amyf,y,eps - if (y/eps.lt.0.d0) then - amyf = eps*Log(1 + Exp(2*y/eps))/2 - else - amyf = y + eps*Log(Exp(-2*y/eps)+1)/2 - endif - return - end -c - function f1(y,eps) - double precision f1,y,eps - f1 = tanh(y/eps)/2.d0 +.5d0 - return - end -c - function f2(y,eps) - double precision f2,y,eps - if (dabs(y/eps).lt.10.d0) then - f2 = 2*Exp(2*y/eps)/(eps*(1 + Exp(2*y/eps))**2) - else - f2 = 0.d0 - endif - return - end -c - function f4(y,eps) - double precision f4,y,eps - if (dabs(y/eps).lt.10.d0) then - f4 = 8*Exp(2*y/eps)* - & (1 - 4*Exp(2*y/eps) + Exp(4*y/eps))/ - & (eps**3*(1 + Exp(2*y/eps))**4) - else - f4 = 0.0d0 - endif - return - end -c - function f6(y,eps) - double precision f6,y,eps - if (dabs(y/eps).lt.10.d0) then - f6 = 32*Exp(2*y/eps)* - & (1 - 26*Exp(2*y/eps) + - & 66*Exp(4*y/eps) - - & 26*Exp(6*y/eps) + Exp(8*y/eps))/ - & (eps**5*(1 + Exp(2*y/eps))**6) - else - f6 = 0.d0 - endif - return - end -c -************************************************************************ - subroutine gendip(p,fa,fm) -c This is a subroutine for computing the map for a soft edged dipole -c magnet ( F. Neri 5/16/89 ). -c The routine is based on Rob Ryne original gendip, but all the code has been -c rewritten. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - include 'hmflag.inc' - include 'combs.inc' - include 'files.inc' - include 'dip.inc' - include 'pie.inc' -c -c calling arrays - dimension p(6) - dimension fa(monoms), fm(6,6) -c -c local arrays - dimension pb(6) - dimension y(monoms+15) -c - real ttaa, ttbb -c -c use equivalence statement to make the various parameter sets pstj -c available as if they were in a two dimensional array -c -c -c y(1-6) = given (design) trajectory -c y(7-42) = matrix -c y(43-98) = f3 -c y(99-224) = f4 -c -c get interval and number of steps from GENREC parameters -c - za = p(1) - zb = p(2) - ns = 10000 - By = p(3) - phi = p(4) * pi180 - s = sin(phi) - gap = p(5) - zi = 0.0d0 - zf = p(6) -c - write(6,*) 'za=',za,'zb=',zb - write(6,*) 'By=',By,'phi=',p(4) - write(6,*) 'gap=',gap,'zf=',zf -c - jtty = 1 - jdsk = 1 -c -c if((isend.eq.1).or.(isend.eq.3)) jtty = 1 -c if((isend.eq.2).or.(isend.eq.3)) jdsk = 1 -c - h=(zf-zi)/float(ns) -c -c call VAX system routine for timing report -c - ttaa = secnds(0.0) -c -c initial values for design orbit (in dimensionless units) : -c - y(1)=0.d0 - y(2)= s - y(3)=0.d0 - y(4)=0.d0 - y(5)=0.d0 - y(6)=-1.d0/beta -c set constants - qbyp=1.d0/brho - ptg=-1.d0/beta -c -c initialize map to the identity map: - ne=224 - do 40 i=7,ne - 40 y(i)=0.d0 - do 50 i=1,6 - j=7*i - 50 y(j)=1.d0 -c -c do the computation: - t=zi - iflag = 3 - call adam11(h,ns,'start',t,y) - call errchk(y(7)) - call putmap(y,fa,fm) - s1 = -y(2) - phi1 = dasin(s1) - phi1deg = phi1/pi180 - write(jof , 991) phi1deg - write(jodf, 991) phi1deg -991 format(' Final angle is ',f16.8,' degrees') -c -c call VAX system routine for timing report -c - ttbb = secnds(ttaa) - if(jtty.eq.1) write( jof,567) ttbb - if(jdsk.eq.1) write(jodf,567) ttbb - 567 format(' GENDIP integration time = ',f12.2,' sec.') - end -c -********************************************************************** -c - subroutine hmltn3(t,y,h) -c this routine is used to specify h(z) for a dipole magnet. -c Written by F. Neri, 5/16/89. -c Modified 6/3/89 to handle different gauges. -c The design orbit is assumed to be in the Y = 0 plane. -c B Field derivatives on the design orbit are provided by the routine -c BDERIVS as a function of z,and x = y(1), bderivs is called as -c call bderivs(z,y,b) -c The derivatives are stored in the array b(0:*,0:*), defined in the -c include file bfield.inc, and passed to other parts of the program -c in the common/bfield/b(0:*,0:*) -c The array b is arranged so that B(0,0) is By, B(1,0) is d(By)/(dX), -c b(1,1) is d2(By)/(dX dz), etc. -c - use beamdata - use lieaparam, only : monoms - parameter (itop=209,iplus=224) - include 'impli.inc' - include 'dip.inc' - include 'bfield.inc' -c - dimension h(monoms),y(*) -c - dimension X(0:itop),YY(0:itop),P1(0:itop),P2(0:itop) - dimension A(0:12) -c begin calculation -c -c compute gradients - call bderivs(t,y,b) -c -c initialization - do 10 i=1,monoms - 10 h(i)=0.d0 -c -c cccc -c Slow method to produce hamiltonian: use polynomial -c expansion of square root: when this method works we will use it to -c to check the "hardwired" version. -c cccc -c Coefficients of expansion of -SQRT(1+X)+1 - A(0) = 0.d0 - A(1) = -1.d0/2.d0 - do 50 i=2, 6 - A(i) = A(i-1) * (1.d0/2.d0 - (i-1.d0))/i - 50 continue -c - do 60 i=0,209 - X(i) = 0.d0 - 60 continue - X(6) = -2.d0 / beta -c X(13) = -1.d0 - X(22) = -1.d0 - X(27) = 1.d0 -c - maxord = 4 - nn = 4 - cos2 = 1 - y(2)**2 -c P1 = px - q Ax - do 101 i=0,itop - 101 P1(i) = 0.d0 -c Note constant term in px - q Ax, coming from design orbit -c y(2) = Px = sin(phi). - P1(0) = y(2) -c - P1(2) = 1.d0 - P1(18) = b(0,1)/(2.d0*brho) - P1(39) = b(1,1)/(2.d0*brho) - P1(95) = b(2,1)/(4.d0*brho) - P1(175) = -(b(2,1)+b(0,3))/(24.d0*brho) -c P2 = P1**2 - call mypmult(P1,P1,P2,maxord) -c Zero order term subtracted ( Sum starts at 1 ): -c Divide by cos2 - do 102 i=1,itop - 102 X(i) = (X(i) - P2(i))/cos2 -c X = pt**2 - 2/beta*pt - (px -q Ax)**2 - (py)**2 -c YY = -Sqrt(1+X) - call mypoly1(nn,A,X,YY,maxord) -c h = -Az - h(7) = b(1,0)/(2.d0*brho) - h(18) = -b(1,0)/(2.d0*brho) - h(28) = b(2,0)/(6.d0*brho) - h(39) = -b(2,0)/(6.d0*brho) - h(84) = b(3,0)/(24.d0*brho) - h(95) = -b(3,0)/(4.d0*brho) - h(175) = (b(3,0)+b(1,2))/(24.d0*brho) -c h = -Sqrt(1+X) - Az -c Zero and first order terms subtracted ( Sum starts at 7 ): -c Scale by cos - do 70 i=7, 209 - h(i) = h(i) + dsqrt(cos2)*YY(i)/sl - 70 continue -c - return - end -c -c ****************************************************************** -c -c Aux polynomial routines (really a poor man's DA package). -c They don't really belong here. -c -c ****************************************************************** -c - subroutine mypoly1(N,A,X,Y,maxord) - parameter (MN=6) - include 'lims.inc' - double precision X(0:209),Y(0:209) - double precision A(0:N) -c - double precision Vect(0:209,MN) -c -c NO COMMENT - do 100 i=0,top(maxord) - 100 Y(i) = 0.0d0 - do 200 i=0,top(maxord) - 200 Vect(i,1) = X(i) - do 300 iord=2,N - call mypmult(X,Vect(0,iord-1),Vect(0,iord),maxord) - 300 continue - Y(0) = A(0) - do 400 iord=1,N - do 500 i=0,top(maxord) - Y(i) = Y(i) + Vect(i,iord)*A(iord) - 500 continue - 400 continue - return - end -c - subroutine mypmult(p1,p2,p3,maxord) - double precision p1(0:209),p2(0:209),p3(0:209) -c - include 'lims.inc' - if (maxord.lt.0) return -c - do 10 i=1,top(maxord) - 10 p3(i) = 0.0d0 - p3(0) = p1(0) * p2(0) - do 100 mord=1,maxord - call mypmadd(p1(1),mord,p2(0),p3(1)) - call mypmadd(p2(1),mord,p1(0),p3(1)) - do 200 nord1 = 1,mord-1 - nord2 = mord - nord1 - call myproduct(p1(1),nord1,p2(1),nord2,p3(1)) - 200 continue - 100 continue - return - end -c - subroutine mypmadd(f,n,coeff,h) - implicit double precision (a-h,o-z) - dimension f(209),h(209) - include 'len.inc' - include 'lims.inc' - if(coeff.eq.1.d0) goto 20 - do 10 i=len(n-1)+1,len(n) - h(i) = h(i) + f(i)*coeff - 10 continue - return - 20 continue - do 30 i = len(n-1)+1, len(n) - h(i) = h(i) + f(i) - 30 continue - return - end -c - subroutine myproduct(a,na,b,nb,c) - use lieaparam, only : monoms - include 'impli.inc' - include 'len.inc' - include 'expon.inc' - include 'vblist.inc' - dimension a(209),b(209),c(209),l(6) - if(na.eq.1) then - ia1 = 1 - else - ia1 = len(na-1)+1 - endif - if(nb.eq.1) then - ib1 = 1 - else - ib1 = len(nb-1)+1 - endif - do 200 ia=ia1,len(na) - if(a(ia).eq.0.d0) goto 200 - do 20 ib = ib1,len(nb) - if(b(ib).eq.0.d0) goto 20 - do 2 m=1,6 - l(m) = expon(m,ia) + expon(m,ib) - 2 continue - n = ndex(l) - c(n) = c(n) + a(ia)*b(ib) - 20 continue - 200 continue - return - end -c -*********************************************************************** -c - subroutine nndrift(l,phideg,h,mh) -c -c Transverse entry drift. -c generates linear matrix mh and -c array h containing nonlinearities -c for the transfer map describing -c a drift section of length l meters, -c with the design trajectory at an angle of phideg degrees -c F. Neri 5/24/89 -c Actual code generated by Johannes Van Zeijts using -c REDUCE. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' - double precision l,h(monoms),mh(6,6) -c - double precision lsc - dimension j(6) -c - DOUBLE PRECISION UL - DOUBLE PRECISION UB - DOUBLE PRECISION CO - DOUBLE PRECISION Si - DIMENSION UDERS(923) - DOUBLE PRECISION UDERS - DOUBLE PRECISION T1 -c - call clear(h,mh) - lsc=l/sl -c - phi = phideg*pi180 - SI = SIN(phi) - CO = COS(phi) -c -c add drift terms to mh -c - do 40 k=1,6 - mh(k,k)=+1.0d0 - 40 continue - mh(1,2)=+lsc*(1.d0/CO + SI**2/CO**3) - mh(1,6)=+lsc*SI/(beta*CO**3) - mh(3,4)=+lsc*(1.d0/CO) - mh(5,2)=+lsc*SI/(beta*CO**3) - mh(5,6)=+lsc*(-1.d0/CO+1.d0/(beta**2*CO**3)) -c mh(5,6)=+(lsc/((gamma**2)*(beta**2))) -c -c add drift terms to h - UL = lsc - UB = beta -c - do 1 i=1,923 - UDERS(i) = 0.0d0 - 1 continue -c -c From: CINCOM::JOHANNES "Johannes van Zeijts" 23-MAY-1989 16:38 -c - UDERS(923) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7)) + (-2.1875D0 - & ) * (UL / (UB ** 4 * CO ** 9)) + 1.3125D0 * (UL / (UB ** 6 - & * CO ** 11)) + (-6.25D-02) * (UL / CO ** 5) - UDERS(910) = (-1.875D0) * (UL / (UB ** 2 * CO ** 7)) + 2.1875D0 - & * (UL / (UB ** 4 * CO ** 9)) + 0.1875D0 * (UL / CO ** 5) - UDERS(901) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7)) + (-0.1875D0 - & ) * (UL / CO ** 5) - UDERS(896) = 6.25D-02 * (UL / CO ** 5) - UDERS(839) = 1.875D0 * ((UL * SI) / (UB * CO ** 7)) + ( - & -8.75D0) * ((UL * SI) / (UB ** 3 * CO ** 9)) + 7.875D0 * - & ((UL * SI) / (UB ** 5 * CO ** 11)) - UDERS(828) = (-3.75D0) * ((UL * SI) / (UB * CO ** 7)) + - & 8.75D0 * ((UL * SI) / (UB ** 3 * CO ** 9)) - UDERS(821) = 1.875D0 * ((UL * SI) / (UB * CO ** 7)) - UDERS(783) = (-1.875D0) * (UL / (UB ** 2 * CO ** 7)) + 2.1875D0 - & * (UL / (UB ** 4 * CO ** 9)) + 0.1875D0 * (UL / CO ** 5) - & + (-13.125D0) * ((UL * SI ** 2) / (UB ** 2 * CO ** 9)) + - & 19.6875D0 * ((UL * SI ** 2) / (UB ** 4 * CO ** 11)) + - & 0.9375D0 * ((UL * SI ** 2) / CO ** 7) - UDERS(774) = 1.875D0 * (UL / (UB ** 2 * CO ** 7)) + (-0.375D0) - & * (UL / CO ** 5) + 13.125D0 * ((UL * SI ** 2) / (UB ** 2 - & * CO ** 9)) + (-1.875D0) * ((UL * SI ** 2) / CO ** 7) - UDERS(769) = 0.1875D0 * (UL / CO ** 5) + 0.9375D0 * ((UL * SI - & ** 2) / CO ** 7) - UDERS(748) = (-3.75D0) * ((UL * SI) / (UB * CO ** 7)) + - & 8.75D0 * ((UL * SI) / (UB ** 3 * CO ** 9)) + (-8.75D0) * - & ((UL * SI ** 3) / (UB * CO ** 9)) + 26.25D0 * ((UL * SI - & ** 3) / (UB ** 3 * CO ** 11)) - UDERS(741) = 3.75D0 * ((UL * SI) / (UB * CO ** 7)) + 8.75D0 * - & ((UL * SI ** 3) / (UB * CO ** 9)) - UDERS(728) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7)) + (-0.1875D0 - & ) * (UL / CO ** 5) + 13.125D0 * ((UL * SI ** 2) / (UB ** - & 2 * CO ** 9)) + (-1.875D0) * ((UL * SI ** 2) / CO ** 7) - & + 19.6875D0 * ((UL * SI ** 4) / (UB ** 2 * CO ** 11)) + ( - & -2.1875D0) * ((UL * SI ** 4) / CO ** 9) - UDERS(723) = 0.1875D0 * (UL / CO ** 5) + 1.875D0 * ((UL * SI - & ** 2) / CO ** 7) + 2.1875D0 * ((UL * SI ** 4) / CO ** 9 - & ) - UDERS(718) = 1.875D0 * ((UL * SI) / (UB * CO ** 7)) + 8.75D0 - & * ((UL * SI ** 3) / (UB * CO ** 9)) + 7.875D0 * ((UL * - & SI ** 5) / (UB * CO ** 11)) - UDERS(714) = 6.25D-02 * (UL / CO ** 5) + 0.9375D0 * ((UL * SI - & ** 2) / CO ** 7) + 2.1875D0 * ((UL * SI ** 4) / CO ** - & 9) + 1.3125D0 * ((UL * SI ** 6) / CO ** 11) - UDERS(461) = 0.375D0 * (UL / (UB * CO ** 5)) + (-1.25D0) * (UL - & / (UB ** 3 * CO ** 7)) + 0.875D0 * (UL / (UB ** 5 * CO ** - & 9)) - UDERS(450) = (-0.75D0) * (UL / (UB * CO ** 5)) + 1.25D0 * (UL / - & (UB ** 3 * CO ** 7)) - UDERS(443) = 0.375D0 * (UL / (UB * CO ** 5)) - UDERS(405) = (-3.75D0) * ((UL * SI) / (UB ** 2 * CO ** 7)) + - & 4.375D0 * ((UL * SI) / (UB ** 4 * CO ** 9)) + 0.375D0 * ( - & (UL * SI) / CO ** 5) - UDERS(396) = 3.75D0 * ((UL * SI) / (UB ** 2 * CO ** 7)) + ( - & -0.75D0) * ((UL * SI) / CO ** 5) - UDERS(391) = 0.375D0 * ((UL * SI) / CO ** 5) - UDERS(370) = (-0.75D0) * (UL / (UB * CO ** 5)) + 1.25D0 * (UL / - & (UB ** 3 * CO ** 7)) + (-3.75D0) * ((UL * SI ** 2) / (UB - & * CO ** 7)) + 8.75D0 * ((UL * SI ** 2) / (UB ** 3 * CO - & ** 9)) - UDERS(363) = 0.75D0 * (UL / (UB * CO ** 5)) + 3.75D0 * ((UL * - & SI ** 2) / (UB * CO ** 7)) - UDERS(350) = 3.75D0 * ((UL * SI) / (UB ** 2 * CO ** 7)) + ( - & -0.75D0) * ((UL * SI) / CO ** 5) + 8.75D0 * ((UL * SI - & ** 3) / (UB ** 2 * CO ** 9)) + (-1.25D0) * ((UL * SI ** 3 - & ) / CO ** 7) - UDERS(345) = 0.75D0 * ((UL * SI) / CO ** 5) + 1.25D0 * ((UL * - & SI ** 3) / CO ** 7) - UDERS(340) = 0.375D0 * (UL / (UB * CO ** 5)) + 3.75D0 * ((UL * - & SI ** 2) / (UB * CO ** 7)) + 4.375D0 * ((UL * SI ** 4) - & / (UB * CO ** 9)) - UDERS(336) = 0.375D0 * ((UL * SI) / CO ** 5) + 1.25D0 * ((UL - & * SI ** 3) / CO ** 7) + 0.875D0 * ((UL * SI ** 5) / - & CO ** 9) - UDERS(209) = (-0.75D0) * (UL / (UB ** 2 * CO ** 5)) + 0.625D0 * - & (UL / (UB ** 4 * CO ** 7)) + 0.125D0 * (UL / CO ** 3) - UDERS(200) = 0.75D0 * (UL / (UB ** 2 * CO ** 5)) + (-0.25D0) * - & (UL / CO ** 3) - UDERS(195) = 0.125D0 * (UL / CO ** 3) - UDERS(174) = (-1.5D0) * ((UL * SI) / (UB * CO ** 5)) + 2.5D0 - & * ((UL * SI) / (UB ** 3 * CO ** 7)) - UDERS(167) = 1.5D0 * ((UL * SI) / (UB * CO ** 5)) - UDERS(154) = 0.75D0 * (UL / (UB ** 2 * CO ** 5)) + (-0.25D0) * - & (UL / CO ** 3) + 3.75D0 * ((UL * SI ** 2) / (UB ** 2 * - & CO ** 7)) + (-0.75D0) * ((UL * SI ** 2) / CO ** 5) - UDERS(149) = 0.25D0 * (UL / CO ** 3) + 0.75D0 * ((UL * SI ** - & 2) / CO ** 5) - UDERS(144) = 1.5D0 * ((UL * SI) / (UB * CO ** 5)) + 2.5D0 * ( - & (UL * SI ** 3) / (UB * CO ** 7)) - UDERS(140) = 0.125D0 * (UL / CO ** 3) + 0.75D0 * ((UL * SI ** - & 2) / CO ** 5) + 0.625D0 * ((UL * SI ** 4) / CO ** 7) - UDERS(83) = (-0.5D0) * (UL / (UB * CO ** 3)) + 0.5D0 * (UL / ( - & UB ** 3 * CO ** 5)) - UDERS(76) = 0.5D0 * (UL / (UB * CO ** 3)) - UDERS(63) = 1.5D0 * ((UL * SI) / (UB ** 2 * CO ** 5)) + ( - & -0.5D0) * ((UL * SI) / CO ** 3) - UDERS(58) = 0.5D0 * ((UL * SI) / CO ** 3) - UDERS(53) = 0.5D0 * (UL / (UB * CO ** 3)) + 1.5D0 * ((UL * SI - & ** 2) / (UB * CO ** 5)) - UDERS(49) = 0.5D0 * ((UL * SI) / CO ** 3) + 0.5D0 * ((UL * - & SI ** 3) / CO ** 5) -c - do 2 i=1, monoms - h(i) = -UDERS(i) - 2 continue - return - end -c -*********************************************************************** -c - subroutine myprot(phideg,h,mh) -c -c High order PROT routine. -c Actual code generated by Johannes van Zeijts using -c REDUCE. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' - double precision l,h(monoms),mh(6,6) -c - dimension j(6) -c - DOUBLE PRECISION B - DOUBLE PRECISION CO - DOUBLE PRECISION Si -c - call clear(h,mh) -c - B = beta - phi = phideg*pi180 - SI = SIN(phi) - CO = COS(phi) -c - mh(1,1)=1.0d0/CO - mh(2,2)=CO - mh(2,6)=(-SI)/B - mh(3,3)=1.0d0 - mh(4,4)=1.0d0 - mh(5,1)=SI/(B*CO) - mh(5,5)=1.0d0 - mh(6,6)=1.0d0 -c - h(34) =(-SI)/(2.0d0*CO) - h(43) =(-SI)/(2.0d0*CO) - h(48) =(SI*(B**2-1))/(2.0d0*B**2*CO) - h(105) =SI**2/(4.0d0*(SI**2-1)) - h(109) =(-SI)/(2.0d0*B*CO) - h(114) =SI**2/(4.0d0*(SI**2-1)) - h(119) =(SI**2*(-B**2+1))/(4.0d0*B**2*(SI**2-1)) - h(132) =(-SI)/(2.0d0*B*CO) - h(139) =(SI*(B**2-1))/(2.0d0*B**3*CO) - h(266) =SI/(8.0d0*CO*(SI**2-1)) - h(270) =SI**2/(2.0d0*B*(SI**2-1)) - h(275) =(SI*(-2.0d0*SI**2+3))/(12.0d0*CO*(SI**2-1)) - h(280) =(SI*(2.0d0*B**2*SI**2-3.0d0*B**2-8.0d0*SI**2+9))/( - & 12.0d0*B**2*CO*(SI**2-1)) - h(293) =SI**2/(2.0d0*B*(SI**2-1)) - h(300) =(SI**2*(-B**2+1))/(2.0d0*B**3*(SI**2-1)) - h(321) =(SI*(-4.0d0*SI**2+3))/(24.0d0*CO*(SI**2-1)) - h(326) =(SI*(4.0d0*B**2*SI**2-3.0d0*B**2-10.0d0*SI**2+9))/( - & 12.0d0*B**2*CO*(SI**2-1)) - h(335) =(SI*(-4.0d0*B**4*SI**2+3.0d0*B**4+20.0d0*B**2*SI**2- - & 18.0d0*B**2-16.0d0*SI**2+15))/(24.0d0*B**4*CO*(SI**2-1)) - h(588) =(SI**2*(SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+1)) - h(592) =(SI*(SI**2+6))/(16.0d0*B*CO*(SI**2-1)) - h(597) =(SI**2*(3.0d0*SI**2-4))/(16.0d0*(SI**4-2.0d0*SI**2+ - & 1)) - h(602) =(SI**2*(-3.0d0*B**2*SI**2+4.0d0*B**2+15.0d0*SI**2-16.0d0 - & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) - h(615) =(3.0d0*SI*(-SI**2+2))/(8.0d0*B*CO*(SI**2-1)) - h(622) =(SI*(3.0d0*B**2*SI**2-6.0d0*B**2-7.0d0*SI**2+10))/( - & 8.0d0*B**3*CO*(SI**2-1)) - h(643) =(SI**2*(5.0d0*SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+ - & 1)) - h(648) =(SI**2*(-5.0d0*B**2*SI**2+4.0d0*B**2+17.0d0*SI**2-16.0d0 - & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) - h(657) =(SI**2*(5.0d0*B**4*SI**2-4.0d0*B**4-34.0d0*B**2*SI**2 - & +32.0d0*B**2+29.0d0*SI**2-28))/(32.0d0*B**4*(SI**4-2.0d0*SI**2+ - & 1)) - h(695) =(SI*(-7.0d0*SI**2+6))/(16.0d0*B*CO*(SI**2-1)) - h(702) =(SI*(7.0d0*B**2*SI**2-6.0d0*B**2-11.0d0*SI**2+10))/( - & 8.0d0*B**3*CO*(SI**2-1)) - h(713) =(SI*(-7.0d0*B**4*SI**2+6.0d0*B**4+22.0d0*B**2*SI**2- - & 20.0d0*B**2-15.0d0*SI**2+14))/(16.0d0*B**5*CO*(SI**2-1)) -c - call revf(1,h,mh) -c - return - end -c -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/gengrad_mod.f b/OpticsJan2020/MLI_light_optics/Src/gengrad_mod.f deleted file mode 100644 index 8a95dfd..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/gengrad_mod.f +++ /dev/null @@ -1,37 +0,0 @@ -!*********************************************************************** -! -! gengrad: data module for generalized gradients -! -! Description: This module implements a derived type data container -! for generalized gradients for either electric or magnetic fields. -! -! Version: 0.1 -! Author: D.T.Abell, Tech-X Corp., May.2005 -! -! Comments -! 19.May.05 DTA: Implementing this so both electric and magnetic -! field generalized gradients can use the same data structure. -! -!*********************************************************************** -! - module gengrad_data - implicit none -! -! derived types -! - type gengrad - integer :: nz_intrvl, maxj, maxm - double precision :: zmin, zmax, dz - double precision :: angfrq - ! must allocate zvals(0:nz_intrvl+rkxtra) - ! G1c(0:nz_intrvl+rkxtra,0/1:maxj,0:maxm) - ! G1s(0:nz_intrvl+rkxtra,0/1:maxj,0:maxm) - ! ... - ! G3s(0:nz_intrvl+rkxtra,0/1:maxj,0:maxm) - ! [ rkxtra = extra z values required by adam11 ] - double precision, dimension(:), pointer :: zvals - double precision, dimension(:,:,:), pointer :: G1c,G2c,G3c - double precision, dimension(:,:,:), pointer :: G1s,G2s,G3s - end type gengrad - - end module gengrad_data diff --git a/OpticsJan2020/MLI_light_optics/Src/genm.f b/OpticsJan2020/MLI_light_optics/Src/genm.f deleted file mode 100755 index 3bb9a03..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/genm.f +++ /dev/null @@ -1,526 +0,0 @@ -************************************************************************ -* header GENM (General GENMAP Routines) * -* All routines common to the various GENMAP programs * -************************************************************************ - subroutine putmap(y,fa,fm) -c Written by Rob Ryne, Spring 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension y(monoms+15) - dimension fa(monoms),fm(6,6) - call clear(fa,fm) - do 10 i=28,monoms - 10 fa(i)=y(i+15) - do 20 i=1,6 - do 20 j=1,6 - 20 fm(i,j)=y(i+6*j) - call revf(1,fa,fm) - return - end -c -************************************************************************ -c - subroutine feval(t,yy,f,ne) -c subroutine called by numerical map integration routines -c Written by Rob Ryne, Spring 1986 -c Modified by F. Neri and A. Dragt 9/29/89 -c Generic Vector Potential Version by F. Neri, 3/28/90 -c Merged generic version with existing ML/I version June 2004 RDR/FN/PW -c -c The equations are expressed as dy/dt=f(y;t), where: -c t denotes the independent variable (usually s, the arc length), -c y denotes the transfer map's vector representation (elements 7--938) -c along with the reference trajectory (elements 1--6) -c This subroutine calls subroutine hlmtnN, which should return the -c coefficients of the Hamiltonian, which will depend on the particular -c beamline element (vector potential). -c This routine returns f, the RHS of the equation dy/dt=f. -c -cryneneriwalstrom=== - use lieaparam, only : monoms - use beamdata -cryneneriwalstrom=== -c==dabell== - use e_gengrad - use phys_consts -c==dabell== -c - include 'impli.inc' -************************************************************************ - interface - subroutine hmltnRF(s,y,h) - implicit none - double precision, intent(in) :: s ! longitudinal coordinate - double precision, intent(inout) :: y(:) ! y(1:6)=ref. ptcl. data - double precision, intent(out) :: h(:) ! rf cavity Hamiltonian - end subroutine hmltnRF - end interface -************************************************************************ -c -cryne fix this parameter statement later to use monoms instead of hardwire: - parameter (itop=monoms,iplus=monoms+15) - include 'hmflag.inc' -cryneneriwalstrom=== -cryneneriwalstrom:param.inc replaced w/ "use beamdata..." -cryneneriwalstrom:parm.inc replaced w/ "use lieaparam..."(needed by vecpot.inc) - include 'bfield.inc' - include 'gronax.inc' - include 'vecpot.inc' -cryneneriwalstrom=== - dimension h(itop),hint(itop),temp(itop),t5a(itop),t5b(itop) - dimension yy(iplus),f(iplus) - dimension ajsm(6,6) -cryne 7/11/2002 this missing "save" cost me many hours of lost sleep! -cryne 7/11/2002 would be nice to deal w/ the issue of save statements -cryne 7/11/2002 once and for all. - save ajsm,h -cryneneriwalstrom: check to make sure there are not other variables that -cryneneriwalstrom need to be saved in the merged version -c -c y(1-6) = given (design) trajectory -c y(7-42) = matrix -c y(43-98) = f3 -c y(99-224) = f4 -c y(225-476) = f5 -c y(477-938) = f6 -c -c design trajectory: -c NB We have assumed the coordinates have been selected so that -c the design trajectory is yy(i)=0.d0 for i=1 to 6. - f(1)=0.d0 - f(2)=0.d0 - f(3)=0.d0 - f(4)=0.d0 - f(5)=0.d0 - f(6)=0.d0 -c -c matrix and polynomials: -c the expressions for f below are from p. 2742 of -c J. Math.Phys.,Vol 24,No.12,Dec 1983 (A.J.Dragt and E.Forest) -c -c select and compute hamiltonian, s matrix, and ajsm=-j*s -c skip these steps if iflag=0 - if (iflag.eq.0) go to 100 -c otherwise carry out the selection and required computations -cryneneriwalstrom go to (10,20),iflag - go to (10,20,30,40,50),iflag - write(6,*) 'trouble with iflag in subroutine feval' - call myexit - 10 call hmltn1(h) - call matify(ajsm,h) - goto 100 - 20 call hmltn2(t,yy,h) - call matify(ajsm,h) - go to 100 -cryneneriwalstrom eventually, need to check that this works for -cryneneriwalstrom arbitrary choice of units. -c -cryneneriwalstrom===== code from Neri generic version follows: - 30 continue - call hmltn3(t,yy,h) - call matify(ajsm,h) -c Change in design trajectory in the general case: no midplane symmetry - q = 1./brho - x = yy(1) - y = yy(3) -c t = yy(5) Oh boy! - Px = yy(2) - Py = yy(4) - Pt = yy(6) -c - k1 = 1 - k2 = 2 - k3 = 3 - k4 = 4 - k5 = 5 - k6 = 6 -c -c Hamilton equations, given vector potential (Ax,Ay,Az): -c - Pix = yy(2) - Ax(0) - Piy = yy(4) - Ay(0) -cryneabell:9.Nov.05: beta and gamma do not change in dipole, so okay here -cryneabell:9.Nov.05: rfcavity (below) requires continous update - xm2 = 1.d0/(gamma*beta)**2 -c - root = Dsqrt(-xm2 + yy(6)**2 - Pix**2 - Piy**2) -c - f(k1) = Pix/root - f(k2) = (Ax(1)*Pix+Ay(1)*Piy)/root + Az(1) - f(k3) = Piy/root - f(k4) = (Ax(3)*Pix+Ay(3)*Piy)/root + Az(3) - f(k5) = (-yy(6))/root - f(k6)=0 -c write(6,*) t, Pix, yy(1) -c write(36,*) t, Pix, yy(1) - goto 100 -cryneneriwalstrom===== code from Neri generic version above -c -c solenoid - 40 continue ! uses static units - call hmltn4(t,yy,h) - call matify(ajsm,h) - ! no need to integrate reftraj for this element - !betag=-1.d0/yy(6) - !f(1:6)=0.d0 - !f(5)=1.d0/(sl*betag) - go to 100 -c -cdabell===code for nonlinear rf cavity=== - 50 continue - call hmltnRF(t,yy,h) - call matify(ajsm,h) -c given (reference) trajectory - xg = yy(1) - pxg = yy(2) - yg = yy(3) - pyg = yy(4) - tg = yy(5) - ptg = yy(6) -c -c Hamilton equations for given given vector potential (Ax,Ay,Az): -c here using dynamic units, which sets p_ref=mc -c also, the vector potential has already been multiplied by e/p_ref - !write(6,*) "... computing reftraj ..." - !write(6,*) "sl=",sl - !write(6,*) "omegascl=",omegascl - !write(6,*) "c_light=",c_light - !write(6,*) "beta=",beta - write(60,*) t,tg,ptg - wlbyc=omegascl*sl/c_light - gammag=-wlbyc*ptg - betag=sqrt((gammag+1.d0)*(gammag-1.d0))/gammag - f(1:4)=0.d0 - f(5)=wlbyc/(sl*betag) - f(6)=vp%Az(5)/sl - ! - goto 100 -cdabell================================== -c -c================================== -c Insert your code here! -c================================== -c - 100 continue -c -c continue to evaluate f's -c -c matrix part: dm/dt = j*s*m = -ajsm*m - do 110 i=7,42 - 110 f(i)=0.d0 - do 120 i=1,6 - do 120 j=1,6 - do 120 k=1,6 -c compute xm2dot(i,j) = -ajsm(i,k)*xm2(k,j) - ij=i+6*j - 120 f(ij)=f(ij) - ajsm(i,k)*yy(k+6*j) - if(ne.eq.42)return -c -c compute f3dot ********************************** - call xform5(h,3,yy(7),hint) - do 130 i=43,98 - 130 f(i)=-hint(i-15) - if(ne.eq.98)return -c compute f4dot ********************************** - call xform5(h,4,yy(7),hint) - call pbkt1(yy(16),3,f(16),3,temp) - do 140 i=99,224 - 140 f(i)=-hint(i-15)+0.5*temp(i-15) - if(ne.eq.224)return -c compute f5dot ********************************** - call xform5(h,5,yy(7),hint) - call pbkt1(yy(16),3,temp,4,t5a) - call pbkt1(yy(16),3,f(16),4,t5b) - do 150 i=225,476 - 150 f(i)=-hint(i-15)-t5a(i-15)/6.d0+t5b(i-15) - if(ne.eq.476)return -c compute f6dot ********************************** - call xform5(h,6,yy(7),hint) - do 160 i=210,461 - 160 temp(i)=t5a(i)/24.d0-t5b(i)/2.d0+f(15+i) - call pbkt1(yy(16),3,temp,5,t5a) - call pbkt1(yy(16),4,f(16),4,t5b) - do 170 i=477,938 - 170 f(i)=-hint(i-15)+t5a(i-15)+t5b(i-15)/2.d0 -c -c print some terms from the RHS (for debugging) -c ! s t' pt' -c write(61,*) t,f(5:6) -c ! s m11' m12' m21' m22' m55' m56' m65' m66' -c write(62,*) t,f( 7: 8), f(13:14), f(35:36), f(41:42) -c ! s f32' f33' f37' f38' f52' f53' f80'..f83' -c write(63,*) t,f(47:48), f(52:53), f(67:68), f(95:98) -c - return - end -c -************************************************************************ -c - subroutine adam11(h,ns,nf,t,y,ne) -c Written by Rob Ryne, Spring 1986, based on a routine of Alex Dragt -c This integration routine makes local truncation errors at each -c step of order h**11. That is, it is locally correct through -c order h**10. Due to round off errors, its true precision is -c realized only when more than 64 bits are used. - use lieaparam, only : monoms - use beamdata - use phys_consts - include 'impli.inc' - character*6 nf -cryneneriwalstrom fix later to use monoms instead of hardwire: - dimension y(938),yp(938),yc(938),f1(938),f2(938),f3(938),f4(938), - & f5(938),f6(938),f7(938),f8(938),f9(938),f10(938),f11(938) - dimension a(10),am(10),b(10),bm(10) -c - data (a(i),i=1,10)/57281.d0,-583435.d0,2687864.d0, - & -7394032.d0,13510082.d0,-17283646.d0,16002320.d0, - & -11271304.d0,9449717.d0,2082753.d0/ - data (b(i),i=1,10)/-2082753.d0,20884811.d0,-94307320.d0, - & 252618224.d0,-444772162.d0,538363838.d0,-454661776.d0, - & 265932680.d0,-104995189.d0,30277247.d0/ -cryne 7/23/2002 - save a,b -cryne 1 August 2004 ne=monoms+15 -c - nsa=ns - if (nf.eq.'cont') go to 20 -c rk start - iqt=5 - qt=float(iqt) - hqt=h/qt - !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light - !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) - !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) - call feval(t,y,f1,ne) - call rk78ii(hqt,iqt,t,y,ne) - !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light - !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) - !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) - call feval(t,y,f2,ne) - call rk78ii(hqt,iqt,t,y,ne) - !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light - !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) - !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) - call feval(t,y,f3,ne) - call rk78ii(hqt,iqt,t,y,ne) - !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light - !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) - !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) - call feval(t,y,f4,ne) - call rk78ii(hqt,iqt,t,y,ne) - !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light - !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) - !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) - call feval(t,y,f5,ne) - call rk78ii(hqt,iqt,t,y,ne) - !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light - !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) - !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) - call feval(t,y,f6,ne) - call rk78ii(hqt,iqt,t,y,ne) - !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light - !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) - !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) - call feval(t,y,f7,ne) - call rk78ii(hqt,iqt,t,y,ne) - !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light - !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) - !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) - call feval(t,y,f8,ne) - call rk78ii(hqt,iqt,t,y,ne) - !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light - !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) - !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) - call feval(t,y,f9,ne) - call rk78ii(hqt,iqt,t,y,ne) - !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light - !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) - !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) - call feval(t,y,f10,ne) - nsa=ns-9 - hdiv=h/7257600.0d+00 - do 10 i=1,10 - am(i)=hdiv*a(i) - 10 bm(i)=hdiv*b(i) - 20 tint=t - do 100 i=1,nsa - do 30 j=1,ne - yp(j)=y(j)+bm(1)*f1(j)+bm(2)*f2(j)+bm(3)*f3(j) - &+bm(4)*f4(j)+bm(5)*f5(j)+bm(6)*f6(j)+bm(7)*f7(j) - & +bm(8)*f8(j)+bm(9)*f9(j)+bm(10)*f10(j) - 30 continue - call feval(t+h,yp,f11,ne) - do 40 j=1,ne - yp(j)=y(j)+am(1)*f2(j)+am(2)*f3(j)+am(3)*f4(j)+am(4)*f5(j) - & +am(5)*f6(j)+am(6)*f7(j)+am(7)*f8(j)+am(8)*f9(j)+am(9)*f10(j) - 40 yc(j)=yp(j)+am(10)*f11(j) - 41 call feval(t+h,yc,f11,ne) - do 50 j=1,ne - 50 y(j)=yp(j)+am(10)*f11(j) - do 60 j=1,ne - f1(j)=f2(j) - f2(j)=f3(j) - f3(j)=f4(j) - f4(j)=f5(j) - f5(j)=f6(j) - f6(j)=f7(j) - f7(j)=f8(j) - f8(j)=f9(j) - f9(j)=f10(j) - 60 f10(j)=f11(j) - t=tint+i*h - !write(41,*) t,y(5:6),-y(6)*omegascl*sl/c_light - !write(42,*) t,y(7:8),y(13:14),y(35:36),y(41:42) - !write(43,*) t,y(47:48),y(52:53),y(67:68),y(95:98) - !call myflush(41) - !call myflush(42) - !call myflush(43) - 100 continue - return - end -c -*********************************************************************** -c - subroutine rk78ii(h,ns,t,y,ne) -c Written by Rob Ryne, Spring 1986, based on a routine of -c J. Milutinovic. -c For a reference, see page 76 of F. Ceschino and J Kuntzmann, -c Numerical Solution of Initial Value Problems, Prentice Hall 1966. -c This integration routine makes local truncation errors at each -c step of order h**7. -c That is, it is locally correct through terms of order h**6. -c Each step requires 8 function evaluations. - - use lieaparam, only : monoms - include 'impli.inc' -cryneneriwalstrom fix later to use monoms instead of hardwire: - dimension y(938),yt(938),f(938),a(938),b(938),c(938),d(938), - &e(938),g(938),o(938),p(938) -cryne 1 August 2004 ne=monoms+15 -c - tint=t - do 200 i=1,ns - call feval(t,y,f,ne) - do 10 j=1,ne - 10 a(j)=h*f(j) - do 20 j=1,ne - 20 yt(j)=y(j)+a(j)/9.d+0 - tt=t+h/9.d+0 - call feval(tt,yt,f,ne) - do 30 j=1,ne - 30 b(j)=h*f(j) - do 40 j=1,ne - 40 yt(j)=y(j) + (a(j) + 3.d+0*b(j))/24.d+0 - tt=t+h/6.d+0 - call feval(tt,yt,f,ne) - do 50 j=1,ne - 50 c(j)=h*f(j) - do 60 j=1,ne - 60 yt(j)=y(j)+(a(j)-3.d+0*b(j)+4.d+0*c(j))/6.d+0 - tt=t+h/3.d+0 - call feval(tt,yt,f,ne) - do 70 j=1,ne - 70 d(j)=h*f(j) - do 80 j=1,ne - 80 yt(j)=y(j) + (-5.d+0*a(j) + 27.d+0*b(j) - - & 24.d+0*c(j) + 6.d+0*d(j))/8.d+0 - tt=t+.5d+0*h - call feval(tt,yt,f,ne) - do 90 j=1,ne - 90 e(j)=h*f(j) - do 100 j=1,ne - 100 yt(j)=y(j) + (221.d+0*a(j) - 981.d+0*b(j) + - & 867.d+0*c(j)- 102.d+0*d(j) + e(j))/9.d+0 - tt = t+2.d+0*h/3.d+0 - call feval(tt,yt,f,ne) - do 110 j=1,ne - 110 g(j)=h*f(j) - do 120 j=1,ne - 120 yt(j) = y(j)+(-183.d+0*a(j)+678.d+0*b(j)-472.d+0*c(j)- - & 66.d+0*d(j)+80.d+0*e(j) + 3.d+0*g(j))/48.d+0 - tt = t + 5.d+0*h/6.d+0 - call feval(tt,yt,f,ne) - do 130 j=1,ne - 130 o(j)=h*f(j) - do 140 j=1,ne - 140 yt(j) = y(j)+(716.d+0*a(j)-2079.d+0*b(j)+1002.d+0*c(j)+ - & 834.d+0*d(j)-454.d+0*e(j)-9.d+0*g(j)+72.d+0*o(j))/82.d+0 - tt = t + h - call feval(tt,yt,f,ne) - do 150 j=1,ne - 150 p(j)=h*f(j) - do 160 j=1,ne - 160 y(j) = y(j)+(41.d+0*a(j)+216.d+0*c(j)+27.d+0*d(j)+ - & 272.d+0*e(j)+27.d+0*g(j)+216.d+0*o(j)+41.d+0*p(j))/840.d+0 - t=tint+i*h - 200 continue - return - end -cryneneriwalstrom=== -c removed subroutine poly1 and pmult, which are now in integ.f -c also, left in place below a commented out version of subroutine drift -c as a reminder to ourselves -cryneneriwalstrom=== -c ****************************************************************** -c -c Drift and aux poly routines. -c They don't really belong here. -c -c ***************************************************************** -c -c subroutine drift(l,h,mh) -c -c generates linear matrix mh and -c array h containing nonlinearities -c for the transfer map describing -c a drift section of length l metres -c -c implicit double precision (a-h,o-z) -c double precision l,lsc,mh -c dimension j(6) -c dimension h(923) -c dimension mh(6,6) -c dimension X(0:923), Y(0:923), A(0:6) -c common/parm/brho,c,gamma,gamm1,beta,achg,sl,ts -c -c call clear(h,mh) -c lsc=l/sl -c -c add drift terms to mh -c -c do 40 k=1,6 -c mh(k,k)=+1.0d0 -c 40 continue -c mh(1,2)=+lsc -c mh(3,4)=+lsc -c mh(5,6)=+(lsc/((gamma**2)*(beta**2))) -c -c add drift terms to h -c -c do degree 3-6 -c -c F. Neri Aug. 28 1987 -c -c A(0) = 0.d0 -c A(1) = 1.d0/2.d0 -c do 50 i=2, 6 -c A(i) = A(i-1) * (1.d0/2.d0 - (i-1.d0))/i -c 50 continue -c -c do 60 i=0,923 -c X(i) = 0.d0 -c 60 continue -c X(6) = -2.d0 / beta -c X(13) = -1.d0 -c X(22) = -1.d0 -c X(27) = 1.d0 -c -c maxord = 6 -c nn = 6 -c call poly1(nn,A,X,Y,maxord) -c do 70 i=28, 923 -c h(i) = Y(i) * lsc -c 70 continue -c return -c end -c ******************************************************************* diff --git a/OpticsJan2020/MLI_light_optics/Src/gensol.f b/OpticsJan2020/MLI_light_optics/Src/gensol.f deleted file mode 100755 index 78fb2b3..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/gensol.f +++ /dev/null @@ -1,511 +0,0 @@ -************************************************************************ -* header GENSOL * -* (GENMAP for a solenoid magnet with soft fringe fields) * -* All routines needed for this special GENMAP * -************************************************************************ -c - subroutine gensol(p,fa,fm,jsl,nsl,slfr) -c -c This routine computes the map for a solenoid, by numerical integration. -c F. Neri, 8/18/89; A. Dragt, 10/4/89 -c The routine is based on Rob Ryne original solnsc, but all the code -c has been rewritten. -c Modified by D.T. Abell (15.Jan.07) to include 5th and 6th-order terms -c and enable slicing of solenoids. -c - use beamdata - use lieaparam, only : monoms - use parallel, only : idproc - include 'impli.inc' - include 'parset.inc' - include 'hmflag.inc' - include 'combs.inc' - include 'files.inc' - include 'sol.inc' -c -c calling arrays - dimension p(*) - dimension fa(monoms), fm(6,6) -c -c local arrays - dimension y(monoms+15) -c -c use equivalence statement to make the various parameter sets pstj -c available as if they were in a two dimensional array -c -c -c y(1-6) = given (design) trajectory -c y(7-42) = matrix -c y(43-98) = f3 -c y(99-224) = f4 -c y(225-476) = f5 -c y(477-938) = f6 -c -c get interval and number of steps from GENSOL parameters -c - zi = p(1) - zf = p(2) - ns = nint(p(3)) - ifile = nint(p(4)) - ips = nint(p(5)) - mpole = nint(p(6)) ! not used -c - if(ips.ge.1 .and. ips.le.9)then -c get other parameters from pset - di = pst(1,ips) - tl = pst(2,ips) - cl = pst(3,ips) - bz0 = pst(4,ips) - iecho = nint(pst(5,ips)) - ioptr = nint(pst(6,ips)) -c - elseif(ips.eq.-1)then -c If using sif-style input (type code 'solenoid' instead of 'sol') -c then the code will have set p(5)=-1. -c In that case, the other parameters are in array elements p(7)-p(12) - di = p(7) - tl = p(8) - cl = p(9) - bz0 = p(10) - iecho = nint(p(11)) - ioptr = nint(p(12)) - else - write(6,*)'error in solenoid specification' - write(6,*)'problem with element 5 of array passed to gensol' - stop - endif -c -c dabell Mon Jan 15 09:48:01 PST 2007 -c MaryLie manual defines di as length from zi to start of solenoid body -c but code treats di as z at start of solenoid body; so here we redefine -c di as the code expects. - di = zi + di -c -c complain if cl equals zero - if (cl.eq.0.d0) then - if (idproc.eq.0) then - write(6,*) ' <*** ERROR ***> solenoid specified with' - write(6,*) ' characteristic length of zero!' - end if - call myexit() - end if -c -c set parameters for this slice - if (nsl.gt.1) then - dz=slfr*(zf-zi) - z1=zi+dz*(jsl-1) - z2=zi+dz*jsl - nstep=nint(slfr*ns) - dz=dz/real(nstep) - else - dz = (zf - zi) / real(ns) - z1 = zi - z2 = zf - nstep = ns - end if -c -c -c write out parameters, if desired -c - if (iecho.eq.1.or.iecho.eq.3) then - if (jsl.eq.1) then - write(jof,*) - write(jof,*) ' zi=',zi,' zf=',zf,' nsl=',nsl - write(jof,*) ' ns=',ns - write(jof,*) ' di=',di,' length=',tl - write(jof,*) ' cl=',cl,' B=',bz0 - write(jof,*) ' iopt=',ioptr - write(jof,*) - end if - if (nsl.ne.1) then - write(jof,*) ' z1=',z1,' z2=',z2,' dz=',dz - write(jof,*) ' jsl=',jsl,' nstep=',nstep - write(jof,*) - end if - end if - if (iecho.eq.2.or.iecho.eq.3) then - if (jsl.eq.1) then - write(jodf,*) - write(jodf,*) ' zi=',zi,' zf=',zf,' nsl=',nsl - write(jodf,*) ' ns=',ns - write(jodf,*) ' di=',di,' length=',tl - write(jodf,*) ' cl=',cl,' B=',bz0 - write(jodf,*) ' iopt=',ioptr - write(jodf,*) - end if - if (nsl.ne.1) then - write(jodf,*) ' z1=',z1,' z2=',z2,' dz=',dz - write(jodf,*) ' jsl=',jsl,' nstep=',nstep - write(jodf,*) - end if - end if -c -c -c write out gradient and derivatives on file ifile: - ipflag=0 - if (ifile.ne.0) then - if (ifile.lt.0) then - ipflag=1 - ifile=-ifile - endif - zz = zi - h = (zf - zi) / real(ns) - do 999 ii = 0, ns - call bz04(zz,b0,b2,b4) - write(ifile,137) zz, b0, b2, b4, 0., 0. - 137 format(6(1x,1pg12.5)) - zz = zz + h - 999 continue - write(jof,*) ' profile written on file ',ifile - endif -c -c return identity map if ifile was < 0 -c - if (ipflag .eq. 1) then - call ident(fa,fm) - return - endif -c -c initial values for design orbit (in dimensionless units) : -c - y(1)= 0.d0 - y(2)= 0.d0 - y(3)= 0.d0 - y(4)= 0.d0 - y(5)= 0.d0 ! updated after integration (in afro.f) - y(6)= -1.d0/beta ! for static units (change to dynamic in afro) -c set constants - qbyp= 1.d0/brho - ptg= -1.d0/beta -c -c initialize map to the identity: -c - ne=monoms+15 - do 40 i=7,ne - 40 y(i)=0.d0 - do 50 i=1,6 - j=7*i - 50 y(j)=1.d0 -c -c do the computation: - t=z1 - iflag = 4 -cryne 1 August 2004 fix later: -cryne call adam11(h,ns,'start',t,y) - call adam11(dz,nstep,'start',t,y,ne) - call putmap(y,fa,fm) - call csym(1,fm,ans) -c - return - end -c -************************************************************************* -c - subroutine bz02(z,b0,b2) -c This routine computes b0(z) = Bz(z) -c and the second derivative b2(z) on axis -c Alex Dragt 10/4/89 -c - include 'impli.inc' - include 'sol.inc' -c - zz = z - di - call bump0(zz,cl,tl,ans0) - call bump2(zz,cl,tl,ans2) - b0 = bz0*ans0 - b2 = bz0*ans2 -c - return - end -c -************************************************************************* - subroutine bz04(z,b0,b2,b4) -c -c Return the zeroth, second, and fourth derivatives of the on-axis -c solenoidal field described by the parameters in 'sol.inc'. -c Dan Abell, January 2007 - implicit none - double precision, intent(in) :: z - double precision, intent(out) :: b0,b2,b4 -c-----!----------------------------------------------------------------! - include 'sol.inc' - double precision :: ta,ta2,tb,tb2,zz -c - zz = z - di - ta = tanh(zz/cl) - tb = tanh((zz-tl)/cl) - ta2=ta**2 - tb2=tb**2 - b0 = bz0 * 0.5d0 * (ta - tb) - b2 = -bz0 * (ta * (1.d0 - ta2) - tb * (1.d0 - tb2)) / (cl**2) - b4 = bz0 * 4.d0 * (ta * (1.d0 - ta2) * (2.d0 - 3.d0 * ta2) & - & - tb * (1.d0 - tb2) * (2.d0 - 3.d0 * tb2)) & - & / (cl**4) -c - return - end -c -********************************************************************** -c - subroutine bump0(z,cl,tl,ans0) -c -c This routine computes the soft-edge bump function -c Alex Dragt 10/4/89 -c - include 'impli.inc' -c -c----------------------------------------------------------- - sgn0(z,cl)=tanh(z/cl) -c----------------------------------------------------------- - ans0=( sgn0(z,cl) - sgn0(z-tl,cl) )/2. -c - return - end -c -************************************************************************ -c - subroutine bump2(z,cl,tl,ans2) -c -c This routine computes the second derivative of the soft-edge bump function -c Alex Dragt 10/4/89 -c - include 'impli.inc' -c - zl=z - zr=z-tl - call sgn2(zl,cl,ansl) - call sgn2(zr,cl,ansr) - ans2=(ansl - ansr)/2. -c - return - end -c -********************************************************************* -c - subroutine sgn2(z,cl,ans) -c -c This subroutine computes the second derivative of the approximating -c signum function -c Alex Dragt 10/4/89 -c - include 'impli.inc' -c - ans=0. - if( abs(z/cl) .lt. 30.) then - ans=-(2./(cl**2))*(tanh(z/cl))/((cosh(z/cl))**2) - endif -c - return - end -c -*********************************************************************** -c - subroutine hmltn4(t,y,h) -c -c This routine is used to specify the Hamiltonian h for a solenoid. -c Written by A. Dragt 9/28/89 -c Modified by D.T. Abell to include 5th and 6th-order terms (15.Jan.07) -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'sol.inc' -c -c calling arrays - dimension h(monoms) - dimension y(monoms+15) -c -c begin calculation -c -c compute gradients - call bz04(t,b0,b2,b4) -c -c scale gradients -c - b0=sl*b0/brho - b2=(sl**3)*b2/brho -c -c compute terms in hamiltonian -c - h=0.d0 -c -c terms of degree 2 -c - h( 7)= b0**2/(8.*sl) - h(10)= -b0/(2.*sl) - h(13)= 1./(2.*sl) - h(14)= b0/(2.*sl) - h(18)= b0**2/(8.*sl) - h(22)= 1./(2.*sl) - h(27)= 1./(2.*beta**2*gamma**2*sl) - if (ioptr .ne. 0) then - h(10)= 0.d0 - h(14)= 0.d0 - endif -c -c terms of degree 3 -c - h(33)= b0**2/(8.*beta*sl) - h(45)= -b0/(2.*beta*sl) - h(53)= 1./(2.*beta*sl) - h(57)= b0/(2.*beta*sl) - h(67)= b0**2/(8.*beta*sl) - h(76)= 1./(2.*beta*sl) - h(83)= 1./(2.*beta**3*gamma**2*sl) -c -c terms of degree 4 -c - h( 84)= b0*(b0**3 - 4.*b2)/(128.*sl) - h( 87)= -(b0**3 - b2)/(16.*sl) - h( 90)= b0**2/(16.*sl) - h( 91)= (b0**3 - b2)/(16.*sl) - h( 95)= b0*(b0**3 - 4.*b2)/(64.*sl) - h( 99)= 3.*b0**2/(16.*sl) - h(104)= b0**2*(3. - beta**2)/(16.*beta**2*sl) - h(107)= -b0/(4.*sl) - h(111)= -(b0**2)/(4.*sl) - h(121)= -(b0**3 - b2)/(16.*sl) - h(130)= -b0/(4.*sl) - h(135)= -b0*(3. - beta**2)/(4.*beta**2*sl) - h(140)= 1./(8.*sl) - h(141)= b0/(4.*sl) - h(145)= 3.*b0**2/(16.*sl) - h(149)= 1./(4.*sl) - h(154)= (3. - beta**2)/(4.*beta**2*sl) - h(155)= (b0**3 - b2)/(16.*sl) - h(159)= b0/(4.*sl) - h(164)= b0*(3. - beta**2)/(4.*beta**2*sl) - h(175)= b0*(b0**3 - 4.*b2)/(128.*sl) - h(179)= b0**2/(16.*sl) - h(184)= b0**2*(3. - beta**2)/(16.*beta**2*sl) - h(195)= 1./(8.*sl) - h(200)= (3. - beta**2)/(4.*beta**2*sl) - h(209)= (5. - beta**2)/(8.*beta**4*gamma**2*sl) -c -c terms of degree 5 -c - h(215)= b0*(3.*b0**3 - 4.*b2)/(128.*beta*sl) - h(227)= -(3.*b0**3 - b2)/(16.*beta*sl) - h(235)= 3.*b0**2/(16.*beta*sl) - h(239)= (3.*b0**3 - b2)/(16.*beta*sl) - h(249)= b0*(3.*b0**3 - 4.*b2)/(64.*beta*sl) - h(258)= 9.*b0**2/(16.*beta*sl) - h(265)= b0**2*(5. - 3.*beta**2)/(16.*beta**3*sl) - h(277)= -3.*b0/(4.*beta*sl) - h(287)= -3.*b0**2/(4.*beta*sl) - h(307)= -(3.*b0**3 - b2)/(16.*beta*sl) - h(323)= -3.*b0/(4.*beta*sl) - h(330)= -b0*(5. - 3.*beta**2)/(4.*beta**3*sl) - h(340)= 3./(8.*beta*sl) - h(344)= 3.*b0/(4.*beta*sl) - h(354)= 9.*b0**2/(16.*beta*sl) - h(363)= 3./(4.*beta*sl) - h(370)= (5. - 3.*beta**2)/(4.*beta**3*sl) - h(374)= (3.*b0**3 - b2)/(16.*beta*sl) - h(383)= 3.*b0/(4.*beta*sl) - h(390)= b0*(5. - 3.*beta**2)/(4.*beta**3*sl) - h(409)= b0*(3.*b0**3 - 4.*b2)/(128.*beta*sl) - h(418)= 3.*b0**2/(16.*beta*sl) - h(425)= b0**2*(5. - 3.*beta**2)/(16.*beta**3*sl) - h(443)= 3./(8.*beta*sl) - h(450)= (5. - 3.*beta**2)/(4.*beta**3*sl) - h(461)= (7. - 3.*beta**2)/(8.*beta**5*gamma**2*sl) -c -c terms of degree 6 -c - h(462)= (3.*b0**6 - 12.*b0**3*b2 + 6.*b2**2 + 4.*b0*b4)/(3072.*sl) - h(465)= (-9.*b0**5 + 18.*b0**2*b2 - 2.*b4)/(768.*sl) - h(468)= b0*(3.*b0**3 - 4.*b2)/(256.*sl) - h(469)= (9.*b0**5 - 18.*b0**2*b2 + 2.*b4)/(768.*sl) - h(473)= (3.*b0**6 - 12.*b0**3*b2 + 6.*b2**2 + 4.*b0*b4)/(1024.*sl) - h(477)= b0*(15.*b0**3 - 12.*b2)/(256.*sl) - h(482)= b0*(b0**3*(15. - 3.*beta**2) - b2*(12. - 4.*beta**2)) & - & /(256.*beta**2*sl) - h(485)= -(3.*b0**3 - b2)/(32.*sl) - h(489)= -b0*(3.*b0**3 - 2.*b2)/(32.*sl) - h(499)= -(9.*b0**5 - 18.*b0**2*b2 + 2.*b4)/(384.*sl) - h(508)= -(5.*b0**3 - b2)/(32.*sl) - h(513)= -(b0**3*(15. - 3.*beta**2) - b2*(3. - beta**2)) & - & /(32.*beta**2*sl) - h(518)= 3.*b0**2/(64.*sl) - h(519)= (3.*b0**3 - b2)/(32.*sl) - h(523)= b0*(9.*b0**3 - 8.*b2)/(128.*sl) - h(527)= 9.*b0**2/(32.*sl) - h(532)= 3.*b0**2*(5. - beta**2)/(32.*beta**2*sl) - h(533)= (9.*b0**5 - 18.*b0**2*b2 + 2.*b4)/(384.*sl) - h(537)= (9.*b0**3 - b2)/(32.*sl) - h(542)= (b0**3*(15. - 3.*beta**2) - b2*(3. - beta**2)) & - & /(32.*beta**2*sl) - h(553)= (3.*b0**6 - 12.*b0**3*b2 + 6.*b2**2 + 4.*b0*b4)/(1024.*sl) - h(557)= b0*(9.*b0**3 - 8.*b2)/(128.*sl) - h(562)= b0*(b0**3*(15. - 3.*beta**2) - b2*(12. - 4.*beta**2)) & - & /(128.*beta**2*sl) - h(573)= 15.*b0**2/(64.*sl) - h(578)= b0**2*(45. - 9.*beta**2)/(32.*beta**2*sl) - h(587)= b0**2*(35. - 30.*beta**2 + 3.*beta**4)/(64.*beta**4*sl) - h(590)= -3.*b0/(16.*sl) - h(594)= -3.*b0**2/(8.*sl) - h(604)= -(9.*b0**3 - b2)/(32.*sl) - h(613)= -3.*b0/(8.*sl) - h(618)= -b0*(15 - 3.*beta**2)/(8.*beta**2*sl) - h(624)= -b0*(3.*b0**3 - 2.*b2)/(32.*sl) - h(633)= -3.*b0**2/(8.*sl) - h(638)= -b0**2*(15. - 3.*beta**2)/(8.*beta**2*sl) - h(659)= -(9.*b0**5 - 18.*b0**2*b2 + 2.*b4)/(768.*sl) - h(668)= -(3.*b0**3 - b2)/(32.*sl) - h(673)= -(b0**3*(15. - 3.*beta**2) - b2*(3. - beta**2)) & - & /(32.*beta**2*sl) - h(693)= -3.*b0/(16.*sl) - h(698)= -b0*(15. - 3.*beta**2)/(8.*beta**2*sl) - h(707)= -b0*(35. - 30.*beta**2 + 3.*beta**4)/(16.*beta**4*sl) - h(714)= 1./(16.*sl) - h(715)= 3.*b0/(16.*sl) - h(719)= 15.*b0**2/(64.*sl) - h(723)= 3./(16.*sl) - h(728)= (15. - 3.*beta**2)/(16.*beta**2*sl) - h(729)= (5.*b0**3 - b2)/(32.*sl) - h(733)= 3.*b0/(8.*sl) - h(738)= b0*(15. - 3.*beta**2)/(8.*beta**2*sl) - h(749)= b0*(15.*b0**3 - 12.*b2)/(256.*sl) - h(753)= 9.*b0**2/(32.*sl) - h(758)= b0**2*(45. - 9.*beta**2)/(32.*beta**2*sl) - h(769)= 3./(16.*sl) - h(774)= (15. - 3.*beta**2)/(8.*beta**2*sl) - h(783)= (35. - 30.*beta**2 + 3.*beta**4)/(16.*beta**4*sl) - h(784)= (9.*b0**5 - 18.*b0**2*b2 + 2.*b4)/(768.*sl) - h(788)= (3.*b0**3 - b2)/(32.*sl) - h(793)= (b0**3*(15. - 3.*beta**2) - b2*(3. - beta**2)) & - & /(32.*beta**2*sl) - h(804)= 3.*b0/(16.*sl) - h(809)= b0*(15. -3.* beta**2)/(8.*beta**2*sl) - h(818)= b0*(35. - 30.*beta**2 + 3.*beta**4)/(16.*beta**4*sl) - h(840)= (3.*b0**6 - 12.*b0**3*b2 + 6.*b2**2 + 4.*b0*b4)/(3072.*sl) - h(844)= b0*(3.*b0**3 - 4.*b2)/(256.*sl) - h(849)= b0*(b0**3*(15. - 3.*beta**2) - b2*(12. - 4.*beta**2)) & - & /(256.*beta**2*sl) - h(860)= 3.*b0**2/(64.*sl) - h(865)= b0**2*(15. - 3.*beta**2)/(32.*beta**2*sl) - h(874)= b0**2*(35. - 30.*beta**2 + 3.*beta**4)/(64.*beta**4*sl) - h(896)= 1./(16.*sl) - h(901)= (15. - 3.*beta**2)/(16.*beta**2*sl) - h(910)= (35. - 30.*beta**2 + 3.*beta**4)/(16.*beta**4*sl) - h(923)= (21. - 14.*beta**2 + beta**4)/(16.*beta**6*gamma**2*sl) -c -c add sextupoles -c h(28)=fsxnr*sl2 -c h(30)=-3.d0*fsxsk*sl2 -c h(39)=-3.d0*fsxnr*sl2 -c h(64)=fsxsk*sl2 -c -c add octupoles -c -c h(84)=h(84)+focnr*sl3 -c h(86)=-4.0d0*focsk*sl3 -c h(95)=-6.d0*focnr*sl3 -c h(120)=4.d0*focsk*sl3 -c h(175)=h(175)+focnr*sl3 -c - return - end -c -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/greenfn_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/greenfn_mod.f90 deleted file mode 100644 index 3baf6a3..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/greenfn_mod.f90 +++ /dev/null @@ -1,573 +0,0 @@ -!*********************************************************************** -! -! intgreenfn: module for computing integrated Green functions -! -! Description: This module implements the derived types and subroutines -! for computing 'effective integrated Green functions'. -! -! Version: 0.1 -! Author: D.T.Abell, Tech-X Corp., Jan.2007 -! -! Comments -! 24.Jan.07 DTA: This module currently implements only the 3-D -! integrated Green functions for open boundary conditions. -! -!*********************************************************************** - module intgreenfn - !use parallel, only : idproc - implicit none -! -! data -! - double precision, parameter, private :: dtiny=1.d-13 -! -! derived types -! - type griddata - integer :: NxIntrvl,NyIntrvl,NzIntrvl - integer :: Nx,Ny,Nz,Nx2,Ny2,Nz2 - double precision :: xmin,xmax,ymin,ymax,zmin,zmax - double precision :: hx,hy,hz - double precision :: Vh,Vhinv - end type griddata -! -! functions and subroutines -! - contains -! -!*********************************************************************** - subroutine intgreenphi(grid,g) - use math_consts - implicit none - type(griddata), intent(in) :: grid -! complex*16, dimension(:,:,:), intent(out) :: g - complex*16,dimension(grid%Nx2,grid%Ny2,grid%Nz2),intent(out) :: g - - integer :: ix,nx1,nx12 - integer :: iy,ny1,ny12 - integer :: iz,nz1,nz12 - double precision :: invfourpi,gg,vh2i - - invfourpi=1/fourpi - vh2i = grid%vhinv ** 2 - nx1 = grid%Nx + 1; nx12 = 2 * nx1 - ny1 = grid%Ny + 1; ny12 = 2 * ny1 - nz1 = grid%Nz + 1; nz12 = 2 * nz1 - do iz = 1,nz1 - do iy = 1,ny1 - do ix = 1,nx1 - call geff3phi(grid%hx,grid%hy,grid%hz,ix-1,iy-1,iz-1,gg) - !g(ix,iy,iz) = vh2i * gg - g(ix,iy,iz) = invfourpi * gg - end do - do ix = nx1+1,grid%Nx2 - g(ix,iy,iz) = g(nx12-ix,iy,iz) - end do - end do - do iy = ny1+1,grid%Ny2 - do ix = 1,grid%Nx2 - g(ix,iy,iz) = g(ix,ny12-iy,iz) - end do - end do - end do - do iz = nz1+1,grid%Nz2 - do iy = 1,grid%Ny2 - do ix = 1,grid%Nx2 - g(ix,iy,iz) = g(ix,iy,nz12-iz) - end do - end do - end do - - return - end subroutine intgreenphi -! -!*********************************************************************** - subroutine geff3phi(hx,hy,hz,i,j,k,g) - implicit none - double precision, intent(in) :: hx,hy,hz - integer, intent(in) :: i,j,k - double precision, intent(out) :: g - - double precision :: g000,g001,g010,g011,g100,g101,g110,g111 - - call intg3(hx,hy,hz,i,j,k,0,0,0,g000) - call intg3(hx,hy,hz,i,j,k,0,0,1,g001) - call intg3(hx,hy,hz,i,j,k,0,1,0,g010) - call intg3(hx,hy,hz,i,j,k,0,1,1,g011) - call intg3(hx,hy,hz,i,j,k,1,0,0,g100) - call intg3(hx,hy,hz,i,j,k,1,0,1,g101) - call intg3(hx,hy,hz,i,j,k,1,1,0,g110) - call intg3(hx,hy,hz,i,j,k,1,1,1,g111) - - g = g000 - (g001 + g010 + g100) + (g011 + g101 + g110) - g111 - g = g/(hx*hy*hz)**2 - - return - end subroutine geff3phi -! -!*********************************************************************** - subroutine intg3(hx,hy,hz,i,j,k,r,s,t,g) - implicit none - double precision, intent(in) :: hx,hy,hz - integer, intent(in) :: i,j,k,r,s,t - double precision, intent(out) :: g - - double precision :: a,b,c,xl,xu,yl,yu,zl,zu - - a = hx*(i - 1 + 2*r); xl = hx*(i - 1 + r); xu = hx*(i + r) - b = hy*(j - 1 + 2*s); yl = hy*(j - 1 + s); yu = hy*(j + s) - c = hz*(k - 1 + 2*t); zl = hz*(k - 1 + t); zu = hz*(k + t) - - call defintg3(a,b,c,xl,xu,yl,yu,zl,zu,g) - - return - end subroutine intg3 -! -!*********************************************************************** - subroutine defintg3(a,b,c,xl,xu,yl,yu,zl,zu,g) - implicit none - double precision, intent(in) :: a,b,c - double precision, intent(in) :: xl,xu,yl,yu,zl,zu - double precision, intent(out) :: g - - double precision :: aa,ba,ca - double precision :: lll,llu,lul,ull,uul,ulu,luu,uuu - - aa=abs(a); ba=abs(b); ca=abs(c) - if (aa.lt.dtiny.and.ba.lt.dtiny.and.ca.lt.dtiny) then - call indef000(xl,yl,zl,lll) - call indef000(xl,yl,zu,llu) - call indef000(xl,yu,zl,lul) - call indef000(xl,yu,zu,luu) - call indef000(xu,yl,zl,ull) - call indef000(xu,yl,zu,ulu) - call indef000(xu,yu,zl,uul) - call indef000(xu,yu,zu,uuu) - else if (aa.lt.dtiny.and.ba.lt.dtiny) then - call indef00c(c,xl,yl,zl,lll) - call indef00c(c,xl,yl,zu,llu) - call indef00c(c,xl,yu,zl,lul) - call indef00c(c,xl,yu,zu,luu) - call indef00c(c,xu,yl,zl,ull) - call indef00c(c,xu,yl,zu,ulu) - call indef00c(c,xu,yu,zl,uul) - call indef00c(c,xu,yu,zu,uuu) - else if (aa.lt.dtiny.and.ca.lt.dtiny) then - call indef0b0(b,xl,yl,zl,lll) - call indef0b0(b,xl,yl,zu,llu) - call indef0b0(b,xl,yu,zl,lul) - call indef0b0(b,xl,yu,zu,luu) - call indef0b0(b,xu,yl,zl,ull) - call indef0b0(b,xu,yl,zu,ulu) - call indef0b0(b,xu,yu,zl,uul) - call indef0b0(b,xu,yu,zu,uuu) - else if (aa.lt.dtiny) then - call indef0bc(b,c,xl,yl,zl,lll) - call indef0bc(b,c,xl,yl,zu,llu) - call indef0bc(b,c,xl,yu,zl,lul) - call indef0bc(b,c,xl,yu,zu,luu) - call indef0bc(b,c,xu,yl,zl,ull) - call indef0bc(b,c,xu,yl,zu,ulu) - call indef0bc(b,c,xu,yu,zl,uul) - call indef0bc(b,c,xu,yu,zu,uuu) - else if (ba.lt.dtiny.and.ca.lt.dtiny) then - call indefa00(a,xl,yl,zl,lll) - call indefa00(a,xl,yl,zu,llu) - call indefa00(a,xl,yu,zl,lul) - call indefa00(a,xl,yu,zu,luu) - call indefa00(a,xu,yl,zl,ull) - call indefa00(a,xu,yl,zu,ulu) - call indefa00(a,xu,yu,zl,uul) - call indefa00(a,xu,yu,zu,uuu) - else if (ba.lt.dtiny) then - call indefa0c(a,c,xl,yl,zl,lll) - call indefa0c(a,c,xl,yl,zu,llu) - call indefa0c(a,c,xl,yu,zl,lul) - call indefa0c(a,c,xl,yu,zu,luu) - call indefa0c(a,c,xu,yl,zl,ull) - call indefa0c(a,c,xu,yl,zu,ulu) - call indefa0c(a,c,xu,yu,zl,uul) - call indefa0c(a,c,xu,yu,zu,uuu) - else if (ca.lt.dtiny) then - call indefab0(a,b,xl,yl,zl,lll) - call indefab0(a,b,xl,yl,zu,llu) - call indefab0(a,b,xl,yu,zl,lul) - call indefab0(a,b,xl,yu,zu,luu) - call indefab0(a,b,xu,yl,zl,ull) - call indefab0(a,b,xu,yl,zu,ulu) - call indefab0(a,b,xu,yu,zl,uul) - call indefab0(a,b,xu,yu,zu,uuu) - else - call indefabc(a,b,c,xl,yl,zl,lll) - call indefabc(a,b,c,xl,yl,zu,llu) - call indefabc(a,b,c,xl,yu,zl,lul) - call indefabc(a,b,c,xl,yu,zu,luu) - call indefabc(a,b,c,xu,yl,zl,ull) - call indefabc(a,b,c,xu,yl,zu,ulu) - call indefabc(a,b,c,xu,yu,zl,uul) - call indefabc(a,b,c,xu,yu,zu,uuu) - end if - g = uuu - (uul + ulu + luu) + (llu + lul + ull) - lll - - return - end subroutine defintg3 -! -!*********************************************************************** - subroutine aux23(a,b,v,r) - implicit none - double precision, intent(in) :: a,b,v - double precision, intent(out) :: r - - double precision :: d - - d = 2*v - 3*b - r = 0 - if (abs(d).gt.dtiny) r = d*atan(v*(3*v - 4*b)/(4*a*d)) - - return - end subroutine aux23 -! -!*********************************************************************** - subroutine aux34(b,c,v,w,v2,w2,vpr,r) - implicit none - double precision, intent(in) :: b,c,v,w,v2,w2,vpr - double precision, intent(out) :: r - - double precision :: d - - d = 3*w - 4*c - r = 0 - if (abs(d).gt.0.d0) r = d*log((v2+w2)*(4*vpr/(b*d*w*v2*w2))**2) - - return - end subroutine aux34 -! -!*********************************************************************** - subroutine indef000(u,v,w,g) - implicit none - double precision, intent(in) :: u,v,w - double precision, intent(out) :: g - - g = (u**2 + v**2 + w**2)**2.5d0/15.d0 - - return - end subroutine indef000 -! -!*********************************************************************** - subroutine indef00c(c,u,v,w,g) - implicit none - double precision, intent(in) :: c - double precision, intent(in) :: u,v,w - double precision, intent(out) :: g - - double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 - double precision :: u2v2 - - ua=abs(u); va=abs(v); wa=abs(w); - u2=u**2; v2=v**2; w2=w**2; - r2=u2+v2+w2; r=sqrt(r2); - upr=u+r; vpr=v+r; wpr=w+r; - - if (ua.lt.dtiny.and.va.lt.dtiny) then - g = (4*w2 - 5*c*w)*w2*wa/60.d0 - else if (va.lt.dtiny) then - g = (32*r2**2.5d0 + 5*c*(3*u2*(3*r2 + w2) - 4*r*w*(5*u2 + 2* & - & w2)) - 60*c*u2**2*log(wpr))/480.d0 - else if (wa.lt.dtiny) then - g = (32*r2**2.5d0 + 45*c*u2*(r2 + v2) - 30*c*r2**2*log(r2))/ & - & 480.d0 - else - u2v2 = u2 + v2 - g = (15*c*u2*(3*(r2 + v2) + w2) + 4*r*(8*r2**2 - 5*c*w*(2*r2 + & - & 3*u2v2)) - 60*c*u2*(u2v2 + v2)*log(wpr) - 30*c*v2**2* & - & log((v2 + w2) * ((4*wpr)/(3*c*v2**2*w2))**2))/480.d0 - end if - - return - end subroutine indef00c -! -!*********************************************************************** - subroutine indef0b0(b,u,v,w,g) - implicit none - double precision, intent(in) :: b - double precision, intent(in) :: u,v,w - double precision, intent(out) :: g - - double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 - - ua=abs(u); va=abs(v); wa=abs(w); - u2=u**2; v2=v**2; w2=w**2; - r2=u2+v2+w2; r=sqrt(r2); - upr=u+r; vpr=v+r; wpr=w+r; - - if (ua.lt.dtiny.and.wa.lt.dtiny) then - g = v2*(4*v2 - 5*b*v)*va/60.d0 - else if (va.lt.dtiny) then - g = (32*r2**2.5d0 + 15*b*u2*(r2 + w2) - 30*b*r2**2*log(r2))/ & - & 480.d0 - else if (wa.lt.dtiny) then - g = (32*r2**2.5d0 - 20*b*r*v*(5*u2 + 2*v2) + 15*b*u2**2*(1 - 4* & - & log(vpr)))/480.d0 - else - g = (4*r*(8*r2**2 - 5*b*v*(5*(u2 + w2) + 2*v2)) + 15*b*u2*(u2 + & - & 2*w2)*(1 - 4*log(vpr)) - 30*b*w2**2*log((16*(v2 + & - & w2)*vpr**2)/(9*b**2*v2**2*w2**4)))/480.d0 - end if - - return - end subroutine indef0b0 -! -!*********************************************************************** - subroutine indef0bc(b,c,u,v,w,g) - implicit none - double precision, intent(in) :: b,c - double precision, intent(in) :: u,v,w - double precision, intent(out) :: g - - double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 - double precision :: aux1,aux2 - - ua=abs(u); va=abs(v); wa=abs(w); - u2=u**2; v2=v**2; w2=w**2; - r2=u2+v2+w2; r=sqrt(r2); - upr=u+r; vpr=v+r; wpr=w+r; - - if (ua.lt.dtiny.and.va.lt.dtiny.and.wa.lt.dtiny) then - g = 0.d0 - else if (ua.lt.dtiny.and.va.lt.dtiny) then - g = w2*w*((16*w - 20*c)*wa - 15*b*(w - 4*c)*log(w2))/240.d0 - else if (ua.lt.dtiny.and.wa.lt.dtiny) then - g = v2*v*((16*v - 20*b)*va - 5*c*(3*v - 4*b)*log(v2))/240.d0 - else if (va.lt.dtiny) then - g = (15*u2*(c*(3*r2 + w2) + b*(r2 + w2 - 8*c*w)) + 4*r*(8* & - & r2**2 - 5*c*w*(5*u2 + 2*w2)) - 30*b*r2*(r2 - 4*c*w)* & - & log(r2) - 60*c*u2**2*log(wpr))/480.d0 - else if (wa.lt.dtiny) then - g = (5*u2*(b*(3*u2 - 56*c*v) + 9*c*(r2 + v2)) + 4*r*(8*r2**2 - & - & 5*b*v*(5*u2 + 2*v2)) + 160*b*c*u2*u*atan(v/u) - 10*c*(3* & - & r2**2 - 4*b*v*(r2 + 2*u2))*log(r2) - 60*b*u2**2*log(vpr))/ & - & 480.d0 - else if (ua.lt.dtiny) then - call aux34(b,c,v,w,v2,w2,vpr,aux1) - call aux34(c,b,w,v,w2,v2,wpr,aux2) - g = (2*r*(8*r2**2 + 5*(8*b*c*v*w - b*v*(5*w2 + 2*v2) - c*w*(5* & - & v2 + 2*w2))) + 40*b*c*w*w2*log(w2) - 5*b*w*w2*aux1 - 5*c* & - & v*v2*aux2)/240.d0 - else - call aux34(b,c,v,w,v2,w2,vpr,aux1) - call aux34(c,b,w,v,w2,v2,wpr,aux2) - g = (u2*(3*c*(3*(r2 + v2) + w2) + b*(3*u2 + 6*w2 - 8*c*(7*v + & - & 3*w))) + 0.8d0*r*(8*r2**2 - 5*(b*v*(2*r2 + 3*(u2 + w2)) + & - & c*w*(2*r2 + 3*(u2 + v2)) - 8*b*c*v*w)) + 32*b*c*u*u2* & - & (atan(v/u) - atan((v*w)/(u*r))) - 12*u2*(b*(u2 + 2*w*(w - & - & 2*c))*log(vpr) + c*(u2 + 2*v*(v - 2*b))*log(wpr)) + 16*b* & - & c*w*w2*log(u2 + w2) - 2*b*w*w2*aux1 - 2*c*v*v2*aux2)/96.d0 - end if - - return - end subroutine indef0bc -! -!*********************************************************************** - subroutine indefa00(a,u,v,w,g) - implicit none - double precision, intent(in) :: a - double precision, intent(in) :: u,v,w - double precision, intent(out) :: g - - double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 - double precision :: v2w2 - - ua=abs(u); va=abs(v); wa=abs(w); - u2=u**2; v2=v**2; w2=w**2; - r2=u2+v2+w2; r=sqrt(r2); - upr=u+r; vpr=v+r; wpr=w+r; - - if (ua.lt.dtiny.and.va.lt.dtiny.and.wa.lt.dtiny) then - g = 0.d0 - else if (va.lt.dtiny.and.wa.lt.dtiny) then - g = r*u2*(4*u2 - 5*a*u)/60.d0 - else - v2w2 = v2 + w2 - g = (r*(8*r2**2 - 5*a*u*(2*r2 + 3*v2w2)) - 15*a*v2w2**2* & - & log(upr))/120.d0 - end if - - return - end subroutine indefa00 -! -!*********************************************************************** - subroutine indefa0c(a,c,u,v,w,g) - implicit none - double precision, intent(in) :: a,c - double precision, intent(in) :: u,v,w - double precision, intent(out) :: g - - double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 - double precision :: u2v2,v2w2 - - ua=abs(u); va=abs(v); wa=abs(w); - u2=u**2; v2=v**2; w2=w**2; - r2=u2+v2+w2; r=sqrt(r2); - upr=u+r; vpr=v+r; wpr=w+r; - - if (ua.lt.dtiny.and.va.lt.dtiny.and.wa.lt.dtiny) then - g = 0.d0 - else if (ua.lt.dtiny.and.va.lt.dtiny) then - g = w2*w*((16*w - 20*c)*wa - 5*a*(3*w - 4*c)*log(w2))/240.d0 - else if (va.lt.dtiny.and.wa.lt.dtiny) then - g = u2*u*((96*u - 120*a)*ua + 5*c*((27*u - 40*a) - 6*(3*u - 4* & - & a)*log(u2)))/1440.d0 - else if (va.lt.dtiny) then - g = (5*c*u*(9*u*(3*r2 + w2) - 8*a*(5*u2 + 9*w2)) + & - & 12*r*(8*r2**2 + 5*(8*a*c*u*w - a*u*(2*r2 + 3*w2) - c*w*(2* & - & r2 + 3*u2))) + 60*a*w*(4*c - 3*w)*w2*log(upr) + 60*c*u*(4* & - & a - 3*u)*u2*log(wpr))/1440.d0 - else if (wa.lt.dtiny) then - g = (5*c*u*(27*u*(r2 + v2) - 8*a*(5*r2 + 16*v2)) + 12*r*(8* & - & r2**2 - 5*a*u*(2*r2 + 3*v2)) + 480*a*c*v*v2*(atan(u/v) + & - & atan((3*v)/(8*a))) - 30*c*(3*r2**2 - 4*a*u*(u2 + 3*v2))* & - & log(r2) - 180*a*v2**2*log(upr))/1440.d0 - else - u2v2 = u2 + v2 - v2w2 = v2 + w2 - g = (c*u*(9*u*(3*(r2 + v2) + w2) - 8*a*(5*r2 + 16*v2 + 4*w2)) + & - & 2.4d0*r*(8*r2**2 + 40*a*c*u*w - 5*a*u*(2*r2 + 3*v2w2) - 5* & - & c*w*(2*r2 + 3*u2v2)) + 96*a*c*v*v2*(atan(u/v) - atan((8*a* & - & u*w - 3*r*v2)/(v*(8*a*r + 3*u*w)))) - 12*a*(3*v2w2**2 - & - & 4*c*w*(3*v2 + w2))*log(upr) - 12*c*u*(3*u*(u2v2 + v2) - & - & 4*a*(u2v2 + 2*v2))*log(wpr) - 18*c*v2**2*log((v2w2/(64* & - & a**2 + 9*v2))*((4*wpr)/(c*v*v2*w2))**2))/288.d0 - end if - - return - end subroutine indefa0c -! -!*********************************************************************** - subroutine indefab0(a,b,u,v,w,g) - implicit none - double precision, intent(in) :: a,b - double precision, intent(in) :: u,v,w - double precision, intent(out) :: g - - double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 - - ua=abs(u); va=abs(v); wa=abs(w); - u2=u**2; v2=v**2; w2=w**2; - r2=u2+v2+w2; r=sqrt(r2); - upr=u+r; vpr=v+r; wpr=w+r; - - if (ua.lt.dtiny.and.va.lt.dtiny.and.wa.lt.dtiny) then - g = 0.d0 - else if (ua.lt.dtiny.and.wa.lt.dtiny) then - g = v2*v*((16*v - 20*b)*va - 5*a*(3*v - 4*b)*log(v2))/240.d0 - else if (va.lt.dtiny.and.wa.lt.dtiny) then - g = u2*u*((96*u - 120*a)*ua + 5*b*((9*u - 16*a) - 6*(3*u - 4* & - & a)*log(u2)))/1440.d0 - else if (wa.lt.dtiny) then - g = (5*b*u2*(9*u2 - 16*a*u) + 12*r*(8*r2**2 + 40*a*b*u*v - 5* & - & (a*u*(2*u2 + 5*v2) + b*v*(5*u2 + 2*v2))) + 60*(a*(4*b*v - & - & 3*v2)*v2*log(upr) + b*(4*a*u - 3*u2)*u2*log(vpr)))/1440.d0 - else if (va.lt.dtiny) then - g = (5*b*u*(9*u*(r2 + w2) - 16*a*(r2 + 5*w2)) + 12*r*(8*r2**2 - & - & 5*a*u*(2*u2 + 5*w2)) + 480*a*b*w*w2*(atan(u/w) + atan((3* & - & w)/(8*a))) - 30*b*(3*r2**2 - 4*a*u*(r2 + 2*w2))* & - & log(r2) - 180*a*w2**2*log(upr))/1440.d0 - else - g = (5*b*u*(9*u*(u2 + 2*w2) - 16*a*(u2 + 6*w2)) + 12*r*(8* & - & r2**2 + 40*a*b*u*v - 5*(a*u*(2*r2 + 3*(v2 + w2)) + b*v*(2* & - & r2 + 3*(u2 + w2)))) + 480*a*b*w*w2*(atan(u/w) - atan((8* & - & a*u*v - 3*r*w2)/((8*a*r + 3*u*v)*w))) + 60*a*(4*b*v*(v2 + & - & 3*w2) - 3*(v2 + w2)**2)*log(upr) - 60*b*u*(3*u*(u2 + 2* & - & w2) - 4*a*(u2 + 3*w2))*log(vpr) - 90*b*w2**2*log(((v2 + & - & w2)/(64*a**2 + 9*w2))*((4*vpr)/(b*w*v2*w2))**2))/1440.d0 - end if - - return - end subroutine indefab0 -! -!*********************************************************************** - subroutine indefabc(a,b,c,u,v,w,g) - implicit none - double precision, intent(in) :: a,b,c - double precision, intent(in) :: u,v,w - double precision, intent(out) :: g - - double precision :: r,r2,ua,upr,u2,va,vpr,v2,wa,wpr,w2 - double precision :: aux1,aux2 - - ua=abs(u); va=abs(v); wa=abs(w); - u2=u**2; v2=v**2; w2=w**2; - r2=u2+v2+w2; r=sqrt(r2); - upr=u+r; vpr=v+r; wpr=w+r; - - if (ua.lt.dtiny.and.va.lt.dtiny.and.wa.lt.dtiny) then - g = 0.d0 - else if (ua.lt.dtiny.and.va.lt.dtiny) then - call aux23(a,c,w,aux2) - g = w2*(4*wa*(4*w2 - 5*c*w) + 5*(8*a*b*aux2 + w*(4*c*(a + 3* & - & b) - 3*w*(a + b))*log(w2)))/240.d0 - else if (ua.lt.dtiny.and.wa.lt.dtiny) then - call aux23(a,b,v,aux1) - g = v2*(4*va*(4*v2 - 5*b*v) + 5*(8*a*c*aux1 + (a + c)*(4*b*v - & - & 3*v2)*log(v2)))/240.d0 - else if (va.lt.dtiny.and.wa.lt.dtiny) then - g = u*u2*(24*(4*u - 5*a)*ua + 5*(9*(b + 3*c)*u - 8*a*(2*b + & - & 5*c) + 6*(b + c)*(4*a - 3*u)*log(u2)))/1440.d0 - else if (va.lt.dtiny) then - call aux23(a,c,w,aux2) - g = (12*r*(8*r2**2 + 40*a*c*u*w - 5*(a*u*(2*u2 + 5*w2) + c*w* & - & (5*u2 + 2*w2))) + 5*u*(9*u*((b + 3*c)*u2 + 2*(b + 2*c)* & - & w2) - 8*a*(2*b + 5*c)*u2 + 72*b*c*(4*a - u)*w - 24*a*(4* & - & b + 3*c)*w2) + 240*a*b*w2*((2*w - 6*c)*atan(u/w) + aux2) + & - & 30*b*(4*a*u*(u2 - 6*c*w + 3*w2) + 3*r2*(4*c*w - r2))* & - & log(r2) + 60*(a*w*(4*c - 3*w)*w2*log(upr) + c*u*(4*a - 3* & - & u)*u2*log(wpr)))/ 1440.d0 - else if (wa.lt.dtiny) then - call aux23(a,b,v,aux1) - g = (5*u*(3*u*(3*(b + 3*c)*u2 + c*(18*v2 - 56*b*v)) - 8*a*((2* & - & b + 5*c)*u2 + c*(21*v2 - 54*b*v))) + 12*r*(8*r2**2 + 40*a* & - & b*u*v - 5*(a*u*(2*u2 + 5*v2) + b*v*(5*u2 + 2*v2))) - 240* & - & c*(b*(3*a - 2*u)*u2*atan(v/u) + a*v2*((3*b - 2*v)* & - & atan(u/v) - aux1)) + 30*c*(4*(a*u*(u2 - 3*(b - v)*v) + b* & - & v*(v2 - 3*(a - u)*u)) - 3*r2**2)*log(r2) + 60*(a*v*(4*b - & - & 3*v)*v2*log(upr) + b*u*(4*a - 3*u)*u2*log(vpr)))/1440.d0 - else if (ua.lt.dtiny) then - call aux23(a,b,v,aux1) - call aux23(a,c,w,aux2) - g = (12*r*(8*r2**2 + 40*b*c*v*w - 5*(b*v*(2*v2 + 5*w2) + c*w* & - & (5*v2 + 2*w2))) + 30*a*(4*b*v*(v2 + 3*w*(w - c)) + 4*c*w* & - & (w2 + 3*v*(v - b)) - 3*r2**2)*log(r2) + 240*b*c*w*w2* & - & log(w2) + 240*a*(b*w2*aux2 + c*v2*aux1) + 30*b*w*(4*c - 3* & - & w)*w2*log((1/(16*a**2*(3*c - 2*w)**2 + (4*c - 3*w)**2* & - & w2))*((4*r*vpr)/(b*v2*w2))**2) + 30*c*v*(4*b - 3*v)*v2* & - & log((1/(16*a**2*(3*b - 2*v)**2 + (4*b - 3*v)**2*v2))*((4* & - & r*wpr)/(c*v2*w2))**2))/1440.d0 - else - g = (2.4d0*r*(8*r2**2 + 40*(a*b*u*v + a*c*u*w + b*c*v*w) - 5* & - & (a*u*(2*u2 + 5*(v2 + w2)) + b*v*(5*(u2 + w2) + 2*v2) + c*w & - & *(5*(u2 + v2) + 2*w2))) + u*(3*u*(3*(b + 3*c)*u2 + 2*c*(9* & - & v - 28*b)*v - 24*b*c*w + 6*(b + 2*c)*w2) - 8*a*(2*b*(u2 - & - & 27*c*v - 18*c*w + 6*w2) + c*(5*u2 + 21*v2 + 9*w2))) - 144* & - & a*b*c*w2*atan(u/w) - 48*b*c*(3*a - 2*u)*u2*(atan(v/u) - & - & atan((v*w)/(u*r))) - 48*a*c*(3*b - 2*v)*v2*(atan(u/v) - & - & atan((4*a*u*(3*b - 2*v)*w - (4*b - 3*v)*v2*r)/(v*(u*(4* & - & b - 3*v)*w + 4*a*(3*b - 2*v)*r)))) - 48*a*b*(3*c - 2*w)* & - & w2*(atan(u/w) - atan((4*a*u*v*(3*c - 2*w) - (4*c - 3*w)* & - & w2*r)/(w*(u*v*(4*c - 3*w) + 4*a*(3*c - 2*w)*r)))) + 12*a* & - & (4*b*v*(v2 + 3*w*(w - c)) + 4*c*w*(w2 + 3*v*(v - b)) - 3* & - & (v2 + w2)**2)*log(upr) - 12*b*u*(3*u*(u2 + 2*w*(w - 2* & - & c)) - 4*a*(u2 + 3*w*(w - 2*c)))*log(vpr) - 12*c*u*(3*u* & - & (u2 + 2*v*(v - 2*b)) - 4*a*(u2 + 3*v*(v - 2*b)))* & - & log(wpr) + 48*b*c*w*w2*log(u2 + w2) + 6*b*w*(4*c - 3*w)* & - & w2*log(((v2 + w2)/(16*a**2*(3*c - 2*w)**2 + (4*c - 3*w)** & - & 2*w2))*((4*vpr)/(b*v2*w2))**2) + 6*c*v*(4*b - 3*v)*v2* & - & log(((v2 + w2)/(16*a**2*(3*b - 2*v)**2 + (4*b - 3*v)**2* & - & v2))*((4*wpr)/(c*v2*w2))**2))/288.d0 - end if - - return - end subroutine indefabc -! -!*********************************************************************** - end module intgreenfn - diff --git a/OpticsJan2020/MLI_light_optics/Src/hamdrift.f b/OpticsJan2020/MLI_light_optics/Src/hamdrift.f deleted file mode 100755 index 8288222..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/hamdrift.f +++ /dev/null @@ -1,58 +0,0 @@ -c -*************************************************** -c - subroutine hamdrift(h) -c -c computes the Hamiltonian for a drift. -c MARYLIE5.0 upgrade. -c Written by M.Venturini 5 Aug 1997. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - dimension h(monoms) -c - do i=7,monoms - h(i)=0.d0 - enddo -c - ptg=-1/beta - ptg2=ptg*ptg - ptg3=ptg*ptg2 - ptg4=ptg*ptg3 - ptg5=ptg*ptg4 - ptg6=ptg*ptg5 -c - h(13)=1/2.d0 - h(22)=1/2.d0 - h(27)=(-1 + ptg2)/2.d0 - h(53)=-ptg/2.d0 - h(76)=-ptg/2.d0 - h(83)=(3*ptg - 3*ptg3)/6.d0 - h(140)=1/8.d0 - h(149)=1/4.d0 - h(154)=(-1 + 3*ptg2)/4.d0 - h(195)=1/8.d0 - h(200)=(-1 + 3*ptg2)/4.d0 - h(209)=(3 - 18*ptg2 + 15*ptg4)/24.d0 - h(340)=-3*ptg/8.d0 - h(363)=-3*ptg/4.d0 - h(370)=(9*ptg - 15*ptg3)/12.d0 - h(443)=-3*ptg/8.d0 - h(450)=(9*ptg - 15*ptg3)/12.d0 - h(461)=(-45*ptg + 150*ptg3 - 105*ptg5)/120.d0 - h(714)=1/16.d0 - h(723)=3/16.d0 - h(728)=(-9 + 45*ptg2)/48.d0 - h(769)=3/16.d0 - h(774)=(-3 + 15*ptg2)/8.d0 - h(783)=(9 - 90*ptg2 + 105*ptg4)/48.d0 - h(896)=1/16.d0 - h(901)=(-9 + 45*ptg2)/48.d0 - h(910)=(9 - 90*ptg2 + 105*ptg4)/48.d0 - h(923)=(-45 + 675*ptg2 - 1575*ptg4 + 945*ptg6)/720.d0 -c - return - end -c end of file - diff --git a/OpticsJan2020/MLI_light_optics/Src/imkmpak.f b/OpticsJan2020/MLI_light_optics/Src/imkmpak.f deleted file mode 100644 index 33c2ee2..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/imkmpak.f +++ /dev/null @@ -1,1380 +0,0 @@ -c******************************************************************* -c ImKmpak is a collection of portable modified Bessel function routines. -c Written 4-96 by P. L. Walstrom Northrop Grumman -c Modified from CLAMS and Numerical Recipes. Should give 12-digit -c precision for all valid arguments. -c Should use exponentially scaled functions when x is greater than 20. -c Function routines: -c dbesI0s=I0 -c dbesI0es=exponentially scaled I0 -c dbesK0s=K0 -c dbesK0es=exponentially scaled K0 -c dbesI1s=I1 -c dbesI1es=exponentially scaled I1 -c dbesK1s=K1 -c dbesK1es=exponentially scaled K1 -c Subroutines: -c -c BESSIn( M,N,x,y,KODE) -c computes a M-member sequence I_k(x), k=N, N+1, N+2 ... N+M-1. -c KODE=1 means unscaled, KODE=2 is exponentially scaled. Results in vector -c y, with y(1)=I_N, y(2)=I_N+1, etc. -c -c -c bessKn( M,N,x,y,KODE) -c computes a M-member sequence K_k(x), k=N, N+1, N+2 ... N+M-1. -c KODE=1 means unscaled, KODE=2 is exponentially scaled. Results in vector -c y, with y(1)=K_N, y(2)=K_N+1, etc. -c -c -c Exponential scaling means for the I_m -c -c I_m (x) scaled = exp(-x) * I_m (x) unscaled -c -c and for the K_m -c -c K_m (x) scaled = exp(x) * K_m (x) unscaled -c -c******************************************************************* - subroutine BESSIn(M,N,X,y,KODE) - implicit double precision(a-h,o-z) -c Calculates an M-member sequence of modified Bessel functions of the -c first kind. Needs subroutines for exponentially scaled and unscaled -c I_0(x). Sequence contains either unscaled or scaled Bessel functions. -c KODE=1 means unscaled. -c KODE=2 means scaled. -c y(k), k=1,2,..m contains I_N (x),I_N+1 (x),...I_N+M-1 (x) -c N must be > or = 0. - PARAMETER(IACC=40,BIGNO=1.0d10,BIGNI=1.0d-10) - parameter(mmax=1000) - dimension y(m),z(mmax) -C - if(m.gt.20) go to 1005 - if(dabs(x).gt.0.1d0) go to 44 - if(dabs(x).ne.0.d0) go to 23 - do 24 l=1,m - if(n.eq.0) y(1)=1.d0 - 24 y(l)=0.d0 - return - 23 continue -c Series expansion for I_n, I_n+1, ...I_n+m-1. - if(m.gt.mmax) go to 1001 - qx2=0.25d0*x**2 - hfx=0.5d0*x -c Find 1/n! and (x/2)**n. - rnfac=1.d0 - hfxn=1.d0 - if(n.gt.0) hfxn=hfx - if(n.lt.2) go to 1 - do 2 l=2,n - hfxn=hfxn*hfx - 2 rnfac=rnfac/dfloat(l) - 1 y(1)=rnfac -c find 1/ (n+l)!, l=0,1,2...m-1. -c store in z(1),z(2)...z(m) - z(1)=rnfac - if(m.lt.2) go to 6 - do 3 l=2,m - z(l)=z(l-1)/dfloat(l+n-1) - 3 y(l)=z(l) - 6 yy=1.d0 - do 5 k=1,4 - yy=yy*qx2/dfloat(k) - do 5 l=1,m - z(l)=z(l)/dfloat(l+k+n-1) - 5 y(l)=y(l)+yy*z(l) - y(1)=y(1)*hfxn - if(m.lt.2) go to 9 - yy=hfxn - do 10 l=2,m - yy=yy*hfx - 10 y(l)=y(l)*yy - 9 continue - if(kode.eq.1) return -c convert vector of I_n, I_n+1...I_n+m-1 to exponentially scaled values - zz=dexp(-dabs(x)) - do 45 l=1,m - 45 y(l)=zz*y(l) - return -c Larger x- use downwards recursion - 44 n2=n+m-1 - IF (N.LT.0) PAUSE 'bad argument N < 0 in BESSIn' - if(dabs(x).gt.dfloat(2*n2)) go to 60 - TOX=2.d0/X - BIP=0.d0 - BI=1.d0 - do 21 k=1,m - 21 y(k)=0.d0 - MAX=2*((N2+dINT(dSQRT(dFLOAT(IACC*N2))))) - DO 11 J=MAX,1,-1 - BIM=BIP+dFLOAT(J)*TOX*BI - BIP=BI - BI=BIM -c Rescale large numbers - IF (dABS(BI).GT.BIGNO) THEN - BI=BI*BIGNI - BIP=BIP*BIGNI - jmax=N2 - jmin=j+1 - if(jmin.gt.jmax) go to 22 - jdif=n2-j - if(jdif.gt.m) go to 17 - do 13 jj=jmin,jmax - k=jj-jmax+m - 13 y(k)=y(k)*bigni - go to 22 - 17 do 18 k=1,m - 18 y(k)=y(k)*bigni - 22 continue - ENDIF -c Rescale small numbers. - IF (dABS(BI).lT.BIGNI) THEN - BI=BI*BIGNO - BIP=BIP*BIGNO - jmax=N2 - jmin=j+1 - if(jmin.gt.jmax) go to 25 - jdif=n2-j - if(jdif.gt.m) go to 19 - do 16 jj=jmin,jmax - k=jj-jmax+m - 16 y(k)=y(k)*bigno - go to 25 - 19 do 20 k=1,m - 20 y(k)=y(k)*bigno - 25 continue - ENDIF - do 14 k=1,m - ncheck=k+n2-m - 14 if(j.eq.ncheck) y(k)=bip -11 CONTINUE - if(KODE.eq.1) zz=dbesi0s(x) - if(KODE.eq.2) zz=dbsi0es(x) - do 15 k=1,m - 15 y(k)=y(k)*zz/BI - if(n.eq.0) y(1)=zz - RETURN -c Very large x- use upwards recursion - 60 continue - if(kode.eq.2) bim=dbsi0es(x) - if(kode.eq.2) bi=dbsi1es(x) - if(kode.eq.1) bim=dbesi0s(x) - if(kode.eq.1) bi=dbesi1s(x) - if(n.gt.1) go to 64 - if(n.gt.0) go to 63 -c n=0 - y(1)=bim - if(m.lt.2) return - y(2)=bi - if(m.lt.3) return - lmin=3 - go to 64 - 63 y(1)=bi - if(m.lt.2) return - lmin=2 - 64 n2=n+m-1 - if(n.gt.1) lmin=1 - tox=2.d0/x - do 61 j=1,n2-1 - bip=bim-dfloat(j)*tox*bi - bim=bi - bi=bip - do 62 l=lmin,m - jj=n+l-2 - 62 if(jj.eq.j) y(l)=bi - 61 continue - return - 1001 write(5,200) m,mmax - 200 format(1x,'m=',i4,' > mmax=',i4,' in BESSIN-stopped') - stop - 1005 write(6,201) m - 201 format(1x,'m in BESSIn= ',i2,' is > 20- stopped') - stop - END - DOUBLE PRECISION FUNCTION DBSI0Es(X) -c Stripped of extraneous calls, etc. to make it portable. -C***BEGIN PROLOGUE DBSI0E -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESI0E-S DBSI0E-D),BESSEL FUNCTION, -C EXPONENTIALLY SCALED,FIRST KIND, -C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, -C ORDER ZERO,SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the d.p. exponentially scaled hyperbolic Bessel -C function of the first kind of order zero. -C***DESCRIPTION -C -C DBSI0E(X) calculates the double precision exponentially scaled -C modified (hyperbolic) Bessel function of the first kind of order -C zero for double precision argument X. The result is the Bessel -C function I0(X) multiplied by EXP(-ABS(X)). -C -C Series for BI0 on the interval 0. to 9.00000E+00 -C with weighted error 9.51E-34 -C log weighted error 33.02 -C significant figures required 33.31 -C decimal places required 33.65 -C -C Series for AI0 on the interval 1.25000E-01 to 3.33333E-01 -C with weighted error 2.74E-32 -C log weighted error 31.56 -C significant figures required 30.15 -C decimal places required 32.39 -C -C Series for AI02 on the interval 0. to 1.25000E-01 -C with weighted error 1.97E-32 -C log weighted error 31.71 -C significant figures required 30.15 -C decimal places required 32.63 -C***REFERENCES (NONE) -C***ROUTINES CALLED DCSEVLs,INITDS -C***END PROLOGUE DBSI0E - DOUBLE PRECISION X, BI0CS(18), AI0CS(46), AI02CS(69), - 1 Y, DCSEVLs - SAVE BI0 CS, AI0 CS, AI02CS, NTI0, NTAI0, NTAI02 - DATA BI0 CS( 1) / -.7660547252 8391449510 8189497624 3285 D-1 / - DATA BI0 CS( 2) / +.1927337953 9938082699 5240875088 1196 D+1 / - DATA BI0 CS( 3) / +.2282644586 9203013389 3702929233 0415 D+0 / - DATA BI0 CS( 4) / +.1304891466 7072904280 7933421069 1888 D-1 / - DATA BI0 CS( 5) / +.4344270900 8164874513 7868268102 6107 D-3 / - DATA BI0 CS( 6) / +.9422657686 0019346639 2317174411 8766 D-5 / - DATA BI0 CS( 7) / +.1434006289 5106910799 6209187817 9957 D-6 / - DATA BI0 CS( 8) / +.1613849069 6617490699 1541971999 4611 D-8 / - DATA BI0 CS( 9) / +.1396650044 5356696994 9509270814 2522 D-10 / - DATA BI0 CS( 10) / +.9579451725 5054453446 2752317189 3333 D-13 / - DATA BI0 CS( 11) / +.5333981859 8625021310 1510774400 0000 D-15 / - DATA BI0 CS( 12) / +.2458716088 4374707746 9678591999 9999 D-17 / - DATA BI0 CS( 13) / +.9535680890 2487700269 4434133333 3333 D-20 / - DATA BI0 CS( 14) / +.3154382039 7214273367 8933333333 3333 D-22 / - DATA BI0 CS( 15) / +.9004564101 0946374314 6666666666 6666 D-25 / - DATA BI0 CS( 16) / +.2240647369 1236700160 0000000000 0000 D-27 / - DATA BI0 CS( 17) / +.4903034603 2428373333 3333333333 3333 D-30 / - DATA BI0 CS( 18) / +.9508172606 1226666666 6666666666 6666 D-33 / - DATA AI0 CS( 1) / +.7575994494 0237959427 2987203743 8 D-1 / - DATA AI0 CS( 2) / +.7591380810 8233455072 9297873320 4 D-2 / - DATA AI0 CS( 3) / +.4153131338 9237505018 6319749138 2 D-3 / - DATA AI0 CS( 4) / +.1070076463 4390730735 8242970217 0 D-4 / - DATA AI0 CS( 5) / -.7901179979 2128946607 5031948573 0 D-5 / - DATA AI0 CS( 6) / -.7826143501 4387522697 8898980690 9 D-6 / - DATA AI0 CS( 7) / +.2783849942 9488708063 8118538985 7 D-6 / - DATA AI0 CS( 8) / +.8252472600 6120271919 6682913319 8 D-8 / - DATA AI0 CS( 9) / -.1204463945 5201991790 5496089110 3 D-7 / - DATA AI0 CS( 10) / +.1559648598 5060764436 1228752792 8 D-8 / - DATA AI0 CS( 11) / +.2292556367 1033165434 7725480285 7 D-9 / - DATA AI0 CS( 12) / -.1191622884 2790646036 7777423447 8 D-9 / - DATA AI0 CS( 13) / +.1757854916 0324098302 1833124774 3 D-10 / - DATA AI0 CS( 14) / +.1128224463 2189005171 4441135682 4 D-11 / - DATA AI0 CS( 15) / -.1146848625 9272988777 2963387698 2 D-11 / - DATA AI0 CS( 16) / +.2715592054 8036628726 4365192160 6 D-12 / - DATA AI0 CS( 17) / -.2415874666 5626878384 4247572028 1 D-13 / - DATA AI0 CS( 18) / -.6084469888 2551250646 0609963922 4 D-14 / - DATA AI0 CS( 19) / +.3145705077 1754772937 0836026730 3 D-14 / - DATA AI0 CS( 20) / -.7172212924 8711877179 6217505917 6 D-15 / - DATA AI0 CS( 21) / +.7874493403 4541033960 8390960332 7 D-16 / - DATA AI0 CS( 22) / +.1004802753 0094624023 4524457183 9 D-16 / - DATA AI0 CS( 23) / -.7566895365 3505348534 2843588881 0 D-17 / - DATA AI0 CS( 24) / +.2150380106 8761198878 1205128784 5 D-17 / - DATA AI0 CS( 25) / -.3754858341 8308744291 5158445260 8 D-18 / - DATA AI0 CS( 26) / +.2354065842 2269925769 0075710532 2 D-19 / - DATA AI0 CS( 27) / +.1114667612 0479285302 2637335511 0 D-19 / - DATA AI0 CS( 28) / -.5398891884 3969903786 9677932270 9 D-20 / - DATA AI0 CS( 29) / +.1439598792 2407526770 4285840452 2 D-20 / - DATA AI0 CS( 30) / -.2591916360 1110934064 6081840196 2 D-21 / - DATA AI0 CS( 31) / +.2238133183 9985839074 3409229824 0 D-22 / - DATA AI0 CS( 32) / +.5250672575 3647711727 7221683199 9 D-23 / - DATA AI0 CS( 33) / -.3249904138 5332307841 7343228586 6 D-23 / - DATA AI0 CS( 34) / +.9924214103 2050379278 5728471040 0 D-24 / - DATA AI0 CS( 35) / -.2164992254 2446695231 4655429973 3 D-24 / - DATA AI0 CS( 36) / +.3233609471 9435940839 7333299199 9 D-25 / - DATA AI0 CS( 37) / -.1184620207 3967424898 2473386666 6 D-26 / - DATA AI0 CS( 38) / -.1281671853 9504986505 4833868799 9 D-26 / - DATA AI0 CS( 39) / +.5827015182 2793905116 0556885333 3 D-27 / - DATA AI0 CS( 40) / -.1668222326 0261097193 6450150399 9 D-27 / - DATA AI0 CS( 41) / +.3625309510 5415699757 0068480000 0 D-28 / - DATA AI0 CS( 42) / -.5733627999 0557135899 4595839999 9 D-29 / - DATA AI0 CS( 43) / +.3736796722 0630982296 4258133333 3 D-30 / - DATA AI0 CS( 44) / +.1602073983 1568519633 6551253333 3 D-30 / - DATA AI0 CS( 45) / -.8700424864 0572298845 2249599999 9 D-31 / - DATA AI0 CS( 46) / +.2741320937 9374811456 0341333333 3 D-31 / - DATA AI02CS( 1) / +.5449041101 4108831607 8960962268 0 D-1 / - DATA AI02CS( 2) / +.3369116478 2556940898 9785662979 9 D-2 / - DATA AI02CS( 3) / +.6889758346 9168239842 6263914301 1 D-4 / - DATA AI02CS( 4) / +.2891370520 8347564829 6692402323 2 D-5 / - DATA AI02CS( 5) / +.2048918589 4690637418 2760534093 1 D-6 / - DATA AI02CS( 6) / +.2266668990 4981780645 9327743136 1 D-7 / - DATA AI02CS( 7) / +.3396232025 7083863451 5084396952 3 D-8 / - DATA AI02CS( 8) / +.4940602388 2249695891 0482449783 5 D-9 / - DATA AI02CS( 9) / +.1188914710 7846438342 4084525196 3 D-10 / - DATA AI02CS( 10) / -.3149916527 9632413645 3864862961 9 D-10 / - DATA AI02CS( 11) / -.1321581184 0447713118 7540739926 7 D-10 / - DATA AI02CS( 12) / -.1794178531 5068061177 7943574026 9 D-11 / - DATA AI02CS( 13) / +.7180124451 3836662336 7106429346 9 D-12 / - DATA AI02CS( 14) / +.3852778382 7421427011 4089801777 6 D-12 / - DATA AI02CS( 15) / +.1540086217 5214098269 1325823339 7 D-13 / - DATA AI02CS( 16) / -.4150569347 2872220866 2689972015 6 D-13 / - DATA AI02CS( 17) / -.9554846698 8283076487 0214494312 5 D-14 / - DATA AI02CS( 18) / +.3811680669 3526224207 4605535511 8 D-14 / - DATA AI02CS( 19) / +.1772560133 0565263836 0493266675 8 D-14 / - DATA AI02CS( 20) / -.3425485619 6772191346 1924790328 2 D-15 / - DATA AI02CS( 21) / -.2827623980 5165834849 4205593759 4 D-15 / - DATA AI02CS( 22) / +.3461222867 6974610930 9706250813 4 D-16 / - DATA AI02CS( 23) / +.4465621420 2967599990 1042054284 3 D-16 / - DATA AI02CS( 24) / -.4830504485 9441820712 5525403795 4 D-17 / - DATA AI02CS( 25) / -.7233180487 8747539545 6227240924 5 D-17 / - DATA AI02CS( 26) / +.9921475412 1736985988 8046093981 0 D-18 / - DATA AI02CS( 27) / +.1193650890 8459820855 0439949924 2 D-17 / - DATA AI02CS( 28) / -.2488709837 1508072357 2054491660 2 D-18 / - DATA AI02CS( 29) / -.1938426454 1609059289 8469781132 6 D-18 / - DATA AI02CS( 30) / +.6444656697 3734438687 8301949394 9 D-19 / - DATA AI02CS( 31) / +.2886051596 2892243264 8171383073 4 D-19 / - DATA AI02CS( 32) / -.1601954907 1749718070 6167156200 7 D-19 / - DATA AI02CS( 33) / -.3270815010 5923147208 9193567485 9 D-20 / - DATA AI02CS( 34) / +.3686932283 8264091811 4600723939 3 D-20 / - DATA AI02CS( 35) / +.1268297648 0309501530 1359529710 9 D-22 / - DATA AI02CS( 36) / -.7549825019 3772739076 9636664410 1 D-21 / - DATA AI02CS( 37) / +.1502133571 3778353496 3712789053 4 D-21 / - DATA AI02CS( 38) / +.1265195883 5096485349 3208799248 3 D-21 / - DATA AI02CS( 39) / -.6100998370 0836807086 2940891600 2 D-22 / - DATA AI02CS( 40) / -.1268809629 2601282643 6872095924 2 D-22 / - DATA AI02CS( 41) / +.1661016099 8907414578 4038487490 5 D-22 / - DATA AI02CS( 42) / -.1585194335 7658855793 7970504881 4 D-23 / - DATA AI02CS( 43) / -.3302645405 9682178009 5381766755 6 D-23 / - DATA AI02CS( 44) / +.1313580902 8392397817 4039623117 4 D-23 / - DATA AI02CS( 45) / +.3689040246 6711567933 1425637280 4 D-24 / - DATA AI02CS( 46) / -.4210141910 4616891492 1978247249 9 D-24 / - DATA AI02CS( 47) / +.4791954591 0828657806 3171401373 0 D-25 / - DATA AI02CS( 48) / +.8459470390 2218217952 9971707412 4 D-25 / - DATA AI02CS( 49) / -.4039800940 8728324931 4607937181 0 D-25 / - DATA AI02CS( 50) / -.6434714653 6504313473 0100850469 5 D-26 / - DATA AI02CS( 51) / +.1225743398 8756659903 4464736990 5 D-25 / - DATA AI02CS( 52) / -.2934391316 0257089231 9879821175 4 D-26 / - DATA AI02CS( 53) / -.1961311309 1949829262 0371205728 9 D-26 / - DATA AI02CS( 54) / +.1503520374 8221934241 6229900309 8 D-26 / - DATA AI02CS( 55) / -.9588720515 7448265520 3386388206 9 D-28 / - DATA AI02CS( 56) / -.3483339380 8170454863 9441108511 4 D-27 / - DATA AI02CS( 57) / +.1690903610 2630436730 6244960725 6 D-27 / - DATA AI02CS( 58) / +.1982866538 7356030438 9400115718 8 D-28 / - DATA AI02CS( 59) / -.5317498081 4918162145 7583002528 4 D-28 / - DATA AI02CS( 60) / +.1803306629 8883929462 3501450390 1 D-28 / - DATA AI02CS( 61) / +.6213093341 4548931758 8405311242 2 D-29 / - DATA AI02CS( 62) / -.7692189292 7721618632 0072806673 0 D-29 / - DATA AI02CS( 63) / +.1858252826 1117025426 2556016596 3 D-29 / - DATA AI02CS( 64) / +.1237585142 2813957248 9927154554 1 D-29 / - DATA AI02CS( 65) / -.1102259120 4092238032 1779478779 2 D-29 / - DATA AI02CS( 66) / +.1886287118 0397044900 7787447943 1 D-30 / - DATA AI02CS( 67) / +.2160196872 2436589131 4903141406 0 D-30 / - DATA AI02CS( 68) / -.1605454124 9197432005 8446594965 5 D-30 / - DATA AI02CS( 69) / +.1965352984 5942906039 3884807331 8 D-31 / - DATA NTI0, NTAI0, NTAI02 / 3*0/ -C***FIRST EXECUTABLE STATEMENT DBSI0E - IF (NTI0.NE.0) GO TO 10 -c ETA = 0.1*SNGL(D1MACH(3)) -c replace above statement - eta=1.4d-18 - NTI0 = INITDSs (BI0CS, 18, ETA) - NTAI0 = INITDSs (AI0CS, 46, ETA) - NTAI02 = INITDSs (AI02CS, 69, ETA) -C - 10 Y = DABS(X) - IF (Y.GT.3.0D0) GO TO 20 -C - DBSI0Es = 1.0D0 - IF (Y.GT.1.d-15) DBSI0Es = DEXP(-Y) * (2.75D0 + - 1 DCSEVLs (Y*Y/4.5D0-1.D0, BI0CS, NTI0) ) - RETURN -C - 20 IF (Y.LE.8.D0) DBSI0Es = - & (0.375D0 + DCSEVLs ((48.D0/Y-11.D0)/5.D0, - 1 AI0CS, NTAI0))/DSQRT(Y) - IF (Y.GT.8.D0) DBSI0Es = - & (0.375D0 + DCSEVLs (16.D0/Y-1.D0, AI02CS, - 1 NTAI02))/DSQRT(Y) -C - RETURN - END - DOUBLE PRECISION FUNCTION DCSEVLs(X,A,N) -c Stripped down version - no XERROR call- stops on wrong input. -C***BEGIN PROLOGUE DCSEVLs -C***DATE WRITTEN 770401 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C3A2 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(CSEVL-S DCSEVLs-D),CHEBYSHEV, -C SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Evaluate the double precision N-term Chebyshev series A -C at X. -C***DESCRIPTION -C -C Evaluate the N-term Chebyshev series A at X. Adapted from -C R. Broucke, Algorithm 446, C.A.C.M., 16, 254 (1973). -C W. Fullerton, C-3, Los Alamos Scientific Laboratory. -C -C Input Arguments -- -C X double precision value at which the series is to be evaluated. -C A double precision array of N terms of a Chebyshev series. In -C evaluating A, only half of the first coefficient is summed. -C N number of terms in array A. -C***REFERENCES (NONE) -C***ROUTINES CALLED XERROR -C***END PROLOGUE DCSEVLs -C - DOUBLE PRECISION A(N),X,TWOX,B0,B1,B2 -C***FIRST EXECUTABLE STATEMENT DCSEVLs - IF(N.LT.1) go to 1001 - IF(N.GT.1000) go to 1002 - IF ((X.LT.-1.D0) .OR. (X.GT.1.D0)) go to 1003 -C - TWOX = 2.0D0*X - B1 = 0.D0 - B0=0.D0 - DO 10 I=1,N - B2=B1 - B1=B0 - NI = N - I + 1 - B0 = TWOX*B1 - B2 + A(NI) - 10 CONTINUE -C - DCSEVLs = 0.5D0 * (B0-B2) -C - RETURN - 1001 write(6,201) N - 201 format(1x,'N < 1 in DCSEVLs- stopped') - stop - 1002 write(6,202) N - 202 format(1x,'N>1000 in DCSEVLs- stopped') - stop - 1003 write(6,203) x - 203 format(1x,'x outside interval [-1,1] in DCSEVLs- stopped') - stop - END - FUNCTION INITDSs(DOS,NOS,ETA) -C***BEGIN PROLOGUE INITDS -C***DATE WRITTEN 770601 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C3A2 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(INITS-S INITDS-D),CHEBYSHEV, -C INITIALIZE,ORTHOGONAL POLYNOMIAL,ORTHOGONAL SERIES,SERIES, -C SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Initializes the d.p. properly normalized orthogonal -C polynomial series to determine the number of terms needed -C for specific accuracy. -C***DESCRIPTION -C -C Initialize the double precision orthogonal series DOS so that INITDS -C is the number of terms needed to insure the error is no larger than -C ETA. Ordinarily ETA will be chosen to be one-tenth machine precision -C -C Input Arguments -- -C DOS dble prec array of NOS coefficients in an orthogonal series. -C NOS number of coefficients in DOS. -C ETA requested accuracy of series. -C***REFERENCES (NONE) -C***ROUTINES CALLED XERROR -C***END PROLOGUE INITDS -C - DOUBLE PRECISION DOS(NOS) -C***FIRST EXECUTABLE STATEMENT INITDS - IF (NOS.LT.1) write(6,201) - 201 format( 'INITDS NUMBER OF COEFFICIENTS LT 1') -C - ERR = 0. - DO 10 II=1,NOS - I = NOS + 1 - II - ERR = ERR + ABS(DOS(I)) - IF (ERR.GT.ETA) GO TO 20 - 10 CONTINUE -C - 20 IF (I.EQ.NOS) write(6,200) - 200 format( 'INITDSs ETA MAY BE TOO SMALL') - INITDSs = I -C - RETURN - END - DOUBLE PRECISION FUNCTION DBSI1Es(X) -C***BEGIN PROLOGUE DBSI1E -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESI1E-S DBSI1E-D),BESSEL FUNCTION, -C EXPONENTIALLY SCALED,FIRST KIND, -C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, -C ORDER ONE,SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the d.p. exponentially scaled modified (hyper- -C bolic) Bessel function of the first kind of order one. -C***DESCRIPTION -C -C DBSI1E(X) calculates the double precision exponentially scaled -C modified (hyperbolic) Bessel function of the first kind of order -C one for double precision argument X. The result is I1(X) -C multiplied by EXP(-ABS(X)). -C -C Series for BI1 on the interval 0. to 9.00000E+00 -C with weighted error 1.44E-32 -C log weighted error 31.84 -C significant figures required 31.45 -C decimal places required 32.46 -C -C Series for AI1 on the interval 1.25000E-01 to 3.33333E-01 -C with weighted error 2.81E-32 -C log weighted error 31.55 -C significant figures required 29.93 -C decimal places required 32.38 -C -C Series for AI12 on the interval 0. to 1.25000E-01 -C with weighted error 1.83E-32 -C log weighted error 31.74 -C significant figures required 29.97 -C decimal places required 32.66 -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DCSEVL,INITDS,XERROR -C***END PROLOGUE DBSI1E - DOUBLE PRECISION X, BI1CS(17), AI1CS(46), AI12CS(69), XMIN, - 1 XSML, Y, DCSEVLs - SAVE BI1 CS, AI1 CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML - DATA BI1 CS( 1) / -.1971713261 0998597316 1385032181 49 D-2 / - DATA BI1 CS( 2) / +.4073488766 7546480608 1553936520 14 D+0 / - DATA BI1 CS( 3) / +.3483899429 9959455866 2450377837 87 D-1 / - DATA BI1 CS( 4) / +.1545394556 3001236038 5984010584 89 D-2 / - DATA BI1 CS( 5) / +.4188852109 8377784129 4588320041 20 D-4 / - DATA BI1 CS( 6) / +.7649026764 8362114741 9597039660 69 D-6 / - DATA BI1 CS( 7) / +.1004249392 4741178689 1798080372 38 D-7 / - DATA BI1 CS( 8) / +.9932207791 9238106481 3712980548 63 D-10 / - DATA BI1 CS( 9) / +.7663801791 8447637275 2001716813 49 D-12 / - DATA BI1 CS( 10) / +.4741418923 8167394980 3880919481 60 D-14 / - DATA BI1 CS( 11) / +.2404114404 0745181799 8631720320 00 D-16 / - DATA BI1 CS( 12) / +.1017150500 7093713649 1211007999 99 D-18 / - DATA BI1 CS( 13) / +.3645093565 7866949458 4917333333 33 D-21 / - DATA BI1 CS( 14) / +.1120574950 2562039344 8106666666 66 D-23 / - DATA BI1 CS( 15) / +.2987544193 4468088832 0000000000 00 D-26 / - DATA BI1 CS( 16) / +.6973231093 9194709333 3333333333 33 D-29 / - DATA BI1 CS( 17) / +.1436794822 0620800000 0000000000 00 D-31 / - DATA AI1 CS( 1) / -.2846744181 8814786741 0037246830 7 D-1 / - DATA AI1 CS( 2) / -.1922953231 4432206510 4444877497 9 D-1 / - DATA AI1 CS( 3) / -.6115185857 9437889822 5624991778 5 D-3 / - DATA AI1 CS( 4) / -.2069971253 3502277088 8282377797 9 D-4 / - DATA AI1 CS( 5) / +.8585619145 8107255655 3694467313 8 D-5 / - DATA AI1 CS( 6) / +.1049498246 7115908625 1745399786 0 D-5 / - DATA AI1 CS( 7) / -.2918338918 4479022020 9343232669 7 D-6 / - DATA AI1 CS( 8) / -.1559378146 6317390001 6068096907 7 D-7 / - DATA AI1 CS( 9) / +.1318012367 1449447055 2530287390 9 D-7 / - DATA AI1 CS( 10) / -.1448423418 1830783176 3913446781 5 D-8 / - DATA AI1 CS( 11) / -.2908512243 9931420948 2504099301 0 D-9 / - DATA AI1 CS( 12) / +.1266388917 8753823873 1115969040 3 D-9 / - DATA AI1 CS( 13) / -.1664947772 9192206706 2417839858 0 D-10 / - DATA AI1 CS( 14) / -.1666653644 6094329760 9593715499 9 D-11 / - DATA AI1 CS( 15) / +.1242602414 2907682652 3216847201 7 D-11 / - DATA AI1 CS( 16) / -.2731549379 6724323972 5146142863 3 D-12 / - DATA AI1 CS( 17) / +.2023947881 6458037807 0026268898 1 D-13 / - DATA AI1 CS( 18) / +.7307950018 1168836361 9869812612 3 D-14 / - DATA AI1 CS( 19) / -.3332905634 4046749438 1377861713 3 D-14 / - DATA AI1 CS( 20) / +.7175346558 5129537435 4225466567 0 D-15 / - DATA AI1 CS( 21) / -.6982530324 7962563558 5062922365 6 D-16 / - DATA AI1 CS( 22) / -.1299944201 5627607600 6044608058 7 D-16 / - DATA AI1 CS( 23) / +.8120942864 2427988920 5467834286 0 D-17 / - DATA AI1 CS( 24) / -.2194016207 4107368981 5626664378 3 D-17 / - DATA AI1 CS( 25) / +.3630516170 0296548482 7986093233 4 D-18 / - DATA AI1 CS( 26) / -.1695139772 4391041663 0686679039 9 D-19 / - DATA AI1 CS( 27) / -.1288184829 8979078071 1688253822 2 D-19 / - DATA AI1 CS( 28) / +.5694428604 9670527801 0999107310 9 D-20 / - DATA AI1 CS( 29) / -.1459597009 0904800565 4550990028 7 D-20 / - DATA AI1 CS( 30) / +.2514546010 6757173140 8469133448 5 D-21 / - DATA AI1 CS( 31) / -.1844758883 1391248181 6040002901 3 D-22 / - DATA AI1 CS( 32) / -.6339760596 2279486419 2860979199 9 D-23 / - DATA AI1 CS( 33) / +.3461441102 0310111111 0814662656 0 D-23 / - DATA AI1 CS( 34) / -.1017062335 3713935475 9654102357 3 D-23 / - DATA AI1 CS( 35) / +.2149877147 0904314459 6250077866 6 D-24 / - DATA AI1 CS( 36) / -.3045252425 2386764017 4620617386 6 D-25 / - DATA AI1 CS( 37) / +.5238082144 7212859821 7763498666 6 D-27 / - DATA AI1 CS( 38) / +.1443583107 0893824464 1678950399 9 D-26 / - DATA AI1 CS( 39) / -.6121302074 8900427332 0067071999 9 D-27 / - DATA AI1 CS( 40) / +.1700011117 4678184183 4918980266 6 D-27 / - DATA AI1 CS( 41) / -.3596589107 9842441585 3521578666 6 D-28 / - DATA AI1 CS( 42) / +.5448178578 9484185766 5051306666 6 D-29 / - DATA AI1 CS( 43) / -.2731831789 6890849891 6256426666 6 D-30 / - DATA AI1 CS( 44) / -.1858905021 7086007157 7190399999 9 D-30 / - DATA AI1 CS( 45) / +.9212682974 5139334411 2776533333 3 D-31 / - DATA AI1 CS( 46) / -.2813835155 6535611063 7083306666 6 D-31 / - DATA AI12CS( 1) / +.2857623501 8280120474 4984594846 9 D-1 / - DATA AI12CS( 2) / -.9761097491 3614684077 6516445730 2 D-2 / - DATA AI12CS( 3) / -.1105889387 6262371629 1256921277 5 D-3 / - DATA AI12CS( 4) / -.3882564808 8776903934 5654477627 4 D-5 / - DATA AI12CS( 5) / -.2512236237 8702089252 9452002212 1 D-6 / - DATA AI12CS( 6) / -.2631468846 8895195068 3705236523 2 D-7 / - DATA AI12CS( 7) / -.3835380385 9642370220 4500678796 8 D-8 / - DATA AI12CS( 8) / -.5589743462 1965838068 6811252222 9 D-9 / - DATA AI12CS( 9) / -.1897495812 3505412344 9892503323 8 D-10 / - DATA AI12CS( 10) / +.3252603583 0154882385 5508067994 9 D-10 / - DATA AI12CS( 11) / +.1412580743 6613781331 6336633284 6 D-10 / - DATA AI12CS( 12) / +.2035628544 1470895072 2452613684 0 D-11 / - DATA AI12CS( 13) / -.7198551776 2459085120 9258989044 6 D-12 / - DATA AI12CS( 14) / -.4083551111 0921973182 2849963969 1 D-12 / - DATA AI12CS( 15) / -.2101541842 7726643130 1984572746 2 D-13 / - DATA AI12CS( 16) / +.4272440016 7119513542 9778833699 7 D-13 / - DATA AI12CS( 17) / +.1042027698 4128802764 1741449994 8 D-13 / - DATA AI12CS( 18) / -.3814403072 4370078047 6707253539 6 D-14 / - DATA AI12CS( 19) / -.1880354775 5107824485 1273453396 3 D-14 / - DATA AI12CS( 20) / +.3308202310 9209282827 3190335240 5 D-15 / - DATA AI12CS( 21) / +.2962628997 6459501390 6854654205 2 D-15 / - DATA AI12CS( 22) / -.3209525921 9934239587 7837353288 7 D-16 / - DATA AI12CS( 23) / -.4650305368 4893583255 7128281897 9 D-16 / - DATA AI12CS( 24) / +.4414348323 0717079499 4611375964 1 D-17 / - DATA AI12CS( 25) / +.7517296310 8421048054 2545808029 5 D-17 / - DATA AI12CS( 26) / -.9314178867 3268833756 8484784515 7 D-18 / - DATA AI12CS( 27) / -.1242193275 1948909561 1678448869 7 D-17 / - DATA AI12CS( 28) / +.2414276719 4548484690 0515390217 6 D-18 / - DATA AI12CS( 29) / +.2026944384 0532851789 7192286069 2 D-18 / - DATA AI12CS( 30) / -.6394267188 2690977870 4391988681 1 D-19 / - DATA AI12CS( 31) / -.3049812452 3730958960 8488450357 1 D-19 / - DATA AI12CS( 32) / +.1612841851 6514802251 3462230769 1 D-19 / - DATA AI12CS( 33) / +.3560913964 3099250545 1027090462 0 D-20 / - DATA AI12CS( 34) / -.3752017947 9364390796 6682800324 6 D-20 / - DATA AI12CS( 35) / -.5787037427 0747993459 5198231074 1 D-22 / - DATA AI12CS( 36) / +.7759997511 6481619619 8236963209 2 D-21 / - DATA AI12CS( 37) / -.1452790897 2022333940 6445987408 5 D-21 / - DATA AI12CS( 38) / -.1318225286 7390367021 2192275337 4 D-21 / - DATA AI12CS( 39) / +.6116654862 9030707018 7999133171 7 D-22 / - DATA AI12CS( 40) / +.1376279762 4271264277 3024338363 4 D-22 / - DATA AI12CS( 41) / -.1690837689 9593478849 1983938230 6 D-22 / - DATA AI12CS( 42) / +.1430596088 5954331539 8720108538 5 D-23 / - DATA AI12CS( 43) / +.3409557828 0905940204 0536772990 2 D-23 / - DATA AI12CS( 44) / -.1309457666 2707602278 4573872642 4 D-23 / - DATA AI12CS( 45) / -.3940706411 2402574360 9352141755 7 D-24 / - DATA AI12CS( 46) / +.4277137426 9808765808 0616679735 2 D-24 / - DATA AI12CS( 47) / -.4424634830 9826068819 0028312302 9 D-25 / - DATA AI12CS( 48) / -.8734113196 2307149721 1530978874 7 D-25 / - DATA AI12CS( 49) / +.4045401335 6835333921 4340414242 8 D-25 / - DATA AI12CS( 50) / +.7067100658 0946894656 5160771780 6 D-26 / - DATA AI12CS( 51) / -.1249463344 5651052230 0286451860 5 D-25 / - DATA AI12CS( 52) / +.2867392244 4034370329 7948339142 6 D-26 / - DATA AI12CS( 53) / +.2044292892 5042926702 8177957421 0 D-26 / - DATA AI12CS( 54) / -.1518636633 8204625683 7134680291 1 D-26 / - DATA AI12CS( 55) / +.8110181098 1875758861 3227910703 7 D-28 / - DATA AI12CS( 56) / +.3580379354 7735860911 2717370327 0 D-27 / - DATA AI12CS( 57) / -.1692929018 9279025095 9305717544 8 D-27 / - DATA AI12CS( 58) / -.2222902499 7024276390 6775852777 4 D-28 / - DATA AI12CS( 59) / +.5424535127 1459696550 4860040112 8 D-28 / - DATA AI12CS( 60) / -.1787068401 5780186887 6491299330 4 D-28 / - DATA AI12CS( 61) / -.6565479068 7228149388 2392943788 0 D-29 / - DATA AI12CS( 62) / +.7807013165 0611452809 2206770683 9 D-29 / - DATA AI12CS( 63) / -.1816595260 6689797173 7933315222 1 D-29 / - DATA AI12CS( 64) / -.1287704952 6600848203 7687559895 9 D-29 / - DATA AI12CS( 65) / +.1114548172 9881645474 1370927369 4 D-29 / - DATA AI12CS( 66) / -.1808343145 0393369391 5936887668 7 D-30 / - DATA AI12CS( 67) / -.2231677718 2037719522 3244822893 9 D-30 / - DATA AI12CS( 68) / +.1619029596 0803415106 1790980361 4 D-30 / - DATA AI12CS( 69) / -.1834079908 8049414139 0130843921 0 D-31 / - DATA NTI1, NTAI1, NTAI12, XMIN, XSML / 3*0, 2*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBSI1Es - IF (NTI1.NE.0) GO TO 10 -c type *,'D1mach(3)',d1mach(3) - eta=1.4e-18 -c ETA = 0.1*SNGL(D1MACH(3)) -c type *,'eta',eta - NTI1 = INITDSs (BI1CS, 17, ETA) - NTAI1 = INITDSs (AI1CS, 46, ETA) - NTAI12 = INITDSs (AI12CS, 69, ETA) -C - XMIN = 4.d-39 -c type *,'D1mach(1)',d1mach(1) - XSML = 1.d-8 -C - 10 Y = DABS(X) - IF (Y.GT.3.0D0) GO TO 20 -C - DBSI1Es = 0.0D0 - IF (Y.EQ.0.D0) RETURN -C - IF (Y.LT.XMIN) write(6,301) - 301 format(1x,'DBSI1Es DABS(X) SO SMALL I1 UNDERFLOWS') - IF (Y.GT.XMIN) DBSI1Es = 0.5D0*X - IF (Y.GT.XSML) DBSI1Es = - & X*(0.875D0 + DCSEVLs (Y*Y/4.5D0-1.D0, - 1 BI1CS, NTI1) ) - DBSI1Es = DEXP(-Y) * DBSI1Es - RETURN -C - 20 IF (Y.LE.8.D0) DBSI1Es = - & (0.375D0 + DCSEVLs ((48.D0/Y-11.D0)/5.D0, - 1 AI1CS, NTAI1))/DSQRT(Y) - IF (Y.GT.8.D0) DBSI1Es = - & (0.375D0 + DCSEVLs (16.D0/Y-1.D0, AI12CS, - 1 NTAI12))/DSQRT(Y) - DBSI1Es = DSIGN (DBSI1Es, X) -C - RETURN - END - DOUBLE PRECISION FUNCTION DBESI1s(X) -C***BEGIN PROLOGUE DBESI1 -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESI1-S DBESI1-D),BESSEL FUNCTION, -C FIRST KIND,HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION,ORDER ONE,SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the d.p. modified (hyperbolic) Bessel function -C of the first kind of order one. -C***DESCRIPTION -C -C DBESI1(X) calculates the double precision modified (hyperbolic) -C Bessel function of the first kind of order one and double precision -C argument X. -C -C Series for BI1 on the interval 0. to 9.00000E+00 -C with weighted error 1.44E-32 -C log weighted error 31.84 -C significant figures required 31.45 -C decimal places required 32.46 -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DBSI1E,DCSEVL,INITDS,XERROR -C***END PROLOGUE DBESI1 - DOUBLE PRECISION X, BI1CS(17), XMAX, XMIN, XSML, Y, - 1 DCSEVLs, DBSI1Es - SAVE BI1 CS, NTI1, XMIN, XSML, XMAX - DATA BI1 CS( 1) / -.1971713261 0998597316 1385032181 49 D-2 / - DATA BI1 CS( 2) / +.4073488766 7546480608 1553936520 14 D+0 / - DATA BI1 CS( 3) / +.3483899429 9959455866 2450377837 87 D-1 / - DATA BI1 CS( 4) / +.1545394556 3001236038 5984010584 89 D-2 / - DATA BI1 CS( 5) / +.4188852109 8377784129 4588320041 20 D-4 / - DATA BI1 CS( 6) / +.7649026764 8362114741 9597039660 69 D-6 / - DATA BI1 CS( 7) / +.1004249392 4741178689 1798080372 38 D-7 / - DATA BI1 CS( 8) / +.9932207791 9238106481 3712980548 63 D-10 / - DATA BI1 CS( 9) / +.7663801791 8447637275 2001716813 49 D-12 / - DATA BI1 CS( 10) / +.4741418923 8167394980 3880919481 60 D-14 / - DATA BI1 CS( 11) / +.2404114404 0745181799 8631720320 00 D-16 / - DATA BI1 CS( 12) / +.1017150500 7093713649 1211007999 99 D-18 / - DATA BI1 CS( 13) / +.3645093565 7866949458 4917333333 33 D-21 / - DATA BI1 CS( 14) / +.1120574950 2562039344 8106666666 66 D-23 / - DATA BI1 CS( 15) / +.2987544193 4468088832 0000000000 00 D-26 / - DATA BI1 CS( 16) / +.6973231093 9194709333 3333333333 33 D-29 / - DATA BI1 CS( 17) / +.1436794822 0620800000 0000000000 00 D-31 / - DATA NTI1, XMIN, XSML, XMAX / 0, 3*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBESI1 - IF (NTI1.NE.0) GO TO 10 - eta=1.4d-18 - NTI1 = INITDSs (BI1CS, 17, eta) - XMIN = 4.0d-39 - XSML = 1.d-8 - XMAX = 86.d0 -C - 10 Y = DABS(X) - IF (Y.GT.3.0D0) GO TO 20 -C - DBESI1s = 0.D0 - IF (Y.EQ.0.D0) RETURN -C - IF (Y.LT.XMIN) - & write(6,*) 'DBESI1s DABS(X) SO SMALL IT UNDERFLOWS' - IF (Y.GT.XMIN) DBESI1s = 0.5D0*X - IF (Y.GT.XSML) DBESI1s = X*(0.875D0 + - & DCSEVLs (Y*Y/4.5D0-1.D0, - 1 BI1CS, NTI1)) - RETURN -C - 20 IF (Y.GT.XMAX) write(6,*)'DBESI1s DABS(X) SO BIG I1 OVERFLOWS' -C - DBESI1s = DEXP(Y) * DBSI1Es(X) -C - RETURN - END - DOUBLE PRECISION FUNCTION DBESI0s(X) -c Stripped version of CLAMS DBESI0 - no machine-dependent calls. -C***BEGIN PROLOGUE DBESI0 -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESI0-S DBESI0-D),BESSEL FUNCTION, -C FIRST KIND,HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION,ORDER ZERO,SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the d.p. hyperbolic Bessel function of the first -C kind of order zero. -C***DESCRIPTION -C -C DBESI0(X) calculates the double precision modified (hyperbolic) -C Bessel function of the first kind of order zero and double -C precision argument X. -C -C Series for BI0 on the interval 0. to 9.00000E+00 -C with weighted error 9.51E-34 -C log weighted error 33.02 -C significant figures required 33.31 -C decimal places required 33.65 -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DBSI0E,DCSEVL,INITDS,XERROR -C***END PROLOGUE DBESI0 - DOUBLE PRECISION X, BI0CS(18), XMAX, XSML, Y, - 1 DCSEVLs, DBSI0Es - SAVE BI0 CS, NTI0, XSML, XMAX - DATA BI0 CS( 1) / -.7660547252 8391449510 8189497624 3285 D-1 / - DATA BI0 CS( 2) / +.1927337953 9938082699 5240875088 1196 D+1 / - DATA BI0 CS( 3) / +.2282644586 9203013389 3702929233 0415 D+0 / - DATA BI0 CS( 4) / +.1304891466 7072904280 7933421069 1888 D-1 / - DATA BI0 CS( 5) / +.4344270900 8164874513 7868268102 6107 D-3 / - DATA BI0 CS( 6) / +.9422657686 0019346639 2317174411 8766 D-5 / - DATA BI0 CS( 7) / +.1434006289 5106910799 6209187817 9957 D-6 / - DATA BI0 CS( 8) / +.1613849069 6617490699 1541971999 4611 D-8 / - DATA BI0 CS( 9) / +.1396650044 5356696994 9509270814 2522 D-10 / - DATA BI0 CS( 10) / +.9579451725 5054453446 2752317189 3333 D-13 / - DATA BI0 CS( 11) / +.5333981859 8625021310 1510774400 0000 D-15 / - DATA BI0 CS( 12) / +.2458716088 4374707746 9678591999 9999 D-17 / - DATA BI0 CS( 13) / +.9535680890 2487700269 4434133333 3333 D-20 / - DATA BI0 CS( 14) / +.3154382039 7214273367 8933333333 3333 D-22 / - DATA BI0 CS( 15) / +.9004564101 0946374314 6666666666 6666 D-25 / - DATA BI0 CS( 16) / +.2240647369 1236700160 0000000000 0000 D-27 / - DATA BI0 CS( 17) / +.4903034603 2428373333 3333333333 3333 D-30 / - DATA BI0 CS( 18) / +.9508172606 1226666666 6666666666 6666 D-33 / - DATA NTI0, XSML, XMAX / 0, 2*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBESI0 - IF (NTI0.NE.0) GO TO 10 - NTI0 = INITDSs(BI0CS, 18, 1.4e-18) -c XSML = DSQRT (8.0D0*D1MACH(3)) - xsml=7.5d-9 -c XMAX = DLOG (D1MACH(2)) - xmax=86.4d0 -C - 10 Y = DABS(X) - IF (Y.GT.3.0D0) GO TO 20 -C - DBESI0s= 1.0D0 - IF (Y.GT.XSML) DBESI0s= 2.75D0 + DCSEVLs(Y*Y/4.5D0-1.D0, BI0CS, - 1 NTI0) - RETURN -C - 20 IF (Y.GT.XMAX) go to 1001 -C - DBESI0s= DEXP(Y) * DBSI0Es(X) -C - RETURN - 1001 write(6,*) 'X>XMAX in DBESI0s-stopped:XMAX=86.4,x=',x - stop - END - DOUBLE PRECISION FUNCTION DBESK0s(X) -c Stripped of machine-dependent calls . -C***BEGIN PROLOGUE DBESK0s -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESK0-S DBESK0s-D),BESSEL FUNCTION, -C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, -C ORDER ZERO,SPECIAL FUNCTIONS,THIRD KIND -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes d.p. modified (hyperbolic) Bessel function of -C the third kind of order zero. -C***DESCRIPTION -C -C DBESK0s(X) calculates the double precision modified (hyperbolic) -C Bessel function of the third kind of order zero for double -C precision argument X. The argument must be greater than zero -C but not so large that the result underflows. -C -C Series for BK0 on the interval 0. to 4.00000E+00 -C with weighted error 3.08E-33 -C log weighted error 32.51 -C significant figures required 32.05 -C decimal places required 33.11 -C***REFERENCES (NONE) -C***ROUTINES CALLED DBESI0,DBSK0E,DCSEVL,INITDS -C***END PROLOGUE DBESK0s - DOUBLE PRECISION X, BK0CS(16), XMAX, XSML, Y, - 1 DCSEVLs, DBESI0s, DBSK0Es - SAVE BK0 CS, NTK0, XSML, XMAX - DATA BK0 CS( 1) / -.3532739323 3902768720 1140060063 153 D-1 / - DATA BK0 CS( 2) / +.3442898999 2462848688 6344927529 213 D+0 / - DATA BK0 CS( 3) / +.3597993651 5361501626 5721303687 231 D-1 / - DATA BK0 CS( 4) / +.1264615411 4469259233 8479508673 447 D-2 / - DATA BK0 CS( 5) / +.2286212103 1194517860 8269830297 585 D-4 / - DATA BK0 CS( 6) / +.2534791079 0261494573 0790013428 354 D-6 / - DATA BK0 CS( 7) / +.1904516377 2202088589 7214059381 366 D-8 / - DATA BK0 CS( 8) / +.1034969525 7633624585 1008317853 089 D-10 / - DATA BK0 CS( 9) / +.4259816142 7910825765 2445327170 133 D-13 / - DATA BK0 CS( 10) / +.1374465435 8807508969 4238325440 000 D-15 / - DATA BK0 CS( 11) / +.3570896528 5083735909 9688597333 333 D-18 / - DATA BK0 CS( 12) / +.7631643660 1164373766 7498666666 666 D-21 / - DATA BK0 CS( 13) / +.1365424988 4407818590 8053333333 333 D-23 / - DATA BK0 CS( 14) / +.2075275266 9066680831 9999999999 999 D-26 / - DATA BK0 CS( 15) / +.2712814218 0729856000 0000000000 000 D-29 / - DATA BK0 CS( 16) / +.3082593887 9146666666 6666666666 666 D-32 / - DATA NTK0, XSML, XMAX / 0, 2*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBESK0s - IF (NTK0.NE.0) GO TO 10 - NTK0 = INITDSs(BK0CS, 16, 1.4e-18) - XSML = 7.5d-9 - XMAX = 86.4 -C - 10 if(x.le.0.d0) go to 1001 - IF (X.GT.2.0D0) GO TO 20 -C - Y = 0.D0 - IF (X.GT.XSML) Y = X*X - DBESK0s = -DLOG(0.5D0*X)*DBESI0s(X) - & - 0.25D0 + DCSEVLs(.5D0*Y-1.D0, - 1 BK0CS, NTK0) - RETURN -C - 20 DBESK0s = 0.D0 - IF (X.GT.XMAX) write(6,*)'DBESK0s X SO BIG K0 UNDERFLOWS' - IF (X.GT.XMAX) RETURN -C - DBESK0s = DEXP(-X) * DBSK0Es(X) -C - RETURN - 1001 write(6,*) 'DBESK0s X IS ZERO OR NEGATIVE- stopped' - stop - END - DOUBLE PRECISION FUNCTION DBSK0Es(X) -c Stripped of machine-dependent calls. -C***BEGIN PROLOGUE DBSK0Es -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESK0E-S DBSK0Es-D),BESSEL FUNCTION, -C EXPONENTIALLY SCALED,HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION,ORDER ZERO,SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the d.p. exponentially scaled modified (hyper- -C bolic) Bessel function of the third kind of order zero. -C***DESCRIPTION -C -C DBSK0Es(X) computes the double precision exponentially scaled -C modified (hyperbolic) Bessel function of the third kind of -C order zero for positive double precision argument X. -C -C Series for BK0 on the interval 0. to 4.00000E+00 -C with weighted error 3.08E-33 -C log weighted error 32.51 -C significant figures required 32.05 -C decimal places required 33.11 -C -C Series for AK0 on the interval 1.25000E-01 to 5.00000E-01 -C with weighted error 2.85E-32 -C log weighted error 31.54 -C significant figures required 30.19 -C decimal places required 32.33 -C -C Series for AK02 on the interval 0. to 1.25000E-01 -C with weighted error 2.30E-32 -C log weighted error 31.64 -C significant figures required 29.68 -C decimal places required 32.40 -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DBESI0,DCSEVL,INITDSs,XERROR -C***END PROLOGUE DBSK0Es - DOUBLE PRECISION X, BK0CS(16), AK0CS(38), AK02CS(33), - 1 XSML, Y, DCSEVLs,DBESI0s - SAVE BK0 CS, AK0 CS, AK02CS,NTK0, NTAK0, NTAK02, XSML - DATA BK0 CS( 1) / -.3532739323 3902768720 1140060063 153 D-1 / - DATA BK0 CS( 2) / +.3442898999 2462848688 6344927529 213 D+0 / - DATA BK0 CS( 3) / +.3597993651 5361501626 5721303687 231 D-1 / - DATA BK0 CS( 4) / +.1264615411 4469259233 8479508673 447 D-2 / - DATA BK0 CS( 5) / +.2286212103 1194517860 8269830297 585 D-4 / - DATA BK0 CS( 6) / +.2534791079 0261494573 0790013428 354 D-6 / - DATA BK0 CS( 7) / +.1904516377 2202088589 7214059381 366 D-8 / - DATA BK0 CS( 8) / +.1034969525 7633624585 1008317853 089 D-10 / - DATA BK0 CS( 9) / +.4259816142 7910825765 2445327170 133 D-13 / - DATA BK0 CS( 10) / +.1374465435 8807508969 4238325440 000 D-15 / - DATA BK0 CS( 11) / +.3570896528 5083735909 9688597333 333 D-18 / - DATA BK0 CS( 12) / +.7631643660 1164373766 7498666666 666 D-21 / - DATA BK0 CS( 13) / +.1365424988 4407818590 8053333333 333 D-23 / - DATA BK0 CS( 14) / +.2075275266 9066680831 9999999999 999 D-26 / - DATA BK0 CS( 15) / +.2712814218 0729856000 0000000000 000 D-29 / - DATA BK0 CS( 16) / +.3082593887 9146666666 6666666666 666 D-32 / - DATA AK0 CS( 1) / -.7643947903 3279414240 8297827008 8 D-1 / - DATA AK0 CS( 2) / -.2235652605 6998190520 2309555079 1 D-1 / - DATA AK0 CS( 3) / +.7734181154 6938582353 0061817404 7 D-3 / - DATA AK0 CS( 4) / -.4281006688 8860994644 5214643541 6 D-4 / - DATA AK0 CS( 5) / +.3081700173 8629747436 5001482666 0 D-5 / - DATA AK0 CS( 6) / -.2639367222 0096649740 6744889272 3 D-6 / - DATA AK0 CS( 7) / +.2563713036 4034692062 9408826574 2 D-7 / - DATA AK0 CS( 8) / -.2742705549 9002012638 5721191524 4 D-8 / - DATA AK0 CS( 9) / +.3169429658 0974995920 8083287340 3 D-9 / - DATA AK0 CS( 10) / -.3902353286 9621841416 0106571796 2 D-10 / - DATA AK0 CS( 11) / +.5068040698 1885754020 5009212728 6 D-11 / - DATA AK0 CS( 12) / -.6889574741 0078706795 4171355798 4 D-12 / - DATA AK0 CS( 13) / +.9744978497 8259176913 8820133683 1 D-13 / - DATA AK0 CS( 14) / -.1427332841 8845485053 8985534012 2 D-13 / - DATA AK0 CS( 15) / +.2156412571 0214630395 5806297652 7 D-14 / - DATA AK0 CS( 16) / -.3349654255 1495627721 8878205853 0 D-15 / - DATA AK0 CS( 17) / +.5335260216 9529116921 4528039260 1 D-16 / - DATA AK0 CS( 18) / -.8693669980 8907538076 3962237883 7 D-17 / - DATA AK0 CS( 19) / +.1446404347 8622122278 8776344234 6 D-17 / - DATA AK0 CS( 20) / -.2452889825 5001296824 0467875157 3 D-18 / - DATA AK0 CS( 21) / +.4233754526 2321715728 2170634240 0 D-19 / - DATA AK0 CS( 22) / -.7427946526 4544641956 9534129493 3 D-20 / - DATA AK0 CS( 23) / +.1323150529 3926668662 7796746240 0 D-20 / - DATA AK0 CS( 24) / -.2390587164 7396494513 3598146559 9 D-21 / - DATA AK0 CS( 25) / +.4376827585 9232261401 6571255466 6 D-22 / - DATA AK0 CS( 26) / -.8113700607 3451180593 3901141333 3 D-23 / - DATA AK0 CS( 27) / +.1521819913 8321729583 1037815466 6 D-23 / - DATA AK0 CS( 28) / -.2886041941 4833977702 3595861333 3 D-24 / - DATA AK0 CS( 29) / +.5530620667 0547179799 9261013333 3 D-25 / - DATA AK0 CS( 30) / -.1070377329 2498987285 9163306666 6 D-25 / - DATA AK0 CS( 31) / +.2091086893 1423843002 9632853333 3 D-26 / - DATA AK0 CS( 32) / -.4121713723 6462038274 1026133333 3 D-27 / - DATA AK0 CS( 33) / +.8193483971 1213076401 3568000000 0 D-28 / - DATA AK0 CS( 34) / -.1642000275 4592977267 8075733333 3 D-28 / - DATA AK0 CS( 35) / +.3316143281 4802271958 9034666666 6 D-29 / - DATA AK0 CS( 36) / -.6746863644 1452959410 8586666666 6 D-30 / - DATA AK0 CS( 37) / +.1382429146 3184246776 3541333333 3 D-30 / - DATA AK0 CS( 38) / -.2851874167 3598325708 1173333333 3 D-31 / - DATA AK02CS( 1) / -.1201869826 3075922398 3934621245 2 D-1 / - DATA AK02CS( 2) / -.9174852691 0256953106 5256107571 3 D-2 / - DATA AK02CS( 3) / +.1444550931 7750058210 4884387805 7 D-3 / - DATA AK02CS( 4) / -.4013614175 4357097286 7102107787 9 D-5 / - DATA AK02CS( 5) / +.1567831810 8523106725 9034899033 3 D-6 / - DATA AK02CS( 6) / -.7770110438 5217377103 1579975446 0 D-8 / - DATA AK02CS( 7) / +.4611182576 1797178825 3313052958 6 D-9 / - DATA AK02CS( 8) / -.3158592997 8605657705 2666580330 9 D-10 / - DATA AK02CS( 9) / +.2435018039 3650411278 3588781432 9 D-11 / - DATA AK02CS( 10) / -.2074331387 3983478977 0985337350 6 D-12 / - DATA AK02CS( 11) / +.1925787280 5899170847 4273650469 3 D-13 / - DATA AK02CS( 12) / -.1927554805 8389561036 0034718221 8 D-14 / - DATA AK02CS( 13) / +.2062198029 1978182782 8523786964 4 D-15 / - DATA AK02CS( 14) / -.2341685117 5792424026 0364019507 1 D-16 / - DATA AK02CS( 15) / +.2805902810 6430422468 1517882845 8 D-17 / - DATA AK02CS( 16) / -.3530507631 1618079458 1548246357 3 D-18 / - DATA AK02CS( 17) / +.4645295422 9351082674 2421633706 6 D-19 / - DATA AK02CS( 18) / -.6368625941 3442664739 2205346133 3 D-20 / - DATA AK02CS( 19) / +.9069521310 9865155676 2234880000 0 D-21 / - DATA AK02CS( 20) / -.1337974785 4236907398 4500531199 9 D-21 / - DATA AK02CS( 21) / +.2039836021 8599523155 2208896000 0 D-22 / - DATA AK02CS( 22) / -.3207027481 3678405000 6086997333 3 D-23 / - DATA AK02CS( 23) / +.5189744413 6623099636 2635946666 6 D-24 / - DATA AK02CS( 24) / -.8629501497 5405721929 6460799999 9 D-25 / - DATA AK02CS( 25) / +.1472161183 1025598552 0803840000 0 D-25 / - DATA AK02CS( 26) / -.2573069023 8670112838 1235199999 9 D-26 / - DATA AK02CS( 27) / +.4601774086 6435165873 7664000000 0 D-27 / - DATA AK02CS( 28) / -.8411555324 2010937371 3066666666 6 D-28 / - DATA AK02CS( 29) / +.1569806306 6353689393 0154666666 6 D-28 / - DATA AK02CS( 30) / -.2988226453 0057577889 7919999999 9 D-29 / - DATA AK02CS( 31) / +.5796831375 2168365206 1866666666 6 D-30 / - DATA AK02CS( 32) / -.1145035994 3476813321 5573333333 3 D-30 / - DATA AK02CS( 33) / +.2301266594 2496828020 0533333333 3 D-31 / - DATA NTK0, NTAK0, NTAK02, XSML / 3*0, 0.0D0 / -C***FIRST EXECUTABLE STATEMENT DBSK0Es - IF (NTK0.NE.0) GO TO 10 -c type *,d1mach(3) - ETA = 1.d-18 - NTK0 = INITDSs (BK0CS, 16, ETA) - NTAK0 = INITDSs (AK0CS, 38, ETA) - NTAK02 = INITDSs (AK02CS, 33, ETA) - XSML = 1.d-9 -c type *,xsml -C - 10 IF (X.LE.0.D0) write(6,*)'DBSK0Es X IS ZERO OR NEGATIVE' - IF (X.GT.2.0D0) GO TO 20 -C - Y = 0.D0 - IF (X.GT.XSML) Y = X*X - DBSK0Es = - & DEXP(X)*(-DLOG(0.5D0*X)*DBESI0s(X) - 0.25D0 + - 1 DCSEVLs (.5D0*Y-1.D0, BK0CS, NTK0)) - RETURN -C - 20 IF (X.LE.8.D0) DBSK0Es = - & (1.25D0 + DCSEVLs ((16.D0/X-5.D0)/3.D0, - 1 AK0CS, NTAK0))/DSQRT(X) - IF (X.GT.8.D0) DBSK0Es = (1.25D0 + - 1 DCSEVLs (16.D0/X-1.D0, AK02CS, NTAK02))/DSQRT(X) -C - RETURN - END - DOUBLE PRECISION FUNCTION DBSK1Es(X) -c Stripped of machine-dependent calls- same as CLAMS DBSK1E -C***BEGIN PROLOGUE DBSK1E -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESK1E-S DBSK1E-D),BESSEL FUNCTION, -C EXPONENTIALLY SCALED,HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION,ORDER ONE,SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the exponentially scaled,modified (hyperbolic) -C Bessel function of the third kind of order one (double -C precision). -C***DESCRIPTION -C -C DBSK1E(S) computes the double precision exponentially scaled -C modified (hyperbolic) Bessel function of the third kind of order -C one for positive double precision argument X. -C -C Series for BK1 on the interval 0. to 4.00000E+00 -C with weighted error 9.16E-32 -C log weighted error 31.04 -C significant figures required 30.61 -C decimal places required 31.64 -C -C Series for AK1 on the interval 1.25000E-01 to 5.00000E-01 -C with weighted error 3.07E-32 -C log weighted error 31.51 -C significant figures required 30.71 -C decimal places required 32.30 -C -C Series for AK12 on the interval 0. to 1.25000E-01 -C with weighted error 2.41E-32 -C log weighted error 31.62 -C significant figures required 30.25 -C decimal places required 32.38 -C***REFERENCES (NONE) -C***ROUTINES CALLED DBESI1,DCSEVLs,INITDS -C***END PROLOGUE DBSK1E - DOUBLE PRECISION X, BK1CS(16), AK1CS(38), AK12CS(33), XMIN, - 1 XSML, Y, DCSEVLs, DBESI1s - SAVE BK1 CS, AK1 CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML - DATA BK1 CS( 1) / +.2530022733 8947770532 5311208685 33 D-1 / - DATA BK1 CS( 2) / -.3531559607 7654487566 7238316918 01 D+0 / - DATA BK1 CS( 3) / -.1226111808 2265714823 4790679300 42 D+0 / - DATA BK1 CS( 4) / -.6975723859 6398643501 8129202960 83 D-2 / - DATA BK1 CS( 5) / -.1730288957 5130520630 1765073689 79 D-3 / - DATA BK1 CS( 6) / -.2433406141 5659682349 6007350301 64 D-5 / - DATA BK1 CS( 7) / -.2213387630 7347258558 3152525451 26 D-7 / - DATA BK1 CS( 8) / -.1411488392 6335277610 9583302126 08 D-9 / - DATA BK1 CS( 9) / -.6666901694 1993290060 8537512643 73 D-12 / - DATA BK1 CS( 10) / -.2427449850 5193659339 2631968648 53 D-14 / - DATA BK1 CS( 11) / -.7023863479 3862875971 7837971200 00 D-17 / - DATA BK1 CS( 12) / -.1654327515 5100994675 4910293333 33 D-19 / - DATA BK1 CS( 13) / -.3233834745 9944491991 8933333333 33 D-22 / - DATA BK1 CS( 14) / -.5331275052 9265274999 4666666666 66 D-25 / - DATA BK1 CS( 15) / -.7513040716 2157226666 6666666666 66 D-28 / - DATA BK1 CS( 16) / -.9155085717 6541866666 6666666666 66 D-31 / - DATA AK1 CS( 1) / +.2744313406 9738829695 2576662272 66 D+0 / - DATA AK1 CS( 2) / +.7571989953 1993678170 8923781492 90 D-1 / - DATA AK1 CS( 3) / -.1441051556 4754061229 8531161756 25 D-2 / - DATA AK1 CS( 4) / +.6650116955 1257479394 2513854770 36 D-4 / - DATA AK1 CS( 5) / -.4369984709 5201407660 5808450891 67 D-5 / - DATA AK1 CS( 6) / +.3540277499 7630526799 4171390085 34 D-6 / - DATA AK1 CS( 7) / -.3311163779 2932920208 9826882457 04 D-7 / - DATA AK1 CS( 8) / +.3445977581 9010534532 3114997709 92 D-8 / - DATA AK1 CS( 9) / -.3898932347 4754271048 9819374927 58 D-9 / - DATA AK1 CS( 10) / +.4720819750 4658356400 9474493390 05 D-10 / - DATA AK1 CS( 11) / -.6047835662 8753562345 3735915628 90 D-11 / - DATA AK1 CS( 12) / +.8128494874 8658747888 1938379856 63 D-12 / - DATA AK1 CS( 13) / -.1138694574 7147891428 9239159510 42 D-12 / - DATA AK1 CS( 14) / +.1654035840 8462282325 9729482050 90 D-13 / - DATA AK1 CS( 15) / -.2480902567 7068848221 5160104405 33 D-14 / - DATA AK1 CS( 16) / +.3829237890 7024096948 4292272991 57 D-15 / - DATA AK1 CS( 17) / -.6064734104 0012418187 7682103773 86 D-16 / - DATA AK1 CS( 18) / +.9832425623 2648616038 1940046506 66 D-17 / - DATA AK1 CS( 19) / -.1628416873 8284380035 6666201156 26 D-17 / - DATA AK1 CS( 20) / +.2750153649 6752623718 2841203370 66 D-18 / - DATA AK1 CS( 21) / -.4728966646 3953250924 2810695680 00 D-19 / - DATA AK1 CS( 22) / +.8268150002 8109932722 3920503466 66 D-20 / - DATA AK1 CS( 23) / -.1468140513 6624956337 1939648853 33 D-20 / - DATA AK1 CS( 24) / +.2644763926 9208245978 0858948266 66 D-21 / - DATA AK1 CS( 25) / -.4829015756 4856387897 9698688000 00 D-22 / - DATA AK1 CS( 26) / +.8929302074 3610130180 6563327999 99 D-23 / - DATA AK1 CS( 27) / -.1670839716 8972517176 9977514666 66 D-23 / - DATA AK1 CS( 28) / +.3161645603 4040694931 3686186666 66 D-24 / - DATA AK1 CS( 29) / -.6046205531 2274989106 5064106666 66 D-25 / - DATA AK1 CS( 30) / +.1167879894 2042732700 7184213333 33 D-25 / - DATA AK1 CS( 31) / -.2277374158 2653996232 8678400000 00 D-26 / - DATA AK1 CS( 32) / +.4481109730 0773675795 3058133333 33 D-27 / - DATA AK1 CS( 33) / -.8893288476 9020194062 3360000000 00 D-28 / - DATA AK1 CS( 34) / +.1779468001 8850275131 3920000000 00 D-28 / - DATA AK1 CS( 35) / -.3588455596 7329095821 9946666666 66 D-29 / - DATA AK1 CS( 36) / +.7290629049 2694257991 6799999999 99 D-30 / - DATA AK1 CS( 37) / -.1491844984 5546227073 0240000000 00 D-30 / - DATA AK1 CS( 38) / +.3073657387 2934276300 7999999999 99 D-31 / - DATA AK12CS( 1) / +.6379308343 7390010366 0048853410 2 D-1 / - DATA AK12CS( 2) / +.2832887813 0497209358 3503028470 8 D-1 / - DATA AK12CS( 3) / -.2475370673 9052503454 1454556673 2 D-3 / - DATA AK12CS( 4) / +.5771972451 6072488204 7097662576 3 D-5 / - DATA AK12CS( 5) / -.2068939219 5365483027 4553319655 2 D-6 / - DATA AK12CS( 6) / +.9739983441 3818041803 0921309788 7 D-8 / - DATA AK12CS( 7) / -.5585336140 3806249846 8889551112 9 D-9 / - DATA AK12CS( 8) / +.3732996634 0461852402 2121285473 1 D-10 / - DATA AK12CS( 9) / -.2825051961 0232254451 3506575492 8 D-11 / - DATA AK12CS( 10) / +.2372019002 4841441736 4349695548 6 D-12 / - DATA AK12CS( 11) / -.2176677387 9917539792 6830166793 8 D-13 / - DATA AK12CS( 12) / +.2157914161 6160324539 3956268970 6 D-14 / - DATA AK12CS( 13) / -.2290196930 7182692759 9155133815 4 D-15 / - DATA AK12CS( 14) / +.2582885729 8232749619 1993956522 6 D-16 / - DATA AK12CS( 15) / -.3076752641 2684631876 2109817344 0 D-17 / - DATA AK12CS( 16) / +.3851487721 2804915970 9489684479 9 D-18 / - DATA AK12CS( 17) / -.5044794897 6415289771 1728250880 0 D-19 / - DATA AK12CS( 18) / +.6888673850 4185442370 1829222399 9 D-20 / - DATA AK12CS( 19) / -.9775041541 9501183030 0213248000 0 D-21 / - DATA AK12CS( 20) / +.1437416218 5238364610 0165973333 3 D-21 / - DATA AK12CS( 21) / -.2185059497 3443473734 9973333333 3 D-22 / - DATA AK12CS( 22) / +.3426245621 8092206316 4538880000 0 D-23 / - DATA AK12CS( 23) / -.5531064394 2464082325 0124800000 0 D-24 / - DATA AK12CS( 24) / +.9176601505 6859954037 8282666666 6 D-25 / - DATA AK12CS( 25) / -.1562287203 6180249114 4874666666 6 D-25 / - DATA AK12CS( 26) / +.2725419375 4843331323 4943999999 9 D-26 / - DATA AK12CS( 27) / -.4865674910 0748279923 7802666666 6 D-27 / - DATA AK12CS( 28) / +.8879388552 7235025873 5786666666 6 D-28 / - DATA AK12CS( 29) / -.1654585918 0392575489 3653333333 3 D-28 / - DATA AK12CS( 30) / +.3145111321 3578486743 0399999999 9 D-29 / - DATA AK12CS( 31) / -.6092998312 1931276124 1600000000 0 D-30 / - DATA AK12CS( 32) / +.1202021939 3698158346 2399999999 9 D-30 / - DATA AK12CS( 33) / -.2412930801 4594088413 8666666666 6 D-31 / - DATA NTK1, NTAK1, NTAK12, XMIN, XSML / 3*0, 2*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBSK1Es - IF (NTK1.NE.0) GO TO 10 -c ETA = 0.1*SNGL(D1MACH(3)) - eta=1.4e-18 - NTK1 = INITDSs (BK1CS, 16, ETA) - NTAK1 = INITDSs (AK1CS, 38, ETA) - NTAK12 = INITDSs (AK12CS, 33, ETA) -C -c XMIN = DEXP (DMAX1(DLOG(D1MACH(1)), -DLOG(D1MACH(2))) + 0.01D0) - xmin=5.94d-39 -c XSML = DSQRT (4.0D0*D1MACH(3)) - xsml=7.5d-9 -C - 10 IF (X.LE.0.D0) write(6,*)'DBSK1Es X IS ZERO OR NEGATIVE' - IF (X.GT.2.0D0) GO TO 20 -C - IF (X.LT.XMIN) write(6,*)'DBSK1Es X SO SMALL K1 OVERFLOWS' - Y = 0.D0 - IF (X.GT.XSML) Y = X*X - DBSK1Es = DEXP(X)*(DLOG(0.5D0*X)*DBESI1s(X) + (0.75D0 + - 1 DCSEVLs (0.5D0*Y-1.D0, BK1CS, NTK1))/X ) - RETURN -C - 20 IF (X.LE.8.D0) DBSK1Es = - & (1.25D0 + DCSEVLs ((16.D0/X-5.D0)/3.D0, - 1 AK1CS, NTAK1))/DSQRT(X) - IF (X.GT.8.D0) DBSK1Es = (1.25D0 + - 1 DCSEVLs (16.D0/X-1.D0, AK12CS, NTAK12))/DSQRT(X) -C - RETURN - END - DOUBLE PRECISION FUNCTION DBESK1s(X) -C***BEGIN PROLOGUE DBESK1 -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESK1-S DBESK1-D),BESSEL FUNCTION, -C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, -C ORDER ONE,SPECIAL FUNCTIONS,THIRD KIND -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the dp modified Bessel function of the third kind -C of order one. -C***DESCRIPTION -C -C DBESK1(X) calculates the double precision modified (hyperbolic) -C Bessel function of the third kind of order one for double precision -C argument X. The argument must be large enough that the result does -C not overflow and small enough that the result does not underflow. -C -C Series for BK1 on the interval 0. to 4.00000E+00 -C with weighted error 9.16E-32 -C log weighted error 31.04 -C significant figures required 30.61 -C decimal places required 31.64 -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DBESI1,DBSK1E,DCSEVL,INITDS,XERROR -C***END PROLOGUE DBESK1 - DOUBLE PRECISION X, BK1CS(16), XMAX, XMIN, XSML, Y, - 1 DCSEVLs, DBESI1s, DBSK1Es - SAVE BK1 CS, NTK1, XMIN, XSML, XMAX - DATA BK1 CS( 1) / +.2530022733 8947770532 5311208685 33 D-1 / - DATA BK1 CS( 2) / -.3531559607 7654487566 7238316918 01 D+0 / - DATA BK1 CS( 3) / -.1226111808 2265714823 4790679300 42 D+0 / - DATA BK1 CS( 4) / -.6975723859 6398643501 8129202960 83 D-2 / - DATA BK1 CS( 5) / -.1730288957 5130520630 1765073689 79 D-3 / - DATA BK1 CS( 6) / -.2433406141 5659682349 6007350301 64 D-5 / - DATA BK1 CS( 7) / -.2213387630 7347258558 3152525451 26 D-7 / - DATA BK1 CS( 8) / -.1411488392 6335277610 9583302126 08 D-9 / - DATA BK1 CS( 9) / -.6666901694 1993290060 8537512643 73 D-12 / - DATA BK1 CS( 10) / -.2427449850 5193659339 2631968648 53 D-14 / - DATA BK1 CS( 11) / -.7023863479 3862875971 7837971200 00 D-17 / - DATA BK1 CS( 12) / -.1654327515 5100994675 4910293333 33 D-19 / - DATA BK1 CS( 13) / -.3233834745 9944491991 8933333333 33 D-22 / - DATA BK1 CS( 14) / -.5331275052 9265274999 4666666666 66 D-25 / - DATA BK1 CS( 15) / -.7513040716 2157226666 6666666666 66 D-28 / - DATA BK1 CS( 16) / -.9155085717 6541866666 6666666666 66 D-31 / - DATA NTK1, XMIN, XSML, XMAX / 0, 3*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBESK1s - IF (NTK1.NE.0) GO TO 10 - NTK1 = INITDSs (BK1CS, 16, 1.4e-18) -c XMIN = DEXP (DMAX1(DLOG(D1MACH(1)), -DLOG(D1MACH(2))) + 0.01D0) - xmin=5.94d-39 - xsml=7.5e-9 -c XSML = DSQRT (4.0D0*D1MACH(3)) -c XMAX = -DLOG(D1MACH(1)) -c XMAX = XMAX - 0.5D0*XMAX*DLOG(XMAX)/(XMAX+0.5D0) - xmax=86.4 -C - 10 IF (X.LE.0.D0) go to 1001 - IF (X.GT.2.0D0) GO TO 20 -C - IF (X.LT.XMIN) write(6,*)'DBESK1s X SO SMALL K1 OVERFLOWS' - Y=0.d0 - IF (X.GT.XSML) Y = X*X - DBESK1s = DLOG(0.5D0*X)*DBESI1s(X) + - & (0.75D0 + DCSEVLs(.5D0*Y-1.D0, - 1 BK1CS, NTK1))/X - RETURN -C - 20 DBESK1s = 0.D0 - IF (X.GT.XMAX) write(6,*)'DBESK1s X SO BIG K1 UNDERFLOWS' - IF (X.GT.XMAX) RETURN -C - DBESK1s = DEXP(-X) * DBSK1Es(X) -C - RETURN - 1001 write(6,*)'DBESK1s X IS ZERO OR NEGATIVE- stopped' - stop - END - subroutine BESSKn(M,N,X,y,KODE) - implicit double precision(a-h,o-z) -c Calculates an M-member sequence of modified Bessel functions of the -c 2nd kind. Needs subroutines for exponentially scaled and unscaled -c K_0(x) and K1(x). -c Sequence contains either unscaled or scaled Bessel functions. -c KODE=1 means unscaled. -c KODE=2 means scaled. -c y(k), k=1,2,..m contains K_N (x),K_N+1 (x),...K_N+M-1 (x) -c N must be > or = 0. - dimension y(m) - IF (N.LT.0) go to 1001 - if(kode.eq.2) bkm=dbsk0es(x) - if(kode.eq.2) bk=dbsk1es(x) - if(kode.eq.1) bkm=dbesk0s(x) - if(kode.eq.1) bk=dbesk1s(x) - if(n.gt.1) go to 64 - if(n.gt.0) go to 63 -c n=0 - y(1)=bkm - if(m.lt.2) return - y(2)=bk - if(m.lt.3) return - lmin=3 - go to 64 -c n=1 - 63 y(1)=bk - if(m.lt.2) return - lmin=2 - 64 n2=n+m-1 - if(n.gt.1) lmin=1 - tox=2.d0/x - do 61 j=1,n2-1 - bkp=bkm+dfloat(j)*tox*bk - bkm=bk - bk=bkp - do 62 l=lmin,m - jj=n+l-2 - 62 if(jj.eq.j) y(l)=bk - 61 continue - return - 1001 write(6,*) 'Stopped in BESSKn- N<0: N=',N - stop - end diff --git a/OpticsJan2020/MLI_light_optics/Src/inpu.f b/OpticsJan2020/MLI_light_optics/Src/inpu.f deleted file mode 100755 index 65aab06..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/inpu.f +++ /dev/null @@ -1,1857 +0,0 @@ -************************************************************************ -* header: INPUT AND OUTPUT * -* Input and output for maps, matrices, files, arrays, and parameter * -* sets * -************************************************************************ -c - subroutine cf(p) -c subroutine to close files -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' - dimension p(6),ip(6) - include 'files.inc' -c -c set up control indices - do 10 j=1,6 - ip(j)=nint(p(j)) - 10 continue -c -c close indicated files - do 20 j=1,6 - n=ip(j) - if( n.gt.0) close(unit=n, err=30) - go to 20 - 30 write(jof,*) 'error in closing file unit ',n - 20 continue -c - return - end -c -*********************************************************************** -c - subroutine fnamechk(fname,iu,ierr,str) -cryne -c R. Ryne 7/16/2002 -c check file names and associated unit number -c this is needed now that it is possible to open files w/ given names -c NB: At the end of this routine, only PE0 knows the file unit number iu, -c and only PE0 has an connection to file fname via file unit number iu. -c All PEs know the error flag ierr. - use parallel - logical ex,op,exu,opu,lname - character*16 fname,uname - character (len=*) str - integer n - common/bfileinfo/ifileinfo -!cryne===== 28 July, 2004 if(idproc.ne.0)return - if(idproc.eq.0)then -!cryne===== -! -! -! write(6,*)'here I ama in fnamemchk, iu=',iu - nmax=len_trim(str) - ierr=0 -cryne----- Jan 3, 2003: -c if the requested unit number =0, then the code should obtain -c a valid, unused unit number. -c For historical purposes (original Marylie used multiple files <~20), -c the unit numbers will be searched between 31 on upward. -c This should be irrelevant to the user, as these numbers will not be seen. - if(iu.eq.0)then - iumin=31 - iumax=1000 - do iuu=iumin,iumax - INQUIRE(UNIT=iuu,EXIST=exu,OPENED=opu,NAMED=lname,NAME=uname) - if(exu .and. .not.opu)then - iu=iuu - exit - endif - enddo - if(iu.eq.0)then - if(idproc.eq.0)write(6,*)'unable to find an available unit #' - ierr=1 - goto 9999 - endif - endif -cryne----- - INQUIRE(UNIT=iu,EXIST=exu,OPENED=opu,NAMED=lname,NAME=uname) - INQUIRE(FILE=fname,EXIST=ex,OPENED=op,NUMBER=numb) -c if the file is already open and connected to the unit specified -c by the user (or the default value in use), then everything is OK: - if(op.and.(numb.eq.iu))then - if(idproc.eq.0.and.fname.ne.' ')then - if(ifileinfo.ne.0)write(6,*)'(',str(1:nmax),') ', & - & 'file ',fname(1:16), ' will stay connected to unit ',iu - endif - goto 9999 - endif -c the file needs to be created and/or opened. -c first check to see if iu is a valid unit number: - if(.not.exu)then - write(6,*)'Error: file unit ',iu,' is not valid for this system.' - write(6,*)'It cannot be assigned to file ',fname - write(6,*)'command ',str(1:nmax),' will be ignored' - ierr=1 - goto 9999 - endif -c does the file exist? - if(.not.ex)then -c if not, create/open it: - if(fname.ne.' ')then - if(idproc.eq.0)then - if(ifileinfo.ne.0)write(6,*)'(',str(1:nmax),') ','creating ', & - & 'file ',fname(1:16), ' and connecting to unit ',iu - endif - open(unit=iu,file=fname,status='new') - else -cg95 open(unit=iu,status='new') - if(idproc.eq.0)write(6,*)'code should not get here' - call myexit - endif - goto 9999 - endif -c file exists. Is it open? -c if not, open it, but first make sure unit iu is not in use. - if(.not.op)then - if(.not.opu)then - if(idproc.eq.0.and.ifileinfo.ne.0)then - write(6,*)'(',str(1:nmax),') ','opening ', & - & 'existing file ',fname(1:16), ' and connecting to unit ',iu - write(6,*)'If written to, the file will be overwritten' - endif - open(unit=iu,file=fname,status='old') - goto 9999 - else - write(6,*)'file unit ',iu,' is already in use.' - write(6,*)'It cannot be assigned to file ',fname -c write(6,*)'command ',str(1:nmax),' will be ignored' -c ierr=1 - write(6,*)'instead the following file will be used: ',uname - goto 9999 - endif - else -c the file exists and is open. There must be a problem with -c conflicting unit numbers [numb.ne.iu] Fix it: -c write(6,*)'(',str(1:nmax),') Problem w/ file unit specification' -c write(6,*)'for file with name ',fname -c write(6,*)'File is already connected to unit ',numb -c write(6,*)'but user has specified (or default is) unit ',iu -c write(6,*)'Existing unit number will be used' -c - if(ifileinfo.ne.0)then - write(6,*)'(',str(1:nmax),') File named ',fname - write(6,*)'will continue to stay connected to unit ',numb - endif - iu=numb - goto 9999 - endif -c -!cryne===== 28 July 2004 only PE 0 executed the above code - 9999 continue - endif -!cryne===== 28 July 2004 now all PEs execute the following: - call ibcast(ierr) -cryne-abell: delete next four lines when read_egengrads works in || -c call ibcast(iu) -c if (idproc.ne.0.and.iu.ne.0) then -c open(unit=iu,file=fname,status='old') -c endif - return - end -c -*********************************************************************** -c - subroutine mapin(nopt,nskp,h,mh) -c read nonzero matrix elements and monomials from file unit mpi - use lieaparam, only : monoms - include 'impli.inc' - double precision h,mh - include 'files.inc' - dimension mh(6,6),h(monoms) -c Written by D. Douglas ca 1982 and modified by Rob Ryne -c and Alex Dragt ca 1986 -c - if(nopt.eq.0)goto 5 - rewind mpi - write(jof,210)mpi - 5 continue -c initialize arrays: - do 10 j=1,monoms - 10 h(j)=0.d0 - do 20 k=1,6 - do 20 l=1,6 - 20 mh(k,l)=0. -c -c skip nskp maps: - ns=nskp - 55 if(ns.eq.0)goto 100 - 60 read(mpi,*)i,j,temp - if(i.eq.6.and.j.eq.6)goto 80 - goto 60 - 80 read(mpi,*)k,temp - if(k.eq.monoms)goto 90 - goto 80 - 90 ns=ns-1 - goto 55 -c -c now read in the map: - 100 continue - 160 read(mpi,*)i,j,temp - mh(i,j)=temp - if(i.eq.6.and.j.eq.6)goto 180 - goto 160 - 180 read(mpi,*)k,temp - h(k)=temp - if(k.eq.monoms)goto 200 - goto 180 - 200 continue - write(6,205) mpi,nskp - 205 format(1x,'map read in from file ',i3,'; ',i3, - &' record(s) skipped') - 210 format(1x,'file unit ',i2,' rewound') - return - end -c -*********************************************************************** -c - subroutine mapout(nopt,h,mh) -c output present matrix and polynomials (nonzero values) -c Written by D. Douglas ca 1982 and modified by Rob Ryne -c and Alex Dragt ca 1984 -c modified Oct 89 by Tom Mottershead to work without requiring -c a prior map file. -c The parameter nopt is not currently used -c - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' -c -c calling arrays -c - double precision h,mh - dimension mh(6,6),h(monoms) -c -c check to see if file assignment makes sense - if(mpo .le. 0) return -c - nout=mpo -c - read(nout,*,end=5,err=19)dummy - 5 rewind(nout) -c -c count the # of lines in the file: - ncount=0 - 10 read(nout,*,end=15)dummy - ncount=ncount+1 - goto 10 - 15 continue - write(6,*)'found ',ncount,' lines in file ',nout - rewind(nout) - do n=1,ncount - read(nout,*)dummy - enddo - write(jof,*)'adding current map to file on unit ',nout - goto 25 -c -c read error means map file does not exist, so start a new one -c - 19 write(jof,21) nout - 21 format(' starting new map file on unit',i3) -c -c write out map -c - 25 continue - do 30 i=1,6 - do 30 j=1,6 - 30 if(mh(i,j).ne.0.)write(nout,*)i,j,mh(i,j) - if(mh(6,6).eq.0.)write(nout,*)6,6,mh(6,6) - do 40 k=1,monoms - 40 if(h(k).ne.0.)write(nout,*)k,h(k) - if(h(monoms).eq.0.)write(nout,*)monoms,h(monoms) -c write(jof,100) nout -c 100 format(1x,'map written on file ',i2) - return - end -c -*********************************************************************** -c - subroutine mapsnd(iopt,nmap,ta,tm,ha,hm) -c this is a subroutine for sending a map to some buffer or file -c Written by Alex Dragt, Spring 1987 - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'buffer.inc' - character*3 kynd -c - dimension ta(monoms),ha(monoms) - dimension tm(6,6),hm(6,6) -c -c procedure when iopt = 0 - if (iopt.eq.0) then - if (nmap.ge.1 .and. nmap.le.5) then - kynd='stm' - call strget(kynd,nmap,ta,tm) - endif -c - if (nmap.eq.0) call mapmap(ta,tm,ha,hm) -c - if (nmap.eq.-1) call mapmap(ta,tm,buf1a,buf1m) - if (nmap.eq.-2) call mapmap(ta,tm,buf2a,buf2m) - if (nmap.eq.-3) call mapmap(ta,tm,buf3a,buf3m) - if (nmap.eq.-4) call mapmap(ta,tm,buf4a,buf4m) - if (nmap.eq.-5) call mapmap(ta,tm,buf5a,buf5m) - endif -c -c procedure when iopt .gt. 0 - if (iopt.gt.0) then - mpot=mpo - mpo=iopt - call mapout(0,ta,tm) - mpo=mpot - endif -c - return - end -c -************************************************************************ -c - subroutine numfile(p) -c This is a subroutine for numbering lines in a file -c Written by Alex Dragt, Spring 1987 - use rays - include 'impli.inc' - dimension p(6) - write(6,*)'THIS ROUTINE (NUMFILE) NEEDS TO BE MODIFIED TO' - write(6,*)'EXECUTE PROPERLY IN PARALLEL' -c -c set up control indices - iopt=nint(p(1)) - nfile=nint(p(2)) - ifirst=nint(p(3)) - istep=nint(p(4)) -c -c procedure for writing out a file with numbered lines - line=ifirst - do 10 i=1,nraysp - write(nfile,100) line, - & zblock(1,i), zblock(2,i), zblock(3,i), - & zblock(4,i), zblock(5,i), zblock(6,i) - 100 format(1x,i5,6(1x,1pe11.4)) - line=line+istep - 10 continue -c - return - end -c -*********************************************************************** -c - subroutine of(p) -c subroutine to open files -c Written by Alex Dragt, Spring 1987 - include 'impli.inc' - character*6 unit - dimension p(6),ip(6) - dimension unit(50) - include 'files.inc' -c -c set up file names -c - data (unit(i),i=1,50)/ - &'unit01','unit02','unit03','unit04','unit05', - &'unit06','unit07','unit08','unit09','unit10', - &'unit11','unit12','unit13','unit14','unit15', - &'unit16','unit17','unit18','unit19','unit20', - &'unit21','unit22','unit23','unit24','unit25', - &'unit26','unit27','unit28','unit29','unit30', - &'unit31','unit32','unit33','unit34','unit35', - &'unit36','unit37','unit38','unit39','unit40', - &'unit41','unit42','unit43','unit44','unit45', - &'unit46','unit47','unit48','unit49','unit50'/ -cryne 7/23/2002 - save unit -c -c set up control indices - do 10 j=1,6 - ip(j)=nint(p(j)) - 10 continue -c -c open indicated files - do 20 j=1,6 - n=ip(j) - if( n.gt.0 .and. n.le.50 .and. n.ne.lf .and. n.ne.jof - & .and. n.ne.jodf) then - open(unit=n, file=unit(n), status='unknown', err=30) - endif - go to 20 - 30 write(jof,*) 'error in opening file unit ',n - 20 continue -c - return - end -c -*********************************************************************** -c - subroutine pcmap(n1,n2,n3,n4,fa,fm) -c routine to print m,f3,f4 and t,u. -c Written by D. Douglas ca 1982 and modified by Rob Ryne -c and Alex Dragt ca 1986 - use parallel - use lieaparam, only : monoms - include 'impli.inc' - integer colme(6,0:6) - include 'expon.inc' - include 'pbkh.inc' - include 'files.inc' - dimension fa(monoms),fm(6,6) - dimension t(monoms),u(monoms),u2(monoms) - if(idproc.ne.0)return -c -c test for matrix write - if(n1.eq.0) goto 20 -c -c procedure for writing out matrix -c write matrix at terminal - if(n1.eq.1.or.n1.eq.3)then - write(jof,13) - 13 format(/1h ,'matrix for map is :'/) - write(jof,15)((fm(k,i),i=1,6),k=1,6) - 15 format(6(1x,1pe12.5)) - write(jof,*) - write(jof,*)'nonzero matrix elements in full precision:' - do k=1,6 - do i=1,6 - if(fm(k,i).ne.0.d0)write(jof,155)k,i,fm(k,i) - 155 format(i1,2x,i1,2x,1pg21.14) - enddo - enddo - write(jof,*) - endif -c write matrix on file 12 - if(n1.eq.2.or.n1.eq.3)then - write(jodf,13) - write(jodf,15)((fm(k,i),i=1,6),k=1,6) - write(jodf,*) - write(jodf,*)'nonzero matrix elements in full precision:' - do k=1,6 - do i=1,6 - if(fm(k,i).ne.0.d0)write(jodf,155)k,i,fm(k,i) - enddo - enddo - write(jodf,*) - endif -c -c test for polynomial write - 20 continue - if(n2.eq.0)goto 30 -c -c procedure for writing out polynomial -c write polynomial at terminal - if(n2.eq.1.or.n2.eq.3)then - write(jof,22) - 22 format(/1h ,'nonzero elements in generating polynomial are :'/) - do 25 i=1,monoms -ccccc if(fa(i).eq.0.0d0) goto 25 - if(fa(i).eq.0.0d0) goto 25 - write(jof,27)i,(expon(j,i),j=1,6),fa(i) -cryne 6/21/2002 27 format(2x,'f(',i3,')=f( ',3(2i1,1x),')=',d21.14) - 27 format(2x,'f(',i3,')=f( ',3(2i1,1x),')=',1pg21.14) - 25 continue - endif -c write polynomial on file 12 - if(n2.eq.2.or.n2.eq.3)then - write(jodf,22) - do 26 i=1,monoms -c06jan2019 if(fa(i).eq.0.0d0) goto 26 - write(jodf,27)i,(expon(j,i),j=1,6),fa(i) - 26 continue - endif -c -c prepare for higher order matrix write if required - 30 continue -cryne write(6,*)'inside pcmap' - if(n3.gt.0.or.n4.gt.0)then -cryne write(6,*)'calling brkts' - call brkts(fa) -cryne write(6,*)'returned from brkts' - endif -c -c test for t matrix write - if(n3.eq.0) goto 40 -c -c procedure for writing t matrix -c write out heading - if(n3.eq.1.or.n3.eq.3)write(jof,32) - if(n3.eq.2.or.n3.eq.3)write(jodf,32) - 32 format(/1h ,'nonzero elements in second order matrix are :'/) -c write out contents - do 35 i=1,6 - call xform(pbh(1,i),2,fm,i-1,t) - do 36 n=7,27 - if(t(n).eq.0.0d0) goto 36 - if(n3.eq.1.or.n3.eq.3) - & write(jof,38) i,n,i,(expon(j,n),j=1,6),t(n) - if(n3.eq.2.or.n3.eq.3) - & write(jodf,38) i,n,i,(expon(j,n),j=1,6),t(n) -cryne6/21/02 38format(2x,'t',i1,'(',i3,')','=t',i1,'( ',3(2i1,1x),')=',d21.14) - 38 format(2x,'t',i1,'(',i3,')','=t',i1,'( ',3(2i1,1x),')=',1pg21.14) - 36 continue - 35 continue -c - -c test for u matrix write - 40 continue - if(n4.eq.0) goto 50 -c -c procedure for writing u matrix -c write out heading - if(n4.eq.1.or.n4.eq.3)write(jof,42) - if(n4.eq.2.or.n4.eq.3)write(jodf,42) - 42 format(/1h ,'nonzero elements in third order matrix are :'/) -c write out contents - do 44 i=1,6 - call xform(pbh(1,i),3,fm,i-1,u) - call xform(pbh(1,i+6),3,fm,1,u2) - do 45 n=28,83 - u(n)=u(n)+u2(n)/2.d0 - if(u(n).eq.0.0d0) goto 45 - if(n4.eq.1.or.n4.eq.3) - & write(jof,46) i,n,i,(expon(j,n),j=1,6),u(n) - if(n4.eq.2.or.n4.eq.3) - & write(jodf,46) i,n,i,(expon(j,n),j=1,6),u(n) -cryne 6/21/02 46format(2x,'u',i1,'(',i3,')','=u',i1,'( ',3(2i1,1x),')=',d21.14) - 46 format(2x,'u',i1,'(',i3,')','=u',i1,'( ',3(2i1,1x),')=',1pg21.14) - 45 continue - 44 continue -c -c procedure if all n's are zero or are faulty - 50 continue -c - return - end -c -*********************************************************************** -c - subroutine pset(p,k) -c subroutine to read in parameter set values -c the integer k labels the parameter set -c Written by Alex Dragt, Fall 1986 - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - dimension p(6) -c -c test on k - if (k.gt.maxpst .or. k.le.0) then - write(6,*) 'improper attempt to store parameters in - & a parameter set with k=',k - call myexit - endif -c -c store parameter values - do 10 i=1,6 - 10 pst(i,k)=p(i) -c - return - end -c -*********************************************************************** -c - subroutine psrmap(n1,n2,fa,fm) -c routine to print mij in the cartesian basis -c and the f's in the static resonance basis. -c Written by Alex Dragt, Fall 1986 -c - use lieaparam, only : monoms - include 'impli.inc' - include 'srl.inc' - include 'files.inc' - dimension fa(monoms),fm(6,6) -c -c beginning of routine -c -c writing out matrix - if(n1.eq.0)goto 20 - if(n1.eq.1.or.n1.eq.3)write(jof,33) - if(n1.eq.2.or.n1.eq.3)write(jodf,33) - 33 format(/1h ,'matrix for map is :'/) - if(n1.eq.1.or.n1.eq.3)write(jof,35)((fm(k,i),i=1,6),k=1,6) - if(n1.eq.2.or.n1.eq.3)write(jodf,35)((fm(k,i),i=1,6),k=1,6) -c 35 format(6(1x,e12.5)) - 35 format(6(1x,1pe12.5)) -c -c writing out f's - 20 if(n2.eq.0)goto 30 - if(n2.eq.1.or.n2.eq.3)write(jof,55) - if(n2.eq.2.or.n2.eq.3)write(jodf,55) - 55 format(/1h ,'nonzero elements in generating polynomial in',/, - &1x,'the static resonance basis are :'/) - do 22 i=1,monoms - if (fa(i).eq.0.0d0) go to 22 - if(n2.eq.1.or.n2.eq.3)write(jof,60)i,sln(i),fa(i) - if(n2.eq.2.or.n2.eq.3)write(jodf,60)i,sln(i),fa(i) - 60 format(1x,'f(',i3,')=f( ',a6,' )=',d21.14) - 22 continue -c - 30 continue - return - end -c -*********************************************************************** -c - subroutine pdrmap(n1,n2,fa,fm) -c routine to print mij in the cartesian basis -c and the f's in the dynamic resonance basis. -c F. Neri 6/3/1986 -c - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'drl.inc' - dimension fa(monoms),fm(6,6) -c -c beginning of routine -c -c writing out matrix - if(n1.eq.0)goto 20 - if(n1.eq.1.or.n1.eq.3)write(jof,33) - if(n1.eq.2.or.n1.eq.3)write(jodf,33) - 33 format(/1h ,'matrix for map is :'/) - if(n1.eq.1.or.n1.eq.3)write(jof,35)((fm(k,i),i=1,6),k=1,6) - if(n1.eq.2.or.n1.eq.3)write(jodf,35)((fm(k,i),i=1,6),k=1,6) -c 35 format(6(1x,e12.5)) - 35 format(6(1x,1pe12.5)) -c -c writing out f's - 20 if(n2.eq.0)goto 30 - if(n2.eq.1.or.n2.eq.3)write(jof,55) - if(n2.eq.2.or.n2.eq.3)write(jodf,55) - 55 format(/1h ,'nonzero elements in generating polynomial in',/, - &1x,'the dynamic resonance basis are :'/) - do 22 i=1,monoms - if (fa(i).eq.0.0d0) go to 22 - if(n2.eq.1.or.n2.eq.3)write(jof,60)i,dln(i),fa(i) - if(n2.eq.2.or.n2.eq.3)write(jodf,60)i,dln(i),fa(i) - 60 format(1x,'f(',i3,')=f( ',a7,' )=',d21.14) - 22 continue -c - 30 continue - return - end -c -***************************************************************** -c - subroutine pmif(iu,itype,fname) -c subroutine to write out the master input file -c written by Rob Ryne ca 1984 -ctm modified 9/01 to write unexpanded #include files -c - use parallel - use beamdata - use acceldata - use lieaparam, only : monoms - include 'impli.inc' - include 'codes.inc' - include 'incmif.inc' - include 'files.inc' -c - character*79 line - logical noitem, nolab - character*16 str1,fname -c -cryne 7/23/2002 don't know why this save statement was put here, -cryne but I will leave it for now. - save - if(idproc.ne.0)return -c------------------ -c start routine -c------------------ -ctm itype = 0 to echo input file as is -ctm itype = 1 to write input file from full internal commons. -ctm itype = 2 to write only #labor part -ctm itype = 3 to write from commons without expanding the #includes -c------------------------------------------------------- -c------------------------------------------------------- -c -c initialize loop limits for full common dump -c - noitem = .true. - if(nb.gt.0) noitem = .false. - nolab = .true. - if(noble.gt.0) nolab = .false. - kbgn = 1 - kend = na - ibgn = 1 - iend = nb - jbgn = 1 - jend = noble - goto(4,90,30)itype -c -c echo exact contents of file lf: (for out of bounds itype) -c - rewind lf - 1 read(lf,1002,end=3)line - 1002 format(a) - write(iu,1003)line - 1003 format(1x,a) - goto 1 - 3 continue - write(iu,*) - return -c -ctm reset loop limits to exclude #includes -c - 30 continue - if(ninc.eq.0) go to 4 - kend = na1 - noitem = .true. - if((nb1.gt.0).and.(nb2.eq.nb)) then - ibgn = 1 - iend = nb1 - noitem = .false. - endif - if((nb2.gt.0).and.(nb.gt.nb2)) then - ibgn = nb2 + 1 - iend = nb - noitem = .false. - endif - jbgn = noble2 + 1 -c -c -c write from internal commons -c - 4 continue -c -c comments - if(np.eq.0)goto 5 - write(iu,530)ling(1) - write(iu,6)(mline(i),i=1,np) -c mline is character*80, but is written out with an a79 format -c so that the last character (which should be a blank) does not -c cause carriage returns (and hence blank lines) on laser printers - 6 format(a79) -c 6 format(a80) -c beam - 5 write(iu,530)ling(2) - write(iu,*)brho - write(iu,*)gamm1 - write(iu,*)achg - write(iu,*)sl -c menu - write(iu,530)ling(3) -cryne quick hack to check for long names in the menu: - longnm=0 - do 10 k=kbgn,kend - str1=lmnlbl(k) - if(str1(9:9).ne.' ')longnm=1 - if(longnm.eq.0)write(iu,600)lmnlbl(k),ltc(nt1(k),nt2(k)) - if(longnm.eq.1)write(iu,6000)trim(lmnlbl(k)),ltc(nt1(k),nt2(k)) - imax=nrp(nt1(k),nt2(k)) - if(imax.eq.0)goto 10 - write(iu,603)(pmenu(i+mpp(k)),i=1,imax) - 10 continue -c -ctm explicit #include -c - if(itype.eq.3) then - if(ninc.eq.0) go to 50 - write(iu,530)ling(8) - do 35 jj = 1, ninc - write(iu,33) incfil(jj) - 33 format(2x,a) - 35 continue - endif -c lines,lumps,loops - 50 if(noitem)goto 90 - do 40 ii=2,4 - write(iu,530)ling(ii+2) - do 20 k=ibgn,iend - if(ityp(k).ne.ii)goto 20 - write(iu,790)ilbl(k) - if(longnm.eq.0)write(iu,791)(irep(l,k),icon(l,k),l=1,ilen(k)) - if(longnm.eq.1) & - & write(iu,7910)(irep(l,k),trim(icon(l,k)),l=1,ilen(k)) - 20 continue - 40 continue -c labor - 90 if(nolab)goto 999 - write(iu,530)ling(7) - do 100 j=jbgn,jend - 100 write(iu,800)num(j),latt(j) -c 529 format(1h ,'#comments') - 530 format(1h ,a8) - 600 format(1h ,1x,a8,1x,a8) - 6000 format(1h ,1x,a,1x,a8) -c 603 format((1h ,3(1x,d22.15))) -c Output using Mottershead's favorite pg format - 603 format((1h ,3(1x,1pg22.15))) -cryne 790 format(1h ,1x,a8) - 790 format(1h ,1x,a) - 791 format((1h ,1x,5(i5,'*',a8),1x,:'&')) -cryne 7910 format((1h ,1x,3(i5,'*',a28),1x,:'&')) - 7910 format((1h ,1x,5(i5,'*',a),1x,:'&')) -cryne 800 format(1h ,1x,i4,'*',a8) - 800 format(1h ,1x,i4,'*',a) - 999 continue -c write(iu,*) - return - end -c -****************************************************************** -c - subroutine randin(nfile,kt1,kt2,p) -c This is a subroutine for reading in and checking the parameters -c for random elements. -c Written by Alex Dragt, ca 1985, and modified by F. Neri -c and Alex Dragt on 29 January 1988 - use lieaparam, only : monoms - include 'impli.inc' - double precision p(6) - include 'files.inc' - include 'codes.inc' - include 'parset.inc' -c - if(nfile.gt.0) then -c Read in parameters from file: - 2 read(nfile,*,end=4,err=6)(p(i),i=1,nrp(kt1,kt2)) - goto 8 - 4 rewind nfile - goto 2 - 6 write(6,7) nfile,kt1,kt2 - 7 format(1x,'nfile=',i4,'kt1,kt2=',2i4,'error in randin') - call myexit - 8 continue - else if(nfile.lt.0) then -c Read in parameters form parameter sets: - npar = -nfile - if(npar.gt.maxpst) then - write(jof,*) ' num of pset too large in rnd lmnt.' - call myexit - endif - do 7008 i=1,6 - p(i) = pst(i,npar) - 7008 continue - else - write(jof,*) ' zero pset number in rnd lmnt.' - call myexit - endif -c -c Check on parameter values corresponding to control indices: - goto(10,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160, - &170),kt2 - return -c -c drift: - 10 continue - return -c -c normal entry bend: - 20 call rcheck(0,1,p(3),'lfrn','nbnd',nfile) - call rcheck(0,1,p(4),'tfrn','nbnd',nfile) - return -c -c parallel faced bend: - 30 continue - return -c -c general bending magnet: - 40 call rcheck(0,1,p(5),'lfrn','gbnd',nfile) - call rcheck(0,1,p(6),'tfrn','gbnd',nfile) - return -c -c leading or trailing rotation for a parallel faced bend: - 50 call rcheck(0,1,p(2),'kind','prot',nfile) - return -c -c body of a general bending magnet: - 60 continue - return -c -c hard edge fringe fields of a normal entry bend: - 70 call rcheck(0,1,p(2),'iedg','frng',nfile) - return -c -c combined function bend: - 80 continue - return -c -c quadrupole: - 90 call rcheck(0,1,p(3),'lfrn','quad',nfile) - call rcheck(0,1,p(4),'tfrn','quad',nfile) - return -c -c sextupole: - 100 continue - return -c -c mag. octupole: - 110 continue - return -c -c elec. octupole: - 120 continue - return -c -c short rf cavity - 130 continue - return -c -c axial rotation: - 140 continue - return -c -c linear matrix via twiss parameters: - 150 call rcheck(1,3,p(1),'ipla','twsm',nfile) - return -c -c thin lens low order multipole: - 160 continue - return -c -c "compressed" low order multipole: - 170 continue -c - return - end -c -c -*************************************************************** -c - subroutine raysin(icfile,nraysinp,scaleleni,scalefrqi,scalemomi, & - &ubuf,jerr) -c routine to read in initial conditions of rays to be traced -c and to initialize the arrays istat and ihist -c Written by Robert Ryne ca 1984, and modified by Alex Dragt -cryne 2/16/2002 mods to handle missing file and file with a bad record - - use rays -! use parallel - include 'impli.inc' - include 'files.inc' - include 'parset.inc' - character*80 fname,line - character*80 string - character*16 symb(50),istrtsymb(50) - character*16 ubuf - logical keypres,numpres,leof - dimension bufr(1) - dimension tmpvec(6) -c -c procedure for reading a single set of initial conditions from -c a parameter set -c - if(icfile.lt.0) then -cryne 3/10/2004 this option does not work sensibly on multiple processors. -cryne Whatever is in ipset goes in zblock, so all procs get the same partcles. - ipset=-icfile - if(ipset.gt.maxpst) then - if(idproc.eq.0)write(jof,*)'(raysin)parameter icfile out of range' - call myexit - endif - nrays=1 - do 10 j=1,6 - 10 zblock(j,1)=pst(j,ipset) - goto 130 - endif -c - if(idproc.eq.0)then -c procedure for reading initial conditions from a file -c first check to see if there is a header (scaling info) in the input file: - write(6,*)'Rewinding/reading particle data in file connected', & - & ' to unit ',icfile - 20 continue - nrays=0 - rewind icfile - ncomm=0 - 22 continue - read(icfile,'(a)',end=110,err=120)line -cryne quick hack: % should be in column 1, or user might put an extra -cryne space or two: - if(line(1:1).eq.'%' .or. & - & line(1:2).eq.' %' .or. & - & line(1:3).eq.' %')then - call low(line) - write(6,'(a)')line - ncomm=ncomm+1 - ubuf=' ' - call getscaleinfo(line,ubuf,scaleleni,scalefrqi,scalemomi,jerr) - if(jerr.ne.0)write(6,*)'(RAYSIN)ERROR RETURN FROM GETSCALEINFO' - else - write(6,*)'found ',ncomm, 'lines of header info' - goto 123 - endif - goto 22 -c EOF: - 110 continue - write(6,*)'trouble:particle data file may be missing or empty.' - goto 122 -c ERR: - 120 write(jof,121) - 121 format(1x,'trouble in raysin while trying to read header info') - 122 continue -c try opening another file: - write(6,*)'type a file name or to stop' - read(5,210)fname - if(fname.eq.' ')call myexit - 210 format(a16) - open(icfile,file=fname,status='old',err=300) - goto 20 - 300 continue - write(6,*)'file still does not exist. Halting.' - call myexit - - 123 continue -c count particle data - if(nraysinp.gt.0)then - nrays=nraysinp - goto 125 - endif -c - nrays=0 - rewind icfile - if(ncomm.ne.0)then - do i=1,ncomm -cryne could put an end= and err= here, but not really needed. -cryne read(icfile,'(a)',end=987,err=987)line - read(icfile,'(a)')line - enddo - endif -cryne 222 read(icfile,'(a)',end=910,err=920)line -cryne modified March 10, 2004 to perform unformmated read of 6 numbers -cryne instead of a formatted read of a character string. -cryne this was done because there may be blank lines (e.g. at end), which -cryne lead to an incorrect count unless reading 6 numbers (not a char string) - 222 read(icfile,*,end=910,err=920)tmpvec(1:6) - nrays=nrays+1 - goto 222 - 910 continue - if(nrays.ne.0)then - write(6,*)'found ',nrays,' particles in data file' - goto 125 - endif - write(6,*)'trouble: no particles found in particle data file' - call myexit - 920 continue - write(6,*)'error trying to read particle data' - call myexit -c Processor 0 knows value of nrays. Now broadcast it to all processors - 125 continue - do l=1,nvp-1 - call MPI_SEND(nrays,1,mntgr,l,96,lworld,ierr) - enddo - else - call MPI_RECV(nrays,1,mntgr,0,96,lworld,mpistat,ierr) - endif -c -cryne 1 August, 2004 - if(nrays.lt.nvp)then - if(idproc.eq.0)then - write(6,*)'ERROR: # of particles is < # of processors' - write(6,*)'Execution will be terminated' - endif - call myexit - endif -c - if( (nrays.le.maxray) .and. allocated(zblock) )goto 127 - if( (nrays.le.maxray) .and. .not.allocated(zblock) )then - call new_particledata - goto 127 - endif -c -c trouble: nrays.gt.maxray -c has zblock already been allocated? yes... - if(allocated(zblock))then - if(idproc.eq.0)then - write(6,*)'error: zblock has been allocated but is not large' - write(6,*)'enough to contain the particle array to be read in' - write(6,*)'Rerun with maxray .ge. ',nrays,' in beam definition' - endif - call myexit - endif -c ...no, zblock has not been allocated - if(idproc.eq.0)then - write(6,*)'WARNING: # of rays in input file = ',nrays - write(6,*)' current value of maxray = ',maxray - write(6,*)'setting maxray to ',nrays,' and allocating zblock' - endif - maxray=nrays - call new_particledata -c=========== data file counted; now proc 0 reads in the rays=========== - 127 continue - if(idproc.eq.0)then - rewind icfile - write(6,*)'PE0 has rewound file with unit number ',icfile - if(ncomm.gt.0)then - do n=1,ncomm - read(icfile,*)line(1:80) - enddo - endif -cryne May 19 2006 nraysp=(nrays-1)/nvp + 1 - nraysp0=nrays/nvp - nremain=nrays-nraysp0*nvp - nraysp=nraysp0 - if(nremain.gt.0.and.idproc.le.nremain-1)nraysp=nraysp0+1 -c1221 continue -c if(nraysp*(nvp-1).ge.nrays)then -c nraysp=nraysp-1 -c if(nraysp.eq.0)then -c write(6,*)'trouble: nraysp=0. something wrong. halting.' -c endif -c goto 1221 -c endif -c write(6,*)'nraysp=',nraysp - do k=1,nraysp -c write(6,*)k - read(icfile,*,end=9991,err=9992)zblock(:,k) -c write(6,1841)zblock(1:6,k) -c1841 format(6(1pe12.5,1x)) - enddo - write(6,*)'PE0 has read its own data' -cryne May 19, 2006 nraysw=nraysp - do l=1,nvp-1 -cryne May 19, 2006 if (l.eq.nvp-1) nraysw = nrays - nraysp*(nvp-1) - nraysw=nraysp0 - if(nremain.gt.0.and.l.le.nremain-1)nraysw=nraysp0+1 -c write(6,*)'PE0 is reading nraysw=',nraysw,' for PE#',l,'...' - do k=1,nraysw - read(icfile,*,end=9991,err=9992)tblock(:,k) - enddo -c write(6,*)'...done' - if(l.lt.nvp)then - call MPI_SEND(tblock,6*nraysw,mreal,l,99,lworld,ierr) - endif - enddo -c - izero=0 - write(6,*)'processor ',izero,' retained ',nraysp,' rays' -c - else - call MPI_RECV(zblock,6*maxrayp,mreal,0,99,lworld,mpistat,ierr) - call MPI_GET_COUNT(mpistat,mreal,nraysp,ierr) - nraysp=nraysp/6 - write(6,*)'processor ',idproc,' received ',nraysp,' rays' - endif - - 130 continue -c -c initialize arrrays and set up counters -c - do 115 k=1,nraysp - istat(k)=0 - ihist(1,k)=0 - ihist(2,k)=0 - 115 continue - iturn=0 - nlost=0 - return -cryne This does not work properly, since only PE0 would get here and exit. -cryne To do this right all the procs should find out that there is a problem, -cryne and all should exit. E.G. PE0 could send a special number in tblock(1,1), -cryne and all the procs could check to see if they received it, and if so, exit -cryne Too much trouble. MPI is a pain in the neck. - 9991 continue - if(idproc.eq.0)write(6,*)'error reading particle data file' - call myexit - 9992 continue - if(idproc.eq.0)write(6,*)'EOF encountered reading ptcl data file' - call myexit - end -*********************************************************************** -c - subroutine rcheck(min,max,arg,ivar,itype,nfile) -c This is a subroutine for checking that control -c parameters for random elements lie within the allowed range. -c Written by Alex Dragt ca 1985 - double precision arg - character*4 ivar,itype - iarg=nint(arg) - if (iarg.lt.min.or.iarg.gt.max) goto 10 - return - 10 write (6,100) ivar,iarg,itype,nfile - 100 format(1x,a4,'=',i4,1x,'trouble with random element',1x,a4,1x, - &'read from file',1x,i4) - call myexit - return - end -c -************************************************************************ -c - subroutine wcl(pp) -c subroutine to write out contents of a loop -c Written by Alex Dragt, 23 August 1988 -c Modified 19 June 1998 AJD -c Based on the subroutines cqlate and pmif -c - use beamdata - use acceldata - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' -c -c common blocks -c - include 'codes.inc' - include 'files.inc' - include 'loop.inc' - include 'core.inc' -c - dimension pp(6) -c -c local variables -c - character*8 string(5),str - logical ljof,ljodf -c -c set up control indices -c - iopt=nint(pp(1)) - ifile=nint(pp(2)) - isend=nint(pp(3)) -c -c start routine -c -c see if a loop exists - if(nloop.le.0) then - write(jof ,*) ' error from wcl: no loop has been specified' - write(jodf,*) ' error from wcl: no loop has been specified' - return - endif -c -c procedure when iopt=1 (write only names of loop contents -c at the terminal and/or file 12) - if (iopt.eq.1) then - ljof = isend.eq.1 .or. isend.eq.3 - ljodf = isend.eq.2 .or. isend.eq.3 - if (ljof .or. ljodf) then -c write loop name - if(ljof ) write(jof ,510) ilbl(nloop), joy - if(ljodf) write(jodf,510) ilbl(nloop), joy - 510 format(/,1h ,'contents of loop ',a8,';',i6,' items:') -c write loop contents - do 1 jtot=0,joy,5 - kmax=min(5,joy-jtot) - do 2 k=1,kmax - jk1=jtot+k -c element - if(mim(jk1).lt.0) then - string(k)=lmnlbl(-mim(jk1)) -c user supplied element - else if(mim(jk1).gt.5000) then - string(k)=lmnlbl(mim(jk1)-5000) -c lump - else - string(k)=ilbl(inuse(mim(jk1))) - endif - 2 continue - if(ljof) write(jof ,511)(string(k),k=1,kmax) - if(ljodf) write(jodf,511)(string(k),k=1,kmax) - 511 format(' ',5(1x,a8)) - 1 continue - endif - endif -c -c Procedure when iopt=2 (write out names of loop contents with & signs -c on file ifile. Each line is preceded by a blank space.) - if (iopt .eq. 2 .and. ifile .gt. 0) then -c write loop contents - do jtot=0,joy,5 - kmax=min(5,joy-jtot) - jcheck=joy-jtot - do k=1,kmax - jk1=jtot+k -c element - if(mim(jk1).lt.0) then - string(k)=lmnlbl(-mim(jk1)) -c user supplied element - else if(mim(jk1).gt.5000) then - string(k)=lmnlbl(mim(jk1)-5000) -c lump - else - string(k)=ilbl(inuse(mim(jk1))) - endif - end do - if (jcheck .gt. 5) write(ifile,612) (string(k),k=1,kmax) - if (jcheck .le. 5) write(ifile,613) (string(k),k=1,kmax) - 612 format(' ',' ',5(1x,a8),' &') - 613 format(' ',' ',5(1x,a8)) - end do - endif -c -c procedure when iopt=3 (write out names of loop contents -c with % and & signs on file ifile) - if (iopt .eq. 3 .and. ifile .gt. 0) then -c write loop contents - do jtot=0,joy,5 - kmax=min(5,joy-jtot) - jcheck=joy-jtot - do k=1,kmax - jk1=jtot+k -c element - if(mim(jk1).lt.0) then - string(k)=lmnlbl(-mim(jk1)) -c user supplied element - else if(mim(jk1).gt.5000) then - string(k)=lmnlbl(mim(jk1)-5000) -c lump - else - string(k)=ilbl(inuse(mim(jk1))) - endif - end do - if (jcheck .gt. 5) write(ifile,712) (string(k),k=1,kmax) - if (jcheck .eq. 5) write(ifile,713) (string(k),k=1,kmax) - if (jcheck .lt. 5 .and. kmax .gt. 0) then - write(ifile,714) (string(k),k=1,kmax) - endif - 712 format(' ',' ',5(1x,'% ',a8),' &') - 713 format(' ',' ',5(1x,'% ',a8),' %') - 714 format(' ',' ',5(1x,'% ',a8)) - end do - endif -c -c procedure when iopt=4 or iopt=5 (write out full loop contents) - if (ifile .gt. 0 .and. (iopt.eq.4 .or. iopt.eq.5)) then -c comments - write(ifile,530) ling(1) -c write loop name - write(ifile,512) ilbl(nloop) - 512 format(1h ,' contents of loop ',a8) -c beam - write(ifile,530) ling(2) - write(ifile,*) brho - write(ifile,*) gamm1 - write(ifile,*) achg - write(ifile,*) sl -c biglist heading - write(ifile,127) - 127 format(1h ,'#biglist') -c -c contents of biglist -c write loop contents - do 137 jk1=1,joy -c element - if(mim(jk1).lt.0) then - string(1)=lmnlbl(-mim(jk1)) -c user supplied element - else if(mim(jk1).gt.5000) then - string(1)=lmnlbl(mim(jk1)-5000) -c lump - else - string(1)=ilbl(inuse(mim(jk1))) - endif - call lookup(string(1),itype,item) -c write(6,513) string(1) -c 513 format(1x,a8) -c write(6,*) 'itype and item are ',itype, item -c procedure for a menu item - if(itype.eq.1) then - k=item -c case where iopt=4 - if (iopt.eq.4) then - write(ifile,600)lmnlbl(k),ltc(nt1(k),nt2(k)) - 600 format(1h ,1x,a8,1x,a8) - imax=nrp(nt1(k),nt2(k)) - if(imax.eq.0)goto 137 - write(ifile,603)(pmenu(i+mpp(k)),i=1,imax) -c 603 format((1h ,3(1x,d22.15))) -c Output using Mottershead's favorite pg format - 603 format((1h ,3(1x,1pg22.15))) - endif -c case where iopt=5 - if (iopt.eq.5) then - imax=nrp(nt1(k),nt2(k)) - write(ifile,605)lmnlbl(k),ltc(nt1(k),nt2(k)),imax,nt1(k),nt2(k) - 605 format(1h ,1x,a8,1x,a8,1x,i5,1x,i5,1x,i5) - if(imax.eq.0)goto 137 - write(ifile,607)(pmenu(i+mpp(k)),i=1,imax) -c 607 format((1h ,3(1x,d22.15))) -c Output using Mottershead's favorite pg format - 607 format((1h ,3(1x,1pg22.15))) - endif - endif -c procedure for a lump - if(itype.eq.3) then -c case where iopt=4 - if (iopt .eq. 4) then - write(ifile,514) string(1) - 514 format(1x,1x,a8,1x,'lump') - endif -c case where iopt=5 - if (iopt .eq. 5) then - write(ifile,515) string(1),mim(jk1) - 515 format(1x,1x,a8,1x,'lump',9x,'0',4x,'-1',2x,i4) - endif - endif - 137 continue - endif -c - 530 format(1h ,a8) -c - return - end -c -************************************************************************ -c - subroutine whst(p) -c subroutine to write out history of beam loss -c Written by Alex Dragt, Fall 1986 - use rays - include 'impli.inc' - dimension p(6) - write(6,*)'THIS ROUTINE (WHST) NEEDS TO BE MODIFIED TO' - write(6,*)'EXECUTE PROPERLY IN PARALLEL' -c begin routine - ifile=nint(p(1)) - job=nint(p(2)) -c determine what job is to be done - if (job.eq.2) goto 200 -c procedure for writing out istat -c - do 5 k=1,nraysp - write (ifile,50) k, istat(k) - 50 format (1h ,i10,i10) - 5 continue - if(nraysp.gt.0)then - write(6,*)'istat written on file ',ifile,' for PE# ',idproc - endif - return -c -c procedure for writing out ihist -c - 200 continue - do 10 k=1,nlost - write (ifile,100) k, ihist(1,k), ihist(2,k) - 100 format (1h ,i10,i10,i10) - 10 continue - write(6,*) 'nlost =',nlost - if(nlost.eq.0) write(6,*) 'ihist not written out' - if(nlost.gt.0) write(6,*) 'ihist written on file ',ifile - return - end -c -*********************************************************************** -c - subroutine wps(ipset,isend) -c subroutine for writing out values in a parameter set -c Written by Alex Dragt, 30 January 1988 -c - include 'impli.inc' - include 'files.inc' - include 'parset.inc' -c -c Check to see that ipset is within range - if ((ipset.lt.1) .or. (ipset.gt.maxpst)) then - write (jof,*) 'WARNING: ipset out of range in command', - & ' with typecode wps' - return - endif -c -c Write out values of parameters -c - if ((isend.eq.1) .or. (isend.eq.3)) then - write (jof,*) 'values of parameters in the parameter set',ipset - write (jof,100)( pst(j,ipset), j=1,6) - endif - if ((isend.eq.2) .or. (isend.eq.3)) then - write (jodf,*) 'values of parameters in the parameter set',ipset - write (jodf,100)( pst(j,ipset), j=1,6) - endif - 100 format((1h ,3(1x,1pg22.15))) -c - return - end -c -c-------------- -c - subroutine getfirststring(line,m1,mlast,istart,iend,ierr) - implicit none - character*80 line - integer m1,mlast,istart,iend,ierr - integer m - ierr=0 - do m=m1,mlast - if(line(m:m).ne.' ')then - istart=m - goto 100 - endif - enddo - ierr=1 - return - 100 continue - do m=istart+1,mlast - if(line(m:m).eq.' ')then - iend=m-1 - return - endif - enddo - iend=80 - return - end -c -c-------------- -c - subroutine getscaleinfo(line,ubuf,scaleleni,scalefrqi,scalemomi, & - &jerr) - implicit none -c arguments: - character*80 line - character*16 ubuf - real*8 scaleleni,scalefrqi,scalemomi - integer jerr,iostat,numerr -c other variables: - real*8 bufr(1),value - character*80 string - integer m0,istart,iend,ierr -cryne!!!!!!!!!!!!!!!!!!!!!!!!!!!!!July 5, 2004 needs cleaning up!!! - ierr=0 -cryne!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -c units: - - m0=index(line,'units') - if(m0.ne.0)then - write(6,*)'found units' - m0=index(line,'=') - call getfirststring(line,m0+1,80,istart,iend,ierr) - if(ierr.eq.0)then -c write(6,*)'found istart,iend=',istart,iend -c write(6,*)'char value is ',line(istart:iend) - ubuf=line(istart:iend) - else - write(6,*)'error return from getfirststring' - jerr=1 - endif -c write(6,*)'character string following UNITS is: ',ubuf - goto 23 - endif -c scale length: - m0=index(line,'length') - if(m0.ne.0)then - write(6,*)'found scale_length' - m0=index(line,'=') - call getfirststring(line,m0+1,80,istart,iend,ierr) - if(ierr.eq.0)then -c write(6,*)'found istart,iend=',istart,iend -c write(6,*)'char value is ',line(istart:iend) - string=line(istart:iend) - else - write(6,*)'error return from getfirststring' - jerr=1 - endif - read(string,*,iostat=numerr)value - if(numerr.eq.0)then - bufr(1)=value - else - write(6,*)'ERROR reading SCALE LENGTH info' - endif - scaleleni=bufr(1) - write(6,*)'scale length in particle data file is ',scaleleni - goto 23 - endif -c scale frequency: - m0=index(line,'freq') - if(m0.ne.0)then - write(6,*)'found scale_frequency' - m0=index(line,'=') - call getfirststring(line,m0+1,80,istart,iend,ierr) - if(ierr.eq.0)then -c write(6,*)'found istart,iend=',istart,iend -c write(6,*)'char value is ',line(istart:iend) - string=line(istart:iend) - else - write(6,*)'error return from getfirststring' - jerr=1 - endif - read(string,*,iostat=numerr)value - if(numerr.eq.0)then - bufr(1)=value - else - write(6,*)'ERROR reading SCALE FREQENCY info' - endif - scalefrqi=bufr(1) - write(6,*)'scale freq in particle data file is ',scalefrqi - goto 23 - endif -c scale momentum: - m0=index(line,'momentum') - if(m0.ne.0)then - write(6,*)'found scale_momentum' - m0=index(line,'=') - call getfirststring(line,m0+1,80,istart,iend,ierr) - if(ierr.eq.0)then -c write(6,*)'found istart,iend=',istart,iend -c write(6,*)'char value is ',line(istart:iend) - string=line(istart:iend) - else - write(6,*)'error return from getfirststring' - jerr=1 - endif - read(string,*,iostat=numerr)value - if(numerr.eq.0)then - bufr(1)=value - else - write(6,*)'ERROR reading SCALE MOMENTUM info' - endif - scalemomi=bufr(1) - write(6,*)'scale momentum in input file is ',scalemomi - goto 23 - endif - 23 continue - jerr=ierr - return - end - -c\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -c============================================================================== -c////////////////////////////////////////////////////////////////////////////// - - subroutine wrtmap(iu,refinit,reffin,arclen,h,mh) -c------------------------------------------------------------------------------ -c -c wrtmap: writes a map to file, including the scale factors used to generate -c the map, the initial and final reference particle trajectories, the -c arclength of the map, and the matrix and non-linear parts of the -c map. Map is written in internal units, and the scale factors -c allow one to convert from these units to any other units by -c rescaling. Also, only the non-zero components of the map are -c written to file. -c -c input: -c iu : file unit number -c refinit : initial reference trajectory -c reffin : final reference trajectory -c arclen : length of map element -c h : non-linear part of map -c mh : linear (matrix) part of map -c -c misc: -c scale factors for length, momentum, and frequency are stored in the -c beamdata module found in 'afro_mod.f90' -c -c KMP - 9 Nov 2006 -c------------------------------------------------------------------------------ - use parallel, only : idproc - use lieaparam, only : monoms - use beamdata, only : sl,p0sc,freqscl - implicit none - double precision arclen,refinit(6),reffin(6),mh(6,6),h(monoms) - integer i,j,iu -c -c -c Begin Map File delimiter: - write(iu,'(a)') '#BeginMap' -c -c Scale Factors: - write(iu,100) '#ScaleLen=',sl - write(iu,100) '#ScaleMom=',p0sc - write(iu,100) '#ScaleFrq=',freqscl - 100 format(A10,1X,ES21.13E3) -c -c Arc Length of Map Element: - write(iu,150) '#ArcLen=',arclen - 150 format(A8,1X,ES21.13E3) - write(iu,160) '#Monoms=',monoms - 160 format(A8,1X,I8) -c -c Initial/Final Reference Trajectory: - write(iu,200) '#InitialRefTraj=',refinit - write(iu,200) '#FinalRefTraj= ',reffin - 200 format(A16,6(1X,ES21.13E3)) -c -c Matrix/Linear part of Transfer Map: - do i=1,6 - do j=1,6 - if(abs(mh(i,j)).gt.0.)then - write(iu,300) i,j,mh(i,j) - 300 format(I1,1X,I1,1X,ES21.13E3) - endif - enddo - enddo -c -c Non-linear part of Transfer Map (output 'monoms' in case it changes at some point) - do i=28,monoms - if(abs(h(i)).gt.0.)then - write(iu,400) i,h(i) - 400 format(I8,1X,ES21.13E3) - endif - enddo -c -c End Map File delimiter: - write(iu,'(a)') '#EndMap' -c -c Automatically flush write to file so map can be read and used immediately - call myflush(iu) - end - -c\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -c============================================================================== -c////////////////////////////////////////////////////////////////////////////// - - subroutine rdmap(iu,darc,dreftraj,h,mh) -c------------------------------------------------------------------------------ -c -c readmap: reads a map, or series of maps, from file, including the scale -c factors used to generate the map, the initial and final reference -c particle trajectories, the arclength of the map, and the matrix -c and non-linear parts of the map. The map is read in assuming -c internal units, and the scale factors allow one to convert from -c these units to any other units by rescaling. The map, once read, -c is immediately applied. -c -c input: -c iu : file unit number -c -c -c misc: -c scale factors for length, momentum, and frequency are stored in the -c beamdata module found in 'afro_mod.f90' -c -c KMP - 15 Dec 2006 -c------------------------------------------------------------------------------ - use parallel, only : idproc - use lieaparam, only : monoms - use beamdata, only : sl,p0sc,freqscl - implicit none - include 'map.inc' - double precision refinit(6),reffin(6),dreftraj(6) - double precision mh(6,6),h(monoms),mh2(6,6),h2(monoms) - double precision lsctmp,psctmp,fsctmp,darc - double precision d1,d2 - integer i,j,iu,monomstmp - character*160 cline - character*20 cword - character ch -c -c Read a line from the file - 100 read(iu,'(A160)',end=300) cline -c write(*,*) cline -c -c Look for #BeginMap delimiter - if(cline(1:9).eq.'#BeginMap')then - read(iu,*) cword, lsctmp - if(lsctmp.eq.0.0)then - write(*,*) 'ERROR (rdmap): length scale is zero!' - write(*,*) ' keeping current length scale' - lsctmp = sl - endif -c write(*,*) cword, lsctmp - read(iu,*) cword, psctmp - if(psctmp.eq.0.0)then - write(*,*) 'ERROR (rdmap): momentum scale is m*c' - write(*,*) ' keeping current momentum scale' - psctmp = p0sc - endif -c write(*,*) cword, psctmp - read(iu,*) cword, fsctmp - if(fsctmp.eq.0.0)then - write(*,*) 'ERROR (rdmap): frequency scale is zero!' - write(*,*) ' keeping current frequency scale' - fsctmp = freqscl - endif -c write(*,*) cword, fsctmp - read(iu,*) cword, darc -c write(*,*) cword, darc - read(iu,*) cword, monomstmp -c write(*,*) cword, monomstmp - if(monoms.ne.monomstmp)then - if(idproc.eq.0)then - write(*,*) 'WARNING (rdmap): Lie Algebraic order of ', - & 'map read from file is ',monomstmp,' but ' - write(*,*) ' the current order in the simulation ', - & 'is ',monoms,'.' - endif - endif - read(iu,*) cword, refinit -c write(*,*) cword, refinit -c -c Rescale initial reference trajectory - refinit(1) = refinit(1) * lsctmp / sl - refinit(2) = refinit(2) * psctmp / p0sc - refinit(3) = refinit(3) * lsctmp / sl - refinit(4) = refinit(4) * psctmp / p0sc - refinit(5) = refinit(5) * freqscl / fsctmp - refinit(6) = refinit(6) * (fsctmp*lsctmp*psctmp) - & / (freqscl*sl*p0sc) -c -c Compare initial and current reference trajectories - do i=1,6 - if(i.ne.5)then - d1 = reftraj(i) - refinit(i) - d2 = abs(reftraj(i)) + abs(refinit(i)) - if((d2.gt.0.0).and.(abs(d1).gt.0.05*d2))then - if(idproc.eq.0)then - write(*,*) 'WARNING (rdmap): Map reference trajectory ', - & 'coordinate',i,'differs from simulation ' - write(*,*) 'reference trajectory by greater than 10%!', - & ' Results could be inaccurate!' - endif - endif - endif - enddo - read(iu,*) cword, reffin -c write(*,*) cword, reffin -c Rescale final reference trajectory - reffin(1) = reffin(1) * lsctmp / sl - reffin(2) = reffin(2) * psctmp / p0sc - reffin(3) = reffin(3) * lsctmp / sl - reffin(4) = reffin(4) * psctmp / p0sc - reffin(5) = reffin(5) * freqscl / fsctmp - reffin(6) = reffin(6) * (fsctmp*lsctmp*psctmp) - & / (freqscl*sl*p0sc) -c -c Find change in reference trajectory - dreftraj = reffin - refinit -c -c Initialize map and read in non-zero coefficients - h = 0.0 - mh = 0.0 - 200 read(iu,'(A160)') cline -c write(*,*) '1: ',cline - if(cline(1:1).eq.'#')then - if(cline(1:7).eq.'#EndMap')goto 400 - else - read(cline,*) i -c write(*,*) '2: ',i - if(i.gt.6)then - read(cline,*) i,d1 -c write(*,*) '3: ',i,d1 - if(i.le.monoms)h(i) = d1 - else - read(cline,*) i,j,d1 -c write(*,*) '4: ',i,j,d1 - mh(i,j) = d1 - endif - endif - goto 200 - else - goto 100 - endif -c -c Error trapping: Only reaches here if no map found in file. - 300 continue - write(*,*) 'ERROR (rdmap): No map found in file. ', - & 'Returning the identity map.' - call ident(h,mh) - darc = 0.0 - dreftraj = 0.0 - return -c - 400 continue -c Scale map to with current scale factors - call rescale_map(lsctmp,psctmp,fsctmp,h,mh) -c -c Check return values: -! if(idproc.eq.0)then -! write(*,*) 'ERROR CHECKING:' -! write(*,*) 'darc = ',darc -! write(*,*) 'mh:' -! do i=1,6 -! write(*,*) ' ',(mh(i,j),j=1,6) -! enddo -! write(*,*) 'h:' -! do i=1,monoms -! if(h(i).ne.0.0)write(*,*) ' ',i,': ',h(i) -! enddo -! endif - return - end - diff --git a/OpticsJan2020/MLI_light_optics/Src/integ.f b/OpticsJan2020/MLI_light_optics/Src/integ.f deleted file mode 100644 index 0d0c8cf..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/integ.f +++ /dev/null @@ -1,803 +0,0 @@ -************************************************************************ -* header INTEGRATE (GENMAP for a general string of * -* magnets with soft fringe fields) * -* All routines needed for this special GENMAP * -************************************************************************ - subroutine integ(p,fa,fm) -c This is a subroutine for computing the map for a soft edged dipole -c magnet ( F. Neri 5/16/89 ). -c Interface to subroutine BONAX by P. Walstrom. -c Computes By (and derivatives on axis) for a sinPHI -c (Walstrom) steering magnet. 2/15/90. -c Eventually use GRONAX for m diff. from 1. -c Done (F. Neri 3/13/90). -c Generalized to arbitrary m, etc. 3/23/90, F. Neri -c Added type 8 (REC dipole sheets). -c Corrected sign problem. -c 11-19-90. -c Interface to CFQD F. Neri 5/8/91. -c Spacers, etc. F. Neri 6/28/91. -c Thick Halbach magnets. 6/28/91. -c -c included in ML/I -c - use lieaparam, only : monoms - use beamdata -cryneneriwalstrom include 'param.inc' - include 'impli.inc' - include 'parset.inc' - include 'hmflag.inc' - include 'combs.inc' -cryneneriwalstrom include 'parm.inc' - include 'files.inc' - include 'dip.inc' - include 'pie.inc' - include 'gronax.inc' - include 'multipole.inc' - include 'zz.inc' - include 'vecpot.inc' - include 'nnprint.inc' -c -c calling arrays - dimension p(6) - dimension fa(monoms), fm(6,6) -c -c local arrays - dimension ha(monoms), hm(6,6) - dimension pb(6) - dimension y(monoms+15) -c - real ttaa, ttbb -c -c use equivalence statement to make the various parameter sets pstj -c available as if they were in a two dimensional array -c -c -c y(1-6) = given (design) trajectory -c y(7-42) = matrix -c y(43-98) = f3 -c y(99-224) = f4 -c -c - zlength = xldr + ztotal -c - nops = nint(p(2)) - shflag = nint(p(3)) - ashield = p(4) - ns = nint(p(5)) - lun = nint(p(1)) - if (lun.gt.10) then - nnprint = 2*nint(p(6)) - endif - if ( nops .eq. 0 ) then -c write (6,*) ' CFQD option not implemented!!!' - call multcfq(zlength,fa,fm) - return - else if ( nops .lt. 0 ) then - call mulplt(zlength) -c write (6,*) ' PLOT option not implemented!!!' - return - endif - zi = 0.d0 - zf = zlength - h=(zf-zi)/float(ns) -c -c call VAX system routine for timing report -c - ttaa = secnds(0.0) -c -c initial values for design orbit (in dimensionless units) : -c - do 2 i = 1,6 - y(i) = 0.0d0 - 2 continue -c -c I really don't understand this! FN: -c Actually it just means that the design trajectory is -c ALWAYS on momentum. -c - y(6)=-1.d0/beta -c set constants - qbyp=1.d0/brho - ptg=-1.d0/beta -c -c initialize map to the identity map: -cryneneriwalstrom ne=224 - ne=monoms+15 - do 40 i=7,ne - 40 y(i)=0.d0 - do 50 i=1,6 - j=7*i - 50 y(j)=1.d0 -c -c do the computation: - t=zi - iflag = 3 -cryne 1 August 2004 fix later: -cryne call adam11(h,ns,'start',t,y) - nedummy=monoms+15 - call adam11(h,ns,'start',t,y,nedummy) - call errchk(y(7)) - call putmap(y,fa,fm) - s1 = -(y(2)-Ax(0)) - phi1 = dasin(s1) - phi1deg = phi1/pi180 -cx for test only the following lines are commented out: -c call prot(phi1deg,2,ha,hm) -c call concat(fa,fm,ha,hm,fa,fm) -c - write(jof,*) ' Final conditions in fixed reference frame!' - write(jodf,*) ' Final conditions in fixed reference frame!' -c - do 22 i = 1,6 - zfinal(i) = y(i) - 22 continue -c - write(jof , 999) (zfinal(i),i=1,6) - write(jodf, 999) (zfinal(i),i=1,6) - 999 format(' zf=',6e12.5) -c - write(jof , 991) phi1deg - write(jodf, 991) phi1deg -991 format(' Final angle is ',f16.8,' degrees') -c -c call VAX system routine for timing report -c - ttbb = secnds(ttaa) - write( jof,567) ttbb - write(jodf,567) ttbb - 567 format(' Integration time = ',f12.2,' sec.') -c call vecpot(Ax,Ay) -cryneneriwalstrom: added return statement - return - end -c -********************************************************************** - subroutine vecpot(Ax,Ay) - use lieaparam, only : monoms - use beamdata - include 'impli.inc' -cryneneriwalstrom include 'parm.inc' -cryneneriwalstrom include 'param.inc' - include 'files.inc' - double precision Ax(0:monoms), Ay(0:monoms) - do 1 i=1,monoms - if(Ax(i).ne. 0.d0) write(jodf,*) ' Ax(',i,')=',Ax(i) - if(Ay(i).ne. 0.d0) write(jodf,*) ' Ay(',i,')=',Ay(i) - 1 continue - return - end -c -********************************************************************** -c - subroutine gradients(z0) -c -c F. Neri -c Revised version 7/12/90. -c Corrected bug 8/6/90. -c Skew Multipoles 5/27/91. -c - include 'impli.inc' - include 'gronax.inc' - include 'multipole.inc' - include 'dip.inc' - integer ifirst,nderiv - logical initg - data ifirst/0/ - double precision bb(14) -c -cryne this looks like old code that is not needed here, -cryne so I am commenting it out -cryne data blprod/2.d0/,a1/0.75d0/,a2/1.d0/,xl/2.d0/,ss/1.d0/ -cryne data nmax/100/,kmax/100/ -c - save ifirst -c -c Initialization, if necessary: - if (ifirst .eq. 0 ) then - do 10 j=1, ncoil - initg = .false. - jtyp = itype(j) - if(jtyp.eq.3) initg = .true. - if(jtyp.eq.4) initg = .true. - if(jtyp.eq.6) initg = .true. - if(jtyp.eq.17) initg = .true. -cryneneriwalstrom if(initg) call onaxgr(0,0.d0,j,bb) - if(initg) call onaxgr(0,0.d0,j,nderiv,bb) - 10 continue - ifirst = 1 - endif -c -ctm plot net gradient in file 79 -c - gnet = 0.0d0 - do 1 j = 1, ncoil -c zz = z0 - zcoil(j) - zz = z0 - xldr -c write(6,*) j,z0,zz - call onaxgr(1,zz,j,11,bb) - gnet = gnet + bb(1) -c write(79,*) zz, bb(1) -c - if ( mcoil(j) .gt. 0 ) then - do 666 i= 0, 10 - gn(mcoil(j),i) = gn(mcoil(j),i) + bb(i+1)/float(mcoil(j)) - 666 continue - else - do 777 i= 0, 10 - gs(-mcoil(j),i) = gs(-mcoil(j),i) + bb(i+1)/float(-mcoil(j)) - 777 continue - endif -c -c write(6,*) ' z = ',zz, ' b =',bb(1) - 1 continue - write(79,*) zz,gnet - return - end -c -********************************************************************** -c - subroutine prenv(z,y) - include 'impli.inc' - include 'sigbuf.inc' - include 'nnprint.inc' - include 'gronax.inc' -c - dimension y(*) -c - save ncount, nf -c - if(ncount.eq.0) then - nf = 1 - xx(1) = xxin - ax(1) = axin - px(1) = pxin - yy(1) = yyin - ay(1) = ayin - py(1) = pyin - endif - ncount = ncount+1 - if (mod(ncount, nnprint).ne.0) return -c------------------- x plane ------------ - cfx = y(7) - sfx = y(13) - cpx = y(8) - spx = y(14) - txx = cfx**2 - tax = 2.0*cfx*sfx - tpx = sfx**2 - txa = cfx*cpx - taa = cfx*spx+sfx*cpx - tpa = sfx*spx - txp = cpx**2 - tap = 2.0*cpx*spx - tpp = spx**2 -c------------------- y plane ------------ - cfy = y(21) - sfy = y(27) - cpy = y(22) - spy = y(28) - ryy = cfy**2 - ray = 2.0*cfy*sfy - rpy = sfy**2 - rya = cfy*cpy - raa = cfy*spy+sfy*cpy - rpa = sfy*spy - ryp = cpy**2 - rap = 2.0*cpy*spy - rpp = spy**2 -c -c -c compute x-plane final beam ellipse -c - ni = 1 -c - nf = nf + 1 - zu = z -c - xs = xx(ni)**2 - xa = -xx(ni)*ax(ni)*px(ni)/sqrt(1.0d0 + ax(ni)**2) - xps = px(ni)**2 -c sigf1 = (cfx**2)*xs + 2.0*cfx*sfx*xa + (sfx**2)*xps -c sigf2 = cfx*cpx*xs + (cfx*spx+sfx*cpx)*xa + sfx*spx*xps -c sigf3 = (cpx**2)*xs + 2.0*cpx*spx*xa + (spx**2)*xps - sigf1 = txx*xs + tax*xa + tpx*xps - sigf2 = txa*xs + taa*xa + tpa*xps - sigf3 = txp*xs + tap*xa + tpp*xps - exsq = sigf1*sigf3 - sigf2**2 - if(exsq.le.0.0) exsq = 1.e-30 - ex = sqrt(exsq) - xx(nf) = sqrt(sigf1) - if(xx(nf).gt.xmax) then - xmax = xx(nf) - zxmax = zu - endif - if(xx(nf).gt.exmax) then - exmax = xx(nf) - zxm = zu - endif - if(xx(nf).lt.exmin) exmin = xx(nf) - px(nf) = sqrt(sigf3) - ax(nf) = -sigf2/ex -c -c compute y-plane beam ellipse -c - ys = yy(ni)**2 - ya = -yy(ni)*ay(ni)*py(ni)/sqrt(1.0d0 + ay(ni)**2) - yps = py(ni)**2 -c sigf4 = (cfy**2)*ys + 2.0*cfy*sfy*ya + (sfy**2)*yps -c sigf5 = cfy*cpy*ys + (cfy*spy+sfy*cpy)*ya + sfy*spy*yps -c sigf6 = (cpy**2)*ys + 2.0*cpy*spy*ya + (spy**2)*yps - sigf4 = ryy*ys + ray*ya + rpy*yps - sigf5 = rya*ys + raa*ya + rpa*yps - sigf6 = ryp*ys + rap*ya + rpp*yps - eysq = sigf4*sigf6 - sigf5**2 - if(eysq.le.0.0) eysq = 1.e-30 - ey = sqrt(eysq) - yy(nf) = sqrt(sigf4) - if(yy(nf).gt.ymax) then - ymax = yy(nf) - zymax = zu - endif - if(yy(nf).gt.eymax) then - eymax = yy(nf) - zym = zu - endif - if(yy(nf).lt.eymin) eymin = yy(nf) - py(nf) = sqrt(sigf6) - ay(nf) = -sigf5/ey -c - quadp = gn(2,0)*2. - octp = gn(4,0)*4. -c - if(lun.gt.0) write(lun,27) zu,xx(nf),px(nf),yy(nf),py(nf),ax(nf) - * ,ay(nf), quadp, octp - 27 format(f10.4,4(1pe11.4),4(1pe12.4)) - return - end -c -********************************************************************** -c - subroutine hmltn3(t,y,h) -c Originally written by F. Neri, 5/16/89. -c Modified 6/3/89 to handle different gauges. -c Modified 3/13/90 for arbitrary sin(m theta)+cos(m theta) -c magnets, as given in common block GRONAX. -c Interfaces to routine GRONAX by P. Walstrom. -c Modified again 3/23/90 for new input format. -c - use lieaparam, only : monoms - use beamdata -cryneneriwalstrom It appears that iplus is not used. Comment out later. -cryneneriwalstrom Need to set itop to whatever makes sense for this version -c -cryneneriwalstrom parameter (itop=209,iplus=224) - parameter (itop=923,iplus=itop+15) - include 'impli.inc' -cryneneriwalstrom include 'param.inc' -cryneneriwalstrom include 'parm.inc' - include 'dip.inc' - include 'bfield.inc' - include 'gronax.inc' - include 'multipole.inc' - include 'vecpot.inc' - include 'nnprint.inc' -c - dimension h(monoms),y(*) -c - dimension X(0:itop),YY(0:itop),P1(0:itop),P2(0:itop) - dimension P12(0:itop),P22(0:itop) - dimension A(0:12) - double precision bb(14) -c -c begin calculation -c -c compute gradients on axis: -c - do 10 i=0,10 - do 10 j=0,10 - gn(i,j) = 0.0d0 - gs(i,j) = 0.0d0 - 10 continue -c - zz = t -c write(6,*) zz -c call dbonax(1,a1,a2,xl,blprod,ss,nmax,kmax,ndriv,zz,bb) -c - call gradients(zz) -c -c print out envelopes, gradients, etc. - if(lun.gt.10) then - call prenv(zz,y) - endif -c -c initialization - do 11 i=1,monoms - 11 h(i)=0.d0 -c -c cccc -c Slow method to produce hamiltonian: use polynomial -c expansion of square root: when this method works we will use it to -c to check the "hardwired" version. -c cccc -c Coefficients of expansion of -SQRT(1+X)+1 - A(0) = 0.d0 - A(1) = -1.d0/2.d0 - do 50 i=2, 6 - A(i) = A(i-1) * (1.d0/2.d0 -(i-1.d0))/i - 50 continue -c - do 60 i=0,monoms - X(i) = 0.d0 - 60 continue - X(6) = -2.d0 / beta -c X(13) = -1.d0 -c X(22) = -1.d0 - X(27) = 1.d0 -c -cryneneriwalstrom maxord = 4 -cryneneriwalstrom nn = 4 - maxord = 6 - nn = 6 -c P1 = px -q Ax - do 101 i=0,monoms - Ax(i) = 0.d0 - Ay(i) = 0.d0 - Az(i) = 0.d0 - P2(i) = 0.d0 - 101 P1(i) = 0.d0 -c - q = 1.d0/brho - x0 = y(1) - y0 = y(3) -c -c write(6,*) ' x0=',x0,' y0=',y0 -c -c Mathematica generated block follows: -c include 'a3.fop' -c NEED A SWITCH HERE THAT SAYS, "IF(not an rf cavity)THEN - call a3(q,x0,y0) -c ELSE -c call rf cavity routines -c - cos2 = 1.d0 -(y(2) -Ax(0))**2 -(y(4)-Ay(0))**2 -c -c Note constant term in px -q Ax, coming from design orbit -c y(2) = Px = sin(phi) (initially). - P1(0) = y(2) - P1(2) = 1.d0 -c P12 = P1**2 - do 112 i=0,itop - 112 P1(i) = P1(i)-Ax(i) - call pmult(P1,P1,P12,maxord) -c - P2(0) = y(4) - P2(4) = 1.d0 - do 122 i=0,itop - 122 P2(i) = P2(i)-Ay(i) - call pmult(P2,P2,P22,maxord) -c -c Zeroth order term subtracted ( Sum starts at 1 ): -c Divide by cos2 - do 102 i=1,itop - 102 X(i) = (X(i)-P12(i)-P22(i))/cos2 -c X = pt**2 -2/beta*pt -(px -q Ax)**2 -(py -q Ay)**2 -c YY = -Sqrt(1+X) - call poly1(nn,A,X,YY,maxord) -c h = -Az - do 132 i=7, monoms - 132 h(i) = -Az(i) -c -c h = -Sqrt(1+X)-Az -c Zero and first order terms subtracted ( Sum starts at 7 ): -c Scale by cos - do 70 i=7, monoms - h(i) = h(i)+dsqrt(cos2)*YY(i)/sl - 70 continue - return - end -c -*********************************************************************** -c - subroutine poly1(N,A,X,Y,maxord) - include 'lims.inc' - parameter (MN=6) -cryne 7/23/2002 common /lims/bottom,top -cryne 7/23/3003 integer bottom(0:12),top(0:12) - double precision X(0:923),Y(0:923) - double precision A(0:N) - - double precision Vect(0:923,MN) - -c NO COMMENT - do 100 i=0,top(maxord) - 100 Y(i) = 0.0d0 - do 200 i=0,top(maxord) - 200 Vect(i,1) = X(i) - do 300 iord=2,N - call pmult(X,Vect(0,iord-1),Vect(0,iord),maxord) - 300 continue - Y(0) = A(0) - do 400 iord=1,N - do 500 i=0,top(maxord) - Y(i) = Y(i) + Vect(i,iord)*A(iord) - 500 continue - 400 continue - return - end -c - subroutine pmult(p1,p2,p3,maxord) - include 'lims.inc' - double precision p1(0:923),p2(0:923),p3(0:923) -c -cryne 7/23/2002 common /lims/bottom,top -cryne 7/23/3003 integer bottom(0:12),top(0:12) - if (maxord.lt.0) return -c - do 10 i=1,top(maxord) - 10 p3(i) = 0.0d0 - p3(0) = p1(0) * p2(0) - do 100 mord=1,maxord - call pmadd(p1(1),mord,p2(0),p3(1)) - call pmadd(p2(1),mord,p1(0),p3(1)) - do 200 nord1 = 1,mord-1 - nord2 = mord - nord1 - call product(p1(1),nord1,p2(1),nord2,p3(1)) - 200 continue - 100 continue - return - end -*********************************************************************** -c - subroutine nndrift(l,phideg,h,mh) -c -c Transverse entry drift. -c generates linear matrix mh and -c array h containing nonlinearities -c for the transfer map describing -c a drift section of length l meters, -c with the design trajectory at an angle of phideg degrees -c F. Neri 5/24/89 -c Actual code generated by Johannes Van Zeijts using -c REDUCE. -c - use lieaparam, only : monoms - use beamdata -c - include 'impli.inc' -cryneneriwalstrom include 'param.inc' -cryneneriwalstrom include 'parm.inc' - include 'pie.inc' - double precision l,h(monoms),mh(6,6) -c - double precision lsc - dimension j(6) -c - DOUBLE PRECISION UL - DOUBLE PRECISION UB - DOUBLE PRECISION CO - DOUBLE PRECISION Si - DIMENSION UDERS(923) - DOUBLE PRECISION UDERS - DOUBLE PRECISION T1 -c - call clear(h,mh) - lsc=l/sl -c - phi = phideg*pi180 - SI = SIN(phi) - CO = COS(phi) -c -c add drift terms to mh -c - do 40 k=1,6 - mh(k,k)=+1.0d0 - 40 continue - mh(1,2)=+lsc*(1.d0/CO+SI**2/CO**3) - mh(1,6)=+lsc*SI/(beta*CO**3) - mh(3,4)=+lsc*(1.d0/CO) - mh(5,2)=+lsc*SI/(beta*CO**3) - mh(5,6)=+lsc*(-1.d0/CO+1.d0/(beta**2*CO**3)) -c mh(5,6)=+(lsc/((gamma**2)*(beta**2))) -c -c add drift terms to h - UL = lsc - UB = beta -c - do 1 i=1,923 - UDERS(i) = 0.0d0 - 1 continue -c -c From: CINCOM::JOHANNES "Johannes van Zeijts" 23-MAY-1989 16:38 -c - UDERS(923) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7))+(-2.1875D0 - & ) * (UL / (UB ** 4 * CO ** 9))+1.3125D0 * (UL / (UB ** 6 - & * CO ** 11))+(-6.25D-02) * (UL / CO ** 5) - UDERS(910) = (-1.875D0) * (UL / (UB ** 2 * CO ** 7))+2.1875D0 - & * (UL / (UB ** 4 * CO ** 9))+0.1875D0 * (UL / CO ** 5) - UDERS(901) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7))+(-0.1875D0 - & ) * (UL / CO ** 5) - UDERS(896) = 6.25D-02 * (UL / CO ** 5) - UDERS(839) = 1.875D0 * ((UL * SI) / (UB * CO ** 7))+( - & -8.75D0) * ((UL * SI) / (UB ** 3 * CO ** 9))+7.875D0 * - & ((UL * SI) / (UB ** 5 * CO ** 11)) - UDERS(828) = (-3.75D0) * ((UL * SI) / (UB * CO ** 7))+ - & 8.75D0 * ((UL * SI) / (UB ** 3 * CO ** 9)) - UDERS(821) = 1.875D0 * ((UL * SI) / (UB * CO ** 7)) - UDERS(783) = (-1.875D0) * (UL / (UB ** 2 * CO ** 7))+2.1875D0 - & * (UL / (UB ** 4 * CO ** 9))+0.1875D0 * (UL / CO ** 5) - & +(-13.125D0) * ((UL * SI ** 2) / (UB ** 2 * CO ** 9))+ - & 19.6875D0 * ((UL * SI ** 2) / (UB ** 4 * CO ** 11))+ - & 0.9375D0 * ((UL * SI ** 2) / CO ** 7) - UDERS(774) = 1.875D0 * (UL / (UB ** 2 * CO ** 7))+(-0.375D0) - & * (UL / CO ** 5)+13.125D0 * ((UL * SI ** 2) / (UB ** 2 - & * CO ** 9))+(-1.875D0) * ((UL * SI ** 2) / CO ** 7) - UDERS(769) = 0.1875D0 * (UL / CO ** 5)+0.9375D0 * ((UL * SI - & ** 2) / CO ** 7) - UDERS(748) = (-3.75D0) * ((UL * SI) / (UB * CO ** 7))+ - & 8.75D0 * ((UL * SI) / (UB ** 3 * CO ** 9))+(-8.75D0) * - & ((UL * SI ** 3) / (UB * CO ** 9))+26.25D0 * ((UL * SI - & ** 3) / (UB ** 3 * CO ** 11)) - UDERS(741) = 3.75D0 * ((UL * SI) / (UB * CO ** 7))+8.75D0 * - & ((UL * SI ** 3) / (UB * CO ** 9)) - UDERS(728) = 0.9375D0 * (UL / (UB ** 2 * CO ** 7))+(-0.1875D0 - & ) * (UL / CO ** 5)+13.125D0 * ((UL * SI ** 2) / (UB ** - & 2 * CO ** 9))+(-1.875D0) * ((UL * SI ** 2) / CO ** 7) - & +19.6875D0 * ((UL * SI ** 4) / (UB ** 2 * CO ** 11))+( - & -2.1875D0) * ((UL * SI ** 4) / CO ** 9) - UDERS(723) = 0.1875D0 * (UL / CO ** 5)+1.875D0 * ((UL * SI - & ** 2) / CO ** 7)+2.1875D0 * ((UL * SI ** 4) / CO ** 9 - & ) - UDERS(718) = 1.875D0 * ((UL * SI) / (UB * CO ** 7))+8.75D0 - & * ((UL * SI ** 3) / (UB * CO ** 9))+7.875D0 * ((UL * - & SI ** 5) / (UB * CO ** 11)) - UDERS(714) = 6.25D-02 * (UL / CO ** 5)+0.9375D0 * ((UL * SI - & ** 2) / CO ** 7)+2.1875D0 * ((UL * SI ** 4) / CO ** - & 9)+1.3125D0 * ((UL * SI ** 6) / CO ** 11) - UDERS(461) = 0.375D0 * (UL / (UB * CO ** 5))+(-1.25D0) * (UL - & / (UB ** 3 * CO ** 7))+0.875D0 * (UL / (UB ** 5 * CO ** - & 9)) - UDERS(450) = (-0.75D0) * (UL / (UB * CO ** 5))+1.25D0 * (UL / - & (UB ** 3 * CO ** 7)) - UDERS(443) = 0.375D0 * (UL / (UB * CO ** 5)) - UDERS(405) = (-3.75D0) * ((UL * SI) / (UB ** 2 * CO ** 7))+ - & 4.375D0 * ((UL * SI) / (UB ** 4 * CO ** 9))+0.375D0 * ( - & (UL * SI) / CO ** 5) - UDERS(396) = 3.75D0 * ((UL * SI) / (UB ** 2 * CO ** 7))+( - & -0.75D0) * ((UL * SI) / CO ** 5) - UDERS(391) = 0.375D0 * ((UL * SI) / CO ** 5) - UDERS(370) = (-0.75D0) * (UL / (UB * CO ** 5))+1.25D0 * (UL / - & (UB ** 3 * CO ** 7))+(-3.75D0) * ((UL * SI ** 2) / (UB - & * CO ** 7))+8.75D0 * ((UL * SI ** 2) / (UB ** 3 * CO - & ** 9)) - UDERS(363) = 0.75D0 * (UL / (UB * CO ** 5))+3.75D0 * ((UL * - & SI ** 2) / (UB * CO ** 7)) - UDERS(350) = 3.75D0 * ((UL * SI) / (UB ** 2 * CO ** 7))+( - & -0.75D0) * ((UL * SI) / CO ** 5)+8.75D0 * ((UL * SI - & ** 3) / (UB ** 2 * CO ** 9))+(-1.25D0) * ((UL * SI ** 3 - & ) / CO ** 7) - UDERS(345) = 0.75D0 * ((UL * SI) / CO ** 5)+1.25D0 * ((UL * - & SI ** 3) / CO ** 7) - UDERS(340) = 0.375D0 * (UL / (UB * CO ** 5))+3.75D0 * ((UL * - & SI ** 2) / (UB * CO ** 7))+4.375D0 * ((UL * SI ** 4) - & / (UB * CO ** 9)) - UDERS(336) = 0.375D0 * ((UL * SI) / CO ** 5)+1.25D0 * ((UL - & * SI ** 3) / CO ** 7)+0.875D0 * ((UL * SI ** 5) / - & CO ** 9) - UDERS(209) = (-0.75D0) * (UL / (UB ** 2 * CO ** 5))+0.625D0 * - & (UL / (UB ** 4 * CO ** 7))+0.125D0 * (UL / CO ** 3) - UDERS(200) = 0.75D0 * (UL / (UB ** 2 * CO ** 5))+(-0.25D0) * - & (UL / CO ** 3) - UDERS(195) = 0.125D0 * (UL / CO ** 3) - UDERS(174) = (-1.5D0) * ((UL * SI) / (UB * CO ** 5))+2.5D0 - & * ((UL * SI) / (UB ** 3 * CO ** 7)) - UDERS(167) = 1.5D0 * ((UL * SI) / (UB * CO ** 5)) - UDERS(154) = 0.75D0 * (UL / (UB ** 2 * CO ** 5))+(-0.25D0) * - & (UL / CO ** 3)+3.75D0 * ((UL * SI ** 2) / (UB ** 2 * - & CO ** 7))+(-0.75D0) * ((UL * SI ** 2) / CO ** 5) - UDERS(149) = 0.25D0 * (UL / CO ** 3)+0.75D0 * ((UL * SI ** - & 2) / CO ** 5) - UDERS(144) = 1.5D0 * ((UL * SI) / (UB * CO ** 5))+2.5D0 * ( - & (UL * SI ** 3) / (UB * CO ** 7)) - UDERS(140) = 0.125D0 * (UL / CO ** 3)+0.75D0 * ((UL * SI ** - & 2) / CO ** 5)+0.625D0 * ((UL * SI ** 4) / CO ** 7) - UDERS(83) = (-0.5D0) * (UL / (UB * CO ** 3))+0.5D0 * (UL / ( - & UB ** 3 * CO ** 5)) - UDERS(76) = 0.5D0 * (UL / (UB * CO ** 3)) - UDERS(63) = 1.5D0 * ((UL * SI) / (UB ** 2 * CO ** 5))+( - & -0.5D0) * ((UL * SI) / CO ** 3) - UDERS(58) = 0.5D0 * ((UL * SI) / CO ** 3) - UDERS(53) = 0.5D0 * (UL / (UB * CO ** 3))+1.5D0 * ((UL * SI - & ** 2) / (UB * CO ** 5)) - UDERS(49) = 0.5D0 * ((UL * SI) / CO ** 3)+0.5D0 * ((UL * - & SI ** 3) / CO ** 5) -c - do 2 i=1, monoms - h(i) = -UDERS(i) - 2 continue - return - end -c -*********************************************************************** -c - subroutine myprot(phideg,h,mh) -c -c High order PROT routine. -c Actual code generated by Johannes van Zeijts using -c REDUCE. -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' - double precision l,h(monoms),mh(6,6) -c - dimension j(6) -c - DOUBLE PRECISION B - DOUBLE PRECISION CO - DOUBLE PRECISION Si -c - call clear(h,mh) -c - B = beta - phi = phideg*pi180 - SI = SIN(phi) - CO = COS(phi) -c - mh(1,1)=1.0d0/CO - mh(2,2)=CO - mh(2,6)=(-SI)/B - mh(3,3)=1.0d0 - mh(4,4)=1.0d0 - mh(5,1)=SI/(B*CO) - mh(5,5)=1.0d0 - mh(6,6)=1.0d0 -c - h(34) =(-SI)/(2.0d0*CO) - h(43) =(-SI)/(2.0d0*CO) - h(48) =(SI*(B**2-1))/(2.0d0*B**2*CO) - h(105) =SI**2/(4.0d0*(SI**2-1)) - h(109) =(-SI)/(2.0d0*B*CO) - h(114) =SI**2/(4.0d0*(SI**2-1)) - h(119) =(SI**2*(-B**2+1))/(4.0d0*B**2*(SI**2-1)) - h(132) =(-SI)/(2.0d0*B*CO) - h(139) =(SI*(B**2-1))/(2.0d0*B**3*CO) - h(266) =SI/(8.0d0*CO*(SI**2-1)) - h(270) =SI**2/(2.0d0*B*(SI**2-1)) - h(275) =(SI*(-2.0d0*SI**2+3))/(12.0d0*CO*(SI**2-1)) - h(280) =(SI*(2.0d0*B**2*SI**2-3.0d0*B**2-8.0d0*SI**2+9))/( - & 12.0d0*B**2*CO*(SI**2-1)) - h(293) =SI**2/(2.0d0*B*(SI**2-1)) - h(300) =(SI**2*(-B**2+1))/(2.0d0*B**3*(SI**2-1)) - h(321) =(SI*(-4.0d0*SI**2+3))/(24.0d0*CO*(SI**2-1)) - h(326) =(SI*(4.0d0*B**2*SI**2-3.0d0*B**2-10.0d0*SI**2+9))/( - & 12.0d0*B**2*CO*(SI**2-1)) - h(335) =(SI*(-4.0d0*B**4*SI**2+3.0d0*B**4+20.0d0*B**2*SI**2- - & 18.0d0*B**2-16.0d0*SI**2+15))/(24.0d0*B**4*CO*(SI**2-1)) - h(588) =(SI**2*(SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+1)) - h(592) =(SI*(SI**2+6))/(16.0d0*B*CO*(SI**2-1)) - h(597) =(SI**2*(3.0d0*SI**2-4))/(16.0d0*(SI**4-2.0d0*SI**2+ - & 1)) - h(602) =(SI**2*(-3.0d0*B**2*SI**2+4.0d0*B**2+15.0d0*SI**2-16.0d0 - & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) - h(615) =(3.0d0*SI*(-SI**2+2))/(8.0d0*B*CO*(SI**2-1)) - h(622) =(SI*(3.0d0*B**2*SI**2-6.0d0*B**2-7.0d0*SI**2+10))/( - & 8.0d0*B**3*CO*(SI**2-1)) - h(643) =(SI**2*(5.0d0*SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+ - & 1)) - h(648) =(SI**2*(-5.0d0*B**2*SI**2+4.0d0*B**2+17.0d0*SI**2-16.0d0 - & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) - h(657) =(SI**2*(5.0d0*B**4*SI**2-4.0d0*B**4-34.0d0*B**2*SI**2 - & +32.0d0*B**2+29.0d0*SI**2-28))/(32.0d0*B**4*(SI**4-2.0d0*SI**2+ - & 1)) - h(695) =(SI*(-7.0d0*SI**2+6))/(16.0d0*B*CO*(SI**2-1)) - h(702) =(SI*(7.0d0*B**2*SI**2-6.0d0*B**2-11.0d0*SI**2+10))/( - & 8.0d0*B**3*CO*(SI**2-1)) - h(713) =(SI*(-7.0d0*B**4*SI**2+6.0d0*B**4+22.0d0*B**2*SI**2- - & 20.0d0*B**2-15.0d0*SI**2+14))/(16.0d0*B**5*CO*(SI**2-1)) -c - call revf(1,h,mh) -c - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/iron.f b/OpticsJan2020/MLI_light_optics/Src/iron.f deleted file mode 100644 index be70550..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/iron.f +++ /dev/null @@ -1,2264 +0,0 @@ -c Changes made 6/04, especially to ImKmpak to eliminate -c single-double mismatches, etc. P. Walstrom -c This collection of subroutines is in the file IRON.for -c -c They are used in adding the equivalent iron shape function to -c magnets. Must also link in Bessel function package ImKmpak to -c do iron coils. -c CTM Bessel package ImKmpak included in this file for MaryLie use (4/99) -c 6/04- cleaned up package- passes ftnchek -c Subroutines in this package: -c subroutine fksegm(z1,z2,ai,k,fcos,fsin,nterm) -c subroutine firon(k,fsin,fcos) -c subroutine fderiv(k,fsin,fcos) -c subroutine filonin(xmin,xmax,y,nsteps,fname, -c subroutine weight(theta,alpha,beta,gamma) -c subroutine cubint(x1,x2,y1,y2,y1p,y2p,a1,a2,a3,a4) -c subroutine fbar11(xl,w1,w2,s1,s2,xbar) -c subroutine fk11(k,xl,w1,w2,s1,s2,fk,gk) -c subroutine divis(a,b,xl,w1,w2,s1,s2,xj,nj) -c function fkern(k) -c function aintgrl(a,a2,m) -c -c -c -c - function fkern(k) - implicit double precision(a-h,o-z) - double precision k - parameter(small=1.d-12) - common/stuff/ a,b,m -c Evaluates Fourier fkernel -K_m(kb) * I_m'(ka) / ( K_m'(kb) * I_m(kb)) -c This kernel when convoluted with the shape function gives the iron -c contribution to a winding of radius a with a cylinder of radius b. - dimension yia(3),yib(3),ykb(3) - bk=k*b - if(bk.gt.small) go to 1 -c small k value - fkern=1.d0 - if(m.lt.2) return - fkern=(a/b)**(m-1) - return - 1 continue - ml=m-1 - bk=b*k - ak=a*k - mm=m - if(bk.gt.1.d1) go to 2 -c Useunscaled Bessel functions - call bessin(3,ml,ak,yia,1) - call bessin(1,mm,bk,yib,1) - call besskn(3,ml,bk,ykb,1) -c derivatives of K and I - xkmp=-0.5d0*(ykb(1)+ykb(3)) - ximp=0.5d0*(yia(1)+yia(3)) - xnum=ykb(2)*ximp - fkern=-xnum/(xkmp*yib(1)) - return -c Usescaled Bessel functions - 2 continue - call bessin(3,ml,ak,yia,2) - call bessin(1,mm,bk,yib,2) - call besskn(3,ml,bk,ykb,2) -c derivatives of K and I - xkmp=-0.5d0*(ykb(1)+ykb(3)) - ximp=0.5d0*(yia(1)+yia(3)) - xnum=ykb(2)*ximp - fkern=-xnum/(xkmp*yib(1)) - fkern=fkern*dexp((a-b)*k) - return - end -c -c*********************************** -c - subroutine fksegm(z1,z2,ai,k,fcos,fsin,nterm) - implicit double precision(a-h,o-z) - real*8 k,k2 -c This subroutine evaluates -c -c fcos=1/pi * integral from z1 to z2 of f(x) * cos(k*x), and -c fsin=1/pi * integral from z1 to z2 of f(x) * sin(k*x) -c -c where f(x)= ai(1)+ai(2)*x+ai(3)*x^2+ai(4)*x^3+ai(5)*x^4 -c - parameter(pi=3.141592653589793d0) - parameter(smal=0.05d0) - parameter(c13=-1.d0/6.d0,c15=1.d0/1.2d2,c17=-1.d0/5.04d3, - &c19=1.d0/3.6288d5) - parameter(c22=0.5d0,c24=-0.125d0,c26=1.d0/1.44d2) - parameter(c28=-1.d0/5.76d3,c210=1.d0/4.03d5) - parameter(c33=1.d0/3.d0,c35=-0.1d0,c37=1.d0/1.68d2, - &c39=-1.d0/6.480d3) - parameter(c44=0.25d0,c46=-1.d0/1.2d1,c48=1.d0/1.92d2, - &c410=-1.d0/7.2d3) - parameter(c55=0.2d0,c57=-1.d0/1.4d1,c59=1.d0/2.16d2) - parameter(d12=0.5d0,d14=-1.d0/2.4d1,d16=1.d0/7.2d2, - &d18=-1.d0/4.032d4,d110=1.d0/3.6288d6) - parameter(d23=1.d0/3.d0,d25=-1.d0/3.d1,d27=1.d0/8.4d2, - &d29=-1.d0/4.536d4) - parameter(d34=0.25d0,d36=-1.d0/3.6d1,d38=1.d0/9.6d2, - &d310=-1.d0/5.04d4) - parameter(d45=0.2d0,d47=-1.d0/4.2d1,d49=1.d0/1.08d3) - parameter(d56=1.d0/6.d0,d58=-1.d0/4.8d1,d510=1.d0/1.2d3) - dimension ai(5) - if((nterm.gt.5).or.(nterm.lt.1)) go to 1001 - check=(z2-z1)*k - if(check.lt.smal) go to 50 -c k is not "small" - coskz1=dcos(k*z1) - coskz2=dcos(k*z2) - sinkz1=dsin(k*z1) - sinkz2=dsin(k*z2) - r=1.d0/k -c useidentity cos(k*z2)-cos(k*z1)=2 sin(k(z2+z1)/2) * sin(k(z1-z2)/2) to -c retain accuracy for small k. - fc1=2.d0*dsin(0.5d0*k*(z1+z2))*dsin(0.5d0*k*(z1-z2))*r - fs1=(sinkz2-sinkz1)*r - fcos=ai(1)*fs1 - fsin=-ai(1)*fc1 - if(nterm.lt.2) go to 40 - fc2=(z2*coskz2-z1*coskz1)*r - fs2=(z2*sinkz2-z1*sinkz1)*r - fcos=fcos+ai(2)*(fc1+k*fs2)*r - fsin=fsin+ai(2)*(fs1-k*fc2)*r - if(nterm.lt.3) go to 40 - z12=z1**2 - z22=z2**2 - r2=r**2 - fc3=(z22*coskz2-z12*coskz1)*r - fs3=(z22*sinkz2-z12*sinkz1)*r - fcos=fcos+ai(3)*(-2.d0*fs1+k*(2.d0*fc2+k*fs3))*r2 - fsin=fsin+ai(3)*(2.d0*fc1+k*(2.d0*fs2-k*fc3))*r2 - if(nterm.lt.4) go to 40 - z13=z1*z12 - z23=z2*z22 - r3=r*r2 - fc4=(z23*coskz2-z13*coskz1)*r - fs4=(z23*sinkz2-z13*sinkz1)*r - fsin=fsin+ai(4)*(-6.d0*fs1+k*(6.d0*fc2+k*(3.d0*fs3-k*fc4)))*r3 - fcos=fcos+ai(4)*(-6.d0*fc1+k*(-6.d0*fs2+k*(3.d0*fc3+k*fs4)))*r3 - if(nterm.lt.5) go to 40 - z14=z1*z13 - z24=z2*z23 - r4=r*r3 - fc5=(z24*coskz2-z14*coskz1)*r - fs5=(z24*sinkz2-z14*sinkz1)*r - fcos=fcos+ai(5)*(24.d0*fs1+k*(-24.d0*fc2+k*(-12.d0*fs3+ - &k*(4.d0*fc4+k*fs5))))*r4 - fsin=fsin+ai(5)*(-24.d0*fc1+k*(-24.d0*fs2+k*(12.d0*fc3+ - &k*(4.d0*fs4-k*fc5))))*r4 - 40 fcos=fcos/pi - fsin=fsin/pi - return -c small k limit -c Note- in deriving these, it is necessary to carry the expansions of -c sin(k*z1),sin(k*z2),cos(k*z1),cos(k*z2) to enough places that all -c of the coefficients in the expansions for integral of sinkx * x**n -c andintegral of coskx * x**n -c areof the form 1/m, where m is an integer. (See parameter statements). -c This means sin to x**11, cos to x**10. - 50 continue - fcos=fcos/pi - fsin=fsin/pi - k2=k**2 - z12=z1**2 - z13=z1*z12 - z14=z1*z13 - z15=z1*z14 - z16=z1*z15 - z17=z1*z16 - z18=z1*z17 - z22=z2**2 - z23=z2*z22 - z24=z2*z23 - z25=z2*z24 - z26=z2*z25 - z27=z2*z26 - z28=z2*z27 - z211=z2-z1 - z212=z211*(z2+z1) - z213=z211*(z22+z1*z2+z12) - z214=z212*(z22+z12) - z215=z211*(z24+z23*z1+z22*z12+z2*z13+z14) - z216=z213*(z23+z13) - z217=z211*(z26+z25*z1+z24*z12+z23*z13+z22*z14+z2*z15+z16) - z218=z214*(z24+z14) - z219=z211*(z28+z27*z1+z26*z12+z25*z13+z24*z14+z23*z15+z22*z16+ - &z2*z17+z18) - z2110=z215*(z25+z15) - fcos=ai(1)*(z211+k2*(c13*z213+k2*(c15*z215+k2*(c17*z217+ - &k2*c19*z219)))) - fsin=ai(1)*k*(d12*z212+k2*(d14*z214+k2*(d16*z216+k2*(d18*z218+ - &k2*d110*z2110)))) - if(nterm.lt.2) go to 11 - fcos=fcos+ai(2)*(c22*z212+k2*(c24*z214+k2*(c26*z216+k2*(c28*z218+ - &k2*c210*z2110)))) - fsin=fsin+ai(2)*k*(d23*z213+k2*(d25*z215+k2* - * (d27*z217+k2*d29*z219))) - if(nterm.lt.3) go to 11 - fcos=fcos+ai(3)*(c33*z213+k2*(c35*z215+k2*(c37*z217+k2*c39*z219))) - fsin=fsin+ai(3)*k*(d34*z214+k2*(d36*z216+k2* - * (d38*z218+k2*d310*z2110))) - if(nterm.lt.4) go to 11 - fcos=fcos+ai(4)*(c44*z214+k2*(c46*z216+k2*(c48*z218+ - &k2*c410*z2110))) - fsin=fsin+ai(4)*k*(d45*z215+k2*(d47*z217+k2*d49*z219)) - if(nterm.lt.5) go to 11 - fcos=fcos+ai(5)*(c55*z215+k2*(c57*z217+k2*c59*z219)) - fsin=fsin+ai(5)*k*(d56*z216+k2*(d58*z218+k2*d510*z2110)) - 11 continue - fcos=fcos/pi - fsin=fsin/pi - return - 1001 write(6,*) 'NTERM out of bounds in FKSEGM: NTERM=',nterm - stop - end -c -c*********************************** -c - subroutine firon(k,fsin,fcos) - implicit double precision(a-h,o-z) - real*8 k - common/geom1/xl,w1,w2,s1,s2 - common/stuff/a,b,m - call fk11(k,xl,w1,w2,s1,s2,fk,gk) - hk=fkern(k) - fsin=gk*hk - fcos=fk*hk - return - end -c -c*********************************** -c - subroutine fderiv(k,fsin,fcos) - implicit double precision(a-h,o-z) - real*8 k - common/geom1/xl,w1,w2,s1,s2 - common/stuff/a,b,m - call fk11(k,xl,w1,w2,s1,s2,fk,gk) - hk=fkern(k) - fsin=-k*fk*hk - fcos=k*gk*hk - return - end -c -c*********************************** -c - subroutine filonin(xmin,xmax,y,nsteps,fname,sinint,cosint) -c This version uses a subroutine with two functions in the EXTERNAL, -c instead of one function in a function subroutine (FILONINT). -c Different functions for sine and cosine integrals 6-28-96. - implicit double precision(a-h,o-z) - external fname -c Generic Filon integrator -c Method of Filon is used to evaluate the integrals from xmin to xmax -c of -c -c fsin(x) sin xy dx and -c -c fcos(x) cos xy dx -c -c Method of Filon allows evaluation of the integral of an oscillating -c function without having to follow every wiggle with many evaluation -c points. This version has only a single freqency, y. - parameter(half=0.5d0,one=1.d0,zero=0.d0) - dimension dsinint(3),dcosint(3) - h=(xmax-xmin)*half/dfloat(nsteps) -c find Filon weights - theta=h*y - call weight(theta,alf,bet,gam) -c write(20,200) theta,alf,bet,gam -c 200format(1x,4(1pd11.4,1x)) -c Zero intermediate arrays. - do 111 ievod=1,3 - dsinint(ievod)=zero - 111 dcosint(ievod)=zero -c nowperform Filon integration -c Step through odd, then x values. - do 2 ievod=1,2 -c ievod=1 ----- odd points -c ievod=2 -----even points -c ievod=3 ------endpoints - nstp=nsteps -c Extra x value in set of even points. - if(ievod.eq.2) nstp=nsteps+1 - do 2 n=1,nstp - if(ievod.eq.2) go to 3 -c oddpoints. - x=h*dfloat(2*n-1)+xmin - wt=one - go to 4 -c even points - 3 wt=one - if(n.eq.1) wt=half - if(n.eq.nstp) wt=half - x=h*dfloat(2*n-2)+xmin - 4 continue -ccccccf=wt*fname(x) - call fname(x,fsin,fcos) - fsin=fsin*wt - fcos=fcos*wt - xy=x*y - cosxy=dcos(xy) - sinxy=dsin(xy) - dsinint(ievod)=dsinint(ievod)+fsin*sinxy - 2 dcosint(ievod)=dcosint(ievod)+fcos*cosxy -c Nowdo end points-first, upper end (xk=xkmx) - x=xmax - wt=one - do 5 iend=1,2 - xy=y*x - cosxy=dcos(xy) - sinxy=dsin(xy) -ccccccc f=wt*fname(x) - call fname(x,fsin,fcos) - fsin=fsin*wt - fcos=fcos*wt - dsinint(3)=dsinint(3)-fsin*cosxy - dcosint(3)=dcosint(3)+fcos*sinxy - x=xmin - 5 wt=-one -c Nowsum up contributions from ievod=1,2,3 with Filon weights. - sinint=h*(alf*dsinint(3)+bet*dsinint(2)+gam*dsinint(1)) - cosint=h*(alf*dcosint(3)+bet*dcosint(2)+gam*dcosint(1)) - return - end -c -c*********************************** -c - subroutine weight(theta,alpha,beta,gamma) -c Subroutine to calculate weights for method of Filon (called by FILON) - implicit double precision(a-h,o-z) - parameter(a1=2.d0/4.5d1,a2=2.d0/3.15d2,a3=2.d0/4.725d3) - parameter(b1=2.d0/3.d0,b2=2.d0/1.5d1,b3=4.d0/1.05d2, - &b4=2.d0/5.67d2) - parameter(c1=4.d0/3.0d0,c2=2.d0/1.5d1,c3=1.d0/2.1d2, - &c4=1.d0/1.134d4) - parameter(two=2.d0,smal1=1.d-1,one=1.d0) - if(dabs(theta).gt.smal1) go to 11 - t2=theta**2 - t3=theta*t2 - alpha=t3*(a1-t2*(a2-t2*a3)) - beta=b1+t2*(b2-t2*(b3-t2*b4)) - gamma=c1-t2*(c2-t2*(c3-t2*c4)) - return - 11 sinth=dsin(theta) - costh=dcos(theta) - onoth=one/theta - tuoth2=two*onoth**2 - beta=tuoth2*(one+costh*(costh-two*sinth*onoth)) - gamma=two*tuoth2*(sinth*onoth-costh) - alpha=onoth*(one+onoth*sinth*(costh-two*sinth*onoth)) - return - end -c -c*********************************** -c - subroutine cubint(x1,x2,y1,y2,y1p,y2p,a1,a2,a3,a4) - implicit double precision(a-h,o-z) - h=x2-x1 - a=y1 - b=y1p - c=(3.d0*(y2-y1-y1p*h)-h*(y2p-y1p))/h**2 - d=((y2p-y1p)*h-2.d0*(y2-y1-y1p*h))/h**3 - a1=a-x1*(b-x1*(c-x1*d)) - a2=b-x1*(2.d0*c-x1*3.d0*d) - a3=c-3.d0*x1*d - a4=d - return - end -c -c*********************************** -c - subroutine fbar11(xl,w1,w2,s1,s2,xbar) - implicit double precision(a-h,o-z) - parameter(third=1.d0/3.d0,sixth=1.d0/6.d0) - parameter(fifteenth=1.d0/1.5d1,eight15th=8.d0/1.5d1) - parameter(small=1.d-9) -c xl=coil length -c w1=width of the curved section from -xl/2 to the flattop. -c w2=width of the curved section from the flattop to xl/2. -c s1=LH slope*w1 -c s2=-RH slope*w2 -c -c Output variables: -c dg=vector with ndriv components containing the on-axis gradient, and -c its ndriv-1 derivatives. -c -c Shape function has form -c -c f(x)=1+A1(x+xl/2-w1)**2 + B1*(x+xl/2-w1)**4 -xl/2xl in GTYPE11-stopped') - stop - end -c -c*********************************** -c - subroutine fk11(k,xl,w1,w2,s1,s2,fk,gk) - implicit double precision(a-h,o-z) - real*8 k -c Modified 7-11 to use shifted form for better accuracy. -c Calculates cosine and sine transforms of type 11 shape function, -c Coil is centered in coordinate system. -c x=0at center of windings- i.e., LH end is at -xl/2, RH end at xl/2. -c -c Inputs: -c k=inverse-distance independent variable of transforms. (f(k),g(k)). -c xl=coil length -c w1=width of the curved section from -xl/2 to the flattop. -c w2=width of the curved section from the flattop to xl/2. -c s1=w1* slope at -xl/2 -c s2=-w2*slope at +xl/2 -c -c Outputs: -c -c fk=f(k)= cosine transform = 1/pi*integral from -xl/2 to xl/2 -c of f(x) * cos(k*x) dx -c gk=g(k)= sine transform = 1/pi*integral from -xl/2 to xl/2 -c of f(x) * sin(k*x) dx - parameter(fifteenth=1.d0/1.5d1,eight15th=8.d0/1.5d1) - parameter(small=1.d-9) - dimension ai(5) -c -c -c Shape function has form -c -c f(x)=1+A1(x+xl/2-w1)**2 + B1*(x+xl/2-w1)**4 -xl/2xl in FK11-stopped') - stop - end -c -c*********************************** -c - subroutine divis(a,b,xl,w1,w2,s1,s2,xj,nj) - implicit double precision(a-h,o-z) - dimension xj(101) - cwidth=xl-w1-w2 - hfw1=0.5d0*w1 - hfw2=0.5d0*w2 - hfl=0.5d0*xl - ratio=b/a - if(ratio.lt.1.1d0) go to 1001 - if(ratio.ge.1.3d0) go to 1 - t=2.d0*(b-a) - xj(1)=-hfl-3.d0*b - xj(2)=-hfl-b - xj(3)=-hfl-0.50d0*b - nl=3 - xj(nl+1)=-hfl-t - xj(nl+2)=-hfl - if(w1.lt.(4.d0*t)) go to 3 - if(w1.ge.(0.5d0*a)) go to 21 - xj(nl+3)=-hfl+t - xj(nl+4)=-hfl+hfw1 - xj(nl+5)=-hfl+w1-t - xj(nl+6)=-hfl+w1 - nw1=nl+6 - go to 4 - 21 xj(nl+3)=-hfl+t - xj(nl+4)=-hfl+0.25d0*w1 - xj(nl+5)=-hfl+hfw1 - xj(nl+6)=-hfl+0.75d0*w1 - xj(nl+7)=-hfl+w1-t - xj(nl+8)=-hfl+w1 - nw1=nl+8 - go to 4 - 3 xj(nl+3)=-hfl+hfw1 - xj(nl+4)=-hfl+w1 - nw1=nl+4 - 4 if(cwidth.lt.(4.d0*t)) go to 5 - if(cwidth.gt.a) go to 9 - xj(nw1+1)=-hfl+w1+t - xj(nw1+2)=hfw1-hfw2 - xj(nw1+3)=hfl-w2-t - xj(nw1+4)=hfl-w2 - nww=nw1+4 - go to 6 - 9 if(cwidth.gt.(4.d0*a)) go to 11 - xj(nw1+1)=-hfl+w1+t - xj(nw1+2)=-hfl+0.5d0*a+w1 - xj(nw1+3)=hfw1-hfw2 - xj(nw1+4)=hfl-0.5d0*a-w2 - xj(nw1+5)=hfl-w2-t - xj(nw1+6)=hfl-w2 - nww=nw1+6 - go to 6 - 11 if(cwidth.gt.(6.d0*a)) go to 25 - xj(nw1+1)=-hfl+w1+t - xj(nw1+2)=-hfl+w1+0.5d0*a - xj(nw1+3)=-hfl+w1+a - xj(nw1+4)=hfw1-hfw2 - xj(nw1+5)=hfl-w2-a - xj(nw1+6)=hfl-w2-0.5d0*a - xj(nw1+7)=hfl-w2-t - xj(nw1+8)=hfl-w2 - nww=nw1+8 - go to 6 - 25 xj(nw1+1)=-hfl+w1+t - xj(nw1+2)=-hfl+w1+0.5d0*a - xj(nw1+3)=-hfl+w1+a - xj(nw1+4)=-hfl+w1+0.25d0*cwidth - xj(nw1+5)=hfw1-hfw2 - xj(nw1+6)=hfl-w2-0.25d0*cwidth - xj(nw1+7)=hfl-w2-a - xj(nw1+8)=hfl-w2-0.5d0*a - xj(nw1+9)=hfl-w2-t - xj(nw1+10)=hfl-w2 - nww=nw1+10 - go to 6 - 5 xj(nw1+1)=-hfl+w1+0.2d0*cwidth - xj(nw1+2)=hfw1-hfw2 - xj(nw1+3)=hfl-w2-0.2d0*cwidth - xj(nw1+4)=hfl-w2 - nww=nw1+4 - 6 if(w2.lt.(4.d0*t)) go to 7 - if(w2.ge.0.5d0*a) go to 22 - xj(nww+1)=hfl-w2+t - xj(nww+2)=hfl-hfw2 - xj(nww+3)=hfl-t - xj(nww+4)=hfl - nw2=nww+4 - go to 8 - 22 xj(nww+1)=hfl-w2+t - xj(nww+2)=hfl-0.75d0*w2 - xj(nww+3)=hfl-hfw2 - xj(nww+4)=hfl-0.25d0*w2 - xj(nww+5)=hfl-t - xj(nww+6)=hfl - nw2=nww+6 - go to 8 - 7 xj(nww+1)=hfl-hfw2 - xj(nww+2)=hfl - nw2=nww+2 - 8 xj(nw2+1)=hfl+t - xj(nw2+2)=hfl+0.5d0*b - nr=nw2+2 - 16 xj(nr+1)=hfl+b - xj(nr+2)=hfl+3.d0*b - nj=nr+2 - return -c************************************************************************* -c -c r/a> or equal 1.3 - 1 if(ratio.ge.1.5d0) go to 2 - xj(1)=-hfl-3.d0*b - xj(2)=-hfl-b - xj(3)=-hfl-0.50d0*b - xj(4)=-hfl-0.25d0*b - xj(5)=-hfl - nl=5 - if(w1.ge.(0.5d0*a)) go to 31 - xj(nl+1)=-hfl+hfw1 - xj(nl+2)=-hfl+w1 - nw1=nl+2 - go to 34 - 31 xj(nl+1)=-hfl+0.25d0*w1 - xj(nl+2)=-hfl+hfw1 - xj(nl+3)=-hfl+0.75d0*w1 - xj(nl+4)=-hfl+w1 - nw1=nl+4 - 34 if(cwidth.gt.(2.d0*a)) go to 39 - xj(nw1+1)=hfw1-hfw2 - xj(nw1+2)=hfl-w2 - nww=nw1+2 - go to 36 - 39 if(cwidth.gt.(4.d0*a)) go to 41 - xj(nw1+1)=-hfl+0.5d0*a+w1 - xj(nw1+2)=hfw1-hfw2 - xj(nw1+3)=hfl-0.5d0*a-w2 - xj(nw1+4)=hfl-w2 - nww=nw1+4 - go to 36 - 41 if(cwidth.gt.(6.d0*a)) go to 45 - xj(nw1+1)=-hfl+w1+0.5d0*a - xj(nw1+2)=-hfl+w1+a - xj(nw1+3)=hfw1-hfw2 - xj(nw1+4)=hfl-w2-a - xj(nw1+5)=hfl-w2-0.5d0*a - xj(nw1+6)=hfl-w2 - nww=nw1+6 - go to 36 - 45 xj(nw1+1)=-hfl+w1+0.5d0*a - xj(nw1+2)=-hfl+w1+a - xj(nw1+3)=-hfl+w1+0.25d0*cwidth - xj(nw1+4)=hfw1-hfw2 - xj(nw1+5)=hfl-w2-0.25d0*cwidth - xj(nw1+6)=hfl-w2-a - xj(nw1+7)=hfl-w2-0.5d0*a - xj(nw1+8)=hfl-w2 - nww=nw1+8 - 36 if(w2.ge.0.5d0*a) go to 42 - xj(nww+1)=hfl-hfw2 - xj(nww+2)=hfl - nw2=nww+2 - go to 38 - 42 xj(nww+1)=hfl-0.75d0*w2 - xj(nww+2)=hfl-hfw2 - xj(nww+3)=hfl-0.25d0*w2 - xj(nww+4)=hfl - nw2=nww+4 - 38 xj(nw2+1)=hfl+0.25d0*b - xj(nw2+2)=hfl+0.5d0*b - xj(nw2+3)=hfl+b - xj(nw2+4)=hfl+3.d0*b - nj=nw2+4 - return -c************************************************************************* -c -c r/a> or equal 1.5 - 2 continue -c To left of windings - xj(1)=-hfl-3.d0*b - xj(2)=-hfl-2.d0*b - xj(3)=-hfl-b - xj(4)=-hfl-0.50d0*b - xj(5)=-hfl-0.25d0*b - xj(6)=-hfl - nl=6 -c LH curved section, w1 in width. - if(w1.ge.(0.5d0*b)) go to 51 - xj(nl+1)=-hfl+hfw1 - xj(nl+2)=-hfl+w1 - nw1=nl+2 - go to 54 - 51 xj(nl+1)=-hfl+0.25d0*w1 - xj(nl+2)=-hfl+hfw1 - xj(nl+3)=-hfl+0.75d0*w1 - xj(nl+4)=-hfl+w1 - nw1=nl+4 -c Central flattop - 54 if(cwidth.ge.(2.d0*b)) go to 59 - xj(nw1+1)=-hfl+w1+0.25d0*cwidth - xj(nw1+2)=hfw1-hfw2 - xj(nw1+3)=hfl-w2-0.25d0*cwidth - xj(nw1+4)=hfl-w2 - nww=nw1+4 - go to 56 - 59 if(cwidth.gt.(4.d0*b)) go to 52 - xj(nw1+1)=-hfl+0.5d0*b+w1 - xj(nw1+2)=hfw1-hfw2 - xj(nw1+3)=hfl-0.5d0*b-w2 - xj(nw1+4)=hfl-w2 - nww=nw1+4 - go to 56 - 52 if(cwidth.gt.(6.d0*b)) go to 55 - xj(nw1+1)=-hfl+w1+0.5d0*b - xj(nw1+2)=-hfl+w1+b - xj(nw1+3)=hfw1-hfw2 - xj(nw1+4)=hfl-w2-b - xj(nw1+5)=hfl-w2-0.5d0*b - xj(nw1+6)=hfl-w2 - nww=nw1+6 - go to 56 - 55 xj(nw1+1)=-hfl+w1+0.5d0*b - xj(nw1+2)=-hfl+w1+b - xj(nw1+3)=-hfl+w1+0.25d0*cwidth - xj(nw1+4)=hfw1-hfw2 - xj(nw1+5)=hfl-w2-0.25d0*cwidth - xj(nw1+6)=hfl-w2-b - xj(nw1+7)=hfl-w2-0.5d0*b - xj(nw1+8)=hfl-w2 - nww=nw1+8 -c RH curved section, w2 in width. - 56 if(w2.ge.0.5d0*b) go to 57 - xj(nww+1)=hfl-hfw2 - xj(nww+2)=hfl - nw2=nww+2 - go to 58 - 57 xj(nww+1)=hfl-0.75d0*w2 - xj(nww+2)=hfl-hfw2 - xj(nww+3)=hfl-0.25d0*w2 - xj(nww+4)=hfl - nw2=nww+4 -c To right of windings. - 58 xj(nw2+1)=hfl+0.25d0*b - xj(nw2+2)=hfl+0.5d0*b - xj(nw2+3)=hfl+b - xj(nw2+4)=hfl+2.d0*b - xj(nw2+5)=hfl+3.d0*b - nj=nw2+5 - return - 1001 write(6,*) 'b/a=',ratio,' <1.1 in DIVIS- stopped' - stop - end -c -c*********************************** -c - function aintgrl(a,a2,m) - implicit double precision(a-h,o-z) -c calculates integral from a to a2 of dx/x**(m-1) -c m> or equal 1. - if(m.gt.1) go to 1 -c m=1 - aintgrl=a2-a - return - 1 if(m.gt.2) go to 2 -c m=2 - aintgrl=dlog(a2/a) - return - 2 aintgrl=(a2**(2-m)-a**(2-m))/dfloat(2-m) - return - end -c -c*********************************** -c - subroutine fitlength(Leff,a1i,a2i,a3i,a4i,xi,ni) - implicit double precision(a-h,o-z) - double precision Leff -c Calculates Leff=integral for xi(1) to xi(ni) of a Piecewise-Continuous -c Polynomial of maximum degree 3 (=cubic). The PCP is assumed to be zero -c outside of [xi(1),xi(ni)] -c ThePCP is of the form a1i(i)+a2i(i)*x+a3i(i)*x**2+a4i(i)*x**3 -c Inputs: -c -c a1i,a2i,a3i,a4i are arrays with ni-1 nonzero components (sometimes -c more are nonzero) -c xi is an array of length ni containing the endpoints of the ni-1 -c intervals on which the PCP is defined. -c ni is the number of node points specifying the intervals for the PCP. -c -c Output: Leff -c - parameter(third=1.d0/3.d0) - dimension a1i(ni),a2i(ni),a3i(ni),a4i(ni),xi(ni) - Leff=0.d0 - do 1 i=1,ni-1 - x1=xi(i) - x2=xi(i+1) - Leff=Leff+x2*(a1i(i)+x2*(0.5d0*a2i(i)+x2*(third*a3i(i)+ - &x2*0.25d0*a4i(i))))- - &x1*(a1i(i)+x1*(0.5d0*a2i(i)+x1*(third*a3i(i)+x1*0.25d0*a4i(i)))) - 1 continue - return - end -c -c*********************************** -c - subroutine BESSIn(M,N,X,y,KODE) -c ImKmpak is a collection of portable modified Bessel function routines. -c Written 4-96 by P. L. Walstrom Northrop Grumman -c Modified from CLAMS and Numerical Recipes. Should give 12-digit -c precision for all valid arguments. -c Should use exponentially scaled functions when x is greater than 20. -c Function routines: -c dbesI0s=I0 -c dbesI0es=exponentially scaled I0 -c dbesK0s=K0 -c dbesK0es=exponentially scaled K0 -c dbesI1s=I1 -c dbesI1es=exponentially scaled I1 -c dbesK1s=K1 -c dbesK1es=exponentially scaled K1 -c Subroutines: -c -c BESSIn( M,N,x,y,KODE) -c computes a M-member sequence I_k(x), k=N, N+1, N+2 ... N+M-1. -c KODE=1 means unscaled, KODE=2 is exponentially scaled. Results in vector -c y,with y(1)=I_N, y(2)=I_N+1, etc. -c -c -c bessKn( M,N,x,y,KODE) -c computes a M-member sequence K_k(x), k=N, N+1, N+2 ... N+M-1. -c KODE=1 means unscaled, KODE=2 is exponentially scaled. Results in vector -c y,with y(1)=K_N, y(2)=K_N+1, etc. -c -c -c Exponential scaling means for the I_m -c -c I_m(x) scaled = exp(-x) * I_m (x) unscaled -c -c andfor the K_m -c -c K_m(x) scaled = exp(x) * K_m (x) unscaled -c -c******************************************************************* - implicit double precision(a-h,o-z) -c Calculates an M-member sequence of modified Bessel functions of the -c first kind. Needs subroutines for exponentially scaled and unscaled -c I_0(x). Sequence contains either unscaled or scaled Bessel functions. -c KODE=1 means unscaled. -c KODE=2 means scaled. -c y(k), k=1,2,..m contains I_N (x),I_N+1 (x),...I_N+M-1 (x) -c N must be > or = 0. - PARAMETER(IACC=40,BIGNO=1.0d10,BIGNI=1.0d-10) - parameter(mmax=1000) - dimension y(m),z(mmax) -C - if(m.gt.20) go to 1005 - if(dabs(x).gt.0.1d0) go to 44 - if(dabs(x).ne.0.d0) go to 23 - do 24 l=1,m - if(n.eq.0) y(1)=1.d0 - 24 y(l)=0.d0 - return - 23 continue -c Series expansion for I_n, I_n+1, ...I_n+m-1. - if(m.gt.mmax) go to 1001 - qx2=0.25d0*x**2 - hfx=0.5d0*x -c Find 1/n! and (x/2)**n. - rnfac=1.d0 - hfxn=1.d0 - if(n.gt.0) hfxn=hfx - if(n.lt.2) go to 1 - do 2 l=2,n - hfxn=hfxn*hfx - 2 rnfac=rnfac/dfloat(l) - 1 y(1)=rnfac -c find 1/ (n+l)!, l=0,1,2...m-1. -c store in z(1),z(2)...z(m) - z(1)=rnfac - if(m.lt.2) go to 6 - do 3 l=2,m - z(l)=z(l-1)/dfloat(l+n-1) - 3 y(l)=z(l) - 6 yy=1.d0 - do 5 k=1,4 - yy=yy*qx2/dfloat(k) - do 5 l=1,m - z(l)=z(l)/dfloat(l+k+n-1) - 5 y(l)=y(l)+yy*z(l) - y(1)=y(1)*hfxn - if(m.lt.2) go to 9 - yy=hfxn - do 10 l=2,m - yy=yy*hfx - 10 y(l)=y(l)*yy - 9 continue - if(kode.eq.1) return -c convert vector of I_n, I_n+1...I_n+m-1 to exponentially scaled values - zz=dexp(-dabs(x)) - do 45 l=1,m - 45 y(l)=zz*y(l) - return -c Larger x- use downwards recursion - 44 n2=n+m-1 -cryne IF (N.LT.0) PAUSE 'bad argument N < 0 in BESSIn' - IF (N.LT.0) write(6,*) 'bad argument N < 0 in BESSIn' - if(dabs(x).gt.dfloat(2*n2)) go to 60 - TOX=2.d0/X - BIP=0.d0 - BI=1.d0 - do 21 k=1,m - 21 y(k)=0.d0 - MAX=2*((N2+dINT(dSQRT(dFLOAT(IACC*N2))))) - DO 11 J=MAX,1,-1 - BIM=BIP+dFLOAT(J)*TOX*BI - BIP=BI - BI=BIM -c Rescale large numbers - IF (dABS(BI).GT.BIGNO) THEN - BI=BI*BIGNI - BIP=BIP*BIGNI - jmax=N2 - jmin=j+1 - if(jmin.gt.jmax) go to 22 - jdif=n2-j - if(jdif.gt.m) go to 17 - do 13 jj=jmin,jmax - k=jj-jmax+m - 13 y(k)=y(k)*bigni - go to 22 - 17 do 18 k=1,m - 18 y(k)=y(k)*bigni - 22 continue - ENDIF -c Rescale small numbers. - IF (dABS(BI).lT.BIGNI) THEN - BI=BI*BIGNO - BIP=BIP*BIGNO - jmax=N2 - jmin=j+1 - if(jmin.gt.jmax) go to 25 - jdif=n2-j - if(jdif.gt.m) go to 19 - do 16 jj=jmin,jmax - k=jj-jmax+m - 16 y(k)=y(k)*bigno - go to 25 - 19 do 20 k=1,m - 20 y(k)=y(k)*bigno - 25 continue - ENDIF - do 14 k=1,m - ncheck=k+n2-m - 14 if(j.eq.ncheck) y(k)=bip -11 CONTINUE - if(KODE.eq.1) zz=dbesi0s(x) - if(KODE.eq.2) zz=dbsi0es(x) - do 15 k=1,m - 15 y(k)=y(k)*zz/BI - if(n.eq.0) y(1)=zz - RETURN -c Very large x- use upwards recursion - 60 continue - if(kode.eq.2) bim=dbsi0es(x) - if(kode.eq.2) bi=dbsi1es(x) - if(kode.eq.1) bim=dbesi0s(x) - if(kode.eq.1) bi=dbesi1s(x) - if(n.gt.1) go to 64 - if(n.gt.0) go to 63 -c n=0 - y(1)=bim - if(m.lt.2) return - y(2)=bi - if(m.lt.3) return - lmin=3 - go to 64 - 63 y(1)=bi - if(m.lt.2) return - lmin=2 - 64 n2=n+m-1 - if(n.gt.1) lmin=1 - tox=2.d0/x - do 61 j=1,n2-1 - bip=bim-dfloat(j)*tox*bi - bim=bi - bi=bip - do 62 l=lmin,m - jj=n+l-2 - 62 if(jj.eq.j) y(l)=bi - 61 continue - return - 1001 write(5,200) m,mmax - 200 format(1x,'m=',i4,' > mmax=',i4,' in BESSIN-stopped') - stop - 1005 write(6,201) m - 201 format(1x,'m in BESSIn= ',i2,' is > 20- stopped') - stop - END - DOUBLE PRECISION FUNCTION DBSI0Es(X) -c Stripped of extraneous calls, etc. to make it portable. -C***BEGIN PROLOGUE DBSI0E -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESI0E-S DBSI0E-D),BESSEL FUNCTION, -C EXPONENTIALLY SCALED,FIRST KIND, -C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, -C ORDER ZERO,SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the d.p. exponentially scaled hyperbolic Bessel -C function of the first kind of order zero. -C***DESCRIPTION -C -C DBSI0E(X) calculates the double precision exponentially scaled -C modified (hyperbolic) Bessel function of the first kind of order -C zerofor double precision argument X. The result is the Bessel -C function I0(X) multiplied by EXP(-ABS(X)). -C -C Series for BI0 on the interval 0. to 9.00000E+00 -C with weighted error 9.51E-34 -C log weighted error 33.02 -C significant figures required 33.31 -C decimal places required 33.65 -C -C Series for AI0 on the interval 1.25000E-01 to 3.33333E-01 -C with weighted error 2.74E-32 -C log weighted error 31.56 -C significant figures required 30.15 -C decimal places required 32.39 -C -C Series for AI02 on the interval 0. to 1.25000E-01 -C with weighted error 1.97E-32 -C log weighted error 31.71 -C significant figures required 30.15 -C decimal places required 32.63 -C***REFERENCES (NONE) -C***ROUTINES CALLED DCSEVLs,INITDS -C***END PROLOGUE DBSI0E - DOUBLE PRECISION X, BI0CS(18), AI0CS(46), AI02CS(69), - 1Y,DCSEVLs,eta - SAVE BI0CS, AI0CS, AI02CS, NTI0, NTAI0, NTAI02 - DATA BI0CS( 1) /-.7660547252 8391449510 8189497624 3285 D-1 / - DATA BI0CS( 2) /+.1927337953 9938082699 5240875088 1196 D+1 / - DATA BI0CS( 3) /+.2282644586 9203013389 3702929233 0415 D+0 / - DATA BI0CS( 4) /+.1304891466 7072904280 7933421069 1888 D-1 / - DATA BI0CS( 5) /+.4344270900 8164874513 7868268102 6107 D-3 / - DATA BI0CS( 6) /+.9422657686 0019346639 2317174411 8766 D-5 / - DATA BI0CS( 7) /+.1434006289 5106910799 6209187817 9957 D-6 / - DATA BI0CS( 8) /+.1613849069 6617490699 1541971999 4611 D-8 / - DATA BI0CS( 9) /+.1396650044 5356696994 9509270814 2522 D-10 / - DATA BI0CS( 10) /+.9579451725 5054453446 2752317189 3333 D-13 / - DATA BI0CS( 11) /+.5333981859 8625021310 1510774400 0000 D-15 / - DATA BI0CS( 12) /+.2458716088 4374707746 9678591999 9999 D-17 / - DATA BI0CS( 13) /+.9535680890 2487700269 4434133333 3333 D-20 / - DATA BI0CS( 14) /+.3154382039 7214273367 8933333333 3333 D-22 / - DATA BI0CS( 15) /+.9004564101 0946374314 6666666666 6666 D-25 / - DATA BI0CS( 16) /+.2240647369 1236700160 0000000000 0000 D-27 / - DATA BI0CS( 17) /+.4903034603 2428373333 3333333333 3333 D-30 / - DATA BI0CS( 18) /+.9508172606 1226666666 6666666666 6666 D-33 / - DATA AI0CS( 1) /+.7575994494 0237959427 2987203743 8 D-1 / - DATA AI0CS( 2) /+.7591380810 8233455072 9297873320 4 D-2 / - DATA AI0CS( 3) /+.4153131338 9237505018 6319749138 2 D-3 / - DATA AI0CS( 4) /+.1070076463 4390730735 8242970217 0 D-4 / - DATA AI0CS( 5) /-.7901179979 2128946607 5031948573 0 D-5 / - DATA AI0CS( 6) /-.7826143501 4387522697 8898980690 9 D-6 / - DATA AI0CS( 7) /+.2783849942 9488708063 8118538985 7 D-6 / - DATA AI0CS( 8) /+.8252472600 6120271919 6682913319 8 D-8 / - DATA AI0CS( 9) /-.1204463945 5201991790 5496089110 3 D-7 / - DATA AI0CS( 10) /+.1559648598 5060764436 1228752792 8 D-8 / - DATA AI0CS( 11) /+.2292556367 1033165434 7725480285 7 D-9 / - DATA AI0CS( 12) /-.1191622884 2790646036 7777423447 8 D-9 / - DATA AI0CS( 13) /+.1757854916 0324098302 1833124774 3 D-10 / - DATA AI0CS( 14) /+.1128224463 2189005171 4441135682 4 D-11 / - DATA AI0CS( 15) /-.1146848625 9272988777 2963387698 2 D-11 / - DATA AI0CS( 16) /+.2715592054 8036628726 4365192160 6 D-12 / - DATA AI0CS( 17) /-.2415874666 5626878384 4247572028 1 D-13 / - DATA AI0CS( 18) /-.6084469888 2551250646 0609963922 4 D-14 / - DATA AI0CS( 19) /+.3145705077 1754772937 0836026730 3 D-14 / - DATA AI0CS( 20) /-.7172212924 8711877179 6217505917 6 D-15 / - DATA AI0CS( 21) /+.7874493403 4541033960 8390960332 7 D-16 / - DATA AI0CS( 22) /+.1004802753 0094624023 4524457183 9 D-16 / - DATA AI0CS( 23) /-.7566895365 3505348534 2843588881 0 D-17 / - DATA AI0CS( 24) /+.2150380106 8761198878 1205128784 5 D-17 / - DATA AI0CS( 25) /-.3754858341 8308744291 5158445260 8 D-18 / - DATA AI0CS( 26) /+.2354065842 2269925769 0075710532 2 D-19 / - DATA AI0CS( 27) /+.1114667612 0479285302 2637335511 0 D-19 / - DATA AI0CS( 28) /-.5398891884 3969903786 9677932270 9 D-20 / - DATA AI0CS( 29) /+.1439598792 2407526770 4285840452 2 D-20 / - DATA AI0CS( 30) /-.2591916360 1110934064 6081840196 2 D-21 / - DATA AI0CS( 31) /+.2238133183 9985839074 3409229824 0 D-22 / - DATA AI0CS( 32) /+.5250672575 3647711727 7221683199 9 D-23 / - DATA AI0CS( 33) /-.3249904138 5332307841 7343228586 6 D-23 / - DATA AI0CS( 34) /+.9924214103 2050379278 5728471040 0 D-24 / - DATA AI0CS( 35) /-.2164992254 2446695231 4655429973 3 D-24 / - DATA AI0CS( 36) /+.3233609471 9435940839 7333299199 9 D-25 / - DATA AI0CS( 37) /-.1184620207 3967424898 2473386666 6 D-26 / - DATA AI0CS( 38) /-.1281671853 9504986505 4833868799 9 D-26 / - DATA AI0CS( 39) /+.5827015182 2793905116 0556885333 3 D-27 / - DATA AI0CS( 40) /-.1668222326 0261097193 6450150399 9 D-27 / - DATA AI0CS( 41) /+.3625309510 5415699757 0068480000 0 D-28 / - DATA AI0CS( 42) /-.5733627999 0557135899 4595839999 9 D-29 / - DATA AI0CS( 43) /+.3736796722 0630982296 4258133333 3 D-30 / - DATA AI0CS( 44) /+.1602073983 1568519633 6551253333 3 D-30 / - DATA AI0CS( 45) /-.8700424864 0572298845 2249599999 9 D-31 / - DATA AI0CS( 46) /+.2741320937 9374811456 0341333333 3 D-31 / - DATA AI02CS( 1) /+.5449041101 4108831607 8960962268 0 D-1 / - DATA AI02CS( 2) /+.3369116478 2556940898 9785662979 9 D-2 / - DATA AI02CS( 3) /+.6889758346 9168239842 6263914301 1 D-4 / - DATA AI02CS( 4) /+.2891370520 8347564829 6692402323 2 D-5 / - DATA AI02CS( 5) /+.2048918589 4690637418 2760534093 1 D-6 / - DATA AI02CS( 6) /+.2266668990 4981780645 9327743136 1 D-7 / - DATA AI02CS( 7) /+.3396232025 7083863451 5084396952 3 D-8 / - DATA AI02CS( 8) /+.4940602388 2249695891 0482449783 5 D-9 / - DATA AI02CS( 9) /+.1188914710 7846438342 4084525196 3 D-10 / - DATA AI02CS( 10) /-.3149916527 9632413645 3864862961 9 D-10 / - DATA AI02CS( 11) /-.1321581184 0447713118 7540739926 7 D-10 / - DATA AI02CS( 12) /-.1794178531 5068061177 7943574026 9 D-11 / - DATA AI02CS( 13) /+.7180124451 3836662336 7106429346 9 D-12 / - DATA AI02CS( 14) /+.3852778382 7421427011 4089801777 6 D-12 / - DATA AI02CS( 15) /+.1540086217 5214098269 1325823339 7 D-13 / - DATA AI02CS( 16) /-.4150569347 2872220866 2689972015 6 D-13 / - DATA AI02CS( 17) /-.9554846698 8283076487 0214494312 5 D-14 / - DATA AI02CS( 18) /+.3811680669 3526224207 4605535511 8 D-14 / - DATA AI02CS( 19) /+.1772560133 0565263836 0493266675 8 D-14 / - DATA AI02CS( 20) /-.3425485619 6772191346 1924790328 2 D-15 / - DATA AI02CS( 21) /-.2827623980 5165834849 4205593759 4 D-15 / - DATA AI02CS( 22) /+.3461222867 6974610930 9706250813 4 D-16 / - DATA AI02CS( 23) /+.4465621420 2967599990 1042054284 3 D-16 / - DATA AI02CS( 24) /-.4830504485 9441820712 5525403795 4 D-17 / - DATA AI02CS( 25) /-.7233180487 8747539545 6227240924 5 D-17 / - DATA AI02CS( 26) /+.9921475412 1736985988 8046093981 0 D-18 / - DATA AI02CS( 27) /+.1193650890 8459820855 0439949924 2 D-17 / - DATA AI02CS( 28) /-.2488709837 1508072357 2054491660 2 D-18 / - DATA AI02CS( 29) /-.1938426454 1609059289 8469781132 6 D-18 / - DATA AI02CS( 30) /+.6444656697 3734438687 8301949394 9 D-19 / - DATA AI02CS( 31) /+.2886051596 2892243264 8171383073 4 D-19 / - DATA AI02CS( 32) /-.1601954907 1749718070 6167156200 7 D-19 / - DATA AI02CS( 33) /-.3270815010 5923147208 9193567485 9 D-20 / - DATA AI02CS( 34) /+.3686932283 8264091811 4600723939 3 D-20 / - DATA AI02CS( 35) /+.1268297648 0309501530 1359529710 9 D-22 / - DATA AI02CS( 36) /-.7549825019 3772739076 9636664410 1 D-21 / - DATA AI02CS( 37) /+.1502133571 3778353496 3712789053 4 D-21 / - DATA AI02CS( 38) /+.1265195883 5096485349 3208799248 3 D-21 / - DATA AI02CS( 39) /-.6100998370 0836807086 2940891600 2 D-22 / - DATA AI02CS( 40) /-.1268809629 2601282643 6872095924 2 D-22 / - DATA AI02CS( 41) /+.1661016099 8907414578 4038487490 5 D-22 / - DATA AI02CS( 42) /-.1585194335 7658855793 7970504881 4 D-23 / - DATA AI02CS( 43) /-.3302645405 9682178009 5381766755 6 D-23 / - DATA AI02CS( 44) /+.1313580902 8392397817 4039623117 4 D-23 / - DATA AI02CS( 45) /+.3689040246 6711567933 1425637280 4 D-24 / - DATA AI02CS( 46) /-.4210141910 4616891492 1978247249 9 D-24 / - DATA AI02CS( 47) /+.4791954591 0828657806 3171401373 0 D-25 / - DATA AI02CS( 48) /+.8459470390 2218217952 9971707412 4 D-25 / - DATA AI02CS( 49) /-.4039800940 8728324931 4607937181 0 D-25 / - DATA AI02CS( 50) /-.6434714653 6504313473 0100850469 5 D-26 / - DATA AI02CS( 51) /+.1225743398 8756659903 4464736990 5 D-25 / - DATA AI02CS( 52) /-.2934391316 0257089231 9879821175 4 D-26 / - DATA AI02CS( 53) /-.1961311309 1949829262 0371205728 9 D-26 / - DATA AI02CS( 54) /+.1503520374 8221934241 6229900309 8 D-26 / - DATA AI02CS( 55) /-.9588720515 7448265520 3386388206 9 D-28 / - DATA AI02CS( 56) /-.3483339380 8170454863 9441108511 4 D-27 / - DATA AI02CS( 57) /+.1690903610 2630436730 6244960725 6 D-27 / - DATA AI02CS( 58) /+.1982866538 7356030438 9400115718 8 D-28 / - DATA AI02CS( 59) /-.5317498081 4918162145 7583002528 4 D-28 / - DATA AI02CS( 60) /+.1803306629 8883929462 3501450390 1 D-28 / - DATA AI02CS( 61) /+.6213093341 4548931758 8405311242 2 D-29 / - DATA AI02CS( 62) /-.7692189292 7721618632 0072806673 0 D-29 / - DATA AI02CS( 63) /+.1858252826 1117025426 2556016596 3 D-29 / - DATA AI02CS( 64) /+.1237585142 2813957248 9927154554 1 D-29 / - DATA AI02CS( 65) /-.1102259120 4092238032 1779478779 2 D-29 / - DATA AI02CS( 66) /+.1886287118 0397044900 7787447943 1 D-30 / - DATA AI02CS( 67) /+.2160196872 2436589131 4903141406 0 D-30 / - DATA AI02CS( 68) /-.1605454124 9197432005 8446594965 5 D-30 / - DATA AI02CS( 69) /+.1965352984 5942906039 3884807331 8 D-31 / - DATA NTI0, NTAI0, NTAI02 / 3*0/ -C***FIRST EXECUTABLE STATEMENT DBSI0E - IF (NTI0.NE.0) GO TO 10 -c ETA = 0.1*SNGL(D1MACH(3)) -c replace above statement - eta=1.4d-18 - NTI0 = INITDSs (BI0CS, 18, ETA) - NTAI0 = INITDSs (AI0CS, 46, ETA) - NTAI02 = INITDSs (AI02CS, 69, ETA) -C - 10 Y = DABS(X) - IF (Y.GT.3.0D0) GO TO 20 -C - DBSI0Es = 1.0D0 - IF (Y.GT.1.d-15) DBSI0Es = DEXP(-Y) * (2.75D0 + - 1DCSEVLs (Y*Y/4.5D0-1.D0, BI0CS, NTI0) ) - RETURN -C - 20 IF (Y.LE.8.D0) DBSI0Es = - &(0.375D0 + DCSEVLs ((48.D0/Y-11.D0)/5.D0, - 1AI0CS, NTAI0))/DSQRT(Y) - IF (Y.GT.8.D0) DBSI0Es = - &(0.375D0 + DCSEVLs (16.D0/Y-1.D0, AI02CS, - 1NTAI02))/DSQRT(Y) -C - RETURN - END - DOUBLE PRECISION FUNCTION DCSEVLs(X,A,N) -c Stripped down version - no XERROR call- stops on wrong input. -C***BEGIN PROLOGUE DCSEVLs -C***DATE WRITTEN 770401 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C3A2 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(CSEVL-S DCSEVLs-D),CHEBYSHEV, -C SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Evaluate the double precision N-term Chebyshev series A -C at X. -C***DESCRIPTION -C -C Evaluate the N-term Chebyshev series A at X. Adapted from -C R. Broucke, Algorithm 446, C.A.C.M., 16, 254 (1973). -C W. Fullerton, C-3, Los Alamos Scientific Laboratory. -C -C Input Arguments -- -C X double precision value at which the series is to be evaluated. -C A double precision array of N terms of a Chebyshev series. In -C evaluating A, only half of the first coefficient is summed. -C N number of terms in array A. -C***REFERENCES (NONE) -C***ROUTINES CALLED XERROR -C***END PROLOGUE DCSEVLs -C - DOUBLE PRECISION A(N),X,TWOX,B0,B1,B2 -C***FIRST EXECUTABLE STATEMENT DCSEVLs - IF(N.LT.1) go to 1001 - IF(N.GT.1000) go to 1002 - IF ((X.LT.-1.D0) .OR. (X.GT.1.D0)) go to 1003 -C - TWOX = 2.0D0*X - B1 = 0.D0 - B0=0.D0 - DO 10 I=1,N - B2=B1 - B1=B0 - NI = N - I + 1 - B0 = TWOX*B1 - B2 + A(NI) - 10 CONTINUE -C - DCSEVLs = 0.5D0 * (B0-B2) -C - RETURN - 1001 write(6,201) N - 201 format(1x,'N < 1 in DCSEVLs- stopped') - stop - 1002 write(6,202) N - 202 format(1x,'N>1000 in DCSEVLs- stopped') - stop - 1003 write(6,203) x - 203 format(1x,'x outside interval [-1,1] in DCSEVLs- stopped') - stop - END - FUNCTION INITDSs(DOS,NOS,ETA) -C***BEGIN PROLOGUE INITDS -C***DATE WRITTEN 770601 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C3A2 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(INITS-S INITDS-D),CHEBYSHEV, -C INITIALIZE,ORTHOGONAL POLYNOMIAL,ORTHOGONAL SERIES,SERIES, -C SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Initializes the d.p. properly normalized orthogonal -C polynomial series to determine the number of terms needed -C for specific accuracy. -C***DESCRIPTION -C -C Initialize the double precision orthogonal series DOS so that INITDS -C is the number of terms needed to insure the error is no larger than -C ETA.Ordinarily ETA will be chosen to be one-tenth machine precision -C -C Input Arguments -- -C DOS dble prec array of NOS coefficients in an orthogonal series. -C NOS number of coefficients in DOS. -C ETA requested accuracy of series. -C***REFERENCES (NONE) -C***ROUTINES CALLED XERROR -C***END PROLOGUE INITDS -C - DOUBLE PRECISION DOS(NOS),eta,err -C***FIRST EXECUTABLE STATEMENT INITDS - IF (NOS.LT.1) write(6,201) - 201 format( 'INITDS NUMBER OF COEFFICIENTS LT 1') -C - ERR = 0.d0 - DO 10 II=1,NOS - I = NOS + 1 - II - ERR = ERR + ABS(DOS(I)) - IF (ERR.GT.ETA) GO TO 20 - 10 CONTINUE -C - 20 IF (I.EQ.NOS) write(6,200) - 200 format( 'INITDSs ETA MAY BE TOO SMALL') - INITDSs = I -C - RETURN - END - DOUBLE PRECISION FUNCTION DBSI1Es(X) -C***BEGIN PROLOGUE DBSI1E -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESI1E-S DBSI1E-D),BESSEL FUNCTION, -C EXPONENTIALLY SCALED,FIRST KIND, -C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, -C ORDER ONE,SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the d.p. exponentially scaled modified (hyper- -C bolic) Bessel function of the first kind of order one. -C***DESCRIPTION -C -C DBSI1E(X) calculates the double precision exponentially scaled -C modified (hyperbolic) Bessel function of the first kind of order -C one for double precision argument X. The result is I1(X) -C multiplied by EXP(-ABS(X)). -C -C Series for BI1 on the interval 0. to 9.00000E+00 -C with weighted error 1.44E-32 -C log weighted error 31.84 -C significant figures required 31.45 -C decimal places required 32.46 -C -C Series for AI1 on the interval 1.25000E-01 to 3.33333E-01 -C with weighted error 2.81E-32 -C log weighted error 31.55 -C significant figures required 29.93 -C decimal places required 32.38 -C -C Series for AI12 on the interval 0. to 1.25000E-01 -C with weighted error 1.83E-32 -C log weighted error 31.74 -C significant figures required 29.97 -C decimal places required 32.66 -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DCSEVL,INITDS,XERROR -C***END PROLOGUE DBSI1E - DOUBLE PRECISION X, BI1CS(17), AI1CS(46), AI12CS(69), XMIN, - 1XSML, Y, DCSEVLs,eta - SAVE BI1CS, AI1CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML - DATA BI1CS( 1) /-.1971713261 0998597316 1385032181 49 D-2 / - DATA BI1CS( 2) /+.4073488766 7546480608 1553936520 14 D+0 / - DATA BI1CS( 3) /+.3483899429 9959455866 2450377837 87 D-1 / - DATA BI1CS( 4) /+.1545394556 3001236038 5984010584 89 D-2 / - DATA BI1CS( 5) /+.4188852109 8377784129 4588320041 20 D-4 / - DATA BI1CS( 6) /+.7649026764 8362114741 9597039660 69 D-6 / - DATA BI1CS( 7) /+.1004249392 4741178689 1798080372 38 D-7 / - DATA BI1CS( 8) /+.9932207791 9238106481 3712980548 63 D-10 / - DATA BI1CS( 9) /+.7663801791 8447637275 2001716813 49 D-12 / - DATA BI1CS( 10) /+.4741418923 8167394980 3880919481 60 D-14 / - DATA BI1CS( 11) /+.2404114404 0745181799 8631720320 00 D-16 / - DATA BI1CS( 12) /+.1017150500 7093713649 1211007999 99 D-18 / - DATA BI1CS( 13) /+.3645093565 7866949458 4917333333 33 D-21 / - DATA BI1CS( 14) /+.1120574950 2562039344 8106666666 66 D-23 / - DATA BI1CS( 15) /+.2987544193 4468088832 0000000000 00 D-26 / - DATA BI1CS( 16) /+.6973231093 9194709333 3333333333 33 D-29 / - DATA BI1CS( 17) /+.1436794822 0620800000 0000000000 00 D-31 / - DATA AI1CS( 1) /-.2846744181 8814786741 0037246830 7 D-1 / - DATA AI1CS( 2) /-.1922953231 4432206510 4444877497 9 D-1 / - DATA AI1CS( 3) /-.6115185857 9437889822 5624991778 5 D-3 / - DATA AI1CS( 4) /-.2069971253 3502277088 8282377797 9 D-4 / - DATA AI1CS( 5) /+.8585619145 8107255655 3694467313 8 D-5 / - DATA AI1CS( 6) /+.1049498246 7115908625 1745399786 0 D-5 / - DATA AI1CS( 7) /-.2918338918 4479022020 9343232669 7 D-6 / - DATA AI1CS( 8) /-.1559378146 6317390001 6068096907 7 D-7 / - DATA AI1CS( 9) /+.1318012367 1449447055 2530287390 9 D-7 / - DATA AI1CS( 10) /-.1448423418 1830783176 3913446781 5 D-8 / - DATA AI1CS( 11) /-.2908512243 9931420948 2504099301 0 D-9 / - DATA AI1CS( 12) /+.1266388917 8753823873 1115969040 3 D-9 / - DATA AI1CS( 13) /-.1664947772 9192206706 2417839858 0 D-10 / - DATA AI1CS( 14) /-.1666653644 6094329760 9593715499 9 D-11 / - DATA AI1CS( 15) /+.1242602414 2907682652 3216847201 7 D-11 / - DATA AI1CS( 16) /-.2731549379 6724323972 5146142863 3 D-12 / - DATA AI1CS( 17) /+.2023947881 6458037807 0026268898 1 D-13 / - DATA AI1CS( 18) /+.7307950018 1168836361 9869812612 3 D-14 / - DATA AI1CS( 19) /-.3332905634 4046749438 1377861713 3 D-14 / - DATA AI1CS( 20) /+.7175346558 5129537435 4225466567 0 D-15 / - DATA AI1CS( 21) /-.6982530324 7962563558 5062922365 6 D-16 / - DATA AI1CS( 22) /-.1299944201 5627607600 6044608058 7 D-16 / - DATA AI1CS( 23) /+.8120942864 2427988920 5467834286 0 D-17 / - DATA AI1CS( 24) /-.2194016207 4107368981 5626664378 3 D-17 / - DATA AI1CS( 25) /+.3630516170 0296548482 7986093233 4 D-18 / - DATA AI1CS( 26) /-.1695139772 4391041663 0686679039 9 D-19 / - DATA AI1CS( 27) /-.1288184829 8979078071 1688253822 2 D-19 / - DATA AI1CS( 28) /+.5694428604 9670527801 0999107310 9 D-20 / - DATA AI1CS( 29) /-.1459597009 0904800565 4550990028 7 D-20 / - DATA AI1CS( 30) /+.2514546010 6757173140 8469133448 5 D-21 / - DATA AI1CS( 31) /-.1844758883 1391248181 6040002901 3 D-22 / - DATA AI1CS( 32) /-.6339760596 2279486419 2860979199 9 D-23 / - DATA AI1CS( 33) /+.3461441102 0310111111 0814662656 0 D-23 / - DATA AI1CS( 34) /-.1017062335 3713935475 9654102357 3 D-23 / - DATA AI1CS( 35) /+.2149877147 0904314459 6250077866 6 D-24 / - DATA AI1CS( 36) /-.3045252425 2386764017 4620617386 6 D-25 / - DATA AI1CS( 37) /+.5238082144 7212859821 7763498666 6 D-27 / - DATA AI1CS( 38) /+.1443583107 0893824464 1678950399 9 D-26 / - DATA AI1CS( 39) /-.6121302074 8900427332 0067071999 9 D-27 / - DATA AI1CS( 40) /+.1700011117 4678184183 4918980266 6 D-27 / - DATA AI1CS( 41) /-.3596589107 9842441585 3521578666 6 D-28 / - DATA AI1CS( 42) /+.5448178578 9484185766 5051306666 6 D-29 / - DATA AI1CS( 43) /-.2731831789 6890849891 6256426666 6 D-30 / - DATA AI1CS( 44) /-.1858905021 7086007157 7190399999 9 D-30 / - DATA AI1CS( 45) /+.9212682974 5139334411 2776533333 3 D-31 / - DATA AI1CS( 46) /-.2813835155 6535611063 7083306666 6 D-31 / - DATA AI12CS( 1) /+.2857623501 8280120474 4984594846 9 D-1 / - DATA AI12CS( 2) /-.9761097491 3614684077 6516445730 2 D-2 / - DATA AI12CS( 3) /-.1105889387 6262371629 1256921277 5 D-3 / - DATA AI12CS( 4) /-.3882564808 8776903934 5654477627 4 D-5 / - DATA AI12CS( 5) /-.2512236237 8702089252 9452002212 1 D-6 / - DATA AI12CS( 6) /-.2631468846 8895195068 3705236523 2 D-7 / - DATA AI12CS( 7) /-.3835380385 9642370220 4500678796 8 D-8 / - DATA AI12CS( 8) /-.5589743462 1965838068 6811252222 9 D-9 / - DATA AI12CS( 9) /-.1897495812 3505412344 9892503323 8 D-10 / - DATA AI12CS( 10) /+.3252603583 0154882385 5508067994 9 D-10 / - DATA AI12CS( 11) /+.1412580743 6613781331 6336633284 6 D-10 / - DATA AI12CS( 12) /+.2035628544 1470895072 2452613684 0 D-11 / - DATA AI12CS( 13) /-.7198551776 2459085120 9258989044 6 D-12 / - DATA AI12CS( 14) /-.4083551111 0921973182 2849963969 1 D-12 / - DATA AI12CS( 15) /-.2101541842 7726643130 1984572746 2 D-13 / - DATA AI12CS( 16) /+.4272440016 7119513542 9778833699 7 D-13 / - DATA AI12CS( 17) /+.1042027698 4128802764 1741449994 8 D-13 / - DATA AI12CS( 18) /-.3814403072 4370078047 6707253539 6 D-14 / - DATA AI12CS( 19) /-.1880354775 5107824485 1273453396 3 D-14 / - DATA AI12CS( 20) /+.3308202310 9209282827 3190335240 5 D-15 / - DATA AI12CS( 21) /+.2962628997 6459501390 6854654205 2 D-15 / - DATA AI12CS( 22) /-.3209525921 9934239587 7837353288 7 D-16 / - DATA AI12CS( 23) /-.4650305368 4893583255 7128281897 9 D-16 / - DATA AI12CS( 24) /+.4414348323 0717079499 4611375964 1 D-17 / - DATA AI12CS( 25) /+.7517296310 8421048054 2545808029 5 D-17 / - DATA AI12CS( 26) /-.9314178867 3268833756 8484784515 7 D-18 / - DATA AI12CS( 27) /-.1242193275 1948909561 1678448869 7 D-17 / - DATA AI12CS( 28) /+.2414276719 4548484690 0515390217 6 D-18 / - DATA AI12CS( 29) /+.2026944384 0532851789 7192286069 2 D-18 / - DATA AI12CS( 30) /-.6394267188 2690977870 4391988681 1 D-19 / - DATA AI12CS( 31) /-.3049812452 3730958960 8488450357 1 D-19 / - DATA AI12CS( 32) /+.1612841851 6514802251 3462230769 1 D-19 / - DATA AI12CS( 33) /+.3560913964 3099250545 1027090462 0 D-20 / - DATA AI12CS( 34) /-.3752017947 9364390796 6682800324 6 D-20 / - DATA AI12CS( 35) /-.5787037427 0747993459 5198231074 1 D-22 / - DATA AI12CS( 36) /+.7759997511 6481619619 8236963209 2 D-21 / - DATA AI12CS( 37) /-.1452790897 2022333940 6445987408 5 D-21 / - DATA AI12CS( 38) /-.1318225286 7390367021 2192275337 4 D-21 / - DATA AI12CS( 39) /+.6116654862 9030707018 7999133171 7 D-22 / - DATA AI12CS( 40) /+.1376279762 4271264277 3024338363 4 D-22 / - DATA AI12CS( 41) /-.1690837689 9593478849 1983938230 6 D-22 / - DATA AI12CS( 42) /+.1430596088 5954331539 8720108538 5 D-23 / - DATA AI12CS( 43) /+.3409557828 0905940204 0536772990 2 D-23 / - DATA AI12CS( 44) /-.1309457666 2707602278 4573872642 4 D-23 / - DATA AI12CS( 45) /-.3940706411 2402574360 9352141755 7 D-24 / - DATA AI12CS( 46) /+.4277137426 9808765808 0616679735 2 D-24 / - DATA AI12CS( 47) /-.4424634830 9826068819 0028312302 9 D-25 / - DATA AI12CS( 48) /-.8734113196 2307149721 1530978874 7 D-25 / - DATA AI12CS( 49) /+.4045401335 6835333921 4340414242 8 D-25 / - DATA AI12CS( 50) /+.7067100658 0946894656 5160771780 6 D-26 / - DATA AI12CS( 51) /-.1249463344 5651052230 0286451860 5 D-25 / - DATA AI12CS( 52) /+.2867392244 4034370329 7948339142 6 D-26 / - DATA AI12CS( 53) /+.2044292892 5042926702 8177957421 0 D-26 / - DATA AI12CS( 54) /-.1518636633 8204625683 7134680291 1 D-26 / - DATA AI12CS( 55) /+.8110181098 1875758861 3227910703 7 D-28 / - DATA AI12CS( 56) /+.3580379354 7735860911 2717370327 0 D-27 / - DATA AI12CS( 57) /-.1692929018 9279025095 9305717544 8 D-27 / - DATA AI12CS( 58) /-.2222902499 7024276390 6775852777 4 D-28 / - DATA AI12CS( 59) /+.5424535127 1459696550 4860040112 8 D-28 / - DATA AI12CS( 60) /-.1787068401 5780186887 6491299330 4 D-28 / - DATA AI12CS( 61) /-.6565479068 7228149388 2392943788 0 D-29 / - DATA AI12CS( 62) /+.7807013165 0611452809 2206770683 9 D-29 / - DATA AI12CS( 63) /-.1816595260 6689797173 7933315222 1 D-29 / - DATA AI12CS( 64) /-.1287704952 6600848203 7687559895 9 D-29 / - DATA AI12CS( 65) /+.1114548172 9881645474 1370927369 4 D-29 / - DATA AI12CS( 66) /-.1808343145 0393369391 5936887668 7 D-30 / - DATA AI12CS( 67) /-.2231677718 2037719522 3244822893 9 D-30 / - DATA AI12CS( 68) /+.1619029596 0803415106 1790980361 4 D-30 / - DATA AI12CS( 69) /-.1834079908 8049414139 0130843921 0 D-31 / - DATA NTI1, NTAI1, NTAI12, XMIN, XSML / 3*0, 2*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBSI1Es - IF (NTI1.NE.0) GO TO 10 -c type *,'D1mach(3)',d1mach(3) - eta=1.4d-18 -c ETA = 0.1*SNGL(D1MACH(3)) -c type *,'eta',eta - NTI1 = INITDSs (BI1CS, 17, ETA) - NTAI1 = INITDSs (AI1CS, 46, ETA) - NTAI12 = INITDSs (AI12CS, 69, ETA) -C - XMIN = 4.d-39 -c type *,'D1mach(1)',d1mach(1) - XSML = 1.d-8 -C - 10 Y = DABS(X) - IF (Y.GT.3.0D0) GO TO 20 -C - DBSI1Es = 0.0D0 - IF (Y.EQ.0.D0) RETURN -C - IF (Y.LT.XMIN) write(6,301) - 301 format(1x,'DBSI1Es DABS(X) SO SMALL I1 UNDERFLOWS') - IF (Y.GT.XMIN) DBSI1Es = 0.5D0*X - IF (Y.GT.XSML) DBSI1Es = - &X*(0.875D0 + DCSEVLs (Y*Y/4.5D0-1.D0, - 1BI1CS, NTI1) ) - DBSI1Es = DEXP(-Y) * DBSI1Es - RETURN -C - 20 IF (Y.LE.8.D0) DBSI1Es = - &(0.375D0 + DCSEVLs ((48.D0/Y-11.D0)/5.D0, - 1AI1CS, NTAI1))/DSQRT(Y) - IF (Y.GT.8.D0) DBSI1Es = - &(0.375D0 + DCSEVLs (16.D0/Y-1.D0, AI12CS, - 1NTAI12))/DSQRT(Y) - DBSI1Es = DSIGN (DBSI1Es, X) -C - RETURN - END - DOUBLE PRECISION FUNCTION DBESI1s(X) -C***BEGIN PROLOGUE DBESI1 -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESI1-S DBESI1-D),BESSEL FUNCTION, -C FIRST KIND,HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION,ORDER ONE,SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the d.p. modified (hyperbolic) Bessel function -C of the first kind of order one. -C***DESCRIPTION -C -C DBESI1(X) calculates the double precision modified (hyperbolic) -C Bessel function of the first kind of order one and double precision -C argument X. -C -C Series for BI1 on the interval 0. to 9.00000E+00 -C with weighted error 1.44E-32 -C log weighted error 31.84 -C significant figures required 31.45 -C decimal places required 32.46 -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DBSI1E,DCSEVL,INITDS,XERROR -C***END PROLOGUE DBESI1 - DOUBLE PRECISION X, BI1CS(17), XMAX, XMIN, XSML, Y, - 1DCSEVLs, DBSI1Es,eta - SAVE BI1CS, NTI1, XMIN, XSML, XMAX - DATA BI1CS( 1) /-.1971713261 0998597316 1385032181 49 D-2 / - DATA BI1CS( 2) /+.4073488766 7546480608 1553936520 14 D+0 / - DATA BI1CS( 3) /+.3483899429 9959455866 2450377837 87 D-1 / - DATA BI1CS( 4) /+.1545394556 3001236038 5984010584 89 D-2 / - DATA BI1CS( 5) /+.4188852109 8377784129 4588320041 20 D-4 / - DATA BI1CS( 6) /+.7649026764 8362114741 9597039660 69 D-6 / - DATA BI1CS( 7) /+.1004249392 4741178689 1798080372 38 D-7 / - DATA BI1CS( 8) /+.9932207791 9238106481 3712980548 63 D-10 / - DATA BI1CS( 9) /+.7663801791 8447637275 2001716813 49 D-12 / - DATA BI1CS( 10) /+.4741418923 8167394980 3880919481 60 D-14 / - DATA BI1CS( 11) /+.2404114404 0745181799 8631720320 00 D-16 / - DATA BI1CS( 12) /+.1017150500 7093713649 1211007999 99 D-18 / - DATA BI1CS( 13) /+.3645093565 7866949458 4917333333 33 D-21 / - DATA BI1CS( 14) /+.1120574950 2562039344 8106666666 66 D-23 / - DATA BI1CS( 15) /+.2987544193 4468088832 0000000000 00 D-26 / - DATA BI1CS( 16) /+.6973231093 9194709333 3333333333 33 D-29 / - DATA BI1CS( 17) /+.1436794822 0620800000 0000000000 00 D-31 / - DATA NTI1, XMIN, XSML, XMAX / 0, 3*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBESI1 - IF (NTI1.NE.0) GO TO 10 - eta=1.4d-18 - NTI1 = INITDSs (BI1CS, 17, eta) - XMIN = 4.0d-39 - XSML = 1.d-8 - XMAX = 86.d0 -C - 10 Y = DABS(X) - IF (Y.GT.3.0D0) GO TO 20 -C - DBESI1s = 0.D0 - IF (Y.EQ.0.D0) RETURN -C - IF (Y.LT.XMIN) - &write(6,*) 'DBESI1s DABS(X) SO SMALL IT UNDERFLOWS' - IF (Y.GT.XMIN) DBESI1s = 0.5D0*X - IF (Y.GT.XSML) DBESI1s = X*(0.875D0 + - &DCSEVLs (Y*Y/4.5D0-1.D0, - 1BI1CS, NTI1)) - RETURN -C - 20 IF (Y.GT.XMAX) write(6,*)'DBESI1s DABS(X) SO BIG I1 OVERFLOWS' -C - DBESI1s = DEXP(Y) * DBSI1Es(X) -C - RETURN - END - DOUBLE PRECISION FUNCTION DBESI0s(X) -c Stripped version of CLAMS DBESI0 - no machine-dependent calls. -C***BEGIN PROLOGUE DBESI0 -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESI0-S DBESI0-D),BESSEL FUNCTION, -C FIRST KIND,HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION,ORDER ZERO,SPECIAL FUNCTIONS -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the d.p. hyperbolic Bessel function of the first -C kind of order zero. -C***DESCRIPTION -C -C DBESI0(X) calculates the double precision modified (hyperbolic) -C Bessel function of the first kind of order zero and double -C precision argument X. -C -C Series for BI0 on the interval 0. to 9.00000E+00 -C with weighted error 9.51E-34 -C log weighted error 33.02 -C significant figures required 33.31 -C decimal places required 33.65 -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DBSI0E,DCSEVL,INITDS,XERROR -C***END PROLOGUE DBESI0 - DOUBLE PRECISION X, BI0CS(18), XMAX, XSML, Y, - 1DCSEVLs, DBSI0Es - SAVE BI0CS, NTI0, XSML, XMAX - DATA BI0CS( 1) /-.7660547252 8391449510 8189497624 3285 D-1 / - DATA BI0CS( 2) /+.1927337953 9938082699 5240875088 1196 D+1 / - DATA BI0CS( 3) /+.2282644586 9203013389 3702929233 0415 D+0 / - DATA BI0CS( 4) /+.1304891466 7072904280 7933421069 1888 D-1 / - DATA BI0CS( 5) /+.4344270900 8164874513 7868268102 6107 D-3 / - DATA BI0CS( 6) /+.9422657686 0019346639 2317174411 8766 D-5 / - DATA BI0CS( 7) /+.1434006289 5106910799 6209187817 9957 D-6 / - DATA BI0CS( 8) /+.1613849069 6617490699 1541971999 4611 D-8 / - DATA BI0CS( 9) /+.1396650044 5356696994 9509270814 2522 D-10 / - DATA BI0CS( 10) /+.9579451725 5054453446 2752317189 3333 D-13 / - DATA BI0CS( 11) /+.5333981859 8625021310 1510774400 0000 D-15 / - DATA BI0CS( 12) /+.2458716088 4374707746 9678591999 9999 D-17 / - DATA BI0CS( 13) /+.9535680890 2487700269 4434133333 3333 D-20 / - DATA BI0CS( 14) /+.3154382039 7214273367 8933333333 3333 D-22 / - DATA BI0CS( 15) /+.9004564101 0946374314 6666666666 6666 D-25 / - DATA BI0CS( 16) /+.2240647369 1236700160 0000000000 0000 D-27 / - DATA BI0CS( 17) /+.4903034603 2428373333 3333333333 3333 D-30 / - DATA BI0CS( 18) /+.9508172606 1226666666 6666666666 6666 D-33 / - DATA NTI0, XSML, XMAX / 0, 2*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBESI0 - IF (NTI0.NE.0) GO TO 10 - NTI0 = INITDSs(BI0CS, 18, 1.4d-18) -c XSML = DSQRT (8.0D0*D1MACH(3)) - xsml=7.5d-9 -c XMAX = DLOG (D1MACH(2)) - xmax=86.4d0 -C - 10 Y = DABS(X) - IF (Y.GT.3.0D0) GO TO 20 -C - DBESI0s= 1.0D0 - IF (Y.GT.XSML) DBESI0s= 2.75D0 + DCSEVLs(Y*Y/4.5D0-1.D0, BI0CS, - 1NTI0) - RETURN -C - 20 IF (Y.GT.XMAX) go to 1001 -C - DBESI0s= DEXP(Y) * DBSI0Es(X) -C - RETURN - 1001 write(6,*) 'X>XMAX in DBESI0s-stopped:XMAX=86.4,x=',x - stop - END - DOUBLE PRECISION FUNCTION DBESK0s(X) -c Stripped of machine-dependent calls . -C***BEGIN PROLOGUE DBESK0s -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESK0-S DBESK0s-D),BESSEL FUNCTION, -C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, -C ORDER ZERO,SPECIAL FUNCTIONS,THIRD KIND -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes d.p. modified (hyperbolic) Bessel function of -C the third kind of order zero. -C***DESCRIPTION -C -C DBESK0s(X) calculates the double precision modified (hyperbolic) -C Bessel function of the third kind of order zero for double -C precision argument X. The argument must be greater than zero -C but not so large that the result underflows. -C -C Series for BK0 on the interval 0. to 4.00000E+00 -C with weighted error 3.08E-33 -C log weighted error 32.51 -C significant figures required 32.05 -C decimal places required 33.11 -C***REFERENCES (NONE) -C***ROUTINES CALLED DBESI0,DBSK0E,DCSEVL,INITDS -C***END PROLOGUE DBESK0s - DOUBLE PRECISION X, BK0CS(16), XMAX, XSML, Y, - 1DCSEVLs, DBESI0s, DBSK0Es - SAVE BK0CS, NTK0, XSML, XMAX - DATA BK0CS( 1) /-.3532739323 3902768720 1140060063 153 D-1 / - DATA BK0CS( 2) /+.3442898999 2462848688 6344927529 213 D+0 / - DATA BK0CS( 3) /+.3597993651 5361501626 5721303687 231 D-1 / - DATA BK0CS( 4) /+.1264615411 4469259233 8479508673 447 D-2 / - DATA BK0CS( 5) /+.2286212103 1194517860 8269830297 585 D-4 / - DATA BK0CS( 6) /+.2534791079 0261494573 0790013428 354 D-6 / - DATA BK0CS( 7) /+.1904516377 2202088589 7214059381 366 D-8 / - DATA BK0CS( 8) /+.1034969525 7633624585 1008317853 089 D-10 / - DATA BK0CS( 9) /+.4259816142 7910825765 2445327170 133 D-13 / - DATA BK0CS( 10) /+.1374465435 8807508969 4238325440 000 D-15 / - DATA BK0CS( 11) /+.3570896528 5083735909 9688597333 333 D-18 / - DATA BK0CS( 12) /+.7631643660 1164373766 7498666666 666 D-21 / - DATA BK0CS( 13) /+.1365424988 4407818590 8053333333 333 D-23 / - DATA BK0CS( 14) /+.2075275266 9066680831 9999999999 999 D-26 / - DATA BK0CS( 15) /+.2712814218 0729856000 0000000000 000 D-29 / - DATA BK0CS( 16) /+.3082593887 9146666666 6666666666 666 D-32 / - DATA NTK0, XSML, XMAX / 0, 2*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBESK0s - IF (NTK0.NE.0) GO TO 10 - NTK0 = INITDSs(BK0CS, 16, 1.4d-18) - XSML = 7.5d-9 - XMAX = 86.4d0 -C - 10 if(x.le.0.d0) go to 1001 - IF (X.GT.2.0D0) GO TO 20 -C - Y = 0.D0 - IF (X.GT.XSML) Y = X*X - DBESK0s = -DLOG(0.5D0*X)*DBESI0s(X) - &- 0.25D0 + DCSEVLs(.5D0*Y-1.D0, - 1BK0CS, NTK0) - RETURN -C - 20 DBESK0s = 0.D0 - IF (X.GT.XMAX) write(6,*)'DBESK0s X SO BIG K0 UNDERFLOWS' - IF (X.GT.XMAX) RETURN -C - DBESK0s = DEXP(-X) * DBSK0Es(X) -C - RETURN - 1001 write(6,*) 'DBESK0s X IS ZERO OR NEGATIVE- stopped' - stop - END - DOUBLE PRECISION FUNCTION DBSK0Es(X) -c Stripped of machine-dependent calls. -C***BEGIN PROLOGUE DBSK0Es -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESK0E-S DBSK0Es-D),BESSEL FUNCTION, -C EXPONENTIALLY SCALED,HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION,ORDER ZERO,SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the d.p. exponentially scaled modified (hyper- -C bolic) Bessel function of the third kind of order zero. -C***DESCRIPTION -C -C DBSK0Es(X) computes the double precision exponentially scaled -C modified (hyperbolic) Bessel function of the third kind of -C order zero for positive double precision argument X. -C -C Series for BK0 on the interval 0. to 4.00000E+00 -C with weighted error 3.08E-33 -C log weighted error 32.51 -C significant figures required 32.05 -C decimal places required 33.11 -C -C Series for AK0 on the interval 1.25000E-01 to 5.00000E-01 -C with weighted error 2.85E-32 -C log weighted error 31.54 -C significant figures required 30.19 -C decimal places required 32.33 -C -C Series for AK02 on the interval 0. to 1.25000E-01 -C with weighted error 2.30E-32 -C log weighted error 31.64 -C significant figures required 29.68 -C decimal places required 32.40 -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DBESI0,DCSEVL,INITDSs,XERROR -C***END PROLOGUE DBSK0Es - DOUBLE PRECISION X, BK0CS(16), AK0CS(38), AK02CS(33), - 1XSML, Y, DCSEVLs,DBESI0s,eta - SAVE BK0CS, AK0CS, AK02CS,NTK0, NTAK0, NTAK02, XSML - DATA BK0CS( 1) /-.3532739323 3902768720 1140060063 153 D-1 / - DATA BK0CS( 2) /+.3442898999 2462848688 6344927529 213 D+0 / - DATA BK0CS( 3) /+.3597993651 5361501626 5721303687 231 D-1 / - DATA BK0CS( 4) /+.1264615411 4469259233 8479508673 447 D-2 / - DATA BK0CS( 5) /+.2286212103 1194517860 8269830297 585 D-4 / - DATA BK0CS( 6) /+.2534791079 0261494573 0790013428 354 D-6 / - DATA BK0CS( 7) /+.1904516377 2202088589 7214059381 366 D-8 / - DATA BK0CS( 8) /+.1034969525 7633624585 1008317853 089 D-10 / - DATA BK0CS( 9) /+.4259816142 7910825765 2445327170 133 D-13 / - DATA BK0CS( 10) /+.1374465435 8807508969 4238325440 000 D-15 / - DATA BK0CS( 11) /+.3570896528 5083735909 9688597333 333 D-18 / - DATA BK0CS( 12) /+.7631643660 1164373766 7498666666 666 D-21 / - DATA BK0CS( 13) /+.1365424988 4407818590 8053333333 333 D-23 / - DATA BK0CS( 14) /+.2075275266 9066680831 9999999999 999 D-26 / - DATA BK0CS( 15) /+.2712814218 0729856000 0000000000 000 D-29 / - DATA BK0CS( 16) /+.3082593887 9146666666 6666666666 666 D-32 / - DATA AK0CS( 1) /-.7643947903 3279414240 8297827008 8 D-1 / - DATA AK0CS( 2) /-.2235652605 6998190520 2309555079 1 D-1 / - DATA AK0CS( 3) /+.7734181154 6938582353 0061817404 7 D-3 / - DATA AK0CS( 4) /-.4281006688 8860994644 5214643541 6 D-4 / - DATA AK0CS( 5) /+.3081700173 8629747436 5001482666 0 D-5 / - DATA AK0CS( 6) /-.2639367222 0096649740 6744889272 3 D-6 / - DATA AK0CS( 7) /+.2563713036 4034692062 9408826574 2 D-7 / - DATA AK0CS( 8) /-.2742705549 9002012638 5721191524 4 D-8 / - DATA AK0CS( 9) /+.3169429658 0974995920 8083287340 3 D-9 / - DATA AK0CS( 10) /-.3902353286 9621841416 0106571796 2 D-10 / - DATA AK0CS( 11) /+.5068040698 1885754020 5009212728 6 D-11 / - DATA AK0CS( 12) /-.6889574741 0078706795 4171355798 4 D-12 / - DATA AK0CS( 13) /+.9744978497 8259176913 8820133683 1 D-13 / - DATA AK0CS( 14) /-.1427332841 8845485053 8985534012 2 D-13 / - DATA AK0CS( 15) /+.2156412571 0214630395 5806297652 7 D-14 / - DATA AK0CS( 16) /-.3349654255 1495627721 8878205853 0 D-15 / - DATA AK0CS( 17) /+.5335260216 9529116921 4528039260 1 D-16 / - DATA AK0CS( 18) /-.8693669980 8907538076 3962237883 7 D-17 / - DATA AK0CS( 19) /+.1446404347 8622122278 8776344234 6 D-17 / - DATA AK0CS( 20) /-.2452889825 5001296824 0467875157 3 D-18 / - DATA AK0CS( 21) /+.4233754526 2321715728 2170634240 0 D-19 / - DATA AK0CS( 22) /-.7427946526 4544641956 9534129493 3 D-20 / - DATA AK0CS( 23) /+.1323150529 3926668662 7796746240 0 D-20 / - DATA AK0CS( 24) /-.2390587164 7396494513 3598146559 9 D-21 / - DATA AK0CS( 25) /+.4376827585 9232261401 6571255466 6 D-22 / - DATA AK0CS( 26) /-.8113700607 3451180593 3901141333 3 D-23 / - DATA AK0CS( 27) /+.1521819913 8321729583 1037815466 6 D-23 / - DATA AK0CS( 28) /-.2886041941 4833977702 3595861333 3 D-24 / - DATA AK0CS( 29) /+.5530620667 0547179799 9261013333 3 D-25 / - DATA AK0CS( 30) /-.1070377329 2498987285 9163306666 6 D-25 / - DATA AK0CS( 31) /+.2091086893 1423843002 9632853333 3 D-26 / - DATA AK0CS( 32) /-.4121713723 6462038274 1026133333 3 D-27 / - DATA AK0CS( 33) /+.8193483971 1213076401 3568000000 0 D-28 / - DATA AK0CS( 34) /-.1642000275 4592977267 8075733333 3 D-28 / - DATA AK0CS( 35) /+.3316143281 4802271958 9034666666 6 D-29 / - DATA AK0CS( 36) /-.6746863644 1452959410 8586666666 6 D-30 / - DATA AK0CS( 37) /+.1382429146 3184246776 3541333333 3 D-30 / - DATA AK0CS( 38) /-.2851874167 3598325708 1173333333 3 D-31 / - DATA AK02CS( 1) /-.1201869826 3075922398 3934621245 2 D-1 / - DATA AK02CS( 2) /-.9174852691 0256953106 5256107571 3 D-2 / - DATA AK02CS( 3) /+.1444550931 7750058210 4884387805 7 D-3 / - DATA AK02CS( 4) /-.4013614175 4357097286 7102107787 9 D-5 / - DATA AK02CS( 5) /+.1567831810 8523106725 9034899033 3 D-6 / - DATA AK02CS( 6) /-.7770110438 5217377103 1579975446 0 D-8 / - DATA AK02CS( 7) /+.4611182576 1797178825 3313052958 6 D-9 / - DATA AK02CS( 8) /-.3158592997 8605657705 2666580330 9 D-10 / - DATA AK02CS( 9) /+.2435018039 3650411278 3588781432 9 D-11 / - DATA AK02CS( 10) /-.2074331387 3983478977 0985337350 6 D-12 / - DATA AK02CS( 11) /+.1925787280 5899170847 4273650469 3 D-13 / - DATA AK02CS( 12) /-.1927554805 8389561036 0034718221 8 D-14 / - DATA AK02CS( 13) /+.2062198029 1978182782 8523786964 4 D-15 / - DATA AK02CS( 14) /-.2341685117 5792424026 0364019507 1 D-16 / - DATA AK02CS( 15) /+.2805902810 6430422468 1517882845 8 D-17 / - DATA AK02CS( 16) /-.3530507631 1618079458 1548246357 3 D-18 / - DATA AK02CS( 17) /+.4645295422 9351082674 2421633706 6 D-19 / - DATA AK02CS( 18) /-.6368625941 3442664739 2205346133 3 D-20 / - DATA AK02CS( 19) /+.9069521310 9865155676 2234880000 0 D-21 / - DATA AK02CS( 20) /-.1337974785 4236907398 4500531199 9 D-21 / - DATA AK02CS( 21) /+.2039836021 8599523155 2208896000 0 D-22 / - DATA AK02CS( 22) /-.3207027481 3678405000 6086997333 3 D-23 / - DATA AK02CS( 23) /+.5189744413 6623099636 2635946666 6 D-24 / - DATA AK02CS( 24) /-.8629501497 5405721929 6460799999 9 D-25 / - DATA AK02CS( 25) /+.1472161183 1025598552 0803840000 0 D-25 / - DATA AK02CS( 26) /-.2573069023 8670112838 1235199999 9 D-26 / - DATA AK02CS( 27) /+.4601774086 6435165873 7664000000 0 D-27 / - DATA AK02CS( 28) /-.8411555324 2010937371 3066666666 6 D-28 / - DATA AK02CS( 29) /+.1569806306 6353689393 0154666666 6 D-28 / - DATA AK02CS( 30) /-.2988226453 0057577889 7919999999 9 D-29 / - DATA AK02CS( 31) /+.5796831375 2168365206 1866666666 6 D-30 / - DATA AK02CS( 32) /-.1145035994 3476813321 5573333333 3 D-30 / - DATA AK02CS( 33) /+.2301266594 2496828020 0533333333 3 D-31 / - DATA NTK0, NTAK0, NTAK02, XSML / 3*0, 0.0D0 / -C***FIRST EXECUTABLE STATEMENT DBSK0Es - IF (NTK0.NE.0) GO TO 10 -c type *,d1mach(3) - ETA = 1.d-18 - NTK0 = INITDSs (BK0CS, 16, ETA) - NTAK0 = INITDSs (AK0CS, 38, ETA) - NTAK02 = INITDSs (AK02CS, 33, ETA) - XSML = 1.d-9 -c type *,xsml -C - 10 IF (X.LE.0.D0) write(6,*)'DBSK0Es X IS ZERO OR NEGATIVE' - IF (X.GT.2.0D0) GO TO 20 -C - Y = 0.D0 - IF (X.GT.XSML) Y = X*X - DBSK0Es = - &DEXP(X)*(-DLOG(0.5D0*X)*DBESI0s(X) - 0.25D0 + - 1DCSEVLs (.5D0*Y-1.D0, BK0CS, NTK0)) - RETURN -C - 20 IF (X.LE.8.D0) DBSK0Es = - &(1.25D0 + DCSEVLs ((16.D0/X-5.D0)/3.D0, - 1AK0CS, NTAK0))/DSQRT(X) - IF (X.GT.8.D0) DBSK0Es = (1.25D0 + - 1DCSEVLs (16.D0/X-1.D0, AK02CS, NTAK02))/DSQRT(X) -C - RETURN - END - DOUBLE PRECISION FUNCTION DBSK1Es(X) -c Stripped of machine-dependent calls- same as CLAMS DBSK1E -C***BEGIN PROLOGUE DBSK1E -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESK1E-S DBSK1E-D),BESSEL FUNCTION, -C EXPONENTIALLY SCALED,HYPERBOLIC BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION,ORDER ONE,SPECIAL FUNCTIONS, -C THIRD KIND -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the exponentially scaled,modified (hyperbolic) -C Bessel function of the third kind of order one (double -C precision). -C***DESCRIPTION -C -C DBSK1E(S) computes the double precision exponentially scaled -C modified (hyperbolic) Bessel function of the third kind of order -C one for positive double precision argument X. -C -C Series for BK1 on the interval 0. to 4.00000E+00 -C with weighted error 9.16E-32 -C log weighted error 31.04 -C significant figures required 30.61 -C decimal places required 31.64 -C -C Series for AK1 on the interval 1.25000E-01 to 5.00000E-01 -C with weighted error 3.07E-32 -C log weighted error 31.51 -C significant figures required 30.71 -C decimal places required 32.30 -C -C Series for AK12 on the interval 0. to 1.25000E-01 -C with weighted error 2.41E-32 -C log weighted error 31.62 -C significant figures required 30.25 -C decimal places required 32.38 -C***REFERENCES (NONE) -C***ROUTINES CALLED DBESI1,DCSEVLs,INITDS -C***END PROLOGUE DBSK1E - DOUBLE PRECISION X, BK1CS(16), AK1CS(38), AK12CS(33), XMIN, - 1XSML, Y, DCSEVLs, DBESI1s,eta - SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML - DATA BK1CS( 1) /+.2530022733 8947770532 5311208685 33 D-1 / - DATA BK1CS( 2) /-.3531559607 7654487566 7238316918 01 D+0 / - DATA BK1CS( 3) /-.1226111808 2265714823 4790679300 42 D+0 / - DATA BK1CS( 4) /-.6975723859 6398643501 8129202960 83 D-2 / - DATA BK1CS( 5) /-.1730288957 5130520630 1765073689 79 D-3 / - DATA BK1CS( 6) /-.2433406141 5659682349 6007350301 64 D-5 / - DATA BK1CS( 7) /-.2213387630 7347258558 3152525451 26 D-7 / - DATA BK1CS( 8) /-.1411488392 6335277610 9583302126 08 D-9 / - DATA BK1CS( 9) /-.6666901694 1993290060 8537512643 73 D-12 / - DATA BK1CS( 10) /-.2427449850 5193659339 2631968648 53 D-14 / - DATA BK1CS( 11) /-.7023863479 3862875971 7837971200 00 D-17 / - DATA BK1CS( 12) /-.1654327515 5100994675 4910293333 33 D-19 / - DATA BK1CS( 13) /-.3233834745 9944491991 8933333333 33 D-22 / - DATA BK1CS( 14) /-.5331275052 9265274999 4666666666 66 D-25 / - DATA BK1CS( 15) /-.7513040716 2157226666 6666666666 66 D-28 / - DATA BK1CS( 16) /-.9155085717 6541866666 6666666666 66 D-31 / - DATA AK1CS( 1) /+.2744313406 9738829695 2576662272 66 D+0 / - DATA AK1CS( 2) /+.7571989953 1993678170 8923781492 90 D-1 / - DATA AK1CS( 3) /-.1441051556 4754061229 8531161756 25 D-2 / - DATA AK1CS( 4) /+.6650116955 1257479394 2513854770 36 D-4 / - DATA AK1CS( 5) /-.4369984709 5201407660 5808450891 67 D-5 / - DATA AK1CS( 6) /+.3540277499 7630526799 4171390085 34 D-6 / - DATA AK1CS( 7) /-.3311163779 2932920208 9826882457 04 D-7 / - DATA AK1CS( 8) /+.3445977581 9010534532 3114997709 92 D-8 / - DATA AK1CS( 9) /-.3898932347 4754271048 9819374927 58 D-9 / - DATA AK1CS( 10) /+.4720819750 4658356400 9474493390 05 D-10 / - DATA AK1CS( 11) /-.6047835662 8753562345 3735915628 90 D-11 / - DATA AK1CS( 12) /+.8128494874 8658747888 1938379856 63 D-12 / - DATA AK1CS( 13) /-.1138694574 7147891428 9239159510 42 D-12 / - DATA AK1CS( 14) /+.1654035840 8462282325 9729482050 90 D-13 / - DATA AK1CS( 15) /-.2480902567 7068848221 5160104405 33 D-14 / - DATA AK1CS( 16) /+.3829237890 7024096948 4292272991 57 D-15 / - DATA AK1CS( 17) /-.6064734104 0012418187 7682103773 86 D-16 / - DATA AK1CS( 18) /+.9832425623 2648616038 1940046506 66 D-17 / - DATA AK1CS( 19) /-.1628416873 8284380035 6666201156 26 D-17 / - DATA AK1CS( 20) /+.2750153649 6752623718 2841203370 66 D-18 / - DATA AK1CS( 21) /-.4728966646 3953250924 2810695680 00 D-19 / - DATA AK1CS( 22) /+.8268150002 8109932722 3920503466 66 D-20 / - DATA AK1CS( 23) /-.1468140513 6624956337 1939648853 33 D-20 / - DATA AK1CS( 24) /+.2644763926 9208245978 0858948266 66 D-21 / - DATA AK1CS( 25) /-.4829015756 4856387897 9698688000 00 D-22 / - DATA AK1CS( 26) /+.8929302074 3610130180 6563327999 99 D-23 / - DATA AK1CS( 27) /-.1670839716 8972517176 9977514666 66 D-23 / - DATA AK1CS( 28) /+.3161645603 4040694931 3686186666 66 D-24 / - DATA AK1CS( 29) /-.6046205531 2274989106 5064106666 66 D-25 / - DATA AK1CS( 30) /+.1167879894 2042732700 7184213333 33 D-25 / - DATA AK1CS( 31) /-.2277374158 2653996232 8678400000 00 D-26 / - DATA AK1CS( 32) /+.4481109730 0773675795 3058133333 33 D-27 / - DATA AK1CS( 33) /-.8893288476 9020194062 3360000000 00 D-28 / - DATA AK1CS( 34) /+.1779468001 8850275131 3920000000 00 D-28 / - DATA AK1CS( 35) /-.3588455596 7329095821 9946666666 66 D-29 / - DATA AK1CS( 36) /+.7290629049 2694257991 6799999999 99 D-30 / - DATA AK1CS( 37) /-.1491844984 5546227073 0240000000 00 D-30 / - DATA AK1CS( 38) /+.3073657387 2934276300 7999999999 99 D-31 / - DATA AK12CS( 1) /+.6379308343 7390010366 0048853410 2 D-1 / - DATA AK12CS( 2) /+.2832887813 0497209358 3503028470 8 D-1 / - DATA AK12CS( 3) /-.2475370673 9052503454 1454556673 2 D-3 / - DATA AK12CS( 4) /+.5771972451 6072488204 7097662576 3 D-5 / - DATA AK12CS( 5) /-.2068939219 5365483027 4553319655 2 D-6 / - DATA AK12CS( 6) /+.9739983441 3818041803 0921309788 7 D-8 / - DATA AK12CS( 7) /-.5585336140 3806249846 8889551112 9 D-9 / - DATA AK12CS( 8) /+.3732996634 0461852402 2121285473 1 D-10 / - DATA AK12CS( 9) /-.2825051961 0232254451 3506575492 8 D-11 / - DATA AK12CS( 10) /+.2372019002 4841441736 4349695548 6 D-12 / - DATA AK12CS( 11) /-.2176677387 9917539792 6830166793 8 D-13 / - DATA AK12CS( 12) /+.2157914161 6160324539 3956268970 6 D-14 / - DATA AK12CS( 13) /-.2290196930 7182692759 9155133815 4 D-15 / - DATA AK12CS( 14) /+.2582885729 8232749619 1993956522 6 D-16 / - DATA AK12CS( 15) /-.3076752641 2684631876 2109817344 0 D-17 / - DATA AK12CS( 16) /+.3851487721 2804915970 9489684479 9 D-18 / - DATA AK12CS( 17) /-.5044794897 6415289771 1728250880 0 D-19 / - DATA AK12CS( 18) /+.6888673850 4185442370 1829222399 9 D-20 / - DATA AK12CS( 19) /-.9775041541 9501183030 0213248000 0 D-21 / - DATA AK12CS( 20) /+.1437416218 5238364610 0165973333 3 D-21 / - DATA AK12CS( 21) /-.2185059497 3443473734 9973333333 3 D-22 / - DATA AK12CS( 22) /+.3426245621 8092206316 4538880000 0 D-23 / - DATA AK12CS( 23) /-.5531064394 2464082325 0124800000 0 D-24 / - DATA AK12CS( 24) /+.9176601505 6859954037 8282666666 6 D-25 / - DATA AK12CS( 25) /-.1562287203 6180249114 4874666666 6 D-25 / - DATA AK12CS( 26) /+.2725419375 4843331323 4943999999 9 D-26 / - DATA AK12CS( 27) /-.4865674910 0748279923 7802666666 6 D-27 / - DATA AK12CS( 28) /+.8879388552 7235025873 5786666666 6 D-28 / - DATA AK12CS( 29) /-.1654585918 0392575489 3653333333 3 D-28 / - DATA AK12CS( 30) /+.3145111321 3578486743 0399999999 9 D-29 / - DATA AK12CS( 31) /-.6092998312 1931276124 1600000000 0 D-30 / - DATA AK12CS( 32) /+.1202021939 3698158346 2399999999 9 D-30 / - DATA AK12CS( 33) /-.2412930801 4594088413 8666666666 6 D-31 / - DATA NTK1, NTAK1, NTAK12, XMIN, XSML / 3*0, 2*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBSK1Es - IF (NTK1.NE.0) GO TO 10 -c ETA = 0.1*SNGL(D1MACH(3)) - eta=1.4d-18 - NTK1 = INITDSs (BK1CS, 16, ETA) - NTAK1 = INITDSs (AK1CS, 38, ETA) - NTAK12 = INITDSs (AK12CS, 33, ETA) -C -c XMIN = DEXP (DMAX1(DLOG(D1MACH(1)), -DLOG(D1MACH(2))) + 0.01D0) - xmin=5.94d-39 -c XSML = DSQRT (4.0D0*D1MACH(3)) - xsml=7.5d-9 -C - 10 IF (X.LE.0.D0) write(6,*)'DBSK1Es X IS ZERO OR NEGATIVE' - IF (X.GT.2.0D0) GO TO 20 -C - IF (X.LT.XMIN) write(6,*)'DBSK1Es X SO SMALL K1 OVERFLOWS' - Y = 0.D0 - IF (X.GT.XSML) Y = X*X - DBSK1Es = DEXP(X)*(DLOG(0.5D0*X)*DBESI1s(X) + (0.75D0 + - 1DCSEVLs (0.5D0*Y-1.D0, BK1CS, NTK1))/X ) - RETURN -C - 20 IF (X.LE.8.D0) DBSK1Es = - &(1.25D0 + DCSEVLs ((16.D0/X-5.D0)/3.D0, - 1AK1CS, NTAK1))/DSQRT(X) - IF (X.GT.8.D0) DBSK1Es = (1.25D0 + - 1DCSEVLs (16.D0/X-1.D0, AK12CS, NTAK12))/DSQRT(X) -C - RETURN - END - DOUBLE PRECISION FUNCTION DBESK1s(X) -C***BEGIN PROLOGUE DBESK1 -C***DATE WRITTEN 770701 (YYMMDD) -C***REVISION DATE 861211 (YYMMDD) -C***CATEGORY NO. C10B1 -C***KEYWORDS LIBRARY=SLATEC(FNLIB), -C TYPE=DOUBLE PRECISION(BESK1-S DBESK1-D),BESSEL FUNCTION, -C HYPERBOLIC BESSEL FUNCTION,MODIFIED BESSEL FUNCTION, -C ORDER ONE,SPECIAL FUNCTIONS,THIRD KIND -C***AUTHOR FULLERTON, W., (LANL) -C***PURPOSE Computes the dp modified Bessel function of the third kind -C of order one. -C***DESCRIPTION -C -C DBESK1(X) calculates the double precision modified (hyperbolic) -C Bessel function of the third kind of order one for double precision -C argument X. The argument must be large enough that the result does -C not overflow and small enough that the result does not underflow. -C -C Series for BK1 on the interval 0. to 4.00000E+00 -C with weighted error 9.16E-32 -C log weighted error 31.04 -C significant figures required 30.61 -C decimal places required 31.64 -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH,DBESI1,DBSK1E,DCSEVL,INITDS,XERROR -C***END PROLOGUE DBESK1 - DOUBLE PRECISION X, BK1CS(16), XMAX, XMIN, XSML, Y, - 1DCSEVLs, DBESI1s, DBSK1Es - SAVE BK1CS, NTK1, XMIN, XSML, XMAX - DATA BK1CS( 1) /+.2530022733 8947770532 5311208685 33 D-1 / - DATA BK1CS( 2) /-.3531559607 7654487566 7238316918 01 D+0 / - DATA BK1CS( 3) /-.1226111808 2265714823 4790679300 42 D+0 / - DATA BK1CS( 4) /-.6975723859 6398643501 8129202960 83 D-2 / - DATA BK1CS( 5) /-.1730288957 5130520630 1765073689 79 D-3 / - DATA BK1CS( 6) /-.2433406141 5659682349 6007350301 64 D-5 / - DATA BK1CS( 7) /-.2213387630 7347258558 3152525451 26 D-7 / - DATA BK1CS( 8) /-.1411488392 6335277610 9583302126 08 D-9 / - DATA BK1CS( 9) /-.6666901694 1993290060 8537512643 73 D-12 / - DATA BK1CS( 10) /-.2427449850 5193659339 2631968648 53 D-14 / - DATA BK1CS( 11) /-.7023863479 3862875971 7837971200 00 D-17 / - DATA BK1CS( 12) /-.1654327515 5100994675 4910293333 33 D-19 / - DATA BK1CS( 13) /-.3233834745 9944491991 8933333333 33 D-22 / - DATA BK1CS( 14) /-.5331275052 9265274999 4666666666 66 D-25 / - DATA BK1CS( 15) /-.7513040716 2157226666 6666666666 66 D-28 / - DATA BK1CS( 16) /-.9155085717 6541866666 6666666666 66 D-31 / - DATA NTK1, XMIN, XSML, XMAX / 0, 3*0.D0 / -C***FIRST EXECUTABLE STATEMENT DBESK1s - IF (NTK1.NE.0) GO TO 10 - NTK1 = INITDSs (BK1CS, 16, 1.4d-18) -c XMIN = DEXP (DMAX1(DLOG(D1MACH(1)), -DLOG(D1MACH(2))) + 0.01D0) - xmin=5.94d-39 - xsml=7.5d-9 -c XSML = DSQRT (4.0D0*D1MACH(3)) -c XMAX = -DLOG(D1MACH(1)) -c XMAX = XMAX - 0.5D0*XMAX*DLOG(XMAX)/(XMAX+0.5D0) - xmax=86.4d0 -C - 10 IF (X.LE.0.D0) go to 1001 - IF (X.GT.2.0D0) GO TO 20 -C - IF (X.LT.XMIN) write(6,*)'DBESK1s X SO SMALL K1 OVERFLOWS' - Y=0.d0 - IF (X.GT.XSML) Y = X*X - DBESK1s = DLOG(0.5D0*X)*DBESI1s(X) + - &(0.75D0 + DCSEVLs(.5D0*Y-1.D0, - 1BK1CS, NTK1))/X - RETURN -C - 20 DBESK1s = 0.D0 - IF (X.GT.XMAX) write(6,*)'DBESK1s X SO BIG K1 UNDERFLOWS' - IF (X.GT.XMAX) RETURN -C - DBESK1s = DEXP(-X) * DBSK1Es(X) -C - RETURN - 1001 write(6,*)'DBESK1s X IS ZERO OR NEGATIVE- stopped' - stop - END - subroutine BESSKn(M,N,X,y,KODE) - implicit double precision(a-h,o-z) -c Calculates an M-member sequence of modified Bessel functions of the -c 2ndkind. Needs subroutines for exponentially scaled and unscaled -c K_0(x) and K1(x). -c Sequence contains either unscaled or scaled Bessel functions. -c KODE=1 means unscaled. -c KODE=2 means scaled. -c y(k), k=1,2,..m contains K_N (x),K_N+1 (x),...K_N+M-1 (x) -c N must be > or = 0. - dimension y(m) - IF (N.LT.0) go to 1001 - if(kode.eq.2) bkm=dbsk0es(x) - if(kode.eq.2) bk=dbsk1es(x) - if(kode.eq.1) bkm=dbesk0s(x) - if(kode.eq.1) bk=dbesk1s(x) - if(n.gt.1) go to 64 - if(n.gt.0) go to 63 -c n=0 - y(1)=bkm - if(m.lt.2) return - y(2)=bk - if(m.lt.3) return - lmin=3 - go to 64 -c n=1 - 63 y(1)=bk - if(m.lt.2) return - lmin=2 - 64 n2=n+m-1 - if(n.gt.1) lmin=1 - tox=2.d0/x - do 61 j=1,n2-1 - bkp=bkm+dfloat(j)*tox*bk - bkm=bk - bk=bkp - do 62 l=lmin,m - jj=n+l-2 - 62 if(jj.eq.j) y(l)=bk - 61 continue - return - 1001 write(6,*) 'Stopped in BESSKn- N<0: N=',N - stop - end -c -c*********************************** -c diff --git a/OpticsJan2020/MLI_light_optics/Src/liea.f b/OpticsJan2020/MLI_light_optics/Src/liea.f deleted file mode 100644 index 4f2aef5..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/liea.f +++ /dev/null @@ -1,1900 +0,0 @@ -************************************************************************ -* header: LIE ALGEBRAIC * -* Lie algebraic manipulations: Poisson brackets, etc. * -************************************************************************ -c - subroutine brkts(h) -c -c computes poisson brackets of total -c lattice generator h with each -c dynamical variable z(i) -c pbh(j,i=1,6) contains -c exp(:h3:) exp(:h4:) exp(:h5:) exp(:h6:) z(i) -c truncated to sixth order ( for marylie 5.0 ) -c -c - use rays - use lieaparam, only : monoms - include 'impli.inc' - include 'pbkh.inc' - include 'ind.inc' - include 'lims.inc' -cryne 7/23/2002 implicit double precision (a-h,o-z) -c double precision tmh(6,6) - dimension h(923),pb1(923),pb2(923),pb3(923),pb4(923),pb5(923) -cryne 7/23/2002 common /pbkh/ pbh(923,12) -cryne 7/23/2002 common/ind/imaxi,jv(923),index1(923),index2(923) -cryne 7/23/2002 integer bottom(0:12),top(0:12) -cryne 7/23/2002 common/lims/bottom,top -c -c if(idproc.eq.0)write(6,*)'inside brkts' -c -c initialize arrays -c - do 10 i=1,923 - pb1(i)=0.0d0 - pb2(i)=0.0d0 - pb3(i)=0.0d0 - do 20 j=1,12 - pbh(i,j)=0.0d0 - 20 continue - 10 continue -c -c if(idproc.eq.0)write(6,*)'done with initialization' - do i=1,27 - if(h(i).ne.h(i))write(6,*)'warning: element undefined:',i - enddo -c -c compute poisson brackets and store in pbh -c - do 100 iz = 1,6 -c if(idproc.eq.0)write(6,*)'do 100; iz=',iz - do 110 i=1,923 - pb1(i) = 0.d0 - 110 continue - pb1(iz)=1.d0 - do 200 ideg = imaxi,3,-1 - call exphf(h,ideg,pb1,imaxi,pb2) - do 220 i=1,top(imaxi) - pb1(i) = pb2(i) - 220 continue - 200 continue - do 300 i = 1,top(imaxi) - pbh(i,iz) = pb1(i) - 300 continue - 100 continue -c if(idproc.eq.0)write(6,*)'done with do 100' -c debug = 0 -c if ( debug .eq. 1) then -c do 7 i=1,6 -c do 70 j=1,6 -c 70 if(tmh(i,j) .ne. 0.d0 ) write(36,*) i,j,tmh(i,j) -c do 7 no = 2,6 -c call xform5(pbh(1,i),no,tmh,pb1) -c do 7 j=bottom(no),top(no) -c if(pb1(j).ne.0.d0 ) write(36,*) i,j,pb1(j) -c 7 continue -c endif -c -cryne 8/6/2002 -c pbh6=0.d0 -c do i=7,top(imaxi) -c do j=1,6 -c pbh6(i,j)=pbh(i,j) -c enddo -c enddo -c if(idproc.eq.0)write(6,*)'here I am before alloc check' - if(allocated(pbh6t))then -c if(idproc.eq.0)write(6,*)'pbh6t is already allocated' - pbh6t=0.d0 - do i=7,top(imaxi) - do j=1,6 - pbh6t(j,i)=pbh(i,j) - enddo - enddo - endif -c if(idproc.eq.0)write(6,*)'done with final do loop' -c if(idproc.eq.0) then -c write(6,*) ' === liea::brkts() ===' -c write(6,'(a)') ' pbh6t(:) =' -c do i=1,top(imaxi) -c write(6,123) i,(pbh6t(j,i),j=1,6) -c123 format(i4,6(1x,1pe16.9)) -c enddo -c write(6,*) ' leaving liea::brkts()' -c write(6,*) ' =====================' -c end if - return - end -c -************************************************************************ -c - subroutine clear(h,mh) -c Clears to zero the polynomials h and the matrix mh. -c Written by Liam Healy, June 12, 1984. - use lieaparam, only : monoms - double precision mh(6,6),h(monoms) -c Clear out polynomial coefficients: - do 120 i=1,monoms - 120 h(i)=0. -c Clear out matrix: - do 100 i=1,6 - do 100 j=1,6 - 100 mh(i,j)=0. - return - end -*********************************************************************** -c - subroutine concat(fa,fm,ga,gm,ha,hm) -c - use lieaparam, only : monoms - include 'impli.inc' -c -c variables -c - - dimension fa(923),fm(6,6) - dimension ga(923),gm(6,6) - dimension ha(923),hm(6,6) - dimension ha1(923),hm1(6,6) -c -c write(6,*) 'first factor in concat is' -c call pcmap(1,1,0,0,fa,fm) -c write(6,*) 'second factor in concat is' -c call pcmap(1,1,0,0,ga,gm) -c - maxcat = 6 - call drcat(fa,fm,ga,gm,ha1,hm1) -c -c write(6,*) 'result of concat is' -c call pcmap(1,1,0,0,ha1,hm1) -c - call mapmap(ha1,hm1,ha,hm) -c - return - end -c -******************************************************************** -c - subroutine cpadd(fa,ga,ha) -c this is a subroutine for computing the sum of two polynomials -c Written by Alex Dragt, Fall 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms),ha(monoms) -c -c perform calculation - do 10 j=1,monoms - ha(j)=fa(j)+ga(j) - 10 continue -c - return - end -c -************************************************************************ -c - subroutine cpdnf(pow,fa,fm,ga,gm) -c this subroutine computes the power of a dynamic normal form map: -c mapg=(mapf)**pow -c Written by Alex Dragt, Fall 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms) - dimension fm(6,6),gm(6,6) - dimension ta(monoms),t1a(monoms) -c -c clear output array - call clear(t1a,gm) -c -c begin calculation -c -c compute phase advances - cwx=fm(1,1) - swx=fm(1,2) - wx=atan2(swx,cwx) - cwy=fm(3,3) - swy=fm(3,4) - wy=atan2(swy,cwy) - cwt=fm(5,5) - swt=fm(5,6) - wt=atan2(swt,cwt) -c compute new quantities - pwx=pow*wx - cpwx=cos(pwx) - spwx=sin(pwx) - pwy=pow*wy - cpwy=cos(pwy) - spwy=sin(pwy) - pwt=pow*wt - cpwt=cos(pwt) - spwt=sin(pwt) -c compute new matrix - gm(1,1)=cpwx - gm(1,2)=spwx - gm(2,1)=-spwx - gm(2,2)=cpwx - gm(3,3)=cpwy - gm(3,4)=spwy - gm(4,3)=-spwy - gm(4,4)=cpwy - gm(5,5)=cpwt - gm(5,6)=spwt - gm(6,5)=-spwt - gm(6,6)=cpwt -c compute polynomials of old normal form map in dynamic resonance basis - call ctodr(fa,ta) -c pick out those terms which are allowed to be nonzero - t1a(84)=ta(84) - t1a(85)=ta(85) - t1a(86)=ta(86) - t1a(87)=ta(87) - t1a(88)=ta(88) - t1a(89)=ta(89) -c compute polynomials of new map in dynamic resonance basis - call csmul(pow,t1a,t1a) -c transform back to cartesian basis - call drtoc(t1a,ga) -c - return - end -c -******************************************************************** -c - subroutine cppb(fa,ga,ha) -c This subroutine computes the poisson brackets two polynomials -c It gives the result ha=[fa,ga] -c The aray ha is cleared upon entry -c written 5/22/02 AJD -c revised 6/14/02 AJD -c - use lieaparam, only : monoms - include 'impli.inc' -cryne include 'param.inc' -c -c calling arrays -c - dimension fa(monoms) - dimension ga(monoms) - dimension ha(monoms) -c -c working arrays - dimension ta(monoms) - dimension tm(6,6) -c -c clear ha - call clear(ha,tm) -c -c compute Poisson bracket - do if=1,6 !4 changed to 6 - do ig=1,6 !4 changed to 6 - iord=if+ig-2 - if((iord .ge. 0) .and. (iord .le. 6)) then !4 changed to 6 -c clear the result array ta since pbkt does not do so completely - call clear(ta,tm) - call pbkt(fa,if,ga,ig,ta) - call cpadd(ha,ta,ha) - endif - enddo - enddo - return - end -c -******************************************************************** -c - subroutine cpmul(fa,ga,ha) -c Subroutine for computing the product of polynomials -c Written by Alex Dragt, Fall 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms),ha(monoms) -c -c perform calculation - do 10 nf=1,3 - do 20 ng=1,3 - if ((nf+ng).le.4) then - call pprod(fa,nf,ga,ng,ha) - endif - 20 continue - 10 continue -c - return - end -c -************************************************************************ -c - subroutine cpsnf(pow,fa,fm,ga,gm) -c this subroutine computes the power of a static normal form map: -c mapg=(mapf)**pow -c Written by Alex Dragt, Fall 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms) - dimension fm(6,6),gm(6,6) - dimension ta(monoms),t1a(monoms) -c -c clear output array - call clear(t1a,gm) -c -c begin calculation -c -c compute phase advances - cwx=fm(1,1) - swx=fm(1,2) - wx=atan2(swx,cwx) - cwy=fm(3,3) - swy=fm(3,4) - wy=atan2(swy,cwy) -c compute momentum compaction - wt=fm(5,6) -c compute new quantities - pwx=pow*wx - cpwx=cos(pwx) - spwx=sin(pwx) - pwy=pow*wy - cpwy=cos(pwy) - spwy=sin(pwy) - pwt=pow*wt -c compute new matrix - gm(1,1)=cpwx - gm(1,2)=spwx - gm(2,1)=-spwx - gm(2,2)=cpwx - gm(3,3)=cpwy - gm(3,4)=spwy - gm(4,3)=-spwy - gm(4,4)=cpwy - gm(5,5)=1.d0 - gm(5,6)=pwt - gm(6,6)=1.d0 -c compute polynomials of old normal form map in static resonance basis - call ctosr(fa,ta) -c pick out those terms which are allowed to be nonzero - t1a(28)=ta(28) - t1a(29)=ta(29) - t1a(30)=ta(30) - t1a(84)=ta(84) - t1a(85)=ta(85) - t1a(86)=ta(86) - t1a(87)=ta(87) - t1a(88)=ta(88) - t1a(89)=ta(89) -c compute polynomials of new map in static resonance basis - call csmul(pow,t1a,t1a) -c transform back to cartesian basis - call srtoc(t1a,ga) -c - return - end -c -******************************************************************** -c - subroutine csmul(scalar,fa,ga) -c this subroutine computes the scalar multiple of a polynomial -c Written by Alex Dragt, Fall 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms) -c -c perform calculation - do 10 j=1,monoms - ga(j)=scalar*fa(j) - 10 continue -c - return - end -c -*********************************************************************** -c - subroutine drcat(f,mf,g,mg,h,mh) -c concatenates a map with linear piece -c represented by a matrix mf and nonlinearities -c represented by exp:f:, with a map whose -c linear piece has matrix representation mg -c and whose nonlinearities are represented by exp:g: -c -c the result is a map with linearities possessing -c a matrix representation mh=mg*mf -c and with nonlinearities generated by exp:h: -c -c the "f" map is assumed to occur first in the beamline -c the "g" map is encountered second -c - implicit double precision (a-h,o-z) - double precision mf,mg,mh,m - dimension f(923), g(923), h(923) - dimension mf(6,6),mg(6,6),mh(6,6),m(6,6) - dimension f3(923),f4(923),f5(923),f6(923) - dimension t3(923),t4(923),t5(923),t6(923) - include 'symp.inc' -c -c write(6,*) 'first factor in mycat' -c call pcmap(1,1,0,0,f,mf) -c write(6,*) 'second factor in mycat' -c call pcmap(1,1,0,0,g,mg) -c - call ident(h,mh) - do 666 i1=1,923 - t3(i1) = 0.0d0 - 666 continue -c -c compute mh=mg*mf -c - call mmult(mg,mf,mh) -c -c compute m = mginverse -c - call matmat(mg,m) - call minv(m) -c -c compute transformed arrays -c - call xform5(f,3,m,f3) - call xform5(f,4,m,f4) - call xform5(f,5,m,f5) -c -c write(6,*) 'contents of f5 and m' -c call pcmap(1,1,0,0,f5,m) -c - call xform5(f,6,m,f6) -c third order terms - call pmadd(g,3,1.d0,h) - call pmadd(f3,3,1.d0,h) -c fourth order terms - call pbkt1(f3,3,g,3,t4) - call pmadd(g,4,1.d0,h) - call pmadd(f4,4,1.d0,h) - call pmadd(t4,4,.5d0,h) -c fifth order terms - call pmadd(g,5,1.d0,h) - call pmadd(f5,5,1.d0,h) - call pmadd(g,3,1.d0,t3) - call pmadd(f3,3,1.d0/2.d0,t3) - call pbkt1(t3,3,t4,4,t5) - call pmadd(t5,5,-1.d0/3.d0,h) - call pbkt1(g,3,f4,4,t5) - call pmadd(t5,5,-1.d0,h) -c write(6,*) 'result of drcat at end of fifth order' -c call pcmap(1,1,0,0,h,mh) - -c sixth order terms - call pbkt1(g,4,f4,4,t6) - call pmadd(t6,6,-.5d0,h) - call pmadd(g,6,1.d0,h) - call pmadd(f6,6,1.d0,h) - call pbkt1(g,3,f5,5,t6) - call pmadd(t6,6,-1.d0,h) - call pbkt1(f3,3,g,3,t4) - call pbkt1(g,3,t4,4,t5) - call pbkt1(f3,3,t5,5,t6) - call pmadd(t6,6,(-1.d0/24.d0),h) - call pbkt1(h,3,t4,4,t5) - call pbkt1(h,3,t5,5,t6) - call pmadd(t6,6,(1.d0/12.d0),h) - call pbkt1(g,3,f4,4,t5) - call pbkt1(g,3,t5,5,t6) - call pmadd(t6,6,(.5d0),h) - call pbkt1(f4,4,t4,4,t6) - call pmadd(t6,6,-.25d0,h) - call pbkt1(g,4,t4,4,t6) - call pmadd(t6,6,-.25d0,h) - call pbkt1(g,3,t4,4,t5) - call pbkt1(h,3,t5,5,t6) - call pmadd(t6,6,(1.d0/24.d0),h) - call pbkt1(f3,3,t4,4,t5) - call pbkt1(h,3,t5,5,t6) - call pmadd(t6,6,(-1.d0/24.d0),h) -c This is not very efficient, but we are trying to -c make it work before making it fast. -c -c write(6,*) 'result of drcat' -c call pcmap(1,1,0,0,h,mh) -c - return - end -c -*********************************************************************** - - subroutine cpsp(job,f,g,ans1,ans2,ans3,ans4) -c this subroutine computes the scalar product of the two polynomials -c f and g. -c Written by Alex Dragt 10/23/89 -c - use lieaparam, only : monoms - include 'impli.inc' -ccccc include 'param.inc' - include 'expon.inc' -c -c calling arrays - dimension f(*), g(*) -ccccc dimension f(0:monoms), g(0:monoms) -c - integer jf(6),jg(6) -c -c compute scalar products -c -c procedure for USp(6) invariant scalar product -c - if(job .eq. 1) then -c -c first order part -c - ans1=0.d0 - do ind=1,6 - test=f(ind)*g(ind) - if (test .ne. 0.d0) then - do k=1,6 - jf(k)=expon(k,ind) - enddo - call msp1(jf,val) - ans1=ans1+test*val - endif - enddo -c -c second order part -c - ans2=0.d0 - do ind=7,27 - test=f(ind)*g(ind) - if (test .ne. 0.d0) then - do k=1,6 - jf(k)=expon(k,ind) - enddo - call msp1(jf,val) - ans2=ans2+test*val - endif - enddo -c -c third order part -c - ans3=0.d0 - do ind=28,83 - test=f(ind)*g(ind) - if (test .ne. 0.d0) then - do k=1,6 - jf(k)=expon(k,ind) - enddo - call msp1(jf,val) - ans3=ans3+test*val - endif - enddo -c -c fourth order part -c - ans4=0.d0 - do ind=84,209 - test=f(ind)*g(ind) - if (test .ne. 0.d0) then - do k=1,6 - jf(k)=expon(k,ind) - enddo - call msp1(jf,val) - ans4=ans4+test*val - endif - enddo -c - endif -c -c procedure for integration over S^5 invariant scalar product -c - if(job .eq. 2) then -c -c first order part -c - ans1=0.d0 - do 10 indf=1,6 - do 10 indg=1,6 - test=f(indf)*g(indg) - if (test .ne. 0.d0) then - do 12 k=1,6 - jf(k)=expon(k,indf) - jg(k)=expon(k,indg) - 12 continue - call msp2(jf,jg,val) - ans1=ans1+test*val - endif - 10 continue - ans1=ans1/3.d0 -c -c second order part -c - ans2=0.d0 - do 20 indf=7,27 - do 20 indg=7,27 - test=f(indf)*g(indg) - if (test .ne. 0.) then - do 22 k=1,6 - jf(k)=expon(k,indf) - jg(k)=expon(k,indg) - 22 continue - call msp2(jf,jg,val) - ans2=ans2+test*val - endif - 20 continue - ans2=ans2/12.d0 -c -c third order part -c - ans3=0.d0 - do 30 indf=28,83 - do 30 indg=28,83 - test=f(indf)*g(indg) - if (test .ne. 0.d0) then - do 32 k=1,6 - jf(k)=expon(k,indf) - jg(k)=expon(k,indg) - 32 continue - call msp2(jf,jg,val) - ans3=ans3+test*val - endif - 30 continue - ans3=ans3/60.d0 -c -c fourth order part -c - ans4=0.d0 - do 40 indf=84,209 - do 40 indg=84,209 - test=f(indf)*g(indg) - if (test .ne. 0.) then - do 42 k=1,6 - jf(k)=expon(k,indf) - jg(k)=expon(k,indg) - 42 continue - call msp2(jf,jg,val) - ans4=ans4+test*val - endif - 40 continue - ans4=ans4/360.d0 -c - endif -c - return - end - -*********************************************************************** -c - subroutine old_cpsp(f,g,ans1,ans2,ans3,ans4) -c this subroutine computes the scalar product of the two polynomials -c f and g. -c Written by Alex Dragt 10/23/89 -c - use lieaparam, only : monoms - include 'impli.inc' - include 'expon.inc' -c -c calling arrays -ccccc dimension f(209), g(209) - dimension f(*), g(*) -c - integer jf(6),jg(6) -c -c compute inner products -c -c first order part -c - ans1=0.d0 - do 10 indf=1,6 - do 10 indg=1,6 - test=f(indf)*g(indg) - if (test .ne. 0.d0) then - do 12 k=1,6 - jf(k)=expon(k,indf) - jg(k)=expon(k,indg) - 12 continue - call msp(jf,jg,val) - ans1=ans1+test*val - endif - 10 continue - ans1=ans1/3.d0 -c -c second order part -c - ans2=0.d0 - do 20 indf=7,27 - do 20 indg=7,27 - test=f(indf)*g(indg) - if (test .ne. 0.) then - do 22 k=1,6 - jf(k)=expon(k,indf) - jg(k)=expon(k,indg) - 22 continue - call msp(jf,jg,val) - ans2=ans2+test*val - endif - 20 continue - ans2=ans2/12.d0 -c -c third order part -c - ans3=0.d0 - do 30 indf=28,83 - do 30 indg=28,83 - test=f(indf)*g(indg) - if (test .ne. 0.d0) then - do 32 k=1,6 - jf(k)=expon(k,indf) - jg(k)=expon(k,indg) - 32 continue - call msp(jf,jg,val) - ans3=ans3+test*val - endif - 30 continue - ans3=ans3/60.d0 -c -c fourth order part -c - ans4=0.d0 - do 40 indf=84,209 - do 40 indg=84,209 - test=f(indf)*g(indg) - if (test .ne. 0.) then - do 42 k=1,6 - jf(k)=expon(k,indf) - jg(k)=expon(k,indg) - 42 continue - call msp(jf,jg,val) - ans4=ans4+test*val - endif - 40 continue - ans4=ans4/360.d0 -c - return - end -c -*********************************************************************** -c - subroutine evalf(zi,h,val2,val3,val4) -c this subroutine computes the value of the function h(zi) -c Written by Alex Dragt, Fall 1986, based on work of F. Neri - use lieaparam, only : monoms - include 'impli.inc' - dimension zi(6) - dimension h(monoms),avect(monoms) - include 'ind.inc' -c compute vector containing values of basis monomials -cryne call evalm(zi,vect) - call evalm(zi,avect) -c -c the following code has been commented out since it is replaced -c by the use of evalm -c compute linear monomials -c do 10 i=1,6 -c 10 avect(i) = zi(i) -c compute higher order monomials -c do 20 i = 7,monoms -c 20 avect(i) = avect(index1(i))*avect(index2(i)) -c -c compute value of h - val2=0.d0 - do 30 i=1,27 - 30 val2=val2+h(i)*avect(i) - val3=val2 - do 40 i=28,83 - 40 val3=val3+h(i)*avect(i) - val4=val3 - do 50 i=84,209 - 50 val4=val4+h(i)*avect(i) - return - end -c -************************************************************ -c - subroutine evalf_old(zi,h,val2,val3,val4) -c this subroutine computes the value of the function h(zi) -c Written by Alex Dragt, Fall 1986, based on work of F. Neri - use lieaparam, only : monoms - include 'impli.inc' - dimension zi(6) - dimension h(monoms),avect(monoms) - include 'ind.inc' -c compute vector containing values of basis monomials -c compute linear monomials - do 10 i=1,6 - 10 avect(i) = zi(i) -c compute higher order monomials - do 20 i = 7,monoms - 20 avect(i) = avect(index1(i))*avect(index2(i)) -c compute value of h - val2=0.d0 - do 30 i=1,27 - 30 val2=val2+h(i)*avect(i) - val3=val2 - do 40 i=28,83 - 40 val3=val3+h(i)*avect(i) - val4=val3 - do 50 i=84,209 - 50 val4=val4+h(i)*avect(i) - return - end -c -******************************************************************** -c - subroutine evalm(zi,vect) -c this subroutine computes the values of the basis -c monomials and stores them in the vector vect. -c Written by Alex Dragt, 1 July 1991, based on work of F. Neri -c - use lieaparam, only : monoms - include 'impli.inc' - include 'ind.inc' -c -c calling arrays - dimension zi(6) - dimension vect(monoms) -c -c compute linear monomials - do 10 i=1,6 - 10 vect(i) = zi(i) -c compute higher order monomials - do i = 7,27 - vect(i) = vect(index1(i))*vect(index2(i)) - enddo - do i = 28,209 - vect(i) = vect(index1(i))*vect(index2(i)) - enddo - do i = 210,monoms - vect(i) = vect(index1(i))*vect(index2(i)) - enddo -c - return - end -c - subroutine exphf(h,ideg,f,maxf,trf) -c Applies Exp(:h:) on polynomial f. -c h is a polynomial of degree ideg. -c f has terms from 1 thru maxf. -c The result is trf, which has terms 1-maxf. -c -c Written By F. Neri 9/26/86. -c - include 'lims.inc' - double precision f(923),h(923),trf(923) - double precision tmpf1(923),tmpf2(923) -c maxf has to be .le. 6. - integer maxf - integer maxpow, ifact, maxord -cryne 7/23/2002 integer bottom(0:12),top(0:12) -cryne 7/23/2002 common/lims/bottom,top - do 1 i=1,top(maxf) - tmpf1(i) = f(i) - 1 continue - do 3 i = 1,top(maxf) - trf(i) = f(i) - 3 continue - maxpow = int((maxf-1)/(ideg-2)) - ifact = 1 - do 10 n=1,maxpow - ifact = ifact * (-n) - maxord = int(maxf - (ideg-2) ) - do 11 i=1,top(maxf) - tmpf2(i) = 0.d0 - 11 continue - do 20 iord=maxord,1,-1 - call pbkt(tmpf1,iord,h,ideg,tmpf2) - call pmadd(tmpf2,iord+ideg-2,(1.d0/ifact),trf) - 20 continue - do 30 i=1,top(maxf) - tmpf1(i) = tmpf2(i) - 30 continue - 10 continue - return - end -c -****************************************************************** -c - subroutine fxform(ga,gm,fa,ha) -c this is a subroutine for transforming a function f. -c that is, it computes h=exp(:g:)f where f is given -c by f=f2+f3+f4 and exp(:g:) denotes a general map. -c Written by Alex Dragt, Fall 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension ga(monoms),fa(monoms),ha(monoms),t1a(monoms), - & t2a(monoms),t3a(monoms) - dimension gm(6,6),tm(6,6) -c clear arrays - call clear(t1a,tm) - call clear(t2a,tm) - call clear(t3a,tm) - call clear(ha,tm) -c compute [g3,f2] - call pbkt(ga,3,fa,2,t1a) -c compute [g3,f3] - call pbkt(ga,3,fa,3,t2a) -c compute [g3,[g3,f2]] - call pbkt(ga,3,t1a,3,t3a) -c compute [g4,f2] - call pbkt(ga,4,fa,2,t1a) -c accumulate results -c set up second order part - do 10 i=7,27 - 10 t1a(i)=fa(i) -c set up third order part - do 20 i=28,83 - 20 t1a(i)=fa(i) + t1a(i) -c set up fourth order part - do 30 i=84,209 - 30 t1a(i)=fa(i) + t2a(i) + t3a(i)/2.d0 + t1a(i) -c transform results by gm - call xform(t1a,2,gm,0,ha) - call xform(t1a,3,gm,1,ha) - call xform(t1a,4,gm,1,ha) - return - end -c - subroutine mapmap(rh,rmh,th,tmh) -c Written by Rob Ryne, ca 1982 - use lieaparam, only : monoms - include 'impli.inc' - dimension rh(monoms),th(monoms),rmh(6,6),tmh(6,6) - do 10 i=1,6 - do 10 j=1,6 - 10 tmh(i,j)=rmh(i,j) - do 20 i=1,monoms - 20 th(i)=rh(i) -c - return - end -c -*********************************************************************** -c - subroutine matify(matrix,f2) -c Computes the matrix that corresponds to :f2:. -c It is written in a simple-minded manner to keep execution time short. -c Written by Liam Healy, May 29, 1985. -c -c----Variables---- -c implicit none -c matrix = matrix supplied - double precision matrix(6,6) -c f2 = array of coefficients giving f2 values (others are ignored) - double precision f2(*) -c -c----Routine---- - matrix(1,1)=-f2(8) - matrix(1,2)=-2.*f2(13) - matrix(1,3)=-f2(14) - matrix(1,4)=-f2(15) - matrix(1,5)=-f2(16) - matrix(1,6)=-f2(17) - matrix(2,1)=2.*f2(7) - matrix(2,2)=f2(8) - matrix(2,3)=f2(9) - matrix(2,4)=f2(10) - matrix(2,5)=f2(11) - matrix(2,6)=f2(12) - matrix(3,1)=-f2(10) - matrix(3,2)=-f2(15) - matrix(3,3)=-f2(19) - matrix(3,4)=-2.*f2(22) - matrix(3,5)=-f2(23) - matrix(3,6)=-f2(24) - matrix(4,1)=f2(9) - matrix(4,2)=f2(14) - matrix(4,3)=2*f2(18) - matrix(4,4)=f2(19) - matrix(4,5)=f2(20) - matrix(4,6)=f2(21) - matrix(5,1)=-f2(12) - matrix(5,2)=-f2(17) - matrix(5,3)=-f2(21) - matrix(5,4)=-f2(24) - matrix(5,5)=-f2(26) - matrix(5,6)=-2.*f2(27) - matrix(6,1)=f2(11) - matrix(6,2)=f2(16) - matrix(6,3)=f2(20) - matrix(6,4)=f2(23) - matrix(6,5)=2.*f2(25) - matrix(6,6)=f2(26) - return - end -c -*********************************************************************** -c - subroutine mclear(mh) -c -c Clears to zero the matrix mh. -c Written by Liam Healy, June 12, 1984. -c - double precision mh(6,6) -c - do 100 i=1,6 - do 100 j=1,6 - 100 mh(i,j)=0.d0 - return - end -c -*********************************************************************** -c -c -*********************************************************************** -c - subroutine mident(mh) -c -c Sets mh to the identity matrix. -c - double precision mh(6,6) -c - call mclear(mh) -c - do 100 i=1,6 - 100 mh(i,i)=1.d0 -c - return - end -c -************************************************************************ -c - subroutine minv(fm) -c Returns the inverse of the matrix fm on the -c assumption that fm is symplectic. -c Written by Alex Dragt, 4 October 1989. -c - include 'impli.inc' - include 'symp.inc' -c -c Calling array - dimension fm(6,6) -c -c Temporary arrays - dimension temp(6,6) -c -c----Routine---- -c -c Calculate (fm transpose)*jm -c - call mclear(temp) - do 120 j=1,6 - do 120 k=1,6 - do 120 l=1,6 - 120 temp(j,k)=temp(j,k)+fm(l,j)*jm(l,k) -c -c Calculate (jm transpose)*(fm transpose)*jm -c - call mclear(fm) - do 140 j=1,6 - do 140 l=1,6 - do 140 k=1,6 - 140 fm(j,k)=fm(j,k)+jm(l,j)*temp(l,k) -c - return - end -c -*********************************************************************** -c - subroutine mycat(maxcat,f,mf,g,mg,h,mh) -c concatenates a map with linear piece -c represented by a matrix mf and nonlinearities -c represented by exp:f:, with a map whose -c linear piece has matrix representation mg -c and whose nonlinearities are represented by exp:g: -c -c the result is a map with linearities possessing -c a matrix representation mh=mg*mf -c and with nonlinearities generated by exp:h: -c -c the "f" map is assumed to occur first in the beamline -c the "g" map is encountered second -c - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' - include 'symp.inc' - include 'ind.inc' - double precision j4,mf,mg,mh,m,l3,l4 - dimension mf(6,6),mg(6,6),mh(6,6),temp(6,6),m(6,6) - dimension f(monoms), g(monoms), h(monoms) - dimension f3(monom2),f4(monom2),f5(monom1),f6(monoms) - dimension t3(monom2),t4(monom2),t5(monom1),t6(monoms) -cryne 7/23/2002 implicit double precision (a-h,o-z) -cryne 7/23/2002 dimension f(923), g(923), h(923) -cryne 7/23/2002 dimension f3(209),f4(209),f5(461),f6(923) -cryne 7/23/2002 dimension t3(209),t4(209),t5(461),t6(923) -cryne 7/23/2002 common /ind/imaxi,jv(923),index1(923),index2(923) -c - write(6,*) 'first factor in mycat' - call pcmap(1,1,0,0,f,mf) - write(6,*) 'second factor in mycat' - call pcmap(1,1,0,0,g,mg) -c - call ident(h,mh) - do 666 i1=1,209 - t3(i1) = 0.0d0 - 666 continue - do 777 i1=1,6 - do 777 i2=1,6 - m(i1,i2)=0.d0 - mh(i1,i2) = 0.d0 - temp(i1,i2) = 0.d0 - 777 continue -c -c compute mh=mg*mf and temp=mgtransposed*jm -c - do 40 j=1,6 - do 30 k=1,6 - do 20 l=1,6 - mh(j,k)=mh(j,k)+mg(j,l)*mf(l,k) - temp(j,k)=temp(j,k)+mg(l,j)*jm(l,k) - 20 continue - 30 continue - 40 continue -c -c compute m=inverse of mg=jmtransposed*temp -c - do 41 j=1,6 - do 31 k=1,6 - do 21 l=1,6 - m(j,k)=m(j,k)+jm(l,j)*temp(l,k) - 21 continue - 31 continue - 41 continue -c -c compute transformed arrays -c - call xform5(f,3,m,f3) - call xform5(f,4,m,f4) - if(maxcat.gt.4) call xform5(f,5,m,f5) - if(maxcat.gt.5) call xform5(f,6,m,f6) -c third order terms - call pmadd(g,3,1.d0,h) - call pmadd(f3,3,1.d0,h) -c fourth order terms - call pbkt1(f3,3,g,3,t4) - call pmadd(g,4,1.d0,h) - call pmadd(f4,4,1.d0,h) - call pmadd(t4,4,.5d0,h) -c fifth order terms - if(maxcat.gt.4) then - call pmadd(g,5,1.d0,h) - call pmadd(f5,5,1.d0,h) - call pmadd(g,3,1.d0,t3) - call pmadd(f3,3,1.d0/2.d0,t3) - call pbkt1(t3,3,t4,4,t5) - call pmadd(t5,5,-1.d0/3.d0,h) - call pbkt1(g,3,f4,4,t5) - call pmadd(t5,5,-1.d0,h) - endif -c sixth order terms - if(maxcat.gt.5) then - call pbkt1(g,4,f4,4,t6) - call pmadd(t6,6,-.5d0,h) - call pmadd(g,6,1.d0,h) - call pmadd(f6,6,1.d0,h) - call pbkt1(g,3,f5,5,t6) - call pmadd(t6,6,-1.d0,h) - call pbkt1(f3,3,g,3,t4) - call pbkt1(g,3,t4,4,t5) - call pbkt1(f3,3,t5,5,t6) - call pmadd(t6,6,(-1.d0/24.d0),h) - call pbkt1(h,3,t4,4,t5) - call pbkt1(h,3,t5,5,t6) - call pmadd(t6,6,(1.d0/12.d0),h) - call pbkt1(g,3,f4,4,t5) - call pbkt1(g,3,t5,5,t6) - call pmadd(t6,6,(.5d0),h) - call pbkt1(f4,4,t4,4,t6) - call pmadd(t6,6,-.25d0,h) - call pbkt1(g,4,t4,4,t6) - call pmadd(t6,6,-.25d0,h) - call pbkt1(g,3,t4,4,t5) - call pbkt1(h,3,t5,5,t6) - call pmadd(t6,6,(1.d0/24.d0),h) - call pbkt1(f3,3,t4,4,t5) - call pbkt1(h,3,t5,5,t6) - call pmadd(t6,6,(-1.d0/24.d0),h) -c This is not very efficient, but we are trying to -c make it work before making it fast. - endif -c - write(6,*) 'result of mycat' - call pcmap(1,1,0,0,h,mh) -c - return - end -c -*********************************************************************** -c - subroutine msp(j1,j2,val) -c Calculated the scalar product of two monomials having exponent -c arrays j1 and j2. -c Written by Alex Dragt 10/22/89 -c - include 'impli.inc' -c -c calling arrays - integer j1(6),j2(6) -c - integer jt(6) -c - do 10 i=1,6 - 10 jt(i)=j1(i)+j2(i) - call s5i(jt,val) -c - return - end -c -*********************************************************************** -c - subroutine msp1(j1,val) -c For a monomial having exponent array j1, calculates -c the USp(6) invariant scalar product of the monomial -c with itself. -c Written by Alex Dragt 2/18/03. -c - include 'impli.inc' -c -c calling arrays - integer j1(6) -c -c procedure for computing j1! -c - val=1.d0 - do i=1,6 - ipow=j1(i) - call factfn(ipow,coefi) - val=val*coefi - enddo -c - return - end -c -*********************************************************************** -c - subroutine msp2(j1,j2,val) -c Calculates the S^5 invariant scalar product of two monomials -c having exponent arrays j1 and j2. -c Written by Alex Dragt 10/22/89 -c - include 'impli.inc' -c -c calling arrays - integer j1(6),j2(6) -c - integer jt(6) -c - do 10 i=1,6 - 10 jt(i)=j1(i)+j2(i) - call s5i(jt,val) -c - return - end -*********************************************************************** -c - subroutine factfn(intg,val) -c -c This subroutine finds val=intg! -c Written by Alex Dragt 2/18/03 -c - include 'impli.inc' -c - dimension table(0:6) -c - data table/1.d0,1.d0,2.d0,6.d0,24.d0,120.d0,720.d0/ -c - val=table(intg) -c - return - end - -*********************************************************************** -c - subroutine pbkt(f,ordf,g,ordg,pb) -c Calculates the Poisson Bracket of the order ordf part of f with -c the order ordg part of g, leaving the result in pb. -c Written by Liam Healy, November 26, 1984. -c - use lieaparam, only : monoms -c----Variables---- -c f,g,pb = two arrays and their Poisson bracket - double precision f(*),g(*),pb(*) -c ordf,ordg = order desired from f and g - integer ordf,ordg -c indf,indg,indpb = index in f,g and pb - integer indf,indg,indpb -c pr = array of exponents for the product of f(indf) and g(indg) -c prd =copy of pr -c prx, prp = exponents of particular x, p variables, from pr - integer pr(6),prd(6),prx,prp -c xvb, pvb, vbl = x variable, p variable (pvb=xvb+1), variable number - integer xvb,pvb,vbl - include 'expon.inc' - include 'lims.inc' -c -c----Routine---- -c initialize array pb - do 80 indpb=bottom(ordf+ordg-2),top(ordf+ordg-2) - 80 pb(indpb)=0. -c pick individual indf and indg, find what element of pb it affects, -c and calculate the new value. Loop for all indeces in the specified -c orders. - do 100 indf=bottom(ordf),top(ordf) - if (f(indf).ne.0.) then - do 120 indg=bottom(ordg),top(ordg) - if (g(indg).ne.0.) then -c load sum of exponents into pr - do 140 vbl=1,6 - 140 pr(vbl)=expon(vbl,indf)+expon(vbl,indg) - do 160 xvb=1,5,2 -c go through three axes; for each one that pb can -c be taken, modify appropriate element of pb. - pvb=xvb+1 - do 180 vbl=1,6 - 180 prd(vbl)=pr(vbl) - prx=prd(xvb) - prp=prd(pvb) - if (prx*prp.gt.0) then - prd(xvb)=prx-1 - prd(pvb)=prp-1 - indpb=ndex(prd) - pb(indpb)=pb(indpb)+f(indf)*g(indg) - & *(expon(xvb,indf)*expon(pvb,indg) - & -expon(pvb,indf)*expon(xvb,indg)) - endif - 160 continue - endif - 120 continue - endif - 100 continue - return - end -c - subroutine pbkt1(f,ordf,g,ordg,pb) -c Calculates the Poisson Bracket of the order ordf part of f with -c the order ordg part of g, leaving the result in pb. -c - use lieaparam, only : monoms,monom1 - include 'iprod.inc' - include 'expon.inc' - include 'lims.inc' - include 'prodex.inc' -c----Variables---- -c f,g,pb = two arrays and their Poisson bracket - double precision f(*),g(*),pb(*) -c ordf,ordg = order desired from f and g - integer ordf,ordg -c indf,indg,indpb = index in f,g and pb - integer indf,indg,indpb -c pr = array of exponents for the product of f(indf) and g(indg) -c prd =copy of pr -c prx, prp = exponents of particular x, p variables, from pr - integer pr(6),prd(6),prx,prp -c xvb, pvb, vbl = x variable, p variable (pvb=xvb+1), variable number - integer xvb,pvb,vbl -c expon = table of exponents -cryne 7/23/2002 integer expon(6,0:923) -cryne 7/23/2002 common/expon/expon -c bottom, top = lowest and highest monomial number for each order -cryne 7/23/2002 integer bottom(0:12),top(0:12) -cryne 7/23/2002 common/lims/bottom,top -cryne 7/23/2002 integer prodex(6,0:923) -cryne 7/23/2002 common /prodex/prodex - integer vbf,vbg - integer conj(6),sigj(6) - data conj /2,1,4,3,6,5/ - data sigj /1,-1,1,-1,1,-1/ - save conj,sigj !cryne 7/23/3003 -c -c----Routine---- -c initialize array pb - do 80 indpb=bottom(ordf+ordg-2),top(ordf+ordg-2) - 80 pb(indpb)=0. -c pick individual indf and indg, find what element of pb it affects, -c and calculate the new value. Loop for all indeces in the specified orders. - do 160 vbf = 1,6 - vbg = conj(vbf) - sign = sigj(vbf) - do 100 indf=bottom(ordf-1),top(ordf-1) - if(f(prodex(vbf,indf)).eq.0.0d0 ) goto 100 - do 110 indg=bottom(ordg-1),top(ordg-1) - indpb = iprod(indg,indf) - pb(indpb) = pb(indpb) + - & sign * f(prodex(vbf,indf)) * g(prodex(vbg,indg)) - & * (expon(vbf,indf)+1) * (expon(vbg,indg)+1) - 110 continue - 100 continue - 160 continue - return - end -c - subroutine pbkt2(f,n,index,bpb) -c computes the poisson bracket [f,z(i)] of -c an n-th degree polynomial whose coefficients -c are stored in an array f with the i-th component -c of the dynamical variable array z. -c z(1)=x -c z(2)=px -c . -c . -c . -c -c the coefficients of the result are -c stored in the array bpb. note the -c result is a polynomial of degree n-1 -c - use lieaparam, only : monoms - include 'impli.inc' - include 'expon.inc' - include 'vblist.inc' - include 'len.inc' -cryne 7/23/2002 implicit double precision (a-h,o-z) -cryne 7/23/2002 integer expon(6,0:923),vblist(6,0:923) -cryne 7/23/2002 dimension f(923),bpb(923),j(6) -cryne 7/23/2002 common/expon/expon -cryne 7/23/2002 common/vblist/vblist - dimension f(monoms),bpb(monoms),j(6) - dimension zz(6) -cryne 7/23/2002 common /len/ len(16) - do 10 i = 1,6 - zz(i) = 0.0d0 - 10 continue - zz(index) = 1.0d0 - call pbkt1(f,n,zz,1,bpb) -c - return - end -c -************************************************************************ -c - subroutine polr(fa,fm,rm,pdsm,reval,revec) -c this subroutine finds the polar decomposition of a symplectic map -c fa,fm is the incoming matrix, and is left unchanged -c rm and pdsm are its orthogonal (rotation) and positive definite -c symmetric factors -c reval and revec are the eigenvalues and eigenvector array for pdsm -c Written by Alex Dragt, Fall 1986 -c - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms) - dimension fm(6,6),rm(6,6),pdsm(6,6),reval(6),revec(6,6) - dimension t1m(6,6),t2m(6,6) - dimension ta(monoms) -c -c clear array - call clear(ta,t1m) -c -c begin computation -c -c computation of positive definite symmetric factor -c along with its eigenvalues and eigenvectors -c -c find (fm transpose)*fm - call matmat(fm,t1m) - call mtran(t1m) - call mmult(t1m,fm,t2m) -c extract square root - call seig6(t2m,reval,revec) - call mclear(t2m) - do 10 i=1,6 - reval(i)=sqrt(reval(i)) - t2m(i,i)=reval(i) - 10 continue - call matmat(revec,t1m) - call inv(ta,t1m) - call sndwch(ta,t1m,ta,t2m,ta,pdsm) -c -c computation of orthogonal (rotation) factor -c - call matmat(pdsm,t1m) - call inv(ta,t1m) - call concat(ta,t1m,ta,fm,ta,rm) -c - return - end -c -*********************************************************************** -c - subroutine pprod(a,na,b,nb,c) -c this subroutine computes the product of two polynomials: c=a*b -c Written by Alex Dragt, Fall 1986, based on work of F. Neri - use lieaparam, only : monoms - include 'impli.inc' - include 'expon.inc' - include 'lims.inc' - dimension a(monoms),b(monoms),c(monoms),l(6) -c - do 200 ia=bottom(na),top(na) - if(a(ia).eq.0.d0) goto 200 - do 20 ib = bottom(nb),top(nb) - if(b(ib).eq.0.d0) goto 20 - do 2 m=1,6 - l(m) = expon(m,ia) + expon(m,ib) - 2 continue - n = ndex(l) - c(n) = c(n) + a(ia)*b(ib) - 20 continue - 200 continue -c - return - end -c -*********************************************************************** -c - subroutine s2f(revec,k1,k2,val) -c this subroutine evaluates the symplectic 2-form assiciated with J -c Written by Alex Dragt, Fall 1986 - include 'impli.inc' - dimension revec(6,6) -c -c begin calculation - val=0.d0 - do 10 ip=2,6,2 - iq=ip-1 - val=val+revec(iq,k1)*revec(ip,k2)-revec(ip,k1)*revec(iq,k2) - 10 continue -c - return - end -c -*********************************************************************** -c - subroutine s5i(j,ans) -c Calculates the integral over S5 of the monomial having exponents -c stored in j. -c Written by Alex Dragt 10/22/89 -c - include 'impli.inc' -c -c calling array - integer j(6) -c - dimension anst(6) -c - ans=0. - do 10 i=1,6 - tans=0.d0 - ji=j(i) - if (ji .eq. 0) tans=1.d0 - if (ji .eq. 2) tans=1.d0/2.d0 - if (ji .eq. 4) tans=3.d0/4.d0 - if (ji .eq. 6) tans=15.d0/8.d0 - if (ji .eq. 8) tans=105.d0/16.d0 - if (tans .eq. 0.d0) return - anst(i)=tans - 10 continue - ans=anst(1)*anst(2)*anst(3)*anst(4)*anst(5)*anst(6) -c - return - end -c -*********************************************************************** -c - subroutine scncat(fa,fm,ga,gm,ha,hm) -c this is a special routine for concatenation. -c it calls concat and then transfers the -c coefficients for the linear and quadratic -c polynomials. -c Written by Alex Dragt, Fall 1985 -c - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms),ha(monoms) - dimension fm(6,6),gm(6,6),hm(6,6) - call clear(ha,hm) - call concat(fa,fm,ga,gm,ha,hm) -c transfer coefficients for linear and quadratic polynomials - do 10 i=1,27 - ha(i)=ga(i) - 10 continue - return - end -c -*********************************************************************** -c - subroutine smtof(scale,tm,ta) -c converts the symmetric matrix scale*tm to the array ta. -c written by Alex Dragt 22 May 1991 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension ta(monoms), tm(6,6) -c -c procedure -c clear array - do 5 i=1,monoms - 5 ta(i)=0.d0 -c put in new contents - ta(7)=tm(1,1) - ta(8)=tm(1,2) - ta(9)=tm(1,3) - ta(10)=tm(1,4) - ta(11)=tm(1,5) - ta(12)=tm(1,6) - ta(13)=tm(2,2) - ta(14)=tm(2,3) - ta(15)=tm(2,4) - ta(16)=tm(2,5) - ta(17)=tm(2,6) - ta(18)=tm(3,3) - ta(19)=tm(3,4) - ta(20)=tm(3,5) - ta(21)=tm(3,6) - ta(22)=tm(4,4) - ta(23)=tm(4,5) - ta(24)=tm(4,6) - ta(25)=tm(5,5) - ta(26)=tm(5,6) - ta(27)=tm(6,6) -c - do 10 i=7,27 - 10 ta(i)=scale*ta(i) -c - return - end -c -*********************************************************************** -c - subroutine sndwch(t1a,t1m,t2a,t2m,t3a,t3m) -c this is a subroutine for sandwiching a map -c it computes t3=t1*t2*(t1 inverse) -c Written by Alex Dragt, Fall 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension t1a(monoms),t2a(monoms),t3a(monoms),t4a(monoms), - & t5a(monoms) - dimension t1m(6,6),t2m(6,6),t3m(6,6),t4m(6,6),t5m(6,6) - call mapmap(t1a,t1m,t4a,t4m) - call inv(t4a,t4m) - call concat(t1a,t1m,t2a,t2m,t5a,t5m) - call concat(t5a,t5m,t4a,t4m,t3a,t3m) - return - end -c -************************************************************************ - subroutine sndwchi(t1a,t1m,t2a,t2m,t3a,t3m) -c added to liea.f by rdr and ctm on 5/22/02 -cryne 08/17/2001 This version (sndwchi) reverses the order -c -c this is a subroutine for sandwiching a map -c it computes t3=t1*t2*(t1 inverse) -c Written by Alex Dragt, Fall 1986 -c Modified by Alex Dragt, 18 July 1988 -c - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension t1a(monoms),t2a(monoms),t3a(monoms) - dimension t1m(6,6),t2m(6,6),t3m(6,6) -c -c working arrays - dimension ta(monoms) - dimension tm(6,6) -c - call mapmap(t1a,t1m,ta,tm) - call inv(ta,tm) - call concat(ta,tm,t2a,t2m,ta,tm) - call concat(ta,tm,t1a,t1m,t3a,t3m) -c - return - end -c -*********************************************************************** -c - subroutine svpbkt(in,ord,psv,base, pb) -c Single Variable Poisson BracKeT -c Takes the poisson bracket of the order 'ord' part of 'in' with the -c phase space variable represented by 'psv'. The result is left in pb. -c This subroutine replaces DRD's pbkt2 and was written by Liam Healy -c on November 29, 1984 from an idea of Christoph Iselin. -c - use lieaparam, only : monoms -c----Variables---- -c base = lowest index of pb - integer base -c in, pb = incoming array, outgoing pb array - double precision in(*),pb(base:*) -c ord = order of 'in' to be pb-ed - integer ord -c psv,wrt = phase space variable in pb, -c variable to be diff with resp to - integer psv,wrt -c indin,indpb = indeces for 'in' and 'pb' - integer indin,indpb -c sign = multiplier +1 or -1 depending on whether x or p -c differentiating - double precision sign - include 'expon.inc' - include 'lims.inc' -c -c----Routine---- - if (mod(psv,2).eq.1) then -c psv is a coordinate, diff wrt the canonical momentum and flip sign - wrt=psv+1 - sign=-1. - else -c psv is a momentum, diff wrt the canonical coordinate - wrt=psv-1 - sign=+1. - endif - indin=bottom(ord) - do 120 indpb=bottom(ord-1),top(ord-1) - 100 if (expon(wrt,indin).eq.0) then - indin=indin+1 - if (indin.le.top(ord)) goto 100 - return - endif - pb(indpb)=sign*expon(wrt,indin)*in(indin) - 120 indin=indin+1 - return - end -c -*********************************************************************** -c - subroutine xform(in,ord,matrix,matold,out) -c Transforms the order 'ord' part of polynomial represented by array -c 'in' with the matrix 'matrix', and leaves the resulting polynomial -c in the array 'out'. 'matold' should be set >=1 if the -c matrix in the previous call to xform was the same as this call. -c This subroutine replaces DRD's xform and was written by -c Liam Healy on November 30, 1984. -c - use lieaparam, only : monoms -c----Variables---- -c in, out = original polynomial array, transformed polynomial array - double precision in(*),out(*) -c ord = order to be transformed - integer ord -c matrix = matrix that represents the linear transformation -c prod = product, used to accumulate matrix elements - double precision matrix(6,6),prod -c indin, indout = indices for arrays 'in' and 'out' - integer indin,indout -c colme(row,count) = column number of the count-th one - integer colme(6,0:6),size - save colme -c matold = matrix supplied was used in the last call to xform - integer matold -c posn,psv = position in incoming variable list, phase space variable - integer posn,psv -c code = packed information on which combination of matrix elts to -c select -c ncombs = number of different combinations of me's that can be selected -c rem= remainder, gives the code information for the remaining positions - integer code,ncombs,rem -c row, this = row for this position, ordinal of non-zero me at this posn -c col = column - integer row(6),this(6),col - include 'vblist.inc' - include 'prodex.inc' - include 'lims.inc' -c -c rowa, cola = row and column in matrix -c count = ordinal of the non-zero matrix elements for a given row - integer count,rowa,cola -c -c------------------------ -c Find non-zero matrix elements -c Analyzes the matrix to find its non-zero entries, which are -c recorded in the array 'colme' by row number, together with -c the total number of non-zero entries in each row in colme(rowa,0). - if (matold.le.0) then - do 100 rowa=1,6 - count=0 - do 110 cola=1,6 - if(matrix(rowa,cola).ne.0.) then - count=count+1 - colme(rowa,count)=cola - endif - 110 continue - colme(rowa,0)=count - 100 continue - endif -c -c--------------- -c Clear the 'out' array elements of this order - do 80 indout=bottom(ord),top(ord) - 80 out(indout)=0. -c------------------------ -c Cycle through incoming array elements, for each that are non-zero -c Map them to outgoing elements - do 120 indin=bottom(ord),top(ord) - if (in(indin).ne.0.) then - ncombs=1 - do 140 posn=1,ord - row(posn)=vblist(posn,indin) - 140 ncombs=ncombs*colme(row(posn),0) -c------------------------ -c Go through all possible combinations of matrix elements that -c have the correct rows, i.e. corrosponding to the variables in 'indin' -c 'Code' contains packed (by variable base) information on which me to -c select. - do 160 code=0,ncombs-1 - rem=code - prod=1. - indout=0 - do 200 posn=1,ord - size=colme(row(posn),0) - this(posn)=mod(rem,size)+1 - rem=rem/size - col=colme(row(posn),this(posn)) - indout=prodex(col,indout) - prod=prod*matrix(row(posn),col) - 200 continue - out(indout)=out(indout)+in(indin)*prod - 160 continue -c------------------------ - endif - 120 continue - return - end -c -****************************************************************** -c - subroutine xform5(f,no,m,l) -c -c Transforms arguments of the polynomial f of degree no -c by the matrix m. The coefficients of the resultant -c polynomial are stored in the the array l which -c thus contains the coefficients of f(m*z). -c - use lieaparam, only : monoms - include 'impli.inc' - include 'expon.inc' - include 'vblist.inc' - include 'prodex.inc' - include 'len.inc' - include 'ind.inc' -c - double precision l,m,f -cryne 7/23/2002 dimension f(923),l(923) -cryne 7/23/2002 double precision temp(923) -cryne dimension f(monoms),l(monoms),temp(monoms) - dimension f(*),l(*),temp(monoms) - dimension m(6,6) -c -c do 127 my=1,6 -c write(6,*) my, len(my), -c & vblist(my,211), prodex(my,84) -c 127 continue -c return -c -c write(6,*) 'm and f coming into xform5' -c write(6,*) 'with no =',no -c call pcmap(1,1,0,0,f,m) -c -c initialise arrays -c - do 10 kp=1,len(no) - l(kp)=0.0d0 - temp(kp) = 0.0d0 - 10 continue - do 100 n= len(no-1)+1,len(no) - if(f(n).eq.0.0d0) goto 100 - do 101 kp=1,len(no-1) - temp(kp) = 0.0d0 - 101 continue - do 102 k=1,6 - if(m(vblist(1,n),k).eq.0.0d0) goto 102 - temp(k) = f(n)*m(vblist(1,n),k) - 102 continue - do 110 ior=1,no-1 - k1 = vblist(ior+1,n) - if(ior.eq.1) then - n1 = 1 - else - n1=len(ior-1)+1 - endif - do 112 k=1,6 - if(m(k1,k).eq.0.0d0) goto 112 - xm = m(k1,k) -cryne 7/21/01 cdir$ ivdep - do 111 nn=n1,len(ior) - temp(prodex(k,nn)) = temp(prodex(k,nn)) + temp(nn)*xm - 111 continue - 112 continue - 110 continue - 100 continue - do 200 nn=len(no-1)+1,len(no) - l(nn) = l(nn)+temp(nn) - 200 continue -c -c write(6,*) 'm and l coming out of xform5' -c write(6,*) 'with no =',no -c call pcmap(1,1,0,0,l,m) - - return - end -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/liea_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/liea_mod.f90 deleted file mode 100755 index 4a6e1fc..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/liea_mod.f90 +++ /dev/null @@ -1,4 +0,0 @@ -module lieaparam -integer, parameter :: monoms=923,monom1=461,monom2=209 -save -end module lieaparam diff --git a/OpticsJan2020/MLI_light_optics/Src/linpak.f b/OpticsJan2020/MLI_light_optics/Src/linpak.f deleted file mode 100755 index ddfd2b8..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/linpak.f +++ /dev/null @@ -1,1187 +0,0 @@ - SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) -C***BEGIN PROLOGUE DGECO -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2A1 -C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, -C MATRIX -C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -C***PURPOSE Factors a double precision matrix by Gaussian elimination -C and estimates the condition of the matrix. -C***DESCRIPTION -C -C DGECO factors a double precision matrix by Gaussian elimination -C and estimates the condition of the matrix. -C -C If RCOND is not needed, DGEFA is slightly faster. -C To solve A*X = B , follow DGECO by DGESL. -C To compute INVERSE(A)*C , follow DGECO by DGESL. -C To compute DETERMINANT(A) , follow DGECO by DGEDI. -C To compute INVERSE(A) , follow DGECO by DGEDI. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the matrix to be factored. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C A an upper triangular matrix and the multipliers -C which were used to obtain it. -C The factorization can be written A = L*U where -C L is a product of permutation and unit lower -C triangular matrices and U is upper triangular. -C -C IPVT INTEGER(N) -C an INTEGER vector of pivot indices. -C -C RCOND DOUBLE PRECISION -C an estimate of the reciprocal condition of A . -C For the system A*X = B , relative perturbations -C in A and B of size EPSILON may cause -C relative perturbations in X of size EPSILON/RCOND . -C If RCOND is so small that the logical expression -C 1.0 + RCOND .EQ. 1.0 -C is true, then A may be singular to working -C precision. In particular, RCOND is zero if -C exact singularity is detected or the estimate -C underflows. -C -C Z DOUBLE PRECISION(N) -C a work vector whose contents are usually unimportant. -C If A is close to a singular matrix, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C -C LINPACK. This version dated 08/14/78 . -C Cleve Moler, University of New Mexico, Argonne National Lab. -C -C Subroutines and Functions -C -C LINPACK DGEFA -C BLAS DAXPY,DDOT,DSCAL,DASUM -C Fortran DABS,DMAX1,DSIGN -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DASUM,DAXPY,DDOT,DGEFA,DSCAL -C***END PROLOGUE DGECO - INTEGER LDA,N,IPVT(1) - DOUBLE PRECISION A(LDA,1),Z(1) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION DDOT,EK,T,WK,WKM - DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM - INTEGER INFO,J,K,KB,KP1,L -C -C COMPUTE 1-NORM OF A -C -C***FIRST EXECUTABLE STATEMENT DGECO - ANORM = 0.0D0 - DO 10 J = 1, N - ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1)) - 10 CONTINUE -C -C FACTOR -C - CALL DGEFA(A,LDA,N,IPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . -C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE -C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE -C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID -C OVERFLOW. -C -C SOLVE TRANS(U)*W = E -C - EK = 1.0D0 - DO 20 J = 1, N - Z(J) = 0.0D0 - 20 CONTINUE - DO 100 K = 1, N - IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) - IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30 - S = DABS(A(K,K))/DABS(EK-Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = DABS(WK) - SM = DABS(WKM) - IF (A(K,K) .EQ. 0.0D0) GO TO 40 - WK = WK/A(K,K) - WKM = WKM/A(K,K) - GO TO 50 - 40 CONTINUE - WK = 1.0D0 - WKM = 1.0D0 - 50 CONTINUE - KP1 = K + 1 - IF (KP1 .GT. N) GO TO 90 - DO 60 J = KP1, N - SM = SM + DABS(Z(J)+WKM*A(K,J)) - Z(J) = Z(J) + WK*A(K,J) - S = S + DABS(Z(J)) - 60 CONTINUE - IF (S .GE. SM) GO TO 80 - T = WKM - WK - WK = WKM - DO 70 J = KP1, N - Z(J) = Z(J) + T*A(K,J) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - Z(K) = WK - 100 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C -C SOLVE TRANS(L)*Y = W -C - DO 120 KB = 1, N - K = N + 1 - KB - IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) - IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110 - S = 1.0D0/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - 110 CONTINUE - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - 120 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C - YNORM = 1.0D0 -C -C SOLVE L*V = Y -C - DO 140 K = 1, N - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) - IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130 - S = 1.0D0/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 130 CONTINUE - 140 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE U*Z = V -C - DO 160 KB = 1, N - K = N + 1 - KB - IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150 - S = DABS(A(K,K))/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 150 CONTINUE - IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 - T = -Z(K) - CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) - 160 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 - RETURN - END - SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) -C***BEGIN PROLOGUE DGESL -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2A1 -C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE -C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -C***PURPOSE Solves the double precision system A*X=B or TRANS(A)*X=B -C using the factors computed by DGECO or DGEFA. -C***DESCRIPTION -C -C DGESL solves the double precision system -C A * X = B or TRANS(A) * X = B -C using the factors computed by DGECO or DGEFA. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the output from DGECO or DGEFA. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C IPVT INTEGER(N) -C the pivot vector from DGECO or DGEFA. -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -C -C JOB INTEGER -C = 0 to solve A*X = B , -C = nonzero to solve TRANS(A)*X = B where -C TRANS(A) is the transpose. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero will occur if the input factor contains a -C zero on the diagonal. Technically this indicates singularity -C but it is often caused by improper arguments or improper -C setting of LDA . It will not occur if the subroutines are -C called correctly and if DGECO has set RCOND .GT. 0.0 -C or DGEFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) -C IF (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) -C 10 CONTINUE -C -C LINPACK. This version dated 08/14/78 . -C Cleve Moler, University of New Mexico, Argonne National Lab. -C -C Subroutines and Functions -C -C BLAS DAXPY,DDOT -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DAXPY,DDOT -C***END PROLOGUE DGESL - INTEGER LDA,N,IPVT(1),JOB - DOUBLE PRECISION A(LDA,1),B(1) -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,NM1 -C***FIRST EXECUTABLE STATEMENT DGESL - NM1 = N - 1 - IF (JOB .NE. 0) GO TO 50 -C -C JOB = 0 , SOLVE A * X = B -C FIRST SOLVE L*Y = B -C - IF (NM1 .LT. 1) GO TO 30 - DO 20 K = 1, NM1 - L = IPVT(K) - T = B(L) - IF (L .EQ. K) GO TO 10 - B(L) = B(K) - B(K) = T - 10 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) - 20 CONTINUE - 30 CONTINUE -C -C NOW SOLVE U*X = Y -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/A(K,K) - T = -B(K) - CALL DAXPY(K-1,T,A(1,K),1,B(1),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, SOLVE TRANS(A) * X = B -C FIRST SOLVE TRANS(U)*Y = B -C - DO 60 K = 1, N - T = DDOT(K-1,A(1,K),1,B(1),1) - B(K) = (B(K) - T)/A(K,K) - 60 CONTINUE -C -C NOW SOLVE TRANS(L)*X = Y -C - IF (NM1 .LT. 1) GO TO 90 - DO 80 KB = 1, NM1 - K = N - KB - B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) - L = IPVT(K) - IF (L .EQ. K) GO TO 70 - T = B(L) - B(L) = B(K) - B(K) = T - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - RETURN - END - SUBROUTINE DSICO(A,LDA,N,KPVT,RCOND,Z) -C***BEGIN PROLOGUE DSICO -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2B1A -C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, -C MATRIX,SYMMETRIC -C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -C***PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with symmet- -C ric pivoting and estimates the condition of the matrix. -C***DESCRIPTION -C -C DSICO factors a double precision symmetric matrix by elimination -C with symmetric pivoting and estimates the condition of the -C matrix. -C -C If RCOND is not needed, DSIFA is slightly faster. -C To solve A*X = B , follow DSICO by DSISL. -C To compute INVERSE(A)*C , follow DSICO by DSISL. -C To compute INVERSE(A) , follow DSICO by DSIDI. -C To compute DETERMINANT(A) , follow DSICO by DSIDI. -C To compute INERTIA(A), follow DSICO by DSIDI. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the symmetric matrix to be factored. -C Only the diagonal and upper triangle are used. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C Output -C -C A a block diagonal matrix and the multipliers which -C were used to obtain it. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices, TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KPVT INTEGER(N) -C an integer vector of pivot indices. -C -C RCOND DOUBLE PRECISION -C an estimate of the reciprocal condition of A . -C For the system A*X = B , relative perturbations -C in A and B of size EPSILON may cause -C relative perturbations in X of size EPSILON/RCOND . -C If RCOND is so small that the logical expression -C 1.0 + RCOND .EQ. 1.0 -C is true, then A may be singular to working -C precision. In particular, RCOND is zero if -C exact singularity is detected or the estimate -C underflows. -C -C Z DOUBLE PRECISION(N) -C a work vector whose contents are usually unimportant. -C If A is close to a singular matrix, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C -C LINPACK. This version dated 08/14/78 . -C Cleve Moler, University of New Mexico, Argonne National Lab. -C -C Subroutines and Functions -C -C LINPACK DSIFA -C BLAS DAXPY,DDOT,DSCAL,DASUM -C Fortran DABS,DMAX1,IABS,DSIGN -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DASUM,DAXPY,DDOT,DSCAL,DSIFA -C***END PROLOGUE DSICO - INTEGER LDA,N,KPVT(1) - DOUBLE PRECISION A(LDA,1),Z(1) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T - DOUBLE PRECISION ANORM,S,DASUM,YNORM - INTEGER I,INFO,J,JM1,K,KP,KPS,KS -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT DSICO - DO 30 J = 1, N - Z(J) = DASUM(J,A(1,J),1) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = Z(I) + DABS(A(I,J)) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0D0 - DO 40 J = 1, N - ANORM = DMAX1(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL DSIFA(A,LDA,N,KPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE U*D*W = E -C - EK = 1.0D0 - DO 50 J = 1, N - Z(J) = 0.0D0 - 50 CONTINUE - K = N - 60 IF (K .EQ. 0) GO TO 120 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - KP = IABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 70 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 70 CONTINUE - IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,Z(K)) - Z(K) = Z(K) + EK - CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 1) GO TO 80 - IF (Z(K-1) .NE. 0.0D0) EK = DSIGN(EK,Z(K-1)) - Z(K-1) = Z(K-1) + EK - CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 80 CONTINUE - IF (KS .EQ. 2) GO TO 100 - IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 90 - S = DABS(A(K,K))/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 90 CONTINUE - IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 - GO TO 110 - 100 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 110 CONTINUE - K = K - KS - GO TO 60 - 120 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C -C SOLVE TRANS(U)*Y = W -C - K = 1 - 130 IF (K .GT. N) GO TO 160 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 150 - Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) - KP = IABS(KPVT(K)) - IF (KP .EQ. K) GO TO 140 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 140 CONTINUE - 150 CONTINUE - K = K + KS - GO TO 130 - 160 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C - YNORM = 1.0D0 -C -C SOLVE U*D*V = Y -C - K = N - 170 IF (K .EQ. 0) GO TO 230 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. KS) GO TO 190 - KP = IABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 180 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 180 CONTINUE - CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 190 CONTINUE - IF (KS .EQ. 2) GO TO 210 - IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 200 - S = DABS(A(K,K))/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 200 CONTINUE - IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 - GO TO 220 - 210 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 220 CONTINUE - K = K - KS - GO TO 170 - 230 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE TRANS(U)*Z = V -C - K = 1 - 240 IF (K .GT. N) GO TO 270 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 260 - Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) - KP = IABS(KPVT(K)) - IF (KP .EQ. K) GO TO 250 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 250 CONTINUE - 260 CONTINUE - K = K + KS - GO TO 240 - 270 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 - RETURN - END - SUBROUTINE DSISL(A,LDA,N,KPVT,B) -C***BEGIN PROLOGUE DSISL -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2B1A -C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, -C SYMMETRIC -C***AUTHOR BUNCH, J., (UCSD) -C***PURPOSE Solves the double precision SYMMETRIC system -C A*X=B using the factors computed by DSIFA. -C***DESCRIPTION -C -C DSISL solves the double precision symmetric system -C A * X = B -C using the factors computed by DSIFA. -C -C On Entry -C -C A DOUBLE PRECISION(LDA,N) -C the output from DSIFA. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C KPVT INTEGER(N) -C the pivot vector from DSIFA. -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero may occur if DSICO has set RCOND .EQ. 0.0 -C or DSIFA has set INFO .NE. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DSIFA(A,LDA,N,KPVT,INFO) -C IF (INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL DSISL(A,LDA,N,KPVT,C(1,J)) -C 10 CONTINUE -C -C LINPACK. This version dated 08/14/78 . -C James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. -C -C Subroutines and Functions -C -C BLAS DAXPY,DDOT -C Fortran IABS -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DAXPY,DDOT -C***END PROLOGUE DSISL - INTEGER LDA,N,KPVT(1) - DOUBLE PRECISION A(LDA,1),B(1) -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP - INTEGER K,KP -C -C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND -C D INVERSE TO B. -C -C***FIRST EXECUTABLE STATEMENT DSISL - K = N - 10 IF (K .EQ. 0) GO TO 80 - IF (KPVT(K) .LT. 0) GO TO 40 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 30 - KP = KPVT(K) - IF (KP .EQ. K) GO TO 20 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 20 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL DAXPY(K-1,B(K),A(1,K),1,B(1),1) - 30 CONTINUE -C -C APPLY D INVERSE. -C - B(K) = B(K)/A(K,K) - K = K - 1 - GO TO 70 - 40 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 2) GO TO 60 - KP = IABS(KPVT(K)) - IF (KP .EQ. K - 1) GO TO 50 -C -C INTERCHANGE. -C - TEMP = B(K-1) - B(K-1) = B(KP) - B(KP) = TEMP - 50 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL DAXPY(K-2,B(K),A(1,K),1,B(1),1) - CALL DAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) - 60 CONTINUE -C -C APPLY D INVERSE. -C - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = B(K)/A(K-1,K) - BKM1 = B(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - B(K) = (AKM1*BK - BKM1)/DENOM - B(K-1) = (AK*BKM1 - BK)/DENOM - K = K - 2 - 70 CONTINUE - GO TO 10 - 80 CONTINUE -C -C LOOP FORWARD APPLYING THE TRANSFORMATIONS. -C - K = 1 - 90 IF (K .GT. N) GO TO 160 - IF (KPVT(K) .LT. 0) GO TO 120 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 110 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) - KP = KPVT(K) - IF (KP .EQ. K) GO TO 100 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 100 CONTINUE - 110 CONTINUE - K = K + 1 - GO TO 150 - 120 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 140 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) - B(K+1) = B(K+1) + DDOT(K-1,A(1,K+1),1,B(1),1) - KP = IABS(KPVT(K)) - IF (KP .EQ. K) GO TO 130 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 130 CONTINUE - 140 CONTINUE - K = K + 2 - 150 CONTINUE - GO TO 90 - 160 CONTINUE - RETURN - END - SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) -****BEGIN PROLOGUE DGEFA -****DATE WRITTEN 780814 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D2A1 -****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX -****AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -****PURPOSE Factors a double precision matrix by Gaussian elimination. -****DESCRIPTION -* -* DGEFA factors a double precision matrix by Gaussian elimination. -* -* DGEFA is usually called by DGECO, but it can be called -* directly with a saving in time if RCOND is not needed. -* (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . -* -* On Entry -* -* A DOUBLE PRECISION(LDA, N) -* the matrix to be factored. -* -* LDA INTEGER -* the leading dimension of the array A . -* -* N INTEGER -* the order of the matrix A . -* -* On Return -* -* A an upper triangular matrix and the multipliers -* which were used to obtain it. -* The factorization can be written A = L*U where -* L is a product of permutation and unit lower -* triangular matrices and U is upper triangular. -* -* IPVT INTEGER(N) -* an integer vector of pivot indices. -* -* INFO INTEGER -* = 0 normal value. -* = K if U(K,K) .EQ. 0.0 . This is not an error -* condition for this subroutine, but it does -* indicate that DGESL or DGEDI will divide by zero -* if called. Use RCOND in DGECO for a reliable -* indication of singularity. -* -* LINPACK. This version dated 08/14/78 . -* Cleve Moler, University of New Mexico, Argonne National Lab. -* -* Subroutines and Functions -* -* BLAS DAXPY,DSCAL,IDAMAX -****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -* *LINPACK USERS GUIDE*, SIAM, 1979. -****ROUTINES CALLED DAXPY,DSCAL,IDAMAX -****END PROLOGUE DGEFA - INTEGER LDA,N,IPVT(1),INFO - DOUBLE PRECISION A(LDA,1) -* - DOUBLE PRECISION T - INTEGER IDAMAX,J,K,KP1,L,NM1 -* -* GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -* -****FIRST EXECUTABLE STATEMENT DGEFA - INFO = 0 - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 70 - DO 60 K = 1, NM1 - KP1 = K + 1 -* -* FIND L = PIVOT INDEX -* - L = IDAMAX(N-K+1,A(K,K),1) + K - 1 - IPVT(K) = L -* -* ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -* - IF (A(L,K) .EQ. 0.0D0) GO TO 40 -* -* INTERCHANGE IF NECESSARY -* - IF (L .EQ. K) GO TO 10 - T = A(L,K) - A(L,K) = A(K,K) - A(K,K) = T - 10 CONTINUE -* -* COMPUTE MULTIPLIERS -* - T = -1.0D0/A(K,K) - CALL DSCAL(N-K,T,A(K+1,K),1) -* -* ROW ELIMINATION WITH COLUMN INDEXING -* - DO 30 J = KP1, N - T = A(L,J) - IF (L .EQ. K) GO TO 20 - A(L,J) = A(K,J) - A(K,J) = T - 20 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) - 30 CONTINUE - GO TO 50 - 40 CONTINUE - INFO = K - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - IPVT(N) = N - IF (A(N,N) .EQ. 0.0D0) INFO = N - RETURN - END - SUBROUTINE DSIFA(A,LDA,N,KPVT,INFO) -****BEGIN PROLOGUE DSIFA -****DATE WRITTEN 780814 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D2B1A -****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX, -* SYMMETRIC -****AUTHOR BUNCH, J., (UCSD) -****PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with -* symmetric pivoting -****DESCRIPTION -* -* DSIFA factors a double precision symmetric matrix by elimination -* with symmetric pivoting. -* -* To solve A*X = B , follow DSIFA by DSISL. -* To compute INVERSE(A)*C , follow DSIFA by DSISL. -* To compute DETERMINANT(A) , follow DSIFA by DSIDI. -* To compute INERTIA(A) , follow DSIFA by DSIDI. -* To compute INVERSE(A) , follow DSIFA by DSIDI. -* -* On Entry -* -* A DOUBLE PRECISION(LDA,N) -* the symmetric matrix to be factored. -* Only the diagonal and upper triangle are used. -* -* LDA INTEGER -* the leading dimension of the array A . -* -* N INTEGER -* the order of the matrix A . -* -* On Return -* -* A a block diagonal matrix and the multipliers which -* were used to obtain it. -* The factorization can be written A = U*D*TRANS(U) -* where U is a product of permutation and unit -* upper triangular matrices, TRANS(U) is the -* transpose of U , and D is block diagonal -* with 1 by 1 and 2 by 2 blocks. -* -* KPVT INTEGER(N) -* an integer vector of pivot indices. -* -* INFO INTEGER -* = 0 normal value. -* = K if the K-th pivot block is singular. This is -* not an error condition for this subroutine, -* but it does indicate that DSISL or DSIDI may -* divide by zero if called. -* -* LINPACK. This version dated 08/14/78 . -* James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. -* -* Subroutines and Functions -* -* BLAS DAXPY,DSWAP,IDAMAX -* Fortran DABS,DMAX1,DSQRT -****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -* *LINPACK USERS GUIDE*, SIAM, 1979. -****ROUTINES CALLED DAXPY,DSWAP,IDAMAX -****END PROLOGUE DSIFA - INTEGER LDA,N,KPVT(1),INFO - DOUBLE PRECISION A(LDA,1) -* - DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T - DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX - INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,IDAMAX - LOGICAL SWAP -* -* INITIALIZE -* -* ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. -****FIRST EXECUTABLE STATEMENT DSIFA - ALPHA = (1.0D0 + DSQRT(17.0D0))/8.0D0 -* - INFO = 0 -* -* MAIN LOOP ON K, WHICH GOES FROM N TO 1. -* - K = N - 10 CONTINUE -* -* LEAVE THE LOOP IF K=0 OR K=1. -* -* ...EXIT - IF (K .EQ. 0) GO TO 200 - IF (K .GT. 1) GO TO 20 - KPVT(1) = 1 - IF (A(1,1) .EQ. 0.0D0) INFO = 1 -* ......EXIT - GO TO 200 - 20 CONTINUE -* -* THIS SECTION OF CODE DETERMINES THE KIND OF -* ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, -* KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND -* SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS -* REQUIRED. -* - KM1 = K - 1 - ABSAKK = DABS(A(K,K)) -* -* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -* COLUMN K. -* - IMAX = IDAMAX(K-1,A(1,K),1) - COLMAX = DABS(A(IMAX,K)) - IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 - KSTEP = 1 - SWAP = .FALSE. - GO TO 90 - 30 CONTINUE -* -* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -* ROW IMAX. -* - ROWMAX = 0.0D0 - IMAXP1 = IMAX + 1 - DO 40 J = IMAXP1, K - ROWMAX = DMAX1(ROWMAX,DABS(A(IMAX,J))) - 40 CONTINUE - IF (IMAX .EQ. 1) GO TO 50 - JMAX = IDAMAX(IMAX-1,A(1,IMAX),1) - ROWMAX = DMAX1(ROWMAX,DABS(A(JMAX,IMAX))) - 50 CONTINUE - IF (DABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 - KSTEP = 1 - SWAP = .TRUE. - GO TO 80 - 60 CONTINUE - IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 - KSTEP = 1 - SWAP = .FALSE. - GO TO 80 - 70 CONTINUE - KSTEP = 2 - SWAP = IMAX .NE. KM1 - 80 CONTINUE - 90 CONTINUE - IF (DMAX1(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100 -* -* COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. -* - KPVT(K) = K - INFO = K - GO TO 190 - 100 CONTINUE - IF (KSTEP .EQ. 2) GO TO 140 -* -* 1 X 1 PIVOT BLOCK. -* - IF (.NOT.SWAP) GO TO 120 -* -* PERFORM AN INTERCHANGE. -* - CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K),1) - DO 110 JJ = IMAX, K - J = K + IMAX - JJ - T = A(J,K) - A(J,K) = A(IMAX,J) - A(IMAX,J) = T - 110 CONTINUE - 120 CONTINUE -* -* PERFORM THE ELIMINATION. -* - DO 130 JJ = 1, KM1 - J = K - JJ - MULK = -A(J,K)/A(K,K) - T = MULK - CALL DAXPY(J,T,A(1,K),1,A(1,J),1) - A(J,K) = MULK - 130 CONTINUE -* -* SET THE PIVOT ARRAY. -* - KPVT(K) = K - IF (SWAP) KPVT(K) = IMAX - GO TO 190 - 140 CONTINUE -* -* 2 X 2 PIVOT BLOCK. -* - IF (.NOT.SWAP) GO TO 160 -* -* PERFORM AN INTERCHANGE. -* - CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) - DO 150 JJ = IMAX, KM1 - J = KM1 + IMAX - JJ - T = A(J,K-1) - A(J,K-1) = A(IMAX,J) - A(IMAX,J) = T - 150 CONTINUE - T = A(K-1,K) - A(K-1,K) = A(IMAX,K) - A(IMAX,K) = T - 160 CONTINUE -* -* PERFORM THE ELIMINATION. -* - KM2 = K - 2 - IF (KM2 .EQ. 0) GO TO 180 - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - DENOM = 1.0D0 - AK*AKM1 - DO 170 JJ = 1, KM2 - J = KM1 - JJ - BK = A(J,K)/A(K-1,K) - BKM1 = A(J,K-1)/A(K-1,K) - MULK = (AKM1*BK - BKM1)/DENOM - MULKM1 = (AK*BKM1 - BK)/DENOM - T = MULK - CALL DAXPY(J,T,A(1,K),1,A(1,J),1) - T = MULKM1 - CALL DAXPY(J,T,A(1,K-1),1,A(1,J),1) - A(J,K) = MULK - A(J,K-1) = MULKM1 - 170 CONTINUE - 180 CONTINUE -* -* SET THE PIVOT ARRAY. -* - KPVT(K) = 1 - K - IF (SWAP) KPVT(K) = -IMAX - KPVT(K-1) = KPVT(K) - 190 CONTINUE - K = K - KSTEP - GO TO 10 - 200 CONTINUE - RETURN - END - DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) - implicit double precision (a-h, o-z) - INTEGER NEXT - DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE - DATA ZERO, ONE /0.0D0, 1.0D0/ -C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE -C INCREMENT INCX . -C C.L.LAWSON, 1978 JAN 08 - DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / - IF(N .GT. 0) GO TO 10 - DNRM2 = ZERO - GO TO 300 - 10 ASSIGN 30 TO NEXT - SUM = ZERO - NN = N * INCX -C BEGIN MAIN LOOP - I = 1 - 20 GO TO NEXT,(30, 50, 70, 110) - 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 - ASSIGN 50 TO NEXT - XMAX = ZERO -C PHASE 1. SUM IS ZERO - 50 IF( DX(I) .EQ. ZERO) GO TO 200 - IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 -C PREPARE FOR PHASE 2. - ASSIGN 70 TO NEXT - GO TO 105 -C PREPARE FOR PHASE 4. - 100 I = J - ASSIGN 110 TO NEXT - SUM = (SUM / DX(I)) / DX(I) - 105 XMAX = DABS(DX(I)) - GO TO 115 -C PHASE 2. SUM IS SMALL. -C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. - 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 -C COMMON CODE FOR PHASES 2 AND 4. -C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. - 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 - SUM = ONE + SUM * (XMAX / DX(I))**2 - XMAX = DABS(DX(I)) - GO TO 200 - 115 SUM = SUM + (DX(I)/XMAX)**2 - GO TO 200 -C PREPARE FOR PHASE 3. - 75 SUM = (SUM * XMAX) * XMAX -C FOR REAL OR D.P. SET HITEST = CUTHI/N -C FOR COMPLEX SET HITEST = CUTHI/(2*N) - 85 HITEST = CUTHI/FLOAT( N ) -C PHASE 3. SUM IS MID-RANGE. NO SCALING. - DO 95 J =I,NN,INCX - IF(DABS(DX(J)) .GE. HITEST) GO TO 100 - 95 SUM = SUM + DX(J)**2 - DNRM2 = DSQRT( SUM ) - GO TO 300 - 200 CONTINUE - I = I + INCX - IF ( I .LE. NN ) GO TO 20 -C END OF MAIN LOOP. -C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. - DNRM2 = XMAX * DSQRT(SUM) - 300 CONTINUE - RETURN - END diff --git a/OpticsJan2020/MLI_light_optics/Src/linpak_all.f b/OpticsJan2020/MLI_light_optics/Src/linpak_all.f deleted file mode 100755 index 346369d..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/linpak_all.f +++ /dev/null @@ -1,1615 +0,0 @@ - SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) -C***BEGIN PROLOGUE DGECO -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2A1 -C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, -C MATRIX -C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -C***PURPOSE Factors a double precision matrix by Gaussian elimination -C and estimates the condition of the matrix. -C***DESCRIPTION -C -C DGECO factors a double precision matrix by Gaussian elimination -C and estimates the condition of the matrix. -C -C If RCOND is not needed, DGEFA is slightly faster. -C To solve A*X = B , follow DGECO by DGESL. -C To compute INVERSE(A)*C , follow DGECO by DGESL. -C To compute DETERMINANT(A) , follow DGECO by DGEDI. -C To compute INVERSE(A) , follow DGECO by DGEDI. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the matrix to be factored. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C A an upper triangular matrix and the multipliers -C which were used to obtain it. -C The factorization can be written A = L*U where -C L is a product of permutation and unit lower -C triangular matrices and U is upper triangular. -C -C IPVT INTEGER(N) -C an INTEGER vector of pivot indices. -C -C RCOND DOUBLE PRECISION -C an estimate of the reciprocal condition of A . -C For the system A*X = B , relative perturbations -C in A and B of size EPSILON may cause -C relative perturbations in X of size EPSILON/RCOND . -C If RCOND is so small that the logical expression -C 1.0 + RCOND .EQ. 1.0 -C is true, then A may be singular to working -C precision. In particular, RCOND is zero if -C exact singularity is detected or the estimate -C underflows. -C -C Z DOUBLE PRECISION(N) -C a work vector whose contents are usually unimportant. -C If A is close to a singular matrix, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C -C LINPACK. This version dated 08/14/78 . -C Cleve Moler, University of New Mexico, Argonne National Lab. -C -C Subroutines and Functions -C -C LINPACK DGEFA -C BLAS DAXPY,DDOT,DSCAL,DASUM -C Fortran DABS,DMAX1,DSIGN -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DASUM,DAXPY,DDOT,DGEFA,DSCAL -C***END PROLOGUE DGECO - INTEGER LDA,N,IPVT(1) - DOUBLE PRECISION A(LDA,1),Z(1) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION DDOT,EK,T,WK,WKM - DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM - INTEGER INFO,J,K,KB,KP1,L -C -C COMPUTE 1-NORM OF A -C -C***FIRST EXECUTABLE STATEMENT DGECO - ANORM = 0.0D0 - DO 10 J = 1, N - ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1)) - 10 CONTINUE -C -C FACTOR -C - CALL DGEFA(A,LDA,N,IPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . -C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE -C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE -C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID -C OVERFLOW. -C -C SOLVE TRANS(U)*W = E -C - EK = 1.0D0 - DO 20 J = 1, N - Z(J) = 0.0D0 - 20 CONTINUE - DO 100 K = 1, N - IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) - IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30 - S = DABS(A(K,K))/DABS(EK-Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = DABS(WK) - SM = DABS(WKM) - IF (A(K,K) .EQ. 0.0D0) GO TO 40 - WK = WK/A(K,K) - WKM = WKM/A(K,K) - GO TO 50 - 40 CONTINUE - WK = 1.0D0 - WKM = 1.0D0 - 50 CONTINUE - KP1 = K + 1 - IF (KP1 .GT. N) GO TO 90 - DO 60 J = KP1, N - SM = SM + DABS(Z(J)+WKM*A(K,J)) - Z(J) = Z(J) + WK*A(K,J) - S = S + DABS(Z(J)) - 60 CONTINUE - IF (S .GE. SM) GO TO 80 - T = WKM - WK - WK = WKM - DO 70 J = KP1, N - Z(J) = Z(J) + T*A(K,J) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - Z(K) = WK - 100 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C -C SOLVE TRANS(L)*Y = W -C - DO 120 KB = 1, N - K = N + 1 - KB - IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) - IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110 - S = 1.0D0/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - 110 CONTINUE - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - 120 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C - YNORM = 1.0D0 -C -C SOLVE L*V = Y -C - DO 140 K = 1, N - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) - IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130 - S = 1.0D0/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 130 CONTINUE - 140 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE U*Z = V -C - DO 160 KB = 1, N - K = N + 1 - KB - IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150 - S = DABS(A(K,K))/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 150 CONTINUE - IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 - T = -Z(K) - CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) - 160 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 - RETURN - END - SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) -C***BEGIN PROLOGUE DGESL -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2A1 -C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE -C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -C***PURPOSE Solves the double precision system A*X=B or TRANS(A)*X=B -C using the factors computed by DGECO or DGEFA. -C***DESCRIPTION -C -C DGESL solves the double precision system -C A * X = B or TRANS(A) * X = B -C using the factors computed by DGECO or DGEFA. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the output from DGECO or DGEFA. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C IPVT INTEGER(N) -C the pivot vector from DGECO or DGEFA. -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -C -C JOB INTEGER -C = 0 to solve A*X = B , -C = nonzero to solve TRANS(A)*X = B where -C TRANS(A) is the transpose. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero will occur if the input factor contains a -C zero on the diagonal. Technically this indicates singularity -C but it is often caused by improper arguments or improper -C setting of LDA . It will not occur if the subroutines are -C called correctly and if DGECO has set RCOND .GT. 0.0 -C or DGEFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) -C IF (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) -C 10 CONTINUE -C -C LINPACK. This version dated 08/14/78 . -C Cleve Moler, University of New Mexico, Argonne National Lab. -C -C Subroutines and Functions -C -C BLAS DAXPY,DDOT -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DAXPY,DDOT -C***END PROLOGUE DGESL - INTEGER LDA,N,IPVT(1),JOB - DOUBLE PRECISION A(LDA,1),B(1) -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,NM1 -C***FIRST EXECUTABLE STATEMENT DGESL - NM1 = N - 1 - IF (JOB .NE. 0) GO TO 50 -C -C JOB = 0 , SOLVE A * X = B -C FIRST SOLVE L*Y = B -C - IF (NM1 .LT. 1) GO TO 30 - DO 20 K = 1, NM1 - L = IPVT(K) - T = B(L) - IF (L .EQ. K) GO TO 10 - B(L) = B(K) - B(K) = T - 10 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) - 20 CONTINUE - 30 CONTINUE -C -C NOW SOLVE U*X = Y -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/A(K,K) - T = -B(K) - CALL DAXPY(K-1,T,A(1,K),1,B(1),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, SOLVE TRANS(A) * X = B -C FIRST SOLVE TRANS(U)*Y = B -C - DO 60 K = 1, N - T = DDOT(K-1,A(1,K),1,B(1),1) - B(K) = (B(K) - T)/A(K,K) - 60 CONTINUE -C -C NOW SOLVE TRANS(L)*X = Y -C - IF (NM1 .LT. 1) GO TO 90 - DO 80 KB = 1, NM1 - K = N - KB - B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) - L = IPVT(K) - IF (L .EQ. K) GO TO 70 - T = B(L) - B(L) = B(K) - B(K) = T - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - RETURN - END - SUBROUTINE DSICO(A,LDA,N,KPVT,RCOND,Z) -C***BEGIN PROLOGUE DSICO -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2B1A -C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, -C MATRIX,SYMMETRIC -C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -C***PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with symmet- -C ric pivoting and estimates the condition of the matrix. -C***DESCRIPTION -C -C DSICO factors a double precision symmetric matrix by elimination -C with symmetric pivoting and estimates the condition of the -C matrix. -C -C If RCOND is not needed, DSIFA is slightly faster. -C To solve A*X = B , follow DSICO by DSISL. -C To compute INVERSE(A)*C , follow DSICO by DSISL. -C To compute INVERSE(A) , follow DSICO by DSIDI. -C To compute DETERMINANT(A) , follow DSICO by DSIDI. -C To compute INERTIA(A), follow DSICO by DSIDI. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the symmetric matrix to be factored. -C Only the diagonal and upper triangle are used. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C Output -C -C A a block diagonal matrix and the multipliers which -C were used to obtain it. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices, TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KPVT INTEGER(N) -C an integer vector of pivot indices. -C -C RCOND DOUBLE PRECISION -C an estimate of the reciprocal condition of A . -C For the system A*X = B , relative perturbations -C in A and B of size EPSILON may cause -C relative perturbations in X of size EPSILON/RCOND . -C If RCOND is so small that the logical expression -C 1.0 + RCOND .EQ. 1.0 -C is true, then A may be singular to working -C precision. In particular, RCOND is zero if -C exact singularity is detected or the estimate -C underflows. -C -C Z DOUBLE PRECISION(N) -C a work vector whose contents are usually unimportant. -C If A is close to a singular matrix, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C -C LINPACK. This version dated 08/14/78 . -C Cleve Moler, University of New Mexico, Argonne National Lab. -C -C Subroutines and Functions -C -C LINPACK DSIFA -C BLAS DAXPY,DDOT,DSCAL,DASUM -C Fortran DABS,DMAX1,IABS,DSIGN -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DASUM,DAXPY,DDOT,DSCAL,DSIFA -C***END PROLOGUE DSICO - INTEGER LDA,N,KPVT(1) - DOUBLE PRECISION A(LDA,1),Z(1) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T - DOUBLE PRECISION ANORM,S,DASUM,YNORM - INTEGER I,INFO,J,JM1,K,KP,KPS,KS -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT DSICO - DO 30 J = 1, N - Z(J) = DASUM(J,A(1,J),1) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = Z(I) + DABS(A(I,J)) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0D0 - DO 40 J = 1, N - ANORM = DMAX1(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL DSIFA(A,LDA,N,KPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE U*D*W = E -C - EK = 1.0D0 - DO 50 J = 1, N - Z(J) = 0.0D0 - 50 CONTINUE - K = N - 60 IF (K .EQ. 0) GO TO 120 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - KP = IABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 70 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 70 CONTINUE - IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,Z(K)) - Z(K) = Z(K) + EK - CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 1) GO TO 80 - IF (Z(K-1) .NE. 0.0D0) EK = DSIGN(EK,Z(K-1)) - Z(K-1) = Z(K-1) + EK - CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 80 CONTINUE - IF (KS .EQ. 2) GO TO 100 - IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 90 - S = DABS(A(K,K))/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 90 CONTINUE - IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 - GO TO 110 - 100 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 110 CONTINUE - K = K - KS - GO TO 60 - 120 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C -C SOLVE TRANS(U)*Y = W -C - K = 1 - 130 IF (K .GT. N) GO TO 160 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 150 - Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) - KP = IABS(KPVT(K)) - IF (KP .EQ. K) GO TO 140 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 140 CONTINUE - 150 CONTINUE - K = K + KS - GO TO 130 - 160 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C - YNORM = 1.0D0 -C -C SOLVE U*D*V = Y -C - K = N - 170 IF (K .EQ. 0) GO TO 230 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. KS) GO TO 190 - KP = IABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 180 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 180 CONTINUE - CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 190 CONTINUE - IF (KS .EQ. 2) GO TO 210 - IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 200 - S = DABS(A(K,K))/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 200 CONTINUE - IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 - GO TO 220 - 210 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 220 CONTINUE - K = K - KS - GO TO 170 - 230 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE TRANS(U)*Z = V -C - K = 1 - 240 IF (K .GT. N) GO TO 270 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 260 - Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) - KP = IABS(KPVT(K)) - IF (KP .EQ. K) GO TO 250 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 250 CONTINUE - 260 CONTINUE - K = K + KS - GO TO 240 - 270 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 - RETURN - END - SUBROUTINE DSISL(A,LDA,N,KPVT,B) -C***BEGIN PROLOGUE DSISL -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2B1A -C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, -C SYMMETRIC -C***AUTHOR BUNCH, J., (UCSD) -C***PURPOSE Solves the double precision SYMMETRIC system -C A*X=B using the factors computed by DSIFA. -C***DESCRIPTION -C -C DSISL solves the double precision symmetric system -C A * X = B -C using the factors computed by DSIFA. -C -C On Entry -C -C A DOUBLE PRECISION(LDA,N) -C the output from DSIFA. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C KPVT INTEGER(N) -C the pivot vector from DSIFA. -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero may occur if DSICO has set RCOND .EQ. 0.0 -C or DSIFA has set INFO .NE. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DSIFA(A,LDA,N,KPVT,INFO) -C IF (INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL DSISL(A,LDA,N,KPVT,C(1,J)) -C 10 CONTINUE -C -C LINPACK. This version dated 08/14/78 . -C James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. -C -C Subroutines and Functions -C -C BLAS DAXPY,DDOT -C Fortran IABS -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DAXPY,DDOT -C***END PROLOGUE DSISL - INTEGER LDA,N,KPVT(1) - DOUBLE PRECISION A(LDA,1),B(1) -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP - INTEGER K,KP -C -C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND -C D INVERSE TO B. -C -C***FIRST EXECUTABLE STATEMENT DSISL - K = N - 10 IF (K .EQ. 0) GO TO 80 - IF (KPVT(K) .LT. 0) GO TO 40 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 30 - KP = KPVT(K) - IF (KP .EQ. K) GO TO 20 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 20 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL DAXPY(K-1,B(K),A(1,K),1,B(1),1) - 30 CONTINUE -C -C APPLY D INVERSE. -C - B(K) = B(K)/A(K,K) - K = K - 1 - GO TO 70 - 40 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 2) GO TO 60 - KP = IABS(KPVT(K)) - IF (KP .EQ. K - 1) GO TO 50 -C -C INTERCHANGE. -C - TEMP = B(K-1) - B(K-1) = B(KP) - B(KP) = TEMP - 50 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL DAXPY(K-2,B(K),A(1,K),1,B(1),1) - CALL DAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) - 60 CONTINUE -C -C APPLY D INVERSE. -C - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = B(K)/A(K-1,K) - BKM1 = B(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - B(K) = (AKM1*BK - BKM1)/DENOM - B(K-1) = (AK*BKM1 - BK)/DENOM - K = K - 2 - 70 CONTINUE - GO TO 10 - 80 CONTINUE -C -C LOOP FORWARD APPLYING THE TRANSFORMATIONS. -C - K = 1 - 90 IF (K .GT. N) GO TO 160 - IF (KPVT(K) .LT. 0) GO TO 120 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 110 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) - KP = KPVT(K) - IF (KP .EQ. K) GO TO 100 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 100 CONTINUE - 110 CONTINUE - K = K + 1 - GO TO 150 - 120 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 140 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) - B(K+1) = B(K+1) + DDOT(K-1,A(1,K+1),1,B(1),1) - KP = IABS(KPVT(K)) - IF (KP .EQ. K) GO TO 130 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 130 CONTINUE - 140 CONTINUE - K = K + 2 - 150 CONTINUE - GO TO 90 - 160 CONTINUE - RETURN - END - SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -****BEGIN PROLOGUE DSWAP -****DATE WRITTEN 791001 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D1A5 -****KEYWORDS BLAS,DOUBLE PRECISION,INTERCHANGE,LINEAR ALGEBRA,VECTOR -****AUTHOR LAWSON, C. L., (JPL) -* HANSON, R. J., (SNLA) -* KINCAID, D. R., (U. OF TEXAS) -* KROGH, F. T., (JPL) -****PURPOSE Interchange d.p. vectors -****DESCRIPTION -* -* B L A S Subprogram -* Description of Parameters -* -* --Input-- -* N number of elements in input vector(s) -* DX double precision vector with N elements -* INCX storage spacing between elements of DX -* DY double precision vector with N elements -* INCY storage spacing between elements of DY -* -* --Output-- -* DX input vector DY (unchanged if N .LE. 0) -* DY input vector DX (unchanged if N .LE. 0) -* -* Interchange double precision DX and double precision DY. -* For I = 0 to N-1, interchange DX(LX+I*INCX) and DY(LY+I*INCY), -* where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is -* defined in a similar way using INCY. -****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., -* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, -* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL -* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 -****ROUTINES CALLED (NONE) -****END PROLOGUE DSWAP -* - DOUBLE PRECISION DX(1),DY(1),DTEMP1,DTEMP2,DTEMP3 -****FIRST EXECUTABLE STATEMENT DSWAP - IF(N.LE.0)RETURN - IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 - 5 CONTINUE -* -* CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. -* - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP1 = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP1 - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -* -* CODE FOR BOTH INCREMENTS EQUAL TO 1 -* -* -* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. -* - 20 M = MOD(N,3) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP1 = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP1 - 30 CONTINUE - IF( N .LT. 3 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,3 - DTEMP1 = DX(I) - DTEMP2 = DX(I+1) - DTEMP3 = DX(I+2) - DX(I) = DY(I) - DX(I+1) = DY(I+1) - DX(I+2) = DY(I+2) - DY(I) = DTEMP1 - DY(I+1) = DTEMP2 - DY(I+2) = DTEMP3 - 50 CONTINUE - RETURN - 60 CONTINUE -* -* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. -* - NS = N*INCX - DO 70 I=1,NS,INCX - DTEMP1 = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP1 - 70 CONTINUE - RETURN - END - INTEGER FUNCTION IDAMAX(N,DX,INCX) -****BEGIN PROLOGUE IDAMAX -****DATE WRITTEN 791001 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D1A2 -****KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT, -* VECTOR -****AUTHOR LAWSON, C. L., (JPL) -* HANSON, R. J., (SNLA) -* KINCAID, D. R., (U. OF TEXAS) -* KROGH, F. T., (JPL) -****PURPOSE Find largest component of d.p. vector -****DESCRIPTION -* -* B L A S Subprogram -* Description of Parameters -* -* --Input-- -* N number of elements in input vector(s) -* DX double precision vector with N elements -* INCX storage spacing between elements of DX -* -* --Output-- -* IDAMAX smallest index (zero if N .LE. 0) -* -* Find smallest index of maximum magnitude of double precision DX. -* IDAMAX = first I, I = 1 to N, to minimize ABS(DX(1-INCX+I*INCX) -****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., -* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, -* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL -* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 -****ROUTINES CALLED (NONE) -****END PROLOGUE IDAMAX -* - DOUBLE PRECISION DX(1),DMAX,XMAG -****FIRST EXECUTABLE STATEMENT IDAMAX - IDAMAX = 0 - IF(N.LE.0) RETURN - IDAMAX = 1 - IF(N.LE.1)RETURN - IF(INCX.EQ.1)GOTO 20 -* -* CODE FOR INCREMENTS NOT EQUAL TO 1. -* - DMAX = DABS(DX(1)) - NS = N*INCX - II = 1 - DO 10 I = 1,NS,INCX - XMAG = DABS(DX(I)) - IF(XMAG.LE.DMAX) GO TO 5 - IDAMAX = II - DMAX = XMAG - 5 II = II + 1 - 10 CONTINUE - RETURN -* -* CODE FOR INCREMENTS EQUAL TO 1. -* - 20 DMAX = DABS(DX(1)) - DO 30 I = 2,N - XMAG = DABS(DX(I)) - IF(XMAG.LE.DMAX) GO TO 30 - IDAMAX = I - DMAX = XMAG - 30 CONTINUE - RETURN - END - SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) -****BEGIN PROLOGUE DGEFA -****DATE WRITTEN 780814 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D2A1 -****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX -****AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -****PURPOSE Factors a double precision matrix by Gaussian elimination. -****DESCRIPTION -* -* DGEFA factors a double precision matrix by Gaussian elimination. -* -* DGEFA is usually called by DGECO, but it can be called -* directly with a saving in time if RCOND is not needed. -* (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . -* -* On Entry -* -* A DOUBLE PRECISION(LDA, N) -* the matrix to be factored. -* -* LDA INTEGER -* the leading dimension of the array A . -* -* N INTEGER -* the order of the matrix A . -* -* On Return -* -* A an upper triangular matrix and the multipliers -* which were used to obtain it. -* The factorization can be written A = L*U where -* L is a product of permutation and unit lower -* triangular matrices and U is upper triangular. -* -* IPVT INTEGER(N) -* an integer vector of pivot indices. -* -* INFO INTEGER -* = 0 normal value. -* = K if U(K,K) .EQ. 0.0 . This is not an error -* condition for this subroutine, but it does -* indicate that DGESL or DGEDI will divide by zero -* if called. Use RCOND in DGECO for a reliable -* indication of singularity. -* -* LINPACK. This version dated 08/14/78 . -* Cleve Moler, University of New Mexico, Argonne National Lab. -* -* Subroutines and Functions -* -* BLAS DAXPY,DSCAL,IDAMAX -****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -* *LINPACK USERS GUIDE*, SIAM, 1979. -****ROUTINES CALLED DAXPY,DSCAL,IDAMAX -****END PROLOGUE DGEFA - INTEGER LDA,N,IPVT(1),INFO - DOUBLE PRECISION A(LDA,1) -* - DOUBLE PRECISION T - INTEGER IDAMAX,J,K,KP1,L,NM1 -* -* GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -* -****FIRST EXECUTABLE STATEMENT DGEFA - INFO = 0 - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 70 - DO 60 K = 1, NM1 - KP1 = K + 1 -* -* FIND L = PIVOT INDEX -* - L = IDAMAX(N-K+1,A(K,K),1) + K - 1 - IPVT(K) = L -* -* ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -* - IF (A(L,K) .EQ. 0.0D0) GO TO 40 -* -* INTERCHANGE IF NECESSARY -* - IF (L .EQ. K) GO TO 10 - T = A(L,K) - A(L,K) = A(K,K) - A(K,K) = T - 10 CONTINUE -* -* COMPUTE MULTIPLIERS -* - T = -1.0D0/A(K,K) - CALL DSCAL(N-K,T,A(K+1,K),1) -* -* ROW ELIMINATION WITH COLUMN INDEXING -* - DO 30 J = KP1, N - T = A(L,J) - IF (L .EQ. K) GO TO 20 - A(L,J) = A(K,J) - A(K,J) = T - 20 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) - 30 CONTINUE - GO TO 50 - 40 CONTINUE - INFO = K - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - IPVT(N) = N - IF (A(N,N) .EQ. 0.0D0) INFO = N - RETURN - END - SUBROUTINE DSIFA(A,LDA,N,KPVT,INFO) -****BEGIN PROLOGUE DSIFA -****DATE WRITTEN 780814 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D2B1A -****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX, -* SYMMETRIC -****AUTHOR BUNCH, J., (UCSD) -****PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with -* symmetric pivoting -****DESCRIPTION -* -* DSIFA factors a double precision symmetric matrix by elimination -* with symmetric pivoting. -* -* To solve A*X = B , follow DSIFA by DSISL. -* To compute INVERSE(A)*C , follow DSIFA by DSISL. -* To compute DETERMINANT(A) , follow DSIFA by DSIDI. -* To compute INERTIA(A) , follow DSIFA by DSIDI. -* To compute INVERSE(A) , follow DSIFA by DSIDI. -* -* On Entry -* -* A DOUBLE PRECISION(LDA,N) -* the symmetric matrix to be factored. -* Only the diagonal and upper triangle are used. -* -* LDA INTEGER -* the leading dimension of the array A . -* -* N INTEGER -* the order of the matrix A . -* -* On Return -* -* A a block diagonal matrix and the multipliers which -* were used to obtain it. -* The factorization can be written A = U*D*TRANS(U) -* where U is a product of permutation and unit -* upper triangular matrices, TRANS(U) is the -* transpose of U , and D is block diagonal -* with 1 by 1 and 2 by 2 blocks. -* -* KPVT INTEGER(N) -* an integer vector of pivot indices. -* -* INFO INTEGER -* = 0 normal value. -* = K if the K-th pivot block is singular. This is -* not an error condition for this subroutine, -* but it does indicate that DSISL or DSIDI may -* divide by zero if called. -* -* LINPACK. This version dated 08/14/78 . -* James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. -* -* Subroutines and Functions -* -* BLAS DAXPY,DSWAP,IDAMAX -* Fortran DABS,DMAX1,DSQRT -****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -* *LINPACK USERS GUIDE*, SIAM, 1979. -****ROUTINES CALLED DAXPY,DSWAP,IDAMAX -****END PROLOGUE DSIFA - INTEGER LDA,N,KPVT(1),INFO - DOUBLE PRECISION A(LDA,1) -* - DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T - DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX - INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,IDAMAX - LOGICAL SWAP -* -* INITIALIZE -* -* ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. -****FIRST EXECUTABLE STATEMENT DSIFA - ALPHA = (1.0D0 + DSQRT(17.0D0))/8.0D0 -* - INFO = 0 -* -* MAIN LOOP ON K, WHICH GOES FROM N TO 1. -* - K = N - 10 CONTINUE -* -* LEAVE THE LOOP IF K=0 OR K=1. -* -* ...EXIT - IF (K .EQ. 0) GO TO 200 - IF (K .GT. 1) GO TO 20 - KPVT(1) = 1 - IF (A(1,1) .EQ. 0.0D0) INFO = 1 -* ......EXIT - GO TO 200 - 20 CONTINUE -* -* THIS SECTION OF CODE DETERMINES THE KIND OF -* ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, -* KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND -* SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS -* REQUIRED. -* - KM1 = K - 1 - ABSAKK = DABS(A(K,K)) -* -* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -* COLUMN K. -* - IMAX = IDAMAX(K-1,A(1,K),1) - COLMAX = DABS(A(IMAX,K)) - IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 - KSTEP = 1 - SWAP = .FALSE. - GO TO 90 - 30 CONTINUE -* -* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -* ROW IMAX. -* - ROWMAX = 0.0D0 - IMAXP1 = IMAX + 1 - DO 40 J = IMAXP1, K - ROWMAX = DMAX1(ROWMAX,DABS(A(IMAX,J))) - 40 CONTINUE - IF (IMAX .EQ. 1) GO TO 50 - JMAX = IDAMAX(IMAX-1,A(1,IMAX),1) - ROWMAX = DMAX1(ROWMAX,DABS(A(JMAX,IMAX))) - 50 CONTINUE - IF (DABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 - KSTEP = 1 - SWAP = .TRUE. - GO TO 80 - 60 CONTINUE - IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 - KSTEP = 1 - SWAP = .FALSE. - GO TO 80 - 70 CONTINUE - KSTEP = 2 - SWAP = IMAX .NE. KM1 - 80 CONTINUE - 90 CONTINUE - IF (DMAX1(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100 -* -* COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. -* - KPVT(K) = K - INFO = K - GO TO 190 - 100 CONTINUE - IF (KSTEP .EQ. 2) GO TO 140 -* -* 1 X 1 PIVOT BLOCK. -* - IF (.NOT.SWAP) GO TO 120 -* -* PERFORM AN INTERCHANGE. -* - CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K),1) - DO 110 JJ = IMAX, K - J = K + IMAX - JJ - T = A(J,K) - A(J,K) = A(IMAX,J) - A(IMAX,J) = T - 110 CONTINUE - 120 CONTINUE -* -* PERFORM THE ELIMINATION. -* - DO 130 JJ = 1, KM1 - J = K - JJ - MULK = -A(J,K)/A(K,K) - T = MULK - CALL DAXPY(J,T,A(1,K),1,A(1,J),1) - A(J,K) = MULK - 130 CONTINUE -* -* SET THE PIVOT ARRAY. -* - KPVT(K) = K - IF (SWAP) KPVT(K) = IMAX - GO TO 190 - 140 CONTINUE -* -* 2 X 2 PIVOT BLOCK. -* - IF (.NOT.SWAP) GO TO 160 -* -* PERFORM AN INTERCHANGE. -* - CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) - DO 150 JJ = IMAX, KM1 - J = KM1 + IMAX - JJ - T = A(J,K-1) - A(J,K-1) = A(IMAX,J) - A(IMAX,J) = T - 150 CONTINUE - T = A(K-1,K) - A(K-1,K) = A(IMAX,K) - A(IMAX,K) = T - 160 CONTINUE -* -* PERFORM THE ELIMINATION. -* - KM2 = K - 2 - IF (KM2 .EQ. 0) GO TO 180 - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - DENOM = 1.0D0 - AK*AKM1 - DO 170 JJ = 1, KM2 - J = KM1 - JJ - BK = A(J,K)/A(K-1,K) - BKM1 = A(J,K-1)/A(K-1,K) - MULK = (AKM1*BK - BKM1)/DENOM - MULKM1 = (AK*BKM1 - BK)/DENOM - T = MULK - CALL DAXPY(J,T,A(1,K),1,A(1,J),1) - T = MULKM1 - CALL DAXPY(J,T,A(1,K-1),1,A(1,J),1) - A(J,K) = MULK - A(J,K-1) = MULKM1 - 170 CONTINUE - 180 CONTINUE -* -* SET THE PIVOT ARRAY. -* - KPVT(K) = 1 - K - IF (SWAP) KPVT(K) = -IMAX - KPVT(K-1) = KPVT(K) - 190 CONTINUE - K = K - KSTEP - GO TO 10 - 200 CONTINUE - RETURN - END - DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -****BEGIN PROLOGUE DASUM -****DATE WRITTEN 791001 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D1A3A -****KEYWORDS ADD,BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAGNITUDE,SUM, -* VECTOR -****AUTHOR LAWSON, C. L., (JPL) -* HANSON, R. J., (SNLA) -* KINCAID, D. R., (U. OF TEXAS) -* KROGH, F. T., (JPL) -****PURPOSE Sum of magnitudes of d.p. vector components -****DESCRIPTION -* -* B L A S Subprogram -* Description of Parameters -* -* --Input-- -* N number of elements in input vector(s) -* DX double precision vector with N elements -* INCX storage spacing between elements of DX -* -* --Output-- -* DASUM double precision result (zero if N .LE. 0) -* -* Returns sum of magnitudes of double precision DX. -* DASUM = sum from 0 to N-1 of DABS(DX(1+I*INCX)) -****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., -* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, -* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL -* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 -****ROUTINES CALLED (NONE) -****END PROLOGUE DASUM -* - DOUBLE PRECISION DX(1) -****FIRST EXECUTABLE STATEMENT DASUM - DASUM = 0.D0 - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GOTO 20 -* -* CODE FOR INCREMENTS NOT EQUAL TO 1. -* - NS = N*INCX - DO 10 I=1,NS,INCX - DASUM = DASUM + DABS(DX(I)) - 10 CONTINUE - RETURN -* -* CODE FOR INCREMENTS EQUAL TO 1. -* -* -* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. -* - 20 M = MOD(N,6) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DASUM = DASUM + DABS(DX(I)) - 30 CONTINUE - IF( N .LT. 6 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,6 - DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) - & + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) - 50 CONTINUE - RETURN - END - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -****BEGIN PROLOGUE DAXPY -****DATE WRITTEN 791001 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D1A7 -****KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,TRIAD,VECTOR -****AUTHOR LAWSON, C. L., (JPL) -* HANSON, R. J., (SNLA) -* KINCAID, D. R., (U. OF TEXAS) -* KROGH, F. T., (JPL) -****PURPOSE D.P computation y = a*x + y -****DESCRIPTION -* -* B L A S Subprogram -* Description of Parameters -* -* --Input-- -* N number of elements in input vector(s) -* DA double precision scalar multiplier -* DX double precision vector with N elements -* INCX storage spacing between elements of DX -* DY double precision vector with N elements -* INCY storage spacing between elements of DY -* -* --Output-- -* DY double precision result (unchanged if N .LE. 0) -* -* Overwrite double precision DY with double precision DA*DX + DY. -* For I = 0 to N-1, replace DY(LY+I*INCY) with DA*DX(LX+I*INCX) + -* DY(LY+I*INCY), where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N -* and LY is defined in a similar way using INCY. -****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., -* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, -* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL -* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 -****ROUTINES CALLED (NONE) -****END PROLOGUE DAXPY -* - DOUBLE PRECISION DX(1),DY(1),DA -****FIRST EXECUTABLE STATEMENT DAXPY - IF(N.LE.0.OR.DA.EQ.0.D0) RETURN - IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 - 5 CONTINUE -* -* CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. -* - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -* -* CODE FOR BOTH INCREMENTS EQUAL TO 1 -* -* -* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. -* - 20 M = MOD(N,4) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DY(I) = DY(I) + DA*DX(I) - 30 CONTINUE - IF( N .LT. 4 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I + 1) = DY(I + 1) + DA*DX(I + 1) - DY(I + 2) = DY(I + 2) + DA*DX(I + 2) - DY(I + 3) = DY(I + 3) + DA*DX(I + 3) - 50 CONTINUE - RETURN -* -* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. -* - 60 CONTINUE - NS = N*INCX - DO 70 I=1,NS,INCX - DY(I) = DA*DX(I) + DY(I) - 70 CONTINUE - RETURN - END - SUBROUTINE DSCAL(N,DA,DX,INCX) -****BEGIN PROLOGUE DSCAL -****DATE WRITTEN 791001 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D1A6 -****KEYWORDS BLAS,LINEAR ALGEBRA,SCALE,VECTOR -****AUTHOR LAWSON, C. L., (JPL) -* HANSON, R. J., (SNLA) -* KINCAID, D. R., (U. OF TEXAS) -* KROGH, F. T., (JPL) -****PURPOSE D.P. vector scale x = a*x -****DESCRIPTION -* -* B L A S Subprogram -* Description of Parameters -* -* --Input-- -* N number of elements in input vector(s) -* DA double precision scale factor -* DX double precision vector with N elements -* INCX storage spacing between elements of DX -* -* --Output-- -* DX double precision result (unchanged if N.LE.0) -* -* Replace double precision DX by double precision DA*DX. -* For I = 0 to N-1, replace DX(1+I*INCX) with DA * DX(1+I*INCX) -****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., -* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, -* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL -* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 -****ROUTINES CALLED (NONE) -****END PROLOGUE DSCAL -* - DOUBLE PRECISION DA,DX(1) -****FIRST EXECUTABLE STATEMENT DSCAL - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GOTO 20 -* -* CODE FOR INCREMENTS NOT EQUAL TO 1. -* - NS = N*INCX - DO 10 I = 1,NS,INCX - DX(I) = DA*DX(I) - 10 CONTINUE - RETURN -* -* CODE FOR INCREMENTS EQUAL TO 1. -* -* -* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. -* - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DX(I) = DA*DX(I) - 30 CONTINUE - IF( N .LT. 5 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I + 1) = DA*DX(I + 1) - DX(I + 2) = DA*DX(I + 2) - DX(I + 3) = DA*DX(I + 3) - DX(I + 4) = DA*DX(I + 4) - 50 CONTINUE - RETURN - END - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) - implicit double precision (a-h, o-z) -C RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. -C DDOT = SUM FOR I = 0 TO N-1 OF DX(LX+I*INCX) * DY(LY+I*INCY) -C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS -C DEFINED IN A SIMILAR WAY USING INCY. - DOUBLE PRECISION DX(1),DY(1) - DDOT = 0.D0 - IF(N.LE.0)RETURN - IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 - 5 CONTINUE -C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DDOT = DDOT + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C CODE FOR BOTH INCREMENTS EQUAL TO 1. -C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DDOT = DDOT + DX(I)*DY(I) - 30 CONTINUE - IF( N .LT. 5 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + - & DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) - 50 CONTINUE - RETURN -C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. - 60 CONTINUE - NS = N*INCX - DO 70 I=1,NS,INCX - DDOT = DDOT + DX(I)*DY(I) - 70 CONTINUE - RETURN - END - DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) - implicit double precision (a-h, o-z) - INTEGER NEXT - DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE - DATA ZERO, ONE /0.0D0, 1.0D0/ -C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE -C INCREMENT INCX . -C C.L.LAWSON, 1978 JAN 08 - DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / - IF(N .GT. 0) GO TO 10 - DNRM2 = ZERO - GO TO 300 - 10 ASSIGN 30 TO NEXT - SUM = ZERO - NN = N * INCX -C BEGIN MAIN LOOP - I = 1 - 20 GO TO NEXT,(30, 50, 70, 110) - 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 - ASSIGN 50 TO NEXT - XMAX = ZERO -C PHASE 1. SUM IS ZERO - 50 IF( DX(I) .EQ. ZERO) GO TO 200 - IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 -C PREPARE FOR PHASE 2. - ASSIGN 70 TO NEXT - GO TO 105 -C PREPARE FOR PHASE 4. - 100 I = J - ASSIGN 110 TO NEXT - SUM = (SUM / DX(I)) / DX(I) - 105 XMAX = DABS(DX(I)) - GO TO 115 -C PHASE 2. SUM IS SMALL. -C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. - 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 -C COMMON CODE FOR PHASES 2 AND 4. -C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. - 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 - SUM = ONE + SUM * (XMAX / DX(I))**2 - XMAX = DABS(DX(I)) - GO TO 200 - 115 SUM = SUM + (DX(I)/XMAX)**2 - GO TO 200 -C PREPARE FOR PHASE 3. - 75 SUM = (SUM * XMAX) * XMAX -C FOR REAL OR D.P. SET HITEST = CUTHI/N -C FOR COMPLEX SET HITEST = CUTHI/(2*N) - 85 HITEST = CUTHI/FLOAT( N ) -C PHASE 3. SUM IS MID-RANGE. NO SCALING. - DO 95 J =I,NN,INCX - IF(DABS(DX(J)) .GE. HITEST) GO TO 100 - 95 SUM = SUM + DX(J)**2 - DNRM2 = DSQRT( SUM ) - GO TO 300 - 200 CONTINUE - I = I + INCX - IF ( I .LE. NN ) GO TO 20 -C END OF MAIN LOOP. -C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. - DNRM2 = XMAX * DSQRT(SUM) - 300 CONTINUE - RETURN - END diff --git a/OpticsJan2020/MLI_light_optics/Src/linpak_old.f b/OpticsJan2020/MLI_light_optics/Src/linpak_old.f deleted file mode 100755 index ddfd2b8..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/linpak_old.f +++ /dev/null @@ -1,1187 +0,0 @@ - SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) -C***BEGIN PROLOGUE DGECO -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2A1 -C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, -C MATRIX -C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -C***PURPOSE Factors a double precision matrix by Gaussian elimination -C and estimates the condition of the matrix. -C***DESCRIPTION -C -C DGECO factors a double precision matrix by Gaussian elimination -C and estimates the condition of the matrix. -C -C If RCOND is not needed, DGEFA is slightly faster. -C To solve A*X = B , follow DGECO by DGESL. -C To compute INVERSE(A)*C , follow DGECO by DGESL. -C To compute DETERMINANT(A) , follow DGECO by DGEDI. -C To compute INVERSE(A) , follow DGECO by DGEDI. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the matrix to be factored. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C A an upper triangular matrix and the multipliers -C which were used to obtain it. -C The factorization can be written A = L*U where -C L is a product of permutation and unit lower -C triangular matrices and U is upper triangular. -C -C IPVT INTEGER(N) -C an INTEGER vector of pivot indices. -C -C RCOND DOUBLE PRECISION -C an estimate of the reciprocal condition of A . -C For the system A*X = B , relative perturbations -C in A and B of size EPSILON may cause -C relative perturbations in X of size EPSILON/RCOND . -C If RCOND is so small that the logical expression -C 1.0 + RCOND .EQ. 1.0 -C is true, then A may be singular to working -C precision. In particular, RCOND is zero if -C exact singularity is detected or the estimate -C underflows. -C -C Z DOUBLE PRECISION(N) -C a work vector whose contents are usually unimportant. -C If A is close to a singular matrix, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C -C LINPACK. This version dated 08/14/78 . -C Cleve Moler, University of New Mexico, Argonne National Lab. -C -C Subroutines and Functions -C -C LINPACK DGEFA -C BLAS DAXPY,DDOT,DSCAL,DASUM -C Fortran DABS,DMAX1,DSIGN -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DASUM,DAXPY,DDOT,DGEFA,DSCAL -C***END PROLOGUE DGECO - INTEGER LDA,N,IPVT(1) - DOUBLE PRECISION A(LDA,1),Z(1) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION DDOT,EK,T,WK,WKM - DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM - INTEGER INFO,J,K,KB,KP1,L -C -C COMPUTE 1-NORM OF A -C -C***FIRST EXECUTABLE STATEMENT DGECO - ANORM = 0.0D0 - DO 10 J = 1, N - ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1)) - 10 CONTINUE -C -C FACTOR -C - CALL DGEFA(A,LDA,N,IPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . -C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE -C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE -C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID -C OVERFLOW. -C -C SOLVE TRANS(U)*W = E -C - EK = 1.0D0 - DO 20 J = 1, N - Z(J) = 0.0D0 - 20 CONTINUE - DO 100 K = 1, N - IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) - IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30 - S = DABS(A(K,K))/DABS(EK-Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 30 CONTINUE - WK = EK - Z(K) - WKM = -EK - Z(K) - S = DABS(WK) - SM = DABS(WKM) - IF (A(K,K) .EQ. 0.0D0) GO TO 40 - WK = WK/A(K,K) - WKM = WKM/A(K,K) - GO TO 50 - 40 CONTINUE - WK = 1.0D0 - WKM = 1.0D0 - 50 CONTINUE - KP1 = K + 1 - IF (KP1 .GT. N) GO TO 90 - DO 60 J = KP1, N - SM = SM + DABS(Z(J)+WKM*A(K,J)) - Z(J) = Z(J) + WK*A(K,J) - S = S + DABS(Z(J)) - 60 CONTINUE - IF (S .GE. SM) GO TO 80 - T = WKM - WK - WK = WKM - DO 70 J = KP1, N - Z(J) = Z(J) + T*A(K,J) - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - Z(K) = WK - 100 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C -C SOLVE TRANS(L)*Y = W -C - DO 120 KB = 1, N - K = N + 1 - KB - IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) - IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110 - S = 1.0D0/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - 110 CONTINUE - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - 120 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C - YNORM = 1.0D0 -C -C SOLVE L*V = Y -C - DO 140 K = 1, N - L = IPVT(K) - T = Z(L) - Z(L) = Z(K) - Z(K) = T - IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) - IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130 - S = 1.0D0/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 130 CONTINUE - 140 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE U*Z = V -C - DO 160 KB = 1, N - K = N + 1 - KB - IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150 - S = DABS(A(K,K))/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 150 CONTINUE - IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 - T = -Z(K) - CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) - 160 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 - RETURN - END - SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) -C***BEGIN PROLOGUE DGESL -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2A1 -C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE -C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -C***PURPOSE Solves the double precision system A*X=B or TRANS(A)*X=B -C using the factors computed by DGECO or DGEFA. -C***DESCRIPTION -C -C DGESL solves the double precision system -C A * X = B or TRANS(A) * X = B -C using the factors computed by DGECO or DGEFA. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the output from DGECO or DGEFA. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C IPVT INTEGER(N) -C the pivot vector from DGECO or DGEFA. -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -C -C JOB INTEGER -C = 0 to solve A*X = B , -C = nonzero to solve TRANS(A)*X = B where -C TRANS(A) is the transpose. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero will occur if the input factor contains a -C zero on the diagonal. Technically this indicates singularity -C but it is often caused by improper arguments or improper -C setting of LDA . It will not occur if the subroutines are -C called correctly and if DGECO has set RCOND .GT. 0.0 -C or DGEFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) -C IF (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) -C 10 CONTINUE -C -C LINPACK. This version dated 08/14/78 . -C Cleve Moler, University of New Mexico, Argonne National Lab. -C -C Subroutines and Functions -C -C BLAS DAXPY,DDOT -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DAXPY,DDOT -C***END PROLOGUE DGESL - INTEGER LDA,N,IPVT(1),JOB - DOUBLE PRECISION A(LDA,1),B(1) -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,NM1 -C***FIRST EXECUTABLE STATEMENT DGESL - NM1 = N - 1 - IF (JOB .NE. 0) GO TO 50 -C -C JOB = 0 , SOLVE A * X = B -C FIRST SOLVE L*Y = B -C - IF (NM1 .LT. 1) GO TO 30 - DO 20 K = 1, NM1 - L = IPVT(K) - T = B(L) - IF (L .EQ. K) GO TO 10 - B(L) = B(K) - B(K) = T - 10 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) - 20 CONTINUE - 30 CONTINUE -C -C NOW SOLVE U*X = Y -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/A(K,K) - T = -B(K) - CALL DAXPY(K-1,T,A(1,K),1,B(1),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, SOLVE TRANS(A) * X = B -C FIRST SOLVE TRANS(U)*Y = B -C - DO 60 K = 1, N - T = DDOT(K-1,A(1,K),1,B(1),1) - B(K) = (B(K) - T)/A(K,K) - 60 CONTINUE -C -C NOW SOLVE TRANS(L)*X = Y -C - IF (NM1 .LT. 1) GO TO 90 - DO 80 KB = 1, NM1 - K = N - KB - B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) - L = IPVT(K) - IF (L .EQ. K) GO TO 70 - T = B(L) - B(L) = B(K) - B(K) = T - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - RETURN - END - SUBROUTINE DSICO(A,LDA,N,KPVT,RCOND,Z) -C***BEGIN PROLOGUE DSICO -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2B1A -C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, -C MATRIX,SYMMETRIC -C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -C***PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with symmet- -C ric pivoting and estimates the condition of the matrix. -C***DESCRIPTION -C -C DSICO factors a double precision symmetric matrix by elimination -C with symmetric pivoting and estimates the condition of the -C matrix. -C -C If RCOND is not needed, DSIFA is slightly faster. -C To solve A*X = B , follow DSICO by DSISL. -C To compute INVERSE(A)*C , follow DSICO by DSISL. -C To compute INVERSE(A) , follow DSICO by DSIDI. -C To compute DETERMINANT(A) , follow DSICO by DSIDI. -C To compute INERTIA(A), follow DSICO by DSIDI. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the symmetric matrix to be factored. -C Only the diagonal and upper triangle are used. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C Output -C -C A a block diagonal matrix and the multipliers which -C were used to obtain it. -C The factorization can be written A = U*D*TRANS(U) -C where U is a product of permutation and unit -C upper triangular matrices, TRANS(U) is the -C transpose of U , and D is block diagonal -C with 1 by 1 and 2 by 2 blocks. -C -C KPVT INTEGER(N) -C an integer vector of pivot indices. -C -C RCOND DOUBLE PRECISION -C an estimate of the reciprocal condition of A . -C For the system A*X = B , relative perturbations -C in A and B of size EPSILON may cause -C relative perturbations in X of size EPSILON/RCOND . -C If RCOND is so small that the logical expression -C 1.0 + RCOND .EQ. 1.0 -C is true, then A may be singular to working -C precision. In particular, RCOND is zero if -C exact singularity is detected or the estimate -C underflows. -C -C Z DOUBLE PRECISION(N) -C a work vector whose contents are usually unimportant. -C If A is close to a singular matrix, then Z is -C an approximate null vector in the sense that -C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . -C -C LINPACK. This version dated 08/14/78 . -C Cleve Moler, University of New Mexico, Argonne National Lab. -C -C Subroutines and Functions -C -C LINPACK DSIFA -C BLAS DAXPY,DDOT,DSCAL,DASUM -C Fortran DABS,DMAX1,IABS,DSIGN -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DASUM,DAXPY,DDOT,DSCAL,DSIFA -C***END PROLOGUE DSICO - INTEGER LDA,N,KPVT(1) - DOUBLE PRECISION A(LDA,1),Z(1) - DOUBLE PRECISION RCOND -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T - DOUBLE PRECISION ANORM,S,DASUM,YNORM - INTEGER I,INFO,J,JM1,K,KP,KPS,KS -C -C FIND NORM OF A USING ONLY UPPER HALF -C -C***FIRST EXECUTABLE STATEMENT DSICO - DO 30 J = 1, N - Z(J) = DASUM(J,A(1,J),1) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - Z(I) = Z(I) + DABS(A(I,J)) - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - ANORM = 0.0D0 - DO 40 J = 1, N - ANORM = DMAX1(ANORM,Z(J)) - 40 CONTINUE -C -C FACTOR -C - CALL DSIFA(A,LDA,N,KPVT,INFO) -C -C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . -C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . -C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL -C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . -C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. -C -C SOLVE U*D*W = E -C - EK = 1.0D0 - DO 50 J = 1, N - Z(J) = 0.0D0 - 50 CONTINUE - K = N - 60 IF (K .EQ. 0) GO TO 120 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - KP = IABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 70 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 70 CONTINUE - IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,Z(K)) - Z(K) = Z(K) + EK - CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 1) GO TO 80 - IF (Z(K-1) .NE. 0.0D0) EK = DSIGN(EK,Z(K-1)) - Z(K-1) = Z(K-1) + EK - CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 80 CONTINUE - IF (KS .EQ. 2) GO TO 100 - IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 90 - S = DABS(A(K,K))/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - EK = S*EK - 90 CONTINUE - IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 - GO TO 110 - 100 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 110 CONTINUE - K = K - KS - GO TO 60 - 120 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C -C SOLVE TRANS(U)*Y = W -C - K = 1 - 130 IF (K .GT. N) GO TO 160 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 150 - Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) - KP = IABS(KPVT(K)) - IF (KP .EQ. K) GO TO 140 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 140 CONTINUE - 150 CONTINUE - K = K + KS - GO TO 130 - 160 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) -C - YNORM = 1.0D0 -C -C SOLVE U*D*V = Y -C - K = N - 170 IF (K .EQ. 0) GO TO 230 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. KS) GO TO 190 - KP = IABS(KPVT(K)) - KPS = K + 1 - KS - IF (KP .EQ. KPS) GO TO 180 - T = Z(KPS) - Z(KPS) = Z(KP) - Z(KP) = T - 180 CONTINUE - CALL DAXPY(K-KS,Z(K),A(1,K),1,Z(1),1) - IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1) - 190 CONTINUE - IF (KS .EQ. 2) GO TO 210 - IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 200 - S = DABS(A(K,K))/DABS(Z(K)) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM - 200 CONTINUE - IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) - IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 - GO TO 220 - 210 CONTINUE - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = Z(K)/A(K-1,K) - BKM1 = Z(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - Z(K) = (AKM1*BK - BKM1)/DENOM - Z(K-1) = (AK*BKM1 - BK)/DENOM - 220 CONTINUE - K = K - KS - GO TO 170 - 230 CONTINUE - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C -C SOLVE TRANS(U)*Z = V -C - K = 1 - 240 IF (K .GT. N) GO TO 270 - KS = 1 - IF (KPVT(K) .LT. 0) KS = 2 - IF (K .EQ. 1) GO TO 260 - Z(K) = Z(K) + DDOT(K-1,A(1,K),1,Z(1),1) - IF (KS .EQ. 2) - & Z(K+1) = Z(K+1) + DDOT(K-1,A(1,K+1),1,Z(1),1) - KP = IABS(KPVT(K)) - IF (KP .EQ. K) GO TO 250 - T = Z(K) - Z(K) = Z(KP) - Z(KP) = T - 250 CONTINUE - 260 CONTINUE - K = K + KS - GO TO 240 - 270 CONTINUE -C MAKE ZNORM = 1.0 - S = 1.0D0/DASUM(N,Z,1) - CALL DSCAL(N,S,Z,1) - YNORM = S*YNORM -C - IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM - IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 - RETURN - END - SUBROUTINE DSISL(A,LDA,N,KPVT,B) -C***BEGIN PROLOGUE DSISL -C***DATE WRITTEN 780814 (YYMMDD) -C***REVISION DATE 820801 (YYMMDD) -C***CATEGORY NO. D2B1A -C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, -C SYMMETRIC -C***AUTHOR BUNCH, J., (UCSD) -C***PURPOSE Solves the double precision SYMMETRIC system -C A*X=B using the factors computed by DSIFA. -C***DESCRIPTION -C -C DSISL solves the double precision symmetric system -C A * X = B -C using the factors computed by DSIFA. -C -C On Entry -C -C A DOUBLE PRECISION(LDA,N) -C the output from DSIFA. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C KPVT INTEGER(N) -C the pivot vector from DSIFA. -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero may occur if DSICO has set RCOND .EQ. 0.0 -C or DSIFA has set INFO .NE. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DSIFA(A,LDA,N,KPVT,INFO) -C IF (INFO .NE. 0) GO TO ... -C DO 10 J = 1, P -C CALL DSISL(A,LDA,N,KPVT,C(1,J)) -C 10 CONTINUE -C -C LINPACK. This version dated 08/14/78 . -C James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. -C -C Subroutines and Functions -C -C BLAS DAXPY,DDOT -C Fortran IABS -C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -C *LINPACK USERS GUIDE*, SIAM, 1979. -C***ROUTINES CALLED DAXPY,DDOT -C***END PROLOGUE DSISL - INTEGER LDA,N,KPVT(1) - DOUBLE PRECISION A(LDA,1),B(1) -C - DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP - INTEGER K,KP -C -C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND -C D INVERSE TO B. -C -C***FIRST EXECUTABLE STATEMENT DSISL - K = N - 10 IF (K .EQ. 0) GO TO 80 - IF (KPVT(K) .LT. 0) GO TO 40 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 30 - KP = KPVT(K) - IF (KP .EQ. K) GO TO 20 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 20 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL DAXPY(K-1,B(K),A(1,K),1,B(1),1) - 30 CONTINUE -C -C APPLY D INVERSE. -C - B(K) = B(K)/A(K,K) - K = K - 1 - GO TO 70 - 40 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 2) GO TO 60 - KP = IABS(KPVT(K)) - IF (KP .EQ. K - 1) GO TO 50 -C -C INTERCHANGE. -C - TEMP = B(K-1) - B(K-1) = B(KP) - B(KP) = TEMP - 50 CONTINUE -C -C APPLY THE TRANSFORMATION. -C - CALL DAXPY(K-2,B(K),A(1,K),1,B(1),1) - CALL DAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1) - 60 CONTINUE -C -C APPLY D INVERSE. -C - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - BK = B(K)/A(K-1,K) - BKM1 = B(K-1)/A(K-1,K) - DENOM = AK*AKM1 - 1.0D0 - B(K) = (AKM1*BK - BKM1)/DENOM - B(K-1) = (AK*BKM1 - BK)/DENOM - K = K - 2 - 70 CONTINUE - GO TO 10 - 80 CONTINUE -C -C LOOP FORWARD APPLYING THE TRANSFORMATIONS. -C - K = 1 - 90 IF (K .GT. N) GO TO 160 - IF (KPVT(K) .LT. 0) GO TO 120 -C -C 1 X 1 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 110 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) - KP = KPVT(K) - IF (KP .EQ. K) GO TO 100 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 100 CONTINUE - 110 CONTINUE - K = K + 1 - GO TO 150 - 120 CONTINUE -C -C 2 X 2 PIVOT BLOCK. -C - IF (K .EQ. 1) GO TO 140 -C -C APPLY THE TRANSFORMATION. -C - B(K) = B(K) + DDOT(K-1,A(1,K),1,B(1),1) - B(K+1) = B(K+1) + DDOT(K-1,A(1,K+1),1,B(1),1) - KP = IABS(KPVT(K)) - IF (KP .EQ. K) GO TO 130 -C -C INTERCHANGE. -C - TEMP = B(K) - B(K) = B(KP) - B(KP) = TEMP - 130 CONTINUE - 140 CONTINUE - K = K + 2 - 150 CONTINUE - GO TO 90 - 160 CONTINUE - RETURN - END - SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) -****BEGIN PROLOGUE DGEFA -****DATE WRITTEN 780814 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D2A1 -****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX -****AUTHOR MOLER, C. B., (U. OF NEW MEXICO) -****PURPOSE Factors a double precision matrix by Gaussian elimination. -****DESCRIPTION -* -* DGEFA factors a double precision matrix by Gaussian elimination. -* -* DGEFA is usually called by DGECO, but it can be called -* directly with a saving in time if RCOND is not needed. -* (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . -* -* On Entry -* -* A DOUBLE PRECISION(LDA, N) -* the matrix to be factored. -* -* LDA INTEGER -* the leading dimension of the array A . -* -* N INTEGER -* the order of the matrix A . -* -* On Return -* -* A an upper triangular matrix and the multipliers -* which were used to obtain it. -* The factorization can be written A = L*U where -* L is a product of permutation and unit lower -* triangular matrices and U is upper triangular. -* -* IPVT INTEGER(N) -* an integer vector of pivot indices. -* -* INFO INTEGER -* = 0 normal value. -* = K if U(K,K) .EQ. 0.0 . This is not an error -* condition for this subroutine, but it does -* indicate that DGESL or DGEDI will divide by zero -* if called. Use RCOND in DGECO for a reliable -* indication of singularity. -* -* LINPACK. This version dated 08/14/78 . -* Cleve Moler, University of New Mexico, Argonne National Lab. -* -* Subroutines and Functions -* -* BLAS DAXPY,DSCAL,IDAMAX -****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -* *LINPACK USERS GUIDE*, SIAM, 1979. -****ROUTINES CALLED DAXPY,DSCAL,IDAMAX -****END PROLOGUE DGEFA - INTEGER LDA,N,IPVT(1),INFO - DOUBLE PRECISION A(LDA,1) -* - DOUBLE PRECISION T - INTEGER IDAMAX,J,K,KP1,L,NM1 -* -* GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -* -****FIRST EXECUTABLE STATEMENT DGEFA - INFO = 0 - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 70 - DO 60 K = 1, NM1 - KP1 = K + 1 -* -* FIND L = PIVOT INDEX -* - L = IDAMAX(N-K+1,A(K,K),1) + K - 1 - IPVT(K) = L -* -* ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -* - IF (A(L,K) .EQ. 0.0D0) GO TO 40 -* -* INTERCHANGE IF NECESSARY -* - IF (L .EQ. K) GO TO 10 - T = A(L,K) - A(L,K) = A(K,K) - A(K,K) = T - 10 CONTINUE -* -* COMPUTE MULTIPLIERS -* - T = -1.0D0/A(K,K) - CALL DSCAL(N-K,T,A(K+1,K),1) -* -* ROW ELIMINATION WITH COLUMN INDEXING -* - DO 30 J = KP1, N - T = A(L,J) - IF (L .EQ. K) GO TO 20 - A(L,J) = A(K,J) - A(K,J) = T - 20 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) - 30 CONTINUE - GO TO 50 - 40 CONTINUE - INFO = K - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - IPVT(N) = N - IF (A(N,N) .EQ. 0.0D0) INFO = N - RETURN - END - SUBROUTINE DSIFA(A,LDA,N,KPVT,INFO) -****BEGIN PROLOGUE DSIFA -****DATE WRITTEN 780814 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D2B1A -****KEYWORDS DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX, -* SYMMETRIC -****AUTHOR BUNCH, J., (UCSD) -****PURPOSE Factors a d.p. SYMMETRIC matrix by elimination with -* symmetric pivoting -****DESCRIPTION -* -* DSIFA factors a double precision symmetric matrix by elimination -* with symmetric pivoting. -* -* To solve A*X = B , follow DSIFA by DSISL. -* To compute INVERSE(A)*C , follow DSIFA by DSISL. -* To compute DETERMINANT(A) , follow DSIFA by DSIDI. -* To compute INERTIA(A) , follow DSIFA by DSIDI. -* To compute INVERSE(A) , follow DSIFA by DSIDI. -* -* On Entry -* -* A DOUBLE PRECISION(LDA,N) -* the symmetric matrix to be factored. -* Only the diagonal and upper triangle are used. -* -* LDA INTEGER -* the leading dimension of the array A . -* -* N INTEGER -* the order of the matrix A . -* -* On Return -* -* A a block diagonal matrix and the multipliers which -* were used to obtain it. -* The factorization can be written A = U*D*TRANS(U) -* where U is a product of permutation and unit -* upper triangular matrices, TRANS(U) is the -* transpose of U , and D is block diagonal -* with 1 by 1 and 2 by 2 blocks. -* -* KPVT INTEGER(N) -* an integer vector of pivot indices. -* -* INFO INTEGER -* = 0 normal value. -* = K if the K-th pivot block is singular. This is -* not an error condition for this subroutine, -* but it does indicate that DSISL or DSIDI may -* divide by zero if called. -* -* LINPACK. This version dated 08/14/78 . -* James Bunch, Univ. Calif. San Diego, Argonne Nat. Lab. -* -* Subroutines and Functions -* -* BLAS DAXPY,DSWAP,IDAMAX -* Fortran DABS,DMAX1,DSQRT -****REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., -* *LINPACK USERS GUIDE*, SIAM, 1979. -****ROUTINES CALLED DAXPY,DSWAP,IDAMAX -****END PROLOGUE DSIFA - INTEGER LDA,N,KPVT(1),INFO - DOUBLE PRECISION A(LDA,1) -* - DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T - DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX - INTEGER IMAX,IMAXP1,J,JJ,JMAX,K,KM1,KM2,KSTEP,IDAMAX - LOGICAL SWAP -* -* INITIALIZE -* -* ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. -****FIRST EXECUTABLE STATEMENT DSIFA - ALPHA = (1.0D0 + DSQRT(17.0D0))/8.0D0 -* - INFO = 0 -* -* MAIN LOOP ON K, WHICH GOES FROM N TO 1. -* - K = N - 10 CONTINUE -* -* LEAVE THE LOOP IF K=0 OR K=1. -* -* ...EXIT - IF (K .EQ. 0) GO TO 200 - IF (K .GT. 1) GO TO 20 - KPVT(1) = 1 - IF (A(1,1) .EQ. 0.0D0) INFO = 1 -* ......EXIT - GO TO 200 - 20 CONTINUE -* -* THIS SECTION OF CODE DETERMINES THE KIND OF -* ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, -* KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND -* SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS -* REQUIRED. -* - KM1 = K - 1 - ABSAKK = DABS(A(K,K)) -* -* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -* COLUMN K. -* - IMAX = IDAMAX(K-1,A(1,K),1) - COLMAX = DABS(A(IMAX,K)) - IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 - KSTEP = 1 - SWAP = .FALSE. - GO TO 90 - 30 CONTINUE -* -* DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN -* ROW IMAX. -* - ROWMAX = 0.0D0 - IMAXP1 = IMAX + 1 - DO 40 J = IMAXP1, K - ROWMAX = DMAX1(ROWMAX,DABS(A(IMAX,J))) - 40 CONTINUE - IF (IMAX .EQ. 1) GO TO 50 - JMAX = IDAMAX(IMAX-1,A(1,IMAX),1) - ROWMAX = DMAX1(ROWMAX,DABS(A(JMAX,IMAX))) - 50 CONTINUE - IF (DABS(A(IMAX,IMAX)) .LT. ALPHA*ROWMAX) GO TO 60 - KSTEP = 1 - SWAP = .TRUE. - GO TO 80 - 60 CONTINUE - IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 - KSTEP = 1 - SWAP = .FALSE. - GO TO 80 - 70 CONTINUE - KSTEP = 2 - SWAP = IMAX .NE. KM1 - 80 CONTINUE - 90 CONTINUE - IF (DMAX1(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100 -* -* COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. -* - KPVT(K) = K - INFO = K - GO TO 190 - 100 CONTINUE - IF (KSTEP .EQ. 2) GO TO 140 -* -* 1 X 1 PIVOT BLOCK. -* - IF (.NOT.SWAP) GO TO 120 -* -* PERFORM AN INTERCHANGE. -* - CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K),1) - DO 110 JJ = IMAX, K - J = K + IMAX - JJ - T = A(J,K) - A(J,K) = A(IMAX,J) - A(IMAX,J) = T - 110 CONTINUE - 120 CONTINUE -* -* PERFORM THE ELIMINATION. -* - DO 130 JJ = 1, KM1 - J = K - JJ - MULK = -A(J,K)/A(K,K) - T = MULK - CALL DAXPY(J,T,A(1,K),1,A(1,J),1) - A(J,K) = MULK - 130 CONTINUE -* -* SET THE PIVOT ARRAY. -* - KPVT(K) = K - IF (SWAP) KPVT(K) = IMAX - GO TO 190 - 140 CONTINUE -* -* 2 X 2 PIVOT BLOCK. -* - IF (.NOT.SWAP) GO TO 160 -* -* PERFORM AN INTERCHANGE. -* - CALL DSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1) - DO 150 JJ = IMAX, KM1 - J = KM1 + IMAX - JJ - T = A(J,K-1) - A(J,K-1) = A(IMAX,J) - A(IMAX,J) = T - 150 CONTINUE - T = A(K-1,K) - A(K-1,K) = A(IMAX,K) - A(IMAX,K) = T - 160 CONTINUE -* -* PERFORM THE ELIMINATION. -* - KM2 = K - 2 - IF (KM2 .EQ. 0) GO TO 180 - AK = A(K,K)/A(K-1,K) - AKM1 = A(K-1,K-1)/A(K-1,K) - DENOM = 1.0D0 - AK*AKM1 - DO 170 JJ = 1, KM2 - J = KM1 - JJ - BK = A(J,K)/A(K-1,K) - BKM1 = A(J,K-1)/A(K-1,K) - MULK = (AKM1*BK - BKM1)/DENOM - MULKM1 = (AK*BKM1 - BK)/DENOM - T = MULK - CALL DAXPY(J,T,A(1,K),1,A(1,J),1) - T = MULKM1 - CALL DAXPY(J,T,A(1,K-1),1,A(1,J),1) - A(J,K) = MULK - A(J,K-1) = MULKM1 - 170 CONTINUE - 180 CONTINUE -* -* SET THE PIVOT ARRAY. -* - KPVT(K) = 1 - K - IF (SWAP) KPVT(K) = -IMAX - KPVT(K-1) = KPVT(K) - 190 CONTINUE - K = K - KSTEP - GO TO 10 - 200 CONTINUE - RETURN - END - DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) - implicit double precision (a-h, o-z) - INTEGER NEXT - DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE - DATA ZERO, ONE /0.0D0, 1.0D0/ -C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE -C INCREMENT INCX . -C C.L.LAWSON, 1978 JAN 08 - DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / - IF(N .GT. 0) GO TO 10 - DNRM2 = ZERO - GO TO 300 - 10 ASSIGN 30 TO NEXT - SUM = ZERO - NN = N * INCX -C BEGIN MAIN LOOP - I = 1 - 20 GO TO NEXT,(30, 50, 70, 110) - 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 - ASSIGN 50 TO NEXT - XMAX = ZERO -C PHASE 1. SUM IS ZERO - 50 IF( DX(I) .EQ. ZERO) GO TO 200 - IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 -C PREPARE FOR PHASE 2. - ASSIGN 70 TO NEXT - GO TO 105 -C PREPARE FOR PHASE 4. - 100 I = J - ASSIGN 110 TO NEXT - SUM = (SUM / DX(I)) / DX(I) - 105 XMAX = DABS(DX(I)) - GO TO 115 -C PHASE 2. SUM IS SMALL. -C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. - 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 -C COMMON CODE FOR PHASES 2 AND 4. -C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. - 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 - SUM = ONE + SUM * (XMAX / DX(I))**2 - XMAX = DABS(DX(I)) - GO TO 200 - 115 SUM = SUM + (DX(I)/XMAX)**2 - GO TO 200 -C PREPARE FOR PHASE 3. - 75 SUM = (SUM * XMAX) * XMAX -C FOR REAL OR D.P. SET HITEST = CUTHI/N -C FOR COMPLEX SET HITEST = CUTHI/(2*N) - 85 HITEST = CUTHI/FLOAT( N ) -C PHASE 3. SUM IS MID-RANGE. NO SCALING. - DO 95 J =I,NN,INCX - IF(DABS(DX(J)) .GE. HITEST) GO TO 100 - 95 SUM = SUM + DX(J)**2 - DNRM2 = DSQRT( SUM ) - GO TO 300 - 200 CONTINUE - I = I + INCX - IF ( I .LE. NN ) GO TO 20 -C END OF MAIN LOOP. -C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. - DNRM2 = XMAX * DSQRT(SUM) - 300 CONTINUE - RETURN - END diff --git a/OpticsJan2020/MLI_light_optics/Src/magnet.f b/OpticsJan2020/MLI_light_optics/Src/magnet.f deleted file mode 100644 index b93dce3..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/magnet.f +++ /dev/null @@ -1,3985 +0,0 @@ -c Minor changes made 6/04 by P. Walstrom to help it pass FTNCHEK -c P Walstrom's current sheet magnet routines for all gtypes -c - subroutine onaxgr(init,zfp,icoil,ndriv,dg) -c modified 8-25 to use modified gtype6=gtipe6. -ctm renamed back to gtype6 and gtype17 for MaryLie version - implicit double precision(a-h,o-z) -c Requires initialization calls for some values of icoil,according -c to value of itype(icoil). See below. -c Also, must call subroutines BINCOF,GAULEG and COEFFS once -c before the above initialization calls -c Applies to cylindrical current sheet coils or PMMs. Some types can h -c an infinitely long, cylindrical infinite-mu shield surrrounding the -c windings. -c -c Written by P. L. Walstrom, Grumman Space Systems,6-90, LANL. -c Modified by P. L. Walstrom 4/91 to include thick and thin Halbach PMM -c Modified 8-96 to include coils with an iron cylinder or shield -c around the windings. This is done by adding an equivalent cylindrcal -c current sheet of radius b, the iron radius, that duplicates the -c iron contribution for r1 -c -c Input variables: -c -c z=zcoordinate of field point with respect to coil center. -c a1=inner magnet radius -c a2=outer magnet radius -c xl=coil length -c glprod=integral of on axis gradient -c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. -c ndriv=highest derivative of on-axis gradient, plus 1. -c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize -c gradient. -c mu0=4pi*1.d-7 - parameter (maxdrv=20,maxcof=35) - common /cmcof/ cm(maxcof),cmp(maxcof),xmu0 - common /dnms/ denom(maxcof,2,2) - dimension dg(maxdrv),dgdz(maxdrv) -c cmp(m)=1*3*5*...(2m+1)/(m!*2**(m+1)) -c -c Output variables: -c dg=vector with ndriv components containing the on-axis gradient, and -c its ndriv-1 derivatives. -c -c Themagnetic moment per unit area has magnitude -c M_0, -xl/21gradient constant - 44 mm1=m-1 - c=glprod*cmp(m)*dfloat(m-1)/(xl*(a1**(-mm1)-a2**(-mm1))) -c Get0th derivative of g_m - 45 hfl=0.5d0*xl - x1=-hfl-z - x2=hfl-z -c call g0hlb to get the above double integral -c - call denoms(a1,a2,x1,x2,m,ndriv) -c - call g0hlb(a1,a2,x1,x2,m,g0) - dg(1)=-c*g0 - if(ndriv.lt.2) return - s1=-x1 - s2=-x2 - ndrvm1=ndriv-1 -c Get1st and higher derivatives of g_m - call dghlb(a1,a2,s1,s2,m,ndriv,dgdz) - do 1 n=1,ndrvm1 - np1=n+1 - 1 dg(np1)=c*dgdz(n) - return - end -c -c************************************************** -c - subroutine gtype3(init,k,icoil,xl,xlmin,z,a,glprod,m, - &ndriv,dg) - implicit double precision(a-h,o-z) - parameter(maxcof=35) - common /cmcof/ cm(maxcof),cmp(maxcof),xmu0 -c This subroutine calulates the on-axis gradient for both the fundament -c andfirst harmonic of a Lambertson m-pole coil. -c Called with init=0 to initialize, with init=1 for gradient. -c k=0means fundamental -c k=1means first harmonic -c m=multipole index of harmonic in question. -c i.e., if k=1, m=3*(m of fundamental) - parameter(maxcoils=100,maxdrv=20,npoint=25) - dimension aii(npoint,maxcoils),bii(npoint,maxcoils), - &cii(npoint,maxcoils),amid(maxcoils),zn(npoint,maxcoils) - dimension xi(npoint),yi(npoint),ai(npoint),bi(npoint) - dimension ccoil(maxcoils),alfi(5),dg(maxdrv) - dimension xngi(maxdrv),ci(npoint),points(npoint) - data small/1.d-4/ - save aii,bii,cii,amid,zn,ccoil,npm1 - save small - if(init.gt.0) go to 1 - dif=(xl-xlmin)/xl - if(dabs(dif).lt.small) go to 1001 - m2=2*m - hfl=xl*0.5d0 - hflmin=0.5d0*xlmin - npm1=npoint-1 - dell=hfl-hflmin - points(1)=0.d0 - points(npoint)=1.d0 - npm2=npoint-2 - dy=1.d0/dfloat(npm2) - do 55 n=2,npm2 - y=dy*dfloat(n-1) - 55 points(n)=y**2*(2.d0-y) - points(npm1)=0.5d0*points(npm2)+0.5d0 - xleff=0.5d0*(xl+xlmin) - ccoil(icoil)=glprod*cm(m)*a**m2/xleff - do 4 n=1,npoint - x=dell*points(n)-hfl - xi(n)=x - zn(n,icoil)=x - call flamb(xl,xlmin,x,fz,f3z) - if(k.eq.0) yi(n)=fz - if(k.eq.1) yi(n)=f3z - 4 continue -c nowfit parabolae to xi,yi - call parfit(npoint,xi,yi,ai,bi,ci) - do 5 n=1,npm1 - aii(n,icoil)=ai(n) - bii(n,icoil)=bi(n) - 5 cii(n,icoil)=ci(n) - amid(icoil)=yi(npoint) - return -c Calculate gradients in subsequent calls. - 1 continue - hflmin=0.5d0*xlmin - c=ccoil(icoil) - do 6 nd=1,ndriv - 6 dg(nd)=0.d0 - do 7 n=1,npm1 - np1=n+1 - x1=zn(n,icoil) - x2=zn(np1,icoil) - alfi(1)=aii(n,icoil) - alfi(2)=bii(n,icoil) - alfi(3)=cii(n,icoil) - call xngmin(m,3,ndriv,a,x1,x2,z,alfi,xngi) - do 8 nd=1,ndriv - 8 dg(nd)=dg(nd)+xngi(nd) -c right hand side of coil is mirror image of left - zm=-z - call xngmin(m,3,ndriv,a,x1,x2,zm,alfi,xngi) - sign=-1.d0 - do 9 nd=1,ndriv - sign=-sign - 9 dg(nd)=dg(nd)+xngi(nd)*sign - 7 continue -c getmiddle - alfi(1)=amid(icoil) - x1=-hflmin - x2=hflmin - call xngmin(m,1,ndriv,a,x1,x2,z,alfi,xngi) - do 10 nd=1,ndriv - 10 dg(nd)=dg(nd)+xngi(nd) - do 11 nd=1,ndriv - 11 dg(nd)=dg(nd)*c - return - 1001 write(6,300) - 300 format(1x,'End zone of Lambertson too short-stopped in GTYPE3') - stop - end -c -c************************************************** -c - subroutine gtype5(z,a,xl,glprod,m,ndriv,dg) - implicit double precision(a-h,o-z) - parameter(maxcof=35) - common /cmcof/ cm(maxcof),cmp(maxcof),xmu0 -c This subroutine calculates the on-axis generalized gradient for a -c cylindrical surface winding without iron, with a flat shape function. -c Input variables: -c -c z=zcoordinate of field point with respect to coil center. -c a=coil radius -c xl=coil length -c glprod=integral of on axis gradient -c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. -c ndriv=highest derivative of on-axis gradient, plus 1. -c Forthis shape function, NI=2*glprod*a**mcoil/(xl*mu0) -c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize -c gradient. -c mu0=4pi*1.d-7 - parameter (maxdrv=20) - dimension dg(maxdrv),ai(5),xngi(maxdrv) -c cm(m)=1*3*5*...(2m-1)/(m!*2**m) -c -c Output variables: -c dg=vector with ndriv components containing the on-axis gradient, and -c its ndriv-1 derivatives. -c -c Shape function has form -c f(x)=1, -xl/21001-stopped in GTYPE6') - stop - end -c -c************************************************** -c - subroutine gtype7(z,a,xl,wflat,glprod,m,ndriv,dg) - implicit double precision(a-h,o-z) - parameter(maxcof=35) - common /cmcof/ cm(maxcof),cmp(maxcof),xmu0 -c This subroutine calculates the on-axis generalized gradient for a -c cylindrical surface winding without iron, with a shape function -c that is flat in the center and rounded at the ends. The ends -c arerepresented by a parabola tangent to the flat top. -c Input variables: -c -c z=zcoordinate of field point with respect to coil center. -c a=coil radius -c xl=coil length -c wflat=length of the flat section of the shape function. -c glprod=integral of on axis gradient -c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. -c ndriv=highest derivative of on-axis gradient, plus 1. -c Forthis shape function, NI=2*glprod*a**mcoil/(xleff*mu0) -c where xleff=2/3*xl+1/3*wflat -c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize -c gradient. -c mu0=4pi*1.d-7 - parameter (maxdrv=20) - dimension dg(maxdrv),ai(5),xngi(maxdrv) -c cm(m)=1*3*5*...(2m-1)/(m!*2**m) -c -c Output variables: -c dg=vector with ndriv components containing the on-axis gradient, and -c its ndriv-1 derivatives. -c -c Shape function has form -c f(x)=1, -wflat/2xl in GTYPE11-stopped') - stop - end -c -c************************************************** -c - subroutine gtype12(z,a,xl,w1,w2,s1,s2,glprod,m,ndriv,dg) - implicit double precision(a-h,o-z) - parameter(maxcof=35) - common /cmcof/ cm(maxcof),cmp(maxcof),xmu0 -c This subroutine calculates the on-axis generalized gradient for a -c cylindrical surface winding without iron, with a shape function -c that is flat in the center and rounded at the ends. The ends -c arequadratic + cubic in distance from flattop. -c Input variables: -c -c z=zcoordinate of field point with respect to coil center. -c a=coil radius -c xl=coil length -c w1=width of the curved section from -xl/2 to the flattop. -c w2=width of the curved section from the flattop to xl/2. -c glprod=integral of on-axis gradient -c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. -c ndriv=highest derivative of on-axis gradient, plus 1. -c Forthis shape function, NI=glprod*a**mcoil/(xleff*mu0) -c where xleff=w1*(8+s1)/15+xl-w1-w2+w2*(8+s2)/15 -c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize -c gradient. -c mu0=4pi*1.d-7 - parameter (maxdrv=20) - parameter(twelveth=1.d0/1.2d1) - dimension dg(maxdrv),ai(5),xngi(maxdrv) -c cm(m)=1*3*5*...(2m-1)/(m!*2**m) -c -c Output variables: -c dg=vector with ndriv components containing the on-axis gradient, and -c its ndriv-1 derivatives. -c -c Shape function has form -c -c f(x)=1+A1(x+xl/2-w1)**2 + B1*(x+xl/2-w1)**3 -xl/2xl in GTYPE12-stopped') - stop - end -c -c************************************************** -c - subroutine gtype13(z,a,a2,xl,eslope,glprod,m,ndriv,dg) - implicit double precision(a-h,o-z) -c This subroutine calculates the on-axis generalized gradient for a -c cylindrical surface winding without iron,with an even quartic shape -c function. Thick analog of gtype1. -c Input variables: -c -c z=zcoordinate of field point with respect to coil center. -c a=inner coil radius -c a2 = outer coil radius. -c xl=coil length -c eslope=dimensionless end slope of the shape function -c glprod=integral of on axis gradient -c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. -c ndriv=highest derivative of on-axis gradient, minus 1. -c Forthis shape function, NI=2*glprod*a**mcoil/(Leff*mu0) -c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize -c gradient. -c -c Output variables: -c dg=vector with ndriv components containing the on-axis gradient, and -c its ndriv-1 derivatives. -c -c typical value for eslope (for dipoles) is 1. -c Shape function has form -c f(x)=1+x**2*(eslope/2-2)*4/xl**2+x**4*(1-eslope/2)*16/xL**4 -c =1+bb*x**2+dd*x**4, -xl/2 or = xl in GTYPE14-stopped') - stop - end -c -c************************************************** -c - subroutine gtype15(z,a,a2,xl,w1,w2,s1,s2,glprod,m,ndriv,dg) - implicit double precision(a-h,o-z) -c This subroutine calculates the on-axis generalized gradient for a -c cylindrical surface winding without iron, with a shape function -c that is flat in the center and rounded at the ends. The ends -c arequadratic + quartic in distance from flattop. -c Thick analog of gtype11. Integration in radial depth by Gaussian -c quadrature. -c Assumes that NI/layer scales as ap, the radius of the layer, -c while the shape function and Leff stay the same as the winding radius -c increases. This is not quite right. -c Since more turns are added to increase NI in the outer -c layers, there is less room at the ends for crossover parts of the tur -c Therefore, the shape function would be different, and Leff of the out -c layers would be lower. For a better approximation of real windings, -c multiple thick coils with increasing end zone widths w1 and w2 should -c be used. -c Input variables: -c -c z=zcoordinate of field point with respect to coil center. -c a=inner coil radius -c a2=outer coil radius -c xl=coil length -c w1=width of the curved section from -xl/2 to the flattop. -c w2=width of the curved section from the flattop to xl/2. -c s1=Left hand end slope=df/dz(-xl/2) -c s2=Right hand end slope=-df/dz(xl/2) -c glprod=integral of on-axis gradient -c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. -c ndriv=highest derivative of on-axis gradient, plus 1. -c Forthis shape function, NI=2*glprod*a**mcoil/(xleff*mu0) -c where xleff=w1*(8+s1)/15+xl-w1-w2+w2*(8+s2)/15 -c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize -c gradient. -c mu0=4pi*1.d-7 -c cm(m)=1*3*5*...(2m-1)/(m!*2**m) -c -c Output variables: -c dg=vector with ndriv components containing the on-axis gradient, and -c its ndriv-1 derivatives. -c -c Shape function has form -c -c f(x)=1+A1(x+xl/2-w1)**2 + B1*(x+xl/2-w1)**4 -xl/2xl in GTYPE15-stopped') - stop - end -c -c************************************************** -c - subroutine gtype16(z,a,a2,xl,w1,w2,s1,s2,glprod,m,ndriv,dg) - implicit double precision(a-h,o-z) -c This subroutine calculates the on-axis generalized gradient for a -c cylindrical surface winding without iron, with a shape function -c that is flat in the center and rounded at the ends. The ends -c arequadratic + cubic in distance from flattop. -c Thick analog of gtype12. Integration in radial depth by Gaussian -c quadrature. -c Assumes that NI/layer scales as ap, the radius of the layer, -c while the shape function and Leff stay the same as the winding radius -c increases. This is not quite right. -c Since more turns are added to increase NI in the outer -c layers, there is less room at the ends for crossover parts of the tur -c Therefore, the shape function would be different, and Leff of the out -c layers would be lower. For a better approximation of real windings, -c multiple thick coils with increasing end zone widths w1 and w2 should -c be used. -c Input variables: -c -c z=zcoordinate of field point with respect to coil center. -c a=inner coil radius -c a2=outer coil radius -c xl=coil length -c w1=width of the curved section from -xl/2 to the flattop. -c w2=width of the curved section from the flattop to xl/2. -c s1=Left hand end slope=df/dz(-xl/2) -c s2=Right hand end slope=-df/dz(xl/2) -c glprod=integral of on-axis gradient -c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. -c ndriv=highest derivative of on-axis gradient, plus 1. -c Forthis shape function, NI=2*glprod*a**mcoil/(xleff*mu0) -c where xleff=w1*(8+s1)/15+xl-w1-w2+w2*(8+s2)/15 -c glprod=integral from z=-inf. to z=+inf. of g(z), g=on-axis generalize -c gradient. -c mu0=4pi*1.d-7 -c cm(m)=1*3*5*...(2m-1)/(m!*2**m) -c -c Output variables: -c dg=vector with ndriv components containing the on-axis gradient, and -c its ndriv-1 derivatives. -c -c Shape function has form -c -c f(x)=1+A1(x+xl/2-w1)**2 + B1*(x+xl/2-w1)**3 -xl/2xl in GTYPE16-stopped') - stop - end -c -c************************************************** -c - subroutine gtype17(init,icoil,z,a,a2,b,xL,w1,w2,s1,s2,glprod,dg, - & m,ndriv) -c Like gtype17, except finer Gaussian quadrature. -c This subroutine calculates the on-axis generalized gradient for a -c cylindrical surface winding WITH iron, with a shape function -c that is flat in the center and rounded at the ends. The ends -c arequadratic + quartic in distance from flattop. -c -c Coaxial mu=infinity iron cylinder surrounding a thick GTYPE15 coil. -c Requires an initialization call to compute and store the equivalent i -c shape function. This is the shape function for a fictitious -c winding of radius b(=the iron radius) that mimics the incremental eff -c of the iron for ra2>a. If b< -c the iron contribution is omitted and the calculation -c applies to a "bare" thick coil (just like GTYPE15). -c -c xL=coil length -c w1=width of the curved section from -xL/2 to the flattop. -c w2=width of the curved section from the flattop to xL/2. -c s1=Left hand end slope=df/dz(-xL/2) -c s2=Right hand end slope=-df/dz(xL/2) -c glprod=integral of on-axis gradient -c m=multipole index of winding pattern-1=dipole, 2=quad.,etc. -c ndriv=highest derivative of on-axis gradient, plus 1. -c init=initialization code: 0 meams initialize, 1 means compute gradien -c -c -c mu0=4pi*1.d-7 -c cm(m)=1*3*5*...(2m-1)/(m!*2**m) -c -c Output variables: -c dg=vector with ndriv components containing the on-axis gradient, and -c its ndriv-1 derivatives. -c -c Shape function has form -c -c f(x)=1+A1(x+xL/2-w1)**2 + B1*(x+xL/2-w1)**4 -xL/2a2) - if(b.le.a2) go to 9 -c Find iron contribution to gradient - do 10 n=1,ndriv - 10 giron(n)=0.d0 -c Step through intervals of piecewise-continuous cubic interpolant of -c Fstar. -c There are ni-1 intervals, ni nodes. - ni=nin(icoil) - do 11 i=1,ni-1 - ai(1)=a1in(i,icoil) - ai(2)=a2in(i,icoil) - ai(3)=a3in(i,icoil) - ai(4)=a4in(i,icoil) - ndeg=4 - if((i.eq.1).or.(i.eq.(ni-1))) ndeg=2 - x1=xin(i,icoil) - x2=xin(i+1,icoil) - call xngmin(m,ndeg,ndriv,b,x1,x2,z,ai,xngi) - do 12 n=1,ndriv - 12 giron(n)=giron(n)+xngi(n) - 11 continue - 9 continue -c calculate field constant C0=m*mu0*J0/2 -c This constant is chosen to make the integral gradient equal the -c specified value, glprod. -c Use"new" generalized gradient definition, including factor of m. -c i.e, g_m(z)= m * lim as r goes to 0 of V_m(r,z)/r**m. -c J0 is the winding current density at phi=0, z=0, and is assumed to -c be constant with radial depth. - denom=xLeff*aintgrl(a,a2,m) - Lstar=Lstarn(icoil) - if(b.gt.a2) denom=denom+adif*a*Lstar/b**m - c0=glprod/denom -c Nowadd up bare-coil and iron contributions to gradient with -c appropriate weights. - fact0=a**(m+1)*adif - facti=b**m*a*adif - c0cm=c0*cm(m) - do 13 n=1,ndriv - dg(n)=fact0*gbare(n) - if(b.gt.a2) dg(n)=dg(n)+facti*giron(n) - 13 dg(n)=c0cm*dg(n) - if(iniflg.eq.0) then - iniflg = iniflg+1 -c write(6,297) fact0,facti,c0cm -c write(6,166) glprod,xL,a,a2,b -c rite(6,167) w1,w2,s1,s2 - 297 format(' 1st grad, f0,fi,c)cm:',3f12.5) - endif - return - 1001 write(6,300) - 300 format(1x,'w1+w2>xL in GTYPE15-stopped') - stop - end -c -c************************************************** -c -c -c rest of routines called by gtypes -c - subroutine denoms(a1,a2,s1,s2,m,ndriv) - implicit double precision(a-h,o-z) -c Calculates the quantities -c -c 1/(rho**2+s**2)**(n+1/2)) -c -c for n=0,1,2,3,....m+ndriv-1 -c rho= a1,a2 -c s= s1,s2 -c -c Results stored in common block DNMS -c - parameter(maxcof=35) - common /dnms/ denom(maxcof,2,2) - dimension u(2,2) -c -c First index in denoms is n+1, 2nd is 1 for a1, 2 for a2. 3rd index is -c 1 for s1, 2 for s2 -c -c ndriv is always equal to or greater than 1 - a12=a1**2 - a22=a2**2 - s12=s1**2 - s22=s2**2 - u(1,1)=1.d0/(a12+s12) - u(1,2)=1.d0/(a12+s22) - u(2,1)=1.d0/(a22+s12) - u(2,2)=1.d0/(a22+s22) - denom(1,1,1)=dsqrt(u(1,1)) - denom(1,1,2)=dsqrt(u(1,2)) - denom(1,2,1)=dsqrt(u(2,1)) - denom(1,2,2)=dsqrt(u(2,2)) - maxn=m+ndriv - if(maxn.lt.2) return - do 1 n=2,maxn - nm1=n-1 - do 1 k=1,2 - do 1 l=1,2 - 1 denom(n,k,l)=denom(nm1,k,l)*u(k,l) -c do 5 k=1,maxn -c 5write(6,500) k,denom(k,1,2),denom(k,1,2),denom(k,2,1), -c &denom(k,2,2) -c 500format(1x,'k,denom:',i2,4(1x,1pd14.7)) - return - end -c -c************************************************** -c - subroutine dghlb(a1,a2,s1,s2,m,ndriv,dg) - implicit double precision(a-h,o-z) -c -c Evaluates repeated derivatives with respect to z of the double -c integral -c -c s1to s2 ds a1 to a2 drho of -c -c rho**(m+2)/(rho**2+s**2)**(m+3/2) -c -c s1=z+L/2 -c s2=z-L/2 -c -c Thefirst element of the output vector dg is the first derivative, et -c dg has nd computed elements. -c -c Note difference in definition from that of s1 and s2 in G0HLB- they -c differ by a factor of -1. -c -c Calls subroutine RHOINT -c - parameter(maxdrv=20) - parameter(small=1.d-6) - dimension dg(maxdrv),ck(maxdrv),rhoin1(maxdrv), - &rhoin2(maxdrv),ckold(maxdrv),pwr(maxdrv) - dimension s1oddp(maxdrv),s2oddp(maxdrv),s1evnp(maxdrv), - &s2evnp(maxdrv),xk(maxdrv),xkold(maxdrv) - nd=ndriv-1 -c write(20,204) m,nd -c 204format(1x,'m=',i3,2x,'nd=',i3) - call rhoint(a1,a2,s1,1,m,nd,rhoin1) -c write(6,200) (rhoin1(k),k=1,nd) - 200 format(5(1x,1pd12.5)) - call rhoint(a1,a2,s2,2,m,nd,rhoin2) -c First derivative - dg(1)=rhoin2(1)-rhoin1(1) - if(nd.lt.2) return -c Second derivative - nmin=m+1 - xkmin=dfloat(2*nmin+1) - dg(2)=xkmin*(s1*rhoin1(2)-s2*rhoin2(2)) - if(nd.lt.3) return -c Third derivative - s12=s1**2 - s22=s2**2 - dg(3)=xkmin*(rhoin1(2)-rhoin2(2)+(xkmin+2.d0)*(s22*rhoin2(3)- - &s12*rhoin1(3))) - if(nd.lt.4) return -c Fourth and higher derivatives. -c Find out if nd is odd or even - x=0.5d0*dfloat(nd)+small - id=x - ileft=0 - if((x-dfloat(id)).gt.0.1d0) ileft=1 -c ileft=0 if nd is even, =1 if nd is odd -c write(20,205) id,ileft -c 205format(1x,'id=',i3,1x,'ileft=',i3) - ckold(1)=-xkmin - xkold(1)=xkmin - xkold(2)=xkmin+2.d0 - ckold(2)=-ckold(1)*xkold(2) - pwr(1)=0.d0 - pwr(2)=2.d0 - s1oddp(1)=s1 - s2oddp(1)=s2 - s1evnp(1)=1.d0 - s2evnp(1)=1.d0 - s1evnp(2)=s12 - s2evnp(2)=s22 - do 1 i=2,id -c write(20,200) i -c write(20,240) - 240 format(1x,'Even derivative Coefficients') - im=i-1 - ip=i+1 -c first, even derivative in pair - s1oddp(i)=s1oddp(im)*s12 - s2oddp(i)=s2oddp(im)*s22 - ng=2*i - do 9 j=1,i - 9 xk(j)=xkold(j)+2.d0 - do 2 j=1,im - jp=j+1 - 2 ck(j)=-ckold(j)*xk(j)+ckold(jp)*pwr(jp) - do 3 j=1,i - 3 pwr(j)=pwr(j)+1.d0 - xk(i)=xk(im)+2.d0 - ck(i)=-ckold(i)*xk(i) - dg(ng)=0.d0 - do 4 j=1,i - jcol=i+j - 4 dg(ng)=dg(ng)+(s2oddp(j)*rhoin2(jcol)- - &s1oddp(j)*rhoin1(jcol))*ck(j) -c Done with even derivative for this value of i -c replace elements in ckold vector with elements in ck vector - do 11 j=1,i -c write(20,201) j,xk(j),pwr(j),ck(j),s1oddp(j),s2oddp(j) - 11 ckold(j)=ck(j) -c skipodd derivative calculation if not wanted- i.e. i=id & ileft=0 - if(i.lt.id) go to 5 - if(ileft.eq.0) go to 1 - 5 continue - s1evnp(ip)=s1evnp(i)*s12 - s2evnp(ip)=s2evnp(i)*s22 - ng=ng+1 - ck(1)=ckold(1) - do 6 j=2,i - jm=j-1 - 6 ck(j)=-ckold(jm)*xk(j)+pwr(j)*ckold(j) - xk(ip)=xk(i)+2.d0 - ck(ip)=-ckold(i)*xk(ip) - do 7 j=1,i - 7 pwr(j)=pwr(j)-1.d0 - pwr(ip)=pwr(i)+2.d0 - dg(ng)=0.d0 - do 8 j=1,ip - jcol=i+j - 8 dg(ng)=dg(ng)+(s2evnp(j)*rhoin2(jcol)- - &s1evnp(j)*rhoin1(jcol))*ck(j) - if(i.eq.id) go to 1 -c write(20,250) -c 250format(1x,'Odd Derivative Coefficients') -c if not last value of i, load ck into ckold - do 12 j=1,ip -c write(20,201) j,xk(j),pwr(j),ck(j),s1evnp(j),s2evnp(j) -c 201format(1x,i3,5(1x,1pd14.7)) - xkold(j)=xk(j) - 12 ckold(j)=ck(j) - 1 continue - return - end -c -c************************************************** -c - subroutine dpmrv(m,ndriv,a,s,dipm) - implicit double precision(a-h,o-z) -c Used in dipole sheet model of large bore PMMs. -c This subroutine calculates repeated s derivatives of h_m= -c -c 1/(a**2+s**2)**(m+3/2)) -c -c dipm(1) = h_m, dipm(2)=d h_m /ds, dipm(3)= d**2 h_m /ds**2, etc. -c -c Uses formula from Gradstein and Ryzhik, Table of Integrals, -c Series, and Products, 1980, p.20 -c -c a=coil radius -c m=multipole index(m=1 for dipole,2 for quadrupole, 3 for sextupole,etc -c s=x-z, where x=coil z coordinate, z= field point z coordinate. -c ndriv= no. of entries in dipm (no. of times h_m is differentiated + 1 -c -c maxdrv is the maximum value of ndriv required. - parameter (maxdrv=20,maxhlf=11) -c maxhlf must be at least 1/2 of maxdrv if maxdrv is even, -c 1/2(maxdrv+1) if maxdrv is odd. -c - dimension dipm(maxdrv) - dimension cnk(maxhlf,maxdrv), - &rnk2(maxhlf,maxdrv),snk(maxhlf,maxdrv),rkfac(maxhlf) - aa=1.d0/a**2 - xm=dfloat(m) - u=1.d0+aa*s**2 - ru=1.d0/u - rru=dsqrt(ru) - m2mm3=-2*m-3 - denom=ru**m*rru*a**m2mm3 - c2=denom*ru - dipm(1)=c2 - if(ndriv.lt.2) return - tas=2.d0*aa*s - p2=-xm-1.5d0 - c2=c2*p2*ru - dipm(2)=c2*tas - if(ndriv.lt.3) return - p2m=p2 - au=aa*u - aunh=1.d0 - snk(1,1)=tas -c n=order of derivative -c find integers nhalf= nearest integer below or = (ndriv-1)/2, -c and ileft=1+(ndriv-1)-2*nhalf - xhalf=0.5d0*dfloat(ndriv-1) - nhalf=xhalf - dif=xhalf-dfloat(nhalf) - ileft=1 - if(dif.gt.0.1d0) ileft=2 - n=1 - rkf=1.d0 - do 1 nh=1,nhalf - rkf=rkf/dfloat(nh) - rkfac(nh)=rkf - nhp1=nh+1 - ilef=2 - if(nh.lt.nhalf) go to 6 - if(ileft.eq.1) ilef=1 - 6 aunh=aunh*au - nhp1=nh+1 - do 1 il=1,ilef - nm1=n - nm2=n-1 - n=n+1 - p2m=p2m-1.d0 - c2=c2*p2m*ru - snk(nhp1,n)=aunh - do 4 k=1,nh - 4 snk(k,n)=snk(k,nm1)*tas - if(il.eq.2) snk(nhp1,n)=snk(nhp1,n)*tas - cnk(2,n)=dfloat(n*(n-1)) - rnk2(2,n)=1.d0/p2m - if(nhp1.lt.3) go to 8 - do 7 k=3,nhp1 - km1=k-1 - cnk(k,n)=cnk(km1,nm2)*cnk(2,n) - 7 rnk2(k,n)=rnk2(km1,nm1)*rnk2(2,n) - 8 sum2=snk(1,n) - do 5 k=2,nhp1 - km1=k-1 - 5 sum2=sum2+snk(k,n)*cnk(k,n)*rnk2(k,n)*rkfac(km1) - np1=n+1 - 1 dipm(np1)=sum2*c2 - return - end -c -c************************************************** -c - subroutine flamb(xl,xlmin,z,fz,f3z) - implicit double precision(a-h,o-z) -c This routine calculates the mth and 3mth(i.e., the two lowest) Fourie -c coeffients of the stream function for an ideal Lambertson coil. -c This type of Lambertson coil has equal z spacing of end crossover -c turns. The stream function is dimensionless-i.e., the results -c of this routine, fz, must be multiplied somewhere by NI, -c where NI is the number of amp-turns/pole. -c -c Input variables: -c xl=coil length -c xlmin=length of shortest turn (at center of pole) -c z=axial coordinate measured from coil center -c -c Output -c fz=mth Fourier coefficient of the dimensionless stream function -c fora Lambertson m-pole coil. (All lower coefficients are zero). -c f3z=3m th Fourier coefficient " " " " -c -c Note that the shape functions f(z) and f3z(z) have no m dependence. - data two/2.d0/,three/3.d0/,half/0.5d0/,zero/0.d0/ - data five/5.d0/,four/4.d0/ - data one/1.d0/,small/1.d-12/ - hfl=half*xl - zet=dabs(z) - fz=zero - f3z=zero - if(zet.gt.hfl) return - dif=dabs(xl-xlmin) - if(dif.gt.small) go to 2 - fz=one - return - 2 hflmin=half*xlmin - hfpi=dasin(one) - xl2=xl**2 - qtrpi=half*hfpi - xlmin2=xlmin**2 - third=one/three - b=(xl2-xlmin2)/xl2 - b2=b**2 - c=xl/((xl-xlmin)*qtrpi) - xkc2=(one-b)/(one+b) - xkc=dsqrt(xkc2) -c find elliptic integrals E(pi/4,r),F(pi/4,r), where r=sqrt(2b/(1+b)). - ee=el2(one,xkc,one,xkc2) - ff=el2(one,xkc,one,one) - rootab=dsqrt(one+b) - sixth=half*third - g2f=(one-b)*sixth/b - g2e=(three*b-one)*sixth/b - g2cos=-sixth/rootab - denom=one/(30.d0*b2) - g4f=-(five*b2-four*b-one)*denom - g4e=(12.d0*b2-5.d0*b-one)*denom - g4cos=-one/(60.d0*b*rootab) - g6g2=-three*(one+b)/(14.d0*b) - g6g4=(two+8.d0*b)/(7.d0*b) - g6cos=one/(56.d0*b*rootab) - dif=(zet-hflmin)/hflmin - if(dif.gt.small) go to 1 -c z falls in center part of coil, ie. between crossover regions at ends - dele=cel(xkc,one,one,xkc2)-ee - delf=cel(xkc,one,one,one)-ff - cm=third*(one+two*(rootab*dele-(one-b2)*delf/rootab)/b) - fz=cm*c - g0=dele - g2=g2f*delf+g2e*dele-g2cos - g4=g4f*delf+g4e*dele-g4cos*(10.d0*b-one) - g6=g6g2*g2+g6g4*g4-g6cos - c3m=third-two*rootab*(g0-18.d0*g2+48.d0*g4-32.d0*g6) - f3z=c*c3m - return - 1 continue -c z falls in one of 2 crossover regions - zr=zet/hfl - zr2=zr**2 - sinfz=(one-zr2)/b - cosfz=dsqrt(one-sinfz**2) - x=dsqrt((one+sinfz)/(one-sinfz)) - dele=el2(x,xkc,one,xkc2)-ee - delf=el2(x,xkc,one,one)-ff - fz=third*(two*(rootab*dele-(one-b**2)*delf/rootab)/b+ - &one-cosfz*zr) - fz=fz*c - cos3fz=cosfz*(one-four*sinfz**2) - g0=dele - g2=g2cos*(cosfz*zr-one)+g2e*dele+g2f*delf - g4=g4cos*((10.d0*b-one+three*b*sinfz)*cosfz*zr- - &10.d0*b+one)+g4e*dele+g4f*delf - g6=(cosfz*(one+sinfz)*zr*zr2-one)*g6cos+g6g2*g2+g6g4*g4 - f3z=third*(one-zr*cos3fz)-two*rootab*(g0-18.d0*g2+ - &48.d0*g4-32.d0*g6) - f3z=f3z*c - return - end -c -c************************************************** -c -c -c -c this is a function subprogram copied from numerical recipes -c by w.h.press ,etl pp. 186-187. -c evaluates the general incomplete elliptic integral of -c the 2nd kind as the following function of four variables: -c -c el2(x,kc,a,b)= -c int[ (a+b*x**2)dx/{1+x**2)*sqrt((1+x**2)*(1+kc**2*x**2))} ] -c from x=0 to x=x -c -c the elliptic integral of the 1st kind is called by el2(x,kc,1,1) -c the elliptic integral of the 2nd kind is called by el2(x,kc,1,kc** -c - subroutine g0hlb(a1,a2,s1,s2,m,g0) - implicit double precision(a-h,o-z) - parameter(small=1.d-6) - parameter(maxcof=35) - dimension zinti(maxcof,2) -c The array ZINTI contains the integrals from s1 to s2 of -c -c ds/(a**2+s**2)**n+1/2, n=nmin,nmin+1,nmin+2,...m -c -c zinti(i,1) is evaluated at a1, zinti(i,2) at a2. -c The index i runs from 1 to m-nmin+1, with n=nmin for i=1, nmin+1 for -c i=2, etc. -c -c -c -c Used in calculating the gradient on axis of thick Halbach PMMs. -c Evaluates the double integral, s=s1 to s2, rho=a1 to a2 of -c -c (drho*ds*rho**(m+2))/(rho**2+s**2)**(m+3/2) -c -c This is the gradient on axis , except for a constant factor -c -c a1=inner radius -c a2=outer radius -c s1=-L/2-z -c s2=L/2-z -c where L is the length of the PMM, assumed to be rectangular in cro -c section in the r-z plane, and z is the axial coordinate where the -c gradient is evaluated. -c m=multipole index: m=1 for dipole, 2 for quad, etc. -c g0=value of double integral -c Uses repeated integration by parts to do the rho integral -c Each term in resultant series is integrated in z, except if m is eve -c Then the series ends in a double integral that is evaluated by the -c special-case subroutine INTEND. -c Check to see if m is even or odd. - if(m.lt.2) go to 8 - mm1=m-1 - ra1=a1**(-mm1) - ra2=a2**(-mm1) - go to 9 - 8 ra1=1.d0 - ra2=1.d0 - 9 x=dfloat(m+3)*0.5d0+small - iterms=x - dif=x-dfloat(iterms) - ileft=0 - if(dif.gt.0.1d0) ileft=1 -c ileft=0 if m is odd, =1 if m is even - if(ileft.gt.0) go to 11 -c m is odd - itop=0 - ibot=m-2 -c Exponent on denominator in innermost term=n+1/2 - nmin=(m-1)/2 - g0=0.d0 - go to 1 - 11 continue -c m is even- descending series ends in an integral evaluated by INTE - itop=1 - ibot=m-1 - nmin=m/2 - call intend(a1,a2,s1,s2,m,xiend) - g0=-xiend - 1 itrm1=iterms-1 - call zint(a1,a2,s1,s2,nmin,m,zinti) - do 2 i=1,itrm1 - if(m.lt.2) go to 10 - g0=g0+zinti(i,2)*ra2-zinti(i,1)*ra1 - go to 14 - 10 g0=g0+zinti(i,2)-zinti(i,1) - 14 itop=itop+2 - ibot=ibot+2 - g0=g0*dfloat(itop)/dfloat(ibot) - 2 continue - ibot=ibot+2 - if(m.lt.2) go to 12 - g0=g0+zinti(iterms,2)*ra2-zinti(iterms,1)*ra1 - go to 13 - 12 g0=g0+zinti(iterms,2)-zinti(iterms,1) - 13 g0=-g0/dfloat(ibot) - return - end -c -c************************************************** -c - subroutine parfit(npoint,xi,yi,ai,bi,ci) - implicit double precision(a-h,o-z) - dimension xi(npoint),yi(npoint),ai(npoint),bi(npoint), - &ci(npoint) -c fit parabola to 1st 3 points. - x1=xi(1) - y1=yi(1) - x2=xi(2) - y2=yi(2) - x3=xi(3) - y3=yi(3) - h1=x2-x1 - h2=x3-x2 - d1=y1/(h1*(h1+h2)) - d2=y2/(h1*h2) - d3=y3/(h2*(h1+h2)) -c parabola of form a1+b1*x+c1*x**2 - a1=x1*x2*d3+x2*x3*d1-x1*x3*d2 - b1=(x1+x3)*d2-(x2+x3)*d1-(x1+x2)*d3 - c1=d1-d2+d3 - ai(1)=a1 - bi(1)=b1 - ci(1)=c1 - npm2=npoint-2 -c except for ends, the parabola coefficients for a particular interval -c theaverage of those calculated with the point on the right, with tho -c calculated with the point on the left. - do 1 i=2,npm2 - ip2=i+2 - x1=x2 - x2=x3 - y1=y2 - y2=y3 - h1=h2 - x3=xi(ip2) - y3=yi(ip2) - h2=x3-x2 - d1=y1/(h1*(h1+h2)) - d2=y2/(h1*h2) - d3=y3/(h2*(h1+h2)) - a2=x1*x2*d3+x2*x3*d1-x1*x3*d2 - b2=(x1+x3)*d2-(x2+x3)*d1-(x1+x2)*d3 - c2=d1-d2+d3 - ai(i)=0.5d0*(a1+a2) - bi(i)=0.5d0*(b1+b2) - ci(i)=0.5d0*(c1+c2) - a1=a2 - b1=b2 - 1 c1=c2 - npm1=npoint-1 -c rightmost interval - ai(npm1)=a2 - bi(npm1)=b2 - ci(npm1)=c2 - return - end -c -c************************************************** -c - subroutine parfit1(npoint,xi,yi,ai,bi,ci) - implicit double precision(a-h,o-z) - dimension xi(npoint),yi(npoint),ai(npoint),bi(npoint), - &ci(npoint) -c This subroutine finds coefficients for a piecewise-quadratic fit to a -c of xi,yi points. There are npoint (xi,yi) points and npoint-1 interva -c also npoint-1 ai values, npoint-1 bi values, npoint-1 ci values. -c fitto ith interval is ai(i)+bi(i)*t+ci(i)*t**2, where t=x-xi(i). -c Like PARFIT, but coefficients apply to x-xi(i), not x. Roundoff erro -c should be lower. -c fit parabola to 1st 3 points. - y1=yi(1) - y2=yi(2) - y3=yi(3) - h1=xi(2)-xi(1) - h2=xi(3)-xi(2) - denom=h1*h2*(h1+h2) - aa=y1 - denom=h1*h2*(h1+h2) - bb=((y2-y1)*(h1+h2)**2-(y3-y1)*h1**2)/denom - cc=(h1*(y3-y2)-h2*(y2-y1))/denom -c parabola of form a+b*t+c*t**2 -c where t=x-x1 - ai(1)=aa - bi(1)=bb - ci(1)=cc -c except for ends, the parabola coefficients for a particular interval -c theaverage of those calculated with the point on the right, with tho -c calculated with the point on the left. - if(npoint.lt.4) go to 2 - do 1 i=2,npoint-2 - h3=xi(i+2)-xi(i+1) - y4=yi(i+2) -c LH expression - aa=y2 - denom=h2*h3*(h2+h3) - bb=((y3-y2)*(h2+h3)**2-(y4-y2)*h2**2)/denom - cc=(h2*(y4-y3)-h3*(y3-y2))/denom -c RH expression - denom=h1*h2*(h1+h2) - a=y2 - b=(h2**2*(y2-y1)+h1**2*(y3-y2))/denom - c=(h1*(y3-y2)-h2*(y2-y1))/denom -c Average two expressions - ai(i)=0.5d0*(a+aa) - bi(i)=0.5d0*(b+bb) - ci(i)=0.5d0*(c+cc) -c Shift fit window, unless at RH end of array. - if(i.ne.(npoint-2)) then - h1=h2 - y1=y2 - h2=h3 - y2=y3 - y3=y4 - endif - 1 continue - 2 npm1=npoint-1 -c rightmost interval - denom=h2*h3*(h2+h3) - a=y3 - b=(h3**2*(y3-y2)+h2**2*(y4-y3))/denom - c=(h2*(y4-y3)-h3*(y3-y2))/denom - ai(npm1)=a - bi(npm1)=b - ci(npm1)=c - ai(npoint)=0.d0 - bi(npoint)=0.d0 - ci(npoint)=0.d0 - return - end -c -c************************************************** -c - subroutine pmmint(x1,x2,a,m,gm0int) - implicit double precision(a-h,o-z) -c this subroutine calculates the integral from x1 to x2 of -c -c (s**2+a**2)**(-m-3/2) ds -c -c Uses formula for Gradstein and Ryzhik, p. 86 - parameter(maxcof=35) - common /bicof/ bcoeff(maxcof,maxcof) -c bcoeff contains the binomial expansion coefficients up to order -c maxcof-1 - mp1=m+1 - gm0int=0.d0 - a2=a**2 - x=x2 - do 1 i=1,2 - xsq=x**2 - root2=xsq+a2 - root=dsqrt(root2) - term=x/root - temp=bcoeff(1,m)*term - do 2 k=2,mp1 - term=-term*xsq/root2 - x2km1=dfloat(2*k-1) - 2 temp=temp+bcoeff(k,m)*term/x2km1 - gm0int=gm0int+temp - 1 x=-x1 - gm0int=gm0int*a2**(-mp1) - return - end -c -c************************************************** -c - subroutine rdrivs(m,ndriv,a,s,di) - implicit double precision(a-h,o-z) -c This subroutine calculates repeated derivatives of g_m= -c -c 1/(a**2+s**2)**(m+1/2)) -c -c di(1) = g_m, di(2)=d g_m /ds, di(3)= d**2 g_m /ds**2, etc. -c -c Uses formula from Gradstein and Ryzhik, Table of Integrals, -c Series, and Products, 1980, p.20 -c -c a=coil radius -c m=multipole index (m=1 for dipole,2 for quadrupole, 3 for sextupole,e -c s=x-z, where x=coil z coordinate, z= field point z coordinate. -c ndriv= no. of entries in di (no. of times g_m is differentiated + 1) -c -c maxdrv is the maximum value of ndriv required. - parameter (maxdrv=20,maxhlf=11) -c maxhlf must be at least 1/2 of maxdrv if maxdrv is even, -c 1/2(maxdrv+1) if maxdrv is odd. -c - dimension di(maxdrv) - dimension cnk(maxhlf,maxdrv),rnk1(maxhlf,maxdrv), - &snk(maxhlf,maxdrv),rkfac(maxhlf) - aa=1.d0/a**2 - xm=dfloat(m) - u=1.d0+aa*s**2 - ru=1.d0/u - rru=dsqrt(ru) - m2mm1=-2*m-1 - denom=ru**m*rru*a**m2mm1 - c1=xm*denom - di(1)=c1 - if(ndriv.lt.2) return - tas=2.d0*aa*s - p1=-xm-0.5d0 - c1=c1*p1*ru - di(2)=c1*tas - if(ndriv.lt.3) return - p1m=p1 - au=aa*u - aunh=1.d0 - snk(1,1)=tas -c n=order of derivative -c find integers nhalf= nearest integer below or = (ndriv-1)/2, -c and ileft=1+(ndriv-1)-2*nhalf - xhalf=0.5d0*dfloat(ndriv-1) - nhalf=xhalf - dif=xhalf-dfloat(nhalf) - ileft=1 - if(dif.gt.0.1d0) ileft=2 - n=1 - rkf=1.d0 - do 1 nh=1,nhalf - rkf=rkf/dfloat(nh) - rkfac(nh)=rkf - nhp1=nh+1 - ilef=2 - if(nh.lt.nhalf) go to 6 - if(ileft.eq.1) ilef=1 - 6 aunh=aunh*au - nhp1=nh+1 - do 1 il=1,ilef - nm1=n - nm2=n-1 - n=n+1 - p1m=p1m-1.d0 - c1=c1*p1m*ru - snk(nhp1,n)=aunh - do 4 k=1,nh - 4 snk(k,n)=snk(k,nm1)*tas - if(il.eq.2) snk(nhp1,n)=snk(nhp1,n)*tas - cnk(2,n)=dfloat(n*(n-1)) - rnk1(2,n)=1.d0/p1m - if(nhp1.lt.3) go to 8 - do 7 k=3,nhp1 - km1=k-1 - cnk(k,n)=cnk(km1,nm2)*cnk(2,n) - 7 rnk1(k,n)=rnk1(km1,nm1)*rnk1(2,n) - 8 sum1=snk(1,n) - do 5 k=2,nhp1 - km1=k-1 - 5 sum1=sum1+snk(k,n)*cnk(k,n)*rnk1(k,n)*rkfac(km1) - np1=n+1 - 1 di(np1)=sum1*c1 - return - end -c -c************************************************** -c - subroutine thickf(a,a2,ratio,m) - implicit double precision(a-h,o-z) -c calculates ratio of thin to thick coils for correction of field -c constant to get desired glprod in gtype 13,14,15,16. -c factor of 1/2 comes from the fact that sum of wgn is 2. -c RATIO is 1/2 * (a2-a)/a**(m-1) / integral from a to a2 of dx*x**(1-m -c this comes from the fact that if NI varies as x, and gL varies as -c x**(-m), the product varies as x**(1-m) (x=dummy coil radius variabl -c of integration). For thin coils, RATIO approcahes 1/2. For m=1, it -c EXACTLY 1/2, for any thickness. - parameter(c1=0.5d0,c2=0.5d0,c3=1.d0/6.d0,c4=1.d0/6.d0, - &c5=1.9d1/9.0d1,c6=0.3d0,c7=8.63d2/1.89d3,c8=2.75d2/3.78d2) - parameter(third=1.d0/3.d0) - if(m.gt.1) go to 22 - ratio=0.5d0 - go to 50 - 22 x=0.5d0*(a2-a)/a - if(x.lt.0.002d0) go to 44 - if(m.gt.2) go to 23 -c m=2, not thin - ratio=0.5d0*(a2-a)/(a*dlog(a2/a)) - go to 50 - 23 if(m.gt.3) go to 24 -c m=3, not thin - ratio=0.5d0*a2/a - go to 50 -c m>3, not thin - 24 ratio=x*dfloat(m-2)/ - &(1.d0-(a/a2)**(m-2)) - go to 50 - 44 continue -c Thin-small value of x - x=0.5d0*(a2-a)/a - if(m.gt.2) go to 25 -c thin-m=2 - ratio=c1+x*(c2-x*(c3-x*(c4-x*(c5-x*c6)))) - go to 50 - 25 if(m.gt.3) go to 26 -c Thin- m=3 - ratio=0.5d0*a2/a - go to 50 -c Thin- m>3 - 26 ratio=0.5d0*(1.d0+dfloat(m-1)*x*(1.d0+third*x* - &dfloat(m-3)*(1.d0-x))) - 50 continue - return - end -c -c************************************************** -c - subroutine xngmin(m,nterm,ndriv,a,x1,x2,z,ai,xngi) - implicit double precision(a-h,o-z) -c Evaluates analytical expressions for -c -c d**n/ dz**n of Integral from x1 to x2 of f(x)g_m(x,z) dx, where -c -c f(x)=ai(1)+ai(2)*x+..ai(nterm)*x**(nterm-1) -c -c g_m=a**(1-m) * d/da [a**m/(a**2+(x-z)**2)**(m+1/2)] -c -c for n=0 to ndriv-1. -c Maximum value of nterm is 5. - parameter(maxdrv=20) - dimension c0(5,5),c1(4,4),c2(3,3),bi(5),ai(5) -c dimension c3(2,2) - dimension xgi1(5),xgi2(5),xngi(maxdrv),di1(maxdrv),di2(maxdrv) - data (c0(k,1),k=1,5) /5*1.d0/ - data (c0(k,2),k=1,5) /0.d0,1.d0,2.d0,3.d0,4.d0/ - data (c0(k,3),k=1,5) /2*0.d0,1.d0,3.d0,6.d0/ - data (c0(k,4),k=1,5) /3*0.d0,1.d0,4.d0/ - data (c0(k,5),k=1,5) /4*0.d0,1.d0/ - data (c1(k,1),k=1,4) /1.d0,2.d0,3.d0,4.d0/ - data (c1(k,2),k=1,4) /0.d0,2.d0,6.d0,12.d0/ - data (c1(k,3),k=1,4) /2*0.d0,3.d0,12.0/ - data (c1(k,4),k=1,4) /3*0.d0,4.d0/ - data (c2(k,1),k=1,3) /2.d0,6.d0,12.d0/ - data (c2(k,2),k=1,3) /0.d0,6.d0,24.d0/ - data (c2(k,3),k=1,3) /2*0.d0,12.d0/ -c data (c3(k,1),k=1,2) /6.d0,24.d0/ -c data (c3(k,2),k=1,2) /0.d0,24.d0/ -c data c4/24.d0/ - save c0,c1,c2 - if(nterm.gt.5) go to 1001 - if(nterm.lt.1) go to 1002 - s1=x1-z - s2=x2-z - call xngint(m,nterm,a,s1,xgi1) - call xngint(m,nterm,a,s2,xgi2) -c Find coefficients for the expansion of f(x)=f(z+s) in powers of s. - do 1 n=1,nterm - kmax=nterm-n - bi(n)=ai(nterm)*c0(nterm,n) - if(kmax.lt.1) go to 1 - do 2 k=1,kmax - l=nterm-k - 2 bi(n)=ai(l)*c0(l,n)+z*bi(n) - 1 continue -c Find integral of f(s+z)*g_m(s)ds from s1 to s2, where s1=x1-z, x2=x2- -c =zeroth derivative of integral. - xngi(1)=0.d0 - do 3 n=1,nterm - 3 xngi(1)=xngi(1)+bi(n)*(xgi2(n)-xgi1(n)) - if(ndriv.lt.2) return -c Getfirst derivative of integral -c Getzeroth, first, and higher derivatives of g_m -c Need only ndriv-1 terms in derivative vector, since everything is -c integrated once. - ndrm1=ndriv-1 - call drivs(m,ndrm1,a,s1,di1) - call drivs(m,ndrm1,a,s2,di2) - f1=ai(nterm) - f2=f1 - if(nterm.lt.2) go to 6 - do 5 n=2,nterm - k=nterm-n+1 - f1=ai(k)+x1*f1 - 5 f2=ai(k)+x2*f2 - 6 xngi(2)=f1*di1(1)-f2*di2(1) - if(nterm.lt.2) go to 7 -c calculate coefficients in expansion of df/dx(x)=df/dx(s+z) in powers o - ntrm1=nterm-1 - do 8 n=2,nterm - nm1=n-1 - kmax=nterm-n - bi(n)=ai(nterm)*c1(ntrm1,nm1) - if(kmax.lt.1) go to 8 - do 9 k=1,kmax - l=ntrm1-k - lp=nterm-k - 9 bi(n)=ai(lp)*c1(l,nm1)+z*bi(n) - 8 continue - do 10 n=2,nterm - nm1=n-1 - 10 xngi(2)=xngi(2)+bi(n)*(xgi2(nm1)-xgi1(nm1)) - 7 if(ndriv.lt.3) return -c Now get second derivative of integral - xngi(3)=f2*di2(2)-f1*di1(2) - if(nterm.lt.2) go to 11 -c Evaluate df/dx at x1 and x2 - f1p=c1(ntrm1,1)*ai(nterm) - f2p=f1p - if(nterm.lt.3) go to 12 - do 13 n=3,nterm - k=nterm-n+2 - km1=k-1 - f1p=ai(k)*c1(km1,1)+x1*f1p - 13 f2p=ai(k)*c1(km1,1)+x2*f2p - 12 xngi(3)=xngi(3)+f1p*di1(1)-f2p*di2(1) - if(nterm.lt.3) go to 11 -c Find coefficients in expansion of d**2 f(x)/dx**2 in powers of s. - ntrm2=nterm-2 - do 14 n=3,nterm - nm2=n-2 - kmax=nterm-n - bi(n)=ai(nterm)*c2(ntrm2,nm2) - if(kmax.lt.1) go to 14 - do 15 k=1,kmax - l=ntrm2-k - lp=nterm-k - 15 bi(n)=ai(lp)*c2(l,nm2)+z*bi(n) - 14 continue - do 16 n=3,nterm - nm2=n-2 - 16 xngi(3)=xngi(3)+bi(n)*(xgi2(nm2)-xgi1(nm2)) - 11 if(ndriv.lt.4) return -c Get3rd derivative of integral. - xngi(4)=f1*di1(3)-f2*di2(3) - if(nterm.lt.2) go to 17 - xngi(4)=xngi(4)+f2p*di2(2)-f1p*di1(2) - if(nterm.lt.3) go to 17 -c evaluate d**2 f/ dz**2 at x1 and x2 - f1pp=c2(ntrm2,1)*ai(nterm) - f2pp=f1pp - if(nterm.lt.4) go to 18 - do 19 n=4,nterm - k=nterm-n+3 - km2=k-2 - f1pp=ai(k)*c2(km2,1)+x1*f1pp - 19 f2pp=ai(k)*c2(km2,1)+x2*f2pp - 18 xngi(4)=xngi(4)+f1pp*di1(1)-f2pp*di2(1) - if(nterm.lt.4) go to 17 - delxg=xgi2(1)-xgi1(1) - xngi(4)=xngi(4)+6.d0*ai(4)*delxg - if(nterm.lt.5) go to 17 - xngi(4)=xngi(4)+24.d0*ai(5)*(z*delxg+xgi2(2)-xgi1(2)) - 17 if(ndriv.lt.5) return -c Integral of 4th derivative - xngi(5)=f2*di2(4)-f1*di1(4) - if(nterm.lt.2) go to 20 - xngi(5)=xngi(5)-f2p*di2(3)+f1p*di1(3) - if(nterm.lt.3) go to 20 - xngi(5)=xngi(5)+f2pp*di2(2)-f1pp*di1(2) - if(nterm.lt.4) go to 20 - f1ppp=6.d0*ai(4) - f2ppp=f1ppp - if(nterm.lt.5) go to 21 - f1ppp=f1ppp+24.d0*ai(5)*x1 - f2ppp=f2ppp+24.d0*ai(5)*x2 - 21 xngi(5)=xngi(5)+f1ppp*di1(1)-f2ppp*di2(1) - if(nterm.lt.5) go to 20 - xngi(5)=xngi(5)+24.d0*ai(5)*(xgi2(1)-xgi1(1)) - 20 if(ndriv.lt.6) return -c ndriv=6 or higher- ie., 5th or higher derivatives - sign=-1.d0 - do 22 n=6,ndriv - sign=-sign - nm1=n-1 - xngi(n)=f1*di1(nm1)-f2*di2(nm1) - if(nterm.lt.2) go to 22 - nm2=n-2 - xngi(n)=xngi(n)+f2p*di2(nm2)-f1p*di1(nm2) - if(nterm.lt.3) go to 22 - nm3=n-3 - xngi(n)=xngi(n)+f1pp*di1(nm3)-f2pp*di2(nm3) - if(nterm.lt.4) go to 22 - nm4=n-4 - xngi(n)=xngi(n)+f2ppp*di2(nm4)-f1ppp*di1(nm4) - if(nterm.lt.5) go to 22 - nm5=n-5 - xngi(n)=xngi(n)+24.d0*ai(5)*(di1(nm5)-di2(nm5)) - 22 xngi(n)=xngi(n)*sign - return - 1001 write(6,300) nterm - 300 format(1x,'nterm=',i4,' was >5 in XNGMIN --stopped') - stop - 1002 write(6,301) nterm - 301 format(1x,'nterm=',i4,' was < 1 in XNGMIN --stopped') - stop - end -c -c************************************************** -c -c -c next group of called routines -c - function cel(qqc,pp,aa,bb) - implicit double precision(a-h,o-z) -c -c returns the general complete elliptic integral cel(kc,p,a,b) with -c qqc=kc, pp=p, aa=a and bb=b. -c - parameter (ca=.00001d0 , pio2=1.570796326795d0) -c -c the desired accuracy is the square of ca -c - if(qqc.eq.0.d0) go to 21 - 22 format(1x,'xkc=0 in cel-stopped') - qc=dabs(qqc) - a=aa - b=bb - p=pp - e=qc - em=1.d0 - if(p.gt.0.d0)then - p=dsqrt(p) - b=b/p - else - f=qc*qc - q=1.d0-f - g=1.d0-p - f=f-p - q=q*(b-a*p) - p=dsqrt(f/g) - a=(a-b)/g - b=-q/(g*g*p)+a*p - endif - 1 f=a - a=a+b/p - g=e/p - b=b+f*g - b=b+b - p=g+p - g=em - em=qc+em - if(dabs(g-qc).gt.g*ca)then - qc=dsqrt(e) - qc=qc+qc - e=qc*em - go to 1 - endif - cel=pio2*(b+a*em)/(em*(em+p)) - return - 21 write(6,22) - stop - end -c -c************************************************** -c - subroutine drivs(m,ndriv,a,s,di) - implicit double precision(a-h,o-z) -c This subroutine calculates repeated derivatives of g_m= -c -c a**(1-m)d/da(a**m/(a**2+s**2)**(m+1/2)) -c -c di(1) = g_m, di(2)=d g_m /ds, di(3)= d**2 g_m /ds**2, etc. -c -c Uses formula from Gradstein and Ryzhik, Table of Integrals, -c Series, and Products, 1980, p.20 -c -c a=coil radius -c m=multipole index (m=1 for dipole,2 for quadrupole, 3 for sextupole,e -c s=x-z, where x=coil z coordinate, z= field point z coordinate. -c ndriv= no. of entries in di (no. of times g_m is differentiated + 1) -c -c maxdrv is the maximum value of ndriv required. - parameter (maxdrv=20,maxhlf=11) -c maxhlf must be at least 1/2 of maxdrv if maxdrv is even, -c 1/2(maxdrv+1) if maxdrv is odd. -c - dimension di(maxdrv) - dimension cnk(maxhlf,maxdrv),rnk1(maxhlf,maxdrv), - &rnk2(maxhlf,maxdrv),snk(maxhlf,maxdrv),rkfac(maxhlf) - aa=1.d0/a**2 - xm=dfloat(m) - u=1.d0+aa*s**2 - ru=1.d0/u - rru=dsqrt(ru) - m2mm1=-2*m-1 - denom=ru**m*rru*a**m2mm1 - c1=xm*denom - c2=(2.d0*xm+1.d0)*denom*ru - di(1)=c1-c2 - if(ndriv.lt.2) return - tas=2.d0*aa*s - p1=-xm-0.5d0 - p2=p1-1.d0 - c1=c1*p1*ru - c2=c2*p2*ru - di(2)=(c1-c2)*tas - if(ndriv.lt.3) return - p1m=p1 - p2m=p2 - au=aa*u - aunh=1.d0 - snk(1,1)=tas -c n=order of derivative -c find integers nhalf= nearest integer below or = (ndriv-1)/2, -c and ileft=1+(ndriv-1)-2*nhalf - xhalf=0.5d0*dfloat(ndriv-1) - nhalf=xhalf - dif=xhalf-dfloat(nhalf) - ileft=1 - if(dif.gt.0.1d0) ileft=2 - n=1 - rkf=1.d0 - do 1 nh=1,nhalf - rkf=rkf/dfloat(nh) - rkfac(nh)=rkf - nhp1=nh+1 - ilef=2 - if(nh.lt.nhalf) go to 6 - if(ileft.eq.1) ilef=1 - 6 aunh=aunh*au - nhp1=nh+1 - do 1 il=1,ilef - nm1=n - nm2=n-1 - n=n+1 - p1m=p1m-1.d0 - p2m=p2m-1.d0 - c1=c1*p1m*ru - c2=c2*p2m*ru - snk(nhp1,n)=aunh - do 4 k=1,nh - 4 snk(k,n)=snk(k,nm1)*tas - if(il.eq.2) snk(nhp1,n)=snk(nhp1,n)*tas - cnk(2,n)=dfloat(n*(n-1)) - rnk1(2,n)=1.d0/p1m - rnk2(2,n)=1.d0/p2m - if(nhp1.lt.3) go to 8 - do 7 k=3,nhp1 - km1=k-1 - cnk(k,n)=cnk(km1,nm2)*cnk(2,n) - rnk1(k,n)=rnk1(km1,nm1)*rnk1(2,n) - 7 rnk2(k,n)=rnk2(km1,nm1)*rnk2(2,n) - 8 sum1=snk(1,n) - sum2=sum1 - do 5 k=2,nhp1 - km1=k-1 - sum1=sum1+snk(k,n)*cnk(k,n)*rnk1(k,n)*rkfac(km1) - 5 sum2=sum2+snk(k,n)*cnk(k,n)*rnk2(k,n)*rkfac(km1) - np1=n+1 - 1 di(np1)=sum1*c1-sum2*c2 - return - end -c -c************************************************** -c - function el2(x,qqc,aa,bb) - implicit double precision(a-h,o-z) -c -c returns the general elliptic integral of the second kind, -c el2(x,kc,a,b) with x.ge.0,qqc=kc,aa=a and bb=b. -c - parameter (pi=3.14159265359d0 , ca=.00001d0,cb=1.d-11) -c -c the desired accuracy is the square of ca, while cb should be -c set to 0.01 times desired accuracy. -c - if(x.eq.0.d0)then - el2=0.d0 - else if(qqc.ne.0.d0) then - qc=qqc - a=aa - b=bb - c=x**2 - d=1.d0+c - p=dsqrt((1.d0+qc**2*c)/d) - d=x/d - c=d/(2.d0*p) - z=a-b - eye=a - a=0.5d0*(b+a) - y=abs(1.d0/x) - f=0.d0 - l=0 - em=1.d0 - qc=dabs(qc) - 1 b=eye*qc+b - e=em*qc - g=e/p - d=f*g+d - f=c - eye=a - p=g+p - c=0.5d0*(d/p+c) - g=em - em=qc+em - a=0.5d0*(b/em+a) - y=-e/y+y - if(y.eq.0)y=dsqrt(e)*cb - if(dabs(g-qc).gt.ca*g)then - qc=dsqrt(e)*2.d0 - l=l+l - if(y.lt.0.) l=l+1 - go to 1 - endif - if(y.lt.0.)l=l+1 - e=(datan(em/y)+pi*l)*a/em - if(x.lt.0) e=-e - el2=e+c*z - else - write(6,21) - 21 format(1x,'xkc=0 in el2-stopped') - stop -c argument qqc was zero - endif - return - end -c -c************************************************** -c -c -c -c this is a function subprogram copied from numerical recipes -c by w.h.press ,etl pp. 186-187. -c evaluates the general complete elliptic integral -c as the following function of four variables: -c -c cel(kc,p,a,b)= -c int[ (a+b*x**2)dx/{1+p*x**2)*sqrt((1+x**2)*(1+kc**2*x**2))} -c from x=0 to x=infinite -c - subroutine intend(a1,a2,z1,z2,m,xiend) -c Used for m even case, 0th derivative of on-axis gradient of a PMM. - implicit double precision(a-h,o-z) -c Evaluates the double integral from a1 to a2 and z1 to z2 of -c -c drho*dz/((rho**2+z**2)**(m/2+1/2)) -c -c using a polar coordinate approach. -c z1 or z2 can be zero; a1 and a2 are assumed to always be greater -c than zero. -c -c mMUST BE EVEN! -c -c mgreater than or equal to 2 -c - parameter(mmax=26) - dimension amk(mmax) -c data small/1.d-1/ - xm=dfloat(m) - xmm1=xm-1.d0 - mm1=m-1 - mhalf=m/2 - a12=a1**2 - a22=a2**2 - z12=z1**2 - z22=z2**2 - hyp12=a12+z22 - hyp22=a22+z22 - hyp32=a22+z12 - hyp42=a12+z12 - hyp1=dsqrt(hyp12) - hyp2=dsqrt(hyp22) - hyp3=dsqrt(hyp32) - hyp4=dsqrt(hyp42) - sin1=a1/hyp1 - sin2=a2/hyp2 - sin3=a2/hyp3 - sin4=a1/hyp4 - cos1=z2/hyp1 - cos2=z2/hyp2 - cos3=z1/hyp3 - cos4=z1/hyp4 -c Find coefficients for cosine**(m-1) and sine**(m-1) integrals-- -c they are the same for both--see Gradshtein&Ryzhik, p. 131. -c There are a total of m/2-1 coefficients. 2l+1 in G&R is m-1 here. -c Skip calculation of coeffficients if m=2 - if(m.lt.3) go to 2 - xnum=xm-2.d0 - dnom=xm-3.d0 - amk(1)=xnum/dnom - mhm1=mhalf-1 - if(mhm1.lt.2) go to 23 - do 22 j=2,mhm1 - jm1=j-1 - xnum=xnum-2 - dnom=dnom-2 - 22 amk(j)=amk(jm1)*xnum/dnom - 23 continue -c m>2 case-- use subroutine INTCOS -c RHS vertical line - call intcos(cos1,cos2,sin1,sin2,hyp12,hyp22,z2,amk,m,cosint) - xiend=cosint -c LHSvertical line - call intcos(cos3,cos4,sin3,sin4,hyp32,hyp42,z1,amk,m,cosint) - xiend=xiend+cosint -c Tophorizontal line - call intcos(sin1,sin4,cos1,cos4,hyp12,hyp42,a1,amk,m,cosint) - xiend=xiend+cosint -c Bottom horizontal line - call intcos(sin2,sin3,cos2,cos3,hyp22,hyp32,a2,amk,m,cosint) - xiend=xiend-cosint - xiend=xiend/dfloat(m-1) - return -c m=2case - 2 xiend=0.d0 - if(cos1.eq.0.d0) go to 3 - if(dabs(cos1).gt.0.1d0) go to 4 -c small angle formula used when z2 is small -c Floating-point numbers in the expression below are the coefficients -c theexpansion for (1+x)**(-1/2) - e12=z22/a12 - e22=z22/a22 - t2=(0.5d0-e22*(0.375d0-e22*(0.3125d0-e22*(0.2734375d0- - &e22*(0.24609375d0-e22*(0.2255859375d0- - &e22*(0.20947265625d0-e22*(0.196380615234375d0- - &e22*(0.1854705810546875d0- - &e22*0.1761970520019531d0)))))))))/a22 - t1=(0.5d0-e12*(0.375d0-e12*(0.3125d0-e12*(0.2734375d0- - &e12*(0.24609375d0-e12*(0.2255859375d0- - &e12*(0.20947265625d0-e12*(0.196380615234375d0- - &e12*(0.1854705810546875d0- - &e12*0.1761970520019531d0)))))))))/a12 - xiend=z2*(t2-t1) - go to 3 -c General (z2 not small) case - 4 xiend=(sin1-sin2)/z2 -c Left hand vertical line at z1 - 3 if(cos4.eq.0.d0) go to 5 - if(dabs(cos4).gt.0.1d0) go to 6 -c Small angle formula for small z1 - e12=z12/a12 - e22=z12/a22 - t2=(0.5d0-e22*(0.375d0-e22*(0.3125d0-e22*(0.2734375d0- - &e22*(0.24609375d0-e22*(0.2255859375d0- - &e22*(0.20947265625d0-e22*(0.196380615234375d0- - &e22*(0.1854705810546875d0- - &e22*0.1761970520019531d0)))))))))/a22 - t1=(0.5d0-e12*(0.375d0-e12*(0.3125d0-e12*(0.2734375d0- - &e12*(0.24609375d0-e12*(0.2255859375d0- - &e12*(0.20947265625d0-e12*(0.196380615234375d0- - &e12*(0.1854705810546875d0- - &e12*0.1761970520019531d0)))))))))/a12 - xiend=xiend-z1*(t2-t1) - go to 5 -c General (z1 not small) case - 6 xiend=xiend+(sin3-sin4)/z1 -c Upper and lower horizontal lines - 5 xiend=xiend+(cos1-cos4)/a1+(cos3-cos2)/a2 - return - end -c -c************************************************** -c - subroutine rhoint(a1,a2,s,is,m,nd,rhoin) -c Checked by numerical integration -c Used for gtype2 (thick Halbach) - implicit double precision(a-h,o-z) -c This subroutine evaluates the components of the vector rhoin, which -c arethe integrals -c integral from a1 to a2 dr of -c (r**(m+2))/((r**2+s**2)*(m+k+3/2)) , -c k=0,1,2,3,...nd-1 -c -c m=multipole index. m=1 for dipole, 2 for quad.,etc. m is > or = 1. -c ndis number of derivatives. This subroutine called only if nd > or -c - parameter(maxdrv=20,small=1.d-6,smal=5.d-2) - parameter(nterms=15) - parameter(maxcof=35) - common /dnms/ denom(maxcof,2,2) -c NTERMS is the number of terms used in the small-s expansion. Can be m -c large, while SMAL is also made larger, for check. - dimension rhoin(maxdrv),rhon1(maxdrv) - dimension rhon2(maxdrv),xirend(maxdrv) -c -c Calls subroutine RHOEND if m is even (2 or greater). -c -c First check to see if s is small or zero. If so, use expansion in s/a - x1=(s/a1)**2 - if(x1.lt.smal) go to 3 -c -c Next check to see if m is odd or even -c - a12=a1**2 - a22=a2**2 - x=dfloat(m+3)*0.5d0+small - iterms=x - dif=x-dfloat(iterms) - ileft=0 - if(dif.gt.0.1d0) ileft=1 -c ileft=0 if m is odd, =1 if m is even - if(ileft.gt.0) go to 1 -c m is odd - do 2 l=1,nd - 2 rhoin(l)=0.d0 -c Exponent on denominator in innermost term=n+k+1/2 ,k=0,1,..nd-1 - nmin=(m-1)/2 - a1prod=1.d0 - a2prod=1.d0 - itop=0 - ibot=m-2 - go to 5 - 1 continue -c m is even- descending series ends in an integral evaluated by RHOE - nmin=m/2 - call rhoend(a1,a2,s,is,m,nd,xirend) - do 6 l=1,nd - 6 rhoin(l)=-xirend(l) - a1prod=a1 - a2prod=a2 - itop=1 - ibot=m-1 - 5 itrm1=iterms-1 - np1=nmin+1 - do 8 i=1,itrm1 - itop=itop+2 - ibot=ibot+2 - do 10 l=1,nd - k=l-1 - np1pk=np1+k - 10 rhoin(l)=(rhoin(l)+a2prod*denom(np1pk,2,is)- - &a1prod*denom(np1pk,1,is))*dfloat(itop)/dfloat(ibot+2*k) - a1prod=a1prod*a12 - a2prod=a2prod*a22 - np1=np1+1 - 8 continue - ibot=ibot+2 - do 7 l=1,nd - k=l-1 - np1pk=np1+k - 7 rhoin(l)=-(rhoin(l)+a2prod*denom(np1pk,2,is)- - &a1prod*denom(np1pk,1,is))/dfloat(ibot+2*k) - return - 3 x2=(s/a2)**2 -c Small-s expansion algorithm -c No.of terms should be increased if quadruple precision, etc. is used - do 11 l=1,nd - k=l-1 - rhon1(l)=1.d0/dfloat(m+2*k) - rhon2(l)=rhon1(l) - xnum=dfloat(m+k+1)-0.5d0 - fac=1.d0 - y1=1.d0 - y2=1.d0 - do 9 n=1,nterms - xnum=xnum+1.d0 - y1=-y1*xnum*x1 - y2=-y2*xnum*x2 - fac=fac*dfloat(n) - dnm=1.d0/(fac*dfloat(m+2*(k+n))) - rhon1(l)=rhon1(l)+y1*dnm - rhon2(l)=rhon2(l)+y2*dnm - 9 continue - n=m+2*(l-1) - 11 rhoin(l)=rhon1(l)*a1**(-n)-rhon2(l)*a2**(-n) - return - end -c -c************************************************** -c - subroutine xngint(m,nint,a,s,xgi) - implicit double precision(a-h,o-z) - parameter(maxcof=35) - parameter(c83=8.d0/3.d0) - parameter(t3rds=2.d0/3.d0) - parameter(sv3rds=7.d0/3.d0) - common /bicof/ bcoeff(maxcof,maxcof) -c This subroutine calculates indefinite integrals to s of gm*x**(n-1), -c n=1,nint, fixed m. -c -c where gm=a**(1-m)*d/da((a**m)/(a**2+x**2)**(m+1/2)) -c -c maximum nint=5 -c "m =9 -c -c m=multipole index -c nint=no. of integrals, = no. of components in xgi -c xgi=vector of nint integrals -c a=coil radius - dimension xgi(5) -c bcoeff contains the binomial expansion coefficients up to order maxc -c input parameter checks - if(m.gt.100) go to 1001 - if(m.lt.1) go to 1002 - if(nint.gt.5) go to 1003 - if(a.le.0.d0) go to 1004 -c m=1and m=2 are treated specially - if(m.gt.1) go to 20 -c m=1case - a2=a**2 - ra2=1.d0/a2 - s2=s**2 - u2=a2+s2 - ru2=1.d0/u2 - u=dsqrt(u2) - ru=1.d0/u - xgi(1)=-s*(ra2+ru2)*ru - if(nint.lt.2) return - xgi(2)=-ru+a2*ru*ru2 - if(nint.lt.3) return - dl=dlog(s+u) - xgi(3)=-s*ru+dl+a2*s*ru2*ru+a2*ru/(s+u) - if(nint.lt.4) return - xgi(4)=u+a2*ru*(4.d0-a2*ru2) - if(nint.lt.5) return - xgi(5)=s*(0.5d0*u+ru*a2*(4.d0+s2*ru2))-4.5d0*a2*dl - return -c m=2case - 20 if(m.gt.2) go to 30 - a2=a**2 - a4=a2**2 - s2=s**2 - u2=a2+s2 - u22=u2**2 - u=dsqrt(u2) - ru=1.d0/u - ru2=1.d0/u2 - xgi(1)=(s*ru*(c83*s2*ru2-3.d0-(s2*ru2)**2))/a4 - if(nint.lt.2) return - xgi(2)=ru2*ru*(a2*ru2-t3rds) - if(nint.lt.3) return - xgi(3)=-s2*s/(u22*u) - if(nint.lt.4) return - xgi(4)=ru*(a2*ru2*(sv3rds-a2*ru2)-2.d0) - if(nint.lt.5) return - xgi(5)=2.d0*dlog(s+u)- - &s*ru*(2.d0+s2*ru2*(t3rds+ru2*s2)) - return - 30 continue -c m=3or greater - xm=dfloat(m) - mm1=m-1 - mm2=m-2 - mm3=m-3 - mp1=m+1 - xmm1=dfloat(mm1) - xmm2=dfloat(mm2) - a2=a**2 - a2m=a2**m - a2mm2=a2m/a2 - a2mm4=a2mm2/a2 - x2mp1=dfloat(2*m+1) - tmm1=dfloat(2*m-1) - tmm3=dfloat(2*m-3) - r1=xm/tmm3 - r2=dfloat(3*m+1)/tmm1 - z=s - zsq=z**2 - u2=zsq+a2 - ru2=1.d0/u2 - ur2=a2/u2 - u=dsqrt(u2) - rz2u2=zsq/u2 - rzu=z/u - rend=rz2u2**m*rzu - u2mm3=u2**mm2*u - u2mm1=u2*u2mm3 -c n=1 - sign=-1.d0 - sum=0.d0 - do 2 k=1,m - sign=-sign - k2m1=2*k-1 - km1=k-1 - tkm1=dfloat(k2m1) - if(km1.eq.0) go to 21 - term=rzu/tkm1*rz2u2**km1 - go to 22 - 21 term=rzu/tkm1 - 22 c=xm*bcoeff(k,mm1)-x2mp1*bcoeff(k,m) - 2 sum=sum+c*term*sign - sum=sum+sign*rend - sum=sum/a2m - xgi(1)=sum - if(nint.lt.2) return -c n=2 - term=(ur2-xm/tmm1)/u2mm1 - xgi(2)=term - if(nint.lt.3) return -c n=3 - sign=-1.d0 - sum=0.d0 - do 3 k=1,mm1 - km1=k-1 - sign=-sign - tkp1=dfloat(2*k+1) - term=rzu/tkp1*rz2u2**k - c=xm*bcoeff(k,mm2)-x2mp1*bcoeff(k,mm1) - 3 sum=sum+c*term*sign - sum=sum+sign*rend - sum=sum/a2mm2 - xgi(3)=sum - if(nint.lt.4) return -c n=4 - term=(r1-ur2*(r2-ur2))/u2mm3 - xgi(4)=-term - if(nint.lt.5) return -c n=5 - if(m.gt.3) go to 8 -c m=3is a special case - term=(rend-0.8d0*rzu*rz2u2**2)/a2 - xgi(5)=term - return - 8 sign=-1.d0 - sum=0.d0 - do 4 k=1,mm2 - tkp3=dfloat(2*k+3) - kp1=k+1 - sign=-sign - c=xm*bcoeff(k,mm3)-x2mp1*bcoeff(k,mm2) - term=rzu/tkp3*rz2u2**kp1 - 4 sum=sum+c*term*sign - sum=sum+sign*rend - sum=sum/a2mm4 - xgi(5)=sum - return - 1001 write(6,3001) - 3001 format(1x,'m greater than 100 in xngint-stopped') - stop - 1002 write(6,3002) - 3002 format(1x,'m less than 1 in xngint-stopped') - stop - 1003 write(6,3003) - 3003 format(1x,'nint greater than 5 in xngint-stopped') - stop - 1004 write(6,3004) - 3004 format(1x,'a less than or equal 0 in xngint-stopped') - stop - end -c -c************************************************** -c - subroutine zint(a1,a2,s1,s2,nmin,m,zinti) - implicit double precision(a-h,o-z) - parameter(maxcof=35) -c The array ZINTI contains the integrals from s1 to s2 of -c -c ds*a**2n/(a**2+s**2)**n+1/2, n=nmin,nmin+1,nmin+2,...m -c -c zinti(i,1) is evaluated at a1, zinti(i,2) at a2. -c The index i runs from 1 to m-nmin+1, with n=nmin for i=1, nmin+1 for -c i=2, etc. -c -c -c Uses analytical formula from Gradshtein and Ryzhik, p. 86. -c -c - common /bicof/ bcoeff(maxcof,maxcof) -c bcoeff(k,n) is an element of array containing the binomial coefficien -c index k goes from 1 to maxcof; elements with k>n+1 are zero. -c index n goes from 1 to maxcof - common/dnms/denom(maxcof,2,2) - dimension zinti(maxcof,2) - if(nmin.gt.0) go to 1 -c nmin=0 --- First term is a logarithmic expression, since m=1 -c There are two terms. - a12=a1**2 - a22=a2**2 - s12=s1**2 - s22=s2**2 -c fora1: - zinti(1,1)=dlog((s2+dsqrt(s22+a12))/(s1+dsqrt(s12+a12))) -c fora2: - zinti(1,2)=dlog((s2+dsqrt(s22+a22))/(s1+dsqrt(s12+a22))) -c fora1: - zinti(2,1)=s2*denom(1,1,2)-s1*denom(1,1,1) -c fora2: - zinti(2,2)=s2*denom(1,2,2)-s1*denom(1,2,1) - return -c nmin=1 or greater - 1 nterm=m-nmin+1 -c nterm is the number of elements in each of zinti(n,1) and zinti(n,2), -c separately. - s12=s1**2 - s22=s2**2 - s1n=s1 - s2n=s2 - do 2 l=1,nterm -c rho=a1 - zinti(l,1)=s2*denom(1,1,2)-s1*denom(1,1,1) -c rho=a2 - 2 zinti(l,2)=s2*denom(1,2,2)-s1*denom(1,2,1) - do 3 k=2,m - r2kp1=1.d0/dfloat(2*k-1) - s1n=-s12*s1n - s2n=-s22*s2n - ck1=s1n*r2kp1 - ck2=s2n*r2kp1 - lmin=1 - if(k.gt.nmin) lmin=k-nmin+1 - do 3 l=lmin,nterm - n=nmin+l-2 - ckl1=bcoeff(k,n)*ck1 - ckl2=bcoeff(k,n)*ck2 -c rho=a1 - zinti(l,1)=zinti(l,1)+ckl2*denom(k,1,2)-ckl1*denom(k,1,1) -c rho=a2 - 3 zinti(l,2)=zinti(l,2)+ckl2*denom(k,2,2)-ckl1*denom(k,2,1) - return - end -c -c************************************************** -c - subroutine intcos(cos1,cos2,sin1,sin2,r12,r22,x,amk,m,cosint) - implicit double precision(a-h,o-z) - dimension amk(m) -c This subroutine evaluates 1/x times the integral from phi1 to phi2 of -c -c (cos phi)**(m-1) * dphi -c -c used only for even m values -c -c when x is small, by definition cos1 and cos2 are small, and the -c result is well-behaved as x goes to zero. For small x, a small -c x expansion is used. Otherwise, the expression from Gradstein and -c Ryzhik, p. 131, is used to evaluate the integral, and the result is -c divided by x. -c analogous sine integral obtained by switching sine for cosines in -c call and changing the sign of COSINT. - if(cos1.eq.0.d0) go to 1 - xm=dfloat(m) - mhalf=m/2 - if(dabs(cos1).gt.0.1d0) go to 2 -c Usesmall angle Taylor series to evaluate integral - cos12=cos1**2 - cos22=cos2**2 - t2=1.d0/xm+cos22*(0.5d0/(xm+2.d0)+cos22*(0.375d0/(xm+4.d0)+ - &cos22*(0.3125d0/(xm+6.d0)+cos22*(0.2734375d0/(xm+8.d0)+ - &cos22*(0.24609375d0/(xm+1.d1)+cos22*(0.2255859375d0/ - &(xm+1.2d1)+cos22*(0.20947265625d0/(xm+1.4d1)+ - &cos22*(0.196380615234375d0/(xm+1.6d1)+ - &cos22*(0.1854705810546875d0/(xm+1.8d1)+ - &cos22*0.1761970520019531d0/(xm+2.d1)))))))))) - t1=1.d0/xm+cos12*(0.5d0/(xm+2.d0)+cos12*(0.375d0/(xm+4.d0)+ - &cos12*(0.3125d0/(xm+6.d0)+cos12*(0.2734375d0/(xm+8.d0)+ - &cos12*(0.24609375d0/(xm+1.d1)+cos12*(0.2255859375d0/ - &(xm+1.2d1)+cos12*(0.20947265625d0/(xm+1.4d1)+ - &cos12*(0.196380615234375d0/(xm+1.6d1)+ - &cos12*(0.1854705810546875d0/(xm+1.8d1)+ - &cos12*0.1761970520019531d0/(xm+2.d1)))))))))) - r1m=r12**(-mhalf) - r2m=r22**(-mhalf) - cosint=x*(t2*r2m-t1*r1m) - return -c General expression for cosine integral - 2 cosi2=cos2**2 - sini=sin2 - mhm1=mhalf-1 - mm1=m-1 - xmm1=dfloat(mm1) - temp=0.d0 - do 11 i=1,2 - cos2k=1.d0 - sum=0.d0 - do 12 j=1,mhm1 - k=mhm1-j+1 - sum=sum+amk(k)*cos2k - 12 cos2k=cos2k*cosi2 - sum=sum+cos2k - sum=sum*sini - if(i.eq.1) sum=-sum - temp=temp+sum - cosi2=cos1**2 - 11 sini=sin1 - cosint=temp/(xmm1*x**mm1) - return - 1 cosint=0.d0 - return - end -c -c************************************************** -c - subroutine rhoend(a1,a2,s,is,m,nd,xirend) -c Checked by numerical integration -c used for gtype2 (thick Halbach) - implicit double precision(a-h,o-z) - parameter(maxcof=35,maxdrv=20) - common /dnms/ denom(maxcof,2,2) - common /bicof/ bcoeff(maxcof,maxcof) - dimension xirend(maxdrv) -c This subroutine evaluates the integral from a1 to a2 of -c -c drho/(rho**2+s**2)**(m/2+k+1/2) , k=0,2,3....nd-1 -c -c s is assumed not to be small or zero-- if so, the subroutine calling -c one(i.e. RHOINT) uses a series expansion in s, and therefore does no -c call this one. -c -c THIS SUBROUTINE IS CALLED ONLY IF m IS EVEN (2 or GREATER). -c Also nd must be 1 or greater. -c -c Uses analytical formula from Gradshtein and Ryzhik, p. 86. -c -c is =1 for s1, 2 for s2 -c xirend is a vector of length nd containing the inetgrals - a12=a1**2 - a22=a2**2 - a1n=a1 - a2n=a2 - rs2=1.d0/s**2 - mo2=m/2 - kmax=mo2+nd-1 - do 2 l=1,nd - 2 xirend(l)=a2*denom(1,2,is)-a1*denom(1,1,is) - do 3 k=2,kmax - r2kp1=1.d0/dfloat(2*k-1) - a1n=-a12*a1n - a2n=-a22*a2n - ck1=a1n*r2kp1 - ck2=a2n*r2kp1 - lmin=1 - if(k.gt.mo2) lmin=k-mo2+1 - do 3 l=lmin,nd - n=mo2+l-2 - ckl1=bcoeff(k,n)*ck1 - ckl2=bcoeff(k,n)*ck2 - 3 xirend(l)=xirend(l)+ckl2*denom(k,2,is)-ckl1*denom(k,1,is) - if(m.gt.2) go to 6 - sfac=rs2 - go to 7 - 6 sfac=rs2**mo2 - 7 do 5 l=1,nd - xirend(l)=xirend(l)*sfac - if(l.eq.nd) go to 5 - sfac=sfac*rs2 - 5 continue - return - end -c -c************************************************** -c diff --git a/OpticsJan2020/MLI_light_optics/Src/makeit b/OpticsJan2020/MLI_light_optics/Src/makeit deleted file mode 100755 index cbedab0..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/makeit +++ /dev/null @@ -1,2 +0,0 @@ -cd ../Makedir -make diff --git a/OpticsJan2020/MLI_light_optics/Src/math.f b/OpticsJan2020/MLI_light_optics/Src/math.f deleted file mode 100644 index 0cbce9f..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/math.f +++ /dev/null @@ -1,2037 +0,0 @@ -*********************************************************************** -* header MATH UTILITIES * -* Routines for handling maps and general mathematical utilities * -*********************************************************************** -c - subroutine dcdiv(a,b,c,d,e,f) -c computes the complex division -c a + ib = (c + id)/(e + if) -c very slow, but tries to be as accurate as -c possible by changing the order of the -c operations, so to avoid under(over)flow -c problems. -c Written by F. Neri Feb. 12 1986 -c -c implicit none - double precision a,b,c,d,e,f - double precision s,t - double precision cc,dd,ee,ff - double precision temp - integer flip - flip = 0 - cc = c - dd = d - ee = e - ff = f - if( dabs(f).ge.dabs(e) ) then - ee = f - ff = e - cc = d - dd = c - flip = 1 - endif - s = 1.d0/ee - t = 1.d0/(ee+ ff*(ff*s)) - if ( dabs(ff) .ge. dabs(s) ) then - temp = ff - ff = s - s = temp - endif - if( dabs(dd) .ge. dabs(s) ) then - a = t*(cc + s*(dd*ff)) - else if ( dabs(dd) .ge. dabs(ff) ) then - a = t*(cc + dd*(s*ff)) - else - a = t*(cc + ff*(s*dd)) - endif - if ( dabs(cc) .ge. dabs(s)) then - b = t*(dd - s*(cc*ff)) - else if ( dabs(cc) .ge. dabs(ff)) then - b = t*(dd - cc*(s*ff)) - else - b = t*(dd - ff*(s*cc)) - endif - if (flip.ne.0 ) then - b = -b - endif - return - end -c -c ****************************************************************** -c - subroutine dhqr2(nm,n,low,igh,h,wr,wi,z,ierr) -c -c implicit none - integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn, - & igh,its,low,mp2,enm2,ierr - double precision h(nm,n),wr(n),wi(n),z(nm,n) - double precision p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,machep -c double precision dsqrt,dabs,dsign -c integer min0 - logical notlas -c complex z3 - double precision z3r,z3i -c complex cmplx -c double precision real,aimag -c -c -c -c this subroutine is a translation of the algol procedure hqr2, -c num. math. 16, 181-204(1970) by peters and wilkinson. -c handbook for auto. comp., vol.ii-linear algebra, 372-395(1971). -c -c this subroutine finds the eigenvalues and eigenvectors -c of a real upper hessenberg matrix by the qr method. the -c eigenvectors of a real general matrix can also be found -c if elmhes and eltran or orthes and ortran have -c been used to reduce this general matrix to hessenberg form -c and to accumulate the similarity transformations. -c -c on input- -c -c nm must be set to the row dimension of two-dimensional -c array parameters as declared in the calling program -c dimension statement, -c -c n is the order of the matrix, -c -c low and igh are integers determined by the balancing -c subroutine balanc. if balanc has not been used, -c set low=1, igh=n, -c -c h contains the upper hessenberg matrix, -c -c z contains the transformation matrix produced by eltran -c after the reduction by elmhes, or by ortran after the -c reduction by orthes, if performed. if the eigenvectors -c of the hessenberg matrix are desired, z must contain the -c identity matrix. -c -c on output- -c -c h has been destroyed, -c -c wr and wi contain the real and imaginary parts, -c respectively, of the eigenvalues. the eigenvalues -c are unordered except that complex conjugate pairs -c of values appear consecutively with the eigenvalue -c having the positive imaginary part first. if an -c error exit is made, the eigenvalues should be correct -c for indices ierr+1,...,n, -c -c z contains the real and imaginary parts of the eigenvectors. -c if the i-th eigenvalue is real, the i-th column of z -c contains its eigenvector. if the i-th eigenvalue is complex -c with positive imaginary part, the i-th and (i+1)-th -c columns of z contain the real and imaginary parts of its -c eigenvector. the eigenvectors are unnormalized. if an -c error exit is made, none of the eigenvectors has been found, -c -c ierr is set to -c zero for normal return, -c j if the j-th eigenvalue has not been -c determined after 30 iterations. -c -c arithmetic is double precision. complex division -c is simulated by routin dcdiv. -c -c fortran routine by b. s. garbow. -c modified by f. neri. -c -c -c ********** machep is a machine dependent parameter specifying -c the relative precision of floating point arithmetic. -c -c ********** - machep = 1.d-15 -c machep = r1mach(4) -c - ierr = 0 - norm = 0.0 - k = 1 -c ********** store roots isolated by balanc -c and compute matrix norm ********** - do 50 i = 1, n -c - do 40 j = k, n - 40 norm = norm + dabs(h(i,j)) -c - k = i - if (i .ge. low .and. i .le. igh) go to 50 - wr(i) = h(i,i) - wi(i) = 0.0 - 50 continue -c - en = igh - t = 0.0 -c ********** search for next eigenvalues ********** - 60 if (en .lt. low) go to 340 - its = 0 - na = en - 1 - enm2 = na - 1 -c ********** look for single small sub-diagonal element -c for l=en step -1 until low do -- ********** - 70 do 80 ll = low, en - l = en + low - ll - if (l .eq. low) go to 100 - s = dabs(h(l-1,l-1)) + dabs(h(l,l)) - if (s .eq. 0.0) s = norm - if (dabs(h(l,l-1)) .le. machep * s) go to 100 - 80 continue -c ********** form shift ********** - 100 x = h(en,en) - if (l .eq. en) go to 270 - y = h(na,na) - w = h(en,na) * h(na,en) - if (l .eq. na) go to 280 - if (its .eq. 30) go to 1000 - if (its .ne. 10 .and. its .ne. 20) go to 130 -c ********** form exceptional shift ********** - t = t + x -c - do 120 i = low, en - 120 h(i,i) = h(i,i) - x -c - s = dabs(h(en,na)) + dabs(h(na,enm2)) - x = 0.75 * s - y = x - w = -0.4375 * s * s - 130 its = its + 1 -c ********** look for two consecutive small -c sub-diagonal elements. -c for m=en-2 step -1 until l do -- ********** - do 140 mm = l, enm2 - m = enm2 + l - mm - zz = h(m,m) - r = x - zz - s = y - zz - p = (r * s - w) / h(m+1,m) + h(m,m+1) - q = h(m+1,m+1) - zz - r - s - r = h(m+2,m+1) - s = dabs(p) + dabs(q) + dabs(r) - p = p / s - q = q / s - r = r / s - if (m .eq. l) go to 150 - if (dabs(h(m,m-1)) * (dabs(q) + dabs(r)) .le. machep * dabs(p) - & * (dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1)))) go to 150 - 140 continue -c - 150 mp2 = m + 2 -c - do 160 i = mp2, en - h(i,i-2) = 0.0 - if (i .eq. mp2) go to 160 - h(i,i-3) = 0.0 - 160 continue -c ********** double qr step involving rows l to en and -c columns m to en ********** - do 260 k = m, na - notlas = k .ne. na - if (k .eq. m) go to 170 - p = h(k,k-1) - q = h(k+1,k-1) - r = 0.0 - if (notlas) r = h(k+2,k-1) - x = dabs(p) + dabs(q) + dabs(r) - if (x .eq. 0.0) go to 260 - p = p / x - q = q / x - r = r / x - 170 s = dsign(dsqrt(p*p+q*q+r*r),p) - if (k .eq. m) go to 180 - h(k,k-1) = -s * x - go to 190 - 180 if (l .ne. m) h(k,k-1) = -h(k,k-1) - 190 p = p + s - x = p / s - y = q / s - zz = r / s - q = q / p - r = r / p -c ********** row modification ********** - do 210 j = k, n - p = h(k,j) + q * h(k+1,j) - if (.not. notlas) go to 200 - p = p + r * h(k+2,j) - h(k+2,j) = h(k+2,j) - p * zz - 200 h(k+1,j) = h(k+1,j) - p * y - h(k,j) = h(k,j) - p * x - 210 continue -c - j = min0(en,k+3) -c ********** column modification ********** - do 230 i = 1, j - p = x * h(i,k) + y * h(i,k+1) - if (.not. notlas) go to 220 - p = p + zz * h(i,k+2) - h(i,k+2) = h(i,k+2) - p * r - 220 h(i,k+1) = h(i,k+1) - p * q - h(i,k) = h(i,k) - p - 230 continue -c ********** accumulate transformations ********** - do 250 i = low, igh - p = x * z(i,k) + y * z(i,k+1) - if (.not. notlas) go to 240 - p = p + zz * z(i,k+2) - z(i,k+2) = z(i,k+2) - p * r - 240 z(i,k+1) = z(i,k+1) - p * q - z(i,k) = z(i,k) - p - 250 continue -c - 260 continue -c - go to 70 -c ********** one root found ********** - 270 h(en,en) = x + t - wr(en) = h(en,en) - wi(en) = 0.0 - en = na - go to 60 -c ********** two roots found ********** - 280 p = (y - x) / 2.0 - q = p * p + w - zz = dsqrt(dabs(q)) - h(en,en) = x + t - x = h(en,en) - h(na,na) = y + t - if (q .lt. 0.0) go to 320 -c ********** real pair ********** - zz = p + dsign(zz,p) - wr(na) = x + zz - wr(en) = wr(na) - if (zz .ne. 0.0) wr(en) = x - w / zz - wi(na) = 0.0 - wi(en) = 0.0 - x = h(en,na) - s = dabs(x) + dabs(zz) - p = x / s - q = zz / s - r = dsqrt(p*p+q*q) - p = p / r - q = q / r -c ********** row modification ********** - do 290 j = na, n - zz = h(na,j) - h(na,j) = q * zz + p * h(en,j) - h(en,j) = q * h(en,j) - p * zz - 290 continue -c ********** column modification ********** - do 300 i = 1, en - zz = h(i,na) - h(i,na) = q * zz + p * h(i,en) - h(i,en) = q * h(i,en) - p * zz - 300 continue -c ********** accumulate transformations ********** - do 310 i = low, igh - zz = z(i,na) - z(i,na) = q * zz + p * z(i,en) - z(i,en) = q * z(i,en) - p * zz - 310 continue -c - go to 330 -c ********** complex pair ********** - 320 wr(na) = x + p - wr(en) = x + p - wi(na) = zz - wi(en) = -zz - 330 en = enm2 - go to 60 -c ********** all roots found. backsubstitute to find -c vectors of upper triangular form ********** - 340 if (norm .eq. 0.0) go to 1001 -c ********** for en=n step -1 until 1 do -- ********** - do 800 nn = 1, n - en = n + 1 - nn - p = wr(en) - q = wi(en) - na = en - 1 - if (q) 710, 600, 800 -c ********** real vector ********** - 600 m = en - h(en,en) = 1.0 - if (na .eq. 0) go to 800 -c ********** for i=en-1 step -1 until 1 do -- ********** - do 700 ii = 1, na - i = en - ii - w = h(i,i) - p - r = h(i,en) - if (m .gt. na) go to 620 -c - do 610 j = m, na - 610 r = r + h(i,j) * h(j,en) -c - 620 if (wi(i) .ge. 0.0) go to 630 - zz = w - s = r - go to 700 - 630 m = i - if (wi(i) .ne. 0.0) go to 640 - t = w - if (w .eq. 0.0) t = machep * norm - h(i,en) = -r / t - go to 700 -c ********** solve real equations ********** - 640 x = h(i,i+1) - y = h(i+1,i) - q = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) - t = (x * s - zz * r) / q - h(i,en) = t - if (dabs(x) .le. dabs(zz)) go to 650 - h(i+1,en) = (-r - w * t) / x - go to 700 - 650 h(i+1,en) = (-s - y * t) / zz - 700 continue -c ********** end real vector ********** - go to 800 -c ********** complex vector ********** - 710 m = na -c ********** last vector component chosen imaginary so that -c eigenvector matrix is triangular ********** - if (dabs(h(en,na)) .le. dabs(h(na,en))) go to 720 - h(na,na) = q / h(en,na) - h(na,en) = -(h(en,en) - p) / h(en,na) - go to 730 -c 720 z3 = cmplx(0.0,-h(na,en)) / cmplx(h(na,na)-p,q) -c h(na,na) = real(z3) -c h(na,en) = aimag(z3) - 720 call dcdiv(z3r,z3i,0.d0,-h(na,en),h(na,na)-p,q) - h(na,na) = z3r - h(na,en) = z3i - 730 h(en,na) = 0.0 - h(en,en) = 1.0 - enm2 = na - 1 - if (enm2 .eq. 0) go to 800 -c ********** for i=en-2 step -1 until 1 do -- ********** - do 790 ii = 1, enm2 - i = na - ii - w = h(i,i) - p - ra = 0.0 - sa = h(i,en) -c - do 760 j = m, na - ra = ra + h(i,j) * h(j,na) - sa = sa + h(i,j) * h(j,en) - 760 continue -c - if (wi(i) .ge. 0.0) go to 770 - zz = w - r = ra - s = sa - go to 790 - 770 m = i - if (wi(i) .ne. 0.0) go to 780 -c z3 = cmplx(-ra,-sa) / cmplx(w,q) -c h(i,na) = real(z3) -c h(i,en) = aimag(z3) - call dcdiv(z3r,z3i,-ra,-sa,w,q) - h(i,na) = z3r - h(i,en) = z3i - go to 790 -c ********** solve complex equations ********** - 780 x = h(i,i+1) - y = h(i+1,i) - vr = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) - q * q - vi = (wr(i) - p) * 2.0 * q - if (vr .eq. 0.0 .and. vi .eq. 0.0) vr = machep * norm - & * (dabs(w) + dabs(q) + dabs(x) + dabs(y) + dabs(zz)) -c z3 = cmplx(x*r-zz*ra+q*sa,x*s-zz*sa-q*ra) / cmplx(vr,vi) -c h(i,na) = real(z3) -c h(i,en) = aimag(z3) - call dcdiv(z3r,z3i,x*r-zz*ra+q*sa,x*s-zz*sa-q*ra,vr,vi) - h(i,na) = z3r - h(i,en) = z3i - if (dabs(x) .le. dabs(zz) + dabs(q)) go to 785 - h(i+1,na) = (-ra - w * h(i,na) + q * h(i,en)) / x - h(i+1,en) = (-sa - w * h(i,en) - q * h(i,na)) / x - go to 790 -c 785 z3 = cmplx(-r-y*h(i,na),-s-y*h(i,en)) / cmplx(zz,q) -c h(i+1,na) = real(z3) -c h(i+1,en) = aimag(z3) - 785 call dcdiv(z3r,z3i,-r-y*h(i,na),-s-y*h(i,en),zz,q) - h(i+1,na) = z3r - h(i+1,en) = z3i - 790 continue -c ********** end complex vector ********** - 800 continue -c ********** end back substitution. -c vectors of isolated roots ********** - do 840 i = 1, n - if (i .ge. low .and. i .le. igh) go to 840 -c - do 820 j = i, n - 820 z(i,j) = h(i,j) -c - 840 continue -c ********** multiply by transformation matrix to give -c vectors of original full matrix. -c for j=n step -1 until low do -- ********** - do 880 jj = low, n - j = n + low - jj - m = min0(j,igh) -c - do 880 i = low, igh - zz = 0.0 -c - do 860 k = low, m - 860 zz = zz + z(i,k) * h(k,j) -c - z(i,j) = zz - 880 continue -c - go to 1001 -c ********** set error -- no convergence to an -c eigenvalue after 30 iterations ********** - 1000 ierr = en - 1001 return -c ********** last card of dhqr2 ********** - end -c -c ****************************************************************** -c - subroutine dorhes(nm,n,low,igh,a,ort) -c implicit none - integer i,j,m,n,ii,jj,la,mp,nm,igh,kp1,low - double precision a(nm,n),ort(igh) - double precision f,g,h,scale -c double precision dsqrt,dabs,dsign -c -c this subroutine is a translation of the algol procedure orthes, -c num. math. 12, 349-368(1968) by martin and wilkinson. -c handbook for auto. comp., vol.ii-linear algebra, 339-358(1971). -c -c given a real general matrix, this subroutine -c reduces a submatrix situated in rows and columns -c low through igh to upper hessenberg form by -c orthogonal similarity transformations. -c -c on input- -c -c nm must be set to the row dimension of two-dimensional -c array parameters as declared in the calling program -c dimension statement, -c -c n is the order of the matrix, -c -c low and igh are integers determined by the balancing -c subroutine balanc. if balanc has not been used, -c set low=1, igh=n, -c -c a contains the input matrix. -c -c on output- -c -c a contains the hessenberg matrix. information about -c the orthogonal transformations used in the reduction -c is stored in the remaining triangle under the -c hessenberg matrix, -c -c ort contains further information about the transformations. -c only elements low through igh are used. -c -c fortran routine by b. s. garbow -c modified by filippo neri. -c -c - la = igh - 1 - kp1 = low + 1 - if (la .lt. kp1) go to 200 -c - do 180 m = kp1, la - h = 0.0 - ort(m) = 0.0 - scale = 0.0 -c ********** scale column (algol tol then not needed) ********** - do 90 i = m, igh - 90 scale = scale + dabs(a(i,m-1)) -c - if (scale .eq. 0.0) go to 180 - mp = m + igh -c ********** for i=igh step -1 until m do -- ********** - do 100 ii = m, igh - i = mp - ii - ort(i) = a(i,m-1) / scale - h = h + ort(i) * ort(i) - 100 continue -c - g = -dsign(dsqrt(h),ort(m)) - h = h - ort(m) * g - ort(m) = ort(m) - g -c ********** form (i-(u*ut)/h) * a ********** - do 130 j = m, n - f = 0.0 -c ********** for i=igh step -1 until m do -- ********** - do 110 ii = m, igh - i = mp - ii - f = f + ort(i) * a(i,j) - 110 continue -c - f = f / h -c - do 120 i = m, igh - 120 a(i,j) = a(i,j) - f * ort(i) -c - 130 continue -c ********** form (i-(u*ut)/h)*a*(i-(u*ut)/h) ********** - do 160 i = 1, igh - f = 0.0 -c ********** for j=igh step -1 until m do -- ********** - do 140 jj = m, igh - j = mp - jj - f = f + ort(j) * a(i,j) - 140 continue -c - f = f / h -c - do 150 j = m, igh - 150 a(i,j) = a(i,j) - f * ort(j) -c - 160 continue -c - ort(m) = scale * ort(m) - a(m,m-1) = scale * g - 180 continue -c - 200 return -c ********** last card of dorhes ********** - end -c -c ****************************************************************** -c - subroutine dorttr(nm,n,low,igh,a,ort,z) -c -c implicit none - integer i,j,n,kl,mm,mp,nm,igh,low,mp1 - double precision a(nm,igh),ort(igh),z(nm,n) - double precision g -c -c this subroutine is a translation of the algol procedure ortrans, -c num. math. 16, 181-204(1970) by peters and wilkinson. -c handbook for auto. comp., vol.ii-linear algebra, 372-395(1971). -c -c this subroutine accumulates the orthogonal similarity -c transformations used in the reduction of a real general -c matrix to upper hessenberg form by dorhes. -c -c on input- -c -c nm must be set to the row dimension of two-dimensional -c array parameters as declared in the calling program -c dimension statement, -c -c n is the order of the matrix, -c -c low and igh are integers determined by the balancing -c subroutine balanc. if balanc has not been used, -c set low=1, igh=n, -c -c a contains information about the orthogonal trans- -c formations used in the reduction by orthes -c in its strict lower triangle, -c -c ort contains further information about the trans- -c formations used in the reduction by dorhes. -c only elements low through igh are used. -c -c on output- -c -c z contains the transformation matrix produced in the -c reduction by dorhes, -c -c ort has been altered. -c -c fortran routine by b. s. garbow. -c modified by f. neri. -c -c -c ********** initialize z to identity matrix ********** - do 80 i = 1, n -c - do 60 j = 1, n - 60 z(i,j) = 0.0 -c - z(i,i) = 1.0 - 80 continue -c - kl = igh - low - 1 - if (kl .lt. 1) go to 200 -c ********** for mp=igh-1 step -1 until low+1 do -- ********** - do 140 mm = 1, kl - mp = igh - mm - if (a(mp,mp-1) .eq. 0.0) go to 140 - mp1 = mp + 1 -c - do 100 i = mp1, igh - 100 ort(i) = a(i,mp-1) -c - do 130 j = mp, igh - g = 0.0 -c - do 110 i = mp, igh - 110 g = g + ort(i) * z(i,j) -c ********** divisor below is negative of h formed in orthes. -c double division avoids possible underflow ********** - g = (g / ort(mp)) / a(mp,mp-1) -c - do 120 i = mp, igh - 120 z(i,j) = z(i,j) + g * ort(i) -c - 130 continue -c - 140 continue -c - 200 return -c ********** last card of dorttr ********** - end -c -************************************************************************ -c - subroutine drphse(fm) -c this subroutine readjusts the phases of the eigenvectors making up the -c matrix computed by the subroutine da2 in such a way that fm(1,2)=0 and -c fm(1,1).ge.0, etc. -c Written by Alex Dragt, Fall 1986 - include 'impli.inc' - dimension fm(6,6) - dimension t1m(6,6),t2m(6,6) -c -c clear the matrix t1m - call mclear(t1m) -c compute required phases - arg1=-fm(1,2) - arg2=fm(1,1) - wx=atan2(arg1,arg2) - arg1=-fm(3,4) - arg2=fm(3,3) - wy=atan2(arg1,arg2) - arg1=-fm(5,6) - arg2=fm(5,5) - wt=atan2(arg1,arg2) -c compute rephasing matrix - cwx=cos(wx) - swx=sin(wx) - cwy=cos(wy) - swy=sin(wy) - cwt=cos(wt) - swt=sin(wt) - 10 continue - t1m(1,1)=cwx - t1m(1,2)=swx - t1m(2,1)=-swx - t1m(2,2)=cwx - t1m(3,3)=cwy - t1m(3,4)=swy - t1m(4,3)=-swy - t1m(4,4)=cwy - t1m(5,5)=cwt - t1m(5,6)=swt - t1m(6,5)=-swt - t1m(6,6)=cwt -c rephase fm - call mmult(fm,t1m,t2m) -c check that t2m(1,1).ge.0 etc. - iflag=0 - if (t2m(1,1).lt.0.d0) then - iflag=1 - cwx=-cwx - swx=-swx - endif - if (t2m(3,3).lt.0.d0) then - iflag=1 - cwy=-cwy - swy=-swy - endif - if (t2m(5,5).lt.0.d0) then - iflag=1 - cwt=-cwt - swt=-swt - endif - if (iflag.eq.1) goto 10 - call matmat(t2m,fm) -c - return - end -c -************************************************************************ -c - subroutine dvsort(revec,aievec) -c this is a subroutine that sorts eigenvectors for a dynamic map. -c it also standardizes the magnitudes and signs of the eigenvctors. -c Written by Alex Dragt, Fall 1986 - include 'impli.inc' - dimension revec(6,6),aievec(6,6) - dimension rtv(6,6),aitv(6,6) - dimension r2v(2),ai2v(2) - dimension c(6),kpnt(6) -c store vectors in temporary array - do 10 i=1,5,2 - do 10 j=1,6 - rtv(i,j)=revec(i,j) - aitv(i,j)=aievec(i,j) - 10 continue -c find vertical components of vectors - do 20 i=1,5,2 - r2v(1)=rtv(i,3) - ai2v(1)=aitv(i,3) - r2v(2)=rtv(i,4) - ai2v(2)=aitv(i,4) - sqnrm=r2v(1)**2+ai2v(1)**2+r2v(2)**2+ai2v(2)**2 - c(i)=sqnrm - 20 continue -c find vector with the largest vertical component - kv=1 - big=c(1) - if(c(3).gt.big) big=c(3) - if(c(5).gt.big) big=c(5) - if(big.eq.c(3)) kv=3 - if(big.eq.c(5)) kv=5 -c set pointer - kpnt(3)=kv -c find horizontal components of vectors - do 30 i=1,5,2 - c(i)=0. - if(i.eq.kv) go to 30 - r2v(1)=rtv(i,1) - ai2v(1)=aitv(i,1) - r2v(2)=rtv(i,2) - ai2v(2)=aitv(i,2) - sqnrm=r2v(1)**2+ai2v(1)**2+r2v(2)**2+ai2v(2)**2 - c(i)=sqnrm - 30 continue -c find vector with the largest horizontal component - kh=1 - big=c(1) - if(c(3).gt.big) big=c(3) - if(c(5).gt.big) big=c(5) - if(big.eq.c(3)) kh=3 - if(big.eq.c(5)) kh=5 -c set pointer - kpnt(1)=kh -c find the remaining vector - do 40 i=1,5,2 - if (i.eq.kv) go to 40 - if (i.eq.kh) go to 40 - kt=i - 40 continue -c set pointer - kpnt(5)=kt -c reorder vectors - do 50 i=1,5,2 - k=kpnt(i) - do 60 j=1,6 - revec(i,j)=rtv(k,j) - aievec(i,j)=aitv(k,j) - 60 continue - 50 continue -c standardize magnitudes and signs -c the goal is to maximize revec(1,1), revec(3,3), and revec(5,5) - do 70 i=1,5,2 -c see if u and v should be interchanged - amaxu=abs(revec(i,i)) - amaxv=abs(aievec(i,i)) - if(amaxv.gt.amaxu) then - do 80 j=1,6 - unew=aievec(i,j) - vnew=-revec(i,j) - revec(i,j)=unew - aievec(i,j)=vnew - 80 continue - endif -c see if signs of u and v should be changed - if( revec(i,i) .lt. 0.d0) then - do 90 j=1,6 - revec(i,j)=-revec(i,j) - aievec(i,j)=-aievec(i,j) - 90 continue - endif - 70 continue - return - end -c -*********************************************************************** -c - subroutine egphse(fm) -c this subroutine readjusts the phases of the eigenvectors making up the -c matrix computed by the subroutine da2 in such a way that fm(2,1)=0 and -c fm(1,1).ge.0, etc. Consequently, when fm is transposed, the 1,2 entry -c will be zero, and the 1,1 entry will be .ge. 0, etc. -c Written by Alex Dragt, 5 June 1991 - include 'impli.inc' - dimension fm(6,6) - dimension t1m(6,6),t2m(6,6) -c -c clear the matrix t1m - call mclear(t1m) -c compute required phases - arg1=fm(2,1) - arg2=fm(2,2) - wx=0.d0 - if(arg1 .ne. 0.d0) wx=atan2(arg1,arg2) - arg1=fm(4,3) - arg2=fm(4,4) - wy=0.d0 - if(arg1 .ne. 0.d0) wy=atan2(arg1,arg2) - arg1=fm(6,5) - arg2=fm(6,6) - wt=0.d0 - if(arg1 .ne. 0.d0) wt=atan2(arg1,arg2) -c compute rephasing matrix - cwx=cos(wx) - swx=sin(wx) - cwy=cos(wy) - swy=sin(wy) - cwt=cos(wt) - swt=sin(wt) - 10 continue - t1m(1,1)=cwx - t1m(1,2)=swx - t1m(2,1)=-swx - t1m(2,2)=cwx - t1m(3,3)=cwy - t1m(3,4)=swy - t1m(4,3)=-swy - t1m(4,4)=cwy - t1m(5,5)=cwt - t1m(5,6)=swt - t1m(6,5)=-swt - t1m(6,6)=cwt -c rephase fm - call mmult(fm,t1m,t2m) -c check that t2m(1,1).ge.0 etc. - iflag=0 - if (t2m(1,1).lt.0.d0) then - iflag=1 - cwx=-cwx - swx=-swx - endif - if (t2m(3,3).lt.0.d0) then - iflag=1 - cwy=-cwy - swy=-swy - endif - if (t2m(5,5).lt.0.d0) then - iflag=1 - cwt=-cwt - swt=-swt - endif - if (iflag.eq.1) goto 10 - call matmat(t2m,fm) -c - return - end - -c -************************************************************************ -c - subroutine eig4(fm,reval,aieval,revec,aievec) -c this routine finds the eigenvalues and eigenvectors -c of the 4X4 upper left part of fm. -c the eigenvectors are normalized so that the real and -c imaginary part of vectors 1 and 3 have +1 antisymmetric -c product: -c revec1 J aivec1 = 1 ; revec3 J aivec3 = 1. -c the eigenvector 2 and 4 have the opposite normalization. -c written by F. Neri, Feb 26 1986. -c -c implicit none - integer i,j,ilo,ihi,nn,mdim,info - double precision fm(6,6),reval(6),aieval(6) - double precision revec(6,6),aievec(6,6),pbkt(6) - double precision vv(6,6),ort(6),aa(6,6) -c clear vector arrays - do 10 i=1,6 - do 20 j=1,6 - revec(j,i)=0. - aievec(j,i)=0. - vv(j,i) = 0. - 20 continue - 10 continue - ilo = 1 - ihi = 4 - mdim = 6 - nn = 4 -c copy matrix to temporary storage ( the matrix aa is destroyed). - do 100 i=1,6 - do 200 j=1,6 - aa(j,i) = fm(j,i) - 200 continue - 100 continue -c compute eigenvalues and vectors using double precision -c Eispack routines: - call dorhes(mdim,nn,ilo,ihi,aa,ort) - call dorttr(mdim,nn,ilo,ihi,aa,ort,vv) - call dhqr2(mdim,nn,ilo,ihi,aa,reval,aieval,vv,info) - if ( info .ne. 0 ) then - write(6,*) ' Something wrong in eig4' - return - endif - vv(5,5) = 1.d0 - vv(6,6) = 1.d0 - call neigv(vv,pbkt) - reval(5) = 1.d0 - reval(6) = 1.d0 - aieval(5) = 0.d0 - aieval(6) = 0.d0 - do 300 j=1,4 - revec(1,j) = vv(j,1) - revec(2,j) = vv(j,1) - revec(3,j) = vv(j,3) - revec(4,j) = vv(j,3) - aievec(1,j) = vv(j,2) - aievec(2,j) = -vv(j,2) - aievec(3,j) = vv(j,4) - aievec(4,j) = -vv(j,4) - 300 continue -c if poisson bracket is negative,change sign of imaginary part of -c eigenvalue - do 400 i=2,4,2 - if( pbkt(i) .lt. 0.d0 ) then - aieval(i-1) = -aieval(i-1) - aieval(i) = -aieval(i) - endif - 400 continue - revec(5,5) = 1.d0 - revec(6,6) = 1.d0 -c if eigenvalues are off the unit circle, print warning message: - do 600 i=1,4 - if(dabs(reval(i)**2+aieval(i)**2 - 1.d0).gt.1.d-10) then - write(6,*) ' Eig4: Eigenvalues off the unit circle!' - write(6,*) ' delta=',dabs(reval(i)**2+aieval(i)**2 - 1.d0) - return - endif - 600 continue - return - end -c -******************************************************************** -c - subroutine eig6(fm,reval,aieval,revec,aievec) -c this routine finds the eigenvalues and eigenvectors -c of the full matrix fm. -c the eigenvectors are normalized so that the real and -c imaginary part of vectors 1, 3, and 5 have +1 antisymmetric -c product: -c revec1 J aivec1 = 1 ; revec3 J aivec3 = 1 ; -c revec5 J aivec5 = 1. -c the eigenvectors 2 ,4, and 6 have the opposite normalization. -c written by F. Neri, Feb 26 1986. -c -c implicit none - integer nn - integer nnr,ilo,ihi,mdim,info - double precision reval(6),aieval(6),revec(6,6),aievec(6,6) - double precision fm(6,6),aa(6,6) - integer i,i1,j - double precision ort(6),vv(6,6) - double precision pbkt(6) -c copy matrix to temporary storage (the matrix aa is destroyed) - do 600 i=1,6 - do 600 i1=1,6 - aa(i1,i) = fm(i1,i) - 600 continue - ilo = 1 - ihi = 6 - mdim = 6 - nn = 6 -c compute eigenvalues and eigenvectors using double -c precision Eispack routines: - call dorhes(mdim,nn,ilo,ihi,aa,ort) - call dorttr(mdim,nn,ilo,ihi,aa,ort,vv) - call dhqr2(mdim,nn,ilo,ihi,aa,reval,aieval,vv,info) - if ( info .ne. 0 ) then - write(6,*) ' ERROR IN EIG6' - return - endif - call neigv(vv,pbkt) - do 700 j=1,6 - revec(1,j) = vv(j,1) - revec(2,j) = vv(j,1) - revec(3,j) = vv(j,3) - revec(4,j) = vv(j,3) - revec(5,j) = vv(j,5) - revec(6,j) = vv(j,5) - aievec(1,j) = vv(j,2) - aievec(2,j) = -vv(j,2) - aievec(3,j) = vv(j,4) - aievec(4,j) = -vv(j,4) - aievec(5,j) = vv(j,6) - aievec(6,j) = -vv(j,6) - 700 continue -c if poisson bracket is negative, change sign of imginary part of -c eigenvalue - do 800 i=2,6,2 - if( pbkt(i) .lt. 0.d0) then - aieval(i-1) = -aieval(i-1) - aieval(i ) = -aieval(i ) - endif - 800 continue -c if eigenvalues are off unit circle, print warning message: - do 900 i=1,6 - if(dabs(reval(i)**2+aieval(i)**2 -1.d0).gt.1.d-10) then - write(6,*) ' EIG6: Eigenvalues off the unit circle!' - return - endif - 900 continue - return - end -c -************************************************************************ -c - subroutine eigemt(idim,ha) -c This subroutine computes eigen emittances, etc. -c The array ha contains the incoming moments. -c As described below, rusults are put in buffers 1 through 5. -c This subroutine eventually needs to be improved because at present it -c does not deal properly with the case of degenerate eigenvalues. -c Written by Alex Dragt, 22 May 1991. -c Modified by Alex Dragt, 25 May 1998 to deal with -c phase spaces of various dimensions. -c Again modified 10/14/98 by AJD to change contents of buffers 1 and 2. -c - use lieaparam - include 'impli.inc' - include 'buffer.inc' -c - dimension ha(monoms) -c -c local arrays - dimension t1m(6,6), t2m(6,6) -c -c Case of 2-dimensional phase space -c - if (idim .eq. 2) then -c compute "diagonalizing" matrix and put it in the matrix part of buffer 1. - z11=ha(7) - if(z11 .le. 0.d0) then - write(6,*) 'error: is negative or zero' - return - endif - z12=ha(8) - z22=ha(13) - if(z22 .le. 0.d0) then - write(6,*) 'error: is negative or zero' - return - endif -c remove possibly offensive moments in 2-dimensional case. - do 2 i=7,27 - 2 ha(i)=0.d0 - ha(7)=z11 - ha(8)=z12 - ha(13)=z22 - emit2=z11*z22-z12**2 - if(emit2 .le. 0.d0) then - write(6,*) 'error: x emittance is zero or imaginary' - return - endif - emit=dsqrt(emit2) - beta=z11/emit - rbeta=dsqrt(beta) - alpha=-z12/emit - call mclear(buf1m) - buf1m(1,1)=1.d0/rbeta - buf1m(1,2)=alpha/rbeta - buf1m(2,1)=0.d0 - buf1m(2,2)=rbeta - buf1m(3,3)=1.d0 - buf1m(4,4)=1.d0 - buf1m(5,5)=1.d0 - buf1m(6,6)=1.d0 - go to 100 - endif -c -c Case of 4- and 6-dimensional phase space -c - if ((idim .eq. 4) .or. (idim .eq. 6)) then -c compute "diagonalizing" matrix and put it in the matrix part of buffer 1. -c -c Remove possibly offensive moments in 4-dimensional case. -c - if(idim .eq. 4) then - ha(11)=0.d0 - ha(12)=0.d0 - ha(16)=0.d0 - ha(17)=0.d0 - ha(20)=0.d0 - ha(21)=0.d0 - ha(23)=0.d0 - ha(24)=0.d0 - ha(25)=0.d0 - ha(26)=0.d0 - ha(27)=0.d0 - endif -c -c let Z denote the matrix with entries Zij=. -c compute the polynomial -(1/2)*(z,Zz) and temporarily -c put result in buf2a - do 5 i=7,27 - 5 buf2a(i)=-ha(i) - buf2a(7)=buf2a(7)/2.d0 - buf2a(13)=buf2a(13)/2.d0 - buf2a(18)=buf2a(18)/2.d0 - buf2a(22)=buf2a(22)/2.d0 - buf2a(25)=buf2a(25)/2.d0 - buf2a(27)=buf2a(27)/2.d0 -c -c matify buf2a. this should produce the matrix JZ. - call matify(buf1m,buf2a) -c compute norm of buf1m=JZ. - call mnorm(buf1m,ans) -c compute taylor series result buf2m=exp(scale*buf1m) - scale=.1d0/ans - call smmult(scale,buf1m,buf1m) - call exptay(buf1m,buf2m) -c compute normal form transformation - if (idim .eq. 4) call sa2(buf2m,buf2a,buf1m) - if (idim .eq. 6) call da2(buf2m,buf2a,buf1m) -c - endif !cryne 8/9/2002 - 100 continue -c -c rephase and transpose result - call egphse(buf1m) - call mtran(buf1m) -cryne 8/9/2002 moved endif to before "100 continue" endif -c -c act on moments with "diagonalizing" matrix and put result in buf2a -c letting the map (matrix) act on moments amounts to computing buf2a = D*ha -c -c clear arrays (the array buf2a has already been cleared by da2) -c temporarily use buf3a, buf4a, and buf5a. - do 10 i=1,monoms - buf3a(i)=0.d0 - 10 buf4a(i)=0.d0 -c -c compute "diagonalized" moments only through 2'nd moments - imax=27 -c -c perform calculation - do 20 i=7,imax - buf3a(i)=1.d0 - call fxform(buf4a,buf1m,buf3a,buf5a) - buf3a(i)=0.d0 - do 30 j=1,imax - 30 buf2a(i)=buf2a(i)+buf5a(j)*ha(j) - 20 continue -c -c put result in buf1a - do 40 i=7,monoms - 40 buf1a(i)=buf2a(i) -c -c at this stage buf1m contains the "diagonalizing" matrix. -c put this matrix in buf2m, and put the inverse of the -c diagonalizing matrix in buf1m. - call matmat(buf1m,buf2m) - call inv(buf3a,buf1m) -c -c put original moments in buf2a - do 50 i=7,monoms - 50 buf2a(i)=ha(i) -c -c compute results for buffers 3 through 5 -c need to compute buf1m*diagj*(buf1m transpose) for j=X,Y,Tau, -c and then multiply the result by eigemitj. -c - call matmat(buf1m,t1m) - call mtran(t1m) -c - call mclear(t2m) - t2m(1,1)=1.d0 - t2m(2,2)=1.d0 - call mmult(buf1m,t2m,buf3m) - call mmult(buf3m,t1m,buf3m) - scale=buf1a(7) - call smtof(scale,buf3m,buf3a) -c - call mclear(t2m) - t2m(3,3)=1.d0 - t2m(4,4)=1.d0 - call mmult(buf1m,t2m,buf4m) - call mmult(buf4m,t1m,buf4m) - scale=buf1a(18) - call smtof(scale,buf4m,buf4a) -c - call mclear(t2m) - t2m(5,5)=1.d0 - t2m(6,6)=1.d0 - call mmult(buf1m,t2m,buf5m) - call mmult(buf5m,t1m,buf5m) - scale=buf1a(25) - call smtof(scale,buf5m,buf5a) -c - return - end -c -************************************************************************ -c - subroutine exptay(em,fm) -c this subroutine computes fm=exp(em) using a finite taylor series -c Written by Alex Dragt, Fall 1986, based on work of Liam Healy - include 'impli.inc' - include 'id.inc' - dimension em(6,6),fm(6,6),tm1(6,6),tm2(6,6) -c -c initialize fm and tm1 to be the identity matrix - call matmat(ident,fm) - call matmat(ident,tm1) -c -c begin calculation - kmax=10 - do 10 k=1,kmax - rk=1.d0/float(k) - call mmult(em,tm1,tm2) - call smmult(rk,tm2,tm1) - call madd(fm,tm1,fm) - 10 continue -c - return - end -c -*********************************************************************** -c - subroutine leshs(soln, dim,matrix,rhs,augm,det) -c Linear Equation Solver HandShaking routine. -c Interfaces Etienne's need for linear equation solutions with my -c 'solver'. -c Written by Liam Healy, May 9, 1985. -c -c----Variables---- -c dim = size of linear space - integer dim -c matrix = matrix supplied (dim x dim) -c rhs = right hand side of equation, supplied (dim) -c augm = augmented martrix (dim x dim+1), set up with arbitrary -c contents by calling routine -c det = determinant of original matrix - double precision matrix(dim,dim),rhs(dim),soln(dim),det - double precision augm(dim,dim+1) -c -c----Routine---- - do 120 i=1,dim - do 100 j=1,dim - 100 augm(i,j)=matrix(i,j) - 120 augm(i,dim+1)=rhs(i) - call solver(augm,dim,det) - do 140 i=1,dim - 140 soln(i)=augm(i,dim+1) - return - end -c - subroutine madd(a,b,c) -c This is a subroutine for adding two matrices. -c Written by Alex Dragt on 11 Nov 1985. - double precision a(6,6),b(6,6),c(6,6) - do 10 j=1,6 - do 10 i=1,6 - 10 c(i,j)=a(i,j)+b(i,j) - return - end -c -*********************************************************************** -c - subroutine matmat(a,b) -c This is a subroutine for copying a matrix. -c Written by Alex Dragt on 11 Nov 1985. - double precision a(6,6),b(6,6) -c---Routine--- - do 10 j=1,6 - do 10 i=1,6 - 10 b(i,j)=a(i,j) - return - end -c -*********************************************************************** -c - subroutine mmult(a,b,c) -c This is a subroutine for matrix multiplication. -c Written by Alex Dragt on Friday, 13 Sept 1985. - double precision a(6,6),b(6,6),c(6,6),ct(6,6),sum -c----Routine---- - do 10 k=1,6 - do 20 i=1,6 - sum = 0.d0 - do 30 j=1,6 - sum = sum + a(i,j)*b(j,k) - 30 continue - ct(i,k) = sum - 20 continue - 10 continue - call matmat(ct,c) -c - return - end -c -*********************************************************************** -c - subroutine mnorm(fm,res) -c Computes the norm (maximum column sum norm) for the matrix fm. -c Reference: L. Collatz, Functional Analysis & Numerical Mathematics, -c p.177 -c Written by Alex Dragt, Fall 1986, based on work of Liam Healy - include 'impli.inc' - dimension fm(6,6),sum(6) -c -c initialize variables - res=0.d0 - do 100 j=1,6 - 100 sum(j)=0.d0 -c -c perform calculation - do 120 j=1,6 - do 110 i=1,6 - 110 sum(j)=sum(j)+abs(fm(i,j)) - 120 res=max(res,sum(j)) -c - return - end -c -*********************************************************************** -c - subroutine neigv(m,pbkt) -c this subroutine normalizes the eigenvectors of -c a stable ( all roots on the unit circle ) symplectic -c matrix. on entry m has on the odd numbered colums -c the real part of the eigenvectors, on the even ones -c the imaginary parts. only one real (imaginary ) vector -c is included of each complex conjugate pair. -c on exit the vectors are rescaled so that the poisson -c brackets of the real x imaginary parts are equal to 1. -c also, the real and imaginary parts of each eigenvector -c are made orthogonal. -c the resulting matrix is symplectic. when used in sa2 or da2, -c it tranforms -c the original matrix to block diagonal form, with the -c blocks being 2 dimensional rotations. -c WARNING: this only works if the eigenvalues are on -c the unit circle. -c written by F. Neri Feb 10 1986. -c implicit none - integer n - parameter ( n = 3 ) - double precision m(2*n,2*n),pbkt(2*n) - double precision pb,s - double precision usq,vsq,udotv,a,b,phi(6),sn,cn,unew,vnew - integer k,iq,ip,i,j -c rescale u and v - do 10 k=1,5,2 - pb = 0.d0 - do 20 ip = 2,2*n,2 - iq = ip-1 - pb = pb + m(iq,k)*m(ip,k+1) - m(ip,k)*m(iq,k+1) - 20 continue - s = dsqrt(dabs(pb)) -c write(6,*) ' PB=',pb - pbkt(k) = pb - pbkt(k+1)=pb - do 30 i=1,2*n - m(i,k) = m(i,k)/s - m(i,k+1) = m(i,k+1)*(s/pb) - 30 continue - 10 continue -c orthogonalize u and v -c compute required phase - do 40 k=1,5,2 - usq=0.d0 - vsq=0.d0 - udotv=0.d0 - do 50 j=1,6 - usq=usq+m(j,k)**2 - vsq=vsq+m(j,k+1)**2 - udotv=udotv+m(j,k)*m(j,k+1) - 50 continue - phi(k)=0.d0 - a=udotv - if(a.eq.0.d0) goto 40 - b=(usq-vsq)/2.d0 - phi(k)=(1/2.d0)*atan2(-a,b) - 40 continue -c transform u and v - do 60 k=1,5,2 - sn=sin(phi(k)) - cn=cos(phi(k)) - do 70 j=1,6 - unew=cn*m(j,k)-sn*m(j,k+1) - vnew=sn*m(j,k)+cn*m(j,k+1) - m(j,k)=unew - m(j,k+1)=vnew - 70 continue - 60 continue - return - end -c end of file - subroutine pmadd(f,n,coeff,h) - implicit double precision (a-h,o-z) - include 'len.inc' - dimension f(923),h(923) - if(n.eq.1)then - istart=1 - else - istart=len(n-1)+1 - endif -c - if(coeff.eq.1.d0) goto 20 -cryne do 10 i=len(n-1)+1,len(n) - do 10 i=istart,len(n) - h(i) = h(i) + f(i)*coeff - 10 continue - return - 20 continue -cryne do 30 i = len(n-1)+1, len(n) - do 30 i = istart, len(n) - h(i) = h(i) + f(i) - 30 continue - return - end -c - subroutine product(a,na,b,nb,c) - use lieaparam, only : monoms - implicit double precision(a-h,o-z) - include 'len.inc' - include 'expon.inc' - include 'vblist.inc' -cryne 7/23/2002 common/expon/expon -cryne 7/23/2002 common/vblist/vblist -cryne 7/23/2002 common /len/ len(16) -cryne 7/23/2002 integer expon(6,0:923),vblist(6,0:923) - dimension a(923),b(923),c(923),l(6) - if(na.eq.1) then - ia1 = 1 - else - ia1 = len(na-1)+1 - endif - if(nb.eq.1) then - ib1 = 1 - else - ib1 = len(nb-1)+1 - endif - do 200 ia=ia1,len(na) - if(a(ia).eq.0.d0) goto 200 - do 20 ib = ib1,len(nb) - if(b(ib).eq.0.d0) goto 20 - do 2 m=1,6 - l(m) = expon(m,ia) + expon(m,ib) - 2 continue - n = ndex(l) - c(n) = c(n) + a(ia)*b(ib) - 20 continue - 200 continue - return - end -c -******************************************************************** -c - subroutine pttodp(f,ft) -c -c This subroutine converts a power series in the variable Ptau -c (which is the negative of the normalized energy deviation) to a power -c series in the normalized momentum deviation [deltap=(delta p)/p]. -c This routine works through third order. -c Reference: A. Dragt and M. Venturini, Relation between Expansions -c in Energy and Momentum Deviation Variables, U.MD. Physics Dept. -c Technical Report (1995). -c Written in Sept. 1995 by A. Dragt and M. Venturini -c -c f is an aray containing the coefficients of the power -c series in terms of the variable Ptau. -c ft is a transformed aray that contains the coefficients -c of the transformed power series in terms of the variable deltap. -c The transformation uses the matrix a(i,j). -c - use beamdata - include 'impli.inc' - dimension f(*), ft(*) - dimension a(3,3) -c -c Set up transforming coefficients -c - beta2=beta*beta - beta3=beta2*beta - beta4=beta2*beta2 - beta5=beta2*beta3 -c - a(1,1)= -beta - a(2,1)=(-beta + beta3)/(2.d0) - a(2,2)= beta2 - a(3,1)=( beta3 - beta5)/(2.d0) - a(3,2)= beta2 - beta4 - a(3,3)= -beta3 -c -c Make transformation -c - ft(1)=a(1,1)*f(1) - ft(2)=a(2,1)*f(1) + a(2,2)*f(2) - ft(3)=a(3,1)*f(1) + a(3,2)*f(2) + a(3,3)*f(3) -c - return - end -c -******************************************************************* -c - subroutine seig6(fm,reval,revec) -c this routine finds the eigenvalues and eigenvectors -c of a real symmetric 6x6 matrix -c the eigenvectors are normalized so that related pairs (those -c with eigenvalues eval and 1/eval) have antisymmetric product: -c revec1 J revec2 = 1 ; revec3 J revec4 = 1 ; -c revec5 J revec6 = 1. -c further details about normalization and ordering -c conventions may be gleaned from examination of the code -c written by A. Dragt 20 March 1987 -c - include 'impli.inc' - dimension fm(6,6),reval(6),revec(6,6) - dimension aieval(6),ort(6),pbkt(6) - dimension tm(6,6),vv(6,6) -c -c begin computation -c -c copy matrix to temporary storage (the matrix tm is destroyed) - call matmat(fm,tm) -c -c set up control indices - ilo = 1 - ihi = 6 - mdim = 6 - nn = 6 -c -c compute eigenvalues and eigenvectors using double -c precision Eispack routines: - call dorhes(mdim,nn,ilo,ihi,tm,ort) - call dorttr(mdim,nn,ilo,ihi,tm,ort,vv) - call dhqr2(mdim,nn,ilo,ihi,tm,reval,aieval,vv,info) - if ( info .ne. 0 ) then - write(6,*) ' Error in seig6 from Eispack routines ' - return - endif -c -c sort eigenvalues and eigenvectors into related pairs -c -c normalize eigenvectors to have unit Euclidean norm - do 10 i=1,6 - vsq=0.d0 - do 20 j=1,6 - vsq=vsq+vv(j,i)**2 - 20 continue - rv=1.d0/sqrt(vsq) - do 30 k=1,6 - revec(k,i)=rv*vv(k,i) - 30 continue - 10 continue -c find largest eigenvalue - big=0.d0 - do 40 i=1,6 - if (reval(i).gt.big) then - big=reval(i) - imax1=i - endif - 40 continue -c find its reciprocal pair based on symplectic 2-form J - big=0.d0 - do 50 i=1,6 - if (i.eq.imax1) goto 50 - call s2f(revec,imax1,i,val) - aval=abs(val) - if (aval.gt.big) then - big=aval - imax1r=i - endif - 50 continue -c find second largest eigenvalue - big=0.d0 - do 60 i=1,6 - if (i.eq.imax1 .or. i.eq.imax1r) goto 60 - if (reval(i).gt.big) then - big=reval(i) - imax2=i - endif - 60 continue -c find its reciprocal pair based on symplectic 2-form J - big=0.d0 - do 70 i=1,6 - if (i.eq.imax1 .or. i.eq.imax1r .or. i.eq.imax2) goto 70 - call s2f(revec,imax2,i,val) - aval=abs(val) - if (aval.gt.big) then - big=aval - imax2r=i - endif - 70 continue -c find third largest eigenvalue - big=0.d0 - do 80 i=1,6 - if (i.eq.imax1 .or. i.eq.imax1r) goto 80 - if (i.eq.imax2 .or. i.eq.imax2r) goto 80 - if (reval(i).gt.big) then - big=reval(i) - imax3=i - endif - 80 continue -c find its reciprocal pair by elimination - do 90 i=1,6 - if (i.eq.imax1 .or. i.eq.imax1r) goto 90 - if (i.eq.imax2 .or. i.eq.imax2r) goto 90 - if (i.eq.imax3) goto 90 - imax3r=i - 90 continue -c -c renormalize eigenvectors - call s2f(revec,imax1,imax1r,prd) - aprod=abs(prd) - sign=1.d0 - if (prd.lt.0.d0) sign=-1.d0 - rfact=1.d0/sqrt(aprod) - do 100 i=1,6 - vv(i,imax1)=rfact*revec(i,imax1) - vv(i,imax1r)=sign*rfact*revec(i,imax1r) - 100 continue - call s2f(revec,imax2,imax2r,prd) - aprod=abs(prd) - sign=1.d0 - if (prd.lt.0.d0) sign=-1.d0 - rfact=1.d0/sqrt(aprod) - do 110 i=1,6 - vv(i,imax2)=rfact*revec(i,imax2) - vv(i,imax2r)=sign*rfact*revec(i,imax2r) - 110 continue - call s2f(revec,imax3,imax3r,prd) - aprod=abs(prd) - sign=1.d0 - if (prd.lt.0.d0) sign=-1.d0 - rfact=1.d0/sqrt(aprod) - do 120 i=1,6 - vv(i,imax3)=rfact*revec(i,imax3) - vv(i,imax3r)=sign*rfact*revec(i,imax3r) - 120 continue -c -c rearrange eigenvectors - do 130 i=1,6 - revec(i,1)=vv(i,imax1) - revec(i,2)=vv(i,imax1r) - revec(i,3)=vv(i,imax2) - revec(i,4)=vv(i,imax2r) - revec(i,5)=vv(i,imax3) - revec(i,6)=vv(i,imax3r) - 130 continue -c -c rearrange eigenvalues - do 140 i=1,6 - aieval(i)=reval(i) - 140 continue - reval(1)=aieval(imax1) - reval(2)=aieval(imax1r) - reval(3)=aieval(imax2) - reval(4)=aieval(imax2r) - reval(5)=aieval(imax3) - reval(6)=aieval(imax3r) -c - return - end -c -*********************************************************************** -c - subroutine smmult(s,a,b) -c This is a subroutine for multiplying a matrix by a scalar. -c Written by Alex Dragt on 11 Nov 1985. - double precision s,a(6,6),b(6,6) -c---Routine--- - do 10 j=1,6 - do 10 i=1,6 - 10 b(i,j)=s*a(i,j) - return - end -c -*********************************************************************** -c - subroutine solver(augmat,dim,det) -c Solves the linear equation -c m*a = b -c where m is n by n -c On entry : augmat = m augmented by b -c dim = n -c On return: matrix = identity augmented by a -c det = determinant of m -c Coded from a routine originally written for the HP41C calculator -c (Dearing, p.46). Written by Liam Healy, February 14, 1985. -c -c----Variables---- -c dim= dimension of matrix - integer dim -c matrix= input matrix m, vector = input and output vector - double precision augmat(dim,dim+1) -c det = determinant returned - double precision det -c row,col,r,c,roff,rs = row and column numbers, row and column indices, -c row offset, row number for finding max - integer row,col,r,c,roff,rs -c nrow,ncol = total number of rows and columns - integer nrow,ncol -c me, mer, h = matrix element and its row number, held value of mat elt -c const = constant used in multiplication - double precision me,h,const - integer mer -c -c----Routine---- - det=1. - nrow=dim - ncol=dim+1 - col=0 - do 100 row=1,nrow - 300 col=col+1 - if (col.le.ncol) then -c find max of abs of mat elts in this col, and its row number - me=0. - mer=0 - do 120 rs=row,nrow - if (abs(augmat(rs,col)).ge.abs(me)) then - me=augmat(rs,col) - mer=rs - endif - 120 continue - det=det*me - if (me.eq.0.) goto 300 - do 140 c=1,ncol - augmat(mer,c)=augmat(mer,c)/me - 140 continue - r=0 - if (mer.ne.row) then -c swap the rows - do 160 c=1,ncol - h=augmat(mer,c) - augmat(mer,c)=augmat(row,c) - augmat(row,c)=h - 160 continue - det=-det - endif - 320 r=r+1 - if (r.le.nrow.and.row.lt.nrow) then - if (r.eq.row) goto 320 -c multiply row row by const & subtract from row r - const=augmat(r,col) - do 180 c=1,ncol - augmat(r,c)=augmat(r,c)-augmat(row,c)*const - 180 continue - goto 320 - endif - endif - 100 continue -c -c Matrix is now in upper triangular form. -c To solve equation, must get it to the identity. - do 200 roff=nrow,1,-1 - do 200 row=roff-1,1,-1 - const=augmat(row,roff) - do 200 c=row,ncol - augmat(row,c)=augmat(row,c)-const*augmat(roff,c) - 200 continue - return - end -c -************************************************************************ -c - subroutine srphse(fm) -c this subroutine readjusts the phases of the eigenvectors making up the -c matrix computed by the subroutine sa2 in such a way that fm(1,2)=0 and -c fm(1,1).ge.0, etc. -c Written by Alex Dragt, Fall 1986 - include 'impli.inc' - dimension fm(6,6) - dimension t1m(6,6),t2m(6,6) -c -c clear the matrix t1m - call mclear(t1m) -c compute required phases - arg1=-fm(1,2) - arg2=fm(1,1) - wx=atan2(arg1,arg2) - arg1=-fm(3,4) - arg2=fm(3,3) - wy=atan2(arg1,arg2) -c compute rephasing matrix - cwx=cos(wx) - swx=sin(wx) - cwy=cos(wy) - swy=sin(wy) - 10 continue - t1m(1,1)=cwx - t1m(1,2)=swx - t1m(2,1)=-swx - t1m(2,2)=cwx - t1m(3,3)=cwy - t1m(3,4)=swy - t1m(4,3)=-swy - t1m(4,4)=cwy - t1m(5,5)=1.d0 - t1m(6,6)=1.d0 -c rephase fm - call mmult(fm,t1m,t2m) -c check that t2m(1,1).ge.0 etc. - iflag=0 - if (t2m(1,1).lt.0.d0) then - iflag=1 - cwx=-cwx - swx=-swx - endif - if (t2m(3,3).lt.0.d0) then - iflag=1 - cwy=-cwy - swy=-swy - endif - if (iflag.eq.1) goto 10 - call matmat(t2m,fm) -c - return - end -c -*********************************************************************** -c - subroutine svsort(revec,aievec) -c this is a subroutine that sorts eigenvectors for a static map. -c it also standardizes the magnitudes and signs of the eigenvectors. -c Written by Alex Dragt, Fall 1986 - include 'impli.inc' - dimension revec(6,6),aievec(6,6) - dimension rtv(6,6),aitv(6,6) - dimension r2v(2),ai2v(2) - dimension c(6),kpnt(6) -c store vectors in temporary array - do 10 i=1,3,2 - do 10 j=1,6 - rtv(i,j)=revec(i,j) - aitv(i,j)=aievec(i,j) - 10 continue -c find vertical components of vectors - do 20 i=1,3,2 - r2v(1)=rtv(i,3) - ai2v(1)=aitv(i,3) - r2v(2)=rtv(i,4) - ai2v(2)=aitv(i,4) - sqnrm=r2v(1)**2+ai2v(1)**2+r2v(2)**2+ai2v(2)**2 - c(i)=sqnrm - 20 continue -c find vector with the largest vertical component - kv=1 - big=c(1) - if(c(3).gt.big) kv=3 -c set pointer - kpnt(3)=kv -c find the remaining vector - do 30 i=1,3,2 - if (i.eq.kv) go to 30 - kh=i - 30 continue -c set pointer - kpnt(1)=kh -c reorder vectors - do 40 i=1,3,2 - k=kpnt(i) - do 50 j=1,6 - revec(i,j)=rtv(k,j) - aievec(i,j)=aitv(k,j) - 50 continue - 40 continue -c standardize magnitudes and signs -c the goal is to maximize revec(1,1) and revec(3,3) - do 60 i=1,3,2 -c see if u and v should be interchanged - amaxu=abs(revec(i,i)) - amaxv=abs(aievec(i,i)) - if(amaxv.gt.amaxu) then - do 70 j=1,6 - unew=aievec(i,j) - vnew=-revec(i,j) - revec(i,j)=unew - aievec(i,j)=vnew - 70 continue - endif -c see if signs of u and v should be changed - if( revec(i,i) .lt. 0.d0) then - do 80 j=1,6 - revec(i,j)=-revec(i,j) - aievec(i,j)=-aievec(i,j) - 80 continue - endif - 60 continue - return - end -c -************************************************************************ -c - subroutine sympl1(fm) - include 'impli.inc' - dimension fm(6,6) - return - end -c -************************************************************************ -c - subroutine sympl2(fm) - include 'impli.inc' - dimension fm(6,6) - return - end -c -*********************************************************** -c -c SYMPL3 -c -c********************************************************** -c -c Written by F. Neri Feb 7 1986 -c - subroutine sympl3(m) -c implicit none - integer n - parameter ( n = 3 ) - double precision m(2*n,2*n) -c -c On return ,the matrix m(*,*), supposed to be almost -c symplectic on entry is made exactly symplectic by -c using a non iterative, constructive method. -c - double precision qq,pq,qp,pp - integer kp,kq,lp,lq,jp,jq,i -c - do 100 kp=2,2*n,2 - kq = kp-1 - do 200 lp=2,kp-2,2 - lq = lp-1 - qq = 0.d0 - pq = 0.d0 - qp = 0.d0 - pp = 0.d0 - do 300 jp=2,2*n,2 - jq = jp-1 - qq = qq + m(lq,jq)*m(kq,jp) - m(lq,jp)*m(kq,jq) - pq = pq + m(lp,jq)*m(kq,jp) - m(lp,jp)*m(kq,jq) - qp = qp + m(lq,jq)*m(kp,jp) - m(lq,jp)*m(kp,jq) - pp = pp + m(lp,jq)*m(kp,jp) - m(lp,jp)*m(kp,jq) - 300 continue -c write(6,*) qq,pq,qp,pp - do 400 i=1,2*n - m(kq,i) = m(kq,i) - qq*m(lp,i) + pq*m(lq,i) - m(kp,i) = m(kp,i) - qp*m(lp,i) + pp*m(lq,i) - 400 continue - 200 continue - qp = 0.d0 - do 500 jp=2,2*n,2 - jq = jp-1 - qp = qp + m(kq,jq)*m(kp,jp) - m(kq,jp)*m(kp,jq) - 500 continue -c write(6,*) qp - do 600 i=1,2*n - m(kp,i) = m(kp,i)/qp - 600 continue -c -c Maybe the following is a better idea ( uses sqrt and is slower ) -c sign = 1.d0 -c if ( qp.lt.0.d0 ) sign = -1.d0 -c OR, BETTER: -c if ( qp.le.0.d0 ) then complain -c qp = dabs(qp) -c qp = dsqrt(qp) -c do 600 i=1,2*n -c m(kq,i) = m(kq,i)/qp -c m(kp,i) = sign*m(kp,i)/qp -c 600 continue - 100 continue - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/meri.f b/OpticsJan2020/MLI_light_optics/Src/meri.f deleted file mode 100644 index 27933bc..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/meri.f +++ /dev/null @@ -1,793 +0,0 @@ -************************************************************************ -* header MERIT FUNCTIONS -* Weighted sum of sqares and user specified merit functions -*********************************************************************** -c - subroutine mrt0(pp) -c -c This is the weighted sum of squares or the square root of -c weighted sum of squares merit function defined by aims for -c loop pp(2). -c -c T. Mottershead, LANL Feb 89; A. Dragt 7/10/98 -c----------------------------------------------------- - include 'impli.inc' - include 'merit.inc' -c - dimension pp(*) -c -c gather the computed function values -c - kind = nint(pp(1)) - loon = nint(pp(2)) -c write(6,*) 'in mrt0' - temp = rmserr(loon) - if (kind .eq. 1) fval = temp**2 - if (kind .eq. 2) fval = temp - val(0) = fval -c - return - end -c -***************************************************************** -c - subroutine mrt1(p) -c - include 'impli.inc' - include 'merit.inc' - common/count/ifcnt,igcnt,ihcnt -c -c Calling arrays: - dimension p(6) -c -c Local arrays: - dimension c(10), a(10), b(10) -c - write(6,*) 'in mrt1' - ifcnt=ifcnt+1 -c - fcn = 0.d0 - n=6 - kc = n/2 - do 10 i= 1,n - c(i) = i-kc - a(i) = 2 + mod(i,3) - b(i) = mod(i,kc) - next = 1 + mod(i,n) - fcn = fcn + a(i)*(p(i) + b(i)*p(next)- c(i))**2 - 10 continue - val(1) = fcn - return - end -c -************************************************************************ -c - subroutine mrt2(p) -c - include 'impli.inc' - include 'merit.inc' - include 'parset.inc' - include 'usrdat.inc' -c -c Calling arrays: - dimension p(6) -c -c set up sum of squares merit function based -c on contents of ucalc -c -c get strengths of octupole components of cfqds - res1=ucalc(1) - res2=ucalc(2) - res3=ucalc(3) -c get strengths of remaining octupoles - res4=ucalc(4) - res5=ucalc(5) - res6=ucalc(6) - res7=ucalc(7) -c form sum of squares of cfqds octupole strengths - sscf=res1**2 + res2**2 + res3**2 -c form sum of squares of remaining octupole strengths - sso=res4**2 + res5**2 + res6**2 + res7**2 -c form full sum of squares - sst = sscf + sso -c divide by 7 (the number of octupoles) - wss = sst/7.d0 -c square root and square result - rwssq = sqrt(wss) - wss = rwssq**2 -c assign value - val(2)=wss -c - return - end -c -************************************************************************ -c - subroutine mrt3(p) -c - include 'impli.inc' - include 'merit.inc' -c -c Calling arrays: - dimension p(6) - write(6,*) 'in mrt3' - val(3)=p(3) - return - end -c -************************************************************************ -c - subroutine mrt4(p) -c - include 'impli.inc' - include 'merit.inc' -c -c Calling arrays: - dimension p(6) - write(6,*) 'in mrt4' - val(4)=p(4) - return - end -c -************************************************************************ -c - subroutine mrt5(p) -c -c provides standard set of optimization test problems -c C. T. Mottershead LANL AT-3 19 Mar 93 -c------------------------------------------------------------ - include 'impli.inc' - include 'merit.inc' - include 'parset.inc' -c -c Calling arrays: - dimension p(6), xv(6) -c write(6,*) 'in mrt5' - mode = nint(p(1)) - numf = nint(p(2)) - nvar = nint(p(3)) - npset = nint(p(4)) - if((npset.lt.1).or.(npset.gt.maxpst)) then - write(6,*) ' *** mrt5 error:' - write(6,*) npset,' is not a valid parameter set' - return - endif - isend = nint(p(5)) - do 20 j = 1, nvar - xv(j) = pst(j,npset) - 20 continue - call optest(mode, numf, nvar, xv, fval) - val(5) = fval - return - end -c -c end of file - subroutine optest(mode,numf,nv,xv,fv) -c -c selects and evaluates at (xv(i), i=1,nv) test function number numf -c from the standard suite from R. Schnabel, U. Colo -c C. T. Mottershead AT-3 19 Mar 93 -c------------------------------------------------- - implicit double precision (a-h,o-z) - character*24 remark(20), title - character*6 fcname(20) - dimension maxvar(20), xv(*) - external fcn03,fcn04,fcn05,fcn07,fcn09,fcn12,fcn14 - *, fcn16,fcn18,fcn20,fcn21,fcn22,fcn23,fcn24,fcn25 - *, fcn26,fcn35,fcn36,fcn37,fcn38 - data maxvar /3*2,3*3,2*4,11*6,4/, ndone /0/ - if(ndone.eq.0) call fcnlbl(num,remark,fcname) - ndone = 1 -c -c list available test functions -c - if(mode.eq.1) then - write(6,*) num,' test functions available' - kpr = (num + 1)/2 - do 20 k=1,kpr - k2 = k+kpr - write(6,27) k, fcname(k), remark(k), k2, fcname(k2), remark(k2) - 27 format(2(i4,'= ',a6,': ',a24)) - 20 continue - go to 80 - endif -c -c evaluate selected function -c - if((numf.le.0).or.(numf.gt.20)) go to 77 - title = remark(numf) - if(nv.gt.maxvar(numf)) nv=maxvar(numf) - write(6,51) nv,numf,title - 51 format(i5,' variables in test function',i3,': ',a) - go to (61,62,63,64,65,66,67,68,69,70,71,72,73,24,25,26,35,36 - * ,37,38), numf - 61 call fcn03(nv, xv, fv) - go to 80 - 62 call fcn04(nv, xv, fv) - go to 80 - 63 call fcn05(nv, xv, fv) - go to 80 - 64 call fcn07(nv, xv, fv) - go to 80 - 65 call fcn09(nv, xv, fv) - go to 80 - 66 call fcn12(nv, xv, fv) - go to 80 - 67 call fcn14(nv, xv, fv) - go to 80 - 68 call fcn16(nv, xv, fv) - go to 80 - 69 call fcn18(nv, xv, fv) - go to 80 - 70 call fcn20(nv, xv, fv) - go to 80 - 71 call fcn21(nv, xv, fv) - go to 80 - 72 call fcn22(nv, xv, fv) - go to 80 - 73 call fcn23(nv, xv, fv) - go to 80 - 24 call fcn24(nv, xv, fv) - go to 80 - 25 call fcn25(nv, xv, fv) - go to 80 - 26 call fcn26(nv, xv, fv) - go to 80 - 35 call fcn35(nv, xv, fv) - go to 80 - 36 call fcn36(nv, xv, fv) - go to 80 - 37 call fcn37(nv, xv, fv) - go to 80 - 38 call fcn38(nv, xv, fv) - 80 return - 77 write(6,*) numf, ' = invalid function number' - return - end -c -cccccccccccccccccccccccccc fcnlbl ccccccccccccccccccccccccccccccccccc -c - subroutine fcnlbl(num,remark,fcname) - character*24 remark(*) - character*6 fcname(*) - num = 0 -c - num = num + 1 - remark(num) = 'POWELLS BADLY SCALED' - fcname(num) = 'FCN03' -c - num = num + 1 - remark(num) = 'BROWN BADLY SCALED' - fcname(num) = 'FCN04' -c - num = num + 1 - remark(num) = 'BEALE' - fcname(num) = 'FCN05' -c - num = num + 1 - remark(num) = 'HELICAL VALLEY' - fcname(num) = 'FCN07' -c - num = num + 1 - remark(num) = 'GAUSSIAN' - fcname(num) = 'FCN09' -c - num = num + 1 - remark(num) = 'BOX 3D' - fcname(num) = 'FCN12' -c - num = num + 1 - remark(num) = 'WOOD' - fcname(num) = 'FCN14' -c - num = num + 1 - remark(num) = 'BROWN-DENNIS' - fcname(num) = 'FCN16' -c - num = num + 1 - remark(num) = 'BIGGS EXP' - fcname(num) = 'FCN18' -c - num = num + 1 - remark(num) = 'WATSON' - fcname(num) = 'FCN20' -c - num = num + 1 - remark(num) = 'ROSENBROCK BANANA VALLEY' - fcname(num) = 'FCN21' -c - num = num + 1 - remark(num) = 'POWELL SINGULAR' - fcname(num) = 'FCN22' -c - num = num + 1 - remark(num) = 'PENALTY I' - fcname(num) = 'FCN23' -c - num = num + 1 - remark(num) = 'PENALTY II' - fcname(num) = 'FCN24' -c - num = num + 1 - remark(num) = 'VARIABLE DIMENSION' - fcname(num) = 'FCN25' -c - num = num + 1 - remark(num) = 'TRIGONOMETRIC' - fcname(num) = 'FCN26' -c - num = num + 1 - remark(num) = 'CHEBYQUAD' - fcname(num) = 'FCN35' -c - num = num + 1 - remark(num) = 'ROSENBROCK BADLY SCALED' - fcname(num) = 'FCN36' -c - num = num + 1 - remark(num) = 'QUADRATIC FORM' - fcname(num) = 'FCN37' -c - num = num + 1 - remark(num) = 'BERZ' - fcname(num) = 'FCN38' - return - end -c -cccccccccccccccccccccccc powell bad scale cccccccccccccccccccccccccc -c - subroutine fcn03(n,x,f) - implicit double precision (a-h, o-z) -c -c powell"s badly scaled function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - f=(1.d4*x(1)*x(2)-1.d0)**2 + (exp(-x(1))+exp(-x(2))-1.0001d0)**2 - return - end -c -ccccccccccccccccccccccc brown bad scale ccccccccccccccccccc -c - subroutine fcn04(n,x,f) - implicit double precision (a-h, o-z) -c -c brown badly scaled function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - f=(x(1)-1.d6)**2 + (x(2)-2.d-6)**2 + (x(1)*x(2)-2.d0)**2 - return - end -c -cccccccccccccccccccccccccccccccc beale ccccccccccccccccccccccccc -c - subroutine fcn05(n,x,f) - implicit double precision (a-h, o-z) -c -c beale function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - f=(1.5d0-1.0d0*x(1)*(1.d0-1.0d0*x(2)))**2 - + + (2.25d0 -1.0d0*x(1)*(1.d0-1.0d0*x(2)*x(2)))**2 - + + (2.625d0-1.0d0*x(1)*(1.d0-1.d0*x(2)*x(2)*x(2)))**2 - return - end -c -ccccccccccccccccccccccccc helical valley cccccccccccccccccccccc -c - subroutine fcn07(n,x,f) - implicit double precision (a-h, o-z) -c -c helical valley function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 -c pi=3.1415926535898 - pi=3.1415926535897931d0 - if(x(1).gt. 0.d0) th= (1.d0/(2.d0*pi)) * atan(x(2)/x(1)) - if(x(1).lt. 0.d0) th= (1.d0/(2.d0*pi)) * atan(x(2)/x(1))+0.5d0 - f=100.d0*(x(3)-10.d0*th)**2 - + +100.d0*(sqrt(x(1)**2 + x(2)**2)-1.d0)**2 - + + x(3)*x(3) - return - end -c -cccccccccccccccccccccc odd gaussian cccccccccccccccccccccccccc -c - subroutine fcn09(n,x,f) - implicit double precision (a-h, o-z) -c -c gaussian function -c - dimension x(n),y(15) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - y(1)=.0009d0 - y(2)=.0044d0 - y(3)=.0175d0 - y(4)=.0540d0 - y(5)=.1295d0 - y(6)=.2420d0 - y(7)=.3521d0 - y(8)=.3989d0 - y(9)= y(7) - y(10)=y(6) - y(11)=y(5) - y(12)=y(4) - y(13)=y(3) - y(14)=y(2) - y(15)=y(1) - g=0.d0 - do 10 i=1,15 - g=g + (x(1)*exp( -x(2)*((8.d0-i)/2.d0-x(3))**2/2.d0) - y(i))**2 - 10 continue - f=g - return - end -c -ccccccccccccccccccccccccccc 3D box ccccccccccccccccccccccc -c - subroutine fcn12(n,x,f) - implicit double precision (a-h, o-z) -c -c box 3-dimensional function(n,x,f) -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - g=0.d0 - do 10 i=1,n - t=i/10.d0 - g=g + (exp(-t*x(1)) - exp(-t*x(2)) - + - x(3)*(exp(-t)-exp(-10.d0*t)))**2 - 10 continue - f=g - return - end -c -ccccccccccccccccccccccccccc wood cccccccccccccccccccccccccccc -c - subroutine fcn14(n,x,f) - implicit double precision (a-h, o-z) -c -c wood function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - f=100.d0*(x(2)-x(1)*x(1))**2 + (1.d0-x(1))**2 - + + 90.d0*(x(4)-x(3)*x(3))**2 + (1.d0-x(3))**2 - + +10.1d0*( (1.d0-x(2))**2 + (1.d0-x(4))**2) - + +19.8d0*(1.d0-x(2))*(1.d0-x(4)) - return - end -c -cccccccccccccccccccccccccc brown-dennis cccccccccccccccccccccccccccc -c - subroutine fcn16(n,x,f) - implicit double precision (a-h, o-z) -c -c brown + dennis function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - g=0.d0 - do 10 i=1,20 - t=i/5.d0 - g=g + ((x(1)+t*x(2)-exp(t))**2 - + + (x(3)+x(4)*sin(t)-cos(t))**2 )**2 - 10 continue - f=g - return - end -c -ccccccccccccccccccccccccc biggs exp6 cccccccccccccccccccccccc -c - subroutine fcn18(n,x,f) - implicit double precision (a-h, o-z) -c -c biggs exp6 function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - g=0.d0 - do 10 i=1,13 - t=i/10.d0 - g=g + (x(3)*exp(-t*x(1))-x(4)*exp(-t*x(2)) - + + x(6)*exp(-t*x(5))-exp(-t)+5.d0*exp(-10.d0*t) - + - 3.d0*exp(-4.d0*t) )**2 - 10 continue - f=g - return - end -c -ccccccccccccccccccccccccc watson cccccccccccccccccccccccccccccc -c - subroutine fcn20(n,x,f) - implicit double precision (a-h, o-z) -c -c watson function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - g=0.d0 - do 40 i=1,29 - t=i/29.d0 - sum=0.d0 - s=1.d0 - do 20 j=2,n - sum=sum + (j-1)*x(j)*s - s=t*s - 20 continue - sum2=0.d0 - s=1.d0 - do 30 j=1,n - sum2=sum2 + x(j)*s - s=t*s - 30 continue - g=g + (sum - sum2*sum2 - 1.d0)**2 - 40 continue - g=g + x(1)*x(1) + (x(2)-x(1)**2-1.d0)**2 - f=g - return - end -c -ccccccccccccccccccccccc extended rosenbrock cccccccccccccccccccccc -c - subroutine fcn21(n,x,f) - implicit double precision (a-h, o-z) -c -c extended rosenbrock function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - g=0.d0 - j=n/2 - do 10 i=1,j - g=g+ 100.d0*(x(2*i)- x(2*i-1)**2)**2 + (1.d0-x(2*i-1))**2 - 10 continue - f=g - return - end -c -ccccccccccccccccccccccc powell singular cccccccccccccccccccccccc -c - subroutine fcn22(n,x,f) - implicit double precision (a-h, o-z) -c -c extended powell singular function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - g=0.d0 - j=n/4 - do 10 i=1,j - g=g + (x(4*i-3) + 10.d0*x(4*i-2))**2 - + + 5.d0*(x(4*i-1) - x(4*i))**2 - + + ( (x(4*i-2)-2.d0*x(4*i-1))**2)**2 - + + 10.d0*( (x(4*i-3)-x(4*i))**2)**2 - 10 continue - f=g - return - end -c -ccccccccccccccccccccccccccccccc penalty I ccccccccccccccccccc -c - subroutine fcn23(n,x,f) - implicit double precision (a-h, o-z) -c -c penalty function i -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - g=0.d0 - do 20 i=1,n - g=g + (1.d-5) * (x(i)-1.d0)**2 - 20 continue - sum=0.d0 - do 30 j=1,n - sum=sum + x(j)*x(j) - 30 continue - g=g + (sum-.25d0)**2 - f=g - return - end -c -ccccccccccccccccccccccccccccccc penalty II cccccccccccccccccccc -c - subroutine fcn24(n,x,f) - implicit double precision (a-h, o-z) -c -c penalty function ii -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - g=(x(1)-.2d0)**2 - do 10 i=2,n - t=exp(i/10.d0) + exp((i-1)/10.d0) - g=g + 1.d-5* (exp(x(i)/10.d0) + exp(x(i-1)/10.d0) - t)**2 - 10 continue - m1=n+1 - m2=2*n-1 - do 20 i=m1,m2 - g=g + 1.d-5* (exp(x(i-n+1)/10.d0) - exp(1.d0/10.d0))**2 - 20 continue - sum=0.d0 - do 30 j=1,n - sum=sum + (n-j+1)*x(j)*x(j) - 30 continue - g=g + (sum-1.d0)**2 - f=g - return - end -c -ccccccccccccccccccccccccccccc variable dimension ccccccccccccccccc -c - subroutine fcn25(n,x,f) - implicit double precision (a-h, o-z) -c -c variably dimensioned function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - g=0.d0 - do 10 i=1,n - g=g + (x(i)-1.d0)**2 - 10 continue - s=0.d0 - do 20 i=1,n - s=s + i*(x(i)-1.d0) - 20 continue - g=g + s*s + (s*s)**2 - f=g - return - end -c -cccccccccccccccccccccc trigonometric cccccccccccccccccccccc -c - subroutine fcn26(n,x,f) - implicit double precision (a-h, o-z) -c -c trigonometric function -c - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - g=0.d0 - sum=0.d0 - do 10 j=1,n - sum=sum + cos(x(j)) - 10 continue - do 20 i=1,n - g=g+ (n-sum + i*(1.d0-cos(x(i))) - sin(x(i)) )**2 - 20 continue - f=g - return - end -c -ccccccccccccccccccccccccc chebyquad cccccccccccccccccccccccccccccccccc -c - subroutine fcn35(n,x,f) - implicit double precision (a-h, o-z) -c -c chebyquad function -c - dimension x(n) -c work arrays passed thru common dimensioned .ge. n - common y1(100),y2(100),y3(100) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 -c - sum=0.d0 - do 10 j=1,n - y1(j)=2.d0*x(j)-1.d0 - sum=sum+y1(j) - 10 continue - g=(sum/n)**2 -c - sum=0.d0 - do 20 j=1,n - y2(j)=2.d0*(2.d0*x(j)-1.d0)*y1(j)-1.d0 - sum=sum+y2(j) - 20 continue - g=g+ (sum/n + 1.d0/3.d0)**2 -c - sum=0.d0 - do 30 j=1,n - y3(j)=2.d0*(2.d0*x(j)-1.d0)*y2(j)-y1(j) - sum=sum+y3(j) - 30 continue - g=g+(sum/n)**2 -c - do 40 i=4,n -c i-th component - sum=0.d0 - do 35 j=1,n - y1(j)=y2(j) - y2(j)=y3(j) - y3(j)=2.d0*(2.d0*x(j)-1.d0)*y3(j)-y1(j) - sum=sum+y3(j) - 35 continue - k=mod(i,2) - if(k.eq.1) g=g+(sum/n)**2 - if(k.eq.0) g=g+(sum/n + 1.d0/(i*i-1))**2 - 40 continue - f=g - return - end -c -ccccccccccccccccccccccc extended rosenbrock badscale ccccccccccccccccccc -c - subroutine fcn36(n,x,f) - implicit double precision (a-h,o-z) -c -c extended rosenbrock badly scaled function -c - dimension x(n) - parameter (alpha = 1.0d-2) - dimension xt(10) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 - g=0.d0 - j=n/2 - do 10 i=1,j - xt(2*i-1) = x(2*i-1)*alpha - xt(2*i) = x(2*i)/alpha - g=g+ 100.d0*(xt(2*i)- xt(2*i-1)**2)**2 + (1.d0-xt(2*i-1))**2 - 10 continue - f=g - return - end -c -ccccccccccccccccccccccccccccccc quad cccccccccccccccccccccccccccc -c - subroutine fcn37(n,x,fv) -c -c rotated quadratic form with minimum of n at x(k) = k, k=1,n -c C. T. Mottershead LANL AT3 22 Mar 93 -c------------------------------------------------------------ - implicit double precision (a-h,o-z) - dimension x(n), c(10), a(10), b(10) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 -c - fv = n - do 10 k = 1,n - ak = k - km = k-1 - if(km.lt.1) km = n - akm = km - kp = k+1 - if(kp.gt.n) kp = 1 - akp = kp - fv = fv + ak*(x(k)-ak + x(kp)-akp - x(km)+akm)**2 - 10 continue - return - end -c -ccccccccccccccccccccccccccccccc berz cccccccccccccccccccccccccccc -c - subroutine fcn38(n,x,f) - implicit double precision (a-h,o-z) - dimension x(n) - common/count/ifcnt,igcnt,ihcnt - ifcnt=ifcnt+1 -c - f = x(1)**4 + x(2)**2 + dabs( x(2)**3 + x(4)**3) + - $ 13.0d0 * x(3)**2 + (x(2) - x(3)**2)**2 - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/mpi.f b/OpticsJan2020/MLI_light_optics/Src/mpi.f deleted file mode 100644 index f3c9d46..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/mpi.f +++ /dev/null @@ -1,161 +0,0 @@ - blockdata mpifbd - logical mpif_initialized - common /MPILCOMN/ mpif_initialized - data mpif_initialized/.FALSE./ - end - - subroutine MPI_SEND( ) - include 'mpif.h' - print*,'in MPI_SEND: not implemented' - stop 'MPISEND' - end - - subroutine MPI_RECV( ) - include 'mpif.h' - print*,'in MPI_RECV: not implemented' - stop 'MPRECV' - end - - subroutine MPI_GET_COUNT( ) - include 'mpif.h' - print*,'in MPI_GET_COUNT: not implemented' - stop 'MPGETC' - end - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine MPI_ALLGATHER( Sendbuf,SendCount,SendType - & ,recvbuf,RecvCount,RecvType - & ,Comm,ierror ) - include 'mpif.h' - integer Sendbuf(*) ,SendCount,SendType - & ,recvbuf(*) ,RecvCount,RecvType ,Comm ,ierror - ! ignore possible differences in type and count - call MPI_ALLREDUCE( Sendbuf,recvbuf,RecvCount,RecvType - & ,MPI_SUM,Comm,ierror ) - if( ierror .NE. 0 )then - print*,'error: MPI_ALLGATHER: error in MPI_ALLREDUCE()' - else - ! check for count and type differences - if( SendCount .NE. RecvCount )then - ierror = 99 - elseif( SendType .NE. RecvType )then - ierror = 98 - endif - endif - return - end - - - subroutine MPI_ALLREDUCE( Sendbuf,recvbuf,Count,Datatype,Op,Comm - & ,ierror ) - include 'mpif.h' - integer Sendbuf(*) ,recvbuf(*) ,Count,Datatype,Op,Comm ,ierror - integer dtype ,dtypemult - - dtype = MOD( Datatype,100 ) / 10 - dtypemult = MOD( Datatype ,10 ) - -!XXX if( Op .LT. MPII_OP_FIRST .OR. Op .GT. MPII_OP_LAST )then -!XXX print*,'error: MPI_ALLREDUCE: unknown reduce operator ',Op -!XXX print*,'info: op must be in ',MPII_OP_FIRST,' to ',MPII_OP_LAST -!XXX ierror = 1 -!XXX return -!XXX endif - if( dtype .LT. 0 .OR. dtype .GT. MPII_MAX_TYPE )then - print*,'error: MPI_ALLREDUCE: unknown datatype ',Datatype - ierror = 2 - endif - if( dtypemult .LE. 0 .OR. dtypemult .GT. MPII_MAX_TYPE_MULT )then - print*,'error: MPI_ALLREDUCE: unknown datatype ',Datatype - ierror = 3 - return - endif - - call MPII_COPY( recvbuf,Sendbuf,count,dtypemult ) - ierror = 0 - ! warn about invalid args - if( Op .LT. MPII_OP_FIRST .OR. Op .GT. MPII_OP_LAST )then - ierror = 99 - elseif( Comm .NE. MPI_COMM_WORLD )then - ierror = 98 - endif - return - end - - subroutine MPI_BCAST( Bdata,DataLen,DataType,Root,Comm,ierror ) - integer Bdata ,DataLen,DataType,Root,Comm,ierror - ierror = 0 - return - end - - - subroutine MPI_INITIALIZED( flag ,ierror ) - include 'mpif.h' - integer flag ,ierror - if( mpif_initialized )then - flag = 1 - else - flag = 0 - endif - ierror = 0 - return - end - - subroutine MPI_INIT( ierror ) - include 'mpif.h' - integer ierror - mpif_initialized = .TRUE. - ierror = 0 - return - end - - subroutine MPI_COMM_SIZE( Communicator ,num_p ,status ) - include 'mpif.h' - integer Communicator ,num_p ,status(MPI_STATUS_SIZE) - num_p = 1 - status(1) = 0 - if( Communicator .NE. MPI_COMM_WORLD )then - status(1) = 99 - endif - return - end - - subroutine MPI_COMM_RANK( Communicator ,rank_p ,ierror ) - include 'mpif.h' - integer Communicator ,rank_p ,ierror - rank_p = 0 - ierror = 0 - if( Communicator .NE. MPI_COMM_WORLD )then - ierror = 99 - endif - return - end - - subroutine MPI_BARRIER( Communicator ,ierror ) - include 'mpif.h' - integer Communicator ,ierror - ierror = 0 - if( Communicator .NE. MPI_COMM_WORLD )then - ierror = 99 - endif - return - end - - subroutine MPI_FINALIZE( ierror ) - include 'mpif.h' - integer ierror - mpif_initialized = .FALSE. - ierror = 0 - return - end - - subroutine MPII_COPY( recvbuf,Sendbuf,Count,Dtypemult ) - integer recvbuf(*),Sendbuf(*) ,Count,Dtypemult - integer i - do i = 1,Count*Dtypemult - recvbuf(i) = Sendbuf(i) - enddo - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/mpif.h b/OpticsJan2020/MLI_light_optics/Src/mpif.h deleted file mode 100644 index 77430e1..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/mpif.h +++ /dev/null @@ -1,29 +0,0 @@ - implicit none - - integer MPI_STATUS_SIZE ,MPI_COMM_WORLD - parameter( MPI_STATUS_SIZE=1 ,MPI_COMM_WORLD=2 ) - ! values of type parameters are 100*+10*+, - ! where is the number of words in the type, - ! indicates the base type, - ! and is the multiple of the length of this type times - ! int length - integer MPI_DOUBLE_PRECISION ,MPI_DOUBLE_COMPLEX - parameter( MPI_DOUBLE_PRECISION=112 ,MPI_DOUBLE_COMPLEX=124 ) - integer MPI_2DOUBLE_PRECISION - parameter( MPI_2DOUBLE_PRECISION=214 ) - integer MPI_INTEGER ,MPI_2INTEGER - parameter( MPI_INTEGER=101 ,MPI_2INTEGER=202 ) - ![NOTE: have to update these when types change!!! -dbs] - integer MPII_TYPE_INT ,MPII_TYPE_REAL ,MPII_TYPE_CPLX - parameter( MPII_TYPE_INT=0 ,MPII_TYPE_REAL=1 ,MPII_TYPE_CPLX=2 ) - integer MPII_MAX_TYPE ,MPII_MAX_TYPE_MULT - parameter( MPII_MAX_TYPE=2 ,MPII_MAX_TYPE_MULT=4 ) - - integer MPI_SUM ,MPI_MAX ,MPI_MAXLOC - parameter( MPI_SUM=1001 ,MPI_MAX=1002 ,MPI_MAXLOC=1003 ) - integer MPII_OP_FIRST ,MPII_OP_LAST - parameter( MPII_OP_FIRST=MPI_SUM ,MPII_OP_LAST=MPI_MAXLOC ) - - logical mpif_initialized - common /MPILCOMN/ mpif_initialized - save /MPILCOMN/ diff --git a/OpticsJan2020/MLI_light_optics/Src/multitrack_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/multitrack_mod.f90 deleted file mode 100644 index 65f577b..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/multitrack_mod.f90 +++ /dev/null @@ -1,62 +0,0 @@ -module multitrack - use rays - use lieaparam, only : monoms - implicit none - real*8, dimension(:), allocatable :: tlistin,ptlistin !initial t,pt - real*8, dimension(:,:), allocatable :: rho56 !t-pt density (future use) - integer,dimension(:),allocatable::inear,jnear !indices of nearest init t,pt - real*8,dimension(:),allocatable::tdelt,ptdelt !distance to nearest init t,pt - real*8, dimension(:,:,:,:), allocatable :: tmhlist !linear maps - real*8, dimension(:,:,:), allocatable :: hlist !nonlinear maps - real*8, dimension(:,:,:,:),allocatable::pbhlist !Taylor tracking info - real*8, dimension(:,:), allocatable :: tlistfin,ptlistfin !final t,pt -!if multitrac.ne.0, then use multiple maps when tracking -!cover the longitudinal phase space on a grid of size (imaps)x(jmaps) -!refentry5,refentry6 are values for the (single) ref particle at entrance - integer :: multitrac,imaps,jmaps - real*8 :: refentry5,refentry6 -save - -contains - - subroutine new_multiarrays -! create arrays "on the fly" based on imaps, jmaps, nraysp - allocate(tlistin(imaps),ptlistin(jmaps),rho56(imaps,jmaps), & - &inear(nraysp),jnear(nraysp),tdelt(nraysp),ptdelt(nraysp), & - &tmhlist(6,6,imaps,jmaps),hlist(monoms,imaps,jmaps), & - &tlistfin(imaps,jmaps),ptlistfin(imaps,jmaps)) - return - end subroutine new_multiarrays - - subroutine del_multiarrays -! destroy arrays - deallocate(tlistin,ptlistin,inear,jnear,tdelt,ptdelt, & - & tmhlist,hlist) - return - end subroutine del_multiarrays - - subroutine multibrkts -! for nonlinear Taylor tracking, need to store the result of calling brkts - include 'pbkh.inc' - real*8 pbh - integer i,j - if(allocated(pbhlist))deallocate(pbhlist) - if(idproc.eq.0)write(6,*)'(multibrkts): allocating pbhlist array' - allocate(pbhlist(monoms,12,imaps,jmaps)) - do i=1,imaps - do j=1,jmaps - call brkts(hlist(1,i,j)) - pbhlist(:,:,i,j)=pbh(:,:) - enddo - enddo - return - end subroutine multibrkts - - subroutine multicanx -! for nonlinear symplectic tracking, need to store the result of calling canx - if(idproc.eq.0) & - &write(6,*)'error: multitrack symp tracking not yet implemented' - call myexit - end subroutine multicanx - -end module multitrack diff --git a/OpticsJan2020/MLI_light_optics/Src/myblas.f b/OpticsJan2020/MLI_light_optics/Src/myblas.f deleted file mode 100644 index f410015..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/myblas.f +++ /dev/null @@ -1,932 +0,0 @@ - SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - & BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DGEMM performs one of the matrix-matrix operations -* -* C := alpha*op( A )*op( B ) + beta*C, -* -* where op( X ) is one of -* -* op( X ) = X or op( X ) = X', -* -* alpha and beta are scalars, and A, B and C are matrices, with op( A ) -* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -* -* Parameters -* ========== -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n', op( A ) = A. -* -* TRANSA = 'T' or 't', op( A ) = A'. -* -* TRANSA = 'C' or 'c', op( A ) = A'. -* -* Unchanged on exit. -* -* TRANSB - CHARACTER*1. -* On entry, TRANSB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRANSB = 'N' or 'n', op( B ) = B. -* -* TRANSB = 'T' or 't', op( B ) = B'. -* -* TRANSB = 'C' or 'c', op( B ) = B'. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix -* op( A ) and of the matrix C. M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix -* op( B ) and the number of columns of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of columns of the matrix -* op( A ) and the number of rows of the matrix op( B ). K must -* be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANSA = 'N' or 'n', and is m otherwise. -* Before entry with TRANSA = 'N' or 'n', the leading m by k -* part of the array A must contain the matrix A, otherwise -* the leading k by m part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANSA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is -* n when TRANSB = 'N' or 'n', and is k otherwise. -* Before entry with TRANSB = 'N' or 'n', the leading k by n -* part of the array B must contain the matrix B, otherwise -* the leading n by k part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANSB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n matrix -* ( alpha*op( A )*op( B ) + beta*C ). -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* transposed and set NROWA, NCOLA and NROWB as the number of rows -* and columns of A and the number of rows of B respectively. -* - NOTA = LSAME( TRANSA, 'N' ) - NOTB = LSAME( TRANSB, 'N' ) - IF( NOTA )THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF( NOTB )THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.NOTA ).AND. - & ( .NOT.LSAME( TRANSA, 'C' ) ).AND. - & ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.NOTB ).AND. - & ( .NOT.LSAME( TRANSB, 'C' ) ).AND. - & ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( K .LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 8 - ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN - INFO = 10 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - & ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - & RETURN -* -* And if alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( NOTB )THEN - IF( NOTA )THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 50, I = 1, M - C( I, J ) = ZERO - 50 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 60, I = 1, M - C( I, J ) = BETA*C( I, J ) - 60 CONTINUE - END IF - DO 80, L = 1, K - IF( B( L, J ).NE.ZERO )THEN - TEMP = ALPHA*B( L, J ) - DO 70, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 120, J = 1, N - DO 110, I = 1, M - TEMP = ZERO - DO 100, L = 1, K - TEMP = TEMP + A( L, I )*B( L, J ) - 100 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF( NOTA )THEN -* -* Form C := alpha*A*B' + beta*C -* - DO 170, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 130, I = 1, M - C( I, J ) = ZERO - 130 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 140, I = 1, M - C( I, J ) = BETA*C( I, J ) - 140 CONTINUE - END IF - DO 160, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*B( J, L ) - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 150 CONTINUE - END IF - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 200, J = 1, N - DO 190, I = 1, M - TEMP = ZERO - DO 180, L = 1, K - TEMP = TEMP + A( L, I )*B( J, L ) - 180 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM . -* - END - - LOGICAL FUNCTION LSAME( CA, CB ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER CA, CB -* .. -* -* Purpose -* ======= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments -* ========= -* -* CA (input) CHARACTER*1 -* CB (input) CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA, INTB, ZCODE -* .. -* .. Executable Statements .. -* -* Test if the characters are equal -* - LSAME = CA.EQ.CB - IF( LSAME ) - & RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = ICHAR( 'Z' ) -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR( CA ) - INTB = ICHAR( CB ) -* - IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 - IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 -* - ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.129 .AND. INTA.LE.137 .OR. - & INTA.GE.145 .AND. INTA.LE.153 .OR. - & INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 - IF( INTB.GE.129 .AND. INTB.LE.137 .OR. - & INTB.GE.145 .AND. INTB.LE.153 .OR. - & INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 -* - ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 - IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 - END IF - LSAME = INTA.EQ.INTB -* -* RETURN -* -* End of LSAME -* - END -* -************************************************************************** -****BEGIN PROLOGUE DCOPY -****PURPOSE Copy a vector. -****LIBRARY SLATEC (BLAS) -****CATEGORY D1A5 -****TYPE DOUBLE PRECISION (SCOPY-S, DCOPY-D, CCOPY-C, ICOPY-I) -****KEYWORDS BLAS, COPY, LINEAR ALGEBRA, VECTOR -****AUTHOR Lawson, C. L., (JPL) -* Hanson, R. J., (SNLA) -* Kincaid, D. R., (U. of Texas) -* Krogh, F. T., (JPL) -****DESCRIPTION -* -* B L A S Subprogram -* Description of Parameters -* -* --Input-- -* N number of elements in input vector(s) -* DX double precision vector with N elements -* INCX storage spacing between elements of DX -* DY double precision vector with N elements -* INCY storage spacing between elements of DY -* -* --Output-- -* DY copy of vector DX (unchanged if N .LE. 0) -* -* Copy double precision DX to double precision DY. -* For I = 0 to N-1, copy DX(LX+I*INCX) to DY(LY+I*INCY), -* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is -* defined in a similar way using INCY. -* -****REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -* Krogh, Basic linear algebra subprograms for Fortran -* usage, Algorithm No. 539, Transactions on Mathematical -* Software 5, 3 (September 1979), pp. 308-323. -****ROUTINES CALLED (NONE) -****REVISION HISTORY (YYMMDD) -* 791001 DATE WRITTEN -* 890831 Modified array declarations. (WRB) -* 890831 REVISION DATE from Version 3.2 -* 891214 Prologue converted to Version 4.0 format. (BAB) -* 920310 Corrected definition of LX in DESCRIPTION. (WRB) -* 920501 Reformatted the REFERENCES section. (WRB) -****END PROLOGUE DCOPY - - subroutine dcopy(n,dx,incx,dy,incy) -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - dy(i) = dx(i) - dy(i + 1) = dx(i + 1) - dy(i + 2) = dx(i + 2) - dy(i + 3) = dx(i + 3) - dy(i + 4) = dx(i + 4) - dy(i + 5) = dx(i + 5) - dy(i + 6) = dx(i + 6) - 50 continue - return - end - -************************************************************************** - - SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) -****BEGIN PROLOGUE DSWAP -****DATE WRITTEN 791001 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D1A5 -****KEYWORDS BLAS,DOUBLE PRECISION,INTERCHANGE,LINEAR ALGEBRA,VECTOR -****AUTHOR LAWSON, C. L., (JPL) -* HANSON, R. J., (SNLA) -* KINCAID, D. R., (U. OF TEXAS) -* KROGH, F. T., (JPL) -****PURPOSE Interchange d.p. vectors -****DESCRIPTION -* -* B L A S Subprogram -* Description of Parameters -* -* --Input-- -* N number of elements in input vector(s) -* DX double precision vector with N elements -* INCX storage spacing between elements of DX -* DY double precision vector with N elements -* INCY storage spacing between elements of DY -* -* --Output-- -* DX input vector DY (unchanged if N .LE. 0) -* DY input vector DX (unchanged if N .LE. 0) -* -* Interchange double precision DX and double precision DY. -* For I = 0 to N-1, interchange DX(LX+I*INCX) and DY(LY+I*INCY), -* where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is -* defined in a similar way using INCY. -****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., -* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, -* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL -* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 -****ROUTINES CALLED (NONE) -****END PROLOGUE DSWAP -* - DOUBLE PRECISION DX(1),DY(1),DTEMP1,DTEMP2,DTEMP3 -****FIRST EXECUTABLE STATEMENT DSWAP - IF(N.LE.0)RETURN - IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 - 5 CONTINUE -* -* CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. -* - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP1 = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP1 - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -* -* CODE FOR BOTH INCREMENTS EQUAL TO 1 -* -* -* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. -* - 20 M = MOD(N,3) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP1 = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP1 - 30 CONTINUE - IF( N .LT. 3 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,3 - DTEMP1 = DX(I) - DTEMP2 = DX(I+1) - DTEMP3 = DX(I+2) - DX(I) = DY(I) - DX(I+1) = DY(I+1) - DX(I+2) = DY(I+2) - DY(I) = DTEMP1 - DY(I+1) = DTEMP2 - DY(I+2) = DTEMP3 - 50 CONTINUE - RETURN - 60 CONTINUE -* -* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. -* - NS = N*INCX - DO 70 I=1,NS,INCX - DTEMP1 = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP1 - 70 CONTINUE - RETURN - END - INTEGER FUNCTION IDAMAX(N,DX,INCX) -****BEGIN PROLOGUE IDAMAX -****DATE WRITTEN 791001 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D1A2 -****KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT, -* VECTOR -****AUTHOR LAWSON, C. L., (JPL) -* HANSON, R. J., (SNLA) -* KINCAID, D. R., (U. OF TEXAS) -* KROGH, F. T., (JPL) -****PURPOSE Find largest component of d.p. vector -****DESCRIPTION -* -* B L A S Subprogram -* Description of Parameters -* -* --Input-- -* N number of elements in input vector(s) -* DX double precision vector with N elements -* INCX storage spacing between elements of DX -* -* --Output-- -* IDAMAX smallest index (zero if N .LE. 0) -* -* Find smallest index of maximum magnitude of double precision DX. -* IDAMAX = first I, I = 1 to N, to minimize ABS(DX(1-INCX+I*INCX) -****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., -* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, -* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL -* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 -****ROUTINES CALLED (NONE) -****END PROLOGUE IDAMAX -* - DOUBLE PRECISION DX(1),DMAX,XMAG -****FIRST EXECUTABLE STATEMENT IDAMAX - IDAMAX = 0 - IF(N.LE.0) RETURN - IDAMAX = 1 - IF(N.LE.1)RETURN - IF(INCX.EQ.1)GOTO 20 -* -* CODE FOR INCREMENTS NOT EQUAL TO 1. -* - DMAX = DABS(DX(1)) - NS = N*INCX - II = 1 - DO 10 I = 1,NS,INCX - XMAG = DABS(DX(I)) - IF(XMAG.LE.DMAX) GO TO 5 - IDAMAX = II - DMAX = XMAG - 5 II = II + 1 - 10 CONTINUE - RETURN -* -* CODE FOR INCREMENTS EQUAL TO 1. -* - 20 DMAX = DABS(DX(1)) - DO 30 I = 2,N - XMAG = DABS(DX(I)) - IF(XMAG.LE.DMAX) GO TO 30 - IDAMAX = I - DMAX = XMAG - 30 CONTINUE - RETURN - END -**************************************************************** - DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -****BEGIN PROLOGUE DASUM -****DATE WRITTEN 791001 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D1A3A -****KEYWORDS ADD,BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAGNITUDE,SUM, -* VECTOR -****AUTHOR LAWSON, C. L., (JPL) -* HANSON, R. J., (SNLA) -* KINCAID, D. R., (U. OF TEXAS) -* KROGH, F. T., (JPL) -****PURPOSE Sum of magnitudes of d.p. vector components -****DESCRIPTION -* -* B L A S Subprogram -* Description of Parameters -* -* --Input-- -* N number of elements in input vector(s) -* DX double precision vector with N elements -* INCX storage spacing between elements of DX -* -* --Output-- -* DASUM double precision result (zero if N .LE. 0) -* -* Returns sum of magnitudes of double precision DX. -* DASUM = sum from 0 to N-1 of DABS(DX(1+I*INCX)) -****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., -* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, -* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL -* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 -****ROUTINES CALLED (NONE) -****END PROLOGUE DASUM -* - DOUBLE PRECISION DX(1) -****FIRST EXECUTABLE STATEMENT DASUM - DASUM = 0.D0 - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GOTO 20 -* -* CODE FOR INCREMENTS NOT EQUAL TO 1. -* - NS = N*INCX - DO 10 I=1,NS,INCX - DASUM = DASUM + DABS(DX(I)) - 10 CONTINUE - RETURN -* -* CODE FOR INCREMENTS EQUAL TO 1. -* -* -* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. -* - 20 M = MOD(N,6) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DASUM = DASUM + DABS(DX(I)) - 30 CONTINUE - IF( N .LT. 6 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,6 - DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) - & + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) - 50 CONTINUE - RETURN - END -**************************************************************** - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) -****BEGIN PROLOGUE DAXPY -****DATE WRITTEN 791001 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D1A7 -****KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,TRIAD,VECTOR -****AUTHOR LAWSON, C. L., (JPL) -* HANSON, R. J., (SNLA) -* KINCAID, D. R., (U. OF TEXAS) -* KROGH, F. T., (JPL) -****PURPOSE D.P computation y = a*x + y -****DESCRIPTION -* -* B L A S Subprogram -* Description of Parameters -* -* --Input-- -* N number of elements in input vector(s) -* DA double precision scalar multiplier -* DX double precision vector with N elements -* INCX storage spacing between elements of DX -* DY double precision vector with N elements -* INCY storage spacing between elements of DY -* -* --Output-- -* DY double precision result (unchanged if N .LE. 0) -* -* Overwrite double precision DY with double precision DA*DX + DY. -* For I = 0 to N-1, replace DY(LY+I*INCY) with DA*DX(LX+I*INCX) + -* DY(LY+I*INCY), where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N -* and LY is defined in a similar way using INCY. -****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., -* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, -* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL -* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 -****ROUTINES CALLED (NONE) -****END PROLOGUE DAXPY -* - DOUBLE PRECISION DX(1),DY(1),DA -****FIRST EXECUTABLE STATEMENT DAXPY - IF(N.LE.0.OR.DA.EQ.0.D0) RETURN - IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 - 5 CONTINUE -* -* CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. -* - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -* -* CODE FOR BOTH INCREMENTS EQUAL TO 1 -* -* -* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. -* - 20 M = MOD(N,4) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DY(I) = DY(I) + DA*DX(I) - 30 CONTINUE - IF( N .LT. 4 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I + 1) = DY(I + 1) + DA*DX(I + 1) - DY(I + 2) = DY(I + 2) + DA*DX(I + 2) - DY(I + 3) = DY(I + 3) + DA*DX(I + 3) - 50 CONTINUE - RETURN -* -* CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. -* - 60 CONTINUE - NS = N*INCX - DO 70 I=1,NS,INCX - DY(I) = DA*DX(I) + DY(I) - 70 CONTINUE - RETURN - END -**************************************************************** - SUBROUTINE DSCAL(N,DA,DX,INCX) -****BEGIN PROLOGUE DSCAL -****DATE WRITTEN 791001 (YYMMDD) -****REVISION DATE 820801 (YYMMDD) -****CATEGORY NO. D1A6 -****KEYWORDS BLAS,LINEAR ALGEBRA,SCALE,VECTOR -****AUTHOR LAWSON, C. L., (JPL) -* HANSON, R. J., (SNLA) -* KINCAID, D. R., (U. OF TEXAS) -* KROGH, F. T., (JPL) -****PURPOSE D.P. vector scale x = a*x -****DESCRIPTION -* -* B L A S Subprogram -* Description of Parameters -* -* --Input-- -* N number of elements in input vector(s) -* DA double precision scale factor -* DX double precision vector with N elements -* INCX storage spacing between elements of DX -* -* --Output-- -* DX double precision result (unchanged if N.LE.0) -* -* Replace double precision DX by double precision DA*DX. -* For I = 0 to N-1, replace DX(1+I*INCX) with DA * DX(1+I*INCX) -****REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., -* *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, -* ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL -* SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 -****ROUTINES CALLED (NONE) -****END PROLOGUE DSCAL -* - DOUBLE PRECISION DA,DX(1) -****FIRST EXECUTABLE STATEMENT DSCAL - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GOTO 20 -* -* CODE FOR INCREMENTS NOT EQUAL TO 1. -* - NS = N*INCX - DO 10 I = 1,NS,INCX - DX(I) = DA*DX(I) - 10 CONTINUE - RETURN -* -* CODE FOR INCREMENTS EQUAL TO 1. -* -* -* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. -* - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DX(I) = DA*DX(I) - 30 CONTINUE - IF( N .LT. 5 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I + 1) = DA*DX(I + 1) - DX(I + 2) = DA*DX(I + 2) - DX(I + 3) = DA*DX(I + 3) - DX(I + 4) = DA*DX(I + 4) - 50 CONTINUE - RETURN - END -**************************************************************** - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) - implicit double precision (a-h, o-z) -* RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. -* DDOT = SUM FOR I = 0 TO N-1 OF DX(LX+I*INCX) * DY(LY+I*INCY) -* WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS -* DEFINED IN A SIMILAR WAY USING INCY. - DOUBLE PRECISION DX(1),DY(1) - DDOT = 0.D0 - IF(N.LE.0)RETURN - IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 - 5 CONTINUE -* CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DDOT = DDOT + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -* CODE FOR BOTH INCREMENTS EQUAL TO 1. -* CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DDOT = DDOT + DX(I)*DY(I) - 30 CONTINUE - IF( N .LT. 5 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + - & DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) - 50 CONTINUE - RETURN -* CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. - 60 CONTINUE - NS = N*INCX - DO 70 I=1,NS,INCX - DDOT = DDOT + DX(I)*DY(I) - 70 CONTINUE - RETURN - END diff --git a/OpticsJan2020/MLI_light_optics/Src/mygenrec5.f b/OpticsJan2020/MLI_light_optics/Src/mygenrec5.f deleted file mode 100755 index 21062e1..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/mygenrec5.f +++ /dev/null @@ -1,554 +0,0 @@ -************************************************************************ -* header GENREC (GENMAP for a pattern of REC quads) * -* All routines needed for this special GENMAP * -************************************************************************ -************************************************************************ - subroutine gnrec3(p,fa,fm) -c This is a subroutine for computing the map for patterns of REC quads. -c It is based on Rob Ryne's GENMAP as modified by Alex Dragt 12/18/86. -c -c Further modified 4 June 87 by Tom Mottershead to allow any number -c of cycles through a pattern of up to 5 REC quads, with arbitrary -c numbers of repeats. Actually probably more general than this. AJD -c -c Modified by Filippo Neri Jan. 16 1989 to include multipoles. -c Fifth order version by F. Neri Mar 13 1989. -c Modified to be like MaryLie 3.0 version by A. Dragt 4/24/95 -c -c The input parameters come from recn, and the -c auxilary parameter NPQUAD, MULTIPOLES, plus NQT pset defining the quads. - -******************************************************************************* - -c -c The parameters of recm are: -c 1. zi Initial integration point. -c 2. zf Final integration point. -c 3. NS Number of integration steps. -c 4. IFILE (profile file number). -c 5. MULTIPOLES index of pset containin multipole information -c for this integration region. If MULTIPOLES is 0, then -c the value of all multipoles is set to zero. -c 6. NPQUAD index of pset containing quad pattern information. -c--------------------------------------------------------------- -c The pset MULTIPOLES has the same format as used in the cfq element: -c 1. Normal sextupole ( Tesla/meter^2 ). -c 2. Skew sextupole ( Tesla/meter^2 ). -c 3. Normal octupole ( Tesla/meter^3 ). -c 4. Skew octupole ( Tesla/Meter^3 ). -c 5. UNUSED ( must be there!) -c 6. UNUSED ( nust be there!) -c--------------------------------------------------------------- -c The parameter set NPQUAD defines the set of Halbach quad units as follows: -c 1. Di Initial drift to first quad ( starting from Z = 0.) -c 2. NQT Number of psets used for quads. -c 3. IPS Index of inital pset used for quads. The following -c psets in order define the successive quads. -c 4. MAXQ Maximum number of quads actually used, including multiple -c cycles thru pattern (but not repeats). -c 5. NCYC Number of cycles thru pattern, except that the sequence -c stops when MAXQ is reached. -c 6. ISEND output control: 0 = quiet running -c 1 = print on terminal (jof) -c 2 = print on std. output file (jodf) -c 3 = print on both -c--------------------------------------------------------------- -c The parameter set type codes are used to define the Halbach quad unit -c cells in a manner parallel to the normal quad type codes: -c ps(1) = ql, the quad length in meters. -c ps(2) = fg, the field gradient in Tesla/meter (if the quad were -c infinitely long). -c ps(3) = ra, the inner radius. (These radii control the shape of the -c ps(4) = rb, the outer radius. fringe field) -c ps(5) = td, the trailing drift to the front face of the next quad in -c the pattern (meters). Note: the trailing drift assigned to -c the last quad in the whole pattern is ignored; the -c integration proceeds to the final point zf anyway. -c ps(6) = nr, the number of consecutive repetitions, or multiplicity, -c of this quad unit cell in the basic pattern. -c------------------------------------------------------------------- -c - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - include 'hmflag.inc' - include 'combs.inc' - include 'quadpn.inc' - include 'files.inc' - include 'recmul.inc' -c -c calling arrays - dimension p(6) - dimension fa(monoms), fm(6,6) -c -c local arrays - dimension pb(6) - dimension y(monoms+15) -c -c timing variables -c real ttaa, ttbb -c -c use equivalence statement to make the various parameter sets pstj -c available as if they were in a two dimensional array -c -c -c y(1-6) = given (design) trajectory -c y(7-42) = matrix -c y(43-98) = f3 -c y(99-224) = f4 -c y(225-*) = f5 -c y(*-*) = f6 -c -c get interval and number of steps from GENREC parameters -c - zi = p(1) - zf = p(2) - ns = nint(p(3)) - ifile = nint(p(4)) - mpole = nint(p(5)) - npquad = nint(p(6)) -c -c get multipole values from the parameter set mpole -c Note that if mpole is zero, then the multipoles are set to zero. -c - if (mpole.lt.1 .or. mpole.gt.maxpst) then - do 500 i=1,6 - 500 pb(i) = 0.0d0 - else - do 600 i=1,6 - 600 pb(i) = pst(i,mpole) - endif -c -c compute multipole coefficients -c - bsex=pb(1) - asex=pb(2) - boct=pb(3) - aoct=pb(4) - fsxnr=bsex/(3.d0*brho) - fsxsk=asex/(3.d0*brho) - focnr=boct/(4.d0*brho) - focsk=aoct/(4.d0*brho) -c -c get REC pattern information from pset npquad -c - di = pst(1,npquad) - nqt = nint(pst(2,npquad)) - if (nqt .gt. 6) then - write(jof,*) ' input error: nqt=',nqt - write(jof,*) ' this value is > 6 and therefore too large' - call myexit - endif - ips = nint(pst(3,npquad)) - maxq = nint(pst(4,npquad)) - ncyc = nint(pst(5,npquad)) - isend = nint(pst(6,npquad)) - jtty = 0 - jdsk = 0 - if((isend.eq.1).or.(isend.eq.3)) jtty = 1 - if((isend.eq.2).or.(isend.eq.3)) jdsk = 1 -c - h=(zf-zi)/float(ns) -c -c echo input parameters -c - if(jtty.eq.1) write( jof,13) ns,zi,zf - if(jdsk.eq.1) write(jodf,13) ns,zi,zf - 13 format(/' Integrating in ',i6,' steps from',f10.5,'=zi to', - &f10.5,'=zf') - if (mpole.lt.1 .or. mpole.gt.maxpst) then - if(jtty.eq.1) write( jof,*) - &' mpole=0, all multipoles are zero' - if(jdsk.eq.1) write( jodf,*) - &' mpole=0, all multipoles are zero' - endif - if (mpole.ge.1 .and. mpole.le.maxpst) then - if(jtty.eq.1) write( jof,14) mpole,bsex,asex,boct,aoct - if(jdsk.eq.1) write(jodf,14) mpole,bsex,asex,boct,aoct - 14 format(1x,'multipole strengths from pset',i2,':',/, - &1x,' Sextupole:',2(1pg12.4),/, - &1x,' Octupole: ',2(1pg12.4)) - endif - if(jtty.eq.1) write( jof,15) npquad,ncyc,nqt,maxq,di - if(jdsk.eq.1) write(jodf,15) npquad,ncyc,nqt,maxq,di - 15 format(' Pattern from pset',i2,':',/, - &i4,' cycle(s) of',i3,' type(s) of section(s) with a maximum of' - &,i3,' section(s)',/,' di=',f10.5) - if(jtty.eq.1) write( jof,*) ' types of section(s) are:' - if(jdsk.eq.1) write(jodf,*) ' types of section(s) are:' - if(jtty.eq.1) write( jof,16) - if(jdsk.eq.1) write(jodf,16) - 16 format(1x,'pset',2x,'length',4x,'strength',3x, - &'radii: inner',6x,'outer',6x,'tdrift',4x,'number') -c -c inititialize the nqt quad types from the first nqt parameter sets -c - do 20 n = ips, nqt+ips-1 - kn = n-ips+1 - wd(kn) = pst(1,n) - ga(kn) = pst(2,n) - ra(kn) = pst(3,n) - rb(kn) = pst(4,n) - dr(kn) = pst(5,n) - nr(kn) = nint(pst(6,n)) - if(jtty.eq.1) write(jof,17) - & n,wd(kn),ga(kn),ra(kn),rb(kn),dr(kn),nr(kn) - if(jdsk.eq.1) write(jodf,17) - & n,wd(kn),ga(kn),ra(kn),rb(kn),dr(kn),nr(kn) - 17 format(i4,5f12.6,i6) - 20 continue -c -c call VAX system routine for timing report -c -c ttaa = secnds(0.0) -c -c initial values for design orbit (in dimensionless units) : -c - y(1)=0.d0 - y(2)=0.d0 - y(3)=0.d0 - y(4)=0.d0 - y(5)=0.d0 - y(6)=0.d0 -c set constants - qbyp=1.d0/brho - ptg=-1.d0/beta -c cmp2=(1.d0/(beta*gamma))**2 -c -c initialize map to the identity map: - ne=monoms+15 - do 40 i=7,ne - 40 y(i)=0.d0 - do 50 i=1,6 - j=7*i - 50 y(j)=1.d0 -c -c Set up multipoles: -c -c compute useful numbers -c - sl2=sl*sl - sl3=sl*sl2 - bet2=beta*beta - bet3=beta*bet2 - gam2=gamma*gamma -c -c write out gradient and derivatives on file ifile: - ipflag=0 - if (ifile .ne. 0) then - if (ifile .lt.0 ) then - ipflag=1 - ifile=-ifile - endif - do 100 i=0,ns - s=zi + float(i)*h - call g01234(s,g,gz,gzz,gzzz,gzzzz) - 100 write(ifile,101)s,g,gz,gzz,gzzz,gzzzz - 101 format(6(1x,1pg12.5)) - write(jof,*) ' ' - write(jof,*) ' profile written on file ',ifile - endif -c -c return identity map if ifile was < 0 - if (ipflag .eq. 1) then - call ident(fa,fm) - return - endif -c -c do the computation: - t=zi - iflag = 2 -cryne 1 August 2004 fix later: -cryne call adam11(h,ns,'start',t,y) - nedummy=monoms+15 - call adam11(h,ns,'start',t,y,nedummy) - call errchk(y(7)) - call putmap(y,fa,fm) - call csym(1,fm,ans) -c -c call VAX system routine for timing report -c -c ttbb = secnds(ttaa) -c if(jtty.eq.1) write( jof,567) ttbb -c if(jdsk.eq.1) write(jodf,567) ttbb -c 567 format(' GENREC integration time = ',f12.2,' sec.') -c - return - end -c -********************************************************************** -c - subroutine errchk(y) - use lieaparam, only : monoms - use parallel, only : idproc - include 'impli.inc' -cryne dimension y(monoms+15) - dimension y(*) - s1=1.d0 -( y(1)*y(8)-y(2)*y(7) ) - s2=1.d0 -( y(15)*y(22)-y(16)*y(21) ) - s3=1.d0 -( y(29)*y(36)-y(30)*y(35) ) - if (idproc.eq.0) then - write(6,100) s1,s2,s3 - end if - 100 format(1x,'1. - 2 x 2 determinants = ',e14.7,1x,e14.7,1x,e14.7) - return - end -c -********************************************************************** -c - subroutine hmltn2(t,y,h) -c new version by R. Ryne 6/9/2002 -c -c this routine is used to specify h(z) for a REC quad triplet -c This version ( f5 + f6 ) by F. Neri. -c Jan 7 1988. -c Multipoles added by F. Neri Mar 13 1989. - use beamdata - implicit double precision(a-h,o-z) - parameter (itop=923,iplus=938) - include 'combs.inc' - include 'recmul.inc' - dimension A(0:12),X(0:itop),YY(0:itop),P1(0:itop),P2(0:itop) - dimension h(itop),y(*) -c -c begin calculation -c -c compute gradients - call g01234(t,g,gz,gzz,gzzz,gzzzz) - f=0.5d0*g - fz=0.25d0*gz - fzz=gzz/12.d0 - fzzz=gzzz/48.d0 - fzzzz=gzzzz/256.d0 - brho=1./qbyp - beta=-1.d0/ptg -c -c initialization - do 10 i=7,itop - 10 h(i)=0.d0 -c -c 2nd order - h(27)=-(-1.d0 + beta**2)/(2.d0*beta**2*sl) - h(13)=1.d0/(2.d0*sl) - h(22)=1.d0/(2.d0*sl) - h(7)=(f*sl)/brho - h(18)=-((f*sl)/brho) -c 3rd order - h(83)=-(-1.d0 + beta**2)/(2.d0*beta**3*sl) - h(53)=1.d0/(2.d0*beta*sl) - h(76)=1.d0/(2.d0*beta*sl) -c 4th order - h(209)=(5.d0 - 6.d0*beta**2 + beta**4)/(8.d0*beta**4*sl) - h(154)=-(-3.d0 + beta**2)/(4.d0*beta**2*sl) - h(200)=-(-3.d0 + beta**2)/(4.d0*beta**2*sl) - h(140)=1.d0/(8.d0*sl) - h(149)=1.d0/(4.d0*sl) - h(195)=1.d0/(8.d0*sl) - h(85)=-((fz*sl**2)/brho) - h(84)=-((fzz*sl**3)/brho) - h(96)=-((fz*sl**2)/brho) - h(110)=(fz*sl**2)/brho - h(176)=(fz*sl**2)/brho - h(175)=(fzz*sl**3)/brho -c 5th order - h(370)=-(-5.d0 + 3.d0*beta**2)/(4.d0*beta**3*sl) - h(450)=-(-5.d0 + 3.d0*beta**2)/(4.d0*beta**3*sl) - h(461)=(7.d0 - 10.d0*beta**2 + 3.d0*beta**4)/(8.d0*beta**5*sl) - h(340)=3.d0/(8.d0*beta*sl) - h(363)=3.d0/(4.d0*beta*sl) - h(443)=3.d0/(8.d0*beta*sl) - h(220)=-((fz*sl**2)/(beta*brho)) - h(252)=-((fz*sl**2)/(beta*brho)) - h(284)=(fz*sl**2)/(beta*brho) - h(412)=(fz*sl**2)/(beta*brho) -c 6th order - h(783)=(35.d0 - 30.d0*beta**2 + 3.d0*beta**4)/(16.d0*beta**4*sl) - h(910)=(35.d0 - 30.d0*beta**2 + 3.d0*beta**4)/(16.d0*beta**4*sl) - h(728)=(-3.d0*(-5.d0 + beta**2))/(16.d0*beta**2*sl) - h(901)=(-3.d0*(-5.d0 + beta**2))/(16.d0*beta**2*sl) - h(923)= & - &-(-21.d0+35.d0*beta**2-15.d0*beta**4+beta**6)/(16.d0*beta**6*sl) - h(774)=(-3.d0*(-5.d0 + beta**2))/(8.d0*beta**2*sl) - h(714)=1.d0/(16.d0*sl) - h(723)=3.d0/(16.d0*sl) - h(769)=3.d0/(16.d0*sl) - h(896)=1.d0/(16.d0*sl) - h(483)=-(fz*sl**2)/(2.d0*brho) - h(492)=-(fz*sl**2)/(2.d0*brho) - h(497)=((-3.d0 + beta**2)*fz*sl**2)/(2.d0*beta**2*brho) - h(463)=(fzzz*sl**4)/brho - h(462)=(sl**5*(fz**2 + 2.d0*brho*fzzzz))/(2.d0*brho**2) - h(524)=-(fz*sl**2)/(2.d0*brho) - h(563)=-(fz*sl**2)/(2.d0*brho) - h(568)=((-3.d0 + beta**2)*fz*sl**2)/(2.d0*beta**2*brho) - h(474)=(fzzz*sl**4)/brho - h(593)=(fz*sl**2)/(2.d0*brho) - h(627)=(fz*sl**2)/(2.d0*brho) - h(632)=-((-3.d0 + beta**2)*fz*sl**2)/(2.d0*beta**2*brho) - h(473)=(sl**5*(-fz**2 + 2.d0*brho*fzzzz))/(2.d0*brho**2) - h(750)=(fz*sl**2)/(2.d0*brho) - h(850)=(fz*sl**2)/(2.d0*brho) - h(855)=-((-3.d0 + beta**2)*fz*sl**2)/(2.d0*beta**2*brho) - h(623)=-((fzzz*sl**4)/brho) - h(553)=-(sl**5*(fz**2 + 2.d0*brho*fzzzz))/(2.d0*brho**2) - h(841)=-((fzzz*sl**4)/brho) - h(840)=(sl**5*(fz**2 - 2.d0*brho*fzzzz))/(2.d0*brho**2) -c -c add sextupoles - h(28)=fsxnr*sl2 - h(30)=-3.d0*fsxsk*sl2 - h(39)=-3.d0*fsxnr*sl2 - h(64)=fsxsk*sl2 -c -c add octupoles -c - h(84)=h(84)+focnr*sl3 - h(86)=-4.0d0*focsk*sl3 - h(95)=-6.d0*focnr*sl3 - h(120)=4.d0*focsk*sl3 - h(175)=h(175)+focnr*sl3 -c - return - end -c -************************************************************************ -c - subroutine g01234(z,g,gz,gzz,gzzz,gzzzz) -c This routine computes g, dg/dz, and d/dz(dg/dz) for -c (a REC Quadrupole Triplet.) -c Written by Alex Dragt, Fall 1986, and based on work of -c Rob Ryne and F. Neri -c This version by T. Mottershead allows up to 9(?) different -c REC Quadrupoles. -c Extended to derivatives up to 4 by F. Neri Mar 13 1989. - include 'impli.inc' - include 'quadpn.inc' -c---------------------------------------- - external f,fz,fzz,fzzz,fzzzz -c---------------------------------------- -c - g=0.d0 - gz=0.d0 - gzz=0.d0 - gzzz=0.d0 - gzzzz=0.d0 - kuad = 0.d0 - za = di - do 60 i=1,ncyc - do 50 k=1,nqt - gk = ga(k) - wk = wd(k) - dk = dr(k) - aa = ra(k) - bb = rb(k) - do 40 j=1,nr(k) - zb = za + wk - g = g +gk*( f(z-zb,aa,bb)-f(z-za,aa,bb)) - gz = gz +gk*( fz(z-zb,aa,bb)-fz(z-za,aa,bb)) - gzz= gzz+gk*(fzz(z-zb,aa,bb)-fzz(z-za,aa,bb)) - gzzz= gzzz+gk*(fzzz(z-zb,aa,bb)-fzzz(z-za,aa,bb)) - gzzzz= gzzzz+gk*(fzzzz(z-zb,aa,bb)-fzzzz(z-za,aa,bb)) - kuad = kuad + 1 - if(kuad.ge.maxq) return - za = zb + dk - 40 continue - 50 continue - 60 continue - return - end -c - double precision function f(z,r1,r2) - implicit double precision (a-h,o-z) - v(z,r)=1.d0/sqrt(1.d0+(z/r)**2) - f = 0.5d0-.0625d0*z* - &(1.d0/r1+1.d0/r2)*v(z,r1)**2*v(z,r2)**2/(v(z,r1)+v(z,r2))*( & - &v(z,r1)**2+v(z,r1)*v(z,r2)+v(z,r2)**2+4.d0+8.d0/(v(z,r1)*v(z,r2))) - return - end -c - double precision function fz(z,r1,r2) - implicit double precision (a-h,o-z) - v(z,r)=1.d0/sqrt(1.d0+(z/r)**2) - fz = -.1875d0*(1.d0/r1+1.d0/r2)*v(z,r1)**2*v(z,r2)**2* & - &(v(z,r1)**3+v(z,r2)**3 + v(z,r1)**2*v(z,r2)**2/(v(z,r1)+v(z,r2))) - return - end -c - double precision function fzz(z,r1,r2) - implicit double precision (a-h,o-z) - v(z,r)=1.d0/sqrt(1.d0+(z/r)**2) - fzz = .1875d0*(1.d0/r1+1.d0/r2)*z*v(z,r1)**2*v(z,r2)**2 *( & - &5.d0*(v(z,r1)**5/r1**2+v(z,r2)**5/r2**2) & - &+v(z,r1)**2*v(z,r2)**2 *( & - & 2.d0*(v(z,r2)/r1**2+v(z,r1)/r2**2) & - &+4.d0*(v(z,r1)**2/r1**2+v(z,r2)**2/r2**2)/(v(z,r1)+v(z,r2)) & - &-(v(z,r1)**3/r1**2+v(z,r2)**3/r2**2)/(v(z,r1)+v(z,r2))**2 )) - return - end -c -c Higher derivatives of the Halbach function by -c F. Neri, Jan 1988. -c - double precision function fzzz(z,r1,r2) - implicit double precision (a-h,o-z) - v(z,r)=1.d0/sqrt(1.d0+(z/r)**2) - if(dabs(z) .ge. 0.0001d0*r1) then - fzzz =.375d0*((3.5d0*(v(z,r1)**7/(r1**2*z**2)) & - &+3.d0*(v(z,r1)**7/z**4)+7.d0*(v(z,r1)**9/(r1**2*z**2)) & - &+24.5d0*(v(z,r1)**9/r1**4) & - & -3.5d0*(v(z,r2)**7/(r2**2*z**2)) & - &-3.d0*(v(z,r2)**7/z**4)-7.d0*(v(z,r2)**9/(r2**2*z**2)) & - &-24.5d0*(v(z,r2)**9/r2**4))/(1.d0/r1-1.d0/r2)) - else -c-------------------------------------- -c Limiting expression for z ~ 0 - fzzz = 6.d0*(35.d0/128.d0)*(1./(r1*r2**2)+1./(r1**2*r2) & - &+ 1.d0/(r1**3)+1.d0/(r2**3)) & - &+60.d0*(-63.d0/256.d0)*z**2*(1.d0/(r1*r2**4)+1.d0/(r1**2*r2**3) & - &+1.d0/(r1**3*r2**2)+1.d0/(r1**4*r2)+1.d0/(r1**5)+1.d0/(r2**5)) & - &+210.d0*(495.d0/2048.d0)*z**4*(1.d0/(r1*r2**6)+1.d0/(r1**2*r2**5) & - &+1.d0/(r1**3*r2**4)+1.d0/(r1**4*r2**3)+1.d0/(r1**5*r2**2) & - &+1.d0/(r1**6*r2)+1.d0/(r1**7)+1.d0/(r2**7)) & - &+504.d0*(-1001.d0/4096.d0)*z**6*(1./(r1*r2**8)+1.d0/(r1**2*r2**7) & - &+1.d0/(r1**3*r2**6)+1.d0/(r1**4*r2**5)+1.d0/(r1**5*r2**4) & - &+1.d0/(r1**6*r2**3)+1.d0/(r1**7*r2**2)+1.d0/(r1**8*r2) & - &+1.d0/(r1**9)+1.d0/(r2**9)) - endif - return - end -c - double precision function fzzzz(z,r1,r2) - implicit double precision (a-h,o-z) - v(z,r)=1.d0/sqrt(1.d0+(z/r)**2) - if (dabs(z) .ge. 0.0001d0*r1) then - fzzzz = 0.375d0*(( & - &-220.5d0*((z*v(z,r1)**11)/r1**6)-7.d0*(v(z,r1)**7/(r1**2*z**3)) & - &-12.d0*(v(z,r1)**7/z**5)-35.d0*(v(z,r1)**9/(r1**2*z**3)) & - &-24.5d0*(v(z,r1)**9/(r1**4*z))-63.d0*(v(z,r1)**11/(r1**4*z)) & - &+220.5d0*((z*v(z,r2)**11)/r2**6)+7.d0*(v(z,r2)**7/(r2**2*z**3)) & - &+12.d0*(v(z,r2)**7/z**5)+35.d0*(v(z,r2)**9/(r2**2*z**3)) & - &+24.5d0*(v(z,r2)**9/(r2**4*z))+63.d0*(v(z,r2)**11/(r2**4*z)) & - & )/(1.d0/r1-1.d0/r2)) -c---------------------------------------- - else -c Limiting expression for z ~ 0 -cryne 105.*18.? -cryne fzzzz = -105.*18*z*(1./r1**6-1./r2**6)/(64.*(1./r1-1./r2)) - fzzzz = -105.d0*18.d0*z*(1.d0/r1**6-1.d0/r2**6)/(64.d0*(1.d0/r1- & - &1.d0/r2)) & - &+840.d0*z**3*(495.d0/2048.d0)*( 1.d0/(r1*r2**6) & - &+ 1.d0/(r1**2*r2**5) & - &+ 1.d0/(r1**3*r2**4) + 1.d0/(r1**4*r2**3) + 1.d0/(r1**5*r2**2) & - &+ 1.d0/(r1**6*r2) + 1.d0/r1**7 + 1.d0/r2**7 ) & - &-3024.d0*z**5*(1001.d0/4096.d0)*(1.d0/(r1*r2**8) & - &+1.d0/(r1**2*r2**7) & - &+1.d0/(r1**3*r2**6)+1.d0/(r1**4*r2**5)+1.d0/(r1**5*r2**4) & - &+1.d0/(r1**6*r2**3)+1.d0/(r1**7*r2**2)+1.d0/(r1**8*r2) & - &+1.d0/r1**9 + 1.d0/r2**9 ) -c - endif - return - end -c -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/myprot5.f b/OpticsJan2020/MLI_light_optics/Src/myprot5.f deleted file mode 100644 index 30a0f40..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/myprot5.f +++ /dev/null @@ -1,83 +0,0 @@ - subroutine myprot(phideg,h,mh) -c -c High order PROT routine. -c Actual code generated by Johannes van Zeijts using -c REDUCE. -c - include 'impli.inc' - include 'param.inc' - include 'parm.inc' - include 'pie.inc' - double precision l,h(monoms),mh(6,6) -c - dimension j(6) -c - DOUBLE PRECISION B - DOUBLE PRECISION CO - DOUBLE PRECISION Si -c - call clear(h,mh) -c - B = beta - phi = phideg*pi180 - SI = SIN(phi) - CO = COS(phi) -c - mh(1,1)=1.0d0/CO - mh(2,2)=CO - mh(2,6)=(-SI)/B - mh(3,3)=1.0d0 - mh(4,4)=1.0d0 - mh(5,1)=SI/(B*CO) - mh(5,5)=1.0d0 - mh(6,6)=1.0d0 -c - h(34) =(-SI)/(2.0d0*CO) - h(43) =(-SI)/(2.0d0*CO) - h(48) =(SI*(B**2-1))/(2.0d0*B**2*CO) - h(105) =SI**2/(4.0d0*(SI**2-1)) - h(109) =(-SI)/(2.0d0*B*CO) - h(114) =SI**2/(4.0d0*(SI**2-1)) - h(119) =(SI**2*(-B**2+1))/(4.0d0*B**2*(SI**2-1)) - h(132) =(-SI)/(2.0d0*B*CO) - h(139) =(SI*(B**2-1))/(2.0d0*B**3*CO) - h(266) =SI/(8.0d0*CO*(SI**2-1)) - h(270) =SI**2/(2.0d0*B*(SI**2-1)) - h(275) =(SI*(-2.0d0*SI**2+3))/(12.0d0*CO*(SI**2-1)) - h(280) =(SI*(2.0d0*B**2*SI**2-3.0d0*B**2-8.0d0*SI**2+9))/( - # 12.0d0*B**2*CO*(SI**2-1)) - h(293) =SI**2/(2.0d0*B*(SI**2-1)) - h(300) =(SI**2*(-B**2+1))/(2.0d0*B**3*(SI**2-1)) - h(321) =(SI*(-4.0d0*SI**2+3))/(24.0d0*CO*(SI**2-1)) - h(326) =(SI*(4.0d0*B**2*SI**2-3.0d0*B**2-10.0d0*SI**2+9))/( - # 12.0d0*B**2*CO*(SI**2-1)) - h(335) =(SI*(-4.0d0*B**4*SI**2+3.0d0*B**4+20.0d0*B**2*SI**2- - # 18.0d0*B**2-16.0d0*SI**2+15))/(24.0d0*B**4*CO*(SI**2-1)) - h(588) =(SI**2*(SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+1)) - h(592) =(SI*(SI**2+6))/(16.0d0*B*CO*(SI**2-1)) - h(597) =(SI**2*(3.0d0*SI**2-4))/(16.0d0*(SI**4-2.0d0*SI**2+ - # 1)) - h(602) =(SI**2*(-3.0d0*B**2*SI**2+4.0d0*B**2+15.0d0*SI**2-16.0d0 - # ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) - h(615) =(3.0d0*SI*(-SI**2+2))/(8.0d0*B*CO*(SI**2-1)) - h(622) =(SI*(3.0d0*B**2*SI**2-6.0d0*B**2-7.0d0*SI**2+10))/( - # 8.0d0*B**3*CO*(SI**2-1)) - h(643) =(SI**2*(5.0d0*SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+ - # 1)) - h(648) =(SI**2*(-5.0d0*B**2*SI**2+4.0d0*B**2+17.0d0*SI**2-16.0d0 - # ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) - h(657) =(SI**2*(5.0d0*B**4*SI**2-4.0d0*B**4-34.0d0*B**2*SI**2 - # +32.0d0*B**2+29.0d0*SI**2-28))/(32.0d0*B**4*(SI**4-2.0d0*SI**2+ - # 1)) - h(695) =(SI*(-7.0d0*SI**2+6))/(16.0d0*B*CO*(SI**2-1)) - h(702) =(SI*(7.0d0*B**2*SI**2-6.0d0*B**2-11.0d0*SI**2+10))/( - # 8.0d0*B**3*CO*(SI**2-1)) - h(713) =(SI*(-7.0d0*B**4*SI**2+6.0d0*B**4+22.0d0*B**2*SI**2- - # 20.0d0*B**2-15.0d0*SI**2+14))/(16.0d0*B**5*CO*(SI**2-1)) -c - call revf(1,h,mh) -c - return - end -c -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/opti.f b/OpticsJan2020/MLI_light_optics/Src/opti.f deleted file mode 100755 index 0664d92..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/opti.f +++ /dev/null @@ -1,1798 +0,0 @@ -c -c*************************************** -c -c OPTI is an alphabetized collection of the routines in -c NLS, QSO, and SHARED, by Kurt Overley, LANL 89, -c as modified by Tom Mottershead, March 91 -c-------------------------------------------------------- - subroutine condn( maxf,nx,fjac,info) -c -c subroutine condn returns the condition number of the jacobian. -c---------------------------------------------------------------------- - include 'impli.inc' - parameter (epsmach = 1.0d-16) - dimension fjac(maxf,nx) -c - dmax = dabs(fjac(1,1)) - dmin = dmax - do 10 i = 2,nx - diag = dabs(fjac(i,i)) - if (diag .gt. dmax) then - dmax = diag - else if (diag .lt. dmin ) then - dmin = diag - endif - 10 continue - rcond = dmin / dmax - if (rcond .lt. epsmach) info = 5 - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - double precision function enorm(n,x) - integer n - double precision x(n) -c ********** -c -c function enorm -c -c given an n-vector x, this function calculates the -c euclidean norm of x. -c -c the euclidean norm is computed by accumulating the sum of -c squares in three different sums. the sums of squares for the -c small and large components are scaled so that no overflows -c occur. non-destructive underflows are permitted. underflows -c and overflows do not occur in the computation of the unscaled -c sum of squares for the intermediate components. -c the definitions of small, intermediate and large components -c depend on two constants, rdwarf and rgiant. the main -c restrictions on these constants are that rdwarf**2 not -c underflow and rgiant**2 not overflow. the constants -c given here are suitable for every known computer. -c -c the function statement is -c -c double precision function enorm(n,x) -c -c where -c -c n is a positive integer input variable. -c -c x is an input array of length n. -c -c subprograms called -c -c fortran-supplied ... dabs,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i - double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, - & x1max,x3max,zero - data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ - save one,zero,rdwarf,rgiant !cryne 7/23/2002 - s1 = zero - s2 = zero - s3 = zero - x1max = zero - x3max = zero - floatn = n - agiant = rgiant/floatn - do 90 i = 1, n - xabs = dabs(x(i)) - if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 - if (xabs .le. rdwarf) go to 30 -c -c sum for large components. -c - if (xabs .le. x1max) go to 10 - s1 = one + s1*(x1max/xabs)**2 - x1max = xabs - go to 20 - 10 continue - s1 = s1 + (xabs/x1max)**2 - 20 continue - go to 60 - 30 continue -c -c sum for small components. -c - if (xabs .le. x3max) go to 40 - s3 = one + s3*(x3max/xabs)**2 - x3max = xabs - go to 50 - 40 continue - if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 - 50 continue - 60 continue - go to 80 - 70 continue -c -c sum for intermediate components. -c - s2 = s2 + xabs**2 - 80 continue - 90 continue -c -c calculation of norm. -c - if (s1 .eq. zero) go to 100 - enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) - go to 130 - 100 continue - if (s2 .eq. zero) go to 110 - if (s2 .ge. x3max) - & enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) - if (s2 .lt. x3max) - & enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3))) - go to 120 - 110 continue - enorm = x3max*dsqrt(s3) - 120 continue - 130 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine findhi( dmuhi, ld, n, h, hmu, - & g, step, region, info) -c -c subroutine findhi finds the upper value of the levenberg-marquardt -c parameter that brackets the root of the nonlinear equation, -c phi = region - stepnm. -c-------------------------------------------------------- - include 'impli.inc' - dimension h(ld,n), hmu(ld,n) - dimension g(n), step(n) -c - 10 continue - do 20 i = 1,n - call vecopy( n, h(1,i), hmu(1,i)) - hmu(i,i) = h(i,i) + dmuhi - 20 continue - call newton( ld, n, hmu, g, step, info) - if ( info .gt. 0) return - stepnm = enorm(n, step) - if (stepnm .gt. region) then - dmuhi = 2.0d0 * dmuhi - go to 10 - endif - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine geta (maxv, maxq, nx, m, a, xu) -c -c subroutine geta forms the linear system in the center of mass -c coordinates whose solution yields the quadratic coefficients. -c--------------------------------------------------------------- - include 'impli.inc' - dimension a(maxq,m), xu(maxv, m) -c - do 10 k = 1, m - a(k,1) = 1.0 - do 20 i = 1, nx - a(k,i+1) = xu(i,k) - if ( (i+1+nx) .gt. m) go to 20 - a(k,i+1+nx) = xu(i,k)**2 - 20 continue - 25 indexa = 2 * nx + 1 - do 30 i = 1, nx-1 - do 40 j = i+1,nx - indexa = indexa + 1 - if (indexa .gt. m) go to 10 - a(k,indexa) = xu(i,k) * xu(j,k) - 40 continue - 30 continue - 10 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine gradck( n, sgrad, grel, sigma, fv, tol, info) -c -c subroutine gradck provides the main stopping criterion for -c oracle. -c------------------------------------------------------------------ - include 'impli.inc' - dimension sgrad(n), sigma(n) -c - grel = 0 - fmag = dmax1(dabs(fv), 1.0d0) - do 10 i = 1,n - grcomp = dabs( sgrad(i)*dmax1(sigma(i), 1.0d0))/fmag - grel = dmax1( grel, grcomp) - 10 continue - if (grel .lt. tol) info = 9 - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine hesian( ld, nx, h, g, nq, q) -c -c subroutine hesian forms the hessian matrix and the gradient vector -c from the vector of the quadratic coefficients. -c------------------------------------------------------ - include 'impli.inc' - dimension h(ld,nx), g(nx), q(nq) -c - do 10 i = 1, nx - g(i) = - q(i+1) - h(i,i) = 2.0d0 * q(i+1+nx) - 10 continue - indexq = 2*nx + 1 - do 20 i = 1, nx-1 - do 30 j = i+1, nx - indexq = indexq + 1 - h(i,j) = q(indexq) - h(j,i) = h(i,j) - 30 continue - 20 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine initq( m, nx, q) -c -c subroutine initq sets the initial vector of quadratic coefficients -c so that the hessian will start as the identity. -c--------------------------------------------------- - include 'impli.inc' - dimension q(m) -c - do 10 i=1,m - if ( (i .gt. (1+nx)) .and. (i .le. (1+2*nx))) then - q(i) = 0.5 - else - q(i) = 0.0 - endif - 10 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine optisort( iter, dist, nseq, nq) -c -c sorts the first nq entries of the nseq to the -c list of distances from nearest to farthest. -cryne 8/17/02 name changed from isort to optisort because isort -cryne is a name found in a widely used library. -c--------------------------------------------------------------------- - include 'impli.inc' - dimension dist(iter), nseq(iter) -c -c initialize nseq array in reverse order to lessen sorting. -c - do 10 i=1,iter - nseq(i) = iter + 1 - i - 10 continue -c -c make nq passes through the nseq list, sorting on distance. -c - do 20 j=1,nq - do 30 k= j+1, iter - if ( dist(nseq(k)) .lt. dist(nseq(j)) ) then -c -c switch indices. -c - itemp = nseq(j) - nseq(j) = nseq(k) - nseq(k) = itemp - endif - 30 continue - 20 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine jtjmul( ldj,ldjtj,nc,fjac,fjtj) -c -c subroutine jtjmul multiplies the jacobian transpose times the jacobian -c----------------------------------------------------------------------- - include 'impli.inc' - dimension fjac(ldj,nc), fjtj(ldjtj,nc) - parameter (maxv = 10) - dimension temp(maxv), tempt(maxv) -c - do 10 i= 1,nc - do 20 j = i,nc - do 30 k=1,nc - temp(k) = 0.0 - tempt(k) = 0.0 - 30 continue - call vecopy(i,fjac(1,i),tempt) - call vecopy(j,fjac(1,j),temp) - fjtj(i,j) = ddot(nc, tempt, 1, temp, 1) - fjtj(j,i) = fjtj(i,j) - 20 continue - 10 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine lform(maxv,maxf,nx,nf,nq,xu,fu,fjac,info,rcond) -c -c subroutine lform makes a linear approximation to the list of -c xv points and corresponding fv values. -c------------------------------------------------------------------- - include 'impli.inc' - dimension xu(maxv, nq), fu(maxf,nq) - dimension fjac(maxf, nx) -c - parameter (nxdim = 10, maxq = nxdim+1, epsmach = 1.0d-16) - dimension a(nxdim, nxdim), ascale(nxdim) - dimension y(nxdim), ipvt(nxdim), w(nxdim) -c - call nlsa(maxv, nx, nq, a, xu) - call scale(nxdim, nx, ascale, a, info) - if (info .ne. 0) return - call dgeco(a,nxdim,nx,ipvt,rcond,w) - if (rcond .lt. epsmach) then - info = 4 - return - endif - do 10 i = 1,nf - call dcopy(nx,fu(i,2),maxf,y,1) - call dgesl(a,nxdim,nx,ipvt,y,0) - do 20 j= 1,nx - fjac(i,j) = y(j) * ascale(j) - 20 continue - 10 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine lpick(nxmax,nfmax,nx,nf,nvec,iter,xu,fcen,fmu,fu) -c -c subroutine lpick selects the xu from among all xv points by -c choosing the best point, xcen, and the nvec - 1 nearest points -c to xcen. -c-------------------------------------------------------------------- - include 'impli.inc' -cryne 3/15/06 include 'nlsvar.inc' -cryne 3/15/06 here is nlsvar.inc: - - parameter (maxdat = 1000) - parameter (maxv = 10, maxf = 15, maxq = maxv+1 ) - common /nlsvar/ modu, ntot, nomin, minpt, maxpt, nlsi, fmin, - * fmax, regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), - * fdat(maxf,maxdat), fmdat(maxdat), fvmin(maxf), xcen(maxv) -cryne 3/15/06 save /nlsvar/ - - dimension xu(nxmax,nvec), fu(nfmax,nvec), fmu(nvec), fcen(nf) - dimension dist(maxdat), nseq(maxdat), xdif(maxv) - -cryne 3/15/06 - save -c -c write(6,*)'HEEEEEEERRRRRREEEEE I am in LPICK' - do 10 k = 1,iter - call vecdif(nx, xdat(1,k), xcen, xdif) - dist(k) = enorm(nx, xdif) - 10 continue - call optisort( iter, dist, nseq, nvec) -c -c check that the current point is included in the list -c - do 20 k=1,nvec - if(nseq(k).eq.iter) go to 30 - 20 continue -c -c didn't find current point (iter) in the list, so force it -c by replacing worst of the points already chosen: -c - nseq(nvec) = iter -c -c copy the selected points into the working vectors xu. The -c origin is taken as xcen. -c - 30 do 40 k = 1, nvec - nu = nseq(k) - call vecdif( nx, xdat(1,nu), xcen, xu(1,k)) - call vecdif( nf, fdat(1,nu), fcen, fu(1,k)) - fmu(k) = fmdat(nu) - 40 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine message(info,ipr) -c -c subroutine message prints out termination messages in the file -c qout.dat. -c--------------------------------------------------------------------- - include 'impli.inc' - parameter (epsmach = 1.0d-16, epsqrt = 1.0d-8) -c - write(ipr,*) - write(ipr,*) 'done' - if (info .eq. 1) then - write(ipr,*) 'the relative difference between ' - write(ipr,*) 'predicted and actual f values agree within ', - & epsqrt - else if (info .eq. 2) then - write(ipr,*) 'the relative norm of the difference between' - write(ipr,*) 'the last two x vectors lies within stol.' - else if (info .eq. 3) then - write(ipr,*) 'the relative norm of the difference between' - write(ipr,*) 'the last two q vectors lies within stol.' - else if (info .eq. 4) then - write(ipr,*)'exit due to ill-conditioning of the q-coefficient' - write(ipr,*) 'matrix, a. ' - else if (info .eq. 5) then - write(ipr,*) 'exit due to ill-conditioning of the hessian.' - else if (info .eq. 6) then - write(ipr,*)'exit due to attempted step of enormous magnitude.' - write(ipr,*)'If using mss, try increasing parameter 4' - else if (info .eq. 7) then - write(ipr,*) 'absolute f error lies within ',epsqrt - else if (info .eq. 8) then - write(ipr,*) 'absolute x error lies within stol.' - else if (info .eq. 9) then - write(ipr,*) 'relative gradient is less than gtol.' - else if (info .eq. 10) then - write(ipr,*) 'maximum number of iterations exceeded.' - else if (info .eq. 11) then - write(ipr,*) 'norm of residual lies within ftol.' - else if (info .eq. 12) then - write(ipr,*) 'successive steps have an identical component.' - else if (info .eq. 13) then - write(ipr,*) 'one of user-specified weights is zero.' - else if (info .eq. 14) then - write(ipr,*) '# of equations is less than # of unkowns.' - endif - return - end -c -ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine mvmult(lda,nr,nc,a,x,result) -c -c subroutine mvmult multiplies a vector, x, by a matrix, a. -c----------------------------------------------------------------------- - include 'impli.inc' - dimension a(lda,nc), x(nc), result(nr) - parameter (maxv = 10) - dimension xtemp(maxv) -c - call vecopy( nc, x, xtemp) - do 10 i = 1, nr - result(i) = ddot(nc, a(i,1), lda, xtemp, 1) - 10 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine newton( ld, nv, h, g, step, info) -c -c subroutine newton calculates the newton step from the best point, xce -c which is now the origin in the transformed frame of reference. -c----------------------------------------------------------------------- - include 'impli.inc' - parameter (maxv = 10, epsmach = 1.0d-16) - dimension h(ld,nv), g(nv), step(nv) - dimension w(maxv), ipvt(maxv), ht(maxv,maxv) -c - do 10 i= 1,nv - call vecopy( nv, h(1,i), ht(1,i)) - 10 continue - call dsico( ht, maxv, nv, ipvt, rcond, w) - if (rcond .lt. epsmach) then - info = 5 - return - endif - call vecopy(nv, g, step) - call dsisl( ht, maxv, nv, ipvt, step) - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine nls(mode,iter,nx,xv,nf,fv,iscale,wts,tol,info) -c -c subroutine nls solves nonlinear equations and least squares problems. -c -c written by tom mottershead and kurt overley of los alamos national -c laboratory in august 1989. -c -c -c variables: -c -c --> mode: running mode. -c = 0 for normal unconstrained minimization -c = 1 for constrained minimization in the box defined by -c (xlo(i),xhi(i)), i=1,nx -c = 2 to reload internal data commons and return without -c computing new point. -c = 3 for inquiry. The best point so far is returned in -c (xv,fv), its index is returned in iter, and the tota -c points stored is returned as info = - ntot -c -c --> iter: the iteration counter. should be incremented before ever -c call in normal running. -c iter = +n means (xv,fv) is stored and used as nth data -c iter = 0 or 1 causes initialization, clearing stored da -c iter = -n means return nth stored point in (xv,fv) -c -c --> nx: the number of variables. -c -c <--> xv(nx): the current point on input, the new point on output. -c -c <--> fv: the residual vector of function values at the current poi -c on input. -c -c --> iscale: controls x and f scaling. -c iscale = 0: no scaling. this is the recommended -c default value. if unsatisfactory performa -c results, the problem may be poorly scaled -c try the various scalings. -c iscale = 1: auto x scaling -c iscale = 2: auto f scaling -c iscale = 3: auto x and f scaling -c iscale = 4: scale f with wts, no x scaling -c iscale = 5: scale f with wts, auto x scaling -c -c --> wts(nf): a vector of weights to scale f. f(j) is replaced -c by w(j)*f(j). -c -c --> tol(j), j=1,4 -c tol(1) = gtol: if the relative gradient lies within the -c tolerance, gtol, nls exits. -c tol(2) = stol: nls exits if the absolute or relative -c difference between the the suggested minimizer, -c xnew, and the current point, xc, is less -c than stol. -c tol(3) = ftol: if the magnitude of the residual f vector -c is less than ftol, qadnls exits. -c tol(4) = initial step fraction stpfrc (default = 0.1) -c -c <-- info: on return info contains information as to the -c termination status of nls. -c info = 0: no termination yet. -c = 1: the relative difference between the predicted -c and actual values agrees within ftol. -c = 2: the relative difference between the last two -c xv vectors lies within stol. -c = 3: the relative difference between the last two -c q vectors lies within qtol. -c = 4: exit due to ill-conditioning of the q-coeffici -c matrix, a. -c = 5: exit due to ill-conditioning of the hessian. -c = 6: exit due to attempted step of enormous magnitu -c = 7: absolute fv error lies within ftol. -c = 8: absolute xv error lies within stol. -c = 9: relative gradient is less than gtol. -c = 10: maximum iterations exceeded (this must be -c determined by the program calling nls). -c = 11: absolute norm of residual function vector lie -c within ftol. -c = 12: successive steps have an identical x componen -c = 13: one of the user-specified weights is zero. -c = 14: number of equations is less than number of un -c -c parameters: -c -c maxv: the maximum number of variables allowed. -c -c maxf: the maximum number of equations allowed. -c -c maxq: the maximum number of points needed for fitting to a -c quadratic form. -c -c maxdat: the maximum number of points that can be stored. -c -c epsmach: the machine precision. -c -c gtol: the relative gradient tolerance. if the current relative -c gradient falls below gtol, nls exits. -c -c stol: the step tolerance. if two successive points lie -c within stol, nls exits. -c -c ftol: the residual tolerance. if the norm of the current residual -c falls below ftol, nls exits. -c -c stpfrc: the initial random steps are of length stpfrc * the -c norm of the current best point. -c -c trfrac: the initial trust region is set to trustfrac times -c the 2 norm of a vector of unit components, representativ -c of an "average" shifted and rms scaled xv vector. -c -c internal variables: -c -c xcen(maxv): the best point so far. it is the center of the linear -c approximation to the nonlinear system. -c -c xu(maxv,maxq): contains a list of the last nv + 1 points. -c -c fu(maxf,maxq): contains a list of the last nv + 1 function vectors -c -c fmu(maxq): the list of previous norms of residual function values. -c -c xdat(maxv,maxdat): the entire list of all points. -c -c fdat(maxf,maxdat): the entire list of all function vectors. -c -c fvmin(maxf): the best function vector so far. -c -c fcen(maxf): forms the centering function vector for the linear -c approximation to the nonlinear system. it is the same -c as fvmin. -c -c fmdat(maxdat): the entire list of norms of residual function vecto -c -c minpt: location of the minimum fv and xv in the data pool. -c -c maxpt: a pointer to the maximum fv and xv in the list. -c -c a(maxq,maxq): the quadratic coefficient matrix. -c -c ascale(maxq): a scaling vector that normalizes the columns -c of a to unit euclidean norm. -c -c y(maxq): the solution of the scaled a matrix. -c -c q(maxq): the vector of coefficients to the quadratic form. -c -c g(maxv): the gradient vector. -c -c fjac(maxv,maxv): the jacobian of the nonlinear system of equations -c or for nonlinear least squares is the jacobian of -c the norm of the function residual vector. -c -c step(maxv): the trust region newton step (nlstep). -c -c nq = nx+1 : the number of points needed to -c make a linear approximation to the jacobian of the -c norm of the function vector. -c -c nomin: the number of iterations since a new minimum point -c has been found. -c -c region: the region or radius about the current best point -c in which the quadratic model is trusted to accurately -c model the function. -c -c regold: the old trust region. -c -c dmu: the levenberg-marquardt parameter that adjusts the hessian -c to solve the constrained problem of minimizing the quadratic -c form subject to lying in a trust region about the best point. -c -c oldmu: the old levenberg-marquardt parameter. -c -c sgrad: the gradient of the function with respect to a step -c from the minimum point. note that this gradient is -c different from the gradient of fv with respect to xv. -c -c sigma: a vector containing the diagonal elements of a -c scaling matrix used to normalize each of the components of -c xcen to one. -c -c fsigma: a similar scaling vector for the function vectors. -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - include 'impli.inc' -cryne 3/15/06 include 'nlsvar.inc' - dimension xv(nx), fv(nf), tol(4), wts(nf) - parameter (epsmach = 1.0d-16) - parameter ( trfrac = 2.0d0) - -cryne 3/15/06 here is nlsvar.inc: - parameter (maxdat = 1000) - parameter (maxv = 10, maxf = 15, maxq = maxv+1 ) - common /nlsvar/ modu, ntot, nomin, minpt, maxpt, nlsi, fmin, - * fmax, regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), - * fdat(maxf,maxdat), fmdat(maxdat), fvmin(maxf), xcen(maxv) -cryne 3/15/06 save /nlsvar/ - - dimension xu(maxv, maxq), xnew(maxv) - dimension fu(maxf, maxq), fmu(maxq), fcen(maxf) - dimension fjac(maxf, maxv), g(maxv) - dimension sigma(maxv), fsigma(maxf), step(maxv) -cryne 3/15/06 - save -c - if (info .gt. 0) return - if (nf .lt. nx) then - info = 14 - return - endif - modu = mode -c -c nq is number of points needed for full linear form. -c nvec is the number available this iteration. -c - nq = nx + 1 - nvec = min0(nq,iter) - if(iter.gt.ntot) ntot=iter - gtol = tol(1) - stol = tol(2) - ftol = tol(3) - stpfrc = 0.1 - if(tol(4).gt.0.0) stpfrc = tol(4) -c type *, ' nls:',nq,'=nq',iter,'=iter',nvec,'=nvec' - if(iter.lt.0) return - if (iter .gt. 1) go to 60 -c -c initialize varibles on first iteration -c - seed = 1.0d0 - grel = 0.0 - fmin = 1.e30 - fmax = -fmin - minpt = 1 - maxpt = 1 - ntot = 0 - nomin = 0 - regold = 0.0 - region = 0.0 - oldmu = 0.0 - dmu = 0.0 - do 10 i = 1,nx - xnew(i) = 0.0 - xcen(i) = 0.0 - g(i) = 0.0 - sigma(i) = 0.0 - step(i) = 0.0 - 10 continue - do 15 i = 1,nf - fcen(i) = 0.0 - fvmin(i) = 0.0 - fsigma(i) = 0.0 - 15 continue - do 20 j = 1,nq - fmu(j) = 0.0 - do 25 i = 1,nf - fu(i,j) = 0.0 - 25 continue - do 30 i = 1,nx - xu(i,j) = 0.0 - 30 continue - 20 continue - do 40 j = 1,maxdat - fmdat(j) = 0.0 - do 45 i = 1,nf - fdat(i,j) = 0.0 - 45 continue - do 50 i = 1,nx - xdat(i,j) = 0.0 - 50 continue - 40 continue -c -c add new xv & fv to the data pool. -c - 60 continue - call vecopy( nx, xv, xdat(1,iter)) - call vecopy( nf, fv, fdat(1,iter)) - call vecopy( nf, fvmin, fcen) - fmerit = 0.5d0 * (enorm( nf,fv) ** 2.0d0) - fmdat(iter) = fmerit -c -c check for new minimum point -c - if(fmerit.lt.fmin) then - fmin = fmerit - minpt = iter - call vecopy(nx,xv,xcen) - call vecopy(nf,fv,fcen) - call vecopy(nf,fv,fvmin) - endif -c -c check for new maximum point -c - if(fmerit.gt.fmax) then - fmax = fmerit - maxpt = iter - endif -c -c random steps about the minimum the first nx times: -c -c write(6,*)'INSIDE NLS with iter, nx=',iter,nx - if (iter .le. nx) then - call ranstep(iter, nx, seed, xcen, xv, stpfrc) - return - endif -c------------------------------------------------------------- -c Normal running: fit and solve the linear approximation when -c there are enough points: -c------------------------------------------------------------- -c -c lpick the best points - xu - to fit to a quadratic form: -c - call lpick(maxv,maxf,nx,nf,nq,iter,xu,fcen,fmu,fu) -c -c normalize the working points - xu -c - if ((iscale.eq.1) .or. (iscale.eq.3) .or. (iscale.eq.5)) then - call nlscal( maxv, nx, nq, nvec, sigma, xu) - endif - if (iscale.ge.2) then - call scalfu( maxf,nf,nq,fsigma,fu,fcen,iscale,wts,info) - endif -c -c determine quadratic form -c - call lform(maxv,maxf,nx,nf,nq,xu,fu,fjac,info,rcond) - if (info .gt. 0) go to 99 -c -c reset trust region -c - call truset(nx, nq, fmu, fpred, fmerit, - & trfrac, iter, nomin, minpt, nvec, regold, region) -c -c compute step on surface of trust region -c - call nlstep(maxf, nx, nf, fjac, fcen, g, step, trfrac, - & nq, iter, regold, region, oldmu, dmu, info) - if (info .gt. 0) go to 99 -c -c compute xnew by adding rescaled step to xcen -c - do 80 i = 1,nx - if ((iscale.eq.1).or.(iscale.eq.3).or.(iscale.eq.5)) then - xnew(i) = xcen(i) + step(i)*sigma(i) - else - xnew(i) = xcen(i) + step(i) - endif - 80 continue -c -c check whether xnew has moved enough to continue the search -c - call xstop(nx, xv, xnew, stol, info) -c -c put xnew in the xv vector for the return - call vecopy(nx, xnew, xv) - if (info .gt. 0) go to 99 -c -c check gradient for convergence -c -cryne not sure I did this right, but here is how I changed this on 29 April 2008: -cryne call gradck( nx, g, grel, sigma, fv, gtol, info) - fvmaxabs=maxval(abs(fv)) - call gradck( nx, g, grel, sigma, fvmaxabs, gtol, info) - if (fmerit .lt. ftol) info = 11 - 99 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine nlsa (maxv, nx, nq, a, xu) -c -c subroutine nlsa forms the linear system in the center of mass -c coordinates whose solution yields the quadratic coefficients. -c--------------------------------------------------------------- - include 'impli.inc' - dimension a(maxv,nx), xu(maxv, nq) -c - do 10 k = 1, nx - call dcopy(nx,xu(1,k+1),1,a(k,1),maxv) - 10 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine nlscal( nxmax, nx, nq, nvec, sigma, xu) -c -c subroutine nlscal finds the rms values of each of the components -c in the xu. then each of the xu vector components is scaled -c by the inverse of the rms values. -c------------------------------------------------------------------ - include 'impli.inc' - dimension sigma(nx), xu(nxmax, nq) -c - tol = 1.d-15 - denom = nvec - 1 -c -c loop over all components -c - do 40 i = 1, nx - sigma(i) = 0.0 -c -c collect standard deviation of all components -c - do 20 j = 2, nvec - sigma(i) = sigma(i) + xu(i,j)**2 - 20 continue - sigma(i) = dsqrt(sigma(i)/ denom) -c -c renormalize all vectors -c - xdenom = dabs(xu(i,2)) - if(xdenom.le.tol) then - sigma(i) = 1.0d0 - go to 40 - else - sigma(i) = xdenom/ sigma(i) - do 30 j = 2, nvec - xu(i,j) = xu(i,j)/sigma(i) - 30 continue - endif - 40 continue - return - end -c -c********************************************************************* -c - subroutine nlstep( mf, nx, nf, fjac, fcen, g, step, trfrac, - & nq, iter, regold, region, oldmu, dmu, info) -c -c nlstep (trust region step) calculates the new xv point that solves th -c constrained problem of minimizing a quadratic functional subject to -c lying in trust region about the best xv point. -c------------------------------------------------------------ - include 'impli.inc' - dimension fjac(mf, nx), g(nx), step(nx), fcen(nf) -c - parameter (maxv = 10, maxf = 15) - dimension fjact(maxv, maxf),fjtj(maxv,maxv),fjtjmu(maxv,maxv) - dimension qraux(maxv), rsd(maxf) -c -c c first try the newton step. -c - factor = -1.0d0 - call dscal(nf, factor, fcen, 1) - call trnsps(maxf,maxv,nf,nx,fjac,fjact) - call mvmult(maxv,nx,nf,fjact,fcen,g) - call dqrdc(fjac,maxf,nf,nx,qraux,jdum,dum,0) - call condn(maxf,nx,fjac,info) - if (info .gt. 0) return - if (nf .eq. nx) then - call dqrsl(fjac,maxf,nf,nx,qraux,fcen,dum,rsd,step,rsd, - & dum,110,info) - else - call vecopy( nx,g,step) - call dposl( fjac,maxf,nx,step) - endif - if ( info .gt. 0) return - stepnm = enorm(nx, step) - regmax = 1.5*region - regmin = 0.75*region - if (stepnm .lt. regmax) then - oldmu = 0.0 - region = stepnm - return - endif -c -c c newton step has failed, so calculate a dmu such that step(dmu) -c c is fairly close to the region. -c - call jtjmul(maxf,maxv,nx,fjac,fjtj) - dmulow = 0.0 - gnorm = enorm(nx, g) - dmuhi = gnorm/ region - call findhi( dmuhi, maxv, nx, fjtj, fjtjmu, - & g, step, region, info) - if (info .gt. 0) return - if (oldmu .eq. 0.0) then - dmu = dmuhi/ 2.0d0 - else - dmu = (regold/ region) * oldmu - endif - if ( (dmu .lt. dmulow) .or. (dmuhi .lt. dmu) ) then - dmu = dmulow + (dmuhi - dmulow)/ 2.0d0 - endif -c -c c at 40 the mu loop begins by calculating a new step. -c - 40 continue - do 30 i = 1,nx - call vecopy( nx, fjtj(1,i), fjtjmu(1,i)) - fjtjmu(i,i) = fjtj(i,i) + dmu - 30 continue - call newton( maxv, nx, fjtjmu, g, step, info) - if (info .gt. 0) return -c call dpofa(fjtjmu,maxv,nx,info) -c if (info .gt. 0) then -c info = 5 -c return -c endif -c call vecopy(nx, g, step) -c call dposl(fjtjmu,maxv,nx,step) - stepnm = enorm(nx, step) - if ( (regmin .lt. stepnm) .and. (stepnm .lt. regmax) ) then - go to 99 - endif -c -c c update the mu bounds and get a new mu. -c - phi = stepnm - region - if (phi .gt. 0.0) then - dmulow = dmu - else - dmuhi = dmu - endif - if (dmuhi .le. dmulow) then - go to 99 - endif - dmu = dmulow + (dmuhi - dmulow)/ 2.0d0 - go to 40 -c -c c at 99 do exit chores. -c - 99 continue - oldmu = dmu - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine qform(maxv, nx, nq, nvec, xu, fu, h, g, info, rcond) -c -c subroutine qform fits a quadratic form (finds the hessian matrix, h, -c and the gradient, g) to the list of xv points and corresponding -c fv values. -c------------------------------------------------------------------- - include 'impli.inc' - dimension xu(maxv, nq), fu(nq) - dimension h(maxv, nx), g(nx) -c - parameter (nxdim = 10, maxq = (nxdim+1)*(nxdim+2)/2) - dimension a(maxq, maxq), ascale(maxq) - dimension y(maxq), q(maxq) -c -c type *, ' qform:',maxv,'=maxv',nx,'=nx',nvec,'=nvec',nq,'=nq' - if (nvec .lt. nq) call initq( nq, nx, q) - call geta(maxv, maxq, nx, nvec, a, xu) -cryne 3/15/06 call scale(maxq, nvec, ascale, a) - call scale(maxq, nvec, ascale, a, info) - call solve(maxq, nvec, a, y, fu, info, rcond) - if (info .gt. 0) return - do 10 i = 1,nvec - q(i) = y(i) * ascale(i) - 10 continue - call hesian(maxv, nx, h, g, nq, q) - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine qso(mode,iter,nx,xv,fv,iscale,tol,info) -c -c subroutine qadmin is an unconstrained minimization routine that employ -c quadratic form fitting with a trust region step control stategy. -c -c written by tom mottershead and kurt overley of los alamos national -c laboratory in august 1988. -c Renamed 22 Mar 91 to QFM = Quadratic Fit Minimizer (at first -c installation in Marylie. Still not happy with name. -c -c variables: -c -c --> mode: running mode. -c = 0 for normal unconstrained minimization -c = 1 for constrained minimization in the box defined by -c (xlo(i),xhi(i)), i=1,nx -c = 2 to reload internal data commons and return without -c computing new point. -c = 3 for inquiry. The best point so far is returned in -c (xv,fv), its index is returned in iter, and the tota -c points stored is returned as info = - ntot -c -c --> iter: the iteration counter. should be incremented before ever -c call in normal running. -c iter = +n means (xv,fv) is stored and used as nth data -c iter = 0 or 1 causes initialization, clearing stored da -c iter = -n means return nth stored point in (xv,fv) -c -c --> nx: the number of variables. -c -c <--> xv(nx): the current point on input, the new point on output. -c -c <--> fv: the function value at the current point on input, the new -c predicted value of the minimun on output -c -c --> iscale: controls x. -c iscale = 0: no scaling. this is the recommended -c default value. if unsatisfactory performa -c results, the problem may be poorly scaled -c try scaling. -c iscale = 1: auto x scaling. -c -c --> tol(j), j=1,4 -c tol(1) = gtol: if the relative gradient lies within the -c tolerance, gtol, qadmin exits. -c tol(2) = stol: qadmin exits if the absolute or relative -c difference between the the suggested minimizer, -c xnew, and the current point, xc, is less -c than stol. -c -c tol(3) = ftol: not used by qadmin, but by nls. -c tol(4) = initial step fraction stpfrc (default = 0.1) -c -c <-- info: on return info contains information as to the -c termination status of qadmin. -c info = 0: no termination yet. -c = 1: the relative difference between the predicted -c and actual values agrees within ftol. -c = 2: the relative difference between the last two -c xv vectors lies within stol. -c = 3: the relative difference between the last two -c q vectors lies within qtol. -c = 4: exit due to ill-conditioning of the q-coeffici -c matrix, a. -c = 5: exit due to ill-conditioning of the hessian. -c = 6: exit due to attempted step of enormous magnitu -c = 7: absolute fv error lies within ftol. -c = 8: absolute xv error lies within stol. -c = 9: relative gradient is less than gtol. -c -c parameters: -c -c maxv: then maximum number of variables allowed. -c -c maxq: the maximum number of points needed for fitting to a -c quadratic form. -c -c maxdat: the maximum number of points that can be stored. -c -c epsmach: the machine precision. -c -c gtol: the relative gradient tolerance. if the current relative -c gradient falls below gtol, qadmin exits. -c -c stol: the step tolerance. if two successive points lie -c within stol, qadmin exits. -c -c ftol: the residual tolerance. if the norm of the current residual -c falls below ftol, qadmin exits. -c -c stpfrc: the initial random steps are of length stpfrc * the -c norm of the current best point. -c -c trfrac: the initial trust region is set to trustfrac times -c the 2 norm of a vector of unit components, representativ -c of an "average" shifted and rms scaled xv vector. -c -c internal variables: -c -c xu(maxv,maxq): contains a list of the last (n+1)(n+2)/2 points. -c -c fu(maxq): the list of previous function values. -c -c xdat(maxv,maxdat): the entire list of all points. -c -c fdat(maxdat): the entire list of function values. -c -c minpt: location of the minimum fv and xv in the data pool. -c -c maxpt: a pointer to the maximum fv and xv in the list. -c -c a(maxq,maxq): the quadratic coefficient matrix. -c -c ascale(maxq): a scaling vector that normalizes the columns -c of a to unit euclidean norm. -c -c y(maxq): the solution of the scaled a matrix. -c -c q(maxq): the vector of coefficients to the quadratic form. -c -c h(maxv,maxv): the second derivative hessian matrix. -c -c g(maxv): the gradient vector. -c -c step(maxv): the trust region newton step (trstep). -c -c nq = (nx+1)*(nx+2)/2 : the number of points needed to -c determine a quadratic form. -c -c nomin: the number of iterations since a new minimum point -c has been found. -c -c region: the region or radius about the current best point -c in which the quadratic model is trusted to accurately -c model the function. -c -c regold: the old trust region. -c -c dmu: the levenberg-marquardt parameter that adjusts the hessian -c to solve the constrained problem of minimizing the quadratic -c form subject to lying in a trust region about the best point. -c -c oldmu: the old levenberg-marquardt parameter. -c -c sgrad: the gradient of the function with respect to a step -c from the minimum point. note that this gradient is -c different from the gradient of fv with respect to xv. -c -c sigma: a vector containing the diagonal elements of a -c scaling matrix used to normalize each of the components of -c xcen to one. -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - include 'impli.inc' -cryne--- 23 March 2006 include 'minvar.inc' - parameter ( maxdat = 1000) - parameter (maxv = 10, maxq = (maxv+1)*(maxv+2)/2 ) - common /minvar/ jtyp, modu, ntot, nomin, minpt, maxpt, fmin, fmax, - * regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), fdat(maxdat) -cryne save /minvar/ -cryne--- - dimension xv(nx), tol(4) - parameter (epsmach = 1.0d-16) - parameter ( trfrac = 2.0d0) - dimension xu(maxv, maxq), fu(maxq), xcen(maxv), xnew(maxv) - dimension h(maxv, maxv), g(maxv) - dimension sigma(maxv), step(maxv) -cryne--- 23 march 2006: - save -c - write(6,*)'------****-----INSIDE QSO with iter=',iter -c - if (info .gt. 0) return - modu = mode -c -c nq is number of points needed for full quadratic form. -c nvec is the number available this iteration. -c - nq = (nx + 1)*(nx + 2)/2 - nvec = min0(nq,iter) - if(iter.gt.ntot) ntot=iter - stol = tol(1) - gtol = tol(2) - stpfrc = 0.1 - if(tol(4).gt.0.0) stpfrc = tol(4) -c type *, ' qadmin:',nq,'=nq',iter,'=iter',nvec,'=nvec' - if(iter.lt.0) return - if (iter .gt. 1) go to 60 -c -c initialize varibles on first iteration -c - seed = 1.0d0 - grel = 0.0 - fmin = 1.e30 - fmax = -fmin - minpt = 1 - maxpt = 1 - ntot = 0 - nomin = 0 - regold = 0.0 - region = 0.0 - oldmu = 0.0 - dmu = 0.0 - do 10 i = 1,nx - xnew(i) = 0.0 - xcen(i) = 0.0 - g(i) = 0.0 - sigma(i) = 0.0 - step(i) = 0.0 - 10 continue - do 20 j = 1,nq - fu(j) = 0.0 - do 30 i = 1,nx - xu(i,j) = 0.0 - 30 continue - 20 continue - do 40 j = 1,maxdat - fdat(j) = 0.0 - do 50 i = 1,nx - xdat(i,j) = 0.0 - 50 continue - 40 continue -c -c add new xv & fv to the data pool. -c - 60 continue - call vecopy( nx, xv, xdat(1,iter)) - fdat(iter) = fv -c -c check for new minimum point -c - if(fv.lt.fmin) then - fmin = fv - minpt = iter - call vecopy(nx,xv,xcen) - endif -c -c check for new maximum point -c - if(fv.gt.fmax) then - fmax = fv - maxpt = iter - endif -c -c random steps about the minimum the first nx times: -c - if (iter .le. nx) then - call ranstep(iter, nx, seed, xcen, xv, stpfrc) - return - endif -c------------------------------------------------------------- -c Normal running: fit and solve the quadratic form when -c there are enough points: -c------------------------------------------------------------- -c -c select the best points - xu - to fit to a quadratic form: -c - call bestpt(maxv,nx,nvec,iter,xcen,xu,fu) -c -c normalize the working points - xu -c - if (iscale .eq. 1) then - call scalxu( maxv, nx, nq, nvec, sigma, xu) - endif -c -c determine quadratic form -c - call qform(maxv, nx, nq, nvec, xu, fu, h, g, info, rcond) - if (info .gt. 0) go to 99 -c -c reset trust region -c - call truset(nx, nq, fu, fpred, fv, - & trfrac, iter, nomin, minpt, nvec, regold, region) -c -c compute step on surface of trust region -c - call trstep(maxv, nx, h, g, step, trfrac, - & nq, iter, regold, region, oldmu, dmu, info) - if (info .gt. 0) go to 99 -c -c compute xnew by adding rescaled step to xcen -c - do 80 i = 1,nx - if (iscale .eq. 1) then - xnew(i) = xcen(i) + step(i)*sigma(i) - else - xnew(i) = xcen(i) + step(i) - endif - 80 continue -c -c check whether xnew has moved enough to continue the search -c - call xstop(nx, xv, xnew, stol, info) -c -c put xnew in the xv vector for the return - call vecopy(nx, xnew, xv) - if (info .gt. 0) go to 99 -c -c check gradient for convergence -c - call gradck( nx, g, grel, sigma, fv, gtol, info) - 99 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine ranstep( iter, nv, seed, xcen, xnew, stpfrc) -c -c subroutine ranstep generates the first n+1 points by taking random -c steps from the current best point. note there is no protection -c for components of xnew to remain positive. -c-------------------------------------------------------------------- - include 'impli.inc' - dimension xcen(nv), xnew(nv) -c -c - call vecopy( nv, xcen, xnew) - do 10 i=1,nv -c seed = ran( idint( seed*1.0d8 + 1.0d0) ) -c xnew(i) = seed - 0.5d0 - call random_number(x) -c write(6,*)'i,x=',i,x - xnew(i) = x - 0.5d0 - 10 continue - cnorm = enorm(nv, xnew) - xnorm = enorm(nv, xcen) - if (xnorm .eq. 0.) then - dnv = nv - xnorm = dsqrt(dnv) - endif - factor = stpfrc * xnorm/cnorm -c write(6,*)'cnorm,xnorm=',cnorm,xnorm -c write(6,*)'stpfrc,factor=',stpfrc,factor - do 20 i=1,nv - xnew(i) = xcen(i) + factor * xnew(i) - 20 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine scale(ld, n, vscale, dmat, info) -c -c subroutine scale scales a matrix so its columns have unit norm. -c---------------------------------------------------------------- - include 'impli.inc' - dimension vscale(n), dmat(ld,ld) -c - do 10 i = 1,n - denom = enorm(n, dmat(1,i)) - if (denom .eq. 0.) then - info = 12 - return - endif - vscale(i) = 1.0d0/denom - 10 continue - do 30 i = 1,n - do 40 j = 1,n - dmat(j,i) = dmat(j,i) * vscale(i) - 40 continue - 30 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine scalfu( nfmax, nf, nq, fsigma, fu, fcen, - & iscale, wts, info) -c -c subroutine scalfu scales the list of function vectors using the same -c automatic scaling as the x points or else the user-specified weight -c vector. -c---------------------------------------------------------------------- - include 'impli.inc' - dimension fsigma(nf), fu(nfmax, nq), fcen(nf), wts(nf) -c - if (iscale.ge.4) then - do 20 i=1,nf - if (wts(i) .eq. 0.0) then - info = 13 - return - endif - fsigma(i) = 1.0d0/ wts(i) - do 30 j = 2, nq - fu(i,j) = fu(i,j)/ fsigma(i) - 30 continue - 20 continue - else - call nlscal( nfmax, nf, nq, nq, fsigma, fu) - endif - do 10 i = 1,nf - fcen(i) = fcen(i)/ fsigma(i) - 10 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine scalxu( nxmax, nx, nq, nvec, sigma, xu) -c -c subroutine scalxu finds the rms values of each of the components -c in the xu. then each of the xu vector components is scaled -c by the inverse of the rms values - i.e. normalized to unit variance. -c------------------------------------------------------------------ - include 'impli.inc' - dimension sigma(nx), xu(nxmax, nq) -c - tol = 1.d-15 - denom = nvec - 1 -c -c loop over all components -c - do 40 i = 1, nx - sigma(i) = 0.0 -c -c collect standard deviation of all components -c - do 20 j = 2, nvec - sigma(i) = sigma(i) + xu(i,j)**2 - 20 continue - sigma(i) = dsqrt(sigma(i)/ denom) -c -c renormalize all vectors to unit variance -c - if(sigma(i).le.tol) go to 40 - do 30 j = 2, nvec - xu(i,j) = xu(i,j)/sigma(i) - 30 continue - 40 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine bestpt(nxmax,nx,nvec,iter,xcen,xu,fu) -c -c subroutine bestpt selects the xu from among all xv points by -c choosing the best point, xcen, and the nvec - 1 nearest points -c to xcen. -c-------------------------------------------------------------------- - include 'impli.inc' -cryne--- 23 March 2006 include 'minvar.inc' - parameter ( maxdat = 1000) - parameter (maxv = 10, maxq = (maxv+1)*(maxv+2)/2 ) - common /minvar/ jtyp, modu, ntot, nomin, minpt, maxpt, fmin, fmax, - * regold, region, seed, oldmu, dmu, xdat(maxv,maxdat), fdat(maxdat) -cryne save /minvar/ -cryne--- - dimension xu(nxmax,nvec), fu(nvec), xcen(nx) - dimension dist(maxdat), nseq(maxdat), xdif(maxv) -cryne--- 23 march 2006: - save -c - do 10 k = 1,iter - call vecdif(nx, xdat(1,k), xcen, xdif) - dist(k) = enorm(nx, xdif) - 10 continue - call optisort( iter, dist, nseq, nvec) -c -c check that the current point is included in the list -c - do 20 k=1,nvec - if(nseq(k).eq.iter) go to 30 - 20 continue -c -c didn't find current point (iter) in the list, so force it -c by replacing worst of the points already chosen: -c - nseq(nvec) = iter -c -c copy the selected points into the working vectors xu. The -c origin is taken as xcen. -c - 30 do 40 k = 1, nvec - nu = nseq(k) - call vecdif( nx, xdat(1,nu), xcen, xu(1,k)) - fu(k) = fdat(nu) - 40 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine solve(ld, n, dmat, dx, data, info, rcond) -c -c subroutine solve uses the linpack subroutine dgeco and dgesl to -c solve a general linear system. -c---------------------------------------------- - include 'impli.inc' - dimension dmat(ld,ld), dx(n), data(n) - parameter (maxv = 10, maxq = (maxv+1)*(maxv+2)/2 ) - parameter (epsmach = 1.0d-16) - dimension w(maxq), ipvt(maxq), tempd(maxq,maxq) -c - do 10 i = 1,n - call vecopy( n, dmat(1,i), tempd(1,i)) - 10 continue - call dgeco( tempd, maxq, n, ipvt, rcond, w) - if (rcond .lt. epsmach) then - info = 4 - return - endif - call vecopy( n, data, dx) - call dgesl( tempd, maxq, n, ipvt, dx, 0) - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine trnsps( lda, ldat, nr, nc, a, at) -c -c subroutine trnsps transposes a matrix. -c----------------------------------------------------------------------- - include 'impli.inc' - dimension a(lda,nc), at(ldat,nr) -c - do 10 i = 1,nc - call dcopy(nr, a(1,i),1,at(i,1),ldat) - 10 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine trstep( ld, nx, h, g, step, trfrac, - & nq, iter, regold, region, oldmu, dmu, info) -c -c trstep (trust region step) calculates the new xv point that solves th -c constrained problem of minimizing a quadratic functional subject to -c lying in trust region about the best xv point. -c------------------------------------------------------------ - include 'impli.inc' - dimension h(ld,nx), g(nx), step(nx) -c - parameter (maxv = 10) - dimension hmu(maxv,maxv) -c -c c first try the newton step. -c - call newton( ld, nx, h, g, step, info) - if ( info .gt. 0) return - stepnm = enorm(nx, step) -c if (iter .eq. nq) then -c region = stepnm -c endif - regmax = 1.5*region - regmin = 0.75*region - if (stepnm .lt. regmax) then - oldmu = 0.0 - region = stepnm - return - endif -c -c c newton step has failed, so calculate a dmu such that step(dmu) -c c is fairly close to the region. -c - dmulow = 0.0 - gnorm = enorm(nx, g) - dmuhi = gnorm/ region - call findhi( dmuhi, maxv, nx, h, hmu, - & g, step, region, info) - if (info .gt. 0) return - if (oldmu .eq. 0.0) then - dmu = dmuhi/ 2.0d0 - else - dmu = (regold/ region) * oldmu - endif - if ( (dmu .lt. dmulow) .or. (dmuhi .lt. dmu) ) then - dmu = dmulow + (dmuhi - dmulow)/ 2.0d0 - endif -c -c c at 40 the mu loop begins by calculating a new step. -c - 40 continue - do 30 i = 1,nx - call vecopy( nx, h(1,i), hmu(1,i)) - hmu(i,i) = h(i,i) + dmu - 30 continue - call newton( ld, nx, hmu, g, step, info) - if ( info .gt. 0) return - stepnm = enorm(nx, step) - if ( (regmin .lt. stepnm) .and. (stepnm .lt. regmax) ) then - go to 99 - endif -c -c c update the mu bounds and get a new mu. -c - phi = stepnm - region - if (phi .gt. 0.0) then - dmulow = dmu - else - dmuhi = dmu - endif -c call vecopy( nx, step, temp) -c call dsisl( hmu, maxv, nx, ipvt, temp) -c phip = ddot( nx, step, 1, temp, 1) / stepnm - if (dmuhi .le. dmulow) then - go to 99 - endif -c if (phip .ne. 0.) then -c dmu = dmu - (stepnm/ region) * (phi/ phip) -c endif - dmu = dmulow + (dmuhi - dmulow)/ 2.0d0 -c if ( (dmu .lt. dmulow) .or. (dmuhi .lt. dmu) ) then -c dmu = dmulow + (dmuhi - dmulow)/ 2.0d0 -c endif - go to 40 -c -c c at 99 do exit chores. -c - 99 continue - oldmu = dmu - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine truset(nv, nq, fmu, fpred, fmerit, - & trfrac, iter, nomin, minpt, maxpt, regold, region) -c -c subroutine truset updates the size of the trust region. if the -c current fv value is less than the previous best, than the trust regio -c doubles. the trust region will also double if the current function -c value is within 10% of the predicted function value. if the fv value -c worse than the previous worst, the trust region halves. -c -c function values which lie between the best and worst function values -c cause no change in the size of the trust region for n iterations. -c thereafter, each in-between function value halves the trust region. -c -c the reason n iterations are allowed without effect is to keep at leas -c n function evaluations within the current trust region, to avoid the -c problem of allowing the trust region to shrink so far that all the -c other points besides xcen lie outside. the latter situation is -c undesirable because the model that we "trust" is determined by points -c that lie outside the region in which we trust the model, a glaring -c contradiction. -c--------------------------------------------------------------------- - include 'impli.inc' - dimension fmu(nq) -c - regold = region - if ( iter .eq. (nv+1)) then - dnv = nv - region = trfrac * dsqrt(dnv) - return - else if ( fmerit .le. fmu(1) ) then - region = 2.0d0 * regold - nomin = 0 - else - nomin = nomin + 1 -c if ( relerr(1, fv, fpred) .lt. 1.0d-1) then -c region = 2.0d0 * regold - if (nomin .ge. nv) then - region = regold / 2.0d0 - else if ( fmerit .ge. fmu(maxpt) ) then - region = regold / 2.0d0 - endif - endif - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine vecdif(n, v1, v2, dif) -c -c subroutine vecdif subtracts two vectors. -c------------------------------------------------- - include 'impli.inc' - dimension v1(n), v2(n), dif(n) -c - do 10 i = 1,n - dif(i) = v1(i) - v2(i) - 10 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine vecopy( n, xin, xout) - include 'impli.inc' - dimension xin(n), xout(n) -c - do 10 i=1,n - xout(i) = xin(i) - 10 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine xstop( n, xv, xnew, tol, info) -c -c subroutine xstop determines whether current xv and the new xv lie -c within the specified tolerance, either absolutely or relatively. -c------------------------------------------------------------------ - include 'impli.inc' - parameter (maxv = 10, maxq = (maxv+1)*(maxv+2)/2 ) - dimension xv(n), xnew(n), xdif(maxv) - call vecdif(n, xv, xnew, xdif) -c -c check absolute difference -c - absdif = enorm(n, xdif) - if (absdif .lt. tol) then - info = 8 - return - endif -c -c check for grossly oversized step -c - xnorm = enorm(n, xv) - xnewnm = enorm(n, xnew) - if (xnorm .lt. tol*xnewnm) then - info = 6 - return - endif -c -c check relative step size -c - xnmax = dmax1( xnewnm, xnorm) - reldif = absdif/ xnmax - if (reldif .lt. tol) then - info = 2 - endif - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/optics.f b/OpticsJan2020/MLI_light_optics/Src/optics.f deleted file mode 100755 index f90958c..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/optics.f +++ /dev/null @@ -1,299 +0,0 @@ - subroutine transit(el,en,h,hm) - use lieaparam, only : monoms - include 'impli.inc' - double precision hm(6,6),h(monoms) - write(6,*)'inside transit; el,en=',el,en -c - call clear(h,hm) -c -c matrix: - do k=1,6 - hm(k,k)=+1.0d0 - enddo - hm(1,2)=el/en - hm(3,4)=el/en -c f4: - h(140)=-0.125d0*el/en**3 - h(149)=-2.d0*0.125d0*el/en**3 - h(195)=-0.125d0*el/en**3 -c f6: - h(714)=-0.0625d0*el/en**5 - h(723)=-3.d0*0.0625d0*el/en**5 - h(769)=-3.d0*0.0625d0*el/en**5 - h(896)=-0.0625d0*el/en**5 - return - end -c -c -c - subroutine interface(enm,enp,b2,b4,b6,h,hm) - use lieaparam, only : monoms -ccccc include 'impli.inc' - implicit none - integer k - double precision enm,enp,b2,b4,b6 - double precision endiff,term1,term2,term3,term4,term5 - double precision term6,term7,term8,term9 - double precision hm(6,6),h(monoms) - write(6,*)'inside interface; enm,enp=',enm,enp - write(6,*)'b2,b4,b6=',b2,b4,b6 -c - endiff=enm-enp - call clear(h,hm) -c -c matrix: - do k=1,6 - hm(k,k)=+1.0d0 - enddo - hm(2,1)=2.d0*b2*endiff - hm(4,3)=2.d0*b2*endiff -c f4: - term1=-endiff/enm*(enm*(2.d0*b2**3-b4) - 2.d0*b2**3*enp) - term2=2.d0*b2**2*endiff/enm - term3=0.5d0*b2*endiff/(enm*enp) -c (q^2)^2 - h(84)=term1 - h(95)=2.d0*term1 - h(175)=term1 -c (q^2)p.q - h(85)=term2 - h(96)=term2 - h(110)=term2 - h(176)=term2 -c (q^2)(p^2) - h(90)=term3 - h(99)=term3 - h(145)=term3 - h(179)=term3 -c f6: - term4=(1.d0/enm**3)*( (b6-6.d0*b2**2*b4+2.d0*b2**5)*enm**4 & - & + (-b6+12.d0*b2**2*b4-4.d0*b2**5)*enm**3*enp & - & -6.d0*b2**2*b4*enm**2*enp**2+4.d0*b2**5*enm*enp**3 & - & -2.d0*b2**5*enp**4 ) - term5=(1.d0/(enm**3*enp))*( & - &(2.d0*b2*b4-4.d0*b2**4)*enm**4+(2.d0*b2*b4+6.d0*b2**4)*enm**3*enp & - &-(4.d0*b2*b4+4.d0*b2**4)*enm**2*enp**2 & - &+6.d0*b2**4*enm*enp**3-4.d0*b2**4*enp**4 ) - term6=0.5d0/(enm**3*enp)*( & - &b4*enm**3-b4*enm**2*enp+2.d0*b2**3*enm*enp**2-2.d0*b2**3*enp**3) - term9=2.d0*b2**3/(enm**3*enp)* & - &(enm**3-enm**2*enp+enm*enp**2-enp**3) - term7=0.5d0*b2**2/(enm**3*enp**2)* & - &(enm**3+enm*enp**2-2.d0*enp**3) - term8=0.125d0*b2/(enm**3*enp**3)*(enm**3-enp**3) -c f6: -c (q^2)^3 - h(462)=term4 - h(473)=3.d0*term4 - h(553)=3.d0*term4 - h(840)=term4 -c (q^2)^2 q.p - h(463)=term5 - h(474)=term5 - h(488)=2.d0*term5 - h(554)=2.d0*term5 - h(623)=term5 - h(841)=term5 -c (q^2)^2 p^2 - h(468)=term6 - h(477)=term6 - h(523)=2.d0*term6 - h(557)=2.d0*term6 - h(749)=term6 - h(844)=term6 -c q^2 p^2 q.p - h(483)=term7 - h(492)=term7 - h(524)=term7 - h(563)=term7 - h(593)=term7 - h(750)=term7 - h(627)=term7 - h(850)=term7 -c q^2 (p^2)^2 - h(518)=term8 - h(527)=2.d0*term8 - h(573)=term8 - h(719)=term8 - h(753)=2.d0*term8 - h(860)=term8 -c q^2 (p.q)^2 - h(468)=h(468)+term9 - h(489)=2.d0*term9 - h(523)=h(523)+term9 - h(557)=h(557)+term9 - h(624)=2.d0*term9 - h(844)=h(844)+term9 - return - end -c -c -c - subroutine rootmap(en,b2,b4,b6,h,hm) - use lieaparam, only : monoms - include 'impli.inc' - double precision hm(6,6),h(monoms) -c - call clear(h,hm) -c -c matrix: - do k=1,6 - hm(k,k)=+1.0d0 - enddo - hm(2,1)=2.d0*b2*en - hm(4,3)=2.d0*b2*en -c f4: - term1=en*(b4-2.d0*b2**3) - term2=2.d0*b2**2 - term3=-0.5d0*b2/en -c (q^2)^2 - h(84)=term1 - h(95)=2.d0*term1 - h(175)=term1 -c (q^2)p.q - h(85)=term2 - h(96)=term2 - h(110)=term2 - h(176)=term2 -c (q^2)(p^2) - h(90)=term3 - h(99)=term3 - h(145)=term3 - h(179)=term3 -c f6: - term4=en*(b6-6.d0*b2**2*b4+2.d0*b2**5) - term5=4.d0*b2*b4-2.d0*b2**4 - term6=-0.5d0*b4/en - term7=0.5d0*b2**2/en**2 - term8=-0.125d0*b2/en**3 -c (q^2)^3 - h(462)=term4 - h(473)=3.d0*term4 - h(553)=3.d0*term4 - h(840)=term4 -c (q^2)^2 q.p - h(463)=term5 - h(474)=term5 - h(488)=2.d0*term5 - h(554)=2.d0*term5 - h(623)=term5 - h(841)=term5 -c (q^2)^2 p^2 - h(468)=term6 - h(477)=term6 - h(523)=2.d0*term6 - h(557)=2.d0*term6 - h(749)=term6 - h(844)=term6 -c q^2 p^2 q.p - h(483)=term7 - h(492)=term7 - h(524)=term7 - h(563)=term7 - h(593)=term7 - h(750)=term7 - h(627)=term7 - h(850)=term7 -c q^2 (p^2)^2 - h(518)=term8 - h(527)=2.d0*term8 - h(573)=term8 - h(719)=term8 - h(753)=2.d0*term8 - h(860)=term8 - return - end -c - subroutine optirot(angdeg,ijkind,h,mh) -c -c High order PROT routine. -c Actual code generated by Johannes van Zeijts using -c REDUCE. -c -cryne use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'pie.inc' -c include 'param.inc' -c include 'parm.inc' - double precision l,h(monoms),mh(6,6) -c - dimension j(6) -c - DOUBLE PRECISION B - DOUBLE PRECISION CO - DOUBLE PRECISION Si -c -cryne mods to allow for leading/trailing option: -cryne ijkind=1 for normal-to-rotated, =2 for rotated-to-normal - phideg=angdeg - if(ijkind.eq.2)phideg=-angdeg - -c - call clear(h,mh) -c -cryne B = beta - B = 1.0d0 - phi = phideg*pi180 - SI = SIN(phi) - CO = COS(phi) -c - mh(1,1)=1.0d0/CO - mh(2,2)=CO - mh(2,6)=(-SI)/B - mh(3,3)=1.0d0 - mh(4,4)=1.0d0 - mh(5,1)=SI/(B*CO) - mh(5,5)=1.0d0 - mh(6,6)=1.0d0 -c - h(34) =(-SI)/(2.0d0*CO) - h(43) =(-SI)/(2.0d0*CO) - h(48) =(SI*(B**2-1))/(2.0d0*B**2*CO) - h(105) =SI**2/(4.0d0*(SI**2-1)) - h(109) =(-SI)/(2.0d0*B*CO) - h(114) =SI**2/(4.0d0*(SI**2-1)) - h(119) =(SI**2*(-B**2+1))/(4.0d0*B**2*(SI**2-1)) - h(132) =(-SI)/(2.0d0*B*CO) - h(139) =(SI*(B**2-1))/(2.0d0*B**3*CO) - h(266) =SI/(8.0d0*CO*(SI**2-1)) - h(270) =SI**2/(2.0d0*B*(SI**2-1)) - h(275) =(SI*(-2.0d0*SI**2+3))/(12.0d0*CO*(SI**2-1)) - h(280) =(SI*(2.0d0*B**2*SI**2-3.0d0*B**2-8.0d0*SI**2+9))/( - & 12.0d0*B**2*CO*(SI**2-1)) - h(293) =SI**2/(2.0d0*B*(SI**2-1)) - h(300) =(SI**2*(-B**2+1))/(2.0d0*B**3*(SI**2-1)) - h(321) =(SI*(-4.0d0*SI**2+3))/(24.0d0*CO*(SI**2-1)) - h(326) =(SI*(4.0d0*B**2*SI**2-3.0d0*B**2-10.0d0*SI**2+9))/( - & 12.0d0*B**2*CO*(SI**2-1)) - h(335) =(SI*(-4.0d0*B**4*SI**2+3.0d0*B**4+20.0d0*B**2*SI**2- - & 18.0d0*B**2-16.0d0*SI**2+15))/(24.0d0*B**4*CO*(SI**2-1)) - h(588) =(SI**2*(SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+1)) - h(592) =(SI*(SI**2+6))/(16.0d0*B*CO*(SI**2-1)) - h(597) =(SI**2*(3.0d0*SI**2-4))/(16.0d0*(SI**4-2.0d0*SI**2+ - & 1)) - h(602) =(SI**2*(-3.0d0*B**2*SI**2+4.0d0*B**2+15.0d0*SI**2-16.0d0 - & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) - h(615) =(3.0d0*SI*(-SI**2+2))/(8.0d0*B*CO*(SI**2-1)) - h(622) =(SI*(3.0d0*B**2*SI**2-6.0d0*B**2-7.0d0*SI**2+10))/( - & 8.0d0*B**3*CO*(SI**2-1)) - h(643) =(SI**2*(5.0d0*SI**2-4))/(32.0d0*(SI**4-2.0d0*SI**2+ - & 1)) - h(648) =(SI**2*(-5.0d0*B**2*SI**2+4.0d0*B**2+17.0d0*SI**2-16.0d0 - & ))/(16.0d0*B**2*(SI**4-2.0d0*SI**2+1)) - h(657) =(SI**2*(5.0d0*B**4*SI**2-4.0d0*B**4-34.0d0*B**2*SI**2 - & +32.0d0*B**2+29.0d0*SI**2-28))/(32.0d0*B**4*(SI**4-2.0d0*SI**2+ - & 1)) - h(695) =(SI*(-7.0d0*SI**2+6))/(16.0d0*B*CO*(SI**2-1)) - h(702) =(SI*(7.0d0*B**2*SI**2-6.0d0*B**2-11.0d0*SI**2+10))/( - & 8.0d0*B**3*CO*(SI**2-1)) - h(713) =(SI*(-7.0d0*B**4*SI**2+6.0d0*B**4+22.0d0*B**2*SI**2- - & 20.0d0*B**2-15.0d0*SI**2+14))/(16.0d0*B**5*CO*(SI**2-1)) -c - call revf(1,h,mh) -c -cryne this line added Aug 6, 2003: - if(ijkind.eq.2)call inv(h,mh) - return - end -c diff --git a/OpticsJan2020/MLI_light_optics/Src/parallel_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/parallel_mod.f90 deleted file mode 100755 index 43ec432..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/parallel_mod.f90 +++ /dev/null @@ -1,57 +0,0 @@ -module parallel - include 'mpif.h' -! # of processors, processor id - integer ,save :: nvp=1,idproc=0 -! current communicator, MPI datatypes - integer ,save :: lworld,mreal,mcplx,m2real,mntgr -! MPI operators - integer ,save :: mpisum, mpimax, mpimaxloc -! the MPI implementation may require more than one error code - integer ,save ,dimension(MPI_STATUS_SIZE) :: mpistat - - -!cryne Jan 3, 2005 -! The include file "mpi_stubs.inc" contains the mpi stub -! interface files and the mpi stubs themselves. They are -! separated by a line with the word "contains" -! If the code is being run on a parallel machine (so the -! stubs are not needed) then this include file should -! simply consist of a single line with the word "contains" -! (not in quotes, obviously) - include 'mpi_stubs.inc' - - subroutine init_parallel - logical flag - - call MPI_INITIALIZED(flag,mpistat) - if(.not.flag)then - call MPI_INIT(mpistat) - endif - lworld=MPI_COMM_WORLD -! how many processors? - call MPI_COMM_SIZE(lworld,nvp,mpistat) -! get processor id - call MPI_COMM_RANK(lworld,idproc,mpistat) -! in the future, these can be set differently for other precision: - mreal=MPI_DOUBLE_PRECISION - mcplx=MPI_DOUBLE_COMPLEX - m2real=MPI_2DOUBLE_PRECISION - mntgr=MPI_INTEGER -! mntgr=MPI_2INTEGER - mpisum=MPI_SUM - mpimax=MPI_MAX - mpimaxloc=MPI_MAXLOC - end subroutine init_parallel -! - subroutine end_parallel - include 'mpif.h' - logical flag - - call MPI_INITIALIZED(flag,mpistat) - if(flag)then - call MPI_BARRIER(lworld,mpistat) - call MPI_FINALIZE(mpistat) - endif - end subroutine end_parallel - -end module parallel diff --git a/OpticsJan2020/MLI_light_optics/Src/parameters.f90 b/OpticsJan2020/MLI_light_optics/Src/parameters.f90 deleted file mode 100644 index 58bed9f..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/parameters.f90 +++ /dev/null @@ -1,10 +0,0 @@ -MODULE parameters - !--------- -------- --------- --------- --------- --------- --------- --------- ----- - ! Specify data types - !--------- -------- --------- --------- --------- --------- --------- --------- ----- - IMPLICIT NONE - INTEGER, PARAMETER :: rn = KIND(0.0d0) ! Precision of real numbers - INTEGER, PARAMETER :: is = SELECTED_INT_KIND(4) ! Data type of bytecode -END MODULE parameters - - diff --git a/OpticsJan2020/MLI_light_optics/Src/proc.f b/OpticsJan2020/MLI_light_optics/Src/proc.f deleted file mode 100755 index 45fc597..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/proc.f +++ /dev/null @@ -1,3328 +0,0 @@ -c Newest version of proc w/ block data initialization. Berkeley 5/02 -c New version of proc using amdii in fit D-Day June 6 1994 -c - block data prokey - use lieaparam, only : monoms - include 'keyset.inc' -c keyset initialized here. rdr and ctm 5/26/02 - data maxj/2*6,2*monoms,3*6,monoms,250,5,3,6,4/ - data key/'sm','bm', - &'sf','bf', & - &'r(','s(','z(', & - &'f(', & - &'u(', & - &'um', & - &'ls', & - &'rt', & - &'dz', & - &'tx','ty','ts','cx','cy','qx','qy','hh','vv','tt','hv','ht', & - &'vt','ax','bx','gx','ay','by','gy','at','bt','gt','ex','ey','et', & - &'wx','wy','wt','fx','xb','xa','xu','xd','fy','yb','ya','yu','yd', & - &'ft','tb','ta','tu','td','ar'/ - data kask/2*4,5*3,6*2,44*1/ - end -c------------------------------------------- - subroutine aim(pp) -c -c aim allows user selection of map elements to fit -c C. T. Mottershead /AT-6 & L. B. Schweitzer /UCB Dec 86 -c New character controled version July 87 & July 88 -c -c----------------------------------------------------------------------- - use lieaparam, only : monoms - include 'impli.inc' - include 'labpnt.inc' - include 'files.inc' - include 'aimdef.inc' - include 'keyset.inc' - include 'fitbuf.inc' - include 'map.inc' -c - dimension pp(6) - character*1 yn - character*8 word - character*128 card - logical rewind - dimension bufr(4) -c-----!----------------------------------------------------------------! -c write(6,*)'************HERE I AM IN AIM************' - if(jicnt.ne.0) return - keyrms = 11 - ier = 0 - iaim = nint(pp(1)) - infile=nint(pp(2)) - rewind = .true. - if(infile.eq.0) infile = jif - if(infile.eq.jif) rewind = .false. - if(infile.lt.0) then - infile = -infile - rewind = .false. - endif - if(rewind) rewind(infile) - logf = nint(pp(3)) - iquiet = nint(pp(4)) - loon = nint(pp(5)) - if((loon.lt.1).or.(loon.gt.3)) loon = 1 - ksq(loon) = iaim - do 3 j=1,3 - lsq(j,loon) = 0 - 3 continue - isend = nint(pp(6)) - 5 nf = 0 - do 10 j=1,maxf - wts(j,loon) = 1.d0 - 10 continue - go to 45 -c -c help section -c - 20 if(infile.eq.jif) then - write(jof,*) ' ' - write(jof,*) ' Symbols are defined for the following categories:' -c write(jof,*) ' (Enter the catagory number to get help)' - write(jof,*) - &' 1. The current map, the reference trajectory around which the', - &' map has' - write(jof,*) - &' been computed, the arc length, various stored maps, and', - &' maps in buffers.' - write(jof,*) ' 2. Standard quantities derived from the current ma - &p, including tunes,' - write(jof,*) ' chromaticities, anharmonicities, dispersions, a - &nd twiss parameters.' - write(jof,*) ' 3. Beam parameters.' - write(jof,*) ' 4. User calculated quantities.' - write(jof,*) ' -----Select help catagory-----' - ihelp=0 - card = ' ' - read(infile,17,end=45) card - if(card.eq.' ') go to 45 - call txtnum(card,20,1,ng,bufr) - if(ng.gt.0) ihelp = bufr(1) - if((ihelp.gt.0).and.(ihelp.le.4)) go to (25,30,35,40), ihelp - go to 45 - 25 continue - write(jof,*) ' *** Quantities in Map Format ***' - write(jof,*) ' ' - write(jof,*) ' The current transfer map:' - write(jof,*) ' r(i,j) = first order (linear) matrix elements i - &,j=1,6.' - write(jof,*) ' f(i) = Lie polynomial coefficients, i=1,209.' - write(jof,*) ' ' - write(jof,*) - write(jof,*) ' The reference trajectory:' - write(jof,*) - &' rt1,rt2,rt3,rt4,rt5,rt6 = x,px,y,py,t,pt on the reference ', - &'trajectory' - write(jof,*) ' ' - write(jof,*) ' The arc length:' - write(jof,*) ' al = arc length at the current location in', - &' the lattice' - write(jof,*) ' ' - write(jof,*) ' Stored maps in locations 1 through 5:' - write(jof,*) ' sm1(i,j) ... sm5(i,j) = first order (linear) ma - &trix elements i,j=1,6.' - write(jof,*) ' sf1(i) ... sf5(i) = Lie polynomial coefficients - &, i=1,209.' - write(jof,*) ' ' - write(jof,*) ' Result arrays in buffers 1 through 5:' - write(jof,*) ' bm1(i,j) ... bm5(i,j) = first order (linear) ma - &trix elements i,j=1,6.' - write(jof,*) ' bf1(i) ... bf5(i) = Lie polynomial coefficients - &, i=1,209.' - go to 45 - 30 continue - write(jof,*) ' *** Standard quantities computed by COD, TASM - &, and TADM ***' - write(jof,*) ' ' - write(jof,*) ' Tunes:' - write(jof,*) ' tx, ty = horizontal and vertical tunes.' - write(jof,*) ' ts = synchrotron (temporal) tune for a dynam - &ic map,' - write(jof,*) ' or temporal dispersion (eta) for a stat - &ic map.' - write(jof,*) ' ' - write(jof,*) ' Chromaticities:' - write(jof,*) ' cx, cy = horizontal and vertical 1st order chrom - &aticities.' - write(jof,*) ' qx, qy = horizontal and vertical 2nd order (quad - &ratic) chromaticities.' - write(jof,*) ' ' - write(jof,*) ' Anharmonicities:' - write(jof,*) ' hh, vv, tt, hv, ht, vt = second order anharmonic - &ities.' - write(jof,*) ' ' - write(jof,*) ' Dispersions:' - write(jof,*) ' dz1, dz2, dz3, dz4 = first order dispersions for - & the' - write(jof,*) ' transverse phase space coor - &dinates.' - write(jof,*) ' ' - write(jof,*) ' Twiss parameters (zeroth order):' - write(jof,*) ' ax,bx,gx = horizontal alpha, beta, gamma.' - write(jof,*) ' ay,by,gy = vertical alpha, beta, gamma.' - write(jof,*) ' at,bt,gt = temporal alpha, beta, gamma.' - go to 45 - 35 continue - write(jof,*) ' *** Beam Parameters ***' - write(jof,*) ' ' - write(jof,*) ' Particle coordinates from tracking:' -c-----!----------------------------------------------------------------! - write(jof,*) ' z(i,j) = jth component of ith particle in', - & ' tracking buffer.' - write(jof,*) ' ' - write(jof,*) ' Moments (from AMAP):' - write(jof,*) ' s(i,j) = 2nd moments of the beam .' -c-----!----------------------------------------------------------------! - write(jof,*) ' bf1(i) = moments of the beam in standard Lie mon - &omial sequence.' - write(jof,*) ' ' - write(jof,*) ' Emittances (from AMAP):' - write(jof,*) ' ex,ey,et = rms emittances for the x, y, and t pl - &anes.' - write(jof,*) ' wx,wy,wt = eigen emittances for coupled systems. - &' - go to 45 - 40 continue -c-----!----------------------------------------------------------------! - write(jof,*) ' *** User defined quantities computed by USER', - & ' and MERIT routines ***' - write(jof,*) ' ' - write(jof,*) ' u(i) = ucalc(i) for i=1 to 250, stored in common - &/usrdat/' - write(jof,*) ' ' - write(jof,*) ' umi = val(i) for i=1 to 5, computed by user ', - & 'merit functions',' MRT1 through MRT5 and stored in', - & ' common/merit/' - endif -c -c prompt for and read input line -c - 45 if(infile.eq.jif) then - write(jof,*) ' ' - if(iaim.eq.1) write(jof,*) ' Select quantities by entering their s - &ymbols' - if(iaim.eq.2) write(jof,*) ' Enter aim(s) in the form: symbol = t - &arget value' - if(iaim.eq.3) write(jof,*) ' Enter aim(s) in the form: symbol = t - &arget value, weight' - write(jof,*) ' (Enter a # sign when finished, or type help to revi - &ew the defined symbols)' - endif - 50 card = ' ' - 15 read(infile,17,end=200) card(2: ) - 17 format(a) - if(card.eq.' ') go to 50 - call low(card) - ifin = index(card,'#') -c -c scan input line for keywords and numeric values -c - do 150 ku=1,nkeys - nask = kask(ku) - nget = 0 - ntgt = nask - if(iaim.eq.1) nask = nask-1 - if(iaim.eq.3) nask = nask+1 - ju = ku -cryne 20 March 2006 if(ju.gt.12) ju = 12 - if(ju.gt.maxjlen) ju = maxjlen - jmax = maxj(ju) - 60 call keynum(card,key(ku),nask,nget,nloc,bufr) - if(nloc.eq.0) go to 150 -c -c found key(ku) ; check and interpret input -c write(6,*)'FOUND IT: ku, key(ku)=',ku,key(ku) -c - if(nget.ne.nask) go to 60 -c -c scalar variables -c - idu = 0 - jdu = 0 - nsu = 0 -cryne 20 March 2006 if(ku.ge.13) go to 72 - if(ku.ge.(maxjlen+1))then -c write(6,*)'going to 72 with ku=',ku - go to 72 - endif -c write(6,*)'did not go to 72; ku=',ku -c -c stored maps -c - nj = 1 - if(ku.le.4) then - nsu = bufr(1) - nj = 2 - endif - idu = bufr(nj) -c write(6,*)'idu=',idu - imax = jmax - if (ku.eq.7) imax = 999 - if((idu.lt.1).or.(idu.gt.imax)) go to 60 -cryne 20 March 2006 if(jmax.eq.6) then - if(jmax.eq.6 .and. ku.le.7) then - jdu = bufr(nj+1) - if((jdu.lt.1).or.(jdu.gt.jmax)) go to 60 - endif -c -c accept and report the entry -c - 72 if(nf.ge.maxa) then - write(jof,*) maxa,' = maximum aims allowed' - write(jodf,*) maxa,' = maximum aims allowed' - go to 200 - endif -c -c trap and flag rmserr requests -c - if(ku.eq.keyrms) then - lsq(idu,loon) = 1 - write(jof,74) idu - 74 format(' RMS',i1,' enabled') - go to 60 - endif - nf=nf+1 - if(iaim.gt.1) target(nf,loon) = bufr(ntgt) - if(iaim.eq.3) wts(nf,loon) = bufr(nget) - kyf(nf,loon) = ku - nsf(nf,loon) = nsu - idf(nf,loon) = idu - jdf(nf,loon) = jdu -c -c echo accepted aim and see if there are any more -c -cryne 20 March 2006 if(ku.gt.12) then - if(ku.gt.maxjlen) then -c write(6,*)'echoing accepted aim; ku, key(ku)=',ku,key(ku) - write(word,42) key(ku) - 42 format(6x,a2) - go to 100 - endif -c write(6,*)'BEFORE GOTO statement with ku=',ku -cryne 20 March 2006 go to (75,75,80,80,85,85,88,90,90,95,95,95), ku - go to (75,75,80,80,85,85,88,90,90,95,95,95,95), ku - 75 write(word,76) key(ku), nsu, idu, jdu - 76 format(a2,i1,'(',i1,',',i1,')') - go to 100 - 80 write(word,81) key(ku), nsu, idu - 81 format(a2,i1,'(',i3,')') - go to 100 - 85 write(word,86) key(ku), idu, jdu - 86 format(2x,a2,i1,',',i1,')') - go to 100 - 88 write(word,89) key(ku), idu, jdu - 89 format(a2,i3,',',i1,')') - go to 100 - 90 write(word,91) key(ku), idu - 91 format(2x,a2,i3,')') - go to 100 - 95 write(word,96) key(ku), idu - 96 format(5x,a2,i1) - 100 write(jof,101) nf, word -cccccccccccc target(nf,loon) - 101 format(' accept',i3,': ',a) -ccccccccccccc ,' = ',1pg22.14) - qname(nf,loon) = word - go to 60 - 150 continue -c -c check for pleas for help -c - if(index(card,'help').ne.0) go to 20 - if(index(card,'HELP').ne.0) go to 20 - if(ifin.eq.0) go to 50 -c -c End of input, echo variables and target values -c - 200 continue - nsq(loon) = nf - if((isend.eq.1).or.(isend.eq.3)) call wrtaim(jof,iaim,loon) - if((isend.eq.2).or.(isend.eq.3)) call wrtaim(jodf,iaim,loon) -c - if(infile.eq.jif) then - write(jof,*) ' ' - write(jof,*) ' Do you wish to start over? (y/n) :' - yn='n' - read(jif,177) yn - 177 format(a) - if ((yn .eq.'y').or.(yn .eq.'Y')) go to 5 - endif -c -c write log file if requested -c - if(logf.gt.0) then - call wrtaim(logf,4,loon) - write(logf,*) ' #' - endif - return - end -c -ccccccccccccccccccccccccccccc AMDII ccccccccccccccccccccccccc -c - subroutine amdii(iter,nv,fv,xv,ef,em,step,info) -c -c Adaptive MultiDimensional Inverse Interpolation algorithm for -c solving simultaneous non-linear equations. -c -c C. T. Mottershead LANL AT-3 Jan 93 -c email: motters@atdiv.lanl.gov, phone (505) 667-9730 -c -c Parameters: -c iter = external iteration counter -c for iter = 0, initialize routine by passing in: -c fv(i) = target(i), i=1,nv -c em = errtol = quitting tolerance for Max(fv(i)-target(i)) on -c normal running calls with iter>nv -c step = delta = feeler step size for first nv iterations. -c info = maxcut = maximum allowed cuts in the reach from initial -c point to final target. Reach is defined as the fraction -c of the distance between the best point found so far and -c the ultimate target. Full reach = 1.0, in which case we -c try to step xv(i) to fit fv(i) = target(i). If this fail -c and maxcut>0, we cut the reach in half. Thus maxcut=N -c means attempts as short as 2**-N of the original distanc -c are allowed. If the iteration succeeds twice with a reac -c less than 1.0, the reach is doubled (but never exceeds 1 -c iter > 0: normal running. ic = internal iteration counter. Norma -c self incrementing on each call, but may be set back to 0 -c cause new orthogonal feeler steps if the matrix becomes -c degenerate. -c On call: -c nv = number of variables (= dimension of fit, maximum of 40) -c fv(i), i=1,nv = computed or measured function values -c at the current point xv(i), i=1,nv. -c On return: -c xv(i), i=1,nv = recommended new value for the independent -c variables. The function values fv(i), i=1,nv at this new -c point should be acquired and passed in on the next iteratio -c em = Max(fv(i)-target(i)) = error measure of new incoming point. -c Used internally for branching and quitting decisions. -c step = length of step = cartesian distance between incoming old -c xv(i) and returned new xv(i), i=1,nv -c info = control flag. Quit if info > 0. -c = -N for normal return with reach cut by 2**N. Keep going. -c = 0 for normal return at full reach toward final target. -c Keep going. -c = 1 Converged: Quit because new point is below error -c tolerance: em maxv =',maxv - info = 6 - return - endif -c -c initialization: store targets and flags for iter = 0 -c - if(iter.le.0) then - do 5 i = 1,nv - fultgt(i) = fv(i) - partgt(i) = fv(i) - 5 continue - ncut = 0 - ic = 0 - level = 0 - reach = 1.d0 - detol = 1.0d-9 - errtol = ef - auxtol = em - antmin = 1.0d-6 -c antol = 1.e4*errtol - antol = auxtol - if(antol.le.0.0d0) antol = antmin - delta = step - stpmin = 0.01d0*delta - slo = 0.0d0 - maxcut = info -c undocumented function limits test - ymax = 1.0d+38 - ymin = -ymax - if(info.lt.0) then - maxcut = -info - ymax = xv(1) - ymin = xv(2) - endif - return - endif -c -c running for iter>0 -c - info = -ncut - last = nv+1 - ic = ic + 1 -c -c compute error measure of new point and test for convergence -c - em = difmax(nv,fv,partgt) - ef = difmax(nv,fv,fultgt) - if(ef.le.errtol) then - info = 1 - step = 0.0d0 - return - endif -c -c save new xv,fv and em and increment xv on first nv calls: -c - 10 continue - if(ic.le.nv) then - do 20 i = 1,nv - ff(i,ic) = fv(i) - xx(i,ic) = xv(i) - 20 continue - err(ic) = em - do 30 i = 1,nv - xv(i) = xx(i,1) - 30 continue - step = delta*xv(ic) - if(abs(step).lt.stpmin) step=stpmin - xv(ic) = xv(ic) + step - return - endif -c -c at ic = nv+1, we have just enough to take a MDII step, so save -c the incoming point and do it: -c - if(ic.eq.last) then - isav = last - go to 100 - endif -c -c converged enough to extend reach for next MDII step -c - if((ncut.gt.0).and.(em.lt.antol)) then - iwin = 1-iwin - if(iwin.eq.0) ncut = ncut - 1 - call mdicut(nv) - level = -1 - call mdipik(nv,ibest,iworst,best,worst) - antol = best*antmin - if(antol.lt.antmin) antol = antmin - em = difmax(nv,fv,partgt) - write(6,*) ' New em =',em,' antol=',antol - info = -ncut - go to 60 - endif -c---------------------------------------------------------------- -c When ic > nv+1, search for best and worst previous points: -c - call mdipik(nv,ibest,iworst,best,worst) - antol = best*antmin - if(antol.lt.antmin) antol = antmin -c -c return to best case and quit if error fails to decrease at full -c reach while below antol -c - if((ncut.eq.0).and.(em.ge.best).and.(em.lt.antol)) then - info = 2 - do 40 i = 1,nv - xv(i) = xx(i,ibest) - fv(i) = ff(i,ibest) - 40 continue - em = difmax(nv,fv,partgt) - ef = difmax(nv,fv,fultgt) - return - endif -c -c New point is the worst yet. Cut reach if allowed, otherwise restore -c best available point and quit: -c - if(em.ge.worst) then - if(ncut.lt.maxcut) then - ncut = ncut + 1 - call mdicut(nv) - level = 1 - call mdipik(nv,ibest,iworst,best,worst) - antol = best*antmin - if(antol.lt.antmin) antol = antmin - em = difmax(nv,fv,partgt) - write(6,*) ' New em =',em,' antol=',antol - info = -ncut - go to 60 - else - info = 4 - do 50 i = 1,nv - xv(i) = xx(i,ibest) - 50 continue - return - endif - endif -c-------------------------------------------------------------------- -c -c arrange data pool for MDII step -c - 60 continue - isav = 0 - if(em.lt.best) isav = last - if((em.ge.best).and.(em.lt.worst)) isav = iworst -c -c Overwrite the previous worst case with the last one, in preparatio -c saving the new one in last place. -c - if(isav.eq.last) then - do 70 i = 1,nv - ff(i,iworst) = ff(i,last) - xx(i,iworst) = xx(i,last) - 70 continue - err(iworst) = err(last) - endif -c -c if best is not last, swap it there -c - if((isav.ne.last).and.(ibest.ne.last)) then - write(6,*) ' Swapping',ibest,'=ibest for last' - do 90 i=1,nv - temp = ff(i,last) - ff(i,last) = ff(i,ibest) - ff(i,ibest) = temp - temp = xx(i,last) - xx(i,last) = xx(i,ibest) - xx(i,ibest) = temp - 90 continue - temp = err(last) - err(last) = err(ibest) - err(ibest) = temp - endif -c -c save new xv,fv and em in column isav of xx,ff, and err arrays -c - 100 continue - if(isav.gt.0) then - do 120 i = 1,nv - ff(i,isav) = fv(i) - xx(i,isav) = xv(i) - 120 continue - err(isav) = em - endif -c------------------------------------------------------------------- -c compute xv using the amdii algorithm for ic > nv: -c - 200 continue -c -c compute ga matrix for linear solver, with the best rhs vector -c as the nv+1st column. -c - gav = 0.0d0 - do 230 i = 1,nv - kolum = nv*(i-1) - do 210 j = 1,nv - ga(j+kolum) = ff(j,i)-ff(j,last) - gav = gav + abs(ga(j+kolum)) - 210 continue - 230 continue -c -c check for null matrix (serious error) -c - if(gav.eq.0.d0) then - info = 5 - return - endif -c -c ok, ga matrix not 0, so normalize to make mean element = 1 -c (to prevent underflow or overflow) -c - nvsq = nv**2 - gav = gav/float(nvsq) - gfac = 1.d0/gav - do 260 i = 1,nv - kolum = nv*(i-1) - do 250 j = 1,nv - ga(j+kolum) = gfac*ga(j+kolum) - 250 continue - ga(i+nvsq) = gfac*(ff(i,last) - partgt(i)) - 260 continue -c -c Solve for correction vector yy: -c - 265 continue - call solveh(ga,nv,1,det) -cryne========== -c do j=1,nv+1 -c do i=1,nv -c k=nv*(j-1)+i -c ga2d(i,j)=ga(k) -c enddo -c enddo -c call solveh(ga2d,nv,1,det) -c -c do j=1,nv+1 -c do i=1,nv -c k=nv*(j-1)+i -c ga(k)=ga2d(i,j) -c enddo -c enddo -cryne========== -c -c redo feeler steps if determinant is bad -c -c if(abs(det).lt.detol) then -c type *, ' Restart from best point because determinant = ',det -c do 270 i = 1,nv -c xv(i) = xx(i,ibest) -c fv(i) = ff(i,ibest) -c 270 continue -c em = difmax(nv,fv,partgt) -c ef = difmax(nv,fv,fultgt) -cc delta = 2.0*delta -c ic = 1 -c go to 10 -c endif -c -c extract yy from solveh return -c - ytot = 0.d0 - do 280 j = 1,nv - yy(j) = ga(j+nvsq) - ytot = ytot + yy(j) - 280 continue -c -c Set new parameter vector for next round: -c - do 340 i = 1,nv - xbar(i) = 0.d0 - do 320 j = 1,nv - xbar(i) = xbar(i) + yy(j)*xx(i,j) - 320 continue - 340 continue -c -c add the step to xn+1 to get xv -c - step = 0.d0 - 400 do 450 i = 1,nv - yy(i) = ytot*xx(i,last) - xbar(i) - if(yy(i).gt.ymax) yy(i) = ymax - if(yy(i).lt.ymin) yy(i) = ymin - step = step + yy(i)**2 - xv(i) = xx(i,last) + yy(i) - 450 continue - step = sqrt(step) - if((step.lt.slo).and.(ncut.eq.0)) info = 3 - return - end -c************************************************************** - subroutine bip(p) -c subroutine for beginning an inner procedure -c Written by Alex Dragt on 8-8-88. - include 'impli.inc' - dimension p(6) - include 'labpnt.inc' - nitms=nint(p(1)) - jbipnt=lp -c write(6,*) 'lp=',lp - jicnt = 0 - return - end -c -************************************************************************ -c - subroutine bop(p) -c subroutine for beginning an outer procedure -c Written by Alex Dragt on 8-8-88. - include 'impli.inc' - dimension p(6) - include 'labpnt.inc' - notms=nint(p(1)) - jbopnt=lp -c write(6,*) 'lp=',lp - jocnt = 0 - return - end -c -************************************************************************ -c - subroutine chekit(loon,iter,maxit) -c -c returns current loop counter (iter), and -c maximum number of iterations (maxit) for specified loop. -c iter = current loop counter -c maxit = maximum number of iterations -c loon = loop number = 1 for inner loop -c = 2 for outer loop -c -c T. Mottershead LANL AT-3 7 Oct 91 -c---------------------------------------------------- - include 'impli.inc' - include 'files.inc' - include 'labpnt.inc' - if(loon.eq.2) then - iter = jocnt - maxit = notms - else - iter = jicnt - maxit = nitms - endif - iquiet = 1 - return - end -c -c******************************************************************** -c - subroutine cps(prms,p,ipset) -c subroutine for capturing a parameter set -c Written by Alex Dragt, 28 July 1988 -c - include 'impli.inc' - include 'parset.inc' - include 'psflag.inc' -c - dimension prms(6),p(6) -c -c test to see that ipset is in range -c - if(ipset.le.0 .or. ipset.gt.maxpst) then -c print some message - return - endif -c -c capture a parameter set and flag it -c - if(icapt(ipset).eq.0) then - do 10 i=1,6 - 10 prms(i)=pst(i,ipset) - icapt(ipset)=1 - return - endif -c -c transfer p to a captured parameter set -c - do 20 i=1,6 - 20 pst(i,ipset)=p(i) - return - end -c -*********************************************************************** -c - subroutine dapt(p) -c This subroutine finds the dynamic aperture in one dimension. -c - use rays - use lieaparam, only : monoms - include 'impli.inc' - include 'parset.inc' - include 'usrdat.inc' -c -c calling array - dimension p(6) -c -c saved quantities - save ient, gut, bad -c -c set up control parameters - ipset = nint(p(2)) - prec=p(3) - gutic=0.d0 - badic=1.d5 -c -c see if this is initial entry into this subroutine - if(ient .eq. 0) then - gut=gutic - bad=badic - ient=1 - endif -c -c examine result of tracking, and proceed accordingly -c -c procedure if particle not lost - if(nlost .eq. 0) then - gut=pst(1,ipset) -c - if(bad .eq. badic) then - pst(1,ipset)=2.d0*gut - endif -c - if(bad .ne. badic) then - pst(1,ipset)=gut+(bad-gut)/2.d0 - endif -c - acc=(bad-gut)/bad - write(6,*) gut, pst(1,ipset), bad, acc - return - endif -c -c procedure if particle lost - if(nlost .ne. 0) then - bad=pst(1,ipset) -c - if(gut .eq. gutic) then - pst(1,ipset)=bad/2.d0 - endif -c - if(gut .ne. gutic) then - pst(1,ipset)=gut+(bad-gut)/2.d0 - endif -c - acc=(bad-gut)/bad - write(6,*) gut, pst(1,ipset), bad, acc - endif -c - return - end -c -********************************************************************** -c - double precision function difmax(n,aa,bb) - implicit double precision (a-h,o-z) - dimension aa(*), bb(*) -c -c evaluate error of incoming functions -c - difmax = 0.0d0 - do 18 i=1,n - del = abs(aa(i)-bb(i)) - difmax = dmax1(del,difmax) - 18 continue - return - end -c**************************************************************** - subroutine fit(pp) -c -c----------------------------------------------------------------------- - use acceldata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' -cryne 21 March 2006 include 'status.inc' -cryne include 'index.inc' !is now in acceldata, but what is this needed for??? -c include 'fitbuf.inc' - include 'aimdef.inc' -c - dimension pp(6) -c - character*50 quit(6) - parameter (maxf=100) - dimension xv(maxf), aims(maxf), lout(2) -!dbs -- this is redundant since the next statement saves everything -!dbs -- and the Intel compiler objects to it -!dbs save kut, info, em, ef, step - save -c -c reason for quiting messsages -c - quit(1) = 'Converged: error < tolerance' - quit(2) = 'Best effort: Hit bottom at full reach' - quit(3) = 'step size below limit' - quit(4) = '**FAILURE: error increase at full cut' - quit(5) = '**NULL MATRIX: Nothing is Happening!!! **' - quit(6) = '**AMDII OVERFLOW: Too many variables **' -c -c check and reset error flag from eig4 or eig6 to ok value -cryne 21 March 2006 if (imbad .ne. 0) imbad=0 -c -c check iteration counter for specified loop -c - loon =1 - nfit = nint(pp(1)) - if(nfit.lt.0) then - nfit = -nfit - loon = 2 - endif - call chekit(loon,jiter,maxit) - if(jiter.eq.0) then -c -c pick up parameters only on first pass (jiter=0) -c - auxtol = pp(2) - errtol = pp(3) - delta = pp(4) - mode = nint(pp(5)) - nrpt = 0 - if(mode.lt.0) nrpt = -mode -c type *, mode,'=MODE',nrpt,'=NRPT' - isend = nint(pp(6)) -c -c check for x damping -c - relax = 0.5d0 - nrep = 0 - if(nfit.lt.0) then - nrep = -nfit - if(auxtol.ne.0.d0) relax = auxtol - endif - ibsave = ibrief - ibrief = -7 - kfit = 0 ! one more time flag -c -c load fixed data into amdii -c - nf = nsq(loon) - do 20 j=1,nf - aims(j) = target(j,loon) - write(6,*) ' target',j,' =',aims(j) - 20 continue -cryne? nfit=0 - call amdii(jiter,nf,aims,xv,errtol,auxtol,delta,nfit) - endif -c -c set up output levels and routing -c - lout(1) = jof - lout(2) = jodf - ja = 1 - if(iabs(isend).eq.2) ja = 2 - jb = 1 - if(iabs(isend).gt.1) jb = 2 - if(isend.eq.0) ja=3 -c -c check the last go around flag to restore final values everywhere -c - if(kfit.eq.1) go to 700 -c-------------------------------------------------------------- -c Have another go at it: Collect the current x-parameter vector, -c and computed function values: -c - call getaim(loon,nf,aims) - call getvar(loon,nx,xv) - if(nx.ne.nf) then - write(jof,31) nx,nf,loon - write(jof,31) nx,nf,loon - 31 format(' **FATAL FIT ERROR:',i3,' variables with',i3, - &' aims. Abort loop',i3) - go to 1000 - endif -c -c compute the next estimate of the x-parameters, and put them -c back in the parameter buffer: -c - iter=jiter+1 -cryne?info=0 - call amdii(iter,nf,aims,xv,ef,em,step,info) - call putvar(loon,xv) -c -c check the MDII error flag. If quit, do the reset pass. -c - if(info.gt.0) then - kfit = 1 - return - endif -c -c iteration reports -c - if(ja.gt.jb) go to 100 - do 60 j = ja,jb - lun = lout(j) -c -c optional reports every nrpt iterations -c -cryne if((nrpt.gt.0).and.(mod(iter,nrpt).eq.0)) then - if(nrpt.gt.0)then - if(mod(iter,nrpt).eq.0) then - write(lun,53) (aims(k), k=1,nf) - 53 format(' AIMS: ',4(1pg18.9)) - write(lun,54) (xv(k), k=1,nx) - 54 format(' XNEW: ',4(1pg18.9)) - endif - endif - kut = 2**(-info) - write(lun,57) iter,ef,step,em,kut - 57 format(' Iter',i4,' Error=',1pe11.4,', Step=',1pe11.4, - & ', SubErr=',1pe11.4,' @cut=',i5) - write(lun,58) - 58 format(1x,55('-')) - 60 continue - 100 continue - return -c -c Converged at full reach, or failed. Display final results. -c - 700 continue - if(isend.eq.0) go to 1000 - ja = 1 - jb = 2 - do 900 j=ja,jb - lun = lout(j) - write(lun,710) iter,info,quit(info),kut - 710 format(' Quit on iteration',i4,' for reason',i2,': ',a,/ - &' Final values with reach =',i4,' are:') - call wrtaim(lun,2,loon) -c -c Display new values for parameters. -c - call wrtvar(loon,lun) -c -c Display maximum percent error. -c - write(lun,*)' ' - write(lun,840) em - 840 format(2x,'Maximum error is ',1pg13.6) - write(lun,841) errtol - 841 format(2x,'Maximum allowed was ',1pg13.6) - 900 continue - 1000 ibrief = ibsave - call stopit(loon) - return - end -c -********************************************************************** -c - subroutine fps(ipset) -c -c this subroutine frees a parameter set so that it can be recaptured -c if desired -c Written by Alex Dragt, 28 July 1988 -c - include 'impli.inc' - include 'parset.inc' - include 'psflag.inc' -c -c test to see that ipset is within range -c - if(ipset.le.0 .or. ipset.gt.maxpst) then -c write error message - return - endif -c -c free the indicated parameter set -c - icapt(ipset)=0 -c - return - end -c -************************* GETAIM ******************************** -c - subroutine getaim(loon,naim,aims) -c -c getaim returns the number of aims selected (nf,loon), and -c their current values (aims(j), j=1,nf) from aim block loon -c -c C. T. Mottershead LANL AT-3 16 Aug 90 -c modified 29 May 91 to double aim blocks, selected by loon. -c-------------------------------------------------- - include 'impli.inc' - include 'aimdef.inc' - dimension aims(*) -c - naim = nsq(loon) - do 20 nu = 1, naim - ku = kyf(nu,loon) - nsu = nsf(nu,loon) - idu = idf(nu,loon) - jdu = jdf(nu,loon) - aims(nu) = valuat(ku,nsu,idu,jdu) - 20 continue - return - end -c -c************************* GETVAR *************************** -c - subroutine getvar(loon,nx,xv) -c -c collect the current x-parameter vector -c mm(i,kvs) is the i-th marylie menu item selected in vary -c idx(i,kvs) is the index (1 to 6) of the i-th variable parameter -c T. Mottershead LANL AT-3 23 July 90 -c------------------------------------------------------- - use acceldata - include 'impli.inc' - include 'xvary.inc' - dimension xv(*) - kvs = loon - if((kvs.lt.1).or.(kvs.gt.3)) kvs = 1 - nx = nva(kvs) - do 210 i = 1,nx - mnu = mm(i,kvs) -cryne 23 March 2006: - if(mnu.eq.0)then - write(6,*)'error from getvar: mnu =0. This should not happen!' - stop - endif - xv(i) = pmenu(idx(i,kvs)+mpp(mnu)) - 210 continue - return - end -c -c*********************************** GRAD *************************** -c - subroutine grad(pp) -c----------------------------------------------------------------------- - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'aimdef.inc' - include 'xvary.inc' -c - parameter (maxg=100) - common/gradat/nx,ny,dxx,dyy,xcen(maxg),ycen(maxg) - dimension pp(6) - dimension yval(maxg), xval(maxg) - logical ltty, lfile - character*12 vname - character*8 yname(maxg) -cryne - save lun,delta,scale,ltty,lfile,yname -c -c check loop and option flag -c - loon = 1 - job = nint(pp(1)) - if(job.lt.0) then - job = -job - loon = 2 - endif - call chekit(loon,iter,maxit) -c -c initialization for iter = 0 (ic=1) -c - if(iter.eq.0) then -cryne: NOTE: isides is never used - isides = nint(pp(2)) - lun = nint(pp(3)) - delta = pp(4) - scale = pp(5) - isend = nint(pp(6)) - ltty = .false. - lfile = .false. - if((isend.eq.1).or.(isend.eq.3)) ltty = .true. - if((isend.eq.2).or.(isend.eq.3)) lfile = .true. -c -c collect the central x-parameter vector -c - call getvar(loon,nx,xcen) -c -c collect central y-values -c - ny = 0 - if((job.eq.1).or.(job.eq.3)) then - call getaim(loon,ny,ycen) - do 10 k=1,ny - yname(k) = qname(k,loon) - 10 continue - endif -c -c compute any rms errors selected in current loon -c - if(job.ge.2) then - do 15 ku = 1,3 - if(lsq(ku,loon).ne.1) go to 15 - ny = ny + 1 - ycen(ny) = rmserr(ku) - write(yname(ny),14) ku - 14 format(2x,'rms',i1,2x) - 15 continue - endif -c -c increment the first x-variable on the first call -c - do 20 i=1,nx - xval(i) = xcen(i) - 20 continue - xval(1) = xcen(1) + delta - call putvar(loon,xval) - return - endif -c -c all done, jump out of labor loop -c - if(iter.gt.nx) then - write(jif,*) ' gradient loop is finished' - call stopit(loon) - return - endif -c -c normal running: compute and save numerical gradients for iter=1,n -c - call getvar(loon,nx,xval) - ny = 0 - if((job.eq.1).or.(job.eq.3)) call getaim(loon,ny,yval) -c -c compute any rms errors selected in current loon -c - if(job.ge.2) then - do 515 ku = 1,3 - if(lsq(ku,loon).ne.1) go to 515 - ny = ny + 1 - yval(ny) = rmserr(ku) - 515 continue - endif - delx = xval(iter) - xcen(iter) - do 600 n = 1,ny - dydx = (yval(n) - ycen(n))/delx - if(dydx.eq.0.d0) go to 600 - qsq = dydx/delx - qs = 0.d0 - if(qsq.gt.0.0) qs = scale*sqrt(qsq) - vname = varnam(iter,loon) - if(ltty) write(jof,577) n,iter,dydx,qs,yname(n),vname - if(lfile) write(jodf,577) n,iter,dydx,qs,yname(n),vname - if(lun.gt.0) write(lun,577) n,iter,dydx,qs,yname(n),vname - 577 format(2i5,1pg22.14,1pg16.8,2x,a,' / ',a) - 600 continue -c -c increment parameter vector on first nx-1 calls, and restore -c central values on last call: -c - if(iter.lt.nx) then - do 520 i=1,nx - xval(i) = xcen(i) - 520 continue - xval(iter+1) = xcen(iter+1) + delta - call putvar(loon,xval) - else - call putvar(loon,xcen) - endif - return - end -c -********************************************************************** -c - subroutine keynum(text,word,nask,nget,nloc,bufr) -c -c keynum scans the character string 'text' for one -c keyword, followed by a list of associated numbers. -c -c parameters: -c text - the input character string to be searched -c word - the single keyword -c nask - maximum length of number list -c nget - actual number of numbers found -c nloc - location in text string of keyword found -c bufr - output array of real numbers -c -c T. Mottershead Los Alamos Aug 1985 -c---------------------------------------------------------- - implicit double precision (a-h,o-z) - character text *(*), word*(*) - dimension bufr(1) - max=len(text) - nch=len(word) - nloc=index(text,word) - if(nloc.eq.0) go to 40 - jj=nloc+nch-1 - text(nloc:jj)=' ' - nrem=max-nloc+1 - if(nask.gt.0) call txtnum(text(nloc: ),nrem,nask,nget,bufr) -c write(6,17) nrem,nask,nget,(bufr(k), k=1,nask) -c 17 format(' in keynum:',3i3,3(1pg14.6)) - 40 return - end -c -************************************************************************ -c - subroutine lexort(num,namlst,indx) -c -c General character array sorting subroutine. -c parameters - -c num - dimension of the arrays -c namlst - input array of character variables to be -c indexed in alphabetical order. This input -c array is not altered. -c indx - output sorted index array, generated so that -c namlst(indx(k)), k=1,num is in alphabetical order. -c C. T. Mottershead/ AT-3 2 Feb 88 -c---------------------------------------- - dimension indx(*) - character*(*) namlst(*) - character*8 first -c -c initialize the index array -c - do 5 j = 1, num - indx(j) = j - 5 continue -c -c find smallest remaining value and corresponding index -c - j=1 - 10 jin = indx(j) - first=namlst(jin) - mv=j -c -c find first remaining name, and location of its pointer in the -c index array (i.e namlst(indx(mv)) is the lowest remaining name) -c - do 30 k=j,num - kin = indx(k) - if(lge(namlst(kin),first)) go to 30 - first=namlst(kin) - mv=k - 30 continue -c -c swap the index of the lowest name (in location mv) with the -c first index (in location j) in the remaining list -c - isav = indx(j) - indx(j) = indx(mv) - indx(mv) = isav -c -c move starting location down one and repeat if necessary -c - j=j+1 - if(j.lt.num) go to 10 - 77 return - end -c -************************************************************************ -c - subroutine mdicut(nv) -c -c reset partial target (PARTGT) and rejudge the pool (XX,FF) relat -c to the new target -c -c C. T. Mottershead AT-3 6 July 92 -c----------------------------------------------------------------------- - include 'impli.inc' - include 'amdiip.inc' - include 'files.inc' -c----------------------------------------------------------- - last = nv+1 - npower = 2**ncut - write(jof,*) npower,'<<----Reach cut factor' - write(jodf,*) npower,'<<----Reach cut factor' - reach = 1.d0/float(npower) - do 20 k = 1, nv - partgt(k) = ff(k,last) + reach*(fultgt(k) - ff(k,last)) - 20 continue -c -c reevaluate errors of data pool relative to new target -c - do 60 n=1,last - em = 0.d0 - do 40 i=1,nv - df = abs(ff(i,n)-partgt(i)) - em = dmax1(df,em) - 40 continue - err(n) = em - 60 continue - return - end -c************************************************************** - subroutine mdipik(nv,ibest,iworst,best,worst) -c----------------------------------------------------------------------- - include 'impli.inc' - include 'amdiip.inc' -c----------------------------------------------------------- - last = nv + 1 - best=1.d30 - worst=-best - ibest=1 - iworst=1 - do 60 i = 1,last - if(err(i).lt.best) then - best = err(i) - ibest=i - endif - if(err(i).gt.worst) then - worst = err(i) - iworst = i - endif - 60 continue -c write(6,67) ibest,best,iworst,worst -c 67 format(' MDIPIK:',i3,' is best=',1pg15.7,i8,' is worst=',1pg15.7) - return - end -c************************************************************* -c subroutine mrt0 -c -c This is the least squares merit function defined by aims for loop 1 -c -c T. Mottershead, LANL Feb 89 -c----------------------------------------------------- -c include 'impli.inc' -c include 'merit.inc' -c -c gather the computed function values -c -c loon = 1 -c write(6,*) 'in mrt0' -c fval = rmserr(loon) -c val(0) = fval -c return -c end -c -***************************************************************** -c - subroutine mss(pp) -c -c optimization routine to least squares fit the selected aims to the -c specified targets. -c T. Mottershead LANL AT-3 24 Nov 92 -c----------------------------------------------------------------------- -cryne 3/14/06pm use acceldata -cryne 3/14/06pm use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' -cryne 21 March 2006 include 'status.inc' - include 'aimdef.inc' -c - parameter (maxf = 100) - dimension pp(6), tol(4) - dimension aims(maxf), xv(maxf), fv(maxf), lout(2) -cryne 3/15/06 save xv, fval, nx - save -c -c check and reset error flag from eig4 or eig6 to ok value -cryne 21 March 2006 if (imbad .ne. 0) imbad=0 -c -c check iteration counter for specified loop -c - nrpt = 1 - loon =1 - nopt = nint(pp(1)) -c write(6,*)'***INSIDE MSS***, nopt=',nopt - if(nopt.lt.0) then - nopt = -nopt - loon = 2 - endif - call chekit(loon,jiter,maxit) - iter = jiter + 1 - if(jiter.eq.0) then -c -c pick up parameters only on first pass (jicnt=0) -c - ftol = pp(2) - gtol = pp(3) - delta = pp(4) - xtol = pp(5) - tol(1) = gtol - tol(2) = xtol - tol(3) = ftol - tol(4) = delta - isend = nint(pp(6)) - info = 0 - ibsave = ibrief - ibrief = -7 - iscale = 0 - mode = 0 -c -c set up output levels and routing -c - lout(1) = jof - lout(2) = jodf - italk = 0 - if(isend.lt.0) italk = -isend - if(isend.eq.4) italk = 2 - if(isend.eq.-4) italk = 1 - ja = 1 - if(iabs(isend).eq.2) ja = 2 - jb = 1 - if(iabs(isend).gt.1) jb = 2 - write(jof,*) ' MSS is initialized' - endif -c -c progress report on previous iteration; -c compute fv and chi-squared -c - call getaim(loon,nf,aims) - do 40 jj = 1,nf - fv(jj) = aims(jj) - target(jj,loon) -40 continue - fold = fval - fval = rmserr(loon) - change = fval - fold -c if(abs(change).lt.ftol) go to 700 - write(6,*)'change,ja,jb=',change,ja,jb - if(ja.gt.jb) go to 100 - do 60 j = ja,jb - lun = lout(j) - write(lun,*)' ' - write(lun,51) iter, fval, change - 51 format(2x,'MSS iteration',i5,' F=',1pg18.9,' DF=',1pg14.6) - if((nrpt.gt.0).and.(mod(iter,nrpt).eq.0)) then - write(lun,54) (xv(k), k=1,nx) - 54 format(' XNEW: ',4(1pg18.9)) - endif - write(lun,58) - 58 format(1x,55('-')) - 60 continue - 100 continue -c -c Collect the current x-parameter vector. -c - call getvar(loon,nx,xv) -c -c compute the next estimate of the minimum, -c - if(nopt.eq.1) then - write(6,*)'using nls' - call nls(mode,iter,nx,xv,nf,fv,iscale,wts(1,loon),tol,info) - else -c -c use QSO on rms error merit function -c - write(6,*)'using qso' - call qso(mode,iter,nx,xv,fval,iscale,tol,info) - endif - write(jof,*)' optimizer return:',info,'=info' - write(jof,*)' XV=',(xv(ij),ij=1,nx) -c -c scatter the new x-parameter estimate, and let the labor continue. -c - if(info.eq.0) then - call putvar(loon,xv) - write(6,*)'info=0; RETURNING from MSS after first putvar' - return - endif -c -c Termination. Display final results. -c - 700 continue - if((info.lt.4).or.(info.gt.6)) call putvar(loon,xv) - if(isend.eq.0) go to 1000 - do 900 j=ja,jb - lun = lout(j) - call message(info,lun) - write(lun,710) iter - 710 format(' After ',i4,' total iterations, final values are:') - call wrtaim(lun,2,loon) - call wrtvar(loon,lun) - write(lun,*)' ' - write(lun,840) change - 840 format(2x,'Final change was ',1pg13.6) -c write(lun,841) dftol -c 841 format(2x,'Tolerance was ',1pg13.6) - 900 continue - 1000 call stopit(loon) - ibrief = ibsave - write(6,*)'RETURNING from MSS at end of routine; info=',info - return - end -c -********************************************************************** -c - subroutine opt(pp) -c -c optimization routine -c----------------------------------------------------------------------- -cryne 3/14/06pm use acceldata -cryne 3/14/06pm use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' -cryne 21 March 2006 include 'status.inc' -c include 'labpnt.inc' - include 'merit.inc' - parameter (maxf = 100) - dimension aims(maxf), xv(maxf), xold(maxf), lout(2) -c - dimension pp(6), tol(4) - common/rynetest/val12345 - save fffval - save ftol,gtol,delta,xtol,tol,isend,info,ibsave, & - & iscale,mode,lout,ja,jb - -c -c -c check and reset error flag from eig4 or eig6 to ok value -cryne 21 March 2006 if (imbad .ne. 0) imbad=0 -c -c check iteration counter for specified loop -c - nrpt = 1 - loon =1 - job = nint(pp(1)) - write(6,*)'***INSIDE OPT***, job=',job -c write(6,*)'***INSIDE OPT***, pp(1)=',pp(1) - if(job.lt.0) then - job = -job - loon = 2 - endif - call chekit(loon,jiter,maxit) - iter = jiter + 1 -ccc write(6,*)'(OPT) iter,jiter=',iter,jiter - if(jiter.eq.0) then -c -c pick up parameters only on first pass (jicnt=0) -c - ftol = pp(2) - gtol = pp(3) - delta = pp(4) - xtol = pp(5) - tol(1) = gtol - tol(2) = xtol - tol(3) = ftol - tol(4) = delta - isend = nint(pp(6)) - info = 0 - ibsave = ibrief - ibrief = -7 - iscale = 0 - mode = 0 -c -c set up output levels and routing -c - lout(1) = jof - lout(2) = jodf - ja = 1 - if(iabs(isend).eq.2) ja = 2 - jb = 1 - if(iabs(isend).gt.1) jb = 2 - write(jof,*)'************ OPT is initialized' -ccc write(6,*)'jof,jodf,isend,ja,jb=',jof,jodf,isend,ja,jb - fffval=val12345 -c write(6,*)'**********at this point fffval=',fffval - endif -c -c Collect the current x-parameter vector. -c - call getvar(loon,nx,xold) - write(6,*)'(OPT) ######### nx=',nx - do 20 j=1,nx - xv(j) = xold(j) - 20 continue -c -c collect selected merit function -c -c write(6,*)'******************now fffval=',fffval - fold = fffval - if(job.eq.1) then - call getaim(loon,nf,aims) - fffval = aims(1) - else - fffval = rmserr(loon) - endif - change = fffval - fold -c -c use QSO on selected merit function -c - call qso(mode,iter,nx,xv,fffval,iscale,tol,info) -ccc write(6,*)'QSO REPORT:' - dxsq = 0.d0 - do 40 j=1,nx -ccc write(6,*)j,xv(j),xold(j),(xv(j) - xold(j))**2 - dxsq = (xv(j) - xold(j))**2 - 40 continue - step = sqrt(dxsq) -c -c progress report -c write(6,*)'PROGRESS REPORT FROM OPT: ja,jb=',ja,jb -c - if(ja.gt.jb) go to 600 - do 60 j = ja,jb - lun = lout(j) - write(lun,*)' ' - write(lun,51) iter, fffval, change, step - 51 format(i5,'=iter F=',1pg20.12,' DF=',1pg14.6, - & ' DX=',1pg14.6) - if((nrpt.gt.0).and.(mod(iter,nrpt).eq.0)) then - write(lun,54) (xv(k), k=1,nx) - 54 format(' XNEW: ',4(1pg18.10)) -c write(lun,57) (dx(k), k=1,nx) -c 57 format(' DX: ',6(1pg12.4)) - endif - write(lun,58) - 58 format(1x,55('-')) - 60 continue - 600 continue -c -c scatter the new x-parameter estimate, and let the labor continue. -c - if(info.eq.0) then - call putvar(loon,xv) - return - endif -c -c Termination. Display final results. -c - 700 continue - if((info.lt.4).or.(info.gt.6)) call putvar(loon,xv) - if(isend.eq.0) go to 1000 - do 900 j=ja,jb - lun = lout(j) - call message(info,lun) - write(lun,710) iter - 710 format(' After ',i4,' total iterations, final values are:') - if(job.eq.1) then - call wrtaim(lun,1,loon) - else - final = rmserr(loon) - write(lun,721) loon, final - 721 format(' Final RMS error for loop',i2,' is',1pg18.10) - endif - call wrtvar(loon,lun) - write(lun,*)' ' - write(lun,840) change, step - 840 format(2x,'Final change was ',1pg13.6,2x,'final step was ', - & 1pg13.6) - write(lun,841) ftol, xtol - 841 format(2x,'Tolerances: ftol=',1pg13.6,12x,'xtol=',1pg13.6) - 900 continue - 1000 call stopit(loon) - ibrief = ibsave - return - end -c -********************************************************************** -c - subroutine putvar(loon,xnew) -c -c scatter the new x-parameter vector back to the parameter blocks -c including reseting the dependent variables. -c mm(i,kvs) is the i-th marylie menu item selected in vary -c idx(i,kvs) is the index (1 to 6) of the i-th variable parameter -c The first nv of these specify the independent variables being -c adjusted by the fit or optimization routines. -c The next nd entries specify parameters linearly dependent on -c one of the independent variables in the form -c base_value + slope*variable -c idv(j,kvs) specifies which independent variable (1 to nv) -c the j-th dependent parameter is tied to. -c xbase(j) and xslope(j) are the relevant base value and -c slope specified in vary. -c -c T. Mottershead LANL AT-3 23 July 90 -c------------------------------------------------------------- - use acceldata - include 'impli.inc' - include 'xvary.inc' - dimension xnew(*) -c -c simple copy back for the independent varables -c - kvs = loon - if(kvs.ne.2) kvs = 1 - nv = nva(kvs) - nd = nda(kvs) - do 20 i=1,nv - mnu = mm(i,kvs) - pmenu(idx(i,kvs)+mpp(mnu)) = xnew(i) - 20 continue - if (nd.le.0) return -c -c compute new values for linearly dependendent variables -c - do 50 j=1,nd - idu = idx(j+nv,kvs) - mnu = mm(j+nv,kvs) - depvar = xbase(j,kvs) + xslope(j,kvs)*xnew(idv(j,kvs)) - pmenu(idu+mpp(mnu)) = depvar - 50 continue - return - end -c -ccccccccccccccccccccccc RMSERR cccccccccccccccccccccccc -c - double precision function rmserr(loon) -c -c This function calculates the RMS error of the specified loop -c -c T. Mottershead, LANL AT-3 8 Dec 92 -c----------------------------------------------------- - include 'impli.inc' - include 'aimdef.inc' -c - rmserr = 0.d0 - nf = nsq(loon) - if(nf.le.0) return - fnum = float(nf) - chisq = 0.d0 - do 20 nu = 1, nf - ku = kyf(nu,loon) - nsu = nsf(nu,loon) - idu = idf(nu,loon) - jdu = jdf(nu,loon) - aimiss = valuat(ku,nsu,idu,jdu) - target(nu,loon) - chisq = chisq + wts(nu,loon)*aimiss**2 - 20 continue - rmserr = sqrt(chisq/fnum) - return - end -c -*************************************************************** -c - subroutine rset(pp) -c -c this subroutine resets items in the #menu component interactively -c made from parts of 'vary', 19 Aug 91, T. Mottershead, LANL -c - use acceldata - include 'impli.inc' - include 'files.inc' - include 'codes.inc' - character*80 card - dimension pp(6), menitm(20), indvar(20) - logical ltty, lfile, rewind -c -c write(6,*) ' in subroutine rset' -c----------------------------------------------------- - job = nint(pp(1)) - infile=nint(pp(2)) - rewind = .true. - if(infile.eq.0) infile = jif - if(infile.eq.jif) rewind = .false. - if(infile.lt.0) then - infile = -infile - rewind = .false. - endif - if(rewind) rewind(infile) - logf = nint(pp(3)) - lun = nint(pp(4)) - isend = nint(pp(5)) - lfile = .false. - ltty = .false. - if((isend.eq.1).or.(isend.eq.3)) ltty = .true. - if((isend.eq.2).or.(isend.eq.3)) lfile = .true. - ktot = 0 - maxrs = 20 - 10 if(ltty) call varlis(jof) -c -c select variable parameters -c - 20 if(ltty) write(jof,32) - 32 format(/' To RESET #menu items, enter name and (optional)', - & ' parameter index.',/' Type * to relist, or a # sign', - & ' when finished.') -c -c read a new input line -c - 40 read(infile,41,end=200) card - 41 format(a) - if(card.eq.' ') go to 40 - call low(card) - ifin = index(card,'#') - list = index(card,'*') - call vreset(infile,card,maxrs,ktot,menitm,indvar) - if(list.ne.0) go to 10 - if(ifin.eq.0) go to 20 - 200 continue -c -c Display reset selections -c - if(ktot.eq.0) return - if(ltty) write(jof,203) ktot - if(lfile) write(jodf,203) ktot - if(lun.gt.0) write(lun,203) ktot - 203 format(/' The following',i3,' #menu item(s) have been reset:') - if(ltty) write(jof,175) - if(lfile) write(jodf,175) - if(lun.gt.0) write(lun,175) - 175 format(' No. Item ',4x,'Type',5x,'Parameter',3x,'New value' - & /60('-')) - do 170 i = 1,ktot - idu = indvar(i) - mnu = menitm(i) - mt1 = nt1(mnu) - mt2 = nt2(mnu) - if(ltty) write(jof, 176) i, lmnlbl(mnu), ltc(mt1,mt2), idu, - & pmenu(idu+mpp(mnu)) - if(lfile) write(jodf, 176) i, lmnlbl(mnu), ltc(mt1,mt2), - & idu, pmenu(idu+mpp(mnu)) - if(lun.gt.0) write(lun, 176) i, lmnlbl(mnu), ltc(mt1,mt2), - & idu, pmenu(idu+mpp(mnu)) - 176 format(i3,4x,a8,3x,a8,i6,5x,1pg21.14) - 170 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine scan(pp) -c -c routine for scanning parameters -c T. Mottershead LANL AT-3 29-MAR-91 -c----------------------------------------------------------------------- - include 'impli.inc' - include 'files.inc' -c - parameter (maxg=100) - common/gradat/nx,nz,dxx,dyy,xcen(maxg),ycen(maxg) - dimension pp(6) - dimension xval(maxg) - logical ltty, lfile - save ltty, lfile, ncyc, deltax - loon =1 - nopt = nint(pp(1)) - if(nopt.lt.0) then - nopt = -nopt - loon = 2 - endif - call chekit(loon,iter,maxit) -c -c initialization for iter = 0 (ic=1) -c - if(iter.eq.0) then - ndx = nint(pp(2)) - ndy = nint(pp(3)) - ncyc = ndx + 1 - if(ndx.lt.0) ncyc = 1 - 2*ndx - if(ncyc.ge.maxit) ncyc = maxit - 1 - deltax = pp(4) - deltay = pp(5) - isend = nint(pp(6)) - ltty = .false. - lfile = .false. - if((isend.eq.1).or.(isend.eq.3)) ltty = .true. - if((isend.eq.2).or.(isend.eq.3)) lfile = .true. -c -c save the original x-parameter vector and set up loop -c - call getvar(loon,nx,xcen) - xx = xcen(1) - if(ndx.lt.0) xx = xx + float(ndx)*deltax -c -c increment the first x-variable -c - do 20 i=1,nx - xval(i) = xcen(i) - 20 continue - xval(1) = xx - call putvar(loon,xval) - return - endif -c -c normal running: print selected quantities for iter=1,nx: -c - if(iter.gt.ncyc) go to 900 - call getvar(loon,nx,xval) - xx = xval(1) - yy = xval(2) - if(ltty) write(jof,433) iter, xx, yy - if(lfile) write(jodf,433) iter, xx, yy - 433 format(' ** Scan Step',i4,' xx, yy =',2(1pg15.7)) -c -c increment parameter vector on first ncyc-1 calls: -c - if(iter.lt.ncyc) then - do 520 i=1,nx - xval(i) = xcen(i) - 520 continue - xx = xx + deltax - xval(1) = xx - call putvar(loon,xval) - else -c restore original values on last pass - if(nopt.eq.1) call putvar(loon,xcen) - endif - return -c -c all done, put it back the way it was -c and jump out of labor loop -c - 900 continue - if(ltty) write(jof,*) ' Scan loop is finished' - if(lfile) write(jodf,*) ' Scan loop is finished' - call stopit(loon) - return - end -c -***************************************************************** -c - subroutine solveh(augmat,nrow,nca,det) -c Solves the linear equations -c m*a = b -c where m is nrow by nrow -c a is nrow by nca -c b is nrow by nca -c On entry : augmat = m augmented by b -c nca = number of columns in a or b -c On return: augmat = identity augmented by a -c det = determinant of m - double precision augmat(nrow,nrow+nca), det -c -c Coded from a routine originally written for the HP41C calculator -c (Dearing, p.46). Written by Liam Healy, February 14, 1985. -c routine and some variables renamed by Tom Mottershead, 15-Nov-88. -c----Variables---- -c nrow = dimension of matrix = total number of rows. -c nca = number of columns augmented -c ncol = total number of columns = nrow + nca. - integer nrow, nca, ncol -c -c irow,jcol,ir,jc,roff,mr=row and column numbers, row and column indice -c row offset, row number for finding maxc. - integer irow,jcol,ir,jc,roff,mr -c -c elem, mrow, hold = matrix element, its row number, and held value. -c const = constant used in multiplication - double precision elem,hold,const - integer mrow -c -c----Routine---- - det=1.d0 - ncol=nrow+nca - jcol=0 - do 100 irow=1,nrow - 300 jcol=jcol+1 - if (jcol.le.ncol) then -c find max of abs of mat elts in this col, and its row num - elem=0.d0 - mrow=0 - do 120 mr=irow,nrow - if (abs(augmat(mr,jcol)).ge.abs(elem)) then - elem=augmat(mr,jcol) - mrow=mr - endif - 120 continue - det=det*elem - if (elem.eq.0.) goto 300 - do 140 jc=1,ncol - augmat(mrow,jc)=augmat(mrow,jc)/elem - 140 continue - if (mrow.ne.irow) then -c swap the rows - do 160 jc=1,ncol - hold=augmat(mrow,jc) - augmat(mrow,jc)=augmat(irow,jc) - augmat(irow,jc)=hold - 160 continue - det=-det - endif - if (irow.lt.nrow) then - do 190 ir=1,nrow - if (ir.ne.irow) then -c multiply row row by const & subtract from row ir - const=augmat(ir,jcol) - do 180 jc=1,ncol - augmat(ir,jc)=augmat(ir,jc)-augmat(irow,jc)*const - 180 continue - endif - 190 continue - endif - endif - 100 continue -c -c Matrix is now in upper triangular form. -c To solve equation, must get it to the identity. - do 200 roff=nrow,1,-1 - do 200 irow=roff-1,1,-1 - const=augmat(irow,roff) - do 200 jc=irow,ncol - augmat(irow,jc)=augmat(irow,jc)-const*augmat(roff,jc) - 200 continue - return - end -c -********************************************************************* -c - subroutine sq(p) -c -c This subroutine selects quantities to be written out by a command -c with type code wsq (write selected quantities). -c It it essentially a special way of calling the subroutine aim. -c Written by Alex Dragt 6/15/89 -c Revised (interim) by Tom Mottershead, 30 May 91 -c----------------------------------------------------------------------- - include 'impli.inc' - include 'files.inc' - dimension p(6), pp(6) -c -c set up control parameters for pass thru to aim -c - pp(1) = 1.d0 - pp(2) = p(1) - pp(3) = p(2) - pp(4) = 0.d0 - pp(5) = p(3) - pp(6) = p(4) -c -c write(jof,*) ' ' -c write(jof,*) ' In subroutine sq' - call aim(pp) -c - return - end -c -c******************************************************************** -c - subroutine stopit(loon) -c -c stops loop number loon = 1 for inner loop -c = 2 for outer loop -c -c T. Mottershead LANL AT-3 7 Oct 91 -c---------------------------------------------------- - include 'impli.inc' - include 'files.inc' - include 'labpnt.inc' - if(loon.eq.2) then - jocnt = notms - else - jicnt = nitms - endif - iquiet = 0 - return - end -c -************************************************************************ -c - subroutine subtip(p) -c subroutine for terminating an inner procedure -c Written by Alex Dragt on 8-8-88. Modified 9-3-90 AJD -c - include 'impli.inc' - include 'labpnt.inc' - include 'files.inc' -c - dimension p(6) - character*1 yn -c - iopt=nint(p(1)) - if (iopt.eq.1) then -c jif = 5 - write(jof,*) ' ' - write(jof,*) - & ' Do you wish to jump out of inner procedure? (y/n) :' - yn='n' - read(jif,177) yn - 177 format(a) - if ((yn .eq.'y').or.(yn .eq.'Y')) then - jicnt=0 - return - endif - endif -c - jicnt=jicnt+1 - if (jicnt.lt.nitms) then -c write(6,*) 'lp in epro is',lp - lp=jbipnt - return - else - jicnt=0 - iquiet=0 - return - endif -c - end -c -********************************************************************* -c - subroutine subtop(p) -c subroutine for terminating an outer procedure -c Written by Alex Dragt on 8-8-88. Modified 9-3-90 AJD -c - include 'impli.inc' - include 'labpnt.inc' - include 'files.inc' -c - dimension p(6) - character*1 yn -c - iopt=nint(p(1)) - if (iopt.eq.1) then -c jif = 5 - write(jof,*) ' ' - write(jof,*) - & ' Do you wish to jump out of outer procedure? (y/n) :' - yn='n' - read(jif,177) yn - 177 format(a) - if ((yn .eq.'y').or.(yn .eq.'Y')) then - jocnt=0 - return - endif - endif -c - jocnt=jocnt+1 - if (jocnt.lt.notms) then -c write(6,*) 'lp in epro is',lp - lp=jbopnt - return - else - jocnt=0 - iquiet = 0 - return - endif -c - end -c -*************************************************************** -c - subroutine txtnum(str,nch,nask,nget,bufr) -c -c txtnum scans the first nch characters of the string 'str' for -c real numbers in any format. all non-numeric characters -c serve as delimiters. -c -c parameters: -c str - the input character string to be searched -c nch - length of character string to be searched -c nask - maximum length of number list -c nget - actual number of numbers found -c bufr - output array of real numbers -c -c T. Mottershead Los Alamos June 1985 -c---------------------------------------------------------- - implicit double precision(a-h,o-z) -c----------------------------------------------------------------------- - dimension bufr(*) - dimension numc(4) ,ntyp(17) - character*1 ic - character*17 numric - character numdat*30, card*30, str*(*) - data ntyp /10*1,2*2,3,4*4/ - save ntyp !cryne 7/23/2002 - numric='0123456789+-.EeDd' - maxch=len(str) - if(maxch.gt.nch) maxch=nch - indx=0 - maxc=30 - nget=0 -c write(6,17) -c 17 format(' err nget -----numc-----',16x,'extracted text',5x -c $,'value') -c -c scan for numeric characters -c - 90 do 95 j=1,4 - 95 numc(j)=0 - idc=0 - 100 continue - indx=indx+1 - if(indx.le.maxch) go to 110 - if(idc.gt.0) go to 200 - go to 599 - 110 ic=str(indx:indx) - nn=index(numric,ic) - if(nn.eq.0) go to 200 -c -c valid numeric character found, save in decode buffer: -c - kk=ntyp(nn) - numc(kk)=numc(kk)+1 - idc=idc+1 - numdat(idc:idc)=ic - go to 100 -c -c delimiter character, check for valid string -c - 200 continue - if(idc.eq.0) go to 100 - if((numc(1).eq.0).or.(numc(2).gt.2)) go to 90 - if((numc(3).gt.1).or.(numc(4).gt.1)) go to 90 -c -c possible string, right justify and decode -c - if(idc.gt.maxc) idc=maxc - m=maxc-idc+1 - card=' ' - value=-7777777.d0 - card(m:maxc)=numdat(1:idc) - read(card,301,iostat=numerr) value -cryne?read(card,*,iostat=numerr) value - 301 format(f30.0) -c write(6,317) numerr,nget+1,numc,card,value -c 317 format(6i4,a30,1pg16.7) -c -c save the good ones in the output buffer -c - if(numerr.eq.0) then - nget=nget+1 - bufr(nget)=value - if(nget.eq.nask) go to 599 - endif - go to 90 - 599 return - end -c -ccccccccccccccccccccccc valuat ccccccccccccccccccccccccc -c - function valuat(ku,nsu,idu,jdu) -cryne 12/15/2004 modified to use new common block structure in stmap.inc -cryne Originally: -cryne common/stmap/sf1(monoms),sf2(monoms),sf3(monoms),... -cryne# ... sm4(6,6),sm5(6,6) -cryne which is equivalenced to: -cryne dimension sfa(monoms,5), sma(6,6,5) -cryne Replaced with: -cryne common/stmap/storedpoly(monoms,20),storedmat(6,6,20) - use rays - use lieaparam, only : monoms - include 'impli.inc' - include 'fitdat.inc' - include 'buffer.inc' - include 'stmap.inc' - include 'usrdat.inc' - include 'map.inc' - include 'merit.inc' -cryne 20 March 2006 added keyset.inc to get access to maxjlen - include 'keyset.inc' - dimension matsig(6,6) - data matsig /7,8,9,10,11,12,8,13,14,15,16,17,9,14,18,19,20,21, - & 10,15,19,22,23,24,11,16,20,23,25,26,12,17,21,24,26,27/ - save matsig !cryne 7/23/2002 - noffset=9 -cryne----20 March, 2006: - if(ku.eq.57)then - valuat=arclen - return - endif -cryne---- -c -cryne----20 March 2006: -c if(ku.gt.12) then -c valuat = fitval(ku - 8) -c noffset is determined by: -c position of 'tx' in array key minus noffset=position of tux in fitdat -c As of today, 14-noffset=5, i.e. noffset=9 -c As of today, this is hardwired at at routine entry (for debugging) -c Also, variable maxjlen (formerly hardwired 12) = length of maxj array - if(ku.gt.maxjlen) then - valuat = fitval(ku - noffset) - return - endif - go to (10,20,30,40,50,60,70,80,90,100,110,120,130), ku -c -c stored maps -c - 10 continue -cryne valuat = sma(idu,jdu,nsu) - valuat = storedmat(idu,jdu,nsu) - return -c -c map buffers -c - 20 continue - valuat = bma(idu,jdu,nsu) - return -c -c stored polynomials -c - 30 continue -cryne valuat = sfa(idu,nsu) - valuat = storedpoly(idu,nsu) - return -c -c polynomial buffers -c - 40 continue - valuat = bfa(idu,nsu) - return -c -c map matrix -c - 50 continue - valuat = tmh(idu,jdu) - return -c -c beam sigma matrix -c - 60 continue - isig = matsig(idu,jdu) - valuat = bfa(isig,1) - return -c -c ray coordinate -c - 70 continue -cryne valuat = zblock(idu,jdu) - valuat = zblock(jdu,idu) - return -c -c current polynomial -c - 80 continue - valuat = th(idu) - return -c -c user data -c - 90 continue - valuat = ucalc(idu) - return -c -c merit function -c - 100 continue - valuat = val(idu) - return -c -c least squares is just flagged -c - 110 continue - valuat = -777.d0 - return -c -c reference trajectory -c - 120 continue - valuat = reftraj(idu) - return -c -c dispersions -c - 130 continue - valuat = dz(idu) - return - end -c -cccccccccccccccccccccccc VARLIS cccccccccccccccccccccccccc -c - subroutine varlis(jof) -c -c display list of menu item labels -c - use acceldata - include 'impli.inc' -c - dimension kseq(8), lseq(mnumax) - character*8 nwrd(8) -c -cryne - lseq(1:mnumax)=0 -cryne - call lexort(na,lmnlbl,lseq) - nnw = (na+7)/8 - write(jof,11) - 11 format(' MARYLIE #menu entries available to be varied:', - &/72('-')) - do 20 j = 1,nnw - do 15 nn=1,8 -cryne this statement references elements of lseq beyond na, -c so lseq must be initialized to zero or it will cause a core dump - kseq(nn) = lseq(j+(nn-1)*nnw) - 15 continue - do 18 i=1,8 - if (kseq(i).eq.0) nwrd(i) = ' ' - if (kseq(i).ne.0) nwrd(i) = lmnlbl(kseq(i)) - 18 continue - write(jof,19) (nwrd(i),i=1,8) - 19 format(8(1x,a8)) - 20 continue - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine vary(pp) -c -c VARY selects the #menu parameters to vary in fitting procedures -c -c C. T. Mottershead /LANL & L. B. Schweitzer/UCB -c----------------------------------------------------- -c - use acceldata - use lieaparam, only : monoms - include 'impli.inc' - include 'aimdef.inc' - include 'xvary.inc' - include 'labpnt.inc' - include 'files.inc' - include 'codes.inc' -c -c lmnlbl(i) = name of ith element (numbered as they occur in #menu) -c pmenu(k+mpp(i)) = kth parameter of ith element -c nt1(i) = group index of the elements type (see /monics/) -c nt2(i) = type index ..... -c - dimension pp(6), menitm(20), indvar(20) -c -c ltc(i,k) = name of element k in group i -c nrp(i,k) = number of parameters -c both are constants, set in block data names -c - character*128 card, retext - character*12 vword - character*1 yn - logical nodep, rewind -c - write(6,*)'INSIDE VARY' - loon = nint(pp(5)) - if((loon.lt.1).or.(loon.gt.3)) loon = 1 - call chekit(loon,iter,maxit) - if(iter.ne.0) return - ivar=nint(pp(1)) - nodep = .true. - if(ivar.lt.0) then - nodep = .false. - ivar = -ivar - endif -c jif = 5 - infile=nint(pp(2)) - rewind = .true. - if(infile.eq.0) infile = jif - if(infile.eq.jif) rewind = .false. - if(infile.lt.0) then - infile = -infile - rewind = .false. - endif - if(rewind) rewind(infile) - logf = nint(pp(3)) - iscale = nint(pp(4)) - if(iscale.ne.0) write(jof,*)' VARY:scale and bounds not ready yet' - isend = nint(pp(6)) - maxrs = 20 - ktot = 0 - nmax = nsq(loon) - if(ivar.gt.2) nmax = maxv - 5 nrem = nmax - nv = 0 - ibgn = 1 - do 8 j=1,maxv - idx(j,loon) = 0 - mm(j,loon) = 0 - 8 continue - if(infile.ne.jif) go to 40 - 10 call varlis(jof) -c -c select variable parameters -c - 30 if(infile.ne.jif) go to 40 - write(jof,32) - 32 format(/' Enter name and (optional) parameter index for', - &' #menu element(s) to be varied.',/' Elements named following a - & $ may be reset only. Type * to relist') - if(ivar.eq.1) then - write(jof,36) nrem - 36 format(' Selection of',i4,' more elements is required') - else - write(jof,34) nrem - 34 format(' Select up to',i4,' element(s): (Enter a # sign when finis - &hed)') - endif -c -c read a new input line -c - 40 read(infile,41,end=200) card - 41 format(a) - write(jof,41) card - if(card.eq.' ') go to 40 - call low(card) - ifin = index(card,'#') - list = index(card,'*') - idol = index(card,'$') - retext = ' ' -c -c check for reset commands -c - if(idol.gt.0) then - retext = card(idol+1:80) - card(idol+1:80) = ' ' - call vreset(infile,retext,maxrs,ktot,menitm,indvar) - endif -c -c look for normal variable selections -c - write(jof,53) card - 53 format(' New input record:',/,a) - call vscan(card,kount,menitm,indvar) - write(jof,*) kount,' items found in VSCAN' -c -c finish the incomplete specifications -c - do 100 kr = 1, kount - mnu = menitm(kr) - idu = indvar(kr) - mt1 = nt1(mnu) - mt2 = nt2(mnu) - npar=nrp(mt1,mt2) - if(npar.eq.1) idu = 1 - nv = nv + 1 -c write(jof,*) ' card',nv,'=nv',kr,'=kr',mnu,'=mnu',npar,'=npar' - mm(nv,loon) = mnu -c -c ask for new selections for out of bounds parameters -c - 80 if((idu.gt.0).and.(idu.le.npar)) go to 85 - write(jof,81) nv, lmnlbl(mnu), ltc(mt1,mt2) - 81 format(' No.',i3,' is ',2a8,'. Select parameter to vary:') - write(jof,83) (pmenu(k+mpp(mnu)),k = 1,npar) - 83 format(' p=',6(1pg12.4)) - read(jif,*) idu - go to 80 -c -c save valid parameter index and show what is picked so far -c - 85 idx(nv,loon) = idu - 90 write(jof,91) nv, lmnlbl(mnu), ltc(mt1,mt2), idu, npar - 91 format(' No.',i3,' is ',a8,1x,a8,'. Parameter',i2,' out of',i2, - &' selected.') - nch = index(lmnlbl(mnu),' ') -c write(jof,92) nch, mnu, lmnlbl(mnu) -c 92 format(' nch,mnu=',2i6,' name = ',a) - if(nch.eq.0) nch=9 - write(vword,93) idu - 93 format(9x,'(',i1,')') - vword(11-nch:9) = lmnlbl(mnu)(1:nch-1) - varnam(nv,loon) = vword - write(jof,95) varnam(nv,loon),pmenu(idu+mpp(mnu)) - 95 format(1x,a,' = ',1pg21.14) - 100 continue -c -c See if we are finished. If not, go back to read another card -c - nrem = nmax - nv -c write(jof,*) ' VARY end check:',nrem,ifin,list - if(nrem.le.0) go to 200 - if(ifin.ne.0) go to 200 - if(list.ne.0) go to 10 - go to 30 -c -c Display final selections -c - 200 continue - kprt = 0 - if((isend.eq.1).or.(isend.eq.3)) lun = jof - if(isend.eq.2) lun = jodf -cryne 20 March 2006 added "if(isend.ne.0)" to "write(lun..." statements below - 201 if(isend.ne.0)write(lun,203) - 203 format(/' Variable #menu elements selected:') - if(isend.ne.0)write(lun,175) - 175 format(' No. Element',4x,'Type',5x,'Parameter',3x,'Present value' - & /60('-')) - do 170 i = 1,nv - idu = idx(i,loon) - mnu = mm(i,loon) - mt1 = nt1(mnu) - mt2 = nt2(mnu) - if(isend.ne.0) - &write(lun,176) i,lmnlbl(mnu),ltc(mt1,mt2),idu,pmenu(idu+mpp(mnu)) - 176 format(i3,4x,a8,3x,a8,i6,5x,1pg21.14) - 170 continue - if((isend.eq.3).and.(kprt.eq.0)) then - kprt = 1 - lun = jodf - go to 201 - endif -c - if(infile.eq.jif) then - write(jof,*) ' ' - write(jof,*) ' Do you wish to start over? (y/n) :' - yn='n' - read(jif,41) yn - if ((yn .eq.'y').or.(yn .eq.'Y')) go to 5 - endif -c -c select dependent parameters -c - nd = 0 - if(nodep) go to 400 - 300 continue - nd = 0 - nmax = maxv - nv - nrem = nmax - 430 if(infile.ne.jif) go to 340 - write(jof,332) nrem - 332 format(/' Define up to',i4,' dependent variables V by entering the - &ir names',/,' and (optional) parameter indices. (Enter a # sign wh - &en finished)') -c -c read a new input line -c - 340 read(infile,41,end=600) card - write(jof,41) card - if(card.eq.' ') go to 340 - call low(card) - ifin = index(card,'#') - list = index(card,'*') -c -c look for normal variable selections -c - call vscan(card,kount,menitm,indvar) -c -c finish the incomplete specifications -c - if(kount.eq.0) go to 530 - do 500 kr = 1, kount - mnu = menitm(kr) - idu = indvar(kr) - mt1 = nt1(mnu) - mt2 = nt2(mnu) - npar=nrp(mt1,mt2) - if(npar.eq.1) idu = 1 - nd = nd + 1 - mm(nd + nv,loon) = mnu -c -c ask for new selections for out of bounds parameters -c - 380 if((idu.gt.0).and.(idu.le.npar)) go to 355 - write(jof,81) nd, lmnlbl(mnu), ltc(mt1,mt2) - write(jof,83) (pmenu(k+mpp(mnu)),k = 1,npar) - read(jif,*) idu - go to 380 -c -c read new parameter value -c - 355 idx(nd + nv,loon) = idu - write(jof,91) nd, lmnlbl(mnu), ltc(mt1,mt2), idu, npar - if(infile.eq.jif) write(jof,357) nv - 357 format(' Enter ID (1 to',i4,') of independent variable x , and the - & derivative dV/dx:') - read(infile,*) ivn, deriv - idv(nd,loon) = ivn - xslope(nd,loon) = deriv - pval = pmenu(idx(ivn,loon)+mpp(mm(ivn,loon))) - xbase(nd,loon) = pmenu(idu+mpp(mnu)) - xslope(nd,loon)*pval - 500 continue -c -c See if we are finished. If not, go back to read another card -c - 530 nrem = nmax - nd - if(nrem.le.0) go to 600 - if(ifin.ne.0) go to 600 - if(list.ne.0) go to 200 - go to 430 -c -c Display final selections -c - 600 continue - if(nd.le.0) go to 650 - kprt = 0 - if((isend.eq.1).or.(isend.eq.3)) lun = jof - if(isend.eq.2) lun = jodf -cryne 20 March 2006 added "if(isend.ne.0)" to "write(lun..." statements below - 301 if(isend.ne.0)write(lun,303) - 303 format(/' Dependent #menu elements selected:') - if(isend.ne.0)write(lun,375) - 375 format(' No. Element',4x,'Type',5x,'Parameter',3x,'Present value' - &,6x,' IDV Slope', /72('-')) - do 570 i = 1,nd - idu = idx(i+nv,loon) - mnu = mm(i+nv,loon) - mt1 = nt1(mnu) - mt2 = nt2(mnu) - if(isend.ne.0) - &write(lun,376) i,lmnlbl(mnu),ltc(mt1,mt2),idu,pmenu(idu+mpp(mnu)), - & idv(i,loon), xslope(i,loon) - 376 format(i3,3x,a8,3x,a8,i4,5x,1pg21.14,i5,0pf10.5) - 570 continue - if((isend.eq.3).and.(kprt.eq.0)) then - kprt = 1 - lun = jodf - go to 301 - endif -c - 650 if(infile.eq.jif) then - write(jof,*) ' ' - write(jof,*) ' Do you wish to start over? (y/n) :' - yn='n' - read(jif,41) yn - if ((yn .eq.'y').or.(yn .eq.'Y')) go to 300 - endif -c -c write final selections to log file -c - 400 if(logf.gt.0) then - do 410 i = 1,nv - write(logf,407) lmnlbl(mm(i,loon)), idx(i,loon) - 407 format(2x,a8,2x,i2) - 410 continue - if(nd.gt.0) then - if(ivar.gt.1) write(logf,*) ' #' - do 450 j = 1,nd - i = j + nv - write(logf,407) lmnlbl(mm(i,loon)), idx(i,loon) - write(logf,*) idv(j,loon), xslope(j,loon) - 450 continue - endif - write(logf,*) ' #' - endif - nva(loon) = nv - nda(loon) = nd - return - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine vreset(infile,retext,maxrs,ktot,mrset,irset) - use acceldata - include 'impli.inc' - include 'files.inc' - include 'codes.inc' - dimension menitm(20), indvar(20), mrset(*), irset(*) - character*(*) retext - jout = jof - if(infile.ne.jif) jout = jodf -c -c lmnlbl(i) = name of ith element (numbered as they occur in #menu) -c pmenu(k+mpp(i)) = kth parameter of ith element -c nt1(i) = group index of the elements type (see /monics/) -c nt2(i) = type index ..... -c ltc(i,k) = name of element k in group i -c nrp(i,k) = number of parameters -c both are constants, set in block data names -c - call vscan(retext,kount,menitm,indvar) -c write(jof,*) ' after vscan:',kount,'=kount' -c write(jof,*) ' menitm:',(menitm(j),j=1,kount) -c write(jof,*) ' indvar:',(indvar(j),j=1,kount) -c -c complete the resets -c - do 60 kr = 1, kount - mnu = menitm(kr) - idu = indvar(kr) - mt1 = nt1(mnu) - mt2 = nt2(mnu) - npar=nrp(mt1,mt2) - if(npar.eq.0) go to 60 -c write(jof,*) ' vreset',kr,'=kr',mnu,'=mnu',idu,'=idu',mt1,'=mt1 -c &,mt2,'=mt2', npar,'=npar' - if(npar.eq.1) idu = 1 -c -c ask for new selections for out of bounds parameters -c - 50 if((idu.gt.0).and.(idu.le.npar)) go to 55 - write(jout,51) lmnlbl(mnu), ltc(mt1,mt2) - 51 format(' Select parameter to reset for ',2a8) - write(jout,53) (pmenu(k+mpp(mnu)),k = 1,npar) - 53 format(1x,6(1pe13.5)) - read(infile,*) idu - go to 50 -c -c valid index, read new parameter value -c - 55 pval = pmenu(idu+mpp(mnu)) - write(jout,57) idu, lmnlbl(mnu), pval - 57 format(' Enter new value for parameter',i2,' of ',a8, - & ' <',1pg16.8,'>:') - read(infile,*) pval - pmenu(idu+mpp(mnu)) = pval - ktot = ktot + 1 - if(ktot.le.maxrs) then - mrset(ktot) = mnu - irset(ktot) = idu - endif - 60 continue - return - end -c -ccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine vscan(card,kount,menitm,indvar) -c -c VSCAN scans the character array card for valid #menu -c items (menitm) and parameter selections (indvar) -c C. T. Mottershead /LANL AT-3 18 July 90 -c----------------------------------------------------- - use acceldata - include 'impli.inc' - include 'codes.inc' -c -c nt1(i) = group index of the elements type (see /monics/) -c nt2(i) = type index ..... -c nrp(i,k) = number of parameters -c both are constants, set in block data names -c - dimension menitm(*), indvar(*) - character*(*) card - character*10 string - logical lfound, lnum, leftel -c -c parse the input card -c - kbeg = 1 - leftel = .false. - kount = 0 - npar = 0 - 50 continue - msegm=2 - call cread(kbeg,msegm,card,string,lfound) - if(.not.lfound) return -c -c string found, see if it is an element -c - call lookup(string,itype,mnu) - if(itype.ne.1) go to 60 -c -c it is an element -c - mt1 = nt1(mnu) - mt2 = nt2(mnu) - npar=nrp(mt1,mt2) -c -c reject if no parameters -c - if(npar.eq.0) then - leftel = .false. - go to 50 - endif -c -c accept it because it has parameters -c - kount = kount + 1 - menitm(kount) = mnu - indvar(kount) = 0 - leftel = .true. - go to 50 -c -c it isn't an element, see if it is a number -c -cryne August 5, 2004 -cryne Calling cnumb0 (the original version of cnumb) solved a -cryne problem that I was having in which the code would not run -cryne one of Peter Walstrom's examples. The reason for this is -cryne most likely that cnumb was modified for to tread 16 character -cryne strings, but in this routine the dimension is 10. A single -cryne version of cnumb would probably work if it used LEN(string) -cryne instead of hardwired values such as 10 or 16. -cryne This should be checked later, and the two versions consolidated -cryne if possible. - 60 call cnumb(string,num0,lnum) -c -c if it is a number, and a preceeding element is defined, and it is -c in bounds, interpret it as the selected parameter for that element -c - if(lnum.and.leftel) then - if((num0.ge.1).and.(num0.le.npar)) indvar(kount) = num0 - endif - leftel = .false. - go to 50 - end -c -cccccccccccccccccccccc WRTAIM ccccccccccccccccccccccccc -c - subroutine wrtaim(lun,kaim,loon) -c-----!----------------------------------------------------------------! - include 'impli.inc' - include 'aimdef.inc' - include 'fitbuf.inc' - include 'files.inc' - dimension aimbuf(3) - if(kaim.le.3) write(lun,*)' ' - if(kaim.le.3) write(lun,*)' Aims selected : ' - if(kaim.eq.1) write(lun,103) - 103 format(' No. item',6x,'present value',/35('-')) - if(kaim.eq.2) write(lun,105) - 105 format(' No. item',8x,'present value',8x,'target value', - & /53('-')) - if(kaim.eq.3) write(lun,107) - 107 format(' No. item',8x,'present value',8x,'target value', - & 8x,'weights', /70('-')) - jmin = 1 - jmax = kaim - if(kaim.gt.3) then - jmin = 2 - jmax = 3 - endif - nf = nsq(loon) - do 100 nu = 1, nf - ku = kyf(nu,loon) - nsu = nsf(nu,loon) - idu = idf(nu,loon) - jdu = jdf(nu,loon) - aimbuf(1) = valuat(ku,nsu,idu,jdu) - aimbuf(2) = target(nu,loon) - aimbuf(3) = wts(nu,loon) - write(lun,96) nu, qname(nu,loon), (aimbuf(j),j=jmin,jmax) - 96 format(i3,' ',a,' = ',2(1pg20.9),0pf14.4) - go to 100 - 100 continue - return - end -c -ccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine wrtsq(lun,kform,nf,names,values) -c -c Output selected quantities array to unit lun in format kform. -c -c kform = format selection flag -c = 0 to write names only -c = 1 to write a line of values (6 digit accuracy) -c = 2 to write 3 names and values per line (8 digit accuracy) -c = 3 to write a single value per line, full precision -c Tom Mottershead, 31 May 91 -c-----!----------------------------------------------------------------! - use lieaparam, only : monoms - include 'impli.inc' - include 'map.inc' - dimension values(*) - character*(*) names(*) -c write(lun,*) ' *WRTSQ:',nf,' = number items' -c -c format 0: labels only -c - if(kform.eq.0) then - write(lun,63) (names(i), i=1,nf) - 63 format(10(1x,a12)) - endif -c -c format 1: 6 digit columns -c - if(kform.eq.1) then -cryne 20 March 2006 write(lun,67) arclen, (values(i), i=1,nf) - write(lun,67) (values(i), i=1,nf) - 67 format(10(1pe13.5)) - endif -c -c format 2: 3 on a line -c - if(kform.eq.2) then -c write(lun,43) ((names(i),values(i)),i=1,nf) - write(lun,43) (names(i),values(i),i=1,nf) - 43 format(3(a12,'=',1pg13.6)) - endif -c -c format 3: full precision -c - if(kform.eq.3) then - do 25 nu = 1, nf - write(lun,27) nu, names(nu), values(nu) - 27 format(' SQ',i3,': ',a,' = ', 1pg23.15) - 25 continue - endif - return - end -c -c******************************************************************* -c - subroutine wrtvar(kpik,lun) -c -c Display new values for parameters. -c - use acceldata - include 'impli.inc' - include 'codes.inc' - include 'xvary.inc' - loon = kpik - if((loon.lt.1).or.(loon.gt.3)) loon = 1 - nv = nva(loon) - nd = nda(loon) - write(lun,*)' ' - write(lun,*)' New values for parameters:' - write(lun,65) - 65 format(' No. Element',4x,'Type',3x,'Parameter',3x,'Present value' - &,8x,' IDV Slope', /72('-')) - do 50 i = 1,nv - idu = idx(i,loon) - mnu = mm(i,loon) - mt1 = nt1(mnu) - mt2 = nt2(mnu) - write(lun,48) i,lmnlbl(mnu),ltc(mt1,mt2),idu,pmenu(idu+mpp(mnu)) - 48 format(i3,3x,a8,3x,a8,i4,5x,1pg21.14) - 50 continue - do 70 i = 1,nd - j = i + nv - idu = idx(j,loon) - mnu = mm(j,loon) - mt1 = nt1(mnu) - mt2 = nt2(mnu) - write(lun,68) j,lmnlbl(mnu),ltc(mt1,mt2),idu,pmenu(idu+mpp(mnu)), - & idv(i,loon), xslope(i,loon) - 68 format(i3,3x,a8,3x,a8,i4,5x,1pg21.14,i5,0pf10.4) - 70 continue - return - end -c -ccccccccccccccccccc wsq cccccccccccccccccccccccccc -c -c - subroutine wsq(pp) -c subroutine for writing out selected quantities -c Written by Alex Dragt, 21 August 1988 -c Filled in by Tom Mottershead, 30 May 91 -c -c-----!----------------------------------------------------------------! - use acceldata - include 'impli.inc' - include 'files.inc' - include 'aimdef.inc' - include 'xvary.inc' - include 'usrdat.inc' - dimension pp(6), qbuf(30) - character*12 names(30) - job = nint(pp(1)) - loon = nint(pp(2)) - if((loon.lt.1).or.(loon.gt.3)) loon = 1 - lun = nint(pp(3)) - kform = nint(pp(4)) - jform = nint(pp(5)) - isend = nint(pp(6)) - nv = 0 - nf = 0 - numq = 0 -c write(jof,*)job,loon,lun,kform,jform,isend,' = WSQ (PP)' - if(job.eq.4) go to 100 -c -c copy variables to print buffers -c - if(job.eq.1) go to 50 - nv = nva(loon) - numq = nv - if(numq.gt.30) numq = 30 - do 40 i = 1,numq - mnu = mm(i,loon) - qbuf(i) = pmenu(idx(i,loon)+mpp(mnu)) - names(i) = varnam(i,loon) - 40 continue -c -c copy selected quantities (aims) to print buffers -c - 50 if(job.eq.2) go to 100 - nf = nsq(loon) - numq = nf + nv - if(numq.gt.30) then - numq = 30 - nf = 30 - nv - endif - do 60 nu = 1, nf - ku = kyf(nu,loon) - nsu = nsf(nu,loon) - idu = idf(nu,loon) - jdu = jdf(nu,loon) - qbuf(nu+nv) = valuat(ku,nsu,idu,jdu) - names(nu+nv) = qname(nu,loon) - 60 continue -c -c print any rms errors selected in current loon -c - 100 continue - do 150 ku = 1,3 - lu = lsq(ku,loon) - if(lu.ne.1) go to 150 - numq = numq+1 - fval = rmserr(ku) - qbuf(numq) = fval - write(names(numq),141) lu - 141 format(3x,'rms',i1,5x) - 150 continue -c -c print buffers -c -c write(jof,*)' WSQ: nva =', nva -c write(jof,*)' WSQ: nsq =', nsq -c write(jof,*)' * WSQ:',nv,'=nv',nf,'=nf',numq,'=numq total' - if(lun.gt.0) call wrtsq(lun,kform,numq,names,qbuf) - if(isend.ge.2) call wrtsq(jodf,jform,numq,names,qbuf) - if((isend.eq.1).or.(isend.eq.3)) - & call wrtsq(jof,jform,numq,names,qbuf) -c -c copy to ucalc if lun<0 22 Aug 00 CTM from AJD's version -c - if(lun.lt.0) then - ibgn = -lun - do 200 j = 1, numq - ucalc(ibgn+j-1) = qbuf(j) - 200 continue - endif - return - end -c -c*********************************************************************** -cryne August 5, 2004 : This is the original version of cread - subroutine cread0(kbeg,msegm,line,string,lfound) -c----------------------------------------------------------------------- -c This routine searches line(kbeg:80) for the next string; strings are -c delimited by ' ','*' or ','. -c -c Input: line character*80 input line -c kbeg integer line is only searched behind kbeg -c if a string is found, kbeg is set to -c possible start of next string -c msegm integer segment number. for msegm=1 (comment -c section), the length of a string is not -c checked. -c output:string character*10 found string -c lfound logical =.true. if a string was found -c -c Written by Rob Ryne ca 1984 -c Rewritten by Petra Schuett -c October 19, 1987 -c----------------------------------------------------------------------- - include 'impli.inc' - include 'files.inc' -c - integer kbeg - character line*80, string*10 - logical lfound -c -c look for first character of string -c - do 1 k=kbeg,80 - if( (line(k:k).ne.' ') - & .and.(line(k:k).ne.'*') - & .and.(line(k:k).ne.',')) then -c found: - lfound=.true. -c string has max 10 characters - lmax = min(k+10,80) -c look for delimiter - do 2 l=k,lmax - if( (line(l:l).eq.' ') - & .or.(line(l:l).eq.'*') - & .or.(line(l:l).eq.',')) then -c if found, string is known - string=line(k:l-1) - kbeg =l+1 -c done. - return - endif - 2 continue -c no delimiter behind string found... - string=line(k:lmax) -c ...end of line - if(lmax.eq.80) then - kbeg=80 -c ...or string too long (ignored for comment section) - else if (msegm.ne.1) then - write(jof,99) kbeg,line - 99 format(' ---> warning from cread0:'/ - & ' the following line has a very long string at ', - & 'position ',i2,' :'/' ',a80) - kbeg=lmax+1 - endif -c ...anyway, its done. - return - endif - 1 continue -c No string was found after all. - lfound=.false. - return - end -c -c*********************************************************************** -cryne August 5, 2004 : This is the original version of cnumb - subroutine cnumb0(string,num,lnum) -c----------------------------------------------------------------------- -c This routine finds out, whether string codes an integer number. -c if so, it converts it to num -c -c Input: string character*10 input string -c Output:num integer correspondent number -c lnum logical =.true. if string is a number -c -c Author: Petra Schuett -c October 19, 1987 -c----------------------------------------------------------------------- - include 'impli.inc' - include 'files.inc' -c - integer num - character string*10 - logical lnum -c - character*10 digits - save digits - data digits /'0123456789'/ -c----------------- -c The first char may be minus or digit -c write(jodf,*)'cnumb0: string= ',string - if(index(digits,string(1:1)).eq.0 .and. string(1:1).ne.'-') then - lnum=.false. -c write(jodf,*)'first char is no digit' - return - endif -c All other characters must be digits... - do 1 k=2,10 - if(index(digits,string(k:k)).eq.0) then -c ...or trailing blanks - if(string(k:10).ne.' ') then -c write(jodf,*)'string(',k,':10) is not blank' - lnum=.false. - return - else - goto 11 - endif - endif - 1 continue -c string is a number - 11 read(string,*,err=999) num - lnum=.true. - return -c----------------- -c error exit - 999 write(jof ,99) string - write(jodf,99) string - 99 format(' ---> error in cnumb0: string ',a10,' could not be', - &' converted to number') - call myexit - end -c diff --git a/OpticsJan2020/MLI_light_optics/Src/pure.f b/OpticsJan2020/MLI_light_optics/Src/pure.f deleted file mode 100755 index f6a3258..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/pure.f +++ /dev/null @@ -1,576 +0,0 @@ -*********************************************************************** -* header PURIFYING (PURE) ROUTINES * -* Routines for computing conjugacy classes * -*********************************************************************** -* - subroutine da2(fm,a2a,a2m) -c this is a subroutine that generates the matrix a2m -c that brings fm to block form in the dynamic case -c Written by Alex Dragt, Spring 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fm(6,6),a2a(monoms),a2m(6,6) - dimension reval(6),aieval(6) - dimension revec(6,6),aievec(6,6) -c clear the array a2a - do 10 i=1,monoms - 10 a2a(i)=0. -c compute the eigenvectors of fm - call eig6(fm,reval,aieval,revec,aievec) -c sort these eigenvectors - call dvsort(revec,aievec) -c compute a2m from these eigenvectors - do 20 i=1,6 - a2m(i,1)=revec(1,i) - a2m(i,2)=aievec(1,i) - a2m(i,3)=revec(3,i) - a2m(i,4)=aievec(3,i) - a2m(i,5)=revec(5,i) - a2m(i,6)=aievec(5,i) - 20 continue -c rephase the result - call drphse(a2m) - return - end -c -*********************************************************************** -c - subroutine dpur2(fa,fm,ga,gm,ta,tm) -c this is a subroutine for purifying the f2 (matrix) -c part of a dynamic map. -c fa,fm is the original map, and it is left unchanged. -c ga,gm is the purified map. -c ta,tm is the transforming map. that is g=t*f*(t inverse). -c Written by Alex Dragt, Spring 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms),ta(monoms) - dimension fm(6,6),gm(6,6),tm(6,6) -c find the map a2: - call da2(fm,ta,tm) -c go to floquet variables: - call sndwch(ta,tm,fa,fm,ga,gm) - return - end -c -******************************************************************** -c - subroutine dpur3(fa,fm,ga,gm,ta,tm) -c this is a subroutine for purifying the f3 -c part of a dynamic map. -c fa,fm is the original map, and it is left unchanged. -c ga,gm is the purified map, and ta,tm is the purifying transformation. -c that is, g=t*f*(t inverse). -c Written by Alex Dragt, Spring 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms),ta(monoms) - dimension fm(6,6),gm(6,6),tm(6,6) - ibrief = 1 - detmin = 1.d-12 - min=28 - max=83 - call gdpur(fa,fm,ga,gm,ta,tm,min,max,ibrief,detmin) - return - end -c -****************************************************** -c - subroutine dpur4(fa,fm,ga,gm,ta,tm) -c this is a subroutine for purifying the f4 -c part of a dynamic map. -c fa,fm is the original map, and it is left unchanged. -c ga,gm is the purified map, and ta,tm is the purifying transformation. -c that is, g=t*f*(t inverse). -c Written by Alex Dragt, Spring 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms),ta(monoms) - dimension fm(6,6),gm(6,6),tm(6,6) - ibrief = 1 - detmin = 1.d-12 - min=90 - max=208 - call gdpur(fa,fm,ga,gm,ta,tm,min,max,ibrief,detmin) - return - end -c -************************************************************ -c - subroutine fxpt(fa,fm,ana,anm,ta,tm) -c This is a subroutine for finding the fixed point of a map. -c The initial map is given by fa and fm. It is unchanged by the -c subroutine. The map about the closed orbit corresponding to -c the fixed point is given by ana and anm. The transformation -c to the fixed point is given by the map ta,tm. -c Written by Alex Dragt, 11 October 1985. - use parallel, only : idproc - implicit double precision (a-h,o-z) - dimension fa(923),fm(6,6) - dimension ana(923),anm(6,6) - dimension ta(923),tm(6,6) - dimension tta(923),ttm(6,6) - dimension tempa(923),tempm(6,6) - dimension am(4,4),av(4),alphv(4),augm(4,5) -c Computation of an1: -c Set up am = 4x4 block of fm-i: - do 10 i=1,4 - do 10 j=1,4 - am(i,j)=fm(i,j) - if(i.eq.j) am(i,j)=am(i,j)-1.d0 - 10 continue -c Set up av: - do 20 i=1,4 - 20 av(i)=fm(i,6) -c Compute alphv: - call leshs(alphv,4,am,av,augm,det) -c Write out message about determinant: -cryne Jan 3, 2005 added ".lt. 1.d-3" to only print det if it is small - if(idproc.eq.0 .and. det.lt.1.d-3)write(6,600) det - 600 format(1x,'det in fxpt is',e15.4) -c Compute t1: - call ident(ta,tm) - do 30 i=1,4 - 30 tm(i,6)=-alphv(i) - tm(5,1)=alphv(2) - tm(5,2)=-alphv(1) - tm(5,3)=alphv(4) - tm(5,4)=-alphv(3) -c Store t1 - call mapmap(ta,tm,tta,ttm) -c Compute t1*m*t1inv where m is initial map: - call sndwch(ta,tm,fa,fm,ana,anm) -c call mycat(6,ta,tm,fa,fm,tempa,tempm) -c call inv(ta,tm) -c call mycat(6,tempa,tempm,ta,tm,ana,anm) -c Computation of an2: -c Set up am: - call mapmap(ana,anm,tempa,tempm) - call inv(tempa,tempm) - do 40 i=1,4 - do 40 j=1,4 - am(i,j)=tempm(j,i) - if(i.eq.j) am(i,j)=am(i,j)-1.d0 - 40 continue -c Set up av: - av(1)=-ana(48) - av(2)=-ana(63) - av(3)=-ana(73) - av(4)=-ana(79) -c Compute alphv: - call leshs(alphv,4,am,av,augm,det) -c Compute t2: - call ident(ta,tm) - ta(48)=alphv(1) - ta(63)=alphv(2) - ta(73)=alphv(3) - ta(79)=alphv(4) -c Compute and store t2*t1 -c call mycat(6,ta,tm,tta,ttm,tempa,tempm) -cryne 8/16/02 call concat(6,ta,tm,tta,ttm,tempa,tempm) - call concat(ta,tm,tta,ttm,tempa,tempm) - call mapmap(tempa,tempm,tta,ttm) -c Compute t2*an1*t2inv: - call sndwch(ta,tm,ana,anm,ana,anm) -c call mycat(6,ta,tm,ana,anm,tempa,tempm) -c call inv(ta,tm) -c call mycat(6,tempa,tempm,ta,tm,ana,anm) -c Computation of an3: -c The matrix am is unchanged from the previous step. -c Set up av: - av(1)=-ana(139) - av(2)=-ana(174) - av(3)=-ana(194) - av(4)=-ana(204) -c Compute alphv: - call leshs(alphv,4,am,av,augm,det) -c Compute t3: - call ident(ta,tm) - ta(139)=alphv(1) - ta(174)=alphv(2) - ta(194)=alphv(3) - ta(204)=alphv(4) -c Compute and store t3*t2*t1: -c call mycat(6,ta,tm,tta,ttm,tempa,tempm) -cryne 8/16/02 call concat(6,ta,tm,tta,ttm,tempa,tempm) - call concat(ta,tm,tta,ttm,tempa,tempm) - call mapmap(tempa,tempm,tta,ttm) -c Compute t3*an2*t3inv: - call sndwch(ta,tm,ana,anm,ana,anm) -c call mycat(6,ta,tm,ana,anm,tempa,tempm) -c call inv(ta,tm) -c call mycat(6,tempa,tempm,ta,tm,ana,anm) -c Computation of an4: -c The matrix am is the same for all orders. -c Set up av: - av(1)=-ana(335) - av(2)=-ana(405) - av(3)=-ana(440) - av(4)=-ana(455) -c Compute alphv: - call leshs(alphv,4,am,av,augm,det) -c Compute t4: - call ident(ta,tm) - ta(335)=alphv(1) - ta(405)=alphv(2) - ta(440)=alphv(3) - ta(455)=alphv(4) -c Compute and store t4*t3*t2*t1: -c call mycat(6,ta,tm,tta,ttm,tempa,tempm) -cryne 8/16/02 call concat(6,ta,tm,tta,ttm,tempa,tempm) - call concat(ta,tm,tta,ttm,tempa,tempm) - call mapmap(tempa,tempm,tta,ttm) -c Compute t4*an3*t4inv: - call sndwch(ta,tm,ana,anm,ana,anm) -c Computation of an5: -c Set up av: - av(1)=-ana(713) - av(2)=-ana(839) - av(3)=-ana(895) - av(4)=-ana(916) -c Compute alphv: - call leshs(alphv,4,am,av,augm,det) -c Compute t5: - call ident(ta,tm) - ta(713)=alphv(1) - ta(839)=alphv(2) - ta(895)=alphv(3) - ta(916)=alphv(4) -c Compute and store t5*t4*t3*t2*t1: -c call mycat(6,ta,tm,tta,ttm,tempa,tempm) -cryne 8/16/02 call concat(6,ta,tm,tta,ttm,tempa,tempm) - call concat(ta,tm,tta,ttm,tempa,tempm) - call mapmap(tempa,tempm,tta,ttm) -c Compute an5 = t5*an4*t5inv: - call sndwch(ta,tm,ana,anm,ana,anm) -c Store t5*t4*t3*t2*t1 in t: - call mapmap(tta,ttm,ta,tm) - return - end -c -*********************************************************************** -c - subroutine gdpur(fa,fm,ga,gm,ta,tm,min,max, - & ibrief,detmin) -c This is a generic purifying routine for the -c dynamic resonance case -c fa,fm is the original map, which is left unchanged. -c ga,gm is the purified map, and ta,tm is the purifying -c transformation, that is g=t*f*(t inverse) -c min and max are the minimum and maximum index -c of the monomials to be purified -c Written by Alex Dragt and F. Neri, Spring 1986 - use parallel, only : idproc - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(*),ga(*),ta(*),t1a(monoms),t2a(monoms) - dimension fm(6,6),gm(6,6),tm(6,6),t1m(6,6),t2m(6,6) - dimension ax(-4:4),bx(-4:4),ay(-4:4),by(-4:4),at(-4:4),bt(-4:4) - include 'dr.inc' -c -c Set up multiple angle arrays - cwx = fm(1,1) - swx = fm(1,2) - cwy = fm(3,3) - swy = fm(3,4) - cwt = fm(5,5) - swt = fm(5,6) - ax(0)=1.d0 - bx(0)=0.d0 - ay(0)=1.d0 - by(0)=0.d0 - at(0)=1.d0 - bt(0)=0.d0 - ax(1)=cwx - bx(1)=swx - ay(1)=cwy - by(1)=swy - at(1)=cwt - bt(1)=swt -c - do 10 n=2,4 - ax(n)=ax(1)*ax(n-1)-bx(1)*bx(n-1) - bx(n)=bx(1)*ax(n-1)+ax(1)*bx(n-1) - 10 continue -c - do 20 n=2,4 - ay(n)=ay(1)*ay(n-1)-by(1)*by(n-1) - by(n)=by(1)*ay(n-1)+ay(1)*by(n-1) - 20 continue -c - do 30 n=2,4 - at(n)=at(1)*at(n-1)-bt(1)*bt(n-1) - bt(n)=bt(1)*at(n-1)+at(1)*bt(n-1) - 30 continue -c - do 40 n=1,4 - ax(-n)=ax(n) - bx(-n)=-bx(n) - ay(-n)=ay(n) - by(-n)=-by(n) - at(-n)=at(n) - bt(-n)=-bt(n) - 40 continue -c -c Resonance decompose map: - call ctodr(fa,t1a) -c -c Set up map to remove offensive terms of index min->max: - call ident(t2a,t2m) - do 100 k=min,max - if (drexp(0,k).ne.0) then -c compute cth=cos(theta) and sth=sin(theta) for -c theta = drexp(1,k)*wx + drexp(2,k)*wy + drexp(3,k)*wt - nx=drexp(1,k) - ny=drexp(2,k) - nt=drexp(3,k) - axnx=ax(nx) - bxnx=bx(nx) - ayny=ay(ny) - byny=by(ny) - atnt=at(nt) - btnt=bt(nt) - cth=(axnx*ayny-bxnx*byny)*atnt-(axnx*byny+bxnx*ayny)*btnt - sth=(axnx*ayny-bxnx*byny)*btnt+(axnx*byny+bxnx*ayny)*atnt -c -c Carry out rest of calculation - det = 2.d0 * (1.d0 - cth) - k1 = k - k2 = k+1 - if ( ibrief.ne.1 ) then - if(idproc.eq.0) - & write(6,*) ' Det in subspace',k1,',',k2,' is',det - endif - if ( dabs(det) .gt. detmin) then - t2a(k1) = ((1.-cth)*t1a(k1) + sth*t1a(k2))/det - t2a(k2) = ((1.-cth)*t1a(k2) - sth*t1a(k1))/det - else - if(idproc.eq.0) - & write(6,*) ' Det(',k1,',',k2,') =',det,' not removed' - endif - endif - 100 continue -c transfom map t2 to cartesian basis; the result is the map t: - call ident(ta,tm) - call drtoc(t2a,ta) -c remove offensive terms ( min->max ) - call sndwch(ta,tm,fa,fm,ga,gm) - return - end -c -************************************************************************ -c - subroutine gspur(fa,fm,ga,gm,ta,tm,min,max, - & ibrief,detmin) -c This is a generic purifying routine for the -c static resonance case -c fa,fm is the original map, which is left unchanged. -c ga,gm is the purified map, and ta,tm is the purifying -c transformation, that is g=t*f*(t inverse) -c min and max are the minimum and maximum index -c of the monomials to be purified -c Written by Alex Dragt and F. Neri, Spring 1986 - use parallel, only : idproc - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(*),ga(*),ta(*),t1a(monoms),t2a(monoms) - dimension fm(6,6),gm(6,6),tm(6,6),t1m(6,6),t2m(6,6) - dimension ax(-4:4),bx(-4:4),ay(-4:4),by(-4:4) - include 'sr.inc' -c -c Set up multiple angle arrays - cwx = fm(1,1) - swx = fm(1,2) - cwy = fm(3,3) - swy = fm(3,4) - ax(0)=1.d0 - bx(0)=0.d0 - ay(0)=1.d0 - by(0)=0.d0 - ax(1)=cwx - bx(1)=swx - ay(1)=cwy - by(1)=swy -c - do 10 n=2,4 - ax(n)=ax(1)*ax(n-1)-bx(1)*bx(n-1) - bx(n)=bx(1)*ax(n-1)+ax(1)*bx(n-1) - 10 continue -c - do 20 n=2,4 - ay(n)=ay(1)*ay(n-1)-by(1)*by(n-1) - by(n)=by(1)*ay(n-1)+ay(1)*by(n-1) - 20 continue -c - do 30 n=1,4 - ax(-n)=ax(n) - bx(-n)=-bx(n) - ay(-n)=ay(n) - by(-n)=-by(n) - 30 continue -c -c Resonance decompose map: - call ctosr(fa,t1a) -c -c Set up map to remove offensive terms of index min->max: - call ident(t2a,t2m) - do 100 k=min,max - if (srexp(0,k).ne.0) then -c compute cth =cos(theta) and sth=sin(theta) for -c theta = srexp(1,k)*wx + srexp(2,k)*wy - nx=srexp(1,k) - ny=srexp(2,k) - axnx=ax(nx) - bxnx=bx(nx) - ayny=ay(ny) - byny=by(ny) - cth=axnx*ayny-bxnx*byny - sth=bxnx*ayny+axnx*byny -c -c Carry out rest of calculation - det = 2.d0 * (1.d0 - cth) - k1 = k - k2 = k+1 - if ( ibrief.ne.1 ) then - if(idproc.eq.0) - & write(6,*) ' Det in subspace',k1,',',k2,' is',det - endif - if ( dabs(det) .gt. detmin) then - t2a(k1) = ((1.-cth)*t1a(k1) + sth*t1a(k2))/det - t2a(k2) = ((1.-cth)*t1a(k2) - sth*t1a(k1))/det - else - if(idproc.eq.0) - & write(6,*) ' Det(',k1,',',k2,') =',det,' not removed' - endif - endif - 100 continue -c transform map to cartesian basis; the result is the map t: - call ident(ta,tm) - call srtoc(t2a,ta) -c remove offensive terms ( min->max ) - call sndwch(ta,tm,fa,fm,ga,gm) - return - end -c -************************************************************* -c - subroutine sa2(fm,a2a,a2m) -c this is a subroutine that generates the matrix a2m -c that brings fm to block form in the static case -c Written by Alex Dragt, Spring 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fm(6,6),a2a(monoms),a2m(6,6) - dimension reval(6),aieval(6) - dimension revec(6,6),aievec(6,6) -c clear the array a2a - do 10 i=1,monoms - 10 a2a(i)=0. -c compute the eigenvectors of fm - call eig4(fm,reval,aieval,revec,aievec) -c sort these eigenvectors - call svsort(revec,aievec) -c compute a2m from these eigenvectors - do 20 i=1,6 - a2m(i,1)=revec(1,i) - a2m(i,2)=aievec(1,i) - a2m(i,3)=revec(3,i) - a2m(i,4)=aievec(3,i) - a2m(i,5)=revec(5,i) - a2m(i,6)=revec(6,i) - 20 continue -c rephase the result - call srphse(a2m) - return - end -c -*********************************************************************** -c - subroutine scpur3(fa,fm,ga,gm,ta,tm) -c this is a subroutine for purifying the chromatic f3 -c part of a static map. -c fa,fm is the original map, and it is left unchanged. -c ga,gm is the purified map, and ta,tm is the purifying transformation. -c that is, g=t*f*(t inverse). -c Written by Alex Dragt, Spring 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms),ta(monoms) - dimension fm(6,6),gm(6,6),tm(6,6) - ibrief = 1 - detmin = 1.d-12 - min=31 - max=42 - call gspur(fa,fm,ga,gm,ta,tm,min,max,ibrief,detmin) - return - end -c -************************************************** -c - subroutine sgpur3(fa,fm,ga,gm,ta,tm) -c this is a subroutine for purifying the geometric f3 -c part of a static map. -c fa,fm is the original map, and it is left unchanged. -c ga,gm is the purified map, and ta,tm is the purifying transformation. -c that is, g=t*f*(t inverse). -c Written by Alex Dragt, Spring 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms),ta(monoms) - dimension fm(6,6),gm(6,6),tm(6,6) - ibrief = 1 - detmin = 1.d-12 - min=43 - max=62 - call gspur(fa,fm,ga,gm,ta,tm,min,max,ibrief,detmin) - return - end -c -****************************************************** -c - subroutine spur2(fa,fm,ga,gm,ta,tm,t2m) -c this is a subroutine for purifying the f2 (matrix) -c part of a static map. -c fa,fm is the original map, and it is left unchanged. -c ga,gm is the purified map. -c ta,tm is the transforming map. that is g=t*f*(t inverse). -c the matrix t2m associated with a2 is also returned. -c Written by Alex Dragt, Spring 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms),ta(monoms),t1a(monoms),t2a(monoms) - dimension fm(6,6),gm(6,6),tm(6,6),t1m(6,6),t2m(6,6) -c go to the off momentum closed orbit: - call fxpt(fa,fm,ta,tm,t1a,t1m) -c find the map a2: - call sa2(tm,t2a,t2m) -c go to floquet variables: - call sndwch(t2a,t2m,ta,tm,ga,gm) -c accumulate transforming map: - call concat(t2a,t2m,t1a,t1m,ta,tm) - return - end -c -******************************************************************** -c -c - subroutine spur4(fa,fm,ga,gm,ta,tm) -c this is a subroutine for purifying the f4 -c part of a static map. -c fa,fm is the original map, and it is left unchanged. -c ga,gm is the purified map, and ta,tm is the purifying transformation. -c that is, g=t*f*(t inverse). -c Written by Alex Dragt, Spring 1986 - use lieaparam, only : monoms - include 'impli.inc' - dimension fa(monoms),ga(monoms),ta(monoms) - dimension fm(6,6),gm(6,6),tm(6,6) - ibrief = 1 - detmin = 1.d-12 - min=90 - max=153 - call gspur(fa,fm,ga,gm,ta,tm,min,max,ibrief,detmin) - return - end -c -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/rfgap.f b/OpticsJan2020/MLI_light_optics/Src/rfgap.f deleted file mode 100755 index fbedc2c..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/rfgap.f +++ /dev/null @@ -1,809 +0,0 @@ -c IMPACT RF Gap routines -c Copyright 2001 University of California -c - subroutine rfgap(zedge,zmap,nstep,rffreq,escale,theta0, & - &t00,gam00,itype,h,mh) -cryne use Dataclass -c h(28-209) = 2nd order and 3rd order map, mh(6,6)=transfer matrix - use parallel, only : idproc - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' -cryne include 'para.inc' - include 'map.inc' -ctm include 'arcblk.inc' - include 'usrdat.inc' - double precision zedge,zmap,rffreq,escale,theta0 - integer nstep,itype,npusr - double precision h(monoms),mh(6,6) - common/rfcdata/zdat(20500),edat(20500),epdat(20500),Nsize -! write(6,*)'(rfgap) ref(6),brho=',reftraj(6),brho -! nonlinear map for rf gap not implemented yet - do 10 i=1,monoms - h(i)=0. - 10 continue -!!!!!!!!!!!!! fix these hardwired values later: -! qmcc=1./938.28e6 -cryne 7/21/02 qmcc=1./939.294308e6 - qmcc=1.d0/pmass -c - xl=sl - xk=1./xl - ww=rffreq/(c/xl) -c write(6,*) "==> ww = ",ww -c g0 is the quadrupole gradient, assumed to be zero -c (combined rfgap+quad will be implemented later if requested) - g0=0. -c - if(zmap.lt.0.)then - write(6,*)'error(rfgap): zmap cannot be < 0 in this version' - endif - tau=zmap -c - engin=gam00*pmass -c ucalc(11)=engin - if(idproc.eq.0)write(36,*)arclen,engin - call myflush(36) - call mapgap(mh,arclen,tau,nstep,qmcc,xk,xl,ww,zedge, & - & escale,theta0,g0,t00,gam00,itype) -! update brho, beta, and gamma: -cryne 5/1/2006 No. don't update here. Moved to routine lmnt in afro.f -! engfin=gam00*pmass -cryne-abell Mon Nov 24 18:39:30 PST 2003 -! ucalc(12)=engfin - return - end - - subroutine mapgap(xm,t,tau,mapstp,qmcc,xk,xl,ww,zedge,escale, & - & theta0,g0,t00,gam00,itype) -! Compute the linear map for an rf gap + quadrupole -! 2 design orbit eqns + 12 matrix coeffs = 14 eqns -! all the following arrays are serial arrays: -cryne== implicit none - include 'impli.inc' -cryne== - dimension xm(6,6), y(14) -ctm integer, intent(in) :: mapstp,itype -ctm double precision, intent(in) :: t,tau,qmcc,xk,xl,ww,zedge, & -ctm & escale,theta0,g0 -ctm double precision, intent(inout) :: t00,gam00 -ctm double precision, dimension(6,6), intent(out) :: xm -ctm double precision, dimension(14) :: y -ctm double precision :: h,t0,gi,betai,ui,squi,sqi3,ein,e1in,e2in, & -ctm & sinthi -ctm double precision :: costhi,uprimi,qpwi,dlti,thli,gf,betaf,uf, & -ctm & squf,sqf3 -ctm double precision :: tfin,ef,e1f,e2f,sinthf,costhf,uprimf,qpwf, & -ctm & dltf,thlf -! xm = 0.0 - do 11 i=1,6 - do 10 j=1,6 - xm(i,j)=0.d0 - 10 continue - 11 continue -c y(1)=mpasyn(5) -c y(2)=mpasyn(6) - y(1)=t00 - y(2)=-gam00 - y(3)=1.d0 - y(4)=0.d0 - y(5)=0.d0 - y(6)=1.d0 - y(7)=1.d0 - y(8)=0.d0 - y(9)=0.d0 - y(10)=1.d0 - y(11)=1.d0 - y(12)=0.d0 - y(13)=0.d0 - y(14)=1.d0 - h=tau/mapstp - t0=t -c gi=-mpasyn(6) - gi=gam00 - betai=sqrt((gi-1.d0)*(gi+1.d0))/gi - ui=gi*betai - squi=sqrt(ui) - sqi3=sqrt(ui)**3 - call eintrp(t,ein,e1in,e2in,zedge,escale,itype,ww,theta0,y) - sinthi=sin(ww*t00+theta0) - costhi=cos(ww*t00+theta0) - uprimi=qmcc*ein/betai*costhi - qpwi=0.5d0*qmcc*xl/(ui*ww) - dlti=xl*(0.5d0*uprimi/ui-qpwi*e1in*sinthi) - thli=1.5d0*xl*(uprimi/ui) -! call rk6i(h,mapstp,t0,y,qmcc,xk,xl,ww,zedge,escale,g0, & -! & theta0,itype) - call adam11rf(h,mapstp,t0,y,qmcc,xk,xl,ww,zedge,escale,g0, & - & theta0,itype) -c mpasyn(5)=y(1) -c mpasyn(6)=y(2) -c gf=-mpasyn(6) - t00=y(1) - gam00=-y(2) - gf=gam00 - betaf=sqrt((gf-1.d0)*(gf+1.d0))/gf - uf=gf*betaf - squf=sqrt(uf) - sqf3=sqrt(uf)**3 - tfin=t+tau - call eintrp(tfin,ef,e1f,e2f,zedge,escale,itype,ww,theta0,y) - sinthf=sin(ww*t00+theta0) - costhf=cos(ww*t00+theta0) - uprimf=qmcc*ef/betaf*costhf - qpwf=0.5d0*qmcc*xl/(uf*ww) - dltf=xl*(0.5d0*uprimf/uf-qpwf*e1f*sinthf) - thlf=1.5d0*xl*(uprimf/uf) - xm(1,1)= y(3)*squi/squf+y(5)*squi/squf*dlti - xm(2,1)=(y(4)-y(3)*dltf)*squi*squf+(y(6)-y(5)*dltf)*squi*squf* & - & dlti - xm(1,2)= y(5)/(squi*squf) - xm(2,2)=(y(6)-y(5)*dltf)*squf/squi - xm(3,3)= y(7)*squi/squf+y(9)*squi/squf*dlti - xm(4,3)= & - & (y(8)-y(7)*dltf)*squi*squf+(y(10)-y(9)*dltf)*squi*squf*dlti - xm(3,4)= y(9)/(squi*squf) - xm(4,4)=(y(10)-y(9)*dltf)*squf/squi - xm(5,5)= y(11)*sqi3/sqf3+y(13)*sqi3/sqf3*thli - xm(6,5)= & - & (y(12)-y(11)*thlf)*sqi3*sqf3+(y(14)-y(13)*thlf)*sqi3*sqf3*thli - xm(5,6)= y(13)/(sqi3*sqf3) - xm(6,6)=(y(14)-y(13)*thlf)*sqf3/sqi3 - - end !subroutine mapgap -! - subroutine eintrp(z,ez1,ezp1,ezpp1,zedge,escale,itype,ww,theta0,y) - use parallel - use beamdata, only : pmass - include 'impli.inc' - include 'fitbuf.inc' - dimension y(14) - common/rfcdata/zdat(20500),edat(20500),epdat(20500),Nsize -! if(itype.eq.0 .or. itype.eq.1)then -! ez1=0. -! ezp1=0. -! ezpp1=0. -! goto 1000 -! endif - zz=z-zedge - checklo=zz-zdat(1) - checkhi=zdat(Nsize)-zz - eps=1.d-10 - if(checklo.lt.0.d0)then - if(abs(checklo).lt.eps)then - zz=zdat(1) - else - if(idproc.eq.0)then - write(6,*)'interpolation error in routine eintrp' - write(6,*)'zz,zdat(1)=',zz,zdat(1) - endif - call myexit - endif - endif - if(checkhi.lt.0.d0)then - if(abs(checkhi).lt.eps)then - zz=zdat(Nsize) - else - if(idproc.eq.0)then - write(6,*)'interpolation error in routine eintrp' - write(6,*)'zz,zdat(Nsize)=',zz,zdat(Nsize) - endif - call myexit - endif - endif -!============================ - klo=1 - khi=Nsize - 1 if (khi-klo.gt.1)then - k=(khi+klo)/2 - if(zdat(k).gt.zz)then - khi=k - else - klo=k - endif - goto 1 - endif - h=zdat(khi)-zdat(klo) - if(h.eq.0.)then - write(6,*)'bad data in routine eintrp' - call myexit - endif -!============================ -!start linear interpolation. - slope1=(edat(khi)-edat(klo))/h - ez1 =edat(klo)+slope1*(zz-zdat(klo)) - slope2=(epdat(khi)-epdat(klo))/h - ezp1=epdat(klo)+slope2*(zz-zdat(klo)) - ez1=ez1*escale - ezp1=ezp1*escale - ezpp1=0. -cryne -cryne if(idproc.eq.0) then -ccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c modification to only write when fitting has converged: - 1000 continue -cryne 5/9/2006 write(42,*) z,ez1,ezp1,klo,khi,min(zz-zdat(klo),zdat(khi)-zz) -c if(kfit.eq.1 .and. idproc.eq.0)then - if(idproc.eq.0)then -cccc write(49,101)z,zz,y(1),(-y(2)-1.)*pmass,ez1,ezp1,1.0*m -cccc call myflush(49) - m=klo -c if(m.eq.435 .or. m.eq.920)then - if( m.gt.1 .and. m.lt.Nsize)then -c if( (edat(m-1).lt.edat(m)).and.(edat(m+1).lt.edat(m)) )then - if( ((edat(m-1).lt.edat(m)).and.(edat(m+1).lt.edat(m))).or. & - & ((edat(m-1).gt.edat(m)).and.(edat(m+1).gt.edat(m))) )then - twopi=4.*asin(1.0d0) - phasprnt=360./twopi*mod(ww*y(1)+theta0,twopi) - if(phasprnt.lt.10.)phasprnt=phasprnt+360. - prxrad=360./twopi*(ww*y(1)+theta0) - preng=(-y(2)-1.)*939.294308 - write(59,101)z,1.0*m,phasprnt,prxrad,theta0*360./twopi,preng - call myflush(59) - endif - endif - endif -ccccccccccccccccccccccccccccccccccccccccccccccccccccccc -cryne endif - 101 format(7(1x,1pe12.5)) - return - end !subroutine eintrp - - double precision function func1(x,pi52) -cryne== implicit none - include 'impli.inc' -cryne== -ctm double precision, intent(in) :: x, pi52 - - func1 = exp(-(4.*x)**4)*cos(pi52*tanh(5.*x)) - - end !function func1 -c************************************************************ - double precision function func2(x,pi52) -cryne== implicit none - include 'impli.inc' -cryne== -ctm double precision, intent(in) :: x, pi52 - - func2=-5.*pi52*exp(-(4.*x)**4)*sin(pi52*tanh(5.*x))/ & - & cosh(5.*x)**2-16.*(4.*x)**3*exp(-(4.*x)**4)*cos(pi52*tanh(5.*x)) - - end !function func2 - -c*********************************************** - subroutine rk6i(h,ns,t,y,qmcc,xk,xl,ww,zedge,escale,g0, & - & theta0,itype) -cryne== implicit none - include 'impli.inc' -cryne== -ctm integer, intent(in) :: ns,itype -ctm double precision, intent(in) :: qmcc,xk,xl,ww,zedge,escale, & -ctm & g0,theta0 -ctm double precision, intent(inout) :: t -ctm double precision, intent(in) :: h -ctm double precision, dimension(14), intent(inout) :: y -ctm double precision, dimension(14) :: yt,a,b,c,d,e,f,g,o,p -ctm double precision:: tint,tt,blg -ctm integer :: i - dimension y(14),yt(14),a(14),b(14),c(14),d(14),e(14),f(14), & - & g(14),o(14),p(14) - blg=0. - tint=t - do i=1,ns - call evalrf(t,y,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 10 j=1,14 - a(j)=h*f(j) - yt(j)=y(j)+a(j)/9.d0 - 10 continue - tt=t+h/9.d0 - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 20 j=1,14 - b(j)=h*f(j) - yt(j)=y(j) + (a(j) + 3.d0*b(j))/24.d0 - 20 continue - tt=t+h/6.d0 - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 30 j=1,14 - c(j)=h*f(j) - yt(j)=y(j)+(a(j)-3.d0*b(j)+4.d0*c(j))/6.d0 - 30 continue - tt=t+h/3.d0 - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 40 j=1,14 - d(j)=h*f(j) - yt(j)=y(j) + & - &(278.d0*a(j) - 945.d0*b(j) + 840.d0*c(j) + 99.d0*d(j))/544.d0 - 40 continue - tt=t+.5d0*h - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 50 j=1,14 - e(j)=h*f(j) - yt(j)=y(j) + & - &(-106.d0*a(j)+273.d0*b(j)-104.d0*c(j)-107.d0*d(j)+48.d0*e(j))/6.d0 - 50 continue - tt = t+2.d0*h/3.d0 - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 60 j=1,14 - g(j)=h*f(j) - yt(j) = y(j)+(110974.d0*a(j)-236799.d0*b(j)+68376.d0*c(j)+ & - & 103803.d0*d(j)-10240.d0*e(j) + 1926.d0*g(j))/45648.d0 - 60 continue - tt = t + 5.d0*h/6.d0 - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 70 j=1,14 - o(j)=h*f(j) - yt(j) = y(j)+(-101195.d0*a(j)+222534.d0*b(j)-71988.d0*c(j)- & - & 26109.d0*d(j)-2.d4*e(j)-72.d0*g(j)+22824.d0*o(j))/25994.d0 - 70 continue - tt = t + h - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 80 j=1,14 - p(j)=h*f(j) - y(j) = y(j)+(41.d0*a(j)+216.d0*c(j)+27.d0*d(j)+ & - & 272.d0*e(j)+27.d0*g(j)+216.d0*o(j)+41.d0*p(j))/840.d0 - 80 continue - t=tint+i*h -crynedabell -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2) -cryne 5/9/2006 call myflush(41) -crynedabell -! write(20,101)t,y(1),(-y(2)-1.0)*938.28 -cryne write(20,101)t,y(1),(-y(2)-1.0)*939.294308 - 101 format(3(1pe12.5,1x)) -cryne write(21,102)t,y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11), & -cryne& y(12) - 102 format(11(1pe12.5,1x)) - enddo - end !subroutine rk6i -c******************************************************************** - subroutine evalrf(t,y,f,qmcc,xk,xl,ww,zedge,blg,escale,g0, & - & theta0,itype) - use beamdata, only : pmass -cryne== implicit none - include 'impli.inc' -cryne== -ctm integer, intent(in) :: itype -ctm double precision, intent(in) :: t,qmcc,xk,xl,ww,zedge,blg, & -ctm & escale,g0,theta0 -ctm double precision, dimension(14), intent(in) :: y -ctm double precision, dimension(14), intent(out) :: f -ctm double precision :: clite,ez1,ezp1,ezpp1,gamma0,beta0, & -ctm & gbet,sinphi,cosphi -ctm double precision :: rfdsgn,pmass,brho,s11tmp,s11,s33,s55 -cryne 7/21/02 -c - dimension f(14), y(14) - clite=299792458.d0 - call eintrp(t,ez1,ezp1,ezpp1,zedge,escale,itype,ww,theta0,y) -! synchronous particle: - gamma0=-y(2) - beta0=sqrt((gamma0-1.d0)*(gamma0+1.d0))/gamma0 - gbet=beta0*gamma0 - sinphi=sin(ww*y(1)+theta0) - cosphi=cos(ww*y(1)+theta0) - rfdsgn=ez1*cosphi - f(1)=xk/beta0 - f(2)=-qmcc*rfdsgn -cryneabell:09.Nov.05 -cryne 5/9/2006 write(44,*) t,ww*y(1)+theta0,ez1,ezp1 -cryneabell---------- -! matrix elements -! pmass=938.28d6 -! mistaken comment was here previously; now set to H- mass Sept 5, 2000 -! pmass=939.294308d6 -!!!************************************************************************ -!!!cryne 11/06/2003 eventually this should be fixed to use pmass in common** -! pmass=938.27231d6 -!!!************************************************************************ -!!!************************************************************************ -! put a negative sign here for H-. -! brho=-gbet/clite*pmass - brho=gbet/clite*pmass - s11tmp=0.5d0*(1.d0+0.5d0*gamma0**2)* & - & (qmcc*rfdsgn/beta0**2/gamma0**2)**2 + & - & qmcc*xk*ww*0.5d0/beta0**3/gamma0**3*ez1*sinphi -! qmcc*xk*0.5d0/beta0**3/gamma0**3*ez1*sinphi - s11=(s11tmp+g0/brho)*xl - s33=(s11tmp-g0/brho)*xl - s55= & - & -1.5d0*qmcc/beta0**2/gamma0*ezp1*cosphi & - & +(beta0**2+0.5d0)/beta0**3/gamma0*qmcc*xk*ww*ez1*sinphi & - & +1.5d0*(1.d0-0.5d0*gamma0**2)* & - & (qmcc*rfdsgn/beta0**2/gamma0**2)**2 -! +(beta0**2+0.5d0)/beta0**3/gamma0*qmcc*xk*ez1*sinphi - s55=xl*s55 - f(3)=y(4)/xl - f(4)=-s11*y(3) - f(5)=y(6)/xl - f(6)=-s11*y(5) - f(7)=y(8)/xl - f(8)=-s33*y(7) - f(9)=y(10)/xl - f(10)=-s33*y(9) - f(11)=y(12)/xl - f(12)=-s55*y(11) - f(13)=y(14)/xl - f(14)=-s55*y(13) -cryneabell---9.Nov.05 -cryne 5/9/2006 write(43,*) t,f(1)*ww,f(2)/ww,f(1:2),f(7:14) -cryneabell - end !subroutine evalrf - -c========================================================== - subroutine read_RFdata(nunit,numdata,zlen) - use parallel - include 'impli.inc' - common/rfcdata/zdat(20500),edat(20500),epdat(20500),Nsize - if(idproc.eq.0)then - numdata=0 - do i = 1, 999999 - read(nunit,*,end=999)zdat(i),edat(i),epdat(i) - numdata=numdata+1 - enddo - 999 continue -cryne note: this sets the left hand edge to zero: - zdat1=zdat(1) - do i=1,numdata - zdat(i)=zdat(i)-zdat1 - enddo -c if(idproc.eq.0)then -c write(6,*)'Done reading RF data. Closing file unit ',nunit -c endif - close(nunit) - endif - call MPI_BCAST(numdata,1,mntgr,0,lworld,ierr) - call MPI_BCAST(zdat,numdata,mreal,0,lworld,ierr) - call MPI_BCAST(edat,numdata,mreal,0,lworld,ierr) - call MPI_BCAST(epdat,numdata,mreal,0,lworld,ierr) - Nsize = numdata - zlen=zdat(numdata)-zdat(1) - return - end -************************************************************************ -c -! subroutine adam11rf(h,ns,nf,t,y,ne) - subroutine adam11rf(h,ns,t,y,qmcc,xk,xl,ww,zedge,escale,g0, & - & theta0,itype) -c Written by Rob Ryne, Spring 1986, based on a routine of Alex Dragt -c This integration routine makes local truncation errors at each -c step of order h**11. That is, it is locally correct through -c order h**10. Due to round off errors, its true precision is -c realized only when more than 64 bits are used. - use lieaparam, only : monoms - use beamdata - use phys_consts - include 'impli.inc' -c character*6 nf -cryneneriwalstrom fix later to use monoms instead of hardwire: - dimension y( 14),yp( 14),yc( 14),f1( 14),f2( 14),f3( 14),f4( 14), - & f5( 14),f6( 14),f7( 14),f8( 14),f9( 14),f10( 14),f11( 14) - dimension a(10),am(10),b(10),bm(10) -c - data (a(i),i=1,10)/57281.d0,-583435.d0,2687864.d0, - & -7394032.d0,13510082.d0,-17283646.d0,16002320.d0, - & -11271304.d0,9449717.d0,2082753.d0/ - data (b(i),i=1,10)/-2082753.d0,20884811.d0,-94307320.d0, - & 252618224.d0,-444772162.d0,538363838.d0,-454661776.d0, - & 265932680.d0,-104995189.d0,30277247.d0/ -cryne 7/23/2002 - save a,b -c -cryneabell 11/8/2005 - ne=14 -c nf='start' -cryneabell 11/8/2005 -c -cryne 1 August 2004 ne=monoms+15 -c - nsa=ns -c if (nf.eq.'cont') go to 20 -c rk start - iqt=5 - qt=float(iqt) - hqt=h/qt -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light -cryne 5/9/2006 call myflush(41) - call evalrf(t,y,f1,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) - call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & - & theta0,itype) -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light -cryne 5/9/2006 call myflush(41) - call evalrf(t,y,f2,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) - call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & - & theta0,itype) -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light -cryne 5/9/2006 call myflush(41) - call evalrf(t,y,f3,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) - call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & - & theta0,itype) -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light -cryne 5/9/2006 call myflush(41) - call evalrf(t,y,f4,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) - call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & - & theta0,itype) -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light -cryne 5/9/2006 call myflush(41) - call evalrf(t,y,f5,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) - call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & - & theta0,itype) -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light -cryne 5/9/2006 call myflush(41) - call evalrf(t,y,f6,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) - call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & - & theta0,itype) -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light -cryne 5/9/2006 call myflush(41) - call evalrf(t,y,f7,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) - call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & - & theta0,itype) -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light -cryne 5/9/2006 call myflush(41) - call evalrf(t,y,f8,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) - call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & - & theta0,itype) -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light -cryne 5/9/2006 call myflush(41) - call evalrf(t,y,f9,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0,itype) - call rk78iirf(hqt,iqt,t,y,qmcc,xk,xl,ww,zedge,blg,escale,g0, & - & theta0,itype) -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light -cryne 5/9/2006 call myflush(41) - call evalrf(t,y,f10,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - nsa=ns-9 - hdiv=h/7257600.0d+00 - do 10 i=1,10 - am(i)=hdiv*a(i) - 10 bm(i)=hdiv*b(i) - 20 tint=t - do 100 i=1,nsa - do 30 j=1,ne - yp(j)=y(j)+bm(1)*f1(j)+bm(2)*f2(j)+bm(3)*f3(j) & - &+bm(4)*f4(j)+bm(5)*f5(j)+bm(6)*f6(j)+bm(7)*f7(j) & - & +bm(8)*f8(j)+bm(9)*f9(j)+bm(10)*f10(j) - 30 continue - call evalrf(t+h,yp,f11,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 40 j=1,ne - yp(j)=y(j)+am(1)*f2(j)+am(2)*f3(j)+am(3)*f4(j)+am(4)*f5(j) & - & +am(5)*f6(j)+am(6)*f7(j)+am(7)*f8(j)+am(8)*f9(j)+am(9)*f10(j) - 40 yc(j)=yp(j)+am(10)*f11(j) - 41 call evalrf(t+h,yc,f11,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 50 j=1,ne - 50 y(j)=yp(j)+am(10)*f11(j) - do 60 j=1,ne - f1(j)=f2(j) - f2(j)=f3(j) - f3(j)=f4(j) - f4(j)=f5(j) - f5(j)=f6(j) - f6(j)=f7(j) - f7(j)=f8(j) - f8(j)=f9(j) - f9(j)=f10(j) - 60 f10(j)=f11(j) - t=tint+i*h -cryne 5/9/2006 write(41,*) t,y(1:2),-y(2),-y(2)*omegascl*sl/c_light -cryne 5/9/2006 call myflush(41) - 100 continue - return - end -c -*********************************************************************** -c -c subroutine rk78iirf(h,ns,t,y,ne) - subroutine rk78iirf(h,ns,t,y,qmcc,xk,xl,ww,zedge,blg,escale, & - & g0,theta0,itype) -c Written by Rob Ryne, Spring 1986, based on a routine of -c J. Milutinovic. -c For a reference, see page 76 of F. Ceschino and J Kuntzmann, -c Numerical Solution of Initial Value Problems, Prentice Hall 1966. -c This integration routine makes local truncation errors at each -c step of order h**7. -c That is, it is locally correct through terms of order h**6. -c Each step requires 8 function evaluations. - - use lieaparam, only : monoms - include 'impli.inc' -cryneneriwalstrom fix later to use monoms instead of hardwire: - dimension y( 14),yt( 14),f( 14),a( 14),b( 14),c( 14),d( 14), & - &e( 14),g( 14),o( 14),p( 14) -cryne 1 August 2004 ne=monoms+15 -c - ne=14 -c - tint=t - do 200 i=1,ns - call evalrf(t,y,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 10 j=1,ne - 10 a(j)=h*f(j) - do 20 j=1,ne - 20 yt(j)=y(j)+a(j)/9.d+0 - tt=t+h/9.d+0 - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 30 j=1,ne - 30 b(j)=h*f(j) - do 40 j=1,ne - 40 yt(j)=y(j) + (a(j) + 3.d+0*b(j))/24.d+0 - tt=t+h/6.d+0 - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 50 j=1,ne - 50 c(j)=h*f(j) - do 60 j=1,ne - 60 yt(j)=y(j)+(a(j)-3.d+0*b(j)+4.d+0*c(j))/6.d+0 - tt=t+h/3.d+0 - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 70 j=1,ne - 70 d(j)=h*f(j) - do 80 j=1,ne - 80 yt(j)=y(j) + (-5.d+0*a(j) + 27.d+0*b(j) - - & 24.d+0*c(j) + 6.d+0*d(j))/8.d+0 - tt=t+.5d+0*h - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 90 j=1,ne - 90 e(j)=h*f(j) - do 100 j=1,ne - 100 yt(j)=y(j) + (221.d+0*a(j) - 981.d+0*b(j) + - & 867.d+0*c(j)- 102.d+0*d(j) + e(j))/9.d+0 - tt = t+2.d+0*h/3.d+0 - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 110 j=1,ne - 110 g(j)=h*f(j) - do 120 j=1,ne - 120 yt(j) = y(j)+(-183.d+0*a(j)+678.d+0*b(j)-472.d+0*c(j)- - & 66.d+0*d(j)+80.d+0*e(j) + 3.d+0*g(j))/48.d+0 - tt = t + 5.d+0*h/6.d+0 - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 130 j=1,ne - 130 o(j)=h*f(j) - do 140 j=1,ne - 140 yt(j) = y(j)+(716.d+0*a(j)-2079.d+0*b(j)+1002.d+0*c(j)+ - & 834.d+0*d(j)-454.d+0*e(j)-9.d+0*g(j)+72.d+0*o(j))/82.d+0 - tt = t + h - call evalrf(tt,yt,f,qmcc,xk,xl,ww,zedge,blg,escale,g0,theta0, & - & itype) - do 150 j=1,ne - 150 p(j)=h*f(j) - do 160 j=1,ne - 160 y(j) = y(j)+(41.d+0*a(j)+216.d+0*c(j)+27.d+0*d(j)+ - & 272.d+0*e(j)+27.d+0*g(j)+216.d+0*o(j)+41.d+0*p(j))/840.d+0 - t=tint+i*h - 200 continue - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine multirfsetup(imap5,jmap6) - use multitrack - include 'impli.inc' - include 'map.inc' ! this contains the reftraj array (need 5 and 6) - integer imap5,jmap6 - real*8 hx,hy,hxi,hyi - integer nx,ny,i,j,n,ierror - integer imin,imax,jmin,jmax - real*8, dimension(4) :: diag,rdiag -! -! if arrays exist, make sure they have the correct size - if( allocated(tlistin) .and. & - & ((imap5.ne.imaps) .or. (jmap6.ne.jmaps)) )then - if(idproc.eq.0)write(6,*)'(rfsetup) deallocating multiarrays...' - call del_multiarrays - imaps=imap5 - jmaps=jmap6 - if(idproc.eq.0)write(6,*)'(rfsetup) ...allocating multiarrays' - call new_multiarrays - endif -! if arrays do not exist, create them: - if( .not.allocated(tlistin) )then - imaps=imap5 - jmaps=jmap6 - if(idproc.eq.0)write(6,*)'(rfsetup) allocating multiarrays' - call new_multiarrays - endif -! -! save the reference t,pt (these are changed by rfgap, so need to store them) - refentry5=reftraj(5) - refentry6=reftraj(6) -! -! Set up grid of initial t-pt values: -! Note: In theory the 5th variable should be periodic. But in most cases it -! will not fill the full 2pi. And it is not worth the hassle to deal with the -! special case that it does fill the full 2pi. So don't bother with periodic: -! -! pack the values into an array of length 4 to minimize MPI calls: - diag(1)= maxval(zblock(5,1:nraysp)) !tmax - diag(2)= maxval(zblock(6,1:nraysp)) !ptmax - diag(3)=-minval(zblock(5,1:nraysp)) !tmin - diag(4)=-minval(zblock(6,1:nraysp)) !ptmin - call MPI_ALLREDUCE(diag,rdiag,4,mreal,mpimax,lworld,ierror) - xmax= rdiag(1) - ymax =rdiag(2) - xmin=-rdiag(3) - ymin=-rdiag(4) -! -! nx, ny are just local variables (could use imaps and jmaps instead) - nx=imaps - ny=jmaps -! Note that, in the following, tlist and ptlist are *not* deviation variables, -! as can be seen from the addition of refentry5 and refentry6 in the formulas. -! The reason is that the non-deviation variables must be passed to rfgap. -! -! Compute the tlistin grid points and array inear: - if( (xmin.eq.xmax).and.(nx.gt.1) )then - if(idproc.eq.0) & - & write(6,*)'warning: phase spread is zero and imaps.ne.1' - tlistin(1:imaps)=xmin+refentry5 - inear(1:nraysp)=1 - elseif( (xmin.ne.xmax).and.(nx.gt.1) )then - hx=(xmax-xmin)/(nx-1) - hxi=1./hx - do i=1,nx - tlistin(i)=xmin+(i-1)*hx+refentry5 - enddo - do n=1,nraysp - inear(n)=nint((zblock(5,n)-xmin)*hxi)+1 !nearest grid point - enddo - else -! tlistin(1)=0.5d0*(xmin+xmax)+refentry5 - tlistin(1)=refentry5 - inear(1:nraysp)=1 - endif -! Compute the ptlistin grid points and array jnear: - if( (ymin.eq.ymax).and.(ny.gt.1) )then - if(idproc.eq.0) & - & write(6,*)'warning: energy spread is zero and jmaps.ne.1' - ptlistin(1:jmaps)=ymin+refentry6 - jnear(1:nraysp)=1 - elseif( (ymin.ne.ymax).and.(ny.gt.1) )then - hy=(ymax-ymin)/(ny-1) - hyi=1./hy - do j=1,ny - ptlistin(j)=ymin+(j-1)*hy+refentry6 - enddo - do n=1,nraysp - jnear(n)=nint((zblock(6,n)-ymin)*hyi)+1 !nearest grid point - enddo - else -! ptlistin(1)=0.5d0*(ymin+ymax)+refentry6 - ptlistin(1)=refentry6 - jnear(1:nraysp)=1 - endif -! -! compute tdelt, ptdelt arrays: - do n=1,nraysp - tdelt(n)= zblock(5,n)+refentry5- tlistin(inear(n)) - ptdelt(n)=zblock(6,n)+refentry6-ptlistin(jnear(n)) - enddo -! -! In the future, use rho56 to determine whether or not to compute a map: - rho56=0.d0 - do n=1,nraysp - rho56(inear(n),jnear(n))=rho56(inear(n),jnear(n))+1.d0 - enddo -!----- -! just for checking/debugging -! imin=minval(inear) -! imax=maxval(inear) -! jmin=minval(jnear) -! jmax=maxval(jnear) -! if(idproc.eq.0)write(6,*)'imin,imax=',imin,imax -! if(idproc.eq.0)write(6,*)'jmin,jmax=',jmin,jmax -!----- - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/setbound.f b/OpticsJan2020/MLI_light_optics/Src/setbound.f deleted file mode 100644 index 2845203..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/setbound.f +++ /dev/null @@ -1,229 +0,0 @@ - subroutine setbound(c6,msk,np,gblam,gamma,nx0,ny0,nz0,noresize, & - & nadj0) - use rays - use parallel - include 'impli.inc' - real*8 hmax - logical msk - dimension c6(6,np),msk(np) -!hpf$ distribute (*,block) :: c6 -!hpf$ align (:) with c6(*,:) :: msk - real*8 Xmin,Xmax,Ymin,Ymax,Zmin,Zmax,Hx,Hy,Hz,Hxi,Hyi,Hzi - common/GRIDSZ3D/Xmin,Xmax,Ymin,Ymax,Zmin,Zmax,Hx,Hy,Hz,Hxi,Hyi,Hzi - common/gxyzsave/xmin0,xmax0,ymin0,ymax0,zmin0,zmax0,kfixbdy,madegr - integer IDirectFieldCalc,IDensityFunction,ISolve - & ,AnagPatchSize,AnagRefRatio - common/NEWPOISSON/IDirectFieldCalc,IDensityFunction,ISolve - & ,AnagPatchSize,AnagRefRatio - integer IVerbose - common/SHOWME/IVerbose - n0min=16 - n0max=1024 - 37 continue -c if(idproc.eq.0)then -c write(6,*)'inside setbound; gamma=',gamma -c endif - call boundp3d(c6,msk,np,gblam,nx0,ny0,nz0,nadj0) -c if(idproc.eq.0)then -c write(6,*)'returned from boundp3d' -c write(6,*)'xmin,xmax=',xmin,xmax -c write(6,*)'ymin,ymax=',ymin,ymax -c write(6,*)'zmin,zmax=',zmin,zmax -c endif - -! special case for ANAG Infinite Domain Poisson solver which requires -! uniform grid spacing, only applicable in variable grid case - if( kfixbdy .NE. 1 .AND. ISolve/10 .EQ. 1 )then - ! set all h's to max and adjust the physical domain boundaries - ! without moving the center of the domain - hmax = MAX( hx,hy,hz ) - if( IVerbose .GT. 4 .AND. IdProc .EQ. 0 .AND. - & (hmax.NE.hx .OR. hmax.NE.hy .OR. hmax.NE.hz) )then - write(6,*) 'info: SETBOUND: enforcing isotropic grid spacing ' - & ,'for ANAG Poisson solver; old h[xyz] = ',hx,hy,hz - & ,', new h = ',hmax - endif - if( hx .LT. hmax )then - ! new_xmin is center minus 1/2 new X domain length - hx = hmax - xmin0 = 0.5 * ( xmax0 + xmin0 ) - 0.5 * ( hmax * (nx0-1) ) - xmax0 = xmin0 + ( hmax * (nx0-1) ) - endif - if( hy .LT. hmax )then - hy = hmax - ymin0 = 0.5 * ( ymax0 + ymin0 ) - 0.5 * ( hmax * (ny0-1) ) - ymax0 = ymin0 + ( hmax * (ny0-1) ) - endif - if( hz .LT. hmax )then - hz = hmax - zmin0 = 0.5 * ( zmax0 + zmin0 ) - 0.5 * ( hmax * (nz0-1) ) - zmax0 = zmin0 + ( hmax * (nz0-1) ) - endif - hxi = 1.0d0 / hx - hyi = 1.0d0 / hy - hzi = 1.0d0 / hz - endif - -c=================================================================== -c 12/4/2002 new code to allow for fixed grid size: - if(kfixbdy.eq.1)then -cryne 11/27/03 if(idproc.eq.0)write(6,*)'kfixbdy.eq.1' - if(xmin0.lt.xmin)then - xmin=xmin0 - else - if(idproc.eq.0)then - write(6,*)'ERROR: particle range falls outside xmin; halting.' - write(6,*)'xmin0,xmin=',xmin0,xmin - endif - call myexit - endif - if(xmax0.gt.xmax)then - xmax=xmax0 - else - if(idproc.eq.0)then - write(6,*)'ERROR: particle range falls outside xmax; halting.' - write(6,*)'xmax0,xmax=',xmax0,xmax - endif - call myexit - endif - if(ymin0.lt.ymin)then - ymin=ymin0 - else - if(idproc.eq.0)then - write(6,*)'ERROR: particle range falls outside ymin; halting.' - write(6,*)'ymin0,ymin=',ymin0,ymin - endif - call myexit - endif - if(ymax0.gt.ymax)then - ymax=ymax0 - else - if(idproc.eq.0)then - write(6,*)'ERROR: particle range falls outside ymax; halting.' - write(6,*)'ymax0,ymax=',ymax0,ymax - endif - call myexit - endif - hx=(xmax-xmin)/(nx0-1) - hy=(ymax-ymin)/(ny0-1) - hxi=1./hx - hyi=1./hy - endif - if(kfixbdy.eq.1 .and. nadj0.eq.0)then -! if(idproc.eq.0)write(6,*)'kfixbdy.eq.1 .and. nadj0.eq.0' -cryne 11/27/03 from now on, zmin is the grid size IN THE BUNCH FRAME, -cryne WHERE THE POISSON EQUATION IS ACTUALLY SOLVED -cryne if(gamma*zmin0.lt.zmin)then -cryne zmin=gamma*zmin0 - if(zmin0.lt.zmin)then - zmin=zmin0 - else - if(idproc.eq.0)then - write(6,*)'ERROR: particle range falls outside zmin; halting.' -cryne write(6,*)'zmin0,zmin=',gamma*zmin0,zmin - write(6,*)'zmin0,zmin=',zmin0,zmin - endif - call myexit - endif -cryne if(gamma*zmax0.gt.zmax)then -cryne zmax=gamma*zmax0 - if(zmax0.gt.zmax)then - zmax=zmax0 - else - if(idproc.eq.0)then - write(6,*)'ERROR: particle range falls outside zmax; halting.' -cryne write(6,*)'zmax0,zmax=',gamma*zmax0,zmax - write(6,*)'zmax0,zmax=',zmax0,zmax - endif - call myexit - endif - hz=(zmax-zmin)/(nz0-1) - hzi=1./hz - endif -!=================================================================== -! check grid sizes: -! aspect is the max allowed ratio between any *two* grid sizes - aspect=1.9 - aspinv=1./aspect - ierrx=0 - ierry=0 - ierrz=0 - if(hx.lt.hy .and. hx.lt.hz)then - if(hx.lt.aspinv*min(hy,hz))ierrx=1 - else if(hy.lt.hx .and. hy.lt.hz)then - if(hy.lt.aspinv*min(hx,hz))ierry=1 - else if(hz.lt.hx .and. hz.lt.hy)then - if(hz.lt.aspinv*min(hx,hy))ierrz=1 - endif - if(ierrx.eq.1 .and. idproc.eq.0)write(12,1111)hx,hy,hz - if(ierry.eq.1 .and. idproc.eq.0)write(12,1112)hx,hy,hz - if(ierrz.eq.1 .and. idproc.eq.0)write(12,1113)hx,hy,hz - 1111 format('(aspect ratio)should increase hx; hx,hy,hz=',3(1pe9.3,1x)) - 1112 format('(aspect ratio)should increase hy; hx,hy,hz=',3(1pe9.3,1x)) - 1113 format('(aspect ratio)should increase hz; hx,hy,hz=',3(1pe9.3,1x)) - if(hx.gt.hy .and. hx.gt.hz)then - if(hx.gt.aspect*max(hy,hz))ierrx=-1 - else if(hy.gt.hx .and. hy.gt.hz)then - if(hy.gt.aspect*max(hx,hz))ierry=-1 - else if(hz.gt.hx .and. hz.gt.hy)then - if(hz.gt.aspect*max(hx,hy))ierrz=-1 - endif - if(ierrx.eq.-1 .and. idproc.eq.0)write(12,1114)hx,hy,hz - if(ierry.eq.-1 .and. idproc.eq.0)write(12,1115)hx,hy,hz - if(ierrz.eq.-1 .and. idproc.eq.0)write(12,1116)hx,hy,hz - 1114 format('(aspect ratio)should decrease hx; hx,hy,hz=',3(1pe9.3,1x)) - 1115 format('(aspect ratio)should decrease hy; hx,hy,hz=',3(1pe9.3,1x)) - 1116 format('(aspect ratio)should decrease hz; hx,hy,hz=',3(1pe9.3,1x)) -c flush file 12 just in case the code crashes or runs out of time: - call myflush(12) -c=================================================================== -c if(ierrx.ne.0 .or. ierry.ne.0 .or. ierrz.ne.0) -c #write(6,*)'warning from setbound: ierr (x,y,z)=',ierrx,ierry,ierrz - if(noresize.eq.1 .or. kfixbdy.eq.1)goto 38 -c resize the grid if needed: - if((ierrx.eq.1 .or. ierry.eq.1 .or. ierrz.eq.1) .and. - & (nx0.le.n0min .or. ny0.le.n0min .or. nz0.le.n0min))then - write(6,*)'cannot decrease grid size; doubling all sizes' - nx0=2*nx0 - ny0=2*ny0 - nz0=2*nz0 - goto 37 - endif - if(ierrx.eq.1)then - nx0=nx0/2 - if(idproc.eq.0)write(6,*)'#DECREASING NX0 to ',nx0 - else if(ierry.eq.1)then - ny0=ny0/2 - if(idproc.eq.0)write(6,*)'#DECREASING NY0 to ',ny0 - else if(ierrz.eq.1)then - nz0=nz0/2 - if(idproc.eq.0)write(6,*)'#DECREASING NZ0 to ',nz0 - endif - if((ierrx.eq.-1 .or. ierry.eq.-1 .or. ierrz.eq.-1) .and. - & (nx0.ge.n0max .or. ny0.ge.n0max .or. nz0.ge.n0max))then - write(6,*)'cannot increase grid size; stopping.' - stop - endif - if(ierrx.eq.-1)then - nx0=2*nx0 - if(idproc.eq.0)write(6,*)'#INCREASING NX0 to ',nx0 - else if(ierry.eq.-1)then - ny0=2*ny0 - if(idproc.eq.0)write(6,*)'#INCREASING NY0 to ',ny0 - else if(ierrz.eq.-1)then - nz0=2*nz0 - if(idproc.eq.0)write(6,*)'#INCREASING NZ0 to ',nz0 - endif - if(abs(ierrx)+abs(ierry)+abs(ierrz).ne.0)then - write(6,'(3i5,9x,3i5)')nx0,ny0,nz0 - goto 37 - endif - 38 continue -c========== - if(idproc.eq.0.and.iverbose.ge.5)then - write(6,*)'setbound: [xyz]min=',xmin,ymin,zmin - & ,' [xyz]max=',xmax,ymax,zmax, ' h[xyz]=' - & ,hx,hy,hz - endif - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/sfft3d_dummy.f b/OpticsJan2020/MLI_light_optics/Src/sfft3d_dummy.f deleted file mode 100644 index bec4ade..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/sfft3d_dummy.f +++ /dev/null @@ -1,13 +0,0 @@ -! -*- Mode: Fortran; Modified: "Mon 17 Nov 2003 11:36:42 by dbs"; -*- - -! non-operative version of sfft3d() routine for building MLI without FFTW or ESSL - - subroutine sfft3d( f,N ) - implicit none -!Arguments - integer N - real*8 f(0:N,0:N,0:N) - write(6,*) 'error: sfft3d: not implemented. ' - & ,'Requires FFTW or ESSL.' - stop 'NOSFFT3D' - end diff --git a/OpticsJan2020/MLI_light_optics/Src/sfft3d_essl.f b/OpticsJan2020/MLI_light_optics/Src/sfft3d_essl.f deleted file mode 100644 index 942e3d5..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/sfft3d_essl.f +++ /dev/null @@ -1,119 +0,0 @@ -! -*- Mode: Fortran; Modified: "Fri 14 Nov 2003 17:34:29 by dbs"; -*- - -! Computes 3D sine transform on a cubic grid using FFT from IBM ESSL - - subroutine sfft3d(f,N) - implicit none -!Arguments - integer N - real*8 f(0:N,0:N,0:N) -!Locals - integer i,j,k,ll ,naux1,naux2 - real*8 in1d(0:N-1) - real*8 sincoef(0:N-1) - real*8 out1d(0:N) - real*8 aux1(22000+N+N),aux2(25000) - real*8 Pi - -!Initialization - Pi = ATAN(1.0d0) * 4 - naux1 = 22000+N+N - naux2 = 25000 -!Execution - - ! N must be an even number. - if ((N/2)*2 .ne. N) then - write(6,*) "sfft3d: N is odd, N = ",N - call abort - endif - - ! Set up preliminary stuff. - do ll = 0,N-1 - sincoef(ll) = sin(ll*Pi/N) - enddo - - ! assuming cubic grids, initialize internal data just once - call DRCFT( 1 ,in1d ,0 ,out1d,0 ,N,1 ,+1,1.0d0 - & ,aux1,naux1 ,aux2,naux2 ) - - ! Sine transform in the x direction. - do k = 0,N-1 - do j = 0,N-1 - in1d(0) = 0.d0 - do i = 1,N-1 - in1d(i) = sincoef(i)*(f(i,j,k) + f(N-i,j,k)) + - & (f(i,j,k) - f(N-i,j,k))/2 - enddo - - call DRCFT( 0 ,in1d ,0 ,out1d,0 ,N,1 ,+1,1.0d0 - & ,aux1,naux1 ,aux2,naux2 ) - - f(1,j,k) = out1d(0)/2 - f(0,j,k) = 0.d0 - - ! ESSL returns the complex result, but - ! this is the same as the real result just - ! reordered so the imaginary part of out(1:N/2-1) - ! is the same as the real part of out(N/2:N-1) - do i = 1,N/2-1 - f(2*i,j,k) = -out1d(2*i+1) !out(N - i) - f(2*i+1,j,k) = out1d(2*i) + f(2*i-1,j,k) !out(i) - enddo - - enddo - enddo - - - ! Sine transform in the y direction. - do k = 0,N-1 - do j = 0,N-1 - in1d(0) = 0.d0 - do i = 1,N-1 - in1d(i) = sincoef(i)*(f(j,i,k) + f(j,N-i,k)) + - & (f(j,i,k) - f(j,N-i,k))/2 - enddo - - call DRCFT( 0 ,in1d ,0 ,out1d,0 ,N,1 ,+1,1.0d0 - & ,aux1,naux1 ,aux2,naux2 ) - - f(j,1,k) = out1d(0)/2 - f(j,0,k) = 0.d0 - - ![NOTE: see comment above.] - do i = 1,N/2-1 - f(j,2*i,k) = -out1d(2*i+1) !out(N - i) - f(j,2*i+1,k) = out1d(2*i) + f(j,2*i-1,k) !out(i) - enddo - - enddo - enddo - - - ! Sine transform in the z direction. - do k = 0,N-1 - do j = 0,N-1 - in1D(0) = 0.d0 - - do i = 1,N-1 - in1D(i) = sincoef(i)*(f(j,k,i) + f(j,k,N-i)) + - & (f(j,k,i) - f(j,k,N-i))/2 - enddo - - call DRCFT( 0 ,in1d ,0 ,out1d,0 ,N,1 ,+1,1.0d0 - & ,aux1,naux1 ,aux2,naux2 ) - - f(j,k,0) = 0.d0 - f(j,k,1) = out1d(0)/2 - - ![NOTE: see comment above.] - do i = 1,N/2-1 - f(j,k,2*i) = -out1d(2*i+1) !out(N - i) - f(j,k,2*i+1) = out1d(2*i) + f(j,k,2*i-1) !out(i) - enddo - - enddo - enddo - -!done - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/sif.f b/OpticsJan2020/MLI_light_optics/Src/sif.f deleted file mode 100644 index 0727b07..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/sif.f +++ /dev/null @@ -1,5735 +0,0 @@ -cryne The bulk of this file (sif.f) is devoted to reading in -cryne parameters in the Standard Input Format -c - subroutine getconst(line,strval,nreturn) -cryne read & parse a symbolic constant defined in the input file -cryne Note: this assumes only one definition per input record, -cryne i.e. can't have multiple definitions separated by ; if using MADX format. -cryne If using MADX format, the record terminates with the first ; - use parallel - include 'impli.inc' - character line*(*) -cryne 5/4/2006 character linetmp*256 - character linetmp*800 - character cdummy*1 - integer lentmp - logical keypres,numpres - dimension bufr(1) -c -cryne 5/4/2006 linetmp=line -cryne 5/4/2006 lentmp = LEN( linetmp ) -c I don't remember exactly why I added readin800. -c I think it was to process symbolic constants defined on continued lines. -c - call readin800(line,linetmp,mmax) - lentmp=mmax - nreturn=0 -c - -cryne---5/4/2006 I don't know exactly why I commented this out -cryne It must be that this (and other) data processing is handled in readin800 -c n1=index(line,'!') -c if(n1.ne.0)then -c do n=n1,lentmp -c linetmp(n:n)=' ' -c enddo -c endif -c for now assume that there is only one definition per record: -c n1=index(line,';') -c if(n1.ne.0)then -c do n=n1,lentmp -c linetmp(n:n)=' ' -c enddo -c endif -cryne--- - call getparm(linetmp,lentmp,'=',bufr,keypres,numpres,0,cdummy) - if(numpres)then - nreturn=1 - strval=bufr(1) -cc write(6,*)'returning from getparm w/ strval=',strval - endif - return - end -c - subroutine initcons - use acceldata - include 'impli.inc' -c initialize the first few values of #const - pi=2.d0*asin(1.d0) - twopi=4.d0*asin(1.d0) - clite=299792458.d0 - constr(1)='pi' - conval(1)=pi - constr(2)='twopi' - conval(2)=twopi - constr(3)='clite' - conval(3)=clite - nconst=3 -c write(6,*)'nconst=',nconst - return - end -c -ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine stdinf(line80,na,kt1,kt2,initparms,lmntname) -c read a record in the Standard Input Format -c input: -c line80=input line -c na=na'th entry in the menu -c kt1, kt2 = indices describing entry category and type -cryne 5/4/2006: removed a lot of code from stdinf and put it in readin800 -cryne 5/4/2006: na appears unused. formerly for debugging? -cryne 12/17/2004: -cryne added initparms (controls whether or not to initialize parameters) -cryne added lmntname (element label; used for diagnostic info & debugging) - include 'impli.inc' - character line80*(*) - character line*800 - character*16 lmntname - call readin800(line80,line,mmax) - call lmntparm(line,mmax,kt1,kt2,initparms,lmntname) - return - end -c - subroutine readin800(line80,line,mmax) -cryne 5/4/2006 store multiline input into a buffer of length 800 -cryne and do some minimal processing of the line -c line80=first 80 character input line -c line=full 800 characture buffer -c mmax=length of resulting line (i.e. nonblank character length) - include 'impli.inc' - character line80*(*) - character line*800 - logical leof - dimension bufr(1) - integer ilen - common/showme/iverbose -c -cryne 5/4/2006 - logical MAD8,MADX - common/mad8orx/MAD8,MADX -c -c write(6,*)'inside readin800' -c -c - leof = .FALSE. - -! if(iverbose.ge.6 .AND. idproc.eq.0)then -! write(6,*)'entering stdinf; kt1,kt2=',kt1,kt2 -! write(6,*)'line80(1:78) = ',line80(1:78) -! endif - -!XXX -- I rewrote this Aug04 - ! read input lines until all the data for this entry is read; - ! and pack it into 'line' - i1 = 0 - i2 = 0 - do !until eof or entry is terminated - ! first iteration uses line80 from caller; rest get input from file - if( i1 .NE. 0 )then -! write(6,*)'calling readin' - call readin(line80,leof) -! write(6,*)'line80(1:78) = ',line80(1:78) - if( leof )then - if( iverbose.ge.6 .AND. idproc.eq.0 )then - write(6,*) 'info: STDINF(): EOF happend with line80=' - & ,line80 - endif - exit - endif - endif - line80 = ADJUSTL( line80 ) !remove leading blanks - ilen = LEN_TRIM( line80 ) !dont look at trailing blanks - ! skip additional blank lines; - ! line80 initially blank is ok but doesnt need processing - if( ilen .EQ. 0 )then - if(i1 .GT. 0 )cycle - else - ! debug - if( iverbose.ge.6 .AND. idproc.eq.0 )then - write(6,*)'info: STDINF(): line80=' - write(6,*) line80(:ilen) - endif - i1 = i2 + 1 !start inserting after end of previous line80 - ! find comments and ignore them - j1 = INDEX( line80(:ilen) ,'!' ) - if( j1 .GT. 0 )then - ! skip if nothing on the line except the comment - if( j1 .EQ. 1 ) cycle - ! strip trailing blanks before the '!' - ilen = LEN_TRIM(line80(:j1-1)) - ! skip if non-comment part of the line is blank - if( ilen .EQ. 0 ) cycle - endif - ! check for not enough buffer space - i2 = i1 + ilen - 1 - if( i2 .GT. LEN( line ) )then - write(6,*) 'error: STDINF(): input too long for line buffer' - write(6,*) 'info: input is [',line80(:ilen),']' - stop - endif - ! convert to lowercase - ![NOTE: readin() does this, so this is probably redundant. ] - call LOW( line80(:ilen) ) - if( iverbose.ge.6 .AND. idproc.eq.0 )then - write(6,*) 'info: STDINF(): after low(), input line is ' - write(6,*) line80(:ilen) - endif -cryne 5/4/2006 -cryne in MADX style, there could be space between ; and !, so deal with it: - do iq=ilen,1,-1 - ilast=iq - if(line80(ilast:ilast).ne.' ')exit - enddo -cryne - ! save this line - line(i1:i2) = line80(:ilen) - ! check if there are more lines to read - if( (MAD8) .and. line80(ilen:ilen) .EQ. '&' )then - ! add a space to the buffer to make sure words are separated - i2 = i2 + 1 - line(i2:i2) = ' ' - ! continue to next line - cycle - elseif( (MADX) .and. line80(ilast:ilast) .NE. ';' )then - write(6,*)'continuing...' -! write(6,*)line80(1:ilen) - i2 = i2 + 1 - line(i2:i2) = ' ' - cycle - endif - endif - ! line is blank or, for ML and MAD8, this is the end, - ! but for MAD9 we should keep going until a ";" is found: -!cryne if( MAD9 ) cycle - exit - enddo - - ! finished with packing all the input lines into the buffer - mmax = i2 - if( iverbose.ge.6 .AND. idproc.eq.0 )then - write(6,*) 'info: STDINF(): completed input buffer =' - write(6,*) line(:mmax) - endif -cryne 5/4/2006 -cryne skip the rest of there is no equal sign on this line -c write(6,*)'nearly finished in readin800 having found:' -c write(6,*)line(1:mmax) - if(index(line,'=').eq.0)then - write(6,*)'leaving readin800 without cleanup up near = sign' - goto 999 - endif - - ! remove blanks around "="; - ! move each character to the left - ! by the number of blanks found up to that character - move = 0 - i1 = 2 !can skip the 1st char - do while( i1 .LE. mmax ) !loop up to the last non-blank - ![NOTE: use a 'while' loop because i1 gets changed inside the loop] - if( line(i1:i1) .EQ. '=' )then - ! count spaces to the left (dont go past the start of the string) - do i2 = 1 ,i1-1 - if( line(i1-i2:i1-i2) .NE. ' ' ) exit - enddo - ! increase the move distance by the number of spaces found - move = move + i2 - 1 - ! do the move, if necessary - if( move .GT. 0 ) line(i1-move:i1-move) = line(i1:i1) - ! count spaces to the right (dont go past the end) - do i2 = 1 ,mmax-i1 - if( line(i1+i2:i1+i2) .NE. ' ' ) exit - enddo - ! increase the move distance by the number of spaces found - move = move + i2 - 1 - ! skip over the spaces on the right so we dont move them - i1 = i1 + i2 - 1 - else - ! not '=', so just move it, if necessary - if( move .GT. 0 ) line(i1-move:i1-move) = line(i1:i1) - endif - i1 = i1 + 1 - enddo - ! clean up chars at end of the string that were moved but not overwritten - if( move .GT. 0 ) line(mmax-move+1:mmax) = ' ' - - if( iverbose.ge.6 .AND. idproc.eq.0 )then - write(6,*) 'info: STDINF(): completed parsing, line =' - write(6,*) line(:mmax) - endif -cryne 5/4/2006 - mmax=mmax-move -cryne now lmntparm is called separately from the above parsing -cryne call lmntparm(line,mmax,kt1,kt2,initparms,lmntname) -cryne call lmntparm(line,mmax-move,kt1,kt2,initparms,lmntname) -cryne debugging: - 999 continue -c write(6,*)'leaving readin800 at end having found:' -c write(6,*)line(1:mmax) - return - end -c -c - subroutine lmntparm(line,mmax,kt1,kt2,initparms,lmntname) -cryne 12/17/2004 added initparms -cryne If initparms=1 the parameters get initialized, otherwise they do not. -cryne This is needed when a menu element is definied in terms of a previous -cryne element, in which case the initial values are inherited, not set here. -cryne 12/17/2004 also added lmntname: used for diagnostic info & debugging - use rays - use acceldata - use beamdata - include 'impli.inc' - include 'pie.inc' - include 'codes.inc' ! added Dec 1, 2002 to check nrp - include 'setref.inc' ! added by RDR, April 18, 2004 (used in BEAM) - include 'files.inc'!RDR 7/29/04 (to backspace(lf) [wake code after BEAM]) -c character*800 line - character line*(*) - character*16 cbuf - character*16 lmntname -cryne 5/4/2006 logical keypres,keypres1,keypres2,numpres - logical keypres,keypres1,keypres2,numpres,leof - dimension bufr(1) - common/mlunits/sclfreq,magunits - common/showme/iverbose -! common/autslice/iautosl -! common/autoslice/islicetype,isliceprecedence,islicevalue - common/symbdef/isymbdef - data multmsg/1/ - save multmsg -c - if(idproc.eq.0.and.iverbose.ge.6)then - write(6,*)'(lmntparm) mmax,kt1,kt2=',mmax,kt1,kt2 - write(6,*)'line=',line(1:mmax) - endif -c -c files.inc contains the unit # (lf) connected to the master input file. -c this is needed so that that wake_init reads from the correct file - iunitnum=lf -cryne=== 9/16/2004 new code to deal with "at=' -cryne=== (needed to emulate MAD "sequence") -c note: eventually, it might be better not to have a separate array -c called atarray, but instead to store the "at" info in pmenu - call getparm(line,mmax,'at=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)atarray(1+mpp(na))=bufr(1) -cryne=== -cryne=== -c -c eventually "c" should be replaced by "clite" in common/parm/ - clite=c -c Select appropriate action depending on value of kt1,kt2 -c - go to (11,12,13,14,15,16,17,18,19), kt1 -c -c 1: simple elements ************************************* -c -11 continue -c write(6,*)'line(1:80)=' -c write(6,*)line(1:80) -c write(6,*)'(lmntparm) kt1,kt2=',kt1,kt2 -c 'drft ','nbnd ','pbnd ','gbnd ','prot ', - go to(101, 102, 103, 104, 105, -c 'gbdy ','frng ','cfbd ','quad ','sext ', - & 106, 107, 108, 109, 110, -c 'octm ','octe ','srfc ','arot ','twsm ', - & 111, 112, 113, 114, 115, -c 'thlm ','cplm ','cfqd ','dism ','sol ', - & 116, 117, 118, 119, 120, -c 'mark ','jmap ','dp ','recm ','spce ', - & 121, 122, 123, 124, 125, -c 'cfrn ','coil ','intg ','rmap ','arc ', - & 126, 127, 128, 129, 130, -c 'rfgap ','confoc ','spare1 ','spare2 ','spare3 ', - & 1135, 1136, 133, 134, 135, -c 'spare4 ','spare5 ','spare6 ','spare7 ','spare8 ', - & 136, 137, 138, 139, 140, -c 'marker ','drift ','rbend ','sbend ','gbend ', - & 141, 142, 143, 1045, 145, -c 'quadrupo','sextupol','octupole','multipol','solenoid', - & 146, 147, 148, 149, 150, -c 'hkicker ','vkicker ','kicker ','rfcavity','elsepara', - & 151, 152, 153, 154, 155, -c 'hmonitor','vmonitor','monitor ','instrume','sparem1 ', - & 156, 157, 158, 159, 160, -c 'rcollima','ecollima','yrot ','srot ','prot3 ', - & 161, 162, 163, 164, 165, -c 'beambeam','matrix ','profile1d','yprofile','tprofile', - & 166, 167, 168, 169, 170, -c 'hkick ','vkick ','kick ','sparem6 ','nlrf '/ - & 171, 172, 173, 174, 175),kt2 -c -c===================================================================== -c DRFT -c===================================================================== -c 'drft ': drift -101 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) -c slices: - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(nrp(1,1).eq.1)then - write(6,*)'DRFT input warning: SLICES will be ignored.' - write(6,*)'To autoslice individual elements specified in the' - write(6,*)'original MaryLie input style, use the SLICEMARYLIE' - write(6,*)'argument of AUTOSLICE and place first in the menu' - else - pmenu(2+mpp(na))=1. - if(numpres)pmenu(2+mpp(na))=bufr(1) - endif - endif - return -c -c -c===================================================================== -c NBND -c===================================================================== -c 'nbnd': -102 continue -c if(idproc.eq.0)write(6,*)'nbnd element is: ',lmntname -c defaults: - if(initparms.eq.1)then - angle=0. - pmenu(1+mpp(na))=angle !angle or angdeg - pmenu(2+mpp(na))=0. !gap or hgap - pmenu(3+mpp(na))=0.5 !fint - pmenu(4+mpp(na))=0. !b - pmenu(5+mpp(na))=0. !lfrn - pmenu(6+mpp(na))=0. !tfrn -cryne 12/21/2004 need to add slices to MaryLie element parsed in MAD format - if(nrp(1,2).eq.7)then -c if(idproc.eq.0)write(6,*)'initializing nbnd slices to 1' - pmenu(7+mpp(na))=1. - endif - endif -c values provided by user: -c angle: - call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angdeg=bufr(1) - pmenu(1+mpp(na))=angdeg - angle=angdeg*pi180 - else - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angle=bufr(1) - pmenu(1+mpp(na))=angle/pi180 - else - write(6,*)'warning: nbnd bend angle not found' - endif - endif -c -c b field: - call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=bufr(1) - else - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=brho*angle/bufr(1) - else - write(6,*)'Error: nbnd L or B not found' - stop - endif - endif -c -c gap, field integral: - call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=2.d0*bufr(1) - endif - call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) -c leading fringe, trailing fringe: - call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) -c slices: - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(nrp(1,2).eq.6)then - write(6,*)' NBND input warning: SLICES will be ignored.' - write(6,*)'To autoslice individual elements specified in the' - write(6,*)'original MaryLie input style, use the SLICEMARYLIE' - write(6,*)'argument of AUTOSLICE and place first in the menu' - else - if(numpres)then -c if(idproc.eq.0)write(6,*)'resetting nbnd slices to ',bufr(1) - pmenu(7+mpp(na))=bufr(1) - endif - endif - endif - return -c -c===================================================================== -c PBND -c===================================================================== -c 'pbnd': -103 continue -c defaults: - if(initparms.eq.1)then - angle=0. - pmenu(1+mpp(na))=angle - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0.5 - pmenu(4+mpp(na))=0. - pmenu(5+mpp(na))=1. !slices - endif -c values provided by user: -c angle: - call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angdeg=bufr(1) - pmenu(1+mpp(na))=bufr(1) - angle=angdeg*pi180 - else - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angle=bufr(1) - pmenu(1+mpp(na))=angle/pi180 - else - write(6,*)'warning: pbnd bend angle not found' - endif - endif -c -c gap, field integral: - call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=2.d0*bufr(1) - endif - call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) -c -c b field: - call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=bufr(1) - else - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=2.d0*brho*sin(0.5d0*angle)/bufr(1) - else - write(6,*)'Error: pbnd L or B not found' - stop - endif - endif -c slices: -cryne 3/17/2004 this is not quite right. -cryne need to clarify how to handle mixed MaryLie and SIF input -cryne and implement it correctly throughout. This will do for now: - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(nrp(1,3).eq.4)then - write(6,*)' PBND input warning: SLICES will be ignored.' - write(6,*)'To autoslice elements specified in the original' - write(6,*)'MaryLie input style, place an autoslice element' - write(6,*)'in the input file BEFORE any MaryLie elements' - else - if(numpres)pmenu(5+mpp(na))=bufr(1) - endif - endif - return -c -c===================================================================== -c GBND -c===================================================================== -c 'gbnd ': general bending magnet -104 continue -c defaults: -c 6 Marylie parameters = angdeg, e1deg, e2deg, gap, fint, B field - if(initparms.eq.1)then - angle=0.d0 - pmenu(1+mpp(na))=angle - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. - pmenu(4+mpp(na))=0. - pmenu(5+mpp(na))=0.5 - pmenu(6+mpp(na))=0. - endif -c values provided by user: -c angle: - call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angdeg=bufr(1) - pmenu(1+mpp(na))=angdeg - angle=angdeg*pi180 - else - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angle=bufr(1) - pmenu(1+mpp(na))=angle/pi180 - else - write(6,*)'warning: gbnd bend angle not found' - endif - endif -c -c entry angle: - call getparm(line,mmax,'e1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1)/pi180 - else - call getparm(line,mmax,'e1deg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - write(6,*)'warning: gbnd entry angle not found' - endif - endif -c -c exit angle: - call getparm(line,mmax,'e2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=bufr(1)/pi180 - else - call getparm(line,mmax,'e2deg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=bufr(1) - else - write(6,*)'warning: gbnd exit angle not found' - endif - endif -c gap and field integral: -c - call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=2.d0*bufr(1) - call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) -c -c b field: - call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(6+mpp(na))=bufr(1) - else - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - write(6,*)'Reading gbnd parameters. Performing conversion' - write(6,*)'from length to B field assuming sbend geometry' - pmenu(6+mpp(na))=brho*angle/bufr(1) - else - write(6,*)'Error: gbnd L or B not found' - stop - endif - endif -c slices: - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(nrp(1,4).eq.6)then - write(6,*)' GBND input warning: SLICES will be ignored.' - write(6,*)'To autoslice individual elements specified in the' - write(6,*)'original MaryLie input style, use the SLICEMARYLIE' - write(6,*)'argument of AUTOSLICE and place first in the menu' - else - pmenu(7+mpp(na))=1. - if(numpres)pmenu(7+mpp(na))=bufr(1) - endif - endif - return -c===================================================================== -c PROT -c===================================================================== -c -c 'prot ': rotation of reference plane -105 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - endif -c values provided by user: - call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1)/pi180 - call getparm(line,mmax,'kind=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - return -c -c===================================================================== -c GBDY -c===================================================================== -c 'gbdy ': body of a general bending magnet -106 continue -c defaults: - if(initparms.eq.1)then - angle=0. - pmenu(1+mpp(na))=angle - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. - pmenu(4+mpp(na))=0. - endif -c values provided by user: -c angle: - call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angdeg=bufr(1) - pmenu(1+mpp(na))=angdeg - angle=angdeg*pi180 - else - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angle=bufr(1) - pmenu(1+mpp(na))=angle/pi180 - else - write(6,*)'warning: gbnd bend angle not found' - endif - endif -c -c entry angle: - call getparm(line,mmax,'e1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1)/pi180 - else - call getparm(line,mmax,'e1deg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - write(6,*)'warning: gbnd entry angle not found' - endif - endif -c -c exit angle: - call getparm(line,mmax,'e2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=bufr(1)/pi180 - else - call getparm(line,mmax,'e2deg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=bufr(1) - else - write(6,*)'warning: gbnd exit angle not found' - endif - endif -c b field: - call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=bufr(1) - else - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - write(6,*)'Reading gbdy parameters. Performing conversion' - write(6,*)'from length to B field assuming sbend geometry' - pmenu(4+mpp(na))=brho*angle/bufr(1) - else - write(6,*)'Error: gbnd L or B not found' - stop - endif - endif -c slices: - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(nrp(1,6).eq.4)then - write(6,*)' GBDY input warning: SLICES will be ignored.' - write(6,*)'To autoslice individual elements specified in the' - write(6,*)'original MaryLie input style, use the SLICEMARYLIE' - write(6,*)'argument of AUTOSLICE and place first in the menu' - else - pmenu(5+mpp(na))=1. - if(numpres)pmenu(5+mpp(na))=bufr(1) - endif - endif - return -c -c===================================================================== -c FRNG -c===================================================================== -c 'frng ': hard edge dipole fringe fields -107 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0.5 - pmenu(4+mpp(na))=0. - pmenu(5+mpp(na))=0. - endif -c values provided by user: - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=2.d0*bufr(1) - call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'iedge=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - return -c -c===================================================================== -c CFBD : PROBABLY NOT FUNCTIONAL; USE 'SBEND' INSTEAD -c===================================================================== -c 'cfbd ': combined function bend (normal entry and exit) -108 continue - write(6,*)'*****CFBD input is not functional*************' - write(6,*)'USE SBEND INSTEAD' -cryne 12/17/2004 what was I thinking here??? this element is all screwed up! -c combined function bend with arbitrary entrance/exit angles? - call getparm(line,mmax,'e1=',bufr,keypres1,numpres,0,cbuf) - call getparm(line,mmax,'e2=',bufr,keypres1,numpres,0,cbuf) - if(keypres1.or.keypres2)then -! (make sure nt1,nt2,na are present in commons) -! nt1(na)=??? -! nt2(na)=??? - goto 1045 - endif -c defaults: - if(initparms.eq.1)then - angle=0. - pmenu(1+mpp(na))=angle - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. - pmenu(4+mpp(na))=0. - pmenu(5+mpp(na))=0. - pmenu(6+mpp(na))=0. - endif -c values provided by user: -c angle: - call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(numpres)pmenu(1+mpp(na))=bufr(1) - angle=angdeg*pi180 - else - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - angle=bufr(1) - if(numpres)pmenu(1+mpp(na))=angle/pi180 - else - write(6,*)'WARNING: no bend angle specified for cfbd' - endif - endif -c b field: - call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(numpres)pmenu(2+mpp(na))=bufr(1) - else - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(numpres)pmenu(2+mpp(na))=brho*bufr(1)/angle - else - write(6,*)'WARNING: no bfield or length specified for cfbd' - endif - endif -c leading fringe, trailing fringe, iopt, ipset: - call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'ipset=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - return -c -c===================================================================== -c SBEND -c===================================================================== -c 'sbend ': combined function bend (arbitrary entry and exit) -1045 continue -c defaults (in MaryLie units, i.e. degrees for angles) : -c (1)bend angle in degrees, (2)B field, -c (3)entry angle in degrees, (4)exit angle in degrees, -c (5)entry fringe, (6)exit fringe, [DEFAULT FOR BOTH = 3, i.e. turned on] -c (7)gap size for leading (entry) fringe field calculation, -c (8)gap size for trailing (exit) fringe field calculation, -c (9)normalized field integral for leading (entry) edge fringe field, -c (10)normalized field integral for trailing (exit) edge fringe field, -c (11)iopt[interpretation of multipole coeffs;default=3=same meaning as MAD], -c (12)ipset [if multipole coeffs specified in pset], -c (13-18)=P1,P2,P3,P4,P5,P6 -c =BQD, AQD,BSEX,ASEX,BOCT,AOCT if iopt=1 -c =Tay1,AQD,Tay2,ASEX,Tay3,AOCT if iopt=2 -c =Tay1/brho,AQD/brho,Tay2/brho,ASEX/brho,Tay3/brho,AOCT/brho if iopt=3 -c (19)axial rotation angle ["TILT" in MAD] -c (20)order -c (21)number of slices - if(initparms.eq.1)then -c The phrases "entry angle" and "exit angle" are WRONG!!!!!!!!!!! -c They should be "entry pole face rotation angle" and "exit pole face -c rotation angle" (This is what E1 and E2 mean in MAD notation.) -c These are only comments in the code, but they will cause confusion. -c FIX LATER!!!!!!!!! - angle=0. - pmenu(1+mpp(na))=angle - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. - pmenu(4+mpp(na))=0. - pmenu(5+mpp(na))=3. !fixed on 11/3/02 (formerly default was 1) - pmenu(6+mpp(na))=3. !ditto - pmenu(7+mpp(na))=0.d0 - pmenu(8+mpp(na))=0.d0 - pmenu(9+mpp(na))=0.d0 - pmenu(10+mpp(na))=0.d0 - pmenu(11+mpp(na))=3.d0 - pmenu(12+mpp(na))=0. - pmenu(13+mpp(na))=0. - pmenu(14+mpp(na))=0. - pmenu(15+mpp(na))=0. - pmenu(16+mpp(na))=0. - pmenu(17+mpp(na))=0. - pmenu(18+mpp(na))=0. - pmenu(19+mpp(na))=0. - pmenu(20+mpp(na))=5. ! order - pmenu(21+mpp(na))=1. ! slices - endif -c values provided by user: -c angle: - call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angdeg=bufr(1) - pmenu(1+mpp(na))=angdeg - angle=angdeg*pi180 - else - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angle=bufr(1) - pmenu(1+mpp(na))=angle/pi180 - else - write(6,*)'warning: sbend bend angle not found' - endif - endif -c -c b field: - call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=brho*angle/bufr(1) - else - write(6,*)'Error: sbend L or B not found' - stop - endif - endif -c -c entry angle: - call getparm(line,mmax,'e1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=bufr(1)/pi180 - else - call getparm(line,mmax,'e1deg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=bufr(1) - else -c write(6,*)'warning: sbend entry angle not found' - endif - endif -c -c exit angle: - call getparm(line,mmax,'e2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=bufr(1)/pi180 - else - call getparm(line,mmax,'e2deg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=bufr(1) - else -c write(6,*)'warning: sbend exit angle not found' - endif - endif -c -c leading fringe, trailing fringe: - call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) -c gap sizes: - call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(7+mpp(na))=bufr(1) - pmenu(8+mpp(na))=bufr(1) - else - call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=2.d0*bufr(1) - if(keypres.and.numpres)pmenu(8+mpp(na))=2.d0*bufr(1) -c - call getparm(line,mmax,'gap1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) - call getparm(line,mmax,'gap2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) -c - call getparm(line,mmax,'hgap1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=2.d0*bufr(1) - call getparm(line,mmax,'hgap2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=2.d0*bufr(1) - endif -c write(6,*)'sbend gap/hgap: found the following:' -c write(6,*)pmenu(7+mpp(na)),pmenu(8+mpp(na)) -c normalized field integrals: - call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(9+mpp(na))=bufr(1) - pmenu(10+mpp(na))=bufr(1) - else - call getparm(line,mmax,'fint1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) - call getparm(line,mmax,'fint2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) - endif -c check consistency of input parameters regarding fringe fields: - if( (pmenu(7+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then - write(6,*)'warning(sbend): input specifies a nonzero gap size' - write(6,*)'but leading-edge fringe effects are turned off?' - endif - if( (pmenu(8+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then - write(6,*)'warning(sbend): input specifies a nonzero gap size' - write(6,*)'but trailing-edge fringe effects are turned off?' - endif - if( (pmenu(9+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then - write(6,*)'warning(sbend):input specifies nonzero field integral' - write(6,*)'but leading-edge fringe effects are turned off?' - endif - if( (pmenu(10+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then - write(6,*)'warning(sbend):input specifies nonzero field integral' - write(6,*)'but trailing-edge fringe effects are turned off?' - endif - if( (pmenu(3+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then - write(6,*)'warning(sbend):input specifies nonzero entrance angle' - write(6,*)'but leading-edge fringe effects are turned off?' - endif - if( (pmenu(4+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then - write(6,*)'warning(sbend):input specifies nonzero exit angle' - write(6,*)'but trailing-edge fringe effects are turned off?' - endif -c -c -c iopt, ipset: - call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) - call getparm(line,mmax,'ipset=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) -c multipole coefficients: - call getparm(line,mmax,'k1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(13+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'s1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(14+mpp(na))=bufr(1) -c for compatability w/ MAD: - call getparm(line,mmax,'ks=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(14+mpp(na))=bufr(1) - call getparm(line,mmax,'k2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(15+mpp(na))=bufr(1) - call getparm(line,mmax,'s2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(16+mpp(na))=bufr(1) - call getparm(line,mmax,'k3=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(17+mpp(na))=bufr(1) - call getparm(line,mmax,'s3=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(18+mpp(na))=bufr(1) -c tilt: - call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(19+mpp(na))=bufr(1) -c order: - call getparm(line,mmax,'order=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(20+mpp(na))=bufr(1) -c slices: - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(21+mpp(na))=bufr(1) -c for debugging: - if(idproc.eq.0 .and. iverbose.ge.1)then - write(6,*)'done reading SBEND parameters,' - write(6,*)'angle,b=',pmenu(1+mpp(na)),pmenu(2+mpp(na)) - write(6,*)'e1,e2=',pmenu(3+mpp(na)),pmenu(4+mpp(na)) - endif - return -c -c -c===================================================================== -c QUAD -c===================================================================== -c 'quad ': quadrupole -109 continue - if(idproc.eq.0)then - write(6,*)'reading parameters for a QUAD in MAD format.' - write(6,*)'**NOTE WELL** QUAD is used for backward compatibility' - write(6,*)'with MaryLie and corresponds to the original MaryLie' - write(6,*)'code. Suggest you use QUADRUPOLE instead.' - endif -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. - pmenu(4+mpp(na))=0. -cryne 12/17/2004 added initialization of # of slices too, -cryne commented out below at end of QUAD section - pmenu(5+mpp(na))=1. - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'g1=',bufr,keypres1,numpres,0,cbuf) - if(keypres1.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - call getparm(line,mmax,'k1=',bufr,keypres2,numpres,0,cbuf) - if(keypres2.and.numpres)then - pmenu(2+mpp(na))=bufr(1)*brho - endif - endif - if((.not.keypres1).and.(.not.keypres2))then - write(6,*)lmntname,'WARNING: neither g1 nor k1 has been specified' - endif - call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) -c slices: - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(nrp(1,9).eq.4)then - write(6,*)' QUAD input warning: SLICES will be ignored.' - write(6,*)'To autoslice individual elements specified in the' - write(6,*)'original MaryLie input style, use the SLICEMARYLIE' - write(6,*)'argument of AUTOSLICE and place first in the menu' - else -cryne 12/17/2004 pmenu(5+mpp(na))=1. - if(numpres)pmenu(5+mpp(na))=bufr(1) - endif - endif - write(6,*)'done reading QUAD parameters:' - write(6,*)pmenu(1+mpp(na)),pmenu(2+mpp(na)) - write(6,*)pmenu(3+mpp(na)),pmenu(4+mpp(na)) - return -c -c===================================================================== -c SEXT -c===================================================================== -c 'sext ': sextupole -110 continue -c write(6,*)'(LMNTPARM) SEXT:' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'g2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - call getparm(line,mmax,'k2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1)*brho/2.d0 - endif - endif -c slices: - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(nrp(1,10).eq.2)then - write(6,*)' SEXT input warning: SLICES will be ignored.' - write(6,*)'To autoslice individual elements specified in the' - write(6,*)'original MaryLie input style, use the SLICEMARYLIE' - write(6,*)'argument of AUTOSLICE and place first in the menu' - else - pmenu(3+mpp(na))=1. - if(numpres)pmenu(3+mpp(na))=bufr(1) - endif - endif - return -c -c===================================================================== -c OCTM -c===================================================================== -c 'octm ': mag. octupole -111 continue -c write(6,*)'(LMNTPARM) OCTM:' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'g3=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - call getparm(line,mmax,'k3=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1)*brho/6.d0 - endif - endif -c slices: - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(nrp(1,11).eq.2)then - write(6,*)' SEXT input warning: SLICES will be ignored.' - write(6,*)'To autoslice individual elements specified in the' - write(6,*)'original MaryLie input style, use the SLICEMARYLIE' - write(6,*)'argument of AUTOSLICE and place first in the menu' - else - pmenu(3+mpp(na))=1. - if(numpres)pmenu(3+mpp(na))=bufr(1) - endif - endif - return -c -c===================================================================== -c OCTE -c===================================================================== -c 'octe ': elec. octupole -112 continue - if(initparms.eq.1)then -c ... - endif - write(6,*)'MAD-style input for MaryLie octe not implemented' - stop -c -c===================================================================== -c SRFC -c===================================================================== -c 'srfc ': short rf cavity -113 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. !volts (in Volts) - pmenu(2+mpp(na))=0. !freq (in Hz) - endif - call getparm(line,mmax,'volts=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'freq=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - return -c -c===================================================================== -c RFGAP -c===================================================================== -c 'rfgap ': rf gap -1135 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=-1.0 !length - pmenu(2+mpp(na))=0. !frequency - pmenu(3+mpp(na))=0. !escale - pmenu(4+mpp(na))=0. !phasedeg - pmenu(5+mpp(na))=0. !unit (integer N for data file called rfdataN) - pmenu(6+mpp(na))=0. !steps - pmenu(7+mpp(na))=0. !e1deg - pmenu(8+mpp(na))=0. !notused - pmenu(9+mpp(na))=1. !tdim - pmenu(10+mpp(na))=1. !ptdim - pmenu(11+mpp(na))=1. !slices - cmenu(1+mppc(na))=' ' !file = name of data file - cmenu(2+mppc(na))=' ' !wake - endif -c write(6,*)'READING RFGAP PARAMETERS' -c length (or flag), freq,volts, phase, #, int_steps, slices -c - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) -c - call getparm(line,mmax,'freq=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) -c - call getparm(line,mmax,'volts=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(idproc.eq.0)then - write(6,*)'ERROR (RFGAP): the keywork VOLTS has been replaced' - write(6,*)'with ESCALE. Modify your input file and re-run' - endif - call myexit - endif - call getparm(line,mmax,'escale=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) -c - call getparm(line,mmax,'phasedeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) -c - call getparm(line,mmax,'unit=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) -c - call getparm(line,mmax,'steps=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) -c - call getparm(line,mmax,'e1deg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) -c - call getparm(line,mmax,'notused=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) -c - call getparm(line,mmax,'tdim=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) -c - call getparm(line,mmax,'ptdim=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) -c - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) -c file: - call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif -c wake: - call getparm(line,mmax,'wake=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(2+mppc(na))='wake' - write(6,*)'found rfgap wake; name of wake =',cbuf - call wake_init(cbuf) - endif -! check for over-specification: - if(pmenu(5+mpp(na)).ne.0. .and. cmenu(1+mppc(na)).ne.' ')then - if(idproc.eq.0)then - write(6,*)'rfgap input error:' - write(6,*)'specified file rfgapN, where N =',pmenu(5+mpp(na)) - write(6,*)'specified file name, where name=',cmenu(1+mppc(na)) - write(6,*)'cannot specify file by both number and name' - endif - call myexit - endif - return -c -c===================================================================== -c CONFOC -c===================================================================== -c 'confoc ': "constant focusing" element rdr 08/29/2001 -1136 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !length - pmenu(2+mpp(na))=0.d0 !k1 - pmenu(3+mpp(na))=0.d0 !k2 - pmenu(4+mpp(na))=0.d0 !k3 - pmenu(5+mpp(na))=1.d0 !slices - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'k1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'k2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'k3=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) -! - if(idproc.eq.0)then - write(6,*)'results of confoc input:' - write(6,*)'l=',pmenu(1+mpp(na)) - write(6,*)'k1=',pmenu(2+mpp(na)) - write(6,*)'k2=',pmenu(3+mpp(na)) - write(6,*)'k3=',pmenu(4+mpp(na)) - write(6,*)'slices=',pmenu(5+mpp(na)) - endif - return -c -c===================================================================== -c AROT -c===================================================================== -c 'arot ': axial rotation -114 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - endif -c values provided by user: - call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1)/pi180 - return - stop -c -c===================================================================== -c TWSM -c===================================================================== -c 'twsm ': linear matrix via twiss parameters -115 continue - if(initparms.eq.1)then -c ... - endif - write(6,*)'MAD-style input for ML twsm not implemented' - stop -c -c===================================================================== -c THLM -c===================================================================== -c 'thlm ': thin lens low order multipole -116 continue -c if(idproc.eq.0)write(6,*)'reading parameters for thlm' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. - pmenu(4+mpp(na))=0. - pmenu(5+mpp(na))=0. - pmenu(6+mpp(na))=0. - endif -c values provided by user: -c normal quadrupole (n=0): - call getparm(line,mmax,'bqd=',bufr,keypres,numpres,0,cbuf) - if(keypres)then -c if(idproc.eq.0)write(6,*)'found bqd' - if(numpres)then - pmenu(1+mpp(na))=bufr(1) -c if(idproc.eq.0)write(6,*)'param1=',pmenu(1+mpp(na)) - endif - else - call getparm(line,mmax,'k1l=',bufr,keypres,numpres,0,cbuf) - if(keypres)then -c if(idproc.eq.0)write(6,*)'found k1l' - if(numpres)then - pmenu(1+mpp(na))=bufr(1)*brho -c if(idproc.eq.0)write(6,*)'param1=',pmenu(1+mpp(na)) - endif - endif - endif -c skew quadrupole: -c fix later. -c -c normal sextupole: - call getparm(line,mmax,'bsex=',bufr,keypres,numpres,0,cbuf) - if(keypres)then -c if(idproc.eq.0)write(6,*)'found bsex' - if(numpres)then - pmenu(3+mpp(na))=bufr(1) -c if(idproc.eq.0)write(6,*)'param3=',pmenu(3+mpp(na)) - endif - else - call getparm(line,mmax,'k2l=',bufr,keypres,numpres,0,cbuf) - if(keypres)then -c if(idproc.eq.0)write(6,*)'found k2l' - if(numpres)then - pmenu(3+mpp(na))=bufr(1)*brho -c if(idproc.eq.0)write(6,*)'param3=',pmenu(3+mpp(na)) - endif - endif - endif -c skew sextupole: -c fix later. -c -c normal octupole: - call getparm(line,mmax,'boct=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(numpres)pmenu(5+mpp(na))=bufr(1) - else - call getparm(line,mmax,'k3l=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(numpres)pmenu(5+mpp(na))=bufr(1)*brho - endif - endif -c skew sextupole: -c fix later. -c higher order stuff from MAD: -c fix later. -c printout for debugging: -c if(idproc.eq.0)then -c write(6,*)'multipole parameters have been set to:' -c do ii=1,6 -c write(6,*)pmenu(ii+mpp(na)) -c enddo -c endif - return -c -c===================================================================== -c CPLM -c===================================================================== -c 'cplm ': "compressed" low order multipole -117 continue - write(6,*)'MAD-style input for MaryLie cplm not implemented' - stop -c -c===================================================================== -c CFQD -c===================================================================== -c 'cfqd ': combined function quadrupole -118 continue - write(6,*)'MAD-style input for MaryLie cfqd not implemented' - stop -c -c dispersion matrix (dism) -119 continue - write(6,*)'MAD-style input for MaryLie dism not implemented' - stop -c -c 'sol ': solenoid -120 continue - write(6,*)'MAD-style input for MaryLie sol not implemented' - write(6,*)'Use solenoid instead of sol' - stop -c -c 'mark ': marker -121 continue - write(6,*)'MAD-style input for MaryLie mark not implemented' - stop -c -c 'jmap ': j mapping -122 continue - write(6,*)'MAD-style input for MaryLie jmap not implemented' - stop -c -c 'dp ': data point -123 continue - write(6,*)'MAD-style input for MaryLie dp not implemented' - stop -c -c 'recm ': REC multiplet -124 continue - write(6,*)'MAD-style input for MaryLie recm not implemented' - stop -c -c 'spce ': space -125 continue - write(6,*)'MAD-style input for MaryLie spce not implemented' - stop -c -c 'cfrn ': change/write fringe field params for comb function dipole -126 continue - write(6,*)'MAD-style input for MaryLie cfrn not implemented' - stop -c -c 'coil' -127 continue - write(6,*)'MAD-style input for MaryLie coil not implemented' - stop -c -c 'intg' -128 continue - write(6,*)'MAD-style input for MaryLie intg not implemented' - stop -c -129 continue -c 'rmap' - write(6,*)'MAD-style input for MaryLie rmap not implemented' - stop -c -c 'arc' -130 continue - write(6,*)'MAD-style input for MaryLie arc not implemented' - stop -c -c 'transit' -133 continue - write(6,*)'(sif) transit' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. !l (length) - pmenu(2+mpp(na))=1. !n - pmenu(3+mpp(na))=1. !slices - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'n=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - return -c 'interface' -134 write(6,*)'(sif) interface' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=1. !n1 - pmenu(2+mpp(na))=1. !n2 - pmenu(3+mpp(na))=0. !b2 - pmenu(4+mpp(na))=0. !b4 - pmenu(5+mpp(na))=0. !b6 - endif -c values provided by user: - call getparm(line,mmax,'n1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'n2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'b2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'b4=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'b6=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - return -c 'rootmap' -135 write(6,*)'(sif) rootmap' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=1. !n - pmenu(2+mpp(na))=0. !b2 - pmenu(3+mpp(na))=0. !b4 - pmenu(4+mpp(na))=0. !b6 - cmenu(1+mppc(na))='false' !invert= : flag to compute inverted map - endif -c values provided by user: - call getparm(line,mmax,'n=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'b2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'b4=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'b6=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'inverse=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - return -c 'optirot' -136 write(6,*)'(sif) optirot' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - endif -c values provided by user: - call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1)/pi180 - call getparm(line,mmax,'kind=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - return -c -c 'spare5' -137 write(6,*)'spare5 just a placeholder (not a valid type code)' - return -c 'spare6' -138 write(6,*)'spare6 just a placeholder (not a valid type code)' - return -c 'spare7' -139 write(6,*)'spare7 just a placeholder (not a valid type code)' - return -c 'spare8' -140 write(6,*)'spare8 just a placeholder (not a valid type code)' - return -c -c 'marker': MAD marker -141 continue -cryne 5/4/2006 write(6,*)'ignoring input for MAD marker (not implemented)' - write(12,*)'ignoring input for MAD marker (not implemented)' - return -c -c===================================================================== -c DRIFT -c===================================================================== -c 'drift': MAD drift -142 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. !isssflag - pmenu(3+mpp(na))=1. !slices - cmenu(1+mppc(na))=' ' !wake - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=bufr(1) - endif -c wake: - call getparm(line,mmax,'wake=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))='wake' - write(6,*)'found drift wake; name of wake =',cbuf - call wake_init(cbuf) - endif -c write(6,*)'FOUND DRIFT; SLICES=',nint(bufr(1)) - return -c -c===================================================================== -c RBEND -c===================================================================== -c 'rbend': MAD rectangular bend -143 continue -c defaults: - if(initparms.eq.1)then -cryne NOTE TO MYSELF: -c The phrases "entry angle" and "exit angle" are WRONG!!!!!!!!!!! -c They should be "entry pole face rotation angle" and "exit pole face -c rotation angle" (This is what E1 and E2 mean in MAD notation.) -c These are only comments in the code, but they will cause confusion. -c FIX LATER!!!!!!!!! - angle=0. - pmenu(1+mpp(na))=angle !bend angle - pmenu(2+mpp(na))=0. !B field - pmenu(3+mpp(na))=0. !entry angle - pmenu(4+mpp(na))=0. !exit angle - pmenu(5+mpp(na))=3. !entry fringe on/off (default on) - pmenu(6+mpp(na))=3. !exit fringe on/off (default on) - pmenu(7+mpp(na))=0.d0 !gap size for leading (entry) fringe field calc - pmenu(8+mpp(na))=0.d0 !gap size for trailing (exit) fringe field calc - pmenu(9+mpp(na))=0.d0 !fint for leading (entry) fringe - pmenu(10+mpp(na))=0.d0 !fint size for trailing (exit) fringe - pmenu(11+mpp(na))=0. ! tilt - pmenu(12+mpp(na))=5. ! order - pmenu(13+mpp(na))=1. ! slices - endif -c values provided by user: -c angle: - call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angdeg=bufr(1) - pmenu(1+mpp(na))=angdeg - angle=angdeg*pi180 - else - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - angle=bufr(1) - pmenu(1+mpp(na))=angle/pi180 - else - write(6,*)'warning (rbend): bend angle not found' - endif - endif -c -c b field: - call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - if(angle.ne.0.)then - pmenu(2+mpp(na))=brho/(0.5*bufr(1)/sin(0.5*angle)) - else - write(6,*)'error (rbend): angle=0 in b field calculation' - call myexit - endif - else - write(6,*)'Error: rbend L or B not found' - stop - endif - endif -c -c entry angle: - call getparm(line,mmax,'e1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=bufr(1)/pi180 - else - call getparm(line,mmax,'e1deg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=bufr(1) - else -c write(6,*)'warning (rbend): entry angle not found' - endif - endif -c -c exit angle: - call getparm(line,mmax,'e2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=bufr(1)/pi180 - else - call getparm(line,mmax,'e2deg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=bufr(1) - else -c write(6,*)'warning (rbend): exit angle not found' - endif - endif -c -c leading fringe, trailing fringe: - call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) -c gap sizes: - call getparm(line,mmax,'gap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(7+mpp(na))=bufr(1) - pmenu(8+mpp(na))=bufr(1) - else - call getparm(line,mmax,'hgap=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=2.d0*bufr(1) - if(keypres.and.numpres)pmenu(8+mpp(na))=2.d0*bufr(1) -c - call getparm(line,mmax,'gap1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) - call getparm(line,mmax,'gap2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) -c - call getparm(line,mmax,'hgap1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=2.d0*bufr(1) - call getparm(line,mmax,'hgap2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=2.d0*bufr(1) - endif -c write(6,*)'rbend gap/hgap: found the following:' -c write(6,*)pmenu(7+mpp(na)),pmenu(8+mpp(na)) -c normalized field integrals: - call getparm(line,mmax,'fint=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(9+mpp(na))=bufr(1) - pmenu(10+mpp(na))=bufr(1) - else - call getparm(line,mmax,'fint1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) - call getparm(line,mmax,'fint2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) - endif -c check consistency of input parameters regarding fringe fields: - if( (pmenu(7+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then - write(6,*)'warning (rbend): input specifies a nonzero gap size' - write(6,*)'but leading-edge fringe effects are turned off?' - endif - if( (pmenu(8+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then - write(6,*)'warning (rbend): input specifies a nonzero gap size' - write(6,*)'but trailing-edge fringe effects are turned off?' - endif - if( (pmenu(9+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then - write(6,*)'warning (rbend):input specifies nonzero field integral' - write(6,*)'but leading-edge fringe effects are turned off?' - endif - if( (pmenu(10+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then - write(6,*)'warning (rbend):input specifies nonzero field integral' - write(6,*)'but trailing-edge fringe effects are turned off?' - endif - if( (pmenu(3+mpp(na)).ne.0.) .and. (pmenu(5+mpp(na)).eq.0.) )then - write(6,*)'warning (rbend):input specifies nonzero entrance angle' - write(6,*)'but leading-edge fringe effects are turned off?' - endif - if( (pmenu(4+mpp(na)).ne.0.) .and. (pmenu(6+mpp(na)).eq.0.) )then - write(6,*)'warning (rbend):input specifies nonzero exit angle' - write(6,*)'but trailing-edge fringe effects are turned off?' - endif -c -c -c tilt: - call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) -c order: - call getparm(line,mmax,'order=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) -c slices: - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(13+mpp(na))=bufr(1) -c -c write(6,*)'done reading RBEND parameters for element: ',lmntname -c write(6,*)'bend angle=',pmenu(1+mpp(na)) -c write(6,*)'B field=',pmenu(2+mpp(na)) -c write(6,*)'entry angle=',pmenu(3+mpp(na)) -c write(6,*)'exit angle=',pmenu(4+mpp(na)) -c write(6,*)'lfrn=',pmenu(5+mpp(na)) -c write(6,*)'tfrn=',pmenu(6+mpp(na)) -c write(6,*)'gap1=',pmenu(7+mpp(na)) -c write(6,*)'gap2=',pmenu(8+mpp(na)) -c write(6,*)'fint1=',pmenu(9+mpp(na)) -c write(6,*)'fint2=',pmenu(10+mpp(na)) -c write(6,*)'tilt=',pmenu(11+mpp(na)) -c write(6,*)'order=',pmenu(12+mpp(na)) -c write(6,*)'slices=',pmenu(13+mpp(na)) - return -c -c 'sbend': MAD sector bend -c 144 continue -c see statement 1045 -c -c 'gbend': MAD general bend -145 continue - write(6,*)'MAD general bend not implemented' - stop -c -c===================================================================== -c QUADRUPOLE -c===================================================================== -c 'quadrupole': MAD quadrupole -146 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. - pmenu(4+mpp(na))=0. - pmenu(5+mpp(na))=0. !isssflag - pmenu(6+mpp(na))=1. !slices - cmenu(1+mppc(na))=' ' !wake - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'g1=',bufr,keypres1,numpres,0,cbuf) - if(keypres1.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - call getparm(line,mmax,'k1=',bufr,keypres2,numpres,0,cbuf) - if(keypres2.and.numpres)then - pmenu(2+mpp(na))=bufr(1)*brho - endif - endif - if((.not.keypres1).and.(.not.keypres2))then - write(6,*)lmntname,'WARNING: neither g1 nor k1 has been specified' - endif - call getparm(line,mmax,'lfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'tfrn=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) -c - call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) -c - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(6+mpp(na))=bufr(1) - endif -c wake: - call getparm(line,mmax,'wake=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))='wake' - write(6,*)'found quadrupole wake; name of wake =',cbuf - call wake_init(cbuf) - endif - return -c -c -c===================================================================== -c SEXTUPOLE -c===================================================================== -c 'sextupol': MAD sextupole -147 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=1. !slices - cmenu(1+mppc(na))=' ' !wake - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'g2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - call getparm(line,mmax,'k2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1)*brho/2.d0 - endif - endif -c - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) -c wake: - call getparm(line,mmax,'wake=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))='wake' - write(6,*)'found sextupole wake; name of wake =',cbuf - call wake_init(cbuf) - endif - return -c -c===================================================================== -c OCTUPOLE -c===================================================================== -c 'octupole': MAD octupole -148 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=1. !slices - cmenu(1+mppc(na))=' ' !wake - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'g3=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - else - call getparm(line,mmax,'k3=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1)*brho/6.d0 - endif - endif -c - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) -c wake: - call getparm(line,mmax,'wake=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))='wake' - write(6,*)'found octupole wake; name of wake =',cbuf - call wake_init(cbuf) - endif - return -c -c===================================================================== -c MULTIPOLE -c===================================================================== -c 'multipole': MAD general thin multipole -c NOTE WELL: no factors of brho here; dealt with in subroutine lmnt -149 continue - if(multmsg.eq.1)then - if(idproc.eq.0)write(6,*)'MAD multipole partially implemented' - multmsg=0 - endif -c if(idproc.eq.0)write(6,*)'reading parameters for MAD multipole' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. - pmenu(4+mpp(na))=0. - pmenu(5+mpp(na))=0. - pmenu(6+mpp(na))=0. - endif -c values provided by user: -c normal quadrupole (n=0): - call getparm(line,mmax,'k1l=',bufr,keypres,numpres,0,cbuf) - if(keypres)then -c if(idproc.eq.0)write(6,*)'found k1l' - if(numpres)then - pmenu(1+mpp(na))=bufr(1) -c if(idproc.eq.0)write(6,*)'param1=',pmenu(1+mpp(na)) - endif - endif -c skew quadrupole: -c fix later. -c -c normal sextupole: - call getparm(line,mmax,'bsex=',bufr,keypres,numpres,0,cbuf) - call getparm(line,mmax,'k2l=',bufr,keypres,numpres,0,cbuf) - if(keypres)then -c if(idproc.eq.0)write(6,*)'found k2l' - if(numpres)then - pmenu(3+mpp(na))=bufr(1) -c if(idproc.eq.0)write(6,*)'param3=',pmenu(3+mpp(na)) - endif - endif -c skew sextupole: -c fix later. -c -c normal octupole: - call getparm(line,mmax,'k3l=',bufr,keypres,numpres,0,cbuf) - if(keypres)then - if(numpres)pmenu(5+mpp(na))=bufr(1) - endif -c skew sextupole: -c fix later. -c higher order stuff from MAD: -c fix later. -c printout for debugging: - if(idproc.eq.0)then - write(12,*)'(sif) multipole parameters read in, set to:' - do ii=1,6 - write(12,*)pmenu(ii+mpp(na)) - enddo - endif - return -c -c===================================================================== -c -c 'solenoid': MAD solenoid -150 continue -c defaults: - if (initparms.eq.1) then - pmenu(1+mpp(na))= 0. ! zstart - pmenu(2+mpp(na))= 0. ! zend - pmenu(3+mpp(na))= 100. ! steps - pmenu(4+mpp(na))= 0. ! iprofile - pmenu(5+mpp(na))= -1. ! ipset (not used, but -1 ==> SIF-style) - pmenu(6+mpp(na))= 0. ! multipoles (not used) - pmenu(7+mpp(na))= 0. ! ldrift - pmenu(8+mpp(na))= 0. ! lbody - pmenu(9+mpp(na))= 0. ! clength - pmenu(10+mpp(na))= 0. ! b - pmenu(11+mpp(na))= 0. ! iecho - pmenu(12+mpp(na))= 0. ! iopt - pmenu(13+mpp(na))= 1. ! slices - end if -c values provided by user: -c first make sure the user is not using a pset: - call getparm(line,mmax,'ipset=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - if(idproc.eq.0)then - write(6,*)'error: solenoid with MAD-style input does not' - write(6,*)'require specification of ipset' - endif - stop - endif -c - call getparm(line,mmax,'zstart=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'zend=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'steps=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'iprofile=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) -ccccc call getparm(line,mmax,'ipset=',bufr,keypres,numpres,0,cbuf) -ccccc if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'multipoles=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - call getparm(line,mmax,'ldrift=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) - call getparm(line,mmax,'lbody=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) - call getparm(line,mmax,'clength=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) - call getparm(line,mmax,'b=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) - call getparm(line,mmax,'iecho=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) - call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(13+mpp(na))=bufr(1) - return -c -c 'hkicker': MAD horizontal kicker -151 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. !isssflag - pmenu(4+mpp(na))=0. - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'kick=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - return -c -c 'vkicker': MAD vertical kicker -152 continue -c defaults: - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. !isssflag - pmenu(4+mpp(na))=0. -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'kick=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - return -c -c 'kicker': MAD kicker -153 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. - pmenu(4+mpp(na))=0. !isssflag - pmenu(5+mpp(na))=0. - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'hkick=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'vkick=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - return -c -c 'rfcavity': MAD rf cavity -154 continue - write(6,*)'MAD RFCAVITY' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. ! l - pmenu(2+mpp(na))=0. ! volt - pmenu(3+mpp(na))=0. ! lag - pmenu(4+mpp(na))=0. ! harmon - pmenu(5+mpp(na))=0. ! betrf - pmenu(6+mpp(na))=0. ! pg - pmenu(7+mpp(na))=0. ! shunt - pmenu(8+mpp(na))=0. ! tfill - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'volt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'lag=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'harmon=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'betrf=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'pg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - call getparm(line,mmax,'shunt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) - call getparm(line,mmax,'tfill=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) - return -c -c 'elsepara': MAD electrostatic separator -155 continue - write(6,*)'MAD ELSEPARATOR' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - pmenu(3+mpp(na))=0. - pmenu(4+mpp(na))=0. !isssflag - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'e=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'tilt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - return -c -c 'hmonitor': MAD horizontal monitor -156 continue - write(12,*)'reading SIF input for MAD hmonitor' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. !length - pmenu(2+mpp(na))=0. !isssflag - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - return -c -c 'vmonitor': MAD vertical monitor -157 continue - write(12,*)'reading SIF input for MAD vmonitor' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. !length - pmenu(2+mpp(na))=0. !isssflag - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - return -c -c 'monitor': MAD monitor -158 continue - write(12,*)'reading SIF input for MAD monitor' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. !length - pmenu(2+mpp(na))=0. !isssflag - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - return -c -c 'instrume': MAD instrument -159 continue - write(12,*)'reading SIF input for MAD instrument' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. !length - pmenu(2+mpp(na))=0. !isssflag - endif -c values provided by user: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'sssflag=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - return -c -c 'sparem1' -160 write(6,*)'sparem1 just a placeholder (not a valid type code)' - return -c -c 'rcollima': MAD rectangular collimator -161 continue - write(6,*)'ignoring input for MAD rcollimator (not implemented)' - return -c -c 'ecollima': MAD elliptical collimator -162 continue - write(6,*)'ignoring input for MAD ecollimator (not implemented)' - return -c -c 'yrot' -163 write(6,*)'YROT input: using MaryLie prot' - write(6,*)'NOTE WELL: this will not work!' - write(6,*)'YROT has one parameter; MaryLie prot has two.' - write(6,*)'this needs to be fixed.' -cryne goto 105 - stop -c -c 'srot' -164 write(6,*)'SROT input: using MaryLie arot (check sign!)' - goto 114 -c -c===================================================================== -c PROT3 -c===================================================================== -c -c 'prot3 ': 3rd order rotation of reference plane -165 continue - if(idproc.eq.0)write(6,*)'reading prot3 data in sif.f' -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=0. - endif -c values provided by user: - call getparm(line,mmax,'angdeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'angle=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1)/pi180 - call getparm(line,mmax,'kind=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - return -c -c 'beambeam': MAD beam-beam element -166 write(6,*)'MAD beambeam not implemented' - stop -c -c 'matrix': MAD matrix command -167 write(6,*)'MAD matrix not implemented' - stop -c -c===================================================================== -c PROFILE1 -c===================================================================== -c 'profile1d': 1D profile monitor -168 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=1.d0 !column for 1D histrogram - pmenu(2+mpp(na))=128.d0 !number of bins - pmenu(3+mpp(na))=0.d0 !sequencelength (=max # of files in sequence) - pmenu(4+mpp(na))=5.d0 !precision - pmenu(5+mpp(na))=0.d0 !assigned unit# for output file (or can be read in) - pmenu(6+mpp(na))=0.d0 !assigned counter for sequence of files - pmenu(7+mpp(na))=0.d0 !rwall - cmenu(1+mppc(na))=' ' !file= : name of output file - cmenu(2+mppc(na))='true' !close= : flag to close output file - cmenu(3+mppc(na))='false' !flush= : flag to flush output file - endif -c values provided by user: - call getparm(line,mmax,'column=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(1+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'bins=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'sequencelength=',bufr,keypres,numpres, & - & 0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'precision=',bufr,keypres,numpres, & - & 0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'unit=',bufr,keypres,numpres, & - & 0,cbuf) - if(keypres.and.numpres)then - pmenu(5+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'close=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(3+mppc(na))=cbuf - endif - call getparm(line,mmax,'rwall=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) -! if(idproc.eq.0)then -! write(6,*)'done reading data for profile1' -! write(6,*)'column=',pmenu(1+mpp(na)) -! write(6,*)'bins=',pmenu(2+mpp(na)) -! endif - return -c 'sparem4' -169 write(6,*)'sparem4 just a placeholder (not a valid type code)' - return -c 'sparem5' -170 write(6,*)'sparem5 just a placeholder (not a valid type code)' - return -c -c 'hkick ': synonym for MAD horizontal kicker -171 continue - goto 151 -c -c 'vkick ': synonym for MAD vertical kicker -172 continue - goto 152 -c -c 'kick ': synonym for MAD kicker -173 continue - goto 153 -c -c 'sparem6' -174 write(6,*)'sparem6 just a placeholder (not a valid type code)' - return -c -c===================================================================== -c NLRF -c===================================================================== -c 'nlrf': nonlinear rf cavity -175 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !zstart - pmenu(2+mpp(na))=0.d0 !zend - pmenu(3+mpp(na))=0.d0 !frequency - pmenu(4+mpp(na))=0.d0 !phasedeg - pmenu(5+mpp(na))=1.d0 !escale - pmenu(6+mpp(na))=0.d0 !steps - pmenu(7+mpp(na))=1.d0 !slices - cmenu(1+mppc(na))='rfdata' !E-field data file - cmenu(2+mppc(na))='crz.dat' !generalized gradients file - endif -c values provided by user: -cp1 - call getparm(line,mmax,'zstart=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) -cp2 - call getparm(line,mmax,'zend=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) -cp3 - call getparm(line,mmax,'frequency=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) -cp4 - call getparm(line,mmax,'phasedeg=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) -cp5 - call getparm(line,mmax,'escale=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) -cp6 - call getparm(line,mmax,'nz=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) -cp7 - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) -cc1 - call getparm(line,mmax,'efile=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif -cc2 - call getparm(line,mmax,'crzfile=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif -c - if(idproc.eq.0)then - write(6,*) 'Read nlrf parameters:' - write(6,*) ' zstart=',pmenu(1+mpp(na)) - write(6,*) ' zend=',pmenu(2+mpp(na)) - write(6,*) ' frequency=',pmenu(3+mpp(na)) - write(6,*) ' phasedeg=',pmenu(4+mpp(na)) - write(6,*) ' escale=',pmenu(5+mpp(na)) - write(6,*) ' steps=',pmenu(6+mpp(na)) - write(6,*) ' slices=',pmenu(7+mpp(na)) - write(6,*) ' efile=',cmenu(1+mppc(na)) - write(6,*) ' crzfile=',cmenu(2+mppc(na)) - endif - return -c -c -c 2: user-supplied elements ************************************ -c -c 'usr1 ','usr2 ','usr3 ','usr4 ','usr5 ', -12 go to (201, 202, 203, 204, 205, & -c 'usr6 ','usr7 ','usr8 ','usr9 ','usr10 ' - & 206, 207, 208, 209, 210, & -c 'usr11 ','usr12 ','usr13 ','usr14 ','usr15 ', - & 211, 212, 213, 214, 215, & -c 'usr16 ','usr17 ','usr18 ','usr19 ','usr20 ', - & 216, 217, 218, 219, 220),kt2 -c -201 continue - return -202 continue - return -203 continue - return -204 continue - return -205 continue - return -206 continue - return -207 continue - return -208 continue - return -209 continue - return -210 continue - return -211 continue - return -212 continue - return -213 continue - return -214 continue - return -215 continue - return -216 continue - return -217 continue - return -218 continue - return -219 continue - return -220 continue - return -c -c 3: parameter sets ********************************************** -c -c 'ps1 ','ps2 ','ps3 ','ps4 ','ps5 ', -13 go to (301, 302, 303, 304, 305, & -c 'ps6 ','ps7 ','ps8 ','ps9 '/ - & 306, 307, 308, 309),kt2 -c -301 continue - return -302 continue - return -303 continue - return -304 continue - return -305 continue - return -306 continue - return -307 continue - return -308 continue - return -309 continue - return -c -c 4-6: random elements -c -14 continue -15 continue -16 continue - return -c -c 7: simple commands ************************************* -c -c 'rt ','sqr ','symp ','tmi ','tmo ', -17 go to (701, 702, 703, 704, 705, -c 'pmif ','circ ','stm ','gtm ','end ', - & 706, 707, 708, 709, 710, -c 'ptm ','iden ','whst ','inv ','tran ', - & 711, 712, 713, 714, 715, -c 'revf ','rev ','mask ','num ','rapt ', - & 716, 717, 718, 719, 720, -c 'eapt ','of ','cf ','wnd ','wnda ', - & 721, 722, 723, 724, 725, -c 'ftm ','wps ','time ','cdf ','bell ', - & 726, 727, 728, 729, 730, -c 'wmrt ','wcl ','paws ','inf ','dims ', - & 731, 732, 733, 734, 735, -c 'zer ','sndwch ','tpol ','dpol ','cbm ', - & 736, 737, 738, 739, 740, -c 'poisson ','preapply','midapply','autoapply','autoconc', - & 741, 742, 743, 744, 745, -c 'rayscale','beam ','units ','autoslic','verbose ', - & 746, 747, 748, 749, 750, -c 'mask6 ','arcreset','symbdef ','particledump','raytrace', - & 751, 752, 753, 754, 755, -c 'autotrack','sckick','moments ','maxsize','reftraj', - & 756, 757, 758, 759, 760, -c 'initenv','envelopes','contractenv','setreftraj','setarclen', - & 761, 762, 763, 764, 765, -c 'wakedefault','emittance','matchenv','fileinfo','egengrad', - & 766, 767, 768, 769, 770, -c 'wrtmap','rdmap','sparec7','sparec8','sparec9'/ - & 771, 772, 773, 774, 775),kt2 - - -c -c 'rt': ray trace -701 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=13. - pmenu(2+mpp(na))=14. - pmenu(3+mpp(na))=5. - pmenu(4+mpp(na))=1. - pmenu(5+mpp(na))=1. - pmenu(6+mpp(na))=0. - cmenu(1+mppc(na))=' ' - cmenu(2+mppc(na))=' ' - endif -c values provided by user: - call getparm(line,mmax,'unit1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'unit2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'order=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'ntrace=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'nwrite=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'ibrief=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - call getparm(line,mmax,'file1=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'file2=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - return -c -c square the existing map: -c -702 continue - return -c -c symplectify matrix in transfer map -c -703 continue - return -c -c input transfer map from an external file: -c -704 continue - return -c -c output transfer map to an external file (tmo): -c -705 continue - return -c -c 'pmif': print contents of file master input file: -706 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. - pmenu(2+mpp(na))=12. - pmenu(3+mpp(na))=3. - cmenu(1+mppc(na))=' ' - endif -c values provided by user: - call getparm(line,mmax,'itype=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'unit=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - return -c -707 continue - return -c -c store the existing transfer map -c -708 continue - return -c -c get transfer map from storage -c -709 continue - return -c -c end of job: -c -710 continue -c defaults: - cmenu(1+mppc(na))='false' !timers= -c values provided by user: - call getparm(line,mmax,'timers=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - return -c -c 'ptm': print transfer map: -711 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=3. - pmenu(2+mpp(na))=3. - pmenu(3+mpp(na))=0. - pmenu(4+mpp(na))=0. - pmenu(5+mpp(na))=1. - endif -c values provided by user: - call getparm(line,mmax,'matrix=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'poly=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'t2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'u3=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'basis=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - return -c -c identity mapping: -c -712 continue - return -c -c write history of beam loss -c -713 continue - return -c -c inverse: -c -714 continue - return -c -c transpose: -c -715 continue - return -c -c reverse factorization: -c -716 continue - return -c -c Dragt's reversal -c -717 continue - return -c -c mask off selected portions of transfer map: -c -718 continue -c defaults: - if(initparms.eq.1)then -c default it to not mask anything: - pmenu(1+mpp(na))=1. !f1 - pmenu(2+mpp(na))=1. !matrix and f2 - pmenu(3+mpp(na))=1. !f3 - pmenu(4+mpp(na))=1. !f4 - pmenu(5+mpp(na))=1. !f5 - pmenu(6+mpp(na))=1. !f6 - endif -c values provided by user: - call getparm(line,mmax,'f1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'f2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'f3=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'f4=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'f5=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'f6=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) -c "matrix=" means the same thing as "f2=" - call getparm(line,mmax,'matrix=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - return -c -c number lines in a file -c -719 continue - return -c -c aperture particle distribution -c -720 continue - return -c -721 continue - return -c -c open files -c -722 continue - return -c -c close files -c -723 continue - return -c -c window particle distribution -c -724 continue - return -725 continue - return -c -c filter transfer map -c -726 continue - return -c -c write parameter set -c -727 continue - return -c -c write time -c -728 continue - return -c -c 'cdf': change output drop file -729 continue -c default: - if(initparms.eq.1)then - pmenu(1+mpp(na))=12. - endif -c values provided by user: - call getparm(line,mmax,'ifile=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - return -c -c ring bell -c -730 continue - return -c -c write value of merit function -c -731 continue - return -c -c write contents of loop -c -732 continue - return -c -c pause (paws) -c -733 continue - return -c -c change or write out infinities (inf) -c -734 continue - return -c -c get dimensions (dims) -c -735 continue - return -c -c change or write out values of zeroes (zer) -c -736 continue - return -c -c sndwch -c -737 continue - return -c -c twiss polynomial (tpol) -c -738 continue - return -c -c dispersion polynomial (dpol) -c -739 continue - return -c -c change or write out beam parameters (cbm) -c -740 continue - return -c -c set parameters for poisson solver -c===================================================================== -c POISSON -c===================================================================== -741 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0. !nx - pmenu(2+mpp(na))=0. !ny - pmenu(3+mpp(na))=0. !nz - pmenu(4+mpp(na))=0. !xmin - pmenu(5+mpp(na))=0. !xmax - pmenu(6+mpp(na))=0. !ymin - pmenu(7+mpp(na))=0. !ymax - pmenu(8+mpp(na))=0. !zmin - pmenu(9+mpp(na))=0. !zmax - pmenu(10+mpp(na))=0. !anag_patchsize - pmenu(11+mpp(na))=0. !anag_refineratio - cmenu(1+mppc(na))='fft' !solver (fft or fft2 or chombo) - cmenu(2+mppc(na))='rectangular' !geometry [not currently used] - cmenu(3+mppc(na))='variable' !gridsize (fixed or variable) - cmenu(4+mppc(na))='fixed' !gridpoints (fixed or variable) - cmenu(5+mppc(na))='open' !xboundary (open, dirichlet, or periodic) - cmenu(6+mppc(na))='open' !yboundary - cmenu(7+mppc(na))='open' !zboundary - cmenu(8+mppc(na))='open' !boundary - cmenu(9+mppc(na))='E' !solving_for (phi, E) - cmenu(10+mppc(na))='delta' !densityfunction (delta or linear) - cmenu(11+mppc(na))='undefined' !chombo_file - cmenu(12+mppc(na))='none' !anag_smooth - cmenu(13+mppc(na))='undefined' !spare_13 - cmenu(14+mppc(na))='undefined' !spare_14 - cmenu(15+mppc(na))='undefined' !spare_15 - cmenu(16+mppc(na))='undefined' !spare_16 - cmenu(17+mppc(na))='undefined' !spare_17 - endif -c values provided by user: -c nx: - call getparm(line,mmax,'nx=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) -c ny: - call getparm(line,mmax,'ny=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) -c nz: - call getparm(line,mmax,'nz=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) -c xmin: - call getparm(line,mmax,'xmin=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) -c xmax: - call getparm(line,mmax,'xmax=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) -c ymin: - call getparm(line,mmax,'ymin=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) -c ymax: - call getparm(line,mmax,'ymax=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) -c zmin: - call getparm(line,mmax,'zmin=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) -c zmax: - call getparm(line,mmax,'zmax=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) -c anag_patchsize: - call getparm(line,mmax,'anag_patchsize=',bufr,keypres,numpres,0 - & ,cbuf) - if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) -c anag_refineratio: - call getparm(line,mmax,'anag_refineratio=',bufr,keypres,numpres,0 - & ,cbuf) - if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) -c solver: - call getparm(line,mmax,'solver=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))=cbuf - endif -c geometry: - call getparm(line,mmax,'geometry=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(2+mppc(na))=cbuf - endif -c gridsize: - call getparm(line,mmax,'gridsize=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(3+mppc(na))=cbuf - endif -c gridpoints: - call getparm(line,mmax,'gridpoints=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(4+mppc(na))=cbuf - endif -c xboundary:: - call getparm(line,mmax,'xboundary=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(5+mppc(na))=cbuf - endif -c yboundary:: - call getparm(line,mmax,'yboundary=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(6+mppc(na))=cbuf - endif -c zboundary:: - call getparm(line,mmax,'zboundary=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(7+mppc(na))=cbuf - endif -c boundary: - call getparm(line,mmax,'boundary=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(8+mppc(na))=cbuf - endif -c solving_for: - call getparm(line,mmax,'solving_for=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(9+mppc(na))=cbuf - endif -c densityfunction: - call getparm(line,mmax,'densityfunction=',bufr,keypres, & - & numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(10+mppc(na))=cbuf - endif -c chombo_file: - call getparm(line,mmax,'chombo_file=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(11+mppc(na))=cbuf - endif -c anag_smooth: - call getparm(line,mmax,'anag_smooth=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(12+mppc(na))=cbuf - endif -c spare_13: - call getparm(line,mmax,'spare_13=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(13+mppc(na))=cbuf - endif -c spare_14: - call getparm(line,mmax,'spare_14=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(14+mppc(na))=cbuf - endif -c spare_15: - call getparm(line,mmax,'spare_15=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(15+mppc(na))=cbuf - endif -c spare_16: - call getparm(line,mmax,'spare_16=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(16+mppc(na))=cbuf - endif -c spare_17: - call getparm(line,mmax,'spare_17=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(17+mppc(na))=cbuf - endif - return -c -c===================================================================== -c PREAPPLY -c===================================================================== -c preapply commands automatically -c -742 continue - if(initparms.eq.1)then - cmenu(1+mppc(na))=' ' - cmenu(2+mppc(na))='physical' !applyto= 'physical' or 'all' elements - endif - call getparm(line,mmax,'name=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'applyto=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(2+mppc(na))=cbuf - endif - return -c -c===================================================================== -c MIDAPPLY -c===================================================================== -c midapply commands automatically -c -743 continue - if(initparms.eq.1)then - cmenu(1+mppc(na))=' ' - cmenu(2+mppc(na))='physical' !applyto= 'physical' or 'all' elements - endif - call getparm(line,mmax,'name=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'applyto=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(2+mppc(na))=cbuf - endif - return -c -c===================================================================== -c AUTOAPPLY -c===================================================================== -c autoapply commands automatically -c -744 continue - if(initparms.eq.1)then - cmenu(1+mppc(na))=' ' - cmenu(2+mppc(na))='physical' !applyto= 'physical' or 'all' elements - endif - call getparm(line,mmax,'name=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'applyto=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(2+mppc(na))=cbuf - endif -c - if(idproc.eq.0 .and. iverbose.ge.1)then - write(6,*)'(routine lmntparm) results from POST-APPLY command:' - write(6,*)'cmenu(1+mppc(na))=',cmenu(1+mppc(na)) - endif - return -c -c autoconc ('auto-concatenate') -c===================================================================== -c AUTOCONC -c===================================================================== -c -745 continue -c default: - if(initparms.eq.1)then - cmenu(1+mppc(na))='true' !set - endif -c - call getparm(line,mmax,'set=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))=cbuf - else - call getparm(line,mmax,'true',bufr,keypres,numpres,1,cbuf) - if(keypres)cmenu(1+mppc(na))='true' - call getparm(line,mmax,'false',bufr,keypres,numpres,1,cbuf) - if(keypres)cmenu(1+mppc(na))='false' - endif - if(idproc.eq.0)then - write(6,*)'(sif) result of autoconc input:' - write(6,*)'set=',cmenu(1+mppc(na)) - endif - return -c -c rayscale ('scale zblock array') -c===================================================================== -c RAYSCALE -c===================================================================== -c -746 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=1.d0 - pmenu(2+mpp(na))=1.d0 - pmenu(3+mpp(na))=1.d0 - pmenu(4+mpp(na))=1.d0 - pmenu(5+mpp(na))=1.d0 - pmenu(6+mpp(na))=1.d0 - endif -c note: this code allows the use of a 'div' option instead of -c a multiplicative factor. However, when the div option is used -c the data are immediately converted to multiplicative factors, -c which is how they are stored in the pmenu array. -c -c values provided by user: -c X: - call getparm(line,mmax,'xmult=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(1+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'xdiv=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(1+mpp(na))=1.d0/bufr(1) - endif -c PX: - call getparm(line,mmax,'pxmult=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'pxdiv=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=1.d0/bufr(1) - endif -c Y: - call getparm(line,mmax,'ymult=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'ydiv=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(3+mpp(na))=1.d0/bufr(1) - endif -c PY: - call getparm(line,mmax,'pymult=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'pydiv=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(4+mpp(na))=1.d0/bufr(1) - endif -c T: - call getparm(line,mmax,'tmult=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(5+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'tdiv=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(5+mpp(na))=1.d0/bufr(1) - endif -c PT: - call getparm(line,mmax,'ptmult=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(6+mpp(na))=bufr(1) - endif - call getparm(line,mmax,'ptdiv=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(6+mpp(na))=1.d0/bufr(1) - endif - return -c -c===================================================================== -c BEAM -c===================================================================== -c beam: set parameters for an ensemble of particles -747 continue -c write(6,*)'******************************here I am at beam' -c defaults: - if(initparms.eq.1)then - maxray=0 -! energy=1.d9 -! pmass=938.27200d6 -! gamma=energy/pmass -! gamm1=gamma-1.d0 -! beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma -! brho=gamma*beta/clite*pmass - energy=0.d0 - pmass=0.d0 - gamma=1.d0 - gamm1=0.d0 - beta=0.d0 - brho=0.d0 - achg=1.d0 - bcurr=0.d0 - bfreq=0.d0 - bomega=twopi*bfreq -! - icompmass=0 -! - pmenu(1+mpp(na))=maxray - pmenu(2+mpp(na))=brho - pmenu(3+mpp(na))=gamma - pmenu(4+mpp(na))=gamm1 - pmenu(5+mpp(na))=beta - pmenu(6+mpp(na))=pmass - pmenu(7+mpp(na))=achg - pmenu(8+mpp(na))=bcurr - pmenu(9+mpp(na))=bfreq - pmenu(10+mpp(na))=bomega - cmenu(1+mppc(na))='proton' - endif -c values provided by user: -c maximum number of particles: - call getparm(line,mmax,'maxray=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - maxray=nint(bufr(1)) - pmenu(1+mpp(na))=maxray -c allocate space for the particle array, etc: - if(.not.allocated(zblock))call new_particledata - endif -c particle: - call getparm(line,mmax,'particle=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))=cbuf - if(cbuf.eq.'proton')then - achg=1.d0 - pmass=938.27231d6 - endif - if(cbuf.eq.'H+')then - achg=1.d0 - pmass=939.29400d6 - endif - if(cbuf.eq.'electron')then - achg=-1.d0 - pmass=0.511d6 - endif - if(cbuf.eq.'positron')then - achg=1.d0 - pmass=0.511d6 - endif - endif -c mass (read in as GeV, same as MAD): - call getparm(line,mmax,'mass=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmass=bufr(1)*1.d9 - pmenu(6+mpp(na))=pmass - endif -c charge: - call getparm(line,mmax,'charge=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - achg=bufr(1) - pmenu(7+mpp(na))=achg - endif -c energy: - call getparm(line,mmax,'energy=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - energy=bufr(1)*1.d9 - if(pmass.ne.0.d0)then - gamma=energy/pmass - gamm1=gamma-1.d0 - beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma - brho=gamma*beta/clite*pmass - pc=sqrt(energy**2-pmass**2) - ekinetic=energy-pmass - endif - endif -c pc: - call getparm(line,mmax,'pc=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pc=bufr(1)*1.d9 - if(pmass.ne.0.d0)then - energy=sqrt(pc**2+pmass**2) - gamma=energy/pmass - gamm1=gamma-1.d0 - beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma - brho=gamma*beta/clite*pmass - ekinetic=energy-pmass - endif - endif -c gamma: - call getparm(line,mmax,'gamma=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - gamma=bufr(1) - gamm1=gamma-1.d0 - beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma - if(pmass.ne.0.d0)then - brho=gamma*beta/clite*pmass - energy=gamma*pmass - pc=sqrt(energy**2-pmass**2) - ekinetic=energy-pmass - endif - endif -c gamma-1: - call getparm(line,mmax,'gamma1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - gamm1=bufr(1) - gamma=gamm1+1.d0 - beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma - if(pmass.ne.0.d0)then - brho=gamma*beta/clite*pmass - energy=gamma*pmass - pc=sqrt(energy**2-pmass**2) - ekinetic=energy-pmass - endif - endif -c ekinetic: - call getparm(line,mmax,'ekinetic=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - ekinetic=bufr(1)*1.d9 - if(pmass.ne.0.d0)then - gamm1=ekinetic/pmass - gamma= gamm1+1.d0 - beta=sqrt((gamma+1.d0)*(gamma-1.d0))/gamma - brho=gamma*beta/clite*pmass - energy=ekinetic+pmass - pc=sqrt(energy**2-pmass**2) - endif - endif -c brho: - call getparm(line,mmax,'brho=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - brho=bufr(1) - if(gamma.ne.1.d0 .and. beta.ne.0.d0)then - pmass=brho/(gamma*beta/clite) - icompmass=1 -! if(idproc.eq.0)then -! write(6,*)'computed pmass (from brho,gamma,beta) = ',pmass -! endif - energy=gamma*pmass - pc=sqrt(energy**2-pmass**2) - ekinetic=energy-pmass - endif - endif -c store brho,gamma,gamm1,beta in pmenu - pmenu(2+mpp(na))=brho - pmenu(3+mpp(na))=gamma - pmenu(4+mpp(na))=gamm1 - pmenu(5+mpp(na))=beta -c beam current: - call getparm(line,mmax,'bcurr=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - bcurr=bufr(1) - pmenu(8+mpp(na))=bcurr - endif -c beam frequency: - call getparm(line,mmax,'bfreq=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - bfreq=bufr(1) - pmenu(9+mpp(na))=bfreq - bomega=twopi*bfreq - endif -c beam angular frequency: - call getparm(line,mmax,'bomega=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - bomega=bufr(1) - pmenu(10+mpp(na))=bomega - bfreq=bomega/twopi - endif -c print results: - if(idproc.eq.0)then - write(6,*)' ' - write(6,*)'done reading BEAM parameters:' - write(6,'(1x,''brho='',1pd23.16)')brho - write(6, & - &'(1x,''gamma, gamma-1='',1pd23.16,2x,1pd23.16)')gamma,gamm1 - write(6,'(1x,''beta='',1pd23.16)')beta - write(6, & - &'(1x,''energy, ekinetic='',1pe18.11,2x,1pe18.11)')energy,ekinetic - write(6,'(1x,''pc='',1pe18.11)')pc - write(6,'(1x,''mass, charge='',1pe18.11,2x,1pe18.11)')pmass,achg - write(6,'(1x,''beam current='',1pe18.11)')bcurr - write(6,'(1x,''beam frequency='',1pe18.11)')bfreq -c write(6,*)'beam angular freq=',bomega -c write(6,*)'array size=',maxray -c write(6,*)'symbol(1)=',cmenu(1+mppc(na)) -! write(6,*)' ' - if(bcurr.ne.0.d0 .and. bfreq.eq.0.d0)then - write(6,*)'**********************WARNING************************' - write(6,*) & - &'Beam current has been specfied, but the beam rf frequency that' - write(6,*) & - &'defines the total bunch charge, Q=I/freq, has not been specified' - write(6,*)'*****************************************************' - endif -! write(6,*)' ' - endif -cryne 09/20/02 - constr(nconst+1)='brho' - conval(nconst+1)=brho - constr(nconst+2)='gamma' - conval(nconst+2)=gamma - constr(nconst+3)='charge' - conval(nconst+3)=charge - constr(nconst+4)='mass' - conval(nconst+4)=pmass - constr(nconst+5)='beta' - conval(nconst+5)=beta - constr(nconst+6)='energy' - conval(nconst+6)=energy - constr(nconst+7)='ekinetic' - conval(nconst+7)=ekinetic - constr(nconst+8)='pc' - conval(nconst+8)=pc - nconst=nconst+8 -cryne -c--------- -c also set the default units in case the user forgets to use the -c units command later: -!Jan23, 2003 sl=1.d0 -!Jan23, 2003 ts=sl/clite -!Jan23, 2003 omegascl=1.d0/ts -!Jan23, 2003 p0sc=pc -c other stuff: -!Jan23, 2003 magunits=1 -!Jan23, 2003 iverbose=0 -!jan 23, 2003 set p0sc if it has not been set by the user already: -!jan 24, 2003 if(p0sc.eq.0.d0)p0sc=pc -!!!!! if(p0sc.eq.0.d0)p0sc=pc/clite -!!!!! if(idproc.eq.0)write(6,*)'p0sc=pc/clite=',p0sc -!!!!! if(idproc.eq.0)write(6,*)'note also that pc=',pc -! if(idproc.eq.0 )then -! write(6,*)'default scaling variables follow. (Note:' -! write(6,*)'default scaling can be changed using the units command)' -! write(6,*)'scale length, sl=',sl -! write(6,*)'scale time, ts=',ts -! write(6,*)'scale omega, omegascl=',omegascl -! write(6,*)'scale momentum, p0sc=',pc -! write(6,*)'end of reporting of data for BEAM command' -! endif -c--------- -c this does not make sense if the default value for maxray is zero, -c so I have commented it out. -c allocate space for the particle array, etc: -c if(.not.allocated(zblock))call new_particledata -c -cryne March 18, 2004 -c store ref particle data in the default location (location #1) -c in case the user wants to do multiple runs from the same initial values: -c [note: initial reftraj data, refsave(1:6), is set/stored in subroutine tran] - brhosav(1)=brho - gamsav(1)=gamma - gam1sav(1)=gamm1 - betasav(1)=beta - -! Global defautls for wakefields - call readin(line,leof) - if(line(1:9) .ne. 'wakedflt:')then -!cryne write(6,*)'\nWakefield global defaults are not specified' -!cryne write(6,*)'You may specify wakefield global defaults' -!cryne write(6,*)'in the following format' -!cryne write(6,*)'wakedflt: type= nturns= nmodes= r= conduct= ' -!cryne write(6,*)'nx= ny= nz= ndx= ndy= \n' - backspace lf - else - call wake_defaults(line) - endif - - return -c -c -c===================================================================== -c UNITS -c===================================================================== -c units: set scaling variables -748 continue -c defaults: -!Jan23, 2003: now these are set in routine dumpin -!Jan23, 2003 sl=1.d0 -!Jan23, 2003 ts=sl/clite -!Jan23, 2003 omegascl=1.d0/ts -!Jan23, 2003 p0sc=pc - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !scale length - pmenu(2+mpp(na))=0.d0 !scale momentum - pmenu(3+mpp(na))=0.d0 !scale time (sec) - pmenu(4+mpp(na))=0.d0 !scale ang freq (rad/sec) - pmenu(5+mpp(na))=0.d0 !scale freq (Hz) - cmenu(1+mppc(na))=' ' - cmenu(2+mppc(na))=' ' - endif - lflagmagu=.true. - lflagdynu=.false. - itscaleset=0 - ilscaleset=0 - if(idproc.eq.0)then - write(6,*)' ' - write(6,*)'reading UNITS parameters' - endif -c values provided by user: -c type (magnetic, static, or general): - call getparm(line,mmax,'type=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - if( (cbuf.eq.'magnetic') .or. (cbuf.eq.'static') )then - p0sc=gamma*beta*pmass/clite - pmenu(2+mpp(na))=p0sc - cmenu(1+mppc(na))='static' - cmenu(2+mppc(na))='p0' - lflagmagu=.true. - lflagdynu=.false. - if(idproc.eq.0)then - write(6,*)'STATIC UNITS WILL BE USED. p0sc=',p0sc - endif - elseif(cbuf.eq.'dynamic')then - p0sc=pmass/clite - pmenu(2+mpp(na))=p0sc - cmenu(1+mppc(na))='dynamic' - cmenu(2+mppc(na))='mc' - lflagmagu=.false. - lflagdynu=.true. - if(idproc.eq.0)then - write(6,*)'DYNAMIC UNITS WILL BE USED. p0sc=',p0sc - endif - else - cmenu(1+mppc(na))='general' - cmenu(2+mppc(na))='none' - lflagmagu=.false. - lflagdynu=.false. - if(idproc.eq.0)write(6,*)'GENERAL UNITS WILL BE USED.' - endif - endif -! -! momentum: - if(cmenu(1+mppc(na)).ne.'static' .and. & - & cmenu(1+mppc(na)).ne.'magnetic' .and. & - & cmenu(1+mppc(na)).ne.'dynamic')then - call getparm(line,mmax,'p=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - p0sc=bufr(1) - endif - call getparm(line,mmax,'psymbolic=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(2+mppc(na))=cbuf - if(trim(cbuf).eq.'p0')then - pmenu(2+mpp(na))=pc - p0sc=pc - endif - if(trim(cbuf).eq.'mc')then - pmenu(2+mpp(na))=pmass/clite - p0sc=pmass/clite - endif - endif - if(pmenu(2+mpp(na)).eq.0.d0)then - if(idproc.eq.0)then - write(6,*)'ERROR: general units are being used but the' - write(6,*)'scale momentum has not been specified; halting' - call myexit - endif - endif - endif - -! length: - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(1+mpp(na))=bufr(1) - sl=bufr(1) - ilscaleset=1 - else - if(idproc.eq.0)then - write(6,*)'WARNING: scale length has not been specified' - endif - endif -! time: - call getparm(line,mmax,'w=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - omegascl=bufr(1) - ts=1.d0/omegascl - freqscl=omegascl/twopi - itscaleset=1 - endif - call getparm(line,mmax,'f=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - freqscl=bufr(1) - omegascl=twopi*freqscl - ts=1.d0/omegascl - itscaleset=1 - endif - call getparm(line,mmax,'t=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - ts=bufr(1) - omegascl=1.d0/ts - freqscl=omegascl/twopi - itscaleset=1 - endif - if(itscaleset.eq.0)then - if(idproc.eq.0)then - write(6,*)'WARNING: scale time has not been specified' - endif - endif -! choose some sensible defaults for data that have not been provided: - if(itscaleset.eq.0 .and. ilscaleset.eq.0)then -! if(idproc.eq.0)then -! write(6,*)'neither the scale length nor the scale time have ', & -! & 'been specified' -! endif -! static/magnetic: - if(bfreq.eq.0.d0)then - if(idproc.eq.0)write(6,*)'setting sl=1, omega=clite/sl' - sl=1.d0 - omegascl=clite/sl - ts=1.d0/omegascl - freqscl=omegascl/twopi - endif -! dynamic: - if(bfreq.ne.0.d0)then - if(idproc.eq.0)then - write(6,*)'setting scalefreq=beamfreq, l=c/omega' - endif - freqscl=bfreq - omegascl=twopi*freqscl - ts=1.d0/omegascl - sl=clite/omegascl - endif - elseif(ilscaleset.eq.0)then - if(idproc.eq.0)then - write(6,*)'The scale length has not been specified' - write(6,*)'Setting sl=clite/omega=',clite/omegascl - endif - sl=clite/omegascl - elseif(itscaleset.eq.0)then - if(idproc.eq.0)then - write(6,*)'The scale time has not been specified' - write(6,*)'Setting omegascl=clite/sl=',clite/sl - endif - omegascl=clite/sl - ts=1.d0/omegascl - freqscl=omegascl/twopi - endif -! -c print results: - if(idproc.eq.0)then - write(6,*)'done reading UNITS parameters:' - write(6,'(1x,''scale length (m) ='',1pe18.11)')sl - write(6,'(1x,''scale momentum ='',1pe18.11)')p0sc - write(6,'(1x,''scale time (sec)='',1pe18.11)')ts - write(6,'(1x,''scale freq (Hz)='',1pe18.11)')freqscl - write(6,'(1x,''scale angular freq (rad/sec)='',1pe18.11)')omegascl -! write(6,*)'symbol(1)=',cmenu(1+mppc(na)) -! write(6,*)'symbol(2)=',cmenu(2+mppc(na)) - write(6,*)' ' - endif - return -c -c===================================================================== -c AUTOSLICE -c===================================================================== -c autoslice -c -749 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !slices=N - pmenu(2+mpp(na))=0.d0 !l= - cmenu(1+mppc(na))='local' !control="local", "global", or "none" - cmenu(2+mppc(na))='false' !sckick="true" or "false"; determines -c !if a space charge kick will be performed -c !automatically in the middle of each slice - cmenu(3+mppc(na))='false' !includemlstyle="true" or "false" - endif -c values provided by user: -!slices: - call getparm(line,mmax,'slices=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(1+mpp(na))=bufr(1) - endif -!l (interval between slices): - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(2+mpp(na))=bufr(1) - endif -!control: - localcontrol=0 - call getparm(line,mmax,'control=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))=cbuf - if(cbuf.eq.'local')localcontrol=1 - endif -!sckick: - call getparm(line,mmax,'sckick=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(2+mppc(na))=cbuf - endif -!includemlstyle: - inclmlstyle=0 - call getparm(line,mmax,'includemlstyle=',bufr,keypres,numpres, & - & 1,cbuf) - if(keypres.and.numpres)then - cmenu(3+mppc(na))=cbuf - if(cbuf.eq.'true')inclmlstyle=1 - endif -! -! Dec 3, 2002: -! Augment parameter lists for old-style MaryLie input to include # of slices. -! Note that includemlstyle appears to be no longer needed; instead I just -! force it to be enabled if the user specifies local control. -! However, I have left the code in place in case it is needed later. - if(localcontrol.eq.1 .or. inclmlstyle.eq.1)call sliceml -! -! if(idproc.eq.0)then -! write(6,*)'(routine lmntparm) results from AUTOSLICE command:' -! write(6,*)'slices=',pmenu(1+mpp(na)),'l=',pmenu(2+mpp(na)) -! write(6,*)'control=',cmenu(1+mppc(na)) -!!!!!!write(6,*)'sckick=',cmenu(2+mppc(na)) -! endif - return -c -c===================================================================== -c VERBOSE -c===================================================================== -c autoslice -c -750 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 - endif -c values provided by user: - call getparm(line,mmax,'iverbose=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pmenu(1+mpp(na))=bufr(1) - iverbose=nint(bufr(1)) - endif - if(idproc.eq.0 .and. iverbose.ge.1)then - write(6,*)'(routine lmntparm) results from VERBOSE command:' - write(6,*)'iverbose=',iverbose - endif - return -c -c mask6: -cryne 12/31/2004 mask6 now appears to be unecessary. -751 continue - return -c -c arcreset -752 continue - return -c -c symbdef -753 continue - isymbdef=1 - if(idproc.eq.0)then - write(6,*)'SYMBDEF: from now on symbolic names that appear in' - write(6,*)'arithmetic expressions will have default value 0' - endif - return -c -c===================================================================== -c PARTICLEDUMP -c===================================================================== -c particledump: -754 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !min= : ... - pmenu(2+mpp(na))=0.d0 !max= : to print particles # min to max - pmenu(3+mpp(na))=0.d0 !sequencelength (=max # of files in sequence) - pmenu(4+mpp(na))=5.d0 !precision - pmenu(5+mpp(na))=0.d0 !assigned unit# for output file (or can be read in) - pmenu(6+mpp(na))=0.d0 !assigned counter for sequence of files - pmenu(7+mpp(na))=1.d0 !nunits (=0 for dimensionless; =1 for physical) - cmenu(1+mppc(na))=' ' !file= : name of output file - cmenu(2+mppc(na))='true' !close= : flag to close output file - cmenu(3+mppc(na))='false' !flush= : flag to flush output file - cmenu(4+mppc(na))='false' !printarc=:flag to print arc length in column 1 - endif -c values provided by user: - call getparm(line,mmax,'min=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'max=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'sequencelength=',bufr,keypres,numpres, & - & 0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'unit=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) - call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'close=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(3+mppc(na))=cbuf - endif - call getparm(line,mmax,'printarc=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(4+mppc(na))=cbuf - endif -! if(idproc.eq.0)then -! write(6,*)'(lmntparm) results from PARTICEDUMP sif input:' -! write(6,*)'min=',pmenu(1+mpp(na)) -! write(6,*)'max=',pmenu(2+mpp(na)) -! write(6,*)'sequencelength=',pmenu(3+mpp(na)) -! write(6,*)'precision=',pmenu(4+mpp(na)) -! write(6,*)'unit=',pmenu(5+mpp(na)) -! write(6,*)'sequence counter=',pmenu(6+mpp(na)) -! write(6,*)'file=',cmenu(1+mppc(na)) -! write(6,*)'close=',cmenu(2+mppc(na)) -! write(6,*)'flush=',cmenu(3+mppc(na)) -! endif - return -c -c -c===================================================================== -c RAYTRACE -c===================================================================== -c raytrace: -755 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !min= : ... - pmenu(2+mpp(na))=0.d0 !max= : to print particles # min to max - pmenu(3+mpp(na))=5. !norder - pmenu(4+mpp(na))=1. !ntrace - pmenu(5+mpp(na))=1. !nwrite - pmenu(6+mpp(na))=0. !ibrief - pmenu(7+mpp(na))=0. !sequencelength (=max # of files in sequence) - pmenu(8+mpp(na))=6. !precision - pmenu(9+mpp(na))=0. !assigned unit# for initial condition file - pmenu(10+mpp(na))=0. !assigned unit# for final condition file - pmenu(11+mpp(na))=0.d0 !assigned counter for sequence of files - pmenu(12+mpp(na))=0.d0 !nrays=# to read when reading from data file - cmenu(1+mppc(na))=' ' !name of initial condition file - cmenu(2+mppc(na))=' ' !name of final condition file - cmenu(3+mppc(na))='false' !flag to close final condition file - cmenu(4+mppc(na))='false' !flag to flush final condition file - cmenu(5+mppc(na))='undefined' !alternate way to specify track type&order - endif -c values provided by user: - call getparm(line,mmax,'min=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'max=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'order=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'ibrief=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - call getparm(line,mmax,'sequencelength=',bufr,keypres,numpres,0, & - & cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) - call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) - call getparm(line,mmax,'unit1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) - call getparm(line,mmax,'unit2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) - call getparm(line,mmax,'nrays=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) -c - call getparm(line,mmax,'file1=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'file2=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - call getparm(line,mmax,'close=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(3+mppc(na))=cbuf - endif - call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(4+mppc(na))=cbuf - endif -c type: - call getparm(line,mmax,'type=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(5+mppc(na))=cbuf - if(cbuf.eq.'readonly')then -c change defaults: - pmenu(4+mpp(na))=0. !ntrace - pmenu(5+mpp(na))=0. !nwrite - endif - endif -c ntrace, nwrite: - call getparm(line,mmax,'ntrace=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'nwrite=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - return -c -c -c===================================================================== -c AUTOTRACK -c===================================================================== -c autotrack -756 continue -c defaults: - if(initparms.eq.1)then - cmenu(1+mppc(na))='true' !set - cmenu(2+mppc(na))='undefined' !type (taylorN, symplecticN, undefined) - cmenu(3+mppc(na))='undefined' !sckick (true,false) - cmenu(4+mppc(na))='false' !env (true,false) - endif -c set: - call getparm(line,mmax,'set=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))=cbuf - else - call getparm(line,mmax,'true',bufr,keypres,numpres,1,cbuf) - if(keypres)cmenu(1+mppc(na))='true' - call getparm(line,mmax,'false',bufr,keypres,numpres,1,cbuf) - if(keypres)cmenu(1+mppc(na))='false' - endif -c type: - call getparm(line,mmax,'type=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(2+mppc(na))=cbuf - endif -c sckick: - call getparm(line,mmax,'sckick=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(3+mppc(na))=cbuf - endif -c env: - call getparm(line,mmax,'env=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(4+mppc(na))=cbuf - endif -c -c if(idproc.eq.0)then -c write(6,*)'(sif) results of autotrack input:' -c write(6,*)'set= ',cmenu(1+mppc(na)) -c write(6,*)'type= ',cmenu(2+mppc(na)) -c write(6,*)'sckick= ',cmenu(3+mppc(na)) -c write(6,*)'env= ',cmenu(4+mppc(na)) -c endif - return -c -c===================================================================== -c SCKICK -c===================================================================== -c sckick -757 continue - return -c -c===================================================================== -c MOMENTS -c===================================================================== -c moments: -758 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !assigned unit# for xfile - pmenu(2+mpp(na))=0.d0 !assigned unit# for yfile - pmenu(3+mpp(na))=0.d0 !assigned unit# for tfile - pmenu(4+mpp(na))=5.d0 !precision - pmenu(5+mpp(na))=1.d0 !nunits (=0 for dimensionless; =1 for physical) - cmenu(1+mppc(na))='xrms.out' !name of xfile - cmenu(2+mppc(na))='yrms.out' !name of yfile - cmenu(3+mppc(na))='trms.out' !name of tfile - cmenu(4+mppc(na))='true' !flag to flush xfile - cmenu(5+mppc(na))='true' !flag to flush yfile - cmenu(6+mppc(na))='true' !flag to flush tfile - cmenu(7+mppc(na))='ratio' !crossterm [ or /(xrms*pxrms)] - cmenu(8+mppc(na))='false' !set to true to divide emittances by pi - cmenu(9+mppc(na))='keep' !flag to keep/remove beam centroid - endif -c values provided by user: - call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) -c - call getparm(line,mmax,'xfile=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'yfile=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - call getparm(line,mmax,'tfile=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(3+mppc(na))=cbuf - endif - call getparm(line,mmax,'xflush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(4+mppc(na))=cbuf - endif - call getparm(line,mmax,'yflush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(5+mppc(na))=cbuf - endif - call getparm(line,mmax,'tflush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(6+mppc(na))=cbuf - endif - call getparm(line,mmax,'crossterm=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(7+mppc(na))=cbuf - endif - call getparm(line,mmax,'includepi=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(8+mppc(na))=cbuf - endif - call getparm(line,mmax,'centroid=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(9+mppc(na))=cbuf - endif - return -c -c -c -c===================================================================== -c MAXSIZE -c===================================================================== -c maxsize: -759 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !assigned unit# for output file 1 - pmenu(2+mpp(na))=0.d0 !assigned unit# for output file 2 - pmenu(3+mpp(na))=0.d0 !assigned unit# for output file 3 - pmenu(4+mpp(na))=0.d0 !assigned unit# for output file 4 - pmenu(5+mpp(na))=5.d0 !precision - pmenu(6+mpp(na))=1.d0 !nunits (=0 for dimensionless; !=0 for physical) - cmenu(1+mppc(na))=' ' !name of output file 1 - cmenu(2+mppc(na))=' ' !name of output file 2 - cmenu(3+mppc(na))=' ' !name of output file 3 - cmenu(4+mppc(na))=' ' !name of output file 4 - cmenu(5+mppc(na))='true' !flag to flush output file 1 - cmenu(6+mppc(na))='true' !flag to flush output file 2 - cmenu(7+mppc(na))='true' !flag to flush output file 3 - cmenu(8+mppc(na))='true' !flag to flush output file 4 - cmenu(9+mppc(na))='automatic' !flag to use 'standard' file names - endif -c values provided by user: - call getparm(line,mmax,'unit1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'unit2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'unit3=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'unit4=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) -c - call getparm(line,mmax,'file1=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'file2=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - call getparm(line,mmax,'file3=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(3+mppc(na))=cbuf - endif - call getparm(line,mmax,'file4=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(4+mppc(na))=cbuf - endif - call getparm(line,mmax,'flush1=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(5+mppc(na))=cbuf - endif - call getparm(line,mmax,'flush2=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(6+mppc(na))=cbuf - endif - call getparm(line,mmax,'flush3=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(7+mppc(na))=cbuf - endif - call getparm(line,mmax,'flush4=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(8+mppc(na))=cbuf - endif - call getparm(line,mmax,'files=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(9+mppc(na))=cbuf - endif - return -c -c===================================================================== -c REFTRAJ -c===================================================================== -c reftraj: -760 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !assigned unit# for output file - pmenu(2+mpp(na))=5.d0 !precision - pmenu(3+mpp(na))=1.d0 !nunits (=0 for dimensionless; !=0 for physical) - cmenu(1+mppc(na))='reftraj.out' !name of output file - cmenu(2+mppc(na))='true' !flag to flush output file - endif -c values provided by user: - call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) -c - call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - return -c===================================================================== -c INITENV -c===================================================================== -c initenv (initialize rms envelopes): -761 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 ! x= - pmenu(2+mpp(na))=0.d0 ! px= - pmenu(3+mpp(na))=0.d0 ! xpx= - pmenu(4+mpp(na))=0.d0 ! xemit= - pmenu(5+mpp(na))=0.d0 ! y= - pmenu(6+mpp(na))=0.d0 ! py= - pmenu(7+mpp(na))=0.d0 ! ypy= - pmenu(8+mpp(na))=0.d0 ! yemit= - pmenu(9+mpp(na))=0.d0 ! t= - pmenu(10+mpp(na))=0.d0 ! pt= - pmenu(11+mpp(na))=0.d0 ! tpt= - pmenu(12+mpp(na))=0.d0 ! temit= - pmenu(13+mpp(na))=0.d0 ! cpx= - pmenu(14+mpp(na))=0.d0 ! cpy= - pmenu(15+mpp(na))=0.d0 ! cpt= - cmenu(1+mppc(na))='ratio' !crossterm [ or /(xrms*pxrms)] - endif -c values provided by user: - call getparm(line,mmax,'x=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'px=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'xpx=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'xemit=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'y=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'py=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - call getparm(line,mmax,'ypy=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) - call getparm(line,mmax,'yemit=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) - call getparm(line,mmax,'t=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) - call getparm(line,mmax,'pt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) - call getparm(line,mmax,'tpt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) - call getparm(line,mmax,'temit=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) - call getparm(line,mmax,'cpx=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(13+mpp(na))=bufr(1) - call getparm(line,mmax,'cpy=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(14+mpp(na))=bufr(1) - call getparm(line,mmax,'cpt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(15+mpp(na))=bufr(1) - call getparm(line,mmax,'crossterm=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - return -c -c===================================================================== -c ENVELOPES -c===================================================================== -c envelopes: -762 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !assigned unit# for xfile - pmenu(2+mpp(na))=0.d0 !assigned unit# for yfile - pmenu(3+mpp(na))=0.d0 !assigned unit# for tfile - pmenu(4+mpp(na))=5.d0 !precision - pmenu(5+mpp(na))=1.d0 !nunits (=0 for dimensionless; =1 for physical) - cmenu(1+mppc(na))='xenv.out' !name of xfile - cmenu(2+mppc(na))='yenv.out' !name of yfile - cmenu(3+mppc(na))='tenv.out' !name of tfile - cmenu(4+mppc(na))='true' !flag to flush xfile - cmenu(5+mppc(na))='true' !flag to flush yfile - cmenu(6+mppc(na))='true' !flag to flush tfile - cmenu(7+mppc(na))='ratio' !crossterm [ or /(xrms*pxrms)] - endif -c values provided by user: - call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) -c - call getparm(line,mmax,'xfile=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'yfile=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - call getparm(line,mmax,'tfile=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(3+mppc(na))=cbuf - endif - call getparm(line,mmax,'xflush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(4+mppc(na))=cbuf - endif - call getparm(line,mmax,'yflush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(5+mppc(na))=cbuf - endif - call getparm(line,mmax,'tflush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(6+mppc(na))=cbuf - endif - call getparm(line,mmax,'crossterm=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(7+mppc(na))=cbuf - endif - return -c -c===================================================================== -c CONTRACTENV -c===================================================================== -c contractenv (apply contraction map to rms envelopes): -763 continue - return -c -c===================================================================== -c SETREFTRAJ -c===================================================================== -764 continue - if(initparms.eq.1)then - pmenu(1+mpp(na)) =0.d0 ! x= - pmenu(2+mpp(na)) =0.d0 ! px= - pmenu(3+mpp(na)) =0.d0 ! y= - pmenu(4+mpp(na)) =0.d0 ! py= - pmenu(5+mpp(na)) =0.d0 ! t= - pmenu(6+mpp(na)) =0.d0 ! pt= - pmenu(7+mpp(na)) =-9999.d0 ! s= - pmenu(8+mpp(na)) =0.d0 ! sto= - pmenu(9+mpp(na)) =0.d0 ! get= - pmenu(10+mpp(na))=0.d0 ! write= - cmenu(1+mppc(na))='false' !restart= true/false -! resets to values -! stored in loc 1, which contain values from -! start of run (unless overwritten by user)] - cmenu(2+mppc(na))='true' !includearc=true/false [used w/ sto,get] - endif -c values provided by user: - call getparm(line,mmax,'x=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'px=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'y=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'py=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'t=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'pt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - call getparm(line,mmax,'arclen=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) -c sto: - call getparm(line,mmax,'sto=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) - if(bufr(1).le.0 .or. bufr(1).ge.9)then - if(idproc.eq.0)then - write(6,*)'setreftraj error: sto must be in (1,...,8)' - endif - call myexit - endif -c get: - call getparm(line,mmax,'get=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) - if(bufr(1).le.0 .or. bufr(1).ge.9)then - if(idproc.eq.0)then - write(6,*)'setreftraj error: get must be in (1,...,8)' - endif - call myexit - endif -c - call getparm(line,mmax,'write=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) -c - call getparm(line,mmax,'restart=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'includearc=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - return -c -c===================================================================== -c SETARCLEN -c===================================================================== -765 continue - if(initparms.eq.1)then - pmenu(1+mpp(na)) =0.d0 ! s= - pmenu(2+mpp(na))=0.d0 ! write= - cmenu(1+mppc(na))='false' !restart= true/false - endif -c values provided by user: - call getparm(line,mmax,'s=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'write=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) -c - call getparm(line,mmax,'restart=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - return -c -c===================================================================== -c WAKEDEFAULT -c===================================================================== -766 continue - if(idproc.eq.0)then - write(6,*)'CODE UNDER DEVELOPMENT. POSSIBLY PUT WAKEDEFAULT HERE' - endif - return -c -c===================================================================== -c EMITTANCE -c===================================================================== -c emittance: -767 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !assigned unit# for file - pmenu(2+mpp(na))=5.d0 !precision - pmenu(3+mpp(na))=1.d0 !nunits (=0 for dimensionless; =1 for physical) - cmenu(1+mppc(na))='true' !flag to compute 2-D emittances - cmenu(2+mppc(na))='true' !flag to compute 4-D transverse emittance - cmenu(3+mppc(na))='false' !flag to compute 6-D emittance - cmenu(4+mppc(na))='keep' !flag to keep/remove beam centroid - cmenu(5+mppc(na))='emitrms.out' !name of output file - cmenu(6+mppc(na))='true' !flag to flush output file - endif -c values provided by user: - call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'nunits=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) -c - call getparm(line,mmax,'2d=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'4d=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - call getparm(line,mmax,'6d=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(3+mppc(na))=cbuf - endif - call getparm(line,mmax,'centroid=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(4+mppc(na))=cbuf - endif - call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(5+mppc(na))=cbuf - endif - call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(6+mppc(na))=cbuf - endif - return -c -c===================================================================== -c MATCHENV -c===================================================================== -768 continue - if(initparms.eq.1)then - pmenu(1+mpp(na)) =10.d0 ! iterations= - pmenu(2+mpp(na)) =1.d-8 ! tolerance= - cmenu(1+mppc(na))=' ' ! name= - endif - call getparm(line,mmax,'iterations=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'tolerance=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'name=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - cmenu(1+mppc(na))=cbuf - endif - return -c -c===================================================================== -c FILEINFO -c (controls printing of file open/close info) -c===================================================================== -769 continue - if(initparms.eq.1)then - pmenu(1+mpp(na)) =0. ! info= - endif - call getparm(line,mmax,'info=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - return -c -c===================================================================== -c EGENGRAD -c===================================================================== -c egengrad: -770 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=0.d0 !assigned unit# for output file - pmenu(2+mpp(na))=0.d0 !zstart - pmenu(3+mpp(na))=0.d0 !zend - pmenu(4+mpp(na))=1.d0 !nz (intervals) - pmenu(5+mpp(na))=0.d0 !frequency - pmenu(6+mpp(na))=0.d0 !radius - pmenu(7+mpp(na))=3.d2 !kmax - pmenu(8+mpp(na))=3.d3 !nk (intervals) - pmenu(9+mpp(na))=0.d0 !infiles - pmenu(10+mpp(na))=5.d0 !precision - cmenu(1+mppc(na))='rfdata' ! name of input datafile - cmenu(2+mppc(na))='crz.dat' ! name of output datafile - cmenu(3+mppc(na))='true' ! flag to flush output file(s) - cmenu(4+mppc(na))='e0.dat' ! name of optional output datafile - cmenu(5+mppc(na))='false' ! flag to (not) write char. fns. - cmenu(6+mppc(na))='t7' ! E-field file type - cmenu(7+mppc(na))=' ' ! name of optional E-field diagnos. - endif -c values provided by user: -cp2 - call getparm(line,mmax,'zstart=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) -cp3 - call getparm(line,mmax,'zend=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) -cp4 - call getparm(line,mmax,'nz=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) -cp5 - call getparm(line,mmax,'frequency=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) -cp6 - call getparm(line,mmax,'radius=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) -cp7 - call getparm(line,mmax,'kmax=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) -cp8 - call getparm(line,mmax,'nk=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) -cp9 - call getparm(line,mmax,'infiles=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) -cp10 - call getparm(line,mmax,'precision=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) -cc1 - call getparm(line,mmax,'efile=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif -cc2 - call getparm(line,mmax,'crzfile=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif -cc3 - call getparm(line,mmax,'flush=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(3+mppc(na))=cbuf - endif -cc4 - call getparm(line,mmax,'charfile=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(4+mppc(na))=cbuf - endif -cc5 - call getparm(line,mmax,'wrtchar=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(5+mppc(na))=cbuf - endif -cc6 - call getparm(line,mmax,'ftype=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(6+mppc(na))=cbuf - endif -cc7 - call getparm(line,mmax,'ediag=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(7+mppc(na))=cbuf - endif - return -c -c===================================================================== -c WRTMAP: Write Map to File (KMP: 8 Nov 2006) -c===================================================================== -c -771 continue -c -c Initialized Parameters to default values (in case they are not specified): - if(initparms.eq.1)then - cmenu(1+mppc(na))='map.dat' ! name of file for map write - cmenu(2+mppc(na))='lastslice' ! kind of write: accumulated, lastslice - cmenu(3+mppc(na))='append' ! iostatus of write to file: overwrite, append - endif -c -c Get file name for map write: - call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif -c -c Get kind of write to perform: - call getparm(line,mmax,'kind=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif -c -c Get iostatus of write: - call getparm(line,mmax,'iostat=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(3+mppc(na))=cbuf - endif - return -c -c===================================================================== -c RDMAP: Read a Map from File (KMP: 14 Dec 2006) -c===================================================================== -c -772 continue -c -c Initialized Parameters to default values (in case they are not specified): - if(initparms.eq.1)then - cmenu(1+mppc(na))='map.dat' ! name of file for map read - cmenu(2+mppc(na))='true' ! name of file for map read - endif -c -c Get file name for map write: - call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif -c -c Get rewind information - call getparm(line,mmax,'rewind=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - return - -c===================================================================== -c SPARES TYPE CODES -c===================================================================== - -773 continue -774 continue -775 continue - return -c -c -c 8: advanced commands ******************************** -c -c 'cod ','amap ','dia ','dnor ','exp ', -18 go to (801, 802, 803, 804, 805, -c 'pdnf ','psnf ','radm ','rasm ','sia ', - & 806, 807, 808, 809, 810, -c 'snor ','tadm ','tasm ','tbas ','gbuf ', - & 811, 812, 813, 814, 815, -c 'trsa ','trda ','smul ','padd ','pmul ', - & 816, 817, 818, 819, 820, -c 'pb ','pold ','pval ','fasm ','fadm ', - & 821, 822, 823, 824, 825, -c 'sq ','wsq ','ctr ','asni ','pnlp ', - & 826, 827, 828, 829, 830, -c 'csym ','psp ','mn ','bgen ','tic ', - & 831, 832, 833, 834, 835, -c 'ppa ','moma ','geom ','fwa '/ - & 836, 837, 838, 839),kt2 -c -c off-momentum closed orbit analysis -c -801 continue - return -c -c apply map to a function or moments -c -802 continue - return -c -c dynamic invariant analysis -c -803 continue - return -c -c dynamic normal form analysis -c -804 continue - return -c -c compute exponential -c -805 continue - return -c -c compute power of dynamic normal form -c -806 continue - return -c -c compute power of static normal form -c -807 continue - return -c -c resonance analyze dynamic map -c -808 continue - return -c -c resonance analyze static map -c -809 continue - return -c -c static invariant ayalysis -c -810 continue - return -c -c static normal form analysis -c -811 continue - return -c -c twiss analyze dynamic map -c -812 continue - return -c -c 'tasm': twiss analyze static map -813 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=2 - pmenu(2+mpp(na))=1.d-3 - pmenu(3+mpp(na))=1 - pmenu(4+mpp(na))=0 - pmenu(5+mpp(na))=3 - pmenu(6+mpp(na))=0 - endif -c values provided by user: - call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'delta=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'idata=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'ipmaps=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'iwmaps=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - return -c -c translate basis -c -814 continue - return -c -c get buffer contents -c -815 continue - return -c -c transport static (script) A -c -816 continue - return -c -c transport dynamic script A -c -817 continue - return -c -c multiply polynomial by a scalar -c -818 continue - return -c -c add two polynomials -c -819 continue - return -c -c multiply two polynomials -c -820 continue - return -c -c Poisson bracket two polynomials -c -821 continue -c defaults: - if(initparms.eq.1)then - pmenu(1+mpp(na))=1. !map1in - pmenu(2+mpp(na))=2. !map2in - pmenu(3+mpp(na))=0. !mapout - endif -c values provided by user: - call getparm(line,mmax,'map1in=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'map2in=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'mapout=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - return -c -c polar decompose matrix portion of transfer map -c -822 continue - return -c -c evaluate a polynomial -c -823 continue - return -c -c fourier analyze static map -c -824 continue - return -c -c fourier analyze dynamic map -c -825 continue - return -c -c select quantities -c -826 continue - return -c -c write selected quantities -c -827 continue - return -c -c change tune ranges -c -828 continue - return -c -c apply script N inverse -c -829 continue - return -c -c compute power of nonlinear part -c -830 continue - return -c -c check for symplecticity -c -831 continue - return -c -c (psp) compute scalar product of two polynomials -c -832 continue - return -c -c (mn) compute matrix norm -c -833 continue - return -c -c===================================================================== -c BGEN -c===================================================================== -c (bgen) generate a beam -834 continue -c write(6,*)'HERE I AM AT BGEN; MMAX=',mmax, ' LINE(1:800)=' -c write(6,*)line(1:800) - write(6,*)'getting bgen parameters in sif.f' -c defaults: - if(initparms.eq.1)then - job=6 - iopt=1 - nray=10000 - iseed=1234567 - isend=3 - ipset=0 - xx=1.d-3 - yy=1.d-3 - tt=1.d-3 - sigmax=5.d0 - unit1=0 - unit2=0 - pmenu(1+mpp(na))=job !this is called 'dist' by the parser - pmenu(2+mpp(na))=iopt - pmenu(3+mpp(na))=nray !this is called 'maxray' by the parser - pmenu(4+mpp(na))=iseed - pmenu(5+mpp(na))=isend - pmenu(6+mpp(na))=ipset - pmenu(7+mpp(na))=xx - pmenu(8+mpp(na))=yy - pmenu(9+mpp(na))=tt - pmenu(10+mpp(na))=sigmax - pmenu(11+mpp(na))=unit1 - pmenu(12+mpp(na))=unit2 - cmenu(1+mppc(na))=' ' - cmenu(2+mppc(na))=' ' - endif -c values provided by user: - call getparm(line,mmax,'dist=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'maxray=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'iseed=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'ipset=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - call getparm(line,mmax,'xx=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(7+mpp(na))=bufr(1) - call getparm(line,mmax,'yy=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(8+mpp(na))=bufr(1) - call getparm(line,mmax,'tt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(9+mpp(na))=bufr(1) - call getparm(line,mmax,'sigmax=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(10+mpp(na))=bufr(1) -c - call getparm(line,mmax,'unit1=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(11+mpp(na))=bufr(1) - call getparm(line,mmax,'unit2=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(12+mpp(na))=bufr(1) -c - call getparm(line,mmax,'file1=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(1+mppc(na))=cbuf - endif - call getparm(line,mmax,'file2=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - call quotechk(cbuf,16) - cmenu(2+mppc(na))=cbuf - endif - return -c -c (tic) translate (move) initial conditions -c -835 continue - return -c -c (ppa) principal planes analysis -c -836 continue - return -c -c (moma) moment and map analysis -c -837 continue - return -c -c (geom) compute geometry of a loop -c -838 continue - return -c -c (fwa) copy file to working array -c -839 continue - return -c -c 9: procedures and fitting and optimization ************************* -c -c 'bip ','bop ','tip ','top ', -19 go to (901, 902, 903, 904, -c 'aim ','vary ','fit ','opt ', - & 905, 906, 907, 908, -c 'con1 ','con2 ','con3 ','con4 ','con5 ', - & 909, 910, 911, 912, 913, -c 'mrt0 ', - & 914, -c 'mrt1 ','mrt2 ','mrt3 ','mrt4 ','mrt5 ', - & 915, 916, 917, 918, 919, -c 'fps ', - & 920, -c 'cps1 ','cps2 ','cps3 ','cps4 ','cps5 ', - & 921, 922, 923, 924, 925, -c 'cps6 ','cps7 ','cps8 ','cps9 ', - & 926, 927, 928, 929, -c 'dapt ','grad ','rset ','flag ','scan ', - & 930, 931, 932, 933, 934, -c 'mss ','spare1 ','spare2 '/ - & 935, 936, 937),kt2 -c begin procedures -c -c===================================================================== -c BIP -c===================================================================== -c 'bip ': begin inner procedure -901 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=10. !ntimes - endif - call getparm(line,mmax,'ntimes=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - return -c -c===================================================================== -c BOP -c===================================================================== -c 'bop ': begin outer procedure -902 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=10. !ntimes - endif - call getparm(line,mmax,'ntimes=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - return -c -c===================================================================== -c TIP -c===================================================================== -c 'tip ': terminate inner procedure -903 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=1. !iopt - endif - call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - return -c -c===================================================================== -c TOP -c===================================================================== -c 'tip ': terminate outer procedure -904 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=1. !iopt - endif - call getparm(line,mmax,'iopt=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - return -c -c end procedures -c -c -c specify aims -c -c===================================================================== -c AIM -c===================================================================== -c 'aim ': specify quantities to be fit/optimized and set target values -905 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=2. !job - pmenu(2+mpp(na))=0. !infile - pmenu(3+mpp(na))=0. !logfile - pmenu(4+mpp(na))=0. !iquiet - pmenu(5+mpp(na))=0. !istore - pmenu(6+mpp(na))=1. !isend - endif - call getparm(line,mmax,'job=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'infile=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'logfile=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'iquiet=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'istore=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - return -c -c specify quantities to be varied -c -c===================================================================== -c VARY -c===================================================================== -c 'vary ': specify quantities to be varied -906 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=1. !job - pmenu(2+mpp(na))=0. !infile - pmenu(3+mpp(na))=0. !logfile - pmenu(4+mpp(na))=0. !isb (scaling and bounds) - pmenu(5+mpp(na))=0. !istore - pmenu(6+mpp(na))=1. !isend - endif - call getparm(line,mmax,'job=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'infile=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'logfile=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'isb=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'istore=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - return -c -c===================================================================== -c FIT -c===================================================================== -c 'fit ': fit to achieve aims -907 continue - if(initparms.eq.1)then - pmenu(1+mpp(na))=10. !job - pmenu(2+mpp(na))=1. !aux - pmenu(3+mpp(na))=1.d-8 !error - pmenu(4+mpp(na))=1.d-3 !delta - pmenu(5+mpp(na))=0. !mprint - pmenu(6+mpp(na))=1. !isend - endif - call getparm(line,mmax,'job=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(1+mpp(na))=bufr(1) - call getparm(line,mmax,'aux=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(2+mpp(na))=bufr(1) - call getparm(line,mmax,'error=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(3+mpp(na))=bufr(1) - call getparm(line,mmax,'delta=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(4+mpp(na))=bufr(1) - call getparm(line,mmax,'mprint=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(5+mpp(na))=bufr(1) - call getparm(line,mmax,'isend=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)pmenu(6+mpp(na))=bufr(1) - return -c -c -c optimize -c -908 continue - return -c -c constraints -c -909 continue - return -910 continue - return -911 continue - return -912 continue - return -913 continue - return -c -c merit functions -c -c least squares merit function -c -914 continue - return -c -c user supplied merit functions -c -915 continue - return -916 continue - return -917 continue - return -918 continue - return -919 continue - return -c -c free parameter sets -c -920 continue - return -c -c capture parameter sets -c -921 continue - return -922 continue - return -923 continue - return -924 continue - return -925 continue - return -926 continue - return -927 continue - return -928 continue - return -929 continue - return -c -c compute dynamic aperture (dapt) -c -930 continue - return -c -c gradient (grad) -c -931 continue - return -c -c rset -c -932 continue - return -c -c flag -c -933 continue - return -c -c scan -c -934 continue - return -c -c mss -c -935 continue - return -c -c spare1 - -936 continue - return -c -c spare2 - -937 continue - return - return - end -c - subroutine getparm(line,mmax,kywrd,bufr,keypres,numpres,iopt,cbuf) -c "string" has to be long enough to hold a single number or expression - use parallel, only : idproc - use acceldata - include 'impli.inc' - include 'files.inc' -cryne 7/15/2002 parameter (nstrmax=80) -c nstrmax=80 should be sufficient for most purposes. The only reason -c to make it longer is if there is an arithmetic (symbolic) expression -c that extends over several lines. So, just in case, set nstrmax=800 - parameter (nstrmax=800) - character (len=*) line - character(len=nstrmax) string - character(len=*) kywrd - character(len=*) cbuf - logical keypres,numpres - dimension bufr(1) - character*16 symb(50) - integer istrtsym(50) - common/showme/iverbose - - keylen=len(kywrd) - if(kywrd(1:keylen).eq.'=')then - n1=index(line,kywrd) - goto 500 - endif -c-------------------------------- - if(iverbose.eq.2 .and. idproc.eq.0)then - write(6,*)'[getparm] kywrd=',kywrd(1:keylen),', line(1:',mmax,')=' - write(6,*)line(1:mmax) - endif -cccc n1=index(line,kywrd) - call getsymb(line,mmax,symb,istrtsym,nsymb) - if(iverbose.eq.2 .and. idproc.eq.0)then - write(6,*)'(getparm)returned from getsymb with nsymb=',nsymb - do n=1,nsymb - write(6,*)'n,symb(n)=',n,symb(n) - enddo - endif - n1=0 - if(nsymb.gt.0)then - do n=1,nsymb -c write(6,*)n,' ',kywrd(1:keylen),' ',trim(symb(n)) - if(kywrd(1:keylen).eq.trim(symb(n))//'=')then - n1=istrtsym(n) -c write(6,*)'found a match with n, n1 = ',n,n1 - exit - endif - enddo - endif -c-------------------------------- - 500 continue - if(n1.eq.0)then - keypres=.false. - numpres=.false. -c if(jwarn.eq.1)then -c write(6,*)'warning: could not find ',kywrd,' on input line:' -c write(6,*)line(1:mmax) -c endif - return - endif -c possibly this came from a multiline input. -c in that case, there may be '&' that need to be removed. - do n=1,mmax - if(line(n:n).eq.'&')line(n:n)=' ' - enddo -c obtain value for kywrd: -c write(6,*)'obtaining value for keyword:',kywrd -c write(6,*)'with line equal to' -c write(6,*)line(1:mmax) - keypres=.true. - string(1:nstrmax)=' ' - m=1 -c write(6,*)'starting do loop with n=',n1+keylen,' to',mmax - do n=n1+keylen,mmax -cryne 7/9/2002 if(line(n:n).eq.' ')exit - if(line(n:n).eq.',')exit - if((line(n:n).eq.'!').or.(line(n:n).eq.';'))exit - string(m:m)=line(n:n) -cryne can exit after storing another '=' (if any) - if(line(n:n).eq.'=')exit - m=m+1 - if(m.gt.nstrmax)then - write(6,*)'TROUBLE: m > nstrmax' - endif - enddo -c write(6,*)'finished do loop. now string=' -c write(6,*)string(1:nstrmax) -cccccccccccccccccccccc -c in case the user omitted the commas: -c find the next occurence of '=': - mm1=index(string,'=') -c write(6,*)'mm1=',mm1 - if(mm1.eq.0)goto 150 - string(mm1:nstrmax)=' ' - do n=mm1-1,1,-1 - if((string(n:n).eq.' ').or.(string(n:n).eq.','))exit - string(n:n)=' ' - enddo -cccccccccccccccccccccc - 150 continue -c write(6,*)'*string* = ' -c write(6,*)string(1:nstrmax) -c option to return string instead of value (i.e. if looking for a string): -c use numpres to indicate that this is normal return - if(iopt.eq.1)then - nbuf=len(cbuf) - cbuf(1:nbuf)=string(1:nbuf) - numpres=.true. -c write(6,*)'returning from getparm w/ iopt=1' -c write(6,*)'kywrd,cbuf=',kywrd(1:keylen),cbuf(1:nbuf) - return - endif -c - numpres=.false. -c------------------------------------ -c COMMENT THIS SECTION OUT WHEN FPARSER IS WORKING ON YOUR MAC: -c call txtnum(string,nstrmax,1,nget,bufr) -c read(string,*,iostat=numerr)value -c if(numerr.eq.0)then -c numpres=.true. -c bufr(1)=value -c endif -c------------------------------------- - if(.not.numpres)then - call strngfeval(string,nstrmax,value,numpres) - if(numpres)bufr(1)=value -c do j=1,nconst -c if(string.eq.constr(j))then -c write(6,*)'j,constr,conval=',j,constr(j),conval(j) -c bufr(1)=conval(j) -c numpres=.true. -c exit -c endif -c enddo - if(.not.numpres)write(6,*)'ERROR READING ELEMENT PARAMTERS:', & - & 'The string ',trim(string), ' has not been defined' - endif - if(numpres)then -c write(6,*)'bufr(1)=',bufr(1) - else - write(6,*)'number not found for kywrd ',kywrd - endif - return - end -c - subroutine strngfeval(string,nstrmax,result,numpres) - use parallel, only : idproc - use acceldata - include 'impli.inc' -c parameter (nstrmax=80) - character(len=nstrmax) string - character*16 symb(50),newsymb - integer istrtsym(50) - logical numpres - dimension val(50),bufr(1) - common/showme/iverbose - common/symbdef/isymbdef - numpres=.false. -c write(6,*)'evaluating string:',string -c iverbose=2 - if(iverbose.eq.2 .and. idproc.eq.0)then - write(6,*)'inside strngfeval; nstrmax=',nstrmax,' ;string=' - write(6,*)string(1:nstrmax) - endif - call getsymb(string,nstrmax,symb,istrtsym,nsymb) - if(iverbose.eq.2 .and. idproc.eq.0)then - write(6,*)'(strngfeval)returned from getsymb; nsymb=',nsymb - do n=1,nsymb - write(6,*)'n,symb(n)=',n,symb(n) - enddo - endif -c this is wrong; there can be an expression even though there are no symbols. -c so evaluate the symbolic expression regardless. -c if(nsymb.eq.0)then -c call txtnum(string,80,1,nget,bufr) -c if(nget.ge.1)then -c result=bufr(1) -c numpres=.true. -c else -c write(6,*)'trouble(strngfeval):txtnum did not return a number' -c endif -c return -c endif -c found symbols on this line; evaluate the symbolic expression: - do n=1,nsymb -c this is the place to check for function names (e.g. sqrt) and skip: - if(iverbose.eq.2 .and. idproc.eq.0)then - write(6,*)'[strngfeval] n,symb(n),nconst =',n,symb(n),nconst - endif - if(trim(symb(n)).eq.'sqrt')cycle - if(trim(symb(n)).eq.'sin')cycle - if(trim(symb(n)).eq.'cos')cycle - if(trim(symb(n)).eq.'tan')cycle - if(trim(symb(n)).eq.'asin')cycle - if(trim(symb(n)).eq.'acos')cycle - if(trim(symb(n)).eq.'atan')cycle - if(trim(symb(n)).eq.'abs')cycle - do j=1,nconst -c write(6,*)'j,constr(j)=',j,constr(j) - if(symb(n).eq.constr(j))then -ccccc write(6,*)'j,constr,conval=',j,constr(j),conval(j) - val(n)=conval(j) - goto 199 - endif - enddo -c the symbol was not found in the constr array; check for [...] -c new code------------------------- -c if you find it, set val(n)=... and goto 199 - ir1=index(symb(n),'[') - ir2=index(symb(n),']') - if(ir1.eq.0 .or. ir2.eq.0)goto 198 -c found [...] in the symbol. Now determine the value of xxxx[...]: - write(6,*)'reached the [...] section of code' - newsymb=symb(n)(ir1+1:ir2-1) - nlength=ir2-ir1-1 -c write(6,*)'calling str2int w/ newsymb,nlength=',newsymb,nlength - call str2int(newsymb,nlength,mval) - write(6,*)'returned from str2int w/ mval=',mval -c now that the value of the symbol has been found, make sure that -c it corresponds to a menu item: - newsymb=symb(n)(1:ir1-1) - write(6,*)'looking up the following symbol: ',newsymb - call lookup(newsymb,itype,indx) - if(itype.ne.1)then - write(6,*)'error: the symbol ',newsymb,' is not in the menu' - call myexit - endif - write(6,*)'Found ',newsymb,' in the menu (element #',indx,')' - write(6,*)'Parameter ',mval,' has the value ', & - & pmenu(mval+mpp(indx)) - val(n)=pmenu(mval+mpp(indx)) - goto 199 -c --------------------------------- - 198 continue -cryne 9/26/02: -c the symbol has not been defined. deal with it: - if(isymbdef.eq.1)then - if(idproc.eq.0)then - write(6,*)'error: symbol ',symb(n),' is used in expression:' - write(6,*)string - write(6,*)'but the symbol has not been defined. Setting to 0.' - endif - val(n)=0.d0 - else - if(idproc.eq.0)then - write(6,*)'error: symbol ',symb(n),' is used in expression:' - write(6,*)string - write(6,*)'but the symbol has not been defined. Halting.' - endif - call myexit - endif - 199 continue - enddo - nfunc=1 -!dbs -- fproutine expects an array so construct one on the fly -!dbs call fproutine(string,nfunc,symb,val,nsymb,result,nget) - call fproutine( (/ string /),nfunc,symb,val,nsymb,result,nget) - if(nget.eq.1)numpres=.true. - return - end -c - subroutine str2int(newsymb,nlength,mval) - character*16 newsymb - integer nlength,mval,n,ntmp - if(nlength.le.0)then - write(6,*)'error (str2int): nlength = ',nlength - call myexit - endif - mval=0 - do n=nlength,1,-1 - if(newsymb(n:n).eq.'0')ntmp=0 - if(newsymb(n:n).eq.'1')ntmp=1 - if(newsymb(n:n).eq.'2')ntmp=2 - if(newsymb(n:n).eq.'3')ntmp=3 - if(newsymb(n:n).eq.'4')ntmp=4 - if(newsymb(n:n).eq.'5')ntmp=5 - if(newsymb(n:n).eq.'6')ntmp=6 - if(newsymb(n:n).eq.'7')ntmp=7 - if(newsymb(n:n).eq.'8')ntmp=8 - if(newsymb(n:n).eq.'9')ntmp=9 - npow=nlength-n -c write(6,*)'n,ntmp,npow=',n,ntmp,npow - mval=mval+ntmp*10**npow - enddo - return - end -c - subroutine getsymb(line,nstrmax,symb,istrtsym,nsymb) -cryne 09/21/02 modified to include ] and [ - use acceldata - include 'impli.inc' - character (len=*) line - character*16 symb(*) - integer istrtsym(*) - character*1 str - character*26 alpha -ccc character*38 alphaug - character*40 alphaug - character*11 numerdot - logical acheck,echeck,dcheck - alpha='abcdefghijklmnopqrstuvwxyz' -ccc alphaug='abcdefghijklmnopqrstuvwxyz0123456789_.' - alphaug='abcdefghijklmnopqrstuvwxyz0123456789_.[]' - numerdot='0123456789.' - nsymb=0 - i=0 -! search for a new symbol beginning with an alpha character: - 100 i=i+1 -c if(i.eq.81)goto 9999 - if(i.ge.nstrmax+1)goto 9999 - istart=i -c if(line(i:i) .eq. an alpha)then - str=line(i:i) - echeck=.false. - dcheck=.false. - if(i.ge.2)then - echeck=(str.eq.'e').and.(scan(line(i-1:i-1),numerdot).ne.0) - dcheck=(str.eq.'d').and.(scan(line(i-1:i-1),numerdot).ne.0) - endif - acheck=.false. - if(scan(str,alpha).ne.0)acheck=.true. - if( (acheck) .and. (.not.echeck) .and. (.not.dcheck) )then - nsymb=nsymb+1 - 200 i=i+1 -c if(i.eq.81)goto 9999 - if(i.eq.nstrmax+1)goto 9999 -cryne 5/4/2006 if( (line(i:i).eq.'!') .or. (line(i:i).eq.';') )goto 9999 - if( (line(i:i).eq.'!') .or. (line(i:i).eq.';') )goto 201 -c if(line(i:i).eq. an alphanumeric or _ or . or "'")goto 200 - str=line(i:i) -!dbs -- if the last char in the line is the last char in the symbol -!dbs then process the symbol - if( scan(str,alphaug).ne.0 )then - if( i.lt.nstrmax ) goto 200 - !make it seem like the next char is a symbol terminator - i = i + 1 - endif -!dbs if(scan(str,alphaug).ne.0)goto 200 -cryne 5/4/2006 ------ - 201 continue -c-------------------- -cryne 11/04/02 -c store the symbol but first make sure it is not too long: - if(i-istart.gt.16)then - write(6,*)'(getsymb)warning: long character string on line=' - write(6,*)line - endif -c - imax=i-1 - if(i-istart.gt.16)imax=istart+16-1 -c symb(nsymb)=line(istart:i-1) - symb(nsymb)=line(istart:imax) - istrtsym(nsymb)=istart - goto 100 - endif - goto 100 - 9999 continue - return - end -c - subroutine getsymb60(line,nstrmax,symb,istrtsym,nsymb) -cryne 09/21/02 modified to include ] and [ - use acceldata - include 'impli.inc' - character (len=*) line - character*60 symb(*) - integer istrtsym(*) - character*1 str - character*26 alpha -ccc character*38 alphaug - character*40 alphaug - character*11 numerdot - logical acheck,echeck,dcheck - alpha='abcdefghijklmnopqrstuvwxyz' -ccc alphaug='abcdefghijklmnopqrstuvwxyz0123456789_.' - alphaug='abcdefghijklmnopqrstuvwxyz0123456789_.[]' - numerdot='0123456789.' - nsymb=0 - i=0 -! search for a new symbol beginning with an alpha character: - 100 i=i+1 -c if(i.eq.81)goto 9999 - if(i.eq.nstrmax+1)goto 9999 - istart=i -c if(line(i:i) .eq. an alpha)then - str=line(i:i) - echeck=.false. - dcheck=.false. - if(i.ge.2)then - echeck=(str.eq.'e').and.(scan(line(i-1:i-1),numerdot).ne.0) - dcheck=(str.eq.'d').and.(scan(line(i-1:i-1),numerdot).ne.0) - endif - acheck=.false. - if(scan(str,alpha).ne.0)acheck=.true. - if( (acheck) .and. (.not.echeck) .and. (.not.dcheck) )then - nsymb=nsymb+1 - 200 i=i+1 -c if(i.eq.81)goto 9999 - if(i.eq.nstrmax+1)goto 9999 - if( (line(i:i).eq.'!') .or. (line(i:i).eq.';') )goto 9999 -c if(line(i:i).eq. an alphanumeric or _ or . or "'")goto 200 - str=line(i:i) - if(scan(str,alphaug).ne.0)goto 200 -cryne 11/04/02 -c store the symbol but first make sure it is not too long: - if(i-istart.gt.60)then - write(6,*)'(getsymb)warning: long character string on line=' - write(6,*)line - endif -c - imax=i-1 - if(i-istart.gt.60)imax=istart+16-1 -c symb(nsymb)=line(istart:i-1) - symb(nsymb)=line(istart:imax) - istrtsym(nsymb)=istart - goto 100 - endif - goto 100 - 9999 continue - return - end -c -c -c - subroutine fproutine(func,nfunc,var,val,nvar,res,nget) - USE parameters, ONLY: rn - USE fparser, ONLY: initf, parsef, evalf, EvalErrType, EvalErrMsg - IMPLICIT NONE - INTEGER nfunc,nvar,i,nget - CHARACTER (LEN=*), DIMENSION(nfunc) :: func - CHARACTER (LEN=*), DIMENSION(nvar) :: var - REAL(rn), DIMENSION(nvar) :: val - REAL(rn) :: res -! - CALL initf (nfunc) ! Initialize function parser for nfunc functions - DO i=1,nfunc - CALL parsef(i,func(i),var) ! Parse and bytecompile ith function string - END DO -! WRITE(*,*)'==> Bytecode evaluation:' - DO i=1,nfunc - res=evalf(i,val) ! Interprete bytecode representation of ith function - IF(EvalErrType.gt.0)WRITE(6,*)'*** Error: ',EvalErrMsg () - nget=0 - IF(EvalErrType.eq.0)nget=1 -! WRITE(6,*)trim(func(i)),'=',res - END DO - return - end -c - subroutine quotechk(fname,lmax) -c check for unnecessary quotes and apostrophes - character (len=*) fname -c - if(fname.ne.' ')then - if((fname(1:1).eq.'"').or.(fname(1:1).eq."'"))then - write(6,*)'(pmif) quotes and apostrophes not needed in: ',fname - write(6,*)'They will be stripped off.' -c lmax=len(fname) - do i=1,lmax-1 - fname(i:i)=fname(i+1:i+1) - enddo - fname(lmax:lmax)=' ' - n=index(fname,'"') - if(n.ne.0)fname(n:n)=' ' - n=index(fname,"'") - if(n.ne.0)fname(n:n)=' ' - endif - endif - return - end -c--------------------------------------------------- diff --git a/OpticsJan2020/MLI_light_optics/Src/spch2d.f b/OpticsJan2020/MLI_light_optics/Src/spch2d.f deleted file mode 100755 index 08bfef4..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/spch2d.f +++ /dev/null @@ -1,960 +0,0 @@ -c IMPACT 2D space charge routines -c Copyright 2001 University of California -c - subroutine spch2dphi(c,ex,ey,msk,np,ntot,nx,ny,n1,n2) - use rays - implicit double precision(a-h,o-z) - logical msk - complex*16 grnxtr,erhox,erhoxtr,rho2,rho2xtr -! rho=charge density on the grid -! rho2=...on doubled grid -! rho2xtr=...xformed (by fft) and transposed -! grnxtr=green function, xformed, transposed - dimension c(4,maxrayp),msk(maxrayp),ex(maxrayp),ey(maxrayp) - dimension rho(nx,ny),exg(nx,ny),eyg(nx,ny),rhosum(nx,ny) - dimension rho2(n1,n2),rho2xtr(n2,n1),grnxtr(n2,n1) -! weights, indices associated with area weighting: - dimension ab(maxrayp),cd(maxrayp) - dimension indx(maxrayp),jndx(maxrayp) - dimension indxp1(maxrayp),jndxp1(maxrayp) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - common/newpoisson/idirectfieldcalc,idensityfunction,idummy(4) -! compute grid quantities hx,hy,... - call boundp2d(c,msk,np,nx,ny) -! deposit charge on the grid: - call rhoslo2d(c,rho,msk,np,ab,cd,indx,jndx,indxp1,jndxp1,nx,ny) - call MPI_ALLREDUCE(rho,rhosum,nx*ny,mreal,mpisum,lworld,ierror) - rho=rhosum -! store rho in lower left quadrant of doubled grid: - rho2=(0.,0.) - do j=1,ny - do i=1,nx - rho2(i,j)=cmplx(rho(i,j),0.) - enddo - enddo -!---------convolution------------ - twopi=4.d0*asin(1.d0) -! compute FFT of the Green function on the grid: - if(idensityfunction.eq.0)then -! if(idproc.eq.0)write(6,*)'in spch2d (via phi); NOT using slic' - call greenf2d(grnxtr,nx,ny,n1,n2) - grnxtr=0.5d0*grnxtr/(twopi*nrays) - else -! if(idproc.eq.0)write(6,*)'in spch2d, using slic (for phi)' - call greenphi2d(grnxtr,rho,nx,ny,n1,n2) - grnxtr=-1.d0*grnxtr/(hx*hy*twopi*nrays) - endif -! fft the charge density: - scale=1.0 - call fft2dhpf(n1,n2,1,0,scale,0,rho2,rho2xtr) -! multiply transformed charge density and transformed Green function: - rho2xtr=rho2xtr*grnxtr/(n1*n2) -! inverse fft: - call fft2dhpf(n2,n1,-1,0,scale,0,rho2xtr,rho2) -!----done with convolution------- -! store physical data back on grid of correct (not doubled) size: - do j=1,ny - do i=1,nx - rho(i,j)=real(rho2(i,j)) - enddo - enddo -! obtain the electric fields: - exg=0.5*hxi*(cshift(rho,-1,1)-cshift(rho,1,1)) - eyg=0.5*hyi*(cshift(rho,-1,2)-cshift(rho,1,2)) -! interpolate electric field at particle postions: - call ntrslo2d(exg,eyg,ex,ey,msk,ab,cd,indx,jndx,indxp1,jndxp1, & - & nx,ny,np) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! do i=1,nx -! j=ny/2 -! x=xmin+(i-1)*hx -! y=ymin+(j-1)*hy -! write(58,*)x,y,exg(i,j),eyg(i,j) -! enddo -! do j=1,ny -! i=nx/2 -! x=xmin+(i-1)*hx -! y=ymin+(j-1)*hy -! write(59,*)x,y,exg(i,j),eyg(i,j) -! enddo -! if(nx.ne.12345)call myexit -!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - return - end -! - subroutine boundp2d(c,msk,np,nx,ny) - use rays - implicit double precision(a-h,o-z) - logical msk - dimension c(4,maxrayp),msk(maxrayp) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi -! transverse: - xbig=maxval(c(1,:),1,msk) - xsml=minval(c(1,:),1,msk) - ybig=maxval(c(3,:),1,msk) - ysml=minval(c(3,:),1,msk) -! note: this would be a good place to check which particles -! are inside the beampipe, then mask off those that are not. - xmin=xsml-0.05*(xbig-xsml) - xmax=xbig+0.05*(xbig-xsml) - ymin=ysml-0.05*(ybig-ysml) - ymax=ybig+0.05*(ybig-ysml) - hx=(xmax-xmin)/(nx-1) - hy=(ymax-ymin)/(ny-1) - hxi=1./hx - hyi=1./hy - return - end -! - subroutine greenf2d(grnxtr,nx,ny,n1,n2) - implicit double precision(a-h,o-z) - complex*16 grn,grnxtr - dimension grn(n1,n2) - dimension grnxtr(n2,n1) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - eps=1.d-25 - do j=-ny,ny-1 - do i=-nx,nx-1 - grn(1+mod(i+n1,n1),1+mod(j+n2,n2))= -log((hx*i)**2+(hy*j)**2+eps) - enddo - enddo - grn(1,1)=grn(1,2) -! compute FFT of the Green function - scale=1.d0 - call fft2dhpf(n1,n2,1,0,scale,0,grn,grnxtr) - return - end -! -! - subroutine rhoslo2d(c,rho,msk,np,ab,cd,indx,jndx,indxp1, & - & jndxp1,nx,ny) - use rays - implicit double precision(a-h,o-z) - logical msk - dimension c(4,maxrayp),msk(maxrayp),vol(maxrayp) - dimension ab(maxrayp),cd(maxrayp) - dimension indx(maxrayp),jndx(maxrayp) - dimension indxp1(maxrayp),jndxp1(maxrayp) - dimension rho(nx,ny) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - do j=1,np - indx(j)=(c(1,j)-xmin)*hxi + 1 - jndx(j)=(c(3,j)-ymin)*hyi + 1 - enddo - do j=1,np - indxp1(j)=indx(j)+1 - jndxp1(j)=jndx(j)+1 - enddo -!------- - imin=minval(indx,1,msk) - imax=maxval(indx,1,msk) - jmin=minval(jndx,1,msk) - jmax=maxval(jndx,1,msk) - if((imin.lt.1).or.(imax.gt.nx-1))then - write(6,*)'error in rhoslo2d: imin,imax=',imin,imax - call myexit - endif - if((jmin.lt.1).or.(jmax.gt.ny-1))then - write(6,*)'error in rhoslo3d: jmin,jmax=',jmin,jmax - call myexit - endif -!------- - do j=1,np - ab(j)=((xmin-c(1,j))+indx(j)*hx)*hxi - cd(j)=((ymin-c(3,j))+jndx(j)*hy)*hyi - enddo - rho=0. -!1 (i,j): - vol=ab*cd - do n=1,np - rho(indx(n),jndx(n))=rho(indx(n),jndx(n))+vol(n) - enddo -!2 (i,j+1): - vol=ab*(1.-cd) - do n=1,np - rho(indx(n),jndxp1(n))=rho(indx(n),jndxp1(n))+vol(n) - enddo -!3 (i+1,j): - vol=(1.-ab)*cd - do n=1,np - rho(indxp1(n),jndx(n))=rho(indxp1(n),jndx(n))+vol(n) - enddo -!4 (i+1,j+1): - vol=(1.-ab)*(1.-cd) - do n=1,np - rho(indxp1(n),jndxp1(n))=rho(indxp1(n),jndxp1(n))+vol(n) - enddo -! ngood=count(msk) -! rho=rho/ngood - return - end -! - subroutine ntrslo2d(exg,eyg,ex,ey,msk,ab,cd,indx,jndx,indxp1, - &jndxp1,nx,ny,np) - use rays - implicit double precision(a-h,o-z) - logical msk - dimension exg(nx,ny),eyg(nx,ny) - dimension ex(maxrayp),ey(maxrayp),msk(maxrayp) - dimension ab(maxrayp),cd(maxrayp) - dimension indx(maxrayp),jndx(maxrayp) - dimension indxp1(maxrayp),jndxp1(maxrayp) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - do n=1,np - ex(n)= - & exg(indx(n),jndx(n))*ab(n)*cd(n) - & +exg(indx(n),jndxp1(n))*ab(n)*(1.-cd(n)) - & +exg(indxp1(n),jndx(n))*(1.-ab(n))*cd(n) - & +exg(indxp1(n),jndxp1(n))*(1.-ab(n))*(1.-cd(n)) - enddo - do n=1,np - ey(n)= - & eyg(indx(n),jndx(n))*ab(n)*cd(n) - & +eyg(indx(n),jndxp1(n))*ab(n)*(1.-cd(n)) - & +eyg(indxp1(n),jndx(n))*(1.-ab(n))*cd(n) - & +eyg(indxp1(n),jndxp1(n))*(1.-ab(n))*(1.-cd(n)) - enddo - return - end -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!======================================================================= -! 2D SPACE CHARGE ROUTINES BEGIN HERE -!======================================================================= - subroutine spch2ddirect(c,ex,ey,msk,np,ntot,nx,ny,n1,n2) - use rays - implicit double precision(a-h,o-z) - logical msk - double complex grnxtr - double complex rho2,rho2xtr,rho2tmp -! rho=charge density on the grid -! rho2=...on doubled grid -! rho2xtr=...xformed (by fft) and transposed -! grnxtr=green function, xformed, transposed - dimension c(4,maxrayp),msk(maxrayp),ex(maxrayp),ey(maxrayp) - dimension rho(nx,ny),exg(nx,ny),eyg(nx,ny),rhosum(nx,ny) - dimension rho2(n1,n2),rho2xtr(n2,n1),rho2tmp(n2,n1) - dimension grnxtr(n2,n1) -! weights, indices associated with area weighting: - dimension ab(maxrayp),cd(maxrayp) - dimension indx(maxrayp),jndx(maxrayp) - dimension indxp1(maxrayp),jndxp1(maxrayp) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - common/newpoisson/idirectfieldcalc,idensityfunction,idummy(4) -! if(idproc.eq.0)write(6,*)'inside spch2ddirect; np,ntot,nx,ny=' -! if(idproc.eq.0)write(6,*)np,ntot,nx,ny - -! compute grid quantities hx,hy,... - call boundp2d(c,msk,np,nx,ny) -! deposit charge on the grid: - call rhoslo2d(c,rho,msk,np,ab,cd,indx,jndx,indxp1,jndxp1,nx,ny) - call MPI_ALLREDUCE(rho,rhosum,nx*ny,mreal,mpisum,lworld,ierror) - rho=rhosum -! -! store rho in lower left quadrant of doubled grid: - rho2=(0.,0.) - do j=1,ny - do i=1,nx - rho2(i,j)=cmplx(rho(i,j),0.) - enddo - enddo -!---------convolution------------ -! fft the charge density: - scale=1.0 - call fft2dhpf(n1,n2,1,0,scale,0,rho2,rho2xtr) -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! compute FFT of the x-Green function on the grid: - twopi=4.d0*asin(1.d0) - if(idensityfunction.eq.0)then -! if(idproc.eq.0)write(6,*)'in spch2ddirect; NOT using slic' - call greenfxold(grnxtr,rhosum,nx,ny,n1,n2) - grnxtr=grnxtr/(twopi*nrays) - else -! if(idproc.eq.0)write(6,*)'in spch2ddirect; using slic' - call greenfx2d(grnxtr,rhosum,nx,ny,n1,n2) - grnxtr=grnxtr/(twopi*nrays) - endif -! multiply transformed charge density and transformed Green function: - rho2tmp=rho2xtr*grnxtr/(n1*n2) -! inverse fft: - call fft2dhpf(n2,n1,-1,0,scale,0,rho2tmp,rho2) -! store physical data back on grid of correct (not doubled) size: - do j=1,ny - do i=1,nx - rho(i,j)=real(rho2(i,j)) - enddo - enddo -! obtain the x-electric field: -! exg=rho/(4.d0*asin(1.d0)) - exg=rho/(hx*hy) -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! compute FFT of the y-Green function on the grid: - if(idensityfunction.eq.0)then - call greenfy2d(grnxtr,rhosum,nx,ny,n1,n2) - grnxtr=grnxtr/(twopi*nrays) - else - call greenfyold(grnxtr,rhosum,nx,ny,n1,n2) - grnxtr=grnxtr/(twopi*nrays) - endif -! multiply transformed charge density and transformed Green function: - rho2tmp=rho2xtr*grnxtr/(n1*n2) -! inverse fft: - call fft2dhpf(n2,n1,-1,0,scale,0,rho2tmp,rho2) -! store physical data back on grid of correct (not doubled) size: - do j=1,ny - do i=1,nx - rho(i,j)=real(rho2(i,j)) - enddo - enddo -! obtain the y-electric field: -! eyg=rho/(4.d0*asin(1.d0)) - eyg=rho/(hx*hy) -! -! interpolate electric field at particle postions: - call ntrslo2d(exg,eyg,ex,ey,msk,ab,cd,indx,jndx,indxp1,jndxp1, & - & nx,ny,np) -! if(idproc.eq.0)write(6,*)'done with interpolation' -! do j=1,np -! ex(j)=0.5*ex(j) -! enddo -! do j=1,np -! ey(j)=0.5*ey(j) -! enddo - return - end -! -! - subroutine spch2dold(c,ex,ey,msk,np,exg,eyg,nx,ny,n1,n2) - use rays - implicit double precision(a-h,o-z) - logical msk - double complex grnxtr - double complex rho2,rho2xtr,rho2tmp -! rho=charge density on the grid -! rho2=...on doubled grid -! rho2xtr=...xformed (by fft) and transposed -! grnxtr=green function, xformed, transposed - dimension c(4,maxrayp),msk(maxrayp),ex(maxrayp),ey(maxrayp) - dimension rho(nx,ny),exg(nx,ny),eyg(nx,ny),rhosave(nx,ny) - dimension rho2(n1,n2),rho2xtr(n2,n1),rho2tmp(n2,n1) - dimension grnxtr(n2,n1) -! weights, indices associated with area weighting: - dimension ab(maxrayp),cd(maxrayp) - dimension indx(maxrayp),jndx(maxrayp) - dimension indxp1(maxrayp),jndxp1(maxrayp) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - if(idproc.eq.0)write(6,*)'inside spch2dold' -! deposit charge on the grid: -! call rho2d(c,rho,msk,ab,de,indx,jndx,indxp1,jndxp1,nx,ny) - call rhoslo2d(c,rho,msk,np,ab,cd,indx,jndx,indxp1,jndxp1,nx,ny) -! -! store rho in lower left quadrant of doubled grid: - rhosave(:,:)=rho(:,:) - rho2=(0.,0.) - do j=1,ny - do i=1,nx - rho2(i,j)=cmplx(rho(i,j),0.) - enddo - enddo -!---------convolution------------ -! fft the charge density: - scale=1.0 - call fft2dhpf(n1,n2,1,0,scale,0,rho2,rho2xtr) -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! compute FFT of the x-Green function on the grid: - if(idproc.eq.0)write(6,*)'calling greenfxold' - call greenfxold(grnxtr,rhosave,nx,ny,n1,n2) - if(idproc.eq.0)write(6,*)'done with greenfxold' -! multiply transformed charge density and transformed Green function: - rho2tmp=rho2xtr*grnxtr/(n1*n2) -! inverse fft: - call fft2dhpf(n2,n1,-1,0,scale,0,rho2tmp,rho2) - if(idproc.eq.0)write(6,*)'done with inverse fft' -! store physical data back on grid of correct (not doubled) size: - do j=1,ny - do i=1,nx - rho(i,j)=real(rho2(i,j)) - enddo - enddo -! obtain the x-electric field: - exg=rho/(4.d0*asin(1.d0)) -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! compute FFT of the y-Green function on the grid: - if(idproc.eq.0)write(6,*)'calling greenfyold' - call greenfyold(grnxtr,rhosave,nx,ny,n1,n2) - if(idproc.eq.0)write(6,*)'done with greenfyold' -! multiply transformed charge density and transformed Green function: - rho2tmp=rho2xtr*grnxtr/(n1*n2) -! inverse fft: - call fft2dhpf(n2,n1,-1,0,scale,0,rho2tmp,rho2) - if(idproc.eq.0)write(6,*)'done with inverse fft' -! store physical data back on grid of correct (not doubled) size: - do j=1,ny - do i=1,nx - rho(i,j)=real(rho2(i,j)) - enddo - enddo -! obtain the y-electric field: - eyg=rho/(4.d0*asin(1.d0)) -! -! interpolate electric field at particle postions: - call ntrslo2d(exg,eyg,ex,ey,msk,ab,cd,indx,jndx,indxp1,jndxp1, & - & nx,ny,np) -! if(idproc.eq.0)write(6,*)'done with interpolation' - return - end -! -!============================================================= -! - subroutine greenphi2d(gxtr,rho,nx,ny,n1,n2) -! green function routine. - implicit double precision(a-h,o-z) - double complex g,gxtr - dimension g(n1,n2),gxtr(n2,n1) - dimension rho(nx,ny),exg(nx,ny),fxg(nx,ny) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - - xint1(x,y,a,b,hx,hy,e2)= - & (((a - hx)*x**3)/9. - x**4/16. + - & (x**2*(28*b - 28*hy - 9*y)*y)/24. - - & ((a - hx)*x*(18*b - 18*hy - 7*y)*y)/6. + - & ((3*a*b*y**2 - 3*b*hx*y**2 - 3*a*hy*y**2 + 3*hx*hy*y**2 - - & 2*a*y**3 + 2*hx*y**3)*atan(x/y))/3. - - & ((b - hy)*x**2*(-3*a + 3*hx + 2*x)*atan(y/x))/3. + - & (x*(-4*a*x**2 + 4*hx*x**2 + 3*x**3 + 24*a*b*y - - & 24*b*hx*y - 24*a*hy*y + 24*hx*hy*y - 12*b*x*y + - & 12*hy*x*y - 12*a*y**2 + 12*hx*y**2 + 6*x*y**2)* - & Log(x**2 + y**2))/24. + - & ((-4*b*y**3 + 4*hy*y**3 + 3*y**4)*Log(x**2 + y**2))/24.)/ - & 2. - - xint2(x,y,a,b,hx,hy,e2)= - & (((-a - hx)*x**3)/9. + x**4/16. + - & ((a + hx)*x*(18*b - 18*hy - 7*y)*y)/6. + - & (x**2*y*(-28*b + 28*hy + 9*y))/24. + - & ((-3*a*b*y**2 - 3*b*hx*y**2 + 3*a*hy*y**2 + - & 3*hx*hy*y**2 + 2*a*y**3 + 2*hx*y**3)*atan(x/y))/3. - & + ((b - hy)*x**2*(-3*a - 3*hx + 2*x)*atan(y/x))/3. - - & (x*(-4*a*x**2 - 4*hx*x**2 + 3*x**3 + 24*a*b*y + - & 24*b*hx*y - 24*a*hy*y - 24*hx*hy*y - 12*b*x*y + - & 12*hy*x*y - 12*a*y**2 - 12*hx*y**2 + 6*x*y**2)* - & Log(x**2 + y**2))/24. + - & ((4*b*y**3 - 4*hy*y**3 - 3*y**4)*Log(x**2 + y**2))/24.)/2. - - xint3(x,y,a,b,hx,hy,e2)= - & (((-a + hx)*x**3)/9. + x**4/16. + - & ((a - hx)*x*(18*b + 18*hy - 7*y)*y)/6. + - & (x**2*y*(-28*b - 28*hy + 9*y))/24. + - & ((-3*a*b*y**2 + 3*b*hx*y**2 - 3*a*hy*y**2 + - & 3*hx*hy*y**2 + 2*a*y**3 - 2*hx*y**3)*atan(x/y))/3. - & + ((b + hy)*x**2*(-3*a + 3*hx + 2*x)*atan(y/x))/3. - - & (x*(-4*a*x**2 + 4*hx*x**2 + 3*x**3 + 24*a*b*y - - & 24*b*hx*y + 24*a*hy*y - 24*hx*hy*y - 12*b*x*y - - & 12*hy*x*y - 12*a*y**2 + 12*hx*y**2 + 6*x*y**2)* - & Log(x**2 + y**2))/24. + - & ((4*b*y**3 + 4*hy*y**3 - 3*y**4)*Log(x**2 + y**2))/24.)/2. - - xint4(x,y,a,b,hx,hy,e2)= - & (((a + hx)*x**3)/9. - x**4/16. + - & (x**2*(28*b + 28*hy - 9*y)*y)/24. - - & ((a + hx)*x*(18*b + 18*hy - 7*y)*y)/6. + - & ((3*a*b*y**2 + 3*b*hx*y**2 + 3*a*hy*y**2 + 3*hx*hy*y**2 - - & 2*a*y**3 - 2*hx*y**3)*atan(x/y))/3. - - & ((b + hy)*x**2*(-3*a - 3*hx + 2*x)*atan(y/x))/3. + - & (x*(-4*a*x**2 - 4*hx*x**2 + 3*x**3 + 24*a*b*y + - & 24*b*hx*y + 24*a*hy*y + 24*hx*hy*y - 12*b*x*y - - & 12*hy*x*y - 12*a*y**2 - 12*hx*y**2 + 6*x*y**2)* - & Log(x**2 + y**2))/24. + - & ((-4*b*y**3 - 4*hy*y**3 + 3*y**4)*Log(x**2 + y**2))/24.)/ - & 2. -! - xintlimit11= - & (-25*hx**2*hy**2 + 8*hx*hy**3*atan(hx/hy) + - & 8*hx**3*hy*atan(hy/hx) + hx**4*Log(hx**2) + - & hy**4*Log(hy**2) - hx**4*Log(hx**2 + hy**2) + - & 6*hx**2*hy**2*Log(hx**2 + hy**2) - - & hy**4*Log(hx**2 + hy**2))/12. - - xintlimit21= - & (-50*hx**2*hy**2 - 16*hx*hy**3*atan(hx/hy) + - & 16*hx*hy**3*atan((2*hx)/hy) + - & 64*hx**3*hy*atan(hy/(2.*hx)) - - & 16*hx**3*hy*atan(hy/hx) - 2*hx**4*Log(hx**2) + - & 16*hx**4*Log(4*hx**2) - hy**4*Log(hy**2) + - & 2*hx**4*Log(hx**2 + hy**2) - - & 12*hx**2*hy**2*Log(hx**2 + hy**2) + - & 2*hy**4*Log(hx**2 + hy**2) - - & 16*hx**4*Log(4*hx**2 + hy**2) + - & 24*hx**2*hy**2*Log(4*hx**2 + hy**2) - - & hy**4*Log(4*hx**2 + hy**2))/24. -! - xintlimit12= - & (-50*hx**2*hy**2 + 64*hx*hy**3*atan(hx/(2.*hy)) - - & 16*hx*hy**3*atan(hx/hy) - 16*hx**3*hy*atan(hy/hx) + - & 16*hx**3*hy*atan((2*hy)/hx) - hx**4*Log(hx**2) - - & 2*hy**4*Log(hy**2) + 16*hy**4*Log(4*hy**2) + - & 2*hx**4*Log(hx**2 + hy**2) - - & 12*hx**2*hy**2*Log(hx**2 + hy**2) + - & 2*hy**4*Log(hx**2 + hy**2) - hx**4*Log(hx**2 + 4*hy**2) + - & 24*hx**2*hy**2*Log(hx**2 + 4*hy**2) - - & 16*hy**4*Log(hx**2 + 4*hy**2))/24. -! - xintlimit22= - & (-100*hx**2*hy**2 - 128*hx*hy**3*atan(hx/(2.*hy)) + - & 160*hx*hy**3*atan(hx/hy) - - & 32*hx*hy**3*atan((2*hx)/hy) - - & 128*hx**3*hy*atan(hy/(2.*hx)) + - & 160*hx**3*hy*atan(hy/hx) - - & 32*hx**3*hy*atan((2*hy)/hx) + 2*hx**4*Log(hx**2) - - & 16*hx**4*Log(4*hx**2) + 2*hy**4*Log(hy**2) - - & 16*hy**4*Log(4*hy**2) - 4*hx**4*Log(hx**2 + hy**2) + - & 24*hx**2*hy**2*Log(hx**2 + hy**2) - - & 4*hy**4*Log(hx**2 + hy**2) + - & 32*hx**4*Log(4*hx**2 + hy**2) - - & 48*hx**2*hy**2*Log(4*hx**2 + hy**2) + - & 2*hy**4*Log(4*hx**2 + hy**2) + - & 2*hx**4*Log(hx**2 + 4*hy**2) - - & 48*hx**2*hy**2*Log(hx**2 + 4*hy**2) + - & 32*hy**4*Log(hx**2 + 4*hy**2) - - & 16*hx**4*Log(4*hx**2 + 4*hy**2) + - & 96*hx**2*hy**2*Log(4*hx**2 + 4*hy**2) - - & 16*hy**4*Log(4*hx**2 + 4*hy**2))/48. -! -! eps2=1.d-20 - eps2=0.d0 -! compute integrals involving the Green function for Ex: -! do j=1,ny+1 - do j=1,ny - y0=hy*(j-1) - y1=hy*j -! do i=1,nx+1 - do i=1,nx - x0=hx*(i-1) - x1=hx*i -!----------- - fmp= - & xint1(x0-hx,y0-hy,x0,y0,hx,hy,eps2)+xint1(x0,y0,x0,y0,hx,hy,eps2) - &-xint1(x0-hx,y0,x0,y0,hx,hy,eps2)-xint1(x0,y0-hy,x0,y0,hx,hy,eps2) - &+xint2(x0,y0-hy,x0,y0,hx,hy,eps2)+xint2(x0+hx,y0,x0,y0,hx,hy,eps2) - &-xint2(x0,y0,x0,y0,hx,hy,eps2)-xint2(x0+hx,y0-hy,x0,y0,hx,hy,eps2) - &+xint3(x0-hx,y0,x0,y0,hx,hy,eps2)+xint3(x0,y0+hy,x0,y0,hx,hy,eps2) - &-xint3(x0-hx,y0+hy,x0,y0,hx,hy,eps2)-xint3(x0,y0,x0,y0,hx,hy,eps2) - &+xint4(x0,y0,x0,y0,hx,hy,eps2)+xint4(x0+hx,y0+hy,x0,y0,hx,hy,eps2) - &-xint4(x0,y0+hy,x0,y0,hx,hy,eps2)-xint4(x0+hx,y0,x0,y0,hx,hy,eps2) - if(fmp.ne.fmp)then - write(12,123)i,j,x0,y0 - 123 format(1x,'(greenfx)fmp=NaN at i,j,x0,y0=',2(i5,1x),2(1pe12.5,1x)) - call myflush(12) - if(i.eq.1.and.j.eq.1)fmp=xintlimit11 - if(i.eq.1.and.j.eq.2)fmp=xintlimit12 - if(i.eq.2.and.j.eq.1)fmp=xintlimit21 - if(i.eq.2.and.j.eq.2)fmp=xintlimit22 - write(12,*)'new limiting value of fmp =',fmp - call myflush(12) - endif - g(i,j)=fmp/(hx*hy) -!----------- - enddo - enddo -!reflections: - do j=1,ny - do i=1+nx,nx+nx - g(i,j)=g(n1-i+2,j) - enddo - enddo - do j=1+ny,ny+ny - do i=1,nx - g(i,j)=g(i,n2-j+2) - enddo - enddo - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j)=g(n1-i+2,n2-j+2) - enddo - enddo -! compute FFT of the Green function - scale=1.0 -! write(6,*)'calling fft2dhpf in greenfx' - call fft2dhpf(n1,n2,1,0,scale,0,g,gxtr) -! write(6,*)'returned from fft2dhpf in greenfx' - return - end -! -!============================================================= -! -! - subroutine greenfx2d(gxtr,rho,nx,ny,n1,n2) -! green function routine. - implicit double precision(a-h,o-z) - double complex g,gxtr - dimension g(n1,n2),gxtr(n2,n1) - dimension rho(nx,ny),exg(nx,ny),fxg(nx,ny) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - - xint1(x,y,a,b,hx,hy,e2)= - & -((-a + hx)*x**2)/4. - x**3/9. + - & (x*y*(-3*b + 3*hy + 2*y))/6. - - & ((-3*b*y**2 + 3*hy*y**2 + 2*y**3)*atan(x/(y+e2)))/6. - - & ((b - hy)*x*(-2*a + 2*hx + x)*atan(y/(x+e2)))/2. + - & (x**2*(-3*a + 3*hx + 2*x)*log(x**2 + y**2 +e2))/12. - - & ((-2*a*b*y + 2*b*hx*y + 2*a*hy*y - 2*hx*hy*y + - & a*y**2 - hx*y**2)*log(x**2 + y**2 +e2))/4. - - xint2(x,y,a,b,hx,hy,e2)= - & -((a + hx)*x**2)/4. + x**3/9. - - & (x*y*(-3*b + 3*hy + 2*y))/6. - - & ((3*b*y**2 - 3*hy*y**2 - 2*y**3)*atan(x/(y+e2)))/6. + - & ((b - hy)*x*(-2*a - 2*hx + x)*atan(y/(x+e2)))/2. - - & (x**2*(-3*a - 3*hx + 2*x)*log(x**2 + y**2 +e2))/12. - - & ((2*a*b*y + 2*b*hx*y - 2*a*hy*y - 2*hx*hy*y - - & a*y**2 - hx*y**2)*log(x**2 + y**2 +e2))/4. - - xint3(x,y,a,b,hx,hy,e2)= - & ((-a + hx)*x**2)/4. + x**3/9. - - & (x*y*(-3*b - 3*hy + 2*y))/6. + - & ((-3*b*y**2 - 3*hy*y**2 + 2*y**3)*atan(x/(y+e2)))/6. + - & ((b + hy)*x*(-2*a + 2*hx + x)*atan(y/(x+e2)))/2. - - & (x**2*(-3*a + 3*hx + 2*x)*log(x**2 + y**2 +e2))/12. + - & ((-2*a*b*y + 2*b*hx*y - 2*a*hy*y + 2*hx*hy*y + - & a*y**2 - hx*y**2)*log(x**2 + y**2 +e2))/4. - - xint4(x,y,a,b,hx,hy,e2)= - & ((a + hx)*x**2)/4. - x**3/9. + - & (x*y*(-3*b - 3*hy + 2*y))/6. + - & ((3*b*y**2 + 3*hy*y**2 - 2*y**3)*atan(x/(y+e2)))/6. - - & ((b + hy)*x*(-2*a - 2*hx + x)*atan(y/(x+e2)))/2. + - & (x**2*(-3*a - 3*hx + 2*x)*log(x**2 + y**2 +e2))/12. + - & ((2*a*b*y + 2*b*hx*y + 2*a*hy*y + 2*hx*hy*y - - & a*y**2 - hx*y**2)*log(x**2 + y**2 +e2))/4. -! -! write(6,*)'inside greenfx2d w/ hx,hy=',hx,hy - xintlimit21= - & (-2*hy**3*atan(hx/hy) + hy**3*atan((2*hx)/hy) + - & 12*hx**2*hy*atan(hy/(2.*hx)) - - & 6*hx**2*hy*atan(hy/hx) - hx**3*Log(hx**2) + - & 4*hx**3*Log(4*hx**2) + hx**3*Log(hx**2 + hy**2) - - & 3*hx*hy**2*Log(hx**2 + hy**2) - - & 4*hx**3*Log(4*hx**2 + hy**2) + - & 3*hx*hy**2*Log(4*hx**2 + hy**2))/3. -! - xintlimit22= - & (-16*hy**3*atan(hx/(2.*hy)) + 12*hy**3*atan(hx/hy) - - & 2*hy**3*atan((2*hx)/hy) - - & 24*hx**2*hy*atan(hy/(2.*hx)) + - & 36*hx**2*hy*atan(hy/hx) - - & 12*hx**2*hy*atan((2*hy)/hx) + hx**3*Log(hx**2) - - & 4*hx**3*Log(4*hx**2) - 2*hx**3*Log(hx**2 + hy**2) + - & 6*hx*hy**2*Log(hx**2 + hy**2) + - & 8*hx**3*Log(4*hx**2 + hy**2) - - & 6*hx*hy**2*Log(4*hx**2 + hy**2) + - & hx**3*Log(hx**2 + 4*hy**2) - - & 12*hx*hy**2*Log(hx**2 + 4*hy**2) - - & 4*hx**3*Log(4*hx**2 + 4*hy**2) + - & 12*hx*hy**2*Log(4*hx**2 + 4*hy**2))/6. -! -! eps2=1.d-20 - eps2=0.d0 -! compute integrals involving the Green function for Ex: -! do j=1,ny+1 - do j=1,ny - y0=hy*(j-1) - y1=hy*j -! do i=1,nx+1 - do i=1,nx - x0=hx*(i-1) - x1=hx*i -!----------- - fmp= - & xint1(x0-hx,y0-hy,x0,y0,hx,hy,eps2)+xint1(x0,y0,x0,y0,hx,hy,eps2) - &-xint1(x0-hx,y0,x0,y0,hx,hy,eps2)-xint1(x0,y0-hy,x0,y0,hx,hy,eps2) - &+xint2(x0,y0-hy,x0,y0,hx,hy,eps2)+xint2(x0+hx,y0,x0,y0,hx,hy,eps2) - &-xint2(x0,y0,x0,y0,hx,hy,eps2)-xint2(x0+hx,y0-hy,x0,y0,hx,hy,eps2) - &+xint3(x0-hx,y0,x0,y0,hx,hy,eps2)+xint3(x0,y0+hy,x0,y0,hx,hy,eps2) - &-xint3(x0-hx,y0+hy,x0,y0,hx,hy,eps2)-xint3(x0,y0,x0,y0,hx,hy,eps2) - &+xint4(x0,y0,x0,y0,hx,hy,eps2)+xint4(x0+hx,y0+hy,x0,y0,hx,hy,eps2) - &-xint4(x0,y0+hy,x0,y0,hx,hy,eps2)-xint4(x0+hx,y0,x0,y0,hx,hy,eps2) - if(fmp.ne.fmp)then - write(12,123)i,j,x0,y0 - 123 format(1x,'(greenfx)fmp=NaN at i,j,x0,y0=',2(i5,1x),2(1pe12.5,1x)) - call myflush(12) - if(i.eq.1.and.j.eq.1)fmp=0.d0 - if(i.eq.1.and.j.eq.2)fmp=0.d0 - if(i.eq.2.and.j.eq.1)fmp=xintlimit21 - if(i.eq.2.and.j.eq.2)fmp=xintlimit22 - write(12,*)'new limiting value of fmp =',fmp - call myflush(12) - endif - g(i,j)=fmp/(hx*hy) -!----------- - enddo - enddo -!reflections: - do j=1,ny - do i=1+nx,nx+nx - g(i,j)=-g(n1-i+2,j) -! g(i,j)=-g(n1-i+1,j) - enddo - enddo - do j=1+ny,ny+ny - do i=1,nx - g(i,j)=g(i,n2-j+2) -! g(i,j)=g(i,n2-j+1) - enddo - enddo - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j)=-g(n1-i+2,n2-j+2) -! g(i,j)=-g(n1-i+1,n2-j+1) - enddo - enddo -! compute FFT of the Green function - scale=1.0 -! write(6,*)'calling fft2dhpf in greenfx' - call fft2dhpf(n1,n2,1,0,scale,0,g,gxtr) -! write(6,*)'returned from fft2dhpf in greenfx' - return - end -! -!============================================================= -! - subroutine greenfy2d(gxtr,rho,nx,ny,n1,n2) -! green function routine. - implicit double precision(a-h,o-z) - double complex g,gxtr - dimension g(n1,n2),gxtr(n2,n1) - dimension rho(nx,ny),fyg(nx,ny) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - yint1(x,y,a,b,hx,hy,e2)= - & -((a - hx)*x*(2*b - 2*hy + y))/2. + - & (x**2*(3*b - 3*hy + 4*y))/12. + - & ((2*a*b*y - 2*b*hx*y - 2*a*hy*y + 2*hx*hy*y - - & a*y**2 + hx*y**2)*atan(x/(y+e2)))/2. - - & (x**2*(-3*a + 3*hx + 2*x)*atan(y/(x+e2)))/6. - - & ((b - hy)*x*(-2*a + 2*hx + x)*log(x**2 + y**2 +e2))/4. + - & ((-3*b*y**2 + 3*hy*y**2 + 2*y**3)*log(x**2 + y**2 +e2))/ - & 12. - - yint2(x,y,a,b,hx,hy,e2)= - & (x**2*(-3*b + 3*hy - 4*y))/12. + - & ((a + hx)*x*(2*b - 2*hy + y))/2. + - & ((-2*a*b*y - 2*b*hx*y + 2*a*hy*y + 2*hx*hy*y + - & a*y**2 + hx*y**2)*atan(x/(y+e2)))/2. + - & (x**2*(-3*a - 3*hx + 2*x)*atan(y/(x+e2)))/6. + - & ((b - hy)*x*(-2*a - 2*hx + x)*log(x**2 + y**2 +e2))/4. + - & ((3*b*y**2 - 3*hy*y**2 - 2*y**3)*log(x**2 + y**2 +e2))/ - & 12. - - yint3(x,y,a,b,hx,hy,e2)= - & (x**2*(-3*b - 3*hy - 4*y))/12. + - & ((a - hx)*x*(2*b + 2*hy + y))/2. + - & ((-2*a*b*y + 2*b*hx*y - 2*a*hy*y + 2*hx*hy*y + - & a*y**2 - hx*y**2)*atan(x/(y+e2)))/2. + - & (x**2*(-3*a + 3*hx + 2*x)*atan(y/(x+e2)))/6. + - & ((b + hy)*x*(-2*a + 2*hx + x)*log(x**2 + y**2 +e2))/4. + - & ((3*b*y**2 + 3*hy*y**2 - 2*y**3)*log(x**2 + y**2 +e2))/ - & 12. - - yint4(x,y,a,b,hx,hy,e2)= - & -((a + hx)*x*(2*b + 2*hy + y))/2. + - & (x**2*(3*b + 3*hy + 4*y))/12. + - & ((2*a*b*y + 2*b*hx*y + 2*a*hy*y + 2*hx*hy*y - - & a*y**2 - hx*y**2)*atan(x/(y+e2)))/2. - - & (x**2*(-3*a - 3*hx + 2*x)*atan(y/(x+e2)))/6. - - & ((b + hy)*x*(-2*a - 2*hx + x)*log(x**2 + y**2 +e2))/4. + - & ((-3*b*y**2 - 3*hy*y**2 + 2*y**3)*log(x**2 + y**2 +e2))/ - & 12. -! -! write(6,*)'inside greenfy2d' - - yintlimit12= - & (12*hx*hy**2*atan(hx/(2.*hy)) - - & 6*hx*hy**2*atan(hx/hy) - 2*hx**3*atan(hy/hx) + - & hx**3*atan((2*hy)/hx) - hy**3*Log(hy**2) + - & 4*hy**3*Log(4*hy**2) - 3*hx**2*hy*Log(hx**2 + hy**2) + - & hy**3*Log(hx**2 + hy**2) + - & 3*hx**2*hy*Log(hx**2 + 4*hy**2) - - & 4*hy**3*Log(hx**2 + 4*hy**2))/3. - - yintlimit22= - & (-24*hx*hy**2*atan(hx/(2.*hy)) + - & 36*hx*hy**2*atan(hx/hy) - - & 12*hx*hy**2*atan((2*hx)/hy) - - & 16*hx**3*atan(hy/(2.*hx)) + 12*hx**3*atan(hy/hx) - - & 2*hx**3*atan((2*hy)/hx) + hy**3*Log(hy**2) - - & 4*hy**3*Log(4*hy**2) + 6*hx**2*hy*Log(hx**2 + hy**2) - - & 2*hy**3*Log(hx**2 + hy**2) - - & 12*hx**2*hy*Log(4*hx**2 + hy**2) + - & hy**3*Log(4*hx**2 + hy**2) - - & 6*hx**2*hy*Log(hx**2 + 4*hy**2) + - & 8*hy**3*Log(hx**2 + 4*hy**2) + - & 12*hx**2*hy*Log(4*hx**2 + 4*hy**2) - - & 4*hy**3*Log(4*hx**2 + 4*hy**2))/6. - -! eps2=1.d-20 - eps2=0.d0 -! compute integrals involving the Green function for Ey: - do j=1,ny+1 - y0=hy*(j-1) - y1=hy*j - do i=1,nx+1 - x0=hx*(i-1) - x1=hx*i -!----------- - fmp= - & yint1(x0-hx,y0-hy,x0,y0,hx,hy,eps2)+yint1(x0,y0,x0,y0,hx,hy,eps2) - &-yint1(x0-hx,y0,x0,y0,hx,hy,eps2)-yint1(x0,y0-hy,x0,y0,hx,hy,eps2) - &+yint2(x0,y0-hy,x0,y0,hx,hy,eps2)+yint2(x0+hx,y0,x0,y0,hx,hy,eps2) - &-yint2(x0,y0,x0,y0,hx,hy,eps2)-yint2(x0+hx,y0-hy,x0,y0,hx,hy,eps2) - &+yint3(x0-hx,y0,x0,y0,hx,hy,eps2)+yint3(x0,y0+hy,x0,y0,hx,hy,eps2) - &-yint3(x0-hx,y0+hy,x0,y0,hx,hy,eps2)-yint3(x0,y0,x0,y0,hx,hy,eps2) - &+yint4(x0,y0,x0,y0,hx,hy,eps2)+yint4(x0+hx,y0+hy,x0,y0,hx,hy,eps2) - &-yint4(x0,y0+hy,x0,y0,hx,hy,eps2)-yint4(x0+hx,y0,x0,y0,hx,hy,eps2) - if(fmp.ne.fmp)then - write(12,123)i,j,x0,y0 - 123 format(1x,'(greenfy)fmp=NaN at i,j,x0,y0=',2(i5,1x),2(1pe12.5,1x)) - call myflush(12) - if(i.eq.1.and.j.eq.1)fmp=0.d0 - if(i.eq.1.and.j.eq.2)fmp=yintlimit12 - if(i.eq.2.and.j.eq.1)fmp=0.d0 - if(i.eq.2.and.j.eq.2)fmp=yintlimit22 - write(12,*)'new limiting value of fmp =',fmp - call myflush(12) - endif - g(i,j)=fmp/(hx*hy) -!----------- - enddo - enddo -!reflections: - do j=1,ny - do i=1+nx,nx+nx - g(i,j)=g(n1-i+2,j) - enddo - enddo - do j=1+ny,ny+ny - do i=1,nx - g(i,j)=-g(i,n2-j+2) - enddo - enddo - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j)=-g(n1-i+2,n2-j+2) - enddo - enddo -! compute FFT of the Green function - scale=1.0 -! write(6,*)'calling fft2dhpf in greenfy' - call fft2dhpf(n1,n2,1,0,scale,0,g,gxtr) -! write(6,*)'returned from fft2dhpf in greenfy' - return - end -! - subroutine greenfxold(gxtr,rho,nx,ny,n1,n2) -! green function routine. - implicit double precision(a-h,o-z) - double complex g,gxtr - dimension g(n1,n2),gxtr(n2,n1) - dimension rho(nx,ny) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi -! - gfunx(x,y,e2)=x/(x**2+y**2+e2) -! -! write(6,*)'inside greenfxold' - eps2=1.d-20 -! compute integrals involving the Green function for Ex: - do j=1,ny+1 - y0=hy*(j-1) - y1=hy*j - do i=1,nx+1 - x0=hx*(i-1) - x1=hx*i -!----------- - fmp=gfunx(x0,y0,eps2) - g(i,j)=fmp*hx*hy -!----------- - enddo - enddo -!reflections: - do j=1,ny - do i=1+nx,nx+nx - g(i,j)=-g(n1-i+2,j) - enddo - enddo - do j=1+ny,ny+ny - do i=1,nx - g(i,j)=g(i,n2-j+2) - enddo - enddo - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j)=-g(n1-i+2,n2-j+2) - enddo - enddo -! -! compute FFT of the Green function - scale=1.0 -! write(6,*)'calling fft2dhpf in greenfx' - call fft2dhpf(n1,n2,1,0,scale,0,g,gxtr) -! write(6,*)'returned from fft2dhpf in greenfx' - return - end -! -!============================================================= -! - subroutine greenfyold(gxtr,rho,nx,ny,n1,n2) -! green function routine. - implicit double precision(a-h,o-z) - double complex g,gxtr - dimension g(n1,n2),gxtr(n2,n1) - dimension rho(nx,ny),fyg(nx,ny) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi -! - gfuny(x,y,e2)=y/(x**2+y**2+e2) -! -! write(6,*)'inside greenfyold' - eps2=1.d-20 -! compute integrals involving the Green function for Ey: - do j=1,ny+1 - y0=hy*(j-1) - y1=hy*j - do i=1,nx+1 - x0=hx*(i-1) - x1=hx*i -!----------- - fmp=gfuny(x0,y0,eps2) - g(i,j)=fmp*hx*hy -!----------- - enddo - enddo -!reflections: - do j=1,ny - do i=1+nx,nx+nx - g(i,j)=g(n1-i+2,j) - enddo - enddo - do j=1+ny,ny+ny - do i=1,nx - g(i,j)=-g(i,n2-j+2) - enddo - enddo - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j)=-g(n1-i+2,n2-j+2) - enddo - enddo -! compute FFT of the Green function - scale=1.0 -! write(6,*)'calling fft2dhpf in greenfy' - call fft2dhpf(n1,n2,1,0,scale,0,g,gxtr) -! write(6,*)'returned from fft2dhpf in greenfy' - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d.f b/OpticsJan2020/MLI_light_optics/Src/spch3d.f deleted file mode 100755 index 22bcdf9..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/spch3d.f +++ /dev/null @@ -1,1274 +0,0 @@ -!*********************************************************************** -! -! IMPACT 3D space charge routines -! Copyright 2001 University of California -! -! subroutine SPCH3D(c,ex,ey,ez,msk,Np,Ntot, -! & Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,rparams,cparams) -! Arguments in SPCH3D(...) -! c in:out (1:5:2,*) are x,y,z coordinates of particles -! NB: in the rest of MLI, col.5 denotes time-of-flight (i.e., phase), -! but prior to calling the space-charge routines, it is -! converted to longitudinal position z -! (2:6:4,*) are momenta and not used here -! ex,ey,ez :out electric field at particles -! msk :in flag indicating valid particles -! Np :in number of particles (good and bad) on this processor -! Ntot :in number of (good) particles on all processors -! Nx,Ny,Nz :in dimensions of grid on the regular sized grid -! N1,N2,N3 :in dimensions of the bigger (usually doubled) grid -! N3a :in =Nz for longitudinal periodic BCs, =2*Nz for open -! Nadj :in =0 for long. open or Dirichlet BCs, >=1 for periodic -! -! Globals: -! ISolve :in flag denoting Poisson solver to use -! 1 for default Infinite Domain -! 1x for ANAG ID -! 2x for ANAG Homogenous Dirichlet -! 30 for Chombo AMR Homogenous Dirichlet -! 4x for Chombo AMR Infinite Domain -! here "x" denotes the discretization to use -! 0 for Spectral (MLI-style) -! 1 for Laplace (Chombo-style 7-point) -! 2 for Mehrstellen O(h^6) -! 3 for Mehrstellen O(h^4) -! -!*********************************************************************** - subroutine spch3d(c,ex,ey,ez,msk,np,ntot, & - & nx,ny,nz,n1,n2,n3,n3a,nadj,rparams,cparams) - use parallel - implicit none -!Arguments - integer np,ntot,nx,ny,nz,n1,n2,n3,n3a,nadj - double precision c(6,np) - double precision ex(np),ey(np),ez(np) - logical msk(np) - double precision rparams - character*16 cparams - dimension rparams(60),cparams(60) -!Local variables - double precision phi(nx,ny,nz) - integer i,j,k ,ip -!Globals - integer iverbose - common/showme/iverbose - integer idirectfieldcalc,idensityfunction,isolve,idum - common/newpoisson/idirectfieldcalc,idensityfunction,isolve,idum(2) - integer idirich - common/dirichlet/idirich - doubleprecision xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi -!Externals - -!Execute - -!----------------------------------------------------------------------- - -! save particle data in real coordinates for the Chombo programs - if (iverbose.GT.9.AND.idproc.EQ.0) then - write(6,*) 'Writing particle coords to file MLI.Pxyz.dat ...' - open(90,file='MLI.Pxyz.dat') - write(90,9001) ((c(i,ip),i=1,5,2),ip=1,Np) - close(90) - 9001 format(3(1x,E16.9)) - endif - -!----------------------------------------------------------------------- - -!dbs -- added other solvers and formatted output of phi - if( iverbose .ge. 5 .AND. idproc .eq. 0 ) - & write(6,*) 'in SPCH3D with solver,dirich = ',isolve,idirich - - if( isolve .ge. 1 .AND. isolve .lt. 10 )then - ! default open BC (infinite domain) solver - ![NOTE: the value of isolve isnt important because SPCH3D1() - ! ignores the fft_stencil input keyword because it only - ! implements the spectral stencil.] - if( idirich .ne. 0 )then - write(6,*) 'error: SPCH3D1: Dirichlet BC not supported' - stop 'SPCH3D1a' - endif - if( iverbose .ge. 6 .AND. idproc .eq. 0 ) - & write(6,*) 'SPCH3D: calling SPCH3D1' - call SPCH3D1( c ,ex,ey,ez ,msk & - & ,np,ntot,nx,ny,nz,n1,n2,n3,n3a,nadj,phi ) - - elseif( isolve .ge. 10 .and. isolve .lt. 20 )then - ! ANAG infinite domain solver - if( idirectfieldcalc .ne. 0 )then - write(6,*) 'error: SPCH3D2: solving_for=E not supported' - stop 'SPCH3D2a' - endif - if( idirich .ne. 0 )then - write(6,*) 'error: SPCH3D2: Dirichlet BC not supported' - stop 'SPCH3D2b' - endif - if( iverbose .ge. 6 .AND. idproc .eq. 0 ) - & write(6,*) 'SPCH3D: calling SPCH3D2' - call SPCH3D2( c ,ex,ey,ez ,msk & - & ,np,ntot,nx,ny,nz,n1,n2,n3,n3a,nadj,phi ) - - elseif( isolve .ge. 20 .and. isolve .lt. 30 )then - ! ANAG solver for homogenous Dirichlet BCs - if( idirectfieldcalc .ne. 0 )then - write(6,*) 'error: SPCH3DBC0: solving_for=E not supported' - stop 'SPCH3D0a' - endif - if( idirich .EQ. 0 )then - write(6,*) 'warning: SPCH3D: non-Dirichlet BC is inconsistent' - & ,' with SPCH3DBC0 solver.' - stop 'SPCH3D0b' - endif - if( iverbose .ge. 6 .AND. idproc .eq. 0 ) - & write(6,*) 'SPCH3D: calling SPCH3DBC0' - call SPCH3DBC0( c ,ex,ey,ez ,msk & - & ,np,ntot,nx,ny,nz,n1,n2,n3,n3a,nadj,phi ) - - elseif( isolve .ge. 30 .and. isolve .lt. 50 )then - ! ANAG Chombo AMR solver for infinite domain (open) or homogenous Dirichlet BCs - if( idirectfieldcalc .ne. 0 )then - write(6,*) 'error: SPCH3DAMR: solving_for=E not supported' - stop 'SPCH3DEAb' - endif - if( iverbose .ge. 6 .AND. idproc .eq. 0 ) - & write(6,*) 'SPCH3D: calling SPCH3DAMR' - call SPCH3DAMR( c ,ex,ey,ez ,msk & - & ,np,ntot,nx,ny,nz,n1,n2,n3,n3a,nadj,phi ) - - else - write(6,*) 'error: unknown solver = ',isolve - stop 'SPCH3D' - endif - -!----------------------------------------------------------------------- - - if( iverbose .ge. 10 .and. idproc .eq. 0 .AND. - & idirectfieldcalc .EQ. 0 )then !no phi is solving_for=E - write(6,*) 'Writing grid phi data to unit 86 ...' - write(86,8601)' phi on grid (',nx,ny,nz,'), h=' ,hx,hy,hz - write(86,*)' I J K X Y Z phi' - do k = 1 ,nz - do j = 1 ,ny - do i = 1 ,nx - write(86,8602) i,j,k - & ,xmin+(i-1)*hx,ymin+(j-1)*hy,zmin+(k-1)*hz ,phi(i,j,k) - enddo - enddo - enddo - elseif( iverbose .ge. 8 .and. idproc .eq. 0 )then - write(6,*) 'Writing grid centerline phi data to unit 86 ...' - write(86,8601)' phi on grid (',nx,ny,nz,'), h=' ,hx,hy,hz - write(86,*)' I J K X Y Z phi' - i=nx/2+1 - j=ny/2+1 - do k = 1 ,nz - write(86,8602) i,j,k - & ,xmin+(i-1)*hx,ymin+(j-1)*hy,zmin+(k-1)*hz ,phi(i,j,k) - enddo - i=nx/2+1 - k=nz/2+1 - do j = 1 ,ny - write(86,8602) i,j,k - & ,xmin+(i-1)*hx,ymin+(j-1)*hy,zmin+(k-1)*hz ,phi(i,j,k) - enddo - j=ny/2+1 - k=nz/2+1 - do i = 1 ,nx - write(86,8602) i,j,k - & ,xmin+(i-1)*hx,ymin+(j-1)*hy,zmin+(k-1)*hz ,phi(i,j,k) - enddo - write(6,*) 'Writing E on particles 1-10 to unit 87 ...' - write(87,8701)'p X Y Z Ex Ey Ez' - do ip = 1,10 - write(87,8702) ip,(c(i,ip),i=1,5,2),ex(ip),ey(ip),ez(ip) - enddo - endif - if( iverbose .ge. 9 .and. idproc .eq. 0 )then - write(6,*) 'Writing particle XYZ,E data to MLI.Pxyze.dat ...' - open(90,file='MLI.Pxyze.dat') - write(90,9002)((c(i,ip),i=1,5,2),ex(ip),ey(ip),ez(ip),ip=1,Np) - close(90) - endif - 8601 format(A,1x,3(I3,1x),A,1x,1P,3(E11.5,1x)) - 8602 format(1x,3(1X,I3),1P,3(1X,E15.8),4(1X,E15.8)) - 8701 format(1x,A) - 8702 format(1x,I2,1P,6(1x,E16.9)) - 9002 format(1P,6(1x,E16.9)) -!dbs -!Done - if( IVerbose .GT. 19 ) stop 'SPCHDONE' - if( iverbose .ge. 5 .AND. idproc .eq. 0 ) - & write(6,*) 'leaving SPCH3D' - - return - end -! -!*********************************************************************** - subroutine spch3d1(c,ex,ey,ez,msk,np,ntot, & - & nx,ny,nz,n1,n2,n3,n3a,nadj,rho) - use parallel - use spchdata - use intgreenfn - use ml_timer - implicit double precision(a-h,o-z) - real*8, dimension(6,np) :: c - logical, dimension(np) :: msk - real*8, dimension(np) :: ex,ey,ez - real*8, dimension(nx,ny,nz) :: rho,exg,eyg,ezg,rhosum - type (griddata) :: griddims - integer :: idebug=0 -cryne 8/4/2004 integer :: idebug=1 -!in module spchdata complex*16,dimension(n1,n2,n3a) :: rho2 -!in module spchdata complex*16,dimension(n3a,n2,n1) :: grnxtr,rho2xtr - -! rho=charge density on the grid -! rho2=...on doubled grid -! rho2xtr=...xformed (by fft) and transposed -! grnxtr=green function, xformed, transposed -! weights, indices associated with area weighting: - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi -!XXX common/accum/at10,at21,at32,at43,at54,at65,at76,at70 - common/showme/iverbose - common/gxyzsave/xmin0,xmax0,ymin0,ymax0,zmin0,zmax0,kfixbdy,madegr - common/gridxtra/xsml,xbig,ysml,ybig,zsml,zbig - common/newpoisson/idirectfieldcalc,idensityfunction,idum(3) - save idebug - -! if(idproc.eq.0)write(6,*)'inside spch3d' - iexactrho=0 - - iunity=1 - munity=-1 - izero=0 - scale=1.d0 - hxyz=hx*hy*hz - hxyzi=hxi*hyi*hzi - n123a=n1*n2*n3a - - if (idproc.eq.0.and.iverbose.ge.3) then - write(6,*) ' In spch3d1() ...' - write(6,*) ' {np ntot} = {',np,ntot,'}' - write(6,*) ' {nx ny nz} = {',nx,ny,nz,'}' - write(6,*) ' {hx hy hz} = {',hx,hy,hz,'}' - write(6,*) ' {n1 n2 n3} = {',n1,n2,n3,'}' - write(6,*) ' {hxi hyi hzi} = {',hxi,hyi,hzi,'}' - write(6,*) ' {n3a nadj} = {',n3a,nadj,'}' - write(6,*) ' hxyz = ',hxyz - write(6,*) ' hxyzi = ',hxyzi - write(6,*) ' nxyz = ',nx*ny*nz - write(6,*) ' n123 = ',n1*n2*n3 - write(6,*) ' n123a = ',n1*n2*n3a - end if -!====================================================================== -! deposit charge on the grid: - call increment_timer('rhoslo3d',0) - call rhoslo3d(c,rho,msk,np,nx,ny,nz,nadj) - call MPI_ALLREDUCE(rho,rhosum,nx*ny*nz,mreal,mpisum,lworld,ierror) - rho=rhosum - call increment_timer('rhoslo3d',1) -!-------- - if(iexactrho.eq.1)then - glrhochk=sum(rho) -! if(idproc.eq.0)write(6,*)'(exact rho): global sum = ',glrhochk - call getrms(c,xrms,yrms,zrms,np) -! if(idproc.eq.0)write(6,*)'xrms,yrms,zrms=',xrms,yrms,zrms - xmac=sqrt(5.d0)*xrms - ymac=sqrt(5.d0)*yrms - zmac=sqrt(5.d0)*zrms -! if(idproc.eq.0)write(6,*)'xmac,ymac,zmac=',xmac,ymac,zmac - rho=0.d0 - do k=1,nz - z=zmin+(k-1)*hz - do j=1,ny - y=ymin+(j-1)*hy - do i=1,nx - x=xmin+(i-1)*hx -! if((x/xbig)**2+(y/ybig)**2+(z/zbig)**2 .le.1.d0)rho(i,j,k)=1.d0 - if((x/xmac)**2+(y/ymac)**2+(z/zmac)**2 .le.1.d0)rho(i,j,k)=1.d0 - enddo - enddo - enddo - glrhonew=sum(rho) -! if(idproc.eq.0)write(6,*)'glrhonew=',glrhonew - rho=rho*glrhochk/glrhonew - glrhochk=sum(rho) -! if(idproc.eq.0)write(6,*)'new global sum of rho = ',glrhochk - endif -!ryne august 1, 2002 -!ryne moved normalization out of rhoslo to here: - rho=rho/(hx*hy*hz*ntot) - call system_clock(count=iticks1) -!-------- - ! print rho on the grid - if(iverbose.GT.9.AND.idproc.EQ.0)then - write(6,*) 'Writing grid rho data to unit 85 ...' - write(85,*)' SPCH3D rho on grid (',nx,ny,nz,'), h=',hx,hy,hz - write(85,*)' I J K X Y Z rho' - do k = 1 ,nz - do j = 1 ,ny - do i = 1 ,nx - write(85,8501) i,j,k - $ ,xmin+(i-1)*hx,ymin+(j-1)*hy,zmin+(k-1)*hz - $ ,rho(i,j,k) - enddo - enddo - enddo - 8501 format(1x,3(1X,I3),1P,3(1X,E15.8),1X,E15.8) - endif -!-------- -! keep a copy of rho for diagnostics: - if(iexactrho.eq.1)rhosum=rho - checknorm=hx*hy*hz*sum(rhosum) -! store rho in lower left quadrant of doubled grid: - do k=1,n3a - do j=1,n2 - do i=1,n1 - rho2(i,j,k)=0.d0 - enddo - enddo - enddo -cryne forall(i=1:nx,j=1:ny,k=1:nz)rho2(i,j,k)=cmplx(rho(i,j,k),0.) - do k=1,nz - do j=1,ny - do i=1,nx - rho2(i,j,k)=rho(i,j,k) - enddo - enddo - enddo -! fft the charge density: - call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,rho2xtr) -!====================================================================== -!HERE IS THE OLD IMPLEMENTATION THAT USES PHI AND CSHIFTS: - if(idirectfieldcalc.ne.1)then -! if(idproc.eq.0)write(6,*)'******obtaining scalar potential******' - call increment_timer('greenf3d',0) - if(madegr.eq.0 .or. kfixbdy.eq.0)then -! if (idproc.eq.0) then -! write(12,*) ' spch3d::spch3d1:' -! write(12,*) ' computing green function for phi' -! end if - griddims%NxIntrvl=nx-1 - griddims%NyIntrvl=ny-1 - griddims%NzIntrvl=nz-1 - griddims%Nx=nx; griddims%Nx2=n1; griddims%hx=hx - griddims%Ny=ny; griddims%Ny2=n2; griddims%hy=hy - griddims%Nz=nz; griddims%Nz2=n3; griddims%hz=hz - griddims%Vh=hxyz - griddims%Vhinv=hxyzi - if (idensityfunction.eq.0) then -! write(12,*) ' using function greenphi' - call greenphi(rho2,nx,ny,nz,n1,n2,n3,n3a,nadj) - else if (idensityfunction.eq.1) then -! write(12,*) ' using function intgreenphi' - call intgreenphi(griddims,rho2) - end if -c ===DBG=== -! write(6,*) ' === G_phi array ===' -! write(6,*) ' {hx,hy,hz} = {',hx,',',hy,',',hz,'}' -! gmn=rho2(1,1,1) -! gmx=gmn -! agmn=abs(gmn) -! agmx=agmn -! do iz=1,n1 -! do iy=1,n2 -! do ix=1,n1 -! g=rho2(ix,iy,iz) -! ag=abs(g) -! if(g.lt.gmn) gmn=g -! if(g.gt.gmx) gmx=g -! if(ag.lt.agmn) agmn=ag -! if(ag.gt.agmx) agmx=ag -! end do -! end do -! end do -! write(6,*) ' min(G_phi) =',gmn -! write(6,*) ' max(G_phi) =',gmx -! write(6,*) ' min(abs(G_phi)) =',agmn -! write(6,*) ' max(abs(G_phi)) =',agmx -! do iz=1,4 -! do iy=1,4 -! do ix=1,4 -! write(6,*) ix,iy,iz,rho2(ix,iy,iz) -! end do -! end do -! end do -! do iz=1,nz+1 -! do iy=1,ny+1 -! do ix=1,nx+1 -! g=rho2(ix,iy,iz) -! if (g.lt.0) write(6,'(3(1x,i3),2x,1pe12.5))') & -! & ix-1,iy-1,iz-1,g -! end do -! end do -! end do -c ========= - call increment_timer('greenf3d',1) - call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,xgrnxtr) - madegr=1 - else -! if(idproc.eq.0)write(12,*)'using saved green function' - call increment_timer('greenf3d',1) - endif - grnxtr=rho2xtr*xgrnxtr/n123a - call fft3dhpf(n3a,n2,n1,munity,scale,izero,nadj,grnxtr,rho2) - rho(1:nx,1:ny,1:nz)=hxyz*real(rho2(1:nx,1:ny,1:nz)) -! obtain the electric fields: -!XXX exg=0.d0 -!XXX eyg=0.d0 -!XXX ezg=0.d0 - exg=cshift(rho,-1,1) - exg=exg-cshift(rho,1,1) - exg=exg*(0.5*hxi) - eyg=cshift(rho,-1,2) - eyg=eyg-cshift(rho,1,2) - eyg=eyg*(0.5*hyi) -!XXX exg=0.5*hxi*(cshift(rho,-1,1)-cshift(rho,1,1)) -!XXX eyg=0.5*hyi*(cshift(rho,-1,2)-cshift(rho,1,2)) -! ezg=0.5*hzi*(cshift(rho,-1,3)-cshift(rho,1,3)) -! the previous statement (ezg=...) causes a crash on seaborg. Replace with: - ezg=cshift(rho,-1,3) - ezg=ezg-cshift(rho,1,3) - ezg=ezg*(0.5*hzi) - else - !======================================================= - ! New implementation that solves for E directly: - ! compute the Green function on the grid (use rho2 for storage): - call increment_timer('greenf3d',0) - if(madegr.eq.0 .or. kfixbdy.eq.0)then -! if(idproc.eq.0)write(12,*)'computing green function' - call greenfx(rho2,nx,ny,nz,n1,n2,n3,n3a,nadj) - call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,xgrnxtr) - call greenfy(rho2,nx,ny,nz,n1,n2,n3,n3a,nadj) - call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,ygrnxtr) - call greenfz(rho2,nx,ny,nz,n1,n2,n3,n3a,nadj) - call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,zgrnxtr) - madegr=1 - else -! if(idproc.eq.0)write(12,*)'using saved green function' - endif - call increment_timer('greenf3d',1) - !======================================================== -! if(idproc.eq.0)write(6,*)'starting convolution' - !---------convolution------------ - grnxtr=rho2xtr*xgrnxtr/n123a - call fft3dhpf(n3a,n2,n1,munity,scale,izero,nadj,grnxtr,rho2) - exg(1:nx,1:ny,1:nz)=hxyz*real(rho2(1:nx,1:ny,1:nz)) - - grnxtr=rho2xtr*ygrnxtr/n123a - call fft3dhpf(n3a,n2,n1,munity,scale,izero,nadj,grnxtr,rho2) - eyg(1:nx,1:ny,1:nz)=hxyz*real(rho2(1:nx,1:ny,1:nz)) - - grnxtr=rho2xtr*zgrnxtr/n123a - call fft3dhpf(n3a,n2,n1,munity,scale,izero,nadj,grnxtr,rho2) - ezg(1:nx,1:ny,1:nz)=hxyz*real(rho2(1:nx,1:ny,1:nz)) - !----done with convolution------- - endif - -! if(idproc.eq.0)write(6,*)'done with convolution' -!--------------- - if((idebug.eq.1.or.iverbose.ge.8) .and. idproc.eq.0)then - write(6,*)'writing out potential and fields' - do i=1,nx - j=ny/2+1 - k=nz/2+1 - xval=xmin+(i-1)*hx - yval=ymin+(j-1)*hy - zval=zmin+(k-1)*hz - del2=0.d0 - if(i.gt.1 .and. i.lt.nx)then - del2=(exg(i+1,j,k)-exg(i-1,j,k))*0.5*hxi+ & - & (eyg(i,j+1,k)-eyg(i,j-1,k))*0.5*hyi+ & - & (ezg(i,j,k+1)-ezg(i,j,k-1))*0.5*hzi - endif - write(61,1001)xval,yval,zval, & - & rho(i,j,k),exg(i,j,k),eyg(i,j,k),ezg(i,j,k) & - & ,rhosum(i,j,k),del2 - enddo - write(61,*)' ' - call myflush(61) - do j=1,ny - i=nx/2+1 - k=nz/2+1 - xval=xmin+(i-1)*hx - yval=ymin+(j-1)*hy - zval=zmin+(k-1)*hz - del2=0.d0 - if(j.gt.1 .and. j.lt.ny)then - del2=(exg(i+1,j,k)-exg(i-1,j,k))*0.5*hxi+ & - & (eyg(i,j+1,k)-eyg(i,j-1,k))*0.5*hyi+ & - & (ezg(i,j,k+1)-ezg(i,j,k-1))*0.5*hzi - endif - write(62,1001)xval,yval,zval, & - & rho(i,j,k),exg(i,j,k),eyg(i,j,k),ezg(i,j,k) & - & ,rhosum(i,j,k),del2 - enddo - write(62,*)' ' - call myflush(62) - do k=1,nz - i=nx/2+1 - j=ny/2+1 - xval=xmin+(i-1)*hx - yval=ymin+(j-1)*hy - zval=zmin+(k-1)*hz - del2=0.d0 - if(k.gt.1 .and. k.lt.nz)then - del2=(exg(i+1,j,k)-exg(i-1,j,k))*0.5*hxi+ & - & (eyg(i,j+1,k)-eyg(i,j-1,k))*0.5*hyi+ & - & (ezg(i,j,k+1)-ezg(i,j,k-1))*0.5*hzi - endif - write(63,1001)xval,yval,zval, & - & rho(i,j,k),exg(i,j,k),eyg(i,j,k),ezg(i,j,k) & - & ,rhosum(i,j,k),del2 - enddo - write(63,*)' ' - call myflush(63) - 1001 format(9(1pe13.6,1x)) - - endif - if( IVerbose .GT. 11 .AND. idproc .EQ. 0 )then - write(6,*) 'Writing grid E data to unit 88 ...' - write(88,8601)' phi on grid (',nx,ny,nz,'), h=' ,hx,hy,hz - write(88,8701)' I J K X Y ' - & ,' Z Ex ' - & ,'Ey Ez' - do k = 1 ,nz - do j = 1 ,ny - do i = 1 ,nx - write(88,8602) i,j,k,xmin+(i-1)*hx,ymin+(j-1)*hy - & ,zmin+(k-1)*hz - & ,exg(i,j,k),eyg(i,j,k),ezg(i,j,k) - enddo - enddo - enddo - endif - 8601 format(A,1x,3(I3,1x),A,1x,1P,3(E11.5,1x)) - 8602 format(1x,3(1X,I3),1P,3(1X,E15.8),4(1X,E15.8)) - 8701 format(1x,A,A,A) - - - if(idebug.eq.1)then - write(6,*)'PE',idproc,':hxyz,n123a=',hxyz,n123a - write(6,*)'PE',idproc,':rho2xtr(4,6,8),=',rho2xtr(4,6,8) - write(6,*)'PE',idproc,':xgrnxtr(4,6,8),=',xgrnxtr(4,6,8) - endif - if(idebug.eq.1)idebug=0 -!--------------- -! -! -! if(idproc.eq.0)write(6,*)'interpolating electric fields' -! interpolate electric field at particle postions: - call increment_timer('ntrslo3d',0) - call ntrslo3d(c,exg,eyg,ezg,ex,ey,ez,msk,nx,ny,nz,np,nadj) - call increment_timer('ntrslo3d',1) -! if(idproc.eq.0)write(6,*)'done interpolating; leaving spch3d' - return - end - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - subroutine rhoslo3d(coord,rho,msk,np,nx,ny,nz,nadj) -cryne 08/24/2001 use hpf_library - implicit double precision(a-h,o-z) - logical msk - dimension coord(6,np),msk(np) - dimension rho(nx,ny,nz) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - common/showme/iverbose -! if(idproc.eq.0) write(6,*)'inside rhoslo3d' -! write(6,*)'xmin,xmax=',xmin,xmax -! write(6,*)'nx,ny,nz=',nx,ny,nz -! write(6,*)'nadj=',nadj -! xminnn=minval(coord(1,:)) -! xmaxxx=maxval(coord(1,:)) -! write(6,*)'xminnn,xmaxxx=',xminnn,xmaxxx -cryne 6/25/2002 do i=1,np - rho=0. - do n=1,np -c INSERT STATEMENT HERE TO SKIP IF MSK(N)=.FALSE. - indx=(coord(1,n)-xmin)*hxi + 1 - jndx=(coord(3,n)-ymin)*hyi + 1 - kndx=(coord(5,n)-zmin)*hzi + 1 - indxp1=indx+1 - jndxp1=jndx+1 - kndxp1=kndx+1 - ab=((xmin-coord(1,n))+indx*hx)*hxi - de=((ymin-coord(3,n))+jndx*hy)*hyi - gh=((zmin-coord(5,n))+kndx*hz)*hzi -!------- - imin=indx - imax=indx - jmin=jndx - jmax=jndx - kmin=kndx - kmax=kndx - if((imin.lt.1).or.(imax.gt.nx-1))then - write(6,*)'error in rhoslo3d: imin,imax=',imin,imax - write(6,*)'nx,xmin,xmax,hx=',nx,xmin,xmax,hx - write(6,*)'nadj=',nadj - call myexit - endif - if((jmin.lt.1).or.(jmax.gt.ny-1))then - write(6,*)'error in rhoslo3d: jmin,jmax=',jmin,jmax - call myexit - endif - if(nadj.eq.0)then - if((kmin.lt.1).or.(kmax.gt.nz-1))then - write(6,*)'error in rhoslo3d (nadj=0): kmin,kmax=',kmin,kmax - call myexit - endif - endif - if(nadj.eq.1)then - if((kmin.lt.1).or.(kmax.gt.nz))then - write(6,*)'error in rhoslo3d (nadj=1): kmin,kmax=',kmin,kmax - call myexit - endif - endif -!------- - if(nadj.eq.1)then - if(kndxp1.eq.nz+1)kndxp1=1 - endif -!1 (i,j,k): - rho(indx,jndx,kndx)=rho(indx,jndx,kndx)+ab*de*gh -!2 (i,j+1,k): - rho(indx,jndxp1,kndx)=rho(indx,jndxp1,kndx)+ab*(1.-de)*gh -!3 (i,j+1,k+1): - rho(indx,jndxp1,kndxp1)=rho(indx,jndxp1,kndxp1)+ab*(1.-de)*(1.-gh) -!4 (i,j,k+1): - rho(indx,jndx,kndxp1)=rho(indx,jndx,kndxp1)+ab*de*(1.-gh) -!5 (i+1,j,k+1): - rho(indxp1,jndx,kndxp1)=rho(indxp1,jndx,kndxp1)+(1.-ab)*de*(1.-gh) -!6 (i+1,j+1,k+1): - rho(indxp1,jndxp1,kndxp1)= & - &rho(indxp1,jndxp1,kndxp1)+(1.-ab)*(1.-de)*(1.-gh) -!7 (i+1,j+1,k): - rho(indxp1,jndxp1,kndx)=rho(indxp1,jndxp1,kndx)+(1.-ab)*(1.-de)*gh -!8 (i+1,j,k): - rho(indxp1,jndx,kndx)=rho(indxp1,jndx,kndx)+(1.-ab)*de*gh - enddo -! -cryne august 1, 2002: -cccc ngood=count(msk) -cccc write(6,*)'ngood=',ngood -cccc rho=rho/ngood -!wrong rho=rho/ngood*hxi*hyi*hzi -! if(idproc.eq.0)write(6,*)'leaving rhoslo3d' -! rhochk=sum(rho) -! write(6,*)'[rhoslo3d]sum(rho)=',rhochk - return - end - - subroutine ntrslo3d(coord,exg,eyg,ezg,ex,ey,ez,msk,nx,ny,nz,np, & - & nadj) - use parallel - implicit double precision(a-h,o-z) - logical msk - dimension coord(6,np) - dimension exg(nx,ny,nz),eyg(nx,ny,nz),ezg(nx,ny,nz) -!hpf$ distribute exg(*,*,block) -!hpf$ align (*,*,:) with exg(*,*,:) :: eyg,ezg - dimension ex(np),ey(np),ez(np),msk(np) - dimension abz(np),dez(np),ghz(np),indz(np),jndz(np),kndz(np), - &indzp1(np),jndzp1(np),kndzp1(np) -!hpf$ template t1(np) -!hpf$ distribute t1(block) -!hpf$ align (:) with t1(:) :: ex,ey,ez,msk,ab,de,gh -!hpf$ align (:) with t1(:) :: indx,jndx,kndx,indxp1,jndxp1,kndxp1 - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi -! if(idproc.eq.0)write(6,*)'inside ntrslo3d' -! if(idproc.eq.0)then -! do n=1,np -! if(indx(n).lt.1 .or. indx(n).gt.nx)write(6,*)'error: indx(n)' -! enddo -! do n=1,np -! if(jndx(n).lt.1 .or. jndx(n).gt.ny)write(6,*)'error: jndx(n)' -! enddo -! do n=1,np -! if(kndx(n).lt.1 .or. kndx(n).gt.nz)write(6,*)'error: kndx(n)' -! enddo -! do n=1,np -! if(indxp1(n).lt.1.or.indxp1(n).gt.nx)write(6,*)'err:indxp1(n)' -! enddo -! do n=1,np -! if(jndxp1(n).lt.1.or.jndxp1(n).gt.ny)write(6,*)'err:jndxp1(n)' -! enddo -! do n=1,np -! if(kndxp1(n).lt.1.or.kndxp1(n).gt.nz)write(6,*)'err:kndxp1(n)' -! enddo -! endif -cryne forall(n=1:np)ex(n)= - do 100 n=1,np - indx=(coord(1,n)-xmin)*hxi + 1 - jndx=(coord(3,n)-ymin)*hyi + 1 - kndx=(coord(5,n)-zmin)*hzi + 1 - indxp1=indx+1 - jndxp1=jndx+1 - kndxp1=kndx+1 -!cryne August 4, 2004 ------- - if(nadj.eq.1)then - if(kndxp1.eq.nz+1)kndxp1=1 - endif -!cryne ------- - ab=((xmin-coord(1,n))+indx*hx)*hxi - de=((ymin-coord(3,n))+jndx*hy)*hyi - gh=((zmin-coord(5,n))+kndx*hz)*hzi - ex(n)= & - & exg(indx,jndx,kndx)*ab*de*gh - &+exg(indx,jndxp1,kndx)*ab*(1.-de)*gh - &+exg(indx,jndxp1,kndxp1)*ab*(1.-de)*(1.-gh) - &+exg(indx,jndx,kndxp1)*ab*de*(1.-gh) - &+exg(indxp1,jndx,kndxp1)*(1.-ab)*de*(1.-gh) - &+exg(indxp1,jndxp1,kndxp1)*(1.-ab)*(1.-de)*(1.-gh) - &+exg(indxp1,jndxp1,kndx)*(1.-ab)*(1.-de)*gh - &+exg(indxp1,jndx,kndx)*(1.-ab)*de*gh - - ey(n)= & - & eyg(indx,jndx,kndx)*ab*de*gh - &+eyg(indx,jndxp1,kndx)*ab*(1.-de)*gh - &+eyg(indx,jndxp1,kndxp1)*ab*(1.-de)*(1.-gh) - &+eyg(indx,jndx,kndxp1)*ab*de*(1.-gh) - &+eyg(indxp1,jndx,kndxp1)*(1.-ab)*de*(1.-gh) - &+eyg(indxp1,jndxp1,kndxp1)*(1.-ab)*(1.-de)*(1.-gh) - &+eyg(indxp1,jndxp1,kndx)*(1.-ab)*(1.-de)*gh - &+eyg(indxp1,jndx,kndx)*(1.-ab)*de*gh - - ez(n)= & - & ezg(indx,jndx,kndx)*ab*de*gh - &+ezg(indx,jndxp1,kndx)*ab*(1.-de)*gh - &+ezg(indx,jndxp1,kndxp1)*ab*(1.-de)*(1.-gh) - &+ezg(indx,jndx,kndxp1)*ab*de*(1.-gh) - &+ezg(indxp1,jndx,kndxp1)*(1.-ab)*de*(1.-gh) - &+ezg(indxp1,jndxp1,kndxp1)*(1.-ab)*(1.-de)*(1.-gh) - &+ezg(indxp1,jndxp1,kndx)*(1.-ab)*(1.-de)*gh - &+ezg(indxp1,jndx,kndx)*(1.-ab)*de*gh - 100 continue -! if(idproc.eq.0)write(6,*)'leaving ntrslo3d' - return - end -c -c block data etimes -c common/accum/at10,at21,at32,at43,at54,at65,at76,at70 -c data at10,at21,at32,at43,at54,at65,at76,at70/0.,0.,0.,0.,0.,0.,0.,& -c & 0./ -c end -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine getrms(cblock,xrms,yrms,zrms,np) - use beamdata - use rays - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'map.inc' - real*8, dimension(6,np) :: cblock -! - dimension diag(16),rdiag(16) -! if(1.gt.0)return -! rms quantities: - den1=1./nrays - den2=den1*den1 - econ=1.0 - xl=sl - xk=1./xl - gambet=gamma*beta - z=arclen -! xbar=sum(cblock(1,1:nraysp))*xl*den1 -! ybar=sum(cblock(3,1:nraysp))*xl*den1 -! zbar=sum(cblock(5,1:nraysp))*(beta/xk)*den1 -! sq1=sum(cblock(1,1:nraysp)*cblock(1,1:nraysp))*xl**2 -! sq2=sum(cblock(2,1:nraysp)*cblock(2,1:nraysp))/gambet**2*econ**2 -! sq3=sum(cblock(3,1:nraysp)*cblock(3,1:nraysp))*xl**2 -! sq4=sum(cblock(4,1:nraysp)*cblock(4,1:nraysp))/gambet**2*econ**2 -! xpx=sum(cblock(1,1:nraysp)*cblock(2,1:nraysp))*xl/gambet*econ -! ypy=sum(cblock(3,1:nraysp)*cblock(4,1:nraysp))*xl/gambet*econ - diag(1)=sum(cblock(1,1:nraysp))*den1 - diag(2)=sum(cblock(3,1:nraysp))*den1 - diag(3)=sum(cblock(5,1:nraysp))*den1 - diag(4)=sum(cblock(1,1:nraysp)*cblock(1,1:nraysp)) - diag(5)=sum(cblock(2,1:nraysp)*cblock(2,1:nraysp)) - diag(6)=sum(cblock(3,1:nraysp)*cblock(3,1:nraysp)) - diag(7)=sum(cblock(4,1:nraysp)*cblock(4,1:nraysp)) - diag(8)=sum(cblock(5,1:nraysp)*cblock(5,1:nraysp)) - diag(9)=sum(cblock(6,1:nraysp)*cblock(6,1:nraysp)) - diag(10)=sum(cblock(1,1:nraysp)*cblock(2,1:nraysp)) - diag(11)=sum(cblock(3,1:nraysp)*cblock(4,1:nraysp)) - diag(12)=sum(cblock(5,1:nraysp)*cblock(6,1:nraysp)) - call MPI_ALLREDUCE(diag,rdiag,12,mreal,mpisum,lworld,ierror) -c------- - xbar=rdiag(1) - ybar=rdiag(2) - zbar=rdiag(3) - sq1=rdiag(4) - sq2=rdiag(5) - sq3=rdiag(6) - sq4=rdiag(7) - sq5=rdiag(8) - sq6=rdiag(9) - xpx=rdiag(10) - ypy=rdiag(11) - zpz=rdiag(12) -c------- - epsx2=(sq1*sq2-xpx*xpx)*den2 - epsy2=(sq3*sq4-ypy*ypy)*den2 - epsz2=(sq5*sq6-zpz*zpz)*den2 - xrms=sqrt( sq1*den1 ) - yrms=sqrt( sq3*den1 ) - zrms=sqrt( sq5*den1 ) - pxrms=sqrt( sq2*den1 ) - pyrms=sqrt( sq4*den1 ) - pzrms=sqrt( sq6*den1 ) - zero=0. - epsx=sqrt(max(epsx2,zero)) - epsy=sqrt(max(epsy2,zero)) - epsz=sqrt(max(epsz2,zero)) - xpx=xpx*den1 - ypy=ypy*den1 - zpz=zpz*den1 - xpxfac=0. - ypyfac=0. - zpzfac=0. - if(xrms.ne.0. .and. pxrms.ne.0.)xpxfac=1./(xrms*pxrms) - if(yrms.ne.0. .and. pyrms.ne.0.)ypyfac=1./(yrms*pyrms) - if(zrms.ne.0. .and. pzrms.ne.0.)zpzfac=1./(zrms*pzrms) - return - end -c -c-------------------------------------------------------------- -c-------------------------------------------------------------- - - subroutine greenphi(g,nx,ny,nz,n1,n2,n3,n3a,nadj) -! green function routine. - implicit double precision(a-h,o-z) - complex*16 g - dimension g(n1,n2,n3a) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - gfun(x,y,z)=1.d0/sqrt(x**2+y**2+z**2+1.d-20) -! -!******* -! 3/21/2003 include correct factor of 1/(4pi) in the Green function: - fourpi=8.d0*(asin(1.d0)) - fourpinv=1.d0/fourpi -!******* -! write(6,*)'inside greenphi' - if(nadj.eq.1)goto 50 -! write(6,*)'(greenf): isolated boundary conditions' -! zero adjacent bunches (isolated boundary conditions): - do k=1,nz+1 - z=(k-1)*hz - do j=1,ny+1 - y=(j-1)*hy - do i=1,nx+1 - x=(i-1)*hx - g(i,j,k)=fourpinv*gfun(x,y,z) - enddo - enddo - enddo -!OTHER OPTIONS POSSIBLE HERE: -!!! g(1,1,1)=0.d0 - g(1,1,1)=g(1,1,2) -! - do k=1,nz - do j=1,ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,j,k) - enddo - enddo - enddo - do k=1,nz - do j=1+ny,ny+ny - do i=1,nx - g(i,j,k)=g(i,n2-j+2,k) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1,ny - do i=1,nx - g(i,j,k)=g(i,j,n3-k+2) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1+ny,ny+ny - do i=1,nx - g(i,j,k)=g(i,n2-j+2,n3-k+2) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1,ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,j,n3-k+2) - enddo - enddo - enddo - do k=1,nz - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,n2-j+2,k) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,n2-j+2,n3-k+2) - enddo - enddo - enddo - goto 200 -! adjacent bunches (periodic boundary conditions): - 50 continue -! nbunch=200 - nbunch=20 - d=hz*nz - do 100 k=-nz/2,nz/2-1 - do 99 j=-ny,ny-1 - do 98 i=-nx,nx-1 - if(i.eq.0 .and. j.eq.0 .and. k.eq.0)goto 98 - tmp=0.d0 - do n=-nbunch,nbunch - tmp=tmp+1.0/(fourpi*sqrt( (hx*i)**2+(hy*j)**2+(hz*k+n*d)**2)) - enddo - g(1+mod(i+n1,n1),1+mod(j+n2,n2),1+mod(k+nz,nz))=tmp - 98 continue - 99 continue - 100 continue - g(1,1,1)=g(1,1,2) - 200 continue -! write(6,*)'leaving greenphi' - return - end -c-------------------------------------------------------------- -c-------------------------------------------------------------- - - subroutine greenfx(g,nx,ny,nz,n1,n2,n3,n3a,nadj) -! green function routine. - implicit double precision(a-h,o-z) - complex*16 g - dimension g(n1,n2,n3a) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - gfun(x,y,z)=x/sqrt(x**2+y**2+z**2+1.d-20)**3 -! -!******* -! 3/21/2003 include correct factor of 1/(4pi) in the Green function: - fourpi=8.d0*(asin(1.d0)) - fourpinv=1.d0/fourpi -!******* -! write(6,*)'inside greenfx' - if(nadj.eq.1)goto 50 -! write(6,*)'(greenf): isolated boundary conditions' -! zero adjacent bunches (isolated boundary conditions): - do k=1,nz+1 - z=(k-1)*hz - do j=1,ny+1 - y=(j-1)*hy - do i=1,nx+1 - x=(i-1)*hx - g(i,j,k)=fourpinv*gfun(x,y,z) - enddo - enddo - enddo - g(1,1,1)=0.d0 -! - do k=1,nz - do j=1,ny - do i=1+nx,nx+nx - g(i,j,k)=-g(n1-i+2,j,k) - enddo - enddo - enddo - do k=1,nz - do j=1+ny,ny+ny - do i=1,nx - g(i,j,k)=g(i,n2-j+2,k) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1,ny - do i=1,nx - g(i,j,k)=g(i,j,n3-k+2) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1+ny,ny+ny - do i=1,nx - g(i,j,k)=g(i,n2-j+2,n3-k+2) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1,ny - do i=1+nx,nx+nx - g(i,j,k)=-g(n1-i+2,j,n3-k+2) - enddo - enddo - enddo - do k=1,nz - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j,k)=-g(n1-i+2,n2-j+2,k) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j,k)=-g(n1-i+2,n2-j+2,n3-k+2) - enddo - enddo - enddo - goto 200 -! adjacent bunches (periodic boundary conditions): - 50 continue - if(idproc.eq.0)write(6,*)'(greenfx)THIS PORTION OF CODE IS BROKEN' -! nbunch=200 - nbunch=20 - d=hz*nz - do 100 k=-nz/2,nz/2-1 - do 99 j=-ny,ny-1 - do 98 i=-nx,nx-1 - if(i.eq.0 .and. j.eq.0 .and. k.eq.0)goto 98 - tmp=0.d0 - do n=-nbunch,nbunch - tmp=tmp+(hx*i)/(fourpi*sqrt((hx*i)**2+(hy*j)**2+(hz*k+n*d)**2))**3 - enddo - g(1+mod(i+n1,n1),1+mod(j+n2,n2),1+mod(k+nz,nz))=tmp - 98 continue - 99 continue - 100 continue -!cryne July 7, 2004 g(1,1,1)=g(1,1,2) - g(1,1,1)=0.d0 - 200 continue -! write(6,*)'leaving greenfx' - return - end - -c-------------------------------------------------------------- -c-------------------------------------------------------------- - - subroutine greenfy(g,nx,ny,nz,n1,n2,n3,n3a,nadj) -! green function routine. - implicit double precision(a-h,o-z) - complex*16 g - dimension g(n1,n2,n3a) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - gfun(x,y,z)=y/sqrt(x**2+y**2+z**2+1.d-20)**3 -! -!******* -! 3/21/2003 include correct factor of 1/(4pi) in the Green function: - fourpi=8.d0*(asin(1.d0)) - fourpinv=1.d0/fourpi -!******* -! write(6,*)'inside greenfy' - if(nadj.eq.1)goto 50 -! write(6,*)'(greenf): isolated boundary conditions' -! zero adjacent bunches (isolated boundary conditions): - do k=1,nz+1 - z=(k-1)*hz - do j=1,ny+1 - y=(j-1)*hy - do i=1,nx+1 - x=(i-1)*hx - g(i,j,k)=fourpinv*gfun(x,y,z) - enddo - enddo - enddo - g(1,1,1)=0.d0 -!case2 g(1,1,1)=2.d0*g(1,1,2) -!case3 g(1,1,1)=g(2,1,1) -! - do k=1,nz - do j=1,ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,j,k) - enddo - enddo - enddo - do k=1,nz - do j=1+ny,ny+ny - do i=1,nx - g(i,j,k)=-g(i,n2-j+2,k) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1,ny - do i=1,nx - g(i,j,k)=g(i,j,n3-k+2) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1+ny,ny+ny - do i=1,nx - g(i,j,k)=-g(i,n2-j+2,n3-k+2) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1,ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,j,n3-k+2) - enddo - enddo - enddo - do k=1,nz - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j,k)=-g(n1-i+2,n2-j+2,k) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j,k)=-g(n1-i+2,n2-j+2,n3-k+2) - enddo - enddo - enddo - goto 200 -! adjacent bunches (periodic boundary conditions): - 50 continue - if(idproc.eq.0)write(6,*)'(greenfy)THIS PORTION OF CODE IS BROKEN' -! nbunch=200 - nbunch=20 - d=hz*nz - do 100 k=-nz/2,nz/2-1 - do 99 j=-ny,ny-1 - do 98 i=-nx,nx-1 - if(i.eq.0 .and. j.eq.0 .and. k.eq.0)goto 98 - tmp=0.d0 - do n=-nbunch,nbunch - tmp=tmp+(hy*j)/(fourpi*sqrt((hx*i)**2+(hy*j)**2+(hz*k+n*d)**2))**3 - enddo - g(1+mod(i+n1,n1),1+mod(j+n2,n2),1+mod(k+nz,nz))=tmp - 98 continue - 99 continue - 100 continue -!cryne July 7, 2004 g(1,1,1)=g(1,1,2) - g(1,1,1)=0.d0 - 200 continue -! write(6,*)'leaving greenfy' - return - end - -c-------------------------------------------------------------- -c-------------------------------------------------------------- - - subroutine greenfz(g,nx,ny,nz,n1,n2,n3,n3a,nadj) - use parallel, only : idproc -! green function routine. - implicit double precision(a-h,o-z) - complex*16 g - dimension g(n1,n2,n3a) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - gfun(x,y,z)=z/sqrt(x**2+y**2+z**2+1.d-20)**3 -! -!******* -! 3/21/2003 include correct factor of 1/(4pi) in the Green function: - fourpi=8.d0*(asin(1.d0)) - fourpinv=1.d0/fourpi -!******* - if(idproc.eq.0)write(6,*)'inside greenfz' - if(nadj.eq.1)goto 50 -! write(6,*)'(greenf): isolated boundary conditions' -! zero adjacent bunches (isolated boundary conditions): - do k=1,nz+1 - z=(k-1)*hz - do j=1,ny+1 - y=(j-1)*hy - do i=1,nx+1 - x=(i-1)*hx - g(i,j,k)=fourpinv*gfun(x,y,z) - enddo - enddo - enddo - g(1,1,1)=0.d0 -!case2 g(1,1,1)=2.d0*g(1,1,2) -!case3 g(1,1,1)=g(2,1,1) -! - do k=1,nz - do j=1,ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,j,k) - enddo - enddo - enddo - do k=1,nz - do j=1+ny,ny+ny - do i=1,nx - g(i,j,k)=g(i,n2-j+2,k) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1,ny - do i=1,nx - g(i,j,k)=-g(i,j,n3-k+2) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1+ny,ny+ny - do i=1,nx - g(i,j,k)=-g(i,n2-j+2,n3-k+2) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1,ny - do i=1+nx,nx+nx - g(i,j,k)=-g(n1-i+2,j,n3-k+2) - enddo - enddo - enddo - do k=1,nz - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,n2-j+2,k) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j,k)=-g(n1-i+2,n2-j+2,n3-k+2) - enddo - enddo - enddo - goto 200 -! adjacent bunches (periodic boundary conditions): - 50 continue - if(idproc.eq.0)write(6,*)'adjacent bunches' -! nbunch=200 - if(idproc.eq.0)write(6,*)'(greenfz)THIS PORTION OF CODE IS BROKEN' - nbunch=20 - d=hz*nz - do 100 k=-nz/2,nz/2-1 - do 99 j=-ny,ny-1 - do 98 i=-nx,nx-1 - if(i.eq.0 .and. j.eq.0 .and. k.eq.0)goto 98 - tmp=0.d0 - do n=-nbunch,nbunch - tmp=tmp+(hz*k+n*d)/ & - & (fourpi*sqrt( (hx*i)**2+(hy*j)**2+(hz*k+n*d)**2))**3 - enddo - g(1+mod(i+n1,n1),1+mod(j+n2,n2),1+mod(k+nz,nz))=tmp - 98 continue - 99 continue - 100 continue -!cryne July 7, 2004 g(1,1,1)=g(1,1,2) - g(1,1,1)=0.d0 - 200 continue - if(idproc.eq.0)write(6,*)'leaving greenfz' - return - end - diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo.f b/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo.f deleted file mode 100644 index 30a9221..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo.f +++ /dev/null @@ -1,435 +0,0 @@ -! IMPACT 3D space charge routines -! Copyright 2001 University of California -! -! Using Chombo AMR Poisson solver for Infinite Domain or Homogenous Dirichlet BCs -! -! subroutine SPCH3DAMR( c,ex,ey,ez,msk,Np,Ntot -! & ,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,phi ) - -! Arguments: -! c in:out (1:5:2,*) are x,y,z coordinates of particles -! note: in the rest of MLI column 5 is time-of-flight (i.e. phase), -! but prior to calling the space charge routines it is -! converted to longitudinal position z. -! (2:6:2,*) are momenta and not used here. -! ex,ey,ez :out electric field at particles -! Msk :in flag indicating valid particles -! Np :in number of particles (both good and bad) on this processor -! Ntot :in number of (good) particles on all processors -! Nx,Ny,Nz :in dimensions of grid on the regular sized grid -! N1,N2,N3 :in dimensions of the bigger (usually doubled) grid -! N3a :in =Nz for periodic bc longitudinally, =2*Nz for open bc longit. -! Nadj :in =0 for open or Dirichlet BCs, >=1 for longitudinally periodic BCs -! phi :out solution to Poisson equation -! -! Globals: -! Common /NEWPOISSON/ -! ISolve :in choose which Poisson solver to use -- 1 for default Infinite Domain, -! 3x for Chombo AMR Infinite Domain solver -! 4x for Chombo Hom.Dirichlet -! x0 = spectral discretization -! x1 = Mehrstellen " -! x2 = Laplacian " (7-point) -! x3 = Mehrstellen (4th order) -! Common /SHOWME/ -! IVerbose :in -! Common /GRIDSZ3D/ -! Xmin,Xmax :in location of corners of physical grid -! Ymin,Ymax :in -! Zmin,Zmax :in -! Hx,Hy,Hz :in grid spacings -! Hxi,Hyi,Hzi :in 1.0 / Hx,Hy,Hz -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine SPCH3DAMR( c,ex,ey,ez,Msk,Np,Ntot & - & ,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,phi ) - use parallel ,ONLY : NVP,IDPROC - use ml_timer - implicit none -!Constants - integer ,parameter :: InterpType = 1 - integer :: Nxyz !set below - real*8 :: FourPi, Hxyz, Neg4Pi ! " " -!Arguments - integer Np,Ntot,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj - real*8, dimension(6,Np) :: c - logical, dimension(Np) :: Msk - real*8, dimension(Np) :: ex,ey,ez - real*8, dimension(Nx,Ny,Nz) :: phi -!Locals - character filename*32 - integer i,j,k,ierror,status ,stride - integer CHPHandle ,maxlvls ,maxp ,tagsbuffer ,solvertype - integer domain(3,2) ,subdomains(3,2,1) ,bcflags(3,2) - integer refratios(10) - logical ltmp -!!! real*8, dimension(Nx,Ny,Nz) :: exg,eyg,ezg,rhosum - real*8 x0(3) ,fillratio,tolerance ,charge ,bcvals(3,2) - real*8 checknorm ,scale ,xval,yval,zval,del2 - integer iteration ,plotiters - save iteration - data iteration/0/ - character*12 stencil(0:3) !input names of stencils, indexed by ISolve - data stencil/'spectral' ,'mehrstellen' ,'laplace' ,'4mehrstellen'/ - save stencil - -!Globals - real*8 Xmin,Xmax,Ymin,Ymax,Zmin,Zmax,Hx,Hy,Hz,Hxi,Hyi,Hzi - common/GRIDSZ3D/Xmin,Xmax,Ymin,Ymax,Zmin,Zmax,Hx,Hy,Hz,Hxi,Hyi,Hzi - integer IVerbose - common/SHOWME/IVerbose - integer IDirectFieldCalc,IDensityFunction,ISolve - common/NEWPOISSON/IDirectFieldCalc,IDensityFunction,ISolve - character*256 ChomboFilename - common/chombochar/ChomboFilename -!Externals - integer LENC - logical HANDLE_ERROR - external LENC ,HANDLE_ERROR - -!====================================================================== - -!Execution - - if(idproc.eq.0 .AND. iverbose.ge.5) - & write(6,*)'info: SPCH3DAMR: solving for phi with ' - & ,TRIM( stencil( MOD( ISolve,10 ) ) ) ,' stencil' - - !! Set constants - FourPi = 4.0 * ACOS( -1.0d0 ) - Neg4Pi = -FourPi - Nxyz = Nx*Ny*Nz - Hxyz = Hx*Hy*Hz - -!----------------------------------------------------------------------- - -! check for valid conditions for this solver - - if( ISolve.LT.30 .OR. ISolve.GT.42 )then - write(6,*) 'error: SPCH3DAMR: invalid Chombo solver type. ' - & ,' Should be 30--42, not ',ISolve - stop 'SPCH3DAMR' - endif - if( ISolve - 30 .LT. 10 .AND. ( Nx.NE.Ny .OR. Ny.NE.Nz ) )then - write(6,*) 'error: SPCH3DAMR: non-cubic grids are not supported' - & ,'. Nx,Ny,Nz = ' ,Nx,Ny,Nz - stop 'SPCH3DAMR' - endif - if( Hx.NE.Hy .OR. Hy.NE.Hz )then - write(6,*) 'error: SPCH3DAMR: anisotropic grids are not ' - & ,'supported. Hx,Hy,Hz = ' ,Hx,Hy,Hz - stop 'SPCH3DAMR' - endif - if( IDirectFieldCalc .EQ. 1 )then - write(6,*) 'error: SPCH3DAMR: direct Efield calculation is not ' - & ,'supported (i.e. IDirectFieldCalc should be 0).' - stop 'SPCH3DAMR' - endif - if( Nadj .NE. 0 )then - write(6,*) 'error: SPCH3DAMR: periodic longitudinal BC is not ' - & ,'supported (i.e. Nadj should be 0).' - stop 'SPCH3DAMR' - endif - if( NVP .NE. 1 )then - write(6,*) 'error: SPCH3DAMR: parallel not implemented.' - stop 'NVP>1' - endif - if( Ntot .NE. NP )then - write(6,*) 'error: SPCH3DAMR: all particles not on process 1' - stop 'NP!=NPtot' - endif - if( COUNT( Msk ) .NE. NP )then - write(6,*) 'error: SPCH3DAMR: masked particles not supported.' - stop 'Msk!=NP' - endif - if( ChomboFilename .EQ. ' ' )then - write(6,*) 'error: SPCH3DAMR: chombo input filename is blank.' - stop 'SPCH3DAMR' - endif - -!----------------------------------------------------------------------- - - !! keep track of how many calls - iteration = iteration + 1 - - !! read the Chombo input file from - call CH_READINFILE( ChomboFilename ,maxlvls ,refratios ,maxp - & ,tagsbuffer ,fillratio ,tolerance ,solvertype - & ,bcvals ,plotiters ) - - !! instantiate a ChomboPIC object and return a handle to it - call CHP_CREATE( CHPHandle ,status ) - ltmp = HANDLE_ERROR( status, 'CHP_CREATE' ) !ignore warnings - - call CHP_SETDEBUG( CHPHandle, IVerbose ) - - ! set the computational domain (in grid points) - ! and the per-processor subdomains -!XXX for now, assume one cpu - ! domain is in nodes - domain(:,1) = 0 - domain(1,2) = Nx-1 ; domain(2,2) = Ny-1 ; domain(3,2) = Nz-1 - subdomains(:,:,1) = domain - x0(1) = Xmin ; x0(2) = Ymin ; x0(3) = Zmin - - call CHP_SETGRIDPARAMS( CHPHandle, x0,Hx,domain,subdomains,maxlvls - & ,refratios ,maxp ,tagsbuffer ,fillratio - & ,status ) - ltmp = HANDLE_ERROR( status, 'CHP_SETGRID' ) - if( ltmp ) stop 'SPCH3A02' - - if( IVerbose .GE. 5 .AND. iteration .EQ. 1 )then - write(6,*) 'SPCH3D_CHOMBO parameters:' - write(6,*) ' MaxLevels',maxlvls - write(6,*) ' RefRatios',refratios - write(6,*) ' MaxParticlesPerCell',MaxP - write(6,*) ' TagsBufferCells',tagsbuffer - write(6,*) ' FillRatio',fillratio - write(6,*) ' Tolerance',Tolerance - write(6,*) ' SolverType',solvertype - write(6,*) ' BoundaryValues' ,bcvals - write(6,*) ' PlotIters' ,plotiters - endif - - !! set solver parameters - bcflags = 0 !default dirichlet - if( ISolve .LT. 40 )then - !! infinite domain boundary condition on all faces - bcflags = 5 !5==Chombo::PICOpen -!XXX -- discretization type is hardcoded -!XXX !! the infinite domain solver has 3 flavors for the type of -!XXX !! discretization used on the level_0 FFT solver, so extract -!XXX !! this from the ISolve global paramter and pack it into solvertype -!XXX !! (default: spectral, +10 for Mehrstellan, +20 for laplace -!XXX solvertype = solvertype + 10*(ISolve-30) - if( ISolve-30 .NE. 1 )then - write(6,*) 'warning: SPCH3DAMR: ignoring FFT discretization ' - & ,'type ' ,ISolve-30 - write(6,*) 'info: using Mehrstellen discretization instead.' - endif -!XXX - endif - - call CHP_SETSOLVEPARAMS( CHPHandle ,tolerance ,bcflags,bcvals - & ,InterpType ,IVerbose,solvertype,status ) - ltmp = HANDLE_ERROR( status, 'CHP_SETSOLVE' ) - if( ltmp ) stop 'SPCH3A03' - -!----------------------------------------------------------------------- - -! pass particles to ChomboPIC - - !! divide charge by number of particles so rho will be same as MLI - !![NOTE: Chombo::PIC divides by cell volume, so dont need to do that here.] - !![NOTE: poisson3d solver assumes rho is negative.] - call increment_timer('rhoslo3d',0) - charge = -1.0d0 / Ntot - stride = 6 - call CHP_PUTPARTICLES( CHPHandle,1,charge,NP,stride - & ,c(1,1),c(3,1),c(5,1) !x,y,z - & ,status ) - ltmp = HANDLE_ERROR( status, 'CHP_PUTPARTICLES' ) - call increment_timer('rhoslo3d',1) - if( ltmp ) stop 'SPCH3A04' - -!----------------------------------------------------------------------- - -! solve the Poisson equation using the ChomboPIC solver - - call increment_timer('fft',0) - call CHP_SOLVE( CHPHandle ,status ) - ltmp = HANDLE_ERROR( status, 'CHP_SOLVE' ) - call increment_timer('fft',1) - if( ltmp ) stop 'SPCH3A05' - -!----------------------------------------------------------------------- - -! extract results from Chombo::PIC - - call increment_timer('timer1',0) - - !! get the solution on the base grid - call CHP_GETPHIGRID0( CHPHandle ,phi ,status ) - ltmp = HANDLE_ERROR( status, 'CHP_GETPHIGRID' ) - call increment_timer('timer1',1) - if( ltmp ) stop 'SPCH3A08' - - !! get the electric field at the particles - call CHP_GETEFIELD( CHPHandle, 1,NP,stride ,c(1,1),c(3,1),c(5,1) - & ,1 ,ex ,ey ,ez ,status ) !stride for exyz is 1, not 6 - ltmp = HANDLE_ERROR( status, 'CHP_GETEFIELD' ) - if( ltmp ) stop 'SPCH3A06' - - ![NOTE: this may need a factor of 'h' as well] -!! ex = ex * FourPi -!! ey = ey * FourPi -!! ez = ez * FourPi - ex = -ex - ey = -ey - ez = -ez - - call increment_timer('timer1',1) - -!----------------------------------------------------------------------- - -! write data files - - call increment_timer('timer2',0) - - if( iteration .EQ. 1 .OR. MOD( iteration,plotiters ) .EQ. 0 )then - - !! poisson solution on all grids - filename = 'phi_0000.hdf5 ' - write(filename(5:8),'(I4.4)') iteration - if( iverbose .ge. 4 ) - & write(6,*) 'SPCH3DAMR: writing phi to ',TRIM(filename) - call CHP_WRITEPHI( CHPHandle,filename,status ) - ltmp = HANDLE_ERROR( status, 'CHP_WRITEPHI' ) - ! ignore errors or warnings - - !! all data including particles on all grids - filename = 'soln_0000.hdf5 ' - write(filename(6:9),'(I4.4)') iteration - if( iverbose .ge. 4 ) - & write(6,*) 'SPCH3DAMR: writing solution to ',TRIM(filename) - call CHP_WRITESOLN( CHPHandle ,filename ,status ) - ltmp = HANDLE_ERROR( status, 'CHP_WRITESOLN' ) - ! ignore errors or warnings - - endif - - call increment_timer('timer2',1) - -!====================================================================== - -! Done - call CHP_DESTROY( CHPHandle, status ) - ltmp = HANDLE_ERROR( status, 'CHP_DESTROY' ) !ignore warnings - if(idproc.eq.0 .AND. iverbose.gt.5) write(6,*)'leaving SPCH3DAMR' - return - end - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - logical function HANDLE_ERROR( Status ,IdString ) - integer Status - character IdString*(*) - if( Status .EQ. 0 )then - HANDLE_ERROR = .FALSE. - elseif( Status .LT. 0 )then - write(6,*) 'FATALERROR(' ,Status ,') from ' - $ ,IdString(1:LEN(IdString)) - stop - else - write(6,*) 'WARNING(' ,Status ,') from ' - $ ,IdString(1:LEN(IdString)) - HANDLE_ERROR = .TRUE. - endif - return - end - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine CH_READINFILE( FileName ,maxlvls ,refratios ,maxp - & ,tagsbuffer ,fillratio ,tolerance - & ,solvertype ,bcvals ,plotiters ) - -!! Input file format: (filename: chombo.input) -!! Version -- (V2 or later) -!! MaxLevels -- number of AMR levels to use -!! RefRatios -- refinement ratios for levels > 0 (none if MaxLevels==1) -!! MaxParticlesPerCell -- threshold for making tags for MeshRefine -!! TagsBufferCells -- number of cells around tags to include in grids (V3 or later) -!! FillRatio -- portion of cells in a refined box that must be tagged (V4 or later) -!! Tolerance -- AMRNodeElliptic solver tolerance (V4 or later) -!! SolverType -- AMRNodeElliptic solver type (0=default, 1=alternate) -!! BoundaryValues -- homogenous BC values for each direction (both faces) (V2 or later) -!! PlotIters -- number of iterations between plot files (V5 or later) (def: 1) -!! Notes: -!! -!! Defaults: -!! MaxLevels: 1 -!! RefRatios: none -!! MaxParticlesPerCell: 10 -!! TagsBufferCells: 1 -!! FillRatio: .75 -!! Tolerance: 1e-12 -!! SolverType: 0 -!! BoundaryValues: 0 0 0 -!! PlotIters: 1 -!! -!!========================================================================= - implicit none -!Arguments - character FileName*(*) - integer maxlvls ,refratios(*) ,maxp ,tagsbuffer ,solvertype - integer plotiters - real*8 x0(3) ,fillratio ,tolerance ,bcvals(3,2) -!Locals - character word*32 - integer i ,version -!Globals - integer IVerbose - common/SHOWME/IVerbose -!Execute - version = 4 - maxlvls = 1 - maxp = 10 - tagsbuffer = 1 - fillratio = 0.75 - tolerance = 1.0d-12 - solvertype = 0 - bcvals = 0 - plotiters = 1 - - open(2,file=FileName,err=99) - read(2,*,err=99,end=99) word ,version - if( word .NE. 'Version' )then - write(6,*) 'error: Chombo input: expecting Version, got ' - & ,version - stop 'CHOMBOIN' - endif - if( version .LT. 4 )then - write(6,*) 'error: Chombo input: input file versions <4 ' - & ,' are not supported.' - stop 'CHOMBOIN' - endif - read(2,*) word, maxlvls - write(6,*) 'Expecting MaxLevels, got [',TRIM(word),']=',maxlvls - read(2,*) word, (refratios(i),i=1,maxlvls-1) - write(6,*) 'Expecting RefRatios, got [',TRIM(word),']=' - & ,(refratios(i),i=1,maxlvls-1) - read(2,*) word, maxp - write(6,*) 'Expecting MaxParticlesPerCell, got [',TRIM(word),']=' - & ,maxp - read(2,*) word,tagsbuffer - write(6,*) 'Expecting TagsBufferCells, got [',TRIM(word),']=' - & ,tagsbuffer - read(2,*) word,fillratio - write(6,*) 'Expecting FillRatio, got [',TRIM(word),']=',fillratio - read(2,*) word,tolerance - write(6,*) 'Expecting Tolerance, got [',TRIM(word),']=',tolerance - read(2,*) word,solvertype - write(6,*) 'Expecting SolverType, got [',TRIM(word),']=' - & ,solvertype - read(2,*) word,(bcvals(i,1),i=1,3) - do i = 1,3 - bcvals(i,2) = bcvals(i,1) - enddo - if( version .GE. 5 )then - read(2,*) word,plotiters - write(6,*) 'Expecting PlotIters, got [',TRIM(word),']=' - & ,plotiters - endif -!Done - close(2) - return - -!Errors - ! handle missing file - 99 write(6,*) 'info: Chombo: input file [' ,TRIM( FileName ) - & ,'] is missing or empty so using default input values.' - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo_dummy.f b/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo_dummy.f deleted file mode 100644 index fcf195f..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/spch3d_chombo_dummy.f +++ /dev/null @@ -1,13 +0,0 @@ - subroutine SPCH3DAMR( c,ex,ey,ez,Msk,Np,Ntot & - & ,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,phi ) - implicit none -!Arguments - integer Np,Ntot,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj - real*8, dimension(6,Np) :: c - logical, dimension(Np) :: Msk - real*8, dimension(Np) :: ex,ey,ez - real*8, dimension(Nx,Ny,Nz) :: phi - write(6,*) 'error: SPCH3DAMR: Chombo AMR is not included ' - & ,'in this version.' - stop 'NOAMR' - end diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d_dummy.f b/OpticsJan2020/MLI_light_optics/Src/spch3d_dummy.f deleted file mode 100644 index 5e0ca12..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/spch3d_dummy.f +++ /dev/null @@ -1,29 +0,0 @@ - subroutine SPCH3D2( c,ex,ey,ez,Msk,Np,Ntot & - & ,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,rhophi ) - implicit none -!Arguments - integer Np,Ntot,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj - real*8, dimension(6,Np) :: c - logical, dimension(Np) :: Msk - real*8, dimension(Np) :: ex,ey,ez - real*8, dimension(Nx,Ny,Nz) :: rhophi - write(6,*) 'error: SPCH3D2: ANAG Poisson is not included ' - & ,'in this version.' - stop 'NOANAG' - return - end - - subroutine SPCH3DBC0( c,ex,ey,ez,Msk,Np,Ntot & - & ,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj,rho ) -!Arguments - implicit none! double precision(a-h,o-z) - integer Np,Ntot,Nx,Ny,Nz,N1,N2,N3,N3a,Nadj - real*8, dimension(6,Np) :: c - logical, dimension(Np) :: Msk - real*8, dimension(Np) :: ex,ey,ez - real*8, dimension(Nx,Ny,Nz) :: rho - write(6,*) 'error: SPCH3D2: ANAG Poisson is not included ' - & ,'in this version.' - stop 'NOANAG' - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d_essl.f b/OpticsJan2020/MLI_light_optics/Src/spch3d_essl.f deleted file mode 100755 index a646543..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/spch3d_essl.f +++ /dev/null @@ -1,529 +0,0 @@ -c IMPACT 3D space charge routines -c Copyright 2001 University of California -c -c at this point np is the # of particles on a processor: - subroutine spch3d(c,ex,ey,ez,msk,np,ntot, & - & nx,ny,nz,n1,n2,n3,n3a,nadj) - use parallel - use ml_timer - implicit double precision(a-h,o-z) - real*8, dimension(6,np) :: c - logical, dimension(np) :: msk - real*8, dimension(np) :: ex,ey,ez - real*8, dimension(nx,ny,nz) :: rho,exg,eyg,ezg,rhosum -! real*8,dimension(n1,n2,n3a) :: rho2 -! complex*16,dimension(n3a,n2,n1) :: grnxtr,rho2xtr -! - real*8,dimension(n1+2,n2,n3a) :: rho2 - complex*16,dimension(n1/2+1,n2,n3a) :: grnxtr,rho2xtr -! - integer, parameter :: naux=120000 -c rho=charge density on the grid -c rho2=...on doubled grid -c rho2xtr=...xformed (by fft) and transposed -c grnxtr=green function, xformed, transposed -c weights, indices associated with area weighting: - dimension ab(np),de(np),gh(np),indx(np),jndx(np),kndx(np), - &indxp1(np),jndxp1(np),kndxp1(np) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - common/accum/at10,at21,at32,at43,at54,at65,at76,at70 - common/showme/iverbose - real*8 aux(naux) -! if(idproc.eq.0)write(6,*)'inside spchg; nadj=',nadj -c -! call system_clock(count_rate=ihertz) -! hertz=ihertz -! call system_clock(count=iticks0) -c -! compute the Green function on the grid (use rho2 for storage): - call increment_timer('greenf3d',0) - call greenf3d(rho2,nx,ny,nz,n1,n2,n3,n3a,nadj) - call increment_timer('greenf3d',1) -! call system_clock(count=iticks3) -! if(idproc.eq.0)write(6,*)'returned from greenf' -! FFT the Green function: - scale=1.0 -! write(6,*)'(greenf) calling fft3dhpf; grn=' - iunity=1 - izero=0 - scale=1.d0 - ijsign=1 -! if(idproc.eq.0)then -! write(6,*)'calling dcft w/ n1,n2*n1,n3a,n2*n3a,n1,n2,n3a=' -! write(6,*)n1,n2*n1 -! write(6,*)n3a,n2*n3a -! write(6,*)n1,n2,n3a -! endif - call drcft3(rho2,n1+2,n2*(n1+2), & - & grnxtr,n1/2+1,n2*(n1/2+1),n1,n2,n3a,ijsign,scale,aux,naux) -! call fft3dhpf(n1,n2,n3a,iunity,scale,izero,nadj,rho2,grnxtr) -! if(idproc.eq.0)write(6,*)'rtrnd frm dcft3 grnf' -! -! deposit charge on the grid: - call increment_timer('rhoslo3d',0) -! if(idproc.eq.0)write(6,*)'calling rhoslo3d' - call rhoslo3d(c,rho,msk,np,ab,de,gh,indx,jndx,kndx, - &indxp1,jndxp1,kndxp1,nx,ny,nz,nadj) -! if(idproc.eq.0)write(6,*)'returned from rhoslo3d' - call MPI_ALLREDUCE(rho,rhosum,nx*ny*nz,mreal,mpisum,lworld,ierror) -! if(idproc.eq.0)write(6,*)'returned from MPI_ALLREDUCE' - rho=rhosum - call increment_timer('rhoslo3d',1) -! glrhochk=sum(rho) -! if(idproc.eq.0)write(6,*)'global sum of rho = ',glrhochk -cryne august 1, 2002 -cryne moved normalization out of rhoslo to here: - rho=rho/ntot -c gnrhochk=sum(rho) -c if(iverbose.ge.0)then -c write(6,*)'normalized global rhosum=',gnrhochk -c endif -c--------------- - idebug=0 - hxyzi=hxi*hyi*hzi - if(idebug.eq.1)then - write(6,*)'writing charge density (note mult by hxi*hyi*hzi)' - do i=1,nx - write(65,*)xmin+(i-1)*hx,rho(i,ny/2,nz/2)*hxi*hyi*hzi - enddo - endif -c--------------- - call system_clock(count=iticks1) -! store rho in lower left quadrant of doubled grid: - do k=1,n3a - do j=1,n2 - do i=1,n1 - rho2(i,j,k)=0.d0 - enddo - enddo - enddo -cryne forall(i=1:nx,j=1:ny,k=1:nz)rho2(i,j,k)=cmplx(rho(i,j,k),0.) - do k=1,nz - do j=1,ny - do i=1,nx - rho2(i,j,k)=rho(i,j,k) - enddo - enddo - enddo -! if(idproc.eq.0)then -! write(6,*)'finished storing in lower left quadrant; start conv' -! endif -! call system_clock(count=iticks2) -!---------convolution------------ -! -! fft the charge density: - ijsign=1 -! if(idproc.eq.0)then -! write(6,*)'(rho)calling dcft w/ n1,n2*n1,n3a,n2*n3a,n1,n2,n3a=' -! write(6,*)n1,n2*n1 -! write(6,*)n3a,n2*n3a -! write(6,*)n1,n2,n3a -! endif - call drcft3(rho2,n1+2,n2*(n1+2), & - & rho2xtr,n1/2+1,n2*(n1/2+1),n1,n2,n3a,ijsign,scale,aux,naux) -! call fft3dhpf(n1,n2,n3a,1,scale,0,nadj,rho2,rho2xtr) -! call system_clock(count=iticks4) -! if(idproc.eq.0)write(6,*)'returned from dcft3 of rho' -! multiply transformed charge density and transformed Green function: -! rho2xtr=rho2xtr*grnxtr/(n1*n2*n3a) - rho2xtr=rho2xtr*grnxtr - scale=1.d0/(n1*n2*n3a) -! inverse fft: -! if(idproc.eq.0)then -! write(6,*)'calling inv. dcft w/ n1/2+1,n2*(n1/2+1),n1,n2,n3a=' -! write(6,*)n1/2+1,n2*(n1/2+1) -! write(6,*)n1,n2,n3a -! endif - ijsign=-1 - call dcrft3(rho2xtr,n1/2+1,n2*(n1/2+1), & - & rho2,n1+2,n2*(n1+2),n1,n2,n3a,ijsign,scale,aux,naux) -!!!! & rho2,n1,n2*n1,n1/2+1,n2,n3a,ijsign,scale,aux,naux) -! if(idproc.eq.0)write(6,*)'returned from inverse dcft3' -! call fft3dhpf(n3a,n2,n1,-1,scale,0,nadj,rho2xtr,rho2) -! call system_clock(count=iticks5) -!!!! rho2=rho2*hx*hy*hz -!----done with convolution------- -! store physical data back on grid of correct (not doubled) size: -cryne forall(i=1:nx,j=1:ny,k=1:nz)rho(i,j,k)=real(rho2(i,j,k)) - do k=1,nz - do j=1,ny - do i=1,nx - rho(i,j,k)=rho2(i,j,k) - enddo - enddo - enddo -c--------------- - idebug=0 - if(idebug.eq.1)then - write(6,*)'writing out potential' - do i=1,nx - write(66,*)xmin+(i-1)*hx,rho(i,ny/2,nz/2) - enddo - write(6,*)'stopping due to debug statement in spch3d' - call myexit - endif -c--------------- -! if(idproc.eq.0)write(6,*)'obtaining electric fields' -! obtain the electric fields: - exg=0.5*hxi*(cshift(rho,-1,1)-cshift(rho,1,1)) - eyg=0.5*hyi*(cshift(rho,-1,2)-cshift(rho,1,2)) - ezg=0.5*hzi*(cshift(rho,-1,3)-cshift(rho,1,3)) - call system_clock(count=iticks6) -! if(idproc.eq.0)write(6,*)'interpolating electric fields' -! interpolate electric field at particle postions: - call increment_timer('ntrslo3d',0) - call ntrslo3d(exg,eyg,ezg,ex,ey,ez,msk,ab,de,gh,indx,jndx,kndx, - &indxp1,jndxp1,kndxp1,nx,ny,nz,np) - call increment_timer('ntrslo3d',1) -! if(idproc.eq.0)write(6,*)'done interpolating electric fields' -! call system_clock(count=iticks7) -! t10=(iticks1-iticks0)/hertz -! t21=(iticks2-iticks1)/hertz -! t32=(iticks3-iticks2)/hertz -! t43=(iticks4-iticks3)/hertz -! t54=(iticks5-iticks4)/hertz -! t65=(iticks6-iticks5)/hertz -! t76=(iticks7-iticks6)/hertz -! t70=(iticks7-iticks0)/hertz -! at10=at10+t10 -! at21=at21+t21 -! at32=at32+t32 -! at43=at43+t43 -! at54=at54+t54 -! at65=at65+t65 -! at76=at76+t76 -! at70=at70+t70 -! write(3,2468)t10,t21,t32,t43,t54,t65,t76,t70 -! write(4,2468)at10,at21,at32,at43,at54,at65,at76,at70 -!2468 format(8(1pe9.3,1x)) -! call flush_(3) -! call flush_(4) - return - end - - subroutine greenf3d(g,nx,ny,nz,n1,n2,n3,n3a,nadj) - implicit double precision(a-h,o-z) - real*8 g -! dimension g(n1,n2,n3a) - dimension g(n1+2,n2,n3a) - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi -! write(6,*)'inside greenf3d' -! write(6,*)'nx,ny,nz=',nx,ny,nz -! write(6,*)'n1,n2,n3,n3a=',n1,n2,n3,n3a -! write(6,*)'nadj=',nadj - if(nadj.eq.1)goto 50 -! write(6,*)'(greenf): isolated boundary conditions' -! zero adjacent bunches (isolated boundary conditions): - do k=1,nz+1 - do j=1,ny+1 - do i=1,nx+1 - g(i,j,k) = (hx*(i-1))**2 +(hy*(j-1))**2 +(hz*(k-1))**2 - enddo - enddo - enddo - g(1,1,1)=1. - g(1:nx+1,1:ny+1,1:nz+1)=1.d0/sqrt(g(1:nx+1,1:ny+1,1:nz+1)) - g(1,1,1)=g(1,1,2) - do k=1,nz - do j=1,ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,j,k) - enddo - enddo - enddo - do k=1,nz - do j=1+ny,ny+ny - do i=1,nx - g(i,j,k)=g(i,n2-j+2,k) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1,ny - do i=1,nx - g(i,j,k)=g(i,j,n3-k+2) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1+ny,ny+ny - do i=1,nx - g(i,j,k)=g(i,n2-j+2,n3-k+2) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1,ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,j,n3-k+2) - enddo - enddo - enddo - do k=1,nz - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,n2-j+2,k) - enddo - enddo - enddo - do k=1+nz,nz+nz - do j=1+ny,ny+ny - do i=1+nx,nx+nx - g(i,j,k)=g(n1-i+2,n2-j+2,n3-k+2) - enddo - enddo - enddo - goto 200 -! adjacent bunches (periodic boundary conditions): - 50 continue - d=hz*nz - do 100 k=-nz/2,nz/2-1 - do 99 j=-ny,ny-1 - do 98 i=-nx,nx-1 - if(i.eq.0 .and. j.eq.0 .and. k.eq.0)goto 98 - g(1+mod(i+n1,n1),1+mod(j+n2,n2),1+mod(k+nz,nz))= & - & 1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+1.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+2.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+3.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+4.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+5.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+6.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+7.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k+8.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-1.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-2.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-3.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-4.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-5.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-6.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-7.*d)**2) & - &+1.0/sqrt( (hx*i)**2+(hy*j)**2+(hz*k-8.*d)**2) - 98 continue - 99 continue - 100 continue - g(1,1,1)=g(1,1,2) - 200 continue -! write(6,*)'leaving greenf3d' - return - end - - subroutine rhoslo3d(coord,rho,msk,np,ab,de,gh,indx,jndx,kndx, - &indxp1,jndxp1,kndxp1,nx,ny,nz,nadj) -cryne 08/24/2001 use hpf_library - implicit double precision(a-h,o-z) - logical msk - dimension coord(6,np),msk(np),vol(np) -!hpf$ distribute coord(*,block) -!hpf$ align (:) with coord(*,:) :: msk,vol - dimension ab(np),de(np),gh(np),indx(np),jndx(np),kndx(np), - &indxp1(np),jndxp1(np),kndxp1(np) -!hpf$ align (:) with coord(*,:) :: ab,de,gh,indx,jndx,kndx -!hpf$ align (:) with coord(*,:) :: indxp1,jndxp1,kndxp1 - dimension rho(nx,ny,nz),tmp(nx,ny,nz) -!hpf$ distribute rho(*,*,block) -!hpf$ align (*,*,:) with rho(*,*,:) :: tmp - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - common/showme/iverbose - if(idproc.eq.0) write(6,*)'inside rhoslo3d' -! write(6,*)'xmin,xmax=',xmin,xmax -! write(6,*)'nx,ny,nz=',nx,ny,nz -! write(6,*)'nadj=',nadj -! xminnn=minval(coord(1,:)) -! xmaxxx=maxval(coord(1,:)) -! write(6,*)'xminnn,xmaxxx=',xminnn,xmaxxx -cryne 6/25/2002 do i=1,np - do j=1,np - indx(j)=(coord(1,j)-xmin)*hxi + 1 - jndx(j)=(coord(3,j)-ymin)*hyi + 1 - kndx(j)=(coord(5,j)-zmin)*hzi + 1 - enddo - do j=1,np - indxp1(j)=indx(j)+1 - jndxp1(j)=jndx(j)+1 - kndxp1(j)=kndx(j)+1 - enddo -!------- - imin=minval(indx,1,msk) - imax=maxval(indx,1,msk) - jmin=minval(jndx,1,msk) - jmax=maxval(jndx,1,msk) - kmin=minval(kndx,1,msk) - kmax=maxval(kndx,1,msk) - if((imin.lt.1).or.(imax.gt.nx-1))then - write(6,*)'error in rhoslo3d: imin,imax=',imin,imax - call myexit - endif - if((jmin.lt.1).or.(jmax.gt.ny-1))then - write(6,*)'error in rhoslo3d: jmin,jmax=',jmin,jmax - call myexit - endif - if(nadj.eq.0)then - if((kmin.lt.1).or.(kmax.gt.nz-1))then - write(6,*)'error in rhoslo3d (nadj=0): kmin,kmax=',kmin,kmax - call myexit - endif - endif - if(nadj.eq.1)then - if((kmin.lt.1).or.(kmax.gt.nz))then - write(6,*)'error in rhoslo3d (nadj=1): kmin,kmax=',kmin,kmax - call myexit - endif - endif -!------- - if(nadj.eq.1)then - do n=1,np - if(kndxp1(n).eq.nz+1)kndxp1(n)=1 - enddo - endif - ab=((xmin-coord(1,:))+indx*hx)*hxi - de=((ymin-coord(3,:))+jndx*hy)*hyi - gh=((zmin-coord(5,:))+kndx*hz)*hzi - rho=0. -!1 (i,j,k): - vol=ab*de*gh - do 100 n=1,np - rho(indx(n),jndx(n),kndx(n))= & - &rho(indx(n),jndx(n),kndx(n))+vol(n) - 100 continue -!2 (i,j+1,k): - vol=ab*(1.-de)*gh - do 200 n=1,np - rho(indx(n),jndxp1(n),kndx(n))= & - &rho(indx(n),jndxp1(n),kndx(n))+vol(n) - 200 continue -!3 (i,j+1,k+1): - vol=ab*(1.-de)*(1.-gh) - do 300 n=1,np - rho(indx(n),jndxp1(n),kndxp1(n))= & - &rho(indx(n),jndxp1(n),kndxp1(n))+vol(n) - 300 continue -!4 (i,j,k+1): - vol=ab*de*(1.-gh) - do 400 n=1,np - rho(indx(n),jndx(n),kndxp1(n))= & - &rho(indx(n),jndx(n),kndxp1(n))+vol(n) - 400 continue -!5 (i+1,j,k+1): - vol=(1.-ab)*de*(1.-gh) - do 500 n=1,np - rho(indxp1(n),jndx(n),kndxp1(n))= & - &rho(indxp1(n),jndx(n),kndxp1(n))+vol(n) - 500 continue -!6 (i+1,j+1,k+1): - vol=(1.-ab)*(1.-de)*(1.-gh) - do 600 n=1,np - rho(indxp1(n),jndxp1(n),kndxp1(n))= & - &rho(indxp1(n),jndxp1(n),kndxp1(n))+vol(n) - 600 continue -!7 (i+1,j+1,k): - vol=(1.-ab)*(1.-de)*gh - do 700 n=1,np - rho(indxp1(n),jndxp1(n),kndx(n))= & - &rho(indxp1(n),jndxp1(n),kndx(n))+vol(n) - 700 continue -!8 (i+1,j,k): - vol=(1.-ab)*de*gh - do 800 n=1,np - rho(indxp1(n),jndx(n),kndx(n))= & - &rho(indxp1(n),jndx(n),kndx(n))+vol(n) - 800 continue -! -cryne august 1, 2002: -cccc ngood=count(msk) -cccc write(6,*)'ngood=',ngood -cccc rho=rho/ngood -!wrong rho=rho/ngood*hxi*hyi*hzi -! if(idproc.eq.0)write(6,*)'leaving rhoslo3d' -! rhochk=sum(rho) -! write(6,*)'[rhoslo3d]sum(rho)=',rhochk - return - end - - subroutine ntrslo3d(exg,eyg,ezg,ex,ey,ez,msk,ab,de,gh, - &indx,jndx,kndx,indxp1,jndxp1,kndxp1,nx,ny,nz,np) - use parallel - implicit double precision(a-h,o-z) - logical msk - dimension exg(nx,ny,nz),eyg(nx,ny,nz),ezg(nx,ny,nz) -!hpf$ distribute exg(*,*,block) -!hpf$ align (*,*,:) with exg(*,*,:) :: eyg,ezg - dimension ex(np),ey(np),ez(np),msk(np) - dimension ab(np),de(np),gh(np),indx(np),jndx(np),kndx(np), - &indxp1(np),jndxp1(np),kndxp1(np) -!hpf$ template t1(np) -!hpf$ distribute t1(block) -!hpf$ align (:) with t1(:) :: ex,ey,ez,msk,ab,de,gh -!hpf$ align (:) with t1(:) :: indx,jndx,kndx,indxp1,jndxp1,kndxp1 - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi -! if(idproc.eq.0)write(6,*)'inside ntrslo3d' -! if(idproc.eq.0)then -! do n=1,np -! if(indx(n).lt.1 .or. indx(n).gt.nx)write(6,*)'error: indx(n)' -! enddo -! do n=1,np -! if(jndx(n).lt.1 .or. jndx(n).gt.ny)write(6,*)'error: jndx(n)' -! enddo -! do n=1,np -! if(kndx(n).lt.1 .or. kndx(n).gt.nz)write(6,*)'error: kndx(n)' -! enddo -! do n=1,np -! if(indxp1(n).lt.1.or.indxp1(n).gt.nx)write(6,*)'err:indxp1(n)' -! enddo -! do n=1,np -! if(jndxp1(n).lt.1.or.jndxp1(n).gt.ny)write(6,*)'err:jndxp1(n)' -! enddo -! do n=1,np -! if(kndxp1(n).lt.1.or.kndxp1(n).gt.nz)write(6,*)'err:kndxp1(n)' -! enddo -! endif -cryne forall(n=1:np)ex(n)= - do 100 n=1,np - ex(n)= & - & exg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) - &+exg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) - &+exg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) - &+exg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) - &+exg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) - &+exg(indxp1(n), - &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) - &+exg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) - &+exg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) - 100 continue - -cryne forall(n=1:np)ey(n)= - do 200 n=1,np - ey(n)= & - & eyg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) - &+eyg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) - &+eyg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) - &+eyg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) - &+eyg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) - &+eyg(indxp1(n), - &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) - &+eyg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) - &+eyg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) - 200 continue - -cryne forall(n=1:np)ez(n)= - do 300 n=1,np - ez(n)= & - & ezg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) - &+ezg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) - &+ezg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) - &+ezg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) - &+ezg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) - &+ezg(indxp1(n), - &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) - &+ezg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) - &+ezg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) - 300 continue -! if(idproc.eq.0)write(6,*)'leaving ntrslo3d' - return - end -c -c block data etimes -c common/accum/at10,at21,at32,at43,at54,at65,at76,at70 -c data at10,at21,at32,at43,at54,at65,at76,at70/0.,0.,0.,0.,0.,0.,0.,& -c & 0./ -c end diff --git a/OpticsJan2020/MLI_light_optics/Src/spch3d_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/spch3d_mod.f90 deleted file mode 100755 index 03789e6..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/spch3d_mod.f90 +++ /dev/null @@ -1,43 +0,0 @@ -module spchdata - implicit none -!!! real*8, dimension(:,:,:), allocatable :: rho - complex*16, dimension(:,:,:), allocatable :: rho2 - complex*16, dimension(:,:,:), allocatable :: grnxtr,rho2xtr -!3/21/03 added three more arrays: - complex*16, dimension(:,:,:), allocatable::xgrnxtr,ygrnxtr,zgrnxtr -save - -contains - - subroutine new_spchdata(nx,ny,nz,n1,n2,n3a,isolve) - implicit none - integer :: nx,ny,nz,n1,n2,n3a,isolve - integer :: ierror -!!! allocate(rho(nx,ny,nz)) - if( isolve .ge. 10 )return !ANAG solver doesnt need these arrays - allocate(rho2(n1,n2,n3a),stat=ierror) - if( ierror .NE. 0 )then - print*,'error: new_spchdata: allocate(rho2) failed with code ',ierror - stop 'NEWSPCH' - endif - allocate(grnxtr(n3a,n2,n1),rho2xtr(n3a,n2,n1),stat=ierror) - if( ierror .NE. 0 )then - print*,'error: new_spchdata: allocate({grn,rho2}xtr) failed with code ',ierror - stop 'NEWSPCH' - endif -!3/21/03 three more arrays: - allocate(xgrnxtr(n3a,n2,n1),ygrnxtr(n3a,n2,n1),zgrnxtr(n3a,n2,n1),stat=ierror) - if( ierror .NE. 0 )then - print*,'error: new_spchdata: allocate({xyz}grnxtr) failed with code ',ierror - stop 'NEWSPCH' - endif - end subroutine new_spchdata - - subroutine del_spchdata -!!! deallocate(rho) - deallocate(rho2) - deallocate(grnxtr,rho2xtr) -!3/21/03 three more arrays: - deallocate(xgrnxtr,ygrnxtr,zgrnxtr) - end subroutine del_spchdata -end module spchdata diff --git a/OpticsJan2020/MLI_light_optics/Src/sss.f b/OpticsJan2020/MLI_light_optics/Src/sss.f deleted file mode 100755 index 3c66287..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/sss.f +++ /dev/null @@ -1,580 +0,0 @@ -*********************************************************************** -c -c THIS FILE CONTAINS THE ROUTINES THAT IMPLEMENT THE SCALING -c SPLITTING SQUARING (SSS) ALGORITHM FOR MARYLIE5.0 -c (Written 23 April 97) -c (Fixed 8 May 97) -c (Modified 4 Aug 97) -*********************************************************************** -c - subroutine sss(p,ga,gm) -c -c This routine performs the Dragt-Finn factorization of the map -c exp(-t:h:) using the Scaling Splitting, Squaring algorithm. -c The arrays ga initially contains the Hamiltonian h. -c -c Two options are possible: -c 1. ncheck = 0 ; the calculation of the map is done only once. -c The number of squarings np is fixed by the requirement that -c |norm(JS)*.5**np| < eps, with eps specified by the user. -c 2. ncheck =/= 0 ; the calculation of the map is repeated with np=np+1 -c and the difference between selected generators of the map -c calculated with np and np+1 squarings checked. -c If the relative difference is greater than 'err' the calculation is -c repeated by increasing np by one. If the relative difference increases -c with np (round off errors) the algorithm is stopped. -c -c Written by M.Venturini April 23, 97. -c Modified Aug. 4, 97 (M.V.) -c -c*************************** -c err = error allowed for the map generators -c integration length = t -c np = # of squaring -c eps = max norm of the linear part of the generators -c npse = n. of squaring set by the user regardless of err -c (if npse=0 np is set based on err) -c*************************** -c - use lieaparam, only : monoms - implicit double precision (a-h,o-z) - include 'files.inc' -c - parameter(err=1.d-13) -c - character*3 kynd - dimension p(6) - dimension fa(monoms),fm(6,6) - dimension ga(monoms),gm(6,6) - dimension fa2(monoms),fm2(6,6) - dimension fap(monoms),fmp(6,6) - dimension faw(monoms),fmw(6,6) -c - t=p(1) - nmapf=nint(p(2)) - nmapg=nint(p(3)) - eps=p(4) - ncheck=nint(p(5)) - npset=nint(p(6)) -c -c Get the array fa - if (nmapf.eq.0) call mapmap(ga,gm,fa,fm) - if (nmapg.ge.1 .and. nmapf.le.5) then - kynd='gtm' - call strget(kynd,nmapf,fa,fm) - endif -c -c Multiply fa by t - call csmul(t,fa,fa) -c - If(npset.gt.0) then - np=nint(p(6)) - ncheck=0 -cryne write(jof,*) ' ' -cryne write(jof,*) 'number of squaring np=',np - write(jodf,*) ' ' - write(jodf,*) 'number of squaring np=',np - goto 21 - endif -c -c Compute the number of squarings based on eps -c - call matify(fm,fa) - call mnorm(fm,res) - np=1 - scale=.5d0 - 10 continue - test=6*res*scale - if (test .lt. eps) goto 20 - np=np+1 - scale=scale/2.d0 - goto 10 - 20 continue -c -cryne write(jof,*) ' ' -cryne write(jof,*) 'number of squaring np=',np -cryne write(jof,*) 'norm of the linear part of the map generators',res -cryne write(jof,*) 'scale',scale -cryne write(jof,*) ' ' -c - write(jodf,*) ' ' - write(jodf,*) 'number of squaring np=',np - write(jodf,*) 'norm of the linear part of the map generators',res - write(jodf,*) 'scale',scale - write(jodf,*) ' ' -cryne 6/21/2002 -cryne put in a diagnostic until we are sure that these routines are -cryne robust when ncheck=0: - if(ncheck.eq.0 .and. np.lt.5)then - write(jof,*)'WARNING FROM SUBROUTINE SSS: # OF SPLITTINGS=',np - write(jodf,*)'WARNING FROM SUBROUTINE SSS: # OF SPLITTINGS=',np - endif -c - if (ncheck.ne.0) then - call mapmap(fa,fm,fap,fmp) - endif -c - 21 tau=1/2.d0**np - call splitT(np,tau,fa,fm) -c -c Concatenate -c - do 30 i=1,np - call concat(fa,fm,fa,fm,fa2,fm2) - call mapmap(fa2,fm2,fa,fm) - 30 continue -c -c Want to increase np? -c - if (ncheck.eq.0) goto 70 -c - reldifbef=1 - 50 continue - fbef463 = fa(463) - np=np+1 - tau=1/2.d0**np - call mapmap(fap,fmp,fa,fm) - call splitT(np,tau,fa,fm) -c - do 31 i=1,np - call concat(fa,fm,fa,fm,fa2,fm2) - call mapmap(fa2,fm2,fa,fm) - 31 continue -c -c - diff463 = fa(463) -fbef463 - reldif=diff463/fa(463) -c - write(jof,*)'np=',np,' f(463)=',fa(463) - write(jof,*)'np=',np-1,' f(463)=',fbef463 - write(jof,*)'difference =',diff463 - write(jof,*)'relative error =',reldif - write(jof,*)' ' -c - write(jodf,*)'np=',np,' f(463)=',fa(463) - write(jodf,*)'np=',np-1,' f(463)=',fbef463 - write(jodf,*)'difference =',diff463 - write(jodf,*)'relative error =',reldif - write(jodf,*)' ' - -c -c Stop the calculation if the relative error increases with np -c - if (abs(reldifbef).lt. abs(reldif)) then -c - write(jof,*) 'Increasing np (n. of squaring) does not' - write(jof,*) 'improve the accuracy.' - write(jof,*) 'Stop at np=',np-1 - write(jof,*) ' ' -c - write(jodf,*) 'Increasing np (n. of squaring) does not' - write(jodf,*) 'improve the accuracy.' - write(jodf,*) 'Stop at np=',np-1 - write(jodf,*) ' ' -c - call mapmap(faw,fmw,fa,fm) - goto 70 - endif -c - call mapmap(fa,fm,faw,fmw) - reldifbef=reldif -c - if (abs(reldif).le. err) then - goto 70 - endif -c - goto 50 -c -c Set the output -c - 70 if (nmapg.ge.1 .and. nmapg.le.5) then - kynd='stm' - call strget(kynd,nmapg,fa,fm) - endif -c - if (nmapg.eq.0) call mapmap(fa,fm,ga,gm) -c - return - end -c -*********************************************************************** -c - subroutine splitT(np,tau,ga,gm) -c -c The routine calculates the splitting term in the SSS algorithm -c using the Taylor expansion of the generators through 5th order -c in t=tau. The expansions have been evaluated using a Mathematica program. -c The splitting term has the structure: -c R(t) exp(:g3(t):) exp(:g4(t):) exp(:g5(t):) exp(:g6(t):), -c The gn(t) are given through 5th order in t. R(t) is computed -c using the routine 'exptay'. -c Written by M.Venturini April 23, 97. -c Modified Aug. 4, 97 M.V. - -c -c np = number of squarings -c - implicit double precision (a-h,o-z) - dimension h(923),hw(923),hw1(923),ga(923),gm(6,6),hm(6,6) - dimension em(6,6) -c - dimension pb23(923),pb2p23(923),pb2p33(923) - dimension pb24(923),pb2p24(923),pb2p34(923) - dimension pb25(923),pb2p25(923),pb2p35(923) -c - dimension pb234(923),pb233(923),pb2p233(923),pb3b233(923) - dimension pb34(923),pb2p2324(923),pb2p234(923),pb2324(923) -c -c Map the content of ga,gm into ha,hm - call mapmap(ga,gm,h,hm) -c -c Reset ga,gm: - call clear(ga,gm) -c -c Evaluate the linear part: -c - do 10 i=7,27 - ga(i)= -tau*h(i) - 10 continue -c - call matify(em,ga) - call exptay(em,gm) -c -c -c Evaluate some recurrent quantities -c - tau2=tau*tau - tau3=tau2*tau - tau4=tau3*tau - tau5=tau4*tau -c----------- -c pb23= :h2: h3 - call pbkt1(h,2,h,3,pb23) -c -c pb2p23=:h2:^2 h3 - call pbkt1(h,2,pb23,3,pb2p23) -c -c pb2p33 = :h2:^3 h3 - call pbkt1(h,2,pb2p23,3,pb2p33) -c -c------- -c pb24= :h2: h4 - call pbkt1(h,2,h,4,pb24) -c -c pb2p24=:h2:^2 h4 - call pbkt1(h,2,pb24,4,pb2p24) -c -c pb2p34 = :h2:^3 h4 - call pbkt1(h,2,pb2p24,4,pb2p34) -c-------- -c -c pb25= :h2: h5 - call pbkt1(h,2,h,5,pb25) -c -c pb2p25=:h2:^2 h5 - call pbkt1(h,2,pb25,5,pb2p25) -c -c pb2p35 = :h2:^3 h5 - call pbkt1(h,2,pb2p25,5,pb2p35) -c -c-------- -c pb34 = [h3,h4] - call pbkt1(h,3,h,4,pb34) -c -c pb234 = [[h2,h3],h4] - call pbkt1(pb23,3,h,4,pb234) -c -c pb233 = [[h2,h3],h3] - call pbkt1(pb23,3,h,3,pb233) - -c pb2p233 = [:h2:^2 h3 ,h3] - call pbkt1(pb2p23,3,h,3,pb2p233) -c -c pb3b233 = [h3,[:h2: h3,h3]] - call pbkt1(h,3,pb233,4,pb3b233) -c -c pb2p234 = [:h2:^2 h3,h4] - call pbkt1(pb2p23,3,h,4,pb2p234) -c -c pb2p2324 = [:h2: h3, :h2: h4] - call pbkt1(pb23,3,pb24,4,pb2324) -c -c -c -c*************************** -c Evaluate the g3 term (only the direct term is present): -c - call dirterm(tau,h,3,ga) -c -c************************** -c Evaluate the g4 term: -c direct term - call dirterm(tau,h,4,ga) -c -c feed-up term - tc=tau3/12 - call pmadd(pb233,4,tc,ga) -c - tc=tau4/24 - call pmadd(pb2p233,4,tc,ga) -c - call pbkt1(pb2p23,3,pb23,3,hw) - tc=tau5/120 - call pmadd(hw,4,tc,ga) -c - call pbkt1(pb2p33,3,h,3,hw) - tc=tau5/80 - call pmadd(hw,4,tc,ga) -c -c************************** -c Evaluate the g5 term: -c direct term - call dirterm(tau,h,5,ga) -c -c feed-up term -c1 - tc=-tau2/2 - call pmadd(pb34,5,tc,ga) -c2 - call pbkt1(h,3,pb24,4,hw) - tc=-tau3/3 - call pmadd(hw,5,tc,ga) -c3 - tc=-tau3/6 - call pmadd(pb234,5,tc,ga) -c4 - tc=tau4/24 - call pmadd(pb3b233,5,tc,ga) -c5 - call pbkt1(h,3,pb2p24,4,hw) - tc=-tau4/8 - call pmadd(hw,5,tc,ga) -c6 - tc=-tau4/8 - call pmadd(pb2324,5,tc,ga) -c7 - tc=-tau4/24 - call pmadd(pb2p234,5,tc,ga) -c8 - call pbkt1(h,3,pb2p233,4,hw) - tc=tau5/45 - call pmadd(hw,5,tc,ga) -c9 - call pbkt1(h,3,pb2p34,4,hw) - tc = -tau5/30 - call pmadd(hw,5,tc,ga) -c10 - call pbkt1(pb23,3,pb233,4,hw) - tc = tau5/60 - call pmadd(hw,5,tc,ga) -c11 - call pbkt1(pb23,3,pb2p24,4,hw) - tc = -tau5/20 - call pmadd(hw,5,tc,ga) -c12 - call pbkt1(pb2p23,3,pb24,4,hw) - tc = -tau5/30 - call pmadd(hw,5,tc,ga) -c13 - call pbkt1(pb2p33,3,h,4,hw) - tc = -tau5/120 - call pmadd(hw,5,tc,ga) -c -c -c************************** -c -c Evaluate the g6 term -c direct term - call dirterm(tau,h,6,ga) -c -c feed-up term -c1 - call pbkt1(h,3,h,5,hw) - tc = -tau2/2 - call pmadd(hw,6,tc,ga) -c2 - call pbkt1(h,3,pb34,5,hw) - tc = -tau3/6 - call pmadd(hw,6,tc,ga) -c3 - call pbkt1(h,3,pb25,5,hw) - tc = -tau3/3 - call pmadd(hw,6,tc,ga) -c4 - call pbkt1(pb23,3,h,5,hw) - tc = -tau3/6 - call pmadd(hw,6,tc,ga) -c5 - call pbkt1(pb24,4,h,4,hw) - tc = tau3/12 - call pmadd(hw,6,tc,ga) -c6 - call pbkt1(h,3,pb24,4,hw1) - call pbkt1(h,3,hw1,5,hw) - tc = -tau4/8 - call pmadd(hw,6,tc,ga) -c7 - call pbkt1(h,3,pb234,5,hw) - tc = -tau4/16 - call pmadd(hw,6,tc,ga) -c8 - call pbkt1(h,3,pb2p25,5,hw) - tc = -tau4/8 - call pmadd(hw,6,tc,ga) -c9 - call pbkt1(h,4,pb233,4,hw) - tc = tau4/48 - call pmadd(hw,6,tc,ga) -c10 - call pbkt1(pb23,3,pb34,5,hw) - tc = -tau4/16 - call pmadd(hw,6,tc,ga) -c11 - call pbkt1(pb23,3,pb25,5,hw) - tc = -tau4/8 - call pmadd(hw,6,tc,ga) -c12 - call pbkt1(pb2p23,3,h,5,hw) - tc = -tau4/24 - call pmadd(hw,6,tc,ga) -c13 - call pbkt1(pb2p24,4,h,4,hw) - tc = tau4/24 - call pmadd(hw,6,tc,ga) -c14 - call pbkt1(h,3,pb3b233,5,hw) - tc = tau5/80 - call pmadd(hw,6,tc,ga) -c15 - call pbkt1(h,3,pb2p24,4,hw1) - call pbkt1(h,3,hw1,5,hw) - tc = -tau5/20 - call pmadd(hw,6,tc,ga) -c16 - call pbkt1(h,3,pb2324,5,hw) - tc = -tau5/20 - call pmadd(hw,6,tc,ga) -c17 - call pbkt1(h,3,pb2p234,5,hw) - tc = -tau5/60 - call pmadd(hw,6,tc,ga) -c18 - call pbkt1(h,3,pb2p35,5,hw) - tc = -tau5/30 - call pmadd(hw,6,tc,ga) -c19 - call pbkt1(h,4,pb2p233,4,hw) - tc = tau5/80 - call pmadd(hw,6,tc,ga) -c20 - call pbkt1(h,3,pb24,4,hw1) - call pbkt1(pb23,3,hw1,5,hw) - tc = -tau5/20 - call pmadd(hw,6,tc,ga) -c21 - call pbkt1(pb23,3,pb234,5,hw) - tc = -tau5/40 - call pmadd(hw,6,tc,ga) -c22 - call pbkt1(pb23,3,pb2p25,5,hw) - tc = -tau5/20 - call pmadd(hw,6,tc,ga) -c23 - call pbkt1(pb24,4,pb233,4,hw) - tc = tau5/240 - call pmadd(hw,6,tc,ga) -c24 - call pbkt1(pb2p23,3,pb34,5,hw) - tc = -tau5/60 - call pmadd(hw,6,tc,ga) -c25 - call pbkt1(pb2p23,3,pb25,5,hw) - tc = -tau5/30 - call pmadd(hw,6,tc,ga) -c26 - call pbkt1(pb2p24,4,pb24,4,hw) - tc = tau5/120 - call pmadd(hw,6,tc,ga) -c27 - call pbkt1(pb2p33,3,h,5,hw) - tc = -tau5/120 - call pmadd(hw,6,tc,ga) -c28 - call pbkt1(pb2p34,4,h,4,hw) - tc = tau5/80 - call pmadd(hw,6,tc,ga) -c - return - end -c -*********************************************************************** -c - subroutine dirterm(t,h,ideg,ga) -c -c The routine calculates g =- sum_{i=1}^{nt} (t^i/i!) :h_2:^{i-1} h_{ideg} -c through t^nt; -c (direct term in the SSS algorithm). -c Written by M.Venturini April 23, 97. -c - implicit double precision (a-h,o-z) - parameter(nt=5) - dimension h(923),hw(923),ga(923),hw1(923) - dimension isup(6),iinf(6) - data iinf /0,0,28,84,210,462/ - data isup /0,0,83,209,461,923/ - save iinf,isup !cryne 7/23/2002 -c -c Initialize - do 10 i=iinf(ideg),isup(ideg) - hw(i)=h(i) - ga(i)=0.d0 - 10 continue -c - tc=t - call pmadd(hw,ideg,-tc,ga) -c - do 20 i=2,nt - call pbkt1(h,2,hw,ideg,hw1) - tc=tc*t/float(i) - call pmadd(hw1,ideg,-tc,ga) -c - do 11 j=iinf(ideg),isup(ideg) - hw(j)=hw1(j) - 11 continue -c - 20 continue -c - return - end -c -*********************************************************************** -c - subroutine expJS(ga,gm) -c -c The subroutine calculates the matrix exp. out of the -c Lie generator gm. For now the sub cex is called. In the -c future a direct algorithm should be implemented. -c Written by M.Venturini April 24, 97. -c - implicit double precision (a-h,o-z) - dimension p(6),gm(6,6),ga(923),ga2(923) -c - do i=7,923 - ga2(i)=ga(i) - enddo -c - do i=28,923 - ga2(i)=0.d0 - enddo -c - p(1)=1.d0 - p(2)=0 - p(3)=0 -c - call cex(p,ga2,gm) -c - return - end -c -*********************************************************************** - diff --git a/OpticsJan2020/MLI_light_optics/Src/timer_mod.f90 b/OpticsJan2020/MLI_light_optics/Src/timer_mod.f90 deleted file mode 100755 index 7ad54d6..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/timer_mod.f90 +++ /dev/null @@ -1,138 +0,0 @@ -module ml_timer - implicit none - integer, parameter :: ntimers=16 - integer :: ihertz - real*8 :: hertz - real*8, dimension(6*ntimers) :: time_vec -! each 5-vec contains, for a given operation: -! 1: start time for an operation during a step -! 2: elapsed time for an operation during a step -! 3: elasped time (minimum over PEs) during a step -! 4: elasped time (maximum over PEs) during a step -! 5: elasped time (average over PEs) during a step -! 6: elasped time (maximum over PEs) accumulated since start of run -! - character*16 :: opname(ntimers) - save -contains - - subroutine init_ml_timers - use parallel - implicit none - integer n - opname(1)='step' - opname(2)='raysin' - opname(3)='spch3d' - opname(4)='rhoslo3d' - opname(5)='ntrslo3d' - opname(6)='greenf3d' - opname(7)='fft' - opname(8)='transp' - opname(9)='eval' - opname(10)='moments' - opname(11)='ccfftnr' - opname(12)='profile1d' - opname(13)='timer1' - opname(14)='timer2' - opname(15)='timer3' - opname(16)='timer4' - call system_clock(count_rate=ihertz) - hertz=ihertz - time_vec(1:6*ntimers)=0.d0 - if(idproc.eq.0)then - write(71,100)(opname(n)(1:10),n=1,ntimers) - write(72,100)(opname(n)(1:10),n=1,ntimers) - write(73,100)(opname(n)(1:10),n=1,ntimers) - 100 format(12x,20(a10,1x)) - endif - end subroutine init_ml_timers -! - subroutine init_step_timer - implicit none - integer n - do n=1,ntimers - time_vec(6*n-4)=0.d0 - enddo - end subroutine init_step_timer -! - subroutine increment_timer(str,init) -! stores the times at which various operations have been completed - implicit none - character(len=*) :: str - integer :: init,iticks,n,n1,n2 -! time_vec(n1) is the oldest stored time, time_vec(n2) is the most recent - do n=1,ntimers - n1=6*n-5 - n2=6*n-4 - if(str.ne.trim(opname(n)))cycle - call system_clock(count=iticks) - if(init.eq.0)then - time_vec(n1)=iticks/hertz - else - time_vec(n2)=time_vec(n2)+(iticks/hertz-time_vec(n1)) - endif - return - enddo - write(6,*)'timer error: string ',str,' not found.' - end subroutine increment_timer -! - subroutine step_timer(str,ioscreen) -! to be called at the end of each ste. computes, for all operations: -! the min/max times/proc in a step, the average time/proc in a step, -! and the total accumulated time - use parallel - implicit none - character*16 :: str - integer ioscreen - integer :: n,ierror - real*8, dimension(2*ntimers) :: tmp,gtmp -!---------------- - do n=1,ntimers -! "t_elapsed=time_vec(2)-time_vec(1)" - tmp(2*n-1)=-time_vec(6*n-4) - tmp(2*n )=+time_vec(6*n-4) - enddo - call MPI_ALLREDUCE(tmp,gtmp,2*ntimers,mreal,mpimax,lworld,ierror) - do n=1,ntimers - time_vec(6*n-3)=-gtmp(2*n-1) - time_vec(6*n-2)=+gtmp(2*n) - enddo -!---------------- - do n=1,ntimers - tmp(n)=time_vec(6*n-4) - enddo - call MPI_ALLREDUCE(tmp,gtmp,ntimers,mreal,mpisum,lworld,ierror) - do n=1,ntimers - time_vec(6*n-1)=gtmp(n)/nvp - time_vec(6*n)=time_vec(6*n)+time_vec(6*n-2) - enddo -!---------------- - if(idproc.eq.0)then -! minimum times: - write(71,101)str(1:8),(time_vec(6*n-3),n=1,ntimers) -! maximum times: - write(72,101)str(1:8),(time_vec(6*n-2),n=1,ntimers) - if(ioscreen.eq.-1)write(6,101)str(1:8),(time_vec(6*n-2),n=1,ntimers) -! average times: - write(73,101)str(1:8),(time_vec(6*n-1),n=1,ntimers) - 101 format(a8,1x,12(1pe10.3,1x)) - endif -! - do n=1,ntimers - time_vec(6*n-4)=0.d0 - enddo - end subroutine step_timer -! -! - subroutine end_ml_timers - use parallel - implicit none - integer n - if(idproc.eq.0)then - do n=1,ntimers - write(6,100)opname(n),time_vec(6*n) - enddo - 100 format(a16,'::',1pe13.6) - endif - end subroutine end_ml_timers -end module ml_timer diff --git a/OpticsJan2020/MLI_light_optics/Src/trac.f b/OpticsJan2020/MLI_light_optics/Src/trac.f deleted file mode 100755 index 3161497..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/trac.f +++ /dev/null @@ -1,1674 +0,0 @@ -************************************************************************ -* header: TRACK * -* Particle tracking, both symplectic and non-symplectic. * -************************************************************************ -c - subroutine eval(amh,norder,ntrace,nwrite,nunit,idmin,idmax, & - & nprecision) -c -c evaluates the image zf of initial -c data zi under the lie transformation -c with linear part having matrix representation -c mh and nonlinear part having generators -c with coefficients stored in the array h -c - use multitrack !includes 'use rays' May 9, 2006 - use lieaparam, only : monoms - include 'impli.inc' -cryne May 22, 2006 need reftraj from map.inc - include 'map.inc' - include 'ind.inc' - include 'pbkh.inc' - include 'lims.inc' - include 'vblist.inc' - include 'files.inc' -c -c xmh is a local array, amh is in the argument list: - dimension xmh(6,6), amh(6,6) - dimension tempz(6),vect(923) -c -c write(6,*)'HELLO FROM TRACE' - write(6,*)'inside eval with norder=',norder - if(.not.allocated(tblock))then - write(6,*)'error:tblock not allocated' - stop - endif -c -c generate tempz=amh*zi (linear contribution) -c - ktrace=ntrace - if(ktrace.eq.0)ktrace=1 -c - do 9999 idum=1,ktrace - do 5678 nnnn=1,nraysp -c -c store 6-vector in zi. -cNote that zi(5), zi(6) get changed below if multitrac.ne.0 - zi(1:6)=zblock(1:6,nnnn) -c -c Default (multitrac=0) is to use the current transfer map mh: - if(multitrac.eq.0)xmh(1:6,1:6)=amh(1:6,1:6) -c - if(multitrac.ne.0)then - imin=inear(nnnn) - jmin=jnear(nnnn) - xmh(1:6,1:6)=tmhlist(1:6,1:6,imin,jmin) - zi(5)=tdelt(nnnn) - zi(6)=ptdelt(nnnn) - endif -c -c -c perform matrix-vector multiply: - tempz(1:6)=0.d0 - do 30 i=1,6 - do 20 k=1,6 - tempz(i)=tempz(i)+xmh(i,k)*zi(k) - 20 continue - 30 continue - tblock(1:6,nnnn)=tempz(1:6) - - if(norder.eq.1)goto 5001 -c -c loop to compute final values zf(i), including nonlinearities - vect(1:923)=0.d0 - vect(1:6) = tblock(1:6,nnnn) - do i=7,27 - vect(i) = vect(index1(i)) * vect(index2(i)) - enddo -c if(norder.ge.3)then - do i=28,83 - vect(i) = vect(index1(i)) * vect(index2(i)) - enddo -c endif -c if(norder.ge.4)then - do i=84,209 - vect(i) = vect(index1(i)) * vect(index2(i)) - enddo -c endif -c if(norder.ge.5)then - do i=210,461 - vect(i) = vect(index1(i)) * vect(index2(i)) - enddo -c endif -c if(norder.ge.6)then - do i=462,923 - vect(i) = vect(index1(i)) * vect(index2(i)) - enddo -c endif - - klast=923 - if(norder.eq.2)klast=27 - if(norder.eq.3)klast=83 - if(norder.eq.4)klast=209 - if(norder.eq.5)klast=461 - if(norder.eq.6)klast=923 -c if(multitrac.eq.0)then -c -c endif - if(multitrac.ne.0)then - pbh(:,:)=pbhlist(:,:,imin,jmin) -c call brkts(hlist(1,imin,jmin)) - endif - do i=1,6 - tmp = 0.d0 - do k=7,klast - tmp = tmp + pbh(k,i)*vect(k) - enddo - tblock(i,nnnn)=tblock(i,nnnn) + tmp - enddo - 5001 continue -c -c if using multiple maps, then shift the result back to with respect -c to the main reference trajectory: - if(multitrac.ne.0)then - tblock(5,nnnn)=tblock(5,nnnn)+ tlistfin(imin,jmin)-reftraj(5) - tblock(6,nnnn)=tblock(6,nnnn)+ptlistfin(imin,jmin)-reftraj(6) - endif - - 5678 continue - -cryne 3/25/04 : if ntrace.ge.0, copy the tblock data to zblock, -cryne then print what is in zblock. -cryne Otherwise, print what is tblock. NOTE WELL: this will -cryne ruin the tblock array, but that is OK since it is no -cryne longer needed after that data have been printed. -c -c Case with ntrace.ge.1: - if(ntrace.ge.1)then -! zblock(:,1:nraysp)=tblock(:,1:nraysp) - do j=1,nraysp - if(istat(j).eq.0)zblock(1:6,j)=tblock(1:6,j) - enddo - if(nwrite.ne.0)then - if( (mod(idum,nwrite).eq.0) .and. (jfcf.gt.0) )then - call pwritez(nunit,idmin,idmax,nprecision,0,0) - endif - endif - if(nwrite.ne.0)then - if( (mod(idum,nwrite).eq.0) .and. (jfcf.lt.0) )then - jfcf=-jfcf - call pwritezfp - jfcf=-jfcf - endif - endif - endif -c Case with ntrace.eq.0 (print rays trace results if requested, -c but do not do tracking, i.e. leave zblock unchanged): - if(ntrace.eq.0)then - if(nwrite.ne.0)then - if( (mod(idum,nwrite).eq.0) .and. (jfcf.gt.0) )then - call pwritet(nunit,idmin,idmax,nprecision) - endif - endif - if(nwrite.ne.0)then - if( (mod(idum,nwrite).eq.0) .and. (jfcf.lt.0) )then - jfcf=-jfcf - call pwritetfp - jfcf=-jfcf - endif - endif - endif - 9999 continue -c write(6,*)'LEAVING EVAL' - return - end -c -*********************************************************************** -c - subroutine evalsr_old(mh,zi,zf,df,rdf,rrjac) -cryne 8/13/02 sbroutne evalsr_old(mh,zi,zf) -c subroutine to evaluate the image zf of initial data zi under the -c lie transformation with linear part mh and nonlinear part -c represented by a standard representation stored in common/deriv/df -c this subroutine modified on 8/13/86 to change the -c order in which exp(:f2:) acts. -c canx was also modified accordingly. this -c whole subroutine needs rewriting badly AJD -c - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' -cryne 8/13/02 include 'deriv.inc' - include 'files.inc' - include 'ind.inc' - include 'len.inc' - double precision mh - dimension mh(6,6) -!!!!! dimension df(6,monoms),rdf(3,monom1+1),rrjac(3,3,monom2+1) - dimension df(6,monoms),rdf(3,monoms),rrjac(3,3,monoms) - dimension ztmp1(6),ztmp2(6),ztmp3(6) - dimension vect(monoms) -c zlm added for ordering modification 8/13/86 - dimension zlm(6) - dimension zi(6),zf(6) -c -c initialize arrays - zf(1:6)=0.d0 - ztmp1(1:6)=0.d0 - ztmp2(1:6)=0.d0 - ztmp3(1:6)=0.d0 -c also initialize zlm - zlm(1:6)=0.d0 -c the following section is added due to reordering: -c -c compute effect of linear part of the map on zi -c - do 40 i=1,6 - do 4 j=1,6 - zlm(i)=zlm(i) + mh(i,j)*zi(j) - 4 continue - 40 continue -c -c call newton search routine to find value of new momentum -c -c the following statement is commented out due to reordering -c call newt(zi,ztmp1,rdf,rrjac) -c the following statement is added due to reordering - call newt(zlm,ztmp1,rdf,rrjac) -cryne 8/15/02 call newt(zlm,ztmp1) -c -c compute vector containing values of basis monomials -c - do 2 i=1,6 - vect(i) = ztmp1(i) - 2 continue -c -c (only terms through order imaxi-1 are required) -c - do 20 i = 7,len(imaxi-1) - vect(i) = vect(index1(i))*vect(index2(i)) - 20 continue -c compute values of the new coords and old momenta using the standard -c rep of the transfer map which is stored in df -c - do 3000 i=1,5,2 - ivalue=i+1 - do 300 j=1,len(imaxi-1) -c -c new coordinate values - ztmp2(i)=ztmp2(i)+df(ivalue,j)*vect(j) -c ztmp2(i)= ddot(len(imaxi-1),vect,1,df(ivalue,1),6) -c old momentum values (done as a check) - ztmp3(ivalue)=ztmp3(ivalue)+df(i,j)*vect(j) - 300 continue -c ztmp3(ivalue)=ddot(len(imaxi-1),vect,1,df(i,1),6) -c -c transfer new momentum values to ztmp2 (these were returned from -c newt in ztmp1) -c - ztmp2(ivalue)=ztmp2(ivalue)+ztmp1(ivalue) - 3000 continue -c -c at this point, the nonlinearities are fixed. the image of -c the initial data under the nonlinear portion of the -c transformation is stored in ztmp2. before applying the linear -c part of the map to this, check to see if the old momentum values -c which were read in match those computed using the standard -c representation (done immediately above.) -c -c nonlinearities check -c - delpx=zi(2)-ztmp3(2) - delpy=zi(4)-ztmp3(4) - delpz=zi(6)-ztmp3(6) - if(ibrief.ne.2)goto 302 - write(jof,9250) - 9250 format(1h ,' **momentum deviations** ') - write(jof,9300)delpx,delpy,delpz - 9300 format(1h ,3(d22.15,2x)) - 302 continue -c the following statements are commented out due to reordering -c -c compute effect of linear part of the map on ztmp2 -c -c do 40 i=1,6 -c do 4 j=1,6 -c zf(i)=zf(i) + mh(i,j)*ztmp2(j) -c 4 continue -c 40 continue -c add the following lines due to reordering: - do 137 i=1,6 - 137 zf(i)=ztmp2(i) - return - end -c -*********************************************************************** -c - subroutine evalsr(mh,df,rdf,rrjac,norder,ntrace,nwrite,nunit, & - & idmin,idmax,nprecision) -c subroutine to evaluate the image zf of initial data zi under the -c lie transformation with linear part mh and nonlinear part -c represented by a standard representation stored in common/deriv/df -c this subroutine modified on 8/13/86 to change the -c order in which exp(:f2:) acts. -c canx was also modified accordingly. this -c whole subroutine needs rewriting badly AJD -c - use rays - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' -cryne 8/13/02 include 'deriv.inc' - include 'files.inc' - include 'ind.inc' - include 'len.inc' - double precision mh - dimension mh(6,6) -!!!!! dimension df(6,monoms),rdf(3,monom1+1),rrjac(3,3,monom2+1) - dimension df(6,monoms),rdf(3,monoms),rrjac(3,3,monoms) - dimension ztmp1(6),ztmp2(6),ztmp3(6) - dimension vect(monoms) -c zlm added for ordering modification 8/13/86 - dimension zlm(6) -!!!!! dimension zi(6),zf(6) -c - ktrace=ntrace - if(ktrace.eq.0)ktrace=1 -c - do 9999 idum=1,ktrace -c write(6,*)'idum=',idum -c - lda=6 - ldb=6 - ldc=6 - call DGEMM('N','N',6,nraysp,6,1.0d0,mh,lda, - &zblock,ldb,0.0d0,tblock,ldc) -c - if(norder.eq.1)then - goto 5001 - else - write(6,*) '(evalsr) computing nonlinear part' - endif -c - do 8500 nnn=1,nraysp - zi(1:6)=zblock(1:6,nnn) - zf(1:6)=0.d0 - ztmp1(1:6)=0.d0 - ztmp2(1:6)=0.d0 - ztmp3(1:6)=0.d0 -c -c the following section is added due to reordering: -c -c compute effect of linear part of the map on zi -c -! do 40 i=1,6 -! do 4 j=1,6 -! zlm(i)=zlm(i) + mh(i,j)*zi(j) -! 4 continue -! 40 continue - zlm(1:6)=tblock(1:6,nnn) -c -c call newton search routine to find value of new momentum -c -c the following statement is commented out due to reordering -c call newt(zi,ztmp1,rdf,rrjac) -c the following statement is added due to reordering - call newt(zlm,ztmp1,rdf,rrjac) -cryne 8/15/02 call newt(zlm,ztmp1) -c -c compute vector containing values of basis monomials -c - do 2 i=1,6 - vect(i) = ztmp1(i) - 2 continue -c -c (only terms through order imaxi-1 are required) -c - do 20 i = 7,len(imaxi-1) - vect(i) = vect(index1(i))*vect(index2(i)) - 20 continue -c compute values of the new coords and old momenta using the standard -c rep of the transfer map which is stored in df -c - do 3000 i=1,5,2 - ivalue=i+1 - do 300 j=1,len(imaxi-1) -c -c new coordinate values - ztmp2(i)=ztmp2(i)+df(ivalue,j)*vect(j) -c ztmp2(i)= ddot(len(imaxi-1),vect,1,df(ivalue,1),6) -c old momentum values (done as a check) - ztmp3(ivalue)=ztmp3(ivalue)+df(i,j)*vect(j) - 300 continue -c ztmp3(ivalue)=ddot(len(imaxi-1),vect,1,df(i,1),6) -c -c transfer new momentum values to ztmp2 (these were returned from -c newt in ztmp1) -c - ztmp2(ivalue)=ztmp2(ivalue)+ztmp1(ivalue) - 3000 continue -c -c at this point, the nonlinearities are fixed. the image of -c the initial data under the nonlinear portion of the -c transformation is stored in ztmp2. before applying the linear -c part of the map to this, check to see if the old momentum values -c which were read in match those computed using the standard -c representation (done immediately above.) -c -c nonlinearities check -c - delpx=zi(2)-ztmp3(2) - delpy=zi(4)-ztmp3(4) - delpz=zi(6)-ztmp3(6) - if(ibrief.ne.2)goto 302 - write(jof,9250) - 9250 format(1h ,' **momentum deviations** ') - write(jof,9300)delpx,delpy,delpz - 9300 format(1h ,3(d22.15,2x)) - 302 continue -c the following statements are commented out due to reordering -c -c compute effect of linear part of the map on ztmp2 -c -c do 40 i=1,6 -c do 4 j=1,6 -c zf(i)=zf(i) + mh(i,j)*ztmp2(j) -c 4 continue -c 40 continue -c add the following lines due to reordering: - do 137 i=1,6 - 137 zf(i)=ztmp2(i) -c -cryne May 22, 2006 if(ntrace.ge.1)then -cryne May 22, 2006 zblock(1:6,nnn)=zf(1:6) -cryne May 22, 2006 endif -c As in routine eval, the result should temporarily be in tblock: - tblock(1:6,nnn)=zf(1:6) -cryne May 22, 2006 - 8500 continue -c - 5001 continue -c -cryne May 22, 2006 -- Same code as from routine eval: -c -c Case with ntrace.ge.1: - if(ntrace.ge.1)then -! zblock(:,1:nraysp)=tblock(:,1:nraysp) - do j=1,nraysp - if(istat(j).eq.0)zblock(1:6,j)=tblock(1:6,j) - enddo - if(nwrite.ne.0)then - if( (mod(idum,nwrite).eq.0) .and. (jfcf.gt.0) )then - call pwritez(nunit,idmin,idmax,nprecision,0,0) - endif - endif - if(nwrite.ne.0)then - if( (mod(idum,nwrite).eq.0) .and. (jfcf.lt.0) )then - jfcf=-jfcf - call pwritezfp - jfcf=-jfcf - endif - endif - endif -c Case with ntrace.eq.0 (print rays trace results if requested, -c but do not do tracking, i.e. leave zblock unchanged): - if(ntrace.eq.0)then - if(nwrite.ne.0)then - if( (mod(idum,nwrite).eq.0) .and. (jfcf.gt.0) )then - call pwritet(nunit,idmin,idmax,nprecision) - endif - endif - if(nwrite.ne.0)then - if( (mod(idum,nwrite).eq.0) .and. (jfcf.lt.0) )then - jfcf=-jfcf - call pwritetfp - jfcf=-jfcf - endif - endif - endif - 9999 continue -c write(6,*)'LEAVING EVALSR' - return - end -c -*********************************************************************** -c -c subroutine canx -c the following line is commented out due to reordering; -c see the note below. -c subroutine canx(mh,h) -c the following line is inserted due to reordering. - subroutine canx(mh,h,norder) -c subroutine to establish standard rep of transfer map for -c use in evaluating ray traces. -c -cryne 5/22/02 implicit none - use lieaparam, only : monoms - include 'impli.inc' - include 'deriv.inc' - include 'len.inc' - include 'ind.inc' - external pbkt1,pbkt2,pmadd,product - integer i,j,k,l,m,n,nn,ior - integer ivalue,jvalue - integer index1,index2,jv,len,imaxi - integer iq,ip,jq,jp,kq,kp -cryne 5/22/02 double precision df,rjac - double precision deriv3 - double precision mh(6,6) - double precision dg(923,6) - double precision h(923),g(923),gtemp(923) - double precision dgtmp(923),crstrm(923),f(923) - double precision temp(923),dum(923),tmp1(923),tmp2(923) - double precision t1(6),t2(27),t3(83),t4(209),t5(461),t6(923) -cryne common/deriv/df(6,923) -cryne common/rjacob/rjac(3,3,923) -cryne 7/23/2002 common /len/len(16) -cryne 7/23/2002 common/ind/imaxi,jv(923),index1(923),index2(923) -c -c initialize arrays -c - do 1000 n=1,len(imaxi) - g(n)=0.d0 - gtemp(n)=0.d0 - dgtmp(n)=0.d0 - crstrm(n)=0.d0 - f(n)=0.d0 - t6(n) = 0.0d0 - temp(n)=0.d0 - tmp1(n)=0.d0 - tmp2(n)=0.d0 - dum(n)=0.d0 - do 1 m=1,6 - dg(n,m)=0.d0 - df(m,n)=0.d0 - 1 continue - do 100 l=1,3 - do 10 m=1,3 - rjac(l,m,n)=0.d0 - 10 continue - 100 continue - 1000 continue -c -c transfor nonlinear arrays by linear piece -c -c write(6,*) ' The Transfer Map is: ' -c do 7777 k=1,len(imaxi) -c if(dabs(h(k)).gt.1.d-10) write(6,*) k,h(k) -c 7777 continue -c do 200 k=3,imaxi -c do 2 l=1,len(imaxi) -c gtemp(l)=0.d0 -c 2 continue -c call xform5(h,k,mh,gtemp) -c do 20 l=1,len(imaxi) -c g(l)=g(l)+gtemp(l) -c 20 continue -c 200 continue -c -c The nonlinear part of h is not transformed, just copied to g: - do 20 l=1,len(imaxi) - g(l) = h(l) - 20 continue -c -c determine derivs of array g -c - do 303 ior = 3,imaxi-1 - do 300 i=1,6 - do 3 j=1,len(imaxi) - dgtmp(j)=0.d0 - 3 continue - call pbkt2(g,ior,i,dgtmp) - do 30 j=1,len(imaxi) - dg(j,i) = dg(j,i) + dgtmp(j) - 30 continue - 300 continue - 303 continue -c - ivalue = 0 - do 7 i= 1,5,2 - ivalue = ivalue+2 - call product(dg(1,i),2,dg(1,ivalue),2,crstrm) - if(imaxi.gt.4) then - call product(dg(1,i),2,dg(1,ivalue),3,crstrm) - call product(dg(1,i),3,dg(1,ivalue),2,crstrm) - endif - if (imaxi.gt.5) then -c The following implements the 2 derivative part of the contribution to F6. - call product(dg(1,i),3,dg(1,ivalue),3,crstrm) - call product(dg(1,i),2,dg(1,ivalue),4,crstrm) - call product(dg(1,i),4,dg(1,ivalue),2,crstrm) - endif - 7 continue -c -c sum all the contributions to F excluding terms -c with more than 2 derivs and commutators. -c - do 4 n=1,len(imaxi) - f(n)=f(n)-g(n)- crstrm(n)/2.0d0 - 4 continue -c -c -c Terms with 4 derivatives - if(imaxi.gt.4) then - do 808 nn = 1,461 - 808 t5(nn) = 0.0d0 - ip = 0 - do 800 iq = 1,5,2 - ip = ip+2 - call pbkt2(crstrm,4,iq,t3) - call product(t3,3,dg(1,ip),2,t5) - 800 continue - ip = 0 - do 900 iq = 1,5,2 - ip = ip+2 - jp = 0 - do 9000 jq = 1,5,2 - jp = jp+2 - call pbkt2(dg(1,ip),2,jp,t1) - do 999 nn=1,83 - 999 t3(nn) = 0.0d0 - call product(dg(1,iq),2,t1,1,t3) - call product(dg(1,jq),2,t3,3,t5) - 9000 continue - 900 continue -c - call pmadd(t5,5,-1.0d0/6.0d0,f) -c Commutator term - call pbkt1(g,3,g,4,temp) - call pmadd(temp,5,-1.0d0/2.0d0,f) - endif - if ( imaxi .gt. 5 ) then -c four derivative terms ( 1f4 x 2f3 ) -c ( See Dave's Notes ) -c term #1 and #2: - do 66 iq = 1,5,2 - ip = iq+1 - do 666 jq = 1,5,2 - jp = jq+1 - do 6666 nn=1,209 - 6666 t4(nn) = 0.0d0 - call pbkt2(dg(1,jq),2,ip,t1) - call product(t1,1,dg(1,jp),3,t4) - call pbkt2(dg(1,jp),3,ip,t2) - call product(t2,2,dg(1,jq),2,t4) -c add up - call product(dg(1,iq),2,t4,4,tmp1) - 666 continue - 66 continue -c term #3 - do 36 iq = 1,5,2 - ip=iq+1 - do 366 jq = 1,5,2 - jp = jq+1 - do 3666 nn = 1, 209 - 3666 t4(nn) = 0.0d0 - call pbkt2(dg(1,iq),2,jq,t1) - call product(t1,1,dg(1,jp),3,t4) - call product(dg(1,ip),2,t4,4,tmp1) - 366 continue - 36 continue -c add #1,#2,#2, with correct coefficient: -c - call pmadd(tmp1,6,-1.0d0/2.0d0,f) -c -c six derivative terms ( 4f3 ) -c -c - do 1777 iq = 1,5,2 - ip = iq+1 - do 177 jq = 1,5,2 - jp = jq+1 - call pbkt2(dg(1,ip),2,jp,t1) -c *** second term ( done with the first ). - call pbkt2(crstrm,4,iq,temp) - do 37 nn = 1, 83 - 37 t3(nn) = 0.0d0 - call product(t1,1,dg(1,jq),2,t3) - call product(t3,3,temp,3,dum) -c *** end second term ****** - do 17 kq = 1,5,2 - kp = kq+1 - do 117 nn = 1,27 - 117 t2(nn) = 0.0d0 - do 27 nn = 1,209 - 27 t4(nn) = 0.0d0 - deriv3 = t1(kq) - call pmadd(dg(1,iq),2,deriv3,t2) - call product(dg(1,jq),2,t2,2,t4) - call product(dg(1,kq),2,t4,4,t6) - 17 continue - 177 continue - 1777 continue -c *** 3rd term : - do 88 iq = 1,5,2 - ip = iq+1 - call pbkt2(t5,5,iq,t4) - call product(t4,4,dg(1,ip),2,t6) - 88 continue -c *** **** -c add second term with coeff 3. ): - call pmadd(dum,6,3.0d0,t6) -c - call pmadd(t6,6,-1.0d0/24.0d0,f) -c End Six derivative terms -c -c Commutator term: - call pbkt1(g,3,g,5,temp) - call pmadd(temp,6,-1.d0/2.0d0,f) - endif -C End six and 4 deriv terms ************** -c -c add in 2nd order piece -c - f(8)=f(8)+1.d0 - f(19)=f(19)+1.d0 - f(26)=f(26)+1.d0 -c -c print out F (debug mode only) -c write(6,*) ' The generating function F is : ' -c do 77 i=1,923 -c if (dabs(f(i)).gt.1.d-10 ) write(6,*) i,f(i) -c 77 continue -c -c======================================================= -c this is a quick hack to compare these results w/ 3.0: -c write(6,*)'(canx) hack' -c f(210:monoms)=0.d0 -c 8/15/02 verified that, for example 2_7, the symplectic -c tracking results are the same for ML3.0 and ML5.0 with -c the above statement enabled. RDR -c -cryne 12/31/2004: - if(norder.eq.4)f(462:monoms)=0.d0 - if(norder.eq.3)f(210:monoms)=0.d0 - if(norder.eq.2)f(84:monoms) =0.d0 -c======================================================= -c -c now compute the derivs of the generating fxn f (which define -c the standard representation of the canonical transformation) -c - do 5000 i=1,5,2 - do 500 k=2,imaxi - do 5 l=1,len(imaxi) - tmp1(l)=0.d0 - tmp2(l)=0.d0 - 5 continue - ivalue=i+1 - call pbkt2(f,k,ivalue,tmp1) - call pbkt2(f,k,i,tmp2) - do 50 l=1,len(imaxi) - df(i,l)=df(i,l)+tmp1(l) - df(ivalue,l)=df(ivalue,l)-tmp2(l) - 50 continue - 500 continue - 5000 continue -c print out the derivatives of F (debug only) -c write(6,*) ' The derivatives of F are :' -c do 771 i=1,6 -c write(6,772) i -c 772 format(' Derivatives with repect to z',i1, ' are:') -c do 773 l=1,923 -c if(dabs(df(i,l)).gt.1.d-10 ) write(6,*) l,df(i,l) -c 773 continue -c 771 continue -c -c now compute the jacobian of the momentum part of the -c standard rep (which will be used in sub. newton to determine -c the new momentum) -c - ivalue=0 - do 6000 i=1,5,2 - do 6 n=1,len(imaxi) - dum(n)=df(i,n) - 6 continue - ivalue=ivalue+1 - jvalue=0 - do 600 j=1,5,2 - jvalue=jvalue+1 - do 60 k=2,imaxi-1 - do 58 l=1,len(imaxi) - temp(l)=0.d0 - 58 continue - call pbkt2(dum,k,j,temp) - do 59 l=1,len(imaxi) - rjac(ivalue,jvalue,l)=rjac(ivalue,jvalue,l)+temp(l) - 59 continue - 60 continue - 600 continue - 6000 continue - return - end -c -*********************************************************************** -c - subroutine invrs(a,b,d) -c subroutine to compute the inverse b and determinant d -c of a 3x3 matrix a. used by newton search subroutine -c when searching for the new momentum. -c Written by D. Douglas, ca 1983 - include 'impli.inc' - include 'files.inc' - dimension a(3,3),b(3,3),c(3,3) - do 10 i=1,3 - do 1 j=1,3 - b(i,j)=0.d0 - c(i,j)=0.d0 - 1 continue - 10 continue -c -c compute determinant of a -c - d=a(1,1)*a(2,2)*a(3,3)+a(1,2)*a(2,3)*a(3,1)+a(1,3)*a(2,1)*a(3,2) - & -a(1,3)*a(2,2)*a(3,1)-a(1,1)*a(2,3)*a(3,2)-a(1,2)*a(2,1)*a(3,3) -c write(jof,9100)d -c9100 format(1h ,'determinant of a is ',d21.15) - abd=dabs(d) - if(abd.lt.1.d-30)write(6,9000) - 9000 format(1h ,'determinant underflow in subroutine invrs') - if(abd.lt.1.d-30)return -c -c compute b=inverse of a -c - b(1,1)=(a(2,2)*a(3,3)-a(3,2)*a(2,3))/d - b(2,2)=(a(1,1)*a(3,3)-a(1,3)*a(3,1))/d - b(3,3)=(a(1,1)*a(2,2)-a(1,2)*a(2,1))/d - b(1,2)=(a(1,3)*a(3,2)-a(1,2)*a(3,3))/d - b(1,3)=(a(1,2)*a(2,3)-a(2,2)*a(1,3))/d - b(2,1)=(a(2,3)*a(3,1)-a(2,1)*a(3,3))/d - b(2,3)=(a(2,1)*a(1,3)-a(1,1)*a(2,3))/d - b(3,1)=(a(2,1)*a(3,2)-a(2,2)*a(3,1))/d - b(3,2)=(a(1,2)*a(3,1)-a(1,1)*a(3,2))/d -c -c check if this is a reasonable inverse -c -c do 200 i=1,3 -c do 20 j=1,3 -c do 2 k=1,3 -c c(i,j)=c(i,j) + a(i,k)*b(k,j) -c 2 continue -c 20 continue -c 200 continue -c write(6,9150) -c9150 format(1h ,'a * ainverse = '/) -c do 3 i=1,3 -c write(6,9200)(c(i,j),j=1,3) -c9200 format(1h ,3(d21.15,2x)) -c 3 continue - return - end -c -*********************************************************************** -c - subroutine newt(zi,zo,rdf,rrjac) -cryne 8/15/02 subroutine newt(zi,zo) -c subroutine to invert map p(old)=df(q(old),p(new))/dq(old) -c for p(new) using a newton's search procedure -c -c Written by D. Douglas, ca 1983 and substantially modified -c by F. Neri -c - use lieaparam, only : monoms - include 'impli.inc' -cryne 8/15/02 include 'deriv.inc' -cryne 8/15/02 dimension rdf(3,monom1+1),rrjac(3,3,monom2+1) - dimension rdf(3,monoms),rrjac(3,3,monoms) - dimension ztmp(6),zi(6),zo(6) - dimension rlin(3,3),rmat(3,3),ri(3,3),rinv(3,3) - dimension pi(3),crtrm(3),pimag(3),p(3),delp(3),cp(3) - dimension pjac(3,3,84),pdf(3,84) - dimension qvec(84),pvec(84) - include 'files.inc' - include 'ind.inc' - include 'len.inc' - include 'len3.inc' - include 'ind3.inc' - include 'talk.inc' - data ri/1.,3*0.,1.,3*0.,1./ -cryne 5/22/02 - save ri -c -c initialize arrays -c - l31=len3(imaxi-1) - l32=len3(imaxi-2) - ivalue=0 - do 1 i=1,3 - ivalue=ivalue+2 - pi(i)=zi(ivalue) - 1 continue - do 2 i=1,6 - ztmp(i)=zi(i) - 2 continue -c -c generate monomials in the q's -c - qvec(1) = 1.0d0 - ivalue=-1 - do 10 i=1,3 - ivalue=ivalue+2 - qvec(i+1)=ztmp(ivalue) - 10 continue - do 11 i=5,len3(imaxi-1)+1 - qvec(i)=qvec(ind31(i))*qvec(ind32(i)) - 11 continue -c -c generate coefficient of polynomials in the momentum -c variables -c - do 1001 i1=1,3 - do 1001 i2=1,3 - pjac(i1,i2,1)=0.d0 - 1001 continue -c - do 1002 n=1,4 - do 1003 i=1,3 - pdf(i,n) = 0.d0 - 1003 continue - 1002 continue -c -c generate coefficients of reduced df (pdf),function only of p: -c*********************** - do 190 i = 1,3 - do 190 ip = 5,len3(imaxi-1)+1 - pdf(i,ip) = rdf(i,ip) - 190 continue -c***** previous loops replaced by: ************* -c call dcopy(3*(len3(imaxi-1)-3),rdf(1,5),1,pdf(1,5),1) -c********************** - n0 = len3(imaxi-1)+1 - iq2=1 - do 9 ipoq=1,imaxi-2 - iq1=iq2+1 - iq2=len3(ipoq)+1 - if(imaxi.eq.ipoq+1) l = 1 - if(imaxi.gt.ipoq+1) l = len3(imaxi-1-ipoq)+1 - do 99 iq=iq1,iq2 - qval = qvec(iq) -c******************** - do 191 i = 1,3 - do 191 ip = 1,l - pdf(i,ip) = pdf(i,ip) + rdf(i,n0+ip)*qval - 191 continue -c**** previous loops replaced by: ********** -c call daxpy(3*l,qval,rdf(1,n0+1),1,pdf(1,1),1) -c******************** - n0 = n0 + l - 99 continue - 9 continue -c******************** - do 999 i = 1,3 - do 999 ip = 1,l31-l32 - pdf(i,1) = pdf(i,1) + rdf(i,n0+ip)*qvec(l32+1+ip) - 999 continue -c**** previous loops replaced by: ********** -c pdf(1,1)=pdf(1,1)+ddot(l31-l32,qvec(l32+2),1,rdf(1,n0+1),3) -c pdf(2,1)=pdf(2,1)+ddot(l31-l32,qvec(l32+2),1,rdf(2,n0+1),3) -c pdf(3,1)=pdf(3,1)+ddot(l31-l32,qvec(l32+2),1,rdf(3,n0+1),3) -c******************** -c -c genarate coefficients of reduce jacobian (rrjac): -c******************** - do 1190 i1 = 1,3 - do 1190 i2 = 1,3 - do 1190 ip = 2,len3(imaxi-2)+1 - pjac(i1,i2,ip) = rrjac(i1,i2,ip) - 1190 continue -c**** previous loops replaced by: ********** -c call dcopy(9*len3(imaxi-2),rrjac(1,1,2),1,pjac(1,1,2),1) -c******************** - n0 = len3(imaxi-2)+1 - iq2=1 - do 19 ipoq = 1,imaxi-2 - iq1 = iq2 + 1 - iq2 = len3(ipoq)+1 - if(imaxi.eq.ipoq+2) l = 1 - if(imaxi.gt.ipoq+2) l = len3(imaxi-2-ipoq)+1 - do 199 iq = iq1,iq2 - qval = qvec(iq) -c********************* - do 1999 i1 = 1,3 - do 1999 i2 = 1,3 - do 1999 ip = 1,l - pjac(i1,i2,ip) = pjac(i1,i2,ip) + rrjac(i1,i2,n0+ip)*qval - 1999 continue -c**** previous loops replaced by: ********** -c call daxpy(9*l,qval,rrjac(1,1,n0+1),1,pjac(1,1,1),1) -c******************** - n0 = n0 + l - 199 continue - 19 continue -c -c -c loop to apply contraction mapping -c - do 9999 index=1,12 -c - do 30 i=1,3 - crtrm(i)=0.d0 - pimag(i)=0.d0 - p(i)=0.d0 - delp(i)=0.d0 - cp(i)=0.d0 - do 3 j=1,3 - rlin(i,j)=0.d0 - 3 continue - 30 continue -c compute monomials in the momenta -c - pvec(1) = 1.d0 -c first order monomials are equal to the p's; - ivalue=0 - do 4 i=1,3 - ivalue=ivalue+2 - pvec(i+1)=ztmp(ivalue) - 4 continue -c -c compute the remaining monomials as products of -c previous ones: -c need only term up to order imaxi-1 - do 40 i=5,len3(imaxi-1)+1 - pvec(i)=pvec(ind31(i))*pvec(ind32(i)) - 40 continue -c -c compute jacobian -c - do 500 i=1,3 - do 50 j=1,3 -c only terms of order up to imaxi-2 are present in the jacobian, -c the jacobian is produced by taking the second derivatives of a -c imaxi order polynomial. -c******************** - do 5 n =1,len3(imaxi-2)+1 - rlin(i,j) = rlin(i,j) + pjac(i,j,n)*pvec(n) - 5 continue -c**** previous loop replaced by: ********** -c rlin(i,j)=ddot(l32+1,pvec,1,pjac(i,j,1),9) -c******************** -c -c - rmat(i,j)=ri(i,j)-rlin(i,j) - 50 continue - 500 continue - call invrs(rmat,rinv,det) - adet=dabs(det) - if(adet.lt.1.d-30)write(6,501) - 501 format(1h ,'determinant underflow in newt') - if(adet.lt.1.d-30)return - ivalue=0 - do 6 i=1,3 - ivalue=ivalue+2 - p(i)=ztmp(ivalue) - 6 continue - do 600 i=1,3 - pimag(i)=pimag(i)+pi(i) -c only term of order 2 to imaxi-1 are present -c so the sum only goes up to len(imaxi-1) . not -c******************** - do 60 n=1,l31+1 - pimag(i) = pimag(i) - pdf(i,n)*pvec(n) - 60 continue -c**** previous loop repplaced by: ********** -c pimag(i)=pimag(i)-ddot(l31+1,pvec,1,pdf(i,1),3) -c******************** -c -c - delp(i)=p(i)-pimag(i) - 600 continue - do 70 i=1,3 - do 7 j=1,3 - crtrm(i)=crtrm(i)+rinv(i,j)*delp(j) - 7 continue - 70 continue -c square=crtrm(1)**2 + crtrm(2)**2 + crtrm(3)**2 -c root=dsqrt(square) - root=abs(crtrm(1)) + abs(crtrm(2)) + abs(crtrm(3)) - if(ibrief.ne.2)goto 705 - write(jof,71)index,(crtrm(i),i=1,3) - 71 format(1h ,'corrections at iteration ',i2/ - & 1h ,'crtrm(1) = ',d21.15/1h ,'crtrm(2) = ',d21.15/ - & 1h ,'crtrm(3) = ',d21.15) -c if (1.+root.eq.1.) write(jof,72)index - if (root .le. 1.d-12) write(jof,72)index - 72 format(1h ,'iteration has converged; i= ',i1) - 705 continue - do 8 i=1,3 - cp(i)=p(i)-crtrm(i) - 8 continue - ivalue=0 - do 80 i=1,3 - ivalue=ivalue+2 - ztmp(ivalue)=cp(i) - 80 continue - do 800 i=1,6 - zo(i)=ztmp(i) - 800 continue -c if(1.+root.eq.1.) goto 1234 - if(root .le. 1.d-12) goto 1234 - 9999 continue - write(6,906) root - 906 format(' Search did not converge; root= ',e12.5) -c if (root.gt..1) jwarn=1 - jwarn=1 - 1234 continue - return - end -c -*********************************************************************** -c - subroutine prod(dg,crstrm) -c subroutine to compute crossterm in generating fxn of standard -c rep of transfer map -c Written by D. Douglas, ca 1982, and modified by Liam Healy -c - use lieaparam, only : monoms - include 'impli.inc' - dimension dg(6,*),crstrm(*),l(6) - include 'expon.inc' - include 'lims.inc' -c - do 1 m=1,top(4) - crstrm(m)=0.d0 - 1 continue - do 2000 i=1,5,2 - ivalue=i+1 - do 200 j=bottom(2),top(2) - if(dg(i,j).eq.0.d0)goto 200 - do 20 k=bottom(2),top(2) - if(dg(ivalue,k).eq.0.d0)goto 20 - do 2 m=1,6 - l(m)=expon(m,j)+expon(m,k) - 2 continue - n=ndex(l) - crstrm(n)=crstrm(n) - dg(i,j)*dg(ivalue,k)/2.d0 - 20 continue - 200 continue - 2000 continue - return - end -c -*********************************************************************** - subroutine rearr -c Written by F. Neri, ca 1984 - use lieaparam, only : monoms - include 'impli.inc' - dimension j(6) - include 'ja3.inc' - include 'ind.inc' - include 'deriv.inc' - include 'len.inc' - include 'len3.inc' - include 'ind3.inc' -c - do 22 i=1,6 - j(i)=0 - 22 continue - do 1 ip = 2,len3(imaxi-1)+1 - ivalue = 0 - do 11 i = 1,3 - ivalue = ivalue + 2 - j(ivalue) = ja3(i,ip) - 11 continue - n = ndex(j) - if(ip.gt.(len3(imaxi-2)+1)) goto 112 - do 111 i1 = 1,3 - do 111 i2 = 1,3 - rrjac(i1,i2,ip) = rjac(i1,i2,n) - 111 continue - 112 continue - ivalue = -1 - do 10 i = 1,3 - ivalue = ivalue + 2 - rdf(i,ip) = df(ivalue,n) - 10 continue - 1 continue - n1 = len3(imaxi-1)+1 - n2 = len3(imaxi-2)+1 - iq2 = 1 - do 3 ipoq = 1,imaxi-1 - iq1 = iq2+1 - iq2 = len3(ipoq)+1 - if(imaxi-2.gt.ipoq) then - l2 = len3(imaxi-2-ipoq)+1 - l1 = len3(imaxi-1-ipoq)+1 - else if(imaxi-2.eq.ipoq) then - l2 = 1 - l1 = len3(imaxi-1-ipoq)+1 - else - l1 = 1 - end if - do 33 iq = iq1,iq2 - if(imaxi-2.ge.ipoq) then - do 333 ip = 1,l2 - ivalue = -1 - do 3333 i=1,3 - ivalue = ivalue + 2 - j(ivalue) = ja3(i,iq) - j(ivalue+1) = ja3(i,ip) - 3333 continue - n = ndex(j) - do 4 i1=1,3 - do 4 i2 = 1,3 - rrjac(i1,i2,n2+ip) = rjac(i1,i2,n) - 4 continue - 333 continue - n2 = n2 + l2 - endif - do 334 ip = 1,l1 - ivalue = -1 - do 3334 i = 1,3 - ivalue = ivalue + 2 - j(ivalue) = ja3(i,iq) - j(ivalue+1) = ja3(i,ip) - 3334 continue - n = ndex(j) - ivalue = -1 - do 44 i = 1,3 - ivalue = ivalue+2 - rdf(i,n1+ip) = df(ivalue,n) - 44 continue - 334 continue - n1 = n1 + l1 - 33 continue - 3 continue - return - end -c -*********************************************************************** -c - subroutine trace(icfile,nunit,ntaysym,norder,ntrace,nwrite, & - & jdmin,jdmax,nprecision,nraysinp,th,tmh) -c Written by D. Douglas, ca 1982, and modified since by -c nearly everyone at Maryland. Could still stand improvement. -c - use rays - use beamdata - use lieaparam, only : monoms - use multitrack - use ml_timer - include 'impli.inc' - include 'deriv.inc' - include 'files.inc' - include 'talk.inc' - dimension th(monoms),tmh(6,6) - character*16 ubuf -cryne 12/30/2004 moved idmin/idmax statements below past raysin -cryne because calling raysin can potentially change maxray -! data iifile/50/ -! save iifile -c -! write(6,*)'(trace) hello from PE ',idproc -! if(idproc.eq.0)then -! write(6,*)'in routine trace; icfile,nunit,norder,ntrace,nwrite=' -! write(6,*)icfile,nunit,norder,ntrace,nwrite -! endif -c -c read initial conditions, if requested: - if(icfile.gt.0)then - scaleleni=0.d0 - scalefrqi=0.d0 - scalemomi=0.d0 - call increment_timer('raysin',0) - call raysin(icfile,nraysinp,scaleleni,scalefrqi,scalemomi, & - & ubuf,jerror) - call increment_timer('raysin',1) - call rbcast(scaleleni) - call rbcast(scalefrqi) - call rbcast(scalemomi) -c if all the scaling constants are zero, then they are not in the prologue, -c so the sectio of code below on units conversion should be skipped: - if(scaleleni.eq.0.d0.and.scalefrqi.eq.0.d0.and.scalemomi.eq.0.d0& - & )goto 555 -c -c if one of the scaling constants are zero, but not all of them, -c then there is some sort of problem, so exit: - scaleprod=scaleleni*scalefrqi*scalemomi - if(scaleprod.eq.0)then - if(idproc.eq.0)then - write(6,*)'problem reading scaling constants in input file' - write(6,*)'is one of them zero???' - endif - call myexit - endif -c here is where the units conversion takes place: - iconvert=1 - if(iconvert.eq.1)then - slratio=scaleleni/sl - smomratio=scalemomi/p0sc - timratio=freqscl/scalefrqi - wldratio=(scalefrqi*scaleleni*scalemomi)/(freqscl*sl*p0sc) - if(idproc.eq.0)then - write(6,*)'raysin complete; scaling input data' -c write(6,*)'scaleleni,sl=',scaleleni,sl -c write(6,*)'scalemomi,p0sc=',scalemomi,p0sc -c write(6,*)'scalefrqi,freqscl=',scalefrqi,freqscl -c write(6,*)'twopi*freqscl,omegascl=',4.d0*asin(1.d0)*freqscl, & -c & omegascl -c write(6,*)'wld_i,wld=',(scalefrqi*scaleleni*scalemomi), & -c & (freqscl*sl*p0sc) -c write(6,*)' ' -c write(6,*)' ' - write(6,*)'scale length ratio=',slratio - write(6,*)'scale momentum ratio=',smomratio - write(6,*)'scale time ratio=',timratio - write(6,*)'scale energy ratio=',wldratio - endif - do n=1,nraysp - zblock(1,n)=zblock(1,n)*slratio - zblock(2,n)=zblock(2,n)*smomratio - zblock(3,n)=zblock(3,n)*slratio - zblock(4,n)=zblock(4,n)*smomratio - zblock(5,n)=zblock(5,n)*timratio - zblock(6,n)=zblock(6,n)*wldratio - enddo - endif - 555 continue - endif -c -!---new code to print particles in range jdmin to jdmax: - idmin=jdmin - idmax=jdmax - if(idmin.eq.0)idmin=1 - if(idmax.eq.0)idmax=maxray -!--- -c -c examine various cases for norder -c norder=-1 - if(norder.eq.-1.and.icfile.gt.0) return - if(norder.eq.-1.and.icfile.eq.0) then - write(6,*) 'icfile and norder have inconsistent values' - write(12,*) 'icfile and norder have inconsistent values' - call myexit - endif -c -c norder=0 -c write final conditions in full precision -! if(norder.eq.0.and.jfcf.lt.0)then - if(norder.eq.0.and.nunit.lt.0)then - write(6,*)'FULL PRECISION WRITE ON FILE ',jfcf - call pwritezfp - endif -cryne if(norder.eq.0.and.jfcf.lt.0)then -cryne do 120 i=1,nraysp -cryne do 110 j=1,6 -cryne write(-jfcf,2468)zblock(j,i) - 2468 format(1x,d32.25,1x,d32.25) -cryne 110 continue -cryne 120 continue -cryne write(jof,130) -jfcf -cryne 130 format(1x,'final conditions written in full precision on', -cryne # ' file ',i4) -cryne endif -c -c write final conditions in standard format -! if(norder.eq.0.and.jfcf.gt.0)call pwritez(nunit,idmin,idmax, & - if(norder.eq.0.and.nunit.gt.0)call pwritez(nunit,idmin,idmax, & - & nprecision,0,0) -cryne if(norder.eq.0.and.jfcf.gt.0)then -cryne do 135,i=1,nraysp -cryne write(jfcf,136)(zblock(j,i),j=1,6) -cryne 136 format(6(1x,1pe12.5)) -cryne 135 continue -cryne endif - if(norder.eq.0)return -c -c cases where norder > 0 -c -c call preliminary routines depending on type of ray trace: -cryne May 10, 2006 added "if" test on norder =============== - if(norder.gt.1)then - if(ntaysym.eq.1)then - if(multitrac.eq.0)then - call brkts(th) - else - call multibrkts - endif - else -cryne 12/31/2004 added norder to canx argument list. -cryne This is a temporary fix to allow symplectic tracking of order < 5. -cryne It would be better if do loops did not extend to 923 in evalsr. - if(multitrac.eq.0)then - call canx(tmh,th,norder) - call rearr - else - call multicanx - endif - endif - endif -c -c setup before entering main loop: - ktrace=ntrace - if(ktrace.eq.0)ktrace=1 -c -c the 2 statements below seem to cause a problem and have been commented out: -c kwrite=nwrite -c if(kwrite.eq.0)kwrite=1 -c -cryne May 22, 2006 it is very bad and confusing that the names th and tmh -cryne used in the argument list to this routine, since they might/might not be -cryne the total transfer map coefficients stored in common under these names!!! - call increment_timer('eval',0) - if(ntaysym.eq.1)then - call eval(tmh,norder,ntrace,nwrite,nunit,idmin,idmax,nprecision) - call increment_timer('eval',1) - return - else - jwarn=0 - call evalsr(tmh,df,rdf,rrjac,norder,ntrace,nwrite,nunit, & - & idmin,idmax,nprecision) - call increment_timer('eval',1) - return - endif -cryne 8/3/2002 original code still in place for symplectic ray trace: -c main loop; do 'ktrace' ray traces (of the 'nraysp' initial rays) - if(idproc.eq.0)write(6,*)'ERROR: CODE SHOULD NOT GET HERE!!!' - do 300 idum=1,ktrace - do 200 k=1,nraysp -ccc if (nlost.ge.nrays) then -ccc write (jof,*) 'all particles lost' -ccc return -ccc endif -c check to see if particle has already been lost - if (istat(k).ne.0) goto 200 -c - do 150 l=1,6 - 150 zi(l)=zblock(l,k) -c -cryne 8/3/2002 if(norder.le.4)then -cryne 8/3/2002 call eval(tmh,norder,zi,zf) -cryne 8/3/2002 endif - if(norder.gt.4)then -c perform a symplectic ray trace - jwarn=0 - call evalsr_old(tmh,zi,zf,df,rdf,rrjac) -cryne 8/13/02 call evalsr(tmh,zi,zf) -c if(jfcf.lt.0)write(6,*)'back from evalsr, jfcf=',jfcf -c write(6,*)'returned from evalsr for ray #',k -c check to see if particle was 'lost' by the symplectic ray tracer -c and mark so 'lost' particles by a a distinctive negative number - if (jwarn.ne.0) then -c write(6,*)'setting istat,nlost' - istat(k)=-idum - nlost=nlost+1 - ihist(1,nlost)=-idum - ihist(2,nlost)=k -c write(6,*)'done setting istat,nlost' - endif - endif -c the line below has been replaced by the following two lines -c if(mod(idum,kwrite).ne.0)goto 176 - if(nwrite.eq.0)goto 176 - if(mod(idum,nwrite).ne.0)goto 176 -c if(jfcf.lt.0)write(6,*)'did not goto 176;jfcf=',jfcf -c end of modifications -c write out final conditions -c full precision case - if(jfcf.lt.0) then - write(6,*)'writing in full prec, idum=',idum -cryne June 4 2002 do 152 l=1,6 -cryne June 4 2002 write(-jfcf,*) zf(l) -cryne June 4 2002 152 continue - do 152 l=1,6,2 - write(-jfcf,2468)zf(l),zf(l+1) - 152 continue - write(6,*)'donewriting in full prec, idum=',idum - endif -c standard format case - if(jfcf.gt.0)then - tblock(:,k)=zf(:) - endif - if(ibrief.eq.0)goto 176 -c print lengthy info: - write(jof,155) - 155 format(/1h ,'initial conditions are: (dimensionless form)') - write(jof,*)zi(1),zi(2) - write(jof,*)zi(3),zi(4) - write(jof,*)zi(5),zi(6) - write(jof,160) - 160 format(/1h ,'final conditions are: (dimensionless form)') - write(jof,*)zf(1),zf(2) - write(jof,*)zf(3),zf(4) - write(jof,*)zf(5),zf(6) -c (end of lengthy info) -c - 176 continue - if(ntrace.eq.0)goto 200 - zblock(:,k)=zf(:) -c - 200 continue - if(nwrite.ne.0)then - if(mod(idum,nwrite).eq.0 .and. jfcf.gt.0)then - call pwritet(nunit,idmin,idmax,nprecision) - endif - endif - 300 continue - call increment_timer('eval',1) - return - end -c--------------------------------------- - subroutine pwritez(nunit,idmin,idmax,nprecision,nphysunits, & - & iprintarc) -c routine to perform parallel write of zblock array - use rays - use beamdata - use lieaparam, only : monoms !cryne 9/23/07 - include 'impli.inc' - include 'map.inc' !cryne 9/23/07 need to know arclen - integer l,nraysw - include 'files.inc' - character*16 :: myformat='(7(1x,1pe12.5 ))' - character*2 :: a2 - if(idproc.eq.0)then -!---format: - nlength=nprecision+7 - call num2string(nlength,a2,2) - myformat(10:11)=a2 - call num2string(nprecision,a2,2) - myformat(13:14)=a2 -!--- - mycount=0 - do i=1,nraysp - mycount=mycount+1 - if(mycount.lt.idmin)cycle - if(mycount.gt.idmax)exit - if(nphysunits.eq.0)then - if(iprintarc.eq.0)write(nunit,myformat)zblock(:,i) - if(iprintarc.eq.1)write(nunit,myformat)arclen,zblock(:,i) - else - if(iprintarc.eq.0) & - & write(nunit,myformat)zblock(1,i)*sl,zblock(2,i)*p0sc, & - & zblock(3,i)*sl,zblock(4,i)*p0sc,zblock(5,i)/omegascl, & - & zblock(6,i)*(omegascl*sl*p0sc) - if(iprintarc.eq.1) & - & write(nunit,myformat)arclen,zblock(1,i)*sl,zblock(2,i)*p0sc, & - & zblock(3,i)*sl,zblock(4,i)*p0sc,zblock(5,i)/omegascl, & - & zblock(6,i)*(omegascl*sl*p0sc) - endif - enddo - do l=1,nvp-1 - call MPI_RECV(tblock,6*maxrayp,mreal,l,98,lworld,mpistat,ierr) - call MPI_GET_COUNT(mpistat,mreal,nraysw,ierr) - nraysw=nraysw/6 - do i=1,nraysw - mycount=mycount+1 - if(mycount.lt.idmin)cycle - if(mycount.gt.idmax)exit - if(nphysunits.eq.0)then - if(iprintarc.eq.0)write(nunit,myformat)tblock(1:6,i) - if(iprintarc.eq.1)write(nunit,myformat)arclen,tblock(1:6,i) - else - if(iprintarc.eq.0) & - & write(nunit,myformat)tblock(1,i)*sl,tblock(2,i)*p0sc, & - & tblock(3,i)*sl,tblock(4,i)*p0sc,tblock(5,i)/omegascl, & - & tblock(6,i)*(omegascl*sl*p0sc) - if(iprintarc.eq.1) & - & write(nunit,myformat)arclen,tblock(1,i)*sl,tblock(2,i)*p0sc, & - & tblock(3,i)*sl,tblock(4,i)*p0sc,tblock(5,i)/omegascl, & - & tblock(6,i)*(omegascl*sl*p0sc) - endif - 100 format(6(1x,1pe12.5)) - enddo - enddo - else - call MPI_SEND(zblock,6*nraysp,mreal,0,98,lworld,ierr) - endif - return - end -c--------------------------------------- - subroutine pwritet(nunit,idmin,idmax,nprecision) -c routine to perform parallel write of tblock array - use rays -! implicit none - include 'impli.inc' - integer l,nraysw - include 'files.inc' - character*16 :: myformat='(6(1x,1pe12.5 ))' - character*2 :: a2 - if(idproc.eq.0)then -!---format: - nlength=nprecision+7 - call num2string(nlength,a2,2) - myformat(10:11)=a2 - call num2string(nprecision,a2,2) - myformat(13:14)=a2 -! write(6,*)'nlength,nprecision=',nlength,nprecision -! write(6,*)'myformat=',myformat -!--- - mycount=0 - do i=1,nraysp - mycount=mycount+1 - if(mycount.lt.idmin)cycle - if(mycount.gt.idmax)exit -! write(nunit,100)tblock(:,i) - write(nunit,myformat)tblock(:,i) - enddo - do l=1,nvp-1 - call MPI_RECV(tblock,6*maxrayp,mreal,l,98,lworld,mpistat,ierr) - call MPI_GET_COUNT(mpistat,mreal,nraysw,ierr) - nraysw=nraysw/6 -! write(6,*)'(pwrite) PE 0 received ',nraysw,' rays from PE ',l - do i=1,nraysw - mycount=mycount+1 - if(mycount.lt.idmin)cycle - if(mycount.gt.idmax)exit -! write(nunit,100)tblock(1:6,i) - write(nunit,myformat)tblock(1:6,i) - 100 format(6(1x,1pe12.5)) - enddo - enddo - else - call MPI_SEND(tblock,6*nraysp,mreal,0,98,lworld,ierr) - endif - return - end -c--------------------------------------- - subroutine pwritezfp -c routine to perform parallel write of zblock array in FULL PRECISION - use rays -! implicit none - include 'impli.inc' - integer l,nraysw - include 'files.inc' - if(idproc.eq.0)then - do i=1,nraysp - write(jfcf,*)zblock(1,i),zblock(2,i) - write(jfcf,*)zblock(3,i),zblock(4,i) - write(jfcf,*)zblock(5,i),zblock(6,i) - enddo - do l=1,nvp-1 - call MPI_RECV(tblock,6*maxrayp,mreal,l,98,lworld,mpistat,ierr) - call MPI_GET_COUNT(mpistat,mreal,nraysw,ierr) - nraysw=nraysw/6 -! write(6,*)'(pwrite) PE 0 received ',nraysw,' rays from PE ',l - do i=1,nraysw - write(jfcf,*)tblock(1,i),tblock(2,i) - write(jfcf,*)tblock(3,i),tblock(4,i) - write(jfcf,*)tblock(5,i),tblock(6,i) - enddo - enddo - else - call MPI_SEND(zblock,6*nraysp,mreal,0,98,lworld,ierr) - endif - return - end -c end of file -c--------------------------------------- - subroutine pwritetfp -c routine to perform parallel write of tblock array - use rays -! implicit none - include 'impli.inc' - integer l,nraysw - include 'files.inc' - if(idproc.eq.0)then - do i=1,nraysp - write(jfcf,*)tblock(1,i),tblock(2,i) - write(jfcf,*)tblock(3,i),tblock(4,i) - write(jfcf,*)tblock(5,i),tblock(6,i) - enddo - do l=1,nvp-1 - call MPI_RECV(tblock,6*maxrayp,mreal,l,98,lworld,mpistat,ierr) - call MPI_GET_COUNT(mpistat,mreal,nraysw,ierr) - nraysw=nraysw/6 -! write(6,*)'(pwrite) PE 0 received ',nraysw,' rays from PE ',l - do i=1,nraysw - write(jfcf,*)tblock(1,i),tblock(2,i) - write(jfcf,*)tblock(3,i),tblock(4,i) - write(jfcf,*)tblock(5,i),tblock(6,i) - enddo - enddo - else - call MPI_SEND(tblock,6*nraysp,mreal,0,98,lworld,ierr) - endif - return - end -c--------------------------------------- -c end of file diff --git a/OpticsJan2020/MLI_light_optics/Src/user.f b/OpticsJan2020/MLI_light_optics/Src/user.f deleted file mode 100755 index 4fb6fb2..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/user.f +++ /dev/null @@ -1,1667 +0,0 @@ -c************ USER routines ********** - subroutine user1(p) -c Modified to plot beam envelopes 18 Dec 90 -c Overhauled some more to take various input beams -c CTM Oct 91 -c -c Ray tracing added Mar 96 FRN (&CTM) -c FOV calculation added Dec 97 (CTM) -c both moved to other USER routines May 01 -c -c This routine applies the current map in (fa,fm) to the initial sigma -c matrix given in the parameter set p = (s11,s12,s22,s33,s34,s44), to -c produce the output sigma matrix of the same form, which is saved in -c -c control parameters -c p(1) = job = -N, 0, +N : -N (N<0) means silent running in -c a fit or scan loop, with no output files. -c job = 0 (default) is to fill in /linbuf/ -c N = 1 means also slice the elements and fill in the -c sincos buffer for future use in FOV and RAY. -c N = 2 means to compute the envelope from the initial -c moments read in by USER8. The resulting envelope -c excursions are stored in UCALC(33 - 36). -c N = 3 means to also generate the table of envelope -c excursions in each element. ISEND controls where -c (and if) it is written. -c p(2) = menv = 0 for no output files. (used in fit loops, etc.) -c = 1 to write the sincos buffer to the .MSC file (lun=34) -c = 2 to write the beam envelope to the .ENV file (lun=24) -c = 3 to write both. -c p(3) = mincut = minimum no. of slices/element -c p(4) = step: nominal thickness of one slice. nslice=L/step -c p(5) = isend as usual: controls jof and jodf output. -c p(6) = jtran = 0 for no translation files. -c = 1 to write ADLIB dump on unit 22 -c = 2 to write TRACE3D format to .TRC file on unit 36 -c = 3 to write old TRANSPORT format to .TRN on unit 38 -c = 4 to write MAD format to .MAD file on unit 40 -c -c beam parameters: xx(nn) = xmax = sqrt(betax*xemit) -c ax(nn) = alphax -c px(nn) = thetax = sqrt(gammax*xemit) -c yy(nn) = ymax = sqrt(betay*yemit) -c ay(nn) = alphay -c py(nn) = thetay = sqrt(gammay*yemit) -c Tom Mottershead LANL 31-Mar-89 -c revised Dec 97 -c--------------------------------------------------------------------- - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'linbuf.inc' - include 'sigbuf.inc' - include 'usrdat.inc' - include 'parset.inc' - include 'sincos.inc' - dimension xc(2),pxc(2),xs(2),pxs(2),yc(2),pyc(2),ys(2),pys(2) - dimension p(6), fm(6,6) - logical lterm, lfile, lenv, jenv, msc, nosig - write(6,*)'WARNING (user1): sincos.inc has different declaration' - write(6,*)'for common/csrays/ than routines in usubs.f' - write(6,*)'Rob Ryne 7/23/2002' -c -c decode input parameters -c - job = nint(p(1)) - menv = nint(p(2)) - mincut = nint(p(3)) - step = p(4) - isend = nint(p(5)) - jtran = nint(p(6)) -c -c backward compatibility resets for no output if job < 0 -c - msc = .false. - lenv = .false. - jenv = .false. - nosig = .true. - if(job.lt.0) then - iquiet=1 - job = -job - endif - if(job.gt.1) nosig = .false. - if(job.eq.3) jenv = .true. - if((menv.eq.1).or.(menv.eq.3)) msc = .true. - if(menv.eq.2) lenv = .true. - lterm = .false. - lfile = .false. - if((isend.eq.1).or.(isend.eq.3)) lterm = .true. - if(isend.gt.1) lfile = .true. -c -c temp setup of dump files -c - ltrace = 1 - ltran = 0 - if(jtran.eq.1) ltran = 22 - if(jtran.eq.2) ltran = 36 - zero = 0.0d0 - one = 1.0d0 - two = 2.0d0 -c -c fillin linbuf from the loop arrays -c - npsu = 9 - call filin -c -c count the beamline -c - ndrft = 0 - nquad = 0 - do 10 nn = nbgn,nend - if(lintyp(nn).eq.0) then - ndrft = ndrft+1 - else - nquad = nquad+1 - endif - 10 continue - if(lterm) write(jof,13) ndrft,nquad - if(lfile) write(jodf,13) ndrft,nquad - 13 format(' Line has',i4,' drifts and',i4,' quads') - if(job.eq.0) return - nep = 1 + ndrft +3*nquad -c type *, ' ACTPAR on FILIN exit:' -c type *, aapar,bbpar,ccpar,ddpar,eepar,ffpar - if(lterm) write(jof,*) ' Beam Line Summary' - if(lfile) write(jodf,*) ' Beam Line Summary' - total = zero - gltot = zero - zbeg = zero -c -c write beamline list and element blocks to .ENV file -c - ap = 0.0 - nn = 0 - if(lterm) write(jof,16) - if(lfile) write(jodf,16) - 16 format(3x,'n',2x,'name',4x,' codes',2x,'aper(cm) length(cm)',4x, - & 'Gradient',5x,'PoleTip(g)',3x,'path(cm)') - do 20 nn = nbgn, nend - ltyp = lintyp(nn) - zbeg = total - total = total + elong(nn) - cmtot = 100.0*total - cml = 100.0*elong(nn) - glp = elong(nn)*strong(nn) - gltot = gltot + abs(glp) - rcm = 100.0*radius(nn) - qupole = 1.e4*strong(nn)*radius(nn) - sxpole = 1.e4*pssext(nn)*radius(nn)**2 - ocpole = 1.e4*psoctu(nn)*radius(nn)**3 - if(lterm) then - write(jof,17) nn, cname(nn), mltyp1(nn), mltyp2(nn), - & lintyp(nn), rcm, cml, strong(nn), qupole, cmtot - if(pssext(nn).ne.0.0) write(jof,18) 'sext',pssext(nn),sxpole - if(psoctu(nn).ne.0.0) write(jof,18) 'oct ',psoctu(nn),ocpole - endif - if(lfile) then - write(jodf,17) nn, cname(nn), mltyp1(nn), mltyp2(nn), - & lintyp(nn), rcm, cml, strong(nn), qupole, cmtot - if(pssext(nn).ne.0.0) write(jodf,18) 'sext',pssext(nn),sxpole - if(psoctu(nn).ne.0.0) write(jodf,18) 'oct ',psoctu(nn),ocpole - endif - 17 format(i4,2x,a,3i2,f8.2,f10.3,f15.7,f15.5,f10.3) - 18 format(16x,a4,18x,f15.7,f15.5) - 20 continue - ucalc(39) = total - ucalc(40) = gltot -cryne 08/24/2001 write(6,*),' *** Step =',step,mincut,'=mincut' - write(6,*)' *** Step =',step,mincut,'=mincut' - nask = total/step - if(lterm) write(jof,23) total,nask,step,gltot - if(lfile) write(jodf,23) total,nask,step,gltot - 23 format(' total length = ',f15.5,' in',i5,' steps of',f9.4, - & f12.6,'= Sum|GL|') -c -c write blocks on top of .ENV file -c - lun = 24 - if(lenv) call blocks(nep,lun) -c -c initialize sin/cos variables -c - jp = 1 - ni = 1 - zu = zero - xc(ni) = one - pxc(ni) = zero - xs(ni) = zero - pxs(ni) = one - yc(ni) = one - pyc(ni) = zero - ys(ni) = zero - pys(ni) = one -c -c initialize sin,cosine file -c - lun = 34 - if(msc) call blocks(nep,lun) - rcm = 100.0*radius(1) - if(msc) write(lun,147) zero,rcm,one,zero,one,zero -c -c initialize element loop -c - ni = 0 - nf = 0 - kka = 0 - kkb = 1 - xmax = 0.0 - ymax = 0.0 - xmin = 1.0e38 - ymin = 1.0e38 - if(jenv) then - if(lterm) write(jof,88) - if(lfile) write(jodf,88) - endif - 88 format(' element cuts',4x,'zxmax',6x,'xmax',6x,'xmin',5x, - &'zymax',6x,'ymax',6x,'ymin') -c -c initialize envelope points -c - xx(1) = xxin - ax(1) = axin - px(1) = pxin - yy(1) = yyin - ay(1) = ayin - py(1) = pyin - if(lenv) write(24,27) zu,xx(1),px(1),yy(1),py(1),ax(1),ay(1) - 27 format(f10.4,4(1pe11.4),2(1pe12.4)) -c -c big loop over all elements -c - do 200 nn = nbgn, nend -c -c setup transfer matrix for one slice -c - nslice = elong(nn)/step - if(nslice.lt.mincut) nslice = mincut - delta = elong(nn)/float(nslice) - grad = strong(nn) - rcm = 100.0*radius(nn) - call rmquad(delta,grad,fm) -c------------------- x plane ------------ - cfx = fm(1,1) - sfx = fm(1,2) - cpx = fm(2,1) - spx = fm(2,2) - txx = cfx**2 - tax = 2.0*cfx*sfx - tpx = sfx**2 - txa = cfx*cpx - taa = cfx*spx+sfx*cpx - tpa = sfx*spx - txp = cpx**2 - tap = 2.0*cpx*spx - tpp = spx**2 -c------------------- y plane ------------ - cfy = fm(3,3) - sfy = fm(3,4) - cpy = fm(4,3) - spy = fm(4,4) - ryy = cfy**2 - ray = 2.0*cfy*sfy - rpy = sfy**2 - rya = cfy*cpy - raa = cfy*spy+sfy*cpy - rpa = sfy*spy - ryp = cpy**2 - rap = 2.0*cpy*spy - rpp = spy**2 -c -c propagate through all the slices -c - exmax = 0.0 - eymax = 0.0 - exmin = 1.0e30 - eymin = 1.0e30 - zbgn = zu - do 100 kk = 1, nslice - ni = kka + 1 - nf = kkb + 1 - kka = 1- kka - kkb = 1- kkb - zu = zu + delta -c -c collect Sinelike and Cosinelike rays for FOV calculation -c - xc(nf) = cfx*xc(ni)+sfx*pxc(ni) - pxc(nf) = cpx*xc(ni)+spx*pxc(ni) - xs(nf) = cfx*xs(ni)+sfx*pxs(ni) - pxs(nf) = cpx*xs(ni)+spx*pxs(ni) - yc(nf) = cfy*yc(ni)+sfy*pyc(ni) - pyc(nf) = cpy*yc(ni)+spy*pyc(ni) - ys(nf) = cfy*ys(ni)+sfy*pys(ni) - pys(nf) = cpy*ys(ni)+spy*pys(ni) - cx(jp) = xc(nf) - sx(jp) = xs(nf) - cy(jp) = yc(nf) - sy(jp) = ys(nf) - za(jp) = zu - if(msc) write(lun,147) za(jp),rcm,cx(jp),sx(jp),cy(jp),sy(jp) - 147 format(6f13.7) - jp = jp+1 - if(nosig) go to 100 -c -c compute x-plane final beam ellipse -c - xss = xx(ni)**2 - xa = -xx(ni)*ax(ni)*px(ni)/sqrt(1.0d0 + ax(ni)**2) - xps = px(ni)**2 -c sigf1 = (cfx**2)*xss + 2.0*cfx*sfx*xa + (sfx**2)*xps -c sigf2 = cfx*cpx*xss + (cfx*spx+sfx*cpx)*xa + sfx*spx*xps -c sigf3 = (cpx**2)*xss + 2.0*cpx*spx*xa + (spx**2)*xps - sigf1 = txx*xss + tax*xa + tpx*xps - sigf2 = txa*xss + taa*xa + tpa*xps - sigf3 = txp*xss + tap*xa + tpp*xps - exsq = sigf1*sigf3 - sigf2**2 - if(exsq.le.0.0) exsq = 1.e-30 - ex = sqrt(exsq) - xx(nf) = sqrt(sigf1) - if(xx(nf).gt.xmax) then - xmax = xx(nf) - zxmax = zu - endif - if(xx(nf).gt.exmax) then - exmax = xx(nf) - zxm = zu - endif - if(xx(nf).lt.exmin) exmin = xx(nf) - px(nf) = sqrt(sigf3) - ax(nf) = -sigf2/ex -c -c compute y-plane beam ellipse -c - yss = yy(ni)**2 - ya = -yy(ni)*ay(ni)*py(ni)/sqrt(1.0d0 + ay(ni)**2) - yps = py(ni)**2 -c sigf4 = (cfy**2)*yss + 2.0*cfy*sfy*ya + (sfy**2)*yps -c sigf5 = cfy*cpy*yss + (cfy*spy+sfy*cpy)*ya + sfy*spy*yps -c sigf6 = (cpy**2)*yss + 2.0*cpy*spy*ya + (spy**2)*yps - sigf4 = ryy*yss + ray*ya + rpy*yps - sigf5 = rya*yss + raa*ya + rpa*yps - sigf6 = ryp*yss + rap*ya + rpp*yps - eysq = sigf4*sigf6 - sigf5**2 - if(eysq.le.0.0) eysq = 1.e-30 - ey = sqrt(eysq) - yy(nf) = sqrt(sigf4) - if(yy(nf).gt.ymax) then - ymax = yy(nf) - zymax = zu - endif - if(yy(nf).gt.eymax) then - eymax = yy(nf) - zym = zu - endif - if(yy(nf).lt.eymin) eymin = yy(nf) - py(nf) = sqrt(sigf6) - ay(nf) = -sigf5/ey - if(lenv) write(24,27) zu,xx(nf),px(nf),yy(nf),py(nf),ax(nf) - & ,ay(nf) - 100 continue - if(nosig) go to 200 - exmax = 100.0*exmax - eymax = 100.0*eymax - exmin = 100.0*exmin - eymin = 100.0*eymin - dzz = 100.0*delta - zxm = 100.0*(zxm-zbgn) - zym = 100.0*(zym-zbgn) - if(jenv) then - if(lterm) write(jof,117) cname(nn), nslice, zxm, exmax, exmin, - & zym, eymax, eymin - if(lfile) write(jodf,117) cname(nn), nslice, zxm, exmax, exmin, - & zym, eymax, eymin - endif - 117 format(2x,a,i4,6f10.3) - 200 continue - if(nosig) go to 400 - if(jenv) then -cryne 08/24/2001 if(lterm) write(jof,203), nf, xmax, zxmax, ymax, zymax -cryne 08/24/2001 if(lfile) write(jodf,203), nf, xmax, zxmax, ymax, zymax - if(lterm) write(jof,203) nf, xmax, zxmax, ymax, zymax - if(lfile) write(jodf,203) nf, xmax, zxmax, ymax, zymax - endif - 203 format(i6,' points generated. xmax =',f10.6,' at z =',f10.6,/ - & 26x,'ymax =',f10.6,' at z =',f10.6) -c -c save envelope excursions and elliptic parameters in ucalc -c - big = xmax - if(ymax.gt.big) big = ymax - ucalc(33) = xmax - ucalc(34) = ymax - ucalc(35) = xmax - ymax - ucalc(36) = big - ucalc(46) = sqrt(ymax/xmax) - ucalc(47) = sqrt(xmax*ymax) - ucalc(48) = ucalc(40)*(ucalc(47)**3) - 400 continue -c -c optional beamline translation files -c - 600 if(jtran.eq.1) call adump(ltran) - if(jtran.eq.2) call trcdmp(ltran,ltrace) - if(jtran.eq.3) call trnspt(ltran) - if(jtran.eq.4) call madump(ltran) - 777 return - end -c--------------------------------------- - subroutine user2(p) -c -c CTM 16 Apr 2001: -c New USER 2 routine generates a Taylor map from the current map in -c common/map/th(monoms),tmh(6,6) in map.inc. The Taylor map generation -c is adapted from sunroutine pcmap that writes a taylor map in -c the cartesian basis. -c - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'map.inc' - include 'expon.inc' - include 'taylor.inc' - include 'parset.inc' - dimension p(6), iuse(6), zz(6), zvec(monoms) - character*1 tu, tag(2) - logical lterm, lfile -c -c LUT for rearranging Giorgelli indexing by aberration class -c - dimension lut(209),kblok(35) - data lut /1,3,7,9,18,28,30,39,64,84,86,95,120, - & 175,2,4,8,10,14,19,29,31,35,40,54,65,85,87,91, - & 96,110,121,155,176,13,15,22,34,36,43,50,55,68,90,92, - & 99,106,111,124,145,156,179,49,51,58,74,105,107,114,130,141, - & 146,159,185,140,142,149,165,195,6,12,21,33,42,67,89,98, - & 123,178,17,24,38,45,57,70,94,101,113,126,158,181,53,60, - & 76,109,116,132,148,161,187,144,151,167,197,27,48,73,104,129, - & 184,63,79,119,135,164,190,154,170,200,83,139,194,174,204,209, - & 5,11,20,32,41,66,88,97,122,177,16,23,37,44,56,69, - & 93,100,112,125,157,180,52,59,75,108,115,131,147,160,186,143, - & 150,166,196,26,47,72,103,128,183,62,78,118,134,163,189,153, - & 169,199,82,138,193,173,203,208,25,46,71,102,127,182,61,77, - & 117,133,162,188,152,168,198,81,137,192,172,202,207,80,136,191, - & 171,201,206,205/ -c - data kblok /14,20,18,12,5,10,12,9,4,6,6,3,3, - & 2,1,10,12,9,4,6,6,3,3,2,1,6,6,3,3,2,1,3,2,1,1/ - save lut,kblok !cryne 7/23/2002 -c -c User routine for computine and printing Taylor map coefficients -c -c P(1) = iopt = 0 for compute only -c = 1 to also print -c P(2) = ipq = 0 for no T,U components -c = 1 to print Q components (x,y) only -c = 2 to print P components (Px,Py) only -c = 3 to print both Q and P components -c = 4 to print all components, including TOF -c P(3) = lun = file to write machine readback format (0 if none) -c P(4) = isend for formatted writes (0=none, 1=jof, 2=jodf, 3=both) -c P(5) = iref = pset number containing reference point to weight by -c (0=none) -c P(6) = print threshhold for weighted coefficient (at ref pt) -c - write(6,*)'inside routine user2' - iopt = nint(p(1)) - ipq = nint(p(2)) - lun = nint(p(3)) - isend= nint(p(4)) - iref = nint(p(5)) - fmin = p(6) - zero = 0.0d0 - lterm = .false. - lfile = .false. - if((isend.eq.1).or.(isend.eq.3)) lterm = .true. - if((isend.eq.2).or.(isend.eq.3)) lfile = .true. - zero = 0.0d0 -c -c set components list and reference point -c - imax = 6 - do 10 j = 1,6 - iuse(j) = j - zz(j) = pst(j,iref) - 10 continue - if(ipq.eq.3) imax = 4 - if(ipq.eq.1) then - imax = 2 - iuse(2) = 3 - endif - if(ipq.eq.2) then - imax = 2 - iuse(1) = 2 - iuse(2) = 4 - endif -c -c fill z monomial vector -c - write(6,*)'calling routine zmono' - call zmono(iopt,zz,zvec) - write(6,*)'returned from zmono' -c -c reordered dump of Lie polynomials -c - if(lterm) write(jof,19) zz - if(lfile) write(jodf,19) zz - 19 format(/,' Ref Z:',6(1pe11.2)) - if(lterm) write(jof,22) - if(lfile) write(jodf,22) - 22 format(/1h ,'nonzero elements in generating polynomial are :'/) - kmax = 35 - jmin = 1 - jmax = 0 - do 60 k = 1, kmax - jmax = jmax + kblok(k) - nfuse = 0 - do 50 j = jmin, jmax - n = lut(j) -c -c test to see if th(n) is large enough to write -c - if( abs(th(n)) .le. zero) go to 50 - frp = th(n)*zvec(n) - if(lterm) write(jof,27)n,(expon(m,n),m=1,6),th(n),th(n),frp - if(lfile) write(jodf,27)n,(expon(m,n),m=1,6),th(n),th(n),frp - 27 format(2x,'f(',i3,')=f( ',3(2i1,1x),')=',f21.6,2(1pe12.2)) - nfuse = nfuse + 1 - 50 continue - if(nfuse.gt.0) then - if(lterm) write(jof,*) ' ' - if(lfile) write(jodf,*) ' ' - endif - jmin = jmax + 1 - 60 continue -c -c generate Taylor map -c - write(6,*)'calling routine tugen' - call tugen(th,tmh) - write(6,*)'returned from tugen' -c -c write formatted dump of taylor map -c - tag(1) = 't' - tag(2) = 'u' -c -c T-matrix elements -c - if(lterm) write(jof,61) fmin - if(lfile) write(jodf,61) fmin - 61 format(/,' T-Matrix elements >',1pe10.3,/) -c -c optional machine readback file of taylor map -c - if(lun.gt.0) then - ii = 0 - jj = 0 - write(lun,68) ii,jj,zero - 68 format(2i4,1pg23.14) - do 75 ii = 1, 6 - do 70 jj = 1, 6 - if(tmh(ii,jj).ne.zero) write(lun,68) ii,jj,tmh(ii,jj) - 70 continue - 75 continue - do 85 jj = 1, 6 - do 80 ii = 1, 83 - if(tumat(ii,jj).ne.zero) then - write(lun,78) jj,ii,tumat(ii,jj),(expon(m,ii),m=1,6) - 78 format(2i4,1pg23.14,3x,6i2) - endif - 80 continue - 85 continue - endif -c -c begin formatted writes -c - write(6,*)'beginning formatted writes' - do 90 ii = 1,imax - i = iuse(ii) - kmax = 35 - jmin = 1 - jmax = 0 - tu = tag(1) - do 120 k = 1, kmax - jmax = jmax + kblok(k) - nfuse = 0 - do 100 j = jmin, jmax - n = lut(j) - if(n.gt.27) go to 100 - tval = tumat(n,i) - if(dabs(tval).le.fmin) go to 100 - tref = tval*zvec(n) - if(lterm) then - write(jof,38) tu,i,n,tu,i,(expon(m,n),m=1,6),tval,tval,tref - endif - if(lfile) then - write(jodf,38) tu,i,n,tu,i,(expon(m,n),m=1,6),tval,tval,tref - endif - 38 format(2x,a1,i1,'(',i2,')',' = ',a1,i1,'( ',2i1,2(i2,i1),' ) =', - & f21.6,' =',1pe10.2,' ref:',1pe10.2) -c if(lun.gt.0) write(lun,138) i,n,(expon(m,n),m=1,6),tumat(n,i) - 138 format(2i3,6i2,1pg21.13) - nfuse = nfuse + 1 - 100 continue - jmin = jmax + 1 - 120 continue - if(lterm) write(jof,*) ' ' - if(lfile) write(jodf,*) ' ' - 90 continue -c -c print sorted U-matrix -c - tu = tag(2) - if(lterm) write(jof,91) fmin - if(lfile) write(jodf,91) fmin - 91 format(/,' U-Matrix elements >',1pe10.3,/) -c if(lun.gt.0) write(lun,91) fmin - kmax = 35 - jmin = 1 - jmax = 0 - do 180 k = 1, kmax - jmax = jmax + kblok(k) - do 190 ii = 1,imax - i = iuse(ii) - nfuse = 0 - do 170 j = jmin, jmax - n = lut(j) - if(n.lt.28) go to 170 - if(n.gt.83) go to 170 - tval = tumat(n,i) - if(dabs(tval).le.fmin) go to 170 - tref = tval*zvec(n) - if(lterm) then - write(jof,38) tu,i,n,tu,i,(expon(m,n),m=1,6),tval,tval,tref - endif - if(lfile) then - write(jodf,38) tu,i,n,tu,i,(expon(m,n),m=1,6),tval,tval,tref - endif -c if(lun.gt.0) write(lun,138) i,n,(expon(m,n),m=1,6),tumat(n,i) - nfuse = nfuse + 1 - 170 continue - if(nfuse.gt.0) then - if(lterm) write(jof,*) ' ' - if(lfile) write(jodf,*) ' ' - endif - 190 continue - jmin = jmax + 1 - 180 continue - return - end -c -*********************************************************************** -c - subroutine user3(p) -c -c user3 dumps the specified range of ucalc in full -c precision on unit nfile - - use acceldata - use lieaparam, only : monoms - include 'impli.inc' - include 'usrdat.inc' - include 'map.inc' - dimension p(6) -c -c parameters -c -c p(1) = nfile = unit to write on -c p(2) = kmin = array min to write -c p(3) = kmax = array max to write -c p(4) = job: job = 0 to dump range if ucalc to unit nfile -c job = 1 to dump current matrix to unit nfile -c job = 2 to list typecodes -c job = 3 to list all typecodes -c job = 4 to edit comment block -c job = 5 for a Marylie dump of all commons -c p(5) = kform = format flag for dumps = 0 for full * precision -c p(6) = nextra = spare flag -c - nfile = nint(p(1)) - if(nfile.le.0) return - kmin = nint(p(2)) - kmax = nint(p(3)) - job = nint(p(4)) - kform = nint(p(5)) - nextra = nint(p(6)) -c -c ucalc dump is job 0 -c - if(job.eq.0) then - write(nfile,*) ' UCALC DUMP' - do 100 k=kmin, kmax - if(ucalc(k).ne.0.0) write(nfile,*) k, ucalc(k) - 100 continue - endif -c -c matrix print is job 1 -c - if(job.eq.1) then - write(nfile,*) ' -------- Current Matrix ----------' - write(nfile,130) (tmh(1,j),j=1,2),(tmh(3,j),j=3,4) - write(nfile,130) (tmh(2,j),j=1,2),(tmh(4,j),j=3,4) - 130 format(' Rx:',2f15.9,' Ry:',2f15.9) - endif -c -c list typecodes in this version of marylie -c - if(job.eq.2) call listyp(nfile) - if(job.eq.3) call allist(nfile) -c -c comment editing -c - if(job.eq.4) then - write(6,*)' Edit comments (e.g. to show purpose of this run)' - call caedit(maxcmt, np, mline) - endif -c -c marylie input dump -c - if(job.eq.5) call dump(nfile) - return - end -c------------------------------------------------------ - subroutine user4(p) - dimension p(*) - write(6,*)'In dummy USER4' - return - end -c--------------------------------------------------------------- - subroutine user5(pp) - include 'impli.inc' - include 'files.inc' - include 'linbuf.inc' - include 'usrdat.inc' - parameter (maxa=200, maxpt=2000) - dimension ktyp(maxa), path(maxa), bend(maxa), pp(*) - dimension xx(maxpt),yy(maxpt),key(maxpt) - logical ltty, ldsk - ltty = .true. - ldsk = .true. -c write(jof,*) ' USER5 Parameter set processor called for arcs.' - npsu = 7 - call filin -c type *, npsu,'=npsu',npst,' of these are in loop:' - if(npst.le.0) return - zero = 0.0d0 - one = 1.0d0 - two = 2.0d0 - pi = 3.14159265358979d0 - radeg = pi/180.0d0 - rdef = 192.0d0/pi - rru = rdef -c------------------------------------------ - iop = nint(pp(1)) - xbeg = pp(2) - ybeg = pp(3) - if(iop.eq.1) then - xbeg = pp(2)*dcos(radeg*pp(3)) - ybeg = pp(2)*dsin(radeg*pp(3)) - endif - angle = pp(4) - iud = nint(pp(5)) - if(iud.lt.0) then - iud = -iud - ltty = .false. - ldsk = .false. - endif - lun = nint(pp(6)) -c -c echo and process contents of loop -c - arclen = zero - do 20 j = 1, npst - job = nint(aap(j)) - path(j) = bbp(j) - bend(j) = ccp(j) - theta = radeg*bend(j) - if(job.eq.1) rru = dabs(path(j)/theta) - if(job.eq.2) path(j) = dabs(rru*radeg*bend(j)) - if(job.eq.3) bend(j) = path(j)/(rru*radeg) - ktyp(j) = nint(ddp(j)) - arclen = arclen + path(j) - if(ltty) then - write(jof,17) j,job,ktyp(j),path(j),bend(j),rru,bbp(j),ccp(j) - endif - if(ldsk) then - write(jodf,17) j,job,ktyp(j),path(j),bend(j),rru,bbp(j),ccp(j) - endif - 17 format(i6,2i3,5f13.6) - 20 continue -c -c data in, draw arcs -c - xx(1) = xbeg - yy(1) = ybeg - delta = two - call arcs(npst,ktyp,path,bend,angle,delta,maxpt,xx,yy,key,nn) - if(ltty) write(jof,32) arclen,nn - if(ldsk) write(jodf,32) arclen,nn - 32 format(' Total path length =',f12.6,' in',i4,' points') - if(ltty) write(jof,34) xx(nn),yy(nn),angle - if(ldsk) write(jodf,34) xx(nn),yy(nn),angle - 34 format(' Endpoint:',f13.6,' = x',f13.6,' = y at',f10.4,' deg.') -c -c optional save to ucalc -c - if((iud.gt.0).and.(iud.le.250)) then - ucalc(iud) = arclen - ucalc(iud+1) = angle - ucalc(iud+2) = xx(nn) - ucalc(iud+3) = yy(nn) - endif -c -c optional coordinate dump -c - if(lun.le.0) return - do 50 j = 1,nn - write(lun,47) key(j),xx(j),yy(j) - 47 format(i5,2f12.6) - 50 continue - return - end -c -*********************************************************************** -c - subroutine user6(p,f,fm) -c -c alternate sigma matrix input -c -c p(1) = alphax -c p(2) = betax -c p(3) = epsx -c p(4) = alphay -c p(5) = betay -c p(6) = epsy - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'usrdat.inc' - include 'sigbuf.inc' - dimension f(monoms) - dimension fm(6,6) - dimension p(6), psig(6) - alphax = p(1) - betax = p(2) - epsx = p(3) - if(epsx.le.0.0) epsx = 1.0 - alphay = p(4) - betay = p(5) - epsy = p(6) - if(epsy.le.0.0) epsy = 1.0 - psig(1) = sqrt(epsx*betax) - psig(2) = alphax - gamx = (1.0 + alphax**2)/betax - psig(3) = sqrt(epsx*gamx) - psig(4) = sqrt(epsy*betay) - psig(5) = alphay - gamy = (1.0 + alphay**2)/betay - psig(6) = sqrt(epsy*gamy) - call user8(psig, f, fm) - return - end -c -************************************************************************ -c -cryne 8/11/2001 subroutine user7(p,g,mh) -cryne 8/11/2001 include 'impli.inc' -cryne 8/11/2001 dimension p(6) -ccc call u7test(p) -cryne 8/11/2001 return -cryne 8/11/2001 end -c -c subroutine user7(p,g,mh) -c type *, ' In dummy USER7' -c return -c end -*********************************************************************** -c - subroutine user8(p,f,rm) -c This routine applies the current map in (f,rm) to the initial sigma -c matrix given in the parameter set p = (s11,s12,s22,s33,s34,s44), to -c produce the output sigma matrix of the same form, which is saved in -c ucalc(1:6) in the same order. -c -c parameters: p(1) = xmax = sqrt(betax*xemit) -c p(2) = alphax -c p(3) = thetax = sqrt(gammax*xemit) -c p(4) = ymax = sqrt(betay*yemit) -c p(5) = alphay -c p(6) = thetay = sqrt(gammay*yemit) -c Tom Mottershead LANL 31-Mar-89 -c f Neri LANL 5-Dec-90 Full 4D calculation. -c Elliptical beam kicks. 8-Apr-92 -c--------------------------------------------------------------------- - use beamdata - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'usrdat.inc' - include 'sigbuf.inc' - include 'parset.inc' - dimension f(monoms) - dimension rm(6,6) - dimension p(6) - logical lterm, lfile - isend = 3 - level = 1 - lterm = .true. - lfile = .true. -c -c save input parameters to sigbuf for user1 -c -c load input beam from #menu -c - if(p(1).gt.0.0) then - xxin = p(1) - axin = p(2) - pxin = p(3) - yyin = p(4) - ayin = p(5) - pyin = p(6) - go to 100 - endif -c -c optional input specifications -c - job = nint(-p(1)) - inform = nint(p(2)) - lunin = nint(p(3)) - lout = nint(p(4)) -c -c output switches -c - level = nint(p(5)) - isend = nint(p(6)) - lterm = .false. - lfile = .false. - if((isend.eq.1).or.(isend.eq.3)) lterm = .true. - if(isend.ge.2) lfile = .true. -c -c aberrations only case -c - if(job.eq.5) go to 300 - if(inform.ne.0) go to 100 - if(lunin.gt.0) then - rewind(lunin) - read(lunin,*) xxin,axin,pxin,yyin,ayin,pyin - endif - if(lunin.lt.0) then - kpu = -lunin - if((kpu.lt.1).or.(kpu.gt.maxpst)) then - write(jof,*) ' USR8 Error:',kpu,' is not a valid pset' - call myexit - endif - xxin = pst(1,kpu) - axin = pst(2,kpu) - pxin = pst(3,kpu) - yyin = pst(4,kpu) - ayin = pst(5,kpu) - pyin = pst(6,kpu) - endif -c -c end of input options, map the beam -c - 100 continue - if(iquiet.eq.1) then - lterm = .false. - lfile = .false. - endif -c -c clear sigma matrices -c - do 150 i=1,4 - do 150 j=1,4 - sig0(i,j) = 0.d0 - sigf(i,j) = 0.d0 - 150 continue -c -c Initialize Sigma Matrix from input beam parameter block -c - sig0(1,1) = xxin**2 - sig0(1,2) = -xxin*axin*pxin/sqrt(1.0d0 + axin**2) - sig0(2,2) = pxin**2 - sig0(2,1) = sig0(1,2) - sig0(3,3) = yyin**2 - sig0(3,4) = -yyin*ayin*pyin/sqrt(1.0d0 + ayin**2) - sig0(4,4) = pyin**2 - sig0(4,3) = sig0(3,4) -c -c Transport Ellipse ( 4D ) -c - do 250 i=1,4 - do 250 j=1,4 - do 200 k=1,4 - do 200 n=1,4 - sigf(i,j) = sigf(i,j) + rm(i,n)*sig0(n,k)*rm(j,k) - 200 continue - 250 continue -c type *, ' sigf:', sigf -c -c normal moments -c - xxf = sigf(1,1) - xpf = sigf(1,2) - ppf = sigf(2,2) - yyf = sigf(3,3) - yqf = sigf(3,4) - qqf = sigf(4,4) -c -c cross moments -c - xyf = sigf(1,3) - ypf = sigf(2,3) - xqf = sigf(1,4) - detc = xxf*yyf-xyf**2 -c type *,' detc =',detc - xfocus = (yyf*xpf-xyf*ypf)/detc - yfocus = (xxf*yqf-xyf*xqf)/detc - xcross = (xxf*ypf-xyf*xpf)/detc - ycross = (yyf*xqf-xyf*yqf)/detc -c -c normal emittances -c - exsq = xxf*ppf - xpf**2 - if(exsq.le.0.0) exsq = 1.e-30 - ex = sqrt(exsq) - betax = xxf/ex - gammax = ppf/ex -c - eysq = yyf*qqf - yqf**2 - if(eysq.le.0.0) eysq = 1.e-30 - ey = sqrt(eysq) - betay = yyf/ey -c - ucalc(1) = sqrt(xxf) - ucalc(2) = -xpf/ex - ucalc(3) = sqrt(ppf) - ucalc(4) = sqrt(yyf) - ucalc(5) = -yqf/ey - ucalc(6) = sqrt(qqf) - ucalc(7) = betax - ucalc(8) = ex - ucalc(9) = xfocus - ucalc(10) = xcross - ucalc(11) = betay - ucalc(12) = ey - ucalc(13) = yfocus - ucalc(14) = ycross - ucalc(50) = xxf-yyf -c -c save output beam -c - if (lout.gt.0) write(lout,*) (ucalc(j), j= 1,6) - if (lout.lt.0) then - kpu = -lout - if((kpu.lt.1).or.(kpu.gt.maxpst)) then - write(jof,*) ' USR8 Error:',kpu,' is not a valid pset' - call myexit - endif - do 400 j=1,6 - pst(j,kpu) = ucalc(j) - 400 continue - endif -c -c copy output back over input if job=3 -c - if(job.eq.3) then - xxin = ucalc(1) - axin = ucalc(2) - pxin = ucalc(3) - yyin = ucalc(4) - ayin = ucalc(5) - pyin = ucalc(6) - endif -c -c Change of Sigma with energy: first order ( f. Neri 12-5-1990 ). -c - dsig(1,1) = -2*f(38)*sigf(1,1) - 4*f(53)*sigf(1,2) - - & 2*f(57)*sigf(1,3) - 2*f(60)*sigf(1,4) - dsig(1,2) = 2*f(33)*sigf(1,1) + f(42)*sigf(1,3) + - & f(45)*sigf(1,4) - 2*f(53)*sigf(2,2) - - & f(57)*sigf(2,3) - f(60)*sigf(2,4) - dsig(2,2) = 4*f(33)*sigf(1,2) + 2*f(38)*sigf(2,2) + - & 2*f(42)*sigf(2,3) + 2*f(45)*sigf(2,4) - dsig(1,3) = -(f(45)*sigf(1,1)) - f(60)*sigf(1,2) - - & f(38)*sigf(1,3) - f(70)*sigf(1,3) - - & 2*f(76)*sigf(1,4) - 2*f(53)*sigf(2,3) - - & f(57)*sigf(3,3) - f(60)*sigf(3,4) - dsig(2,3) = -(f(45)*sigf(1,2)) + 2*f(33)*sigf(1,3) - - & f(60)*sigf(2,2) + f(38)*sigf(2,3) - - & f(70)*sigf(2,3) - 2*f(76)*sigf(2,4) + - & f(42)*sigf(3,3) + f(45)*sigf(3,4) - dsig(3,3) = -2*f(45)*sigf(1,3) - 2*f(60)*sigf(2,3) - - & 2*f(70)*sigf(3,3) - 4*f(76)*sigf(3,4) - dsig(1,4) = f(42)*sigf(1,1) + f(57)*sigf(1,2) + - & 2*f(67)*sigf(1,3) - f(38)*sigf(1,4) + - & f(70)*sigf(1,4) - 2*f(53)*sigf(2,4) - - & f(57)*sigf(3,4) - f(60)*sigf(4,4) - dsig(2,4) = f(42)*sigf(1,2) + 2*f(33)*sigf(1,4) + - & f(57)*sigf(2,2) + 2*f(67)*sigf(2,3) + - & f(38)*sigf(2,4) + f(70)*sigf(2,4) + - & f(42)*sigf(3,4) + f(45)*sigf(4,4) - dsig(3,4) = f(42)*sigf(1,3) - f(45)*sigf(1,4) + - & f(57)*sigf(2,3) - f(60)*sigf(2,4) + - & 2*f(67)*sigf(3,3) - 2*f(76)*sigf(4,4) - dsig(4,4) = 2*f(42)*sigf(1,4) + 2*f(57)*sigf(2,4) + - & 4*f(67)*sigf(3,4) + 2*f(70)*sigf(4,4) -c - ds11 = dsig(1,1) - ds12 = dsig(1,2) - ds22 = dsig(2,2) - ds33 = dsig(3,3) - ds34 = dsig(3,4) - ds44 = dsig(4,4) -c - ucalc(21) = ds11 - ucalc(22) = ds12 - ucalc(23) = ds22 - ucalc(24) = ds33 - ucalc(25) = ds34 - ucalc(26) = ds44 -c - dfxdp = -beta*(xxf*ds12 - xpf*ds11)/(xxf**2) - dfydp = -beta*(yyf*ds34 - yqf*ds33)/(yyf**2) - ucalc(15) = dfxdp - ucalc(16) = dfydp - ucalc(37) = dfxdp - dfydp - ucalc(38) = dfxdp**2 + dfydp**2 -c -c rms cubic aberration amplitude -c -c aa = f(84) -c bb = f(95) -c cc = f(175) -c qq0 = 5.0*(aa**2 + cc**2) + 0.5*bb**2 + bb*(aa+cc) -c abcube = sqrt(qq0) -c Get Ellipticity from user1: - rx = ucalc(46) - if (rx .eq. 0.0 ) then - write(6,*) ' user8: Ellipticity not set in user1, so take r=1' - rx = 1.0 - endif - ry = 1/rx -c -c Mathematica formula for quadratic and cubic kicks -c - 300 continue -c abquad=3.375*(f(28)**2 + f(64)**2) + 0.875*(f(30)**2 + f(39)**2) -c * + 0.75*(f(30)*f(64) + f(28)*f(39)) -c abcube=5.*(f(84)**2 + f(175)**2) + f(95)*(f(175)+f(84)) + -c * 0.5*f(95)**2 + 0.75*f(86)*f(120) + 0.875*(f(86)**2+f(120)**2) -c - abquad=3.375*rx**4*f(28)**2 + 0.375*rx**4*f(30)**2 + - & 0.5*rx**2*ry**2*f(30)**2 + - & 0.75*rx**2*ry**2*f(28)*f(39) + - & 0.5*rx**2*ry**2*f(39)**2 + 0.375*ry**4*f(39)**2 + - & 0.75*rx**2*ry**2*f(30)*f(64) + 3.375*ry**4*f(64)**2 - abcube=5.*rx**6*f(84)**2 + 0.3125*rx**6*f(86)**2 + - & 0.5625*rx**4*ry**2*f(86)**2 + - & rx**4*ry**2*f(84)*f(95) + - & 0.25*rx**4*ry**2*f(95)**2 + - & 0.25*rx**2*ry**4*f(95)**2 + - & 0.375*rx**4*ry**2*f(86)*f(120) + - & 0.375*rx**2*ry**4*f(86)*f(120) + - & 0.5625*rx**2*ry**4*f(120)**2 + - & 0.3125*ry**6*f(120)**2 + rx**2*ry**4*f(95)*f(175) + - & 5.*ry**6*f(175)**2 -c -c - ptquad=3.375*(f(49)**2 + f(74)**2) + 0.875*(f(51)**2 + f(58)**2) - & + 0.75*(f(51)*f(74) + f(49)*f(58)) -c - ptcube=5.*(f(140)**2 + f(195)**2) + f(149)*(f(195)+f(140)) + - & 0.5*f(149)**2 + 0.75*f(142)*f(165) + 0.875*(f(142)**2+f(165)**2) -c - abfour = 0.0 - abfive = 0.0 - ucalc(17) = sqrt(abquad) - ucalc(18) = sqrt(abcube) - ucalc(19) = sqrt(abfour) - ucalc(20) = sqrt(abfive) - ucalc(60) = sqrt(ptquad) - ucalc(61) = sqrt(ptcube) -c - cx = -2.0*beta*f(33) - cy = -2.0*beta*f(67) - ucalc(41) = cx - ucalc(42) = cy - ucalc(43) = cx**2 + cy**2 - ucalc(44) = cx - cy - ucalc(45) = ucalc(1)*ucalc(4) - cxim = -2.0*beta*f(53) - ucalc(62) = cxim - if(f(38).ne.0.0) xvs = -2.0*f(53)/f(38) - ucalc(63) = xvs - cyim = -2.0*beta*f(76) - ucalc(64) = cyim - if(f(70).ne.0.0) yvs = -2.0*f(76)/f(70) - ucalc(65) = yvs - if(lterm) call u8out(jof,level) - if(lfile) call u8out(jodf,level) - return - end -c**************************************************************** - subroutine user9(p,fa,fm) -c -c This routine does arithmetic operations on the current map. -c C. T. Mottershead LANL AOT-1 / 4 April 96 -c--------------------------------------------------------------------- - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'usrdat.inc' - include 'taylor.inc' - dimension fa(monoms) - dimension fm(6,6) - dimension p(6), xv(30) -c - job = int(p(1)) - jndx = int(p(2)) - kndx = int(p(3)) - nusr = int(p(4)) - aa = p(5) - bb = p(6) -c type *,' USR9:',job,jndx,kndx,nusr,aa,bb - if(job.lt.0) then - job = -job - idxa = nint(p(5)) - if((idxa.gt.0).and.(idxa.le.250)) aa = ucalc(idxa) - idxb = nint(p(6)) - if((idxb.gt.0).and.(idxb.le.250)) bb = ucalc(idxb) - endif - zero = 0.0d0 - value = zero -c -c job = 0 is to set constants into ucalc -c - if(job.eq.0) then - if((jndx.gt.0).and.(jndx.le.250)) ucalc(jndx) = aa - if((kndx.gt.0).and.(kndx.le.250)) ucalc(kndx) = bb -c write(6,17) jndx,aa,kndx,bb -c 17 format(' in USR9, set u(',i3,')=',f12.6,' u(',i3,')=',f12.6) - return - endif -c -c a valid user location is required for job.ne.0 -c - if((nusr.lt.1).or.(nusr.gt.250)) then - write(jof,117) nusr - 117 format(' USR9 ERROR:',i8,' is not a valid UCALC location') - return - endif -c -c job = 1 is to store linear combinations of R-matrix elements -c - if(job.eq.1) then - if((jndx.gt.10).and.(jndx.lt.67)) then - ii = jndx/10 - jj = jndx - 10*ii - value = value + aa*fm(ii,jj) - endif - if((kndx.gt.10).and.(kndx.lt.67)) then - ii = kndx/10 - jj = kndx - 10*ii - value = value + bb*fm(ii,jj) - endif - endif -c -c job = 2 is to store linear combinations of Lie coefficients -c - if(job.eq.2) then - if((jndx.gt.0).and.(jndx.le.monoms)) value=value+aa*fa(jndx) - if((kndx.gt.0).and.(kndx.le.monoms)) value=value+bb*fa(kndx) - endif -c -c job=3 is to store linear combinations of UCALC entries -c - if(job.eq.3) then - if((jndx.gt.0).and.(jndx.le.250)) value=value+aa*ucalc(jndx) - if((kndx.gt.0).and.(kndx.le.250)) value=value+bb*ucalc(kndx) - endif -c -c job=4 is to compute reciprocals of selected variables -c - if(job.eq.4) then - if((kndx.gt.0).and.(kndx.lt.4)) then - call getvar(kndx,nv,xv) - if((jndx.le.nv).and.(jndx.gt.0)) then - xpar = xv(jndx) - if(xpar.ne.0.0d0) value = aa/xpar - endif - endif - endif -c -c job=5 is to compute ratios of Lie coefficients -c - if(job.eq.5) then - if((jndx.gt.0).and.(jndx.le.monoms)) value=value+aa*fa(jndx) - if((kndx.gt.0).and.(kndx.le.monoms)) then - denom = fa(kndx) + bb - if(denom.ne.zero) value = value/denom - endif - endif -c -c job=6 is to compute ratios of Taylor coefficients -c - if(job.eq.6) then - if((jndx.gt.10).and.(jndx.lt.836)) then - ii = jndx/10 - jj = jndx - 10*ii - value = value + aa*tumat(ii,jj) - endif - if((kndx.gt.10).and.(kndx.lt.836)) then - ii = kndx/10 - jj = kndx - 10*ii - denom = tumat(ii,jj) + bb - if(denom.ne.zero) value = value/denom - endif - endif -c -c job=7 is to compute ratios of ucalc entries -c - if(job.eq.7) then - if((jndx.gt.0).and.(jndx.le.250)) value=value+aa*ucalc(jndx) - if((kndx.gt.0).and.(kndx.le.250)) then - denom = ucalc(kndx) + bb - if(denom.ne.zero) value = value/denom - endif - endif -c -c job=8 is to compute the weighted RMS of the two ucalc entries: -c - if(job.eq.8) then - if((jndx.gt.0).and.(jndx.le.250)) then - value=value+aa*ucalc(jndx)**2 - endif - if((kndx.gt.0).and.(kndx.le.250)) then - value=value+bb*ucalc(kndx)**2 - endif - value = dsqrt(value) - endif - ucalc(nusr) = value - return - end -c**************************************************************** - subroutine user10(p,fa,fm) -cryne routine to print data in the fitbuf array -c--------------------------------------------------------------------- - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'usrdat.inc' - include 'taylor.inc' - include 'fitdat.inc' -ctm include 'arcblk.inc' - include 'map.inc' - dimension fa(monoms) - dimension fm(6,6),p(6) -c - nfile = nint(p(1)) - i1=nint(p(2)) - i2=nint(p(3)) - i3=nint(p(4)) - i4=nint(p(5)) - i5=nint(p(6)) - if(i1.eq.0)then - col1=arclen - else - col1=fitval(i1) - endif - if(i3.eq.0)then - write(nfile,101)col1,fitval(i2) - elseif(i4.eq.0)then - write(nfile,101)col1,fitval(i2),fitval(i3) - elseif(i5.eq.0)then - write(nfile,101)col1,fitval(i2),fitval(i3),fitval(i4) - else - write(nfile,101)col1,fitval(i2),fitval(i3),fitval(i4),fitval(i5) - endif - 101 format(5(1pe13.6,1x)) -ctm9/01 call flush_(nfile) - return - end -c -************************************************************************ -c - subroutine user11(p,fa,fm) -c dbleArr p(6) -c p(1)= -c p(2)= -c p(3)= -c p(4)= -c p(5)= -c p(6)= -c dblArr fa(monoms)=Lie generators for map f -c dblArr fm(6,6)=linear part of map f -c -c Dummy user routine 'user11'. -c-----!----------------------------------------------------------------! - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c - write(6,*) 'in user11 ... returning ...' -c - return - end -c -************************************************************************ -c - subroutine user12(p,fa,fm) -c dbleArr p(6) -c p(1)= -c p(2)= -c p(3)= -c p(4)= -c p(5)= -c p(6)= -c dblArr fa(monoms)=Lie generators for map f -c dblArr fm(6,6)=linear part of map f -c -c Dummy user routine 'user12'. -c-----!----------------------------------------------------------------! - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c - write(6,*) 'in user12 ... returning ...' -c - return - end -c -************************************************************************ -c - subroutine user13(p,fa,fm) -c dbleArr p(6) -c p(1)= -c p(2)= -c p(3)= -c p(4)= -c p(5)= -c p(6)= -c dblArr fa(monoms)=Lie generators for map f -c dblArr fm(6,6)=linear part of map f -c -c Dummy user routine 'user13'. -c-----!----------------------------------------------------------------! - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c - write(6,*) 'in user13 ... returning ...' -c - return - end -c -************************************************************************ -c - subroutine user14(p,fa,fm) -c dbleArr p(6) -c p(1)= -c p(2)= -c p(3)= -c p(4)= -c p(5)= -c p(6)= -c dblArr fa(monoms)=Lie generators for map f -c dblArr fm(6,6)=linear part of map f -c -c Dummy user routine 'user14'. -c-----!----------------------------------------------------------------! - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c - write(6,*) 'in user14 ... returning ...' -c - return - end -c -************************************************************************ -c - subroutine user15(p,fa,fm) -c dbleArr p(6) -c p(1)= -c p(2)= -c p(3)= -c p(4)= -c p(5)= -c p(6)= -c dblArr fa(monoms)=Lie generators for map f -c dblArr fm(6,6)=linear part of map f -c -c Dummy user routine 'user15'. -c-----!----------------------------------------------------------------! - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c - write(6,*) 'in user15 ... returning ...' -c - return - end -c -************************************************************************ -c - subroutine user16(p,fa,fm) -c dbleArr p(6) -c p(1)= -c p(2)= -c p(3)= -c p(4)= -c p(5)= -c p(6)= -c dblArr fa(monoms)=Lie generators for map f -c dblArr fm(6,6)=linear part of map f -c -c Dummy user routine 'user16'. -c-----!----------------------------------------------------------------! - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c - write(6,*) 'in user16 ... returning ...' -c - return - end -c -************************************************************************ -c - subroutine user17(p,fa,fm) -c dbleArr p(6) -c p(1)= -c p(2)= -c p(3)= -c p(4)= -c p(5)= -c p(6)= -c dblArr fa(monoms)=Lie generators for map f -c dblArr fm(6,6)=linear part of map f -c -c Dummy user routine 'user17'. -c-----!----------------------------------------------------------------! - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c - write(6,*) 'in user17 ... returning ...' -c - return - end -c -************************************************************************ -c - subroutine user18(p,fa,fm) -c dbleArr p(6) -c p(1)= -c p(2)= -c p(3)= -c p(4)= -c p(5)= -c p(6)= -c dblArr fa(monoms)=Lie generators for map f -c dblArr fm(6,6)=linear part of map f -c -c Dummy user routine 'user18'. -c-----!----------------------------------------------------------------! - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c - write(6,*) 'in user18 ... returning ...' -c - return - end -c -************************************************************************ -c - subroutine user19(p,fa,fm) -c dbleArr p(6) -c p(1)= -c p(2)= -c p(3)= -c p(4)= -c p(5)= -c p(6)= -c dblArr fa(monoms)=Lie generators for map f -c dblArr fm(6,6)=linear part of map f -c -c Dummy user routine 'user19'. -c-----!----------------------------------------------------------------! - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c - write(6,*) 'in user19 ... returning ...' -c - return - end -c -************************************************************************ -c - subroutine user20(p,fa,fm) -c dbleArr p(6) -c p(1)= -c p(2)= -c p(3)= -c p(4)= -c p(5)= -c p(6)= -c dblArr fa(monoms)=Lie generators for map f -c dblArr fm(6,6)=linear part of map f -c -c Dummy user routine 'user20'. -c-----!----------------------------------------------------------------! - use lieaparam, only : monoms - include 'impli.inc' -c -c calling arrays - dimension fa(monoms) - dimension fm(6,6) - dimension p(6) -c - write(6,*) 'in user20 ... returning ...' -c - return - end -c -************************************************************************ diff --git a/OpticsJan2020/MLI_light_optics/Src/user7.f b/OpticsJan2020/MLI_light_optics/Src/user7.f deleted file mode 100755 index c4a7c84..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/user7.f +++ /dev/null @@ -1,51 +0,0 @@ - subroutine user7(p,g,hmh) - use lieaparam, only : monoms - include 'impli.inc' - include 'ind.inc' - include 'prodex.inc' - dimension p(*), g(*), hmh(*) - write(6,*)' In USER7 test' - lun = p(1) - mbgn = p(2) - if(mbgn.le.0) mbgn = 1 - num = p(3) - if(num.le.0) num = monoms - write(6,*)'PRODEX:' - do i=0,923 - write(96,1234)i,prodex(1:6,i) - enddo - 1234 format(i5,4x,6i10) -c call sixi(lun,prodex,monoms) - write(6,*)imaxi,' = IMAXI' - write(6,*)' JV, INDEX1, INDEX2' - call onei(lun,jv(mbgn),index1(mbgn),index2(mbgn),num) - return - end -c-------------------------------- - subroutine sixi(lun,ival,num) - dimension ival(6,*), ibuf(6) - do 100 k = 1,num+1 - kv = 0 - do 50 j = 1,6 - ibuf(j) = ival(j,k) - if(ibuf(j).ne.0) kv = kv + 1 - 50 continue - if(kv.gt.0) write(lun,77) k,ibuf - 77 format(7i5) - 100 continue - return - end -c-------------------------------------- - subroutine onei(lun,ival,jval,kval,num) - dimension ival(*), jval(*), kval(*) - do 100 k = 1,num - if(ival(k).ne.0) write(lun,77) k,ival(k),jval(k),kval(k) - 77 format(4i8) - 100 continue - return - end -c -c subroutine user7(p,g,hmh) -c dimension p(*), g(*), hmh(*) -c return -c end diff --git a/OpticsJan2020/MLI_light_optics/Src/usubs.f b/OpticsJan2020/MLI_light_optics/Src/usubs.f deleted file mode 100755 index 37fa2c7..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/usubs.f +++ /dev/null @@ -1,1185 +0,0 @@ -c********* USER subroutines pkg ******* - subroutine allist(lun) -c -c allist makes an alphabetical LaTeX table of all -c type codes in the current vesion of marylie -c T. Mottershead LANL AT-3 16 Jan 92 -c------------------------------------------------- - include 'codes.inc' - character*8 tcode(360), word - dimension nseq(360), npars(360), kind(360) -c -c fill unsorted tcode array, stopping on null string for each group -c - long = 40 - max = 0 - do 20 j = 1, 9 - do 10 n=1,40 - word = ltc(j,n) - if(ichar(word(1:1)).eq.0) go to 20 - max = max + 1 - tcode(max) = word - npars(max) = nrp(j,n) - kind(max) = j - 10 continue - 20 continue -c -c alphabetize and write Latex table -c - call lexort(max,tcode,nseq) - call headoc(lun,'MaryLie Type Codes') - call tabdef(lun,5) - write(lun,27) - 27 format(' No. & Code & Kind & NRP & \\') - write(lun,*) ' \hline' - do 50 k = 1,max - jj = nseq(k) - write(lun,37) k, tcode(jj), kind(jj), npars(jj) - 37 format(i6,' & ',a,' &',i3,' &',i3,' & \\') - if(mod(k,long).eq.0) then - call tabend(lun) - write(lun,*) ' \newpage' - call tabdef(lun,5) - write(lun,27) - write(lun,*) ' \hline' - endif - 50 continue - call tabend(lun) - call endoc(lun) - return - end -c--------------------------------------------------- - subroutine arcs(nseg,ktyp,path,bend,angle,delta,max,xx,yy,key,nn) -c -c Generates (xx(i),yy(i),i=1,nn) for drawing a sequence of -c connected arcs. The curve starts from x(1),y(1) at input angle, -c and ends at x(nn),y(nn) headed in direction of final angle. -c nseg = number of path segments k=1,nseg -c path(k) = arclength of kth segment -c bend(k) = bend angle in degrees of kth segment -c ktyp(k) = ID or type code for kth segment -c delta = degrees of bend per plot point (max allowed) -c max = maximum number of output points allowed -c -c C. T. Mottershead 24 Aug 99 -c------------------------------------------------------- - implicit double precision (a-h,o-z) - dimension path(*),bend(*),ktyp(*),xx(max),yy(max),key(max) - pi = 3.14159265358979d0 - radeg = pi/180.0d0 - bmin = 0.001 - one = 1.0d0 - xu = xx(1) - yu = yy(1) - key(1) = ktyp(1) - lout = 44 - nn = 0 -c -c loop over all path segments -c - do 200 k = 1,nseg - theta = radeg*angle - angle = angle + bend(k) - xs = path(k)*dcos(theta) - ys = path(k)*dsin(theta) - write(lout,207) k,ktyp(k),path(k),bend(k),angle,xs,ys - 207 format(' Arc:',2i4,5f12.4) -c -c straight segment -c - if(dabs(bend(k)).lt.bmin) then - nn = nn+1 - if(nn.gt.max) return - xx(nn) = xu - yy(nn) = yu - key(nn) = ktyp(k) - nn = nn+1 - if(nn.gt.max) return - xu = xu + xs - yu = yu + ys - xx(nn) = xu - yy(nn) = yu - key(nn) = ktyp(k) - np = 1 -c write(lout,97) nn,key(nn),xx(nn),yy(nn),xs,ys - go to 190 - endif -c -c curved segment (starts with duplicate of previous point) -c - nn = nn+1 - if(nn.gt.max) return - xx(nn) = xu - yy(nn) = yu - key(nn) = ktyp(k) - phi = radeg*bend(k) - radius = path(k)/phi - np = nint(bend(k)/delta) - if(np.lt.0) np = -np - if(np.eq.0) np = 1 - fnp = float(np) - alpha = phi/fnp - xs = xs/fnp - ys = ys/fnp - cosa = dcos(alpha) - sina = dsin(alpha) - sfac = sina/alpha - cfac = (one-cosa)/alpha - x0 = xs - y0 = ys -c -c update plot points in arc -c - do 100 j = 1,np - dx = sfac*xs - cfac*ys - dy = sfac*ys + cfac*xs - xu = xu + dx - yu = yu + dy - nn = nn+1 - if(nn.gt.max) return - xx(nn) = xu - yy(nn) = yu - key(nn) = ktyp(k) - xs = cosa*x0 - sina*y0 - ys = cosa*y0 + sina*x0 - x0 = xs - y0 = ys - 100 continue - 190 continue - 200 continue - return - end -c -ccccccccccccccccc Blocks cccccccccccccccccccccccccccccc -c - subroutine blocks(nep,lun) - use beamdata - include 'impli.inc' - include 'linbuf.inc' - zero = 0.0d0 - ap = zero - zbeg = zero - nn = 0 - write(lun,12) nep,nrays,npos,nang,brho,beta,gamm1 - write(lun,13) zbeg, ap, strong(1), nn,nn, cname(1) - 12 format(4i5,3f16.7) - 13 format(3f16.7,2i5,2x,a8) -c -c write envelope file top section -c - do 20 nn = nbgn, nend - ltyp = lintyp(nn) - zbeg = total - total = total + elong(nn) - cmtot = 100.0*total - cml = 100.0*elong(nn) - glp = elong(nn)*strong(nn) - gltot = gltot + abs(glp) - rcm = 100.0*radius(nn) - kk = nn - if(ltyp.ne.0) then - ap = radius(nn) - write(lun,13) zbeg, ap, strong(nn), nn, ltyp, cname(nn) - write(lun,13) total, ap, strong(nn), nn, ltyp, cname(nn) - kk = nn + 1 - endif - ap = 0.0 - write(lun,13) total, ap, zero, nn, ltyp, cname(kk) - 20 continue - return - end -c-------------------------------------- - - subroutine caedit(max, nl, text) -c -c caedit is a simple character array editing routine. -c text(i), i=1,nl is the array of character strings to be edited. -c The length of the strings is determined internally. -c All strings are the same length. -c nl = actual number of character strings, which may be increased -c or decreased by this routine. -c max = maximum number of character strings allowed by the calling -c program. -c -c T. Mottershead/ LANL AT-3 / 24 Jan 91 -c---------------------------------------------------------- - character*(*) text(max) - character*74 card -c -c print array -c - 10 do 20 j=1, nl - card = text(j) - write(6,13) j,card - 13 format(i3,a) - 20 continue -c -c command input -c - 30 write(6,32) - 32 format(' enter command: +N = insert new line N, 0 = quit,', - & ' -N = delete line N') - read(5,*) kl - if(kl.eq.0) return -c -c delete line N -c - if(kl.lt.0) then - nd = -kl - if(nd.gt.nl) go to 30 - last = nd - card = ' ' - write(6,37) last - 37 format(' enter last line to delete <',i3,'>:') - read(5,64) card - if(card.ne.' ') then - read(card,*) last - endif - 40 nl = nl-1 - do 50 n = nd,nl - text(n) = text(n+1) - 50 continue - if(last.le.nd) go to 10 - last = last-1 - go to 40 - endif -c -c add new line N -c - if(kl.gt.0) then - if(kl.gt.nl) kl = nl+1 - write(6,*) ' Enter new line(s) =print' - 60 card = ' ' - read(5,64) card - 64 format(a) - if(card.eq.' ') go to 10 - nl = nl+1 - do 90 n = nl-1, kl, -1 - text(n+1) = text(n) - 90 continue - text(kl)=card - kl = kl+1 - go to 60 - endif - go to 10 - end -c -cccccccccccccccccccccccccccccccccccccccccccccccccccc -c - subroutine endoc(lun) -c -c writes LaTeX document end to LUN from fortran programs. -c T. Mottershead AT-3 16 Jan 91 -c-------------------------------------------------- - write(lun,*) ' \end{document}' - return - end -c -*********************************************************************** -c - subroutine filin -c -c filin's job is to fill in /linbuf/ from the contents of -c a loop. Derived from wcl, written by Alex Dragt, 23 August 1988 -c Based on the SRs cqlate and pmif. WCL modified by F. Ner -c Dec 90 to fill LINBUF. That function of wcl save is this routine -c April 91, by T. Mottershead. -c - use beamdata - use acceldata - use lieaparam, only : monoms,monom1,monom2 - include 'impli.inc' - include 'linbuf.inc' - include 'actpar.inc' -c -c common blocks -c - include 'codes.inc' - include 'parset.inc' - include 'files.inc' - include 'loop.inc' - include 'core.inc' -c - dimension ltype(50) - data (ltype(j),j=1,25)/ - & 0,2,2,2,2, - & 2,3,2,1,0, - & 0,0,4,5,7, - & -1,7,1,7,6, - & 7,7,7,7,7/ - save ltype -c -c set parameter set to use (old=9, now pass in from caller CTM 5/00) -c -c npsu = 9 -c -c start routine by checking to see if a loop exists -c - if(nloop.le.0) then - write(jodf,*) ' error in filin: no loop in labor' - write(jof,*) ' error in filin: no loop in labor' - return - endif -c -c initialize linbuf pointers: -c - nbgn = 1 - nend = 0 - npst = 0 -c -c contents of biglist -c -c write(jodf,*) joy,' = joy in filin' - do 100 jj=1,joy - mmv = mim(jj) -c element - if(mmv.lt.0) then - ktyp = 1 - mnu = -mmv -c user supplied element - else if(mmv.gt.5000) then - ktyp = 1 - mnu = mmv-5000 -c lump - else - ktyp = 3 - endif -c write(jodf,*) ' filin: ',jj,'=jj',mmv,'=mim(jj)',mnu,'=mnu', -c * ktyp,'=ktyp' -c procedure for a menu item - if(ktyp.ne.1) go to 100 - imax=nrp(nt1(mnu),nt2(mnu)) - if(imax.eq.0)goto 100 -c -c reset default radius from pset(npsu) (T. Mottershead 23 Jan 91) -c keep all values from the same pset for other purposes, e.g. FOV calc -c (CTM 12/97) -c CTM 11/99: save all instances of npsu in linbuf for future use -c - if((nt1(mnu).eq.3).and.(nt2(mnu).eq.npsu)) then - aapar = pmenu(1+mpp(mnu)) - bbpar = pmenu(2+mpp(mnu)) - ccpar = pmenu(3+mpp(mnu)) - ddpar = pmenu(4+mpp(mnu)) - eepar = pmenu(5+mpp(mnu)) - ffpar = pmenu(6+mpp(mnu)) - npst = npst + 1 - aap(npst) = aapar - bbp(npst) = bbpar - ccp(npst) = ccpar - ddp(npst) = ddpar - eep(npst) = eepar - ffp(npst) = ffpar - endif -c -c Put simple element in linbuf (F. Neri 12/18/1990) -c - if (nt1(mnu).eq.1) then - lt = ltype(nt2(mnu)) - if(lt.eq.1.or.lt.eq.0) then - nend = nend+1 - cname(nend) = lmnlbl(mnu) - lintyp(nend) = lt - mltyp1(nend) = nt1(mnu) - mltyp2(nend) = nt2(mnu) - elong(nend) = pmenu(1+mpp(mnu)) - radius(nend) = aapar - strong(nend) = 0.d0 -c -c normal quad -c - if(nt2(mnu).eq.9) strong(nend) = pmenu(2+mpp(mnu)) -c -c quick & dirty fix for new cfqd (think again about when psets are exe -c - if(nt2(mnu).eq.18) then - ids = nint(pmenu(2+mpp(mnu))) - strong(nend) = pst(1,ids) - pssext(nend) = pst(3,ids) - psoctu(nend) = pst(5,ids) - endif - endif - endif - 100 continue - return - end -c -ccccccccccccccccc RMQUAD ccccccccccccccccccccccccccccccc -c - subroutine fvscan(wx,wy,aper,theta,xfov,yfov,kx,ky) - implicit double precision (a-h,o-z) - parameter (maxz=2000) - common/csrays/jp,mode,cx(maxz),sx(maxz),cy(maxz),sy(maxz) - & ,z(maxz) - write(6,*)'WARNING (fvscan): this routine has a different' - write(6,*)'declaration for common/csrays/ than in sincos.inc' - write(6,*)'Rob Ryne 7/23/2002' -c - eps = 1.0d-12 - xfov = 1.0d6 - yfov = xfov - do 100 k = 1,jp - denx = cx(k)+wx*sx(k) - deny = cy(k)+wy*sy(k) - if(dabs(denx).lt.eps) denx = eps - if(dabs(deny).lt.eps) deny = eps -c type *,k,denx,deny - biga = aper/denx - bigb = aper/deny - xbar = sx(k)*theta/denx - ybar = sy(k)*theta/deny - xsiz = dabs(biga+xbar) - if(xsiz.lt.xfov) then - xfov = xsiz - kx = k - endif - xsiz = dabs(biga-xbar) - if(xsiz.lt.xfov) then - xfov = xsiz - kx = k - endif - ysiz = dabs(bigb+ybar) - if(ysiz.lt.yfov) then - yfov = ysiz - ky = k - endif - ysiz = dabs(bigb-ybar) - if(ysiz.lt.yfov) then - yfov = ysiz - ky = k - endif - 100 continue - xfov = 200.0d0*xfov - yfov = 200.0d0*yfov - return - end -c-------------------------------------------------------------- - subroutine genray(wx,wy,lunz,npos,dx,dy,nang,dxp,dyp) -c -c generates matched ray initial conditions for a map -c and a set of scattered rays -c C. T. Mottershead LANL AOT-1 16 April 1996 -c------------------------------------------------------- - use rays - implicit double precision (a-h,o-z) - logical ltbl - include 'parset.inc' - dimension pp(6) - write(6,*) igen,' = igen, wx,wy=', wx,wy - zero = 0.0d0 - ltbl = .false. - if(lunz.gt.0) ltbl = .true. - do 10 j = 1,6 - pp(j) = zero - 10 continue - nn = 0 - do 100 i = 1, npos - fi = npos - i + 1 - x = fi*dx - xpref = x*wx - y = fi*dy - ypref = y*wy - pp(1) = x - pp(3) = y -c -c positive scattering angles -c - if(nang.ge.1) then - do 50 j = 1, nang - fj = nang - j + 1 - pp(2) = xpref + fj*dxp - pp(4) = ypref + fj*dyp - if(ltbl) write(lunz,57) pp - nn = nn + 1 - do 40 k = 1, 6 - zblock(nn,k) = pp(k) - 40 continue - 50 continue - endif -c -c central matched ray -c - pp(2) = xpref - pp(4) = ypref - if(ltbl) write(lunz,57) pp - nn = nn + 1 - do 60 k = 1, 6 - zblock(nn,k) = pp(k) - 60 continue - 57 format(1x,4(1pe13.5),2(1pe12.4)) -c -c negative scattering angles -c - if(nang.ge.1) then - do 80 j = 1, nang - fj = j - pp(2) = xpref - fj*dxp - pp(4) = ypref - fj*dyp - if(ltbl) write(lunz,57) pp - nn = nn + 1 - do 70 k = 1, 6 - zblock(nn,k) = pp(k) - 70 continue - 80 continue - endif - 100 continue -c -c on axis rays -c - pp(1) = zero - pp(3) = zero - if(nang.ge.1) then - do 120 j = 1, nang - fj = nang - j + 1 - pp(2) = fj*dxp - pp(4) = fj*dyp - if(ltbl) write(lunz,57) pp - nn = nn + 1 - do 110 k = 1, 6 - zblock(nn,k) = pp(k) - 110 continue - 120 continue - endif - pp(2) = zero - pp(4) = zero - if(ltbl) write(lunz,57) pp - nn = nn + 1 - do 140 k = 1, 6 - zblock(nn,k) = pp(k) - 140 continue - nrays = nn - write(6,147) npos,nang,nrays - 147 format(' #GENRAY:',i6,' positions',i6,' angles',i6,' rays') - return - end -c -*********************************************************************** -c - subroutine headoc(lun,title) -c -c writes LaTeX document header to LUN from fortran programs. -c -c T. Mottershead AT-3 16 Jan 91 -c-------------------------------------------------- - character title*(*) -c -c Write Document opening -c - write(lun,*) ' \documentstyle[12pt]{article} ' - write(lun,*) ' \setlength{\textwidth}{6.5in}' - write(lun,*) ' \setlength{\oddsidemargin}{0in} ' - write(lun,*) ' \setlength{\topmargin}{-0.5in}' - write(lun,*) ' \setlength{\textheight}{9in} \pagestyle{empty}' - write(lun,*) ' \begin{document}' - write(lun,*) ' ' - write(lun,*) ' {\large ' - write(lun,14) title - 14 format(' \begin{center} {\bf ',a,' } \\ - & \today \end{center} }') - return - end -c*************************************************************** - subroutine kinema(bmass,ener,pmom) - use beamdata - implicit double precision (a-h,o-z) -cryne 7/23/2002 common/parm/brho,c,gamma,gamm1,beta,charge,sl,ts,pbeam - two = 2.0d0 - light = 299792458 - fmev = 1.0d-6*float(light) - pmom = fmev*brho - gambet = dsqrt(gamm1*(gamm1+two)) - bmass = pmom/gambet - ener = gamm1*bmass - return - end -c----------------------------------------------------------------- - subroutine listyp(lun) -c -c listyp lists the type codes in the current vesion of marylie -c T. Mottershead LANL AT-3 17 Jan 91 -c------------------------------------------------- - include 'codes.inc' - character*8 tcode(9), word - dimension numcmd(9), nord(9), jlo(2),jhi(2) - data nord /1,4,7,8,9,2,3,5,6/ - save nord !cryne 7/23/2002 - jlo(1)=1 - jhi(1)=5 - jlo(2)=6 - jhi(2)=9 -c -c scan for null string to indicate number of commands -c - ntot = 0 - do 20 j = 1, 9 - max = 0 - do 10 n=1,40 - word = ltc(j,n) - if(ichar(word(1:1)).eq.0) go to 15 - max = max + 1 - 10 continue - 15 numcmd(j) = max - ntot = ntot + max - 20 continue -c -c report total -c - write(lun,*) ' Marylie Type Codes ' - write(lun,*) - write(lun,*) ntot,' type codes in this version' -c -c writeout -c - do 90 kk = 1,2 - jmin = jlo(kk) - jmax = jhi(kk) - nmax = 0 - do 30 j=jmin, jmax - mm = numcmd(nord(j)) - if(mm.gt.nmax) nmax = mm - 30 continue - write(lun,*) - write(lun,33) (nord(k),k=jmin,jmax) - 33 format(' index ',2x,5('nrp (G',i1,')',4x)) - do 50 n = 1 ,nmax - do 40 j=jmin, jmax - tcode(j) = ' ' - jju = nord(j) - if(n.le.numcmd(jju)) tcode(j) = ltc(jju,n) - 40 continue - write(lun,43) n,(nrp(nord(j),n), tcode(j), j=jmin,jmax) - 43 format(i4,5x,5(i2,2x,a8)) - 50 continue - write(lun,31) (numcmd(nord(j)), j=jmin, jmax) - 31 format(' total:',i8,4i12) - 90 continue - return - end -c -c******************************************************* - subroutine mlfov(wx,wy,aper,phiref,philim,lunf,ufov,kfov) - implicit double precision (a-h,o-z) - dimension ufov(*),kfov(*) - parameter (maxz=2000) - common/csrays/jp,mode,cx(maxz),sx(maxz),cy(maxz),sy(maxz) - & ,z(maxz) - logical ltbl, last -c - write(6,*)'WARNING (mlfov): this routine has a different' - write(6,*)'declaration for common/csrays/ than in sincos.inc' - write(6,*)'Rob Ryne 7/23/2002' -c -c write(99,*) ' MLFOV call:',jp,aper,philim,phiref,lunf - ltbl = .false. - last = .false. - if(lunf.gt.0) ltbl = .true. -c -c scan given sin/cosine rays for extrema -c -c type *, jp,'=jp in mlfov (length of S/C buffer)' - sxmax = 0.0d0 - cxlo = 1.0d30 - cxhi = -cxlo - symax = 0.0d0 - cylo = 1.0d30 - cyhi = -cylo - do 50 k = 1,jp - cc = cx(k) - ss = sx(k) - xmat = cc + wx*ss - if(xmat.gt.cxhi) cxhi = xmat - if(xmat.lt.cxlo) cxlo = xmat - sab = dabs(ss) - if(sab.gt.sxmax) sxmax = sab - cc = cy(k) - ss = sy(k) - ymat = cc + wy*ss - if(ymat.gt.cyhi) cyhi = ymat - if(ymat.lt.cylo) cylo = ymat - sab = dabs(ss) - if(sab.gt.symax) symax = sab - 50 continue -c type *, ' C+wS:',cxlo,cxhi,cylo,cyhi -c -c solve for envelope max -c - pxm = 1000.0d0*aper/sxmax - pym = 1000.0d0*aper/symax - if(ltbl) write(lunf,73) sxmax,symax, pxm, pym - 73 format(' Max S: ',2f13.5,' Max-phi(mR):',2f10.3) - phi = 0.0d0 - phimax = pxm - if(ltbl) write(lunf,506) - 506 format(' phi(mR) xfov yfov kx ky', - & 6x,'ysize+/-',10x,'xsize+/-') -c -c scan for FOV at the reference angle -c - xrefov = 0.0d0 - yrefov = 0.0d0 - if(phiref.lt.phimax) then - theta = 1.0d-3*phiref - call fvscan(wx,wy,aper,theta,xrefov,yrefov,kx,ky) - endif -c -c initialize search over all angles -c - kf = 0 - kx = 0 - ky = 0 - dphi = 0.05 - theta = 0.0d0 - eps = 1.0d-12 - 510 continue - kf = kf+1 - kxo = kx - kyo = ky - call fvscan(wx,wy,aper,theta,xfov,yfov,kx,ky) -c -c check size of other axis ellipse at limit points (kx,ky) -c - dyx = cy(kx) + wy*sy(kx) - if(dabs(dyx).lt.eps) dyx = eps - ayxm = 100.0d0*(aper - sy(kx)*theta)/dyx - ayxp = 100.0d0*(aper + sy(kx)*theta)/dyx - dxy = cx(ky) + wx*sx(ky) - if(dabs(dxy).lt.eps) dxy = eps - axym = 100.0d0*(aper - sx(ky)*theta)/dxy - axyp = 100.0d0*(aper + sx(ky)*theta)/dxy - phi = 1000.0d0*theta - ango = ang - xapo = xap - ang = phi - xap = xfov - if(ltbl) write(lunf,107) phi,xfov,yfov,kx,ky - & ,ayxm,ayxp,axym,axyp - 107 format(f7.2,2f9.4,2i5,4f9.3) - if(kf.eq.1) xzero = xfov - if((iabs(kxo-kx).gt.80).and.(iabs(ky-kyo).gt.80)) then - xfb = xapo - phib = ango - kxb = kx - kyb = ky - endif - if(last) then - radphi = phib/philim - bratio = zrad(radphi) - rmax = phimax/philim - radmax = zrad(rmax) -c type *, 'break ratios: phi,z ',phi, radphi, bratio -c type *, 'endpoint ratios: phi,z ',phimax,rmax,radmax - pipe = 200.0d0*aper - ufov(1) = pipe - ufov(2) = xzero - ufov(3) = xfb - ufov(4) = phib - ufov(5) = phimax - ufov(6) = bratio - ufov(7) = radmax - ufov(8) = sxmax - ufov(9) = symax - ufov(10)= pym - ufov(11)= xrefov - ufov(12)= yrefov - kfov(1) = kxb - kfov(2) = kyb - endif - phi = phi + dphi - theta = 1.0d-3*phi - if(last) return - if(phi.lt.phimax) go to 510 - phi = phimax - theta = 1.0d-3*phi - last = .true. - go to 510 - end -c-------------------------------------------------------------- - subroutine rmquad(zlen,grad,rm) -c -c computes matrix rm for a quadrupole of length zlen meters -c and with field gradient of grad tesla/meter -c if grad>0, the quad is horizontally focusing, vertically defocusin -c if grad<0, the quad is vertically focusing, horizontally defocusin -c If grad=0, it is simply a drift. -c T. Mottershead LANL AT-3, 10/89, copied from MARYLIE routines -c FQUAD and DQUAD by D. Douglas, 1982. -c------------------------------------------------------------------ - use beamdata - implicit double precision (a-h,o-z) -c -c beam and kinematic constants: -cryne 7/23/2002 common/parm/brho,c,gamma,gamm1,beta,achg,sl,ts - double precision rm(6,6) -c -c initialize rm to the identitiy matrix -c - do 40 i=1,6 - do 20 j=1,6 - rm(i,j)=0.0 - 20 continue - rm(i,i)=+1.0d0 - 40 continue -c -c add drift terms to rm -c - rm(1,2)= zlen - rm(3,4)= zlen - rm(5,6)= zlen/(gamma*beta)**2 -c -c drift return -c - if(grad.eq.0.0) return -c -c positive quad (horizontally focusing) -c - square = grad/brho - if(square.gt.0.0) then - ifp = 1 - jfp = 2 - idp = 3 - jdp = 4 - endif -c -c negative quad (horizontally defocusing) -c - if(square.lt.0.0) then - idp = 1 - jdp = 2 - ifp = 3 - jfp = 4 - square = -square - endif -c -c coefficients for transverse rm -c - wavek=dsqrt(square) - zk=zlen*wavek - coshkz=(dexp(zk)+dexp(-zk))/(2.0d0) - sinhkz=(dexp(zk)-dexp(-zk))/(2.0d0) - coskz=dcos(zk) - sinkz=dsin(zk) -c -c matrix in the focusing plane -c - rm(ifp,ifp) = coskz - rm(ifp,jfp) = sinkz/wavek - rm(jfp,jfp) = coskz - rm(jfp,ifp) = -wavek*sinkz -c -c matrix in the defocusing plane -c - rm(idp,idp) = coshkz - rm(idp,jdp) = sinhkz/wavek - rm(jdp,jdp) = coshkz - rm(jdp,idp) = wavek*sinhkz - return - end -c -*********************************************************************** -c - subroutine setcor(kor,wx,wy) - use lieaparam, only : monoms - include 'impli.inc' - include 'taylor.inc' - include 'map.inc' - include 'parset.inc' - include 'usrdat.inc' - zero = 0.0d0 - two = 2.0d0 -c -c No corr: Straight in -c - if(kor.eq.0) then - wx = zero - wy = zero - endif -c -c Fourier corr -c - if(kor.eq.1) then - wx = -tmh(1,1)/tmh(1,2) - wy = -tmh(3,3)/tmh(3,4) - endif -c -c Chromatic corr for identity lens -c - if(kor.eq.2) then - wx = -th(38)/(two*th(53)) - wy = -th(70)/(two*th(76)) - endif -c -c Chromatic corr in general from Taylor map -c - if(kor.eq.3) then - wx = -tumat(12,1)/tumat(17,1) - wy = -tumat(21,3)/tumat(24,3) - endif -c -c general correlation from ucalc(N) and N+1 -c - if(kor.lt.0) then - nc = -kor - if(nc.gt.250) return - wx = ucalc(nc) - wy = ucalc(nc+1) - endif - return - end -c========================================== - subroutine tabdef(lun,ncol) -c -c writes LaTeX table headers to LUN from fortran programs. -c T. Mottershead AT-3 16 Jan 91 -c-------------------------------------------------- - write(lun,*) ' \begin{center}' - write(lun,*) ' \begin{tabular}{',('|c',j=1,ncol),'|}' - write(lun,*) ' \hline' - return - end -c*************************************************************** - subroutine tabend(lun) -c -c writes LaTeX table end to LUN from fortran programs. -c T. Mottershead AT-3 16 Jan 91 -c-------------------------------------------------- - write(lun,*) ' \hline \end{tabular} \end{center}' - return - end -c*************************************************************** - subroutine tugen(fa,fm) -c pcmap routine to print m,f3,f4 and t,u. -c Written by D. Douglas ca 1982 and modified by Rob Ryne -c and Alex Dragt ca 1986 -ctm modified to just generate the taylor map in 'taylor.inc' -c - use lieaparam, only : monoms - include 'impli.inc' - include 'files.inc' - include 'expon.inc' - include 'pbkh.inc' - include 'taylor.inc' -c - dimension fa(monoms),fm(6,6),fsav(monoms) - dimension t(monoms),u(monoms),u2(monoms) - write(6,*)'inside routine tugen' -c -c prepare for higher order matrix generation -c - do 10 jj = 1, monoms - fsav(jj) = fa(jj) - 10 continue - call brkts(fa) -c -c procedure for generating t-matrix -c - do 35 i=1,6 - call xform(pbh(1,i),2,fm,i-1,t) - do 36 n=7,27 - tumat(n,i) = t(n) - 36 continue - 35 continue -c -c procedure for generating U-matrix -c - do 44 i=1,6 - call xform(pbh(1,i),3,fm,i-1,u) - call xform(pbh(1,i+6),3,fm,1,u2) - do 45 n=28,83 - u(n)=u(n)+u2(n)/2.d0 - tumat(n,i) = u(n) - 45 continue - 44 continue - return - end -c -c------------------------------------------------------ -c - subroutine u8out(lun,level) - use lieaparam, only : monoms - include 'impli.inc' - include 'usrdat.inc' - include 'sigbuf.inc' - character*3 tag - write(lun,21) - 21 format(/' Output beam parameters:',/,' x=u(1) ', - &' alfx=u(2) px=u(3) y=u(4) alfy=u(5) ', - &' py=u(6) ') - write(lun,25) (ucalc(j), j=1,6) - 25 format(6(1pe13.5)) - write(lun,22) - 22 format(6x,'beta',15x,'emittance',10x,'focus',14x,'cross-focus') - tag = ' X:' - write(lun,24) tag, (j,ucalc(j),j=7,10) - 24 format(a3,i3,'>',1pe14.7,3(i4,'>',1pe14.7)) - tag = ' Y:' - write(lun,24) tag, (j,ucalc(j),j=11,14) - if(level.lt.1) return -c -c also write aberration coefficients for level 1 -c - write(lun,27) - 27 format(/,' Chromatic and RMS Geometric Aberration Coefficients:', - &/,' dFx/dp=u(15) dFy/dp=u(16) K2(R/m^2)=u(17)', - &' K3(R/m^3)=u(18)') - write(lun,29) (ucalc(j),j=15,18) - 29 format(4(1pg18.7)) - if(level.lt.2) return -c -c also write dsigma/de for level 2 -c - write(lun,23) - 23 format(/' Energy dependence of sigma matrix:',/,' ds11=u(21)', - &' ds12=u(22) ds22=u(23) ds33=u(24) ds34=u(25)', - &' ds44=u(26)') - write(lun,25) (ucalc(j),j=21,26) -c write(lun,*) ' Sigma matrix:' -c do 201 i=1,4 -c write(lun,26) (sigf(i,j),j=1,4) -c 201 continue -c 26 format(3x,4(1pe15.7)) -c write(lun,*) ' Energy derivative of Sigma matrix:' -c do 202 i=1,4 -c write(lun,26) (dsig(i,j),j=1,4) -c 202 continue - return - end -c -*********************************************************************** -c - subroutine zmono(nopt,zz,zvec) - use lieaparam, only : monoms - include 'impli.inc' - include 'expon.inc' - include 'vblist.inc' - dimension zz(6) -cryne August 4, 2004 -cryne setting the following to 209 to reproduce old results. -cryne Extend later to 5th order -c dimension zvec(monoms) - dimension zvec(209) - write(6,*)'inside routine zmono' -c -c do 20 n = 1, monoms -c j = 1 -c kode = expon(j,n) -c 18 continue -c j = j + 1 -c kode = 10*kode + expon(j,n) -c if(j.lt.6) go to 18 -c write(89,19) n,kode,(expon(j,n),j=1,6),(vblist(k,n),k=1,4) -c 19 format(2i8,2x,6i2,' vb:',4i2) -c 20 continue - one = 1.0d0 - nord = 2 -cryne August 4, 2004 -cryne setting the following to 209 to reproduce old results. -cryne Extend later to 5th order -c do 100 n = 1, monoms - do 100 n = 1, 209 - if(n.eq.28) nord = 3 - if(n.eq.84) nord = 4 - prod = one - do 50 j = 1,nord - prod = prod*zz(vblist(j,n)) - 50 continue - zvec(n) = prod - 100 continue - return - end - double precision function zrad(radphi) - implicit double precision (a-h,o-z) - common/iters/it - zero = 0.0d0 - if(radphi.le.zero) then - zrad = zero - return - endif - tol = 1.0d-9 - derr = 1.0d9 - one = 1.0d0 - two = 2.0d0 - bb = 9.0d0*dlog(10.0d0) - aa = one/bb - bb = bb/two -c type *, ' aa=',aa,' bb=',bb - maxit=50 - y = radphi**2 - zest = y - do 80 j=1,maxit - it = j - vv = one+aa*dlog(zest) - yc = zest*(vv)**2 - err = yc-y -c type *,j,zest,err - errold = derr - derr = dabs(err) - if(derr.lt.tol) then - if(derr.ge.errold) go to 100 - endif - zest = (vv*zest+bb*y)/(vv*(one+bb*vv)) - 80 continue - 100 zrad = zest - return - end -c----------------------------------------------- - subroutine trcdmp(ltran,ltrace) - use beamdata - include 'impli.inc' - include 'linbuf.inc' - include 'actpar.inc' - include 'sigbuf.inc' - include 'usrdat.inc' - ntrc = ltrace-1 - write(ltran,*) '$data' - do 500 nn = nbgn, nend - nnu = nn + ntrc - tlong = 1000.0*elong(nn) -c -c drift -c - if(lintyp(nn).eq.0) then - ityp = 1 - write(ltran,488) nnu,cname(nn),nnu,ityp,nnu,tlong - endif -c -c quad -c - if(lintyp(nn).eq.1) then - ityp = 3 - write(ltran,488) nnu,cname(nn),nnu,ityp,nnu,strong(nn),tlong - endif - 488 format(1x,'cmt(',i3,')=''',a,''' nt(',i3,')=',i3,', a(1,',i3 - & ,')=',2(1pg17.9,',')) - 500 continue - write(ltran,*) '$end' - return - end -ccccccccccccccc++++++++++++++++++++++++++++c - subroutine adump(ldump) - use beamdata - include 'impli.inc' - include 'linbuf.inc' - include 'actpar.inc' - include 'sigbuf.inc' -c write(ldump,*) ' Beam:', beta, gamm1, brho -c write(ldump,*) ' Xsig:', xxin, axin, pxin -c write(ldump,*) ' Ysig:', yyin, ayin, pyin -c write(ldump,*) ' Zsig:', zzin, azin, pzin - write(ldump,*) beta, gamm1, brho - write(ldump,*) xxin, axin, pxin - write(ldump,*) yyin, ayin, pyin - write(ldump,*) zzin, azin, pzin - do 700 nn = nbgn, nend - write(ldump,617) cname(nn),nn,lintyp(nn),mltyp1(nn),mltyp2(nn), - & radius(nn), elong(nn), strong(nn) - 617 format(2x,a8,i4,3i3,2f12.7,1pg24.16) - 700 continue - return - end -c-------------------------- - subroutine trnspt(ltran) - return - end - subroutine madump(ltran) - return - end diff --git a/OpticsJan2020/MLI_light_optics/Src/wakefld.f b/OpticsJan2020/MLI_light_optics/Src/wakefld.f deleted file mode 100644 index 28363e3..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/wakefld.f +++ /dev/null @@ -1,1732 +0,0 @@ -! wakefld.f -! -! Contains subroutines for computing wakefield forces -! written by Roman Samulyak (BNL), July 2002 -! rosamu@bnl.gov, (631) 344-3304 -! -!*********************************************************************** - module wakefld_params - double precision :: z0 = 377.0 ! Free space impedance - - character*8 :: wktype !Wakefield type - -! Global defaults - integer :: gnmodes !Number of modes - integer :: nturns !Number of turns for collecting - !wakefield forces (long range wakes) - double precision :: gcond !Conductivity - double precision :: gradius !Average radius of chamber elements - - -! elements creating wake fields - - type WKFLD_WALL - double precision :: length - double precision :: conduct - double precision :: radius - integer :: nmodes - end type WKFLD_WALL - - type WKFLD_RLC - double precision, dimension(6) :: res_fr - double precision, dimension(6) :: r_shunt - double precision, dimension(6) :: quality - integer :: nmodes - end type WKFLD_RLC - - type WKFLD_PILLBOX - double precision, dimension(3) :: length - double precision, dimension(3) :: depth - double precision, dimension(3) :: radius - integer :: nmodes - end type WKFLD_PILLBOX - - type WKFLD_DATAFILE - character*31 :: fname - integer :: nmodes - end type WKFLD_DATAFILE - - type(WKFLD_WALL), dimension(100) :: rwall_param - type(WKFLD_RLC), dimension(100) :: rlc_param - type(WKFLD_PILLBOX), dimension(100) :: pbx_param - type(WKFLD_DATAFILE), dimension(100) :: file_param - - integer :: nrwall = 0 ! Order number of rwall element model - integer :: nrlc = 0 ! Order number of rlc element model - integer :: npbx = 0 ! Order number of pbx element model - integer :: nfile = 0 ! Order number of datafile element - - integer :: ncurel = 0 ! Order number of the current wakefield -! element in the ring - integer :: nwkel = 0 ! total number of wakefield el. in the list - character*8, dimension(500) :: wk_el_list ! contains element names - integer, dimension(500,3) :: wkfld_work -! wkfld_work(i,j) : -! i = element # in the list of elements creating wakes -! wkfld_work(i,1) : model # for ith elemnt: -! 0 = read wake function data from file -! 1 = res. wall -! 2 = rlc resonator -! 3 = pbx model -! 4 = -! wkfld_work(i,2) : element # in this group of elements -! wkfld_work(i,3) : # of modes for this el. - - -! variables used for the beam moments calculation - double precision, dimension(:,:), allocatable :: moments - double precision, dimension(:,:,:), allocatable :: density - type LOCAL_COORD - double precision :: x - integer :: k - integer :: nn ! entry # in the moments array - end type LOCAL_COORD - type(LOCAL_COORD) :: lcoord - - type WKGRID - integer :: nx,ny,nz ! the number of nodes. -! users should enter number of mesh cells (2^n numbers) -! number of nodes = number of mesh cells + 1 - double precision :: hx,hy,hz - double precision :: xmin,xmax,ymin,ymax,zmin,zmax - integer :: ndx,ndy ! number of subdomains in x and y directions - end type WKGRID - type(WKGRID) :: grid - -! variables used for wake field force calculation - double precision, dimension(:,:,:), allocatable :: wkfx,wkfy,wkfz - double precision,dimension(:,:,:),allocatable::lwkfx,lwkfy,lwkfz - -! an array for tabulated wake function values - double precision, dimension(:,:), allocatable :: wkfunc_table - -! temp arrays needed to deposit particles on the grid and interp. fields - double precision, dimension(:,:), allocatable :: p_data - integer, dimension(:), allocatable :: indx,jndx,kndx - integer, dimension(:), allocatable :: indxp1,jndxp1,kndxp1 - double precision, dimension(:), allocatable :: ab,de,gh - logical, dimension(:), allocatable :: msk - integer :: flg - - save - - end module wakefld_params - -!*********************************************************************** - - subroutine wake_defaults(line) - - use wakefld_params, only: wktype,gnmodes,nturns,gradius,gcond,grid - use parallel, only : nvp,idproc !cryne - - character*80 :: line - character*16 :: cbuf - logical keypres, numpres - double precision, dimension(1) :: bufr - integer :: mmax - mmax=80 - - call getparm(line,mmax,'type=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - wktype=cbuf - endif - - call getparm(line,mmax,'nmodes=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - gnmodes=int(bufr(1)) - endif - - call getparm(line,mmax,'nturns=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - nturns=int(bufr(1)) - endif - - call getparm(line,mmax,'r=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - gradius=bufr(1) - endif - - call getparm(line,mmax,'conduct=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - gcond=bufr(1) - endif -! another name - call getparm(line,mmax,'cond=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - gcond=bufr(1) - endif - -! new line containinf wakefield grid parameters - call readin(line,leof) - - call getparm(line,mmax,'nx=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - grid%nx=int(bufr(1))+1 - endif - - call getparm(line,mmax,'ny=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - grid%ny=int(bufr(1))+1 - endif - - call getparm(line,mmax,'nz=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - grid%nz=int(bufr(1))+1 - endif - - call getparm(line,mmax,'ndx=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - grid%ndx=int(bufr(1)) - endif - - call getparm(line,mmax,'ndy=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - grid%ndy=int(bufr(1)) - endif -!cryne--- - if(grid%ndx*grid%ndy.ne.nvp)then - if(idproc.eq.0)then - write(6,*)'ERROR (in wake_defaults) : ndx*ndy .ne. nvp' - write(6,*)'ndx, ndy, nvp = ',grid%ndx,grid%ndy,nvp - write(6,*)'Halting.' - endif - call myexit - endif -!cryne--- - - return - end subroutine wake_defaults - -!*********************************************************************** - - subroutine wake_init(cbufin) - - use wakefld_params - use acceldata - include 'files.inc' - - character*16 :: cbufin, cbuf - integer :: mmax, i - double precision, dimension(1) :: bufr - logical keypres, numpres, leof - character*80 :: line - double precision :: l,r,sigma - mmax=80 - nwkel=nwkel+1 - - if ((cbufin.eq.'rwall').or.(cbufin.eq.'res_wall')) then - go to 110 - elseif (cbufin.eq.'rlc') then - go to 120 - elseif ((cbufin.eq.'pillbox').or.(cbufin.eq.'pbx')) then - go to 130 - elseif ((cbufin.eq.'datafile').or.(cbufin.eq.'file')) then - go to 140 - else - write(6,*)'Wakefield model',cbufin,'is not supported' - call myexit - endif - -!*** res_wall -! Input format: -! wakedata: nmodes= l= r= conduct= - - 110 nrwall = nrwall+1 - backspace lf -! Defaults: - call readin(line,leof) - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - rwall_param(nrwall)%length=bufr(1) - endif - rwall_param(nrwall)%nmodes = gnmodes - rwall_param(nrwall)%radius = gradius - rwall_param(nrwall)%conduct = gcond - - wk_el_list(nwkel) = lmnlbl(na) - wkfld_work(nwkel,1) = 1 - wkfld_work(nwkel,2) = nrwall - wkfld_work(nwkel,3) = gnmodes - -! End defaults - - call readin(line,leof) - if(line(1:9) .ne. 'wakedata:')then - write(6,*)'No user specified wakefield data. Using defaults' - backspace lf - return - endif - - call getparm(line,mmax,'nmodes=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - rwall_param(nrwall)%nmodes=int(bufr(1)) - endif - - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - rwall_param(nrwall)%length=bufr(1) - endif - - call getparm(line,mmax,'r=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - rwall_param(nrwall)%radius=bufr(1) - endif - - call getparm(line,mmax,'conduct=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - rwall_param(nrwall)%conduct=bufr(1) - endif - - wkfld_work(nwkel,3) = rwall_param(nrwall)%nmodes - - if (ibrief.eq.2) then - write(6,*)'\n Initialized parameters for rwall:' - write(6,*)'nrwall = ',nrwall - write(6,*)'nmodes = ',rwall_param(nrwall)%nmodes - write(6,*)'l = ',rwall_param(nrwall)%length - write(6,*)'r = ',rwall_param(nrwall)%radius - write(6,*)'conduct = ',rwall_param(nrwall)%conduct,'\n' - endif - return - -!*** rlc -! Input format: -! wakedata: nmodes= -! mode0: fr= q= r= -! mode1: fr= q= r= -! ............ -! the word 'mode' is optional - - 120 nrlc = nrlc + 1 - call readin(line,leof) - if(line(1:9) .ne. 'wakedata:')then - write(6,*)'\n Error:' - write(6,*)'There are no defaults for rlc wakefield model.' - write(6,*)'Please enter wakefield model data: ' - write(6,*)'the number of modes and the resonant frequency, ' - write(6,*)'shunt impedance, and quality factor for each mode' - write(6,*)'in the following format' - write(6,*)'wakedata: nmodes= ' - write(6,*)'mode0: fr= q= r=' - write(6,*)'mode1: fr= q= r=' - write(6,*)' ............\n' - call myexit - return - endif - -! If there is wake data, get the number of modes - call getparm(line,mmax,'nmodes=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - rlc_param(nrlc)%nmodes=int(bufr(1)) - endif - -! Get parameters for each mode - do i=1,rlc_param(nrlc)%nmodes - call readin(line,leof) - - call getparm(line,mmax,'fr=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - rlc_param(nrlc)%res_fr(i)=bufr(1) - endif - - call getparm(line,mmax,'r=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - rlc_param(nrlc)%r_shunt(i)=bufr(1) - endif - - call getparm(line,mmax,'q=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - rlc_param(nrlc)%quality(i)=bufr(1) - endif - enddo - - wk_el_list(nwkel) = lmnlbl(na) - wkfld_work(nwkel,1) = 2 - wkfld_work(nwkel,2) = nrlc - wkfld_work(nwkel,3) = rlc_param(nrlc)%nmodes - - if (ibrief.eq.2) then - write(6,*)'\n Initialized parameters for rlc:' - write(6,*)'nrlc = ',nrlc, 'nmodes = ',rlc_param(nrlc)%nmodes - write(6,*)'fr = ',rlc_param(nrlc)%res_fr(1:rlc_param(nrlc)%nmodes) - write(6,*)'R = ',rlc_param(nrlc)%r_shunt(1:rlc_param(nrlc)%nmodes) - write(6,*)'Q = ',rlc_param(nrlc)%quality(1:rlc_param(nrlc)%nmodes) - write(6,*)'\n' - endif - return - -!*** pillbox -! Input format: -! wakedata: nmodes= -! mode0: l= h= r= -! mode1: l= h= r= -! ............ -! the word 'mode' is optional - - 130 npbx = npbx + 1 - call readin(line,leof) - if(line(1:9) .ne. 'wakedata:')then - write(6,*)'\n Error:' - write(6,*)'There are no defaults for pillbox wakefield model.' - write(6,*)'Please enter wakefield model data: ' - write(6,*)'the number of modes and the length, depth,' - write(6,*)'and radius for each mode in the following format' - write(6,*)'wakedata: nmodes= ' - write(6,*)'mode0: l= h= r= ' - write(6,*)'mode1: l= h= r= ' - write(6,*)' ............\n' - call myexit - return - endif - -! If there is wake data, get the number of modes - call getparm(line,mmax,'nmodes=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pbx_param(npbx)%nmodes=int(bufr(1)) - endif - -! Get parameters for each mode - do i=1,pbx_param(npbx)%nmodes - call readin(line,leof) - call getparm(line,mmax,'l=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pbx_param(npbx)%length(i)=bufr(1) - endif - - call getparm(line,mmax,'r=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pbx_param(npbx)%radius(i)=bufr(1) - endif - - call getparm(line,mmax,'h=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - pbx_param(npbx)%depth(i)=bufr(1) - endif - enddo - - wk_el_list(nwkel) = lmnlbl(na) - wkfld_work(nwkel,1) = 3 - wkfld_work(nwkel,2) = npbx - wkfld_work(nwkel,3) = pbx_param(npbx)%nmodes - - if (ibrief.eq.2) then - write(6,*)'\n Initialized parameters for pillbox:' - write(6,*)'npbx = ',npbx, 'nmodes = ',pbx_param(npbx)%nmodes - write(6,*)'l = ',pbx_param(npbx)%length(1:pbx_param(npbx)%nmodes) - write(6,*)'r = ',pbx_param(npbx)%radius(1:pbx_param(npbx)%nmodes) - write(6,*)'h = ',pbx_param(npbx)%depth(1:pbx_param(npbx)%nmodes) - write(6,*)'\n' - endif - - return - -!*** datafile -! Input format: -! wakedata: file=file_name nmodes=number_of_modes - - 140 nfile = nfile + 1 - call readin(line,leof) - if(line(1:9) .ne. 'wakedata:')then - write(6,*)'\n Error:' - write(6,*)'There are no defaults for tabulated wakefield data.' - write(6,*)'Please enter the file name and the number of modes' - write(6,*)'in the following format' - write(6,*)'wakedata: file=file_name nmodes=number_of_modes\n' - call myexit - return - endif -! If there is wake data, get parameters - call getparm(line,mmax,'file=',bufr,keypres,numpres,1,cbuf) - if(keypres.and.numpres)then - file_param(nfile)%fname=cbuf - endif - - call getparm(line,mmax,'nmodes=',bufr,keypres,numpres,0,cbuf) - if(keypres.and.numpres)then - file_param(nfile)%nmodes=int(bufr(1)) - endif - - wk_el_list(nwkel) = lmnlbl(na) - wkfld_work(nwkel,1) = 0 - wkfld_work(nwkel,2) = nfile - wkfld_work(nwkel,3) = file_param(nfile)%nmodes - - if (ibrief.eq.2) then - write(6,*)'\nInitialized parameters for tabulated wakefield data:' - write(6,*)'nfile = ',nfile - write(6,*)'file name = ',file_param(nfile)%fname - write(6,*)'nmodes = ',file_param(nfile)%nmodes,'\n' - endif - - return - - end subroutine wake_init - - -!*********************************************************************** - - subroutine wkfld_srange(nslices,elname,tau) - - use wakefld_params, only: wktype,ncurel,nwkel,wk_el_list - - integer :: nslices, i - character*8 :: elname - double precision :: tau - - if (wktype.ne.'short') return - -! Identify the current element - do ncurel=1,nwkel - if (elname .eq. wk_el_list(ncurel)) exit - enddo - - call initialize_wk_structures - call compute_beam_moments - call compute_wk_forces - call apply_wk_forces(tau) - call free_wk_structures - - end subroutine wkfld_srange - -!*********************************************************************** - - subroutine initialize_wk_structures - - use wakefld_params - use rays, only : nraysp,maxrayp - - implicit double precision(a-h,o-z) - integer :: nx,ny,nz,nmodes,j -! common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0,nspchset - - nx = grid%nx - ny = grid%ny - nz = grid%nz - - allocate(density(nx,ny,nz)) - allocate(p_data(6,nraysp)) - - nmodes = wkfld_work(ncurel,3) - allocate(moments(nz,2*nmodes+1)) - - allocate(wkfx(nx,ny,nz)) - allocate(wkfy(nx,ny,nz)) - allocate(wkfz(nx,ny,nz)) - - allocate(indx(nraysp)) - allocate(jndx(nraysp)) - allocate(kndx(nraysp)) - allocate(indxp1(nraysp)) - allocate(jndxp1(nraysp)) - allocate(kndxp1(nraysp)) - allocate(ab(nraysp)) - allocate(de(nraysp)) - allocate(gh(nraysp)) - allocate(msk(maxrayp)) - - end subroutine initialize_wk_structures - -!*********************************************************************** - - subroutine free_wk_structures - - use wakefld_params - - deallocate(density) - deallocate(moments) - deallocate(p_data) - deallocate(wkfx) - deallocate(wkfy) - deallocate(wkfz) - - deallocate(indx) - deallocate(jndx) - deallocate(kndx) - deallocate(indxp1) - deallocate(jndxp1) - deallocate(kndxp1) - deallocate(ab) - deallocate(de) - deallocate(gh) - deallocate(msk) - - end subroutine free_wk_structures - -!*********************************************************************** - - subroutine wkfld_lrange - - use wakefld_params - - if (wktype.ne.'long') return - - end subroutine wkfld_lrange - -!*********************************************************************** -! INTEGRATOR - - subroutine compute_beam_moments - - use wakefld_params - use rays, only : zblock,nraysp,maxrayp - use beamdata - use parallel - - double precision,dimension(:,:,:), allocatable :: dens_local - double precision, dimension(:,:), allocatable :: mom_local - integer :: i,j,nx,ny,nz,nmodes,nz_start,nz_end,n_zone,noresize - double precision :: ss,bbyk,gblam - double precision :: xmin,xmax,ymin,ymax,zmin,zmax - double precision :: hx,hy,hz,hxi,hyi,hzi - double precision :: toopi,c5j,ac5j - - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi -! common/nxyzsave/nxsave,nysave,nzsave,noresize,nadj0,nspchset - - external ysimpsonint - - nmodes = wkfld_work(ncurel,3) - nx = grid%nx - ny = grid%ny - nz = grid%nz - - allocate(dens_local(nx,ny,nz)) - allocate(mom_local(nz,2*nmodes+1)) - - bbyk = gamma*beta*c/omegascl - gblam = gamma*beta*c/bfreq - - noresize = 1 - - do j = 1,nraysp - p_data(1,j) = zblock(1,j) - p_data(2,j) = zblock(2,j) - p_data(3,j) = zblock(3,j) - p_data(4,j) = zblock(4,j) - p_data(5,j) = zblock(5,j) - p_data(6,j) = zblock(6,j) - enddo - -! if(nadj0.ne.0)then -! toopi=4.d0*asin(1.d0) -! do j=1,nraysp -! c5j=p_data(5,j) -! ac5j=abs(c5j) -! if(c5j.gt.0.)p_data(5,j)=mod(c5j,toopi) -! if(c5j.lt.0.)p_data(5,j)=toopi-mod(ac5j,toopi) -! enddo! -! -!c place the value which is in(-pi,pi) back in the zblock array: -! do j=1,nraysp -! zblock(5,j)=p_data(5,j)-0.5d0*toopi -! enddo -! endif - -c convert phase to z (bbyk) and transform to the beam frame (gamma) -c also multiply by scale length (sl) to convert x and y to units of meters - do j=1,nraysp - p_data(5,j)=p_data(5,j)*gamma*bbyk - p_data(1,j)=p_data(1,j)*sl - p_data(3,j)=p_data(3,j)*sl - enddo - -c mask off lost particles - do j=1,nraysp - msk(j)=.true. - enddo - if(nraysp.lt.maxrayp)then - do j=nraysp+1,maxrayp - msk(j)=.false. - enddo - endif - - call setbound(p_data,msk,nraysp,gblam,gamma,nx,ny,nz,noresize,0) - - grid%xmin = xmin - grid%xmax = xmax - grid%ymin = ymin - grid%ymax = ymax - grid%zmin = zmin - grid%zmax = zmax - grid%hx = (xmax - xmin)/(nx - 1) - grid%hy = (ymax - ymin)/(ny - 1) - grid%hz = (zmax - zmin)/(nz - 1) - -! Deposit local chunk of particles on every processor on the entire grid - call rhoslo3d_loc(p_data,dens_local,msk,nraysp,ab,de,gh,indx,jndx,& - &kndx,indxp1,jndxp1,kndxp1,nx,ny,nz,0) - call MPI_ALLREDUCE(dens_local,density,nx*ny*nz,mreal,mpisum, & - &lworld,ierror) - - n_zone = int(nz/nvp) - nz_start = 1 + n_zone*idproc - nz_end = n_zone*(idproc + 1) - if (idproc .eq. nvp - 1) nz_end = nz - - do i = nz_start,nz_end - lcoord%k = i - do j = 1, 2*nmodes+1 - lcoord%nn = j - call qsimpsonx(ysimpsonint,xmin,xmax,ss) - mom_local(i,j) = ss - enddo - enddo - - call MPI_ALLREDUCE(mom_local,moments,nz*(2*nmodes+1),mreal,mpisum,& - &lworld,ierror) - - deallocate(dens_local) - deallocate(mom_local) - - return - end subroutine compute_beam_moments - -!*********************************************************************** - - function ysimpsonint(xx) - - use wakefld_params - implicit double precision(a-h,o-z) - - external func_rho - ymin = grid%ymin - ymax = grid%ymax - - lcoord%x = xx - call qsimpsony(func_rho,ymin,ymax,sst) - ysimpsonint = sst - - return - end function ysimpsonint - -!*********************************************************************** - - function func_rho(yy) - - use wakefld_params, only: grid, lcoord, density - implicit double precision(a-h,o-z) - integer i,j,k - - xmin = grid%xmin - xmax = grid%xmax - ymin = grid%ymin - ymax = grid%ymax - hx = grid%hx - hy = grid%hy - - xx = lcoord%x - i = int((xx - xmin)/hx) + 1 - j = int((yy - ymin)/hy) + 1 - k = lcoord%k - -! mode # 0 - if (lcoord%nn .eq. 1) then - func_rho = density(i,j,k) - endif -! mode # 1 - if (lcoord%nn .eq. 2) then - func_rho = density(i,j,k)*xx - endif - - if (lcoord%nn .eq. 3) then - func_rho = density(i,j,k)*yy - endif -! mode # 2 - if (lcoord%nn .eq. 4) then - func_rho = density(i,j,k)*(xx**2 - yy**2) - endif - - if (lcoord%nn .eq. 5) then - func_rho = density(i,j,k)*2*xx*yy - endif -! mode # 3 - if (lcoord%nn .eq. 6) then - func_rho = density(i,j,k)*(xx**3 - 3*xx*yy**2) - endif - - if (lcoord%nn .eq. 7) then - func_rho = density(i,j,k)*(3*xx**2*yy - yy**3) - endif -! mode # 4 - if (lcoord%nn .eq. 8) then - func_rho = density(i,j,k) - endif - - if (lcoord%nn .eq. 9) then - func_rho = density(i,j,k) - endif -! mode # 5 - if (lcoord%nn .eq. 10) then - func_rho = density(i,j,k) - endif - - if (lcoord%nn .eq. 11) then - func_rho = density(i,j,k) - endif - - - if (lcoord%nn .gt. 11) then - write(6,*)'Error in the beam moment computation:' - write(6,*)'only 5 modes are supported' - call myexit - endif - - return - end function func_rho - -!*********************************************************************** - - subroutine qsimpsonx(function,start,end,dint) - - implicit double precision(a-h,o-z) - integer :: j,jmax - external function - - eps=1.e-9 - jmax = 10 - ost=-1.e30 - os =-1.e30 - - do j=1,jmax - call trapzdx(function,start,end,st,j) - dint=(4.*st-ost)/3. - if (abs(dint-os) .lt. eps*abs(os)) return - if (dint .eq. 0. .and. os .eq. 0. .and. j .gt. 6) return - os = dint - ost = st - enddo - end subroutine qsimpsonx - -!*********************************************************************** - - subroutine qsimpsony(function,start,end,dint) - - implicit double precision(a-h,o-z) - integer :: j,jmax - external function - - eps=1.e-9 - jmax = 10 - ost=-1.e30 - os =-1.e30 - - do j=1,jmax - call trapzdy(function,start,end,st,j) - dint=(4.*st-ost)/3. - if (abs(dint-os) .lt. eps*abs(os)) return - if (dint .eq. 0. .and. os .eq. 0. .and. j .gt. 6) return - os = dint - ost = st - enddo - end subroutine qsimpsony - -!*********************************************************************** - - subroutine trapzdx(func,a,b,s,n) - - implicit double precision(a-h,o-z) - integer :: n,it,j - external func - - if (n .eq. 1) then - s = 0.5*(b-a)*(func(a)+func(b)) - else - it = 2**(n-2) - tnm = it - del = (b-a)/tnm - x = a+0.5*del - sum = 0. - do j = 1,it - sum = sum + func(x) - x = x +del - enddo - s = 0.5*(s+(b-a)*sum/tnm) - endif - return - end subroutine trapzdx - -!*********************************************************************** - - subroutine trapzdy(func,a,b,s,n) - - implicit double precision(a-h,o-z) - integer :: n,it,j - external func - - if (n .eq. 1) then - s = 0.5*(b-a)*(func(a)+func(b)) - else - it = 2**(n-2) - tnm = it - del = (b-a)/tnm - x = a+0.5*del - sum = 0. - do j = 1,it - sum = sum + func(x) - x = x +del - enddo - s = 0.5*(s+(b-a)*sum/tnm) - endif - return - end subroutine trapzdy - -!*********************************************************************** - - subroutine compute_wk_forces - - use wakefld_params - use parallel - -! 2d domain decomposition in x-y plane. ndx, ndy = number of subdomains -! in x and y directions (declared in wakefld_params) -! nxst,nxend,nyst,nyend = start and end grid nodes in x and y directions -! nnx,nny = number of grids in x and y directions -! ii,jj = indices of subdomains: -! -! ---------------------|-------------------- -! idproc = 4 | idproc = 5 -! | -! ii = 1, jj = 3 | ii = 2, jj = 3 -! ---------------------|-------------------- -! idproc = 2 | idproc = 3 -! | -! ii = 1, jj = 2 | ii = 2, jj = 2 -! ---------------------|-------------------- -! idproc = 0 | idproc = 1 -! | -! ii = 1, jj = 1 | ii = 2, jj = 1 -! ---------------------|-------------------- -! - - double precision :: rho, z - integer :: nxst,nxend,nyst,nyend,ii,jj,nnx,nny - integer :: i,j,k1,k2,nx,ny,nz,nm - - nx = grid%nx - ny = grid%ny - nz = grid%nz - hz = grid%hz - ndx = grid%ndx - ndy = grid%ndy - - allocate(lwkfx(nx,ny,nz)) - allocate(lwkfy(nx,ny,nz)) - allocate(lwkfz(nx,ny,nz)) - - jj = int(idproc/ndx) + 1 - ii = idproc - (jj - 1)*ndx + 1 - nnx = int(nx/ndx) - nny = int(ny/ndy) - - nxst = 1 + (ii - 1)*nnx - nxend = ii*nnx - if(ii .eq. ndx) nxend = nx - - nyst = 1 + (jj - 1)*nny - nyend = jj*nny - if (jj .eq. ndy) nyend = ny - - do k1 = 1,nz - do j = nyst,nyend - do i = nxst,nxend - -! For every grid point include wake fields created by -! particles in the head of the bunch - do k2 = k1,nz - z = (k1 - k2)*hz - rho = density(i,j,k1) - nm = wkfld_work(ncurel,3) - - if (wkfld_work(ncurel,1) .eq. 0) then - call compute_wkfrc_from_table - elseif (wkfld_work(ncurel,1) .eq. 1) then - call compute_wkfrc_reswall(rho,z,i,j,k1,k2,nm) - elseif (wkfld_work(ncurel,1) .eq. 2) then - call compute_wkfrc_rlc(rho,z,i,j,k1,k2,nm) - elseif (wkfld_work(ncurel,1) .eq. 3) then - call compute_wkfrc_pbx(rho,z,i,j,k1,k2,nm) - else - write(6,*)'Error in compute_wk_forces:' - write(6,*)'unimplemented wakefield model' - call myexit - endif - enddo - - enddo - enddo - enddo - - - call MPI_ALLREDUCE(lwkfx,wkfx,nx*ny*nz,mreal,mpisum,lworld,ierror) - call MPI_ALLREDUCE(lwkfy,wkfy,nx*ny*nz,mreal,mpisum,lworld,ierror) - call MPI_ALLREDUCE(lwkfz,wkfz,nx*ny*nz,mreal,mpisum,lworld,ierror) - - deallocate(lwkfx) - deallocate(lwkfy) - deallocate(lwkfz) - - ncurel = ncurel + 1 - if (ncurel .gt. nwkel) then - ncurel = 1 - endif - return - end subroutine compute_wk_forces - -!*********************************************************************** - - - subroutine apply_wk_forces(tau) - - use wakefld_params, only: wkfx,wkfy,wkfz,ab,de,gh,indx,jndx,kndx, & - &msk,indxp1,jndxp1,kndxp1,grid - use rays, only: zblock, nraysp - use beamdata - - double precision, dimension (:), allocatable :: fx,fy,fz - double precision :: tau,fourpi,perv,xycon,tcon,ratio3,gbi,fpei - integer :: j - - allocate(fx(nraysp)) - allocate(fy(nraysp)) - allocate(fz(nraysp)) - - nx = grid%nx - ny = grid%ny - nz = grid%nz - -! Interpolate forces to positions of particles - - call ntrslo3d_loc(wkfx,wkfy,wkfz,fx,fy,fz,msk,ab,de,gh,indx,jndx, & - &kndx,indxp1,jndxp1,kndxp1,nx,ny,nz,nraysp) - - fpei=c*c*1.d-7 - perv=2.d0*bcurr*fpei/(brho*beta*beta*c*c*gamma*gamma) - fourpi=8.d0*(asin(1.d0)) - xycon=fourpi*0.5*perv*gamma*beta*(beta*c/bfreq) - tcon=beta*xycon*gamma**2 - ratio3=omegascl*sl/299792458.d0 - tcon=tcon/ratio3 - - gbi=1./(gamma*beta) - - if(lflagmagu)then - xycon=xycon*gbi - tcon=tcon*gbi - endif - - open(77,file='wake_data') - - do j=1,nraysp - - write(77,88)zblock(2,j),tau*xycon*fx(j),zblock(4,j), & - & xycon*fy(j),zblock(6,j),tau*tcon*fz(j) - 88 format(6d12.3) - - zblock(2,j)=zblock(2,j) + tau*xycon*fx(j) - zblock(4,j)=zblock(4,j) + tau*xycon*fy(j) - zblock(6,j)=zblock(6,j) + tau*tcon*fz(j) - enddo - - deallocate(fx) - deallocate(fy) - deallocate(fz) - - end subroutine apply_wk_forces - -!*********************************************************************** - - subroutine compute_wkfrc_reswall(rho,z,ii,jj,kk1,kk2,nmod) - -! Computes wake forces acting on the test particle due to wake wields -! created by the source particle using the resistive wake field model -! Writes forces to arrays lwkfx,lwkfy,lwkfz in wakefld_params.mod -! -! z is the distance between the source and test particles -! ii,jj,kk1 are discrete coordinates of the test particle -! kk2 is the discrete z coord. of the source particle -! nmod is the number of modes - - use wakefld_params - implicit double precision(a-h,o-z) - integer ii,jj,kk1,kk2,nmod,nrw - - x = grid%xmin + grid%hx*(ii-1) - y = grid%ymin + grid%hy*(jj-1) - - nrw = wkfld_work(ncurel,2) - call wkfunction_rwall(z,1,1,nrw,wkfl) - lwkfx(ii,jj,kk1) = 0. - lwkfy(ii,jj,kk1) = 0. - lwkfz(ii,jj,kk1) = -moments(kk2,1)*wkfl - - if (nmod .gt. 1) then - call wkfunction_rwall(z,2,0,nrw,wkft) - call wkfunction_rwall(z,2,1,nrw,wkfl) - - lwkfx(ii,jj,kk1) = -moments(kk2,2)*wkft - - lwkfy(ii,jj,kk1) = -moments(kk2,3)*wkft - - lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & - & wkfl*(x*moments(kk2,2) + y*moments(kk2,3)) - endif - - if (nmod .gt. 2) then - call wkfunction_rwall(z,3,0,nrw,wkft) - call wkfunction_rwall(z,3,1,nrw,wkfl) - - lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & - & 2*wkft*(x*moments(kk2,4) + y*moments(kk2,5)) - - lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & - & 2*wkft*(-y*moments(kk2,4) + x*moments(kk2,5)) - - lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & - & wkfl*((x**2-y**2)*moments(kk2,4)+2*x*y*moments(kk2,5)) - endif - - if (nmod .gt. 3) then - call wkfunction_rwall(z,4,0,nrw,wkft) - call wkfunction_rwall(z,4,1,nrw,wkfl) - - lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & - & 3*wkft*((x**2-y**2)*moments(kk2,6)+2*x*y*moments(kk2,7)) - - lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & - & 3*wkft*(-2*x*y*moments(kk2,6)+(x**2-y**2)*moments(kk2,7)) - - lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & - & wkfl*((x**3-3*x*y**2)*moments(kk2,6) + & - & (3*x**2*y-y**3)*moments(kk2,7)) - endif - -! if (nmod .gt. 4) then -! call wkfunction_rwall(z,5,0,nrw,wkft) -! call wkfunction_rwall(z,5,1,nrw,wkfl) -! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) -! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) -! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) -! endif - -! if (nmod .gt. 5) then -! call wkfunction_rwall(z,6,0,nrw,wkft) -! call wkfunction_rwall(z,6,1,nrw,wkfl) -! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) -! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) -! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) -! endif - - return - end subroutine compute_wkfrc_reswall - -!*********************************************************************** - - subroutine compute_wkfrc_rlc(rho,z,ii,jj,kk1,kk2,nmod) - -! Computes wake forces acting on the test particle due to wake wields -! created by the source particle using the rlc resonator model -! Writes forces to arrays lwkfx,lwkfy,lwkfz in wakefld_params.mod -! -! z is the distance between the source and test particles -! ii,jj,kk1 are discrete coordinates of the test particle -! kk2 is the discrete z coord. of the source particle -! nmod is the number of modes - - use wakefld_params - implicit double precision(a-h,o-z) - integer ii,jj,kk1,kk2,nmod,nrf - - x = grid%xmin + grid%hx*(ii-1) - y = grid%ymin + grid%hy*(jj-1) - - nrf = wkfld_work(ncurel,2) - call wkfunction_rlc(z,1,1,nrf,wkfl) - lwkfx(ii,jj,kk1) = 0. - lwkfy(ii,jj,kk1) = 0. - lwkfz(ii,jj,kk1) = -moments(kk2,1)*wkfl - - if (nmod .gt. 1) then - call wkfunction_rlc(z,2,0,nrf,wkft) - call wkfunction_rlc(z,2,1,nrf,wkfl) - - lwkfx(ii,jj,kk1) = -moments(kk2,2)*wkft - - lwkfy(ii,jj,kk1) = -moments(kk2,3)*wkft - - lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & - & wkfl*(x*moments(kk2,2) + y*moments(kk2,3)) - endif - - if (nmod .gt. 2) then - call wkfunction_rlc(z,3,0,nrf,wkft) - call wkfunction_rlc(z,3,1,nrf,wkfl) - - lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & - & 2*wkft*(x*moments(kk2,4) + y*moments(kk2,5)) - - lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & - & 2*wkft*(-y*moments(kk2,4) + x*moments(kk2,5)) - - lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & - & wkfl*((x**2-y**2)*moments(kk2,4)+2*x*y*moments(kk2,5)) - endif - - if (nmod .gt. 3) then - call wkfunction_rlc(z,4,0,nrf,wkft) - call wkfunction_rlc(z,4,1,nrf,wkfl) - - lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & - & 3*wkft*((x**2-y**2)*moments(kk2,6)+2*x*y*moments(kk2,7)) - - lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & - & 3*wkft*(-2*x*y*moments(kk2,6)+(x**2-y**2)*moments(kk2,7)) - - lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & - & wkfl*((x**3-3*x*y**2)*moments(kk2,6) + & - & (3*x**2*y-y**3)*moments(kk2,7)) - endif - -! if (nmod .gt. 4) then -! call wkfunction_rlc(z,5,0,nrf,wkft) -! call wkfunction_rlc(z,5,1,nrf,wkfl) -! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) -! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) -! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) -! endif - -! if (nmod .gt. 5) then -! call wkfunction_rlc(z,6,0,nrf,wkft) -! call wkfunction_rlc(z,6,1,nrf,wkfl) -! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) -! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) -! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) -! endif - - return - end subroutine compute_wkfrc_rlc - -!*********************************************************************** - - subroutine compute_wkfrc_pbx(rho,z,ii,jj,kk1,kk2,nmod) - -! Computes wake forces acting on the test particle due to wake wields -! created by the source particle using the pbx resonator model -! Writes forces to arrays lwkfx,lwkfy,lwkfz in wakefld_params.mod -! -! z is the distance between the source and test particles -! ii,jj,kk1 are discrete coordinates of the test particle -! kk2 is the discrete z coord. of the source particle -! nmod is the number of modes - - use wakefld_params - implicit double precision(a-h,o-z) - integer ii,jj,kk1,kk2,nmod,nrf - - x = grid%xmin + grid%hx*(ii-1) - y = grid%ymin + grid%hy*(jj-1) - - nrf = wkfld_work(ncurel,2) - call wkfunction_pbx(z,1,1,nrf,wkfl) - lwkfx(ii,jj,kk1) = 0. - lwkfy(ii,jj,kk1) = 0. - lwkfz(ii,jj,kk1) = -moments(kk2,1)*wkfl - - if (nmod .gt. 1) then - call wkfunction_pbx(z,2,0,nrf,wkft) - call wkfunction_pbx(z,2,1,nrf,wkfl) - - lwkfx(ii,jj,kk1) = -moments(kk2,2)*wkft - - lwkfy(ii,jj,kk1) = -moments(kk2,3)*wkft - - lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & - & wkfl*(x*moments(kk2,2) + y*moments(kk2,3)) - endif - - if (nmod .gt. 2) then - call wkfunction_pbx(z,3,0,nrf,wkft) - call wkfunction_pbx(z,3,1,nrf,wkfl) - - lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & - & 2*wkft*(x*moments(kk2,4) + y*moments(kk2,5)) - - lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & - & 2*wkft*(-y*moments(kk2,4) + x*moments(kk2,5)) - - lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & - & wkfl*((x**2-y**2)*moments(kk2,4)+2*x*y*moments(kk2,5)) - endif - - if (nmod .gt. 3) then - call wkfunction_pbx(z,4,0,nrf,wkft) - call wkfunction_pbx(z,4,1,nrf,wkfl) - - lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) - & - & 3*wkft*((x**2-y**2)*moments(kk2,6)+2*x*y*moments(kk2,7)) - - lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) - & - & 3*wkft*(-2*x*y*moments(kk2,6)+(x**2-y**2)*moments(kk2,7)) - - lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) - & - & wkfl*((x**3-3*x*y**2)*moments(kk2,6) + & - & (3*x**2*y-y**3)*moments(kk2,7)) - endif - -! if (nmod .gt. 4) then -! call wkfunction_pbx(z,5,0,nrf,wkft) -! call wkfunction_pbx(z,5,1,nrf,wkfl) -! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) -! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) -! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) -! endif - -! if (nmod .gt. 5) then -! call wkfunction_pbx(z,6,0,nrf,wkft) -! call wkfunction_pbx(z,6,1,nrf,wkfl) -! lwkfx(ii,jj,kk1) = lwkfx(ii,jj,kk1) -! lwkfy(ii,jj,kk1) = lwkfy(ii,jj,kk1) -! lwkfz(ii,jj,kk1) = lwkfz(ii,jj,kk1) -! endif - - return - end subroutine compute_wkfrc_pbx - -!*********************************************************************** - - subroutine compute_wkfrc_from_table - - end subroutine compute_wkfrc_from_table - -!*********************************************************************** - - subroutine wkfunction_rlc(z,m,ntype,nel,wkfunction) - -! z is the longitudinal coordinate -! m is the mode number -! ntype = 0 for the transverse wake function -! ntype = 1 for the longitudinal wake function -! nel is the order number of this rlc element model -! wkfunction is the wake function value - - use wakefld_params - use beamdata, only: c - - implicit double precision(a-h,o-z) - integer m,ntype,nel - common/pie/pi,pi180,twopi - - Q = rlc_param(nel)%quality(m) - omega = rlc_param(nel)%res_fr(m) - Rs = rlc_param(nel)%r_shunt(m) - alpha = 0.5*omega/Q - bomega = sqrt(omega**2 - alpha**2) - - if (ntype .eq. 0) then ! transverse wake function - if (z .gt. 0.) then - write(6,*)'Error: positive z in subroutine wkfunction_rlc' - call myexit - else - wkfunction=c*Rs*omega*exp(alpha*z/c)*sin(bomega*z/c)/(Q*bomega) - endif - endif - - if (ntype .eq. 1) then ! longitudinal wake function - if (z .gt. 0.) then - write(6,*)'Error: positive z in subroutine wkfunction_rlc' - call myexit - elseif (z .eq. 0.) then - wkfunction=alpha*Rs - else - wkfunction=2*alpha*Rs*exp(alpha*z/c)*(cos(bomega*z/c)+ & - & alpha*sin(bomega*z/c)/bomega) - endif - endif - - if (ntype .gt. 1) then ! invalid ntype - write(6,*)'Invalid ntype of the rlc wake function' - call myexit - endif - return - - end subroutine wkfunction_rlc - -!*********************************************************************** - - subroutine wkfunction_rwall(z,m,ntype,nel,wkfunction) - -! z is the distance between the source and test particles (with - sign) -! m is the mode number -! ntype = 0 for the transverse wake function -! ntype = 1 for the longitudinal wake function -! nel is the order number of this res. wall element model -! wkfunction is the wake function value - - use wakefld_params - use beamdata, only : c - - implicit double precision(a-h,o-z) - integer m,ntype,nel - common/pie/pi,pi180,twopi - - if (z .eq. 0) then - wkfunction = 0 - return - endif - - if (m .eq. 0) then - delta = 1. - else - delta = 0. - endif - - if (ntype .eq. 0) then ! transverse wake function - wkfunction = c*sqrt(z0)/(pi*(rwall_param(nel)%radius)**(m+1)* & - & (1+delta)*sqrt(pi*rwall_param(nel)%conduct*abs(z))) - endif - - if (ntype .eq. 1) then ! longitudinal wake function - wkfunction = c*sqrt(z0)/(twopi*(rwall_param(nel)%radius)**(m+1)*& - & (1+delta)*z*sqrt(pi*rwall_param(nel)%conduct*abs(z))) - endif - - if (ntype .gt. 1) then ! invalid ntype - write(6,*)'Invalid ntype of the resistive wall wake function' - call myexit - endif - return - end subroutine wkfunction_rwall - -!*********************************************************************** - - subroutine wkfunction_pbx(z,m,ntype,nel,wkfunction) - -! z is the longitudinal coordinate -! m is the mode number -! ntype = 0 for the transverse wake function -! ntype = 1 for the longitudinal wake function -! nel is the order number of this rlc element model -! wkfunction is the wake function value - - use wakefld_params - use beamdata, only: c - - implicit double precision(a-h,o-z) - integer m,ntype,nel - common/pie/pi,pi180,twopi - - l = pbx_param(nel)%length(m) - d = pbx_param(nel)%depth(m) - r = pbx_param(nel)%radius(m) - - if (m .eq. 1) then - dlt = 2 - else - dlt = 1 - endif - - if (ntype .eq. 0) then ! transverse wake function - if (z .gt. 0.) then - write(6,*)'Error: positive z in subroutine wkfunction_pbx' - call myexit - else - wkfunction=2*z0*c*sqrt(-2.d0*l*z)/(dlt*pi**2*r**(2*m-1)) - endif - endif - - if (ntype .eq. 1) then ! longitudinal wake function - if (z .gt. 0.) then - write(6,*)'Error: positive z in subroutine wkfunction_pbx' - call myexit - elseif (z .eq. 0.) then - wkfunction=0 - else - wkfunction=z0*c*sqrt(2.d0*l)/(dlt*pi**2*r**(2*m-1)*sqrt(-z)) - endif - endif - - if (ntype .gt. 1) then ! invalid ntype - write(6,*)'Invalid ntype of the pbx wake function' - call myexit - endif - return - - end subroutine wkfunction_pbx - -!*********************************************************************** - - - subroutine locate_index(x,n,j) - -! Given an array wkfunc_table(:,:), and given a value x, returns a value -! j such that x is between wkfunc_table(j,1) and wkfunc_table(j+1,1). -! wkfunc_table(1:n,1) must be monotonic. j = 0 or j = n is rturned to -! indicate that x is out of range - - use wakefld_params, only: wkfunc_table - - implicit double precision(a-h,o-z) - integer j,n - integer jl,jm,ju -!temp - allocate(wkfunc_table(100,2)) - - jl = 0 - ju = n+1 - 10 if (ju-jl .gt. 1) then - jm = (ju+jl)/2 - if ((wkfunc_table(n,1) .ge. wkfunc_table(1,1)) .eqv. & - & (x .ge. wkfunc_table(jm,1))) then -!XXX gfortran compiler complains about uninitialized variable -!XXX jl = lm - write(6,*) 'error: locate_index(): uninitialized var: lm' - stop 'LMERROR' -!XXX - else - ju = jm - endif - goto 10 - endif - if (x .eq. wkfunc_table(1,1)) then - j = 1 - else if (x .eq. wkfunc_table(n,1)) then - j = n-1 - else - j = jl - endif -!temp - deallocate(wkfunc_table) - - - return - end subroutine locate_index - -!*********************************************************************** - - subroutine rhoslo3d_loc(coord,rho,msk,np,ab,de,gh,indx,jndx,kndx, & - &indxp1,jndxp1,kndxp1,nx,ny,nz,nadj) -cryne 08/24/2001 use hpf_library - implicit double precision(a-h,o-z) - logical msk - dimension coord(6,np),msk(np),vol(np) -!hpf$ distribute coord(*,block) -!hpf$ align (:) with coord(*,:) :: msk,vol - dimension ab(np),de(np),gh(np),indx(np),jndx(np),kndx(np), & - &indxp1(np),jndxp1(np),kndxp1(np) -!hpf$ align (:) with coord(*,:) :: ab,de,gh,indx,jndx,kndx -!hpf$ align (:) with coord(*,:) :: indxp1,jndxp1,kndxp1 - dimension rho(nx,ny,nz),tmp(nx,ny,nz) -!hpf$ distribute rho(*,*,block) -!hpf$ align (*,*,:) with rho(*,*,:) :: tmp - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi - common/showme/iverbose -! if(idproc.eq.0) write(6,*)'inside rhoslo3d' -! write(6,*)'xmin,xmax=',xmin,xmax -! write(6,*)'nx,ny,nz=',nx,ny,nz -! write(6,*)'nadj=',nadj -! xminnn=minval(coord(1,:)) -! xmaxxx=maxval(coord(1,:)) -! write(6,*)'xminnn,xmaxxx=',xminnn,xmaxxx -cryne 6/25/2002 do i=1,np - do j=1,np - indx(j)=(coord(1,j)-xmin)*hxi + 1 - jndx(j)=(coord(3,j)-ymin)*hyi + 1 - kndx(j)=(coord(5,j)-zmin)*hzi + 1 - enddo - do j=1,np - indxp1(j)=indx(j)+1 - jndxp1(j)=jndx(j)+1 - kndxp1(j)=kndx(j)+1 - enddo -!------- - imin=minval(indx,1,msk) - imax=maxval(indx,1,msk) - jmin=minval(jndx,1,msk) - jmax=maxval(jndx,1,msk) - kmin=minval(kndx,1,msk) - kmax=maxval(kndx,1,msk) - if((imin.lt.1).or.(imax.gt.nx-1))then - write(6,*)'error in rhoslo3d: imin,imax=',imin,imax - write(6,*)'nx,xmin,xmax,hx=',nx,xmin,xmax,hx - write(6,*)'nadj=',nadj - call myexit - endif - if((jmin.lt.1).or.(jmax.gt.ny-1))then - write(6,*)'error in rhoslo3d: jmin,jmax=',jmin,jmax - call myexit - endif - if(nadj.eq.0)then - if((kmin.lt.1).or.(kmax.gt.nz-1))then - write(6,*)'error in rhoslo3d (nadj=0): kmin,kmax=',kmin,kmax - call myexit - endif - endif - if(nadj.eq.1)then - if((kmin.lt.1).or.(kmax.gt.nz))then - write(6,*)'error in rhoslo3d (nadj=1): kmin,kmax=',kmin,kmax - call myexit - endif - endif -!------- - if(nadj.eq.1)then - do n=1,np - if(kndxp1(n).eq.nz+1)kndxp1(n)=1 - enddo - endif - ab=((xmin-coord(1,:))+indx*hx)*hxi - de=((ymin-coord(3,:))+jndx*hy)*hyi - gh=((zmin-coord(5,:))+kndx*hz)*hzi - rho=0. -!1 (i,j,k): - vol=ab*de*gh - do 100 n=1,np - rho(indx(n),jndx(n),kndx(n))= & - &rho(indx(n),jndx(n),kndx(n))+vol(n) - 100 continue -!2 (i,j+1,k): - vol=ab*(1.-de)*gh - do 200 n=1,np - rho(indx(n),jndxp1(n),kndx(n))= & - &rho(indx(n),jndxp1(n),kndx(n))+vol(n) - 200 continue -!3 (i,j+1,k+1): - vol=ab*(1.-de)*(1.-gh) - do 300 n=1,np - rho(indx(n),jndxp1(n),kndxp1(n))= & - &rho(indx(n),jndxp1(n),kndxp1(n))+vol(n) - 300 continue -!4 (i,j,k+1): - vol=ab*de*(1.-gh) - do 400 n=1,np - rho(indx(n),jndx(n),kndxp1(n))= & - &rho(indx(n),jndx(n),kndxp1(n))+vol(n) - 400 continue -!5 (i+1,j,k+1): - vol=(1.-ab)*de*(1.-gh) - do 500 n=1,np - rho(indxp1(n),jndx(n),kndxp1(n))= & - &rho(indxp1(n),jndx(n),kndxp1(n))+vol(n) - 500 continue -!6 (i+1,j+1,k+1): - vol=(1.-ab)*(1.-de)*(1.-gh) - do 600 n=1,np - rho(indxp1(n),jndxp1(n),kndxp1(n))= & - &rho(indxp1(n),jndxp1(n),kndxp1(n))+vol(n) - 600 continue -!7 (i+1,j+1,k): - vol=(1.-ab)*(1.-de)*gh - do 700 n=1,np - rho(indxp1(n),jndxp1(n),kndx(n))= & - &rho(indxp1(n),jndxp1(n),kndx(n))+vol(n) - 700 continue -!8 (i+1,j,k): - vol=(1.-ab)*de*gh - do 800 n=1,np - rho(indxp1(n),jndx(n),kndx(n))= & - &rho(indxp1(n),jndx(n),kndx(n))+vol(n) - 800 continue -! -cryne august 1, 2002: -cccc ngood=count(msk) -cccc write(6,*)'ngood=',ngood -cccc rho=rho/ngood -!wrong rho=rho/ngood*hxi*hyi*hzi -! if(idproc.eq.0)write(6,*)'leaving rhoslo3d' -! rhochk=sum(rho) -! write(6,*)'[rhoslo3d]sum(rho)=',rhochk - return - end - -!************************************************************* - - - subroutine ntrslo3d_loc(exg,eyg,ezg,ex,ey,ez,msk,ab,de,gh, - #indx,jndx,kndx,indxp1,jndxp1,kndxp1,nx,ny,nz,np) - use parallel - implicit double precision(a-h,o-z) - logical msk - dimension exg(nx,ny,nz),eyg(nx,ny,nz),ezg(nx,ny,nz) -!hpf$ distribute exg(*,*,block) -!hpf$ align (*,*,:) with exg(*,*,:) :: eyg,ezg - dimension ex(np),ey(np),ez(np),msk(np) - dimension ab(np),de(np),gh(np),indx(np),jndx(np),kndx(np), - #indxp1(np),jndxp1(np),kndxp1(np) -!hpf$ template t1(np) -!hpf$ distribute t1(block) -!hpf$ align (:) with t1(:) :: ex,ey,ez,msk,ab,de,gh -!hpf$ align (:) with t1(:) :: indx,jndx,kndx,indxp1,jndxp1,kndxp1 - common/gridsz3d/xmin,xmax,ymin,ymax,zmin,zmax,hx,hy,hz,hxi,hyi,hzi -! if(idproc.eq.0)write(6,*)'inside ntrslo3d' -! if(idproc.eq.0)then -! do n=1,np -! if(indx(n).lt.1 .or. indx(n).gt.nx)write(6,*)'error: indx(n)' -! enddo -! do n=1,np -! if(jndx(n).lt.1 .or. jndx(n).gt.ny)write(6,*)'error: jndx(n)' -! enddo -! do n=1,np -! if(kndx(n).lt.1 .or. kndx(n).gt.nz)write(6,*)'error: kndx(n)' -! enddo -! do n=1,np -! if(indxp1(n).lt.1.or.indxp1(n).gt.nx)write(6,*)'err:indxp1(n)' -! enddo -! do n=1,np -! if(jndxp1(n).lt.1.or.jndxp1(n).gt.ny)write(6,*)'err:jndxp1(n)' -! enddo -! do n=1,np -! if(kndxp1(n).lt.1.or.kndxp1(n).gt.nz)write(6,*)'err:kndxp1(n)' -! enddo -! endif -cryne forall(n=1:np)ex(n)= - do 100 n=1,np - ex(n)= & - & exg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) - &+exg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) - &+exg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) - &+exg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) - &+exg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) - &+exg(indxp1(n), - &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) - &+exg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) - &+exg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) - 100 continue - -cryne forall(n=1:np)ey(n)= - do 200 n=1,np - ey(n)= & - & eyg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) - &+eyg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) - &+eyg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) - &+eyg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) - &+eyg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) - &+eyg(indxp1(n), - &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) - &+eyg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) - &+eyg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) - 200 continue - -cryne forall(n=1:np)ez(n)= - do 300 n=1,np - ez(n)= & - & ezg(indx(n),jndx(n),kndx(n))*ab(n)*de(n)*gh(n) - &+ezg(indx(n),jndxp1(n),kndx(n))*ab(n)*(1.-de(n))*gh(n) - &+ezg(indx(n),jndxp1(n),kndxp1(n))*ab(n)*(1.-de(n))*(1.-gh(n)) - &+ezg(indx(n),jndx(n),kndxp1(n))*ab(n)*de(n)*(1.-gh(n)) - &+ezg(indxp1(n),jndx(n),kndxp1(n))*(1.-ab(n))*de(n)*(1.-gh(n)) - &+ezg(indxp1(n), - &jndxp1(n),kndxp1(n))*(1.-ab(n))*(1.-de(n))*(1.-gh(n)) - &+ezg(indxp1(n),jndxp1(n),kndx(n))*(1.-ab(n))*(1.-de(n))*gh(n) - &+ezg(indxp1(n),jndx(n),kndx(n))*(1.-ab(n))*de(n)*gh(n) - 300 continue -! if(idproc.eq.0)write(6,*)'leaving ntrslo3d_loc' - return - end - - - - - - - - - - diff --git a/OpticsJan2020/MLI_light_optics/Src/xerbla.f b/OpticsJan2020/MLI_light_optics/Src/xerbla.f deleted file mode 100644 index 963eefd..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/xerbla.f +++ /dev/null @@ -1,43 +0,0 @@ - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- LAPACK auxiliary routine (preliminary version) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER SRNAME*(*) - INTEGER INFO -* .. -* -* Purpose -* ======= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments -* ========= -* -* SRNAME (input) CHARACTER*(*) -* The name of the routine which called XERBLA. -* -* INFO (input) INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* - WRITE( *, FMT = 9999 )SRNAME, INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END diff --git a/OpticsJan2020/MLI_light_optics/Src/xtra.f b/OpticsJan2020/MLI_light_optics/Src/xtra.f deleted file mode 100755 index 0e4bbf7..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/xtra.f +++ /dev/null @@ -1,95 +0,0 @@ -************************************************************************ -* header XTRA CODE * -* MARYLIE code that is not part of the f90 standard -************************************************************************ -c - subroutine myflush(nfile) - call flush(nfile) -c call flush_(nfile) - return - end -c -c -c - subroutine cputim(t) -c----------------------------------------------------------------------- -c implicit real(a-h,o-z),logical(l),integer(i,j,k,m,n) -c----------------------------------------------------------------------- -c t is the cpu time used so far -c note, that this routine will work only for VAX VMS-Systems -c written by Petra Schuett, 12 April 1988 -c----------------------------------------------------------------------- -c include '($jpidef)' -c integer*2 ilen1,ilen2,ilen3,icod1,icod2,icod3 -c integer*4 iadd1,iadd11,iadd2,iadd21 -c common/tcbl/ilen1,icod1,iadd1,iadd11, -c * ilen2,icod2,iadd2,iadd21, -c * ilen3,icod3 -c data ilen1,ilen2,ilen3/3*4/ -c * iadd11,iadd21,icod3/3*0/ -c data icod1/jpi$_cpulim/ -c * icod2/jpi$_cputim/ - -c iadd1 = %loc(icpulm) -c iadd2 = %loc(icputm) - -c call sys$getjpi(,,,ilen1,,,) -c t = icputm/100. -c100 return - t=0. - return - end -c -*********************************************************************** -c - subroutine mytime(p) -c -c This subroutine computes and prints out the run time. -c It calls the VAX specific routine cputim. This is the -c only place in MaryLie where cputim is called. -c Written by A. Dragt on 7 April 1988. Modified -c 28 September 1991. -c - include 'impli.inc' - include 'time.inc' - include 'files.inc' -c - dimension p(6) - real runtim,tnow -c -c Compute and write out run time. -c - iopt = nint(p(1)) - ifile = nint(p(2)) - isend = nint(p(3)) -c - if (isend .ne. 0) then - call cputim(tnow) - runtim = tnow-tstart - if ((isend .eq. 1) .or. (isend .eq. 3)) - & write (jof,100) runtim - if ((isend .eq. 2) .or. (isend .eq. 3)) - & write (ifile,100) runtim - 100 format(/,1x,'Execution time in seconds = ',f8.2) - endif -c -c Reset clock if iopt .ne. 0 -c - if (iopt .ne. 0) then - call cputim(tstart) - if ((isend .eq. 1) .or. (isend .eq. 3)) - & write (jof,*) ' time reset to zero' - if ((isend .eq. 2) .or. (isend .eq. 3)) - & write (ifile,*) ' time reset to zero' - endif -c - return - end -c - real function secnds(tt) - real tt - secnds=0.0 - return - end -c end of file - diff --git a/OpticsJan2020/MLI_light_optics/Src/xtra_notgnu.f b/OpticsJan2020/MLI_light_optics/Src/xtra_notgnu.f deleted file mode 100755 index 0e4bbf7..0000000 --- a/OpticsJan2020/MLI_light_optics/Src/xtra_notgnu.f +++ /dev/null @@ -1,95 +0,0 @@ -************************************************************************ -* header XTRA CODE * -* MARYLIE code that is not part of the f90 standard -************************************************************************ -c - subroutine myflush(nfile) - call flush(nfile) -c call flush_(nfile) - return - end -c -c -c - subroutine cputim(t) -c----------------------------------------------------------------------- -c implicit real(a-h,o-z),logical(l),integer(i,j,k,m,n) -c----------------------------------------------------------------------- -c t is the cpu time used so far -c note, that this routine will work only for VAX VMS-Systems -c written by Petra Schuett, 12 April 1988 -c----------------------------------------------------------------------- -c include '($jpidef)' -c integer*2 ilen1,ilen2,ilen3,icod1,icod2,icod3 -c integer*4 iadd1,iadd11,iadd2,iadd21 -c common/tcbl/ilen1,icod1,iadd1,iadd11, -c * ilen2,icod2,iadd2,iadd21, -c * ilen3,icod3 -c data ilen1,ilen2,ilen3/3*4/ -c * iadd11,iadd21,icod3/3*0/ -c data icod1/jpi$_cpulim/ -c * icod2/jpi$_cputim/ - -c iadd1 = %loc(icpulm) -c iadd2 = %loc(icputm) - -c call sys$getjpi(,,,ilen1,,,) -c t = icputm/100. -c100 return - t=0. - return - end -c -*********************************************************************** -c - subroutine mytime(p) -c -c This subroutine computes and prints out the run time. -c It calls the VAX specific routine cputim. This is the -c only place in MaryLie where cputim is called. -c Written by A. Dragt on 7 April 1988. Modified -c 28 September 1991. -c - include 'impli.inc' - include 'time.inc' - include 'files.inc' -c - dimension p(6) - real runtim,tnow -c -c Compute and write out run time. -c - iopt = nint(p(1)) - ifile = nint(p(2)) - isend = nint(p(3)) -c - if (isend .ne. 0) then - call cputim(tnow) - runtim = tnow-tstart - if ((isend .eq. 1) .or. (isend .eq. 3)) - & write (jof,100) runtim - if ((isend .eq. 2) .or. (isend .eq. 3)) - & write (ifile,100) runtim - 100 format(/,1x,'Execution time in seconds = ',f8.2) - endif -c -c Reset clock if iopt .ne. 0 -c - if (iopt .ne. 0) then - call cputim(tstart) - if ((isend .eq. 1) .or. (isend .eq. 3)) - & write (jof,*) ' time reset to zero' - if ((isend .eq. 2) .or. (isend .eq. 3)) - & write (ifile,*) ' time reset to zero' - endif -c - return - end -c - real function secnds(tt) - real tt - secnds=0.0 - return - end -c end of file -