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] 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 -