From e3cd728ecbf7ff65f5b5f015d51d82f6f132ebe0 Mon Sep 17 00:00:00 2001 From: cvs Date: Fri, 20 Jun 2003 10:17:44 +0000 Subject: [PATCH] - Rearranged directory structure for forking out ANSTO - Refactored site specific stuff into a site module - PSI specific stuff is now in the PSI directory. - The old version has been tagged with pre-ansto SKIPPED: psi/A1931.c psi/A1931.h psi/amor2t.c psi/amor2t.h psi/amor2t.i psi/amor2t.tex psi/amor2t.w psi/amorscan.c psi/amorscan.h psi/amorscan.w psi/amorstat.c psi/amorstat.h psi/amorstat.i psi/amorstat.tex psi/amorstat.w psi/bruker.c psi/bruker.h psi/bruker.w psi/buffer.c psi/buffer.h psi/dilludriv.c psi/dilludriv.h psi/dmc.c psi/dmc.h psi/dmc.w psi/docho.c psi/ecb.c psi/ecb.h psi/ecb.i psi/ecb.w psi/ecbdriv.c psi/ecbdriv.h psi/el734dc.c psi/el734driv.c psi/el755driv.c psi/el755driv.h psi/faverage.c psi/faverage.h psi/faverage.tex psi/faverage.w psi/fowrite.c psi/fowrite.h psi/itc4.c psi/itc4.h psi/itc4.w psi/itc4driv.c psi/ltc11.c psi/ltc11.h psi/nextrics.c psi/nextrics.h psi/nxamor.c psi/nxamor.h psi/nxamor.tex psi/nxamor.w psi/pimotor.c psi/pimotor.h psi/pimotor.tex psi/pimotor.w psi/pipiezo.c psi/polterwrite.c psi/polterwrite.h psi/psi.c psi/ruli.c psi/ruli.h psi/sanscook.c psi/sanswave.c psi/sanswave.h psi/sanswave.tex psi/sanswave.w psi/serial.c psi/serial.h psi/serial.w psi/sinqhmdriv.c psi/sinqhmdriv.i psi/sinqhmdriv.w psi/slsmagnet.c psi/sps.c psi/sps.h psi/sps.i psi/sps.tex psi/sps.w psi/swmotor.c psi/swmotor.h psi/swmotor.i psi/tas.c psi/tas.h psi/tas.tex psi/tas.w psi/tasdrive.c psi/tasinit.c psi/tasscan.c psi/tasu.h psi/tasutil.c psi/tdchm.c psi/tdchm.h psi/tecsdriv.c psi/tecsdriv.h psi/velodorn.c psi/velodorn.h psi/velodorn.w psi/velodornier.c psi/hardsup/README psi/hardsup/StrMatch.c psi/hardsup/asynsrv_def.h psi/hardsup/asynsrv_errcodes.h psi/hardsup/asynsrv_mark.c psi/hardsup/asynsrv_utility.c psi/hardsup/c_interfaces.c psi/hardsup/dillutil.c psi/hardsup/dillutil.h psi/hardsup/el734_def.h psi/hardsup/el734_errcodes.h psi/hardsup/el734_utility.c psi/hardsup/el734fix.h psi/hardsup/el734tcl.c psi/hardsup/el737_def.h psi/hardsup/el737_errcodes.h psi/hardsup/el737_utility.c psi/hardsup/el737fix.h psi/hardsup/el737tcl.c psi/hardsup/el755_def.h psi/hardsup/el755_errcodes.h psi/hardsup/el755_errorlog.c psi/hardsup/el755_utility.c psi/hardsup/err.c psi/hardsup/failinet.c psi/hardsup/geterrno.c psi/hardsup/itc4util.c psi/hardsup/itc4util.h psi/hardsup/make_gen psi/hardsup/makefile_alpha psi/hardsup/makefile_linux psi/hardsup/makeprint.c psi/hardsup/rs232c_def.h psi/hardsup/serialsinq.c psi/hardsup/serialsinq.h psi/hardsup/sinq_defs.h psi/hardsup/sinq_prototypes.h psi/hardsup/sinqhm.c psi/hardsup/sinqhm.h psi/hardsup/sinqhm_def.h psi/hardsup/stredit.c psi/hardsup/strjoin.c psi/hardsup/table.c psi/hardsup/table.h psi/hardsup/velsel_def.h psi/hardsup/velsel_utility.c psi/motor/Makefile psi/motor/el734_test psi/motor/el734_test.c psi/motor/makeprint.c psi/sinqhm/FOCUS_gbl.h psi/sinqhm/FOCUS_srv_main.c psi/sinqhm/Makefile psi/sinqhm/SinqHM_bootParamsConfig.c psi/sinqhm/SinqHM_bootUtil.c psi/sinqhm/SinqHM_def.h psi/sinqhm/SinqHM_gbl.h psi/sinqhm/SinqHM_srv_filler.c psi/sinqhm/SinqHM_srv_main.c psi/sinqhm/SinqHM_srv_routines.c psi/sinqhm/SinqHM_srv_server.c psi/sinqhm/bld psi/sinqhm/bld2 psi/sinqhm/bldmen psi/sinqhm/hist_mem_notes.tex psi/sinqhm/hist_mem_spec.tex psi/sinqhm/hist_mem_spec_fig1.ps psi/sinqhm/hist_mem_spec_fig2.ps psi/sinqhm/hist_mem_spec_fig3.ps psi/sinqhm/hist_mem_spec_fig4.ps psi/sinqhm/lwl_client.c psi/sinqhm/lwl_server.c psi/sinqhm/make_sinqhm.com psi/sinqhm/monitor.c psi/sinqhm/psi_logo.ps psi/sinqhm/sinq_logo.ps psi/sinqhm/sinqhm_bootutil_client.c psi/sinqhm/sinqhm_client.c psi/sinqhm/sinqhm_ctrl.c psi/sinqhm/usrConfig.c psi/sinqhm/usrConfig.c_diffs psi/sinqhm/usrConfig2604.c psi/sinqhm/vmio10_def.h psi/sinqhm/vmio_utility.c psi/tecs/coc_client.c psi/tecs/coc_client.h psi/tecs/coc_logfile.c psi/tecs/coc_logfile.h psi/tecs/coc_server.c psi/tecs/coc_server.h psi/tecs/coc_util.c psi/tecs/coc_util.h psi/tecs/fortify1.c psi/tecs/instr_hosts.c psi/tecs/instr_hosts.h psi/tecs/keep_running.c psi/tecs/make_gen psi/tecs/make_opt psi/tecs/make_opt_alpha psi/tecs/make_opt_llc psi/tecs/makefile psi/tecs/makefile_alpha psi/tecs/makefile_linux psi/tecs/myc_buf.c psi/tecs/myc_buf.h psi/tecs/myc_err.c psi/tecs/myc_err.h psi/tecs/myc_fortran.h psi/tecs/myc_mem.h psi/tecs/myc_str.c psi/tecs/myc_str.h psi/tecs/myc_time.c psi/tecs/myc_time.h psi/tecs/myc_tmp.c psi/tecs/myc_tmp.h psi/tecs/rstart.c psi/tecs/six.c psi/tecs/str.f psi/tecs/sys_cmdpar.f psi/tecs/sys_date.f psi/tecs/sys_env.c psi/tecs/sys_get_key.f psi/tecs/sys_getenv.f psi/tecs/sys_lun.f psi/tecs/sys_open.f psi/tecs/sys_open_alpha.f psi/tecs/sys_rdline.c psi/tecs/sys_select.c psi/tecs/sys_select.h psi/tecs/sys_unix.c psi/tecs/sys_wait.f psi/tecs/tecs.bld psi/tecs/tecs.c psi/tecs/tecs.tcl psi/tecs/tecs_c.c psi/tecs/tecs_c.h psi/tecs/tecs_cli.c psi/tecs/tecs_cli.h psi/tecs/tecs_client.f psi/tecs/tecs_data.c psi/tecs/tecs_data.h psi/tecs/tecs_dlog.inc psi/tecs/tecs_for.f psi/tecs/tecs_lsc.c psi/tecs/tecs_lsc.h psi/tecs/tecs_plot.f psi/tecs/tecs_serial.c psi/tecs/tecs_serial.h psi/tecs/term.c psi/tecs/term.h psi/utils/Makefile psi/utils/SerPortServer.c psi/utils/asynsrv_test.c psi/utils/ecb-load.c psi/utils/el734.c psi/utils/el734_test.c psi/utils/el737.c psi/utils/make.ecb psi/utils/check/amorcheck psi/utils/check/dmccheck psi/utils/check/focuscheck psi/utils/check/focusstatus.tcl psi/utils/check/hrptcheck psi/utils/check/sanscheck psi/utils/check/sicssyntax.tex psi/utils/check/sicssyntaxlib.tcl psi/utils/check/test.tcl psi/utils/check/topsicheck psi/utils/check/tricscheck psi/utils/check/tst --- A1931.c | 344 -- A1931.h | 20 - amor2t.c | 996 ---- amor2t.h | 22 - amor2t.i | 55 - amor2t.tex | 204 - amor2t.w | 150 - amorscan.c | 140 - amorscan.h | 15 - amorscan.w | 57 - amorstat.c | 919 ---- amorstat.h | 21 - amorstat.i | 29 - amorstat.tex | 138 - amorstat.w | 102 - bruker.c | 999 ---- bruker.h | 25 - bruker.w | 64 - buffer.c | 584 --- buffer.h | 94 - choco.c | 85 +- countdriv.c | 663 +-- countdriv.h | 1 + counter.c | 70 +- danu.dat | 2 +- difrac/CAD4COMM | 728 --- difrac/COMDIF | 54 - difrac/IATSIZ | 5 - difrac/Makefile | 53 - difrac/alfnum.f | 50 - difrac/align.f | 640 --- difrac/ang180.f | 8 - difrac/ang360.f | 13 - difrac/angcal.f | 285 -- difrac/angl.f | 14 - difrac/angrw.f | 76 - difrac/angval.f | 20 - difrac/basinp.f | 722 --- difrac/begin.f | 436 -- difrac/bigchi.f | 146 - difrac/blind.f | 727 --- difrac/burger.f | 174 - difrac/cad4io.f | 517 --- difrac/cad4l.f | 454 -- difrac/cad4l.mak | 14 - difrac/cartc.f | 18 - difrac/cellls.f | 628 --- difrac/cellsd.f | 123 - difrac/cent8.f | 405 -- difrac/centre.f | 507 -- difrac/cfind.f | 63 - difrac/cinput.f | 56 - difrac/cntref.f | 88 - difrac/comptn.f | 69 - difrac/creduc.f | 340 -- difrac/demo1e.f | 138 - difrac/dhgen.f | 215 - difrac/dif.asc | Bin 131702 -> 0 bytes difrac/dif.mak | 34 - difrac/dif.wpd | Bin 184931 -> 0 bytes difrac/difini.f | 248 - difrac/difint.f | 724 --- difrac/difrac.f | 245 - difrac/eulkap.f | 50 - difrac/fndsys.f | 399 -- difrac/freefm.f | 262 -- difrac/goloop.f | 433 -- difrac/goniom.ini | 39 - difrac/grid.f | 195 - difrac/gwrite.f | 115 - difrac/ibmfil.f | 184 - difrac/iedevs.f | 49 - difrac/inchkl.f | 81 - difrac/indmes.f | 466 -- difrac/keyget.f | 28 - difrac/latmod.f | 37 - difrac/linprf.f | 151 - difrac/list.dat | 80 - difrac/lister.f | 257 - difrac/lotem.f | 24 - difrac/lsormt.f | 547 --- difrac/matrix.f | 234 - difrac/mesint.f | 407 -- difrac/mod360.f | 8 - difrac/nexseg.f | 58 - difrac/orcel2.f | 318 -- difrac/ormat3.f | 211 - difrac/oscil.f | 93 - difrac/params.f | 21 - difrac/pcdraw.f | 330 -- difrac/pcount.f | 149 - difrac/peaksr.f | 209 - difrac/pfind.f | 55 - difrac/pltprf.f | 144 - difrac/prnbas.f | 291 -- difrac/prnint.f | 423 -- difrac/profil.f | 475 -- difrac/prompt.f | 157 - difrac/prtang.f | 12 - difrac/pscan.f | 86 - difrac/qio.f | 204 - difrac/ralf.f | 1121 ----- difrac/range.f | 13 - difrac/rcpcor.f | 125 - difrac/readme.dif | 128 - difrac/reindx.f | 105 - difrac/sammes.f | 116 - difrac/setiou.f | 87 - difrac/setop.f | 724 --- difrac/setrow.f | 184 - difrac/sgerrs.f | 40 - difrac/sglatc.f | 656 --- difrac/sglpak.f | 11 - difrac/sgmtml.f | 23 - difrac/sgprnh.f | 125 - difrac/sgrmat.f | 30 - difrac/sgroup.f | 561 --- difrac/sgtrcf.f | 68 - difrac/sinmat.f | 87 - difrac/stdmes.f | 168 - difrac/swrite.f | 109 - difrac/sysang.f | 74 - difrac/tcentr.f | 190 - difrac/tfind.f | 59 - difrac/trics.f | 354 -- difrac/wrbas.f | 77 - difrac/wxw2t.f | 85 - difrac/yesno.f | 48 - dilludriv.c | 272 -- dilludriv.h | 15 - dmc.c | 54 - dmc.h | 19 - dmc.tex | 48 - dmc.w | 27 - docho.c | 747 --- dummy/dummy.c | 102 + dummy/make_gen | 18 + .../makefile_alpha_dummy | 7 +- ecb.c | 496 -- ecb.h | 69 - ecb.i | 23 - ecb.w | 173 - ecbcounter.c | 7 +- ecbdriv.c | 1261 ----- ecbdriv.h | 45 - el734dc.c | 907 ---- el734driv.c | 923 ---- el755driv.c | 318 -- el755driv.h | 15 - eurodriv.c | 6 +- evcontroller.c | 341 +- faverage.c | 557 --- faverage.h | 21 - faverage.tex | 70 - faverage.w | 50 - fowrite.c | 1195 ----- fowrite.h | 21 - hardsup/Makefile | 44 - hardsup/README | 4 - hardsup/StrMatch.c | 96 - hardsup/asynsrv_def.h | 51 - hardsup/asynsrv_errcodes.h | 34 - hardsup/asynsrv_mark.c | 1465 ------ hardsup/asynsrv_utility.c | 2121 --------- hardsup/c_interfaces.c | 472 -- hardsup/dillutil.c | 481 -- hardsup/dillutil.h | 108 - hardsup/el734_def.h | 73 - hardsup/el734_errcodes.h | 28 - hardsup/el734_utility.c | 2638 ----------- hardsup/el734fix.h | 29 - hardsup/el734tcl.c | 644 --- hardsup/el737_def.h | 67 - hardsup/el737_errcodes.h | 27 - hardsup/el737_utility.c | 1742 ------- hardsup/el737fix.h | 33 - hardsup/el737tcl.c | 400 -- hardsup/el755_def.h | 31 - hardsup/el755_errcodes.h | 27 - hardsup/el755_errorlog.c | 26 - hardsup/el755_utility.c | 1445 ------ hardsup/err.c | 105 - hardsup/failinet.c | 109 - hardsup/geterrno.c | 96 - hardsup/itc4util.c | 421 -- hardsup/itc4util.h | 124 - hardsup/make_gen | 28 - hardsup/makefile_linux | 15 - hardsup/makeprint.c | 276 -- hardsup/rs232c_def.h | 186 - hardsup/serialsinq.c | 914 ---- hardsup/serialsinq.h | 56 - hardsup/sinq_defs.h | 108 - hardsup/sinq_prototypes.h | 674 --- hardsup/sinqhm.c | 1770 ------- hardsup/sinqhm.h | 107 - hardsup/sinqhm.i | 54 - hardsup/sinqhm.tex | 618 --- hardsup/sinqhm.w | 446 -- hardsup/sinqhm_def.h | 483 -- hardsup/stredit.c | 415 -- hardsup/strjoin.c | 142 - hardsup/table.c | 176 - hardsup/table.h | 35 - hardsup/velsel_def.h | 58 - hardsup/velsel_utility.c | 928 ---- histmem.c | 26 +- histsim.c | 2 +- hkl.c | 25 +- itc4.c | 281 -- itc4.h | 43 - itc4.w | 74 - itc4driv.c | 470 -- ltc11.c | 828 ---- ltc11.h | 24 - macro.c | 10 + make_gen | 60 +- make_gen_dummy | 77 + makefile_alpha | 8 +- makefile_alpha_dummy | 44 + makefile_linux | 3 + modriv.h | 36 +- motor.c | 123 +- motor/Makefile | 21 - motor/el734_test.c | 3900 ---------------- motor/makeprint.c | 203 - motor/test.dat | 45 - nextrics.c | 1535 ------ nextrics.h | 37 - nserver.c | 11 + nxamor.c | 835 ---- nxamor.h | 27 - nxamor.tex | 69 - nxamor.w | 48 - nxdict.c | 2 +- nxsans.c | 796 ---- nxsans.h | 17 - ofac.c | 85 +- pimotor.c | 784 ---- pimotor.h | 24 - pimotor.tex | 67 - pimotor.w | 48 - pipiezo.c | 390 -- polterwrite.c | 786 ---- polterwrite.h | 21 - ruli.c | 335 -- ruli.h | 39 - sanscook.c | 682 --- sanswave.c | 385 -- sanswave.h | 27 - sanswave.tex | 100 - sanswave.w | 67 - scan.c | 34 +- scontroller.c | 2 +- serial.c | 25 - serial.h | 15 - serial.w | 29 - serialwait.c | 5 +- serialwait.h | 2 +- sicsdata.c | 2 +- simcter.c | 11 +- simdriv.c | 17 +- sinqhm/FOCUS_gbl.h | 299 -- sinqhm/FOCUS_srv_main.c | 2705 ----------- sinqhm/Makefile | 103 - sinqhm/SinqHM_bootParamsConfig.c | 1263 ----- sinqhm/SinqHM_bootUtil.c | 631 --- sinqhm/SinqHM_def.h | 493 -- sinqhm/SinqHM_gbl.h | 351 -- sinqhm/SinqHM_srv_filler.c | 1399 ------ sinqhm/SinqHM_srv_main.c | 378 -- sinqhm/SinqHM_srv_routines.c | 4130 ---------------- sinqhm/SinqHM_srv_server.c | 284 -- sinqhm/bld | 415 -- sinqhm/bld2 | 432 -- sinqhm/bldmen | 439 -- sinqhm/hist_mem_notes.tex | 1572 ------- sinqhm/hist_mem_spec.tex | 2677 ----------- sinqhm/hist_mem_spec_fig1.ps | 1632 ------- sinqhm/hist_mem_spec_fig2.ps | 808 ---- sinqhm/hist_mem_spec_fig3.ps | 1048 ----- sinqhm/hist_mem_spec_fig4.ps | 1336 ------ sinqhm/lwl_client.c | 1423 ------ sinqhm/lwl_server.c | 485 -- sinqhm/make_sinqhm.com | 202 - sinqhm/monitor.c | 354 -- sinqhm/psi_logo.ps | 743 --- sinqhm/sinq_logo.ps | 1385 ------ sinqhm/sinqhm_bootutil_client.c | 1311 ------ sinqhm/sinqhm_client.c | 3124 ------------- sinqhm/sinqhm_ctrl.c | 2038 -------- sinqhm/usrConfig.c | 944 ---- sinqhm/usrConfig.c_diffs | 125 - sinqhm/usrConfig2604.c | 996 ---- sinqhm/vmio10_def.h | 44 - sinqhm/vmio_utility.c | 307 -- sinqhmdriv.c | 1171 ----- sinqhmdriv.i | 42 - sinqhmdriv.w | 85 - site.h | 57 + site.w | 124 + slsmagnet.c | 389 -- splitter.c | 24 + splitter.h | 4 + sps.c | 799 ---- sps.h | 27 - sps.i | 26 - sps.tex | 198 - sps.w | 144 - swmotor.c | 547 --- swmotor.h | 20 - swmotor.i | 21 - tas.c | 129 - tas.h | 187 - tas.w | 255 - tasdrive.c | 331 -- tasinit.c | 435 -- tasscan.c | 1504 ------ tasu.h | 54 - tasutil.c | 848 ---- tdchm.c | 563 --- tdchm.h | 15 - tecs/coc_client.c | 521 --- tecs/coc_client.h | 82 - tecs/coc_logfile.c | 350 -- tecs/coc_logfile.h | 28 - tecs/coc_server.c | 661 --- tecs/coc_server.h | 123 - tecs/coc_util.c | 112 - tecs/coc_util.h | 44 - tecs/fortify1.c | 4 - tecs/instr_hosts.c | 87 - tecs/instr_hosts.h | 11 - tecs/keep_running.c | 49 - tecs/make_gen | 65 - tecs/make_opt | 37 - tecs/make_opt_alpha | 27 - tecs/make_opt_llc | 27 - tecs/makefile | 3 - tecs/makefile_alpha | 44 - tecs/makefile_linux | 45 - tecs/myc_buf.c | 312 -- tecs/myc_buf.h | 60 - tecs/myc_err.c | 136 - tecs/myc_err.h | 85 - tecs/myc_fortran.h | 56 - tecs/myc_mem.h | 30 - tecs/myc_str.c | 251 - tecs/myc_str.h | 122 - tecs/myc_time.c | 124 - tecs/myc_time.h | 42 - tecs/myc_tmp.c | 96 - tecs/myc_tmp.h | 9 - tecs/rstart.c | 52 - tecs/six.c | 220 - tecs/str.f | 131 - tecs/sys_cmdpar.f | 23 - tecs/sys_date.f | 18 - tecs/sys_env.c | 179 - tecs/sys_get_key.f | 52 - tecs/sys_getenv.f | 75 - tecs/sys_lun.f | 43 - tecs/sys_open.f | 55 - tecs/sys_open_alpha.f | 54 - tecs/sys_rdline.c | 37 - tecs/sys_select.c | 91 - tecs/sys_select.h | 14 - tecs/sys_unix.c | 133 - tecs/sys_wait.f | 20 - tecs/tecs.bld | 4 - tecs/tecs.c | 2553 ---------- tecs/tecs.tcl | 3 - tecs/tecs_c.c | 82 - tecs/tecs_c.h | 8 - tecs/tecs_cli.c | 374 -- tecs/tecs_cli.h | 65 - tecs/tecs_client.f | 364 -- tecs/tecs_data.c | 558 --- tecs/tecs_data.h | 49 - tecs/tecs_dlog.inc | 14 - tecs/tecs_for.f | 231 - tecs/tecs_lsc.c | 208 - tecs/tecs_lsc.h | 56 - tecs/tecs_plot.f | 756 --- tecs/tecs_serial.c | 244 - tecs/tecs_serial.h | 20 - tecs/term.c | 238 - tecs/term.h | 19 - tecsdriv.c | 419 -- tecsdriv.h | 27 - utils/Makefile | 72 - utils/SerPortServer.c | 2588 ----------- utils/asynsrv_test.c | 861 ---- utils/check/amorcheck | 97 - utils/check/dmccheck | 68 - utils/check/focuscheck | 82 - utils/check/hrptcheck | 85 - utils/check/sanscheck | 144 - utils/check/sicssyntax.tex | 86 - utils/check/sicssyntaxlib.tcl | 1088 ----- utils/check/topsicheck | 142 - utils/check/tricscheck | 288 -- utils/el734.c | 2087 --------- utils/el734_test.c | 4133 ----------------- utils/el737.c | 2848 ------------ velo.c | 19 +- velodorn.c | 210 - velodorn.h | 55 - velodorn.tex | 113 - velodorn.w | 93 - velodornier.c | 683 --- velodriv.h | 2 - 412 files changed, 695 insertions(+), 139541 deletions(-) delete mode 100644 A1931.c delete mode 100644 A1931.h delete mode 100644 amor2t.c delete mode 100644 amor2t.h delete mode 100644 amor2t.i delete mode 100644 amor2t.tex delete mode 100644 amor2t.w delete mode 100644 amorscan.c delete mode 100644 amorscan.h delete mode 100644 amorscan.w delete mode 100644 amorstat.c delete mode 100644 amorstat.h delete mode 100644 amorstat.i delete mode 100644 amorstat.tex delete mode 100644 amorstat.w delete mode 100644 bruker.c delete mode 100644 bruker.h delete mode 100644 bruker.w delete mode 100644 buffer.c delete mode 100644 buffer.h delete mode 100644 difrac/CAD4COMM delete mode 100644 difrac/COMDIF delete mode 100644 difrac/IATSIZ delete mode 100644 difrac/Makefile delete mode 100644 difrac/alfnum.f delete mode 100644 difrac/align.f delete mode 100644 difrac/ang180.f delete mode 100644 difrac/ang360.f delete mode 100644 difrac/angcal.f delete mode 100644 difrac/angl.f delete mode 100644 difrac/angrw.f delete mode 100644 difrac/angval.f delete mode 100644 difrac/basinp.f delete mode 100644 difrac/begin.f delete mode 100644 difrac/bigchi.f delete mode 100644 difrac/blind.f delete mode 100644 difrac/burger.f delete mode 100644 difrac/cad4io.f delete mode 100644 difrac/cad4l.f delete mode 100644 difrac/cad4l.mak delete mode 100644 difrac/cartc.f delete mode 100644 difrac/cellls.f delete mode 100644 difrac/cellsd.f delete mode 100644 difrac/cent8.f delete mode 100644 difrac/centre.f delete mode 100644 difrac/cfind.f delete mode 100644 difrac/cinput.f delete mode 100644 difrac/cntref.f delete mode 100644 difrac/comptn.f delete mode 100644 difrac/creduc.f delete mode 100644 difrac/demo1e.f delete mode 100644 difrac/dhgen.f delete mode 100644 difrac/dif.asc delete mode 100644 difrac/dif.mak delete mode 100644 difrac/dif.wpd delete mode 100644 difrac/difini.f delete mode 100644 difrac/difint.f delete mode 100644 difrac/difrac.f delete mode 100644 difrac/eulkap.f delete mode 100644 difrac/fndsys.f delete mode 100644 difrac/freefm.f delete mode 100644 difrac/goloop.f delete mode 100644 difrac/goniom.ini delete mode 100644 difrac/grid.f delete mode 100644 difrac/gwrite.f delete mode 100644 difrac/ibmfil.f delete mode 100644 difrac/iedevs.f delete mode 100644 difrac/inchkl.f delete mode 100644 difrac/indmes.f delete mode 100644 difrac/keyget.f delete mode 100644 difrac/latmod.f delete mode 100644 difrac/linprf.f delete mode 100644 difrac/list.dat delete mode 100644 difrac/lister.f delete mode 100644 difrac/lotem.f delete mode 100644 difrac/lsormt.f delete mode 100644 difrac/matrix.f delete mode 100644 difrac/mesint.f delete mode 100644 difrac/mod360.f delete mode 100644 difrac/nexseg.f delete mode 100644 difrac/orcel2.f delete mode 100644 difrac/ormat3.f delete mode 100644 difrac/oscil.f delete mode 100644 difrac/params.f delete mode 100644 difrac/pcdraw.f delete mode 100644 difrac/pcount.f delete mode 100644 difrac/peaksr.f delete mode 100644 difrac/pfind.f delete mode 100644 difrac/pltprf.f delete mode 100644 difrac/prnbas.f delete mode 100644 difrac/prnint.f delete mode 100644 difrac/profil.f delete mode 100644 difrac/prompt.f delete mode 100644 difrac/prtang.f delete mode 100644 difrac/pscan.f delete mode 100644 difrac/qio.f delete mode 100644 difrac/ralf.f delete mode 100644 difrac/range.f delete mode 100644 difrac/rcpcor.f delete mode 100644 difrac/readme.dif delete mode 100644 difrac/reindx.f delete mode 100644 difrac/sammes.f delete mode 100644 difrac/setiou.f delete mode 100644 difrac/setop.f delete mode 100644 difrac/setrow.f delete mode 100644 difrac/sgerrs.f delete mode 100644 difrac/sglatc.f delete mode 100644 difrac/sglpak.f delete mode 100644 difrac/sgmtml.f delete mode 100644 difrac/sgprnh.f delete mode 100644 difrac/sgrmat.f delete mode 100644 difrac/sgroup.f delete mode 100644 difrac/sgtrcf.f delete mode 100644 difrac/sinmat.f delete mode 100644 difrac/stdmes.f delete mode 100644 difrac/swrite.f delete mode 100644 difrac/sysang.f delete mode 100644 difrac/tcentr.f delete mode 100644 difrac/tfind.f delete mode 100644 difrac/trics.f delete mode 100644 difrac/wrbas.f delete mode 100644 difrac/wxw2t.f delete mode 100644 difrac/yesno.f delete mode 100644 dilludriv.c delete mode 100644 dilludriv.h delete mode 100644 dmc.c delete mode 100644 dmc.h delete mode 100644 dmc.tex delete mode 100644 dmc.w delete mode 100644 docho.c create mode 100644 dummy/dummy.c create mode 100644 dummy/make_gen rename hardsup/makefile_alpha => dummy/makefile_alpha_dummy (69%) delete mode 100644 ecb.c delete mode 100644 ecb.h delete mode 100644 ecb.i delete mode 100644 ecb.w delete mode 100644 ecbdriv.c delete mode 100644 ecbdriv.h delete mode 100644 el734dc.c delete mode 100644 el734driv.c delete mode 100644 el755driv.c delete mode 100644 el755driv.h delete mode 100644 faverage.c delete mode 100644 faverage.h delete mode 100644 faverage.tex delete mode 100644 faverage.w delete mode 100644 fowrite.c delete mode 100644 fowrite.h delete mode 100644 hardsup/Makefile delete mode 100644 hardsup/README delete mode 100755 hardsup/StrMatch.c delete mode 100644 hardsup/asynsrv_def.h delete mode 100644 hardsup/asynsrv_errcodes.h delete mode 100644 hardsup/asynsrv_mark.c delete mode 100644 hardsup/asynsrv_utility.c delete mode 100644 hardsup/c_interfaces.c delete mode 100644 hardsup/dillutil.c delete mode 100644 hardsup/dillutil.h delete mode 100644 hardsup/el734_def.h delete mode 100644 hardsup/el734_errcodes.h delete mode 100644 hardsup/el734_utility.c delete mode 100644 hardsup/el734fix.h delete mode 100644 hardsup/el734tcl.c delete mode 100644 hardsup/el737_def.h delete mode 100644 hardsup/el737_errcodes.h delete mode 100644 hardsup/el737_utility.c delete mode 100644 hardsup/el737fix.h delete mode 100644 hardsup/el737tcl.c delete mode 100644 hardsup/el755_def.h delete mode 100644 hardsup/el755_errcodes.h delete mode 100644 hardsup/el755_errorlog.c delete mode 100644 hardsup/el755_utility.c delete mode 100644 hardsup/err.c delete mode 100644 hardsup/failinet.c delete mode 100644 hardsup/geterrno.c delete mode 100644 hardsup/itc4util.c delete mode 100644 hardsup/itc4util.h delete mode 100644 hardsup/make_gen delete mode 100644 hardsup/makefile_linux delete mode 100644 hardsup/makeprint.c delete mode 100644 hardsup/rs232c_def.h delete mode 100644 hardsup/serialsinq.c delete mode 100644 hardsup/serialsinq.h delete mode 100644 hardsup/sinq_defs.h delete mode 100644 hardsup/sinq_prototypes.h delete mode 100644 hardsup/sinqhm.c delete mode 100644 hardsup/sinqhm.h delete mode 100644 hardsup/sinqhm.i delete mode 100644 hardsup/sinqhm.tex delete mode 100644 hardsup/sinqhm.w delete mode 100644 hardsup/sinqhm_def.h delete mode 100644 hardsup/stredit.c delete mode 100644 hardsup/strjoin.c delete mode 100644 hardsup/table.c delete mode 100644 hardsup/table.h delete mode 100644 hardsup/velsel_def.h delete mode 100644 hardsup/velsel_utility.c delete mode 100644 itc4.c delete mode 100644 itc4.h delete mode 100644 itc4.w delete mode 100644 itc4driv.c delete mode 100644 ltc11.c delete mode 100644 ltc11.h create mode 100644 make_gen_dummy create mode 100644 makefile_alpha_dummy delete mode 100644 motor/Makefile delete mode 100644 motor/el734_test.c delete mode 100644 motor/makeprint.c delete mode 100644 motor/test.dat delete mode 100644 nextrics.c delete mode 100644 nextrics.h delete mode 100644 nxamor.c delete mode 100644 nxamor.h delete mode 100644 nxamor.tex delete mode 100644 nxamor.w delete mode 100644 nxsans.c delete mode 100644 nxsans.h delete mode 100644 pimotor.c delete mode 100644 pimotor.h delete mode 100644 pimotor.tex delete mode 100644 pimotor.w delete mode 100644 pipiezo.c delete mode 100644 polterwrite.c delete mode 100644 polterwrite.h delete mode 100644 ruli.c delete mode 100644 ruli.h delete mode 100644 sanscook.c delete mode 100644 sanswave.c delete mode 100644 sanswave.h delete mode 100644 sanswave.tex delete mode 100644 sanswave.w delete mode 100644 serial.c delete mode 100644 serial.h delete mode 100644 serial.w delete mode 100755 sinqhm/FOCUS_gbl.h delete mode 100755 sinqhm/FOCUS_srv_main.c delete mode 100644 sinqhm/Makefile delete mode 100755 sinqhm/SinqHM_bootParamsConfig.c delete mode 100755 sinqhm/SinqHM_bootUtil.c delete mode 100755 sinqhm/SinqHM_def.h delete mode 100755 sinqhm/SinqHM_gbl.h delete mode 100755 sinqhm/SinqHM_srv_filler.c delete mode 100755 sinqhm/SinqHM_srv_main.c delete mode 100755 sinqhm/SinqHM_srv_routines.c delete mode 100755 sinqhm/SinqHM_srv_server.c delete mode 100755 sinqhm/bld delete mode 100755 sinqhm/bld2 delete mode 100755 sinqhm/bldmen delete mode 100755 sinqhm/hist_mem_notes.tex delete mode 100755 sinqhm/hist_mem_spec.tex delete mode 100755 sinqhm/hist_mem_spec_fig1.ps delete mode 100755 sinqhm/hist_mem_spec_fig2.ps delete mode 100755 sinqhm/hist_mem_spec_fig3.ps delete mode 100755 sinqhm/hist_mem_spec_fig4.ps delete mode 100755 sinqhm/lwl_client.c delete mode 100755 sinqhm/lwl_server.c delete mode 100755 sinqhm/make_sinqhm.com delete mode 100644 sinqhm/monitor.c delete mode 100755 sinqhm/psi_logo.ps delete mode 100755 sinqhm/sinq_logo.ps delete mode 100755 sinqhm/sinqhm_bootutil_client.c delete mode 100755 sinqhm/sinqhm_client.c delete mode 100755 sinqhm/sinqhm_ctrl.c delete mode 100755 sinqhm/usrConfig.c delete mode 100755 sinqhm/usrConfig.c_diffs delete mode 100755 sinqhm/usrConfig2604.c delete mode 100755 sinqhm/vmio10_def.h delete mode 100755 sinqhm/vmio_utility.c delete mode 100644 sinqhmdriv.c delete mode 100644 sinqhmdriv.i delete mode 100644 sinqhmdriv.w create mode 100644 site.h create mode 100644 site.w delete mode 100644 slsmagnet.c delete mode 100644 sps.c delete mode 100644 sps.h delete mode 100644 sps.i delete mode 100644 sps.tex delete mode 100644 sps.w delete mode 100644 swmotor.c delete mode 100644 swmotor.h delete mode 100644 swmotor.i delete mode 100644 tas.c delete mode 100644 tas.h delete mode 100644 tas.w delete mode 100644 tasdrive.c delete mode 100644 tasinit.c delete mode 100644 tasscan.c delete mode 100644 tasu.h delete mode 100644 tasutil.c delete mode 100644 tdchm.c delete mode 100644 tdchm.h delete mode 100644 tecs/coc_client.c delete mode 100644 tecs/coc_client.h delete mode 100644 tecs/coc_logfile.c delete mode 100644 tecs/coc_logfile.h delete mode 100644 tecs/coc_server.c delete mode 100644 tecs/coc_server.h delete mode 100644 tecs/coc_util.c delete mode 100644 tecs/coc_util.h delete mode 100644 tecs/fortify1.c delete mode 100644 tecs/instr_hosts.c delete mode 100644 tecs/instr_hosts.h delete mode 100644 tecs/keep_running.c delete mode 100644 tecs/make_gen delete mode 100644 tecs/make_opt delete mode 100644 tecs/make_opt_alpha delete mode 100644 tecs/make_opt_llc delete mode 100644 tecs/makefile delete mode 100644 tecs/makefile_alpha delete mode 100644 tecs/makefile_linux delete mode 100644 tecs/myc_buf.c delete mode 100644 tecs/myc_buf.h delete mode 100644 tecs/myc_err.c delete mode 100644 tecs/myc_err.h delete mode 100755 tecs/myc_fortran.h delete mode 100644 tecs/myc_mem.h delete mode 100644 tecs/myc_str.c delete mode 100644 tecs/myc_str.h delete mode 100644 tecs/myc_time.c delete mode 100644 tecs/myc_time.h delete mode 100644 tecs/myc_tmp.c delete mode 100644 tecs/myc_tmp.h delete mode 100644 tecs/rstart.c delete mode 100644 tecs/six.c delete mode 100644 tecs/str.f delete mode 100755 tecs/sys_cmdpar.f delete mode 100755 tecs/sys_date.f delete mode 100755 tecs/sys_env.c delete mode 100644 tecs/sys_get_key.f delete mode 100755 tecs/sys_getenv.f delete mode 100755 tecs/sys_lun.f delete mode 100755 tecs/sys_open.f delete mode 100755 tecs/sys_open_alpha.f delete mode 100755 tecs/sys_rdline.c delete mode 100644 tecs/sys_select.c delete mode 100644 tecs/sys_select.h delete mode 100755 tecs/sys_unix.c delete mode 100755 tecs/sys_wait.f delete mode 100644 tecs/tecs.bld delete mode 100644 tecs/tecs.c delete mode 100644 tecs/tecs.tcl delete mode 100644 tecs/tecs_c.c delete mode 100644 tecs/tecs_c.h delete mode 100644 tecs/tecs_cli.c delete mode 100644 tecs/tecs_cli.h delete mode 100644 tecs/tecs_client.f delete mode 100644 tecs/tecs_data.c delete mode 100644 tecs/tecs_data.h delete mode 100644 tecs/tecs_dlog.inc delete mode 100644 tecs/tecs_for.f delete mode 100644 tecs/tecs_lsc.c delete mode 100644 tecs/tecs_lsc.h delete mode 100644 tecs/tecs_plot.f delete mode 100644 tecs/tecs_serial.c delete mode 100644 tecs/tecs_serial.h delete mode 100644 tecs/term.c delete mode 100644 tecs/term.h delete mode 100644 tecsdriv.c delete mode 100644 tecsdriv.h delete mode 100644 utils/Makefile delete mode 100755 utils/SerPortServer.c delete mode 100755 utils/asynsrv_test.c delete mode 100755 utils/check/amorcheck delete mode 100755 utils/check/dmccheck delete mode 100755 utils/check/focuscheck delete mode 100755 utils/check/hrptcheck delete mode 100755 utils/check/sanscheck delete mode 100644 utils/check/sicssyntax.tex delete mode 100644 utils/check/sicssyntaxlib.tcl delete mode 100755 utils/check/topsicheck delete mode 100755 utils/check/tricscheck delete mode 100755 utils/el734.c delete mode 100755 utils/el734_test.c delete mode 100755 utils/el737.c delete mode 100644 velodorn.c delete mode 100644 velodorn.h delete mode 100644 velodorn.tex delete mode 100644 velodorn.w delete mode 100644 velodornier.c diff --git a/A1931.c b/A1931.c deleted file mode 100644 index b9585513..00000000 --- a/A1931.c +++ /dev/null @@ -1,344 +0,0 @@ -/*------------------------------------------------------------------------- - This is the implementation file for a driver for the Risoe A1931a - temperature controller. This driver controls the device through a GPIB - interface. - - copyright: see file COPYRIGHT - - Mark Koennecke, February 2003 - -------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include -#include -#include "fortify.h" -#include "sics.h" -#include "obpar.h" -#include "evcontroller.h" -#include "evcontroller.i" -#include "evdriver.i" -#include "gpibcontroller.h" -#include "A1931.h" - -/*========================== private data structure ====================*/ -typedef struct { - int sensor; /* the control sensor */ - pGPIB gpib; /* the GPIB interface to use in order to talk to the thing*/ - int gpibAddress; /* address on bus */ - int devID; /* deviceID of the controller on the GPIB */ - char errorBuffer[132]; /* a buffer for error messages from the thing*/ - char commandLine[132]; /* buffer to keep the offending command line */ - int errorCode; /* error indicator */ -}A1931, *pA1931; -/*============================ defines ================================*/ -#define COMMERROR -300 -#define A1931ERROR -301 -#define FILEERROR -302 -/*====================================================================*/ -static char *A1931comm(pEVDriver pData, char *command){ - char buffer[256], *pPtr; - int status; - pA1931 self = NULL; - Tcl_DString reply; - - self = (pA1931)pData->pPrivate; - assert(self); - - /* - send - */ - strncpy(buffer,command,250); - strcat(buffer,"\n"); - status = GPIBsend(self->gpib,self->devID,buffer,(int)strlen(buffer)); - if(status < 0){ - self->errorCode = COMMERROR; - GPIBerrorDescription(self->gpib,status,self->errorBuffer,131); - return NULL; - } - - /* - read until > is found - */ - Tcl_DStringInit(&reply); - while(1){ - pPtr = GPIBreadTillTerm(self->gpib,self->devID,10); - if(strstr(pPtr,"GPIB READ ERROR") != NULL){ - free(pPtr); - self->errorCode = COMMERROR; - Tcl_DStringFree(&reply); - return NULL; - } else { - Tcl_DStringAppend(&reply,pPtr,-1); - if(strchr(pPtr,'>') != NULL){ - /* - finished - */ - free(pPtr); - break; - } - free(pPtr); - } - } - pPtr = NULL; - pPtr = strdup(Tcl_DStringValue(&reply)); - Tcl_DStringFree(&reply); - if(pPtr[0] == '#'){ - /* - error - */ - self->errorCode = A1931ERROR; - strncpy(self->errorBuffer,pPtr,131); - free(pPtr); - return NULL; - } - return pPtr; -} -/*--------------------------------------------------------------------*/ -static int A1931command(pEVDriver pData, char *command, char *replyBuffer, - int replyBufferLen){ - pA1931 self = NULL; - char *pReply = NULL; - - self = (pA1931)pData->pPrivate; - assert(self); - - pReply = A1931comm(pData,command); - if(pReply != NULL){ - strncpy(replyBuffer,pReply,replyBufferLen); - free(pReply); - return 1; - } else { - strncpy(replyBuffer,self->errorBuffer,replyBufferLen); - return 0; - } -} -/*====================================================================*/ -static int A1931Init(pEVDriver pData){ - pA1931 self = NULL; - - self = (pA1931)pData->pPrivate; - assert(self); - - self->devID = GPIBattach(self->gpib,0,self->gpibAddress,0,13,0,0); - if(self->devID < 0){ - return 0; - } - return 1; -} -/*====================================================================*/ -static int A1931Close(pEVDriver pData){ - pA1931 self = NULL; - - self = (pA1931)pData->pPrivate; - assert(self); - - GPIBdetach(self->gpib,self->devID); - self->devID = 0; - return 1; -} -/*===================================================================*/ -static int A1931Get(pEVDriver pData,float *fPos){ - pA1931 self = NULL; - char buffer[132], command[50]; - int status; - - self = (pA1931)pData->pPrivate; - assert(self); - - sprintf(command,"?TEMP%1.1d",self->sensor); - status = A1931command(pData,command,buffer,131); - if(!status){ - return 0; - } - sscanf(buffer,"%f",fPos); - return 1; -} -/*=====================================================================*/ -static int A1931Set(pEVDriver pData, float fNew){ - pA1931 self = NULL; - char buffer[132], command[50]; - int status; - - self = (pA1931)pData->pPrivate; - assert(self); - - sprintf(command,"SET%1.1d=%f",self->sensor,fNew); - status = A1931command(pData,command,buffer,131); - if(!status){ - return 0; - } - return 1; -} -/*====================================================================*/ -static int A1931error(pEVDriver pData, int *iCode, char *errBuff, int bufLen){ - pA1931 self = NULL; - char pError[256]; - - self = (pA1931)pData->pPrivate; - assert(self); - - *iCode = self->errorCode; - sprintf(pError,"ERROR: %s",self->errorBuffer); - strncpy(errBuff,pError,bufLen); - return 1; -} -/*====================================================================*/ -static int A1931fix(pEVDriver pData, int iCode){ - pA1931 self = NULL; - char pError[256]; - - self = (pA1931)pData->pPrivate; - assert(self); - - if(iCode == COMMERROR){ - GPIBclear(self->gpib,self->devID); - return DEVREDO; - } - return DEVFAULT; -} -/*=====================================================================*/ -pEVDriver CreateA1931Driver(int argc, char *argv[]){ - pEVDriver self = NULL; - pA1931 priv = NULL; - - if(argc < 2){ - return NULL; - } - - /* - allocate space - */ - self = CreateEVDriver(argc,argv); - priv = (pA1931)malloc(sizeof(A1931)); - if(self == NULL || priv == NULL){ - return NULL; - } - memset(priv,0,sizeof(A1931)); - self->pPrivate = priv; - self->KillPrivate = free; - - /* - initialize - */ - priv->gpib = (pGPIB)FindCommandData(pServ->pSics,argv[0],"GPIB"); - if(!priv->gpib){ - DeleteEVDriver(self); - return NULL; - } - priv->sensor = 1; - priv->gpibAddress = atoi(argv[1]); - - /* - initialize function pointers - */ - self->Send = A1931command; - self->Init = A1931Init; - self->Close = A1931Close; - self->GetValue = A1931Get; - self->SetValue = A1931Set; - self->GetError = A1931error; - self->TryFixIt = A1931fix; - - return self; -} -/*=======================================================================*/ -static int downloadFile(pA1931 self, FILE *fd){ - char buffer[132], *pPtr; - int status; - - while(1){ - if(fgets(buffer,130,fd) == NULL){ - self->errorCode = FILEERROR; - strcpy(self->errorBuffer,"Failed to read from file"); - return 0; - } - if(strstr(buffer,"$END") != NULL){ - break; - } - status = GPIBsend(self->gpib,self->devID,buffer,(int)strlen(buffer)); - if(status < 0){ - self->errorCode = COMMERROR; - GPIBerrorDescription(self->gpib,status,self->errorBuffer,131); - return 0; - } - pPtr = GPIBreadTillTerm(self->gpib,self->devID,10); - if(pPtr[0] == '#'){ - self->errorCode = A1931ERROR; - strncpy(self->errorBuffer,pPtr,131); - strncpy(self->commandLine,buffer,131); - free(pPtr); - return 0; - } - free(pPtr); - usleep(50); - } - return 1; -} -/*=======================================================================*/ -int A1931Action(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]){ - pEVControl pEV = NULL; - pA1931 self = NULL; - char buffer[256]; - char error[132]; - FILE *fd = NULL; - int status, iCode; - - pEV = (pEVControl)pData; - assert(pEV); - self = (pA1931)pEV->pDriv->pPrivate; - assert(self); - - if(argc > 1){ - strtolower(argv[1]); - if(strcmp(argv[1],"sensor") == 0){ - if(argc > 2){ - /* set case */ - if(!SCMatchRights(pCon,usUser)){ - return 0; - } - self->sensor = atoi(argv[2]); - SCSendOK(pCon); - return 1; - } else { - /* get case */ - sprintf(buffer,"%s.sensor = %d",argv[0],self->sensor); - SCWrite(pCon,buffer,eValue); - return 1; - } - }else if(strcmp(argv[1],"list") == 0){ - sprintf(buffer,"%s.sensor = %d",argv[0],self->sensor); - SCWrite(pCon,buffer,eValue); - return EVControlWrapper(pCon,pSics,pData,argc,argv); - } else if(strcmp(argv[1],"file") == 0){ - if(!SCMatchRights(pCon,usUser)){ - return 0; - } - if(argc < 3){ - SCWrite(pCon,"ERROR: need filename argument",eError); - return 0; - } - fd = fopen(argv[2],"r"); - if(fd == NULL){ - sprintf(buffer,"ERROR: failed to open %s", argv[2]); - SCWrite(pCon,buffer,eError); - return 0; - } - status = downloadFile(self,fd); - fclose(fd); - if(!status){ - A1931error(pEV->pDriv,&iCode,error,131); - sprintf(buffer,"%s while transfering file", error); - SCWrite(pCon,buffer,eError); - sprintf(buffer,"Offending command: %s",self->commandLine); - SCWrite(pCon,buffer,eError); - return 0; - } - SCSendOK(pCon); - return 1; - } - } - return EVControlWrapper(pCon,pSics,pData,argc,argv); -} diff --git a/A1931.h b/A1931.h deleted file mode 100644 index 954813f7..00000000 --- a/A1931.h +++ /dev/null @@ -1,20 +0,0 @@ -/*------------------------------------------------------------------------- - This is the header file for a driver for the Risoe A1931a temperature - controller. This driver controls the device through a GPIB interface. - - copyright: see file COPYRIGHT - - Mark Koennecke, February 2003 - -------------------------------------------------------------------------*/ -#ifndef A1931A -#define A19131A - -#include "sics.h" - -pEVDriver CreateA1931Driver(int argc, char *argv[]); - -int A1931Action(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - - -#endif diff --git a/amor2t.c b/amor2t.c deleted file mode 100644 index 96bf3b7f..00000000 --- a/amor2t.c +++ /dev/null @@ -1,996 +0,0 @@ -/*--------------------------------------------------------------------------- - A M O R 2 T - - A class for controlling the two theta movement of the reflectometer - AMOR at SINQ. It is not clear if this class may be useful for other - reflectometers, too. At AMOR the two theta movement of the detector is - realized by translating the detector along x and z. Also it can be - tilted in omega. Furthermore the height of two diaphragms has to be - adjusted when moving two theta as well. In polarizing mode the analyzer - mirror has to be moved as well. - - copyright: see copyright.h - - Mark Koennecke, September 1999 - - Bugs fixed, analyzer included for A2T. Then there is a second thing: - aoz2t which allows to scan the analyzer in two-theta during alignment - of the instrument. As all the parameters are already held in the a2t - structures this extra was added into this module. - - Mark Koennecke, May-June 2000 ----------------------------------------------------------------------------*/ -#include -#include -#include -#include "fortify.h" -#include -#include "sics.h" -#include "motor.h" -#include "obpar.h" - -#define DEBUG 1 - -#define MAXMOT 13 -#define MAXPAR 13 - -#include "amor2t.i" -#include "amor2t.h" - -/* - Defines for accessing various motors and variables. Definition of motor: see - annotated AMOR drawing. -*/ - -/* monochromator omega */ -#define MOTMOM 0 -/* sample omega */ -#define MOTSOM 1 -/* detector height movement */ -#define MOTCOZ 2 -/* detector movement along main axis */ -#define MOTCOX 3 -/* sample holder height movement */ -#define MOTSTZ 4 -/* whole sample table height movement */ -#define MOTSOZ 5 -/* lift for diaphragm 4*/ -#define MOTD4B 6 -/* lift for diaphragm 5 */ -#define MOTD5B 7 -/* detector omega movement */ -#define MOTCOM 8 -/* lift for analyzer */ -#define MOTAOZ 9 -/* analyzer omega */ -#define MOTAOM 10 -/* detector 2 movement */ -#define MOTC3Z 11 - - -/*====================================================================== - The core of it all: The calculation of the settings for the various - motors. -========================================================================*/ - static int CalculateAMORE(pAmor2T self, SConnection *pCon, float fNew) - { - float fMOM, fSOM, fSTZ, fSOZ, fAOM, fAOZ, fC3Z, fconstAOM; - double fAngle, fX, fZ, fZ2, fBase, fPIR; - float fCOZ, fCOX, fCOM; - int iRet; -#ifdef DEBUG - char pBueffel[132]; -#endif - - /* get the necessary angles first */ - iRet = MotorGetSoftPosition(self->aEngine[MOTMOM],pCon,&fMOM); - if(iRet != 1) - { - return iRet; - } - iRet = MotorGetSoftPosition(self->aEngine[MOTSOM],pCon,&fSOM); - if(iRet != 1) - { - return iRet; - } - iRet = MotorGetSoftPosition(self->aEngine[MOTSTZ],pCon,&fSTZ); - if(iRet != 1) - { - return iRet; - } - iRet = MotorGetSoftPosition(self->aEngine[MOTSOZ],pCon,&fSOZ); - if(iRet != 1) - { - return iRet; - } - - /* calculate base height of sample table */ - fBase = fSOZ + ObVal(self->aParameter,PARDH); - fPIR = 180. / 3.1415926; - - /* calculation for detector */ - fAngle = fNew - 2*fMOM; - if(fAngle < 0) - { - fAngle = fAngle + 360.; - } - fAngle /= fPIR; - fX = ObVal(self->aParameter,PARDS)*cos(fAngle); - fZ = ObVal(self->aParameter,PARDS)*sin(fAngle); - self->toStart[0].pMot = self->aEngine[MOTCOX]; - strcpy(self->toStart[0].pName,self->aEngine[MOTCOX]->name); - self->toStart[0].fTarget = fX - ObVal(self->aParameter,PARDS); - self->toStart[1].pMot = self->aEngine[MOTCOZ]; - strcpy(self->toStart[1].pName,self->aEngine[MOTCOZ]->name); - self->toStart[1].fTarget = fZ + fBase - - ObVal(self->aParameter,PARDDH); - self->toStart[2].pMot = self->aEngine[MOTCOM]; - strcpy(self->toStart[2].pName,self->aEngine[MOTCOM]->name); - self->toStart[2].fTarget = fNew - 2*fMOM; - self->iStart = 3; - - /* calculation for diaphragm 4 */ - fZ = ObVal(self->aParameter,PARDD4) * sin(fAngle); - self->toStart[3].pMot = self->aEngine[MOTD4B]; - strcpy(self->toStart[3].pName,self->aEngine[MOTD4B]->name); - self->toStart[3].fTarget = fBase + fZ - - ObVal(self->aParameter,PARD4H); - self->iStart = 4; - - /* calculation for diaphragm 5 */ - fZ = ObVal(self->aParameter,PARDD5) * sin(fAngle); - self->toStart[4].pMot = self->aEngine[MOTD5B]; - strcpy(self->toStart[4].pName,self->aEngine[MOTD5B]->name); - self->toStart[4].fTarget = fBase + fZ - - ObVal(self->aParameter,PARD5H); - self->iStart = 5; -#ifdef DEBUG - sprintf(pBueffel,"2T COZ COX COM D4B D5B "); - SCWrite(pCon,pBueffel,eValue); - sprintf(pBueffel,"%6.2f %6.2f %6.2f %6.2f %6.2f %6.2f", - fNew, self->toStart[1].fTarget, self->toStart[0].fTarget, - self->toStart[2].fTarget, self->toStart[3].fTarget, - self->toStart[4].fTarget); - SCWrite(pCon,pBueffel,eValue); -#endif - - if(ObVal(self->aParameter,ANAFLAG) > 0) - { - /* the analyzer height */ - fZ = ObVal(self->aParameter,PARADIS)*sin(fAngle); - fAOZ = fBase + fZ - ObVal(self->aParameter,PARANA); - self->toStart[5].pMot = self->aEngine[MOTAOZ]; - strcpy(self->toStart[5].pName,self->aEngine[MOTAOZ]->name); - self->toStart[5].fTarget = fAOZ; - self->iStart = 6; - - /* analyzer omega */ - self->toStart[6].pMot = self->aEngine[MOTAOM]; - strcpy(self->toStart[6].pName,self->aEngine[MOTAOM]->name); - self->toStart[6].fTarget = fNew/2. - + ObVal(self->aParameter,PARAOM); - self->iStart = 7; - - /* C3Z */ - fZ2 = (ObVal(self->aParameter,PARDS) - ObVal(self->aParameter, - PARADIS))*sin(fAngle + (fNew/fPIR) ); - - self->toStart[7].pMot = self->aEngine[MOTC3Z]; - strcpy(self->toStart[7].pName,self->aEngine[MOTC3Z]->name); - self->toStart[7].fTarget = fBase + fZ + fZ2 - - ObVal(self->aParameter,PARDDD) - - self->toStart[1].fTarget; - self->iStart = 8; -#ifdef DEBUG - sprintf(pBueffel,"2T AOZ AOM C3Z"); - SCWrite(pCon,pBueffel,eValue); - sprintf(pBueffel,"%6.2f %6.2f %6.2f %6.2f", - fNew, self->toStart[5].fTarget, self->toStart[6].fTarget, - self->toStart[7].fTarget); - SCWrite(pCon,pBueffel,eValue); -#endif - - } - return 1; - } -/*======================================================================= - Calculations for Analyzer two theta -=========================================================================*/ - static int CalculateANA2T(pAmor2T self, SConnection *pCon, float fNew) - { - double fBase, fPIR; - float fAOZ, fIncident, fSOM, fMOM, fDiffracted, fDistance, fX, fZ; - int iRet; -#ifdef DEBUG - char pBueffel[132]; -#endif - - /* calculate base height of analyzer table */ - iRet = MotorGetSoftPosition(self->aEngine[MOTSOZ],pCon,&fAOZ); - if(iRet != 1) - { - return iRet; - } - fBase = fAOZ + ObVal(self->aParameter,PARANA); - fPIR = 180. / 3.1415926; - - /* Calculate the incident angle at the analyzer */ - iRet = MotorGetSoftPosition(self->aEngine[MOTSOM],pCon,&fSOM); - if(iRet != 1) - { - return iRet; - } - iRet = MotorGetSoftPosition(self->aEngine[MOTMOM],pCon,&fMOM); - if(iRet != 1) - { - return iRet; - } - fIncident = fMOM + 2. * fSOM; - - /* calculate the angle of the diffracted beam against the - horizon at the analyzer. - - fDiffracted = fIncident - 2. * AOM. - - There is a problem here. We should read AOM in order to get the - value. However in the context of an omega - two-theta scan on AOM - and ana2t, it is fNew. - */ - fDiffracted = fIncident - fNew; - - - /* calculation for detector */ - fDiffracted /= fPIR; - fDistance = ObVal(self->aParameter,PARDS) - - ObVal(self->aParameter, PARANA); - fX = fDistance*cos(fDiffracted); - fZ = fDistance*sin(fDiffracted); - self->toStart[0].pMot = self->aEngine[MOTCOX]; - strcpy(self->toStart[0].pName,self->aEngine[MOTCOX]->name); - self->toStart[0].fTarget = fX - fDistance; - - self->toStart[1].pMot = self->aEngine[MOTCOZ]; - strcpy(self->toStart[1].pName,self->aEngine[MOTCOZ]->name); - self->toStart[1].fTarget = fZ + fBase - - ObVal(self->aParameter,PARDDH); - - self->toStart[2].pMot = self->aEngine[MOTCOM]; - strcpy(self->toStart[2].pName,self->aEngine[MOTCOM]->name); - self->toStart[2].fTarget = -fDiffracted*fPIR; - self->iStart = 3; - - /* calculation for diaphragm 5 */ - fZ = ObVal(self->aParameter,PARDD5) * sin(fDiffracted); - self->toStart[3].pMot = self->aEngine[MOTD5B]; - strcpy(self->toStart[3].pName,self->aEngine[MOTD5B]->name); - self->toStart[3].fTarget = fBase + fZ - - ObVal(self->aParameter,PARD5H); - self->iStart = 4; - -#ifdef DEBUG - sprintf(pBueffel,"2T COX COZ COM D5B "); - SCWrite(pCon,pBueffel,eValue); - sprintf(pBueffel,"%6.2f %6.2f %6.2f %6.2f %6.2f ", - fNew, self->toStart[0].fTarget, self->toStart[1].fTarget, - self->toStart[2].fTarget,self->toStart[3].fTarget); - SCWrite(pCon,pBueffel,eValue); -#endif - - return 1; - } -/*======================================================================== - Definition of interface functions. -=========================================================================*/ - static long A2TSetValue(void *pData, SConnection *pCon, float fNew) - { - int i, iRet; - pIDrivable pDriv = NULL; - pAmor2T self = (pAmor2T) pData; - - assert(self); - - /* calculation */ - iRet = CalculateAMORE(self,pCon,fNew); - if(iRet != 1) - { - return iRet; - } - - /* start them all */ - for(i = 0; i < self->iStart; i++) - { - pDriv = self->toStart[i].pMot->pDescriptor->GetInterface( - self->toStart[i].pMot,DRIVEID); - if(pDriv != NULL) - { - iRet = pDriv->SetValue(self->toStart[i].pMot,pCon, - self->toStart[i].fTarget); - if(iRet != OKOK) - { - return iRet; - } - } - } - return OKOK; - } -/*--------------------------------------------------------------------*/ - static long ANA2TSetValue(void *pData, SConnection *pCon, float fNew) - { - int i, iRet; - pIDrivable pDriv = NULL; - pAmor2T self = (pAmor2T) pData; - - assert(self); - - /* calculation */ - iRet = CalculateANA2T(self,pCon,fNew); - if(iRet != 1) - { - return iRet; - } - - /* start them all */ - for(i = 0; i < self->iStart; i++) - { - pDriv = self->toStart[i].pMot->pDescriptor->GetInterface( - self->toStart[i].pMot,DRIVEID); - if(pDriv != NULL) - { - iRet = pDriv->SetValue(self->toStart[i].pMot,pCon, - self->toStart[i].fTarget); - if(iRet != OKOK) - { - return iRet; - } - } - } - return OKOK; - } -/*-------------------------------------------------------------------------*/ - static int A2THalt(void *pData) - { - int i, iRet; - pIDrivable pDriv = NULL; - pAmor2T self = (pAmor2T) pData; - - assert(self); - - /* stop them all */ - for(i = 0; i < self->iStart; i++) - { - pDriv = self->toStart[i].pMot->pDescriptor->GetInterface( - self->toStart[i].pMot,DRIVEID); - if(pDriv != NULL) - { - iRet = pDriv->Halt(self->toStart[i].pMot); - } - } - return OKOK; - } -/*-----------------------------------------------------------------------*/ - static int A2TCheck(void *pData, float fNew, char *error, int iErrLen) - { - int i, iRet; - pIDrivable pDriv = NULL; - pAmor2T self = (pAmor2T) pData; - SConnection *pDumCon = NULL; - - - assert(self); - pDumCon = SCCreateDummyConnection(pServ->pSics); - assert(pDumCon); - - /* calculation */ - iRet = CalculateAMORE(self,pDumCon,fNew); - SCDeleteConnection(pDumCon); - if(iRet != 1) - { - return iRet; - } - - /* check them all */ - for(i = 0; i < self->iStart; i++) - { - pDriv = self->toStart[i].pMot->pDescriptor->GetInterface( - self->toStart[i].pMot,DRIVEID); - if(pDriv != NULL) - { - iRet = pDriv->CheckLimits(self->toStart[i].pMot, - self->toStart[i].fTarget, - error,iErrLen); - if(iRet != 1) - { - return iRet; - } - } - } - return 1; - } -/*-------------------------------------------------------------------*/ - static int ANA2TCheck(void *pData, float fNew, char *error, int iErrLen) - { - int i, iRet; - pIDrivable pDriv = NULL; - pAmor2T self = (pAmor2T) pData; - SConnection *pDumCon = NULL; - - - assert(self); - pDumCon = SCCreateDummyConnection(pServ->pSics); - assert(pDumCon); - - /* calculation */ - iRet = CalculateANA2T(self,pDumCon,fNew); - SCDeleteConnection(pDumCon); - if(iRet != 1) - { - return iRet; - } - - /* check them all */ - for(i = 0; i < self->iStart; i++) - { - pDriv = self->toStart[i].pMot->pDescriptor->GetInterface( - self->toStart[i].pMot,DRIVEID); - if(pDriv != NULL) - { - iRet = pDriv->CheckLimits(self->toStart[i].pMot, - self->toStart[i].fTarget, - error,iErrLen); - if(iRet != 1) - { - return iRet; - } - } - } - return 1; - } -/*------------------------------------------------------------------------*/ - static int A2TStatus(void *pData, SConnection *pCon) - { - int i, iRet; - pIDrivable pDriv = NULL; - pAmor2T self = (pAmor2T) pData; - - assert(self); - - /* check them all */ - for(i = 0; i < self->iStart; i++) - { - pDriv = self->toStart[i].pMot->pDescriptor->GetInterface( - self->toStart[i].pMot,DRIVEID); - if(pDriv != NULL) - { - iRet = pDriv->CheckStatus(self->toStart[i].pMot,pCon); - if( (iRet != OKOK) && (iRet != HWIdle) ) - { - return iRet; - } - } - } - return iRet; - } -/*------------------------------------------------------------------------*/ - static float A2TGetValue(void *pData, SConnection *pCon) - { - float fVal, fMOM, fResult; - int iRet; - pAmor2T self = (pAmor2T) pData; - - assert(self); - - /* get COM */ - iRet = MotorGetSoftPosition(self->aEngine[MOTCOM], pCon, &fVal); - if(!iRet) - { - return -9999.99; - } - /* get MOM */ - iRet = MotorGetSoftPosition(self->aEngine[MOTMOM], pCon, &fMOM); - if(!iRet) - { - return -9999.99; - } - - /* retrocalculate 2 theta */ - fResult = fVal + 2*fMOM; - return fResult; - } -/*------------------------------------------------------------------------*/ - static float ANA2TGetValue(void *pData, SConnection *pCon) - { - float fVal, fMOM, fResult; - int iRet; - pAmor2T self = (pAmor2T) pData; - - assert(self); - - /* get AOM */ - iRet = MotorGetSoftPosition(self->aEngine[MOTAOM], pCon, &fVal); - if(!iRet) - { - return -9999.99; - } - - return 2. * fVal; - - } -/*-----------------------------------------------------------------------*/ - static void *A2TGetInterface(void *pData, int iID) - { - pAmor2T self = (pAmor2T) pData; - - assert(self); - if(iID == DRIVEID) - { - return self->pDriv; - } - return NULL; - } -/*------------------------------------------------------------------------*/ - static int A2TSave(void *pData, char *name, FILE *fd) - { - int i; - pAmor2T self = (pAmor2T) pData; - - assert(self); - - fprintf(fd,"%s detectord %f \n", name, ObVal(self->aParameter,PARDS)); - fprintf(fd,"%s sampleh %f \n", name, ObVal(self->aParameter,PARDH)); - fprintf(fd,"%s d4d %f \n", name, ObVal(self->aParameter,PARDD4)); - fprintf(fd,"%s d5d %f \n", name, ObVal(self->aParameter,PARDD5)); - fprintf(fd,"%s interrupt %f \n", name, ObVal(self->aParameter,PARINT)); - fprintf(fd,"%s detectorh %f \n", name, ObVal(self->aParameter,PARDDH)); - fprintf(fd,"%s d4h %f \n", name, ObVal(self->aParameter,PARD4H)); - fprintf(fd,"%s d5h %f \n", name, ObVal(self->aParameter,PARD5H)); - fprintf(fd,"%s anah %f \n", name, ObVal(self->aParameter,PARANA)); - fprintf(fd,"%s anad %f \n", name, ObVal(self->aParameter,PARADIS)); - fprintf(fd,"%s anaflag %f \n", name, ObVal(self->aParameter,ANAFLAG)); - fprintf(fd,"%s c2h %f \n", name, ObVal(self->aParameter,PARDDD)); - fprintf(fd,"%s aomconst %f \n", name, ObVal(self->aParameter,PARAOM)); - return 1; - } -/*------------------------------------------------------------------------*/ - static void A2TList(pAmor2T self, SConnection *pCon, char *name) - { - char pBueffel[132]; - Tcl_DString tString; - - assert(pCon); - assert(self); - - Tcl_DStringInit(&tString); - sprintf(pBueffel, - "%s.detectord %f \n", name, ObVal(self->aParameter,PARDS)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.sampleh %f \n", name, ObVal(self->aParameter,PARDH)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.d4d %f \n", name, ObVal(self->aParameter,PARDD4)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.d5d %f \n", name, ObVal(self->aParameter,PARDD5)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.interrupt %f \n", name, ObVal(self->aParameter,PARINT)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.detectorh %f \n", name, ObVal(self->aParameter,PARDDH)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.d4h %f \n", name, ObVal(self->aParameter,PARD4H)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.d5h %f \n", name, ObVal(self->aParameter,PARD5H)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.anah %f \n", name, ObVal(self->aParameter,PARANA)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.anad %f \n", name, ObVal(self->aParameter,PARADIS)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.anaflag %f \n", name, ObVal(self->aParameter,ANAFLAG)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.c2h %f \n", name, ObVal(self->aParameter,PARDDD)); - Tcl_DStringAppend(&tString,pBueffel,-1); - sprintf(pBueffel, - "%s.aomconst %f \n", name, ObVal(self->aParameter,PARAOM)); - Tcl_DStringAppend(&tString,pBueffel,-1); - SCWrite(pCon,Tcl_DStringValue(&tString),eValue); - Tcl_DStringFree(&tString); - } -/*------------------------------------------------------------------------*/ - static void A2TKill(void *pData) - { - pAmor2T self = (pAmor2T) pData; - - if(self == NULL) - return; - - if(self->pDes) - DeleteDescriptor(self->pDes); - - if(self->pDriv) - free(self->pDriv); - - if(self->aParameter) - ObParDelete(self->aParameter); - - free(self); - } -/*-------------------------------------------------------------------------- - Initialization: All is done from the Factory function. This takes an Tcl - array as parameter which is supposed to hold the names of all motors. - This must fail if one of the motors cannot be accessed. ---------------------------------------------------------------------------*/ - int Amor2TFactory(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - pAmor2T pNew, pAOM = NULL; - int i, iRet; - char pBueffel[512]; - char *pMot = NULL; - - if(argc < 4) - { - SCWrite(pCon, - "ERROR: Insufficient number of arguments to Amor2tFactory", - eError); - return 0; - } - - /* allocate space ..............*/ - pNew = (pAmor2T)malloc(sizeof(Amor2T)); - if(!pNew) - { - SCWrite(pCon,"ERROR: out of memory in Amor2TFactory",eError); - return 0; - } - memset(pNew,0,sizeof(Amor2T)); - pNew->pDes = CreateDescriptor("Amor2T"); - pNew->aParameter = ObParCreate(MAXPAR); - pNew->pDriv = CreateDrivableInterface(); - if( (!pNew->pDes) || (!pNew->aParameter) || (!pNew->pDriv) ) - { - SCWrite(pCon,"ERROR: out of memory in Amor2TFactory",eError); - A2TKill(pNew); - return 0; - } - - /* find the motors*/ - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"mom",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for mom motr found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTMOM] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTMOM]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"som",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for som motor found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTSOM] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTSOM]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"coz",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for coz motor found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTCOZ] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTCOZ]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"cox",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for cox motor found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTCOX] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTCOX]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"stz",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for stz motor found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTSTZ] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTSTZ]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"soz",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for soz motor found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTSOZ] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTSOZ]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"d4b",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for d4b motor found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTD4B] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTD4B]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"d5b",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for d5b motor found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTD5B] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTD5B]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"com",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for com motor found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTCOM] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTCOM]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"aoz",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for aoz motor found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTAOZ] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTAOZ]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"aom",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for aom motor found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTAOM] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTAOM]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - pMot = Tcl_GetVar2(pSics->pTcl,argv[2],"c3z",TCL_GLOBAL_ONLY); - if(!pMot) - { - SCWrite(pCon,"ERROR: no value for c3z motor found",eError); - A2TKill(pNew); - return 0; - } - pNew->aEngine[MOTC3Z] = FindMotor(pSics,pMot); - if(!pNew->aEngine[MOTC3Z]) - { - sprintf(pBueffel,"ERROR: motor %s NOT found!", pMot); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - - - /* initialize parameters */ - ObParInit(pNew->aParameter,PARDS,"detectord",1400.,usMugger); - ObParInit(pNew->aParameter,PARDH,"sampleh",50.,usMugger); - ObParInit(pNew->aParameter,PARDD4,"d4d",100.,usMugger); - ObParInit(pNew->aParameter,PARDD5,"d5d",200.,usMugger); - ObParInit(pNew->aParameter,PARINT,"interrupt",0.,usMugger); - ObParInit(pNew->aParameter,PARDDH,"detectorh",40.,usMugger); - ObParInit(pNew->aParameter,PARD4H,"d4h",40.,usMugger); - ObParInit(pNew->aParameter,PARD5H,"d5h",400.,usMugger); - ObParInit(pNew->aParameter,PARANA,"anah",400.,usMugger); - ObParInit(pNew->aParameter,PARADIS,"anad",600.,usMugger); - ObParInit(pNew->aParameter,ANAFLAG,"anaflag",-1.,usMugger); - ObParInit(pNew->aParameter,PARDDD,"c2h",100.,usMugger); - ObParInit(pNew->aParameter,PARAOM,"aomconst",3.,usMugger); - - - /* initialize interfaces */ - pNew->pDes->GetInterface = A2TGetInterface; - pNew->pDes->SaveStatus = A2TSave; - pNew->pDriv->Halt = A2THalt; - pNew->pDriv->CheckLimits = A2TCheck; - pNew->pDriv->SetValue = A2TSetValue; - pNew->pDriv->CheckStatus = A2TStatus; - pNew->pDriv->GetValue = A2TGetValue; - - /* copy data structure for second command for aom2t */ - pAOM = (pAmor2T)malloc(sizeof(Amor2T)); - if(!pAOM) - { - A2TKill(pNew); - SCWrite(pCon,"ERROR: out of memory in Amor2TFactory",eError); - return 0; - } - memcpy(pAOM,pNew,sizeof(Amor2T)); - pAOM->pDriv = CreateDrivableInterface(); - pAOM->pDes = CreateDescriptor("Amor2T"); - if(!pAOM->pDriv || !pAOM->pDes ) - { - A2TKill(pNew); - SCWrite(pCon,"ERROR: out of memory in Amor2TFactory",eError); - return 0; - } - - /* set modified interface functions */ - pAOM->pDes->GetInterface = A2TGetInterface; - pAOM->pDriv->Halt = A2THalt; - pAOM->pDriv->CheckLimits = ANA2TCheck; - pAOM->pDriv->SetValue = ANA2TSetValue; - pAOM->pDriv->GetValue = ANA2TGetValue; - pAOM->pDriv->CheckStatus = A2TStatus; - - - /* install commands */ - iRet = AddCommand(pSics,argv[1], - Amor2TAction,A2TKill,pNew); - if(!iRet) - { - sprintf(pBueffel,"ERROR: duplicate command %s NOT created", - argv[1]); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - iRet = AddCommand(pSics,argv[3], - Amor2TAction,free,pAOM); - if(!iRet) - { - sprintf(pBueffel,"ERROR: duplicate command %s NOT created", - argv[1]); - SCWrite(pCon,pBueffel,eError); - A2TKill(pNew); - return 0; - } - return 1; - } -/*----------------------------------------------------------------------*/ - int Amor2TAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - pAmor2T self = (pAmor2T)pData; - char pBueffel[256]; - float fVal; - double dVal; - ObPar *pPar = NULL; - int iRet; - - assert(self); - - if(argc > 1) - { - strtolower(argv[1]); - /* deal with list */ - if(strcmp(argv[1],"list") == 0) - { - A2TList(self,pCon,argv[0]); - return 1; - } - /* otherwise it should be a parameter command */ - if(argc >= 3) - { - iRet = Tcl_GetDouble(pSics->pTcl,argv[2],&dVal); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: failed to convert %s to number", - argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = ObParSet(self->aParameter,argv[0],argv[1],(float)dVal,pCon); - if(iRet) - { - SCSendOK(pCon); - } - return iRet; - } - else - { - pPar = ObParFind(self->aParameter,argv[1]); - if(!pPar) - { - sprintf(pBueffel,"ERROR: parameter %s NOT found",argv[1]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - sprintf(pBueffel,"%s.%s = %f",argv[0],pPar->name, pPar->fVal); - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } - else - { - fVal = self->pDriv->GetValue(self,pCon); - sprintf(pBueffel," %s = %f", argv[0], fVal); - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } - - - diff --git a/amor2t.h b/amor2t.h deleted file mode 100644 index 6e243cb0..00000000 --- a/amor2t.h +++ /dev/null @@ -1,22 +0,0 @@ - -/*------------------------------------------------------------------------- - A m o r 2 T - A class for controlling the two theta movement of a reflectometer. - Especially the AMOR reflectometer at SINQ. For details see the file - amor2t.tex. DO NOT TOUCH! This file is automatically created from amor2t.w - with nuweb. - - Mark Koennecke, September 1999 ----------------------------------------------------------------------------*/ -#ifndef AMOR2T -#define AMOR2T - - typedef struct __AMOR2T *pAmor2T; - - int Amor2TFactory(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - int Amor2TAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - void Amor2TKill(void *pData); - -#endif diff --git a/amor2t.i b/amor2t.i deleted file mode 100644 index 2bcf2ae0..00000000 --- a/amor2t.i +++ /dev/null @@ -1,55 +0,0 @@ - -/*-------------------------------------------------------------------------- - A m o r 2 T . i - Internal data structure definitions for Amor2T. For details see amor2t.tex. - DO NOT TOUCH! This file is automatically created from amor2t.w. - - Mark Koennecke, September 1999 -----------------------------------------------------------------------------*/ - -/* distance detector sample */ -#define PARDS 0 -/* constant height of sample: height = PARDH + MOTSOZ + MOTSTZ */ -#define PARDH 1 -/* distance diaphragm 4 - sample */ -#define PARDD4 2 -/* distance to diaphragm 5 */ -#define PARDD5 3 -/* interrupt to issue when a motor fails on this */ -#define PARINT 4 -/* base height of counter station */ -#define PARDDH 5 -/* height of D4 */ -#define PARD4H 6 -/* height of D5 */ -#define PARD5H 7 -/* base height of analyzer */ -#define PARANA 8 -/* distance of analyzer from sample */ -#define PARADIS 9 -/* flag analyzer calculation on/off */ -#define ANAFLAG 10 -/* constant for second detector */ -#define PARDDD 11 -/* constant part of AOM */ -#define PARAOM 12 - - - typedef struct { - pMotor pMot; - char pName[80]; - float fTarget; - }MotEntry, *pMotEntry; - - - - typedef struct __AMOR2T { - pObjectDescriptor pDes; - pIDrivable pDriv; - pMotor aEngine[MAXMOT]; - MotEntry toStart[MAXMOT]; - int iStart; - ObPar *aParameter; - }Amor2T; - - diff --git a/amor2t.tex b/amor2t.tex deleted file mode 100644 index c458706b..00000000 --- a/amor2t.tex +++ /dev/null @@ -1,204 +0,0 @@ -\subsection{AMOR Two Theta} -AMOR is SINQ's new reflectometer. It has the peculiar feature that the -two theta movement of the detector is expressed in translations along -the reflectometer base axis and the detector height. Additionally the -detector is tilted. The height of two diaphragms has to be adjusted as -well. And, in polarizing mode, the analyzer has to be operated as -well. Quite a complicated movement. I fear this module may only be -useful for AMOR, but may be, other reflectometers may profit as well. -This object implements this complex movement as a virtual motor. - -The following formulas are used for the necessary calculations: -\begin{eqnarray} -delta height & = & h_{s} - \sin \alpha \\ -delta x & = & |x_{c} - x_{s}| - R \cos \alpha \\ -omega & = & -2 MOM + 2 SOM \\ -\end{eqnarray} -with -\begin{eqnarray} -h_{s} & = & \tan(2MOM)|x_{c} - x_{s}| \\ -R & = & \sqrt{hs^{2} - |x_{c} - x_{s}|^{2}} \\ -\alpha & = & ATT - 2SOM \\ -\beta & = & 180 - 90 - 2MOM \\ -MOM & = & polarizer \omega \\ -SOM & = & sample \omega \\ -x_{c} & = & counter position \\ -x_{s} & = & sample position\\ -\end{eqnarray} -The same equations hold true for the calculations of the diaphragm -heights, just replace the distances. The equations for the analyzer -are not yet known. - -Due to this complicated movement this module needs to know about a lot -of motors and a lot of parameters. The distances of the various -components need to be modified at run time in order to allow for -configuration changes. These are not motorized but must be entered -manually. - -\subsubsection{Data Structures} -Consequently data structures are complex. The first data structure -used is an entry in an array of motors to start: -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap1} -$\langle$putput {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ typedef struct {@\\ -\mbox{}\verb@ pMotor pMot;@\\ -\mbox{}\verb@ char pName[80];@\\ -\mbox{}\verb@ float fTarget;@\\ -\mbox{}\verb@ }MotEntry, *pMotEntry;@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{description} -\item[pMot] is a pointer to the motors data structure. -\item[pName] is the name of the motor to start. -\item[fTarget] is the target value for the motor. -\end{description} - -The next data structure is the class data structure for amor2t: -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap2} -$\langle$amoredata {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ typedef struct __AMOR2T {@\\ -\mbox{}\verb@ pObjectDescriptor pDes;@\\ -\mbox{}\verb@ pIDrivable pDriv;@\\ -\mbox{}\verb@ pMotor aEngine[MAXMOT];@\\ -\mbox{}\verb@ MotEntry toStart[MAXMOT];@\\ -\mbox{}\verb@ int iStart;@\\ -\mbox{}\verb@ ObPar *aParameter;@\\ -\mbox{}\verb@ }Amor2T;@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{description} -\item[pDes] The standard SICS object descriptor. -\item[pDriv] The drivable interface. The functions defined for the -drivable interface implement most of the work of this class. -\item[aEngine] An array of pointers to the motor data structures this -class has to deal with. The proper initialization of this is taken -care of during the initialization of the object. -\item[toStart] An array of motors to start when all calculations have -been performed. -\item[iStart] The number of valid entries in toStart. -\item[aParameter] An array of parameters for this object. -\end{description} - -\subsubsection{The Interface} -The interface to this module is quite primitive. Most of the -functionality is hidden in the drivable interface. So there are only -functions for interacting with the interpreter. - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap3} -$\langle$amorinterface {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ typedef struct __AMOR2T *pAmor2T;@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ int Amor2TFactory(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ -\mbox{}\verb@ int argc, char *argv[]);@\\ -\mbox{}\verb@ int Amor2TAction(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ -\mbox{}\verb@ int argc, char *argv[]);@\\ -\mbox{}\verb@ void Amor2TKill(void *pData); @\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap4} -\verb@"amor2t.i"@ {\footnotesize ? }$\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@/*--------------------------------------------------------------------------@\\ -\mbox{}\verb@ A m o r 2 T . i@\\ -\mbox{}\verb@ Internal data structure definitions for Amor2T. For details see amor2t.tex.@\\ -\mbox{}\verb@ DO NOT TOUCH! This file is automatically created from amor2t.w.@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ Mark Koennecke, September 1999@\\ -\mbox{}\verb@----------------------------------------------------------------------------*/@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@/* distance detector sample */@\\ -\mbox{}\verb@#define PARDS 0@\\ -\mbox{}\verb@/* constant height of sample: height = PARDH + MOTSOZ + MOTSTZ */@\\ -\mbox{}\verb@#define PARDH 1@\\ -\mbox{}\verb@/* distance diaphragm 4 - sample */@\\ -\mbox{}\verb@#define PARDD4 2@\\ -\mbox{}\verb@/* distance to diaphragm 5 */@\\ -\mbox{}\verb@#define PARDD5 3@\\ -\mbox{}\verb@/* interrupt to issue when a motor fails on this */@\\ -\mbox{}\verb@#define PARINT 4@\\ -\mbox{}\verb@/* base height of counter station */@\\ -\mbox{}\verb@#define PARDDH 5@\\ -\mbox{}\verb@/* height of D4 */@\\ -\mbox{}\verb@#define PARD4H 6@\\ -\mbox{}\verb@/* height of D5 */@\\ -\mbox{}\verb@#define PARD5H 7@\\ -\mbox{}\verb@/* base height of analyzer */@\\ -\mbox{}\verb@#define PARANA 8@\\ -\mbox{}\verb@/* distance of analyzer from sample */@\\ -\mbox{}\verb@#define PARADIS 9@\\ -\mbox{}\verb@/* flag analyzer calculation on/off */@\\ -\mbox{}\verb@#define ANAFLAG 10@\\ -\mbox{}\verb@/* constant for second detector */@\\ -\mbox{}\verb@#define PARDDD 11@\\ -\mbox{}\verb@/* constant part of AOM */@\\ -\mbox{}\verb@#define PARAOM 12@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@@$\langle$putput {\footnotesize ?}$\rangle$\verb@@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@@$\langle$amoredata {\footnotesize ?}$\rangle$\verb@@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-2ex} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap5} -\verb@"amor2t.h"@ {\footnotesize ? }$\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@/*-------------------------------------------------------------------------@\\ -\mbox{}\verb@ A m o r 2 T@\\ -\mbox{}\verb@ A class for controlling the two theta movement of a reflectometer. @\\ -\mbox{}\verb@ Especially the AMOR reflectometer at SINQ. For details see the file @\\ -\mbox{}\verb@ amor2t.tex. DO NOT TOUCH! This file is automatically created from amor2t.w@\\ -\mbox{}\verb@ with nuweb.@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ Mark Koennecke, September 1999@\\ -\mbox{}\verb@---------------------------------------------------------------------------*/@\\ -\mbox{}\verb@#ifndef AMOR2T@\\ -\mbox{}\verb@#define AMOR2T@\\ -\mbox{}\verb@@$\langle$amorinterface {\footnotesize ?}$\rangle$\verb@@\\ -\mbox{}\verb@#endif @\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-2ex} -\end{minipage}\\[4ex] -\end{flushleft} diff --git a/amor2t.w b/amor2t.w deleted file mode 100644 index 9c28a7f5..00000000 --- a/amor2t.w +++ /dev/null @@ -1,150 +0,0 @@ -\subsection{AMOR Two Theta} -AMOR is SINQ's new reflectometer. It has the peculiar feature that the -two theta movement of the detector is expressed in translations along -the reflectometer base axis and the detector height. Additionally the -detector is tilted. The height of two diaphragms has to be adjusted as -well. And, in polarizing mode, the analyzer has to be operated as -well. Quite a complicated movement. I fear this module may only be -useful for AMOR, but may be, other reflectometers may profit as well. -This object implements this complex movement as a virtual motor. - -The following formulas are used for the necessary calculations: -\begin{eqnarray} -delta height & = & h_{s} - \sin \alpha \\ -delta x & = & |x_{c} - x_{s}| - R \cos \alpha \\ -omega & = & -2 MOM + 2 SOM \\ -\end{eqnarray} -with -\begin{eqnarray} -h_{s} & = & \tan(2MOM)|x_{c} - x_{s}| \\ -R & = & \sqrt{hs^{2} - |x_{c} - x_{s}|^{2}} \\ -\alpha & = & ATT - 2SOM \\ -\beta & = & 180 - 90 - 2MOM \\ -MOM & = & polarizer \omega \\ -SOM & = & sample \omega \\ -x_{c} & = & counter position \\ -x_{s} & = & sample position\\ -\end{eqnarray} -The same equations hold true for the calculations of the diaphragm -heights, just replace the distances. The equations for the analyzer -are not yet known. - -Due to this complicated movement this module needs to know about a lot -of motors and a lot of parameters. The distances of the various -components need to be modified at run time in order to allow for -configuration changes. These are not motorized but must be entered -manually. - -\subsubsection{Data Structures} -Consequently data structures are complex. The first data structure -used is an entry in an array of motors to start: -@d putput @{ - typedef struct { - pMotor pMot; - char pName[80]; - float fTarget; - }MotEntry, *pMotEntry; -@} -\begin{description} -\item[pMot] is a pointer to the motors data structure. -\item[pName] is the name of the motor to start. -\item[fTarget] is the target value for the motor. -\end{description} - -The next data structure is the class data structure for amor2t: -@d amoredata @{ - typedef struct __AMOR2T { - pObjectDescriptor pDes; - pIDrivable pDriv; - pMotor aEngine[MAXMOT]; - MotEntry toStart[MAXMOT]; - int iStart; - ObPar *aParameter; - }Amor2T; -@} -\begin{description} -\item[pDes] The standard SICS object descriptor. -\item[pDriv] The drivable interface. The functions defined for the -drivable interface implement most of the work of this class. -\item[aEngine] An array of pointers to the motor data structures this -class has to deal with. The proper initialization of this is taken -care of during the initialization of the object. -\item[toStart] An array of motors to start when all calculations have -been performed. -\item[iStart] The number of valid entries in toStart. -\item[aParameter] An array of parameters for this object. -\end{description} - -\subsubsection{The Interface} -The interface to this module is quite primitive. Most of the -functionality is hidden in the drivable interface. So there are only -functions for interacting with the interpreter. - -@d amorinterface @{ - typedef struct __AMOR2T *pAmor2T; - - int Amor2TFactory(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - int Amor2TAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - void Amor2TKill(void *pData); -@} - -@o amor2t.i @{ -/*-------------------------------------------------------------------------- - A m o r 2 T . i - Internal data structure definitions for Amor2T. For details see amor2t.tex. - DO NOT TOUCH! This file is automatically created from amor2t.w. - - Mark Koennecke, September 1999 -----------------------------------------------------------------------------*/ - -/* distance detector sample */ -#define PARDS 0 -/* constant height of sample: height = PARDH + MOTSOZ + MOTSTZ */ -#define PARDH 1 -/* distance diaphragm 4 - sample */ -#define PARDD4 2 -/* distance to diaphragm 5 */ -#define PARDD5 3 -/* interrupt to issue when a motor fails on this */ -#define PARINT 4 -/* base height of counter station */ -#define PARDDH 5 -/* height of D4 */ -#define PARD4H 6 -/* height of D5 */ -#define PARD5H 7 -/* base height of analyzer */ -#define PARANA 8 -/* distance of analyzer from sample */ -#define PARADIS 9 -/* flag analyzer calculation on/off */ -#define ANAFLAG 10 -/* constant for second detector */ -#define PARDDD 11 -/* constant part of AOM */ -#define PARAOM 12 - -@ - -@ - -@} - -@o amor2t.h @{ -/*------------------------------------------------------------------------- - A m o r 2 T - A class for controlling the two theta movement of a reflectometer. - Especially the AMOR reflectometer at SINQ. For details see the file - amor2t.tex. DO NOT TOUCH! This file is automatically created from amor2t.w - with nuweb. - - Mark Koennecke, September 1999 ----------------------------------------------------------------------------*/ -#ifndef AMOR2T -#define AMOR2T -@ -#endif -@} - diff --git a/amorscan.c b/amorscan.c deleted file mode 100644 index 7f556e46..00000000 --- a/amorscan.c +++ /dev/null @@ -1,140 +0,0 @@ -/*------------------------------------------------------------------------- - A M O R S C A N - - An adaption of the general scan routine to deal with special issues at - the reflectometer AMOR at SINQ. - - copyright: see copyright.h - - Mark Koennecke, September 1999 ---------------------------------------------------------------------------*/ -#include -#include -#include "fortify.h" -#include "sics.h" -#include "scan.h" -#include "scan.i" -#include "HistMem.h" -#include "nxamor.h" -#include "amorscan.h" - -/*--------------------------------------------------------------------*/ - static int AmorHeader(pScanData self) - { - return WriteAmorHeader(self->pFile, self->pCon); - } -/*--------------------------------------------------------------------*/ - static int AmorPoints(pScanData self, int iP) - { - /* write only at last scan point */ - if((iP+1) >= self->iNP) - { - return WriteAmorScan(self->pFile,self->pCon,self); - } - } -/*--------------------------------------------------------------------*/ - static int AmorCollect(pScanData self, int iP) - { - pVarEntry pVar = NULL; - void *pDings; - int i, iRet, status; - float fVal; - char pStatus[512], pItem[20]; - char pHead[512]; - CountEntry sCount; - - assert(self); - assert(self->pCon); - - /* prepare output header */ - sprintf(pHead,"%-5.5s","NP"); - sprintf(pStatus,"%-5d",iP); - - /* loop over all scan variables */ - status = 1; - for(i = 0; i < self->iScanVar; i++) - { - DynarGet(self->pScanVar,i,&pDings); - pVar = (pVarEntry)pDings; - if(pVar) - { - fVal = pVar->pInter->GetValue(pVar->pObject,self->pCon); - pVar->fData[iP] = fVal; - sprintf(pItem,"%-10.10s",pVar->Name); - strcat(pHead,pItem); - sprintf(pItem,"%-10.3f",fVal); - strcat(pStatus,pItem); - } - } - - /* store counter data */ - /* monitors */ - for(i = 1; i < 10; i++) - { - sCount.Monitors[i-1] = GetMonitor((pCounter)self->pCounterData,i, - self->pCon); - } - if( self->iChannel != 0 && self->iChannel != -10 ) - { - sCount.Monitors[self->iChannel - 1] = - GetCounts((pCounter)self->pCounterData, - self->pCon); - } - /* counter1 */ - strcat(pHead,"Counter1 "); - sCount.lCount = GetCounts((pCounter)self->pCounterData,self->pCon); - sprintf(pItem,"%-15d",sCount.lCount); - strcat(pStatus,pItem); - - /* - WARNING - Assignements have to be checked when the Schlumpfes are - ready putting the counter box together. - */ - - /* counter2 */ - strcat(pHead,"Counter2 "); - sCount.Monitors[0] = GetMonitor((pCounter)self->pCounterData, - 1,self->pCon); - sprintf(pItem,"%-15d",sCount.Monitors[0]); - strcat(pStatus,pItem); - - /* monitors */ - sCount.Monitors[3] = GetMonitor((pCounter)self->pCounterData, - 2,self->pCon); - sCount.Monitors[4] = GetMonitor((pCounter)self->pCounterData, - 3,self->pCon); - - /* get time */ - sCount.fTime = GetCountTime((pCounter)self->pCounterData, - self->pCon); - strcat(pHead,"Monitor1 "); - sprintf(pItem,"%-12d",sCount.Monitors[3]); - strcat(pStatus,pItem); - strcat(pHead,"Monitor2 "); - sprintf(pItem,"%-12d",sCount.Monitors[4]); - strcat(pStatus,pItem); - strcat(pHead,"Time "); - sprintf(pItem,"%-6.1f",sCount.fTime); - strcat(pStatus,pItem); - - /* write progress */ - strcat(pHead,"\n"); - strcat(pStatus,"\n"); - SCWrite(self->pCon,pHead,eWarning); - SCWrite(self->pCon,pStatus,eWarning); - - /* stow away */ - DynarReplace(self->pCounts,self->iCounts,&sCount,sizeof(CountEntry)); - self->iCounts++; - return 1; - } -/*-----------------------------------------------------------------------*/ - int ConfigureAmor(pScanData self) - { - self->WriteHeader = AmorHeader; - self->WriteScanPoints = AmorPoints; - self->CollectScanData = AmorCollect; - strcpy(self->ext,".hdf"); - return 1; - } diff --git a/amorscan.h b/amorscan.h deleted file mode 100644 index d97195f4..00000000 --- a/amorscan.h +++ /dev/null @@ -1,15 +0,0 @@ - -/*----------------------------------------------------------------------- - A M O R S C A N - Adaption of the scan command to do things specific to the - reflectometer AMOR at SINQ. - - Mark Koennecke, September 1999 ------------------------------------------------------------------------*/ -#ifndef AMORSCAN -#define AMORSCAN - - int ConfigureAmor(pScanData pScan); - -#endif - diff --git a/amorscan.w b/amorscan.w deleted file mode 100644 index b52be00d..00000000 --- a/amorscan.w +++ /dev/null @@ -1,57 +0,0 @@ -\subsection{Amor Scan} -This is a special adaption of the general scan routines for the -reflectometer AMOR at SINQ. It works by replacing the configurable -routines in the general scan command with special ones, suited to the -reflectometers purpose. There are several adaptions to the standard -scan command: -\begin{itemize} -\item Data is written to NeXus files instead of ASCII files. -\item There are two counters to keep track of. -\item Furthermore stubs are provided for dealing with spin flippers. -\end{itemize} - -In order to keep track of counters and monitors the following -convention has been devised: -\begin{itemize} -\item GetCounts gets the main detector. -\item GetMonitor 0 the second detector -\item GetMonitor 1 the first detector other spin -\item GetMonitor 2 the second detector other spin -\item GetMonitor 3 the first monitor -\item GetMonitor 4 the second monitor -\end{itemize} -Thus the monitor channels are used to keep the additional counter -information. - -This module provides only one external function: -@d amorscan @{ - int ConfigureAmor(pScanData pScan); -@} -which configures the variable fields and function pointers in pScan to -functions defined in this module. These then do the right thing. This -module is also an example of how the scan command can be configured to do -tricks based on the syntax and hooks defined in scan.*. - - -@o amorscan.h @{ -/*----------------------------------------------------------------------- - A M O R S C A N - Adaption of the scan command to do things specific to the - reflectometer AMOR at SINQ. - - Mark Koennecke, September 1999 ------------------------------------------------------------------------*/ -#ifndef AMORSCAN -#define AMORSCAN -@ -#endif - -@} - - - - - - - - diff --git a/amorstat.c b/amorstat.c deleted file mode 100644 index fb422b91..00000000 --- a/amorstat.c +++ /dev/null @@ -1,919 +0,0 @@ -/*-------------------------------------------------------------------------- - A M O R S T A T U S - - The implementation file for the amor status display facilitator module. The - reflectometer AMOR needs some advanced feautures for its status display. - These needs are taken care of here. - - copyright: see copyright.h - - Mark Koennecke, September 1999 - - As AMOR's histogram memory becomes too big in tof mode to transfer it - for status information the collapse and subsample functionalities have - been moved to the histogram memory. This code had to be modified to - call SINQHMProject directly. - - Mark Koennecke, August 2001 - --------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include "fortify.h" -#include "sics.h" -#include "counter.h" -#include "stringdict.h" -#include "HistMem.h" -#include "HistMem.i" -#include "HistDriv.i" -#include "hardsup/sinqhm.h" -#include "sinqhmdriv.i" -#include "scan.h" -#include "lld.h" -#include "amorstat.i" -#include "amorstat.h" -/*------------------------------------------------------------------------- - A static which determines if we are in TOF or scan mode. -*/ - static int iTOF = 0; - static pHistMem pHMHM = NULL; -/*-------------------------------------------------------------------------*/ - static int HMCountStartCallback(int iEvent, void *pEvent, void *pUser) - { - SConnection *pCon = (SConnection *)pUser; - const float *fTime = NULL; - int *iTime = NULL; - int iLength, iRet, i; - - assert(pCon); - - if(iEvent == COUNTSTART) - { - /* send current time binning */ - iTOF = 1; - fTime = GetHistTimeBin(pHMHM,&iLength); - iTime = (int *)malloc((iLength+1)*sizeof(int)); - if( (!fTime) || (!iTime)) - { - return 0; - } - iTime[0] = htonl(iLength); - for(i = 0 ; i < iLength; i++) - { - iTime[i+1] = htonl((int)((fTime[i]/10.)*65536.)); - } - /* send new time binning to all clients */ - SCWrite(pCon,"TOFClear",eError); - SCWriteUUencoded(pCon,"arrowaxis_time",iTime, - (iLength+1)*sizeof(int)); - free(iTime); - } - return 1; - } -/*-------------------------------------------------------------------------*/ - static int ScanStartCallback(int iEvent, void *pEvent, void *pUser) - { - float *fAxis = NULL; - int *iAxis = NULL; - int iLength, iRet, i; - char pBueffel[80], pName[40]; - SConnection *pCon = (SConnection *)pUser; - pScanData pScan = (pScanData)pEvent; - - assert(pCon); - assert(pScan); - - - if(iEvent == SCANSTART) - { - iTOF = 0; - /* send current axis */ - iLength = GetScanNP(pScan); - fAxis = (float *)malloc((iLength+1)*sizeof(float)); - iAxis = (int *)malloc((iLength+1)*sizeof(int)); - if( (!fAxis) || (!iAxis)) - { - return 0; - } - iAxis[0] = htonl(iLength); - GetSoftScanVar(pScan,0,fAxis,iLength); - GetScanVarName(pScan,0,pName,39); - sprintf(pBueffel,"arrowaxis_%s",pName); - for(i = 0 ; i < iLength; i++) - { - iAxis[i+1] = htonl((int)(fAxis[i]*65536.)); - } - /* send new axis to client */ - SCWrite(pCon,"SCANClear",eError); - SCWriteUUencoded(pCon,pBueffel,iAxis, - (iLength+1)*sizeof(int)); - free(iAxis); - free(fAxis); - } - return 1; - } -/*------------------------------------------------------------------------*/ - static int ScanPointCallback(int iEvent, void *pEvent, void *pUser) - { - long *lData = NULL; - int *iData = NULL; - int iLength, iRet, i; - SConnection *pCon = (SConnection *)pUser; - pScanData pScan = (pScanData)pEvent; - - assert(pCon); - assert(pScan); - - - if( (iEvent == SCANPOINT) || (iEvent == SCANEND) ) - { - /* send current data */ - iTOF = 0; - iLength = GetScanNP(pScan); - lData = (long *)malloc((iLength+1)*sizeof(long)); - iData = (int *)malloc((iLength+1)*sizeof(int)); - if( (!lData) || (!iData)) - { - return 0; - } - iData[0] = htonl(iLength); - GetScanCounts(pScan,lData,iLength); - for(i = 0 ; i < iLength; i++) - { - iData[i+1] = htonl((int)(lData[i])); - } - /* send counts to client */ - SCWriteUUencoded(pCon,"arrow_spinupup",iData, - (iLength+1)*sizeof(int)); - /* send counts for other detector */ - GetScanMonitor(pScan,2,lData,iLength); - for(i = 0 ; i < iLength; i++) - { - iData[i+1] = htonl((int)(lData[i])); - } - SCWriteUUencoded(pCon,"arrow_spinuplo",iData, - (iLength+1)*sizeof(int)); - /* to do: check for polarization and send spinlo */ - free(iData); - free(lData); - } - return 1; - } -/*------------------------------------------------------------------------*/ - static int SendLoadedData(pAmorStat self, SConnection *pCon) - { - int i, iRet, *iData = NULL; - char pBueffel[80]; - UserData ud; - - SCWrite(pCon,"loaded_CLEAR",eValue); - iRet = LLDnodePtr2First(self->iUserList); - while(iRet != 0) - { - LLDnodeDataTo(self->iUserList,&ud); - iData = (int *)malloc((ud.iNP*2 + 1)*sizeof(int)); - if(!iData) - { - return 0; - } - iData[0] = htonl(ud.iNP); - for(i = 0; i < ud.iNP; i++) - { - iData[i+1] = htonl((int)(ud.fX[i]*65536)); - iData[i+1+ud.iNP] = htonl((int)(ud.fY[i]*65536)); - } - sprintf(pBueffel,"loaded_%s",ud.name); - SCWriteUUencoded(pCon,pBueffel,iData,(ud.iNP*2+1)*sizeof(int)); - iRet = LLDnodePtr2Next(self->iUserList); - } - } -/*------------------------------------------------------------------------*/ - static int LoadCallback(int iEvent, void *pEvent, void *pUser) - { - pAmorStat pAS = NULL; - SConnection *pCon = NULL; - - if(iEvent == FILELOADED) - { - pAS = (pAmorStat)pEvent; - pCon = (SConnection *)pUser; - assert(pAS); - assert(pCon); - SendLoadedData(pAS,pCon); - } - return 1; - } -/*-------------------------------------------------------------------------*/ - static void ClearUserData(pAmorStat self) - { - int iRet; - UserData ud; - - iRet = LLDnodePtr2First(self->iUserList); - while(iRet != 0) - { - LLDnodeDataTo(self->iUserList,&ud); - if(ud.fX != NULL) - free(ud.fX); - if(ud.fY != NULL) - free(ud.fY); - if(ud.name != NULL) - free(ud.name); - iRet = LLDnodePtr2Next(self->iUserList); - } - LLDdelete(self->iUserList); - self->iUserList = LLDcreate(sizeof(UserData)); - } -/*----------------------------------------------------------------------*/ - void KillAmorStatus(void *pData) - { - pAmorStat self = (pAmorStat)pData; - - if(!self) - return; - - if(self->iUserList >= 0) - { - ClearUserData(self); - LLDdelete(self->iUserList); - } - if(self->pDes) - DeleteDescriptor(self->pDes); - if(self->pCall) - DeleteCallBackInterface(self->pCall); - free(self); - } -/*------------------------------------------------------------------*/ - int AmorStatusFactory(SConnection *pCon, SicsInterp *pSics, - void *pData, int argc, char *argv[]) - { - pAmorStat pNew = NULL; - CommandList *pCom = NULL; - char pBueffel[256]; - int iRet; - - /* check number of arguments */ - if(argc < 4) - { - sprintf(pBueffel,"ERROR: insufficient number of arguments to %s", - argv[0]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - - /* allocate a new data structure */ - pNew = (pAmorStat)malloc(sizeof(AmorStat)); - if(!pNew) - { - sprintf(pBueffel,"ERROR: out of memory in %s",argv[0]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - memset(pNew,0,sizeof(AmorStat)); - pNew->pDes = CreateDescriptor("AmorStatus"); - pNew->iUserList = LLDcreate(sizeof(UserData)); - pNew->pCall = CreateCallBackInterface(); - if( (!pNew->pDes) || (pNew->iUserList < 0) || (!pNew->pCall) ) - { - sprintf(pBueffel,"ERROR: out of memory in %s",argv[0]); - SCWrite(pCon,pBueffel,eError); - KillAmorStatus(pNew); - return 0; - } - - /* to locate the HM and the scan object */ - pCom = FindCommand(pSics,argv[2]); - if(pCom) - { - if(pCom->pData) - { - if(!iHasType(pCom->pData,"ScanObject")) - { - sprintf(pBueffel,"ERROR: %s is NO scan object",argv[2]); - SCWrite(pCon,pBueffel,eError); - KillAmorStatus(pNew); - return 0; - } - } - else - { - sprintf(pBueffel,"ERROR: %s is NO scan object",argv[2]); - SCWrite(pCon,pBueffel,eError); - KillAmorStatus(pNew); - return 0; - } - } - else - { - sprintf(pBueffel,"ERROR: %s NOT found",argv[2]); - SCWrite(pCon,pBueffel,eError); - KillAmorStatus(pNew); - return 0; - } - pNew->pScan = (pScanData)pCom->pData; - pCom = FindCommand(pSics,argv[3]); - if(pCom) - { - if(pCom->pData) - { - if(!iHasType(pCom->pData,"HistMem")) - { - sprintf(pBueffel,"ERROR: %s is NO histogram memory object", - argv[3]); - SCWrite(pCon,pBueffel,eError); - KillAmorStatus(pNew); - return 0; - } - } - else - { - sprintf(pBueffel,"ERROR: %s is NO histogram memory object", - argv[3]); - SCWrite(pCon,pBueffel,eError); - KillAmorStatus(pNew); - return 0; - } - } - else - { - sprintf(pBueffel,"ERROR: %s NOT found",argv[3]); - SCWrite(pCon,pBueffel,eError); - KillAmorStatus(pNew); - return 0; - } - pNew->pHM = (pHistMem)pCom->pData; - pHMHM = (pHistMem)pCom->pData; - - /* install command */ - iRet = AddCommand(pSics,argv[1], - AmorStatusAction,KillAmorStatus,pNew); - if(!iRet) - { - sprintf(pBueffel,"ERROR: duplicate command %s NOT created", - argv[1]); - SCWrite(pCon,pBueffel,eError); - KillAmorStatus(pNew); - return 0; - } - - - return 1; - } -/*------------------------------------------------------------------*/ - static int RegisterInterest(pAmorStat self, SConnection *pCon) - { - long lID; - pDummy pDum = NULL; - pICallBack pCall = NULL; - - assert(self); - assert(pCon); - - /* Register all the callbacks. Dependent on the state of - iTOF invoke the apropriate callbacks in order to force - an initial update. - */ - /* file load callback */ - lID = RegisterCallback(self->pCall, FILELOADED, LoadCallback, - pCon, NULL); - SCRegister(pCon,pServ->pSics, self->pCall,lID); - SendLoadedData(self,pCon); - - /* scan object */ - pDum = (pDummy)self->pScan; - pCall = pDum->pDescriptor->GetInterface(pDum,CALLBACKINTERFACE); - if(pCall) - { - lID = RegisterCallback(pCall,SCANSTART,ScanStartCallback, - pCon, NULL); - SCRegister(pCon,pServ->pSics,pCall,lID); - lID = RegisterCallback(pCall,SCANPOINT,ScanPointCallback, - pCon, NULL); - SCRegister(pCon,pServ->pSics,pCall,lID); - lID = RegisterCallback(pCall,SCANEND,ScanPointCallback, - pCon, NULL); - SCRegister(pCon,pServ->pSics,pCall,lID); - if(iTOF == 0) - { - ScanStartCallback(SCANSTART,pDum,pCon); - ScanPointCallback(SCANPOINT,pDum,pCon); - } - } - pDum = (pDummy)self->pHM; - pCall = pDum->pDescriptor->GetInterface(pDum,CALLBACKINTERFACE); - if(pCall) - { - lID = RegisterCallback(pCall,COUNTSTART,HMCountStartCallback, - pCon, NULL); - SCRegister(pCon,pServ->pSics,pCall,lID); - if(iTOF == 1) - { - HMCountStartCallback(COUNTSTART,pDum,pCon); - } - } - return 1; - } -/*-----------------------------------------------------------------*/ - static int FileLoad(pAmorStat self, SConnection *pCon, - char *name, double dScale) - { - char pBueffel[256], pDummy[50]; - FILE *fd = NULL; - UserData ud; - int iNP, i; - float fDummy; - - /* open the file */ - fd = fopen(name,"r"); - if(!fd) - { - sprintf(pBueffel,"ERROR: cannot open %s for reading",name); - SCWrite(pCon,pBueffel,eError); - return 0; - } - - /* skip first line */ - if(fgets(pBueffel,255,fd) == NULL) - { - SCWrite(pCon,"ERROR: premature end of file",eError); - fclose(fd); - return 0; - } - - /* read number of points in second line */ - if(fgets(pBueffel,255,fd) == NULL) - { - SCWrite(pCon,"ERROR: premature end of file",eError); - fclose(fd); - return 0; - } - sscanf(pBueffel,"%s %d",pDummy, &iNP); - /* allocate data */ - ud.iNP = iNP; - ud.fX = (float *)malloc(iNP*sizeof(float)); - ud.fY = (float *)malloc(iNP*sizeof(float)); - ud.name = strdup(name); - - /* skip two lines */ - if(fgets(pBueffel,255,fd) == NULL) - { - SCWrite(pCon,"ERROR: premature end of file",eError); - fclose(fd); - return 0; - } - if(fgets(pBueffel,255,fd) == NULL) - { - SCWrite(pCon,"ERROR: premature end of file",eError); - fclose(fd); - return 0; - } - - /* loop reading data */ - for(i = 0; i < iNP; i++) - { - if(fgets(pBueffel,255,fd) == NULL) - { - SCWrite(pCon,"WARNING: premature end of file",eError); - break; - } - sscanf(pBueffel," %f %f %f",&ud.fX[i],&fDummy, &ud.fY[i]); - ud.fY[i] *= dScale; - } - fclose(fd); - - /* enter ud into list */ - LLDnodeInsertFrom(self->iUserList,&ud); - - return 1; - } -/*----------------------------------------------------------------- - Collapse creates a 2D image from the detector by summing all time - channels together in any given detector. -*/ - - static int Collapse(pAmorStat self, SConnection *pCon) - { - HistInt *lData = NULL; - int i, i2, i3, iDim[MAXDIM], iIdx, iSum, status, length; - int *iImage = NULL, *iPtr; - pSINQHM pHist; - SinqHMDriv *pTata; - int iMax = -999999; - - /* get size of our problem */ - GetHistDim(self->pHM,iDim,&i3); - /* assert(i3 == 3); */ - - /* allocate some data */ - length = 2 + iDim[0]*iDim[1]; - iImage = (int *)malloc(length*sizeof(int)); - if(iImage == NULL) - { - SCWrite(pCon,"ERROR: failed to allocate memory in Collapse",eError); - return 0; - } - memset(iImage,0,(2 + iDim[0]*iDim[1])*sizeof(int)); - - /* first two numbers are the dimension of the image */ - iImage[0] = htonl(iDim[0]); - iImage[1] = htonl(iDim[1]); - - - if(isSINQHMDriv(self->pHM->pDriv)) - { - /* - send a Project request to the histogram memory - */ - pTata = (SinqHMDriv *)self->pHM->pDriv->pPriv; - pHist = (pSINQHM)pTata->pMaster; - /* - The 3 in the following call has to be identical to - PROJECT__COLL in sinqhm_def.h - */ - status = SINQHMProject(pHist, 3, 0, iDim[0], - 0, iDim[1], iImage+2, (length-2)*sizeof(int)); - /* - Byte swapping - */ - for(i = 2; i < length; i++) - { - /* - if(iImage[i] > iMax){ - iMax = iImage[i]; - } - */ - iImage[i] = htonl(iImage[i]); - } - /* - printf("Collapsed maximum: %d\n",iMax); - */ - if(status != 1) - { - SCWrite(pCon,"ERROR: histogram memory refused to Collapse",eError); - return 0; - } - } - else - { - /* - we are in simulation and just create some random numbers - */ - for(i = 0; i < iDim[0]; i++) - { - for(i2 = 0; i2 < iDim[1]; i2++) - { - iIdx = i*iDim[1] + i2; - iImage[iIdx+2] = htonl(random()); - /* iImage[iIdx+2] = htonl(77);*/ - } - } - } - - /* send image */ - SCWriteUUencoded(pCon,"arrow_image",iImage, - ((iDim[0]*iDim[1])+2)*sizeof(int)); - free(iImage); - return 1; - } -/*----------------------------------------------------------------- - SendSingleTOF sends single detector data for TOF mode -*/ - - static int SendSingleTOF(pAmorStat self, SConnection *pCon) - { - HistInt *lData = NULL; - int i, i2, i3, iDim[MAXDIM], iIdx, iSum, status, length, nTime; - pSINQHM pHist; - SinqHMDriv *pTata; - int iMax = -999999; - const float *timebin; - HistInt *iData = NULL; - int iStart; - - /* get size of our problem */ - GetHistDim(self->pHM,iDim,&i3); - - /* allocate some data */ - timebin = GetHistTimeBin(self->pHM, &nTime); - if(nTime < 2) { - return 1; - } - - length = 1 + 2*nTime; - iData = (HistInt *)malloc(length*sizeof(HistInt)); - if(iData == NULL){ - SCWrite(pCon,"ERROR: failed to allocate memory in SendSingleTOF", - eError); - return 0; - } - memset(iData,0,length*sizeof(int)); - - /* first number is the length of each single histogram */ - iData[0] = htonl(nTime); - - - if(isSINQHMDriv(self->pHM->pDriv)) - { - iStart = iDim[0]*iDim[1]*nTime; - GetHistogramDirect(self->pHM,pCon,0,iStart, - iStart + 2*nTime,&iData[1],2*nTime*sizeof(HistInt)); - for(i = 1; i < length; i++) - { - iData[i] = htonl(iData[i]); - } - } - else - { - /* - we are in simulation and just create some random numbers - */ - for(i = 1; i < length; i++) - { - iData[i] = htonl(random()); - } - } - - /* - send, with a little trick to do two histograms. - */ - SCWriteUUencoded(pCon,"SING1",iData, - (nTime+1)*sizeof(int)); - iData[nTime] = htonl(nTime); - SCWriteUUencoded(pCon,"SING2",&iData[nTime], - (nTime+1)*sizeof(int)); - free(iData); - return 1; - } -/*------------------------------------------------------------------- - SubSample sums histogram data in the area defined by the rectangle - x1,y1 x2, y2. Summing is along the time axis. -*/ - static int SubSample(pAmorStat self, SConnection *pCon, - char *name, int x1, int x2, int y1, int y2) - { - int iDim[MAXDIM], i, i2, i3, *iSum = NULL, iLang, *iPtr; - HistInt *lData = NULL; - int iLimit, status, nTime; - char pBueffel[132]; - pSINQHM pHist; - SinqHMDriv *pTata; - const float *fTime; - - /* get histogram dimensions */ - GetHistDim(self->pHM,iDim,&i3); - fTime = GetHistTimeBin(self->pHM,&nTime); - iDim[i3] = nTime; - i3++; - assert(i3 == 3); - - /* check limits */ - if(x2 < x1){ - i = x1; - x1 = x2; - x2 = i +1; - } - if(y2 < y1){ - i = y1; - y1 = y2; - y2 = i + 1; - } - - iLimit = 0; - if( x1 > iDim[0]) - { - iLimit = 1; - x1 = iDim[0] - 1; - } - if(x1 < 0) - { - iLimit = 1; - x1 = 0; - } - if( x2 > iDim[0]) - { - iLimit = 2; - x2 = iDim[0] - 1; - } - if(x2 < 0) - { - iLimit = 2; - x2 = 0; - } - if( y1 > iDim[1]) - { - iLimit = 3; - y1 = iDim[1] - 1; - } - if(y1 < 0) - { - iLimit = 3; - y1 = 0; - } - if( y2 > iDim[1]) - { - iLimit = 4; - y2 = iDim[1] - 1; - } - if(y2 < 0) - { - iLimit = 4; - y2 = 0; - } - if(iLimit != 0) - { - switch(iLimit) - { - case 1: - strcpy(pBueffel,"WARNING: limit violation on x1"); - break; - case 2: - strcpy(pBueffel,"WARNING: limit violation on x2"); - break; - case 3: - strcpy(pBueffel,"WARNING: limit violation on y1"); - break; - case 4: - strcpy(pBueffel,"WARNING: limit violation on y2"); - break; - } - SCWrite(pCon,pBueffel,eWarning); - } - - /* allocate space for result */ - iSum = (int *)malloc((iDim[2]+1)*sizeof(int)); - if(!iSum) - { - SCWrite(pCon,"ERROR: out of memory in SubSample",eError); - return 0; - } - memset(iSum,0,(iDim[2]+1)*sizeof(int)); - - iSum[0] = htonl(iDim[2]); - if(isSINQHMDriv(self->pHM->pDriv)) - { - /* - send project message to histogram memory - */ - pTata = (SinqHMDriv *)self->pHM->pDriv->pPriv; - pHist = (pSINQHM)pTata->pMaster; - status = SINQHMProject(pHist, 4, x1, x2-x1, - y1, y2-y1, iSum+1, iDim[2]*sizeof(int)); - /* - convert to network byte order - */ - for(i = 1; i < iDim[2]+1; i++) - { - iSum[i] = htonl(iSum[i]); - } - if(status != 1) - { - SCWrite(pCon,"ERROR: histogram memory refused to SubSample",eError); - return 0; - } - } - else - { - /* do acouple of random numbers! */ - for(i = 1; i < iDim[2]+1; i++) - { - iSum[i] = htonl(random()); - } - } - - /* send */ - sprintf(pBueffel,"arrowsum_%s",name); - SCWriteUUencoded(pCon,pBueffel,iSum,(iDim[2]+1)*sizeof(int)); - - free(iSum); - return 1; - } -/*------------------------------------------------------------------*/ - int AmorStatusAction(SConnection *pCon, SicsInterp *pSics, - void *pData, int argc, char *argv[]) - { - pAmorStat self = (pAmorStat)pData; - char pBueffel[512]; - double dScale; - int iRet; - int x1, x2, y1, y2; - - assert(self); - - if(argc < 2) - { - sprintf(pBueffel,"ERROR: need argument to %s",argv[0]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - - strtolower(argv[1]); - if(strcmp(argv[1],"interest") == 0) - { - RegisterInterest(self,pCon); - SCSendOK(pCon); - return 1; - } - else if(strcmp(argv[1],"load") == 0) - { - if(argc < 4) - { - sprintf(pBueffel, - "ERROR: need filename and scale argument to %s load", - argv[0]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = Tcl_GetDouble(pSics->pTcl,argv[3],&dScale); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert %s to scale factor", - argv[3]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - FileLoad(self,pCon,argv[2],dScale); - InvokeCallBack(self->pCall, FILELOADED,self); - SCSendOK(pCon); - } - else if(strcmp(argv[1],"collapse") == 0) - { - iRet = Collapse(self,pCon); - if(iRet) - { - SCSendOK(pCon); - } - return iRet; - } - else if(strcmp(argv[1],"sample") == 0) - { - if(argc < 7) - { - SCWrite(pCon,"ERROR: insufficent number of arguments to sample", - eError); - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[3],&x1); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert %s to int", argv[3]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[6],&y2); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert %s to int", argv[6]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[4],&x2); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert %s to int", argv[4]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[5],&y1); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert %s to int", argv[5]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = SubSample(self,pCon,argv[2],x1,x2,y1,y2); - if(iRet) - SCSendOK(pCon); - return iRet; - } - else if(strcmp(argv[1],"singletof") == 0) - { - return SendSingleTOF(self,pCon); - } - else if(strcmp(argv[1],"sendloaded") == 0) - { - SendLoadedData(self,pCon); - return 1; - } - else if(strcmp(argv[1],"clear") == 0) - { - ClearUserData(self); - InvokeCallBack(self->pCall, FILELOADED,self); - SCSendOK(pCon); - } - else if(strcmp(argv[1],"tofmode") == 0) - { - HMCountStartCallback(COUNTSTART,NULL,pCon); - return 1; - } - else - { - sprintf(pBueffel,"ERROR: %s nor recognized as subcommand to %s", - argv[1], argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - return 1; - } - - diff --git a/amorstat.h b/amorstat.h deleted file mode 100644 index 6665cec2..00000000 --- a/amorstat.h +++ /dev/null @@ -1,21 +0,0 @@ - -/*------------------------------------------------------------------------ - A M O R S T A T U S - - Public definitions for the AMOR status display - facilitator object. DO NOT CHANGE. This file is automatically - created from amorstat.w. - - Mark Koennecke, September 1999 ----------------------------------------------------------------------*/ -#ifndef AMORSTATUS -#define AMORSTATUS - - int AmorStatusFactory(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - int AmorStatusAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - void KillAmorStatus(void *pData); - -#endif - diff --git a/amorstat.i b/amorstat.i deleted file mode 100644 index 5a24a644..00000000 --- a/amorstat.i +++ /dev/null @@ -1,29 +0,0 @@ - -/*------------------------------------------------------------------------ - A M O R S T A T U S - - Internal data structure definitions for the AMOR status display - facilitator object. DO NOT CHANGE. This file is automatically - created from amorstat.w. - - Mark Koennecke, September 1999 ----------------------------------------------------------------------*/ - -/*---------------------------------------------------------------------*/ - typedef struct { - float *fX, *fY; - int iNP; - char *name; - }UserData, *pUserData; -/*---------------------------------------------------------------------*/ - typedef struct __AMORSTAT { - pObjectDescriptor pDes; - pICallBack pCall; - int iUserList; - pScanData pScan; - pHistMem pHM; - int iTOF; - }AmorStat, *pAmorStat; - - - diff --git a/amorstat.tex b/amorstat.tex deleted file mode 100644 index 8d295337..00000000 --- a/amorstat.tex +++ /dev/null @@ -1,138 +0,0 @@ -\subsection{Amor Status Display Support} -The reflectometer AMOR has a few unique status display requirements: -\begin{itemize} -\item In scan mode up to four detector counts curves must be shown for -the two counters in spin-up or spin-down mode. This needs to be -updated after each scan point. -\item Additionally user defined curves may need to be displayed. -\item The usual helper information muste be displayed. -\item In TOF mode it must be possible to define a region on the -detector whose summed counts are displayed versus the time -binning. This must be sent on request. -\end{itemize} -In order to cover all this a special object within SICS is required -which deals with all this and packages information in a status display -compliant way. - -In order to do this the amorstatus object registers callbacks both -with the histogram memory and the scan object. These callback -functions are then responsible for updating the status displays. In -order for amorstatus to be able to do this, the client must register -itself with a special command. - -In order to achieve all this some data structures are needed: -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap1} -$\langle$asdata {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@/*---------------------------------------------------------------------*/@\\ -\mbox{}\verb@ typedef struct {@\\ -\mbox{}\verb@ float *fX, *fY;@\\ -\mbox{}\verb@ int iNP;@\\ -\mbox{}\verb@ char *name;@\\ -\mbox{}\verb@ }UserData, *pUserData; @\\ -\mbox{}\verb@/*---------------------------------------------------------------------*/@\\ -\mbox{}\verb@ typedef struct __AMORSTAT {@\\ -\mbox{}\verb@ pObjectDescriptor pDes;@\\ -\mbox{}\verb@ pICallBack pCall;@\\ -\mbox{}\verb@ int iUserList;@\\ -\mbox{}\verb@ pScanData pScan;@\\ -\mbox{}\verb@ pHistMem pHM;@\\ -\mbox{}\verb@ int iTOF;@\\ -\mbox{}\verb@ }AmorStat, *pAmorStat;@\\ -\mbox{}\verb@ @\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -The fourth data structure is the amor status object data structure. It -has the following fields: -\begin{description} -\item[pDes] The standard SICS object descriptor. -\item[pCall] The callback interface. -\item[iUserList] A list of user data loaded data. -\item[pScan] A pointer to the scan object. -\item[pHM] A pointer to the histogram memory. -\item[iTOF] A flag which is true if we are taking measurements in TOF -mode. -\end{description} - -In terms of a function interface this object has not much to -offer. Its main purpose is really as an interface to the status -display clients and thus it is configured through the interpreter -interface function. No need for other SICS objects to access it. - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap2} -$\langle$asinter {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ int AmorStatusFactory(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ -\mbox{}\verb@ int argc, char *argv[]);@\\ -\mbox{}\verb@ int AmorStatusAction(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ -\mbox{}\verb@ int argc, char *argv[]);@\\ -\mbox{}\verb@ void KillAmorStatus(void *pData);@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap3} -\verb@"amorstat.i"@ {\footnotesize ? }$\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@/*------------------------------------------------------------------------@\\ -\mbox{}\verb@ A M O R S T A T U S@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ Internal data structure definitions for the AMOR status display @\\ -\mbox{}\verb@ facilitator object. DO NOT CHANGE. This file is automatically@\\ -\mbox{}\verb@ created from amorstat.w.@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ Mark Koennecke, September 1999@\\ -\mbox{}\verb@---------------------------------------------------------------------*/@\\ -\mbox{}\verb@@$\langle$asdata {\footnotesize ?}$\rangle$\verb@@\\ -\mbox{}\verb@ @\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-2ex} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap4} -\verb@"amorstat.h"@ {\footnotesize ? }$\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@/*------------------------------------------------------------------------@\\ -\mbox{}\verb@ A M O R S T A T U S@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ Public definitions for the AMOR status display @\\ -\mbox{}\verb@ facilitator object. DO NOT CHANGE. This file is automatically@\\ -\mbox{}\verb@ created from amorstat.w.@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ Mark Koennecke, September 1999@\\ -\mbox{}\verb@---------------------------------------------------------------------*/@\\ -\mbox{}\verb@#ifndef AMORSTATUS@\\ -\mbox{}\verb@#define AMORSTATUS@\\ -\mbox{}\verb@@$\langle$asinter {\footnotesize ?}$\rangle$\verb@@\\ -\mbox{}\verb@#endif@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-2ex} -\end{minipage}\\[4ex] -\end{flushleft} diff --git a/amorstat.w b/amorstat.w deleted file mode 100644 index a8653d7b..00000000 --- a/amorstat.w +++ /dev/null @@ -1,102 +0,0 @@ -\subsection{Amor Status Display Support} -The reflectometer AMOR has a few unique status display requirements: -\begin{itemize} -\item In scan mode up to four detector counts curves must be shown for -the two counters in spin-up or spin-down mode. This needs to be -updated after each scan point. -\item Additionally user defined curves may need to be displayed. -\item The usual helper information muste be displayed. -\item In TOF mode it must be possible to define a region on the -detector whose summed counts are displayed versus the time -binning. This must be sent on request. -\end{itemize} -In order to cover all this a special object within SICS is required -which deals with all this and packages information in a status display -compliant way. - -In order to do this the amorstatus object registers callbacks both -with the histogram memory and the scan object. These callback -functions are then responsible for updating the status displays. In -order for amorstatus to be able to do this, the client must register -itself with a special command. - -In order to achieve all this some data structures are needed: -@d asdata @{ -/*---------------------------------------------------------------------*/ - typedef struct { - float *fX, *fY; - int iNP; - char *name; - }UserData, *pUserData; -/*---------------------------------------------------------------------*/ - typedef struct __AMORSTAT { - pObjectDescriptor pDes; - pICallBack pCall; - int iUserList; - pScanData pScan; - pHistMem pHM; - int iTOF; - }AmorStat, *pAmorStat; - -@} - - -The fourth data structure is the amor status object data structure. It -has the following fields: -\begin{description} -\item[pDes] The standard SICS object descriptor. -\item[pCall] The callback interface. -\item[iUserList] A list of user data loaded data. -\item[pScan] A pointer to the scan object. -\item[pHM] A pointer to the histogram memory. -\item[iTOF] A flag which is true if we are taking measurements in TOF -mode. -\end{description} - -In terms of a function interface this object has not much to -offer. Its main purpose is really as an interface to the status -display clients and thus it is configured through the interpreter -interface function. No need for other SICS objects to access it. - -@d asinter @{ - int AmorStatusFactory(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - int AmorStatusAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - void KillAmorStatus(void *pData); -@} - - -@o amorstat.i @{ -/*------------------------------------------------------------------------ - A M O R S T A T U S - - Internal data structure definitions for the AMOR status display - facilitator object. DO NOT CHANGE. This file is automatically - created from amorstat.w. - - Mark Koennecke, September 1999 ----------------------------------------------------------------------*/ -@ - -@} - -@o amorstat.h @{ -/*------------------------------------------------------------------------ - A M O R S T A T U S - - Public definitions for the AMOR status display - facilitator object. DO NOT CHANGE. This file is automatically - created from amorstat.w. - - Mark Koennecke, September 1999 ----------------------------------------------------------------------*/ -#ifndef AMORSTATUS -#define AMORSTATUS -@ -#endif - -@} - - - diff --git a/bruker.c b/bruker.c deleted file mode 100644 index 0c413dbe..00000000 --- a/bruker.c +++ /dev/null @@ -1,999 +0,0 @@ -/*------------------------------------------------------------------------- - B r u k e r - - An environment control driver and an additonal wrapper function for - controlling a Bruker B-EC-1 magnet controller. This controller can - either control a current or control the current through an external hall - sensor mesuring the magnetic field. In both cases both values: the field - and the current must be readable. - - copyright: see copyright.h - - Mark Koennecke, October 1998 ----------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include -#include -#include "fortify.h" -#include "sics.h" -#include "obpar.h" -#include "evcontroller.h" -#include "evcontroller.i" -#include "evdriver.i" -#include "hardsup/serialsinq.h" -#include "hardsup/el734_errcodes.h" -#include "hardsup/el734fix.h" -#include "bruker.h" - -/* -#define debug 1 -*/ -/*----------------------------------------------------------------------- - The Bruker Data Structure -*/ - typedef struct { - void *pData; - char *pHost; - int iPort; - int iChannel; - int iMode; - int iLastError; - } BrukerDriv, *pBrukerDriv; -/*----------------------------------------------------------------------- - A couple of defines for Bruker modes and special error conditions -*/ -#define FIELD 100 -#define CURRENT 200 - -/* errors */ -#define NOFUNC -1601 -#define BADARG -1602 -#define NOACCESS -1603 -#define BADRANGE -1604 -#define ERRPENDING -1605 -#define NOPOWER -1606 -#define NOTFIELD -1607 -#define BADINTERN -1608 -#define NOCONN -1609 -#define BTIMEOUT -1610 -#define NOPOLUNIT -1620 - -/* polarity */ -#define PPLUS 0 -#define PMINUS 1 -#define PBUSY 3 - -/* rmtrail.c */ -extern char *rmtrail(char *p); - -/*--------------------------------------------------------------------------- - This Bruker thing has a lot of internal error conditions and a few nasty - habits. Such as to lock up after an error ocurred until the error is reset. - Or to switch the power off, when a current above the limit is requested - after setting a bad value for the magnetic field. These problems can be - detected by analysing the return values from the Bruker. Usually the Bruker - returns the command given to the user plus additional values if requested. - On an error a string of the type E0n is appended to the command echo with - n being a small integer. In order to handle this all commands to the Bruker - are processed through this special function which takes care of the error - handling. -*/ - static int BrukerCommand(pBrukerDriv self, char *pCommand, - char *pReplyBuffer, int iReplyLen) - { - int iTest, iCode; - char *pPtr; - - assert(self); - assert(iReplyLen > 20); /* so small a buffer will hide errors */ - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - /* send the command to the Bruker */ - rmtrail(pCommand); - iTest = SerialWriteRead(&(self->pData), pCommand,pReplyBuffer, iReplyLen); -#ifdef debug - printf("Comm: %s , Reply %s\n",pCommand,pReplyBuffer); -#endif - if(iTest != 1) /* communication error */ - { - self->iLastError = iTest; - return 0; - } - - /* identify timeout */ - if(strstr(pReplyBuffer,"?TMO") != NULL) - { - self->iLastError = BTIMEOUT; - return 0; - } - - /* try to find a E0 response indicating a Bruker error */ - if( (pPtr = strstr(pReplyBuffer,"E0")) == NULL) - { - return 1; - } - - /* decode the error */ - sscanf(pPtr+1,"%x",&iCode); - switch(iCode) - { - case 1: - self->iLastError = NOFUNC; - break; - case 2: - self->iLastError = BADARG; - break; - case 4: - self->iLastError = NOACCESS; - break; - case 5: - self->iLastError = BADRANGE; - break; - case 7: - self->iLastError = ERRPENDING; - break; - case 9: - self->iLastError = NOPOWER; - break; - case 10: - self->iLastError = NOTFIELD; - break; - default: - self->iLastError = BADINTERN; - break; - } - return 0; - } -/*-------------------------------------------------------------------------*/ - int BrukerReadField(pEVControl pEva, float *fField) - { - pBrukerDriv self = NULL; - int iRet; - char pBueffel[80]; - char pCommand[6]; - char *pPtr,*pSign; - int iSign = 1; - float fVal; - - self = (pBrukerDriv)pEva->pDriv->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - strcpy(pCommand,"FIE/"); - iRet = BrukerCommand(self,pCommand,pBueffel,79); - if(!iRet) - { - *fField = -99; - return 0; - } - - pPtr = pBueffel+4; /* skip over echo */ - /* deal with obstructing sign */ - if( (pSign = strchr(pPtr,'+')) != NULL) - { - *pSign = ' '; - iSign = 1; - } - if( (pSign = strchr(pPtr,'-')) != NULL) - { - *pSign = ' '; - iSign = -1; - } - sscanf(pPtr,"%f",&fVal); - *fField = iSign * fVal; - return 1; - } -/*-------------------------------------------------------------------------*/ - int BrukerReadCurrent(pEVControl pEva, float *fField) - { - pBrukerDriv self = NULL; - int iRet, iSign = 1; - char pBueffel[80]; - char pCommand[6]; - char *pPtr, *pSign = NULL; - float fVal; - - self = (pBrukerDriv)pEva->pDriv->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - strcpy(pCommand,"CHN/"); - iRet = BrukerCommand(self,pCommand,pBueffel,79); - if(!iRet) - { - *fField = -99; - return 0; - } - - pPtr = pBueffel+4; /* skip over echo */ - /* deal with obstructing sign */ - if( (pSign = strchr(pPtr,'+')) != NULL) - { - *pSign = ' '; - iSign = 1; - } - if( (pSign = strchr(pPtr,'-')) != NULL) - { - *pSign = ' '; - iSign = -1; - } - sscanf(pPtr,"%f",&fVal); - *fField = iSign * fVal; - return 1; - } -/*-------------------------------------------------------------------------*/ - static int BrukerGet(pEVDriver pEva, float *fValue) - { - pBrukerDriv self = NULL; - int iRet, iSign = 1; - char pBueffel[80]; - char pCommand[6]; - char *pPtr, *pSign = NULL; - float fVal; - - self = (pBrukerDriv)pEva->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - if(self->iMode == FIELD) - { - strcpy(pCommand,"CUF/"); - iRet = BrukerCommand(self,pCommand,pBueffel,79); - } - else if(self->iMode == CURRENT) - { - strcpy(pCommand,"CUR/"); - iRet = BrukerCommand(self,pCommand,pBueffel,79); - } - else - { - /* programming error */ - assert(1); - } - - if(!iRet) - { - *fValue = -99; - return 0; - } - - pPtr = pBueffel+4; /* skip over echo */ - /* deal with obstructing sign */ - if( (pSign = strchr(pPtr,'+')) != NULL) - { - *pSign = ' '; - iSign = 1; - } - if( (pSign = strchr(pPtr,'-')) != NULL) - { - *pSign = ' '; - iSign = -1; - } - sscanf(pPtr,"%f",&fVal); - *fValue = iSign * fVal; - return 1; - } -/*-------------------------------------------------------------------------*/ - static int BrukerRun(pEVDriver pEva, float fVal) - { - pBrukerDriv self = NULL; - int iRet; - char pBueffel[80]; - char pCommand[40]; - char *pPtr; - - self = (pBrukerDriv)pEva->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - if(self->iMode == FIELD) - { - sprintf(pCommand,"PTF=%-6.2f",fVal); - iRet = BrukerCommand(self,pCommand,pBueffel,79); - } - else if(self->iMode == CURRENT) - { - sprintf(pCommand,"PNT=%-6.2f",fVal); - iRet = BrukerCommand(self,pCommand,pBueffel,79); - } - else - { - /* programming error */ - assert(1); - } - - if(!iRet) - { - return 0; - } - return 1; - } -/*------------------------------------------------------------------------*/ - static int BrukerError(pEVDriver pEva, int *iCode, char *pError, - int iErrLen) - { - pBrukerDriv self = NULL; - - self = (pBrukerDriv)pEva->pPrivate; - assert(self); - - *iCode = self->iLastError; - switch(*iCode) - { - case NOFUNC: - strncpy(pError, - "Function not supported", - iErrLen); - break; - case BADINTERN: - case BADARG: - strncpy(pError, - "Programming problem, reset Controller & contact Programmer", - iErrLen); - break; - case NOTFIELD: - strncpy(pError,"Bruker not switched to field mode",iErrLen); - break; - case BADRANGE: - strncpy(pError,"Requested value out of range",iErrLen); - break; - case NOACCESS: - strncpy(pError,"No Access, check key position at Controller", - iErrLen); - break; - case ERRPENDING: - strncpy(pError,"Error condition pending in Bruker Controller", - iErrLen); - break; - case NOPOWER: - strncpy(pError, - "Power OFF as consequence of some error in Bruker Controller", - iErrLen); - break; - case NOCONN: - strncpy(pError,"No Connection to Bruker Controller",iErrLen); - break; - case BTIMEOUT: - strncpy(pError,"Timeout at serial port",iErrLen); - break; - case NOPOLUNIT: - strncpy(pError,"No polarity switching unit, try setting negative current", - iErrLen); - break; - default: - SerialError(*iCode,pError,iErrLen); - break; - } - return 1; - } -/*---------------------------------------------------------------------------*/ - static int BrukerSend(pEVDriver pEva, char *pCommand, char *pReply, - int iReplyLen) - { - pBrukerDriv self = NULL; - int iRet; - - self = (pBrukerDriv)pEva->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - - iRet = SerialWriteRead(&(self->pData),pCommand, pReply, iReplyLen); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - return 1; - } -/*--------------------------------------------------------------------------*/ - static int BrukerInit(pEVDriver pEva) - { - pBrukerDriv self = NULL; - int iRet; - char pBueffel[80], pCommand[20]; - - self = (pBrukerDriv)pEva->pPrivate; - assert(self); - - /* open port connection */ - self->pData = NULL; - iRet = SerialOpen(&(self->pData),self->pHost, self->iPort, self->iChannel); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - /* configure serial port terminators */ - SerialSendTerm(&(self->pData),"\r"); - SerialATerm(&(self->pData),"1\r\n"); - - /* set power on */ - strcpy(pCommand,"DCP=1"); - iRet = SerialWriteRead(&(self->pData),pCommand,pBueffel,80); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - - /* switch to current mode as default init mode */ - self->iMode = CURRENT; - strcpy(pCommand,"EXT=0"); - iRet = SerialWriteRead(&(self->pData),pCommand,pBueffel,80); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - return 1; - } -/*-------------------------------------------------------------------------*/ - static int BrukerClose(pEVDriver pEva) - { - pBrukerDriv self = NULL; - - self = (pBrukerDriv)pEva->pPrivate; - assert(self); - - SerialClose(&(self->pData)); - self->pData = 0; - - return 1; - } -/*---------------------------------------------------------------------------*/ - static int BrukerFix(pEVDriver self, int iError) - { - pBrukerDriv pMe = NULL; - int iRet; - char pCommand[20], pBueffel[80]; - - assert(self); - pMe = (pBrukerDriv )self->pPrivate; - assert(pMe); - - switch(iError) - { - /* network errors */ - case EL734__BAD_FLUSH: - case EL734__BAD_RECV: - case EL734__BAD_RECV_NET: - case EL734__BAD_RECV_UNKN: - case EL734__BAD_RECVLEN: - case EL734__BAD_RECV1: - case EL734__BAD_RECV1_PIPE: - case EL734__BAD_RNG: - case EL734__BAD_SEND: - case EL734__BAD_SEND_PIPE: - case EL734__BAD_SEND_NET: - case EL734__BAD_SEND_UNKN: - case EL734__BAD_SENDLEN: - BrukerClose(self); - iRet = BrukerInit(self); - if(iRet) - { - return DEVREDO; - } - else - { - return DEVFAULT; - } - break; - case EL734__FORCED_CLOSED: - case NOCONN: - iRet = BrukerInit(self); - if(iRet) - { - return DEVREDO; - } - else - { - return DEVFAULT; - } - break; - /* fixable Bruker Errors */ - case ERRPENDING: - strcpy(pCommand,"RST=0"); - iRet = BrukerCommand(pMe,pCommand, pBueffel,79); - if(iRet) - { - return DEVREDO; - } - else - { - return DEVFAULT; - } - break; - case NOPOWER: - strcpy(pCommand,"RST=0"); - iRet = BrukerCommand(pMe,pCommand, pBueffel,79); - strcpy(pCommand,"DCP=1"); - iRet = BrukerCommand(pMe,pCommand, pBueffel,79); - if(iRet) - { - return DEVREDO; - } - else - { - return DEVFAULT; - } - break; - case NOTFIELD: - strcpy(pCommand,"EXT=2"); - iRet = BrukerCommand(pMe,pCommand, pBueffel,79); - if(iRet) - { - return DEVREDO; - } - else - { - return DEVFAULT; - } - break; - /* handable protocoll errors */ - case EL734__BAD_TMO: - case BTIMEOUT: - case NOFUNC: - return DEVREDO; - break; - default: - return DEVFAULT; - break; - } - return DEVFAULT; - } -/*------------------------------------------------------------------------*/ - void KillBruker(void *pData) - { - pBrukerDriv pMe = NULL; - - pMe = (pBrukerDriv)pData; - assert(pMe); - - if(pMe->pHost) - { - free(pMe->pHost); - } - free(pMe); - } -/*------------------------------------------------------------------------*/ - pEVDriver CreateBrukerDriver(int argc, char *argv[]) - { - pEVDriver pNew = NULL; - pBrukerDriv pSim = NULL; - - /* check for arguments */ - if(argc < 3) - { - return NULL; - } - - pNew = CreateEVDriver(argc,argv); - pSim = (pBrukerDriv)malloc(sizeof(BrukerDriv)); - memset(pSim,0,sizeof(BrukerDriv)); - if(!pNew || !pSim) - { - return NULL; - } - pNew->pPrivate = pSim; - pNew->KillPrivate = KillBruker; - - /* initalise pBrukerDriver */ - pSim->iLastError = 0; - pSim->pHost = strdup(argv[0]); - pSim->iPort = atoi(argv[1]); - pSim->iChannel = atoi(argv[2]); - - - /* initialise function pointers */ - pNew->SetValue = BrukerRun; - pNew->GetValue = BrukerGet; - pNew->Send = BrukerSend; - pNew->GetError = BrukerError; - pNew->TryFixIt = BrukerFix; - pNew->Init = BrukerInit; - pNew->Close = BrukerClose; - - return pNew; - } -/*-------------------------------------------------------------------------*/ - int BrukerSetMode(pEVControl pEva, SConnection *pCon, int iMode) - { - pBrukerDriv self = NULL; - int iRet; - char pBueffel[80]; - char pCommand[6]; - char *pPtr; - - self = (pBrukerDriv)pEva->pDriv->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - if(iMode == CURRENT) - { - strcpy(pCommand,"EXT=0"); - } - else if(iMode == FIELD) - { - strcpy(pCommand,"EXT=2"); - } - else - { - SCWrite(pCon,"ERROR: Internal: invalid mode for Bruker given",eError); - return 0; - } - iRet = BrukerCommand(self,pCommand,pBueffel,79); - if(!iRet) - { - strcpy(pBueffel,"ERROR:"); - BrukerError(pEva->pDriv,&iRet,(pBueffel+7),70); - SCWrite(pCon,pBueffel,eError); - return 0; - } - self->iMode = iMode; - return 1; - } -/*-------------------------------------------------------------------------*/ - int BrukerGetPolarity(pEVControl pEva, SConnection *pCon, int *iMode) - { - pBrukerDriv self = NULL; - int iRet; - char pBueffel[80]; - char pCommand[6]; - char *pPtr; - - self = (pBrukerDriv)pEva->pDriv->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - strcpy(pCommand,"POL/"); - iRet = BrukerCommand(self,pCommand,pBueffel,79); - if(!iRet) - { - strcpy(pBueffel,"ERROR:"); - BrukerError(pEva->pDriv,&iRet,(pBueffel+7),70); - SCWrite(pCon,pBueffel,eError); - return 0; - } - pPtr = pBueffel+4; - sscanf(pPtr,"%d",iMode); - return 1; - } -/*------------------------------------------------------------------------*/ - int BrukerSetPolarity(pEVControl pEva, SConnection *pCon, int iMode) - { - pBrukerDriv self = NULL; - int iRet; - char pBueffel[80]; - char pCommand[6]; - char *pPtr; - - self = (pBrukerDriv)pEva->pDriv->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - if(iMode == PPLUS) - { - strcpy(pCommand,"POL=0"); - } - else if(iMode == PMINUS) - { - strcpy(pCommand,"POL=1"); - } - else - { - assert(1); /* programming error */ - } - - iRet = BrukerCommand(self,pCommand,pBueffel,79); - if( (strstr(pBueffel,"POL=0E01") != NULL) || - (strstr(pBueffel,"POL=1E01") != NULL) ) - { - self->iLastError = NOPOLUNIT; - iRet = 0; - } - if(!iRet) - { - strcpy(pBueffel,"ERROR:"); - BrukerError(pEva->pDriv,&iRet,(pBueffel+6),70); - SCWrite(pCon,pBueffel,eError); - return 0; - } - return 1; - } -/*-------------------------------------------------------------------------- - handle Bruker specific commands: - - polarity for switching polarity - - field for reading field - - current for reading current - - mode for setting and retrieving the current control mode - - list append our own stuff to the rest - in all other cases fall back and call EVControllerWrapper to handle it or - eventually throw an error. -*/ - int BrukerAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - - pEVControl self = NULL; - int iRet, iMode; - char pBueffel[256]; - pBrukerDriv pMe = NULL; - float fVal; - - self = (pEVControl)pData; - assert(self); - pMe = (pBrukerDriv)self->pDriv->pPrivate; - assert(pMe); - - if(argc > 1) - { - strtolower(argv[1]); -/*------ polarity */ - if(strcmp(argv[1],"polarity") == 0) - { - if(argc > 2) /* set case */ - { - strtolower(argv[2]); - if(strcmp(argv[2],"plus") == 0) - { - iMode = PPLUS; - } - else if(strcmp(argv[2],"minus") == 0) - { - iMode = PMINUS; - } - else - { - sprintf(pBueffel,"ERROR: %s is no knwon polarity mode", argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - /* check permission */ - if(!SCMatchRights(pCon,usUser)) - { - return 0; - } - /* do it */ - iRet = BrukerSetPolarity(self,pCon,iMode); - if(iRet) - { - SCSendOK(pCon); - return 1; - } - else - { - return 0; - } - } - else /* get case */ - { - iRet = BrukerGetPolarity(self,pCon,&iMode); - if(iRet) - { - if(iMode == PPLUS) - { - sprintf(pBueffel,"%s.polarity = plus",argv[0]); - } - else if (iMode == PMINUS) - { - sprintf(pBueffel,"%s.polarity = minus",argv[0]); - } - else - { - assert(1); /* programming problem */ - } - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } - } -/*-------- control mode */ - else if(strcmp(argv[1],"mode") == 0) - { - if(argc > 2) /* set case */ - { - strtolower(argv[2]); - if(strcmp(argv[2],"field") == 0) - { - iMode = FIELD; - } - else if(strcmp(argv[2],"current") == 0) - { - iMode = CURRENT; - } - else - { - sprintf(pBueffel,"ERROR: %s is no known control mode", argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - /* check permission */ - if(!SCMatchRights(pCon,usUser)) - { - return 0; - } - /* do it */ - iRet = BrukerSetMode(self,pCon,iMode); - if(iRet) - { - SCSendOK(pCon); - return 1; - } - else - { - return 0; - } - } - else /* get case */ - { - if(pMe->iMode == FIELD) - { - sprintf(pBueffel,"%s.mode = field",argv[0]); - } - else if (pMe->iMode == CURRENT) - { - sprintf(pBueffel,"%s.mode = current",argv[0]); - } - else - { - assert(1); /* programming problem */ - } - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } -/*-----------field */ - else if(strcmp(argv[1],"field") == 0) - { - iRet = BrukerReadField(self,&fVal); - if(!iRet) - { - strcpy(pBueffel,"ERROR: "); - self->pDriv->GetError(self->pDriv,&iMode,pBueffel+7,240); - SCWrite(pCon,pBueffel,eError); - return 0; - } - sprintf(pBueffel,"%s.field = %f Tesla",argv[0],fVal); - SCWrite(pCon,pBueffel,eValue); - return 1; - } -/*----------- current */ - else if(strcmp(argv[1],"current") == 0) - { - iRet = BrukerReadCurrent(self,&fVal); - if(!iRet) - { - strcpy(pBueffel,"ERROR: "); - self->pDriv->GetError(self->pDriv,&iMode,pBueffel+7,240); - SCWrite(pCon,pBueffel,eError); - return 0; - } - sprintf(pBueffel,"%s.current = %f A",argv[0],fVal); - SCWrite(pCon,pBueffel,eValue); - return 1; - } -/*--------- list */ - else if(strcmp(argv[1],"list") == 0) - { - /* print generals first */ - EVControlWrapper(pCon,pSics,pData,argc,argv); - /* print our add on stuff */ - iRet = BrukerReadCurrent(self,&fVal); - if(!iRet) - { - strcpy(pBueffel,"ERROR: "); - self->pDriv->GetError(self->pDriv,&iMode,pBueffel+7,240); - SCWrite(pCon,pBueffel,eError); - } - else - { - sprintf(pBueffel,"%s.current = %f A",argv[0],fVal); - SCWrite(pCon,pBueffel,eValue); - } - iRet = BrukerReadField(self,&fVal); - if(!iRet) - { - strcpy(pBueffel,"ERROR: "); - self->pDriv->GetError(self->pDriv,&iMode,pBueffel+7,240); - SCWrite(pCon,pBueffel,eError); - } - else - { - sprintf(pBueffel,"%s.field = %f Tesla",argv[0],fVal); - SCWrite(pCon,pBueffel,eValue); - } - if(pMe->iMode == FIELD) - { - sprintf(pBueffel,"%s.mode = field",argv[0]); - } - else if (pMe->iMode == CURRENT) - { - sprintf(pBueffel,"%s.mode = current",argv[0]); - } - else - { - sprintf(pBueffel,"ERROR: Programming error"); - } - SCWrite(pCon,pBueffel,eValue); - iRet = BrukerGetPolarity(self,pCon,&iMode); - if(iRet) - { - if(iMode == PPLUS) - { - sprintf(pBueffel,"%s.polarity = plus",argv[0]); - } - else if (iMode == PMINUS) - { - sprintf(pBueffel,"%s.polarity = minus",argv[0]); - } - else if(iMode == PBUSY) - { - sprintf(pBueffel,"%s.polarity = busy",argv[0]); - } - else - { - sprintf(pBueffel,"ERROR: Programming problem"); - } - SCWrite(pCon,pBueffel,eValue); - } - else - { - SCWrite(pCon,"ERROR: cannot read polarity",eError); - } - return 1; - } - else - { - return EVControlWrapper(pCon,pSics,pData,argc,argv); - } - } - return EVControlWrapper(pCon,pSics,pData,argc,argv); - } diff --git a/bruker.h b/bruker.h deleted file mode 100644 index bfa26a29..00000000 --- a/bruker.h +++ /dev/null @@ -1,25 +0,0 @@ -/*------------------------------------------------------------------------- - B r u k e r - - An environment control driver and an additonal wrapper function for - controlling a Bruker B-EC-1 magnet controller. This controller can - either control a current or control the current through an external hall - sensor mesuring the magnetic field. In both cases both values: the field - and the current must be readable. - - copyright: see copyright.h - - Mark Koennecke, October 1998 ----------------------------------------------------------------------------*/ -#ifndef BRUKERMAGNET -#define BRUKERMAGNET - - pEVDriver CreateBrukerDriver(int argc, char *argv[]); - - int BrukerReadField(pEVControl self, float *fField); - int BrukerReadCurrent(pEVControl self, float *fCurrent); - - int BrukerAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - -#endif diff --git a/bruker.w b/bruker.w deleted file mode 100644 index 2a96bcb9..00000000 --- a/bruker.w +++ /dev/null @@ -1,64 +0,0 @@ -\subsubsection{Bruker Magnet Controller B-EC-1} -SANS is using a Bruker magnet controller. This controller is integrated -into SICS as a derivate of an environment controller. The Bruker controller -can be operated in two modes: in the first the current is controlled, -in the second the current -is controlled by an external hall sensor giving the magnetic field. Whatever -is the controlling sensor, the magnetic field and the current need to be -read. Furthermore this device supports switching the polarity. All this is -achieved with a special driver and an additional wrapper function for -handling extra commands. All this is implemented in the file bruker.h -and bruker.c. The functions defined are: - -\begin{verbatim} - pEVDriver CreateBrukerDriver(int argc, char *argv[]); - - int BrukerReadField(pEVControl self, float *fField); - int BrukerReadCurrent(pEVControl self, float *fCurrent); - - int BrukerAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - -\end{verbatim} - -\begin{description} -\item[CreateBrukerDriver] creates a driver for the bruker magnet -controller. -\item[BrukerReadField] reads the current magnetic field. -\item[BrukerReadCurrent] reads the current current in Ampere. -\item[BrukerAction] a special SICS interpreter wrapper function for -the Bruker Magnet. This function handles the few special Bruker -commands and passes everything else to the standard environment -controller handler function. -\end{description} - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/buffer.c b/buffer.c deleted file mode 100644 index 998d1b39..00000000 --- a/buffer.c +++ /dev/null @@ -1,584 +0,0 @@ -/*-------------------------------------------------------------------------- - L N S R \"U N B U F F E R - - - Mark Koennecke, January 1997 - - Copyright: - - Labor fuer Neutronenstreuung - Paul Scherrer Institut - CH-5423 Villigen-PSI - - - The authors hereby grant permission to use, copy, modify, distribute, - and license this software and its documentation for any purpose, provided - that existing copyright notices are retained in all copies and that this - notice is included verbatim in any distributions. No written agreement, - license, or royalty fee is required for any of the authorized uses. - Modifications to this software may be copyrighted by their authors - and need not follow the licensing terms described here, provided that - the new terms are clearly indicated on the first page of each file where - they apply. - - IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY - FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY - DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - - THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE - IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE - NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR - MODIFICATIONS. -----------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include "fortify.h" -#include "lld.h" -#include "lld_blob.h" -#include "lld_str.h" -#include "conman.h" -#include "obdes.h" -#include "buffer.h" -#include "fupa.h" -#include "splitter.h" -#include "ruli.h" -/*-------------------------------------------------------------------------*/ - static int SaveBuffer(void *pData, char *name, FILE *fd) - { - pRuenBuffer self = NULL; - int iRet; - char *pPtr = NULL; - - assert(fd); - assert(pData); - - self = (pRuenBuffer)pData; - fprintf(fd,"# RuenBuffer %s\n",name); - fprintf(fd,"Buf new %s\n",name); - iRet = LLDnodePtr2First(self->iLineList); - while(iRet != 0) - { - pPtr = (char *)LLDnodePtr(self->iLineList); - fprintf(fd,"%s append %s\n",name,pPtr); - iRet = LLDnodePtr2Next(self->iLineList); - } - return 1; - } - -/*--------------------------------------------------------------------------*/ - pRuenBuffer CreateRuenBuffer(char *name) - { - pRuenBuffer pNew = NULL; - - pNew = (pRuenBuffer)malloc(sizeof(RuenBuffer)); - if(!pNew) - { - return NULL; - } - pNew->pDes = CreateDescriptor("SicsRuenBuffer"); - if(!pNew->pDes) - { - free(pNew); - return NULL; - } - - pNew->name = strdup(name); - Fortify_CheckAllMemory(); - pNew->iLineList = LLDblobCreate(); - if(pNew->iLineList == -1) - { - DeleteDescriptor(pNew->pDes); - free(pNew->name); - free(pNew); - return NULL; - } - pNew->pDes->SaveStatus = SaveBuffer; - return pNew; - } -/*--------------------------------------------------------------------------*/ - static void DeleteLineBuffer(int iList) - { - int iRet; - char *pPtr; - - iRet = LLDnodePtr2First(iList); - while(iRet != 0) - { - pPtr = (char *)LLDnodePtr(iList); - free(pPtr); - iRet = LLDnodePtr2Next(iList); - } - LLDdelete(iList); - } -/*-------------------------------------------------------------------------*/ - void DeleteRuenBuffer(void *self) - { - int iRet; - pRuenBuffer pOld = (pRuenBuffer)self; - - assert(pOld); - /* delete line buffer */ - DeleteLineBuffer(pOld->iLineList); - if(pOld->name) - { - free(pOld->name); - } - if(pOld->pDes) - { - DeleteDescriptor(pOld->pDes); - } - free(pOld); - } -/*--------------------------------------------------------------------------*/ - pRuenBuffer CopyRuenBuffer(pRuenBuffer pOld, char *name) - { - pRuenBuffer pNew = NULL; - int iRet; - char *pPtr; - - pNew = CreateRuenBuffer(name); - if(!pNew) - { - return NULL; - } - - /* copy list*/ - iRet = LLDnodePtr2First(pOld->iLineList); - while(iRet != 0) - { - pPtr = (char *)LLDnodePtr(pOld->iLineList); - LLDstringAdd(pNew->iLineList,pPtr); - iRet = LLDnodePtr2Next(pOld->iLineList); - } - return pNew; - } -/*-------------------------------------------------------------------------*/ - int BufferAppendLine(pRuenBuffer self, char *line) - { - assert(self); - - return LLDstringAppend(self->iLineList,line); - } -/*------------------------------------------------------------------------*/ - int BufferDel(pRuenBuffer self, int i) - { - int iNum; - int iRet; - - assert(self); - - iRet = LLDnodePtr2First(self->iLineList); - iNum = 0; - while(iRet != 0) - { - if(iNum == i) - { - LLDstringDelete(self->iLineList); - return 1; - } - iNum++; - iRet = LLDnodePtr2Next(self->iLineList); - } - return 0; - } -/*------------------------------------------------------------------------*/ - int BufferInsertAfter(pRuenBuffer self, int i, char *line) - { - int iNum; - int iRet; - - assert(self); - - iRet = LLDnodePtr2First(self->iLineList); - iNum = 0; - while(iRet != 0) - { - if(iNum == i) - { - LLDstringInsert(self->iLineList, line); - return 1; - } - iNum++; - iRet = LLDnodePtr2Next(self->iLineList); - } - return 0; - } -/*------------------------------------------------------------------------*/ - int BufferPrint(pRuenBuffer self, SConnection *pCon) - { - int iRet; - char *pPtr = NULL; - char pBueffel[512]; - int iCount = 1; - - iRet = LLDnodePtr2First(self->iLineList); - sprintf(pBueffel,"Listing for Bueffer %s",self->name); - SCWrite(pCon,pBueffel,eValue); - while(iRet != 0) - { - pPtr = (char *)LLDnodePtr(self->iLineList); - sprintf(pBueffel,"[%d] %s",iCount,pPtr); - SCWrite(pCon,pBueffel,eValue); - iRet = LLDnodePtr2Next(self->iLineList); - iCount++; - } - return 1; - } - -/*------------------------------------------------------------------------*/ - extern char *StrReplace(char *str, char *old, char *pNew); - /* realised in Strrepl.c - */ - - int BufferReplace(pRuenBuffer self, char *pattern, char *pReplace) - { - int iRet; - char *pPtr = NULL; - char pBueffel[1024]; - char *pRet; - - iRet = LLDnodePtr2First(self->iLineList); - while(iRet != 0) - { - pPtr = (char *)LLDnodePtr(self->iLineList); - strcpy(pBueffel,pPtr); - pRet = NULL; - pRet = StrReplace(pBueffel,pattern,pReplace); - if(pRet) - { - LLDstringDelete(self->iLineList); - iRet = LLDnodePtr2Next(self->iLineList); - LLDnodePtr2Prev(self->iLineList); - if(iRet) - { - LLDstringInsert(self->iLineList,pBueffel); - } - else - { - LLDstringAppend(self->iLineList,pBueffel); - } - } - iRet = LLDnodePtr2Next(self->iLineList); - } - return 1; - } -/*-----------------------------------------------------------------------*/ - int BufferRun(pRuenBuffer self, SConnection *pCon, SicsInterp *pSics) - { - int iRet; - char *pPtr = NULL; - int iInt, iRes; - - iRes = 1; - iRet = LLDnodePtr2First(self->iLineList); - while(iRet != 0) - { - pPtr = (char *)LLDnodePtr(self->iLineList); - iInt = InterpExecute(pSics,pCon,pPtr); - if(!iInt) - { - iRes = 0; - } - iRet = LLDnodePtr2Next(self->iLineList); - } - return iRes; - } -/*------------------------------------------------------------------------*/ - int BufferSave(pRuenBuffer self, char *file) - { - int iRet; - char *pPtr = NULL; - FILE *fd = NULL; - - fd = fopen(file,"w"); - if(fd == NULL) - { - return 0; - } - iRet = LLDnodePtr2First(self->iLineList); - while(iRet != 0) - { - pPtr = (char *)LLDnodePtr(self->iLineList); - fprintf(fd,"%s\n",pPtr); - iRet = LLDnodePtr2Next(self->iLineList); - } - fclose(fd); - return 1; - } -/*------------------------------------------------------------------------*/ - int BufferLoad(pRuenBuffer self, char *file) - { - int iRet; - char *pPtr = NULL; - FILE *fd = NULL; - char pBueffel[256]; - - fd = fopen(file,"r"); - if(fd == NULL) - { - return 0; - } - - pPtr = fgets(pBueffel,255,fd); - while(pPtr != NULL) - { - LLDstringAppend(self->iLineList,pBueffel); - pPtr = fgets(pBueffel,255,fd); - } - - fclose(fd); - return 1; - } - -/*------------------------------------------------------------------------*/ - pRuenBuffer FindRuenBuffer(SicsInterp *pSics, char *name) - { - pRuenBuffer pBuf = NULL; - CommandList *pCom = NULL; - - pCom = FindCommand(pSics,name); - if(!pCom) - { - return NULL; - } - pBuf = (pRuenBuffer)pCom->pData; - if(!pBuf) - { - return NULL; - } - if(!pBuf->pDes) - { - return NULL; - } - if(strcmp(pBuf->pDes->name,"SicsRuenBuffer") != 0) - { - return NULL; - } - return pBuf; - } -/*-------------------------------------------------------------------------*/ - int InitBufferSys(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - pRuenStack pStack = NULL; - - pStack = CreateRuenStack(); - if(!pStack) - { - SCWrite(pCon,"ERROR: No memory to create Ruen-Stack",eError); - return 0; - } - AddCommand(pSics,"Buf",BufferCommand,NULL,NULL); - AddCommand(pSics,"Stack",RuenStackAction,DeleteRuenStack,pStack); - return 1; - } -/*------------------------------------------------------------------------*/ - int BufferCommand(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - int iRet, iRet2; - char pBueffel[512]; - char **argx; - FuPaResult PaRes; - pRuenBuffer pBuf = NULL; - FuncTemplate BufferTemplate[] = { - {"new",1,{FUPATEXT} }, - {"del",1,{FUPATEXT} }, - {"copy",2,{FUPATEXT, FUPATEXT}}, - }; - - assert(pCon); - assert(pSics); - - /* minimum user to use this */ - if(!SCMatchRights(pCon,usUser)) - { - return 0; - } - /* parse function args */ - argtolower(argc,argv); - argx = &argv[1]; - iRet = EvaluateFuPa((pFuncTemplate)&BufferTemplate,3,argc-1,argx,&PaRes); - if(iRet < 0) - { - sprintf(pBueffel,"%s",PaRes.pError); - SCWrite(pCon,pBueffel,eError); - return 0; - } - - switch(iRet) - { - case 0: /* new */ - pBuf = CreateRuenBuffer(PaRes.Arg[0].text); - if(!pBuf) - { - SCWrite(pCon, "ERROR: Out of memory allocating buffer",eError); - return 0; - } - iRet2 = AddCommand(pSics,pBuf->name,BufferAction,DeleteRuenBuffer, - (void *)pBuf); - if(!iRet2) - { - sprintf(pBueffel,"ERROR: duplicate command %s not created",pBuf->name); - SCWrite(pCon,pBueffel,eError); - DeleteRuenBuffer((void *)pBuf); - return 0; - } - return 1; - break; - case 1: /* del */ - return RemoveCommand(pSics,PaRes.Arg[0].text); - break; - case 2: /* copy */ - pBuf = FindRuenBuffer(pSics,PaRes.Arg[0].text); - if(!pBuf) - { - sprintf(pBueffel,"ERROR: Buffer %s not found", - PaRes.Arg[0].text); - SCWrite(pCon,pBueffel,eError); - return 0; - } - pBuf = CopyRuenBuffer(pBuf,PaRes.Arg[1].text); - if(!pBuf) - { - sprintf(pBueffel,"ERROR: creating buffer %s ", - PaRes.Arg[1].text); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet2 = AddCommand(pSics,pBuf->name,BufferAction,DeleteRuenBuffer, - (void *)pBuf); - if(!iRet2) - { - sprintf(pBueffel,"ERROR: duplicate command %s not created",pBuf->name); - SCWrite(pCon,pBueffel,eError); - DeleteRuenBuffer((void *)pBuf); - return 0; - } - - return 1; - break; - default: - assert(0); - break; - - } - assert(0); - } -/*-------------------------------------------------------------------------*/ - int BufferAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - int iRet, iRet2; - char pBueffel[512]; - char **argx; - FuPaResult PaRes; - pRuenBuffer pBuf = NULL; - FuncTemplate BufferTemplate[] = { - {"append",0,{FUPATEXT} }, - {"del",1,{FUPAINT} }, - {"ins",1,{FUPAINT}}, - {"save",1,{FUPATEXT}}, - {"load",1,{FUPATEXT}}, - {"subst",2,{FUPATEXT,FUPATEXT}}, - {"print",0,{0,0}}, - {"run",0,{0,0}}, - NULL - }; - - assert(pCon); - assert(pSics); - pBuf = (pRuenBuffer)pData; - assert(pBuf); - - - /* You need to be user in order to do this */ - if(!SCMatchRights(pCon,usUser)) - { - return 0; - } - /* parse function args */ - argx = &argv[1]; - strtolower(argx[0]); - iRet = EvaluateFuPa((pFuncTemplate)&BufferTemplate,8,argc-1,argx,&PaRes); - if(iRet < 0) - { - sprintf(pBueffel,"%s",PaRes.pError); - SCWrite(pCon,pBueffel,eError); - return 0; - } - - switch(iRet) - { - case 0: /* append */ - argx = &argv[2]; - Arg2Text(argc-2,argx,pBueffel,511); - BufferAppendLine(pBuf,pBueffel); - SCSendOK(pCon); - return 1; - break; - case 1: /* del */ - iRet2 = BufferDel(pBuf,PaRes.Arg[0].iVal); - if(iRet2) - SCSendOK(pCon); - break; - case 2: /* ins */ - argx = &argv[3]; - Arg2Text(argc-3,argx,pBueffel,511); - iRet2 = BufferInsertAfter(pBuf,PaRes.Arg[0].iVal,pBueffel); - if(iRet2) - SCSendOK(pCon); - return iRet2; - break; - case 3: /* save */ - iRet2 = BufferSave(pBuf,PaRes.Arg[0].text); - if(!iRet2) - { - sprintf(pBueffel,"ERROR: cannot open %s for writing", - PaRes.Arg[0].text); - SCWrite(pCon,pBueffel,eError); - return 0; - } - else - { - SCSendOK(pCon); - return 1; - } - break; - case 4: /* load */ - iRet2 = BufferLoad(pBuf,PaRes.Arg[0].text); - if(!iRet2) - { - sprintf(pBueffel,"ERROR: cannot open %s for reading ", - PaRes.Arg[0].text); - SCWrite(pCon,pBueffel,eError); - return 0; - } - else - { - SCSendOK(pCon); - return 1; - } - break; - case 5: /* subst */ - iRet2 = BufferReplace(pBuf,PaRes.Arg[0].text,PaRes.Arg[1].text); - if(iRet2) - SCSendOK(pCon); - break; - case 6: /* print */ - return BufferPrint(pBuf,pCon); - break; - case 7: /* run */ - return BufferRun(pBuf,pCon,pSics); - default: - assert(0); - } - return 1; - } - diff --git a/buffer.h b/buffer.h deleted file mode 100644 index 785c487b..00000000 --- a/buffer.h +++ /dev/null @@ -1,94 +0,0 @@ -/*--------------------------------------------------------------------------- - - T H E L N S R \" U N B U F F E R - - The LNS has devised a special scheme to operate an instrument - via R\"un sequeneces and buffers. A R\"unbuffer is a series of - commands which are collected in a buffer. This buffer is - implemented here. A buffer can be added to, printed loaded from - a file etc. and can be executed. - - The next schem is the R\"unlist which is a stack of R\"unbuffers. - That list can be exeuted as well. It gets a buffer from the - bottom of the stack and executes it and does so until the stack - is empty. While this is happening you are able to add other - buffers to the top of the stack. This schem is implemented in module - ruli. - - So, here is all necessary to deal with an individual buffer. - For Lists A. Reitsma's lld package will be used. This package - identifies a list by an integer handle. - - Mark Koennecke, January 1996 - - copyright: see implementation file -----------------------------------------------------------------------------*/ -#ifndef RUENBUFFER -#define RUENBUFFER - - typedef struct { - pObjectDescriptor pDes; /* needed */ - char *name; /* BufferName */ - int iLineList; /* Handle to the Line List */ - } RuenBuffer, *pRuenBuffer; - -/*--------------------- live & death ----------------------------------- */ - pRuenBuffer CreateRuenBuffer(char *name); - void DeleteRuenBuffer(void *pSelf); - pRuenBuffer CopyRuenBuffer(pRuenBuffer pOld, char *NewName); - -/*--------------------- operations --------------------------------------*/ - - int BufferAppendLine(pRuenBuffer self, char *line); - int BufferDel(pRuenBuffer self, int iLine); - /* - deletes line iLine from the RuenBuffer self - --------------------------------------------------------------------------*/ - int BufferInsertAfter(pRuenBuffer self, int iLine, char *line); - /* - inserts line line AFTER line number iLine in the RuenBuffer self -------------------------------------------------------------------------- */ - int BufferPrint(pRuenBuffer self, SConnection *pCon); - /* - lists the contents of the RuenBuffer on the Connection pCon ------------------------------------------------------------------------- */ - int BufferReplace(pRuenBuffer self, char *pattern, char *pReplace); - /* - replaces all occurences of the string pattern in the whole RuenBuffer - by the replacement string pReplace. -------------------------------------------------------------------------- */ - int BufferRun(pRuenBuffer self, SConnection *pCon, SicsInterp *pSics); - /* - executes the lines of the Ruenbuffer one by one. - Returns 1 on success, 0 on error. -------------------------------------------------------------------------- */ - int BufferSave(pRuenBuffer self, char *file); - /* - writes the contents of Ruenbuffer self to the file specified by - file. - Returns 1 on success, 0 on error. ---------------------------------------------------------------------------*/ - int BufferLoad(pRuenBuffer self, char *file); - /* - reads the contents of file into the RuenBuffer self. - Returns 1 on success, 0 on error. - */ -/* ------------------------ object functions ----------------------------*/ - int InitBufferSys(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - int BufferCommand(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - int BufferAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - -/* ----------------------- utility --------------------------------------*/ - pRuenBuffer FindRuenBuffer(SicsInterp *pSics, char *name); - /* - similar to FindCommand in SCinter.h. But checks the object found if - it is a RuenBuffer. - Returns NULL if no RuenBuffer with this name could be found. - Returns a pointer to the RuenBuffer, when a RuenBuffer of this - name could be found in the interpreter pSics -----------------------------------------------------------------------------*/ -#endif diff --git a/choco.c b/choco.c index f8902f00..c4db12ab 100644 --- a/choco.c +++ b/choco.c @@ -12,6 +12,7 @@ #include #include "fortify.h" #include "sics.h" +#include "site.h" #define CHOCOINTERNAL #include "choco.h" @@ -174,9 +175,6 @@ */ extern pCodri MakeSimChopper(void); -extern pCodri MakeDoChoDriver(char *pHost, int iPort, int iChannel, - int iSingle); -extern pCodri MakeCookerDriver(char *pHost, int iPort, int iChannel); /*-----------------------------------------------------------------------*/ int ChocoFactory(SConnection *pCon, SicsInterp *pSics, void *pData, int argc, char *argv[]) @@ -187,6 +185,7 @@ extern pCodri MakeCookerDriver(char *pHost, int iPort, int iChannel); char pBueffel[132]; int iRet, iPort, iChannel; int iSingle = 0; + pSite site = NULL; if(argc < 3) { @@ -206,78 +205,20 @@ extern pCodri MakeCookerDriver(char *pHost, int iPort, int iChannel); { pDriv = MakeSimChopper(); } - else if(strcmp(argv[2],"docho") == 0) - { - if(argc < 6) - { - SCWrite(pCon, - "ERROR: Insufficient number of arguments to install Dornier Chopper driver", - eError); - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[4],&iPort); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: expected integer as port number, got %s", - argv[4]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[5],&iChannel); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: expected integer as channel number, got %s", - argv[4]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - if(argc > 6) - { - iRet = Tcl_GetInt(pSics->pTcl,argv[6],&iSingle); - if(iRet != TCL_OK) - { - sprintf(pBueffel, - "ERROR: expected integer as single flag, got %s", - argv[6]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - } - pDriv = MakeDoChoDriver(argv[3],iPort,iChannel,iSingle); - } - else if(strcmp(argv[2],"sanscook") == 0) - { - if(argc < 6) - { - SCWrite(pCon, - "ERROR: Insufficient number of arguments to install SANS Cooker driver", - eError); - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[4],&iPort); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: expected integer as port number, got %s", - argv[4]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[5],&iChannel); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: expected integer as channel number, got %s", - argv[4]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - pDriv = MakeCookerDriver(argv[3],iPort,iChannel); - } else { - sprintf(pBueffel,"ERROR: Driver %s NOT supported for MakeController", + site = getSite(); + if(site != NULL){ + pDriv = site->CreateControllerDriver(pCon,argc-2,&argv[2]); + } else { + pDriv = NULL; + } + if(pDriv == NULL){ + sprintf(pBueffel,"ERROR: Driver %s NOT supported for MakeController", argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; + SCWrite(pCon,pBueffel,eError); + return 0; + } } if( (pNew == NULL) || (pDes == NULL) || (pDriv == NULL) ) { diff --git a/countdriv.c b/countdriv.c index bf421fa0..1bbe47f5 100644 --- a/countdriv.c +++ b/countdriv.c @@ -43,9 +43,6 @@ #include #include "sics.h" #include "countdriv.h" -#include "hardsup/sinq_prototypes.h" -#include "hardsup/el737_def.h" -#include "hardsup/el737fix.h" /*-------------------------------------------------------------------------*/ pCounterDriver CreateCounterDriver(char *name, char *type) @@ -92,661 +89,13 @@ } if(self->pData) { - free(self->pData); + if(self->KillPrivate != NULL) + { + self->KillPrivate(self); + } else { + free(self->pData); + } } free(self); } -/*----------------------------- EL737 ------------------------------------*/ - typedef struct { - char *host; - int iPort; - int iChannel; - void *pData; - int finishCount; - } EL737st; -/*------------------------------------------------------------------------*/ - static int EL737GetStatus(struct __COUNTER *self, float *fControl) - { - int iRet; - int iC1, iC2, iC3,iC4,iRS; - float fTime; - EL737st *pEL737; - - assert(self); - pEL737 = (EL737st *)self->pData; - assert(pEL737); - iRet = EL737_GetStatus(&pEL737->pData,&iC1,&iC2,&iC3,&iC4,&fTime,&iRS); - if(self->eMode == eTimer) - { - *fControl = fTime; - } - else - { - *fControl = iC1; - } - /* store time */ - self->fTime = fTime; - - if(iRet != 1) - { - return HWFault; - } - self->lCounts[0] = iC2; - self->lCounts[1] = iC1; - self->lCounts[2] = iC3; - self->lCounts[3] = iC4; - - /* get extra counters for 8-fold counter boxes */ - iRet = EL737_GetStatusExtra(&pEL737->pData,&iC1,&iC2,&iC3,&iC4); - self->lCounts[4] = iC1; - self->lCounts[5] = iC2; - self->lCounts[6] = iC3; - self->lCounts[7] = iC4; - if(iRS == 0) - { - pEL737->finishCount++; - if(pEL737->finishCount >= 2) - { - return HWIdle; - } - else - { - return HWBusy; - } - } - else if((iRS == 1) || (iRS == 2)) - { - pEL737->finishCount = 0; - return HWBusy; - } - else if( (iRS == 5) || (iRS == 6)) - { - pEL737->finishCount = 0; - return HWNoBeam; - } - else - { - pEL737->finishCount = 0; - return HWPause; - } - } -#ifdef NONINTF - extern float nintf(float f); -#endif -/*-------------------------------------------------------------------------*/ - static int EL737Start(struct __COUNTER *self) - { - int iRet, iRS; - EL737st *pEL737; - - assert(self); - pEL737 = (EL737st *)self->pData; - assert(pEL737); - - - self->fTime = 0.; - - if(self->eMode == ePreset) - { - iRet = EL737_StartCnt(&pEL737->pData,(int)nintf(self->fPreset),&iRS); - if(iRet == 1) - { - pEL737->finishCount = 0; - return OKOK; - } - else - { - return HWFault; - } - } - else if(self->eMode == eTimer) - { - iRet = EL737_StartTime(&pEL737->pData,self->fPreset,&iRS); - if(iRet == 1) - { - pEL737->finishCount = 0; - return OKOK; - } - else - { - return HWFault; - } - } - return 0; - } -/*-------------------------------------------------------------------------*/ - static int EL737Pause(struct __COUNTER *self) - { - int iRet, iRS; - EL737st *pEL737; - - assert(self); - pEL737 = (EL737st *)self->pData; - assert(pEL737); - - - iRet = EL737_Pause(&pEL737->pData,&iRS); - if(iRet == 1) - { - return OKOK; - } - else - { - return HWFault; - } - return 0; - } -/*-------------------------------------------------------------------------*/ - static int EL737Continue(struct __COUNTER *self) - { - int iRet, iRS; - EL737st *pEL737; - - assert(self); - pEL737 = (EL737st *)self->pData; - assert(pEL737); - - - iRet = EL737_Continue(&pEL737->pData,&iRS); - if(iRet == 1) - { - return OKOK; - } - else - { - return HWFault; - } - return 0; - } -/*--------------------------------------------------------------------------*/ - static int EL737Halt(struct __COUNTER *self) - { - int iRet, iC1, iC2, iC3, iC4,iRS; - float fPreset; - EL737st *pEL737; - - assert(self); - pEL737 = (EL737st *)self->pData; - assert(pEL737); - - - - iRet = EL737_Stop(&pEL737->pData,&iC1, &iC2,&iC3,&iC4,&fPreset,&iRS); - if(iRet == 1) - { - self->lCounts[0] = iC2; - self->lCounts[1] = iC1; - self->lCounts[2] = iC3; - self->lCounts[3] = iC4; - return OKOK; - } - return HWFault; - } -/*--------------------------------------------------------------------------*/ - static int EL737ReadValues(struct __COUNTER *self) - { - int iRet; - int iC1, iC2, iC3,iC4,iRS; - float fTime; - EL737st *pEL737; - - assert(self); - pEL737 = (EL737st *)self->pData; - assert(pEL737); - - - iRet = EL737_GetStatus(&pEL737->pData,&iC1,&iC2,&iC3,&iC4,&fTime,&iRS); - if(iRet != 1) - { - return HWFault; - } - self->fTime = fTime; - - self->lCounts[0] = iC2; - self->lCounts[1] = iC1; - self->lCounts[2] = iC3; - self->lCounts[3] = iC4; - /* get extra counters for 8-fold counter boxes */ - iRet = EL737_GetStatusExtra(&pEL737->pData,&iC1,&iC2,&iC3,&iC4); - self->lCounts[4] = iC1; - self->lCounts[5] = iC2; - self->lCounts[6] = iC3; - self->lCounts[7] = iC4; - - return OKOK; - } -/*--------------------------------------------------------------------------- - - EL737Error2Text converts between an EL734 error code to text ------------------------------------------------------------------------------*/ - static void EL737Error2Text(char *pBuffer, int iErr) - { - switch(iErr) - { - case EL737__BAD_ADR: - strcpy(pBuffer,"EL737__BAD_ADR"); - break; - case EL737__BAD_OVFL: - strcpy(pBuffer,"EL737__BAD_OVFL"); - break; - case EL737__BAD_BSY: - strcpy(pBuffer,"EL737__BAD_BSY"); - break; - case EL737__BAD_SNTX: - strcpy(pBuffer,"EL737__BAD_SNTX"); - break; - case EL737__BAD_CONNECT: - strcpy(pBuffer,"EL737__BAD_CONNECT"); - break; - case EL737__BAD_FLUSH: - strcpy(pBuffer,"EL737__BAD_FLUSH"); - break; - case EL737__BAD_DEV: - strcpy(pBuffer,"EL734__BAD_DEV"); - break; - case EL737__BAD_ID: - strcpy(pBuffer,"EL737__BAD_ID"); - break; - case EL737__BAD_ILLG: - strcpy(pBuffer,"EL737__BAD_ILLG"); - break; - case EL737__BAD_LOC: - strcpy(pBuffer,"EL737__BAD_LOC"); - break; - case EL737__BAD_MALLOC: - strcpy(pBuffer,"EL737__BAD_MALLOC"); - break; - case EL737__BAD_NOT_BCD: - strcpy(pBuffer,"EL737__BAD_NOT_BCD"); - break; - case EL737__BAD_OFL: - strcpy(pBuffer,"EL737__BAD_OFL"); - break; - case EL737__BAD_PAR: - strcpy(pBuffer,"EL737__BAD_PAR"); - break; - - case EL737__BAD_RECV: - strcpy(pBuffer,"EL737__BAD_RECV"); - break; - case EL737__BAD_RECV_NET: - strcpy(pBuffer,"EL737__BAD_RECV_NET"); - break; - case EL737__BAD_RECV_PIPE: - strcpy(pBuffer,"EL737__BAD_RECV_PIPE"); - break; - case EL737__BAD_RECV_UNKN: - strcpy(pBuffer,"EL737__BAD_RECV_UNKN"); - break; - case EL737__BAD_RECVLEN: - strcpy(pBuffer,"EL737__BAD_RECVLEN"); - break; - case EL737__BAD_RECV1: - strcpy(pBuffer,"EL737__BAD_RECV1"); - break; - case EL737__BAD_RECV1_NET: - strcpy(pBuffer,"EL737__BAD_RECV1_NET"); - break; - case EL737__BAD_RECV1_PIPE: - strcpy(pBuffer,"EL737__BAD_RECV1_PIPE"); - break; - case EL737__BAD_RNG: - strcpy(pBuffer,"EL737__BAD_RNG"); - break; - case EL737__BAD_SEND: - strcpy(pBuffer,"EL737__BAD_SEND"); - break; - case EL737__BAD_SEND_PIPE: - strcpy(pBuffer,"EL737__BAD_SEND_PIPE"); - break; - case EL737__BAD_SEND_NET: - strcpy(pBuffer,"EL737__BAD_SEND_NET"); - break; - case EL737__BAD_SEND_UNKN: - strcpy(pBuffer,"EL737__BAD_SEND_UNKN"); - break; - case EL737__BAD_SENDLEN: - strcpy(pBuffer,"EL737__BAD_SENDLEN"); - break; - case EL737__BAD_SOCKET: - strcpy(pBuffer,"EL737__BAD_SOCKET"); - break; - case EL737__BAD_TMO: - strcpy(pBuffer,"EL737__BAD_TMO"); - break; - case EL737__FORCED_CLOSED: - strcpy(pBuffer,"EL737__FORCED_CLOSED"); - break; - case EL737__BAD_ASYNSRV: - strcpy(pBuffer,"EL737__BAD_ASYNSRV"); - break; - default: - sprintf(pBuffer,"Unknown EL737 error %d", iErr); - break; - } - } - -/*--------------------------------------------------------------------------*/ - static int EL737GetError(struct __COUNTER *self, int *iCode, - char *error, int iErrLen) - { - char *pErr = NULL; - int iC1, iC2, iC3; - char pBueffel[256]; - - if(self->iErrorCode == UNKNOWNPAR) - { - strncpy(error,"unknown internal parameter code",iErrLen); - *iCode = self->iErrorCode; - self->iErrorCode = 0; - return 1; - } - else if(self->iErrorCode == BADCOUNTER) - { - strncpy(error,"monitor cannot be selected",iErrLen); - *iCode = self->iErrorCode; - self->iErrorCode = 0; - return 1; - } - - EL737_ErrInfo(&pErr,&iC1,&iC2, &iC3); - EL737Error2Text(pBueffel,iC1); - - strncpy(error,pBueffel,iErrLen); - *iCode = iC1; - return 1; - } -/*--------------------------------------------------------------------------*/ - static int EL737TryAndFixIt(struct __COUNTER *self, int iCode) - { - EL737st *pEL737; - int iRet; - char pCommand[50], pReply[50]; - - assert(self); - pEL737 = (EL737st *)self->pData; - assert(pEL737); - - switch(iCode) - { - case EL737__BAD_ILLG: - case EL737__BAD_ADR: - case EL737__BAD_PAR: - case EL737__BAD_TMO: - case EL737__BAD_REPLY: - case EL737__BAD_SNTX: - case EL737__BAD_OVFL: - return COREDO; - break; - case EL737__BAD_BSY: - strcpy(pCommand,"S \r"); - iRet = EL737_SendCmnd(&pEL737->pData,pCommand,pReply,49); - if(iRet < 0) - { - return COTERM; - } - else - { - return COREDO; - } - break; - case EL737__BAD_LOC: - strcpy(pCommand,"rmt 1\r"); - iRet = EL737_SendCmnd(&pEL737->pData,pCommand,pReply,49); - if(iRet < 0) - { - return COTERM; - } - strcpy(pCommand,"echo 2\r"); - iRet = EL737_SendCmnd(&pEL737->pData,pCommand,pReply,49); - if(iRet < 0) - { - return COTERM; - } - strcpy(pCommand,"ra\r"); - iRet = EL737_SendCmnd(&pEL737->pData,pCommand,pReply,49); - if(iRet < 0) - { - return COTERM; - } - return COREDO; - break; - case EL737__BAD_DEV: - case EL737__BAD_ID: - case EL737__BAD_NOT_BCD: - case UNKNOWNPAR: - case BADCOUNTER: - return COTERM; - break; - case EL737__FORCED_CLOSED: - iRet = EL737_Open(&pEL737->pData,pEL737->host, pEL737->iPort, - pEL737->iChannel); - if(iRet == 1) - { - return COREDO; - } - else - { - return COTERM; - } - break; - case EL737__BAD_OFL: - EL737_Close(&pEL737->pData,0); - iRet = EL737_Open(&pEL737->pData,pEL737->host, pEL737->iPort, - pEL737->iChannel); - if(iRet == 1) - { - return COREDO; - } - else - { - return COTERM; - } - break; -/* case EL737__BAD_ASYNSRV: - EL737_Close(&pEL737->pData,1); - return COREDO; -*/ default: - /* try to reopen connection */ - - EL737_Close(&pEL737->pData,1); - iRet = EL737_Open(&pEL737->pData,pEL737->host, pEL737->iPort, - pEL737->iChannel); - if(iRet == 1) - { - return COREDO; - } - else - { - return COTERM; - } - break; - } - return COTERM; - } -/*-------------------------------------------------------------------------*/ - static int EL737Set(struct __COUNTER *self, char *name, int iCter, - float fVal) - { - int iRet; - EL737st *pEL737; - char pCommand[80],pReply[80]; - - assert(self); - pEL737 = (EL737st *)self->pData; - assert(pEL737); - - if(strcmp(name,"threshold") == 0) - { - sprintf(pCommand,"DL %1.1d %f\r",iCter,fVal); - iRet = EL737_SendCmnd(&pEL737->pData,pCommand,pReply,79); - if(iRet == 1) - { - if(pCommand[0] == '?') - { - self->iErrorCode = BADCOUNTER; - return HWFault; - } - } - else - { - return HWFault; - } - sprintf(pCommand,"DR %1.1d \r",iCter); - iRet = EL737_SendCmnd(&pEL737->pData,pCommand,pReply,79); - if(iRet == 1) - { - if(pCommand[0] == '?') - { - self->iErrorCode = BADCOUNTER; - return HWFault; - } - return OKOK; - } - else - { - return HWFault; - } - } - else - { - self->iErrorCode = UNKNOWNPAR; - return HWFault; - } - } -/*-------------------------------------------------------------------------*/ - static int EL737Get(struct __COUNTER *self, char *name, int iCter, - float *fVal) - { - int iRet; - EL737st *pEL737; - char pCommand[80],pReply[80]; - - assert(self); - pEL737 = (EL737st *)self->pData; - assert(pEL737); - - if(strcmp(name,"threshold") == 0) - { - sprintf(pCommand,"DL %1.1d\r",iCter); - iRet = EL737_SendCmnd(&pEL737->pData,pCommand,pReply,79); - if(iRet == 1) - { - if(pReply[0] == '?') - { - self->iErrorCode = BADCOUNTER; - return HWFault; - } - sscanf(pReply,"%f",fVal); - return OKOK; - } - else - { - return HWFault; - } - } - else - { - self->iErrorCode = UNKNOWNPAR; - return HWFault; - } - } -/*-------------------------------------------------------------------------*/ - static int EL737Send(struct __COUNTER *self, char *pText, char *pReply, - int iReplyLen) - { - EL737st *pEL737; - char pBuffer[256]; - - assert(self); - pEL737 = (EL737st *)self->pData; - assert(pEL737); - - /* ensure a \r at the end of the text */ - if(strlen(pText) > 254) - { - strncpy(pReply,"Command to long",iReplyLen); - return 1; - } - strcpy(pBuffer,pText); - if(strchr(pBuffer,(int)'\r') == NULL) - { - strcat(pBuffer,"\r"); - } - - return EL737_SendCmnd(&pEL737->pData,pBuffer,pReply,iReplyLen); - } -/*--------------------------------------------------------------------------*/ - pCounterDriver NewEL737Counter(char *name, char *host, int iPort, int iChannel) - { - pCounterDriver pRes = NULL; - EL737st *pData = NULL; - int iRet; - int iC1, iC2, iC3; - char *pErr; - char pBueffel[132]; - - pRes = CreateCounterDriver(name, "EL737"); - if(!pRes) - { - return NULL; - } - - /* open connection to counter */ - pData = (EL737st *)malloc(sizeof(EL737st)); - if(!pData) - { - DeleteCounterDriver(pRes); - return NULL; - } - pData->host = strdup(host); - pData->iPort = iPort; - pData->iChannel = iChannel; - pData->pData = NULL; - iRet = EL737_Open(&(pData->pData), host,iPort,iChannel); - if(iRet != 1) - { - EL737_ErrInfo(&pErr,&iC1,&iC2, &iC3); - DeleteCounterDriver(pRes); - if(pData->host) - { - free(pData->host); - } - return NULL; - } - pRes->pData = (void *)pData; - - /* assign functions */ - pRes->GetStatus = EL737GetStatus; - pRes->Start = EL737Start; - pRes->Halt = EL737Halt; - pRes->ReadValues = EL737ReadValues; - pRes->GetError = EL737GetError; - pRes->TryAndFixIt = EL737TryAndFixIt; - pRes->Pause = EL737Pause; - pRes->Continue = EL737Continue; - pRes->Set = EL737Set; - pRes->Get = EL737Get; - pRes->Send = EL737Send; - pRes->iNoOfMonitors = 7; - pRes->fTime = 0.; - - return pRes; -} -/*--------------------------------------------------------------------------*/ - void KillEL737Counter(pCounterDriver self) - { - EL737st *pEL737 = NULL; - - assert(self); - pEL737 = (EL737st *)self->pData; - assert(pEL737); - - EL737_Close(&pEL737->pData,0); - if(pEL737->host) - { - free(pEL737->host); - } - DeleteCounterDriver(self); - } diff --git a/countdriv.h b/countdriv.h index 9b0a05e3..79986609 100644 --- a/countdriv.h +++ b/countdriv.h @@ -61,6 +61,7 @@ int iCter, float *fVal); int (*Send)(struct __COUNTER *self, char *pText, char *pReply, int iReplyLen); + void (*KillPrivate)(struct __COUNTER *self); void *pData; /* counter specific data goes here, ONLY for internal driver use! */ diff --git a/counter.c b/counter.c index 72e0e849..ff2dc4d1 100644 --- a/counter.c +++ b/counter.c @@ -50,7 +50,7 @@ #include "fupa.h" #include "status.h" #include "splitter.h" -#include "ecbcounter.h" +#include "site.h" /*-------------------------------------------------------------------------*/ /* The monitor callback data structure @@ -411,22 +411,7 @@ } if(self->pDriv) { - if(strcmp(self->pDriv->type,"EL737") == 0) - { - KillEL737Counter(self->pDriv); - } - else if (strcmp(self->pDriv->type,"SIM") == 0) - { - KillSIMCounter(self->pDriv); - } - else if(strcmp(self->pDriv->type,"ecb") == 0) - { - KillECBCounter(self->pDriv); - } - else - { - assert(0); - } + DeleteCounterDriver(self->pDriv); } free(self); } @@ -496,46 +481,35 @@ { pCounter pNew = NULL; pCounterDriver pDriv = NULL; + float fFail = -1; int iRet; char pBueffel[256]; - char **argx; - FuPaResult pParse; - FuncTemplate MakeTemplate[] = { - {"el737",3,{FUPATEXT,FUPAINT,FUPAINT}}, - {"sim",1,{FUPAFLOAT}}, - {"ecb",1,{FUPATEXT}} - }; + pSite site = NULL; assert(pCon); assert(pSics); - argtolower(argc,argv); - /* parse function template */ - argx = &argv[2]; /* 0 = MakeCounter, 1 = counter name */ - iRet = EvaluateFuPa((pFuncTemplate)&MakeTemplate,3,argc-2,argx,&pParse); - if(iRet < 0) /* I/O error */ - { - sprintf(pBueffel,"%s",pParse.pError); - SCWrite(pCon,pBueffel,eError); + argtolower(argc,argv); + if(argc < 3){ + SCWrite(pCon,"ERROR: insuficient number of arguments to MakeCounter", + eError); return 0; } - - /* create driver depending on parse result */ - switch(iRet) - { - case 0: /* EL737 driver */ - pDriv = NewEL737Counter(argv[1],pParse.Arg[0].text, - pParse.Arg[1].iVal,pParse.Arg[2].iVal); - break; - case 1: /* SIM */ - pDriv = NewSIMCounter(argv[1],pParse.Arg[0].fVal); - break; - case 2: /* ecb */ - pDriv = MakeECBCounter(pParse.Arg[0].text); - break; - default: - assert(0); /* internal error */ + site = getSite(); + if(site != NULL){ + pDriv = site->CreateCounterDriver(pCon,argc,argv); } + + /* + test for simulation driver, which is for everybody + */ + if(strcmp(argv[2],"sim") == 0){ + if(argc > 3){ + fFail = atof(argv[3]); + pDriv = NewSIMCounter(argv[1],fFail); + } + } + if(!pDriv) { sprintf(pBueffel,"ERROR: cannot create requested driver %s", diff --git a/danu.dat b/danu.dat index a8179996..d53f5012 100644 --- a/danu.dat +++ b/danu.dat @@ -1,3 +1,3 @@ - 286 + 288 NEVER, EVER modify or delete this file You'll risk eternal damnation and a reincarnation as a cockroach!|n \ No newline at end of file diff --git a/difrac/CAD4COMM b/difrac/CAD4COMM deleted file mode 100644 index c262117f..00000000 --- a/difrac/CAD4COMM +++ /dev/null @@ -1,728 +0,0 @@ -*$noreference -! -! This is the common block for CAD4 -! VAX/VMS to PDP11/02 transfer program. -! -! modified: 03-jan-1985 LCB adaption for SBC-21 target processor -! -! Logical assignments used in CAD4 system -! -! CAn_term device name of communication channel with lsi-11 -! LB0 default device for [1,3n]GONCAn.DAT;1 data files -! cad4$nrcsys default directory specification for .EXE -! cad4$error default task error device -! -! Assumed process name CAD4?_CAn -! -! -! Filename of GONCAn.DAT file -! - character*22 def_gon_spec - parameter (def_gon_spec='LB0:[1,40]GONCAn.DAT;1') - character*18 gon_file_spec -! -! Filename of monitor task image -! - character*21 def_mon_spec - parameter (def_mon_spec='CAD4M.TSK') - character*22 mon_file_spec -! -! Default mother task image name -! - character*18 def_mother_spec - parameter (def_mother_spec='nrccad') -! -! Input filenames -! - character*63 mother_file_spec - character*63 daughter_file_spec -! -! Test send message definitions -! - character*120 message_text - integer*1 message_buffer - integer*4 message_descr - dimension message_buffer(128),message_descr(2) - equivalence (message_buffer(9),message_text) -! - parameter (l_unit=6 ) ! Logical unit number for log file - logical*1 l_unit_open ! True if file open -! -! Define QIO function codes and modifiers -! - external tt$v_eightbit,tt$v_noecho,tt$v_passall - external tt$v_nobrdcst,tt$v_escape,tt$v_hostsync - external tt$v_ttsync,tt$v_readsync,tt$v_halfdup - external io$_setmode,io$_ttyreadpall,io$_writelblk - external io$_ttyreadall,io$m_timed,io$m_noecho - external io$m_noformat,io$m_purge -! -! Define QIO status codes -! - integer*4 ss$_normal,ss$_badchksum,ss$_bufferovf - integer*4 ss$_abort,ss$_timeout,ss$_nodata -! - parameter (ss$_normal = #1) ! Normal return - parameter (ss$_timeout = #22c) ! Timeout -! -! Internal status codes returned in one byte -! - integer*2 result,e_suc,e_tos,e_tol,e_seq - integer*2 e_crc,e_typ,e_ovf,e_pnd -! - parameter (e_suc = #0) ! success - parameter (e_tos = #4) ! tmo + data - parameter (e_tol = #8) ! tmo , no data - parameter (e_seq = #c) ! Unexpected sequence number - parameter (e_crc = #10) ! CRC error - parameter (e_typ = #14) ! Unexpected function code - parameter (e_ovf = #18) ! Buffer overflow - parameter (e_pnd = #1c) ! Any system service fail. -! - integer*2 m_seq,m_efl,m_fun -! - parameter (m_seq = #3) ! Mask to get seq. bits - parameter (m_efl = #1c) ! Mask to get error flag - parameter (m_fun = #e0) ! Mask to get function bits -! -! Function codes for CAD4_IO routine -! - integer*2 io_func,f_init,f_xfr_asc,f_xfr_mem,f_tr_swr - integer*2 f_tr_gon,f_tr_asc,f_req_mem,f_req_asc -! - parameter (f_init = #0) ! Bootstrap 11/02 - parameter (f_xfr_asc = #20) ! Xfr ASCII buffer to 11/02 - parameter (f_xfr_mem = #40) ! Xfr code block to 11/02 - parameter (f_tr_swr = #60) ! Trm. and rec. SWR - parameter (f_tr_gon = #ff80) ! Trm. and rec. goniometer data - parameter (f_tr_asc = #ffa0) ! Trm. and rec. ASCII buffer - parameter (f_req_mem = #ffc0) ! Request code block from 11/02 - parameter (f_req_asc = #ffe0) ! Request ASCII buffer from 11/02 -! -! Data used by CAD4_IO routine -! - integer*2 io_coswr ! Switch options register from vax to 11/02 - integer*2 io_cobnr ! No. of calls to 11/02 - integer*1 io_cohex ! Header from VAX to 11/02 - ! bit 0-1 : seq. no. of the calls to 11/02 - ! bit 2-4 : result code - ! bit 5-7 : function -! -! Flags to define command string options -! 0 - no option -! -1 - negated option -! +1 - positive option -! - integer*1 mt_flag,ex_flag -! -! Flag for cad4_prompt routine -! 0 - no error message -! 1 - command input error -! -1 - daughter file cannot be opened -! -2 - " " " " read -! - integer*1 io_prompt_flag -! -! Define baud rate constants for CAD4 terminal -! - integer*2 baud_38400,baud_19200,baud_9600,baud_4800 - integer*2 baud_2400,baud_1200,baud_600,baud_300 -! - parameter (baud_38400 = 3) - parameter (baud_19200 = 2*baud_38400) - parameter (baud_9600 = 2*baud_19200) - parameter (baud_4800 = 2*baud_9600) - parameter (baud_2400 = 2*baud_4800) - parameter (baud_1200 = 2*baud_2400) - parameter (baud_600 = 2*baud_1200) - parameter (baud_300 = 2*baud_600) -! -! Default goniometer parameter (goncan.dat record 8) -! system constants as will be expected at bottom of LSI target computer -! - integer*2 lsi_bottom ! LSI memory size (bytes) - parameter (lsi_bottom=#8000) - integer*2 sbc_bottom ! SBC user memory bottom - parameter (sbc_bottom=#ec00) - integer*2 lsypar ! value of LSI syspar address - integer*2 sbcp_bottom ! SBC PLUS memory bottom - parameter (sbcp_bottom=#7F80) -! - integer*2 syspar_def_1,syspar_def_2,syspar_def_3 - integer*2 syspar_def_4,syspar_def_5,syspar_def_6 - integer*2 syspar_def_7,syspar_def_8,syspar_def_9 - integer*2 syspar_def_10,syspar_def_11,syspar_def_12 - integer*2 syspar_def_13,syspar_def_14,syspar_def_15 - integer*2 syspar_def_16,syspar_def_17 -! - parameter (syspar_def_1 = #ff-((640-255)/3) ) - ! Photomultiplier hv setting of 640 volts - parameter (syspar_def_2 = #ff-(120/5) ) - ! Lower level setting of 120 - parameter (syspar_def_3 = #ff-(750/5) ) - ! Discrimination window setting - parameter (syspar_def_4 = 0) - parameter (syspar_def_5 = 0) - ! Deadtime correction factor (default 0, I*4) - parameter (syspar_def_6 = baud_300.and.#ff) - ! CAD4 terminal baudrate setting of ... - parameter (syspar_def_7 = baud_300/#100) - ! 300 baud default - parameter (syspar_def_8 = 0) - parameter (syspar_def_9 = 18) - ! System clock speed default = 400 cycles/sec. - parameter (syspar_def_10 = 2) - ! Default positioning accuracy is 2 steps -! -! -! common for load syspar data -! - integer*2 slave_load_address !address to load syspar in lsi - integer*2 nr_load_byte !number of bytes to load -! - character*1 bvers_c - integer*1 bvers !bootstrap version character if not 0 - equivalence (bvers,bvers_c(1:1)) -! -! -! 5 Axes gain list -! -! output = calculated value*(32.-gain)/32. -! - parameter (syspar_def_11 = 24) ! Theta motorgain - parameter (syspar_def_12 = 28) ! Phi motorgain - parameter (syspar_def_13 = 24) ! Omega motorgain - parameter (syspar_def_14 = 24) ! Kappa motorgain - parameter (syspar_def_15 = 24) ! Dial motorgain -! -! System flag word -! -! 1 - High voltage sense -! 4 - Switch limit for phi: present = set -! 10 - Special collar: present = set -! 20 - Cryostat: present = set -! - parameter (syspar_def_16 = 0) ! System flag word -! - parameter (syspar_def_17 = (60-10)*3/10 ) - ! Maximum emission allowed of 60 mA -! - integer*2 syspar_def - dimension syspar_def(32) -! -! Define syspar values as read from goncan.dat file -! - integer*2 syspar_val - dimension syspar_val(32) -! -! Define code for $getdvi system service -! - integer*4 dvi$_devdepend,dvi$_devdepend2 - integer*4 dvi$_devclass,dvi$_devtype - parameter (dvi$_devclass = #00000004) - parameter (dvi$_devdepend = #0000000A) - parameter (dvi$_devdepend2= #0000001C) - parameter (dvi$_devtype = #00000006) -! -! Define system services as integer*4 to allow function call -! - integer*4 io_status ! I/O status code - integer*4 exmess_status !i/o status code memory for exit - integer*4 cli$present,cli$get_value,sys$exit,sys$alloc - integer*4 sys$assign,sys$qiow,sys$getdvi,sys$dclexh,sys$sndopr - integer*4 sys$setprn,sys$getjpi,sys$creprc,sys$getmsg -! -! Cad4 buffer format -! -! 15 0 -! +-----------------------+ -! + header byte + -! +------------------------------------------------+ -! + length(high byte) + length (low byte) + -! +------------------------------------------------+ -! ! switch register word or load address + -! +------------------------------------------------+ -! ! switch register word or load address + -! +------------------------------------------------+ -! ! ! -! ! ... ! -! -! ! 256 words data (512. bytes) ! -! +------------------------------------------------+ -! + CRC (16. bit) + -! +------------------------------------------------+ -! -! -! Define argumensts for cad4_readprompt routine -! - integer*1 prompt_buffer ! Buffer to save prompt - dimension prompt_buffer(521) ! send to pdp11/02 - integer*1 output_buffer ! Same as Output buffer - dimension output_buffer(521) ! for cad4_writelogical - equivalence (prompt_buffer(1),output_buffer(1)) - character*521 output_buffer_c ! Allow use of ICHAR function - equivalence (prompt_buffer(1),output_buffer_c) -! - integer*4 prompt_size ! Size of prompt (for QIO) - integer*4 output_size ! " - equivalence (prompt_size,output_size) -! - integer*1 input_buffer ! Input buffer to read record - dimension input_buffer(521) - integer*4 input_size ! Size of input buff for Qio - character*521 input_buffer_c ! Allow use of ICHAR function - equivalence (input_buffer(1),input_buffer_c) -! -! Buffer for input and output are the same -! - equivalence (input_buffer(1),output_buffer(1)) -! -! Define structure of I/O blocks -! - integer*1 prompt_header ! Header byte of output block - integer*1 output_header ! " - equivalence (prompt_buffer(1),prompt_header) - equivalence (prompt_buffer(1),output_header) -! - integer*2 prompt_length ! Length send to pdp11/02 - integer*2 output_length ! " - equivalence (prompt_buffer(2),prompt_length) - equivalence (prompt_buffer(2),output_length) -! - integer*1 prompt_data ! Data bytes send to pdp11/02! - integer*1 output_data ! " - integer*2 output_data_w ! - character*518 output_data_c ! - dimension prompt_data(512+2+2+2) - dimension output_data(512+2+2+2) - dimension output_data_w((512+2+2+2)/2) - equivalence (prompt_buffer(4),output_data_c) - equivalence (prompt_buffer(4),prompt_data(1)) - equivalence (prompt_buffer(4),output_data(1)) - equivalence (prompt_buffer(4),output_data_w(1)) -! - integer*1 input_header ! Header byte received from 11 - equivalence (input_buffer(1),input_header) -! - integer*2 input_length ! Length received from pdp11/02 - equivalence (input_buffer(2),input_length) -! - integer*1 input_data ! Data read from pdp11/02 - integer*2 input_data_w ! - dimension input_data(512+2+2+2) - dimension input_data_w((512+2+2+2)/2) - equivalence (input_buffer(4),input_data(1)) - character*518 input_data_c ! - equivalence (input_buffer(4),input_data_c) - equivalence (input_buffer(4),input_data_w) -! -! Define word to compute CRC -! - integer*4 iconst !crc-constant - parameter (iconst=#a001) ! value of constant - integer*4 crchar !crc-character - integer*4 isum !to remember received crc - integer*4 isum_w ! 16 bit CRC - integer*1 isum_b ! 8 bit (low&high 16 bit CRC) - dimension isum_b(2) - equivalence (isum_w,isum_b) -! -! Define item list for $getdvi system service -! - integer*4 item_list_i4 ! Item list for $getdvi - integer*2 item_list_i2 ! information - integer*1 item_list_i1 - dimension item_list_i4(13) ! 4* 3 + 1 longword - dimension item_list_i2(13*2) - dimension item_list_i1(13*4) - equivalence (item_list_i4,item_list_i2) - equivalence (item_list_i4,item_list_i1) -! -! Define item list for $getjpi system service -! - integer*4 getjpi_list_l - integer*2 getjpi_list_w - dimension getjpi_list_l(13) - dimension getjpi_list_w(2*13) - equivalence (getjpi_list_l,getjpi_list_w) -! -! Define info var from $getjpi -! - character*15 process_name_c - integer*1 process_name_b - dimension process_name_b(15) - equivalence (process_name_c(1:1),process_name_b(1)) - integer*2 process_name_len -! - integer*4 process_uic_l - integer*2 process_uic_w - dimension process_uic_w(2) - equivalence (process_uic_l,process_uic_w) - integer*2 process_uic_len -! - character*63 process_image_c - integer*1 process_image_b - dimension process_image_b(63) - equivalence (process_image_c(1:1),process_image_b(1)) - integer*2 process_image_len -! - integer*4 process_prio_l - integer*2 process_prio_len -! -! Define buffer for io$_setmode QIO -! - integer*4 char_buff_i4 ! Item list for $getdvi - integer*2 char_buff_i2 ! information - integer*1 char_buff_i1 - dimension char_buff_i4(3) ! Three longwords - dimension char_buff_i2(3*2) - dimension char_buff_i1(3*4) - equivalence (char_buff_i4,char_buff_i2) - equivalence (char_buff_i4,char_buff_i1) -! -! Define characteristics returned by $getdvi and used for -! $qiow (io$_setmode). -! - integer*4 cad4_devclass ! Device class - integer*4 cad4_devtype ! Device type - integer*4 cad4_devdepend ! Device characteristics - integer*4 cad4_devdepend2 ! - integer*2 cad4_pagewidth ! Width of a page - integer*1 cad4_pagelength ! Length of a page - equivalence (char_buff_i1(1),cad4_devclass) - equivalence (char_buff_i1(2),cad4_devtype) - equivalence (char_buff_i2(2),cad4_pagewidth) - equivalence (char_buff_i4(2),cad4_devdepend) - equivalence (char_buff_i4(3),cad4_devdepend2) - equivalence (char_buff_i1(8),cad4_pagelength) -! - integer*4 cad4_devdepend_old ! Save old characteristics here -! -! -! Define arguments for QIOW system service to cad4 -! - integer*4 qio_status ! Qio status code - integer*2 cad4_chan ! Channel number - integer*4 cad4_event_flag ! Event flag number - parameter (cad4_event_flag=8) ! - integer*4 cad4_iosb ! I/O status - integer*2 cad4_iosb_i2 ! words - dimension cad4_iosb(2) ! quadword - dimension cad4_iosb_i2(4) - equivalence (cad4_iosb,cad4_iosb_i2) - integer*4 cad4_l_timo ! Long time out count - parameter (cad4_l_timo=25) ! 25 seconds - integer*4 cad4_timeout ! Short timeout count - parameter (cad4_timeout=2) ! Two seconds - integer*4 cad4_terminator ! Line terminator bit mask - dimension cad4_terminator(2) ! quadword (short form) -! -! Define argument block for declare exit handler directive -! - integer*4 exit_block ! Exit handler control block - dimension exit_block(4) - integer*4 exit_status -! -! Define parameters for $assign system service -! - character*10 cad4_term_name ! Physical name of transfer - ! terminal - integer*4 cad4_term_len ! Length of physical - ! name string -! -! Variable to save instrument name -! -! ibycan_b 1. byte : integer CA?: unit number -! 2.-4. byte : ASCII device name ('CAn') -! - integer*1 ibycan_b - dimension ibycan_b(4) - integer*2 ibycan - dimension ibycan(2) - character*4 ibycan_c - equivalence (ibycan_b(1),ibycan_c(1:1)) - equivalence (ibycan_b(1),ibycan(1)) - integer*2 ir5can !radix-50 name of channel for RSX -! -! Variable to save current process name name and uic -! -! Common block for all I/O routines -! - integer*4 img_io_record ! Record no. of task image - integer*4 img_io_status ! FORTRAN I/O status code -! -! Define file I/O buffer -! - integer*4 img_io_buffer_l - integer*2 img_io_buffer_w - integer*1 img_io_buffer_b - dimension img_io_buffer_l(128),img_io_buffer_w(256) - equivalence (img_io_buffer_l,img_io_buffer_w) - equivalence (img_io_buffer_l,img_io_buffer_b) -! -! Define read bookkeeping -! - integer*2 img_io_bsa ! Base address (bytes) - integer*2 img_io_ldz ! Load size (32. word blocks) - integer*2 img_io_xfr ! Transfer address - integer*4 img_io_pointer ! Pointer -! -! -! common declaration for blank common block - integer*2 nswreg !slave switch register - integer*2 iroutf !routine flag - integer*2 incr1 !master increment - integer*2 incr2 !slave increment - integer*2 npi1 !inverse of scanspeed for master - integer*2 npi2 !relative scanspeed for slave - integer*2 iscanw !scanwidth tensor - integer*2 motw !motor selection word - integer*2 ishutf !shutter flag - integer*2 ibalf !balance filter flag - integer*2 iattf !attenuator filter flag - integer*2 iresf !reserve flag - integer*2 ierrf !result error flag - integer*2 intfl !intensity result flag - real*4 xrayt !x-ray time - real*4 tthp !limit value for detector - real*4 tthn !limit value for neg side - real*4 aptw !wanted encoder value for aperture - real*4 want !wanted values for gonio-angles - real*4 spare !spare locs - real*4 aptm !measured encoder value of aperture - real*4 cmeas !measured gonio angles - real*4 dump !intensity dumps -! -! cad4-handler offsets -! - integer*2 c4h_swreg - integer*2 c4h_routfl - integer*2 c4h_errfl - integer*2 c4h_intfl - integer*2 c4h_tthmxh - integer*2 c4h_tthmnh - integer*2 c4h_sasysc - integer*2 c4h_xrtim - integer*2 c4h_mselw - integer*2 c4h_nrd - integer*2 c4h_nid - integer*2 c4h_incr - integer*2 c4h_inci - integer*2 c4h_dincr - integer*2 c4h_nrinc - integer*2 c4h_thwh - integer*2 c4h_phwh - integer*2 c4h_omwh - integer*2 c4h_kawh - integer*2 c4h_apwh - integer*2 c4h_apwl - integer*2 c4h_thmh - integer*2 c4h_phmh - integer*2 c4h_ommh - integer*2 c4h_kamh - integer*2 c4h_apmh - integer*2 c4h_dump0 -! - parameter (c4h_swreg =1) - parameter (c4h_routfl =2) - parameter (c4h_errfl =3) - parameter (c4h_intfl =4) - parameter (c4h_tthmxh =5) - parameter (c4h_tthmnh =7) - parameter (c4h_sasysc =9) - parameter (c4h_xrtim =10) - parameter (c4h_mselw =12) - parameter (c4h_nrd =13) - parameter (c4h_nid =14) - parameter (c4h_incr =12) - parameter (c4h_inci =0) - parameter (c4h_dincr =1) - parameter (c4h_nrinc =2) - parameter (c4h_thwh =30) - parameter (c4h_phwh =32) - parameter (c4h_omwh =34) - parameter (c4h_kawh =36) - parameter (c4h_apwh =38) - parameter (c4h_apwl =39) - parameter (c4h_thmh =40) - parameter (c4h_phmh =42) - parameter (c4h_ommh =44) - parameter (c4h_kamh =46) - parameter (c4h_apmh =48) - parameter (c4h_dump0 =50) -! -! c4h_routfl function table -! - integer*2 rf_swi - integer*2 rf_mea - integer*2 rf_col - integer*2 rf_poc - integer*2 rf_pos - integer*2 rf_pof - integer*2 rf_sap - integer*2 rf_sca - integer*2 rf_scd - integer*2 rf_res - integer*2 routbl(16) -! - parameter (rf_swi =#0) - parameter (rf_mea =#4) - parameter (rf_col =#8) - parameter (rf_poc =#10) - parameter (rf_pos =#20) - parameter (rf_pof =#40) - parameter (rf_sap =#80) - parameter (rf_sca =#100) - parameter (rf_scd =#200) - parameter (rf_res =#8000) -! - integer*2 rout0,rout1,rout2,rout3,rout4,rout5 - integer*2 rout6,rout7,rout8,rout9,rout10,rout11 - integer*2 rout12,rout13,rout14,rout15 -! - parameter (rout0 = rf_swi+rf_res) - parameter (rout1 = rf_swi+rf_mea+rf_res) - parameter (rout2 = rf_swi+rf_col+rf_res) - parameter (rout3 = rf_swi+rf_pos+rf_res) - parameter (rout4 = rf_swi+rf_pof+rf_res) - parameter (rout5 = rf_swi+rf_poc+rf_pof+rf_res) - parameter (rout6 = rf_swi+rf_sca+rf_res) - parameter (rout7 = rf_swi+rf_sap+rf_sca+rf_res) - parameter (rout8 = rf_swi+rf_poc+rf_pof+rf_sap+rf_sca+rf_res) - parameter (rout9 = rf_swi+rf_scd+rf_res) - parameter (rout10= rf_swi+rf_sap+rf_scd+rf_res) - parameter (rout11= rf_swi+rf_poc+rf_pof+rf_sap+rf_scd+rf_res) - parameter (rout12= rf_swi+rf_poc+rf_res) - parameter (rout13= rf_swi+rf_sap+rf_res) - parameter (rout14= rf_swi+rf_res) !free - parameter (rout15= rf_swi+rf_res) !free -! -! cad4_handler error table -! - integer*2 errtbl(15) -! -! cad4_handler intensity error table -! - integer*2 inttbl(15) -! -! -! cad4-handler sasysc table -! - integer*2 sa_att - integer*2 sa_shu -! - parameter (sa_att = #4000) - parameter (sa_shu = #8000) -! - integer*2 satbl(4),sas0,sas1,sas2,sas3 -! - parameter (sas0 = #0) - parameter (sas1 = sa_att) - parameter (sas2 = sa_shu) - parameter (sas3 = sa_att+sa_shu) -! -! fortran blank common array for angles -! - integer*2 for_ph - integer*2 for_om - integer*2 for_ka - integer*2 for_th -! - parameter (for_ph = 1) - parameter (for_om = 2) - parameter (for_ka = 3) - parameter (for_th = 4) -! -! number of dumps used -! - integer ndumps -! - common /cad4_main/nswreg ,iroutf ,incr1 ,incr2 ,npi1 , - 1 npi2 ,iscanw ,motw ,ishutf ,ibalf ,iattf , - 2 iresf ,ierrf ,intfl ,xrayt ,tthp ,tthn , - 3 aptw ,want(4) ,spare(6) ,aptm , - 4 cmeas(4),ndumps, dump(512) -! -! -! Common for cad4 ascii buffer in cad4b -! - integer*2 nr_ascii_byte !number of ascii in BUFA - character*1 bufa !ascii buffer - dimension bufa(134) -! -! - common /mesg/bufa !ascii buffer for cad4b -! -! -! Common blocks for integer and logical variables -! - common /cad4_integer/ io_status,cad4_term_len, - 1 item_list_i4,char_buff_i4,cad4_devdepend_old, - 2 exit_block,cad4_chan,cad4_iosb,qio_status, - 3 cad4_terminator,isum_w,l_unit_open, - 4 message_buffer,message_descr, - 5 img_io_buffer_l,img_io_bsa,img_io_ldz,img_io_xfr, - 6 img_io_record,img_io_pointer,img_io_status, - 7 getjpi_list_l,process_name_b,process_uic_l, - 8 process_image_b,process_name_len,process_uic_len, - 9 process_image_len,process_prio_l,process_prio_len, - 1 mt_flag,ex_flag,io_prompt_flag,syspar_def, - 2 slave_load_address,nr_load_byte,nr_ascii_byte, - 3 bvers -! -! -! Common block for transfer buffer -! - common /tbuf/output_size,output_buffer,input_size - -! -! -! Common block for communication channel name and communication values -! - common /cacomm/ibycan,ir5can,lsypar,io_coswr,io_cobnr, - 1 io_cohex -! -! -! Common block for syspar values (shadow of 11/02 lsi_bottom) -! - common /syspar/syspar_val -! -! -! Common block for character variables -! - common /cad4_character/ cad4_term_name, - 1 mother_file_spec,daughter_file_spec, - 2 gon_file_spec -! - common /cad4_sysval/ freq, ragmxt -! -! cad4-handler motor table -! - integer*2 mottbl(8) !no,ap,ph,om,ka,th,no,no -! !converted to - data mottbl /0,5,2,3,4,1,0,0/ !no,th,ph,om,ka,ap,no,no -! - data syspar_def /syspar_def_1,syspar_def_2,syspar_def_3, - 1 syspar_def_4,syspar_def_5,syspar_def_6, - 2 syspar_def_7,syspar_def_8,syspar_def_9, - 3 syspar_def_10,syspar_def_11,syspar_def_12, - 4 syspar_def_13,syspar_def_14,syspar_def_15, - 5 syspar_def_16,syspar_def_17,15*0/ -! - data routbl /rout0,rout1,rout2,rout3, - 1 rout4,rout5,rout6,rout7,rout8, - 2 rout9,rout10,rout11,rout12,rout13, - 3 rout14,rout15/ -! - data errtbl /1,2,3,4,5,5,5,0,0,0,0,0,0,0,0/ -! - data inttbl /-1,1,0,0,0,0,0,0,0,0,0,0,0,0,0/ -! - data satbl/sas0,sas1,sas2,sas3/ -! - data ndumps /512/ -! -! -! -*$reference - diff --git a/difrac/COMDIF b/difrac/COMDIF deleted file mode 100644 index 038e02a6..00000000 --- a/difrac/COMDIF +++ /dev/null @@ -1,54 +0,0 @@ - PARAMETER (NSIZE=200) - COMMON /DFMACH/ ISCDEF,ICDDEF,IDTDEF,IDODEF,IDCDEF,IFRDEF,NRC, - $ NATTEN,STEPDG,ICADSL,ICADSW - CHARACTER DFTYPE*5,DFMODL*5 - COMMON /DFMACC/ DFTYPE,DFMODL - COMMON /ANGLE/ THETA,PHI,CHI,OMEGA,RTHETA,ROMEGA,RPHI,RCHI, - $ DTHETA,DOMEGA,DCHI,THEMAX,THEMIN,PSI,DPSI,PSIMAX, - $ PSIMIN,R(3,3),ROLD(3,3),IVALID,WAVE,IROT,DEG,DPHI - COMMON /REFLEC/ IH,IK,IL,IH0,IK0,IL0,IHMAX,IKMAX,ILMAX,NREF, - $ IOH(NSIZE),IOK(NSIZE),IOL(NSIZE),ITRUE - COMMON /SYMTRY/ NSYM,ICENT,LATCEN,LAUENO,NAXIS, - $ SGSYMB(10),JHKL(3,24),JRT(3,4,24) - COMMON /INTENS/ IHK(10),ILA(10),BCOUNT(10),BBGR1(10),BBGR2(10), - $ BTIME(10),BPSI(10),NREFB(10),PRESET,COUNT,BGRD1, - $ BGRD2,NATT,AS,BS,CS,PA,PM,QTIME,TMAX,AFRAC, - $ ATTEN(6) - COMMON /PROFL/ ACOUNT(10*NSIZE),D12,ILOW,IHIGH,IDEL,IWARN,SUM, - $ FRAC1,IPRFLG,IAUTO,STEPOF,FRAC,PJUNK(9),NPK - COMMON /CUTOFF/ ISYS,SINABS(6),ILN,DELAY,STEP,IUPDWN,ISTOP, - $ CJUNK(8) - COMMON /CELL/ SR(3,3),SSG(3,3),GI(3,3),AP(3),APS(3),SANGS(3), - $ CANGS(3),SANG(3),CANG(3) - COMMON /SEGS/ IFSHKL(3,3),NDH(3,3),IHO(8),IKO(8),ILO(8), - $ IDH(8,3,3),ISEG,NCOND,ICOND(5),IHS(5),IKS(5), - $ ILS(5),IR(5),IS(5),NSEG,NMSEG,IND(3),NUMDH,NSET - COMMON /IODEVS/ ITP,ITR,LPT,LPTX,NB,NBLOCK,ISD,IID, - $ IBYLEN,IPR,NPR,IIP - COMMON /IOUASS/ IOUNIT(10) - CHARACTER*132 COUT(20) - COMMON /IOUASC/ COUT - COMMON /STAN/ NSTAN,NMSTAN,ISTAN,NN,IHSTAN(6),IKSTAN(6), - $ ILSTAN(6),NINTRR,NINTOR,IORNT,REOTOL,NREFOR - COMMON /FLAGS/ ITYPE,KQFLAG,KQFLG2,IBSECT,ISCAN,IPRVAL,IUMPTY - COMMON /TRANS/ BLINDR(3,3),TMATS(3,3,20),IFSYS(20),IFMODE(20), - $ NTMATS - COMMON /JUNKS/ JA(8),JB(8),JC(8),JMIN(8),JMAX(8) - COMMON /INFREE/ IFREE(20),RFREE(20),ICFLAG - CHARACTER OCHAR*100,KI*2,ANS*1 - COMMON /FREECH/ OCHAR - COMMON /POINTR/ KI,ANS - CHARACTER IDNAME*40,DSNAME*40,DDNAME*40,STATUS*2,PRNAME*40 - COMMON /FNAMES/ IDNAME,DSNAME,DDNAME,STATUS,PRNAME - COMMON /REGIST/ ISREG(10) - COMMON /SCRTCH/ SIGMA(7),SIGSQ(7),LAUE,NUMD,IAXIS - CHARACTER WIN1BF*80 - COMMON /CWIND1/ WIN1BF(3) - COMMON /FWIND1/ IWNCUR - DIMENSION PROF(520),CUT(20) - EQUIVALENCE (ACOUNT(1),PROF(1)),(CUT(1),ISYS) - INTEGER XOPEN,XCLOSE,XMOVE,XDRAW,XCLEAR,XTEXT,XSCROL,XWIN, - $ XTDEL - PARAMETER (XOPEN = 1, XCLOSE = 2, XMOVE = 3, XDRAW = 4, - $ XCLEAR = 5, XTEXT = 6, XSCROL = 7, XWIN = 8, - $ XTDEL = 9) diff --git a/difrac/IATSIZ b/difrac/IATSIZ deleted file mode 100644 index 621c222c..00000000 --- a/difrac/IATSIZ +++ /dev/null @@ -1,5 +0,0 @@ -C----------------------------------------------------------------------- -C Parameters for LSTSQ, FOURR & COFOUR, DATRD2, TABLES and SOLVER -C----------------------------------------------------------------------- - CHARACTER MNCODE*6 - PARAMETER (MNCODE = 'PCMSDS') diff --git a/difrac/Makefile b/difrac/Makefile deleted file mode 100644 index 54cb1bed..00000000 --- a/difrac/Makefile +++ /dev/null @@ -1,53 +0,0 @@ -#--------------------------------------------------------------------------- -# Makefile for the DIFRAC library for SICS. -# -# Mark Koennecke, November 1999 -#---------------------------------------------------------------------------- - -#---------- for Redhat linux -CC= gcc -CFLAGS= -C -g -c - -#------------ for DigitalUnix -##CC=cc -##CFLAGS= -C -g -c -#---------------------------------------------------------------------------- - - -FL = f77 $(CFLAGS) -ROOT = .. -LIBS = $(ROOT)\libs - -OBJECTS=difini.o \ - ang180.o angval.o begin.o \ - cent8.o cfind.o demo1e.o align.o \ - centre.o mod360.o profil.o range.o sinmat.o cellls.o \ - wxw2t.o angcal.o basinp.o comptn.o orcel2.o inchkl.o \ - linprf.o lsormt.o mesint.o goloop.o ormat3.o blind.o \ - params.o pltprf.o pcount.o prtang.o prnbas.o prnint.o \ - grid.o sammes.o cellsd.o stdmes.o cntref.o indmes.o \ - wrbas.o reindx.o rcpcor.o lotem.o nexseg.o lister.o \ - oscil.o pfind.o pscan.o peaksr.o sgprnh.o \ - difint.o tcentr.o tfind.o fndsys.o \ - dhgen.o setrow.o creduc.o cinput.o \ - burger.o angrw.o bigchi.o \ - eulkap.o trics.o swrite.o - -GENS = yesno.o freefm.o alfnum.o matrix.o \ - sgroup.o latmod.o sgrmat.o \ - sglatc.o sglpak.o sgerrs.o sgmtml.o \ - sgtrcf.o \ - setiou.o ibmfil.o - -all: lib - -clean: - rm -f *.o - -lib: $(OBJECTS) $(GENS) - - rm -f libdif.a - ar cr libdif.a $(OBJECTS) $(GENS) - ranlib libdif.a - -.f.o: - $(FL) $*.f diff --git a/difrac/alfnum.f b/difrac/alfnum.f deleted file mode 100644 index 79b53c0d..00000000 --- a/difrac/alfnum.f +++ /dev/null @@ -1,50 +0,0 @@ -C----------------------------------------------------------------------- -C Get an alphanumeric input string. -C In general all alphabetic characters are converted to upper-case, -C but if STRING contains "DONT DO IT" on input no conversion is done. -C This is useful to allow the input of file names in case sensitive -C operating systems like UNIX. -C All null characters are converted to blanks -C The code should be general for ASCII and EBCDIC. -C If the first character is a question mark (?) the routine exits to -C the system monitor. -C----------------------------------------------------------------------- - SUBROUTINE ALFNUM (STRING) - COMMON /IOUASS/ IOUNIT(12) - CHARACTER STRING*(*),NULL*1 - NULL = CHAR(0) - ITR = IOUNIT(5) - ITP = IOUNIT(6) - IDONT = 0 - IF (LEN(STRING) .GE. 10 .AND. STRING(1:10) .EQ. 'DONT DO IT') - $ IDONT = 1 -C----------------------------------------------------------------------- -C Write the prompt - if any - and get the answer -C----------------------------------------------------------------------- - CALL GWRITE (ITP,'$') - STRING = ' ' - ILEN = LEN(STRING) - IF (ILEN .GT. 80) ILEN = 80 - CALL GETLIN (STRING) - IF (STRING(1:1) .EQ. '?') STOP - ILEN = LEN(STRING) - DO 120 I = 1,ILEN - IF (STRING(I:I) .EQ. NULL) STRING(I:I) = ' ' - 120 CONTINUE - IF (IDONT .EQ. 0) THEN - LITTLA = ICHAR('a') - LARGEA = ICHAR('A') - LITTLZ = ICHAR('z') - IDIFF = LITTLA - LARGEA - ILEN = LEN(STRING) - DO 130 I = 1,ILEN - ITHIS = ICHAR(STRING(I:I)) - IF (ITHIS .GE. LITTLA .AND. ITHIS .LE. LITTLZ) THEN - ITHIS = ITHIS - IDIFF - STRING(I:I) = CHAR(ITHIS) - ENDIF - 130 CONTINUE - ENDIF - RETURN -10000 FORMAT (A) - END diff --git a/difrac/align.f b/difrac/align.f deleted file mode 100644 index 65393f9c..00000000 --- a/difrac/align.f +++ /dev/null @@ -1,640 +0,0 @@ -C----------------------------------------------------------------------- -C -C Reflection Alignment routine -C -C The routine has 5 entry points :-- -C -C CR aligns the reflection which is already in the detector, or -C a single reflection which is set before alignment. -C AL firstly reads in h,k,l values and generates symmetry equivalent -C reflections if wanted; -C secondly aligns both + and - h,k,l values for use by MM. -C AR resumes alignment after AL has been interrupted. -C RO reads in reflections as for the first part of AL. -C IORNT .EQ. 1 does re-orientation during data collection via the -C second part of AL. -C----------------------------------------------------------------------- - SUBROUTINE ALIGN - INCLUDE 'COMDIF' - DIMENSION IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10),BCHI(10), - $ BPHI(10),T4(4),O4(4),C4(4),P4(4) - CHARACTER CPM*1 - 100 IF (KI .EQ. 'CR') WRITE (COUT,10000) - IF (KI .EQ. 'AL') WRITE (COUT,11000) - IF (KI .EQ. 'AR') WRITE (COUT,12000) - CALL GWRITE (ITP,' ') - DT = IDTDEF - DO = IDODEF - DC = IDCDEF - AFRAC = 0.5 - PRESET = 1000. -C----------------------------------------------------------------------- -C Read the angle steps DT, DO and DC, counting TIME and AFRAC -C----------------------------------------------------------------------- - IF (KI .EQ. 'AL' .OR. KI .EQ. 'CR' .OR. KI. EQ. 'RO') THEN - IF (DFMODL .EQ. 'CAD4') THEN - WRITE (COUT,12900) - CALL FREEFM (ITR) - DT = RFREE(1) - ISLIT = 10.0*DT + 0.5 - IF (ISLIT .EQ. 0) ISLIT = 40 - IF (ISLIT .LT. 10) ISLIT = 10 - IF (ISLIT .GT. 60) ISLIT = 60 - ELSE - ISLIT = 0 - WRITE (COUT,13000) IDTDEF,IDODEF,IDCDEF,IFRDEF - CALL FREEFM (ITR) - DT = RFREE(1) - DO = RFREE(2) - DC = RFREE(3) - IF (DT .EQ. 0) DT = IDTDEF - IF (DO .EQ. 0) DO = IDODEF - IF (DC .EQ. 0) DC = IDCDEF - DT = DT/IFRDEF - DO = DO/IFRDEF - DC = DC/IFRDEF - WRITE (COUT,14000) - CALL FREEFM (ITR) - PRESET = RFREE(1) - IF (PRESET .EQ. 0.0) PRESET = 1000. - WRITE (COUT,15000) - CALL FREEFM (ITR) - AFRAC = RFREE(1) - IF (AFRAC .EQ. 0.) AFRAC = 0.5 - WRITE (COUT,16000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') GO TO 100 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C For CR, set the reflection if necessary -C----------------------------------------------------------------------- - IF (KI .EQ. 'CR') THEN - ITRY = 1 - IHSET = 0 - WRITE (COUT,17000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - 110 WRITE (COUT,18000) - CALL FREEFM (ITR) - IH = IFREE(1) - IK = IFREE(2) - IL = IFREE(3) - IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) THEN - KI = ' ' - RETURN - ENDIF - IHSET = 1 - MREF = MREF + 1 - CALL HKLN (IH,IK,IL,MREF) - IPRVAL = 1 - CALL ANGCAL - IF (IVALID .NE. 0) GO TO 110 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC) - IF (ICC .NE. 0) THEN - WRITE (COUT,19000) - CALL GWRITE (ITP,' ') - GO TO 110 - ENDIF - ENDIF - IF (IHSET .EQ. 0) THEN - WRITE (COUT,20000) - CALL FREEFM (ITR) - IHNEW = IFREE(1) - IKNEW = IFREE(2) - ILNEW = IFREE(3) - IF (IHNEW .NE. 0 .OR. IKNEW .NE. 0 .OR. ILNEW .NE. 0) THEN - IH = IHNEW - IK = IKNEW - IL = ILNEW - ENDIF - ENDIF - CALL ANGET (RTHETA,ROMEGA,RCHI,RPHI) - WRITE (COUT,21000) IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI - CALL GWRITE (ITP,' ') - IF (LPT .NE. ITP) WRITE (LPT,21000) - $ IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI - 115 CALL HKLN (IH,IK,IL,MREF) - CALL WXW2T (DT,DO,DC,ISLIT) - IF (KI .EQ. 'FF') THEN - IF (ITRY .EQ. 1) THEN - WRITE (COUT,22000) IH,IK,IL - CALL GWRITE (ITP,' ') - ITRY = 2 - IPRVAL = 1 - CALL ANGCAL - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC) - GO TO 115 - ELSE - WRITE (COUT,22100) IH,IK,IL - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN - ENDIF - ENDIF - CALL SHUTTR (1) - CALL CCTIME (PRESET,CT1) - CALL SHUTTR (-1) - WRITE (COUT,23000) IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI,CT1 - CALL GWRITE (ITP,' ') - IF (LPT .NE. ITP) WRITE (LPT,23000) - $ IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI,CT1 - WRITE (COUT,24000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - WRITE (COUT,25000) - CALL FREEFM (ITR) - I = IFREE(1) - IHK(I) = IH - NREFB(I) = IK - ILA(I) = IL - BCOUNT(I) = RTHETA - BBGR1(I) = ROMEGA - BBGR2(I) = RCHI - BTIME(I) = RPHI - ENDIF - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C AR -- Resume AL-type alignment from where it was interrupted. -C----------------------------------------------------------------------- - IF (KI .EQ. 'AR') THEN - READ (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC - READ (IID,REC=17) (IOK(J),J = 1,80),NTOT - READ (IID,REC=18) (IOL(J),J = 1,80) - READ (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100) - IF (DFMODL .EQ. 'CAD4') THEN - ISLIT = 10.0*DT + 0.5 - IF (ISLIT .EQ. 0) ISLIT = 40 - ENDIF - NBLOKO = 250 - NDONE = 0 - 120 READ (ISD,REC=NBLOKO) - $ (JUNK,I = 1,80),NINBLK,NLIST,IPLUS,NTOT,NBLOKO - IF (NINBLK .NE. 0) THEN - NBLOKO = NBLOKO + 1 - NDONE = NDONE + NINBLK - GO TO 120 - ENDIF - NBLOKO = NBLOKO - 1 - READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI, - $ BPSI,NINBLK,NLIST,IPLUS,NTOT,NBLOKO - IF (IPLUS .EQ. -1) NLIST = NLIST + 1 - IPLUS = -IPLUS - IH = IPLUS*IOH(NLIST) - IK = IPLUS*IOK(NLIST) - IL = IPLUS*IOL(NLIST) - WRITE (COUT,26000) NDONE,IH,IK,IL - CALL GWRITE (ITP,' ') - NSTART = NLIST - ENDIF -C----------------------------------------------------------------------- -C AL -- First Part -- Read in a list of h,k,l values & generate -C symmetry equivs if wanted; -C Second Part -- Align the + and - Friedel reflections -C RO -- First part of AL -C Second part of AL, when IORNT = 1 -C----------------------------------------------------------------------- - IF (KI .EQ. 'AL' .OR. KI .EQ. 'RO') THEN - CALL ALEDIT (NTOT) - IF (NTOT .EQ. 0) THEN - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Write the h,k,l values to file for use with AR and RO -C----------------------------------------------------------------------- - WRITE (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC - WRITE (IID,REC=17) (IOK(J),J = 1,80),NTOT - WRITE (IID,REC=18) (IOL(J),J = 1,80) - WRITE (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100) - ENDIF - IF (KI .EQ. 'RO') RETURN -C----------------------------------------------------------------------- -C Read in data if IORNT = 1 (RO) -C----------------------------------------------------------------------- - IF (IORNT .EQ. 1) THEN - READ (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC - READ (IID,REC=17) (IOK(J),J = 1,80),NTOT - READ (IID,REC=18) (IOL(J),J = 1,80) - READ (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100) - WRITE (LPT,27000) NREF - ENDIF -C----------------------------------------------------------------------- -C Get ready for the second part of AL or OR -C----------------------------------------------------------------------- - IF (KI .EQ. 'AL' .OR. IORNT .EQ. 1) THEN - NBLOKO = 250 - NINBLK = 0 - MREF = 0 - NSTART = 1 - IPLUS = 1 - IHSV = IH - IKSV = IK - ILSV = IL - ENDIF -C----------------------------------------------------------------------- -C Do alignment on these reflections (+ and -) -C----------------------------------------------------------------------- - DO 150 NLIST = NSTART,NTOT - 130 IH = IPLUS*IOH(NLIST) - IK = IPLUS*IOK(NLIST) - IL = IPLUS*IOL(NLIST) - ISTAN = 0 - DPSI = 0.0 - ITRY = 1 - MREF = MREF + 1 - NTRUE = 0 - IPRVAL = 0 - CALL ANGCAL - IF (IVALID .NE. 0 .AND. IVALID .NE. 4) GO TO 140 - IF (DFMODL .EQ. 'CAD4' .AND. THETA .GT. 110.0 .AND. - $ (CHI .GT. 270.0 .AND. CHI .LT. 300)) THEN - WRITE (LPT,28000) IH,IK,IL - GO TO 140 - ENDIF - IF (ITRUE .EQ. 1) THEN - T4(1) = THETA - T4(2) = 360.0 - THETA - T4(3) = THETA - T4(4) = 360.0 - THETA - O4(1) = OMEGA - O4(2) = OMEGA - O4(3) = OMEGA - O4(4) = OMEGA - C4(1) = CHI - C4(2) = CHI - C4(3) = 360.0 - CHI - C4(4) = 360.0 - CHI - P34 = 180.0 + PHI - IF (P34 .GE. 360.0) P34 = P34 - 360.0 - P4(1) = PHI - P4(2) = PHI - P4(3) = P34 - P4(4) = P34 - ENDIF - 135 CALL HKLN (IH,IK,IL,MREF) - IF (ITRUE .EQ. 1 .AND. ITRY .EQ. 1) THEN - NTRUE = NTRUE + 1 - THETA = T4(NTRUE) - OMEGA = O4(NTRUE) - CHI = C4(NTRUE) - PHI = P4(NTRUE) - ENDIF - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC) - IF (ICC .NE. 0) GO TO 140 - CPM = '+' - IF (IPLUS .EQ. -1) CPM = '-' - WRITE (LPT,29000) NLIST,CPM,IH,IK,IL,THETA,OMEGA,CHI,PHI - CALL WXW2T (DT,DO,DC,ISLIT) - IF (KI .EQ. 'FF') THEN - IF (ITRY .EQ. 1) THEN - WRITE (LPT,22000) IH,IK,IL - WRITE (COUT,22000) IH,IK,IL - CALL GWRITE (ITP,' ') - ITRY = 2 - GO TO 135 - ELSE - WRITE (LPT,22100) IH,IK,IL - WRITE (COUT,22100) IH,IK,IL - CALL GWRITE (ITP,' ') - GO TO 140 - ENDIF - ENDIF - CALL SHUTTR (1) - CALL CCTIME (PRESET,CT1) - CALL SHUTTR (-1) - WRITE (LPT,30000) IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI,CT1 - IF (ITRUE .EQ. 1) THEN - T4(NTRUE) = RTHETA - O4(NTRUE) = ROMEGA - C4(NTRUE) = RCHI - P4(NTRUE) = RPHI - IF (NTRUE .LT. 4) THEN - ITRY = 1 - GO TO 135 - ELSE - DO 136 I4 = 1,4 - IF (T4(I4) .GT. 180.0) T4(I4) = T4(I4) - 360.0 - IF (O4(I4) .GT. 180.0) O4(I4) = O4(I4) - 360.0 - IF (C4(I4) .GT. 180.0) C4(I4) = C4(I4) - 360.0 - 136 CONTINUE - RTHETA = (T4(1) - T4(2) + T4(3) - T4(4))/4.0 - ROMEGA = (O4(1) + O4(2) + O4(3) + O4(4))/4.0 - IF (ROMEGA .LT. 0.0) ROMEGA = ROMEGA + 360.0 - RCHI = (C4(1) + C4(2) - C4(3) - C4(4))/4.0 - IF (RCHI .LT. 0.0) RCHI = RCHI + 360.0 - RPHI = P4(1) - WRITE ( LPT,22200) RTHETA,ROMEGA,RCHI,RPHI - WRITE (COUT,22200) RTHETA,ROMEGA,RCHI,RPHI - CALL GWRITE (ITP,' ') - ENDIF - ENDIF - NINBLK = NINBLK + 1 - IBH(NINBLK) = IH - IBK(NINBLK) = IK - IBL(NINBLK) = IL - BTHETA(NINBLK) = RTHETA - BOMEGA(NINBLK) = ROMEGA - BCHI(NINBLK) = RCHI - BPHI(NINBLK) = RPHI - BPSI(NINBLK) = 0.0 -C----------------------------------------------------------------------- -C Write the block of alignment data so far -C----------------------------------------------------------------------- - WRITE (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI, - $ BPSI,NINBLK,NLIST,IPLUS,NTOT,NBLOKO - IF (NINBLK .EQ. 10) THEN - NBLOKO = NBLOKO + 1 - NINBLK = 0 - ENDIF - 140 CALL KORQ (KQFLAG) - IF (KQFLAG .NE. 1) GO TO 160 - IF (IPLUS .EQ. 1) THEN - IPLUS = -1 - GO TO 130 - ELSE - IPLUS = 1 - ENDIF - 150 CONTINUE -C----------------------------------------------------------------------- -C Write guard block on the end -C----------------------------------------------------------------------- - 160 IF (NINBLK .GT. 0) NBLOKO = NBLOKO + 1 - NINBLK = 0 - WRITE (ISD,REC=NBLOKO) (IOH(I),I = 1,80),NINBLK,NINBLK,NINBLK, - $ NTOT,NBLOKO - IF (IORNT .EQ. 1) THEN - IH = IHSV - IK = IKSV - IL = ILSV - ENDIF - CALL ZERODF - KI = ' ' - RETURN -10000 FORMAT (10X,' Centre the reflection already in the detector ') -11000 FORMAT (/10X,' Alignment of Symmetry and Friedel Equivalent', - $ ' Reflections'/,'%') -12000 FORMAT (10X,' Resume alignment from the AL command') -12900 FORMAT (' Type the horizontal slit width in mms (4.0) ',$) -13000 FORMAT (' Type the size of steps in 2T,Om,Chi,', - $ ' (',I2,',',I2,',',I2,') 1/',I3,'deg ',$) -14000 FORMAT (' Type the count preset for each step (1000.0) ',$) -15000 FORMAT (' Fraction of max. count for half-height cutoff (0.5) ',$) -16000 FORMAT (' All OK (Y) ? ',$) -17000 FORMAT (' Is the reflection already set (Y) ? ',$) -18000 FORMAT (' Type h,k,l for the reflection (Exit) ',$) -19000 FORMAT (3I3,' setting collision. Try again.') -20000 FORMAT (' Type h,k,l for use in M2/M3 ',$) -21000 FORMAT (' Starting Values ',3I4,4F10.3) -22000 FORMAT (3I4,' ailignment failed on first attempt'/) -22100 FORMAT (3I4,' ailignment failed on both attempts'/) -22200 FORMAT (' Mean Values ',12X,4F10.3/) -23000 FORMAT (' Final Values ',3I4,4F10.3,F7.0/) -24000 FORMAT (' Do you wish to save the angles for M2 or M3 (Y) ? ',$) -25000 FORMAT (' What is the sequence number of this reflection ? ',$) -26000 FORMAT (I4,' reflections have been aligned. Resuming at ',3I3/) -27000 FORMAT (/' Reorientation before Reflection ',I5) -28000 FORMAT (3I4,' is probably inaccessible on a CAD-4.'/) -29000 FORMAT (I4,A,' Starting Values ',3I4,4F10.3) -30000 FORMAT (' Final Values ',3I4,4F10.3,F7.0/) - END -C----------------------------------------------------------------------- -C Routine to generate equivalent reflections (Not Friedel) -C----------------------------------------------------------------------- - SUBROUTINE DEQHKL (NHKL,ILIST) - INCLUDE 'COMDIF' -C----------------------------------------------------------------------- -C Work out the reflection details and the unique equivalents -C----------------------------------------------------------------------- - NHKL = 0 - NRCEN = 0 - IEXCL = 0 - DO 110 K = 1,NSYM - IM = 0 - JS = 0 - JH = IH*JRT(1,1,K) + IK*JRT(2,1,K) + IL*JRT(3,1,K) - JK = IH*JRT(1,2,K) + IK*JRT(2,2,K) + IL*JRT(3,2,K) - JL = IH*JRT(1,3,K) + IK*JRT(2,3,K) + IL*JRT(3,3,K) - IPHASE = IH*JRT(1,4,K) + IK*JRT(2,4,K) + IL*JRT(3,4,K) - IF (MOD(IPHASE,12) .EQ. 0) IPHASE = 0 - IF (IH .EQ. JH .AND. IK .EQ. JK .AND. IL .EQ. JL) IM = 1 - IF (IH .EQ. -JH .AND. IK .EQ. -JK .AND. IL .EQ. -JL) JS = 1 - IF (JS .EQ. 1) NRCEN = 1 - IF (IM .EQ. 1 .AND. IPHASE .NE. 0) IEXCL = 1 - IF (ICENT .EQ. 0) JS = 0 - IF (JS .EQ. 1 .AND. IPHASE .NE. 0) IEXCL = 1 - IF (NHKL .NE. 0) THEN - DO 100 I = 1,NHKL - IF (JHKL(1,I) .EQ. JH .AND. - $ JHKL(2,I) .EQ. JK .AND. - $ JHKL(3,I) .EQ. JL) GO TO 110 - IF (JHKL(1,I) .EQ. -JH .AND. - $ JHKL(2,I) .EQ. -JK .AND. - $ JHKL(3,I) .EQ. -JL) GO TO 110 - 100 CONTINUE - ENDIF - NHKL = NHKL + 1 - JHKL(1,NHKL) = JH - JHKL(2,NHKL) = JK - JHKL(3,NHKL) = JL - 110 CONTINUE - IVALID = IEXCL - IEXCL = 0 - IF (LATCEN .NE. 1) THEN - IF (LATCEN .EQ. 2) IREM = MOD((IK + IL),2) - IF (LATCEN .EQ. 3) IREM = MOD((IH + IL),2) - IF (LATCEN .EQ. 4) IREM = MOD((IH + IK),2) - IF (LATCEN .EQ. 5) IREM = MOD((IH + IK + IL),2) - IF (LATCEN .EQ. 6) THEN - IREM = MOD((IH + IK),2) - IF (IREM .EQ. 0) IREM = MOD((IH + IL),2) - ENDIF - IF (LATCEN .EQ. 7) IREM = MOD((-IH + IK + IL),3) - IF (IEXCL .EQ. 0) IEXCL = IREM - ENDIF - IF (IEXCL .NE. 0) THEN - IVALID = IVALID + 2 - RETURN - ENDIF -C----------------------------------------------------------------------- -C Print the equivalent indices -C----------------------------------------------------------------------- - IF (ILIST .EQ. 1) THEN - WRITE (COUT,10000) ((JHKL(J,K),J = 1,3),K = 1,NHKL) - CALL GWRITE (ITP,' ') - ENDIF - RETURN -10000 FORMAT (4(5X,3I4)) - END -C----------------------------------------------------------------------- -C Edit the h,k,l list for the AL or RO commands -C----------------------------------------------------------------------- - SUBROUTINE ALEDIT (NTOT) - INCLUDE 'COMDIF' - DIMENSION NDEL(100) - CHARACTER IOPT*1,LINE*80 -C----------------------------------------------------------------------- -C Read in the existing list of h,k,l values and write it to terminal -C----------------------------------------------------------------------- - READ (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC - READ (IID,REC=17) (IOK(J),J = 1,80),NTOT - READ (IID,REC=18) (IOL(J),J = 1,80) - READ (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100) - 100 IF (NTOT .LE. 0) THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - ELSE - WRITE (COUT,11000) NTOT - CALL GWRITE (ITP,' ') - NLINE = NTOT/4 - IF (NTOT - 4*NLINE .NE. 0) NLINE = NLINE + 1 - I1 = 1 - I2 = 4 - DO 110 N = 1,NLINE - IF (N .EQ. NLINE) I2 = NTOT - WRITE (COUT,12000) (I,IOH(I),IOK(I),IOL(I),I = I1,I2) - CALL GWRITE (ITP,' ') - I1 = I1 + 4 - I2 = I2 + 4 - 110 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Get the edit option IOPT -C----------------------------------------------------------------------- - WRITE (COUT,13000) - CALL ALFNUM (LINE) - IOPT = LINE(1:1) - IF (IOPT .EQ. ' ') IOPT = 'U' -C----------------------------------------------------------------------- -C Option E. Exit from AL with 0 reflns -C----------------------------------------------------------------------- - IF (IOPT .EQ. 'E') THEN - NTOT = 0 - RETURN - ENDIF -C----------------------------------------------------------------------- -C Option U. Use the present list and get the TRUANG flag. -C----------------------------------------------------------------------- - IF (IOPT .EQ. 'U') THEN - ITRUE = 0 - WRITE (COUT,14100) - CALL YESNO ('N',LINE) - ANS = LINE(1:1) - IF (ANS .EQ. 'Y') ITRUE = 1 - RETURN - ENDIF -C----------------------------------------------------------------------- -C Options A and N. Add reflns or use new ones. -C----------------------------------------------------------------------- - IF (IOPT .EQ. 'A' .OR. IOPT .EQ. 'N') THEN - IF (IOPT .EQ. 'N') NTOT = 0 - ISYMOR = 0 - WRITE (COUT,14000) - CALL YESNO ('Y',LINE) - ANS = LINE(1:1) - IF (ANS .EQ. 'Y') THEN - ISYMOR = 1 - IOUT = -1 - CALL SPACEG (IOUT,0) - ENDIF - NPOSS = 100 - NTOT - WRITE (COUT,15000) NPOSS - CALL GWRITE (ITP,' ') - 120 WRITE (COUT,16000) - CALL FREEFM (ITR) - IH = IFREE(1) - IK = IFREE(2) - IL = IFREE(3) - IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN - IPRVAL = 1 - CALL ANGCAL - IF (IVALID .EQ. 0) THEN - IF (ISYMOR .EQ. 1) THEN - ILIST = 1 - CALL DEQHKL (NHKL,ILIST) - DO 130 I = 1,NHKL - NTOT = NTOT + 1 - IOH(NTOT) = JHKL(1,I) - IOK(NTOT) = JHKL(2,I) - IOL(NTOT) = JHKL(3,I) - IF (NTOT .EQ. NSIZE/2) THEN - WRITE (COUT,17000) - CALL GWRITE (ITP,' ') - GO TO 100 - ENDIF - 130 CONTINUE - ELSE - NTOT = NTOT + 1 - IOH(NTOT) = IH - IOK(NTOT) = IK - IOL(NTOT) = IL - ENDIF - ENDIF - GO TO 120 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Option D. Delete reflections from the list -C----------------------------------------------------------------------- - IF (IOPT .EQ. 'D') THEN - DO 140 I = 1,100 - NDEL(I) = 0 - 140 CONTINUE - 150 WRITE (COUT,18000) - CALL FREEFM (ITR) - IH = IFREE(1) - IK = IFREE(2) - IL = IFREE(3) - IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN - DO 160 N = 1,NTOT - IF (IH .EQ. IOH(N) .AND. IK .EQ. IOK(N) .AND. - $ IL .EQ. IOL(N)) THEN - NDEL(N) = 1 - GO TO 150 - ENDIF - 160 CONTINUE - WRITE (COUT,19000) IH,IK,IL - CALL GWRITE (ITP,' ') - GO TO 150 - ELSE -C----------------------------------------------------------------------- -C Form the new list -C----------------------------------------------------------------------- - NEW = 0 - DO 170 N = 1,NTOT - IF (NDEL(N) .EQ. 0) THEN - NEW = NEW + 1 - IOH(NEW) = IOH(N) - IOK(NEW) = IOK(N) - IOL(NEW) = IOL(N) - ENDIF - 170 CONTINUE - NTOT = NEW - ENDIF - ENDIF -C----------------------------------------------------------------------- -C List the existing list and get new option -C----------------------------------------------------------------------- - GO TO 100 -10000 FORMAT (' There are no reflections in the AL/RO list.') -11000 FORMAT (' The following',I4,' reflections are in the AL/RO list') -12000 FORMAT (4(I3,'.',3I4,3X)) -13000 FORMAT (' The following options are available :--'/ - $ ' U. Use the existing AL/RO list;'/ - $ ' A. Add reflections to the existing AL/RO list;'/ - $ ' D. Delete reflections from the existing AL/RO list;'/ - $ ' N. New AL/RO list.'/ - $ ' L. List the reflections in the existing AL/RO list;'/ - $ ' E. Exit from AL/RO.'/ - $ ' Which option do you want (U) ? ',$) -14000 FORMAT (' Friedel equivalents are always used.'/ - $ ' Do you want symmetry equivalents as well (Y) ? ',$) -14100 FORMAT (' Align 4 equivalent settings for each refln (N) ? ',$) -15000 FORMAT (' Type h,k,l for up to',I4,' reflections ') -16000 FORMAT (' h,k,l (End) ',$) -17000 FORMAT (' No more reflections allowed.') -18000 FORMAT (' Type h,k,l for the reflection to be deleted (End) ',$) -19000 FORMAT (3I4,' not found. Try again please.') - END diff --git a/difrac/ang180.f b/difrac/ang180.f deleted file mode 100644 index 4d4a8f06..00000000 --- a/difrac/ang180.f +++ /dev/null @@ -1,8 +0,0 @@ -C----------------------------------------------------------------------- -C Make the negative of an angle in mathematical form -C----------------------------------------------------------------------- - SUBROUTINE ANG180 (ANG) - IF (ANG .LE. 180.0) ANG = -ANG - IF (ANG .GT. 180.0) ANG = 360.0-ANG - RETURN - END diff --git a/difrac/ang360.f b/difrac/ang360.f deleted file mode 100644 index c030cbe7..00000000 --- a/difrac/ang360.f +++ /dev/null @@ -1,13 +0,0 @@ -C----------------------------------------------------------------------- -C Routine to make the difference between ANG and EXPCT small -C----------------------------------------------------------------------- - SUBROUTINE ANG360 (ANG,EXPCT) - 100 D = EXPCT - ANG - ISIGN = 1 - IF (D .LT. 0.) ISIGN = -1 - IF (ABS(D) .GE. 180.0) THEN - ANG = ANG + ISIGN*360.0 - GO TO 100 - ENDIF - RETURN - END diff --git a/difrac/angcal.f b/difrac/angcal.f deleted file mode 100644 index 63a2caa6..00000000 --- a/difrac/angcal.f +++ /dev/null @@ -1,285 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to calculate 2Theta, chi,phi when Dpsi=0 -C and 2Theta,omega,chi,phi otherwise -C IVALID = 32 if 2theta .ge. 180.0 -C 16 if low temp. and chi is not in +/- 90 range -C 8 if reflection is 0,0,0, or -C 4 if not within 2Theta limits, or -C 2 if lattice or specific absence, or -C 1 if translation absence. -C IROT=1 if rotation is not possible -C----------------------------------------------------------------------- - SUBROUTINE ANGCAL - INCLUDE 'COMDIF' - DIMENSION Q(3,3),VEC(3) - CHARACTER INTFLT*3 - RAD = 1.0/DEG - SM4 = 2.0*SIN(THEMIN*RAD*0.5) - SM4 = SM4*SM4 - SS4 = 2.0*SIN(THEMAX*RAD*0.5) - SS4 = SS4*SS4 - IROT = 0 - IVALID = 0 -C----------------------------------------------------------------------- -C If called by RA allow for fractional h,k,l values -C----------------------------------------------------------------------- - INTFLT = 'INT' - IF ((KI .EQ. 'RA' .OR. KI .EQ. 'SR' .OR. KI .EQ. 'MS') .AND. - $ (ABS(RFREE(1) - IH) .GT. 0.0001 .OR. - $ ABS(RFREE(2) - IK) .GT. 0.0001 .OR. - $ ABS(RFREE(3) - IL) .GT. 0.0001)) INTFLT = 'FLT' - IF (INTFLT .EQ. 'INT') THEN - RH = IH - RK = IK - RL = IL - ELSE - RH = RFREE(1) - RK = RFREE(2) - RL = RFREE(3) - ENDIF - IF (INTFLT .EQ. 'INT') THEN -C----------------------------------------------------------------------- -C Test for the 0,0,0 reflection -C----------------------------------------------------------------------- - IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) THEN - IVALID = 8 - IF (IPRVAL .NE. 0) THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - ENDIF - RETURN - ENDIF -C----------------------------------------------------------------------- -C Test for translation and lattice absences -C----------------------------------------------------------------------- - IF (KI .NE. 'IE') CALL DEQHKL (NHKL,0) - IF (IVALID .NE. 0 .AND. IPRVAL .NE. 0) THEN - WRITE (COUT,11000) IH,IK,IL - CALL GWRITE (ITP,' ') - ENDIF -C----------------------------------------------------------------------- -C Tests for typed in specific absence conditions (NCOND .GT. 0) -C If only the direction is of interest (NN), bypass these tests. -C----------------------------------------------------------------------- - IF (NCOND .GT. 0 .AND. NN .NE. -1) THEN - DO 100 J = 1,NCOND - JCOND = ICOND(J) - IF ((JCOND .EQ. 1 .AND. IH .EQ. 0 .AND. IK .EQ. 0) .OR. - $ (JCOND .EQ. 2 .AND. IH .EQ. 0 .AND. IL .EQ. 0) .OR. - $ (JCOND .EQ. 3 .AND. IK .EQ. 0 .AND. IL .EQ. 0) .OR. - $ (JCOND .EQ. 4 .AND. IH .EQ. 0) .OR. - $ (JCOND .EQ. 5 .AND. IK .EQ. 0) .OR. - $ (JCOND .EQ. 6 .AND. IL .EQ. 0) .OR. - $ JCOND .EQ. 7) THEN - LHS = IABS(IH*IHS(J) + IK*IKS(J) + IL*ILS(J)) - M = IR(J) - IF (MOD(LHS,M) .NE. IS(J)) THEN - IVALID = 2 - IF (IPRVAL .NE. 0) THEN - WRITE (COUT,12000) IH,IK,IL - CALL GWRITE (ITP,' ') - ENDIF - ENDIF - ENDIF - 100 CONTINUE - ENDIF - ENDIF - SUM = 0.0 - DO 110 I = 1,3 - VEC(I) = R(I,1)*RH + R(I,2)*RK + R(I,3)*RL - SUM = SUM + VEC(I)*VEC(I) - 110 CONTINUE -C----------------------------------------------------------------------- -C Calculate Theta from SINABS to avoid segment problems -C Test for 2Theta limits, if not a reference reflection and print -C error message if not the UM command. -C----------------------------------------------------------------------- - SINMAX = RH*RH*SINABS(1) + RK*RK*SINABS(2) + RL*RL*SINABS(3) + - $ RH*RK*SINABS(4) + RH*RL*SINABS(5) + RK*RL*SINABS(6) - IF (ISTAN .EQ. 0 .AND. NN .NE. -1) THEN - IF (IUMPTY .EQ. 0 .AND. SINMAX .GE. 4.0) THEN - IF (INTFLT .EQ. 'INT') THEN - WRITE (COUT,13000) IH,IK,IL - ELSE - WRITE (COUT,13100) RH,RK,RL - ENDIF - CALL GWRITE (ITP,' ') - IVALID = 32 - RETURN - ENDIF - IF (SINMAX .LT. SM4 .OR. SINMAX .GT. SS4) THEN - IVALID = 4 - IF (IPRVAL .NE. 0) THEN - IF (INTFLT .EQ. 'INT') THEN - WRITE (COUT,14000) IH,IK,IL - ELSE - WRITE (COUT,14100) RH,RK,RL - ENDIF - CALL GWRITE (ITP,' ') - ENDIF - ENDIF - ENDIF - CALL CALANG (VEC) - CALL CHICOL -C----------------------------------------------------------------------- -C Rotation about scattering vector. Omega,Chi,Phi for a given Psi -C----------------------------------------------------------------------- -C Modified MK. Make PSI calculation all the time and add 180 to PSI -C This is because TRICS seems to have a PSI rotation by 180 degree -C hidden in its setup. This may be WRONG! -C IF (ISTAN .EQ. 0 .AND. DPSI .NE. 0) THEN -C - IF(.TRUE.) THEN - PSIDUM = PSI + 180 - IF(PSIDUM .GT. 360) PSIDUM = PSIDUM - 360. - CHO = CHI*RAD - PHO = PHI*RAD -C PSO = PSI*RAD - PSO = PSIDUM*RAD - Q(3,1) = SIN(PSO)*SIN(PHO) - COS(PSO)*SIN(CHO)*COS(PHO) - Q(3,2) = -SIN(PSO)*COS(PHO) - COS(PSO)*SIN(CHO)*SIN(PHO) - Q(3,3) = COS(PSO)*COS(CHO) - Q(1,3) = SIN(CHO) - Q(2,3) = SIN(PSO)*COS(CHO) - OMEGA = DEG*ATAN2(-Q(2,3), Q(1,3)) - PHI = DEG*ATAN2(-Q(3,2),-Q(3,1)) - CHI = DEG*ATAN2(SQRT(Q(3,1)*Q(3,1) + Q(3,2)*Q(3,2)),Q(3,3)) - IF (OMEGA .LT. 0) OMEGA = OMEGA + 360.0 - IF (PHI .LT. 0) PHI = PHI + 360.0 - IF (OMEGA .LT. 270.0 .AND. OMEGA .GT. 90.0) THEN - PHI = PHI + 180.0 - CHI = 360.0 - CHI - OMEGA = 180.0 + OMEGA - ENDIF - IF (PHI .GE. 360.0) PHI = PHI - 360.0 - IF (OMEGA .GE. 360.0) OMEGA = OMEGA - 360.0 - CALL OMGCOL - IF (IROT .EQ. 0) CALL CHICOL - ENDIF - CALL MOD360 (OMEGA) - CALL MOD360 (CHI) - CALL ANGCHECK(THETA,OMEGA,CHI,PHI,IVALID) - IF(IVALID .GE. 4) IROT = 1 - RETURN -10000 FORMAT (' Reflection 0,0,0 is invalid.') -11000 FORMAT (' Reflection',3I4,' is a systematic absence') -12000 FORMAT (' Reflection',3I4,' is a specified absence') -13000 FORMAT (' Reflection',3I4,' has 2theta .ge. 180. Impossible!') -13100 FORMAT (' Reflection',3F8.3,' has 2theta .ge. 180. Impossible!') -14000 FORMAT (' Reflection',3I4,' is outside the 2theta limits ') -14100 FORMAT (' Reflection',3F8.3,' is outside the 2theta limits ') - END -C----------------------------------------------------------------------- -C Calculate 2Theta, Chi, Phi for the Omega=0 position -C If chi .gt. 89.999 (cos**2(89.999) = 3.0E-10) chi is set to 90.0 -C----------------------------------------------------------------------- - SUBROUTINE CALANG (VEC) - INCLUDE 'COMDIF' - DIMENSION VEC(3) - BOT = ABS(VEC(1)) - CEN = ABS(VEC(2)) - TOP = ABS(VEC(3)) - IF (BOT .EQ. 0.0) THEN - PHI = 90.0 - ELSE - PHI = ATAN2(CEN,BOT)*DEG - ENDIF - SUM = SUM - TOP*TOP - IF (SUM .LT. 3.0E-10) THEN - CHI = 90.0 - ELSE - CHI = ATAN2(TOP,SQRT(SUM))*DEG - ENDIF - IF (VEC(3) .LT. 0.0) CHI = 360.0 - CHI - IF (VEC(1) .LT. 0.0) THEN - IF (VEC(2) .LT. 0.0) THEN - PHI = 180.0 + PHI - ELSE - PHI = 180.0 - PHI - ENDIF - ELSE - IF (VEC(2) .LT. 0.0) PHI = 360.0 - PHI - ENDIF - IF (CHI .EQ. 90.0 .OR. CHI .EQ. 270.0) PHI = 0.0 - SINSQ = 0.25*(SUM + TOP*TOP) - IF (SINSQ .GE. 0.999999) THEN - THETA = 180.0 - ELSE - THETA = 2.0*DEG*ATAN(SQRT(SINSQ/(1.0 - SINSQ))) - ENDIF - OMEGA = 0.0 -C----------------------------------------------------------------------- -C Bisecting or parallel mode IBSECT = 0/1 (forced 0) -C----------------------------------------------------------------------- - IF (IBSECT .EQ. 1) THEN - PHI = PHI + 90.0 - IF (PHI .GE. 360.0) PHI = PHI - 360.0 - OMEGA = CHI + 270.0 - IF (OMEGA .GE. 360.0) OMEGA = OMEGA - 360.0 - CHI = 90.0 - CALL OMGCOL - IF (IROT .EQ. 0) CALL CHICOL - ENDIF - RETURN - END -C----------------------------------------------------------------------- -C Test if rotation is possible without omega collisions. -C Limits are set for 4 possible collisions as follows :-- -C a. Chi ring with front of tube housing; -C b. Chi ring with rear of tube housing; -C c. Chi ring with front of detector mount; -C d. Chi ring with rear of detector mount attenuator housing. -C For a. and d. omega is in the range 0 to 90, and -C for b. and c. omega is in the range 270 to 360. -C The chi ring has an angular half width DELCHI = 16degs. -C The angular restrictions for a., b., c. and d. are -C DELA = 13, DELB = 31, DELC = 5, DELD = 33, each plus DELCHI. -C If chi is in the range 53 to 117, i.e. in a position where the phi -C base could be caught between the front of the tube housing and the -C detector mount, DELCHI must be increased by 3 for a. and 6 for c. -C The limits are conservative, but will need to be changed for -C different instruments. -C----------------------------------------------------------------------- - SUBROUTINE OMGCOL - INCLUDE 'COMDIF' - DELCHI = 16.0 - DELA = 13.0 - DELB = 31.0 - DELC = 5.0 - DELD = 33.0 - CHIBOT = 53.0 - CHITOP = 117.0 - IROT = 0 - THET = 0.5*THETA - IF (OMEGA .LT. 90.0) THEN - OMEGAD = OMEGA - T1 = 90.0 - DELA - DELCHI - THET - IF (CHI .GT. CHIBOT .AND. CHI .LT. CHITOP) T1 = T1 - 3.0 - T2 = 90.0 - DELD - DELCHI + THET - ELSE - OMEGAD = 360.0 - OMEGA - T1 = 90.0 - DELB - DELCHI + THET - T2 = 90.0 - DELC - DELCHI - THET - IF (CHI .GT. CHIBOT .AND. CHI .LT. CHITOP) T2 = T2 - 6.0 - ENDIF - IF (OMEGAD .GE. T1 .OR. OMEGAD .GE. T2) IROT = 1 - RETURN - END -C----------------------------------------------------------------------- -C Sample routine to ensure that the range of CHI is restricted when -C there is a cryostat on the instrument. -C It is assumed that 2thetamax is set realistically to ensure that -C there will be no OMEGA collisions with the cryostat. -C CHI is restricted to the range +/- 90 -C----------------------------------------------------------------------- - SUBROUTINE CHICOL - INCLUDE 'COMDIF' - IF (ILN .EQ. 1) THEN - IF (CHI .GE. 270.0 .OR. CHI .LE. 90.0) THEN - IVALID = 0 - ELSE - IVALID = 16 - ENDIF - ENDIF - RETURN - END diff --git a/difrac/angl.f b/difrac/angl.f deleted file mode 100644 index ffcbf9be..00000000 --- a/difrac/angl.f +++ /dev/null @@ -1,14 +0,0 @@ -C----------------------------------------------------------------------- -C Calculate the angle between two Cartesian vectors -C----------------------------------------------------------------------- - SUBROUTINE ANGL (X1,Y1,Z1,X2,Y2,Z2,ANGLE) - SPROD = X1*X2 + Y1*Y2 + Z1*Z2 - SMOD = (X1*X1 + Y1*Y1 + Z1*Z1)*(X2*X2 + Y2*Y2 + Z2*Z2) - COSIN = SPROD/SQRT(SMOD) - IF (COSIN .GE. 1) COSIN = 1 - IF (COSIN .LT. -1) COSIN = -1 - ANGLE = ACOS(COSIN) - ANGLE = ANGLE*180/3.141593 - RETURN - END - \ No newline at end of file diff --git a/difrac/angrw.f b/difrac/angrw.f deleted file mode 100644 index d81c759c..00000000 --- a/difrac/angrw.f +++ /dev/null @@ -1,76 +0,0 @@ -C----------------------------------------------------------------------- -C Routine to read or write the alignment angles from IDATA.DA -C -C The call is CALL ANGRW (IRDWRT,NANG,NUM,NRECS,IOFF) where -C IRDWRT is 0/1 for read or write; -C NANG is the number of angles to be used; -C NUM is the number of reflections; -C NRECS is the record number to start the operation; -C IOFF is the offset in the ACOUNT array. -C The ACOUNT array is equivalenced to the angle arrays as :-- -C DIMENSION THETAS(NSIZE),OMEGAS(NSIZE),CHIS(NSIZE),PHIS(NSIZE), -C $ ICNT(NSIZE), -C $ THETAP(NSIZE),OMEGAP(NSIZE),CHIP(NSIZE),PHIP(NSIZE) -C EQUIVALENCE (ACOUNT( 1),THETAS(1)), -C $ (ACOUNT( NSIZE*1),OMEGAS(1)), -C $ (ACOUNT(2*NSIZE+1),CHIS(1)), -C $ (ACOUNT(3*NSIZE+1),PHIS(1)), -C $ (ACOUNT(4*NSIZE+1),ICNT(1)), -C $ (ACOUNT(5*NSIZE+1),THETAP(1)), -C $ (ACOUNT(6*NSIZE+1),OMEGAP(1)), -C $ (ACOUNT(7*NSIZE+1),CHIP(1)), -C $ (ACOUNT(8*NSIZE+1),PHIP(1)) -C----------------------------------------------------------------------- - SUBROUTINE ANGRW (IRDWRT,NANG,NUM,NRECS,IOFF) - INCLUDE 'COMDIF' -C----------------------------------------------------------------------- -C Calculate the ACOUNT address offset and number of reads or writes -C----------------------------------------------------------------------- - NOFF = 0 - IF (IOFF .EQ. 1) NOFF = 5*NSIZE - NRW = (NSIZE + 79)/80 - NADD = NOFF - NREC = NRECS -C----------------------------------------------------------------------- -C Read data from the file -C----------------------------------------------------------------------- - IF (IRDWRT .EQ. 0) THEN - DO 110 N = 1,NANG - NADD1 = NADD + 1 - NADD2 = NADD + 80 - DO 100 J = 1,NRW - IF (N .EQ. 1 .AND. J .EQ. 1) THEN - READ (ISD,REC=NREC) NUM,(ACOUNT(I),I = NADD1,NADD2) - ELSE - READ (ISD,REC=NREC) (ACOUNT(I),I = NADD1,NADD2) - ENDIF - NREC = NREC + 1 - NADD1 = NADD2 + 1 - NADD2 = NADD2 + 80 - IF (NADD2 .GT. NADD+NSIZE) NADD2 = NADD + NSIZE - 100 CONTINUE - NADD = NADD + NSIZE - 110 CONTINUE -C----------------------------------------------------------------------- -C Write data to the file -C----------------------------------------------------------------------- - ELSE - DO 130 N = 1,NANG - NADD1 = NADD + 1 - NADD2 = NADD + 80 - DO 120 J = 1,NRW - IF (N .EQ. 1 .AND. J .EQ. 1) THEN - WRITE (ISD,REC=NREC) NUM,(ACOUNT(I),I = NADD1,NADD2) - ELSE - WRITE (ISD,REC=NREC) (ACOUNT(I),I = NADD1,NADD2) - ENDIF - NREC = NREC + 1 - NADD1 = NADD2 + 1 - NADD2 = NADD2 + 80 - IF (NADD2 .GT. NADD+NSIZE) NADD2 = NADD + NSIZE - 120 CONTINUE - NADD = NADD + NSIZE - 130 CONTINUE - ENDIF - RETURN - END diff --git a/difrac/angval.f b/difrac/angval.f deleted file mode 100644 index 574df1aa..00000000 --- a/difrac/angval.f +++ /dev/null @@ -1,20 +0,0 @@ -C----------------------------------------------------------------------- -C This subroutine initializes the diffractometer angles. It is assumed -C that the encoders only show the fractional part of each angle and -C therefore the integer part must be fixed. This is done by reading -C the encoders and if the fractional parts have not changed since they -C were written to the file when the routine was stopped, it is assumed -C that the integer parts are OK. If not the integer parts are read -C from the terminal -C----------------------------------------------------------------------- - SUBROUTINE ANGVAL - INCLUDE 'COMDIF' -C----------------------------------------------------------------------- -C Find out if there is a diffractometer attached (debug purposes) -C----------------------------------------------------------------------- -C WRITE (ITP,10000) -C CALL YESNO ('Y',ANS) - CALL INTON - RETURN -10000 FORMAT (' Is there a diffractometer on the computer (Y) ? ',$) - END diff --git a/difrac/basinp.f b/difrac/basinp.f deleted file mode 100644 index f587f663..00000000 --- a/difrac/basinp.f +++ /dev/null @@ -1,722 +0,0 @@ -C----------------------------------------------------------------------- -C Read in all Basic Data from the terminal commands -C----------------------------------------------------------------------- - SUBROUTINE BASINP - INCLUDE 'COMDIF' - CHARACTER KISAVE*2 -C----------------------------------------------------------------------- -C Select data to be read from keys with the value in KI -C If KI = 'BD' then all basic data must be typed in. -C The following keys are allowed :-- -C AD BD CZ DH FR LA M2 M3 MM OM PS RO RR SD SE TM TP -C -C If M2, M3 or MM reset the indices corresponding to 2thetamax -C -C BD -- All Basic Data -C----------------------------------------------------------------------- - IF (KI .EQ. 'BD') THEN - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - ENDIF -C----------------------------------------------------------------------- -C AD -- Attenuator Data -C----------------------------------------------------------------------- - IF (KI .EQ. 'AD' .OR. KI .EQ. 'BD') THEN - IF (NATTEN .EQ. 0) THEN - WRITE (COUT,12000) - ELSE - WRITE (COUT,12100) (ATTEN(I),I=1,NATTEN+1) - ENDIF - CALL GWRITE (ITP,' ') - WRITE (COUT,12200) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - WRITE (COUT,12300) - CALL FREEFM (ITR) - NATTEN = 0 - ATTEN(1) = 1.0 - DO 100, I = 1,6 - IF (RFREE(I) .GT. 1.0) THEN - NATTEN = NATTEN + 1 - ATTEN(NATTEN+1) = RFREE(I) - ENDIF - 100 CONTINUE - ENDIF - IF (KI .EQ. 'AD') THEN - KI = ' ' - RETURN - ENDIF - ENDIF -C----------------------------------------------------------------------- -C LA -- Wavelength. When a new wavelength is to be used, the R matrix, -C SINABS and IH,K,LMAX must all be changed -C----------------------------------------------------------------------- - IF (KI .EQ. 'LA' .OR. KI .EQ. 'BD') THEN - WRITE (COUT,11000) WAVE - CALL FREEFM (ITR) - OWAVE = WAVE - IF (RFREE(1) .NE. 0.0) WAVE = RFREE(1) - WAVFAC = WAVE/OWAVE - IF (KI .EQ. 'LA') THEN - DO 110 I = 1,3 - SINABS(I) = WAVFAC*WAVFAC*SINABS(I) - SINABS(I+3) = WAVFAC*WAVFAC*SINABS(I+3) - DO 110 J = 1,3 - R(I,J) = WAVFAC*R(I,J) - 110 CONTINUE - S = 2.0*SIN((THEMAX*0.5)/DEG) - IHMAX = 1.0+S/(APS(1)*SANGS(2)*SANG(3)*WAVE) - IKMAX = 1.0+S/(APS(2)*SANGS(3)*SANG(1)*WAVE) - ILMAX = 1.0+S/(APS(3)*SANGS(1)*SANG(2)*WAVE) - KI = ' ' - CALL WRBAS - RETURN - ENDIF - ENDIF -C----------------------------------------------------------------------- -C OM -- Orientation Matrix -C----------------------------------------------------------------------- - IF (KI .EQ. 'OM' .OR. KI .EQ. 'BD') THEN - IF (KI .EQ. 'OM') THEN - WRITE (COUT,11000) WAVE - CALL FREEFM (ITR) - IF (RFREE(1) .NE. 0.0) WAVE = RFREE(1) - ENDIF - WRITE (COUT,13000) - CALL GWRITE (ITP,' ') - DO 120 I = 1,3 - WRITE (COUT,13100) - CALL FREEFM (ITR) - R(I,1) = RFREE(1) - R(I,2) = RFREE(2) - R(I,3) = RFREE(3) - 120 CONTINUE - DO 130 I = 1,3 - DO 130 J = 1,3 - R(I,J) = R(I,J)*WAVE - 130 CONTINUE - KISAVE = KI - KI = 'OM' - CALL ORMAT3 - KI = KISAVE - CALL WRBAS - ENDIF -C----------------------------------------------------------------------- -C CZ -- Circle Zero Corrections -C----------------------------------------------------------------------- - IF (KI .EQ. 'CZ' .OR. KI .EQ. 'BD') THEN - WRITE (COUT,14000) DTHETA,DOMEGA,DCHI,DPHI - CALL FREEFM (ITR) - DTHETA = RFREE(1) - DOMEGA = RFREE(2) - DCHI = RFREE(3) - DPHI = RFREE(4) - IF (KI .NE. 'BD') THEN - KI = ' ' - CALL WRBAS - RETURN - ENDIF - ENDIF -C----------------------------------------------------------------------- -C RO -- Re-Orientation reflections for use during GO -C----------------------------------------------------------------------- - IF (KI .EQ. 'RO' .OR. KI .EQ. 'BD') THEN - WRITE (COUT,15000) - CALL YESNO ('N',ANS) - NINTOR = 0 - REOTOL = 10.0 - IF (ANS .EQ. 'N') THEN - CALL WRBAS - ELSE - WRITE (COUT,15100) - CALL FREEFM (ITR) - NINTOR = IFREE(1) - IF (NINTOR .EQ. 0) NINTOR = 500 - WRITE (COUT,15200) - CALL FREEFM (ITR) - REOTOL = RFREE(1) - IF (REOTOL .EQ. 0.0) REOTOL = 0.1 - CALL WRBAS - CALL ALIGN - ENDIF - KI = ' ' - ENDIF -C----------------------------------------------------------------------- -C RR -- Reference Reflections -C----------------------------------------------------------------------- - IF (KI .EQ. 'RR' .OR. KI .EQ. 'BD') THEN - WRITE (COUT,16000) - CALL YESNO ('Y',ANS) - IF (ANS. EQ. 'Y') THEN - WRITE (COUT,16100) - CALL FREEFM (ITR) - NSTAN = 0 - NINTRR = IFREE(1) - IF (NINTRR .EQ. 0) NINTRR = 100 - WRITE (COUT,19000) - CALL GWRITE (ITP,' ') - 140 WRITE (COUT,19100) - CALL FREEFM (ITR) - IF (IFREE(1) .NE. 0 .OR. IFREE(2) .NE. 0 .OR. - $ IFREE(3) .NE. 0) THEN - NSTAN = NSTAN + 1 - IHSTAN(NSTAN) = IFREE(1) - IKSTAN(NSTAN) = IFREE(2) - ILSTAN(NSTAN) = IFREE(3) - GO TO 140 - ENDIF - ELSE - NSTAN = 0 - NINTRR = 0 - ENDIF - IF (KI .NE. 'BD') THEN - KI = ' ' - CALL WRBAS - RETURN - ENDIF - ENDIF -C----------------------------------------------------------------------- -C TM -- 2Theta min and max -C----------------------------------------------------------------------- - IF (KI .EQ. 'TM' .OR. KI .EQ. 'OM' .OR. KI .EQ. 'BD' .OR. - $ KI .EQ. 'M2' .OR. KI .EQ. 'M3' .OR. KI .EQ. 'MM' .OR. - $ KI .EQ. 'TO') THEN - IF (KI .EQ. 'TM' .OR. KI .EQ. 'OM' .OR. KI .EQ. 'BD' .OR. - $ THEMAX .LT. 1.0) THEN - WRITE (COUT,21000) THEMIN,THEMAX - CALL FREEFM (ITR) - IF (RFREE(1) .NE. 0.0) THEMIN = RFREE(1) - IF (RFREE(2) .NE. 0.0) THEMAX = RFREE(2) - IF (ITYPE .GE. 0 .AND. ITYPE .LE. 3) THEN - NPTS = (AS + BS*TAN(0.5*THEMAX/DEG) + CS)*STEPDG + 0.5 - IF (NPTS .GT. 499) THEN - WRITE (COUT,22000) - CALL GWRITE (ITP,' ') - ENDIF - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Optionally retain old matrix for M2, M3 or MM -C----------------------------------------------------------------------- - IF (KI .EQ. 'M2' .OR. KI .EQ. 'M3' .OR. KI .EQ. 'MM' .OR. - $ KI .EQ. 'TO') THEN - WRITE (COUT,24000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - DO 145 I = 1,3 - DO 145 J = 1,3 - R(I,J) = ROLD(I,J) - 145 CONTINUE - ELSE - DO 148 I = 1,3 - DO 148 J = 1,3 - R(I,J) = R(I,J)/WAVE - 148 CONTINUE - ENDIF - CALL GETPAR - DO 146 I = 1,3 - SANG(I) = SIN(CANG(I)/DEG) - CANG(I) = COS(CANG(I)/DEG) - SANGS(I) = SIN(CANGS(I)/DEG) - CANGS(I) = COS(CANGS(I)/DEG) - 146 CONTINUE - DO 147 I = 1,3 - DO 147 J = 1,3 - R(I,J) = R(I,J)*WAVE - 147 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Set new h,k,l max values -C----------------------------------------------------------------------- - S = 2.0*SIN((THEMAX*0.5)/DEG) - IHMAX = 1.0 + S/(APS(1)*SANGS(2)*SANG(3)*WAVE) - IKMAX = 1.0 + S/(APS(2)*SANGS(3)*SANG(1)*WAVE) - ILMAX = 1.0 + S/(APS(3)*SANGS(1)*SANG(2)*WAVE) - IF (KI .EQ. 'OM') ANS = 'Y' - IF (KI .NE. 'TM' .AND. KI .NE. 'BD' .AND. ANS .EQ. 'Y') - $ CALL SYSPNT - IF (KI .NE. 'BD') THEN - KI = ' ' - CALL WRBAS - RETURN - ENDIF - ENDIF -C----------------------------------------------------------------------- -C SE -- Systematic Extinction Conditions -C----------------------------------------------------------------------- - IF (KI .EQ. 'SE' .OR. KI .EQ. 'BD') THEN - WRITE (COUT,25000) - CALL FREEFM (ITR) - NCOND = IFREE(1) - IF (NCOND .NE. 0) THEN - WRITE (COUT,28000) - CALL GWRITE (ITP,' ') - DO 150 J = 1,NCOND - WRITE (COUT,13100) - CALL FREEFM (ITR) - ICOND(J) = IFREE(1) - IHS(J) = IFREE(2) - IKS(J) = IFREE(3) - ILS(J) = IFREE(4) - IR(J) = IFREE(5) - IS(J) = IFREE(6) - 150 CONTINUE - ENDIF - IF (KI .NE. 'BD') THEN - KI = ' ' - CALL WRBAS - RETURN - ENDIF - ENDIF -C----------------------------------------------------------------------- -C SD -- Scan Control Data -C -C Values of ITYPE on input & during running and IBSECT & ISCAN -C -C ITYPE -C Type of Operation Input Running IBSECT3 ISCAN -C -C Theta/2Theta b/P/b scan 0 0 0 0 -C Omega b/P/b scan 1 2 0 0 -C Compton or T.D.S. 2 0 0 1 -C Theta/2Theta Precision scan 3 1 0 3 -C Omega Precision scan 4 3 0 4 -C Peak Top Theta backgrounds 5 5 0 0 -C Peak Top Omega backgrounds 6 6 0 0 -C Economized Peak Top Theta 7 7 0 0 -C Economized Peak Top Omega 8 8 0 0 -C -C----------------------------------------------------------------------- - IF (KI .EQ. 'SD' .OR. KI .EQ. 'BD') THEN - WRITE (COUT,30000) - CALL FREEFM (ITR) - ITYPE = IFREE(1) - WRITE (COUT,30100) AS,BS,CS - CALL FREEFM (ITR) - IF (RFREE(1) .NE. 0.0) AS = RFREE(1) - IF (RFREE(2) .NE. 0.0) BS = RFREE(2) - IF (RFREE(3) .NE. 0.0) CS = RFREE(3) - IPRFLG = 1 - IF (ITYPE .LT. 4) THEN - WRITE (COUT,31000) - CALL FREEFM (ITR) - IPRFLG = IFREE(1) - ENDIF - ISCAN = 0 - IBSECT = 0 - ITEMP = ITYPE - IF (ITYPE .EQ. 1) ITEMP = 2 -C IF (ITYPE .EQ. 2) THEN -C ITEMP = 0 -C ISCAN = 1 -C ENDIF - IF (ITYPE .EQ. 2) THEN - ITEMP = 1 - ISCAN = 3 - ENDIF - IF (ITYPE .EQ. 3) THEN - ITEMP = 3 - ISCAN = 4 - ENDIF - IF (ITYPE .GE. 4) ITEMP = ITYPE + 1 - ITYPE = ITEMP - IBSECT = 0 -C WRITE (COUT,32000) -C CALL FREEFM (ITR) -C IBSECT = IFREE(1) - IF (ITYPE .LT. 4) THEN -C WRITE (COUT,33000) -C CALL FREEFM (ITR) -C SPEED = RFREE(1) -C IF (SPEED .EQ. 0.0) SPEED = 4.0 - ENDIF -C--------------------------------------------------------------------- -C Step and Preset for TRICS -C------------------------------------------------------------------- - OLDDSTEP = STEP - OLDPRE = PRESET - WRITE(COUT,33500)STEP,PRESET - CALL FREEFM(ITR) - STEP = RFREE(1) - PRESET = RFREE(2) - IF(STEP .LE. 0.)STEP = OLDSTEP - IF(PRESET .LE. 0)PRESET = OLDPRE - IF(STEP .LE. 0.)STEP = 0.02 - IF(PRESET .LE. 0)PRESET = 10000 -C----------------------------------------------------------------------- -C Horizontal aperture width for CAD-4 data collection -C----------------------------------------------------------------------- - IF (DFMODL .EQ. 'CAD4') THEN - CADSL = ICADSL/10.0 - WRITE (COUT,33100) CADSL - CALL FREEFM (ITR) - IF (RFREE(1) .EQ. 0.0) RFREE(1) = CADSL - ICADSL = 10*RFREE(1) + 0.5 - WRITE (COUT,33200) - CALL YESNO ('Y',ANS) - ICADSW = 1 - IF (ANS .EQ. 'N') ICADSW = 0 - ENDIF - STEPOF = 0.5 - IF (IPRFLG .EQ. 0) THEN - WRITE (COUT,34000) - CALL FREEFM (ITR) - STEPOF = RFREE(1) - IF (STEPOF .EQ. 0) STEPOF = 0.5 - ENDIF - IF (ITYPE .GE. 0 .AND. ITYPE .LE. 3) THEN - NPTS = (AS + BS*TAN(0.5*THEMAX/DEG) + CS)*STEPDG + 0.5 - IF (NPTS .GT. 499) THEN - WRITE (COUT,22000) - CALL GWRITE (ITP,' ') - ENDIF - ENDIF - IF (KI .NE. 'BD') THEN - KI = ' ' - CALL WRBAS - RETURN - ENDIF - ENDIF -C----------------------------------------------------------------------- -C TP -- Time and Precision control data -C----------------------------------------------------------------------- - IF (KI .EQ. 'TP' .OR. KI .EQ. 'BD') THEN - WRITE (COUT,35000) - CALL GWRITE (ITP,' ') - I = ITYPE - IF (ISCAN .EQ. 1) THEN - WRITE (COUT,37000) - CALL FREEFM (ITR) - FRAC = RFREE(1) - TMAX = RFREE(2) - PA = RFREE(3) - PM = RFREE(4) - ELSE - IF (I .EQ. 0 .OR. I .EQ. 2 .OR. I .EQ. 5 .OR. I .EQ. 6) THEN - WRITE (COUT,36000) - CALL FREEFM (ITR) - FRAC = RFREE(1) - IF (FRAC .EQ. 0.0) FRAC = 0.1 - IF (I .EQ. 5 .OR. I .EQ. 6) THEN - WRITE (COUT,35900) - CALL FREEFM (ITR) - PRESET = RFREE(1) - IF (PRESET .EQ. 0.0) PRESET = 1000.0 - ENDIF - ELSE IF (I .EQ. 1 .OR. I .EQ. 3) THEN - WRITE (COUT,36000) - CALL FREEFM (ITR) - FRAC = RFREE(1) - IF (FRAC .EQ. 0.0) FRAC = 0.1 - WRITE (COUT,37100) - CALL FREEFM (ITR) - TMAX = RFREE(1) - IF (TMAX .EQ. 0.0) TMAX = 240.0 - WRITE (COUT,37200) - CALL FREEFM (ITR) - PA = RFREE(1) - IF (PA .EQ. 0.0) PA = 0.02 - WRITE (COUT,37300) - CALL FREEFM (ITR) - PM = RFREE(1) - IF (PM .EQ. 0.0) PM = 0.10 - ELSE IF (I .EQ. 7 .OR. I .EQ. 8) THEN - WRITE (COUT,38000) - CALL FREEFM (ITR) - FRAC = RFREE(1) - TMAX = RFREE(2) - PA = RFREE(3) - ENDIF - ENDIF - IF (KI .NE. 'BD') THEN - KI = ' ' - CALL WRBAS - RETURN - ENDIF - ENDIF -C----------------------------------------------------------------------- -C DH -- DH Matrix Data -C----------------------------------------------------------------------- - IF (KI .EQ. 'DH' .OR. KI .EQ. 'BD') THEN - WRITE (COUT,40000) - CALL FREEFM (ITR) - NSEG = IFREE(1) - NMSEG = 1 - WRITE (COUT,42000) - CALL GWRITE (ITP,' ') - DO 160 J = 1,NSEG - WRITE (COUT,13100) - CALL FREEFM (ITR) - IHO(J) = IFREE(1) - IKO(J) = IFREE(2) - ILO(J) = IFREE(3) - IDH(J,1,1) = IFREE(4) - IDH(J,2,1) = IFREE(5) - IDH(J,3,1) = IFREE(6) - IDH(J,1,2) = IFREE(7) - IDH(J,2,2) = IFREE(8) - IDH(J,3,2) = IFREE(9) - IDH(J,1,3) = IFREE(10) - IDH(J,2,3) = IFREE(11) - IDH(J,3,3) = IFREE(12) - 160 CONTINUE -C----------------------------------------------------------------------- -C Read the B.Z. limits for COMPTON or TDS -C----------------------------------------------------------------------- - IF (ISCAN .EQ. 1) THEN - WRITE (COUT,44000) - CALL GWRITE (ITP,' ') - DO 170 J = 1,NSEG - WRITE (COUT,13100) - CALL FREEFM (ITR) - JA(J) = IFREE(1) - JB(J) = IFREE(2) - JC(J) = IFREE(3) - JMIN(J) = IFREE(4) - JMAX(J) = IFREE(5) - 170 CONTINUE - ENDIF - IF (KI .EQ. 'DH') CALL SYSPNT - IF (KI .NE. 'BD') THEN - KI = ' ' - RETURN - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Psi Scan Data -C----------------------------------------------------------------------- - IF (KI .EQ.'PS' .OR. KI .EQ. 'BD') THEN - WRITE (COUT,47000) - CALL FREEFM (ITR) - DPSI = RFREE(1) - PSIMIN = RFREE(2) - PSIMAX = RFREE(3) - IF (KI .NE. 'BD') THEN - KI = ' ' - RETURN - ENDIF - ENDIF -C----------------------------------------------------------------------- -C FR -- First Reflection Data -C----------------------------------------------------------------------- - IF (KI .EQ. 'FR' .OR. KI .EQ. 'BD') THEN - WRITE (COUT,49000) - CALL FREEFM (ITR) - IND(1) = IFREE(1) - IND(2) = IFREE(2) - IND(3) = IFREE(3) - WRITE (COUT,52000) - CALL FREEFM (ITR) - NREF = IFREE(1) - NMSEG = IFREE(2) - WRITE (COUT,53000) - CALL FREEFM (ITR) - NBLOCK = IFREE(1) - KI = ' ' - ENDIF - RETURN -10000 FORMAT (' Basic Data Input (Y) ',$) -11000 FORMAT (' Type the wavelength (',F7.5,') ',$) -12000 FORMAT (' There are no attenuators at present.') -12100 FORMAT (' The current attenuator coefficients are'/6F8.3) -12200 FORMAT (' Do you wish to change this (Y) ? ',$) -12300 FORMAT (' Type the new values ',$) -13000 FORMAT (' Type the Orientation Matrix on 3 lines.'/) -13100 FORMAT (' > ',$) -14000 FORMAT (' The current 2Theta, Omega, Chi and PHI zeroes are :--', - $ /4F7.3/, - $ ' Type the new values ',$) -15000 FORMAT (' Perform re-orientation during data collection (N) ? ',$) -15100 FORMAT (' Type the re-orientation frequency (500) ',$) -15200 FORMAT (' Type the re-orientation angular tolerance (0.1) ',$) -16000 FORMAT (' Measure reference reflections during data collection', - $ ' (Y) ? ',$) -16100 FORMAT (' Type the measurement frequency (100) ',$) -19000 FORMAT (' Type up to 6 sets of h,k,l values.') -19100 FORMAT (' h,k,l > ',$) -21000 FORMAT (' Type 2Thetamin and 2Thetamax (',F4.1,F6.1,') ',$) -22000 FORMAT (' **WARNING** More than 500 profile points possible.'/ - $ ' Reduce either 2theta(max), or the scan parameters', - $ ' AS and/or CS.') -24000 FORMAT (' You can keep the new matrix or retain the old one.'/ - $ ' Do you wish to keep the new matrix (Y) ? ',$) -25000 FORMAT (' Systematic Extinction Conditions'/ - $ ' Type the number of conditions ',$) -28000 FORMAT (' For each condition type the following :--'/ - $ ' A reflection class number 1 to 7,'/ - $ ' 1=00l 2=0k0 3=h00 4=0kl 5=h0l 6=hk0 7=hkl'/ - $ ' followed by the coefficients A to E of an equation'/ - $ ' Ah + Bk + Cl = Dn + E'/ - $ ' which is the condition for h,k,l to be present.') -30000 FORMAT (' Scan data : Scan type, As,Bs,Cs, Profile flag.'// - $ ' Scan type: 0 2Theta, 1 Omega,'/ - $ ' 2 2Theta precision, 3 Omega precision,'/ - $ ' 4 2Theta peak top, 5 Omega peak top,'/ - $ ' 6 2Theta econ. pktop, 7 Omega econ. pk top;'/ - $ ' Type the scan type (0) ',$) -30100 FORMAT (' Reflection width in degs is As + Bs*tan(theta) + Cs'/ - $ ' Type the new As, Bs, Cs (',3F6.3,') ',$) -31000 FORMAT (' Profile flag 0/1 for DO/DONT-DO profile analysis.'/ - $ ' Type the flag (0) ',$) -C32000 FORMAT (' Bisecting (0) or Parallel (1) mode ',$) -33000 FORMAT (' Scan speed in deg/min 2theta or omega (4) ',$) -33500 FORMAT (' Scan step in deg (',F8.3, - & ') and Scan Preset (',F12.3,') ', - & $) -33100 FORMAT (' Horizontal aperture width in mms (',F4.1,') ',$) -33200 FORMAT (' Try -,-,- refln if high-angle scan problems (Y) ? ',$) -34000 FORMAT (' Fraction of A & C to step off for profile analysis', - $ ' (0.5) ',$) -35000 FORMAT (' Time and Precision Parameters') -35900 FORMAT (' Type the peak-top measuring preset (1000.0) ',$) -36000 FORMAT (' Type the Background fraction (0.1) ',$) -37000 FORMAT (' Type Bkfrac,Qtime,PresetMax,Pa,Pm ',$) -37100 FORMAT (' Type the maximum preset/reflection (240) ',$) -37200 FORMAT (' Type the precision desired (0.02) ',$) -37300 FORMAT (' Type the minimum precision acceptable (0.10) ',$) -38000 FORMAT (' Max Counts, Sample & Max Time (secs) ',$) -40000 FORMAT (' Segment Data (DH Matrices)'/ - $ ' Type the number of segments ',$) -42000 FORMAT (' For each segment type the 12 integer values'/ - $ ' HOO KOO LOO D11 D21 D31 D12 D22 D32 D13 D23 D33') -44000 FORMAT (' B.Z. Limits for each segment'/ - $ ' JA,JB,JC,Jmin,Jmax ',$) -47000 FORMAT (' Psi Data: Dpsi,Psimin,Psimax') -49000 FORMAT (' First Reflection Data'/ - $ ' Type h,k,l for the reflection ',$) -52000 FORMAT (' Type the Reflection and Segment numbers ',$) -53000 FORMAT (' Type the Data record number ',$) - END -C----------------------------------------------------------------------- -C Get the crystal system pointer for an absolute matrix -C----------------------------------------------------------------------- - SUBROUTINE SYSPNT - INCLUDE 'COMDIF' - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - IF (LAUENO .NE. 0) THEN - ISYS = LAUENO - IF (LAUENO .GE. 4 .AND. LAUENO .LE. 5) ISYS = 4 - IF (LAUENO .GE. 6 .AND. LAUENO .LE. 7) ISYS = 6 - IF (LAUENO .GE. 8 .AND. LAUENO .LE. 12) ISYS = 5 - IF (LAUENO .GE. 13 .AND. LAUENO .LE. 14) ISYS = 7 - ELSE - CALL SYSANG (AP,SANG,CANG,ISYS,KI) - ENDIF - ISYSAN = ISYS - IF (ISYS .GT. 7) ISYS = 2 - WRITE (COUT,11000) ISYS - CALL FREEFM (ITR) - IF (IFREE(1) .NE. 0) ISYS = IFREE(1) - IF (ISYS .EQ. 2) THEN - IF (LAUENO .NE. 0) THEN - ISYS = NAXIS + 7 - ELSE - ISYS = ISYSAN - ENDIF - ENDIF - CALL SINMAT - RETURN -10000 FORMAT (' Select a number for the cell geometry to be used'/ - $ ' Triclinic 1 Monoclinic 2'/ - $ ' Orthorhombic 3 Tetragonal 4'/ - $ ' Hexagonal 5 Rhombohedral 6 Cubic 7') -11000 FORMAT (' Type your selection (',I1,') ',$) - END -C----------------------------------------------------------------------- -C -C Decide on the crystal system based on the cell-edges and angles -C The routine looks for differences between cell-edges which are less -C than a tolerance based on the cell-edge/500.0; and differnces -C between 90.0 and the cell angles which are less than TOLANG -C ICTE is the count of cell edges which are equal within TOLIJ; -C ICTA is the count of cell angles which are equal to 90 within TOLANG -C----------------------------------------------------------------------- - SUBROUTINE SYSANG (ABC,SANG,CANG,ISYS,KI) - DIMENSION ABC(3),SANG(3),CANG(3),ANG(3), - $ DEIJ(3),DAI(3),TOLEI(3),TOLEIJ(3) - CHARACTER KI*2 - RMULT = 1.0 - IF (KI .EQ. 'OP') RMULT = 3.0 - TOLANG = 0.1*RMULT -C----------------------------------------------------------------------- -C Make the angles from their sines and cosines; the 90 differences DA, -C and the cell-edge tolerances. -C----------------------------------------------------------------------- - DO 100 I = 1,3 - ANG(I) = 57.2958*ATAN2(SANG(I),CANG(I)) - DAI(I) = ABS(90.0 - ANG(I)) - TOLEI(I) = ABC(I)/500.0 - 100 CONTINUE -C----------------------------------------------------------------------- -C Make the cell-edge differences and their tolerances -C----------------------------------------------------------------------- - K = 0 - DO 110 I = 1,2 - DO 110 J = I+1,3 - K = K + 1 - DEIJ(K) = ABS(ABC(I) - ABC(J)) - TOLEIJ(K) = RMULT*SQRT(TOLEI(I)*TOLEI(I) + TOLEI(J)*TOLEI(J)) - 110 CONTINUE -C----------------------------------------------------------------------- -C Count the agreements etween cell-edges and angles -C----------------------------------------------------------------------- - ICTE = 0 - ICTA = 0 - DO 120 I = 1,3 - IF (DEIJ(I) .LT. TOLEIJ(I)) ICTE = ICTE + 1 - IF (DAI(I) .LT. TOLANG) ICTA = ICTA + 1 - 120 CONTINUE -C----------------------------------------------------------------------- -C Set ISYS according to ICTE and ICTA -C----------------------------------------------------------------------- - ISYS = 0 -C----------------------------------------------------------------------- -C ICTE = 0 and ICTA = 0 -- Triclinic -C----------------------------------------------------------------------- - IF (ICTE .EQ. 0 .AND. ICTA .EQ. 0) ISYS = 1 -C----------------------------------------------------------------------- -C ICTE = 0 and ICTA = 2 -- Monoclinic -C----------------------------------------------------------------------- - 130 IF (ICTE .EQ. 0 .AND. ICTA .EQ. 2) THEN - IF (DAI(1) .GT. TOLANG) ISYS = 8 - IF (DAI(2) .GT. TOLANG) ISYS = 9 - IF (DAI(3) .GT. TOLANG) ISYS = 10 - ENDIF -C----------------------------------------------------------------------- -C ICTE = 0 and ICTA = 3 -- Orthorhombic -C----------------------------------------------------------------------- - IF (ICTE .EQ. 0 .AND. ICTA .EQ. 3) ISYS = 3 -C----------------------------------------------------------------------- -C ICTE = 1 and ICTA = 3 -- Tetragonal -C----------------------------------------------------------------------- - IF (ICTE .EQ. 1 .AND. ICTA .EQ. 3) ISYS = 4 -C----------------------------------------------------------------------- -C ICTE = 1 and ICTA = 2 -- Hexagonal (maybe monoclinic) -C----------------------------------------------------------------------- - IF (ICTE .EQ. 1 .AND. ICTA .EQ. 2) THEN - IF (ABS(120.0 - ANG(3)) .LT. TOLANG) THEN - ISYS = 5 - ELSE - ICTE = 0 - GO TO 130 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C ICTE = 3 and ICTA = 0 -- Rhombohedral -C----------------------------------------------------------------------- - IF (ICTE .EQ. 3 .AND. ICTA .EQ. 0) ISYS = 6 -C----------------------------------------------------------------------- -C ICTE = 3 and ICTA = 3 -- Cubic -C----------------------------------------------------------------------- - IF (ICTE .EQ. 3 .AND. ICTA .EQ. 3) ISYS = 7 -C----------------------------------------------------------------------- -C Safety - just in case ! -C----------------------------------------------------------------------- - IF (ISYS .EQ. 0) ISYS = 1 - RETURN - END diff --git a/difrac/begin.f b/difrac/begin.f deleted file mode 100644 index a26b7876..00000000 --- a/difrac/begin.f +++ /dev/null @@ -1,436 +0,0 @@ -C----------------------------------------------------------------------- -C This subroutine reads the info necessary to start the data collection -C at the start of data collection and at each new segment -C Modified to give output to ITP-->SICS, MK -C----------------------------------------------------------------------- - SUBROUTINE BEGIN - INCLUDE 'COMDIF' - DIMENSION INDX(3),ISET(25),DHC(3,3),JUNKP(200),FDH(3,3), - $ FDHI(3,3) - EQUIVALENCE (ACOUNT(301),JUNKP(1)) - IRES = 0 - 100 IF (ISEG .EQ. 0) THEN - IF (IAUTO .NE. 1) THEN -C----------------------------------------------------------------------- -C GO entry point -C----------------------------------------------------------------------- - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Save the Basic Data in the first 3 blocks of the IDATA file -C----------------------------------------------------------------------- - CALL WRBAS - IF (ILN .EQ. 1) THEN - WRITE (COUT,11000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') ILN = 0 - ENDIF -C----------------------------------------------------------------------- -C Is this run manual? -C----------------------------------------------------------------------- - IF (IKO(5) .NE. -777) THEN - WRITE (COUT,12000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - NB = 1 - GO TO 200 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Was the last automatic run stopped by K or Q ? -C----------------------------------------------------------------------- - IKO(5) = -777 - IAUTO = 1 - CALL WRBAS -C----------------------------------------------------------------------- -C IHO(5) = 0/1 Normal sequence/Pointer mode -C IHO(6) = Sequence number of the present set in the Pointer mode -C IHO(7) = 0/1 Do not/Do measure the translation-element absences -C IHO(8),IKO(8),ILO(8) = Indices of current reflection -C IKO(5) = -777 if DH matrices were NOT typed in -C IKO(6) = 0/1 Acentric/Centric Space-group -C----------------------------------------------------------------------- - IHO(5) = 0 - ZERO = 0 - SAVE = NBLOCK - READ (IID,REC=9) IRES,IND,NSET,IPOINT,IHO(5) - WRITE (IID,REC=9) ZERO - NBLOCK = SAVE -C----------------------------------------------------------------------- -C Propose an automatic restart -C----------------------------------------------------------------------- - IF (IRES .EQ. 1) THEN - WRITE (COUT,13000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') GO TO 170 - ENDIF -C----------------------------------------------------------------------- -C Call the space-group generation routines -C----------------------------------------------------------------------- - IOUT = -1 - CALL SPACEG (IOUT,1) - ENDIF -C----------------------------------------------------------------------- -C The information written by the space-group routines is :-- -C LATCEN Lattice-centering code -C 1=P 2=A 3=B 4=C 5=I 6=F 7=R -C NSYM Number of matrices generated -C JRT The matrices generated -C IPOINT The number of set pointers entered -C ICENT 0/1 Acentric/Centric -C JUNKP The set pointers -C LAUENO The Laue group code -C 1=-1, 2=2/m, 3=mmm, 4=4/m, 5=4/mmm, 6=R-3R, 7=R-3mR -C 8=-3, 9=-31m, 10=-3m1, 11=6/m, 12=6/mmm, 13=m3, 14=m3m -C----------------------------------------------------------------------- - NUMDH = NSEG - IPOINT = NSET - IKO(6) = ICENT -C----------------------------------------------------------------------- -C Constrain the orientation matrix according to the Laue group -C----------------------------------------------------------------------- - IF ( LAUENO .GE. 13) ISYS = 7 - IF (LAUENO .GE. 8 .AND. LAUENO .LT. 13) ISYS = 5 - IF (LAUENO .GE. 6 .AND. LAUENO .LT. 8) ISYS = 6 - IF (LAUENO .LT. 6) THEN - ISYS = LAUENO - IF (LAUENO .EQ. 5) ISYS = 4 - IF (LAUENO .EQ. 2) ISYS = 7 + NAXIS - ENDIF - CALL SINMAT -C----------------------------------------------------------------------- -C Propose a package deal. -C Start at Refln 1, Segment 1, Set 1, at Record 20 -C----------------------------------------------------------------------- - WRITE (COUT,14000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - NREF = 1 - NMSEG = 1 - NSET = 1 - IPOINT = 1 - NBLOCK = 20 - IND(1) = 0 - IND(2) = 0 - IND(3) = 0 - ELSE -C----------------------------------------------------------------------- -C Get detailed information from the terminal -C----------------------------------------------------------------------- - WRITE (COUT,15000) - CALL FREEFM (ITR) - IND(1) = IFREE(1) - IND(2) = IFREE(2) - IND(3) = IFREE(3) - WRITE (COUT,16000) - CALL FREEFM (ITR) - NREF = IFREE(1) -C----------------------------------------------------------------------- -C Pointer mode -C----------------------------------------------------------------------- - IF (IHO(5) .NE. 0) THEN - 110 WRITE (COUT,17000) - CALL FREEFM (ITR) - ITEMP1 = IFREE(1) - IF (ITEMP1 .LT. 0) THEN - WRITE (COUT,18000) - CALL GWRITE (ITP,' ') - GO TO 110 - ENDIF - WRITE (COUT,19000) - CALL FREEFM (ITR) - NMSEG = IFREE(1) -C write (6,99991) itemp1,ipoint -C99991 format (' itemp1,ipoint',2i5) - IF (ITEMP1 .LT. IPOINT) IPOINT = ITEMP1 - ELSE -C----------------------------------------------------------------------- -C Normal sequence 1,-1,2,-2.... -C----------------------------------------------------------------------- - WRITE (COUT,20000) - CALL FREEFM (ITR) - NSET = IFREE(1) - NMSEG = IFREE(2) - ENDIF - WRITE (COUT,21000) - CALL FREEFM (ITR) - NBLOCK = IFREE(1) -C----------------------------------------------------------------------- -C Find the equivalent in Set 1 of the starting reflection -C----------------------------------------------------------------------- - IF (IHO(5) .NE. 0) THEN - READ (IID,REC=4) (JUNK,J = 1,52),(JUNKP(J),J = 1,25) -C write (6,99992) iho(5),ipoint,junkp(ipoint) -C99992 format (' iho(5),ipoint,junkp ',3i5) - NSET = JUNKP(IPOINT) - ENDIF - MSET = 1 - IF (NSET .LT. 0) MSET = -1 - NSET = NSET*MSET - DO 120 I = 1,3 - DO 120 J = 1,3 - FDH(I,J) = JRT(I,J,NSET)*MSET - 120 CONTINUE - CALL MATRIX (FDH,FDHI,FDHI,FDHI,'INVERT') - DO 130 J = 1,3 - JUNKP(J) = 0 - DO 130 I = 1,3 - JUNKP(J) = JUNKP(J)+IND(I)*FDHI(I,J) - 130 CONTINUE -C----------------------------------------------------------------------- -C Store its indices in IND -C----------------------------------------------------------------------- - DO 140 I = 1,3 - IND(I) = JUNKP(I) - 140 CONTINUE - NSET = NSET*MSET - ENDIF -C----------------------------------------------------------------------- -C Are there lattice-mode absences ? -C NCOND = -1 if lattice absences are to be applied -C = 0 if no lattice absences -C > 0 if specified absences (SE) to be applied -C----------------------------------------------------------------------- - NCOND = 0 - IF (LATCEN .NE. 1) THEN - WRITE (COUT,22000) - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'N') NCOND = -1 - ENDIF -C----------------------------------------------------------------------- -C Are there translation elements and if so, are they to be measured ? -C----------------------------------------------------------------------- - DO 150 M = 1,NSYM - DO 150 I = 1,3 - IF (JRT(I,4,M) .NE. 0) THEN - IHO(7) = 0 - WRITE (COUT,23000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') IHO(7) = 1 - GO TO 160 - ENDIF - 150 CONTINUE - IHO(7) = 0 - 160 WRITE (COUT,24000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Attach the profile file to unit 7 if wanted -C----------------------------------------------------------------------- - 170 CALL RSW (9,J) - IF (J .EQ. 1) THEN - WRITE (COUT,25000) - PRNAME = 'DONT DO IT'//' ' - CALL ALFNUM (PRNAME) - IF (PRNAME .EQ. ' ') PRNAME = 'PROFL7.DAT' - IDREC = 32*IBYLEN - IPR = IOUNIT(7) - STATUS = 'DU' - CALL IBMFIL (PRNAME,IPR,IDREC,STATUS,IERR) - CALL LENFIL (IPR,NPR) - ENDIF -C----------------------------------------------------------------------- -C Everything is now known, start here in the automatic mode -C----------------------------------------------------------------------- - READ (IID,REC=4) LATCEN,NUMDH,(IHO(I),IKO(I),ILO(I), - $ ((IDH(I,J,M),J = 1,3),M = 1,3),I = 1,4),NSYM, - $ LSET,ISET,LAUENO,NAXIS,ICENT - READ (IID,REC=5) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 1, 6) - READ (IID,REC=6) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 7,12) - READ (IID,REC=7) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 13,18) - READ (IID,REC=8) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 19,24) - NSEG = NUMDH - MSET = 1 -C----------------------------------------------------------------------- -C Pointer mode -C----------------------------------------------------------------------- - IF (IHO(5) .NE. 0) THEN - IF (NMSEG .GT. NSEG) THEN - NMSEG = 1 - IPOINT = IPOINT+1 - ENDIF - NSET = ISET(IPOINT) - IHO(6) = IPOINT - ENDIF - IF (NSET .LE. 0) THEN - MSET = -1 - NSET = -NSET - ENDIF - DO 180 I = 1,3 - DO 180 J = 1,3 - IDH(8,I,J) = JRT(I,J,NSET)*MSET - 180 CONTINUE - NSET = NSET*MSET -C----------------------------------------------------------------------- -C Start here in the Manual Mode. Set record pointer NB to 1 and -C re-orientation reflection counter NREFOR to NREF -C----------------------------------------------------------------------- - NB = 1 - NREFOR = NREF - ENDIF -C----------------------------------------------------------------------- -C Sequence to set new segment parameters -C----------------------------------------------------------------------- - 200 IF (IAUTO .EQ. 1) THEN -C----------------------------------------------------------------------- -C Calculate and output the data collection info in the automatic mode -C----------------------------------------------------------------------- - DO 210 M = 1,3 - DO 210 J = 1,3 - DHC(J,M) = 0 - DO 210 I = 1,3 - DHC(J,M) = DHC(J,M)+IDH(NMSEG,I,M)*IDH(8,I,J) - 210 CONTINUE - NG = NMSEG - INH = IHO(NG)*IDH(8,1,1)+IKO(NG)*IDH(8,2,1)+ILO(NG)*IDH(8,3,1) - INK = IHO(NG)*IDH(8,1,2)+IKO(NG)*IDH(8,2,2)+ILO(NG)*IDH(8,3,2) - INL = IHO(NG)*IDH(8,1,3)+IKO(NG)*IDH(8,2,3)+ILO(NG)*IDH(8,3,3) - WRITE (COUT,26000) NSET,NMSEG,INH,INK,INL,DHC - CALL GWRITE(ITP,' ') - ENDIF -C----------------------------------------------------------------------- -C Select the new segment -C----------------------------------------------------------------------- - ISEG = 0 - DO 220 I = 1,3 - DO 220 J = 1,3 - NDH(I,J) = IDH(NMSEG,I,J) - 220 CONTINUE -C----------------------------------------------------------------------- -C Find the starting reflection -C----------------------------------------------------------------------- - IH0 = IHO(NMSEG) - IK0 = IKO(NMSEG) - IL0 = ILO(NMSEG) - IF (IND(1) .EQ. 0 .AND. IND(2) .EQ. 0 .AND. IND(3) .EQ. 0) THEN - IND(1) = IH0 - IND(2) = IK0 - IND(3) = IL0 - ENDIF -C----------------------------------------------------------------------- -C Invert the current segment -C----------------------------------------------------------------------- - DO 230 I = 1,3 - DO 230 J = 1,3 - FDH(I,J) = NDH(I,J) - 230 CONTINUE - CALL MATRIX (FDH,FDHI,FDHI,FDHI,'INVERT') - DO 240 I = 1,3 - INDX(I) = FDHI(I,1)*(IND(1) - IH0) + - $ FDHI(I,2)*(IND(2) - IK0) + - $ FDHI(I,3)*(IND(3) - IL0) - IF (INDX(I) .GE. 0) INDX(I) = INDX(I) + 0.5 - IF (INDX(I) .LT. 0) INDX(I) = INDX(I) - 0.5 - 240 CONTINUE -C----------------------------------------------------------------------- -C Calculate the starting reflection matrix -C----------------------------------------------------------------------- - IFSHKL(1,1) = NDH(1,1)*INDX(1) + IH0 - IFSHKL(2,1) = NDH(2,1)*INDX(1) + IK0 - IFSHKL(3,1) = NDH(3,1)*INDX(1) + IL0 - DO 250 I = 1,3 - IFSHKL(I,2) = NDH(I,2)*INDX(2) + IFSHKL(I,1) - IFSHKL(I,3) = NDH(I,3)*INDX(3) + IFSHKL(I,2) - 250 CONTINUE - IH = IFSHKL(1,3) - IK = IFSHKL(2,3) - IL = IFSHKL(3,3) -C----------------------------------------------------------------------- -C Set IUPDWN for incrementing the indices -C IUPDWN = 1 if INDX(2) is even -C IUPDWN =-1 if INDX(2) is odd -C----------------------------------------------------------------------- - I = INDX(2) - IF (I .LT. 0) I = -I - I = I-2*(I/2) - IUPDWN = 1 - IF (I .NE. 0) IUPDWN = -1 - ISTOP = 0 - IF (IH .EQ. IFSHKL(1,2) .AND. IK .EQ. IFSHKL(2,2) .AND. - $ IL .EQ. IFSHKL(3,2) .AND. IUPDWN .EQ. -1) ISTOP = 1 -C----------------------------------------------------------------------- -C Find the indices of the 1st refln in the current set for printing -C----------------------------------------------------------------------- - IF (IAUTO .EQ. 1) THEN - IHO(8) = IH - IKO(8) = IK - ILO(8) = IL - ITEMP1 = IH*IDH(8,1,1) + IK*IDH(8,2,1) + IL*IDH(8,3,1) - ITEMP2 = IH*IDH(8,1,2) + IK*IDH(8,2,2) + IL*IDH(8,3,2) - ITEMP3 = IH*IDH(8,1,3) + IK*IDH(8,2,3) + IL*IDH(8,3,3) - IH = ITEMP1 - IK = ITEMP2 - IL = ITEMP3 - ENDIF -C----------------------------------------------------------------------- -C If Psi rotation is asked for, check if it is rrrreally wanted! -C----------------------------------------------------------------------- - IF (DPSI .NE. 0.0) THEN - WRITE (COUT,27000) - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'N') DPSI = 0.0 - ENDIF -C----------------------------------------------------------------------- -C Write all this to IDATA just for safety -C----------------------------------------------------------------------- - CALL WRBAS -C----------------------------------------------------------------------- -C Do re-orientation if wanted, but not at the very start -C----------------------------------------------------------------------- - IF (NINTOR .NE. 0 .AND. NREF .NE. 0) THEN - NDIFF = NREF - NREFOR - I = NDIFF - NINTOR*(NDIFF/NINTOR) - IF (I .EQ. 0) THEN - IORNT = 1 - CALL ALIGN - CALL LSORMT - ENDIF - IORNT = 0 - ENDIF -C----------------------------------------------------------------------- -C Measure standards in STDMES and then data proper -C----------------------------------------------------------------------- - CALL STDMES - IF (KQFLAG .EQ. 1) THEN - CALL GOLOOP - IF (KI .EQ. 'GO') GO TO 100 -C----------------------------------------------------------------------- -C This is the return to KEYS -C----------------------------------------------------------------------- - ELSE - KI = ' ' - ENDIF - RETURN -10000 FORMAT (' Start Data Collection (Y) ? ',$) -11000 FORMAT (' Is this a Low-Temperature run (Y) ? ',$) -12000 FORMAT (' Use the DH matrices already typed in (Y) ? ',$) -13000 FORMAT (' Is this an Automatic Restart (Y) ? ',$) -14000 FORMAT (' Start at Reflection 1, Segment 1, Set 1, Record 20', - $ ' (Y) ? ',$) -15000 FORMAT (' Type the indices of the Starting Reflection ',$) -16000 FORMAT (' Type the reflection number ',$) -17000 FORMAT (' Type the sequence number of the starting set ',$) -18000 FORMAT (' The sequence number cannot be negative.'/ - $ ' The sequence number is the position of the starting', - $ ' set in the'/ - $ ' previously typed in list of set numbers.') -19000 FORMAT (' Type the segment number ',$) -20000 FORMAT (' Type the set and segment numbers ',$) -21000 FORMAT (' Type the Idata record number ',$) -22000 FORMAT (' Measure the lattice-mode absences (N) ? ',$) -23000 FORMAT (' Measure the Translation-element absences (Y) ? ',$) -24000 FORMAT (' Force the shutter open now if necessary.'/ - $ ' Is everything OK (Y) ? ',$) -25000 FORMAT (' Type the name of the profile file (PROFL7.DAT) ',$) -26000 FORMAT (///' Set ',I3,4X,'Segment ',I2,4X,'Matrix', - $ 3I3,4X,3(3F3.0,2X)) -27000 FORMAT (' Psi rotation is turned on.', - $ ' Do you really want it (N) ? ',$) - END diff --git a/difrac/bigchi.f b/difrac/bigchi.f deleted file mode 100644 index 24fdc4ae..00000000 --- a/difrac/bigchi.f +++ /dev/null @@ -1,146 +0,0 @@ -C----------------------------------------------------------------------- -C -C Find Reflections with Chi Values .GT. CHIMIN which are suitable for -C Psi Rotation, particularly on Kappa geometry machines -C -C The routine does the following :-- -C 1. Finds the exact indices for the Euler angles -C theta = THTMAX, omega = 0, chi = 90, phi = 0. -C 2. Finds the exact, i.e fractional, min/max values of h,k,l for -C theta = THTMAX, omega = 0, chi = 80, phi = 0 to 350 in steps -C of 10 degrees. -C 3. Searches from theta = 0 to THTMAX in steps of 0.01 in sin(theta), -C for reflections with chi greater than CHIMIN, using h,k,l limits -C which are proportional to those found at THTMAX in step 2. -C -C----------------------------------------------------------------------- - SUBROUTINE BIGCHI - INCLUDE 'COMDIF' - DIMENSION RHKL(3),RMNMXH(2,3),MNMXH(2,3),X(3),RM1(3,3) - EQUIVALENCE (RHKL(1),RH),(RHKL(2),RK),(RHKL(3),RL), - $ (MNMXH(1,1),MINH),(MNMXH(2,1),MAXH), - $ (MNMXH(1,2),MINK),(MNMXH(2,2),MAXK), - $ (MNMXH(1,3),MINL),(MNMXH(2,3),MAXL), - $ (X(1),X1),(X(2),X2),(X(3),X3) -C----------------------------------------------------------------------- -C Get CHIMIN and THTMAX -C----------------------------------------------------------------------- - WRITE (COUT,10000) - CALL FREEFM (ITR) - CHIMIN = RFREE(1) - IF (CHIMIN .EQ. 0.0) CHIMIN = 80.0 - WRITE (COUT,11000) THEMAX - CALL FREEFM (ITR) - THTMAX = RFREE(1) - IF (THTMAX .EQ. 0.0) THTMAX = THEMAX -C----------------------------------------------------------------------- -C Calculate h,k,l for THTMAX,0,90,0 -C----------------------------------------------------------------------- - CALL MATRIX (R,RM1,RM1,RM1,'INVERT') - THETA = 0.5*THTMAX/DEG - OMEGA = 0.0 - CHI = 90.0/DEG - PHI = 0.0 - CALL ANGTOH (RH,RK,RL,RM1) - WRITE (COUT,12000) THTMAX,RH,RK,RL,CHIMIN - CALL GWRITE (ITP,' ') - WRITE (LPT,12000) THTMAX,RH,RK,RL,CHIMIN -C----------------------------------------------------------------------- -C Find the min and max h,k and l at theta = 90 and chi = 80 for -C phi from 0 to 350 in steps of 10deg -C----------------------------------------------------------------------- - DO 100 I = 1,3 - RMNMXH(1,I) = 10000 - RMNMXH(2,I) = -10000 - 100 CONTINUE - THETA = 90.0/DEG - OMEGA = 0.0 - CHI = CHIMIN/DEG - DO 110 IPHI = 0,350,10 - PHI = IPHI/DEG - CALL ANGTOH (RH,RK,RL,RM1) - DO 105 I = 1,3 - IF (RHKL(I) .LT. RMNMXH(1,I)) RMNMXH(1,I) = RHKL(I) - IF (RHKL(I) .GT. RMNMXH(2,I)) RMNMXH(2,I) = RHKL(I) - 105 CONTINUE - 110 CONTINUE -C----------------------------------------------------------------------- -C Loop over the min/max indices for shells of 0.01 sin(theta) from -C theta 0.0 to THTMAX/2.0 -C----------------------------------------------------------------------- - IHSAVE = IH - IKSAVE = IK - ILSAVE = IL - STMIN2 = 0.0 - STMAX = SIN(0.5*THTMAX/DEG) - NTHETA = 1.0 + STMAX/0.01 - DO 150 N = 1,NTHETA - SMAX = N*0.01 - IF (SMAX .GT. STMAX) SMAX = STMAX - DO 115 J = 1,3 - DO 115 I = 1,2 - TEMP = SMAX*RMNMXH(I,J) - ROUND = 0.5 - IF (TEMP .LT. 0.0) ROUND = -0.5 - MNMXH(I,J) = TEMP + ROUND - 115 CONTINUE - STMAX2 = 4.0*SMAX*SMAX - OMEGA = 0.0 - DO 140 JH = MINH,MAXH - DO 130 JK = MINK,MAXK - DO 120 JL = MINL,MAXL - IF (JH .NE. 0 .OR. JK .NE. 0 .OR. JL .NE. 0) THEN - X1 = JH*R(1,1) + JK*R(1,2) + JL*R(1,3) - X2 = JH*R(2,1) + JK*R(2,2) + JL*R(2,3) - X3 = JH*R(3,1) + JK*R(3,2) + JL*R(3,3) - SUM = X1*X1 + X2*X2 + X3*X3 - STHT2 = SUM - IF (STHT2 .GE. STMIN2 .AND. STHT2 .LT. STMAX2) THEN - IPRVAL = 0 - IH = JH - IK = JK - IL = JL - CALL DEQHKL (NHKL,0) - IF (IVALID .EQ. 0) THEN - CALL CALANG (X) - IF (CHI .GT. CHIMIN) THEN - WRITE (LPT,13000) JH,JK,JL,THETA,OMEGA,CHI,PHI - WRITE (COUT,13000) JH,JK,JL,THETA,OMEGA,CHI,PHI - CALL GWRITE (ITP,' ') - ENDIF - ENDIF - ENDIF - ENDIF - 120 CONTINUE - 130 CONTINUE - 140 CONTINUE - STMIN2 = STMAX2 - 150 CONTINUE - IH = IHSAVE - IK = IKSAVE - IL = ILSAVE - KI = ' ' - RETURN -10000 FORMAT (/10X,'Search for Reflections with High Chi Values'// - $ ' Type the minimum acceptable chi value (80) ',$) -11000 FORMAT (' Type 2theta(max) (',F5.1,') ',$) -12000 FORMAT (' h,k,l for 2theta',F8.3,', Chi 90 ',3F8.3/ - $ ' Reflections with chi greater than',F8.3/ - $ ' h k l 2theta omega chi phi') -13000 FORMAT (3I4,4F9.3) - END -C----------------------------------------------------------------------- -C Subroutine to compute h,k,l from Euler angles with omega = 0 -C----------------------------------------------------------------------- - SUBROUTINE ANGTOH (RH,RK,RL,RM1) - INCLUDE 'COMDIF' - DIMENSION RM1(3,3) - TEMP = 2.0*SIN(THETA) - X1 = TEMP*COS(CHI)*COS(PHI) - X2 = TEMP*COS(CHI)*SIN(PHI) - X3 = TEMP*SIN(CHI) - RH = RM1(1,1)*X1 + RM1(1,2)*X2 + RM1(1,3)*X3 - RK = RM1(2,1)*X1 + RM1(2,2)*X2 + RM1(2,3)*X3 - RL = RM1(3,1)*X1 + RM1(3,2)*X2 + RM1(3,3)*X3 - RETURN - END diff --git a/difrac/blind.f b/difrac/blind.f deleted file mode 100644 index 3f0430e7..00000000 --- a/difrac/blind.f +++ /dev/null @@ -1,727 +0,0 @@ -C-------------------------------------------------------------------- -C Index Reflections found by OC -C -C The algorithm used is that described by R.A.Jacobsen in the -C program BLIND (Bravais Lattice and INdex Determination), which is -C described in Ames Lab Report IS-3469, September 1974. -C -C Adapted by P.S.White and E.J.Gabe April, 92. -C-------------------------------------------------------------------- - SUBROUTINE BLIND - INCLUDE 'COMDIF' - DIMENSION XX(NSIZE),YY(NSIZE),ZZ(NSIZE) - WRITE (COUT,10000) - CALL FREEFM (ITR) - ISELEC = IFREE(1) - IF (ISELEC .EQ. 0) THEN - ISELEC = 1 - ELSE IF (ISELEC .EQ. 2) THEN - CALL EDLIST - WRITE (COUT,11000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') ISELEC = 1 - ENDIF - IF (ISELEC .EQ. 1) THEN - IVALID = 0 - DD = 0.080 - DJ = 0.0 - MJ = 0 -C-------------------------------------------------------------------- -C Input the data and prepare the working X, Y, Zs. -C-------------------------------------------------------------------- - CALL PRPXYZ (XX,YY,ZZ,LMT) -C-------------------------------------------------------------------- -C Do the indexing and reduction to a minimum cell -C-------------------------------------------------------------------- - IF (IVALID .EQ. 0) THEN - CALL INDRED (LMT,XX,YY,ZZ,DD,DJ,MJ) - IF (IVALID .EQ. 0) CALL LISTER - ENDIF - ENDIF - KI = ' ' - RETURN -10000 FORMAT (' Index Reflections and derive an Orientation Matrix'/ - $ ' 1) Index reflections in the list from PK '/ - $ ' 2) List and edit the reflections'/ - $ ' 3) Cancel'// - $ ' Enter option (1) ',$) -11000 FORMAT (' Do you want to index the reflections (Y) ? ',$) - END -C-------------------------------------------------------------------- -C Do the actual indexing -C-------------------------------------------------------------------- - SUBROUTINE INDRED (LMT,XX,YY,ZZ,DD,DJ,MJ) - INCLUDE 'COMDIF' - DIMENSION B(3,3) - DIMENSION XX(NSIZE),YY(NSIZE),ZZ(NSIZE), - $ XH(3,NSIZE),A(3,3),JH(3,NSIZE) - EQUIVALENCE (BLINDR,B) - IZ = IABS(MJ) - 100 DO 110 J = 1,3 - B(1,J) = XX(J) - B(2,J) = YY(J) - B(3,J) = ZZ(J) - 110 CONTINUE - CALL INVERT (B,A,D) - DO 120 J = 1,3 - DO 120 I = 1,LMT - XH(J,I) = A(J,1)*XX(I) + A(J,2)*YY(I) + A(J,3)*ZZ(I) - 120 CONTINUE - MM = 0 - CALL TRYIND (XH,LMT,DD,IZ) - IF (DD .EQ. 0.100) THEN - DD = -0.010 - GO TO 100 - ENDIF - CALL COMPB (XX,YY,ZZ,B,XH,LMT) - CALL REDCL1 (B,A) - DO 140 I = 4,LMT - DO 130 J = 1,3 - XH(J,I) = A(J,1)*XX(I) + A(J,2)*YY(I) + A(J,3)*ZZ(I) - IF (XH(J,I) .LT. 0.0) LB = XH(J,I) - 0.5 - IF (XH(J,I) .GE. 0.0) LB = XH(J,I) + 0.5 - IF (ABS(XH(J,I) - LB) .GT. DD) MM = 1 - JH(J,I) = LB - 130 CONTINUE - 140 CONTINUE - IF (MM .EQ. 1) GO TO 100 - IF (MJ .LT. 0) THEN - CALL INVERT (B,A,D) - IF ((DJ + 0.1) .GT. (1.0/ABS(D)) .AND. - $ (DJ - 0.1) .LT. (1.0/ABS(D))) GO TO 100 - ENDIF - CALL CALCEL (B,A,D) - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - DO 150 I = 4,LMT,4 - WRITE (COUT,11000) (JH(1,J),JH(2,J),JH(3,J),J = I,I+3) - CALL GWRITE (ITP,' ') - 150 CONTINUE - WRITE (COUT,12000) - CALL GWRITE (ITP,' ') - WRITE (COUT,13000) ((B(I,J),J = 1,3),I = 1,3) - CALL GWRITE (ITP,' ') - RETURN -10000 FORMAT (/4(' h k l ')) -11000 FORMAT (4(3I4,4X)) -12000 FORMAT (/' Orientation Matrix:') -13000 FORMAT (3F10.6/3F10.6/3F10.6/) - END -C-------------------------------------------------------------------- -C Reduce the cell via REDCL2 -C-------------------------------------------------------------------- - SUBROUTINE REDCL1 (B,A) - INCLUDE 'COMDIF' - DIMENSION B(3,3),A(3,3),W(4),AB(3,3),V(6),L(7) - W(1) = 1.0E9 - W(2) = W(1) - W(3) = W(1) - W(4) = W(1) - CALL INVERT (B,AB,D) - CALL REDCL2 (AB,V,L) - DO 120 I = 1,3 - DO 110 J = 1,3 - IF (V(I) .LT. W(J)) THEN - DO 100 K = 3,J,-1 - W(K+1) = W(K) - L(K+1) = L(K) - 100 CONTINUE - W(J) = V(I) - L(J) = I - GO TO 120 - ENDIF - 110 CONTINUE - 120 CONTINUE - DO 130 I = 1,3 - A(3,I) = AB(L(1),I) - A(1,I) = AB(L(2),I) - A(2,I) = AB(L(3),I) - 130 CONTINUE - W(4) = V(5) - V(5) = V(6) - V(6) = W(4) - IF (V(L(1) + L(2) + 1) .GT. 0.0) THEN - DO 140 I = 1,3 - A(1,I) = -A(1,I) - V(L(1) + L(2) + 1) = -V(L(1) + L(2) + 1) - V(L(2) + L(3) + 1) = -V(L(2) + L(3) + 1) - 140 CONTINUE - ENDIF - IF (V(L(3) + L(1) + 1) .GT. 0.0) THEN - DO 150 I = 1,3 - A(2,I) = -A(2,I) - V(L(3) + L(1) + 1) = -V(L(3) + L(1) + 1) - V(L(2) + L(3) + 1) = -V(L(2) + L(3) + 1) - 150 CONTINUE - ENDIF - CALL INVERT (A,B,D) - IF (D .GE. 0.0) RETURN - DO 170 I = 1,3 - DO 160 J = 1,3 - A(I,J) = -A(I,J) - B(I,J) = -B(I,J) - 160 CONTINUE - 170 CONTINUE - RETURN - END -C-------------------------------------------------------------------- -C Form a reduced set of cell vectors -C-------------------------------------------------------------------- - SUBROUTINE REDCL2 (AB,V,L) - INCLUDE 'COMDIF' - DIMENSION AB(3,3),V(6),L(7) - 100 DO 110 J = 1,6 - V(J) = 0.0 - 110 CONTINUE - DO 130 J = 1,3 - M = J + 1 - IF (M .GT. 3) M = M - 3 - DO 120 I = 1,3 - V(J) = V(J) + AB(J,I)*AB(J,I) - V(J+3) = V(J+3) + AB(J,I)*AB(M,I) - 120 CONTINUE - 130 CONTINUE - DO 140 J = 1,3 - M = J + 1 - IF (M .GT. 3) M = M - 3 - IF (V(J+3) .LT. 0.0) THEN - L(J) = (V(J+3)/V(J) - 0.498) - L(J+3) = (V(J+3)/V(M) - 0.498) - ELSE - L(J) = (V(J+3)/V(J) + 0.498) - L(J+3) = (V(J+3)/V(M) + 0.498) - ENDIF - 140 CONTINUE - L(7) = 0 - DO 150 J = 1,6 - IF (IABS(L(J)) .GT. L(7)) THEN - L(7) = IABS(L(J)) - K = J - ENDIF - 150 CONTINUE - IF (L(7) .EQ. 0) RETURN - IF (K .LT. 4) THEN - DO 160 J = 1,3 - M = K + 1 - IF (M .GT. 3) M = M - 3 - AB(M,J) = AB(M,J) - AB(K,J)*L(K) - 160 CONTINUE - ELSE - DO 170 J = 1,3 - M = K - 2 - IF (M .GT. 3) M = M - 3 - AB(K-3,J) = AB(K-3,J) - AB(M,J)*L(K) - 170 CONTINUE - ENDIF - GO TO 100 - END -C-------------------------------------------------------------------- -C Actually do the indexing at last. -C Return with IVALID = 0 means success, -C-------------------------------------------------------------------- - SUBROUTINE TRYIND (FH,LMT,DD,IZ) - INCLUDE 'COMDIF' - DIMENSION LA(NSIZE),LL(3,NSIZE),FH(3,NSIZE) - INTEGER HH(3,NSIZE),S1,S2,S3,HA,HB,HC,DA - NI = 512 - DO 110 J = 1,LMT - DO 100 I = 1,3 - HH(I,J) = FH(I,J) * NI - 100 CONTINUE - 110 CONTINUE - HA = HH(1,LMT) - HB = HH(2,LMT) - HC = HH(3,LMT) - 120 DD = DD + 0.020 - WRITE (COUT,10000) DD - CALL GWRITE (ITP,' ') - IF (DD .GE. 0.50) THEN - WRITE (COUT,11000) - CALL GWRITE (ITP,' ') - DO 130 J = 1,LMT - WRITE (COUT,12000) (FH(I,J),I=1,3) - CALL GWRITE (ITP,' ') - 130 CONTINUE - IVALID = 1 - RETURN - ENDIF - IZ = IZ + 1 - DA = DD*NI - KKA = 0 - DO 280 MM = 1,10 - DO 270 KKK = 1,MM+1 - K = KKK - 1 - S1 = K * HA - DO 260 LLL = 1,MM+1 - L = LLL - 1 - S2 = L * HB - DO 250 MMM = 1,MM+1 - M = MMM - 1 - IF (K .EQ. MM .OR. L .EQ. MM .OR. M .EQ. MM) THEN - S3 = M * HC - 140 IF (ITOLDD(S1+S2+S3,LB,DA) .EQ. 0) THEN - LA(1) = K - LA(2) = L - LA(3) = M - N = 2 - LA(LMT) = LB - GO TO 180 - ENDIF - 150 IF (L .NE. 0 .AND. ITOLDD(S1-S2+S3,LB,DA) .EQ. 0) THEN - LA(1) = K - LA(2) = -L - LA(3) = M - N = 3 - LA(LMT) = LB - GO TO 180 - ENDIF - 160 IF (K .EQ. 0) GO TO 250 - IF (M .NE. 0 .AND. ITOLDD(S1+S2-S3,LB,DA) .EQ. 0) THEN - LA(1) = K - LA(2) = L - LA(3) = -M - N = 4 - LA(LMT) = LB - GO TO 180 - ENDIF - 170 N = 5 - IF (L .EQ. 0 .OR. M .EQ. 0 .OR. - $ ITOLDD(S1-S2-S3,LB,DA) .NE. 0) GO TO 240 - LA(1) = K - LA(2) = -L - LA(3) = -M - N = 5 - LA(LMT) = LB - 180 DO 190 J = LMT-1,4,-1 - IF (ITOLDD(LA(1)*HH(1,J) + - $ LA(2)*HH(2,J) + - $ LA(3)*HH(3,J),LB,DA) .NE. 0) GO TO 240 - LA(J) = LB - 190 CONTINUE - KKA = KKA + 1 - DO 200 J = 1,LMT - LL(KKA,J) = LA(J) - 200 CONTINUE - IF (KKA .EQ. 1) GO TO 240 - M1 = LL(1,1)*LL(2,2) - LL(1,2)*LL(2,1) - M2 = LL(1,1)*LL(2,3) - LL(1,3)*LL(2,1) - M3 = LL(1,2)*LL(2,3) - LL(1,3)*LL(2,2) - IF (KKA .NE. 2) THEN - ID = M1*LL(3,3) - M2*LL(3,2) + M3*LL(3,1) - IF (ID .NE. 0) THEN - DO 230 J = 1,LMT - DO 220 I = 1,3 - FH(I,J) = LL(I,J) - 220 CONTINUE - 230 CONTINUE - RETURN - ENDIF - KKA = 2 - ENDIF - IF (M1 .EQ. 0 .AND. M2 .EQ. 0 .AND. M3 .EQ. 0) KKA = 1 - 240 GO TO (140,150,160,170,250),N - ENDIF - 250 CONTINUE - 260 CONTINUE - 270 CONTINUE - 280 CONTINUE - GO TO 120 -10000 FORMAT (' Error Limit = ',F4.2) -11000 FORMAT (' Non-Integer Indices:') -12000 FORMAT (5X,3F10.4) - END -C-------------------------------------------------------------------- -C Find if the tentative index is within the tolerance DD -C-------------------------------------------------------------------- - FUNCTION ITOLDD (IS,LB,IDD) - LB = (IS + 256)/512 - IF (IS .LT. 0) LB = (IS - 256)/512 - ITOLDD = 1 - IF (IABS(IS - 512*LB) .LT. IDD) ITOLDD = 0 - RETURN - END -C-------------------------------------------------------------------- -C Compute a B matrix from the X and H matrices. -C-------------------------------------------------------------------- - SUBROUTINE COMPB (XX,YY,ZZ,B,HH,LMT) - INCLUDE 'COMDIF' - DIMENSION XX(NSIZE),YY(NSIZE),ZZ(NSIZE), - $ HH(3,NSIZE),A(3,3),B(3,3),AI(3,3) - DO 120 I = 1,3 - DO 110 J = 1,3 - A(I,J) = 0.0 - B(I,J) = 0.0 - DO 100 K = 1,LMT - B(I,J) = B(I,J) + HH(I,K)*HH(J,K) - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - DO 140 I = 1,3 - DO 130 K = 1,LMT - A(1,I) = A(1,I) + XX(K)*HH(I,K) - A(2,I) = A(2,I) + YY(K)*HH(I,K) - A(3,I) = A(3,I) + ZZ(K)*HH(I,K) - 130 CONTINUE - 140 CONTINUE - CALL INVERT (B,AI,D) - DO 170 I = 1,3 - DO 160 J = 1,3 - B(I,J) = 0.0 - DO 150 K = 1,3 - B(I,J) = B(I,J) + A(I,K)*AI(K,J) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - RETURN - END -C-------------------------------------------------------------------- -C Calculate and output the cell etc. -C-------------------------------------------------------------------- - SUBROUTINE CALCEL (B,AI,D) - INCLUDE 'COMDIF' - DIMENSION B(3,3),AI(3,3) - CALL INVERT (B,AI,D) - VOL = 1.0/D - A2 = AI(1,1)*AI(1,1) + AI(1,2)*AI(1,2) + AI(1,3)*AI(1,3) - B2 = AI(2,1)*AI(2,1) + AI(2,2)*AI(2,2) + AI(2,3)*AI(2,3) - C2 = AI(3,1)*AI(3,1) + AI(3,2)*AI(3,2) + AI(3,3)*AI(3,3) - DAB = AI(1,1)*AI(2,1) + AI(1,2)*AI(2,2) + AI(1,3)*AI(2,3) - DAC = AI(1,1)*AI(3,1) + AI(1,2)*AI(3,2) + AI(1,3)*AI(3,3) - DBC = AI(2,1)*AI(3,1) + AI(2,2)*AI(3,2) + AI(2,3)*AI(3,3) - D1 = SQRT(A2) - D2 = SQRT(B2) - D3 = SQRT(C2) - D4 = DBC/(D2*D3) - D5 = DAC/(D1*D3) - D6 = DAB/(D1*D2) - D4 = DEG*ATAN(SQRT(1-D4*D4)/D4) - IF (D4 .LT. 0.0) D4 = D4 + 180.0 - D5 = DEG*ATAN(SQRT(1-D5*D5)/D5) - IF (D5 .LT. 0.0) D5 = D5 + 180.0 - D6 = DEG*ATAN(SQRT(1-D6*D6)/D6) - IF (D6 .LT. 0.0) D6 = D6 + 180.0 - WRITE (COUT,10000) D1,D2,D3,D4,D5,D6,VOL - CALL GWRITE (ITP,' ') - RETURN -10000 FORMAT (/' Cell Dimensions:'/ - $ ' a',F8.3,', b',F8.3,', c',F8.3/ - $ ' alpha',F7.2,', beta',F7.2,', gamma',F7.2, - $ '. Volume = ',F8.2) - END -C-------------------------------------------------------------------- -C Get the input angles and form the XX, YY and ZZ arrays. -C LMT is the number of input reflections. -C-------------------------------------------------------------------- - SUBROUTINE PRPXYZ (XX,YY,ZZ,LMT) - INCLUDE 'COMDIF' - DIMENSION XX(NSIZE),YY(NSIZE),ZZ(NSIZE),THETAS(NSIZE), - $ OMEGAS(NSIZE),CHIS(NSIZE),PHIS(NSIZE),ICNTS(NSIZE) - EQUIVALENCE (ACOUNT( 1),THETAS(1)), - $ (ACOUNT( NSIZE+1),OMEGAS(1)), - $ (ACOUNT(2*NSIZE+1),CHIS(1)), - $ (ACOUNT(3*NSIZE+1),PHIS(1)), - $ (ACOUNT(4*NSIZE+1),ICNTS(1)) - CALL ANGRW (0,5,NTOT,140,0) - LMT = 0 - DO 100 I = 1,NTOT - IF (ICNTS(I) .GT. 0) THEN - LMT = LMT + 1 - THETA = THETAS(I)/(2.0*DEG) - OMEGA = OMEGAS(I)/DEG - CHI = CHIS(I)/DEG - PHI = PHIS(I)/DEG - HM = 2.0 * SIN(THETA)/WAVE - XX(LMT) = HM*(COS(CHI)*COS(PHI)*COS(OMEGA) - - $ SIN(PHI)*SIN(OMEGA)) - YY(LMT) = HM*(COS(CHI)*SIN(PHI)*COS(OMEGA) + - $ COS(PHI)*SIN(OMEGA)) - ZZ(LMT) = HM*SIN(CHI)*COS(OMEGA) - ENDIF - 100 CONTINUE - CALL SRCH3 (LMT,XX,YY,ZZ) - RETURN - END -C-------------------------------------------------------------------- -C Sort the input list and search for the 3 shortest non-coplanar -C vectors. -C-------------------------------------------------------------------- - SUBROUTINE SRCH3 (LMT,XX,YY,ZZ) - INCLUDE 'COMDIF' - DIMENSION XX(NSIZE),YY(NSIZE),ZZ(NSIZE), - $ XA(NSIZE),YA(NSIZE),ZA(NSIZE),A(3,3),B(3,3), - $ W(NSIZE+1),VV(6),L(NSIZE+1),LL(7) - VSTART = 0.5 - VEND = 0.05 - DO 100 I = 1,NSIZE+1 - W(I) = 1.0E9 - L(I) = 0 - 100 CONTINUE - DO 130 I = 1,LMT - HM = XX(I)*XX(I) + YY(I)*YY(I) + ZZ(I)*ZZ(I) - DO 120 J = 1,LMT - IF (HM .LT. W(J)) THEN - DO 110 K = LMT,J,-1 - W(K+1) = W(K) - L(K+1) = L(K) - 110 CONTINUE - W(J) = HM - L(J) = I - GO TO 130 - ENDIF - 120 CONTINUE - 130 CONTINUE - VMIN = VSTART - 135 DO 140 J = 1,LMT - XA(J) = XX(L(J)) - YA(J) = YY(L(J)) - ZA(J) = ZZ(L(J)) - 140 CONTINUE -C-------------------------------------------------------------------- -C Search for a reasonable first cell. -C The actual volume of the cells selected is D, the determinant of -C the 3 vectors L formed by XA, YA, ZA. The maximum volume such a -C cell can have is V = L1*L2*L3. If D/V > VMIN (0.5) the cell of -C L1, L2 and L3 is a reasonable starting point. If not, swap out -C either L2 or L3, depending on which makes the smaller angle with -C L1, with vectors (reflections) sequentially lower in the list. -C-------------------------------------------------------------------- - EL1 = SQRT(XA(1)*XA(1) + YA(1)*YA(1) + ZA(1)*ZA(1)) - K = 3 -150 K = K + 1 - IF (K .GT. LMT) THEN - VMIN = 0.5*VMIN - IF (VMIN .LT. VEND) THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - IVALID = 1 - RETURN - ELSE - GO TO 135 - ENDIF - ENDIF - DO 160 I = 1,3 - B(I,1) = XA(I) - B(I,2) = YA(I) - B(I,3) = ZA(I) - 160 CONTINUE - CALL INVERT (B,A,D) - EL2 = SQRT(XA(2)*XA(2) + YA(2)*YA(2) + ZA(2)*ZA(2)) - EL3 = SQRT(XA(3)*XA(3) + YA(3)*YA(3) + ZA(3)*ZA(3)) - VMAX = EL1*El2*EL3 - IF (ABS(D)/VMAX .LT. VMIN) THEN - COS12 = (XA(1)*XA(2) + YA(1)*YA(2) + ZA(1)*ZA(2))/(EL1*EL2) - COS13 = (XA(1)*XA(3) + YA(1)*YA(3) + ZA(1)*ZA(3))/(EL1*EL3) - IF (ABS(COS12) .GT. ABS(COS13)) THEN - HM = XA(K) - XA(K) = XA(2) - XA(2) = XA(3) - XA(3) = HM - HM = YA(K) - YA(K) = YA(2) - YA(2) = YA(3) - YA(3) = HM - HM = ZA(K) - ZA(K) = ZA(2) - ZA(2) = ZA(3) - ZA(3) = HM - M = L(K) - L(K) = L(2) - L(2) = M - ELSE - HM = XA(K) - XA(K) = XA(3) - XA(3) = HM - HM = YA(K) - YA(K) = YA(3) - YA(3) = HM - HM = ZA(K) - ZA(K) = ZA(3) - ZA(3) = HM - M = L(K) - L(K) = L(3) - L(3) = M - ENDIF - GO TO 150 - ENDIF - CALL REDCL2 (B,VV,LL) - DO 170 I = LMT,1,-1 - XX(I+3) = XX(I) - YY(I+3) = YY(I) - ZZ(I+3) = ZZ(I) - 170 CONTINUE - DO 180 I = 1,3 - XX(I) = B(I,1) - YY(I) = B(I,2) - ZZ(I) = B(I,3) - 180 CONTINUE - LMT = LMT + 3 - RETURN -10000 FORMAT (' The reflections are essentially coplanar and', - $ ' indexing would be unreliable.'/ - $ ' Collect more peaks and try again.') - END -C-------------------------------------------------------------------- -C Invert matrix A to AI. Determinant is D. -C-------------------------------------------------------------------- - SUBROUTINE INVERT (A,AI,D) - DIMENSION A(3,3),AI(3,3) - D = A(1,1)*(A(2,2)*A(3,3) - A(2,3)*A(3,2)) - - $ A(1,2)*(A(2,1)*A(3,3) - A(2,3)*A(3,1)) + - $ A(1,3)*(A(2,1)*A(3,2) - A(2,2)*A(3,1)) - IF (D .NE. 0.0) CALL MATRIX (A,AI,AI,AI,'INVERT') - RETURN - END -C-------------------------------------------------------------------- -C EDLIST Edit the reflection list -C-------------------------------------------------------------------- - SUBROUTINE EDLIST - INCLUDE 'COMDIF' - CHARACTER FLAG*1,REFNAM*40,LINE*80 - DIMENSION THETAS(NSIZE), - $ OMEGAS(NSIZE),CHIS(NSIZE),PHIS(NSIZE),ICNTS(NSIZE) - EQUIVALENCE (ACOUNT( 1),THETAS(1)), - $ (ACOUNT( NSIZE+1),OMEGAS(1)), - $ (ACOUNT(2*NSIZE+1),CHIS(1)), - $ (ACOUNT(3*NSIZE+1),PHIS(1)), - $ (ACOUNT(4*NSIZE+1),ICNTS(1)) -C-------------------------------------------------------------------- -C Read in the reflection list -C-------------------------------------------------------------------- - CALL ANGRW (0,5,NTOT,140,0) -C-------------------------------------------------------------------- -C Do the editing here -C-------------------------------------------------------------------- - WRITE (COUT,10000) NTOT - CALL GWRITE (ITP,' ') - 90 WRITE (COUT,11000) - CALL GWRITE (ITP,' ') - 100 WRITE (COUT,12000) - CALL ALFNUM (LINE) - ANS = LINE(1:1) - IF (ANS .NE. 'L' .AND. ANS .NE. 'D' .AND. ANS .NE. 'R' .AND. - $ ANS .NE. 'A' .AND. ANS .NE. 'F' .AND. ANS .NE. 'E') - $ GO TO 90 -C-------------------------------------------------------------------- -C List the reflections in use -C-------------------------------------------------------------------- - IF (ANS .EQ. 'L') THEN - IF (NTOT .GT. 0) THEN - WRITE (COUT,13000) - CALL GWRITE (ITP,' ') - DO 110, I = 1,NTOT - FLAG = ' ' - IF (ICNTS(I) .LE. 0) FLAG = '*' - WRITE (COUT,14000) I,THETAS(I),OMEGAS(I),CHIS(I), - $ PHIS(I),ICNTS(I),FLAG - CALL GWRITE (ITP,' ') -110 CONTINUE - ELSE - WRITE (COUT,15000) - CALL GWRITE (ITP,' ') - ENDIF -C-------------------------------------------------------------------- -C Delete a reflection, i.e. make the count negative -C-------------------------------------------------------------------- - ELSE IF (ANS .EQ. 'D') THEN - WRITE (COUT,16000) - CALL FREEFM (ITR) - INDX = IFREE(1) - IF (INDX .GE. 1 .AND. INDX .LE. NTOT) THEN - IF (ICNTS(INDX) .GT. 0) ICNTS(INDX) = -ICNTS(INDX) - WRITE (COUT,17000) INDX - CALL GWRITE (ITP,' ') - ENDIF -C-------------------------------------------------------------------- -C Reinsert a deleted reflection -C-------------------------------------------------------------------- - ELSE IF (ANS .EQ. 'R') THEN - WRITE (COUT,16000) - CALL FREEFM (ITR) - INDX = IFREE(1) - IF (INDX .GE. 1 .AND. INDX .LE. NTOT) THEN - IF (ICNTS(INDX) .LT. 0) ICNTS(INDX) = -ICNTS(INDX) - WRITE (COUT,18000) INDX - CALL GWRITE (ITP,' ') - ENDIF -C-------------------------------------------------------------------- -C Add a reflection -C-------------------------------------------------------------------- - ELSE IF (ANS .EQ. 'A') THEN - WRITE (COUT,19000) - CALL YESNO ('N',ANS) - 120 WRITE (COUT,20000) - CALL FREEFM (ITR) - IF (RFREE(1) .NE. 0) THEN - NTOT = NTOT + 1 - THETAS(NTOT) = RFREE(1) - IF (ANS .EQ. 'N') THEN - OMEGAS(NTOT) = RFREE(2) - ELSE - OMEGAS(NTOT) = RFREE(2) - 0.5*RFREE(1) - ENDIF - CHIS(NTOT) = RFREE(3) - PHIS(NTOT) = RFREE(4) - ICNTS(NTOT) = 1000 - GO TO 120 - ENDIF -C-------------------------------------------------------------------- -C Read reflections from the file REFL.DAT -C-------------------------------------------------------------------- - ELSE IF (ANS .EQ. 'F') THEN - WRITE (COUT,18900) - REFNAM = 'DONT DO IT'//' ' - CALL ALFNUM (REFNAM) - IF (REFNAM .EQ. ' ') REFNAM = 'REFL.DAT'//' ' - WRITE (COUT,19000) - CALL YESNO ('N',ANS) - IREFL = IOUNIT(10) - CALL IBMFIL (REFNAM,IREFL,80,'SU',IERR) - NTOT = 0 - DO 130 I = 1,NSIZE - READ (IREFL,21000,END = 140) OCHAR - CALL FREEFM (1000) - NTOT = NTOT + 1 - THETAS(NTOT) = RFREE(1) - IF (ANS .EQ. 'N') THEN - OMEGAS(NTOT) = RFREE(2) - ELSE - OMEGAS(NTOT) = RFREE(2) - 0.5*RFREE(1) - ENDIF - CHIS(NTOT) = RFREE(3) - PHIS(NTOT) = RFREE(4) - ICNTS(NTOT) = 1000 - 130 CONTINUE - 140 CALL IBMFIL (REFNAM,-IREFL,80,'SU',IERR) - DO 150 J = 40,1,-1 - IF (REFNAM(J:J) .NE. ' ') GO TO 160 - 150 CONTINUE - 160 WRITE (COUT,22000) NTOT,REFNAM(1:J) - CALL GWRITE (ITP,' ') -C-------------------------------------------------------------------- -C Write the reflections to file and exit -C-------------------------------------------------------------------- - ELSE IF (ANS .EQ. 'E') THEN - CALL ANGRW (1,5,NTOT,140,0) - RETURN - ENDIF - GO TO 100 -10000 FORMAT (' There are ',I4,' peaks in the list') -11000 FORMAT (' (L) List the reflections;'/ - $ ' (D) Delete a reflection;'/ - $ ' (R) Reinsert a reflection;'/ - $ ' (A) Add a reflection;'/ - $ ' (F) Read reflections from a file;'/ - $ ' (E) Exit.') -12000 FORMAT ( ' Command (L,D,R,A,F,E) ',$) -13000 FORMAT (' N Theta Omega Chi Phi Int'/) -14000 FORMAT (' ',I2,1X,4(F8.2),2X,I8,5X,A) -15000 FORMAT (' There are no reflections in the list') -16000 FORMAT (' Input reflection number: ') -17000 FORMAT (' Reflection ',I2,' marked unused') -18000 FORMAT (' Reflection ',I2,' marked used') -18900 FORMAT (' Type the reflection file name (REFL.DAT) ',$) -19000 FORMAT (' Subtract theta from the omega value (N) ? ',$) -20000 FORMAT (' Type 2theta, omega, chi, phi ',$) -21000 FORMAT (A) -22000 FORMAT (I4,' reflections have been read from ',A) - END diff --git a/difrac/burger.f b/difrac/burger.f deleted file mode 100644 index e47da3b1..00000000 --- a/difrac/burger.f +++ /dev/null @@ -1,174 +0,0 @@ -C----------------------------------------------------------------------- -C Buerger reduction -C----------------------------------------------------------------------- - SUBROUTINE BURGER (IOUT,A,ANG,IND) - CHARACTER COUT*132 - COMMON /IOUASC/ COUT(20) - REAL IND(3,3) - DIMENSION AA(3,3),A(3),ANG(3) - DATA INUM/0/ - RAD = 3.14159/180.0 -C----------------------------------------------------------------------- -C Form the matrix of dot products -C----------------------------------------------------------------------- - DO 100 I = 1,3 - DO 100 J = 1,3 - IF (I .EQ. J) AA(I,J) = A(I)*A(I) - IF (I .NE. J) AA(I,J) = A(I)*A(J)*COS(ANG(6 - I - J)*RAD) - 100 CONTINUE -C----------------------------------------------------------------------- -C Look for shorter translations in cell faces -C----------------------------------------------------------------------- - 110 NUM = 0 - DO 170 I = 1,3 - DO 160 J = 1,3 - IF (J .NE. I) THEN - IS = 1 - IF (AA(I,J) .GT. 0) IS = -1 - IS1 = IS - VMIN = 0 - 120 V = AA(I,J)*2*IS1 + AA(J,J)*IS1**2 - IF (V .LT. VMIN) THEN - VMIN = V - IS1 = IS1 + IS - GO TO 120 - ENDIF -C----------------------------------------------------------------------- -C Did we find a shorter translation? -C----------------------------------------------------------------------- - IS1 = IS1 - IS - IF (IS1 .NE. 0) THEN -C----------------------------------------------------------------------- -C Yes, we did. Accept it as a cell edge -C----------------------------------------------------------------------- - NUM = NUM + 1 - INUM = INUM + 1 -C----------------------------------------------------------------------- -C Transform the old-new indices -C----------------------------------------------------------------------- - DO 140 K = 1,3 - IND(I,K) = IND(I,K) + IS1*IND(J,K) - 140 CONTINUE -C----------------------------------------------------------------------- -C Modify the matrix of dot products -C----------------------------------------------------------------------- - AA(I,I) = AA(I,I) + AA(I,J)*2*IS1 + AA(J,J)*IS1**2 - AA(I,J) = AA(I,J) + IS1*AA(J,J) - AA(J,I) = AA(I,J) - K = 6 - I - J - AA(I,K) = AA(I,K) + IS1*AA(J,K) - AA(K,I) = AA(I,K) - ENDIF - ENDIF - 160 CONTINUE - 170 CONTINUE -C----------------------------------------------------------------------- -C Look for more transformations -C----------------------------------------------------------------------- - IF (NUM .GE. 1) GO TO 110 -C----------------------------------------------------------------------- -C Are the cross-terms of a same sign? -C----------------------------------------------------------------------- - 180 VAR = ABS(AA(1,2)) + ABS(AA(1,3)) + ABS(AA(2,3)) - IF (ABS(ABS(AA(1,2)+AA(1,3)+AA(2,3))-VAR) .GT. 0.0001*VAR) THEN -C----------------------------------------------------------------------- -C No, find the odd sign -C----------------------------------------------------------------------- - ISIGN = 1 - IF (AA(1,2)*AA(1,3)*AA(2,3) .LT. 0) ISIGN = -1 -C----------------------------------------------------------------------- -C Reverse two vectors to make the cell triacute or triobtuse -C----------------------------------------------------------------------- - DO 200 I = 1,2 - K = I + 1 - DO 190 J = K,3 - IF (AA(I,J)*ISIGN .GT. 0.0) GO TO 210 - 190 CONTINUE - 200 CONTINUE - 210 K = 6 - I - J -C----------------------------------------------------------------------- -C Modify the indices and the dot products -C----------------------------------------------------------------------- - DO 220 II = 1,3 - IND(I,II) = -IND(I,II) - IND(J,II) = -IND(J,II) - 220 CONTINUE - AA(K,J) = -AA(K,J) - AA(J,K) = -AA(J,K) - AA(K,I) = -AA(K,I) - AA(I,K) = -AA(I,K) - ENDIF -C----------------------------------------------------------------------- -C Order the diagonal terms in increasing values -C----------------------------------------------------------------------- - INUM = 0 - 240 NUM = 0 - DO 280 I = 1,2 - IF ((AA(I,I) - AA(I+1,I+1)) .GT. 0.0) THEN - NUM = NUM + 1 - INUM = INUM + 1 - DO 250 J = 1,3 - SAVE = AA(I,J) - AA(I,J) = AA(I + 1,J) - AA(I + 1,J) = SAVE - 250 CONTINUE - DO 260 J = 1,3 - SAVE = AA(J,I) - AA(J,I) = AA(J,I + 1) - AA(J,I + 1) = SAVE - 260 CONTINUE - DO 270 K = 1,3 - SAVE = IND(I,K) - IND(I,K) = IND(I + 1,K) - IND(I + 1,K) = SAVE - 270 CONTINUE - ENDIF - 280 CONTINUE - IF (NUM .NE. 0) GO TO 240 -C----------------------------------------------------------------------- -C If the cell is left-handed, reverse all axes -C----------------------------------------------------------------------- - IF (MOD(INUM,2) .NE. 0) THEN - DO 290 I = 1,3 - DO 290 J = 1,3 -C----------------------------------------------------------------------- -C If 111 is shorter than c, call it c and re-reduce the cell -C----------------------------------------------------------------------- - IND(I,J) = -IND(I,J) - 290 CONTINUE - ENDIF - IF (AA(1,1)+AA(2,2) .LT. -2*(AA(1,2)+AA(1,3)+AA(2,3))) THEN - AA(3,3) = AA(3,3) + 2*AA(3,1) + AA(1,1) - AA(3,1) = AA(3,1) + AA(1,1) - AA(1,3) = AA(3,1) - AA(3,2) = AA(3,2) + AA(1,2) - AA(2,3) = AA(3,2) - AA(3,3) = AA(3,3) + 2*AA(3,2) + AA(2,2) - AA(3,2) = AA(3,2) + AA(2,2) - AA(2,3) = AA(3,2) - AA(3,1) = AA(3,1) + AA(1,2) - AA(1,3) = AA(3,1) - DO 310 J = 1,3 - IND(3,J) = IND(1,J) + IND(2,J) + IND(3,J) - 310 CONTINUE - GO TO 180 - ENDIF -C----------------------------------------------------------------------- -C Get the Niggli cell parameters -C----------------------------------------------------------------------- - DO 330 I = 1,3 - A(I) = SQRT(AA(I,I)) - 330 CONTINUE - DO 340 I = 1,3 - J = MOD(I,3) + 1 - K = MOD(J,3) + 1 - ANG(I) = ACOS(AA(J,K)/(A(J)*A(K)))/RAD - 340 CONTINUE - WRITE (COUT,10000) A,ANG - CALL GWRITE (IOUT,' ') - WRITE (COUT,11000) ((IND(I,J),J = 1,3),I = 1,3) - CALL GWRITE (IOUT,' ') - RETURN -10000 FORMAT (/' The Shortest Non-coplanar Translations '/10X,6F10.3) -11000 FORMAT (' The Old-to-New Cell Matrix'/(10X,3F6.1)) - END diff --git a/difrac/cad4io.f b/difrac/cad4io.f deleted file mode 100644 index 95f220e0..00000000 --- a/difrac/cad4io.f +++ /dev/null @@ -1,517 +0,0 @@ -! -! This is a set of FORTRAN subroutines for PDP11/02 and -! VAX/VMS CAD4 application. -! -! H. Lenk 8-Jun-1983 - Subroutine cad4_io (io_func,io_pre,io_post0,io_post1,io_post2, - 1 io_post3,io_post4,io_post5,io_post6,io_post7) -! -! Subroutine for protocol I/O with LSI 11 -! -! io_func (byte) - function code from VAX to 11/02 -! io_pre (addr) - address of pre-processing routine -! io_postn(addr) - address of post-processing routine n -! depending on function bits in input_header -! (received from 11/02) -! - integer*2 head02 !input header in word mode -! - include 'CAD4COMM' !Include common block -! -! input: -! io_coswr (word) - switch options register from vax to 11/02 -! io_cobnr (word) - no. of calls to 11/02 -! io_cohex (byte) - header from VAX to 11/02 -! -! IO_COHEX is copied into OUTPUT_HEADER byte -! -! Prepare for next protocol message: -! a) previous result is assumed to be successfull -! b) block number of protocol message is one higher than previous one -! - result = e_suc - io_cobnr = io_cobnr + 1 -! - 10 continue -! Define header of protocol message -! bit 0-1 : seq. no. of the calls to LSI-11 -! bit 2-4 : result code -! bit 5-7 : function -! - io_cohex = io_func + result + iand(io_cobnr,m_seq) -! -! Call pre processing routine to fill the output_buffer -! - call io_pre -! -! Move transmit header to transfer buffer -! - output_header = io_cohex -! -! Transfer buffer to LSI-11 and wait for answer -! - call cad4_readprompt (result) -! -! Check for succesfull reception of answer -! - if (result .ne. e_suc) go to 10 -! -! Check if LSI-11 was able to interprete our transmitted data well -! - head02 = input_header !integer*2 header for IAND's - if (iand(head02,m_efl) .eq. e_suc) go to 30 -! -! Now we are disappointed but check if LSI-11 wants a new start -! - if (iand(head02,m_efl+m_fun).ne. - 1 iand(#ff,f_req_mem+e_typ)) goto 10 -! -! -! If seq. no. correct -! -30 if (iand(io_cobnr,m_seq).eq.iand(head02,m_seq)) go to 40 -! -! Transfer sequence error -! - result = e_seq - go to 10 -! -! Select the post processing routine -! -40 n = iand(head02,m_fun) / #20 -! -! write (l_unit,10010) n -10010 format(' cad4_io : received function dispatch = ',z2) -! - go to (100,101,102,103,104,105,106,107) n+1 -100 call io_post0(result) - go to 200 -101 call io_post1(result) - go to 200 -102 call io_post2(result) - go to 200 -103 call io_post3(result) - go to 200 -104 call io_post4(result) - go to 200 -105 call io_post5(result) - go to 200 -106 call io_post6(result) - go to 200 -107 call io_post7(result) -! -! Check post processing error and eventual -! initialization of 11/02 -! -200 if (result .eq. e_typ) then - if (io_func .eq. f_init) result = e_suc - goto 10 - else - if (result .ne. e_suc) goto 10 - end if - return - end -! -! - subroutine cad4_load_syspar -! -! Pre processing routine to copy syspar values from syspar_val -! to output buffer -! - include 'CAD4COMM' -! -! Copy syspar data to output_buffer -! - do i=1,((nr_load_byte+1)/2) - output_data_w(i+1) = syspar_val(i) - end do -! -! Set load address -! - output_data_w(1) = slave_load_address -! -! Set output length -! - output_length = nr_load_byte + 2 -! - return - end -! -! - Subroutine cad4_send_oper4 (text) -! -! Routine to send message to operator -! - character*(*) text ! Input string -! - include 'CAD4COMM' ! Include common block -! - print *,text - return - end -! -! - Subroutine cad4_get_instrument -! -! Subroutine to insert ASCII instrument name and logical*1 -! unit number to CAD4 instrument into fortran common block -! -! modified: 03-jan-1985 LCB Adaption for SBC-21 (Falcon processor) -! -! A process name of 'CAD4?_CAn' is required !!!!!! -! - include 'CAD4COMM' ! Include common block -! - ibycan_c(2:4) = 'CA0' ! Set default - ibycan_b(1) = 0 ! name and unit -! -! For now assume a Falcon by setting UIC = #40 -! - process_uic_w(1) = #40 -! - if ((process_uic_w(1).and.#40).ne.0) then - lsypar = sbc_bottom - #40 - else - lsypar = lsi_bottom - #40 - end if - if ((process_uic_w(1).and.#20).ne.0) then - lsypar = sbcp_bottom - #40 - end if -! -! write (l_unit,10020) ibycan_c(2:4), ibycan_b(1) -10020 format (' Instrument name = ',a3,' Unit = ',i3) -! - return - end -! -! - Subroutine cad4_ini_terminal ! Initialize terminal -! - CHARACTER PORT*4 - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - include 'CAD4COMM' ! Include common block -! - cad4_terminator(1) = 0 ! Short form - cad4_terminator(2) = 0 ! No terminator characters -! - PORT = 'COM'//CHAR(IPORT+48) - call io_init (PORT,IBAUD,8,'n',1) - write (l_unit,10060) PORT,IBAUD -10060 format (' Port ',A,': set to 'I5,',8,n,1') -! - return - end -! - Subroutine cad4_exit_handler(exit_status) ! Exit handler -! - include 'CAD4COMM' ! Include common block -! -! -! if (l_unit_open) close (unit=l_unit) ! Close Log file if open - l_unit_open = .false. ! Set false -! - exit_status = exit_status - return ! Return - end -! -! - Subroutine cad4_reset_terminal ! Routine to reset cad4 terminal -! - include 'CAD4COMM' ! Include common block -! - qio_status = io_done () -! -! de-allocate cad4 communication channel -! - return ! Return to caller - end -! -! - Subroutine cad4_readprompt(result) -! -! Arguments used : -! -! prompt_buffer ! Buffer to save prompt -! prompt_length ! No of data bytes to send -! input_buffer ! Input buffer to read record -! - include 'CAD4COMM' ! Include common block -! -! First compute checksum and insert it at the end of output buffer -! (compute total prompt size) -! - call cad4_prepare_output -! -! write (l_unit,10010) (prompt_buffer(l),l=1,prompt_size) -10010 format (' ttyreadpall - Prompt = ',20(z4,1x)) -! write (l_unit,10020) prompt_header -10020 format (' - Header = ',z4) -! write (l_unit,10030) prompt_length -10030 format (' - Length = ',z7) -! write (l_unit,10035) isum_w -10035 format (' - CRC = ',z8,' sending header') -! -! Perform QIO to send prompt and read header -! -! qio_status = sys$qiow (%val(cad4_efn),%val(cad4_chan), -! 1 %val(io_funct),cad4_iosb,,, -! 2 %ref(input_buffer), ! p1 = input buffer -! 3 %val(1), ! p2 = input size -! 4 %val(cad4_l_timo), ! p3 = timeout count -! 5 %ref(cad4_terminator(1)), ! p4 = term. mask -! 6 %val(%loc(prompt_buffer)), ! p5 = prompt buffer -! 7 %val(prompt_size) ) ! p6 = prompt b. size -! - qui_status = io_prompt (cad4_iosb, - $ input_buffer, - $ 1, - $ cad4_l_timo, - $ prompt_buffer, - $ prompt_size) -! - if (iand(cad4_iosb_i2(1),1) .eq. 1) then -! -! Now read length and crc or data bytes from PDP11/02 -! - cad4_iosb(1) = 0 ! Be sure length and - cad4_iosb(2) = 0 ! io-status is zero -! -! qio_status = sys$qiow (%val(cad4_efn),%val(cad4_chan), -! 1 %val(io_funct),cad4_iosb,,, -! 2 %ref(input_buffer(2)), ! p1 = input buffer -! 3 %val(4), ! p2 = input size -! 4 %val(cad4_timeout), ! p3 = timeout count -! 5 %ref(cad4_terminator(1)),,) ! p4 = term. mask -! -! - qio_status = io_read (cad4_iosb, - $ input_buffer(2), - $ 4, - $ cad4_timeout) -! -! write (l_unit,10040) input_header -10040 format (' - InpHdr = ',z4) -! write (l_unit,10050) input_length -10050 format (' - InpLen = ',z7) -! - input_size = 4 - if((iand(cad4_iosb_i2(1),1) .eq. 1) .and. - $ input_length .ne. 0) then -! -! Now read data bytes from PDP11/02 -! - cad4_iosb(1) = 0 ! Be sure length and - cad4_iosb(2) = 0 ! io-status is zero -! - input_size = input_length !(n-2)Data bytes and checksum - if(input_size.lt.0.or.input_size .gt. 516)input_size=516 -! -! qio_status = sys$qiow (%val(cad4_efn),%val(cad4_chan), -! 1 %val(io_funct),cad4_iosb,,, -! 2 %ref(input_buffer(6)), ! p1 = input buffer -! 3 %val(input_size), ! p2 = input size -! 4 %val(cad4_timeout), ! p3 = timeout count -! 5 %ref(cad4_terminator(1)),,) ! p4 = term. mask -! - qio_status = io_read (cad4_iosb, - $ input_buffer(6), - $ input_size, - $ cad4_timeout) -! - end if - end if -! -! Check CRC and set up return status -! - call cad4_check_crc (result) -! -! write (l_unit,10070) (input_buffer(l),l=1,10) -10070 format (' - Input = ',10(z4,1x)) -! write (l_unit,10080) qio_status,cad4_iosb -10080 format (' - IOSB = ',z8,2x,z8,2x,z8) -! - return - end -! - Subroutine cad4_prepare_output -! - include 'CAD4COMM' ! Include common block -! -! Prepare output buffer for output -! 1. set output_size to to no of bytes output in QIO -! 2. computes 16. bit CRC and store it at end of buffer -! 3. clear iosb -! -! -! 1. Set output_size -! - output_size = 1 + 2 + output_length + 2 ! Header byte - ! No. of data bytes (word) - ! n data bytes - ! 16 bit CRC -! -! 2. Compute CRC -! - isum_w = 0 ! First use 16 bit sum - do l = 1, output_length + 3 - crchar=ichar(output_buffer_c(l:l)) - crchar=iand(crchar,#ff) - isum_w = ieor (isum_w,crchar) - do m = 1, 8 - if (iand(isum_w,1) .eq. 1) then - isum_w = isum_w/2 - isum_w = ieor (isum_w,iconst) - else - isum_w = isum_w / 2 - end if - end do - end do -! - output_buffer(output_length+3+1) = isum_b(1) ! Copy CRC to - output_buffer(output_length+3+2) = isum_b(2) ! end of buffer -! -! 3. Clear IOSB -! - cad4_iosb(1) = 0 ! Be sure length and - cad4_iosb(2) = 0 ! io-status is zero -! - return - end -! -! - Subroutine cad4_check_crc (result) -! - include 'CAD4COMM' ! Include common block -! -! Check answer from cad4 -! -! input: cad4_iosb - I/O status block -! input_buffer - input data and CRC -! -! output: cad4_iosb -! -! 1. word 2. word result -! -! ss$_xxxxxx 0 e_pnd system service failed -! ss$_normal 0 e_tol no data within timeout seconds -! ss$_normal icnt e_tos not enough data to meet protcol -! icnt = no. of bytes received -! ss$_normal rcnt e_ovf buffer ovf but trans. not. fin. -! rcnt = no. of rec. bytes is max -! ss$_normal pcnt e_crc enough data rec. but CRC error -! pcnt = hd.byte + length + data -! ss$_normal pcnt e_suc success -! -! -! -! qio_status = cad4_iosb_i2(1) ! Copy status code -! -! Here if no timeout or any other error -! - if (cad4_iosb_i2(1) .ne. 0) then -! -! - if(cad4_iosb_i2(2).eq.input_size)then -! -! Subtract CRC -! - if (input_length.lt.0 .or. input_length.gt.516) - 1 input_length = 516 !protect memory - isum_b(1) = input_buffer(input_length+3+1) - isum_b(2) = input_buffer(input_length+3+2) - isum = isum_w !save received crc -! -! -! Check checksum of received data -! - isum_w = 0 ! First use 16 bit sum - do l = 1, input_length + 3 - crchar=ichar(input_buffer_c(l:l)) - crchar=iand(crchar,#ff) - isum_w = ieor (isum_w,crchar) - do m = 1, 8 - if (iand(isum_w,1) .eq. 1) then - isum_w = isum_w / 2 - isum_w = ieor (isum_w,iconst) - else - isum_w = isum_w / 2 - end if - end do - end do -! -! write (l_unit,10010) isum_w, isum -10010 format (13x,'- Computed Sum = ',z8,' Received CRC = ',z8) -! -! Set status code into third word of IOSB -! - if (isum_w.eq.isum) then - result = e_suc - else - result = e_crc - end if - else - result=e_ovf - end if -! -! Here if any qio error except timeout -! - else - if (qio_status.ne.ss$_timeout) then - result = e_pnd -! -! Here if timeout -! - else - cad4_iosb_i2(1) = ss$_normal ! Set success in first word - if (cad4_iosb_i2(2).eq.0) then - result = e_tol ! No data for zero byte count - else - result = e_tos ! Not enoght data received - end if -! - end if - end if - qio_status = cad4_iosb_i2(1) ! Copy status code! -! -! write (l_unit,10020) result -10020 format (13x,'- Result = ',z4) -! - return - end -! - Subroutine cad4_open_log_file -! - include 'CAD4COMM' ! Include common block -! - l_unit_open = .true. ! File open flag - return - end -! - Subroutine cad4_post_dummy(result) -! -! Post proc. routine - just to meet standard call sequence -! - include 'CAD4COMM' - result = result - return - end -! - Subroutine cad4_pre_dummy -! -! Pre proc. routine - just to meet standard call sequence -! - include 'CAD4COMM' - output_length = 0 - return - end -! - Subroutine cad4_type_error(result) -! -! Post proc. routine -! - include 'CAD4COMM' - result = e_typ - return - end diff --git a/difrac/cad4l.f b/difrac/cad4l.f deleted file mode 100644 index f2184395..00000000 --- a/difrac/cad4l.f +++ /dev/null @@ -1,454 +0,0 @@ - program CAD4L -! -! Program to load 11/02 or Falcon or Falcon+ from PC -! - external cad4_pre_dummy,cad4_type_error,cad4_post_dummy - external cad4_load_syspar,cad4_restart_load,cad4_prompt - external cad4_check_type -! - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - include 'CAD4COMM' ! include common block -! -! First open log file -! - call cad4_open_log_file -! -! Get instument number from process name and save it into common block -! - call cad4_get_instrument -! -! Initialize terminal connected to 11/02 -! - call cad4_read_gon_file (1) - call cad4_ini_terminal -! -! Initialize block number (count io transfers) -! - io_cobnr = 0 -! -! Initialize 11/02 -! - call cad4_io (f_init,cad4_pre_dummy,cad4_type_error, - 1 cad4_type_error,cad4_type_error,cad4_type_error, - 2 cad4_type_error,cad4_type_error,cad4_check_type, - 3 cad4_type_error) -! -! Select normal preprocessing routine -! - io_prompt_flag = 0 -! -! Read the goniometer ini file and write info into common block -! - call cad4_read_gon_file (2) -! -! Transmit syspar values to 11/02 -! - slave_load_address = lsypar - nr_load_byte = 64 !load 32 words to lsypar - call cad4_io (f_xfr_mem,cad4_load_syspar,cad4_type_error, - 1 cad4_type_error,cad4_type_error,cad4_type_error, - 2 cad4_type_error,cad4_type_error,cad4_restart_load, - 3 cad4_post_dummy) -! -! Define the proper file for the slave computer -! - mon_file_spec(1:22) = 'LSI_11.EXE' - if (bvers_c .eq. 'C') mon_file_spec(1:22) = 'FALCON.EXE' - if (bvers_c .eq. 'E') mon_file_spec(1:22) = 'FALCNP.EXE' -! -! LOAD THE SLAVE COMPUTER -! - call cad4_load_lsi(mon_file_spec,load_error) -! -! START THE MOTHER TASK -! - mother_file_spec = def_mother_spec - call cad4_start_mother -! - stop - end -! -! - Subroutine cad4_read_gon_file (ISWT) -C----------------------------------------------------------------------- -C Read the CAD-4 Goniometer constants file (goniom.ini) for the -C relevant system parameter values in SYSPAR_VAL. -C----------------------------------------------------------------------- - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - COMMON /INFREE/ IFREE(20),RFREE(20),ICFLAG - COMMON /FREECH/ OCHAR - CHARACTER OCHAR*100,CKEY*6 - include 'CAD4COMM' ! include common block -C----------------------------------------------------------------------- -C Attach goniom.ini to unit 9 -C----------------------------------------------------------------------- - OPEN (UNIT=9, ACCESS='SEQUENTIAL', FILE='goniom.ini', - $ STATUS='OLD', ERR=20) -C----------------------------------------------------------------------- -C Set the SYSPAR_VAL values to SYSPAR_DEF for safety -C----------------------------------------------------------------------- - IF (ISWT .EQ. 2) THEN - DO 90 I = 1,32 - SYSPAR_VAL(I) = SYSPAR_DEF(I) - 90 CONTINUE -C----------------------------------------------------------------------- -C Set the invariant SYSPAR_VAL parameters to local values -C----------------------------------------------------------------------- - SYSPAR_VAL( 7) = 6 - SYSPAR_VAL( 8) = 0 - SYSPAR_VAL( 9) = 18 - SYSPAR_VAL(10) = 2 - SYSPAR_VAL(16) = 0 - ENDIF -C----------------------------------------------------------------------- -C Read a value from goniom.ini. Ignore lines starting with / -C----------------------------------------------------------------------- - 100 READ (9,11000,END=200) OCHAR -11000 FORMAT (A) - IF (OCHAR(1:1) .EQ. '/') GO TO 100 - CKEY = OCHAR(1:6) - IF (CKEY .EQ. 'Dfmodl') GO TO 100 - OCHAR(1:6) = ' ' - CALL FREEFM (1000) - IVAL = IFREE(1) -C----------------------------------------------------------------------- -C Get the Port and Baudrate -C----------------------------------------------------------------------- - IF (ISWT .EQ. 1) THEN - IF (CKEY .EQ. 'Port ') THEN - IPORT = IVAL - ELSE IF (CKEY .EQ. 'Baud ') THEN - IBAUD = IVAL - ENDIF -C----------------------------------------------------------------------- -C Get SYSPAR values for CAD4L routine -C----------------------------------------------------------------------- - ELSE - IF (CKEY .EQ. 'Hivolt') THEN - SYSPAR_VAL(1) = 255 - (IVAL - 255)/3 - ELSE IF (CKEY .EQ. 'Lolevl') THEN - SYSPAR_VAL(2) = 255 - IVAL/5 - ELSE IF (CKEY .EQ. 'Window') THEN - SYSPAR_VAL(3) = 255 - IVAL/5 - ELSE IF (CKEY .EQ. 'Deadtm') THEN - I45 = 9105330*RFREE(1)/5.3 - I4 = I45/32768 - SYSPAR_VAL(4) = I4 - SYSPAR_VAL(5) = I45 - I4*32768 - ELSE IF (CKEY .EQ. 'Termbd') THEN - IVAL = 3*38400/IVAL - SYSPAR_VAL(6) = IAND(IVAL,255) - ELSE IF (CKEY .EQ. 'Thgain') THEN - SYSPAR_VAL(11) = IVAL - ELSE IF (CKEY .EQ. 'Phgain') THEN - SYSPAR_VAL(12) = IVAL - ELSE IF (CKEY .EQ. 'Omgain') THEN - SYSPAR_VAL(13) = IVAL - ELSE IF (CKEY .EQ. 'Kagain') THEN - SYSPAR_VAL(14) = IVAL - ELSE IF (CKEY .EQ. 'Digain') THEN - SYSPAR_VAL(15) = IVAL - ELSE IF (CKEY .EQ. 'Milamp') THEN - SYSPAR_VAL(17) = (3*(IVAL - 10))/10 - ENDIF - ENDIF - GO TO 100 - 200 CLOSE (UNIT = 9) - RETURN -! -! On error load default values for syspar -! -20 do 30 i=1,32 - syspar_val(I) = syspar_def(I) -30 continue - return - end -! -! - Subroutine cad4_restart_load -! -! Subroutine to restart load detached process -! -! 1. reset communication terminal -! 2. create detached process -! 3. exit current process -! - include 'CAD4COMM' ! Include common block -! character*120 error_mess -! -! -! 1. reset communication terminal -! - call cad4_reset_terminal -! -! 2. Create detached process -! -! process_name_c(5:5) = 'E' -! exmess_status = sys$creprc (,process_image_c,,, -! 1 'E_err_'//ibycan_c(2:4),,, -! 2 process_name_c, -! 3 %val(process_prio_l), -! 4 %val(process_uic_l),,) -! if (.not.exmess_status) then -! call cad4_send_oper4 (' Cannot create new load process') -! io_status = sys$getmsg (%val(exmess_status),i,error_mess,,) -! if (.not.io_status) call lib$signal(%val(io_status)) -! call cad4_send_oper4 (error_mess(1:i)) -! end if -! -! 3. Exit current process -! -! call sys$exit (%val(exmess_status)) - stop - end -! -! - Subroutine cad4_start_mother -! -! Subroutine to start detached process with mother image name -! modified: 03-jan-1985 LCB Flag SBC target processor in uic spec -! -! 1. reset communication terminal -! 2. create detached process -! 3. exit current process -! - include 'CAD4COMM' ! Include common block -! character*120 error_mess -! -! 1. reset communication terminal -! - call cad4_reset_terminal -! -! -! 2. Create detached process -! - if (bvers_c.eq.'C') then - process_uic_w(1) = process_uic_w(1).or. #40 - else - process_uic_w(1) = process_uic_w(1).and. #ffbf - end if - process_name_c(1:6)='NRCCAD' -! exmess_status = sys$creprc (,mother_file_spec,,, -! 1 'M_err_'//ibycan_c(2:4),,, -! 2 process_name_c, -! 3 %val(process_prio_l), -! 4 %val(process_uic_l),,) -! if (.not.exmess_status) then -! call cad4_send_oper4 (' Cannot create mother process') -! io_status = sys$getmsg (%val(exmess_status),i,error_mess,,) -! if (.not.io_status) call lib$signal(%val(io_status)) -! call cad4_send_oper4 (error_mess(1:i)) -! end if -! -! 3. Exit current process -! -! call sys$exit (%val(exmess_status)) - stop - end -! -! - Subroutine cad4_load_lsi (filename,ierr) -! -! Subroutine to load LSI via terminal line -! modified: 03-jan-85 LCB Enable load of complete disc blocks -! -! filename ASCII filename string -! ierr 0 - success -! -1 - file open error -! -2 - read error -! - character*(*) filename - integer io_incr -! - external cad4_codx,cad4_type_error,cad4_restart_load - external cad4_post_dummy - include 'CAD4COMM' ! Include Instrument common block -! -! -! First open task image file -! - open (access='direct', - 1 form='unformatted',file=filename, - 2 recl=512,status='old',unit=1,err=20, - 3 iostat=img_io_status) -! - write (l_unit,10010) filename(1:30) -10010 format (' cad4_load_lsi : task image filename = ',a30) -! -! Read first record to get base address, load size and transfer -! address of task image file -! - img_io_record = 1 ! First record has length in bytes - read (1,rec=img_io_record, - 1 iostat=img_io_status,err=30) img_io_buffer_l - img_io_bsa = img_io_buffer_w(#8/2 + 1) ! Get base address - img_io_ldz = img_io_buffer_w(#e/2 + 1) ! Load size (in 32. word blocks) - img_io_xfr = img_io_buffer_w(#e8/2 + 1) ! Transfer address - write (l_unit,10020) img_io_bsa, img_io_ldz, img_io_xfr -10020 format (' : base address = ',z6,/, - 1 ' load size = ',z6, - 2 ' 32-word-blocks',/, - 2 ' XFR address = ',z6) -! -! Reset buffer pointer and record number for read -! - img_io_pointer = 256 ! Offset 256 to force read - img_io_record = 3 ! Skip LUN block - if (bvers_c .eq. char(0)) then - io_incr = 2 - else - io_incr = 8 - end if -! -10 if (img_io_pointer.ge.256.and.img_io_ldz.gt.0) then - read (1,rec=img_io_record, - 1 iostat=img_io_status,err=30) img_io_buffer_l - write (l_unit,10030) img_io_record -10030 format (' : record ',i3,' read from disk') - img_io_record = img_io_record + 1 ! Inc. record no. - img_io_pointer = 0 ! Reset pointer - end if -! - call cad4_io (f_xfr_mem,cad4_codx, - 1 cad4_type_error,cad4_type_error,cad4_type_error, - 2 cad4_type_error,cad4_type_error,cad4_type_error, - 3 cad4_restart_load,cad4_post_dummy) -! - img_io_ldz = img_io_ldz - io_incr ! Dec. no. of 32 word blocks - img_io_pointer = img_io_pointer + io_incr*32 ! Adjust pointer (words) - img_io_bsa = img_io_bsa + io_incr*32*2 ! Base address (bytes) -! - if (img_io_ldz.ge.(1-io_incr)) goto 10 ! Loop -! -! Here if normal end -! - close (unit=1) ! Close task image file - ierr = 0 - return -! -! Here if unable to open task image file -! -20 ierr = -1 - write (l_unit,10040) img_io_status -10040 format (' File open error : ',i5) - return -! -! Here if read error -! -30 ierr = -2 - close(unit=1) - write (l_unit,10050) img_io_status -10050 format (' File read error : ',i5) - return - end -! - Subroutine cad4_check_type (result) -! -! Postprocessing routine for IO call in initialze 11/02 -! output: bvers !bootstrap version character -! lsypar !address of lsi system parameters -! - include 'CAD4COMM' ! Include common block -! -! check if bootstrap version is returned -! -! input_length .eq. 0 means LSI_11 interface -! .ne. 0 and bvers_c .eq. 'C' means Falcon interface -! .ne. 0 and bvers_c .eq. 'E' means Falcon+ interface - if(input_length .le. 0) then - lsypar = lsi_bottom - #40 - bvers_c = char(0) - else - bvers = input_data(1) - if (bvers_c .eq. 'C') lsypar = sbc_bottom - #40 - if (bvers_c .eq. 'E') lsypar = sbcp_bottom - #40 - endif - write (l_unit,10000) bvers_c, lsypar -10000 format(' Cad4_Check_Type: Prom version - ',z4/ - $ ' lsypar - ',z8) - return - end -! - Subroutine cad4_codx -! -! Preprocessing routine for IO call in cad4_load_lsi -! modified: 03-jan-1985 LCB to enable load of complete blocks -! - include 'CAD4COMM' ! Include common block -! - if (img_io_ldz.gt.0) then ! Normal memory block - if (bvers_c .eq. char(0)) then - if (img_io_ldz.eq.1) then - len = 1*32 ! Last 32. word block - else - len = 2*32 ! All other blocks - end if - else - if (img_io_ldz.ge.8) then !complete block? - len = 8*32 !yes! - else - len = img_io_ldz*32 !last 32 word blocks - end if - end if -! - do i = 1, len - output_data_w(i+1) = img_io_buffer_w(i+img_io_pointer) - end do -! - output_data_w(1) = img_io_bsa ! Set load address - output_length = len*2 + 2 ! Length (bytes) -! - else - output_data_w(1) = img_io_xfr ! Set start address - output_length = 2 ! One word - end if -! - return - end -! -! - subroutine cad4_prompt -! -! Pre processing routine to set up a prompt message -! to be printed on 11/02 CAD4 terminal -! - include 'CAD4COMM' - n = 6 -! - if (io_prompt_flag .ne. 0) then - if (io_prompt_flag .gt. 0) then -! -! Put command error into buffer -! - output_buffer(6) = #0d ! write CR - output_buffer(7) = #0a ! write LF - output_buffer_c (8:27) = 'C4L -- command-error' - n = 28 - else -! -! Put i/o error into buffer -! - output_buffer(6) = #0d ! write CR - output_buffer(7) = #0a ! write LF - output_buffer_c (8:23) = 'C4L -- i/o-error' - n = 24 - end if - end if -! -! Put 'C4L>' prompt into buffer -! - output_buffer(n) = #0d ! write CR - output_buffer(n+1) = #0a ! write LF - output_buffer_c (n+2:n+5) = 'C4L>' -! - output_length = n+2 - return - end - -! - - diff --git a/difrac/cad4l.mak b/difrac/cad4l.mak deleted file mode 100644 index 906c843f..00000000 --- a/difrac/cad4l.mak +++ /dev/null @@ -1,14 +0,0 @@ -CFLAGS = -FPc -Od -c -Lr -Gs -Gt 512 -W2 -FL = c:\fortran\bin\fl $(CFLAGS) -ROOT = .. -LIBS = $(ROOT)\libs - -OBJECTS= cad4l.obj cad4io.obj qio.obj freefm.obj gwrite.obj setiou.obj - -EXEC = cad4l.exe - -$(EXEC): $(OBJECTS) - link @cad4l.ovl - -.for.obj: - $(FL) $< diff --git a/difrac/cartc.f b/difrac/cartc.f deleted file mode 100644 index aa50c982..00000000 --- a/difrac/cartc.f +++ /dev/null @@ -1,18 +0,0 @@ -C----------------------------------------------------------------------- -C This subroutine calculates the Cartesian coordinates of a reflection -C----------------------------------------------------------------------- - SUBROUTINE CARTC (XP,YP,ZP) - INCLUDE 'COMDIF' - CO = COS((OMEGA)/DEG) - SO = SIN((OMEGA)/DEG) - CC = COS((CHI)/DEG) - SC = SIN((CHI)/DEG) - CP = COS((PHI)/DEG) - SP = SIN((PHI)/DEG) - ENGTH = 2*SIN((THETA/2)/DEG) - XP = ENGTH*(CO*CC*CP - SO*SP) - YP = ENGTH*(CO*CC*SP + SO*CP) - ZP = ENGTH*CO*SC - RETURN - END - \ No newline at end of file diff --git a/difrac/cellls.f b/difrac/cellls.f deleted file mode 100644 index c42c5ef6..00000000 --- a/difrac/cellls.f +++ /dev/null @@ -1,628 +0,0 @@ -C----------------------------------------------------------------------- -C -C Constrained Cell Parameter Least Squares on Theta Data. -C Adapted from the routine CELLLS of the NRCVAX package. -C -C E.J.Gabe Chemistry Division, N.R.C., Ottawa Canada -C -C 2theta data is taken from the file ORIENT.DA, which must have been -C written by the AL command. -C -C----------------------------------------------------------------------- - SUBROUTINE CELLLS - INCLUDE 'COMDIF' - DIMENSION IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10),BCHI(10), - $ BPHI(10),QOBS(NSIZE) - EQUIVALENCE (IHK(1),IBH(1)),(NREFB(1),IBK(1)),(ILA(1),IBL(1)), - $ (BCOUNT(1),BTHETA(1)),(BBGR1(1),BOMEGA(1)), - $ (BBGR2(1),BCHI(1)),(BTIME(1),BPHI(1)), - $ (ACOUNT(1),QOBS(1)) -C----------------------------------------------------------------------- -C File data input. Skip reflections flagged bad in MM (Psi .ne. 0) -C----------------------------------------------------------------------- - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - IOUT = -1 - CALL SPACEG (IOUT,0) - LAUE = LAUENO - IAXIS = NAXIS - IF (LAUENO .EQ. 4 .OR. LAUENO .EQ. 5) LAUE = 4 - IF (LAUENO .EQ. 6 .OR. LAUENO .EQ. 7) LAUE = 7 - IF (LAUENO .GE. 8 .AND. LAUENO .LE. 12) LAUE = 6 - IF (LAUENO .EQ. 13 .OR. LAUENO .EQ. 14) LAUE = 5 - NUMD = 0 - NBLOKO = 250 - 100 READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,(JUNK, I = 41,70), - $ BPSI,NBL - NBLOKO = NBLOKO + 1 - IF (NBL .NE. 0) THEN - DO 110 NB = 1,NBL - IF (BPSI(NB) .EQ. 0) THEN - NUMD = NUMD + 1 - S = 2.0*SIN(0.5*BTHETA(NB)/DEG)/WAVE - QOBS(NUMD) = S*S - IOH(NUMD) = IBH(NB) - IOK(NUMD) = IBK(NB) - IOL(NUMD) = IBL(NB) - ENDIF - 110 CONTINUE - GO TO 100 - ENDIF -C----------------------------------------------------------------------- -C Do the least squares -C----------------------------------------------------------------------- - IF (NUMD .GE. 6) THEN - WRITE (LPT,11000) WAVE,NUMD - CALL CLSTSQ - ELSE - WRITE (COUT,12000) - CALL GWRITE (ITP,' ') - ENDIF - KI = ' ' - RETURN -10000 FORMAT (/10X,'Constrained Cell Dimension Least-Squares'/) -11000 FORMAT (/' Wavelength',F10.6,'; ',I6,' reflections.') -12000 FORMAT (' Less than 6 reflections. Quit') - END -C----------------------------------------------------------------------- -c General least-squares of lattice parameters -C----------------------------------------------------------------------- - SUBROUTINE CLSTSQ - INCLUDE 'COMDIF' - DIMENSION AI(6),SIG(7,7),PAR(6),QOBS(NSIZE) - EQUIVALENCE (ACOUNT(1),QOBS(1)) - EQUIVALENCE (PAR(1),ASO),(PAR(2),BSO),(PAR(3),CSO), - $ (PAR(4),ALPHA),(PAR(5),BETA),(PAR(6),GAMMA) - DATA ASIG,BSIG,CSIG,DSIG,ESIG,FSIG/6*0.0/, - $ AA,AB,AC,ADD,AE,AF/6*0.0/,DETERM/1.0/,AI/6*0.0/ -C----------------------------------------------------------------------- -C Select the appropriate number of parameters to calculate -C----------------------------------------------------------------------- - WC = 1 - N = 2 - IF (LAUE .EQ. 1) N = 6 - IF (LAUE .EQ. 2) N = 4 - IF (LAUE .EQ. 3) N = 3 - IF (LAUE .EQ. 5) N = 1 - L = N -C----------------------------------------------------------------------- -C Initialize arrays -C----------------------------------------------------------------------- - DO 110 J = 1,7 - DO 100 K = 1,7 - SIG(J,K) = 0.0 - 100 CONTINUE - SIGSQ(J) = 0.0 - SIGMA(J) = 0.0 - 110 CONTINUE -C----------------------------------------------------------------------- -C Accumulate the sums and make the coeficients of the theta equation -C----------------------------------------------------------------------- - DO 140 II = 1,NUMD - I = II - IF (IOH(I) .NE. 0 .OR. IOK(I) .NE. 0 .OR. IOL(I) .NE. 0) THEN - M = L - CALL ETAI (AI,I) - N = M - BI = QOBS(I) - DO 130 J = 1,N - DO 120 K = 1,N - SIG(J,K) = AI(J)*AI(K)*WC + SIG(J,K) - 120 CONTINUE - SIGMA(J) = SIGMA(J) + WC*BI*AI(J) - 130 CONTINUE - ENDIF - 140 CONTINUE - IF (N .EQ. 1) THEN - SIGMA(1) = SIGMA(1)/SIG(1,1) - SIG(1,1) = 1.0/SIG(1,1) - ELSE - NN = N - 1 - DO 150 J = 1,NN - JJ = J + 1 - DO 150 K = JJ,N - SIG(K,J) = SIG(J,K) - 150 CONTINUE - CALL CMATIN (SIG,N,SIGMA,1,DETERM) - ENDIF - IF (DETERM .EQ. 0.0) THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - ENDIF -C----------------------------------------------------------------------- -C Make the sums for the esds -C----------------------------------------------------------------------- - SUMWV = 0.0 - SUMW = 0.0 - DO 170 II = 1,NUMD - I = II - IF (IOH(I) .NE. 0 .OR. IOK(I) .NE. 0 .OR. IOL(I) .NE. 0) THEN - T3 = 0.0 - CALL ETAI(AI,I) - DO 160 K = 1,N - T3 = T3 + AI(K)*SIGMA(K) - 160 CONTINUE - VI = T3 - QOBS(I) - RWGHT = 1 - SUMWV = SUMWV + RWGHT*VI*VI - SUMW = SUMW + RWGHT - ENDIF - 170 CONTINUE -C----------------------------------------------------------------------- -C Sigma squared -C----------------------------------------------------------------------- - DO 180 I = 1,N - SIGSQ(I) = SUMWV*SIG(I,I)/SUMW - 180 CONTINUE -C----------------------------------------------------------------------- -C Calculate a, b, c, alpha, beta, gamma according to the Laue code -C -C Triclinic -C----------------------------------------------------------------------- - IF (LAUE .EQ. 1) THEN - AF = SIGMA(6) - AE = SIGMA(5) - ADD = SIGMA(4) - FSIG = SIGSQ(6) - ESIG = SIGSQ(5) - DSIG = SIGSQ(4) - ENDIF -C----------------------------------------------------------------------- -C Monoclinic - a, b or c unique -C----------------------------------------------------------------------- - IF (LAUE .EQ. 2) THEN - IF (IAXIS .EQ. 1) THEN - AF = SIGMA(4) - FSIG = SIGSQ(4) - ENDIF - IF (IAXIS .EQ. 2) THEN - AE = SIGMA(4) - ESIG = SIGSQ(4) - ENDIF - IF (IAXIS .EQ. 3) THEN - ADD = SIGMA(4) - DSIG = SIGSQ(4) - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Triclinic, monoclinic or orthorhombic -C----------------------------------------------------------------------- - IF (LAUE .EQ. 1 .OR. LAUE .EQ. 2 .OR. LAUE .EQ. 3) THEN - AC = SIGMA(3) - AB = SIGMA(2) - AA = SIGMA(1) - CSIG = SIGSQ(3) - BSIG = SIGSQ(2) - ASIG = SIGSQ(1) - ENDIF -C----------------------------------------------------------------------- -C Tetragonal -C----------------------------------------------------------------------- - IF (LAUE .EQ. 4) THEN - AA = SIGMA(1) - AB = AA - AC = SIGMA(2) - ASIG = SIGSQ(1) - BSIG = ASIG - CSIG = SIGSQ(2) - ENDIF -C----------------------------------------------------------------------- -C Hexagonal and rhombohedral with hexagonal axes -C----------------------------------------------------------------------- - IF (LAUE .EQ. 6) THEN - AA = SIGMA(1) - AB = AA - ADD = AA/2.0 - AC = SIGMA(2) - ASIG = SIGSQ(1) - BSIG = ASIG - DSIG = ASIG/2.0 - CSIG = SIGSQ(2) - ENDIF -C----------------------------------------------------------------------- -C Rhombohedral with rhombohedral axes -C----------------------------------------------------------------------- - IF (LAUE .EQ. 7) THEN - ADD = SIGMA(2) - AE = ADD - AF = ADD - DSIG = SIGSQ(2) - ESIG = DSIG - FSIG = DSIG - ENDIF -C----------------------------------------------------------------------- -C Rhombohedral or cubic -C----------------------------------------------------------------------- - IF (LAUE .EQ. 5 .OR. LAUE .EQ. 7) THEN - AA = SIGMA(1) - AB = AA - AC = AA - ASIG = SIGSQ(1) - BSIG = ASIG - CSIG = ASIG - ENDIF -C----------------------------------------------------------------------- -C Now the actual cell parameters -C----------------------------------------------------------------------- - VK = 1.0/SQRT(AA*AB*AC - AA*AF*AF - AB*AE*AE - AC*ADD*ADD + - $ 2.0*AF*AE*ADD) - ABC = AB*AC - AF*AF - AAC = AA*AC - AE*AE - AAB = AA*AB - ADD*ADD - ASO = VK*SQRT(ABC) - BSO = VK*SQRT(AAC) - CSO = VK*SQRT(AAB) - ARG1 = AE*ADD - AA*AF - ARG2 = AAC*AAB - ARG2 = SQRT(ARG2 - ARG1*ARG1) - CALL CATAN2 (ARG2,ARG1,ANSWER) - ALPHA = ANSWER*DEG - ARG1 = ADD*AF - AB*AE - ARG2 = AAB*ABC - ARG2 = SQRT(ARG2 - ARG1*ARG1) - CALL CATAN2 (ARG2,ARG1,ANSWER) - BETA = ANSWER*DEG - ARG1 = AF*AE - AC*ADD - ARG2 = ABC*AAC - ARG2 = SQRT(ARG2 - ARG1*ARG1) - CALL CATAN2 (ARG2,ARG1,ANSWER) - GAMMA = ANSWER*DEG - SALPHA = SIN(ALPHA/DEG) - SBETA = SIN(BETA/DEG) - SGAMMA = SIN(GAMMA/DEG) -C----------------------------------------------------------------------- -C Determine the standard errors using the quantities derived from the -C least-squares (AA to AF) and their variances -C -C Variances of the direct cell parameters a, b and c -C----------------------------------------------------------------------- - V2 = AA*AB*AC - AA*AF*AF - AB*AE*AE - AC*ADD*ADD + 2.0*ADD*AE*AF - V = SQRT(V2) - V3 = V2*V - TA2 = AB*AC - AF*AF - TB2 = AA*AC - AE*AE - TC2 = AA*AB - ADD*ADD - TA = SQRT(TA2) - TB = SQRT(TB2) - TC = SQRT(TC2) -C----------------------------------------------------------------------- -C Variance of a -C----------------------------------------------------------------------- - TEM = TA2*TA/(2.0*V3) - PASO = TEM*TEM*ASIG - TEM = (V2*AC - TA2*TB2)/(2.0*TA*V3) - PASO = PASO + TEM*TEM*BSIG - TEM = (V2*AB - TA2*TC2)/(2.0*TA*V3) - PASO = PASO + TEM*TEM*CSIG - TEM = TA*(AE*AF - AC*ADD)/V3 - PASO = PASO + TEM*TEM*DSIG - TEM = TA*(ADD*AF - AB*AE)/V3 - PASO = PASO + TEM*TEM*ESIG - TEM = (AF*V2 + TA2*(ADD*AE - AA*AF))/(TA*V3) - PASO = PASO + TEM*TEM*FSIG - PASO = SQRT(PASO) -C----------------------------------------------------------------------- -C Variance of b -C----------------------------------------------------------------------- - TEM = (AC*V2 - TB2*TA2)/(2.0*TB*V3) - PBSO = TEM*TEM*ASIG - TEM = TB2*TB/(2.0*V3) - PBSO = PBSO + TEM*TEM*BSIG - TEM = (AA*V2 - TB2*TC2)/(2.0*TB*V3) - PBSO = PBSO + TEM*TEM*CSIG - TEM = TB*(AE*AF - AC*ADD)/V3 - PBSO = PBSO + TEM*TEM*DSIG - TEM = (AE*V2 + TB2*(ADD*AF - AB*AE))/(TB*V3) - PBSO = PBSO + TEM*TEM*ESIG - TEM = TB*(ADD*AE - AA*AF)/V3 - PBSO = PBSO + TEM*TEM*FSIG - PBSO = SQRT(PBSO) -C----------------------------------------------------------------------- -C Variance of c -C----------------------------------------------------------------------- - TEM = (AB*V2 - TC2*TA2)/(2.0*TC*V3) - PCSO = TEM*TEM*ASIG - TEM = (AA*V2 - TC2*TB2)/(2.0*TC*V3) - PCSO = PCSO + TEM*TEM*BSIG - TEM = TC2*TC/(2.0*V3) - PCSO = PCSO + TEM*TEM*CSIG - TEM = (ADD*V2 + TC2*(AE*AF - AC*ADD))/(TC*V3) - PCSO = PCSO + TEM*TEM*DSIG - TEM = TC*(ADD*AF - AB*AE)/V3 - PCSO = PCSO + TEM*TEM*ESIG - TEM = TC*(ADD*AE - AA*AF)/V3 - PCSO = PCSO + TEM*TEM*FSIG - PCSO = SQRT(PCSO) -C----------------------------------------------------------------------- -C Variances of alpha, beta and gamma from their cosines -C -C Variance of alpha -C----------------------------------------------------------------------- - IF (LAUE .EQ. 1 .OR. LAUE .EQ. 2 .OR. LAUE .EQ. 7) THEN - BOT2 = (AA*AC - AE*AE)*(AA*AB - ADD*ADD) - BOT = SQRT(BOT2) - FAC = (AE*ADD - AA*AF)/(2.0*BOT) - TEM = (AF*BOT + FAC*(2.0*AA*AB*AC-AB*AE*AE-AC*ADD*ADD))/BOT2 - PALPHA = TEM*TEM*ASIG - TEM = FAC*(AA*AA*AC - AA*AE*AE)/BOT2 - PALPHA = PALPHA + TEM*TEM*BSIG - TEM = FAC*(AA*AA*AB - AA*ADD*ADD)/BOT2 - PALPHA = PALPHA + TEM*TEM*CSIG - TEM = (BOT*AE - 2.0*FAC*(ADD*AE*AE - AA*AC*ADD))/BOT2 - PALPHA = PALPHA + TEM*TEM*DSIG - TEM = (ADD*BOT - FAC*2.0*(ADD*ADD*AE - AA*AB*AE))/BOT2 - PALPHA = PALPHA + TEM*TEM*ESIG - PALPHA = PALPHA + AA*AA*FSIG/BOT2 - PALPHA = DEG*SQRT(PALPHA/(SALPHA*SALPHA)) - ENDIF -C----------------------------------------------------------------------- -C Variance of beta -C----------------------------------------------------------------------- - IF (LAUE .EQ. 1 .OR. LAUE .EQ. 2) THEN - BOT2 = (AB*AC - AF*AF)*(AA*AB - ADD*ADD) - BOT = SQRT(BOT2) - FAC = (ADD*AF - AB*AE)/(2.0*BOT) - TEM = FAC*(AB*AB*AC - AB*AF*AF)/BOT2 - PBETA = TEM*TEM*ASIG - TEM = (BOT*AE + FAC*(2.0*AA*AB*AC-AA*AF*AF-AC*ADD*ADD))/BOT2 - PBETA = PBETA + TEM*TEM*BSIG - TEM = FAC*(AA*AB*AB - AB*ADD*ADD)/BOT2 - PBETA = PBETA + TEM*TEM*CSIG - TEM = (BOT*AF - FAC*2.0*(ADD*AF*AF - AB*AC*ADD))/BOT2 - PBETA = PBETA + TEM*TEM*DSIG - PBETA = PBETA + AB*AB*ESIG/BOT2 - TEM = (BOT*ADD - FAC*2.0*(AF*ADD*ADD - AA*AB*AF))/BOT2 - PBETA = PBETA + TEM*TEM*FSIG - PBETA = DEG*SQRT(PBETA/(SBETA*SBETA)) - PGAMMA = 0.0 -C----------------------------------------------------------------------- -C Variance of gamma -C----------------------------------------------------------------------- - BOT2 = (AA*AC - AE*AE)*(AB*AC - AF*AF) - BOT = SQRT(BOT2) - FAC = (AE*AF - AC*ADD)/(2.0*BOT) - TEM = FAC*(AB*AC*AC - AC*AF*AF)/BOT2 - PGAMMA = TEM*TEM*ASIG - TEM = FAC*(AA*AC*AC - AC*AE*AE)/BOT2 - PGAMMA = PGAMMA + TEM*TEM*BSIG - TEM = (ADD*BOT + FAC*(2.0*AA*AB*AC-AB*AE*AE-AA*AF*AF))/BOT2 - PGAMMA = PGAMMA + TEM*TEM*CSIG - PGAMMA = PGAMMA + AC*AC*DSIG/BOT2 - TEM = (AF*BOT - FAC*2.0*(AE*AF*AF - AB*AC*AE))/BOT2 - PGAMMA = PGAMMA + TEM*TEM*ESIG - TEM = (AE*BOT - FAC*2.0*(AE*AE*AF - AA*AC*AF))/BOT2 - PGAMMA = PGAMMA + TEM*TEM*FSIG - PGAMMA = DEG*SQRT(PGAMMA/(SGAMMA*SGAMMA)) - ENDIF - CALL DEVLST (PAR) - WRITE (LPT,11000) ASO, PASO, BSO, PBSO, CSO, PCSO, - $ ALPHA,PALPHA,BETA,PBETA,GAMMA,PGAMMA - RETURN -10000 FORMAT (10X,' Singular Matrix') -11000 FORMAT (/18X,' Cell Errors '/ - $ 8X,'a ',F12.6,F13.7/ - $ 8X,'b ',F12.6,F13.7/ - $ 8X,'c ',F12.6,F13.7/ - $ 8X,'Alpha ',F9.3,4X,F9.4/ - $ 8X,'Beta ',F9.3,4X,F9.4/ - $ 8X,'Gamma ',F9.3,4X,F9.4/) - END -C----------------------------------------------------------------------- -C Determine the AI values from h, k and l -C----------------------------------------------------------------------- - SUBROUTINE ETAI (AI,I) - INCLUDE 'COMDIF' - DIMENSION AI(6) -C----------------------------------------------------------------------- -C Triclinic -C----------------------------------------------------------------------- - IF (LAUE .EQ. 1) THEN - AI(6) = 2*IOK(I)*IOL(I) - AI(5) = 2*IOH(I)*IOL(I) - AI(4) = 2*IOH(I)*IOK(I) - ENDIF -C----------------------------------------------------------------------- -C Monoclinic -C----------------------------------------------------------------------- - IF (LAUE .EQ. 2) THEN - IF (IAXIS .EQ. 1) AI(4) = 2*IOK(I)*IOL(I) - IF (IAXIS .EQ. 2) AI(4) = 2*IOH(I)*IOL(I) - IF (IAXIS .EQ. 3) AI(4) = 2*IOH(I)*IOK(I) - ENDIF -C----------------------------------------------------------------------- -C Triclinic, monoclinic or orthorhombic -C----------------------------------------------------------------------- - IF (LAUE .LE. 3) THEN - AI(3) = IOL(I)*IOL(I) - AI(2) = IOK(I)*IOK(I) - AI(1) = IOH(I)*IOH(I) - RETURN - ENDIF -C----------------------------------------------------------------------- -C Tetragonal -C----------------------------------------------------------------------- - IF (LAUE .EQ. 4) THEn - AI(2) = IOL(I)*IOL(I) - AI(1) = IOH(I)*IOH(I) + IOK(I)*IOK(I) - RETURN - ENDIF -C----------------------------------------------------------------------- -C Hexagonal and rhombohedral with hexagonal axes -C----------------------------------------------------------------------- - IF (LAUE .EQ. 6) THEN - AI(2) = IOL(I)*IOL(I) - AI(1) = IOH(I)*IOH(I) + IOK(I)*IOK(I) + IOH(I)*IOK(I) - RETURN - ENDIF -C----------------------------------------------------------------------- -C Rhombohedral with rhombohedral axes -C----------------------------------------------------------------------- - IF (LAUE .EQ. 7) - $ AI(2) = 2*(IOH(I)*IOK(I) + IOH(I)*IOL(I) + IOK(I)*IOL(I)) -C----------------------------------------------------------------------- -C Rhombohedral or cubic -C----------------------------------------------------------------------- - IF (LAUE .EQ. 5 .OR. LAUE .EQ. 7) - $ AI(1) = IOH(I)*IOH(I) + IOK(I)*IOK(I) + IOL(I)*IOL(I) - RETURN - END -C----------------------------------------------------------------------- -C List the obs and calc data in the input form -C----------------------------------------------------------------------- - SUBROUTINE DEVLST (PAR) - INCLUDE 'COMDIF' - DIMENSION PAR(6),REC(6),Q(6),QOBS(NSIZE) - EQUIVALENCE (ACOUNT(1),QOBS(1)) -C----------------------------------------------------------------------- -C Make the reciprocal cell, (Int. Tab. Vol. II, p.106. -C----------------------------------------------------------------------- - PAR4 = PAR(4)/DEG - PAR5 = PAR(5)/DEG - PAR6 = PAR(6)/DEG - SUM = (PAR4 + PAR5 + PAR6)/2.0 - XPRSS = SIN(SUM)*SIN(SUM - PAR4)*SIN(SUM - PAR5)*SIN(SUM - PAR6) - VOL = 2.0*PAR(1)*PAR(2)*PAR(3)*SQRT(XPRSS) - REC(1) = PAR(2)*PAR(3)*SIN(PAR4)/VOL - REC(2) = PAR(3)*PAR(1)*SIN(PAR5)/VOL - REC(3) = PAR(1)*PAR(2)*SIN(PAR6)/VOL - REC(4) = (COS(PAR5)*COS(PAR6) - COS(PAR4))/(SIN(PAR5)*SIN(PAR6)) - REC(5) = (COS(PAR6)*COS(PAR4) - COS(PAR5))/(SIN(PAR6)*SIN(PAR4)) - REC(6) = (COS(PAR4)*COS(PAR5) - COS(PAR6))/(SIN(PAR4)*SIN(PAR5)) -C----------------------------------------------------------------------- -C Calculate the metric tensor Q -C----------------------------------------------------------------------- - Q(1) = REC(1)*REC(1) - Q(2) = REC(2)*REC(2) - Q(3) = REC(3)*REC(3) - Q(4) = REC(2)*REC(3)*REC(4) - Q(5) = REC(3)*REC(1)*REC(5) - Q(6) = REC(1)*REC(2)*REC(6) -C----------------------------------------------------------------------- -C Derive the Obs and Calc data -C----------------------------------------------------------------------- - DO 100 I = 1, NUMD - QCALC = IOH(I)*IOH(I)*Q(1) + IOK(I)*IOK(I)*Q(2) + - $ IOL(I)*IOL(I)*Q(3) + 2*IOK(I)*IOL(I)*Q(4) + - $ 2*IOL(I)*IOH(I)*Q(5) + 2*IOH(I)*IOK(I)*Q(6) - THOBS = 2.0*DEG*ACOS(SQRT(1.0 - (QOBS(I)*WAVE*WAVE/4.))) - THCAL = 2.0*DEG*ACOS(SQRT(1.0 - (QCALC *WAVE*WAVE/4.))) - 100 CONTINUE - RETURN - END -C----------------------------------------------------------------------- -C Find atan(A/B) and put the answer C in the 0 to 180 range -C----------------------------------------------------------------------- - SUBROUTINE CATAN2 (A,B,C) - PI = 3.141592654 - C = PI/2.0 - IF (B .NE. 0) THEN - C = ATAN(ABS(A/B)) - IF (B .LT. 0) C = PI - C - ENDIF - RETURN - END -C----------------------------------------------------------------------- -C Matrix inversion with accompanying solution of linear equations -C----------------------------------------------------------------------- - SUBROUTINE CMATIN (A,N,B,M,DETERM) - DIMENSION IPIVOT(7),A(7,7),B(7,1),INDEX(7,2),PIVOT(7) - EQUIVALENCE (IROW,JROW),(ICOLUM,JCOLUM),(AMAX,T,SWAP) - I = 1 - EPS = .0000000001 - DETERM = 1.0 - DO 100 J = 1,N - IPIVOT(J) = 0 - 100 CONTINUE -C----------------------------------------------------------------------- -C Search for the pivot element -C----------------------------------------------------------------------- - DO 200 I = 1,N - AMAX = 0.0 - DO 120 J = 1,N - IF (IPIVOT(J) .NE. 1) THEN - DO 110 K = 1,N - IF (IPIVOT(K) .GT. 1) RETURN - IF (IPIVOT(K) .LT. 1) THEN - IF (ABS(AMAX) .LT. ABS(A(J,K))) THEN - IROW = J - ICOLUM = K - AMAX = A(J,K) - ENDIF - ENDIF - 110 CONTINUE - ENDIF - 120 CONTINUE - IPIVOT(ICOLUM) = IPIVOT(ICOLUM) + 1 -C----------------------------------------------------------------------- -C Interchange rows to put the pivot element on the main diagonal -C----------------------------------------------------------------------- - IF (IROW .NE. ICOLUM) THEN - DETERM = - DETERM - DO 130 L = 1,N - SWAP = A(IROW,L) - A(IROW,L) = A(ICOLUM,L) - A(ICOLUM,L) = SWAP - 130 CONTINUE - IF (M .GT. 0) THEN - DO 140 L = 1,M - SWAP = B(IROW,L) - B(IROW,L) = B(ICOLUM,L) - B(ICOLUM,L) = SWAP - 140 CONTINUE - ENDIF - ENDIF - INDEX(I,1) = IROW - INDEX(I,2) = ICOLUM - PIVOT(I) = A(ICOLUM,ICOLUM) - IF (ABS(PIVOT(I)) .LE. EPS) THEN - DETERM = 0.0 - RETURN - ENDIF - DETERM = DETERM*PIVOT(I) -C----------------------------------------------------------------------- -C Divide the pivot row by the pivot element -C----------------------------------------------------------------------- - A(ICOLUM,ICOLUM) = 1.0 - DO 150 L = 1,N - A(ICOLUM,L) = A(ICOLUM,L)/PIVOT(I) - 150 CONTINUE - IF (M .GT. 0) THEN - DO 160 L = 1,M - B(ICOLUM,L) = B(ICOLUM,L)/PIVOT(I) - 160 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Reduce non-pivot rows -C----------------------------------------------------------------------- - DO 200 L1 = 1,N - IF (L1 .NE. ICOLUM) THEN - T = A(L1,ICOLUM) - A(L1,ICOLUM) = 0.0 - DO 170 L = 1,N - A(L1,L) = A(L1,L) - A(ICOLUM,L)*T - 170 CONTINUE - IF (M .GT. 0) THEN - DO 180 L = 1,M - B(L1,L) = B(L1,L) - B(ICOLUM,L)*T - 180 CONTINUE - ENDIF - ENDIF - 200 CONTINUE -C----------------------------------------------------------------------- -C Interchange columns -C----------------------------------------------------------------------- - DO 220 I = 1,N - L = N + 1 - I - IF (INDEX(L,1) .NE. INDEX(L,2)) THEN - JROW = INDEX(L,1) - JCOLUM = INDEX(L,2) - DO 210 K = 1,N - SWAP = A(K,JROW) - A(K,JROW) = A(K,JCOLUM) - A(K,JCOLUM) = SWAP - 210 CONTINUE - ENDIF - 220 CONTINUE - RETURN - END - diff --git a/difrac/cellsd.f b/difrac/cellsd.f deleted file mode 100644 index e4f8a7a1..00000000 --- a/difrac/cellsd.f +++ /dev/null @@ -1,123 +0,0 @@ -C----------------------------------------------------------------------- -C subroutine to calculate the s.d.'s of the cell parameters from the -C s.d.'s of the orientation matrix -C----------------------------------------------------------------------- - SUBROUTINE CELLSD - INCLUDE 'COMDIF' - DIMENSION RT(3,3),ANGS(3),ANG(3),RS(3,3),SRT(3,3) - DIMENSION SAS(3),SANS(3),SAN(3),SA(3) - DO 100 I = 1,3 - DO 100 J = 1,3 - R(I,J) = R(I,J)/WAVE - 100 CONTINUE -C----------------------------------------------------------------------- -C Real and reciprocal angles passed from LSORMT in CANG and CANGS -C----------------------------------------------------------------------- - DO 110 J = 1,3 - ANG(J) = CANG(J) - ANGS(J) = CANGS(J) - SANG(J) = SIN(CANG(J)/DEG) - CANG(J) = COS(CANG(J)/DEG) - SANGS(J) = SIN(CANGS(J)/DEG) - CANGS(J) = COS(CANGS(J)/DEG) - 110 CONTINUE - DO 120 I = 1,3 - DO 120 J = 1,3 - RS(I,J) = R(I,J)*R(I,J) - SR(I,J) = SR(I,J)*SR(I,J) - 120 CONTINUE -C----------------------------------------------------------------------- -C Use the RT array for the S matrix -C----------------------------------------------------------------------- - DO 130 I = 1,3 - DO 130 J = 1,3 - SRT(I,J) = SR(J,I) - 130 CONTINUE - CALL MATRIX (SRT,RS,RT,RT,'MATMUL') - SSG(1,1) = 4.0*RT(1,1) - SSG(2,2) = 4.0*RT(2,2) - SSG(3,3) = 4.0*RT(3,3) - SSG(1,2) = RT(1,2) + RT(2,1) - SSG(1,3) = RT(1,3) + RT(3,1) - SSG(2,3) = RT(2,3) + RT(3,2) - DO 140 J = 1,3 - SANG(J) = SANG(J)*SANG(J) - SANGS(J) = SANGS(J)*SANGS(J) - CANG(J) = CANG(J)*CANG(J) - CANGS(J) = CANGS(J)*CANGS(J) - AP(J) = AP(J)*AP(J) - APS(J) = APS(J)*APS(J) - SAS(J) = SSG(J,J)/(4.0*GI(J,J)) - 140 CONTINUE - XA = SAS(2)*GI(2,3)*GI(2,3)/APS(2) - YA = SAS(3)*GI(2,3)*GI(2,3)/APS(3) - ZA = APS(2)*APS(3)*SANGS(1) - SANS(1) = (SSG(2,3) + XA + YA)/ZA - XA = SAS(1)*GI(1,3)*GI(1,3)/APS(1) - YA = SAS(3)*GI(1,3)*GI(1,3)/APS(3) - ZA = APS(1)*APS(3)*SANGS(2) - SANS(2) = (SSG(1,3) + XA + YA)/ZA - XA = SAS(1)*GI(1,2)*GI(1,2)/APS(1) - YA = SAS(2)*GI(1,2)*GI(1,2)/APS(2) - ZA = APS(1)*APS(2)*SANGS(3) - SANS(3) = (SSG(1,2) + XA + YA)/ZA - XA = SANS(1) + SANS(2)*CANG(3) + SANS(3)*CANG(2) - YA = SANG(2)*SANGS(3) - SAN(1) = XA/YA - XA = SANS(1)*CANG(3) + SANS(2) + SANS(3)*CANG(1) - YA = SANG(3)*SANGS(1) - SAN(2) = XA/YA - XA = SANS(1)*CANG(2) + SANS(2)*CANG(1) + SANS(3) - YA = SANG(1)*SANGS(2) - SAN(3) = XA/YA - XA = SAS(1)/APS(1) - YA = SANS(2)*CANGS(2)/SANGS(2) - ZA = SAN(3)*CANG(3)/SANG(3) - SA(1) = AP(1)*(XA + YA + ZA) - XA = SAS(2)/APS(2) - YA = SANS(3)*CANGS(3)/SANGS(3) - ZA = SAN(1)*CANG(1)/SANG(1) - SA(2) = AP(2)*(XA + YA + ZA) - XA = SAS(3)/APS(3) - YA = SANS(1)*CANGS(1)/SANGS(1) - ZA = SAN(2)*CANG(2)/SANG(2) - SA(3) = AP(3)*(XA + YA + ZA) -C----------------------------------------------------------------------- -C Form the s.d.'s from the variances -C----------------------------------------------------------------------- - DO 150 J = 1,3 - SA(J) = SQRT(SA(J)) - SAS(J) = SQRT(SAS(J)) - SAN(J) = DEG*SQRT(SAN(J)) - SANS(J) = DEG*SQRT(SANS(J)) - 150 CONTINUE -C----------------------------------------------------------------------- -C Store the R-matrix times the wavelength -C----------------------------------------------------------------------- - DO 160 I = 1,3 - DO 160 J = 1,3 - R(I,J) = R(I,J)*WAVE - 160 CONTINUE -C----------------------------------------------------------------------- -C Put the correct values of the cell parameters in COMMON -C----------------------------------------------------------------------- - DO 170 J = 1,3 - SANG(J) = SIN(ANG(J)/DEG) - CANG(J) = COS(ANG(J)/DEG) - SANGS(J) = SIN(ANGS(J)/DEG) - CANGS(J) = COS(ANGS(J)/DEG) - APS(J) = SQRT(APS(J)) - AP(J) = SQRT(AP(J)) - 170 CONTINUE - WRITE (LPT,10000) AP(1),AP(2),AP(3),ANG(1),ANG(2),ANG(3), - $ SA(1), SA(2), SA(3), SAN(1), SAN(2), SAN(3) - WRITE (LPT,11000) APS(1),APS(2),APS(3),ANGS(1),ANGS(2),ANGS(3), - $ SAS(1),SAS(2),SAS(3),SANS(1),SANS(2),SANS(3) - RETURN -10000 FORMAT (/,' Real Cell'/ - $ 3X,'a', 11X,'b', 11X,'c', 9X,'alpha', 6X, 'beta', 5X,'gamma'/ - $ 3(F9.5,3X),3(F7.3,3X)/3(F9.5,3X),3(F7.3,3X)) -11000 FORMAT (/,' Reciprocal Cell'/ - $ 3X,'a*',10X,'b*',10X,'c*',8X,'alpha*',5X, 'beta*',4X,'gamma*'/ - $ ,3(1X,F8.6,3X),3(F7.3,3X)/3(1X,F8.6,3X),3(F7.3,3X)) - END diff --git a/difrac/cent8.f b/difrac/cent8.f deleted file mode 100644 index 03f34af7..00000000 --- a/difrac/cent8.f +++ /dev/null @@ -1,405 +0,0 @@ -C----------------------------------------------------------------------- -C 8-Reflection Centring Routine July.80 -C The treatment follows INT TAB V.4. pp. 282 -C For the CAD-4 the treatment is the same as described in the CAD-4 -C Manual as corrected in the note by Y. Le Page -C----------------------------------------------------------------------- - SUBROUTINE CENT8 - INCLUDE 'COMDIF' - DIMENSION T8(8),D8(8),A8(8),P8(8) - DATA RA/57.2958/ - INTEGER INTERRUPT - REAL MPRESET - 100 WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - IF (DFMODL .EQ. 'CAD4') THEN - WRITE (COUT,14900) - DT = RFREE(1) - ISLIT = 10.0*DT + 0.5 - IF (ISLIT .EQ. 0) ISLIT = 40 - IF (ISLIT .LT. 10) ISLIT = 10 - IF (ISLIT .GT. 60) ISLIT = 60 - ELSE - ISLIT = 0 - WRITE (COUT,15000) IFRDEF,IDTDEF,IDODEF,IDCDEF - CALL FREEFM (ITR) - DT = RFREE(1) - DO = RFREE(2) - DC = RFREE(3) - IF (DT .EQ. 0) DT = IDTDEF - IF (DO .EQ. 0) DO = IDODEF - IF (DC .EQ. 0) DC = IDCDEF - 110 DT = DT/IFRDEF - DO = DO/IFRDEF - DC = DC/IFRDEF - WRITE (COUT,16000) - CALL FREEFM (ITR) - MPRESET = RFREE(1) - IF (MPRESET .EQ. 0) MPRESET = 1000.0 - WRITE (COUT,18000) - CALL FREEFM (ITR) - AFRAC = RFREE(1) - IF (AFRAC .EQ. 0) AFRAC = 0.5 - ENDIF - DO 115 I = 1,10 - IHK(I) = 0 - NREFB(I) = 0 - ILA(I) = 0 - 115 CONTINUE -C----------------------------------------------------------------------- -C Get the reflections to be used -C----------------------------------------------------------------------- - WRITE (COUT,19000) - CALL GWRITE (ITP,' ') - I = 0 - IREFS = 0 - 120 WRITE (COUT,34000) - CALL FREEFM (ITR) - IH = IFREE(1) - IK = IFREE(2) - IL = IFREE(3) - IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN - ISTAN = 0 - DPSI = 0 - MREF = 0 - IPRVAL = 1 - CALL ANGCAL - IF (IVALID .EQ. 0) THEN - I = I + 1 - IHK(I) = IH - NREFB(I) = IK - ILA(I) = IL - IREFS = I - ENDIF - GO TO 120 - ENDIF - IF (I .EQ. 0) THEN - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Set the first reflection as a check. (Probably unnecessary now) -C----------------------------------------------------------------------- - IH = IHK(1) - IK = NREFB(1) - IL = ILA(1) - IPRVAL = 0 - CALL ANGCAL - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC) - CALL SHUTTR (1) -C WRITE (COUT,22000) -C CALL YESNO ('Y',ANS) -C IF (ANS .EQ. 'N') GO TO 100 -C----------------------------------------------------------------------- -C Make and store the 8 angular combinations in T8,D8,A8,P8 -C----------------------------------------------------------------------- - DO 200 J = 1,IREFS - IH = IHK(J) - IK = NREFB(J) - IL = ILA(J) - IPRVAL = 0 - IF (DFMODL .NE. 'CAD4') THEN - CALL ANGCAL - TNEG = -THETA - CALL MOD360 (TNEG) - CNEG = -CHI - CALL MOD360 (CNEG) - PNEG = 180.0 + PHI - CALL MOD360 (PNEG) - T8(1) = THETA - T8(2) = THETA - T8(3) = TNEG - T8(4) = TNEG - T8(5) = THETA - T8(6) = THETA - T8(7) = TNEG - T8(8) = TNEG - DO 130 I = 1,8 - D8(I) = OMEGA - 130 CONTINUE - OMNEG = -OMEGA - CALL MOD360(OMNEG) - DO 140 I = 3,6 - D8(I) = OMNEG - 140 CONTINUE - A8(1) = CHI - A8(2) = CNEG - A8(7) = CNEG - A8(8) = CHI - CNEG = 180.0 + CNEG - CALL MOD360 (CNEG) - A8(4) = CNEG - A8(5) = CNEG - CNEG = 180 + CHI - CALL MOD360 (CNEG) - A8(3) = CNEG - A8(6) = CNEG - P8(1) = PHI - P8(2) = PNEG - P8(3) = PHI - P8(4) = PNEG - P8(5) = PNEG - P8(6) = PHI - P8(7) = PNEG - P8(8) = PHI -C----------------------------------------------------------------------- -C For CAD-4 :-- -C Work out the 8 settings, as in CAD-4 manual, with the arcs of the -C goniometer head are horizontal and vertical - heaven knows why!! -C----------------------------------------------------------------------- - ELSE - DPSI = 0 - ISTAN = 0 - CALL ANGCAL - PSI = 360.0 - PHI -C----------------------------------------------------------------------- -C Rotate psi by -phi to get required position. This is approximate -C but good enough for alignment to start -C----------------------------------------------------------------------- - DPSI = 10.0 - CALL ANGCAL -C----------------------------------------------------------------------- -C Generate positions 1, 2, 3 and 4 from this -C----------------------------------------------------------------------- - TNEG = -THETA - CALL MOD360 (TNEG) - T8(1) = THETA - T8(2) = TNEG - T8(3) = THETA - T8(4) = TNEG - D8(1) = OMEGA - D8(2) = OMEGA - OMEGA = -OMEGA - CALL MOD360 (OMEGA) - D8(3) = OMEGA - D8(4) = OMEGA - A8(1) = CHI - A8(2) = CHI - A8(3) = 180.0 - CHI - CALL MOD360 (A8(3)) - A8(4) = A8(3) - P8(1) = PHI - P8(2) = PHI - PHI = 180.0 + PHI - CALL MOD360(PHI) - P8(3) = PHI - P8(4) = PHI -C----------------------------------------------------------------------- -C Calculate the position at Phi = 90 and take the settings at -C 180 + Phi and -Chi from there to generate settings 5, 6, 7 and 8 -C----------------------------------------------------------------------- - PSI = PSI - 90.0 - CALL MOD360 (PSI) - CALL ANGCAL - T8(5) = THETA - T8(6) = TNEG - T8(7) = THETA - T8(8) = TNEG - D8(5) = OMEGA - D8(6) = OMEGA - OMEGA = -OMEGA - CALL MOD360 (OMEGA) - D8(7) = OMEGA - D8(8) = OMEGA - CHI = -CHI - CALL MOD360 (CHI) - A8(5) = CHI - A8(6) = CHI - CHI = 180.0 - CHI - CALL MOD360 (CHI) - A8(7) = CHI - A8(8) = CHI - PHI = 180.0 + PHI - CALl MOD360 (PHI) - P8(5) = PHI - P8(6) = PHI - PHI = - PHI - CALl MOD360 (PHI) - P8(7) = PHI - P8(8) = PHI -C write (cout,99999) (i,t8(i),d8(i),a8(i),p8(i), i=1,8) -C99999 format (i3,4f10.3) -C call gwrite (itp,' ') - ENDIF -C----------------------------------------------------------------------- -C Set the 8 different settings, align them and store the results -C in T8,D8,A8 AND P8. -C----------------------------------------------------------------------- - TT0 = 0 - OM0 = 0 - CH0 = 0 - MREF = 0 - CALL SHUTTR (1) - DO 150 I = 1,8 - 145 ITRY = 1 - THETA = T8(I) - OMEGA = D8(I) - CHI = A8(I) - PHI = P8(I) - MREF = MREF + 1 - CALL HKLN (IH,IK,IL,MREF) - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC) - IF (ICC .NE. 0) THEN - WRITE (COUT,23000) MREF,IH,IK,IL - CALL GWRITE (ITP,' ') - GO TO 200 - ENDIF - WRITE (COUT,24000) IH,IK,IL,THETA,OMEGA,CHI,PHI - CALL GWRITE (ITP,' ') - WRITE (LPT,24000) IH,IK,IL,THETA,OMEGA,CHI,PHI - CALL WXW2T (DT,DO,DC,ISLIT) - CALL SHUTTR (1) - CALL CCTIME (MPRESET,COUNT) - CALL KORQ(INTERRUPT) - IF(INTERRUPT .NE. 1) THEN - WRITE(COUT,37000) - RETURN - ENDIF - CALL SHUTTR (-1) - IF (KI .EQ. 'FF') THEN - IF (ITRY .EQ. 1) THEN - WRITE (LPT,25000) MREF,IH,IK,IL - WRITE (COUT,25000) MREF,IH,IK,IL - CALL GWRITE (ITP,' ') - ITRY = 2 - GO TO 145 - ELSE IF (ITRY .EQ. 2) THEN - WRITE (LPT,25100) MREF,IH,IK,IL - WRITE (COUT,25100) MREF,IH,IK,IL - CALL GWRITE (ITP,' ') - GO TO 200 - ENDIF - ENDIF - WRITE (COUT,26000) RTHETA,ROMEGA,RCHI,RPHI,COUNT - CALL GWRITE (ITP,' ') - WRITE (LPT,26000) RTHETA,ROMEGA,RCHI,RPHI,COUNT - T8(I) = RTHETA - D8(I) = ROMEGA - A8(I) = RCHI - P8(I) = RPHI - 150 CONTINUE - CALL SHUTTR (-1) -C----------------------------------------------------------------------- -C Analyse the results for CAD4 or all others -C----------------------------------------------------------------------- - DO 160 I = 1,8 - IF (T8(I) .GE. 180.0) T8(I) = T8(I) - 360.0 - TT0 = TT0 + T8(I) - IF (D8(I) .GE. 180.0) D8(I) = D8(I) - 360.0 - OM0 = OM0 + D8(I) - CH0 = CH0 + A8(I) - 160 CONTINUE - EXPCT = 0. - CALL ANG360(TT0,EXPCT) - TT0 = TT0/8.0 - CALL ANG360(OM0,EXPCT) - OM0 = OM0/8.0 - CALL ANG360(CH0,EXPCT) - CH0 = CH0/8.0 - WRITE (COUT,28000) TT0,OM0,CH0 - CALL GWRITE (ITP,' ') - WRITE (LPT,28000) TT0,OM0,CH0 -C----------------------------------------------------------------------- -C Get the true values of the angles -C----------------------------------------------------------------------- - IF (DFMODL .NE. 'CAD4') THEN - TT0 = T8(1)+T8(2)+T8(5)+T8(6)-T8(3)-T8(4)-T8(7)-T8(8) - EXPCT = 8*T8(1) - CALL ANG360(TT0,EXPCT) - OM0 = D8(1)+D8(2)+D8(7)+D8(8)-D8(3)-D8(4)-D8(5)-D8(6) - EXPCT = 8*D8(1) - CALL ANG360(OM0,EXPCT) - CH0 = A8(1)+A8(3)+A8(6)+A8(8)-A8(2)-A8(4)-A8(5)-A8(7) - EXPCT = 8*A8(1) - CALL ANG360(CH0,EXPCT) - TT0 = TT0/8.0 - OM0 = OM0/8.0 - CALL MOD360 (OM0) - CH0 = CH0/8.0 -C BCOUNT(J-1) = TT0 -C BBGR1(J-1) = OM0 -C BBGR2(J-1) = CH0 -C BTIME(J-1) = PHI - WRITE (COUT,29000) TT0,OM0,CH0,PHI - CALL GWRITE (ITP,' ') - WRITE (LPT,29000) TT0,OM0,CH0,PHI - CHXL = A8(1)+A8(2)+A8(3)+A8(4)-A8(5)-A8(6)-A8(7)-A8(8) - EXPCT = 0. - CALL ANG360(CHXL,EXPCT) - CHC = A8(1)+A8(2)+A8(5)+A8(6)-A8(3)-A8(4)-A8(7)-A8(8) - CALL ANG360(CHC,EXPCT) - CHXL = CHXL/8.0 - CHC = CHC/8.0 - WRITE (COUT,30000) CHXL,CHC - CALL GWRITE (ITP,' ') - WRITE (LPT,30000) CHXL,CHC - ELSE - OM0 = (D8(1)-D8(2)+D8(3)-D8(4)+D8(5)-D8(6)+D8(7)-D8(8))/8.0 - CH0 = (A8(1)-A8(2)+A8(3)-A8(4)+A8(5)-A8(6)+A8(7)-A8(8))/8.0 - DMON = 5.4*CH0*SIN(0.5*T8(1)/RA) - VER = 216.5*TAN(DMON/RA) - HOR = 3.78*OM0 - DETEC = 3.02*(TT0 - OM0) - WRITE (COUT,35000) DETEC,HOR,VER,DMON - CALL GWRITE (ITP,' ') - WRITE (LPT,35000) DETEC,HOR,VER,DMON - TT0 = (T8(1)-T8(2)+T8(3)-T8(4)+T8(5)-T8(6)+T8(7)-T8(8))/8.0 - OMET = (D8(1)+D8(2)-D8(3)-D8(4)-A8(5)-A8(6)+A8(7)+A8(8))/8.0 - CHIT = (A8(1)+A8(2)-A8(3)-A8(4)-D8(5)-D8(6)+D8(7)+D8(8))/8.0 - CHSIGN = 1.0 - IF (A8(1) .GT. 180.0) CHSIGN = -1.0 - CHIT = CHSIGN*(90.0 + CHIT) - CALL MOD360 (CHIT) - PHIT = 0.0 - WRITE (COUT,36000) TT0,OMET,CHIT,PHIT - CALL GWRITE (ITP,'%') - WRITE (LPT,36000) TT0,OMET,CHIT,PHIT - ENDIF - 200 CONTINUE - KI = ' ' - RETURN -10000 FORMAT (' 8 Reflection Centring (Y) ? ',$) -C12000 FORMAT (' *** WARNING --- Remove the low temp. arm *** ',/, -C $ ' Type the Source-to-Crystal distance (',I3,'mm) ',$) -C14000 FORMAT (' Type the Crystal-to-Detector distance (',I3,'mm) ',$) -14900 FORMAT (' Type the horizontal slit width in mms (4.0) ',$) -15000 FORMAT (' Type the 2T,Om,Ch step size in 1/',I3,'th', - $ ' (',I2,',',I2,',',I2,') ',$) -16000 FORMAT (' Type the count preset per step (1000.0) ',$) -18000 FORMAT (' Type the max count cutoff fraction (0.5) ',$) -19000 FORMAT (' Type h,k,l for reflections to be used (End) ') -C22000 FORMAT (' The 1st reflection is set. Is everything OK (Y) ? ',$) -23000 FORMAT (' Setting',I2,', Collision. Cannot complete',3I4) -24000 FORMAT (' Starting values ',3I4,4F10.3) -25000 FORMAT (' Setting',I2,' of',3I4,' failed on first attempt.') -25100 FORMAT (' Setting',I2,' of',3I4,' failed. Cannot complete') -26000 FORMAT (' Final values ',12X,4F10.3,F8.0) -28000 FORMAT (' Zero Values of TT,OM,CH ',3F8.3) -29000 FORMAT (' True values of TT,OM,CH ',3F8.3,' (at Phi',F8.3,')') -30000 FORMAT (' Delta-chi Crystal ',F8.3,5X,'Delta-chi Counter ', - $ F8.3//) -C31000 FORMAT (' SXT ',F10.3,' SXO',F10.3,' CXT',F10.3) -C32000 FORMAT (' SYT ',F10.3,' SYO',F10.3,' CYT',F10.3//) -34000 FORMAT (' Next h,k,l (End) ',$) -35000 FORMAT (' Offsets: Det',F7.3,'mm, Hor',F7.3,'mm, ', - $ 'Ver',F7.3,'mm, Mon',F7.3,'deg.') -36000 FORMAT (' True 2Theta Omega Chi Phi'/2X,4F10.3/) -37000 FORMAT (' Operation interrupted by user') - END -C----------------------------------------------------------------------- -C Routine to make the difference between ANG and EXPCT small -C----------------------------------------------------------------------- - SUBROUTINE ANG360 (ANG,EXPCT) - 100 D = EXPCT - ANG - ISIGN = 1 - IF (D .LT. 0.) ISIGN = -1 - IF (ABS(D) .GE. 180.0) THEN - ANG = ANG + ISIGN*360.0 - GO TO 100 - ENDIF - RETURN - END diff --git a/difrac/centre.f b/difrac/centre.f deleted file mode 100644 index 893bcea8..00000000 --- a/difrac/centre.f +++ /dev/null @@ -1,507 +0,0 @@ -C----------------------------------------------------------------------- -C Routine to align one circle by accumulating a distribution -C of intensity values against degrees & then -C finding the median of the distribution. -C -C Modifications: Mark Koennecke, April 2000 -C Added code for doing PH optimizations as well. -C Added code for monitoring the centering process as well. -C When a peak is not found, drive back to start and give an FP error -C code instead of an FF. Then the alignement of another circle -C might resolve the issue. -C----------------------------------------------------------------------- - SUBROUTINE CENTRE (DX,ANG,ISLIT) - INCLUDE 'COMDIF' - DIMENSION XA(100),YA(100),AN(4),ST(4),ANG(4) - CHARACTER ANGLE(4)*6 - DATA ANGLE/'2theta','Omega','Chi','PH'/ - INTEGER IRUPT -C - external range ! Prevent use of intrinsic function under GNU G77 -C - NATT = 0 -C------- a debug flag! Set to 0 for no debug output - IDEBUG = 1 -C----------------------------------------------------------------------- -C If CAD-4 call the scan fitting version of the routine -C----------------------------------------------------------------------- - IF (DFMODL .EQ. 'CAD4') THEN - CALL CADCEN (ISLIT) - NATT = 0 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR) - ANG(1) = THETA - ANG(2) = OMEGA - ANG(3) = CHI - ANG(4) = PHI - RETURN - ENDIF -C----------------------------------------------------------------------- -C Get the starting values for the angles & set up the working ranges -C----------------------------------------------------------------------- - 100 CALL ANGET (ST(1),ST(2),ST(3),ST(4)) - IF (KI .EQ. 'ST') N = 1 - IF (KI .EQ. 'SO') N = 2 - IF (KI .EQ. 'SC') N = 3 - IF (KI .EQ. 'SP') N = 4 - ICHI = 0 - IF (ST(3) .GE. 350.0 .OR. ST(3) .LE. 10.0) ICHI = 1 - IPHI = 0 - IF (ST(4) .GE. 350.0 .OR. ST(4) .LE. 10.0) IPHI = 1 - IA = 0 - ISTEP = -1 - I = 50 - MAX = -1000000 - MIN = 1000000 -C----------------------------------------------------------------------- -C Step forwards or backwards on the appropriate circle, count & store -C----------------------------------------------------------------------- - 110 D1 = DX*(I - 50) - IF (N .EQ. 1) D2 = -0.5*D1 - IF (N .EQ. 2) D2 = 0.5*D1 - DO 120 J = 1,4 - AN(J) = ST(J) - 120 CONTINUE - AN(N) = AN(N) + D1 - CALL MOD360 (AN(N)) - IF (N .EQ. 1) THEN - AN(2) = AN(2) + D2 - CALL MOD360 (AN(2)) - ENDIF - IF (N .EQ. 2) THEN - AN(1) = AN(1) + D2 - CALL MOD360 (AN(1)) - ENDIF - IF (N .EQ. 3) AN(4) = ST(4) - CALL ANGSET (AN(1),AN(2),AN(3),AN(4),IA,IC) - IF (IC .NE. 0) THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - KI = 'FF' - RETURN - ENDIF - CALL CCTIME (PRESET,COUNT) - IF(IDEBUG .EQ. 1)THEN - WRITE(COUT,20000),AN(1),AN(2),AN(3),AN(4),COUNT -20000 FORMAT('TH = ',F8.2,' OM = ',F8.2,' CH = ',F8.2,' PH = ', F8.2, - & ' CTS = ', F8.2) - ENDIF - CALL KORQ(IRUPT) - IF(IRUPT .NE. 1) THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - KI = 'FF' - RETURN - ENDIF - CALL ANGET (AN(1),AN(2),AN(3),AN(4)) - CALL RANGE (ICHI,IPHI,AN) - XA(I) = AN(N) - IF (COUNT .LT. 1) THEN - YA(I) = 0 - GO TO 110 - ENDIF - YA(I) = COUNT - IF (COUNT .GT. MAX) THEN - MAX = COUNT - IMAX = I - ENDIF - IF (COUNT .LT. MIN) MIN = COUNT - IF (COUNT .GT. AFRAC*MAX) THEN - I = I + ISTEP - IF (I .GE. 1 .AND. I .LE. 100) GO TO 110 - ENDIF -C----------------------------------------------------------------------- -C Sort out what happened on the low angle side (ISTEP = -1) -C -C There are 4 situations to take care of on the low angle side. -C 1. The peak is at the low angle extremity. Move and try again. -C 2. There is no significant low angle peak. -C 3. The peak behaves normally and the peak straddles the centre of -C the search range, i.e. I = 50 is in the peak. -C 1. The peak is at the low angle extremity. Move and try again. -C----------------------------------------------------------------------- - IF (ISTEP .EQ. -1) THEN - ILOW = I -C----------------------------------------------------------------------- -C Case 1. Peak is at the low angle extremity. Start again. -C----------------------------------------------------------------------- - IF (IMAX .EQ. 1 .AND. AFRAC*MAX .GT. MIN) GO TO 100 -C----------------------------------------------------------------------- -C Cases 2 and 3. No significant peak or normal peak. -C In either case do the high angle side. -C----------------------------------------------------------------------- - IF (I .LT. 1 .OR. YA(50) .GE. AFRAC*MAX) THEN - ISTEP = 1 - NBOT = I - I = 51 - GO TO 110 - ENDIF -C----------------------------------------------------------------------- -C Case 4. Peak is all on low angle side. -C ILOW is where the peak ended, find where it started. -C----------------------------------------------------------------------- - IF (YA(50) .LT. AFRAC*MAX) THEN - DO 130 ISRCH = 1,50 - JSRCH = 51-ISRCH - IF (YA(JSRCH) .GT. AFRAC*MAX) THEN - NTOP = JSRCH - NBOT = ILOW - GO TO 200 - ENDIF - 130 CONTINUE - NTOP = JSRCH - NBOT = ILOW - GO TO 200 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Sort out what happened on the high angle side. (ISTEP = 1) -C -C Again there are 4 cases to take care of -C 1. The peak is at the high angle extremity. Move and try again. -C 2. There is no significant high angle peak. This can only occur -C after case 1 on the low side, i.e. there is no peak at all. -C 3. It is a normal peak continuing from the low angle case 2. -C 4. Peak is all on the high angle side. -C IHIGH is where the peak ended, find where it started. -C----------------------------------------------------------------------- - IF (ISTEP .EQ. 1) THEN - IHIGH = I -C----------------------------------------------------------------------- -C Case 1. Peak is at the high angle extremity. Start again. -C----------------------------------------------------------------------- - IF (IMAX .EQ. 100 .AND. AFRAC*MAX .GT. MIN) GO TO 100 -C----------------------------------------------------------------------- -C Case 2. There is no significant peak. -C -C Modified: Drive back to start positions. So that other circle centering -C will not fail. -C Modified error code to give an FP in order to decide between -C interrupt and bad peak. -C Mark Koennecke, April 2000 -C----------------------------------------------------------------------- - IF (ILOW .LT. 1 .OR. IHIGH .GT. 100) THEN - WRITE (COUT,11000) ANGLE(N),ILOW,IHIGH - CALL GWRITE (ITP,' ') - KI = 'FP' - CALL ANGSET(ST(1),ST(2),ST(3),ST(4),IA,IC) - RETURN - ENDIF -C----------------------------------------------------------------------- -C Case 3. Normal peak. -C----------------------------------------------------------------------- - IF (YA(50) .GE. AFRAC*MAX) THEN - NTOP = I - 1 -C----------------------------------------------------------------------- -C Case 4. Peak is all on the high angle side. -C----------------------------------------------------------------------- - ELSE - DO 140 ISRCH = 50,100 - IF (YA(ISRCH) .GT. AFRAC*MAX) THEN - NTOP = IHIGH - 1 - NBOT = ISRCH - 1 - GO TO 200 - ENDIF - 140 CONTINUE - NTOP = IHIGH - 1 - NBOT = ISRCH - 1 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Find the median of the distribution -C----------------------------------------------------------------------- - 200 AREA = 0.0 - IF (NBOT .LT. 1 .OR. NTOP .GT. 100 .OR. MAX .LE. 25) THEN - WRITE (COUT,11000) ANGLE(N),NBOT,NTOP,MAX - CALL GWRITE (ITP,' ') - KI = 'FF' - RETURN - ENDIF - DO 210 I = NBOT,NTOP - AREA = AREA + (XA(I+1) - XA(I))*(YA(I+1) + YA(I))*0.25 - 210 CONTINUE - S = 0.0 - DO 220 I = NBOT,NTOP - S = S + (XA(I+1) - XA(I))*(YA(I+1) + YA(I))*0.5 - IF (S .GT. AREA) GO TO 230 - 220 CONTINUE - 230 S = S - 0.5*(XA(I+1) - XA(I))*(YA(I+1) + YA(I)) -C----------------------------------------------------------------------- -C The centre is now in the Ith strip -C----------------------------------------------------------------------- - DA = AREA - S -C----------------------------------------------------------------------- -C Get the slope of the Ith strip & solve for X at AREA/2 -C----------------------------------------------------------------------- - IF (YA(I+1) .EQ. YA(I)) THEN - XCENT = XA(I) + DA/YA(I) - ELSE - S = (YA(I+1) - YA(I))/(XA(I+1) - XA(I)) - IF ((YA(I)*YA(I) + 2.0*S*DA) .LE. 0) THEN - WRITE (COUT,12000) - $ NBOT,NTOP,I,(XA(III),YA(III),III = NBOT,NTOP) - CALL GWRITE (ITP,' ') - KI = 'FF' - RETURN - ENDIF - DISC = SQRT(YA(I)*YA(I) + 2.0*S*DA) - XCENT = XA(I) + (DISC - YA(I))/S - ENDIF -C----------------------------------------------------------------------- -C Put the answer in the correct range -C N = 1 2THETA; N = 2 Omega; N = 3 Chi; N = 4 Phi. -C----------------------------------------------------------------------- - IF (N .EQ. 1) THEN - DA = XCENT - ST(1) - ST(1) = XCENT - ST(2) = ST(2) - 0.5*DA - CALL MOD360 (ST(2)) - ANG(2) = ST(2) -C----------------------------------------------------------------------- -C OMEGA range -C----------------------------------------------------------------------- - ELSE IF (N .EQ. 2) THEN - DA = ST(2) + 180 - IF (DA .GE. 360) DA = DA - 360 - DA = XCENT - DA - ST(1) = ST(1) + 0.5*DA - CALL MOD360 (ST(1)) - XCENT = XCENT - 180.0 - CALL MOD360 (XCENT) - ST(N) = XCENT -C----------------------------------------------------------------------- -C CHI range -C----------------------------------------------------------------------- - ELSE IF (N .EQ. 3) THEN - XCENT = XCENT - ICHI*180.0 - CALL MOD360 (XCENT) - ST(N) = XCENT -C----------------------------------------------------------------------- -C PHI range -C----------------------------------------------------------------------- - ELSE IF (N .EQ. 4) THEN - XCENT = XCENT - IPHI*180.0 - CALL MOD360 (XCENT) - ST(N) = XCENT - ENDIF -C----------------------------------------------------------------------- -C Set angles to the max values -C----------------------------------------------------------------------- - CALL ANGSET (ST(1),ST(2),ST(3),ST(4),IA,IC) - ANG(N) = ST(N) - IF (N .NE. 4) ANG(4) = ST(4) - KI = ' ' - RETURN -10000 FORMAT (' Real Collision in routine CENTRE') -11000 FORMAT (' Alignment Failure on ',A,'. NBOT, NTOP',2I4,' MAX',I6) -12000 FORMAT (3I6,/,(10F10.4)) - END -C -C----------------------------------------------------------------------- -C Subroutine to do a fine (1) or coarse (0) centreing on a specified -C circle for the CAD4 using the routine GENSCN. -C Different for the 2theta circle. -C----------------------------------------------------------------------- - SUBROUTINE CADCEN (ISLIT) - INCLUDE 'COMDIF' - ICPSMX = 25000 -C----------------------------------------------------------------------- -C Set the attenuator if necessary -C----------------------------------------------------------------------- - TIME = 1.0 - CALL CCTIME (TIME,COUNT) - IF (COUNT .GT. ICPSMX .AND. NATT .EQ. 0) THEN - NATT = 1 - COUNT = COUNT/ATTEN(2) - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR) - ENDIF -C----------------------------------------------------------------------- -C 2Theta circle (and chi) -C After the initial omega/2theta scan, this completes the alignment -C for a CAD-4 machine -C 1. Scans with the + 45deg slit; -C 2. Scans with the - 45deg slit; -C 3. Works out the 2theta & chi corrections via EULKAP. -C----------------------------------------------------------------------- -C write (lpt,99999) ki,theta,omega,chi,phi -C99999 format (' Before ',a,2x,4f8.3) - IF (KI .EQ. 'ST') THEN - SSPEED = 10 - IF (COUNT .LT. 2000) SSPEED = 5.0 - IF (COUNT .LT. 1000) SSPEED = 2.5 - IF (COUNT .LT. 400) SSPEED = 1.0 - ICIRCLE = 1 - NPTS = 50 - WIDTH = 2.5 - STEP = WIDTH/NPTS - ISLIT = 3 - CALL GENSCN (ICIRCLE,SSPEED,STEP,NPTS,ISLIT,ICOL) - CALL PFIT (NPTS,BEST) - ISLIT = 0 - IF (KI .EQ. 'FF') GO TO 200 - FIRST = BEST*STEP - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR) - ISLIT = 4 - CALL GENSCN (ICIRCLE,SSPEED,STEP,NPTS,ISLIT,ICOL) - CALL PFIT (NPTS,BEST) - ISLIT = 0 - IF (KI .EQ. 'FF') GO TO 200 - SECOND = STEP*BEST - DELTAC = 0.5*(FIRST - SECOND)/(2.0*SIN(0.5*THETA/DEG)) - CHI = CHI - DELTAC - ISLIT = 0 - IF (ABS(DELTAC) .GE. 1.0) ISLIT = 1 - THETA = THETA + 0.5*(FIRST + SECOND) - OMEGA = OMEGA - 0.25*(FIRST + SECOND) - ENDIF -C----------------------------------------------------------------------- -C Omega circle -C----------------------------------------------------------------------- - IF (KI .EQ. 'SO') THEN - ICIRCLE = 2 - NPTS = 50 - STEP = 1.0/NPTS - SSPEED = 5 - 120 CALL GENSCN (ICIRCLE,SSPEED,STEP,NPTS,ISLIT,ICOL) - CALL PFIT (NPTS,BEST) - IF (KI .EQ. 'BO' .OR. KI .EQ. 'TO') THEN - IF (KI .EQ. 'BO') OFF = -0.5 - IF (KI .EQ. 'TO') OFF = 0.5 - OMEGA = OMEGA + OFF - KI = 'SO' - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - GO TO 120 - ENDIF - IF (KI .EQ. 'FF') GO TO 200 - OMEGA = OMEGA + STEP*BEST - ENDIF -C----------------------------------------------------------------------- -C Chi (Kappa) circle -C----------------------------------------------------------------------- - IF (KI .EQ. 'SC') THEN - ICIRCLE = 3 - NPTS = 50 - STEP = 5.0/NPTS - SSPEED = 20 - CALL GENSCN (ICIRCLE,SSPEED,STEP,NPTS,ISLIT,ICOL) - CALL PFIT (NPTS,BEST) - IF (KI .EQ. 'FF') RETURN - OMEGA = OMEGA + THETA/2.0 - CALL EULKAP (0,OMEGA,CHI,PHI,OMK,RKA,PHIK,ICOL) - RKA = RKA + STEP*BEST - CALL EULKAP (1,OMEGA,CHI,PHI,OMK,RKA,PHIK,ICOL) - OMEGA = OMEGA - THETA/2.0 - ENDIF -C----------------------------------------------------------------------- -C Phi circle -C----------------------------------------------------------------------- - IF (KI .EQ. 'SP') THEN - ICIRCLE = 4 - NPTS = 50 - STEP = 4.0/NPTS - SSPEED = 10 - 130 CALL GENSCN (ICIRCLE,SSPEED,STEP,NPTS,ISLIT,ICOL) - CALL PFIT (NPTS,BEST) - IF (KI .EQ. 'BO' .OR. KI .EQ. 'TO') THEN - IF (KI .EQ. 'BO') OFF = -2.0 - IF (KI .EQ. 'TO') OFF = 2.0 - PHI = PHI + OFF - KI = 'SP' - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - GO TO 130 - ENDIF - IF (KI .EQ. 'FF') GO TO 200 - PHI = PHI + STEP*BEST - ENDIF -C----------------------------------------------------------------------- -C Omega/2theta circles -C----------------------------------------------------------------------- - IF (KI .EQ. 'WT') THEN - ICIRCLE = 5 - NPTS = 50 - STEP = 4.0/NPTS - SSPEED = 20 - 140 CALL GENSCN (ICIRCLE,SSPEED,STEP,NPTS,ISLIT,ICOL) - CALL PFIT (NPTS,BEST) - IF (KI .EQ. 'BO' .OR. KI .EQ. 'TO') THEN - IF (KI .EQ. 'BO') OFF = -2.0 - IF (KI .EQ. 'TO') OFF = 2.0 - THETA = THETA + OFF - OMEGA = OMEGA + 0.5*OFF - KI = 'WT' - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - GO TO 140 - ENDIF - IF (KI .EQ. 'FF') RETURN - THETA = THETA + STEP*BEST - ENDIF - 200 CONTINUE -C write (LPT,99998) ki,theta,omega,chi,phi -C99998 format (' After ',a,2x,4f8.3) - RETURN - END -C -C----------------------------------------------------------------------- -C Subroutine to find the centroid of the ACOUNT distribution -C----------------------------------------------------------------------- - SUBROUTINE PFIT (NPTS,BEST) - INCLUDE 'COMDIF' - DIMENSION TCOUNT(NSIZE) - EQUIVALENCE (ACOUNT(9*NSIZE+1), TCOUNT(1)) -C----------------------------------------------------------------------- -C Find the maximum point -C----------------------------------------------------------------------- - MAX = 0 - SUM = 0.0 - DO 100 I = 1,NPTS - IF (TCOUNT(I) .GT. MAX) THEN - MAX = TCOUNT(I) - IMAX = I - ENDIF - SUM = SUM + TCOUNT(I) - 100 CONTINUE - IF (MAX .LE. 10) THEN - KI = 'FF' - GO TO 200 - ENDIF -C----------------------------------------------------------------------- -C Find the half-height points on either side -C----------------------------------------------------------------------- - DO 110 I = IMAX,1,-1 - IF (TCOUNT(I) .LT. MAX/2) THEN - NBOT = I - GO TO 120 - ENDIF - 110 CONTINUE - KI = 'BO' - BEST = IMAX - NPTS/2 - GO TO 200 - 120 DO 130 I = IMAX,NPTS - IF (TCOUNT(I) .LT. MAX/2) THEN - NTOP = I - GO TO 140 - ENDIF - 130 CONTINUE - KI = 'TO' - BEST = IMAX - NPTS/2 - GO TO 200 -C----------------------------------------------------------------------- -C Find the point of half sum between NBOT and NTOP -C----------------------------------------------------------------------- - 140 SUM = 0.0 - DO 150 I = NBOT,NTOP - SUM = SUM + TCOUNT(I) - 150 CONTINUE - HALF = 0.0 - DO 160 I = NBOT,NTOP - HALF = HALF + TCOUNT(I) - IF (HALF .GT. SUM/2.0) GO TO 170 - 160 CONTINUE - 170 FRACX = (SUM/2.0 - HALF + TCOUNT(I))/TCOUNT(I) - BEST = I - 1 + FRACX - NPTS/2 - 0.5 - 200 CONTINUE -C IF (KI .EQ. 'FF' .OR. KI .EQ. 'TO' .OR. KI .EQ. 'BO') THEN -C write (LPT,99999) KI,imax,max,nbot,ntop,(tcount(i),i=1,50) -C ENDIF -C99999 format (' imax,max,nbot,ntop',A,4i6/(10f7.0)) - RETURN - END diff --git a/difrac/cfind.f b/difrac/cfind.f deleted file mode 100644 index beed4b8d..00000000 --- a/difrac/cfind.f +++ /dev/null @@ -1,63 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to find the coarse centre for Chi -C----------------------------------------------------------------------- - SUBROUTINE CFIND (TIM,MAXCOUNT) - INCLUDE 'COMDIF' - REAL MAXCOUNT, MCOUNT - DIMENSION TCOUNT(NSIZE) - EQUIVALENCE (ACOUNT(9*NSIZE+1),TCOUNT(1)) - ICPSMX = 25000 - STEPM = 0.02 - SENSE = -1.0 - CSTEP = 1.5 - NPTS = 10 - NRUN = 0 - 100 IF (CHI .LT. 0) CHI = CHI + 360 - IF (CHI .GE. 360) CHI = CHI - 360 - CHI = CHI + NPTS*CSTEP/2 - CHISV = CHI - 110 CALL ANGSET (THETA,OMEGA,CHISV,PHI,NATT,ICOL) - ICOUNT = 0 - MCOUNT = 0 - DO 120 I = 1,NPTS - CALL CCTIME (TIM,TCOUNT(I)) - CALL KORQ (IFLAG1) - IF (IFLAG1 .NE. 1) THEN - KI = 'O4' - RETURN - ENDIF - IF (TCOUNT(I)/TIM .GT. ICPSMX .AND. NATT .LT. NATTEN) THEN - NATT = NATT + 1 - GO TO 110 - ENDIF - IF (TCOUNT(I) .GT. MCOUNT) THEN - MCOUNT = TCOUNT(I) - ICOUNT = I - ENDIF - CHI = CHI + SENSE*CSTEP - IF (CHI .LT. 0) CHI = CHI + 360 - IF (CHI .GE. 360) CHI = CHI - 360 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - 120 CONTINUE - MAXCOUNT = REAL(MCOUNT) - IF (ICOUNT .EQ. 1) THEN -C -C try the other direction, but only once otherwise we get into an -C endless loop -C - IF(NRUN .GT. 0) THEN - MAXCOUNT = 0. - RETURN - ENDIF - SENSE = -SENSE - CHI = CHISV + 9*SENSE*CSTEP - NRUN = NRUN + 1 - GO TO 100 - ELSE IF (ICOUNT .EQ. 20) THEN - CHI = CHISV - 3*SENSE*CSTEP - GO TO 100 - ENDIF -C CHI = CHI + (ICOUNT - 12.25)*SENSE*CSTEP - CHI = CHISV + ICOUNT*SENSE*CSTEP - RETURN - END diff --git a/difrac/cinput.f b/difrac/cinput.f deleted file mode 100644 index c0c73884..00000000 --- a/difrac/cinput.f +++ /dev/null @@ -1,56 +0,0 @@ -C----------------------------------------------------------------------- -C Input from the existing cell -C----------------------------------------------------------------------- - SUBROUTINE CINPUT (IOUT,PRIM,ANPRIM,TRANSF) - INCLUDE 'COMDIF' - DIMENSION A(3),ALP(3),SYS(7),TRANS(3,3,7),AA(3,3),PRIM(3), - $ ANPRIM(3),TRANSF(3,3),H(3,3) - CHARACTER CATMOD*1,SYS*1,LINE*80 - DATA SYS/'P','A','B','C','I','F','R'/ - DATA TRANS/ 1, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0,.5,.5, - $ 0, 0, 1, .5, 0,.5, 0, 1, 0, 0, 0, 1, .5,.5, 0, - $ 0, 1, 0, 0, 0, 1, .5,.5,.5, 0, 1, 0, 0, 0, 1, - $ .5,.5, 0, 0,.5,.5, .5, 0,.5, - $ .666667, .333333, .333333, - $ -.333333, .333333, .333333, - $ -.333333, -.666667, .333333/ - RADEG = 180./3.141593 - DO 100 I = 1,3 - A(I) = AP(I) - ALP(I) = RADEG*ATAN2(SANG(I),CANG(I)) - 100 CONTINUE - 110 WRITE (COUT,10000) - CALL ALFNUM (LINE) - CATMOD = LINE(1:1) - IF (CATMOD .EQ. ' ') CATMOD = 'P' - READ (CATMOD,11000) ATMOD - WRITE (COUT,12000) A,ALP,CATMOD - CALL GWRITE (IOUT,' ') - DO 120 I = 1,7 - IF (CATMOD .EQ. SYS(I)) GO TO 130 - 120 CONTINUE - GO TO 110 -C----------------------------------------------------------------------- -C CRAP is a dummy floating argument -C----------------------------------------------------------------------- - 130 CALL MATRIX(A,ALP,AA,CRAP,'ORTHOG') - DO 140 N = 1,3 - CALL MATRIX(AA,TRANS(1,N,I),H(1,N),CRAP,'MATVEC') - 140 CONTINUE - DO 150 N = 1,3 - CALL MATRIX(AA,TRANS(1,N,I),PRIM(N),CRAP,'LENGTH') - J = MOD(N,3) + 1 - K = 6 - N - J - CALL MATRIX(H(1,J),H(1,K),COSNG,CRAP,'SCALPR') - ANPRIM(N) = ACOS(COSNG)*RADEG - 150 CONTINUE - DO 160 N = 1,3 - DO 160 NN = 1,3 - TRANSF(NN,N) = TRANS(N,NN,I) - 160 CONTINUE - CALL BURGER(IOUT,PRIM,ANPRIM,TRANSF) - RETURN -10000 FORMAT (' Lattice Type (P) ? ',$) -11000 FORMAT (A1) -12000 FORMAT (' Input Cell:',F8.3,5F10.3/12X,'Lattice Type ',A) - END diff --git a/difrac/cntref.f b/difrac/cntref.f deleted file mode 100644 index 40f1528f..00000000 --- a/difrac/cntref.f +++ /dev/null @@ -1,88 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to count the number of reflections in a segment -C----------------------------------------------------------------------- - SUBROUTINE CNTREF - INCLUDE 'COMDIF' - DIMENSION INDX(3),FDH(3,3),FDHI(3,3),ISET(25) - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - IOUT = -1 - CALL SPACEG (IOUT,1) -C----------------------------------------------------------------------- -C Ensure no rotation and set segment flag -C----------------------------------------------------------------------- - DPSI = 0.0 - ISEG = 0 - IPRVAL = 0 - IUMPTY = 1 -C----------------------------------------------------------------------- -C Get segment data and calculate segment parameters -C----------------------------------------------------------------------- - DO 180 JSEG = 1,NSEG - DO 110 I = 1,3 - DO 110 J = 1,3 - NDH(I,J) = IDH(JSEG,I,J) - 110 CONTINUE - IND(1) = IHO(JSEG) - IND(2) = IKO(JSEG) - IND(3) = ILO(JSEG) - HO = IND(1) - KO = IND(2) - LO = IND(3) - DO 120 I = 1,3 - DO 120 J = 1,3 - FDH(I,J) = NDH(I,J) - 120 CONTINUE - CALL MATRIX (FDH,FDHI,FDHI,FDHI,'INVERT') - DO 140 I = 1,3 - INDX(I) = FDHI(I,1)*(IND(1)-HO) + FDHI(I,2)*(IND(2)-KO) + - $ FDHI(I,3)*(IND(3)-LO) - IF (INDX(I) .GE. 0) THEN - INDX(I) = INDX(I) + 0.5 - ELSE - INDX(I) = INDX(I) - 0.5 - ENDIF - 140 CONTINUE - IFSHKL(1,1) = NDH(1,1)*INDX(1) + IND(1) - IFSHKL(2,1) = NDH(2,1)*INDX(1) + IND(2) - IFSHKL(3,1) = NDH(3,1)*INDX(1) + IND(3) - DO 150 I = 1,3 - IFSHKL(I,2) = NDH(I,2)*INDX(2) + IFSHKL(I,1) - IFSHKL(I,3) = NDH(I,3)*INDX(3) + IFSHKL(I,2) - 150 CONTINUE - IH = IFSHKL(1,3) - IK = IFSHKL(2,3) - IL = IFSHKL(3,3) - IUPDWN = 1 -C----------------------------------------------------------------------- -C Set the standards flag for ANGCAL -C----------------------------------------------------------------------- - ISTAN = 0 - NN = 0 - NCOUNT = 0 -C----------------------------------------------------------------------- -C Calculate the angle values and count the valid reflections -C----------------------------------------------------------------------- - 160 IPRVAL = 0 - CALL ANGCAL - IF (IVALID .EQ. 0) THEN - IF (ISCAN .EQ. 1) THEN - IBZ = 1 - CALL COMPTN (IBZ) - IF (IBZ .EQ. 3) GO TO 170 - ENDIF - NCOUNT = NCOUNT + 1 - CALL HKLN (IH,IK,IL,NCOUNT) - ENDIF - 170 CALL INCHKL - IF (ISEG .EQ. 0) GO TO 160 - WRITE (COUT,11000) JSEG,NCOUNT - CALL GWRITE (ITP,' ') - WRITE (LPT,11000) JSEG,NCOUNT - 180 CONTINUE - IUMPTY = 0 - KI = ' ' - RETURN -10000 FORMAT (' Count the number of reflections in each segment') -11000 FORMAT (' DH Segment',I2,' contains',I6,' reflections') - END diff --git a/difrac/comptn.f b/difrac/comptn.f deleted file mode 100644 index 3084b82a..00000000 --- a/difrac/comptn.f +++ /dev/null @@ -1,69 +0,0 @@ -C----------------------------------------------------------------------- -C Count for a given time at a point within a defined Brillouin zone -C----------------------------------------------------------------------- - SUBROUTINE COMPTN(IBZ) - INCLUDE 'COMDIF' - IF (IBZ .EQ. 1) THEN -C----------------------------------------------------------------------- -C Test if point within B.Z. limits. Return with IBZ=3 for invalid -C----------------------------------------------------------------------- - JTEMP = IH*JA(NMSEG) + IK*JB(NMSEG) + IL*JC(NMSEG) - JMN = JMIN(NMSEG) - JMX = JMAX(NMSEG) - IF (JTEMP .LT. JMN .OR. JTEMP .GT. JMX) IBZ = 3 - RETURN - ENDIF -C----------------------------------------------------------------------- -C Point measurement -C----------------------------------------------------------------------- - NATT = 0 -C----------------------------------------------------------------------- -C Count for 1 sec to set correct attenuator -C No attenuator at TRICS, commented out, MK -C----------------------------------------------------------------------- -C ATIME = 1000.0 -C CALL CTIME (ATIME,ATCOUN) -C IF (ATCOUN .GT. 10000.0) THEN -C NATT = NATT + 1 -C IF (NATT .LT. 6) THEN -C CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) -C IF (ICOL .NE. 0) THEN -C WRITE (COUT,10000) IH,IK,IL -C CALL GWRITE (ITP,' ') -C RETURN -C ENDIF -C ENDIF -C ENDIF -C----------------------------------------------------------------------- -C QTIME,TMAX -C----------------------------------------------------------------------- - SAVEQ = QTIME - STMAX = TMAX - QTIME = QTIME - TMAX = TMAX -C----------------------------------------------------------------------- -C Sample count at point to find suitable counting time, then measure -C----------------------------------------------------------------------- - CALL CCTIME (QTIME,ENQ) - COUNT = ENQ - ENQD = ENQ - 2.0*SQRT(ENQ) - IF (ENQD .LE. 0.0) ENQD = ENQ - F = ((100.0/PA)**2)/ENQD - PRESET = QTIME*F - IF (PRESET .GT. QTIME) THEN - IF (PRESET .GT. PRESET) PRESET = TMAX - TIMED = PRESET - QTIME - CALL CCTIME (TIMED,EN) - ELSE - PRESET = QTIME - EN = 0 - ENDIF - COUNT = COUNT + EN - BGRD1 = 0.0 - BGRD2 = 0.0 - PSI = 0.0 - QTIME = SAVEQ - TMAX = STMAX - RETURN -10000 FORMAT (3I4,' Collision') - END diff --git a/difrac/creduc.f b/difrac/creduc.f deleted file mode 100644 index dff8b3f4..00000000 --- a/difrac/creduc.f +++ /dev/null @@ -1,340 +0,0 @@ -C----------------------------------------------------------------------- -C This program finds the conventional representation of a lattice -C input as cell parameters and a lattice type, assuming that metric -C relations in the lattice correspond to lattice symmetry. -C Pseudo-symmetry in the primitive lattice is also detected. -C See: Le Page, Y. (1982). J. Appl. Cryst., 15,255-259. -C Sept. 1986 Fortran 77 + three-fold axes YLP. -C----------------------------------------------------------------------- - SUBROUTINE CREDUC (KI) - COMMON /GEOM/ AA(3,3),AINV(3,3),TRANS(3,3),RH(3,20),HH(3,20), - $ AANG(20),PH(3,20),PMESH(3,2,20),NERPAX(20),N2,N3, - $ EXPER - COMMON /IOUASS/ IOUNIT(10) - CHARACTER COUT*132 - COMMON /IOUASC/ COUT(20) - COMMON /IODEVS/ ITP,ITR,LPT,LPTX,LNCNT,PGCNT,ICD,IRE,IBYLEN, - $ IPR,NPR,IIP - COMMON /INFREE/ IFREE(20),RFREE(20),ICFLAG - DIMENSION P(3),H(3),IP(3),IR(3),HX(3,37),DHX(3,37),CELL(3), - $ CELANG(3),SHORT(4,4),IPAD(20),VPROD(3),DIRECT(3), - $ RECIP(3) - CHARACTER KI*2 -C---------------------------------------------------------------------- -C The 37 acceptable index combinations of 0, +/- 1 or 2 -C---------------------------------------------------------------------- - DATA ITOT/37/ - DATA DHX/ 1, 0, 0, 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 0, 1, - $ 0, 1, 1, 1,-1, 0, 1, 0,-1, 0, 1,-1, 1, 1, 1, - $ 1, 1,-1, 1,-1, 1, -1, 1, 1, 2, 1, 0, 2, 0, 1, - $ 2,-1, 0, 2, 0,-1, 0, 2, 1, 1, 2, 0, 0, 2,-1, - $ -1, 2, 0, 1, 0, 2, 0, 1, 2, -1, 0, 2, 0,-1, 2, - $ 2, 1, 1, 2, 1,-1, 2,-1, 1, -2, 1, 1, 1, 2, 1, - $ 1, 2,-1, 1,-2, 1, -1, 2, 1, 1, 1, 2, 1, 1,-2, - $ 1,-1, 2, -1, 1, 2/ - INP = -1 - IOUT = ITP - WRITE (COUT,18000) - CALL FREEFM (ITR) - EXPER = RFREE(1) - IF (EXPER .EQ. 0.0) EXPER = 0.01 -C---------------------------------------------------------------------- -C Get the input cell and bring back the Buerger cell parameters -C and the input -> Buerger cell parameters -C---------------------------------------------------------------------- - 100 CALL CINPUT (IOUT,CELL,CELANG,TRANS) - WRITE (COUT,13000) - CALL GWRITE (IOUT,' ') - WRITE (COUT,14000) - CALL GWRITE (IOUT,' ') -C----------------------------------------------------------------------- -C Describe the Buerger direct and reciprocal cells by their cartesian -C coordinates AA and AINV. CRAP is a dummy floating argument -C----------------------------------------------------------------------- - CALL MATRIX (CELL,CELANG,AA,CRAP,'ORTHOG') - CALL MATRIX (AA,AINV,CRAP,CRAP,'INVERT') -C---------------------------------------------------------------------- -C Default angular tolerance: 3 degrees -C---------------------------------------------------------------------- - ANGMAX = TAN(3.0/57.2958)**2 -C----------------------------------------------------------------------- -C Find the twofold axes: -C Generate all unique combinations of 0, 1 and 2 -C Get the direction cosines of the possible rows -C----------------------------------------------------------------------- - DO 110 IT = 1,ITOT - CALL MATRIX (AA,DHX(1,IT),HX(1,IT),CRAP,'MATVEC') - 110 CONTINUE -C----------------------------------------------------------------------- -C Get direction cosines for the normal to the possible planes in turn -C----------------------------------------------------------------------- - N2 = 0 - DO 140 IT = 1,ITOT - CALL MATRIX (DHX(1,IT),AINV,P,CRAP,'VECMAT') -C----------------------------------------------------------------------- -C Select the rows in turn -C----------------------------------------------------------------------- - DO 130 L = 1,ITOT -C----------------------------------------------------------------------- -C Calculate the multiplicity of the cell defined by the mesh on the -C plane and the translation along the row -C----------------------------------------------------------------------- - MULT = ABS(DHX(1,L)*DHX(1,IT) + DHX(2,L)*DHX(2,IT) + - $ DHX(3,L)*DHX(3,IT)) + 0.1 - IF (MULT .EQ. 1 .OR. MULT .EQ. 2) THEN -C----------------------------------------------------------------------- -C Calculate the angle between the row and the normal to the plane -C----------------------------------------------------------------------- - ANG = ((P(1)*HX(2,L) - P(2)*HX(1,L))**2 + - $ (P(2)*HX(3,L) - P(3)*HX(2,L))**2 + - $ (P(3)*HX(1,L) - P(1)*HX(3,L))**2) - IF (ANG .LE. ANGMAX) THEN - N2 = N2 + 1 - DO 120 NX = 1,3 - PH(NX,N2) = DHX(NX,IT) - HH(NX,N2) = HX (NX,L) - RH(NX,N2) = DHX(NX,L) - 120 CONTINUE - AANG(N2) = ANG - NERPAX(N2) = 2 - ENDIF - ENDIF - 130 CONTINUE - 140 CONTINUE - N3 = N2 -C----------------------------------------------------------------------- -C Order the rows on the angle with the normal to the plane -C----------------------------------------------------------------------- - IF (N2 .LT. 2) GO TO 250 - DO 170 I = 1,N2 - 1 - ANMAX = AANG(I) - MAX = I - DO 160 J = I + 1,N2 - IF (AANG(J) .LT. ANMAX) THEN - ANMAX = AANG(J) - MAX = J - ENDIF - 160 CONTINUE - CALL MATRIX (RH(1,I),RH(1,MAX),CRAP,CRAP,'INTRCH') - CALL MATRIX (PH(1,I),PH(1,MAX),CRAP,CRAP,'INTRCH') - CALL MATRIX (HH(1,I),HH(1,MAX),CRAP,CRAP,'INTRCH') - AANG(MAX) = AANG(I) - AANG(I) = ANMAX - 170 CONTINUE -C----------------------------------------------------------------------- -C Find the kind of axis: find a family of coplanar twofold axes -C----------------------------------------------------------------------- - IF (N2 .LT. 3) GO TO 250 - DO 220 I = 1,N2 - 1 - IPAD(1) = I - DO 210 J = I + 1,N2 - IPAD(2) = J - NUMAX = 2 - DO 180 K = 1,N2 - IF (K .NE. I .AND. K .NE. J) THEN - CALL MATRIX (RH(1,I),RH(1,J),RH(1,K),DET,'DETERM') - IF (ABS(DET) .LE. 0.01) THEN - IF (K .LT. J) GO TO 210 - NUMAX = NUMAX + 1 - IPAD (NUMAX) = K - ENDIF - ENDIF - 180 CONTINUE -C----------------------------------------------------------------------- -C Now find a twofold axis perpendicular to this plane -C----------------------------------------------------------------------- - DO 190 K = 1,N2 - CALL MATRIX (PH(1,K),RH(1,I),SCAL,CRAP,'SCALPR') - IF (ABS(SCAL) .LE. 0.01) THEN - CALL MATRIX (PH(1,K),RH(1,J),SCAL,CRAP,'SCALPR') - IF (ABS(SCAL) .LE. 0.01) THEN -C----------------------------------------------------------------------- -C Found one: its maximum order is NUMAX, the number of perpend. axes -C----------------------------------------------------------------------- - NERPAX(K) = NUMAX - IF (NUMAX .LE. 2) NERPAX(K) = 2 - GO TO 210 - ENDIF - ENDIF - 190 CONTINUE -C----------------------------------------------------------------------- -C Three coplanar axes were found, but no perpendicular one: -C this is likely to be a threefold axis. -C----------------------------------------------------------------------- - IF (NUMAX .GT. 2) THEN - CALL MATRIX (HH(1,I),HH(1,J),VPROD ,CRAP,'VECPRD') - CALL MATRIX (VPROD ,AA ,RECIP ,CRAP,'VECMAT') - CALL MATRIX (RECIP ,RECIP ,CRAP ,CRAP,'COPRIM') - CALL MATRIX (RECIP ,AINV ,P ,CRAP,'VECMAT') - CALL MATRIX (AINV ,VPROD ,DIRECT,CRAP,'MATVEC') - CALL MATRIX (DIRECT ,DIRECT ,CRAP ,CRAP,'COPRIM') - CALL MATRIX (AA ,DIRECT ,H ,CRAP,'MATVEC') - CALL MATRIX (DIRECT ,RECIP ,SCAL ,CRAP,'SCALPR') - MULT = ABS(SCAL) + 0.1 - ANG = ((P(1)*H(2) - P(2)*H(1))**2 + - $ (P(2)*H(3) - P(3)*H(2))**2 + - $ (P(3)*H(1) - P(1)*H(3))**2)/(MULT*MULT) - IF (ANG .LE. ANGMAX) THEN -C----------------------------------------------------------------------- -C All seems to be ok, save the results -C----------------------------------------------------------------------- - N3 = N3 + 1 - DO 200 NX = 1,3 - PH(NX,N3) = RECIP(NX) - RH(NX,N3) = DIRECT(NX) - HH(NX,N3) = H(NX) - 200 CONTINUE - AANG(N3) = ANG - NERPAX(N3) = NUMAX - IF (NUMAX .EQ. 0) NERPAX(N3) = 2 - ENDIF - ENDIF - 210 CONTINUE - 220 CONTINUE -C----------------------------------------------------------------------- -C Order the threefold axes on the angle with the plane -C----------------------------------------------------------------------- - IF (N3 - N2 .GE. 2) THEN - DO 240 I = N3,N3 - 1,-1 - ANMAX = AANG(I) - MAX = I - DO 230 J = I + 1,N3 - IF (AANG(J) .LT. ANMAX) THEN - ANMAX = AANG(J) - MAX = J - ENDIF - 230 CONTINUE - CALL MATRIX (RH(1,I),RH(1,MAX),CRAP,CRAP,'INTRCH') - CALL MATRIX (PH(1,I),PH(1,MAX),CRAP,CRAP,'INTRCH') - CALL MATRIX (HH(1,I),HH(1,MAX),CRAP,CRAP,'INTRCH') - SAVE = NERPAX(I) - NERPAX(I) = NERPAX(MAX) - NERPAX(MAX) = NERPAX(I) - AANG(MAX) = AANG(I) - AANG(I) = ANMAX - 240 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Get 2 primitive translations for the perpendicular plane -C----------------------------------------------------------------------- - 250 DO 380 IT = 1,N3 - NMESH = 1 - DO 260 I = 1,ITOT - CALL MATRIX (DHX(1,I),PH(1,IT),SCAL,CRAP,'SCALPR') - IF (ABS(SCAL) .LE. 0.01) THEN - NMESH2 = I - IF (NMESH .EQ. 1) NMESH1 = I - IF (NMESH .EQ. 2) GO TO 270 - NMESH = NMESH + 1 - ENDIF - 260 CONTINUE - 270 DO 280 I = 1,3 - SHORT(I,1) = DHX(I,NMESH1) - SHORT(I,2) = DHX(I,NMESH2) - 280 CONTINUE -C----------------------------------------------------------------------- -C Get the 2 shortest translations in the plane: generate mesh diagonals -C----------------------------------------------------------------------- - 290 DO 300 I = 1,3 - SHORT(I,3) = SHORT(I,1) + SHORT(I,2) - SHORT(I,4) = SHORT(I,1) - SHORT(I,2) - 300 CONTINUE - DO 310 I = 1,4 - CALL MATRIX (AA,SHORT(1,I),SHORT(4,I),CRAP,'LENGTH') - 310 CONTINUE -C----------------------------------------------------------------------- -C Rank their lengths -C----------------------------------------------------------------------- - ISWTCH = 0 - DO 340 I = 1,2 - DO 330 J = 2,4 - IF (SHORT(4,J) .LT. SHORT(4,I)) THEN - DO 320 K = 1,4 - SAVE = SHORT(K,I) - SHORT(K,I) = SHORT(K,J) - SHORT(K,J) = SAVE - 320 CONTINUE - ISWTCH = 1 - ENDIF - 330 CONTINUE - 340 CONTINUE -C----------------------------------------------------------------------- -C Finished when no more interchanges -C----------------------------------------------------------------------- - IF (ISWTCH .EQ. 1) GO TO 290 -C----------------------------------------------------------------------- -C Make sure the angle is not acute -C----------------------------------------------------------------------- - CALL MATRIX (AA,SHORT(1,1),SHORT(1,3),CRAP,'MATVEC') - CALL MATRIX (AA,SHORT(1,2),SHORT(1,4),CRAP,'MATVEC') - CALL MATRIX (SHORT(1,3),SHORT(1,4),SCAL,CRAP,'SCALPR') - IF (SCAL .GE. 0.0) THEN - DO 350 IAX = 1,3 - SHORT(IAX,2) = -SHORT(IAX,2) - 350 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Make sure the reference system is right-handed -C----------------------------------------------------------------------- - IS = 1 - CALL MATRIX (RH(1,IT),PH(1,IT),SCAL,CRAP,'SCALPR') - IF (SCAL .LT. 0.) IS = -1 - IS1 = 1 - CALL MATRIX (SHORT(1,1),SHORT(1,2),RH(1,IT),DET,'DETERM') - IF (DET .LT. 0.) IS1 = -1 -C----------------------------------------------------------------------- -C This is a potential symmetry axis, we print and save the values -C----------------------------------------------------------------------- - DO 370 NX = 1,3 - RH(NX,IT) = IS1*RH(NX,IT) - HH(NX,IT) = IS1*HH(NX,IT) - PH(NX,IT) = IS*IS1*PH(NX,IT) - IP(NX) = PH(NX,IT) - IR(NX) = RH(NX,IT) - DO 370 NY = 1,2 - PMESH (NX,NY,IT) = IS1 * SHORT (NX,NY) - 370 CONTINUE - AANG(IT) = ATAN(SQRT(AANG(IT)))*180.0/3.1415927 - MULT = IR(1)*IP(1) + IR(2)*IP(2) + IR(3)*IP(3) - WRITE (COUT,15000) IR,IP,MULT,AANG(IT),NERPAX(IT) - CALL GWRITE (IOUT,' ') - 380 CONTINUE -C----------------------------------------------------------------------- -C Fill the next slot -C----------------------------------------------------------------------- - DO 390 I = 1,3 - RH(I,N3 + 1) = 0.0 - PH(I,N3 + 1) = 0.0 - PMESH(I,1,N3 + 1) = 0.0 - PMESH(I,2,N3 + 1) = 0.0 - 390 CONTINUE - PMESH(1,1,N3 + 1) = 1.0 - PMESH(2,2,N3 + 1) = 1.0 - RH(3,N3 + 1) = 1.0 - PH(3,N3 + 1) = 1.0 -C----------------------------------------------------------------------- -C Find the crystal system -C----------------------------------------------------------------------- - WRITE (COUT,16000) - CALL GWRITE (IOUT,' ') - NPSUDO = N2 - CALL FNDSYS (IOUT,HH,NPSUDO) - IF (INP .GT. 0 .OR. IOUT .NE. ITP) THEN - WRITE (COUT,17000) - CALL GWRITE (IOUT,' ') - ENDIF - KI = ' ' - RETURN - 9000 FORMAT (/10X,'CREDUC -- The NRCVAX Cell Reduction Routine'/'%') -10000 FORMAT (' Input from the terminal or a file (T) ? ',$) -11000 FORMAT (' Output to terminal or lineprinter-file (T) ? ',$) -13000 FORMAT (/15X,'Possible 2-fold Axes:'/ - $ 14X,'Rows',20X,'Products',9X,'Kind') -14000 FORMAT (7X,'Direct',6X,'Reciprocal',7X,'Dot',4X,'Vector',4X, - $ 'of Axis') -15000 FORMAT (2X,3I4,2X,3I4,I10,F10.3,7X,I3) -16000 FORMAT (/) -17000 FORMAT (//) -18000 FORMAT (' Type the Allowable Tolerance on True Cell Angles', - $ ' (0.01deg) ',$) - END diff --git a/difrac/demo1e.f b/difrac/demo1e.f deleted file mode 100644 index 2dcac1e6..00000000 --- a/difrac/demo1e.f +++ /dev/null @@ -1,138 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to demonstrate the operations of the diffractometer. -C----------------------------------------------------------------------- - SUBROUTINE DEMO1E - INCLUDE 'COMDIF' -C----------------------------------------------------------------------- -C Print the header and wait 3 seconds -C----------------------------------------------------------------------- - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - DELAY = 3.0 -C----------------------------------------------------------------------- -C Move 2Theta -C----------------------------------------------------------------------- - CALL CCTIME (DELAY,COUNT) - CALL ANGET (THETA,OMEGA,CHI,PHI) - THETA = THETA + 20.0 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) -C----------------------------------------------------------------------- -C Move Omega -C----------------------------------------------------------------------- - WRITE (COUT,11000) - CALL GWRITE (ITP,' ') - CALL CCTIME (DELAY,COUNT) - OMEGA = OMEGA - 20.0 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) -C----------------------------------------------------------------------- -C Move Chi -C----------------------------------------------------------------------- - WRITE (COUT,12000) - CALL GWRITE (ITP,' ') - CALL CCTIME (DELAY,COUNT) - CHI = CHI + 20.0 - IF (CHI .GE. 360.0) CHI = CHI - 360.0 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) -C----------------------------------------------------------------------- -C Move Phi -C----------------------------------------------------------------------- - WRITE (COUT,13000) - CALL GWRITE (ITP,' ') - CALL CCTIME (DELAY,COUNT) - PHI = PHI + 30.0 - IF (PHI .GE. 360.0) PHI = PHI - 360.0 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) -C----------------------------------------------------------------------- -C Move all circles -C----------------------------------------------------------------------- - WRITE (COUT,14000) - CALL GWRITE (ITP,' ') - CALL CCTIME(DELAY,COUNT) - THETA = THETA - 20.0 - OMEGA = OMEGA + 20.0 - CHI = CHI - 20.0 - PHI = PHI - 30.0 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) -C----------------------------------------------------------------------- -C Operate the shutter -C----------------------------------------------------------------------- - WRITE (COUT,15000) - CALL GWRITE (ITP,' ') - DO 110 I = 1,10 - DO 100 J = 1,100 - DJUNK = SQRT(1.0) - 100 CONTINUE - 110 CALL SHUTTR (1) -C----------------------------------------------------------------------- -C Operate the attenuator -C----------------------------------------------------------------------- - WRITE (COUT,16000) - CALL GWRITE (ITP,' ') - DO 120 NAT = 1,6 - IAT = MOD(NAT,6) - CALL ANGSET (THETA,OMEGA,CHI,PHI,IAT,ICOL) - 120 CONTINUE -C----------------------------------------------------------------------- -C Count for 5 seconds -C----------------------------------------------------------------------- - WRITE (COUT,17000) - CALL GWRITE (ITP,' ') - DELAY = 5.0 - DO 140 I = 1,5 - DO 130 J = 1,100 - DJUNK = SQRT(1.0) - 130 CONTINUE - CALL CCTIME (DELAY,COUNT) - 140 CONTINUE - CALL SHUTTR (-1) -C----------------------------------------------------------------------- -C Header for line profile done by LINPRF -C----------------------------------------------------------------------- - WRITE (COUT,18000) - CALL GWRITE (ITP,' ') - DO 150 I = 1,300 - DJUNK = SQRT(1.0) - 150 CONTINUE - CALL LINPRF - WRITE (COUT,20000) - CALL GWRITE (ITP,' ') - CALL INDMES - WRITE (COUT,21000) - CALL GWRITE (ITP,' ') - LPT = ISTAN - WRITE (COUT,22000) - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN -10000 FORMAT (///,10X,'Demonstration of the National Research Council', - $ ' Diffractometer',///, - $ 6X,'An automatic diffractometer measures the X-ray', - $ ' diffraction intensities',/, - $ ' of crystals using a scintillation counter.',/, - $ ' Its computer controls 4 angles.',/, - $ ' Please watch the instrument, it will operate',/, - $ 3X,'-- The 2-Theta Circle') -11000 FORMAT (3X,'-- The Omega Circle') -12000 FORMAT (3X,'-- The Chi Circle') -13000 FORMAT (3X,'-- The Phi Circle') -14000 FORMAT (' One at a time or all together.') -15000 FORMAT (' It also controls a shutter') -16000 FORMAT (' and an attenuator to protect the counter from', - $ ' excessive radiation.') -17000 FORMAT (' It can also count the x-ray quanta entering the', - $ ' scintillation counter.',/, - $ ' If you now watch the oscilloscope display on the', - $ ' top of the cabinet,',/, - $ ' it will count for 5 seconds.') -18000 FORMAT (//' These elementary operations (angles, shutter,', - $ ' attenuator, timed count)',/, - $ ' are now combined to make a line-profile analysis:') -20000 FORMAT (///,' It is now going to scan through the peak while', - $ ' counting, then subtract',/, - $ ' two background measurements to derive the integrated', - $ ' intensity under the peak.') -21000 FORMAT (//,' An actual experiment involves the measurement', - $ ' of thousands of intensities.',/, - $ ' Typically, it lasts for 1-2 weeks, day and night.') -22000 FORMAT (//////////////////) - END diff --git a/difrac/dhgen.f b/difrac/dhgen.f deleted file mode 100644 index a994efbd..00000000 --- a/difrac/dhgen.f +++ /dev/null @@ -1,215 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to generate and print the DH matrices -C----------------------------------------------------------------------- - SUBROUTINE DHGEN - INCLUDE 'COMDIF' - DIMENSION IDHM(3,4,4),IDHC(3,4),ISET(25),IDHN(4,14),JDHM(3,4,16), - $ INDH(14),JDHN(4),JUNK(8) - EQUIVALENCE (JUNK(1),D12), (JUNK(2),ILOW), (JUNK(3),IHIGH), - $ (JUNK(4),IDEL), (JUNK(5),IWARN),(JUNK(6),SUM), - $ (JUNK(7),FRAC1),(JUNK(8),IPRFLG) -C----------------------------------------------------------------------- -C The 16 possible DH matrices -C----------------------------------------------------------------------- - DATA JDHM / 0,0,0, 1,0,0, 0,1,0, 0,0,1, - $ -1,0,1, -1,0,0, 0,1,0, 0,0,1, - $ -1,1,0, -1,0,0, 0,1,0, 0,0,-1, - $ 0,1,-1, 1,0,0, 0,1,0, 0,0,-1, - $ 0,0,0, 1,0,0, 1,1,0, 0,0,1, - $ 0,0,0, 1,0,0, 1,1,0, 1,1,1, - $ 1,2,0, 0,1,0, 1,1,0, 1,1,1, - $ 1,2,0, 0,1,0, 1,1,0, 0,0,1, - $ 0,1,1, 0,1,0, 1,1,0, 0,0,1, - $ 1,1,-1, 1,0,0, 1,1,0, 0,0,-1, - $ 0,1,1, 0,1,0, -1,1,0, 0,0,1, - $ 1,2,0, 1,1,0, 0,1,0, 0,0,1, - $ 0,0,0, 1,0,0, 1,0,-1, 1,1,1, - $ 1,1,0, 1,0,-1, 0,0,-1, 1,1,1, - $ 0,-1,-2, 1,0,0, 1,0,-1,-1,-1,-1, - $ 1,0,-2, 1,0,-1, 0,0,-1,-1,-1,-1/ - DATA INDH/4,2,1,2,1,4,2,3,2,2,2,1,2,1/ -C----------------------------------------------------------------------- -C -1 2/m mmm 4/m -C 4/mmm R-3 R-3m -3 -C -31m -3m1 6/m 6/mmm -C m3 m3m -C----------------------------------------------------------------------- - DATA IDHN/ 1, 2, 3, 4, 1, 2, 0, 0, 1, 0, 0, 0, 5,12, 0, 0, - $ 5, 0, 0, 0, 13,14,15,16, 13,14, 0, 0, 5,12,11, 0, - $ 5, 9, 0, 0, 5,10, 0, 0, 5, 8, 0, 0, 5, 0, 0, 0, - $ 6, 7, 0, 0, 6, 0, 0, 0/ -C----------------------------------------------------------------------- -C Select the proper segment information -C----------------------------------------------------------------------- - NUMDH = INDH(LAUENO) - DO 100 I = 1,4 - JDHN(I) = IDHN(I,LAUENO) - 100 CONTINUE -C----------------------------------------------------------------------- -C Output the independent set -C----------------------------------------------------------------------- - DO 120 N = 1,NUMDH - DO 120 I = 1,3 - DO 120 J = 1,4 - M = JDHN(N) - IDHM(I,J,N) = JDHM(I,J,M) - 120 CONTINUE - IF (LAUENO .EQ. 2) THEN - DO 130 N = 1,NUMDH - DO 130 J = 1,4 - SAVE = IDHM(2,J,N) - IDHM(2,J,N) = IDHM(NAXIS,J,N) - IDHM(NAXIS,J,N) = SAVE - 130 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C If in Automatic Alignment mode, skip the questions (???) -C----------------------------------------------------------------------- -C 140 IF (KI .EQ. 'O2') GO TO 260 -C----------------------------------------------------------------------- -C Do DH stuff in GO mode only -C----------------------------------------------------------------------- - IF (KI .EQ. 'GO') THEN -C----------------------------------------------------------------------- -C Any changes to the DH sequences ? -C----------------------------------------------------------------------- - WRITE (COUT,9000) - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'Y') THEN - 140 WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - WRITE (COUT,11000) (L,((IDHM(I,J,L),I=1,3),J=1,4),L=1,NUMDH) - CALL GWRITE (ITP,' ') -C----------------------------------------------------------------------- -C Alter the order of the DH vectors ? -C----------------------------------------------------------------------- - WRITE (COUT,12000) - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'Y') THEN - WRITE (COUT,13000) - CALL FREEFM (ITR) - NSET = IFREE(1) - NSMIN = NSET - NSMAX = NSET - IF (NSET .EQ. 0) THEN - NSMIN = 1 - NSMAX = NUMDH - ENDIF - 150 WRITE (COUT,15000) - CALL FREEFM (ITR) - I1 = IFREE(1) - I2 = IFREE(2) - I3 = IFREE(3) - IF (I1*I2*I3 .NE. 6) GO TO 150 - DO 160 NSET = NSMIN,NSMAX - DO 160 I = 1,3 - SAVE1 = IDHM(I,I1+1,NSET) - SAVE2 = IDHM(I,I2+1,NSET) - SAVE3 = IDHM(I,I3+1,NSET) - IDHM(I,2,NSET) = SAVE1 - IDHM(I,3,NSET) = SAVE2 - IDHM(I,4,NSET) = SAVE3 - 160 CONTINUE - GO TO 140 - ENDIF -C----------------------------------------------------------------------- -C Print the DH matrices for the various sets -C----------------------------------------------------------------------- - NSET = 0 - WRITE (COUT,17000) - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'Y') THEN - WRITE (LPT,19000) -C----------------------------------------------------------------------- -C Calculate the symmetry-related matrices and print them -C----------------------------------------------------------------------- - DO 190 M = 1,NSYM - DO 190 L = 1,NUMDH - LDH = JDHN(L) - DO 180 K = 1,4 - DO 180 J = 1,3 - IDHC(J,K) = 0 - DO 180 I = 1,3 - IDHC(J,K) = IDHC(J,K)+IDHM(I,K,L)*JRT(I,J,M) - 180 CONTINUE - WRITE (LPT,21000) M,L,IDHC - 190 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Propose the pointer mode -C----------------------------------------------------------------------- - WRITE (COUT,22000) - CALL YESNO ('Y',ANS) - NSET = 0 - IF (ANS .EQ. 'N') THEN - 200 WRITE (COUT,23000) - CALL FREEFM (ITR) - DO 210 I = 1,12 - ISET(I) = IFREE(I) - 210 CONTINUE - DO 220 I = 13,25 - ISET(I) = 0 - 220 CONTINUE - WRITE (COUT,23100) - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'Y') THEN - WRITE (COUT,23200) - CALL FREEFM (ITR) - DO 230 I = 1,13 - ISET(I+12) = IFREE(I) - 230 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Find the number of pointers typed -C----------------------------------------------------------------------- - DO 240 NSET = 1,25 - IF (ISET(NSET) .EQ. 0) GO TO 250 - 240 CONTINUE - NSET = NSET + 1 - 250 NSET = NSET - 1 -C----------------------------------------------------------------------- -C Output them -C----------------------------------------------------------------------- - WRITE (COUT,24000) (ISET(I),I = 1,NSET) - CALL GWRITE (ITP,' ') - WRITE (COUT,25000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') GO TO 200 - WRITE (LPT,26000) - WRITE (LPT,24000) (ISET(I),I = 1,NSET) - IHO(5) = 1 - ENDIF - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Write all this information on the IDATA file -C----------------------------------------------------------------------- - 260 WRITE (IID,REC=4) LATCEN,NUMDH,IDHM,NSYM, - $ NSET,ISET,LAUENO,NAXIS,ICENT - WRITE (IID,REC=5) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 1, 6) - WRITE (IID,REC=6) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 7,12) - WRITE (IID,REC=7) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 13,18) - WRITE (IID,REC=8) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 19,24) - RETURN - 9000 FORMAT (' Do you wish to change the order of data-collection', - $ ' (N) ? ',$) -10000 FORMAT (/' DH Segment',15X,'Slow',16X,'Fast'/ - $ 28X,'1',9X,'2',9X,'3') -11000 FORMAT (5X,I3,5X,3I3,'/',3I3,'/',3I3,'/',3I3) -12000 FORMAT (' Do you wish to alter the h,k,l collection order', - $ ' (N) ? ',$) -13000 FORMAT (' In which segment (All) ? ',$) -15000 FORMAT (' Type the order of collection, slowest first.',/, - $ '(e.g. 3,1,2 means 3 slowest and 2 fastest) ',$) -17000 FORMAT (' Do you wish to print the DH matrices (N) ? ',$) -19000 FORMAT (6X,'Set # Segment # St Ref Slow',18X,'Fast',/) -21000 FORMAT (2I10,5X,4(3I3,2X)) -22000 FORMAT (' Do you wish to collect the sets in the order', - $ ' 1,-1,2,-2,... (Y) ? ',$) -23000 FORMAT (' Type a sequence of up to 12 set numbers on one line') -23100 FORMAT (' Any more set numbers to type (N) ? ',$) -23200 FORMAT (' Type up to another 13 set numbers on one line') -24000 FORMAT (12I5,/,13I5) -25000 FORMAT (' Is this sequence OK (Y) ? ',$) -26000 FORMAT (///' The sequence of DH sets for data collection is :--') - END diff --git a/difrac/dif.asc b/difrac/dif.asc deleted file mode 100644 index 5e3a999529220e6883ca8e2decad2cd19e1e1bdd..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 131702 zcmeFadvxVlR^O-UnI6wf55s_GjCsz3c}U&TExo1cc^EybHCe00E&t|*=F~NWxSjn;%9>*jxW(A17>^!hZypkB4pUJ>X91}c&fN_k81La`C zN(kih-TR#LJNN3Us=B8pe{s9(>fYb|{m$8EpZ(tZob&rHZY=%PHw+D3dg~LHhK7co zc#^lfBMpmfBl^|ZhqIZ-~Qx({L26QO>g<~xBvOS z`)_Z5=)3;xl`A*j`?1*%{LD{o|IP>gk01Ll{?^ZZ>o5GtAOGC%|8GD1(YOBi&)oT; zzx?Chy!O%m@-MveGk@gWPhI;fzxMv8j(_s_ul>spJo$^C{_dwg`19@WKKmQbe&09$ z(|7-g&wu3){PO*mKK;A@)1Uq$@A%Fy`;NIkI{kI;`FwM4cy{?Wf9&4oZ~w;Rk36&W z&ei6fmEZkmzy9`vkNooY{M7G#^tV6qgYzF>yY~10$)7p?c>T|P;Jg0h-LEO${?sRa z@c*9q;KA%=~jh%*MIBhZv5(Z{Lufh_f6mM+w(v5 zgWvbRKE2dfBS=f;Zq;`rprJ0Ti^Qb&(8e0Kl6#!$DduE{p`~Hk9?@U z{+WCK^nKU=`cJ?7i=X<{H#Qdk?q~k^Kl+Mq89Dri&-}N4_&@vb2Y+koD~6tW-}ip@ zx$pm-pLzO&A3FUXUwra~Pyf;{efF<+{=Jd6|Lyoh{~!I;w|>L7zU^1nzwRTqe(5)V?+16@|Gi)Hi~r)+ zPM#Qg3o{;HZ#E)$2VcL9`5(F|lDNUY@8;WEKA>-J;@>~v+nc{u-}L%rzCAUr+lRxq zp_@+(T^d^D+gqWmH{a2n-@v~OeVf*|ck=Ih^zG|k9lASoiHE^%e4Yl~* z;X!|0f{0(T5xvo1i`V1dOMm!@q4y7cny>ozk)dl}`_*s%Z|L{Z6~5B6|XPo_N=P{>0EvfW?>SMUUymH*nAWOLq4g z^SgiR(x0Dw!_aSC>bskJ?mzKnV7c_=fIYPT&oshILtj4h+52zca#`Mg;w|Y{{h~YU zS1y<7RoLt4FX&Z1)<(Rs*Yp1L(+LuLeA!-nTw7Z!idBCV#iqTyg9ZPyq?dm@*N9zS z=AAZ*RlkWw?1Q~86xNDA@9(d<5w)Oy0SIgSA&oE`hanDU!C$Yb5o>`r4I~UkmjLB8 zK%yt~vIg{K_^2AW04Ke(V=cr+)KqGuc);w$r(V{x?rHm|aoXr~vo=y= z{U3Jjoxf|PR(!lxT&?dkMvG#jR&3RZ7Z01KjiP?MS6rQ`f0O$TxWERZlm7WJ!H6N z$Ggo|(cUkX>c{oH`k=?Gf%VhV`kgueuOFY*JIywq!V?!hQgzJ0&JQL2yxcgccTSHQ z$EOCyVdJRTJ?-2Z-0aQc=50{lJiVuzZ!mETqRxypkL$(xN0tujCyiF|T(i{z;NIK0 zaI>~mTR8tzajvEEGjDkprh=5=FTa2CJ++}r?|IkIXL2fvqv`v*cD&cPJE(`g`yTdn zqkhmR%QX?_9uv$o_CHap)xxC*f0`)E#ZI%qgtw25L~++ZcYkC0{@`Y&Y*1G_?Xwd^ zNNB5jzMV&JW%04Jvh-M5S$^HEOlNpmc`U80K9*LlegUnNkyN%C-*VPC-ff(p=7$r^ zOj&Mp+6SHbQL)-YnBMHZu4ZP-vR4cjE8lWva;=Z}9!z-iW%+#lU(ApXovDQhBjJpW7iz_JqjQ9aZ85-;v(rRNc9TK3fa$i#zonP4-poRI zhyY1L3H@0s*RV#eZKGtaqZzj_b=DubmB|X0P47QpjSs1}2Y*^{v1U(h$r$Z@J!&g1 z1nk+Zm7>_X+SAOVwlZ6dXd8TNZ@jKn=3Mi-q+YBQOPzb&Qzmku)jT*hLXEUib+>S> zrz?GVM4%U)cy~2T}D-=%cohP3E=S&UTOCqUbV6bESnJd=GO4``iQmoXxLqp z9M=6#h?;(GnG(?pEN1|#_K z@4$)fYo!m~^|Mn6T)iILN=By0&Q5z@iemwheXrXTK=JALx4M#jTFS^2PrMh4*qli% zJ-C&OOpD?iZ9MSV1ZT075m-@t!cdUCy{=YpeDGfI><)^4!l>`#(-qK4r`|mb{iHsY z=I;{%yZ@OtMK55q_Ug!o-3z#XNxvljAp0fw2TqlEbqmJ_%*j^c)Bup}U19ioqu#}B zyFegcMHjB2NwQaht-{!#Ps6c&Mh^BL9$C=(ZY@f=oJUJ9@@kh?{_{KGOqLM_b&GndWscAO z+3{XoQV`~7^J{SJ>fLU8w^=`J>=k#K#C(X>y)@RT-z)ceVsaJ@+YJ_On=l9MnA(@H zZ6-W1talp4vtwgrIblJT({^#vY2R+{5wk0H z+easz#-Z$u+l`{zurOADq2+RkMj4kGAl>55VUx()E+g29QM$8kHLiO_-;j1aB-!GY zoqP1RvGn0`@;n%{(Xk;tB<7WKW3zRy zI3cE1-$73)uqaR(9fjta$+7L`D8q>tx<(7d@R}Bbqz!qnt$O!#v^cDT6MC=ny#u8* z?qZmo((W!3!-%-El*eo_ONI3GXoM(@;gDb`%^nf^Qjk-V$#A;`@hgi1suhR3*-~f_ zlR#&qle&jLX1)?1oYF%e9vG1NQo)n37f1zjCf0$shcS6aw=?2vE# zymCexMg49QK6Vr{1+7;5PKzsY$Y?P+Ia*B5%!RQ+_nQ7D(@?)%Z?=qz1D}?{m9dD6kHK8){9nzSSfFvY zPUJ&S2cCx5>)rBB1LQy*M{RI&(!PTnJ8PZea$_>1c@qu*pgHQ^JMx$l?U%1zN_88M z!k*FR9U!2A1BGT_koxXn6N-;AvX~reVQexFN5>5a4>2SP6fsrwFFZ4e&7%`|p4r)J z-{}^o_f8zr-Hxaq`PPl16l5Zne~Ofhnzetg=4@+eZ7B~Z?En=7&d-4OaTSCL^Hwp&aKi0d?3joUO4NuB{oOAk_| zd-$uye_%zk2^KoI+GF)yg)_bBv#w(mS%MZTqZ7$vYZCZ8W)SSPf$g|`3d<=aaR-%Z zBaN_gpLuVhD`XENMJl62OjICF>SwLf;trXj+WOfMlWrx=Y25s78NWFp$EV|1Lb zY5i7xny5J6Cle{KM4X|I{Z9MH0JK)rBiP+zRLf@_-6qr^wNvPU%-tcV-H)LNMi9k3 z$k&{DLkzPmQ4KKPMW98S>?CC+$e4^hXI*%dbZR%S zvJtBjTAXe3|WBcaeT1ZYB6CdNl-kraWI3{KW*nOUc1wt&mM_7RwHRRKXqO$4ni zxj<*io7i(po1?|r_0a+!ojGma5rm~#fJpu3Nl@ex8^S}P#AImITf#kp*g0 zp`UeHBIRwpEL@`(^|Zo2^#q$~1_R((%W$@s1nUphp_K(Jnj^E+j!%>P##-HJoZgY5 zF<}rXOjzlXohjPtTXM}(^HCUz0*xIsMzwDjM0hZ|jLg7PnsyQxVwi|4DF)&MJZON4 z)q*}RgF_N&CQYifAfduP7)||+_24u$PGjA(-NR9MwS9JQSoIR9yRj$J4vSQnku?Ic z&5Mv?21nZxh@v`>CnaV4CsO5`TjoNHvq!PtAid2%vG2@A(U5}ds@*4HeNo6tzYGjn z4f5Y!^EGn{L&!tsLa(XaXn= z(HB`MSn&yldaK)3570z3`k1Y~#;$xvxdM_)$4%0z(SoP3-6m6rP>4wIhtA)sSX3q8M2Jv3=7$8sE zvB7FU6(YP@xC@h>2i&8-gIR%Jd_uQaIf39cZvLSlTg{{9sZVs!mGA~g_6EAA?Gw3g zK?xWyM~{7>8clFhkt9wpCM*EBeTEO%?4Go+*ARLYe#9iwwm7rKZ#;%W-aM9SH^1Sq z(K?YBw5gIbz#K8m3Gx_W;HmCeGr7wcA|7sc!V>q&>PCP@aS|rOqP&`8OeD>Vi7r__ z!BUbgb$9a+8P1^PTbOJNGGxy!jHELnfv92h7@Q=TRxe>Z?!+VBY1NN!!383C{Q_3% z2gg_m&0Pl|s7=!v`dyeVJ_P9<=qU+k45w1!=0nMsj%YA{Qph8^-aM$RL>L6!hf|4U z?=liuY@U3?T%gLQQh?wBJDjjf6zJano%R_PsmX;qm@hJn&yFcWLI$_@U0<8(!UJK% zyX}rl21Q{o($I9dCc<& z@zB9iHR|(JTeJ5-x-ihgiRui z!7d1oxOj3I+{W+d-h(_5O$5%utT%)fp3hPv z6+G6q_C6a?hhdqtcpH3r}t)n?od_kO6i+8N@vsoUOZY8($5M(=Mxqk^H0ttLzpg8mZe55>m0W~ezTHXCC(K$YFleHObNg9k~7 zc!UEFM~hpdMJuNKLu){zA|&Q02+eA?9^677G*hLjkhY}tMS0K0Nj3vQK{~0py;Fby z+p^=}P75MLXUT@YFkM28A=fB>zgW48IT!K~cFUt+dSSLyCDWD}($36oNP7#9ifNir zIn(5}%s&Fp2uw+``rX&a40EL_qPCkjh-zR%c5_#Su~nSMhaCeJsc4ub@4YIX*h$L`Qs5mA_D%B851S}=ct+JrMCt483m+kBVK znO}O~1T9XM6k2&R;^lcH7UtS9%0H++X!UqJ9$+QJTYwopa{TS{hXSaF2Q&ZDK?PnvLf=~;ard%%i3oO zm|Yhi5t^BjapuiTA}1;CroX%`ks{VJR(~%Tv6&5pCqVAlyri0vwysM!kx zWA%d6T~FKA3`)4Mh2tXXGiq=VV`?QCqi+5M{4juX&0HWDmJkeUDVJ;(K~-Q@meiAN zsmMqSSIHhDrYsoT2X$}fsw^Yl|Gd1H6oD#;{AxT6#!S;Tv@<-O9=~50=M{!R2^IAc zpTG^v%)w(~DUu37AOr=K({OseYG!b-s9$h;=dbnMqD9mFZMhI$2G@^RHU;LlD5$`M z-Evyaoo&&zNfJWMM~#EJBo=v>3|C>S)Jv_cWYe2BBB{5MqCP!r-;Xjib3JS3x*KPv zx5MOB7>7)3I%BxCn!x4Bk^pN(Y&kSMw9##n5^0>cV!;S&61c+YsP7P!4thgFR5P0w zG^0TUQw>qJnXF3F2t6#JW(X`_lMA^K?2MBZQHv1AIw8z~)=`I%0DGU0D8{N;P^p$B zm`w>;7OjFJBv>Ba%#t;;#6-GRnvKNTFjyYm%ySg7omrw3ZnIGKE*TU=jl9JDR`cZY zK2-#vvB6`bwv9qK4Qk!!>jCf#L`sI64QoaM@BxiHd{B5HKvPZVv)HP)Mq8sN-6k&J zgP+f!*|uhawRSN;4;d8YezMf|@PP>IMQgc&VlYyB8(p3*sTh2D1-D7UFU!Z6gcv}u zz0b!%Q9n3X*sLIIE-of4H?HNs2A;iECn`#!tWk|+V6WjK<%HBBW}Sp)*1Oa$C}9RK zS!=^xa+M;$^(}djefUu`_?lJWV`#>dXKF*w^*z`N+X^xI!KhdT6&KYgmeeK&j6)C4 ziKvPM?%GR$+uO^)Z&WE#-nhW9o0(uTEg2n{P+nl8xM(11W+OBcWzq$W3qV3IqUVy39$&#YYm6uT4dIq1)3be3( zVjS5ERcxRTOlq_jM4F*;)8~hY3R9M5YIETcXKJdX_;c+Bl{ExRUlHS-HV%;UDmgN@ zB8cz{MiWsyRo>V%yF+8TvAJvGVl~))tA5Z6_ybWqRZ@a#lj24q#`~3VVu}Y;ssy?6 zpyw-SsAAoa#tQZY7Lof&0hR}kCTnInG_$N|1G-(oB1nf|w!a<)n(1Vxg0wMl%;k%&X5{Sj1aWyzBLFbmf)4 z#xe@z_XxQM%`s)X)c>xM#6(`=cUn$L!Q@zfR~%UlpP|7pIIuOEp@i6h0Gd#yX93CA z2n|)pA^260WRf4Ej6tg%sx3l-dZz)4>va({6f$daiEzc%E^gxi%~TG`-LanIm1=oigoH-&@+EDSMgo(IX=RVNhL*1*gtW_~$dNYpSE>vQpB>*iZr?eM$%0x@ zdg>9kq9^5ZaHjM$eOV>!80j;wo&jQc;nX#dmQ%ixu=6RE3UsI98)`uH`#zzR^U?nv z#Knk(Y)kU-Wnp#I*JT?zn}@iYno~g8E0jVc0JRuAj?4r!ul|MWwX(3sUf3M9#d7cU5)5 zl&4hn0c6{YS#`P;s)`}MLrn>{hBB18{C3g48$-of{f*1UpR- zzt^4H8;s~m!Z)5!^XzDhh^5435B4oUS_dqvNK(m6r%7QNt`l0astpOfT2+hpq-lYa zlp|L;H5^I1A-W?UKa^?by#ddPx$OBEY>qdnz@8WvybF7uJfpTs3{v68?$OX}(OkFD zh=wWDXJr*$-K5w=am5hOgDA{3FDxs%q~M{73FCj`jZR}MpX(mnNZqY%Ca8sSD;=aX zC`}~KhtcHC5OJ2g+9L<fnbI zclNuR`xOS6I>on6I#b9cfNQ-AHzpbQv2 zg=N!iDhX{fp&X2-lr_;tDw>l3#o9`aBeaJVMnDt}tUbU{tlq**=*^Net)bO6aE=Blz(F zazljQqd|kX>@DZ zQj_4eq{1z+ttkh$I|OQ`BC4{n9DK`3D2uL=B&_ZD@-l{8+4HlZ5Mx|>g{c}7Xt50w zX-v#&j1vO(8ituPq{Y-d|03C8M6hs8BFWHkgIlXupy8I1R#oW$N-p}Tp9xfuD3B^G z;VDxmuX}}zfrYneOFRVj+_<`T!pg+DtpJ*xw;y{;nxT&1_fb>K;v{Xlq{2j%xPl2A zS!HK;y*N|g8|xU?BD}4PTgwBXfr;^P)jAuyfaJOx+>pQ5B*X9vPLb9^s86*uI9lCd z@*htSxNMr}3YISU3Qrp}WN;vAx20GVCkI!{9&D`)jX#GSNALw##(S}Nd*X9nL{eJQ z8e~7IdC$q#(OeUF(Gm^NdaTercLXTw7<}@f^0h!hrzlx9JHa+Epd+GG?idyaC3<)< zE{KXyhV@TIB~g^SQ>&G)J?o()3|p-dzYs)dO=jlUxL;xOFu|Hi<7`=_>};haRfr_E z6D%#Ezegm1GJF|o_QFLNA7v)1_bc|fdM{tBJZ67J@8h+(@hel4#qjm^^AjUwFnO?X ztPaTUoAgF$uQVphezF_1_|yND3l_hs3R&!T10=qAlfykZU`h)PnVevfxQ6)rm?YiF@4N;bI9mqv?k z94%hXt*<)I)k>=-Gh)jI1FKC4-^F5Alf#E4yK;UjM1RO6vpa-VfF|A&zdl0)PvdD0 zZ_98R;rmi|bTELHC%qgJi{@I|;2>mY_)ts#VJ~eX9x{Fz0>Klmm5VF_ljKGPnU`)b zY07}YTGG|h_tqd}z>@wQ=-xKwxq%T^ZYIaL62ZmvXaNEc+ZNE0Y%m#xJdwqe3+qyO z_x`*P8pB%7Y!;V8(k0$!T=>_G!9rn7n0$uN=QFqXN4ZCbWka3AHooJoKW|uRsowUU ztae4$D(@kiLVc7{CL$~!HH*QWS0q7iN#I?m(j5}G0gL+hhji#8FWNaC>n3n8?H;bSaGhb1Svws13y;r z>h_K%hnerF5p$guf_8g!!x*{WkDus^CR@{Wx?%zH^VDg^sX;_QIQy)`hQiXaIm0he zydZIQFfUNW#>#H{5R2g zJqCeQtDVZUwsx>HLZ1P;xLQc`ufP-&=Ib-KGwYpc7T>$66owk;lm|mww5;koGpq^o;9$ zf(F2n^A^@j39JAWHxGg1JY9!9En+5yRZ{?M0AuwZ156O&7tbn z=r_Qj1oUlNIh~T4J1p4RRcw_(c=C5*e!Lh9W$B z{CBNfXT|f`(GCg+tlQ#x0hUWYJ!$DKM3|Q5Rim_)w7{z5!BLiZSaIA(F|&YOpnR0- z4KS#pJ1vx=q4tjS7c3Y;tLzEF<~r?T2D#1n_S;&*N&rf0XrlGl=&<&X&K1|v@>;-l zt&tK9akgj$!N&-3l-Q>i38lF&S-O(ePp4;24}JYrbWbqAeFE_tim;~B?*Q?qY>sZ_ z*9`WcUTTOzd-~LCCMqBzO>6IYBm-pt$3&}%>0hOc<(Bpq(MI#ExVN+u)X)~qq8Ren zP~ZwRZ}ubmy|6(}hdmIik#)~ZknrV+KqyR)5ej=( z`CO?@YQi=7Cw2`I(zT$2Hr$r20KrP;=jW>>Mh>6V9`M68|KS>Gl0Cs&8YByB)V}E1 zwX1zkc8P1TvQEDflNA_O>#Wk#qy8)-$4O*znEW90eW~LPxD(&7?98RX9mq_E_JM7O zpYKvcjIOk`h}1~?-h85!7(|4)G(N~qTN~lSyX^4pi8m(5bsql|yEkWSqUkV@6o#-d=_8x(ryG;ph(xTf7QFHemCLaAY0_`E$qh{m6{*3Lc8AO}3p6KID4uMrJET$@RV-8Q3T{u5t%(a&$- zmzZ}70+z+(Rkm;M$-g2qD`GVZcavnV8HSr`x;1gOytq%--AecufH5AMFn}N9f^Z?e?xdnO1{*LgSDx zs{e($-SGmVL(}y_z4pTHn4rE{YCl@TzHRN1(ULNRJ&SS;?RKlsY3{GAXMaI$i3taB zcDOCxe6M&F77ujwU_${~%34O+vGXTPDkKH>?(V4X1n`RKa&52zcbL>t9tWpirmn%v z4mVlaU;USkrzpz;sincmn&1&D0j80(O=k~c*ldqVA+?NypaS=3W>>O-X|i1r(Y|-( zL?R2t`~s>?W(4P%jcvomiTui_fX~zDTTRQufmbDbCQ|zcJvEZwk&~xM^(Qi{1ui>Gp0e4mU?XX_ko^ zuq>PHcgpS*?ublD?3!^hl_)C~!rW^%D0UXAt`s*H3--vcNwf+WuCmhKqWsD(DNbsy zb=xP0M|dD`LX`5>k|p%A4D69rO%d5(QudLxp_v}U(D34R?I!=5wBxgO9UtCi*xR=0 z9Sas2qX3OC%G$E~R8AT!FXPDi)9`AI_fL+vIly-?G(y}^lHQ~6n*H30)1rC+mF_l3 z6-m+Z1*13XMjOw#u!JJ1(&33n*^PlmCnU^8=rpzjeb7rp^G@mqRyh&_GVp@>GF+xM z$}qw{|?+c1hc}!$0ZiTW`r_#!H5yux&h)5SiHI~~a z@?sZl4ny?Q0xd7$^J|0NNU;5ck@YIoiiMZF11Vj%g|df?8R;r{CFoaw2pbWX!c9nd zL~2>00_}il*2{)Hy;?W9Ti_j=j}&jjWkAa*JIv+F#qiw|35jRW_WVUQOk74?TX!Ca zuv>xRGFC)zEMTKfBh=$Ksag4nV(b?Ev%FDEfTVDnDS7LirD74~F>w_!>l+OhZIyj0 z}{WIz4% z2*?JpubiC6I4OIM~w z@~8r%3PNDaZ->~tjr^{PaJg%eChV>WYb(I9ji#H55Sxa>Acys%E*X%#h^d62+fi>p zlt8#<`QBU5O~+&^<`bE1f??Ms>C~}p?xIA*Dn!$Mf<%Tq z#eH$LY%EE`sH)O1J=H!i=DJb)#CQ!AhKrUgMNM8noqkT4Xs^PP*AV>H1f*cdoZ@;2 zDPxKTI|1lp>_}5*Es=C$!fue6SIVEusgM||18e3swA^Dc&tg%og9yP-aRq48F z4tMKHsbXd*m1}!VkuAUo3bn1)L1{ZjD7U5cd!07v2!!1;m&de9S#TYxpdsrDTG8bQ zN^Y)v=kU*e{guaWu5egdKb_@7=W9dbxtOK|^z*u$I?Ju7;!-}wEjvInZe(vhgYBte zQGHj`EtaWRO@g+)x3ojpX`i2CA{I@nbh|cEa_5%lRPdPAk5nIK&w=R8$WmtL(SlMP z1(LyZKtL#;$|UwI!=Pl< zoIHY=w!OX4irr~EA5oF~fNd*E6{IrbR7Hks=bHv&P31Y?XtHD!E~=QclNh=(ZDZqc z8AhP`#@$epqM%LSD7Wz|UR-Y|#@&Dc*KgG*=XjnIHFT&sj0`Oz5RPg<$0c4wyl6x+aqk8Rig^ zBeI!*#@aSR3`8s)n(Z~rM|35yS_q$y`XSiC@zIULTRge}EsVM8Y@@4TL_c5W=A<*% zk8~fY+l%h2BH3?!*URtts>d%@vIE0xO2V5($~(1NRpMky^Xyw z4{~sN+TnK37bLdNMTmK071 zxK+0cPsXuPdmn`!|*jt=KL!yn1f^~s3~7>A`1X)(K8-QNfOq*QcaBhZ8aO4(8R>_%rcY%#p`4u{UVEu ze_2G12}B>*uk^q-R=uc+UAU96uE5rjhwadj>RC4bqfT$5(OI@FX`DnG#q`qJ=F+v5 z+S(0PgHl_Ys6uDdI6CPlK_CgF(=K8ZQqsx#&*Vl}PlnL5HiFg)wb;yTw%8xyY_sCB zS|zQvK$EZq(qdJe%R|b(WI!e9W0WGMjvh`bw^cY$^&Nl~sD$c!%;&y(nKDQ_&6VN> zIwdDc{tznVC*jfeWpI({d|J(ZRLcp9Bxl0OV^$erR-`ORgG>YVn7dc?o5&=OV<``v zWfHfQ&&7MKys1LbQ?{D7P2-(FfKbJ4@c@OixEru67DB#4NVVFtr0ziRM@ubE#d@wr zqDd9a>DL|}>t!y-n#+}7+j4S+mHtG*8thbcTs7}jaLi#d!)XAv+|hR0H;|a-0H-xbrN|@#X z)MGYjP20{d5-uI`8a|BA$#m1M&CA%;_8BqfxMF|{9R;3JYoEAiy(NK9T= z>qs0L2qKbZg$|lCbeNE}qdjdWTM>FXbq>OmQnMivnr9K69W*Ga6Y3K-_!f@bjwe-_ zW(*o;+UsX6XO_Dfs1rN54-_cht}GtBnJ!f zh9Vl9Wyt=73OsRKGR2VaG=9P4i><(bWwP8vQd`wH!|*g0$UmPuO}}tTxN*|(Nv)V2L3XY6me6Aus}HM!kJS&hywa=}HHF27 zgHf<5H;l`%!i?H9goPd%ID?iV6?DHeryP1ZxK2EV?8OBjZAHPZRaE$~C6a!7w>jlR zIG6ghgCyM&(FvV_iVdsj1W}e#+*o6Y{VGQZ@Qf18Is(Qp2$Q<7t%n6DTn%*9m0D#k z)tIl}$qyxUvhkoUBUTU#tB?~6Bxu$audl9Mvkpbf+5lCTg-c&uB7|LAxsl&Q?L(+{ zV?UI%rg+fVf6Uc3Gt)Q7wdL*gg)QsTH+KM6rbICTbl#PA4H7UKwi9U}cgr{#Xlg5(H%ar+2e8$< zwj2Y%ZIpJ9W~k|AeJ_JRqOd`MFN1MHiv<-)x)_W0j96_A=FEUnJ%VmC3XVG!&_`f? z@Tilg5__q+J`U^WE>-=K##snE$AiZf6}>)HU`<RqZF~qqD&WuLaJ<~pT zZbSA?G)vUmyB19HeZj;)p&j*{&3SBA?S&qZoZQ5&0~~_MD$SPgWoOw4&|`L$WD2lZ zi$#`)?=w1sU#=aPzuj)BWX4+S1l>o&wPN$kHBp?3rDeqCNBuuXWqO+X4j~?^kSnx#MKSx7EFk2>Qbp~t5fr^nXJa=Xyz&EZ9z za5Arl4HARe^IPlJURc@Gu2x~7Ng^axa1xJ(oybVSRyjnsxEHpz*Vhzdut^Gok3YhN zkc6ZHByUM%yg>q@dmV^8cC#Hy16b|{llv7@tKdVY5%qD9g@&9u7NR_-0y)HpkPJf;x|Yh7Q7U zVIF;kat;m=LD7+l$A!@+48=}hWE=pdI_Jw|hKL#X?9^e~=7yfi?TBF4*Wi#SnMJi= zOk&;&147*cXZR{`oD`hjl^R)=N!oXOS2^I^EpJaVx!Weu;ybf>X%sC&>az+Ng_F7n z9uQW7vvt0aP%L;BIR=SQU3dytI)Y2*Z>{$q!4>;wxB<_$%Y*BA$$5CqkZgU3?;?57 zz3iGeJALT|e2g7PSAqSoKby*4IDsOV1}^9&;A`1_Go%?)oR2AlpwdpHHV5(-2qWdk zStF0@rj#lHAcaooFYW%jis&P?zB6%N*`a3&lYk~ zS^LQ^k$KV7(rIjc->nwmU=*d@V3}hgTwz~WO-tCt*7nS!Pyswk+=(OnVGZ{Y4tI-` zj9WOWefO)vUbW@MZl;f6E!pgT_y}vB3DstdHCnnnhRZ_qQgrJ|`ap(6Sohmydw(3! ztLrYk)Kk_+u&2sujc^W%x!qx?nMIx1kN^bfU}0?2ZWXU7k}7MS!+!$5(>{^P+~Vl9l|coaG#^F|(=JEA?Mqv1>2&+mpGOBaU)`-K6>|} zaOQ02sKUTt5Znq833TGKW9*o^}lk(IbkV22!UCa)HWG&5)gMMXO4nCyyBo&;<$d<{^>SZzHya#?NjeMGx}vV-f0R4-LYGUo{(!S4bf01C?l zQ#%^27H2l*koaQXUb9rgK1|`5i_#~EZ~PAnR$&7?yyj;hU!Fg(PF zE>dj~$1K~9$nY2ODcfl50y=F)f>a+Fu9BgJJbfL_9!4kkE_Kni!E0}zS~?ZU_%yjy4z@Rod`OI#i6jYA9gwTd`s_o zp|A}^aB5I^zEiAS5$AETqIQn;@2K%)R>^;X2!lM3F=6I!h+Bv(f&dM<1^}sc5*h3` zTI>SavSJQxR$mK+Ow33pmOef2QVp$xh(%N(jYQgfRm8!0GmXYi*QA7;b3bS=uI1-xt z8KrT4A~&2h0P6+DI7rmOl|j1TgraF}btdWjY_SZ9jq(-xvOgTyDVfjehqA=vM&Lif znW;d~y=AXLXBRQg5@SU5dlmC^Fy7p7 z9>ADjv`IA6OEJREvwe00F;U|Y#e+g|9doMUKkX+fv91}%0_f_RU>w;4+^WkV>*f-lUsbZ^?sI+f|2R={gtRu_3Z zj1=F!1$#v^Q&eWD4AvcjNb9W^Zy`zz2xdjofS5l$h2HcHs~PTMRVysM4ocg$uaId5 zuxMMEe7?JxW>}kbvmw3j<-RMyr5faDL(v3tMgeRq%=%^{r|4kVV*tnyF>@Zlqe&FP zDq3I`$Nzr_5wQo+0MnB281jUw8wIoaP&=6Yis2h0#UCr!q$XL4ea}@x8=e^-A0fJT z(VdYw6U7#o3M>*HuTi+TEiBot%feYPG1Y^5kNFrX7p`4K)`>viJ=_0I<@>5!ofI$n zHfiC~m|r5NQr)55nG4$f;`>fm&mFGcyt$=`w4E{V{mby7f14E6)CpxMJl2&SAvDD zDgBb73KinCnt6dd(_YWoaq)y`^@0bMYsBQFZF?rhEYb%&b)#0?Kyp`oD=K}Bf`!dx;hUn>W8A0n=bkv4+{}}v0*>YE(Lqv6 z64%ak82-l4u2HtT{jiV}BREq@dNztOIB3Hw$9p5i#3)N=dM{0nvP7r%($wg5|E1~C z8Tn`4nYYzX03xNVV;iAl6ez6l4Z4j(j@WdkxROU!RD*D@xWTHb zN^6NwWmA|Tk3V5WjWJUzqn}<;+xa6s$4lWu$caz`)ObSg_1kUYtD-Wgdn}eLaO^fn z+NONa2|8g#vy46lOY#g5ZqO>xXM**zyN=l0Tph8Vv`J=AUG)K|G3^s|8f)+GQ~B(x zg506oZ?q&>h(;+FN1`0XO!OEN4)YKLVF&fBIKE}MZ0B-E4=eD=5wpi#xn%dcT(yID z5CbYy+>$DEMgufYKHZ-K2B^k4W>Ge!a5V}|lJ`d8% z58zU>5smw@6sFW86_5|+5Lix-OMT zyblTpxG~-5_i!2)Exa$r0XF zZWx#KZBgy0o+}`ry{hlv1&1CjcOER#9%O4wL~gola}%riHC7kB#yG$fDsqi!M9IXj z={=3Ow^!G-@fk$E2t4ApA9HM%W7W@g(}QOzChWq9l%;bL6pI=YAascKX=4@-@`{=w z;|U#cfH~!wAhY!lzDPt!rbtGyh~7}E1fJa&7!lV8nlwZNU8Yz=g?~G^ysKSoz~!lJ z9zZz(ScYA_cB6BEc-bXs4YLup5giCh@WFv#USbLE#RpaZ=sT7&B+N3iLNx9>$Uq1% zGZ{|`tsC8u|4!t&%~rQj1}j?YM%$oi!p8$7%_u{tNBW5|^+f0KhaS9BmrBG> zfgLX;FDVA4Oi`v^>P>+_?%9%wG`LMBY~etpITiE&(k*^$ z5`$vWwl{*lkgkccp-RwG&8vlsUgDQ&7O#J;K|Q_Qb{N^H;-dx0q6j_^h|q{0^SIlb}Fb$jQNN^7f3s>)A)k(`Wh z==4UU-;6n2TjiVa!46h}5ac$@$hhZ4n2ztPSf*t>$1#z7$5TX63706SV20LCa5}V4sB}wnIA7D^0mSbm<73)@`)zOy(3GxR(tsd z;}`tK6?~d^`OX?uKQJ;-Fu&n`9aF_UE;`J(h^|^O?Cx19|I9{zwZ4NLxl;Q$9@@vr z9k3z*>1{5Xd2I7|Y!kSz6BE;Xaxh!$8sJIGP*r)a6pXempc+=hl>wwZ>a}VO!|4vB z!dw8THke7;2~!SXj6+@Rr2q%@HwVTyV#BeDMts2B2TzL@!L4ctL6VtueVJz=&I->( zR!%(Kvjd$Q%%fqsHNerLA(Y0DRqTlrmV9b`8Q2HG9+8k2+e;NXqE)u33r3bSMrD!0 zwWWb1Im~eh7_``GVkOOPWzW({W+?S2D8LJSSVFQY%V0|xNDDLB=&#oba|FxoU_4pV zoTxddZ{2iEl|TYoGnV&it6IhHy0h-e515_uQ|QT8jM_cyZOqBaAXyU~q|0WCXh(W> z?G?}sQ%MoD>i2j|E-hVg-bSNwY{4PEvaYTpF4GZQ=c>SD$Jo5e*x~m2`7Fvsx z6}?$Wn}({)NXeOOF#T7N0s&jYv7n4d3z9`MbPn3szWmL+u&mD`9UN+M%}`h%tIw*> z;#Z?+5y+g`vQQT!mhCyC=tivPu<-~rSqxtY(#-f~<1QiaM=<*v>w+^ebLUyr}caV47LaDtE~jBcaXX0`=$ z>Otl5nNj}By2u@jr$=6S|Fe(30Csj@p+YyHM=x}{9+*-}}D8Eekt=UDBC9$pP^iXh&^bBcY zYu}|2S%}__X5%yRW^2XCE!|Pfg=gYLxa@>P1txHa&xkC{lo_@>Ri+5sg@DXtxk{kr z-pDYl8jnBCnp2Gz7{q~K^Hbu(2qLOhcptZSt6<^qRjldS9HlZrSD59>=4F@3qKjmf z*Do)x-`E~oUQeL_L(vCz)i>#$Ss29W2O2s`#xcn9Jw1|*8 z)&mD)X~zKhTRd_^h)I>de`GTd6x(c;?w#G*|rDZmsqS~Hmzt63QZKAlN>-aJeJtHG`o zX>q^vUKXWN+RMXcggSOu^Mlc)VD^P&m{|<5I?5bgW@`@WRCLxG;V@;;*?Bqs4IX&08gQcDfAKW_y~fT?1=)m7b~>K-6LY(0I;OV0#6hc z@`dGz6jTPt47@qLBOMqM|5HZ8yBOvw45K24F<-hznbA%=jA<+E7!hVGmecSxthzVC zN`*<;(i1|vwF7btE2Ao_rr6f#j@`AcGBdW?(oD||a{~{E6tFyw_c-ZS=(GK1RL&}} zjHnfp1}r9*zIgW>;|booqWUe7y2Cj58r2}E*}-U#Zk0*7tF6SgE)Yv z#w!594`s&zcGxFx~GF1GqsQ1sOi1jCm2NDPX~Pt$qev+@VwQ zL{@3J1#;HH9P&p3{<6Xugwz0R<`&o&X$jKYU<-^xUy~vqz$?QW6nU~5ui$`C6~q{q zb9SW0y^45P)5~c3bsb?7j~q7)qGkh49v$g0itC=gVco9B zlk3IR1}O`Wwxx}VWc*Cbh7Pq~OJ2I*idgs5J3CEKZj@fUf_O97f)H3CnNGwJm@-jr zGW^*j>HNg8TPE^a_O7?Fp3A*Aj}5*#Uao32EA?T08lAaq;{wvQ6)Cr`qeQl4+7;JB zMo{z|-D;1Ry4+sOE5K8+8vGCiS`1UgtebUdnUs*okv#MxgYi)+?y%%J*c36RJ&aSn zLYx_&is2g|#$&<~aA_D931SOry)6%f>IHVUJE?P?2_yEAcqPW9Zkgc}1SvnoeMhCm z&{x`@&>7Oo+jy*xV}@faqNZjpH(?QvDR7H}><%ma(jP4&PY#GEAZOI4GHy z={|z0-QIxRP@2z#pe1pW`Vd;Di2Tlt`@DBcQlr2w9wI^v?ipIXR*mu^WqudybpD6u|ye-`eL*y zn$Wh08DLr0qMV*v^~Hh!*-gPUhf?&bML`6yBt|GzqmOkG(LRn;j^(HQ@`w>@L{Xl$ z&B0G7Vr*L}km_`9#G#6(kZ!dQT?(zKGHPvb@iN2x;&wIvIW4-`IXOM9v@x;s ztUN+^9G{SdpwgwRWXMiUp7?;JOSoqOzVb`sA4rQCt0JZ{LsT@8#(P#PYi!c}3KTQZ0{cJ`|{7zzf*?O@-1T;X$V}Hrj{5)0fP*8H>BdCH9m2 zph{qh?E~z{F5MNtx@hjVR9&6m@o`gEi-!}?j~*fC>lr%F=ATQxPuPSh&mSK${=P^) zo**C3OS_G2=p-J68z$OV@f`v*{=EP1Hlx za8Kuo72x|spGTH7Rc`2Z-#tO4KRgWSqQ#>VP&FlQ)WZy(ybosk(xzMGJcgv`V(Q@& zQTdL5A(vsYP7IN`B1kV6hgz5HVg8=j3mgF>B05ew%_CwH80m;2Tno1Na4l?xf?7>G zaOl*o9$~TUUSK1PkIC%-_l3%QU?M0aY5p>LscCjW9-Bw7$ zoFc188#urOzWI&>L0r_(yr^J09uA?LDbrkGraDPO(`?l_)%0MORk@djavs`h*>KSp zDSxHWX%}TE6*F@Zwqyjdq&nKdBRccXgCr0y|5Y3KF&*sGMw&iESI*cw0fNjz1GWZYHoe6?(*dk04jrY~PlYi?Xn ziA9MVz|@bjoDkB{t9MNw7qnJX7l}XGt9KbHm&UZP&+dq;d3UkLZ-~nE?cMCQw)U^jKe-2o0!25H74+cAp(1<*zAq zc80Ze5JPa%uBB10@u zy-J?UB=aT|zwkn0uc1`r563oj7|ku!kd_Pc5h-eNexM?R;U+SvZgC*uk+|ow9d+8S z5WlW+kO4;0vL< z#qgIDNAEpjx@Tg3{F#kIUt#G#kEsbRXFrD~q*Z$Fd8X>dS5=NZ1PUpg-g~lc%EA71~^V7l$TB&L0I`D*{lJ;s1PZ7D_96^VY!qN zdN!xc8X!AHf_f<}oc8Kq_q|x9tqmXCXNi*9@^f+H{E7rHwBQ=z>gNUR>Vn* zOHoJw6Rgo!5~W+R!&fR^<|+IrTh!AnmRGh%i|5uiM+5QyvCU(W449kp z8mhUp+g8UH!qZN~g;)b_@R4WIu{-|^CoWIeM3MV22q0mc6 z9m$Mi!ug}?N26fX>QB0?d=h>qE@K0e9Ud;GSpdrRR{1j)7Z@{9O5Wce^UR1Xxdu$f26RwfM8Z+5$xdIlYNf9`r& ztRZH#8v{lP_*#EHpbVS|W0j9-fp#Qlut=cDM&0PoXy0pCoga8C7%ExZ?u%2Ewm6lU zLe6*0wOJxqKWvf2YZ3)IuTN7mbG6AybShil%+;o6rDkQ{%uieqg}6nO8qsalOO0Gn z?SvW`zoLCctP$%XG@@%Wv(uH0klN}2XliPvHa&s5`a%G*M#eQ30W>il0rJ%&IY4tW z4+E&e5Xh>{&6(XeKj~&iF){ZVFl1oR$n3nvSJ22b6%fpXH==7ZQ*#dksKU?}0FWA) znm1EQ0CA))F8~5xe8>SBpL`fV6^5o}zzZoJ0Gk6>(^gJ%g-pcUqtTEdSB*?_zKl0A zn>WI>VrFvUVE|Pa`T_tl49y7)2T0VUQO(TB-sccvjY^+prsp39P=%oa6JdJJFf9D^x4x7R| z;7-?Oy_9VX%AGYdOAcZi*h`hA=vP6!^qj?ea~)$QkhJ~A^R}m%sm?08KdJhr>quiY zRViYnh-`!Qlw3>g*v@$v{5n6&7JY0ykG*G^T~ZRE?8$5aJKND~3eI&XvnFods6cUl zh`T2cTg72_v8R_jsC{mb>l}=u!Gs}26Jm?dnr(6v*2bdCxl^`Ggf$yC0!II%a|uC} zJwKp{q>SQ@58knFce1O}}P0dQm3UV!cJSmc0{#r59~mpY51y zQT{c#Ea_2_`6`CQbnJUr0q&Uc@t?|A+DjeZDUO@`KN7xXth?c1e$ZY+tE#iUgc)+j zj3XG9W}mPyU2c@jA__1JRGAsprRZI5yA@bt9I5EXsn0*G$o!IgEaOIdNM?URq&z}_PBt<(vbYO>`5g9khlnnh3b zklDb&j?a3R8SX3Ly?gaxcC=+0`WL`98BUY3VFjizsLblKsx&vf1HA8(pTIU8VLd55 zFWG^f;Q)GbTo^)_KVP1LjVf_K#kjdg_Js#m!IhV9kc_i6<;pUZJ=@nq5GwZaR9YmZ zysR5L*Vj97%2-wQ%_L(y+M1)XOTwQVmU;t=zA*^7f0ZWNf##8rz^N9Vs}hHtpUwj` z_bsfrp^z~i`{4V$S0=aS+ydF*c*#Im2vI7eRHm7Vc|hy5jPucQQh$t1C#Z_&qZ-NG zN1@7(rld~DNkW?^fi@9lvce&C2)JZ&-lvHlbFzD1ByOvVGPhGe8NHb?FG9Z@C?}p2 z5^6|h-~=rLg#z>9!K)wof%nZl_T?Lk)6Q(6bjBD%!4#x`vUEufIPZ%rHHPza5I2@k z_%Yt)&xmb8{KlwW`Ac6yWiBdfXIRl7O!#bvLWSmWX*24le2F7KG#NHDf;N`OQ0>k( zS-QY}-Ye6T4+*OF<#p02v2umDkrk(lL|~U0>K7ag+jtyusMgYYqn;lOwWDkXC8RlME>asjr!nRFeD#gFF=O$79n0wCwg;tr30Z@>m47 z2e+}p7Zz6h!hxag+ftBW3c;hM5I?Qc#vN1ARCRS4fbU=6PlYLS=%`uB7qS_Z0B98w z0DT!uq_iP+%ea!oCnCtsb=;nubrbIr2Nu8Rk>duWup>Mm(2>BQ)Y=XZCA59krus0X zc&*Z_=L8B}2_^H>GqQzPB5cwpYv$ENRh|U< zifK}*E%6%4QGyMct^H0F7L|c}{kmp52G1#VDW!1 zFe_X<;ALRt*H>&Sq3f3sY8{ddKVEcemB@YagE!wh^Y~3Cw$_1ld0n@nJhxu2_hy4wht6j3Jz@kZLL`gS zBh9@i8?`$B3vJP}FS54(3M1D8o*t!*#jTP`V4$tng{DA`)Jt%ga(zVIeweYWzen7}d>r zFE!&Cs}dt;rogiNm?Q&bXqAAXs5HwG_nKG&wZg(Hc~U{jJ#6}9Mtw*JEgd5AwoQko zBIk0qrTR5wm2yZS$`ECqi4X)RCy1%ZSY~Jzkp$E|yX?hpX!A0pp;F`IZ#ZL=9V%HrK$rAr=t?{t9l6^Mt(gESf&ePkv%p56!jRe6ti1b#S&$0x zSve+Ck>-$mk*eo77NE%F6X^vLO(Tj%u(zIsoV9fBIp1PG4_c(~4#zQIB~t~ejlDvB zqZ>^gEYkW?_6ovcv2EYYKp35{X$yO`>rpoxM%_o-^mf?0Ws^0Lq%{EhW7S^hI!cco zhz;my^U5m05Yj;aoXw+H7;Bm#Bt_Fq(Akg*Y6!CXwU2UBYoFPBhg&77_~>^Mr;)j< zr7rAfvSk(6Fj$BH$s7~5jMY+d4xqrlh>GxBQ13JtY#dg_9JgKPbBP#W&w?shED$eA zzB)NRtIwD&pCbz%zhTJOEt`jJR;*FXtA$k-<6b)3VX0Ozr#+b(+G(DYlff%(Hp~uE zw%Vmi=L}Bc#Jo)u)j8eu%0I?)1%ip8rEYk_#QDtllqFYWea+5IPR>mWrK;DTLLFV1 ziQ-)a{L@6!y)Z?O>id*MNcC-Ue0o0KJZ3-7&&+#Lhi@b*rY0;Cqu=JPjL%F@2QSxf zRK2aUxSDOVNfi%zEyb0jJ-;vb0WA!RGp08b*R9e3_Z&CN2U#BL>7tUwDGUN#@+!JQigjyp~E?Q7) z1QCfRlkm7wn=`w*=hvwj`ob)ZzY2j<(_so}fi_;}>oK)~tv@EP`8PoUjRt8rnk8|< zm#NvBr389^RYFb`O7T~XYLd+n6`fc9O5-?6pl=x|ma5#T@f1R43UMc(4a5NiL zx!vCThV*RVR8gDm*Q4FS0nPEoU{cx1aCVI?K<%~z**SVnHXL+ppRPgKdQf?UExxH_AdLh^OKQ)RCQ^u#LK`o(szk%zjK}An|%X z5lRI<9?2#=OLON_NHG=VR@QSD8C8hMT#w~bC+cPgiOF1(DVC8reEETa!HbJO*GG3o zcSnu*M@9IfM)iS*`2z!A3G5q~7xLzR%C%)^s`AW&QppJRD9SOtgC}jJR^dwfx5<7o zYqcJ>tB{-*H}ltcgRiDVxaN998lp!>gxgF#sFu=I06t$lV+AK{L>H0Lb;C6(XM7y{M^*}- zW&KRgm{bnd4<5SaB$_@-zUmnapIN(4YDR_+iFod_Zxiz~vns*m7uh^hwp2sE$mXGX zfNY_nYrR5gYLHMeY6xX%luLSYOJ_&+`I&k7Rgx(lcZx({V!(qi1S)|!OzBQM_x%N=Ox{7NC@omPo zW&tX)scF~s0sJc!C=TbJOgyV!3Adl;W4CtHBDTxa1XW8s?qtMY%%6!_vk2y~GC7V> zg66e41)FPEpW7be@EPqjcM*oE1po#g7MoS601KGK4_89GCo)8cPdP_ST#;R%(TO9> z{&MJHiK%I`3nEWkQB^c|iYMkL%(@9oF*`0t06WBO55T}+G3x_1!DMm!L-oS@*ebF? zra>5CDZaV=Q509}NAcSvC-<3Mc12vat$jx79Yi)_;`Jn{p%XXA5uv+_K&nv$eEFhARkm-tMAlcv=esV8!gth#-^rc zuZ(hN2AhZBC0mw{sI*jYDop5)7AxHW)3F#YZ8$?=Ir(OmR8w85+_7h;h%jtC9|TUy zonSL$vJS!?yF2PY3mMJ}L9AMN~ z5F@U=W;_8@kf9YD0XmO)RRDq7km#c&c0AKL-V&wiie;YKIyJ@918($lJB$AW>(7jy zY`MN-Hi}stBfJ&e-zO6q_Uk72!q6>*7tOO!mg7M?t&a6nEyExQ$<~T?bV4r1!oKP} zhqYpxhU#hXew#Zj*`$l zXY(}J=bTC+{)x8j-hf_ZGsCW4v0BNMnq^axk0HF<2^1}k4=A2KIC z{a#YT^5v9-s9&BW=w-~g4Y3jlcPkpOB>yj$q=V^s4j6yAg-p{UW`D+Vok7C%)X@?_rhI1@Hl zo;Q?7`swj6n3koGPiyZ|MJ)-~V^pY{sxs}onq*DLNO&xxmPl?nvzEo=NO6s-A(IpX zEOUZyoY}OblagEbnJZfGY)DY(k6y4Op&z*%{KG1^VuewOwAEM1;qRdnO<)EQdt454 z{Cfz~*0Z1V3mXD#;+I$uw*R+<5j(lF|MIFHfy=W#T$DIltJReeJ3$lTk2oH_Ho82z zIl3^qI?9jxnXy(i<5JpW@4YMW%TXJgwJLD#6fDeY{4Of?D$Oqm2j%9&eAj|o1)<@zWVjgHB-KvI>D?6R|! z0!6d6D-*M$9#P`+B>SIWh1m6Rj3W;$O-yLbp6*g~N#ACt_~y=OF{=*X!{UW@i+T}y zB+NE7U85|!ik-ae>;L9^rXRm;GH+3kDxgZ&ydL>`i3KamR{vxW>&0ig7QgGSt|^wJ z7vJr7^UidUe|CY7y2)--gZi$&u|ZvkpUv*nk7^+Fq?_&G*t33DZ@Pz9`c3{`Y*{VZ zOAm*C_B}Lg_i-UToO;%S;oN)ik zT2`>ZevD(5K`f}^cQvFA4QvB}FS?0Wf+Bv`Up*Kf)^~eGJ@X|!z;*p#(C7wU5$rhT z1ev)V0gUvc96g2`qna(-oZ<5{eazF z?|q~N&OmX!)9DBR>-RVsV9SaOB=L%UEz}_%_P=*DEnx?=PL$AS-NVzLG)5V9AR9uy zd}3pwnx3avMvYH?ur?j~34hl$Et8H8rpQh=YM_u?mI5r>O+30m8`EPVTF)s?9l-b1;)!q84(g&dlOLs12HyE(HX+WInrgUpS1xgw?9iTb` zz}`GS4OgJ-F>g`qn1$Z)(ygFC&M83oP7Oe@qBTW#sgV_x{+oabGH#IjpXhGD$~r&^ z?uve_fEo^kr3rt*MsT+!xHr_C)KdZqlk?`LY`zsx{eh?~-36eS-E?>E)_{tmpe1$~ z)p(NZ=!aR1f-w1<@zd{U@2A;E>ERRVEBN&U=a43cIudy&`^r}Zli-E zDH|QL;lb=S{s!{^izH_@u|t?#PzQ=5vTSd4+EmIIbR^D~VOJ|Vs!2^tk^@@GlyUVI z&vm{Lo7mX_Tx5t|7a8!om#0U#T1|~s^Xa6u5G}D44S&ULVRR4|XD2drJammd@8%Hk zRxV&J4^(z5CaO{e%G5v3BT!VhU3c}z(rXdl0EnJA+c17?ccIMttxGE_ut zRjW01B!>!Ym4S8lBmQET=x5yzuE-FYQ%6`&|`e!POs>rJ}k*S{GMx zv*JtWATI%dBoV0p$cl`;}MK~uhaAGA%&rP`f2Uh)Ym81FRwt^T~3bEm27nm09_7$ z=tZE^R8A(eRL$M{KmYLG{fj^Q`057~D`@#t`u*#)3~1}DV$LWq9}{7-k@DGg(zg6_ zpgc~2(KV(GEnigT1*lQUHHB&=uML6=3AxDt7}uD5RhmM9OpO zQd3|i%xJ2*mJ3gf)Q&R1s6cSU1|9$K za)iwz3rk7SsC>f)dpxRhWnH=!!0tq7-iY#LP!Dn)i8_!g17#UGICApQyUfqU1`+!g zDT}M?3d?eqM-_fs7@7mr@q%mWLN5sv`KW3Yiwr=2ovBEtLm{1gij%XT%G z2%amAWbkoN7Xic&7>C*&D!8r2yg|GVA%NkWEX{^s|?XpS@cA?96-B zd%4(qwb*mLluU+?-NWG`*k`RgF4`(eYDiQLTt>|$-Oe5*c-odjPUp;P zrBL7qrW?syJFv;|>5(KpZcL6>fJ5t#;%b4zQ-*?0OZ?`QF2_A~n*1{Y*nS)iA?{u^ z7>!W~xPq+GM(ybO1mJD&B_Ms!11n(9W6aNG&{T?9?jxV~1(IVAmlv_M_E#5&{Y7L4 zIjqLh)Zf-s2icFa)5Ge{gg)DJwWisgdZhH{Kl0n4O(!o=v%8fO$ZOX|-Gu>9{uR$M z{W-a19QSmOdP%gI1iNOA*sx7-gMR5=mx-* zr#9!24`IT~sJ~k?r=LLv7SF35^y=QO)V20VqEepduSpxJSE@69wDq{xwH~jSHKeIn zp145ZJ(E^JM@&w%!-`S`5%e~YRi}nMt>#*O!N?7#$RX8ZLYIi#JaYAURjw8NP!F>x zMmB>fbSmtzuAC$oFHT=Tam!^F*4jtTmYDI1N*`6&0CHbJ+&QrCO!_dlFlo%d3M5xD zr%VQ?`Bj|uYM8VwPqM-to!vYaNpW;=*P$q0#!`qxn1v>57uO|66=NvhJ>G`a?5cBi z1!I}d&VI(md8<~^QP$YNNk}49Mq$ORcWEY z|ACB99WGA6Ne^TP;a*J#cH7nrRwK<&bfD+fHwHx*{oQ5JDvkbLT?9Zu)j0qiE>8i} zVDx$MJ0pApk2wIPgLOOovu3OTh729p!wtv;*&tB>mro$f~c{$vk#BikMjI&4|D8aL`PNpyMje7WQ;=oh4C4q%JKJedfTF68q5^~%1$f6n-C_=z% z%S)6jdwq?+jTG({#w|Xei?=j}X+?C384fjzAZ?<87&Gk2l;vK#T>VTg=vs-5ZKri~ zp@fsq@te>na3>?^L7H`vy({%&y#V<@xV~W-&kh%{wmN0eGia41b2{YujpXf0I7nPk z9siU#r~?Bfvj3Y<)7G5Z6&$wR%*2#9Jw)xNc3@Ek!WK0fVVNUs3(L^WUj5DMoNJ)5 zD0=%;?OK)CNAD%tb28Tz*AIaPndtZlQJ+O4R7L{A1GKQTV zWH!x#nQQ@(gb0zzfm^6Jc-3m<>QI#;UyCgoFT6XxzQ@(abry0Wb(~({b>Cr0_>xI3 z*9Nf|C1JIkDb(ZgLa8GEG~;P9mYgMKj|BEYDQsY-kR4(3bsOm#5%yqBj& z6Uw07vXvH=rAdoeIgQBZtjnE4jF^oZo0h9ddZRl9457QwK=x6;As(eDgTMFQt^^4Q z{SuIo79pW#hzzDHqR)Ag0vNlF)~qI50_53`#9`_7_=YW#WU6t{2JuBQU`TDjgCP;6 zjv)sG87c9;5veyKoeG1{K`EJM)+`w_&%iPkvkFQaPb!;~5)+7T$uvpA6h@cg0>q78 zN;;wN)!|nbomYl~gdvln(n9rM_z-NMp>ik!m#SQ=?m&m_J*MFET4X~VNgqRN3;;yb z>O7W%b2yd?=KH$lV6M8YYH-pNU+|OUsJbZODzr_OQw}NpYL5?|5r?@uQ^IR+JKV6n z`Av`YP82Ogo(| zQRYIY^(2p@#>$B1j{I5aeAjupQjBn%#<`C6jj)TJJN)jSJ$}I6#D!_xc>3_W`i1kT zkyrsUo|r4KH~ilQy|pE|U#IW_Yb3L>k~>D2C<#wV43XX1=;pR<3^M}bPnkj_b6eIN zn1PtRoCUQpoDb4+QVFb#uo@mhVbsn*ZQOQx2Ji)TwD=JquwX%gNdyq8MRNr{ke*`- z5h>b)ir$`rr_m6-HsGPgIQgCzo03#l2o*RA=}Lh;=~mLVHjUNQpZ(D<|NNt?aJTJP zB(Qd`DABZyN6Jo>#U7}h&32STl)$tdu9~P+CSN|Is#{54)d^d+R%CHNT8Mz7DdtwG z<@QveiBSH>TjRZFTd>!LA#1Gs}0a?`Oi&#No*ka`xOC zKN-LfOPE95><*?#6L-MnH5WF&hfa$3GjmN2xG5m$%bYT)_@A0sK^?nw6!LE}Adlrz zo3W{g#xoom^RlGQ_aJm^)k^6)*(jQ{}M7EuH9G4i2%nD_JeZWW3j=P z9oEVk&#qvcuB#v~;o{RHc-@8YYPnj&OcyG?Fv7(X>SU#2d{Q`R;uN^~vX=Jrg#+1x zNj-!KR08b_6@->~MkXTEm9QwPUJm7vLh&59iC3aq-W9W1P*^KFA&DB21oyFJfM|A8 z7%w9BV%x}!;SBxoTtYe*Bm&RO3l+@<6qigA-WL_gMOn>!M9DiEEhI4VYB|ZIv(6=w zYpCF0t*U0nRm^DW~6-x!D4Fih#w;>hFU zNeZe|!~AlD?)~A?zh3Hu)(F2Lr4ddCn<=%ftgR#%4}iM(ts}95Bj3y_ajFUAgmvzl zxwHK>4yKvAakibeScd7j0?Ik?DYfmJ5lQ4?3(%W0@~`0@9UfwwkvY#YJBgNt&JBb~ z-6VzUFD{eF{FlbqfhJZb~n%@=i`(dg$Jz0 z=|CBGT?(+dsStt{6f|p!Ltvmv#L#)qnwoXnr8PLHp7TZ4A#Wz)KCHPrHBW_B@$v$W zHTU%q`9iKEqiE;uo%~#xMC6O%NQm;4-Da19f3qG1$ji7@z-#!5VBClpkamfL7HSWq0`XLrbd{@m%61A;GD^-F|C}3(yd=hp$S9N8- z58hrx6uKa*;R6v$)RS?q)+VmI?oHP*Q?eMXP)7_@4N@Tz(x>t#{~2HWA>Q$w)oU9 z={6RIE%3?e_YBhFvJI?rdK{H}PY&jMc&^JY?tK2`;<4EoRwcWId#KD%3{D0*RO`V zlP@6gnai0bFN1dAN~Jeq9vW_ z)VwDIANHfxH!rsWq*-DBL+dG2f&@)gwa^hnk=hk@XI1uQlYpULI=(#v3(M?PQ z*0$hBJvYe=WCZJVW{)#SVyTwc(4s9)j+aiB6n_Xu!4y2l&o1Qaf~Hi^^bHRG zCzV={I4tl7X!4 z4HN?3n)B zBIRL74Sx(8QfcI}OB*Ni5{K6vVKhsHFVRl}jh}u+8ou1!O^YVnuHY$hOYFcF1D{^P z>lEf|ik2iVp-6Ly`}5A3kH;hhJ$QHUp=LD&VUNtOS&;HQiZrFXyw?_jqr(cNfXJj_ zn#yg1REz4hq59g?4kRq_RU{){euYMxlT6!@Y9d4uYol==tj<y%UKmQY- z%2y2w7Y|z>DHhEi)!*H1B+N*9?M&KCC`$WoLpJKdj?izi882i)%q2) z^Z-BWitEVdq`CZ^N3Ok)a`*kc0EYt5SmGSO@c zRo6l=n`vB6WpCL3ad6EvuKAprx!*B#&WB$Maq0*H8%4+6FMg=Z)E{ood*0A~D)6EX zqF!Ux-OxNzmpxwl|8$rc_xCu==OyNbRmFcZ3vD14Z&|Y*nR@X{hhuaTfb!qzw=KXV zzWVhcLkGOS8htNGr*cB}*-1@|S&(Am_kDbFVLzBoMc!2yhta^!346`OY+usri{Ok9 zaQ)L1gEP&|N6j^&cyVN&V?$rp8l`w3it+=HLyL*+1SF@O6K zw-|V!BC?bfw`|Y9|K-Lf8y}zT$vm{S@gUGfhYiqr$Cp&wV5B#cR2oUh3e8lLQPOVs?A*JFT|gZi1M2Km zC+J}ADs$}BmF=@P%cUJA;pyoGR0souY7NMmm8Jvz)Nq+GKrCX4C)ey9ITbn21@p3) zqKvo6MIcV+)Cj8xsh)nnsj5t?A1scm*Ki`m+7&a*1X7?ixH=TJE(K@`_WRV7M#ldh zPr@?zQEO#zyU@BC*~5ZyY#$jTn+2=DYACnKw?&)ixYKe(yZ}a`LWi-%@5i|;4IxHa z^}uBdu#@X&9m`w4Ct1Ugtw)&jttUjSC{OGj=KNliMm{njEi>oWwqtd)O3R324Q}c~ zqb!MoE~8(>ad8a54~wmOE7ih_5!Oii5*KMU^-5DGNy-p>XK=F%o$AEdOn*bm2R9Cu z^ZqvHM8~@m@-*ZN@>2y4M|GKZ%plweC*cy5j(V|#>PnX_8Gm&4PHs35*OK;>>HuMp zu^Ja35M|`X7>Q!zMtUNrJ*6gO{XwN4HjL zAIT8jD2!f`HvA0eH}C`o91s2LgXtgft-;tZ4sCR7T4~9*q2|ca#kXK34Cf*!q;b(( z-j2rtg=2+6R=4(YdWudXTE^rwYB%o9`C+IJ)envY4$-_izAi1wLVmP`A1pJ}qNm2; zAnU7XxBI1?2VDGT$L!_g5qJ>(wuuYvk(=6>1@AhO-v4ez36(JJFqG^&Spb3P7ceY$ zk8CG?6`1e5jvYEZIUgNC3WNjsC+YKSwo{?aW!T8$_}p zb;T=IIpGQ^n>SV4nO!UijO3;^vDMltsSVAesB(r_=q|2NuEOKP(a|e;vVaECLib9U zze)JApo=@$g}!i-?%)@aRcL92aH?Ssie=f4i?ONs9; zoapjra&0M2$EfoQE;v3}dp&+yu~4C<<9%p$lph~I#Z`rb1V|HsDTl}#LS%3xOklzg zn%7rSjd{?|6Y6u^3{h~)I(?CBQypC!EGHC_S8fw?iIH*`InvF>%Xp#qTzqNlUdx%~mO*zpGx!wEN_OT-HbKB%Of=l+;@PP{ zruaJWfMrASXS-s&Q*v<1b|Le+(sN#j0T9h>cw(qGPO?&ve<(6N6$%pDeHSK;gHlQ! z;J|2lrG*ws$t($ z)D5oN@d!*beCaim9GO^`_lydNNO+)5Ui#$<*IhWXSbr=8b*u1>$*j(>deOK%To_Gp z&EOqklwz~_BxaKHXIiY|tn-zt@|pO{$NX^H3e)Yzcd$END8alW zIKjSRsm34`34vS8DFzo^$t{tIN>SzzS5s1;7CRxp=|fr4gf*0_1S$6XLdjrt>&JZo z+&xo;kt3NuCp3vecCE|~a>##iMzT|Al6IC2+==-W?j*P;QS=D?d+Qp+^zO*?8@ieu zE~JTtC!-&B$cTD{?Fh6&Ceis;zFkZAHH>FGlFzmwr6o-d%k++JLQCR&kEn&Z-pRQs zK*S!6SEtw%x=I@pNPF>Cf?!~Kl^l{KnuB0mD8v|^foWPo{Mq7|9iiHiek=md8(p`*#ErJr z#f3se<63Z;1!W=Nf+8s^Lks2&5oU&O%k?sgDv6#nI3lmX@uKr(xPy`dSFW zUtnu*mT#-{TN*Hk3#sC6t4-pgW7IcWH zwEGSj;l9%pfLFfgyR?MTg5N=4dojn7uSVIeP(Luw+Hm{54b$mX?FKD#``>=`4}bdk z$JhI{{xeWi7WHcYCiq!X$=zM@F9Ib}V6E!X;NNKw`Nl8?P}CfXc4N^A48o+Vl&>U4 zpc$>Cq9}I_An&B@S)qJwk^D-68fjsnd}4M)c$7y2YQ<&{JgTrYMgFNzZUDIylWi)B z>*jWKmua1GGTquc@L$DabX}mHI)ww$sWrA;j}FD4P!A?ZXJT^(|GCAne0xlLD-sJG zbva(1UZmq;P^R6WFEw$8;+<^$7W0FInvO{~lq5Oc-Fx=v@w)Pb1I>D! zr?z3UK;DmwN@cyzrUG&+?~Fuddl;@hP{ZvU{Q=norYV z9oCw>q(?|%odj`&n*7BJoU_#}S4ZI;B=UP%-R$n_tdTcLZ(i5!4h5iQcE)I!)WcUN zq#uRnxi20oB(^Eu=yp#4SsfL?b?a$(E@6U&F%7HbLk1c!7FDBDj6=zCJUTQf&?8;G2{r%=j8CMFT4Oc=!XJE&XtOXL?yLZfd<}P2 z>xV}hOZu<_ndjeif4{RPEUtjsymy~#L#ZpwHs8Dv(D`N>*c^pr8nQWRJLk1id0xpC zg~0AWPPd?`0XH@6p0l!?9eaDJ{BMxIu-TaGm3B&5Lzt5}QWf*GDv+%WYMF)K^=kk% zYz0idBVTAnAj{bj=h>V(&!h^7?J^NrcnQLgv+^E)Ud7w;@c3WRO8?hC@vw@6<-2_^Oiv%(B-JinV=@tb*KJ%<1J;BLN}s|@+zZu-lg;z`C4 z`mE8p1a+y3vogyT7<-)}qe!pgPv$~<_v&=Kppu4nk@v=V{OOK`HyV^ep7CM1il+=ySG2#oQ9{w;=z>YCx zJ1d@?T#$Ft1~T6QjUh3sQrFb;OaJFuTn&$I6@YTvM5bB3#UuWjE z2?pWu_-i7fD6&F2eY5<`NB4h|yb1+_ojtm3DI4#6;Y(GPpmxSW{GMzMTnsj7>`qyV9D`(^s2~XMHi|2^5nHtU^lO?F3w1S z13j9&I(~OZMg~b#vNy4^BkpdCW+_voHTC$1V|ZR5$cQ^3*nK^wwWd$3*v-+aNj|A+ z@i?}CT00MoVNHmDtcn*WmlR2>mxLv+SqGPEud)Gf2mGYaw;^r{m}dy?;QHqBHNXfK zq+4f7t04R2H|*?hAi^1~t1W$vV9eBP0A??58-%8|6_H;j=}PiDSGySg~a5;m%cvsf(yQVr1uw{MrlujV>EzBTt}^N<&iC{UZ&aF}C6nfT<9@ znk>Y2DL|da*$X)tob$|-Yf;Kgae6~;JRcE)9T4_Kgg?%tQ85WPntL5eP}khs*B)x< z%XxN5atZ&~1SFG9*HxaZW?mH#$92hCZmrt z&1krZ2oAO2YJiN?2?|w25nh7NM>siv?OR~P4XIOfL4<730$OVvv3*_yXE(F~4#tiR z(7il&9!IJ{rk|?r*D6`8ea=NR#dNgltdH%+=9uPfm+LuTvj}J+vcf4IrHN(57tUCe zc}sJpqAo2{VUD6`d?HFxw9rQZgi1hTZt(sKDRjyNn{*yZ9b)SFp+g-h?b;;IpLb~L zSEc|JOoy>f=`4J$aOhZrH>m5XyN5NIZpINWB@JGhooUT~Qt?RHgH>7WThe{dFI{0^9)`NU!)y;fujr z0TBeW9Q6sO7mVa?;z-;kWUVsVH^=R5_~dFl(Z5hd}DB;>OTI(i@4k zzrmok``~`xd)*~l)mFG?I3U8OMFGQ(lMqW$6=(=Eq3FjykW3tE!m1VElNmS|zX-K= z%A!{LvQdJ+IvZUn$3AhX*OTTp+`MDey41f6=d(b2$$5=0lT0yr0O^B z*=8f_82DY&k^#s!vou{M0o|J6%5`A;tqCtm6nlIzeYWir8? z+1Jp$0rWzjims$gN|%JX6C8?LRZ)vOjkJDnC(yLg$!BOPVK9_PaRm91@Rw~W?2XtW z4JFF6Ypu5GwLT(eVsVGlS;sLtYhq0wpRm4fEOgp3)!uaiocf$4-OvnAvn;WUd5fb7 z1a%+f#$=kKYu)XBJr(~I7zHE>QpxVeUGm9i@cWG2kw4yb&}!5MfAG)$(?9*iM^_s> z=mIF1Y@{N3Kq{gwd#LQEw}61OQ>o085JPP8O^FJx!O55V>HvDQAC#)03y>(KHNOAs z{QmaK0+;-I0Ps5s1|h~g3W34Y(QKd?5-thLiW5!? zX;99>lKbX@N%P+ovDA`4&~b48C=%Jkbmj;PwSAl08ah{I1*!Kf%CZpck8O+w_^i=zqSZT~?^H_~!=3H7B4pzhR;jau; z6QjYwR}T-i#?*ZoEcQ2+mKT=>?|q(>sSm&08uw7GEUhdqAxFQba}aX-s~zPZ7k%Z< zu{uL~Qthg&9yn&%IWniQwY~Rje;e%E3`ENXSt}T{Nx%ik-1I9ff(L(s51X>6w$Knx$lvc99|FE z8j}AypRNK#Urm@y z*_ze5COjN?QBhDUQzbiDTbaCnUe!2#{o8km8j2sN@ut%y_hV_RYwfh%Ox4W#8ylL- z%Cg4XRJpKzBmj0%Bg()VV8d+eX~#NMeg?im4X7ok_o_1l)ZF#DS3dME3}Veu`wKMS z6_9s*_SFrodEg0;BQ3Nlv-3=BAxNqZ{%Rb%*8ndbbq>Grz&o597SC`T)HueBe?74P zNo-Z1P@;-=Apwjx%4Fvux`|49Tbim1_#qVzU;-7B(@{%^@otl&@#=Hsd?Vr8er9`f zsyA~Ct{w};o(d=4@A5tF?1dTt0wD_73=!OK<}QH!fYdgzO}_0)Y4Nz`?JHE`M7l@C zy1+EKs?9h{g24OSy9k%ahZ;E4k>7j=b4kS;&hL=j`r z=3qtwn0F1F;#1S%!;|hR4!uo-5POw}!rb^b6f{U;tI5n!YcA{(8FO#^#@bC&<=|O_ zW?^k3>vw|zOXMNNG34QEG8~YhvGO-j06~$S}B@5HoV_)DcI1q`ypj_hr49aB|4>1{Xo0eS%=Eph^ zU957`%p6;@C*`?P+?s2yXKga?tRd=T!bQRu!~J6WeWaZDR{Cy@zPd>R~Brpgfl1byWg0k&D^#=bg`%M7O#+7Nps*4kyI}L6`CL;=Ir_awwildFs6QPO7H>p97AzcK_bJ+H6J5Tq*(X zr#eQ25&#hNxkNi4>z3&+d%Lx9M)@SqqR8dtQ%HE{0S-~m&KJi~R&0@Dg5gw=1Iz{| zj#V5s28%lzbuuengX<+DqsWZ}w?KBKnSeq-@3_+5h{w0qI?kguR_o}jY*yV~SY4G$ z1=ikxw7uUx!nHN$&Y5t-G#77k4!zho)W}kM-K{&1a=e!fd(tFzY5GZhN$^D+)8hMr zJfi@1zKJEn2#T2Iu_z~gqU8Bg;l}gGcgrea3PafT8BC&(J!1)ol&nd@Sgw!V?tW67 zX1iN1jq~JsT0waDRBnKY%>}+EJRYaFU3c7^I;kA2D^diJ6iY~tRxn%!I4MUpUGD9L zPH{OkSrR9KQ1uxoNm5541$nuSGByyK%Rh5W7SX7kjgafC?NzpsCWmlb#w4a?o*V)2 zy=7Ip!$p0k;&7;ll*REEXn}U^ukZ!F2wX~W+_<(ytDtF}?_FoQZ;krc^bfG*7#G8& zUr)FC{sQhwaD;$0o&YF1oYS}Pqs4u2v9^sfU#;#ncIb|VE%)`YO*&Cf44#r8_Z9IPx^$X%lDukvt=SIseRZ0e8SXL|U-`U+Zy$zvEA-5n*wgurSnIjPM} zEmkNe%!L#N1jPwBNo)@+1NxJmUFbRBe5_}qJHRMVI1;4eufKKHrC^w78bN1Q7~u2q z{07?jie4tL6G&EUX2IR! z#~n0-HX*XkqjeptddG!y#)Y&in2x65oFLxKu<5*X_C-pr5rsdO?cjQJKk*0fJyZEM zrPt$q(RJwvz9!L#NGsGk)q%fiZ0I__i*nnOgZmQKHkIpI*-gqX!CZH`Z*&1#-P%(q zd~vl!`W+3~6;+lNrRJUN6Y+vdm)g;1Yz|ulj7nZ)a+;^B;XKsolIe1-g#QM2PblRW z_>=&@ORVdtA*MQvK~ne-{n54-)3p*{B8G6rjA;$8fIvB!;FRjgZo`Susn*xwqAw(l z!v0r0^wkY+jp$lQ^e8|dovBX6`m6&Mw}>n$pMP>SZ(l+x)EJ#gr)lsDN_n z23QED-z&R1s@|&+h%(t%;(eg!O}%qUK$+vI=TxKb?uo-q=%Mbq`#gPW=Wz{pYi?SW z0qkpl*gz}9zG83_|7ZB|a0bkc7m8~z0jq>##da4Pzs?@0WDHB6ASZaVFsYahWFdiz zVYI){6Z`Y&awbL)`!Z0x#e}rCXt%Gvo5jO(-|5ojfG6+4ae*g&Wj6w_7hFQ;q^vzc z7Jz;b@XWJ!2i&_1zCV+0V1=n1fVjGgDUB<|btY6O0%4rf5DA6%*h(e%9Rp(|7H(-) z4+QxR3W`$6P(X|l?^KHNnHVBs5e0))qx$szIoMAR*p1bL$`qJ6w4;YfgO9uQTXCFb zqgsCGT@tpJS!NC;YDL2`m`<~(iR?VIM4kqDJa3U&iIEyGZiR3R z(`Q9lhPfKl3(q}fEzg%j)R07Cb4bn{yduqt;$_)V8^!ZI^A=wvi#HAnkZuer^0(2} z0*P)UuP=?+4uO&(Lt+~|XUyt3MqBT<8GcK`9&_5d>FfdlfX-Pzw~0MDJR7}MHO13- zr0bJ~=0V18qT~-nRi!cT8uGfTR!ZB8Pdc)i0Ms>38d z#|hy@$6Xj{J_%-Rgge|N(YWnz8mJaDS$%57ag7RfBUVkBkYj-H z>zII`u9B&^%Emzb{_5tkO28I())cgx?hOdsAYp}{N{Q@U|4yN}1>IvqGy}H5LGeW; zhkHvY9VI|@`0C3xf_Ep=jB6h8tvtH*cxrL0uIp-+=GGxq0IWUFh0ahwug`~52dSB? zFeoU22~N=1jG8X!l(@uPyc5{_C?7n2A_9|czY!^98^n=o{VCY&}wIZm)rx4z? z`lh)^M#0zWRl-HOg`_4HW*d&g=XX*&5^THEf=D;egTrCr+4KD=G8KUg)5*}&@6>#wfp!|>sI-}bql3y1dBhk=IU2Q%k5cO9v_oP2uGJylMAne2G!%LDcgmD>7B1exnWUMrhR zgI~s5{uRdka;A+B&{P}Bb}e^pC@Z`^+h(9cH`QiLY2mI7nZ?#-+o($OOdIUZO&g+H ze+gguw-3kTzkPTaEONt%C-d#uPYHr>?i`FM8Nd=sT$&2t6#H=eN*BaG9Mdr*R!qvI z$3auf-ClN^yZ~las>VDP}x_`ZAw!N^mwG?Xg7z?$liQ~2*hOf z@zjcwv3JI4WmTCLKZu%8*dr$5R?ygLWQ(o>Yba45Q$PsxQr<+(D;|J_z(L-)!gncw z5pHZ*D=)69X%Kl1%_8cyqtnYHNva@~mReo+(IIjvk#4{SFa!@u>%a*BN(FIqKZub$ zC#IOUV$VQoFVYa!wxox3nje(Lf*LX}@fuMkA3!zlCVz8=6AsIZ8N0t-je~!DthjLH zmv||*N@+nNEo_DF(j#dm)oB81zQqCH(`N_c7b+1!%(PVFAuW9Dv4@ywVJuiqn4Ur* zpp|K6wnw0xlJ!>CE_x|S!>{Uc*({$2!=<%NR1<;-5_GOtIEJX)oT|jJXIEtTiI5e5 zEmYH4Y>`Q2JflWmhgOMDY_3^14uY^q*I`ujl{nexkX^uVr-Kq|`#UkS zQ)QVGxNEbC5^CqXi}lNV(2OyigM32oQUj%2+*@75N5@8VZM^XrG)xT~Aoat51+sY~ zf;*)gs%eIT!NPjqzc+5n&-~(#|H~iT`{=HK4{rgjJvUAoRws$$@f)oAp`VS8--_v<4eX;WnlB z`T~Y#eQCY$GwFV@(R>w7PW?ViP@LWn?CGVe?6S8mR5$#jX&)EKl#7^=#M`7A$T;GS16vb zk3JuN$&GahmD;zCs}N^EzlAC?+-9w2`3hy#;`l6RoKQyEE50cDEF9@CsMs#|%T(uF zfy!`DHeIu|R?kXMX!9kZkSTHlN`n%-%ydFacE>>(;d8rPvM!DHs`D(fw`Gu7w3yi$ z0m?MOrw3yNRX31?R&qn<_cUHGCm?|cyuqj;lScb)K;D>*<|N!P9<1#anVPn^HBKAL zP8hi5C4p=#PZSs^FR>Rqh)`CBjIl_v$SSBSRLJWj0^(9(kZW4v) zkk*P+GrI#dfPp|SPZrzLL!uF*uIQJ~q#T%Rp&O0`?WPad-OCZuAbi^)9#eqwv3d=eG8jrjbfbjQJ9 z0yX>{;!&#?;Bw*c#Pb#R7b!G-Sfs-CUBcd58P}MrWf&sB9M(xLD#Zyg%ea>gaPO$4 zgmBJg>c5uhZ4eB zy?7GzO43M1DcKVJ5!{4CC>?NonAOW6bv;pt0}I$*RGZ*7>Vh@{(uC>%mihOzn#11; zYh^mt2i-*KM9VatfHl6OSJt!h!i}UDeXUG_XiI1tv%<0K#s`jVko=eqGH`^xixh1V z$pqu~NKzKsO=`okYOSEOVtwlQ`UV~GdFrqj|B)Eb&WWO3N7r(~i1Vh!qyb81@Dra{ zlJx0eLuE@l)_wzhoLT^zh9~&1zqtI9!N=zb22-+NhPPNy znuVzomTa?^&@_B;pk|fdt5`|?jW>}bLz^B4a$$ok&+%*kYXPv_Q#Ko9t$Sk_pY-w3 zs0mJKoutWCFYFmwGdL~B4D<#|Ya~RIPHkyr4Hj^3cAjc;g0v;Osdr?&?s4(nNKE?8h70$MvPbrkTm$=r#sR8}g1HuC6W(hFHnsRT|mr z0oC8q=7xE_Y}BU_-BEgYX_Nd&r4cLZMndH}ST~1JM_OAJXR9GsyGGJ5!UOC7^oY7G zyzXnGxzj6+ye1m;rKl`i>c+;>ioz8JltUh@S01;QjbcqSS`LNm``5&>J-rxdW2sLj zi*6+NW$A7Ec#15qRR+74jdCOcT7uQ8BlU-Bw1&d6U*&)voVvjtfPnWmw374QKzBI= zdc)-n_TqMbfNoMW57vfodtIZlrWgt2Tx~HzPA@cC1x1(jy;up@J+TrU zBbN+C@>Z376HnA|3ZvP8NRh#EjoY}-=geXPUx$jwB-rZo;4P>mNU9+YgZb_$3PyvB zqLdN)25~Gs5Ooxfj-hu>@yGEFK}`(GWb3i1(~~Ds(m&oV^t;f@SXN$ug}WhJtx{5% z-&5bZB?haL!_yO0d7NT`5+3#TsDMEXb`Y&i!{O&$j;{&L)nw|_*SnGlh91qnxy3^R zt26E)!P99r9tPle3>(F`uXLsB$F3YQl=*551k584dMrBKJn{0?kBBRW5S50=1{`34 z0uFLXyWeK7Z`Eu;s@MxbuE8Ti79`+@0wQb+tPa5z8c~UK#LR2L8Skm3mKebC0**8H zWR!p`-!hpcoQzaujI@{?0G`hFmG0{B4nVfkjfYcFV71QH3=O6aki)Oyl(!==>=d%d zQQ}t}P@gvdumr24*ZN=?CVfQFEKzZ3kGIUOqM7~c@%Z6iqj9YKF>+F5V2RpLLK)J< z;v8B8r*c99zO6IH@fq4XEV0Kw(4n#T_9`?Ajo zjfN8G%ix6!D1D8T;7+8S5=A;n$eEsb_~vXuW<}2 zN;>ICsxQzKr?#D%^Oty%`-tbH>|u*5`*fsIIXYZ_Xu1b>yi85^Di@n>aW1$OGgiqh z-PNg(bmu8F^{L%Z!dLJ5_=F2aVQ048goXzRT39}1p97_2;R!24da|7UL!q;R)l^49 zcJ3vIkHz&Bunw2Z&LC*s8_mRpy|m2UE6U|exQLGy>dcDjP8ohZF&3sLrbHc5C`qh_ zY&vN}91G>xnmpYb+w7ycJl)%t-ooec#o6d2R=Cw>p+J09kggO;x*6C&)+~3u(TUVu zs(+|TBLlWp^(Rrj|1Jr z#D7UtD9VYx~ZJHN!5Obxx0iKXJh0TO@Yz-vDP9UMV!+=+;jqxWlgF zxJi|xRN2noepdVP`0NeD01dBPssIff2PML^Q)vhj#1lu57el8kSlzr~)!$s}>Fz(Wng0ukSGQx!T<5`QNi_$JbAGp=)UDIb&NQX#$wED`-J^<%yK`Evf}gt7M_h zj_A|K#W*Q^6b9&TQP6^rJkoh8zmK|sCI@s^h-MPY(vy1CXy!@sx9U}=)#;4FsW4sQ z{H4&e^H@-rG9QMRYte)@mTRq{(G4ddVX9KZX@VGJu=A??ndEOcw8`#+vSSaNxD{6e zSa0qe8CCr9pRMwx4y-PJv@>P|guj*3UMx6Kub%L~EY|w!T`o4fsTCH4q;?bB1!v;$ zSSPY}#sw~V_Wb+PD-legseiK~20T%m9waVQK>zjzQqMJkG*G9^ux_AUZ9EJb$k96v zD|cqyyK7IMCrAvJUE_H`jk-X^ah@?A?;c>`bd)301<9wIk%aRe1?>?g-i(e)DEIDoaG&7a zczs9qm;j|dFCzU&iP09PU2Nb-#UmL7056E`V^(^K^ujavcKit?9 zFW-GX-COg6dt+XMfwTqNl5G7V?vTM?%i)T&Al^vTAT>d}ia)@3Q_2pZPke)jR8&VE zo*y2B9yvzUXKRxDD}gfMvk|3~U@P>+ZlmdE=KV3MEcgZ4Nn17J+$>W(Z}CPmLSCb{ zz2jcv4pS~Vk%=a49s{E^AxPr%TvR7=|uKR9|R|QF_VLy@3}>J-{tn0FELJ!aooBl zLB#k8w-ZiiY#*gEpNxJ$4)d-+@xDS8X-@5Hy;1#!$9_XS3faOT8zLP~pN$`qWlSdV z@m4zhV_eUeaLA0DBuZ$ELT2ch*KQiPO6VDVeo<{5UuF!k9(9xr;stb*muCtyaUW5i z^DXkYi={lmj9Cs)GAe#1%wNZij@)YtT%p$^<;{*CnLU0+_c2RlQ7QKzV2r6q?)O99f3)C<*9f0qV6?6c}_sQw>rpxv+i^l9OZGQ{Ru;=o`?9A_#1QQE7-M=V0nUEFWtrd=uiIF zA1{4;#X7b09&r!NT&NCSm%leW4bjj@Fy?+b4a(>615ZoI!a`ys8I}THUnn_f7K{7B ziIPo7PzbT+Sp^cES)Aea4aSbUn>+eN&sp=(>RsSghO78ua)!X>sX%BSq;R)q4dTy$ z`7PR%%A<^!pi#_I41&^<3v&ajKZ~0_$|^{fet+6!weH-Q)Q|Emn_1|(fPqci_5-49 z?MwKNO$l?NrlS>fS)$$5eTAa=-E7k@YC7o{GuwN7O}>pywWVfe=-P1^*^p3ko}L?& zT4oR>+`jE6ithwMJfIMi5%XnR#|cvPqVH0*S`9 z@62{oW>!FptO+cki2wzXYlUv1Z?L0?hYg%zyu`5s`)<&XKuUKJxm%eoj*_%VpXn4O=@7?!PQX7q4CiJd#GL(jpA=F8S3No!!QY@CLN!|D`MZ)m9a^-E@Vw8xO2TAN}~0U9CF6 zVK7))PpJb=z3U2gTcHn4S6EMZU=1}se-I9uS*=lchFPKXXMs$>3oN(($`BYaMRmn< ze7&+vHT2!|M-5`fNbwyq~fqiw2u2wOmXgdC+ zes~QBs}>hlHkLM!;l;f2e4W|K0Fz*Xogfr`VnR#gpIQ$f`I9^1m-ThQLT-oye8=<> z$Sc_CN;Yt2wX(A2Suv=d$2iM#2umHT0G!$lH?em_R|32KPY((JS(dazS8HqQ`f6nz zSP_2`v+}1z2EJ4-Ix^2;XXjweL{Yu5wVP&t!L>%jGn8 z0@M6LcieAGO};iQrv#2}8~DqT^hh#8leC{}fn5DKGf;(4S`Xb4Q5~Ss>!y?_>APf`U*chqJT-3-KdcqFNqyV zy|&_Rc-SpgEn_;XlbFX6Trp#Xo^ld2ewYG*l~d|)Y6Wcd0pGFgq7{~`>5M0>^R!Crh( zbFIojePi9FP}X7(5yqS*ht8x_Y^16^ zDo=+=JXg)KlAx>+Xev80T@V+3JXXZVH15<^01_T#q#Wo_JY!hX9;)^>aJ!tCqP#CQ zn*MT6snoM3V%=nc6aP(yR-`ygy!B840U>b||Wqy>b*Y5Z$tpCte)mSSkG&B2laVjCIvhRh zut2bGg-Rz8*KR}+N8eK_B0U-xJ}m-PM$tQ8?mkEW{`2})erkF%_1bds1&`x9(Ld^P zK*aXT?u0w(OP z!4tf1glH84fu<(BojXqTCl;IGn$8hm|f28PLz%nY(0ODG?5avNQUsY?4XMt z^JUh>4RjHE>DNym0IoQT6aAC{#H@bc0A0P^pE7{m`!vE&TfukauY~aUB7{1iRLVLf z1x$>Yu5BP3u432Y^`dErh17o!0B*_nVbzJNRdSbgu@3VsnOASEkFJbV(*Jrph%|l< zIqM_S3^^yO#4)YI_E&$(I)yoJB&*K+PyS`9FI8zTYs`z-F0NXL>b1NZaf+9#z+X`h@-z6Eg#zf&A0k_LT?=LWW?qst3wrH~7| zczAR?&Xn&()j+BWJ+mYKkrJk&vZ_54Uy#z1L>rQG6Pw|x5F*{-YO;jaOgP)>g0(wE zN+ry~T3mTY9mZ2CT_&d^wz?1c9MV7dTg6tvKlCxORqJ_Rz3 zu!fvRf`HqSrjFA@-il78BnLkWrF?6=mcjxzpNkv$lyNKE_Hn#|Ou$UORz5ahi=_XH zhS073v;Xmr|K&%Q;=jBd02-MhzWjU~u|dTuSz|v**Sz(hw*t+2_%)8HNqq|q92(k>HsCe&Ci(=bU_a=N6s(q z>J_1<4r|K3_*|2Dr*2

Hwli6~ktZ33&Nv2a<>@1s5NQxkUI(IEAD|_Kkz!(zSKS!>w?rzSbuf>(Lh>{tsvM7(dVA_$} ziIiVWO+is~$)7iJZv?Co=d{A)8i0Pp;nKI3Nd&(#nnc}z3DO0Y4xX+svv;0V1I5Wr z8>N=&m7L0Z8ONi^8gA%#YCow?0nFu;rMRjmbpxrhi$j@2<1kvN>bA0M!en+68kw;p zV>+HDZZW|IT{(9vtBd3Hjm2?q4T~}VH4b&`#5McFfgBMyPbY}NbiliEl?4}CAUqZ7` zA5MiNZIVAq=@KlLnc2k7*rOKRP8ooD6g~8uzNV0}Oril@xe}F|r&~xcx$5qYN42z^ zrigHzmoPaIYNyNlSq=(B%DfzBslgeee=nDB?^6pqWwMh?qHn|oLgp1&T<`g|yamve z%c`CP51>HLjU}38CZ3Gg+zHom#Q)MlRW#8lO1+W^WM;PA0WT&UkV;Q8ucstE$_5QW z7qFK#FcY86pu|&)IXixF&CI?l{>7#zOfeAGos&?GL$jH zMBAZ_2NK~8R7<#(?49>?OKNyu8Z;+IVGaA&3L-_1^|EooxYer*GYNX*VmXPCD{Y^~ zuiHe=3oN)V_hg~Uq!2(cG+&dVD(DN3HCJBVXI%*Y0h6S59lW;D?dykX{bY||n9QD# zIzMHBnU`TGZky1ZXu(BA*etwivS-N+TU5v{Z)wd&ffA`mf3ibyslECH7nu5I2Tz=a z*c6xB+3Mh;TV?9|!TNH`loh;Z-un===1K3<{B^Q>E`GrzZcRJNHApe38G7FPb>8)+ ViYp=`TNgSA#7$%I241x%Q&Zx|Yg^q&w;Q#xrz4tkL?|V}! zF#pe)&p?y2_c>=j)>?bL_S);bbpDREYu^zBMN^B5f*>d^!>_(?7vm}j{&maZk8WJp z_L0obvsZrjt-tu~Q~xxu^Q0@*-}5gY{rfXt`0ypevp-g}dEm(}{mu1*AH3-7+{f4c zeBocut*pQJU%&nr&#u_r-}9-y#8n^uRO8Bbw)bo<+FJbgfBNb1;ZL7;Q`JxY;`3Y5 zH?=0ebM0rgpB>)!nNxrAv-AhP{Feu=zwPX?A1?X(hb}qo0~nWe)sU#iat5gdHTg~fA<^y zbj!D{`%vfJne{Cn7_7Se_)ir7!;=lWYai{tx9-+0KR)twYv&!8zkAP-$M1jPrMo}) zDNE2`=_U_ zTJ+gBHT-Ax@E3R0zT@9YZrr=*TZ^9h(qmOW`egH_pFMQ_!_V&d8ysLEDPsTg1>rM>5?z+wt!`C`~zqC00L*UzKGnRpQ^1C{?X0 z!PRp7`!OHbNh;cef3+2OW*?tC8~@H@X$?!q;ol7`&0y*4_;;IA8bQPHy|q*9(yyfi z@|5?!Iu)c^$yP4Hzdx?RuYQ)=@xTvRk~wfJ%WKS&ohS{X6yN*1=-!)AT{0cNqE;?J zN%hc;>QBtD?>)~_)WhpIEqU)Ofa4HL(Y-ItHLa{bb?H3wy0;FkJV#=adtb+FR{&J% z-Um>9m{XQ}@5FoW0^zHB=b?I9!rUXe`%qH%?nCvb`pmrtFuzQ{Dg6|!oH@uRAqRrD zqq?5R!2P0NF;MdvlvFFc_pPjXkN39a?DvND+wc7hCH3B)qI&v4^B()V38l)_R|NZm zB8+p+O!l=bxN*_L)3X@G46O0sf}pA>c=vH@gPtG->PQB;U@^E+GT4W|T|owQiC|c+ zlfghR7Nk+;;M7kMC~Oz_St&&sTF0sr4yA8Le~M-n2TOvFqs)J223t>9Q1cJyzlem4 zF_d8pO+g#_8$;_U^q)na@i+?g4W<WHb=Gb zg?*n()BmyWW3lG_*!QtS^M366T(tHNDd=cF|1)Osj-yQh_x@+h;;R1@v-qR`6|*P` z$TPa|Z}-@6U)Xu@;8_O`rjxrzFC0pYW>fnwKiHSag_)t`Kw@bwHLR~z)m;@8!lm&O ztLj!QUA46N%4}+2aP-Y36;q}bJ%|4Ysp8t8zNn}(E|(P57ZsQPFs}GTQE72;#a_GO z+eO6{`|XOq@GFM>iZlI+seZ*Hf!F9K{fb&t?2Eg-qnrb~(yrjZ-ey;DU`_=G=2UQC zP6Y?%RB&KU1qbF-a9{`HZbyn27ncC~am}BWEG{mtTpd^Rm*NrNDz14~nfJ)n^2NnP ztKtV16gL7fKZq-?K!w}J$4c;s+YKIZM)IyQ?~$$LjYW1hj~Aa2*yW#>y5+6qC^x@0 za#2zFMos0H+w{GEv<_6ODORYzv#G6VQ2vbASD@`~4<)kc45;k9Qy z^2*kpS~V~$6oIxCmJOgj@O(|4;Q!4_V*YkLP7z&J&*Q@w^Po(mhTKKqLD{V;V>XE)66DSDxSN>w9+;y9!}V z3Cc}zgBg}B?(m>@zqu6mEunTj%hvlxN5)8%zZ6q`mJcD(;;_`os@zh&_2YTZN z9xw48SX_z+EJ<_-WmlE?L>X{jSrNBUR_?ViQGqu4;s@SX={@k?O1G0|P^&#Z>&9nfb1PPl(;`%*<=!b~pkY<#1XB8nveS#}(ci z-{J#SuMN-}U2U>+3cU^1RPUPNwQ&Sb*lqMo^{u9TRcxau#`Cb}q4Wam^1ig%W0{v$do1(PYL8`J zTJ5pSORGJWc~}N!t<}RaFl((ImVr4H9GFw#vCP9VFy{%6WgeD+IZt>j^V(|A{9p|6 zYpc&GD%xY0cLhc1xP0j}k6#{F0~BnC9~fiVqO6B&Jd`|K;`2 zG~JV87ftt2@~avbCBLe1QSz%AL5aATAC45D+-Rb2Pa>Tf7`}Xb|H#3!mfCvXN~QHR zEvL#Ou4hqS`UX?-7Y>JmR~@8oqwZcwDig1h2SCE?%)XR8=V-m>aK$G%D=%@BqupPQtHOU}Z6#l^hVcPZ*sr{RvfImoseHxqNPLYIwv#$j<w)-7=*q*szdxyjzQ>3^D0Px z4=Z@U!3xUGTJarN=ZXW%!HV0&tO|cvYoTL!Sivjx%5)wBN8#Rqv!Mb1D?G5u4{PrT z99-ermCbc6b*qidd8&I4??-zgAU^(f+|sh$Vnrl}r9+%(nmAlx*SfVW8GCa6k| z2jOaQ7+6-x)xN{vYTsdSweK*v+IJXS?K=#v_8kUS`woMveTTs}rh0DEZ@{*6w1jU= zRRT)1;4338_F(C3L>dNDOx#Y<;@QE2WM83)zVKO)Y{BhxoO1g;_aT_#L2^f%4LWYU zJT~Ux`wv?mpgYU3nq=$4@`|5^tq%v^r(y2{Zt_?*6yE%>gh&47hliC+iMI+fCEhB` zlz6K!Q{t_{Oo_J&GbP?C%#?VmFjL~K!t-QT#ae~u$*zh8uk&PA#i{W4@_DkW;ymH; z<@01$#d(4Qb1FQ({QeTILd)Iqeg>)7?$q~F#k1Y1^C=x|HLn1!`D zm7X-6Q|U?5Ih7vP=2UvpbWWv*wKG=JfUP4-@$cex z)c#ETz?-rCRggTc?7UUcU4f=!nvi+3VCer`~7T!4UYHt76#ohgg$i+Ds? zFt&K!KeD{Jekp#p$nVwl2sdL5exnAzQFEEp;5TaUdv$$mv+M%d7E~qj)PUxtgDp!3 zSJ&-nUb?4c>7Lbf>E@;BmZfQ92Zma|*wD1);K7SBS(JH=u_9o~wRt`J=^E;@heU9&LWKWGZ}KP=6k+KT>_f_jGwo^Y=vox!sTZ zyuI9GnzxsGO!M|~k7?ds?lH~V%RQ!fd%4FnZ!h@;w7ncKkAEL)zAa~Nc5jUZ2D zdY<7U78Bi7gt9XQl&uC1GD_7BO*or-S5^ZbXW5y8+rT%lmE|;WHG`O}2A*cwnS$Fu zo|5-GBVMcqcEJnfP61_S3Z9mDHWU=QfseE7Ou=p78+1w8YUb65nX(&rnq_ASZUal9 zzc^y$K`J!6V##$`rT4%Rn2Wa1_#>7rq44i4TS8;=RQLX^zIA!4Z(ZK%TbH-`*5$3f zb$P3AUEb<}LQerg@9~v1#67e{7n!*dLqbE%wKz zd5itAY2IRgfY#-pwGxh0vBDyY`O{coq4@#YpL?8FSmC_F3g;D&QrdZi70xTHuwMCS zjYk{ro9@!ab1Yl5(Ov7(#^11P-Jd-J>|r^3Kl20~UEd#In`EnmH(MiPf+>=M18OAH)^Up#n=*jqY)KUdaYe0lRq{JHWVelAK3_u~(DvCJ#jw_17dvXS~L^IeS4 z*=*0!y-+os8TCWgEM>SS|?9w?Kxlkm4JTYT#+WmFwU;#t40{4$3R zeS^BC?dE?gbxSbgC}v_?rTfNp)GaOD@LAq(j-OvM1?81-c^}Ib@!d;Z(_)=(s6s#& z02$BvtZ5j6y%+H#R@f@@`)cw)HM`cG`CgPAnQ&+Z9L+|R^%K6E`U&4n{e9@vyN4#X{ zrgk<7>8G~Y;f0m{D+hhQ^`-P%JFUJ~{MMG7c!nmu#bi4fy#tz#2a@&u*6ZlEb{@G< z{MJ^hZ-QdsEbkI=4_kig5^)b(=q(ZVuv6jrUP{D0>^$N5UP{D0>^wmM?o@cbm#2Nd z_0zuJ`f1;9{j~45e%kk2KkfUipZ5LMPy2rBr+vTmaw-ybxbJdCK-oI=@+zfZ3VY+J zamC(*8AZ~|7Ij+EX>nFq+9BR!CFEi~tw|m}JUeRFv5D&r)Lmv69{M_}Pdkt0{hnHs zH~7)~Hw2!Nd4nI#e}fz|upFN^_|g0~$T0)w2~WwqL5>+XPk2fuEy^N`h-sb`9f(&b zZJnaa;_{my^PJVUm3x(zl#$?mYtf5;+fvOWxZk?}V2Ova2Yr9{gTBA}!4hxvKIr?q zAN2j*5BmP@2Yr9{ga2dv-9M*^J{Y6q=d^b%&*{%;Jiex$)7EIAUOtk@j;0dn@bcW) zP@cQ=%FNzmHZ;#%zH`I!RKulM?pVdE)JiQ`tVQthU;^B;B%VcUP!7Ush%4R~e9!f^ zW{b)lGyNfy9Y^Q)i`m2v;wJvM1aDZh`4g5c+IwRu$`);YhGpx1bs5SQq=#6xl-YkQ z+vs>2?x6qIp2KfgvD50|%btq9nC{+=#?51wynTp6OOI$PS0~alg5N?D}0d^wyp3%&$@Vwo@@)eXI8)#uxy35 zv2582UuD^{6}HpXuypnpPKhYV@{Nh{>FC!oqZ(;U z*y44aXG}bWvLkLkVHp$c(PDF?qH|jLtb;FqR@tWkkInwR_*(z>oO64tFB%tk=iIJf z*+g+&;##bm0PXNi$xql~x+A^6{@W*_Cp%F03RM=DNIr)2PJ^QPt*5gP$wVso|r`B`w_tbh${+?RT{_3gaz%2W# zr`EH-=2rU=f@jdFUpYI5a#fA*jA@$gJ#qvUHqm{R_PnhL*H!!8noZO2h}(_tooSlx zJ#qvUb~jg5!_rt4kMz%L-13p>C~K#A6I^fFX>RK^<8hiH|Ex#8lXNKvT_f&y+yNs(t3QJ zx3sQ-Ys2*=-hth4#}KN)cDSvPW%BYWUC-b$dn4uut#3<->jA%ad)bE_aL0ytgcbH` zT%YHWy{N()+25hU?q*S*N4C}X$o>-hh3-feg1I>Jy%H66tKZM#K1E2~v8l-5D_+7$q z8HkQwgF~KvJ_I){WX>DxDkxR?>$0L`}o}R;hfL>61Ez6dB>~PsP9q;26JdkNG zkEJ+(X%FCCEL#KqG0WBfI(Qn>8o+HVTmH4GDJWY5NKbJGaHn^_b}H^${=06LE&tsO zEL-h=7e_nMel+2C;AE%m&uio{P79!a!m>4=pRsJsX9tdX+VlBKmaY3Uy)&LUuPkRi zZ6d#yhd^Dbcq%^#14k6CL3Nby9gCaXh6;NYJoIV5kY?E$rJVV+u+mh9`xex$W!Zw- z`f`*lKJx>XEvU6upll8B7M894%6aTiH$iwy5$+3K%;id(Mb5eV1Yj0zWOXXHZ- z9LE}z9LjW|h6k)!@KC1xLYid@Di5%1&7ujM(w^nDEL*c!55DO_4P~ppc7~%{1H6T0 z3o7NvQ7ZvS@SJfZfK(E>jw18%Vh5Van6Igcey^Mji%1o?kmrsN8=ZfuJ^g~u!P1Zx% zb44ywIXaIp*Ph+#lYZ{K);xuRULdE9$#U&!qy0+}W!hp}e2<`1>x zl)Zd8$``jNm#0eDfD&Xq@7G_cLgJJhf6E@W0)hUPBpy_a(UKN#X%m9ml%JEY)s2f- zS8u4xmwl&zoUeqoZ~0bAicn$mraMq!^O2h3%3@FMUtfYpELLy?WfxU*%Gix1>GqZV zQ&CYeUW51I0h`+_D0h4P8p{?B&s4ZwK8Uh(8O7Zlsod<0d+ihs!Sd!k$qJjJUNhBi zMkk511|c!H)@LUh6VW#7xN8E9JiOO^%cAOO4mAiMSa;?Z@F$QXEzpf z??8pEG1pY!6(=~exstC~q<1|kY#bk9*_wRM6qGHAF$X8>DOV%t?F$+`VBi547~UH- zI5gt|gKs#%==UY_eWm@5;Hxj|_e_qhMA-ob z%Jsg|{(I^XTP&&AtTT6uB^8_H23{9*`PL{ED zKNzUp4+d)YgMr#hykMYqKNzUp4+d)YgMr%pV4!wC80dZ(n1#~&WndQc@0Wo&6&_0O zmw`D?cqqMJ2If5Bq4a(kn1#|5RSyd#Df*SHg_B}1kfn#VGjW7%BtGMBB0uAAB0uAA zB0uAAB0uAAB0uAAB0uAAB0uAAB0uAAB9Ho;$fN!y@~FRwJnC;EkNTU)qy8rHsK1Fk z>Te>C`kTnJ%G^~li^qj5DxXEu!YV)GA2$9Vk3?BG`yezs8)qM+EwWn0NHUiSw@og0 z0>6z_fWPwL1)R`RUtaiKa=kPo*Gv3joa?0p`C+bFlXoN`2&TK~A%ft0ZnBRc__SZK z*RN>vD{B3U$KAa>e5uQ?-~m``Z*QcS1GCoVNHGUyEu)cQ4$P_Gz?=#W%&FkOoC*%i zso=nz3J%O#n@fUa4xXQ8*&>W5i`?>(pxGg$r&+e>93=)Wh+dQV+*-Nu z|6W^4kXt_Nb!8sN*Ohr7UsvXVd|jCb@^xh%$k&y5AYWJJfqY$=2l91tuH0Hy3(Gx_ zFD&;!zOdW_`NDD!u{7A>R=SGY)gy?=uKqo^pthXonM{`=h`)jsdoqJ{@a7zw$NYTYL@q7GFcY#n+H;@ipXId=2>)Uqimd*N|`VHRM}-4f#|* zJDg0EF{p|4>$ zgvFt+;l8$2z5wocr^PSOKmU8jp=bCy^bB8zp5g1zGXhW8&j>tWKO^vj{fxj9_A`7P zdPd;sSBHEZ`jD?fAM$nRL&cu3KUC}q`$NT^us>An3Hw9Ep0Gbu>CnIObm(V6W;Q9F=IPA8^2-0m*P&1Hbm$j-9r|WphrZd@p>Ote=$m~V`et8; zzS-BIZ}xTQn|&SnW?zS1=IhYQd>wk3uR|~Mb?9Zj4!z9Rp_lnO^fF(EUgqo2-|%$k zZ+JTNH#{BsFMJ)k!`GoZd>y*O*P%On9lFEUp*wsXy2IC@JA56w!`Go3eI2^d*P$DI z9lFuip&NZ2y3yC68+{$R(bu6HeI5EnPlvwI)1ila9r^)JhyJ9mL%+?_q2K1|(4D>x zeW#^EUv0b`1+y91@uJG}(JUVuuOI+j^4b>sRcl%Ex^>Sz2lZA3NpN`9|c5sgG%M~1vVZw5(zq;f?ez%6wzG}Hm4JQok=GRZZ8u_wbS@Ue0|MbA6TW|D-r=MLl!)+b|mnXf^ z12|G00jE{{IL&hg_UJ!V`+U_*w|Qyg=)lpS;gcBtQAU69jL%lja+{xI^wKMSNz?o# zaF3fW2>aPHlhclKni^yNi zqK#I{YtV?E1v!eD5TVx^Zpvgwvj{CZ{q(RcGd!Bjq{FVv*l21v8Sc(x!!?adPb<<1!-`)f981!8ZWn)wL#-?y{qBq$P zhC7maO8XZGh zoYJ;TI@vdtPGrOG(d<~?=vX#cXw=&iqp8d=k~?%IbIC-uZxHao)?+FiW_E{diQzw9hk->5h%npI|rZK^hvC)W@;c55r^8l$S5Ov_q2q|qNNKHG{Xq~6 z$2idq7NKok^nv+H^C#L$&3m2S$Fa6=5!!DTZ9jfle*0}(ut@TV?O5Bl2<`3@%N8up zZ+~lKhD7A?JHW>xwDjUHE~w9Mf7>=6Hopt}Pm2km?xftp6$RRFc{S}@g#749D^57I zK>Mp-qxRo-^1q(Ykl%jitAf9^P`1>4a1kQC9TgJvzvG-&KK>2Ot77=SRM&Z;)^Q_B zLHk{>mAiJ}UpM+$j*1>~+Io59*r;?vv$e|ZSyH}urJ9Ac+}oNUOGcB!qT{#Y$Owc= z8s?2i(t^u=v+(<9p!(w21{Ahg1NuKpXPn&Pffcs+mT+5QG@F7LR!tvs%Q168E8a{x z$3`hI`E%6v+LYp`dJdr}?WW*wg~&aSOXZIKZhW`xGeS7Q9;|f*x20I@Mp`g`N4&*-5koYg6E)hcmRaZ zog9@uXt2d--Ih$`-~*UkQf`Kt)UnZr?@^H-Prcn*GP^2nEiQGZ4$OrePzgG~DLNbw zA8Y%Tq?}&)mXb2JeM75FC;qVx61uy`o>zfB+bv1?^~yP=<@xRR zpxp~zF?=jZdF7M`N-H!1iE4#DIEHo%W=3iCj0_ToFqR9lwjEoc(&n+Z0&|M76JKq# z@bt%3kCac%pXUw-KZX{MwS5auZ>YYuqAG8mo8bLQ4kxov-MXQ{C5H;nvK1I?g%7(G z7~Bxa$YUJECTo^&toiVin*3RAK-(L4*;K)q9&7v7EQ_X}JJoT#xQ@*kn;-ruNIOJ6?_dRWaI4mfp5>#@=ejAFtZ) z+JIGg{wsyQrMEpkqj8$!kXP;FV_)HU_;>yWyN_dq|GHT3dH>8G8jrk4I<;Eisr7sU z1=s4vb70T&6FT7)|zv`%>`r!mYonF`GCr z(eF6##S7l2t;7u6m}o~7M#{xhq)raSak?IeH_vs8p$RHsk!b=hPkA;v-OzLiq)fep7r6#a^b$g z6g=>Km{Bi0IS&>Y2lMBqR+Qtzp`zT|osH#UARGw2`S+=fjx-+WJ%GXNXnS3Zi$v95 z#>~HE@)@9qtUxQfI{{~&8X%NRKB&_wDdFj%#Ga&} z79bM$9-2v|4}>Fd+9!IUyKv`%(@19N`%gt4vRu=HrTF^v>;Oys?&`A2>Hr68E0)*s zU-9A-p$gex0p{Q_B-R>2NnR}*A?SzhvUDOh+7J#VfDnu*fpQj9pWF}oVibM%fl2@| zJUK!4oNSzMUxBZhQAbc1Obra8*&#UExzj?*0>E;Z=df%>$V)P}R2use6F^B{a%40Y z_9yoy)1c{onK2*R-qm(q>#i{FGbhrq08Q>rW#NU#>@W$EWpX&oCKKt@WoT`0DiKXd zlUr`A7oK-+bs<}wP$m@637_Uj&!E;JDE@>BR-j8wIqVqpD6rzmec99~-~|MQo3N#Z zd2?!J`w7&x8_?ja1h^P2v0$Lsm+4Qc)*^sr$3Xn(nnW66)hDwP+qxUuJG%i+s>|C_ zec4PdgKy<>MZwz1Vmz%FWM3jp+^W?hb4X;d)cZrsn4?Popcq{u+dm$zh6kO)#hLt<|tl@@w8tb(xOQkzg5tuW(I%qYej7fW(~ z0?t;BTC)|9Jg8z{62QUVp-eV8F_PH_);gBXV>GfHh4O_zVF1KY?!b_8bF+PqaZVg7 z`!EhPGeDm(7E1zIAwd0xd50~HX&5ZP#?WvQ; z9swNnXZGd7(E}rDynR`&0WjK};qd@@D`=0c%GMxAYajOeCOE?cz`${+W(2c%j@+%l zS{ofqWz{Ue^P-W1z*D&l$qsPmQU?P_?N0S+I?Q70Bb7zVSV{d^aDI_Yc`Qw_pWF}^ zTYZ?85r78ByyOrVWVS)E;0f$ek125W_haIK1}KQgQ8R(^iG@6fLGMc(Kpu|7 z@Brw}j3;KXz^B=S0O2H?2AblB5?aL>FxwtO1i&yhu7{JDTxJ+RgqRviK-6Kd7(gyL zVOWif6UgGQddJdx?8OguHIzWdKs0(!438E7ykWJ#7yu8{i)q^n8p8gI_&YF}!Au&+ z0r;}XbaF2mGK&DyqAF2H-uJ`lA}bQGAx;5{EIdh#i9YVBsHVqq3bx=bke(C96N1+| zC@x({+*=4-}|=fvPAje#3szTndkE)yhYFqp(xdNkadNRM%f z;Hp3}eA$X_I4dwss6Rj{n4NSC`AAQX^y~IHk>4lK$zhR1bsxL4nIRdVw89<%-G0of zeJsnz2pZtTc-AHmRxk+A?lzt_%)l^y0H2su4PlxYGH(D>rm0n`epKVBgfL<}J<*p? z3LJRbfMBg5$)dfgAIWz(Rj%iVhC(>A`TABlv1F5|n8ixWL(KCcTatPGu zMF*6DkyhC-(F;+hStF=rFe7{?(zN0QZWL^3H3zK(YSc_USq2&|-DVvp$kV?qN zYJzl$He5)?1?7P#HGpV;W(asvA_Qb@BoxrnrdT`>pMpjRqe1pK8hF*g9Rs=ADjP_^ zb!MN8S#(ZFhSZ1_`5b>D){-|a`?HhRC@tBd+DKVTq=_f6ZnaALv9b{8lf`H{0q1Ny z7TGgWW1%lZUD5NSuJov|R6zxC@4sHQweB?4yIug++5yMl;)Aw{B}uY`?ldG?uPB{L z;e~$Pn;hLoVJ1w*P%Z#Dk;B$=nBh3dH6?(_uv${KEHhFI+m{LwG#Ch#TD@3FNZ6g_ zLNw5)*nyuZdJ%+ZGzV>s87hqIFKL0y3jc;P6YQ_i!AaCO8q1CK4RQ%*#s&uCUi7L- z_EU+32299M?*U>GW^8~_4;d}#7{H?lRO=eeqok|_;iJO7!`(^5^kAaUBt;wIlr&Fl ziY?{~PyNhN<2!wIrm}upEM{!U+tx=bq`4?R{lb3LE`>p?F(0vX6gCN>(4ewG;ZmC; zRLVqUv6V7QvI&fm=4D|!*tpv9I2)c!; zr0JSB4$r7OjP*H`8U-dm+FH_L1=wulwy7_cX;WXdnH$ZF&`?xjMZ|$8Oj^w}BfSos zM3@3?It*-hEHeh1GnE@jLmLD&#R%jgp%hp4T`D($_uzg=4O3?j6J;=&9wE;ZB$6FK z&ml}@vc|uHw{l~t*oH^opln7dlH>BFY7cH}_=$$9Y)26L(7lK;;ayazj0y&ptt{I? z2mufl%@{IAC==o&=~t>tK{3=2_F|1uFM$GyU`QCPkk0AE@E)uW@($jCZk`wzhWe4} zQv=YFSi}zBB-;#^fe;4x7CAJ{3i6v}k@0T8piEZ)4?8`nfmr>-(t$XI{R-Be!%V0O zs_+FuCY6h2DqsOMAMU1zqqF~seVH++y23H`K`)}-JvNNsOD@pem?u;KCFjI`?8{`S z)6(YzI{}_0(jkZ(`eq8NJqe)<=>uPY;sgkaqIZIXK{_Q-H(Ak*FU;6tJfN=~&r~si zM`@2bffiGa6VVElbhvI0Mjo5+q+-&3AAuz@QBN+iHe)drDTT`Rp2!R*8xcDSKqPa0 z+0=+Q4e>hFVPUyw9RHIk!KXnhNGJ?A?%TtaMMDn@5EKJw8hM8Ckl^y}(^UlUgB!vL zB?BM|XrVgYqd%yG$zjcIfje=ZMGm0YpCq4SL!$@618~i$ZrP+_ONQt1MYPZ_cFu(O zki?D?)j3kLG22!G5(Xws6{UkHB0<~flqe%&tK%tO{n%Jx)a=#el~f6!~eW z!B|z)>cI)&`(dpJE@&fk@M6&7W`mU{=9BS&aClnbQIbU-)NKG^SUJQ3_%mc6!EabO z4G^{b3|uGF1}p&;k4M@jQ`ikn$BbJ9qGpgO=(LJPNf3gd5ateAF=!`9hDP9T+{*xI zFk#`Q;Ci?u#ByT;Fw7xx0Vr=VU;(JThSoE}9urd6PJ79Xt8-SzU)Pl6?M8X+{tiWn zB*r*e)n*f~&>KB}2%`k&LIv+|OzKDPuN=c4JBIJL+J3VIg%&rc&S(I$#P;cfxB6P1 z8tzMvVRf<+5rl}w*whsw*@--+r#dSA>z;^42=OPc9-9(U0`;lqz&{U z+jiV(RLm0u!_9Quy#RH|Y{pp8Xz6#H-`i(=+ngCeb2{9SS7=y#xwxjG5nI}zT1%A? z*dDDjT#A>{GLz zubHE)D>U4xqRM!MF08#B)bJKH+Wj2=(V*tuvpc)^xX+s1HZ-_HHtjecxk`Z_>767| z|6X}Fvu7vG{v8@uA*$>~XrU1o-sEDfEq4a2Cg`CMG>|^vY_PKSG=ym#jbx^6&uM)2 z!Wr`;0P6Tv)0vT3QCYiuj^2+4Kx@bl6Uq)8`hg`(vSg_ zI~TXqYHc?^JGXV#!niXPLaRFyiwoDRgeWq0m+D7;yX_V%*`3`w?*((>2+j5=qHn<^ zO$l_uNwJbrl;SP1-(phiuwV~vWvdl*^_KZ}9;bt;*`JEvYHZdie*<3KrXX&>Xomy8{e*ANTN2ShtHjK(GYm$Yh{W#cgS?mhN7Knu@Yb5ku`u)Hl4mt%a>9 zjbYnrUYl83Oyg50K5rtR*`EO^MKYWYP?mH*0@uhX{c`R-YZ+{?I=guBXH7UXI#W^5 zEn=aw$S$!>+?a!D1m#!e&pPNNG9}{+poxL~6KrPCy~*41VeZaGHGxb_;eUcM5d|n7PfnCA+gT>aJPT5Y0>l zPouL)P-4(1l4KOqfTN`eo6XXz(9cLRu}70F9*m=-y)G@L_-tM4i8`=4dV?22Be;-| zSABL8j97@MAw0aY@-Tik!sX*HhB)Ng?NpUE*g@B~E_uNOU8AQiiG$+>`^MQmaAbue z)X6f@1X!ruf*^KcuitXYohJ60eF*p0ol)Tt7Q+dl^KkXrRSlpFS(c=g9K$JSbZYqG z3~9f!7R=Pcb~K>!leX|6L~T@{H3k{j|&&QtSlwrgnT1ASsA7=J{5$V={r+= zVCe}bH>)lumpN^aIUP}akXT%CxH$$Di=0Q6FJGcJ94K;B(0MmweCbPxMWN`4@y6QA z(7PRezJA5kr>u=&q@t_Q6EEn{iM;aK>H54%m&;oLVnEK zb(jgvglH$uYd){D=uqy(4WC`6Bd~qbS_9&D{3E{pHGW$dzcSO?K{m%2fb9^G9TmsM zNcRMVXp!(R;8K=?9L~1grWUhV4K@SmN~YsZ$_0-drJby}+eB%jhYr!2d4b*|+P8Zn z7sGu%S8yXB5Ak+q3oFwlI%J!D80qJ9h8wI`?t8HYG$F^-MLU)Jz--;ceYRWL(nFPX zCVrcp89wH8X3q?b;<>}kinGBPGolngSgt8-jKC|E=*4!a*4Y$%?f$Nr@~DaDW`E>g zY;e;42uW=LL+av5;dqAVMIZCfW=*bj>ifznBZi=MNYMnB5M7qI`Wb|CQ7!w~qxGT4K!#+eOK)TTrx;vd3 zS-BgLd!{=Vc)Dc6@PuhYj8p3k${c(Q|b)NxG#h!+A13qB|$Li6EqW~~BOuyc^H`$rEoMK?wmhsVNR}gCj z`upYd4ikKjZh8z&YI|4~FYBP~U<)w%(G4ASnVHTk6XCAfpjs!!L1*fyiMfFLku+}w zbBL%Zz$^+*t=;NoV8-W+>vM7)Xd{H#q{mS(<5&mE&ibnH0#XOsK~7}YP<)<6Gj2Q} z!X7)Th}Gd?^@787EA2BY4;@!mtK;C=nORMw@=^M7NxkXk7O321f+M5K7_ z2u4wjjepO?Y7!y%dD+hTkN+FvLSi3=*V&!1PD{f{x+>Uk-{v%oeY>3 z>0Q0>yT*Tp&eYi`a{(KGZJKRISbJt4U&SN~XtBVePW4pHoUCrnKH<7~b&-79LR=Ae z5e)B+p(UrksS%g zK!?i+ee&k2!%NB!>-Z!&u4BlsU{7wP-S5K1=>*QR_GEQ~FG z{uFH3t+Y?VwVwPw%PZF<2h%Vo(T@;6s>vkU@Ko%|gzQEuOD$)&7hT$9dF5U>dCMZ5 z&H#O=lXm7JH7aqv0|-w8!IKgZy`v8eD*zsKYIZkw*1cr;<93Q+$1DJHH8Ogj9+93< zj_9Rg%vWs6sjYou!s@UnAEcYCb9lR#++(@n&Xbgto^ZDN3ED4qwZOeJL#l26L< zkv{12IBA3=0@MZa@Mm{+!YM~r{u_sVy~>0lt#kj=*4zKZ$awPmG-H` zv+J)j{x9^g$;c<}YxA%e>O?@ny)1EKjO8%LaS-*yBRzr>p}B&6+MPXLzxfm$UyFv% zF%FApDr#oYL|@&^KD*+#mfvlg@N&J!8fwQH<9^Z^9i*-J0ygcz+Ve@P0O*pZ-fel@ z)VWZSGd4#}Ka;nfN4o_&SlEzWrV|{*@vjdx)GdGQePT%0Wyinj>%1eQz*@HncfkR7 zogNJATgQ1Z&6h*WpDq7wQHfF&oDL)~7y*5_JB^TREf!SE_{kVRN+)IHw0(9MM$lfTpqGJ;RxO!zPr7aYBq< zWbCRF7d9})*jG@eoZD+e1fGiNhdY6ebHqj?vX3E;i1-*qv@^QnkpLb$!u{QFj50Rp zSO9Dbd9!KS%?ZZ*!8%Af?j2m+CXAY}GQm;oKLfXy9JesueyD=lqhuMQW}i>kGLCAR zbF21gQ1_52a83T8Bs+kUOEN?a!Bg6ABNR3`G%q z(2TGr!)QS{BPP1F+9cr&fdIAbVxKksQO)Vb#}cM22w{wKgJ4=vg|E0qCvWE>VdZJg zC}rBdoR`o+K`&3tLg~=TwV8rAO(j;?kQp$o4h6&qEVk5s&ZBcF)> zx3=&xT613brP@w9JgiaUyl}YIK~|eSM+!!Pbtv9H35(w!Azrp@Ej-;bqddwxaJti0 zw;U}7rP^mFz1Bpfuv#0M`FAF2>lG~ac0}McTKh}F)#6pL|G4{1IMaBz&cW8kVF~h& zf{k;G&JoR%^dY<|UTG4s7@b1`sPG8rN|`uAF`}$cBb$ICP^x$!O@I<*Vqt6VoUb!< z$ivopXVgMtLpVP&Hq?micM4&L;^Y)P!z<-53y)!BQwWiUw;c+nb>1Kza^u`9O$?D7 zoQTG%DHAJ~A=f+z4DO81^v)Mu`TBsdJp>4YjpA(=GLF0Xm$}P~N5+tT7j+A3{(my> z`;7T<=ij`_nSX2lrDNDHBR7l@W*XGcm4rgzs>V>)VN`mrl)D_^dch#@7Y}gb{6919 z8@3*8wB!&V&NKK0IY2WqAXw-8H3w+4$=^W_^+2#50j&cmIaY^c2@Dn#l8guT$>V=v z@+4-HPSc3IrS$Aa*tR-uA#9DFKMSgFUU0`8cv3v5LL^z^jxZK(O~6*MkIqEoAUP8; zW{NKY2uIVv&7yD+^$v(0_p-@&^v5miH@+1N7fUQL)SH50FnT~Ax?Qsphr_U(I1^su zze%C(W>x5c>;iR;fUqFX>5``&8 z@r2anO2o3d5-(tKw67l0E1t;@7Ogg3lSt-I3Sn2Gb>wm&2f_}Wt37@b^-bvFXcB3F z_o33_+y@hRP@|DJ0P<3cHCrUvzWDu&K=Qx?v1E~CH_rY@%l3Yyfw$OpU_cm^_$=i7 zac*ok0&AJtd7*0xhUTzHEX`pavGpVwhnMw)Of*?+e|b}9zRja8q^%9>1>2+3^wL) zYG{lr$>;(zPDwDv#hq}oD-*XPg@itF>heEXp@1y)mtH2AIBk{9^g|t&PL3OKgqQ-q za7vX4cOlsn&{^swR0!zQ2T;w49w>Bx3M>uut-|2!DJ7TQeG+0?yeYW?b6eto5?>@1 zm97*NO6$f_;&nJ62d5^9PL&SEx7rv6&%>W!V2~w!h(EG9+`?sPlP9rHEE+ipXk=z@ z5~zi+qSRSC*|KYKh1_Ok4ZF6N3@+EN4Lb}=Mbd$=4A_7X9#*jv#$37lfjWfgxDaY_ zh1L$kBO&A2mWl|}1gnTksYNjPlNLd(slRFoyb^BPvBCWx^{+F21hal#)nAE0L0)Uy z(9qX;_O@*fVn#dMjM_MF1cb&)q8)}}w~hq)%uu0(hgcGDaR5lUaE&ZspdwPYXedG~ z7!OzjPGfXz+}?xS)D05@IRBR!YQl@3TUiXOZ`AcR`}8Z9=w&S2#oneyl$2V-Pf=Qy% z5fn&OAq*5MEe=k}uEo03@G*&zj7d5s^|01!apX9c$8f9qdC;Yh-xqFuZPaAlW)W4Hn2$gtQFM6bTT`sl3=)#9Pf? zI{n_MwaOg@)!F=XSeZt&XDG71$%{k_PyuwDq@@eQ>6`3{OOy^H#CawRJ_Ga9op+ua zw*~lcDeyZMJTr@Vz=aZ#R`XiUzL|sF3L}WVF$up=@lE7(M*fP#vF7^Cne)xAev9}m z!tH3JgA^o5cm-cLnanIV7^E$Zaok5!mPgwi>g1p${ai?>2ccGh zB{n5N%-VHwGYYW6(pDZs<$CK)P9TE~KMcSFq&%n$NXh(Siy8;EdBm0kB8yVE0)(67 zPGUYOP)~C_gb5%ap{!>tEOq7_y|yYICoSkx#*(6iX+K0h!ncO?AZSEa5SS?GBq zgpG0lGH05TF^BvX90z_a00W!26PBYwnfbyKn~{f0_|9rT2_Il!(jD+Sd<|#3jRE`p z@W+CtskF-vOl^cV+rQUKP5gWO{Md!4-r?_6O{cF~zq%z{zAbZ(9G|O?8PfQ|g~p6h zsst2MIjs}F-lBR%SMh6mPx$&gee6S)t@n!L7i&R|v6hzcRynK~ALx*VW!&bM>T0?4 zkHB;Uov9#oYnb;hI^G<>=(Nt%Y1b8}C}#rEA{)aWn{TQ1^$qpMJpD3{>DJVzB;scD zl`K^;Iddb(C?=*A*P)6D@8ubG#SQogjd;tXaG$#x!Z$U97uZ^F0`E1AcSn9NYXDfU z%|uJMAxHG$qD^Y@zXhaT685h=GIE5CE0l}=R5Y*xUZUkZUs8`^TdpC-@<`oR%*TVQ zzT-=xYNa9@arVe;u{IPN(RmhL$8bpSp*2mbR)V#~^n@k=f}QExDAKsF*;?GT{i z+>>sIR}58JXYII3%qz#{5c{uMzq4MV_yi<%eq;LO=;(LUu36h7>m(7S+)f z4&ys=*6~R*N8Pfeu<4^MQJ*FQRnF`h5v&CFsn{$#br1gW=s5DsWCt_wtn{h(1yX4q zy*@yjj9V#?$H%sp5(>}2ekDCT*n)}i^_AtdOLR!SqlV{;H_hCSk{3)8ktm+7_dS%w zF`-eV(36VWe;J(zle8&^DI&-bA0 zIQ|SPQ_kS2pEsFu44PimUol)xcMTVr1{0b&D!v$wznjWCp;TUC+ERHTJOzwY0+dh` zsic%gu@OatLIzlrHxX|hs{IH_Mm9{MrU!TrvUd_`lF&$rO(fe<=f8kDV0={NGa`7k z0P|#CG;7Nwi8e81gph2JMWP%}MidGuNw-Gg8fqXIF=3z{IbQHv(v&G8;e-d12-$)W zN3E8|JtTFMoNW|x1@3_fL@VM@Hkb$(R$3DBfcntEHfltg)HIo*2hK1eQ@(O{OFRr|yL=e73B#bV=Wc;W(>~&@|9d z$^#8krJ`_jkO@j}ljG9yJTTZS5F^=pEyq=>)^3j7;DX5asZSY)vFE32+D&GUFjDX6 zAEZl!FtAvu=IcP@Ze(sGq6EQ)lvUCjAQ9#rxvWxv;Y7ycREDD02|1q00-mWX8j59a zLSkqTti5o}}fcf$S6hXS-u|cd7sAyf( z^w=w#5lT(h6VoJwMmcsKX%k%5s=&`or=1kf@Ng7B#j6q|~ zswGFlHa06&)R+v)X6`h5eA2Lpr^!Z*#+Z)5?A~D7D!etCc08p!XTCHIAN9?V~p2(OB`V4>qf$XXTWD+W~-+)j(VhfC+}HRu0dmGCt$ zix6Jt@Xup(9=5xw)i;{&=s7OLqormtA$kxa2{24mlze6J=T^xAbmDXd(Fm51I7IUK zG5a6XAUM{v|0ot<+%K|NsHS8ly&f2haAh8V9%w=U_1R!xQu6b191INHD_J3c6cDar%9_`$3LABFh)L_myGSg7NFNyHAeNYjtgn@rjN0UJ2ow`(%@@V_05J#2 z4c{`pS-=fa-dL^kR4e_2yg+6PB+uQ9VAiF3F0%@r2qPUxBQ{QaPyCLH;(wJwE14}Ew%gx%d$e-!uQF%jnwBUKZ*%23vep#pf=mjX>u zPumB8(i(z>$^lBr<>A1h-S(`jZ|kgX}MBi=qQfoEr14 zfRzswnwqSN!ZWkPv+Dc;q&>7<3eme_7{nma@>f32AaCwcFOI6?{~&xjMD0zpK5Y^i zIgGel2Vi^LOav-3utiBSHGkUQ5MpgzCWyzRqghM*AwpE-3=+tQFs6@#$nA~NFX~1V z+IC5Vp$whyOQZ*qy;(`i+{+DErp)KIj!j~#_pgr6wTOcVJ_7aG?Jjfr37=r5p8;UR z&lACgL0H;|?>Ed0jtlAn_h(ixJqQ+81;Hg?U%_8gR6JJ{1RIO*n|AiRpOt^1m=Bx3 zyte8u44#NF(LMiW^Rdox&^d_6AIzJa!ORZk26HeNbY}fbI+*Jhm_eAoeCxhxy1ocg zv<7p_!k^F8r%omTjC|_N0H!9W1rX{2nQSzgNyqZTMP>}vG9~YG8h-GB~gq)A7N=U;)Nd%C@7QNygMX<3CQhvh*wRnEA^>RA0(5Nne|o zWS^aON`#xmI%Cp$_LSC>bYT4xMJbSSQ*dHX9-I_32W8TS`E^oo0>~I&JsGK;G3~{d zii(RaLCB;>*teDbYU%z((~Cb)5d?3XK0U&@sYjcs;EAU&+W@&>Pp(^D$A5Q~s(%ZD zr|$CanP*;udx7c4YST&w`qTQePSJto_CE2kD3baa`B0F){>sew148p=$JZlspz&lFjSwoI@~%fRm7i=7c9$4N^72TI znvG>GT@v7TPZSLZDVz{22^Iw_K@j%OiNxO}Q-fgDv;fvjQAs`_+*Mjuxqs15i-$l6 zAD#Zwh!9LYS{#T8;jYrZELH#V2_e3xp0Nqxzu{g)B&KcjXOn{n;tY(iaDQLJfxd>z z@L3NioSELeOoIvi49+xlYK@SFZ0f_qqCX=#O@!Y5k%j{!4VR6WPogM^25jm5h@Hwm z2l)m}!j%$ZV_8riEC)6KQ|rgaMo}SbbWhvA=nKWQSg^Y)mE2(qca^GowD>;<8?JT% zm!i_p4fL8eP`i;M4B~~3PJn3@o_;s#4*oKM2`h=0jU_9NoSmvQlRi=%jL<$A%eiV$ zM_vo_LbVjx#A?m077L^a@*D9Xn|S2l)H*8VeMg88sW>|X(7=FB7&FgS~*ehk$wCEb#dmZ)s zUe%5=uA^4)WP%oW&iGz>8CyFs5=v!s5 z;&}J=X%nA@A{dXkl_9`uF+z^z1lxqJ^*}OLM%w5C-7od4qCf^Hh0>!xe`C4JQ5= z?dbGieXtJN(G-X1C(({Bp8lQ1A1qY_ZvOJUsD6s8vHkd@b>{2USG5tQZti^oY#3f1-tQ34x!ns(xU$jY-qT;mI<;qo3__sF+e zkYlKRd|Z~dwM^tW?&jzvBYY>Z0vxFczb~zC>dWL9Zi1SIOY7_5gQmz-Ay8;5b~fE! z`Rfw>RbyK(W(bTue)`3D7+BVgbk4NqN>E^xAr=yEnANI-3?)7wUeYmAwWgF(TuXxH$HQ-Y;f zzw*t@XayHszmHXJsr^=!V&LX4--zm~HLoCRg9PleW^>_;&zOAVhF4LHC~nmfti}ky zovfdNBlvv9X|vukOK~gnm+wUN(_9W>JH9BVv81v|9jd74OCs;Mks}UVY^30LtoDjU z&d~93Xf=@&IdsufH0NBiVFTcryBW+-BBK z!6AIUqH)0-jVJS$??m;}WeD-)&t35GIVO>^Mw9_RB~KRI2=<$x2k|6~jKB(|PJ@+} z&|g82#5W>m<92^}LdSfaSQxXheLh-cW0+B=@x^R{(kjj&YnA9r1A?=H*8>E#762x} zLVNYP#n+T6ESSH1E2^(GSYQt^!_&+^p29gNePp4|s)4Z)C+CJ>;1ON41{*M<881Jg z`IXnyoj6~O$o%D7QT+^e@!YuNrzfro6q`b~E|UlCNd7$u<6ulGx3Z|jq!Jt>hw1$o z2(|_781KxNAMe|%9$EHpHI3q*Fn{@0R6o-l?}wKEq|O9MIn28UVs*6{u*fwS8(8H= zz7^P!GW$M8g^0KY4gf?>0jQoTstxU%eYSW@L2nspd_wq`jS~nUlC*YN0`6Q(6N28G!%k=m67wNe9~+lvX?_=9YXlF**EA#9QP2^zbKwRn7YI40T!U;9ZjawCJ5fM!d=#G zRZrC?%5_f3JSx=05Wg<*_?)YXou+}8P=YC%JcX&{ABpKNo|>glX!Qq>G7iP4b!?1+ zCbuKThG9FX=5Y)S04Q08-$G15^;4fF#R<+NzD)$7i3j4tD-0g*OEBsH8W@AJB`rVp z`Jl&{z$vA*GK;0&fJHWpY=-Al5S+TQF&_M{r)@QQ&UzIS!4a#E0?GGLIS2{?R+~Xu zTXCPP`Nfp!YMI2OeJuK#e#U%4{v1h8vsr(5)=}8D&-kcOUff8qPTJ=3fm(*p)9l+L zt(ec(Dlb>OL96tSG)}`x$WbCZJR958vNtH|a|{)0gAXt1I0PyX40>Vabmh9B8g8~w zN!2=Nmn{MtU530xQARt`(~#LYj(fB8q-e(x_(o?~cY#upF}ai=B6b(=^Y=L{tdHK_MNhH#(9G$3sV^EB|a$l#9Sels2M zJKPcVmmS-|+^HwySXrF00bXA_mcrcwa7=GX z5?3}8-1WBc*qLlV7y>d7$dj(u?2|= ze}>83m^WN66mT(cz`;PUkbtov4rhz{u%nBEiI&KW*I3|=M*#+mNt^j@4z^&v5SrFc z!TH`&ed7u5tNEPh6Xq}9iRx#|e4}LEH!nJ3+-C;Huj;Rozby_$91EX9yqP#imD>kP zxg+|1cG!wtc866>77qo+90k58;Sf3>r_b}4Q!%FKi9EFug@$NLCqUCqoWR8r%Lo+! zAo7LPSbmT{dfkvZD9;fwF+3XWwIEB&Xd^fNK`c%?cwFs&d9F5lPUONc3*_ss=u171 z&jm=9wn)r@lQM|~c6}hxAig-R38Y%?+aq5%RA(Kj!cldAE}Ptkv54Xu3m11bzOnqp+DMDlMKcf|v6k89~6TDisYrI)VP7FQ_2bXg3Qd zMNKppBY_(A=Aq1qOgZk$C>E6XREV)gh4(haT>9?nGLznDYbLXYGL8XCF0KJbS@T9b z>!cWbYJX!Ecpn|>h2upzzSGIw60gQaCgSKObyJ8^L12HQh${_ZYtSRy>?m#KT=aN_A<*p=$If`=y~J;kdiiYeE_a{iKVpn8W& zqC^iUfB5@Fg-$+a0vkKzXrvC~60V*+*D6&n-OAv{M z1Tr|pomrtuFqZLkQhd+cSU#eeDB^`g?*VX(LdYlNuDueXIco5#!N*-$P9BN*Q);aT zRx#N@g=)htMk~|_#_UDlg=0L)^Rbv#7HI_4X-K7=00S~MIuRi;#SIXT!cu04ZvN{| zCA;u!^P1DzLH$^L_~5wQ0o{}KEypTI1~N?UqGyyyxM-pe`~qLX+z3WvmOCTB6Y;xY zH)DBMngCzEw5F}2t8MGXrjG3$`rHDB&Ko)Tk~eop?QlR#hlxf+PRUPi8%va2RK{a* zw&+W`s$DI4_1PUz&+eFMV`*iOY9UT{!?pyN1iXM((Sx>7HShK)5=A6bnd_n=TVLJkK+MCT_tH#EMEaMrX#~5qp`#sQc1iC zEn_%gM!s2jPJnPZPbMrMyT!7Z$Ir!^58$d6R0E)foeW$b#aD6peOsahw1gp2XVzbV zjjx5qy~0ozb8trV$JR7>$;CXC#SM+d160Yx`}(Q`NL3(|~+R7|g^S?!-}t%ZxLc&1*tnm%{sm4{^*E zY3N>2Lunq*z;YsD(SozXQz$2k8z_?iO#x1ePP?|g+`}7HsQ?1F{!LQpn+^+pE~*@D^h-O$r^7PYz}6| zfg28cM{pWYxdSTUXn^`kUp^KagTg1UOhxGNU`->x6s+Rz@t}Ou7{FAvi5R?EF%^mc zSt2bE9%p_qNDUmIf`YaQo3;qklE2t{Z^72P+Mi<7tb8yy+EU~uy}O0GFG)?;GF`23 zeFxC_0BG;n)YaO?wSaH>QcD(AB4bM^BXxIu>M|x@D})}j=A6V-GXQnwgApB> z*m}wjfK9#x##O4fp=H|yi#6`ailQgDkf;i0%fRqpR{$Hrd1J_$Z?{95_U%EM7_}?_ za!Thl>VSY2A(%V_9KIh7AC>6*6csQL-P}6dhQ|}?i!JnSX-r#*8X#Dy0}2TB**gP7 zC9EYz%sNb!p7up^rcUSyqIqZpCzk1-iZpI@h;b4+BU=E_WUp8BT^y-2#AT*VtU^$L zJ_?@H8Mkv@kwPHm#rK|tIhE=YWtDg-khg`fjHRL`o*f!66CoF-B$+d5ZkLZVg=_19 ziVpW&6YL}QAY^C4uOt}*70?MN<*+nEoC4Of6~Bw(@4%fom=_NuqSCyx!663FcDgMO z2WNcVc;Y&g_9Tm6q;3uy`?3c?!7cfqNF)7w@u_=ahH+dGgwXcNBaj29Skg8e3$t{FHiN1SlfbJG->qtb$O5E;M)srjPjjMAodNx)0! zGli~?FG-Uxc5K+Tsbi~j#wEdT|FD{X&4qG6a_h$J_7ez`(jm)?3mG1OPYsPG3Lsl8 zAbVyV?LD2X-O`!LmIdgDLLyo$KN}(m?Pacti1h-&UfX1}=$~P16*eJBS5?pq*17&R zC@mMDA3!AxNI#a$Q{U{sz5F#9GZgD+oV!l(o~poUKS4|q<}dJ|IwH+!OHtxhcu-O} zgGBXY@zr!;19%?oFwK%WQ>oBxg0&(pCkvm*;tT{#DzizROwod!&qLa4?Is?kEFKI^ zPM$|=VZvLK{*vUOj>234>5!akc&#zm(>SxCkPq-O@iPz~oxA3oEpDC~CInC!O)rN3 zlH*5>|IcG@X7Ly}%iJ+JwF*W5&nA1vQfVPxEyS>b5Qw!0p?`8>8Y>9{;ZZzw7+m=i z#>j1M~iC0UU62IQ&Pt;{{iF35w8doyW-@J&F% z9uo`@#@aQeq^Ln#TRRy2MjLH}i%Ldn!d-s!Dw%k&Tlu8@v6!y!O#}XV(t4uLK=G!=j$PFcVSV9oR)>nCZLc|EQ5Pn0NPgheg6K=3$F2ey$MIh1Tt zuCR!q$eZ1rThH6r6(R?%1`Z7%g1CUL$5EzQY z^Um0FlDuUqPA!Z)572!{Ay7mS+=hXJBye)GZx6$7wO<2Y1eTo%a&vr&9z8b=G=ndRG3I36R>rAegQ(uXm3PYc|4Fi*JeH07KWJt^*jtg^Z;Lc+%qp3w3Xj7Nxy$I~h^XgvQ85!qzjQ zcEfh~7+^B7@q*N0eV{@IouA+u1yJ7_G9O0g_Zhr^Jt`ZCyk zRcV-Yu0=?$Ot_Z5R^28XX7I;?@r)iA5zI}>5;(98YGB+kVu@qPAQ4F6ehc>=!f$ zXe7*;1C*Q3XIrU=Xl=$jkdoa?EJrZMRwMusc_*G-bs%j5wy&mWW0^aZ3D#RVoWHfNS|en@Jx^%+Y95->L48L3rlE_ZVli!>@YK zy*gm3NlEvt>>^8DavP>&&1Me`@SAEcy56WOc$N@e|sv9Wp42aLzs8>G0Abe(0ESvH62RsD9+c9U(AW61+Y zltovxWi8EQg%Wq7ep@+6Me@iuFW`@qZAIqLW%vMD0Zc0x5-|S3GfhrjEIin={4fGN zoX`ucy(f%YAMN2D*WM&NoQOe)Ht{fCv^YtllwhV|!4GFAJX3tRVk{kyjq$uG+nI^A zcIQKq`~`=kV%Flblo*?TeNxE@I#`)QKue0eHM@blG10A;o_ud~x@)6SOwMR*95*5p zJZ~HxNv?)2SX*Eygeyhsc-RB!rODf9JQks~G^}bsmQZ2dcA0VrNx$+DBU5=BYul&g|dIhz!DQAt+p*p{4f;!TQ2X+=@k4EwzbQYB|fIW=1W5mo`Nd%2TdBb}Qn3_%jm6+2Tfx5c<)vX#$+#%R!_Fxzp- zoKg93GnuM|jYb=I=qnP2DHpknTe_~8-*jOB1SGDion$C3C-g+GQ_IBO!zw_iE=OfqJ#M*dDXZz*dfOm->Ijf~M^zGmN z`2SXN?&x^Cf{b^-@0ygfx>o86|Ij!8{l`C*C`@OGE8*BK9RO?(DYU3E5?_g|ZDZ4~ zU$C8p#ZTchi2{o|w1k)Rl6ASi{?zGQj!GNP#V;<-cb=&1xYTkyWnK@w!6?c@9JJzP zh*AvRd-EDX;(ocCw&9l*(A{tba#UV{d8!IUy2*L;n)^|LAdjtaT&`XXLywt~mYJ=l z6&&OwAp78(DQTGGLugM0#Xouawag*vSUI3TaQ8ts0kM-0hcnK0(gm9%is`UK85!7^ zl)_y7fCU|cYaQ?>KlLwj5}~|5iJ2V>_FJJA7wcJ9Z^syT(`#}?5$_-!saYVs%_DikA4em=m7ns}br_$K87cZUGX4T@_Qu?VT-1 znzlyZkJYr*Ak!2fOy}?|2rY1E@V^>A$2p+D5X<@ z^^4DawlGBs15#*45*5eLEcR@ZthnKsnCgr86jsiYZL^$=u$f}nb*$wnuM!S9>jpgJ zE~a$AaLqEyl?{TkOyjfHdtFgZMIc$nd?NXa4L`}Vc4?PCuyB(bN-h@|<7GRLQ(`3W zEnsK&JAh5Hx!rw>b-L`A`08$PHT>1MB}-m8&P_=a7)&;|wve(;9@}BC) zYGJmmJ8I;p`}Eged`VS}#N3701f1>fSBENO)xe=X9a$ANxWb#Lg5))ZY=V}-3Ip)a zFa=GJ9D!R>GTZhCril$J#hZ#}{O!)NqF6?z<@CXgxqf4-xvmz!@UK5Vh}q`~BSKy) z*vRo9^`Z_$7ud-}2X(UGN2j)p=2q}UVU5Ap?bRCcW3m(1sI#?6{9qjjge=g?$3PDk ztm^fn;M=+=vOp=8UgY6Gd!F)H#z){;oFVyG19IsZDM|Qc9NLNBBqQy znNN5@bm>}qlfa`-BSFbxykIu$4caZps#bw=<;*dZc0v?;(;(NVN`eY1^ey8M1YN$G zj<1NotxpX6)Er;o`Q}E`1A3a*7y6AR{$WTtt^>^$n`Q)S>a~=f@>uF=IXx3!=n+b0 z@K`yjDi!k)~~9)U89I1j5DPUV^PLcz$v%P z%FJ-(iq2WVbDa$V_>cxCX3({pUufG{%6OMn=VpfIpv`q`WurMW6GeB_uI)?*?eGbl zoFOuLlU;wqw^|Ye@Gg9N=MFLjYMzNN30H3-k;`7yp>_#Owb~2wIMFm6N7zKJT?BIC zE2&>&c4(}`Y;x}cv#4%Uz<4*w{1Yc{UYQ*BrutJLMYM^p=B5TyAbk7PU}|pktGTIp ziTv$T2M!6S)PfK7uP>#sha?}6Kw6`k5K$k6g>uZ$AO6$V@s$pVKdOw9^bho0&**RB zp9Il^_^14uVhxMJG?b)>kK*?93p`^zcCRRAJ+Xzp`n=^$jPG}T{zpGeHOz4#gAHQ? zBBT*ol$ZzyjCJtxkkoYoci%MvV)6cAaDRaplvcz zr+sI~{Eq`dI325B-NA^VV=evxHmb4n1f!GM!-7A=rQCCJtaPS3JH!zIYV^dZWSVXRIOf+zf zaHOym;rfvTC)b~n^a%eToebL#!*SdX2YqqvVW@_D@#T7v%;#pjk!`YrgtO!0e@h2V zjHcKV#Kt77idD~wS!vMBJkm#wd^tpV*+n0DHWcvMq%kOQ*gbC=*IeF>Oxqyn1k|qF z@d>#kgP3IwVwITEOuN2)Scu)X4=a`9efyziG+H_O?|$RUtE|lVOhy4{oxw|-L9uMS zP3Fs2%rq+`?8nw;p6{7xTZhX*#ea-xx3 zcO<>^ej*RetQx;<-6-w)95z*_@!owkp4oPwd&0SY9wsNzuU?RrQsEe$P~_FF+ReRY zLQU#&@p$cox}C)IiiWi9qe(_Crtt7S4ot-K{N3Qy7}gDnOBcKq=0h5QNtSSIW}(Zh%@HRn&eStqrSD zC08nS&5%+N%4g9%75~!R<*{8BjNVxZ$CSIjE?Q*`?Y@CeNw%M=&5ULkS51;Wx#prC zySg1S5v#@s58cCJj9@fBB6OmL?jAnh*s*Yyh4uek|mxG6TRid0g2OA`pcBk>n-ABU&n9mhdpj-yPWx+ z4>t!kZP5BAbT>T|Q=nNTXidcw5z>iOC6+7-W5YhSwSXVJ4zglLOFIQwrR|#AKF=!U z2lsp>S>`z68LFVu|MOWz9cn4b?#<(r1h~vLB{K_{XUQ3aRgfDlIATh4Pe^0Ie!>m1 zJB(T)U$x0)8Wg_Go9CF!EqP6Z5|q0di;5G*2EysWqd2arG@?mp61nl=e5BFSS864YAbD)Z4| zPARs<$I7^Fol9A99aXt;gTcvdxK{<84BJu2aiAQJy5@gH*!=FQ^8FGBwdu!3)Ov4ECb*r zt^}Cgc4jIxu0Wd^hXdX2H3-pqF6&~`wq^@ls6!sX1MGp$gFV)%zm2wurNI=N1=RZA zgj#|FEyIrP6wAGS^e}p&^ZP9_g2TP0Mani1Ec3YS0!3qIp@6PaqKERCs%z~cm?sJK zUZHCkc`~9x>{tn*4*1q%hbg!kv|N&d`pv-_dmI(gctB$6IzyPL%LJs+h9s%`fC$i+ zs{jD&k^{lj^XipIRmx$`R3WLd5z6F=Y5h#oee8 zO5ULuFszjPybgsc4#!jboNKH?ArWLdMzblCL(I{{^o^icVPVpQZQ4o8obv+bCq)i? zTn`)zu3hKo(W-TU3B<@*avhR>KJHnVEX)lN0j%}ZyE^VU?GWt+ZeM`SotWF*!=%G~ zvN;^-#N<80J&>^%$z_0#l$0E+`?AT%#|a#!P<1AdCdY(ZUfcFNSGDE`@O3NbM*_bGBiy^BbjC2OL84sbC% z@oTEunjX`2lskkKaZIoQ%cavG!i+DZvNb@z9Meqc(qOSGKrN~0*q~H+SqPC5Z}}dU ze_tjiihoa+IaeC~+}>0l>O?!e2%AycZ)3EWw}fH=LKKFsNlGVU4D?=PbVDBBIH1V_ zmU>TP@2vfR{Ac9WTBX7N=H5U||wlI@|UG^n&HhQjaJc|sDcT!+b&ze6N`EeS}Vk19b4Xu|>* zwkq9ciY}#=yKV@}u+b}|FPXkzv^yMG8VAnJ)XJ^ZgI;e)2qpp4N-fc=94%3xHy+`y z#evGfHOc7w2#wi(VM*5fNA2IDGhW*u?TlINmc<7z)FvEeG7V{t;vaeBpM4XhKknPP ziK=!?>kwz0x{4+-o>%c|Sw(gDi8B>5WV(6-^S#IO(|Cr==x@A!_=nwx+0Ht|zx>F# z4}Ik8SV8}5&$0)8aq1i2q1ttmW6#eWFS9>n4`S{a%$baiiZOM7refz^)ZtdlCGSm1 zjV=bA|Cp6YMZZnJT{C)iW-uPHdYkZpet`KLs(1Eqqa*UA5A>~M~ZE!h_JE0z)XO1_XtiSg0Q#pBF^)WNb zF*Qukw&XBiIIoTZCb3$q$a!^DW;Jmetpn5_{>0aENv!zC7E5)|^) z8ROb7qLy7r;t9K^tOw)cS4R<2g16}Z=*$Dl046f(76H>-xVLq=A)OT=d^iz;_fV3z zo$FpBCS+=Oa^{Q3-e1H%N9-Vx+I6K{EWAPjQTXlI8KcTwjk$E~STqH_Qt_B0sCdv3i zpZWWrOa8g%-rZfcoLT9V(L>|KkeJw;u@o23nlDMUCmL z^)GI_r^5o)>ByPFlrtxvdlq6~=c2^C5M3TMcC|?<;wmMiw~X9bAtLIyA!lM-UQE2q zKGki&kllf-R*+$uNT7DR3zTLYsW>{m!Hq1rcbHz&cQ>?6TGOhaq`**Ch}&MmPaV`|Jukg~4#}n2TcA74^K|W2D4VOSMr^b+0wO;t613U`V)Gn4B{sZWJG8WJiAB8q64GV0 z-evhf#$|1NK_wHV|1K#pqJYVYjR$3XC>5^Q3{z8*7=T$m;i25j-<#|9T}pUF61Gw{ z`u)6)O5G9#PntcbGB_*TCH#w>lc>+ZE3>cd^xS?`D2xdGr)YG1<;3(HM?R&U?o1)3>GIKSvZbP z@xOZJ7bbt-w=4#aRR?WF(x&7}@Z#_DZvJbT0Q+Z)$bL-UZo?WafUMK{GygLt(0vLh$X zl}5U;u*j*+a6UK6Uv}CoNV-4aiP^0Q8=#vDB&164 z@5;tCQ-W4(od7{@V@o&+U)pphhfyFn1cdxBoIr5FdyT)d{%cRRnZ+qYm6=6c=F%Nw zjvmA9F}!JnMJLW5J8}Np<>?dW3(?6G39?+~?q)G$5``&m{_4Lt1wg!e<*9+rl9cz*2u8NGJ8JDlKiIyaU{V|M&!%_s#Rtt3p%YB0_!?4R$AP-ncYQVvO9Dl2p-aQCM6*AyzPy1e*c zG(P5d?E^sEpP{6gN&<2_0=%YmyispS%ebNtXdjd2FIaX_w zNeK$p>m0aOZ|Kx*p+-7!lXoZYX2M%1sQv*GJ-ciI3+F-s>?BJaHYeOm)0IIjOAXQ+ z&dzS>O@BChLs}i^)O8LnuQ|T)PxE}^Hw(k-@ysG`wz`VHOXO!!1cqjo@(!d6&j^!q zQow?Ok9FEfwJZ(UfNKxE$L$@ZdP}TRn6`pzEkG;DzCur@xdI$*8OLu(#jE2aGr)nw z3-qse1n6IA4J+gSIOp*<9Y3RO_GFP`lwuF`B}kz%-`i_DTUBfGQ=dDMBT73*?^0w0 zOFNu`tBgb`{gIKeI7c>7m?>KVgPzuTcgRtSVBx#u2VQU0C!Sr+0S%YO9XvZ#vG>TV zLRopjTv;VQ8yn+{h_E1DWE`4Uo{*>5E9y``|LoJBc{#{TnRty2XhMJ3upDAoT+wC6 zhE0%xzu9gxPneMmRWTd7h^~ZvVU60GNZ^S_*D*qJF>wN%idu6jMyHmzfD!#zDu}4} z`~4n&qd?+?;lkk9_Hcc;J<8CpSbjFwpQfonnu%J)w82GY$i2Od`GfnQ*{h(WdrGsG zk|AX&!=xYxUP?x8BA!W~8Q$zn+l9wz)J+m&Or+DMMa=5N-egdrQkOmQ_5_vkhH9c@ zY)42FRZK)6@4=OQhiU7Xa8rngKZwwY*Y!9mJSU74zAM-!3~Lb2FuSynsbk=}STW?q zm+oX^&M6N5NZ5*?Wl(1Fir}v6NJqi!g=ThUmASXbn1lARp__+vzf0>gZ2bKoos9`F z!?|TIXD5caoM55?@9&>rFBiwNm)9CDWy}GaxPUJ_aq`0}{0}$2OFDzY*GytgL9I^c zOS=WPzi>WQj>~$1k@M8F-XXX1G%rqL`Iw^#;AGCM$G4u z)DxaHSih|B4CfK`-T2fP1ahJXM#!4cq%jZyjO<1%JSQ?Tw;^uq4neJ4Qvm?bW?bC$ zZH|@2kPrhUYY1`DCxRI#@cW#dofA;y zq$p8An4+QcgCgjSR?D~d9xfLOM6^zA8ewzPTOhenEFc=m@eL|RzwH=-M9`qjAN!z) zlT>2$W@4S8L#b3ARVP-`G!Li3gkmT_=IR$T=eYhID)KMvmkR^f=NLzS*a2XXA!kEVbkL%$YiVz9* zAsMnMR-patvmeR4rHo2DQGPjrgiLfcSy=K+8awmS-fi_S`iKN8_kiM{C4|8!ahnom zu)lY9QHhL)c7JXb_J`ETne3}uxvb9i#3(uAU!#tj*_heyy=V&{&-6Isn|wvI(u>7E ztNJ`v{mwz;GkWTPG$`sDli8$H#-lDrZDoN#KUd@l4;$87u-?uj7Cl)D3tvG}-&7{7 zjJDwVyjOj%^BVE_@ve?cvp5rF2OuTHGfO_%iMiX}R3k}0zKkVN9GFV9*T$cDcsCAuGXX1$`C~^_j64G|TGm+NjvZI{Tn6m^Yl!dg~m2?!Lf(lO}{2x>H ztK$kl3#p056-~eJ$eZ8va7-R047@l}Ez&E80t=i8xM)=)M8e<%jn7bQ+&F&ak(m!> zFP#n|bhLdOZ>S3NkPxqJbY6&A&|DOc%CKxQVNOirmNaRqf!$_(>#}9|LBn5VE>$LG zQj*FLB`Q;hOC!s|A#fSgd}yrY)zbioE}YpCs`MqtdG!&d5Iw5s5g6^l%BNdX6c1M$4x$rRlBKDfr-AJdnZ{1n1*RsV@tBHJQ4%dL^_lK99u_|21@2c+)#*Ex z01CIDp{d0jDbP@ROI);^T^mZ;mlvUr>b^Y@>&8h>SImhUGUKVfjbSlj_W40&>P!B! zX5=%a0HSr1{_*3l=2VYXMkz@esPFrP2HyorgoXv|w95j!b&EqLIbR!)`SE6kaqxtA z?La^A#IJw!<8jPLl%LMC_BWk(oxSa5QEUU)*%C1uv7k6Jm)s@kheC{(VE2XgHm16Rz%hw7Hizj*u z@h^WBZd^W+8_hBK?txw;_;=^?oAJk@ZU^I!Z&r0fJxZ}%DHMxyN;Q)EjeoxzsDy^S zcH23j;Q(GyB;}51n33@+rnzHhOGs%DJ<xW`l!4Uhd3M}Pe{fXD84RRt^3 zP;ocg^ToGPX5^s#x}=)JY1Y9!cIFdtl&NJk@T>AQhzN2?xqo$wB`$X4sP*QN^^N*r zJqODMGXoR;g~80+VE*nYX9@>NO9w{S{6`%ufNq2N<(cIrVJ98*=XEip4i3y9!E)DI2tDc*i znbWEVvjdhtdoOSw2+GzWs2v^556J(KJFq&?{D;+n%KUAH6Mo1^EMQc^I1>pa3g5)V zRAr)88{G<2N%d!$tv=lp9qot>D`8_QtXsC&XQpWt^iKXsvL@ew9lVy+vnmQEaT*16 z4nKiit*l>DuBj|Rnq4tT!HwZffDr>4sPVP*WKxUc1|y3tvG||qpw-ir*u^^9=bzlk z{9AM`y;OvLgj2V4$fzO8R2p7TTxi1z{`Dtc%DEq7tCVfJyH%PDllBke?rjJ|uO$l> zwH#F|wi)k-l2G%1|3vTcaiz=8%Ry{RgQXF0nB9mOY+;2(l0vB zj9S{mRso7*{cw0RnEGKTJAEAO(-rSjdNE$Q7!N)>9nbcbW{;|PXkFBIKK-LvFWnhZ zmuc>1+WOTYjYqmkL+X}2`0UZ{^y-lR;OSR#+Q!b1&OmjKtJI}Eec;(2K5UhL;8TA$ z>(e_!`l3(Wyw@s&1F+dOzHM`A!>?NV1IOL<)J2lMWhbnZ zpVI?*3*A5xb&{{S(r<1M>v;3!x%sHQS{;s%0dC;e(-Z)F<#WG3=PFN<_1nae-`o@x z#0x4c1D#o0$o0rcptErdqfj=e!G_1UfVG1A?|yDBdzDC)oWy#A!0M?)o2_68K{`>R zSCyrl!uEP^2FHa3$KYwv*s6sQE%h~hiLiMG= z^DtDe*g^$H;Ace=KOJn3#G|nWwbiA&VD81@jXIQh+gbDNSEt*4;xgknP=A18-=41E zqUfr8zw!i<6RcD-lZ}LgX>RKL_SEs~;fl9MfUy)Ey<_YE5qT5CIWjSjeza|4<z6$N?cbN4tb$nO8SO0s)t3A?w5W8K>~3Tv zh=)UX!X;~n@P6R?yTj95bV@k|iwZM&{=32z5n?|g*h?`gRcYc!L2htgXzN22VE}Q^ z0CZwg8&3Q0y*!^oMiYU4fB)El;?+UJ2giA)SF@ooV~F9 zab|8oJeHW-rQWg-B-r87i5{yjb+RnKuK}IRE-UkzJMj>y6MZ+oFjpD#(pP6fgTegF zTyKeo)z{ZKA$KyXwWyQcY@Sd=Q??UYoPVzgRR{sBnZ-r3u}l5nIfuQ)`+$(AK_?4K zTHlaP=HyA0JJEOZgT?onP=(O@n2}CS(XLY8o*iVUt!hzbIjE z7^~8|`MIU{noxz15+=m(#@VUkuj}V&jKNyMG$&P1 z=HGt*?)j@%Uwwl`lkNjb>aG^;LddCW){L3cN)xHFqlOLmwYnR>ns<9JWY$Zc3y$&t8!1C@53;20GQ{G8+vE^0@v9=x`HV;;=JVWEqAupKm^za zo)q_#)_1q%d8CWP1)KjVb#4VETd)7mDrYD=-2MP+&tX64ab<>+k&TcRRmBU6i3*+> z5L>m7!+lav5FGGo%9oT_)Xcfpy>2{OjE7xrTU=QMN9`7u2|1i&c^v6j_O@&~O+V!@ z4CP%Svx9Oo$@FFUC6oZNtKpsc77S7|m;i})2y2UFC&t)(6ymQ0Wt;n{o0|*I-2VJu z%sg)gakUK3N<37JB^G;m@(wBG8D0fZEy2J7uI`d6CrsVfSGO=fhnU0ZRumdZRFthM zDF^N7fqW!Bd3|$tJr}%HP>9@}rB~U2XT&2$_C&l@@TJi-+&~skQmZi!8|u^uA+?Bm z&FE(390V7`>zG(Z2>V*VJWYzCe=KK{xDFXRn5dauyWxgdk>>lngeNk0B^3fAA8%F= zQXNYm1W}U>yP?E-xM_*BNR$YYAy=la=;9QM0X=Z9fYvzijE%6JLR?^vESGi-tVG~< zzVM5mn~5Wu@wAQMfs>DrS;}_T7$1-X_BaAl_izb90@VykrZL5j?5Ci$jEQV5#S4K7 zQ6V@Z;A?KrtXy_y?@lhZ7xft(-(#U7Z`6M5bT&S6Pv8WqG>^sg5TMUV{Ez?$Z1P)E zhaRC&@r%hyh9!XY&k3l~xIB;%`(JzUuRfd7*K@$|ehkD?>PtW_^e%oX$w15&KQHu| z4&;44&(+SLmh5$&*jM~4m3l=-=~%+QTplv{tIfx(B^$Lq*KdE}7oPuy*GqbpoTII_ zCHe9Blu5q_)sY>%(47w6C)aVdKkszblMx!Rds~5^K6NIXI)h2g=p!T#fhfCVCqM!% ziFOk}0y&Z|FEmXjl@kVv`*;CwEYgHXK^h=x1>&LBz|fr(6){tGt6dVC86n$*tL|r4 zI8>PqI1)xN-aKwjF%1_SVs$l}M06S?AbZ}&*%3v;e@sMF(@O*@t_)+p+|3-~o1mgG zZZ$wTI8%r&jWQGwVRw~Ktj%$7^w@NoZ3nbDa3U#+VlD*n$YQ^rb`UUXZ;)GecMwnI zl^~yC%|CJ>MXR)9F*&>>+u&y-i858nH^t`>=+!CVcnrqdr2+pL@+pz682A_6MF;Oh zL#!d{Tn(P9U_?7bE7u zMlORy&}GSSQnSeI2hHRLggaXPK;u5sHp^ zR2umlB5Kd^st6MQ3L2j6AA@m(mFo{%rAQJ;n3BbM=|OC0@0zLj($+yeb8pr``olgr zC)r5$MM)E*=D`pq&RD6KFcy%igcx47x2N|=`@uCG*IM>ZQn;KNz|#;cVxM3+memdT z(kK6mv2{P$a78}guEXPyX_d)o5~qYmplC)bHQ2{cSdqXFk1w~OQ1B| zTo)k}cEcguQW$~m37m)dP9<+hCX&P-@s5@;isx0JI~&CgQ;Qn}Qy^U_s{>adgbQft z@N?Yl=%(|dEiR7ZarTpLsR%_vR)N-{SY5*>KYcCh`-Req*UO2=vc5foUIQigm{7`* zheQ$$RK;n+_kq*iH1llsL{ry7T=Ea#cLr0P0*ENvd~PRse>uW7FT3M$65eE1UlOgU z6c8qUQIBY{Rr&sKQ{r)JT`J1_I^H16abds-xD93tcY4Oyb}6t;?o%apy$L{K#zbZg ziL9DCwmmr{43Mb59@Q1@zJa+QD%#|+W)^3c2mRS^&7V0?9fuKF6vn(ft@itq&K;Q_ zUTuF`o|#`*n6>IGzLs#_pT~Hdo?7cZy*!wm^BF8pqq>-#&rcKBRbLBIhYmvN46AW&B z;pct>SigB`H{#GU6TRoe*jG6C_54l8LP{1EDj;=87Fe}%#!i@(FdbGp^9^zBwR*JJ z_J+X2G9b!CRZVic;?@ffk#q~0p{}NoaEI;8MJ$KTwP@e8X`eoip)Z*xLT5xP&86@A z^m5uVV;b=lg{X|vw3y1|h_oazZxHFvv1jCCZ3ed{8Gg>)LOf<=Ul6@J;qY z#f%XS*c5ilq}IMOOj1S)0`0GC!U4_fTiw>0n8d;qy3ZwV^RR#+aVJ&{8LhD->s#`X zh3LtSnKVb0aNhdxpZ~yz;-XKa*4zX18zecds?_G0viozei_k#wBQTF}y%qbCjHJ!5 z*EcA4-?$-v`jH>V{@qz~mdaDtniKhlG%$-Qh>RaK7Y|ou!=?O>k35&XyvLf$wzuI} z;$`YMOw^HJ(5m1%8wVp9&@NWnTG=r+i<4j%bl_dE25Y9geksf~Y=|dTEYrnUCk}LBvEN^u6G#~w z5BY>aY|yjCProfL&(6=yp+hiyx_{0S$4?2GE8TDNr{gt;bN-5dSE9Zm-6@b+0n1xi zqo1|;Ntcfz-|dpV|G=;M@kFlDNPk?#_QT`f9!4GA%&c`dJ-0No+?U(T%#t9`{dGVE zG*Gzy%94AECKqJYg?hsxBV15#D2}mPVCh?)S+s1?`E@YQScnGsR{?M^*Mjao-S*1k z-=ID?E7O`b|Ml?F(;^L{1q^h27%a@#^wj-ThF`fs=3lj{{vtEVz3I0lgC#*6$4i~3 zMa(Yz)BSbO!zr@))i7EZi(hUl>bZq~!`4=UL1wCk!@?9Mes8rfawK&3W7oulsht>1 z@YwH`2R&he`9ir{2Gb`R!M-iab1}W~fWQZCk?*v&p3Uj{s;|EMolTYonUG!PsM zJLn7Jy&2S`Ev&*b*Hbc&aqENvCd-Pg0Zao`72)>Pz8+TOS3!$Ji2B@4q8wn}bOr1Q$@ zHC!qRRuongf7o?JGu>qM22Vj(vB1ov%7HDo4D*}CU?I;(2Fk|EI@(`;_^A(kF!;*C z_>`%c-!8nKtgsDJ*KnlcnL5aHdylrasAbQifV;U#rB7<4;kNwyu&`>r$Ay6-(q|hHr@UWbnWJ^b=2|;^XRN#QAfj#vhBqzMC*!DO*sPj5a1l zLF4MNfBrMOpL`*XeL4@~>IW_2C&9cy#8%K6LvR|iUZOj7y#M7hlTWAA!1AnaX;Gc` zz0sZD^V$C?XQUWUcLoTPhhfWLl;RA(qoFzD#X}Jd2=Q3Lp|Zz`Y+RSJwL)tg;b`cF zSzw7q!aIFGhJc6%5Q*VG@wj#rOOGEUB*E^fN0_%k5BETt2Oje;{9kXuEYT8dHf8BW z>F!r5x_J7v*Dp^~$WjRs4}>yVo!KdhjOWB_AZ^ug;_~LFk-=cF%392vtJxzc(!1`6zqBxW=%}k z8~{UU$fsbyhQrrZxAUj|-PO2MmPHQN;%1Q&bUkjDJ_LrY5{EhuS*I(W%<4qC;**)y zrN;C0hmQX8Z$OOKqBykkVcgI=sD+g$$nAX8_sS3tXY2ePW^;_yVJGXbB$YTdN<>zo zSI1@;Y*Dfca6`&WK(=)Xq=F!*$E@#$t@`5XI(c_DZhk@GD)3jjP_yxNVg=LW{+ZRa z8II;H@&`{1PhXlI%q=WWQCE%(rzjR|ZpH#3MSA3igC`u({@aMgF(o}pVd4qL!B2uD zAy}^E^AL8@#zQO7xauI&afQ*L$I_x8ls3(I!=Ry8+T6agZI|u!9kRyYuTe&8@)RpQ z%n%DKrV6UT*_eNO;~KnOn9Y(#kLUqe0yS)8uuAg|#bli%i%+&_dLm&fp$KNP9if+k zca!CW{9A^aE`gm!nHKDE*t(h&HKOoR9TH-(DjN?xZmvs%CX0EABcw1Qz9fZMC%?GR zxz=3XY#Y{c5=XnXScfnMU}y&e<_xC30_tV)7a#dVRu}GJ7RP4=n@wW*QBZSH1!Eld zTp(~_^sU#`3c>}4)Pr*NDTxGF>J{n^!v~YKLi~R6>amMYbwi0O35N)kWW2Ob`%O;G7adht$CQS&f78PzAxg)oSRjo&c2OfY zMln{c9_yoj?5yrG(>6|(rr;y6#H)tfxz;o{=F3=RN>8q4MUB2G_Y~!+P=Yk!=LkHy zg^dBiS9emtjMJ9e6{UdFrt*uTa?V&%ap|u<{!Gr-K>telBGa{o$}*&k>=%`tm>OtJ zoKrP)68@$+haU%{gr%orE)o3kgt;RYqnbOB>1^#J ztfNuPFF*Nj=7_*CM_CZ8MwfS!<#N_{Z(_#G2CcvL0AXOR4s`(CTFM%f(3+ zowV^^Esf$x9Q>Ui* zk-9;ae7jQ(`gD{0ddw@4C#6WZbY~4sdN>=RXDhe>VIga{FPoBdVTjVLomdUB6RnK4 zx$nbfN4DiG#wtk@Z?OGaI~(tovnW)f^=VB;dHCg>E&Q(-5&i05Zicvz zsxL87zhut`jtlu@7p5aw~lboG@u%0>2rAd8XBRP?GC{v&}IC^qBiD78QQ>v13&uf)ROjj$2>*-xsciM{xtfB zE5ntyHbm?@uZufx?sdLMA1>Hk4%R)tzKe?{w>@D8<@lvB^QWxnl|3lLp*2L$85*n>O-2J3h zaUgMclIW14j+LuzZW<`0Z_0%AQyoX|)ND*s zYqZ^XdW#{5ONjPbDf0O3YVmG8y+)lm>Oe6-;^5*%U~s4x6U@ z9HVNoey2&tt2AxEG-x=WA9?9lo*RTlI5&A;{{{!Ntn>eZcP#aGVQ=FO*~ro>+&50? z(^&$}VY-t8-z)}ia3_q(qA5Xdg1VrITbdR0R*FSgIyc3^+6v2NC9P`I>(OUw_1q1M zw0o+57+T#41yJ85>$N-t6p9)aUv46m{n3r&f1~@m=0riqJiC~px?7wVDMtU7Tnw3A zzYj_!yK$$R+^qpsadTJ!RqZYp#{p_E2VswSi(tnr^p2M<1;vSX0Ocz+0L6+H6g;X% zR?qt11gN0m2D$%4cYRh?0VTLAxVivpFc79C_zO0IyBz?g2bz<5N`S)CV0l@l{sO38 zUqqJf0#MAZ+nu{LpaPw>#0sd!f#|e;7{w^efPj?l*S8&Wxkt0xgcdvD^8&leJ>s}aP-An9}pn)ODMob3!&k|-uyEedaI8@@vp z%{GKfJe_T2sErr`b>p2iWL-H5A{%%0KUNf`xl28)Cp4|JfPL)wQQl;Y)+HUeHA%>{ z8Yxe^YVDg+w+AG1;#0O(Q-GG(uT~Lk$5xd*OJ7dNx;1D>4M!`JiCs#`*NG%D+b-~s1P7hu&hB0G|B-0iebrfvb|c`_ zJsZjTkzGC6!M2fT@|8pB!y=-+%*yfzft3~4$4kc``-s^7R1xuj`Do;rgl1Jc zn&VZ`A?^{ifpn(qX4o7kn~=;{ge%?*jepYIg8vsWUL(j++&7|7q=S?i-(`{XXfi4{+aBo?&ZeF@-WC&oWPhUfl&OW0E6=+Z!21b^XMbrmmSqf zO}u`?W;Gb06f+&ATR@U?U4I@MI2K6h=44ev$kHO?{Sk`x*Xbk?Bd;lb}SL5>b%hoc@DOOFc+j$WTSdSmM7Rvl;cBR~DYN3uu8 zmErXDsp%V2(=MTxN{wMva#$C0HzW>(7_vJlNGpQ7vPo2gb!Yn)P}RofKts}zhwm7` zL(v^{if{n}9l>4EW~tEGG$mc*IHv5~t9v($DYtjD`)ri)Fx^Fkj-+{zP>kal@M%NY zKK$5MKKxiLmU~(?*hP54dR;9dI?XuUOcUCduw4W^$A;9P^&ms&!Phpg-60sG0`<>7 z_V^a_4ca59O__ie(bM2l43D4J+z0PZZMbS z36=vw5%3j2!Bz!bn@}_+n3>0a*GHa+d5`sRxphNw)kScPkVKusOYXsdxL8aX(zTRS ziKn%pI={_`Ij={5n!QH!iFv%D${)%${}%O<6ahOyS&+f(6t?)@{M4W~gf^c4RmGZ}UYs$n)LRM@LzL$J|*qR*4x!Lv+%Oja;- zbio8wjv(<;Hb{~W3{ENoL7~=wiR&WlpP5!|%xjUQcE>cx=w+ zF6Y)Eu@jM+TwZvtyd_kxykA5lGJ}ja3hpSmc}Ridn>SreFVz9?PAkndt^1H`@~B^5 zGiMG%3n6(zJ?K^6&Xu)Jlm99|(OZzBSFfZgde7Fw>DqcYC)Kl>>g>cd2t%K!V&d{m zWfe~kB8cDyvL58qvjLuGa$ZSOJ|Rv-kgt=nUtS0%jqYm{+4e^eD+?dGLKC&Qx_K4K zpD*vgzf;b4{N>2dq!fUO=;ENjJ;TX;+vgdJ7PH5$uM8MUTmb>miZs1~+&%@&IeC(h zJ9X>Mm7q5pO@E@FDNISXvE>rHBXl5~cgAvs*aoPvLw_5Z)FdmpdqHEf1(+*+#xA9p zS#RlFa?~~Z(_9XGe;;2YfP&Iv06LiM0Muag zx$-+7j0PTK07?goj<;da7-VcDpaVO%qWT%kEQNDyKyM5{)jtUzcixO89MbFh{R+3-k2!haduabz& zAju}55#N<+?b{pgkIH@(-+N|b=&62XW@`9F#68L>&m5Qc-ArW` zn)*Q#z2&9;-h@qOyZl6HC9<~GTbFjHg%Y8ZbU*?|IXuu zQ`5evVwtjtDU{OM7CJ0mV90ocCswd*Mtp}{ccYk*FASt4^PzjlBzBk-bA*2uV%LcM zN?U;_31N)_=oTr&=CclQ81{`~X8UE*IU9lbj`pe2b(_t~?OSLGK9n{x*JUGT>JLw` zP%YpCXReRUFGB$g*iAMWPW94U?ynHpa-y3TYAQo(5*9@J6JkZwJIaKXvN$Th=~$x|2tPsQIf2(EXk#;e3jECd*qT`AsG z$-NJxmE^3mn&E6jRICX3xIn+COux_CQ-)@xAmUTwgr@ZibV=pr5bM2LDxr>zI#`a~ zjp^b~gLiB7rxES|9l0~HWz|)y`swVhH;zLq_iGlv+cj5*S$q^XU?>0s``mERB_}VZ zf^&^(Lm_o6T+{WIS8W8uj)KmF9hPd<|*BGZ3W87=hR${Mwn zmO?)ucSDyM+2<0a5?M2tVUkwC79~uoz5j)$Kb}*o97O#z7bzz;*E!entz>J%Ar>Ve zUnC}z2}Dd+aGNB*3oTM8PqHqcl^MU~)3zkd4YQz^hCi~gFglvU8J=r|{j3*Rt)wYDdT#vB7* zExI=LAkxA922pSFiT~bb{#wqe&Q+y-7W93S`FsN$r!{28mmN-*{KiEzOem}k0<3#? z$WM)GCPv6GZ8*_mpZVQ6c*XS$?7dlVVS^TO=ge-NBPYzFxo|Dh`|Qme9K{6c$4zD; zY^9^iE*)MGrAeCJDf^eIRJf1&^ndvIfA}uh8Anb&Bn!<>kOmYhp<)VF;Lz!Y_Nv*0 zfBx*5TzNF~s0uC=`jgTlD^yW1n_&QNO^cMVfu$y9rt86)ehb*Bryyh%yME@mhdz5W z&ZTCVQbg2C#b%nrs1xoNa;B6g>Da)WMwNkuC|n@VpE(iw6p-C$f9~WPvWO2PpF#V@hC+u+4y)+sy&EGJ==|K!$jycQ3`7ED(|A`YZc;c3QYCT z>8^Ism=r8SQuYQj6Y5xGf1IMGoqX(jhG$lW7taqbTpC`yICLFiJG)MaWU@%A~gjNES)N>xL|bS!@rmn{T+aJ2s}6Z z?rj(|nv3QV?lYBQmn(>a&NW4ugK4wD)0_cWi7ITen%e|S5f8iM$`bi$Y7g@a$Js_= zN^~S8kj!oS*WmPS1+R(*)>lt6njtFKa>GUt$sXx(#9xNNFEe+TT>&8swKV>f9`--_ zLm&D`pmQzWEXE^9V)*k-<6G{UTC0kRQf#kbFGdP8tIp3g%Eo3BRT8T9iL8Q$NiDkf zKcpOSWessaH9U5t&XkQ+c3!mfFsTkO06;8bo11`t_UV>)**G3IiFN!urXeY0)aCU6 z;s`2>7mD!c*jS)JM2D^%qyMgoW6GfJy(vt*%<+3-idAS9gAW_$CgtW4n)n!LSxMYt zy{b#CGU26uF?$GCrw!a+M;N_kgBG(S=!dQI<$$#UZas}54Dt54JZ`%EVx%&*7`u^m zA4WaW_m4mJ(IdZ_-d}&5_Z-O+uSe1twzfkwnh=hW^CAspO0ErCADm{(>r23_;xvFs zXs^&DgzGGxl2Ua#1uQWK6J+LKmP_6f>SgfOp!|>q${q&H;aa4Gh97UV1h$H&XW@pS z;`C)`-rQu;ffmTeF%Gj~nB1qbDUrfvE~2o#rpmzB^|?ItET* zh7HC)kGOHg_S;)qcgQ`PV*hmN#yuM<07K~xL{Jk?cV=&Dmi$l0hL}duzq~^fg(PfZ zeeDs?aQVZ>o1pGZtmfTAdE~-viFhDu<~YsItE`#kXR9e6=Zbl7V=C8 z0tmA^M`UdSh6&Hud;v4d&*Z^ImxPe#182??efjPV^2f;jp4!~qyB#^htB{+7kUW`^ z=2kQ{LxkN5Zr2Jx^xY8BgvVAUDKvY!1hpZGUfZQAx9BX3M~KF9WuGDd!ny?zYX}lQ zSc^XABlT8*npoG8)M^j)-p015uxe6E4l^C5wl8iESk;>XbKv)cKtp|qclr=Fzkb!%!wGF%wmwgq?a&j4c3{>q zKcEjy2h&@m*E%0c2y0#i)c9uJ0deR8(Py&T#!RHpcaA*qb zvSRM_@83T1#*yJe(?^~^a{9<~N1i&;zMeSp=#eAOe)!0d@BhFDj_}lnjvP7p;Lkt$ zi_bmsp`U$F59WXMzI^`_J^t;=&;081v!9zj^1!p-eB_tz-j!oOkrtB$=GLl;IfQw< zS&|m;xEH|RcOLv_Pu$BY&Kx<*Dn6UY>R#1Sn@M}xpV9ogCg&4kXbTJN*QfL?qY5| zQ@l%uGTwC$<=wkvW3+pnTmv)_UGIv&)|B=X-q$%!g$h`C5KlP6C_nim$ z=A8%sA3k^I(?ac?hxq-SBmY7Oz`MMu=Z>7e*G>J?kNwmK{;MP3{owa#FU#wv9*ysh zJS~)rQ6BIp{K=zSIPzN=<>}H$Zw^8HfA~l~w)tN@{PT~d@6#w6;K)BuYpF=|Z#?!l zvX@Dk3D4BS-sC0kGP;+qlhVAv-uekEdEu4Wi*zBuNLnhelTG6`NW#Q!ymY~}auIeo zmnbs9wg=CrVGrf|N;<3HcG2POks(_A-`<*t*nw%dLWbZ;i#JisA?Eox6AC$EWc1gG}1hgNzwc6qCq?BGf?*>n0P6Se^aC z>R68Haz(7y(h2wGn)FZv?XR~6kAQP}iV_h1UD7>=jWT*TxXQ^%ck&jN3NCY$>ej8w z`RqE--9V06+gQhQt|12S-3s1nnPuA@bjy|?eFGpa4Q13FiuCMkTPLpLPO!b$j>5GV zVEfTcOa$R4<42(jiOEZ@akq(mGpDWnkEL3ZfSx^BL^iJqd@R-z&TGZberrb_h_~b3 zHfIKZFLQiF9pa?M5#V4ddhi+t@L=@uyMf)|z?ONr7SW6CPYVdwNJ^D#GA&cYyePP2 z_~W)J@2OAy2f1kJ?9>f8Eio-Rp&DZPDBzmEPT%)aA5=(;=Z71&*RuyE@}JL;5_8P% z?^Zsv$eImcq>yA&RTm!ENhU zqQe5MfD9Uo!XM|07Ig_SdvoELU^Paq>o;b73TJO%7~`;HWD#~-W(&SCvHqd980}+v zw3F4Z?!c9o1ClQPwYT?^l$I%Hy31Gh&>3sfT1DkQ`1~u+Odc^y(%z(B_xoT*sEu&h zN7hV4PE;c@l#ic8g>-t5COX=jDhh}o>LwzPHS;czOu)xdlDj*?R++1x(x>ymyp$i} z4MU$DCHh$qK!%9_>roh){DFVtQ~t^^(VdRfMLfpW=>wnhm-($9sdG(T==nUryEcws z?9?j#<1X_GqL(~c?vu}ofvG@J#(ls1izcquyEL}8J)X*c?`y?n$=l?^_Ur2zx%5Ke zfOqeOrF0fQX8w8r|Esii{>cr-w9NxEZkqpL(|?!7!;3k5{#_btpR}~-=OCV?AJVLO zDmQSS@6p!JPKO6(TCO{)-Oz#mpBEfZP7|Ve+cpNPjpuHXZp}P^FAL zT=@U#Ff;D^ILzAvFETHaW$D!{)UXf)GVoZlK6G9@RB|U7F#b!AWr{wA2h>~kWD#6TGbBhdl_*38ou`k`I{WZcNh^K-< zLXz-LqkN7z(BR^wnufb(xX@6XlF?~n3vN>O8!Y?$4zE%l2==HB?kDgpbPs--50&B6 zI^MjFw;ild)^Ow%x7^RdGgv2KzHo{LXem7*BKI(yw9c0e}LlCYp>l zDTYR-PZ{dWF7hEPu*q8o^*T&cwafkF2mj>*4+Zy@mS+Q;gn2nfNQze0J*-zUS^-$G zV95@pPt-t1;*!jEz&>PiaU)Qs417rvC>q4(3ApcUuo07wVhJN)BOoyO;P`|XVKcX8 z`npOqksyQ^lvRmsp`L8gP&<4INWD$cJ&M*lx)M~YeiXqJR-Rg`%-iiSq22Hr4|o@o zR5dp3C+%&+oyGvM2rWl~H!?=zKb3+n%D8B(yqM&}ZWy^_Uvkxt5W28J(eIaveZ~q6 z3;2RbIMN&aWi(4k6*&gr_Fy0Eo(a&T(-NnwG}3vQ=1Eu$KWcqX5;Gf-#iF*hZ(k{) zn*|RilJv1hc1qAPI<9(?5~r2vH@+*E;vDCOP$Ge&@1jlkmFQ

%i~nu;KWjN0{`1 zCv@!QQV(N(A5};Bh=m-^+;4_pSx`XBF*(TkqmGm)0uhGi>e*=Nmz}VZvtV zp*U&FIwwnN7CiCr`b`RU4zFWPkzsiITRGD+!+Lao`tb*H3cnL~9Jf7ch8DS~h$kbA zGB*YSMwP&~nW4xt%L{kK&^K71lNp9wQV7QC_&KV=;h1^gM0L5%By&?LVNa`e8d&y6eGYZ%g4QLA9tvdje zKP9Y0O@o6}BjHb~E30vswCC^WNlUR8bwZWJGMgA}>f zVcvIFB4{S8{cKqxG~T}ELeTyOuy&z~Q8H7`A&mm;I#p4&ICBlOfeVLIe{CK0k9fj? zGDA)iYYak=Tk@^fCDMUMHBJqrGw5J2OXfPtr*g_fpdC+85h`bwfgD&AZZ35rqGe1@ zqt^q8 zdmJug0E8)b!n=;E$fY;tlr|9CBSW31%T(WqNW^l(?5eI&hWF{4-kq<#`0&>z^nSA1 z06z2l)@P?$r49#Pu3$9yEyMoHwTV`BXn(_(U#?yL<>#L&HbkxNzE(D0S9Uos3q)5M zvYf1{P9&nRJV(7{$>)S|fpU#^^V2U~f3Dvy@?1v0v2%;fYMH;L`km23gS@X-Fn^?T zOH}dU58*d+A;@+^d~-B`a<69cJ#NbOrEnQcuvvi{PTb2ODa1ciuDT~ugq*mDlHfsS zU~P5%hHQSIkTmksxxDm#_=dqAKo9L?2Zg#gj&fPwmROyZ+6XJhus4+?KKSs(hrTKH zN6*>{2vRdsUrOhiyG?9utCx*wT~rKI;~@QK9{zAH>JjJ5^hGh~O3%&3m`PkgEvNJF zmYyqk9$NU}C7Mm!NHIKzTNtT+kfH+h){x6|R=~P2lGanurH7jQ(BCQ zePSIW>vKg1?tMi&YGH^+e}pf9kQT*$LTupzKv{&>chgfNT%K3V4f1cmAx}zZdE!M?nAL<^3sfWC=G?WLhI9}Zr;SqpirvByJSv8S9-g!!?<2> zKa=~F%xfp+euM+=9FXl#{kd%H>kO0o%6z+p6d6DIPds|_+=B%&ZX(g_US=5Oy@ z_EVKM{|}%3T#lY8*9Bm6*8fT)x|~XOr1otwoX80)NNtv-DsPU+8MVA0$Zk7tJ@fN9 zfF`Ynqs#V|D}`A4UK1jekF7RZ`@#YdDq4^T!6CO!&Y#zh^7-93~Hbh$x%cbU-8jjwAU)>kca)dYuN8!65!6unK zg?EIeB?-~`sd1wV^(5lW46#r$oX~7X$q?egbCs-BNIh5YT}9^@Jk9k%lQ;9lIf_pS zvDr!cQ*aNX191mAE5D+`ga)CA+up%9qglSa7~Z4-gP^gKZ~kfRkEgkpu3{ld?yi!x z-3^Sq;FiN&*@VkHmGO=1E#q56!qHzj_3F;&_RY;JXds*GUHdcYB60cr8CZEr7rs2P zvNt?BJia%1Oz}tYYJ@_4!DHG`jZiT=qeFx~A0tumjL3(kV7|pY(RXgi4ZtA?!ap5z zOtp=DC_*3lflO?kd-=DI#^xV?*S^BDUtRSZPV=w6{LD+sf&JC*>dw)>lndM(JQ4wb z`}-T>0!1j>t0lB{r19MY(99iZTg%;SA}}TK=DcYpM4#}hE>OX_jM|kpG@4@Ff_E(7 zf`=$Rm42RtM07<@QeWkpl#LtJmW--b7N*GgC`?&uZkO-=(0`eeia~zGCW`vu`lF&U zY&HoN6mqTbb&bYFrXUEiVx~0(IyC#yMo|o7 z`t8*8lL8_{Azu4KL($^p^>#W3t{?j)z@?xtOcIg|p*ip#ZIhFC{P zQgW(e@j-6a$dN+yspYu~7tfzMv#1&@>_uU9l9p*X@1-BLMMlZG#IWMDMP@hdG}g6C zXv;3~#+qjl1VlIXRd9nr0g8fPveJ)UFIt7+5LN-EnT3ZEnd}i-xb`+KV|Jz*P7M0{ zbJO|)X%k;67^yue&%T^L_*#!ARLW<4gJf#vO41Hx+%gNV0s5%j={|AQ)?GD}R?`Ya zOVCwFXY%>DdpBk;!&fQ`dG40*=rocJe4|#lJtM^sk1rCo*61v zOysIi`>beo85L+d z{CWdAV%hh6{*R1}bFckaL(k^FxvM<5(DpDenu6wjm2FOmYq)`caS$|N2}&MzVSjWN zWY`kxB%)GGj${tVEm!vhD!q6nY5mw=)1!&&;2x>GC;8__yv+{}pQnZX)1P=4m(2X| z=~cAMRi*TTw?hwinw=S=Mq<};a3r>`5mtYEHy6Y{r^D|t{O7*Ad3~(b>b|?_&AyDc zBq!%+qZ|wG<*X|m3&V?Ld#b(Sg|Sb5tw-k8303$$?5e0@*M}#*@*?L-zK_)#;=^z9i%!p){sqTyF13#Zzfs!&-uEnwSpO8m)d`q7P=`Wbtlx+AUDk4=an@C^ZjP;3g5ILS}=8Eu?~U}<9J zHAH=#y0~)OZL?Yp?BN}{53 zeLPJ_Yn4X?BAr()N^0UOIH>G3;z(nBmwZfXr6HSDTvMsF< z@PA=AhezUxZUOBG1h)ti4piWNFh!f>&9bz-z3Qy{dNga7b*W#wDGlSDn|nK3WT=C_?cdmVdyS+;k^^PvWJid4 z4y|L7gp!?q(;BRHUB^$g^~Na5qhT z(*cH&xqWB%Cfz4)DZ@!|6_VA((J^uP%dp|;9T!B(!k{7TUw~CW8wk!EbhoJJbNlmu zF*9-F&<8b(PC26pPusW)O>%UK!>muxrUc(JGMx&gzxM2lIcL$>DP}JZb-?f)H@}9~ z{9Dict;_8#jLHfNK-e66R>pIvMPD@h3p^t2;IN(aPp?M`&@Rg$ua$pp8vLN z?^n{47Nv}6u3!wlNa4CITxneilk^%?E2Q`BRnmN<9Z#50VfCNC@PB`9CeC=HfYiox z5G-NF8QFycHH7j6lL>%Mn3-ATmLt!MOT~$=yz~>D*2rtgg zH|&1yJalvk^BVz5o^5grlS^xO(ZoFz3`rU!YXaaxny%B2s`9uWgs9on#DD1-crV~@ z$q_IZI5U-bd~EW!eM6bY;2oDbaC;YX*hNfLN%|SR3zOVHl8n{8>+ECQpAUTS@&gYh zhPTy?o?pj#5tIgtVfd~fy9=e!EJB{;N&yQ(yd#?Y)y*xXhKU=X$qDHkg_@6(J5ZFa zgiA_Mr#u80&~wt7RUF8m$SbJL?j*bjWp;bGgrlqMw^zyi5_&dg--$z~tsgrNZ=8NA z<{ukj1SAUw3rOw3McDhJneO7~p zd$q1#(>%^~f(=alNIRX#!*H6@Vu#6kkB@8J#rlwgN5qTpyUshP>)06mS1Sm&@Mn%5~i54(H~Vj~O3+Q!>T z=U%|}ZVXyNMjrxTE_Zig1=6h+Ix%{@vh$|3WC`W5>~O}mGy-q|j;iUtCvF1A4HDZWw)XS#JPZ$JYjG3l9w{iSs^fv;^((!z*4f0;BdY4ynF^U$W77HRCKWj{k>pAW zCI?_dwz8x_QSbTo4vE9$(LIG)GoR(mJLmai-Y5I8Ry!34F9^F2XlL%=C?*4V*#0&cG!Dl~7hMShCVAGK+ z@&Q`=!!hrpNW+KBOs)jsaF zTSF}!LEzjjPjkt)mCSeVC&iI>^V3Vtp_+)g0LxDGamDprus*CcfD2>7!p zWddfc$V3p-tw}|Inh?ypl63h$Wl~^2|UYepfd)aB3r|UAn_F zwM%5w8IF@JTwK9^+Yan}fDy2kd2X z@~u_z%+{Nxtr}j#I&sNgYb|WFeK%gywv4L2yg(%?!0+nra0PHFK{&TEp!+SyFMhko znLxe^36#3ntaVtPE!OgwiK#M*pl@^nSx=5QKv3!>L)F54|MKf6FRu)#%h{jmEzQhM z&Gg^(`QiDqCtq6`PNTG)nVXtH8}}}qgDuBjKds#4x|_uRNl~hsT)QeuF8)b&>QB>H zIezi{rAs*4TvO6%(QD64MP%3{I09qC6n;Y(y_l^EjS>*xDGi4w&cAW4Z9AApw>-8j z{uFbxRbw&&>o4vddij0i2UhV`es!7PRGY-rNQU<5>3L+8snSEX@TR}6wc)hC@;>3! zk6#CVGM=B0k>jiQ*+H#Q_8G0CntA*=KNH_X)$iUQ8n?a1m{H|J6Q?YV>~W#H6!*`-u^v9$SxcG_;HV$;2)CCz1SR%0%!nsYCT zgShA{kTt*tsj;UW>r{DAI59P#)VtoR4lGb}*Na~Hz)~XuvBbuXQqj*4+1m zhfy+S5Ze}82$HISze>B;052YOrs!ecJDfHwp5ZvCaf}&%J+S~u+89qbp^A4Q0T?eo z(c#cDiulUhQ|Nh1f5p@AyA+Zoh`6DjdzBjhE1&&iPrsNH02g*)_Dc3(-?%GE8$2#& za84Ku@qu8-JPP4SNk3}uf9`XS7T?B}S-8~6k$zeVrBDb$dg4BBxM@i=DLWDDAw*nr zWI&Y7!EV$${d3RW%y+u&4CtNdPAoMvGRJb(=3+O+_FqwImqhke48e<{wo!1)q^+?; zwyz)(NM!;v)l?HBhOCve>g^s>^;)?s;+Cb4eSSngEs{;=jT2SQrc2?3I~&uHLN3>a zfakW9a`39yPgg~7&lW9NjkM5G)^q_Xt-D#@Jven;wJ`QqE$y`BT96vYT{@e1Mvmnm zLbrReZp_6-9vZ!m#+YIzE)cysIlN_yjPHPuSA@vHzEgjwG5}m;$1mcrck(8+MjFO* zIKekmnN!wCpES-I=S>IK$4rNh4^FC)ztD&2_6dJbGrFieZR%Q7{(O$7(oLC;nsJyN zLh0Lx#f_6>Wdr}l%M;n5-`TalV?~a) zAN_@gAAPr*M3|A%%)k4s@i!lPITzjRh&G{`7dxJP9*PrJN;I}Uyme<6_?xwr*r)9m z_m225ar{dczkKqN+&?Gx!Tu^_G*mmzbDLWsYjxOn*(_*SkgZ$^y2|%Hfd#vT?z@~ zyLg_g!5gYVjLYjaY9&8l@T{8qHj@HXV6P(fGDTLE<`MlXRTf!((}cDRH1s zH0~W}27oV$B?UreQ^~8Ur^b3ufkh|p;38k9Sx5QWli!)+tU6QI1s;0M?dmVwffo?+ zB3Qq(LbDN`VzDtgp?DqX$3Om09(yVvxGj5wtC2a|H0~76rY1$#A-*gXivq3Ww|~YC zbh>MRk8c{%qR~FAf*1!$e+j{y7)nP1yLK}kCt8? zGg3KM9p|Ks16<8EwCu$63DB09z1tEf+m(n&*o3R@WAJjeLB%}V42Ct1!^CGtqFP91;!7sXxLhOg&?XPB^tCwteUkUxhCh{Kbw|UpP1bTVJvy zlU?_xO4}e|#qq2}Js;ArO;zxzqnp10-1%U9-0Xb z0>LAqli}ac2u}Mhf#UG7oW4pnPzi!`&2LG!D~cFAFK;67eh-JU{CIo=F@vQP^g%+! z18C4DZu?d&Cb_v;xoUO~Qk5bJWfr&b|K?S5`Gu8Do}2J(NbhWY#_|+(m1G^-gsNm5 z@vYLzA-C=px9$Z^adoIme0U-4K?45;S=gbL>1MqoG9?wvD++eJy?QKR8{j*?y>SiS zU5B(~?X3>$O%l`rKE;J3t;I`?7ne@@lsw`Usx|{hNj>+3)@m&1qx8qg4_fK4MFCpB z*sC@oX8aJpqx0RPrtp+ZM?$kpE1;CE6gExRVM$-1H}a;1Z$rU{xQHsEJ@C|T&Dn)I zG_s3mwMYlIVt6-lb%s)!X>OA8U>9GlNIX}OFD8(7P;^a5kez0fh#k3=^BZ_sF%=bu zPtYZC(IZO}`=)QXmJGV?!s@yn`SkbX2$tyU_0pH#-N8>B^8`7{bqB3)X&PLfh)!FZ zw~k%i+PPJ`YMc@~AW9CEd)K2gP~H6~dR}R|*Z}ZdLvRUcL%*u>Qe4V=t6-_OE-IjD z6PXfBDDT9i-pl$L=fi{th1@iqrQ)9N1+3rw+TtRyyO8svoQF&e?H?A~Q-qqNyfLdXueb=W}5IaPk<*Iqi6>yD@_ zZ->cjxtnHf)>N38l6dK&W%62U;&swRNlK3ga_sUS|H8j`KCvq3lW}B|7BQjC<#H|p z2m3<8C+-ai*Ixb;IVQTQ`+j2>in*BX{QWrG&CG@EQ8i7goT1q=) zH#4r+3M77XnxS$e6?oSk^h{@QnxOj{c8tRp{2yzj2Q*(Cf*6r|Sh8J6M4D%K$?Nkz z$1<{mFrx@}VD@scT*D4Rsv>B_mgA45c~v?XcGnIf={;A3*z?sJl+erRB)G>iMCwSU z_`%k3Az%QL-B!8|gdOIO^Xxf{&7dMJO$8!fY*GV*POb*}s#2?M-LHud8#0V;Y-3ss8 zP%ur1`|`T?CfNdh0--s@z$xvLy(o1y)W;6CuwBA3jIMmKBY9MsV7OAWTPUrQD@NHx zOf(VH!L{M2Hgf<{tU2`$0N>ogZnZ-`A_seD6iBV3S<>lhR`r#S|3p^V4abU7x7T4H zO@WS^0&&}|4lg+RyVVbAlz2c7H|J2f>qjDi0-wEn14^(+B154!s`3(S^6+L%KwH$4 zFTqqAsMnico?YgG$=xS?R@1#fq(B$~b0>%2(LL^Oh<@a=64jjj4^RdrZ*eT44iVdJz?vdR?rA11 zTnq9ef(WuTX@N50C9Gpk-Whx<<^kbZQGnR6UVpByBn_7~uWheR=m(`}#F=1b-a6Zg zd4+(q%|)j&W*4tVxRe!i8{&D7!={=f+$|jm#`UD30O{+&K|2GcE5UeHVlPe$`eO%) zUT*-cm|m1a!L%JGl8b@Wywmc-nC>O74<4Dh&sQdR_t^|2obL7KO~sb*EST=i&*{U0 zrql2D^*($MJn^1=Af^YB@23|jG{V35#f+TzwCk8f6OHgwmn)6PlO4{ycA5P{`Mo&z zvUkx>0=DIu{)_27+5<4|#gR5XP@Ogu;GV5*2ECcZ(KdY@!cLpveA|Yc#|xuv1_#^V z+f&C;=9CvhSot1Ddx>QE-EPQVjpP@?UM1;2Ht}mOo7bCT8CHPK8dU2h3h+T3cIVf zt}B-=s;}eYd>Y%L+ucnND^SwWunqK3yh@>bVsVDI${6A%*rfng(poi69rme^FcJnh z-81lmX%A{I5L~m7@+pDQa#+7aEH+pqm7FqAB!c6#QQC~;HJF9{GQUVjW#&l)Nh0e7 zDcP(mkQ`j*t(mANo^U`Hfj!EmSh4icN51cyl6kr#x8i#!Yc@_kA&++NsFg;;7P0JN z2SW0Kh+6z~zIlxu51*kPE5MY{ zPBi_FB|U9rx1>$EW$pubr6^(##ba-iDJO3y$}bf=@_uL!Q*={sirNEJpSq6Upt64g z*l`{)x3+M@M7oX{yT1z>hls|=u%D%%UA+58Ig#X)kaJncmDG5 zs*3fI2}t&`5I(-qV-Ikffem6gVK(FQ&)vApM=U{Iq z2&>cxV^M~f_4Ca-FJSjK@Ann)e&GSDa{}$SM(Pc8}5nJ{2Hy(tEQp zewZT;X}_b3qN9>6X-b2cB#{mtS95o(rlRrIdp{(+v<+I`H#sUAw8J)E50IG1d)6gM zhtcf!vGXI_K3uIE|Fa+b$b%1s=w|gr-F7Gb%G>UgiE^koY?D!%=oGBNF9{VPHJmCG zo)W@aDK`vv?7?6@<~2eE z87636eba+)?Jc^e-pt%!wmC^nJenr>zF$5`r+OX2cNkZczJL5NGNN>&Dmo&R&Lxx?-_vlyY>#A9FcbTzq^I^>pM;W2%~?BS zypS?hbB*3r z!q=YbPJ+o05af%ngD~Iu z^p9r$E>p%%P=Hc5x#vr-;max144Hsk#Ko;*-GB0_cgCjKwk`|N21Z@1yNsY?NZ3AGLc8O_Hnby5g{O)1;0&x6U!l7 z+o9A+39@fyjF6!tPBDsd)zSXgGygnigvl;O$am*&j`%lLp+e`Oaa+u;4zXk}5^0bb z6Tp0@@lpEnXMQZFfXN}XW?m(*!<;LsNjHJNaXfKsPi(iO3v^*S5*xN7V1W=~$9^=xfj7&iycERjd!3z6x}cn_}P?C9EoeYD*dB z9kNz~cx{}f_l-1};9ML0^JjjR@h9oNi8x^nrlK&4i1YmORxa{K2X(Qo86ss-Afguc z_OUeIlpYu?Yfpk&d-hKc*1j1?W(VlroE2sf1kaW z(Jv~G6uMdPtAkp5dpLDVlj<0BgZ3Lo-XfNUinliKXV3k2X548oi+;&*I09;b1Jmr@ ztzG<6DsH)F_=)6FHPA^9lQhvr+6MzMoNM$?$O#u|Pk%k;$+Q{(!^I(Pddl%!mKK0v zy7Wk>k*VxQh+DiF*i6>}{m=8~Gn3Ep&dTrS_TeqMx3V^-m@5fPmO-Ke@D6EdapF&_ z!{izOCyI06{U8hPgWMg&2i zmnz}~;;AL5R=&d>Pe({znV>RLOPtK)-}b=Bz0nk4oK_A}v<%Z@`0P+DN#){S@KDV8 z%jCS+06L6x2FBjvC1-lGLy}-i*FD=GB5}Oa_`%xdpfcoDfD4Q`u_dc4#R3j(8k6GF zlkjJI;}Fhytm3+Mu5V-!oj`0+MK0sW-c%$iRicV79k_9pA4kWZrbB z76HQGZ5K<^wTAJ-ERI@ki(}f~Z%|sy|6NTp7P;&1vF>LFex3n}nPkzAK z65^TcDOiJM=Y~a|n~6fv62ZLAcbAst7gT77Az{9VoihlA26hJoqNYJB1id9}3JXAQ zVQz`JI9kZNw>Z0?nhPL6HyMC>!v$FXS}4clErFba79-?LNudEKI;ZE(`=2hnf92yk zoPRKL!Auu^UCe7`#m;}}`x7}`W5vkop|pwJxN``f@j~Xe1x|UASDe`hOe#KTJKXLn8$!M+`MdVn--jui<`-^IwBBM_<*|1KzLh|d*izVh@&5dtQuFyDvPHMGAA zN?e++?wxWot!|;+jb_s+HUkFut@pDbBG|@@92%xbMvi(1(pB~j&o`xEM4A;(9b(E& zRGKTBo71vkvRfRnxW{@i?9Dd9;JyY(s>wW}>tLhU->NChy<*wO^6G94)WKS^OT*U9 zIf3C^Euf7^bi>F10GJ)Rc3`nLhkJ%z456fGZSztAQ3Nl5nNyMNT!W?gW!oNleTaTj zfOns26t30Z-`DDddaq7F7Z=!x?5;Ohm~+BLiiA04)x0@h`%TG*TBCM{IiLtDNZ6hd z(+|iN`fy4Lu@otC=i;gux%I0*d_F=Q4hihS8E5-BXLVi96<2?o#uP3f^ik!JbrFd( z{k+C!B4WF?D_^KaYEJ~2_cMWw@#;%Mm3=FGFW3U#?8jck(ane-^8Y%3^Q9|hDuj6_ z^T##GWHquJRJYLWHUQzrQ_o}?L4)pt{^NWb)_Z2+&Egzg^>+f2$ON-x>aGg&<9!CN zcJ*{3r_~BlBNL404k~z5mzVAsjkjqNDjf9I4c7OJSYsj@$In!ctG#sYtV3#&&vY2s z(1s#61gQyqB|$F)r5z3{&m|0ZfC;Q;@eW}E8?f(-$zlKR8{Zksq|vVlmBwN@cQF@> z-I@EIJHYQ+veMAGM6HQH?<(hGKLYNEIGM@vA5Y$z%)zR8QO!+$T#T6waw9bo!cLr_+kc-b|A6Rq>Pi+Wrut) zQs$~skObJs&3&{kRr4lF$cyisi5Oo=l62HM;4T2r$FEp5q@r z^P|+zX)Ee1tu^K$^X7FeH!O8Kd`L5u4jWoJT1)zyb{y7@h7xkXX0qA$B>N2t|L$|2 zqz3Fr$9x}(?I+t)+v-zho8*8;+p2By1u^-Jz*4d?lOs#^4vXP(vYWj=#?Z9G=8=3w zv+Ff1pM>$UWpsB8-zTd2=93p+$S@BTdf?01fWD!CGI1Jb)}nwON*IKcvB)GM-E6R+ zF~WOSI^bT(0xB&g4&|dUbXrm=MX_!JC1Wy(p%4}bRazrizsDZ^P-9Cua z_s32Dm6owym9#KEYY^QUuVpkJZJb|S!vVyyXV6{n(Tpl$|GmsHUARsp3&#U9!sSDYc z%cS>pQ0mDXY8U(vnx@<23GQu{C6E4v0)eys6;-f`I8I`DnY>*ywxUoAN~xp!g{8$% zyI8BF3Y%LXJ(<6pUmgyWuS_4#4+gzusg_C&b5`51H<;^@RIJvl8PL^y==Tdt%aYIP z^KNa;3#*NO^?FiFossjBT_lO1F+?pmObv(|X|<%0@++OL#>>*H34QztVsB_gy%k=Z zbyuSL+mx2pIbwa?G0xApR(?Moi0RGUik{Dp(VD_5$pfU-@MIdyPHHB;H<496LI$U{ zcdpJf9*Vggi%c{rZfO|(+<0YkV|`1Jlcx@qYW22L_3Y{iNxi1kgN8-tm*i*ZNh1rC zsZ6yV9GEk@wYMs%XZgTyr6aWWjk?fh-b&irRBu~8MQlmZVvMes>c-fMI4v|HXV1$Y zhkQxn3y3*5A~S!l+7Yh^*ETJXyf;yM8=Lx;Zgg_wdAsQWDX<>8A=+{A?eS~mLzcJC zcm)S+O%Z-Wk*o+hBPX&9*u4ZpOU+!XVdKuwdFnh}EQoJJ3K@N>B9iUki@B_)MC6`A zf5QUTyH%WkJj)Ej0ZfLA-w^6A;(kp!=_$6`y^#*e@|W};+IkARavbMvH3%5v(>LVP zK~c0fua4I=TnYgY#4!1$t8#8dNOUV5lxO-kVmWp8O(z7fVsgLeLG$hP)UKg~AtcZB zSJQXT-(Z3vOnhAKv(S+WB51xY4+BSjPPe~Clel*p2jqXf?>vHobaew?kW;ZT0e|$> z|9ob~B>|Ow;LDkSL1*uNoh|9m-fEeS6ek2HWZFg7uT%xuD~PQZv5efnqbHP|k?X-v zSU;_^FDzdKlWJ!kxk24jgRUQ}C$3k4q&Ycte8&Vr_U4jqi5>jfj3xg@VZ2SO5>ZDl z!;l74F8W{b1r`Lxu*B#wAx9`zesX&Xx@lD$dsvGj3!LeAfLOFnK@wW|C(S=doJRoFm70d>$MzzPcS@ ze6y-Ca*0(zRVdFR>zxH+Wj&5qV>2`!t|)t!phXA=mJm#U0zozhpCo=Tt4PRAFH#gl zOi@3q(Sj>cqlj;cR^nD;;oFRH#?Xuo7xlx34Al0#!36ntb}o}6HA|ZEQn8B>IT+KY zd8swN3WI4Da=#io_q^JTO<;$R!$O$V19jt(L$)qH@rT8^%4$#b^+klWLK?!faTIuj zO-b4L|HTzg;&79lJ_JK`9>P4S#IZc_alGw4nqb2}uGH}yaWCu!D`k0zPgaL*C(~W? z3eRlbVEg1~)7BQwzKcE@6xkbTca(U=qp5SJcCj;HXptZ$PH9V9-hJ6j7A*HVjf(e? zkwIG*_R^uun|+;vJ*P+WxcKv;kFAnF@yqsn9`;qP$AH`dY)NgiDx7;wAxc%U%u`iw zu1_8F*h^KF{|ehH54FMa?Yx_KEn{w}3f-zw;At zSPJ}~RpG)rP|ljBDjb0MVBmGk`>&{KV8L;{-t1zCD>A{9s^HTVHrG^zg`W?G*mU@V zRMGTm$YHni3JVYeqysj<1f< zBd_StEE!uD9Z2@eD&o!JqF^D<>>kdpx&)^JE2@&82EFR{ht?|^)%Q3M@EuZCg%yBP zxrJqnUtX2KuK%e)!Gm)Wlc;JqT-2lfBCsNM(R*dT0vULyT+w8P#utQzbtoct$3*r? z=D|C6f9~XoyQlB|JpbN(=t=&0SpPiq)QP*O)b2jaUwizm`W$VFJ*SJ`(vfN+>(EZK zd%41H^LFKYe*f$L^1^~MdL8EMHJP&5vNmp#TtWWQ0!!+cs_jajC`QPRkzlvz)M3il zPs=*QFzgt(RDF8t2KF_DXuHOxdI?nR=9%d~cyZDDedv(3iF{YHMKO@m+I6#GkuvTr z{#)Bg*y!7IZ9kj-W`;FpnosS*%}IdlRvZ9`AJE9txoY$BBL}OFJ`Edt;?wvb7eI&DqJUn}8`ZpW~cOT{*GxXq>bLvB> z>)w(3hpFpi4>27vxWo%RuV&L?T}=a}<)^GD)@blL=%Fn`$eC~v%YTd0F%{k6f}KqT zpec}fdAzg9nJjvQzcz6tR}LC|nx*Lo7tL1gcPHVO!{;DEn#c@ka%@^&9p(pa>X*hDyjS`>NcjpY#jZ*S^>0|4dz)RT$x0AsXNfd zOK|}x%7JFAJu~8hvu4?dD$IqwHus}nc}U^ndCS2Q}$?cY!yZU>bI8tTu<7 zX+W1QT~0KxyA94v13c?QW78|yuPn||%KJL!pM2qkM;@I(Ryy_>pTfqMSZ+QDUWo{F zmqkTjL5O0UMFhhq73+aV7ng1z5;>sZm^m&3i`U37*wYvX?Jva^XXB~|sh+cNdjGI< zK&Nm@q1G5=!Va7v?J~#h-QJP5e$-?T{r(gGkcQ>qemq5&(fu9Su*R-qFH7_5iz57%>`iG=fGLE zd$r)DTwYVx#Ai%wC#+DkZA8llDJI>nZ1!#Y<;{l3uUHGPbAMAF8qP9w>WCWPJN@qL z+s3QiR~=&I?K-9(M^#)8(xdyU&7HvLUG(i(l=cy}73A zloc{qq}#S@K;a3sls>-oER$|G^ZW61_8s6yzVh? zJcdz)E0ww)H_8p9R}%iol-H{uh-luQy#VKN$B_wJ_q)tI_g`vqJp+3nnjX};>y zNHK7DmePd9XAFvEh!N68Hv3TmiY0T5Zgl^qg8Xy7tL31ba;CdI4%U+a0JJoHfw#p- z!|7w_c$(6vIGQhe?U&M^wO^Wy@t$L3a$4!Q6GWOBd5;Of>qzXJKHd1>);6bta*j~C zC{A3Kc+uoPsDBIsrZ|YqL9$fR55)Cs)sCHgxDEhxY{Yqwb z`7HGMQ@=5S{s!9f7Ort`DXW+&Pr~rVE918;v@;FtEdI#>`Z@}8Lo5I&~hQd zYo;30#7k7NLsWn-KlR+IbsLziphH;z8o%mJH&<*4fU}(i*?3!H`STD^R+Bs)-RZ!a zh;#rqtZi4ch`X*h-KadAA@)$vCv?b&Vwh3Cd10+p)y{)*3{x1l=$plk7UB8OIi4Y6_C-_OA*}9e{|5x$%Qce3p|^G33XOJ(DLrC4C50gzC`tu4cC1 zSA>(3026#Gk{mmA6Xg4b%0o+x_Pg+rNNCAEX8Hp~pT9g_T=Ks&L$jfh!XcZ#X(x5K9mXzNW0J)D0N^cWlCA-^EyNnf9ps>_x8o} z-#)x%>pI%m{@{jmG@)UDr*ik`x{R7#4sLqBlT%tVZYavwwE>}DMO)!BR7b*|ItxCP zk3%_68Rr8klwLadaUMy}Vw1;+Z3@MEzoLW9z%iMhu|-YpWo@{-cB044G$iw)Jc|V; z8bR&r?>zaF+@6mqC@wfS9c^u86oMH3&=XId?vVO(^-Ka+_1FxXBmjA6klH3;CWdE@ z^(N@%RNNxma}QF(&Z=B3g?Xz-3#R_iz6AZCw^veW%P3@Ni7+V`Dobfc-Kc1d(Yaf)sJO8~m8tT^xBnlX{k2S=VVv*<4+nBMgyvfqF)6WR zB{~24d@oZv1OA%1QOX{lJs%%sK%XP RT`I#WOo6jY5mI^Q{{R}#TmS$7 diff --git a/difrac/difini.f b/difrac/difini.f deleted file mode 100644 index 84ea49b8..00000000 --- a/difrac/difini.f +++ /dev/null @@ -1,248 +0,0 @@ -C----------------------------------------------------------------------- -C -C Diffractometer Control Routine for NRC Picker or Rigaku AFC6 -C E.J.Gabe and P.S White -C Chemistry Department , UNC, Chapel Hill, NC, USA -C -C This routine is based on the original NRC Picker routine for the PDP8 -C E.J. Gabe, Y. Le Page & D.F. Grant -C Chemistry Division, N.R.C., Ottawa, Canada. -C -C The original code has been cleaned up and brought to F77 standard. -C -C Transformed into a Subroutine for initialization for SICS by -C Mark Koennecke, November 1999 -C -C Key Function -C -C *** Terminal Data Input Commands *** -C -C AD Attenuator Data: number and values. -C BD all Basic Data (CZ DH FR LA OM OR PS RR SD SE TM TP) -C CZ Correct angle Zero values. -C FR First Reflection to be measured. -C LA LAmbda for the wavelength in use, usually alpha1. -C LN Liquid Nitrogen option - specific to cryosystem. -C OM Orientation Matrix. -C PS PSi rotation data. -C RO re-Orientation Reflections: frequency and h,k,ls. -C RR Reference Reflections: frequency and h,k,ls. -C SD Scan Data: type, width, speed, profile control. -C SE Systematic Extinctions. -C SG Space-Group symbol. -C TM 2Theta Min and max values. -C TP Time and Precision parameters for intensity measurement. -C -C *** Crystal Alignment Commands *** -C -C AL ALign reflections and their symmetry equivalents for MM. -C AR Align Resumption after interruption. -C A8 Align the 8 alternate settings of one reflection. -C CH CHoose reflections from the PK list for use with M2/M3. -C CR Centre the Reflection which is already in the detector. -C LC 2theta Least-squares Cell with symmetry constrained cell. -C MM Matrix from Many reflections by least-squares on AL data. -C M2 Matrix from 2 indexed reflections and a unit cell. -C M3 Matrix from 3 indexed reflections. -C OC Orient a Crystal, i.e. index the peaks from PK. -C PK PeaK search in 2Theta, Chi, Phi for use with OC. -C RC Reduce a unit Cell. -C RP Rotate Phi 360degs, centre and save any peaks found. -C RS ReSet the cell and matrix with the results from RC. -C -C *** Intensity Data Collection *** -C -C GO Start of intensity data collection. -C K Kill operation at the end of the current reflection. -C Q Quit after the next set of reference reflections. -C -C *** Angle Setting and Intensity Measurement *** -C -C GS Grid Search measurement in 2theta, omega or chi. -C IE Intensity measurement for Equivalent reflections. -C IM Intensity Measurement of the reflection in the detector. -C IP Intensity measurement in Psi for empirical absorption. -C IR Intensity measurement for specified Reflections. -C LP Line Profile plot on the printer. -C SA Set All angles to specified values. -C SC Set Chi to the specified value. -C SH SHutter open or close as a flip/flop. -C SO Set Omega to the specified value. -C SP Set Phi to the specified value. -C SR Set Reflection: h,k,l,psi. -C ST Set 2Theta to the specified value. -C TC Timed Counts. -C ZE ZEro the instrument Angles. -C -C *** Photograph Setup Commands *** -C -C PL Photograph in the Laue mode. -C PO Photograph in the Oscillation mode (same as OS). -C PR Photograph in the Rotation mode. -C -C *** General System Commands *** -C AH Angles to H,k,l (same as IX). -C AI Ascii Intensity data file conversion. -C AP Ascii Profile data file conversion. -C BC Big Chi search for psi rotation. -C BI Big Intensity search in the IDATA.DA file. -C EX EXit the program saving the basic data on IDATA.DA. -C HA H,k,l to Angles (same as RA). -C PA Print Angle settings. -C PD Print Data of all forms. -C Q Quit the program directly. -C RB Read the Basic data from the IDATA.DA file. -C SW SWitch register flags setting. -C UM (UMpty) Count unique reflections within theta limits. -C WB Write the Basic data to the IDATA.DA file. -C -C The program uses 2 main files:-- -C 1. On unit IID the file IDATA.DA contains all the permanent -C information for a data collection: -C 2. ON unit ISD the file ORIENT.DA is really a scratch file for -C use with the crystal orientation routines -C -C Both files are 'direct-access' with records of length 85 4-byte -C variables. -C -C The file IDATA.DA contains the following information:-- -C Record # Information -C 1,2,3 All the basic info for a particular data collection; -C 4 to 8 All symmetry info from SGROUP; -C 9 Automatic restart info for use after interruption; -C 16 to 19 Alignment data for ALIGN; -C 20 and up Intensity data, 10 reflns per record. -C -C There is a 9-bit switch register which can be changed with the SW -C command or during operation by typing any digit from 1 to 9. -C The switches control the following :-- -C -C 1. 0 normal screen display; 1 profile display. -C 2. 0 display raw profile data; 1 display smoothed data. -C 3. 0 dont print profiles; 1 print profiles on printer. -C 4. 0 print intensity data; 1 do not print intensity data. -C 5. 0 print standards data; 1 do not print standards. -C 6. 0 no action; 1 add 20 points to profile tolerance. -C 7. 0 no action; 1 add 10 points to profile tolerance. -C 8. 0 no action; 1 add 5 points to profile tolerance. -C 9. 0 no action; 1 write profiles to unit 7. -C -C Common to match the CREDUC Common /GEOM/ -C----------------------------------------------------------------------- - SUBROUTINE DIFINI - INCLUDE 'COMDIF' - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - COMMON /GEOM/ GJUNK(370) - CALL INIDATA - IDH(1,1,1) = 1 - IDH(1,2,2) = 1 - IDH(1,3,3) = 1 - NOTEND = 0 - IKO(5) = -777 - ALPHA = 50.0 -C----------------------------------------------------------------------- -C Get the I/O unit numbers with SETIOU -C----------------------------------------------------------------------- - CALL SETIOU (IID,ISD,LPT,ITR,ITP,IBYLEN) - CALL WNSET (3) -C----------------------------------------------------------------------- -C Check that the angles did not change since the last time the -C program was stopped. -C----------------------------------------------------------------------- - CALL ANGVAL - DFMODL = 'TRICS' - DFTYPE = 'TRICS' - WRITE (COUT,10000) DFMODL - CALL GWRITE (ITP,' ') - LPT = ITP -C----------------------------------------------------------------------- -C Open the Idata file (IID) and the scratch file (ISD) -C If either file does not exist, create it. -C----------------------------------------------------------------------- - DO 100 I = 1,85 - ACOUNT(I) = 0.0 - 100 CONTINUE - IDREC = 85*IBYLEN - STATUS = 'OD' - IDNAME = 'IDATA.DA' - LENID = 700 - CALL IBMFIL (IDNAME,IID,IDREC,STATUS,IERR) - IF (IERR .NE. 0) THEN - STATUS = 'DN' - CALL IBMFIL (IDNAME,IID,IDREC,STATUS,IERR) - KI = 'W2' - CALL WRBAS - KI = ' ' - DO 110 I = 4,20 - WRITE (IID,REC=I) (NOTEND,J = 1,85) - 110 CONTINUE - STATUS = 'DO' - CALL IBMFIL (IDNAME,-IID,IDREC,STATUS,IERR) - CALL IBMFIL (IDNAME, IID,IDREC,STATUS,IERR) - ELSE - KI = 'AN' - CALL WRBAS - ENDIF - STATUS = 'OD' - DSNAME = 'ORIENT.DA' - LENSD = 300 - CALL IBMFIL (DSNAME,ISD,IDREC,STATUS,IERR) - IF (IERR .NE. 0) THEN - WRITE (COUT,11000) DSNAME(1:9) - CALL GWRITE (ITP,' ') - STATUS = 'DN' - CALL IBMFIL (DSNAME,ISD,IDREC,STATUS,IERR) - DO 120 I = 1,300 - WRITE (ISD,REC=I) (NOTEND,J = 1,85) - 120 CONTINUE - STATUS = 'OD' - CALL IBMFIL (DSNAME,-ISD,IDREC,STATUS,IERR) - CALL IBMFIL (DSNAME, ISD,IDREC,STATUS,IERR) - ENDIF -10000 FORMAT (/,10X,'Diffractometer Routine for TRICS ',A /) -11000 FORMAT (' There is no file ',A,'. It will be created.') - RETURN - END -C---------------------------------------------------------------------- - SUBROUTINE WNSET(I) - INTEGER I - RETURN - END -C---------------------------------------------------------------------- - SUBROUTINE WNEND - RETURN - END -C----------------------------------------------------------------------- -C Block Data routine to initialize the COMMONs -C----------------------------------------------------------------------- - SUBROUTINE INIDATA - INCLUDE 'COMDIF' - DATA ISCDEF,ICDDEF/150,250/,IDTDEF,IDODEF,IDCDEF/4,2,10/, - $ IFRDEF/100/,NRC/-1/,STEPDG/100.0/,ICADSL/60/,NATTEN/0/, - $ ATTEN/1.0,1.88,3.54,6.66,12.52,170.4/ - DATA KQFLG2/0/,IUPDWN/1/,IUMPTY/0/,IAUTO,NSET/0,1/,SGSYMB/10*0.0/, - $ DEG/57.2958/ - DATA R/0.070932,0,0, 0,0.070932,0, 0,0,0.070932/, - $ DTHETA,DOMEGA,DCHI/0.,0.,0./,NAXIS/2/, - $ THEMIN,THEMAX/2.0,100.0/, AS,BS,CS/1.0,0.7,1.0/, - $ DPSI,PSIMIN,PSIMAX/3*0.0/, - $ TIME,QTIME,TMAX/1000,1000,100000/, - $ PA,PM/2*1.0/, IHMAX,IKMAX,ILMAX/3*22/, WAVE/0.70932/, - $ NCOND/0/,ICOND,IHS,IKS,ILS,IR,IS/30*0/, - $ SPEED/4.0/, STEPOF/0.5/, IORNT/0/,NINTOR/0/ - DATA NSTAN/1/,NINTRR/100/,IHSTAN,IKSTAN,ILSTAN/4,17*0/,ISTAN/0/, - $ NSEG/1/,NMSEG/1/,NMSTAN/1/, NREF/0/, NBLOCK/20/, - $ IHO,IKO,ILO/24*0/, IND/3*0/, ITYPE/0/, JMIN,JMAX/16*0/, - $ AP/3*10.0/,APS/3*0.1/, - $ CANGS/3*0.0/,SANGS/3*1.0/,CANG/3*0.0/,SANG/3*1.0/, - $ RTHETA,ROMEGA,RCHI,RPHI/4*0.0/, IH,IK,IL/1,2,3/ - DATA IDH/72*0/, IBSECT,ISCAN/2*0/, FRAC/0.1/, IPRFLG/0/, - $ ISYS/1/, SINABS/3*0.00503135,3*0.0/, ILN/0/, DELAY/100/ - DATA COUT/20*' '/,IWNCUR/0/,ISREG/1,1,1,0,0,0,0,0,1,0/ - DATA STEP/0.02/,PRESET/15000./DPHI/0./ - RETURN - END - - diff --git a/difrac/difint.f b/difrac/difint.f deleted file mode 100644 index e40a6932..00000000 --- a/difrac/difint.f +++ /dev/null @@ -1,724 +0,0 @@ -C----------------------------------------------------------------------- -C This is the Command interpreting subroutine -C -C Each 2-letter command in KI is associated with a unique call or -C set of calls. Having made the call the particular 2-letter sequence -C will not make any further calls and will be cleared at the end of -C the call. -C When routines change the value of KI, which some do, the new value -C is always unique and will always cause action further down in SETOP. -C -C----------------------------------------------------------------------- - SUBROUTINE DIFINT(COMMAND, LEN) - INTEGER COMMAND(256), LEN - INCLUDE 'COMDIF' - CHARACTER STRING*80 - - KI(1:1) = CHAR(COMMAND(1)) - KI(2:2) = CHAR(COMMAND(2)) -C---------------------------------------------------------------------- -C Disabling some unsupported commands for TRICS -C---------------------------------------------------------------------- - IF(KI .EQ. 'AD' .OR. KI .EQ. 'LT' .OR. KI .EQ. 'SH' .OR. - $ KI .EQ. 'IN' .OR. KI .EQ. 'NR' .OR. - $ KI .EQ. 'EK' .OR. KI .EQ. 'FI' .OR. KI .EQ. 'KE' .OR. - $ KI .EQ. 'MR' .OR. KI .EQ. 'MS')THEN - WRITE(COUT,23000) - CALL GWRITE(ITP,' ') - RETURN - ENDIF -C----------------------------------------------------------------------- -C The program runs in two modes, full screen and windowed. -C The following routines require the use of the windowed mode -C----------------------------------------------------------------------- - IF (KI .EQ. 'GO' .OR. KI .EQ. 'IP' .OR. - $ KI .EQ. 'IR' .OR. KI .EQ. 'IE' .OR. KI .EQ. 'IM') THEN - IF (IWNCUR .EQ. 3) CALL WNSET (2) - ENDIF -C----------------------------------------------------------------------- -C These routines require full screen mode, any others should work -C in either mode so we are not flipping screens all the time -C----------------------------------------------------------------------- - IF (KI .EQ. 'AL' .OR. KI .EQ. 'A8' .OR. KI .EQ. 'RO' .OR. - $ KI .EQ. 'OC' .OR. KI .EQ. 'SD' .OR. KI .EQ. 'AR' .OR. - $ KI .EQ. 'PK' .OR. KI .EQ. 'RC' .OR. KI .EQ. 'PD' .OR. - $ KI .EQ. 'RP' .OR. KI .EQ. 'BD' .OR. KI .EQ. 'CH' .OR. - $ KI .EQ. 'GS' .OR. KI .EQ. 'CR' .OR. KI .EQ. 'LC' .OR. - $ KI .EQ. 'LP' .OR. KI .EQ. 'M2' .OR. KI .EQ. 'M3' .OR. - $ KI .EQ. 'MM' .OR. KI .EQ. 'RS' .OR. KI .EQ. 'BC' .OR. - $ KI .EQ. 'NR' .OR. KI .EQ. 'TO' .OR. - $ KI .EQ. 'MR' .OR. KI .EQ. 'MS' .OR. KI .EQ. 'FI') THEN - IF (IWNCUR .NE. 3) CALL WNSET (3) - ENDIF -C----------------------------------------------------------------------- -C This routine reads commands from the terminal and sets a flag to -C indicate whether the command may inhibit an automatic restart of -C data collection, if appropriate. -C All control of the program flow is via the variable KI. -C----------------------------------------------------------------------- - IF (KI .NE. ' ') THEN - IMENU = 0 - ELSE - IF (IMENU .EQ. 0) THEN - WRITE (COUT,11000) - CALL YESNO ('N',ANS) - ELSE - IMENU = 0 - ANS = 'Y' - ENDIF - IF (ANS .EQ. 'Y') THEN - IWNOLD = IWNCUR - IF (IWNCUR .NE. 3) CALL WNSET (3) - WRITE (COUT,12000) - CALL GWRITE (ITP,' ') - IF (DFMODL .EQ. 'CAD4') THEN - WRITE (COUT,12100) - CALL GWRITE (ITP,' ') - ENDIF - WRITE (COUT,12200) - CALL FREEFM (ITR) - I = IFREE(1) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0 .OR. I .EQ. 1) THEN - WRITE (COUT,13000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (I .EQ. 0 .OR. I .EQ. 2) THEN - WRITE (COUT,15000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (I .EQ. 0 .OR. I .EQ. 3) THEN - WRITE (COUT,16000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (I .EQ. 0 .OR. I .EQ. 4) THEN - WRITE (COUT,17000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (I .EQ. 0 .OR. I .EQ. 5) THEN - WRITE (COUT,18000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (I .EQ. 0 .OR. I .EQ. 6) THEN - WRITE (COUT,19000) - CALL GWRITE (ITP,' ') - WRITE (COUT,20000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (DFMODL .EQ. 'CAD4' .AND. (I .EQ. 0 .OR. I .EQ. 7)) THEN - WRITE (COUT,20100) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - ENDIF - RETURN - ENDIF - IF (KI .EQ. 'RI') KI = 'RB' - JAUTO = 0 - IF (KI .EQ. 'AD') CALL BASINP - IF (KI .EQ. 'AL' .OR. KI .EQ. 'AR') CALL ALIGN - IF (KI .EQ. 'AP') CALL PROFAS - IF (KI .EQ. 'A8') CALL CENT8 - IF (KI .EQ. 'BI') CALL PRNINT - IF (KI .EQ. 'CR') CALL ALIGN - IF (KI .EQ. 'CZ') CALL BASINP - IF (KI .EQ. 'DE') CALL DEMO1E - IF (KI .EQ. 'GO') THEN - ISEG = 0 - IAUTO = 0 - CALL BEGIN - ENDIF - IF (KI .EQ. 'GS') CALL GRID - IF (KI .EQ. 'AI') CALL IDTOAS - IF (KI .EQ. 'IE') CALL INDMES - IF (KI .EQ. 'IM') CALL INDMES - IF (KI .EQ. 'IN') CALL ANGINI - IF (KI .EQ. 'IR') CALL INDMES - IF (KI .EQ. 'IP') CALL INDMES - IF (KI .EQ. 'AH') KI = 'IX' - IF (KI .EQ. 'IX') CALL RCPCOR - IF (KI .EQ. 'LP') CALL LINPRF - IF (KI .EQ. 'MM') THEN - CALL LSORMT - IF (KI .NE. ' ') CALL BASINP - ENDIF - IF (KI .EQ. 'M2') THEN - CALL ORCEL2 - IF (KI .NE. ' ') CALL BASINP - ENDIF - IF (KI .EQ. 'M3') THEN - CALL ORMAT3 - IF (KI .NE. ' ') CALL BASINP - ENDIF - IF (KI .EQ. 'TO') THEN - CALL TRANSF - IF (KI .NE. ' ') CALL BASINP - ENDIF - IF (KI .EQ. 'LC') CALL CELLLS - IF (KI .EQ. 'OM') CALL BASINP - IF (KI .EQ. 'PO') KI = 'OS' - IF (KI .EQ. 'OS') CALL OSCIL - IF (KI .EQ. 'PA') CALL PRTANG - IF (KI .EQ. 'PD') CALL PRNBAS - IF (KI .EQ. 'PL') CALL SETROW - IF (KI .EQ. 'PR') CALL SETROW - IF (KI .EQ. 'HA') KI = 'RA' - IF (KI .EQ. 'P9') CALL PHI90 - IF (KI .EQ. 'RA') CALL ORMAT3 - IF (KI .EQ. 'RB') CALL WRBAS - IF (KI .EQ. 'RP') CALL PSCAN (JUNK,JUNK) - IF (KI .EQ. 'SA') CALL INDMES - IF (KI .EQ. 'SC') CALL INDMES - IF (KI .EQ. 'SH') THEN - CALL SHUTTR (0) - KI = ' ' - ENDIF - IF (KI .EQ. 'SW') CALL SWITCH - IF (KI .EQ. 'SO') CALL INDMES - IF (KI .EQ. 'SP') CALL INDMES - IF (KI .EQ. 'SR') CALL INDMES - IF (DFMODL .EQ. 'CAD4') THEN - IF (KI .EQ. 'EK' .OR. KI .EQ. 'KE') CALL EKKE - IF (KI .EQ. 'MS') CALL INDMES - IF (KI .EQ. 'MR') CALL RCPCOR - IF (KI .EQ. 'FI') CALL FACEIN - ENDIF - IF (KI .EQ. 'ST') CALL INDMES - IF (KI .EQ. 'TC') CALL PCOUNT - IF (KI .EQ. 'UM') CALL CNTREF - IF (KI .EQ. 'VM') CALL VUMICR - IF (KI .EQ. 'WB') CALL WRBAS - IF (KI .EQ. 'HO' .OR. KI .EQ. 'ZE') THEN - CALL ZERODF - KI = ' ' - ENDIF - IF (KI .EQ. 'NR') CALL SETNRC -C----------------------------------------------------------------------- -C If the command has not yet been executed, no auto restart is -C possible -C----------------------------------------------------------------------- - IF (KI .NE. ' ') JAUTO = 1 - IF (KI .EQ. 'BD') CALL BASINP - IF (KI .EQ. 'CH') CALL REINDX - IF (KI .EQ. 'DH') THEN - IKO(5) = 0 - CALL BASINP - ENDIF - IF (KI .EQ. 'FR') CALL BASINP - IF (KI .EQ. 'LA') CALL BASINP - IF (KI .EQ. 'LT') CALL LOTEM - IF (KI .EQ. 'OC') CALL BLIND - IF (KI .EQ. 'PK') CALL PEAKSR - IF (KI .EQ. 'PS') CALL BASINP - IF (KI .EQ. 'RC') CALL CREDUC (KI) - IF (KI .EQ. 'RO') CALL BASINP - IF (KI .EQ. 'BC') CALL BIGCHI - IF (KI .EQ. 'RR') CALL BASINP - IF (KI .EQ. 'RS') CALL REINDX - IF (KI .EQ. 'SD') CALL BASINP - IF (KI .EQ. 'SE') CALL BASINP - IF (KI .EQ. 'SG') THEN - IOUT = ITP - CALL SPACEG (IOUT,1) - ENDIF - IF (KI .EQ. 'TM') CALL BASINP - IF (KI .EQ. 'TP') CALL BASINP -C----------------------------------------------------------------------- -C If the KI code is in the first 60 codes, then no automatic restart. -C----------------------------------------------------------------------- - IF (JAUTO .NE. 0) THEN - NSAVE = NBLOCK - ZERO = 0 - WRITE (IID,REC=9) ZERO - NBLOCK = NSAVE - ENDIF - IF (KI .NE. ' ') THEN - WRITE (COUT,22000) KI - CALL GWRITE (ITP,' ') - KI = ' ' - IMENU = 1 - RETURN - ENDIF - RETURN -10000 FORMAT (' Command ',$) -11000 FORMAT (' Unacceptable command. Do you want the menus (N) ? ',$) -12000 FORMAT (/' The following help menus are available :--'/ - $ ' 1. Terminal Data Input Commands;'/ - $ ' 2. Crystal Alignment Commands;'/ - $ ' 3. Intensity Data Collection;'/ - $ ' 4. Angle Setting and Intensity Measurement;'/ - $ ' 5. Photograph Setup Commands;'/ - $ ' 6. General System Commands.') -12100 FORMAT ( ' 7. Kappa Geometry (CAD-4) Commands.') -12200 FORMAT (' Which do you want (All) ? ',$) -13000 FORMAT (/10X,'*** Terminal Data Input Commands ***'/ - $' AD Attenuator Data: number and values.'/ - $' BD all Basic Data (CZ DH FR LA OM OR PS RR SD SE TM TP)'/ - $' CZ Correct angle Zero values.'/ - $' FR First Reflection to be measured.'/ - $' LA LAmbda for the wavelength in use, usually alpha1.'/ - $' LT Liquid Nitrogen option - specific to cryosystem.'/ - $' OM Orientation Matrix.'/ - $' PS PSi rotation data.'/ - $' RO re-Orientation Reflections: frequency and h,k,ls.'/ - $' RR Reference Reflections: frequency and h,k,ls.'/ - $' SD Scan Data: type, width, speed, profile control.'/ - $' SE Systematic Extinctions.'/ - $' SG Space-Group symbol.'/ - $' TM 2Theta Min and max values.'/ - $' TP Time and Precision parameters for intensity measurement.'/) -14000 FORMAT (' Type when ready to proceed.') -15000 FORMAT (/10X,'*** Crystal Alignment Commands ***'/ - $' AL ALign reflections and their symmetry equivalents for MM.'/ - $' AR Align Resumption after interruption.'/ - $' A8 Align the 8 alternate settings of one reflection.'/ - $' CH CHoose reflections from the PK list for use with M2/M3.'/ - $' CR Centre the Reflection which is already in the detector.'/ - $' LC 2theta Least-squares Cell with symmetry constrained cell.'/ - $' MM Matrix from Many reflections by least-squares on AL data.'/ - $' M2 Matrix from 2 indexed reflections and a unit cell.'/ - $' M3 Matrix from 3 indexed reflections.'/ - $' OC Orient a Crystal, i.e. index the peaks from PK.'/ - $' PK PeaK search in 2Theta, Chi, Phi for use with OC.'/ - $' RC Reduce a unit Cell.'/ - $' RP Rotate Phi 360degs, centre and save any peaks found.'/ - $' RS ReSet the cell and matrix with the results from RC.'/ - $' TO Transform the Orientation matrix.'/) -16000 FORMAT (/10X,'*** Intensity Data Collection ***'/ - $' GO Start of intensity data collection.'/ - $' K Kill operation at the end of the current reflection.'/ - $' Q Quit after the next set of reference reflections.'/) -17000 FORMAT (/5X,'*** Angle Setting and Intensity Measurement ***'/ - $' GS Grid Search measurement in 2theta, omega or chi.'/ - $' IE Intensity measurement for Equivalent reflections.'/ - $' IM Intensity Measurement of the reflection in the detector.'/ - $' IP Intensity measurement in Psi for empirical absorption.'/ - $' IR Intensity measurement for specified Reflections.'/ - $' LP Line Profile plot on the printer.'/ - $' SA Set All angles to specified values.'/ - $' SC Set Chi to the specified value.'/ - $' SH SHutter open or close as a flip/flop.'/ - $' SO Set Omega to the specified value.'/ - $' SP Set Phi to the specified value.'/ - $' SR Set Reflection: h,k,l,psi.'/ - $' ST Set 2Theta to the specified value.'/ - $' TC Timed Counts.'/ - $' ZE ZEro the instrument Angles.'/) -18000 FORMAT (/10X,'*** Photograph Setup Commands ***'/ - $' PL Photograph in the Laue mode.'/ - $' PO Photograph in the Oscillation mode (same as OS).'/ - $' PR Photograph in the Rotation mode.'/) -19000 FORMAT (/10X,'*** General System Commands ***'/ - $' AH Angles to H,k,l (same as IX).'/ - $' AI Ascii Intensity data file conversion.'/ - $' AP Ascii Profile data file conversion.'/ - $' BC Big Chi search for psi rotation.'/ - $' BI Big Intensity search in the IDATA.DA file.'/ - $' EX EXit the program saving the basic data on IDATA.DA.'/ - $' HA H,k,l to Angles (same as RA).') -20000 FORMAT ( - $' IN INitialize integer parts of present angles (NRC only).'/ - $' NR set the NRC program flag.'/ - $' P9 Rotate Phi by 90 degrees for crystal centering.'/ - $' PA Print Angle settings.'/ - $' PD Print Data of all forms.'/ - $' Q Quit the program directly.'/ - $' RB Read the Basic data from the IDATA.DA file.'/ - $' SW SWitch register flags setting.'/ - $' UM (UMpty) Count unique reflections within theta limits.'/ - $' VM View crystal with Microscope.'/ - $' WB Write the Basic data to the IDATA.DA file.'/) -20100 FORMAT (/10X,'*** For Kappa geometry (CAD-4) ***'/ - $' EK Euler to Kappa angle conversion.'/ - $' KE Kappa to Euler angle conversion.'/ - $' MR emulate CAD-4 MICROR command.'/ - $' MS emulate CAD-4 MICROS command.') -21000 FORMAT (' EX was typed. Are you sure you wish to exit (Y) ? ',$) -22000 FORMAT (' The command ',A,' is invalid. Type for the menus.') -23000 FORMAT ('ERROR: Unsupported command ignored by difrac subsystem') - END -C----------------------------------------------------------------------- -C Subroutine to open and close the X-ray shutter -C This routine is called via 'SH' or direct from other routines. -C The argument IDO has the following values :-- -C -1 Close the shutter -C 0 Reverse the sense of the shutter. The sense is held in SENSE -C 1 Open the shutter -C 2 ?? -C 99 Called from GOLOOP at the start of data-collection; -C Opens the shutter and sets DOIT = 'NO' -C to prevent shutter operation during data-collection. -C -99 Called from GOLOOP at the end of data-collection; -C Closes the shutter and sets DOIT = 'YES' -C to allow normal shutter operation. -C -C This version is for Rigaku diffractometers,but should work (surely?) -C for all instruments with trivial modification. -C----------------------------------------------------------------------- - SUBROUTINE SHUTTR (IDO) - CHARACTER SENSE*4,COUT(20)*132,DOIT*4 - COMMON /IOUASC/ COUT - DATA SENSE/'CLOS'/,ICLOSE,IOPEN/0,1/,DOIT/'YES '/ - INF = 0 - IF (DOIT .EQ. 'YES ') THEN - IF (IDO .EQ.-1 .OR. IDO .EQ. -99) THEN - IF (SENSE .EQ. 'OPEN') THEN - CALL SHUTR (ICLOSE,INF) - IF (INF .NE. 0) GO TO 100 - SENSE = 'CLOS' - ENDIF - ELSE IF (IDO .EQ. 0) THEN - IF (SENSE .EQ. 'OPEN') THEN - CALL SHUTR (ICLOSE,INF) - IF (INF .NE. 0) GO TO 100 - SENSE = 'CLOS' - ELSE - CALL SHUTR (IOPEN,INF) - IF (INF .NE. 0) GO TO 100 - SENSE = 'OPEN' - ENDIF - ELSE IF (IDO .EQ. 1 .OR. IDO .EQ. 99) THEN - IF (SENSE .EQ. 'CLOS') THEN - CALL SHUTR (IOPEN,INF) - IF (INF .NE. 0) GO TO 100 - SENSE = 'OPEN' - ENDIF - ELSE IF (IDO .EQ. 2) THEN - IF (SENSE .EQ. 'OPEN') CALL SHUTR (IOPEN,INF) - IF (SENSE .EQ. 'CLOS') CALL SHUTR (ICLOSE,INF) - ENDIF - ELSE - IF (IDO .EQ. -99) THEN - CALL SHUTR (ICLOSE,INF) - IF (INF .NE. 0) GO TO 100 - SENSE = 'CLOS' - ENDIF - ENDIF - IF (IDO .EQ. 99) DOIT = 'NO ' - IF (IDO .EQ. -99) DOIT = 'YES ' - RETURN - 100 WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - RETURN -10000 FORMAT (' Shutter Error.') - END -C----------------------------------------------------------------------- -C Subroutine to initialize the integer values of the angles -C----------------------------------------------------------------------- - SUBROUTINE ANGINI - INCLUDE 'COMDIF' - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - WRITE (COUT,11000) - CALL FREEFM (ITR) - RTHETA = RFREE(1) - ROMEGA = RFREE(2) - RCHI = RFREE(3) - RPHI = RFREE(4) - CALL INITL (RTHETA,ROMEGA,RCHI,RPHI) - KI = ' ' - ENDIF - RETURN -10000 FORMAT (' Initialize the integer parts of the angle (Y) ? ',$) -11000 FORMAT (' Type the integers for 2theta,omega,chi,phi ',$) - END -C----------------------------------------------------------------------- -C Subroutine to call the space group symbol interpreting routines -C If IOUT .LT. -1 the symbol is not asked for -C If IOUT .LT. 0 there is no printed output from SGROUP -C If IDHFLG .EQ. 1 the DH matrices are generated -C----------------------------------------------------------------------- - SUBROUTINE SPACEG (IOUT,IDHFLG) - INCLUDE 'COMDIF' - DIMENSION CEN(3,4),GARB(500),ISET(25) - EQUIVALENCE (ACOUNT(1),GARB(1)) - CHARACTER STRING*10 - IF (IOUT .EQ. -2) THEN - IOUT = -1 - GO TO 130 - ENDIF - 100 IF (SGSYMB(1) .EQ. 0.0 .AND. SGSYMB(2) .EQ. 0.0) THEN - WRITE (COUT,10000) - ELSE - WRITE (STRING,11000) SGSYMB - DO 110 I = 10,1,-1 - IF (STRING(I:I) .NE. ' ') GO TO 120 - 110 CONTINUE - 120 WRITE (COUT,12000) STRING(1:I) - ENDIF - CALL ALFNUM (STRING) - IF (STRING .NE. ' ') READ (STRING,11000) SGSYMB - 130 IERR = ITP - CALL SGROUP (SGSYMB,LAUENO,NAXIS,ICENT,LATCEN,NSYM,NPOL,JRT, - $ CEN,NCV,IOUT,IERR,GARB) - IF (NAXIS .GE. 4) GO TO 100 - IF (IDHFLG .EQ. 1) THEN - SAVE = NBLOCK - CALL DHGEN - NBLOCK = SAVE -C----------------------------------------------------------------------- -C Read the DH segment data from the IDATA file -C----------------------------------------------------------------------- - READ (IID,REC=4) LATCEN,NSEG,(IHO(I),IKO(I),ILO(I),((IDH(I,J,M), - $ J = 1,3),M = 1,3),I = 1,4), - $ NSYM,NSET,ISET,LAUENO,NAXIS,ICENT - ENDIF - IF (KI .EQ. 'SG') KI = ' ' - RETURN -10000 FORMAT (' Type the space-group symbol ') -11000 FORMAT (10A1) -12000 FORMAT (' Type the space-group symbol (',A,') ') - END -C----------------------------------------------------------------------- -C Subroutine to set switches -C----------------------------------------------------------------------- - SUBROUTINE SWITCH - INCLUDE 'COMDIF' - CHARACTER STRING*20 - WRITE (COUT,10000) (ISREG(I),I=1,10) - CALL ALFNUM (STRING) - IF (STRING .NE. ' ') THEN - DO 100 I = 1,LEN(STRING) - IASCII = ICHAR (STRING(I:I)) - IF (IASCII .GE. 48 .AND. IASCII .LE. 57) THEN - ISWTCH = IASCII - 48 + 1 - IF (ISREG(ISWTCH) .EQ. 0) THEN - ISREG(ISWTCH) = 1 - ELSE - ISREG(ISWTCH) = 0 - ENDIF - ENDIF - 100 CONTINUE - ENDIF - WRITE (COUT,11000) (ISREG(I),I=1,10) - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN -10000 FORMAT (' The current settings are: 0 1 2 3 4 5 6 7 8 9'/ - $ ' ',10I2/ - $ ' Input switches to change (none): ') -11000 FORMAT (' The new settings are: 0 1 2 3 4 5 6 7 8 9'/ - $ ' ',10I2) - END -C---------------------------------------------------------------------- -C Set the NRC flag +1 if Chi(0) is at the bottom of the chi circle, -C -1 if Chi(0) is at the top. -C Assuming the instrument itself is defined in a right-handed way. -C---------------------------------------------------------------------- - SUBROUTINE SETNRC - INCLUDE 'COMDIF' - WRITE (COUT,10000) NRC - CALL FREEFM (ITR) - IF (IFREE(1) .NE. 0) NRC = IFREE(1) - RETURN -10000 FORMAT (' The current value of the NRC flag is',I3/ - $ ' Type the new value (Current) ',$) - END -C----------------------------------------------------------------------- -C Convert Euler angles to Kappa (KI = 'EK') or vice-versa (KI = 'KE') -C----------------------------------------------------------------------- - SUBROUTINE EKKE - INCLUDE 'COMDIF' - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - PARAMETER (RA = 57.2958) - SALPHA = SIN(ALPHA/RA) - CALPHA = COS(ALPHA/RA) - ISTATUS = 0 -C----------------------------------------------------------------------- -C KI = 'EK' Euler to Kappa -C----------------------------------------------------------------------- - IF (KI .EQ. 'EK') THEN - WRITE (COUT,10000) THETA,OMEGA,CHI,PHI - CALL FREEFM (ITR) - IF (RFREE(1) .EQ. 0.0 .AND. RFREE(2) .EQ. 0.0 .AND. - $ RFREE(3) .EQ. 0.0) THEN - THE = THETA - OME = OMEGA - CHE = CHI - PHE = PHI - ELSE - THE = RFREE(1) - OME = RFREE(2) - CHE = RFREE(3) - PHE = RFREE(4) - ENDIF - THE = THE/2.0 - SCO2 = SIN(ONE80(CHE)/(2.0*RA)) - BOT = SALPHA*SALPHA - SCO2*SCO2 - IF (BOT .LT. 0.0) THEN - ISTATUS = 1 - KI = ' ' - RETURN - ENDIF - RKAO2 = ATAN(SCO2/SQRT(BOT)) - RKA = ONE80(2.0*RA*RKAO2) - DELTA = RA*ATAN(CALPHA*SIN(RKAO2)/COS(RKAO2)) - OMK = ONE80(OME - DELTA) + THE - PHK = ONE80(PHE - DELTA) - WRITE (COUT,11000) THE,OMK,RKA,PHK -C----------------------------------------------------------------------- -C KI = 'KE' Kappa to Euler -C----------------------------------------------------------------------- - ELSE - WRITE (COUT,12000) - CALL FREEFM (ITR) - THE = RFREE(1) - OMK = RFREE(2) - RKA = RFREE(3) - PHK = RFREE(4) - OMK = OMK - THE - THE = THE + THE - RKAO2 = RKA/(2.0*RA) - CHE = ONE80(2.0*RA*ASIN(SALPHA*SIN(RKAO2))) - DELTA = RA*ATAN(CALPHA*SIN(RKAO2)/COS(RKAO2)) - OME = ONE80(OMK + DELTA) - PHE = ONE80(PHK + DELTA) - WRITE (COUT,13000) THE,OME,CHE,PHE - ENDIF - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN -10000 FORMAT (' The present Euler angles are 2T,O,C,P',4F8.3,/ - $ ' Type the angles to convert (Present) ',$) -11000 FORMAT (' The 4 Kappa angles T,O,K,P are ',4F8.3) -12000 FORMAT (' Type the 4 Kappa angles T,O,K,P ',$) -13000 FORMAT (' The 4 Euler angles 2T,O,C,P are ',4F8.3) - END -C----------------------------------------------------------------------- -C Set the diffractometer to a convenient microscope viewing position -C----------------------------------------------------------------------- - SUBROUTINE VUMICR - INCLUDE 'COMDIF' - NATT = 0 - CALL VUPOS (THETA,OMEGA,CHI,PHI) - CALL SHUTTR (-99) - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR) - IF (IERR .NE. 0) THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - ENDIF - KI = ' ' - RETURN -10000 FORMAT (' Setting collision during VM') - END -C----------------------------------------------------------------------- -C Rotate the crystal 90 degrees in phi for centering operations -C----------------------------------------------------------------------- - SUBROUTINE PHI90 - INCLUDE 'COMDIF' - CALL ANGET (THETA,OMEGA,CHI,PHI) - PHI = PHI + 90.0 - CALL MOD360 (PHI) - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR) - KI = ' ' - RETURN - END -C----------------------------------------------------------------------- -C Transform the orientation matrix -C----------------------------------------------------------------------- - SUBROUTINE TRANSF - INCLUDE 'COMDIF' - DIMENSION HOLD(3,3),HNEW(3,3),HNEWI(3,3),RNEW(3,3) - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - DO 100 I = 1,3 - 90 WRITE (COUT,11000) I - CALL FREEFM (ITR) - HOLD(1,I) = IFREE(1) - HOLD(2,I) = IFREE(2) - HOLD(3,I) = IFREE(3) - HNEW(1,I) = IFREE(4) - HNEW(2,I) = IFREE(5) - HNEW(3,I) = IFREE(6) - IF ((HOLD(1,I) .EQ. 0.0 .AND. HOLD(2,I) .EQ. 0.0 .AND. - $ HOLD(3,I) .EQ. 0.0) .OR. - $ (HNEW(1,I) .EQ. 0.0 .AND. HNEW(2,I) .EQ. 0.0 .AND. - $ HNEW(3,I) .EQ. 0.0)) THEN - WRITE (COUT,11100) - CALL GWRITE (ITP,' ') - GO TO 90 - ENDIF - 100 CONTINUE -C----------------------------------------------------------------------- -C Invert the IHNEW matrix and form RNEW = R.IHOLD.(IHNEW)-1 -C----------------------------------------------------------------------- - CALL MATRIX (HNEW,HNEWI,HNEWI,HNEWI,'INVERT') - CALL MATRIX (R,HOLD,RNEW,RJUNK,'MATMUL') - CALL MATRIX (RNEW,HNEWI,RNEW,RJUNK,'MATMUL') -C----------------------------------------------------------------------- -C Print the new matrix and parameters -C----------------------------------------------------------------------- - DO 110 I = 1,3 - DO 110 J = 1,3 - ROLD(I,J) = R(I,J)/WAVE - R(I,J) = RNEW(I,J) - RNEW(I,J) = RNEW(I,J)/WAVE - 110 CONTINUE -C----------------------------------------------------------------------- -C Evaluate the determinant to decide if right or left handed -C----------------------------------------------------------------------- - DET = R(1,1)*(R(2,2)*R(3,3) - R(2,3)*R(3,2)) - - $ R(1,2)*(R(2,1)*R(3,3) - R(2,3)*R(3,1)) + - $ R(1,3)*(R(2,1)*R(3,2) - R(2,2)*R(3,1)) - IF (NRC*DET .EQ. 0) THEN - WRITE (COUT,12000) - KI = ' ' - ELSE IF (NRC*DET .GT. 0) THEN - WRITE (COUT,13000) KI,((RNEW(I,J),J = 1,3),I = 1,3) - ELSE - WRITE (COUT,14000) KI,((RNEW(I,J),J = 1,3),I = 1,3) - ENDIF - CALL GWRITE (ITP,' ') - CALL GETPAR - DO 120 I = 1,3 - AP(I) = AP(I)*WAVE - 120 CONTINUE - WRITE (COUT,15000) AP,CANG - CALL GWRITE (ITP,' ') - RETURN -10000 FORMAT (10X,' Transform the Orientation Matrix'/ - $ ' Type in old and new h,k,l values for 3 reflections') -11000 FORMAT (' Type old and new h,k,l for reflection',I2,' ',$) -11100 FORMAT (' 0,0,0 indices not allowed. Try again.') -12000 FORMAT (' The determinant of the matrix is 0.') -13000 FORMAT (' New RIGHT-handed Orientation Matrix from ',A2/(3F12.8)) -14000 FORMAT (' New LEFT-handed Orientation Matrix from ',A2/(3F12.8)) -15000 FORMAT (' New Unit Cell ',3F9.4,3F9.3) - END diff --git a/difrac/difrac.f b/difrac/difrac.f deleted file mode 100644 index b8cc35fc..00000000 --- a/difrac/difrac.f +++ /dev/null @@ -1,245 +0,0 @@ -C----------------------------------------------------------------------- -C -C Diffractometer Control Routine for NRC Picker or Rigaku AFC6 -C E.J.Gabe and P.S White -C Chemistry Department , UNC, Chapel Hill, NC, USA -C -C This routine is based on the original NRC Picker routine for the PDP8 -C E.J. Gabe, Y. Le Page & D.F. Grant -C Chemistry Division, N.R.C., Ottawa, Canada. -C -C The original code has been cleaned up and brought to F77 standard. -C -C Key Function -C -C *** Terminal Data Input Commands *** -C -C AD Attenuator Data: number and values. -C BD all Basic Data (CZ DH FR LA OM OR PS RR SD SE TM TP) -C CZ Correct angle Zero values. -C FR First Reflection to be measured. -C LA LAmbda for the wavelength in use, usually alpha1. -C LN Liquid Nitrogen option - specific to cryosystem. -C OM Orientation Matrix. -C PS PSi rotation data. -C RO re-Orientation Reflections: frequency and h,k,ls. -C RR Reference Reflections: frequency and h,k,ls. -C SD Scan Data: type, width, speed, profile control. -C SE Systematic Extinctions. -C SG Space-Group symbol. -C TM 2Theta Min and max values. -C TP Time and Precision parameters for intensity measurement. -C -C *** Crystal Alignment Commands *** -C -C AL ALign reflections and their symmetry equivalents for MM. -C AR Align Resumption after interruption. -C A8 Align the 8 alternate settings of one reflection. -C CH CHoose reflections from the PK list for use with M2/M3. -C CR Centre the Reflection which is already in the detector. -C LC 2theta Least-squares Cell with symmetry constrained cell. -C MM Matrix from Many reflections by least-squares on AL data. -C M2 Matrix from 2 indexed reflections and a unit cell. -C M3 Matrix from 3 indexed reflections. -C OC Orient a Crystal, i.e. index the peaks from PK. -C PK PeaK search in 2Theta, Chi, Phi for use with OC. -C RC Reduce a unit Cell. -C RP Rotate Phi 360degs, centre and save any peaks found. -C RS ReSet the cell and matrix with the results from RC. -C -C *** Intensity Data Collection *** -C -C GO Start of intensity data collection. -C K Kill operation at the end of the current reflection. -C Q Quit after the next set of reference reflections. -C -C *** Angle Setting and Intensity Measurement *** -C -C GS Grid Search measurement in 2theta, omega or chi. -C IE Intensity measurement for Equivalent reflections. -C IM Intensity Measurement of the reflection in the detector. -C IP Intensity measurement in Psi for empirical absorption. -C IR Intensity measurement for specified Reflections. -C LP Line Profile plot on the printer. -C SA Set All angles to specified values. -C SC Set Chi to the specified value. -C SH SHutter open or close as a flip/flop. -C SO Set Omega to the specified value. -C SP Set Phi to the specified value. -C SR Set Reflection: h,k,l,psi. -C ST Set 2Theta to the specified value. -C TC Timed Counts. -C ZE ZEro the instrument Angles. -C -C *** Photograph Setup Commands *** -C -C PL Photograph in the Laue mode. -C PO Photograph in the Oscillation mode (same as OS). -C PR Photograph in the Rotation mode. -C -C *** General System Commands *** -C AH Angles to H,k,l (same as IX). -C AI Ascii Intensity data file conversion. -C AP Ascii Profile data file conversion. -C BC Big Chi search for psi rotation. -C BI Big Intensity search in the IDATA.DA file. -C EX EXit the program saving the basic data on IDATA.DA. -C HA H,k,l to Angles (same as RA). -C PA Print Angle settings. -C PD Print Data of all forms. -C Q Quit the program directly. -C RB Read the Basic data from the IDATA.DA file. -C SW SWitch register flags setting. -C UM (UMpty) Count unique reflections within theta limits. -C WB Write the Basic data to the IDATA.DA file. -C -C The program uses 2 main files:-- -C 1. On unit IID the file IDATA.DA contains all the permanent -C information for a data collection: -C 2. ON unit ISD the file ORIENT.DA is really a scratch file for -C use with the crystal orientation routines -C -C Both files are 'direct-access' with records of length 85 4-byte -C variables. -C -C The file IDATA.DA contains the following information:-- -C Record # Information -C 1,2,3 All the basic info for a particular data collection; -C 4 to 8 All symmetry info from SGROUP; -C 9 Automatic restart info for use after interruption; -C 16 to 19 Alignment data for ALIGN; -C 20 and up Intensity data, 10 reflns per record. -C -C There is a 9-bit switch register which can be changed with the SW -C command or during operation by typing any digit from 1 to 9. -C The switches control the following :-- -C -C 1. 0 normal screen display; 1 profile display. -C 2. 0 display raw profile data; 1 display smoothed data. -C 3. 0 dont print profiles; 1 print profiles on printer. -C 4. 0 print intensity data; 1 do not print intensity data. -C 5. 0 print standards data; 1 do not print standards. -C 6. 0 no action; 1 add 20 points to profile tolerance. -C 7. 0 no action; 1 add 10 points to profile tolerance. -C 8. 0 no action; 1 add 5 points to profile tolerance. -C 9. 0 no action; 1 write profiles to unit 7. -C -C Common to match the CREDUC Common /GEOM/ -C----------------------------------------------------------------------- - INCLUDE 'COMDIF' - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - COMMON /GEOM/ GJUNK(370) - IDH(1,1,1) = 1 - IDH(1,2,2) = 1 - IDH(1,3,3) = 1 - NOTEND = 0 - IKO(5) = -777 - ALPHA = 50.0 -C----------------------------------------------------------------------- -C Get the I/O unit numbers with SETIOU -C----------------------------------------------------------------------- - CALL SETIOU (IID,ISD,LPT,ITR,ITP,IBYLEN) - CALL WNSET (3) -C----------------------------------------------------------------------- -C Check that the angles did not change since the last time the -C program was stopped. -C----------------------------------------------------------------------- - CALL ANGVAL - WRITE (COUT,10000) DFMODL - CALL GWRITE (ITP,' ') - WRITE (COUT,12000) - CALL ALFNUM (ANS) - IF (ANS .EQ. 'F' .OR. ANS .EQ. 'f') THEN - OPEN (LPT, FILE = 'printer.out', STATUS = 'UNKNOWN') - WRITE (COUT,13000) - CALL GWRITE (ITP,' ') - ELSE IF (ANS .EQ. 'S' .OR. ANS .EQ. 's') THEN - LPT = ITP - ELSE - OPEN (LPT, FILE = 'LPT1', STATUS = 'UNKNOWN') - ENDIF -C----------------------------------------------------------------------- -C Open the Idata file (IID) and the scratch file (ISD) -C If either file does not exist, create it. -C----------------------------------------------------------------------- - DO 100 I = 1,85 - ACOUNT(I) = 0.0 - 100 CONTINUE - IDREC = 85*IBYLEN - STATUS = 'OD' - IDNAME = 'IDATA.DA' - LENID = 700 - CALL IBMFIL (IDNAME,IID,IDREC,STATUS,IERR) - IF (IERR .NE. 0) THEN - STATUS = 'DN' - CALL IBMFIL (IDNAME,IID,IDREC,STATUS,IERR) - KI = 'W2' - CALL WRBAS - KI = ' ' - DO 110 I = 4,20 - WRITE (IID,REC=I) (NOTEND,J = 1,85) - 110 CONTINUE - STATUS = 'DO' - CALL IBMFIL (IDNAME,-IID,IDREC,STATUS,IERR) - CALL IBMFIL (IDNAME, IID,IDREC,STATUS,IERR) - ELSE - KI = 'AN' - CALL WRBAS - ENDIF - STATUS = 'OD' - DSNAME = 'ORIENT.DA' - LENSD = 300 - CALL IBMFIL (DSNAME,ISD,IDREC,STATUS,IERR) - IF (IERR .NE. 0) THEN - WRITE (COUT,11000) DSNAME(1:9) - CALL GWRITE (ITP,' ') - STATUS = 'DN' - CALL IBMFIL (DSNAME,ISD,IDREC,STATUS,IERR) - DO 120 I = 1,300 - WRITE (ISD,REC=I) (NOTEND,J = 1,85) - 120 CONTINUE - STATUS = 'OD' - CALL IBMFIL (DSNAME,-ISD,IDREC,STATUS,IERR) - CALL IBMFIL (DSNAME, ISD,IDREC,STATUS,IERR) - ENDIF -C----------------------------------------------------------------------- -C All commands are read and interpreted in the routine SETOP using -C 2-letter codes only. -C----------------------------------------------------------------------- - 200 CALL SETOP - GO TO 200 -10000 FORMAT (/,10X,'Diffractometer Routine for Enraf-Nonius ',A /) -11000 FORMAT (' There is no file ',A,'. It will be created.') -12000 FORMAT (' Send output to Printer or File (P) ') -13000 FORMAT (' Printer output will be sent to the file PRINTER.OUT') - END -C----------------------------------------------------------------------- -C Block Data routine to initialize the COMMONs -C----------------------------------------------------------------------- - BLOCK DATA - INCLUDE 'COMDIF' - DATA ISCDEF,ICDDEF/150,250/,IDTDEF,IDODEF,IDCDEF/4,2,10/, - $ IFRDEF/100/,NRC/-1/,STEPDG/100.0/,ICADSL/60/,NATTEN/0/, - $ ATTEN/1.0,1.88,3.54,6.66,12.52,170.4/ - DATA KQFLG2/0/,IUPDWN/1/,IUMPTY/0/,IAUTO,NSET/0,1/,SGSYMB/10*0.0/, - $ DEG/57.2958/ - DATA R/0.070932,0,0, 0,0.070932,0, 0,0,0.070932/, - $ DTHETA,DOMEGA,DCHI/3*0/,NAXIS/2/, - $ THEMIN,THEMAX/2.0,100.0/, AS,BS,CS/1.0,0.7,1.0/, - $ DPSI,PSIMIN,PSIMAX/3*0.0/, TIME,QTIME,TMAX/10,0.5,10/, - $ PA,PM/2*1.0/, IHMAX,IKMAX,ILMAX/3*22/, WAVE/0.70932/, - $ NCOND/0/,ICOND,IHS,IKS,ILS,IR,IS/30*0/, - $ SPEED/4.0/, STEPOF/0.5/, IORNT/0/,NINTOR/0/ - DATA NSTAN/1/,NINTRR/100/,IHSTAN,IKSTAN,ILSTAN/4,17*0/,ISTAN/0/, - $ NSEG/1/,NMSEG/1/,NMSTAN/1/, NREF/0/, NBLOCK/20/, - $ IHO,IKO,ILO/24*0/, IND/3*0/, ITYPE/0/, JMIN,JMAX/16*0/, - $ AP/3*10.0/,APS/3*0.1/, - $ CANGS/3*0.0/,SANGS/3*1.0/,CANG/3*0.0/,SANG/3*1.0/, - $ RTHETA,ROMEGA,RCHI,RPHI/4*0.0/, IH,IK,IL/1,2,3/ - DATA IDH/72*0/, IBSECT,ISCAN/2*0/, FRAC/0.1/, IPRFLG/0/, - $ ISYS/1/, SINABS/3*0.00503135,3*0.0/, ILN/0/, DELAY/100/ - DATA COUT/20*' '/,IWNCUR/0/,ISREG/1,1,1,7*0/ - END - diff --git a/difrac/eulkap.f b/difrac/eulkap.f deleted file mode 100644 index 7864579d..00000000 --- a/difrac/eulkap.f +++ /dev/null @@ -1,50 +0,0 @@ -C----------------------------------------------------------------------- -C Convert Euler angles to Kappa (IEK = 0) or vice-versa (IEK = 1) -C----------------------------------------------------------------------- - SUBROUTINE EULKAP (IEK,OME,CHE,PHE,OMK,RKA,PHK,ISTTUS) - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - PARAMETER (RA = 57.2958) -C ALPHA = 49.98907 -C ALPHA = ALPHA/RA - SALPHA = SIN(ALPHA/RA) - CALPHA = COS(ALPHA/RA) - ISTTUS = 0 -C----------------------------------------------------------------------- -C IEK = 0 Euler to Kappa -C----------------------------------------------------------------------- - IF (IEK .EQ. 0) THEN - SCO2 = SIN(ONE80(CHE)/(2.0*RA)) - BOT = SALPHA*SALPHA - SCO2*SCO2 - IF (BOT .LE. 0.0) THEN - ISTTUS = 1 - RETURN - ENDIF - RKAO2 = ATAN(SCO2/SQRT(BOT)) - RKA = ONE80(2.0*RA*RKAO2) - DELTA = RA*ATAN(CALPHA*SIN(RKAO2)/COS(RKAO2)) - OMK = ONE80(OME - DELTA) - PHK = ONE80(PHE - DELTA) -C----------------------------------------------------------------------- -C IEK = 1 Kappa to Euler -C----------------------------------------------------------------------- - ELSE - RKAO2 = RKA/(2.0*RA) - CHE = ONE80(2.0*RA*ASIN(SALPHA*SIN(RKAO2))) - DELTA = RA*ATAN(CALPHA*SIN(RKAO2)/COS(RKAO2)) - OME = ONE80(OMK + DELTA) - PHE = ONE80(PHK + DELTA) - ENDIF - RETURN - END -C----------------------------------------------------------------------- -C Function to put angles in the range -180 to 180 -C----------------------------------------------------------------------- - REAL FUNCTION ONE80 (X) - XX = X - IF (X .LT. -180.00) XX = X + 360.00 - IF (X .GT. 180.00) XX = X - 360.00 - ONE80 = XX - RETURN - END diff --git a/difrac/fndsys.f b/difrac/fndsys.f deleted file mode 100644 index 25dc4bc1..00000000 --- a/difrac/fndsys.f +++ /dev/null @@ -1,399 +0,0 @@ -C----------------------------------------------------------------------- -C Find the crystal system -C----------------------------------------------------------------------- - SUBROUTINE FNDSYS (IOUT,DIRCOS,NPSUDO) - REAL LATIC,MAT - CHARACTER*6 SYSTEM,PSUDO,T2 - CHARACTER*4 T1,T3,CMODE - CHARACTER*132 COUT(20) - COMMON /IODEVS/ ITP,ITR,LPT,LPTX,NB,NBLOCK,ISD,IID, - $ IBYLEN,IPR,NPR,IIP - COMMON /IOUASC/ COUT - COMMON /GEOM/ AA(3,3),AINV(3,3),TRANS(3,3),RH(3,20),HH(3,20), - $ AANG(20),PH(3,20),PMESH(3,2,20),PERPAX(20),N2,N3, - $ EXPER - COMMON /TRANS/ BLINDR(3,3),TMATS(3,3,20),IFSYS(20),IFMODE(20), - $ NTMATS - DIMENSION LATIC(3,9,5),NDIR(5),NAMBI(5),NIND(5),TOT(2),ENGTH(3,2) - DIMENSION VEC(3,3,2),MAT(3,3,2),ALP(3),PSUDO(2,2) - DIMENSION CUBIC(3,9),HEXAG(3,7),RHOMB(3,4),TETRAG(3,5) - DIMENSION ORTHO(3,3),NAXES(3,2,5),MATCH(20),DIRCOS(3,20) - DIMENSION SYSTEM(2,7),ATM1(3,3),ATM2(3,3),TEST(3),RESULT(3) - DIMENSION T1(3),T2(3),T3(3) - EQUIVALENCE (LATIC(1,1,1),CUBIC(1,1)),(LATIC(1,1,2),HEXAG(1,1)) - EQUIVALENCE (LATIC(1,1,3),RHOMB(1,1)),(LATIC(1,1,4),TETRAG(1,1)) - EQUIVALENCE (LATIC(1,1,5),ORTHO(1,1)) -C----------------------------------------------------------------------- -C The number of even-order axes, of orientation ambiguities, -C of symmetry-unrelated axes -C----------------------------------------------------------------------- - DATA NDIR/9,7,3,5,3/,NAMBI/0,1,0,1,0/,NIND/2,3,1,2,1/ -C----------------------------------------------------------------------- -C The possible conventional axes -C----------------------------------------------------------------------- - DATA NAXES/1,3,4, 0,0,0, 1,5,3, 2,6,3, 1,2,4, 0,0,0, - $ 1,4,2, 5,3,2, 1,2,3, 0,0,0/ -C----------------------------------------------------------------------- -C The direction cosines of the even-order axes in the system -C----------------------------------------------------------------------- - DATA CUBIC / 1.0, 0, 0, .707,.707, 0, 0, 1, 0, - $ 0, 0, 1, .707, 0,.707, 0,.707,.707, - $ .707,-.707, 0, .707, 0,-.707, 0,.707,-.707/ - DATA HEXAG / .5,-.866,0, .866, -.5,0, 0,0,1, - $ .866, .5,0, .5,.866,0, 0,1,0, 1,0,0/ - DATA RHOMB / .5,-.866,0, .5,.866,0, -1,0,0, 0,0,1/ - DATA TETRAG/ 1,0,0, 0,0,1, .707,.707,0, 0,1,0, .707,-.707,0/ - DATA ORTHO / 1,0,0, 0,1,0, 0,0,1/ - DATA ACCEPT/.06/,TEST/.666667,.333333,.333333/ - DATA PSUDO/' Metri','cally ',' P','seudo '/ - DATA SYSTEM/' ',' Cubic',' Hex','agonal',' Hex','agonal', - $ ' Tetr','agonal','Orthor','hombic',' Mono','clinic', - $ ' Tri','clinic'/ - DATA T1 /'a ','b ','c '/,T2/'Alpha ','Beta ','Gamma '/ - DATA T3 /'a* ','b* ','c* '/ - NTMATS = 0 - 100 IF (NPSUDO .LT. 3) GO TO 390 -C----------------------------------------------------------------------- -C Consider the C,H,R,T and O systems -C----------------------------------------------------------------------- - ISYS = 1 -C----------------------------------------------------------------------- -C Consider rows in turn and call them primary -C----------------------------------------------------------------------- - 110 IPRIM = 1 -C----------------------------------------------------------------------- -C If not enough rows are left, no solution can be found, skip -C----------------------------------------------------------------------- - 120 IF (NPSUDO .LT. IPRIM + NDIR(ISYS) - 1) GO TO 240 -C----------------------------------------------------------------------- -C Consider symmetry-unrelated primary axes to be matched with -C the primary row -C----------------------------------------------------------------------- - IFIRST = 1 -C----------------------------------------------------------------------- -C Pick up a secondary row -C----------------------------------------------------------------------- - 130 ISEC = IPRIM + 1 -C----------------------------------------------------------------------- -C If not enough rows are left, skip -C----------------------------------------------------------------------- - 140 IF (NPSUDO .LT. ISEC + NDIR(ISYS) - 2) GO TO 230 -C----------------------------------------------------------------------- -C Get the angle between the two selected rows -C----------------------------------------------------------------------- - CALL MATRIX(DIRCOS(1,IPRIM),DIRCOS(1,ISEC),PRODOB,CRAP,'SCALPR') -C----------------------------------------------------------------------- -C Pick up a secondary even-order axis -C----------------------------------------------------------------------- - ITWO = 1 - 150 IF (ITWO .EQ. IFIRST) GO TO 220 -C----------------------------------------------------------------------- -C Calculate the angle between the primary and secondary axes -C----------------------------------------------------------------------- - CALL MATRIX(LATIC(1,IFIRST,ISYS),LATIC(1,ITWO,ISYS),PROCAL,CRAP, - $ 'SCALPR') -C----------------------------------------------------------------------- -C Try to match the obs and calc angles -C----------------------------------------------------------------------- - IF (PRODOB*PROCAL .GE. 0.) GO TO 170 - DO 160 I = 1,3 - RH(I,ISEC) = -RH(I,ISEC) - DIRCOS(I,ISEC) = -DIRCOS(I,ISEC) - 160 CONTINUE - PRODOB = -PRODOB - 170 IF (ABS(PRODOB - PROCAL) .GT. ACCEPT) GO TO 220 -C----------------------------------------------------------------------- -C The angles match, try to associate an obs row with each axis in -C the system -C----------------------------------------------------------------------- - DO 210 IANY = 1,NDIR(ISYS) -C----------------------------------------------------------------------- -C Get the hand of IFIRST, ITWO, IANY -C----------------------------------------------------------------------- - CALL MATRIX(LATIC(1,IFIRST,ISYS),LATIC(1,ITWO,ISYS), - $ LATIC(1,IANY,ISYS),HAND1,'DETERM') -C----------------------------------------------------------------------- -C Calculate angle of try axis with primary and secondary axes -C----------------------------------------------------------------------- - CALL MATRIX(LATIC(1,IFIRST,ISYS),LATIC(1,IANY,ISYS),PROC1,CRAP, - $ 'SCALPR') - CALL MATRIX(LATIC(1,ITWO,ISYS),LATIC(1,IANY,ISYS),PROC2,CRAP, - $ 'SCALPR') -C----------------------------------------------------------------------- -C Now find a row that could match this axis -C----------------------------------------------------------------------- - DO 200 ITRY = 1,NPSUDO - IS = 1 -C----------------------------------------------------------------------- -C Get the hand of IPRIM, ISEC, ITRY -C----------------------------------------------------------------------- - CALL MATRIX(DIRCOS(1,IPRIM),DIRCOS(1,ISEC),DIRCOS(1,ITRY), - $ HAND2,'DETERM') - CALL MATRIX(DIRCOS(1,ITRY),DIRCOS(1,IPRIM),PROD1,CRAP, - $ 'SCALPR') - CALL MATRIX(DIRCOS(1,ITRY),DIRCOS(1,ISEC),PROD2,CRAP,'SCALPR') - 180 IF (ABS(PROC1 - IS*PROD1) .GT. ACCEPT) GO TO 190 - IF (ABS(PROC2 - IS*PROD2) .GT. ACCEPT) GO TO 190 - IF (ABS(HAND2 - IS*HAND1) .GT. .1) GO TO 190 -C----------------------------------------------------------------------- -C This row is OK, remember it -C----------------------------------------------------------------------- - MATCH(IANY) = ITRY*IS - GO TO 210 - 190 IF (IS .EQ. -1) GO TO 200 - IS = -1 - GO TO 180 - 200 CONTINUE - GO TO 220 - 210 CONTINUE -C----------------------------------------------------------------------- -C We were able to associate a row with each axis in the system -C----------------------------------------------------------------------- - GO TO 250 - 220 ITWO = ITWO + 1 - IF (ITWO .LE. NDIR(ISYS)) GO TO 150 - ISEC = ISEC + 1 - IF (ISEC .LE. NPSUDO) GO TO 140 - 230 IFIRST = IFIRST + 1 - IF (IFIRST .LE. NIND(ISYS)) GO TO 130 - IPRIM = IPRIM + 1 - IF (IPRIM .LE. NPSUDO) GO TO 120 - 240 ISYS = ISYS + 1 - IF (ISYS .LE. 5) GO TO 110 - GO TO 390 -C----------------------------------------------------------------------- -C Find the worst-fitting row -C----------------------------------------------------------------------- - 250 MATMAX = 0 - DO 260 I = 1,NDIR(ISYS) - IF (ABS(MATCH(I)) .GT. MATMAX) MATMAX = ABS(MATCH(I)) - 260 CONTINUE -C----------------------------------------------------------------------- -C Does it fit within experimental accuracy? -C----------------------------------------------------------------------- - IP = 2 - IF (AANG(MATMAX) .LT. EXPER) IP = 1 -C----------------------------------------------------------------------- -C Find the conventional reference axes among the symmetry axes -C----------------------------------------------------------------------- - I = 1 - 270 J = 1 - 280 IAX = NAXES(J,I,ISYS) - IF (IAX .LE. NDIR(ISYS)) GO TO 300 -C----------------------------------------------------------------------- -C Rhombohedral, find the three-fold axis -C----------------------------------------------------------------------- - DO 290 I1 = N2 + 1, N3 - CALL MATRIX(DIRCOS(1,MATCH(1)),DIRCOS(1,MATCH(2)),DIRCOS(1,I1), - $ DET2,'DETERM') - ISG = 1 - IF (DET2 .LT. 0.) ISG = -1 - IF (ABS(ABS(DET2) - 0.866).GT.0.1) GO TO 290 - MATCH(IAX) = I1 * ISG - GO TO 300 - 290 CONTINUE -C----------------------------------------------------------------------- -C No three-fold axis, next combination of twofolds -C----------------------------------------------------------------------- - GO TO 220 - 300 NAX = IABS(MATCH(IAX)) - IS = 1 - IF (MATCH(IAX) .LT. 0) IS = -1 -C----------------------------------------------------------------------- -C Store the direction cosines and the primitive indices of the -C conventional axes -C----------------------------------------------------------------------- - DO 310 K = 1,3 - VEC(K,J,I) = IS*DIRCOS(K,NAX) - MAT(K,J,I) = IS*RH(K,NAX) - 310 CONTINUE -C----------------------------------------------------------------------- -C Get the length of the conventional cell edges -C----------------------------------------------------------------------- - CALL MATRIX(AA,MAT(1,J,I),ENGTH(J,I),CRAP,'LENGTH') - J = J + 1 - IF (J .LE. 3) GO TO 280 - I = I + 1 - IF (I .LE. NAMBI(ISYS) + 1) GO TO 270 -C----------------------------------------------------------------------- -C Keep the solution with the shortest cell edges -C----------------------------------------------------------------------- - TOT(2) = 1.E6 - DO 320 I = 1,NAMBI(ISYS) + 1 - TOT(I) = 0 - DO 320 J = 1,3 - TOT(I) = TOT(I) + ENGTH(J,I) - 320 CONTINUE - I = 1 - IF (TOT(2) .LT. TOT(1)) I = 2 -C----------------------------------------------------------------------- -C Rank the orthorhombic axes a SICS - WRITE (COUT,11000) KQ,IH,IK,IL,NREF,NSET,NMSEG,NBLOCK - CALL GWRITE(IPT,' ') - IF (ISEG .NE. 0) THEN - IND(1) = 0 - IND(2) = 0 - IND(3) = 0 - WRITE (LPT, 12000) NBLOCK - WRITE (COUT,12000) NBLOCK - CALL GWRITE (ITP,' ') - ENDIF - IF (IAUTO .EQ. 1) THEN - SAVE = NBLOCK - IRES = 1 - WRITE (IID,REC=9) IRES,IHO(8),IKO(8),ILO(8),NSET,IHO(6),IHO(5) - NBLOCK = SAVE - ENDIF - KI = 'W2' - CALL WRBAS - KI = ' ' - RETURN - ELSE -C----------------------------------------------------------------------- -C It is the end of a segment and maybe the end of data collection. -C----------------------------------------------------------------------- - IND(1) = 0 - IND(2) = 0 - IND(3) = 0 - WRITE (LPT, 12000) NBLOCK - WRITE (COUT,12000) NBLOCK - CALL GWRITE (ITP,' ') - IF (NMSEG .LE. NSEG) THEN - KI = 'GO' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Check if it is the end of data collection in automatic mode ? -C----------------------------------------------------------------------- - IF (IAUTO .EQ. 1) THEN -C----------------------------------------------------------------------- -C Get the next set parameters in the automatic mode -C----------------------------------------------------------------------- - CALL NEXSEG - IF (NSET .NE. 0) THEN - KI = 'GO' - RETURN - ELSE - IAUTO = 0 - ENDIF - ENDIF - CALL SHUTTR (-99) -C------- modified: MK --> IO to SICS instead of LPT - WRITE (COUT,13000) - CALL GWRITE(ITP,' ') - KI = ' ' - RETURN - ENDIF -10000 FORMAT (3I4,' Scan Collision in GOLOOP') -11000 FORMAT (10X,A1,'-stop. Restart at'/ - $ 3I4,', number',I5,' in set',I3,' segment',I2, - $ ' at Idata Record',I4) -12000 FORMAT (10X,'End of Segment. Start next data at Record',I4) -13000 FORMAT (10X,'End of Data Collection ---- HURRAY !!') - END diff --git a/difrac/goniom.ini b/difrac/goniom.ini deleted file mode 100644 index 4a9c89ab..00000000 --- a/difrac/goniom.ini +++ /dev/null @@ -1,39 +0,0 @@ -/ The first value is the machine model code. -/ Present values can be CAD4 R-6S 145D or other if wanted -Dfmodl CAD4 -/ The next 2 values are the COM port number and baudrate -Port 1 -Baud 9600 -/ The next 11 values are those printed by CASPAR in the E-N program, -/ except for Termbd -Hivolt 774 -Lolevl 300 -Window 700 -Deadtm 2.0 -Termbd 9600 -Thgain 18 -Phgain 26 -Omgain 20 -Kagain 24 -Digain 24 -Milamp 40 -/ The next 12 values are those from GCONST, except that the angle Alpha -/ is given in degrees. ( CON2 = cos(Alpha) ) -Alpha 49.977 -Apmax 5.9 -Apmin 1.3 -/ The next 9 values for dial settings are octal. -Maxvar 2443 -Minvar 277 -Upperh 3731 -Lowerh 3477 -Negsl 3001 -Possl 3135 -Vslit 3315 -Hslit 77 -Hole 2570 -/ The next 4 values are the Euler angles for microscope viewing -Vutht 293.0 -Vuome 223.0 -Vuchi 315.0 -Vuphi 355.0 diff --git a/difrac/grid.f b/difrac/grid.f deleted file mode 100644 index 39b949a0..00000000 --- a/difrac/grid.f +++ /dev/null @@ -1,195 +0,0 @@ -C----------------------------------------------------------------------- -C dimensional grid of points. -C The grid is specified by from 1 to 3 start & end angles, -C 2Theta, Omega & Chi and the step size in each. -C If the step size for any angle is zero that angle is not varied. -C The counting-time/step is also needed. -C----------------------------------------------------------------------- - SUBROUTINE GRID - INCLUDE 'COMDIF' - CHARACTER ANGLES(3)*8 - DIMENSION ANG(3),ANSTRT(3),ANSTOP(3),ANSTEP(3),NNN(3),ICOUNT(500) - EQUIVALENCE (ACOUNT(1),ICOUNT(1)) - DATA ANGLES/'2THETA ',' OMEGA ',' CHI '/ - NATT = 0 -C----------------------------------------------------------------------- -C Verify command GD and then read grid specifications -C----------------------------------------------------------------------- - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - WRITE (COUT,12000) - CALL GWRITE (ITP,' ') - DO 100 I = 1,3 - WRITE (COUT,13000) ANGLES(I) - CALL FREEFM (ITR) - ANSTRT(I) = RFREE(1) - ANSTOP(I) = RFREE(2) - CALL MOD360 (ANSTRT(I)) - CALL MOD360 (ANSTOP(I)) - ANSTEP(I) = RFREE(3) - ANSTEP(I) = ANSTEP(I) - 100 CONTINUE - WRITE (COUT,15000) - CALL FREEFM (ITR) - TIMSTP = RFREE(1) - IF (TIMSTP .EQ. 0) TIMSTP = 100.0 -C----------------------------------------------------------------------- -C Work out the heading -C----------------------------------------------------------------------- - CALL ANGET (THETA,OMEGA,CHI,PHI) - ANG(1) = THETA - ANG(2) = OMEGA - ANG(3) = CHI - OMOFF = 0.0 - DO 110 I = 1,3 - IF (ANSTEP(I) .EQ. 0) THEN - ANSTRT(I) = ANG(I) - ANSTOP(I) = ANG(I) - NNN(I) = 0 - ELSE - DEL1 = ANSTOP(I) - ANSTRT(I) - IF (DEL1 .GT. 0.0) THEN - DEL2 = DEL1 - 360.0 - ELSE - DEL2 = DEL1 + 360.0 - ENDIF - IF (ABS(DEL2) .LT. ABS(DEL1)) DEL1 = DEL2 - IF (DEL1 .LT. 0.0) ANSTEP(I) = -ABS(ANSTEP(I)) - NNN(I) = DEL1/ANSTEP(I) + 1.5 - ENDIF - ANG(I) = ANSTRT(I) - IF (I .EQ. 1) OMOFF = 0.5*(ANG(1) - THETA) - IF (I .EQ. 2) ANG(2) = ANG(2) - OMOFF - 110 CONTINUE -C----------------------------------------------------------------------- -C Work out the grid loop control and grid header print. -C The grid is such that if :-- -C theta is stepped it is always fastest, then omega, then chi. -C IFIRST, ISECND or ITHIRD 1 means theta, 2 omega, 3 chi. -C NFIRST, NSECND or NTHIRD are the number of steps on that axis. -C----------------------------------------------------------------------- - IFIRST = 0 - ISECND = 0 - ITHIRD = 0 - NFIRST = 1 - NSECND = 1 - NTHIRD = 1 -C----------------------------------------------------------------------- -C Theta variation -C----------------------------------------------------------------------- - IF (ANSTEP(1) .NE. 0.0) THEN - IFIRST = 1 - NFIRST = NNN(1) - ENDIF -C----------------------------------------------------------------------- -C Omega variation -C----------------------------------------------------------------------- - IF (ANSTEP(2) .NE. 0.0) THEN - IF (NFIRST .EQ. 1) THEN - NFIRST = NNN(2) - IFIRST = 2 - ELSE - NSECND = NNN(2) - ISECND = 2 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Chi variation -C----------------------------------------------------------------------- - IF (ANSTEP(3) .NE. 0.0) THEN - IF (NSECND .EQ. 1) THEN - IF (NFIRST .EQ. 1) THEN - NFIRST = NNN(3) - IFIRST = 3 - ELSE - NSECND = NNN(3) - ISECND = 3 - ENDIF - ELSE - NTHIRD = NNN(3) - ITHIRD = 3 - ENDIF - ENDIF - WRITE (COUT,16000) - $ ANGLES(IFIRST),ANSTRT(IFIRST),NFIRST,ANSTOP(IFIRST) - CALL GWRITE (ITP,' ') - IF (ISECND .NE. 0) THEN - WRITE (COUT,16100) ANGLES(ISECND),ANSTRT(ISECND),NSECND, - $ ANSTOP(ISECND) - CALL GWRITE (ITP,' ') - ENDIF - IF (ITHIRD .NE. 0) THEN - WRITE (COUT,16200) ANGLES(ITHIRD),ANSTRT(ITHIRD),NTHIRD, - $ ANSTOP(ITHIRD) - CALL GWRITE (ITP,' ') - ENDIF -C----------------------------------------------------------------------- -C Now scan the grid in the correct order -C----------------------------------------------------------------------- - IF (NSECND .EQ. 0) NSECND = 1 - IF (NTHIRD .EQ. 0) NTHIRD = 1 - CALL SHUTTR (99) - DO 140 N3 = 1,NTHIRD - ANG2SV = ANG(2) - DO 130 N2 = 1,NSECND - DO 120 N1 = 1,NFIRST - CALL ANGSET (ANG(1),ANG(2),ANG(3),PHI,0,ICOL) - IF (ICOL .NE. 0) THEN - WRITE (COUT,18000) - CALL GWRITE (ITP,' ') - CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICOL) - KI = ' ' - RETURN - ENDIF - CALL CCTIME (TIMSTP,COUNT) - ICOUNT(N1) = COUNT - ANG(IFIRST) = ANG(IFIRST) + ANSTEP(IFIRST) - CALL MOD360 (ANG(IFIRST)) - IF (IFIRST .EQ. 1) THEN - ANG(2) = ANG(2) - 0.5*ANSTEP(1) - CALL MOD360 (ANG(2)) - ENDIF - 120 CONTINUE - WRITE (COUT,19000) (ICOUNT(I),I = 1,NFIRST) - CALL GWRITE (ITP,' ') - ANG(IFIRST) = ANSTRT(IFIRST) - IF (ISECND .NE. 0) THEN - ANG2SV = ANG2SV + ANSTEP(ISECND) - ANG(ISECND) = ANG2SV - CALL MOD360 (ANG(ISECND)) - ENDIF - 130 CONTINUE - IF (ISECND .NE. 0) ANG(ISECND) = ANSTRT(ISECND) - IF (ITHIRD .NE. 0) THEN - ANG(ITHIRD) = ANG(ITHIRD) + ANSTEP(ITHIRD) - CALL MOD360 (ANG(ITHIRD)) - ENDIF - IF (ITHIRD .EQ. 3 .AND. N3 .LT. NTHIRD) THEN - WRITE (COUT,17000) ANG(ITHIRD) - CALL GWRITE (ITP,' ') - ENDIF - 140 CONTINUE - CALL SHUTTR (-99) - CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICOL) - KI = ' ' - RETURN -10000 FORMAT (' Sample an Angular Grid (Y) ? ',$) -12000 FORMAT (' Type the grid specs.'/ - $ ' A response of is interpreted as no variation of', - $ ' of that axis.'/) -13000 FORMAT (' Type start, end & step for ',A,' ',$) -15000 FORMAT (' Counting preset per step (1000) ',$) -16000 FORMAT (1X,A,' ACROSS page, from',F8.3,' in',I3, - $ ' steps, to ',F8.3) -16100 FORMAT (1X,A,' DOWN page, from',F8.3,' in',I3, - $ ' steps, to ',F8.3) -16200 FORMAT (1X,A,' SECTIONS, from',F8.3,' in',I3, - $ ' steps, to ',F8.3) -17000 FORMAT (' Chi Incremented to ',F8.3) -18000 FORMAT (' Collision') -19000 FORMAT (10I7) - END diff --git a/difrac/gwrite.f b/difrac/gwrite.f deleted file mode 100644 index 48f3c319..00000000 --- a/difrac/gwrite.f +++ /dev/null @@ -1,115 +0,0 @@ -C----------------------------------------------------------------------- -C Routines to perform consol I/O -C----------------------------------------------------------------------- - SUBROUTINE GWRITE (IDEV,DOLLAR) - CHARACTER DOLLAR*(*) - CHARACTER*132 COUT - COMMON /IOUASC/ COUT(20) - COMMON /IOUASS/ IOUNIT(10) - CHARACTER CR*1,LF*1,CRLF*2,STATUS*2 - CR = CHAR(13) - LF = CHAR(10) - CRLF(1:1) = CR - CRLF(2:2) = LF - ITP = IOUNIT(6) -C----------------------------------------------------------------------- -C First find out how many lines to output -C----------------------------------------------------------------------- - DO 100 I = 20,1,-1 - IF (COUT(I) .NE. ' ') GO TO 110 - 100 CONTINUE -C----------------------------------------------------------------------- -C Must be just a blank line. Only here for safety - should not happen. -C----------------------------------------------------------------------- - I = 1 - 110 NLINES = I - IF (COUT(NLINES)(1:1) .EQ. '%') COUT(NLINES)(1:1) = ' ' -C----------------------------------------------------------------------- -C If the unit is not ITP then just do straight output to the device -C----------------------------------------------------------------------- - IF (IDEV .NE. ITP) THEN - IF (NLINES .GT. 1) THEN - DO 120 I = 1,NLINES-1 - WRITE (IDEV,10200) COUT(I)(1:LINELN(COUT(I))) - 120 CONTINUE - ENDIF - IF (DOLLAR .EQ. '$') THEN - WRITE (IDEV,10000) COUT(NLINES)(1:LINELN(COUT(I))) - ELSE IF (DOLLAR .EQ. '%') THEN - WRITE (IDEV,10100) COUT(NLINES)(1:LINELN(COUT(I))) - ELSE - WRITE (IDEV,10200) COUT(NLINES)(1:LINELN(COUT(I))) - ENDIF - ELSE -C----------------------------------------------------------------------- -C Unit is ITP. Output in Windows compatible form. -C----------------------------------------------------------------------- - IF (NLINES .GT. 1) THEN - DO 130 I = 1,NLINES-1 - CALL WNTEXT (COUT(I)(1:LINELN(COUT(I)))) - CALL SCROLL - 130 CONTINUE - ENDIF - CALL WNTEXT (COUT(NLINES)(1:LINELN(COUT(NLINES)))) - IF (DOLLAR .EQ. '$') THEN - CALL WNTEXT (' ') - ELSE - IF (DOLLAR .NE. '%') CALL SCROLL - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Blank out COUT in case some compilers dont -C----------------------------------------------------------------------- - DO 140 I = 1,20 - COUT(I) = ' ' - 140 CONTINUE - RETURN -10000 FORMAT (A,' ',$) -10100 FORMAT (A,$) -10200 FORMAT (A) - END -C----------------------------------------------------------------------- -C Function to return the length of a character string -C----------------------------------------------------------------------- - INTEGER FUNCTION LINELN (STRING) - CHARACTER STRING*(*) - DO 10 I = LEN(STRING),1,-1 - IF (STRING(I:I) .NE. ' ') GO TO 20 -10 CONTINUE - I = 0 -20 LINELN = I - RETURN - END -C----------------------------------------------------------------------- -C GETLIN Read a line of input from the keyboard -C----------------------------------------------------------------------- - SUBROUTINE GETLIN (STRING) - COMMON /IOUASS/ IOUNIT(10) - CHARACTER STRING*(*) - ITR = IOUNIT(5) - READ (ITR,10000) STRING -10000 FORMAT (A) - RETURN - END -C----------------------------------------------------------------------- -C WNTEXT Output text to a window -C----------------------------------------------------------------------- - SUBROUTINE WNTEXT (STRING) - COMMON /IOUASS/ IOUNIT(10) - CHARACTER STRING*(*) - ITP = IOUNIT(6) - WRITE (ITP,10000) STRING -10000 FORMAT (A,$) - RETURN - END -C----------------------------------------------------------------------- -C SCROLL Output a new-line -C----------------------------------------------------------------------- - SUBROUTINE SCROLL - COMMON /IOUASS/ IOUNIT(10) - ITP = IOUNIT(6) - WRITE (ITP,10000) -10000 FORMAT (1X) - RETURN - END - diff --git a/difrac/ibmfil.f b/difrac/ibmfil.f deleted file mode 100644 index b770d693..00000000 --- a/difrac/ibmfil.f +++ /dev/null @@ -1,184 +0,0 @@ -C----------------------------------------------------------------------- -C -C Subroutine IBMFIL to OPEN and CLOSE all files for the NRCVAX system -C -C The need for this routine was caused by the inability of Unix and -C MS/DOS to interpret global symbols transparently during OPEN and -C CLOSE statements. NRCVAX only uses one such symbol GROUPS, which -C must be expanded before attempting to open the actual files involved. -C -C The routine essentially performs a straight OPEN or CLOSE function, -C once the actual file-name is known. -C The specification of the RECL parameter for SEQUENTIAL files is -C NOT standard F77 and is included only for writing plot files. -C -C The calling sequence is as follows :-- -C -C CALL IBMFIL (ACTUAL,IUNIT,IBMREC,ST,IERR) -C -C The parameters are :-- -C ACTUAL - the actual file name as in all sensible computers -C IUNIT - the unit number; negative to CLOSE file -C IBMREC - the record length for all files. Non-standard F77 -C Only required for direct-access files. -C ST - a 2-character STATUS/ACCESS code made up as follows, -C For OPEN statements : -C N, O, U or T for NEW, OLD, UNKNOWN or SCRATCH -C S or D for SEQUENTIAL or DIRECT. -C F can be specified for UNformatted files, which are then -C assumed to be Sequential. -C L is used only in the VAX to specify -C CARRIAGECONTROL = 'LIST' -C If blanks are used the defaults are U and S. -C Files are assumed to be Formatted for S & Unformatted for D -C For CLOSE statements : -C As above except, -C DE means delete the file after closing -C IERR - Error flag returned. 0 for OK. -C -C----------------------------------------------------------------------- - SUBROUTINE IBMFIL (ACTUAL,IUNIT,IBMREC,STT,IERR) - INCLUDE 'IATSIZ' - CHARACTER ACTUAL*(*),STT*(*),ST*2,SA*2,STATUS*8, - $ FORM*12,ACCESS*12,CARRIJ*8,WORK*128 - DIMENSION STUFF(100) - ST(1:2) = STT(1:2) - IERR = 0 - LENGTH = IBMREC -C----------------------------------------------------------------------- -C Is the call for an OPEN or CLOSE function ? -C----------------------------------------------------------------------- - IF (IUNIT .LT. 0) THEN -C----------------------------------------------------------------------- -C **** It is a CLOSE **** -C -C For Sun machines find the end of direct-access files and rewrite the -C last record to prevent the file being truncated. -C----------------------------------------------------------------------- - STATUS = 'KEEP' - IUNIT = -IUNIT - IF (ST .EQ. 'DE') THEN - STATUS = 'DELETE' - ELSE -C IF (MNCODE .EQ. 'UNXSUN' .OR. MNCODE .EQ. 'UNXSGI') THEN - IF (MNCODE .EQ. 'UNXSUN') THEN - INQUIRE (UNIT = IUNIT, ACCESS = ACCESS, RECL = LENSUN) - IF (ACCESS(1:3) .EQ. 'DIR') THEN - IVLEN = 4 - IF (MNCODE .EQ. 'UNXSGI') IVLEN = 1 - CALL LENFIL (IUNIT,LASTBL) - LENVAR = LENSUN/IVLEN - READ (IUNIT,REC = LASTBL) (STUFF(J),J = 1,LENVAR) - WRITE (IUNIT,REC = LASTBL) (STUFF(J),J = 1,LENVAR) - ENDIF - ENDIF - ENDIF - CLOSE (UNIT = IUNIT, STATUS = STATUS) - RETURN - ELSE -C----------------------------------------------------------------------- -C **** It is an OPEN **** -C -C For Unix and MS/DOS machines get the full name from the ACTUAL name. -C This allows names to be expanded across sub-directories if the ACTUAL -C name is GROUPS. In UNIX this should have a SETENV statement in -C .cshrc to expand the name to the full local name. -C -C *** The call to GETENV should be uncommented for Unix machines *** -C -C----------------------------------------------------------------------- - LENAME = LEN(ACTUAL) - DO 120 I = 1,LENAME - J = LENAME + 1 - I - IF (ACTUAL(J:J) .NE. ' ') GO TO 130 - 120 CONTINUE - 130 LENAME = J - WORK = ACTUAL - IF (MNCODE .NE. 'VAXVMS') then - IF (MNCODE .EQ. 'PCMSDS') THEN -c -c Avoid a compiler problem with '\'. char(92) is '\'! -c -CCC IF (ACTUAL .EQ. 'GROUPS') WORK = '\NRCVAX\GROUPS.DAT' - IF (ACTUAL .EQ. 'GROUPS') - + WORK = char(92) // 'NRCVAX' // char(92) // 'GROUPS.DAT' -C ELSE -C IF (ACTUAL .EQ. 'GROUPS') -C $ CALL GETENV (ACTUAL(1:LENAME),WORK) - ENDIF - ENDIF -C----------------------------------------------------------------------- -C The ST code can be in any form of -C N, O, U, T or blank with D, S, F, L or blank in any order. -C----------------------------------------------------------------------- - SA = ST - FORM = 'FORMATTED' - IF (ST(1:1) .EQ. 'F' .OR. ST(2:2) .EQ. 'F') THEN - FORM = 'UNFORMATTED' - IF (ST(1:1) .EQ. 'F') ST(1:1) = ' ' - IF (ST(2:2) .EQ. 'F') ST(2:2) = ' ' - ENDIF - CARRIJ = 'FORTRAN' - IF (ST(1:1) .EQ. 'L' .OR. ST(2:2) .EQ. 'L') THEN - CARRIJ = 'LIST' - IF (ST(1:1) .EQ. 'L') ST(1:1) = ' ' - IF (ST(2:2) .EQ. 'L') ST(2:2) = ' ' - ENDIF - IF (ST .EQ. 'DN') SA = 'ND' - IF (ST .EQ. 'DO') SA = 'OD' - IF (ST .EQ. 'ST') SA = 'TS' - IF (ST .EQ. 'DT') SA = 'TD' - IF (ST .EQ. ' N' .OR. ST .EQ. 'N ' .OR. ST .EQ. 'SN') SA = 'NS' - IF (ST .EQ. ' O' .OR. ST .EQ. 'O ' .OR. ST .EQ. 'SO') SA = 'OS' - IF (ST .EQ. ' D' .OR. ST .EQ. 'D ' .OR. ST .EQ. 'DU') SA = 'UD' - IF (ST .EQ. ' ' .OR. ST .EQ. ' S' .OR. ST .EQ. 'S ' .OR. - $ ST .EQ. ' U' .OR. ST .EQ. 'U ' .OR. ST .EQ. 'SU') SA = 'US' - STATUS = 'UNKNOWN' - IF (SA(1:1) .EQ. 'N') STATUS = 'NEW' - IF (SA(1:1) .EQ. 'O') STATUS = 'OLD' - IF (SA(1:1) .EQ. 'T') STATUS = 'SCRATCH' - ACCESS = 'SEQUENTIAL' - IF (SA(2:2) .EQ. 'D') THEN - ACCESS = 'DIRECT' - FORM = 'UNFORMATTED' - ENDIF -C----------------------------------------------------------------------- -C Open the file at last. Safeguard the record length for VAX -C The first OPEN statement (for the VAX) must be commented out in -C versions for other computers -C----------------------------------------------------------------------- - IF (LENGTH .EQ. 0) LENGTH = 80 - IF (MNCODE .EQ. 'VAXVMS') THEN -C OPEN (UNIT = IUNIT, FILE = WORK, STATUS = STATUS, -C $ ACCESS = ACCESS, FORM = FORM, RECL = LENGTH, -C $ CARRIAGECONTROL = CARRIJ, ERR = 200) - CONTINUE - ELSE - IF (STATUS .NE. 'SCRATCH') THEN - IF (ACCESS .EQ. 'DIRECT') THEN - OPEN (UNIT = IUNIT, FILE = WORK, STATUS = STATUS, - $ ACCESS = ACCESS, FORM = FORM, RECL = LENGTH, - $ ERR = 200) - ELSE - OPEN (UNIT = IUNIT, FILE = WORK, STATUS = STATUS, - $ ACCESS = ACCESS, FORM = FORM, ERR = 200) - ENDIF - ELSE - IF (ACCESS .EQ. 'DIRECT') THEN - OPEN (UNIT = IUNIT, STATUS = STATUS, - $ ACCESS = ACCESS, FORM = FORM, RECL = LENGTH, - $ ERR = 200) - ELSE - OPEN (UNIT = IUNIT, STATUS = STATUS, - $ ACCESS = ACCESS, FORM = FORM, ERR = 200) - ENDIF - ENDIF - ENDIF - RETURN - ENDIF -C----------------------------------------------------------------------- -C Some sort of error was made. Go back and try again probably. -C----------------------------------------------------------------------- - 200 IERR = 1 - RETURN - END diff --git a/difrac/iedevs.f b/difrac/iedevs.f deleted file mode 100644 index b1f56073..00000000 --- a/difrac/iedevs.f +++ /dev/null @@ -1,49 +0,0 @@ -C----------------------------------------------------------------------- -C Setup permitted device types: -C ITERM is the generic type and ITERM2 is a specific device. -C Note that values for ITERM2 can be duplicated as long as ITERM -C is different. In particular the values of ITERM2 for the PC -C refer to specific video modes and should not be changed. -C -C Feel free to add to this list. -C----------------------------------------------------------------------- - INTEGER TEK, T4010, T4663, VT340, T4107, - $ QMSTEK, LN03TK, W99GT, - $ HPGL, - $ POSTSC, - $ PC, CGA, HERC, EGAM, EGA, - $ MCGA, VGAM, VGA, - $ X11, - $ RASTER, EPSON, PROPRT, PRINTX, IMAGEW - PARAMETER (TEK = 1, HPGL = 2, POSTSC = 3, PC = 4, - $ RASTER = 5, X11 = 6) - PARAMETER (T4010 = 11, T4663 = 12, VT340 = 13, T4107 = 14, - $ QMSTEK = 15, LN03TK = 16, W99GT = 17) - PARAMETER (CGA = 6, HERC = 8, EGAM = 15, EGA = 16, - $ MCGA = 17, VGAM = 17, VGA = 18) - PARAMETER (EPSON = 51, PROPRT = 52, PRINTX = 53, IMAGEW = 54) -C----------------------------------------------------------------------- -C The following common block defines the current devices and their -C resolutions. This block is for EDRAW internal use only -C----------------------------------------------------------------------- - INTEGER ITERM, ITERM2, ITSAV1, ITSAV2, - $ EDXRES, EDYRES, EDFCOL, EDBCOL, - $ EDDASH, EDIX, EDIY, EDTSIZ - REAL PCXMUL, PCYMUL - COMMON /EDEVS/ ITERM, ITERM2, ITSAV1, ITSAV2, - $ EDXRES, EDYRES, EDFCOL, EDBCOL, - $ EDDASH, EDIX, EDIY, EDTSIZ, - $ PCXMUL, PCYMUL - CHARACTER*12 TERMTP, TERMGR, PRINTR, PRINTP, PLOTR, PLOTP - COMMON /IEDEVC/ TERMTP, TERMGR, PRINTR, PRINTP, PLOTR, PLOTP -C----------------------------------------------------------------------- -C The following defines the codes for CXDRAW. -C NOTE: If you change these you must also change the definitions in -C CXDRAW.C -C----------------------------------------------------------------------- - INTEGER XOPEN, XCLOSE, XMOVE, XDRAW, XDRAWD, XCLEAR, - $ XWRITE, XFLUSH, XFGCOL, XBGCOL, XCROSS, XCHSIZ - PARAMETER ( XOPEN = 1, XCLOSE = 2, XMOVE = 3, XDRAW = 4, - $ XDRAWD = 5, XCLEAR = 6, XWRITE = 7, XFLUSH = 8, - $ XFGCOL = 9, XBGCOL = 10,XCROSS = 11,XCHSIZ = 12) - \ No newline at end of file diff --git a/difrac/inchkl.f b/difrac/inchkl.f deleted file mode 100644 index 6d0df4be..00000000 --- a/difrac/inchkl.f +++ /dev/null @@ -1,81 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to increment the indices with the DH segment scheme. -C Incrementing is done up one row of h2 and down the next row of h2, -C on each level of h1. -C IUPDWN = 1 at the start of each level of h1 -C ISEG = 0 if the next refln is OK, = 1 if the end of segment. -C----------------------------------------------------------------------- - SUBROUTINE INCHKL - INCLUDE 'COMDIF' - INTEGER IHSAVE,IKSAVE,ILSAVE - ISEG = 0 - IH = IH + NDH(1,3)*IUPDWN - IK = IK + NDH(2,3)*IUPDWN - IL = IL + NDH(3,3)*IUPDWN - IX = IABS(IH) - IY = IABS(IK) - IZ = IABS(IL) -C----------------------------------------------------------------------- -C IUPDWN = 1 Increment h3 up towards IHMAX,IKMAX,ILMAX -C----------------------------------------------------------------------- - IF (IUPDWN .GT. 0) THEN - IF (IX.LT.IHMAX .AND. IY.LT.IKMAX .AND. IZ.LT.ILMAX) RETURN -C----------------------------------------------------------------------- -C H3 going up has run out. Prepare for going down -C----------------------------------------------------------------------- - IHSAVE = IH + NDH(1,2) - IKSAVE = IK + NDH(2,2) - ILSAVE = IL + NDH(3,2) - ELSE -C----------------------------------------------------------------------- -C IUPDWN = -1 Increment h3 down towards FSTHKL(I,2) -C----------------------------------------------------------------------- - IF (ISTOP .NE. 1) THEN - ISTOP = 0 - IF (IH .NE. IFSHKL(1,2) .OR. IK .NE. IFSHKL(2,2) .OR. - $ IL .NE. IFSHKL(3,2)) RETURN - ISTOP = 1 - RETURN - ENDIF - ISTOP = 0 -C----------------------------------------------------------------------- -C H3 going down has run out. Prepare for going up. -C----------------------------------------------------------------------- - IHSAVE = IFSHKL(1,2) + NDH(1,2) - IKSAVE = IFSHKL(2,2) + NDH(2,2) - ILSAVE = IFSHKL(3,2) + NDH(3,2) - ENDIF - IUPDWN = -IUPDWN - DO 100 I = 1,3 - IFSHKL(I,2) = IFSHKL(I,2) + NDH(I,2) - IFSHKL(I,3) = IFSHKL(I,2) - 100 CONTINUE - IX = IABS(IFSHKL(1,3)) - IY = IABS(IFSHKL(2,3)) - IZ = IABS(IFSHKL(3,3)) -C----------------------------------------------------------------------- -C Start of new level of h1. Set IUPDWN = 1 -C----------------------------------------------------------------------- - IF (IX .GE. IHMAX .OR. IY .GE. IKMAX .OR. IZ .GE. ILMAX) THEN - IUPDWN = 1 - DO 120 I = 1,3 - IFSHKL(I,1) = IFSHKL(I,1) + NDH(I,1) - IFSHKL(I,2) = IFSHKL(I,1) - IFSHKL(I,3) = IFSHKL(I,2) - 120 CONTINUE - IHSAVE = IFSHKL(1,3) - IKSAVE = IFSHKL(2,3) - ILSAVE = IFSHKL(3,3) - IX = IABS(IHSAVE) - IY = IABS(IKSAVE) - IZ = IABS(ILSAVE) - IF (IX .GE. IHMAX .OR. IY .GE. IKMAX .OR. IZ .GE. ILMAX) THEN - ISEG = 1 - RETURN - ENDIF - ENDIF - IH = IHSAVE - IK = IKSAVE - IL = ILSAVE - RETURN - END diff --git a/difrac/indmes.f b/difrac/indmes.f deleted file mode 100644 index d33b3335..00000000 --- a/difrac/indmes.f +++ /dev/null @@ -1,466 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine for the following functions -C 1. To set and measure a given hkl reflection IR -C 2. To set only a given hkl reflection SR -C 3. To measure only a given hkl reflection IM -C 4. To move the circles to given angles SA (& ST,SO,SC,SP) -C 5. Perform Psi scans IP -C----------------------------------------------------------------------- - SUBROUTINE INDMES - INCLUDE 'COMDIF' - CHARACTER ITF*1,IT(NSIZE)*1,PSNAME*40 - REAL RW(3,3) - NJREF = NREF - NATT = 0 - PSI = 0.0 -C----------------------------------------------------------------------- -C Set up for the DE function -C----------------------------------------------------------------------- - IF (KI .EQ. 'DE') THEN - CALL HKLN (IH,IK,IL,NJREF) - CALL ANGET (THETA,OMEGA,CHI,PHI) - CALL MESRIT - CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICOL) - RETURN - ENDIF -C----------------------------------------------------------------------- -C Default values for IH,IK,IL and write the appropriate header -C----------------------------------------------------------------------- - IH = 0 - IK = 0 - IL = 0 - NIREF = 0 - IF (KI .EQ. 'IR') THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - ENDIF - IF (KI .EQ. 'IE') THEN - WRITE (COUT,11000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - ENDIF - IF (KI .EQ. 'SR') THEN - WRITE (COUT,14000) - CALL GWRITE (ITP,' ') - ENDIF - IF (KI .EQ. 'MS') THEN - WRITE (COUT,14100) - CALL GWRITE (ITP,' ') - ENDIF - IF (KI .EQ. 'IM') THEN - WRITE (COUT,15000) - CALL GWRITE (ITP,' ') - ENDIF - IF (KI .EQ. 'SA') THEN - WRITE (COUT,24000) - CALL GWRITE (ITP,'$') - ENDIF - IF (KI .EQ. 'ST') THEN - WRITE (COUT,28000) - CALL GWRITE (ITP,'$') - ENDIF - IF (KI .EQ. 'SO') THEN - WRITE (COUT,29000) - CALL GWRITE (ITP,'$') - ENDIF - IF (KI .EQ. 'SC') THEN - WRITE (COUT,30000) - CALL GWRITE (ITP,'$') - ENDIF - IF (KI .EQ. 'SP') THEN - WRITE (COUT,31000) - CALL GWRITE (ITP,'$') - ENDIF -C----------------------------------------------------------------------- -C The SA function angle input -C----------------------------------------------------------------------- - IF (KI .EQ. 'SA') THEN - CALL ANGET (THETA,OMEGA,CHI,PHI) - CALL FREEFM (ITR) - THETA = RFREE(1) - OMEGA = RFREE(2) - CHI = RFREE(3) - PHI = RFREE(4) - NJREF = -NJREF - CALL SETIT (NJREF) - RETURN - ENDIF -C----------------------------------------------------------------------- -C The ST, SO, SC, SP functions angle input -C----------------------------------------------------------------------- - IF (KI .EQ. 'ST' .OR. KI .EQ. 'SO' .OR. - $ KI .EQ. 'SC' .OR. KI .EQ. 'SP') THEN - CALL ANGET (THETA,OMEGA,CHI,PHI) - CALL FREEFM (ITR) - IF (KI .EQ. 'ST' )THETA = RFREE(1) - IF (KI .EQ. 'SO') OMEGA = RFREE(1) - IF (KI .EQ. 'SC') CHI = RFREE(1) - IF (KI .EQ. 'SP') PHI = RFREE(1) - NJREF = -NJREF - CALL SETIT (NJREF) - RETURN - ENDIF -C----------------------------------------------------------------------- -C Only the IM, IR, IE and SR functions are left at this point. Do IM. -C----------------------------------------------------------------------- - IF (KI .EQ. 'IM' ) THEN - WRITE (COUT,13000) - CALL FREEFM (ITR) - IH = IFREE(1) - IK = IFREE(2) - IL = IFREE(3) - CALL HKLN (IH,IK,IL, NJREF) - CALL ANGET (THETA,OMEGA,CHI,PHI) - CALL MESRIT - CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICC) - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Input instruction for the IE function -C----------------------------------------------------------------------- - IOUT = -1 - IF (KI .EQ. 'IE') THEN - CALL SPACEG (IOUT,0) - WRITE (COUT,17000) - ENDIF -C----------------------------------------------------------------------- -C Input instruction for the SR AND IR functions -C----------------------------------------------------------------------- - IF (KI .EQ. 'SR' .OR. KI .EQ. 'MS') THEN - WRITE (COUT,18000) - ENDIF - IF (KI .EQ. 'IR') THEN - IF (SGSYMB(1) .EQ. 0.0 .AND. SGSYMB(2) .EQ. 0.0) - $ CALL SPACEG (IOUT,0) - WRITE (COUT,16000) - ENDIF -C----------------------------------------------------------------------- -C Set up the IP instruction and CURVES.DAT -C----------------------------------------------------------------------- - IF (KI .EQ. 'IP') THEN - WRITE (COUT,33000) - IIP = LPT - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - IIP = IOUNIT(8) - PSNAME = 'CURVES.DAT' - CALL IBMFIL (PSNAME,IIP,80,'US',IERR) - WRITE (IIP,34000) WAVE - DO 100 I = 1,3 - DO 110 J = 1,3 - RW(I,J) = R(I,J)/WAVE - 110 CONTINUE - WRITE (IIP,35000) (RW(I,J),J=1,3) - 100 CONTINUE - ENDIF - DPSI = 10 - PSIMIN = 0.0 - PSIMAX = 360.0 - WRITE (COUT,17000) - ENDIF - CALL GWRITE (ITP,' ') -C----------------------------------------------------------------------- -C Interpret the free-form input for SR, IR and IE -C----------------------------------------------------------------------- - 150 WRITE (COUT,32000) - CALL ALFNUM (OCHAR) - DO 160 J = 1,100 - I = 101 - J - ANS = OCHAR(I:I) - IF (ANS .NE. ' ') THEN - ITF = '+' - IF (ANS .EQ. '-') ITF = '-' - IF (ANS .EQ. '-' .OR. ANS .EQ. '+') OCHAR(I:I) = ' ' - GO TO 170 - ENDIF - 160 CONTINUE - 170 CALL FREEFM (1000) - IH = IFREE(1) - IK = IFREE(2) - IL = IFREE(3) -C----------------------------------------------------------------------- -C SR Function - Set the display and then the reflection -C MS Function for the CAD4 only -C----------------------------------------------------------------------- - IF (KI .EQ. 'SR' .OR. KI .EQ. 'MS') THEN - CALL HKLN (IH,IK,IL,NJREF) - ISTAN = 0 - DPSISV = DPSI - DPSI = 180. - IPRVAL = 1 - CALL ANGCAL - DPSI = DPSISV - IF (IVALID .EQ. 32) THEN - KI = ' ' - RETURN - ENDIF - IF (IVALID .NE. 0) THEN - WRITE (COUT,19000) - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - ENDIF - IF (KI .EQ. 'MS') OMEGA = OMEGA + 90.0 - 0.5*THETA - IF (ITF .EQ. '-') THETA = 360.0 - THETA - CALL SETIT (NJREF) - RETURN - ENDIF -C----------------------------------------------------------------------- -C Store the h,k,l values for the IR and IE functions -C----------------------------------------------------------------------- - IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN - ILIST = 0 - IF (KI .EQ. 'IE') ILIST = 1 - IPRVAL = 1 - CALL ANGCAL - IF (IVALID .EQ. 32) GO TO 150 - IF (IVALID .NE. 0) THEN - WRITE (COUT,19100) - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'N') GO TO 150 - ENDIF - CALL DEQHKL (NHKL,ILIST) - NIREF = NIREF + 1 - IOH(NIREF) = IH - IOK(NIREF) = IK - IOL(NIREF) = IL - IT(NIREF) = ITF - IF (NIREF .EQ. NSIZE) THEN - WRITE (COUT,18500) - CALL GWRITE (ITP,' ') - GO TO 180 - ENDIF - GO TO 150 - ENDIF -C----------------------------------------------------------------------- -C IR and IE Functions -C----------------------------------------------------------------------- - 180 DO 220 I = 1,NIREF - IH = IOH(I) - IK = IOK(I) - IL = IOL(I) - ITF = IT(I) - JHKL(1,1) = IH - JHKL(2,1) = IK - JHKL(3,1) = IL - NHKL = 1 - ILIST = 0 - IPRVAL = 0 - IF (KI .EQ. 'IE') CALL DEQHKL (NHKL,ILIST) - DO 210 J = 1,NHKL - IH = JHKL(1,J) - IK = JHKL(2,J) - IL = JHKL(3,J) - PSI = 0.0 -C----------------------------------------------------------------------- -C Set the display -C----------------------------------------------------------------------- - CALL HKLN (IH,IK,IL,NJREF) - ISTAN = 0 -C----------------------------------------------------------------------- -C Test if psi rotation is required -C----------------------------------------------------------------------- - IF (ABS(DPSI) .GT. 0.0001) THEN - TPSI = PSIMIN - IF (TPSI .GE. 180.0) TPSI = TPSI - 360.0 - PSI = PSIMIN - ENDIF -C----------------------------------------------------------------------- -C Calculate angles for given h,k,l and psi. Why is Psi reversed ??? -C Psi has to be reversed for the absorp calculation to work -C could have something to do with the handedness of the NRC -C Picker. -C----------------------------------------------------------------------- - 200 PSISAV = PSI - PSI = 360.0 - PSI - IPRVAL = 0 - CALL ANGCAL - IF (ITF .EQ. '-') THETA = 360.0 - THETA - PSI = PSISAV -C----------------------------------------------------------------------- -C If ANGCAL found rotation is possible set the circles and measure -C----------------------------------------------------------------------- - IF (IROT .EQ. 0) THEN - CALL MESRIT - ELSE - WRITE (COUT,25000) IH,IK,IL,PSI - CALL GWRITE (ITP,' ') - ENDIF - CALL KORQ (KQFLAG) - IF (KQFLAG .EQ. 1) THEN -C----------------------------------------------------------------------- -C Increment the psi value for rotation -C----------------------------------------------------------------------- - IF (ABS(DPSI) .GT. 0.0001) THEN - TPSI = TPSI + DPSI - PSI = PSI + DPSI - IF (PSI .GE. 360.0) PSI = PSI - 360.0 - IF (TPSI .LE. PSIMAX) GO TO 200 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Return circles to omega=0 and peak centre before exit -C----------------------------------------------------------------------- - ICC = 0 - PSI = 0.0 - SDPSI = DPSI - DPSI = 0.0 - IPRVAL = 0 - CALL ANGCAL - IF (ITF .EQ. '-') THETA = 360.0 - THETA - DPSI = SDPSI - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC) - IF (ICC .NE. 0) THEN - WRITE (COUT,26000) - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN - ENDIF -C CALL KORQ (KQFLAG) - IF (KQFLAG .NE. 1) THEN - KI = ' ' - RETURN - ENDIF - 210 CONTINUE - 220 CONTINUE - IF (KI .EQ. 'IP') THEN - IF (IIP .NE. LPT) - $ CALL IBMFIL (PSNAME,-IIP,80,'US',IERR) - ENDIF - KI = ' ' - RETURN -10000 FORMAT (' Intensity Measurements for Individual Reflections') -11000 FORMAT (' Intensity Measurements for Equivalent Reflections', - $ ' (Y) ? ',$) -13000 FORMAT (' Type h,k,l for label ',$) -14000 FORMAT (' Set One Reflection') -14100 FORMAT (' Set a Crystal Face for absorption measurements') -15000 FORMAT (' Measure the Reflection which is now in the Detector') -16000 FORMAT (' Type h,k,l and +/- 2Theta sense (+) for up to 50', - $ ' reflections. CR = End.') -17000 FORMAT (' Type h,k,l for up to 50 reflections. CR = End.') -18000 FORMAT (' Type h,k,l and +/- 2theta sense (+) ',$) -18500 FORMAT (' No more reflections allowed.') -19000 FORMAT (' Do you want to set it anyway (N) ? ',$) -19100 FORMAT (' Do you want to measure it anyway (N) ? ',$) -20000 FORMAT (3I4,5F8.3) -24000 FORMAT (' Type 2Theta,Omega,Chi,Phi (0) ',$) -25000 FORMAT (3I4,' Rotation to Psi',F7.2,' is NOT possible.') -26000 FORMAT (' Setting Collision') -28000 FORMAT (' Type 2-Theta ',$) -29000 FORMAT (' Type Omega ',$) -30000 FORMAT (' Type Chi ',$) -31000 FORMAT (' Type Phi ',$) -32000 FORMAT (' Next h,k,l (End) > ',$) -33000 FORMAT (' Collect Psi scan data'/ - $ ' Do you want to write data to CURVES.DAT (Y) ? ') -34000 FORMAT (1X,F8.5) -35000 FORMAT (1X,3F10.6) - END -C----------------------------------------------------------------------- -C Measure the reflection -C----------------------------------------------------------------------- - SUBROUTINE MESRIT - INCLUDE 'COMDIF' - ITIME = 1 - IF (ISCAN .EQ. 3 .OR. ISCAN .EQ. 4) THEN - CALL SAMMES (ITIME,ICC) - ELSE - CALL MESINT (IROFL,ICC) - ENDIF - IF (ICC .EQ. 2) THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - RETURN - ENDIF - CALL PROFIL - IBGRD1 = BGRD1 - IBGRD2 = BGRD2 - ISUM = SUM - ICOUNT = COUNT - ATT = ATTEN(NATT+1) - IF (IPRFLG .EQ. 0) THEN - if(FRAC1 .GT. 0.01) THEN - PEAK = ATT*(SUM - (0.5*(BGRD1 + BGRD2)/FRAC1)*NPK) - ELSE - PEAK = 0. - END IF - IPEAK = PEAK - IF (KI .EQ. 'DE') THEN - WRITE (COUT,11000) - CALL GWRITE (ITP,' ') - ENDIF - IF (LPT .NE. ITP) - $ WRITE (LPT,12000) IH,IK,IL,THETA,FRAC1,NATT, - $ IBGRD1,ISUM,IBGRD2,PSI,IPEAK,ITIME - WRITE (COUT,12000) IH,IK,IL,THETA,FRAC1,NATT, - $ IBGRD1,ISUM,IBGRD2,PSI,IPEAK,ITIME - CALL GWRITE (ITP,' ') - ELSE - FFRAC = FRAC - IF (ITYPE .EQ. 7 .OR. ITYPE .EQ. 8) THEN - IP = PRESET - BB = 1000*(PRESET - IP) - FFRAC = BB/IP - ENDIF - PEAK = ATT*(COUNT - 0.5*(BGRD1 + BGRD2)/FFRAC) - IPEAK = PEAK - IF (LPT .NE. ITP) - $ WRITE (LPT,12000) IH,IK,IL,THETA,PRESET,NATT, - $ IBGRD1,ICOUNT,IBGRD2,PSI,IPEAK,ITIME - WRITE (COUT,12000) IH,IK,IL,THETA,TIME,NATT, - $ IBGRD1,ICOUNT,IBGRD2,PSI,IPEAK,ITIME - CALL GWRITE (ITP,' ') - ENDIF - IF (KI .EQ. 'IP') THEN - WRITE (IIP,13000) IH,IK,IL,THETA,OMEGA,CHI,PHI,PSI, - $ IPEAK - ENDIF - RETURN -10000 FORMAT (' Scan Collision') -11000 FORMAT (/,3X, ' h k l 2-Theta Time', - $ ' Att Bkg Peak Bkg Psi Inet ') -12000 FORMAT (3I4,F7.2,F7.3,1X,I1,I5,I7,I5,F7.2,I7,I4) -13000 FORMAT (3I4,5F8.2,I8) - END -C----------------------------------------------------------------------- -C Set the display and the circles -C----------------------------------------------------------------------- - SUBROUTINE SETIT (NJREF) - INCLUDE 'COMDIF' - IF (NJREF .LT. 0) THEN - RH = IH - RK = IK - RL = IL - NJREF = -NJREF - ELSE - RH = RFREE(1) - RK = RFREE(2) - RL = RFREE(3) - ENDIF - IF (ABS(RH - IH) .GT. 0.0001 .OR. - $ ABS(RK - IK) .GT. 0.0001 .OR. - $ ABS(RL - IL) .GT. 0.0001) THEN - WRITE (COUT,10100) RH,RK,RL,THETA,OMEGA,CHI,PHI,PSI - ELSE - WRITE (COUT,10000) IH,IK,IL,THETA,OMEGA,CHI,PHI,PSI - ENDIF - CALL GWRITE (ITP,' ') - CALL HKLN (IH,IK,IL,NJREF) - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC) - IF (ICC .NE. 0) THEN - WRITE (COUT,11000) - CALL GWRITE (ITP,' ') - ENDIF - KI = ' ' - RETURN -10000 FORMAT (3I4,5F8.3) -10100 FORMAT (8F8.3) -11000 FORMAT (' Setting Collision') - END diff --git a/difrac/keyget.f b/difrac/keyget.f deleted file mode 100644 index f8e53dee..00000000 --- a/difrac/keyget.f +++ /dev/null @@ -1,28 +0,0 @@ -C----------------------------------------------------------------------- -C Function KEYSIN -- MS Fortran specific -C----------------------------------------------------------------------- - INTEGER FUNCTION KEYSIN (STRING) - CHARACTER STRING*(*) -C----------------------------------------------------------------------- -C Do some housekeeping -C----------------------------------------------------------------------- - MAX = LEN(STRING) - STRING = ' ' - INDEX = 0 -C----------------------------------------------------------------------- -C Loop until we get nothing back -C----------------------------------------------------------------------- -10 IC = KEYIN () - IF (IC .NE. 0) THEN - INDEX = INDEX + 1 - STRING(INDEX:INDEX) = CHAR(IC) - IF (INDEX .GE. MAX) THEN - KEYSIN = MAX - RETURN - ENDIF - GO TO 10 - ENDIF - KEYSIN = INDEX - RETURN - END - \ No newline at end of file diff --git a/difrac/latmod.f b/difrac/latmod.f deleted file mode 100644 index da56bc8e..00000000 --- a/difrac/latmod.f +++ /dev/null @@ -1,37 +0,0 @@ -C----------------------------------------------------------------------- -C Get the lattice mode of the conventional cell -C----------------------------------------------------------------------- - SUBROUTINE LATMOD (LAT,MODE) - REAL LAT - DIMENSION LAT(3,3),M(3) - CHARACTER*1 CMODE - CALL MATRIX(LAT(1,1),LAT(1,2),LAT(1,3),DET,'DETERM') - IDET = ABS(DET) + .1 - CMODE = ' ' - IF (IDET .EQ. 1) CMODE = 'P' - IF (IDET .EQ. 3) CMODE = 'R' - IF (IDET .EQ. 4) CMODE = 'F' - IF (IDET .NE. 2) GO TO 130 - DO 120 I = 1,2 - M(1) = MOD(I,2) - DO 120 J = 1,2 - M(2) = MOD(J,2) - DO 120 K = 1,2 - M(3) = MOD(K,2) - IF (M(1) + M(2) + M(3) .LT. 2) GO TO 120 - DO 110 L = 1,3 - ISUM = 0 - DO 100 N = 1,3 - 100 ISUM = ISUM + M(N)*ABS(LAT(L,N)) + 0.1 - IF (MOD(ISUM,2) .NE. 0) GO TO 120 - 110 CONTINUE - CMODE = 'I' - IF (M(1) .EQ. 0) CMODE = 'A' - IF (M(2) .EQ. 0) CMODE = 'B' - IF (M(3) .EQ. 0) CMODE = 'C' - GO TO 130 - 120 CONTINUE - 130 READ (CMODE,10000) MODE - RETURN -10000 FORMAT (A1) - END diff --git a/difrac/linprf.f b/difrac/linprf.f deleted file mode 100644 index 2f9e03c5..00000000 --- a/difrac/linprf.f +++ /dev/null @@ -1,151 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to make a line profile using a theta/2theta or omega scan -C The reflection is assumed to be in the centre of the detector at the -C start of the procedure -C There can be a maximum of 100 steps -C----------------------------------------------------------------------- - SUBROUTINE LINPRF - INCLUDE 'COMDIF' - CHARACTER BEGIN*2 - DATA ITYP,NPTS,NPTSA,CSTEP,TSTEP/0,10,10,0.05,1000./ - IF (KI .EQ. 'DE') THEN - ISTAN = LPT - LPT = ITP - ENDIF - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - WRITE (COUT,13000) - CALL FREEFM (ITR) - ITYP = IFREE(1) - 120 WRITE (COUT,15000) NPTS,NPTSA - CALL FREEFM (ITR) - IF (IFREE(1) .NE. 0) NPTS = IFREE(1) - IF (IFREE(2) .NE. 0) NPTSA = IFREE(2) - WRITE (COUT,15100) CSTEP,TSTEP - CALL FREEFM (ITR) - IF (RFREE(1) .NE. 0.0) CSTEP = RFREE(1) - IF (RFREE(2) .NE. 0.0) TSTEP = RFREE(2) - IF(TSTEP .LE. 0)TSTEP = 1000. - IF (TSTEP .LT. 0.01 ) THEN - WRITE (COUT,11000) - CALL GWRITE (ITP,' ') - GO TO 120 - ENDIF -C----------------------------------------------------------------------- -C Get current angle values -C----------------------------------------------------------------------- - CALL ANGET(THETA,OMEGA,CHI,PHI) - DEL = NPTS*CSTEP - NPTS = NPTS + NPTSA - IF (ITYP .EQ. 0) THEN - ANG1 = THETA - DEL - ANG2 = OMEGA - START = ANG1 - ELSE - ANG1 = THETA - ANG2 = OMEGA - DEL - START = ANG2 - ENDIF - NATT = 0 - IF (KI .NE. 'DE' .AND. NATTEN .GT. 0) THEN - WRITE (COUT,17000) - CALL FREEFM (ITR) - NATT = IFREE(1) - IF (NATT .GT. NATTEN) NATT = NATTEN - ENDIF -C----------------------------------------------------------------------- -C Offset the scan from the peak centre -C----------------------------------------------------------------------- - CALL ANGSET (ANG1,ANG2,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - WRITE (COUT,26000) - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Loop to count and step through the reflection -C----------------------------------------------------------------------- - CALL SHUTTR (99) - DO 240 J = 1,NPTS - CALL CCTIME (TSTEP,COUNT) - ACOUNT(J) = COUNT - IF (ITYP .EQ. 0) ANG1 = ANG1 + CSTEP - IF (ITYP .NE. 0) ANG2 = ANG2 + CSTEP - CALL ANGSET (ANG1,ANG2,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - WRITE (COUT,26000) - CALL GWRITE (ITP,' ') - CALL SHUTTR (-99) - KI = ' ' - RETURN - ENDIF - 240 CONTINUE - CALL SHUTTR (-99) - END = ANG1 - CSTEP - IF (ITYP .NE. 0) END = ANG2 - CSTEP -C----------------------------------------------------------------------- -C Set the circles back to the peak -C----------------------------------------------------------------------- - NATT = 0 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - WRITE (COUT,26000) - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN - ENDIF - SUM = 0. - DO 300 I = 1,NPTS - SUM = SUM + ACOUNT(I) - 300 CONTINUE - IF (KI .EQ. 'DE') THEN - WRITE (COUT,19000) - CALL GWRITE (LPT,' ') - ENDIF - WRITE (COUT,20000) IH,IK,IL,THETA,OMEGA,CHI,PHI,SUM - CALL GWRITE (LPT,' ') - IF (ITYP .EQ. 0) THEN - WRITE (COUT,21000) - ELSE - WRITE (COUT,22000) - ENDIF - CALL GWRITE (LPT,' ') - IF (END .GE. 360.) END = END - 360.0 - WRITE (COUT,23000) START,END,NPTS,TSTEP,CSTEP - CALL GWRITE (LPT,' ') - WRITE (COUT,24000) (ACOUNT(J),J = 1,NPTS) - CALL GWRITE (LPT,' ') - IF (KI .EQ. 'DE') THEN - WRITE (COUT,25000) - CALL GWRITE (ITP,' ') - ENDIF -C----------------------------------------------------------------------- -C Call PLTPRF to form a plot of the profile on LPT -C----------------------------------------------------------------------- - BEGIN = KI - CALL PLTPRF (ACOUNT,NPTS,BEGIN) - KI = ' ' - RETURN -10000 FORMAT (' Plot a Line Profile on the Printer (Y) ? ',$) -11000 FORMAT (' There is something WRONG. Please try again.') -13000 FORMAT (' Scan type: Theta/2Theta or Omega, 0 or 1 ',$) -15000 FORMAT (' Type the no. of pts before & after the peak,' - $ ,'(',I2,',',I2,') ',$) -15100 FORMAT (' Type the step size in degs and the preset/step', - $ ' (',F4.2,',',F4.2,') ',$) -17000 FORMAT (' Which attenuator do you wish to use (0) ? ',$) -19000 FORMAT (//,4X,'Indices',21X,'2Theta Omega Chi Phi') -20000 FORMAT (//3I4,' Angle Settings: ',4F8.3,' Total Counts ',F8.0) -21000 FORMAT (' Theta/2Theta Scan') -22000 FORMAT (' Omega Scan') -23000 FORMAT (1H+,20X,' Begins at',F8.3,' Ends at',F8.3,I4,' Points,', - $ ' Time/point ',F8.3,' secs, Step Size ',F5.2) -24000 FORMAT (10F7.0) -25000 FORMAT (/' A normalized plot of these measurements looks like'/) -26000 FORMAT (' Collision') - END diff --git a/difrac/list.dat b/difrac/list.dat deleted file mode 100644 index 35361d30..00000000 --- a/difrac/list.dat +++ /dev/null @@ -1,80 +0,0 @@ -To sock 12 : 2theta Omega Chi Phi INT -To sock 12 : 1 10.00 0.00 90.00 268.00 4428. -To sock 12 : 2 10.00 0.00 110.00 268.00 4508. -To sock 12 : 3 10.00 0.00 130.00 268.00 4359. -To sock 12 : 4 10.00 0.00 150.00 268.00 4519. -To sock 12 : 5 10.00 0.00 170.00 268.00 4389. -To sock 12 : 6 10.00 0.00 190.00 268.00 4511. -To sock 12 : 7 10.00 0.00 210.00 268.00 4458. -To sock 12 : 8 15.00 360.00 90.00 268.00 2061. -To sock 12 : 9 15.00 360.00 110.00 268.00 2456. -To sock 12 : 10 15.00 360.00 110.00 140.00 299. -To sock 12 : 11 15.00 360.00 130.00 268.00 2063. -To sock 12 : 12 15.00 360.00 150.00 268.00 2097. -To sock 12 : 13 15.00 360.00 170.00 268.00 2153. -To sock 12 : 14 15.00 360.00 190.00 268.00 2174. -To sock 12 : 15 15.00 360.00 210.00 268.00 2124. -To sock 12 : 16 20.00 360.00 90.00 268.00 1493. -To sock 12 : 17 20.00 360.00 110.00 268.00 1476. -To sock 12 : 18 20.00 360.00 130.00 268.00 1486. -To sock 12 : 19 20.00 360.00 150.00 268.00 1559. -To sock 12 : 20 20.00 360.00 170.00 268.00 1470. -To sock 12 : 21 20.00 360.00 190.00 268.00 1466. -To sock 12 : 22 20.00 360.00 210.00 268.00 1545. -To sock 12 : 23 25.00 359.99 90.00 268.00 1162. -To sock 12 : 24 25.00 360.00 110.00 268.00 1136. -To sock 12 : 25 25.00 360.00 130.00 268.00 1127. -To sock 12 : 26 25.00 360.00 150.00 268.00 1223. -To sock 12 : 27 25.00 360.00 170.00 268.00 1178. -To sock 12 : 28 25.00 360.00 190.00 268.00 1181. -To sock 12 : 29 25.00 360.00 210.00 268.00 1187. -To sock 12 : 30 30.00 0.00 90.00 268.00 916. -To sock 12 : 31 30.00 0.00 110.00 268.00 952. -To sock 12 : 32 30.00 0.00 130.00 268.00 1629. -To sock 12 : 33 30.00 0.00 130.00 182.00 361. -To sock 12 : 34 30.00 0.00 130.00 132.00 75. -To sock 12 : 35 30.00 0.00 130.00 124.00 229. -To sock 12 : 36 30.00 0.00 150.00 268.00 1053. -To sock 12 : 37 30.00 0.00 170.00 268.00 1086. -To sock 12 : 38 30.00 0.00 170.00 206.00 59. -To sock 12 : 39 30.00 0.00 170.00 98.00 35. -To sock 12 : 40 30.00 0.00 190.00 268.00 1032. -To sock 12 : 40 new peaks found before the end of the search. -To sock 12 : -To sock 12 : Peak 1 Coarse Setting 10.000 0.001 90.000 268.000 -To sock 12 : Approximate 9.309 0.347 91.125 268.500 -To sock 12 : Alignment Failure on Omega . NBOT, NTOP 0 78 MAX -To sock 12 : Peak 2 Coarse Setting 10.000 0.001 110.000 268.000 -To sock 12 : Approximate 9.570 0.216 110.500 269.000 -To sock 12 : Alignment Failure on Omega . NBOT, NTOP 0 92 MAX -To sock 12 : Peak 3 Coarse Setting 10.000 0.001 130.000 268.000 -To sock 12 : Alignment Failure on Omega . NBOT, NTOP 0 51 MAX -To sock 12 : Peak 4 Coarse Setting 10.000 0.001 150.000 268.000 -To sock 12 : Approximate 9.500 0.251 153.188 267.563 -To sock 12 : Alignment Failure on Omega . NBOT, NTOP 0 82 MAX -To sock 12 : Peak 5 Coarse Setting 10.000 0.001 170.000 268.000 -To sock 12 : Peak 6 Coarse Setting 10.000 0.001 190.000 268.000 -To sock 12 : Approximate 9.230 0.386 190.750 268.563 -To sock 12 : Alignment Failure on Omega . NBOT, NTOP 0 101 MAX -To sock 12 : Peak 7 Coarse Setting 10.000 0.001 210.000 268.000 -To sock 12 : Approximate 9.430 0.286 210.063 270.500 -To sock 12 : Alignment Failure on Omega . NBOT, NTOP 0 92 MAX -To sock 12 : Peak 8 Coarse Setting 15.000 359.998 90.000 268.000 -To sock 12 : Peak 9 Coarse Setting 15.000 359.998 110.000 268.000 -To sock 12 : Peak 10 Coarse Setting 15.000 359.998 110.000 140.000 -To sock 12 : Approximate 16.809 359.094 111.438 141.375 -To sock 12 : Final Values 16.378 359.259 110.066 141.375 1167 -To sock 12 : Peak 11 Coarse Setting 15.000 359.998 130.000 268.000 -To sock 12 : Peak 12 Coarse Setting 15.000 359.998 150.000 268.000 -To sock 12 : Peak 13 Coarse Setting 15.000 359.998 170.000 268.000 -To sock 12 : Peak 14 Coarse Setting 15.000 359.998 190.000 268.000 -To sock 12 : Peak 15 Coarse Setting 15.000 359.998 210.000 268.000 -To sock 12 : Peak 16 Coarse Setting 20.000 359.997 90.000 268.000 -To sock 12 : Peak 17 Coarse Setting 20.000 359.997 110.000 268.000 -To sock 12 : Peak 18 Coarse Setting 20.000 359.997 130.000 268.000 -To sock 12 : Peak 19 Coarse Setting 20.000 359.997 150.000 268.000 -To sock 12 : Peak 20 Coarse Setting 20.000 359.997 170.000 268.000 -To sock 12 : Peak 21 Coarse Setting 20.000 359.997 190.000 268.000 -To sock 12 : Peak 22 Coarse Setting 20.000 359.997 210.000 268.000 -To sock 12 : Peak 23 Coarse Setting 25.002 359.995 90.000 268.000 -To sock 12 : Peak 24 Coarse Setting 25.000 359.996 110.000 268.000 diff --git a/difrac/lister.f b/difrac/lister.f deleted file mode 100644 index e293ecb7..00000000 --- a/difrac/lister.f +++ /dev/null @@ -1,257 +0,0 @@ -C----------------------------------------------------------------------- -C Use one of the transformation matrices from CREDUC to make a new -C orientation matrix (RNEW) and list the old and new indices of -C peaks found by the OC command. -C----------------------------------------------------------------------- - SUBROUTINE LISTER - INCLUDE 'COMDIF' - DIMENSION RNEW(3,3),IRNEW(3,3),IROLD(3,3),RSAVE(3,3), - $ THETAS(NSIZE),OMEGAS(NSIZE),CHIS(NSIZE),PHIS(NSIZE), - $ ICNTS(NSIZE),ROLDI(3,3),RNEWI(3,3),XA(3),HOLD(3), - $ HNEW(3),APSAVE(3),COSAVE(3),SISAVE(3),ANG(3), - $ IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10), - $ BCHI(10),BPHI(10) - CHARACTER FLAG*1,OLDNEW*1,STRING*14,FSTRIN*10,CMODE(7)*1, - $ CSYMB(7)*8 - EQUIVALENCE (ACOUNT( 1),THETAS(1)), - $ (ACOUNT( NSIZE+1),OMEGAS(1)), - $ (ACOUNT(2*NSIZE+1),CHIS(1)), - $ (ACOUNT(3*NSIZE+1),PHIS(1)), - $ (ACOUNT(4*NSIZE+1),ICNTS(1)) - EQUIVALENCE (IHK(1),IBH(1)),(NREFB(1),IBK(1)),(ILA(1),IBL(1)), - $ (BCOUNT(1),BTHETA(1)),(BBGR1(1),BOMEGA(1)), - $ (BBGR2(1),BCHI(1)),(BTIME(1),BPHI(1)) - DATA CMODE/'P','A','B','C','I','F','R'/, - $ CSYMB/'-1','2/m','m m m','4/m','6/m','-3','m 3'/ -C----------------------------------------------------------------------- -C Save the old cell and R matrix in case of trouble -C Extract the cell params from the matrix from BLIND and put in place -C for CREDUC to use. -C----------------------------------------------------------------------- - DO 100 I = 1,3 - APSAVE(I) = AP(I) - COSAVE(I) = CANG(I) - SISAVE(I) = SANG(I) - DO 100 J = 1,3 - RSAVE(I,J) = R(I,J) - RNEW(J,I) = BLINDR(I,J) - 100 CONTINUE - CALL MATRIX (RNEW,BLINDR,ROLDI,ROLDI,'MATMUL') - CALL MATRIX (ROLDI,RNEW,RNEW,RNEW,'INVERT') - CALL PARAMS (RNEW,AP,ANG) - DO 105 I = 1,3 - CANG(I) = COS(ANG(I)/DEG) - SANG(I) = SIN(ANG(I)/DEG) - DO 105 J = 1,3 - BLINDR(I,J) = BLINDR(I,J)*WAVE - R(I,J) = BLINDR(I,J) - 105 CONTINUE -C----------------------------------------------------------------------- -C Reduce the cell obtained by BLIND -C----------------------------------------------------------------------- - WRITE (COUT,9000) - CALL GWRITE (ITP,' ') - CALL CREDUC (KI) -C----------------------------------------------------------------------- -C If there are two or more transformations from CREDUC, find out -C which to use -C----------------------------------------------------------------------- - INEW = 1 - IF (NTMATS .GT. 1) THEN - WRITE (COUT,10000) - CALL FREEFM (ITR) - INEW = IFREE(1) - IF (INEW .EQ. 0) INEW = 1 - ENDIF - DO 110 I = 1,3 - DO 110 J = 1,3 - ROLD(I,J) = TMATS(I,J,INEW) - 110 CONTINUE - ISYSF = IFSYS(INEW) - IMODE = IFMODE(INEW) -C----------------------------------------------------------------------- -C Get the old and new indices needed to generate the new orientation -C matrix and cell. Make sure the old indices (ROLD) are integers. -C----------------------------------------------------------------------- - DO 130 IT = 1,6 - DO 120 I = 1,3 - DO 120 J = 1,3 - IRNEW(I,J) = 0 - IF (I .EQ. J) IRNEW(I,J) = IT - ROUND = 0.00001 - IF (ROLD(I,J) .LT. 0.0) ROUND = -0.00001 - IROLD(I,J) = IT*ROLD(I,J) + ROUND - IF (ABS(IT*ROLD(I,J) - IROLD(I,J)) .GT. 0.001) GO TO 130 - 120 CONTINUE - GO TO 140 - 130 CONTINUE -C----------------------------------------------------------------------- -C IRNEW now has the new index values to use for reorientation -C Calculate the angles needed with the old indices and matrix and -C then calculate the new R matrix with ORMAT3 -C----------------------------------------------------------------------- - 140 DO 150 I = 1,3 - IH = IROLD(I,1) - IK = IROLD(I,2) - IL = IROLD(I,3) - NN = -1 - IPRVAL = 0 - CALL ANGCAL - IHK(I) = IRNEW(I,1) - NREFB(I) = IRNEW(I,2) - ILA(I) = IRNEW(I,3) - BCOUNT(I) = THETA - BBGR1(I) = OMEGA - BBGR2(I) = CHI - BTIME(I) = PHI - 150 CONTINUE - KI = 'OP' - CALL ORMAT3 - DO 160 I = 1,3 - DO 160 J = 1,3 - RNEW(I,J) = R(I,J) - 160 CONTINUE - CALL MATRIX (BLINDR,ROLDI,RJUNK,RJUNK,'INVERT') - CALL MATRIX (RNEW,RNEWI,RJUNK,RJUNK,'INVERT') -C----------------------------------------------------------------------- -C Read the angles found by OC and calculate the old and new indices -C----------------------------------------------------------------------- - CALL ANGRW (0,5,NREFS,140,0) - WRITE (LPT,13000) - NINBLK = 0 - NBLOCK = 250 - DO 200 N = 1,NREFS - ST = 2.0*SIN(0.5*THETAS(N)/DEG) - CO = COS(OMEGAS(N)/DEG) - SO = SIN(OMEGAS(N)/DEG) - CC = COS(CHIS(N)/DEG) - SC = SIN(CHIS(N)/DEG) - CP = COS(PHIS(N)/DEG) - SP = SIN(PHIS(N)/DEG) - XA(1) = ST*(CO*CC*CP - SO*SP) - XA(2) = ST*(CO*CC*SP + SO*CP) - XA(3) = ST*CO*SC - CALL MATRIX (ROLDI,XA,HOLD,RJUNK,'MVMULT') - CALL MATRIX (RNEWI,XA,HNEW,RJUNK,'MVMULT') - FLAG = ' ' - IF (ICNTS(N) .LE. 0) FLAG = '*' - WRITE (LPT,11000) N,HOLD,THETAS(N),OMEGAS(N),CHIS(N),PHIS(N), - $ HNEW,FLAG - NINBLK = NINBLK + 1 - IF (HNEW(1) .GE. 0.0) THEN - IHNEW = HNEW(1) + 0.5 - ELSE - IHNEW = HNEW(1) - 0.5 - ENDIF - IF (HNEW(2) .GE. 0.0) THEN - IKNEW = HNEW(2) + 0.5 - ELSE - IKNEW = HNEW(2) - 0.5 - ENDIF - IF (HNEW(3) .GE. 0.0) THEN - ILNEW = HNEW(3) + 0.5 - ELSE - ILNEW = HNEW(3) - 0.5 - ENDIF - I = 0 - IF (ICNTS(N) .LE. 0) I = 1 - IBH(NINBLK) = IHNEW - IBK(NINBLK) = IKNEW - IBL(NINBLK) = ILNEW - BTHETA(NINBLK) = THETAS(N) - BOMEGA(NINBLK) = OMEGAS(N) - BCHI(NINBLK) = CHIS(N) - BPHI(NINBLK) = PHIS(N) - BPSI(NINBLK) = I - IF (NINBLK .EQ. 10) THEN - WRITE (ISD,REC=NBLOCK) - $ IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI,BPSI,NINBLK - NINBLK = 0 - NBLOCK = NBLOCK + 1 - ENDIF - 200 CONTINUE - IF (NINBLK .GT. 0) THEN - WRITE (ISD,REC=NBLOCK) - $ IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI,BPSI,NINBLK - NBLOCK = NBLOCK + 1 - ENDIF - NINBLK = 0 - WRITE (ISD,REC=NBLOCK) (NINBLK,I = 1,81) - OLDNEW = 'N' - WRITE (COUT,14000) - CALL YESNO ('N',OLDNEW) - IF (OLDNEW .EQ. 'Y') THEN - KI = 'OP' - CALL LSORMT - ST = 2.0*SIN(0.5*THEMAX/DEG) - IHMAX = 1.0 + ST/(APS(1)*SANGS(2)*SANG(3)*WAVE) - IKMAX = 1.0 + ST/(APS(2)*SANGS(3)*SANG(1)*WAVE) - ILMAX = 1.0 + ST/(APS(3)*SANGS(1)*SANG(2)*WAVE) - CALL SYSANG (AP,SANG,CANG,ISYS,KI) - IF (ISYS .EQ. 1) STRING = 'P -1' - IF (ISYS .EQ. 8) STRING = 'P 2/m 1 1' - IF (ISYS .EQ. 9) STRING = 'P 2/m' - IF (ISYS .EQ. 10) STRING = 'P 1 1 2/m' - IF (ISYS .EQ. 3) STRING = 'P m m m' - IF (ISYS .EQ. 4) STRING = 'P 4/m' - IF (ISYS .EQ. 5) STRING = 'P 6/m or P -3' - IF (ISYS .EQ. 6) STRING = 'R -3 R' - IF (ISYS .EQ. 7) STRING = 'P m 3' - FSTRIN = CMODE(IMODE)//' ' - FSTRIN(3:10) = CSYMB(ISYSF) - IF (ISYSF .EQ. 6) ISYSF = 5 - WRITE (COUT,15000) FSTRIN,STRING -15000 FORMAT (' Space-group choices are as follows :--'/ - $ ' 1. The safest space-group based on cell-reduction ', A/ - $ ' 2. The safest space-group based on cell lengths ', A/ - $ ' 3. Any other space-group.'/ - $ ' Which do you want (1) ',$) -16000 FORMAT (' Type the space-group symbol ',$) - CALL FREEFM (ITR) - IF (IFREE(1) .LT. 2) THEN - STRING = FSTRIN//' ' - ISYS = ISYSF - ELSE IF (IFREE(1) .EQ. 2) THEN - IF (STRING(6:9) .EQ. ' or ') THEN - WRITE (COUT,16100) STRING -16100 FORMAT (' The space-group symbol CANNOT be both ',A/ - $ ' Please type the correct symbol ',$) - CALL ALFNUM (STRING) - ENDIF - ELSE IF (IFREE(1) .EQ. 3) THEN - WRITE (COUT,16000) - CALL ALFNUM (STRING) - ENDIF - DO 205 I = 3,10 - IF (STRING(I:I) .GE. 'a' .AND. STRING(I:I) .LE. 'z') - $ STRING(I:I) = CHAR(ICHAR(STRING(I:I)) - 32) - 205 CONTINUE - READ (STRING,'(10A1)') SGSYMB - CALL SPACEG (-2,1) - CALL SINMAT - IND(1) = IHO(1) - IND(2) = IKO(1) - IND(3) = ILO(1) - NREF = 1 - NSET = 1 - NMSEG = 1 - NBLOCK = 20 - CALL WRBAS - ELSE - DO 210 I = 1,3 - AP(I) = APSAVE(I) - CANG(I) = COSAVE(I) - SANG(I) = SISAVE(I) - DO 210 J = 1,3 - R(I,J) = RSAVE(I,J) - 210 CONTINUE - ENDIF - RETURN - 9000 FORMAT (/,' Cell Reduction Step'/'%') -10000 FORMAT (' Which transformation do you wish to use (1) ? ',$) -11000 FORMAT (I4,2X,3F6.2,3X,4F7.2,3X,3F6.2,1X,A) -13000 FORMAT (' N hold kold lold 2theta omega chi phi', - $ ' hnew knew lnew') -14000 FORMAT (/' Do you want to replace the old matrix with this', - $ ' new matrix (N) ? ',$) - END diff --git a/difrac/lotem.f b/difrac/lotem.f deleted file mode 100644 index 81dcfd1d..00000000 --- a/difrac/lotem.f +++ /dev/null @@ -1,24 +0,0 @@ -C----------------------------------------------------------------------- -C Set the delay time to wait after the LN Dewar has been filled to -C allow the temperature to reach equilibrium. -C----------------------------------------------------------------------- - SUBROUTINE LOTEM - INCLUDE 'COMDIF' - EQUIVALENCE (SINABS(1),CUT(2)) - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - ILN = 0 - IF (ANS .EQ. 'Y') THEN - ILN = 1 - WRITE (COUT,11000) - CALL FREEFM (ITR) - DELAY = RFREE(1) - IF (DELAY .LT. 0.1) DELAY = 20.0 - ENDIF - KI = ' ' - RETURN -10000 FORMAT (' Is this a Low-temperature Experiment (Y) ? ',$) -11000 FORMAT (' Type the delay in minutes, between the end of', - $ ' filling the LN Dewar',/, - $ ' and the restart of data collection (20) ',$) - END diff --git a/difrac/lsormt.f b/difrac/lsormt.f deleted file mode 100644 index 71d4dd7f..00000000 --- a/difrac/lsormt.f +++ /dev/null @@ -1,547 +0,0 @@ -C----------------------------------------------------------------------- -C Linear Least Squares Derivation of Orientation Matrix -C -C The routine is called from the terminal with the MM command, or -C internally from re-orientation during data-collection with OZ. -C -C The data is obtained from ORIENT.DA beginning at record 250. -C There are 10 reflections per record -C h k l 2theta omega chi phi in the arrays -C IHK,NREFB,ILA,BCOUNT,BBGR1,BBGR2,BTIME,BPSI -C The 81st variable NBL is the number of reflections in the record. -C If NBL = 10 the block is full, if not it is the last record. -C -C----------------------------------------------------------------------- - SUBROUTINE LSORMT - INCLUDE 'COMDIF' - DIMENSION RHX(3,3),RHH(3,3),IHI(3),XOBS(3),XCNEW(3),XCOLD(3), - $ RHHI(3,3),DEL(3),RNEW(3,3), - $ IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10),BCHI(10), - $ BPHI(10) - CHARACTER ANS0*1 - MARK = 0 - AVEANG = 0.0 - DO 100 I = 1,3 - DO 100 J = 1,3 - ROLD(I,J) = R(I,J)/WAVE - 100 CONTINUE - ANS0 = 'N' - DO 110 I = 1,3 - DO 110 J = 1,3 - RHX(I,J) = 0.0 - RHH(I,J) = 0.0 - 110 CONTINUE - IF (IORNT .EQ. 1) THEN - IHSV = IH - IKSV = IK - ILSV = IL - NBSV = NB - GO TO 200 - ENDIF - IF (KI .EQ. 'OP') GO TO 200 - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - WRITE (COUT,13000) WAVE - CALL FREEFM (ITR) - IF (RFREE(1) .NE. 0.0) WAVE = RFREE(1) -C----------------------------------------------------------------------- -C Read from the terminal or from the Idata file -C----------------------------------------------------------------------- - WRITE (COUT,15000) - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'Y') THEN - CALL TERMRD - ENDIF -C----------------------------------------------------------------------- -C Print the current MM data if wanted -C----------------------------------------------------------------------- - 115 WRITE (COUT,16000) - CALL FREEFM (ITR) - IOPSHN = IFREE(1) - IF (IOPSHN .EQ. 0) IOPSHN = 3 - IF (IOPSHN .EQ. 4) THEN - KI = ' ' - RETURN - ENDIF - IF (IOPSHN .EQ. 1) LLIST = LPT - IF (IOPSHN .EQ. 2) THEN - LLIST = IOUNIT(10) - CALL IBMFIL ('MMDATA.DA',LLIST,80,'SU',IERR) - WRITE (LLIST,16100) WAVE - ENDIF - IF (IOPSHN .EQ. 1 .OR. IOPSHN .EQ. 2) THEN - NBLOKO = 250 - 120 READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI, - $ BPSI,NBL - NBLOKO = NBLOKO + 1 - IF (NBL .NE. 0) THEN - DO 130 I = 1,NBL - IDR = BPSI(I) + 0.1 - WRITE (LLIST,17000) IBH(I),IBK(I),IBL(I),BTHETA(I), - $ BOMEGA(I),BCHI(I),BPHI(I),IDR - 130 CONTINUE - GO TO 120 - ENDIF - IF (IOPSHN .EQ. 2) CALL IBMFIL ('MMDATA.DA',-LLIST,80,'SU',IERR) - GO TO 115 - ENDIF -C----------------------------------------------------------------------- -C Routine to Delete(1) or Restore(0) reflections from LS -C----------------------------------------------------------------------- - WRITE (COUT,19000) - CALL GWRITE (ITP,' ') - 140 WRITE (COUT,29000) - CALL FREEFM (ITR) - JHD = IFREE(1) - KD = IFREE(2) - LD = IFREE(3) - IDR = IFREE(4) -C----------------------------------------------------------------------- -C Find the reflection to be changed -C----------------------------------------------------------------------- - IF (JHD .NE. 0 .OR. KD .NE. 0 .OR. LD .NE. 0) THEN - NBLOKO = 250 - 150 READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI, - $ BPHI,BPSI,NBL - NBLOKO = NBLOKO + 1 - IF (NBL .EQ. 0) GO TO 140 -C----------------------------------------------------------------------- -C Find the reflection, change its status, write back and get the next -C----------------------------------------------------------------------- - DO 160 NB = 1,NBL - IF (IBH(NB) .EQ. JHD .AND. IBK(NB) .EQ. KD .AND. - $ IBL(NB) .EQ. LD) THEN - BPSI(NB) = IDR - NBLOKO = NBLOKO-1 - WRITE (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI, - $ BPHI,BPSI,NBL - NBLOKO = NBLOKO + 1 - GO TO 140 - ENDIF - 160 CONTINUE - GO TO 150 - ENDIF -C----------------------------------------------------------------------- -C Insert new reflections -C----------------------------------------------------------------------- - WRITE (COUT,23000) - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'Y') THEN - NBLOKO = 250 - 170 READ (ISD,REC=NBLOKO) (JUNK,I = 1,80),NBL - NBLOKO = NBLOKO + 1 - IF (NBL .NE. 0) GO TO 170 - NBLOKO = NBLOKO - 1 - WRITE (COUT,24000) NBLOKO - CALL GWRITE (ITP,' ') - CALL TERMRD - ENDIF -C----------------------------------------------------------------------- -C Get the zero values of omega and chi and possibly use them -C----------------------------------------------------------------------- - CALL WCZERO (ZOMEGA,ZCHI) - WRITE (COUT,24100) - CALL YESNO ('Y',ANS0) - IF (ANS0 .EQ. 'Y') THEN - DOMEGA = DOMEGA + ZOMEGA - DCHI = DCHI + ZCHI - WRITE (COUT,24200) DOMEGA,DCHI - CALL GWRITE (ITP,' ') - ENDIF -C----------------------------------------------------------------------- -C Start of the Least Squares Procedure -C Data is read from the file twice -C MARK = 0 when making and solving the normal equations -C MARK = -1 when forming the deltas for the e.s.d.'s -C----------------------------------------------------------------------- - 200 NRF = 0 - NBLOKO = 250 - IF (MARK .EQ. -1) WRITE (LPT,25000) - 210 READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI, - $ BPHI,BPSI,NBL - NBLOKO = NBLOKO + 1 - IF (NBL .NE. 0) THEN - DO 250 NB = 1,NBL - IF (BPSI(NB) .EQ. 0.0) THEN - NRF = NRF + 1 - IHI(1) = IBH(NB) - IHI(2) = IBK(NB) - IHI(3) = IBL(NB) - TH = 2.0*SIN(0.5*BTHETA(NB)/DEG)/WAVE - IF (ANS0 .EQ. 'Y') THEN - BOMEGA(NB) = BOMEGA(NB) - ZOMEGA - BCHI(NB) = BCHI(NB) - ZCHI - ENDIF - CCH = COS(BCHI(NB)/DEG) - SCH = SIN(BCHI(NB)/DEG) - COM = COS(BOMEGA(NB)/DEG) - SOM = SIN(BOMEGA(NB)/DEG) - CPH = COS((BPHI(NB))/DEG) - SPH = SIN((BPHI(NB))/DEG) - XOBS(1) = TH*(CCH*CPH*COM - SOM*SPH) - XOBS(2) = TH*(CCH*SPH*COM + SOM*CPH) - XOBS(3) = TH*SCH*COM -C----------------------------------------------------------------------- -C MARK = 0 Form the RHH and RHX elements -C MARK = -1 For IORNT = 1, i.e. re-orientation, -C form the calcd values of X with the old and new matrices; -C then form the differences and hence the angular deviation. -C For IORNT = 0, i.e. normal MM, -C form the calcd value of X at the observed phi, -C and then the differences between the obs and calcd X and -C then the angular deviation. -C----------------------------------------------------------------------- - IF (MARK .EQ. 0) THEN - DO 220 I = 1,3 - DO 220 J = 1,3 - RHH(I,J) = RHH(I,J) + IHI(I)*IHI(J) - RHX(I,J) = RHX(I,J) + IHI(I)*XOBS(J) - 220 CONTINUE - ELSE - IH = IHI(1) - IK = IHI(2) - IL = IHI(3) - DO 230 I = 1,3 - XCOLD(I) = 0.0 - XCNEW(I) = 0.0 - DO 230 J = 1,3 - XCNEW(I) = XCNEW(I) + RNEW(I,J)*IHI(J) - XCOLD(I) = XCOLD(I) + ROLD(I,J)*IHI(J) - 230 CONTINUE - PHI = BPHI(NB) - CALL ANGPHI (XCNEW) -C----------------------------------------------------------------------- -C Work out the sums for the average angular deviation -C Keep or re-orientation, keep the new R matrix if AVEANG .gt. REOTOL -C----------------------------------------------------------------------- - TOP = 0.0 - BOT = 0.0 - DO 240 I = 1,3 - IF (IORNT .EQ. 1) THEN - DELTA = XCOLD(I) - XCNEW(I) - ELSE - DELTA = XOBS(I) - XCNEW(I) - ENDIF - DELTA = DELTA*DELTA - DEL(I) = DEL(I) + DELTA - TOP = TOP + DELTA - BOT = BOT + XCNEW(I)*XCNEW(I) - 240 CONTINUE - ANGLE = DEG*RATAN2(SQRT(TOP),SQRT(BOT)) - AVEANG = AVEANG + ANGLE -C----------------------------------------------------------------------- -C Write the results for this reflection -C----------------------------------------------------------------------- - OMG = OMEGA - IF (OMG .GT. 359.995) OMG = 0.0 - WRITE (LPT,26000) - $ IHI,BTHETA(NB),BOMEGA(NB),BCHI(NB),BPHI(NB), - $ THETA,OMG,CHI,PHI,ANGLE - ENDIF - ENDIF - 250 CONTINUE - IF (ANS0 .EQ. 'Y' .AND. MARK .EQ. -1) THEN - NBLOKO = NBLOKO - 1 - WRITE (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI, - $ BPHI,BPSI,NBL - NBLOKO = NBLOKO + 1 - ENDIF - GO TO 210 - ENDIF -C----------------------------------------------------------------------- -C Solve for R matrix elements -C----------------------------------------------------------------------- - IF (MARK .EQ. 0) THEN - CALL MATRIX (RHH,RHHI,RHHI,RHHI,'INVERT') - DO 270 I = 1,3 - DO 260 J = 1,3 - R(I,J) = 0.0 - DO 260 KK = 1,3 - R(I,J) = R(I,J) + RHHI(J,KK)*RHX(KK,I) - 260 CONTINUE - 270 CONTINUE - DET = R(1,1)*(R(2,2)*R(3,3) - R(2,3)*R(3,2)) - - $ R(1,2)*(R(2,1)*R(3,3) - R(2,3)*R(3,1)) + - $ R(1,3)*(R(2,1)*R(3,2) - R(2,2)*R(3,1)) - IF (NRC*DET .GT. 0) THEN - WRITE (LPT,27000) NRF - ELSE - WRITE (LPT,28000) NRF - ENDIF -C----------------------------------------------------------------------- -C Extract the real and reciprocal cell parameters -C----------------------------------------------------------------------- - CALL GETPAR -C----------------------------------------------------------------------- -C Clear the esds array -C----------------------------------------------------------------------- - DO 290 J = 1,3 - DEL(J) = 0.0 - 290 CONTINUE -C----------------------------------------------------------------------- -C Store new R matrix times Wavelength -C----------------------------------------------------------------------- - DO 300 I = 1,3 - DO 300 J = 1,3 - RNEW(I,J) = R(I,J) - R(I,J) = R(I,J)*WAVE - 300 CONTINUE - MARK = MARK - 1 - GO TO 200 - ENDIF -C----------------------------------------------------------------------- -C S.D.'s of the R matrix elements from the diagonal elements of the -C inverted (RHHI) matrix. -C Print the matrix and its e.s.ds -C----------------------------------------------------------------------- - DO 310 I = 1,3 - DO 310 J = 1,3 - SR(I,J) = SQRT(RHHI(J,J)*DEL(I)/(NRF - 3)) - 310 CONTINUE - WRITE (LPT,28100) ((RNEW(I,J),J=1,3),(SR(I,J),J=1,3),I = 1,3) -C----------------------------------------------------------------------- -C Call CELLSD to find the s.d.'s of the cell parameters -C----------------------------------------------------------------------- - CALL CELLSD - IF (IORNT .EQ. 1) THEN - AVEANG = AVEANG/NRF - IH = IHSV - IK = IKSV - IL = ILSV - NB = NBSV - IF (AVEANG .LT. REOTOL) THEN - WRITE (COUT,30000) AVEANG - CALL GWRITE (ITP,' ') - WRITE (LPT,30000) AVEANG - DO 320 I = 1,3 - DO 320 J = 1,3 - R(I,J) = ROLD(I,J)*WAVE - 320 CONTINUE - RETURN - ELSE - WRITE (COUT,31000) AVEANG - CALL GWRITE (ITP,' ') - WRITE (LPT,31000) AVEANG - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Calculate the SINABS matrix -C----------------------------------------------------------------------- - IF (KI .NE. 'MM' .AND. KI .NE. 'OP') THEN - ISYS = 1 - CALL SINMAT - ENDIF - RETURN -10000 FORMAT (20X,' Least Squares Orientation Matrix') -13000 FORMAT (' Reflection data can be on file or from the terminal.'/ - $ ' Wavelength (',F7.5,') ',$) -14000 FORMAT (/10X,' Reflections in the Alignment List') -15000 FORMAT (' Read the data from the terminal (N) ? ',$) -16000 FORMAT (' The following options are available :--'/ - $ ' 1. List the MM data on the printer for editting, or'/ - $ ' 2. Write the MM data to the ASCII file MMDATA.DA, or'/ - $ ' 3. Proceed to the next step, or'/ - $ ' 4. Exit from MM.'/ - $ ' Which do you want (3) ? ',$) -16100 FORMAT (' MM data from DIFRAC'/F10.6) -17000 FORMAT (3I4,4F8.3,I3) -19000 FORMAT (' Reflections may be deleted or restored to the list', - $ ' by typing :--',/, - $ ' h,k,l,1 for Delete or h,k,l,0 for Restore (End)') -23000 FORMAT (' Do you wish to insert reflections (N) ? ',$) -24100 FORMAT (' Do you want to include these zero values (Y) ? ',$) -24200 FORMAT (' The new zeroes for Omega and Chi are',2F7.3) -24000 FORMAT (' First non-written record: ',I4) -25000 FORMAT (/,22X,'Observed',22X,'Calculated',10X,'Angular'/ - $ ' h k l 2Theta Omega Chi Phi ', - $ ' 2Theta Omega Chi Phi ', - $ 'Deviation') -26000 FORMAT (3I4,4F7.2,2X,4F7.2,F8.3) -26100 FORMAT (I4,2X,3I4,4F8.3) -27000 FORMAT (/' Right-handed Orientation Matrix from ',I4, - $ ' Reflections') -28000 FORMAT (/' Left-handed Orientation Matrix from ',I4, - $ ' Reflections') -28100 FORMAT (/9X,'Orientation Matrix',30X,'E.S.Ds'/(3F12.8,6X,3F12.8)) -29000 FORMAT (' > ',$) -30000 FORMAT (' The angular deviation is',F6.3,'. The old matrix will', - $ ' be retained.') -31000 FORMAT (' The angular deviation is',F6.3,'. The new matrix will', - $ ' be used.') - END -C----------------------------------------------------------------------- -C Routine to find the zeroes of omega and chi from the alignment data -C ZOMEGA is the average value of omega; -C ZCHI is half the average value of chi for pairs of +++/--- reflns -C----------------------------------------------------------------------- - SUBROUTINE WCZERO (ZOMEGA,ZCHI) - INCLUDE 'COMDIF' - DIMENSION IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10),BCHI(10), - $ BPHI(10) -C EQUIVALENCE (IHK(1),IBH(1)),(NREFB(1),IBK(1)),(ILA(1),IBL(1)), -C $ (BCOUNT(1),BTHETA(1)),(BBGR1(1),BOMEGA(1)), -C $ (BBGR2(1),BCHI(1)),(BTIME(1),BPHI(1)) - SUMOME = 0.0 - SUMCHI = 0.0 - NOMEGA = 0 - NCHI = 0 - NBLOKO = 250 - IH1 = 0 - IK1 = 0 - IL1 = 0 - CHI1 = 999.0 - 100 READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI, - $ BPSI,NBL - IF (NBL .NE. 0) THEN - DO 110 NB = 1,NBL - IF (BPSI(NB) .EQ. 0.0) THEN - WOMEGA = BOMEGA(NB) - IF (WOMEGA .GT. 180.0) WOMEGA = WOMEGA - 360.0 - SUMOME = SUMOME + WOMEGA - NOMEGA = NOMEGA + 1 - IH2 = IBH(NB) - IK2 = IBK(NB) - IL2 = IBL(NB) - CHI2 = BCHI(NB) - IF (IH1 .EQ. -IH2 .AND. - $ IK1 .EQ. -IK2 .AND. - $ IL1 .EQ. -IL2) THEN - CHI12 = CHI1 + CHI2 - IF (CHI12 .GT. 350.0) CHI12 = CHI12 - 360.0 - IF (CHI12 .GT. 350.0) CHI12 = CHI12 - 360.0 - SUMCHI = SUMCHI + CHI12 - NCHI = NCHI + 1 - ENDIF - IH1 = IH2 - IK1 = IK2 - IL1 = IL2 - CHI1 = CHI2 - ENDIF - 110 CONTINUE - NBLOKO = NBLOKO + 1 - GO TO 100 - ENDIF - ZOMEGA = SUMOME/NOMEGA - ZCHI = 0.0 - IF (NCHI .NE. 0) ZCHI = 0.5*SUMCHI/NCHI - WRITE (COUT,10000) ZOMEGA,NOMEGA,ZCHI,NCHI - CALL GWRITE (ITP,' ') - WRITE (LPT,10000) ZOMEGA,NOMEGA,ZCHI,NCHI - RETURN -10000 FORMAT (' Omega(0) is',F7.3,' from',I4,' reflections.'/ - $ ' Chi(0) is',F7.3,' from',I4,' +/- pairs.') - END -C----------------------------------------------------------------------- -C Get reflection angle input from the terminal -C----------------------------------------------------------------------- - SUBROUTINE TERMRD - INCLUDE 'COMDIF' - DIMENSION IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10),BCHI(10), - $ BPHI(10) -C EQUIVALENCE (IHK(1),IBH(1)),(NREFB(1),IBK(1)),(ILA(1),IBL(1)), -C $ (BCOUNT(1),BTHETA(1)),(BBGR1(1),BOMEGA(1)), -C $ (BBGR2(1),BCHI(1)),(BTIME(1),BPHI(1)) - NBLOKO = 250 - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - 100 NBL = 0 - DO 110 I = 1,10 - WRITE (COUT,11000) - CALL FREEFM (ITR) - IH = IFREE(1) - IK = IFREE(2) - IL = IFREE(3) - IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) GO TO 120 - IBH(I) = IH - IBK(I) = IK - IBL(I) = IL - BTHETA(I) = RFREE(4) - BOMEGA(I) = RFREE(5) - BCHI(I) = RFREE(6) - BPHI(I) = RFREE(7) - BPSI(I) = 0. - NBL = NBL + 1 - 110 CONTINUE - 120 WRITE (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI, - $ BPHI,BPSI,NBL - NBLOKO = NBLOKO + 1 - IF (NBL .EQ. 10) GO TO 100 - NBL = 0 - WRITE (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI, - $ BPHI,BPSI,NBL - RETURN -10000 FORMAT (' Type h,k,l,2theta,omega,chi,phi for each refln. (End)') -11000 FORMAT (' > ',$) - END -C----------------------------------------------------------------------- -C Calculate chi and omega for a given phi value -C----------------------------------------------------------------------- - SUBROUTINE ANGPHI (XC) - INCLUDE 'COMDIF' - DIMENSION XC(3) - CP = COS(PHI/DEG) - SP = SIN(PHI/DEG) - TOPC = XC(3) - BOTC = CP*XC(1) + SP*XC(2) - CHI = DEG*RATAN2(TOPC,BOTC) - TOPO = CP*XC(2) - SP*XC(1) - IF (CHI .EQ. 0.0) THEN - OMEGA = 0.0 - ELSE - BOTO = XC(3)/SIN(CHI/DEG) - OMEGA = DEG*RATAN2(TOPO,BOTO) - ENDIF - TH = 0.5*WAVE*SQRT(XC(1)*XC(1) + XC(2)*XC(2) + XC(3)*XC(3)) - THETA = 2.0*DEG*ATAN(TH/SQRT(1.0 - TH*TH)) - TH = 2.0*TH/WAVE - CC = COS(CHI/DEG) - SC = SIN(CHI/DEG) - CO = COS(OMEGA/DEG) - SO = SIN(OMEGA/DEG) - XC(1) = TH*(CC*CP*CO - SO*SP) - XC(2) = TH*(CC*SP*CO + SO*CP) - XC(3) = TH*SC*CO - CALL MOD360 (CHI) - CALL MOD360 (OMEGA) - RETURN - END -C----------------------------------------------------------------------- -C Get around stupid Microsoft compiler problems -C----------------------------------------------------------------------- - FUNCTION RATAN2 (TOP,BOT) - RA = 57.2958 - IF (BOT .EQ. 0) THEN - X = 90.0/RA - IF (TOP .LT. 0.0) X = 270.0/RA - ELSE - X = ATAN2(TOP,BOT) - ENDIF - RATAN2 = X - RETURN - END - -C----------------------------------------------------------------------- -C Extract the real and reciprocal cell parameters -C----------------------------------------------------------------------- - SUBROUTINE GETPAR - INCLUDE 'COMDIF' - DIMENSION RT(3,3) - DO 100 I = 1,3 - DO 100 J = 1,3 - RT(I,J) = R(J,I) - 100 CONTINUE - CALL MATRIX (RT,R,GI,GI,'MATMUL') -C----------------------------------------------------------------------- -C Use CANGS array for reciprocal angles -C----------------------------------------------------------------------- - CALL PARAMS (GI,APS,CANGS) -C----------------------------------------------------------------------- -C Use RT array for metric tensor G -C----------------------------------------------------------------------- - CALL MATRIX (GI,RT,RT,RT,'INVERT') -C----------------------------------------------------------------------- -C Use CANG array for real angles -C----------------------------------------------------------------------- - CALL PARAMS (RT,AP,CANG) - RETURN - END diff --git a/difrac/matrix.f b/difrac/matrix.f deleted file mode 100644 index f6475bbf..00000000 --- a/difrac/matrix.f +++ /dev/null @@ -1,234 +0,0 @@ -C----------------------------------------------------------------------- -C Library of matrix operations for crystal geometry -C----------------------------------------------------------------------- - SUBROUTINE MATRIX(A,B,C,D,IWHAT) - COMMON /IOUASS/ IOUNIT(12) - CHARACTER COUT*132 - COMMON /IOUASC/ COUT(20) - CHARACTER*6 IWHAT - DIMENSION A(3,3),B(3,3),C(3,3),D(3,3),E(3,3),V(3) - DATA RA/57.29578/ - IF (IWHAT .EQ. 'INVERT') GO TO 100 - IF (IWHAT .EQ. 'MATMUL') GO TO 120 - IF (IWHAT .EQ. 'MATVEC') GO TO 150 - IF (IWHAT .EQ. 'VECMAT') GO TO 180 - IF (IWHAT .EQ. 'SCALPR') GO TO 210 - IF (IWHAT .EQ. 'LENGTH') GO TO 230 - IF (IWHAT .EQ. 'ORTHOG') GO TO 250 - IF (IWHAT .EQ. 'DETERM') GO TO 270 - IF (IWHAT .EQ. 'MVMULT') GO TO 290 - IF (IWHAT .EQ. 'VMMULT') GO TO 320 - IF (IWHAT .EQ. 'TRNSPS') GO TO 340 - IF (IWHAT .EQ. 'SYMOPR') GO TO 370 - IF (IWHAT .EQ. 'VECPRD') GO TO 400 - IF (IWHAT .EQ. 'COPRIM') GO TO 410 - IF (IWHAT .EQ. 'INTRCH') GO TO 440 - IF (IWHAT .EQ. 'SUMVEC') GO TO 460 - IF (IWHAT .EQ. 'DIFVEC') GO TO 480 - IF (IWHAT .EQ. 'COPVEC') GO TO 500 - ITP = IOUNIT(6) - WRITE (COUT,10000) IWHAT - CALL GWRITE (ITP,' ') - STOP -C----------------------------------------------------------------------- -C Invert 3x3 matrix A, put the result in B -C----------------------------------------------------------------------- - 100 E(1,1) = A(2,2)*A(3,3) - A(2,3)*A(3,2) - E(2,1) = -(A(2,1)*A(3,3) - A(2,3)*A(3,1)) - E(3,1) = A(2,1)*A(3,2) - A(2,2)*A(3,1) - E(1,2) = -(A(1,2)*A(3,3) - A(1,3)*A(3,2)) - E(2,2) = A(1,1)*A(3,3) - A(1,3)*A(3,1) - E(3,2) = -(A(1,1)*A(3,2) - A(1,2)*A(3,1)) - E(1,3) = A(1,2)*A(2,3) - A(1,3)*A(2,2) - E(2,3) = -(A(1,1)*A(2,3) - A(1,3)*A(2,1)) - E(3,3) = A(1,1)*A(2,2) - A(1,2)*A(2,1) - DMAT = A(1,1)*E(1,1) + A(1,2)*E(2,1) + A(1,3)*E(3,1) - DO 115 I=1,3 - DO 110 J = 1,3 - 110 B(I,J) = E(I,J)/DMAT - 115 CONTINUE - GO TO 520 -C----------------------------------------------------------------------- -C Multiply 3x3 matrices A and B, store result in C -C----------------------------------------------------------------------- - 120 DO 135 I = 1,3 - DO 132 J = 1,3 - E(I,J) = 0.0 - DO 130 K = 1,3 - 130 E(I,J) = E(I,J) + A(I,K)*B(K,J) - 132 CONTINUE - 135 CONTINUE - DO 145 I = 1,3 - DO 140 J = 1,3 - 140 C(I,J) = E(I,J) - 145 CONTINUE - GO TO 520 -C----------------------------------------------------------------------- -C Multiply matrix A by vector B, store dir. cosines of result in C -C----------------------------------------------------------------------- - 150 DO 165 I = 1,3 - V(I) = 0. - DO 160 J = 1,3 - 160 V(I) = V(I) + A(I,J)*B(J,1) - 165 CONTINUE - IF(V(1)**2 + V(2)**2 +V(3)**2 .GT. 0) THEN - VMOD = SQRT(V(1)**2 + V(2)**2 + V(3)**2) - ELSE - VMOD = 1 - ENDIF - DO 170 I = 1,3 - 170 C(I,1) = V(I)/VMOD - GO TO 520 -C----------------------------------------------------------------------- -C Multiply vector A by matrix B, store dir. cosines of result in C -C----------------------------------------------------------------------- - 180 DO 195 I = 1,3 - V(I) = 0. - DO 190 J = 1,3 - 190 V(I) = V(I) + B(J,I)*A(J,1) - 195 CONTINUE - VMOD = SQRT(V(1)**2 + V(2)**2 + V(3)**2) - DO 200 I = 1,3 - 200 C(I,1) = V(I)/VMOD - GO TO 520 -C----------------------------------------------------------------------- -C Scalar product of vectors A and B -C----------------------------------------------------------------------- - 210 S = 0 - DO 220 I = 1,3 - 220 S = S + A(I,1)*B(I,1) - C(1,1) = S - GO TO 520 -C----------------------------------------------------------------------- -C length of vector B when A is the metric matrix -C----------------------------------------------------------------------- - 230 DO 245 I = 1,3 - V(I) = 0. - DO 240 J = 1,3 - 240 V(I) = V(I) + A(I,J)*B(J,1) - 245 CONTINUE - C(1,1) = SQRT(V(1)**2 + V(2)**2 + V(3)**2) - GO TO 520 -C----------------------------------------------------------------------- -C Get the metric matrix C corresponding to cell edges A & angles B -C----------------------------------------------------------------------- - 250 COSGAS = (COS(B(1,1)/RA)*COS(B(2,1)/RA) - COS(B(3,1)/RA)) - COSGAS = COSGAS/(SIN(B(1,1)/RA)*SIN(B(2,1)/RA)) - SINGAS = SQRT(1.0 - COSGAS**2) - E(1,1) = A(1,1)*SIN(B(2,1)/RA)*SINGAS - E(1,2) = 0 - E(1,3) = 0 - E(2,1) = -A(1,1)*SIN(B(2,1)/RA)*COSGAS - E(2,2) = A(2,1)*SIN(B(1,1)/RA) - E(2,3) = 0 - E(3,1) = A(1,1)*COS(B(2,1)/RA) - E(3,2) = A(2,1)*COS(B(1,1)/RA) - E(3,3) = A(3,1) - DO 265 I = 1,3 - DO 260 J = 1,3 - 260 C(I,J) = E(I,J) - 265 CONTINUE - GO TO 520 -C----------------------------------------------------------------------- -C Calculate the determinant D of the vectors A,B,C -C----------------------------------------------------------------------- - 270 DET = 0. - DO 280 I = 1,3 - J = I + 1 - IF (J .EQ. 4) J = 1 - K = 6 - I - J - 280 DET = DET + A(I,1)*(B(J,1)*C(K,1) - B(K,1)*C(J,1)) - D(1,1) = DET - GO TO 520 -C----------------------------------------------------------------------- -C Multiply matrix A by vector B, store result in C -C----------------------------------------------------------------------- - 290 DO 305 I = 1,3 - E(I,1) = 0 - DO 300 J = 1,3 - 300 E(I,1) = E(I,1) + A(I,J)*B(J,1) - 305 CONTINUE - DO 310 I = 1,3 - 310 C(I,1) = E(I,1) - GO TO 520 -C----------------------------------------------------------------------- -C Multiply vector A by matrix B, store result in C -C----------------------------------------------------------------------- - 320 DO 335 I = 1,3 - C(I,1) = 0. - DO 330 J = 1,3 - 330 C(I,1) = C(I,1) + A(J,1)*B(J,I) - 335 CONTINUE - GO TO 520 -C----------------------------------------------------------------------- -Ctranspose matrix A and put it in B -C----------------------------------------------------------------------- - 340 DO 355 I = 1,3 - DO 350 J = 1,3 - 350 E(I,J) = A(J,I) - 355 CONTINUE - DO 365 I = 1,3 - DO 360 J = 1,3 - 360 B(I,J) = E(I,J) - 365 CONTINUE - GO TO 520 -C----------------------------------------------------------------------- -C Get the symmetry-equivalent of an atom -C----------------------------------------------------------------------- - 370 DO 390 I = 1,3 - C(I,1) = 0. - DO 380 J = 1,3 - 380 C(I,1) = C(I,1) + A(I,J)*B(J,1) - J = 4 - 390 C(I,1) = C(I,1) + A(I,J)/12. - GO TO 520 -C----------------------------------------------------------------------- -C Vector product C = A x B -C----------------------------------------------------------------------- - 400 C(1,1) = A(2,1)*B(3,1) - A(3,1)*B(2,1) - C(2,1) = A(3,1)*B(1,1) - A(1,1)*B(3,1) - C(3,1) = A(1,1)*B(2,1) - A(2,1)*B(1,1) - GO TO 520 -C----------------------------------------------------------------------- -C Make coprime integers (the smallest non-zero integer will be 1) -C----------------------------------------------------------------------- - 410 SMALL = 2. - DO 420 I = 1,3 - IF (ABS(A(I,1)) .LE. 0.1 .OR. ABS(A(I,1)) .GE. SMALL) GO TO 420 - SMALL = ABS(A(I,1)) - 420 CONTINUE - DO 430 I = 1,3 - INDEX = A(I,1)/SMALL + 0.5 - IF (A(I,1) .LT. 0.) INDEX = A(I,1)/SMALL - 0.5 - 430 B(I,1) = INDEX - GO TO 520 -C----------------------------------------------------------------------- -C Interchange two vectors A and B -C----------------------------------------------------------------------- - 440 DO 450 I = 1,3 - SAVE = A(I,1) - A(I,1) = B(I,1) - 450 B(I,1) = SAVE - GO TO 520 -C----------------------------------------------------------------------- -C Sum of vectors C = A + B -C----------------------------------------------------------------------- - 460 DO 470 I = 1,3 - 470 C(I,1) = A(I,1) + B(I,1) - GO TO 520 -C----------------------------------------------------------------------- -C Vector difference C = A - B -C----------------------------------------------------------------------- - 480 DO 490 I = 1,3 - 490 C(I,1) = A(I,1) - B(I,1) - GO TO 520 -C----------------------------------------------------------------------- -C Vector copy B = A -C----------------------------------------------------------------------- - 500 DO 510 I = 1,3 - 510 B(I,1) = A(I,1) - GO TO 520 - 520 RETURN -10000 FORMAT(' Matrix operation ',A6,' is not programmed') - END - diff --git a/difrac/mesint.f b/difrac/mesint.f deleted file mode 100644 index 5ddf9799..00000000 --- a/difrac/mesint.f +++ /dev/null @@ -1,407 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to measure a reflection by :-- -C Theta/2Theta scan (ITYPE=0) or Omega scan (ITYPE=1) -C -C IROFL = 1 Count-rate Overflow; ICC = 2 indicates a Collision -C -C Modified for doing step scans at TRICS. -C IO to COUT instead LPT for SICS -C Mark Koennecke, November 1999 -C----------------------------------------------------------------------- - SUBROUTINE MESINT (IROFL,ICC) - INCLUDE 'COMDIF' - INTEGER IHTAGS(4), IRUPT - REAL SPRESET - ICPSMX = 45000 - IF (DFMODL .EQ. 'CAD4') ICPSMX = 25000 -C----------------------------------------------------------------------- -C Reset the liquid nitrogen loading flag -C----------------------------------------------------------------------- - IFILN = 0 - SPRESET = PRESET - 100 STIME = PRESET - ICS = 0 - IROFL = 0 - NATT = 0 - IWARN = 0 - ISIGN = 1 - IF (THETA .LT. 0.0 .OR. THETA .GT. 180.0) ISIGN = -1 -C---- Modified MK: there is no alpha1 alpha2 separation with neutrons -C D12 = BS*ABS(TAN(0.5*THETA/DEG)) - D12 = 0. -C---- end of modification - TTIME = 0.20*PRESET - 110 CALL SHUTTR (1) - IF (NATTEN .GT. 0) THEN - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - ICC = 2 - CALL FILLN2 (IFILN,NFLG) - IF (NFLG .EQ. 1) GO TO 100 - PRESET = SPRESET - RETURN - ENDIF - 120 CALL CCTIME (TTIME,COUNT) - IF (COUNT/TTIME .GE. ICPSMX) THEN - NATT = NATT + 1 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - IF (NATT .LT. NATTEN) GO TO 120 - ENDIF - ENDIF - IF ((ITYPE+1)/2 .EQ. 4) STIME = QTIME - IF (ITYPE .GE. 4) GO TO 160 - IF (ITYPE .EQ. 0 .OR. ITYPE .EQ. 1) THEN - DEL1 = AS + D12 + CS - ANG1 = THETA - ISIGN*AS - ANG2 = OMEGA - ELSE - DEL1 = AS + D12/2 + CS - ANG1 = THETA + ISIGN*D12/3 - ANG2 = OMEGA - ISIGN*(AS + D12/6) - ENDIF -C----------------------------------------------------------------------- -C Offset to low angle side of reflection -C----------------------------------------------------------------------- - ICC = 0 - 130 CALL ANGSET (ANG1,ANG2,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - ICC = 2 - CALL FILLN2 (IFILN,NFLG) - IF (NFLG .EQ. 1) GO TO 100 - PRESET = SPRESET - RETURN - ENDIF -C----------------------------------------------------------------------- -C Measure the low angle background for BGDTIM -C----------------------------------------------------------------------- - BGDTIM = FRAC*PRESET - CALL CCTIME (BGDTIM,BGRD1) -C----------------------------------------------------------------------- -C Do the scan: -C ITYPE Type of scan 0 -- theta/2-theta b-p-b -C 1 -- theta/2-theta precision -C 2 -- omega b-p-b -C 3 -- omega precision -C DEL1 Range of the scan (2-theta for types 0 & 1) -C ACOUNT Array of profile points with sum in ACOUNT(1) -C TIME Return value of scan time in secs -C SPEED Scan speed in degs/min. -C NPPTS No of points in returned profile -C IERR Error code 0 -- OK -C 1 -- Ratemeter overflow -C 2 -- Really bad! -C----------------------------------------------------------------------- - SDEL1 = ISIGN*DEL1 - CALL TSCAN (ITYPE,SDEL1,ACOUNT(1),PRESET,STEP,NPPTS,IERR) - CALL KORQ(IRUPT) - IF(IRUPT .NE. 1)THEN - WRITE(COUT,11000) - CALL GWRITE(ITP,' ') - PRESET = SPRESET - RETURN - ENDIF - MAX = 1 - IEND = 10*NSIZE - DO 135 I = 2,NPPTS - IF (MAX .LT. ACOUNT(I)) MAX = ACOUNT(I) - ACOUNT(IEND - I) = ACOUNT(I) - 135 CONTINUE -C----------------------------------------------------------------------- -C For the CAD-4 at -ve 2theta the profile is delivered backwards. -C----------------------------------------------------------------------- - IF (DFMODL .EQ. 'CAD4' .AND. - $ (THETA .LT. 0.0 .OR. THETA .GT. 180.0)) THEN - J = IEND - NPPTS - 2 - DO 138 I = 2,NPPTS - ACOUNT(I) = ACOUNT(J + I) - 138 CONTINUE - ENDIF -C WRITE (COUT,99999) MAX,NPPTS,TIME -C CALL GWRITE (ITP,' ') -C99999 FORMAT (I6,I4,F8.3) -C----------------------------------------------------------------------- -C For the CAD-4 at high 2theta and chi near 90 there can be no profile, -C because the interface detects a potential collision. -C Then TIME = 0, and the profile analysis should not be done IDEL < 10 -C----------------------------------------------------------------------- - IF (DFMODL .EQ. 'CAD4') THEN - RTIME = ABS(60*DEL1/SPEED) - IF (TIME .LT. RTIME/3) THEN - WRITE (LPT,12200) IH,IK,IL - WRITE (COUT,12200) IH,IK,IL - CALL GWRITE (ITP,' ') - IDEL = 5 - GO TO 150 - ENDIF - ENDIF - IF (MAX*NPPTS/PRESET .GT. ICPSMX) IROFL = 1 - IF (IERR .GE. 2) THEN - WRITE (LPT,16000) IH,IK,IL - WRITE (COUT,16000) IH,IK,IL - CALL GWRITE (ITP,' ') - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - GO TO 110 - ENDIF -C----------------------------------------------------------------------- -C Test for low angle count too high near direct beam -C----------------------------------------------------------------------- - IF (IROFL .NE. 0 .AND. PRESET .LT. 10) THEN - WRITE (COUT,12000) IH,IK,IL - CALL GWRITE(ITP,' ') - GO TO 150 - ENDIF -C----------------------------------------------------------------------- -C Plot the last reflection if SR2 is ON -C For details of the profile plotting see PROFIL -C----------------------------------------------------------------------- - ISTEP = 1000.0/DEL1 - IDEL = NPPTS + 1 -C----------------------------------------------------------------------- -C Test for -ve 2theta scan problem with SIERAY 145D -C----------------------------------------------------------------------- - IF (IDEL .LT. 10) THEN - WRITE (COUT,12100) IH,IK,IL - CALL GWRITE (ITP,' ') - GO TO 150 - ENDIF -C----------------------------------------------------------------------- -C Possibly draw the raw data profile -C----------------------------------------------------------------------- - CALL RSW (0,I) - IF (I .EQ. 1) THEN - DO 140 I = 1,4 - IHTAGS(I) = 0 - 140 CONTINUE - IHTAGS(2) = AS*STEPDG - CALL PTPREP (NPPTS,ACOUNT(2),IHTAGS) - ENDIF -C----------------------------------------------------------------------- -C Check that the scan time is reasonably close to the calculated value -C----------------------------------------------------------------------- - COUNT = ACOUNT(1) - IF (ICOL .NE. 0) THEN - ICS = ICS + 1 - IF (ICS .LT. 2) GO TO 130 - ICC = 2 - CALL FILLN2 (IFILN,NFLG) - IF (NFLG .EQ. 1) GO TO 100 - PRESET = SPRESET - RETURN - ENDIF -C----------------------------------------------------------------------- -C Change the attenuator if necessary and try again. -C----------------------------------------------------------------------- - IF (IROFL .NE. 0) THEN - IF (NATTEN .GT. 0 .AND. NATT .LT. NATTEN) THEN - NATT = NATT + 1 - GO TO 130 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C The scan is OK. -C Correct the low angle background to the time FRAC*TIME, measure the -C high angle background and then return. -C----------------------------------------------------------------------- - I = BGRD1*PRESET*FRAC/BGDTIM + 0.5 - BGRD1 = I - BGDTIM = PRESET*FRAC - CALL CCTIME (BGDTIM,BGRD2) - IF (BGRD1 + BGRD2 .GT. 4.0*COUNT) THEN - WRITE (COUT,11000) IH,IK,IL - CALL GWRITE(ITP,' ') - ENDIF - CALL FILLN2 (IFILN,NFLG) - IF (NFLG .EQ. 1) GO TO 100 - PRESET = SPRESET - RETURN -C----------------------------------------------------------------------- -C Return if there are counting problems -C----------------------------------------------------------------------- - 150 COUNT = 2 - SUM = 2 - BGRD1 = 1 - BGRD2 = 1 - FRAC = 0.1 - PRESET = SPRESET - NATT = 0 - ICC = 0 - IROFL = 0 - IWARN = 1 - CALL FILLN2 (IFILN,NFLG) - IF (NFLG .EQ. 1) GO TO 100 - RETURN -C----------------------------------------------------------------------- -C Set up peak top counting for appropriate angles -C----------------------------------------------------------------------- - 160 IF (ITYPE .EQ. 4 .OR. ITYPE .EQ. 6) THEN - ANG1 = THETA - AS - ANG2 = OMEGA - ANG3 = THETA + BS*TAN(0.5*THETA/DEG) + CS - ANG4 = OMEGA - PRESET= STIME - ELSE - ANG1 = THETA - ANG2 = OMEGA - AS - ANG3 = THETA - ANG4 = OMEGA + CS - ENDIF - 170 CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - WRITE (COUT,13000) IH,IK,IL - CALL GWRITE(ITP,' ') - GO TO 150 - ENDIF -C----------------------------------------------------------------------- -C Count at peak for time TIME -C----------------------------------------------------------------------- - 420 CALL CCTIME (PRESET,COUNT) -C C = COUNT/PRESET - IF (C .GE. ICPSMX .AND. NATTEN .GT. 0 .AND. NATT .LT. NATTEN) THEN - NATT = NATT + 1 - GO TO 170 - ENDIF -C----------------------------------------------------------------------- -C Drive to high angle background position and count -C----------------------------------------------------------------------- - CALL ANGSET (ANG3,ANG4,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - WRITE (COUT,13000) IH,IK,IL - CALL GWRITE(ITP,' ') - GO TO 150 - ENDIF -C----------------------------------------------------------------------- -C Measure the backgrounds -C----------------------------------------------------------------------- - IF (ITYPE .EQ. 5 .OR. ITYPE .EQ. 6) THEN - BGDTIM = FRAC*PRESET - CALL CCTIME (BGDTIM,BGRD2) - CALL ANGSET (ANG1,ANG2,CHI,PHI,NATT,ICOL) - CALL CCTIME (BGDTIM,BGRD1) - IF (BGRD1 + BGRD2 .GT. 4.0*COUNT) THEN - WRITE (COUT,11000) IH,IK,IL - CALL GWRITE(LPT,' ') - ENDIF - CALL FILLN2 (IFILN,NFLG) - PRESET = SPRESET - IF (NFLG .EQ. 1) GO TO 100 - RETURN - ENDIF -C----------------------------------------------------------------------- -C Sample background on high side -C----------------------------------------------------------------------- - PRESET = STIME*0.5 - CALL CCTIME (PRESET,BGRD2) -C----------------------------------------------------------------------- -C Evaluate rough Peak/Background ratio and Time required to -C accumulate a preset number FRAC of counts on the peak. -C----------------------------------------------------------------------- - RRAT = COUNT/(2*BGRD2 + 1.0) - IF (RRAT .LT. 1.05) RRAT = 1.05 - RTIM = FRAC*STIME/(COUNT + 1.0) -C----------------------------------------------------------------------- -C Optimum time splitting and required total time -C----------------------------------------------------------------------- - OPT = (RRAT - SQRT(RRAT))/(RRAT - 1.0) - TOT = RTIM/OPT - IF (TOT .GT. TMAX) TOT = TMAX - IBCT = (TOT*(1.0 - OPT) + 1.0)/2.0 - IPCT = (TOT*OPT) + 1 -C----------------------------------------------------------------------- -C Finish measurement of high background -C----------------------------------------------------------------------- - BCT = (IBCT - (STIME/2.0)) - IF (BCT .GT. 0.) THEN - CALL CCTIME (BCT,BKG2) - BGRD2 = BGRD2 + BKG2 - BCT = IBCT - ICC = 0 - ELSE - BCT = STIME/2.0 - ENDIF - PCT = IPCT - STIME - IF (PCT .GT. 0.) THEN - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - ICC = 2 - CALL FILLN2 (IFILN,NFLG) - PRESET = SPRESET - IF (NFLG .EQ. 1) GO TO 100 - RETURN - ENDIF - PPCT = PCT - PCT = IPCT - CALL CCTIME (PPCT,PC) - COUNT = COUNT + PC - ELSE - PCT = STIME - ENDIF - CALL ANGSET (ANG1,ANG2,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - ICC = 2 - CALL FILLN2 (IFILN,NFLG) - PRESET = SPRESET - IF (NFLG .EQ. 1) GO TO 100 - RETURN - ENDIF - PRESET = BCT - CALL CCTIME (PRESET,BGRD1) - PRESET = PCT + BCT - CALL FILLN2 (IFILN,NFLG) - IF (NFLG .EQ. 1) GO TO 100 - PRESET = SPRESET - RETURN -10000 FORMAT (' Clock Problems in reflection ',3I4) -11000 FORMAT (' Trouble Warning in reflection ',3I4) -12000 FORMAT (' Low Angle Problem in ',3I4) -12100 FORMAT (' Scan problem in ',3I4) -12200 FORMAT (' Potential CAD4 scan collision in',3I4) -13000 FORMAT (' Collision in reflection ',3I4) -16000 FORMAT (' Scan error in ',3I4,' Trying again') - END -C----------------------------------------------------------------------- -C Finish the measurement, with or without low temperature. -C----------------------------------------------------------------------- - SUBROUTINE FILLN2 (IFILN,NFLG) - INCLUDE 'COMDIF' - NFLG = 0 - IF (ILN .EQ. 0) THEN - CALL SHUTTR (-1) - RETURN - ENDIF - DUM1 = 1.0/16.0 - DUM2 = 0.5 - CALL ONEBEP (DUM1,DUM2) - IF (DUM2 .GT. 1) THEN - TMIN = 0 - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - 100 TIM1 = 1500 - CALL CCTIME (TIM1,CONT) - DUM1 = 1.0/16.0 - DUM2 = 0.5 - CALL ONEBEP (DUM1,DUM2) - IF (DUM2 .GE. 1.0) THEN - TMIN = TMIN + 0.25 - GO TO 100 - ENDIF - WRITE (COUT,11000) IH,IK,IL,NREF,TMIN,DELAY - CALL GWRITE (ITP,' ') - TMIN = DELAY*6000 - IF (TMIN .LE. 1) TMIN = 1 - CALL CCTIME (TMIN,DUM2) - IFILN = 1 - NFLG = 1 - ENDIF - IF (IFILN .NE. 0) ICC = ICC + 4 - CALL SHUTTR (-1) - RETURN -10000 FORMAT (' Liquid Nitrogen fillup. Waiting...') -11000 FORMAT (' Liquid Nitrogen Tank now full',/, - $ ' Reflection',3I3,' # ',I5,'. Filling lasted',F6.2, - $ ' minutes.',/, - $ ' Now starting a ',F5.2,' minutes delay before', - $ ' resuming data collection.') - END - - - diff --git a/difrac/mod360.f b/difrac/mod360.f deleted file mode 100644 index 55e9b128..00000000 --- a/difrac/mod360.f +++ /dev/null @@ -1,8 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to put angle in 0 to 359.999 range -C----------------------------------------------------------------------- - SUBROUTINE MOD360 (ANG) - IF (ANG .GE. 360.0) ANG = ANG - 360.0 - IF (ANG .LT. 0.0) ANG = ANG + 360.0 - RETURN - END diff --git a/difrac/nexseg.f b/difrac/nexseg.f deleted file mode 100644 index 690eeec6..00000000 --- a/difrac/nexseg.f +++ /dev/null @@ -1,58 +0,0 @@ -C----------------------------------------------------------------------- -C This subroutine gets the next DH set for automatic data collection -C----------------------------------------------------------------------- - SUBROUTINE NEXSEG - INCLUDE 'COMDIF' - DIMENSION ISET(25) - IUPDWN = 1 - READ (IID,REC=4) ICENT,NUMDH,(SCRAP,I = 1,48),NSYM,LSET,ISET -C----------------------------------------------------------------------- -C IHO(5) = 1 means pointer mode, i.e. typed in DH matrices. -C----------------------------------------------------------------------- - IF (IHO(5) .EQ. 1) THEN - IHO(6) = IHO(6) + 1 - NHO = IHO(6) - IF (NHO .GT. 25) THEN - NSET = 0 - RETURN - ENDIF - NSET = ISET(NHO) - IF (NSET .EQ. 0) RETURN - NMSEG = 1 - MSET = 1 - IF (NSET .LT. 0) MSET = -1 - IF (NSET .LT. 0) NSET = -NSET - DO 100 I = 1,3 - DO 100 J = 1,3 - IDH(8,I,J) = JRT(I,J,NSET)*MSET - 100 CONTINUE - NSET = NSET*MSET -C----------------------------------------------------------------------- -C Normal sequence of sets. NSYM is the max no. of sets (+/-). -C If end of data collection set NSET = 0 -C----------------------------------------------------------------------- - ELSE - IF (NSET .EQ. -NSYM) THEN - NSET = 0 - RETURN -C----------------------------------------------------------------------- -C If a + set make it -; if a - set get the next + set. -C----------------------------------------------------------------------- - ELSE IF (NSET .GE. 0) THEN - NSET = -NSET - NMSEG = 1 - DO 110 I = 1,3 - DO 110 J = 1,3 - IDH(8,I,J) = -IDH(8,I,J) - 110 CONTINUE - ELSE - NSET = 1 - NSET - DO 120 I = 1,3 - DO 120 J = 1,3 - IDH(8,I,J) = JRT(I,J,NSET) - 120 CONTINUE - NMSEG = 1 - ENDIF - ENDIF - RETURN - END diff --git a/difrac/orcel2.f b/difrac/orcel2.f deleted file mode 100644 index e9a6d0cf..00000000 --- a/difrac/orcel2.f +++ /dev/null @@ -1,318 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to calculate the orientation matrix from the cell -C parameters and two non-collinear reflections. -C----------------------------------------------------------------------- - SUBROUTINE ORCEL2 - INCLUDE 'COMDIF' - DIMENSION JH(2),JK(2),JL(2),OM(2),CH(2),PH(2),ANG(3),T(3,3), - $ XP(2),YP(2),ZP(2),SC(3,3),SPH(3,3),SCT(3,3),RO(3,3) - EQUIVALENCE(NREFB(7),ANG(1)) - IF (KI .EQ. 'OC') THEN - ANG(1) = CANG(1) - ANG(2) = CANG(2) - ANG(3) = CANG(3) - GO TO 130 - ENDIF - IF (KI .NE. 'RO' .AND. KI .NE. 'O4') THEN - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - DO 90 I = 1,3 - DO 90 J = 1,3 - ROLD(I,J) = R(I,J)/WAVE - 90 CONTINUE -C----------------------------------------------------------------------- -C Read Wavelength, Cell parameters and data for the 2 reflections -C----------------------------------------------------------------------- - 95 WRITE (COUT,13000) WAVE - CALL FREEFM (ITR) - IF (RFREE(1) .NE. 0.) WAVE = RFREE(1) - WRITE (COUT,15000) - CALL FREEFM (ITR) - AP(1) = RFREE(1) - AP(2) = RFREE(2) - AP(3) = RFREE(3) - ANG(1) = RFREE(4) - ANG(2) = RFREE(5) - ANG(3) = RFREE(6) - WRITE (COUT,16000) WAVE,AP,ANG - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') GO TO 95 - WRITE (COUT,17000) - CALL YESNO ('N',ANS) -C----------------------------------------------------------------------- -C Typed input. Test it for h=k=l=0; collinear h,k,ls; collinear angles -C----------------------------------------------------------------------- - IF (ANS .EQ. 'Y') THEN - 96 WRITE (COUT,22000) - CALL GWRITE (ITP,' ') - DO 100 J = 1,2 - 97 WRITE (COUT,26000) J - CALL FREEFM (ITR) - IHK(J) = IFREE(1) - NREFB(J) = IFREE(2) - ILA(J) = IFREE(3) - IF (IFREE(1) .EQ. 0 .AND. - $ IFREE(2) .EQ. 0 .AND. - $ IFREE(3) .EQ. 0) THEN - WRITE (COUT,16100) - CALL GWRITE (ITP,' ') - GO TO 97 - ENDIF - BBGR1(J) = RFREE(4) - BBGR2(J) = RFREE(5) - BTIME(J) = RFREE(6) - 100 CONTINUE - TOP = IHK(1)*IHK(2) + NREFB(1)*NREFB(2) + ILA(1)*ILA(2) - BOT = IHK(1)*IHK(1) + NREFB(1)*NREFB(1) + ILA(1)*ILA(1) + - $ IHK(2)*IHK(2) + NREFB(2)*NREFB(2) + ILA(2)*ILA(2) - TOP = ABS(TOP/SQRT(BOT)) - IF (TOP .GT. 0.999) THEN - WRITE (COUT,16200) - CALL GWRITE (ITP,' ') - GO TO 96 - ENDIF - DO 105 I = 1,2 - OM(I) = BBGR1(I) - DOMEGA - CALL MOD360 (OM(I)) - CH(I) = BBGR2(I) - DCHI - CALL MOD360 (CH(I)) - PH(I) = BTIME(I) - XP(I) = COS(CH(I)/DEG)*COS(PH(I)/DEG)*COS(OM(I)/DEG) - - $ SIN(OM(I)/DEG)*SIN(PH(I)/DEG) - YP(I) = COS(OM(I)/DEG)*COS(CH(I)/DEG)*SIN(PH(I)/DEG) + - $ SIN(OM(I)/DEG)*COS(PH(I)/DEG) - ZP(I) = NRC*COS(OM(I)/DEG)*SIN(CH(I)/DEG) - 105 CONTINUE - TOP = XP(1)*XP(2) + YP(1)*YP(2) + ZP(1)*ZP(2) - IF (TOP .GT. 0.999) THEN - WRITE (COUT,16210) - CALL GWRITE (ITP,' ') - GO TO 96 - ENDIF - WRITE (COUT,16300) (IHK(J),NREFB(J),ILA(J), - $ BBGR1(J),BBGR2(J),BTIME(J),J = 1,2) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') GO TO 96 - ELSE - WRITE (COUT,19000) - $ IHK(1), NREFB(1), ILA(1), BBGR1(1), BBGR2(1), BTIME(1), - $ IHK(2), NREFB(2), ILA(2), BBGR1(2), BBGR2(2), BTIME(2) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - WRITE (COUT,20000) - CALL FREEFM (ITR) - IHK(1) = IFREE(1) - NREFB(1) = IFREE(2) - ILA(1) = IFREE(3) - IHK(2) = IFREE(4) - NREFB(2) = IFREE(5) - ILA(2) = IFREE(6) - ENDIF - ENDIF - ENDIF - DO 110 I = 1,3 - CANG(I) = COS(ANG(I)/DEG) - SANG(I) = SIN(ANG(I)/DEG) - 110 CONTINUE - 130 DO 140 J = 1,2 - JH(J) = IHK(J) - JK(J) = NREFB(J) - JL(J) = ILA(J) - OM(J) = BBGR1(J) - DOMEGA - CALL MOD360 (OM(J)) - CH(J) = BBGR2(J) - DCHI - CALL MOD360 (CH(J)) - PH(J) = BTIME(J) - 140 CONTINUE -C----------------------------------------------------------------------- -C Calculate reciprocal cell dimensions -C----------------------------------------------------------------------- - CANGS(1) = ((CANG(2)*CANG(3)) - CANG(1))/(SANG(2)*SANG(3)) - CANGS(2) = ((CANG(1)*CANG(3)) - CANG(2))/(SANG(1)*SANG(3)) - CANGS(3) = ((CANG(1)*CANG(2)) - CANG(3))/(SANG(1)*SANG(2)) - DO 150 I = 1,3 - SANGS(I) = SQRT(1.0-CANGS(I)**2) - 150 CONTINUE - APS(1) = 1.0/(AP(1)*SANGS(2)*SANG(3)) - APS(2) = 1.0/(AP(2)*SANGS(1)*SANG(3)) - APS(3) = 1.0/(AP(3)*SANGS(1)*SANG(2)) -C----------------------------------------------------------------------- -C T-matrix -C----------------------------------------------------------------------- - T(1,1) = APS(1) - T(1,2) = APS(2)*CANGS(3) - T(1,3) = APS(3)*CANGS(2) - T(2,1) = 0.0 - T(2,2) = APS(2)*SANGS(3) - T(2,3) = -APS(3)*SANGS(2)*CANG(1) - T(3,3) = 1.0/AP(3) - T(3,1) = 0.0 - T(3,2) = 0.0 -C----------------------------------------------------------------------- -C Form X,Y,Z for H1C and H2C vectors -C----------------------------------------------------------------------- - DO 160 I = 1,2 - XP(I) = T(1,1)*JH(I) + T(1,2)*JK(I) + T(1,3)*JL(I) - YP(I) = T(2,2)*JK(I) + T(2,3)*JL(I) - ZP(I) = T(3,3)*JL(I) - 160 CONTINUE - MARK = 0 -C----------------------------------------------------------------------- -C Call ORCELS to form the SC matrix -C----------------------------------------------------------------------- - CALL ORCELS (XP,YP,ZP,SC,MARK) - IF (MARK .NE. 0) RETURN -C----------------------------------------------------------------------- -C Form X,Y,Z, for U1PHI and U2PHI vectors -C----------------------------------------------------------------------- - DO 170 I = 1,2 - XP(I) = COS(CH(I)/DEG)*COS(PH(I)/DEG)*COS(OM(I)/DEG) - - $ SIN(OM(I)/DEG)*SIN(PH(I)/DEG) - YP(I) = COS(OM(I)/DEG)*COS(CH(I)/DEG)*SIN(PH(I)/DEG) + - $ SIN(OM(I)/DEG)*COS(PH(I)/DEG) - ZP(I) = NRC*COS(OM(I)/DEG)*SIN(CH(I)/DEG) - 170 CONTINUE - MARK = 0 -C----------------------------------------------------------------------- -C Call ORCELS to form the SPH matrix -C----------------------------------------------------------------------- - CALL ORCELS (XP,YP,ZP,SPH,MARK) - IF (MARK .NE. 0) RETURN - DO 180 I = 1,3 - DO 180 J = 1,3 - SCT(J,I) = SC(I,J) - 180 CONTINUE -C----------------------------------------------------------------------- -C Form the RO and R matrices -C----------------------------------------------------------------------- - CALL MATRIX (SPH,SCT,RO,RO,'MATMUL') - CALL MATRIX (RO,T,R,R,'MATMUL') -C----------------------------------------------------------------------- -C The R matrix is truly right handed, change for NRC diffractometer -C----------------------------------------------------------------------- - DO 190 J = 1,3 - R(3,J) = NRC*R(3,J) - 190 CONTINUE - IF (KI .EQ. 'M2') THEN - WRITE (COUT,24000) - CALL GWRITE (ITP,' ') - WRITE (COUT,25000) ((R(I,J),J = 1,3),I = 1,3) - CALL GWRITE (ITP,' ') - WRITE (LPT,24000) - WRITE (LPT,25000) ((R(I,J),J = 1,3),I = 1,3) - ENDIF -C----------------------------------------------------------------------- -C Store R matrix times Wavelength -C----------------------------------------------------------------------- - DO 200 I = 1,3 - DO 200 J = 1,3 - R(I,J) = R(I,J)*WAVE - 200 CONTINUE -C----------------------------------------------------------------------- -C Calculate symmetry matrix SINABS. Done for M2 in BASINP only if the -C new matrix is retained. -C----------------------------------------------------------------------- - IF (KI .NE. 'M2') THEN - ISYS = 1 - CALL SINMAT - ENDIF - RETURN -10000 FORMAT (' Orientation Matrix from Cell + 2 Non-Collinear', - $ ' Reflections (Y) ',$) -13000 FORMAT (' Type the wavelength (',F7.5,') ',$) -15000 FORMAT (' Type a,b,c,alpha,beta,gamma ',$) -16000 FORMAT (' The input values are :-- Wavelength',F8.5/ - $ ' Cell Parameters',3F9.4,3F9.3/ - $ ' Is this correct (Y) ? ',$) -16100 FORMAT (' The reflection 0,0,0 is invalid. Try again.') -16200 FORMAT (' The reflection indices typed are collinear. Try again.') -16210 FORMAT (' The reflection angles typed are collinear. Try again.') -16300 FORMAT (' The input values are :--',2(/3I4,3F9.3)/ - $ ' Is this correct (Y) ? ',$) -17000 FORMAT (' Are angles to be typed (N) ? ',$) -19000 FORMAT (' The two reflections being used are ',2(/3I4,3F8.3)/ - $ ' Do you wish to edit the reflection indices (Y) ? ') -20000 FORMAT (' Type the new h1,k1,l1 and h2,k2,l2 ',$) -22000 FORMAT (' Type h,k,l, Omega, Chi, Phi for 2 non-collinear', - $ ' reflections') -24000 FORMAT (/' Orientation Matrix from M2') -25000 FORMAT (3F12.8) -26000 FORMAT (' Reflection,',I2,' > ',$) - END -C----------------------------------------------------------------------- -C Subroutine to calculate the S matrices for ORCEL2 -C----------------------------------------------------------------------- - SUBROUTINE ORCELS (XP,YP,ZP,SC,MARK) - COMMON /IODEVS/ ITP,ITR,LPT,LPTX,NB,NBLOCK,ISD,IID, - $ IBYLEN,IPR,NPR,IIP - CHARACTER*132 COUT(20) - COMMON /IOUASC/ COUT - DIMENSION XP(3),YP(3),ZP(3),SC(3,3),AL(4),AM(4),AN(4) - MARK = 0 - DEN = SQRT(XP(1)*XP(1) + YP(1)*YP(1) + ZP(1)*ZP(1)) - AL(1) = XP(1)/DEN - AM(1) = YP(1)/DEN - AN(1) = ZP(1)/DEN - DEN = SQRT(XP(2)*XP(2) + YP(2)*YP(2) + ZP(2)*ZP(2)) - AL(4) = XP(2)/DEN - AM(4) = YP(2)/DEN - AN(4) = ZP(2)/DEN - BL = AM(1)*AN(4) - AM(4)*AN(1) - BM = AL(4)*AN(1) - AL(1)*AN(4) - BN = AL(1)*AM(4) - AL(4)*AM(1) - DEN = SQRT(BL*BL + BM*BM + BN*BN) - AL(3) = -BL/DEN - AM(3) = -BM/DEN - AN(3) = -BN/DEN - DEN = AL(1)*AM(3) - AM(1)*AL(3) - DIS = ABS(DEN) - AL(2) = 1.0 - AM(2) = 0.0 - AN(2) = 0.0 - IF (DIS .GT. 0.0) THEN - ALN = (AM(1)*AN(3) - AM(3)*AN(1))/DEN - AMN = (AL(3)*AN(1) - AL(1)*AN(3))/DEN - SUM = SQRT(1.0 + ALN*ALN + AMN*AMN) - AN(2) = 1.0/SUM - AL(2) = AN(2)*ALN - AM(2) = AN(2)*AMN - ELSE - DEN = AL(1)*AN(3) - AL(3)*AN(1) - DIS = ABS(DEN) - IF (DIS .GT. 0.0) THEN - ALM = (AN(1)*AM(3) - AM(1)*AN(3))/DEN - ANM = (AL(3)*AM(1) - AL(1)*AM(3))/DEN - SUM = SQRT(1.0 + ALM*ALM + ANM*ANM) - AM(2) = 1.0/SUM - AL(2) = AM(2)*ALM - AN(2) = AM(2)*ANM - ENDIF - ENDIF - DO 100 I = 1,3 - SC(1,I) = AL(I) - SC(2,I) = AM(I) - SC(3,I) = AN(I) - 100 CONTINUE - DET = SC(1,1)*(SC(2,2)*SC(3,3) - SC(2,3)*SC(3,2)) - - $ SC(1,2)*(SC(2,1)*SC(3,3) - SC(2,3)*SC(3,1)) + - $ SC(1,3)*(SC(2,1)*SC(3,2) - SC(2,2)*SC(3,1)) -C----------------------------------------------------------------------- -C To ensure both matrices are right handed -C----------------------------------------------------------------------- - IF (DET .EQ. 0) THEN - MARK = 1 - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - ENDIF - IF (DET .LT. 0.0) THEN - DO 110 I = 1,3 - SC(I,2) = -SC(I,2) - 110 CONTINUE - ENDIF - RETURN -10000 FORMAT (' Determinant = 0') - END diff --git a/difrac/ormat3.f b/difrac/ormat3.f deleted file mode 100644 index f03e201d..00000000 --- a/difrac/ormat3.f +++ /dev/null @@ -1,211 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to calculate the orientation matrix from three -C non-collinear reflections forming a right-handed system. -C----------------------------------------------------------------------- - SUBROUTINE ORMAT3 - INCLUDE 'COMDIF' - DIMENSION TH(3),OM(3),CH(3),PH(3),THE(3,3),HM(3,3),HMI(3,3), - $ ANGS(3) - CHARACTER INTFLT*3 - IF (KI .EQ. 'M3') THEN - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - ENDIF - ENDIF - DO 90 I = 1,3 - DO 90 J = 1,3 - ROLD(I,J) = R(I,J)/WAVE - 90 CONTINUE -C----------------------------------------------------------------------- -C Part 1: Read in wavelength and data for the 3 reflections and then -C form the H matrix. Used by M3 and RS and OP (LISTER) -C----------------------------------------------------------------------- - IF (KI .EQ. 'M3' .OR. KI .EQ. 'RS' .OR. KI .EQ. 'OP') THEN - IF (KI .NE. 'OP') THEN - WRITE (COUT,11000) WAVE - CALL FREEFM (ITR) - WAV = RFREE(1) - IF (WAV .NE. 0) WAVE = WAV - ENDIF - ANS = 'N' - IF (KI .EQ. 'M3') THEN - WRITE (COUT,12000) - CALL YESNO ('N',ANS) - IF (KI .EQ. 'M3' .AND. ANS .EQ. 'N') THEN - WRITE (COUT, 12100) - CALL GWRITE (ITP, ' ') - ENDIF - ENDIF - IF (ANS .EQ. 'N') THEN - DO 100 J = 1,3 - HM(1,J) = IHK(J) - HM(2,J) = NREFB(J) - HM(3,J) = ILA(J) - TH(J) = BCOUNT(J) - OM(J) = BBGR1(J) - CALL MOD360 (OM(J)) - CH(J) = BBGR2(J) - CALL MOD360 (CH(J)) - PH(J) = BTIME(J) - IF (KI .EQ. 'M3') THEN - WRITE (COUT,12200) IHK(J),NREFB(J),ILA(J),BCOUNT(J), - $ BBGR1(J),BBGR2(J),BTIME(J) - CALL GWRITE (ITP,' ') - ENDIF - 100 CONTINUE - ELSE - WRITE (COUT,13000) - CALL GWRITE (ITP,' ') - DO 110 J = 1,3 - WRITE (COUT,14000) - CALL FREEFM (ITR) - HM(1,J) = RFREE(1) - HM(2,J) = RFREE(2) - HM(3,J) = RFREE(3) - TH(J) = RFREE(4) - OM(J) = RFREE(5) - CH(J) = RFREE(6) - PH(J) = RFREE(7) - TH(J) = TH(J) - OM(J) = OM(J) - CALL MOD360 (OM(J)) - CH(J) = CH(J) - CALL MOD360 (CH(J)) - 110 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Calculate the elements of the THETA matrix -C----------------------------------------------------------------------- - DO 120 J = 1,3 - SLTEMP = 2.0*SIN((0.5*TH(J))/DEG)/WAVE - THE(1,J) = (COS(OM(J)/DEG)*COS(CH(J)/DEG)*COS(PH(J)/DEG) - - $ SIN(OM(J)/DEG)*SIN(PH(J)/DEG))*SLTEMP - THE(2,J) = (COS(OM(J)/DEG)*COS(CH(J)/DEG)*SIN(PH(J)/DEG) + - $ SIN(OM(J)/DEG)*COS(PH(J)/DEG))*SLTEMP - THE(3,J) = (COS(OM(J)/DEG)*SIN(CH(J)/DEG))*SLTEMP - 120 CONTINUE -C----------------------------------------------------------------------- -C Invert the H matrix and form the R matrix -C----------------------------------------------------------------------- - CALL MATRIX (HM,HMI,HMI,HMI,'INVERT') - CALL MATRIX (THE,HMI,R,R,'MATMUL') -C----------------------------------------------------------------------- -C Evaluate the determinant to decide if right or left handed -C----------------------------------------------------------------------- - DET = R(1,1)*(R(2,2)*R(3,3) - R(2,3)*R(3,2)) - - $ R(1,2)*(R(2,1)*R(3,3) - R(2,3)*R(3,1)) + - $ R(1,3)*(R(2,1)*R(3,2) - R(2,2)*R(3,1)) - IF (NRC*DET .EQ. 0) THEN - WRITE (LPT,15000) - KI = ' ' - RETURN - ENDIF - IF (NRC*DET .GT. 0) THEN - WRITE (LPT,16000) KI,((R(I,J),J = 1,3),I = 1,3) - ELSE - WRITE (LPT,17000) KI,((R(I,J),J = 1,3),I = 1,3) - ENDIF - ENDIF - IF (KI .EQ. 'OM') THEN - DO 130 I = 1,3 - DO 130 J = 1,3 - R(I,J) = R(I,J)/WAVE - 130 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Get the real and reciprocal cell parameters -C----------------------------------------------------------------------- - IF (KI .NE. 'RA') THEN - CALL GETPAR - WRITE (LPT,18000) APS,CANGS - WRITE (LPT,19000) AP,CANG -C----------------------------------------------------------------------- -C Calculate SANG, CANG, SANGS and CANGS for COMMON and put R right -C----------------------------------------------------------------------- - DO 160 I = 1,3 - SANG(I) = SIN(CANG(I)/DEG) - CANG(I) = COS(CANG(I)/DEG) - SANGS(I) = SIN(CANGS(I)/DEG) - CANGS(I) = COS(CANGS(I)/DEG) - DO 160 J = 1,3 - R(I,J) = R(I,J)*WAVE - 160 CONTINUE -C----------------------------------------------------------------------- -C Calculate the symmetry matrix SINABS, unless called from LISTER (OP) -C or M3 when it will be done only if the new matrix is retained. -C----------------------------------------------------------------------- - ISYS = 1 - IF (KI .NE. 'OP' .AND. KI .NE. 'M3') CALL SINMAT - IF (KI .NE. 'M3') KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C RA calculates angles for given h,k,l values RA -C----------------------------------------------------------------------- - IF (KI .EQ. 'RA') THEN - DPSI = 0.0 - 200 WRITE (COUT,20000) - CALL FREEFM (ITR) - IH = IFREE(1) - IK = IFREE(2) - IL = IFREE(3) - RH = RFREE(1) - RK = RFREE(2) - RL = RFREE(3) - INTFLT = 'INT' - IF (ABS(RH - IH) .GT. 0.0001 .OR. - $ ABS(RK - IK) .GT. 0.0001 .OR. - $ ABS(RL - IL) .GT. 0.0001) INTFLT = 'FLT' - IF (INTFLT .EQ. 'INT' .AND. - $ IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) THEN - KI = ' ' - RETURN - ENDIF - PSI = RFREE(4) -C----------------------------------------------------------------------- -C Give a value to DPSI for ANGCAL calculation to proceed for PSI .NE. 0 -C----------------------------------------------------------------------- - IF (ABS(PSI) .GT. 0.0001) DPSI = 10.0 - ISTAN = 0 - IPRVAL = 1 - CALL ANGCAL - IF (IROT .NE. 0) THEN - IF (INTFLT .EQ. 'INT') THEN - WRITE (COUT,22000) IH,IK,IL,PSI - ELSE - WRITE (COUT,22100) RH,RK,RL,PSI - ENDIF - CALL GWRITE (ITP,' ') - ENDIF - IF (IVALID .EQ. 0 .AND. IROT .EQ. 0) THEN - IF (INTFLT .EQ. 'INT') THEN - WRITE (COUT,23000) IH,IK,IL,THETA,OMEGA,CHI,PHI,PSI - ELSE - WRITE (COUT,23100) RH,RK,RL,THETA,OMEGA,CHI,PHI,PSI - ENDIF - CALL GWRITE (ITP,' ') - ENDIF - GO TO 200 - ENDIF -10000 FORMAT (' Orientation Matrix from 3 Reflections (Y) ? ',$) -11000 FORMAT (' Type the Wavelength (',F7.5,') ',$) -12000 FORMAT (' Are the angles to be typed (N) ? ',$) -12100 FORMAT (' The three reflections being used are') -12200 FORMAT (3I4,4F8.3) -13000 FORMAT (' Type h,k,l,2Theta,Omega,Chi,Phi ') -14000 FORMAT (' > ',$) -15000 FORMAT (' The determinant of the matrix is 0.') -16000 FORMAT (/' RIGHT-handed Orientation Matrix from ',A2/(3F12.8)) -17000 FORMAT (/' LEFT-handed Orientation Matrix from ',A2/(3F12.8)) -18000 FORMAT (/' a* ',F8.5,' b* ',F8.5,' c* ',F8.5, - $ ' Alf* ',F7.3,' Bet* ',F7.3,' Gam* ',F7.3) -19000 FORMAT (' a ',F8.5,' b ',F8.5,' c ',F8.5, - $ ' Alf ',F7.3,' Bet ',F7.3,' Gam ',F7.3/) -20000 FORMAT (' Type h,k,l,Psi (End) ',$) -22000 FORMAT (3I4,' Psi ',F7.3,' Rotation not possible') -22100 FORMAT (3F8.3,' Psi ',F7.3,' Rotation not possible') -23000 FORMAT (3I4,5F8.3) -23100 FORMAT (8F8.3) - END diff --git a/difrac/oscil.f b/difrac/oscil.f deleted file mode 100644 index 6644ae2b..00000000 --- a/difrac/oscil.f +++ /dev/null @@ -1,93 +0,0 @@ -C----------------------------------------------------------------------- -C This subroutine performs a wide omega scan for photographic purposes -C----------------------------------------------------------------------- - SUBROUTINE OSCIL - INCLUDE 'COMDIF' - CON = IFRDEF - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - WRITE (COUT,11000) - CALL FREEFM (ITR) - OLIM1 = RFREE(1) - OLIM2 = RFREE(2) - WRITE (COUT,12000) - CALL FREEFM (ITR) - OSTIM = RFREE(1) - WRITE ( COUT,13000) - CALL FREEFM (ITR) - NOSTIM = IFREE(1) - IF (NOSTIM .EQ. 0) NOSTIM = 1 - NO = NOSTIM -C----------------------------------------------------------------------- -C Get the scan range assuming that 180 is the maximum -C----------------------------------------------------------------------- - OLI1 = AMOD(OLIM1,360.) - OLI2 = AMOD(OLIM2,360.) - IF (OLI2 .LE. OLI1) THEN - SAVE = OLI1 - OLI1 = OLI2 - OLI2 = SAVE - ENDIF - OLI3 = OLI1 + 360.0 - IF ((OLI2 - OLI1) .GE. 180.0) THEN - OLI1 = OLI2 - OLI2 = OLI3 - ENDIF - RANGE = AMOD((OLI2-OLI1),360.0) - IRANGE = RANGE + 1 - MSTEP = (RANGE - IRANGE)*CON - TOSTEP = CON*RANGE - TOTIME = OSTIM - TISTEP = OSTIM - IF (TISTEP .LT. 0.01) TISTEP = 0.01 - DO 150 NT = 1,NO - CALL ANGET (THETA,OMEGA,CHI,PHI) - OLIC = OLI1 - CALL ANGSET (THETA,OLI1,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - WRITE (COUT,14000) - CALL GWRITE (ITP,' ') - CALL SHUTTR (-1) - KI = ' ' - RETURN - ENDIF - DO 140 I = 1,IRANGE - NSTEP = MSTEP - IF ((IRANGE-I) .GT. 0) NSTEP = CON - DO 130 J = 1,NSTEP - OLIC = OLIC + 1.0/CON - CALL MOD360 (OLIC) - CALL ANGSET (THETA,OLIC,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - WRITE (COUT,14000) - CALL GWRITE (ITP,' ') - CALL SHUTTR (-1) - KI = ' ' - RETURN - ENDIF - CALL CCTIME (TISTEP,COUNT) - CALL KORQ (KQFLAG) - IF (KQFLAG .NE. 1) THEN - WRITE (COUT,15000) - CALL GWRITE (ITP,' ') - CALL SHUTTR (-1) - KI = ' ' - RETURN - ENDIF - 130 CONTINUE - 140 CONTINUE - 150 CONTINUE - CALL SHUTTR (-1) - KI = ' ' - RETURN -10000 FORMAT (' Oscillation Picture (Y) ? ',$) -11000 FORMAT (' Type the omega scan limits ',$) -12000 FORMAT (' Type the count preset',$) -13000 FORMAT (' Type the number of repeats (1) ',$) -14000 FORMAT (' Collision Stop') -15000 FORMAT (' K-stop') - END diff --git a/difrac/params.f b/difrac/params.f deleted file mode 100644 index 43360dd0..00000000 --- a/difrac/params.f +++ /dev/null @@ -1,21 +0,0 @@ -C----------------------------------------------------------------------- -C To extract real or reciprocal cell parameters from the metric -C tensor G into ABC and ANG -C----------------------------------------------------------------------- - SUBROUTINE PARAMS (G,ABC,ANG) - DIMENSION G(3,3),ABC(3),ANG(3) - DEG = 57.2958 - DO 100 I = 1,3 - ABC(I) = SQRT(G(I,I)) - 100 CONTINUE - P = G(2,3)/(ABC(2)*ABC(3)) - Q = SQRT(1.0 - P*P) - ANG(1) = DEG*ATAN2(Q,P) - P = G(1,3)/(ABC(1)*ABC(3)) - Q = SQRT(1.0 - P*P) - ANG(2) = DEG*ATAN2(Q,P) - P = G(1,2)/(ABC(1)*ABC(2)) - Q = SQRT(1.0 - P*P) - ANG(3) = DEG*ATAN2(Q,P) - RETURN - END diff --git a/difrac/pcdraw.f b/difrac/pcdraw.f deleted file mode 100644 index b6e48a47..00000000 --- a/difrac/pcdraw.f +++ /dev/null @@ -1,330 +0,0 @@ -C----------------------------------------------------------------------- -C PCDRAW -- PC Graphics package using the library supplied with -C MS FORTRAN version 5.0 -C -C Version for DIFRAC. Supports a graphics window as well as two -C text windows, one for commands and the other for use by HKLN -C----------------------------------------------------------------------- - include 'fgraph.fi' - SUBROUTINE PCDRAW (IFUNC,IX,IY,IZ,STRING) - include 'fgraph.fd' - include 'COMDIF' - integer ifunc, ix, iy, iz - character string*(*) -C----------------------------------------------------------------------- -C Definitions for the graphics package, these may not be standard -C Fortran -C----------------------------------------------------------------------- - integer*2 result, - $ irt(3),ict(3),irb(3),icb(3), - $ RED,BLUE,WHITE,CYAN, - $ irow,icol - common /pclocl/ irt,ict,irb,icb,ntextw - record /videoconfig/ screen - double precision wx,wy - record /wxycoord/ wprev - record /rccoord/ cursor,cursor2,tcoords - logical first - data first /.true./ - data RED,BLUE,WHITE,CYAN/4,1,15,3/ -C----------------------------------------------------------------------- -C XOPEN Initialise the display -C----------------------------------------------------------------------- - if (IFUNC .eq. XOPEN) then -C----------------------------------------------------------------------- -C -- Find the graphics mode -C----------------------------------------------------------------------- - call getvideoconfig (screen) - select case (screen.adapter) - case ($CGA) - result = setvideomode ($HRESBW) - termgr = 'CGA' - case ($OCGA) - result = setvideomode ($ORESCOLOR) - termgr = 'OCGA' - case ($EGA,$OEGA) - if (screen.monitor .eq. $MONO) then - result = setvideomode (ERESNOCOLOR) - termgr = 'EGAM' - else - result = setvideomode ($ERESCOLOR) - termgr = 'EGA' - endif - case ($HGC) - result = setvideomode ($HERCMONO) - termgr = 'HERC' - case ($MCGA) - result = setvideomode ($VRES2COLOR) - termgr = 'MCGA' - case ($VGA,$OVGA) - result = setvideomode ($VRES16COLOR) - termgr = 'VGA' - case DEFAULT - result = 0 - end select - if (result .eq. 0) STOP 'ERROR: Unsupported graphics adaptor' -C----------------------------------------------------------------------- -C -- Now we can find out some dimensions -C----------------------------------------------------------------------- - call getvideoconfig (screen) - edxres = screen.numxpixels - edyres = screen.numypixels - nrows = screen.numtextrows - ncols = screen.numtextcols -C----------------------------------------------------------------------- -C -- And setup the default colour scheme -C----------------------------------------------------------------------- - result = setbkcolor ($BLUE) - result = setcolor (WHITE) - call clearscreen ($GCLEARSCREEN) -C----------------------------------------------------------------------- -C -- For now define text window 1 as the top three lines of the screen -C----------------------------------------------------------------------- - irt(1) = 1 - irb(1) = 3 - ict(1) = 1 - icb(1) = ncols - call settextwindow (irt(1),ict(1),irb(1),icb(1)) - call clearscreen ($GWINDOW) - call settextwindow (irt(1),ict(1),irb(1)+1,icb(1)) - do 100 i = 2,79 - win1bf(1)(i:i) = char(205) - win1bf(3)(i:i) = char(205) -100 continue - win1bf(2) = ' ' - win1bf(1)(1:1) = char(201) - win1bf(1)(ncols:ncols) = char(187) - win1bf(2)(1:1) = char(186) - win1bf(2)(ncols:ncols) = char(186) - win1bf(3)(1:1) = char(200) - win1bf(3)(ncols:ncols) = char(188) - win1bf(2)(3:14) = 'D I F R A C ' - do 110 i = 1,3 - call settextposition (i,1,cursor) - call outtext (win1bf(i)) -110 continue -C----------------------------------------------------------------------- -C And setup the constants for a second text window which is the -C normal command window -C----------------------------------------------------------------------- - irt(2) = nrows - 6 - irb(2) = nrows - ict(2) = 1 - icb(2) = ncols - call settextwindow (irt(2),ict(2),irb(2),icb(2)) - call settextposition (1,1,cursor) - ntextw = 2 -C----------------------------------------------------------------------- -C And then window 3 which is a full screen window. -C----------------------------------------------------------------------- - irt(3) = 4 - irb(3) = nrows - ict(3) = 1 - ict(3) = ncols -C----------------------------------------------------------------------- -C -- And the graphics window as the top righthand corner of the -C screen on a scale of 4096 along the x-axis and 60% of the screen. -C----------------------------------------------------------------------- - xt = 0.0 - ypix = edyres/float(nrows) - yt = 3.0 * ypix + 1 - yb = edyres - (7.0 * ypix + 1) - xb = (yb - yt) * edxres/edyres - call setviewport (xt,yt,xb,yb) - result = setwindow (.TRUE.,-205.0,-154.0,4300.0,3225.0) - result = setcolor (BLUE) -C call clearscreen ($GVIEWPORT) -C----------------------------------------------------------------------- -C XMOVE Move the graphics cursor to x,y -C----------------------------------------------------------------------- - else if (IFUNC .eq. XMOVE) then - wx = ix - wy = iy - call moveto_w (wx,wy,wprev) -C----------------------------------------------------------------------- -C XDRAW Draw a line -C----------------------------------------------------------------------- - else if (IFUNC .eq. XDRAW) then - wx = ix - wy = iy - result = lineto_w (wx,wy) -C----------------------------------------------------------------------- -C XCLOSE Return to normal text mode -C----------------------------------------------------------------------- - else if (IFUNC .eq. XCLOSE) then - result = setvideomode ($DEFAULTMODE) -C----------------------------------------------------------------------- -C XCLEAR Clear the graphics viewport -C----------------------------------------------------------------------- - else if (IFUNC .eq. XCLEAR) then - result = setcolor (BLUE) - call gettextposition (cursor2) - call settextwindow (irt(1),ict(1),irb(1)+1,icb(1)) - call clearscreen ($GWINDOW) - do 120 i = 1,3 - call settextposition (i,1,cursor) - call outtext (win1bf(i)) -120 continue - call displa (theta,omega,chi,phi) - call settextwindow (irt(2),ict(2),irb(2),icb(2)) - irow = cursor2.row - icol = cursor2.col - call settextposition (irow,icol,cursor2) - result = rectangle_w ($GFILLINTERIOR,-205.0,-154.0, - $ 4300.0,3225.0) - result = setcolor (WHITE) - result = rectangle_w ($GBORDER,-205.0,-154.0, - $ 4300.0,3225.0) - ntextw = 2 -C----------------------------------------------------------------------- -C XTEXT Output text to the current text window -C----------------------------------------------------------------------- - else if (IFUNC .EQ. XTEXT) then - call outtext (string) -C----------------------------------------------------------------------- -C XSCROL Scroll text in the current window -C----------------------------------------------------------------------- - else if (IFUNC .EQ. XSCROL) then - call gettextposition (tcoords) - irow = tcoords.row + 1 - icol = 1 - mxlins = irb(ntextw) - irt(ntextw) + 1 - if (irow .gt. mxlins) then - call scrolltextwindow ($GSCROLLUP) - irow = mxlins - endif - call settextposition (irow,icol,tcoords) -C----------------------------------------------------------------------- -C XTDEL Delete a character -C----------------------------------------------------------------------- - else if (IFUNC .EQ. XTDEL) then - call gettextposition (tcoords) - irow = tcoords.row - icol = tcoords.col - 1 - if (icol .ge. 1) then - call settextposition (irow,icol,tcoords) - call outtext (' ') - call settextposition (irow,icol,tcoords) - endif -C----------------------------------------------------------------------- -C XWIN Set current text window -C----------------------------------------------------------------------- - else if (IFUNC .EQ. XWIN) then - if (ix .ge. 1 .and. ix .le. 3) then - call settextwindow (irt(ix),ict(ix),irb(ix),icb(ix)) - if (iy .eq. XCLEAR) call clearscreen ($GWINDOW) - ntextw = ix - endif - endif - return - end -C----------------------------------------------------------------------- -C WNTEXT Simple routine to output text the the current window -C----------------------------------------------------------------------- - SUBROUTINE WNTEXT (STRING) - INCLUDE 'COMDIF' - CHARACTER STRING*(*) - INTEGER IX,IY,IZ - DATA IX,IY,IZ/1,0,0/ - CALL PCDRAW (XTEXT,IX,IY,IZ,STRING) - RETURN - END -C----------------------------------------------------------------------- -C WNCDEL Delete a character from the screen -C----------------------------------------------------------------------- - SUBROUTINE WNCDEL - INCLUDE 'COMDIF' - CALL PCDRAW (XTDEL,0,0,0,'Delete') - RETURN - END -C----------------------------------------------------------------------- -C WNSET Routine to set the current text window -C Assumes: 1 -- Top left hand window -C 2 -- Text window along bottom -C 3 -- Full Screen -C----------------------------------------------------------------------- - SUBROUTINE WNSET (I) - INCLUDE 'COMDIF' - LOGICAL FIRST - DATA FIRST/.TRUE./ - IF (FIRST) THEN - CALL PCDRAW (XOPEN,0,0,0,'PCDRAW') - FIRST = .FALSE. - ENDIF - IF (I .EQ. 2 .AND. IWNCUR .NE. 3) THEN - CALL PCDRAW (XWIN,2,0,0,ANS) - ELSE IF (I .EQ. 2 .AND. IWNCUR .EQ. 3) THEN - CALL PCDRAW (XWIN,3,XCLEAR,0,ANS) - CALL PCDRAW (XWIN,2,XCLEAR,0,ANS) - CALL PCDRAW (XCLEAR,0,0,0,ANS) - ELSE IF (I .EQ. 3) THEN - CALL PCDRAW (XWIN,3,XCLEAR,0,ANS) - ELSE - CALL PCDRAW (XWIN,I,0,0,ANS) - ENDIF - IWNCUR = I - RETURN - END -C----------------------------------------------------------------------- -C WNEND Tidy up for quitting -C----------------------------------------------------------------------- - SUBROUTINE WNEND - INCLUDE 'COMDIF' - CALL PCDRAW (XCLOSE,0,0,0,'WNEND') - RETURN - END -C----------------------------------------------------------------------- -C SCROLL Scroll text in current window -C----------------------------------------------------------------------- - SUBROUTINE SCROLL - INCLUDE 'COMDIF' - CHARACTER STRING - DATA IX,IY,IZ/0,0,0/,STRING/' '/ - CALL PCDRAW (XSCROL,IX,IY,IZ,STRING) - RETURN - END -C----------------------------------------------------------------------- -C DISPLA Display current angle settings -C----------------------------------------------------------------------- - SUBROUTINE DISPLA (ZT,ZO,ZC,ZP) - include 'fgraph.fd' - INCLUDE 'COMDIF' - character buffer*76 - integer*2 result, - $ irt(3),ict(3),irb(3),icb(3) - record /rccoord/ cursor,old - common /pclocl/ irt,ict,irb,icb,ntextw - nw = ntextw - icount = acount(1) - call gettextposition (old) - call settextwindow (irt(1),ict(1),irb(1),icb(1)) - call settextposition (2,2,cursor) - write (buffer,10000) ih,ik,il,zt,zo,zc,zp,nref,icount -10000 format (3i4,' ',4f8.2,' Nref',I5,' Int',i8) - call outtext (buffer(1:76)) - call settextwindow (irt(nw),ict(nw),irb(nw),icb(nw)) - call settextposition (old.row,old.col,cursor) - return - end -C----------------------------------------------------------------------- -C DISPLC Display current count settings -C----------------------------------------------------------------------- - SUBROUTINE DISPLC (ICOUNT) - include 'fgraph.fd' - INCLUDE 'COMDIF' - character buffer*64 - integer*2 result, - $ irt(3),ict(3),irb(3),icb(3) - record /rccoord/ cursor,old - common /pclocl/ irt,ict,irb,icb,ntextw - nw = ntextw - call gettextposition (old) - call settextwindow (irt(1),ict(1),irb(1),icb(1)) - call settextposition (2,54,cursor) - write (buffer,10000) nref,icount -10000 format (' Nref',I5,' Int',i8) - call outtext (buffer(1:24)) - call settextwindow (irt(nw),ict(nw),irb(nw),icb(nw)) - call settextposition (old.row,old.col,cursor) - return - end diff --git a/difrac/pcount.f b/difrac/pcount.f deleted file mode 100644 index fd022812..00000000 --- a/difrac/pcount.f +++ /dev/null @@ -1,149 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to take a count for a given time -C----------------------------------------------------------------------- - SUBROUTINE PCOUNT - INCLUDE 'COMDIF' - DIMENSION C(20),IDEV(20),IFREQ(4),FREQ(4) - REAL MPRESET - CHARACTER TAG(20)*1 - DATA TAG/20*' '/ - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - IF (NATTEN .NE. 0) THEN - WRITE (COUT,11000) - ELSE - WRITE (COUT,12000) - ENDIF - CALL FREEFM (ITR) - MPRESET = RFREE(1) - IF (MPRESET .EQ. 0.0) MPRESET = 1000.0 - JFLAG = 0 - IF (NATT .NE. IFREE(2)) THEN - JFLAG = 1 - NATT = IFREE(2) - ENDIF - IF (NATT .GT. NATTEN) NATT = NATTEN - WRITE (COUT,14000) - CALL YESNO ('N',ANS) -C----------------------------------------------------------------------- -C Get current angle values -C----------------------------------------------------------------------- -C CALL ANGET (THETA,OMEGA,CHI,PHI) - ICC = 0 -C----------------------------------------------------------------------- -C Use ANGSET to set the attenuator -C----------------------------------------------------------------------- - IF (JFLAG .EQ. 1) CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - IF (ICOL .NE. 0) THEN - WRITE (COUT,13000) - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN - ENDIF - CALL SHUTTR (99) -C----------------------------------------------------------------------- -C Single count only -C----------------------------------------------------------------------- - IF (ANS .EQ. 'N') THEN - CALL CCTIME (MPRESET,COUNT) - IF (NATTEN .NE. 0) THEN - WRITE (COUT,15000) MPRESET,NATT,COUNT - CALL GWRITE (ITP,' ') - ELSE - WRITE (COUT,16000) MPRESET,COUNT - CALL GWRITE (ITP,' ') - ENDIF - CALL SHUTTR (-99) - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Repetitive counting, deriving counter preformance statistics. -C----------------------------------------------------------------------- - 100 DO 110 I = 1,4 - IFREQ(I) = 0 - 110 CONTINUE - BIGTIM = MPRESET * 5. - WRITE (LPT,17000) BIGTIM - CALL CCTIME (BIGTIM,COUNT) - COUNT = COUNT*MPRESET/BIGTIM - SIGM = SQRT(COUNT) - AVC = COUNT + 0.5 - IF (NATTEN .NE. 0) THEN - WRITE (LPT,18000) MPRESET,NATT,AVC,SIGM - ELSE - WRITE (LPT,19000) MPRESET,AVC,SIGM - ENDIF - WRITE (LPT,20000) - DO 150 N = 1,50 - DO 120 I = 1,10 - CALL CCTIME (MPRESET,COUNT) - C(I) = COUNT - 120 CONTINUE - DO 130 I = 1,10 - IDEV(I) = C(I) - AVC - 130 CONTINUE - DO 140 I = 1,10 - TAG(I) = ' ' - IF (ABS(IDEV(I)) .GT. 0.674*SIGM) IFREQ(1) = IFREQ(1) + 1 - IF (ABS(IDEV(I)) .GT. SIGM) THEN - TAG(I) = 'A' - IFREQ(2) = IFREQ(2) + 1 - ENDIF - IF (ABS(IDEV(I)) .GT. 2.*SIGM) THEN - TAG(I) = 'B' - IFREQ(3) = IFREQ(3) + 1 - ENDIF - IF (ABS(IDEV(I)) .GT. 3.*SIGM) THEN - TAG(I) = 'C' - IFREQ(4) = IFREQ(4) + 1 - ENDIF - 140 CONTINUE - WRITE (LPT,21000) (IDEV(I),TAG(I),I = 1,10) - CALL KORQ (KQFLAG) - IF (KQFLAG .NE. 1) GO TO 155 - 150 CONTINUE - I = 50 - 155 BOT = 0.1*N - DO 160 I = 1,4 - FREQ(I) = IFREQ(I)/BOT - 160 CONTINUE - WRITE (LPT,22000) FREQ - WRITE (COUT,23000) - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'Y') GO TO 100 - CALL SHUTTR (-99) - KI = ' ' - RETURN -10000 FORMAT (' Timed Count at a Point (Y) ? ',$) -11000 FORMAT (' Type the Count Preset and the attenuator', - $ ' number (1000.0,0) ',$) -12000 FORMAT (' Type the Count Preset (1000.0) ',$) -13000 FORMAT (' Setting Collision') -14000 FORMAT (' Do you wish to repeat the counting for a stability', - $ ' test (N) ? ',$) -15000 FORMAT (' Time ',F8.3,', Attenuator',I2,', Count ',F7.0) -16000 FORMAT (' Time ',F8.3,', Count ',F7.0) -17000 FORMAT (' A count is taken for',F7.2,'secs to establish a', - $ ' reasonable mean.'/ - $ ' Counts are then repeated 500 times and a statistical', - $ ' summary printed.'/) -18000 FORMAT (/,' Time ',F6.2,', Attn.',I2,', Mean Count ',F7.0, - $ ' Sigma(Mean)',F7.1) -19000 FORMAT (/,' Time ',F6.2,', Mean Count ',F7.0, - $ ' Sigma(Mean)',F7.1) -20000 FORMAT (' The deviations from the Mean Count are printed', - $ ' followed by A, B or C,',/, - $ ' if the deviation is more than 1, 2 or 3 Sigma(Mean).') -21000 FORMAT (1X,10(I6,A1)) -22000 FORMAT (/' Distribution of Counts Observed Theoretical'/ - $ ' .GT. 0.674*Sigma ',F5.1,'% 50.0%'/ - $ ' .GT. 1.000*Sigma ',F5.1,'% 31.7%'/ - $ ' .GT. 2.000*Sigma ',F5.1,'% 4.6%'/ - $ ' .GT. 3.000*Sigma ',F5.1,'% 0.3%'/) -23000 FORMAT (' Do you want to repeat the procedure (N) ? ',$) - END diff --git a/difrac/peaksr.f b/difrac/peaksr.f deleted file mode 100644 index cab7b200..00000000 --- a/difrac/peaksr.f +++ /dev/null @@ -1,209 +0,0 @@ -C---------------------------------------------------------------------- -C Search for peaks to use with Index (OC) -C---------------------------------------------------------------------- - SUBROUTINE PEAKSR - INCLUDE 'COMDIF' - DIMENSION PHIP(40),THETAS(NSIZE),OMEGS(NSIZE),CHIS(NSIZE), - $ PHIS(NSIZE),ITIMS(NSIZE) - REAL SPRESET - EQUIVALENCE (ACOUNT( 1),THETAS(1)), - $ (ACOUNT( NSIZE+1),OMEGS(1)), - $ (ACOUNT(2*NSIZE+1),CHIS(1)), - $ (ACOUNT(3*NSIZE+1),PHIS(1)), - $ (ACOUNT(4*NSIZE+1),ITIMS(1)), - $ (BCOUNT( 1),PHIP(1)) - NATT = 0 - NSTORE = 1 - NTOT = 0 - SPRESET = 10000 -C---------------------------------------------------------------------- -C Write the header and find out if this is new search -C---------------------------------------------------------------------- - WRITE (COUT,9000) - CALL YESNO ('Y',ANS) -C---------------------------------------------------------------------- -C If the answer is yes, then do a straight search; -C if the answer is no, then there are 4 possibilities :-- -C 1) Recentre the existing peaks only; -C 2) Do nothing and exit; -C 3) Continue searching adding more peaks to the list and then -C centre the new ones only; -C 4) As 3), but recentre the old peaks as well. -C---------------------------------------------------------------------- - IF (ANS .EQ. 'N') THEN - CALL ANGRW (0,1,NTOT,160,0) -C---------------------------------------------------------------------- -C Search for more peaks ? -C---------------------------------------------------------------------- - WRITE (COUT,10000) NTOT - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN -C---------------------------------------------------------------------- -C Recentre existing peaks ? -C---------------------------------------------------------------------- - WRITE (COUT,11000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') CALL TCENTR (NSTORE) - KI = ' ' - RETURN -C---------------------------------------------------------------------- -C Centre all peaks or just the new peaks -C---------------------------------------------------------------------- - ELSE - WRITE (COUT,11100) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') NSTORE = NTOT + 1 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C 2theta min, max and step -C----------------------------------------------------------------------- - WRITE (COUT,12000) - CALL FREEFM (ITR) - TTMIN = RFREE(1) - TTMAX = RFREE(2) - TTSTEP = RFREE(3) - IF (TTMIN .EQ. 0.0) TTMIN = 10.0 - IF (TTMAX .LT. TTMIN) TTMAX = TTMIN + 20.0 - IF (TTSTEP .EQ. 0.0) TTSTEP = 4.0 -C----------------------------------------------------------------------- -C Chi min, max and step -C----------------------------------------------------------------------- - WRITE (COUT,13000) - CALL FREEFM (ITR) - CHMIN = RFREE(1) - CHMAX = RFREE(2) - CHSTEP = RFREE(3) - IF (CHMIN .EQ. 0.0 .AND. CHMAX .EQ. 0.0) THEN - CHMIN = 220.0 - CHMAX = 140.0 - ENDIF - IF (CHSTEP .EQ. 0.0) CHSTEP = 10.0 -C----------------------------------------------------------------------- -C How many peaks to search for -C----------------------------------------------------------------------- - WRITE (COUT,14000) - CALL FREEFM (ITR) - MAXPKS = IFREE(1) - IF (MAXPKS .EQ. 0) MAXPKS = 20 - MAXPKS = NTOT + MAXPKS -C---------------------------------------------------------------------- -C Preset for searching ? -C--------------------------------------------------------------------- - WRITE (COUT,13500) - CALL FREEFM (ITR) - SPRESET = RFREE(1) - IF(SPRESET .LE. 0.)SPRESET = 10000 -C----------------------------------------------------------------------- -C Is everything OK ? -C----------------------------------------------------------------------- - WRITE (COUT,14100) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF -C---------------------------------------------------------------------- -C Use PSCAN to find MAXPKS peaks -C---------------------------------------------------------------------- - WTHETA = TTMIN - WOMEGA = 0.0 - WCHI = CHMIN - WPHI = 270. - NATT = 0 - WRITE (COUT,14900) - CALL GWRITE (ITP,' ') - WRITE (LPT,14900) - 100 CALL ANGSET (WTHETA,WOMEGA,WCHI,WPHI,NATT,ICOL) - CALL PSCAN (NMAX,NTOT,SPRESET) -C---------------------------------------------------------------------- -C Save the peaks we found on disk -C---------------------------------------------------------------------- - CALL ANGRW (0,5,JUNK,160,0) - NMAX = NMAX + NTOT - IF (NMAX .GT. NSIZE) NMAX = NSIZE - NMIN = NTOT + 1 -C---------------------------------------------------------------------- -C Add peaks found by this PSCAN -C---------------------------------------------------------------------- - J = 0 - IF (NMIN .LE. NMAX) THEN - DO 110 I = NMIN,NMAX - J = J + 1 - THETAS(I) = RTHETA - OMEGS(I) = ROMEGA - CHIS(I) = RCHI - PHIS(I) = PHIP(J) - ITIMS(I) = 100 - 110 CONTINUE - NTOT = NMAX -C---------------------------------------------------------------------- -C And write them out just in case -C---------------------------------------------------------------------- - CALL ANGRW (1,5,NTOT,160,0) - ENDIF -C---------------------------------------------------------------------- -C Check for K or Q flag setting -C---------------------------------------------------------------------- - CALL KORQ (KQFLAG) - IF (KQFLAG .NE. 1) THEN - WRITE (COUT,15000) NTOT - CALL GWRITE (ITP,' ') - GO TO 120 - ENDIF -C---------------------------------------------------------------------- -C If we have too few peaks change angles and look for more -C---------------------------------------------------------------------- - IF (NTOT .LT. MAXPKS) THEN - IF (WCHI .GE. CHMAX) THEN - WCHI = CHMIN - IF (WTHETA .GE. TTMAX) THEN - WRITE (COUT,16000) NTOT - CALL GWRITE (ITP,' ') - WRITE (LPT,16000) NTOT - GO TO 120 - ENDIF - WTHETA = WTHETA + TTSTEP - ELSE - WCHI = WCHI + CHSTEP - ENDIF - CALL ANGET (RTHETA,ROMEGA,RCHI,RPHI) - WPHI = RPHI - GO TO 100 - ENDIF - NFOUND = NTOT - NSTORE + 1 - WRITE (COUT,17000) NFOUND - CALL GWRITE (ITP,' ') - WRITE (LPT,17000) NFOUND -C---------------------------------------------------------------------- -C We have finished searching for one reason or another -C---------------------------------------------------------------------- -120 IF (NTOT .GT. 0) THEN - CALL ANGRW (1,4,NTOT,160,0) -C---------------------------------------------------------------------- -C CAll TCENTR to center the peaks and return -C---------------------------------------------------------------------- - CALL TCENTR (NSTORE) - ENDIF - KI = ' ' - RETURN - 9000 FORMAT (' Routine to Search for Reflection Positions'// - $ ' Is this a new search (Y) ',$) -10000 FORMAT (' There are ',I2,' old positions in the list'/ - $ ' Do you want to search for more (Y) ',$) -11000 FORMAT (' Do you want to re-centre the old positions (Y) ',$) -11100 FORMAT (' New positions will be added to the list as they are', - $ ' found.'/ - $ ' Re-centre the old positions before', - $ ' centreing the new ones (Y) ? ',$) -12000 FORMAT (' 2-theta search: min, max, step (10,30,4) ',$) -13000 FORMAT (' Chi search (allowed range 270 to 90):'/ - $ ' min, max, step (220,140,10) ',$) -13500 FORMAT(' Counter preset during search (10000): ',$) -14000 FORMAT (' How many peaks do you want to find (20) ? ',$) -14100 FORMAT (' Is everything OK (Y) ? ',$) -14900 FORMAT (/18X,'2theta',5X,'Omega',6X,'Chi',7X,'Phi',7X,'INT') -15000 FORMAT (' User interrupt after ',I2,' peaks found') -16000 FORMAT (' Search for complete range. ',I2,' peaks found.') -17000 FORMAT (I4,' new peaks found before the end of the search.') - END diff --git a/difrac/pfind.f b/difrac/pfind.f deleted file mode 100644 index d7630ed9..00000000 --- a/difrac/pfind.f +++ /dev/null @@ -1,55 +0,0 @@ -C----------------------------------------------------------------------- -C Get the coarse value of Phi for PCENTR -C----------------------------------------------------------------------- - SUBROUTINE PFIND (TIM,MAXCOUNT) - INCLUDE 'COMDIF' - REAL MAXCOUNT, MCOUNT - DIMENSION PCOUNT(NSIZE) - EQUIVALENCE (ACOUNT(9*NSIZE + 1), PCOUNT(1)) -C----------------------------------------------------------------------- -C If offset by 2.5 deg and do 20 0.25 deg steps then we should find -C the maximum. -C----------------------------------------------------------------------- - STEPM = 0.05 - PSTEP = 0.25 - NPTS = 20 - NATT = 0 -C----------------------------------------------------------------------- -C Offset phi to the start of the scan -C----------------------------------------------------------------------- - 100 POFFS = PSTEP*10.0 - PHI = PHI - POFFS - IF (PHI .LT. 0.0) PHI = PHI + 360.0 - IF (PHI .GE. 360.0) PHI = PHI - 360.0 - PHIOFF = PHI - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) -C----------------------------------------------------------------------- -C Find the max intensity either by step and count or by doing a scan, -C depending on the type of diffractometer -C----------------------------------------------------------------------- - ICOUNT = 0 - MCOUNT = 0 - DO 110 I = 1,NPTS - CALL CCTIME (TIM,PCOUNT(I)) - CALL KORQ (IFLAG1) - IF (IFLAG1 .NE. 1) THEN - KI = 'O4' - RETURN - ENDIF - IF (PCOUNT(I) .GT. MCOUNT) THEN - MCOUNT = PCOUNT(I) - ICOUNT = I - ENDIF - PHI = PHI + PSTEP - IF (PHI .LT. 0.0) PHI = PHI + 360.0 - IF (PHI .GE. 360.0) PHI = PHI - 360.0 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - 110 CONTINUE - MAXCOUNT = REAL(MCOUNT) - IF (ICOUNT .EQ. 1 .OR. ICOUNT .EQ. NPTS) THEN - TIM = -5.0 - RETURN - ENDIF - PHI = PHIOFF + (ICOUNT - 1)*PSTEP - RETURN - END diff --git a/difrac/pltprf.f b/difrac/pltprf.f deleted file mode 100644 index 4bf6dc4f..00000000 --- a/difrac/pltprf.f +++ /dev/null @@ -1,144 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to plot a line profile on LPT -C Redirected output to Screen for SICS: MK -C----------------------------------------------------------------------- - SUBROUTINE PLTPRF (ACOUNT,NPTS,BEGIN) - COMMON /IODEVS/ ITP,ITR,LPT,LPTX,NB,NBLOCK,ISD,IID,IBYLEN, - $ IPR,NPR,IIP - CHARACTER*132 COUT(20) - COMMON /IOUASC/ COUT - CHARACTER BEGIN*2,BL(121)*1,BLANK*1,SPACE*1,AST*1,MARK*1 - CHARACTER ANS*1 - DIMENSION ACOUNT(121),IX(121),IAL(21) - BLANK = ' ' - SPACE = '+' - AST = '*' - MARK = '^' - IF (BEGIN .NE. 'DE') THEN - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') RETURN - ENDIF -C----------------------------------------------------------------------- -C Put intensities in descending order -C----------------------------------------------------------------------- - DO 100 J = 1,NPTS - IX(J) = J - 100 CONTINUE - MPTS = NPTS-1 - DO 120 J = 1,MPTS - BIG = 0 - DO 110 I = J,NPTS - IF (ACOUNT(I) .GT. BIG) THEN - BIG = ACOUNT(I) - ISAVE = IX(I) - JBIG = I - ENDIF - 110 CONTINUE - IX(JBIG) = IX(J) - ACOUNT(JBIG) = ACOUNT(J) - ACOUNT(J) = BIG - IX(J) = ISAVE - 120 CONTINUE -C----------------------------------------------------------------------- -C Scale to 50 max or 10(ACOUNT(1)/10) if ACOUNT(1) < 40 -C----------------------------------------------------------------------- - SMAX = 50.0 - JLOOP = 6 - SCALE = ACOUNT(1) - IF (SCALE .LE. 40.0) THEN - J = 1 + SCALE/10 - SCALE = 10*J - JLOOP = J + 1 - ENDIF - DO 130 J = 1,NPTS - ACOUNT(J) = ACOUNT(J)*SMAX/SCALE - 130 CONTINUE -C----------------------------------------------------------------------- -C Fix length of angle axis -C----------------------------------------------------------------------- - NINT = 2 - IF (NPTS .GT. 35) NINT = 1 - WRITE (LPT,11000) -C----------------------------------------------------------------------- -C Write the tenth lines -C----------------------------------------------------------------------- - INOW = 50 - DO 200 JLINE = 1,JLOOP - DO 150 J = 1,121 - BL(J) = BLANK - 150 CONTINUE - JK = 1 - DO 160 J = 1,NPTS - ICOUNT = INT(ACOUNT(J) +0.5) - IF (INOW .EQ. ICOUNT) THEN - JT = NINT*(IX(J)-1)+1 - BL(JT) = AST - IF (JT .GT. JK) JK = JT - ENDIF - 160 CONTINUE - WRITE (LPT,12000) INOW,(BL(J),J = 1,JK) -C---------------------------------------------------------------------- -C Write the intermediate lines -C----------------------------------------------------------------------- - IF (JLINE .NE. 6) THEN - DO 190 JINT = 1,9 - INOW = INOW-1 - DO 170 I = 1,121 - BL(I) = BLANK - 170 CONTINUE - JK = 1 - DO 180 J = 1,NPTS - ICOUNT = INT(ACOUNT(J) + 0.5) - IF (INOW .EQ. ICOUNT) THEN - JT = NINT*(IX(J)-1)+1 - BL(JT) = AST - IF (JT .GT. JK) JK = JT - ENDIF - 180 CONTINUE - WRITE (COUT,13000) (BL(J),J = 1,JK) - CALL GWRITE(ITP,' ') - 190 CONTINUE - INOW = INOW - 1 - ENDIF - 200 CONTINUE -C----------------------------------------------------------------------- -C Write the angle axis -C----------------------------------------------------------------------- - DO 210 J = 1,121 - BL(J) = BLANK - 210 CONTINUE - DO 220 J = 1,121,NINT - BL(J) = SPACE - 220 CONTINUE - JINT = NINT*5 - DO 230 J = 1,121,JINT - BL(J) = MARK - 230 CONTINUE - JK = NPTS*NINT - WRITE (COUT,14000) (BL(J),J = 1,JK) - CALL GWRITE(ITP,' ') - MPTS = 1+(NPTS/5) - NUM = 0 - DO 240 J = 1,MPTS - IAL(J) = NUM - NUM = NUM+5 - 240 CONTINUE - IF (NPTS .LE. 35) THEN - WRITE (COUT,15000) (IAL(J),J = 1,MPTS) - CALL GWRITE(ITP,' ') - ELSE - WRITE (COUT,16000) (IAL(J),J = 1,MPTS) - CALL GWRITE(ITP,' ') - ENDIF - RETURN -10000 FORMAT (' Plot Line Profile on LPT (Y) ? ',$) -11000 FORMAT (/) -12000 FORMAT (1X,I2,'>',121A1) -13000 FORMAT (3X,'+',121A1) -14000 FORMAT (3X,'.',121A1) -15000 FORMAT (1X,16(I3,7X)) -16000 FORMAT (1X,21(I3,2X)) - END - - diff --git a/difrac/prnbas.f b/difrac/prnbas.f deleted file mode 100644 index dcb45401..00000000 --- a/difrac/prnbas.f +++ /dev/null @@ -1,291 +0,0 @@ -C----------------------------------------------------------------------- -C Routine to print the Basic Data or Intensity Data on LPT -C----------------------------------------------------------------------- - SUBROUTINE PRNBAS - INCLUDE 'COMDIF' - DIMENSION RW(3,3),ANG(3) - CHARACTER CPROF*4,STRING*10 - WRITE (COUT,10000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - KZ = -1 - IF (ANS .EQ. ' ' .OR. ANS .EQ. '0') KZ = 0 - IF (ANS .EQ. '1') KZ = 1 - IF (ANS .EQ. '2') KZ = 2 - IF (ANS .EQ. '3') KZ = 3 - IF (KZ .EQ. -1) THEN - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Call to PRNINT to print Intensity Data -C----------------------------------------------------------------------- - IF (KZ .EQ. 2 .OR. KZ .EQ. 3) THEN - KI = ANS - CALL PRNINT - KI = ' ' - RETURN - ENDIF - IOUT = ITP - IF (KZ .EQ. 1) IOUT = LPT -C----------------------------------------------------------------------- -C Print the space-group symbol, wavelength and unit cell -C----------------------------------------------------------------------- - WRITE (STRING,11000) SGSYMB - WRITE (COUT,11100) STRING,WAVE - CALL GWRITE (IOUT,' ') - DO 100 I = 1,3 - ANG(I) = DEG*ATAN2(SANG(I),CANG(I)) - 100 CONTINUE -C----------------------------------------------------------------------- -C Matrix and cell data -C----------------------------------------------------------------------- - DO 110 I = 1,3 - DO 110 J = 1,3 - RW(I,J) = R(I,J)/WAVE - 110 CONTINUE - WRITE (COUT,13000) - CALL GWRITE (IOUT,' ') - WRITE (COUT,13100) (RW(1,J),J = 1,3),(SINABS(J),J = 1,3) - CALL GWRITE (IOUT,' ') - WRITE (COUT,13100) (RW(2,J),J = 1,3),(SINABS(J),J = 4,6) - CALL GWRITE (IOUT,' ') - WRITE (COUT,13100) (RW(3,J),J = 1,3) - CALL GWRITE (IOUT,' ') - WRITE (COUT,14000) AP,ANG - CALL GWRITE (IOUT,' ') -C----------------------------------------------------------------------- -C CZ data -C----------------------------------------------------------------------- - WRITE (COUT,15000) DTHETA,DOMEGA,DCHI - CALL GWRITE (IOUT,' ') -C----------------------------------------------------------------------- -C Attenuator Data -C----------------------------------------------------------------------- - IF (NATTEN .EQ. 0) THEN - WRITE (COUT,15100) - ELSE - WRITE (COUT,15200) (ATTEN(J),J = 1,NATTEN+1) - ENDIF - CALL GWRITE (IOUT,' ') -C----------------------------------------------------------------------- -C Psi data -C----------------------------------------------------------------------- - IF (DPSI .EQ. 0) THEN - WRITE (COUT,15300) - ELSE - WRITE (COUT,15400) PSIMIN,PSIMAX,DPSI - ENDIF - CALL GWRITE (IOUT,' ') -C----------------------------------------------------------------------- -C Reference Reflection data -C----------------------------------------------------------------------- - IF (NSTAN .EQ. 0) THEN - WRITE (COUT,15900) - CALL GWRITE (IOUT,' ') - ELSE - WRITE (COUT,16000) NSTAN,NINTRR - CALL GWRITE (IOUT,' ') - DO 310 J = 1, NSTAN - WRITE (COUT,17000)IHSTAN(J),IKSTAN(J),ILSTAN(J) - CALL GWRITE (IOUT,' ') - 310 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Re-Orientation data -C----------------------------------------------------------------------- - IF (NINTOR .EQ. 0) THEN - WRITE (COUT,18000) - ELSE - WRITE (COUT,19000) NINTOR,REOTOL - ENDIF - CALL GWRITE (IOUT,' ') - READ (IID,REC = 16) (IOH(I),I = 1,80) - READ (IID,REC = 17) (IOK(I),I = 1,80),NTOT - READ (IID,REC = 18) (IOL(I),I = 1,80) - I = NTOT + NTOT - IF (NTOT .GT. 0) THEN - WRITE (COUT,16900) I - CALL GWRITE (IOUT,' ') - DO 320 I = 1, NTOT - WRITE (COUT,17000)IOH(I),IOK(I),IOL(I) - CALL GWRITE (IOUT,' ') - 320 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Pause to allow users to read the screen -C----------------------------------------------------------------------- - WRITE (COUT,20000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) -C----------------------------------------------------------------------- -C Theta min/max and h,k,l max data -C----------------------------------------------------------------------- - WRITE (COUT,21000) THEMIN,THEMAX,IHMAX,IKMAX,ILMAX - CALL GWRITE (IOUT,' ') -C----------------------------------------------------------------------- -C SE data -C----------------------------------------------------------------------- - IF (NCOND .LE. 0) THEN - WRITE (COUT,22000) - CALL GWRITE (IOUT,' ') - ELSE - WRITE (COUT,23000) - CALL GWRITE (IOUT,' ') - DO 140 J = 1,NCOND - WRITE (COUT,24000) ICOND(J),IHS(J),IKS(J),ILS(J),IR(J),IS(J) - CALL GWRITE (IOUT,' ') - 140 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C SD data -C----------------------------------------------------------------------- - IF (ISCAN .EQ. 1) THEN - WRITE (COUT,25000) - CALL GWRITE (IOUT,' ') - ELSE - CPROF = 'No p' - IF (IPRFLG .EQ. 0) CPROF = ' P' - IF (ITYPE .EQ. 0) THEN - WRITE (COUT,26000) CPROF - CALL GWRITE (IOUT,' ') - ENDIF - IF (ITYPE .EQ. 2) THEN - WRITE (COUT,27000) CPROF - CALL GWRITE (IOUT,' ') - ENDIF - IF (ITYPE .EQ. 1) THEN - WRITE (COUT,28000) CPROF - CALL GWRITE (IOUT,' ') - ENDIF - IF (ITYPE .EQ. 3) THEN - WRITE (COUT,29000) CPROF - CALL GWRITE (IOUT,' ') - ENDIF - IF (ITYPE .EQ. 5) THEN - WRITE (COUT,30000) - CALL GWRITE (IOUT,' ') - ENDIF - IF (ITYPE .EQ. 6) THEN - WRITE (COUT,31000) - CALL GWRITE (IOUT,' ') - ENDIF - IF (ITYPE .EQ. 7) THEN - WRITE (COUT,32000) - CALL GWRITE (IOUT,' ') - ENDIF - IF (ITYPE .EQ. 8) THEN - WRITE (COUT,33000) - CALL GWRITE (IOUT,' ') - ENDIF - ENDIF -C IF (ITYPE .LE. 3) THEN -C IF (IBSECT .EQ. 1) THEN -C WRITE (COUT,34000) SPEED -C CALL GWRITE (IOUT,' ') -C ELSE -C WRITE (COUT,35000) SPEED -C CALL GWRITE (IOUT,' ') -C ENDIF -C ENDIF - WRITE (COUT,36000) AS,BS,CS - CALL GWRITE (IOUT,' ') - WRITE (COUT,37000) FRAC,TMAX,PA,PM - CALL GWRITE (IOUT,' ') - WRITE(COUT,37100),STEP, PRESET - CALL GWRITE (IOUT,' ') -C----------------------------------------------------------------------- -C DH data -C----------------------------------------------------------------------- - WRITE (COUT,38000) NSEG - CALL GWRITE (IOUT,' ') - DO 150 J = 1,NSEG - WRITE (COUT,39000) IHO(J), IKO(J), ILO(J), - $ IDH(J,1,1),IDH(J,2,1),IDH(J,3,1), - $ IDH(J,1,2),IDH(J,2,2),IDH(J,3,2), - $ IDH(J,1,3),IDH(J,2,3),IDH(J,3,3) - CALL GWRITE (IOUT,' ') - 150 CONTINUE -C----------------------------------------------------------------------- -C Compton scattering data (not active EJG April 94) -C----------------------------------------------------------------------- - IF (ISCAN .EQ. 1) THEN - WRITE (COUT,40000) - CALL GWRITE (IOUT,' ') - DO 160 J = 1,NSEG - WRITE (COUT,39000) JA(J),JB(J),JC(J),JMIN(J),JMAX(J) - CALL GWRITE (IOUT,' ') - 160 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Current GO data -C----------------------------------------------------------------------- - IF (NSET .LE. 0) READ (IID,REC=9) JUNK,JUNK,JUNK,JUNK,NSET - WRITE (COUT,43000) IND,NREF,NSET,NMSEG,NBLOCK - CALL GWRITE (IOUT,' ') - IF (ILN .EQ. 1) THEN - WRITE (COUT,44000) DELAY - CALL GWRITE (IOUT,' ') - ENDIF - KI = ' ' - RETURN -10000 FORMAT (10X,' Print Data on Terminal or LPT'/ - $ ' Options are :-- 0 Print Basic Data on Terminal'/ - $ ' 1 Print Basic Data on LPT'/ - $ ' 2 Print Intensity Data on Terminal'/ - $ ' 3 Print Intensity Data on LPT'/ - $ ' Type your choice (0) ',$) -11000 FORMAT (10A1) -11100 FORMAT (' Space-group ',A,' Wavelength ',F10.5) -13000 FORMAT (10X,'Orientation Matrix',26X,'Theta Matrix') -13100 FORMAT (3F12.8,5X,3F12.8) -14000 FORMAT (' Cell ',3F9.4,5X,3F9.3) -15000 FORMAT (' D2theta ',F6.3,' Domega ',F6.3,' Dchi ',F6.3) -15100 FORMAT (' No attenuators.') -15200 FORMAT (' Attenuator factors ',6F8.3) -15300 FORMAT (' No Psi rotation') -15400 FORMAT (' Psi rotation from',F7.2,' to',F7.2,' in steps of',F6.2) -15900 FORMAT (' No reference reflection measurements') -16000 FORMAT (I3,' reference reflections measured every',I4, - $ ' reflections') -16900 FORMAT (I4,' Alignment/Re-orientation Reflections', - $ ' (including Friedel equivalents)') -17000 FORMAT (4(3I4,3X)) -18000 FORMAT (' No Re-orientation during data-collection.') -19000 FORMAT (' Re-orientation every',I4,' reflections.'/ - $ ' Angular tolerance for new matrix acceptance',F7.3) -20000 FORMAT (/' Type when ready to proceed.') -21000 FORMAT (' 2Theta Limits: Min',F7.3,'; Max',F8.3,'.', - $ ' Hmax',I3,', Kmax',I3,', Lmax',I3,'.') - $ -22000 FORMAT (' There are NO Explicit Absence Conditions') -23000 FORMAT (' The Explicit Absence Conditions are :--') -24000 FORMAT (' Type',I3,' -- ', - $ I4,'*h +',I2,'*k +',I2,'*l = ',I2,'*n +',I2) -30000 FORMAT (' Peak Top Counting - 2Theta range') -31000 FORMAT (' Peak Top Counting - Omega range') -32000 FORMAT (' Economized Peak Top - 2Theta range') -33000 FORMAT (' Economized Peak Top - Omega range') -26000 FORMAT (' Omega/2Theta Scan. ',A,'rofile analysis.') -27000 FORMAT (' Omega Scan. ',A,'rofile analysis.') -28000 FORMAT (' Omega/2Theta Scan with Precision Control. ',A, - $ 'rofile analysis.') -29000 FORMAT (' Omega Scan with Precision Control. ',A, - $ 'rofile analysis.') -25000 FORMAT (' Compton or TDS Measurements') -35000 FORMAT (' Bisecting Geometry. Scan speed ',F8.3,'deg/min') -34000 FORMAT (' Parallel Geometry. Scan speed ',F8.3,'deg/min') -36000 FORMAT (' Scan Parameters: ', - $ F6.3,' + ',F6.3,'*tan(theta) + ',F6.3) -37000 FORMAT (' Time/Precision Params: ', - $ ' Bkfrac',F6.3,'; Tmax ',F6.1,', PA ',F6.2,', PM ',F6.2) -37100 FORMAT(' Stepwidth: ',F8.3,' Counter Preset: ', F12.2) -38000 FORMAT (' Segment Data (DH Matrices) ',I2,' segment(s)') -39000 FORMAT (12I4) -40000 FORMAT (' Brillouin Zone Data for each segment',/, - $ ' JA JB JC JMN JMX') -43000 FORMAT (' Next reflection: ',3I4,', #',I5,', set',I3, - $ ', segment',I2,', at record ',I4) -44000 FORMAT (' This is a low-temperature experiment.'/ - $ ' The waiting time after a refill is',F6.2,' minutes.') - END diff --git a/difrac/prnint.f b/difrac/prnint.f deleted file mode 100644 index 909bc28a..00000000 --- a/difrac/prnint.f +++ /dev/null @@ -1,423 +0,0 @@ -C----------------------------------------------------------------------- -C Routine to print intensity data from the IDATA file -C -C The data is listed on the terminal if KI = '2', or -C LPT if KI = '3'. -C -C For the BI command, the 25 reflections which are in the 2theta -C range and have the highest Inet/Sigma(Inet) are saved, sorted and -C printed. -C -C 2theta values are calculated from the R matrix in COMMON. -C----------------------------------------------------------------------- - SUBROUTINE PRNINT - INCLUDE 'COMDIF' - PARAMETER (NSIG = 50) - DIMENSION VEC(3),ENREFB(10), - $ IHSIG(NSIG),IKSIG(NSIG),ILSIG(NSIG), - $ INSIG(NSIG),RDSIG(NSIG),THSIG(NSIG) -C EQUIVALENCE (ACOUNT( 1),IHSIG(1)),(ACOUNT( 51),IKSIG(1)), -C $ (ACOUNT(101),ILSIG(1)),(ACOUNT(151),INSIG(1)), -C $ (ACOUNT(201),RDSIG(1)),(ACOUNT(251),THSIG(1)), -C $ (NREFB(1),ENREFB(1)) - DATA MOST/25/ - IF (KI .EQ. 'BI') THEN - WRITE (COUT,10000) MOST - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - ENDIF - IP = 0 - IF (KI .EQ. '2') IOUT = ITP - IF (KI .EQ. '3') IOUT = LPT - NSAVE = NBLOCK - IF (NATTEN .GT. 0 .AND. KI .NE. 'BI') THEN - DO 100 I = 1,NATTEN+1 - J = I - 1 - WRITE (COUT,12000) J,ATTEN(I) - CALL GWRITE (IOUT,' ') - 100 CONTINUE - ENDIF - IF (KI .EQ.'BI') THEN - WRITE (COUT,13000) - SIGMIN = 100000.0 - ELSE - WRITE (COUT,14000) - ENDIF - CALL FREEFM (ITR) - TPMIN = RFREE(1) - TPMAX = RFREE(2) - SIGRAT = RFREE(3) - IRRFLG = 0 - IF (TPMIN .EQ. 0 .AND. TPMAX .EQ. 0) THEN - TPMIN = THEMIN - TPMAX = THEMAX - SIGRAT = -100000.0 - IRRFLG = 1 - ENDIF - CALL LENFIL (IID,LASTBL) - 110 WRITE (COUT,15000) LASTBL - CALL FREEFM (ITR) - NBEGIN = IFREE(1) - IF (NBEGIN .LT. 20) NBEGIN = 20 - NEND = IFREE(2) - IF (NEND .EQ. 0) NEND = NBEGIN - IF (NEND .GT. LASTBL) NEND = LASTBL - IALL = 0 - IF (NEND .EQ. LASTBL) IALL = 1 - IF (KI .EQ. 'BI') WRITE (LPT,17000) - NBLOCK = NBEGIN - ISAVE = 0 -C----------------------------------------------------------------------- -C Read the specified blocks of intensity data -C----------------------------------------------------------------------- - DO 150 J = NBEGIN,NEND - READ (IID,REC=NBLOCK) - $ IHK,ILA,BCOUNT,BBGR1,BBGR2,BTIME,ENREFB,BPSI - NBLOCK = NBLOCK + 1 -C----------------------------------------------------------------------- -C Unpack indices and NATT -C----------------------------------------------------------------------- - DO 140 NB = 1,10 - ITEMP = IHK(NB)/1000 - IH = ITEMP - 500 - IK = IHK(NB) - 500 - 1000*ITEMP - ITEMP = ILA(NB)/1000 - IL = ITEMP - 500 - IA = ILA(NB) - 1000*ITEMP - IF (IH .EQ. 99) THEN - THET2 = 0.0 - GO TO 140 - ENDIF -C----------------------------------------------------------------------- -C Calculate the 2theta value -C----------------------------------------------------------------------- - SUM = 0.0 - DO 120 I = 1,3 - VEC(I) = R(I,1)*IH + R(I,2)*IK + R(I,3)*IL - SUM = SUM + VEC(I)*VEC(I) - 120 CONTINUE - SINSQ = 0.25*SUM - IF (SINSQ .GE. 1.0) THEN - NBLOCK = NBLOCK - 1 - WRITE (COUT,17100) NBLOCK,IH,IK,IL - CALL GWRITE (ITP,' ') - GO TO 110 - ENDIF - THET2 = 2.0*DEG*ATAN(SQRT(SINSQ/(1.0 - SINSQ))) - IF (KI .EQ. 'BI') THEN - IF (THET2 .LT. TPMIN) GO TO 140 - ELSE - IF (BPSI(NB) .LT. 900.0 .OR. - $ (BPSI(NB) .GE. 900.0 .AND. IRRFLG .EQ. 0)) THEN - IF (THET2 .LT. TPMIN .OR. THET2 .GT. TPMAX) GO TO 140 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Correct for Precision mode (ITYPE = 3 or 4) -C Allow for Precision mode with Profile Analysis -C----------------------------------------------------------------------- - RATIO = FRAC - NTIMES = 1 - IF (ITYPE .EQ. 3 .OR. ITYPE .EQ. 4) THEN - NTIMES = BTIME(NB) - RATIO = FRAC - IF (IPRFLG .EQ. 0) NTIMES = ENREFB(NB) - ENDIF - IF (ITYPE .EQ. 7 .OR. ITYPE .EQ. 8) THEN - IRAT = BTIME(NB) - RATIO = 1000*(BTIME(NB) - IRAT)/IRAT - ENDIF - IF (IPRFLG .EQ. 0 .AND. BPSI(NB) .LT. 900) RATIO = BTIME(NB) - RATIO = 1.0/(RATIO + RATIO) - BAKGND = BBGR1(NB) + BBGR2(NB) - INET = BCOUNT(NB) - RATIO*BAKGND - RESD = INET/SQRT(BCOUNT(NB) + RATIO*RATIO*BAKGND) - AT = ATTEN(IA+1) - INET = AT*INET/NTIMES - IF (KI .EQ. 'BI') THEN - IF (BPSI(NB) .LT. 900.0) THEN - IF (ISAVE .LT. NSIG) THEN - ISAVE = ISAVE + 1 - IHSIG(ISAVE) = IH - IKSIG(ISAVE) = IK - ILSIG(ISAVE) = IL - INSIG(ISAVE) = INET - RDSIG(ISAVE) = RESD - THSIG(ISAVE) = THET2 - IF (RESD .LT. SIGMIN) THEN - SIGMIN = RESD - IMIN = ISAVE - ENDIF - ELSE - IF (RESD .GT. SIGMIN) THEN - IHSIG(IMIN) = IH - IKSIG(IMIN) = IK - ILSIG(IMIN) = IL - INSIG(IMIN) = INET - RDSIG(IMIN) = RESD - THSIG(IMIN) = THET2 - SIGMIN = 100000.0 - DO 130 I = 1,NSIG - IF (RDSIG(I) .LT. SIGMIN) THEN - SIGMIN = RDSIG(I) - IMIN = I - ENDIF - 130 CONTINUE - ENDIF - ENDIF - ENDIF - GO TO 140 - ENDIF -C----------------------------------------------------------------------- -C Reflection data print for the PD command. -C Sort out the reference reflections from the rest -C----------------------------------------------------------------------- - IF (RESD .GE. SIGRAT) THEN - IF (BPSI(NB) .LT. 900.0) THEN - IF (IP .NE. 0) THEN - IF (KI .EQ. '3') THEN - WRITE (COUT,18000) - CALL GWRITE (IOUT,' ') - ENDIF - IP = 0 - ENDIF - WRITE (COUT,19000) IH,IK,IL,THET2,BTIME(NB),IA, - $ BBGR1(NB),BCOUNT(NB),BBGR2(NB), - $ BPSI(NB),INET,RESD - CALL GWRITE (IOUT,' ') - ELSE - IP = 0 - DO 135 I = 1,NSTAN - IF (IH .EQ. IHSTAN(I) .AND. - $ IK .EQ. IKSTAN(I) .AND. - $ IL .EQ. ILSTAN(I)) IP = I - 1 - 135 CONTINUE - IF (IP .EQ. 0) THEN - IF (KI .EQ. '3') THEN - WRITE (COUT,18000) - CALL GWRITE (IOUT,' ') - ENDIF - ENDIF - IP = IP + 1 - WRITE (COUT,20000) IP,IH,IK,IL,THET2,BTIME(NB),IA, - $ BBGR1(NB),BCOUNT(NB),BBGR2(NB), - $ INET,RESD - CALL GWRITE (IOUT,' ') - ENDIF - ENDIF - 140 CONTINUE - 150 CONTINUE -C----------------------------------------------------------------------- -C Sort and print for the BI command -C----------------------------------------------------------------------- - IF (KI .EQ. 'BI') THEN - CALL SORTIS (RDSIG(1),ISAVE,IHSIG(1),IKSIG(1),ILSIG(1),INSIG(1), - $ THSIG(1)) - ISIG = MOST - IF (ISAVE .LT. MOST) ISIG = ISAVE - DO 160 I = 1,ISIG - WRITE (LPT,21000) IHSIG(I),IKSIG(I),ILSIG(I), - $ THSIG(I),INSIG(I),RDSIG(I) - 160 CONTINUE - ENDIF - IF (IALL .EQ. 0) THEN - IF (KI .EQ. 'BI') THEN - WRITE (COUT,22000) - ELSE - WRITE (COUT,23000) - ENDIF - CALL YESNO ('N',ANS) - IF (ANS .EQ. 'Y') GO TO 110 - ENDIF - NBLOCK = NSAVE - KI = ' ' - RETURN -10000 FORMAT (' Search for the',I3,' biggest Inet/Sigma(Inet) (Y) ? ',$) -12000 FORMAT (5X,' Attenuator(',I1,') ',F7.2) -13000 FORMAT (' Type 2thetamin ',$) -14000 FORMAT (/' Reflns can be selected on 2theta and Inet/Sig(Inet)'/ - $ ' Type 2thetamin, 2thetamax and min(I/sigI)', - $ ' (All Reflns) ',$) -15000 FORMAT (' Intensity data is in records 20 to',I5/ - $ ' Type the range of records to be examined ',$) -16000 FORMAT (/' Records',I4,' to',I4,' will be used.') -17000 FORMAT (' h k l 2Theta Inet I/SigI') -17100 FORMAT (3I4,' in record',I5,' is incompatible with', - $ ' the current orientation matrix.'/ - $ ' Please try again.') -18000 FORMAT ('%') -19000 FORMAT (3X, 3(I3,1X),2(F7.3,1X),I1,F5.0,F7.0,F5.0,F8.3,I8,F8.2) -20000 FORMAT (2X,I1,3(I3,1X),2(F7.3,1X),I1,F5.0,F7.0,F5.0,8X,I8,F8.2) -21000 FORMAT (3X,3(I3,1X),F7.2,I8,F8.2) -22000 FORMAT (' Do you want to search more records (N) ? ',$) -23000 FORMAT (' Do you want to print more records (N) ? ',$) - END -C----------------------------------------------------------------------- -C Sort the largest Inet/Sigma(Inet) values -C----------------------------------------------------------------------- - SUBROUTINE SORTIS (RIOS,MOST,LH,LK,LL,LI,RT) - DIMENSION RIOS(1), LH(1), LK(1), LL(1), LI(1), RT(1) - M = 2 - 100 INTVL = MOST/M - IF (INTVL .EQ. 0) INTVL = 1 - IFIN = MOST - INTVL - 110 MARK = 0 - DO 120 I = 1,IFIN - J = I+INTVL - IF (RIOS(I) .LT. RIOS(J)) THEN - TEMP = RIOS(I) - RIOS(I) = RIOS(J) - RIOS(J) = TEMP - ITEM = LH(I) - LH(I) = LH(J) - LH(J) = ITEM - ITEM = LK(I) - LK(I) = LK(J) - LK(J) = ITEM - ITEM = LL(I) - LL(I) = LL(J) - LL(J) = ITEM - ITEM = LI(I) - LI(I) = LI(J) - LI(J) = ITEM - TEMP = RT(I) - RT(I) = RT(J) - RT(J) = TEMP - MARK = 1 - ENDIF - 120 CONTINUE - IF (MARK .EQ. 1) GO TO 110 - IF (INTVL .NE. 1) THEN - M = 2*M - GO TO 100 - ENDIF - RETURN - END -C----------------------------------------------------------------------- -C Subroutine to find the length of a direct-access file -C----------------------------------------------------------------------- - SUBROUTINE LENFIL (IUNIT,LASTBL) - DIMENSION ISTEP(4) - DATA ISTEP/1000,100,10,1/ - NRSAVE = 0 - DO 120 I = 1,4 - IDEL = ISTEP(I) - NOFF = NRSAVE - N1 = 1 - N2 = 10 - IF (I .EQ. 1) N2 = 1000 - DO 100 N = N1,N2 - NREC = NOFF + N*IDEL - READ (IUNIT, REC = NREC, IOSTAT = IERR) RJUNK - IF (IERR .NE. 0) GO TO 110 - NRSAVE = NREC - 100 CONTINUE - 110 IF (I .EQ. 4) THEN - LASTBL = NREC - 1 - RETURN - ENDIF - 120 CONTINUE - END -C----------------------------------------------------------------------- -C -C Convert the intensity data on the direct-access IDATA.DA file, into -C a formatted ASCII file suitable for transmission to or processing by -C other computers. -C -C The contents and format of the ASCII file are :-- -C h,k,l, Ia, Ib1, Ipeak, Ib2, Time, Nref, Ipsi -C ( 3I4, I2, I6, I7, I6, F9.5, I6, I5) where -C Ia is the attenuator index (0 to 5), -C Ib1 is the low angle background, -C Ipeak is the total peak count, -C Ib2 is the high angle background, -C Time is (time for 1 background) / (Time for peak), i.e. FRAC -C for normal scans, or -C 10*number of scans + FRAC for controlled precision modes, -C Nref is the reflection sequence number, -C Ipsi is the psi value, usually 0, 999 for standards. -C -C----------------------------------------------------------------------- - SUBROUTINE IDTOAS - INCLUDE 'COMDIF' - DIMENSION ENREFB(10) - EQUIVALENCE(NREFB(1),ENREFB(1)) - CHARACTER FILEF*40,DEFNAM*10,MORE - DEFNAM = 'IDATA.ASC ' -C----------------------------------------------------------------------- -C Print the header and connect the file IFM, the formatted ASCII file -C----------------------------------------------------------------------- - IFM = IOUNIT(9) - 100 WRITE (COUT,10000) DEFNAM - FILEF(1:10) = 'DONT DO IT' - CALL ALFNUM (FILEF) - IF (FILEF .EQ. ' ') FILEF = DEFNAM//' ' - CALL IBMFIL (FILEF,IFM,IBMREC,'SU',IERR) - IF (IERR .NE. 0) GO TO 100 -C----------------------------------------------------------------------- -C Find the intensity data record numbers to process -C----------------------------------------------------------------------- - CALL LENFIL (IID,LASTBL) - WRITE (COUT,11000) LASTBL - CALL YESNO ('Y',ANS) - 110 IF (ANS .EQ. 'Y') THEN - ILAST = 1 - NBEGIN = 20 - NEND = LASTBL - ELSE - WRITE (COUT,12000) - CALL FREEFM (ITR) - NBEGIN = IFREE(1) - NEND = IFREE(2) - IF (NEND .EQ. 0) NEND = NBEGIN - ILAST = 0 - IF (NEND .EQ. LASTBL) ILAST = 1 - ENDIF -C----------------------------------------------------------------------- -C Write the data needed by DATRD2 etc from record 1 -C----------------------------------------------------------------------- - WRITE (IFM,12900) THEMAX,DFTYPE,DFMODL,FRAC -C----------------------------------------------------------------------- -C Process the valid data in the selected intensity data records -C----------------------------------------------------------------------- - DO 130 I = NBEGIN,NEND - READ (IID,REC = I) IHK,ILA,BCOUNT,BBGR1,BBGR2,BTIME,ENREFB,BPSI - DO 120 J = 1,10 - IF (IHK(J) .NE. 599599) THEN - IH = IHK(J)/1000 - 500 - IK = IHK(J) - 1000*(IH + 500) - 500 - IL = ILA(J)/1000 - 500 - IA = ILA(J) - 1000*(IL + 500) - IB1 = BBGR1(J) - IPEAK = BCOUNT(J) - IB2 = BBGR2(J) - TIME = BTIME(J) - NREF = ENREFB(J) - IPSI = BPSI(J) - WRITE (IFM,13000) IH,IK,IL,IA,IB1,IPEAK,IB2,TIME,NREF,IPSI - ENDIF - 120 CONTINUE - 130 CONTINUE -C----------------------------------------------------------------------- -C Any more to processing ? -C----------------------------------------------------------------------- - IF (ILAST .EQ. 0) THEN - WRITE (COUT,14000) - CALL YESNO ('N',MORE) - IF (MORE .EQ. 'Y') GO TO 110 - ENDIF - CALL IBMFIL (FILEF,-IFM,IBMREC,'SU',IERR) - KI = ' ' - RETURN -10000 FORMAT (/10X,'Convert the IDATA File to ASCII'/ - $ ' Type the Output ASCII Filename (',A,') ',$) -11000 FORMAT (' Valid data is in records 20 to',I5,'. Transform it all', - $ ' (Y) ? ',$) -12000 FORMAT (' Type the First and Last record to be transferred ',$) -12900 FORMAT (F8.3,1X,2A4,F8.4) -13000 FORMAT (3I4,I2,I6,I7,I6,F9.5,I6,I5) -14000 FORMAT (' Do you wish to transfer more records (N) ? ',$) - END diff --git a/difrac/profil.f b/difrac/profil.f deleted file mode 100644 index 47f9bf1c..00000000 --- a/difrac/profil.f +++ /dev/null @@ -1,475 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to find peak limits in the profile -C----------------------------------------------------------------------- - SUBROUTINE PROFIL - INCLUDE 'COMDIF' - DIMENSION SMOOTH(500),IHTAGS(4),ID(500) -C----------------------------------------------------------------------- -C -C Explanation of symbols used for Profile Analysis -C -C PLIM Probability lower limit. Arbitrarily 0.01 -C A12 Ratio of Int(alpha1)/Int(alpha2) (1.8) -C NWIND No. of profile points in the test window. (6) -C IDEL No. of pts in the profile + 1 -C COUNT Sum of all profile points -C FRAC Ratio of 0.5*Background time/Peak time -C SIGLIM Inet significance limit -C CON No. of profile pts per degree scan (STEPDG). This -C gives a power of two steps for all speeds. -C SPEED Scan speed in degs per min. -C D12 Alpha1 to Alpha2 seperation in degrees -C ITYPE Scan type indicator. 0 or 1 2Theta; 2 or 3 Omega -C AS Scan before Alpha1 in degrees -C CS Scan after Alpha2 in degrees -C ACOUNT(I) Array of profile intensity values -C IWARN Warning flag from the measuring routine. 0 = OK. -C IPRFLG Profile analysis indicator. 0 = Do; 1 = Dont. -C BGRD1 Low angle background, taken for FRAC*Peak-time -C BGRD2 High angle background, as BGRD1. -C RSW PDP8E Read switch register routine. -C RSW(N,J) Reads 1-bit switch N into J -C STEPOF Fraction of As (and Cs) to step off from Alpha1 -C (and Alpha2) before starting the profile analysis -C -C----------------------------------------------------------------------- - DATA PLIM/0.01/,A12/1.8/ - IF ((IPRFLG .NE. 0 .AND. KI(1:1) .NE. 'G') .OR. - $ IDEL .LT. 10) RETURN -C----------------------------------------------------------------------- -C Results are sent to the printer for either :-- -C 1. Individual measurements, i.e. not part of GO; or -C 2. Part of GO and Switch 4 is set to 1. -C----------------------------------------------------------------------- - IF (KI(1:1) .EQ. 'G') THEN - CALL RSW (4,ILPT) - ELSE - ILPT = 0 - ENDIF - A1 = A12/(A12 + 1.0) - A2 = 1.0 - A1 - NWIND = 6 - ILOW = 1 - NP = IDEL - 1 - IHIGH = NP - SUM = COUNT - FRAC1 = FRAC - SIGLIM = 2.0 - CON = STEPDG - RD12 = CON*D12 - IF (ITYPE .EQ. 2 .OR. ITYPE .EQ. 3) RD12 = RD12*0.5 - NXPTS = 1000.0/((AS + CS)*CON + RD12) - ID12 = RD12 + 0.5 - ITOL = CON*(AS + CS)/8.0 - MAXI = 0 -C----------------------------------------------------------------------- -C Do not try to process peak top measurements -C----------------------------------------------------------------------- - IF (ITYPE .GE. 4) RETURN - CMAX = 0 - DO 100 I = 1,NP - ACT = ACOUNT(I+1) - IF (CMAX .LT. ACT) CMAX = ACT - 100 ACOUNT(I) = ACT -C----------------------------------------------------------------------- -C Smooth the profile (5-point average) -C----------------------------------------------------------------------- - SMOOTH(1) = (ACOUNT(1) + ACOUNT(2) + ACOUNT(3))/3.0 - SMOOTH(2) = (3.0*SMOOTH(1) + ACOUNT(4))/4.0 - DO 110 I = 3,NP-2 - SMOOTH(I) = (ACOUNT(I-2) + ACOUNT(I-1) + ACOUNT(I) + - $ ACOUNT(I+1) + ACOUNT(I+2))/5.0 - 110 CONTINUE - SMOOTH(NP-1) = (SMOOTH(NP-2)*5 - ACOUNT(NP-4))/4.0 - SMOOTH(NP) = (4.0*SMOOTH(NP-1) - ACOUNT(NP-3))/3.0 -C----------------------------------------------------------------------- -C Test if peak is OK from MESINT or profile not needed -C----------------------------------------------------------------------- - IF (IWARN .NE. 0) GO TO 240 -C----------------------------------------------------------------------- -C Work out Inet and sigma(Inet) -C----------------------------------------------------------------------- - BTOT = (BGRD1 + BGRD2)/(FRAC + FRAC) - BKN = BTOT/NP - TOP = COUNT - BTOT - BOT = SQRT(COUNT + BTOT/(FRAC + FRAC)) -C----------------------------------------------------------------------- -C If GO mode and no profile analysis print results for non-standards -C----------------------------------------------------------------------- - IF (IPRFLG .NE. 0 .AND. KI(1:1) .EQ. 'G') THEN - IF (ISTAN .EQ. 0) THEN - ITOP = TOP + 0.5 - IBOT = BOT + 0.5 - IF (TOP .LE. SIGLIM*BOT) THEN - IF (ILPT .EQ. 0) WRITE (LPT,10000) IH,IK,IL,ITOP,IBOT,NREF - WRITE (COUT,10000) IH,IK,IL,ITOP,IBOT,NREF - ELSE - IF (NATT .NE. 0) THEN - IF (ILPT .EQ. 0) - $ WRITE (LPT,15100) IH,IK,IL,NATT,ITOP,IBOT,NREF - WRITE (COUT,15100) IH,IK,IL,NATT,ITOP,IBOT,NREF - ELSE - IF (ILPT .EQ. 0) - $ WRITE (LPT,15200) IH,IK,IL,ITOP,IBOT,NREF - WRITE (COUT,15200) IH,IK,IL,ITOP,IBOT,NREF - ENDIF - ENDIF - CALL GWRITE (ITP,' ') - GO TO 240 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Test if peak is considered significant and print if not -C----------------------------------------------------------------------- - IF (TOP .LE. SIGLIM*BOT) IWARN = 1 - IF (IWARN .NE. 0) THEN - ITOP = TOP + 0.5 - IBOT = BOT + 0.5 - IF (ILPT .EQ. 0) WRITE (LPT,10000) IH,IK,IL,ITOP,IBOT,NREF - WRITE (COUT,10000) IH,IK,IL,ITOP,IBOT,NREF - CALL GWRITE (ITP,' ') - ENDIF - IF (IWARN .NE. 0) GO TO 240 -C----------------------------------------------------------------------- -C Profile is OK and significant. Print smoothed profile if Demo -C----------------------------------------------------------------------- - IF (KI .EQ. 'DE') THEN - WRITE (COUT,11000) - CALL GWRITE (ITP,' ') - WRITE (COUT,12000) (SMOOTH(J),J = 1,NP) - CALL GWRITE (ITP,' ') - ENDIF -C----------------------------------------------------------------------- -C Test that there are no funny bumps in the profile, by ensuring that -C the max of the peak is near the correct position. -C MAXA is the calculated position of the alpha peak -C MAXI is the intensity weighted maximum -C----------------------------------------------------------------------- - MAXA = AS*CON + RD12*A2 + 0.5 - SUMI = 0 - SUMNI = 0 - DO 120 N = 1,NP - D = SMOOTH(N) - BKN - SUMI = SUMI + D - SUMNI = SUMNI + N*D - 120 CONTINUE - MAXI = 0.5 + SUMNI/SUMI -C----------------------------------------------------------------------- -C Allow for a variable acceptance window -C----------------------------------------------------------------------- - CALL RSW(8,I) - ITOL = 5*I + ITOL - CALL RSW(7,I) - ITOL = 10*I + ITOL - CALL RSW(6,I) - ITOL = 20*I + ITOL - IF (ABS(MAXI-MAXA) .GT. ITOL) THEN - IF (TOP .GT. 2.0*SIGLIM*BOT) THEN - IWARN = 2 - WRITE (COUT,14000) IH,IK,IL,MAXI,MAXA,BGRD1,COUNT,BGRD2 - CALL GWRITE (ITP,' ') - IF (ILPT .EQ. 0) - $ WRITE (LPT,14000) IH,IK,IL,MAXI,MAXA,BGRD1,COUNT,BGRD2 - ELSE - WRITE (COUT,14100) IH,IK,IL,MAXI,MAXA,BGRD1,COUNT,BGRD2 - CALL GWRITE (ITP,' ') - IF (ILPT .EQ. 0) - $ WRITE (LPT,14100) IH,IK,IL,MAXI,MAXA,BGRD1,COUNT,BGRD2 - ENDIF - GO TO 240 - ENDIF -C----------------------------------------------------------------------- -C The profile is suitable for analysis to find the limits -C J1 is the beginning of the low angle search -C J2 is the beginning of the high angle search -C----------------------------------------------------------------------- -C J1 = MAXI - STEPOF*CON*AS - A2*ID12 -C J2 = MAXI + STEPOF*CON*CS + A1*ID12 - J1 = MAXI - ((STEPOF*AS)/STEP) - A2*ID12 - J2 = MAXI + ((STEPOF*CS)/STEP) + A1*ID12 - IF (J1 .LE. NWIND .OR. J2 .GE. NP-NWIND) THEN - ILOW = 1 - IHIGH = NP - GO TO 210 - ENDIF -C----------------------------------------------------------------------- -C Find the low angle limit by moving down from J1 -C Set the window width to 0.67*0.67*CNT/5 -C Find how many of the next NWIND values are in the window and if more -C than half are in the window, switch on the detector PROB. -C----------------------------------------------------------------------- - J = J1 - LIM = J - 1 - IFLAG = 0 - PROB = 1 - DO 160 I = NWIND,LIM - CNT = SMOOTH(J) - W = 0.08978*CNT - SUM = 0 - DO 150 KK = J-NWIND,J-1 - DIFF = CNT - SMOOTH(KK) - DC = DIFF*DIFF - IF (DC .LT. W) SUM = SUM + 1 - 150 CONTINUE - IF (SUM .GE. NWIND/2) IFLAG = 1 - IF (IFLAG .NE. 0) THEN - PROB = PROB*(NWIND - SUM)/NWIND - IF (PROB .LE. PLIM) GO TO 170 - ENDIF - J = J - 1 - 160 CONTINUE - 170 ILOW = J-NWIND - IF (ILOW .LE. 0) ILOW = 1 -C----------------------------------------------------------------------- -C Do the same for the high angle side -C----------------------------------------------------------------------- - J = J2 - LIM = J + 1 - IFLAG = 0 - PROB = 1 - DO 190 I = LIM,IDEL-NWIND - CNT = SMOOTH(J) - W = 0.08978*CNT - SUM = 0 - DO 180 KK = J+1,J+NWIND - DIFF = CNT - SMOOTH(KK) - DC = DIFF*DIFF - IF (DC .LT. W) SUM = SUM + 1 - 180 CONTINUE - IF (SUM .GE. NWIND/2) IFLAG = 1 - IF (IFLAG .NE. 0) THEN - PROB = PROB*(NWIND - SUM)/NWIND - IF (PROB .LE. PLIM) GO TO 200 - ENDIF - J = J + 1 - 190 CONTINUE - 200 IHIGH = J + NWIND - IF (IHIGH .GT. NP) IHIGH = NP -C----------------------------------------------------------------------- -C Now work out the net count & esd for profile between -C ILOW & IHIGH, using BGRD1 & BGRD2 plus pts between 1 to ILOW -C and IHIGH to NP for the background -C Revised EJG Aug 94 to allow for sloping backgrounds better -C----------------------------------------------------------------------- - 210 NPK = IHIGH - ILOW + 1 - B1 = BGRD1 - IF (ILOW .GT. 1) THEN - DO 220 I = 1,ILOW-1 - B1 = B1 + ACOUNT(I) - 220 CONTINUE - ENDIF - FRAC1 = (FRAC*NP + ILOW - 1)/NPK - PEAK = 0.0 - DO 225 I = ILOW,IHIGH - PEAK = PEAK + ACOUNT(I) - 225 CONTINUE - B2 = BGRD2 - IF (IHIGH .LT. NP) THEN - DO 230 I = IHIGH+1,NP - B2 = B2 + ACOUNT(I) - 230 CONTINUE - ENDIF - FRAC2 = (FRAC*NP + NP - IHIGH)/NPK - BTOT = 0.5*(B1/FRAC1 + B2/FRAC2) - TOP1 = PEAK - BTOT - BOT1 = SQRT(PEAK + 0.25*(B1/(FRAC1*FRAC1) + B2/(FRAC2*FRAC2))) - FRAC1 = 0.5*(FRAC1 + FRAC2) - BGRD1 = BTOT*FRAC1 - SUM = PEAK - BGRD2 = BGRD1 -C----------------------------------------------------------------------- -C Print Inet and sigma(Inet) for non-standards in GO mode -C----------------------------------------------------------------------- - IF (KI(1:1) .EQ. 'G' .AND. ISTAN .EQ. 0) THEN - ITOP = TOP1 + 0.5 - IBOT = BOT1 + 0.5 - IF (TOP .LE. SIGLIM*BOT) THEN - IF (ILPT .EQ. 0) WRITE (LPT,10000) IH,IK,IL,ITOP,IBOT,NREF - WRITE (COUT,10000) IH,IK,IL,ITOP,IBOT,NREF - ELSE - IF (NATT .NE. 0) THEN - IF (ILPT .EQ. 0) - $ WRITE (LPT,15100) IH,IK,IL,NATT,ITOP,IBOT,NREF - WRITE (COUT,15100) IH,IK,IL,NATT,ITOP,IBOT,NREF - ELSE - IF (ILPT .EQ. 0) - $ WRITE (LPT,15200) IH,IK,IL,ITOP,IBOT,NREF - WRITE (COUT,15200) IH,IK,IL,ITOP,IBOT,NREF - ENDIF - ENDIF - CALL GWRITE (ITP,' ') - ENDIF - 240 CALL RSW(9,JSW) -C------- always write profile at TRICS! -C IF (JSW .NE. 0 .and. istan .ne. 0) CALL PRFWRT (NP) - CALL PRFWRT (NP) -C----------------------------------------------------------------------- -C Prepare the profile for display on the c.r.t. if wanted -C Code below here is not needed for profile analysis -C The display is 10-bits * 10-bits -C If this reflection is to be plotted, the scaling is done in the -C display routine itself as the profile is developed. -C If the last reflection is to be plotted, the scaling is done here -C and an origin offset is added. Scaling is to a max of 1000 in each -C direction and the packing is -C 4096*scaled-counts + scaled-width + 4096*1024 -C The marks are shifted by 100 points. -C -C SR 0 = 0 for normal display; = 1 for profile display -C----------------------------------------------------------------------- - CALL RSW (1,I) - IF (I .NE. 0) THEN -C----------------------------------------------------------------------- -C SR 1 = 0 not this time; = 1 for last reflection -C----------------------------------------------------------------------- - N = NXPTS -C----------------------------------------------------------------------- -C SR 2 = 0 for raw counts; = 1 for smoothed counts -C----------------------------------------------------------------------- - CALL RSW (2,J) -C----------------------------------------------------------------------- -C Insert marks at ILOW,IHIGH and ALPHA1 obs and calc positions -C----------------------------------------------------------------------- - IHTAGS(1) = AS * CON - IHTAGS(2) = AS * CON - IF (IWARN .NE. 1) IHTAGS(1) = MAXI - A2*ID12 - IHTAGS(3) = ILOW - IHTAGS(4) = IHIGH - IF (J .NE. 0) THEN - CALL PTPREP (NP,SMOOTH,IHTAGS) - ELSE - CALL PTPREP (NP,ACOUNT,IHTAGS) - ENDIF - ENDIF - CALL RSW (3,J) - IF (J .EQ. 1) THEN -C----------------------------------------------------------------------- -C Dump the difference profile for Ladge -C----------------------------------------------------------------------- -C ic = 0 -C do 1000 i = 1,np -C j = acount(i) + 0.5 -C id(i) = j - ic -C ic = j -C 1000 continue -C WRITE (LPT,17100) (id(I),I=1,NP) -C17100 format (10(3x,z4)) - WRITE (LPT,17000) (acount(I),I=1,NP) - WRITE (LPT,17000) (SMOOTH(I),I=1,NP) - ENDIF - RETURN -10000 FORMAT (3I4,2X,I7,'(',I4,') ',I5,' **') -11000 FORMAT (/,' The Profile counts are:') -12000 FORMAT (1X,10F7.0) -14000 FORMAT (3I4,' Max Profile',I4,', Alpha',I5,3F7.0) -14100 FORMAT (3I4,' Max Profile',I4,', Alpha',I4,3F7.0,' Weak Peak') -15000 FORMAT (3I4,F5.0,F7.0,F5.0,3I4,5F7.0/1X,F5.0,F8.4,2F6.0) -15100 FORMAT (3I4,I2,I7,'(',I4,') ',I5) -15200 FORMAT (3I4,2X,I7,'(',I4,') ',I5) -17000 FORMAT (1X,10F7.0) - END -C----------------------------------------------------------------------- -C Write a profile on unit 7 (32 4-byte variables per record) :-- -C Each reflection is written as several records. -C Record 1: -C Bytes Symbol Contents -C 1 to 12 IH IK IL h, k, l 4 bytes each -C 13 to 16 NP2 number of pts in profile + 1000*std # -C 17 to 20 ILOW the point number on the low angle side -C 1 if no analysis -C 21 to 24 IHIGH the point number on the high angle side -C NP if no analysis -C 25 to 28 FRAC1 b/P time ratio (0.1 if no analysis) -C 29 to 32 IB1 Low angle background -C 31 to 36 ICOUNT Sum of all NP profile points -C 37 to 40 IB2 High angle background -C 41 to 28 44 profile points - 32000 (2 bytes each) -C -C Record 2 on: -C 1 to 128 64 profile points -C----------------------------------------------------------------------- - SUBROUTINE PRFWRT (NP) - INCLUDE 'COMDIF' - INTEGER*2 IPTS(500) - EQUIVALENCE (ACOUNT(501),IPTS(1)) - NP2 = NP2 + 1000*NN - IB1 = BGRD1 - ICOUNT = COUNT - IB2 = BGRD2 - NREC = (NP + 20 + 63)/64 - 1 - DO 100 I = 1,NP - IPTS(I) = ACOUNT(I) - 32000 - 100 CONTINUE - IPR = IOUNIT(7) - IDREC = 32*IBYLEN - STATUS = 'DO' - CALL IBMFIL (PRNAME, IPR,IDREC,STATUS,IERR) - NPR = NPR + 1 - WRITE (IPR,REC=NPR) IH,IK,IL,NP2,ILOW,IHIGH,FRAC1,IB1,ICOUNT,IB2, - $ (IPTS(J),J=1,44) - IF (NREC .NE. 0) THEN - J1 = 45 - DO 110 I = 1,NREC - J2 = J1 + 63 - NPR = NPR + 1 - WRITE (IPR,REC=NPR) (IPTS(J),J=J1,J2) - J1 = J2 + 1 - 110 CONTINUE - ENDIF - CALL IBMFIL (PRNAME,-IPR,IDREC,STATUS,IERR) - RETURN - END -C----------------------------------------------------------------------- -C Routine to write the binary stored profiles to an ASCII file -C The format of the ASCII file for each reflection is :-- -C Line 1 -C h,k,l, Npts, Ilow, Ihigh, Frac, Ib1, Icount, Ib2 -C ( 3I4, 3I5, F8.5, I6, I7, I6) -C NREC lines of IPTS (10I6) -C----------------------------------------------------------------------- - SUBROUTINE PROFAS - INCLUDE 'COMDIF' - DIMENSION JPTS(500) - INTEGER*2 IPTS(500) - CHARACTER ASPROF*40 - EQUIVALENCE (ACOUNT(501),IPTS(1)),(ACOUNT(1001),JPTS(1)) - IPR = IOUNIT(7) - IDREC = 32*IBYLEN - CALL IBMFIL (PRNAME, IPR,IDREC,'DO',IERR) - IAS = IOUNIT(8) - WRITE (COUT,10000) - ASPROF = 'DONT DO IT'//' ' - CALL ALFNUM (ASPROF) - IF (ASPROF .EQ. ' ') ASPROF = 'PROFL7.ASC' - CALL IBMFIL (ASPROF, IAS,IDREC,'SU',IERR) - NPR = 0 - 100 NPR = NPR + 1 - READ (IPR,REC=NPR,IOSTAT=I) - $ IH,IK,IL,NP2,ILOW,IHIGH,FRAC,IB1,ICOUNT,IB2,(IPTS(J),J=1,52) - IF (I .EQ. 0) THEN - NP = NP2 - 1000*(NP2/1000) - NREC = (NP + 20 + 63)/64 - 1 - IF (NREC .GT. 0) THEN - J1 = 45 - DO 110 I = 1,NREC - J2 = J1 + 63 - NPR = NPR + 1 - READ (IPR,REC=NPR) (IPTS(J),J=J1,J2) - J1 = J2 + 1 - 110 CONTINUE - ENDIF - DO 120 I = 1,NP - JPTS(I) = IPTS(I) + 32000 - 120 CONTINUE - WRITE (IAS,11000) IH,IK,IL,NP2,ILOW,IHIGH,FRAC,IB1,ICOUNT,IB2 - WRITE (IAS,12000) (JPTS(I),I=1,NP) - GO TO 100 - ENDIF - CALL IBMFIL (PRNAME,-IPR,IDREC,'DO',IERR) - CALL IBMFIL (ASPROF,-IAS,IDREC,'SU',IERR) - KI = ' ' - RETURN -10000 FORMAT (' Type the name of the ASCII file (PROFL7.ASC) ',$) -11000 FORMAT (3I4,3I5,F8.5,I6,I7,I6) -12000 FORMAT (10I6) - END diff --git a/difrac/prompt.f b/difrac/prompt.f deleted file mode 100644 index 3c67c6c8..00000000 --- a/difrac/prompt.f +++ /dev/null @@ -1,157 +0,0 @@ -C----------------------------------------------------------------------- -C Routines to perform consol I/O -C----------------------------------------------------------------------- - SUBROUTINE GWRITE (IDEV,DOLLAR) - CHARACTER DOLLAR*(*) - CHARACTER*132 COUT(20) - COMMON /IOUASC/ COUT - COMMON /IOUASS/ IOUNIT(10) - CHARACTER CR*1,LF*1,CRLF*2 - CR = CHAR(13) - LF = CHAR(10) - CRLF(1:1) = CR - CRLF(2:2) = LF - ITP = IOUNIT(6) -C----------------------------------------------------------------------- -C First find out how many lines to output -C----------------------------------------------------------------------- - DO 10 I = 20,1,-1 - IF (COUT(I) .NE. ' ') GO TO 20 -10 CONTINUE -C----------------------------------------------------------------------- -C Nothing to print -- assume that we must want to output a blank line -C----------------------------------------------------------------------- - I = 1 -20 NLINES = I -C----------------------------------------------------------------------- -C If the unit is not ITP then just do straight output to the device -C----------------------------------------------------------------------- - IF (IDEV .NE. ITP) THEN - IF (NLINES .GT. 1) THEN - DO 30 I = 1,NLINES-1 - WRITE (IDEV,10000) COUT(I)(1:LINELN(COUT(I))) -30 CONTINUE - ENDIF - IF (DOLLAR .EQ. '$') THEN - WRITE (IDEV,10100) COUT(NLINES)(1:LINELN(COUT(I))) - ELSE - WRITE (IDEV,10000) COUT(NLINES)(1:LINELN(COUT(I))) - ENDIF - ELSE - DO 40 I = 1,NLINES-1 - CALL WNTEXT (COUT(I)(1:LINELN(COUT(I)))) - CALL SCROLL -40 CONTINUE - IF (COUT(NLINES)(1:1) .NE. '%') - $ CALL WNTEXT (COUT(NLINES)(1:LINELN(COUT(NLINES)))) - IF (DOLLAR .EQ. '$') THEN - CALL WNTEXT (' ') - ELSE - CALL SCROLL - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Just in case we will blank out COUT -C----------------------------------------------------------------------- - DO 50 I = 1,20 - COUT(I) = ' ' -50 CONTINUE - RETURN -10000 FORMAT (A) -10100 FORMAT (A,' ',$) - END -C----------------------------------------------------------------------- -C Function to return the length of a character string -C----------------------------------------------------------------------- - INTEGER FUNCTION LINELN (STRING) - CHARACTER STRING*(*) - DO 10 I = LEN(STRING),1,-1 - IF (STRING(I:I) .NE. ' ') GO TO 20 -10 CONTINUE - I = 1 -20 LINELN = I - RETURN - END -C----------------------------------------------------------------------- -C GETLIN Read a line of input from the keyboard -C----------------------------------------------------------------------- - SUBROUTINE GETLIN (STRING) - CHARACTER STRING*(*) - INTEGER KEYGET -C----------------------------------------------------------------------- -C Do some housekeeping -C----------------------------------------------------------------------- - MAX = LEN(STRING) - STRING = ' ' - INDEX = 0 -C----------------------------------------------------------------------- -C Loop until we find either or control-C -C----------------------------------------------------------------------- -10 IC = KEYGET () -C----------------------------------------------------------------------- -C Control C -C----------------------------------------------------------------------- - IF (IC .EQ. 3) THEN - STOP -C----------------------------------------------------------------------- -C Return -- line complete -C----------------------------------------------------------------------- - ELSE IF (IC .EQ. 13) THEN - CALL SCROLL - RETURN -C----------------------------------------------------------------------- -C Backspace or Delete -C----------------------------------------------------------------------- - ELSE IF (IC .EQ. 8 .OR. IC .EQ. 16) THEN - IF (INDEX .GE. 1) THEN - CALL WNCDEL - STRING(INDEX:INDEX) = ' ' - INDEX = INDEX - 1 - ENDIF - GO TO 10 -C----------------------------------------------------------------------- -C Some other control character -C----------------------------------------------------------------------- - ELSE IF (IC .LE. 31) THEN - GO TO 10 -C----------------------------------------------------------------------- -C Something we want! -C----------------------------------------------------------------------- - ELSE - INDEX = INDEX + 1 - STRING(INDEX:INDEX) = CHAR(IC) - CALL WNTEXT (STRING(INDEX:INDEX)) - ENDIF -C----------------------------------------------------------------------- -C Handle the case of more input than string length by eating characters -C while waiting for . Backspace is handled correctly. -C----------------------------------------------------------------------- - IF (INDEX .GE. MAX) THEN -20 IC = KEYGET () - IF (IC .EQ. 8 .OR. IC .EQ. 16) THEN - CALL WNCDEL - STRING(INDEX:INDEX) = ' ' - INDEX = INDEX - 1 - GO TO 10 - ENDIF - IF (IC .NE. 13) GO TO 20 - CALL SCROLL - RETURN - ENDIF - GO TO 10 - END -C----------------------------------------------------------------------- -C Function KEYGET -- MS Fortran specific -C----------------------------------------------------------------------- -C INCLUDE 'FLIB.FI' -C FUNCTION KEYGET -C INCLUDE 'FLIB.FD' -C RECORD /REGS$INFO/ INREGS, OUTREGS -C INREGS.BREGS.AH = 8 -C CALL INTDOSQQ (INREGS,OUTREGS) -C KEYGET = OUTREGS.BREGS.AL -C RETURN -C END -C----------------------------------------------------------------------- -C Function KEYSIN -- MS Fortran specific -C----------------------------------------------------------------------- diff --git a/difrac/prtang.f b/difrac/prtang.f deleted file mode 100644 index 3aeb71e4..00000000 --- a/difrac/prtang.f +++ /dev/null @@ -1,12 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to print the current angle values -C----------------------------------------------------------------------- - SUBROUTINE PRTANG - INCLUDE 'COMDIF' - CALL ANGET (RTHETA,ROMEGA,RCHI,RPHI) - WRITE (COUT,10000) IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN -10000 FORMAT (' Current values are ',3I4,4F8.3) - END diff --git a/difrac/pscan.f b/difrac/pscan.f deleted file mode 100644 index fc514554..00000000 --- a/difrac/pscan.f +++ /dev/null @@ -1,86 +0,0 @@ -C----------------------------------------------------------------------- -C This subroutine scans Phi from 0 to 360 and extracts possible peaks -C----------------------------------------------------------------------- - SUBROUTINE PSCAN (NMAX,NTOT,SPRESET) - INCLUDE 'COMDIF' - DIMENSION PHIP(40),PCOUNT(40) - EQUIVALENCE (BCOUNT(1),PHIP(1)) - NMAX = 0 - KI = ' ' - N5= 5*NSIZE -C----------------------------------------------------------------------- -C Start Phi, high speed, + sense -C----------------------------------------------------------------------- - ACOUNT(N5) = 0 - CALL ANGET (RTHETA,ROMEGA,RCHI,RPHI) - CALL RPSCAN (NPTS,ICOL,SPRESET) - IF (ICOL .NE. 0) THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - IF (KI .EQ. 'RP') KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Look for peaks in the profile: if a given count is more than 4 sigmas -C above the average of the 3 counts before and the 3 counts after it, -C it is a probably a peak. This may be a little weak -- try 8 sigmas -C for now. -C----------------------------------------------------------------------- - I = NPTS - DO 110 J = 1,I - INDZ = MOD((J + I - 4),I) + 1 - SUM = 0 - DO 100 KA = 1,7 - IF (KA .NE. 4) SUM = SUM + ACOUNT(INDZ) - INDZ = INDZ + 1 - IF (INDZ .GT. I) INDZ = 1 - 100 CONTINUE - AVECT = SUM/6.0 - THRESH = AVECT + 4.0*SQRT(AVECT/6.0 + ACOUNT(J)) - IF (ACOUNT(J) .GT. THRESH) THEN - NMAX = NMAX + 1 - PHIP(NMAX) = ACOUNT(J+N5) - PCOUNT(NMAX) = ACOUNT(J) - ENDIF - 110 CONTINUE -C----------------------------------------------------------------------- -C Eliminate duplicate peaks -C----------------------------------------------------------------------- - IPFLAG = 0 - IF (NMAX .GT. 1) THEN - DO 120 I = 1,NMAX-1 - IF (ABS(PHIP(I) - PHIP(I+1)) .LT. 2.5) THEN - IPFLAG = 1 - IF (PCOUNT(I) .LT. PCOUNT(I+1)) THEN - PCOUNT(I) = - PCOUNT(I) - ELSE - PCOUNT(I+1) = - PCOUNT(I+1) - ENDIF - ENDIF - 120 CONTINUE - IF (IPFLAG .NE. 0) THEN - J = 0 - DO 130 I = 1,NMAX - IF (PCOUNT(I) .GT. 0) THEN - J = J + 1 - PCOUNT(J) = PCOUNT(I) - PHIP(J) = PHIP(I) - ENDIF - 130 CONTINUE - NMAX = J - ENDIF - ENDIF - IF (NMAX .GT. 0) THEN - NPEAK = NTOT - DO 140 I = 1,NMAX - NPEAK = NPEAK + 1 - WRITE (COUT,11000) NPEAK,RTHETA,ROMEGA,RCHI,PHIP(I),PCOUNT(I) - CALL GWRITE (ITP,' ') - WRITE (LPT,11000) NPEAK,RTHETA,ROMEGA,RCHI,PHIP(I),PCOUNT(I) - 140 CONTINUE - ENDIF - IF (KI .EQ. 'RP') KI = ' ' - RETURN -10000 FORMAT (1X,' Scan error in PSCAN') -11000 FORMAT (10X,I4,4F10.2,F10.0) - END diff --git a/difrac/qio.f b/difrac/qio.f deleted file mode 100644 index ac823968..00000000 --- a/difrac/qio.f +++ /dev/null @@ -1,204 +0,0 @@ - INTERFACE TO INTEGER*2 FUNCTION SIOBAUD [c,alias:'_SioBaud'] - $ (Port, BaudCode) - INTEGER*2 Port [value] - INTEGER*2 BaudCode [value] - END - - INTERFACE TO INTEGER*2 FUNCTION SIODONE [c,alias:'_SioDone'] - $ (Port) - INTEGER*2 Port [value] - END - - INTERFACE TO INTEGER*2 FUNCTION SIOERROR [c,alias:'_SioError'] - $ (Code) - INTEGER*2 Code [value] - END - - INTERFACE TO INTEGER*2 FUNCTION SIOGETC [c,alias:'_SioGetc'] - $ (Port, TimeOut) - INTEGER*2 Port [value] - INTEGER*2 TimeOut [value] - END - - INTERFACE TO INTEGER*2 FUNCTION SIOPARMS [c,alias:'_SioParms'] - $ (Port, Parity, StopBits, WordLength) - INTEGER*2 Port [value] - INTEGER*2 Parity [value] - INTEGER*2 StopBits [value] - INTEGER*2 WordLength [value] - END - - INTERFACE TO INTEGER*2 FUNCTION SIOPUTC [c,alias:'_SioPutc'] - $ (Port, Byte) - INTEGER*2 Port [value] - CHARACTER*1 Byte [value] - END - - INTERFACE TO INTEGER*2 FUNCTION SIORESET [c,alias:'_SioReset'] - $ (Port, BaudCode) - INTEGER*2 Port [value] - INTEGER*2 BaudCode [value] - END - - INTERFACE TO INTEGER*2 FUNCTION SIORXBUF [c,alias:'_SioRxBuf'] - $ (Port, Buffer, Size) - INTEGER*2 Port [value] - INTEGER*1 Buffer [reference] - INTEGER*2 Size [value] - END - - INTERFACE TO INTEGER*2 FUNCTION SIORXFLUSH - $ [c,alias:'_SioRxFlush'] (Port) - INTEGER*2 Port [value] - END - - INTERFACE TO INTEGER*2 FUNCTION SIORXQUE [c,alias:'_SioRxQue'] - $ (Port) - INTEGER*2 Port [value] - END -! -! -! Routines to simulate VAX QIOs -! - integer function io_init (cport, speed, width, parity, bits) - integer*2 SioRxBuf, SioReset, SioParms, SioError, SioRxFlush - character cport*(*), parity*(*) - integer speed, width, bits - integer*2 prty, dwidth, dbits, dspeed, rc - integer*1 RxBuffer(1024) - integer*2 Port - common /QioConst/ Port - common /QioBuf/ RxBuffer - - Port = 0 - if (cport(1:3) .eq. 'COM' .or. cport(1:3) .eq. 'com') then - if (len(cport) .ge. 4) then - if (cport(4:4) .eq. '2') Port = 1 - endif - endif - - prty = 0 - if (parity(1:1) .eq. 'o' .or. parity(1:1) .eq. 'O') prty = 1 - if (parity(1:1) .eq. 'e' .or. parity(1:1) .eq. 'E') prty = 3 - - dbits = 0 - if (bits .eq. 2) dbits = 1 - - dwidth = 3 - if (width .eq. 7) dwidth = 2 - - dspeed = 5 - if (speed .eq. 19200) dspeed = 6 - if (speed .eq. 4800) dspeed = 4 - if (speed .eq. 2400) dspeed = 3 - if (speed .eq. 1200) dspeed = 2 - if (speed .eq. 300) dspeed = 0 - - rc = SioRxBuf (Port, RxBuffer(1), 7) - if (rc .lt. 0) i = SioError (rc) - rc = SioParms (Port, prty, dbits, dwidth) - if (rc .lt. 0) i = SioError (rc) - rc = SioReset (Port, dspeed) - if (rc .lt. 0) i = SioError (rc) - rc = SioRxFlush (Port) - - io_init = 1 - return - end - - integer function io_done () - integer*2 SioDone, rc - integer*2 Port - common /QioConst/ Port - - rc = SioDone (Port) - - io_done = 1 - return - end - - - integer function io_read (iosb, in_buff, in_size, itime) - integer in_size, itime - integer*2 iosb(4) - integer*1 in_buff(*) - integer*2 SioGetc, j - integer*2 Port - common /QioConst/ Port - - M_time = itime * 18 - L_time = M_time/in_size - if (L_time .le. 0) L_time = 5 - J_time = 0 - - do 100 i = 1, in_size -110 j = SioGetc (Port, L_time) - if (j .eq. -1) then - J_time = J_time + L_time - if (J_Time .gt. M_time) go to 500 - go to 110 - endif - in_buff(i) = iand (j, #ff) -100 continue - iosb(1) = 1 - iosb(2) = in_size - io_read = 1 - return -500 continue - iosb(1) = 0 - iosb(2) = i - 1 - io_read = #22c - return - end - - - integer function io_prompt (iosb, in_buff, in_size, itime, - $ out_buf, out_size) - integer in_size, itime, out_size - integer*2 iosb(4) - integer*1 in_buff(*), out_buf(*) - integer*2 SioGetc, SioPutc, SioRxFlush, j - integer*2 Port - common /QioConst/ Port - - j = SioRxFlush (Port) - do 50 i = 1, out_size - jc = out_buf(i) - j = SioPutc (Port, char(jc)) -50 continue - - M_time = itime * 18 - L_time = M_time/in_size - if (L_time .le. 0) L_time = 5 - J_time = 0 - - do 100 i = 1, in_size -110 j = SioGetc (Port, L_time) - if (j .eq. -1) then - J_time = J_time + L_time - if (J_Time .gt. M_time) go to 500 - go to 110 - endif - in_buff(i) = iand (j, #ff) -100 continue - iosb(1) = 1 - iosb(2) = in_size - io_read = 1 - return -500 continue - iosb(1) = 0 - iosb(2) = i - 1 - io_prompt = #22c - return - end - - - - - - - - - - - \ No newline at end of file diff --git a/difrac/ralf.f b/difrac/ralf.f deleted file mode 100644 index f9a1cf44..00000000 --- a/difrac/ralf.f +++ /dev/null @@ -1,1121 +0,0 @@ -C----------------------------------------------------------------------- -C RALF Routines for the CAD4L with standard Enraf Nonius LSI/11 -C interface. -C -C Peter S. White February 1994 -C -C----------------------------------------------------------------------- - SUBROUTINE HKLN (I1, I2, I3, I4) - J1 = I1 - J2 = I2 - J3 = I3 - J4 = I4 - RETURN - END -C----------------------------------------------------------------------- -C INTON This routine must be called before any others and may be -C used to initialise the diffractometer -C----------------------------------------------------------------------- - SUBROUTINE INTON - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - PARAMETER (STDGR =(128.0 * 4096.0)/360.0) - LOGICAL FIRST - INCLUDE 'COMDIF' - INCLUDE 'CAD4COMM' - DATA FIRST/.TRUE./ - IF (FIRST) THEN - STEPDG = 91.0222 - IFRDEF = 100 - IDTDEF = 4 - IDODEF = 2 - NATTEN = 1 - NRC = 1 - DFTYPE = 'NONI' - CALL DIFGON -C----------------------------------------------------------------------- -C Set the CAD4 common block to starting values -C----------------------------------------------------------------------- - iroutf = 0 - incr1 = 0 - incr2 = 0 - npi1 = 0 - npi2 = 0 - iscanw = 0 - motw = 0 - ishutf = 0 - ibalf = 0 - iattf = 0 - iresf = 0 - ierrf = 0 - intfl = 0 - xrayt = 0.0 - do 100 i = 1,4 - want(i) = 0.0 - cmeas(i) = 0.0 -100 continue - thpos = 78.0 - thneg = -49.0 - tthp = aint(-2.0 * THPOS * STDGR) - tthn = aint( 2.0 * (THPOS - THNEG) * STDGR) - aptw = 0.0 - aptm = 0.0 - call cad4_get_instrument - call cad4_ini_terminal - io_cobnr = 0 - freq = 400 - ENDIF -C CALL ZERODF - RETURN - END -C----------------------------------------------------------------------- -C INTOFF -- clean up the interface -C----------------------------------------------------------------------- - SUBROUTINE INTOFF - irc = io_done() - return - end -C----------------------------------------------------------------------- -C ZERODF In case of an error this routine returns the diffractometer -C to a known state -C----------------------------------------------------------------------- - SUBROUTINE ZERODF - INCLUDE 'CAD4COMM' - ishutf = 0 - iattf = 0 - do 100 i = 1,4 -100 want(i) = 0.0 - iroutf = 5 - call lsi (1) - RETURN - END -C----------------------------------------------------------------------- -C CTIME Count for a fixed time -C----------------------------------------------------------------------- - SUBROUTINE CTIME (XTIME, XCOUNT) - INCLUDE 'COMDIF' - include 'cad4comm' - call setslt (icadsl,icol) - iroutf = 6 - ibalf = 0 - ishutf = 1 - incr1 = 0 - incr2 = 2 - npi1 = int(xtime * freq) - npi2 = 0 - motw = 0 - iscanw = 1 - call lsi (1) - xcount = 0 - do 100 i = 1,ndumps - xcount = xcount + dump(i) -100 continue - RETURN - END -C----------------------------------------------------------------------- -C ANGET Read the angles -C----------------------------------------------------------------------- - SUBROUTINE ANGET (WTWOTH, WOMEGA, WCHI, WPHI) - include 'COMDIF' - include 'cad4comm' - iroutf = 1 - call lsi (1) - call mtokap (cmeas(for_th),wtwoth) - call mtokap (cmeas(for_om),wkom) - call mtokap (cmeas(for_ka),wkappa) - call mtokap (cmeas(for_ph),wkphi) - call eulkap (1,womega,wchi,wphi,wkom,wkappa,wkphi,istatus) - womega = womega - wtwoth - wtwoth = 2 * wtwoth - wtwoth = wtwoth - dtheta - womega = womega - domega - wchi = wchi - dchi - if (wtwoth .lt. 0.0) wtwoth = wtwoth + 360.00 - if (womega .lt. 0.0) womega = womega + 360.00 - if (wchi .lt. 0.0) wchi = wchi + 360.00 - if (wphi .lt. 0.0) wphi = wphi + 360.00 - RETURN - END -C----------------------------------------------------------------------- -C ANGSET Set the angles -C----------------------------------------------------------------------- - SUBROUTINE ANGSET (WTHETA, WOMEGA, WCHI, WPHI, NATTW, ICOL) - include 'COMDIF' - include 'cad4comm' - ishutf = 0 - if (nattw .gt. 0) then - iattf = 1 - else - iattf = 0 - endif - atheta = wtheta + dtheta - aomega = womega + domega - achi = wchi + dchi - if (atheta .gt. 180.00) atheta = atheta - 360.00 - if (aomega .gt. 180.00) aomega = aomega - 360.00 - atheta = atheta/2.0 - aomega = aomega + atheta - call eulkap (0,aomega,achi,wphi,wkom,wkappa,wkphi,istatus) - if (istatus .ne. 0) then - icol = istatus - return - endif - call kaptom (atheta, want(for_th)) - call kaptom (wkom, want(for_om)) - call kaptom (wkappa, want(for_ka)) - call kaptom (wkphi, want(for_ph)) - iroutf = 5 - call lsi (1) - icol = 0 - call displa (wtheta,womega,wchi,wphi) - RETURN - END -C----------------------------------------------------------------------- -C Convert encoders to degrees -C----------------------------------------------------------------------- - SUBROUTINE MTOKAP (ENCODR, ANGLE) - PARAMETER (DGRST = 360.0/(128.0 * 4096.0)) - ANGLE = DGRST * ENCODR - if (angle .gt. 180.0) angle = angle - 360.0 - RETURN - END -C----------------------------------------------------------------------- -C Convert degrees to encoder steps--check the range -C----------------------------------------------------------------------- - SUBROUTINE KAPTOM (ANGLE,ENCODR) - PARAMETER (STDGR = (128.0 * 4096.0)/360.0) - TANGLE = ANGLE - IF (TANGLE .GT. 180.0) TANGLE = TANGLE - 360.0 - ENCODR = AINT (TANGLE * STDGR) - RETURN - END -C----------------------------------------------------------------------- -C SHUTR Open or close the shutter -C IOC = 1 open, 2 close -C INF = 0 OK -C----------------------------------------------------------------------- - SUBROUTINE SHUTR (IOC, INF) - INCLUDE 'CAD4COMM' - INF = 0 - IF (IOC .EQ. 1) THEN - ISHUTF = 1 - ELSE - ISHUTF = 0 - ENDIF - IROUTF = 0 - CALL LSI (1) - IF (IERRF .NE. 0) INF = 1 - RETURN - END - - SUBROUTINE ONEBEP(R1,R2) - CHARACTER CTRLG*1 - A1 = R1 - A2 = R2 - CTRLG = CHAR(7) -C WRITE (6,10000) CTRLG -10000 FORMAT (1H+,A,$) - RETURN - END - -C----------------------------------------------------------------------- -C KORQ -- Read the keyboard buffer -C If it contains K|k|Q|q return: 0 = K -C 1 = nothing found -C 2 = Q -C -C KORQ will toggle the switch registers 1-9,0 if the numeric -C keys are found in the buffer. -C----------------------------------------------------------------------- - SUBROUTINE KORQ (I1) - INCLUDE 'COMDIF' - CHARACTER STRING*80 - LOGICAL SWFND,SAVED,SWCALL - DATA SAVED/.FALSE./ - SWFND = .FALSE. -C----------------------------------------------------------------------- -C First check if we are making a regular call after a K or Q has been -C found from a call from RSW. -C----------------------------------------------------------------------- - IF (SAVED .AND. I1 .NE. -9999) THEN - SAVED = .FALSE. - I1 = ISAVED - RETURN - ENDIF - SWCALL = .FALSE. - IF (I1 .EQ. -9999) SWCALL = .TRUE. - ANS = ' ' -C----------------------------------------------------------------------- -C For now dummy out the call to keysin and return 0 characters -C----------------------------------------------------------------------- - NCHARS = 0 - NCHARS = KEYSIN (STRING) - I1 = 1 - DO 10 I = 1,NCHARS - IASCII = ICHAR (STRING(I:I)) - IF (IASCII .EQ. 3) STOP - IF (IASCII .EQ. 75 .OR. IASCII .EQ. 107) ANS = 'K' - IF (IASCII .EQ. 81 .OR. IASCII .EQ. 113) ANS = 'Q' - IF (ANS .EQ. 'K' .OR. ANS .EQ. 'k') I1 = 0 - IF (ANS .EQ. 'Q' .OR. ANS .EQ. 'q') I1 = 2 - IF (IASCII .GE. 48 .AND. IASCII .LE. 57) THEN - SWFND = .TRUE. - ISWTCH = IASCII - 48 + 1 - IF (ISREG(ISWTCH) .EQ. 0) THEN - ISREG(ISWTCH) = 1 - ELSE - ISREG(ISWTCH) = 0 - ENDIF - ENDIF -10 CONTINUE - IF (SWCALL .AND. I1 .NE. 1) THEN - ISAVED = I1 - SAVED = .TRUE. - ENDIF -C IF (SWFND) THEN -C WRITE (WIN1BF(13),10000) (ISREG(I),I=1,10) -C ENDIF -10000 FORMAT (10X,10I2) - RETURN - END -C----------------------------------------------------------------------- -C RSW Read the switch register -C----------------------------------------------------------------------- - SUBROUTINE RSW (N,IVALUE) - INCLUDE 'COMDIF' -C----------------------------------------------------------------------- -C Update the switches just in case. II = -9999 is a flag to tell -C KORQ to protect any K or Q characters. -C----------------------------------------------------------------------- - II = -9999 - CALL KORQ (II) -C----------------------------------------------------------------------- -C And get the current value. -C----------------------------------------------------------------------- - IF (N .LT. 0 .OR. N .GT. 9) RETURN - IVALUE = ISREG(N+1) - RETURN - END -C----------------------------------------------------------------------- -C Initialise the Program -C----------------------------------------------------------------------- - SUBROUTINE INITL(R1,R2,R3,R4) - A1 = R1 - A2 = R2 - A3 = R3 - A4 = R4 - RETURN - END -C-------------------------------------------------------------------- -C Routine to perform scans. -C ITYPE Scan type -- 0 or 2 Omega/2-theta -C 1 or 3 Omega -C SCNANG Angle to scan in degrees. This should be the -C 2theta range for an omega-2theta scan and the -C omega range for an omega scan. -C ACOUNT Returns total intensity in ACOUNT(1) and profile -C in ACOUNT(2)-ACOUNT(NPPTS+1) -C TIME Total scan time in secs -C SPEED Scan speed in degs/min. -C NPPTS Number of points in the profile on output -C IERR Error code 0 -- O.K. -C 1 -- Collision -C 2 or more really bad! -C-------------------------------------------------------------------- - SUBROUTINE TSCAN (ITYPE,SCNANG,ACOUNT,TIME,SPEED,NPPTS,IERR) - COMMON /DFMACH/ ISCDEF,ICDDEF,IDTDEF,IDODEF,IDCDEF,IFRDEF,NRC, - $ NATTEN,STEPDG,ICADSL,ICADSW - DIMENSION ACOUNT(*) - include 'cad4comm' -C-------------------------------------------------------------------- -C Version 0.50 Supports itype = 0 or 2 omega-2theta and -C 1 or 3 omega -C in both cases IANGLE is omega at the end of the scan -C -C-------------------------------------------------------------------- - IERR = 0 -C-------------------------------------------------------------------- -C The diffractometer should have been positioned at the beginning -C position for the scan. -C -C Omega/2-Theta scan -C Speed is passed in terms of 2-theta but E-N needs omega speed -C 1 encoder step = 360/(128 * 4096) = 0.00068664 deg -C 16 steps = 0.01098 deg (equals 8 omega steps) -C-------------------------------------------------------------------- - CALL SETSLT (ICADSL,ICOL) - isense = 1 - if (scnang .lt. 0.0) then - isense = -1 - scnang = - scnang - endif - IF (ITYPE .EQ. 0 .OR. ITYPE .EQ. 1) THEN - MODE = 0 - if (speed .le. 16.48) then - npi = nint(0.5 + 16.48*2/speed) - incr1 = isense - else - npi = 1 - incr1 = isense*nint(0.5 + speed/(2*16.48)) - endif - npi2 = 6 - scang = scnang/2.0 - iscanw = 8 -C-------------------------------------------------------------------- -C Omega scan -C-------------------------------------------------------------------- - ELSE IF (ITYPE .EQ. 2 .OR. ITYPE .EQ. 3) THEN - MODE = 2 - if (speed .le. 16.48) then - npi = nint(0.5 + 16.48/speed) - incr1 = isense - else - npi = 1 - incr1 = isense*nint(0.5 + speed/(16.48)) - endif - npi2 = 0 - scang = scnang - iscanw = 16 - ELSE - IERR = 2 - RETURN - ENDIF -C-------------------------------------------------------------------- -C Setup complete -- do the scan -C-------------------------------------------------------------------- - call mtokap (float(iscanw), stpsiz) - nppts = int (scang/stpsiz) - call kaptom (float(ndumps * iscanw), scang) - incr2 = incr1 - npi1 = npi - iresf = 0 -C-------------------------------------------------------------------- -C Set MOTW = 3 + 5*64 Omega master, theta slave -C-------------------------------------------------------------------- - IBALF = 0 - MOTW = 323 - time = xrayt - iroutf = 6 - call lsi (nppts) - acount(1) = 0.0 - do 200 i = 1,nppts - acount(i+1) = dump(i) - acount(1) = acount(1) + dump(i) -200 continue - time = (xrayt - time) / freq - return - end - -C-------------------------------------------------------------------- -C Routine to display a peak profile in the current graphics window. -C The arguments are: -C -C NHIST The number of points to be plotted -C HIST An array of points -C IHTAGS(4) The calculated peak position, the experimental position, -C low background limit and high background limit. -C-------------------------------------------------------------------- - SUBROUTINE PTPREP (NHIST,HIST,IHTAGS) - INCLUDE 'COMDIF' - INTEGER IHTAGS(4) - REAL HIST(*) - INTEGER IX,IY,IZ - CHARACTER STRING*80 - DATA IX,IY,IZ/0,0,0/ - CALL PCDRAW (XCLEAR,IX,IY,IZ,STRING) - MAX = 1 - MIN = 999999 - IF (NHIST .LE. 1) THEN - WRITE (LPT,10000) NHIST -10000 FORMAT (1X,' Invalid value for NHIST: ',I10) - RETURN - ENDIF - DO 10 I = 1,NHIST - IF (HIST(I) .GT. MAX) MAX = HIST(I) - IF (HIST(I) .LT. MIN) MIN = HIST(I) -10 CONTINUE - XSCALE = 4096.0/NHIST - DO 20 I = 1,NHIST - IY = HIST(I) - IY = IY*3072.0/MAX - IX = I * XSCALE - IF (IY .LT. 0 .OR. IY .GT. 3072 .OR. - $ IX .LT. 1 .OR. IX .GT. 4096) THEN - WRITE (LPT,10100) IX,IY -10100 FORMAT (1X,'Error plotting point ',I10,',',I10) - RETURN - ENDIF - CALL PCDRAW (XMOVE, IX,IY,IZ,STRING) - CALL PCDRAW (XDRAW, IX,IY,IZ,STRING) -20 CONTINUE -C------------------------------------------------------------------- -C Now put in the indicators. -C------------------------------------------------------------------- - DO 30 I = 1,4 - IHTAGS(I) = IHTAGS(I) * XSCALE -30 CONTINUE - IF (IHTAGS(1) .GT. 0) THEN - CALL PCDRAW (XMOVE, IHTAGS(1),100,IZ,STRING) - CALL PCDRAW (XDRAW, IHTAGS(1),300,IZ,STRING) - ENDIF - IF (IHTAGS(2) .GT. 0) THEN - CALL PCDRAW (XMOVE, IHTAGS(2),400,IZ,STRING) - CALL PCDRAW (XDRAW, IHTAGS(2),600,IZ,STRING) - ENDIF - IF (IHTAGS(3) .GT. 0) THEN - CALL PCDRAW (XMOVE, IHTAGS(3),100,IZ,STRING) - CALL PCDRAW (XDRAW, IHTAGS(3),300,IZ,STRING) - ENDIF - IF (IHTAGS(4) .GT. 0) THEN - CALL PCDRAW (XMOVE, IHTAGS(4),100,IZ,STRING) - CALL PCDRAW (XDRAW, IHTAGS(4),300,IZ,STRING) - ENDIF - RETURN - END -C------------------------------------------------------------------- -C RPSCAN Ralf support for PSCAN routine -C------------------------------------------------------------------- - SUBROUTINE RPSCAN (NPTS,ICOL) - INCLUDE 'COMDIF' - INCLUDE 'CAD4COMM' - ICOL = 0 - NATTN = 0 - CALL SETSLT (0,ICOL) -C------------------------------------------------------------------- -C Get the current angles and decide which direction to scan -C------------------------------------------------------------------- - CALL ANGET (WTH,WOM,WCHI,WPHI) - IF (WPHI .GT. 180.0) WPHI = WPHI - 360.00 - IF (WPHI .LE. 0) THEN - WPHI = -90.00 - TARGET = 90.00 - IDIR = 1 - ELSE - WPHI = 90.00 - TARGET = -90.00 - IDIR = -1 - ENDIF -C------------------------------------------------------------------- -C Move PHI to the correct starting position -C------------------------------------------------------------------- - CALL ANGSET (WTH,WOM,WCHI,WPHI,NATTN,ICOL) -C------------------------------------------------------------------- -C Now do the scan -C------------------------------------------------------------------- - INCR1 = 10 * IDIR - INCR2 = 0 - IRESF = 0 - NPI1 = 1 - MOTW = 2 - STEPW = 2.0 - CALL KAPTOM (STEPW,ENCST) - ISCANW = INT(ENCST + 0.5)/IABS(INCR1) - NPTS = 90 - IROUTF = 6 - CALL LSI (NPTS) - PHIST = WPHI - STEPW/2.0 - IF (IDIR .LT. 1) PHIST = -WPHI - STEPW/2.0 -C----------------------------------------------------------------------- -C Nonius (in their wisdom) always return the profile in ascending -C phi. -C----------------------------------------------------------------------- - DO 100 I = 1,NPTS - ACOUNT(I) = DUMP(I) - ACOUNT(5*NSIZE + I) = PHIST + I*STEPW -100 CONTINUE - RETURN - END -C------------------------------------------------------------------------- - SUBROUTINE MAXPOINT (IAXIS,WIDTH,STEPS,ANGLE) - RETURN - END -C----------------------------------------------------------------------- -C GENSCN Routine to perform a scan of a given motor -C ICIRCL 1 -- 2-theta ISLIT 0 -- Nothing -C 2 -- omega 1 -- Vertical -C 3 -- kappa 2 -- Horizontal -C 4 -- phi 3 -- +45 deg -C 4 -- -45 deg -C 5 -- Upper 1/2 circle -C 6 -- Lower 1/2 circle -C 10 to 59 -- horiz. aperture in mms -C SPEED Speed in degrees per minute -C STEP Step width in degrees, NPTS number of steps -C ICOL 0 -- OK -C----------------------------------------------------------------------- - SUBROUTINE GENSCN (ICIRCL, WSPEED, WSTEP, NPTS, ISLIT, ICOL) - include 'COMDIF' - include 'cad4comm' - icol = 0 - call setslt (islit,icol) -C----------------------------------------------------------------------- -C Get current positions -C----------------------------------------------------------------------- - ishutf = 0 - iroutf = 1 - call lsi (1) - call mtokap (cmeas(for_th),wtwoth) - call mtokap (cmeas(for_om),wkom) - call mtokap (cmeas(for_ka),wkappa) - call mtokap (cmeas(for_ph),wkphi) -C----------------------------------------------------------------------- -C Offset required angle -C----------------------------------------------------------------------- - imult = 1 - tstep = wstep - if (icircl .eq. 1) then - tstep = wstep/2.0 - wtwoth = wtwoth - tstep*npts/2 - tstep/2 - else if (icircl .eq. 2) then - wkom = wkom - tstep*npts/2 - tstep/2 - else if (icircl .eq. 3) then - wkappa = wkappa - tstep*npts/2 - tstep/2 - else if (icircl .eq. 4) then - wkphi = wkphi - tstep*npts/2 - tstep/2 - else if (icircl .eq. 5) then - tstep = wstep/2.0 - wtwoth = wtwoth - tstep*npts/2 - tstep/2 - wkom = wkom - tstep*npts/2 - tstep/2 - imult = 2 - endif - call kaptom (wtwoth, want(for_th)) - call kaptom (wkom, want(for_om)) - call kaptom (wkappa, want(for_ka)) - call kaptom (wkphi, want(for_ph)) - ishutf = 0 - iroutf = 5 - call lsi (1) -C----------------------------------------------------------------------- -C Now we are at the begining of the scan -C----------------------------------------------------------------------- - isense = 1 - if (tstep .lt. 0.0) isense = -1 - nattn = 0 - incr2 = 0 - iresf = 0 - npi2 = 0 - if (wspeed .le. 16.48) then - incr1 = isense - npi1 = int((imult*16.48)/wspeed + 0.5) - else - npi1 = 1 - incr1 = isense*int(wspeed/(imult*16.48) + 0.5) - endif - stepw = abs(tstep) - if (icircl .eq. 1) then - motw = 5 - else if (icircl .eq. 2) then - motw = 3 - else if (icircl .eq. 3) then - motw = 4 - else if (icircl .eq. 4) then - motw = 2 - else if (icircl .eq. 5) then - motw = 323 - incr2 = incr1 - npi2 = 6 - else - icol = -1 - return - endif - call kaptom (stepw,encst) - iscanw = int(encst + 0.5)/iabs(incr1) - npoints = npts - ishutf = 1 - iroutf = 6 - call lsi (npoints) - i1 = 9*NSIZE + 1 - i2 = 9*NSIZE + npoints - j = 0 - do 100 i = i1,i2 - j = j + 1 - acount(i) = dump(j) -100 continue - return - end -C----------------------------------------------------------------------- -C SETSLT -- Set the slits -C----------------------------------------------------------------------- - subroutine setslt (islt,icol) - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - include 'cad4comm' - icol = 0 - ishutf = 0 - if (islit .lt. 0) then - icol = -1 - return - endif - aptwsv = aptw - if (islt .eq. 0) aptw = IHOLE - if (islt .eq. 1) aptw = IVSLIT - if (islt .eq. 2) aptw = IHSLIT - if (islt .eq. 3) aptw = INEG45 - if (islt .eq. 4) aptw = IPOS45 - if (islt .eq. 5) aptw = IUPHAF - if (islt .eq. 6) aptw = ILOHAF - if (islt .ge. 10) then - slsize = float(islt)/10.0 - if (slsize .lt. APMIN) slsize = APMIN - if (slsize .gt. APMAX) slsize = APMAX - aptw = (MAXVAR - MINVAR) * (slsize - APMIN)/(APMAX - APMIN) - aptw = aptw + MINVAR - endif - if (abs(aptm - aptw) .lt.1.5) return - if (aptw .ne. aptwsv) then - iroutf = 13 - call lsi (0) - endif - return - end -C----------------------------------------------------------------------- -C LSI Cad specific routine to initiate transfer to the interface -C If doing multple transfers use xrayt from the first one to -C improve accuracy of the scan time estimate. -C----------------------------------------------------------------------- - subroutine lsi (length) - include 'cad4comm' - nreturn = length - if (nreturn .lt. 1) nreturn = 1 - call disap (4,nreturn) - if (nreturn .gt. 96) then - xrayts = xrayt - lcount = 0 - ltemp = nreturn -100 ltemp = ltemp - 96 - lcount = lcount + 1 - iroutf = 4096 + lcount*4*96 - call disap (4,ltemp) - if (ltemp .gt. 96) go to 100 - xrayt = xrayts - endif - return - end -C----------------------------------------------------------------------- -C For now we only need support the old DISAP type 4 -C----------------------------------------------------------------------- - subroutine disap (mode, length) - external cad4_transm_gonio, cad4_recv_gonio, cad4_type_error, - $ cad4_start_load - include 'CAD4COMM' - if (mode .eq. 4) then - ndumps = length - call cad4_io (f_tr_gon, cad4_transm_gonio, cad4_recv_gonio, - $ cad4_type_error, cad4_type_error, cad4_type_error, - $ cad4_type_error, cad4_type_error, cad4_start_load, - $ cad4_type_error) - endif - return - end -C----------------------------------------------------------------------- -C Cad4_start_load: The interface needs to be reloaded so quit! -C----------------------------------------------------------------------- - subroutine cad4_start_load (result) - include 'CAD4COMM' - call cad4_reset_terminal - stop - end -C----------------------------------------------------------------------- -C Cad4_set_swreg: Copy switch register to buffer -C----------------------------------------------------------------------- - subroutine cad4_set_swreg - include 'CAD4COMM' - output_data_w(1) = io_coswr - output_length = 2 - return - end -C----------------------------------------------------------------------- -C Cad4_get_swreg: Copy pocket terminal switch register to host -C----------------------------------------------------------------------- - subroutine cad4_get_swreg - include 'CAD4COMM' - nswreg = input_data_w(1) - return - end -C----------------------------------------------------------------------- -C Cad4_recv_gonio: Copy results returned from the LSI -C----------------------------------------------------------------------- - subroutine cad4_recv_gonio (result) - integer*2 i, nrd - include 'CAD4COMM' -C----------------------------------------------------------------------- -C Get the interface switch register -C----------------------------------------------------------------------- - nswreg = input_data_w(c4h_swreg) -C----------------------------------------------------------------------- -C Convert input error bits to an error number -C----------------------------------------------------------------------- - call bitcon (c4h_errfl, errtbl, ierrf) -C----------------------------------------------------------------------- -C Convert accumulated exposure time to a real -C----------------------------------------------------------------------- - call input_double (c4h_xrtim, xrayt) -C----------------------------------------------------------------------- -C Convert encoder readings -C----------------------------------------------------------------------- - call input_double (c4h_thmh, cmeas(for_th)) - call input_double (c4h_phmh, cmeas(for_ph)) - call input_double (c4h_ommh, cmeas(for_om)) - call input_double (c4h_kamh, cmeas(for_ka)) - call input_double (c4h_apmh, aptm) -C----------------------------------------------------------------------- -C And finally any profile points -C----------------------------------------------------------------------- - nd = 1 - nend = ndumps - if (iroutf .gt. 4096) then - nd = (iroutf - 4096)/4 + 1 - endif - if (nend .gt. 96) nend = 96 - do 100 i = 1,nend - nrd = (i - 1)*2 + c4h_dump0 - call input_double (nrd, dump(nd)) - nd = nd + 1 -100 continue - return - end -C----------------------------------------------------------------------- -C Input_double: convert LSI double integers to floating point -C----------------------------------------------------------------------- - subroutine input_double (c4h_label, f_value) - integer*2 c4h_label - real f_value -C----------------------------------------------------------------------- -C Equivalence integer with pairs of short integers -C----------------------------------------------------------------------- - integer*4 long - integer*2 short(2) - equivalence (long, short(1)) - include 'CAD4COMM' - short(2) = input_data_w(c4h_label) - short(1) = input_data_w(c4h_label + 1) - f_value = float (long) - return - end -C----------------------------------------------------------------------- -C Bitcon: Convert most significant bit set to a number -C----------------------------------------------------------------------- - subroutine bitcon (c4h_label, tabel, iresult) - integer*2 c4h_label, tabel(15), iresult - integer*2 itcnt, itval, inval - include 'CAD4COMM' - iresult = 0 - inval = input_data_w(c4h_label) - if (inval .gt. 0) then - itcnt = 15 - itval = #4000 -100 continue - if (tabel(itcnt) .ne. 0) then - if (iand(inval, itval) .ne. 0) iresult = tabel(itcnt) - endif - itval = itval/2 - itcnt = itcnt - 1 - if (itval .ne. 0 .and. iresult .ne. 0) go to 100 - endif - return - end -C----------------------------------------------------------------------- -C Cad4_transm_gonio: Setup buffer for transmission to LSI -C----------------------------------------------------------------------- - subroutine cad4_transm_gonio - integer*2 nsa, nba, nmast, nslav, mselw - include 'CAD4COMM' -C----------------------------------------------------------------------- -C Outtput switch register -C----------------------------------------------------------------------- - output_data_w(c4h_swreg) = io_coswr -C----------------------------------------------------------------------- -C Route flag -C----------------------------------------------------------------------- - if (iroutf .lt. 4096) then - output_data_w(c4h_routfl) = routbl (iand(iroutf, #0f) + 1) - else - output_data_w(c4h_routfl) = iroutf - endif -C----------------------------------------------------------------------- -C Two theta limit values -C----------------------------------------------------------------------- - call output_double ((tthp*16.0), c4h_tthmxh) - call output_double ((tthn*16.0), c4h_tthmnh) -C----------------------------------------------------------------------- -C Shutter and attenuator go in one word -C----------------------------------------------------------------------- - nsa = ishutf * 2 - nsa = ior(nsa, iattf) - nsa = iand (nsa, #03) - nsa = satbl (nsa + 1) -C----------------------------------------------------------------------- -C Set function comes from IBALF -C----------------------------------------------------------------------- - nba = iand (ibalf, #03) - if (nba .eq. 3) then - nba = (ibalf - nba)/4 - nba = iand (nba, (not (satbl(3)))) - nsa = nsa + nba - endif - output_data_w(c4h_sasysc) = nsa -C----------------------------------------------------------------------- -C Output cumulative exposure time -C----------------------------------------------------------------------- - call output_double (xrayt, c4h_xrtim) -C----------------------------------------------------------------------- -C Motor selection word -C----------------------------------------------------------------------- - nmast = iand (motw, #07) + 1 - nslav = iand (motw, #01C0)/#0040 + 1 - output_data_w(c4h_mselw) = mottbl(nmast) + mottbl(nslav)*#0008 -C----------------------------------------------------------------------- -C Number of dumps required -C----------------------------------------------------------------------- - if (incr1 .lt. 0) then - output_data_w(c4h_nrd) = -ndumps - else - output_data_w(c4h_nrd) = ndumps - endif -C----------------------------------------------------------------------- -C Calculate master and slave increment words -C----------------------------------------------------------------------- - mselw = nmast - 1 - call setinc (mselw) - mselw = 1 - nslav - call setinc (mselw) -C----------------------------------------------------------------------- -C Wanted goniometer and aperature settings -C----------------------------------------------------------------------- - call output_double (want(for_th), c4h_thwh) - call output_double (want(for_ph), c4h_phwh) - call output_double (want(for_om), c4h_omwh) - call output_double (want(for_ka), c4h_kawh) - call output_double (aptw, c4h_apwh) -C----------------------------------------------------------------------- -C Set output buffer length -C----------------------------------------------------------------------- - output_length = c4h_apwl * 2 - return - end -C----------------------------------------------------------------------- -C Output_double: convert real to double integer -C----------------------------------------------------------------------- - subroutine output_double (f_value, c4h_label) - real f_value - integer*2 c4h_label - integer*4 long - integer*2 short(2) - equivalence (long, short(1)) - include 'CAD4COMM' - long = int(f_value) - output_data_w(c4h_label) = short(2) - output_data_w(c4h_label + 1) = short(1) - return - end -C----------------------------------------------------------------------- -C Setinc: routine to output increment values for master axis if the -C selection word is positive ot the slave axis if negative -C----------------------------------------------------------------------- - subroutine setinc (aselw) - integer*2 aselw, iabaw, aoffs, nid, inci, dincr, nrinc - include 'CAD4COMM' -C----------------------------------------------------------------------- -C calculate increment values -C----------------------------------------------------------------------- - call increm (aselw, nid, inci, dincr, nrinc) -C----------------------------------------------------------------------- -C and copy them to the output buffer -C----------------------------------------------------------------------- - output_data_w (c4h_nid) = nid - iabaw = iabs (aselw) + 1 - aoffs = mottbl(iabaw)*3 + c4h_incr - if (mottbl(iabaw) .ne. 0) then - output_data_w (c4h_inci + aoffs) = inci - output_data_w (c4h_dincr + aoffs) = dincr - output_data_w (c4h_nrinc + aoffs) = nrinc - endif - return - end -C----------------------------------------------------------------------- -C Increm: calculate increment values -C----------------------------------------------------------------------- - subroutine increm (aselw, nid, inci, dincr, nrinc) - integer*2 aselw, nid, inci, dincr, nrinc - real fincr - include 'CAD4COMM' - ifact = 4 - if (iroutf .ge. 9 .and. iroutf .le. 11) ifact = 2 - nid = iscanw * npi1 - if (aselw .ne. 0) then - if (npi1 .ne. 0) then - if (aselw .le. 0) then - fincr = float(incr1 * npi2 * ifact)/float(npi1 * 6) - else - fincr = float(incr1 * ifact)/float(npi1) - endif - else - fincr = 0.0 - endif - if (abs(fincr) .gt. (1.0/32768.0)) then - nrinc = int(1.0/abs(fincr)) - if (nrinc .lt. 1) nrinc = 1 - else - nrinc = 32767 - endif - inci = int(fincr * float(nrinc)) - if ((fincr * float(nrinc) - float(inci)) .lt. 0.0) - $ inci = inci - 1 - dincr = int((fincr * float(nrinc) - float(inci)) * 32768.0) - endif - return - end -C----------------------------------------------------------------------- -C Set the microscope viewing position (CAD-4 version) -C----------------------------------------------------------------------- - SUBROUTINE VUPOS (VTH,VOM,VCH,VPH) - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - VTH = VUTHT - VOM = VUOME - VCH = VUCHI - VPH = VUPHI - RETURN - END -C----------------------------------------------------------------------- -C Read the CAD-4 Goniometer constants file (goniom.ini) for the -C constants needed by DIFRAC in /CADCON/ -C----------------------------------------------------------------------- - SUBROUTINE DIFGON - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - CHARACTER DFTYPE*4,DFMODL*4 - COMMON /DFMACC/ DFTYPE,DFMODL - COMMON /INFREE/ IFREE(20),RFREE(20),ICFLAG - CHARACTER COUT(20)*132,OCHAR*100,CKEY*6 - COMMON /IOUASC/ COUT - COMMON /FREECH/ OCHAR -C----------------------------------------------------------------------- -C Set the values to sensible defaults. Values from IHSLIT to IUPHAP -C are decimal numbers with the same digits as the octal numbers which -C are the true values. -C----------------------------------------------------------------------- - DFMODL = 'CAD4' - ALPHA = 49.99 - APMIN = 1.3 - APMAX = 5.9 - IHSLIT = 77 - MINVAR = 277 - MAXVAR = 2443 - IHOLE = 2570 - INEG45 = 3001 - IPOS45 = 3135 - IVSLIT = 3315 - ILOHAF = 3477 - IUPHAF = 3731 -C----------------------------------------------------------------------- -C Attach goniom.ini to unit 9 -C----------------------------------------------------------------------- - OPEN (UNIT=9, ACCESS='SEQUENTIAL', FILE='goniom.ini', - $ STATUS='OLD', ERR=110) -C----------------------------------------------------------------------- -C Read values from goniom.ini. Ignore lines starting with / -C----------------------------------------------------------------------- - 100 READ (9,11000,END=200) OCHAR -11000 FORMAT (A) - IF (OCHAR(1:1) .EQ. '/') GO TO 100 - CKEY = OCHAR(1:6) - IDONE = 0 - IF (CKEY .EQ. 'Dfmodl') THEN - IF (OCHAR(9:9) .NE. ' ') I = 9 - IF (OCHAR(8:8) .NE. ' ') I = 8 - IF (OCHAR(7:7) .NE. ' ') I = 7 - DFMODL = OCHAR(I:I+3) - GO TO 100 - ENDIF - OCHAR(1:6) = ' ' - CALL FREEFM (1000) - IVAL = IFREE(1) -C----------------------------------------------------------------------- -C Get COMMON /CADCON/ values for DIFRAC -C----------------------------------------------------------------------- - IF (CKEY .EQ. 'Port ') THEN - IPORT = IVAL - IDONE = 1 - ELSE IF (CKEY .EQ. 'Baud ') THEN - IBAUD = IVAL - IDONE = 1 - ELSE IF (CKEY .EQ. 'Alpha ') THEN - ALPHA = RFREE(1) - IDONE = 1 - ELSE IF (CKEY .EQ. 'Apmax ') THEN - APMAX = RFREE(1) - IDONE = 1 - ELSE IF (CKEY .EQ. 'Apmin ') THEN - APMIN = RFREE(1) - IDONE = 1 - ELSE IF (CKEY .EQ. 'Vutht ') THEN - VUTHT = RFREE(1) - IDONE = 1 - ELSE IF (CKEY .EQ. 'Vuome ') THEN - VUOME = RFREE(1) - IDONE = 1 - ELSE IF (CKEY .EQ. 'Vuchi ') THEN - VUCHI = RFREE(1) - IDONE = 1 - ELSE IF (CKEY .EQ. 'Vuphi ') THEN - VUPHI = RFREE(1) - IDONE = 1 - ENDIF - IF (IDONE .EQ. 0) THEN - IVAL = IFREE(1) - CALL OCTDEC (IVAL) - IF (CKEY .EQ. 'Maxvar') THEN - MAXVAR = IVAL - ELSE IF (CKEY .EQ. 'Minvar') THEN - MINVAR = IVAL - ELSE IF (CKEY .EQ. 'Upperh') THEN - IUPHAF = IVAL - ELSE IF (CKEY .EQ. 'Lowerh') THEN - ILOHAF = IVAL - ELSE IF (CKEY .EQ. 'Negsl ') THEN - INEG45 = IVAL - ELSE IF (CKEY .EQ. 'Possl ') THEN - IPOS45 = IVAL - ELSE IF (CKEY .EQ. 'Vslit ') THEN - IVSLIT = IVAL - ELSE IF (CKEY .EQ. 'Hslit ') THEN - IHSLIT = IVAL - ELSE IF (CKEY .EQ. 'Hole ') THEN - IHOLE = IVAL - ENDIF - ENDIF - GO TO 100 -C----------------------------------------------------------------------- -C There was an error opening goniom.ini. Do something about it. -C----------------------------------------------------------------------- - 110 WRITE (COUT,10000) - CALL GWRITE (ITP,' ') -10000 FORMAT (' Error opening CAD-4 goniometer constants file', - $ ' goniom.ini.'/ - $ ' Exit from DIFRAC, check the file and try again.') - RETURN - 200 CLOSE (UNIT = 9) - RETURN - END -C----------------------------------------------------------------------- -C Convert a decimal number to the decimal equivalent of the octal -C number with the same digits. -C e.g. 123(10) --> 123(8) --> 83(10) -C----------------------------------------------------------------------- - SUBROUTINE OCTDEC (IVAL) - IWORK = IVAL - IMULT = 1 - IVAL = 0 - 100 ITEMP = IWORK/10 - IDIGIT = IWORK - 10*ITEMP - IVAL= IVAL + IDIGIT*IMULT - IMULT = IMULT*8 - IWORK = ITEMP - IF (IWORK .NE. 0) GO TO 100 - RETURN - END diff --git a/difrac/range.f b/difrac/range.f deleted file mode 100644 index feee6d66..00000000 --- a/difrac/range.f +++ /dev/null @@ -1,13 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to put Omega, Chi & Phi into the correct range -C----------------------------------------------------------------------- - SUBROUTINE RANGE (ICHI,IPHI,A) - DIMENSION A(4) - A(2) = A(2) + 180.0 - A(3) = A(3) + 180.0*ICHI - A(4) = A(4) + 180.0*IPHI - IF (A(2) .GE. 360.0) A(2) = A(2) - 360.0 - IF (A(3) .GE. 360.0) A(3) = A(3) - 360.0 - IF (A(4) .GE. 360.0) A(4) = A(4) - 360.0 - RETURN - END diff --git a/difrac/rcpcor.f b/difrac/rcpcor.f deleted file mode 100644 index 50cf7957..00000000 --- a/difrac/rcpcor.f +++ /dev/null @@ -1,125 +0,0 @@ -C----------------------------------------------------------------------- -C This subroutine calculates the reciprocal coordinates of a reflection -C Called by 3 commands :-- -C AH - to convert Euler angles to h,k,l -C MR - to convert direct beam Euler angles to h,k,l -C FI - to convert face indexing Euler angles to h,k,l -C----------------------------------------------------------------------- - SUBROUTINE RCPCOR - INCLUDE 'COMDIF' - DIMENSION RM1(3,3),XA(3),HA(3) - CHARACTER STRING*80 - IF (KI .EQ. 'AH') THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - ENDIF - CALL MATRIX (R,RM1,RJUNK,RJUNK,'INVERT') - 100 IF (KI .EQ. 'MR') THEN - CALL ANGET (THETAS,OMEGS,CHIS,PHIS) - OMEGS = OMEGS - 90.0 + 0.5*THETAS - ELSE IF (KI .EQ. 'FI') THEN - THETAS = THETA - OMEGS = OMEGA - CHIS = CHI - PHIS = PHI - ELSE - WRITE (COUT,11000) - CALL FREEFM (ITR) - IF (RFREE(1) .EQ. 0) THEN - KI = ' ' - RETURN - ENDIF - THETAS = RFREE(1) - OMEGS = RFREE(2) - CHIS = RFREE(3) - PHIS = RFREE(4) - ENDIF - CO = COS(OMEGS/DEG) - SO = SIN(OMEGS/DEG) - CC = COS(CHIS/DEG) - SC = SIN(CHIS/DEG) - CP = COS(PHIS/DEG) - SP = SIN(PHIS/DEG) - ESS = 2.0*SIN(THETAS/(2.0*DEG)) - XA(1) = ESS*(CO*CC*CP - SO*SP) - XA(2) = ESS*(CO*CC*SP + SO*CP) - XA(3) = ESS*CO*SC - CALL MATRIX (RM1,XA,HA,RJUNK,'MVMULT') - WRITE (COUT,12000) HA - CALL GWRITE (ITP,' ') - IF (KI .EQ. 'MR') KI = ' ' - IF (KI .EQ. 'MR' .OR. KI .EQ. 'FI') RETURN - GO TO 100 -10000 FORMAT (' Calculate Reciprocal Coordinates ') -11000 FORMAT (' Type the reflection angles (End) ',$) -12000 FORMAT (5X,' Reciprocal Coordinates (h,k,l)',3F10.3) - END -C----------------------------------------------------------------------- -C Index faces for ABSORP when they are set so that the face normal is -C in the equator plane and normal to the microscope viewing direction -C at the Kappa angles -45, 78, kappa (-60 start), phi (0 start) -C----------------------------------------------------------------------- - SUBROUTINE FACEIN - CHARACTER STRING*80 - INCLUDE 'COMDIF' - DATA ISENSE/-1/ - NATT = 0 - ICOL = 0 -C----------------------------------------------------------------------- -C Set the microscope to the initial viewing position and print message -C The viewing position Kappa angles are -45, 78, -60, 0 -C The Euler equivalent is used below. -C----------------------------------------------------------------------- - THETA = -90.0 - OMEGA = 102.63 - CHI = -45.0 - PHI = -20.37 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') -C----------------------------------------------------------------------- -C Get the adjusted angles and transform them -C----------------------------------------------------------------------- - 100 WRITE (COUT,11000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) -C write (cout,99990) -C99990 format (' Type omk, kap, phk for face ',$) -C call freefm (itr) -C omk = rfree(1) -C if (omk .eq. 0) omk = 78.0 -C rka = rfree(2) -C phk = rfree(3) -C call eulkap (1,omega,chi,phi,omk,rka,phk,isttus) -C99991 format (i3,7f8.2) - CALL ANGET (THETA,OMEGA,CHI,PHI) - CALL EULKAP (0,OMEGA,CHI,PHI,OMK,RKA,PHK,ISTTUS) -C i = 2 -C write (COUT,99991) i,theta,omega,chi,phi,omk,rka,phk -C call gwrite (itp, ' ') -C OMK = OMK - 135.0 - IRL = 1 - IF (ANS .EQ. 'L') IRL = 0 - OMK = OMK - IRL*180.0 - CALL EULKAP (1,OMEGA,CHI,PHI,OMK,RKA,PHK,ISTTUS) - THETA = 20.0 -C i = 3 -C write (COUT,99991) i,theta,omega,chi,phi,omk,rka,phk -C call gwrite (itp, ' ') - CALL RCPCOR - WRITE (COUT,12000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') GO TO 100 - KI = ' ' - RETURN -10000 FORMAT (/20X,' CAD-4 Face Indexing'/ - $ ' Adjust Kappa and Phi with the pocket terminal,', - $ ' so that the face-normal is'/ - $ ' a. Horizontal,'/ - $ ' b. Normal to the view direction, pointing right', - $ ' or left.') -11000 FORMAT (' When the face is set correctly, type R or L to', - $ ' indicate whether'/ - $ ' the normal is pointing to the Right or Left (R) ',$) -12000 FORMAT (/' Index another face (Y) ? ',$) - END diff --git a/difrac/readme.dif b/difrac/readme.dif deleted file mode 100644 index 78a0d90f..00000000 --- a/difrac/readme.dif +++ /dev/null @@ -1,128 +0,0 @@ - - - - - Installation Instructions for DIFRAC on a PC - -------------------------------------------- - - - The diskette supplied contains all files necessary to run and maintain - the DIFRAC programs on a PC controlling the diffractometer. These are - - 1. CAD4L.EXE -- the program to load the interface (CAD4 only). - 2. DIFRAC.EXE -- the program to control the instrument; - - The PC should be configured so that - a. communication between the computer and the instrument is via COM1:, - b. a printer is attached to LPT1: and - c. graphics is supported with a standard VGA (640x480) card. - - The file GONIOM.INI contains constants needed by program to define the - diffractometer model, the microscope viewing position, the COM port number and - baud-rate and, in the case of the CAD4, other constants which define slit - positions, voltages etc. This file is plain ASCII and commented to facilitate - editting. - - - 1. CAD4L (CAD-4 only) - ----- - This is the analogue of the routine of the same name in the original - Enraf-Nonius control system. It loads the binary interface code and some of - the instrumental constants. - - There are three versions of the binary interface code. - - a. interfaces with Falcon computers require the file FALCON.EXE; - b. interfaces with LS-11 computers require the file LSI_11.EXE; - c. interfaces with Falcon+ computers require the file FALCNP.EXE. - - The routine CAD4L.EXE loads the appropriate file together with the interface - resident constants from the file goniom.ini. - - The instrumental constants in the file GONIOM.INI should be editted so that - it contains values appropriate to the instrument in use. These values should - be obtained from the original CAD-4 control routine with the CASPAR and GCONST - commands. - - Files Needed :-- CAD4L.EXE, LSI_11.EXE or FALCON.EXE or FALCNP.EXE, - GONIOM.INI. - - - 2. DIFRAC - ------ - This is the instrument control routine which carries out all - crystallographic operations and controls the diffractometer via the interface - computer. It too needs the file goniom.ini in order to obtain other - instrumental constants. The routine uses the file IDATA.DA to hold all data, - and if it does not exist when the routine is started it will be created and - sensible defaults will be supplied for most parameters. - - Files Needed :-- DIFRAC.EXE, GONIOM.INI, probably IDATA.DA. - - - - - - Setup Procedure - --------------- - 1. Create a working subdirectory and copy all files from the diskettes into this - subdirectory. - - 2. Non-CAD-4 machines - Connect a serial line between COM1: and the instrument interface. - Edit the file goniom.ini to ensure that it contains at least the correct values - for Dfmodl, Port, Baud, Vutht, Vuome, Vuchi and Vuphi. - - 2. CAD-4 Only - Before disconnecting the main PDP-11 or VAX computer from the serial line to - the interface, run the E-N control routine to obtain the instrumental - constants for the particular instrument. Edit the file GONIOM.INI to - reflect these constants as well as Dfmodl, Port, Baud, Vutht, Vuome, Vuchi and - Vuphi. - - Disconnect the main computer from the interface serial line and connect the - line to COM1:. The connection needs only a straight-through (null-modem) - cable (2 to 2, 3 to 3 etc). - - Run CAD4L to load the interface. - It should not be necessary to perform this step every time the - diffractometer is used. It maybe necessary to turn the interface power off - and on again after a few seconds in order to get CAD4L to run properly. The - interface baud-rate is set to 9600 and the routine reports as the 46 blocks - are loaded. If the interface has been loaded correctly, the pocket - terminal should be active and displaying the string DIFRAC. Check that - the values for HV, LL etc are those from the goniom.ini file. - - 3. Run DIFRAC to drive the diffractometer. - See the writeup for a description of the commands. - When DIFRAC (and CAD4L) is started a header screen appears from the - shareware used to control communication with the serial port. Follow the - simple instructions and the screen will clear as the routine is run. - - - Files on Diskettes - ------------------ - 1. CAD4L.EXE, LSI_11.EXE, FALCON.EXE, FALCNP.EXE, DIFRAC.EXE, GONIOM.INI. - Library files GONIO6.LIB and PCL4.LIB. - CAD4L.MAK and CAD4L.OVL to rebuild CAD4L, and DIF.MAK and DIF.OVL - to rebuild DIFRAC, if necessary with Microsoft Fortran. - - 2. All source files *.FOR for CAD4L and DIFRAC. The writeup in ASCII form - as DIF.ASC and in Word-Perfect 6.1 form as DIF.WPD. - This file README.DIF. - - It would probably be a good idea to copy all files before using them for any - other purpose. - - In Case of Difficulties - ----------------------- - Only 3 problems have been encountered with these programs. - 1. The cable between the PC and the interface is not a null-modem. - 2. The cable is not connected to the COM1: port. - 3. CAD4L seems to load correctly, but incorrect HV, LL etc values appear in - the pocket terminal. - - The first 2 problems can be solved by ensuring that the correct cable is - connected to the correct port. The third problem occurred in CAD4L and - has been fixed. If difficulties of this type are experienced contact - Eric Gabe (e-mail gabe@sg1.chem.nrc.ca). diff --git a/difrac/reindx.f b/difrac/reindx.f deleted file mode 100644 index b20be589..00000000 --- a/difrac/reindx.f +++ /dev/null @@ -1,105 +0,0 @@ -C----------------------------------------------------------------------- -C This subroutine either :-- -C 1. for RS, finds the direct cell by reindexing 3 reflections; -C 2. for CH, chooses reflections from the PK list to use with M2 or M3. -C----------------------------------------------------------------------- - SUBROUTINE REINDX - INCLUDE 'COMDIF' - DIMENSION IOLD(3,3),INEW(3,3),INDICS(3) - DIMENSION THETAS(NSIZE),OMEGAS(NSIZE),CHIS(NSIZE),PHIS(NSIZE) - EQUIVALENCE (ACOUNT( 1),THETAS(1)), - $ (ACOUNT( NSIZE*1),OMEGAS(1)), - $ (ACOUNT(2*NSIZE+1),CHIS(1)), - $ (ACOUNT(3*NSIZE+1),PHIS(1)) - IF (KI .EQ. 'RS') THEN - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - DO 110 I = 1,3 - 100 WRITE (COUT,11000) I - CALL FREEFM (ITR) - IOLD(I,1) = IFREE(1) - IOLD(I,2) = IFREE(2) - IOLD(I,3) = IFREE(3) - INEW(I,1) = IFREE(4) - INEW(I,2) = IFREE(5) - INEW(I,3) = IFREE(6) - NN = -1 - ISTAN = 0 - IH = IOLD(I,1) - IK = IOLD(I,2) - IL = IOLD(I,3) - IF ((IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) .OR. - $ (INEW(I,1) .EQ. 0 .AND. INEW(I,2) .EQ. 0 .AND. - $ INEW(I,3) .EQ. 0)) THEN - WRITE (COUT,11100) - CALL GWRITE (ITP,' ') - GO TO 100 - ENDIF - IPRVAL = 1 - CALL ANGCAL - IF (IVALID .NE. 0) THEN - WRITE (COUT,12000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') GO TO 100 - ENDIF - WRITE (COUT,13000) - $ (IOLD(I,KK),KK = 1,3),THETA,OMEGA,CHI,PHI, - $ (INEW(I,KK),KK = 1,3) - CALL GWRITE (ITP,' ') - IHK(I) = INEW(I,1) - NREFB(I) = INEW(I,2) - ILA(I) = INEW(I,3) - BCOUNT(I) = THETA - BBGR1(I) = OMEGA - BBGR2(I) = CHI - BTIME(I) = PHI - 110 CONTINUE - CALL ORMAT3 - ENDIF -C----------------------------------------------------------------------- -C Choose PK reflections for M2 or M3 -C----------------------------------------------------------------------- - ELSE IF (KI .EQ. 'CH') THEN - WRITE (COUT,14000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - WRITE (COUT,15000) - CALL GWRITE (ITP,' ') -C----------------------------------------------------------------------- -C Bring in the peaks from PK -C----------------------------------------------------------------------- - READ (ISD, REC=140) NGOOD - CALL ANGRW (0,4,NGOOD,140,0) - DO 120 I = 1,3 - WRITE (COUT,16000) I - CALL FREEFM (ITR) - IOC = IFREE(1) - INDICS(1) = IFREE(2) - INDICS(2) = IFREE(3) - INDICS(3) = IFREE(4) - IF (IOC .EQ. 0) THEN - KI = ' ' - RETURN - ENDIF - IHK(I) = INDICS(1) - NREFB(I) = INDICS(2) - ILA(I) = INDICS(3) - BCOUNT(I) = THETAS(IOC) - BBGR1(I) = OMEGAS(IOC) - BBGR2(I) = CHIS(IOC) - BTIME(I) = PHIS(IOC) - 120 CONTINUE - ENDIF - ENDIF - KI = ' ' - RETURN -10000 FORMAT (' Reindex 3 Reflections (Y) ? ',$) -11000 FORMAT (' Reflection',I3,'. Type OLD indices then NEW indices ',$) -11100 FORMAT (' 0,0,0 indices not allowed. Try again.') -12000 FORMAT (' The OLD indices are Invalid. Use them anyway (Y) ? ',$) -13000 FORMAT (2X,3I3,4F8.2,' New indices ',3I3) -14000 FORMAT (' Choose reflections from OC for M2 or M3 (Y) ? ',$) -15000 FORMAT (' Sequence number in OC and indices') -16000 FORMAT (' Reflection ',I1,' ',$) - END diff --git a/difrac/sammes.f b/difrac/sammes.f deleted file mode 100644 index 1499533f..00000000 --- a/difrac/sammes.f +++ /dev/null @@ -1,116 +0,0 @@ -C----------------------------------------------------------------------- -C -C Subroutine to measure intensities to controlled precision. -C -C A sample scan is taken and from the results a decision is made -C on the further course of action to obtain a specified precision. -C A precision PA is defined as sigma(Inet)/Inet. Then :-- -C 1. If Inet < 2sigma(Inet) no further measurement is done; -C 2. If precision PA has been acheived, no further measurement; -C 3. If PA has not been acheived, THEN -C a. if PA can be acheived in a time less than TMAX, then the -C necessary further scans are done, -C b. if PA cannot be acheived in TMAX, but a minimum precision PM -C can be if all of TMAX is used, then this is done, -C c. if PM cannot be acheived in TMAX, then no further measurement. -C The algorithm is described in D.F.Grant, Acta Cryst. 1973, A29, 217. -C -C On return :-- -C the peak count is in COUNT, the backgrounds in BGRD1 & BGRD2, -C total number of scans in ITIME and attenuator number in NATT. -C -C----------------------------------------------------------------------- - SUBROUTINE SAMMES (ITIME,ICC) - COMMON/PREC/PCOUNT(500) - INCLUDE 'COMDIF' -C----------------------------------------------------------------------- -C Do the sample scan -C----------------------------------------------------------------------- - CALL MESINT (IROFL,ICC) - ITIME = 1 - NPPTS = IDEL - TOTIME = PRESET - PK = COUNT - B1 = BGRD1 - B2 = BGRD2 - DO 100 N = 1,NPPTS + 10 - PCOUNT(N) = ACOUNT(N) - 100 CONTINUE - CALL PROFIL - TEMP = FRAC - IF (IPRFLG .EQ. 0) TEMP = FRAC1 -C----------------------------------------------------------------------- -C Analysis of the sample counts. -C If the net count is < 2sigma(Inet) RETURN -C----------------------------------------------------------------------- - IF(TEMP .GT. 0) THEN - FACT = 1.0/(TEMP*2.0) - ELSE - FACT = 1. - ENDIF - ENQ = COUNT - (BGRD1 + BGRD2)*FACT - ENQD = ENQ - (2.0*SQRT(COUNT + (BGRD1 + BGRD2)*FACT*FACT)) - IF (ENQD .LE. 0.0) RETURN -C----------------------------------------------------------------------- -C How many scans will be needed to attain precision PA ? -C----------------------------------------------------------------------- - NF = (COUNT + (BGRD1 + BGRD2)*FACT*FACT)/(ENQD*ENQD*PA*PA) + 0.5 - IF (NF .LE. 1) THEN - RETURN - ELSE - TEMP = NF*PRESET - IF (TEMP .LE. TMAX) THEN - DO 120 I = 2,NF - CALL MESINT (IROFL,ICC) - DO 110 N = 1,NPPTS + 10 - PCOUNT(N) = PCOUNT(N) + ACOUNT(N) - 110 CONTINUE - TOTIME = TOTIME + PRESET - PK = PK + COUNT - B1 = B1 + BGRD1 - B2 = B2 + BGRD2 - CALL KORQ (KQFLAG) - IF (KQFLAG .EQ. 0) GO TO 200 - 120 CONTINUE - GO TO 200 - ENDIF - ENDIF -C----------------------------------------------------------------------- -C PA cannot be acheived in TMAX. -C How many scans will be needed to attain precision PM ? -C----------------------------------------------------------------------- - NF = (COUNT + (BGRD1 + BGRD2)*FACT*FACT)/(ENQ*ENQ*PM*PM) + 0.5 - IF (NF .LE. 1) THEN - RETURN - ELSE - TEMP = NF*PRESET - IF (TEMP .LE. TMAX) THEN - NF = TMAX/PRESET + 0.5 - DO 140 I = 2,NF - CALL MESINT (IROFL,ICC) - DO 130 N = 1,NPPTS + 10 - PCOUNT(N) = PCOUNT(N) + ACOUNT(N) - 130 CONTINUE - TOTIME = TOTIME + PRESET - PK = PK + COUNT - B1 = B1 + BGRD1 - B2 = B2 + BGRD2 - CALL KORQ (KQFLAG) - IF (KQFLAG .EQ. 0) GO TO 200 - 140 CONTINUE - ENDIF - ENDIF -C----------------------------------------------------------------------- -C This is the end of all scans -C----------------------------------------------------------------------- - 200 COUNT = PK - BGRD1 = B1 - BGRD2 = B2 - PRESET = TOTIME - ITIME = NF - DO 210 N = 1,NPPTS + 10 - ACOUNT(N) = PCOUNT(N) - 210 CONTINUE - RETURN - END - diff --git a/difrac/setiou.f b/difrac/setiou.f deleted file mode 100644 index fddfc5b9..00000000 --- a/difrac/setiou.f +++ /dev/null @@ -1,87 +0,0 @@ -C----------------------------------------------------------------------- -C -C Subroutine SETIOU -C -C This subroutine sets the unit numbers for the commonly used I/O -C units and the RECL multiplier for direct-access OPEN statements -C for the NRCVAX Structure Package. It is called by all the -C routines of the package and therefore by changing the numbers -C assigned, all the I/O units can be changed for different operating -C systems. The assignments are as follows for VAX VMS :-- -C -C IOUNIT Value General System File or General System -C Array Device Symbol -C -C 1 1 Crystal Data File ICD -C 2 2 Reflection Data File IRE -C 3 3 Line-printer Output File LPT -C 4 4 -- -C 5 5 Terminal Input ITR -C 6 6 Terminal Output ITP -C 7 7 -- -C 8 8 -- -C 9 9 -- -C 10 10 -- -C -C The values of the 5 general symbols are set by the subroutine and -C assigned to the general system symbol. -C -C The 5 other values are set, but are not automatically assigned to a -C symbol generally used by the system. These are units 4,7,8,9 & 10. -C -C To change the values, alter the numbers assigned to IOUNIT(i). -C Ensure that there are no duplicate assignments. -C -C The RECL length multiplier, IBYLEN, is the number used to get the -C RECL parameter of OPEN statements for direct-access files to the -C correct value. -C For the VAX it is 1, i.e. the record-length is specified as -C the number of 4-byte variables/record. For other systems it may be -C necessary to change the length to bytes, in which case the value -C should be 4. -C -C The values in IOUNIT are used in all free form input -C -C----------------------------------------------------------------------- - SUBROUTINE SETIOU (ICD,IRE,LPT,ITR,ITP,IBYLEN) - INCLUDE 'IATSIZ' - COMMON /IOUASS/ IOUNIT(12) -C----------------------------------------------------------------------- -C Setup for the various machines and compilers -C----------------------------------------------------------------------- - IF (MNCODE .EQ. 'VAXVMS') THEN - IBYLEN = 1 - ELSE - IBYLEN = 4 - ENDIF -C----------------------------------------------------------------------- -C First the 5 general units (for ICD, IRE, LPT, ITR and ITP -C----------------------------------------------------------------------- - IOUNIT( 1) = 1 - IOUNIT( 2) = 2 - IOUNIT( 3) = 3 - IOUNIT( 5) = 5 - IOUNIT( 6) = 6 -C----------------------------------------------------------------------- -C Now the remaining less general units -C----------------------------------------------------------------------- - IOUNIT( 4) = 4 - IOUNIT( 7) = 7 - IOUNIT( 8) = 8 - IOUNIT( 9) = 9 - IOUNIT(10) = 10 -C----------------------------------------------------------------------- -C Save the value of IBYLEN -C----------------------------------------------------------------------- - IOUNIT(12) = IBYLEN -C----------------------------------------------------------------------- -C Assign the General System units to save having to do it in each -C system routine -C----------------------------------------------------------------------- - ICD = IOUNIT(1) - IRE = IOUNIT(2) - LPT = IOUNIT(3) - ITR = IOUNIT(5) - ITP = IOUNIT(6) - RETURN - END diff --git a/difrac/setop.f b/difrac/setop.f deleted file mode 100644 index 0b36b1c9..00000000 --- a/difrac/setop.f +++ /dev/null @@ -1,724 +0,0 @@ -C----------------------------------------------------------------------- -C This is the Command interpreting subroutine -C -C Each 2-letter command in KI is associated with a unique call or -C set of calls. Having made the call the particular 2-letter sequence -C will not make any further calls and will be cleared at the end of -C the call. -C When routines change the value of KI, which some do, the new value -C is always unique and will always cause action further down in SETOP. -C -C----------------------------------------------------------------------- - SUBROUTINE SETOP - INCLUDE 'COMDIF' - CHARACTER STRING*80 - 100 WRITE (COUT,10000) - CALL ALFNUM (STRING) - KI = STRING(1:2) - IF (KI .EQ. 'Q') THEN - CALL WNEND - STOP - ENDIF -C----------------------------------------------------------------------- -C The program runs in two modes, full screen and windowed. -C The following routines require the use of the windowed mode -C----------------------------------------------------------------------- - IF (KI .EQ. 'GO' .OR. KI .EQ. 'IP' .OR. - $ KI .EQ. 'IR' .OR. KI .EQ. 'IE' .OR. KI .EQ. 'IM') THEN - IF (IWNCUR .EQ. 3) CALL WNSET (2) - ENDIF -C----------------------------------------------------------------------- -C These routines require full screen mode, any others should work -C in either mode so we are not flipping screens all the time -C----------------------------------------------------------------------- - IF (KI .EQ. 'AL' .OR. KI .EQ. 'A8' .OR. KI .EQ. 'RO' .OR. - $ KI .EQ. 'OC' .OR. KI .EQ. 'SD' .OR. KI .EQ. 'AR' .OR. - $ KI .EQ. 'PK' .OR. KI .EQ. 'RC' .OR. KI .EQ. 'PD' .OR. - $ KI .EQ. 'RP' .OR. KI .EQ. 'BD' .OR. KI .EQ. 'CH' .OR. - $ KI .EQ. 'GS' .OR. KI .EQ. 'CR' .OR. KI .EQ. 'LC' .OR. - $ KI .EQ. 'LP' .OR. KI .EQ. 'M2' .OR. KI .EQ. 'M3' .OR. - $ KI .EQ. 'MM' .OR. KI .EQ. 'RS' .OR. KI .EQ. 'BC' .OR. - $ KI .EQ. 'NR' .OR. KI .EQ. 'TO' .OR. - $ KI .EQ. 'MR' .OR. KI .EQ. 'MS' .OR. KI .EQ. 'FI') THEN - IF (IWNCUR .NE. 3) CALL WNSET (3) - ENDIF -C----------------------------------------------------------------------- -C This routine reads commands from the terminal and sets a flag to -C indicate whether the command may inhibit an automatic restart of -C data collection, if appropriate. -C All control of the program flow is via the variable KI. -C----------------------------------------------------------------------- - IF (KI .NE. ' ') THEN - IMENU = 0 - ELSE - IF (IMENU .EQ. 0) THEN - WRITE (COUT,11000) - CALL YESNO ('N',ANS) - ELSE - IMENU = 0 - ANS = 'Y' - ENDIF - IF (ANS .EQ. 'Y') THEN - IWNOLD = IWNCUR - IF (IWNCUR .NE. 3) CALL WNSET (3) - WRITE (COUT,12000) - CALL GWRITE (ITP,' ') - IF (DFMODL .EQ. 'CAD4') THEN - WRITE (COUT,12100) - CALL GWRITE (ITP,' ') - ENDIF - WRITE (COUT,12200) - CALL FREEFM (ITR) - I = IFREE(1) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0 .OR. I .EQ. 1) THEN - WRITE (COUT,13000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (I .EQ. 0 .OR. I .EQ. 2) THEN - WRITE (COUT,15000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (I .EQ. 0 .OR. I .EQ. 3) THEN - WRITE (COUT,16000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (I .EQ. 0 .OR. I .EQ. 4) THEN - WRITE (COUT,17000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (I .EQ. 0 .OR. I .EQ. 5) THEN - WRITE (COUT,18000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (I .EQ. 0 .OR. I .EQ. 6) THEN - WRITE (COUT,19000) - CALL GWRITE (ITP,' ') - WRITE (COUT,20000) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - IF (DFMODL .EQ. 'CAD4' .AND. (I .EQ. 0 .OR. I .EQ. 7)) THEN - WRITE (COUT,20100) - CALL GWRITE (ITP,' ') - IF (I .EQ. 0) THEN - WRITE (COUT,14000) - CALL ALFNUM (STRING) - ANS = STRING(1:1) - ENDIF - ENDIF - ENDIF - GO TO 100 - ENDIF - IF (KI .EQ. 'RI') KI = 'RB' - JAUTO = 0 - IF (KI .EQ. 'AD') CALL BASINP - IF (KI .EQ. 'AL' .OR. KI .EQ. 'AR') CALL ALIGN - IF (KI .EQ. 'AP') CALL PROFAS - IF (KI .EQ. 'A8') CALL CENT8 - IF (KI .EQ. 'BI') CALL PRNINT - IF (KI .EQ. 'CR') CALL ALIGN - IF (KI .EQ. 'CZ') CALL BASINP - IF (KI .EQ. 'DE') CALL DEMO1E - IF (KI .EQ. 'EX') THEN - WRITE (COUT,21000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - CALL WRBAS - CALL WNEND - STOP - ENDIF - ENDIF - IF (KI .EQ. 'GO') THEN - ISEG = 0 - IAUTO = 0 - CALL BEGIN - ENDIF - IF (KI .EQ. 'GS') CALL GRID - IF (KI .EQ. 'AI') CALL IDTOAS - IF (KI .EQ. 'IE') CALL INDMES - IF (KI .EQ. 'IM') CALL INDMES - IF (KI .EQ. 'IN') CALL ANGINI - IF (KI .EQ. 'IR') CALL INDMES - IF (KI .EQ. 'IP') CALL INDMES - IF (KI .EQ. 'AH') KI = 'IX' - IF (KI .EQ. 'IX') CALL RCPCOR - IF (KI .EQ. 'LP') CALL LINPRF - IF (KI .EQ. 'MM') THEN - CALL LSORMT - IF (KI .NE. ' ') CALL BASINP - ENDIF - IF (KI .EQ. 'M2') THEN - CALL ORCEL2 - IF (KI .NE. ' ') CALL BASINP - ENDIF - IF (KI .EQ. 'M3') THEN - CALL ORMAT3 - IF (KI .NE. ' ') CALL BASINP - ENDIF - IF (KI .EQ. 'TO') THEN - CALL TRANSF - IF (KI .NE. ' ') CALL BASINP - ENDIF - IF (KI .EQ. 'LC') CALL CELLLS - IF (KI .EQ. 'OM') CALL BASINP - IF (KI .EQ. 'PO') KI = 'OS' - IF (KI .EQ. 'OS') CALL OSCIL - IF (KI .EQ. 'PA') CALL PRTANG - IF (KI .EQ. 'PD') CALL PRNBAS - IF (KI .EQ. 'PL') CALL SETROW - IF (KI .EQ. 'PR') CALL SETROW - IF (KI .EQ. 'HA') KI = 'RA' - IF (KI .EQ. 'P9') CALL PHI90 - IF (KI .EQ. 'RA') CALL ORMAT3 - IF (KI .EQ. 'RB') CALL WRBAS - IF (KI .EQ. 'RP') CALL PSCAN (JUNK,JUNK) - IF (KI .EQ. 'SA') CALL INDMES - IF (KI .EQ. 'SC') CALL INDMES - IF (KI .EQ. 'SH') THEN - CALL SHUTTR (0) - KI = ' ' - ENDIF - IF (KI .EQ. 'SW') CALL SWITCH - IF (KI .EQ. 'SO') CALL INDMES - IF (KI .EQ. 'SP') CALL INDMES - IF (KI .EQ. 'SR') CALL INDMES - IF (DFMODL .EQ. 'CAD4') THEN - IF (KI .EQ. 'EK' .OR. KI .EQ. 'KE') CALL EKKE - IF (KI .EQ. 'MS') CALL INDMES - IF (KI .EQ. 'MR') CALL RCPCOR - IF (KI .EQ. 'FI') CALL FACEIN - ENDIF - IF (KI .EQ. 'ST') CALL INDMES - IF (KI .EQ. 'TC') CALL PCOUNT - IF (KI .EQ. 'UM') CALL CNTREF - IF (KI .EQ. 'VM') CALL VUMICR - IF (KI .EQ. 'WB') CALL WRBAS - IF (KI .EQ. 'HO' .OR. KI .EQ. 'ZE') THEN - CALL ZERODF - KI = ' ' - ENDIF - IF (KI .EQ. 'NR') CALL SETNRC -C----------------------------------------------------------------------- -C If the command has not yet been executed, no auto restart is -C possible -C----------------------------------------------------------------------- - IF (KI .NE. ' ') JAUTO = 1 - IF (KI .EQ. 'BD') CALL BASINP - IF (KI .EQ. 'CH') CALL REINDX - IF (KI .EQ. 'DH') THEN - IKO(5) = 0 - CALL BASINP - ENDIF - IF (KI .EQ. 'FR') CALL BASINP - IF (KI .EQ. 'LA') CALL BASINP - IF (KI .EQ. 'LT') CALL LOTEM - IF (KI .EQ. 'OC') CALL BLIND - IF (KI .EQ. 'PK') CALL PEAKSR - IF (KI .EQ. 'PS') CALL BASINP - IF (KI .EQ. 'RC') CALL CREDUC (KI) - IF (KI .EQ. 'RO') CALL BASINP - IF (KI .EQ. 'BC') CALL BIGCHI - IF (KI .EQ. 'RR') CALL BASINP - IF (KI .EQ. 'RS') CALL REINDX - IF (KI .EQ. 'SD') CALL BASINP - IF (KI .EQ. 'SE') CALL BASINP - IF (KI .EQ. 'SG') THEN - IOUT = ITP - CALL SPACEG (IOUT,1) - ENDIF - IF (KI .EQ. 'TM') CALL BASINP - IF (KI .EQ. 'TP') CALL BASINP -C----------------------------------------------------------------------- -C If the KI code is in the first 60 codes, then no automatic restart. -C----------------------------------------------------------------------- - IF (JAUTO .NE. 0) THEN - NSAVE = NBLOCK - ZERO = 0 - WRITE (IID,REC=9) ZERO - NBLOCK = NSAVE - ENDIF - IF (KI .NE. ' ') THEN - WRITE (COUT,22000) KI - CALL GWRITE (ITP,' ') - KI = ' ' - IMENU = 1 - GO TO 100 - ENDIF - RETURN -10000 FORMAT (' Command ',$) -11000 FORMAT (' Unacceptable command. Do you want the menus (N) ? ',$) -12000 FORMAT (/' The following help menus are available :--'/ - $ ' 1. Terminal Data Input Commands;'/ - $ ' 2. Crystal Alignment Commands;'/ - $ ' 3. Intensity Data Collection;'/ - $ ' 4. Angle Setting and Intensity Measurement;'/ - $ ' 5. Photograph Setup Commands;'/ - $ ' 6. General System Commands.') -12100 FORMAT ( ' 7. Kappa Geometry (CAD-4) Commands.') -12200 FORMAT (' Which do you want (All) ? ',$) -13000 FORMAT (/10X,'*** Terminal Data Input Commands ***'/ - $' AD Attenuator Data: number and values.'/ - $' BD all Basic Data (CZ DH FR LA OM OR PS RR SD SE TM TP)'/ - $' CZ Correct angle Zero values.'/ - $' FR First Reflection to be measured.'/ - $' LA LAmbda for the wavelength in use, usually alpha1.'/ - $' LT Liquid Nitrogen option - specific to cryosystem.'/ - $' OM Orientation Matrix.'/ - $' PS PSi rotation data.'/ - $' RO re-Orientation Reflections: frequency and h,k,ls.'/ - $' RR Reference Reflections: frequency and h,k,ls.'/ - $' SD Scan Data: type, width, speed, profile control.'/ - $' SE Systematic Extinctions.'/ - $' SG Space-Group symbol.'/ - $' TM 2Theta Min and max values.'/ - $' TP Time and Precision parameters for intensity measurement.'/) -14000 FORMAT (' Type when ready to proceed.') -15000 FORMAT (/10X,'*** Crystal Alignment Commands ***'/ - $' AL ALign reflections and their symmetry equivalents for MM.'/ - $' AR Align Resumption after interruption.'/ - $' A8 Align the 8 alternate settings of one reflection.'/ - $' CH CHoose reflections from the PK list for use with M2/M3.'/ - $' CR Centre the Reflection which is already in the detector.'/ - $' LC 2theta Least-squares Cell with symmetry constrained cell.'/ - $' MM Matrix from Many reflections by least-squares on AL data.'/ - $' M2 Matrix from 2 indexed reflections and a unit cell.'/ - $' M3 Matrix from 3 indexed reflections.'/ - $' OC Orient a Crystal, i.e. index the peaks from PK.'/ - $' PK PeaK search in 2Theta, Chi, Phi for use with OC.'/ - $' RC Reduce a unit Cell.'/ - $' RP Rotate Phi 360degs, centre and save any peaks found.'/ - $' RS ReSet the cell and matrix with the results from RC.'/ - $' TO Transform the Orientation matrix.'/) -16000 FORMAT (/10X,'*** Intensity Data Collection ***'/ - $' GO Start of intensity data collection.'/ - $' K Kill operation at the end of the current reflection.'/ - $' Q Quit after the next set of reference reflections.'/) -17000 FORMAT (/5X,'*** Angle Setting and Intensity Measurement ***'/ - $' GS Grid Search measurement in 2theta, omega or chi.'/ - $' IE Intensity measurement for Equivalent reflections.'/ - $' IM Intensity Measurement of the reflection in the detector.'/ - $' IP Intensity measurement in Psi for empirical absorption.'/ - $' IR Intensity measurement for specified Reflections.'/ - $' LP Line Profile plot on the printer.'/ - $' SA Set All angles to specified values.'/ - $' SC Set Chi to the specified value.'/ - $' SH SHutter open or close as a flip/flop.'/ - $' SO Set Omega to the specified value.'/ - $' SP Set Phi to the specified value.'/ - $' SR Set Reflection: h,k,l,psi.'/ - $' ST Set 2Theta to the specified value.'/ - $' TC Timed Counts.'/ - $' ZE ZEro the instrument Angles.'/) -18000 FORMAT (/10X,'*** Photograph Setup Commands ***'/ - $' PL Photograph in the Laue mode.'/ - $' PO Photograph in the Oscillation mode (same as OS).'/ - $' PR Photograph in the Rotation mode.'/) -19000 FORMAT (/10X,'*** General System Commands ***'/ - $' AH Angles to H,k,l (same as IX).'/ - $' AI Ascii Intensity data file conversion.'/ - $' AP Ascii Profile data file conversion.'/ - $' BC Big Chi search for psi rotation.'/ - $' BI Big Intensity search in the IDATA.DA file.'/ - $' EX EXit the program saving the basic data on IDATA.DA.'/ - $' HA H,k,l to Angles (same as RA).') -20000 FORMAT ( - $' IN INitialize integer parts of present angles (NRC only).'/ - $' NR set the NRC program flag.'/ - $' P9 Rotate Phi by 90 degrees for crystal centering.'/ - $' PA Print Angle settings.'/ - $' PD Print Data of all forms.'/ - $' Q Quit the program directly.'/ - $' RB Read the Basic data from the IDATA.DA file.'/ - $' SW SWitch register flags setting.'/ - $' UM (UMpty) Count unique reflections within theta limits.'/ - $' VM View crystal with Microscope.'/ - $' WB Write the Basic data to the IDATA.DA file.'/) -20100 FORMAT (/10X,'*** For Kappa geometry (CAD-4) ***'/ - $' EK Euler to Kappa angle conversion.'/ - $' KE Kappa to Euler angle conversion.'/ - $' MR emulate CAD-4 MICROR command.'/ - $' MS emulate CAD-4 MICROS command.') -21000 FORMAT (' EX was typed. Are you sure you wish to exit (Y) ? ',$) -22000 FORMAT (' The command ',A,' is invalid. Type for the menus.') - END -C----------------------------------------------------------------------- -C Subroutine to open and close the X-ray shutter -C This routine is called via 'SH' or direct from other routines. -C The argument IDO has the following values :-- -C -1 Close the shutter -C 0 Reverse the sense of the shutter. The sense is held in SENSE -C 1 Open the shutter -C 2 ?? -C 99 Called from GOLOOP at the start of data-collection; -C Opens the shutter and sets DOIT = 'NO' -C to prevent shutter operation during data-collection. -C -99 Called from GOLOOP at the end of data-collection; -C Closes the shutter and sets DOIT = 'YES' -C to allow normal shutter operation. -C -C This version is for Rigaku diffractometers,but should work (surely?) -C for all instruments with trivial modification. -C----------------------------------------------------------------------- - SUBROUTINE SHUTTR (IDO) - CHARACTER SENSE*4,COUT(20)*132,DOIT*4 - COMMON /IOUASC/ COUT - DATA SENSE/'CLOS'/,ICLOSE,IOPEN/0,1/,DOIT/'YES '/ - INF = 0 - IF (DOIT .EQ. 'YES ') THEN - IF (IDO .EQ.-1 .OR. IDO .EQ. -99) THEN - IF (SENSE .EQ. 'OPEN') THEN - CALL SHUTR (ICLOSE,INF) - IF (INF .NE. 0) GO TO 100 - SENSE = 'CLOS' - ENDIF - ELSE IF (IDO .EQ. 0) THEN - IF (SENSE .EQ. 'OPEN') THEN - CALL SHUTR (ICLOSE,INF) - IF (INF .NE. 0) GO TO 100 - SENSE = 'CLOS' - ELSE - CALL SHUTR (IOPEN,INF) - IF (INF .NE. 0) GO TO 100 - SENSE = 'OPEN' - ENDIF - ELSE IF (IDO .EQ. 1 .OR. IDO .EQ. 99) THEN - IF (SENSE .EQ. 'CLOS') THEN - CALL SHUTR (IOPEN,INF) - IF (INF .NE. 0) GO TO 100 - SENSE = 'OPEN' - ENDIF - ELSE IF (IDO .EQ. 2) THEN - IF (SENSE .EQ. 'OPEN') CALL SHUTR (IOPEN,INF) - IF (SENSE .EQ. 'CLOS') CALL SHUTR (ICLOSE,INF) - ENDIF - ELSE - IF (IDO .EQ. -99) THEN - CALL SHUTR (ICLOSE,INF) - IF (INF .NE. 0) GO TO 100 - SENSE = 'CLOS' - ENDIF - ENDIF - IF (IDO .EQ. 99) DOIT = 'NO ' - IF (IDO .EQ. -99) DOIT = 'YES ' - RETURN - 100 WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - RETURN -10000 FORMAT (' Shutter Error.') - END -C----------------------------------------------------------------------- -C Subroutine to initialize the integer values of the angles -C----------------------------------------------------------------------- - SUBROUTINE ANGINI - INCLUDE 'COMDIF' - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - WRITE (COUT,11000) - CALL FREEFM (ITR) - RTHETA = RFREE(1) - ROMEGA = RFREE(2) - RCHI = RFREE(3) - RPHI = RFREE(4) - CALL INITL (RTHETA,ROMEGA,RCHI,RPHI) - KI = ' ' - ENDIF - RETURN -10000 FORMAT (' Initialize the integer parts of the angle (Y) ? ',$) -11000 FORMAT (' Type the integers for 2theta,omega,chi,phi ',$) - END -C----------------------------------------------------------------------- -C Subroutine to call the space group symbol interpreting routines -C If IOUT .LT. -1 the symbol is not asked for -C If IOUT .LT. 0 there is no printed output from SGROUP -C If IDHFLG .EQ. 1 the DH matrices are generated -C----------------------------------------------------------------------- - SUBROUTINE SPACEG (IOUT,IDHFLG) - INCLUDE 'COMDIF' - DIMENSION CEN(3,4),GARB(500),ISET(25) - EQUIVALENCE (ACOUNT(1),GARB(1)) - CHARACTER STRING*10 - IF (IOUT .EQ. -2) THEN - IOUT = -1 - GO TO 130 - ENDIF - 100 IF (SGSYMB(1) .EQ. 0.0 .AND. SGSYMB(2) .EQ. 0.0) THEN - WRITE (COUT,10000) - ELSE - WRITE (STRING,11000) SGSYMB - DO 110 I = 10,1,-1 - IF (STRING(I:I) .NE. ' ') GO TO 120 - 110 CONTINUE - 120 WRITE (COUT,12000) STRING(1:I) - ENDIF - CALL ALFNUM (STRING) - IF (STRING .NE. ' ') READ (STRING,11000) SGSYMB - 130 IERR = ITP - CALL SGROUP (SGSYMB,LAUENO,NAXIS,ICENT,LATCEN,NSYM,NPOL,JRT, - $ CEN,NCV,IOUT,IERR,GARB) - IF (NAXIS .GE. 4) GO TO 100 - IF (IDHFLG .EQ. 1) THEN - SAVE = NBLOCK - CALL DHGEN - NBLOCK = SAVE -C----------------------------------------------------------------------- -C Read the DH segment data from the IDATA file -C----------------------------------------------------------------------- - READ (IID,REC=4) LATCEN,NSEG,(IHO(I),IKO(I),ILO(I),((IDH(I,J,M), - $ J = 1,3),M = 1,3),I = 1,4), - $ NSYM,NSET,ISET,LAUENO,NAXIS,ICENT - ENDIF - IF (KI .EQ. 'SG') KI = ' ' - RETURN -10000 FORMAT (' Type the space-group symbol ') -11000 FORMAT (10A1) -12000 FORMAT (' Type the space-group symbol (',A,') ') - END -C----------------------------------------------------------------------- -C Subroutine to set switches -C----------------------------------------------------------------------- - SUBROUTINE SWITCH - INCLUDE 'COMDIF' - CHARACTER STRING*20 - WRITE (COUT,10000) (ISREG(I),I=1,10) - CALL ALFNUM (STRING) - IF (STRING .NE. ' ') THEN - DO 100 I = 1,LEN(STRING) - IASCII = ICHAR (STRING(I:I)) - IF (IASCII .GE. 48 .AND. IASCII .LE. 57) THEN - ISWTCH = IASCII - 48 + 1 - IF (ISREG(ISWTCH) .EQ. 0) THEN - ISREG(ISWTCH) = 1 - ELSE - ISREG(ISWTCH) = 0 - ENDIF - ENDIF - 100 CONTINUE - ENDIF - WRITE (COUT,11000) (ISREG(I),I=1,10) - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN -10000 FORMAT (' The current settings are: 0 1 2 3 4 5 6 7 8 9'/ - $ ' ',10I2/ - $ ' Input switches to change (none): ') -11000 FORMAT (' The new settings are: 0 1 2 3 4 5 6 7 8 9'/ - $ ' ',10I2) - END -C---------------------------------------------------------------------- -C Set the NRC flag +1 if Chi(0) is at the bottom of the chi circle, -C -1 if Chi(0) is at the top. -C Assuming the instrument itself is defined in a right-handed way. -C---------------------------------------------------------------------- - SUBROUTINE SETNRC - INCLUDE 'COMDIF' - WRITE (COUT,10000) NRC - CALL FREEFM (ITR) - IF (IFREE(1) .NE. 0) NRC = IFREE(1) - RETURN -10000 FORMAT (' The current value of the NRC flag is',I3/ - $ ' Type the new value (Current) ',$) - END -C----------------------------------------------------------------------- -C Convert Euler angles to Kappa (KI = 'EK') or vice-versa (KI = 'KE') -C----------------------------------------------------------------------- - SUBROUTINE EKKE - INCLUDE 'COMDIF' - COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR, - $ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF, - $ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD - PARAMETER (RA = 57.2958) - SALPHA = SIN(ALPHA/RA) - CALPHA = COS(ALPHA/RA) - ISTATUS = 0 -C----------------------------------------------------------------------- -C KI = 'EK' Euler to Kappa -C----------------------------------------------------------------------- - IF (KI .EQ. 'EK') THEN - WRITE (COUT,10000) THETA,OMEGA,CHI,PHI - CALL FREEFM (ITR) - IF (RFREE(1) .EQ. 0.0 .AND. RFREE(2) .EQ. 0.0 .AND. - $ RFREE(3) .EQ. 0.0) THEN - THE = THETA - OME = OMEGA - CHE = CHI - PHE = PHI - ELSE - THE = RFREE(1) - OME = RFREE(2) - CHE = RFREE(3) - PHE = RFREE(4) - ENDIF - THE = THE/2.0 - SCO2 = SIN(ONE80(CHE)/(2.0*RA)) - BOT = SALPHA*SALPHA - SCO2*SCO2 - IF (BOT .LT. 0.0) THEN - ISTATUS = 1 - KI = ' ' - RETURN - ENDIF - RKAO2 = ATAN(SCO2/SQRT(BOT)) - RKA = ONE80(2.0*RA*RKAO2) - DELTA = RA*ATAN(CALPHA*SIN(RKAO2)/COS(RKAO2)) - OMK = ONE80(OME - DELTA) + THE - PHK = ONE80(PHE - DELTA) - WRITE (COUT,11000) THE,OMK,RKA,PHK -C----------------------------------------------------------------------- -C KI = 'KE' Kappa to Euler -C----------------------------------------------------------------------- - ELSE - WRITE (COUT,12000) - CALL FREEFM (ITR) - THE = RFREE(1) - OMK = RFREE(2) - RKA = RFREE(3) - PHK = RFREE(4) - OMK = OMK - THE - THE = THE + THE - RKAO2 = RKA/(2.0*RA) - CHE = ONE80(2.0*RA*ASIN(SALPHA*SIN(RKAO2))) - DELTA = RA*ATAN(CALPHA*SIN(RKAO2)/COS(RKAO2)) - OME = ONE80(OMK + DELTA) - PHE = ONE80(PHK + DELTA) - WRITE (COUT,13000) THE,OME,CHE,PHE - ENDIF - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN -10000 FORMAT (' The present Euler angles are 2T,O,C,P',4F8.3,/ - $ ' Type the angles to convert (Present) ',$) -11000 FORMAT (' The 4 Kappa angles T,O,K,P are ',4F8.3) -12000 FORMAT (' Type the 4 Kappa angles T,O,K,P ',$) -13000 FORMAT (' The 4 Euler angles 2T,O,C,P are ',4F8.3) - END -C----------------------------------------------------------------------- -C Set the diffractometer to a convenient microscope viewing position -C----------------------------------------------------------------------- - SUBROUTINE VUMICR - INCLUDE 'COMDIF' - NATT = 0 - CALL VUPOS (THETA,OMEGA,CHI,PHI) - CALL SHUTTR (-99) - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR) - IF (IERR .NE. 0) THEN - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - ENDIF - KI = ' ' - RETURN -10000 FORMAT (' Setting collision during VM') - END -C----------------------------------------------------------------------- -C Rotate the crystal 90 degrees in phi for centering operations -C----------------------------------------------------------------------- - SUBROUTINE PHI90 - INCLUDE 'COMDIF' - CALL ANGET (THETA,OMEGA,CHI,PHI) - PHI = PHI + 90.0 - CALL MOD360 (PHI) - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR) - KI = ' ' - RETURN - END -C----------------------------------------------------------------------- -C Transform the orientation matrix -C----------------------------------------------------------------------- - SUBROUTINE TRANSF - INCLUDE 'COMDIF' - DIMENSION HOLD(3,3),HNEW(3,3),HNEWI(3,3),RNEW(3,3) - WRITE (COUT,10000) - CALL GWRITE (ITP,' ') - DO 100 I = 1,3 - 90 WRITE (COUT,11000) I - CALL FREEFM (ITR) - HOLD(1,I) = IFREE(1) - HOLD(2,I) = IFREE(2) - HOLD(3,I) = IFREE(3) - HNEW(1,I) = IFREE(4) - HNEW(2,I) = IFREE(5) - HNEW(3,I) = IFREE(6) - IF ((HOLD(1,I) .EQ. 0.0 .AND. HOLD(2,I) .EQ. 0.0 .AND. - $ HOLD(3,I) .EQ. 0.0) .OR. - $ (HNEW(1,I) .EQ. 0.0 .AND. HNEW(2,I) .EQ. 0.0 .AND. - $ HNEW(3,I) .EQ. 0.0)) THEN - WRITE (COUT,11100) - CALL GWRITE (ITP,' ') - GO TO 90 - ENDIF - 100 CONTINUE -C----------------------------------------------------------------------- -C Invert the IHNEW matrix and form RNEW = R.IHOLD.(IHNEW)-1 -C----------------------------------------------------------------------- - CALL MATRIX (HNEW,HNEWI,HNEWI,HNEWI,'INVERT') - CALL MATRIX (R,HOLD,RNEW,RJUNK,'MATMUL') - CALL MATRIX (RNEW,HNEWI,RNEW,RJUNK,'MATMUL') -C----------------------------------------------------------------------- -C Print the new matrix and parameters -C----------------------------------------------------------------------- - DO 110 I = 1,3 - DO 110 J = 1,3 - ROLD(I,J) = R(I,J)/WAVE - R(I,J) = RNEW(I,J) - RNEW(I,J) = RNEW(I,J)/WAVE - 110 CONTINUE -C----------------------------------------------------------------------- -C Evaluate the determinant to decide if right or left handed -C----------------------------------------------------------------------- - DET = R(1,1)*(R(2,2)*R(3,3) - R(2,3)*R(3,2)) - - $ R(1,2)*(R(2,1)*R(3,3) - R(2,3)*R(3,1)) + - $ R(1,3)*(R(2,1)*R(3,2) - R(2,2)*R(3,1)) - IF (NRC*DET .EQ. 0) THEN - WRITE (COUT,12000) - KI = ' ' - ELSE IF (NRC*DET .GT. 0) THEN - WRITE (COUT,13000) KI,((RNEW(I,J),J = 1,3),I = 1,3) - ELSE - WRITE (COUT,14000) KI,((RNEW(I,J),J = 1,3),I = 1,3) - ENDIF - CALL GWRITE (ITP,' ') - CALL GETPAR - DO 120 I = 1,3 - AP(I) = AP(I)*WAVE - 120 CONTINUE - WRITE (COUT,15000) AP,CANG - CALL GWRITE (ITP,' ') - RETURN -10000 FORMAT (10X,' Transform the Orientation Matrix'/ - $ ' Type in old and new h,k,l values for 3 reflections') -11000 FORMAT (' Type old and new h,k,l for reflection',I2,' ',$) -11100 FORMAT (' 0,0,0 indices not allowed. Try again.') -12000 FORMAT (' The determinant of the matrix is 0.') -13000 FORMAT (' New RIGHT-handed Orientation Matrix from ',A2/(3F12.8)) -14000 FORMAT (' New LEFT-handed Orientation Matrix from ',A2/(3F12.8)) -15000 FORMAT (' New Unit Cell ',3F9.4,3F9.3) - END diff --git a/difrac/setrow.f b/difrac/setrow.f deleted file mode 100644 index e318a1e5..00000000 --- a/difrac/setrow.f +++ /dev/null @@ -1,184 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to set a specified direct lattice row:-- -C Along the Omega rotation axis (PR) or -C Along the x-ray beam (PL). -C----------------------------------------------------------------------- - SUBROUTINE SETROW - INCLUDE 'COMDIF' - DIMENSION HKL(3),DICOS(3),RM1(3,3),VEC(3) - IF (KI .EQ. 'PL') THEN - WRITE (COUT,10000) - ELSE - WRITE (COUT,11000) - ENDIF - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - WRITE (COUT,12000) - CALL FREEFM (ITR) - IH = IFREE(1) - IK = IFREE(2) - IL = IFREE(3) - HKL(1) = IH - HKL(2) = IK - HKL(3) = IL -C----------------------------------------------------------------------- -C The inverse transpose of the UB matrix of Busing and Levy (here R) -C allows Direct rather than Reciprocal rows to be set. -C----------------------------------------------------------------------- - 100 CALL MATRIX (R,RM1,CRAP,CRAP,'INVERT') - CALL MATRIX (HKL,RM1,DICOS,CRAP,'VECMAT') - PHI = ATAN(DICOS(2)/DICOS(1))*DEG - IF (DICOS(1) .LT. 0) PHI = PHI + 180.0 - CALL MOD360 (PHI) - CHI = ASIN(DICOS(3))*DEG -C----------------------------------------------------------------------- -C Bring the positive end of the row up (CHI = CHI + 90) -C----------------------------------------------------------------------- - IF (KI .EQ. 'PR') THEN - CALL MATRIX (HKL,RM1,VEC,CRAP,'VMMULT') - PER = WAVE*SQRT(VEC(1)*VEC(1) + VEC(2)*VEC(2)+ VEC(3)*VEC(3)) - WRITE (COUT,13000) PER - CALL FREEFM (ITR) - DIST = RFREE(1) - IF (DIST .NE. 0.) THEN - WRITE (COUT,14000) - CALL GWRITE (ITP,' ') - DO 110 N = 1,10 - DSIN = N*WAVE/PER - IF (DSIN .LE. 0.71) THEN - VEL = DIST*TAN(ASIN(DSIN)) - VEL = VEL*2 - WRITE (COUT,15000) N,VEL - CALL GWRITE (ITP,' ') - ENDIF - 110 CONTINUE - ENDIF - THETA = 0.0 - OMEGA = 0.0 - CHI = CHI + 90.0 - CALL MOD360(CHI) - ICC = 0 - WRITE (COUT,16000) THETA,OMEGA,CHI,PHI - CALL GWRITE (ITP,' ') - CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICOL) - IF (ICOL .NE. 0) THEN - WRITE (COUT,17000) - CALL GWRITE (ITP,' ') - ENDIF - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Set up for Laue photos PL -C A direct lattice row is set along the direct beam by :-- -C setting CHI = 90, PHI = PHI + 90 and OMEGA = CHI, but because of -C restrictions on the OMEGA motion, OMEGA may not be greater than OLIM. -C This means that the original CHI must be within OLIM degrees of the -C OMEGA axis -C----------------------------------------------------------------------- - CALL MOD360 (CHI) - OLIM = 47.0 - IF (CHI .GE. 180-OLIM .AND. CHI .LE. 180+OLIM) THEN - WRITE (COUT,18000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') THEN - IH = -IH - IK = -IK - IL = -IL - GO TO 100 - ENDIF - KI = ' ' - RETURN - ENDIF - IF (CHI .GT. OLIM .AND. CHI .LT. 360-OLIM) THEN - WRITE (COUT,19000) - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN - ENDIF - OMEGA = CHI - CHI = 90.0 - PHI = PHI + 90.0 - CALL MOD360 (PHI) - THETA = 0.0 - WRITE (COUT,20000) IH,IK,IL,THETA,OMEGA,CHI,PHI - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Find the azimuths of given reciprocal vectors -C----------------------------------------------------------------------- - ICC = 0 - CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICOL) - IF (ICOL .EQ. 0) THEN - WRITE (COUT,17000) - CALL GWRITE (ITP,' ') - KI = ' ' - RETURN - ENDIF -C----------------------------------------------------------------------- -C Direction cosines of the line along the vertical -C----------------------------------------------------------------------- - XU = COS((PHI)/DEG) - YU = SIN((PHI)/DEG) - ZU = 0. -C----------------------------------------------------------------------- -C Direction cosines of the line along the diffraction vector -C----------------------------------------------------------------------- - XD = COS((90.0 - OMEGA)/DEG)*COS((90.0 + PHI)/DEG) - YD = COS((90.0 - OMEGA)/DEG)*SIN((90.0 + PHI)/DEG) - ZD = SIN((90.0 - OMEGA)/DEG) - WRITE (COUT,21000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - WRITE (COUT,22000) - CALL GWRITE (ITP,' ') - 120 WRITE (COUT,23000) - CALL FREEFM (ITR) - IH = IFREE(1) - IK = IFREE(2) - IL = IFREE(3) - HKL(1) = IH - HKL(2) = IK - HKL(3) = IL - CALL MATRIX (R,HKL,DICOS,CRAP,'MATVEC') - SU = XU*DICOS(1) + YU*DICOS(2) + ZU*DICOS(3) - SD = XD*DICOS(1) + YD*DICOS(2) + ZD*DICOS(3) - SN = SQRT(SU*SU + SD*SD) - ANG = ACOS(SU/SN)*DEG - IF (SD .LT. 0) ANG = -ANG - WRITE (COUT,24000) ANG - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'Y') GO TO 120 - KI = ' ' - RETURN -10000 FORMAT (' Set for a Laue Pattern along a given row (Y) ? ',$) -11000 FORMAT (' Set a Direct Lattice Row upwards along the Omega', - $ ' Rotation Axis',/, - $ ' Confirm (Y) ',$) -12000 FORMAT (' Type the indices of the row ',$) -13000 FORMAT (' The Periodicity for a Primitive Lattice is ',F10.3, - $ ' Angstroms',/, - $ ' Type the Crystal-to-Film Distance in mms ',$) -14000 FORMAT (' Separation in mm between the + and - nth levels') -15000 FORMAT (5X,I2,F10.1) -16000 FORMAT (' Setting angles ',4F10.3) -17000 FORMAT (' Setting Collisions. The row cannot be set') -18000 FORMAT (' hkl CANNOT be set, but -h-k-l can. OK (Y) ? ',$) -19000 FORMAT (' The setting is NOT feasible') -20000 FORMAT (' Setting angles for row',3I4,4F10.3,/, - $ ' Set it (Y) ? ',$) -21000 FORMAT (' Are you interested in the azimuth for given reciprocal', - $ ' vectors. (Y) ? ',$) -22000 FORMAT (' Origin of azimuths UP, + toward diffraction vector.') -23000 FORMAT (' Type the h k l ',$) -24000 FORMAT (20X,'Azimuth ',F10.1,' degrees. More vectors (Y) ? ',$) - END diff --git a/difrac/sgerrs.f b/difrac/sgerrs.f deleted file mode 100644 index 70873338..00000000 --- a/difrac/sgerrs.f +++ /dev/null @@ -1,40 +0,0 @@ -C----------------------------------------------------------------------- -C Space group routine error message printing -C----------------------------------------------------------------------- - SUBROUTINE SGERRS (SGP,IER,LPTX) - CHARACTER COUT*132 - COMMON /IOUASC/ COUT(20) - DIMENSION SGP(10) - CHARACTER*52 ERRMSG(25),ERR1(12),ERR2(13) - EQUIVALENCE (ERRMSG(1),ERR1(1)),(ERRMSG(13),ERR2(1)) - DATA ERR1 /'Either a 5-axis anywhere or a 3-axis in field 4 ', - $ 'Less than 2 operator fields were found ', - $ 'Lattice operator was not a P, A, B, C, I, F or R ', - $ 'Rhombohedral lattice without a 3-axis ', - $ 'Minus sign does not precede 1, 2, 3, 4 or 6 ', - $ 'Lattice subroutine found an error ', - $ '1st operator in a field was a space. Impossible ', - $ 'Index for COMPUTED GO TO is out of range ', - $ 'An a-glide mirror normal to a ', - $ 'A b-glide mirror normal to b ', - $ 'A c-glide mirror normal to c ', - $ 'd-glide in a primitive lattice '/ - DATA ERR2 /'A 4-axis not in the 2nd operator field ', - $ 'A 6-axis not in the 2nd operator field ', - $ 'More than 24 matrices needed to define the group ', - $ 'More than 24 matrices needed to define the group ', - $ 'Improper construction of a rotation operator ', - $ 'No mirror following a / ', - $ 'A translation conflict between operators ', - $ 'The 2bar operator is not allowed ', - $ '3 fields are legal only in r lattices and m3 cubic ', - $ 'Syntax error. Expected I-43d at this point ', - $ ' ', - $ 'A or B centered tetragonal? Impossible!!!!! ', - $ 'No delimiter blanks in symbol. Try again. '/ - WRITE (COUT,10000) IER,SGP,ERRMSG(IER+1) - CALL GWRITE (LPTX,' ') - RETURN -10000 FORMAT (' Error no.',I3,' in processing space group symbol ', - $ 10A1/1X,A52) - END diff --git a/difrac/sglatc.f b/difrac/sglatc.f deleted file mode 100644 index 549c2734..00000000 --- a/difrac/sglatc.f +++ /dev/null @@ -1,656 +0,0 @@ -C----------------------------------------------------------------------- -C Space group lattice and operator interpretation -C----------------------------------------------------------------------- - SUBROUTINE SGLATC (K,L,D,LCENT,NCENT,LAUENO,NAXIS,LPT,IER,I209,ID) - DIMENSION D(3,3),L(4,4) - JUNK = LCENT - JUNK = LPT -C----------------------------------------------------------------------- -C Now let us determine the Laue group and unique axis if monoclinic -C----------------------------------------------------------------------- - IF ( K-3 ) 100,180,190 - 100 CONTINUE -C----------------------------------------------------------------------- -C Only 2 fields were read -C----------------------------------------------------------------------- - IF ( L(1,2) .EQ. 17 ) GO TO 120 - IF ( L(1,2) .EQ. 14 ) GO TO 130 - IF ( L(1,2) .EQ. 15 ) GO TO 140 - IF ( L(1,2) .EQ. 12 ) GO TO 170 -C----------------------------------------------------------------------- -C 2/m, b-axis unique -C----------------------------------------------------------------------- - IM = 2 - GO TO 350 - 110 CONTINUE -C----------------------------------------------------------------------- -C We have something like P 6n 1 * -C----------------------------------------------------------------------- - IF (L(1,4) .NE. 12) GO TO 460 - 120 CONTINUE -C----------------------------------------------------------------------- -C 6/m -C----------------------------------------------------------------------- - LAUENO = 11 - GO TO 620 - 130 CONTINUE -C----------------------------------------------------------------------- -C 3bar -C----------------------------------------------------------------------- - LAUENO = 8 - GO TO 620 - 140 CONTINUE -C----------------------------------------------------------------------- -C 4/m -C----------------------------------------------------------------------- - LAUENO = 4 -C----------------------------------------------------------------------- -C Is it I-centered or F-centered? -C----------------------------------------------------------------------- - IF (LCENT .GE. 5) GO TO 150 -C----------------------------------------------------------------------- -C Is it C-centered? -C----------------------------------------------------------------------- - IF (LCENT .EQ. 4) GO TO 160 -C----------------------------------------------------------------------- -C No. Is there an n-glide normal to c? -C----------------------------------------------------------------------- - IF (L(3,2) .EQ. 10) GO TO 520 - IF (L(4,2) .EQ. 10) D(2,3) = 0.5 -C----------------------------------------------------------------------- -C No. OK, let's get on with this. -C----------------------------------------------------------------------- - GO TO 620 - 150 CONTINUE -C----------------------------------------------------------------------- -C Is there either an a-glide or a d-glide normal to c? -C----------------------------------------------------------------------- - IF (L(4,2) .NE. 4 .AND. L(4,2) .NE. 11) GO TO 530 -C----------------------------------------------------------------------- -C Yes. -C----------------------------------------------------------------------- - D(1,3) = 0.75 - IF (LCENT .EQ. 5) D(2,3) = 0.25 - GO TO 620 - 160 CONTINUE -C----------------------------------------------------------------------- -C C-centered 4/m tetragonal -C If there is no a-glide normal to c we are through -C----------------------------------------------------------------------- - IF (L(3,2) .NE. 4 .AND. L(4,2) .NE. 4) GO TO 620 - D(1,3) = 0.25 - D(2,3) = 0.25 - IF (L(4,2) .EQ. 4) D(2,3) = 0.75 - GO TO 620 - 170 CONTINUE -C----------------------------------------------------------------------- -C 1bar -C----------------------------------------------------------------------- - LAUENO = 1 - GO TO 620 - 180 CONTINUE -C----------------------------------------------------------------------- -C 3 fields were read. Must be m3 cubic. (R3R has been taken care of) -C----------------------------------------------------------------------- - IF (L(1,3) .NE. 14) IER = 20 - IF (IER .GT. 0) GO TO 630 - LAUENO = 13 -C----------------------------------------------------------------------- -C Set the b-axis translation flag if a 21 along a -C----------------------------------------------------------------------- - IF (L(2,2) .EQ. 12) D(2,1) = 0.5 -C----------------------------------------------------------------------- -C Set the c-axis translation flag if an a-glide normal to c -C----------------------------------------------------------------------- - IF (L(1,2) .EQ. 3 .OR. L(1,2) .EQ. 4) D(3,3) = 0.5 - GO TO 610 -C----------------------------------------------------------------------- -C Four fields were read -C----------------------------------------------------------------------- - 190 IF (L(1,3) .EQ. 14) GO TO 390 -C----------------------------------------------------------------------- -C It is not cubic -C----------------------------------------------------------------------- - IF (L(1,2) .EQ. 17) GO TO 450 -C----------------------------------------------------------------------- -C It is not hexagonal -C----------------------------------------------------------------------- - IF (L(1,2) .EQ. 14) GO TO 470 -C----------------------------------------------------------------------- -C It is not trigonal -C----------------------------------------------------------------------- - IF (L(1,2) .EQ. 15) GO TO 480 -C----------------------------------------------------------------------- -C It is not tetragonal -C----------------------------------------------------------------------- - IF (L(1,2) .EQ. 12) GO TO 340 - IF (L(1,3) .EQ. 12) GO TO 360 -C----------------------------------------------------------------------- -C It may be orthorhombic -C----------------------------------------------------------------------- - 200 CONTINUE -C----------------------------------------------------------------------- -C It is orthorhombic -C----------------------------------------------------------------------- - LAUENO = 3 -C----------------------------------------------------------------------- -C Set up counts of the various types of mirrors. -C----------------------------------------------------------------------- - IM = 0 - IR = 0 - IA = 0 - IB = 0 - IC = 0 - ID = 0 - I21 = 0 -C----------------------------------------------------------------------- -C Do we have a 2-axis along a -C----------------------------------------------------------------------- - IF (L(1,2) .NE. 13) GO TO 210 -C----------------------------------------------------------------------- -C Yes, is it a 21? -C----------------------------------------------------------------------- - IF (L(2,2) .NE. 12) GO TO 220 - D(1,2) = 0.5 - D(1,3) = 0.5 - I21 = 4 - GO TO 220 - 210 CONTINUE - IR = 1 - IF (L(1,2) .EQ. 9) IM = 4 - IF (L(1,2) .EQ. 3) IB = 1 - IF (L(1,2) .EQ. 2) IC = 1 - IF (L(1,2) .EQ. 11) ID = 1 - IF (L(1,3) .EQ. 4 .OR. L(1,3) .EQ. 10) D(1,1) = 0.5 - IF (L(1,4) .EQ. 4 .OR. L(1,4) .EQ. 10) D(1,1) = D(1,1) + 0.5 - 220 CONTINUE -C----------------------------------------------------------------------- -C Do we have a 2-axis along b -C----------------------------------------------------------------------- - IF (L(1,3) .NE. 13) GO TO 230 -C----------------------------------------------------------------------- -C Yes, is it a 21? -C----------------------------------------------------------------------- - IF (L(2,3) .NE. 12) GO TO 240 - D(2,1) = 0.5 - D(2,3) = 0.5 - I21 = I21 + 2 - GO TO 240 - 230 CONTINUE - IR = IR + 1 - IF (L(1,3) .EQ. 9) IM = IM + 2 - IF (L(1,3) .EQ. 4) IA = 1 - IF (L(1,3) .EQ. 2) IC = IC + 1 - IF (L(1,3) .EQ. 11) ID = ID + 1 - IF (L(1,2) .EQ. 3 .OR. L(1,2) .EQ. 10) D(2,2) = 0.5 - IF (L(1,4) .EQ. 3 .OR. L(1,4) .EQ. 10) D(2,2) = D(2,2) + 0.5 - 240 CONTINUE -C----------------------------------------------------------------------- -C Do we have a 2-axis along c -C----------------------------------------------------------------------- - IF (L(1,4) .NE. 13) GO TO 250 -C----------------------------------------------------------------------- -C Yes, is it a 21? -C----------------------------------------------------------------------- - IF (L(2,4) .NE. 12) GO TO 260 - D(3,1) = 0.5 - D(3,2) = 0.5 - I21 = I21 + 1 - GO TO 260 - 250 CONTINUE - IR = IR + 1 - IF (L(1,4) .EQ. 9) IM = IM + 1 - IF (L(1,4) .EQ. 4) IA = IA + 1 - IF (L(1,4) .EQ. 3) IB = IB + 1 - IF (L(1,4) .EQ. 11) ID = ID + 1 - IF (L(1,2) .EQ. 2 .OR. L(1,2) .EQ. 10) D(3,3) = 0.5 - IF (L(1,3) .EQ. 2 .OR. L(1,3) .EQ. 10) D(3,3) = D(3,3) + 0.5 - 260 CONTINUE -C----------------------------------------------------------------------- -C If there are 3 mirrors check for centering, Which may alter the -C origin location -C----------------------------------------------------------------------- - IF (IR .EQ. 3) GO TO 300 -C----------------------------------------------------------------------- -C Less than 3 mirrors. Set up the 2-axes locations -C----------------------------------------------------------------------- - IF (I21 .EQ. 4 .OR. I21 .EQ. 5 .OR. I21 .EQ. 7) D(1,2) = 0.0 - IF (I21 .EQ. 6 .OR. I21 .EQ. 7) D(1,3) = 0.0 - IF (I21 .EQ. 3) D(2,1) = 0.0 - IF (I21 .EQ. 2 .OR. I21 .EQ. 6 .OR. I21 .EQ. 7) D(2,3) = 0.0 - IF (I21 .EQ. 1 .OR. I21 .EQ. 3 .OR. I21 .EQ. 7) D(3,1) = 0.0 - IF (I21 .EQ. 5) D(3,2) = 0.0 - IF (IM .LE. 0) GO TO 620 - IF (IM .EQ. 1 .AND. (I21 .EQ. 4 .OR. I21 .EQ. 2)) GO TO 270 - IF (IM .EQ. 2 .AND. (I21 .EQ. 4 .OR. I21 .EQ. 1)) GO TO 280 - IF (IM .EQ. 4 .AND. (I21 .EQ. 2 .OR. I21 .EQ. 1)) GO TO 290 - GO TO 620 - 270 CONTINUE - IF (D(3,3) .EQ. 0.0) GO TO 620 - D(3,3) = 0.0 - D(3,2) = D(3,2) + 0.5 - GO TO 620 - 280 CONTINUE - IF (D(2,2) .EQ. 0.0) GO TO 620 - D(2,2) = 0.0 - D(2,1) = D(2,1) + 0.5 - GO TO 620 - 290 CONTINUE - IF (D(1,1) .EQ. 0.0) GO TO 620 - D(1,1) = 0.0 - D(1,3) = D(1,3) + 0.5 - GO TO 620 - 300 CONTINUE -C----------------------------------------------------------------------- -C 3 mirrors present. Is the lattice centered? -C----------------------------------------------------------------------- - IF (LCENT .EQ. 1) GO TO 620 -C----------------------------------------------------------------------- -C Yes. Is it A-centered? -C----------------------------------------------------------------------- - IF (LCENT .EQ. 2) GO TO 310 -C----------------------------------------------------------------------- -C No. Is it B-centered? -C----------------------------------------------------------------------- - IF (LCENT .EQ. 3) GO TO 320 -C----------------------------------------------------------------------- -C No. Is it C-centered? -C----------------------------------------------------------------------- - IF (LCENT .EQ. 4) GO TO 330 -C----------------------------------------------------------------------- -C No. Is it I-centered? -C----------------------------------------------------------------------- - IF (LCENT .NE. 5) GO TO 620 -C----------------------------------------------------------------------- -C Yes. If only 1 glide plane, shift the mirrors by I -C----------------------------------------------------------------------- - IF (IA + IB + IC .NE. 1) GO TO 620 - D(1,1) = D(1,1) + 0.5 - D(2,2) = D(2,2) + 0.5 - D(3,3) = D(3,3) + 0.5 - GO TO 620 - 310 CONTINUE -C----------------------------------------------------------------------- -C An A-centered lattice. -C If only one b or c glide present relocate the mirrors by A -C----------------------------------------------------------------------- - IF (IB + IC .NE. 1) GO TO 620 - IF (IA .EQ. 2) GO TO 620 - D(2,2) = D(2,2) + 0.5 - D(3,3) = D(3,3) + 0.5 - GO TO 620 - 320 CONTINUE -C----------------------------------------------------------------------- -C A B-centered lattice -C----------------------------------------------------------------------- - IF (IA + IC .NE. 1) GO TO 620 - IF (IB .EQ. 2) GO TO 620 - D(1,1) = D(1,1) + 0.5 - D(3,3) = D(3,3) + 0.5 - GO TO 620 - 330 CONTINUE -C----------------------------------------------------------------------- -C A C-centered lattice -C----------------------------------------------------------------------- - IF (IA + IB .NE. 1) GO TO 620 - IF (IC .EQ. 2) GO TO 620 - D(1,1) = D(1,1) + 0.5 - D(2,2) = D(2,2) + 0.5 - GO TO 620 - 340 IF (L(1,3) .EQ. 12) GO TO 370 -C----------------------------------------------------------------------- -C It is not c-axis unique monoclinic -C----------------------------------------------------------------------- - IF (L(1,4) .NE. 12) GO TO 200 - IM = 3 - 350 CONTINUE -C----------------------------------------------------------------------- -C It is b-axis unique monoclinic. (full symbol used) -C----------------------------------------------------------------------- - LAUENO = 2 - NAXIS = 2 - IA = 4 - IC = 2 - NA = 1 - NB = 2 - NC = 3 - GO TO 380 - 360 IF (L(1,4) .NE. 12) GO TO 200 -C----------------------------------------------------------------------- -C It is a-axis unique monoclinic -C----------------------------------------------------------------------- - LAUENO = 2 - NAXIS = 1 - IA = 3 - IC = 2 - NA = 2 - NB = 1 - NC = 3 - IM = 2 - GO TO 380 - 370 IF (L(1,4) .EQ. 12) GO TO 170 -C----------------------------------------------------------------------- -C It is c-axis unique monoclinic -C----------------------------------------------------------------------- - LAUENO = 2 - NAXIS = 3 - IA = 4 - IC = 3 - NA = 1 - NB = 3 - NC = 2 - IM = 4 - 380 CONTINUE - IF (L(2,IM) .EQ. 12) D(NB,NAXIS) = 0.5 - IF (L(3,IM) .EQ. IA .OR. L(3,IM) .EQ. 10) D(NA,NAXIS) = 0.5 - IF (L(3,IM) .EQ. IC .OR. L(3,IM) .EQ. 10) D(NC,NAXIS) = 0.5 - IF (L(4,IM) .EQ. IA .OR. L(4,IM) .EQ. 10) D(NA,NAXIS) = 0.5 - IF (L(4,IM) .EQ. IC .OR. L(4,IM) .EQ. 10) D(NC,NAXIS) = 0.5 - GO TO 620 - 390 CONTINUE -C----------------------------------------------------------------------- -C It is m3m cubic -C----------------------------------------------------------------------- - LAUENO = 14 -C----------------------------------------------------------------------- -C Set the c-axis translation flag if an a-glide normal to c -C----------------------------------------------------------------------- - IF (L(1,2) .EQ. 3 .OR. L(1,2) .EQ. 4) D(3,3) = 0.5 -C----------------------------------------------------------------------- -C Is a 4n-axis specified -C----------------------------------------------------------------------- - IF (L(1,2) .NE. 15) GO TO 610 -C----------------------------------------------------------------------- -C Yes. Is it 4bar? -C----------------------------------------------------------------------- - IF (L(2,2) .EQ. 3) GO TO 400 -C----------------------------------------------------------------------- -C No. Is it a 4? -C----------------------------------------------------------------------- - IF (L(2,2) .LT. 12) GO TO 610 - IF (L(2,2) .GT. 14) GO TO 610 -C----------------------------------------------------------------------- -C No. Is it a 41? -C----------------------------------------------------------------------- - IF (L(2,2) .EQ. 12) GO TO 410 -C----------------------------------------------------------------------- -C No. Is it a 42? -C----------------------------------------------------------------------- - IF (L(2,2) .EQ. 13) GO TO 420 -C----------------------------------------------------------------------- -C No. It must be a 43 (P 43 3 2) -C----------------------------------------------------------------------- - IF (LCENT .EQ. 6) GO TO 430 - D(1,3) = 0.75 - D(2,3) = 0.25 - GO TO 610 - 400 CONTINUE -C----------------------------------------------------------------------- -C 4b. Is it 4b 3 m -C----------------------------------------------------------------------- - IF (L(1,4) .EQ. 9) GO TO 610 -C----------------------------------------------------------------------- -C No. Is it 4b 3 d? -C----------------------------------------------------------------------- - IF (L(1,4) .EQ. 11) GO TO 440 -C----------------------------------------------------------------------- -C No. -C----------------------------------------------------------------------- - D(1,3) = 0.5 - D(2,3) = 0.5 - D(3,3) = 0.5 - GO TO 610 - 410 CONTINUE -C----------------------------------------------------------------------- -C 41-axis. Is it F 41 3 2? -C----------------------------------------------------------------------- - IF (LCENT .EQ. 6) GO TO 430 -C----------------------------------------------------------------------- -C No. It is either P 41 3 2 or I 41 3 2 -C----------------------------------------------------------------------- - D(1,3) = 0.25 - D(2,3) = -0.25 - GO TO 610 - 420 CONTINUE -C----------------------------------------------------------------------- -C P 42 3 2 -C----------------------------------------------------------------------- - D(1,3) = 0.5 - D(2,3) = 0.5 - GO TO 610 - 430 CONTINUE -C----------------------------------------------------------------------- -C F 41 3 2 -C----------------------------------------------------------------------- - D(1,3) = 0.25 - D(2,3) = 0.25 - GO TO 610 - 440 CONTINUE -C----------------------------------------------------------------------- -C I 4b 3 d we hope -C----------------------------------------------------------------------- - IF (LCENT .NE. 5) IER = 21 - IF (IER .GT. 0) GO TO 630 - D(1,3) = 0.75 - D(2,3) = 0.25 - D(3,3) = 0.75 - GO TO 610 - 450 CONTINUE - IF (L(1,3) .EQ. 12) GO TO 110 - 460 CONTINUE -C----------------------------------------------------------------------- -C It is hexagonal 6/mmm -C----------------------------------------------------------------------- - LAUENO = 12 - GO TO 620 - 470 CONTINUE -C----------------------------------------------------------------------- -C It is trigonal p3** -C----------------------------------------------------------------------- - IF (L(1,3) .EQ. 12) GO TO 600 - IF (L(1,4) .NE. 12) GO TO 460 -C----------------------------------------------------------------------- -C It is trigonal 3m1 -C----------------------------------------------------------------------- - LAUENO = 9 - GO TO 620 - 480 CONTINUE -C----------------------------------------------------------------------- -C It is tetragonal 4/mmm -C----------------------------------------------------------------------- - LAUENO = 5 -C----------------------------------------------------------------------- -C If there is an n-glide normal to c put any mirror normal to a at 1/4 -C----------------------------------------------------------------------- - IF (L(3,2) .EQ. 10 .OR. L(4,2) .EQ. 10) D(1,1) = 0.5 -C----------------------------------------------------------------------- -C If there is an a-glide normal to c, put any mirror normal to (110) -C at 1/4 -C----------------------------------------------------------------------- - IF (L(3,2) .EQ. 4 .OR. L(4,2) .EQ. 4) D(2,2) = 0.25 -C----------------------------------------------------------------------- -C If there is a 21 along b, move it and place it at x=1/4 -C----------------------------------------------------------------------- - IF (L(1,3) .EQ. 13 .AND. L(2,3) .EQ. 12) D(1,2) = 0.5 -C----------------------------------------------------------------------- -C If there is a 21 along (110), move it and place it at x=1/4 -C If there is either a b- or n-glide normal to the a-axis -C shift the mirror by 1/4 along the a-axis -C----------------------------------------------------------------------- - IF (L(1,3) .EQ. 3 .OR. L(1,3) .EQ. 10) D(1,1) = D(1,1) + 0.5 -C----------------------------------------------------------------------- -C If there is either a b- or n-glide normal to (110) -C shift the mirror by 1/4 along the a-axis -C----------------------------------------------------------------------- - IF (L(1,4) .EQ. 3 .OR. L(1,4) .EQ. 10) D(2,2) = D(2,2) + 0.25 -C----------------------------------------------------------------------- -C Set the z location for 2-axes along (110) -C----------------------------------------------------------------------- - IF (L(2,2) .GT. 11 .AND. L(2,2) .LT. 15 .AND. L(2,3) .NE. 12) - $ D(3,1) = -(L(2,2) - 11)/4.0 -C----------------------------------------------------------------------- -C Set the z-translation for 21-axes along (110) -C----------------------------------------------------------------------- - IF (L(1,4) .EQ. 13 .AND. L(2,4) .NE. 12) GO TO 490 - IF (L(2,2) .GT. 11 .AND. L(2,2) .LT. 15) - $ D(3,1) = (L(2,2) - 11)/4.0 - 490 CONTINUE -C----------------------------------------------------------------------- -C Set the z-translation for 21-axes along b -C----------------------------------------------------------------------- - IF (L(1,3) .EQ. 13 .AND. L(2,3) .NE. 12) GO TO 500 - IF (L(2,2) .GT. 11 .AND. L(2,2) .LT. 15) - $ D(3,2) = (L(2,2) - 11)/4.0 - 500 CONTINUE -C----------------------------------------------------------------------- -C Place the d in F 4* d * at y=7/8 -C----------------------------------------------------------------------- - IF (L(1,3) + L(3,2) .EQ. 11 .AND. LCENT .EQ. 6) D(2,1) = 0.75 -C----------------------------------------------------------------------- -C Set position of m in F 4** * * at x=1/8 if there is a c along (110) -C----------------------------------------------------------------------- - IF (L(1,4) .EQ. 2 .AND. LCENT .EQ. 6) D(1,1) = 0.5 -C----------------------------------------------------------------------- -C Is this a 4bar? -C----------------------------------------------------------------------- - IF (L(2,2) .EQ. 3) GO TO 560 -C----------------------------------------------------------------------- -C Is the lattice primitive? -C----------------------------------------------------------------------- - IF (LCENT .GT. 1) GO TO 530 -C----------------------------------------------------------------------- -C Yes. Do we have a n-glide normal to c? -C----------------------------------------------------------------------- - IF (L(3,2) .EQ. 10 .OR. L(4,2) .EQ. 10) GO TO 520 -C----------------------------------------------------------------------- -C No. Do we have a 21 along b? -C----------------------------------------------------------------------- - IF (L(1,3) .EQ. 13 .AND. L(2,3) .EQ. 12) GO TO 510 -C----------------------------------------------------------------------- -C No. Do we have a n-glide normal to a? -C----------------------------------------------------------------------- - IF (L(1,3) .NE. 10) GO TO 620 - IF (L(2,2) .LE. 0) GO TO 620 - IF (L(2,2) .GT. 15) GO TO 620 - 510 CONTINUE - D(1,3) = 0.5 - D(2,3) = 0.5 - GO TO 620 - 520 CONTINUE -C----------------------------------------------------------------------- -C P 4n/n * * -C----------------------------------------------------------------------- - D(1,3) = 0.5 - GO TO 620 - 530 CONTINUE -C----------------------------------------------------------------------- -C Is the lattice I or F-centered? -C----------------------------------------------------------------------- - IF (LCENT .LT. 5) GO TO 550 -C----------------------------------------------------------------------- -C Yes. If there is a c along (110) place the d at y=1/4 -C----------------------------------------------------------------------- - IF (L(1,4) .EQ. 2) D(2,1) = D(2,1) + 0.5 -C----------------------------------------------------------------------- -C Is this I 41/a * * or F 41/d * * ? -C----------------------------------------------------------------------- - IF (L(4,2) .NE. 4 .AND. L(4,2) .NE. 11) GO TO 540 -C----------------------------------------------------------------------- -C Yes. -C----------------------------------------------------------------------- - D(1,3) = 0.25 - IF (LCENT .EQ. 5) D(2,3) = 0.75 - GO TO 620 - 540 CONTINUE -C----------------------------------------------------------------------- -C Is there a 41 present? -C----------------------------------------------------------------------- - IF (L(2,2) .NE. 12) GO TO 620 -C----------------------------------------------------------------------- -C Yes. If F-centered go to 580 -C----------------------------------------------------------------------- - IF (LCENT .EQ. 6) GO TO 580 - D(2,3) = 0.5 -C----------------------------------------------------------------------- -C Set the b-axis translation flags for I 41 2 2 -C----------------------------------------------------------------------- - GO TO 570 - 550 CONTINUE -C----------------------------------------------------------------------- -C Is the lattice C-centered? -C----------------------------------------------------------------------- - IF (LCENT .NE. 4) IER = 23 - IF (IER .GT. 0) GO TO 630 -C----------------------------------------------------------------------- -C C-centered. An a normal to c -C----------------------------------------------------------------------- - IF (L(3,2) .EQ. 4 .OR. L(4,2) .EQ. 4) GO TO 590 - IF (D(1,1) .EQ. 0.0) D(1,1) = 2.0*D(2,2) -C----------------------------------------------------------------------- -C Is there a 21 on the diagonal? -C----------------------------------------------------------------------- - IF (L(1,4) .EQ. 13 .AND. L(2,4) .EQ. 12) GO TO 520 - IF (L(2,2) .LE. 0) GO TO 620 -C----------------------------------------------------------------------- -C Is there a n-glide normal to (110)? -C----------------------------------------------------------------------- - IF (L(1,4) .NE. 10) GO TO 620 - IF (L(2,2) .GT. 15) GO TO 620 - D(1,1) = D(1,1) - 2.0*D(2,2) - GO TO 520 - 560 CONTINUE -C----------------------------------------------------------------------- -C Account for translations due to diagonal symmetry operation -C If F 4b d 2 we want the 2 at z=1/8 -C----------------------------------------------------------------------- - IF (L(1,3) .EQ. 11 .AND. LCENT .EQ. 6) D(3,1) = 0.25 -C----------------------------------------------------------------------- -C If * 4b * 21 we want the mirror at x=1/4 -C----------------------------------------------------------------------- - IF (L(1,4) .EQ. 13 .AND. L(2,4) .EQ. 12) D(1,1) = 0.5 -C----------------------------------------------------------------------- -C If there is a c- or a n-glide along (110) set the 2-axis at z=1/4 -C----------------------------------------------------------------------- - IF (L(1,4) .EQ. 2 .OR. L(1,4) .EQ. 10) D(3,2) = 0.5 -C----------------------------------------------------------------------- -C If there is a b- or a n-glide along (110) set the 2 at x=1/4 -C----------------------------------------------------------------------- - IF (L(1,4) .EQ. 3 .OR. L(1,4) .EQ. 10) D(1,2) = 0.5 - IF (L(1,4) .NE. 11) GO TO 620 - 570 CONTINUE - IF (LCENT .EQ. 5) D(1,2) = 0.5 - D(3,2) = 0.75 - GO TO 620 - 580 CONTINUE -C----------------------------------------------------------------------- -C F 41 * * -C----------------------------------------------------------------------- - D(1,3) = 0.25 - D(2,3) = 0.75 - GO TO 620 - 590 CONTINUE -C----------------------------------------------------------------------- -C C 4*/a * * -C----------------------------------------------------------------------- - D(1,3) = 0.25 - D(2,3) = 0.25 - IF (L(1,4) .EQ. 3 .OR. L(1,4) .EQ. 10) D(1,1) = 0.5 - GO TO 620 - 600 CONTINUE -C----------------------------------------------------------------------- -C It is trigonal 31* -C----------------------------------------------------------------------- - IF (L(1,4) .EQ. 12) GO TO 130 -C----------------------------------------------------------------------- -C It is trigonal 31m -C----------------------------------------------------------------------- - LAUENO = 10 - GO TO 620 - 610 CONTINUE - I209 = 1 - 620 CONTINUE - RETURN - 630 CONTINUE - IF (IER .EQ. 0) IER = 5 - RETURN - END diff --git a/difrac/sglpak.f b/difrac/sglpak.f deleted file mode 100644 index 5a19100e..00000000 --- a/difrac/sglpak.f +++ /dev/null @@ -1,11 +0,0 @@ -C----------------------------------------------------------------------- -C Convert to standard working notation -C----------------------------------------------------------------------- - SUBROUTINE SGLPAK (L,IER) - DIMENSION L(4) - IF ( L(2) .LT. 12 ) IER = 4 - IF (L(2) .GT. 17) IER = 4 - L(1) = L(2) - L(2) = 3 - RETURN - END diff --git a/difrac/sgmtml.f b/difrac/sgmtml.f deleted file mode 100644 index 5814ca03..00000000 --- a/difrac/sgmtml.f +++ /dev/null @@ -1,23 +0,0 @@ -C----------------------------------------------------------------------- -C 4*4 matrix multiply for the space group routine -C----------------------------------------------------------------------- - SUBROUTINE SGMTML (X,I,Y,J,Z,K) - DIMENSION X(5,4,24),Y(5,4,24),Z(5,4,24) - DO 100 L = 1,4 - DO 100 M = 1,4 - Z(L,M,K) = 0.0 - DO 100 N = 1,4 - Z(L,M,K) = Z(L,M,K) + Y(L,N,J)*X(N,M,I) - 100 CONTINUE - Z(1,4,K) = AMOD(5.0 + Z(1,4,K),1.0) - Z(2,4,K) = AMOD(5.0 + Z(2,4,K),1.0) - Z(3,4,K) = AMOD(5.0 + Z(3,4,K),1.0) - Z(5,1,K) = 81*(2*Z(1,1,K) + 3*Z(1,2,K) + 4*Z(1,3,K)) + - $ 9*(2*Z(2,1,K) + 3*Z(2,2,K) + 4*Z(2,3,K)) + - $ 2*Z(3,1,K) + 3*Z(3,2,K) + 4*Z(3,3,K) - Z(5,2,K) = 1728*Z(1,4,K) + 144*Z(2,4,K) + 12*Z(3,4,K) - Z(5,3,K) = 0.0 - Z(5,4,K) = 0.0 - CONTINUE - RETURN - END diff --git a/difrac/sgprnh.f b/difrac/sgprnh.f deleted file mode 100644 index 422970dc..00000000 --- a/difrac/sgprnh.f +++ /dev/null @@ -1,125 +0,0 @@ -C----------------------------------------------------------------------- -C Space group routine printing -C----------------------------------------------------------------------- - SUBROUTINE SGPRNT (SPG,JRT,LAUENO,NAXIS,NCENT,LCENT,NSYM,NPOL,CEN, - $ NCV,LPT) - CHARACTER COUT*132 - COMMON /IOUASC/ COUT(20) - DIMENSION SPG(10),JRT(3,4,25),CEN(3,4),NCVT(7),CENV(3,6),NSYS(14) - CHARACTER*3 POLAR(8) - CHARACTER*4 LTYP(3,7),SYST(3,8),LAUE(2,14) - CHARACTER*1 NAX(3),NC(2) - CHARACTER CHKL(3)*2,CTEM*4,OUTL(3)*20 - DATA CHKL/'+h','+k','+l'/ - DATA LTYP/' Pr','imit','ive ', - $ ' A-C','ente','red ',' B-C','ente','red ', - $ ' C-C','ente','red ',' I-C','ente','red ', - $ ' F-C','ente','red ',' R-C','ente','red '/ - DATA SYST/'Tric','lini','c ','Mono','clin','ic ', - $ 'Orth','orho','mbic','Tetr','agon','al ', - $ 'Rhom','bohe','dral','Trig','onal',' ', - $ 'Hexa','gona','l ','Cubi','c ',' '/ - DATA LAUE/'1bar',' ','2/m ',' ','mmm ',' ','4/m ',' ', - $ '4/mm','m ','3bar',' ','3bar',' M ','3bar',' ', - $ '3bar','m 1 ','3bar','1 m ','6/m ',' ','6/mm','m ', - $ 'M 3 ',' ','M 3 ','M '/ - DATA POLAR/'x','y','x y','z','x z','y z','xyz','111'/ - DATA NAX/'a','b','c'/ - DATA NSYS/1,2,3,4,4,5,5,6,6,6,7,7,8,8/ - DATA NC/'A',' '/ - DATA NCVT/1,2,2,2,2,4,3/ - DATA CENV/ 0,0.5,0.5, 0.5,0,0.5, 0.5,0.5,0, 0.5,0.5,0.5, - $ 0.3333333,0.6666667,0.6666667,0.6666667,0.3333333,0.3333333/ - NCV = NCVT(LCENT) - MULT = NCV*NSYM*(NCENT + 1) - LSYS = NSYS(LAUENO) - DO 90 I = 1,3 - CEN(I,1) = 0.0 - OUTL(I) = ' ' - 90 CONTINUE - IF (NCV .LE. 1) GO TO 110 - J = LCENT - 1 - IF (LCENT .EQ. 6) J = 1 - IF (LCENT .EQ. 7) J = 5 - DO 100 I = 2,NCV - CEN(1,I) = CENV(1,J) - CEN(2,I) = CENV(2,J) - CEN(3,I) = CENV(3,J) - J = J + 1 - 100 CONTINUE - 110 CONTINUE - NPX = 1 - NPY = 2 - NPZ = 4 - NPXYZ = 0 - NPYXZ = 1 - DO 120 I = 1,NSYM - IF (JRT(1,1,I) .LE. 0) NPX = 0 - IF (JRT(2,2,I) .LE. 0) NPY = 0 - IF (JRT(3,3,I) .LE. 0) NPZ = 0 - IF (JRT(1,3,I) .GT. 0) NPXYZ = 8 - IF (JRT(1,3,I) .LT. 0) NPYXZ = 0 - 120 CONTINUE - NPOL = (NPX + NPY + NPZ + NPXYZ*NPYXZ)*(1 - NCENT) - IF (LPT .LT. 0) RETURN - WRITE (COUT,10000) SPG,NC(NCENT + 1), - $ LTYP(1,LCENT),LTYP(2,LCENT),LTYP(3,LCENT), - $ SYST(1,LSYS),SYST(2,LSYS),SYST(3,LSYS), - $ LAUE(1,LAUENO),LAUE(2,LAUENO),MULT - CALL GWRITE (LPT,' ') - IF (NAXIS .GT. 0) THEN - WRITE (COUT,11000) NAX(NAXIS) - CALL GWRITE (LPT,' ') - ENDIF - IF (NPOL .GT. 0) THEN - WRITE (COUT,12000) POLAR(NPOL) - CALL GWRITE (LPT,' ') - ENDIF - WRITE (COUT,13000) - CALL GWRITE (LPT,' ') - KI = 0 - KL = 2 - IF (LAUENO .GT. 5) KL = 3 - DO 140 I = 1,NSYM - KI = KI + 1 - DO 135 J = 1,3 - L = 1 - CTEM = ' ' - DO 130 K = 1,3 - IF (JRT(K,J,I) .NE. 0) THEN - CTEM(L:L+1) = CHKL(K) - IF (JRT(K,J,I) .EQ. -1) CTEM(L:L) = '-' - L = L + 2 - ENDIF - 130 CONTINUE - IF (CTEM(1:1) .EQ. '+') CTEM(1:1) = ' ' - MC = L - 1 - M = 1 + 6*(J - 1) + 4 - MC - OUTL(KI)(M:M+MC-1) = CTEM(1:MC) - 135 CONTINUE - IF (KI .EQ. KL) THEN - WRITE (COUT,15000) (OUTL(K),K = 1,KL) - CALL GWRITE (LPT,' ') - KI = 0 - DO 137 K = 1,3 - OUTL(K) = ' ' - 137 CONTINUE - ENDIF - 140 CONTINUE - IF (LAUENO .EQ. 1) THEN - WRITE (COUT,15000) (OUTL(I),I = 1,3) - CALL GWRITE (LPT,' ') - ENDIF - WRITE (COUT,14000) - CALL GWRITE (LPT,' ') - RETURN -10000 FORMAT (/' Space Group ',10A1/ - $ ' The Space Group is ',A1,'Centric',6A4, - $ ' Laue Symmetry ',2A4/ - $ ' Multiplicity of a General Site is',I4) -11000 FORMAT (' The Unique Axis is ',A1) -12000 FORMAT (' The location of the origin is arbitrary in ',A3) -13000 FORMAT (/' Space-group Equivalent Reflections are:') -14000 FORMAT (' Friedel Reflections are the -,-,- of these.'/'%') -15000 FORMAT (5X,3(A20,3X)) - END diff --git a/difrac/sgrmat.f b/difrac/sgrmat.f deleted file mode 100644 index 8fa5c7d7..00000000 --- a/difrac/sgrmat.f +++ /dev/null @@ -1,30 +0,0 @@ -C----------------------------------------------------------------------- -C Space group routine setup of the r-matrix -C----------------------------------------------------------------------- - SUBROUTINE SGRMAT (RT,A,B,C,D,E,F,G,H,O) - INTEGER A,B,C,D,E,F,G,H,O - DIMENSION RT(5,4) - RT(1,1) = A - RT(1,2) = B - RT(1,3) = C - RT(1,4) = 0.0 - RT(2,1) = D - RT(2,2) = E - RT(2,3) = F - RT(2,4) = 0.0 - RT(3,1) = G - RT(3,2) = H - RT(3,3) = O - RT(3,4) = 0.0 - RT(4,1) = 0.0 - RT(4,2) = 0.0 - RT(4,3) = 0.0 - RT(4,4) = 1.0 - RT(5,1) = 81*(2*RT(1,1) + 3*RT(1,2) + 4*RT(1,3)) + - $ 9*(2*RT(2,1) + 3*RT(2,2) + 4*RT(2,3)) + - $ 2*RT(3,1) + 3*RT(3,2) + 4*RT(3,3) - RT(5,2) = 1728*RT(1,4) + 144*RT(2,4) + 12*RT(3,4) - RT(5,3) = 10.0 - RT(5,4) = 20. - RETURN - END diff --git a/difrac/sgroup.f b/difrac/sgroup.f deleted file mode 100644 index a75238bb..00000000 --- a/difrac/sgroup.f +++ /dev/null @@ -1,561 +0,0 @@ -C----------------------------------------------------------------------- -C Main Routine for the Space Group Symbol Interpreter -C -C Adapted from the LASL routine by Allen C. Larson -C----------------------------------------------------------------------- - SUBROUTINE SGROUP (SPG,LAUENO,NAXIS,NCENT,LCENT,NSYM,NPOL,JRT, - $ CEN,NCV,LPT,LPTX,RT) -C----------------------------------------------------------------------- -C This subroutine interprets the Hermann-Mauguin space group symbol. -C -C Data in the calling sequence are -C SGP Input. Ten words containing the space group symbol 10A1 -C **NOTE** Vol. A of Int Tab uses different symbols for cubic -C 2-July-87 space groups with -3 axes, -C i.e. P n -3 n instead of P n 3 n. -C The routine changes the symbol to the old form for -C interpretation, but prints the new form. -C LAUENO Output. The Laue group number -C 1 = 1bar, 2 = 2/m, 3 = mmm, 4 = 4/m, 5 = 4/mm, -C 6 = R3R, 7 = R3mR, 8 = 3, 9 = 31m, 10 = 3m1, -C 11 = 6/m, 12 = 6/mmm, 13 = m3, 14 = m3m -C NAXIS Output. Unique axis in monoclinic space groups. -C Set to 4 on error exits -C NCENT Output. 1bar flag (0/1) for (acentric/centric) -C LCENT Output. Lattice centering number -C 1=P, 2=A, 3=B, 4=C, 5=I, 6=F and 7=R -C NSYM Output. The number of matrices generated (24 max), -C NCV*(NCENT+1)*NSYM = 192 (max) -C JRT Output. The NSYM (3,4,NSYM) matrices -C CEN Output. The lattice centering vectors -C NCV Output. The number of lattice centering vectors -C LPT Output listing device for normal output. -C If .lt. 0 no listing will be produced -C LPTX Output listing device for error listings -C If .lt. 0 no listing will be produced -C RT scratch array of 500 words needed by SGROUP -C----------------------------------------------------------------------- - DIMENSION SPG(10),JRT(3,4,24),CEN(3,4) - DIMENSION RT(5,4,25),D(3,3),L(4,4),LCEN(7) - CHARACTER*1 CHR(25),CHAR - CHARACTER*10 CSPG -C----------------------------------------------------------------------- -C C B A P F I R -C----------------------------------------------------------------------- - DATA LCEN/4,3,2,1,6,5,7/ -C----------------------------------------------------------------------- -C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 -C 15 16 17 18 19 20 21 -C----------------------------------------------------------------------- - DATA CHR/' ','C','B','A','P','F','I','R','M','N','D','1','2','3', - $ '4','5','6','-','/','H','.','0','0','0','0'/ - DO 100 I = 1,4 - DO 100 J = 1,4 - L(J,I) = 0 - 100 CONTINUE - WRITE (CSPG,10000) SPG -C----------------------------------------------------------------------- -C Check that there are blanks in the symbol, so that it has at least a -C sporting chance of being interpreted correctly -C----------------------------------------------------------------------- - DO 1012 I = 1,10 - J = 11 - I - IF (CSPG(J:J) .NE. ' ') THEN - DO 1010 K = 2,J - IF (CSPG(K:K) .EQ. ' ') GO TO 1014 - 1010 CONTINUE - ENDIF - 1012 CONTINUE - IER = 24 - GO TO 710 -C----------------------------------------------------------------------- -C Change the symbol for the cubic cases. EJG 2-July-87 -C If the -3 symbol is preceded by a second kind symmetry element, -C m, n, a, b, c or d then change -3 to 3 -C----------------------------------------------------------------------- - 1014 DO 104 J = 1,9 - IF (CSPG(J:J + 1) .EQ. '-3') THEN - DO 102 JJ = 1,J - 1 - K = J - JJ - CHAR = CSPG(K:K) - IF (CHAR .EQ. ' ') GO TO 102 - IF (CHAR .EQ. 'M' .OR. CHAR .EQ. 'N' .OR. - $ CHAR .EQ. 'D' .OR. CHAR .EQ. 'A' .OR. - $ CHAR .EQ. 'B' .OR. CHAR .EQ. 'C') THEN - CSPG(J:9) = CSPG(J + 1:10) - CSPG(10:10) = ' ' - GO TO 106 - ENDIF - 102 CONTINUE - ENDIF - 104 CONTINUE - 106 K = 0 - M = 0 - IER = 0 - NCENT = 0 - LAUENO = 0 - NAXIS = 0 - IERX = 0 - N = 0 -C----------------------------------------------------------------------- -C Break the space group symbol into the 4 fields as numerical values -C for manipulation -C----------------------------------------------------------------------- - DO 140 J = 1,10 - DO 110 I = 1,21 - IF (CSPG(J:J) .EQ. CHR(I)) GO TO 120 - 110 CONTINUE - GO TO 140 - 120 IF (K + M + I .EQ. 1) GO TO 140 - IF (I .EQ. 1) GO TO 130 - IF (M .EQ. 0) K = K + 1 - M = M + 1 - L(M,K) = I - IF (I .LT. 12) GO TO 130 - IF (M - 4) 140,130,130 - 130 CONTINUE - M = 0 - IF (K .GT. 3) GO TO 150 - 140 CONTINUE -C----------------------------------------------------------------------- -C If only 1 field was found, there is an error. Go to 710 -C----------------------------------------------------------------------- - 150 IF (K .LE. 1) IER = 1 - IF (IER .GT. 0) GO TO 710 -C----------------------------------------------------------------------- -C If the first character was not P, A, B, C, F, I or R Error. -C----------------------------------------------------------------------- - IF (L(1,1) .GT. 8) IER = 2 - IF (IER .GT. 0) GO TO 710 -C----------------------------------------------------------------------- -C Convert the -n notation to the nb(ar) notation -C----------------------------------------------------------------------- - IF (L(1,2) .EQ. 18) CALL SGLPAK (L(1,2),IER) - IF (IER .GT. 0) GO TO 710 - IF (L(1,3) .EQ. 18) CALL SGLPAK (L(1,3),IER) - IF (IER .GT. 0) GO TO 710 - IF (L(1,4) .EQ. 18) CALL SGLPAK (L(1,4),IER) - IF (IER .GT. 0) GO TO 710 -C----------------------------------------------------------------------- -C Set the matrix count N to 2 -C----------------------------------------------------------------------- - N = 2 -C----------------------------------------------------------------------- -C Set the translation flags -C----------------------------------------------------------------------- - D(1,1) = 0.0 - D(1,2) = 0.0 - D(1,3) = 0.0 - D(2,1) = 0.0 - D(2,2) = 0.0 - D(2,3) = 0.0 - D(3,1) = 0.0 - D(3,2) = 0.0 - D(3,3) = 0.0 -C----------------------------------------------------------------------- -C Set the lattice centering flag. 1=P, 2=A, 3=B, 4=C, 5=I, 6=F, 7=R -C----------------------------------------------------------------------- - LCENT = L(1,1) - 1 - LCENT = LCEN(LCENT) - IF (LCENT .NE. 7) GO TO 170 -C----------------------------------------------------------------------- -C Rhombohedral lattice. Make sure that there is a 3-axis. -C----------------------------------------------------------------------- - IF (L(1,2) .NE. 14) IER = 3 - IF (IER .GT. 0) GO TO 710 - IF (L(1,K) .EQ. 8) GO TO 160 -C----------------------------------------------------------------------- -C Hexagonal axes. Retain R centering and set LAUENO to 8 or 9 -C----------------------------------------------------------------------- - IF (L(1,K) .EQ. 20) K = K - 1 - LAUENO = K + 6 - GO TO 190 - 160 CONTINUE -C----------------------------------------------------------------------- -C Rhombohedral axes. Delete R centering and set LAUENO to 6 or 7 -C----------------------------------------------------------------------- - LCENT = 1 - K = K - 1 - LAUENO = K + 4 - GO TO 180 - 170 CONTINUE -C----------------------------------------------------------------------- -C Call SGLATC to determine LAUENO and some preliminary data -C----------------------------------------------------------------------- - IER = 0 - I209 = 0 - CALL SGLATC (K,L,D,LCENT,NCENT,LAUENO,NAXIS,LPT,IER,I209,ID) - IF (IER .GT. 0) GO TO 710 - IF (I209 .EQ. 0) GO TO 190 - 180 CONTINUE -C----------------------------------------------------------------------- -C Cubic or rhombohedral cell. Insert the 3-fold axis -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,2),0,1,0,0,0,1,1,0,0) - CALL SGRMAT (RT(1,1,3),0,0,1,1,0,0,0,1,0) - N = 4 - 190 CONTINUE - CALL SGRMAT (RT,1,0,0,0,1,0,0,0,1) -C----------------------------------------------------------------------- -C Decode the last 3 fields of the symbol -C----------------------------------------------------------------------- - DO 680 M = 2,K - IF (L(1,M) .EQ. 0) IER = 6 - IF (IER .GT. 0) GO TO 710 - I = IABS(L(1,M) - 5) - 200 IF (I .LE. 0 .OR. I .GT. 15) IER = 7 - IF (IER .GT. 0) GO TO 710 - NXI = N -C----------------------------------------------------------------------- -C A B C M N D 1 2 3 4 5 6 - / -C H -C----------------------------------------------------------------------- - GO TO (210,210,210,210,210,330,390,400,500,520,710,540,560,560, - $ 560),I - 210 CONTINUE -C----------------------------------------------------------------------- -C A mirror is needed -C A B C axis -C----------------------------------------------------------------------- - GO TO (710,220,240,260),M - 220 CONTINUE - IF (LAUENO .GT. 3) GO TO 270 - IF (K .EQ. 2) GO TO 250 - 230 CONTINUE - IF (I .EQ. 1) IER = 8 - IF (IER .GT. 0) GO TO 710 -C----------------------------------------------------------------------- -C An A-axis mirror -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),-1,0,0,0,1,0,0,0,1) - RT(1,4,N) = D(1,1) - IF (I .EQ. 2 .OR. I .EQ. 5) RT(2,4,N) = 0.5 - IF (I .EQ. 3 .OR. I .EQ. 5) RT(3,4,N) = 0.5 - GO TO 560 - 240 IF (L(1,2) .EQ. 14 .OR. L(1,2) .EQ. 17) GO TO 310 -C----------------------------------------------------------------------- -C It is not trigonal or hexagonal -C----------------------------------------------------------------------- - IF (L(1,2) .EQ. 15) GO TO 230 -C----------------------------------------------------------------------- -C It is not tetragonal -C----------------------------------------------------------------------- - 250 CONTINUE - IF (I .EQ. 2) IER = 9 - IF (IER .GT. 0) GO TO 710 -C----------------------------------------------------------------------- -C A B-axis mirror -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),1,0,0,0,-1,0,0,0,1) - RT(2,4,N) = D(2,2) - IF (I .EQ. 1 .OR. I .EQ. 5) RT(1,4,N) = 0.5 - IF (I .EQ. 3 .OR. I .EQ. 5) RT(3,4,N) = 0.5 - GO TO 560 - 260 IF (L(1,3) .EQ. 14 .OR. L(1,2) .EQ. 15) GO TO 280 -C----------------------------------------------------------------------- -C It is not cubic or tetragonal -C----------------------------------------------------------------------- - IF (L(1,2) .EQ. 14 .OR. L(1,2) .EQ. 17) GO TO 280 -C----------------------------------------------------------------------- -C It is not trigonal or hexagonal -C----------------------------------------------------------------------- - 270 CONTINUE - IF (I .EQ. 3) IER = 10 - IF (IER .GT. 0) GO TO 710 -C----------------------------------------------------------------------- -C A C-axis mirror -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),1,0,0,0,1,0,0,0,-1) - RT(3,4,N) = D(3,3) - IF (I .EQ. 1 .OR. I .EQ. 5) RT(1,4,N) = 0.5 - IF (I .EQ. 2 .OR. I .EQ. 5) RT(2,4,N) = 0.5 - IF (M .NE. 2 .OR. L(1,2) .NE. 17) GO TO 560 -C----------------------------------------------------------------------- -C If this is a 63-axis, the mirror is at 1/4 -C----------------------------------------------------------------------- - IF (L(2,2) .EQ. 14) RT(3,4,N) = 0.5 - GO TO 560 - 280 CONTINUE -C----------------------------------------------------------------------- -C A diagonal mirrror perpendicular to -110 -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),0,1,0,1,0,0,0,0,1) - RT(1,4,N) = D(2,2) - RT(2,4,N) = -D(2,2) - IF (I .EQ. 3 .OR. I .EQ. 5) RT(3,4,N) = 0.5 - IF (LAUENO .EQ. 7 .AND. I .EQ. 3) GO TO 290 - IF (I .EQ. 3 .OR. I .EQ. 4) GO TO 560 - 290 CONTINUE - IF (LCENT .EQ. 6 .OR. LCENT .EQ. 4) GO TO 300 - RT(1,4,N) = 0.5 + RT(1,4,N) - RT(2,4,N) = 0.5 + RT(2,4,N) - GO TO 560 - 300 CONTINUE -C----------------------------------------------------------------------- -C Either F- or C-centered tetragonal. Glides are 1/4,1/4 -C----------------------------------------------------------------------- - RT(1,4,N) = 0.25 + RT(1,4,N) - RT(2,4,N) = 0.25 + RT(2,4,N) - GO TO 560 - 310 CONTINUE - IF (LAUENO .EQ. 7) GO TO 280 -C----------------------------------------------------------------------- -C Mirror normal to (1000) in hex cell -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),-1,1,0,0,1,0,0,0,1) - IF (I .EQ. 3) RT(3,4,N) = 0.5 - 320 CONTINUE - GO TO 560 -C----------------------------------------------------------------------- -C D type mirror -C----------------------------------------------------------------------- - 330 CONTINUE - IF (LCENT .LE. 1) IER = 11 - IF (IER .GT. 0) GO TO 710 - GO TO (710,340,350,360),M - 340 IF (LAUENO .GT. 3) GO TO 370 - IF (K .EQ. 2) GO TO 350 - CALL SGRMAT (RT(1,1,N),-1,0,0,0,1,0,0,0,1) - IF (ID .EQ. 2) RT(1,4,N) = 0.25 - RT(2,4,N) = 0.25 - RT(3,4,N) = 0.25 - GO TO 560 - 350 CONTINUE - CALL SGRMAT (RT(1,1,N),1,0,0,0,-1,0,0,0,1) - RT(1,4,N) = 0.25 - IF (ID .EQ. 2) RT(2,4,N) = 0.25 - IF (LAUENO .EQ. 5) RT(2,4,N) = D(2,1) - RT(3,4,N) = 0.25 - GO TO 560 - 360 IF (L(1,2) .EQ. 15 .OR. L(1,3) .EQ. 14) GO TO 380 -C----------------------------------------------------------------------- -C It is not tetragonal or cubic -C----------------------------------------------------------------------- - 370 CONTINUE - CALL SGRMAT (RT(1,1,N),1,0,0,0,1,0,0,0,-1) - RT(1,4,N) = 0.25 - RT(2,4,N) = 0.25 - IF (ID .EQ. 2) RT(3,4,N) = 0.25 - GO TO 560 - 380 CONTINUE -C----------------------------------------------------------------------- -C Cubic or tetragonal. D-glide along diagonal -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),0,1,0,1,0,0,0,0,1) - RT(1,4,N) = 0.25 - RT(2,4,N) = 0.25 - RT(3,4,N) = 0.25 - IF (L(1,3) .NE. 13) GO TO 320 - RT(1,4,N) = 0.0 - RT(2,4,N) = 0.5 - GO TO 560 -C----------------------------------------------------------------------- -C 1 fold rotation -C----------------------------------------------------------------------- - 390 IF (L(2,M) .NE. 3) GO TO 680 -C----------------------------------------------------------------------- -C A center of symmetry -C----------------------------------------------------------------------- - NCENT = 1 - GO TO 680 -C----------------------------------------------------------------------- -C 2 fold rotation axis -C----------------------------------------------------------------------- - 400 CONTINUE -C----------------------------------------------------------------------- -C Do not allow a -2 axis. -C----------------------------------------------------------------------- - IF (L(2,M) .EQ. 3) IER = 19 - IF (IER .GT. 0) GO TO 710 - GO TO (710,410,420,440),M - 410 IF (K .EQ. 2) GO TO 430 - CONTINUE -C----------------------------------------------------------------------- -C Rotation about the a-axis. (orthogonal cell) -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),1,0,0,0,-1,0,0,0,-1) - RT(2,4,N) = D(2,1) - RT(3,4,N) = D(3,1) - IF (IABS(L(2,M) - 13) .EQ. 1) RT(1,4,N) = 0.5 - GO TO 560 - 420 CONTINUE - IF (L(1,2) .EQ. 14) GO TO 460 - IF (L(1,2) .EQ. 17) GO TO 450 -C----------------------------------------------------------------------- -C It is not a hexagonal or trigonal space group -C----------------------------------------------------------------------- - 430 CONTINUE -C----------------------------------------------------------------------- -C Rotation about the b-axis -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),-1,0,0,0,1,0,0,0,-1) - RT(1,4,N) = D(1,2) - RT(3,4,N) = D(3,2) - IF (L(2,M) .EQ. 12) RT(2,4,N) = 0.5 - GO TO 560 - 440 IF (L(1,2) .GE. 14) GO TO 490 - IF (L(1,3) .EQ. 14) GO TO 490 - CONTINUE - CALL SGRMAT (RT(1,1,N),-1,0,0,0,-1,0,0,0,1) - RT(1,4,N) = D(1,3) - RT(2,4,N) = D(2,3) - IF (IABS(L(2,M) - 13) .EQ. 1) RT(3,4,N) = 0.5 - IF (L(2,M) .EQ. 16) RT(3,4,N) = 0.5 - GO TO 560 - 450 CONTINUE - IF (L(1,4) .EQ. 12) GO TO 460 -C----------------------------------------------------------------------- -C 2-axis normal to (-2110). Used for the P 6n22 groups -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),1,-1,0,0,-1,0,0,0,-1) - GO TO 560 - 460 CONTINUE - IF (LAUENO .EQ. 7) GO TO 480 - 470 CONTINUE -C----------------------------------------------------------------------- -C 2-axis along to (11-20) trigonal and (110) tetragonal -C Used for the P 3n21 groups -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),0,1,0,1,0,0,0,0,-1) - RT(1,4,N) = D(2,1) - IF (L(2,M) .EQ. 12) RT(1,4,N) = RT(1,4,N) + 0.5 - RT(2,4,N) = -D(2,1) - RT(3,4,N) = D(3,1) - GO TO 560 - 480 CONTINUE -C----------------------------------------------------------------------- -C 2-axis normal to (110) -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),0,-1,0,-1,0,0,0,0,-1) - GO TO 560 - 490 CONTINUE - IF (L(1,2) .EQ. 15) GO TO 470 -C----------------------------------------------------------------------- -C 2-axis normal to (10-10) -C----------------------------------------------------------------------- - CALL SGRMAT (RT(1,1,N),1,0,0,1,-1,0,0,0,-1) - GO TO 560 -C----------------------------------------------------------------------- -C 3 fold rotation -C----------------------------------------------------------------------- - 500 GO TO (710,510,390,710),M - 510 CONTINUE - IF (LAUENO .LE. 7) GO TO 390 - CALL SGRMAT (RT(1,1,N),0,-1,0,1,-1,0,0,0,1) - IF (L(2,M) .EQ. 12) RT(3,4,N) = 0.33333333 - IF (L(2,M) .EQ. 13) RT(3,4,N) = 0.66666667 - IF (L(2,2) .EQ. 3) NCENT = 1 - GO TO 560 - 520 CONTINUE -C----------------------------------------------------------------------- -C 4 fold axis -C----------------------------------------------------------------------- - IF (M .NE. 2) IER = 12 - IF (IER .GT. 0) GO TO 710 - IF (L(2,2) .EQ. 3) GO TO 530 - CALL SGRMAT (RT(1,1,N),0,-1,0,1,0,0,0,0,1) - RT(1,4,N) = D(1,3) - RT(2,4,N) = D(2,3) - IF (L(2,2) .EQ. 12) RT(3,4,N) = 0.25 - IF (L(2,2) .EQ. 13) RT(3,4,N) = 0.5 - IF (L(2,2) .EQ. 14) RT(3,4,N) = 0.75 - GO TO 560 - 530 CONTINUE - CALL SGRMAT (RT(1,1,N),0,1,0,-1,0,0,0,0,-1) - RT(1,4,N) = D(1,3) - RT(2,4,N) = D(2,3) - RT(3,4,N) = D(3,3) - GO TO 560 - 540 CONTINUE -C----------------------------------------------------------------------- -C 6-axis -C----------------------------------------------------------------------- - IF (M .NE. 2) IER = 13 - IF (IER .GT. 0) GO TO 710 - IF (L(2,2) .EQ. 3) GO TO 550 - CALL SGRMAT (RT(1,1,N),1,-1,0,1,0,0,0,0,1) - IF (L(2,2) .GT. 11 .AND. L(2,2) .LT. 18) - $ RT(3,4,N) = (L(2,2) - 11)/6.0 - GO TO 560 - 550 CONTINUE - CALL SGRMAT (RT(1,1,N),-1,1,0,-1,0,0,0,0,-1) - IF (L(1,3) .EQ. 2 .OR. L(1,4) .EQ. 2) RT(3,4,N) = 0.5 - 560 CONTINUE - RT(1,4,N) = AMOD(RT(1,4,N) + 5.0,1.0) - RT(2,4,N) = AMOD(RT(2,4,N) + 5.0,1.0) - RT(3,4,N) = AMOD(RT(3,4,N) + 5.0,1.0) - RT(5,2,N) = 1728*RT(1,4,N) + 144*RT(2,4,N) + 12*RT(3,4,N) - DO 580 M2 = 1,N - 1 - IF (RT(5,1,M2) .EQ. RT(5,1,N)) GO TO 570 - IF (RT(5,1,M2) .NE. -RT(5,1,N)) GO TO 580 - NCENT = 1 - 570 CONTINUE - IF (RT(5,2,N) .NE. RT(5,2,M2)) GO TO 670 - GO TO 680 - 580 CONTINUE - N = N + 1 - IF (N .GT. 25) IER = 14 - IF (IER .GT. 0) GO TO 710 - 590 CONTINUE - IDENT = 0 - NXL = N - 1 - IF (NXL .LT. NXI) GO TO 640 - DO 630 NX = NXI,NXL - DO 620 M1 = 2,NX - CALL SGMTML (RT,M1,RT,NX,RT,N) - DO 610 M2 = 1,N - 1 - IF ( RT(5,1,N) .EQ. RT(5,1,M2)) GO TO 600 - IF (-RT(5,1,N) .NE. RT(5,1,M2)) GO TO 610 - NCENT = 1 - 600 CONTINUE - GO TO 620 - 610 CONTINUE - N = N + 1 - IF (N .GT. 25) IER = 15 - IF (IER .GT. 0) GO TO 710 - 620 CONTINUE - IF (N - 1 .EQ. NXL) GO TO 640 - 630 CONTINUE - NXI = NXL + 1 - GO TO 590 - 640 CONTINUE - IF (L(1,M) .LT. 12) GO TO 680 -C----------------------------------------------------------------------- -C Search for a / to indicate a mirror perpendicular to this axis -C----------------------------------------------------------------------- - IF (L(2,M) .EQ. 3) GO TO 680 - DO 650 I = 2,3 - IF (L(I,M) .EQ. 0) GO TO 680 - IF (L(I,M) .EQ. 19) GO TO 660 - IF (L(I,M) .LT. 12) IER = 16 - IF (IER .GT. 0) GO TO 710 - 650 CONTINUE - GO TO 680 - 660 IF (L(I + 1,M) .LE. 1) IER = 17 - IF (IER .GT. 0) GO TO 710 - I = IABS(L(I + 1,M) - 5) - GO TO 200 - 670 CONTINUE - CALL SGTRCF (M,RT,N,M2,LCENT,LAUENO,IER,LPTX) - IF (IER .GT. 0) IERX = IER - IER = 0 - 680 CONTINUE - NSYM = N - 1 - DO 700 I = 1,3 - DO 700 K = 1,NSYM - DO 690 J = 1,3 - JRT(I,J,K) = RT(I,J,K) - 690 CONTINUE - JRT(I,4,K) = 12*RT(I,4,K) + 144.1 - JRT(I,4,K) = JRT(I,4,K) - 12*(JRT(I,4,K)/12) - 700 CONTINUE - CALL SGPRNT (SPG,JRT,LAUENO,NAXIS,NCENT,LCENT,NSYM,NPOL,CEN, - $ NCV,LPT) - IF (IERX .EQ. 0) RETURN - IER = IERX - 710 CONTINUE - IF (LPTX .GE. 0) CALL SGERRS (SPG,IER,LPTX) - NAXIS = 4 - RETURN -10000 FORMAT (10A1) - END diff --git a/difrac/sgtrcf.f b/difrac/sgtrcf.f deleted file mode 100644 index 49c13c8f..00000000 --- a/difrac/sgtrcf.f +++ /dev/null @@ -1,68 +0,0 @@ -C----------------------------------------------------------------------- -C Space group routine check of operators -C----------------------------------------------------------------------- - SUBROUTINE SGTRCF (M,RT,N,M2,LCENT,LAUENO,IER,LPT) - CHARACTER COUT*132 - COMMON /IOUASC/ COUT(20) - DIMENSION RT(5,4,24) - DIMENSION ICENV(3,5),NCVT(7),JCVT(7) - DATA ICENV/0,0,0,0,6,6,6,0,6,6,6,0,6,6,6/ - DATA NCVT/1,2,3,4,5,4,1/ - DATA JCVT/1,1,2,3,4,1,1/ - IER = 0 - IRN = RT(5,2,N) - IRM = RT(5,2,M2) - IRX = MOD((IRN/144 + IRM/144),12) - IRY = MOD((IRN/12 + IRM/12),12) - IRZ = MOD(IRN + IRM,12) - NCV = NCVT(LCENT) - JCV = JCVT(LCENT) - DO 120 ICV = 1,NCV,JCV - IRX1 = MOD(IRX + ICENV(1,ICV),12) - IRY1 = MOD(IRY + ICENV(2,ICV),12) - IRZ1 = MOD(IRZ + ICENV(3,ICV),12) -C----------------------------------------------------------------------- -C Does this pair make a 1bar? -C----------------------------------------------------------------------- - M2Z = M2 - IF (RT(5,1,N) + RT(5,1,M2) .EQ. 0) M2Z = 1 -C----------------------------------------------------------------------- -C No. -C----------------------------------------------------------------------- - IF (RT(3,3,N) + RT(3,3,M2Z) .LE. 0) IRZ1 = 0 -C----------------------------------------------------------------------- -C Is this an operator operating along the face diagonal? -C----------------------------------------------------------------------- - IF (LAUENO .LE. 3 .OR. M .NE. 4) GO TO 100 -C----------------------------------------------------------------------- -C Yes. -C----------------------------------------------------------------------- - IRX1 = MOD(IRX1 + IRY1,12) - IRY1 = 0 - GO TO 110 - 100 CONTINUE -C----------------------------------------------------------------------- -C No. -C----------------------------------------------------------------------- - IF (RT(1,1,N) + RT(1,1,M2Z) .LE. 0) IRX1 = 0 - IF (RT(2,2,N) + RT(2,2,M2Z) .LE. 0) IRY1 = 0 - 110 CONTINUE - TOTTR = 144*IRX1 + 12*IRY1 + IRZ1 - IF (TOTTR .EQ. 0) RETURN - 120 CONTINUE - CONTINUE - IF (LPT .GE. 0) THEN - WRITE (COUT,10000) RT(5,2,N),RT(5,2,M2), - $ TOTTR,IRX,IRY,IRZ,RT(5,1,N),RT(5,1,M2) - CALL GWRITE (LPT,' ') - ENDIF - IER = 18 - IF (LPT .GE. 0) THEN - WRITE (COUT,11000) M,N,M2 - CALL GWRITE (LPT,' ') - ENDIF - RETURN -10000 FORMAT (3F10.1,3I5,2F10.1) -11000 FORMAT (' Operator',I2,' generates matrix',I3,' which has a', - $ ' translation conflict',2I3) - END diff --git a/difrac/sinmat.f b/difrac/sinmat.f deleted file mode 100644 index 0d93c597..00000000 --- a/difrac/sinmat.f +++ /dev/null @@ -1,87 +0,0 @@ -C----------------------------------------------------------------------- -C Make a symmetry constrained matrix for calculating Sin(Theta) -C -C Constrain the DUM array for the appropriate Crystal System -C If ISYS = 1 triclinic, no constraints; -C 2 is a dummy; -C 3 orthorhombic; -C 4 tetragonal; -C 5 hexagonal; -C 6 rhombohedral; -C 7 cubic; -C 8,9,10 monoclinic, a,b,c axes unique. -C----------------------------------------------------------------------- - SUBROUTINE SINMAT - INCLUDE 'COMDIF' - DIMENSION DUM(6) - IF (ISYS .LT. 1 .OR. ISYS .GT. 10) ISYS = 1 - DO 100 I = 1,3 - DUM(I) = APS(I) - DUM(I+3) = CANGS(I) - 100 CONTINUE - TEMP = WAVE*WAVE -C----------------------------------------------------------------------- -C Orthorhombic, tetragonal, hexagonal, cubic alpha, beta, gamma. -C----------------------------------------------------------------------- - IF ((ISYS .GE. 3 .AND. ISYS .LE. 5) .OR. ISYS .EQ. 7) THEN - DO 110 I = 4,6 - DUM(I) = 0 - 110 CONTINUE - ENDIF -C----------------------------------------------------------------------- -C Tetragonal, hexagonal a, a, c -C----------------------------------------------------------------------- - IF (ISYS .EQ. 4 .OR. ISYS .EQ. 5) THEN - DUM(1) = (DUM(1)+DUM(2))/2 - DUM(2) = DUM(1) - ENDIF -C----------------------------------------------------------------------- -C Hexagonal gamma -C----------------------------------------------------------------------- - IF (ISYS .EQ. 5) DUM(6) = 0.5 -C----------------------------------------------------------------------- -C Rhombohedral, cubic a, a, a -C----------------------------------------------------------------------- - IF (ISYS .EQ. 6 .OR. ISYS .EQ. 7) THEN - DUM(1) = (DUM(1)+DUM(2)+DUM(3))/3 - DUM(2) = DUM(1) - DUM(3) = DUM(1) - ENDIF -C----------------------------------------------------------------------- -C Rhombohedral alpha, alpha, alpha -C----------------------------------------------------------------------- - IF (ISYS .EQ. 6) THEN - DUM(4) = (DUM(4)+DUM(5)+DUM(6))/3 - DUM(5) = DUM(4) - DUM(6) = DUM(4) - ENDIF -C----------------------------------------------------------------------- -C Monoclinic (a unique) beta, gamma -C----------------------------------------------------------------------- - IF (ISYS .EQ. 8) THEN - DUM(5) = 0 - DUM(6) = 0 -C----------------------------------------------------------------------- -C Monoclinic (b unique) alpha, gamma -C----------------------------------------------------------------------- - ELSE IF (ISYS .EQ. 9) THEN - DUM(4) = 0 - DUM(6) = 0 -C----------------------------------------------------------------------- -C Monoclinic (c unique) alpha, beta -C----------------------------------------------------------------------- - ELSE IF (ISYS .EQ. 10) THEN - DUM(4) = 0 - DUM(5) = 0 - ENDIF -C----------------------------------------------------------------------- -C Calculate the symmetry constrained matrix SINABS -C----------------------------------------------------------------------- - SINABS(1) = TEMP*DUM(1)*DUM(1) - SINABS(2) = TEMP*DUM(2)*DUM(2) - SINABS(3) = TEMP*DUM(3)*DUM(3) - SINABS(4) = TEMP*2*DUM(1)*DUM(2)*DUM(6) - SINABS(5) = TEMP*2*DUM(1)*DUM(3)*DUM(5) - SINABS(6) = TEMP*2*DUM(2)*DUM(3)*DUM(4) - RETURN - END diff --git a/difrac/stdmes.f b/difrac/stdmes.f deleted file mode 100644 index eece02bc..00000000 --- a/difrac/stdmes.f +++ /dev/null @@ -1,168 +0,0 @@ -C----------------------------------------------------------------------- -C Subroutine to Measure Standard Refletions -C Modified to output to ITP for SICS MK -C----------------------------------------------------------------------- - SUBROUTINE STDMES - INCLUDE 'COMDIF' - DIMENSION ENREFB(10) - EQUIVALENCE (NREFB(1),ENREFB(1)) - IF (NSTAN .EQ. 0) THEN - KQFLAG = 1 - RETURN - ENDIF - CALL RSW (5,ILPT) -C----------------------------------------------------------------------- -C Set the standards flag -C----------------------------------------------------------------------- - 100 ISTAN = 1 - IF (ILPT .EQ. 0) THEN - IF (NMSEG .LE. NSEG) THEN - WRITE (COT,10000) IH,IK,IL,NREF,NSET,NMSEG,NBLOCK - ELSE - WRITE (COUT,10100) NSET,NREF,NBLOCK - ENDIF - CALL GWRITE(ITP,' ') - ENDIF -C----------------------------------------------------------------------- -C Loop to measure NSTAN standards -C----------------------------------------------------------------------- - JH = IH - JK = IK - JL = IL - DO 120 NN = 1,NSTAN - IH = IHSTAN(NN) - IK = IKSTAN(NN) - IL = ILSTAN(NN) -C----------------------------------------------------------------------- -C Calculate angles, set the display, set the circles and measure -C----------------------------------------------------------------------- - IPRVAL = 0 - CALL ANGCAL - CALL HKLN (IHSTAN(NN),IKSTAN(NN),ILSTAN(NN),NREF) - 110 IF (ISCAN .EQ. 3 .OR. ISCAN .EQ. 4) THEN - CALL SAMMES (ITIME,ICC) - IF (ICC .EQ. 2) THEN - WRITE (COUT,12000) IHSTAN(NN),IKSTAN(NN),ILSTAN(NN) - CALL GWRITE(ITP,' ') - GO TO 120 - ENDIF - ELSE - CALL MESINT (IROFL,ICC) - IF (ICC .GE. 4) GO TO 100 - IF (ICC .EQ. 2) THEN - WRITE (COUT,12000) IHSTAN(NN),IKSTAN(NN),ILSTAN(NN) - CALL GWRITE(ITP,' ') - GO TO 120 - ENDIF - IF (IROFL .NE. 0) GO TO 110 - ENDIF -C----------------------------------------------------------------------- -C Pack h&k and l&natt, put psi=999.0 to denote standard -C----------------------------------------------------------------------- - IHK(NB) = (IHSTAN(NN) + 500)*1000 + IKSTAN(NN) + 500 - ILA(NB) = (ILSTAN(NN) + 500)*1000 + NATT - BCOUNT(NB) = COUNT - BBGR1(NB) = BGRD1 - BBGR2(NB) = BGRD2 - BTIME(NB) = PRESET - IF (IPRFLG .EQ. 0) THEN - IF (ISCAN .EQ. 3 .OR. ISCAN .EQ. 4) THEN - BTIME(NB) = 10*ITIME + FRAC - ELSE - BTIME(NB) = FRAC - ENDIF - ENDIF - ENREFB(NB) = NREF - BPSI(NB) = 999.0 -C----------------------------------------------------------------------- -C Write a block of intensity data to file -C----------------------------------------------------------------------- - IF (NB .GE. 10) THEN - WRITE (IID,REC=NBLOCK) IHK,ILA,BCOUNT,BBGR1,BBGR2,BTIME, - $ ENREFB,BPSI - NBLOCK = NBLOCK + 1 - NB = 0 - ENDIF - NB = NB+1 -C----------------------------------------------------------------------- -C Sort out which attenuators to apply and write standard on terminal -C----------------------------------------------------------------------- - ATT = ATTEN(NATT+1) - IF (ITYPE .EQ. 7 .OR. ITYPE .EQ. 8) THEN - IPCT = PRESET - IBCT = (PRESET - IPCT)*2000 - PCOUNT = COUNT/IPCT - (BGRD1 + BGRD2)/IBCT - SIG = SQRT(COUNT/(IPCT*IPCT) + (BGRD1 + BGRD2)/(IBCT*IBCT)) - PCOUNT = PCOUNT*ATT/IPCT - SIG = SIG*ATT/IPCT - PCT = IPCT - IF (ILPT .EQ. 0) THEN - WRITE (COUT,16000) - $ NN,IHSTAN(NN),IKSTAN(NN),ILSTAN(NN), - $ THETA,PCT,NATT,BGRD1,COUNT,BGRD2,PCOUNT,SIG - CALL GWRITE(ITP,' ') - ENDIF - ELSE - PCOUNT = COUNT - (BGRD1 + BGRD2)/(2.0*FRAC) - PCOUNT = PCOUNT*ATT - IF (ILPT .EQ. 0) THEN - WRITE (COUT,13000) - $ NN,IHSTAN(NN),IKSTAN(NN),ILSTAN(NN), - $ THETA,TIME,NATT,BGRD1,COUNT,BGRD2,PCOUNT - CALL GWRITE(ITP,' ') - ENDIF - SIG = SQRT(COUNT + (BGRD1 + BGRD2)/(4.0*FRAC*FRAC)) - ICOUNT = COUNT + 0.5 - ISIG = SIG + 0.5 - IF (NATT .NE. 0) THEN - WRITE (COUT,14000) IHSTAN(NN),IKSTAN(NN),ILSTAN(NN),NATT, - $ ICOUNT,ISIG,NN - ELSE - WRITE (COUT,14100) IHSTAN(NN),IKSTAN(NN),ILSTAN(NN), - $ ICOUNT,ISIG,NN - ENDIF - CALL GWRITE (ITP,' ') - IATT = NATT + 10 -C----------------------------------------------------------------------- -C Write the profile on the screen -C----------------------------------------------------------------------- - CALL PROFIL -C----------------------------------------------------------------------- -C Test for K or Q stop -C----------------------------------------------------------------------- - ENDIF - CALL KORQ (KQFLAG) - IF (KQFLAG .EQ. 0) THEN - ISTAN = 0 - KI = 'G3' - RETURN - ENDIF - KQFLGS = 1 - IF (KQFLAG .EQ. 2) KQFLGS = 2 - 120 CONTINUE -C----------------------------------------------------------------------- -C Reset standards flag and return with a disguised call to GOLOOP -C----------------------------------------------------------------------- - ISTAN = 0 - IH = JH - IK = JK - IL = JL - KI = 'G3' - IF(KQFLGS .NE. 0) THEN - KQFLAG = KQFLGS - ELSE - KQFLAG = 1 - ENDIF - RETURN -10000 FORMAT (/20X,'Reference Reflection Measurement '/ - $ ' Next reflection:',3I4,', # ',I4,', Set',I3, - $ ', Segment ',I2,', Record ',I4) -10100 FORMAT (/20X,'Reference Reflection Measurement at end of set',I3/ - $ ' Restart at reflection #',I6,', segment 1, record',I5) -11000 FORMAT (3I4,' Setting Collision') -12000 FORMAT (3I4,' Scan Collision ') -13000 FORMAT (2X,I1,3(I3,1X),2(F7.3,1X),I1,F5.0,F7.0,F5.0,10X,F7.0) -14000 FORMAT (3I4,I2,I7,'(',I4,')',I2) -14100 FORMAT (3I4,2X,I7,'(',I4,')',I2) -16000 FORMAT (2X,I1,3(I3,1X),2(F7.3,1X),I1,F5.0,F7.0,F5.0,10X,2F8.2) - END diff --git a/difrac/swrite.f b/difrac/swrite.f deleted file mode 100644 index ae9daa7c..00000000 --- a/difrac/swrite.f +++ /dev/null @@ -1,109 +0,0 @@ -C----------------------------------------------------------------------- -C Routines to perform consol I/O -C----------------------------------------------------------------------- - SUBROUTINE GWRITE (IDEV,DOLLAR) - CHARACTER DOLLAR*(*) - CHARACTER*132 COUT - INTEGER LINE(132), IL, LEN - COMMON /IOUASC/ COUT(20) - COMMON /IOUASS/ IOUNIT(10) - CHARACTER CR*1,LF*1,CRLF*2,STATUS*2 - CR = CHAR(13) - LF = CHAR(10) - CRLF(1:1) = CR - CRLF(2:2) = LF - ITP = IOUNIT(6) -C----------------------------------------------------------------------- -C First find out how many lines to output -C----------------------------------------------------------------------- - DO 100 I = 20,1,-1 - IF (COUT(I) .NE. ' ') GO TO 110 - 100 CONTINUE -C----------------------------------------------------------------------- -C Must be just a blank line. Only here for safety - should not happen. -C----------------------------------------------------------------------- - I = 1 - 110 NLINES = I - IF (COUT(NLINES)(1:1) .EQ. '%') COUT(NLINES)(1:1) = ' ' -C----------------------------------------------------------------------- -C If the unit is not ITP then just do straight output to the device -C----------------------------------------------------------------------- - IF (IDEV .NE. ITP) THEN - IF (NLINES .GT. 1) THEN - DO 120 I = 1,NLINES-1 - WRITE (IDEV,10200) COUT(I)(1:LINELN(COUT(I))) - 120 CONTINUE - ENDIF - IF (DOLLAR .EQ. '$') THEN - WRITE (IDEV,10000) COUT(NLINES)(1:LINELN(COUT(I))) - ELSE IF (DOLLAR .EQ. '%') THEN - WRITE (IDEV,10100) COUT(NLINES)(1:LINELN(COUT(I))) - ELSE - WRITE (IDEV,10200) COUT(NLINES)(1:LINELN(COUT(I))) - ENDIF - ELSE -C----------------------------------------------------------------------- -C Unit is ITP. Output in SICS compatible form. -C----------------------------------------------------------------------- - IF (NLINES .GE. 1) THEN - DO 130 I = 1,NLINES - LEN = LINELN(COUT(I)) - DO 200, IL = 1, LINELN(COUT(I)) - LINE(IL) = ICHAR(COUT(I)(IL:IL)) - 200 CONTINUE - CALL SICSWRITE(LINE,LEN) - 130 CONTINUE - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Blank out COUT in case some compilers dont -C----------------------------------------------------------------------- - DO 140 I = 1,20 - COUT(I) = ' ' - 140 CONTINUE - RETURN -10000 FORMAT (A,' ',$) -10100 FORMAT (A,$) -10200 FORMAT (A) - END -C----------------------------------------------------------------------- -C Function to return the length of a character string -C----------------------------------------------------------------------- - INTEGER FUNCTION LINELN (STRING) - CHARACTER STRING*(*) - DO 10 I = LEN(STRING),1,-1 - IF (STRING(I:I) .NE. ' ') GO TO 20 -10 CONTINUE - I = 0 -20 LINELN = I - RETURN - END -C----------------------------------------------------------------------- -C GETLIN Read a line of input from the keyboard -C----------------------------------------------------------------------- - SUBROUTINE GETLIN (STRING) - COMMON /IOUASS/ IOUNIT(10) - CHARACTER STRING*(*) - INTEGER LINE(132), LEN, I - CALL SICSGETLINE(LINE,LEN) - DO 100, I = 1, LEN - STRING(I:I) = CHAR(LINE(I)) - 100 CONTINUE - RETURN - END -C----------------------------------------------------------------------- -C WNTEXT Output text to a window -C----------------------------------------------------------------------- - SUBROUTINE WNTEXT (STRING) - COMMON /IOUASS/ IOUNIT(10) - CHARACTER STRING*(*) - RETURN - END -C----------------------------------------------------------------------- -C SCROLL Output a new-line -C----------------------------------------------------------------------- - SUBROUTINE SCROLL - COMMON /IOUASS/ IOUNIT(10) - RETURN - END - diff --git a/difrac/sysang.f b/difrac/sysang.f deleted file mode 100644 index ba6de485..00000000 --- a/difrac/sysang.f +++ /dev/null @@ -1,74 +0,0 @@ -C----------------------------------------------------------------------- -C Decide on the crystal system based on the cell edges and angles -C----------------------------------------------------------------------- - SUBROUTINE ANGSYS (ABC,SANG,CANG,ISYS) - DIMENSION ABC(3),SANG(3),CANG(3),ANG(3) - EQUIVALENCE (ABC(1),A), (ABC(2),B), (ABC(3),C), - $ (ANG(1),AL),(ANG(2),BE),(ANG(3),GA) - DATA RA/57.2958/,TAN/0.1/,TED/0.01/ -C----------------------------------------------------------------------- -C Make the angles from their sines and cosines -C----------------------------------------------------------------------- - DO 100 I = 1,3 - ANG(I) = RA*ATAN2(SANG(I),CANG(I)) - 100 CONTINUE - ISYS = 0 - IF (AMOD(AL - BE) .GT. TAN) THEN -C----------------------------------------------------------------------- -C Monoclinic or triclinic ? -C----------------------------------------------------------------------- - IF (AMOD(AL - GA) .GT. TAN) THEN -C----------------------------------------------------------------------- -C Triclinic -C----------------------------------------------------------------------- - ISYS = 1 - ELSE -C----------------------------------------------------------------------- -C Monoclinic -C----------------------------------------------------------------------- - ISYS = 2 - ENDIF - ELSE -C----------------------------------------------------------------------- -C Cubic, rhombohedral, hexagonal, tetragonal, or orthorhombic -C----------------------------------------------------------------------- - IF (AMOD(AL - GA) .GT. TAN) THEN -C----------------------------------------------------------------------- -C Hexagonal -C----------------------------------------------------------------------- - ISYS = 5 - ELSE - IF(AMOD(AL - 90.0) .GT. TAN) THEN -C----------------------------------------------------------------------- -C Rhombohedral -C----------------------------------------------------------------------- - ISYS = 6 - ELSE - IF (AMOD(A - B) .GT. TED) THEN -C----------------------------------------------------------------------- -C Orthorhombic -C----------------------------------------------------------------------- - ISYS = 3 - ELSE - IF (AMOD(B - C) .GT. TED) THEN -C----------------------------------------------------------------------- -C Tetragonal -C----------------------------------------------------------------------- - ISYS = 4 -C----------------------------------------------------------------------- -C Cubic -C----------------------------------------------------------------------- - ELSE - ISYS = 7 - ENDIF - ENDIF - ENDIF - ENDIF - ENDIF -C----------------------------------------------------------------------- -C Just in case !! -C----------------------------------------------------------------------- - IF (ISYS .EQ. 0) ISYS = 1 - RETURN - END - \ No newline at end of file diff --git a/difrac/tcentr.f b/difrac/tcentr.f deleted file mode 100644 index fb545541..00000000 --- a/difrac/tcentr.f +++ /dev/null @@ -1,190 +0,0 @@ -C----------------------------------------------------------------------- -C This subroutine controls the automatic alignment of reflections -C----------------------------------------------------------------------- - SUBROUTINE TCENTR (NSTORE) - INCLUDE 'COMDIF' - DIMENSION THETAS(NSIZE), OMEGS(NSIZE), CHIS(NSIZE),PHIS(NSIZE), - $ ITIMS(NSIZE),THETAP(NSIZE),OMEGP(NSIZE),CHIP(NSIZE), - $ PHIP(NSIZE) - CHARACTER WHICH*6 - EQUIVALENCE (ACOUNT( 1),THETAS(1)), - $ (ACOUNT( NSIZE+1),OMEGS(1)), - $ (ACOUNT(2*NSIZE+1),CHIS(1)), - $ (ACOUNT(3*NSIZE+1),PHIS(1)), - $ (ACOUNT(4*NSIZE+1),ITIMS(1)), - $ (ACOUNT(5*NSIZE+1),THETAP(1)), - $ (ACOUNT(6*NSIZE+1),OMEGP(1)), - $ (ACOUNT(7*NSIZE+1),CHIP(1)), - $ (ACOUNT(8*NSIZE+1),PHIP(1)) - REAL CURCTS,MAXCTS - WIDTH = 1.25 -C----------------------------------------------------------------------- -C Read the peaks from disk -C----------------------------------------------------------------------- - CALL ANGRW (0,4,NMAX,160,0) -C----------------------------------------------------------------------- -C Save the current angles for later -C----------------------------------------------------------------------- - DO 100 J = 1,NMAX - THETAP(J) = THETAS(J) - OMEGP(J) = OMEGS(J) - PHIP(J) = PHIS(J) - CHIP(J) = CHIS(J) - 100 CONTINUE -C----------------------------------------------------------------------- -C Centre the NSTORE to NMAX positions -C----------------------------------------------------------------------- - NGOOD = NSTORE - 1 - DO 210 J = NSTORE,NMAX -C----------------------------------------------------------------------- -C Check if a K or a Q was typed on the terminal -C----------------------------------------------------------------------- - CALL KORQ (IFLAG1) - IF (IFLAG1 .NE. 1) THEN - KI = 'O4' - RETURN - ENDIF - RTHETA = THETAS(J) - ROMEGA = OMEGS(J) - RCHI = CHIS(J) - RPHI = PHIS(J) - WRITE (COUT,10000) J,RTHETA,ROMEGA,RCHI,RPHI - CALL GWRITE (ITP,' ') - WRITE (LPT,10000) J,RTHETA,ROMEGA,RCHI,RPHI - CALL ANGSET (RTHETA,ROMEGA,RCHI,RPHI,NATT,ICOL) - THETA = RTHETA - OMEGA = ROMEGA - CHI = RCHI - PHI = RPHI -C----------------------------------------------------------------------- -C Set the angles at the approximate position of the peak and adjust -C Phi, Chi and 2Theta to get maximum intensity in the detector. -C Sietronics interface works via MAXPOINT; CAD4 via CADCEN -C----------------------------------------------------------------------- -C CAD-4 and Sietronics deleted for clarity: Mark Koennecke - CALL SHUTTR (99) -C----------------------------------------------------------------------- -C All other machines for the moment -C Modified: Mark Koennecke for TRICS -C Do initial search. But use the results of the searches -C only if they improved the countrate. -C----------------------------------------------------------------------- - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - CALL CCTIME (PRESET,CURCTS) -C----- first two theta - RTIM = PRESET - CALL TFIND(RTIM,MAXCTS) - IF(MAXCTS .LT. CURCTS) THEN - THETA = RTHETA - OMEGA = ROMEGA - ELSE - CURCTS = MAXCTS - ENDIF - CALL KORQ (IFLAG1) - IF (IFLAG1 .NE. 1) THEN - KI = 'O4' - RETURN - ENDIF -C----- now phi - RTIM = PRESET - CALL PFIND(RTIM,MAXCTS) - IF(MAXCTS .LT. CURCTS) THEN - PHI = RPHI - ELSE - CURCTS = MAXCTS - ENDIF - CALL KORQ (IFLAG1) - IF (IFLAG1 .NE. 1) THEN - KI = 'O4' - RETURN - ENDIF -C------ finally phi - RTIM = PRESET - CALL CFIND(RTIM,MAXCTS) - IF(MAXCTS .LT. CURCTS) THEN - CHI = RCHI - ELSE - CURCTS = MAXCTS - ENDIF - CALL KORQ (IFLAG1) - IF (IFLAG1 .NE. 1) THEN - KI = 'O4' - RETURN - ENDIF -C------- end of pre centering - WRITE (COUT,11000) THETA,OMEGA,CHI,PHI - CALL GWRITE (ITP,' ') - WRITE (LPT,11000) THETA,OMEGA,CHI,PHI - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) -C----------------------------------------------------------------------- -C Save the tweaked positions to make life a little easier later -C----------------------------------------------------------------------- - THETAP(J) = THETA - OMEGP(J) = OMEGA - CHIP(J) = CHI - PHIP(J) = PHI - CALL ANGRW (1,4,NMAX,160,1) -C----------------------------------------------------------------------- -C Now proceed with the conventional alignment with defaults appropriate -C to fully open windows -C The steps are adapted to the 2-Theta angle. -C----------------------------------------------------------------------- - AFRAC = 0.5 - CON = IFRDEF - CON = 10.0/(IFRDEF*THETA) - DT = 10.0*CON - DO = 5.0*CON - DC = 50.0*CON - IF(PRESET .LT. 1000) PRESET = 1000.0 -C IF (TIME .LT. 0.10) TIME = 0.10 -C IF (TIME .GT. 3.0) GO TO 200 - NATT = 0 - IF (CHI .LT. 0.0) CHI = CHI + 360.0 - IF (CHI .GT. 360.0) CHI = CHI - 360.0 - IF (PHI .LT. 0.0) PHI = PHI + 360.0 - IF (PHI .GT. 360.0) PHI = PHI - 360.0 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - ISLIT = 0 - IF (DFMODL .EQ. 'CAD4') ISLIT = 40 - CALL WXW2T (DT,DO,DC,ISLIT) - COUNT = 0 - ITIMS(J) = 0 - IF (KI .EQ. 'FF') GO TO 200 -C----------------------------------------------------------------------- -C Position on the peak and count for standard preset -C----------------------------------------------------------------------- - CALL ANGSET (RTHETA,ROMEGA,RCHI,RPHI,NATT,ICOL) - CALL SHUTTR (99) - CALL CCTIME (PRESET,COUNT) - ICOUNT = COUNT -C----------------------------------------------------------------------- -C Do not save a weak count -C----------------------------------------------------------------------- - IF (ICOUNT .LT. 100) GO TO 200 - WRITE (COUT,12000) RTHETA,ROMEGA,RCHI,RPHI,ICOUNT - CALL GWRITE (ITP,' ') - WRITE (LPT,12000) RTHETA,ROMEGA,RCHI,RPHI,ICOUNT -C----------------------------------------------------------------------- -C If the alignment was successful, remember it -C----------------------------------------------------------------------- - THETAP(J) = RTHETA - OMEGP(J) = ROMEGA - CHIP(J) = RCHI - PHIP(J) = RPHI - CALL ANGRW (1,4,NMAX,160,1) - NGOOD = NGOOD + 1 - THETAS(NGOOD) = RTHETA - OMEGS(NGOOD) = ROMEGA - CHIS(NGOOD) = RCHI - PHIS(NGOOD) = RPHI - ITIMS(NGOOD) = COUNT - CALL ANGRW (1,5,NGOOD,140,0) - 200 CALL SHUTTR (-99) - 210 CONTINUE - KI = 'O4' - RETURN -10000 FORMAT (/' Peak',I4,' Coarse Setting ',4F10.3) -11000 FORMAT ( ' Approximate ',4F10.3) -12000 FORMAT ( ' Final Values ',4F10.3,I10) -13000 FORMAT (' Coarse centering failure in ',A) - END diff --git a/difrac/tfind.f b/difrac/tfind.f deleted file mode 100644 index bf27a702..00000000 --- a/difrac/tfind.f +++ /dev/null @@ -1,59 +0,0 @@ -C----------------------------------------------------------------------- -C Find the Coarse setting for 2-Theta -C----------------------------------------------------------------------- - SUBROUTINE TFIND (TIM, MAXCOUNT) - INCLUDE 'COMDIF' - REAL MAXCOUNT, MCOUNT - DIMENSION TCOUNT(NSIZE) - EQUIVALENCE (ACOUNT(9*NSIZE+1),TCOUNT(1)) - STEPM = 0.01 - SENSE = -1.0 - TSTEP = 0.25 - NATT = 0 - NPTS = 10 - NRUN = 0 -100 THEOFF = THETA - OMEOFF = OMEGA - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - ICOUNT = 0 - MCOUNT = 0 - DO 110 I = 1,NPTS - CALL CCTIME (TIM,TCOUNT(I)) - CALL KORQ (IFLAG1) - IF (IFLAG1 .NE. 1) THEN - KI = 'O4' - RETURN - ENDIF - IF (TCOUNT(I) .GT. MCOUNT) THEN - MCOUNT = TCOUNT(I) - ICOUNT = I - ENDIF - THETA = THETA + SENSE*TSTEP - OMEGA = OMEGA - SENSE*TSTEP*0.5 - CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL) - 110 CONTINUE - MAXCOUNT = MCOUNT - IF (ICOUNT .EQ. 1) THEN -C -C try, the other direction. But only once as checked by NRUN -C otherwise we end in an endless loop. -C - IF (NRUN .GT. 0) THEN - MAXCOUNT = 0. - RETURN - ENDIF - SENSE = -SENSE - THETA = THEOFF + 9.0*SENSE*TSTEP - OMEGA = OMEOFF - 9.0*SENSE*TSTEP/2 - NRUN = NRUN + 1 - GO TO 100 - ENDIF - IF (ICOUNT .EQ. 10) THEN - THETA = THEOFF - 3.0*SENSE*TSTEP - OMEGA = OMEOFF + 3.0*SENSE*TSTEP/2 - GO TO 100 - ENDIF - THETA = THEOFF + ICOUNT*SENSE*TSTEP - OMEGA = OMEOFF - ICOUNT*SENSE*TSTEP/2 - RETURN - END diff --git a/difrac/trics.f b/difrac/trics.f deleted file mode 100644 index 2e03d00e..00000000 --- a/difrac/trics.f +++ /dev/null @@ -1,354 +0,0 @@ -C----------------------------------------------------------------------- -C RALF Routines for TRICS running SICS -C interface. -C -C Mark Koennecke, November 1999 -C -C----------------------------------------------------------------------- - SUBROUTINE HKLN (I1, I2, I3, I4) - J1 = I1 - J2 = I2 - J3 = I3 - J4 = I4 - RETURN - END -C----------------------------------------------------------------------- -C INTON This routine must be called before any others and may be -C used to initialise the diffractometer -C----------------------------------------------------------------------- - SUBROUTINE INTON - RETURN - END -C----------------------------------------------------------------------- -C INTOFF -- clean up the interface -C----------------------------------------------------------------------- - SUBROUTINE INTOFF - return - end -C----------------------------------------------------------------------- -C ZERODF In case of an error this routine returns the diffractometer -C to a known state -C----------------------------------------------------------------------- - SUBROUTINE ZERODF - RETURN - END -C----------------------------------------------------------------------- -C CTIME Count for a fixed time -C----------------------------------------------------------------------- - SUBROUTINE CCTIME (XTIME, XCOUNT) - REAL XTIME, XCOUNT - INCLUDE 'COMDIF' - call setslt (icadsl,icol) - CALL SICSCOUNT(XTIME,XCOUNT) - RETURN - END -C----------------------------------------------------------------------- -C ANGET Read the angles -C----------------------------------------------------------------------- - SUBROUTINE ANGET (WTWOTH, WOMEGA, WCHI, WPHI) - include 'COMDIF' - CALL SICSANGET(WTWOTH,WOMEGA,WCHI,WPHI) - wtwoth = wtwoth - dtheta - womega = womega - wtwoth/2. - domega - wchi = wchi - dchi - wphi = wphi - dphi - if (wtwoth .lt. 0.0) wtwoth = wtwoth + 360.00 - if (womega .lt. 0.0) womega = womega + 360.00 - if (wchi .lt. 0.0) wchi = wchi + 360.00 - if (wphi .lt. 0.0) wphi = wphi + 360.00 - RETURN - END -C---------------------------------------------------------------------- -C ANGCHECK check the angles against hardware or software limits -C----------------------------------------------------------------------- - SUBROUTINE ANGCHECK (WTHETA, WOMEGA, WCHI, WPHI, INVALID) - include 'COMDIF' - atheta = wtheta + dtheta - aomega = womega + domega + wtheta/2.0 - achi = wchi + dchi - aphi = wphi + dphi - if (atheta .gt. 180.00) atheta = atheta - 360.00 - if (aomega .gt. 180.00) aomega = aomega - 360.00 - IF(ACHI .LT. 0)ACHI = ACHI + 360. - IF(APHI .GT. 360.)APHI = APHI - 360. - IF(APHI .LT. 0) APHI = APHI + 360. - CALL SICSANGCHECK(ATHETA,AOMEGA,ACHI,APHI,INVALID) - RETURN - END -C----------------------------------------------------------------------- -C ANGSET Set the angles -C----------------------------------------------------------------------- - SUBROUTINE ANGSET (WTHETA, WOMEGA, WCHI, WPHI, NATTW, ICOL) - include 'COMDIF' - ishutf = 0 - if (nattw .gt. 0) then - iattf = 1 - else - iattf = 0 - endif - atheta = wtheta + dtheta - aomega = womega + wtheta/2. + domega - achi = wchi + dchi - aphi = wphi + dphi - if (atheta .gt. 180.00) atheta = atheta - 360.00 - if (aomega .gt. 180.00) aomega = aomega - 360.00 - IF(ACHI .LT. 0)ACHI = ACHI + 360. - IF(APHI .GT. 360.)APHI = APHI - 360. - IF(APHI .LT. 0) APHI = APHI + 360. - CALL SICSANGSET(ATHETA,AOMEGA,ACHI,APHI,ICOL) - RETURN - END -C----------------------------------------------------------------------- -C SHUTR Open or close the shutter -C IOC = 1 open, 2 close -C INF = 0 OK -C----------------------------------------------------------------------- - SUBROUTINE SHUTR (IOC, INF) - INF = 0 - IF (IOC .EQ. 1) THEN - ISHUTF = 1 - ELSE - ISHUTF = 0 - ENDIF - RETURN - END - - SUBROUTINE ONEBEP(R1,R2) - CHARACTER CTRLG*1 - RETURN - END - -C----------------------------------------------------------------------- -C KORQ -- Read the keyboard buffer -C If it contains K|k|Q|q return: 0 = K -C 1 = nothing found -C 2 = Q -C -C KORQ will toggle the switch registers 1-9,0 if the numeric -C keys are found in the buffer. -C----------------------------------------------------------------------- - SUBROUTINE KORQ (I1) - INCLUDE 'COMDIF' - CHARACTER STRING*80 - LOGICAL SWFND,SAVED,SWCALL - DATA SAVED/.FALSE./ - SWFND = .FALSE. -C----------------------------------------------------------------------- -C First check if we are making a regular call after a K or Q has been -C found from a call from RSW. -C----------------------------------------------------------------------- - CALL CHECKINT(I1) - RETURN - END -C----------------------------------------------------------------------- -C RSW Read the switch register -C----------------------------------------------------------------------- - SUBROUTINE RSW (N,IVALUE) - INCLUDE 'COMDIF' - IVALUE = ISREG(N) - RETURN - END -C----------------------------------------------------------------------- -C Initialise the Program -C----------------------------------------------------------------------- - SUBROUTINE INITL(R1,R2,R3,R4) - A1 = R1 - A2 = R2 - A3 = R3 - A4 = R4 - RETURN - END -C-------------------------------------------------------------------- -C Routine to perform scans. -C ITYPE Scan type -- 0 or 2 Omega/2-theta -C 1 or 3 Omega -C SCNANG Angle to scan in degrees. This should be the -C 2theta range for an omega-2theta scan and the -C omega range for an omega scan. -C ACOUNT Returns total intensity in ACOUNT(1) and profile -C in ACOUNT(2)-ACOUNT(NPPTS+1) -C TIME Total scan time in secs -C SPEED Scan speed in degs/min. -C NPPTS Number of points in the profile on output -C IERR Error code 0 -- O.K. -C 1 -- Collision -C 2 or more really bad! -C-------------------------------------------------------------------- - SUBROUTINE TSCAN (ITYPE,SCNANG,ACOUNT,PRESET,STEP,NPPTS,IERR) - COMMON /DFMACH/ ISCDEF,ICDDEF,IDTDEF,IDODEF,IDCDEF,IFRDEF,NRC, - $ NATTEN,STEPDG,ICADSL,ICADSW - DIMENSION ACOUNT(*) - REAL THSTART, OMSTART, CHI, PHI, TH, OM - INTEGER ICOL, IT -C-------------------------------------------------------------------- -C Version 0.50 Supports itype = 0 or 1 omega-2theta and -C 2 or 3 omega -C in both cases IANGLE is omega at the end of the scan -C -C Version 0.6 Modified to be a generic routine using ANGSET and -C CTIME for doing the scans. This ammounts to a simple -C step scan. This is the only useful thing for TRICS -C at SINQ. -C PRESET is the preset for counting. -C STEP is the scan step width. -C-------------------------------------------------------------------- - IERR = 0 -C-------------------------------------------------------------------- -C The diffractometer should have been positioned at the beginning -C position for the scan. -C-------------------------------------------------------------------- - CALL SETSLT (ICADSL,ICOL) - isense = 1 - if (scnang .lt. 0.0) then - isense = -1 - scnang = - scnang - endif - NPPTS = INT(SCNANG/STEP) - CALL ANGET(THSTART,OMSTART,CHI,PHI) - IF (ITYPE .EQ. 0 .OR. ITYPE .EQ. 1) THEN - MODE = 0 -C-------------------------------------------------------------------- -C Omega scan -C-------------------------------------------------------------------- - ELSE IF (ITYPE .EQ. 2 .OR. ITYPE .EQ. 3) THEN - MODE = 2 - ELSE - IERR = 2 - RETURN - ENDIF -C-------------------------------------------------------------------- -C Setup complete -- do the scan -C-------------------------------------------------------------------- - ACOUNT(1) = 0. - DO 200, I = 1, NPPTS -C----- position - IF(MODE .EQ. 0) THEN - TH = THSTART + ISENSE*I*STEP - OM = 0 - ELSE IF(MODE .EQ. 2)THEN - TH = THSTART - OM = OMSTART + ISENSE*I*STEP - ENDIF - CALL ANGSET(TH,OM,CHI,PHI,1,ICOL) - IF(ICOL .GT. 0)THEN - IERR = 2 - RETURN - ENDIF -C----- count - CALL CCTIME(PRESET,COUNT) - CALL KORQ(IT) - IF(IT .NE. 1)THEN - IERR = 2 - RETURN - ENDIF - ACOUNT(I+1) = COUNT - ACOUNT(1) = ACOUNT(1) + COUNT - 200 CONTINUE - return - end -C-------------------------------------------------------------------- -C Routine to display a peak profile in the current graphics window. -C The arguments are: -C -C NHIST The number of points to be plotted -C HIST An array of points -C IHTAGS(4) The calculated peak position, the experimental position, -C low background limit and high background limit. -C-------------------------------------------------------------------- - SUBROUTINE PTPREP (NHIST,HIST,IHTAGS) - INTEGER IHTAGS(4) - REAL HIST(*) - INTEGER IX,IY,IZ - CHARACTER STRING*80 - RETURN - END -C------------------------------------------------------------------- -C RPSCAN Ralf support for PSCAN routine -C PHI scan from -90 to 90 with a step of 2. -C------------------------------------------------------------------- - SUBROUTINE RPSCAN (NPTS,ICOL,SPRESET) - INCLUDE 'COMDIF' - INTEGER IDIR,I,IT - REAL WTH,WOM,WCHI,WPHI, STEP, PHI,SPRESET - STEP = 2. -C------------------------------------------------------------------- -C Get the current angles and decide which direction to scan -C------------------------------------------------------------------- - CALL ANGET (WTH,WOM,WCHI,WPHI) -C------------------------------------------------------------------ -C have the scan go always from 270 - 90 region as TRICS may have -C restrictions around 0. -C------------------------------------------------------------------ - WPHI = 270.00 - TARGET = 90.00 - IDIR = -1 - NPTS = 90 -C------------------------------------------------------------------- -C Now do the scan -C------------------------------------------------------------------- - ACOUNT(1) = 0. - DO 200, I = 1, NPTS -C----- position - PHI = WPHI + I*IDIR*STEP - CALL ANGSET(WTH,WOM,WCHI,PHI,1,ICOL) - IF(ICOL .GT. 0)THEN - IERR = 2 - RETURN - ENDIF -C----- count - CALL CCTIME(SPRESET,COUNT) - CALL KORQ(IT) - IF(IT .NE. 1)THEN - IERR = 2 - RETURN - ENDIF - ACOUNT(I) = COUNT - ACOUNT(5*NSIZE+I) = PHI - 200 CONTINUE - RETURN - END -C------------------------------------------------------------------- -C special to some strange diffractometer, just keep the linker happy -C------------------------------------------------------------------- - SUBROUTINE MAXPOINT (IAXIS,WIDTH,STEPS,ANGLE) - RETURN - END -C----------------------------------------------------------------------- -C GENSCN Routine to perform a scan of a given motor -C ICIRCL 1 -- 2-theta ISLIT 0 -- Nothing -C 2 -- omega 1 -- Vertical -C 3 -- kappa 2 -- Horizontal -C 4 -- phi 3 -- +45 deg -C 4 -- -45 deg -C 5 -- Upper 1/2 circle -C 6 -- Lower 1/2 circle -C 10 to 59 -- horiz. aperture in mms -C SPEED Speed in degrees per minute -C STEP Step width in degrees, NPTS number of steps -C ICOL 0 -- OK -C GENSCN is also only valid for CAD4 -C----------------------------------------------------------------------- - SUBROUTINE GENSCN (ICIRCL, WSPEED, WSTEP, NPTS, ISLIT, ICOL) - return - end -C----------------------------------------------------------------------- -C SETSLT -- Set the slits -C cannot set slits at TRICS: NOT motorized -C----------------------------------------------------------------------- - subroutine setslt (islt,icol) - return - end -C----------------------------------------------------------------------- -C Set the microscope viewing position (CAD-4 version) -C----------------------------------------------------------------------- - SUBROUTINE VUPOS (VTH,VOM,VCH,VPH) - CALL ANGSET(VTH,VOM,VCH,VPH,1,1) - RETURN - END - - - - - - - diff --git a/difrac/wrbas.f b/difrac/wrbas.f deleted file mode 100644 index c9ac029a..00000000 --- a/difrac/wrbas.f +++ /dev/null @@ -1,77 +0,0 @@ -C----------------------------------------------------------------------- -C Routine to read and write the basic data to and from IDATA.DA -C----------------------------------------------------------------------- - SUBROUTINE WRBAS - INCLUDE 'COMDIF' -C----------------------------------------------------------------------- -C If called from ANGVAL or RB read from IDATA -C If called from RB, read from IDATA after confirming -C As of 18-Jun-94 record 1 has 84 variables, -C record 2 85 " (5-Oct-95) -C record 3 85 " -C----------------------------------------------------------------------- - IF (KI .EQ. 'AN' .OR. KI .EQ. 'RB') THEN - IF (KI .EQ. 'RB') THEN - WRITE (COUT,10000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - ENDIF - READ (IID,REC=1) R,WAVE,DCHI,DOMEGA,DTHETA,THEMIN,THEMAX, - $ AS,BS,CS,DPSI,PSIMIN,PSIMAX,PRESET,QTIME, - $ TMAX,PA,PM,IHMAX,IKMAX,ILMAX,NCOND,ICOND, - $ IHS,IKS,ILS,IR,IS,STEP,STEPOF, - $ DFTYPE,DFMODL,NSTAN,NINTRR, - $ IHSTAN,IKSTAN,ILSTAN - READ (IID,REC=2) NSEG,NMSEG, - $ NREF,NMSTAN,NBLOCK,IHO,IKO,ILO,IND,ITYPE, - $ AP,APS,CANGS,SANGS,CANG,SANG,JMIN,JMAX, - $ RTHETA,ROMEGA,RCHI,RPHI,IH,IK,IL, - $ NINTOR,REOTOL,NATTEN,ATTEN,ICADSL,ICADSW - READ (IID,REC=3) IDH,ISCAN,FRAC,IBSECT,IPRFLG,ISYS,SINABS, - $ ILN,DELAY - READ (IID,REC=10) SGSYMB - IF (KI .EQ. 'RB') KI = ' ' - ELSE -C----------------------------------------------------------------------- -C If called from GOLOOP, or WB, or creating file, write to IDATA -C If called from WB, write to IDATA after confirming -C----------------------------------------------------------------------- - IF (KI .EQ. 'WB') THEN - WRITE (COUT,11000) - CALL YESNO ('Y',ANS) - IF (ANS .EQ. 'N') THEN - KI = ' ' - RETURN - ENDIF - ENDIF - CALL ANGET (RTHETA,ROMEGA,RCHI,RPHI) - WRITE (IID,REC=1) R,WAVE,DCHI,DOMEGA,DTHETA,THEMIN,THEMAX, - $ AS,BS,CS,DPSI,PSIMIN,PSIMAX,PRESET,QTIME, - $ TMAX,PA,PM,IHMAX,IKMAX,ILMAX,NCOND,ICOND, - $ IHS,IKS,ILS,IR,IS,STEP,STEPOF, - $ DFTYPE,DFMODL,NSTAN,NINTRR, - $ IHSTAN,IKSTAN,ILSTAN - WRITE (IID,REC=2) NSEG,NMSEG, - $ NREF,NMSTAN,NBLOCK,IHO,IKO,ILO,IND,ITYPE, - $ AP,APS,CANGS,SANGS,CANG,SANG,JMIN,JMAX, - $ RTHETA,ROMEGA,RCHI,RPHI,IH,IK,IL, - $ NINTOR,REOTOL,NATTEN,ATTEN,ICADSL,ICADSW - WRITE (IID,REC=3) IDH,ISCAN,FRAC,IBSECT,IPRFLG,ISYS,SINABS, - $ ILN,DELAY - WRITE (IID,REC=10) SGSYMB -C----------------------------------------------------------------------- -C Now force an update of the directory by closing and reopening IID -C----------------------------------------------------------------------- - IDREC = 85*IBYLEN - STATUS = 'OD' - CALL IBMFIL (IDNAME,-IID,IDREC,STATUS,IERR) - CALL IBMFIL (IDNAME, IID,IDREC,STATUS,IERR) - IF (KI .EQ. 'WB') KI = ' ' - ENDIF - RETURN -10000 FORMAT (' Read the Basic Data (Y) ? ',$) -11000 FORMAT (' Write the Basic Data (Y) ? ',$) - END diff --git a/difrac/wxw2t.f b/difrac/wxw2t.f deleted file mode 100644 index d392eb6c..00000000 --- a/difrac/wxw2t.f +++ /dev/null @@ -1,85 +0,0 @@ -C----------------------------------------------------------------------- -C Routine to align a reflection as follows :-- -C 1. For Euler 4-circle machines. -C Centre omega, omega/2theta, chi, omega, 2omega/-theta. -C 2. For Kappa machines. -C Centre omega/2theta, theta(-45slit), theta(+45slit) -C----------------------------------------------------------------------- - SUBROUTINE WXW2T (DT,DO,DC,ISLIT) - INCLUDE 'COMDIF' - DIMENSION ANG(4) - CALL SHUTTR (99) -C----- a fixed value for PHI alignement, MK - DP = .1 -C----- debug message: MK - WRITE(COUT,22)DT, DO, DC - 22 FORMAT('STEP OM: ',F8.2,' Step TH: ',F8.2,' Step CH: ',F8.2) - CALL GWRITE(ITP,' ') -C----------------------------------------------------------------------- -C For the CAD-4 centering is as follows :-- -C 1. an omega/2theta scan with the 4mm variable slit, -C 2. a) a 2theta scan with the negative 45deg slit, -C b) a 2theta scan with the positive 45deg slit. -C c) the best 2theta and chi values are then calculated. -C----------------------------------------------------------------------- - IF (DFMODL .EQ. 'CAD4') THEN - KI = 'WT' - CALL CENTRE (DT,ANG,ISLIT) - IF (KI .EQ. 'FF') GO TO 100 - KI = 'ST' - CALL CENTRE (DT,ANG,0) - IF (KI .EQ. 'FF') GO TO 100 - ELSE -C----------------------------------------------------------------------- -C Align Omega -C----------------------------------------------------------------------- - KI = 'SO' - CALL CENTRE (DO,ANG,0) - IF (KI .EQ. 'FF') GO TO 100 -C----------------------------------------------------------------------- -C Align 2Theta the first time (Insert 7-May-81) -C----------------------------------------------------------------------- - KI = 'ST' - CALL CENTRE (DT,ANG,0) - IF (KI .EQ. 'FF') GO TO 100 -C----------------------------------------------------------------------- -C Align Chi -C----------------------------------------------------------------------- - KI = 'SC' - CALL CENTRE (DC,ANG,0) - IF (KI .EQ. 'FF') GO TO 100 -C----------------------------------------------------------------------- -C Align Phi -C---------------------------------------------------------------------- - KI = 'SP' - CALL CENTRE(DP,ANG,0) - IF (KI .EQ. 'FF') GO TO 100 -C----------------------------------------------------------------------- -C Omega again -C----------------------------------------------------------------------- - KI = 'SO' - CALL CENTRE (DO,ANG,0) - IF (KI .EQ. 'FF') GO TO 100 - IF (KI .EQ. 'FP') GO TO 100 -C----------------------------------------------------------------------- -C Align 2Theta -C---------------------------------------------------------------------- - KI = 'ST' - CALL CENTRE (DT,ANG,0) - IF (KI .EQ. 'FF') GO TO 100 - IF (KI .EQ. 'FP') GO TO 100 - ENDIF -C----------------------------------------------------------------------- -C The answers are passed in BPSI in COMMON -C----------------------------------------------------------------------- - RTHETA = ANG(1) - ROMEGA = ANG(2) - RCHI = ANG(3) - RPHI = ANG(4) - THETA = RTHETA - OMEGA = ROMEGA - CHI = RCHI - PHI = RPHI - 100 CALL SHUTTR (-99) - RETURN - END diff --git a/difrac/yesno.f b/difrac/yesno.f deleted file mode 100644 index 068f6550..00000000 --- a/difrac/yesno.f +++ /dev/null @@ -1,48 +0,0 @@ -C----------------------------------------------------------------------- -C Routine YESNO to get Yes/No (Y or N) answers to questions. -C It is called with two parameters :-- -C 1. DEFOLT is set to 'Y', 'N' or '$' by the caller depending -C on the expected default; -C 2. ANSWER is the value of the returned answer. -C -C Responses are filtered so that only blank, null (i.e. CR ), Y, y, -C N or n are acceptable answers at the terminal. -C If DEFOLT is set to '$' the typed answer must be Y, y, N or n, -C no default is allowed. -C If the character typed is a question mark the routine exits to the -C system monitor. -C -C Version modified to support non-Fortran screen I/O -C----------------------------------------------------------------------- - SUBROUTINE YESNO (DEFOLT,ANS) - COMMON /IOUASS/ IOUNIT(12) - CHARACTER*132 COUT(20) - COMMON /IOUASC/ COUT - CHARACTER DEFOLT*1,ANS*1,LINE*80 - ITR = IOUNIT(5) - ITP = IOUNIT(6) -C----------------------------------------------------------------------- -C This code gets round IBM VM/CMS limitations -C----------------------------------------------------------------------- - 100 CALL GWRITE (ITP,'$') - CALL GETLIN (LINE) - ANS=LINE(1:1) - IF (ANS .EQ. '?') STOP - IF (ANS .EQ. 'y') ANS = 'Y' - IF (ANS .EQ. 'n') ANS = 'N' - IF ((DEFOLT .EQ. 'Y' .OR. DEFOLT .EQ. 'N') .AND. ANS .EQ. ' ') - $ ANS = DEFOLT - IF (ANS .EQ. 'Y' .OR. ANS .EQ. 'N') RETURN - IF (DEFOLT .EQ. '$') THEN - WRITE (COUT,11000) - GO TO 100 - ELSE - WRITE (COUT,12000) - GO TO 100 - ENDIF -10000 FORMAT (A) -11000 FORMAT (' The typed response must be Y, y, N or n. Try again', - $ ' please.') -12000 FORMAT (' The typed response must be Y, y, N, n or .', - $ ' Try again please.') - END diff --git a/dilludriv.c b/dilludriv.c deleted file mode 100644 index 800f332e..00000000 --- a/dilludriv.c +++ /dev/null @@ -1,272 +0,0 @@ -/*-------------------------------------------------------------------------- - D I L L U D R I V - - This file contains the implementation of a driver for the Oxford - Instruments dillution cryostat using the CC0-510/AVSI temperature - controller. - - - Mark Koennecke, October 1997 - - Copyright: see copyright.h -----------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include -#include "fortify.h" -#include "conman.h" -#include "servlog.h" -#include "fortify.h" - - typedef struct __EVDriver *pEVDriver; - -#include "evdriver.i" -#include "hardsup/dillutil.h" -#include "hardsup/el734_def.h" -#include "hardsup/el734fix.h" -#include "dilludriv.h" - -/*-----------------------------------------------------------------------*/ - typedef struct { - pDILLU pData; - char *pHost; - int iPort; - int iChannel; - int iLastError; - char *pTranslationFile; - } DILLUDriv, *pDILLUDriv; -/*----------------------------------------------------------------------------*/ - static int GetDILLUPos(pEVDriver self, float *fPos) - { - pDILLUDriv pMe = NULL; - int iRet; - - assert(self); - pMe = (pDILLUDriv)self->pPrivate; - assert(pMe); - - iRet = DILLU_Read(&pMe->pData,fPos); - if(iRet != 1 ) - { - pMe->iLastError = iRet; - return 0; - } - if( (*fPos < 0) || (*fPos > 1000) ) - { - *fPos = -999.; - return 0; - } - return 1; - } -/*----------------------------------------------------------------------------*/ - static int DILLURun(pEVDriver self, float fVal) - { - pDILLUDriv pMe = NULL; - int iRet; - - assert(self); - pMe = (pDILLUDriv )self->pPrivate; - assert(pMe); - - iRet = DILLU_Set(&pMe->pData,fVal); - if(iRet != 1) - { - pMe->iLastError = iRet; - return 0; - } - return 1; - } -/*--------------------------------------------------------------------------*/ - static int DILLUError(pEVDriver self, int *iCode, char *error, int iErrLen) - { - pDILLUDriv pMe = NULL; - - assert(self); - pMe = (pDILLUDriv)self->pPrivate; - assert(pMe); - - *iCode = pMe->iLastError; - DILLU_Error2Text(&pMe->pData,pMe->iLastError,error,iErrLen); - - return 1; - } -/*--------------------------------------------------------------------------*/ - static int DILLUSend(pEVDriver self, char *pCommand, char *pReply, int iLen) - { - pDILLUDriv pMe = NULL; - int iRet; - - assert(self); - pMe = (pDILLUDriv )self->pPrivate; - assert(pMe); - - iRet = DILLU_Send(&pMe->pData,pCommand, pReply,iLen); - if(iRet != 1) - { - pMe->iLastError = iRet; - return 0; - } - return 1; - - } -/*--------------------------------------------------------------------------*/ - static int DILLUInit(pEVDriver self) - { - pDILLUDriv pMe = NULL; - int iRet; - - assert(self); - pMe = (pDILLUDriv )self->pPrivate; - assert(pMe); - - pMe->pData = NULL; - iRet = DILLU_Open(&pMe->pData, pMe->pHost, pMe->iPort, pMe->iChannel, - 0,pMe->pTranslationFile); - if(iRet != 1) - { - pMe->iLastError = iRet; - return 0; - } - DILLU_Config(&pMe->pData, 1000); - return 1; - } -/*--------------------------------------------------------------------------*/ - static int DILLUClose(pEVDriver self) - { - pDILLUDriv pMe = NULL; - int iRet; - - assert(self); - pMe = (pDILLUDriv )self->pPrivate; - assert(pMe); - - DILLU_Close(&pMe->pData); - return 1; - } -/*---------------------------------------------------------------------------*/ - static int DILLUFix(pEVDriver self, int iError) - { - pDILLUDriv pMe = NULL; - int iRet; - - assert(self); - pMe = (pDILLUDriv )self->pPrivate; - assert(pMe); - - switch(iError) - { - /* network errors */ - case EL734__BAD_FLUSH: - case EL734__BAD_RECV: - case EL734__BAD_RECV_NET: - case EL734__BAD_RECV_UNKN: - case EL734__BAD_RECVLEN: - case EL734__BAD_RECV1: - case EL734__BAD_RECV1_PIPE: - case EL734__BAD_RNG: - case EL734__BAD_SEND: - case EL734__BAD_SEND_PIPE: - case EL734__BAD_SEND_NET: - case EL734__BAD_SEND_UNKN: - case EL734__BAD_SENDLEN: - DILLUClose(self); - iRet = DILLUInit(self); - if(iRet) - { - return DEVREDO; - } - else - { - return DEVFAULT; - } - break; - /* handable protocoll errors */ - case EL734__BAD_TMO: - return DEVREDO; - break; - case DILLU__NODILLFILE: - case DILLU__ERRORTABLE: - case DILLU__READONLY: - case DILLU__OUTOFRANGE: - case DILLU__BADMALLOC: - case DILLU__FILENOTFOUND: - return DEVFAULT; - case DILLU__BADREAD: - case DILLU__SILLYANSWER: - return DEVREDO; - default: - return DEVFAULT; - break; - } - return DEVFAULT; - } - -/*--------------------------------------------------------------------------*/ - static int DILLUHalt(pEVDriver *self) - { - assert(self); - - return 1; - } -/*------------------------------------------------------------------------*/ - void KillDILLU(void *pData) - { - pDILLUDriv pMe = NULL; - - pMe = (pDILLUDriv)pData; - assert(pMe); - - if(pMe->pHost) - { - free(pMe->pHost); - } - if(pMe->pTranslationFile) - { - free(pMe->pTranslationFile); - } - free(pMe); - } -/*------------------------------------------------------------------------*/ - pEVDriver CreateDILLUDriv(int argc, char *argv[]) - { - pEVDriver pNew = NULL; - pDILLUDriv pSim = NULL; - - /* check for arguments */ - if(argc < 3) - { - return NULL; - } - - pNew = CreateEVDriver(argc,argv); - pSim = (pDILLUDriv)malloc(sizeof(DILLUDriv)); - memset(pSim,0,sizeof(DILLUDriv)); - if(!pNew || !pSim) - { - return NULL; - } - pNew->pPrivate = pSim; - pNew->KillPrivate = KillDILLU; - - /* initalise pDILLUDriver */ - pSim->iLastError = 0; - pSim->pHost = strdup(argv[0]); - pSim->iPort = atoi(argv[1]); - pSim->iChannel = atoi(argv[2]); - pSim->pTranslationFile = strdup(argv[3]); - - - /* initialise function pointers */ - pNew->SetValue = DILLURun; - pNew->GetValue = GetDILLUPos; - pNew->Send = DILLUSend; - pNew->GetError = DILLUError; - pNew->TryFixIt = DILLUFix; - pNew->Init = DILLUInit; - pNew->Close = DILLUClose; - - return pNew; - } - \ No newline at end of file diff --git a/dilludriv.h b/dilludriv.h deleted file mode 100644 index 19e0b43c..00000000 --- a/dilludriv.h +++ /dev/null @@ -1,15 +0,0 @@ -/*------------------------------------------------------------------------ - D I L L U D R I V - - A SICS driver for thedillution cryostat using the CCO-510/AVSI - controller. - - Mark Koennecke, October 1997 - - copyright: see copyright.h ----------------------------------------------------------------------------*/ -#ifndef DILLUDRIV -#define DILLUDRIV - pEVDriver CreateDILLUDriv(int argc, char *argv[]); - -#endif \ No newline at end of file diff --git a/dmc.c b/dmc.c deleted file mode 100644 index 31614cff..00000000 --- a/dmc.c +++ /dev/null @@ -1,54 +0,0 @@ -/*------------------------------------------------------------------------- - D M C - - this modules purpose is solely to initialise the commands specific to - the powder diffractometer DMC. - - Mark Koenencke, March 1997 - - Copyright: - - Labor fuer Neutronenstreuung - Paul Scherrer Institut - CH-5423 Villigen-PSI - - - The authors hereby grant permission to use, copy, modify, distribute, - and license this software and its documentation for any purpose, provided - that existing copyright notices are retained in all copies and that this - notice is included verbatim in any distributions. No written agreement, - license, or royalty fee is required for any of the authorized uses. - Modifications to this software may be copyrighted by their authors - and need not follow the licensing terms described here, provided that - the new terms are clearly indicated on the first page of each file where - they apply. - - IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY - FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY - DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - - THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE - IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE - NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR - MODIFICATIONS. -----------------------------------------------------------------------------*/ -#include -#include -#include -#include "fortify.h" -#include "conman.h" -#include "obdes.h" -#include "napi.h" -#include "nxdata.h" -#include "dmc.h" - - int InitDmc(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - AddCommand(pSics,"StoreData",SNStoreDMC,NULL,NULL); - return 1; - } diff --git a/dmc.h b/dmc.h deleted file mode 100644 index aee4fb39..00000000 --- a/dmc.h +++ /dev/null @@ -1,19 +0,0 @@ - -/*------------------------------------------------------------------------- - D M C - - this modules purpose is solely to initialise the commands specific to - the powder diffractometer DMC. - - Mark Koenencke, March 1997 - - copyright: see implementation file. - ---------------------------------------------------------------------------*/ -#ifndef SICSDMC -#define SICSDMC - - int InitDmc(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - -#endif diff --git a/dmc.tex b/dmc.tex deleted file mode 100644 index 8e52573b..00000000 --- a/dmc.tex +++ /dev/null @@ -1,48 +0,0 @@ -\subsection{DMC module} -This module initialises all DMC specific commands. Currently there is only -one: StoreData. This does not do much, it is just here as a container for -things to come. - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap1} -$\langle$Protos {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ int InitDmc(SConnection *pCon, SicsInterp *pSics, void *pData, @\\ -\mbox{}\verb@ int argc, char *argv[]);@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap2} -\verb@"dmc.h"@ {\footnotesize ? }$\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@/*-------------------------------------------------------------------------@\\ -\mbox{}\verb@ D M C @\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ this modules purpose is solely to initialise the commands specific to@\\ -\mbox{}\verb@ the powder diffractometer DMC.@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ Mark Koenencke, March 1997@\\ -\mbox{}\verb@ @\\ -\mbox{}\verb@ copyright: see implementation file.@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@--------------------------------------------------------------------------*/@\\ -\mbox{}\verb@#ifndef SICSDMC@\\ -\mbox{}\verb@#define SICSDMC@\\ -\mbox{}\verb@@$\langle$Protos {\footnotesize ?}$\rangle$\verb@@\\ -\mbox{}\verb@#endif@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-2ex} -\end{minipage}\\[4ex] -\end{flushleft} diff --git a/dmc.w b/dmc.w deleted file mode 100644 index 347b6824..00000000 --- a/dmc.w +++ /dev/null @@ -1,27 +0,0 @@ -\subsection{DMC module} -This module initialises all DMC specific commands. Currently there is only -one: StoreData. This does not do much, it is just here as a container for -things to come. - -@d Protos @{ - int InitDmc(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); -@} - -@o dmc.h @{ -/*------------------------------------------------------------------------- - D M C - - this modules purpose is solely to initialise the commands specific to - the powder diffractometer DMC. - - Mark Koenencke, March 1997 - - copyright: see implementation file. - ---------------------------------------------------------------------------*/ -#ifndef SICSDMC -#define SICSDMC -@< Protos @> -#endif -@} \ No newline at end of file diff --git a/docho.c b/docho.c deleted file mode 100644 index 6a0dd96b..00000000 --- a/docho.c +++ /dev/null @@ -1,747 +0,0 @@ -/*-------------------------------------------------------------------------- - D o C h o - - - A SICS driver for a Dornier Chopper Control System accessed through a - RS-232 interface connected to a Macintosh PC running the SerialPortServer - terminal server program. There are two choppers which ususally run at fixed - speed ratios against each other. There ia also a phase difference between - the two choppers. And lots of machine surveillance parameters. - - This driver is used by the generic chopper or device controller as described - in choco.tex. - - - Mark Koennecke, January 1999 - - Modified to support a single chopper only, - - Uwe Filges, Mark Koennecke; November 2001 ---------------------------------------------------------------------------*/ -#include -#include -#include -#include "fortify.h" -#include "sics.h" -#include "stringdict.h" -#include "hardsup/serialsinq.h" -#include "hardsup/el734_errcodes.h" -#include "hardsup/el734fix.h" -#include "codri.h" - -/*----------------------------------------------------------------------- - A private data structure for this Dornier chopper --------------------------------------------------------------------------*/ - typedef struct { - char *pHost; - int iPort; - int iChannel; - void *pData; - int iRefreshIntervall; - pStringDict pPar; - time_t tRefresh; - int iStop; - long lTask; - int iError; - int iBusy; - float fRatio; - int iSingle; - char pError[80]; - } DoCho, *pDoCho; -/* - pHost, iPort and iChannel combined are the adress of the chopper - controller at the Macintosh terminal server. pData is the serial - port connection data structure needed and managed by the SerialIO - functions. - - As the communication with the Dornier Chopper System is very slow the - parameter list of this driver will only be updated a predefined time - intervalls. In between buffered values will be returned for requests. - The buffered parameters are held in the string dictioanry pPar. - iRefreshIntervall is the time between refreshs. tRefresh is the time for - the next refresh. iBusy is flag which indicates, that it was tried to - modify a variable. This will only be reflected with the next status update. - In between DoChoCheckPar might conclude, that the chopper is already - done. iBusy is meant to stop that. It is set when a parameter is changed - and cleared bu the status message code. DoChoCheckPar checks for it. - - Refreshing will be performed by a special SICS task which will be - started when the driver is initialized. In order to stop this task when - need arises the parameter iStop can be set to true. - - iError is the last error reported on this device. If no error: 0 - - fRatio is the target value for the chopper ratio. In contrast to the - other parameters, its target value cannot be extracted from the chopper - status message. - - iSingle is a flag which is true if only a single chopper is controlled - through this driver. This supports the POLDI single choper case. - -*/ -/*---------------------------------------------------------------------- - ERROR CODES: -*/ -#define UNDRIVABLE -8002 -#define UNKNOWNPAR -8003 -#define PARERROR -8004 -#define BADSYNC -8005 -#define BADSTOP -8006 -#define CHOPERROR -8007 - -extern char *trim(char *pTrim); /* trim.c */ - -/*----------------------------------------------------------------------*/ -static void SplitChopperReply(pCodri self, char *prefix, char *pBueffel) -{ - char pToken[30], pValue[20], pEntry[80]; - char *pPtr, *pTok, *pVal; - int iCount, iRet; - pDoCho pPriv = NULL; - - pPriv = (pDoCho)self->pPrivate; - - /* decompose pBueffel and store into string dictionary */ - pPtr = strtok(pBueffel,";"); - while(pPtr != NULL) - { - iCount = sscanf(pPtr,"%s %s",pToken,pValue); - if(iCount == 2) - { - pTok = trim(pToken); - pVal = trim(pValue); - pEntry[0] = '\0'; - sprintf(pEntry,"%s.%s",prefix,pTok); - iRet = StringDictUpdate(pPriv->pPar,pEntry,pVal); - if(!iRet) - { - StringDictAddPair(pPriv->pPar,pEntry,pVal); - strcat(self->pParList,pEntry); - strcat(self->pParList,","); - } - } - else - { - /* this fixes a bug with oversized messages in dphas */ - if(strstr(pPtr,"dphas") != NULL) - { - sprintf(pEntry,"%s.dphas",prefix); - iRet = StringDictUpdate(pPriv->pPar, - pEntry,pPtr+5); - if(!iRet) - { - StringDictAddPair(pPriv->pPar,pEntry, - pPtr+5); - strcat(self->pParList,pEntry); - strcat(self->pParList,","); - } - } - } - pPtr = strtok(NULL,";"); - } -} -/*------------------------------------------------------------------------- - Well, DoChoStatus sends a status request to the Dornier chopper control - system. There is a gotcha, you need three reads to get the full information. - Then the answer is parsed and decomposed into parameter content for the - string dictionary. The single status components are separated by ;. --------------------------------------------------------------------------*/ - - static int DoChoStatus(pCodri self) - { - int iRet, iCount, iCode; - char pBueffel[1024], pToken[30], pValue[20]; - char *pPtr, *pTok, *pVal; - pDoCho pPriv = NULL; - - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - pPriv->iBusy = 0; - pPriv->iError = 0; - - - /* first send, command, returns the echo */ - iRet = SerialWriteRead(&(pPriv->pData),"asyst 1",pBueffel,1023); - if(iRet < 0) - { - pPriv->iError = iRet; - return 0; - } - - /* next send: reads first chopper line */ - iRet = SerialWriteRead(&(pPriv->pData),"",pBueffel,1023); - if(iRet < 0) - { - pPriv->iError = iRet; - return 0; - } - SplitChopperReply(self,"chopper1",pBueffel); - - if(!pPriv->iSingle) - { - /* second send: get next second chopper line */ - iRet = SerialWriteRead(&(pPriv->pData),"",pBueffel,1023); - if(iRet < 0) - { - pPriv->iError = iRet; - return 0; - } - SplitChopperReply(self,"chopper2",pBueffel); - } - - - return 1; - } -/*-------------------------------------------------------------------------*/ - static int DoChoTask(void *pData) - { - pCodri self = NULL; - pDoCho pPriv = NULL; - int iCode, iRet; - char pDummy[60]; - - self = (pCodri)pData; - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - - /* check for stop */ - if(pPriv->iStop) - return 0; - - - /* check if it is time to run a status request */ - if(time(NULL) > pPriv->tRefresh) - { - /* try, fix error */ - if(pPriv->iError != 0) - { - self->GetError(self,&iCode,pDummy,59); - iRet = self->TryFixIt(self,iCode); - if(iRet == CHFAIL) - { - pPriv->tRefresh = time(NULL) + pPriv->iRefreshIntervall; - return 1; - } - } - /* do it */ - DoChoStatus(self); - pPriv->tRefresh = time(NULL) + pPriv->iRefreshIntervall; - } - return 1; - } -/*------------------------------------------------------------------------*/ - static void DoChoKill(void *pData) - { - pCodri self = NULL; - pDoCho pPriv = NULL; - - self = (pCodri)pData; - if(!self) - return; - pPriv = (pDoCho)self->pPrivate; - if(!pPriv) - return; - - - if(pPriv->pData) - { - SerialClose(&(pPriv->pData)); - pPriv->pData = NULL; - } - - if(pPriv->pHost) - free(pPriv->pHost); - if(pPriv->pPar) - DeleteStringDict(pPriv->pPar); - - free(pPriv); - } -/*-------------------------------------------------------------------------*/ - static int DoChoInit(pCodri self) - { - pDoCho pPriv = NULL; - int iRet; - - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - pPriv->iError = 0; - - /* first open the connection to the serial port server and channel */ - iRet = SerialOpen(&(pPriv->pData),pPriv->pHost,pPriv->iPort, - pPriv->iChannel); - if(iRet <= 0) - { - pPriv->iError = iRet; - return 0; - } - /* configure the connection */ - SerialConfig(&(pPriv->pData),10000); - SerialATerm(&(pPriv->pData),"1\r\n"); - SerialSendTerm(&(pPriv->pData),"\r"); - - pPriv->iStop = 0; - pPriv->tRefresh = 0; /* force a status request when first run */ - - /* start the update task */ - if(pPriv->lTask == 0) - { - pPriv->lTask = TaskRegister(pServ->pTasker, - DoChoTask, - NULL, - NULL, - self, - 1); - } - return 1; - } -/*------------------------------------------------------------------------*/ - static int DoChoClose(pCodri self) - { - pDoCho pPriv = NULL; - int iRet; - long lVal; - - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - - if(pPriv->pData) - { - SerialClose(&(pPriv->pData)); - pPriv->pData = NULL; - } - return 1; - } -/*------------------------------------------------------------------------*/ - static int DoChoDelete(pCodri self) - { - pDoCho pPriv = NULL; - - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - - if(pPriv->pData) - { - SerialClose(&(pPriv->pData)); - pPriv->pData = NULL; - } - - if(pPriv->pHost) - free(pPriv->pHost); - if(pPriv->pPar) - DeleteStringDict(pPriv->pPar); - - free(pPriv); - - return 1; - } -/*--------------------------------------------------------------------------*/ - static int DoChoSetPar2(pCodri self, char *parname, char *pValue) - { - pDoCho pPriv = NULL; - char pCommand[80], pReply[132]; - char pState[20]; - int iRet; - - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - - /* deal with our four parameters */ - if(strcmp(parname,"chopper1.nspee") == 0) - { - sprintf(pCommand,"nspee 1 %s",pValue); - } - else if(strcmp(parname,"chopper2.nspee") == 0) - { - iRet = StringDictGet(pPriv->pPar,"chopper2.state",pState,19); - if(iRet && strstr(pState,"async") != NULL ) - { - sprintf(pCommand,"nspee 2 %s",pValue); - } - else - { - pPriv->iError = BADSYNC; - return 0; - } - } - else if(strcmp(parname,"chopper2.nphas") == 0) - { - sprintf(pCommand,"nphas 2 %s",pValue); - } - else if(strcmp(parname,"chopper2.ratio") == 0) - { - sprintf(pCommand,"ratio 2 %s",pValue); - } - else - { - pPriv->iError = UNDRIVABLE; - return 0; - } - - iRet = SerialWriteRead(&(pPriv->pData),pCommand,pReply,131); - if(iRet != 1) - { - pPriv->iError = iRet; - return 0; - } - if(strstr(pReply,"error") != NULL) - { - pPriv->iError = CHOPERROR; - strncpy(pPriv->pError,pReply,79); - return 0; - } - else - { - pPriv->iError = 0; - } - pPriv->iBusy = 1; - return 1; - } -/*-------------------------------------------------------------------------*/ - static int DoChoHalt(pCodri self) - { - pDoCho pPriv = NULL; - - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - - /* - there is no documented way to stop the Dornier chopper - system. This at least makes SICS happy. - */ - pPriv->iError = BADSTOP; - pPriv->iBusy = 0; - return 1; - } -/*---------------------------------------------------------------------------*/ - static int DoChoSetPar(pCodri self, char *parname, float fValue) - { - char pValue[50]; - pDoCho pPriv = NULL; - - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - - if(strstr(parname,"nspee") != NULL) - { - sprintf(pValue,"%d",(int)fValue); - } - else if(strstr(parname,"ratio") != NULL) - { - sprintf(pValue,"%d",(int)fValue); - pPriv->fRatio = (int)fValue; - } - else if(strcmp(parname,"updateintervall") == 0) - { - sprintf(pValue,"%d",(int)fValue); - StringDictUpdate(pPriv->pPar,"updateintervall",pValue); - pPriv->iRefreshIntervall = (int)fValue; - return 1; - } - else - { - sprintf(pValue,"%f",fValue); - } - return DoChoSetPar2(self,parname, pValue); - } -/*----------------------------------------------------------------------*/ - static int DoChoGetPar(pCodri self, char *parname, - char *pBuffer, int iBufLen) - { - pDoCho pPriv = NULL; - int iRet; - - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - - if(pPriv->iError != 0) - { - self->GetError(self,&iRet,pBuffer,iBufLen); - return 0; - } - - iRet = StringDictGet(pPriv->pPar,parname,pBuffer,iBufLen); - if(!iRet) - { - pPriv->iError = UNKNOWNPAR; - return 0; - } - return 1; - } -/*-----------------------------------------------------------------------*/ - static int DoChoCheckPar(pCodri self, char *parname) - { - pDoCho pPriv = NULL; - char pVal1[20], pVal2[20]; - float fTarget, fIst, fDelta; - int iRet; - - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - - /* check the busy flag first */ - if(pPriv->iBusy) - return HWBusy; - - /* was there an error in the status show? */ - if(pPriv->iError != 0) - { - return HWFault; - } - - /* updateintervall is always HWIdle */ - if(strcmp(parname,"updateintervall") == 0) - { - return HWIdle; - } - - /* OK, got a new status let us check the parameter */ - /* chopper 1 speed */ - if(strcmp(parname,"chopper1.nspee") == 0) - { - iRet = StringDictGet(pPriv->pPar,"chopper1.nspee",pVal1,19); - iRet += StringDictGet(pPriv->pPar,"chopper1.aspee",pVal2,19); - if(iRet != 2) - { - pPriv->iError = PARERROR; - return HWFault; - } - sscanf(pVal1,"%f",&fTarget); - sscanf(pVal2,"%f",&fIst); - fDelta = fTarget - fIst; - if(fDelta < 0.0) - fDelta = -fDelta; - if(fDelta > 50) - { - return HWBusy; - } - else - { - return HWIdle; - } - } - /* chopper 2 speed */ - if(strcmp(parname,"chopper2.nspee") == 0) - { - iRet = StringDictGet(pPriv->pPar,"chopper2.nspee",pVal1,19); - iRet += StringDictGet(pPriv->pPar,"chopper2.aspee",pVal2,19); - if(iRet != 2) - { - pPriv->iError = PARERROR; - return HWFault; - } - sscanf(pVal1,"%f",&fTarget); - sscanf(pVal2,"%f",&fIst); - fDelta = fTarget - fIst; - if(fDelta < 0.0) - fDelta = -fDelta; - if(fDelta > 5.) - { - return HWBusy; - } - else - { - return HWIdle; - } - } - - /* phase */ - if(strcmp(parname,"chopper2.nphas") == 0) - { - iRet = StringDictGet(pPriv->pPar,"chopper2.dphas",pVal1,19); - sscanf(pVal1,"%f",&fDelta); - if(fDelta < 0.) - fDelta = - fDelta; - if(fDelta > 0.3) - { - return HWBusy; - } - else - { - return HWIdle; - } - } - - /* ratio */ - if(strcmp(parname,"chopper2.ratio") == 0) - { - iRet = StringDictGet(pPriv->pPar,"chopper2.ratio",pVal1,19); - sscanf(pVal1,"%f",&fIst); - fDelta = fIst - pPriv->fRatio; - if(fDelta < 0.) - fDelta = - fDelta; - if(fDelta > 0.3) - { - return HWBusy; - } - else - { - return HWIdle; - } - } - pPriv->iError = UNKNOWNPAR; - return HWFault; - } -/*-------------------------------------------------------------------------*/ - static int DoChoError(pCodri self, int *iCode, char *pError, int iLen) - { - pDoCho pPriv = NULL; - - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - - *iCode = pPriv->iError; - switch(pPriv->iError) - { - case UNDRIVABLE: - strncpy(pError,"Parameter is not drivable",iLen); - break; - case UNKNOWNPAR: - strncpy(pError,"Parameter is unknown",iLen); - break; - case PARERROR: - strncpy(pError,"Internal parameter error",iLen); - break; - case BADSYNC: - strncpy(pError,"Cannot drive slave chopper",iLen); - break; - case CHOPERROR: - strncpy(pError,pPriv->pError,iLen); - break; - case BADSTOP: - strncpy(pError, - "User called STOP. WARNING: chopper is still untamed!", - iLen); - break; - default: - SerialError(pPriv->iError,pError,iLen); - break; - } - pPriv->iError = 0; - return 1; - } -/*------------------------------------------------------------------------*/ - static int DoChoFix(pCodri self, int iCode) - { - pDoCho pPriv = NULL; - int iRet; - - assert(self); - pPriv = (pDoCho)self->pPrivate; - assert(pPriv); - - switch(iCode) - { - /* network errors */ - case EL734__BAD_FLUSH: - case EL734__BAD_RECV: - case EL734__BAD_RECV_NET: - case EL734__BAD_RECV_UNKN: - case EL734__BAD_RECVLEN: - case EL734__BAD_RECV1: - case EL734__BAD_RECV1_PIPE: - case EL734__BAD_RNG: - case EL734__BAD_SEND: - case EL734__BAD_SEND_PIPE: - case EL734__BAD_SEND_NET: - case EL734__BAD_SEND_UNKN: - case EL734__BAD_SENDLEN: - case NOCONNECTION: - SerialForceClose(&(pPriv->pData)); - pPriv->pData = NULL; - iRet = SerialOpen(&(pPriv->pData),pPriv->pHost, - pPriv->iPort,pPriv->iChannel); - if(iRet == 1 ) - { - return CHREDO; - } - else - { - return CHFAIL; - } - break; - case EL734__FORCED_CLOSED: - iRet = DoChoInit(self); - if(iRet) - { - return CHREDO; - } - else - { - return CHFAIL; - } - break; - default: - return CHFAIL; - break; - } - return CHFAIL; - } -/*-------------------------------------------------------------------------*/ - pCodri MakeDoChoDriver(char *pHost, int iPort, int iChannel, int iSingle) - { - pCodri pNew = NULL; - pDoCho pPriv = NULL; - char *pText; - - /* allocate memory */ - pText = (char *)malloc(4096*sizeof(char)); - pNew = (pCodri)malloc(sizeof(Codri)); - pPriv = (pDoCho)malloc(sizeof(DoCho)); - if( !pText || !pNew || !pPriv) - { - return NULL; - } - memset(pText,0,4096); - memset(pNew,0,sizeof(Codri)); - memset(pPriv,0,sizeof(DoCho)); - - /* initialize private data structure */ - pPriv->pHost = strdup(pHost); - pPriv->iPort = iPort; - pPriv->iChannel = iChannel; - pPriv->pData = NULL; - pPriv->iRefreshIntervall = 60; - pPriv->pPar = CreateStringDict(); - pPriv->tRefresh = time(NULL); - pPriv->iSingle = iSingle; - if(!pPriv->pPar) - { - free(pText); - free(pNew); - free(pPriv); - return NULL; - } - - /* install codri */ - pNew->Init = DoChoInit; - pNew->Close = DoChoClose; - pNew->Delete = DoChoDelete; - pNew->SetPar = DoChoSetPar; - pNew->SetPar2 = DoChoSetPar2; - pNew->GetPar = DoChoGetPar; - pNew->CheckPar = DoChoCheckPar; - pNew->GetError = DoChoError; - pNew->TryFixIt = DoChoFix; - pNew->Halt = DoChoHalt; - pNew->pParList = pText; - strcpy(pNew->pParList,"updateintervall,"); - StringDictAddPair(pPriv->pPar,"updateintervall","60"); - pNew->pPrivate = pPriv; - - return pNew; - } - - - - diff --git a/dummy/dummy.c b/dummy/dummy.c new file mode 100644 index 00000000..a86124d9 --- /dev/null +++ b/dummy/dummy.c @@ -0,0 +1,102 @@ +/*------------------------------------------------------------------------ + D U M M Y + + This is an empty site interface for SICS. Can be used as a starting + point for own site specific stuff. + + copyright: see file COPYRIGHT + + Mark Koennecke, June 2003 + -----------------------------------------------------------------------*/ +#include +#include +#include +#include +#include +#include +#include + +static pSite siteDummy = NULL; + +/*----------------------------------------------------------------------*/ +static void AddDummyCommands(SicsInterp *pInter){ +} +/*---------------------------------------------------------------------*/ +static void RemoveDummyCommands(SicsInterp *pSics){ +} +/*-------------------------------------------------------------------*/ +static pMotor CreateDummyMotor(SConnection *pCon, int argc, char *argv[]){ + pMotor pNew = NULL; + return pNew; +} +/*-------------------------------------------------------------------*/ +static pCounterDriver CreateDummyCounterDriver(SConnection *pCon, + int argc, + char *argv[]){ + pCounterDriver pNew = NULL; + return pNew; +} +/*-------------------------------------------------------------------*/ +static HistDriver *CreateDummyHistMem(char *name, pStringDict pOptions){ + HistDriver *pNew = NULL; + + return pNew; +} +/*-------------------------------------------------------------------*/ +static pVelSelDriv CreateDummyVelSelDriv(char *name, char *array, + Tcl_Interp *pTcl){ + pVelSelDriv pNew = NULL; + return pNew; +} +/*-------------------------------------------------------------------*/ +static pCodri CreateDummyController(SConnection *pCon,int argc, char *argv[]){ + pCodri pNew = NULL; + return pNew; +} +/*------------------------------------------------------------------*/ +static pEVControl InstallDummyEnvironmentController(SicsInterp *pSics, + SConnection *pCon, + int argc, char *argv[]){ + pEVControl pNew = NULL; + pEVDriver pDriv = NULL; + + return pNew; +} +/*-----------------------------------------------------------------*/ +static int ConfigureDummyScan(pScanData self, char *option){ + return 0; +} +/*--------------------------------------------------------------------*/ +static void KillDummySite(void *site){ + free(site); + siteDummy = NULL; +} +/*--------------------------------------------------------------------- + The scheme here goes along the lines of the singleton design pattern + ---------------------------------------------------------------------*/ +pSite getSite(void){ + if(siteDummy == NULL){ + siteDummy = (pSite)malloc(sizeof(Site)); + /* + we cannot go on if we do not even have enough memory to allocate + the site data structure + */ + assert(siteDummy); + /* + initializing function pointers + */ + siteDummy->AddSiteCommands = AddDummyCommands; + siteDummy->RemoveSiteCommands = RemoveDummyCommands; + siteDummy->CreateMotor = CreateDummyMotor; + siteDummy->CreateCounterDriver = CreateDummyCounterDriver; + siteDummy->CreateHistogramMemoryDriver = CreateDummyHistMem; + siteDummy->CreateVelocitySelector = CreateDummyVelSelDriv; + siteDummy->CreateControllerDriver = CreateDummyController; + siteDummy->InstallEnvironmentController = + InstallDummyEnvironmentController; + siteDummy->ConfigureScan = ConfigureDummyScan; + siteDummy->KillSite = KillDummySite; + } + return siteDummy; +} + diff --git a/dummy/make_gen b/dummy/make_gen new file mode 100644 index 00000000..67c39a6e --- /dev/null +++ b/dummy/make_gen @@ -0,0 +1,18 @@ +#------------------------------------------------------------------------- +# common part of the makefile for the Dummy specific parts of SICS +# +# Mark Koennecke, June 2003 +#------------------------------------------------------------------------- +.SUFFIXES: +.SUFFIXES: .c .o .f + +OBJ=dummy.o + +libpsi.a: $(OBJ) + - rm libdummy.a + ar cr libdummy.a $(OBJ) + ranlib libdummy.a + +clean: + - rm *.a + - rm *.o \ No newline at end of file diff --git a/hardsup/makefile_alpha b/dummy/makefile_alpha_dummy similarity index 69% rename from hardsup/makefile_alpha rename to dummy/makefile_alpha_dummy index 7cd80b92..dbca2ef0 100644 --- a/hardsup/makefile_alpha +++ b/dummy/makefile_alpha_dummy @@ -1,15 +1,14 @@ #--------------------------------------------------------------------------- -# Makefile for the SINQ hardware support library +# Makefile for the Dummy specific part of SICS # machine-dependent part for Tru64 Unix # -# Mark Koennecke, November 1996 -# Markus Zolliker, March 2003 +# Mark Koennecke, June 2003 #-------------------------------------------------------------------------- # the following line only for fortified version #DFORTIFY=-DFORTIFY #========================================================================== CC = cc -CFLAGS = -std1 -g $(DFORTIFY) -I$(SRC).. -I$(SRC). +CFLAGS = -std1 -g $(DFORTIFY) -I.. include make_gen diff --git a/ecb.c b/ecb.c deleted file mode 100644 index 2ec1cae1..00000000 --- a/ecb.c +++ /dev/null @@ -1,496 +0,0 @@ -/*----------------------------------------------------------------------- - The ECB is a rack controller from Risoe based on a Z80 processor. - This module provides some functions for communicating with such a - device. This is the implementation file. - - WARNING: This contains code which may be endian dependent! - - copyright: see file COPYRIGHT - - Mark Koennecke, January 2002, with some bits taken from the original - tascom code. - -------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include -#include "fortify.h" -#include "sics.h" -#include "ecb.h" -#include "ecb.i" -/*------------- private defines and error codes ------------------------*/ -#define ACKN ('\6') /* Acknowledge character */ -#define READ_BYTES 3 -#define WRITE_BYTES 4 -#define DMAREAD 5 -#define ECB_BYTES 65536L - -typedef union /* Used to swap bytes in 'address' and 'byte_count' */ - { - unsigned short word; - struct - { - unsigned char msb; /* Most significant byte */ - unsigned char lsb; /* Least significant byte */ - }b; - }Swap; -/* ------- error codes */ -#define ECBILLEGALFUNC -100 -#define ECBOVERFLOW -101 - -/*----------------------------------------------------------------------*/ -static int ecbSendFunc(pECB self, int func){ - unsigned char function, response; - int count, status; - - /* - send function code - */ - function = (unsigned char)func; - count = 1; - status = GPIBsend(self->gpib,self->ecbDeviceID,&function,count); - if(status < 0){ - self->lastError = status; - return 0; - } - - /* - read acknowledge byte - */ - status = GPIBread(self->gpib,self->ecbDeviceID,&response,count); - if(status < 0){ - self->lastError = status; - return 0; - } - if(response != ACKN){ - self->lastError = ECBILLEGALFUNC; - return 0; - } - return 1; -} -/*-----------------------------------------------------------------------*/ -int ecbExecute(pECB self, int func, Z80_reg in, Z80_reg *out){ - int count, status; - - assert(self != NULL); - assert(self->gpib != NULL); - self->lastError = 0; - - /* - send function code - */ - status = ecbSendFunc(self,func); - if(status <= 0){ - return status; - } - - /* - send input register - */ - count = 4; - status = GPIBsend(self->gpib,self->ecbDeviceID, &in, count); - if(status < 0){ - self->lastError = status; - return 0; - } - - /* - read result register - */ - status = GPIBread(self->gpib,self->ecbDeviceID, out, count); - if(status < 0){ - self->lastError = status; - return 0; - } - - return 1; -} -/*----------------------------------------------------------------------*/ -static int ecbPrepareIO(pECB self, int func, unsigned short address, - unsigned short byteCount){ - Swap save, adr, count; - int status, bytes; - - if(byteCount > ECB_BYTES){ - self->lastError = ECBOVERFLOW; - return 0; - } - - /* - Swap address and byteCount?? This may be a portability issue! - This may not be necessary on some platforms - */ - save.word = address; /* Swap address bytes */ - adr.b.lsb = save.b.msb; - adr.b.msb = save.b.lsb; - save.word = byteCount; /* Swap byte count bytes */ - count.b.lsb = save.b.msb; - count.b.msb = save.b.lsb; - - status = ecbSendFunc(self,func); - if(status <= 0){ - return status; - } - - /* - send address - */ - bytes = 2; - status = GPIBsend(self->gpib,self->ecbDeviceID,&adr,bytes); - if(status < 0){ - self->lastError = status; - return 0; - } - - /* - send byte count - */ - status = GPIBsend(self->gpib,self->ecbDeviceID,&count,bytes); - if(status < 0){ - self->lastError = status; - return 0; - } - - return 1; -} -/*-----------------------------------------------------------------------*/ -int ecbRead(pECB self, unsigned short address, - void *buffer, int byteCount){ - - int status, count; - - assert(self != NULL); - assert(self->gpib != NULL); - self->lastError = 0; - - status = ecbPrepareIO(self,READ_BYTES,address,(unsigned short)byteCount); - if(status <= 0){ - return 0; - } - - /* - actual read - */ - status = GPIBread(self->gpib,self->ecbDeviceID, buffer, byteCount); - if(status < 0){ - self->lastError = status; - return 0; - } - - return 1; -} -/*----------------------------------------------------------------------*/ -int ecbDMARead(pECB self, unsigned short address, void *buffer, - unsigned short byteCount){ - int status, count; - - assert(self != NULL); - assert(self->gpib != NULL); - self->lastError = 0; - - status = ecbPrepareIO(self,DMAREAD,address,(unsigned short)byteCount); - if(status <= 0){ - return 0; - } - - usleep(20*1000); - - /* - actual read - */ - status = GPIBread(self->gpib,self->ecbDeviceID, buffer, byteCount); - if(status < 0){ - self->lastError = status; - return 0; - } - - return 1; -} -/*----------------------------------------------------------------------*/ -int ecbWrite(pECB self, unsigned short address, - void *buffer, int byteCount){ - - int status, count; - - assert(self != NULL); - assert(self->gpib != NULL); - self->lastError = 0; - - status = ecbPrepareIO(self,WRITE_BYTES,address,(unsigned short)byteCount); - if(status <= 0){ - return 0; - } - - /* - actual read - */ - status = GPIBsend(self->gpib,self->ecbDeviceID, buffer, byteCount); - if(status < 0){ - self->lastError = status; - return 0; - } - - return 1; -} -/*-----------------------------------------------------------------------*/ -void ecbErrorDescription(pECB self, char *buffer, int maxBuffer){ - int positive; - - switch(self->lastError){ - case ECBILLEGALFUNC: - strncpy(buffer,"Illegal ECB function called",maxBuffer); - return; - case ECBOVERFLOW: - strncpy(buffer, - "You tried to copy more then 64K onto the poor ECB, REFUSED!", - maxBuffer); - return; - } - - /* - GPIB error codes - */ - GPIBerrorDescription(self->gpib,self->lastError,buffer, maxBuffer); -} -/*----------------------------------------------------------------------*/ -void ecbClear(pECB self){ - GPIBclear(self->gpib, self->ecbDeviceID); -} -/*-----------------------------------------------------------------------*/ -int fixECBError(pECB self){ - int pos; - - switch(self->lastError){ - case ECBILLEGALFUNC: - case ECBOVERFLOW: - return HWFault; - } - - /* - GPIB error - */ - pos = -self->lastError; - switch(pos){ - case GPIBEABO: - return HWRedo; - default: - return HWFault; - } -} -/*------------------------------------------------------------------------*/ -int ECBAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]){ - pECB self = (pECB)pData; - Z80_reg in, out; - char pBuffer[80], pError[132]; - int status, iVal, func; - - assert(self != NULL); - - /* - Only managers will be allowed to wrestle directly with ECB - controllers. - */ - if(!SCinMacro(pCon)){ - if(!SCMatchRights(pCon,usMugger)){ - return 0; - } - } - - if(argc < 2){ - SCWrite(pCon,"ERROR: keyword required for ECB",eError); - return 0; - } - - strtolower(argv[1]); - if(strcmp(argv[1],"func") == 0){ - if(argc < 7){ - SCWrite(pCon,"ERROR: require function code and four register values", - eError); - return 0; - } - status = Tcl_GetInt(pSics->pTcl, argv[2],&func); - if(status != TCL_OK){ - SCWrite(pCon,"ERROR: failed to convert argument to int",eError); - return 0; - } - status = Tcl_GetInt(pSics->pTcl, argv[3],&iVal); - if(status != TCL_OK){ - SCWrite(pCon,"ERROR: failed to convert argument to int",eError); - return 0; - } - in.d = (unsigned char)iVal; - status = Tcl_GetInt(pSics->pTcl, argv[4],&iVal); - if(status != TCL_OK){ - SCWrite(pCon,"ERROR: failed to convert argument to int",eError); - return 0; - } - in.e = (unsigned char)iVal; - status = Tcl_GetInt(pSics->pTcl, argv[5],&iVal); - if(status != TCL_OK){ - SCWrite(pCon,"ERROR: failed to convert argument to int",eError); - return 0; - } - in.b = (unsigned char)iVal; - status = Tcl_GetInt(pSics->pTcl, argv[6],&iVal); - if(status != TCL_OK){ - SCWrite(pCon,"ERROR: failed to convert argument to int",eError); - return 0; - } - in.c = (unsigned char)iVal; - - status = ecbExecute(self,func,in,&out); - if(status != 1){ - ecbErrorDescription(self,pBuffer,79); - sprintf(pError,"ERROR: %s", pBuffer); - SCWrite(pCon,pError,eError); - return 0; - } - sprintf(pBuffer,"%d %d %d %d", - out.d, out.e, out.b, out.c); - SCWrite(pCon,pBuffer,eValue); - return 1; - } else if(strcmp(argv[1],"clear") == 0){ - ecbClear(self); - SCSendOK(pCon); - return 1; - }else if(strcmp(argv[1],"toint")== 0){ - sprintf(pBuffer,"%d",argv[2][0]); - SCWrite(pCon,pBuffer,eValue); - } else { - SCWrite(pCon,"ERROR: ECB does not understand keyword", eError); - return 0; - } -} -/*---------------------------------------------------------------------*/ -int ecbAssignEncoder(pECB self, int encoder, int motorNumber){ - - if(encoder <= 0 || encoder > 3){ - return 0; - } - - self->encoder[encoder-1] = motorNumber; - self->encoderDirty = 1; - return 1; -} -/*----------------------------------------------------------------------*/ -int ecbLoadEncoder(pECB self){ - Z80_reg in, out; - int status; - - if(self->encoderDirty != 1){ - /* - no need to do it if no change - */ - return 1; - } - - if(self->encoder[0] != 0){ - in.d = self->encoder[0]; - }else { - in.d = 0; - } - if(self->encoder[1] != 0){ - in.e = self->encoder[1]; - }else { - in.e = 0; - } - if(self->encoder[2] != 0){ - in.b = self->encoder[2]; - }else { - in.b = 0; - } - in.c = 1; - - status = ecbExecute(self,152,in,&out); - return status; -} -/*-----------------------------------------------------------------------*/ -void ECBKill(void *pData){ - pECB self = (pECB)pData; - - if(self == NULL){ - return; - } - - /* - Detaching here may be dangerous: If the GPIB has been deleted first, - this makes a core dump. Best is the GPIB keeps a list of attached - things and cleans them itself. - - GPIBdetach(self->gpib,self->ecbDeviceID); - */ - if(self->pDes){ - DeleteDescriptor(self->pDes); - } - free(self); -} -/*---------------------------------------------------------------------- -MakeECB name gpibcontroller boardNo gpib-address - -----------------------------------------------------------------------*/ -int MakeECB(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]){ - pECB self = NULL; - int address, status, boardNo; - pGPIB gpib = NULL; - char pError[132]; - - /* - we need a name, the GPIB controller and an address on the GPIB bus for - the ECB as arguments - */ - if(argc < 5){ - SCWrite(pCon,"ERROR: insufficient arguments to MakeECB",eError); - return 0; - } - gpib = FindCommandData(pSics,argv[2],"GPIB"); - if(gpib == NULL){ - sprintf(pError,"ERROR: no GPIB controller %s found", argv[2]); - SCWrite(pCon,pError,eError); - return 0; - } - status = Tcl_GetInt(pSics->pTcl,argv[3], &boardNo); - if(status != TCL_OK){ - sprintf(pError,"ERROR: failed to convert %s to integer",argv[3]); - SCWrite(pCon,pError,eError); - return 0; - } - status = Tcl_GetInt(pSics->pTcl,argv[4], &address); - if(status != TCL_OK){ - sprintf(pError,"ERROR: failed to convert %s to integer",argv[4]); - SCWrite(pCon,pError,eError); - return 0; - } - if(address < 0 || address > 30){ - SCWrite(pCon,"ERROR: invalid GPIB address specified",eError); - return 0; - } - - self = (pECB)malloc(sizeof(ECB)); - if(self == NULL){ - SCWrite(pCon,"ERROR: no memory to allocate ECB",eError); - return 0; - } - memset(self,0,sizeof(ECB)); - self->pDes = CreateDescriptor("ECB"); - if(self->pDes == NULL){ - SCWrite(pCon,"ERROR: no memory to allocate ECB",eError); - return 0; - } - self->gpib = gpib; - self->boardNumber = boardNo; - self->ecbAddress = address; - self->ecbDeviceID =GPIBattach(self->gpib,self->boardNumber, - self->ecbAddress,0, - 13,0,1); - if(self->ecbDeviceID <= 0){ - SCWrite(pCon,"ERROR: failed to initialize ECB connection", - eError); - ECBKill(self); - return 0; - } - AddCommand(pSics,argv[1],ECBAction,ECBKill,self); - return 1; -} - diff --git a/ecb.h b/ecb.h deleted file mode 100644 index dd5b861e..00000000 --- a/ecb.h +++ /dev/null @@ -1,69 +0,0 @@ - -/*----------------------------------------------------------------------- - The ECB is a rack controller from Risoe based on a Z80 processor. - This module provides some functions for communicating with such a - device. - - WARNING: This contains code which may be endian dependent! - - copyright: see file COPYRIGHT - - Mark Koennecke, January 2002, with some bits taken out of the - original tascom code. -------------------------------------------------------------------------*/ -#ifndef ECBCON -#define ECBCON -#include "gpibcontroller.h" - - -typedef struct { - unsigned char d; /* D register in Z80 */ - unsigned char e; /* E register in Z80 */ - unsigned char b; /* B register in Z80 */ - unsigned char c; /* C register in Z80 */ - } Z80_reg; - -/*-----------------------------------------------------------------------*/ - - typedef struct __ECB *pECB; - - int ecbExecute(pECB self, int func, Z80_reg in, Z80_reg *out); - int ecbRead(pECB self, unsigned short address, - void *buffer, int byteCount); - int ecbWrite(pECB self, unsigned short address, - void *buffer, int byteCount); - int ecbDMARead(pECB self, unsigned short address, void *buffer, - unsigned short byteCount); - void ecbClear(pECB self); - int fixECBError(pECB self); - void ecbErrorDescription(pECB self, char *buffer, - int maxBytes); - int ecbAssignEncoder(pECB self, int encoder, int motorNumber); - int ecbLoadEncoder(pECB self); - - - - - -/*-----------------------------------------------------------------------*/ - - int MakeECB(SConnection *pCon, SicsInterp *pSics, - void *pData, - int ragc, char *argv[]); - - -/*---------------------------------------------------------------------- - for byte packing. result must be an 32 bit integer -----------------------------------------------------------------------*/ -typedef union /* Used to extract and load data to Z80 regs. */{ - unsigned int result; - struct - { - unsigned char byt0; /* Least significant byte */ - unsigned char byt1; - unsigned char byt2; - unsigned char byt3; /* Most significant byte */ - }b; -}Ecb_pack; - -#endif diff --git a/ecb.i b/ecb.i deleted file mode 100644 index 6853f58f..00000000 --- a/ecb.i +++ /dev/null @@ -1,23 +0,0 @@ - -/*----------------------------------------------------------------------- - The ECB is a rack controller from Risoe based on a Z80 processor. - This module provides some functions for communicating with such a - device. This is an internal data structure definition file. - - copyright: see file COPYRIGHT - - Mark Koennecke, January 2002, with some bits taken out of the - original tascom code. -------------------------------------------------------------------------*/ - - struct __ECB { - pObjectDescriptor pDes; - pGPIB gpib; - int boardNumber; - int ecbAddress; - int ecbDeviceID; - int lastError; - int encoder[3]; - int encoderDirty; - }ECB; - diff --git a/ecb.w b/ecb.w deleted file mode 100644 index ae471d98..00000000 --- a/ecb.w +++ /dev/null @@ -1,173 +0,0 @@ -\subsection{The ECB Controller} -The ECB Controller is an electronic device created by the Risoe -neutron scattering institute. At its base is a Z80 8-bit -processor. This Z80 processor can perform certain functions such as -controlling count operations, running a motor etc. To this purpose -further electronic widgets are connected to the Z80's backplane. At -the other end is a GPIB controller which allows to discuss with the -Z80. - -This module now implements three basic functionalities of the ECB: -\begin{itemize} -\item Execute a function -\item Read some memory -\item Write some memory -\end{itemize} - -This module also takes care of the encoder assignment for the ECB. The -ECB can have up to three encoders which can be assigned to motors. As -a single motor driver does not know about the assignments of the other -motors, the task of encoder assignement is handled in this module. - -WARNING: this module contains code which may be endian dependend! - -In order to do this we need the following data structure: -@d ecbdat @{ - struct __ECB { - pObjectDescriptor pDes; - pGPIB gpib; - int boardNumber; - int ecbAddress; - int ecbDeviceID; - int lastError; - int encoder[3]; - int encoderDirty; - }ECB; -@} -The fields: -\begin{description} -\item[pDes] The standard SICS object descriptor. -\item[gpib] The GPIB controller used for accessing the ECB. -\item[boardNumber] The GPIB board number in the NI driver. -\item[ecbAddress] The GPIB address of the ECB controller. -\item[ecbDeviceID] The device ID assigned to the ECB when the ECB has -been attached to. -\item[lastError] The last error which occurred. -\item[encoder] An array holding the motor numbers assigned to the -three encoder. -\item[encoderDirty] is a flag which is set to true if a download of -the encoder assignments is necessary. -\end{description} - -A function in the ECB is executed by sending a function number first, -followed by the content of the Z80 4 registers. In order to do this a -data structure is required for these registers: - -@d z80 @{ -typedef struct { - unsigned char d; /* D register in Z80 */ - unsigned char e; /* E register in Z80 */ - unsigned char b; /* B register in Z80 */ - unsigned char c; /* C register in Z80 */ - } Z80_reg; -@} - -The function interface then looks like: - -@d ecbfunc @{ - typedef struct __ECB *pECB; - - int ecbExecute(pECB self, int func, Z80_reg in, Z80_reg *out); - int ecbRead(pECB self, unsigned short address, - void *buffer, int byteCount); - int ecbWrite(pECB self, unsigned short address, - void *buffer, int byteCount); - int ecbDMARead(pECB self, unsigned short address, void *buffer, - unsigned short byteCount); - void ecbClear(pECB self); - int fixECBError(pECB self); - void ecbErrorDescription(pECB self, char *buffer, - int maxBytes); - int ecbAssignEncoder(pECB self, int encoder, int motorNumber); - int ecbLoadEncoder(pECB self); - - - - -@} -\begin{description} -\item[ecbExecute] tries to execute the ECB function func. The input register -content is in in, on success the outpt registers are stored in out. -\item[ecbRead] reads byteCount bytes from the ECB address address into -buffer. Please note that address in this contest is an address in the -ECB's memory space and not the GPIB address. -\item[ecbDMARead] reads byteCount bytes from the ECB DMA address address into -buffer. Please note that address in this contest is an address in the -ECB's memory space and not the GPIB address. -\item[ecbWrite] writes byteCount bytes from buffer to the ECB address -address. Please note that address in this contest is an address in the -ECB's memory space and not the GPIB address. -\item[ecbClear] tries to clear the ECB interface. -\item[fixECBError] tries to fix the last ECB error. -\item[ecbErrorDescription] retrieves a text description of the last -ECB problem. Max maxBytes of description are copied into buffer. -\item[assignEncoder] assigns an encoder to a motor number. -\item[loadEncoder] downloads the encoder assignment to the ECB if necessary. -\end{description} - - -There is also an interface to the SICS interpreter for the ECB. This -can be useful for debugging and testing and as a tool for scriptingy -auxiliary equipment controlled through the ECB. The interface to the -SICS interpreter for the ECB is represented through the ECB Factory -function: -@d ecbint @{ - int MakeECB(SConnection *pCon, SicsInterp *pSics, - void *pData, - int ragc, char *argv[]); -@} - -@o ecb.h @{ -/*----------------------------------------------------------------------- - The ECB is a rack controller from Risoe based on a Z80 processor. - This module provides some functions for communicating with such a - device. - - WARNING: This contains code which may be endian dependent! - - copyright: see file COPYRIGHT - - Mark Koennecke, January 2002, with some bits taken out of the - original tascom code. -------------------------------------------------------------------------*/ -#ifndef ECBCON -#define ECBCON -#include "gpibcontroller.h" - -@ -/*-----------------------------------------------------------------------*/ -@ -/*-----------------------------------------------------------------------*/ -@ - -/*---------------------------------------------------------------------- - for byte packing. result must be an 32 bit integer -----------------------------------------------------------------------*/ -typedef union /* Used to extract and load data to Z80 regs. */{ - unsigned int result; - struct - { - unsigned char byt0; /* Least significant byte */ - unsigned char byt1; - unsigned char byt2; - unsigned char byt3; /* Most significant byte */ - }b; -}Ecb_pack; - -#endif -@} - -@o ecb.i @{ -/*----------------------------------------------------------------------- - The ECB is a rack controller from Risoe based on a Z80 processor. - This module provides some functions for communicating with such a - device. This is an internal data structure definition file. - - copyright: see file COPYRIGHT - - Mark Koennecke, January 2002, with some bits taken out of the - original tascom code. -------------------------------------------------------------------------*/ -@ -@} - diff --git a/ecbcounter.c b/ecbcounter.c index 9f12dda1..b5d21d95 100644 --- a/ecbcounter.c +++ b/ecbcounter.c @@ -14,7 +14,7 @@ #include "fortify.h" #include "sics.h" #include "status.h" -#include "ecb.h" +#include "psi/ecb.h" #include "countdriv.h" /*------------------ our private data structure ------------------------*/ @@ -579,11 +579,8 @@ pCounterDriver MakeECBCounter(char *ecb){ self->Set = ECBSet; self->Get = ECBGet; self->Send = ECBSend; + self->KillPrivate = NULL; self->pData = pPriv; return self; } -/*=====================================================================*/ -void KillECBCounter(struct __COUNTER *self){ - DeleteCounterDriver(self); -} diff --git a/ecbdriv.c b/ecbdriv.c deleted file mode 100644 index 11b31b09..00000000 --- a/ecbdriv.c +++ /dev/null @@ -1,1261 +0,0 @@ -/*------------------------------------------------------------------------ - this is a motor driver for the Risoe motor controllers within the - ECB system. The motor is controlled through functions invoked in the - Z80 processor of the ECB system which is connected through a GPIB - bus to the wider world. This driver has to do a lot of extra things: - - it has to convert from physical values to motor steps. - - Quite a few parameters, such as ramping parameters, - have to be downloaded to the ECB - - Risoe motors may have a virtual encoder or a real encoder. - - The motor may have to control air cushions as well. - - Tricky backlash handling. Backlash handling ensures that a position is - always arrived at from a defined direction. If backlash is applied - a restart flag is set in ECBRunTo. ECBGetStatus checks for that and - causes the motor to drive back to the position actually desired. - - This driver support only P2048a motor controllers, as these are the - only ones which seem to have arrived at PSI. The P1648 and Tridynamic - things are not supported. - - Multiplexed motors: Originally the ECB supported 24 motors. This did - prove to be not enough. Therefore another device called P2234e was - introduced which allowed to run 8 motors from one controller port. In this - case the motor parameters have to be copied to the ECB before - driving the motor. Multiplexing is selected through the parameter MULT. - MULT 0 means no multiplexing, MULT > 0 makes MULT the number of the - motor in the multiplexer. MULT is now also used to flag a download of - parameters to the ECB. In such a case MULT is -1. - - - Some of this code was taken from the tascom driver for the ECB. - - copyright: see file COPYRIGHT - - Mark Koennecke, January 2003 - ---------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include -#include -#include "fortify.h" -#include "sics.h" -#include "motor.h" -#include "obpar.h" -#include "splitter.h" -#include "ecb.h" - -/*------------------------------------------------------------------------ -Parameter indexes in ObPar array and meanings --------------------------------------------------------------------------*/ -#define ENCODER 0 /* encoder number, 0 if no encoder */ -#define CONTROL 1 /* control signals, > 1 means required. */ -#define RANGE 2 /* 0 = slow, 1 = fast */ -#define MULT 3 /* 0 = not multiplexed, > 0 multiplex motor number*/ -#define MULTCHAN 16 /* multiplexer channel */ -#define ACCTIME 4 /* acceleration time: 500, 1000 or 2000 milSecs */ -#define ROTDIR 5 /* rotation direction */ -#define STARTSPEED 6 /* start speed: 100-500 steps/s */ -#define MAXSPEED 7 /* maximum speed: 100-2000 steps/sec */ -#define SLOWAUTO 8 /* slow speed in auto mode */ -#define SLOWMAN 9 /* slow speed in manual mode */ -#define DELAY 10 /* start delay 0 - 2500 millSecs */ -#define OFFSET 11 /* encoder offset */ -#define TOLERANCE 12 /* tolerance in steps */ -#define STEPS2DEG 13 /* conversion factor motor steps to Degree */ -#define DEG2STEP 14 /* conversion factor from degree to encoder digits */ -#define BACKLASH 15 /* motor backlash */ -#define PORT 17 /* ECB port when multiplexed */ - -#define MAXPAR 19 /* 1 extra for the sentinel, do not forget to initialize! */ - -/*------------------------------ ECB defines -------------------------*/ -#define MAX_ENCODER 40 -#define FENCOR 167 /* read encoder */ -#define MOREAD 145 /* read motor steps */ -#define MOPARA 140 /* motor parameter */ -#define MOCLOA 146 -#define ABS(x) (x < 0 ? -(x) : (x)) -#define MOSTEP 141 -#define MOSTAT 144 - -/********************* t-error codes *************************************/ -#define COMMERROR -300 -#define ECBMANUELL -301 -#define ECBINUSE -302 -#define UNIDENTIFIED -303 -#define ECBINHIBIT -304 -#define ECBRUNNING -305 -#define ECBSTART -306 -#define ECBLIMIT -307 -#define ECBREADERROR -308 -/*================== The Driver data structure ============================*/ - typedef struct __ECBMotorDriv { - /* general motor driver interface - fields. REQUIRED! - */ - float fUpper; /* upper limit */ - float fLower; /* lower limit */ - char *name; - int (*GetPosition)(void *self,float *fPos); - int (*RunTo)(void *self, float fNewVal); - int (*GetStatus)(void *self); - void (*GetError)(void *self, int *iCode, - char *buffer, int iBufLen); - int (*TryAndFixIt)(void *self,int iError, - float fNew); - int (*Halt)(void *self); - int (*GetDriverPar)(void *self, char *name, - float *value); - int (*SetDriverPar)(void *self,SConnection *pCon, - char *name, float newValue); - void (*ListDriverPar)(void *self, char *motorName, - SConnection *pCon); - - - /* ECB specific fields */ - pECB ecb; /* ECB controller for everything */ - int ecbIndex; /* motor index in ECB */ - int errorCode; - int restart; /* flag if we have to restart - because of backlash - compensation - */ - float restartTarget; /* target to restart to */ - ObPar driverPar[MAXPAR]; /* parameters */ - } ECBMOTDriv, *pECBMotDriv; -/*======================================================================= - Reading the motor position means reading the encoder if such a thing - is present or the counted motor steps (Pseudo Encoder) if not. - If the ECB answers us, the value has to be converted to physical - values. - ----------------------------------------------------------------------*/ -static int readEncoder(pECBMotDriv self, long *digits){ - int status; - Z80_reg in, out; - Ecb_pack data; - - in.c = (unsigned char)ObVal(self->driverPar,ENCODER) + MAX_ENCODER; - status = ecbExecute(self->ecb,FENCOR,in,&out); - if(!status){ - self->errorCode = COMMERROR; - return status; - } - - /* pack bytes */ - data.b.byt3 = 0; - data.b.byt2 = out.b; - data.b.byt1 = out.d; - data.b.byt0 = out.e; - if(out.c != 1){ - *digits = -data.result; - } else { - *digits = data.result; - } - return OKOK; -} -/*---------------------------------------------------------------------*/ -static int readPseudoEncoder(pECBMotDriv self, long *digits){ - int status; - Z80_reg in, out; - Ecb_pack data; - - in.c = (unsigned char)self->ecbIndex; - status = ecbExecute(self->ecb,MOREAD,in,&out); - if(!status){ - self->errorCode = COMMERROR; - return status; - } - - /* pack bytes */ - data.b.byt3 = 0; - data.b.byt2 = out.b; - data.b.byt1 = out.d; - data.b.byt0 = out.e; - if(out.c != 1){ - *digits = -data.result; - } else { - *digits = data.result; - } - return OKOK; -} -/*----------------------------------------------------------------------*/ -int ECBMOTGetPos(void *pData, float *fPos){ - pECBMotDriv self = (pECBMotDriv)pData; - long digits = 0; - int status; - double step2degree; - - assert(self); - self->errorCode = 0; - - if((int)ObVal(self->driverPar,ENCODER) > 0){ - status = readEncoder(self, &digits); - *fPos = digits/ObVal(self->driverPar,DEG2STEP) - - ObVal(self->driverPar,OFFSET); - return status; - } else { - status = readPseudoEncoder(self, &digits); - } - step2degree = ObVal(self->driverPar,STEPS2DEG); - if(step2degree == 0.0){ - step2degree = 1.; - } - *fPos = (float)( (double)digits/step2degree); - - return status; -} -/*======================================================================== -In order to start a motor we need to do a couple of steps: - - check if the motors parameters have been changed or it is a multiplexed - motor. In each case download the motor parameters. - - the direction of the motor has to be determined, the speed to be - selected etc. - - Then the motor can be started. - ------------------------------------------------------------------------*/ -static int mustDownload(pECBMotDriv self){ - int multi; - - multi = (int)rint(ObVal(self->driverPar,MULT)); - if(multi > 0 || multi < 0) { - return 1; - } else { - return 0; - } -} -/*--------------------------------------------------------------------*/ -static int checkMotorResult(pECBMotDriv self, Z80_reg out){ - /* - checks the return values from a motor function invocation - and sets error codes in case of problems. - */ - if(out.c == '\0'){ - switch(out.b){ - case 128: - self->errorCode = ECBMANUELL; - break; - case 64: - self->errorCode = ECBINHIBIT; - break; - case 32: - self->errorCode = ECBRUNNING; - break; - case 1: - self->errorCode = ECBSTART; - break; - case 16: - self->errorCode = ECBLIMIT; - break; - case 4: - self->errorCode = ECBINUSE; - break; - default: - self->errorCode = UNIDENTIFIED; - break; - } - return 0; - } else { - return 1; - } -} -/*---------------------------------------------------------------------*/ -static int loadAcceleration(pECBMotDriv self){ - unsigned char parameter; - Z80_reg in, out; - int accel, status; - - accel = (int)rint(ObVal(self->driverPar,ACCTIME)); - if(accel == 500){ - parameter = 1; - }else if(accel == 1000){ - parameter = 2; - }else if(accel == 2000){ - parameter = 3; - } else { - parameter = 0; - } - /* - apply rotation direction mask - */ - if(ObVal(self->driverPar,ROTDIR) < 0){ - parameter += 128; - } - in.c = (unsigned char)self->ecbIndex; - in.b = 7; - in.e = parameter; - in.d = 0; - out.d = out.e = out.b = out.c = 0; - status = ecbExecute(self->ecb,MOPARA,in,&out); - if(!status){ - self->errorCode = COMMERROR; - return 0; - } - - if(!checkMotorResult(self, out)){ - return 0; - } - - return 1; -} -/*--------------------------- speed tables ------------------------------*/ -#define SPEED_TAB3 64 /* Size of speed table */ -const unsigned int low_2048[SPEED_TAB3] = { - 1, 2, 3, 4, 5, 6, 8, 10, 12, 14, - 16, 20, 24, 28, 32, 36, 40, 44, 48, 56, - 64, 72, 80, 88, 96,104,112,120,128,136, - 144,152,160,168,176,184,192,200,208,216, - 224,236,248,260,272,284,296,308,320,332, - 344,356,368,380,392,404,416,428,440,452, - 464,476,488,500 }; - -#define SPEED_TAB4 96 /* Size of speed table */ -const unsigned int high_2048[SPEED_TAB4] = { - 11, 15, 20, 27, 36, 47, 59, 74, - 93, 107, 124, 143, 165, 190, 213, 239, - 268, 298, 331, 368, 405, 446, 491, 536, - 585, 632, 683, 731, 783, 827, 873, 922, - 974, 1028, 1085, 1146, 1211, 1278, 1349, 1424, - 1503, 1587, 1675, 1720, 1820, 1913, 2014, 2123, - 2237, 2360, 2483, 2620, 2755, 2905, 3058, 3221, - 3384, 3575, 3756, 3945, 4150, 4370, 4600, 4800, - 5000, 5250, 5533, 5822, 6120, 6440, 6770, 7090, - 7450, 7800, 8130, 8500, 8900, 9320, 9730, 10200, - 10700, 11200, 11700, 12200, 12800, 13300, 13900, 14500, - 15100, 15800, 16700, 17300, 18000, 18600, 19300, 20000 }; -/*---------------------------------------------------------------------*/ -static unsigned char getSpeedIndex(float value, - int range, int *actualValue ){ - unsigned char index; - const unsigned int *table; - int length; - - if(range == 0){ - table = low_2048; - length = SPEED_TAB3; - } else { - table = high_2048; - length = SPEED_TAB4; - } - - for(index = 0; index < length-1; index++){ - if(table[index] >= value){ - break; - } - } - *actualValue = table[index]; - return index; -} -/*--------------------------------------------------------------------*/ -static int loadSpeed(pECBMotDriv self, float value, int code){ - unsigned char parameter; - Z80_reg in, out; - int accel, status, actual; - - parameter = getSpeedIndex(value, (int)rint(ObVal(self->driverPar,RANGE)), - &actual); - - in.c = (unsigned char)self->ecbIndex; - in.b = code; - in.e = parameter; - status = ecbExecute(self->ecb,MOPARA,in,&out); - if(!status){ - self->errorCode = COMMERROR; - return 0; - } - if(!checkMotorResult(self, out)){ - return 0; - } - return 1; -} -/*-------------------------------------------------------------------*/ -static int loadDelay(pECBMotDriv self){ - int parameter; - Z80_reg in, out; - int accel, status; - unsigned char control; - - parameter = (int)rint(ObVal(self->driverPar,DELAY)); - control = (unsigned char)rint(ObVal(self->driverPar,CONTROL)); - if(control & 3){ - parameter = 5; - } else{ - parameter/= 10; - } - in.c = (unsigned char)self->ecbIndex; - in.b = 8; - in.e = parameter; - status = ecbExecute(self->ecb,MOPARA,in,&out); - if(!status){ - self->errorCode = COMMERROR; - return 0; - } - - if(!checkMotorResult(self, out)){ - return 0; - } - - return 1; -} -/*---------------------------------------------------------------------*/ -static int loadMulti(pECBMotDriv self){ - int multi, mult_chan; - Z80_reg in, out; - int status; - - multi = rint(ObVal(self->driverPar,MULT)); - if(multi <= 0){ - return 1; /* not multiplexed */ - } - - mult_chan = (unsigned char)rint(ObVal(self->driverPar,MULTCHAN)); - in.b = -1; /* SET_PORT */ - in.d = (unsigned char)(multi + (mult_chan << 4)); - in.e = (unsigned char)rint(ObVal(self->driverPar,PORT)); - in.c = self->ecbIndex; - status = ecbExecute(self->ecb,MOPARA,in,&out); - if(status != 1){ - self->errorCode = COMMERROR; - return 0; - } - return 1; -} -/*------------------------------------------------------------------*/ -static int loadOffset(pECBMotDriv self, float offset){ - Z80_reg in, out; - int status; - Ecb_pack data; - - /* - ignored - */ - if(ObVal(self->driverPar,ENCODER) <=.0){ - return 1; - } - - data.result = offset * ObVal(self->driverPar,STEPS2DEG); - in.b = data.b.byt2; - in.d = data.b.byt1; - in.e = data.b.byt0; - in.c = (unsigned char)rint(ObVal(self->driverPar,ENCODER)); - - status = ecbExecute(self->ecb,168,in,&out); - if(status == 1){ - self->driverPar[OFFSET].fVal = offset; - } else { - self->errorCode = COMMERROR; - } - return status; -} -/*--------------------------------------------------------------------- - This loads the gearing parameters for the CRT display. This should - not have any influence on the running of the motor - ------------------------------------------------------------------------*/ -static double To_ten(int v) { - double vv; - - - vv = 1.0; - if (v == 1) - vv = 10.0; - if (v == 2) - vv = 100.0; - if (v == 3) - vv = 1000.0; - if (v == 4) - vv = 10000.0; - if (v == 5) - vv = 100000.0; - if (v == 6) - vv = 1000000.0; - if (v == 7) - vv = 10000000.0; - return (vv); -} -/*----------------------------------------------------------------------*/ -static int loadGearing(pECBMotDriv self){ - int status; - double dgear; - int gdec, dec = 0, ratio; - Ecb_pack data; - Z80_reg in, out; - - in.c = self->ecbIndex; - dgear = (double) ObVal(self->driverPar,STEPS2DEG);; - - /* Calculate decimals in display and gearing ratio for the ECB system*/ - gdec = (int) (1.0 + (log10(dgear - .01))); - if (dec < gdec) - dec = gdec; /* Display does not work with decimals < gdec */ - ratio = (long) (0.5 + dgear*To_ten(6 + 1 - dec)); - - data.result = ratio; - in.b = data.b.byt2; - in.d = data.b.byt1; - in.e = data.b.byt0; - status = ecbExecute(self->ecb,174,in,&out); - if(status != 1){ - self->errorCode = COMMERROR; - } - - if(ObVal(self->driverPar,ENCODER) == 0){ - in.b = self->ecbIndex; - } else { - in.b = 1; - in.e = (unsigned char)ObVal(self->driverPar,ENCODER); - } - in.d = 0; - in.e = dec; - status = ecbExecute(self->ecb,173,in,&out); - if(status != 1){ - self->errorCode = COMMERROR; - } - - return 1; -} -/*----------------------------------------------------------------------*/ -static int downloadECBParam(pECBMotDriv self){ - int status, parameter; - unsigned char func_code; - Z80_reg in, out; - - /* - We assume that all parameters have useful values. It is the task of - SetDriverPar to ensure just that! - */ - if(status = loadAcceleration(self) <= 0){ - return 0; - } - - if(status = loadSpeed(self,ObVal(self->driverPar,STARTSPEED),6) <= 0){ - return 0; - } - - if(status = loadSpeed(self,ObVal(self->driverPar,MAXSPEED),5) <= 0){ - return 0; - } - - if(status = loadSpeed(self,ObVal(self->driverPar,SLOWAUTO),4) <= 0){ - return 0; - } - - if(status = loadSpeed(self,ObVal(self->driverPar,SLOWMAN),10) <= 0){ - return 0; - } - - if(status = loadDelay(self) <= 0){ - return 0; - } - - if(status = loadMulti(self) <= 0){ - return 0; - } - - if(status = ecbLoadEncoder(self->ecb) <= 0){ - return 0; - } - - if(status = loadOffset(self,ObVal(self->driverPar,OFFSET)) <= 0){ - return 0; - } - - - /* - It would be good practice to read the parameters written back - in order to check them. This does not seem to be supported with the - ECB system though. - */ - if(ObVal(self->driverPar,MULT) < 0.){ - self->driverPar[MULT].fVal = .0; - } - - if(status = loadGearing(self) <= 0){ - return 0; - } - - return 1; -} -/*--------------------------------------------------------------------*/ -int degree2Step(pECBMotDriv self, float degree) -{ - double steps; - - steps = degree*ObVal(self->driverPar,STEPS2DEG); - if (ObVal(self->driverPar,ENCODER) > .0) - steps = steps*ObVal(self->driverPar,DEG2STEP); - if(degree < 0){ - steps = - steps; - } - return ((int) steps); -} -/*---------------------------------------------------------------------- - controlMotor enables or disables the motor, according to flag enable. - This is also used to switch on air cushions and the like. - ------------------------------------------------------------------------*/ -static int controlMotor(pECBMotDriv self, int enable){ - int status, delay, control; - Z80_reg in, out; - - /* - nothing to do if we are not in control - */ - control = (int)rint(ObVal(self->driverPar,CONTROL)); - if(!(control & 1)){ - return 1; - } - - delay = (int)rint(ObVal(self->driverPar,DELAY)); - if(enable == 1){ - /* - enabling - */ - in.e = 12; /* 8 + 4 */ - in.b = 11; /* set control signal */ - in.c = (unsigned char)self->ecbIndex; - status = ecbExecute(self->ecb,MOPARA,in,&out); - if(status != 1){ - self->errorCode = COMMERROR; - return 0; - } - /* - wait for air cushions to settle - */ - usleep(delay); - return 1; - }else { - /* - disable motor - */ - in.e = 8; - in.b = 11; /* set control signal */ - in.c = self->ecbIndex; - status = ecbExecute(self->ecb,MOPARA,in,&out); - if(status != 1){ - self->errorCode = COMMERROR; - return 0; - } - usleep(delay); - in.e = 0; - in.b = 11; /* set control signal */ - in.c = -self->ecbIndex; - status = ecbExecute(self->ecb,MOPARA,in,&out); - if(status != 1){ - self->errorCode = COMMERROR; - return 0; - } - usleep(delay); - return 1; - } -} -/*-----------------------------------------------------------------------*/ -static int ECBRunTo(void *pData, float newPosition){ - pECBMotDriv self = (pECBMotDriv)pData; - long digits = 0; - int status; - float oldValue, diff, steps2degree, backlash; - Ecb_pack data; - Z80_reg in, out; - - assert(self); - - if(mustDownload(self)){ - status = downloadECBParam(self); - if(!status){ - return 0; - } - } - - /* - read old position - */ - status = ECBMOTGetPos(self,&oldValue); - if(status != 1){ - return status; - } - - /* - do not start if there - */ - diff = newPosition - oldValue; - steps2degree= ObVal(self->driverPar,STEPS2DEG); - if(ABS(diff) <= .5/steps2degree + ObVal(self->driverPar,TOLERANCE)){ - return OKOK; - } - - /* - save restartTarget for backlash handling - */ - self->restartTarget = newPosition; - - /* - enable and push up airy cushions - */ - status = controlMotor(self,1); - if(status != 1){ - return status; - } - - - /* - write control data - */ - in.d = 0; - if(diff > .0){ - in.d |= 32; /* positive direction */ - } - in.d |= 16; /* interrupts */ - if(rint(ObVal(self->driverPar,RANGE)) == 1.){ - in.d |= 64; /* fast speed */ - } - in.c = (unsigned char)self->ecbIndex; - status = ecbExecute(self->ecb,MOCLOA,in,&out); - if(status != 1){ - self->errorCode = COMMERROR; - return 0; - } - - /* - calculate steps - */ - self->restart = 0; - backlash = ObVal(self->driverPar,BACKLASH); - if(diff < 0){ - diff = -diff; - if(backlash > 0.){ - diff += backlash; - self->restart = 1; - } - } else { - if(backlash < 0.){ - diff -= backlash; - self->restart = 1; - } - } - data.result = degree2Step(self,diff); - - /* - finally start the motor - */ - in.b = data.b.byt2; - in.d = data.b.byt1; - in.e = data.b.byt0; - in.c = (unsigned char)self->ecbIndex; - status = ecbExecute(self->ecb,MOSTEP,in,&out); - if(status != 1){ - self->errorCode = COMMERROR; - return 0; - } - - if(!checkMotorResult(self, out)){ - return 0; - } - - return OKOK; -} -/*=======================================================================*/ -static int checkStatusResponse(pECBMotDriv self, Z80_reg out){ - - if(out.c == '\0'){ - if(out.b & 4) { - self->errorCode = ECBINUSE; - } else { - self->errorCode = ECBREADERROR; - } - return HWFault; - } - - if(out.b & 128){ - self->errorCode = ECBMANUELL; - return HWFault; - } else if(out.b & 32){ - return HWBusy; - } else if(out.b & 16){ - self->errorCode = ECBLIMIT; - return HWFault; - } - return HWIdle; -} -/*----------------------------------------------------------------------*/ -static int ECBGetStatus(void *pData){ - pECBMotDriv self = (pECBMotDriv)pData; - Z80_reg in, out; - int status, result; - - assert(self); - - in.c = (unsigned char)self->ecbIndex; - in.b = 12; - status = ecbExecute(self->ecb,MOSTAT,in,&out); - if(status != 1){ - self->errorCode = COMMERROR; - return HWFault; - } - - result = checkStatusResponse(self,out); - if(result == HWFault || result == HWIdle){ - /* - run down airy cushions ........ - */ - controlMotor(self,0); - } - - /* - take care of backlash..... - */ - if(result == HWIdle && self->restart == 1){ - self->restart = 0; - ECBRunTo(self,self->restartTarget); - return HWBusy; - } - - return result; -} -/*======================================================================*/ -static void ECBGetError(void *pData, int *iCode, char *buffer, int bufferlen){ - pECBMotDriv self = (pECBMotDriv)pData; - char pBueffel[132]; - - assert(self); - - *iCode = self->errorCode; - switch(self->errorCode){ - case COMMERROR: - strncpy(buffer,"communication problem with ECB",bufferlen); - break; - case ECBMANUELL: - strncpy(buffer,"ECB is in manual mode, trying to switch...",bufferlen); - break; - case ECBINUSE: - strncpy(buffer,"Power supply is in use",bufferlen); - break; - case ECBINHIBIT: - strncpy(buffer,"motor is inhibited",bufferlen); - break; - case ECBRUNNING: - strncpy(buffer,"motor is running",bufferlen); - break; - case ECBSTART: - strncpy(buffer,"failed to start motor",bufferlen); - break; - case ECBLIMIT: - strncpy(buffer,"hit limit switch",bufferlen); - break; - default: - strncpy(buffer,"unidentified error code",bufferlen); - break; - } -} -/*=======================================================================*/ -static int ECBTryAndFixIt(void *pData, int iCode, float fNew){ - pECBMotDriv self = (pECBMotDriv)pData; - int result; - Z80_reg in, out; - - assert(self); - - switch(iCode){ - case ECBMANUELL: - in.d = 1 ; - ecbExecute(self->ecb,162,in,&out); - result = MOTREDO; - break; - case COMMERROR: - ecbClear(self->ecb); - result = MOTREDO; - break; - default: - result = MOTFAIL; - break; - } - return result; -} -/*========================================================================*/ -static int ECBHalt(void *pData){ - pECBMotDriv self = (pECBMotDriv)pData; - Z80_reg in, out; - unsigned char par = 2; - - assert(self); - - if(rint(ObVal(self->driverPar,RANGE)) == 1){ - par |= 64; - } - - in.b = 9; - in.e = par; - in.c = (unsigned char)self->ecbIndex; - ecbExecute(self->ecb,MOPARA,in,&out); - self->restart = 0; - return 1; -} -/*=======================================================================*/ -static int ECBGetDriverPar(void *pData,char *name, float *value){ - pECBMotDriv self = (pECBMotDriv)pData; - ObPar *par = NULL; - - assert(self); - - par = ObParFind(self->driverPar,name); - if(par != NULL){ - *value = par->fVal; - return 1; - } else { - return 0; - } -} -/*=====================================================================*/ -static float fixAccTime(float newValue){ - float corrected, min, diff; - int val, possibleValues[4] = { 500, 1000, 2000, 5000}, i; - - val = (int)rint(newValue); - min = 9999999.99; - for(i = 0; i < 4; i++){ - diff = val - possibleValues[i]; - if(ABS(diff) < min){ - min = ABS(diff); - corrected = possibleValues[i]; - } - } - return corrected; -} -/*--------------------------------------------------------------------*/ -static void setDownloadFlag(pECBMotDriv self, int parNumber){ - int mustDownload; - - switch(parNumber){ - case CONTROL: - case MULT: - case MULTCHAN: - case ACCTIME: - case ROTDIR: - case STARTSPEED: - case MAXSPEED: - case SLOWAUTO: - case SLOWMAN: - case DELAY: - mustDownload = 1; - break; - default: - mustDownload = 0; - break; - } - - if(mustDownload && (self->driverPar[MULT].fVal == 0)){ - self->driverPar[MULT].fVal = -1.0; - } -} -/*--------------------------------------------------------------------*/ -static int putMotorPosition(pECBMotDriv self, float newValue){ - Z80_reg in,out; - Ecb_pack data; - float oldPos; - int status; - - if(ABS(ObVal(self->driverPar,ENCODER)) > .1){ - status = ECBMOTGetPos(self,&oldPos); - if(status != 1){ - return status; - } - return loadOffset(self,oldPos - newValue); - } else { - data.result = newValue*ObVal(self->driverPar,STEPS2DEG); - in.b = data.b.byt2; - in.d = data.b.byt1; - in.e = data.b.byt0; - in.c = (unsigned char)self->ecbIndex; - status = ecbExecute(self->ecb,142,in,&out); - if(status != 1){ - self->errorCode = COMMERROR; - return 0; - } - if(!checkMotorResult(self, out)){ - return 0; - } - } - - return 1; -} -/*---------------------------------------------------------------------*/ -static int ECBSetDriverPar(void *pData, SConnection *pCon, char *name, - float newValue){ - pECBMotDriv self = (pECBMotDriv)pData; - int parNumber, speedNumber, actualSpeed, status; - char pBueffel[256]; - float correctedValue; - - assert(self); - - - /* - only managers shall edit these parameters.... - */ - if(!SCMatchRights(pCon,usMugger)){ - return 0; - } - - /* - this is rather a command and forces a parameter download - to the ECB - */ - if(strcmp(name,"download") == 0){ - status = downloadECBParam(self); - if(status != 1){ - ECBGetError(self,&actualSpeed, pBueffel,254); - SCWrite(pCon,pBueffel,eError); - return status; - } - } - - /* - this is another command and assigns a position to the current - motor place - */ - if(strcmp(name,"putpos") == 0){ - status = putMotorPosition(self,newValue); - if(status != 1){ - ECBGetError(self,&actualSpeed, pBueffel,254); - SCWrite(pCon,pBueffel,eError); - return status; - } - } - - /* - get the parameter number - */ - parNumber = ObParIndex(self->driverPar,name); - if(parNumber < 0){ - return 0; - } - - /* - make these parameters right, at least as far as we can ....... - */ - switch(parNumber){ - case ACCTIME: - correctedValue = fixAccTime(newValue); - break; - case STARTSPEED: - getSpeedIndex(rint(newValue),1,&actualSpeed); - correctedValue = actualSpeed; - if(correctedValue < 10){ - correctedValue = 10; - } - if(correctedValue > 4400){ - correctedValue = 4400; - } - break; - case MAXSPEED: - getSpeedIndex(rint(newValue),1,&actualSpeed); - correctedValue = actualSpeed; - break; - case SLOWAUTO: - case SLOWMAN: - getSpeedIndex(rint(newValue),0,&actualSpeed); - correctedValue = actualSpeed; - if(correctedValue > 500){ - correctedValue = 500; - } - break; - case DELAY: - correctedValue = newValue; - if(correctedValue > 2500){ - correctedValue = 2500; - } - break; - case RANGE: - correctedValue = newValue; - if(correctedValue != 0.0 && correctedValue != 1.0){ - correctedValue = .0; /* slow by default! */ - } - break; - case ENCODER: - if(newValue < 0. || newValue > 3.){ - SCWrite(pCon,"ERROR: encoder numbers can only be 0 - 3", eError); - return 0; - } else if(newValue == 0){ - correctedValue = newValue; - } else { - ecbAssignEncoder(self->ecb,(int)newValue, self->ecbIndex); - correctedValue = newValue; - } - break; - case STEPS2DEG: - case DEG2STEP: - if(ABS(newValue) < .1){ - correctedValue = 1.; - } else { - correctedValue = newValue; - } - break; - case OFFSET: - correctedValue = newValue; - break; - default: - correctedValue = newValue; - break; - } - - if(ABS(correctedValue - newValue) > 0.){ - sprintf(pBueffel,"WARNING: Illegal value %6.2f verbosely coerced to %6.2f", - newValue,correctedValue); - SCWrite(pCon,pBueffel,eWarning); - } - - ObParSet(self->driverPar,self->name,name,correctedValue,pCon); - - setDownloadFlag(self,parNumber); - - return 1; -} -/*=========================================================================*/ -static void ECBListPar(void *pData, char *motorName, SConnection *pCon){ - pECBMotDriv self = (pECBMotDriv)pData; - char pBueffel[256]; - int i; - - assert(self); - - for(i = 0; i < MAXPAR-1; i++){ - sprintf(pBueffel,"%s.%s = %f", - motorName,self->driverPar[i].name, - self->driverPar[i].fVal); - SCWrite(pCon,pBueffel,eValue); - } -} -/*========================================================================*/ -static int interpretArguments(pECBMotDriv self, SConnection *pCon, - int argc, char *argv[]){ - char pBueffel[256]; - TokenList *pList, *pCurrent; - - pList = SplitArguments(argc,argv); - if(!pList || argc < 4){ - SCWrite(pCon,"ERROR: no arguments to CreateECBMotor",eError); - return 0; - } - pCurrent = pList; - - /* - first should be the name of the ECB to use - */ - if(pCurrent->Type != eText){ - sprintf(pBueffel,"ERROR: expected EDB name, got: %s", - pCurrent->text); - DeleteTokenList(pList); - return 0; - } - self->ecb = (pECB)FindCommandData(pServ->pSics,pCurrent->text,"ECB"); - if(!self->ecb){ - sprintf(pBueffel,"ERROR: %s is no ECB controller",pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return 0; - } - - /* - next the motor number - */ - pCurrent = pCurrent->pNext; - if(pCurrent->Type != eInt){ - sprintf(pBueffel,"ERROR: expected int motor number, got %s", - pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return 0; - } - self->ecbIndex = pCurrent->iVal; - - /* - next the limits - */ - pCurrent = pCurrent->pNext; - if(pCurrent->Type != eFloat){ - sprintf(pBueffel,"ERROR: expected float type limit, got %s", - pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return 0; - } - self->fLower = pCurrent->fVal; - pCurrent = pCurrent->pNext; - if(pCurrent->Type != eFloat){ - sprintf(pBueffel,"ERROR: expected float type limit, got %s", - pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return 0; - } - self->fUpper = pCurrent->fVal; - DeleteTokenList(pList); - - return 1; -} -/*-----------------------------------------------------------------------*/ -static void initializeParameters(pECBMotDriv self){ - ObParInit(self->driverPar,ENCODER,"encoder",0,usMugger); - ObParInit(self->driverPar,CONTROL,"control",0,usMugger); - ObParInit(self->driverPar,RANGE,"range",1,usMugger); - ObParInit(self->driverPar,MULT,"multi",0,usMugger); - ObParInit(self->driverPar,MULTCHAN,"multchan",0,usMugger); - ObParInit(self->driverPar,ACCTIME,"acceleration",500,usMugger); - ObParInit(self->driverPar,ROTDIR,"rotation_dir",1,usMugger); - ObParInit(self->driverPar,STARTSPEED,"startspeed",100,usMugger); - ObParInit(self->driverPar,MAXSPEED,"maxspeed",2000,usMugger); - ObParInit(self->driverPar,SLOWAUTO,"auto",100,usMugger); - ObParInit(self->driverPar,SLOWMAN,"manuell",100,usMugger); - ObParInit(self->driverPar,DELAY,"delay",50,usMugger); - ObParInit(self->driverPar,OFFSET,"offset",0,usMugger); - ObParInit(self->driverPar,TOLERANCE,"dtolerance",0.,usMugger); - ObParInit(self->driverPar,STEPS2DEG,"step2deg",1,usMugger); - ObParInit(self->driverPar,DEG2STEP,"step2dig",0,usMugger); - ObParInit(self->driverPar,BACKLASH,"backlash",0,usMugger); - ObParInit(self->driverPar,PORT,"port",0,usMugger); - ObParInit(self->driverPar,MAXPAR-1,"tueet",-100,-100); /* sentinel! */ -} -/*------------------------------------------------------------------------*/ -MotorDriver *CreateECBMotor(SConnection *pCon, int argc, char *argv[]){ - pECBMotDriv self = NULL; - - self = (pECBMotDriv)malloc(sizeof(ECBMOTDriv)); - if(self == NULL){ - return NULL; - } - memset(self,0,sizeof(ECBMOTDriv)); - - if(!interpretArguments(self,pCon,argc,argv)){ - free(self); - return 0; - } - - initializeParameters(self); - - /* - set function pointers - */ - self->GetPosition = ECBMOTGetPos; - self->RunTo = ECBRunTo; - self->GetStatus = ECBGetStatus; - self->GetError = ECBGetError; - self->TryAndFixIt = ECBTryAndFixIt; - self->Halt = ECBHalt; - self->GetDriverPar = ECBGetDriverPar; - self->SetDriverPar = ECBSetDriverPar; - self->ListDriverPar = ECBListPar; - - self->errorCode = 0; - return (MotorDriver *)self; -} -/*=======================================================================*/ -void KillECBMotor(void *pDriver){ - int i; - pECBMotDriv self = (pECBMotDriv)pDriver; - - for(i = 0; i < MAXPAR; i++){ - if(self->driverPar[i].name != NULL){ - free(self->driverPar[i].name); - } - } - free(self); -} diff --git a/ecbdriv.h b/ecbdriv.h deleted file mode 100644 index eda63b58..00000000 --- a/ecbdriv.h +++ /dev/null @@ -1,45 +0,0 @@ -/*------------------------------------------------------------------------ - this is a motor driver for the Risoe motor controllers within the - ECB system. The motor is controlled through functions invoked in the - Z80 processor of the ECB system which is connected through a GPIB - bus to the wider world. This driver has to do a lot of extra things: - - it has to convert from physical values to motor steps. - - Quite a few parameters, such as ramping parameters, - have to be downloaded to the ECB - - Risoe motors may have a virtual encoder or a real encoder. - - The motor may have to control air cushions as well. - - Tricky backlash handling. Backlash handling ensures that a position is - always arrived at from a defined direction. If backlash is applied - a restart flag is set in ECBRunTo. ECBGetStatus checks for that and - causes the motor to drive back to the position actually desired. - - This driver support only P2048a motor controllers, as these are the - only ones which seem to have arrived at PSI. The P1648 and Tridynamic - things are not supported. - - Multiplexed motors: Originally the ECB supported 24 motors. This did - prove to be not enough. Therefore another device called P2234e was - introduced which allowed to run 8 motors from one controller port. In this - case the motor parameters have to be copied to the ECB before - driving the motor. Multiplexing is selected through the parameter MULT. - MULT 0 means no multiplexing, MULT > 0 makes MULT the number of the - motor in the multiplexer. MULT is now also used to flag a download of - parameters to the ECB. In such a case MULT is -1. - - - Some of this code was taken from the tascom driver for the ECB. - - copyright: see file COPYRIGHT - - Mark Koennecke, January 2003 - ---------------------------------------------------------------------------*/ -#ifndef ECBDRIV -#define ECBDRIV - -MotorDriver *CreateECBMotor(SConnection *pCon, int argc, char *argv[]); -void KillECBMotor(void *driver); - -#endif - - diff --git a/el734dc.c b/el734dc.c deleted file mode 100644 index c5677963..00000000 --- a/el734dc.c +++ /dev/null @@ -1,907 +0,0 @@ -/*------------------------------------------------------------------------- - A motor driver for EL734 DC motors as used at SinQ - - - Mark Koennecke, November 1996 - - Original code foe EL734 stepper, modified for DC motors, the - 11-June-1997 Mark Koennecke - - Copyright: - - Labor fuer Neutronenstreuung - Paul Scherrer Institut - CH-5423 Villigen-PSI - - - The authors hereby grant permission to use, copy, modify, distribute, - and license this software and its documentation for any purpose, provided - that existing copyright notices are retained in all copies and that this - notice is included verbatim in any distributions. No written agreement, - license, or royalty fee is required for any of the authorized uses. - Modifications to this software may be copyrighted by their authors - and need not follow the licensing terms described here, provided that - the new terms are clearly indicated on the first page of each file where - they apply. - - IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY - FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY - DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - - THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE - IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE - NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR - MODIFICATIONS. -------------------------------------------------------------------------------*/ -#include -#include -#include -#include "fortify.h" -#include "Scommon.h" -#include "SCinter.h" -#include "conman.h" -#include "modriv.h" -#include "hardsup/sinq_prototypes.h" -#include "hardsup/rs232c_def.h" -#include "hardsup/el734_def.h" -#include "hardsup/el734fix.h" -#include "bit.h" -#include "splitter.h" -#include "servlog.h" - - static int EL734EncodeMSR(char *text, int iLen, - int iMSR, int iOMSR, int iFP, int iFR); - - static int EL734AnalyzeMSR(int iMSR, int iOMSR); - -/* addional error codes for Status-things */ -#define MSRBUSY -40 -#define MSRONLIMIT -41 -#define MSRRUNFAULT -42 -#define MSRPOSFAULT -43 -#define MSRDEADCUSHION -44 -#define MSRHALT -45 -#define MSRSTOP -46 -#define MSROK -47 -#define MSRREF -48 -#define MSRFAULT -49 - -/* --------------------------------------------------------------------------*/ - static int GetPos(void *self, float *fData) - { - EL734Driv *pDriv; - float fPos; - int iRet, iMSR, iOMSR, iFRC,iFPC, iSS; - - assert(self); - - pDriv = (EL734Driv *)self; - iRet = EL734_GetStatus(&(pDriv->EL734struct), - &iMSR, - &iOMSR, - &iFPC, - &iFRC, - &iSS, - &fPos); - if(iMSR != 0) - { - pDriv->iMSR = iMSR; - } - *fData = fPos; - if(iRet != 1) - { - return HWFault; - } - else - return OKOK; - - } -/*--------------------------------------------------------------------------*/ - static int Run(void *self, float fNew) - { - EL734Driv *pDriv; - int iRet; - - assert(self); - - pDriv = (EL734Driv *)self; - iRet = EL734_MoveNoWait (&(pDriv->EL734struct), fNew); - if(iRet == 1) - { - return OKOK; - } - else - { - return HWFault; - } - } - -/*--------------------------------------------------------------------------- - - EL734Error2Text converts between an EL734 error code to text ------------------------------------------------------------------------------*/ - static void EL734Error2Text(char *pBuffer, int iErr) - { - strcpy(pBuffer,"ERROR: HW:"); - switch(iErr) - { - case EL734__BAD_ADR: - strcat(pBuffer,"EL734__BAD_ADR"); - break; - case EL734__BAD_BIND: - strcat(pBuffer,"EL734__BAD_BIND"); - break; - case EL734__BAD_CMD: - strcat(pBuffer,"EL734__BAD_CMD"); - break; - case EL734__BAD_CONNECT: - strcat(pBuffer,"EL734__BAD_CONNECT"); - break; - case EL734__BAD_FLUSH: - strcat(pBuffer,"EL734__BAD_FLUSH"); - break; - case EL734__BAD_HOST: - strcat(pBuffer,"EL734__BAD_HOST"); - break; - case EL734__BAD_ID: - strcat(pBuffer,"EL734__BAD_ID"); - break; - case EL734__BAD_ILLG: - strcat(pBuffer,"EL734__BAD_ILLG"); - break; - case EL734__BAD_LOC: - strcat(pBuffer,"EL734__BAD_LOC"); - break; - case EL734__BAD_MALLOC: - strcat(pBuffer,"EL734__BAD_MALLOC"); - break; - case EL734__BAD_NOT_BCD: - strcat(pBuffer,"EL734__BAD_NOT_BCD"); - break; - case EL734__BAD_OFL: - strcat(pBuffer,"EL734__BAD_OFL"); - break; - case EL734__BAD_PAR: - strcat(pBuffer,"EL734__BAD_PAR"); - break; - - case EL734__BAD_RECV: - strcat(pBuffer,"EL734__BAD_RECV"); - break; - case EL734__BAD_RECV_NET: - strcat(pBuffer,"EL734__BAD_RECV_NET"); - break; - case EL734__BAD_RECV_PIPE: - strcat(pBuffer,"EL734__BAD_RECV_PIPE"); - break; - case EL734__BAD_RECV_UNKN: - strcat(pBuffer,"EL734__BAD_RECV_UNKN"); - break; - case EL734__BAD_RECVLEN: - strcat(pBuffer,"EL734__BAD_RECVLEN"); - break; - case EL734__BAD_RECV1: - strcat(pBuffer,"EL734__BAD_RECV1"); - break; - case EL734__BAD_RECV1_NET: - strcat(pBuffer,"EL734__BAD_RECV1_NET"); - break; - case EL734__BAD_RECV1_PIPE: - strcat(pBuffer,"EL734__BAD_RECV1_PIPE"); - break; - case EL734__BAD_RNG: - strcat(pBuffer,"EL734__BAD_RNG"); - break; - case EL734__BAD_SEND: - strcat(pBuffer,"EL734__BAD_SEND"); - break; - case EL734__BAD_SEND_PIPE: - strcat(pBuffer,"EL734__BAD_SEND_PIPE"); - break; - case EL734__BAD_SEND_NET: - strcat(pBuffer,"EL734__BAD_SEND_NET"); - break; - case EL734__BAD_SEND_UNKN: - strcat(pBuffer,"EL734__BAD_SEND_UNKN"); - break; - case EL734__BAD_SENDLEN: - strcat(pBuffer,"EL734__BAD_SENDLEN"); - break; - case EL734__BAD_SOCKET: - strcat(pBuffer,"EL734__BAD_SOCKET"); - break; - case EL734__BAD_TMO: - strcat(pBuffer,"EL734__BAD_TMO"); - break; - case EL734__FORCED_CLOSED: - strcat(pBuffer,"EL734__FORCED_CLOSED"); - break; - case EL734__BAD_STP: - strcat(pBuffer,"EL734__BAD_STP"); - break; - case EL734__EMERG_STOP: - strcat(pBuffer,"EL734__EMERG_STOP"); - break; - case EL734__NOT_OPEN: - strcat(pBuffer,"EL734__NOT_OPEN"); - break; - case EL734__BAD_ASYNSRV: - strcat(pBuffer,"EL734__BAD_ASYNSRV"); - break; - default: - sprintf(pBuffer,"Unknown EL734 error %d", iErr); - break; - } - } - -/*-------------------------------------------------------------------------*/ - static void GetErr(void *self, int *iCode, char *buffer, int iBufLen) - { - EL734Driv *pDriv; - char pBueffel[512]; - int iMSR, iOMSR, iSS; - int iRet, iFPC, iFRC; - int iErr; - float fPos; - char *pErr; - - assert(self); - - /* get EL734 error codes */ - pDriv = (EL734Driv *)self; - EL734_ErrInfo(&pErr,&iMSR,&iOMSR, &iSS); - if(iMSR != 0) - { - EL734Error2Text(pBueffel,iMSR); - strncpy(buffer,pBueffel,(iBufLen-1)); - *iCode = iMSR; - return; - } - else - { /* check status flag for addional errors */ - iRet = EL734_GetStatus(&(pDriv->EL734struct), - &iMSR, - &iOMSR, - &iFPC, - &iFRC, - &iSS, - &fPos); - if(iRet != 1) - { /* failure on this one, this has to be handled */ - EL734_ErrInfo(&pErr,&iMSR,&iOMSR, &iSS); - EL734Error2Text(pBueffel,iMSR); - strncpy(buffer,pBueffel,(iBufLen-1)); - *iCode = iMSR; - return; - - } - else - { - /* we really come down to looking at status flags */ - *iCode = EL734EncodeMSR(buffer,iBufLen,iMSR, iOMSR,iFPC,iFRC); - } - } - } -/* ------------------------------------------------------------------------ - Types of errors possible on EL734: - - Network error: Try reopening connection and redo command. - - Than there are problems which might have to do with a dodgy RS232, - resend command may help - - Some things cannot be fixed. -*/ - - static int FixError(void *self, int iError, float fNew) - { - EL734Driv *pDriv; - int iRet; - char pBueffel[512]; - int iMSR, iOMSR, iSS; - float fPos; - - assert(self); - pDriv = (EL734Driv *)self; - sprintf(pBueffel,"EL734 : %s %d %d %d Problem:",pDriv->hostname, - pDriv->iPort, pDriv->iChannel, pDriv->iMotor); - - /* get & check MSR flags */ - - - /* check for codes */ - switch(iError) - { - case 0: /* no error at all */ - return MOTOK; - case EL734__BAD_ID: /* ID */ - case EL734__BAD_ADR: /* ADR */ - case EL734__BAD_CMD: /* CMD */ - case EL734__BAD_ILLG: /* ILLG */ - case EL734__BAD_PAR: /* PAR */ - case EL734__BAD_TMO: - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("BAD Command or dodgy RS-232",eHWError); - return MOTREDO; - case EL734__EMERG_STOP: - return MOTFAIL; - case EL734__BAD_RNG: /* RNG */ - case MSRONLIMIT: - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("Out of Range",eHWError); - return MOTFAIL; - case EL734__BAD_STP: - return MOTFAIL; - break; - case MSRBUSY: - return MOTREDO; - case MSRRUNFAULT: - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("------ RUN Fault in Controller ---- ",eHWError); - return MOTFAIL; - case MSRPOSFAULT: - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("------ POS Fault in Controller ---- ",eHWError); - return MOTFAIL; - case MSRDEADCUSHION: - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("------ Air cushion Fault in Controller ---- ",eHWError); - return MOTFAIL; - case MSRFAULT: - return MOTFAIL; - case MSRHALT: - case MSRSTOP: - return MOTFAIL; - case EL734__FORCED_CLOSED: - case EL734__NOT_OPEN: - iRet = EL734_Open(&(pDriv->EL734struct),pDriv->hostname, - pDriv->iPort,pDriv->iChannel, - pDriv->iMotor,"DCMC EL734"); - if(iRet != 1) - { - return MOTFAIL; - } - else - { - return MOTREDO; - } - break; - case EL734__BAD_LOC: /* LO2 */ - case EL734__BAD_OFL: - EL734_Close(&(pDriv->EL734struct),0); - iRet = EL734_Open(&(pDriv->EL734struct),pDriv->hostname, - pDriv->iPort,pDriv->iChannel, - pDriv->iMotor,"DCMC EL734"); - if(iRet != 1) - { - return MOTFAIL; - } - else - { - return MOTREDO; - } - break; -/* case EL734__BAD_ASYNSRV: - EL734_Close(&(pDriv->EL734struct),1); - return MOTREDO; - break; -*/ default: - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("Network problem, trying to reopen",eHWError); - EL734_Close(&(pDriv->EL734struct),1); - iRet = EL734_Open(&(pDriv->EL734struct),pDriv->hostname, - pDriv->iPort,pDriv->iChannel, - pDriv->iMotor,"DCMC EL734"); - if(iRet != 1) - { - return MOTFAIL; - } - else - { - return MOTREDO; - } - } - - } -/*--------------------------------------------------------------------------*/ - static int Halt(void *self) - { - EL734Driv *pDriv; - int iRet; - char pBueffel[80]; - - assert(self); - pDriv = (EL734Driv *)self; - iRet = EL734_Stop(&(pDriv->EL734struct)); - if(iRet != 1) - { - return OKOK; - } - return HWFault; - } -/*--------------------------------------------------------------------------*/ - static int GetStat(void *self) - { - EL734Driv *pDriv; - float fPos; - int iRet, iMSR, iOMSR, iFRC,iFPC, iSS; - int eRet; - int iTest; - char pBueffel[80]; - - assert(self); - - pDriv = (EL734Driv *)self; - iRet = EL734_GetStatus(&(pDriv->EL734struct), - &iMSR, - &iOMSR, - &iFPC, - &iFRC, - &iSS, - &fPos); - if(iRet != 1) - { - return HWFault; - } - - if(iMSR != 0) - { - pDriv->iMSR = iMSR; - } - - iTest = EL734AnalyzeMSR(iMSR,iOMSR); - switch(iTest) - { - case MSRDEADCUSHION: - case MSRONLIMIT: - case MSRREF: - case MSRHALT: - case MSRSTOP: - return HWFault; - break; - case MSRRUNFAULT: - case MSRPOSFAULT: - return HWPosFault; - break; - case MSRBUSY: - return HWBusy; - break; - case MSRFAULT: - return HWWarn; - break; - default: - return HWIdle; - break; - } - - } - -/*---------------------------------------------------------------------------*/ - static EL734Driv *MakeEL734DC(char *hostname, int iPort, int iChannel, - int iMotor) - { - EL734Driv *pDriv = NULL; - - int iError; - char pBueffel[80]; - char *pErr; - int iRet; - int iDummy; - - /* create a new struct */ - pDriv = (EL734Driv *)malloc(sizeof(EL734Driv)); - if(!pDriv) - { - return NULL; - } - memset(pDriv,0,sizeof(EL734Driv)); - - /* fill in some of the data entered */ - pDriv->hostname = strdup(hostname); - pDriv->iPort = iPort; - pDriv->iChannel = iChannel; - pDriv->iMotor = iMotor; - pDriv->name = strdup("EL734"); - - /* try opening the motor */ - iRet = EL734_Open(&(pDriv->EL734struct), hostname,iPort, - iChannel,iMotor,"DCMC EL734"); - if(iRet != 1) - { - EL734_ErrInfo(&pErr,&iError,&iRet, &iDummy); - KillEL734((void *)pDriv); - return NULL; - } - - /* now get the limits */ - EL734_GetLimits(&(pDriv->EL734struct),&(pDriv->fLower), - &(pDriv->fUpper)); - - - /* initialise the function pointers */ - pDriv->GetPosition = GetPos; - pDriv->RunTo = Run; - pDriv->GetError = GetErr; - pDriv->GetStatus = GetStat; - pDriv->Halt = Halt; - pDriv->TryAndFixIt = FixError; - - - return pDriv; - } -/*-------------------------------------------------------------------------- - interpreting the driver parameters is up to the driver, this below - inplements just this - */ - MotorDriver *CreateEL734DC(SConnection *pCon, int argc, char *argv[]) - { - EL734Driv *pDriv = NULL; - TokenList *pList = NULL; - TokenList *pCurrent; - char *hostname; - int iPort, iChannel, iMotor; - char pBueffel[512]; - - assert(pCon); - - /* split arguments */ - pList = SplitArguments(argc,argv); - if(!pList) - { - SCWrite(pCon,"Error parsing arguments",eError); - return NULL; - } - - /* first must be hostname */ - pCurrent = pList; - if(pCurrent->Type != eText) - { - sprintf(pBueffel,"EL734DC: Expected hostname but got --> %s <--", - pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return NULL; - } - hostname = pCurrent->text; - - /* next should be port */ - pCurrent = pCurrent->pNext; - if(!pCurrent) - { - SCWrite(pCon,"EL734DC: Insufficient number of arguments",eError); - DeleteTokenList(pList); - return NULL; - } - if(pCurrent->Type != eInt) - { - sprintf(pBueffel,"EL734DC: Expected Integer as Port number, got --> %s <--", - pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return NULL; - } - iPort = pCurrent->iVal; - - - /* next should be Channel number */ - pCurrent = pCurrent->pNext; - if(!pCurrent) - { - SCWrite(pCon,"EL734DC: Insufficient number of arguments",eError); - DeleteTokenList(pList); - return NULL; - } - if(pCurrent->Type != eInt) - { - sprintf(pBueffel,"EL734DC: Expected Integer as channel number, got --> %s <--", - pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return NULL; - } - iChannel = pCurrent->iVal; - - /* finally motor number */ - pCurrent = pCurrent->pNext; - if(!pCurrent) - { - - SCWrite(pCon,"EL734DC: Insufficient number of arguments",eError); - DeleteTokenList(pList); - return NULL; - } - if(pCurrent->Type != eInt) - { - sprintf(pBueffel,"EL734DC: Expected Integer as motor number, got --> %s <--", - pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return NULL; - } - iMotor = pCurrent->iVal; - - - /* finally initialize driver */ - pDriv = MakeEL734DC(hostname,iPort,iChannel,iMotor); - if(!pDriv) - { - SCWrite(pCon,"EL734DC: error opening motor, check adress",eError); - pDriv = NULL; - } - - /* clean up */ - DeleteTokenList(pList); - return (MotorDriver *)pDriv; - } -/*------------------------------------------------------------------------- - Stolen from David and modified to return an integer error code as well -*/ - static int EL734EncodeMSR (char *text, int text_len, - int msr, - int ored_msr, - int fp_cntr, - int fr_cntr) { - int len; - char my_text[132]; - char my_text_0[32]; - int iRet = 0; - - if (msr == 0) { - ored_msr = ored_msr & ~(MSR__BUSY); /* Zero "Busy" bit */ - if (ored_msr == MSR__OK) { - StrJoin (text, text_len, "Status, MSR = Idle. Positioned OK.", ""); - }else { - if ((ored_msr & MSR__OK) != 0) { - StrJoin (text, text_len, "Status, MSR = Idle. Positioned OK. ", ""); - }else { - StrJoin (text, text_len, "Status, MSR = Idle. ", ""); - } - if ((ored_msr & MSR__REF_OK) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n OK. "); - } - if ((ored_msr & MSR__LIM_ERR) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Limit Switch Problem. "); - iRet = MSRONLIMIT; - } - if ((ored_msr & MSR__AC_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Air-Cushion Error. "); - iRet = MSRDEADCUSHION; - } - if ((ored_msr & MSR__REF_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n Fail. "); - } - if ((ored_msr & MSR__POS_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Pos'n Fail. "); - iRet = MSRPOSFAULT; - } - if ((ored_msr & MSR__POS_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - if (fp_cntr == 1) { - StrJoin (text, text_len, my_text, "1 Pos'n Fault. "); - }else { - sprintf (my_text_0, "%d Pos'n Faults. ", fp_cntr); - StrJoin (text, text_len, my_text, my_text_0); - } - } - if ((ored_msr & MSR__RUN_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Run Fail. "); - iRet = MSRRUNFAULT; - } - if ((ored_msr & MSR__RUN_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - if (fr_cntr == 1) { - StrJoin (text, text_len, my_text, "1 Run Fault. "); - }else { - sprintf (my_text_0, "%d Run Faults. ", fr_cntr); - StrJoin (text, text_len, my_text, my_text_0); - } - } - if ((ored_msr & MSR__HALT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Halt. "); - iRet = MSRHALT; - } - if ((ored_msr & MSR__HI_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit HiLim. "); - iRet = MSRONLIMIT; - } - if ((ored_msr & MSR__LO_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit LoLim. "); - iRet = MSRONLIMIT; - } - if ((ored_msr & MSR__STOPPED) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Stopped. "); - iRet = MSRSTOP; - } - } - }else if ((msr & ~(0x2fff)) != 0) { - StrJoin (text, text_len, "Status, MSR = ??", ""); - }else { - sprintf (my_text, "%#x ", msr); - StrJoin (text, text_len, "Status, MSR = ", my_text); - if ((msr & MSR__LIM_ERR) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Limit Switch Problem/"); - iRet = MSRONLIMIT; - } - if ((msr & MSR__AC_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Air-Cushion Error/"); - iRet = MSRDEADCUSHION; - } - if ((msr & MSR__REF_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n Fail/"); - } - if ((msr & MSR__POS_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Pos'n Fail/"); - iRet = MSRPOSFAULT; - } - if ((msr & MSR__POS_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Pos'n Fault/"); - } - if ((msr & MSR__RUN_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Run Fail/"); - iRet = MSRRUNFAULT; - } - if ((msr & MSR__RUN_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Run Fault/"); - } - if ((msr & MSR__HALT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Halt/"); - iRet = MSRHALT; - } - if ((msr & MSR__HI_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit HiLim/"); - iRet = MSRONLIMIT; - } - if ((msr & MSR__LO_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit LoLim/"); - iRet = MSRONLIMIT; - } - if ((msr & MSR__STOPPED) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Stopped/"); - iRet = MSRSTOP; - } - if ((msr & MSR__REF_OK) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n OK/"); - } - if ((msr & MSR__OK) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "OK/"); - } - if ((msr & MSR__BUSY) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Busy/"); - } - len = strlen (text); - text[len-1] = '\0'; - } - return iRet; - } -/*-------------------------------------------------------------------------*/ - static int EL734AnalyzeMSR(int msr,int ored_msr) - { - int iRet = 0; - - /* this means the motor is done */ - if (msr == 0) { - ored_msr = ored_msr & ~(MSR__BUSY); /* Zero "Busy" bit */ - if (ored_msr == MSR__OK) { - iRet = MSROK; - }else { - if ((ored_msr & MSR__OK) != 0) { - iRet = MSROK; - }else { - iRet = MSROK; - } - if ((ored_msr & MSR__REF_OK) != 0) { - iRet = MSROK; - } - if ((ored_msr & MSR__LIM_ERR) != 0) { - return MSRONLIMIT; - } - if ((ored_msr & MSR__AC_FAIL) != 0) { - return MSRDEADCUSHION; - } - if ((ored_msr & MSR__REF_FAIL) != 0) { - iRet = MSRREF; - } - if ((ored_msr & MSR__POS_FAIL) != 0) { - return MSRPOSFAULT; - } - if ((ored_msr & MSR__POS_FAULT) != 0) { - iRet = MSRFAULT; - } - if ((ored_msr & MSR__RUN_FAIL) != 0) { - return MSRRUNFAULT; - } - if ((ored_msr & MSR__RUN_FAULT) != 0) { - iRet = MSRFAULT; - } - if ((ored_msr & MSR__HALT) != 0) { - return MSRHALT; - } - if ((ored_msr & MSR__HI_LIM) != 0) { - return MSRONLIMIT; - } - if ((ored_msr & MSR__LO_LIM) != 0) { - return MSRONLIMIT; - } - if ((ored_msr & MSR__STOPPED) != 0) { - return MSRSTOP; - } - } - /* the motor is still fighting along */ - }else if ((msr & ~(0x2fff)) != 0) { - iRet = MSROK; - }else { - if ((msr & MSR__LIM_ERR) != 0) { - return MSRONLIMIT; - } - if ((msr & MSR__AC_FAIL) != 0) { - return MSRDEADCUSHION; - } - if ((msr & MSR__REF_FAIL) != 0) { - iRet = MSRREF; - } - if ((msr & MSR__POS_FAIL) != 0) { - return MSRPOSFAULT; - } - if ((msr & MSR__POS_FAULT) != 0) { - iRet = MSRFAULT; - } - if ((msr & MSR__RUN_FAIL) != 0) { - return MSRRUNFAULT; - } - if ((msr & MSR__RUN_FAULT) != 0) { - iRet = MSRFAULT; - } - if ((msr & MSR__HALT) != 0) { - return MSRHALT; - } - if ((msr & MSR__HI_LIM) != 0) { - return MSRONLIMIT; - } - if ((msr & MSR__LO_LIM) != 0) { - return MSRONLIMIT; - } - if ((msr & MSR__STOPPED) != 0) { - return MSRSTOP; - } - if ((msr & MSR__REF_OK) != 0) { - iRet = MSROK; - } - if ((msr & MSR__OK) != 0) { - iRet = MSROK; - } - if ((msr & MSR__BUSY) != 0) { - iRet = MSRBUSY; - } - } - return iRet; - } - - diff --git a/el734driv.c b/el734driv.c deleted file mode 100644 index 10835d86..00000000 --- a/el734driv.c +++ /dev/null @@ -1,923 +0,0 @@ -/*-------------------------------------------------------------------------- - A motor driver for EL734 type motors as used at SinQ - - - Mark Koennecke, November 1996 - - Copyright: - - Labor fuer Neutronenstreuung - Paul Scherrer Institut - CH-5423 Villigen-PSI - - - The authors hereby grant permission to use, copy, modify, distribute, - and license this software and its documentation for any purpose, provided - that existing copyright notices are retained in all copies and that this - notice is included verbatim in any distributions. No written agreement, - license, or royalty fee is required for any of the authorized uses. - Modifications to this software may be copyrighted by their authors - and need not follow the licensing terms described here, provided that - the new terms are clearly indicated on the first page of each file where - they apply. - - IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY - FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY - DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - - THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE - IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE - NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR - MODIFICATIONS. -------------------------------------------------------------------------------*/ -#include -#include -#include -#include "fortify.h" -#include "sics.h" -#include "modriv.h" -#include "hardsup/sinq_prototypes.h" -#include "hardsup/rs232c_def.h" -#include "hardsup/el734_def.h" -#include "hardsup/el734fix.h" -#include "bit.h" -#include "splitter.h" - - - - static int EL734EncodeMSR(char *text, int iLen, - int iMSR, int iOMSR, int iFP, int iFR); - - static int EL734AnalyzeMSR(int iMSR, int iOMSR); - -/* addional error codes for Status-things */ -#define MSRBUSY -40 -#define MSRONLIMIT -41 -#define MSRRUNFAULT -42 -#define MSRPOSFAULT -43 -#define MSRDEADCUSHION -44 -#define MSRHALT -45 -#define MSRSTOP -46 -#define MSROK -47 -#define MSRREF -48 -#define MSRFAULT -49 -/* --------------------------------------------------------------------------*/ - static int GetPos(void *self, float *fData) - { - EL734Driv *pDriv; - float fPos; - int iRet, iMSR, iOMSR, iFRC,iFPC, iSS; - - assert(self); - - pDriv = (EL734Driv *)self; - iRet = EL734_GetStatus(&(pDriv->EL734struct), - &iMSR, - &iOMSR, - &iFPC, - &iFRC, - &iSS, - &fPos); - if(iMSR != 0) - { - pDriv->iMSR = iMSR; - } - *fData = fPos; - if(iRet != 1) - { - return HWFault; - } - else - return OKOK; - - } -/*--------------------------------------------------------------------------*/ - static int Run(void *self, float fNew) - { - EL734Driv *pDriv; - int iRet; - - assert(self); - - pDriv = (EL734Driv *)self; - iRet = EL734_MoveNoWait (&(pDriv->EL734struct), fNew); - if(iRet == 1) - { - return OKOK; - } - else - { - return HWFault; - } - } - -/*--------------------------------------------------------------------------- - - EL734Error2Text converts between an EL734 error code to text ------------------------------------------------------------------------------*/ - extern char EL734_IllgText[256]; - - static void EL734Error2Text(char *pBuffer, int iErr) - { - strcpy(pBuffer,"ERROR: HW:"); - switch(iErr) - { - case EL734__BAD_ADR: - strcat(pBuffer,"EL734__BAD_ADR"); - break; - case EL734__BAD_BIND: - strcat(pBuffer,"EL734__BAD_BIND"); - break; - case EL734__BAD_CMD: - strcat(pBuffer,"EL734__BAD_CMD"); - break; - case EL734__BAD_CONNECT: - strcat(pBuffer,"EL734__BAD_CONNECT"); - break; - case EL734__BAD_FLUSH: - strcat(pBuffer,"EL734__BAD_FLUSH"); - break; - case EL734__BAD_HOST: - strcat(pBuffer,"EL734__BAD_HOST"); - break; - case EL734__BAD_ID: - strcat(pBuffer,"EL734__BAD_ID"); - break; - case EL734__BAD_ILLG: - strcat(pBuffer,"EL734__BAD_ILLG "); - - strcat(pBuffer,EL734_IllgText); - - break; - case EL734__BAD_LOC: - strcat(pBuffer,"EL734__BAD_LOC"); - break; - case EL734__BAD_MALLOC: - strcat(pBuffer,"EL734__BAD_MALLOC"); - break; - case EL734__BAD_NOT_BCD: - strcat(pBuffer,"EL734__BAD_NOT_BCD"); - break; - case EL734__BAD_OFL: - strcat(pBuffer,"EL734__BAD_OFL"); - break; - case EL734__BAD_PAR: - strcat(pBuffer,"EL734__BAD_PAR"); - break; - - case EL734__BAD_RECV: - strcat(pBuffer,"EL734__BAD_RECV"); - break; - case EL734__BAD_RECV_NET: - strcat(pBuffer,"EL734__BAD_RECV_NET"); - break; - case EL734__BAD_RECV_PIPE: - strcat(pBuffer,"EL734__BAD_RECV_PIPE"); - break; - case EL734__BAD_RECV_UNKN: - strcat(pBuffer,"EL734__BAD_RECV_UNKN"); - break; - case EL734__BAD_RECVLEN: - strcat(pBuffer,"EL734__BAD_RECVLEN"); - break; - case EL734__BAD_RECV1: - strcat(pBuffer,"EL734__BAD_RECV1"); - break; - case EL734__BAD_RECV1_NET: - strcat(pBuffer,"EL734__BAD_RECV1_NET"); - break; - case EL734__BAD_RECV1_PIPE: - strcat(pBuffer,"EL734__BAD_RECV1_PIPE"); - break; - case EL734__BAD_RNG: - strcat(pBuffer,"EL734__BAD_RNG"); - break; - case EL734__BAD_SEND: - strcat(pBuffer,"EL734__BAD_SEND"); - break; - case EL734__BAD_SEND_PIPE: - strcat(pBuffer,"EL734__BAD_SEND_PIPE"); - break; - case EL734__BAD_SEND_NET: - strcat(pBuffer,"EL734__BAD_SEND_NET"); - break; - case EL734__BAD_SEND_UNKN: - strcat(pBuffer,"EL734__BAD_SEND_UNKN"); - break; - case EL734__BAD_SENDLEN: - strcat(pBuffer,"EL734__BAD_SENDLEN"); - break; - case EL734__BAD_SOCKET: - strcat(pBuffer,"EL734__BAD_SOCKET"); - break; - case EL734__BAD_TMO: - strcat(pBuffer,"EL734__BAD_TMO"); - break; - case EL734__FORCED_CLOSED: - strcat(pBuffer,"EL734__FORCED_CLOSED"); - break; - case EL734__BAD_STP: - strcat(pBuffer,"EL734__BAD_STP"); - break; - case EL734__EMERG_STOP: - strcat(pBuffer,"EL734__EMERG_STOP"); - break; - case EL734__NOT_OPEN: - strcat(pBuffer,"EL734__NOT_OPEN"); - break; - case EL734__BAD_ASYNSRV: - strcat(pBuffer,"EL734__BAD_ASYNSRV"); - break; - default: - sprintf(pBuffer,"Unknown EL734 error %d",iErr); - break; - } - } - -/*-------------------------------------------------------------------------*/ - static void GetErr(void *self, int *iCode, char *buffer, int iBufLen) - { - EL734Driv *pDriv; - char pBueffel[512]; - int iMSR, iOMSR, iSS; - int iRet, iFPC, iFRC; - int iErr; - float fPos; - char *pErr; - - assert(self); - - /* get EL734 error codes */ - pDriv = (EL734Driv *)self; - EL734_ErrInfo(&pErr,&iMSR,&iOMSR, &iSS); - if(iMSR != 0) - { - EL734Error2Text(pBueffel,iMSR); - strncpy(buffer,pBueffel,(iBufLen-1)); - *iCode = iMSR; - return; - } - else - { /* check status flag for addional errors */ - iRet = EL734_GetStatus(&(pDriv->EL734struct), - &iMSR, - &iOMSR, - &iFPC, - &iFRC, - &iSS, - &fPos); - if(iRet != 1) - { /* failure on this one, this has to be handled */ - EL734_ErrInfo(&pErr,&iMSR,&iOMSR, &iSS); - EL734Error2Text(pBueffel,iMSR); - strncpy(buffer,pBueffel,(iBufLen-1)); - *iCode = iMSR; - return; - - } - else - { - /* we really come down to looking at status flags */ - *iCode = EL734EncodeMSR(buffer,iBufLen,iMSR, iOMSR,iFPC,iFRC); - } - } - } -/* ------------------------------------------------------------------------ - Types of errors possible on EL734: - - Network error: Try reopening connection and redo command. - - Than there are problems which might have to do with a dodgy RS232, - resend command may help - - Some things cannot be fixed. -*/ - - static int FixError(void *self, int iError, float fNew) - { - EL734Driv *pDriv; - int iRet; - char pBueffel[512]; - int iMSR, iOMSR, iSS; - float fPos; - - assert(self); - pDriv = (EL734Driv *)self; - sprintf(pBueffel,"EL734 : %s %d %d %d Problem:",pDriv->hostname, - pDriv->iPort, pDriv->iChannel, pDriv->iMotor); - - /* get & check MSR flags */ - - - /* check for codes */ - switch(iError) - { - case 0: /* no error at all */ - return MOTOK; - case EL734__BAD_ID: /* ID */ - case EL734__BAD_ADR: /* ADR */ - case EL734__BAD_CMD: /* CMD */ - case EL734__BAD_ILLG: /* ILLG */ - case EL734__BAD_PAR: /* PAR */ - case EL734__BAD_TMO: /* timeout */ - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("BAD Command or dodgy RS-232",eHWError); - return MOTREDO; - case EL734__EMERG_STOP: - return MOTFAIL; - case EL734__BAD_STP: /* motor disabled by switch */ - return MOTFAIL; - break; - case EL734__BAD_RNG: /* RNG */ - case MSRONLIMIT: - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("Out of Range",eHWError); - return MOTFAIL; - case MSRBUSY: - return MOTREDO; - case MSRRUNFAULT: - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("------ RUN Fault in Controller ---- ",eHWError); - return MOTFAIL; - case MSRPOSFAULT: - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("------ POS Fault in Controller ---- ",eHWError); - return MOTFAIL; - case MSRDEADCUSHION: - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("------ Air cushion Fault in Controller ---- ",eHWError); - return MOTFAIL; - case MSRFAULT: - return MOTFAIL; - case MSRHALT: - case MSRSTOP: - return MOTFAIL; - case EL734__FORCED_CLOSED: - case EL734__NOT_OPEN: - iRet = EL734_Open(&(pDriv->EL734struct),pDriv->hostname, - pDriv->iPort,pDriv->iChannel, - pDriv->iMotor,"STPMC EL734"); - if(iRet != 1) - { - return MOTFAIL; - } - else - { - return MOTREDO; - } - break; - case EL734__BAD_OFL: - case EL734__BAD_LOC: /* LOocal mode */ - EL734_Close(&(pDriv->EL734struct),0); - iRet = EL734_Open(&(pDriv->EL734struct),pDriv->hostname, - pDriv->iPort,pDriv->iChannel, - pDriv->iMotor,"STPMC EL734"); - if(iRet != 1) - { - return MOTFAIL; - } - else - { - return MOTREDO; - } - break; -/* case EL734__BAD_ASYNSRV: - EL734_Close(&(pDriv->EL734struct),1); - return MOTREDO; -*/ - default: - SICSLogWrite(pBueffel,eHWError); - SICSLogWrite("Network problem, trying to reopen",eHWError); - EL734_Close(&(pDriv->EL734struct),1); - iRet = EL734_Open(&(pDriv->EL734struct),pDriv->hostname, - pDriv->iPort,pDriv->iChannel, - pDriv->iMotor,"STPMC EL734"); - if(iRet != 1) - { - return MOTFAIL; - } - else - { - return MOTREDO; - } - } - - } -/*--------------------------------------------------------------------------*/ - static int Halt(void *self) - { - EL734Driv *pDriv; - int iRet; - char pBueffel[80]; - - assert(self); - pDriv = (EL734Driv *)self; - iRet = EL734_Stop(&(pDriv->EL734struct)); - if(iRet == 1) - { - return OKOK; - } - return HWFault; - } -/*--------------------------------------------------------------------------*/ - static int GetStat(void *self) - { - EL734Driv *pDriv; - float fPos; - int iRet, iMSR, iOMSR, iFRC,iFPC, iSS; - int eRet; - int iTest; - char pBueffel[80]; - - assert(self); - - pDriv = (EL734Driv *)self; - iRet = EL734_GetStatus(&(pDriv->EL734struct), - &iMSR, - &iOMSR, - &iFPC, - &iFRC, - &iSS, - &fPos); - if(iRet != 1) - { - return HWFault; - } - - if(iMSR != 0) - { - pDriv->iMSR = iMSR; - } - - iTest = EL734AnalyzeMSR(iMSR,iOMSR); - switch(iTest) - { - case MSRDEADCUSHION: - case MSRONLIMIT: - case MSRREF: - case MSRHALT: - case MSRSTOP: - return HWFault; - break; - case MSRRUNFAULT: - case MSRPOSFAULT: - return HWPosFault; - break; - case MSRBUSY: - return HWBusy; - break; - case MSRFAULT: - return HWWarn; - break; - default: - return HWIdle; - break; - } - } - -/*---------------------------------------------------------------------------*/ - static EL734Driv *MakeEL734(char *hostname, int iPort, int iChannel, - int iMotor) - { - EL734Driv *pDriv = NULL; - - int iError; - char pBueffel[80]; - char *pErr; - int iRet; - int iDummy; - - /* create a new struct */ - pDriv = (EL734Driv *)malloc(sizeof(EL734Driv)); - if(!pDriv) - { - return NULL; - } - memset(pDriv,0,sizeof(EL734Driv)); - - /* fill in some of the data entered */ - pDriv->hostname = strdup(hostname); - pDriv->iPort = iPort; - pDriv->iChannel = iChannel; - pDriv->iMotor = iMotor; - pDriv->name = strdup("EL734"); - - /* try opening the motor */ - iRet = EL734_Open(&(pDriv->EL734struct), hostname,iPort, - iChannel,iMotor,"STPMC EL734"); - if(iRet != 1) - { - EL734_ErrInfo(&pErr,&iError,&iRet, &iDummy); - KillEL734((void *)pDriv); - return NULL; - } - - /* now get the limits */ - EL734_GetLimits(&(pDriv->EL734struct),&(pDriv->fLower), - &(pDriv->fUpper)); - - - /* initialise the function pointers */ - pDriv->GetPosition = GetPos; - pDriv->RunTo = Run; - pDriv->GetError = GetErr; - pDriv->GetStatus = GetStat; - pDriv->Halt = Halt; - pDriv->TryAndFixIt = FixError; - - - return pDriv; - } -/*--------------------------------------------------------------------------*/ - void KillEL734(void *self) - { - EL734Driv *pDriv; - - assert(self); - pDriv = (EL734Driv *)self; - - EL734_Close(&(pDriv->EL734struct),0); - if(pDriv->hostname) - free(pDriv->hostname); - if(pDriv->name) - free(pDriv->name); - free(pDriv); - - } - -/*-------------------------------------------------------------------------- - interpreting the driver parameters is up to the driver, this below - inplements just this - */ - MotorDriver *CreateEL734(SConnection *pCon, int argc, char *argv[]) - { - EL734Driv *pDriv = NULL; - TokenList *pList = NULL; - TokenList *pCurrent; - char *hostname; - int iPort, iChannel, iMotor; - char pBueffel[512]; - - assert(pCon); - - /* split arguments */ - pList = SplitArguments(argc,argv); - if(!pList) - { - SCWrite(pCon,"Error parsing arguments",eError); - return NULL; - } - - /* first must be hostname */ - pCurrent = pList; - if(pCurrent->Type != eText) - { - sprintf(pBueffel,"EL734: Expected hostname but got --> %s <--", - pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return NULL; - } - hostname = pCurrent->text; - - /* next should be port */ - pCurrent = pCurrent->pNext; - if(!pCurrent) - { - SCWrite(pCon,"EL734: Insufficient number of arguments",eError); - DeleteTokenList(pList); - return NULL; - } - if(pCurrent->Type != eInt) - { - sprintf(pBueffel,"EL734: Expected Integer as Port number, got --> %s <--", - pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return NULL; - } - iPort = pCurrent->iVal; - - - /* next should be Channel number */ - pCurrent = pCurrent->pNext; - if(!pCurrent) - { - SCWrite(pCon,"EL734: Insufficient number of arguments",eError); - DeleteTokenList(pList); - return NULL; - } - if(pCurrent->Type != eInt) - { - sprintf(pBueffel,"EL734: Expected Integer as channel number, got --> %s <--", - pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return NULL; - } - iChannel = pCurrent->iVal; - - /* finally motor number */ - pCurrent = pCurrent->pNext; - if(!pCurrent) - { - - SCWrite(pCon,"EL734: Insufficient number of arguments",eError); - DeleteTokenList(pList); - return NULL; - } - if(pCurrent->Type != eInt) - { - sprintf(pBueffel,"EL734: Expected Integer as motor number, got --> %s <--", - pCurrent->text); - SCWrite(pCon,pBueffel,eError); - DeleteTokenList(pList); - return NULL; - } - iMotor = pCurrent->iVal; - - - /* finally initialize driver */ - pDriv = MakeEL734(hostname,iPort,iChannel,iMotor); - if(!pDriv) - { - SCWrite(pCon,"EL734: error opening motor, check adress",eError); - pDriv = NULL; - } - - /* clean up */ - DeleteTokenList(pList); - return (MotorDriver *)pDriv; - } -/*------------------------------------------------------------------------- - Stolen from David and modified to return an integer error code as well -*/ - static int EL734EncodeMSR (char *text, int text_len, - int msr, - int ored_msr, - int fp_cntr, - int fr_cntr) { - int len; - char my_text[132]; - char my_text_0[32]; - int iRet = 0; - - if (msr == 0) { - ored_msr = ored_msr & ~(MSR__BUSY); /* Zero "Busy" bit */ - if (ored_msr == MSR__OK) { - StrJoin (text, text_len, "Status, MSR = Idle. Positioned OK.", ""); - }else { - if ((ored_msr & MSR__OK) != 0) { - StrJoin (text, text_len, "Status, MSR = Idle. Positioned OK. ", ""); - }else { - StrJoin (text, text_len, "Status, MSR = Idle. ", ""); - } - if ((ored_msr & MSR__REF_OK) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n OK. "); - } - if ((ored_msr & MSR__LIM_ERR) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Limit Switch Problem. "); - iRet = MSRONLIMIT; - } - if ((ored_msr & MSR__AC_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Air-Cushion Error. "); - iRet = MSRDEADCUSHION; - } - if ((ored_msr & MSR__REF_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n Fail. "); - } - if ((ored_msr & MSR__POS_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Pos'n Fail. "); - iRet = MSRPOSFAULT; - } - if ((ored_msr & MSR__POS_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - if (fp_cntr == 1) { - StrJoin (text, text_len, my_text, "1 Pos'n Fault. "); - }else { - sprintf (my_text_0, "%d Pos'n Faults. ", fp_cntr); - StrJoin (text, text_len, my_text, my_text_0); - } - } - if ((ored_msr & MSR__RUN_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Run Fail. "); - iRet = MSRRUNFAULT; - } - if ((ored_msr & MSR__RUN_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - if (fr_cntr == 1) { - StrJoin (text, text_len, my_text, "1 Run Fault. "); - }else { - sprintf (my_text_0, "%d Run Faults. ", fr_cntr); - StrJoin (text, text_len, my_text, my_text_0); - } - } - if ((ored_msr & MSR__HALT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Halt. "); - iRet = MSRHALT; - } - if ((ored_msr & MSR__HI_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit HiLim. "); - iRet = MSRONLIMIT; - } - if ((ored_msr & MSR__LO_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit LoLim. "); - iRet = MSRONLIMIT; - } - if ((ored_msr & MSR__STOPPED) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Stopped. "); - iRet = MSRSTOP; - } - } - }else if ((msr & ~(0x2fff)) != 0) { - StrJoin (text, text_len, "Status, MSR = ??", ""); - }else { - sprintf (my_text, "%#x ", msr); - StrJoin (text, text_len, "Status, MSR = ", my_text); - if ((msr & MSR__LIM_ERR) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Limit Switch Problem/"); - iRet = MSRONLIMIT; - } - if ((msr & MSR__AC_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Air-Cushion Error/"); - iRet = MSRDEADCUSHION; - } - if ((msr & MSR__REF_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n Fail/"); - } - if ((msr & MSR__POS_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Pos'n Fail/"); - iRet = MSRPOSFAULT; - } - if ((msr & MSR__POS_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Pos'n Fault/"); - } - if ((msr & MSR__RUN_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Run Fail/"); - iRet = MSRRUNFAULT; - } - if ((msr & MSR__RUN_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Run Fault/"); - } - if ((msr & MSR__HALT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Halt/"); - iRet = MSRHALT; - } - if ((msr & MSR__HI_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit HiLim/"); - iRet = MSRONLIMIT; - } - if ((msr & MSR__LO_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit LoLim/"); - iRet = MSRONLIMIT; - } - if ((msr & MSR__STOPPED) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Stopped/"); - iRet = MSRSTOP; - } - if ((msr & MSR__REF_OK) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n OK/"); - } - if ((msr & MSR__OK) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "OK/"); - } - if ((msr & MSR__BUSY) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Busy/"); - } - len = strlen (text); - text[len-1] = '\0'; - } - return iRet; - } -/*-------------------------------------------------------------------------*/ - static int EL734AnalyzeMSR(int msr,int ored_msr) - { - int iRet = 0; - - /* this means the motor is done */ - if (msr == 0) { - ored_msr = ored_msr & ~(MSR__BUSY); /* Zero "Busy" bit */ - if (ored_msr == MSR__OK) { - iRet = MSROK; - }else { - if ((ored_msr & MSR__OK) != 0) { - iRet = MSROK; - }else { - iRet = MSROK; - } - if ((ored_msr & MSR__REF_OK) != 0) { - iRet = MSROK; - } - if ((ored_msr & MSR__LIM_ERR) != 0) { - return MSRONLIMIT; - } - if ((ored_msr & MSR__AC_FAIL) != 0) { - return MSRDEADCUSHION; - } - if ((ored_msr & MSR__REF_FAIL) != 0) { - iRet = MSRREF; - } - if ((ored_msr & MSR__POS_FAIL) != 0) { - return MSRPOSFAULT; - } - if ((ored_msr & MSR__POS_FAULT) != 0) { - iRet = MSRFAULT; - } - if ((ored_msr & MSR__RUN_FAIL) != 0) { - return MSRRUNFAULT; - } - if ((ored_msr & MSR__RUN_FAULT) != 0) { - iRet = MSRFAULT; - } - if ((ored_msr & MSR__HALT) != 0) { - return MSRHALT; - } - if ((ored_msr & MSR__HI_LIM) != 0) { - return MSRONLIMIT; - } - if ((ored_msr & MSR__LO_LIM) != 0) { - return MSRONLIMIT; - } - if ((ored_msr & MSR__STOPPED) != 0) { - return MSRSTOP; - } - } - /* the motor is still fighting along */ - }else if ((msr & ~(0x2fff)) != 0) { - iRet = MSROK; - }else { - if ((msr & MSR__LIM_ERR) != 0) { - return MSRONLIMIT; - } - if ((msr & MSR__AC_FAIL) != 0) { - return MSRDEADCUSHION; - } - if ((msr & MSR__REF_FAIL) != 0) { - iRet = MSRREF; - } - if ((msr & MSR__POS_FAIL) != 0) { - return MSRPOSFAULT; - } - if ((msr & MSR__POS_FAULT) != 0) { - iRet = MSRFAULT; - } - if ((msr & MSR__RUN_FAIL) != 0) { - return MSRRUNFAULT; - } - if ((msr & MSR__RUN_FAULT) != 0) { - iRet = MSRFAULT; - } - if ((msr & MSR__HALT) != 0) { - return MSRHALT; - } - if ((msr & MSR__HI_LIM) != 0) { - return MSRONLIMIT; - } - if ((msr & MSR__LO_LIM) != 0) { - return MSRONLIMIT; - } - if ((msr & MSR__STOPPED) != 0) { - return MSRSTOP; - } - if ((msr & MSR__REF_OK) != 0) { - iRet = MSROK; - } - if ((msr & MSR__OK) != 0) { - iRet = MSROK; - } - if ((msr & MSR__BUSY) != 0) { - iRet = MSRBUSY; - } - } - return iRet; - } - - diff --git a/el755driv.c b/el755driv.c deleted file mode 100644 index fa54f040..00000000 --- a/el755driv.c +++ /dev/null @@ -1,318 +0,0 @@ -/*-------------------------------------------------------------------------- - E L 7 5 5 D R I V - - This file contains the implementation for the EL755 magnet controller - driver. - - Mark Koennecke, November 1999 - - Copyright: see copyright.h -----------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include -#include "fortify.h" -#include "conman.h" -#include "servlog.h" -#include "fortify.h" - - typedef struct __EVDriver *pEVDriver; - -#include "evdriver.i" -#include "hardsup/el755_def.h" -#include "hardsup/el755_errcodes.h" -#include "hardsup/sinq_prototypes.h" - -/*-----------------------------------------------------------------------*/ - typedef struct { - void *pData; - char *pHost; - int iPort; - int iChannel; - int iIndex; - int iLastError; - } EL755Driv, *pEL755Driv; - -/*---------------------------------------------------------------------------*/ - static int GetEL755Pos(pEVDriver self, float *fPos) - { - pEL755Driv pMe = NULL; - int iRet; - float fSoll; - - assert(self); - pMe = (pEL755Driv)self->pPrivate; - assert(pMe); - - iRet = EL755_GetCurrents(&(pMe->pData),&fSoll,fPos); - if(iRet != 1) - { - return 0; - } - return 1; - } -/*----------------------------------------------------------------------------*/ - static int EL755Run(pEVDriver self, float fVal) - { - pEL755Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pEL755Driv )self->pPrivate; - assert(pMe); - - iRet = EL755_SetCurrent(&(pMe->pData),fVal); - if(iRet != 1) - { - return 0; - } - return 1; - } -/*--------------------------------------------------------------------------*/ - static int EL755Error(pEVDriver self, int *iCode, char *error, int iErrLen) - { - pEL755Driv pMe = NULL; - char *pPtr = NULL; - int i1, i2; - char pBueffel[132]; - - assert(self); - pMe = (pEL755Driv)self->pPrivate; - assert(pMe); - - /* retrieve error */ - EL755_ErrInfo(&pPtr,iCode,&i1,&i2); - switch(*iCode) - { - case EL755__TURNED_OFF: - strncpy(error,"EL755__TURNED_OF",iErrLen); - break; - case EL755__TOO_MANY: - strncpy(error,"EL755__TO_MANY",iErrLen); - break; - case EL755__TOO_LARGE: - strncpy(error,"EL755__TOO_LARGE",iErrLen); - break; - case EL755__OVFLOW: - strncpy(error,"EL755_OVFLOW",iErrLen); - break; - case EL755__OUT_OF_RANGE: - strncpy(error,"EL755_OUT_OF_RANGE",iErrLen); - break; - case EL755__OFFLINE: - strncpy(error,"EL755_OFFLINE",iErrLen); - break; - case EL755__NO_SOCKET: - strncpy(error,"EL755__NO_SOCKET",iErrLen); - break; - case EL755__NOT_OPEN: - strncpy(error,"EL755__NOT_OPEN",iErrLen); - break; - case EL755__FORCED_CLOSED: - strncpy(error,"EL755__FORCED_CLOSED",iErrLen); - break; - case EL755__BAD_TMO: - strncpy(error,"EL755__BAD_TMO",iErrLen); - break; - case EL755__BAD_SOCKET: - strncpy(error,"EL755__BAD_SOCKET",iErrLen); - break; - case EL755__BAD_PAR: - strncpy(error,"EL755__BAD_PAR",iErrLen); - break; - case EL755__BAD_OFL: - strncpy(error,"EL755__BAD_OFL",iErrLen); - break; - case EL755__BAD_MALLOC: - strncpy(error,"EL755__BAD_MALLOC",iErrLen); - break; - case EL755__BAD_ILLG: - strncpy(error,"EL755__BAD_ILLG",iErrLen); - break; - case EL755__BAD_DEV: - strncpy(error,"EL755__BAD_DEV",iErrLen); - break; - case EL755__BAD_CMD: - strncpy(error,"EL755__BAD_CMD",iErrLen); - break; - case EL755__BAD_ASYNSRV: - strncpy(error,"EL755__BAD_ASYNSRV",iErrLen); - break; - default: - sprintf(pBueffel,"Unknown error %d found",*iCode); - strncpy(error,pBueffel,iErrLen); - break; - } - - return 1; - } -/*-----------------------------------------------------------------------*/ - int EL755_Send(void **handle, char *pCom, char *reply, int iLen); - /* - * added to el755_utility by M.K. - */ -/*--------------------------------------------------------------------------*/ - static int EL755Send(pEVDriver self, char *pCommand, char *pReply, int iLen) - { - pEL755Driv pMe = NULL; - char *pPtr = NULL; - char pBueffel[132]; - int iRet; - - assert(self); - pMe = (pEL755Driv)self->pPrivate; - assert(pMe); - - if(strlen(pCommand) > 130) - return 0; - - /* make sure that we have a \r at the end */ - strcpy(pBueffel,pCommand); - if(strrchr(pBueffel,(int)'\r') == NULL) - { - strcat(pBueffel,"\r"); - } - - return EL755_Send(&(pMe->pData),pBueffel,pReply,iLen); - } -/*--------------------------------------------------------------------------*/ - static int EL755Init(pEVDriver self) - { - pEL755Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pEL755Driv )self->pPrivate; - assert(pMe); - - pMe->pData = NULL; - iRet = EL755_Open(&(pMe->pData),pMe->pHost,pMe->iPort,pMe->iChannel, - pMe->iIndex); - return iRet; - } -/*--------------------------------------------------------------------------*/ - static int EL755Close(pEVDriver self) - { - pEL755Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pEL755Driv )self->pPrivate; - assert(pMe); - - EL755_Close(&(pMe->pData),0); - return 1; - } -/*---------------------------------------------------------------------------*/ - static int EL755Fix(pEVDriver self, int iError) - { - pEL755Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pEL755Driv )self->pPrivate; - assert(pMe); - - switch(iError) - { - case EL755__TURNED_OFF: - case EL755__TOO_MANY: - case EL755__TOO_LARGE: - case EL755__OUT_OF_RANGE: - case EL755__BAD_PAR: - case EL755__BAD_SOCKET: - case EL755__BAD_MALLOC: - case EL755__BAD_DEV: - case EL755__BAD_CMD: - case EL755__BAD_ASYNSRV: - return DEVFAULT; - break; - case EL755__OVFLOW: - case EL755__BAD_TMO: - case EL755__BAD_ILLG: - return DEVREDO; - break; - case EL755__OFFLINE: - case EL755__BAD_OFL: - EL755_PutOnline(&(pMe->pData),2); - return DEVREDO; - break; - case EL755__NO_SOCKET: - case EL755__NOT_OPEN: - case EL755__FORCED_CLOSED: - EL755_Open(&(pMe->pData),pMe->pHost,pMe->iPort, - pMe->iChannel,pMe->iIndex); - return DEVREDO; - break; - default: - return DEVFAULT; - break; - } - - } - -/*--------------------------------------------------------------------------*/ - static int EL755Halt(pEVDriver *self) - { - assert(self); - - return 1; - } -/*------------------------------------------------------------------------*/ - void KillEL755(void *pData) - { - pEL755Driv pMe = NULL; - - pMe = (pEL755Driv)pData; - assert(pMe); - - if(pMe->pHost) - { - free(pMe->pHost); - } - free(pMe); - } -/*------------------------------------------------------------------------*/ - pEVDriver CreateEL755Driv(int argc, char *argv[]) - { - pEVDriver pNew = NULL; - pEL755Driv pSim = NULL; - - /* check for arguments */ - if(argc < 4) - { - return NULL; - } - - pNew = CreateEVDriver(argc,argv); - pSim = (pEL755Driv)malloc(sizeof(EL755Driv)); - memset(pSim,0,sizeof(EL755Driv)); - if(!pNew || !pSim) - { - return NULL; - } - pNew->pPrivate = pSim; - pNew->KillPrivate = KillEL755; - - pSim->iLastError = 0; - pSim->pHost = strdup(argv[0]); - pSim->iPort = atoi(argv[1]); - pSim->iChannel = atoi(argv[2]); - pSim->iIndex = atoi(argv[3]); - - /* initialise function pointers */ - pNew->SetValue = EL755Run; - pNew->GetValue = GetEL755Pos; - pNew->Send = EL755Send; - pNew->GetError = EL755Error; - pNew->TryFixIt = EL755Fix; - pNew->Init = EL755Init; - pNew->Close = EL755Close; - - return pNew; - } - - - diff --git a/el755driv.h b/el755driv.h deleted file mode 100644 index 22ec7471..00000000 --- a/el755driv.h +++ /dev/null @@ -1,15 +0,0 @@ -/*------------------------------------------------------------------------ - E L 7 5 5 D R I V - - A environment control driver for the EL755 magnet - controller. - - Mark Koennecke, November 1999 - - copyright: see copyright.h ----------------------------------------------------------------------------*/ -#ifndef EL755DRIV -#define EL755DRIV - pEVDriver CreateEL755Driv(int argc, char *argv[]); - -#endif diff --git a/eurodriv.c b/eurodriv.c index c0f34181..270dbb55 100644 --- a/eurodriv.c +++ b/eurodriv.c @@ -25,9 +25,9 @@ typedef struct __EVDriver *pEVDriver; #include "evdriver.i" -#include "hardsup/el734_def.h" -#include "hardsup/el734fix.h" -#include "hardsup/serialsinq.h" +#include "psi/hardsup/el734_def.h" +#include "psi/hardsup/el734fix.h" +#include "psi/hardsup/serialsinq.h" #include "eurodriv.h" #define INVALIDANSWER -1005 diff --git a/evcontroller.c b/evcontroller.c index 584f3a3b..e3b3714d 100644 --- a/evcontroller.c +++ b/evcontroller.c @@ -54,23 +54,10 @@ #include "evcontroller.i" #include "evdriver.i" #include "simev.h" -#include "itc4.h" -#include "dilludriv.h" #include "tclev.h" -#include "bruker.h" -#include "ltc11.h" -#include "eurodriv.h" -#include "el755driv.h" -#include "A1931.h" -#include "tecsdriv.h" #include "chadapter.h" #include "status.h" - -/* - from slsmagnet.c -*/ -extern pEVDriver CreateSLSDriv(int argc, char *argv[]); - +#include "site.h" /*--------------------- Functions needed to implement interfaces -----------*/ static long EVIDrive(void *pData, SConnection *pCon, float fVal) { @@ -1173,6 +1160,7 @@ extern pEVDriver CreateSLSDriv(int argc, char *argv[]); char pBueffel[512],pError[132]; int iRet; CommandList *pCom = NULL; + pSite site = NULL; assert(pSics); assert(pCon); @@ -1229,7 +1217,8 @@ extern pEVDriver CreateSLSDriv(int argc, char *argv[]); pCom = FindCommand(pSics,argv[2]); if(pCom) { - sprintf(pBueffel,"ERROR: environment device %s already installed, delete first", + sprintf(pBueffel, + "ERROR: environment device %s already installed, delete first", argv[2]); SCWrite(pCon,pBueffel,eError); return 0; @@ -1241,216 +1230,11 @@ extern pEVDriver CreateSLSDriv(int argc, char *argv[]); pDriv = CreateSIMEVDriver(argc-4,&argv[4]); if(!pDriv) { - SCWrite(pCon,"ERROR: failed to create Environment Device driver",eError); - return 0; - } - - } - else if(strcmp(argv[3],"tecs") == 0) /* TECS temperature server */ - { - /* Create a driver */ - pDriv = CreateTecsDriver(argc-4,&argv[4]); - if(!pDriv) - { - SCWrite(pCon,"ERROR: failed to create TECS device driver",eError); - return 0; - } - /* got a driver, initialise everything */ - pNew = CreateEVController(pDriv,argv[2],&iRet); - if(!pNew) - { - SCWrite(pCon,"ERROR: failed to initialize Tecs",eError); - SCWrite(pCon,"ERROR creating Environment Controller",eError); - return 0; - } - if(!iRet) - { - SCWrite(pCon,"ERROR: problem initialising Environment controller", - eError); - pDriv->GetError(pDriv,&iRet,pError,131); - sprintf(pBueffel,"HW reported: %s",pError); - SCWrite(pCon,pBueffel,eError); - } - /* set a few parameters */ - EVCSetPar(pNew,"upperlimit",300.0,pCon); - EVCSetPar(pNew,"lowerlimit",1.0,pCon); - /* install command */ - iRet = AddCommand(pSics,argv[2],TecsWrapper,DeleteEVController, - pNew); - if(!iRet) - { - sprintf(pBueffel,"ERROR: duplicate command %s not created",argv[2]); - DeleteEVController((void *)pNew); - SCWrite(pCon,pBueffel,eError); - return 0; - } - EVRegisterController(FindEMON(pSics),argv[2],pNew, pCon); - SCSendOK(pCon); - return 1; - } - else if(strcmp(argv[3],"itc4") == 0) /* ITC4 driver */ - { - /* Create a driver */ - pDriv = CreateITC4Driver(argc-4,&argv[4]); - if(!pDriv) - { - SCWrite(pCon,"ERROR: failed to create ITC4 device driver",eError); - return 0; - } - /* got a driver, initialise everything */ - pNew = CreateEVController(pDriv,argv[2],&iRet); - if(!pNew) - { - SCWrite(pCon,"ERROR creating Environment Controller",eError); - return 0; - } - if(!iRet) - { - SCWrite(pCon,"ERROR: problem initialising Environment controller", - eError); - pDriv->GetError(pDriv,&iRet,pError,131); - sprintf(pBueffel,"HW reported: %s",pError); - SCWrite(pCon,pBueffel,eError); - } - /* set a few parameters */ - EVCSetPar(pNew,"upperlimit",300.0,pCon); - EVCSetPar(pNew,"lowerlimit",1.0,pCon); - /* install command */ - iRet = AddCommand(pSics,argv[2],ITC4Wrapper,DeleteEVController, - pNew); - if(!iRet) - { - sprintf(pBueffel,"ERROR: duplicate command %s not created",argv[2]); - DeleteEVController((void *)pNew); - SCWrite(pCon,pBueffel,eError); - return 0; - } - EVRegisterController(FindEMON(pSics),argv[2],pNew, pCon); - SCSendOK(pCon); - return 1; - } - else if(strcmp(argv[3],"bruker") == 0) /* Bruker Magnet Controller driver */ - { - /* Create a driver */ - pDriv = CreateBrukerDriver(argc-4,&argv[4]); - if(!pDriv) - { - SCWrite(pCon,"ERROR: failed to create Bruker Controller device driver",eError); - return 0; - } - /* got a driver, initialise everything */ - pNew = CreateEVController(pDriv,argv[2],&iRet); - if(!pNew) - { - SCWrite(pCon,"ERROR creating Environment Controller",eError); - return 0; - } - if(!iRet) - { - SCWrite(pCon,"ERROR: problem initialising Environment controller", - eError); - pDriv->GetError(pDriv,&iRet,pError,131); - sprintf(pBueffel,"HW reported: %s",pError); - SCWrite(pCon,pBueffel,eError); - } - - /* set a few parameters */ - EVCSetPar(pNew,"upperlimit",45.0,pCon); - EVCSetPar(pNew,"lowerlimit",0.0,pCon); - /* install command */ - iRet = AddCommand(pSics,argv[2],BrukerAction,DeleteEVController, - pNew); - if(!iRet) - { - sprintf(pBueffel,"ERROR: duplicate command %s not created",argv[2]); - DeleteEVController((void *)pNew); - SCWrite(pCon,pBueffel,eError); - return 0; - } - EVRegisterController(FindEMON(pSics),argv[2],pNew, pCon); - SCSendOK(pCon); - return 1; - } - else if(strcmp(argv[3],"ltc11") == 0) - /* Neocera LTC-11 temperature controller*/ - { - /* Create a driver */ - pDriv = CreateLTC11Driver(argc-4,&argv[4]); - if(!pDriv) - { - SCWrite(pCon,"ERROR: failed to create LTC-11 device driver",eError); - return 0; - } - /* got a driver, initialise everything */ - pNew = CreateEVController(pDriv,argv[2],&iRet); - if(!pNew) - { - SCWrite(pCon,"ERROR creating Environment Controller",eError); - return 0; - } - if(!iRet) - { - SCWrite(pCon,"ERROR: problem initialising Environment controller", - eError); - pDriv->GetError(pDriv,&iRet,pError,131); - sprintf(pBueffel,"HW reported: %s",pError); - SCWrite(pCon,pBueffel,eError); - } - /* set a few parameters */ - EVCSetPar(pNew,"upperlimit",500.,pCon); - EVCSetPar(pNew,"lowerlimit",1.5,pCon); - /* install command */ - iRet = AddCommand(pSics,argv[2],LTC11Action,DeleteEVController, - pNew); - if(!iRet) - { - sprintf(pBueffel,"ERROR: duplicate command %s not created",argv[2]); - DeleteEVController((void *)pNew); - SCWrite(pCon,pBueffel,eError); - return 0; - } - EVRegisterController(FindEMON(pSics),argv[2],pNew, pCon); - SCSendOK(pCon); - return 1; - }else if(strcmp(argv[3],"a1931") == 0) - /* Risoe A1931 temperature controller*/ - { - /* Create a driver */ - pDriv = CreateA1931Driver(argc-4,&argv[4]); - if(!pDriv) - { - SCWrite(pCon,"ERROR: failed to create A1931 device driver", + SCWrite(pCon, + "ERROR: failed to create Environment Device driver", eError); return 0; } - /* got a driver, initialise everything */ - pNew = CreateEVController(pDriv,argv[2],&iRet); - if(!pNew) - { - SCWrite(pCon,"ERROR creating Environment Controller",eError); - return 0; - } - if(!iRet) - { - SCWrite(pCon,"ERROR: problem initialising Environment controller", - eError); - pDriv->GetError(pDriv,&iRet,pError,131); - sprintf(pBueffel,"HW reported: %s",pError); - SCWrite(pCon,pBueffel,eError); - } - /* install command */ - iRet = AddCommand(pSics,argv[2],A1931Action,DeleteEVController, - pNew); - if(!iRet) - { - sprintf(pBueffel,"ERROR: duplicate command %s not created",argv[2]); - DeleteEVController((void *)pNew); - SCWrite(pCon,pBueffel,eError); - return 0; - } - EVRegisterController(FindEMON(pSics),argv[2],pNew, pCon); - SCSendOK(pCon); - return 1; } else if(strcmp(argv[3],"tcl") == 0) /* Tcl driver */ { @@ -1478,11 +1262,13 @@ extern pEVDriver CreateSLSDriv(int argc, char *argv[]); SCWrite(pCon,pBueffel,eError); } /* install command */ - iRet = AddCommand(pSics,argv[2],TclEnvironmentWrapper,DeleteEVController, + iRet = AddCommand(pSics,argv[2],TclEnvironmentWrapper, + DeleteEVController, pNew); if(!iRet) { - sprintf(pBueffel,"ERROR: duplicate command %s not created",argv[2]); + sprintf(pBueffel,"ERROR: duplicate command %s not created", + argv[2]); DeleteEVController((void *)pNew); SCWrite(pCon,pBueffel,eError); return 0; @@ -1495,22 +1281,6 @@ extern pEVDriver CreateSLSDriv(int argc, char *argv[]); ObVal(pNew->pParam,UPLIMIT)); UpdateTclVariable(pNew->pDriv,"lowerlimit", ObVal(pNew->pParam,LOWLIMIT)); - - /* register controller for monitoring */ - EVRegisterController(FindEMON(pSics),argv[2],pNew, pCon); - SCSendOK(pCon); - return 1; - } - else if(strcmp(argv[3],"dillu") == 0) /* dillution driver */ - { - /* Create a driver */ - pDriv = CreateDILLUDriv(argc-4,&argv[4]); - if(!pDriv) - { - SCWrite(pCon, - "ERROR: failed to create Dillution device driver",eError); - return 0; - } } else if(strcmp(argv[3],"gencon") == 0) /* general controller */ { @@ -1524,87 +1294,20 @@ extern pEVDriver CreateSLSDriv(int argc, char *argv[]); return 0; } } - else if(strcmp(argv[3],"euro") == 0) /* dillution driver */ - { - /* Create a driver */ - pDriv = CreateEURODriv(argc-4,&argv[4]); - if(!pDriv) - { - SCWrite(pCon, - "ERROR: failed to create Eurotherm device driver",eError); - return 0; - } - } - else if(strcmp(argv[3],"psi-dsp") == 0) /* PSI-DSP magnet driver */ - { - /* Create a driver */ - pDriv = CreateSLSDriv(argc-4,&argv[4]); - if(!pDriv) - { - SCWrite(pCon, - "ERROR: failed to create PSI-DSP device driver",eError); - return 0; - } - } - else if(strcmp(argv[3],"el755") == 0) /* EL755 magnet driver */ - { - /* Create a driver */ - pDriv = CreateEL755Driv(argc-4,&argv[4]); - if(!pDriv) - { - SCWrite(pCon, - "ERROR: failed to create EL755 device driver",eError); - return 0; - } - } else { - sprintf(pBueffel,"ERROR: %s not recognized as a valid driver type", - argv[3]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - /* got a driver, initialise everything */ - pNew = CreateEVController(pDriv,argv[2],&iRet); - if(!pNew) - { - SCWrite(pCon,"ERROR creating Environment Controller",eError); - return 0; - } - if(!iRet) - { - SCWrite(pCon,"ERROR: problem initialising Environment controller", - eError); - pDriv->GetError(pDriv,&iRet,pError,131); - sprintf(pBueffel,"HW reported: %s",pError); - SCWrite(pCon,pBueffel,eError); - } - - /* set a few parameters */ - if(strcmp(argv[3],"euro") == 0) - { - EVCSetPar(pNew,"upperlimit",750.0,pCon); - EVCSetPar(pNew,"lowerlimit",15.0,pCon); - } - else if(strcmp(argv[3],"el755") == 0) - { - EVCSetPar(pNew,"upperlimit",10.,pCon); - EVCSetPar(pNew,"lowerlimit",-10.,pCon); - } - else - { - EVCSetPar(pNew,"upperlimit",4.0,pCon); - EVCSetPar(pNew,"lowerlimit",0.05,pCon); - } - /* install command */ - iRet = AddCommand(pSics,argv[2],EVControlWrapper,DeleteEVController, - pNew); - if(!iRet) - { - sprintf(pBueffel,"ERROR: duplicate command %s not created",argv[2]); - DeleteEVController((void *)pNew); - SCWrite(pCon,pBueffel,eError); - return 0; + site = getSite(); + if(site != NULL){ + pNew = site->InstallEnvironmentController(pSics,pCon,argc,argv); + } else { + pNew = NULL; + } + if(pNew == NULL){ + sprintf(pBueffel,"ERROR: %s not recognized as a valid driver type", + argv[3]); + SCWrite(pCon,pBueffel,eError); + return 0; + } } EVRegisterController(FindEMON(pSics),argv[2],pNew, pCon); SCSendOK(pCon); diff --git a/faverage.c b/faverage.c deleted file mode 100644 index 5cb03a39..00000000 --- a/faverage.c +++ /dev/null @@ -1,557 +0,0 @@ -/*--------------------------------------------------------------------------- - F o c u s A v e r a g e r - - A little averager for FOCUS data. Used by the FOCUS status display. - - copyright: see copyright.h - - Mark Koennecke, October 1998 - - Updated for additional detector banks - - Mark Koennecke, March 2000 - - Added focusraw command for retrieving single detector banks in support - of the colour mapping part of the FOCUS status display. - - Mark Koennecke, July 2001 ----------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include "fortify.h" -#include "sics.h" -#include "sicsvar.h" -#include "counter.h" -#include "HistMem.h" -#include "fomerge.h" -#include "faverage.h" - -/* -#define DEB 1 -*/ -/*-------------------------------------------------------------------------*/ - typedef struct __FocusAverager { - pObjectDescriptor pDes; - pHistMem pHistogram1; - pHistMem pHistogram2; - pHistMem pHistogram3; - } FocusAverager, *pFocusAverager; - -/*------------------------------------------------------------------------*/ - - HistInt *CheckBank(pFocusAverager self, SConnection *pCon, - int iLength, int iBank); - - static void KillFA(void *pData) - { - pFocusAverager self = NULL; - - self = (pFocusAverager)pData; - if(!self) - return; - - if(self->pDes) - DeleteDescriptor(self->pDes); - free(self); - } -/*-------------------------------------------------------------------------*/ - int FocusAverageDo(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - pFocusAverager self = NULL; - int *iData = NULL; - const float *fTimeBin = NULL; - float fVal; - int iLength, iStart, iEnd, iNum, i,ii, iTest, iBufLen, iRet, iVal; - char pBueffel[256]; - HistInt *hiData = NULL, *hiPtr; - time_t tStart, tEnd; - int iBank = MIDDLE; - pSicsVariable var1 = NULL; - pSicsVariable var2 = NULL; - pSicsVariable var3 = NULL; - int lbank, mbank, ubank; - - self = (pFocusAverager)pData; - assert(self); - assert(pCon); - assert(pSics); - - /* we need two parameters: start and end of averaging */ - if(argc < 3) - { - SCWrite(pCon, - "ERROR: insufficient number of parameters for FocusAverage", - eError); - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[1],&iStart); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert %d to integer",argv[1]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[2],&iEnd); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert %d to integer",argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - - /* another parameter, if available describes the detector bank - */ - if(argc > 3) - { - iRet = Tcl_GetInt(pSics->pTcl,argv[3],&iBank); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert %d to integer",argv[3]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - } - - /* how much to do: correct parameters? */ - iNum = iEnd - iStart; - if(iNum < 0) - { - SCWrite(pCon,"ERROR: invalid parameters given to FocusAverage", - eError); - return 0; - } - /* may be only one histogram requested */ - if(iNum == 0) - iNum = 1; - if(iStart < 0) - { - SCWrite(pCon,"ERROR: invalid parameters given to FocusAverage", - eError); - return 0; - } - -#ifdef DEB - printf("Starting averaging ...\n"); - fflush(stdout); - tStart = time(NULL); -#endif - - /* do work! first retrieve time binning data */ - - var2 = FindVariable(pServ->pSics,"mbank"); - if(var2) - { - VarGetInt(var2,&mbank); - } else { - SCWrite(pCon,"ERROR: mbank value not found!",eError); - } - if(mbank==1) - { - fTimeBin = GetHistTimeBin(self->pHistogram2,&iLength); - } - else - { - var1 = FindVariable(pServ->pSics,"lbank"); - if(var1) - { - VarGetInt(var1,&lbank); - } else { - SCWrite(pCon,"ERROR: lbank value not found!",eError); - } - if(lbank==1) - { - fTimeBin = GetHistTimeBin(self->pHistogram1,&iLength); - } - else - { - fTimeBin = GetHistTimeBin(self->pHistogram3,&iLength); - } - } - assert(fTimeBin); - if(iLength <= 0) - { - SCWrite(pCon,"ERROR: histogram memory inproperly configured",eError); - return 0; - } - /* allocate result data */ - iBufLen = (iLength *2 +1)*sizeof(int); - iData = (int *)malloc(iBufLen); - memset(iData,0,iBufLen); - - /* get histogram length */ - i = getFMdim(iBank); - /* correct iEnd to maximum allowed */ - iTest = i; - if(iEnd > iTest -1) - { - iEnd = iTest - 1; - iNum = iEnd - iStart; - if(iNum <= 0) - iNum = 1; - } - -#ifdef DEB - printf("Getting histogram....\n"); - fflush(stdout); -#endif - - hiData = CheckBank(self,pCon,iLength,iBank); - -#ifdef DEB - tEnd = time(NULL); - printf("Histogram received in %d seconds\n", tStart - tEnd); - fflush(stdout); -#endif - - if(hiData == NULL) - { - SCWrite(pCon,"ERROR: BAD Configuration",eError); - free(iData); - return 0; - } - - /* first int: length of things to come */ - iData[0] = htonl(iLength); - /* sum up */ - for(i = iStart; i < iEnd; i++) - { - hiPtr = hiData + i*iLength; - for(ii = 0; ii < iLength; ii++) - { - iData[ii+1] += hiPtr[ii]; - } - } - /* average */ - for(i = 1; i < iLength + 1; i++) - { - fVal = (float)iData[i]/(float)iNum; - fVal *= 65536.; - iData[i] = htonl((int)fVal); - } - /* make time binning fixed point */ - for(i = 0; i < iLength; i++) - { - fVal = fTimeBin[i]/10.; - fVal *= 65536.; - iData[iLength+1+i] = htonl((int)fVal); - } -#ifdef DEB - printf("Sending averaged data....\n"); - fflush(stdout); -#endif - /* finally send out uuencoded */ - SCWriteUUencoded(pCon,"FocusAverage",iData,iBufLen); - if(iData) - free(iData); -#ifdef DEB - printf("Averaging finished\n"); - fflush(stdout); -#endif - return 1; - } - -/*-------------------------------------------------------------------------*/ - static int FocusRaw(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - pFocusAverager self = NULL; - int *iData = NULL; - int iLength, noTimebin, iRet, i; - char pBueffel[256]; - const float *timeBin; - HistInt *hiData = NULL, *hiPtr; - int iBank = MIDDLE; - pSicsVariable var1 = NULL; - pSicsVariable var2 = NULL; - pSicsVariable var3 = NULL; - int lbank, mbank, ubank; - - self = (pFocusAverager)pData; - assert(self); - assert(pCon); - assert(pSics); - - - /* we need one parameter, the bank to read */ - if(argc < 2) - { - SCWrite(pCon, - "ERROR: insufficient number of parameters for FocusRaw", - eError); - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[1],&iBank); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert %d to integer",argv[1]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - var2 = FindVariable(pServ->pSics,"mbank"); - if(var2) - { - VarGetInt(var2,&mbank); - } else { - SCWrite(pCon,"ERROR: mbank value not found!",eError); - } - if(var2) - { - timeBin = GetHistTimeBin(self->pHistogram2,&iLength); - } - else - { - var1 = FindVariable(pServ->pSics,"lbank"); - if(var1) - { - VarGetInt(var1,&lbank); - } else { - SCWrite(pCon,"ERROR: lbank value not found!",eError); - } - if(var1) - { - timeBin = GetHistTimeBin(self->pHistogram1,&iLength); - } - else - { - timeBin = GetHistTimeBin(self->pHistogram3,&iLength); - } - } - assert(timeBin); - hiData = CheckBank(self, pCon, iLength, iBank); - - /* get histogram length */ - iLength = getFMdim(iBank); - noTimebin = getFMdim(TIMEBIN); - /* write dimension info*/ - sprintf(pBueffel,"focusrawdim = %d = %d", iLength, noTimebin); - SCWrite(pCon,pBueffel,eValue); - - /* allocate space */ - iData = (int *)malloc((iLength*noTimebin+1)*sizeof(int)); - if(iData == NULL) - { - SCWrite(pCon,"ERROR: out of memory in FocusRaw",eError); - return 0; - } - memset(iData,0,noTimebin*iLength*sizeof(int)); - - /* first int: length of things to come */ - iData[0] = htonl(iLength*noTimebin); - /* network byte order for everything */ - for(i = 0; i < noTimebin*iLength; i++) - { - iData[i+1] = htonl(hiData[i]); - } - /* send away, zipped */ - SCWriteZipped(pCon,"focusraw",iData,(iLength*noTimebin+1)*sizeof(int)); - - free(iData); - return 1; - } -/*-------------------------------------------------------------------------*/ - int MakeFA(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - pFocusAverager pNew = NULL; - CommandList *pCom = NULL; - pDummy pDum = NULL; - char pBueffel[256]; - int iRet; - pSicsVariable var1 = NULL; - pSicsVariable var2 = NULL; - pSicsVariable var3 = NULL; - int lbank, mbank, ubank; - - assert(pCon); - assert(pSics); - - /* we need two parameters: the name for the averager and the histogram - memory - */ - if(argc < 3) - { - SCWrite(pCon,"ERROR: Insufficient number of parameters to MakeFA", - eError); - return 0; - } - - /* find histogram memory */ - pCom = FindCommand(pSics,argv[2]); - if(!pCom) - { - sprintf(pBueffel,"ERROR: histogram memory %s NOT found!", argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - pDum = (pDummy)pCom->pData; - if(!pDum) - { - sprintf(pBueffel,"ERROR: histogram memory %s INVALID!", argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - if(strcmp(pDum->pDescriptor->name,"HMcontrol") != 0) - { - sprintf(pBueffel,"ERROR: %s is NO histogram control object!", argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - - /* we got what we need: set things up */ - pNew = (pFocusAverager)malloc(sizeof(FocusAverager)); - if(!pNew) - { - SCWrite(pCon,"ERROR: out of memory in MakeFA",eError); - return 0; - } - memset(pNew,0,sizeof(FocusAverager)); - - pNew->pDes = CreateDescriptor("FocusAverager"); - if(!pNew->pDes) - { - SCWrite(pCon,"ERROR: out of memory in MakeFA",eError); - return 0; - } - var2 = FindVariable(pServ->pSics,"mbank"); - if(var2) - { - VarGetInt(var2,&mbank); - } else { - SCWrite(pCon,"ERROR: mbank value not found!",eError); - } - if(mbank==1) - { - pCom = FindCommand(pSics,"hm2"); - pDum = (pDummy)pCom->pData; - pNew->pHistogram2 = (pHistMem)pDum; - } - var1 = FindVariable(pServ->pSics,"lbank"); - if(var1) - { - VarGetInt(var1,&lbank); - } else { - SCWrite(pCon,"ERROR: lbank value not found!",eError); - } - if(lbank==1) - { - pCom = FindCommand(pSics,"hm1"); - pDum = (pDummy)pCom->pData; - pNew->pHistogram1 = (pHistMem)pDum; - } - var3 = FindVariable(pServ->pSics,"ubank"); - if(var3) - { - VarGetInt(var3,&ubank); - } else { - SCWrite(pCon,"ERROR: ubank value not found!",eError); - } - if(ubank==1) - { - pCom = FindCommand(pSics,"hm3"); - pDum = (pDummy)pCom->pData; - pNew->pHistogram3 = (pHistMem)pDum; - } - iRet = AddCommand(pSics,argv[1],FocusAverageDo, KillFA, pNew); - if(!iRet) - { - sprintf(pBueffel,"ERROR: duplicate command %s not created", argv[1]); - SCWrite(pCon,pBueffel,eError); - KillFA(pNew); - return 0; - } - iRet = AddCommand(pSics,"focusraw",FocusRaw, NULL, pNew); - if(!iRet) - { - sprintf(pBueffel,"ERROR: duplicate command focusraw not created"); - SCWrite(pCon,pBueffel,eError); - return 0; - } - return 1; - } - -HistInt *CheckBank(pFocusAverager self, SConnection *pCon, - int iLength, int iBank) -{ - - pSicsVariable var1 = NULL; - pSicsVariable var2 = NULL; - pSicsVariable var3 = NULL; - HistInt *lData = NULL; - HistInt *mData = NULL; - HistInt *uData = NULL; - HistInt *mergData = NULL; - int lbank, mbank, ubank; - - if (iBank==2) - { - var2 = FindVariable(pServ->pSics,"mbank"); - if(var2) - { - VarGetInt(var2,&mbank); - } else { - SCWrite(pCon,"ERROR: mbank value not found!",eError); - } - if(mbank==1) - { - mData = GetHistogramPointer(self->pHistogram2,pCon); - if(mData == NULL) - { - return NULL; - } - setFMDataPointer(mData, iLength,2); - mData = getFMBankPointer(2); - return mData; - } - } - if (iBank==3) - { - var1 = FindVariable(pServ->pSics,"lbank"); - if(var1) - { - VarGetInt(var1,&lbank); - } else { - SCWrite(pCon,"ERROR: lbank value not found!",eError); - } - if(lbank==1) - { - lData = GetHistogramPointer(self->pHistogram1,pCon); - if(lData == NULL) - { - return NULL; - } - setFMDataPointer(lData, iLength, 3); - lData = getFMBankPointer(3); - return lData; - } - } - if (iBank==1) - { - var3 = FindVariable(pServ->pSics,"ubank"); - if(var3) - { - VarGetInt(var3,&ubank); - } else { - SCWrite(pCon,"ERROR: ubank value not found!",eError); - } - if(ubank==1) - { - uData = GetHistogramPointer(self->pHistogram3,pCon); - if(uData == NULL) - { - return NULL; - } - setFMDataPointer(uData, iLength, 1); - uData = getFMBankPointer(1); - return uData; - } - } - if (iBank==4) - { - setFMDataPointer(mergData, iLength,4); - mergData = getFMBankPointer(4); - return mergData; - } -} diff --git a/faverage.h b/faverage.h deleted file mode 100644 index 220beb10..00000000 --- a/faverage.h +++ /dev/null @@ -1,21 +0,0 @@ - -/*----------------------------------------------------------------------- - F o c u s A v e r a g e - - An averager for FOCUS data. See faverage.tex for more details. - - Mark Koennecke, October 1998 - ---------------------------------------------------------------------------*/ -#ifndef FOCUSAVERAGE -#define FOCUSAVERAGE - - int MakeFA(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - - int FocusAverageDo(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - - -#endif - diff --git a/faverage.tex b/faverage.tex deleted file mode 100644 index b3372776..00000000 --- a/faverage.tex +++ /dev/null @@ -1,70 +0,0 @@ -\subsection{The FOCUS Averager} -This is a special object for the instrument FOCUS and its Status display -client. In the FOCUS status display the averaged data from a number of -detectors is displayed. Thus there is already a reduced form of data. The -actual raw data would be 150*1024*4 bytes of data and possibly more. Rather -then transporting all this data to the status display client at regular -intervalls it was choosen to implement this averaging process at the server -and only send the reduced form to the status display client. Which is two -arrays of floating point data 1024 items long. This little object implements this -averager. - -As all SICS objects this object has a little data structure: -\begin{verbatim} - typedef struct __FocusAverager { - pObjectDescriptor pDes; - pHistMem pHist; - } FocusAverager; -\end{verbatim} - -The two fields are the standard object descriptor and a pointer to the -histogram memory object holding the data. - -The interface is minimal: it consists just of the factory function for -installing this object into SICS and the actual function doing the -averaging in the interpreter. - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap1} -$\langle$faint {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ int MakeFA(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ -\mbox{}\verb@ int argc, char *argv[]);@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ int FocusAverageDo(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ -\mbox{}\verb@ int argc, char *argv[]);@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap2} -\verb@"faverage.h"@ {\footnotesize ? }$\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@/*-----------------------------------------------------------------------@\\ -\mbox{}\verb@ F o c u s A v e r a g e@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ An averager for FOCUS data. See faverage.tex for more details.@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ Mark Koennecke, October 1998@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@--------------------------------------------------------------------------*/@\\ -\mbox{}\verb@#ifndef FOCUSAVERAGE@\\ -\mbox{}\verb@#define FOCUSAVERAGE@\\ -\mbox{}\verb@@$\langle$faint {\footnotesize ?}$\rangle$\verb@@\\ -\mbox{}\verb@#endif@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-2ex} -\end{minipage}\\[4ex] -\end{flushleft} diff --git a/faverage.w b/faverage.w deleted file mode 100644 index 808f56d8..00000000 --- a/faverage.w +++ /dev/null @@ -1,50 +0,0 @@ -\subsection{The FOCUS Averager} -This is a special object for the instrument FOCUS and its Status display -client. In the FOCUS status display the averaged data from a number of -detectors is displayed. Thus there is already a reduced form of data. The -actual raw data would be 150*1024*4 bytes of data and possibly more. Rather -then transporting all this data to the status display client at regular -intervalls it was choosen to implement this averaging process at the server -and only send the reduced form to the status display client. Which is two -arrays of floating point data 1024 items long. This little object implements this -averager. - -As all SICS objects this object has a little data structure: -\begin{verbatim} - typedef struct __FocusAverager { - pObjectDescriptor pDes; - pHistMem pHist; - } FocusAverager; -\end{verbatim} - -The two fields are the standard object descriptor and a pointer to the -histogram memory object holding the data. - -The interface is minimal: it consists just of the factory function for -installing this object into SICS and the actual function doing the -averaging in the interpreter. - -@d faint @{ - int MakeFA(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - - int FocusAverageDo(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - -@} - -@o faverage.h @{ -/*----------------------------------------------------------------------- - F o c u s A v e r a g e - - An averager for FOCUS data. See faverage.tex for more details. - - Mark Koennecke, October 1998 - ---------------------------------------------------------------------------*/ -#ifndef FOCUSAVERAGE -#define FOCUSAVERAGE -@ -#endif -@} - diff --git a/fowrite.c b/fowrite.c deleted file mode 100644 index 14f9cba0..00000000 --- a/fowrite.c +++ /dev/null @@ -1,1195 +0,0 @@ -/*--------------------------------------------------------------------------- - F O W R I T E - - FOCUS data writing object. - - copyright: see copyright.h - - Mark Koennecke, November 1998 - - Added code for three detector banks. - - Mark Koennecke, March 2000 ------------------------------------------------------------------------------*/ -#include -#include -#include -#include -/* avoid irritating compiler warning M.Z.08.2001 */ -#undef VOID -#include "fortify.h" -#include "sics.h" -#include "event.h" -#include "counter.h" -#include "HistMem.h" -#include "nxdict.h" -#include "nxutil.h" -#include "motor.h" -#include "selector.h" -#include "fowrite.h" -#include "scan.h" -#include "sicsvar.h" -#include "fitcenter.h" -#include "hmcontrol.h" -#include "fomerge.h" - -/* histogram memory names */ -#define HM1 "hm1" -#define HM2 "hm2" -#define HM3 "hm3" - - -/* the name of the SICS chopper controller object */ -#define CHOPPERNAME "choco" - -/*--------- the internal data structure ------------------------------------*/ - typedef struct { - pObjectDescriptor pDes; - pHistMem pHistogram1, pHistogram2, pHistogram3; - int iNew; - time_t tUpdate; - int iInterval; - int iEnd; - SConnection *pCon; - pCounter pCount; - char *pFile; - char *pDictFile; - pFit pFitter; - float fElastic; - pICallBack pCall; - int iUpper, iMiddle, iLower; - /* detector availability flags */ - } FoWrite, *pFoWrite; -/* ------------------- forward declaration of task function --------------*/ - - static int FoTask(void *pData); - static void FoUpdate(pFoWrite self, SConnection *pCon); - - -/*------------------ The Countstart Callback Function ----------------------*/ - static int Countstartcallback(int iEvent, void *pEventData, void *pUser) - { - pFoWrite self = NULL; - - if(iEvent == COUNTSTART) - { - self = (pFoWrite)pUser; - assert(self); - self->iNew = 1; - self->iEnd = 0; - self->tUpdate = time(NULL); - self->pCon = (SConnection *)pEventData; - TaskRegister(pServ->pTasker,FoTask,NULL,NULL,self,1); - return 1; - } - return 1; - } -/*------------------ The Countend Callback Function ----------------------*/ - static int Countendcallback(int iEvent, void *pEventData, void *pUser) - { - pFoWrite self = NULL; - - if(iEvent == COUNTEND) - { - self = (pFoWrite)pUser; - assert(self); - self->tUpdate = time(NULL); - self->iEnd = 1; - /* - FoUpdate(self,self->pCon); - */ - return 1; - } - return 1; - } -/*-----------------------------------------------------------------------*/ - static void SNError(void *pData, char *text) - { - SConnection *pCon; - - assert(pData); - pCon = (SConnection *)pData; - SCWrite(pCon,text,eError); - } -/*------------------------------------------------------------------------*/ - static void WriteSelector(NXhandle pFile, NXdict pDict, SConnection *pCon) - { - pSicsSelector pSel = NULL; - char *pName = NULL; - CommandList *pCom = NULL; - pDummy pDum = NULL; - float fTh, fTTH, fB1, fB2; - int iRet; - - pCom = FindCommand(pServ->pSics,"mono"); - if(!pCom) - { - SCWrite(pCon,"ERROR: no monochromator found",eError); - return ; - } - pSel = (pSicsSelector)pCom->pData; - if(!pSel) - { - SCWrite(pCon,"ERROR: no monochromator found",eError); - return ; - } - pDum = (pDummy)pSel; - if(strcmp(pDum->pDescriptor->name,"CrystalSelector") != 0) - { - SCWrite(pCon,"ERROR: monochromator is invalid",eError); - return ; - } - - NXDputalias(pFile,pDict,"mname",MonoGetType(pSel)); - iRet = GetMonoPositions(pSel,pCon,&fTh, &fTTH, &fB1, &fB2); - if(!iRet) - { - SCWrite(pCon,"ERROR: Problem reading monochromator positions",eError); - SCWrite(pCon,"ERROR: monochromator data missing in file",eError); - return; - } - NXDputalias(pFile,pDict,"mtheta",&fTh); - NXDputalias(pFile,pDict,"mttheta",&fTTH); - SNXSPutDrivable(pServ->pSics,pCon, pFile,pDict,"lambda","mlambda"); - SNXSPutDrivable(pServ->pSics,pCon, pFile,pDict,"qi","menergy"); - } -/*----------------------------------------------------------------------*/ - static float CalculateElastic(pFoWrite self, SConnection *pCon) - { - pIDrivable pDriv; - pSicsVariable pVar; - CommandList *pCom = NULL; - float fLambda, fDist, fResult; - - pCom = FindCommand(pServ->pSics,"lambda"); - if(!pCom) - return 0.; - pDriv = GetDrivableInterface(pCom->pData); - if(!pDriv) - return 0.; - fLambda = pDriv->GetValue(pCom->pData,pCon); - pVar = FindVariable(pServ->pSics,"sampledist"); - if(!pVar) - return 0.; - fDist = pVar->fVal; - pVar = FindVariable(pServ->pSics,"detectordist"); - if(!pVar) - return 0.; - fDist += pVar->fVal; - fResult = 252.78*fLambda*(fDist/1000.); - return fResult; - } -/*------------------------------------------------------------------------- - FoStart writes all the fixed data items, creates a new file etc. - A complete file is obtained after FoStart plus a call to FoUpdate -*/ - static int FoStart(pFoWrite self, SConnection *pCon) - { - NXhandle pFile = NULL; - NXdict pDict = NULL; - pSicsVariable var1 = NULL; - pSicsVariable var2 = NULL; - int lbank, mbank; - int iStat, iLength, i; - char pBueffel[512]; - CounterMode eMode; - float fVal, *fArray; - const float *fTime; - float *fTime2 = NULL; - char pBuffer[50]; - - /* get a filename */ - if(self->pFile) - free(self->pFile); - - self->pFile = SNXMakeFileName(pServ->pSics,pCon); - if(!self->pFile) - { - SCWrite(pCon,"ERROR: Extra severe: failed to create data file name", - eError); - return 0; - } - - /* create a Nexus file */ - NXopen(self->pFile,NXACC_CREATE,&pFile); - if(!pFile) - { - SCWrite(pCon,"ERROR: cannot create data file ",eError); - return 0; - } - - /* tell Uwe User what we are doing */ - sprintf(pBueffel,"Writing %s ......",self->pFile); - SCWrite(pCon,pBueffel,eWarning); - - /* write globals */ - SNXSPutGlobals(pFile,self->pFile,"FOCUS",pCon); - - /* open nxdict and configure nxdict parameters */ - iStat = NXDinitfromfile(self->pDictFile,&pDict); - if(iStat != NX_OK) - { - sprintf(pBueffel,"ERROR: failed to open dictionary file %s", - self->pDictFile); - SCWrite(pCon,pBueffel,eError); - SCWrite(pCon,"ERROR: Aborting data file writing",eError); - SCWrite(pCon,"ERROR: This is a SERIOUS problem!",eError); - SCWrite(pCon,"ERROR: DATA NOT WRITTEN",eError); - NXclose(&pFile); - return 0; - } - - /* put permanent data */ - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"etitle","title"); - SNXFormatTime(pBueffel,511); - - /* entry & instrument stuff */ - NXDputalias(pFile,pDict,"estart",pBueffel); - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"iname","instrument"); - NXDputalias(pFile,pDict,"sname","SINQ, PSI, Switzerland"); - NXDputalias(pFile,pDict,"stype","continous spallation source"); - - /* disk chopper */ - NXDputalias(pFile,pDict,"cname","Dornier disk chopper"); - - /* be-filter */ - NXDputalias(pFile,pDict,"bname","BE-filter"); - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"bstatus","bestatus"); - - /* flight path */ - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"fltype","flightpath"); - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"fllength","flightpathlength"); - - /* monochromator */ - WriteSelector(pFile,pDict,pCon); - - /* fermi chupper */ - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"fcname","ferminame"); - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"fcdist","fermidist"); - - /* counting data */ - - var2 = FindVariable(pServ->pSics,"mbank"); - if(var2) - { - VarGetInt(var2,&mbank); - } else { - SCWrite(pCon,"ERROR: mbank value not found!",eError); - } - if(var2) - { - eMode = GetHistCountMode(self->pHistogram2); - fTime = GetHistTimeBin(self->pHistogram2,&iLength); - fVal = GetHistPreset(self->pHistogram2); - } - else - { - var1 = FindVariable(pServ->pSics,"lbank"); - if(var1) - { - VarGetInt(var1,&lbank); - } else { - SCWrite(pCon,"ERROR: lbank value not found!",eError); - } - if(var1) - { - eMode = GetHistCountMode(self->pHistogram1); - fTime = GetHistTimeBin(self->pHistogram1,&iLength); - fVal = GetHistPreset(self->pHistogram1); - } - else - { - eMode = GetHistCountMode(self->pHistogram3); - fTime = GetHistTimeBin(self->pHistogram3,&iLength); - fVal = GetHistPreset(self->pHistogram3); - } - } - - if(eMode == eTimer) - { - strcpy(pBueffel,"timer"); - } - else - { - strcpy(pBueffel,"monitor"); - } - NXDputalias(pFile,pDict,"cnmode",pBueffel); - NXDputalias(pFile,pDict,"cnpreset",&fVal); - - /* detector banks */ - fTime2 = (float *)malloc(iLength*sizeof(float)); - if(fTime2) - { - for(i = 0; i < iLength; i++) - { - fTime2[i] = fTime[i]/10.; - } - sprintf(pBueffel,"%d",iLength); - NXDupdate(pDict,"timebin",pBueffel); - if(self->iMiddle) - { - NXDupdate(pDict,"bank","bank1"); - NXDputalias(pFile,pDict,"dtime",fTime2); - } - if(self->iUpper) - { - NXDupdate(pDict,"bank","upperbank"); - NXDputalias(pFile,pDict,"dtime",fTime2); - } - if(self->iLower) - { - NXDupdate(pDict,"bank","lowerbank"); - NXDputalias(pFile,pDict,"dtime",fTime2); - } - if( (self->iLower || self->iUpper) && self->iMiddle) - { - NXDupdate(pDict,"bank","merged"); - NXDputalias(pFile,pDict,"dtime",fTime2); - } - NXDupdate(pDict,"bank","bank1"); - - - /* calculate theoretical position of elastic peak */ - fVal = CalculateElastic(self,pCon); - self->fElastic = (fVal - fTime2[0]) / (fTime2[1] - fTime2[0]); - free(fTime2); - fTime2 = NULL; - } - else - { - SCWrite(pCon,"ERROR: out of memory while writing time binning", - eError); - } - - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"ddist","detectordist"); - - /* theta arrays */ - if(self->iMiddle) - { - NXDupdate(pDict,"bank","bank1"); - iLength = 150; - sprintf(pBuffer,"%d",iLength); - NXDupdate(pDict,"noofdetectors",pBuffer); - fArray = getFMBankTheta(MIDDLE); - NXDputalias(pFile,pDict,"dtheta",fArray); - } - if(self->iLower) - { - NXDupdate(pDict,"bank","lowerbank"); - iLength = 115; - sprintf(pBuffer,"%d",iLength); - NXDupdate(pDict,"noofdetectors",pBuffer); - fArray = getFMBankTheta(LOWER); - NXDputalias(pFile,pDict,"dtheta",fArray); - } - if(self->iUpper) - { - NXDupdate(pDict,"bank","upperbank"); - iLength = 110; - sprintf(pBuffer,"%d",iLength); - NXDupdate(pDict,"noofdetectors",pBuffer); - fArray = getFMBankTheta(UPPER); - NXDputalias(pFile,pDict,"dtheta",fArray); - } - if(self->iMiddle && ( self->iLower || self->iUpper) ) - { - NXDupdate(pDict,"bank","merged"); - iLength = 375; - sprintf(pBuffer,"%d",iLength); - NXDupdate(pDict,"noofdetectors",pBuffer); - fArray = getFMBankTheta(MERGED); - NXDputalias(pFile,pDict,"dtheta",fArray); - } - - NXDupdate(pDict,"bank","bank1"); - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"ddelay","delay"); - - - /* sample info */ - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"saname","sample"); - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"senvir","environment"); - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"sdist","sampledist"); - SNXSPutVariable(pServ->pSics,pCon,pFile,pDict,"saangle","sampleangle"); - - /* close everything */ - NXclose(&pFile); - NXDclose(pDict,NULL); - - } -/*---------------------------------------------------------------------------*/ - static void FoUpdate(pFoWrite self, SConnection *pCon) - { - char pBueffel[512]; - int iInt, iStat, iTime, i,ii, j, iDet, iIndex; - pSicsVariable var1 = NULL; - pSicsVariable var2 = NULL; - pSicsVariable var3 = NULL; - int lbank, mbank, ubank; - long lVal; - float fVal; - const float *fTime; - NXhandle pFile = NULL; - NXdict pDict; - HistInt *lData = NULL; - HistInt *mData = NULL; - HistInt *uData = NULL; - int *iSum = NULL; - float *fAxis = NULL; - long *lSum = NULL; - float fCenter, fStdDev, fFWHM; - - /* open everything again */ - NXopen(self->pFile,NXACC_RDWR,&pFile); - if(!pFile) - { - SCWrite(pCon,"ERROR: cannot reopen data file ",eError); - return; - } - iStat = NXDinitfromfile(self->pDictFile,&pDict); - if(iStat != NX_OK) - { - sprintf(pBueffel,"ERROR: failed to open dictionary file %s", - self->pDictFile); - SCWrite(pCon,pBueffel,eError); - SCWrite(pCon,"ERROR: Aborting data file writing",eError); - SCWrite(pCon,"ERROR: This is a SERIOUS problem!",eError); - SCWrite(pCon,"ERROR: DATA NOT WRITTEN",eError); - NXclose(&pFile); - return; - } - - /* tell the user that something is happening */ - sprintf(pBueffel,"Updating %s",self->pFile); - SCWrite(pCon,pBueffel,eWarning); - - /* do the end time */ - SNXFormatTime(pBueffel,511); - NXDputalias(pFile,pDict,"eend",pBueffel); - - /* chopper speeds */ - SNXSPutDrivable(pServ->pSics,pCon,pFile,pDict,"diskspeed","crot"); - SNXSPutDrivable(pServ->pSics,pCon,pFile,pDict,"fermispeed","fcrot"); - SNXSPutDrivable(pServ->pSics,pCon,pFile,pDict,"phase","fcphase"); - SNXSPutDrivable(pServ->pSics,pCon,pFile,pDict,"ratio","cratio"); - - /* counter data */ - var2 = FindVariable(pServ->pSics,"mbank"); - if(var2) - { - VarGetInt(var2,&mbank); - } else { - SCWrite(pCon,"ERROR: mbank value not found!",eError); - } - if(var2) - { - fVal = GetHistCountTime(self->pHistogram2,pCon); - NXDputalias(pFile,pDict,"cntime",&fVal); - lVal = GetHistMonitor(self->pHistogram2,1,pCon); - NXDputalias(pFile,pDict,"cnmon1",&lVal); - lVal = GetHistMonitor(self->pHistogram2,0,pCon); - NXDputalias(pFile,pDict,"cnmon2",&lVal); - lVal = GetHistMonitor(self->pHistogram2,4,pCon); - NXDputalias(pFile,pDict,"cnmon3",&lVal); - fTime = GetHistTimeBin(self->pHistogram2,&iInt); - } - else - { - var1 = FindVariable(pServ->pSics,"lbank"); - if(var1) - { - VarGetInt(var1,&lbank); - } else { - SCWrite(pCon,"ERROR: lbank value not found!",eError); - } - if(var1) - { - fVal = GetHistCountTime(self->pHistogram1,pCon); - NXDputalias(pFile,pDict,"cntime",&fVal); - lVal = GetHistMonitor(self->pHistogram1,1,pCon); - NXDputalias(pFile,pDict,"cnmon1",&lVal); - lVal = GetHistMonitor(self->pHistogram1,0,pCon); - NXDputalias(pFile,pDict,"cnmon2",&lVal); - lVal = GetHistMonitor(self->pHistogram1,4,pCon); - NXDputalias(pFile,pDict,"cnmon3",&lVal); - fTime = GetHistTimeBin(self->pHistogram1,&iInt); - } - else - { - fVal = GetHistCountTime(self->pHistogram3,pCon); - NXDputalias(pFile,pDict,"cntime",&fVal); - lVal = GetHistMonitor(self->pHistogram3,1,pCon); - NXDputalias(pFile,pDict,"cnmon1",&lVal); - lVal = GetHistMonitor(self->pHistogram3,0,pCon); - NXDputalias(pFile,pDict,"cnmon2",&lVal); - lVal = GetHistMonitor(self->pHistogram3,4,pCon); - NXDputalias(pFile,pDict,"cnmon3",&lVal); - fTime = GetHistTimeBin(self->pHistogram3,&iInt); - } - } - - /* histogram with three detector banks */ - iTime = iInt; - sprintf(pBueffel,"%d",iInt); - NXDupdate(pDict,"timebin",pBueffel); - var1 = FindVariable(pServ->pSics,"lbank"); - if(var1) - { - VarGetInt(var1,&lbank); - } else { - SCWrite(pCon,"ERROR: lbank value not found!",eError); - } - if (var1) - { - lData = GetHistogramPointer(self->pHistogram1,pCon); - if(!lData) - { - SCWrite(pCon,"ERROR: failed to find Histogram Memory Data (lower bank)",eError); - NXclose(&pFile); - NXDclose(pDict,NULL); - return; - } - } - if (var2) - { - mData = GetHistogramPointer(self->pHistogram2,pCon); - if(!mData) - { - SCWrite(pCon,"ERROR: failed to find Histogram Memory Data (middle bank)",eError); - NXclose(&pFile); - NXDclose(pDict,NULL); - return; - } - } - var3 = FindVariable(pServ->pSics,"ubank"); - if(var3) - { - VarGetInt(var3,&ubank); - } else { - SCWrite(pCon,"ERROR: ubank value not found!",eError); - } - if (var3) - { - uData = GetHistogramPointer(self->pHistogram3,pCon); - if(!uData) - { - SCWrite(pCon,"ERROR: failed to find Histogram Memory Data (upper bank)",eError); - NXclose(&pFile); - NXDclose(pDict,NULL); - return; - } - } - setFMDataPointer(lData,iTime,3); - setFMDataPointer(mData,iTime,1); - setFMDataPointer(uData,iTime,2); - /* middle bank */ - if(self->iMiddle) - { - NXDupdate(pDict,"bank","bank1"); - iDet = 150; - sprintf(pBueffel,"%d",iDet); - NXDupdate(pDict,"noofdetectors",pBueffel); - mData = getFMBankPointer(MIDDLE); - NXDputalias(pFile,pDict,"dcounts",mData); - /* summed counts for each detector */ - iSum = (int *)malloc(iDet*sizeof(int)); - if(iSum) - { - memset(iSum,0,iDet*sizeof(int)); - for(i = 0; i < iDet; i++) - { - iIndex = i * iTime; - for(j = 0; j < iTime; j++) - { - iSum[i] += mData[iIndex+j]; - } - } - NXDputalias(pFile,pDict,"dsums",iSum); - free(iSum); - } - else - { - SCWrite(pCon,"WARNING: out of memory, failed to do sums", - eWarning); - } - } - if(self->iUpper) - { - NXDupdate(pDict,"bank","upperbank"); - iDet = 110; - sprintf(pBueffel,"%d",iDet); - NXDupdate(pDict,"noofdetectors",pBueffel); - uData = getFMBankPointer(UPPER); - NXDputalias(pFile,pDict,"dcounts",uData); - /* summed counts for each detector */ - iSum = (int *)malloc(iDet*sizeof(int)); - if(iSum) - { - memset(iSum,0,iDet*sizeof(int)); - for(i = 0; i < iDet; i++) - { - iIndex = i * iTime; - for(j = 0; j < iTime; j++) - { - iSum[i] += uData[iIndex+j]; - } - } - NXDputalias(pFile,pDict,"dsums",iSum); - free(iSum); - } - else - { - SCWrite(pCon,"WARNING: out of memory, failed to do sums", - eWarning); - } - } - if(self->iLower) - { - NXDupdate(pDict,"bank","lowerbank"); - iDet = 115; - sprintf(pBueffel,"%d",iDet); - NXDupdate(pDict,"noofdetectors",pBueffel); - lData = getFMBankPointer(LOWER); - NXDputalias(pFile,pDict,"dcounts",lData); - /* summed counts for each detector */ - iSum = (int *)malloc(iDet*sizeof(int)); - if(iSum) - { - memset(iSum,0,iDet*sizeof(int)); - for(i = 0; i < iDet; i++) - { - iIndex = i * iTime; - for(j = 0; j < iTime; j++) - { - iSum[i] += lData[iIndex+j]; - } - } - NXDputalias(pFile,pDict,"dsums",iSum); - free(iSum); - } - else - { - SCWrite(pCon,"WARNING: out of memory, failed to do sums", - eWarning); - } - /* - now get and write tof_monitor - */ - - lData = (HistInt *)malloc(iTime*sizeof(HistInt)); - if(!lData) - { - SCWrite(pCon,"ERROR: out of memory while writing tof-monitor", - eError); - } - else - { - memset(lData,0,iTime*sizeof(HistInt)); - GetHistogramDirect(self->pHistogram1,pCon,0,115*iTime, - 116*iTime, lData, iTime*sizeof(HistInt)); - NXDputalias(pFile,pDict,"tofmon",lData); - } - } - /* merged data */ - if( (self->iUpper || self->iLower) && self->iMiddle) - { - NXDupdate(pDict,"bank","merged"); - iDet = 375; - sprintf(pBueffel,"%d",iDet); - NXDupdate(pDict,"noofdetectors",pBueffel); - lData = getFMBankPointer(MERGED); - NXDputalias(pFile,pDict,"dcounts",lData); - /* summed counts for each detector */ - iSum = (int *)malloc(iDet*sizeof(int)); - if(iSum) - { - memset(iSum,0,iDet*sizeof(int)); - for(i = 0; i < iDet; i++) - { - iIndex = i * iTime; - for(j = 0; j < iTime; j++) - { - iSum[i] += lData[iIndex+j]; - } - } - NXDputalias(pFile,pDict,"dsums",iSum); - free(iSum); - } - else - { - SCWrite(pCon,"WARNING: out of memory, failed to do sums", - eWarning); - } - } - - - /* calculate elastic peak position */ - NXDupdate(pDict,"bank","bank1"); - mData = getFMBankPointer(MIDDLE); - if(mData) - { - lSum = (long *)malloc(iTime *sizeof(long)); - fAxis = (float *)malloc(iTime *sizeof(float)); - if( lSum && fAxis) - { - memset(lSum,0,iTime*sizeof(long)); - memset(fAxis,0,iTime*sizeof(float)); - for(i = 5; i < iDet - 5; i++) - { - iIndex = i * iTime; - for(j = 0; j < iTime; j++) - { - lSum[j] += mData[iIndex+j]; - } - } - for(i = 0; i < iTime; i++) - { - fAxis[i] = (float)i; - } - iStat = CalculateFitFromData(self->pFitter,fAxis,lSum,iTime); - if(iStat != 1) - { - SCWrite(pCon,"WARNING: problem locating elastic peak",eWarning); - } - GetFitResults(self->pFitter,&fCenter,&fStdDev,&fFWHM,&fVal); - fVal = fCenter - self->fElastic; - if(fVal < 0.) - fVal = - fVal; - /* bad value, leave at theoretical value */ - if(fVal > 10.) - { - SCWrite(pCon, - "WARNING: bad fit result, using theoretical elastic peak position", - eWarning); - } - else - { - self->fElastic = fCenter; - } - free(lSum); - free(fAxis); - } - else - { - SCWrite(pCon,"WARNING: out of memory, failed to do sums",eWarning); - } - } - sprintf(pBueffel,"Elastic peak found at detector: %f",self->fElastic); - SCWrite(pCon,pBueffel,eWarning); - NXDputalias(pFile,pDict,"delastic",&self->fElastic); - - - /* sample temperature */ - SNXSPutEVVar(pFile,pDict,"temperature",pCon,"stemp",NULL); - - - /* close everything */ - NXclose(&pFile); - NXDclose(pDict,NULL); - - } -/*------------------------------------------------------------------------- - FoLink sets all the links for the NXdata vGroup. Had to be separate because - at least one update is necessary before this can be done. -*/ - static void FoLink(pFoWrite self, SConnection *pCon) - { - NXhandle pFile; - NXdict pDict; - int iStat; - char pBueffel[512]; - - /* open everything again */ - NXopen(self->pFile,NXACC_RDWR,&pFile); - if(!pFile) - { - SCWrite(pCon,"ERROR: cannot reopen data file ",eError); - return; - } - iStat = NXDinitfromfile(self->pDictFile,&pDict); - if(iStat != NX_OK) - { - sprintf(pBueffel,"ERROR: failed to open dictionary file %s", - self->pDictFile); - SCWrite(pCon,pBueffel,eError); - SCWrite(pCon,"ERROR: Aborting data file writing",eError); - SCWrite(pCon,"ERROR: This is a SERIOUS problem!",eError); - SCWrite(pCon,"ERROR: DATA NOT WRITTEN",eError); - NXclose(&pFile); - return; - } - - if( (self->iUpper || self->iLower) && self->iMiddle) - { - NXDupdate(pDict,"bank","merged"); - NXDaliaslink(pFile,pDict,"dana","dcounts"); - NXDaliaslink(pFile,pDict,"dana","dtime"); - NXDaliaslink(pFile,pDict,"dana","dtheta"); - NXDaliaslink(pFile,pDict,"dana","cnmon1"); - } - - if(self->iUpper) - { - NXDupdate(pDict,"bank","upperbank"); - NXDaliaslink(pFile,pDict,"dana","dcounts"); - NXDaliaslink(pFile,pDict,"dana","dtime"); - NXDaliaslink(pFile,pDict,"dana","dtheta"); - NXDaliaslink(pFile,pDict,"dana","cnmon1"); - } - if(self->iMiddle) - { - NXDupdate(pDict,"bank","bank1"); - NXDaliaslink(pFile,pDict,"dana","dcounts"); - NXDaliaslink(pFile,pDict,"dana","dtime"); - NXDaliaslink(pFile,pDict,"dana","dtheta"); - NXDaliaslink(pFile,pDict,"dana","cnmon1"); - } - if(self->iLower) - { - NXDupdate(pDict,"bank","lowerbank"); - NXDaliaslink(pFile,pDict,"dana","dcounts"); - NXDaliaslink(pFile,pDict,"dana","dtime"); - NXDaliaslink(pFile,pDict,"dana","dtheta"); - NXDaliaslink(pFile,pDict,"dana","cnmon1"); - } - - - /* close everything */ - NXclose(&pFile); - NXDclose(pDict,NULL); - self->iNew = 0; - } -/*--------------------------------------------------------------------------- - This is the task function for updating the data file any now and then - automatically -*/ - static int FoTask(void *pData) - { - pFoWrite self = NULL; - int iWrite, iRet; - - self = (pFoWrite)pData; - if(!self) - return 0; - - /* figure out if we need to write */ - iWrite = 0; - iRet = 1; - /* first case: update intervall */ - if(time(NULL) >= self->tUpdate) - { - self->tUpdate = time(NULL) + self->iInterval; - iWrite = 1; - iRet = 1; - } - if(self->iEnd) - { - self->tUpdate = 0; - iWrite = 0; - iRet = 0; - FoUpdate(self,self->pCon); - } - - if(iWrite) - { - if(self->iNew) - { - FoStart(self,self->pCon); - FoUpdate(self,self->pCon); - FoLink(self,self->pCon); - } - else - { - FoUpdate(self,self->pCon); - } - } - return iRet; - } -/*------------------------------------------------------------------------*/ - static void KillFoWrite(void *pData) - { - pFoWrite self = NULL; - - self = (pFoWrite)pData; - if(!self) - return; - - if(self->pDes) - DeleteDescriptor(self->pDes); - - if(self->pDictFile) - free(self->pDictFile); - - if(self->pFile) - free(self->pFile); - - if(self->pFitter) - DeleteFitCenter(self->pFitter); - - /* free fomerge */ - killFM(); - - free(self); - } -/*-----------------------------------------------------------------------*/ - int FoInstall(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - CommandList *pCom = NULL; - char pBueffel[512]; - pFoWrite pNew = NULL; - pICallBack pCall = NULL; - pDummy pDum; - pHMcontrol pHMC = NULL; - - /* check arguments */ - if(argc < 4 ) - { - SCWrite(pCon,"ERROR: Insufficient number of arguments to FoInstall", - eError); - return 0; - } - - /* allocate data structure */ - pNew = (pFoWrite)malloc(sizeof(FoWrite)); - if(!pNew) - { - SCWrite(pCon,"ERROR: out of memory in FoInstall",eError); - return 0; - } - memset(pNew,0,sizeof(FoWrite)); - pNew->pDes = CreateDescriptor("FocusWrite"); - pNew->pCall = CreateCallBackInterface(); - pNew->pFitter = CreateFitCenter(NULL); - if( (!pNew->pDes) || (!pNew->pFitter) ) - { - SCWrite(pCon,"ERROR: out of memory in FoInstall",eError); - free(pNew); - return 0; - } - pNew->pDictFile = strdup(argv[2]); - pNew->iInterval = 20*60; - - pHMC = FindCommandData(pSics,argv[1],"HMcontrol"); - if(!pHMC){ - SCWrite(pCon,"ERROR: no histogram memory control found!",eError); - free(pNew); - return 0; - } - - /* find things in interpreter */ - pCom = FindCommand(pSics,"hm1"); - if(!pCom) - { - SCWrite(pCon,"ERROR: Histogram memory for lower detector bank NOT found",eError); - pNew->pHistogram1 = NULL; - } else - { - pNew->pHistogram1 = (pHistMem)pCom->pData; - pNew->iLower =1; - } - - - pCom = FindCommand(pSics,HM2); - if(pCom) - { - pNew->pHistogram2 = (pHistMem)pCom->pData; - pNew->iMiddle =1; - } - else - { - SCWrite(pCon,"ERROR: Histogram memory for middle detector bank NOT found",eError); - pNew->pHistogram2 = NULL; - } - - pCom = FindCommand(pSics,HM3); - if(pCom) - { - pNew->pHistogram3 = (pHistMem)pCom->pData; - pNew->iUpper =1; - } - else - { - SCWrite(pCon,"ERROR: Histogram memory for upper detector bank NOT found",eError); - pNew->pHistogram3 = NULL; - } - - if(!initializeFM(argv[3])) - { - SCWrite(pCon,"ERROR: bad merge data file",eError); - return 0; - } - - pCom = FindCommand(pSics,"counter"); - if(pCom) - { - pNew->pCount = (pCounter)pCom->pData; - } - - RegisterCallback(pHMC->pCall,COUNTSTART,Countstartcallback,pNew,NULL); - RegisterCallback(pHMC->pCall,COUNTEND,Countendcallback,pNew,NULL); - - /* install command */ - AddCommand(pSics,"StoreFocus",FoAction,KillFoWrite,pNew); - return 1; - } -/*-------------------------------------------------------------------------*/ - int FoAction(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - int iRet, iVal; - pFoWrite self = NULL; - char pBueffel[512]; - - if(argc < 1) - { - SCWrite(pCon,"ERROR: Insufficient number of arguments to StoreFocus", - eError); - return 0; - } - self = (pFoWrite)pData; - assert(self); - - strtolower(argv[1]); - if(strcmp(argv[1],"start") == 0) - { - FoStart(self,pCon); - FoUpdate(self,pCon); - FoLink(self,pCon); - return 1; - } - else if(strcmp(argv[1],"update") == 0) - { - if((self->iNew) || (!self->pFile)) - { - FoStart(self,pCon); - FoUpdate(self,pCon); - FoLink(self,pCon); - } - else - { - FoUpdate(self,pCon); - } - return 1; - } - else if(strcmp(argv[1],"getfile") == 0) - { - sprintf(pBueffel,"storefocus.file = %s",self->pFile); - SCWrite(pCon,pBueffel,eValue); - return 1; - } - else if(strcmp(argv[1],"interval") == 0) - { - if(argc > 2) /* set value */ - { - if(!SCMatchRights(pCon,usUser)) - { - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[2],&iVal); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert --> %s <-- to number ",argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - self->iInterval = iVal*60; /* go to seconds from minutes*/ - SCSendOK(pCon); - return 1; - } - else /* read the value */ - { - sprintf(pBueffel,"storefocus.interval = %d",self->iInterval/60); - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } - else if(strcmp(argv[1],"middle") == 0) - { - if(argc > 2) /* set value */ - { - if(!SCMatchRights(pCon,usMugger)) - { - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[2],&iVal); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert --> %s <-- to number ", - argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - if(iVal < 0) iVal = 0; - self->iMiddle = iVal; - setFMconfiguration(self->iUpper,self->iMiddle,self->iLower); - SCSendOK(pCon); - return 1; - } - else /* read the value */ - { - sprintf(pBueffel,"storefocus.middle = %d",self->iMiddle); - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } - else if(strcmp(argv[1],"lower") == 0) - { - if(argc > 2) /* set value */ - { - if(!SCMatchRights(pCon,usMugger)) - { - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[2],&iVal); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert --> %s <-- to number ", - argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - if(iVal < 0) iVal = 0; - self->iLower = iVal; - setFMconfiguration(self->iUpper,self->iMiddle,self->iLower); - SCSendOK(pCon); - return 1; - } - else /* read the value */ - { - sprintf(pBueffel,"storefocus.lower = %d",self->iLower); - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } - else if(strcmp(argv[1],"upper") == 0) - { - if(argc > 2) /* set value */ - { - if(!SCMatchRights(pCon,usMugger)) - { - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[2],&iVal); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: cannot convert --> %s <-- to number ", - argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - if(iVal < 0) iVal = 0; - self->iUpper = iVal; - setFMconfiguration(self->iUpper,self->iMiddle,self->iLower); - SCSendOK(pCon); - return 1; - } - else /* read the value */ - { - sprintf(pBueffel,"storefocus.upper = %d",self->iUpper); - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } - SCWrite(pCon,"ERROR: subcommand to storefocus not recognized",eError); - return 0; - } diff --git a/fowrite.h b/fowrite.h deleted file mode 100644 index fdf4ac0d..00000000 --- a/fowrite.h +++ /dev/null @@ -1,21 +0,0 @@ -/*-------------------------------------------------------------------------- - F O W R I T E - - fowrite is an object for writing FOCUS data files. - - copyright: see copyright.h - - Mark Koennecke, November 1998 -----------------------------------------------------------------------------*/ -#ifndef FOWRITE -#define FOWRITE - - int FoInstall(SConnection *pCon, SicsInterp *pSics, - void *pData, int argc, char *argv[]); - - - int FoAction(SConnection *pCon, SicsInterp *pSics, - void *pData, int argc, char *argv[]); - -#endif - \ No newline at end of file diff --git a/hardsup/Makefile b/hardsup/Makefile deleted file mode 100644 index 018b381c..00000000 --- a/hardsup/Makefile +++ /dev/null @@ -1,44 +0,0 @@ -#--------------------------------------------------------------------------- -# Makefile for the SINQ hardware support library -# -# Mark Koennecke, November 1996 -#-------------------------------------------------------------------------- -.SUFFIXES: -.SUFFIXES: .c .o -OBJ= el734_utility.o asynsrv_utility.o stredit.o \ - strjoin.o failinet.o geterrno.o el737_utility.o sinqhm.o serialsinq.o \ - itc4util.o dillutil.o table.o el755_utility.o el755_errorlog.o \ - makeprint.o StrMatch.o - -#---------- for Redhat linux -#CC= gcc -#CFLAGS= -I$SINQDIR/linux/include -I. -I../ -DLINUX -g -c -#------------ for DigitalUnix -CC=cc -CFLAGS= -I. -I../ -std1 -g -c -#CFLAGS= -I/data/koenneck/include -I. -I../ -std1 -g -c -#------------ for DigitalUnix with Fortify -#CC=cc -#CFLAGS= -DFORTIFY -I. -I../ -std1 -g -c - -#------------ for CYGNUS toolchain on Win32 -## CC=gcc -## CFLAGS= -I. -I../ -DCYGNUS -g -c - -.c.o: - $(CC) $(CFLAGS) $*.c - -hlib: $(OBJ) - - rm -f libhlib.a - ar cr libhlib.a $(OBJ) - ranlib libhlib.a - -clean: - rm -f *.o - rm -f *.a - - - - - - diff --git a/hardsup/README b/hardsup/README deleted file mode 100644 index 71597518..00000000 --- a/hardsup/README +++ /dev/null @@ -1,4 +0,0 @@ - - This directory contains support files for the SINQ drivers. - - All of the code; David Maden. diff --git a/hardsup/StrMatch.c b/hardsup/StrMatch.c deleted file mode 100755 index 6134a05c..00000000 --- a/hardsup/StrMatch.c +++ /dev/null @@ -1,96 +0,0 @@ -#define ident "1A01" -#ifdef VAXC -#module StrMatch ident -#endif -#ifdef __DECC -#pragma module StrMatch ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Department ASQ | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]StrMatch.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Nov 1999 -** -** To compile this module, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]StrMatch - - tasmad_disk:[mad.lib.sinq]StrMatch + - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb StrMatch debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb StrMatch -** -** Updates: -** 1A01 12-Nov-1999 DM. Initial version. -**============================================================================ -** The following entry points are included in this module: -** -**------------------------------------------------------------------------- -** #include -** -** char *StrMatch (&str_a, &str_b, min_len) -** ------- -** Input Args: -** char *str_a - Pointer to first string to be compared. -** char *str_b - Pointer to second string to be compared. -** int min_len - The minimum allowed match length. -** Output Args: -** none -** Modified Args: -** none -** Return value: -** True (non-zero) if the 2 strings match. -** Global variables modified: -** none -** Routines called: -** None -** Description: -** The routine compares 2 strings, str_a and str_b, ignoring case. -** The length of str_a must be less than or equal to the length of str_b. -** The length of str_a must be at least min_len. -**------------------------------------------------------------------------- -** Global Definitions -*/ -#include - -#define NIL '\0' -/* -**==================================================================== -*/ -/* -**==================================================================== -** StrMatch - compare two strings. -*/ - int StrMatch ( -/* ======== -*/ char *str_a, - char *str_b, - int min_len) { - - int i = 0; - - while ((tolower(str_a[i]) == tolower(str_b[i])) && (str_a[i] != '\0')) i++; - - return ((str_a[i] == '\0') && (i >= min_len)); - } -/*-------------------------------------------------- End of StrMatch.C =======*/ diff --git a/hardsup/asynsrv_def.h b/hardsup/asynsrv_def.h deleted file mode 100644 index ccaed197..00000000 --- a/hardsup/asynsrv_def.h +++ /dev/null @@ -1,51 +0,0 @@ -#ifndef _asynsrv_def_ -#define _asynsrv_def_ -/*------------------------------------------------ AsynSrv_DEF.H Ident V01N -*/ -#ifndef OffsetOf -#define OffsetOf(type, identifier) ((size_t)(&((type*) NULL)->identifier)) -#endif - -#ifndef _asynsrv_errcodes_ -#define _asynsrv_errcodes_ -#include -#endif - -#define AsynSrv_MAX_LINK 8 - /* - ** Structures needed by AsynSrv_Utility. - */ - struct AsynSrv__info { - int skt; /* The socket number of the connection */ - char host[20]; /* The name of RS-232-C server */ - int port; /* The TCP/IP port number of server */ - int chan; /* The RS-232-C channel number on server */ - int msg_id; - int protocol_code; /* Flag to identify the server's protocol level */ - char protocol_id[4]; /* ASCII version of server's protocol level */ - int cmnd_hdr_len; /* Header length for command strings */ - char cmnd_fmt[8]; /* "sprintf" format for cmnd header conversion */ - int rply_hdr_len; /* Header length for response strings */ - char rply_fmt[8]; /* "sscanf" format for rply header conversion */ - char chan_char[4]; /* ASCII encoded version of chan */ - char tmo[4]; /* ASCII encoded time-out (deci-secs) */ - char eot[4]; /* Expected terminators */ - int max_replies; /* Binary version of #replies in response */ - int n_replies; /* # of last response returned to caller */ - void (*idleHandler) (int, int); /* MZ. handler called when waiting .. - ** .. on a response */ - }; - - struct AsynSrv_HostPortSkt { - char host[30]; - int port; - int skt; - int protocol_code; - char protocol_id[4]; - int cmnd_hdr_len; - int rply_hdr_len; - int usage_cnt; - int status; - }; -/*------------------------------------------------ End of AsynSrv_DEF.H --*/ -#endif /* _asynsrv_def_ */ diff --git a/hardsup/asynsrv_errcodes.h b/hardsup/asynsrv_errcodes.h deleted file mode 100644 index 493e6083..00000000 --- a/hardsup/asynsrv_errcodes.h +++ /dev/null @@ -1,34 +0,0 @@ -/* -** TAS_SRC:[LIB]ASYNSRV_ERRCODES.H -** -** Include file generated from ASYNSRV_ERRCODES.OBJ -** -** 29-AUG-2000 09:49:15.56 -*/ - -#define ASYNSRV__NO_ROOM 0x86480CC -#define ASYNSRV__FORCED_CLOSED 0x86480C4 -#define ASYNSRV__BAD_SOCKET 0x86480BC -#define ASYNSRV__BAD_SEND_UNKN 0x86480B4 -#define ASYNSRV__BAD_SEND_PIPE 0x86480AC -#define ASYNSRV__BAD_SEND_NET 0x86480A4 -#define ASYNSRV__BAD_SEND_LEN 0x864809C -#define ASYNSRV__BAD_SEND 0x8648094 -#define ASYNSRV__BAD_REPLY 0x864808C -#define ASYNSRV__BAD_RECV1_PIPE 0x8648084 -#define ASYNSRV__BAD_RECV1_NET 0x864807C -#define ASYNSRV__BAD_RECV1 0x8648074 -#define ASYNSRV__BAD_RECV_UNKN 0x864806C -#define ASYNSRV__BAD_RECV_PIPE 0x8648064 -#define ASYNSRV__BAD_RECV_NET 0x864805C -#define ASYNSRV__BAD_RECV_LEN 0x8648054 -#define ASYNSRV__BAD_RECV 0x864804C -#define ASYNSRV__BAD_PROT_LVL 0x8648044 -#define ASYNSRV__BAD_PAR 0x864803C -#define ASYNSRV__BAD_NOT_BCD 0x8648034 -#define ASYNSRV__BAD_HOST 0x864802C -#define ASYNSRV__BAD_FLUSH 0x8648024 -#define ASYNSRV__BAD_CONNECT 0x864801C -#define ASYNSRV__BAD_CMND_LEN 0x8648014 -#define ASYNSRV__BAD_BIND 0x864800C -#define ASYNSRV__FACILITY 0x864 diff --git a/hardsup/asynsrv_mark.c b/hardsup/asynsrv_mark.c deleted file mode 100644 index 59273502..00000000 --- a/hardsup/asynsrv_mark.c +++ /dev/null @@ -1,1465 +0,0 @@ -#define ident "1B06" -#ifdef VAXC -#module AsynSrv_Utility ident -#endif -#ifdef __DECC -#pragma module AsynSrv_Utility ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Department ASQ | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]AsynSrv_Utility.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Mar 1996 -** -** To compile this module, use: - - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]AsynSrv_Utility - - lnsa01::tasmad_disk:[mad.psi.lib.sinq]AsynSrv_Utility + - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @lnsa01::tasmad_disk:[mad.psi.lib.sinq]sinq_olb AsynSrv_Utility debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @lnsa01::tasmad_disk:[mad.psi.lib.sinq]sinq_olb AsynSrv_Utility -** -** Updates: -** 1A01 21-Mar-1996 DM. Initial version. -** 1B01 12-Sep-1996 DM. Allow host name to be in dot format too. -** 1B02 5-May-1997 DM. Set 5 sec time-out on "connect" on VMS systems. -**============================================================================ -** The entry points included in this module are described below. Prototypes -** can be defined via: -** -** #include -** -** AsynSrv_Close - Close a connection to an RS-232-C Server. -** AsynSrv_Config - Configure an open AsynSrv_Utility connection. -** AsynSrv_ConfigDflt - Set defaults for AsynSrv_Open. -** AsynSrv_ErrInfo - Return detailed status from last operation. -** AsynSrv_GetReply - Get next reply from a reply buffer. -** AsynSrv_Open - Open a connection to an RS-232-C Server. -** AsynSrv_SendCmnds - Send commands to a channel of an RS-232-C Server. -**--------------------------------------------------------------------- -** int AsynSrv_Close (&asyn_info, force_flag) -** ------------- -** Input Args: -** int force_flag - if non-zero, all connections using the same socket -** will also be marked as force-closed (socket number -** set to -1) and the connection will really be -** closed. This is needed for error recovery operations. -** Output Args: -** none -** Modified Args: -** struct AsynSrv__info *asyn_info - a structure holding skt, host and -** port of the connection. On return -* skt = 0. -** Return status: -** True if no problems detected, otherwise False and AsynSrv_errcode -** is set to indicate the nature of the problem as follows: -** AsynSrv__BAD_PAR = -29 --> skt does not match with host/port. -** Routines called: -** Socket library, "close". -** Description: -** The routine decrements the usage count on the connection to host/port. -** If the counter is still >0, the routine simply returns. -** If the counter is now 0, the routine sends a "-001" message to the -** server to inform it that we are about to close the link, waits for a -** possible 4 bytes of response and then closes the TCP/IP connection. -**--------------------------------------------------------------------- -** int AsynSrv_Config (&asyn_info, &par_id, par_val, ...) -** -------------- -** Input Args: -** char* par_id - Text string identifying the next argument (see below). -** NULL indicates the end of the argument list. -** par_val - The value to set for the argument. The type of the -** argument can depend on par_id. -** Output Args: -** none -** Modified Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It is used to hold the config -** info for the connection. -** Return status: -** True if no problems detected, otherwise False and AsynSrv_errcode -** is set to indicate the nature of the problem as follows: -** AsynSrv__BAD_PAR = -29 --> Unrecognised par_id or msecTmo < 100 or -** msecTmo > 999'999 or bad eot or .. -** Routines called: -** None -** Description: -** AsynSrv_Config may be used for setting values of parameters for -** use in subsequent calls to AsynSrv_SendCmnds. Defaults for these -** parameters are set via a call to AsynSrv_ConfigDflt, prior to -** calling AsynSrv_Open. Values which may be taken by par_id (warning -- -** par_id is case-sensitive) and the corresponding variable type of -** par_val are: -** -** "msecTmo" int The time-out response for commands sent -** to a serial channel on the server. The -** valid range is 100 to 999'999. -** "eot" char* The expected terminators in responses to -** commands sent to a serial channel on the -** server. The first character specifies the -** number of terminators (max=3). -**--------------------------------------------------------------------- -** int AsynSrv_ConfigDflt (&par_id, par_val, ...) -** ------------------ -** Input Args: -** char* par_id - Text string identifying the next argument (see below). -** NULL indicates the end of the argument list. -** par_val - The value to set for the argument. The type of the -** argument can depend on par_id. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and AsynSrv_errcode -** is set to indicate the nature of the problem as follows: -** AsynSrv__BAD_PAR = -29 --> Unrecognised par_id or msecTmo < 100 or -** msecTmo > 999'999 or bad eot or .. -** Routines called: -** None -** Description: -** AsynSrv_ConfigDflt may be used for setting default values of parameters -** for use in subsequent calls to AsynSrv_Open. Values which may be taken -** by par_id (warning -- par_id is case-sensitive) and the corresponding -** variable type of par_val are: -** -** "TmoC" int The time-out in seconds to be used when -** opening a connection to a server. This -** value is only effective on VMS systems. For -** UNIX systems, the systemwide default (usually -** 75 secs) cannot be changed. The initial -** setting for "TmoC" is 5 secs. -** "msecTmo" int The time-out response for commands sent -** to a serial channel on the server. The -** valid range is 100 to 999'999. The initial -** setting for "msecTmo" is 10'000 msec. -** "eot" char* The expected terminators in responses to -** commands sent to a serial channel on the -** server. The first character specifies the -** number of terminators (max=3). The initial -** setting for "eot" is "1\r". -**------------------------------------------------------------------------- -** void AsynSrv_ErrInfo (&entry_txt_ptr, &errcode, &my_errno, &vaxc_errno) -** --------------- -** Input Args: -** None -** Output Args: -** char **entry_txt_ptr - Pointer to a text string giving the call stack -** at the time that the error was detected. -** int *errcode - An internal error code indicating the detected error. -** int *my_errno - Saved value of errno. -** int *vaxc_errno - Saved value of vaxc$errno (OpenVMS only). -** Modified Args: -** none -** Return status: -** none -** Routines called: -** none -** Description: -** Returns detailed status of the last operation. Once an error has been -** detected, the error status is frozen until this routine has been called. -**------------------------------------------------------------------------- -** char *AsynSrv_GetReply (&asyn_info, &rcve_buff, &last_rply) -** ---------------- -** Input Args: -** struct RS__RespStruct *rcve_buff - address of receive buffer used -** in last call to AsynSrv_SendCmnds. -** char *last_rply - Address of last reply processed -** or NULL. -** Output Args: -** none -** Modified Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It is used to hold status info -** between calls to this routine. -** Return status: -** Address of next reply in the buffer or NULL if no more. Note that this -** is a pointer to the reply and not to the head of the reply structure. -** The terminator byte found is therefore at index [-1] from this address. -** Routines called: -** none -** Description: -** AsynSrv_GetReply unpacks the replies in the response packet from the -** RS232C server which is an argument in the call to AsynSrv_SendCmnds. -** If the routine is called with last_rply = NULL, a pointer to the -** first reply is returned. On calling AsynSrv_GetReply again with -** last_rply set to this address, one receives the address of the second -** reply and so on, until NULL is returned, indicating that all responses -** have been exhausted. -** Warning: -** AsynSrv_GetReply keeps count of the number of responses it returns. -** Responses must therefore be processed in order. -**------------------------------------------------------------------------- -** int AsynSrv_Open (&asyn_info) -** ------------ -** Input Args: -** asyn_info->host - Name of host offering the RS-232-C service. The name -** can be either symbolic or numeric, e.g. -** "lnsw02.psi.ch" or "129.129.90.18". -** asyn_info->port - Number of TCP/IP port of TCP/IP server. -** Output Args: -** none -** Modified Args: -** struct AsynSrv__info *asyn_info - a structure holding skt, host and -** port of the connection. On return -** skt = socket number of connection. -** Set to 0 if error. -** Return status: -** If non-zero, no problems detected and asyn_info->skt is the socket to -** use for communicating with the server. Otherwise, a problem -** was detected and AsynSrv_errcode may be set as follows -** to indicate the nature of the problem: -** AsynSrv__BAD_HOST = -6 --> Call to "gethostbyname" failed to get -** network addr of host. -** AsynSrv__BAD_SOCKET = -7 --> Call to "socket" failed. -** AsynSrv__BAD_BIND = -8 --> Call to "bind" failed. -** AsynSrv__BAD_CONNECT = -9 --> Call to "connect" failed. -** AsynSrv__BAD_PAR = -29 --> Bad parameter found. Probably -** asyn_info->port or asyn_info->chan -** are out of range. -** AsynSrv__NO_ROOM = -40 --> Host/port table full or Active-link -** table full. -** Routines called: -** Socket library routine "open". -** Description: -** The routine maintains a list of hosts/ports to which it has open -** sockets. If an entry is found in the list, the socket is returned -** and the usage count of this connection is incremented. If no entry -** is found in the list, a connection to the host is established and -** entered into the list. -** The routine also maintains a table of active links so that the -** "force-close" function can be performed. The link is added to this -** table too. -**------------------------------------------------------------------------- -** int AsynSrv_SendCmnds (&asyn_info, &send_buff, &rcve_buff, ...) -** ----------------- -** Input Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It contains settings required -** for setting up and sending send_buff. -** char * ... - A list of commands, terminated by NULL, for -** sending to the channel on the server. The commands -** must have any necessary \r characters included. -** Output Args: -** struct RS__RespStruct *rcve_buff - a buffer to receive the response -** from the server. -** Modified Args: -** struct RS__MsgStruct *send_buff - a buffer for holding the commands -** for sending to the server. -** Return status: -** True if no problems detected, otherwise False and errcode (see -** AsynSrv_ErrInfo) is set to indicate the nature of the problem. -** AsynSrv_errcode may be set as follows: -** AsynSrv__BAD_SENDLEN = -12 --> Too much to send; either too many -** commands or too long. The buffer -** is 232 bytes long and each command -** has a 2-byte header. -** Errors -13 to -16 are related to network errors whilst sending the -** message buffer to the server: -** AsynSrv__BAD_SEND = -13 --> Network problem - server has -** probably abended. -** AsynSrv__BAD_SEND_PIPE = -14 --> Network pipe broken - probably same -** cause as AsynSrv__BAD_SEND. -** AsynSrv__BAD_SEND_NET = -15 --> Some other network problem. "errno" -** may be helpful. -** AsynSrv__BAD_SEND_UNKN = -16 --> Some other network problem happened -** resulting in the message not -** getting sent completely. "errno" is -** probably not helpful in this case. -** Errors AsynSrv__BAD_RECV, AsynSrv__BAD_RECV_PIPE, AsynSrv__BAD_RECV_NET -** and AsynSrv__BAD_RECV_UNKN (-17 to -20) are related to network -** errors whilst receiving the 4-byte response header. They are -** analogous to AsynSrv__BAD_SEND to AsynSrv__BAD_SEND_UNKN. -** AsynSrv__BAD_NOT_BCD = -21 --> The 4-byte response header is not an -** ASCII coded decimal integer. -** AsynSrv__BAD_RECVLEN = -22 --> The body of the response would be too -** big to fit in the input buffer. The -** buffer is ??? bytes long and each -** response has a 5-byte header and a -** trailing zero-byte. The response -** is flushed. -** AsynSrv__BAD_FLUSH = -23 --> Some network error was detected -** during flushing. This is an "or" -** of errors AsynSrv__BAD_RECV to -** AsynSrv__BAD_RECV_UNKN. -** AsynSrv__FORCED_CLOSED = -32 --> The connection to the motor has been -** forcefully closed. See below. -** AsynSrv__BAD_REPLY = -34 --> The n_rply field of the response was -** either non-numeric or <0, indicating -** that the Terminal Server detected an -** error. The reply is added to the -** routine call stack for debug purposes. -** -** Errors AsynSrv__BAD_RECV1, AsynSrv__BAD_RECV1_PIPE and -** AsynSrv__BAD_RECV1_NET (-24 to -26) are related to network -** errors whilst receiving the body of the response. They are -** equivalent to errors AsynSrv__BAD_RECV, to AsynSrv__BAD_RECV_NET. -** -** AsynSrv__FORCED_CLOSED occurs if AsynSrv_Close has been called -** for another device on the same server and the 'force_flag' -** was set (see AsynSrv_Close). The caller should call -** AsynSrv_Close and then AsynSrv_Open to re-establish a -** connection to the server. -** Routines called: -** Socket library routines send and recv. -** Description: -** The list of commands is assembled into a message buffer with appropriate -** header information and sent off to the server. The response is then -** awaited and read in when it arrives. -** -** For any of the following errors: -** AsynSrv__BAD_SEND (Note: AsynSrv__BAD_SENDLEN and -** AsynSrv__BAD_SEND_PIPE AsynSrv__BAD_RECVLEN do not cause a close -** AsynSrv__BAD_SEND_NET -** AsynSrv__BAD_SEND_UNKN -** AsynSrv__BAD_RECV -** AsynSrv__BAD_RECV_PIPE -** AsynSrv__BAD_RECV_NET -** AsynSrv__BAD_RECV_UNKN -** AsynSrv__BAD_NOT_BCD -** AsynSrv__BAD_FLUSH -** AsynSrv__BAD_RECV1 -** AsynSrv__BAD_RECV1_PIPE -** AsynSrv__BAD_RECV1_NET -** the network link to the server is force-closed via a call to AsynSrv_Close. -** Once the error has been corrected, the link can be re-opened via a -** call to AsynSrv_Open. As a result of the force-close, other active handles -** will need to be released via a call to AsynSrv_Close before AsynSrv_Open is -** called. -** -** Note: neither of the errors AsynSrv__BAD_SENDLEN, AsynSrv__BAD_RECVLEN -** nor AsynSrv__BAD_REPLY cause the link to be closed. -**============================================================================*/ -/* -**--------------------------------------------------------------------------- -** Global Definitions -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include "fortify.h" -#include - -#ifdef __VMS -#include -#include -#else -#include -#endif -/*-----------------------------------------------------------------*/ -#include -#include -#include - -#define True 1 -#define False 0 - -#define MAX_OPEN 64 -/*-------------------------------------------------------------------------- -** Global Variables -*/ - static int AsynSrv_call_depth = 0; - static char AsynSrv_routine[5][64]; - static int AsynSrv_errcode = 0; - static int AsynSrv_errno, AsynSrv_vaxc_errno; - static int AsynSrv_connect_tmo = 5; /* Time-out on "connect" */ - static int AsynSrv_msec_tmo = 10000; /* Time-out for responses */ - static char AsynSrv_eot[] = {'1', '\r', '\0','\0'}; /* Terminators */ -/* -** The following is the list of open connections (= number of -** active sockets). -*/ - static int AsynSrv_n_cnct = 0; - static struct AsynSrv_HostPortSkt AsynSrv_HPS_list[AsynSrv_MAX_LINK]; -/* -** The following is the list of active calls to AsynSrv_Open. -*/ - static int AsynSrv_n_active = 0; - static struct AsynSrv__info *AsynSrv_active[MAX_OPEN]; -/* -**--------------------------------------------------------------------------- -** AsynSrv_Close: Close a connection to an RS-232-C server. -*/ - int AsynSrv_Close ( -/* ============= -*/ struct AsynSrv__info *asyn_info, - int force_flag) { - - int i, j, k, my_skt; - char buff[4]; - /*----------------------------------------------- - */ - if (asyn_info == NULL) return True; /* Just return if nothing to do! */ - my_skt = asyn_info->skt; - if (my_skt <= 0) return True; /* Just return if nothing to do! */ - /*----------------------------------------------- - ** Pre-set the routinename (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_Close"); - AsynSrv_call_depth++; - } - /*------------------------------------------------------ - ** Start by finding the table entry for this connection - */ - for (i = 0; i < AsynSrv_n_cnct; i++) { - if (AsynSrv_HPS_list[i].skt != my_skt) continue; - if (AsynSrv_HPS_list[i].port != asyn_info->port) continue; - if (strcmp (AsynSrv_HPS_list[i].host, asyn_info->host) == 0) break; - } - if (i >= AsynSrv_n_cnct) { /* Did we find the entry? */ - AsynSrv_errcode = AsynSrv__BAD_PAR; /* No! */ - return False; - } - /*------------------------------------------------------ - ** Now find the table entry for the AsynSrvOpen call. - */ - for (j = 0; j < AsynSrv_n_active; j++) { - if ((AsynSrv_active[j] == asyn_info) && - (AsynSrv_active[j]->skt == my_skt)) { - break; - } - } - if (j >= AsynSrv_n_active) { /* Did we find the entry? */ - AsynSrv_errcode = AsynSrv__BAD_PAR; /* No! */ - return False; - } - /*------------------------------------------------------ - ** i is the index for the connection table entry. - ** j is the index for the caller's AsynSrvOpen call entry. - */ - if (AsynSrv_HPS_list[i].usage_cnt <= 0) { /* Is the connection active? */ - AsynSrv_errcode = AsynSrv__BAD_PAR; /* No */ - return False; - } - /*------------------------------------------------------ - ** For the caller, simply set his socket number to zero, - ** mark the AsynSrvOpen entry as free and decrease the - ** usage count (the entries will be compressed later). - */ - AsynSrv_active[j]->skt = 0; /* Mark the close .. */ - AsynSrv_active[j] = NULL; /* .. and flag entry to be removed. */ - AsynSrv_HPS_list[i].usage_cnt--; /* Decrease usage count */ - /*------------------------------------------------------ - ** If this is a force-close, go through all AsynSrv_Open - ** entries looking for a socket match, mark them as - ** free and decrease usage count. - */ - if (force_flag) { - for (k = 0; k < AsynSrv_n_active; k++) { - if (AsynSrv_active[k] != NULL) { - if (AsynSrv_active[k]->skt == my_skt) { - AsynSrv_active[k]->skt = -1; /* Mark the force-close */ - AsynSrv_active[k] = NULL; /* Mark entry to be removed */ - AsynSrv_HPS_list[i].usage_cnt--; /* Decrease usage count */ - } - } - } - if (AsynSrv_HPS_list[i].usage_cnt != 0) { /* Use count should now be .. */ - AsynSrv_errcode = AsynSrv__BAD_PAR; /* .. zero or there's a bug. */ - return False; - } - } - /*------------------------------------------------------ - ** Compress the list of AsynSrv_Open entries - */ - j = 0; - for (k = 0; k < AsynSrv_n_active; k++) { - if (AsynSrv_active[k] != NULL) { - AsynSrv_active[j] = AsynSrv_active[k]; - j++; - } - } - for (k = j; k < AsynSrv_n_active; k++) AsynSrv_active[k] = NULL; - AsynSrv_n_active = j; - /*------------------------------------------------------ - ** If the link is now idle, really close it and compress - ** the connection table entry out of the list. - */ - if (AsynSrv_HPS_list[i].usage_cnt == 0) { - send (my_skt, "-001", 4, 0); /* Tell the TCP/IP server that .. - ** .. we are about to quit. - */ - recv (my_skt, buff, sizeof (buff), 0); /* And wait for his ack */ - close (my_skt); - for (j = i; j < AsynSrv_n_cnct; j++) { - memcpy ((char *) &AsynSrv_HPS_list[j], (char *) &AsynSrv_HPS_list[j+1], - sizeof (AsynSrv_HPS_list[0])); - } - AsynSrv_HPS_list[AsynSrv_n_cnct].skt = 0; /* Invalidate the free entry */ - AsynSrv_n_cnct--; - } - AsynSrv_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_Config: Configure an open connection. -*/ - int AsynSrv_Config ( -/* ============== -*/ struct AsynSrv__info *asyn_info, - ...) { - - char buff[16]; - va_list ap; /* Pointer to variable args */ - char *txt_ptr; - int intval; - /* - ** Pre-set the routinename (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_Config"); - AsynSrv_call_depth++; - } - - va_start (ap, asyn_info); /* Set up var arg machinery */ - txt_ptr = va_arg (ap, char *); /* Get pntr to first parameter ident */ - while (txt_ptr != NULL) { - if (strcmp (txt_ptr, "msecTmo") == 0) { - intval = va_arg (ap, int); - if ((intval < 100) || (intval > 999999)) { - AsynSrv_errcode = AsynSrv__BAD_PAR; - return False; - } - sprintf (buff, "%04d", intval/100); /* Convert to ASCII as .. - ** .. deci-secs */ - memcpy (asyn_info->tmo, buff, 4); - }else if (strcmp (txt_ptr, "eot") == 0) { - txt_ptr = va_arg (ap, char *); - if (txt_ptr == NULL) { - AsynSrv_errcode = AsynSrv__BAD_PAR; - return False; - } - memcpy (asyn_info->eot, "\0\0\0\0", 4); - switch (txt_ptr[0]) { - case '3': asyn_info->eot[3] = txt_ptr[3]; - case '2': asyn_info->eot[2] = txt_ptr[2]; - case '1': asyn_info->eot[1] = txt_ptr[1]; - case '0': - asyn_info->eot[0] = txt_ptr[0]; - break; - default: - AsynSrv_errcode = AsynSrv__BAD_PAR; - return False; - } - }else { - AsynSrv_errcode = AsynSrv__BAD_PAR; - return False; - } - txt_ptr = va_arg (ap, char *); /* Get pntr to next parameter ident */ - } - - AsynSrv_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_ConfigDflt: Set default values in AsynSrv_Utility -** which will be used to initialise -** structures in AsynSrv_Open. -*/ - int AsynSrv_ConfigDflt ( -/* ================== -*/ char *par_id, - ...) { - int i; - char buff[4]; - va_list ap; /* Pointer to variable args */ - char *txt_ptr; - int intval; - /* - ** Pre-set the routinename (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_ConfigDflt"); - AsynSrv_call_depth++; - } - - va_start (ap, par_id); /* Set up var arg machinery */ - txt_ptr = par_id; /* Point to first arg */ - while (txt_ptr != NULL) { - if (strcmp (txt_ptr, "tmoC") == 0) { - intval = va_arg (ap, int); - if ((intval < 1) || (intval > 3600)) { - AsynSrv_errcode = AsynSrv__BAD_PAR; - return False; - } - AsynSrv_connect_tmo = intval; - }else if (strcmp (txt_ptr, "msecTmo") == 0) { - intval = va_arg (ap, int); - if ((intval < 100) || (intval > 999900)) { - AsynSrv_errcode = AsynSrv__BAD_PAR; - return False; - } - AsynSrv_msec_tmo = intval; - }else if (strcmp (txt_ptr, "eot") == 0) { - txt_ptr = va_arg (ap, char *); - if (txt_ptr == NULL) { - AsynSrv_errcode = AsynSrv__BAD_PAR; - return False; - } - switch (txt_ptr[0]) { - case '3': AsynSrv_eot[3] = txt_ptr[3]; - case '2': AsynSrv_eot[2] = txt_ptr[2]; - case '1': AsynSrv_eot[1] = txt_ptr[1]; - case '0': - AsynSrv_eot[0] = txt_ptr[0]; - break; - default: - AsynSrv_errcode = AsynSrv__BAD_PAR; - return False; - } - switch (txt_ptr[0]) { - case '0': AsynSrv_eot[1] = '\0'; - case '1': AsynSrv_eot[2] = '\0'; - case '2': AsynSrv_eot[3] = '\0'; - } - }else { - AsynSrv_errcode = AsynSrv__BAD_PAR; - return False; - } - txt_ptr = va_arg (ap, char *); /* Get pntr to next parameter ident */ - } - - AsynSrv_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_ErrInfo: Return detailed status from last operation. -*/ - void AsynSrv_ErrInfo ( -/* =============== -*/ char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno) { - - int i, j, k; - char buff[80]; - - if (AsynSrv_call_depth <= 0) { - strcpy (AsynSrv_routine[0], "AsynSrv_no_error_detected"); - *errcode = 0; - *my_errno = 0; - *vaxc_errno = 0; - }else { - if (AsynSrv_call_depth > 1) { /* Concatenate the names */ - for (i = 1; i < AsynSrv_call_depth; i++) { - strcat (AsynSrv_routine[0], "/"); - StrJoin (AsynSrv_routine[0], sizeof (AsynSrv_routine), - AsynSrv_routine[0], AsynSrv_routine[i]); - } - } - *errcode = AsynSrv_errcode; - *my_errno = AsynSrv_errno; - *vaxc_errno = AsynSrv_vaxc_errno; - switch (AsynSrv_errcode) { - case AsynSrv__BAD_HOST: strcpy (buff, "/AsynSrv__BAD_HOST"); break; - case AsynSrv__BAD_SOCKET: strcpy (buff, "/AsynSrv__BAD_SOCKET"); break; - case AsynSrv__BAD_BIND: strcpy (buff, "/AsynSrv__BAD_BIND"); break; - case AsynSrv__BAD_CONNECT: strcpy (buff, "/AsynSrv__BAD_CONNECT"); break; - case AsynSrv__BAD_SENDLEN: strcpy (buff, "/AsynSrv__BAD_SENDLEN"); break; - case AsynSrv__BAD_SEND: strcpy (buff, "/AsynSrv__BAD_SEND"); break; - case AsynSrv__BAD_SEND_PIPE: strcpy (buff, "/AsynSrv__BAD_SEND_PIPE"); break; - case AsynSrv__BAD_SEND_NET: strcpy (buff, "/AsynSrv__BAD_SEND_NET"); break; - case AsynSrv__BAD_SEND_UNKN: strcpy (buff, "/AsynSrv__BAD_SEND_UNKN"); break; - case AsynSrv__BAD_RECV: strcpy (buff, "/AsynSrv__BAD_RECV"); break; - case AsynSrv__BAD_RECV_PIPE: strcpy (buff, "/AsynSrv__BAD_RECV_PIPE"); break; - case AsynSrv__BAD_RECV_NET: strcpy (buff, "/AsynSrv__BAD_RECV_NET"); break; - case AsynSrv__BAD_RECV_UNKN: strcpy (buff, "/AsynSrv__BAD_RECV_UNKN"); break; - case AsynSrv__BAD_NOT_BCD: strcpy (buff, "/AsynSrv__BAD_NOT_BCD"); break; - case AsynSrv__BAD_RECVLEN: strcpy (buff, "/AsynSrv__BAD_RECVLEN"); break; - case AsynSrv__BAD_FLUSH: strcpy (buff, "/AsynSrv__BAD_FLUSH"); break; - case AsynSrv__BAD_RECV1: strcpy (buff, "/AsynSrv__BAD_RECV1"); break; - case AsynSrv__BAD_RECV1_PIPE:strcpy (buff, "/AsynSrv__BAD_RECV1_PIPE"); break; - case AsynSrv__BAD_RECV1_NET: strcpy (buff, "/AsynSrv__BAD_RECV1_NET"); break; - case AsynSrv__BAD_PAR: strcpy (buff, "/AsynSrv__BAD_PAR"); break; - case AsynSrv__FORCED_CLOSED: strcpy (buff, "/AsynSrv__FORCED_CLOSED"); break; - case AsynSrv__BAD_REPLY: strcpy (buff, "/AsynSrv__BAD_REPLY"); break; - case AsynSrv__BAD_CMND_LEN: strcpy (buff, "/AsynSrv__BAD_CMND_LEN"); break; - case AsynSrv__BAD_PROT_LVL: strcpy (buff, "/AsynSrv__BAD_PROT_LVL"); break; - case AsynSrv__NO_ROOM: strcpy (buff, "/AsynSrv__NO_ROOM"); break; - default: sprintf (buff, "/AsynSrv__unkn_err_code: %d", AsynSrv_errcode); - } - StrJoin (AsynSrv_routine[0], sizeof(AsynSrv_routine), - AsynSrv_routine[0], buff); - } - *entry_txt = AsynSrv_routine[0]; - AsynSrv_call_depth = 0; - AsynSrv_errcode = 0; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_GetReply: Get next reply from a reply buffer. -*/ - char *AsynSrv_GetReply ( -/* ================ -*/ struct AsynSrv__info *asyn_info, - struct RS__RespStruct *rcve_buff, - char *last_rply) { - - char *pntr = NULL; - int i, rply_len; - - if (last_rply == NULL) { /* Start with first reply? */ - /* Yes */ - asyn_info->n_replies = 1; - if (asyn_info->max_replies > 0) { - pntr = rcve_buff->u.rplys; - pntr = pntr + 1 + asyn_info->rply_hdr_len; - } - }else { /* No - get next reply */ - if (asyn_info->n_replies < asyn_info->max_replies) { /* If there is one */ - i = sscanf ((last_rply - asyn_info->rply_hdr_len - 1), - asyn_info->rply_fmt, &rply_len); - if ((i == 1) && (rply_len >= 0)) { - pntr = last_rply + rply_len + asyn_info->rply_hdr_len; - } - } - } - return pntr; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_Open: Open a connection to an RS-232-C Server. -*/ - int AsynSrv_Open ( -/* ============ -*/ struct AsynSrv__info *asyn_info) { - - int i, status; - int my_skt; - char old_time_out[4]; - union { - char chars[4]; - int val; - } time_out; - char buff[128]; - struct RS__MsgStruct s_buff; - struct RS__RespStruct r_buff; - unsigned int oto_len, oto_status; - struct hostent *rmt_hostent; - struct in_addr *rmt_inet_addr_pntr; - struct in_addr rmt_inet_addr; - int rmt_sockname_len; - struct sockaddr_in lcl_sockname; - struct sockaddr_in rmt_sockname; - - char *errtxt_ptr; - int errcode, my_errno, my_vaxc_errno; -/*-------------------------------------------------------- -*/ - asyn_info->skt = 0; -/*-------------------------------------------------------- -** Initialise the error info stack and pre-set the -** routine name (in case of error). -*/ - AsynSrv_errcode = AsynSrv_errno = AsynSrv_vaxc_errno = 0; - strcpy (AsynSrv_routine[0], "AsynSrv_Open"); - AsynSrv_call_depth = 1; -/*-------------------------------------------------------- -** Is there room for a new AsynSrv_Open table entry? -*/ - if (AsynSrv_n_active >= MAX_OPEN) { - AsynSrv_errcode = AsynSrv__NO_ROOM; /* There isn't! */ - return False; - } -/*-------------------------------------------------------- -** See if a table entry for this connection already exists. -*/ - for (i = 0; i < AsynSrv_n_cnct; i++) { - if (AsynSrv_HPS_list[i].port != asyn_info->port) continue; - if (strcmp (AsynSrv_HPS_list[i].host, asyn_info->host) == 0) break; - } - if (i < AsynSrv_n_cnct) { /* Did we find an entry? */ - AsynSrv_call_depth--; /* Yes */ - AsynSrv_HPS_list[i].usage_cnt++; /* Up the usage count and .. */ - AsynSrv_active[AsynSrv_n_active] = /* .. remember the open and .. */ - asyn_info; - AsynSrv_n_active++; - asyn_info->skt = /* .. return the socket. */ - AsynSrv_HPS_list[i].skt; - if (asyn_info->chan < 0) asyn_info->chan = 0; - if (asyn_info->chan > 255) asyn_info->chan = 0; - sprintf (buff, "%04d", asyn_info->chan); /* Convert channel # to ASCII */ - memcpy (asyn_info->chan_char, buff, sizeof (asyn_info->chan_char)); - - asyn_info->protocol_code = AsynSrv_HPS_list[i].protocol_code; - memcpy (asyn_info->protocol_id, - AsynSrv_HPS_list[i].protocol_id, - sizeof (asyn_info->protocol_id)); - asyn_info->cmnd_hdr_len = AsynSrv_HPS_list[i].cmnd_hdr_len; - sprintf (asyn_info->cmnd_fmt, "%%0%dd", asyn_info->cmnd_hdr_len); - asyn_info->rply_hdr_len = AsynSrv_HPS_list[i].rply_hdr_len; - sprintf (asyn_info->rply_fmt, "%%%dd", asyn_info->rply_hdr_len); - - sprintf (buff, "%04d", AsynSrv_msec_tmo/100); /* Set dflt time-out .. - ** ..(deci-secs) */ - memcpy (asyn_info->tmo, buff, sizeof (asyn_info->tmo)); - - memcpy (asyn_info->eot, /* Set dflt terminator(s) */ - AsynSrv_eot, sizeof (asyn_info->eot)); - - asyn_info->max_replies = asyn_info->n_replies = 0; - return True; - } -/*-------------------------------------------------------- -** There is no existing connection. Is there room for -** a new connection entry? -*/ - if (AsynSrv_n_cnct >= AsynSrv_MAX_LINK) { - AsynSrv_errcode = AsynSrv__NO_ROOM; /* There isn't! */ - return False; - } -/*-------------------------------------------------------- -** But, before going any further, do some quick checks on -** values in asyn_info. -*/ - if ((asyn_info->port <= 0) || - (asyn_info->port > 65535)) { - AsynSrv_errcode = AsynSrv__BAD_PAR; /* Something is bad! */ - return False; - } - if (asyn_info->chan < 0) asyn_info->chan = 0; - if (asyn_info->chan > 255) asyn_info->chan = 0; -/*-------------------------------------------------------- -** Set up a new connection. -*/ - StrJoin (AsynSrv_HPS_list[AsynSrv_n_cnct].host, - sizeof (AsynSrv_HPS_list[AsynSrv_n_cnct].host), - asyn_info->host, ""); - AsynSrv_HPS_list[AsynSrv_n_cnct].port = asyn_info->port; - /*--------------------------- - ** Get the Internet address of the server. - */ - rmt_inet_addr.s_addr = inet_addr (asyn_info->host); - if (rmt_inet_addr.s_addr != -1) { - rmt_inet_addr_pntr = &rmt_inet_addr; - }else { - rmt_hostent = gethostbyname (asyn_info->host); - if (rmt_hostent == NULL) { - AsynSrv_errcode = AsynSrv__BAD_HOST; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save errno info */ - fprintf (stderr, "\nAsynSrv_Open/gethostbyname: Failed to get Internet " - "address of \"%s\".\n", asyn_info->host); - return False; - } - rmt_inet_addr_pntr = (struct in_addr *) rmt_hostent->h_addr_list[0]; - } - /*--------------------------- - ** Create a TCP/IP socket for connecting to server and bind it. - */ - my_skt = socket (AF_INET, SOCK_STREAM, 0); - if (my_skt <= 0) { - AsynSrv_errcode = AsynSrv__BAD_SOCKET; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save the errno info */ - fprintf (stderr, "\nAsynSrv_Open/socket: Failed to create a socket.\n"); - return False; - } - lcl_sockname.sin_family = AF_INET; - lcl_sockname.sin_port = htons (0); - lcl_sockname.sin_addr.s_addr = 0; - status = bind (my_skt, (struct sockaddr *) &lcl_sockname, - sizeof (lcl_sockname)); - if (status == -1) { - close (my_skt); - AsynSrv_errcode = AsynSrv__BAD_BIND; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save the errno info */ - fprintf (stderr, "\nAsynSrv_Open/bind: Failed to bind socket.\n"); - return False; - } - /*--------------------------- - ** Set short time-out (VMS systems only) - */ -#ifdef __VMS - oto_len = sizeof (old_time_out); /* Save current time-out first */ - oto_status = getsockopt (my_skt, IPPROTO_TCP, UCX$C_TCP_PROBE_IDLE, - old_time_out, &oto_len); - - if (oto_status == 0) { - time_out.val = AsynSrv_connect_tmo; /* Set new time-out */ - status = setsockopt (my_skt, IPPROTO_TCP, UCX$C_TCP_PROBE_IDLE, - time_out.chars, sizeof (time_out)); - } -#endif - /*--------------------------- - ** Connect to RS-232-C Server. - */ - rmt_sockname_len = sizeof (rmt_sockname); - rmt_sockname.sin_family = AF_INET; - rmt_sockname.sin_port = htons (asyn_info->port); - rmt_sockname.sin_addr.s_addr = rmt_inet_addr_pntr->s_addr; - status = connect (my_skt, (struct sockaddr *) &rmt_sockname, - sizeof (rmt_sockname)); - if (status != 0) { - close (my_skt); - AsynSrv_errcode = AsynSrv__BAD_CONNECT; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save the errno info */ - fprintf (stderr, - "\nAsynSrv_Open/connect: Failed to connect to server.\n"); - perror ("AsynSrv_Open"); - return False; - } - /*--------------------------- - ** Restore time-out (VMS only) - */ -#ifdef __VMS - if (oto_status == 0) { - setsockopt (my_skt, IPPROTO_TCP, UCX$C_TCP_PROBE_IDLE, - old_time_out, oto_len); - } -#endif - /*--------------------------------------------------- - ** Setup the defaults in the AsynSrv__info data structure. - */ - asyn_info->skt = my_skt; /* Return socket number to caller */ - - asyn_info->protocol_code = 0; /* Ensure protocol_code set to "unknown" */ - memcpy (asyn_info->protocol_id, "\0\0\0\0", - sizeof (asyn_info->protocol_id)); - asyn_info->cmnd_hdr_len = 4; - strcpy (asyn_info->cmnd_fmt, "%04d"); - asyn_info->rply_hdr_len = 4; - strcpy (asyn_info->rply_fmt, "%4d"); - - sprintf (buff, "%04d", asyn_info->chan); /* Convert channel # to ASCII */ - memcpy (asyn_info->chan_char, buff, sizeof (asyn_info->chan_char)); - - sprintf (buff, "%04d", AsynSrv_msec_tmo/100); /* Set dflt time-out .. - ** .. (deci-secs) */ - memcpy (asyn_info->tmo, buff, sizeof (asyn_info->tmo)); - - memcpy (asyn_info->eot, AsynSrv_eot, sizeof (asyn_info->eot)); /* Set .. - ** .. dflt terminator(s) */ - asyn_info->max_replies = 0; - asyn_info->n_replies = 0; - /* - ** Send a null command buffer to the server. This should give - ** a "protocol mismatch" error response and from this we can get - ** the actual protocol level supported by the server. - */ - status = AsynSrv_SendCmnds (asyn_info, &s_buff, &r_buff, NULL); - if (!status && (AsynSrv_errcode == AsynSrv__BAD_PROT_LVL)) { - /* - ** As expected, we got a "protocol mismatch" error. - ** Save the server's protocol level for future use. - */ - memcpy (asyn_info->protocol_id, r_buff.s_pcol_lvl, - sizeof (r_buff.s_pcol_lvl)); - if (strncmp (r_buff.s_pcol_lvl, RS__PROTOCOL_ID_V01B, - strlen (RS__PROTOCOL_ID_V01B)) == 0) { - asyn_info->protocol_code = RS__PROTOCOL_CODE_V01B; - asyn_info->cmnd_hdr_len = 4; - strcpy (asyn_info->cmnd_fmt, "%04d"); - asyn_info->rply_hdr_len = 4; - strcpy (asyn_info->rply_fmt, "%4d"); - }else if (strncmp (r_buff.s_pcol_lvl, RS__PROTOCOL_ID, - strlen (RS__PROTOCOL_ID)) == 0) { - asyn_info->protocol_code = RS__PROTOCOL_CODE; - asyn_info->cmnd_hdr_len = 2; - strcpy (asyn_info->cmnd_fmt, "%02d"); - asyn_info->rply_hdr_len = 2; - strcpy (asyn_info->rply_fmt, "%2d"); - }else { - close (my_skt); - asyn_info->skt = 0; - fprintf (stderr, - "\nAsynSrv_Open: Server protocol level is unrecognised.\n" - " Server level is \"%4s\"\n", r_buff.s_pcol_lvl); - return False; - } - }else { - close (my_skt); - asyn_info->skt = 0; - AsynSrv_errcode = AsynSrv__BAD_PROT_LVL; - fprintf (stderr, - "\nAsynSrv_Open: Problem getting protocol level of Server!\n"); - return False; - } - /*--------------------------------------------------- - ** Complete the setup of the connection table entry - */ - AsynSrv_HPS_list[AsynSrv_n_cnct].skt = my_skt; - AsynSrv_HPS_list[AsynSrv_n_cnct].protocol_code = asyn_info->protocol_code; - memcpy (AsynSrv_HPS_list[AsynSrv_n_cnct].protocol_id, - asyn_info->protocol_id, sizeof (asyn_info->protocol_id)); - AsynSrv_HPS_list[AsynSrv_n_cnct].cmnd_hdr_len = asyn_info->cmnd_hdr_len; - AsynSrv_HPS_list[AsynSrv_n_cnct].rply_hdr_len = asyn_info->rply_hdr_len; - AsynSrv_HPS_list[AsynSrv_n_cnct].usage_cnt = 1; - AsynSrv_n_cnct++; - - AsynSrv_active[AsynSrv_n_active] = /* Remember the open in case .. */ - asyn_info; /* .. there's a force-exit */ - AsynSrv_n_active++; - - AsynSrv_errcode = AsynSrv_errno = AsynSrv_vaxc_errno = 0; - AsynSrv_call_depth = 0; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_Force: Open a connection to an RS-232-C Server. -** Thereby insisting on an own socket. -*/ - int AsynSrv_Force ( -/* ============ -*/ struct AsynSrv__info *asyn_info) { - - int i, status; - int my_skt; - char old_time_out[4]; - union { - char chars[4]; - int val; - } time_out; - char buff[128]; - struct RS__MsgStruct s_buff; - struct RS__RespStruct r_buff; - unsigned int oto_len, oto_status; - struct hostent *rmt_hostent; - struct in_addr *rmt_inet_addr_pntr; - struct in_addr rmt_inet_addr; - int rmt_sockname_len; - struct sockaddr_in lcl_sockname; - struct sockaddr_in rmt_sockname; - - char *errtxt_ptr; - int errcode, my_errno, my_vaxc_errno; -/*-------------------------------------------------------- -*/ - asyn_info->skt = 0; -/*-------------------------------------------------------- -** Initialise the error info stack and pre-set the -** routine name (in case of error). -*/ - AsynSrv_errcode = AsynSrv_errno = AsynSrv_vaxc_errno = 0; - strcpy (AsynSrv_routine[0], "AsynSrv_Open"); - AsynSrv_call_depth = 1; -/*-------------------------------------------------------- -** But, before going any further, do some quick checks on -** values in asyn_info. -*/ - if ((asyn_info->port <= 0) || - (asyn_info->port > 65535)) { - AsynSrv_errcode = AsynSrv__BAD_PAR; /* Something is bad! */ - return False; - } - if (asyn_info->chan < 0) asyn_info->chan = 0; - if (asyn_info->chan > 255) asyn_info->chan = 0; -/*-------------------------------------------------------- -** Set up a new connection. -*/ - /*--------------------------- - ** Get the Internet address of the server. - */ - rmt_inet_addr.s_addr = inet_addr (asyn_info->host); - if (rmt_inet_addr.s_addr != -1) { - rmt_inet_addr_pntr = &rmt_inet_addr; - }else { - rmt_hostent = gethostbyname (asyn_info->host); - if (rmt_hostent == NULL) { - AsynSrv_errcode = AsynSrv__BAD_HOST; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save errno info */ - fprintf (stderr, "\nAsynSrv_Open/gethostbyname: Failed to get Internet " - "address of \"%s\".\n", asyn_info->host); - return False; - } - rmt_inet_addr_pntr = (struct in_addr *) rmt_hostent->h_addr_list[0]; - } - /*--------------------------- - ** Create a TCP/IP socket for connecting to server and bind it. - */ - my_skt = socket (AF_INET, SOCK_STREAM, 0); - if (my_skt <= 0) { - AsynSrv_errcode = AsynSrv__BAD_SOCKET; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save the errno info */ - fprintf (stderr, "\nAsynSrv_Open/socket: Failed to create a socket.\n"); - return False; - } - lcl_sockname.sin_family = AF_INET; - lcl_sockname.sin_port = htons (0); - lcl_sockname.sin_addr.s_addr = 0; - status = bind (my_skt, (struct sockaddr *) &lcl_sockname, - sizeof (lcl_sockname)); - if (status == -1) { - close (my_skt); - AsynSrv_errcode = AsynSrv__BAD_BIND; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save the errno info */ - fprintf (stderr, "\nAsynSrv_Open/bind: Failed to bind socket.\n"); - return False; - } - /*--------------------------- - ** Set short time-out (VMS systems only) - */ -#ifdef __VMS - oto_len = sizeof (old_time_out); /* Save current time-out first */ - oto_status = getsockopt (my_skt, IPPROTO_TCP, UCX$C_TCP_PROBE_IDLE, - old_time_out, &oto_len); - - if (oto_status == 0) { - time_out.val = AsynSrv_connect_tmo; /* Set new time-out */ - status = setsockopt (my_skt, IPPROTO_TCP, UCX$C_TCP_PROBE_IDLE, - time_out.chars, sizeof (time_out)); - } -#endif - /*--------------------------- - ** Connect to RS-232-C Server. - */ - rmt_sockname_len = sizeof (rmt_sockname); - rmt_sockname.sin_family = AF_INET; - rmt_sockname.sin_port = htons (asyn_info->port); - rmt_sockname.sin_addr.s_addr = rmt_inet_addr_pntr->s_addr; - status = connect (my_skt, (struct sockaddr *) &rmt_sockname, - sizeof (rmt_sockname)); - if (status != 0) { - close (my_skt); - AsynSrv_errcode = AsynSrv__BAD_CONNECT; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save the errno info */ - fprintf (stderr, - "\nAsynSrv_Open/connect: Failed to connect to server.\n"); - perror ("AsynSrv_Open"); - return False; - } - /*--------------------------- - ** Restore time-out (VMS only) - */ -#ifdef __VMS - if (oto_status == 0) { - setsockopt (my_skt, IPPROTO_TCP, UCX$C_TCP_PROBE_IDLE, - old_time_out, oto_len); - } -#endif - /*--------------------------------------------------- - ** Setup the defaults in the AsynSrv__info data structure. - */ - asyn_info->skt = my_skt; /* Return socket number to caller */ - - asyn_info->protocol_code = 0; /* Ensure protocol_code set to "unknown" */ - memcpy (asyn_info->protocol_id, "\0\0\0\0", - sizeof (asyn_info->protocol_id)); - asyn_info->cmnd_hdr_len = 4; - strcpy (asyn_info->cmnd_fmt, "%04d"); - asyn_info->rply_hdr_len = 4; - strcpy (asyn_info->rply_fmt, "%4d"); - - sprintf (buff, "%04d", asyn_info->chan); /* Convert channel # to ASCII */ - memcpy (asyn_info->chan_char, buff, sizeof (asyn_info->chan_char)); - - sprintf (buff, "%04d", AsynSrv_msec_tmo/100); /* Set dflt time-out .. - ** .. (deci-secs) */ - memcpy (asyn_info->tmo, buff, sizeof (asyn_info->tmo)); - - memcpy (asyn_info->eot, AsynSrv_eot, sizeof (asyn_info->eot)); /* Set .. - ** .. dflt terminator(s) */ - asyn_info->max_replies = 0; - asyn_info->n_replies = 0; - /* - ** Send a null command buffer to the server. This should give - ** a "protocol mismatch" error response and from this we can get - ** the actual protocol level supported by the server. - */ - status = AsynSrv_SendCmnds (asyn_info, &s_buff, &r_buff, NULL); - if (!status && (AsynSrv_errcode == AsynSrv__BAD_PROT_LVL)) { - /* - ** As expected, we got a "protocol mismatch" error. - ** Save the server's protocol level for future use. - */ - memcpy (asyn_info->protocol_id, r_buff.s_pcol_lvl, - sizeof (r_buff.s_pcol_lvl)); - if (strncmp (r_buff.s_pcol_lvl, RS__PROTOCOL_ID_V01B, - strlen (RS__PROTOCOL_ID_V01B)) == 0) { - asyn_info->protocol_code = RS__PROTOCOL_CODE_V01B; - asyn_info->cmnd_hdr_len = 4; - strcpy (asyn_info->cmnd_fmt, "%04d"); - asyn_info->rply_hdr_len = 4; - strcpy (asyn_info->rply_fmt, "%4d"); - }else if (strncmp (r_buff.s_pcol_lvl, RS__PROTOCOL_ID, - strlen (RS__PROTOCOL_ID)) == 0) { - asyn_info->protocol_code = RS__PROTOCOL_CODE; - asyn_info->cmnd_hdr_len = 2; - strcpy (asyn_info->cmnd_fmt, "%02d"); - asyn_info->rply_hdr_len = 2; - strcpy (asyn_info->rply_fmt, "%2d"); - }else { - close (my_skt); - asyn_info->skt = 0; - fprintf (stderr, - "\nAsynSrv_Open: Server protocol level is unrecognised.\n" - " Server level is \"%4s\"\n", r_buff.s_pcol_lvl); - return False; - } - }else { - close (my_skt); - asyn_info->skt = 0; - AsynSrv_errcode = AsynSrv__BAD_PROT_LVL; - fprintf (stderr, - "\nAsynSrv_Open: Problem getting protocol level of Server!\n"); - return False; - } - AsynSrv_errcode = AsynSrv_errno = AsynSrv_vaxc_errno = 0; - AsynSrv_call_depth = 0; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_SendCmnds: Send commands to RS232C server. -*/ - int AsynSrv_SendCmnds ( -/* ================= -*/ struct AsynSrv__info *asyn_info, - struct RS__MsgStruct *send_buff, - struct RS__RespStruct *rcve_buff, - ...) { /* Now we have list of commands - - ** char *txt = pntr to cmnd strng - ** Terminate list with *txt = NULL. - */ - int i, status, c_len, size, max_size, ncmnds; - int bytes_to_come, bytes_left; - char *nxt_byte_ptr; - char err_text[80]; - char text[20]; - va_list ap; /* Pointer to variable args */ - char *txt_ptr; - char *cmnd_lst_ptr; - /*---------------------------------------------- - ** Pre-set the routine name (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_SendCmnds"); - AsynSrv_call_depth++; - } - /*---------------------------------------------- - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. The connection may - ** also be marked to have been forcefully closed. - */ - if (asyn_info->skt <= 0) { - memset (rcve_buff->msg_size, - '0', sizeof (rcve_buff->msg_size)); - if ((AsynSrv_errcode == 0) && (asyn_info->skt < 0)) { - AsynSrv_errcode = AsynSrv__FORCED_CLOSED; - } - return False; - } - /*---------------------------------------------- - ** Build message for server from the list of commands. - */ - asyn_info->max_replies = asyn_info->n_replies = 0; - - asyn_info->msg_id++; /* Set up an incrementing message id */ - if (asyn_info->msg_id > 9999) asyn_info->msg_id = 1; - sprintf (send_buff->msg_id, "%04d", asyn_info->msg_id); - - memcpy (send_buff->c_pcol_lvl, asyn_info->protocol_id, - sizeof (send_buff->c_pcol_lvl)); - - memcpy (send_buff->serial_port, asyn_info->chan_char, - sizeof (send_buff->serial_port)); - - memcpy (send_buff->tmo, asyn_info->tmo, sizeof (send_buff->tmo)); - - memcpy (send_buff->terms, asyn_info->eot, sizeof (send_buff->terms)); - - memcpy (send_buff->n_cmnds, "0000", sizeof (send_buff->n_cmnds)); - - va_start (ap, rcve_buff); /* Set up var arg machinery */ - - txt_ptr = va_arg (ap, char *); /* Get pntr to next cmnd string */ - ncmnds = 0; - cmnd_lst_ptr = &send_buff->cmnds[0]; - bytes_left = sizeof (*send_buff) - - OffsetOf (struct RS__MsgStruct, cmnds[0]); - - while (txt_ptr != NULL) { - c_len = strlen (txt_ptr); - size = asyn_info->cmnd_hdr_len + c_len; - if (size > bytes_left) { - AsynSrv_errcode = AsynSrv__BAD_SENDLEN; /* Too much to send */ - fprintf (stderr, "\nAsynSrv_SendCmnds/send: too much to send" - " - request ignored.\n"); - memset (rcve_buff->msg_size, '0', sizeof (rcve_buff->msg_size)); - return False; - }else { - sprintf (cmnd_lst_ptr, asyn_info->cmnd_fmt, c_len); - if (cmnd_lst_ptr[asyn_info->cmnd_hdr_len] != '\0') { - AsynSrv_errcode = AsynSrv__BAD_CMND_LEN; - fprintf (stderr, "\nAsynSrv_SendCmnds/send: command too long -" - " - request ignored.\n"); - memset (rcve_buff->msg_size, '0', sizeof (rcve_buff->msg_size)); - return False; - } - cmnd_lst_ptr += asyn_info->cmnd_hdr_len; - strcpy (cmnd_lst_ptr, txt_ptr); - cmnd_lst_ptr += c_len; - ncmnds++; - bytes_left = bytes_left - size; - txt_ptr = va_arg (ap, char *); - } - } - sprintf (text, "%04d", ncmnds); - memcpy (send_buff->n_cmnds, text, sizeof (send_buff->n_cmnds)); - - size = cmnd_lst_ptr - send_buff->msg_id; - size = (size + 3) & (~3); /* Round up to multiple of 4 */ - sprintf (text, "%04d", size); - memcpy (send_buff->msg_size, text, sizeof (send_buff->msg_size)); - - size += sizeof (send_buff->msg_size); - status = send (asyn_info->skt, - (char *) send_buff, size, 0); - if (status != size) { - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - if (status == 0) { - AsynSrv_errcode = AsynSrv__BAD_SEND; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/send: probable network problem"); - }else if (status == -1) { - if (AsynSrv_errno == EPIPE) { - AsynSrv_errcode = AsynSrv__BAD_SEND_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/send: broken network pipe"); - }else { - AsynSrv_errcode = AsynSrv__BAD_SEND_NET; /* It's some other net problem */ - perror ("AsynSrv_SendCmnds/send"); - } - }else { - AsynSrv_errcode = AsynSrv__BAD_SEND_UNKN; /* TCP/IP problems */ - fprintf (stderr, "\nAsynSrv_SendCmnds/send: probable TCP/IP problem"); - } - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - - size = sizeof (rcve_buff->msg_size); - status = recv (asyn_info->skt, rcve_buff->msg_size, size, 0); - if (status != size) { - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - if (status == 0) { - AsynSrv_errcode = AsynSrv__BAD_RECV; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: probable network problem"); - }else if (status == -1) { - if (AsynSrv_errno == EPIPE) { - AsynSrv_errcode = AsynSrv__BAD_RECV_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: broken network pipe"); - }else { - AsynSrv_errcode = AsynSrv__BAD_RECV_NET; /* It's some other net problem */ - perror ("AsynSrv_SendCmnds/recv"); - } - }else { - AsynSrv_errcode = AsynSrv__BAD_RECV_UNKN; /* TCP/IP problems */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: probable TCP/IP problem"); - } - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - if (sscanf (rcve_buff->msg_size, "%4d", &bytes_to_come) != 1) { - AsynSrv_errcode = AsynSrv__BAD_NOT_BCD; /* Header not an ASCII BCD integer */ - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: non-BCD byte count" - " - link to server force-closed.\n"); - return False; - } - max_size = sizeof (*rcve_buff) - size; - if (bytes_to_come > max_size) { - AsynSrv_errcode = AsynSrv__BAD_RECVLEN; - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: pending message length too big" - " - flushing ...\n"); - nxt_byte_ptr = &rcve_buff->msg_size[size]; - while (bytes_to_come > 0) { /* Flush out the incoming message */ - bytes_left = bytes_to_come; - if (bytes_left > max_size) bytes_left = max_size; - status = recv (asyn_info->skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - AsynSrv_errcode = AsynSrv__BAD_FLUSH; /* TCP/IP problem during flush */ - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: network problem during" - " flush.\nLink to server force-closed.\n"); - return False; - } - bytes_to_come = bytes_to_come - status; - } - fprintf (stderr, "\n flushed OK.\n"); - memset (rcve_buff->msg_size, '0', sizeof (rcve_buff->msg_size)); - return False; - }else { - nxt_byte_ptr = &rcve_buff->msg_size[size]; - bytes_left = bytes_to_come; - while (bytes_left > 0) { /* Read the rest of the response */ - status = recv (asyn_info->skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - if (status == 0) { - AsynSrv_errcode = AsynSrv__BAD_RECV1; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv/1: probable network " - "problem"); - }else { - if (AsynSrv_errno == EPIPE) { - AsynSrv_errcode = AsynSrv__BAD_RECV1_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv/1: broken network pipe"); - }else { - AsynSrv_errcode = AsynSrv__BAD_RECV1_NET; /* It's some other net fault */ - perror ("AsynSrv_SendCmnds/recv/1"); - } - } - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - bytes_left = bytes_left - status; - nxt_byte_ptr = nxt_byte_ptr + status; - } - if (strncmp (asyn_info->protocol_id, rcve_buff->s_pcol_lvl, - sizeof (rcve_buff->s_pcol_lvl)) != 0) { - AsynSrv_errcode = AsynSrv__BAD_PROT_LVL; /* Protocol level is bad */ - return False; - } - if ((sscanf (rcve_buff->n_rply, "%4d", &asyn_info->max_replies) != 1) || - (asyn_info->max_replies < 0)) { - AsynSrv_errcode = AsynSrv__BAD_REPLY; /* Reply is bad */ - if (AsynSrv_call_depth < 5) { /* Add reply to routine stack */ - bytes_to_come = bytes_to_come + 4; - if (bytes_to_come >= sizeof (AsynSrv_routine[0])) - bytes_to_come = sizeof (AsynSrv_routine[0]) - 1; - for (i=0; imsg_size[i] == '\0') - rcve_buff->msg_size[i] = '.'; - } - rcve_buff->msg_size[bytes_to_come] = '\0'; - strcpy (AsynSrv_routine[AsynSrv_call_depth], rcve_buff->msg_size); - AsynSrv_call_depth++; - } - return False; - } - } - AsynSrv_call_depth--; - return True; - } -/*-------------------------------------------- End of AsynSrv_Utility.C -----*/ diff --git a/hardsup/asynsrv_utility.c b/hardsup/asynsrv_utility.c deleted file mode 100644 index 2214adfe..00000000 --- a/hardsup/asynsrv_utility.c +++ /dev/null @@ -1,2121 +0,0 @@ -#define ident "1C06" -#ifdef VAXC -#module AsynSrv_Utility ident -#endif -#ifdef __DECC -#pragma module AsynSrv_Utility ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Department ASQ | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]AsynSrv_Utility.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Mar 1996 -** -** To compile this module, use: - - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]AsynSrv_Utility - - lnsa01::tasmad_disk:[mad.psi.lib.sinq]AsynSrv_Utility + - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @lnsa01::tasmad_disk:[mad.psi.lib.sinq]sinq_olb AsynSrv_Utility debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @lnsa01::tasmad_disk:[mad.psi.lib.sinq]sinq_olb AsynSrv_Utility -** -** Updates: -** 1A01 21-Mar-1996 DM. Initial version. -** 1B01 12-Sep-1996 DM. Allow host name to be in dot format too. -** 1B02 5-May-1997 DM. Set 5 sec time-out on "connect" on VMS systems. -** 1B07 11-Mar-1998 DM. Allow range of msecTmo to be 0 - 999999 (it was -** 100 - 999999). -** 1C01 21-Mar-2000 MZ. Introduced idleHandler -** 1C02 30-Mar-2000 DM. Add trace and flush facilities. -** 1C06 30-Aug-2000 DM. Add AsynSrv_GetLenTerm. -**============================================================================ -** The entry points included in this module are described below. Prototypes -** can be defined via: -** -** #include -** -** AsynSrv_ChanClose - Send a "CLOSE CHAN" request to RS-232-C Server. -** AsynSrv_Close - Close a connection to an RS-232-C Server. -** AsynSrv_Config - Configure an open AsynSrv_Utility connection. -** AsynSrv_ConfigDflt - Set defaults for AsynSrv_Open. -** AsynSrv_ErrInfo - Return detailed status from last operation. -** AsynSrv_Flush - Send a "FLUSH" request to an RS-232-C Server. -** AsynSrv_GetLenTerm - Get length and terminator of a reply. -** AsynSrv_GetReply - Get next reply from a reply buffer. -** AsynSrv_Open - Open a connection to an RS-232-C Server. -** AsynSrv_OpenNew - Same as AsynSrv_Open but forces the opening -** of a new socket. -** AsynSrv_SendCmnds - Send commands to a channel of an RS-232-C Server. -** AsynSrv_SendCmndsBig - Similar to AsynSrv_SendCmnds but with user -** defined buffer sizes. -** AsynSrv_Trace - Send a "TRACE ON" or "TRACE OFF" request to -** an RS-232-C Server. -** AsynSrv_Trace_Write - Send a "TRACE WRITE" request to RS-232-C Server. -** Other entry points which are private (i.e. not in ): -** AsynSrv_SendSpecCmnd - Send a "special" command to an RS-232-C Server. -**--------------------------------------------------------------------- -** int AsynSrv_ChanClose (&asyn_info) -** ----------------- -** Input Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It contains settings required -** for setting up and sending send_buff. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and errcode (see -** AsynSrv_ErrInfo) is set to indicate the nature of the problem. -** See AsynSrv_SendSpecCmnd for possible error codes. -** Routines called: -** AsynSrv_SendSpecCmnd -** Description: -** AsynSrv_SendSpecCmnd is called to send the 4-byte "special" -** command "-006" to the server to cause it to close its serial ports. -**--------------------------------------------------------------------- -** int AsynSrv_Close (&asyn_info, force_flag) -** ------------- -** Input Args: -** int force_flag - if non-zero, all connections using the same socket -** will also be marked as force-closed (socket number -** set to -1) and the connection will really be -** closed. This is needed for error recovery operations. -** Output Args: -** none -** Modified Args: -** struct AsynSrv__info *asyn_info - a structure holding skt, host and -** port of the connection. On return -* skt = 0. -** Return status: -** True if no problems detected, otherwise False and AsynSrv_errcode -** is set to indicate the nature of the problem as follows: -** ASYNSRV__BAD_PAR --> skt does not match with host/port. -** Routines called: -** Socket library, "close". -** Description: -** The routine decrements the usage count on the connection to host/port. -** If the counter is still >0, the routine simply returns. -** If the counter is now 0, the routine sends a "-001" message to the -** server to inform it that we are about to close the link, waits for a -** possible 4 bytes of response and then closes the TCP/IP connection. -**--------------------------------------------------------------------- -** int AsynSrv_Config (&asyn_info, &par_id, par_val, ...) -** -------------- -** Input Args: -** char* par_id - Text string identifying the next argument (see below). -** NULL indicates the end of the argument list. -** par_val - The value to set for the argument. The type of the -** argument can depend on par_id. -** Output Args: -** none -** Modified Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It is used to hold the config -** info for the connection. -** Return status: -** True if no problems detected, otherwise False and AsynSrv_errcode -** is set to indicate the nature of the problem as follows: -** ASYNSRV__BAD_PAR --> Unrecognised par_id or msecTmo < 0 or -** msecTmo > 999'999 or bad eot or .. -** Routines called: -** None -** Description: -** AsynSrv_Config may be used for setting values of parameters for -** use in subsequent calls to AsynSrv_SendCmnds. Defaults for these -** parameters are set via a call to AsynSrv_ConfigDflt, prior to -** calling AsynSrv_Open. Values which may be taken by par_id (warning -- -** par_id is case-sensitive) and the corresponding variable type of -** par_val are: -** -** "msecTmo" int The time-out response for commands sent -** to a serial channel on the server. The -** valid range is 0 to 999'999. -** "eot" char* The expected terminators in responses to -** commands sent to a serial channel on the -** server. The first character specifies the -** number of terminators (max=3). -** "idleHdl" void (*hdl) (int msecTmo, int socket) MZ. -** A handler which is called in AsynSrv_SendCmds -** before receiving the response. The handler -** should contain a call to "select ()" and return -** on a read event on the socket passed as -** argument, or after the timeout specified -** has expired. -**--------------------------------------------------------------------- -** int AsynSrv_ConfigDflt (&par_id, par_val, ...) -** ------------------ -** Input Args: -** char* par_id - Text string identifying the next argument (see below). -** NULL indicates the end of the argument list. -** par_val - The value to set for the argument. The type of the -** argument can depend on par_id. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and AsynSrv_errcode -** is set to indicate the nature of the problem as follows: -** ASYNSRV__BAD_PAR --> Unrecognised par_id or msecTmo < 0 or -** msecTmo > 999'999 or bad eot or .. -** Routines called: -** None -** Description: -** AsynSrv_ConfigDflt may be used for setting default values of parameters -** for use in subsequent calls to AsynSrv_Open. Values which may be taken -** by par_id (warning -- par_id is case-sensitive) and the corresponding -** variable type of par_val are: -** -** "TmoC" int The time-out in seconds to be used when -** opening a connection to a server. This -** value is only effective on VMS systems. For -** UNIX systems, the systemwide default (usually -** 75 secs) cannot be changed. The initial -** setting for "TmoC" is 5 secs. -** "msecTmo" int The time-out response for commands sent -** to a serial channel on the server. The -** valid range is 0 to 999'999. The initial -** setting for "msecTmo" is 10'000 msec. -** "eot" char* The expected terminators in responses to -** commands sent to a serial channel on the -** server. The first character specifies the -** number of terminators (max=3). The initial -** setting for "eot" is "1\r". -**------------------------------------------------------------------------- -** void AsynSrv_ErrInfo (&entry_txt_ptr, &errcode, &my_errno, &vaxc_errno) -** --------------- -** Input Args: -** None -** Output Args: -** char **entry_txt_ptr - Pointer to a text string giving the call stack -** at the time that the error was detected. -** int *errcode - An internal error code indicating the detected error. -** int *my_errno - Saved value of errno. -** int *vaxc_errno - Saved value of vaxc$errno (OpenVMS only). -** Modified Args: -** none -** Return status: -** none -** Routines called: -** none -** Description: -** Returns detailed status of the last operation. Once an error has been -** detected, the error status is frozen until this routine has been called. -**------------------------------------------------------------------------- -** int AsynSrv_Flush (&asyn_info) -** ------------- -** Input Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It contains settings required -** for setting up and sending send_buff. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** Same as AsynSrv_ChanClose -** Routines called: -** Same as AsynSrv_ChanClose -** Description: -** AsynSrv_SendSpecCmnd is called to send the 4-byte "special" -** command "-004" to the server to cause it to close its serial ports. -**------------------------------------------------------------------------- -** int AsynSrv_GetLenTerm (&asyn_info, &rcve_buff, &rply, *len, &term) -** ------------------ -** Input Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It is used to hold status info -** between calls to this routine. -** struct RS__RespStruct *rcve_buff - address of receive buffer used -** in last call to AsynSrv_SendCmnds. -** char *rply - address of a reply in rcve_buff as -** returned by AsynSrv_GetReply. -** Output Args: -** int *len - address of location to receive the -** length of the reply. -** char *term - address of location to receive the -** terminator of the reply. -** Modified Args: -** none -** Return status: -** True if everything seems to be OK. Otherwise, False. -** Routines called: -** none -** Description: -** AsynSrv_GetLenTerm simply converts the length of the reply as saved -** in rply[-hdr_size-1] from ASCII to binary, subtracts 2 from it (to -** allow for the terminator byte and the null termination character) and -** returns it to the caller. *term is set to the value of the character -** at location rply[-1]. -**------------------------------------------------------------------------- -** char *AsynSrv_GetReply (&asyn_info, &rcve_buff, &last_rply) -** ---------------- -** Input Args: -** struct RS__RespStruct *rcve_buff - address of receive buffer used -** in last call to AsynSrv_SendCmnds. -** char *last_rply - Address of last reply processed -** or NULL. -** Output Args: -** none -** Modified Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It is used to hold status info -** between calls to this routine. -** Return status: -** Address of next reply in the buffer or NULL if no more. Note that this -** is a pointer to the reply and not to the head of the reply structure. -** The terminator byte found is therefore at index [-1] from this address. -** Routines called: -** none -** Description: -** AsynSrv_GetReply unpacks the replies in the response packet from the -** RS232C server which is an argument in the call to AsynSrv_SendCmnds. -** If the routine is called with last_rply = NULL, a pointer to the -** first reply is returned. On calling AsynSrv_GetReply again with -** last_rply set to this address, one receives the address of the second -** reply and so on, until NULL is returned, indicating that all responses -** have been exhausted. -** Warning: -** AsynSrv_GetReply keeps count of the number of responses it returns. -** Responses must therefore be processed in order. -**------------------------------------------------------------------------- -** int AsynSrv_Open (&asyn_info) -** ------------ -** Input Args: -** struct AsynSrv__info *asyn_info -** asyn_info->host - Name of host offering the RS-232-C service. The name -** can be either symbolic or numeric, e.g. -** "lnsw02.psi.ch" or "129.129.90.18". -** asyn_info->port - Number of TCP/IP port of TCP/IP server. -** asyn_info->chan - Number of RS-232-C channel to be used. -** Output Args: -** none -** Modified Args: -** struct AsynSrv__info *asyn_info - a structure holding skt, host and -** port of the connection. On return -** skt = socket number of connection. -** Set to 0 if error. -** Return status: -** If non-zero, no problems detected and asyn_info->skt is the socket to -** use for communicating with the server. Otherwise, a problem -** was detected and AsynSrv_errcode may be set as follows -** to indicate the nature of the problem: -** ASYNSRV__BAD_HOST --> Call to "gethostbyname" failed to get -** network addr of host. -** ASYNSRV__BAD_SOCKET --> Call to "socket" failed. -** ASYNSRV__BAD_BIND --> Call to "bind" failed. -** ASYNSRV__BAD_CONNECT --> Call to "connect" failed. -** ASYNSRV__BAD_PAR --> Bad parameter found. Probably -** asyn_info->port or asyn_info->chan -** are out of range. -** BAD_PROT_LVL --> Server protocol level is not valid. -** ASYNSRV__NO_ROOM --> Host/port table full or Active-link -** table full. -** Routines called: -** Socket library routine "open". -** Description: -** The routine maintains a list of hosts/ports to which it has open -** sockets. If an entry is found in the list, the socket is returned -** and the usage count of this connection is incremented. If no entry -** is found in the list, a connection to the host is established and -** entered into the list. -** The routine also maintains a table of active links so that the -** "force-close" function can be performed. The link is added to this -** table too. -**------------------------------------------------------------------------- -** int AsynSrv_OpenNew (&asyn_info) -** --------------- -** Input Args: -** struct AsynSrv__info *asyn_info -** asyn_info->host - Name of host offering the RS-232-C service. The name -** can be either symbolic or numeric, e.g. -** "lnsw02.psi.ch" or "129.129.90.18". -** asyn_info->port - Number of TCP/IP port of TCP/IP server. -** asyn_info->chan - Number of RS-232-C channel to be used. -** Output Args: -** none -** Modified Args: -** struct AsynSrv__info *asyn_info - a structure holding skt, host and -** port of the connection. On return -** skt = socket number of connection. -** Set to 0 if error. -** Return status: -** See AsynSrv_Open -** Routines called: -** See AsynSrv_Open -** Description: -** This routine is the same as AsynSrv_Open but forces the opening -** of a new socket. The socket will be marked to ensure that no other -** connections share this connection. -**------------------------------------------------------------------------- -** int AsynSrv_SendCmnds (&asyn_info, &send_buff, &rcve_buff, ...) -** ----------------- -** Input Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It contains settings required -** for setting up and sending send_buff. -** char * ... - A list of commands, terminated by NULL, for -** sending to the channel on the server. The commands -** must have any necessary \r characters included. -** Output Args: -** struct RS__RespStruct *rcve_buff - a buffer to receive the response -** from the server. -** Modified Args: -** struct RS__MsgStruct *send_buff - a buffer for holding the commands -** for sending to the server. -** Return status: -** True if no problems detected, otherwise False and errcode (see -** AsynSrv_ErrInfo) is set to indicate the nature of the problem. -** AsynSrv_errcode may be set as follows: -** ASYNSRV__BAD_SEND_LEN --> Too much to send; either too many -** commands or too long. The buffer -** is 232 bytes long and each command -** has a 2-byte header. -** ASYNSRV__BAD_CMND_LEN --> A command is too long - it's length cannot -** be encoded into the command header field -** The next 4 errors are related to network errors whilst sending the -** message buffer to the server: -** ASYNSRV__BAD_SEND --> Network problem - server has -** probably abended. -** ASYNSRV__BAD_SEND_PIPE --> Network pipe broken - probably same -** cause as ASYNSRV__BAD_SEND. -** ASYNSRV__BAD_SEND_NET --> Some other network problem. "errno" -** may be helpful. -** ASYNSRV__BAD_SEND_UNKN --> Some other network problem happened -** resulting in the message not -** getting sent completely. "errno" is -** probably not helpful in this case. -** ASYNSRV__BAD_RECV \ These are network errors whilst -** ASYNSRV__BAD_RECV_PIPE > receiving the 4-byte response header. -** ASYNSRV__BAD_RECV_NET / They are analogous to ASYNSRV__BAD_SEND -** ASYNSRV__BAD_RECV_UNKN / ... ASYNSRV__BAD_SEND_UNKN. -** ASYNSRV__BAD_NOT_BCD --> The 4-byte response header is not an -** ASCII coded decimal integer. -** ASYNSRV__BAD_RECV_LEN --> The body of the response would be too -** big to fit in the input buffer. The -** buffer is ??? bytes long and each -** response has a 5-byte header and a -** trailing zero-byte. The response -** is flushed. -** ASYNSRV__BAD_FLUSH --> Some network error was detected -** during flushing. This is an "or" -** of errors ASYNSRV__BAD_RECV to -** ASYNSRV__BAD_RECV_UNKN. -** ASYNSRV__FORCED_CLOSED --> The connection to the channel has been -** forcefully closed. See below. -** ASYNSRV__BAD_REPLY --> The n_rply field of the response was -** either non-numeric or <0, indicating -** that the Terminal Server detected an -** error. The reply is added to the -** routine call stack for debug purposes. -** -** ASYNSRV__BAD_RECV1 \ These are network errors whilst receiving -** ASYNSRV__BAD_RECV1_PIPE > the body of the response. They are -** ASYNSRV__BAD_RECV1_NET / equivalent to ASYNSRV__BAD_RECV, -** ASYNSRV__BAD_RECV_PIPE and -** ASYNSRV__BAD_RECV_NET. -** ASYNSRV__FORCED_CLOSED occurs if AsynSrv_Close has been called -** for another device on the same server and the 'force_flag' -** was set (see AsynSrv_Close). The caller should call -** AsynSrv_Close and then AsynSrv_Open to re-establish a -** connection to the server. -** Routines called: -** Socket library routines send and recv. -** Description: -** The list of commands is assembled into a message buffer with appropriate -** header information and sent off to the server. The response is then -** awaited and read in when it arrives. -** -** For any of the following errors: -** ASYNSRV__BAD_SEND (Note: ASYNSRV__BAD_SEND_LEN and -** ASYNSRV__BAD_SEND_PIPE ASYNSRV__BAD_RECV_LEN and -** ASYNSRV__BAD_SEND_NET ASYNSRV__BAD_REPLY -** ASYNSRV__BAD_SEND_UNKN do not cause a close) -** ASYNSRV__BAD_RECV -** ASYNSRV__BAD_RECV_PIPE -** ASYNSRV__BAD_RECV_NET -** ASYNSRV__BAD_RECV_UNKN -** ASYNSRV__BAD_NOT_BCD -** ASYNSRV__BAD_FLUSH -** ASYNSRV__BAD_RECV1 -** ASYNSRV__BAD_RECV1_PIPE -** ASYNSRV__BAD_RECV1_NET -** the network link to the server is force-closed via a call to -** AsynSrv_Close. Once the error has been corrected, the link can be -** re-opened via a call to AsynSrv_Open. As a result of the force-close, -** other active handles will need to be released via a call to -** AsynSrv_Close before AsynSrv_Open is called. -**------------------------------------------------------------------------- -** int AsynSrv_SendCmndsBig (&asyn_info, &send_buff, send_buff_size, -** -------------------- &rcve_buff, rcve_buff_size, ...) -** Input Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It contains settings required -** for setting up and sending send_buff. -** int send_buff_size - The size of *send_buff in bytes. -** int rcve_buff_size - The size of *rcve_buff in bytes. -** int *c_len \ - a list of argument pairs specifying the commands -** char *cmd > to be sent. The list is terminated by -** ... / c_len == NULL. If *c_len > 0, it specifies the -** number of bytes in the command. Otherwise, *cmd -** is assumed to be a zero-terminated string. -** The *cmd string must include any terminator -** byte(s) but, if *c_len > 0, it does not need to -** be zero-terminated. -** Output Args: -** struct RS__RespStruct *rcve_buff - a buffer to receive the response -** from the server. Note that this structure must -** be extended to size rcve_buff_size by the use -** of suitable unions. -** Modified Args: -** struct RS__MsgStruct *send_buff - a buffer for holding the commands -** for sending to the server. Note that this -** structure must be extended to size -** send_buff_size by the use of suitable unions. -** Return status: -** Same as AsynSrv_SendCmnds with the addition of error code: -** ASYNSRV__BAD_SEND_PAR --> Either send_buff_size or rcve_buff_size -** is less than 64. -** Routines called: -** Socket library routines send and recv. -** Description: -** The procedure is similar to AsynSrv_SendCmnds except that the commands -** are specified by a pair of arguments (to allow for the binary -** transmission of zeros) and the send and receive structures are assumed -** to have been extended to the sizes specified by suitable declarations -** in the calling module. -**------------------------------------------------------------------------- -** int AsynSrv_SendSpecCmnd (&asyn_info, &cmnd) -** ------------------- -** Input Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It contains settings required -** for setting up and sending send_buff. -** char *cmnd - the 4-byte special command to be sent. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and errcode (see -** AsynSrv_ErrInfo) is set to indicate the nature of the problem. -** AsynSrv_errcode may be set as follows: -** The next 4 errors are related to network errors whilst sending the -** 4-byte message buffer to the server: -** ASYNSRV__BAD_SEND --> Network problem - server has -** probably abended. -** ASYNSRV__BAD_SEND_PIPE --> Network pipe broken - probably same -** cause as ASYNSRV__BAD_SEND. -** ASYNSRV__BAD_SEND_NET --> Some other network problem. "errno" -** may be helpful. -** ASYNSRV__BAD_SEND_UNKN --> Some other network problem happened -** resulting in the message not -** getting sent completely. "errno" is -** probably not helpful in this case. -** ASYNSRV__BAD_RECV \ These are network errors whilst -** ASYNSRV__BAD_RECV_PIPE > receiving the 4-byte response. -** ASYNSRV__BAD_RECV_NET / They are analogous to ASYNSRV__BAD_SEND -** ASYNSRV__BAD_RECV_UNKN / ... ASYNSRV__BAD_SEND_UNKN. -** ASYNSRV__BAD_NOT_BCD --> The 4-byte response header is not an -** echo of the 4 bytes which were sent. -** ASYNSRV__FORCED_CLOSED --> The connection to the channel has been -** forcefully closed. See below. -** ASYNSRV__FORCED_CLOSED occurs if AsynSrv_Close has been called -** for another device on the same server and the 'force_flag' -** was set (see AsynSrv_Close). The caller should call -** AsynSrv_Close and then AsynSrv_Open to re-establish a -** connection to the server. -** Routines called: -** Socket library routines send and recv. -** Description: -** AsynSrv_SendSpecCmnd sends the 4-byte "special" command, cmnd, to the -** server and reads the response. The response should be an echo of the -** command which was sent. -** Note: -** For any of the following errors: -** ASYNSRV__BAD_SEND -** ASYNSRV__BAD_SEND_PIPE -** ASYNSRV__BAD_SEND_NET -** ASYNSRV__BAD_SEND_UNKN -** ASYNSRV__BAD_RECV -** ASYNSRV__BAD_RECV_PIPE -** ASYNSRV__BAD_RECV_NET -** ASYNSRV__BAD_RECV_UNKN -** ASYNSRV__BAD_NOT_BCD -** the network link to the server is force-closed via a call to -** AsynSrv_Close. Once the error has been corrected, the link can be -** re-opened via a call to AsynSrv_Open. As a result of the force-close, -** other active handles will need to be released via a call to -** AsynSrv_Close before AsynSrv_Open is called. -**------------------------------------------------------------------------- -** int AsynSrv_Trace (&asyn_info, state) -** ------------- -** Input Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It contains settings required -** for setting up and sending send_buff. -** int state - True/False to turn tracing on/off. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** Same as AsynSrv_ChanClose -** Routines called: -** Same as AsynSrv_ChanClose -** Description: -** AsynSrv_SendSpecCmnd is called to send a 4-byte "special" command -** to the server. The command is "-002" to turn on tracing and "-003" -** to turn off tracing. - -** Description: -** To turn on tracing, the 4-byte message "-002" is sent to the server. -** To turn off tracing, the 4-byte message "-003" is sent to the server. -** The server is expected to respond by echoing the message. -** -**------------------------------------------------------------------------- -** int AsynSrv_Trace_Write (&asyn_info) -** ------------------- -** Input Args: -** struct AsynSrv__info *asyn_info - the structure used in the call to -** AsynSrv_Open. It contains settings required -** for setting up and sending send_buff. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** Same as AsynSrv_ChanClose -** Routines called: -** Same as AsynSrv_ChanClose -** Description: -** AsynSrv_SendSpecCmnd is called to send the 4-byte "special" -** command "-005" to the server to cause it to write its trace -** buffer to disk. -**============================================================================*/ -/* -**--------------------------------------------------------------------------- -** Global Definitions -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include - -#ifdef __VMS -#pragma nostandard /* The "$" characters in ucx$inetdef.h give trouble! */ -#include -#include -#else -#include -#endif -/*-----------------------------------------------------------------*/ -#include -#include -#include - -#define True 1 -#define False 0 - -#define MAX_OPEN 64 - - int AsynSrv_SendSpecCmnd ( /* A prototype for a local routine */ - struct AsynSrv__info *asyn_info, - char *cmnd); -/*-------------------------------------------------------------------------- -** Global Variables -*/ - static int AsynSrv_call_depth = 0; - static char AsynSrv_routine[5][64]; - static int AsynSrv_errcode = 0; - static int AsynSrv_errno, AsynSrv_vaxc_errno; - static int AsynSrv_connect_tmo = 5; /* Time-out on "connect" */ - static int AsynSrv_msec_tmo = 10000; /* Time-out for responses */ - static char AsynSrv_eot[] = {'1', '\r', '\0','\0'}; /* Terminators */ -/* -** The following is the list of open connections (= number of -** active sockets). -*/ - static int AsynSrv_n_cnct = 0; - static struct AsynSrv_HostPortSkt AsynSrv_HPS_list[AsynSrv_MAX_LINK]; -/* -** The following is the list of active calls to AsynSrv_Open. -*/ - static int AsynSrv_n_active = 0; - static struct AsynSrv__info *AsynSrv_active[MAX_OPEN]; -/* -**--------------------------------------------------------------------------- -** AsynSrv_ChanClose: Send a "CLOSE CHAN" request to -** RS232C server. -*/ - int AsynSrv_ChanClose ( -/* ================= -*/ struct AsynSrv__info *asyn_info) { - - int status; - char cmnd[8], rply[8]; - /*---------------------------------------------- - ** Pre-set the routine name (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_ChanClose"); - AsynSrv_call_depth++; - } - /*---------------------------------------------- - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. The connection may - ** also be marked to have been forcefully closed. - */ - if (asyn_info->skt <= 0) { - if ((AsynSrv_errcode == 0) && (asyn_info->skt < 0)) { - AsynSrv_errcode = ASYNSRV__FORCED_CLOSED; - } - return False; - } - /*---------------------------------------------- - ** Send message and get reply. - */ - status = AsynSrv_SendSpecCmnd (asyn_info, "-006"); - - if (AsynSrv_errcode == 0) AsynSrv_call_depth--; - return status; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_Close: Close a connection to an RS-232-C server. -*/ - int AsynSrv_Close ( -/* ============= -*/ struct AsynSrv__info *asyn_info, - int force_flag) { - - int i, j, k, my_skt; - char buff[4]; - /*----------------------------------------------- - */ - if (asyn_info == NULL) return True; /* Just return if nothing to do! */ - my_skt = asyn_info->skt; - if (my_skt <= 0) return True; /* Just return if nothing to do! */ - /*----------------------------------------------- - ** Pre-set the routinename (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_Close"); - AsynSrv_call_depth++; - } - /*------------------------------------------------------ - ** Start by finding the table entry for this connection - */ - for (i = 0; i < AsynSrv_n_cnct; i++) { - if (AsynSrv_HPS_list[i].skt != my_skt) continue; - if (AsynSrv_HPS_list[i].port != asyn_info->port) continue; - if (strcmp (AsynSrv_HPS_list[i].host, asyn_info->host) == 0) break; - } - if (i >= AsynSrv_n_cnct) { /* Did we find the entry? */ - AsynSrv_errcode = ASYNSRV__BAD_PAR; /* No! */ - return False; - } - /*------------------------------------------------------ - ** Now find the table entry for the AsynSrvOpen call. - */ - for (j = 0; j < AsynSrv_n_active; j++) { - if ((AsynSrv_active[j] == asyn_info) && - (AsynSrv_active[j]->skt == my_skt)) { - break; - } - } - if (j >= AsynSrv_n_active) { /* Did we find the entry? */ - AsynSrv_errcode = ASYNSRV__BAD_PAR; /* No! */ - return False; - } - /*------------------------------------------------------ - ** i is the index for the connection table entry. - ** j is the index for the caller's AsynSrvOpen call entry. - */ - if (AsynSrv_HPS_list[i].usage_cnt <= 0) { /* Is the connection active? */ - AsynSrv_errcode = ASYNSRV__BAD_PAR; /* No */ - return False; - } - /*------------------------------------------------------ - ** For the caller, simply set his socket number to zero, - ** mark the AsynSrvOpen entry as free and decrease the - ** usage count (the entries will be compressed later). - */ - AsynSrv_active[j]->skt = 0; /* Mark the close .. */ - AsynSrv_active[j] = NULL; /* .. and flag entry to be removed. */ - AsynSrv_HPS_list[i].usage_cnt--; /* Decrease usage count */ - /*------------------------------------------------------ - ** If this is a force-close, go through all AsynSrv_Open - ** entries looking for a socket match, mark them as - ** free and decrease usage count. - */ - if (force_flag != 0) { - for (k = 0; k < AsynSrv_n_active; k++) { - if (AsynSrv_active[k] != NULL) { - if (AsynSrv_active[k]->skt == my_skt) { - AsynSrv_active[k]->skt = -1; /* Mark the force-close */ - AsynSrv_active[k] = NULL; /* Mark entry to be removed */ - AsynSrv_HPS_list[i].usage_cnt--; /* Decrease usage count */ - } - } - } - if (AsynSrv_HPS_list[i].usage_cnt != 0) { /* Use count should now be .. */ - AsynSrv_errcode = ASYNSRV__BAD_PAR; /* .. zero or there's a bug. */ - return False; - } - } - /*------------------------------------------------------ - ** Compress the list of AsynSrv_Open entries - */ - j = 0; - for (k = 0; k < AsynSrv_n_active; k++) { - if (AsynSrv_active[k] != NULL) { - AsynSrv_active[j] = AsynSrv_active[k]; - j++; - } - } - for (k = j; k < AsynSrv_n_active; k++) AsynSrv_active[k] = NULL; - AsynSrv_n_active = j; - /*------------------------------------------------------ - ** If the link is now idle, really close it and compress - ** the connection table entry out of the list. - */ - if (AsynSrv_HPS_list[i].usage_cnt == 0) { - send (my_skt, "-001", 4, 0); /* Tell the TCP/IP server that .. - ** .. we are about to quit. - */ - recv (my_skt, buff, sizeof (buff), 0); /* And wait for his ack */ - close (my_skt); - for (j = i; j < AsynSrv_n_cnct; j++) { - memcpy ((char *) &AsynSrv_HPS_list[j], (char *) &AsynSrv_HPS_list[j+1], - sizeof (AsynSrv_HPS_list[0])); - } - AsynSrv_HPS_list[AsynSrv_n_cnct].skt = 0; /* Invalidate the free entry */ - AsynSrv_n_cnct--; - } - if (AsynSrv_errcode == 0) AsynSrv_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_Config: Configure an open connection. -*/ - int AsynSrv_Config ( -/* ============== -*/ struct AsynSrv__info *asyn_info, - ...) { - - char buff[16], my_eot[4]; - va_list ap; /* Pointer to variable args */ - char *txt_ptr; - int intval; - typedef void (*IdleHandler)(int,int); - /* - ** Pre-set the routinename (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_Config"); - AsynSrv_call_depth++; - } - - va_start (ap, asyn_info); /* Set up var arg machinery */ - txt_ptr = va_arg (ap, char *); /* Get pntr to first parameter ident */ - while (txt_ptr != NULL) { - if (strcmp (txt_ptr, "msecTmo") == 0) { - intval = va_arg (ap, int); - if ((intval < 0) || (intval > 999999)) { - AsynSrv_errcode = ASYNSRV__BAD_PAR; - return False; - } - sprintf (buff, "%04d", intval/100); /* Convert to ASCII as .. - ** .. deci-secs */ - memcpy (asyn_info->tmo, buff, 4); - }else if (strcmp (txt_ptr, "eot") == 0) { - txt_ptr = va_arg (ap, char *); - if (txt_ptr == NULL) { - AsynSrv_errcode = ASYNSRV__BAD_PAR; - return False; - } - memcpy (my_eot, "\0\0\0\0", 4); - switch (txt_ptr[0]) { - case '3': my_eot[3] = txt_ptr[3]; - case '2': my_eot[2] = txt_ptr[2]; - case '1': my_eot[1] = txt_ptr[1]; - case '0': - my_eot[0] = txt_ptr[0]; - break; - default: - AsynSrv_errcode = ASYNSRV__BAD_PAR; - return False; - } - memcpy (asyn_info->eot, my_eot, 4); - }else if (strcmp (txt_ptr, "idleHdl") == 0) { /* MZ. */ - asyn_info->idleHandler = va_arg (ap, IdleHandler); - }else { - AsynSrv_errcode = ASYNSRV__BAD_PAR; - return False; - } - txt_ptr = va_arg (ap, char *); /* Get pntr to next parameter ident */ - } - - if (AsynSrv_errcode == 0) AsynSrv_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_ConfigDflt: Set default values in AsynSrv_Utility -** which will be used to initialise -** structures in AsynSrv_Open. -*/ - int AsynSrv_ConfigDflt ( -/* ================== -*/ char *par_id, - ...) { - int i; - char buff[4]; - va_list ap; /* Pointer to variable args */ - char *txt_ptr; - int intval; - /* - ** Pre-set the routinename (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_ConfigDflt"); - AsynSrv_call_depth++; - } - - va_start (ap, par_id); /* Set up var arg machinery */ - txt_ptr = par_id; /* Point to first arg */ - while (txt_ptr != NULL) { - if (strcmp (txt_ptr, "tmoC") == 0) { - intval = va_arg (ap, int); - if ((intval < 1) || (intval > 3600)) { - AsynSrv_errcode = ASYNSRV__BAD_PAR; - return False; - } - AsynSrv_connect_tmo = intval; - }else if (strcmp (txt_ptr, "msecTmo") == 0) { - intval = va_arg (ap, int); - if ((intval < 0) || (intval > 999999)) { - AsynSrv_errcode = ASYNSRV__BAD_PAR; - return False; - } - AsynSrv_msec_tmo = intval; - }else if (strcmp (txt_ptr, "eot") == 0) { - txt_ptr = va_arg (ap, char *); - if (txt_ptr == NULL) { - AsynSrv_errcode = ASYNSRV__BAD_PAR; - return False; - } - switch (txt_ptr[0]) { - case '3': AsynSrv_eot[3] = txt_ptr[3]; - case '2': AsynSrv_eot[2] = txt_ptr[2]; - case '1': AsynSrv_eot[1] = txt_ptr[1]; - case '0': - AsynSrv_eot[0] = txt_ptr[0]; - break; - default: - AsynSrv_errcode = ASYNSRV__BAD_PAR; - return False; - } - switch (txt_ptr[0]) { - case '0': AsynSrv_eot[1] = '\0'; - case '1': AsynSrv_eot[2] = '\0'; - case '2': AsynSrv_eot[3] = '\0'; - } - }else { - AsynSrv_errcode = ASYNSRV__BAD_PAR; - return False; - } - txt_ptr = va_arg (ap, char *); /* Get pntr to next parameter ident */ - } - - if (AsynSrv_errcode == 0) AsynSrv_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_ErrInfo: Return detailed status from last operation. -*/ - void AsynSrv_ErrInfo ( -/* =============== -*/ char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno) { - - int i, j, k; - char buff[80]; - - if (AsynSrv_call_depth <= 0) { - strcpy (AsynSrv_routine[0], "AsynSrv_no_error_detected"); - *errcode = 0; - *my_errno = 0; - *vaxc_errno = 0; - }else { - if (AsynSrv_call_depth > 1) { /* Concatenate the names */ - for (i = 1; i < AsynSrv_call_depth; i++) { - strcat (AsynSrv_routine[0], "/"); - StrJoin (AsynSrv_routine[0], sizeof (AsynSrv_routine), - AsynSrv_routine[0], AsynSrv_routine[i]); - } - } - *errcode = AsynSrv_errcode; - *my_errno = AsynSrv_errno; - *vaxc_errno = AsynSrv_vaxc_errno; - switch (AsynSrv_errcode) { - case ASYNSRV__BAD_BIND: strcpy (buff, "/ASYNSRV__BAD_BIND"); break; - case ASYNSRV__BAD_CMND_LEN: strcpy (buff, "/ASYNSRV__BAD_CMND_LEN"); break; - case ASYNSRV__BAD_CONNECT: strcpy (buff, "/ASYNSRV__BAD_CONNECT"); break; - case ASYNSRV__BAD_FLUSH: strcpy (buff, "/ASYNSRV__BAD_FLUSH"); break; - case ASYNSRV__BAD_HOST: strcpy (buff, "/ASYNSRV__BAD_HOST"); break; - case ASYNSRV__BAD_NOT_BCD: strcpy (buff, "/ASYNSRV__BAD_NOT_BCD"); break; - case ASYNSRV__BAD_PAR: strcpy (buff, "/ASYNSRV__BAD_PAR"); break; - case ASYNSRV__BAD_PROT_LVL: strcpy (buff, "/ASYNSRV__BAD_PROT_LVL"); break; - case ASYNSRV__BAD_RECV: strcpy (buff, "/ASYNSRV__BAD_RECV"); break; - case ASYNSRV__BAD_RECV_LEN: strcpy (buff, "/ASYNSRV__BAD_RECV_LEN"); break; - case ASYNSRV__BAD_RECV_NET: strcpy (buff, "/ASYNSRV__BAD_RECV_NET"); break; - case ASYNSRV__BAD_RECV_PIPE: strcpy (buff, "/ASYNSRV__BAD_RECV_PIPE"); break; - case ASYNSRV__BAD_RECV_UNKN: strcpy (buff, "/ASYNSRV__BAD_RECV_UNKN"); break; - case ASYNSRV__BAD_RECV1: strcpy (buff, "/ASYNSRV__BAD_RECV1"); break; - case ASYNSRV__BAD_RECV1_NET: strcpy (buff, "/ASYNSRV__BAD_RECV1_NET"); break; - case ASYNSRV__BAD_RECV1_PIPE:strcpy (buff, "/ASYNSRV__BAD_RECV1_PIPE"); break; - case ASYNSRV__BAD_REPLY: strcpy (buff, "/ASYNSRV__BAD_REPLY"); break; - case ASYNSRV__BAD_SEND: strcpy (buff, "/ASYNSRV__BAD_SEND"); break; - case ASYNSRV__BAD_SEND_LEN: strcpy (buff, "/ASYNSRV__BAD_SEND_LEN"); break; - case ASYNSRV__BAD_SEND_NET: strcpy (buff, "/ASYNSRV__BAD_SEND_NET"); break; - case ASYNSRV__BAD_SEND_PIPE: strcpy (buff, "/ASYNSRV__BAD_SEND_PIPE"); break; - case ASYNSRV__BAD_SEND_UNKN: strcpy (buff, "/ASYNSRV__BAD_SEND_UNKN"); break; - case ASYNSRV__BAD_SOCKET: strcpy (buff, "/ASYNSRV__BAD_SOCKET"); break; - case ASYNSRV__FORCED_CLOSED: strcpy (buff, "/ASYNSRV__FORCED_CLOSED"); break; - case ASYNSRV__NO_ROOM: strcpy (buff, "/ASYNSRV__NO_ROOM"); break; - default: sprintf (buff, "/ASYNSRV__unkn_err_code: %d", AsynSrv_errcode); - } - StrJoin (AsynSrv_routine[0], sizeof(AsynSrv_routine), - AsynSrv_routine[0], buff); - } - *entry_txt = AsynSrv_routine[0]; - AsynSrv_call_depth = 0; - AsynSrv_errcode = 0; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_Flush: Send a Flush command to RS232C server. -*/ - int AsynSrv_Flush ( -/* ============= -*/ struct AsynSrv__info *asyn_info) { - - int status; - char cmnd[8], rply[8]; - /*---------------------------------------------- - ** Pre-set the routine name (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_Flush"); - AsynSrv_call_depth++; - } - /*---------------------------------------------- - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. The connection may - ** also be marked to have been forcefully closed. - */ - if (asyn_info->skt <= 0) { - if ((AsynSrv_errcode == 0) && (asyn_info->skt < 0)) { - AsynSrv_errcode = ASYNSRV__FORCED_CLOSED; - } - return False; - } - /*---------------------------------------------- - ** Send message and get reply. - */ - status = AsynSrv_SendSpecCmnd (asyn_info, "-004"); - - if (AsynSrv_errcode == 0) AsynSrv_call_depth--; - return status; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_GetLenTerm: Get length and terminator of given -** reply from reply buffer. -*/ - int AsynSrv_GetLenTerm ( -/* ================== -*/ struct AsynSrv__info *asyn_info, - struct RS__RespStruct *rcve_buff, - char *rply, /* In: Addr of a reply as got .. - ** .. got from _GetReply */ - int *len, /* Out: The returned length */ - char *term) { /* Out: The returned t'nator */ - - int i; - - i = sscanf ((rply - asyn_info->rply_hdr_len - 1), asyn_info->rply_fmt, len); - *len = (i == 1) ? (*len - 2) : 0; - *term = *(rply - 1); - - if (i != 1) return False; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_GetReply: Get next reply from a reply buffer. -*/ - char *AsynSrv_GetReply ( -/* ================ -*/ struct AsynSrv__info *asyn_info, - struct RS__RespStruct *rcve_buff, - char *last_rply) { - - char *pntr = NULL; - int i, rply_len; - - if (last_rply == NULL) { /* Start with first reply? */ - /* Yes */ - asyn_info->n_replies = 1; - if (asyn_info->max_replies > 0) { - pntr = rcve_buff->u.rplys; - pntr = pntr + 1 + asyn_info->rply_hdr_len; - } - }else { /* No - get next reply */ - if (asyn_info->n_replies < asyn_info->max_replies) { /* If there is one */ - i = sscanf ((last_rply - asyn_info->rply_hdr_len - 1), - asyn_info->rply_fmt, &rply_len); - if ((i == 1) && (rply_len >= 0)) { - pntr = last_rply + rply_len + asyn_info->rply_hdr_len; - } - } - } - return pntr; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_Open: Open a connection to an RS-232-C Server. -*/ - int AsynSrv_Open ( -/* ============ -*/ struct AsynSrv__info *asyn_info) { - - int i, status; - int my_skt; - char old_time_out[4]; - union { - char chars[4]; - int val; - } time_out; - char buff[128]; - struct RS__MsgStruct s_buff; - struct RS__RespStruct r_buff; - unsigned int oto_len, oto_status; - struct hostent *rmt_hostent; - struct in_addr *rmt_inet_addr_pntr; - struct in_addr rmt_inet_addr; - int rmt_sockname_len; - struct sockaddr_in lcl_sockname; - struct sockaddr_in rmt_sockname; - - char *errtxt_ptr; - int errcode, my_errno, my_vaxc_errno; -/*-------------------------------------------------------- -*/ - asyn_info->skt = 0; -/*-------------------------------------------------------- -** Initialise the error info stack and pre-set the -** routine name (in case of error). -*/ - AsynSrv_errcode = AsynSrv_errno = AsynSrv_vaxc_errno = 0; - strcpy (AsynSrv_routine[0], "AsynSrv_Open"); - AsynSrv_call_depth = 1; -/*-------------------------------------------------------- -** Is there room for a new AsynSrv_Open table entry? -*/ - if (AsynSrv_n_active >= MAX_OPEN) { - AsynSrv_errcode = ASYNSRV__NO_ROOM; /* There isn't! */ - return False; - } -/*-------------------------------------------------------- -** See if a table entry for this connection already exists. -*/ - for (i = 0; i < AsynSrv_n_cnct; i++) { - if (AsynSrv_HPS_list[i].status != 0) continue; - if (AsynSrv_HPS_list[i].port != asyn_info->port) continue; - if (strcmp (AsynSrv_HPS_list[i].host, asyn_info->host) == 0) break; - } - if (i < AsynSrv_n_cnct) { /* Did we find an entry? */ - /* Yes */ - AsynSrv_HPS_list[i].usage_cnt++; /* Up the usage count and .. */ - AsynSrv_active[AsynSrv_n_active] = /* .. remember the open and .. */ - asyn_info; - AsynSrv_n_active++; - asyn_info->skt = /* .. return the socket. */ - AsynSrv_HPS_list[i].skt; - if (asyn_info->chan < 0) asyn_info->chan = 0; - if (asyn_info->chan > 255) asyn_info->chan = 0; - sprintf (buff, "%04d", asyn_info->chan); /* Convert channel # to ASCII */ - memcpy (asyn_info->chan_char, buff, sizeof (asyn_info->chan_char)); - - asyn_info->protocol_code = AsynSrv_HPS_list[i].protocol_code; - memcpy (asyn_info->protocol_id, - AsynSrv_HPS_list[i].protocol_id, - sizeof (asyn_info->protocol_id)); - asyn_info->cmnd_hdr_len = AsynSrv_HPS_list[i].cmnd_hdr_len; - sprintf (asyn_info->cmnd_fmt, "%%0%dd", asyn_info->cmnd_hdr_len); - asyn_info->rply_hdr_len = AsynSrv_HPS_list[i].rply_hdr_len; - sprintf (asyn_info->rply_fmt, "%%%dd", asyn_info->rply_hdr_len); - - sprintf (buff, "%04d", AsynSrv_msec_tmo/100); /* Set dflt time-out .. - ** ..(deci-secs) */ - memcpy (asyn_info->tmo, buff, sizeof (asyn_info->tmo)); - - memcpy (asyn_info->eot, /* Set dflt terminator(s) */ - AsynSrv_eot, sizeof (asyn_info->eot)); - - asyn_info->max_replies = asyn_info->n_replies = 0; - asyn_info->idleHandler = NULL; - AsynSrv_call_depth--; - return True; - } -/*-------------------------------------------------------- -** There is no existing connection. Open a new one. -*/ - status = AsynSrv_OpenNew (asyn_info); - if (!status) return False; -/*-------------------------------------------------------- -** Allow the entry to be shared (i.e. status = 0) -*/ - AsynSrv_HPS_list[AsynSrv_n_cnct-1].status = 0; -/*-------------------------------------------------------- -*/ - AsynSrv_errcode = AsynSrv_errno = AsynSrv_vaxc_errno = 0; - AsynSrv_call_depth = 0; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_OpenNew: Open a new connection to an RS-232-C Server. -*/ - int AsynSrv_OpenNew ( -/* =============== -*/ struct AsynSrv__info *asyn_info) { - - int i, status; - int my_skt; - char old_time_out[4]; - union { - char chars[4]; - int val; - } time_out; - char buff[128]; - struct RS__MsgStruct s_buff; - struct RS__RespStruct r_buff; - unsigned int oto_len, oto_status; - struct hostent *rmt_hostent; - struct in_addr *rmt_inet_addr_pntr; - struct in_addr rmt_inet_addr; - int rmt_sockname_len; - struct sockaddr_in lcl_sockname; - struct sockaddr_in rmt_sockname; - - char *errtxt_ptr; - int errcode, my_errno, my_vaxc_errno; -/*-------------------------------------------------------- -*/ - asyn_info->skt = 0; -/*-------------------------------------------------------- -** Initialise the error info stack and pre-set the -** routine name (in case of error). -*/ - AsynSrv_errcode = AsynSrv_errno = AsynSrv_vaxc_errno = 0; - if ((AsynSrv_call_depth == 1) && - (strcmp (AsynSrv_routine[0], "AsynSrv_Open") == 0)) { - strcpy (AsynSrv_routine[1], "AsynSrv_OpenNew"); - AsynSrv_call_depth = 2; - }else { - strcpy (AsynSrv_routine[0], "AsynSrv_OpenNew"); - AsynSrv_call_depth = 1; - } -/*-------------------------------------------------------- -** Is there room for a new AsynSrv_Open table entry? -*/ - if (AsynSrv_n_active >= MAX_OPEN) { - AsynSrv_errcode = ASYNSRV__NO_ROOM; /* There isn't! */ - return False; - } -/*-------------------------------------------------------- -** Is there room for a new connection entry? -*/ - if (AsynSrv_n_cnct >= AsynSrv_MAX_LINK) { - AsynSrv_errcode = ASYNSRV__NO_ROOM; /* There isn't! */ - return False; - } -/*-------------------------------------------------------- -** There's room for a new connection but, before going any -** further, do some quick checks on values in asyn_info. -*/ - if ((asyn_info->port <= 0) || - (asyn_info->port > 65535) || - (asyn_info->chan < 0) || - (asyn_info->chan > 255)) { - AsynSrv_errcode = ASYNSRV__BAD_PAR; /* Something is bad! */ - return False; - } -/*-------------------------------------------------------- -** Set up a new connection. -*/ - StrJoin (AsynSrv_HPS_list[AsynSrv_n_cnct].host, - sizeof (AsynSrv_HPS_list[AsynSrv_n_cnct].host), - asyn_info->host, ""); - AsynSrv_HPS_list[AsynSrv_n_cnct].port = asyn_info->port; - /*--------------------------- - ** Get the Internet address of the server. - */ - rmt_inet_addr.s_addr = inet_addr (asyn_info->host); - if (rmt_inet_addr.s_addr != -1) { - rmt_inet_addr_pntr = &rmt_inet_addr; - }else { - rmt_hostent = gethostbyname (asyn_info->host); - if (rmt_hostent == NULL) { - AsynSrv_errcode = ASYNSRV__BAD_HOST; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save errno info */ - fprintf (stderr, "\nAsynSrv_OpenNew/gethostbyname: Failed to get Internet " - "address of \"%s\".\n", asyn_info->host); - return False; - } - rmt_inet_addr_pntr = (struct in_addr *) rmt_hostent->h_addr_list[0]; - } - /*--------------------------- - ** Create a TCP/IP socket for connecting to server and bind it. - */ - my_skt = socket (AF_INET, SOCK_STREAM, 0); - if (my_skt <= 0) { - AsynSrv_errcode = ASYNSRV__BAD_SOCKET; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save the errno info */ - fprintf (stderr, "\nAsynSrv_OpenNew/socket: Failed to create a socket.\n"); - return False; - } - lcl_sockname.sin_family = AF_INET; - lcl_sockname.sin_port = htons (0); - lcl_sockname.sin_addr.s_addr = 0; - status = bind (my_skt, (struct sockaddr *) &lcl_sockname, - sizeof (lcl_sockname)); - if (status == -1) { - close (my_skt); - AsynSrv_errcode = ASYNSRV__BAD_BIND; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save the errno info */ - fprintf (stderr, "\nAsynSrv_OpenNew/bind: Failed to bind socket.\n"); - return False; - } - /*--------------------------- - ** Set short time-out (VMS systems only) - */ -#ifdef __VMS - oto_len = sizeof (old_time_out); /* Save current time-out first */ - oto_status = getsockopt (my_skt, IPPROTO_TCP, UCX$C_TCP_PROBE_IDLE, - old_time_out, &oto_len); - - if (oto_status == 0) { - time_out.val = AsynSrv_connect_tmo; /* Set new time-out */ - status = setsockopt (my_skt, IPPROTO_TCP, UCX$C_TCP_PROBE_IDLE, - time_out.chars, sizeof (time_out)); - } -#endif - /*--------------------------- - ** Connect to RS-232-C Server. - */ - rmt_sockname_len = sizeof (rmt_sockname); - rmt_sockname.sin_family = AF_INET; - rmt_sockname.sin_port = htons (asyn_info->port); - rmt_sockname.sin_addr.s_addr = rmt_inet_addr_pntr->s_addr; - status = connect (my_skt, (struct sockaddr *) &rmt_sockname, - sizeof (rmt_sockname)); - if (status != 0) { - close (my_skt); - AsynSrv_errcode = ASYNSRV__BAD_CONNECT; - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); /* Save the errno info */ - fprintf (stderr, - "\nAsynSrv_OpenNew/connect: Failed to connect to server.\n"); - perror ("AsynSrv_OpenNew"); - return False; - } - /*--------------------------- - ** Restore time-out (VMS only) - */ -#ifdef __VMS - if (oto_status == 0) { - setsockopt (my_skt, IPPROTO_TCP, UCX$C_TCP_PROBE_IDLE, - old_time_out, oto_len); - } -#endif - /*--------------------------------------------------- - ** Setup the defaults in the AsynSrv__info data structure. - */ - asyn_info->skt = my_skt; /* Return socket number to caller */ - - asyn_info->protocol_code = 0; /* Ensure protocol_code set to "unknown" */ - memcpy (asyn_info->protocol_id, "\0\0\0\0", - sizeof (asyn_info->protocol_id)); - asyn_info->cmnd_hdr_len = 4; - strcpy (asyn_info->cmnd_fmt, "%04d"); - asyn_info->rply_hdr_len = 4; - strcpy (asyn_info->rply_fmt, "%4d"); - - sprintf (buff, "%04d", asyn_info->chan); /* Convert channel # to ASCII */ - memcpy (asyn_info->chan_char, buff, sizeof (asyn_info->chan_char)); - - sprintf (buff, "%04d", AsynSrv_msec_tmo/100); /* Set dflt time-out .. - ** .. (deci-secs) */ - memcpy (asyn_info->tmo, buff, sizeof (asyn_info->tmo)); - - memcpy (asyn_info->eot, AsynSrv_eot, sizeof (asyn_info->eot)); /* Set .. - ** .. dflt terminator(s) */ - asyn_info->max_replies = 0; - asyn_info->n_replies = 0; - asyn_info->idleHandler = NULL; - /* - ** Send a null command buffer to the server. This should give - ** a "protocol mismatch" error response and from this we can get - ** the actual protocol level supported by the server. - */ - status = AsynSrv_SendCmnds (asyn_info, &s_buff, &r_buff, NULL); - if (!status && (AsynSrv_errcode == ASYNSRV__BAD_PROT_LVL)) { - /* - ** As expected, we got a "protocol mismatch" error. - ** Save the server's protocol level for future use. - */ - memcpy (asyn_info->protocol_id, r_buff.s_pcol_lvl, - sizeof (r_buff.s_pcol_lvl)); - if (strncmp (r_buff.s_pcol_lvl, RS__PROTOCOL_ID_V01B, - strlen (RS__PROTOCOL_ID_V01B)) == 0) { - asyn_info->protocol_code = RS__PROTOCOL_CODE_V01B; - asyn_info->cmnd_hdr_len = 4; - strcpy (asyn_info->cmnd_fmt, "%04d"); - asyn_info->rply_hdr_len = 4; - strcpy (asyn_info->rply_fmt, "%4d"); - }else if (strncmp (r_buff.s_pcol_lvl, RS__PROTOCOL_ID, - strlen (RS__PROTOCOL_ID)) == 0) { - asyn_info->protocol_code = RS__PROTOCOL_CODE; - asyn_info->cmnd_hdr_len = 2; - strcpy (asyn_info->cmnd_fmt, "%02d"); - asyn_info->rply_hdr_len = 2; - strcpy (asyn_info->rply_fmt, "%2d"); - }else { - close (my_skt); - asyn_info->skt = 0; - fprintf (stderr, - "\nAsynSrv_OpenNew: Server protocol level is unrecognised.\n" - " Server level is \"%4s\"\n", r_buff.s_pcol_lvl); - return False; - } - }else { - close (my_skt); - asyn_info->skt = 0; - AsynSrv_errcode = ASYNSRV__BAD_PROT_LVL; - fprintf (stderr, - "\nAsynSrv_OpenNew: Problem getting protocol level of Server!\n"); - return False; - } - /*--------------------------------------------------- - ** Complete the setup of the connection table entry - */ - AsynSrv_HPS_list[AsynSrv_n_cnct].skt = my_skt; - AsynSrv_HPS_list[AsynSrv_n_cnct].protocol_code = asyn_info->protocol_code; - memcpy (AsynSrv_HPS_list[AsynSrv_n_cnct].protocol_id, - asyn_info->protocol_id, sizeof (asyn_info->protocol_id)); - AsynSrv_HPS_list[AsynSrv_n_cnct].cmnd_hdr_len = asyn_info->cmnd_hdr_len; - AsynSrv_HPS_list[AsynSrv_n_cnct].rply_hdr_len = asyn_info->rply_hdr_len; - AsynSrv_HPS_list[AsynSrv_n_cnct].usage_cnt = 1; - AsynSrv_HPS_list[AsynSrv_n_cnct].status = 1; - AsynSrv_n_cnct++; - - AsynSrv_active[AsynSrv_n_active] = /* Remember the open in case .. */ - asyn_info; /* .. there's a force-exit */ - AsynSrv_n_active++; - - AsynSrv_errcode = AsynSrv_errno = AsynSrv_vaxc_errno = 0; - AsynSrv_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_SendCmnds: Send commands to RS232C server. -*/ - int AsynSrv_SendCmnds ( -/* ================= -*/ struct AsynSrv__info *asyn_info, - struct RS__MsgStruct *send_buff, - struct RS__RespStruct *rcve_buff, - ...) { /* Now we have list of commands - - ** char *txt = pntr to cmnd strng - ** Terminate list with *txt = NULL. - */ - int i, status, c_len, size, max_size, ncmnds; - int bytes_to_come, bytes_left; - char *nxt_byte_ptr; - char err_text[80]; - char text[20]; - va_list ap; /* Pointer to variable args */ - char *txt_ptr; - char *cmnd_lst_ptr; - /*---------------------------------------------- - ** Pre-set the routine name (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_SendCmnds"); - AsynSrv_call_depth++; - } - /*---------------------------------------------- - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. The connection may - ** also be marked to have been forcefully closed. - */ - if (asyn_info->skt <= 0) { - memset (rcve_buff->msg_size, - '0', sizeof (rcve_buff->msg_size)); - if ((AsynSrv_errcode == 0) && (asyn_info->skt < 0)) { - AsynSrv_errcode = ASYNSRV__FORCED_CLOSED; - } - return False; - } - /*---------------------------------------------- - ** Build message for server from the list of commands. - */ - asyn_info->max_replies = asyn_info->n_replies = 0; - - asyn_info->msg_id++; /* Set up an incrementing message id */ - if (asyn_info->msg_id > 9999) asyn_info->msg_id = 1; - sprintf (send_buff->msg_id, "%04d", asyn_info->msg_id); - - memcpy (send_buff->c_pcol_lvl, asyn_info->protocol_id, - sizeof (send_buff->c_pcol_lvl)); - - memcpy (send_buff->serial_port, asyn_info->chan_char, - sizeof (send_buff->serial_port)); - - memcpy (send_buff->tmo, asyn_info->tmo, sizeof (send_buff->tmo)); - - memcpy (send_buff->terms, asyn_info->eot, sizeof (send_buff->terms)); - - memcpy (send_buff->n_cmnds, "0000", sizeof (send_buff->n_cmnds)); - - va_start (ap, rcve_buff); /* Set up var arg machinery */ - - txt_ptr = va_arg (ap, char *); /* Get pntr to next cmnd string */ - ncmnds = 0; - cmnd_lst_ptr = &send_buff->cmnds[0]; - bytes_left = sizeof (*send_buff) - - OffsetOf (struct RS__MsgStruct, cmnds[0]); - - while (txt_ptr != NULL) { - c_len = strlen (txt_ptr); - size = asyn_info->cmnd_hdr_len + c_len; - if (size > bytes_left) { - AsynSrv_errcode = ASYNSRV__BAD_SEND_LEN; /* Too much to send */ - fprintf (stderr, "\nAsynSrv_SendCmnds/send: too much to send" - " - request ignored.\n"); - memset (rcve_buff->msg_size, '0', sizeof (rcve_buff->msg_size)); - return False; - }else { - sprintf (cmnd_lst_ptr, asyn_info->cmnd_fmt, c_len); - if (cmnd_lst_ptr[asyn_info->cmnd_hdr_len] != '\0') { - AsynSrv_errcode = ASYNSRV__BAD_CMND_LEN; - fprintf (stderr, "\nAsynSrv_SendCmnds/send: command too long -" - " - request ignored.\n"); - memset (rcve_buff->msg_size, '0', sizeof (rcve_buff->msg_size)); - return False; - } - cmnd_lst_ptr += asyn_info->cmnd_hdr_len; - strcpy (cmnd_lst_ptr, txt_ptr); - cmnd_lst_ptr += c_len; - ncmnds++; - bytes_left = bytes_left - size; - txt_ptr = va_arg (ap, char *); - } - } - sprintf (text, "%04d", ncmnds); - memcpy (send_buff->n_cmnds, text, sizeof (send_buff->n_cmnds)); - - size = cmnd_lst_ptr - send_buff->msg_id; - size = (size + 3) & (~3); /* Round up to multiple of 4 */ - sprintf (text, "%04d", size); - memcpy (send_buff->msg_size, text, sizeof (send_buff->msg_size)); - - size += sizeof (send_buff->msg_size); - status = send (asyn_info->skt, - (char *) send_buff, size, 0); - if (status != size) { - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - if (status == 0) { - AsynSrv_errcode = ASYNSRV__BAD_SEND; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/send: probable network problem"); - }else if (status == -1) { - if (AsynSrv_errno == EPIPE) { - AsynSrv_errcode = ASYNSRV__BAD_SEND_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/send: broken network pipe"); - }else { - AsynSrv_errcode = ASYNSRV__BAD_SEND_NET; /* It's some other net problem */ - perror ("AsynSrv_SendCmnds/send"); - } - }else { - AsynSrv_errcode = ASYNSRV__BAD_SEND_UNKN; /* TCP/IP problems */ - fprintf (stderr, "\nAsynSrv_SendCmnds/send: probable TCP/IP problem"); - } - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - - if (asyn_info->idleHandler != NULL) { /* MZ. */ - sscanf(asyn_info->tmo, "%4d", &i); /* Decode timeout from ASCII .. - ** .. encoded deci-sec */ - asyn_info->idleHandler (i*150, asyn_info->skt); /* Wait for an event .. - ** .. on asyn_info->skt or a .. - ** .. timeout of 1.5*tmo */ - } - - size = sizeof (rcve_buff->msg_size); - status = recv (asyn_info->skt, rcve_buff->msg_size, size, 0); - if (status != size) { - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - if (status == 0) { - AsynSrv_errcode = ASYNSRV__BAD_RECV; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: probable network problem"); - }else if (status == -1) { - if (AsynSrv_errno == EPIPE) { - AsynSrv_errcode = ASYNSRV__BAD_RECV_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: broken network pipe"); - }else { - AsynSrv_errcode = ASYNSRV__BAD_RECV_NET; /* It's some other net problem */ - perror ("AsynSrv_SendCmnds/recv"); - } - }else { - AsynSrv_errcode = ASYNSRV__BAD_RECV_UNKN; /* TCP/IP problems */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: probable TCP/IP problem"); - } - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - if (sscanf (rcve_buff->msg_size, "%4d", &bytes_to_come) != 1) { - AsynSrv_errcode = ASYNSRV__BAD_NOT_BCD; /* Header not an ASCII BCD integer */ - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: non-BCD byte count" - " - link to server force-closed.\n"); - return False; - } - max_size = sizeof (*rcve_buff) - size; - if (bytes_to_come > max_size) { - AsynSrv_errcode = ASYNSRV__BAD_RECV_LEN; - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: pending message length too big" - " - flushing ...\n"); - nxt_byte_ptr = &rcve_buff->msg_size[size]; - while (bytes_to_come > 0) { /* Flush out the incoming message */ - bytes_left = bytes_to_come; - if (bytes_left > max_size) bytes_left = max_size; - status = recv (asyn_info->skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - AsynSrv_errcode = ASYNSRV__BAD_FLUSH; /* TCP/IP problem during flush */ - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv: network problem during" - " flush.\nLink to server force-closed.\n"); - return False; - } - bytes_to_come = bytes_to_come - status; - } - fprintf (stderr, "\n flushed OK.\n"); - memset (rcve_buff->msg_size, '0', sizeof (rcve_buff->msg_size)); - return False; - }else { - nxt_byte_ptr = &rcve_buff->msg_size[size]; - bytes_left = bytes_to_come; - while (bytes_left > 0) { /* Read the rest of the response */ - status = recv (asyn_info->skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - if (status == 0) { - AsynSrv_errcode = ASYNSRV__BAD_RECV1; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv/1: probable network " - "problem"); - }else { - if (AsynSrv_errno == EPIPE) { - AsynSrv_errcode = ASYNSRV__BAD_RECV1_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmnds/recv/1: broken network pipe"); - }else { - AsynSrv_errcode = ASYNSRV__BAD_RECV1_NET; /* It's some other net fault */ - perror ("AsynSrv_SendCmnds/recv/1"); - } - } - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - bytes_left = bytes_left - status; - nxt_byte_ptr = nxt_byte_ptr + status; - } - if (strncmp (asyn_info->protocol_id, rcve_buff->s_pcol_lvl, - sizeof (rcve_buff->s_pcol_lvl)) != 0) { - AsynSrv_errcode = ASYNSRV__BAD_PROT_LVL; /* Protocol level is bad */ - return False; - } - if ((sscanf (rcve_buff->n_rply, "%4d", &asyn_info->max_replies) != 1) || - (asyn_info->max_replies < 0)) { - AsynSrv_errcode = ASYNSRV__BAD_REPLY; /* Reply is bad */ - if (AsynSrv_call_depth < 5) { /* Add reply to routine stack */ - bytes_to_come = bytes_to_come + 4; - if (bytes_to_come >= sizeof (AsynSrv_routine[0])) - bytes_to_come = sizeof (AsynSrv_routine[0]) - 1; - for (i=0; imsg_size[i] == '\0') - rcve_buff->msg_size[i] = '.'; - } - rcve_buff->msg_size[bytes_to_come] = '\0'; - strcpy (AsynSrv_routine[AsynSrv_call_depth], rcve_buff->msg_size); - AsynSrv_call_depth++; - } - return False; - } - } - if (AsynSrv_errcode == 0) AsynSrv_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_SendCmndsBig: Same as AsynSrv_SendCmnds but with -** user defined buffer sizes. -*/ - int AsynSrv_SendCmndsBig ( -/* ==================== -*/ struct AsynSrv__info *asyn_info, - struct RS__MsgStruct *send_buff, - int send_buff_size, - struct RS__RespStruct *rcve_buff, - int rcve_buff_size, - ...) { /* Now we have list of commands - - ** char *txt = pntr to cmnd strng - ** Terminate list with *txt = NULL. - */ - int i, status, size, max_size, ncmnds; - int bytes_to_come, bytes_left; - char *nxt_byte_ptr; - char err_text[80]; - char text[20]; - va_list ap; /* Pointer to variable args */ - int *c_len, s_len; - char *txt_ptr; - char *cmnd_lst_ptr; - /*---------------------------------------------- - ** Pre-set the routine name (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_SendCmndsBig"); - AsynSrv_call_depth++; - } - /*---------------------------------------------- - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. The connection may - ** also be marked to have been forcefully closed. - */ - if (asyn_info->skt <= 0) { - memset (rcve_buff->msg_size, - '0', sizeof (rcve_buff->msg_size)); - if ((AsynSrv_errcode == 0) && (asyn_info->skt < 0)) { - AsynSrv_errcode = ASYNSRV__FORCED_CLOSED; - } - return False; - } - /*---------------------------------------------- - ** Build message for server from the list of commands. - */ - if (send_buff_size < 64 || rcve_buff_size < 64) { - AsynSrv_errcode = ASYNSRV__BAD_PAR; return False;} - - asyn_info->max_replies = asyn_info->n_replies = 0; - - asyn_info->msg_id++; /* Set up an incrementing message id */ - if (asyn_info->msg_id > 9999) asyn_info->msg_id = 1; - sprintf (send_buff->msg_id, "%04d", asyn_info->msg_id); - - memcpy (send_buff->c_pcol_lvl, asyn_info->protocol_id, - sizeof (send_buff->c_pcol_lvl)); - - memcpy (send_buff->serial_port, asyn_info->chan_char, - sizeof (send_buff->serial_port)); - - memcpy (send_buff->tmo, asyn_info->tmo, sizeof (send_buff->tmo)); - - memcpy (send_buff->terms, asyn_info->eot, sizeof (send_buff->terms)); - - memcpy (send_buff->n_cmnds, "0000", sizeof (send_buff->n_cmnds)); - - va_start (ap, rcve_buff_size); /* Set up var arg machinery */ - - c_len = va_arg (ap, int *); /* Get pntr to length of next cmnd string */ - ncmnds = 0; - cmnd_lst_ptr = &send_buff->cmnds[0]; - bytes_left = send_buff_size - - OffsetOf (struct RS__MsgStruct, cmnds[0]); - - while (c_len != NULL) { - txt_ptr = va_arg (ap, char *); - s_len = *c_len; - if (s_len <= 0) s_len = strlen (txt_ptr); - size = asyn_info->cmnd_hdr_len + s_len; - if (size > bytes_left) { - AsynSrv_errcode = ASYNSRV__BAD_SEND_LEN; /* Too much to send */ - fprintf (stderr, "\nAsynSrv_SendCmndsBig/send: too much to send" - " - request ignored.\n"); - memset (rcve_buff->msg_size, '0', sizeof (rcve_buff->msg_size)); - return False; - } - sprintf (cmnd_lst_ptr, asyn_info->cmnd_fmt, s_len); - if (cmnd_lst_ptr[asyn_info->cmnd_hdr_len] != '\0') { - AsynSrv_errcode = ASYNSRV__BAD_CMND_LEN; - fprintf (stderr, "\nAsynSrv_SendCmndsBig/send: command too long -" - " - request ignored.\n"); - memset (rcve_buff->msg_size, '0', sizeof (rcve_buff->msg_size)); - return False; - } - cmnd_lst_ptr += asyn_info->cmnd_hdr_len; - memcpy (cmnd_lst_ptr, txt_ptr, s_len); - cmnd_lst_ptr += s_len; - ncmnds++; - bytes_left = bytes_left - size; - c_len = va_arg (ap, int *); - } - sprintf (text, "%04d", ncmnds); - memcpy (send_buff->n_cmnds, text, sizeof (send_buff->n_cmnds)); - - size = cmnd_lst_ptr - send_buff->msg_id; - size = (size + 3) & (~3); /* Round up to multiple of 4 */ - sprintf (text, "%04d", size); - memcpy (send_buff->msg_size, text, sizeof (send_buff->msg_size)); - - size += sizeof (send_buff->msg_size); - status = send (asyn_info->skt, - (char *) send_buff, size, 0); - if (status != size) { - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - if (status == 0) { - AsynSrv_errcode = ASYNSRV__BAD_SEND; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmndsBig/send: probable network problem"); - }else if (status == -1) { - if (AsynSrv_errno == EPIPE) { - AsynSrv_errcode = ASYNSRV__BAD_SEND_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmndsBig/send: broken network pipe"); - }else { - AsynSrv_errcode = ASYNSRV__BAD_SEND_NET; /* It's some other net problem */ - perror ("AsynSrv_SendCmndsBig/send"); - } - }else { - AsynSrv_errcode = ASYNSRV__BAD_SEND_UNKN; /* TCP/IP problems */ - fprintf (stderr, "\nAsynSrv_SendCmndsBig/send: probable TCP/IP problem"); - } - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - - size = sizeof (rcve_buff->msg_size); - status = recv (asyn_info->skt, rcve_buff->msg_size, size, 0); - if (status != size) { - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - if (status == 0) { - AsynSrv_errcode = ASYNSRV__BAD_RECV; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmndsBig/recv: probable network problem"); - }else if (status == -1) { - if (AsynSrv_errno == EPIPE) { - AsynSrv_errcode = ASYNSRV__BAD_RECV_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmndsBig/recv: broken network pipe"); - }else { - AsynSrv_errcode = ASYNSRV__BAD_RECV_NET; /* It's some other net problem */ - perror ("AsynSrv_SendCmndsBig/recv"); - } - }else { - AsynSrv_errcode = ASYNSRV__BAD_RECV_UNKN; /* TCP/IP problems */ - fprintf (stderr, "\nAsynSrv_SendCmndsBig/recv: probable TCP/IP problem"); - } - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - if (sscanf (rcve_buff->msg_size, "%4d", &bytes_to_come) != 1) { - AsynSrv_errcode = ASYNSRV__BAD_NOT_BCD; /* Header not an ASCII BCD integer */ - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, "\nAsynSrv_SendCmndsBig/recv: non-BCD byte count" - " - link to server force-closed.\n"); - return False; - } - max_size = rcve_buff_size - size; - if (bytes_to_come > max_size) { - AsynSrv_errcode = ASYNSRV__BAD_RECV_LEN; - fprintf (stderr, "\nAsynSrv_SendCmndsBig/recv: pending message length " - "too big - flushing ...\n"); - nxt_byte_ptr = &rcve_buff->msg_size[size]; - while (bytes_to_come > 0) { /* Flush out the incoming message */ - bytes_left = bytes_to_come; - if (bytes_left > max_size) bytes_left = max_size; - status = recv (asyn_info->skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - AsynSrv_errcode = ASYNSRV__BAD_FLUSH; /* TCP/IP problem during flush */ - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, "\nAsynSrv_SendCmndsBig/recv: network problem during" - " flush.\nLink to server force-closed.\n"); - return False; - } - bytes_to_come = bytes_to_come - status; - } - fprintf (stderr, "\n flushed OK.\n"); - memset (rcve_buff->msg_size, '0', sizeof (rcve_buff->msg_size)); - return False; - }else { - nxt_byte_ptr = &rcve_buff->msg_size[size]; - bytes_left = bytes_to_come; - while (bytes_left > 0) { /* Read the rest of the response */ - status = recv (asyn_info->skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - if (status == 0) { - AsynSrv_errcode = ASYNSRV__BAD_RECV1; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmndsBig/recv/1: probable network " - "problem"); - }else { - if (AsynSrv_errno == EPIPE) { - AsynSrv_errcode = ASYNSRV__BAD_RECV1_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendCmndsBig/recv/1: broken network pipe"); - }else { - AsynSrv_errcode = ASYNSRV__BAD_RECV1_NET; /* It's some other net fault */ - perror ("AsynSrv_SendCmndsBig/recv/1"); - } - } - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - bytes_left = bytes_left - status; - nxt_byte_ptr = nxt_byte_ptr + status; - } - if (strncmp (asyn_info->protocol_id, rcve_buff->s_pcol_lvl, - sizeof (rcve_buff->s_pcol_lvl)) != 0) { - AsynSrv_errcode = ASYNSRV__BAD_PROT_LVL; /* Protocol level is bad */ - return False; - } - if ((sscanf (rcve_buff->n_rply, "%4d", &asyn_info->max_replies) != 1) || - (asyn_info->max_replies < 0)) { - AsynSrv_errcode = ASYNSRV__BAD_REPLY; /* Reply is bad */ - if (AsynSrv_call_depth < 5) { /* Add reply to routine stack */ - bytes_to_come = bytes_to_come + 4; - if (bytes_to_come >= sizeof (AsynSrv_routine[0])) - bytes_to_come = sizeof (AsynSrv_routine[0]) - 1; - for (i=0; imsg_size[i] == '\0') - rcve_buff->msg_size[i] = '.'; - } - rcve_buff->msg_size[bytes_to_come] = '\0'; - strcpy (AsynSrv_routine[AsynSrv_call_depth], rcve_buff->msg_size); - AsynSrv_call_depth++; - } - return False; - } - } - if (AsynSrv_errcode == 0) AsynSrv_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_SendSpecCmnd: Send a "special" command to an -** RS232C server. -*/ - int AsynSrv_SendSpecCmnd ( -/* ==================== -*/ struct AsynSrv__info *asyn_info, - char *cmnd) { - - int status; - char rply[8]; - /*---------------------------------------------- - ** Pre-set the routine name (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_SendSpecCmnd"); - AsynSrv_call_depth++; - } - /*---------------------------------------------- - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. The connection may - ** also be marked to have been forcefully closed. - */ - if (asyn_info->skt <= 0) { - if ((AsynSrv_errcode == 0) && (asyn_info->skt < 0)) { - AsynSrv_errcode = ASYNSRV__FORCED_CLOSED; - } - return False; - } - /*---------------------------------------------- - ** Send the message to the server. - */ - status = send (asyn_info->skt, cmnd, 4, 0); - if (status != 4) { - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - if (status == 0) { - AsynSrv_errcode = ASYNSRV__BAD_SEND; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendSpecCmnd/send: probable network problem"); - }else if (status == -1) { - if (AsynSrv_errno == EPIPE) { - AsynSrv_errcode = ASYNSRV__BAD_SEND_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendSpecCmnd/send: broken network pipe"); - }else { - AsynSrv_errcode = ASYNSRV__BAD_SEND_NET; /* It's some other net problem */ - perror ("AsynSrv_SendSpecCmnd/send"); - } - }else { - AsynSrv_errcode = ASYNSRV__BAD_SEND_UNKN; /* TCP/IP problems */ - fprintf (stderr, "\nAsynSrv_SendSpecCmnd/send: probable TCP/IP problem"); - } - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - - status = recv (asyn_info->skt, rply, 4, 0); - if (status != 4) { - GetErrno (&AsynSrv_errno, &AsynSrv_vaxc_errno); - if (status == 0) { - AsynSrv_errcode = ASYNSRV__BAD_RECV; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendSpecCmnd/recv: probable network problem"); - }else if (status == -1) { - if (AsynSrv_errno == EPIPE) { - AsynSrv_errcode = ASYNSRV__BAD_RECV_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nAsynSrv_SendSpecCmnd/recv: broken network pipe"); - }else { - AsynSrv_errcode = ASYNSRV__BAD_RECV_NET; /* It's some other net problem */ - perror ("AsynSrv_SendSpecCmnd/recv"); - } - }else { - AsynSrv_errcode = ASYNSRV__BAD_RECV_UNKN; /* TCP/IP problems */ - fprintf (stderr, "\nAsynSrv_SendSpecCmnd/recv: probable TCP/IP problem"); - } - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - if (memcmp (cmnd, rply, 4) != 0) { - AsynSrv_errcode = ASYNSRV__BAD_NOT_BCD; /* Message not echoed OK */ - AsynSrv_Close (asyn_info, True); /* Force close TCP/IP connection */ - fprintf (stderr, "\nAsynSrv_SendSpecCmnd/recv: command not echoed correctly" - " - link to server force-closed.\n"); - return False; - } - if (AsynSrv_errcode == 0) AsynSrv_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_Trace: Send a "TRACE" request to RS232C server. -*/ - int AsynSrv_Trace ( -/* ============= -*/ struct AsynSrv__info *asyn_info, - int state) { - - int status; - char cmnd[8], rply[8]; - /*---------------------------------------------- - ** Pre-set the routine name (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_Trace"); - AsynSrv_call_depth++; - } - /*---------------------------------------------- - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. The connection may - ** also be marked to have been forcefully closed. - */ - if (asyn_info->skt <= 0) { - if ((AsynSrv_errcode == 0) && (asyn_info->skt < 0)) { - AsynSrv_errcode = ASYNSRV__FORCED_CLOSED; - } - return False; - } - /*---------------------------------------------- - ** Select message for server according to value of state. - */ - if (state) { - strcpy (cmnd, "-002"); - }else { - strcpy (cmnd, "-003"); - } - /*---------------------------------------------- - ** Send message and get reply. - */ - status = AsynSrv_SendSpecCmnd (asyn_info, cmnd); - - if (AsynSrv_errcode == 0) AsynSrv_call_depth--; - return status; - } -/* -**--------------------------------------------------------------------------- -** AsynSrv_Trace_Write: Send a Trace_Write command to -** RS232C server. -*/ - int AsynSrv_Trace_Write ( -/* =================== -*/ struct AsynSrv__info *asyn_info) { - - int status; - char cmnd[8], rply[8]; - /*---------------------------------------------- - ** Pre-set the routine name (in case of error) - */ - if (AsynSrv_errcode == 0 && AsynSrv_call_depth < 5) { - strcpy (AsynSrv_routine[AsynSrv_call_depth], "AsynSrv_Trace_Write"); - AsynSrv_call_depth++; - } - /*---------------------------------------------- - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. The connection may - ** also be marked to have been forcefully closed. - */ - if (asyn_info->skt <= 0) { - if ((AsynSrv_errcode == 0) && (asyn_info->skt < 0)) { - AsynSrv_errcode = ASYNSRV__FORCED_CLOSED; - } - return False; - } - /*---------------------------------------------- - ** Send message and get reply. - */ - status = AsynSrv_SendSpecCmnd (asyn_info, "-005"); - - if (AsynSrv_errcode == 0) AsynSrv_call_depth--; - return status; - } -/*-------------------------------------------- End of AsynSrv_Utility.C -----*/ diff --git a/hardsup/c_interfaces.c b/hardsup/c_interfaces.c deleted file mode 100644 index a514c64d..00000000 --- a/hardsup/c_interfaces.c +++ /dev/null @@ -1,472 +0,0 @@ -#define ident "1A05" -#ifdef VAXC -#module C_INTERFACES ident -#endif -#ifdef __DECC -#pragma module C_INTERFACES ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Computing Section | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]C_INTERFACES.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Nov 1993 -** -** C_INTERFACES.C provides some routines which make it easier for C programs -** to call some of the Fortran routines in SINQ.OLB. -** -** To include this module in SINQ.OLB, use: - - $ import tasmad - $ define/job sinq_c_tlb mad_lib:sinq_c_tlb.tlb - $ define/job sinq_olb mad_lib:sinq.olb - $ @lnsa09::tasmad_disk:[mad.psi.lib.sinq]sinq_olb c_interfaces debug - $ - $ define/job sinq_olb mad_lib:sinq.olb - $ @lnsa09::tasmad_disk:[mad.psi.lib.sinq]sinq_olb c_interfaces - -** -** Updates: -** 1A01 16-Nov-1993 DM. Initial version. -** 1A02 24-Nov-1994 DM. Make compatible with DEC C (as opposed to VAX C) -** 1A03 28-Nov-1994 DM. Add the TT_PORT_... entry points. -**==================================================================== -** The following entry pointd are included: -** C_log_arr_get : interface routine from C to LOG_ARR_GET. -** C_log_flt_get : interface routine from C to LOG_FLT_GET. -** C_log_int_get : interface routine from C to LOG_INT_GET. -** C_log_str_get : interface routine from C to LOG_STR_GET. -** -** C_str_edit : interface routine to STR_EDIT. -** -** C_tt_port_connect : interface routine to TT_PORT_CONNECT. -** C_tt_port_disconnect: interface routine to TT_PORT_DISCONNECT. -** C_tt_port_io : interface routine to TT_PORT_IO. -** C_tt_port_config : interface routine to TT_PORT_CONFIG. -**==================================================================== -** Global Definitions -*/ -#ifdef VAXC -#include stdio -#include descrip -#include string -#include sinq_prototypes -#else -#include -#include -#include -#include -#endif -/*-------------------------------------------------------------------------- -** Global Variables -*/ - extern int C_gbl_status = 0; - extern struct dsc$descriptor_s C_name_desc = {0, - DSC$K_DTYPE_T, - DSC$K_CLASS_S, - 0}; -/*-------------------------------------------------------------------------- -** Old-style prototypes of routines which we are -** bridging to. -*/ - int log_arr_get (); - int log_int_get (); - int log_flt_get (); - int log_str_get (); - - int str_edit (); - - int tt_port_connect (); - int tt_port_disconnect (); - int tt_port_io (); - int tt_port_config (); -/* --------------------------------------------------------------------------*/ - int C_log_arr_get (char *name, int arr_size, int *value, int indx) { -/* ============= -** -** This routine is useful for calling LOG_ARR_GET from a C program. -** -** Inputs: -** name - a pointer to the zero-terminated logical name. -** arr_size - the number of elements in the array value. -** indx - the index of the logical name. -** Outputs: -** value - an array of size arr_size set to the values converted -** to binary. -** Return status: -** the return status of the function is zero (false) if LOG_ARR_GET -** returns an error (even) condition code. -** Global variables: -** C_gbl_status - set to the VAX/VMS return status of LOG_ARR_GET. -** C_name_desc - set up as a string descriptor for name. It can -** be used to generate an error message if return status == 0. -*/ - C_name_desc.dsc$w_length = strlen (name); - C_name_desc.dsc$a_pointer = name; - - C_gbl_status = log_arr_get (&C_name_desc, &arr_size, value, &indx); - - return (C_gbl_status & 1); - } -/*--------------------------------------------------------------------------*/ - int C_log_int_get (char *name, long int *value, int indx) { -/* ============= -** -** This routine is useful for calling LOG_INT_GET from a C program. -** -** Inputs: -** name - a pointer to the zero-terminated logical name. -** indx - the index of the logical name. -** Outputs: -** value - the value of the logical converted to binary. -** Return status: -** the return status of the function is zero (false) if LOG_INT_GET -** returns an error (even) condition code. -** Global variables: -** C_gbl_status - set to the VAX/VMS return status of LOG_INT_GET. -** C_name_desc - set up as a string descriptor for name. It can -** be used to generate an error message if return status == 0. -*/ - C_name_desc.dsc$w_length = strlen (name); - C_name_desc.dsc$a_pointer = name; - - C_gbl_status = log_int_get (&C_name_desc, value, &indx); - - return (C_gbl_status & 1); - } -/*--------------------------------------------------------------------------*/ - int C_log_flt_get (char *name, float *value, int indx) { -/* ============= -** -** This routine is useful for calling LOG_FLT_GET from a C program. -** -** Inputs: -** name - a pointer to the zero-terminated logical name. -** indx - the index of the logical name. -** Outputs: -** value - the value of the logical converted to binary. -** Return status: -** the return status of the function is zero (false) if LOG_FLT_GET -** returns an error (even) condition code. -** Global variables: -** C_gbl_status - set to the VAX/VMS return status of LOG_FLT_GET. -** C_name_desc - set up as a string descriptor for name. It can -** be used to generate an error message if return status == 0. -*/ - C_name_desc.dsc$w_length = strlen (name); - C_name_desc.dsc$a_pointer = name; - - C_gbl_status = log_flt_get (&C_name_desc, value, &indx); - - return (C_gbl_status & 1); - } -/*--------------------------------------------------------------------------*/ - int C_log_str_get (char *name, char *value, int val_size, int indx) { -/* ============= -** -** This routine is useful for calling LOG_STR_GET from a C program. -** -** Inputs: -** name - a pointer to the zero-terminated logical name. -** val_size - the size of the value string. -** indx - the index of the logical name. -** Outputs: -** value - zero-terminated string giving the value of the logical. -** Trailing space characters will have been stripped. -** Return status: -** the return status of the function is zero (false) if LOG_STR_GET -** returns an error (even) condition code. -** Global variables: -** C_gbl_status - set to the VAX/VMS return status of LOG_STR_GET. -** C_name_desc - set up as a string descriptor for name. It can -** be used to generate an error message if return status == 0. -*/ - struct dsc$descriptor_s my_val_desc = {0, - DSC$K_DTYPE_T, - DSC$K_CLASS_S, - 0}; - - C_name_desc.dsc$w_length = strlen (name); - C_name_desc.dsc$a_pointer = name; - - my_val_desc.dsc$w_length = val_size - 1; - my_val_desc.dsc$a_pointer = value; - - C_gbl_status = log_str_get (&C_name_desc, &my_val_desc, &indx); - value[val_size - 1] = 0; /* Zero-terminate the string */ - - if (C_gbl_status & 1) { /* If success, strip trailing spaces */ - while ((strlen (value) > 0) && (value[strlen (value) - 1] == ' ')) { - value[strlen (value) - 1] = 0; - } - } - return (C_gbl_status & 1); - } -/*--------------------------------------------------------------------------*/ - int C_str_edit (char *out, char *in, char *ctrl, int *length) { -/* ========== -** -** This routine is useful for calling STR_EDIT from a C program. -** -** Inputs: -** in - the string to be edited. -** ctrl - the string specifying what editing is to be done. -** Outputs: -** out - the edited string. The maximum size of this string must -** be specified as input parameter *length. The string -** will be zero terminated on return. -** Modified: -** *length - an integer specifying, on input, the length of "out" in -** bytes. This must include room for the zero termination. -** On return, length will be set to the number of characters -** copied to "out" (not counting the zero termination byte). -** Return status: -** the return status of the function is zero (false) if STR_EDIT -** returns an error (even) condition code. -** Global variables: -** C_gbl_status - set to the VAX/VMS return status of STR_EDIT. -*/ - struct dsc$descriptor_s out_desc = {0, - DSC$K_DTYPE_T, - DSC$K_CLASS_S, - 0}; - struct dsc$descriptor_s in_desc = {0, - DSC$K_DTYPE_T, - DSC$K_CLASS_S, - 0}; - struct dsc$descriptor_s ctrl_desc = {0, - DSC$K_DTYPE_T, - DSC$K_CLASS_S, - 0}; - - out_desc.dsc$w_length = *length - 1; - out_desc.dsc$a_pointer = out; - - in_desc.dsc$w_length = strlen (in); - in_desc.dsc$a_pointer = in; - - ctrl_desc.dsc$w_length = strlen (ctrl); - ctrl_desc.dsc$a_pointer = ctrl; - - C_gbl_status = str_edit (&out_desc, &in_desc, &ctrl_desc, length); - if (*length >= 0) { /* zero-terminate the output string */ - out[*length] = '\0'; - }else { - out[0] = '\0'; - } - - return (C_gbl_status & 1); - } -/*--------------------------------------------------------------------------*/ - int C_tt_port_connect (int *hndl, int *chan, char *lognam, char *pwd) { -/* ================= -** -** This routine is useful for calling TT_PORT_CONNECT from a C program. -** -** Inputs: -** lognam - a zero-terminated string specifying a logical name which -** defines the RS-232-C port to be connected. See description -** of TT_PORT_CONNECT for full details. -** pwd - a zero-terminated string specifying an optional password. -** This is the password associated with a terminal server -** service. See description of TT_PORT_CONNECT for full -** details. Specify NULL if no password. -** Outputs: -** hndl - an integer handle identifying the connection. It will be -** the address of a dynamically allocated data structure. -** chan - an integer (actually only 16 bit) giving the I/O channel -** associated with the connection. This can be used in QIO -** system calls to the terminal driver. -** Return status: -** the return status of the function is zero (false) if TT_PORT_CONNECT -** returns an error (even) condition code. -** Global variables: -** C_gbl_status - set to the VAX/VMS return status of TT_PORT_CONNECT. -*/ - struct dsc$descriptor_s lognam_desc = {0, - DSC$K_DTYPE_T, - DSC$K_CLASS_S, - 0}; - struct dsc$descriptor_s pwd_desc = {0, - DSC$K_DTYPE_T, - DSC$K_CLASS_S, - 0}; - lognam_desc.dsc$w_length = strlen (lognam); - lognam_desc.dsc$a_pointer = lognam; - - if (pwd != NULL) { - pwd_desc.dsc$w_length = strlen (pwd); - pwd_desc.dsc$a_pointer = pwd; - C_gbl_status = tt_port_connect ( - hndl, chan, &lognam_desc, &pwd_desc); - }else { - C_gbl_status = tt_port_connect (hndl, chan, &lognam_desc, NULL); - } - - return (C_gbl_status & 1); - } -/*--------------------------------------------------------------------------*/ - int C_tt_port_disconnect (int *hndl) { -/* ==================== -** -** This routine is useful for calling TT_PORT_DISCONNECT from a C program. -** -** Inputs: -** hndl - the integer handle identifying the connection as returned -** by C_tt_port_connect. It is the address of a dynamically -** allocated data structure which will also be released -** after the connection has been closed. -** Return status: -** the return status of the function is zero (false) if TT_PORT_DISCONNECT -** returns an error (even) condition code. -** Global variables: -** C_gbl_status - set to the VAX/VMS return status of TT_PORT_DISCONNECT. -*/ - C_gbl_status = tt_port_disconnect (hndl); - - return (C_gbl_status & 1); - } -/*--------------------------------------------------------------------------*/ - int C_tt_port_io ( -/* ============ -*/ int *hndl, - char *rqst, - char *term, - char *answ, - int *answ_len, /* Attention -- Read/Write argument!! */ - int flush, - int tmo) { -/* -** This routine is useful for calling TT_PORT_IO from a C program. -** Refer to the DELTAT.OLB description of TT_PORT_IO to clarify any -** uncertainties in the following description. Note that all arguments -** must be present (there is no portable method in C of getting the -** number of arguments in the call!). -** Inputs: -** hndl - the integer handle identifying the connection as returned -** by C_tt_port_connect. -** rqst - an optional zero-terminated string specifying a character -** string to be sent to the port. Specify NULL to not send -** any characters to the port. -** term - an optional zero-terminated string specifying a list of -** terminating characters for input read from the port. -** Specify NULL to terminate input on an exact character cnt. -** flush - an integer specifying if the type-ahead buffer should be -** flushed before the operation. If non-zero, the buffer -** is flushed. -** tmo - an integer (recommended value = 2) specifying a read -** time-out in seconds. Zero or negative indicates infinity. -** Outputs: -** answ - an optional string buffer to receive characters read from -** the port. If answ is not NULL, answ_len must also be -** not NULL. On return, answ will be zero terminated. The -** terminating character, if any (there is no terminating -** char if the buffer overflows) and if there is room in -** the buffer, will follow the zero character. No padding is -** done. If answ is NULL, no characters are read from the -** port. -** Modify: -** answ_len - an integer specifying, on input, the length of answ in -** bytes. This must include room for the zero termination. -** On return, answ_len will be set to the number of -** characters read (not counting the zero termination byte or -** any terminating character). -** Return status: -** the return status of the function is zero (false) if TT_PORT_IO -** returns an error (even) condition code. -** Global variables: -** C_gbl_status - set to the VAX/VMS return status of TT_PORT_IO. -*/ - struct dsc$descriptor_s rqst_desc = {0, - DSC$K_DTYPE_T, - DSC$K_CLASS_S, - 0}; - struct dsc$descriptor_s term_desc = {0, - DSC$K_DTYPE_T, - DSC$K_CLASS_S, - 0}; - struct dsc$descriptor_s answ_desc = {0, - DSC$K_DTYPE_T, - DSC$K_CLASS_S, - 0}; - char *my_rqst = NULL; - char *my_term = NULL; - char *my_answ = NULL; - - int my_answ_len = 0; - int my_flush = 1; - int my_tmo = 2; - - my_tmo = tmo; - if (my_tmo < 0) my_tmo = 0; - my_flush = flush; - if (my_flush != 0) my_flush = 1; - if (answ != NULL) { - if (answ_len == 0) { - printf ("C_tt_port_io -- argument error.\n"); - printf (" %s\n", - "answ_len must be present if answ is present."); - C_gbl_status = FALSE; - return FALSE; - } - answ_desc.dsc$w_length = *answ_len - 1; - answ_desc.dsc$a_pointer = answ; - } - if (term != NULL) { - term_desc.dsc$w_length = strlen (term); - term_desc.dsc$a_pointer = term; - } - if (rqst != NULL) { - rqst_desc.dsc$w_length = strlen (rqst); - rqst_desc.dsc$a_pointer = rqst; - } - C_gbl_status = tt_port_io (hndl, &rqst_desc, &term_desc, - &answ_desc, &my_answ_len, &my_flush, &my_tmo); - if (answ_desc.dsc$w_length > 0) { /* Process any input string */ - if (answ_desc.dsc$w_length > my_answ_len) { /* Room for terminator? */ - answ[my_answ_len+1] = answ[my_answ_len]; /* Yes, so move it. */ - } - answ[my_answ_len] = '\0'; /* Put in null terminator */ - *answ_len = my_answ_len; /* Return value to caller */ - } - - return (C_gbl_status & 1); - } -/*--------------------------------------------------------------------------*/ - int C_tt_port_config ( -/* ================ -*/ int *hndl, - int mask) { -/* -** This routine is useful for calling TT_PORT_CONFIG from a C program. -** Refer to the DELTAT.OLB description of TT_PORT_CONFIG to clarify any -** uncertainties in the following description. -** Inputs: -** hndl - the integer handle identifying the connection as returned -** by C_tt_port_connect. -** mask - an integer specifying the configuration options. Set bits -** TT_PORT__NO_RETRY = 0x0001 to suppress retries on error -** TT_PORT__NO_SIG = 0x0002 to suppress signals on error -** Outputs: -** None -** Modify: -** None -** Return status: -** always non-zero (true). -** Global variables: -** C_gbl_status - set to the VAX/VMS return status of TT_PORT_CONFIG. -*/ - C_gbl_status = tt_port_config (hndl, &mask); - - return (C_gbl_status & 1); - } -/*=========================================== End of C_INTERFACES.C ========*/ diff --git a/hardsup/dillutil.c b/hardsup/dillutil.c deleted file mode 100644 index c9e8c490..00000000 --- a/hardsup/dillutil.c +++ /dev/null @@ -1,481 +0,0 @@ -/*-------------------------------------------------------------------------- - - D I L U T I L - - A few utility functions for dealing with a Dillution emperature controller - CC0-510/AVSI - within the SINQ setup: host -- TCP/IP -- MAC --- RS-232. - - Mark Koennecke, October 1997 - - Copyright: see copyrigh.h ----------------------------------------------------------------------------- */ -#include -#include -#include -#include -#include "serialsinq.h" -#include "dillutil.h" - -#ifdef FORTIFY -#include "../fortify.h" -#endif - -/* -#define debug 1 -*/ -/*-------------------------------------------------------------------------*/ - - int DILLU_Open(pDILLU *pData, char *pHost, int iPort, int iChannel, - int iMode, char *pTransFile) - { - int iRet; - char pCommand[80]; - char pReply[132]; - pDILLU self = NULL; - pSTable pTable = NULL; - FILE *fd = NULL; - - /* check translation file first */ - fd = fopen(pTransFile,"r"); - if(!fd) - { - return DILLU__FILENOTFOUND; - } - fgets(pReply, 131,fd); - if(strstr(pReply,"DILLUTION") == NULL) - { - fclose(fd); - return DILLU__NODILLFILE; - } - - pTable = CreateTable(fd); - fclose(fd); - if(!pTable) - { - return DILLU__ERRORTABLE; - } - - /* allocate a new data structure */ - self = (pDILLU)malloc(sizeof(DILLU)); - if(self == NULL) - { - return DILLU__BADMALLOC; - } - - *pData = self; - self->pTranstable = pTable; - - iRet = SerialOpen(&self->pData, pHost, iPort, iChannel); - if(iRet != 1) - { - return iRet; - } - - /* set an lengthy timeout for the configuration in order to - prevent problems. - */ - iRet = SerialConfig(&self->pData, 100); - if(iRet != 1) - { - return iRet; - } - - self->iReadOnly = iMode; - if(!self->iReadOnly) - { - /* switch to remote operation */ -/* iRet = SerialWriteRead(&self->pData,"C1\r\n",pReply,131); - if(iRet != 1) - { - return iRet; - } -*/ - } - return 1; - } -/* --------------------------------------------------------------------------*/ - void DILLU_Close(pDILLU *pData) - { - char pReply[132]; - int iRet; - pDILLU self; - - self = *pData; - - if(!self) - return; - - /* switch to local operation */ - iRet = SerialWriteRead(&self->pData,"C0\r\n",pReply,131); - /* ignore errors on this one, the thing may be down */ - - /* close connection */ - SerialClose(&self->pData); - - /* free memory */ - free(self); - *pData = NULL; - } -/* --------------------------------------------------------------------------*/ - int DILLU_Config(pDILLU *pData, int iTmo) - { - int iRet; - char pReply[132]; - char pCommand[10]; - pDILLU self; - - self = *pData; - - /* first timeout */ - if(iTmo > 0) - { - iRet = SerialConfig(&self->pData, iTmo); - if(iRet < 0) - { - return iRet; - } - } - return 1; - } -/* --------------------------------------------------------------------------*/ - int DILLU_Send(pDILLU *pData, char *pCommand, char *pReply, int iLen) - { - pDILLU self; - - self = *pData; - - /* make sure, that there is a \r at the end of the command */ - if(strchr(pCommand,(int)'\r') == NULL) - { - strcat(pCommand,"\r\n"); - } - return SerialWriteRead(&self->pData,pCommand,pReply,iLen); - } -/* --------------------------------------------------------------------------*/ - int DILLU_Read(pDILLU *pData, float *fVal) - { - char pCommand[10], pReply[132]; - int iRet; - float fRead = -9999.; - float fOhm; - pDILLU self; - - self = *pData; - - - /* send D command */ - sprintf(pCommand,"D\r\n"); - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - - /* read ohms */ - iRet = sscanf(pReply,"%f",&fOhm); - if(iRet != 1) - { - return DILLU__BADREAD; - } - if(fOhm > 9999890.) - { - return DILLU__SILLYANSWER; - } - - /* convert to K */ - iRet = InterpolateVal2(self->pTranstable,fOhm,&fRead); - *fVal = fRead; - return 1; - } -/*-------------------------------------------------------------------------*/ - int DILLU_Set(pDILLU *pData, float fVal) - { - char pCommand[50], pReply[132]; - int iRet, i,iRange, iExec; - const float fPrecision = 0.0001; - float fSet, fRead, fOhms, tmax, fTemp; - pDILLU self; - - self = *pData; - - if(self->iReadOnly) - { - return DILLU__READONLY; - } - - /* send D command to read current value*/ - sprintf(pCommand,"D\r\n"); - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - - /* read ohms */ - iRet = sscanf(pReply,"%f",&fRead); - if(iRet != 1) - { - return DILLU__BADREAD; - } - if(fRead > 9999890.) - { - return DILLU__SILLYANSWER; - } - - - /* convert new set value to ohms */ - iRet = InterpolateVal1(self->pTranstable,fVal,&fOhms); - if(!iRet) - { - return DILLU__OUTOFRANGE; - } - - /* set to remote operation */ -#ifdef debug - printf("C1\n"); -#endif - iRet = SerialWriteRead(&self->pData,"C1\r\n",pReply,131); - if(iRet != 1) - { - return iRet; - } - - /* set heater power */ - strcpy(pCommand,"G3\r"); - if(fOhms > 1125) - { - strcpy(pCommand,"G2\r"); - } - if(fOhms > 4000) - strcpy(pCommand,"G1\r"); -#ifdef debug - printf("A9\n"); -#endif - iRet = SerialWriteRead(&self->pData,"A9\r",pReply,131); - if(iRet != 1) - { - return iRet; - } -#ifdef debug - printf("%s\n",pCommand); -#endif - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - - /* Integrator time constant */ - strcpy(pCommand,"G2\r"); - if(fOhms > 200) - strcpy(pCommand,"G1\r"); - if(fOhms > 2000) - strcpy(pCommand,"G0\r"); - strcpy(pCommand,"G7\r"); - if(fOhms > 400.) - { - strcpy(pCommand,"G6\r"); - } -#ifdef debug - printf("A4\n"); -#endif - iRet = SerialWriteRead(&self->pData,"A4\r",pReply,131); - if(iRet != 1) - { - return iRet; - } -#ifdef debug - printf("%s\n",pCommand); -#endif - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - - /* derivator time constant */ - if(fOhms > 1000.) - { - strcpy(pCommand,"G1\r"); - } - else - { - strcpy(pCommand,"G2\r"); - } -#ifdef debug - printf("A5\n"); -#endif - iRet = SerialWriteRead(&self->pData,"A5\r",pReply,131); - if(iRet != 1) - { - return iRet; - } -#ifdef debug - printf("%s\n",pCommand); - iRet = 1; -#endif - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - - /* proportional gain */ - if(fOhms > 500.) - { - strcpy(pCommand,"G3\r"); - } - if(fOhms > 1000) - { - strcpy(pCommand,"G2\r"); - } - if(fOhms > 2000) - { - strcpy(pCommand,"G1\r"); - } -#ifdef debug - printf("A6\n"); -#endif - iRet = SerialWriteRead(&self->pData,"A6\r",pReply,131); - if(iRet != 1) - { - return iRet; - } -#ifdef debug - printf("%s\n",pCommand); -#endif - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - - /* range calculation a la Elsenhans */ - iRange = 1; - fTemp = fOhms*10000.; - if( (fRead > 1.9) || (fOhms > 1.9) ) - { - iRange = 2; - fTemp = fOhms*1000.; - } - if( (fRead > 19) || (fOhms > 19) ) - { - iRange = 3; - fTemp = fOhms*100.; - } - if( (fRead > 190) || (fOhms > 190) ) - { - iRange = 4; - fTemp = fOhms*10.; - } - if( (fRead > 750) || (fOhms > 750) ) - { - iRange = 5; - fTemp = fOhms; - } - if( (fRead > 19000) || (fOhms > 19000) ) - { - iRange = 6; - fTemp = fOhms/10.; - } - if( (fRead > 190000) || (fOhms > 190000) ) - { - iRange = 7; - fTemp = fOhms/100.; - } - - sprintf(pCommand,"R%1.1d\r",iRange); -#ifdef debug - printf("%s\n",pCommand); -#endif - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - - - /* finally set temperature */ -#ifdef debug - printf("Set Val befor hex: %d\n",(int)fTemp); -#endif - sprintf(pCommand,"G%4.4X\r",(int)fTemp); -#ifdef debug - printf("A3\n"); -#endif - iRet = SerialWriteRead(&self->pData,"A3\r",pReply,131); - if(iRet != 1) - { - return iRet; - } -#ifdef debug - printf("%s\n",pCommand); -#endif - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - - /* unset remote operation, so that users may mess everything up - from the panel - */ -#ifdef debug - printf("C1\n"); -#endif - iRet = SerialWriteRead(&self->pData,"C0\r\n",pReply,131); - if(iRet != 1) - { - return iRet; - } - - return 1; - } -/*-------------------------------------------------------------------------*/ - void DILLU_Error2Text(pDILLU *pData,int iCode, char *pError, int iLen) - { - char pBueffel[512]; - pDILLU self; - - self = *pData; - - switch(iCode) - { - case DILLU__FILENOTFOUND: - strncpy(pError,"Translation Table file not found",iLen); - return; - break; - case DILLU__NODILLFILE: - strncpy(pError,"Translation Table file is not DILLU",iLen); - return; - break; - case DILLU__ERRORTABLE: - strncpy(pError,"Translation Table could not be created",iLen); - return; - break; - case DILLU__BADREAD: - strncpy(pError,"Message corrupted",iLen); - return; - break; - case DILLU__SILLYANSWER: - strncpy(pError,"Message corrupted",iLen); - return; - break; - case DILLU__BADMALLOC: - strncpy(pError,"Out of memory in Open_DILLU",iLen); - return; - break; - case DILLU__READONLY: - strncpy(pError,"DILLU is read-only",iLen); - return; - break; - case DILLU__OUTOFRANGE: - strncpy(pError,"Requested value is out of range",iLen); - return; - break; - default: - SerialError(iCode,pError,iLen); - break; - } - } diff --git a/hardsup/dillutil.h b/hardsup/dillutil.h deleted file mode 100644 index b1ac9c33..00000000 --- a/hardsup/dillutil.h +++ /dev/null @@ -1,108 +0,0 @@ -/*--------------------------------------------------------------------------- - D I L U U T I L - - A few utility functions for talking to Dillution temperature controller - CCO-510/ AVSI via the SINQ setup: TCP/IP--MAC--RS-232--DILLU. - - This controller is weird in that way, that is accepts temperatures as - resistance values in Ohms. Therefore a translation table is required - in order to convert from Kelvin to Ohms. - - Mark Koennecke, October 1997 - -----------------------------------------------------------------------------*/ -#ifndef SINQDILLU -#define SINQDILLU -#include -#include "table.h" - -/*----------------------- ERRORCODES-------------------------------------- - Most functions return a negative error code on failure. Error codes - defined are those defined for serialsinq plus a few additional ones: -*/ -#define DILLU__FILENOTFOUND -710 -#define DILLU__NODILLFILE -711 -#define DILLU__ERRORTABLE -712 -#define DILLU__BADREAD -713 -#define DILLU__SILLYANSWER -714 -#define DILLU__READONLY -715 -#define DILLU__OUTOFRANGE -716 -#define DILLU__BADMALLOC -717 -#define DILLU__NODILLUFOUND -711 -/*------------------------------------------------------------------------*/ - typedef struct __DILLU { - void *pData; - pSTable pTranstable; - int iReadOnly; - } DILLU; - - typedef struct __DILLU *pDILLU; - -/*-----------------------------------------------------------------------*/ - int DILLU_Open(pDILLU *pData,char *pHost, int iPort, int iChannel, - int iMode, char *pTransFile); - /***** creates an DILLU datastructure and opens a connection to the ITCL4 - controller. Input Parameters are: - the hostname - the port number - the RS-232 channel number on the Mac. - iMode: 1 for ReadOnly, 0 for normal mode - pTransFile: name and path of the temperature ohms - trnslation file. - - Return values are 1 for success, a negative error code on - failure. - - */ - - void DILLU_Close(pDILLU *pData); - /****** close a connection to an DILLU controller and frees its - data structure. The only parameter is a pointer to the data - structure for this controller. This pointer will be invalid after - this call. - */ - - int DILLU_Config(pDILLU *pData, int iTmo); - /***** configure some aspects of a DILLU temperature controller. - The parameter are: - - a pointer to the data structure for the controller as - returned by Open_DILLU - - a value for the connection timeout - The function returns 1 on success, a negative error code on - failure. - */ - - int DILLU_Send(pDILLU *pData, char *pCommand, char *pReply, int iLen); - /******* send a the command in pCommand to the DILLU controller. - A possible reply is returned in the buffer pReply. - Maximum iLen characters are copied to pReply. - The first parameter is a pointer to a DILLU data structure - as returned by Open_DILLU. - - Return values are 1 for success, a negative error code on - failure. - */ - - int DILLU_Read(pDILLU *pData, float *fVal); - /****** - Reads the current temperature at the controller - - Return values are 1 for success, a negative error code on - failure. - */ - - int DILLU_Set(pDILLU *pData, float fVal); - /****** sets a new preset temperature in the DILL temperature - controller. Parameters are: - - a pointer to a DILLU data structure as returned by Open_DILLU. - - the new preset value. - - Return values are 1 for success, a negative error code on - failure. - */ - - void DILLU_Error2Text(pDILLU *pData, int iCode, char *pError, int iLen); - -#endif - - diff --git a/hardsup/el734_def.h b/hardsup/el734_def.h deleted file mode 100644 index f3a64379..00000000 --- a/hardsup/el734_def.h +++ /dev/null @@ -1,73 +0,0 @@ -#ifndef _el734_def_ -#define _el734_def_ -/*------------------------------------------------ EL734_DEF.H Ident V01R -*/ -#include -#include -#include - -#ifndef OffsetOf -#define OffsetOf(type, identifier) ((size_t)(&((type*) NULL)->identifier)) -#endif - -#ifndef _EL734_errcodes_ -#define _EL734_errcodes_ -#include -#endif - -#define MAX_MOT 12 - -enum EL734_Requests {FULL__STATUS, - SHORT__STATUS}; -/* -** Structure to which the EL734_Open handle points. -*/ - struct EL734info { - struct AsynSrv__info asyn_info; /* Contains skt, host, port & chan */ - int motor; - int ored_msr, fp_cntr, fr_cntr; - struct RS__MsgStruct to_host; - struct RS__RespStruct from_host; - }; -/* -** Structure holding everything that is known about a VME Motor Controller. -** It is also the structure of replies from the Server. -*/ - struct Motor_State { - int motor; /* Motor number */ - int exists; /* True if Motor exists */ - int msr; /* MSR - Motor Status Register */ - int ored_msr; /* Cumulated MSR */ - int fp_cntr; /* Counter for *FP reports */ - int fr_cntr; /* Counter for *FR reports */ - int ss; /* SS - Status Flags Register */ - char pos_real[16]; /* U - Position as read (degrees) */ - char name[16]; /* MN */ - int dec_pt; /* A - # of decimal places */ - int enc_factor[2]; /* FD - Encoder scaling factors (numer/denom) */ - int mot_factor[2]; /* FM - Motor scaling factors (numer/denom) */ - char inertia_tol[16];/* D - Inertia tol'nce (sec) (Schleppfehler) */ - int ramp; /* E - Start/stop ramp (kHz/sec) */ - int loop_mode; /* F - Open loop/Closed loop (0/1) */ - int slow_hz; /* G - Start/stop frequency (Mot-S/sec) */ - char lims[2][16]; /* H - Lower/Upper limits */ - int fast_hz; /* J - Top speed (Mot-S/sec) */ - int ref_mode; /* K - Reference mode */ - int backlash; /* L - Backlash par (Mot-S) (Spielausgleich) */ - int pos_tol; /* M - Position tolerance (Enc-Steps) */ - char ref_param[16]; /* Q - Parameter for "Goto Reference" */ - int is_sided; /* T - One-sided operation flag (0 = no) */ - char null_pt[16]; /* V - Null point */ - int ac_par; /* W - Air-cushion dependency */ - int enc_circ; /* Z - circumference of encoder (Enc-Steps) */ - int stat_pos; /* SP - # of positionings */ - int stat_pos_flt; /* ST - # of positioning faults (recovered) */ - int stat_pos_fail; /* SR - # of positioning fails (abandoned) */ - int stat_cush_fail; /* SA - # of air-cushion fails */ - char set_real[16]; /* P - Position as set (degrees) */ - int ac_state; /* AC - Air-cushion state (0 = down) */ - int out; /* SO - State of Output Signal */ - int in; /* RI - State of Input Signal */ - }; -/*------------------------------------------------ End of EL734_DEF.H --*/ -#endif /* _el734_def_ */ diff --git a/hardsup/el734_errcodes.h b/hardsup/el734_errcodes.h deleted file mode 100644 index 1a04d812..00000000 --- a/hardsup/el734_errcodes.h +++ /dev/null @@ -1,28 +0,0 @@ -/* -** TAS_SRC:[LIB]EL734_ERRCODES.H -** -** Include file generated from EL734_ERRCODES.OBJ -** -** 29-AUG-2000 09:49:19.60 -*/ - -#define EL734__VFY_ERR 0x865809C -#define EL734__NO_SOCKET 0x8658094 -#define EL734__NOT_OPEN 0x865808C -#define EL734__FORCED_CLOSED 0x8658084 -#define EL734__EMERG_STOP 0x865807C -#define EL734__BAD_TMO 0x8658074 -#define EL734__BAD_STP 0x865806C -#define EL734__BAD_SOCKET 0x8658064 -#define EL734__BAD_RNG 0x865805C -#define EL734__BAD_PAR 0x8658054 -#define EL734__BAD_OVFL 0x865804C -#define EL734__BAD_OFL 0x8658044 -#define EL734__BAD_MALLOC 0x865803C -#define EL734__BAD_LOC 0x8658034 -#define EL734__BAD_ILLG 0x865802C -#define EL734__BAD_DEV 0x8658024 -#define EL734__BAD_CMD 0x865801C -#define EL734__BAD_ASYNSRV 0x8658014 -#define EL734__BAD_ADR 0x865800C -#define EL734__FACILITY 0x865 diff --git a/hardsup/el734_utility.c b/hardsup/el734_utility.c deleted file mode 100644 index 53efe510..00000000 --- a/hardsup/el734_utility.c +++ /dev/null @@ -1,2638 +0,0 @@ -#define ident "1D08" -#ifdef VAXC -#module EL734_Utility ident -#endif -#ifdef __DECC -#pragma module EL734_Utility ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Department ASQ | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]EL734_Utility.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Nov 1995 -** -** To compile this module, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]EL734_Utility - - tasmad_disk:[mad.psi.lib.sinq]EL734_Utility + - - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb EL734_Utility debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb EL734_Utility -** -** Updates: -** 1A01 2-Nov-1995 DM. Initial version. -** 1B01 21-Mar-1996 DM. Move from DELTAT.OLB to SINQ.OLB. -** 1C01 3-Mar-1997 DM. Add "Forced-close" capability. -** 1C02 14-Apr-1997 DM. Add EL734__BAD_STP to EL734_MoveNoWait. -** 1C11 18-Jun-1998 DM. Modify EL734_GetZeroPoint. -** 1D01 4-Aug-1998 DM. Put messages into a .MSG file. -**============================================================================ -** The entry points included in this module are described below. Prototypes -** can be defined via: -** -** #include -** -** EL734_AddCallStack - Add a routine name to the call stack. -** EL734_Close - Close a connection to a motor. -** EL734_Config - Configure a connection to a motor. -** EL734_EncodeMSR - Encode the MSR status into text. -** EL734_EncodeSS - Encode the SS flags into text. -** EL734_ErrInfo - Return detailed status from last operation. -** EL734_GetAirCush - Get W and AC register values. -** EL734_GetEncGearing - Get FD register values. -** EL734_GetId - Get ID register value. -** EL734_GetLimits - Get H register values. -** EL734_GetMotorGearing - Get FM register values. -** EL734_GetNullPoint - Get V register value. -** EL734_GetPosition - Get U register value = current position. -** EL734_GetPrecision - Get A register value. -** EL734_GetRefMode - Get K register value. -** EL734_GetRefParam - Get Q register value. -** EL734_GetSpeeds - Get G, J and E register values. -** EL734_GetStatus - Get MSR/SS/U register values. -** EL734_GetZeroPoint - Get zero-point of motor. -** EL734_MoveNoWait - Move motor and don't wait for completion. -** EL734_MoveWait - Move motor and wait for completion. -** EL734_Open - Open a connection to a motor. -** EL734_PutOffline - Put the EL734 off-line. -** EL734_PutOnline - Put the EL734 on-line. -** EL734_SendCmnd - Send a command to RS232C server. -** EL734_SetAirCush - Set the air-cushion (AC register). -** EL734_SetErrcode - Set up EL734_errcode. -** EL734_SetHighSpeed - Set the max speed (J register). -** EL734_SetLowSpeed - Set the start/stop speed (G register). -** EL734_SetRamp - Set the start/stop ramp (E register). -** EL734_Stop - Send a stop command to motor. -** EL734_WaitIdle - Wait till MSR goes to zero. -** EL734_ZeroStatus - Zero the "ored-MSR" and fault counters. -**--------------------------------------------------------------------- -** int EL734_AddCallStack (&handle, &name) -** ------------------ -** Add a routine name to the call stack (internal use). -** Input Args: -** struct EL734info *handle - The pointer to the structure returned by -** EL734_Open. -** char *name - The name to be added to the call stack. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** False if an error is detected, otherwise True. -** Routines called: -** none -** Description: -** If an error has already occurred (EL734_errcode != 0), the routine -** simply returns False. Otherwise, *name is added to the call stack. -** Then *handle is checked. -** If NULL, error EL734__NOT_OPEN is set and False is returned. -** Otherwise, the connection's TCP/IP socket number is checked. -** If zero, error EL734__NO_SOCKET is set and False is returned. -** If negative, error EL734__FORCED_CLOSE is set and False is returned. -** Otherwise, True is returned. -**--------------------------------------------------------------------- -** int EL734_Close (&handle, int force_flag) -** ----------- -** Close a connection to a motor. -** Input Args: -** int force_flag - if non-zero, all connections using the same socket -** will also be closed (this gets AsynSrv_Close to -** actually close the socket and is needed for error -** recovery operations). -** Output Args: -** none -** Modified Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** On return, the pointer is set to NULL. -** Return status: -** True always (error returns from close and free are not checked). -** Routines called: -** AsynSrv_Close -** Description: -** The routine calls AsynSrv_Close to close the connection to the RS232C -** server. If 'force_flag' is non-zero, all other connections to the -** RS232C server which use the same socket will also be closed. -** -** The 'force_flag' can be useful in error recovery situations. The AsynSrv -** utility operates by only opening a socket for each separate combination -** of host/port. Hence, if several connections are open to the -** motors on an EL734, then calling EL734_Close doesn't actually close -** the socket until all connections have been closed. In the situation -** where an error has been detected on a motor, it is often desirable to -** close and re-open the socket as part of the recovery procedure. Calling -** EL734_Close with 'force_flag' non-zero will force the socket to be -** closed and will mark all connections using this socket so that they -** will be informed of the event when they next call an EL734_utility -** routine. -** -** Note: The force-close action is effected by the AsynSrv package. A -** force-close will thus also close any connections to other -** RS-232-C devices (e.g. EL737 neutron cntr) on the same server. -**------------------------------------------------------------------------- -** int EL734_Config (&handle, &par_id, par_val, ...) -** ------------ -** Configure a connection to a motor. -** Input Args: -** char* par_id - Text string identifying the next argument (see below). -** NULL indicates the end of the argument list. -** par_val - The value to set for the argument. The type of the -** argument can depend on par_id. -** Output Args: -** none -** Modified Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** It is used to hold the config info for the connection. -** Return status: -** True if no problems detected, otherwise False and EL734_errcode -** is set to indicate the nature of the problem as follows: -** EL734__BAD_PAR --> Unrecognised par_id or msecTmo < 100 or -** msecTmo > 999'999 or bad eot or .. -** Routines called: -** none -** Description: -** The routine sets values in the EL734info data structure. Values which -** may be taken by par_id (warning -- par_id is case-sensitive) and the -** corresponding variable type of par_val are: -** -** "msecTmo" int The time-out response for commands sent to -** the EL734. The valid range is 100 to -** 999'999. Default is 10'000. -** "eot" char* The expected terminators in responses to -** commands sent to the EL734. The first -** character specifies the number of -** terminators (max=3). Default is "1\r". -** "motor" int The index of the motor in the range 1-12 to be -** associated with this connection. -** "chan" int The RS-232-C channel number of the EL734 -** controller associated with this connection. -**------------------------------------------------------------------------- -** char *EL734_EncodeMSR (&text, text_len, msr, ored_msr, fp_cntr, fr_cntr) -** --------------- -** Encode the MSR status into text. -** Input Args: -** int text_len - The size of text. -** int msr - The current MSR. -** int ored_msr - The 'ored' MSR to be encoded. -** int fp_cntr - The counter of *FP faults. -** int fr_cntr - The counter of *FR faults. -** Output Args: -** char *text - The resulting text string is stored here. -** Modified Args: -** none -** Return status: -** A pointer to "text". -** Routines called: -** none -** Description: -** The routine makes an intelligible message out of the MSR input data. -**------------------------------------------------------------------------- -** char *EL734_EncodeSS (&text, text_len, ss) -** -------------- -** Encode the SS flags into text. -** Input Args: -** int text_len - The size of text. -** int ss - The value of SS register. -** Output Args: -** char *text - The resulting text string is stored here. -** Modified Args: -** none -** Return status: -** A pointer to "text". -** Routines called: -** none -** Description: -** The routine makes an intelligible message out of the input SS data. -**------------------------------------------------------------------------- -** void EL734_ErrInfo (&entry_txt_ptr, &errcode, &my_errno, &vaxc_errno) -** ------------- -** Return detailed status from last operation. -** Input Args: -** None -** Output Args: -** char **entry_txt_ptr - Pointer to a text string giving the call stack -** at the time that the error was detected. -** int *errcode - An internal error code indicating the detected error. -** int *my_errno - Saved value of errno. -** int *vaxc_errno - Saved value of vaxc$errno (OpenVMS only). -** Modified Args: -** none -** Return status: -** none -** Routines called: -** none -** Description: -** Returns detailed status of the last operation. Once an error has been -** detected, the error status is frozen until this routine has been called. -**------------------------------------------------------------------------- -** int EL734_GetAirCush (&handle, &present, &state) -** ---------------- -** Get W and AC register values. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** int *present - The W register. If non-zero, motor has an air-cushion. -** int *state - The AC register. If non-zero, air-cushion is up. -** Description: -** The routine is the same as EL734_GetEncGearing except that it issues -** a "W" command and then an "AC" command instead of an "FD" command to -** the controller. -**------------------------------------------------------------------------- -** int EL734_GetEncGearing (&handle, &numerator, &denominator) -** ------------------- -** Get FD register values. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** int *numerator - The encoder gearing numerator. -** int *denominator - The encoder gearing denominator. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL734_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL734_GetEncGearing are (other values may be set by the called -** routines): -** EL734__BAD_TMO, BAD_LOC, BAD_CMD, BAD_OFL, -** BAD_ADR, EMERG_STOP --> see EL734_Open. -** EL734__BAD_ILLG --> the response was probably not 2 integers. -** This could happen if there is noise on the -** RS232C connection to the EL734. -** If an error is detected, *numerator and *denominator are set to 0. -** Routines called: -** EL734_AddCallStack, AsynSrv_SendCmnds, AsynSrv_GetReply -** Description: -** The routine issues an "FD" command to the controller and analyses -** the result. The two parameters of the "FD" command are the numerator -** and denominator respectively. -**------------------------------------------------------------------------- -** int EL734_GetId (&handle, &id_txt, id_len) -** ----------- -** Get ID register value. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** int id_len - The size of the buffer in bytes. -** Output Args: -** char *id_txt - The EL734 identifier ("ID" parameter). -** Description: -** The routine is the same as EL734_GetEncGearing except that it issues -** an "ID" command instead of an "H" command to the controller. -**------------------------------------------------------------------------- -** int EL734_GetLimits (&handle, &lo, &hi) -** --------------- -** Get H register values. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** float *lo - The lower software limit. -** float *hi - The higher software limit. -** Description: -** The routine is the same as EL734_GetEncGearing except that it issues -** an "H" command instead of an "FD" command to the controller. -**------------------------------------------------------------------------- -** int EL734_GetMotorGearing (&handle, &numerator, &denominator) -** --------------------- -** Get FM register values. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** int *numerator - The motor gearing numerator. -** int *denominator - The motor gearing denominator. -** Description: -** The routine is the same as EL734_GetEncGearing except that it issues -** an "FM" command instead of an "FD" command to the controller. The -** two parameters of the "FM" command are the numerator and denominator -** respectively. -**------------------------------------------------------------------------- -** int EL734_GetNullPoint (&handle, &null_pt) -** ------------------ -** Get V register value. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** int *null_pt - The null point ("V" parameter) of the EL734. -** Description: -** The routine is the same as EL734_GetEncGearing except that it issues -** a "V" command instead of an "FD" command to the controller. -**------------------------------------------------------------------------- -** int EL734_GetPosition (&handle, &ist_posit) -** ----------------- -** Get U register value = current position. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** float *ist_posit - The current position (U command) of the motor. -** Description: -** The routine is the same as EL734_GetEncGearing except that it issues -** a "U" command instead of an "FD" command to the controller. -**------------------------------------------------------------------------- -** int EL734_GetPrecision (&handle, &n_dec) -** ------------------ -** Get A register value. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** int *n_dec - The precision ("A" parameter) of the EL734. -** Description: -** The routine is the same as EL734_GetEncGearing except that it issues -** a "A" command instead of an "FD" command to the controller. -**------------------------------------------------------------------------- -** int EL734_GetRefMode (&handle, &mode) -** ---------------- -** Get K register value. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** int *mode - The reference seek mode ("K" parameter) of the EL734. -** Description: -** The routine is the same as EL734_GetEncGearing except that it issues -** a "K" command instead of an "FD" command to the controller. -**------------------------------------------------------------------------- -** int EL734_GetRefParam (&handle, ¶m) -** ----------------- -** Get Q register value. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** float *param - The reference seek param ("Q" parameter) of the EL734. -** Description: -** The routine is the same as EL734_GetEncGearing except that it issues -** a "Q" command instead of an "FD" command to the controller. -**------------------------------------------------------------------------- -** int EL734_GetSpeeds (&handle, &lo, &hi, &ramp) -** --------------- -** Get G, J and E register values. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** int *lo - The start/stop speed (G register). Units = Steps/sec. -** int *hi - The maximum speed (J register). Units = Steps/sec. -** int *ramp - The start/stop ramp (E register). Units = kHz/sec. -** Description: -** The routine is the same as EL734_GetEncGearing except that it issues -** a "G", "J" and "E" commands instead of an "FD" command to the -** controller. -**------------------------------------------------------------------------- -** int EL734_GetStatus (&handle, &msr, &ored_msr, &fp_cntr, &fr_cntr, -** --------------- &ss, &ist_posit) -** Get MSR/SS/U register values. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** int *msr - The MSR register. -** int *ored_msr - The 'ored'-MSR register. This gets zeroed every time -** a 'positioning' command is executed. -** int *fp_cntr - A counter of the 'Position Faults' (*FP). This gets -** zeroed whenever ored_msr is zeroed. -** int *fr_cntr - A counter of the 'Run Faults' (*FR). This gets -** zeroed whenever ored_msr is zeroed. -** int *ss - The SS register. This will be -1 if the motor is busy. -** float *ist_posit - The current position (U command) of the motor. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL734_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL734_GetStatus are (other values may be set by the called routines): -** EL734__BAD_TMO, BAD_LOC, BAD_CMD, BAD_OFL, -** BAD_ADR, EMERG_STOP --> see EL734_Open. -** EL734__BAD_ILLG --> one of the responses could probably not -** be decoded. This could happen if there is noise -** on the RS232C connection to the EL734. -** If an error is detected, ist_posit is set to 0.0 and all other -** arguments to -1. -** Routines called: -** EL734_AddCallStack, AsynSrv_SendCmnds, AsynSrv_GetReply -** Description: -** The routine issues an "MSR", "SS" and "U" command to the controller and -** analyses the result. A count is kept of each time the *FP and *FR bits -** are found to be set and an inclusive-or value of MSR is maintained. -**------------------------------------------------------------------------- -** int EL734_GetZeroPoint (&handle, &zero_pt) -** ------------------ -** Get zero-point of motor. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** float *zero_pt - The zero point of the EL734. -** Return status: -** Any of the errors generated by the called routines is possible plus: -** EL734__BAD_OVFL --> The encoder gearing ratio is zero so -** the conversion would overflow. -** Routines called: -** EL734_AddCallStack, EL734_GetEncGearing, EL734_GetNullPoint -** Description: -** This routine returns the zero point of the motor in the same units -** as used by the "P" and "U" commands. In other words, it reads the -** "V" parameter and converts it from "encoder-step" units to physical -** units using the encoder-gearing parameters. -**------------------------------------------------------------------------- -** int EL734_MoveNoWait (&handle, soll_posit) -** ---------------- -** Move motor and don't wait for completion. -** Input Args: -** void **handle - The pntr to the structure returned by EL734_Open. -** float soll_posit - The position to which the motor should move. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL734_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL734_MoveNoWait are (other values may be set by the called routines): -** EL734__BAD_TMO, BAD_LOC, BAD_CMD, BAD_OFL, -** BAD_ADR, EMERG_STOP --> see EL734_Open. -** EL734__BAD_RNG --> Destination is out-of-range. -** EL734__BAD_STP --> Motor is disabled via Hardware "Stop" -** signal. -** EL734__BAD_ILLG --> some other response obtained from EL734. -** This could happen if there is noise -** on the RS232C connection to the EL734. -** Routines called: -** EL734_AddCallStack, AsynSrv_SendCmnds, AsynSrv_GetReply -** Description: -** The appropriate "P" command is sent to the motor and the response -** checked to check that it has been accepted. The fields "ored_msr", -** "fp_cntr" and "fr_cntr" in the handle are cleared, if so. -**------------------------------------------------------------------------- -** int EL734_MoveWait (&handle, soll_posit, &ored_msr, &fp_cntr, &fr_cntr, -** -------------- &ist_posit) -** Move motor and wait for completion. -** Input Args: -** void **handle - The pntr to the structure returned by EL734_Open. -** float soll_posit - The position to which the motor should move. -** Output Args: -** int *ored_msr \ -** int *fp_cntr \ Same as EL734_WaitIdle. -** int *fr_cntr / -** float *ist_posit / -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False. If False, errcode (see -** EL734_ErrInfo) will have been set by EL734_MoveNoWait or EL734_WaitIdle. -** Routines called: -** EL734_AddCallStack, EL734_MoveNoWait, EL734_WaitIdle -** Description: -** The routine calls EL734_MoveNoWait and, if successful, EL734_WaitIdle. -**------------------------------------------------------------------------- -** int EL734_Open (&handle, host, port, chan, motor, id) -** ---------- -** Open a connection to a motor. -** Input Args: -** char *host - Name of host offering the TCP/IP service. -** int port - Number of TCP/IP port of TCP/IP server. -** int chan - RS-232-C Channel number on the TCP/IP server. -** int motor - The motor to be driven. -** char *id - The expected ID of the device, normally "STPMC EL734". -** If id is NULL, the device ID is not checked. -** Output Args: -** void *handle - A pointer to a structure of type EL734info needed for -** subsequent calls to EL734_... routines. Buffer space -** for the structure is allocated dynamically. It gets -** released via a call to EL734_Close. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False. If False, EL734_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL734_Open are (other values may be set by the called routines): -** EL734__BAD_TMO --> Time-out error ("?TMO" - this gets -** generated by the RS232C server). -** EL734__BAD_LOC --> EL734 off-line ("?LOC"). This should not -** happen on calls to EL734_Open since it -** sends an "RMT 1" cmnd. -** EL734__BAD_CMD --> Command error ("?CMD"). This could be -** caused by noise in the RS-232-C -** transmission. -** EL734__BAD_OFL --> Connection to EL734 broken ("?OFL"). -** This can get generated by RS232C_SRV -** if, for example, the connection is via -** a terminal server and the terminal -** server loses power. -** EL734__BAD_ILLG --> Some other unrecognised response. This -** should never occur, of course! -** EL734__BAD_SOCKET --> Call to "AsynSrv_Open" failed. -** EL734__BAD_DEV --> Device has wrong ID -** EL734__BAD_MALLOC --> Call to "malloc" failed -** EL734__BAD_ADR --> Bad motor address ("?ADR"). Probably -** a non-existent motor has been addressed. -** EL734__EMERG_STOP --> Emergency stop ("*ES") detected. -** Routines called: -** AsynSrv_Open, the memory alloc routine "malloc", StrJoin, -** EL734_Config, AsynSrv_SendCmnds, AsynSrv_GetReply, -** AsynSrv_Close (if an error is detected). -** Description: -** The routine calls AsynSrv_Open to open a TCP/IP connection to a server -** offering the "RS-232-C" service for an EL734 Motor Controller. "RMT 1" -** and "ECHO 0" commands are sent to ensure the device is on-line, an "ID" -** command is sent (only if 'id' is non-NULL) to ensure that an EL734 is -** being addressed and an "MSR " command is sent to ensure that -** the motor exists. -** Note: -** For all error status returns, there is no open connection to the server -** and the handle is set to zero. -**------------------------------------------------------------------------- -** int EL734_PutOffline (&handle) -** ---------------- -** Send "ECHO 1" and "RMT 0" commands to EL734 server. -** Input Args: -** void **handle - The pntr to the structure returned by EL734_Open. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and errcode (see -** EL734_ErrInfo) is set to indicate the nature of the problem. -** Values of Errcode set by EL734_PutOffline are (other values may be set -** by the called routines): -** EL734__BAD_ASYNSRV --> An error occurred in AsynSrv_Utility. -** Call AsynSrv_ErrInfo for more info. -** EL734__BAD_ILLG --> an unrecognised response. This -** should never occur, of course! -** Routines called: -** EL734_AddCallStack, AsynSrv_SendCmnds, AsynSrv_GetReply -** Description: -** The routine calls AsynSrv_SendCmnds to execute "RMT 1", "ECHO 1" -** and "RMT 0" commands. The replies are checked. -**------------------------------------------------------------------------- -** int EL734_PutOnline (&handle, echo) -** --------------- -** Send "RMT 1" and "ECHO x" commands to EL734 server. -** Input Args: -** void **handle - The pntr to the structure returned by EL734_Open. -** int echo - The value for the ECHO command. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and errcode (see -** EL734_ErrInfo) is set to indicate the nature of the problem. -** Values of Errcode set by EL734_PutOnline are (other values may be set -** by the called routines): -** EL734__BAD_PAR --> "echo" is not 0, 1 or 2. -** EL734__BAD_ASYNSRV --> An error occurred in AsynSrv_Utility. -** Call AsynSrv_ErrInfo for more info. -** EL734__BAD_ILLG --> an unrecognised response. This -** should never occur, of course! -** Routines called: -** EL734_AddCallStack, AsynSrv_SendCmnds, AsynSrv_GetReply -** Description: -** The routine calls AsynSrv_SendCmnds to execute "RMT 1" and "ECHO x" -** commands. The replies are checked. -**------------------------------------------------------------------------- -** int EL734_SendCmnd (&handle, &cmnd, &rply, rply_size) -** -------------- -** Send a command to RS232C server. -** Input Args: -** void **handle - The pntr to the structure returned by EL734_Open. -** char *cmnd - A command, terminated by NULL, for sending to the -** EL734 counter controller. The command must have -** any necessary \r character included. -** int rply_size - the size of the buffer. -** Output Args: -** char *rply - A buffer for receiving the reply. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and errcode (see -** EL734_ErrInfo) is set to indicate the nature of the problem. -** Values of Errcode set by EL734_SendCmnd are (other values may be set -** by the called routines): -** EL734__BAD_ASYNSRV --> An error occurred in AsynSrv_Utility. -** Call AsynSrv_ErrInfo for more info. -** Routines called: -** EL734_AddCallStack, AsynSrv_SendCmnds, AsynSrv_GetReply -** Description: -** The command is passed to AsynSrv_SendCmnds and the reply extracted. -**------------------------------------------------------------------------- -** int EL734_SetAirCush (&handle, state) -** ---------------- -** Set AC register value. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Input Args: -** int state - The new state of the AC register. 0 --> down -** non-zero --> up -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL734_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL734_SetAirCush are (other values may be set by the called -** routines): -** EL734__BAD_TMO, BAD_LOC, BAD_CMD, BAD_OFL, -** BAD_ADR, EMERG_STOP --> see EL734_Open. -** EL734__VFY_ERR --> the value for the AC register returned by the -** call to EL734_GetAirCush was not the value which -** was sent via the AC command. This could happen -** if there is noise on the RS232C connection to -** the EL734. -** Routines called: -** EL734_AddCallStack, AsynSrv_SendCmnds, AsynSrv_GetReply, -** EL734_GetAirCush -** Description: -** The routine issues an "AC" command to the controller to set the air- -** cushions of the motor up or down. It then calls EL734_GetAirCush -** to check that the air-cushions were set correctly. -**------------------------------------------------------------------------- -** int EL734_SetErrcode (&info_ptr, &response, &cmnd) -** ---------------- -** Set up EL734_errcode (for internal use only) -** Input Args: -** struct EL734info *info_ptr - The pntr to the structure returned by -** EL734_Open. -** char *response - The response received from a command. -** char *cmnd - The command which was sent. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** The value of EL734_errcode. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** The command checks *response for certain keywords. If not recognised, -** extra action is undertaken to try to see if the emergency stop state -** is active or not. -**------------------------------------------------------------------------- -** int EL734_SetHighSpeed (&handle, hi) -** ------------------ -** Set J register value. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Input Args: -** int hi - The maximum speed (J register). Units = Steps/sec. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL734_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL734_SetHighSpeed are (other values may be set by the called -** routines): -** EL734__BAD_TMO, BAD_LOC, BAD_CMD, BAD_OFL, -** BAD_ADR, EMERG_STOP --> see EL734_Open. -** EL734__VFY_ERR --> the value for the J register returned by the call -** to EL734_GetSpeeds was not the value which was -** sent via the J command. This could happen if -** there is noise on the RS232C connection to -** the EL734. -** Routines called: -** EL734_AddCallStack, AsynSrv_SendCmnds, AsynSrv_GetReply, EL734_GetSpeeds -** Description: -** The routine issues a "J" command to the controller to set the max speed -** of the motor. It then calls EL734_GetSpeeds to check that the speed -** was set correctly. -**------------------------------------------------------------------------- -** int EL734_SetLowSpeed (&handle, hi) -** ----------------- -** Set G register value. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Input Args: -** int lo - The start/stop speed (G register). Units = Steps/sec. -** Description: -** The routine is identical to the EL734_SetHighSpeed routine except that -** a "G" command rather than a "J" command is issued to the controller to -** set the start/stop speed. -**------------------------------------------------------------------------- -** int EL734_SetRamp (&handle, ramp) -** ------------- -** Set E register value. -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Input Args: -** int ramp - The start/stop ramp (E register). Units = kHz/sec. -** Description: -** The routine is identical to the EL734_SetHighSpeed routine except that -** an "E" command rather than a "J" command is issued to the controller to -** set the start/stop ramp. -**------------------------------------------------------------------------- -** int EL734_Stop (&handle) -** ---------- -** Send a stop command to motor -** Input Args: -** void **handle - The pointer to the structure returned by EL734_Open. -** Output Args: -** None -** Description: -** The routine is similar to EL734_GetEncGearing except that it issues -** a "Q m" command instead of an "FD" command to the controller and -** a null response (rather than parameter values) is expected. -**------------------------------------------------------------------------- -** int EL734_WaitIdle (&handle, &ored_msr, &fp_cntr, &fr_cntr, &ist_posit) -** -------------- -** Wait till MSR goes to zero. -** Input Args: -** void **handle - The pntr to the structure returned by EL734_Open. -** Output Args: -** int *ored_msr \ -** int *fp_cntr \ Same as EL734_GetStatus. -** int *fr_cntr / -** float *ist_posit / -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and Errcode (see -** EL734_ErrInfo) will have been set by the called routines to indicate -** the nature of the problem. -** Routines called: -** EL734_AddCallStack, EL734_GetStatus -** Description: -** Routine EL734_GetStatus is called repeatedly at a predefined frequency -** until the MSR__BUSY bit in the MSR register is zero. -**------------------------------------------------------------------------- -** void EL734_ZeroStatus (&handle) -** ----------------- -** Zero the "ored-MSR" and fault counters. -** Input Args: -** void **handle - The pntr to the structure returned by EL734_Open. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** none -** Routines called: -** none -** Description: -** The "ored-MSR" and fault counters in the handle are zeroed. -**============================================================================*/ -/* -**--------------------------------------------------------------------------- -** Global Definitions -*/ -#include -#include -#include -#include -#include -#include -#include -#include - -#include - -#ifdef __VMS -#include -#else -#include -#ifdef FORTIFY -#include -#endif -#endif -/*-----------------------------------------------------------------*/ -#include -#include -#include -#include - -#define True 1 -#define False 0 -/*-------------------------------------------------------------------------- -** Global Variables -*/ - static int EL734_call_depth = 0; - static char EL734_routine[5][64]; - static int EL734_errcode = 0; - static int EL734_errno, EL734_vaxc_errno; - char EL734_IllgText[256]; -/* -**--------------------------------------------------------------------------- -** EL734_AddCallStack: Add a routine name to the call stack. -** This allows EL734_ErrInfo to generate a -** trace-back in case of error. -*/ - int EL734_AddCallStack ( -/* ================== -*/ struct EL734info *pntr, - char *name) { - - if (EL734_errcode != 0) return False; - - if (EL734_call_depth < 5) { - strcpy (EL734_routine[EL734_call_depth], name); - EL734_call_depth++; - } - - if (pntr == NULL) {EL734_errcode = EL734__NOT_OPEN; return False;} - - if (pntr->asyn_info.skt <= 0) { - memset (pntr->from_host.msg_size, - '0', sizeof (pntr->from_host.msg_size)); - EL734_errcode = (pntr->asyn_info.skt < 0) ? EL734__FORCED_CLOSED - : EL734__NO_SOCKET; - return False; - } - return True; - } -/* -**--------------------------------------------------------------------------- -** EL734_Close: Close a connection to a motor. -*/ - int EL734_Close ( -/* =========== -*/ void **handle, - int force_flag) { - - struct EL734info *info_ptr; - char buff[4]; - - info_ptr = (struct EL734info *) *handle; - if (info_ptr == NULL) return True; - - if (info_ptr->asyn_info.skt != 0) { - if (info_ptr->asyn_info.skt > 0) { - AsynSrv_Close (*handle, force_flag); - } - } - free (*handle); - *handle = NULL; - - return True; - } -/* -**--------------------------------------------------------------------------- -** EL734_Config: Configure a connection to a motor. -*/ - int EL734_Config ( -/* ============ -*/ void **handle, - ...) { - - char buff[16]; - va_list ap; /* Pointer to variable args */ - char *txt_ptr; - int intval; - struct EL734info *info_ptr; - /*---------------------------------------------- - */ - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_Config")) return False; - /*---------------------------------------------- - */ - va_start (ap, handle); /* Set up var arg machinery */ - txt_ptr = va_arg (ap, char *); /* Get pntr to first parameter ident */ - while (txt_ptr != NULL) { - if (strcmp (txt_ptr, "msecTmo") == 0) { - intval = va_arg (ap, int); - if ((intval < 100) || (intval > 999999)) { - EL734_errcode = EL734__BAD_PAR; - return False; - } - sprintf (buff, "%04d", intval/100); /* Convert to ASCII as .. - ** .. deci-secs */ - memcpy (info_ptr->asyn_info.tmo, buff, 4); - }else if (strcmp (txt_ptr, "eot") == 0) { - txt_ptr = va_arg (ap, char *); - if (txt_ptr == NULL) { - EL734_errcode = EL734__BAD_PAR; - return False; - } - memcpy (info_ptr->asyn_info.eot, "\0\0\0\0", 4); - switch (txt_ptr[0]) { - case '3': info_ptr->asyn_info.eot[3] = txt_ptr[3]; - case '2': info_ptr->asyn_info.eot[2] = txt_ptr[2]; - case '1': info_ptr->asyn_info.eot[1] = txt_ptr[1]; - case '0': - info_ptr->asyn_info.eot[0] = txt_ptr[0]; - break; - default: - EL734_errcode = EL734__BAD_PAR; - return False; - } - }else if (strcmp (txt_ptr, "motor") == 0) { - intval = va_arg (ap, int); - if ((intval < 1) || (intval > 12)) { - EL734_errcode = EL734__BAD_PAR; - return False; - } - info_ptr->motor = intval; - }else if (strcmp (txt_ptr, "chan") == 0) { - intval = va_arg (ap, int); - if ((intval < 0) || (intval > 255)) { - EL734_errcode = EL734__BAD_PAR; - return False; - } - info_ptr->asyn_info.chan = intval; - sprintf (buff, "%04d", intval); /* Convert to ASCII */ - memcpy (info_ptr->asyn_info.chan_char, buff, 4); - }else { - EL734_errcode = EL734__BAD_PAR; - return False; - } - txt_ptr = va_arg (ap, char *); /* Get pntr to next parameter ident */ - } - - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL734_EncodeMSR: Encode the MSR status into text. -*/ - char *EL734_EncodeMSR (char *text, int text_len, -/* =============== -*/ int msr, - int ored_msr, - int fp_cntr, - int fr_cntr) { - int len; - char my_text[132]; - char my_text_0[32]; - - if (msr == 0) { - ored_msr = ored_msr & ~(MSR__BUSY); /* Zero "Busy" bit */ - if (ored_msr == MSR__OK) { - StrJoin (text, text_len, "Status, MSR = Idle. Positioned OK.", ""); - }else { - if ((ored_msr & MSR__OK) != 0) { - StrJoin (text, text_len, "Status, MSR = Idle. Positioned OK. ", ""); - }else { - StrJoin (text, text_len, "Status, MSR = Idle. ", ""); - } - if ((ored_msr & MSR__REF_OK) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n OK. "); - } - if ((ored_msr & MSR__LIM_ERR) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Limit Switch Problem. "); - } - if ((ored_msr & MSR__AC_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Air-Cushion Error. "); - } - if ((ored_msr & MSR__REF_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n Fail. "); - } - if ((ored_msr & MSR__POS_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Pos'n Fail. "); - } - if ((ored_msr & MSR__POS_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - if (fp_cntr == 1) { - StrJoin (text, text_len, my_text, "1 Pos'n Fault. "); - }else { - sprintf (my_text_0, "%d Pos'n Faults. ", fp_cntr); - StrJoin (text, text_len, my_text, my_text_0); - } - } - if ((ored_msr & MSR__RUN_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Run Fail. "); - } - if ((ored_msr & MSR__RUN_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - if (fr_cntr == 1) { - StrJoin (text, text_len, my_text, "1 Run Fault. "); - }else { - sprintf (my_text_0, "%d Run Faults. ", fr_cntr); - StrJoin (text, text_len, my_text, my_text_0); - } - } - if ((ored_msr & MSR__HALT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Halt. "); - } - if ((ored_msr & MSR__HI_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit HiLim. "); - } - if ((ored_msr & MSR__LO_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit LoLim. "); - } - if ((ored_msr & MSR__STOPPED) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Stopped. "); - } - } - }else if ((msr & ~(0x2fff)) != 0) { - StrJoin (text, text_len, "Status, MSR = ??", ""); - }else { - sprintf (my_text, "%#x ", msr); - StrJoin (text, text_len, "Status, MSR = ", my_text); - if ((msr & MSR__LIM_ERR) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Limit Switch Problem/"); - } - if ((msr & MSR__AC_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Air-Cushion Error/"); - } - if ((msr & MSR__REF_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n Fail/"); - } - if ((msr & MSR__POS_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Pos'n Fail/"); - } - if ((msr & MSR__POS_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Pos'n Fault/"); - } - if ((msr & MSR__RUN_FAIL) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Run Fail/"); - } - if ((msr & MSR__RUN_FAULT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Run Fault/"); - } - if ((msr & MSR__HALT) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Halt/"); - } - if ((msr & MSR__HI_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit HiLim/"); - } - if ((msr & MSR__LO_LIM) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Hit LoLim/"); - } - if ((msr & MSR__STOPPED) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Stopped/"); - } - if ((msr & MSR__REF_OK) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Ref. Pos'n OK/"); - } - if ((msr & MSR__OK) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "OK/"); - } - if ((msr & MSR__BUSY) != 0) { - StrJoin (my_text, sizeof (my_text), text, ""); - StrJoin (text, text_len, my_text, "Busy/"); - } - len = strlen (text); - text[len-1] = '\0'; - } - return text; - } -/* -**--------------------------------------------------------------------------- -** EL734_EncodeSS: Encode the SS flags into text. -*/ - char *EL734_EncodeSS (char *text, int text_len, int ss) { -/* ============== -*/ - int len; - char my_text[132]; - char my_text_0[32]; - - if (ss == 0) { - StrJoin (text, text_len, "Flags, SS = 0", ""); - }else if ((ss & ~(0x3f)) != 0) { - StrJoin (text, text_len, "Flags, SS = ??", ""); - }else { - sprintf (my_text, "Flags, SS = 0x%02X ", ss); - my_text_0[0] = '\0'; - if ((ss & 0x20) != 0) strcat (my_text_0, "LSX/"); - if ((ss & 0x10) != 0) strcat (my_text_0, "LS2/"); - if ((ss & 0x08) != 0) strcat (my_text_0, "LS1/"); - if ((ss & 0x04) != 0) strcat (my_text_0, "STP/"); - if ((ss & 0x02) != 0) strcat (my_text_0, "CCW/"); - if ((ss & 0x01) != 0) strcat (my_text_0, "HLT/"); - len = strlen (my_text_0); - my_text_0[len-1] = '\0'; - StrJoin (text, text_len, my_text, my_text_0); - } - return text; - } -/* -**------------------------------------------------------------------------- -** EL734_ErrInfo: Return detailed status from last operation. -*/ - void EL734_ErrInfo ( -/* ============= -*/ char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno) { - - int i; - char buff[80], *txt; - int asyn_errcode, asyn_errno, asyn_vaxerrno; - char* asyn_errtxt; - - if (EL734_call_depth <= 0) { - strcpy (EL734_routine[0], "EL734_no_error_detected"); - *errcode = 0; - *my_errno = 0; - *vaxc_errno = 0; - }else { - if (EL734_call_depth > 1) { /* Concatenate the names */ - for (i = 1; i < EL734_call_depth; i++) { - strcat (EL734_routine[0], "/"); - StrJoin (EL734_routine[0], sizeof (EL734_routine), - EL734_routine[0], EL734_routine[i]); - } - } - *errcode = EL734_errcode; - *my_errno = EL734_errno; - *vaxc_errno = EL734_vaxc_errno; - switch (EL734_errcode) { - case EL734__BAD_ADR: txt = "/EL734__BAD_ADR"; break; - case EL734__BAD_ASYNSRV: txt = "/EL734__BAD_ASYNSRV"; break; - case EL734__BAD_CMD: txt = "/EL734__BAD_CMD"; break; - case EL734__BAD_DEV: txt = "/EL734__BAD_DEV"; break; - case EL734__BAD_ILLG: txt = "/EL734__BAD_ILLG"; break; - case EL734__BAD_LOC: txt = "/EL734__BAD_LOC"; break; - case EL734__BAD_MALLOC: txt = "/EL734__BAD_MALLOC"; break; - case EL734__BAD_OFL: txt = "/EL734__BAD_OFL"; break; - case EL734__BAD_OVFL: txt = "/EL734__BAD_OVFL"; break; - case EL734__BAD_PAR: txt = "/EL734__BAD_PAR"; break; - case EL734__BAD_RNG: txt = "/EL734__BAD_RNG"; break; - case EL734__BAD_SOCKET: txt = "/EL734__BAD_SOCKET"; break; - case EL734__BAD_STP: txt = "/EL734__BAD_STP"; break; - case EL734__BAD_TMO: txt = "/EL734__BAD_TMO"; break; - case EL734__EMERG_STOP: txt = "/EL734__EMERG_STOP"; break; - case EL734__FORCED_CLOSED: txt = "/EL734__FORCED_CLOSED"; break; - case EL734__NOT_OPEN: txt = "/EL734__NOT_OPEN"; break; - case EL734__NO_SOCKET: txt = "/EL734__NO_SOCKET"; break; - default: - sprintf (buff, "/EL734__unknown_err_code: %d", EL734_errcode); - txt = buff; - } - StrJoin (EL734_routine[0], sizeof(EL734_routine), EL734_routine[0], txt); - } - AsynSrv_ErrInfo (&asyn_errtxt, &asyn_errcode, &asyn_errno, &asyn_vaxerrno); - if (asyn_errcode != 0) { - strcat (EL734_routine[0], "/"); - StrJoin (EL734_routine[0], sizeof(EL734_routine), - EL734_routine[0], asyn_errtxt); - } - *entry_txt = EL734_routine[0]; - EL734_call_depth = 0; - EL734_errcode = 0; - } -/* -**--------------------------------------------------------------------------- -** EL734_GetAirCush: Get W and AC register values. -*/ - int EL734_GetAirCush ( -/* ================ -*/ void **handle, - int *present, - int *state) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10], cmnd1[10]; - char *rply_ptr, *rply_ptr0, *rply_ptr1; - /*---------------------------------------------- - */ - *present = *state = 0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetAirCush")) return False; - /*---------------------------------------------- - ** Send W and AC cmnds to EL734 - */ - sprintf (cmnd0, "w %d\r", info_ptr->motor); - sprintf (cmnd1, "ac %d\r", info_ptr->motor); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, cmnd1, NULL); - if (!status) { - *present = *state = 0; - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr1 = NULL; - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 != NULL) rply_ptr1 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr0); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (rply_ptr1 == NULL) rply_ptr1 = "?no_response"; - - if ((sscanf (rply_ptr0, "%d", present) != 1) || - (sscanf (rply_ptr1, "%d", state) != 1)) { - if (*rply_ptr0 == '?') { - rply_ptr = rply_ptr0; - }else if (*rply_ptr1 == '?') { - rply_ptr = rply_ptr1; - }else { - rply_ptr = "?funny_response"; - } - *present = *state = 0; - EL734_SetErrcode (info_ptr, rply_ptr, "W\" or \"AC"); - return False; - } - } - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL734_GetEncGearing: Get FD register values. -*/ - int EL734_GetEncGearing ( -/* =================== -*/ void **handle, - int *nominator, - int *denominator) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10]; - char *rply_ptr0; - /*---------------------------------------------- - */ - *nominator = *denominator = 0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetEncGearing")) return False; - /*---------------------------------------------- - ** Send FD cmnd to EL734 - */ - sprintf (cmnd0, "fd %d\r", info_ptr->motor); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - *nominator = *denominator = 0; - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (sscanf (rply_ptr0, "%d %d", nominator, denominator) == 2) { - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - *nominator = *denominator = 0; - EL734_SetErrcode (info_ptr, rply_ptr0, "FD"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_GetId: Get ID register value. -*/ - int EL734_GetId ( -/* =========== -*/ void **handle, - char *id_txt, - int id_len) { - - int status; - struct EL734info *info_ptr; - char *rply_ptr0; - /*---------------------------------------------- - */ - *id_txt = '\0'; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetId")) return False; - /*---------------------------------------------- - ** Send ID cmnd to EL734 - */ - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "id\r", NULL); - if (!status) { - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if ((rply_ptr0 != NULL) && - (*rply_ptr0 != '\0') && - (*rply_ptr0 != '?')) { - StrJoin (id_txt, id_len, rply_ptr0, ""); - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - EL734_SetErrcode (info_ptr, rply_ptr0, "ID"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_GetLimits: Get H register values. -*/ - int EL734_GetLimits ( -/* =============== -*/ void **handle, - float *lo, - float *hi) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10]; - char *rply_ptr0; - /*---------------------------------------------- - */ - *lo = *hi = 0.0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetLimits")) return False; - /*---------------------------------------------- - ** Send H cmnd to EL734 - */ - sprintf (cmnd0, "h %d\r", info_ptr->motor); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - *lo = *hi = 0.0; - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (sscanf (rply_ptr0, "%f %f", lo, hi) == 2) { - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - *lo = *hi = 0.0; - EL734_SetErrcode (info_ptr, rply_ptr0, "H"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_GetMotorGearing: Get FM register values. -*/ - int EL734_GetMotorGearing ( -/* ===================== -*/ void **handle, - int *nominator, - int *denominator) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10]; - char *rply_ptr0; - /*---------------------------------------------- - */ - *nominator = *denominator = 0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetMotorGearing")) return False; - /*---------------------------------------------- - ** Send FM cmnd to EL734 - */ - sprintf (cmnd0, "fm %d\r", info_ptr->motor); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - *nominator = *denominator = 0; - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (sscanf (rply_ptr0, "%d %d", nominator, denominator) == 2) { - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - *nominator = *denominator = 0; - EL734_SetErrcode (info_ptr, rply_ptr0, "FM"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_GetNullPoint: Get V register value. -*/ - int EL734_GetNullPoint ( -/* ================== -*/ void **handle, - int *null_pt) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10]; - char *rply_ptr0; - /*---------------------------------------------- - */ - *null_pt = 0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetNullPoint")) return False; - /*---------------------------------------------- - ** Send V cmnd to EL734 - */ - sprintf (cmnd0, "v %d\r", info_ptr->motor); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - *null_pt = 0; - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (sscanf (rply_ptr0, "%d", null_pt) == 1) { - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - *null_pt = 0; - EL734_SetErrcode (info_ptr, rply_ptr0, "V"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_GetPosition: Get U register value, the current position. -*/ - int EL734_GetPosition ( -/* ================= -*/ void **handle, - float *ist_posit) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10]; - char *rply_ptr0; - /*---------------------------------------------- - */ - *ist_posit = 0.0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetPosition")) return False; - /*---------------------------------------------- - ** Send U cmnd to EL734 - */ - sprintf (cmnd0, "u %d\r", info_ptr->motor); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - *ist_posit = 0.0; - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (sscanf (rply_ptr0, "%f", ist_posit) == 1) { - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - *ist_posit = 0.0; - EL734_SetErrcode (info_ptr, rply_ptr0, "U"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_GetPrecision: Get A register value. -*/ - int EL734_GetPrecision ( -/* ================== -*/ void **handle, - int *n_dec) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10]; - char *rply_ptr0; - /*---------------------------------------------- - */ - *n_dec = 3; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetPrecision")) return False; - /*---------------------------------------------- - ** Send A cmnd to EL734 - */ - sprintf (cmnd0, "a %d\r", info_ptr->motor); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - *n_dec = 3; - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (sscanf (rply_ptr0, "%d", n_dec) == 1) { - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - *n_dec = 3; - EL734_SetErrcode (info_ptr, rply_ptr0, "A"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_GetRefMode: Get K register value. -*/ - int EL734_GetRefMode ( -/* ================ -*/ void **handle, - int *mode) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10]; - char *rply_ptr0; - /*---------------------------------------------- - */ - *mode = 0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetRefMode")) return False; - /*---------------------------------------------- - ** Send K cmnd to EL734 - */ - sprintf (cmnd0, "k %d\r", info_ptr->motor); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - *mode = 0; - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (sscanf (rply_ptr0, "%d", mode) == 1) { - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - *mode = 0; - EL734_SetErrcode (info_ptr, rply_ptr0, "K"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_GetRefParam: Get Q register value. -*/ - int EL734_GetRefParam ( -/* ================= -*/ void **handle, - float *param) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10]; - char *rply_ptr0; - /*---------------------------------------------- - */ - *param = 0.0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetRefParam")) return False; - /*---------------------------------------------- - ** Send Q cmnd to EL734 - */ - sprintf (cmnd0, "q %d\r", info_ptr->motor); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - *param = 0.0; - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (sscanf (rply_ptr0, "%f", param) == 1) { - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - *param = 0.0; - EL734_SetErrcode (info_ptr, rply_ptr0, "Q"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_GetSpeeds: Get G/J/E register values. -*/ - int EL734_GetSpeeds ( -/* =============== -*/ void **handle, - int *lo, - int *hi, - int *ramp) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10]; - char cmnd1[10]; - char cmnd2[10]; - char *rply_ptr; - char *rply_ptr0; - char *rply_ptr1; - char *rply_ptr2; - /*---------------------------------------------- - */ - *lo = *hi = *ramp = 0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetSpeeds")) return False; - /*---------------------------------------------- - ** Send G, J and E cmnds to EL734 - */ - sprintf (cmnd0, "g %d\r", info_ptr->motor); - sprintf (cmnd1, "j %d\r", info_ptr->motor); - sprintf (cmnd2, "e %d\r", info_ptr->motor); - - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, cmnd1, cmnd2, NULL); - if (!status) { - *lo = *hi = *ramp = 0; - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr1 = rply_ptr2 = NULL; - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 != NULL) rply_ptr1 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr0); - if (rply_ptr1 != NULL) rply_ptr2 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr1); - - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (rply_ptr1 == NULL) rply_ptr1 = "?no_response"; - if (rply_ptr2 == NULL) rply_ptr2 = "?no_response"; - - if ((sscanf (rply_ptr0, "%d", lo) != 1) || - (sscanf (rply_ptr1, "%d", hi) != 1) || - (sscanf (rply_ptr2, "%d", ramp) != 1)) { - if (*rply_ptr0 == '?') { - rply_ptr = rply_ptr0; - }else if (*rply_ptr1 == '?') { - rply_ptr = rply_ptr1; - }else if (*rply_ptr2 == '?') { - rply_ptr = rply_ptr2; - }else { - rply_ptr = "?funny_response"; - } - *lo = *hi = *ramp = 0; - EL734_SetErrcode (info_ptr, rply_ptr, "G\", \"J\" or \"E"); - return False; - } - } - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL734_GetStatus: Get MSR/SS/U register values. -*/ - int EL734_GetStatus ( -/* =============== -*/ void **handle, - int *msr, - int *ored_msr, - int *fp_cntr, - int *fr_cntr, - int *ss, - float *ist_posit) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10]; - char cmnd1[10]; - char cmnd2[10]; - char *rply_ptr; - char *rply_ptr0; - char *rply_ptr1; - char *rply_ptr2; - /*---------------------------------------------- - */ - *msr = *ored_msr = *fp_cntr = *fr_cntr = *ss = -1; *ist_posit = 0.0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetStatus")) return False; - /*---------------------------------------------- - ** Send MSR, SS and U cmnds to EL734 - */ - sprintf (cmnd0, "msr %d\r", info_ptr->motor); - sprintf (cmnd1, "ss %d\r", info_ptr->motor); - sprintf (cmnd2, "u %d\r", info_ptr->motor); - - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, cmnd1, cmnd2, NULL); - if (!status) { - *msr = *ored_msr = *fp_cntr = *fr_cntr = *ss = -1; *ist_posit = 0.0; - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr1 = rply_ptr2 = NULL; - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 != NULL) rply_ptr1 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr0); - if (rply_ptr1 != NULL) rply_ptr2 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr1); - - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (rply_ptr1 == NULL) rply_ptr1 = "?no_response"; - if (rply_ptr2 == NULL) rply_ptr2 = "?no_response"; - - if ((sscanf (rply_ptr0, "%x", msr) == 1) && - (sscanf (rply_ptr2, "%f", ist_posit) == 1)) { - info_ptr->ored_msr = info_ptr->ored_msr | *msr; - if ((*msr & MSR__POS_FAULT) != 0) info_ptr->fp_cntr++; - if ((*msr & MSR__RUN_FAULT) != 0) info_ptr->fr_cntr++; - *ored_msr = info_ptr->ored_msr; - *fp_cntr = info_ptr->fp_cntr; - *fr_cntr = info_ptr->fr_cntr; - /* Remember: we may get "?BSY" for SS and - ** this should not be treated as an error! - */ - if (sscanf (rply_ptr1, "%x", ss) != 1) *ss = -1; - }else { - if (*rply_ptr0 == '?') { - rply_ptr = rply_ptr0; - }else if (*rply_ptr1 == '?') { - rply_ptr = rply_ptr1; - }else if (*rply_ptr2 == '?') { - rply_ptr = rply_ptr2; - }else { - rply_ptr = "?funny_response"; - } - *msr = *ored_msr = *fp_cntr = *fr_cntr = *ss = -1; *ist_posit = 0.0; - EL734_SetErrcode (info_ptr, rply_ptr, "MSR\", \"SS\" or \"U"); - return False; - } - } - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL734_GetZeroPoint: Get zero point (= converted V register value) -*/ - int EL734_GetZeroPoint ( -/* ================== -*/ void **handle, - float *zero_pt) { - - int status, null_pt, nom, denom; - struct EL734info *info_ptr; - char cmnd0[10]; - char *rply_ptr0; - /*---------------------------------------------- - */ - *zero_pt = 0.0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_GetZeroPoint")) return False; - /*---------------------------------------------- - ** Get V register value. - */ - status = EL734_GetNullPoint (handle, &null_pt); - if (!status) return False; - - /*---------------------------------------------- - ** FD register values. - */ - status = EL734_GetEncGearing (handle, &nom, &denom); - if (!status) return False; - - if (nom == 0) { - EL734_errcode = EL734__BAD_OVFL; /* Encoder gearing ratio is zero */ - return False; - } - - *zero_pt = ((float) denom)/((float) nom); - *zero_pt *= (float) null_pt; - - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL734_MoveNoWait: Move motor and don't wait for completion. -*/ - int EL734_MoveNoWait ( -/* ================ -*/ void **handle, - float soll_posit) { - - int status; - struct EL734info *info_ptr; - char cmnd0[32]; - char *rply_ptr0; - /*---------------------------------------------- - */ - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_MoveNoWait")) return False; - /*---------------------------------------------- - ** Send P cmnd to EL734 - */ - sprintf (cmnd0, "p %d %.3f\r", info_ptr->motor, soll_posit); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (*rply_ptr0 == '\0' || *rply_ptr0 == '\r' ) { - /* - ** The command was accepted - so zero the statistics - ** fields in the handle and return to caller. - */ - info_ptr->ored_msr = info_ptr->fp_cntr = info_ptr->fr_cntr = 0; - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - EL734_SetErrcode (info_ptr, rply_ptr0, "P"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_MoveWait: Move motor and wait for completion. -*/ - int EL734_MoveWait ( -/* ============== -*/ void **handle, - float soll_posit, - int *ored_msr, - int *fp_cntr, - int *fr_cntr, - float *ist_posit) { - - int status; - struct EL734info *info_ptr; - /*---------------------------------------------- - */ - *ored_msr = *fp_cntr = *fr_cntr = -1; *ist_posit = 0.0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_MoveWait")) return False; - /*---------------------------------------------- - ** Start the movement. - */ - status = EL734_MoveNoWait (handle, soll_posit); - if (status) { - status = EL734_WaitIdle (handle, ored_msr, fp_cntr, fr_cntr, ist_posit); - } - if (status && (EL734_errcode == 0)) EL734_call_depth--; - if (EL734_errcode != 0) return False; - return status; - } -/* -**--------------------------------------------------------------------------- -** EL734_Open: Open a connection to a motor. -*/ - int EL734_Open ( -/* ========== -*/ void **handle, - char *host, - int port, - int chan, - int motor, - char *device_id) { - - int my_msr, status; - struct EL734info *my_handle; - char tmo_save[4]; - char msr_cmnd[20]; - char *rply_ptr; - char *rply_ptr0; - char *rply_ptr1; - char *rply_ptr2; - char *rply_ptr3; -/*-------------------------------------------------------- -** Initialise the error info stack and pre-set the -** routine name (in case of error). -*/ - EL734_errcode = EL734_errno = EL734_vaxc_errno = 0; - strcpy (EL734_routine[0], "EL734_Open"); - EL734_call_depth = 1; -/*-------------------------------------------------------- -** Assume trouble -*/ - *handle = NULL; -/*-------------------------------------------------------- -** Reserve space for the data we need to store. -*/ - my_handle = (struct EL734info *) malloc (sizeof (*my_handle)); - if (my_handle == NULL) { - EL734_errcode = EL734__BAD_MALLOC; /* malloc failed!! */ - return False; - } -/*-------------------------------------------------------- -** Set up the connection -*/ - StrJoin (my_handle->asyn_info.host, sizeof (my_handle->asyn_info.host), - host, ""); - my_handle->asyn_info.port = port; - my_handle->asyn_info.chan = chan; - status = AsynSrv_Open (&my_handle->asyn_info); - if (!status) { - EL734_errcode = EL734__BAD_SOCKET; - GetErrno (&EL734_errno, &EL734_vaxc_errno); /* Save errno info */ - fprintf (stderr, "\nEL734_Open/AsynSrv_Open: " - "Failed to make connection.\n"); - free (my_handle); - return False; - } - - memcpy (tmo_save, my_handle->asyn_info.tmo, 4); /* Save time-out */ - EL734_Config ((void *) &my_handle, - "msecTmo", 500, /* Set a short time-out initially since - ** there should be no reason for the RMT, - ** ECHO or ID commands to take very long. - */ - "eot", "1\r", - "motor", motor, - NULL); - my_handle->ored_msr = 0; - my_handle->fp_cntr = 0; - my_handle->fr_cntr = 0; - /* - ** Now ensure the EL734 is on-line. The first "RMT 1" command can - ** fail due to pending characters in the EL734 input buffer causing - ** the "RMT 1" to be corrupted. The response of the EL734 to this - ** command is ignored for this reason (but the AsynSrv_SendCmnds - ** status must be OK otherwise it indicates a network problem). - */ - status = AsynSrv_SendCmnds (&my_handle->asyn_info, - &my_handle->to_host, &my_handle->from_host, - "rmt 1\r", NULL); - sprintf (msr_cmnd, "msr %d\r", motor); - if (status) { - if (device_id != NULL) { - status = AsynSrv_SendCmnds (&my_handle->asyn_info, - &my_handle->to_host, &my_handle->from_host, - "rmt 1\r", "echo 0\r", "id\r", msr_cmnd, NULL); - }else { - status = AsynSrv_SendCmnds (&my_handle->asyn_info, - &my_handle->to_host, &my_handle->from_host, - "rmt 1\r", "echo 0\r", "echo 0\r", msr_cmnd, NULL); - } - } - memcpy (my_handle->asyn_info.tmo, tmo_save, 4); /* Restore time-out */ - if (!status) { - /* Some error occurred in AsynSrv_SendCmnds */ - EL734_errcode = EL734__BAD_ASYNSRV; - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - return False; - }else { - /* Check the responses carefully. The 3rd response should - ** be the device identifier (if to be checked). The 4th - ** response should be a hex integer. - */ - rply_ptr1 = rply_ptr2 = rply_ptr3 = NULL; - rply_ptr0 = AsynSrv_GetReply ( - &my_handle->asyn_info, &my_handle->from_host, NULL); - if (rply_ptr0 != NULL) rply_ptr1 = AsynSrv_GetReply ( - &my_handle->asyn_info, &my_handle->from_host, rply_ptr0); - if (rply_ptr1 != NULL) rply_ptr2 = AsynSrv_GetReply ( - &my_handle->asyn_info, &my_handle->from_host, rply_ptr1); - if (rply_ptr2 != NULL) rply_ptr3 = AsynSrv_GetReply ( - &my_handle->asyn_info, &my_handle->from_host, rply_ptr2); - - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (rply_ptr1 == NULL) rply_ptr1 = "?no_response"; - if (rply_ptr2 == NULL) rply_ptr2 = "?no_response"; - if (rply_ptr3 == NULL) rply_ptr3 = "?no_response"; - - if (*rply_ptr1 == '?') rply_ptr0 = rply_ptr1; - if (*rply_ptr2 == '?') rply_ptr0 = rply_ptr2; - if (*rply_ptr3 == '?') rply_ptr0 = rply_ptr3; - if (*rply_ptr0 != '?') { - if (device_id != NULL) { /* Check device ID? */ - if (*rply_ptr2 == '\0') { /* Yes. But if response is blank, it - ** may be because Emergency Stop is set. - */ - EL734_SetErrcode (my_handle, rply_ptr2, "ID"); - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - return False; - }else { - if (strncmp (rply_ptr2, device_id, strlen (device_id)) != 0) { - EL734_errcode = EL734__BAD_DEV; /* Device has wrong ID */ - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - return False; - } - } - } - if (sscanf (rply_ptr3, "%x", &my_msr) != 1) { - /* MSR response is bad */ - EL734_SetErrcode (my_handle, rply_ptr3, msr_cmnd); /* Check for *ES */ - if (EL734_errcode != EL734__EMERG_STOP) - EL734_errcode = EL734__BAD_DEV; - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - return False; - } - /* - ** The connection is complete. Pass the data structure - ** back to the caller as a handle. - */ - *handle = my_handle; - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - }else { - EL734_errcode = EL734__BAD_DEV; - if (strcmp (rply_ptr0, "?OFL") == 0) EL734_errcode = EL734__BAD_OFL; - if (strcmp (rply_ptr0, "?CMD") == 0) EL734_errcode = EL734__BAD_CMD; - if (strcmp (rply_ptr0, "?LOC") == 0) EL734_errcode = EL734__BAD_LOC; - if (strcmp (rply_ptr0, "?ADR") == 0) EL734_errcode = EL734__BAD_ADR; - if (strcmp (rply_ptr0, "*ES") == 0) EL734_errcode = EL734__EMERG_STOP; - if (strncmp (rply_ptr0, "?TMO", 4) == 0) EL734_errcode = EL734__BAD_TMO; - if (EL734_errcode == EL734__BAD_DEV) - fprintf (stderr, " Unrecognised initial response: \"%s\"\n", - rply_ptr0); - } - } - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - return False; - } -/* -**--------------------------------------------------------------------------- -** EL734_PutOffline: put the EL734 off-line -*/ - int EL734_PutOffline ( -/* ================ -*/ void **handle) { - - int status; - struct EL734info *info_ptr; - char *rply_ptr0, *rply_ptr1, *rply_ptr2; - /*---------------------------------------------- - */ - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_PutOffline")) return False; - /*---------------------------------------------- - ** The problem which this routine has is that the EL734 - ** may already be off-line. The following is, therefore, - ** rather pedantic for most cases which occur in practice. - */ - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "\r", "rmt 1\r", "echo 1\r", "rmt 0\r", NULL); - if (!status) { - EL734_errcode = EL734__BAD_ASYNSRV; return False;} - - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "RMT\r", "", NULL); - if (!status) { - EL734_errcode = EL734__BAD_ASYNSRV; return False;} - - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - rply_ptr1 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr0); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (rply_ptr1 == NULL) rply_ptr1 = "?no_response"; - if ((strcmp (rply_ptr0, "RMT") == 0) && - (strcmp (rply_ptr1, "\n0") == 0)) { - EL734_call_depth--; - return True; - } - - EL734_SetErrcode (info_ptr, rply_ptr0, "RMT"); - return False; - } -/* -**--------------------------------------------------------------------------- -** EL734_PutOnline: put the EL734 on-line -*/ - int EL734_PutOnline ( -/* =============== -*/ void **handle, - int echo) { - - int status, my_echo; - struct EL734info *info_ptr; - char cmnd0[10]; - char *rply_ptr0; - /*---------------------------------------------- - */ - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_PutOnline")) return False; - /*---------------------------------------------- - */ - if ((echo != 0) && (echo != 1) && (echo != 2)) { - EL734_errcode = EL734__BAD_PAR; return False; - } - /*---------------------------------------------- - ** The problem which this routine has is that the state - ** of the EL734 is not known. The following is, therefore, - ** rather pedantic for most cases which occur in practice. - */ - sprintf (cmnd0, "echo %d\r", echo); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "\r", "rmt 1\r", cmnd0, NULL); - if (!status) { - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - } - - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "echo\r", NULL); - if (!status) { - EL734_errcode = EL734__BAD_ASYNSRV; return False;} - - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (strcmp (rply_ptr0, "ECHO") == 0) { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr0); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - } - if ((sscanf (rply_ptr0, "%d", &my_echo) == 1) && (my_echo == echo)) { - EL734_call_depth--; - return True; - } - - EL734_SetErrcode (info_ptr, rply_ptr0, "ECHO"); - return False; - } -/* -**--------------------------------------------------------------------------- -** EL734_SendCmnd - Send a command to RS232C server. -*/ - int EL734_SendCmnd ( -/* ============== -*/ void **handle, - char *cmnd, - char *rply, - int rply_size) { - - struct EL734info *info_ptr; - int my_status; - char *rply_ptr; - /*---------------------------------------------- - */ - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_SendCmnd")) return False; - /*---------------------------------------------- - ** Send command to EL734. - */ - my_status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd, NULL); - if (!my_status) { - EL734_errcode = EL734__BAD_ASYNSRV; return False; - }else { - rply_ptr = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr == NULL) rply_ptr = "?no_response"; - StrJoin (rply, rply_size, rply_ptr, ""); - } - - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL734_SetAirCush: Set the air-cushion register (AC register) -*/ - int EL734_SetAirCush ( -/* ================ -*/ void **handle, - int state) { - - int status, dum1, my_state; - struct EL734info *info_ptr; - char cmnd0[32]; - char *rply_ptr0; - /*---------------------------------------------- - */ - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_SetAirCush")) return False; - /*---------------------------------------------- - ** Send AC cmnd to EL734 - */ - if (state != 0) state = 1; - sprintf (cmnd0, "ac %d %d\r", info_ptr->motor, state); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (*rply_ptr0 == '\0') { - /* - ** The command was accepted - check value is set OK. - */ - status = EL734_GetAirCush (handle, &dum1, &my_state); - if (!status) return False; - if (state != my_state) { - EL734_errcode = EL734__VFY_ERR; - return False; - } - EL734_call_depth--; - return True; - } - EL734_SetErrcode (info_ptr, rply_ptr0, "AC"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_SetErrcode - Set up EL734_errcode -*/ - int EL734_SetErrcode ( -/* ================ -*/ struct EL734info *info_ptr, - char *response, - char *cmnd) { - - int status; - char *rply; - char tmo_save[4]; - char eot_save[4]; - - EL734_errcode = EL734__BAD_ILLG; - if (strcmp (response, "?OFL") == 0) EL734_errcode = EL734__BAD_OFL; - if (strcmp (response, "?CMD") == 0) EL734_errcode = EL734__BAD_CMD; - if (strcmp (response, "?LOC") == 0) EL734_errcode = EL734__BAD_LOC; - if (strcmp (response, "?ADR") == 0) EL734_errcode = EL734__BAD_ADR; - if (strcmp (response, "?RNG") == 0) EL734_errcode = EL734__BAD_RNG; - if (strcmp (response, "*ES") == 0) EL734_errcode = EL734__EMERG_STOP; - if (strcmp (response, "*MS" ) == 0) EL734_errcode = EL734__BAD_STP; - if (strncmp (response, "?TMO", 4) == 0) EL734_errcode = EL734__BAD_TMO; - if (EL734_errcode != EL734__BAD_ILLG) return EL734_errcode; - /* - ** The response is not recognised. Perhaps the emergency stop - ** signal is set. To check this, it is necessary to turn off - ** terminator checking since the EL734 prefixes its "*ES" - ** response with a character. We also therefore set - ** a very short time-out. - */ - memcpy (tmo_save, info_ptr->asyn_info.tmo, 4); /* Save time-out */ - memcpy (eot_save, info_ptr->asyn_info.eot, 4); /* Save terminators */ - AsynSrv_Config (&info_ptr->asyn_info, - "msecTmo", 100, /* Set short time-out */ - "eot", "0", /* Set no terminator */ - NULL); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "ID\r", NULL); - memcpy (info_ptr->asyn_info.eot, eot_save, 4); /* Restore terminators */ - memcpy (info_ptr->asyn_info.tmo, tmo_save, 4); /* Restore time-out */ - if (status) { - rply = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply == NULL) rply = "?no_response"; - }else { - rply = "?no_response"; - } - if (strstr (rply, "*ES") != NULL) EL734_errcode = EL734__EMERG_STOP; - - if ((EL734_errcode == EL734__BAD_ILLG) && (cmnd != NULL)) { - fprintf (stderr, " Unrecognised response to \"%s\" command: \"%s\"\n", - cmnd, response); - strcpy (EL734_IllgText, cmnd); - strcat (EL734_IllgText, " : "); - strcat (EL734_IllgText, response); - } - return EL734_errcode; - } -/* -**--------------------------------------------------------------------------- -** EL734_SetHighSpeed: Set the max speed (J register) -*/ - int EL734_SetHighSpeed ( -/* ================== -*/ void **handle, - int hi) { - - int status, my_lo, my_hi, my_ramp; - struct EL734info *info_ptr; - char cmnd0[32]; - char *rply_ptr0; - /*---------------------------------------------- - */ - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_SetHighSpeed")) return False; - /*---------------------------------------------- - ** Send J cmnd to EL734 - */ - sprintf (cmnd0, "j %d %d\r", info_ptr->motor, hi); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (*rply_ptr0 == '\0') { - /* - ** The command was accepted - check value is set OK. - */ - status = EL734_GetSpeeds (handle, &my_lo, &my_hi, &my_ramp); - if (!status) return False; - if (hi != my_hi) { - EL734_errcode = EL734__VFY_ERR; - return False; - } - EL734_call_depth--; - return True; - } - EL734_SetErrcode (info_ptr, rply_ptr0, "J"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_SetLowSpeed: Set the start/stop speed (G register) -*/ - int EL734_SetLowSpeed ( -/* ================= -*/ void **handle, - int lo) { - - int status, my_lo, my_hi, my_ramp; - struct EL734info *info_ptr; - char cmnd0[32]; - char *rply_ptr0; - /*---------------------------------------------- - */ - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_SetLowSpeed")) return False; - /*---------------------------------------------- - ** Send G cmnd to EL734 - */ - sprintf (cmnd0, "g %d %d\r", info_ptr->motor, lo); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (*rply_ptr0 == '\0') { - /* - ** The command was accepted - check value is set OK. - */ - status = EL734_GetSpeeds (handle, &my_lo, &my_hi, &my_ramp); - if (!status) return False; - if (lo != my_lo) { - EL734_errcode = EL734__VFY_ERR; - return False; - } - EL734_call_depth--; - return True; - } - EL734_SetErrcode (info_ptr, rply_ptr0, "G"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_SetRamp: Set the start/stop ramp (E register) -*/ - int EL734_SetRamp ( -/* ============= -*/ void **handle, - int ramp) { - - int status, my_lo, my_hi, my_ramp; - struct EL734info *info_ptr; - char cmnd0[32]; - char *rply_ptr0; - /*---------------------------------------------- - */ - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_SetRamp")) return False; - /*---------------------------------------------- - ** Send E cmnd to EL734 - */ - sprintf (cmnd0, "e %d %d\r", info_ptr->motor, ramp); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (*rply_ptr0 == '\0') { - /* - ** The command was accepted - check value is set OK. - */ - status = EL734_GetSpeeds (handle, &my_lo, &my_hi, &my_ramp); - if (!status) return False; - if (ramp != my_ramp) { - EL734_errcode = EL734__VFY_ERR; - return False; - } - EL734_call_depth--; - return True; - } - EL734_SetErrcode (info_ptr, rply_ptr0, "E"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_Stop: Send a stop command to motor. -*/ - int EL734_Stop ( -/* ========== -*/ void **handle) { - - int status; - struct EL734info *info_ptr; - char cmnd0[10]; - char *rply_ptr0; - /*---------------------------------------------- - */ - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_Stop")) return False; - /*---------------------------------------------- - ** Send S cmnd to EL734 - */ - sprintf (cmnd0, "s %d\r", info_ptr->motor); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd0, NULL); - if (!status) { - EL734_errcode = EL734__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?no_response"; - if (rply_ptr0[0] == '\0') { - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - EL734_SetErrcode (info_ptr, rply_ptr0, "S"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL734_WaitIdle: Wait till MSR goes to zero. -*/ - int EL734_WaitIdle ( -/* ============== -*/ void **handle, - int *ored_msr, - int *fp_cntr, - int *fr_cntr, - float *ist_posit) { -#ifdef __VMS -#include -#define hibernate lib$wait (0.25) -#else -#include -#include - struct timespec delay = {0, 250000000}; - struct timespec delay_left; - -#ifdef LINUX -#define hibernate nanosleep(&delay, &delay_left) -#else -#define hibernate nanosleep_d9 (&delay, &delay_left) -#endif - -#endif - int msr, ss; - struct EL734info *info_ptr; - /*---------------------------------------------- - */ - *ored_msr = *fp_cntr = *fr_cntr = -1; *ist_posit = 0.0; - info_ptr = (struct EL734info *) *handle; - - if (!EL734_AddCallStack (info_ptr, "EL734_WaitIdle")) return False; - /*---------------------------------------------- - ** Poll the motor status till not moving. - */ - while (EL734_GetStatus (handle, - &msr, ored_msr, fp_cntr, fr_cntr, &ss, ist_posit)) { - if ((msr & MSR__BUSY) == 0) { - if (EL734_errcode != 0) return False; - EL734_call_depth--; - return True; - } - hibernate; - } - return False; /* Error detected in EL734_GetStatus */ - } -/* -**--------------------------------------------------------------------------- -** EL734_ZeroStatus: Zero the "ored-MSR" and fault counters. -*/ - void EL734_ZeroStatus ( -/* ================ -*/ void **handle) { - - struct EL734info *info_ptr; - /* - ** Do nothing if no handle! - */ - info_ptr = (struct EL734info *) *handle; - if (info_ptr == NULL) return; - /* - ** Zero the data structure items. - */ - info_ptr->ored_msr = 0; - info_ptr->fp_cntr = 0; - info_ptr->fr_cntr = 0; - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return; - } -/*-------------------------------------------- End of EL734_Utility.C =======*/ diff --git a/hardsup/el734fix.h b/hardsup/el734fix.h deleted file mode 100644 index e14df3a5..00000000 --- a/hardsup/el734fix.h +++ /dev/null @@ -1,29 +0,0 @@ -/*--------------------------------------------------------------------------- - Fix file for David renaming lots of el734 error codes. - - Mark Koennecke, October 1998 -----------------------------------------------------------------------------*/ -#ifndef EL734FIX -#define EL734FIX -#include "asynsrv_errcodes.h" - -#define EL734__BAD_HOST ASYNSRV__BAD_HOST -#define EL734__BAD_BIND ASYNSRV__BAD_BIND -#define EL734__BAD_SENDLEN ASYNSRV__BAD_SEND_LEN -#define EL734__BAD_SEND ASYNSRV__BAD_SEND -#define EL734__BAD_SEND_PIPE ASYNSRV__BAD_SEND_PIPE -#define EL734__BAD_SEND_UNKN ASYNSRV__BAD_SEND_UNKN -#define EL734__BAD_RECV ASYNSRV__BAD_RECV -#define EL734__BAD_RECV_PIPE ASYNSRV__BAD_RECV_PIPE -#define EL734__BAD_RECV_NET ASYNSRV__BAD_RECV_NET -#define EL734__BAD_SEND_NET ASYNSRV__BAD_SEND_NET -#define EL734__BAD_RECV_UNKN ASYNSRV__BAD_RECV_UNKN -#define EL734__BAD_NOT_BCD ASYNSRV__BAD_NOT_BCD -#define EL734__BAD_RECVLEN ASYNSRV__BAD_RECV_LEN -#define EL734__BAD_FLUSH ASYNSRV__BAD_FLUSH -#define EL734__BAD_RECV1 ASYNSRV__BAD_RECV1 -#define EL734__BAD_RECV1_PIPE ASYNSRV__BAD_RECV1_PIPE -#define EL734__BAD_RECV1_NET ASYNSRV__BAD_RECV1_NET -#define EL734__BAD_CONNECT ASYNSRV__BAD_CONNECT -#define EL734__BAD_ID EL734__BAD_DEV -#endif /* el734fix */ diff --git a/hardsup/el734tcl.c b/hardsup/el734tcl.c deleted file mode 100644 index c4dc11a4..00000000 --- a/hardsup/el734tcl.c +++ /dev/null @@ -1,644 +0,0 @@ -/*-------------------------------------------------------------------------- - - Some code to make EL734 motors as used at SINQ available in TCL. - Just a wrapper around David Maden's motor control routines. - - You are free to use and modify this software for noncommercial - usage. - - No warranties or liabilities of any kind taken by me or my employer - - Mark Koennecke June 1996 -----------------------------------------------------------------------------*/ -#include "sinq_prototypes.h" -/* #include */ -#include -#include -#include -#include -#include "rs232c_def.h" -#include "el734_def.h" - -#define INACTIVE 999.8 -#define MOTACURRACY 0.02 -#define False 0 -#define True 1 - - typedef struct - { - float fUpper; /* upper limit */ - float fLower; /* Lower Limit */ - int iFix; /* fixed, unfixed flag */ - float fSoftZero; /* SW-zero point */ - float fSoftUpper; /* software upper boundary*/ - float fSoftLower; /* " lower " */ - int iLowFlag, iUpFlag, iZeroFlag; /*activity flags */ - void *pData; /* EL734 open struct */ - } EL734st; - - EXTERN int EL734Action(ClientData pDat, Tcl_Interp *i, int a, char *argv[]); - static void EL734Error2Text(char *pBuffer, int errcode); - -/*--------------------------------------------------------------------------- - Tcl has a high niceness level. It deletes a command properly when - exiting, reinitializing etc. I use this facility to kill off the - motor initialised in EL734. ----------------------------------------------------------------------------*/ -EXTERN void EL734Murder(ClientData pData) -{ - EL734st *pTa = (EL734st *)pData; - EL734_Close(&(pTa->pData)); - free(pData); -} -/*---------------------------------------------------------------------------- - EL734 is the main entry point for this stuff. It connects to a motor - and, on success, creates a new command with the name of the motor. - Syntax: - EL734 name host port channel index ----------------------------------------------------------------------------*/ - -int EL734(ClientData clientData, Tcl_Interp *interp, - int argc, char *argv[]) -{ - int iRet; - EL734st *pEL734 = NULL; - int iPort, iChannel, iMotor; - char *pErr = NULL; - char pBueffel[80]; - - /* check arguments */ - if(argc < 6) - { - Tcl_AppendResult(interp, - " Insufficient arguments: EL734 name host port channel index" - , (char *) NULL); - return TCL_ERROR; - } - - /* convert arguments */ - iRet = Tcl_GetInt(interp,argv[3],&iPort); - if(iRet == TCL_ERROR) - { - Tcl_AppendResult(interp,"Need integer value for port", - (char *)NULL); - return iRet; - } - - iRet = Tcl_GetInt(interp,argv[4],&iChannel); - if(iRet == TCL_ERROR) - { - Tcl_AppendResult(interp,"Need integer value for channel", - (char *)NULL); - return iRet; - } - - iRet = Tcl_GetInt(interp,argv[5],&iMotor); - if(iRet == TCL_ERROR) - { - Tcl_AppendResult(interp,"Need integer value for motor", - (char *)NULL); - return iRet; - } - - /* make a new pointer, initialise EL734st */ - pEL734 = (EL734st *)malloc(sizeof(EL734st)); - if(pEL734 ==NULL) - { - Tcl_AppendResult(interp,"No memory in EL734",NULL); - return TCL_ERROR; - } - pEL734->iFix = False; - pEL734->fSoftZero = INACTIVE+1; - pEL734->fSoftUpper = INACTIVE+1.; - pEL734->fSoftLower = -INACTIVE-1.; - pEL734->iZeroFlag = False; - pEL734->iLowFlag = False; - pEL734->iUpFlag = False; - - /* open the motor, finally */ - iRet = EL734_Open(&(pEL734->pData), argv[2],iPort,iChannel,iMotor,"STPMC EL734"); - if(iRet) /* success */ - { - /* figure out motor limits */ - EL734_GetLimits(&(pEL734->pData),&(pEL734->fLower), - &(pEL734->fUpper)); - /* handle TCL, create new command: the motor */ - Tcl_CreateCommand(interp,strdup(argv[1]),EL734Action, - (ClientData)pEL734,EL734Murder); - Tcl_AppendResult(interp,strdup(argv[1]),(char *)NULL); - return TCL_OK; - } - else - { - EL734_ErrInfo(&pErr,&iPort,&iChannel, &iMotor); - EL734Error2Text(pBueffel,iPort); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - free(pEL734); - return TCL_ERROR; - } -} -/*--------------------------------------------------------------------------- - CheckPos checks a position and converts it to a real position. - Returns TCL_ERROR on mistake, TCL_OK else ----------------------------------------------------------------------------*/ - static int CheckPos(Tcl_Interp *interp, EL734st *pData, - float fRequested, float *fDrive) - { - float fPos; - char pBueffel[132]; - - /* fixed ? */ - if(pData->iFix) - { - Tcl_AppendResult(interp,"Motor fixed",NULL); - return TCL_ERROR; - } - - /* check against SW-boundaries */ - if(pData->iUpFlag) - { - if(fRequested > pData->fSoftUpper) - { - sprintf(pBueffel, - "Requested position: %f violates SW-boundary %f", - fRequested, pData->fSoftUpper); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - return TCL_ERROR; - } - } - if(pData->iLowFlag) - { - if(fRequested < pData->fSoftLower) - { - sprintf(pBueffel, - "Requested position: %f violates SW-boundary %f", - fRequested, pData->fSoftLower); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - return TCL_ERROR; - } - } - - /* correct for zero point */ - if(pData->iZeroFlag) - { - fPos = fRequested - pData->fSoftZero; - } - else - { - fPos = fRequested; - } - - /* check HW-boundaries */ - if( (fPos < pData->fLower) || (fPos > pData->fUpper) ) - { - sprintf(pBueffel," %f outside limits %f %f", - fPos,pData->fLower, pData->fUpper); - Tcl_AppendResult(interp,"Requested position: ", - pBueffel,(char *)NULL); - return TCL_ERROR; - } - - *fDrive = fPos; - return TCL_OK; - - } -/* ------------------------------------------------------------------------- - fucking standard library missing functionality!!!!!!!!!!!!!!!! ----------------------------------------------------------------------------*/ - static float absf(float x) - { - if(x < .0) - return -x; - else - return x; - } - -/*-------------------------------------------------------------------------- - - EL734 Action is the routine where commands send to the motor will - end up. - - Syntax: - motor lim shows motor limits - motor dr val drives the motor to val - motor run val set the motor in motion, without waiting - for completion - motor pos shows motor position - motor fix fixes a motor at a position - motor unfix unfixes a fixed motor - motor zero val set a software zero point - motor upper val sets a software upper limit - motor lower val sets a software lower limit -----------------------------------------------------------------------------*/ -EXTERN int EL734Action(ClientData clientData, Tcl_Interp *interp, - int argc, char *argv[]) -{ - EL734st *pData = (EL734st *)clientData; - char pBueffel[80]; - char *pErr = NULL; - int iRet, iMSR, iOMSR, iFPC, iFRC, iSS; - float fPos, fNpos; - double dPos; - int i; - struct RS__RplyStruct *pReply = NULL; - - - /* check parameters */ - if(argc < 2) - { - Tcl_AppendResult(interp, - "Usage: motor and either dr, pos, hlim slim run zero up lo",(char *)NULL); - return TCL_ERROR; - } - if(pData == NULL) - { - Tcl_AppendResult(interp, - "Motor data lost!!!!!!!!",(char *)NULL); - return TCL_ERROR; - } - - /* check for HW-lim */ - if(strcmp(argv[1],"hlim") == 0) - { - sprintf(pBueffel," %f %f",pData->fLower,pData->fUpper); - Tcl_AppendResult(interp,pBueffel,(char *)NULL); - return TCL_OK; - } - - /* check for SW-lim */ - if(strcmp(argv[1],"slim") == 0) - { - sprintf(pBueffel," %f %f",pData->fSoftLower,pData->fSoftUpper); - Tcl_AppendResult(interp,pBueffel,(char *)NULL); - return TCL_OK; - } - - /* fix & unfix */ - if(strcmp(argv[1],"fix") == 0) - { - pData->iFix = True; - return TCL_OK; - } - if(strcmp(argv[1],"unfix") == 0) - { - pData->iFix = False; - return TCL_OK; - } - - /* reset */ - if(strcmp(argv[1],"reset")== 0) - { - pData->iFix = False; - pData->iLowFlag = False; - pData->iUpFlag = False; - pData->iZeroFlag = False; - return TCL_OK; - } - - /* check for pos */ - if(strcmp(argv[1],"pos") == 0) - { - iRet = EL734_GetStatus(&(pData->pData), - &iMSR, - &iOMSR, - &iFPC, - &iFRC, - &iSS, - &fPos); - if(!iRet) - { - EL734_ErrInfo(&pErr,&iMSR,&iOMSR, &iSS); - EL734Error2Text(pBueffel,iMSR); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - return TCL_ERROR; - } - else - { - if(pData->iZeroFlag) - { - fPos += pData->fSoftZero; - } - sprintf(pBueffel," %f",fPos); - Tcl_AppendResult(interp,pBueffel,NULL); - return TCL_OK; - } - } - - /* zero point */ - if(strcmp(argv[1],"zero") == 0) - { - /* check for zero already been defined */ - if(pData->iZeroFlag) - { - Tcl_AppendResult(interp, - "Request to set new zero point rejected.", - " Use reset before new definition. ", - " I'll get confused otherwise ", - NULL); - return TCL_ERROR; - } - - /* get the new position */ - if(argc < 3) - { - Tcl_AppendResult(interp, - "Usage: motor zero val",NULL); - return TCL_ERROR; - } - - iRet = Tcl_GetDouble(interp,argv[2],&dPos); - fNpos = dPos; - if(iRet == TCL_ERROR) - { - Tcl_AppendResult(interp,"Need float value for new zeropint", - (char *)NULL); - return iRet; - } - pData->fSoftZero = -fNpos; - pData->iZeroFlag = True; - return TCL_OK; - } - - /* upper SW-limit */ - if(strcmp(argv[1],"up") == 0) - { - /* get the new position */ - if(argc < 3) - { - Tcl_AppendResult(interp, - "Usage: motor up val",NULL); - return TCL_ERROR; - } - - iRet = Tcl_GetDouble(interp,argv[2],&dPos); - fNpos = dPos; - if(iRet == TCL_ERROR) - { - Tcl_AppendResult(interp,"Need float value for new upper limit", - (char *)NULL); - return iRet; - } - pData->fSoftUpper = fNpos; - pData->iUpFlag = True; - return TCL_OK; - } - - /* lower SW-limit */ - if(strcmp(argv[1],"lo") == 0) - { - /* get the new position */ - if(argc < 3) - { - Tcl_AppendResult(interp, - "Usage: motor lo val",NULL); - return TCL_ERROR; - } - - iRet = Tcl_GetDouble(interp,argv[2],&dPos); - fNpos = dPos; - if(iRet == TCL_ERROR) - { - Tcl_AppendResult(interp,"Need float value for new lower limit", - (char *)NULL); - return iRet; - } - pData->fSoftLower = fNpos; - pData->iLowFlag = True; - return TCL_OK; - } - - - - /* this is most important: dr for Drive */ - if(strcmp(argv[1],"dr") == 0) - { - /* get the new position */ - if(argc < 3) - { - Tcl_AppendResult(interp, - "Usage: motor dr val",NULL); - return TCL_ERROR; - } - - iRet = Tcl_GetDouble(interp,argv[2],&dPos); - fNpos = dPos; - if(iRet == TCL_ERROR) - { - Tcl_AppendResult(interp,"Need value to drive to", - (char *)NULL); - return iRet; - } - - /* check if compatible with limits */ - if(CheckPos(interp,pData,fNpos,&fPos) == TCL_ERROR) - return TCL_ERROR; - - /* finally move */ - iRet = EL734_MoveWait(&(pData->pData), fPos, &iOMSR, - &iFPC, &iFRC,&fNpos); - /* 99.99999999999% of all code is error checking */ - if(!iRet) - { - EL734_ErrInfo(&pErr,&iMSR,&iOMSR, &iSS); - EL734Error2Text(pBueffel,iMSR); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - return TCL_ERROR; - } - - /* check if driving has been done */ - if(absf(fPos-fNpos) > MOTACURRACY) - { - Tcl_AppendResult(interp, - " Motor error: inacurate driving!", - " Probably something serious is wrong ", - " Check the fucking hardware ", - NULL); - return TCL_ERROR; - } - return TCL_OK; - } - - /* this is most important: run for Driving without waiting */ - if(strcmp(argv[1],"run") == 0) - { - /* get the new position */ - if(argc < 3) - { - Tcl_AppendResult(interp, - "Usage: motor run val",NULL); - return TCL_ERROR; - } - - iRet = Tcl_GetDouble(interp,argv[2],&dPos); - fNpos = dPos; - if(iRet == TCL_ERROR) - { - Tcl_AppendResult(interp,"Need value to run for", - (char *)NULL); - return iRet; - } - - /* check if compatible with limits */ - if(CheckPos(interp,pData,fNpos,&fPos) == TCL_ERROR) - return TCL_ERROR; - - /* finally move */ - iRet = EL734_MoveNoWait (&(pData->pData), fPos); - - /* 99.99999999999% of all code is error checking */ - if(!iRet) - { - EL734_ErrInfo(&pErr,&iMSR,&iOMSR, &iSS); - EL734Error2Text(pBueffel,iMSR); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - return TCL_ERROR; - } - return TCL_OK; - } - - /* the dangerous, undocumented expert command: com: - sends something directly to the motor. All args following - com will be concatenated in one string, closed with \r - and send to the motor . A GetReply will be invoked in order - to yield a return value. Usage by normal motor users strictly - discouraged. - */ - if(strcmp(argv[1],"com") == 0) - { - strcpy(pBueffel,argv[2]); - for(i = 3; i < argc; i++) - { - strcat(pBueffel," "); - strcat(pBueffel,argv[i]); - } - sprintf(pBueffel,"%s\r",pBueffel); - iRet = EL734_SendCmnds(&(pData->pData),pBueffel,NULL); - if(!iRet) - { - EL734_ErrInfo(&pErr,&iMSR,&iOMSR, &iSS); - EL734Error2Text(pBueffel,iMSR); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - return TCL_ERROR; - } - /* fetch reply */ - pReply = (struct RS__RplyStruct *)EL734_GetReply( - &(pData->pData),NULL); - while(pReply != NULL) - { - Tcl_AppendElement(interp,pReply->rply); - pReply = (struct RS__RplyStruct *)EL734_GetReply( - &(pData->pData),pReply); - } - return TCL_OK; - } - - /* if we end here an unknown command has been sent */ - Tcl_AppendResult(interp, - "Usage: motor and either dr, run,zero, pos, hlim" - "slim up low reset fix unfix",(char *)NULL); - return TCL_ERROR; -} -/*--------------------------------------------------------------------------- - - EL734Error2Text converts between an EL734 error code to text ------------------------------------------------------------------------------*/ - void EL734Error2Text(char *pBuffer, int iErr) - { - switch(iErr) - { - case -28: - strcpy(pBuffer,"EL734__BAD_ADR"); - break; - case -8: - strcpy(pBuffer,"EL734__BAD_BIND"); - break; - case -30: - strcpy(pBuffer,"EL734__BAD_BSY"); - break; - case -3: - strcpy(pBuffer,"EL734__BAD_CMD"); - break; - case -9: - strcpy(pBuffer,"EL734__BAD_CONNECT"); - break; - case -23: - strcpy(pBuffer,"EL734__BAD_FLUSH"); - break; - case -6: - strcpy(pBuffer,"EL734__BAD_HOST"); - break; - case -10: - strcpy(pBuffer,"EL734__BAD_ID"); - break; - case -5: - strcpy(pBuffer,"EL734__BAD_ILLG"); - break; - case -2: - strcpy(pBuffer,"EL734__BAD_LOC"); - break; - case -11: - strcpy(pBuffer,"EL734__BAD_MALLOC"); - break; - case -21: - strcpy(pBuffer,"EL734__BAD_NOT_BCD"); - break; - case -4: - strcpy(pBuffer,"EL734__BAD_OFL"); - break; - case -29: - strcpy(pBuffer,"EL734__BAD_PAR"); - break; - - case -17: - strcpy(pBuffer,"EL734__BAD_RECV"); - break; - case -19: - strcpy(pBuffer,"EL734__BAD_RECV_NET"); - break; - case -18: - strcpy(pBuffer,"EL734__BAD_RECV_PIPE"); - break; - case -20: - strcpy(pBuffer,"EL734__BAD_RECV_UNKN"); - break; - case -22: - strcpy(pBuffer,"EL734__BAD_RECVLEN"); - break; - case -24: - strcpy(pBuffer,"EL734__BAD_RECV1"); - break; - case -26: - strcpy(pBuffer,"EL734__BAD_RECV1_NET"); - break; - case -25: - strcpy(pBuffer,"EL734__BAD_RECV1_PIPE"); - break; - case -27: - strcpy(pBuffer,"EL734__BAD_RNG"); - break; - case -13: - strcpy(pBuffer,"EL734__BAD_SEND"); - break; - case -14: - strcpy(pBuffer,"EL734__BAD_SEND_PIPE"); - break; - case -15: - strcpy(pBuffer,"EL734__BAD_SEND_NET"); - break; - case -16: - strcpy(pBuffer,"EL734__BAD_SEND_UNKN"); - break; - case -12: - strcpy(pBuffer,"EL734__BAD_SENDLEN"); - break; - case -7: - strcpy(pBuffer,"EL734__BAD_SOCKET"); - break; - case -1: - strcpy(pBuffer,"EL734__BAD_TMO"); - break; - default: - strcpy(pBuffer,"Unknown EL734 error"); - break; - } - } diff --git a/hardsup/el737_def.h b/hardsup/el737_def.h deleted file mode 100644 index 997e6f32..00000000 --- a/hardsup/el737_def.h +++ /dev/null @@ -1,67 +0,0 @@ -#ifndef _el737_def_ -#define _el737_def_ -/*----------------------------------------- [...LIB.SINQ]EL737_DEF.H Ident V02J -** Definitions for the EL737 Neutron Counter -** -** On UNIX systems, this file is located in /public/lib/include -** On VMS systems, this file is a module in mad_lib:sinq_c.tlb -*/ -#include -#include - -#ifndef OffsetOf -#define OffsetOf(type, identifier) ((size_t)(&((type*) NULL)->identifier)) -#endif - -#ifndef _EL737_errcodes_ -#define _EL737_errcodes_ -#include -#endif - -enum EL737_States { - UNKNOWN = -2, - OFFLINE = -1, - MS = 0x0, - PTS = 0x1, - PCS = 0x2, - LRTS = 0x5, - LRCS = 0x6, - PTSP = 0x9, - PCSP = 0xA, - LRTSP = 0xD, - LRCSP = 0xE}; - -enum EL737_Consts { - VMECNT__PRESET_COUNT, - VMECNT__PRESET_TIME, - - VMECNT__FULL, - VMECNT__SHORT, - VMECNT__INCR}; -/* -** Structure to which the EL737_Open handle points. -*/ - struct EL737info { - struct AsynSrv__info asyn_info; /* Contains skt, host, port & chan */ - int c5, c6, c7, c8; - struct RS__MsgStruct to_host; - struct RS__RespStruct from_host; - }; -/* -** Structure holding everything that is known about a VME Neutron Counter. -*/ - struct Counter_State { - int state; /* RS */ - char timer[16]; /* RT \ RA */ - int cntrs[8]; /* RC 1 ... RC 8 / */ - char rates[8][16]; /* RR 1 ... RR 8 */ - char thresh_integ_time[8][16]; /* DI 1 ... DI 8 */ - char rate_integ_time[16]; /* DT */ - int analog_indx; /* DA */ - int thresh_indx; /* DR */ - char threshes[8][16]; /* DL 1 ... DL 8 */ - int mon_preset; /* MP */ - char timer_preset[16]; /* TP */ - }; -/*----------------------------------------------------- End of EL737_DEF.H --*/ -#endif /* _el737_def_ */ diff --git a/hardsup/el737_errcodes.h b/hardsup/el737_errcodes.h deleted file mode 100644 index 600ff028..00000000 --- a/hardsup/el737_errcodes.h +++ /dev/null @@ -1,27 +0,0 @@ -/* -** TAS_SRC:[LIB]EL737_ERRCODES.H -** -** Include file generated from EL737_ERRCODES.OBJ -** -** 29-AUG-2000 09:49:21.56 -*/ - -#define EL737__NO_VALUE 0x8668094 -#define EL737__NO_SOCKET 0x866808C -#define EL737__NOT_OPEN 0x8668084 -#define EL737__FORCED_CLOSED 0x866807C -#define EL737__CNTR_OVFL 0x8668074 -#define EL737__BAD_TMO 0x866806C -#define EL737__BAD_SOCKET 0x8668064 -#define EL737__BAD_PAR 0x866805C -#define EL737__BAD_OVFL 0x8668054 -#define EL737__BAD_OFL 0x866804C -#define EL737__BAD_MALLOC 0x8668044 -#define EL737__BAD_LOC 0x866803C -#define EL737__BAD_ILLG 0x8668034 -#define EL737__BAD_DEV 0x866802C -#define EL737__BAD_CNTR 0x8668024 -#define EL737__BAD_CMD 0x866801C -#define EL737__BAD_BSY 0x8668014 -#define EL737__BAD_ASYNSRV 0x866800C -#define EL737__FACILITY 0x866 diff --git a/hardsup/el737_utility.c b/hardsup/el737_utility.c deleted file mode 100644 index 383ea83f..00000000 --- a/hardsup/el737_utility.c +++ /dev/null @@ -1,1742 +0,0 @@ -#define ident "2B03" -#ifdef VAXC -#module EL737_Utility ident -#endif -#ifdef __DECC -#pragma module EL737_Utility ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Department ASQ | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]EL737_Utility.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Apr 1996 -** -** To compile this module, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]EL737_Utility - - tasmad_disk:[mad.psi.lib.sinq]EL737_Utility + - - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb EL737_Utility debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb EL737_Utility -** -** Updates: -** 1A01 2-Nov-1995 DM. Initial version. -** 1B01 21-Mar-1996 DM. Move from DELTAT.OLB to SINQ.OLB. -** 1C01 16-Jul-1997 DM. Add code for EL737_Pause -** 2A01 6-Aug-1997 DM. Cope with new RA response format (= timer first) -** Add EL737_GetLongStatus. -** 2B01 5-Aug-1998 DM. Put messages into a .MSG file. -** 2B02 22-Apr-1999 DM. Add EL737_GetThresh and EL737_SetThresh. -**============================================================================ -** The entry points included in this module are described below. Prototypes -** can be defined via: -** -** #include -** -** EL737_Close - Close a connection to an EL737 counter. -** EL737_Config - Configure a connection to an EL737 counter. -** EL737_Continue - Continue a measurement with an EL737 counter. -** EL737_EnableThresh - Enable/disable threshold monitoring. -** EL737_ErrInfo - Return detailed status from last operation. -** EL737_GetMonIntegTime - Get Monitor Integration Time (DI register). -** EL737_GetRateIntegTime - Get Rate Integration Time (DT register). -** EL737_GetStatus - Get 4 counters and counter status. -** EL737_GetStatusExtra - Get counters 5 to 8. -** EL737_GetThresh - Get threshold monitoring status. -** EL737_Open - Open a connection to an EL737 counter. -** EL737_Pause - Pause a measurement with an EL737 counter. -** EL737_SendCmnd - Send a command to RS232C server. -** EL737_SetErrcode - Set up EL737_errcode. -** EL737_SetThresh - Set threshold monitoring level. -** EL737_StartCnt - Start a preset cnt measurement with an EL737. -** EL737_StartTime - Start a preset time measurement with an EL737. -** EL737_Stop - Stop a measurement with an EL737 counter. -** EL737_StopFast - Same as EL737_Stop but no registers are returned. -** EL737_WaitIdle - Wait till status goes to zero. -**--------------------------------------------------------------------- -** int EL737_Close (&handle, force_flag) -** ----------- -** Input Args: -** int force_flag - if non-zero, all connections using the same socket -** will also be closed (this gets AsynSrv_Close to -** actually close the socket and is needed for error -** recovery operations). -** Output Args: -** none -** Modified Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** On return, the pointer is set to NULL. -** Return status: -** True always (error returns from close and free are not checked). -** Routines called: -** AsynSrv_Close -** Description: -** The routine calls AsynSrv_Close to close the connection to the RS232C -** server. If 'force_flag' is non-zero, all other connections to the -** RS232C server which use the same socket will also be closed. -** -** The 'force_flag' can be useful in error recovery situations. The AsynSrv -** utility operates by only opening a socket for each separate combination -** of host/port. Hence, if several connections are open to a server, -** then calling EL737_Close doesn't actually close the socket until all -** connections have been closed. In the situation where an error has been -** detected, it is often desirable to close and re-open the socket as part -** of the recovery procedure. Calling EL737_Close with 'force_flag' -** non-zero will force the socket to be closed and will mark all other -** connections using this socket so that they will be informed of the -** event when they next call try to be used. -** -** Note: The force-close action is effected by the AsynSrv package. A -** force-close will thus also close any connections to other -** RS-232-C devices (e.g. EL734 motors) on the same server. -**------------------------------------------------------------------------- -** int EL737_Config (&handle, &par_id, par_val, ...) -** ------------ -** Input Args: -** char* par_id - Text string identifying the next argument (see below). -** NULL indicates the end of the argument list. -** par_val - The value to set for the argument. The type of the -** argument can depend on par_id. -** Output Args: -** none -** Modified Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** It is used to hold the config info for the connection. -** Return status: -** True if no problems detected, otherwise False and EL737_errcode -** is set to indicate the nature of the problem as follows: -** EL737__BAD_PAR --> Unrecognised par_id or msecTmo < 100 or -** msecTmo > 999'999 or bad eot or .. -** Routines called: -** none -** Description: -** The routine sets values in the EL737info data structure. Values which -** may be taken by par_id (warning -- par_id is case-sensitive) and the -** corresponding variable type of par_val are: -** -** "msecTmo" int The time-out response for commands sent to -** the EL737. The valid range is 100 to -** 999'999. Default is 10'000. -** "eot" char* The expected terminators in responses to -** commands sent to the EL737. The first -** character specifies the number of -** terminators (max=3). Default is "1\r". -**------------------------------------------------------------------------- -** int EL737_Continue (&handle, &status) -** -------------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** Output Args: -** int *status - The status (RS) of the counter after the CO cmnd. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_Continue are (other values may be set by the called routines): -** EL737__OFL, __BAD_CMD, __BAD_TMO, __BAD_ASYNSRV --> see EL737_Open. -** EL737__BAD_ILLG --> the response to the RS command was probably not -** an integer. This could happen if there is noise -** on the RS232C connection to the EL737. -** If an error is detected, *status is set to 0. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** EL737_Continue sends a CO command to the counter to get it to continue -** a paused measurement and then an RS command to read its status. -**------------------------------------------------------------------------- -** int EL737_EnableThresh (&handle, indx) -** ------------------ -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** int indx - The number of the counter to select as the "active" -** threshold monitoring counter. If (indx == 0), -** threshold monitoring is disabled. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_EnableThresh are (other values may be set by the called routines): -** EL737__OFL, __BAD_CMD, __BAD_TMO, __BAD_ASYNSRV --> see EL737_Open. -** EL737__BAD_BSY --> "?2" response received - cntr probably in -** wrong state. -** EL737__BAD_PAR --> Bad parameter. Illegal value for or "?3" -** or "?4" response received. -** EL737__BAD_ILLG --> the response to the commands was illegal in -** some way. This could happen if there is noise -** on the RS232C connection to the EL737. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** A "DR " command is sent to select counter to be the -** "active" threshold monitoring counter. A value of 0 causes -** threshold monitoring to be disabled in the EL737. The threshold -** for the selected counter will not be changed. If it is required -** to set a threshold value as well as enabling monitoring, it is -** simplest to use EL737_SetThresh. -**------------------------------------------------------------------------- -** void EL737_ErrInfo (&entry_txt_ptr, &errcode, &my_errno, &vaxc_errno) -** ------------- -** Input Args: -** None -** Output Args: -** char **entry_txt_ptr - Pointer to a text string giving the call stack -** at the time that the error was detected. -** int *errcode - An internal error code indicating the detected error. -** int *my_errno - Saved value of errno. -** int *vaxc_errno - Saved value of vaxc$errno (OpenVMS only). -** Modified Args: -** none -** Return status: -** none -** Routines called: -** none -** Description: -** Returns detailed status of the last operation. Once an error has been -** detected, the error status is frozen until this routine has been called. -**------------------------------------------------------------------------- -** int EL737_GetMonIntegTime (&handle, indx, &mon_integ_time) -** --------------------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** int indx - The counter whose integ time is wanted. -** Output Args: -** float *mon_integ_time - The integration time used for monitoring -** the rate threshold. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_GetMonIntegTime are (other values may be set by the called -** routines): -** EL737__BAD_TMO, _LOC, _CMD, _OFL, _ADR, _ASYNSRV --> see EL737_Open. -** EL737__BAD_ILLG --> the response was probably not a floating point -** number. This could happen if there is noise -** on the RS232C connection to the EL737. -** If an error is detected, *mon_integ_time is set to 0.1. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** The routine issues a "DI " command to the controller and -** analyses the result. -**------------------------------------------------------------------------- -** int EL737_GetRateIntegTime (&handle, &rate_integ_time) -** ---------------------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** Output Args: -** float *rate_integ_time - The integration time used for calculating -** the rates. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_GetRateIntegTime are (other values may be set by the called -** routines): -** EL737__BAD_TMO, _LOC, _CMD, _OFL, _ADR, _ASYNSRV --> see EL737_Open. -** EL737__BAD_ILLG --> the response was probably not a floating point -** number. This could happen if there is noise -** on the RS232C connection to the EL737. -** If an error is detected, *rate_integ_time is set to 0.1. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** The routine issues a DT command to the controller and -** analyses the result. -**------------------------------------------------------------------------- -** int EL737_GetStatus (&handle, &c1, &c2, &c3, &c4, &timer, &rs) -** --------------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** Output Args: -** int *c1 - Counter 1 (Monitor). -** int *c2 - Counter 2 (Detector). -** int *c3 - Counter 3. -** int *c4 - Counter 4. -** float *timer - The measured time. -** int *rs - The counter status (RS command). -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_GetStatus are (other values may be set by the called routines): -** EL737__BAD_TMO, _LOC, _CMD, _OFL, _ADR, _ASYNSRV --> see EL737_Open. -** EL737__BAD_ILLG --> one of the responses could probably not be -** decoded. This could happen if there is noise -** on the RS232C connection to the EL737. -** If an error is detected, all arguments are set to 0. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** The routine issues an RA and RS command to the controller and -** analyses the result. If a syntax error is detected in either the RA -** or RS response, the routine tries up to 3 times to get a meaningful -** reply. -**------------------------------------------------------------------------- -** int EL737_GetStatusExtra (&handle, &c5, &c6, &c7, &c8) -** -------------------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** Output Args: -** int *c5 - Counter 5. -** int *c6 - Counter 6. -** int *c7 - Counter 7. -** int *c8 - Counter 8. -** Modified Args: -** none -** Return status: -** True always. -** Routines called: -** None -** Description: -** The routine returns values for the counters 5, 6, 7 and 8 from the -** counter's structure. A successful call to any of the routines which -** return values for counters 1, 2, 3 and 4 must precede a call to -** EL737_GetStatusExtra. -**------------------------------------------------------------------------- -** int EL737_GetThresh (&handle, &indx, &val) -** --------------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** Output Args: -** int *indx - The number of the threshold monitor counter. If =0, -** threshold monitoring is disabled. -** float *val - If *indx != 0, the value of the threshold. Otherwise, -** it is zero. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_GetThresh are (other values may be set by the called routines): -** EL737__BAD_TMO, _LOC, _CMD, _OFL, _ADR, _ASYNSRV --> see EL737_Open. -** EL737__BAD_ILLG --> one of the responses could probably not be -** decoded. This could happen if there is noise -** on the RS232C connection to the EL737. -** If an error is detected, all arguments are set to 0. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** The routine issues a DR and, if threshold monitoring is enabled, -** a "DL " command to the controller and analyses the responses. -**------------------------------------------------------------------------- -** int EL737_Open (&handle, &host, port, chan) -** ---------- -** Input Args: -** char *host - Name of host offering the TCP/IP service. -** int port - Number of TCP/IP port of TCP/IP server. -** int chan - RS-232-C Channel number on the TCP/IP server. -** Output Args: -** void *handle - A pointer to a structure of type EL737info needed for -** subsequent calls to EL737_... routines. Buffer space -** for the structure is allocated dynamically. It gets -** released via a call to EL737_Close. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False. If False, EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_Open are (other values may be set by the called routines): -** EL737__BAD_TMO --> Time-out error ("?TMO" - this gets -** generated by the RS232C server). -** EL737__BAD_LOC --> EL737 off-line ("?OF"). This should not -** happen on calls to EL737_Open since it -** sends an "RMT 1" cmnd. -** EL737__BAD_CMD --> Syntax error ("?1"). This could be -** caused by noise in the RS-232-C -** transmission. -** EL737__BAD_OFL --> Connection to EL737 broken ("?OFL"). -** This can get generated by RS232C_SRV -** if, for example, the connection is via -** a terminal server and the terminal -** server loses power. -** EL737__BAD_ILLG --> Some other unrecognised response. This -** should never occur, of course! -** EL737__BAD_DEV --> Device doesn't seem to be an EL737. The -** response to the RA command was bad. -** EL737__BAD_MALLOC --> Call to "malloc" failed. -** EL737__BAD_ASYNSRV --> Call to AsynSrv_SendCmnds failed. Use -** AsynSrv_ErrInfo to get more details. -** Routines called: -** AsynSrv_Open, memory allocation routine "malloc" and AsynSrv_SendCmnds. -** Description: -** The routine opens a TCP/IP connection to a server offering the -** "RS-232-C" service for an EL737 Neutron Counter. "RMT 1" and -** "ECHO 2" commands are sent to ensure the device is on-line and an RA -** command is sent to ensure that an EL737 is being addressed. -**------------------------------------------------------------------------- -** int EL737_Pause (&handle, &status) -** ----------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** Output Args: -** int *status - The status (RS) of the counter after the PS cmnd. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_Pause are (other values may be set by the called routines): -** EL737__OFL, __BAD_CMD, __BAD_TMO, __BAD_ASYNSRV --> see EL737_Open. -** EL737__BAD_ILLG --> the response to the RS command was probably not -** an integer. This could happen if there is noise -** on the RS232C connection to the EL737. -** If an error is detected, *status is set to 0. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** EL737_Pause sends a PS command to the counter to get it to pause -** a measurement and then an RS command to read its status. -**------------------------------------------------------------------------- -** int EL737_SendCmnd (&handle, &cmnd, &rply, rply_size) -** -------------- -** Input Args: -** void **handle - The pntr to the structure returned by EL737_Open. -** char *cmnd - A command, terminated by NULL, for sending to the -** EL737 counter controller. The command must have -** any necessary \r character included. -** int rply_size - the size of the buffer. -** Output Args: -** char *rply - A buffer for receiving the reply. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and errcode (see -** EL737_ErrInfo) is set to indicate the nature of the problem. -** EL737_errcode may be set as follows: -** EL737__BAD_ASYNSRV --> An error occurred in AsynSrv_Utility. -** Call AsynSrv_ErrInfo for more info. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** The command is passed to AsynSrv_SendCmnds and the reply extracted. -**------------------------------------------------------------------------- -** int EL737_SetErrcode (&info_ptr, &response, &cmnd) -** ---------------- -** Set up EL737_errcode (for internal use only) -** Input Args: -** struct EL737info *info_ptr - The pntr to the structure returned by -** EL737_Open. -** char *response - The response received from a command. -** char *cmnd - The command which was sent. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** The value of EL737_errcode. -** Routines called: -** none -** Description: -** The command checks *response for certain keywords and sets EL737_errcode -** accordingly. -**------------------------------------------------------------------------- -** int EL737_SetThresh (&handle, indx, val) -** --------------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** int indx - The number of the counter whose threshold is to -** be set. If (indx == 0), threshold monitoring is -** disabled and val is not used. -** float val - The value of the threshold to be set. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_SetThresh are (other values may be set by the called routines): -** EL737__OFL, __BAD_CMD, __BAD_TMO, __BAD_ASYNSRV --> see EL737_Open. -** EL737__BAD_BSY --> "?2" response received - cntr probably in -** wrong state. -** EL737__BAD_PAR --> Bad parameter. Illegal value for or "?3" -** or "?4" response received. -** EL737__BAD_ILLG --> the response to the commands was illegal in -** some way. This could happen if there is noise -** on the RS232C connection to the EL737. -** Routines called: -** AsynSrv_SendCmnds, EL737_EnableThresh -** Description: -** a) If (indx == 0): EL737_SetThresh simply calls EL737_EnableThresh to -** send a "DR 0" command which will disable threshold -** monitoring by the counter. -** -** b) If (indx != 0): First of all, a "DL ||" command is sent -** to the counter to set the threshold for counter -** to the absolute value of . -** Then, if (val >= 0), EL737_EnableThresh is then called -** to select counter to be the "active" threshold -** monitoring counter. Otherwise, the "active" counter -** is not changed. -**------------------------------------------------------------------------- -** int EL737_StartCnt (&handle, count, &status) -** -------------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** int count - The preset-count for the measurement. -** Output Args: -** int *status - The status (RS) of the counter after the MP cmnd. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_StartCnt are (other values may be set by the called routines): -** EL737__OFL, __BAD_CMD, __BAD_TMO, __BAD_ASYNSRV --> see EL737_Open. -** EL737__BAD_BSY --> "?2" response received - cntr probably in -** wrong state. -** EL737__BAD_PAR --> "?3" response received - bad parameter. -** EL737__BAD_ILLG --> the response to the RS command was probably not -** an integer. This could happen if there is noise -** on the RS232C connection to the EL737. -** If an error is detected, *status is set to 0. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** EL737_StartCnt sends a MP command to the counter to get it to start -** a preset-count measurement and then an RS command to read its status. -**------------------------------------------------------------------------- -** int EL737_StartTime (&handle, timer, &status) -** --------------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** float timer - The preset-time for the measurement. -** Output Args: -** int *status - The status (RS) of the counter after the TP cmnd. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_StartTime are (other values may be set by the called routines): -** EL737__OFL, __BAD_CMD, __BAD_TMO, __BAD_ASYNSRV --> see EL737_Open. -** EL737__BAD_BSY --> "?2" response received - cntr probably in -** wrong state. -** EL737__BAD_PAR --> "?3" response received - bad parameter. -** EL737__BAD_ILLG --> the response to the RS command was probably not -** an integer. This could happen if there is noise -** on the RS232C connection to the EL737. -** If an error is detected, *status is set to 0. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** EL737_StartTime sends a TP command to the counter to get it to start -** a preset-time measurement and then an RS command to read its status. -**------------------------------------------------------------------------- -** int EL737_Stop (&handle, &c1, &c2, &c3, &c4, &timer, &rs) -** ---------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** Output Args: -** int *c1 - Counter 1 (Monitor). -** int *c2 - Counter 2 (Detector). -** int *c3 - Counter 3. -** int *c4 - Counter 4. -** float *timer - The measured time. -** int *rs - The counter status (RS command) after the S cmnd. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL737_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL737_Stop are (other values may be set by the called routines): -** EL737__OFL, __BAD_CMD, __BAD_TMO, __BAD_ASYNSRV --> see EL737_Open. -** EL737__BAD_ILLG --> the response to the RA or RS command was -** probably not an integer. This could happen if -** there is noise on the RS232C connection to the -** EL737. -** If an error is detected, all output args are set to 0. -** Routines called: -** AsynSrv_SendCmnds -** Description: -** EL737_Stop sends an S command to the counter to get it to stop -** a measurement. It then calls EL737_GetStatus to read the registers -** and status. -**------------------------------------------------------------------------- -** int EL737_StopFast (&handle) -** -------------- -** Input Args: -** void **handle - The pointer to the structure returned by EL737_Open. -** Output Args: -** None -** Modified Args: -** none -** Return status: -** See EL737_Stop -** Routines called: -** AsynSrv_SendCmnds -** Description: -** EL737_StopFast sends an S command to the counter to get it to stop -** a measurement. Unlike EL737_Stop, the registers are not read out. -**------------------------------------------------------------------------- -** int EL737_WaitIdle (&handle, &c1, &c2, &c3, &c4, &timer) -** -------------- -** Input Args: -** void **handle - The pntr to the structure returned by EL737_Open. -** Output Args: -** int *c1 \ -** int *c2 \ -** int *c3 \ Same as EL737_GetStatus. -** int *c4 / -** float *timer / -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and Errcode (see -** EL737_ErrInfo) will have been set by the called routines to indicate -** the nature of the problem. -** Routines called: -** EL737_GetStatus -** Description: -** Routine EL737_GetStatus is called repeatedly at a predefined frequency -** until the RS register is zero. -**============================================================================*/ -/* -**--------------------------------------------------------------------------- -** Global Definitions -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include - -#ifdef __VMS - #include -#else - #include - #ifdef FORTIFY - #include - #endif -#endif -/*-----------------------------------------------------------------*/ -#include -#include -#include - -#define True 1 -#define False 0 -/*-------------------------------------------------------------------------- -** Global Variables -*/ - static int EL737_call_depth = 0; - static char EL737_routine[5][64]; - static int EL737_errcode = 0; - static int EL737_errno, EL737_vaxc_errno; -/* -**--------------------------------------------------------------------------- -** EL737_AddCallStack: Add a routine name to the call stack. -** This allows EL737_ErrInfo to generate a -** trace-back in case of error. -*/ - int EL737_AddCallStack ( -/* ================== -*/ struct EL737info *pntr, - char *name) { - - if (EL737_errcode != 0) return False; - - if (EL737_call_depth < 5) { - strcpy (EL737_routine[EL737_call_depth], name); - EL737_call_depth++; - } - - if (pntr == NULL) {EL737_errcode = EL737__NOT_OPEN; return False;} - - if (pntr->asyn_info.skt <= 0) { - memset (pntr->from_host.msg_size, - '0', sizeof (pntr->from_host.msg_size)); - EL737_errcode = (pntr->asyn_info.skt < 0) ? EL737__FORCED_CLOSED - : EL737__NO_SOCKET; - return False; - } - return True; - } -/* -**--------------------------------------------------------------------------- -** EL737_Close: Close a connection to an EL737 counter. -*/ - int EL737_Close ( -/* =========== -*/ void **handle, - int force_flag) { - - struct EL737info *info_ptr; - char buff[4]; - - info_ptr = (struct EL737info *) *handle; - if (info_ptr == NULL) return True; - - if (info_ptr->asyn_info.skt != 0) { - if (info_ptr->asyn_info.skt > 0) { - AsynSrv_Close (*handle, force_flag); - } - } - free (*handle); - *handle = NULL; - - return True; - } -/* -**--------------------------------------------------------------------------- -** EL737_Config: Configure a connection to an EL737 counter. -*/ - int EL737_Config ( -/* ============ -*/ void **handle, - ...) { - - char buff[16]; - va_list ap; /* Pointer to variable args */ - char *txt_ptr; - int intval; - struct EL737info *info_ptr; - /*---------------------------------------------- - */ - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_Config")) return False; - /*---------------------------------------------- - */ - va_start (ap, handle); /* Set up var arg machinery */ - txt_ptr = va_arg (ap, char *); /* Get pntr to first parameter ident */ - while (txt_ptr != NULL) { - if (strcmp (txt_ptr, "msecTmo") == 0) { - intval = va_arg (ap, int); - if ((intval < 100) || (intval > 999999)) { - EL737_errcode = EL737__BAD_PAR; return False; - } - sprintf (buff, "%04d", intval/100); /* Convert to ASCII as .. - ** .. deci-secs */ - memcpy (info_ptr->asyn_info.tmo, buff, 4); - }else if (strcmp (txt_ptr, "eot") == 0) { - txt_ptr = va_arg (ap, char *); - if (txt_ptr == NULL) { - EL737_errcode = EL737__BAD_PAR; return False; - } - memcpy (info_ptr->asyn_info.eot, "\0\0\0\0", 4); - switch (txt_ptr[0]) { - case '3': info_ptr->asyn_info.eot[3] = txt_ptr[3]; - case '2': info_ptr->asyn_info.eot[2] = txt_ptr[2]; - case '1': info_ptr->asyn_info.eot[1] = txt_ptr[1]; - case '0': - info_ptr->asyn_info.eot[0] = txt_ptr[0]; - break; - default: - EL737_errcode = EL737__BAD_PAR; return False; - } - }else { - EL737_errcode = EL737__BAD_PAR; return False; - } - txt_ptr = va_arg (ap, char *); /* Get pntr to next parameter ident */ - } - - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL737_Continue: Continue a measurement with an EL737 counter. -*/ - int EL737_Continue ( -/* ============== -*/ void **handle, - int *status) { - - int my_status; - struct EL737info *info_ptr; - char *rply_ptr0, *rply_ptr1; - /*---------------------------------------------- - */ - *status = 0; - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_Continue")) return False; - /*---------------------------------------------- - ** Send CO and RS cmnds to EL737 - */ - my_status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "CO\r", "RS\r", NULL); - if (!my_status) { - EL737_errcode = EL737__BAD_ASYNSRV; - return False; - } - rply_ptr1 = NULL; - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 != NULL) rply_ptr1 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr0); - - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if (rply_ptr1 == NULL) rply_ptr1 = "?"; - if ( ((*rply_ptr0 == '\0') || (*rply_ptr0 == '\r') ) && - (sscanf (rply_ptr1, "%d", status) == 1)) { - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } - *status = 0; - EL737_SetErrcode (info_ptr, rply_ptr0, "CO\" or \"RS"); - return False; - } -/* -**--------------------------------------------------------------------------- -** EL737_EnableThresh: Enable/disable Threshold Monitoring. -*/ - int EL737_EnableThresh ( -/* ================== -*/ void **handle, - int indx) { - - int status; - char cmnd[20]; - struct EL737info *info_ptr; - char *rply_ptr0; - /*---------------------------------------------- - */ - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_EnableThresh")) return False; - - if ((indx < 0) || (indx > 8)) { - EL737_errcode = EL737__BAD_PAR; return False; - } - /*---------------------------------------------- - ** Send "DR " cmnd to EL737 to select the - ** "active" threshold rate counter. - */ - sprintf (cmnd, "DR %d\r", indx); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd, NULL); - if (!status) { - EL737_errcode = EL737__BAD_ASYNSRV; return False; - } - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if ( (*rply_ptr0 == '\0') || (*rply_ptr0 == '\r') ) { - EL737_call_depth--; - return True; - } - EL737_SetErrcode (info_ptr, rply_ptr0, cmnd); - return False; - } -/* -** ------------------------------------------------------------------------- -** EL737_ErrInfo: Return detailed status from last operation. -*/ - void EL737_ErrInfo ( -/* ============= -*/ char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno) { - - int i; - char buff[80]; - int asyn_errcode, asyn_errno, asyn_vaxerrno; - char* asyn_errtxt; - - if (EL737_call_depth <= 0) { - strcpy (EL737_routine[0], "EL737_no_error_detected"); - *errcode = 0; - *my_errno = 0; - *vaxc_errno = 0; - }else { - if (EL737_call_depth > 1) { /* Concatenate the names */ - for (i = 1; i < EL737_call_depth; i++) { - strcat (EL737_routine[0], "/"); - StrJoin (EL737_routine[0], sizeof (EL737_routine), - EL737_routine[0], EL737_routine[i]); - } - } - *errcode = EL737_errcode; - *my_errno = EL737_errno; - *vaxc_errno = EL737_vaxc_errno; - switch (EL737_errcode) { - case EL737__BAD_ASYNSRV: strcpy (buff, "/EL737__BAD_ASYNSRV"); break; - case EL737__BAD_BSY: strcpy (buff, "/EL737__BAD_BSY"); break; - case EL737__BAD_CMD: strcpy (buff, "/EL737__BAD_CMD"); break; - case EL737__BAD_CNTR: strcpy (buff, "/EL737__BAD_CNTR"); break; - case EL737__BAD_DEV: strcpy (buff, "/EL737__BAD_DEV"); break; - case EL737__BAD_ILLG: strcpy (buff, "/EL737__BAD_ILLG"); break; - case EL737__BAD_LOC: strcpy (buff, "/EL737__BAD_LOC"); break; - case EL737__BAD_MALLOC: strcpy (buff, "/EL737__BAD_MALLOC"); break; - case EL737__BAD_OFL: strcpy (buff, "/EL737__BAD_OFL"); break; - case EL737__BAD_OVFL: strcpy (buff, "/EL737__BAD_OVFL"); break; - case EL737__BAD_PAR: strcpy (buff, "/EL737__BAD_PAR"); break; - case EL737__BAD_SOCKET: strcpy (buff, "/EL737__BAD_SOCKET"); break; - case EL737__BAD_TMO: strcpy (buff, "/EL737__BAD_TMO"); break; - case EL737__CNTR_OVFL: strcpy (buff, "/EL737__CNTR_OVFL"); break; - case EL737__FORCED_CLOSED: strcpy (buff, "/EL737__FORCED_CLOSED"); break; - case EL737__NOT_OPEN: strcpy (buff, "/EL737__NOT_OPEN"); break; - case EL737__NO_SOCKET: strcpy (buff, "/EL737__NO_SOCKET"); break; - case EL737__NO_VALUE: strcpy (buff, "/EL737__NO_VALUE"); break; - default: sprintf (buff, "/EL737__unknown_err_code: %d", EL737_errcode); - } - StrJoin (EL737_routine[0], sizeof(EL737_routine), EL737_routine[0], buff); - } - AsynSrv_ErrInfo (&asyn_errtxt, &asyn_errcode, &asyn_errno, &asyn_vaxerrno); - if (asyn_errcode != 0) { - strcat (EL737_routine[0], "/"); - StrJoin (EL737_routine[0], sizeof(EL737_routine), - EL737_routine[0], asyn_errtxt); - } - *entry_txt = EL737_routine[0]; - EL737_call_depth = 0; - EL737_errcode = 0; - } -/* -**--------------------------------------------------------------------------- -** EL737_GetMonIntegTime: Get DI register value for a counter. -*/ - int EL737_GetMonIntegTime ( -/* ===================== -*/ void **handle, - int indx, - float *mon_integ_time) { - - int status; - char cmnd[20]; - struct EL737info *info_ptr; - char *rply_ptr0; - /*---------------------------------------------- - */ - *mon_integ_time = 0.1; - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_GetMonIntegTime")) return False; - /*---------------------------------------------- - ** Send "DI " cmnd to EL737 - */ - sprintf (cmnd, "DI %d\r", indx); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd, NULL); - if (!status) { - EL737_errcode = EL737__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if (sscanf (rply_ptr0, "%f", mon_integ_time) == 1) { - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } - *mon_integ_time = 0.1; - EL737_SetErrcode (info_ptr, rply_ptr0, cmnd); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL737_GetRateIntegTime: Get DT register value. -*/ - int EL737_GetRateIntegTime ( -/* ====================== -*/ void **handle, - float *rate_integ_time) { - - int status; - struct EL737info *info_ptr; - char *rply_ptr0; - /*---------------------------------------------- - */ - *rate_integ_time = 0.1; - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_GetRateIntegTime")) return False; - /*---------------------------------------------- - ** Send DT cmnd to EL737 - */ - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "DT\r", NULL); - if (!status) { - EL737_errcode = EL737__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if (sscanf (rply_ptr0, "%f", rate_integ_time) == 1) { - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } - EL737_SetErrcode (info_ptr, rply_ptr0, "DT"); - *rate_integ_time = 0.1; - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL737_GetStatus: Get RA/RS register values. -*/ - int EL737_GetStatus ( -/* =============== -*/ void **handle, - int *c1, - int *c2, - int *c3, - int *c4, - float *timer, - int *rs) { - - int i, status, nvals; - struct EL737info *info_ptr; - char *rply_ptr, *p_cmnd; - /*---------------------------------------------- - */ - *c1 = *c2 = *c3 = *c4 = *rs = 0; *timer = 0.0; - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_GetStatus")) return False; - info_ptr->c5 = info_ptr->c6 = info_ptr->c7 = info_ptr->c8 = 0; - /*---------------------------------------------- - ** Send RA and RS cmnds to EL737. Since this routine gets - ** used such a lot, try up to 3 times if a syntax error in - ** the reply is detected. - */ - for (i = 0; i < 3; i++) { - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "RA\r", "RS\r", NULL); - if (!status) {EL737_errcode = EL737__BAD_ASYNSRV; return False;} - p_cmnd = "RA"; - rply_ptr = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr != NULL) { - nvals = sscanf (rply_ptr, "%f %d %d %d %d %d %d %d %d", - timer, c1, c2, c3, c4, - &info_ptr->c5, &info_ptr->c6, - &info_ptr->c7, &info_ptr->c8); - if (nvals != 9) nvals = sscanf (rply_ptr, "%d %d %d %d %f", - c1, c2, c3, c4, timer); - if (nvals == 5) { - info_ptr->c5 = info_ptr->c6 = info_ptr->c7 = info_ptr->c8 = 0; - nvals = 9; - } - if (nvals == 9) { - p_cmnd = "RS"; - rply_ptr = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr); - if (rply_ptr != NULL) { - if (sscanf (rply_ptr, "%d", rs) == 1) { - EL737_call_depth--; - return True; - } - } - } - } - } - if (rply_ptr == NULL) rply_ptr = "?"; - EL737_SetErrcode (info_ptr, rply_ptr, p_cmnd); - *c1 = *c2 = *c3 = *c4 = *rs = 0; *timer = 0.0; - return False; - } -/* -**--------------------------------------------------------------------------- -** EL737_GetStatusExtra: Get values of extra counters. -*/ - int EL737_GetStatusExtra ( -/* ==================== -*/ void **handle, - int *c5, - int *c6, - int *c7, - int *c8) { - - struct EL737info *info_ptr; - /*---------------------------------------------- - */ - *c5 = *c6 = *c7 = *c8 = 0; - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_GetStatusExtra")) return False; - - *c5 = info_ptr->c5; - *c6 = info_ptr->c6; - *c7 = info_ptr->c7; - *c8 = info_ptr->c8; - - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL737_GetThresh: Get threshold monitoring status. -*/ - int EL737_GetThresh ( -/* =============== -*/ void **handle, - int *indx, - float *val) { - - int status, my_indx; - float my_val; - char cmnd[20]; - struct EL737info *info_ptr; - char *rply_ptr0; - /*---------------------------------------------- - */ - *indx = 0; - *val = 0.0; - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_GetThresh")) return False; - /*---------------------------------------------- - ** Send DR cmnd to EL737 to get the number of the - ** "active" threshold rate counter. - */ - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "DR\r", NULL); - if (!status) { - EL737_errcode = EL737__BAD_ASYNSRV; - return False; - } - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if ((sscanf (rply_ptr0, "%d", &my_indx) == 1) && - (my_indx >= 0) && - (my_indx <= 8)) { - *indx = my_indx; - if (my_indx != 0) { - /*---------------------------------------------- - ** Now send DL cmnd to EL737 to get the threshold value. - */ - sprintf (cmnd, "DL %d\r", my_indx); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd, NULL); - if (!status) { - EL737_errcode = EL737__BAD_ASYNSRV; - return False; - } - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if (sscanf (rply_ptr0, "%f", &my_val) == 1) { - *val = my_val; - EL737_call_depth--; - return True; - } - }else { - *val = 0.0; - EL737_call_depth--; - return True; - } - } - EL737_SetErrcode (info_ptr, rply_ptr0, cmnd); - return False; - } -/* -**--------------------------------------------------------------------------- -** EL737_Open: Open a connection to an EL737 counter. -*/ - int EL737_Open ( -/* ========== -*/ void **handle, - char *host, - int port, - int chan) { - - int status, c1, c2, c3, c4, nvals; - float timer; - struct EL737info *my_handle; - char tmo_save[4]; - char *rply_ptr; - char *rply_ptr0; - char *rply_ptr1; - char *rply_ptr2; -/*-------------------------------------------------------- -** Initialise the error info stack and pre-set the -** routine name (in case of error). -*/ - EL737_errcode = EL737_errno = EL737_vaxc_errno = 0; - strcpy (EL737_routine[0], "EL737_Open"); - EL737_call_depth = 1; -/*-------------------------------------------------------- -** Assume trouble -*/ - *handle = NULL; -/*-------------------------------------------------------- -** Reserve space for the data we need to store. -*/ - my_handle = (struct EL737info *) malloc (sizeof (*my_handle)); - if (my_handle == NULL) { - EL737_errcode = EL737__BAD_MALLOC; /* malloc failed!! */ - return False; - } -/*-------------------------------------------------------- -** Set up the connection -*/ - StrJoin (my_handle->asyn_info.host, sizeof (my_handle->asyn_info.host), - host, ""); - my_handle->asyn_info.port = port; - my_handle->asyn_info.chan = chan; - status = AsynSrv_Open (&my_handle->asyn_info); - if (!status) { - EL737_errcode = EL737__BAD_SOCKET; - GetErrno (&EL737_errno, &EL737_vaxc_errno); /* Save errno info */ - fprintf (stderr, "\nEL737_Open/AsynSrv_Open: " - "Failed to make connection.\n"); - free (my_handle); - return False; - } - - memcpy (tmo_save, my_handle->asyn_info.tmo, 4); - EL737_Config ((void *) &my_handle, - "msecTmo", 500, /* Set a short time-out initially since - ** there should be no reason for the RMT, - ** ECHO or RA commands to take very long - */ - "eot", "1\r", - NULL); - /* - ** Now ensure the EL737 is on-line. The first "RMT 1" command can - ** fail due to pending characters in the EL737 input buffer causing - ** the "RMT 1" to be corrupted. The response of the EL737 to this - ** command is ignored for this reason (but the AsynSrv_SendCmnds - ** status must be OK otherwise it indicates a network problem). - */ - status = AsynSrv_SendCmnds (&my_handle->asyn_info, - &my_handle->to_host, &my_handle->from_host, - "RMT 1\r", NULL); - if (status) { - status = AsynSrv_SendCmnds (&my_handle->asyn_info, - &my_handle->to_host, &my_handle->from_host, - "RMT 1\r", "ECHO 2\r", "RA\r", NULL); - } - if (!status) { - /* Some error occurred in AsynSrv_SendCmnds */ - EL737_errcode = EL737__BAD_ASYNSRV; - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - return False; - }else { - /* Check the responses carefully. - */ - rply_ptr1 = rply_ptr2 = NULL; - rply_ptr0 = AsynSrv_GetReply ( - &my_handle->asyn_info, &my_handle->from_host, NULL); - if (rply_ptr0 != NULL) rply_ptr1 = AsynSrv_GetReply ( - &my_handle->asyn_info, &my_handle->from_host, rply_ptr0); - if (rply_ptr1 != NULL) rply_ptr2 = AsynSrv_GetReply ( - &my_handle->asyn_info, &my_handle->from_host, rply_ptr1); - - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if (rply_ptr1 == NULL) rply_ptr1 = "?"; - if (rply_ptr2 == NULL) rply_ptr2 = "?"; - - if (*rply_ptr1 == '?') rply_ptr0 = rply_ptr1; - if (*rply_ptr2 == '?') rply_ptr0 = rply_ptr2; - if (*rply_ptr0 != '?') { - nvals = sscanf (rply_ptr2, "%f %d %d %d %d %d %d %d %d", - &timer, &c1, &c2, &c3, &c4, - &my_handle->c5, &my_handle->c6, - &my_handle->c7, &my_handle->c8); - if (nvals != 9) nvals = sscanf (rply_ptr2, "%d %d %d %d %f", - &c1, &c2, &c3, &c4, &timer); - if (nvals == 5) { - my_handle->c5 = my_handle->c6 = my_handle->c7 = my_handle->c8 = 0; - nvals = 9; - } - if (nvals != 9) { - EL737_errcode = EL737__BAD_DEV; /* Device is not EL737 */ - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - return False; - } - memcpy (my_handle->asyn_info.tmo, tmo_save, 4); /* Restore time-out */ - /* - ** The connection is complete. Pass the data structure - ** back to the caller as a handle. - */ - *handle = my_handle; - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - }else { - EL737_SetErrcode (my_handle, rply_ptr0, "RMT\", \"ECHO\" or \"RA"); - } - } - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - return False; - } -/* -**--------------------------------------------------------------------------- -** EL737_Pause: Pause a measurement with an EL737 counter. -*/ - int EL737_Pause ( -/* =========== -*/ void **handle, - int *status) { - - int my_status; - struct EL737info *info_ptr; - char *rply_ptr0, *rply_ptr1; - /*---------------------------------------------- - */ - *status = 0; - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_Pause")) return False; - /*---------------------------------------------- - ** Send PS and RS cmnds to EL737 - */ - my_status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "PS\r", "RS\r", NULL); - if (!my_status) { - EL737_errcode = EL737__BAD_ASYNSRV; - return False; - }else { - rply_ptr1 = NULL; - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 != NULL) rply_ptr1 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr0); - - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if (rply_ptr1 == NULL) rply_ptr1 = "?"; - if ( ((*rply_ptr0 == '\0') || (*rply_ptr0 == '\r') ) && - (sscanf (rply_ptr1, "%d", status) == 1)) { - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } - EL737_SetErrcode (info_ptr, rply_ptr0, "PS\" or \"RS"); - *status = 0; - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL737_SendCmnd - Send a command to RS232C server. -*/ - int EL737_SendCmnd ( -/* ============== -*/ void **handle, - char *cmnd, - char *rply, - int rply_size) { - - struct EL737info *info_ptr; - int my_status; - char *rply_ptr; - /*---------------------------------------------- - */ - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_SendCmnd")) return False; - /*---------------------------------------------- - ** Send command to EL737. - */ - my_status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd, NULL); - if (!my_status) { - EL737_errcode = EL737__BAD_ASYNSRV; return False; - }else { - rply_ptr = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr == NULL) rply_ptr = "?"; - StrJoin (rply, rply_size, rply_ptr, ""); - } - - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL737_SetErrcode - Set up EL737_errcode -*/ - int EL737_SetErrcode ( -/* ================ -*/ struct EL737info *info_ptr, - char *response, - char *cmnd) { - - int status, s_len; - char *rply; - char tmo_save[4]; - char eot_save[4]; - - EL737_errcode = EL737__BAD_ILLG; - if (strcmp (response, "?OF" ) == 0) EL737_errcode = EL737__BAD_LOC; - if (strcmp (response, "?OFL") == 0) EL737_errcode = EL737__BAD_OFL; - if (strcmp (response, "?OV" ) == 0) EL737_errcode = EL737__BAD_OVFL; - if (strcmp (response, "?1" ) == 0) EL737_errcode = EL737__BAD_CMD; - if (strcmp (response, "?2" ) == 0) EL737_errcode = EL737__BAD_BSY; - if (strcmp (response, "?3" ) == 0) EL737_errcode = EL737__BAD_PAR; - if (strcmp (response, "?4" ) == 0) EL737_errcode = EL737__BAD_CNTR; - if (strcmp (response, "?5" ) == 0) EL737_errcode = EL737__NO_VALUE; - if (strcmp (response, "?6" ) == 0) EL737_errcode = EL737__CNTR_OVFL; - if (strncmp (response, "?TMO", 4) == 0) EL737_errcode = EL737__BAD_TMO; - - if ((EL737_errcode == EL737__BAD_ILLG) && (cmnd != NULL)) { - s_len = strlen (cmnd); - if (cmnd[s_len-1] == '\r') s_len--; - fprintf (stderr, " Unrecognised response to \"%.*s\" command: \"%s\"\n", - s_len, cmnd, response); - } - - return EL737_errcode; - } -/* -**--------------------------------------------------------------------------- -** EL737_SetThresh: Set threshold monitoring level. -*/ - int EL737_SetThresh ( -/* =============== -*/ void **handle, - int indx, - float val) { - - int status; - char cmnd[32]; - struct EL737info *info_ptr; - char *rply_ptr0; - /*---------------------------------------------- - */ - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_SetThresh")) return False; - - if ((indx < 0) || (indx > 8)) { - EL737_errcode = EL737__BAD_PAR; return False; - } - /*---------------------------------------------- - ** If is zero, simply call EL737_EnableThresh to - ** disable threshold monitoring by the counter. - */ - if (indx == 0) { - return EL737_EnableThresh (handle, 0); - } - /*---------------------------------------------- - ** Send "DR ||" cmnd to EL737 to set the - ** threshold for counter . - */ - sprintf (cmnd, "DL %d %.3f\r", indx, fabs (val)); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd, NULL); - if (!status) { - EL737_errcode = EL737__BAD_ASYNSRV; return False; - } - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if ( (*rply_ptr0 == '\0') || (*rply_ptr0 == '\r') ) { - if (val >= 0) return EL737_EnableThresh (handle, indx); - EL737_call_depth--; - return True; - } - EL737_SetErrcode (info_ptr, rply_ptr0, cmnd); - return False; - } -/* -**--------------------------------------------------------------------------- -** EL737_StartCnt: Start a preset cnt measurement with an EL737. -*/ - int EL737_StartCnt ( -/* ============== -*/ void **handle, - int count, - int *status) { - - int my_status; - char cmnd[20]; - struct EL737info *info_ptr; - char *rply_ptr0, *rply_ptr1; - /*---------------------------------------------- - */ - *status = 0; - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_StartCnt")) return False; - /*---------------------------------------------- - ** Send MP and RS cmnds to EL737 - */ - sprintf (cmnd, "MP %d\r", count); /* Encode an appropriate command */ - my_status = AsynSrv_SendCmnds (&info_ptr->asyn_info, /* Send it */ - &info_ptr->to_host, &info_ptr->from_host, - cmnd, "RS\r", NULL); - if (!my_status) { - EL737_errcode = EL737__BAD_ASYNSRV; - return False; - }else { - rply_ptr1 = NULL; - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 != NULL) rply_ptr1 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr0); - - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if (rply_ptr1 == NULL) rply_ptr1 = "?"; - if ( ((*rply_ptr0 == '\0') || (*rply_ptr0 == '\r') ) && - (sscanf (rply_ptr1, "%d", status) == 1)) { - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } - EL737_SetErrcode (info_ptr, rply_ptr0, cmnd); - *status = 0; - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL737_StartTime: Start a preset time measurement with an EL737. -*/ - int EL737_StartTime ( -/* =============== -*/ void **handle, - float timer, - int *status) { - - int my_status; - char cmnd[20]; - struct EL737info *info_ptr; - char *rply_ptr0, *rply_ptr1; - /*---------------------------------------------- - */ - *status = 0; - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_StartTime")) return False; - /*---------------------------------------------- - ** Send TP and RS cmnds to EL737 - */ - sprintf (cmnd, "TP %.2f\r", timer); /* Encode an appropriate command */ - my_status = AsynSrv_SendCmnds (&info_ptr->asyn_info, /* Send it */ - &info_ptr->to_host, &info_ptr->from_host, - cmnd, "RS\r", NULL); - if (!my_status) { - EL737_errcode = EL737__BAD_ASYNSRV; - return False; - }else { - rply_ptr1 = NULL; - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 != NULL) rply_ptr1 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr0); - - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if (rply_ptr1 == NULL) rply_ptr1 = "?"; - if ( ((*rply_ptr0 == '\0') || (*rply_ptr0 == 'r') ) && - (sscanf (rply_ptr1, "%d", status) == 1)) { - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } - EL737_SetErrcode (info_ptr, rply_ptr0, cmnd); - *status = 0; - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL737_Stop: stop a measurement with an EL737 counter. -*/ - int EL737_Stop ( -/* ========== -*/ void **handle, - int *c1, - int *c2, - int *c3, - int *c4, - float *timer, - int *rs) { - - int my_status, nvals; - struct EL737info *info_ptr; - char *rply_ptr0, *rply_ptr1, *rply_ptr2; - /*---------------------------------------------- - */ - *c1 = *c2 = *c3 = *c4 = *rs = 0; *timer = 0.0; - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_Stop")) return False; - /*---------------------------------------------- - ** Send S, RS and RA cmnds to EL737 - */ - my_status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "S\r", "RS\r", "RA\r", NULL); - if (!my_status) { - EL737_errcode = EL737__BAD_ASYNSRV; - return False; - }else { - rply_ptr1 = rply_ptr2 = NULL; - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr0 != NULL) rply_ptr1 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr0); - if (rply_ptr1 != NULL) rply_ptr2 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr1); - - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - if (rply_ptr1 == NULL) rply_ptr1 = "?"; - if (rply_ptr2 == NULL) rply_ptr2 = "?"; - - nvals = sscanf (rply_ptr2, "%f %d %d %d %d %d %d %d %d", - timer, c1, c2, c3, c4, - &info_ptr->c5, &info_ptr->c6, - &info_ptr->c7, &info_ptr->c8); - if (nvals != 9) nvals = sscanf (rply_ptr2, "%d %d %d %d %f", - c1, c2, c3, c4, timer); - if (nvals == 5) { - info_ptr->c5 = info_ptr->c6 = info_ptr->c7 = info_ptr->c8 = 0; - nvals = 9; - } - if ( ((*rply_ptr0 == '\0') || (*rply_ptr0 == '\r') )&& - (sscanf (rply_ptr1, "%d", rs) == 1) && - (nvals == 9)) { - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } - if (*rply_ptr0 != '?') { - if (*rply_ptr1 == '?') rply_ptr0 = rply_ptr1; - if (*rply_ptr0 == '?') rply_ptr0 = rply_ptr2; - } - EL737_SetErrcode (info_ptr, rply_ptr0, "S\", \"RS\" or \"RA"); - *c1 = *c2 = *c3 = *c4 = *rs = 0; *timer = 0.0; - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL737_StopFast: stop a measurement with an EL737 counter. -*/ - int EL737_StopFast ( -/* ============== -*/ void **handle) { - - int my_status, nvals; - struct EL737info *info_ptr; - char *rply_ptr0; - /*---------------------------------------------- - */ - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_StopFast")) return False; - /*---------------------------------------------- - ** Send S cmnd to EL737 - */ - my_status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "S\r", NULL); - if (!my_status) { - EL737_errcode = EL737__BAD_ASYNSRV; - return False; - }else { - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - - if (rply_ptr0 == NULL) rply_ptr0 = "?"; - - if ( (*rply_ptr0 == '\0' || (*rply_ptr0 == '\r') ) ) { - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } - EL737_SetErrcode (info_ptr, rply_ptr0, "S"); - return False; - } - } -/* -**--------------------------------------------------------------------------- -** EL737_WaitIdle: Wait till RS goes to zero. -*/ - int EL737_WaitIdle ( -/* ============== -*/ void **handle, - int *c1, - int *c2, - int *c3, - int *c4, - float *timer) { -#ifdef __VMS -#include -#define hibernate lib$wait (0.25) -#else -#include -#include - struct timespec delay = {0, 250000000}; - struct timespec delay_left; -#ifdef LINUX -#define hibernate nanosleep(&delay, &delay_left) -#else -#define hibernate nanosleep_d9 (&delay, &delay_left) -#endif - -#endif - int my_rs; - struct EL737info *info_ptr; - /*---------------------------------------------- - */ - *c1 = *c2 = *c3 = *c4 = 0; *timer = 0.0; - info_ptr = (struct EL737info *) *handle; - - if (!EL737_AddCallStack (info_ptr, "EL737_WaitIdle")) return False; - /*---------------------------------------------- - ** Keep reading status till idle. - */ - while (EL737_GetStatus (handle, c1, c2, c3, c4, timer, &my_rs)) { - if (my_rs == 0) { - if (EL737_errcode != 0) return False; - EL737_call_depth--; - return True; - } - hibernate; - } - return False; /* Error detected in EL737_GetStatus */ - } -/*-------------------------------------------- End of EL737_Utility.C =======*/ diff --git a/hardsup/el737fix.h b/hardsup/el737fix.h deleted file mode 100644 index 4c7d0a17..00000000 --- a/hardsup/el737fix.h +++ /dev/null @@ -1,33 +0,0 @@ -/*--------------------------------------------------------------------------- - Fix file for David renaming lots of el734 error codes. - - Mark Koennecke, October 1998 -----------------------------------------------------------------------------*/ -#ifndef EL737FIX -#define EL737FIX -#include "asynsrv_errcodes.h" - -#define EL737__BAD_HOST ASYNSRV__BAD_HOST -#define EL737__BAD_BIND ASYNSRV__BAD_BIND -#define EL737__BAD_SENDLEN ASYNSRV__BAD_SEND_LEN -#define EL737__BAD_SEND ASYNSRV__BAD_SEND -#define EL737__BAD_SEND_PIPE ASYNSRV__BAD_SEND_PIPE -#define EL737__BAD_SEND_UNKN ASYNSRV__BAD_SEND_UNKN -#define EL737__BAD_RECV ASYNSRV__BAD_RECV -#define EL737__BAD_RECV_PIPE ASYNSRV__BAD_RECV_PIPE -#define EL737__BAD_RECV_NET ASYNSRV__BAD_RECV_NET -#define EL737__BAD_SEND_NET ASYNSRV__BAD_SEND_NET -#define EL737__BAD_RECV_UNKN ASYNSRV__BAD_RECV_UNKN -#define EL737__BAD_NOT_BCD ASYNSRV__BAD_NOT_BCD -#define EL737__BAD_RECVLEN ASYNSRV__BAD_RECV_LEN -#define EL737__BAD_FLUSH ASYNSRV__BAD_FLUSH -#define EL737__BAD_RECV1 ASYNSRV__BAD_RECV1 -#define EL737__BAD_RECV1_PIPE ASYNSRV__BAD_RECV1_PIPE -#define EL737__BAD_RECV1_NET ASYNSRV__BAD_RECV1_NET -#define EL737__BAD_CONNECT ASYNSRV__BAD_CONNECT -#define EL737__BAD_ID -99995 -#define EL737__BAD_SNTX -99991 -#define EL737__BAD_REPLY -99992 -#define EL737__BAD_ADR -99993 -#define EL737__BAD_RNG -99994 -#endif /* el734fix */ diff --git a/hardsup/el737tcl.c b/hardsup/el737tcl.c deleted file mode 100644 index 510b6c97..00000000 --- a/hardsup/el737tcl.c +++ /dev/null @@ -1,400 +0,0 @@ -/*-------------------------------------------------------------------------- - - Some code to make EL737 COUNTERS as used at SINQ available in TCL. - Just a wrapper around David Maden's COUNTER routines. - - You are free to use and modify this software for noncommercial - usage. - - No warranties or liabilities of any kind taken by me or my employer - - Mark Koennecke July 1996 -----------------------------------------------------------------------------*/ -#include "sinq_prototypes.h" -#include -#include -#include -/* -#include -*/ -#include -#include "el737_def.h" - -#define True 1 -#define False 0 - - typedef struct - { - void *pData; /* EL737 open struct */ - } EL737st; - - EXTERN int EL737Action(ClientData pDat, Tcl_Interp *i, int a, char *argv[]); - static void EL737Error2Text(char *pBuffer, int errcode); - -/*--------------------------------------------------------------------------- - Tcl has a high niceness level. It deletes a command properly when - exiting, reinitializing etc. I use this facility to kill off the - counter initialised in CterEL737. ----------------------------------------------------------------------------*/ -EXTERN void EL737Murder(ClientData pData) -{ - EL737st *pTa = (EL737st *)pData; - EL737_Close(&(pTa->pData)); - free(pData); -} -/*---------------------------------------------------------------------------- - CterEL737 is the main entry point for this stuff. It connects to a counter - and, on success, creates a new command with the name of the counter. - Syntax: - EL737 name host port channel ----------------------------------------------------------------------------*/ - -int CterEL737(ClientData clientData, Tcl_Interp *interp, - int argc, char *argv[]) -{ - int iRet; - EL737st *pEL737 = NULL; - int iPort, iChannel, iMotor; - char *pErr = NULL; - char pBueffel[80]; - - /* check arguments */ - if(argc < 5) - { - Tcl_AppendResult(interp, - " Insufficient arguments: CterEL737 name host port channel" - , (char *) NULL); - return TCL_ERROR; - } - - /* convert arguments */ - iRet = Tcl_GetInt(interp,argv[3],&iPort); - if(iRet == TCL_ERROR) - { - Tcl_AppendResult(interp,"Need integer value for port", - (char *)NULL); - return iRet; - } - - iRet = Tcl_GetInt(interp,argv[4],&iChannel); - if(iRet == TCL_ERROR) - { - Tcl_AppendResult(interp,"Need integer value for channel", - (char *)NULL); - return iRet; - } - - /* make a new pointer, initialise EL737st */ - pEL737 = (EL737st *)malloc(sizeof(EL737st)); - if(pEL737 ==NULL) - { - Tcl_AppendResult(interp,"No memory in EL734",NULL); - return TCL_ERROR; - } - - /* open the rotten Counter, finally */ - iRet = EL737_Open(&(pEL737->pData), argv[2],iPort,iChannel); - if(iRet) /* success */ - { - /* handle TCL, create new command: the Counter */ - Tcl_CreateCommand(interp,strdup(argv[1]),EL737Action, - (ClientData)pEL737,EL737Murder); - Tcl_AppendResult(interp,strdup(argv[1]),(char *)NULL); - return TCL_OK; - } - else - { - EL737_ErrInfo(&pErr,&iPort,&iChannel, &iMotor); - EL737Error2Text(pBueffel,iPort); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - free(pEL737); - return TCL_ERROR; - } -} -/*-------------------------------------------------------------------------- - - EL737 Action is the routine where commands send to the conter will - end up. - - Syntax: timer starts counter with a preset value - counter wait val for counts or time and does - monitor not return before finished - - timer starts counter with a preset value - counter start val for counts or time and - monitor returns immediatly - counter isDone returns True, false depending if - started run has ended or not - counter value gets counter values as a little list - consisting of: - { counts monitor time } - counter Stop forces counter to stop -----------------------------------------------------------------------------*/ -EXTERN int EL737Action(ClientData clientData, Tcl_Interp *interp, - int argc, char *argv[]) -{ - EL737st *pData = (EL737st *)clientData; - char pBueffel[132]; - char pNumBuf[20]; - char *pErr = NULL; - int iC1, iC2, iC3, iC4, iRS, iRet; - float fTime; - int iFlag = 0; - int iMode; - double dVal; - - /* obviously we need at least a keyword! */ - if(argc < 2) - { - Tcl_AppendResult(interp,"No keyword given",NULL); - return TCL_ERROR; - } - - /* get values out */ - if(strcmp(argv[1],"value") == 0) - { - iRet = EL737_GetStatus(&(pData->pData),&iC1, &iC2, &iC3, - &iC4,&fTime,&iRS); - if(!iRet) - { - EL737_ErrInfo(&pErr,&iC1,&iC2, &iC3); - EL737Error2Text(pBueffel,iC1); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - return TCL_ERROR; - } - sprintf(pNumBuf,"%d",iC2); - Tcl_AppendElement(interp,pNumBuf); - sprintf(pNumBuf,"%d",iC1); - Tcl_AppendElement(interp,pNumBuf); - sprintf(pNumBuf,"%f",fTime); - Tcl_AppendElement(interp,pNumBuf); - return TCL_OK; - } - - /* isDone ? */ - if(strcmp(argv[1],"isDone") == 0) - { - iRet = EL737_GetStatus(&(pData->pData),&iC1, &iC2, &iC3, - &iC4,&fTime,&iRS); - if(!iRet) - { - EL737_ErrInfo(&pErr,&iC1,&iC2, &iC3); - EL737Error2Text(pBueffel,iC1); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - return TCL_ERROR; - } - if(iRS == 0) /* done is true */ - { - sprintf(pNumBuf,"%d",True); - } - else - { - sprintf(pNumBuf,"%d",False); - } - Tcl_AppendResult(interp,pNumBuf,(char *) NULL); - return TCL_OK; - } - - /* actual counting neutrons in two different modes */ - if(strcmp(argv[1],"wait") == 0) - { - iFlag = 2; - } - if(strcmp(argv[1],"start") == 0) - { - iFlag = 1; - } - if(iFlag > 0) /* we need to count */ - { - if(argc < 4) /* not enough arguments */ - { - Tcl_AppendResult(interp,"Usage: ",argv[0],argv[1], - " timer or monitor val",NULL); - return TCL_ERROR; - } - - /* timer or monitor preset ? */ - if(strcmp(argv[2],"timer") == 0) - { - iMode = 1; - } - else if (strcmp(argv[2],"monitor") == 0) - { - iMode = 2; - } - else - { - Tcl_AppendResult(interp,"Usage: ",argv[0],argv[1], - " timer or monitor val",NULL); - return TCL_ERROR; - } - - /* get the preset value */ - iRet = Tcl_GetDouble(interp,argv[3],&dVal); - if(iRet == TCL_ERROR) - { - return TCL_ERROR; - } - - /* actual start collecting neutrons */ - if(iMode == 1) - { - iRet = EL737_StartTime(&(pData->pData),(float)dVal, - &iRS); - } - else - { - iRet = EL737_StartCnt(&(pData->pData),(int)dVal, - &iRS); - } - if(!iRet) - { - EL737_ErrInfo(&pErr,&iC1,&iC2, &iC3); - EL737Error2Text(pBueffel,iC1); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - return TCL_ERROR; - } - } /* end of count startup code */ - - /* if apropriate: wait */ - if(iFlag == 2) - { - iRet = EL737_WaitIdle(&(pData->pData),&iC1, &iC2, &iC3, - &iC4,&fTime); - if(!iRet) - { - EL737_ErrInfo(&pErr,&iC1,&iC2, &iC3); - EL737Error2Text(pBueffel,iC1); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - return TCL_ERROR; - } - return TCL_OK; - } - else if(iFlag == 1) - { - return TCL_OK; - } - - /* the stop command */ - if(strcmp(argv[1],"stop") == 0) - { - iRet = EL737_Stop(&(pData->pData),&iC1, &iC2, &iC3, - &iC4,&fTime,&iRS); - if(!iRet) - { - EL737_ErrInfo(&pErr,&iC1,&iC2, &iC3); - EL737Error2Text(pBueffel,iC1); - Tcl_AppendResult(interp,pBueffel,(char *) NULL); - return TCL_ERROR; - } - return TCL_OK; - } - - Tcl_AppendResult(interp," obscure command: ",argv[1], - " not understood by EL737 counter", NULL); - return TCL_ERROR; -} -/*--------------------------------------------------------------------------- - - EL737Error2Text converts between an EL734 error code to text ------------------------------------------------------------------------------*/ - void EL737Error2Text(char *pBuffer, int iErr) - { - switch(iErr) - { - case -28: - strcpy(pBuffer,"EL737__BAD_ADR"); - break; - case -8: - strcpy(pBuffer,"EL737__BAD_OVFL"); - break; - case -30: - strcpy(pBuffer,"EL737__BAD_BSY"); - break; - case -3: - strcpy(pBuffer,"EL737__BAD_SNTX"); - break; - case -9: - strcpy(pBuffer,"EL737__BAD_CONNECT"); - break; - case -23: - strcpy(pBuffer,"EL737__BAD_FLUSH"); - break; - case -6: - strcpy(pBuffer,"EL734__BAD_DEV"); - break; - case -10: - strcpy(pBuffer,"EL737__BAD_ID"); - break; - case -5: - strcpy(pBuffer,"EL737__BAD_ILLG"); - break; - case -2: - strcpy(pBuffer,"EL737__BAD_LOC"); - break; - case -11: - strcpy(pBuffer,"EL737__BAD_MALLOC"); - break; - case -21: - strcpy(pBuffer,"EL737__BAD_NOT_BCD"); - break; - case -4: - strcpy(pBuffer,"EL737__BAD_OFL"); - break; - case -29: - strcpy(pBuffer,"EL737__BAD_PAR"); - break; - - case -17: - strcpy(pBuffer,"EL737__BAD_RECV"); - break; - case -19: - strcpy(pBuffer,"EL737__BAD_RECV_NET"); - break; - case -18: - strcpy(pBuffer,"EL737__BAD_RECV_PIPE"); - break; - case -20: - strcpy(pBuffer,"EL737__BAD_RECV_UNKN"); - break; - case -22: - strcpy(pBuffer,"EL737__BAD_RECVLEN"); - break; - case -24: - strcpy(pBuffer,"EL737__BAD_RECV1"); - break; - case -26: - strcpy(pBuffer,"EL737__BAD_RECV1_NET"); - break; - case -25: - strcpy(pBuffer,"EL737__BAD_RECV1_PIPE"); - break; - case -27: - strcpy(pBuffer,"EL737__BAD_RNG"); - break; - case -13: - strcpy(pBuffer,"EL737__BAD_SEND"); - break; - case -14: - strcpy(pBuffer,"EL737__BAD_SEND_PIPE"); - break; - case -15: - strcpy(pBuffer,"EL737__BAD_SEND_NET"); - break; - case -16: - strcpy(pBuffer,"EL737__BAD_SEND_UNKN"); - break; - case -12: - strcpy(pBuffer,"EL737__BAD_SENDLEN"); - break; - case -7: - strcpy(pBuffer,"EL737__BAD_SOCKET"); - break; - case -1: - strcpy(pBuffer,"EL737__BAD_TMO"); - break; - default: - strcpy(pBuffer,"Unknown EL737 error"); - break; - } - } diff --git a/hardsup/el755_def.h b/hardsup/el755_def.h deleted file mode 100644 index 8cfe339d..00000000 --- a/hardsup/el755_def.h +++ /dev/null @@ -1,31 +0,0 @@ -#ifndef _el755_def_ -#define _el755_def_ -/*------------------------------------------------ EL755_DEF.H Ident V01C -** Definitions for the EL755 Magnet Power Supply Controller -** -** On UNIX systems, this file is located in /public/lib/include -** On VMS systems, this file is a module in mad_lib:sinq_c.tlb -*/ -#include -#include - -#ifndef OffsetOf -#define OffsetOf(type, identifier) ((size_t)(&((type*) NULL)->identifier)) -#endif - -#ifndef _EL755_errcodes_ -#define _EL755_errcodes_ -#include -#endif - -/* -** Structure to which the EL755_Open handle points. -*/ - struct EL755info { - struct AsynSrv__info asyn_info; /* Contains skt, host, port & chan */ - int index; - struct RS__MsgStruct to_host; - struct RS__RespStruct from_host; - }; -/*------------------------------------------------ End of EL755_DEF.H --*/ -#endif /* _el755_def_ */ diff --git a/hardsup/el755_errcodes.h b/hardsup/el755_errcodes.h deleted file mode 100644 index 3b9d2367..00000000 --- a/hardsup/el755_errcodes.h +++ /dev/null @@ -1,27 +0,0 @@ -/* -** TAS_SRC:[LIB]EL755_ERRCODES.H -** -** Include file generated from EL755_ERRCODES.OBJ -** -** 29-AUG-2000 09:49:23.51 -*/ - -#define EL755__TURNED_OFF 0x8678094 -#define EL755__TOO_MANY 0x867808C -#define EL755__TOO_LARGE 0x8678084 -#define EL755__OVFLOW 0x867807C -#define EL755__OUT_OF_RANGE 0x8678074 -#define EL755__OFFLINE 0x867806C -#define EL755__NO_SOCKET 0x8678064 -#define EL755__NOT_OPEN 0x867805C -#define EL755__FORCED_CLOSED 0x8678054 -#define EL755__BAD_TMO 0x867804C -#define EL755__BAD_SOCKET 0x8678044 -#define EL755__BAD_PAR 0x867803C -#define EL755__BAD_OFL 0x8678034 -#define EL755__BAD_MALLOC 0x867802C -#define EL755__BAD_ILLG 0x8678024 -#define EL755__BAD_DEV 0x867801C -#define EL755__BAD_CMD 0x8678014 -#define EL755__BAD_ASYNSRV 0x867800C -#define EL755__FACILITY 0x867 diff --git a/hardsup/el755_errorlog.c b/hardsup/el755_errorlog.c deleted file mode 100644 index 5491d214..00000000 --- a/hardsup/el755_errorlog.c +++ /dev/null @@ -1,26 +0,0 @@ -#define ident "1A01" -#ifdef VAXC -#module EL755_ErrorLog ident -#endif -#ifdef __DECC -#pragma module EL755_ErrorLog ident -#endif - -#include - -/* -**-------------------------------------------------------------------------- -** EL755_ErrorLog: This routine is called by EL755 routines in -** the case of certain errors. It simply prints -** to stderr. The user should supply his own -** routine if he wishes to log these errors in -** some other way. -*/ - void EL755_ErrorLog ( -/* ============== -*/ char *routine_name, - char *text) { - - fprintf (stderr, "%s: %s\n", routine_name, text); - } -/*-------------------------------------------- End of EL755_ErrorLog.C =======*/ diff --git a/hardsup/el755_utility.c b/hardsup/el755_utility.c deleted file mode 100644 index 57cb0212..00000000 --- a/hardsup/el755_utility.c +++ /dev/null @@ -1,1445 +0,0 @@ -#define ident "1A04" -#ifdef VAXC -#module EL755_Utility ident -#endif -#ifdef __DECC -#pragma module EL755_Utility ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Department ASQ | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : TAS_SRC:[PSI.LIB.SINQ]EL755_Utility.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Sep 1998 -** -** To compile this module, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]EL755_Utility - - tas_src:[psi.lib.sinq]EL755_Utility + - - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb EL755_Utility debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb EL755_Utility -** -** Updates: -** 1A01 8-Sep-1998 DM. Initial version. -**============================================================================ -** The entry points included in this module are described below. Prototypes -** can be defined via: -** -** #include -** -** EL755_AddCallStack - Add a routine name to the call stack. -** EL755_Close - Close a connection to an EL755 controller. -** EL755_Config - Configure a connection to an EL755 controller. -** EL755_ErrInfo - Return detailed status from last operation. -** EL755_GetCurrents - Get the actual settings of the EL755 currents. -** EL755_Open - Open a connection to an EL755 controller. -** EL755_PutOffline - Put the EL755 off-line. -** EL755_PutOnline - Put the EL755 on-line. -** EL755_SendTillSameStr - Repeatedly send a command to EL755 controller -** until the same reply is received twice. -** EL755_SendTillSameVal - Repeatedly send a command to EL755 controller -** until the first token of the reply is the -** same fl.pnt. value twice in succession. -** EL755_SetCurrent - Set the EL755 current. -**--------------------------------------------------------------------- -** int EL755_AddCallStack (&info_pntr, &name) -** ------------------ -** Input Args: -** struct EL755info *info_pntr - Pointer to structure returned by -** EL755_Open. Note that the type of the pointer -** is "struct EL755info". -** char *name - The name of the routine to be added to the call stack. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL755_errcode -** is set to indicate the nature of the problem as follows: -** EL755__NOT_OPEN --> there is no connection open to the EL755, -** i.e. info_pntr is NULL. -** EL755__FORCED_CLOSED --> the connection has been force-closed -** (probably as a result of an error -** on another device on the same host). -** EL755__NO_SOCKET --> The connection has no socket - probably -** it was closed after a previous error. -** Note that EL755_errcode may have been set prior to the call to -** EL755_AddCallStack. In this case, the routine simply returns False. -** Routines called: -** None -** Description: -** The routine is designed to simplify the building of the call-stack -** which is available to the user via EL755_ErrInfo if an error occurs. -** It is intended for internal use only. -** -** If an error has aready occurred prior to the call to EL755_AddCallStack -** (i.e. EL755_errcode is non-zero), the routine simply returns False -** to prevent redundant information being added to the stack. -** -** Otherwise, the caller's name is added to the stack and basic checks -** are made of the EL755info structure. -**--------------------------------------------------------------------- -** int EL755_Close (&handle, force_flag) -** ----------- -** Input Args: -** int force_flag - if non-zero, all connections using the same socket -** will also be closed (this gets AsynSrv_Close to -** actually close the socket and is needed for error -** recovery operations). -** Output Args: -** none -** Modified Args: -** void **handle - The pointer to the structure returned by EL755_Open. -** On return, the pointer is set to NULL. -** Return status: -** True always (error returns from close and free are not checked). -** Routines called: -** Socket library, "close" and memory release routine, "free". -** Description: -** The routine calls AsynSrv_Close to close the connection to the RS232C -** server. If 'force_flag' is non-zero, all other connections to the -** RS232C server which use the same socket will also be closed. -** -** The 'force_flag' can be useful in error recovery situations. The AsynSrv -** utility operates by only opening a socket for each separate combination -** of host/port. Hence, if several connections are open to a server, -** then calling EL755_Close doesn't actually close the socket until all -** connections have been closed. In the situation where an error has been -** detected, it is often desirable to close and re-open the socket as part -** of the recovery procedure. Calling EL755_Close with 'force_flag' -** non-zero will force the socket to be closed and will mark all other -** connections using this socket so that they will be informed of the -** event when they next call an AsynSrv routine. -** -** Note: The force-close action is effected by the AsynSrv package. A -** force-close will thus also close any connections to other -** RS-232-C devices (e.g. EL734 motors) on the same server. -**------------------------------------------------------------------------- -** void EL755_Config (&handle, &par_id, par_val, ...) -** ------------ -** Input Args: -** char* par_id - Text string identifying the next argument (see below). -** NULL indicates the end of the argument list. -** par_val - The value to set for the argument. The type of the -** argument can depend on par_id. -** Output Args: -** none -** Modified Args: -** void **handle - The pointer to the structure returned by EL755_Open. -** It is used to hold the config info for the connection. -** Return status: -** True if no problems detected, otherwise False and EL755_errcode -** is set to indicate the nature of the problem. Values of Errcode set by -** EL755_Config are (other values may be set by the called routines): -** EL755__BAD_PAR --> Unrecognised par_id or msecTmo < 100 or -** msecTmo > 999'999 or bad eot or .. -** Routines called: -** EL755_AddCallStack -** Description: -** The routine sets values in the EL755info data structure and may modify -** the state of the temperature controller. Values which may be taken by -** par_id (par_id is case-insensitive) and the corresponding variable -** type of par_val are: -** -** "msecTmo" int The time-out response for commands sent to -** the EL755. The valid range is 100 to -** 999'999. Default is 3'000. -** "eot" char* The expected terminators in responses to -** commands sent to the EL755. The first -** character specifies the number of -** terminators (max=3). Default is "1\n". -** "index" int The DAC index in the range 1 to 8 to be -** referenced via this EL755info structure. -**------------------------------------------------------------------------- -** void EL755_ErrInfo (&entry_txt_ptr, &errcode, &my_errno, &vaxc_errno) -** ------------- -** Input Args: -** None -** Output Args: -** char **entry_txt_ptr - Pointer to a text string giving the call stack -** at the time that the error was detected. -** int *errcode - An internal error code indicating the detected error. -** int *my_errno - Saved value of errno. -** int *vaxc_errno - Saved value of vaxc$errno (OpenVMS only). -** Modified Args: -** none -** Return status: -** none -** Routines called: -** none -** Description: -** Returns detailed status of the last operation. Once an error has been -** detected, the error status is frozen until this routine has been called. -**------------------------------------------------------------------------- -** int EL755_GetCurrents (&handle, &soll, &ist) -** ----------------- -** -** Input Args: -** void **handle - The pointer to the structure returned by EL755_Open -** Output Args: -** float *soll - the requested current. -** float *ist - the actual current. This may me different to *soll -** since the controller ramps to a new current. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL755_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL755_GetCurrents are (other values may be set by the called -** routines): -** EL755__BAD_ASYNSRV --> Call to AsynSrv_SendCmnds failed. Use -** AsynSrv_ErrInfo to get more details. -** EL755__BAD_ILLG --> The response to the "I" command was probably not -** two numbers. This could happen if there is -** noise on the RS232C connection to the EL755. -** EL755__BAD_TMO --> Time-out error ("?TMO" - this gets generated -** by the RS232C server). -** EL755__OFFLINE --> The EL755 is offline ("?OF"). -** EL755__TOO_MANY --> The command was repeated too many times -** and never received the same response -** on 2 consecutive occasions. -** -** If an error is detected, *soll and *ist are undefined. -** Routines called: -** EL755_AddCallStack, AsynSrv_SendCmnds -** Description: -** EL755_Getcurrents sends an "I" command to the controller to obtain the -** currents. The command is repeated until the "soll" value is twice the -** same. -** Note: If the power supply is off or not connected (response is -** "?power-supply OFF", then no error is indicated and *soll=*ist=0.0 -** is returned. -**------------------------------------------------------------------------- -** int EL755_Open (&handle, host, port, chan, indx) -** ---------- -** Input Args: -** char *host - Name of host offering the TCP/IP service. -** int port - Number of TCP/IP port of TCP/IP server. -** int chan - RS-232-C Channel number on the TCP/IP server. -** int indx - The DAC index in the range 1 to 8. This selects which -** of the 8 outputs from the EL755 are to be used. -** Output Args: -** void *handle - A pointer to a structure of type EL755info needed for -** subsequent calls to EL755_??? routines. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False. If False, EL755_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL755_Open are (other values may be set by the called routines): -** EL755__BAD_MALLOC --> Call to "malloc" failed -** EL755__BAD_SOCKET --> Call to AsynSrv_Open failed. Use -** AsynSrv_ErrInfo to get more details. -** EL755__BAD_TMO --> Time-out error ("?TMO" - this gets -** generated by the RS232C server). -** EL755__BAD_OFL --> Connection to EL755 broken ("?OFL"). -** This can get generated by RS232C_SRV -** if, for example, the connection is via -** a terminal server and the terminal -** server loses power. -** EL755__BAD_DEV --> Device doesn't seem to be an EL755. The -** response to the "ID\r" command was bad. -** EL755__BAD_ILLG --> Some other unrecognised response. This -** should never occur, of course! -** EL755__BAD_ASYNSRV --> Call to AsynSrv_SendCmnds failed. Use -** AsynSrv_ErrInfo to get more details. -** Routines called: -** "calloc" - memory allocation routine. -** AsynSrv_Open -** AsynSrv_Close - called if an error detected after connection opened. -** EL755_Config -** EL755_SendTillSameStr -** Description: -** The routine opens a TCP/IP connection to a server offering the -** "RS-232-C" service for an EL755 Controller. "RMT 1", "ECHO 0" and -** "ID" commands are sent to ensure the device is an EL755 controller. -**------------------------------------------------------------------------- -** int EL755_PutOffline (&handle) -** ---------------- -** Send "ECHO 1" and "RMT 0" commands to EL755 server. -** Input Args: -** void **handle - The pntr to the structure returned by EL755_Open. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and errcode (see -** EL755_ErrInfo) is set to indicate the nature of the problem. -** Values of Errcode set by EL755_PutOffline are (other values may be set -** by the called routines): -** EL755__BAD_ASYNSRV --> An error occurred in AsynSrv_Utility. -** Call AsynSrv_ErrInfo for more info. -** EL755__BAD_ILLG --> an unrecognised response. This -** should never occur, of course! -** Routines called: -** EL755_AddCallStack, AsynSrv_SendCmnds, AsynSrv_GetReply -** Description: -** The routine calls AsynSrv_SendCmnds to execute "RMT 1", "ECHO 1" -** and "RMT 0" commands. The replies are checked. -**------------------------------------------------------------------------- -** int EL755_PutOnline (&handle, echo) -** --------------- -** Send "RMT 1" and "ECHO x" commands to EL755 server. -** Input Args: -** void **handle - The pntr to the structure returned by EL755_Open. -** int echo - The value for the ECHO command. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and errcode (see -** EL755_ErrInfo) is set to indicate the nature of the problem. -** Values of Errcode set by EL755_PutOnline are (other values may be set -** by the called routines): -** EL755__BAD_PAR --> "echo" is not 0, 1 or 2. -** EL755__BAD_ASYNSRV --> An error occurred in AsynSrv_Utility. -** Call AsynSrv_ErrInfo for more info. -** EL755__BAD_ILLG --> an unrecognised response. This -** should never occur, of course! -** Routines called: -** EL755_AddCallStack, AsynSrv_SendCmnds, AsynSrv_GetReply -** Description: -** The routine calls AsynSrv_SendCmnds to execute "RMT 1" and "ECHO x" -** commands. The replies are checked. -**------------------------------------------------------------------------- -** int EL755_SendTillSameStr (&handle, &cmnd, &rply, rply_len) -** --------------------- -** Input Args: -** char *cmnd - The command to be sent (incl. terminators). -** int rply_len - The size of . -** Output Args: -** char *rply - The response to . -** Modified Args: -** void **handle - The pointer to the structure returned by EL755_Open. -** Return status: -** True if no problems detected, otherwise False. If False, EL755_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL755_SendTillSameStr are (other values may be set by the called routines): -** EL755__BAD_ASYNSRV --> Call to AsynSrv_SendCmnds failed. Use -** AsynSrv_ErrInfo to get more details. -** EL755__BAD_ILLG --> The response to the "I" command was probably not -** two numbers. This could happen if there is -** noise on the RS232C connection to the EL755. -** EL755__BAD_TMO --> Time-out error ("?TMO" - this gets -** generated by the RS232C server). -** EL755__BAD_CMD --> Bad command ("?syntax failure") -** EL755__BAD_OFL --> Connection to EL755 broken ("?OFL"). -** This can get generated by RS232C_SRV -** if, for example, the connection is via -** a terminal server and the terminal -** server loses power. -** EL755__TOO_MANY --> The command was repeated too many times -** and never received the same response -** on 2 consecutive occasions. -** EL755__OFFLINE --> The EL755 is offline ("?OF"). -** Routines called: -** EL755_AddCallStack, EL755_ErrorLog, AsynSrv_SendCmnds, AsynSrv_GetReply -** Description: -** The routine sends the specified command to the EL755 Controller and -** reads the response. The command is repeated up to 5 times until the same -** response is received twice in succession. -** Note: -** The error EL755__TOO_MANY could indicate that is not big enough -** to hold the complete reply. -**------------------------------------------------------------------------- -** int EL755_SendTillSameVal (&handle, &cmnd, &val) -** --------------------- -** Input Args: -** char *cmnd - The command to be sent (incl. terminators). -** Output Args: -** float *val - The response to . -** Modified Args: -** void **handle - The pointer to the structure returned by EL755_Open. -** Return status: -** True if no problems detected, otherwise False. If False, EL755_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL755_SendTillSameVal are (other values may be set by the called -** routines): -** EL755__BAD_ASYNSRV --> Call to AsynSrv_SendCmnds failed. Use -** AsynSrv_ErrInfo to get more details. -** EL755__BAD_ILLG --> The response to the "I" command was probably not -** two numbers. This could happen if there is -** noise on the RS232C connection to the EL755. -** EL755__BAD_TMO --> Time-out error ("?TMO" - this gets -** generated by the RS232C server). -** EL755__BAD_CMD --> Bad command ("?syntax failure") -** EL755__BAD_OFL --> Connection to EL755 broken ("?OFL"). -** This can get generated by RS232C_SRV -** if, for example, the connection is via -** a terminal server and the terminal -** server loses power. -** EL755__TOO_MANY --> The command was repeated too many times -** and never received the same response -** on 2 consecutive occasions. -** EL755__OFFLINE --> The EL755 is offline ("?OF"). -** Routines called: -** EL755_AddCallStack, EL755_ErrorLog, AsynSrv_SendCmnds, AsynSrv_GetReply -** Description: -** The routine sends the specified command to the EL755 Controller and -** reads the response. The command is repeated up to 5 times until the -** first token is the same fl.pnt value twice in succession. -** Note 1: -** The error EL755__TOO_MANY could indicate that is not big enough -** to hold the complete reply. -** Note 2: If the power supply is off or not connected (response is -** "?power-supply OFF") then a zero value is returned and the -** return status is True -**------------------------------------------------------------------------- -** int EL755_SetCurrent (&handle, soll) -** ---------------- -** -** Input Args: -** void **handle - The pointer to the structure returned by EL755_Open -** float soll - the requested current. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and EL755_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** EL755_SetCurrent are (other values may be set by the called -** routines): -** EL755__TURNED_OFF --> The EL755 power supply on this channel is -** turned off ("?power-supply OFF"). -** EL755__OUT_OF_RANGE --> The set value is out of -** range ("?value out of range"). -** EL755__TOO_LARGE --> The set value is too -** large ("?current limitation"). -** EL755__BAD_ILLG --> the response to the first "I" command was -** not null (indicating that the command was -** rejected) or the response to the second -** "I" command was probably not two numbers. -** This could happen if there is noise -** on the RS232C connection to the EL755. -** Routines called: -** EL755_SendTillSameStr, EL755_GetCurrests -** Description: -** EL755_SetCurrent sends an "I" command to the controller to set the -** current for the DAC index selected for the handle. An "I" is sent -** to check that the value was sent correctly. -** Note: If the power supply is off or not connected (response is -** "?power-supply OFF") and soll == 0.0, then return status is True. -**============================================================================*/ -/* -**--------------------------------------------------------------------------- -** Global Definitions -*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include - -#ifdef __VMS -#include -#else -#include -#endif -/*-----------------------------------------------------------------*/ -#include -#include -#include - -#define True 1 -#define False 0 -#define NIL '\0' -/*-------------------------------------------------------------------------- -** Global Variables -*/ - static int EL755_call_depth = 0; - static char EL755_routine[5][64]; - static int EL755_errcode = 0; - static int EL755_errno, EL755_vaxc_errno; -/* -**--------------------------------------------------------------------------- -** EL755_AddCallStack: Add a routine name to the call stack. -** This allows EL755_ErrInfo to generate a -** trace-back in case of error. -*/ - int EL755_AddCallStack ( -/* ================== -*/ struct EL755info *pntr, - char *name) { - - if (EL755_errcode != 0) return False; - - if (EL755_call_depth < 5) { - StrJoin (EL755_routine[EL755_call_depth], sizeof (EL755_routine[0]), - name, ""); - EL755_call_depth++; - } - - if (pntr == NULL) {EL755_errcode = EL755__NOT_OPEN; return False;} - - if (pntr->asyn_info.skt <= 0) { - memset (pntr->from_host.msg_size, - '0', sizeof (pntr->from_host.msg_size)); - EL755_errcode = (pntr->asyn_info.skt < 0) ? EL755__FORCED_CLOSED - : EL755__NO_SOCKET; - return False; - } - return True; - } -/* -**--------------------------------------------------------------------------- -** EL755_Close: Close a connection to an EL755 controller. -*/ - int EL755_Close ( -/* =========== -*/ void **handle, - int force_flag) { - - struct EL755info *info_ptr; - char buff[4]; - - info_ptr = (struct EL755info *) *handle; - if (info_ptr == NULL) return True; - - if (info_ptr->asyn_info.skt != 0) { - if (info_ptr->asyn_info.skt > 0) { - AsynSrv_Close (*handle, force_flag); - } - } - free (*handle); - *handle = NULL; - - return True; - } -/* -**--------------------------------------------------------------------------- -** EL755_Config: Configure a connection to an EL755 controller. -*/ - int EL755_Config ( -/* ============ -*/ void **handle, - ...) { - - struct EL755info *info_ptr; - char buff[80], rply[256], my_txt[16]; - va_list ap; /* Pointer to variable args */ - char *txt_ptr; - int intval, my_txt_l; - /*---------------------------------------------- - */ - info_ptr = (struct EL755info *) *handle; - - if (!EL755_AddCallStack (info_ptr, "EL755_Config")) return False; - /*---------------------------------------------- - */ - va_start (ap, handle); /* Set up var arg machinery */ - txt_ptr = va_arg (ap, char *); /* Get pntr to first parameter ident */ - while (txt_ptr != NULL) { - my_txt_l = sizeof (my_txt); - StrEdit (my_txt, txt_ptr, "lowercase", &my_txt_l); - /*------------------------------------*/ - if (strcmp (my_txt, "msectmo") == 0) { - intval = va_arg (ap, int); - if ((intval < 100) || (intval > 999999)) { - EL755_errcode = EL755__BAD_PAR; return False; - } - sprintf (buff, "%04d", intval/100); /* Convert to ASCII as .. - ** .. deci-secs */ - memcpy (info_ptr->asyn_info.tmo, buff, 4); - /*------------------------------------*/ - }else if (strcmp (my_txt, "eot") == 0) { - txt_ptr = va_arg (ap, char *); - if (txt_ptr == NULL) { - EL755_errcode = EL755__BAD_PAR; - return False; - } - memcpy (info_ptr->asyn_info.eot, "\0\0\0\0", 4); - switch (txt_ptr[0]) { - case '3': info_ptr->asyn_info.eot[3] = txt_ptr[3]; - case '2': info_ptr->asyn_info.eot[2] = txt_ptr[2]; - case '1': info_ptr->asyn_info.eot[1] = txt_ptr[1]; - case '0': - info_ptr->asyn_info.eot[0] = txt_ptr[0]; - break; - default: - EL755_errcode = EL755__BAD_PAR; - return False; - } - /*------------------------------------*/ - }else if (strcmp (txt_ptr, "index") == 0) { - intval = va_arg (ap, int); - if ((intval < 1) || (intval > 8)) { - EL755_errcode = EL755__BAD_PAR; - return False; - } - info_ptr->index = intval; - /*------------------------------------*/ - }else { - EL755_errcode = EL755__BAD_PAR; - return False; - } - /*------------------------------------*/ - txt_ptr = va_arg (ap, char *); /* Get pntr to next parameter ident */ - } - - if (EL755_errcode == 0) EL755_call_depth--; - return True; - } -/* -** ------------------------------------------------------------------------- -** EL755_ErrInfo: Return detailed status from last operation. -*/ - void EL755_ErrInfo ( -/* ============= -*/ char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno) { - - int i, j, k; - char buff[80]; - int asyn_errcode, asyn_errno, asyn_vaxerrno; - char* asyn_errtxt; - - if (EL755_call_depth <= 0) { - strcpy (EL755_routine[0], "EL755_no_error_detected"); - *errcode = 0; - *my_errno = 0; - *vaxc_errno = 0; - }else { - if (EL755_call_depth > 1) { /* Concatenate the names */ - for (i = 1; i < EL755_call_depth; i++) { - strcat (EL755_routine[0], "/"); - StrJoin (EL755_routine[0], sizeof (EL755_routine), - EL755_routine[0], EL755_routine[i]); - } - } - *errcode = EL755_errcode; - *my_errno = EL755_errno; - *vaxc_errno = EL755_vaxc_errno; - switch (EL755_errcode) { - case EL755__BAD_ASYNSRV: strcpy (buff, "/EL755__BAD_ASYNSRV"); break; - case EL755__BAD_CMD: - case EL755__BAD_DEV: strcpy (buff, "/EL755__BAD_DEV"); break; - case EL755__BAD_ILLG: strcpy (buff, "/EL755__BAD_ILLG"); break; - case EL755__BAD_MALLOC: strcpy (buff, "/EL755__BAD_MALLOC"); break; - case EL755__BAD_OFL: strcpy (buff, "/EL755__BAD_OFL"); break; - case EL755__BAD_PAR: strcpy (buff, "/EL755__BAD_PAR"); break; - case EL755__BAD_SOCKET: strcpy (buff, "/EL755__BAD_SOCKET"); break; - case EL755__BAD_TMO: strcpy (buff, "/EL755__BAD_TMO"); break; - case EL755__FORCED_CLOSED: strcpy (buff, "/EL755__FORCED_CLOSED"); break; - case EL755__NOT_OPEN: strcpy (buff, "/EL755__NOT_OPEN"); break; - case EL755__NO_SOCKET: strcpy (buff, "/EL755__NO_SOCKET"); break; - case EL755__OFFLINE: strcpy (buff, "/EL755__OFFLINE"); break; - case EL755__OUT_OF_RANGE: strcpy (buff, "/EL755__OUT_OF_RANGE"); break; - case EL755__OVFLOW: strcpy (buff, "/EL755__OVFLOW"); break; - case EL755__TOO_LARGE: strcpy (buff, "/EL755__TOO_LARGE"); break; - case EL755__TOO_MANY: strcpy (buff, "/EL755__TOO_MANY"); break; - case EL755__TURNED_OFF: strcpy (buff, "/EL755__TURNED_OFF"); break; - default: sprintf (buff, "/EL755__unknown_err_code: %d", EL755_errcode); - } - StrJoin (EL755_routine[0], sizeof(EL755_routine), EL755_routine[0], buff); - } - AsynSrv_ErrInfo (&asyn_errtxt, &asyn_errcode, &asyn_errno, &asyn_vaxerrno); - if (asyn_errcode != 0) { - strcat (EL755_routine[0], "/"); - StrJoin (EL755_routine[0], sizeof(EL755_routine), - EL755_routine[0], asyn_errtxt); - } - *entry_txt = EL755_routine[0]; - EL755_call_depth = 0; - EL755_errcode = 0; - } -/* -**--------------------------------------------------------------------------- -** EL755_GetCurrents: Get currents from EL755. -*/ - int EL755_GetCurrents ( -/* ================= -*/ void **handle, - float *soll, - float *ist) { - - int iret; - char cmnd[32]; - struct EL755info *info_ptr; - /*---------------------------------------------- - */ - *soll = *ist = 0.0; - info_ptr = (struct EL755info *) *handle; - - if (!EL755_AddCallStack (info_ptr, "EL755_GetCurrents")) return False; - /*---------------------------------------------- - ** Send I command to get EL755 currents. Repeat until - ** first value is same 2 times consecutively. - */ - sprintf (cmnd, "I %d\r", info_ptr->index); - iret = EL755_SendTillTwoVals (handle, cmnd, soll, ist); - if (!iret) return False; - - if (EL755_errcode == 0) EL755_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL755_Open: Open a connection to an EL755 controller. -*/ - int EL755_Open ( -/* ========== -*/ void **handle, - char *host, - int port, - int chan, - int indx) { - - int status, i; - char tmo_save[4]; - char *rply_ptr0, *rply_ptr1, *rply_ptr2; - struct EL755info *my_handle; -/*-------------------------------------------------------- -** Initialise the error info stack and pre-set the -** routine name (in case of error). -*/ - EL755_errcode = EL755_errno = EL755_vaxc_errno = 0; - strcpy (EL755_routine[0], "EL755_Open"); - EL755_call_depth = 1; -/*-------------------------------------------------------- -** Assume trouble -*/ - *handle = NULL; -/*-------------------------------------------------------- -** Reserve space for the data we need to store. -*/ - my_handle = (struct EL755info *) calloc (1, sizeof (*my_handle)); - if (my_handle == NULL) { - EL755_errcode = EL755__BAD_MALLOC; /* calloc failed!! */ - return False; - } -/*-------------------------------------------------------- -** Set up the connection -*/ - StrJoin (my_handle->asyn_info.host, sizeof (my_handle->asyn_info.host), - host, ""); - my_handle->asyn_info.port = port; - my_handle->asyn_info.chan = chan; - status = AsynSrv_Open (&my_handle->asyn_info); - if (!status) { - EL755_errcode = EL755__BAD_SOCKET; - GetErrno (&EL755_errno, &EL755_vaxc_errno); /* Save errno info */ - EL755_ErrorLog ("EL755_Open/AsynSrv_Open", "Failed to make connection."); - free (my_handle); - return False; - } - memcpy (tmo_save, my_handle->asyn_info.tmo, 4); - status = EL755_Config ((void *) &my_handle, - "msecTmo", 100, /* Set a short time-out initially since - ** there should be no reason for the RMT, - ** ECHO or ID commands to take very long. - */ - "eot", "1\r", - "index", indx, - NULL); - if (!status) { - /* Some error occurred in EL755_Config - should be impossible! - */ - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - return False; - } - /* - ** Now ensure that there's an EL755 connected to the line. The first - ** "RMT 1" command can fail due to pending characters in the EL755 - ** input buffer causing the command to be corrupted. The response is - ** ignored for this reason. - */ - status = AsynSrv_SendCmnds (&my_handle->asyn_info, - &my_handle->to_host, &my_handle->from_host, - "RMT 1\r", /* Try to put EL755 on-line */ - "RMT 1\r", /* Try again in case type-ahead chars corrupted .. - ** .. the first attempt. */ - "ECHO 0\r", /* And turn off echoing */ - NULL); - status = AsynSrv_SendCmnds (&my_handle->asyn_info, - &my_handle->to_host, &my_handle->from_host, - "RMT 1\r", - "ECHO 0\r", - "ID\r", - NULL); - if (!status) { - /* Some error occurred in AsynSrv_SendCmnds. - */ - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - EL755_errcode = EL755__BAD_ASYNSRV; - return False; - } - - rply_ptr0 = AsynSrv_GetReply (&my_handle->asyn_info, - &my_handle->from_host, NULL); - rply_ptr1 = AsynSrv_GetReply (&my_handle->asyn_info, - &my_handle->from_host, rply_ptr0); - rply_ptr2 = AsynSrv_GetReply (&my_handle->asyn_info, - &my_handle->from_host, rply_ptr1); - if ((rply_ptr0 == NULL) || (rply_ptr1 == NULL) || (rply_ptr2 == NULL)) { - /* Some error occurred in AsynSrv_GetReply. - */ - EL755_AddCallStack (my_handle, "NULL response"); - AsynSrv_Close (&my_handle->asyn_info, False); - EL755_errcode = EL755__BAD_DEV; - free (my_handle); - return False; - } - if (rply_ptr0[0] != '\0') { - EL755_AddCallStack (my_handle, rply_ptr0); - AsynSrv_Close (&my_handle->asyn_info, False); /* Bad response! */ - EL755_errcode = EL755__BAD_DEV; - free (my_handle); - return False; - } - if (rply_ptr1[0] != '\0') { - EL755_AddCallStack (my_handle, rply_ptr1); - AsynSrv_Close (&my_handle->asyn_info, False); /* Bad response! */ - EL755_errcode = EL755__BAD_DEV; - free (my_handle); - return False; - } - if (strncmp (rply_ptr2, "EL755 MAGST", 11) != 0) { - EL755_AddCallStack (my_handle, rply_ptr2); - AsynSrv_Close (&my_handle->asyn_info, False); /* Bad response! */ - EL755_errcode = EL755__BAD_DEV; - free (my_handle); - return False; - } - /* The device seems to be an EL755! */ - - memcpy (my_handle->asyn_info.tmo, tmo_save, 4); /* Restore time-out */ - /* - ** The connection is complete. Pass the data structure - ** back to the caller as a handle. - */ - *handle = my_handle; - if (EL755_errcode == 0) EL755_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL755_PutOffline: put the EL755 off-line -*/ - int EL755_PutOffline ( -/* ================ -*/ void **handle) { - - int status; - struct EL755info *info_ptr; - char *rply_ptr0, *rply_ptr1, *rply_ptr2; - char buff[132]; - /*---------------------------------------------- - */ - info_ptr = (struct EL755info *) *handle; - - if (!EL755_AddCallStack (info_ptr, "EL755_PutOffline")) return False; - /*---------------------------------------------- - ** The problem which this routine has is that the EL755 - ** may already be off-line. The following is, therefore, - ** rather pedantic for most cases which occur in practice. - */ - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "RMT 1\r", - "RMT 1\r", - "ECHO 1\r", - "RMT 0\r", - NULL); - if (!status) { - EL755_errcode = EL755__BAD_ASYNSRV; - return False; - } - - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "RMT\r", "", NULL); - if (!status) { - EL755_errcode = EL755__BAD_ASYNSRV; - return False; - } - - rply_ptr0 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - rply_ptr1 = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, rply_ptr0); - if ((rply_ptr0 == NULL) || (rply_ptr1 == NULL)) { - EL755_AddCallStack (info_ptr, "NULL response"); - EL755_errcode = EL755__BAD_ILLG; return False;} - - if ((strcmp (rply_ptr0, "RMT") == 0) && - (strcmp (rply_ptr1, "\n0") == 0)) { - EL755_call_depth--; - return True; - } - - if (strcmp (rply_ptr0, "?OF") == 0) { - EL755_errcode = EL755__OFFLINE; - }else if (strcmp (rply_ptr0, "?OFL") == 0) { - EL755_errcode = EL755__BAD_OFL; - }else if (strcmp (rply_ptr0, "?syntax failure") == 0) { - EL755_errcode = EL755__BAD_CMD; - }else if (strncmp (rply_ptr0, "?TMO", 4) == 0) { - EL755_errcode = EL755__BAD_TMO; - }else { - sprintf (buff, "Cmnd=\"RMT.\" Rply0=\"%.10s\" Rply1=\"%.10s\"", - rply_ptr0, rply_ptr1); - MakePrintable (buff, sizeof(buff), buff); - EL755_AddCallStack (info_ptr, buff); - - sprintf (buff, "Unrecognised responses to RMT command: \"%s\" \"%s\"", - rply_ptr0, rply_ptr1); - MakePrintable (buff, sizeof(buff), buff); - EL755_ErrorLog (EL755_routine[EL755_call_depth-1], buff); - - EL755_errcode = EL755__BAD_ILLG; - } - return False; - } -/* -**--------------------------------------------------------------------------- -** EL755_PutOnline: put the EL755 on-line -*/ - int EL755_PutOnline ( -/* =============== -*/ void **handle, - int echo) { - - int status, my_echo; - struct EL755info *info_ptr; - char cmnd0[10], buff[132]; - char *rply_ptr; - /*---------------------------------------------- - */ - info_ptr = (struct EL755info *) *handle; - - if (!EL755_AddCallStack (info_ptr, "EL755_PutOnline")) return False; - /*---------------------------------------------- - */ - if ((echo != 0) && (echo != 1)) { - EL755_errcode = EL755__BAD_PAR; return False; - } - /*---------------------------------------------- - ** The problem which this routine has is that the state - ** of the EL755 is not known. The following is, therefore, - ** rather pedantic for most cases which occur in practice. - */ - sprintf (cmnd0, "ECHO %d\r", echo); - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "RMT 1\r", - "RMT 1\r", - cmnd0, - NULL); - if (!status) { - EL755_errcode = EL755__BAD_ASYNSRV; - return False; - } - - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - "ECHO\r", NULL); - if (!status) { - EL755_errcode = EL755__BAD_ASYNSRV; - return False; - } - - rply_ptr = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr == NULL) { - EL755_AddCallStack (info_ptr, "NULL response"); - EL755_errcode = EL755__BAD_ILLG; return False;} - - if ((echo == 1) && (strcmp (rply_ptr, "ECHO") == 0)) { - EL755_call_depth--; - return True; - }else if ((echo == 0) && - (sscanf (rply_ptr, "%d", &my_echo) == 1) && - (my_echo == echo)) { - EL755_call_depth--; - return True; - } - - if (strcmp (rply_ptr, "?OF") == 0) { - EL755_errcode = EL755__OFFLINE; - }else if (strcmp (rply_ptr, "?OFL") == 0) { - EL755_errcode = EL755__BAD_OFL; - }else if (strcmp (rply_ptr, "?syntax failure") == 0) { - EL755_errcode = EL755__BAD_CMD; - }else if (strncmp (rply_ptr, "?TMO", 4) == 0) { - EL755_errcode = EL755__BAD_TMO; - }else { - sprintf (buff, "Cmnd=\"ECHO.\" Rply=\"%.10s\"", rply_ptr); - MakePrintable (buff, sizeof(buff), buff); - EL755_AddCallStack (info_ptr, buff); - - sprintf (buff, "Unrecognised response to ECHO command: \"%s\"", - rply_ptr); - MakePrintable (buff, sizeof(buff), buff); - EL755_ErrorLog (EL755_routine[EL755_call_depth-1], buff); - - EL755_errcode = EL755__BAD_ILLG; - } - return False; - } -/* -**--------------------------------------------------------------------------- -** EL755_SendTillSameStr: Repeat a command until we get the same -** response on 2 successive occasions. -** -** This routine is intended for internal use only! -** If too many retries, EL755_errcode is set to EL755__TOO_MANY. -*/ - int EL755_SendTillSameStr ( -/* ===================== -*/ void **handle, - char *cmnd, - char *rply, - int rply_len) { - - int iret, i, j, n_ovfl; - struct EL755info *info_ptr; - char *rply_ptr; - char buff[132]; - char replies[6][64]; - /*---------------------------------------------- - */ - info_ptr = (struct EL755info *) *handle; - - if (!EL755_AddCallStack (info_ptr, "EL755_SendTillSameStr")) return False; - /*---------------------------------------------- - ** Send command. Do it in a - ** loop until we get the same response twice to guard - ** against RS-232-C problems with the EL755. - */ - i = n_ovfl = 0; - StrJoin (rply, rply_len, "#", ""); - - while (i < 6) { - iret = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd, NULL); - if (!iret) { - EL755_errcode = EL755__BAD_ASYNSRV; return False;} - rply_ptr = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr == NULL) { - EL755_AddCallStack (info_ptr, "NULL response"); - EL755_errcode = EL755__BAD_ILLG; return False;} - if (strncmp (rply_ptr, "?TMO", 4) == 0) { - EL755_errcode = EL755__BAD_TMO; return False;} - if (strcmp (rply_ptr, "?OF") == 0) { - EL755_errcode = EL755__OFFLINE; return False;} - if (strcmp (rply_ptr, "?OFL") == 0) { - EL755_errcode = EL755__BAD_OFL; return False;} - if (strcmp (rply_ptr, "?syntax failure") == 0) { - EL755_errcode = EL755__BAD_CMD; return False;} - if (strcmp (rply_ptr, "?OV") == 0) { /* Check for overflow. This seems - ** to be an EL755 problem which - ** needs fixing. In the meantime, - ** just force a repeat. - */ - sprintf (buff, "Warning -- \"?OV\" received in response to \"%s\".", - cmnd); - MakePrintable (buff, sizeof(buff), buff); - EL755_ErrorLog (EL755_routine[EL755_call_depth-1], buff); - n_ovfl++; - if (n_ovfl > 10) {EL755_errcode = EL755__TOO_MANY; return False;} - }else { - n_ovfl = 0; - if (strncmp (rply, rply_ptr, rply_len) == 0) break; - StrJoin (rply, rply_len, rply_ptr, ""); - MakePrintable (replies[i], sizeof (replies[0]), rply_ptr); - i++; - } - } - if (strncmp (rply, rply_ptr, rply_len) != 0) { - EL755_errcode = EL755__TOO_MANY; - return False; - } - if (i > 1) { - sprintf (buff, "Warning -- %d retries needed for Cmnd = \"%s\".", - (i - 1), cmnd); - MakePrintable (buff, sizeof(buff), buff); - EL755_ErrorLog (EL755_routine[EL755_call_depth-1], buff); - for (j = 0; j < i; j++) fprintf (stderr, " %d: \"%s\"\n", j, replies[j]); - } - - if (EL755_errcode != 0) return False; - EL755_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL755_SendTillSameVal: Repeat a command until we get the same -** response value on 2 successive occasions. -** -** This routine is intended for internal use only! -** If too many retries, EL755_errcode is set to EL755__TOO_MANY. -*/ - int EL755_SendTillSameVal ( -/* ===================== -*/ void **handle, - char *cmnd, - float *val) { - - int iret, i, n_ovfl, cnt; - struct EL755info *info_ptr; - float last_val; - char *rply_ptr, *tok; - char buff[132]; - /*---------------------------------------------- - */ - info_ptr = (struct EL755info *) *handle; - - if (!EL755_AddCallStack (info_ptr, "EL755_SendTillSameVal")) return False; - /*---------------------------------------------- - ** Send command. Do it in a - ** loop until we get the same response twice to guard - ** against RS-232-C problems with the EL755. - */ - i = n_ovfl = 0; - *val = 9999.999; - last_val = *val - 1.0; - - while (i < 6) { - iret = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd, NULL); - if (!iret) { - EL755_errcode = EL755__BAD_ASYNSRV; return False;} - - rply_ptr = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr == NULL) { - EL755_AddCallStack (info_ptr, "NULL response"); - EL755_errcode = EL755__BAD_ILLG; return False;} - - if (strcmp (rply_ptr, "?OV") == 0) { /* Check for overflow. This seems - ** to be an EL755 problem which - ** needs fixing. In the meantime, - ** just force a repeat. - */ - sprintf (buff, "Warning -- \"?OV\" received in response to \"%s\".", - cmnd); - MakePrintable (buff, sizeof(buff), buff); - EL755_ErrorLog (EL755_routine[EL755_call_depth-1], buff); - n_ovfl++; - if (n_ovfl > 10) {EL755_errcode = EL755__TOO_MANY; return False;} - }else { - n_ovfl = 0; - if (strcmp (rply_ptr, "?OF") == 0) { - EL755_errcode = EL755__OFFLINE; return False;} - if (strcmp (rply_ptr, "?OFL") == 0) { - EL755_errcode = EL755__BAD_OFL; return False;} - if (strcmp (rply_ptr, "?syntax failure") == 0) { - EL755_errcode = EL755__BAD_CMD; return False;} - if (strcmp (rply_ptr, "?power-supply OFF") == 0) { /* If off, return 0 */ - *val = 0.0; - EL755_call_depth--; return True; - }else { - tok = strtok (rply_ptr, " "); - if ((tok == NULL) || - (sscanf (tok, "%f%n", val, &cnt) != 1) || - (cnt != strlen (tok))) { - EL755_AddCallStack (info_ptr, rply_ptr); - EL755_errcode = EL755__BAD_ILLG; return False; - } - if (*val == last_val) break; - last_val = *val; - } - i++; - } - } - if (last_val != *val) { - EL755_errcode = EL755__TOO_MANY; return False;} - - if (i > 1) { - sprintf (buff, "Warning -- %d retries needed for Cmnd = \"%s\".", - (i - 1), cmnd); - MakePrintable (buff, sizeof(buff), buff); - EL755_ErrorLog (EL755_routine[EL755_call_depth-1], buff); - } - - if (EL755_errcode != 0) return False; - EL755_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL755_SendTillTwoVals: Repeat a command until we get 2 fl.pt. -** values and the first is the same on 2 -** successive occasions. -** -** This routine is intended for internal use only! It is -** intended to read the Soll- and Ist-currents where the -** Soll-value should be the same but the Ist-value could be -** changing as the power supply ramps to a new value. -** If too many retries, EL755_errcode is set to EL755__TOO_MANY. -*/ - int EL755_SendTillTwoVals ( -/* ===================== -*/ void **handle, - char *cmnd, - float *val0, - float *val1) { - - int iret, i, n_ovfl, cnt0, cnt1; - struct EL755info *info_ptr; - float last_val; - char *rply_ptr, *tok0, *tok1; - char buff[132]; - /*---------------------------------------------- - */ - info_ptr = (struct EL755info *) *handle; - - if (!EL755_AddCallStack (info_ptr, "EL755_SendTillTwoVals")) return False; - /*---------------------------------------------- - ** Send command. Do it in a - ** loop until we get the same response twice to guard - ** against RS-232-C problems with the EL755. - */ - i = n_ovfl = 0; - *val0 = 9999.999; - last_val = *val0 - 1.0; - - while (i < 6) { - iret = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd, NULL); - if (!iret) { - EL755_errcode = EL755__BAD_ASYNSRV; return False;} - - rply_ptr = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr == NULL) { - EL755_AddCallStack (info_ptr, "NULL response"); - EL755_errcode = EL755__BAD_ILLG; return False;} - - if (strcmp (rply_ptr, "?OV") == 0) { /* Check for overflow. This seems - ** to be an EL755 problem which - ** needs fixing. In the meantime, - ** just force a repeat. - */ - sprintf (buff, "Warning -- \"?OV\" received in response to \"%s\".", - cmnd); - MakePrintable (buff, sizeof(buff), buff); - EL755_ErrorLog (EL755_routine[EL755_call_depth-1], buff); - n_ovfl++; - if (n_ovfl > 10) {EL755_errcode = EL755__TOO_MANY; return False;} - }else { - n_ovfl = 0; - if (strcmp (rply_ptr, "?OF") == 0) { - EL755_errcode = EL755__OFFLINE; return False;} - if (strcmp (rply_ptr, "?OFL") == 0) { - EL755_errcode = EL755__BAD_OFL; return False;} - if (strcmp (rply_ptr, "?syntax failure") == 0) { - EL755_errcode = EL755__BAD_CMD; return False;} - if (strcmp (rply_ptr, "?power-supply OFF") == 0) { /* If off, return 0 */ - *val0 = 0.0; - *val1 = 0.0; - EL755_call_depth--; return True; - }else { - tok0 = strtok (rply_ptr, " "); - tok1 = strtok (NULL, " "); - if ((tok0 == NULL) || - (tok1 == NULL) || - (sscanf (tok0, "%f%n", val0, &cnt0) != 1) || - (sscanf (tok1, "%f%n", val1, &cnt1) != 1) || - (cnt0 != strlen (tok0)) || - (cnt1 != strlen (tok1))) { - EL755_AddCallStack (info_ptr, rply_ptr); - EL755_errcode = EL755__BAD_ILLG; return False; - } - if (*val0 == last_val) break; - last_val = *val0; - } - i++; - } - } - if (last_val != *val0) { - EL755_errcode = EL755__TOO_MANY; return False;} - - if (i > 1) { - sprintf (buff, "Warning -- %d retries needed for Cmnd = \"%s\".", - (i - 1), cmnd); - MakePrintable (buff, sizeof(buff), buff); - EL755_ErrorLog (EL755_routine[EL755_call_depth-1], buff); - } - - if (EL755_errcode != 0) return False; - EL755_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL755_SetCurrent: Sets current via EL755. -*/ - int EL755_SetCurrent ( -/* ================ -*/ void **handle, - float soll) { - - int i, iret; - float my_soll, my_ist; - char cmnd[32], cmnd0[32], buff[132], buff1[132]; - struct EL755info *info_ptr; - /*---------------------------------------------- - */ - info_ptr = (struct EL755info *) *handle; - - if (!EL755_AddCallStack (info_ptr, "EL755_SetCurrent")) return False; - /*---------------------------------------------- - ** Send I command to set EL755 current and I command - ** to read back the set value. - ** Repeat until set value is correct. - */ - sprintf (cmnd, "I %d %.4f\r", info_ptr->index, soll); - sprintf (cmnd0, "I %d\r", info_ptr->index); - i = 0; - my_soll = soll + 1.0; - - while ((i < 6) && (fabs (soll - my_soll) > 0.01)) { - iret = EL755_SendTillSameStr (handle, cmnd, buff, sizeof(buff)); - if (!iret) return False; - if (buff[0] == NIL) { /* We should get a null response */ - iret = EL755_SendTillSameVal (handle, cmnd0, &my_soll); - if (!iret) return False; - }else if (strcmp (buff, "?value out of range") == 0) { - EL755_errcode = EL755__OUT_OF_RANGE; return False; - }else if (strcmp (buff, "?current limitation") == 0) { - EL755_errcode = EL755__TOO_LARGE; return False; - }else if (strcmp (buff, "?power-supply OFF") == 0) { - if (soll == 0.0) { /* Suppress error if trying to set zero and - .. power supply is off! */ - if (EL755_errcode != 0) return False; - EL755_call_depth--; - return True; - }else { - EL755_errcode = EL755__TURNED_OFF; return False; - } - }else { - sprintf (buff1, "Cmnd=\"%s\" Rply=\"%.10s\"", cmnd, buff); - MakePrintable (buff1, sizeof(buff1), buff1); - EL755_AddCallStack (info_ptr, buff1); - EL755_errcode = EL755__BAD_ILLG; - return False; - } - i++; - } - - if (fabs (soll - my_soll) > 0.01) { - EL755_errcode = EL755__TOO_MANY; return False;} - - if (i > 1) { - sprintf (buff, "Warning -- %d retries needed for Cmnd = \"%s\".", - (i - 1), cmnd); - MakePrintable (buff, sizeof(buff), buff); - EL755_ErrorLog (EL755_routine[EL755_call_depth-1], buff); - } - if (EL755_errcode != 0) return False; - EL755_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** EL755_Send sends a command to the EL755 and gets a reply -** -** This routine is intended for internal use only! -*/ - int EL755_Send ( -/* ===================== -*/ void **handle, - char *cmnd, - char *rply, - int rply_len) { - - int iret, i, j, n_ovfl; - struct EL755info *info_ptr; - char *rply_ptr; - char buff[132]; - char replies[6][64]; - /*---------------------------------------------- - */ - info_ptr = (struct EL755info *) *handle; - - if (!EL755_AddCallStack (info_ptr, "EL755_SendTillSameStr")) return False; - /*---------------------------------------------- - ** Send command. - */ - i = n_ovfl = 0; - StrJoin (rply, rply_len, "#", ""); - - - iret = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd, NULL); - if (!iret) { - EL755_errcode = EL755__BAD_ASYNSRV; return False;} - rply_ptr = AsynSrv_GetReply ( - &info_ptr->asyn_info, &info_ptr->from_host, NULL); - if (rply_ptr == NULL) { - EL755_AddCallStack (info_ptr, "NULL response"); - EL755_errcode = EL755__BAD_ILLG; return False;} - if (strncmp (rply_ptr, "?TMO", 4) == 0) { - EL755_errcode = EL755__BAD_TMO; return False;} - if (strcmp (rply_ptr, "?OF") == 0) { - EL755_errcode = EL755__OFFLINE; return False;} - if (strcmp (rply_ptr, "?OFL") == 0) { - EL755_errcode = EL755__BAD_OFL; return False;} - if (strcmp (rply_ptr, "?syntax failure") == 0) { - EL755_errcode = EL755__BAD_CMD; return False;} - if (strcmp (rply_ptr, "?OV") == 0) { /* Check for overflow. This seems - ** to be an EL755 problem which - ** needs fixing. In the meantime, - ** just force a repeat. - */ - sprintf (buff, "Warning -- \"?OV\" received in response to \"%s\".", - cmnd); - MakePrintable (buff, sizeof(buff), buff); - EL755_ErrorLog (EL755_routine[EL755_call_depth-1], buff); - n_ovfl++; - if (n_ovfl > 10) {EL755_errcode = EL755__TOO_MANY; return False;} - }else { - n_ovfl = 0; - if (strncmp (rply, rply_ptr, rply_len) == 0) - { - return False; - } - StrJoin (rply, rply_len, rply_ptr, ""); - MakePrintable (replies[i], sizeof (replies[0]), rply_ptr); - i++; - } - if (EL755_errcode != 0) return False; - EL755_call_depth--; - return True; - } -/*-------------------------------------------- End of EL755_Utility.C =======*/ diff --git a/hardsup/err.c b/hardsup/err.c deleted file mode 100644 index 9ef0fad9..00000000 --- a/hardsup/err.c +++ /dev/null @@ -1,105 +0,0 @@ - -/*--------------------------------------------------------------------------- - - EL734Error2Text converts between an EL734 error code to text ------------------------------------------------------------------------------*/ - void EL734Error2Text(char *pBuffer, int iErr) - { - switch(iErr) - { - case -28: - strcpy(pBuffer,"EL734__BAD_ADR"); - break; - case -8: - strcpy(pBuffer,"EL734__BAD_BIND"); - break; - case -30: - strcpy(pBuffer,"EL734__BAD_BSY"); - break; - case -3: - strcpy(pBuffer,"EL734__BAD_CMD"); - break; - case -9: - strcpy(pBuffer,"EL734__BAD_CONNECT"); - break; - case -23: - strcpy(pBuffer,"EL734__BAD_FLUSH"); - break; - case -6: - strcpy(pBuffer,"EL734__BAD_HOST"); - break; - case -10: - strcpy(pBuffer,"EL734__BAD_ID"); - break; - case -5: - strcpy(pBuffer,"EL734__BAD_ILLG"); - break; - case -2: - strcpy(pBuffer,"EL734__BAD_LOC"); - break; - case -11: - strcpy(pBuffer,"EL734__BAD_MALLOC"); - break; - case -21: - strcpy(pBuffer,"EL734__BAD_NOT_BCD"); - break; - case -4: - strcpy(pBuffer,"EL734__BAD_OFL"); - break; - case -29: - strcpy(pBuffer,"EL734__BAD_PAR"); - break; - - case -17: - strcpy(pBuffer,"EL734__BAD_RECV"); - break; - case -19: - strcpy(pBuffer,"EL734__BAD_RECV_NET"); - break; - case -18: - strcpy(pBuffer,"EL734__BAD_RECV_PIPE"); - break; - case -20: - strcpy(pBuffer,"EL734__BAD_RECV_UNKN"); - break; - case -22: - strcpy(pBuffer,"EL734__BAD_RECVLEN"); - break; - case -24: - strcpy(pBuffer,"EL734__BAD_RECV1"); - break; - case -26: - strcpy(pBuffer,"EL734__BAD_RECV1_NET"); - break; - case -25: - strcpy(pBuffer,"EL734__BAD_RECV1_PIPE"); - break; - case -27: - strcpy(pBuffer,"EL734__BAD_RNG"); - break; - case -13: - strcpy(pBuffer,"EL734__BAD_SEND"); - break; - case -14: - strcpy(pBuffer,"EL734__BAD_SEND_PIPE"); - break; - case -15: - strcpy(pBuffer,"EL734__BAD_SEND_NET"); - break; - case -16: - strcpy(pBuffer,"EL734__BAD_SEND_UNKN"); - break; - case -12: - strcpy(pBuffer,"EL734__BAD_SENDLEN"); - break; - case -7: - strcpy(pBuffer,"EL734__BAD_SOCKET"); - break; - case -1: - strcpy(pBuffer,"EL734__BAD_TMO"); - break; - default: - strcpy(pBuffer,"Unknown EL734 error"); - break; - } - } diff --git a/hardsup/failinet.c b/hardsup/failinet.c deleted file mode 100644 index 38c39e8f..00000000 --- a/hardsup/failinet.c +++ /dev/null @@ -1,109 +0,0 @@ -#define ident "1B01" -#ifdef VAXC -#module FailInet ident -#endif -#ifdef __DECC -#pragma module FailInet ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Computing Section | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]FAILINET.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Nov 1995 -** -** To compile this module, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]FailInet - - tasmad_disk:[mad.lib.sinq]FailInet + - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb FailInet debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb FailInet -** -** Updates: -** 1A01 2-Nov-1995 DM. Initial version. -** 1B01 21-Mar-1996 DM. Move from DELTAT.OLB to SINQ.OLB. -**============================================================================ -** The following entry points are included: -** - #include - - void FailInet (char *text) -** -------- -** Input Args: -** text - A text string to be printed. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** none -** Global variables modified: -** none -** Routines called: -** GetErrno -** perror -** exit -** Description: -** The routine is useful if a fatal TCP/IP error occurs. -** The value of errno is printed and then "perror" is called. -** Then "exit" is called. -**============================================================================ -** Global Definitions -*/ -#ifdef VAXC -#include stdlib -#include stdio -#include errno -#include sinq_prototypes -#else -#include -#include -#include -#include -#endif -/*-------------------------------------------------------------------------- -** Global Variables -*/ - -/* -** FailInet: Some network failure has occurred. -*/ - void FailInet (char *text) { -/* ======== -** Output the given text and exit the process. -*/ - int my_errno, my_vaxc_errno; - - GetErrno (&my_errno, &my_vaxc_errno); - printf ("### Internet Error ###\n"); -#ifdef __VMS - printf (" ### errno = %d.\n", my_errno); - printf (" ### vaxc$errno = %d.\n", my_vaxc_errno); -#else - printf (" ### errno = %d.\n", my_errno); -#endif - perror (text); - exit (EXIT_FAILURE); - } -/*------------------------------------------------- End of FAILINET.C =======*/ diff --git a/hardsup/geterrno.c b/hardsup/geterrno.c deleted file mode 100644 index c3edcf18..00000000 --- a/hardsup/geterrno.c +++ /dev/null @@ -1,96 +0,0 @@ -#define ident "1B01" -#ifdef VAXC -#module GetErrno ident -#endif -#ifdef __DECC -#pragma module GetErrno ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Computing Section | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]GETERRNO.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Nov 1995 -** -** To compile this module, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]GetErrno - - tasmad_disk:[mad.lib.sinq]GetErrno + - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb GetErrno debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb GetErrno -** -** Updates: -** 1A01 2-Nov-1995 DM. Initial version. -** 1B01 21-Mar-1996 DM. Move from DELTAT.OLB to SINQ.OLB. -**============================================================================ -** The following entry points are included: -** - #include - - void GetErrno (int *his_errno, int *his_vaxc_errno) -** -------- -** Input Args: -** none -** Output Args: -** his_errno - value of "errno". -** his_vaxc_errno - on VMS systems only, value of "vaxc$errno". Otherwise -** set to 1. -** Modified Args: -** none -** Return status: -** none -** Global variables modified: -** none -** Description: -** GetErrno returns a copy of the universal error variable "errno" (and, -** on VMS systems, vaxc$errno) to a local variable supplied by the user. -** This can occasionally be useful when debugging since the debugger on -** VMS can't easily examine them. -**============================================================================ -** Global Definitions -*/ -#ifdef VAXC -#include errno -#else -#include -#endif -/*-------------------------------------------------------------------------- -** Global Variables -*/ - -/*-------------------------------------------------------------------------- -** GetErrno: Make copies of errno and vaxc$errno for debug. -*/ - void GetErrno (int *his_errno, int *his_vaxc_errno) { -/* ======== -*/ - *his_errno = errno; /* Make copy of errno */ -#ifdef __VMS - *his_vaxc_errno = vaxc$errno; /* Make copy of vaxc$errno */ -#else - *his_vaxc_errno = 1; -#endif - return; - } -/*------------------------------------------------- End of GETERRNO.C =======*/ diff --git a/hardsup/itc4util.c b/hardsup/itc4util.c deleted file mode 100644 index 1dce9f76..00000000 --- a/hardsup/itc4util.c +++ /dev/null @@ -1,421 +0,0 @@ -/*-------------------------------------------------------------------------- - - I T C 4 U T I L - - A few utility functions for dealing with a ITC4 temperature controller - within the SINQ setup: host -- TCP/IP -- MAC --- RS-232. - - Mark Koennecke, Juli 1997 - - Copyright: - - Labor fuer Neutronenstreuung - Paul Scherrer Institut - CH-5423 Villigen-PSI - - - The authors hereby grant permission to use, copy, modify, distribute, - and license this software and its documentation for any purpose, provided - that existing copyright notices are retained in all copies and that this - notice is included verbatim in any distributions. No written agreement, - license, or royalty fee is required for any of the authorized uses. - Modifications to this software may be copyrighted by their authors - and need not follow the licensing terms described here, provided that - the new terms are clearly indicated on the first page of each file where - they apply. - - IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY - FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY - DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - - THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE - IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE - NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR - MODIFICATIONS. ----------------------------------------------------------------------------- */ -#include -#include -#include -#include -#include "serialsinq.h" -#include "itc4util.h" -/* -------------------------------------------------------------------------*/ - - int ITC4_Open(pITC4 *pData, char *pHost, int iPort, int iChannel, int iMode) - { - int iRet; - char pCommand[80]; - char pReply[132]; - pITC4 self = NULL; - - self = (pITC4)malloc(sizeof(ITC4)); - if(self == NULL) - { - return ITC4__BADMALLOC; - } - *pData = self; - self->iControl = 1; - self->iRead = 1; - self->iReadOnly = iMode; - self->fDiv = 10.; - self->fMult = 10.; - - iRet = SerialOpen(&self->pData, pHost, iPort, iChannel); - if(iRet != 1) - { - return iRet; - } - - /* set an lengthy timeout for the configuration in order to - prevent problems. - */ - iRet = SerialConfig(&self->pData, 100); - if(iRet != 1) - { - return iRet; - } - - /* an identification test has been here, but I had to removed as not all - ITC4 controllers at SINQ answer the V command. Some versions of the - controller do not recognize it. Sighhhhhhh. I had to put it in again - in order to check for ITC-503, but I handle the thing by default as - an ITC4 if I do not get a proper response. - */ - self->i503 = 0; - iRet = SerialWriteRead(&self->pData,"V\r\n",pReply,131); - if(iRet != 1) - { - return iRet; - } - if(strstr(pReply,"ITC503") != NULL) - { - self->i503 = 1; - } - - if(!self->iReadOnly) - { - /* switch to remote and locked operation */ - iRet = SerialWriteRead(&self->pData,"C3\r\n",pReply,131); - if(iRet != 1) - { - return iRet; - } - if(pReply[0] == '?') - { - strcpy(self->pAns,pReply); - return ITC4__BADCOM; - } - - /* set the control sensor, for this we need to switch A0 first, - the do it and switch back - */ - iRet = SerialWriteRead(&self->pData,"A0\r\n",pReply,131); - if(iRet != 1) - { - return iRet; - } - if(pReply[0] == '?') - { - strcpy(self->pAns,pReply); - return ITC4__BADCOM; - } - - sprintf(pCommand,"H%1.1d\r\n",self->iControl); - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - if(pReply[0] == '?') - { - strcpy(self->pAns,pReply); - return ITC4__BADCOM; - } - - /* controls to automatic */ - iRet = SerialWriteRead(&self->pData,"A3\r\n",pReply,131); - if(iRet != 1) - { - return iRet; - } - if(pReply[0] == '?') - { - strcpy(self->pAns,pReply); - return ITC4__BADCOM; - } - /* reset timeout */ - iRet = SerialConfig(&self->pData, 10); - if(iRet != 1) - { - return iRet; - } - } - return 1; - } -/*--------------------------------------------------------------------------*/ - void ITC4_Close(pITC4 *pData) - { - char pReply[132]; - int iRet; - pITC4 self; - - self = *pData; - - /* switch to local operation */ - iRet = SerialWriteRead(&self->pData,"C0\r\n",pReply,131); - /* ignore errors on this one, the thing may be down */ - - /* close connection */ - SerialClose(&self->pData); - - /* free memory */ - free(self); - *pData = NULL; - } -/*--------------------------------------------------------------------------*/ - int ITC4_Config(pITC4 *pData, int iTmo, int iRead, int iControl, - float fDiv,float fMult) - { - int iRet; - char pReply[132]; - char pCommand[10]; - pITC4 self; - - self = *pData; - - /* first timeout */ - if(iTmo > 0) - { - iRet = SerialConfig(&self->pData, iTmo); - if(iRet != 1) - { - return iRet; - } - } - - /* Read Sensor */ - if( (iRead > 0) && (iRead < 5) && (self->iRead != iRead) ) - { - self->iRead = iRead; - } - - /* Control Sensor */ - if( (iControl > 0) && (iControl < 5) ) - { - /* set the control sensor, for this we need to switch A0 first, - the do it and switch back - */ - iRet = SerialWriteRead(&self->pData,"A0\r\n",pReply,131); - if(iRet != 1) - { - return iRet; - } - if(pReply[0] == '?') - { - strcpy(self->pAns,pReply); - return ITC4__BADCOM; - } - - /* set sensor */ - sprintf(pCommand,"H%1.1d\r\n",iControl); - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - if(pReply[0] == '?') - { - strcpy(self->pAns,pReply); - return ITC4__BADCOM; - } - - /* controls to automatic */ - iRet = SerialWriteRead(&self->pData,"A3\r\n",pReply,131); - if(iRet != 1) - { - return iRet; - } - if(pReply[0] == '?') - { - strcpy(self->pAns,pReply); - return ITC4__BADCOM; - } - } - self->fDiv = fDiv; - self->fMult = fMult; - - return 1; - } -/* --------------------------------------------------------------------------*/ - int ITC4_Send(pITC4 *pData, char *pCommand, char *pReply, int iLen) - { - pITC4 self; - - self = *pData; - - /* make sure, that there is a \r at the end of the command */ - if(strchr(pCommand,(int)'\r') == NULL) - { - strcat(pCommand,"\r"); - } - return SerialWriteRead(&self->pData,pCommand,pReply,iLen); - } -/*--------------------------------------------------------------------------*/ - int ITC4_Read(pITC4 *pData, float *fVal) - { - char pCommand[10], pReply[132]; - int iRet; - float fRead = -9999999.; - pITC4 self; - - self = *pData; - - - /* format and send R command */ - sprintf(pCommand,"R%1.1d\r\n",self->iRead); - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - if(pReply[0] == '?') - { - strcpy(self->pAns,pReply); - return ITC4__BADCOM; - } - - /* analyse reply */ - if(pReply[0] != 'R') - { - strcpy(self->pAns,pReply); - return ITC4__BADCOM; - } - - iRet = sscanf(&pReply[1],"%f",&fRead); - if(iRet != 1) - { - return ITC4__BADREAD; - } - if(self->i503) - { - *fVal = fRead; - } - else - { - *fVal = fRead/self->fDiv; - } - return 1; - } -/* -------------------------------------------------------------------------*/ - int ITC4_Set(pITC4 *pData, float fVal) - { - char pCommand[10], pReply[132]; - int iRet, i, iRead; - const float fPrecision = 0.0001; - float fSet, fDelta, fRead, fDum; - pITC4 self; - int iSet; - - self = *pData; - - if(self->iReadOnly) - { - return ITC4__READONLY; - } - - /* format command */ - if(self->i503) - { - sprintf(pCommand,"T%-7.3f\r\n",fVal); - } - else - { - fSet = fVal; - iSet = (int)(fSet*self->fMult); - sprintf(pCommand,"T%05.5d\r\n",iSet); - } - - /* try three times: send, read, test, if OK return, else - resend. This must be done because the ITC4 tends to loose - characters - */ - for(i = 0; i < 3; i++) - { - /* send command */ - iRet = SerialWriteRead(&self->pData,pCommand,pReply,131); - if(iRet != 1) - { - return iRet; - } - if(pReply[0] == '?') - { - strcpy(self->pAns,pReply); - return ITC4__BADCOM; - } - /* read the set value again */ - iRead = self->iRead; - self->iRead = 0; /* make a R0 */ - fDum = self->fDiv; - self->fDiv = self->fMult; - iRet = ITC4_Read(pData,&fRead); - self->iRead = iRead; - self->fDiv = fDum; - if(iRet != 1) - { - return iRet; - } - /* check the value read back */ - if(self->i503) - { - fDelta = fRead - fVal; - } - else - { - fDelta = fRead - fSet; - } - if(fDelta < 0) - fDelta = -fDelta; - if(fDelta < fPrecision) - { - /* Success, go home */ - return 1; - } - } - return ITC4__BADSET; - } -/* -------------------------------------------------------------------------*/ - void ITC4_ErrorTxt(pITC4 *pData,int iCode, char *pError, int iLen) - { - char pBueffel[512]; - pITC4 self; - - self = *pData; - - switch(iCode) - { - case ITC4__BADCOM: - sprintf(pBueffel,"ITC4: Invalid command or offline, got %s", - self->pAns); - strncpy(pError,pBueffel,iLen); - break; - case ITC4__BADPAR: - strncpy(pError,"ITC4: Invalid parameter specified",iLen); - break; - case ITC4__BADMALLOC: - strncpy(pError,"ITC4: Error allocating memory in ITC4",iLen); - break; - case ITC4__BADREAD: - strncpy(pError,"ITC4: Badly formatted answer",iLen); - break; - case ITC4__BADSET: - strncpy(pError,"ITC4: Failed three times to write new set value to ITC4",iLen); - break; - default: - SerialError(iCode, pError,iLen); - break; - } - } diff --git a/hardsup/itc4util.h b/hardsup/itc4util.h deleted file mode 100644 index f700c8af..00000000 --- a/hardsup/itc4util.h +++ /dev/null @@ -1,124 +0,0 @@ -/*--------------------------------------------------------------------------- - I T C L 4 U T I L - - A few utility functions for talking to a Oxford Instruments ITCL-4 - temperature controller via the SINQ setup: TCP/IP--MAC--RS-232-- - ITC-4. - - Mark Koennecke, Juli 1997 - -----------------------------------------------------------------------------*/ -#ifndef SINQITCL4 -#define SINQITCL4 - -/*----------------------- ERRORCODES-------------------------------------- - Most functions return a negative error code on failure. Error codes - defined are those defined for serialsinq plus a few additional ones: -*/ - -#define ITC4__BADCOM -501 -/* command not recognized */ -#define ITC4__BADPAR -502 -/* bad parameter to command */ -#define ITC4__BADMALLOC -503 -/* error allocating memory */ -#define ITC4__BADREAD -504 -/* error analysing command string on Read */ -#define ITC4__NOITC -510 -/* Controller is no ITC-4 */ -#define ITC4__BADSET -530 -/* failed three times to set temperature */ -#define ITC4__READONLY -531 -/*------------------------------------------------------------------------*/ - typedef struct __ITC4 { - int iRead; - int iControl; - void *pData; - char pAns[80]; - float fDiv; - float fMult; - int iReadOnly; - int i503; /* flag for model 503, understanding float*/ - } ITC4; - - typedef struct __ITC4 *pITC4; - -/*-----------------------------------------------------------------------*/ - int ITC4_Open(pITC4 *pData,char *pHost, int iPort, int iChannel, int iMode); - /***** creates an ITC4 datastructure and opens a connection to the ITCL4 - controller. Input Parameters are: - the hostname - the port number - the RS-232 channel number on the Mac. - iMode: 1 for ReadOnly, 0 for normal mode - - Return values are 1 for success, a negative error code on - failure. - - */ - - void ITC4_Close(pITC4 *pData); - /****** close a connection to an ITC4controller and frees its - data structure. The only parameter is a pointer to the data - structure for this controller. This pointer will be invalid after - this call. - */ - - int ITC4_Config(pITC4 *pData, int iTmo, int iRead, - int iControl, float fDiv, float fMult); - /***** configure some aspects of a ITC4temperature controller. - The parameter are: - - a pointer to the data structure for the controller as - returned by OpenITCL4 - - a value for the connection timeout - - the temperature sensor to use for reading the - temperature. - - the temperature sensor used by the ITC4controller - for regulating the temperature. - - the divisor needed to calculate the real temperature - from the sensor. - The function returns 1 on success, a negative error code on - failure. - */ - - int ITC4_Send(pITC4 *pData, char *pCommand, char *pReply, int iLen); - /******* send a the command in pCommand to the ITC4controller. - A possible reply is returned in the buffer pReply. - Maximum iLen characters are copied to pReply. - The first parameter is a pointer to a ITC4data structure - as returned by OpenITCL4. - - Return values are 1 for success, a negative error code on - failure. - */ - - int ITC4_Read(pITC4 *pData, float *fVal); - /******* reads the current actual temperature of the sensor - configured by ConfigITC4for reading. The value is returned - in fVal. The first parameter is a pointer to a ITCL4 - data structure as returned by OpenITCL4. - - Return values are 1 for success, a negative error code on - failure. - */ - - int ITC4_Set(pITC4 *pData, float fVal); - /****** sets a new preset temperature in the ITC4temperature - controller. Parameters are: - - a pointer to a ITC4data structure as returned by OpenITCL4. - - the new preset value. - - Return values are 1 for success, a negative error code on - failure. - */ - - void ITC4_ErrorTxt(pITC4 *pData, int iCode, char *pError, int iLen); - /******* translates one of the negative error ITC4error codes - into text. Maximum iLen bytes will be copied to the - buffer pError; - */ - - -#endif - - diff --git a/hardsup/make_gen b/hardsup/make_gen deleted file mode 100644 index 32e8a1f5..00000000 --- a/hardsup/make_gen +++ /dev/null @@ -1,28 +0,0 @@ -#--------------------------------------------------------------------------- -# Makefile for the SINQ hardware support library -# included by a machine specific makefile -# -# Mark Koennecke, November 1996 -# Markus Zolliker, March 2003 -#-------------------------------------------------------------------------- -.SUFFIXES: -.SUFFIXES: .c .o - -OBJ= el734_utility.o asynsrv_utility.o stredit.o \ - strjoin.o failinet.o geterrno.o el737_utility.o sinqhm.o serialsinq.o \ - itc4util.o dillutil.o table.o el755_utility.o el755_errorlog.o \ - makeprint.o StrMatch.o - -libhlib.a: $(OBJ) - rm -f libhlib.a - ar cr libhlib.a $(OBJ) - ranlib libhlib.a - -clean: - rm -f *.o *.a - - - - - - diff --git a/hardsup/makefile_linux b/hardsup/makefile_linux deleted file mode 100644 index 08a262d3..00000000 --- a/hardsup/makefile_linux +++ /dev/null @@ -1,15 +0,0 @@ -#--------------------------------------------------------------------------- -# Makefile for the SINQ hardware support library -# machine-dependent part for Redhat Linux with AFS at PSI -# -# Mark Koennecke, November 1996 -# Markus Zolliker, March 2003 -#-------------------------------------------------------------------------- -# the following line only for fortified version -DFORTIFY=-DFORTIFY -#========================================================================== - -CC = gcc -CFLAGS = -g -DLINUX $(DFORTIFY) -I$(SRC). -I$(SRC).. -I../src - -include $(SRC)make_gen diff --git a/hardsup/makeprint.c b/hardsup/makeprint.c deleted file mode 100644 index b35188e2..00000000 --- a/hardsup/makeprint.c +++ /dev/null @@ -1,276 +0,0 @@ -#define ident "1B02" -#ifdef VAXC -#module MakePrint ident -#endif -#ifdef __DECC -#pragma module MakePrint ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Department ASQ | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]MAKEPRINT.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Nov 1995 -** -** To compile this module, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]MakePrint - - tasmad_disk:[mad.lib.sinq]MakePrint + - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb MakePrint debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb MakePrint -** -** Updates: -** 1A01 30-Nov-1995 DM. Initial version. -** 1B01 21-Mar-1996 DM. Move from DELTAT.OLB to SINQ.OLB. -**============================================================================ -** The entry points included in this module are described below. Prototypes -** can be defined via: -** -** #include -** -** MakeCharPrintable - routine used by MakePrintable and MakeMemPrintable. -** MakeMemPrintable - version of MakePrintable which will handle -** buffers containing a NUL character. -** MakePrint - ensure all characters in a buffer are printable. -** MakePrintable - extended version of MakePrint. -**--------------------------------------------------------------------- -** char *MakePrint (*text) -** --------- -** Input Args: -** none -** Output Args: -** none -** Modified Args: -** char *text -** Return status: -** A pointer to "text". -** Routines called: -** none -** Description: -** The routine ensures that all characters in "text" are 7-bit -** and then replaces any non-printing character with a ".". A trailing -** "\n" or "\r" is removed. -**--------------------------------------------------------------------------- -** int *MakeCharPrintable (*out, out_size, in) -** ----------------- -** Input Args: -** char in -- the character to be converted. -** int out_size -- the size of the out buffer. -** Output Args: -** char *out -- buffer to hold the converted text. -** Modified Args: -** none -** Return status: -** The number of characters put into the output buffer. -** Routines called: -** none -** Description: -** The routine puts a printable version of the character "in" into the -** "out" buffer. The printable version is generated as follows: -** -** a) If the parity bit of a char is set, a "^" is inserted into the -** output buffer, the parity bit of the char is cleared and processed -** further. -** b) If the char is "^", "\^" is inserted into the output buffer. -** c) If the char is "\", "\\" is inserted into the output buffer. -** d) If the char is a standard C-language control char, it gets replaced -** by a recognised backslash escape sequence. The following are -** recognised: -** NUL 0x00 --> \0 -** BEL 0x07 --> \a -** BS 0x08 --> \b -** HT 0x09 --> \t -** LF 0x0a --> \n -** VT 0x0b --> \v -** FF 0x0c --> \f -** CR 0x0d --> \r -** e) If the character is printable (i.e. between " "/0x20 and "~"/0x7e -** inclusive), it is inserted into the output buffer as is. -** f) Anything else gets inserted as "\xxx", where xxx is the octal -** representation of the character. -**--------------------------------------------------------------------------- -** char *MakePrintable (*out, out_size, *in) -** ------------- -** Input Args: -** char *in -- the text to be converted. -** int out_size -- the size of the out buffer. -** Output Args: -** char *out -- buffer to hold the converted text. -** Modified Args: -** none -** Return status: -** A pointer to "out". -** Routines called: -** none -** Description: -** The routine converts characters in the "in" string to a printable -** representation using MakeCharPrintable and copies them to "out" until -** a null is detected. -**--------------------------------------------------------------------------- -** char *MakeMemPrintable (*out, out_size, *in, in_len) -** ---------------- -** Input Args: -** int out_size -- the size of the out buffer. -** char *in -- the text to be converted. -** int in_len -- the number of characters to be converted. -** Output Args: -** char *out -- buffer to hold the converted text. -** Modified Args: -** none -** Return status: -** A pointer to "out". -** Routines called: -** none -** Description: -** The routine is the same as MakePrintable, except that it converts -** a given number of characters rather than a null terminated string. -**============================================================================*/ -/* -**--------------------------------------------------------------------------- -** Global Definitions -*/ -#include -#include -#include -#ifdef FORTIFY - #include -#endif - -#include - -#define NIL ('\0') -/*-------------------------------------------------------------------------- -** Global Variables -*/ -/* -**-------------------------------------------------------------------------- -** MakeCharPrintable: makes a single character printable. -*/ - int MakeCharPrintable (char *out, int out_size, char in) { -/* ================= -** -** Return value is number of chars put into *out. -*/ - char buff[8], *pntr; - - pntr = buff; - - if ((in & 0x80) != 0) { /* Parity bit set? */ - *pntr++ = '^'; /* Yes. Put a '^' in the buffer .. */ - in = in & 0x7f; /* .. and remove the parity bit. */ - } - - switch (in) { - case '^': *pntr++ = '\\'; *pntr++ = '^'; break; - case '\\': *pntr++ = '\\'; *pntr++ = '\\'; break; - case '\000': *pntr++ = '\\'; *pntr++ = '0'; break; - case '\007': *pntr++ = '\\'; *pntr++ = 'a'; break; - case '\010': *pntr++ = '\\'; *pntr++ = 'b'; break; - case '\011': *pntr++ = '\\'; *pntr++ = 't'; break; - case '\012': *pntr++ = '\\'; *pntr++ = 'n'; break; - case '\013': *pntr++ = '\\'; *pntr++ = 'v'; break; - case '\014': *pntr++ = '\\'; *pntr++ = 'f'; break; - case '\015': *pntr++ = '\\'; *pntr++ = 'r'; break; - default: - if ((in < ' ') || (in > '~')) { - pntr += sprintf (pntr, "\\%03.3o", in); - }else { - *pntr++ = in; - } - } - out_size = (out_size > (pntr - buff)) ? (pntr - buff) : out_size; - memcpy (out, buff, out_size); - return out_size; - } -/* -**-------------------------------------------------------------------------- -** MakeMemPrintable: alternative version of MakePrintable. -*/ - char *MakeMemPrintable ( -/* ================ -*/ char *out, - int out_size, - char *in, - int in_len) { - - int i; - char *pntr; - - if (out_size <= 0) return out; - - while ((out_size > 1) && (in_len > 0)) { - i = MakeCharPrintable (out, (out_size - 1), *in); - out += i; out_size -= i; - in++; in_len--; - } - *out = NIL; - return out; - } -/* -**-------------------------------------------------------------------------- -** MakePrint: Make all characters in a buffer printable. -*/ - char *MakePrint (char *chr) { -/* ========= -*/ - int len, i; - - for (i = 0; chr[i] != NIL; i++) chr[i] &= 0x7F; - - len = strlen (chr); - if (len <= 0) return chr; - - if (chr[len-1] == '\r') chr[len-1] = NIL; - if (chr[len-1] == '\n') chr[len-1] = NIL; - - for (i = 0; chr[i] != NIL; i++) { - if (chr[i] < ' ') chr[i] = '.'; - if (chr[i] == 0x7F) chr[i] = '.'; - } - - return chr; - } -/* -**-------------------------------------------------------------------------- -** MakePrintable: improved version of MakePrint. -*/ - char *MakePrintable ( -/* ============= -*/ char *out, - int out_size, - char *in) { - - int i; - char *pntr; - - if (out_size <= 0) return out; - - while ((out_size > 1) && (*in != NIL)) { - i = MakeCharPrintable (out, (out_size - 1), *in); - in++; out += i; out_size -= i; - } - *out = NIL; - return out; - } -/*-------------------------------------------- End of MakePrint.C =======*/ diff --git a/hardsup/rs232c_def.h b/hardsup/rs232c_def.h deleted file mode 100644 index 2753bd1b..00000000 --- a/hardsup/rs232c_def.h +++ /dev/null @@ -1,186 +0,0 @@ -#ifndef _rs232c_def_ -#define _rs232c_def_ -/*------------------------------------------------ RS232C_DEF.H Ident V02G -** Definitions for the RS-232-C Server Protocol -** -** On UNIX systems, this file is located in /public/lib/include -** On VMS systems, this file is a module in mad_lib:sinq_c.tlb -*/ -#define RS__PROTOCOL_ID "V01A" -#define RS__PROTOCOL_ID_V01B "V01B" - -#define RS__PROTOCOL_CODE 1 /* Code corresponding to RS__PROTOCOL_ID */ -#define RS__PROTOCOL_CODE_V01B 2 /* Code corresponding to RS__PROTOCOL_ID_0 */ - -#ifndef OffsetOf -#define OffsetOf(type, identifier) ((size_t)(&((type*) NULL)->identifier)) -#endif -/*---------------------------------------------------------------------------- -** Structure of Message from Client to Server - everything is sent in ASCII -** for LabView's benefit. -** Name #bytes Description -** ==== ====== =========== -** msg_size 4 Number of bytes following (rounded up to multiple -** of 4). -** msg_id 4 Message ident (an incrementing counter for debugging). -** c_pcol_lvl 4 Client-Protocol-Level (should be "V01A"). -** serial_port 4 Serial port to which commands should be sent. This -** is a small integer). -** tmo 4 Time-out in units of 0.1 secs (<0 = "wait for ever"). -** terms 1 + 3 Terminators. The first char gives the number of -** terminators (up to 3) and the following 3 chars -** are valid response terminators, e.g. "1\r\0\0". -** n_cmnds 4 Number of commands following. -** cmnds 356 The command buffer. This is a concatenated list of -** commands with the structure described below. -** -** Special Cases of msg_size -** ------------------------- -** "-001" ==> the client is just about to close his connection. -** "-002" ==> this is a request to the server for him to turn on tracing. -** The reply should be simply an echo of the 4 bytes "-002". -** "-003" ==> this is a request to the server for him to turn off tracing. -** The reply should be simply an echo of the 4 bytes "-003". -** "-004" ==> this is a request to the server for him to flush his buffers. -** The reply should be simply an echo of the 4 bytes "-004". -** -** Structure of a command item in the cmnds buffer. -** -** a) RS__PROTOCOL_ID = "V01A" -** -** Name #bytes Description -** ==== ====== =========== -** cmnd_len 2 The number of bytes following encoded as 2 ASCII -** decimal chars. -** cmnd The command to be sent on Serial Port . -** The string should contain any required terminator -** bytes but should not be zero-terminated (unless -** the zero-byte should be transmitted at the end -** of the command). cmnd_len should count the -** terminator byte. -** -** An example of a command item might be: "06RMT 1\r" -** -** b) RS__PROTOCOL_ID = "V01B" -** -** Name #bytes Description -** ==== ====== =========== -** cmnd_len 4 The number of bytes following encoded as 4 ASCII -** decimal chars. -** cmnd The command to be sent on Serial Port . -** The string should contain any required terminator -** bytes but should not be zero-terminated (unless -** the zero-byte should be transmitted at the end -** of the command). should count the -** terminator byte. -** -** An example of a command item might be: "0006RMT 1\r" -**--------------------------------------------------------------------------*/ - struct RS__MsgStruct { - char msg_size[4]; /* 4 ASCII decimal chars!! */ - char msg_id[4]; - char c_pcol_lvl[4]; /* Client protocol level */ - char serial_port[4]; - char tmo[4]; /* Units are 0.1 secs */ - char terms[4]; - char n_cmnds[4]; - char cmnds[356]; - }; - /* - ** The "cmnds" buffer in RS__MsgStruct is a concatenated - ** list of the following structures. - */ - struct RS__CmndStruct { - char cmnd_len[2]; - char cmnd[1]; - }; - struct RS__CmndStruct_V01B { - char cmnd_len[4]; - char cmnd[1]; - }; -/*---------------------------------------------------------------------------- -** Structure of Reply from Server to Client - everything is sent in ASCII -** for LabView's benefit. -** -** Name #bytes Description -** ==== ====== =========== -** msg_size 4 Number of bytes following (rounded up to multiple -** of 4). -** msg_id 4 Message ident (this is a copy of the msg_id field -** in the message from Client to Server). -** s_pcol_lvl 4 Server-Protocol-Level (should be "V01A" or "V01B"). -** n_rply 4 Number of replies following. If < 0, an error has -** been detected and sub_status may give additional -** information. -** rplys 496 The reply buffer. This is a concatenated list of -** replies with the structure described below. -** sub_status 12 A sub-status code. This field overlays the first 12 -** bytes of rplys and may provide additional -** information in the case that n_rply < 0. -** -** Structure of a reply item in the rplys buffer. -** -** a) RS__PROTOCOL_ID = "V01A" -** -** Name #bytes Description -** ==== ====== =========== -** rply_len 2 The number of bytes following encoded as 2 ASCII -** decimal chars. -** term 1 The terminating character which was detected at the -** end of the reply. This will be one of the -** characters specified in . -** rply The zero-terminated reply. This is effectively the -** reply as received with the terminating character -** replaced by '\0'. -** -** An example of a reply item might be: "08\r12.345\0" -** -** b) RS__PROTOCOL_ID = "V01B" -** -** Name #bytes Description -** ==== ====== =========== -** rply_len 4 The number of bytes following encoded as 4 ASCII -** decimal chars. -** term 1 The terminating character which was detected at the -** end of the reply. This will be one of the -** characters specified in . -** rply The zero-terminated reply. This is effectively the -** reply as received with the terminating character -** replaced by '\0'. -** -** An example of a reply item might be: "0009\r12.3456\0" -**--------------------------------------------------------------------------*/ - struct RS__RespStruct { - char msg_size[4]; - char msg_id[4]; - char s_pcol_lvl[4]; /* Server protocol level */ - char n_rply[4]; /* Error if < 0 */ - union { - char rplys[496]; - char sub_status[12]; - } u; - }; - /* - ** The "rplys" buffer in RS__RespStruct is a - ** concatenated list of the following structures. - */ - struct RS__RplyStruct { - char rply_len[2]; /* 2 ASCII decimal chars!! - ** The length includes the - ** terminator, term, and the - ** zero terminator of rply. - */ - char term; /* The terminating character */ - char rply[1]; /* Zero terminated string */ - }; - struct RS__RplyStruct_V01B { - char rply_len[4]; /* 4 ASCII decimal chars!! - ** The length includes the - ** terminator, term, and the - ** zero terminator of rply. - */ - char term; /* The terminating character */ - char rply[1]; /* Zero terminated string */ - }; -/*------------------------------------------------ End of RS232C_DEF.H --*/ -#endif /* _rs232c_def_ */ diff --git a/hardsup/serialsinq.c b/hardsup/serialsinq.c deleted file mode 100644 index 2d40ac72..00000000 --- a/hardsup/serialsinq.c +++ /dev/null @@ -1,914 +0,0 @@ -/*------------------------------------------------------------------------- - S E R I A L S I N Q - Implementation file of the functions for talking with a RS--232 port - on a SINQ terminal server. This code has been adapted from code - provided by David Maden for the EL734 motor controller. A new version - became necessary as the Dornier velocity selector supports a - completely different protocoll than the EL734. The basics, however, are - the same. - - Mark Koennecke, Juli 1997 - - Copyright: - - Labor fuer Neutronenstreuung - Paul Scherrer Institut - CH-5423 Villigen-PSI - - - The authors hereby grant permission to use, copy, modify, distribute, - and license this software and its documentation for any purpose, provided - that existing copyright notices are retained in all copies and that this - notice is included verbatim in any distributions. No written agreement, - license, or royalty fee is required for any of the authorized uses. - Modifications to this software may be copyrighted by their authors - and need not follow the licensing terms described here, provided that - the new terms are clearly indicated on the first page of each file where - they apply. - - IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY - FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY - DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - - THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE - IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE - NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR - MODIFICATIONS. -----------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include -#include - -#ifdef FORTIFY -#include "../fortify.h" -#endif - -#include -#include -#include -#include -#include -#include - -#include - -#ifdef __VMS -#include -#else -#include -#endif - -/*-----------------------------------------------------------------*/ -#include "sinq_prototypes.h" -#include "el734_def.h" -#include "rs232c_def.h" -#include "el734fix.h" -#include "serialsinq.h" - -#define True 1 -#define False 0 - - struct SerialInfo { - int skt; - int iForce; - int port; - int chan; - char host[20]; - int tmo; - int msg_id; - int n_replies, max_replies; - char pTerms[4]; - char pSendTerm[10]; - struct RS__MsgStruct to_host; - struct RS__RespStruct from_host; - SerialSleep pFunc; - void *pData; - struct AsynSrv__info sAsync; - }; -/*------------------- The default sleep function -----------------------*/ - static int SerialNccrrrh(void *pData, int iTime) - { - usleep(50); - return 1; - } - -/*-----------------------------------------------------------------------*/ - int SerialOpen(void **pData, char *pHost, int iPort, int iChannel) - { - int status; - struct SerialInfo *my_info; - void *my_hndl; - struct hostent *rmt_hostent; - struct in_addr *rmt_inet_addr_pntr; - int rmt_sockname_len; - struct sockaddr_in lcl_sockname; - struct sockaddr_in rmt_sockname; - char msr_cmnd[20]; - struct RS__RplyStruct *rply_ptr; - - *pData = NULL; - -/* -** allocate memory first -*/ - *pData = malloc (sizeof (struct SerialInfo)); - if (*pData == NULL) { - return EL734__BAD_MALLOC; /* malloc failed!! */ - } - my_info = *pData; - memset(my_info,0,sizeof(struct SerialInfo)); - -/* -**-------------------------- Set up the connection -*/ - my_info->sAsync.port = iPort; - strcpy(my_info->sAsync.host,pHost); - my_info->sAsync.chan = iChannel; - status = AsynSrv_Open (&(my_info->sAsync)); - if (status != 1) { - return OPENFAILURE; - } - - /* intialize data structures */ - StrJoin (my_info->host, sizeof (my_info->host), pHost, ""); - my_info->skt = my_info->sAsync.skt; - my_info->port = iPort; - my_info->chan = iChannel; - my_info->tmo = 100; - my_info->msg_id = 0; - my_info->pFunc = SerialNccrrrh; - my_info->pData = NULL; - strcpy(my_info->pTerms,"1\r\n\0"); - my_info->iForce = 0; - memset(my_info->pSendTerm,0,9); - strcpy(my_info->pSendTerm,"\r\n"); - - return 1; - } -/*-----------------------------------------------------------------------*/ - int SerialForceOpen(void **pData, char *pHost, int iPort, int iChannel) - { - int status; - struct SerialInfo *my_info; - void *my_hndl; - struct hostent *rmt_hostent; - struct in_addr *rmt_inet_addr_pntr; - int rmt_sockname_len; - struct sockaddr_in lcl_sockname; - struct sockaddr_in rmt_sockname; - char msr_cmnd[20]; - struct RS__RplyStruct *rply_ptr; - - *pData = NULL; - - /* create pData */ - *pData = malloc (sizeof (struct SerialInfo)); - if (*pData == NULL) { - return EL734__BAD_MALLOC; /* malloc failed!! */ - } - my_info = *pData; - memset(my_info,0,sizeof(struct SerialInfo)); - - -/* -**-------------------------- Set up the connection -*/ - my_info->sAsync.port = iPort; - strcpy(my_info->sAsync.host,pHost); - my_info->sAsync.chan = iChannel; - status = AsynSrv_OpenNew (&(my_info->sAsync)); - if (status != 1) { - return OPENFAILURE; - } - - /* intialize data structures */ - StrJoin (my_info->host, sizeof (my_info->host), pHost, ""); - my_info->skt = my_info->sAsync.skt; - my_info->port = iPort; - my_info->chan = iChannel; - my_info->tmo = 100; - my_info->msg_id = 0; - my_info->pFunc = SerialNccrrrh; - my_info->pData = NULL; - strcpy(my_info->pTerms,"1\r\n\0"); - my_info->iForce = 1; - memset(my_info->pSendTerm,0,9); - strcpy(my_info->pSendTerm,"\r\n"); - - return 1; - } -/*--------------------------------------------------------------------------*/ - int SerialConfig(void **pData, int iTmo) - { - struct SerialInfo *my_info = NULL; - - my_info = (struct SerialInfo *)*pData; - assert(my_info); - - if(iTmo < 100) - { - my_info->tmo = 1; - return 1; - } - else - { - my_info->tmo = iTmo/100; /* convert to deci seconds */ - if(my_info->tmo > 9999)my_info->tmo = 9999; - } - return 1; - } -/*--------------------------------------------------------------------------*/ - int GetSerialTmo(void **pData) - { - struct SerialInfo *my_info = NULL; - int iTmo; - - my_info = (struct SerialInfo *)*pData; - assert(my_info); - - iTmo = my_info->tmo*100-99; /* convert back to milli seconds */ - - return iTmo; - } - int SerialGetTmo(void **pData) - { - return GetSerialTmo(pData); - } -/*--------------------------------------------------------------------------*/ - int SerialGetSocket(void **pData) - { - struct SerialInfo *my_info = NULL; - int iTmo; - - my_info = (struct SerialInfo *)*pData; - assert(my_info); - - return my_info->skt; - - return 1; - } -/*--------------------------------------------------------------------------*/ - int SerialClose(void **pData) - { - - struct SerialInfo *info_ptr; - char buff[4]; - - info_ptr = (struct SerialInfo *) *pData; - if (info_ptr == NULL) return True; - - if (info_ptr->skt != 0) { - AsynSrv_Close (&(info_ptr->sAsync),0); - info_ptr->skt = 0; - } - free (*pData); - *pData = NULL; - return True; - } -/*--------------------------------------------------------------------------*/ - int SerialForceClose(void **pData) - { - - struct SerialInfo *info_ptr; - char buff[4]; - - info_ptr = (struct SerialInfo *) *pData; - if (info_ptr == NULL) return True; - - if (info_ptr->skt != 0) { - AsynSrv_Close (&(info_ptr->sAsync),1); - info_ptr->skt = 0; - } - free (*pData); - *pData = NULL; - return True; - } -/*--------------------------------------------------------------------------*/ - int SerialATerm(void **pData, char *pTerm) - { - struct SerialInfo *my_info = NULL; - - my_info = (struct SerialInfo *)*pData; - if(my_info == NULL) - { - printf("Serious Programming problem: data = NULL\n"); - return 0; - } - - /* only three characters in this field */ - if(strlen(pTerm) > 4) - { - return 0; - } - memset(my_info->pTerms,0,4); - strcpy(my_info->pTerms,pTerm); - - return 1; - } -/*--------------------------------------------------------------------------*/ - int SerialAGetTerm(void **pData, char *pTerm, int iTermLen) - { - struct SerialInfo *my_info = NULL; - - my_info = (struct SerialInfo *)*pData; - assert(my_info); - - strncpy(pTerm,my_info->pTerms,iTermLen); - - return 1; - } -/*-------------------------------------------------------------------------*/ - int SerialSendTerm(void **pData, char *pTerm) - { - struct SerialInfo *my_info = NULL; - - my_info = (struct SerialInfo *)*pData; - assert(my_info); - - /* only 0 characters in this field */ - if(strlen(pTerm) > 9) - { - return 0; - } - strcpy(my_info->pSendTerm,pTerm); - - return 1; - } - -/*---------------------------------------------------------------------------*/ - - int SerialSend(void **pData, char *pCommand) - { - struct SerialInfo *info_ptr; - int status, c_len, size, max_size, ncmnds; - int bytes_to_come, bytes_left; - int iResult; - char *nxt_byte_ptr; - char err_text[80]; - char text[20]; - char *txt_ptr; - char *cmnd_lst_ptr; - char *pComCom = NULL; - - /* - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. - */ - info_ptr = (struct SerialInfo *) *pData; - if (info_ptr == NULL) return NOCONNECTION; - if (info_ptr->skt == 0) { - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return NOCONNECTION; - } - - info_ptr->msg_id++; /* Set up an incrementing message id */ - if (info_ptr->msg_id > 9999) info_ptr->msg_id = 1; - sprintf (info_ptr->to_host.msg_id, "%04.4d", info_ptr->msg_id); - - memcpy (info_ptr->to_host.c_pcol_lvl, RS__PROTOCOL_ID_V01B, - sizeof (info_ptr->to_host.c_pcol_lvl)); - sprintf (info_ptr->to_host.serial_port, "%04.4d", info_ptr->chan); - sprintf (info_ptr->to_host.tmo, "%04d", info_ptr->tmo); - - strncpy(info_ptr->sAsync.eot,info_ptr->pTerms,4); - memcpy (info_ptr->to_host.terms, info_ptr->pTerms, - sizeof (info_ptr->to_host.terms)); - memcpy (info_ptr->to_host.n_cmnds, "0000", - sizeof (info_ptr->to_host.n_cmnds)); - - - txt_ptr = pCommand; /* Get pntr to cmnd string */ - ncmnds = 0; - cmnd_lst_ptr = &info_ptr->to_host.cmnds[0]; - bytes_left = sizeof (info_ptr->to_host) - - OffsetOf (struct RS__MsgStruct, cmnds[0]); - - size = strlen (txt_ptr) + strlen(info_ptr->pSendTerm); - if (size > bytes_left) { - return EL734__BAD_SENDLEN; /* Too much to send */ - }else { - strcpy (cmnd_lst_ptr+4, txt_ptr); - /* make sure that the string is properly terminated */ - if((strstr(txt_ptr,info_ptr->pSendTerm) == 0) && - (strlen(txt_ptr) > 0) ) - { - strcpy(cmnd_lst_ptr+4+strlen(txt_ptr),info_ptr->pSendTerm); - c_len = strlen(txt_ptr) + strlen(info_ptr->pSendTerm); - } - else - { - c_len = strlen (txt_ptr); - } - sprintf (text, "%04.4d", c_len); - memcpy (cmnd_lst_ptr, text, 4); - cmnd_lst_ptr = cmnd_lst_ptr + c_len + 4; - ncmnds++; - bytes_left = bytes_left - size; - } - - sprintf (text, "%04.4d", ncmnds); - memcpy (info_ptr->to_host.n_cmnds, - text, sizeof (info_ptr->to_host.n_cmnds)); - - size = cmnd_lst_ptr - info_ptr->to_host.msg_id; - size = (size + 3) & (~3); /* Round up to multiple of 4 */ - sprintf (text, "%04.4d", size); - memcpy (info_ptr->to_host.msg_size, text, 4); - - status = send (info_ptr->skt, (char *) &info_ptr->to_host, size+4, 0); - if (status != (size+4)) { - if (status == 0) { - iResult = EL734__BAD_SEND; /* Server exited (probably) */ - }else if (status == -1) { - iResult = EL734__BAD_SEND_PIPE; /* Server exited (probably) */ - } - AsynSrv_Close (&(info_ptr->sAsync),1); - info_ptr->skt = 0; - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return iResult; - } - return 1; - } -/*-------------------------------------------------------------------------*/ - int SerialReceive(void **pData, char *pBuffer, int iBufLen) - { - struct SerialInfo *info_ptr; - int status, c_len, size, max_size, ncmnds; - int bytes_to_come, bytes_left; - int iResult; - char *nxt_byte_ptr; - char err_text[80]; - char text[20]; - char *txt_ptr; - char *cmnd_lst_ptr; - struct RS__RplyStruct_V01B *ptr = NULL; - long lMask = 0L; - struct timeval tmo = {0,1}; - - - /* - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. - */ - info_ptr = (struct SerialInfo *) *pData; - if (info_ptr == NULL) return NOCONNECTION; - if (info_ptr->skt == 0) { - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return NOCONNECTION; - } - - /* try with select if there is data */ -/* lMask = (1 << info_ptr->skt); - tmo.tv_usec = 10; - status = select((info_ptr->skt +1), (fd_set *)&lMask, NULL,NULL,&tmo); - if(status <= 0) - { - return SELECTFAIL; - } -*/ - - /* try read the message length to come */ - size = sizeof (info_ptr->from_host.msg_size); - status = recv (info_ptr->skt, info_ptr->from_host.msg_size, size, 0); - if (status != size) { - if(status > 0) - { - iResult = EL734__BAD_RECV; /* Server exited (probably) */ - } - else if (status == -1) { - iResult = EL734__BAD_RECV_NET; /* It's some other net problem */ - } - else - { - iResult = EL734__BAD_RECV_NET; - } - AsynSrv_Close (&(info_ptr->sAsync),1); - info_ptr->skt = 0; - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return iResult; - } - if (sscanf (info_ptr->from_host.msg_size, "%4d", &bytes_to_come) != 1) { - return EL734__BAD_NOT_BCD; /* Header not an ASCII BCD integer */ - } - - max_size = sizeof (info_ptr->from_host) - - sizeof (info_ptr->from_host.msg_size); - if (bytes_to_come > max_size) { - iResult = EL734__BAD_RECVLEN; - nxt_byte_ptr = &info_ptr->from_host.msg_size[size]; - while (bytes_to_come > 0) { /* Flush out the incoming message */ - bytes_left = bytes_to_come; - if (bytes_left > max_size) bytes_left = max_size; - status = recv (info_ptr->skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - iResult = EL734__BAD_FLUSH; /* TCP/IP problem whilst flushing */ - AsynSrv_Close (&(info_ptr->sAsync),1); - info_ptr->skt = 0; - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return iResult; - } - bytes_to_come = bytes_to_come - status; - } - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return iResult; - }else { - nxt_byte_ptr = &info_ptr->from_host.msg_size[size]; - bytes_left = bytes_to_come; - while (bytes_left > 0) { /* Read the rest of the response */ - status = recv (info_ptr->skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - if (status == 0) { - iResult = EL734__BAD_RECV1; /* Server exited (probably) */ - }else { - iResult = EL734__BAD_RECV1_NET; /* It's some other net fault */ - } - AsynSrv_Close (&(info_ptr->sAsync),1); - info_ptr->skt = 0; - return iResult; - } - bytes_left = bytes_left - status; - nxt_byte_ptr = nxt_byte_ptr + status; - } - } - /* well, we got data, make it available */ - if (sscanf (info_ptr->from_host.n_rply, "%4d", - &info_ptr->max_replies) != 1)info_ptr->max_replies = 0; - if (info_ptr->max_replies > 0) - ptr = (struct RS__RplyStruct_V01B *) info_ptr->from_host.u.rplys; - info_ptr->n_replies = 1; - if(ptr) - { - strncpy(pBuffer, ptr->rply,iBufLen); - } - else - { - return NOREPLY; - } - return True; - } -/*-------------------------------------------------------------------------*/ - int SerialReceiveWithTerm(void **pData, char *pBuffer, - int iBufLen, char *cTerm ) - { - struct SerialInfo *info_ptr; - int status, c_len, size, max_size, ncmnds; - int bytes_to_come, bytes_left; - int iResult; - char *nxt_byte_ptr; - char err_text[80]; - char text[20]; - char *txt_ptr; - char *cmnd_lst_ptr; - struct RS__RplyStruct_V01B *ptr = NULL; - long lMask = 0L; - struct timeval tmo = {0,1}; - - - /* - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. - */ - info_ptr = (struct SerialInfo *) *pData; - if (info_ptr == NULL) return NOCONNECTION; - if (info_ptr->skt == 0) { - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return NOCONNECTION; - } - - /* try with select if there is data */ -/* lMask = (1 << info_ptr->skt); - tmo.tv_usec = 10; - status = select((info_ptr->skt +1), (fd_set *)&lMask, NULL,NULL,&tmo); - if(status <= 0) - { - return SELECTFAIL; - } -*/ - - /* try read the message length to come */ - size = sizeof (info_ptr->from_host.msg_size); - status = recv (info_ptr->skt, info_ptr->from_host.msg_size, size, 0); - if (status != size) { - if(status > 0) - { - iResult = EL734__BAD_RECV; /* Server exited (probably) */ - } - else if (status == -1) { - iResult = EL734__BAD_RECV_NET; /* It's some other net problem */ - } - else - { - iResult = EL734__BAD_RECV_NET; - } - AsynSrv_Close (&(info_ptr->sAsync),1); - info_ptr->skt = 0; - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return iResult; - } - if (sscanf (info_ptr->from_host.msg_size, "%4d", &bytes_to_come) != 1) { - return EL734__BAD_NOT_BCD; /* Header not an ASCII BCD integer */ - } - - max_size = sizeof (info_ptr->from_host) - - sizeof (info_ptr->from_host.msg_size); - if (bytes_to_come > max_size) { - iResult = EL734__BAD_RECVLEN; - nxt_byte_ptr = &info_ptr->from_host.msg_size[size]; - while (bytes_to_come > 0) { /* Flush out the incoming message */ - bytes_left = bytes_to_come; - if (bytes_left > max_size) bytes_left = max_size; - status = recv (info_ptr->skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - iResult = EL734__BAD_FLUSH; /* TCP/IP problem whilst flushing */ - AsynSrv_Close (&(info_ptr->sAsync),1); - info_ptr->skt = 0; - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return iResult; - } - bytes_to_come = bytes_to_come - status; - } - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return iResult; - }else { - nxt_byte_ptr = &info_ptr->from_host.msg_size[size]; - bytes_left = bytes_to_come; - while (bytes_left > 0) { /* Read the rest of the response */ - status = recv (info_ptr->skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - if (status == 0) { - iResult = EL734__BAD_RECV1; /* Server exited (probably) */ - }else { - iResult = EL734__BAD_RECV1_NET; /* It's some other net fault */ - } - AsynSrv_Close (&(info_ptr->sAsync),1); - info_ptr->skt = 0; - return iResult; - } - bytes_left = bytes_left - status; - nxt_byte_ptr = nxt_byte_ptr + status; - } - } - /* well, we got data, make it available */ - if (sscanf (info_ptr->from_host.n_rply, "%4d", - &info_ptr->max_replies) != 1)info_ptr->max_replies = 0; - if (info_ptr->max_replies > 0) - ptr = (struct RS__RplyStruct_V01B *) info_ptr->from_host.u.rplys; - info_ptr->n_replies = 1; - if(ptr) - { - strncpy(pBuffer, ptr->rply,iBufLen); - *cTerm = ptr->term; - } - else - { - return NOREPLY; - } - return True; - } - -/*---------------------------------------------------------------------------*/ - int SerialError(int iErr, char *pBuffer, int iBufLen) - { - switch(iErr) - { - case -320: - strncpy(pBuffer,"Select failed to find data",iBufLen); - break; - case -300: - case NOCONNECTION: - strncpy(pBuffer,"Not connected",iBufLen); - break; - case -301: - strncpy(pBuffer,"No reply found", iBufLen); - break; - case -100: - strncpy(pBuffer,"No reply found", iBufLen); - break; - case EL734__BAD_ADR: - strncpy(pBuffer,"SERIAL__BAD_ADR",iBufLen); - break; - case EL734__BAD_BIND: - strncpy(pBuffer,"SERIAL__BAD_BIND",iBufLen); - break; - case EL734__BAD_CMD: - strncpy(pBuffer,"SERIAL__BAD_CMD",iBufLen); - break; - case EL734__BAD_CONNECT: - strncpy(pBuffer,"SERIAL__BAD_CONNECT",iBufLen); - break; - case EL734__BAD_FLUSH: - strncpy(pBuffer,"SERIAL__BAD_FLUSH",iBufLen); - break; - case EL734__BAD_HOST: - strncpy(pBuffer,"SERIAL__BAD_HOST",iBufLen); - break; - case EL734__BAD_ID: - strncpy(pBuffer,"SERIAL__BAD_ID",iBufLen); - break; - case EL734__BAD_ILLG: - strncpy(pBuffer,"SERIAL__BAD_ILLG",iBufLen); - break; - case EL734__BAD_LOC: - strncpy(pBuffer,"SERIAL__BAD_LOC",iBufLen); - break; - case EL734__BAD_MALLOC: - strncpy(pBuffer,"SERIAL__BAD_MALLOC",iBufLen); - break; - case EL734__BAD_NOT_BCD: - strncpy(pBuffer,"SERIAL__BAD_NOT_BCD",iBufLen); - break; - case EL734__BAD_OFL: - strncpy(pBuffer,"SERIAL__BAD_OFL",iBufLen); - break; - case EL734__BAD_PAR: - strncpy(pBuffer,"SERIAL__BAD_PAR",iBufLen); - break; - - case EL734__BAD_RECV: - strncpy(pBuffer,"SERIAL__BAD_RECV",iBufLen); - break; - case EL734__BAD_RECV_NET: - strncpy(pBuffer,"SERIAL__BAD_RECV_NET",iBufLen); - break; - case EL734__BAD_RECV_PIPE: - strncpy(pBuffer,"SERIAL__BAD_RECV_PIPE",iBufLen); - break; - case EL734__BAD_RECV_UNKN: - strncpy(pBuffer,"SERIAL__BAD_RECV_UNKN",iBufLen); - break; - case EL734__BAD_RECVLEN: - strncpy(pBuffer,"SERIAL__BAD_RECVLEN",iBufLen); - break; - case EL734__BAD_RECV1: - strncpy(pBuffer,"SERIAL__BAD_RECV1",iBufLen); - break; - case EL734__BAD_RECV1_NET: - strncpy(pBuffer,"SERIAL__BAD_RECV1_NET",iBufLen); - break; - case EL734__BAD_RECV1_PIPE: - strncpy(pBuffer,"SERIAL__BAD_RECV1_PIPE",iBufLen); - break; - case EL734__BAD_RNG: - strncpy(pBuffer,"SERIAL__BAD_RNG",iBufLen); - break; - case EL734__BAD_SEND: - strncpy(pBuffer,"SERIAL__BAD_SEND",iBufLen); - break; - case EL734__BAD_SEND_PIPE: - strncpy(pBuffer,"SERIAL__BAD_SEND_PIPE",iBufLen); - break; - case EL734__BAD_SEND_NET: - strncpy(pBuffer,"SERIAL__BAD_SEND_NET",iBufLen); - break; - case EL734__BAD_SEND_UNKN: - strncpy(pBuffer,"SERIAL__BAD_SEND_UNKN",iBufLen); - break; - case EL734__BAD_SENDLEN: - strncpy(pBuffer,"SERIAL__BAD_SENDLEN",iBufLen); - break; - case EL734__BAD_SOCKET: - strncpy(pBuffer,"SERIAL__BAD_SOCKET",iBufLen); - break; - case EL734__BAD_TMO: - strncpy(pBuffer,"SERIAL__BAD_TMO",iBufLen); - break; - case EL734__FORCED_CLOSED: - strncpy(pBuffer,"SERIAL__FORCED_CLOSED",iBufLen); - break; - case OPENFAILURE: - strncpy(pBuffer, - "FAILED to open connection to serial port server", iBufLen); - break; - default: - strcpy(pBuffer,"Unknown SERIAL error"); - break; - } - return 1; - } -/*---------------------------------------------------------------------------*/ - int SerialWriteRead(void **pData, char *pCommand, - char *pBuffer, int iBufLen) - { - - struct SerialInfo *pInfo = NULL; - int iRet; - time_t tTarget, tCurrent; - - pInfo = (struct SerialInfo *)*pData; - - /* write */ - iRet = SerialSend(pData,pCommand); - if(iRet != 1) - { - SerialError(iRet, pBuffer,iBufLen); - return iRet; - } - - /* check for answers for maximum time out */ - tTarget = tCurrent = time(&tCurrent); - tTarget += pInfo->tmo*100 - 90; - - while(tCurrent < tTarget) - { - pInfo->pFunc(pInfo->pData, 100); - iRet = SerialReceive(pData, pBuffer,iBufLen); - if( iRet != 1) - { - if(iRet != SELECTFAIL) - { - /* error ! */ - SerialError(iRet, pBuffer,iBufLen); - return iRet; - } - } - else - { - return 1; /* there is data read, we are done */ - } - tCurrent = time(&tCurrent); - } - return TIMEOUT; - } -/*---------------------------------------------------------------------------*/ - int SerialNoReply(void **pData, char *pCommand) - { - - struct SerialInfo *pInfo = NULL; - int iRet, iOld, i; - char pBuffer[30]; - - pInfo = (struct SerialInfo *)*pData; - - iOld = pInfo->tmo; - pInfo->tmo = 0; - - /* write */ - iRet = SerialSend(pData,pCommand); - if(iRet != 1) - { - pInfo->tmo = iOld; - return iRet; - } - - /* try some time to find a TMO */ - for(i = 0 ; i < 10; i++) - { - usleep(50); - SerialReceive(pData, pBuffer,29); - if(strcmp(pBuffer,"?TMO") == 0) - { - break; - } - } - if(i > 7) - { - printf("TMO received after %d cycles \n",i); - } - pInfo->tmo = iOld; - return 1; - } -/*-------------------------------------------------------------------------*/ - void SetSerialSleep(void **pData, SerialSleep pFun, void *pUserData) - { - struct SerialInfo *pInfo = NULL; - int iRet; - - pInfo = (struct SerialInfo *)*pData; - pInfo->pFunc = pFun; - pInfo->pData = pUserData; - - } - - - - - - - - - - - - - - - - - diff --git a/hardsup/serialsinq.h b/hardsup/serialsinq.h deleted file mode 100644 index 60e5dc8d..00000000 --- a/hardsup/serialsinq.h +++ /dev/null @@ -1,56 +0,0 @@ - -#line 156 "velodorn.w" - -/*---------------------------------------------------------------------------- - S E R I A L S I N Q - - Utility functions for maintaining a connection to a RS--232 port on a - Macintosh computer running the SINQ terminal server application. - - Mark Koennecke, Juli 1997 - - copyright: see implementation file -------------------------------------------------------------------------------*/ -#ifndef SERIALSINQ -#define SERIALSINQ -#define NOREPLY -100 -#define NOCONNECTION -121 -#define SELECTFAIL -120 -#define TIMEOUT -730 -#define INTERRUPTED -132 -#define OPENFAILURE -133 - -#line 30 "velodorn.w" - - int SerialOpen(void **pData, char *pHost, int iPort, int iChannel); - int SerialForceOpen(void **pData, char *pHost, int iPort, int iChannel); - int SerialConfig(void **pData, int iTmo); - int SerialGetTmo(void **pData); - int SerialATerm(void **pData, char *pTerm); - int SerialAGetTerm(void **pData, char *pTerm, int iTermLen); - int SerialSendTerm(void **pData, char *pTerm); - int SerialGetSocket(void **pData); - int SerialClose(void **pData); - int SerialForceClose(void **pData); - - int SerialSend(void **pData, char *pCommand); - int SerialReceive(void **pData, char *pBuffer, int iBufLen); - int SerialReceiveWithTerm(void **pData, char *pBuffer, - int iBufLen,char *cTerm); - int SerialError(int iError, char *pError, int iErrLen); - int SerialWriteRead(void **pData, char *pCommand, - char *pBuffer, int iBufLen); - int SerialNoReply(void **pData, char *pCommand); - -#line 175 "velodorn.w" - -/*-------------------------- The sleeperette -----------------------------*/ - -#line 116 "velodorn.w" - - typedef int (*SerialSleep)(void *pData, int iTime); - void SetSerialSleep(void **pData, SerialSleep pFunc, void *pUserData); - -#line 177 "velodorn.w" - -#endif diff --git a/hardsup/sinq_defs.h b/hardsup/sinq_defs.h deleted file mode 100644 index c437f8e7..00000000 --- a/hardsup/sinq_defs.h +++ /dev/null @@ -1,108 +0,0 @@ -/* -** TAS_SRC:[LIB]SINQ_DEFS.H -** -** Include file generated from SINQ_DEFS.OBJ -** -** 29-AUG-2000 09:49:31.72 -*/ - -#define SS__NORMAL 0x1 -#define SS__WASSET 0x9 -#define SS__ILLEFC 0xEC -#define SS__UNASEFC 0x234 -#define SEM_BIT 0x0 -#define SEM_PID 0x4 -#define SEM_WFLG 0x8 -#define SEM_IDNT 0xC -#define SEM_CNT0 0x1C -#define SEM_CNT1 0x20 -#define SEM_CNT2 0x24 -#define SEM_CNT3 0x28 -#define SEM_SUB_PID 0x2C -#define SEM_SIZE 0x40 -#define SEM__CAMAC_CSR 0x0 -#define SEM__CAMAC_IVG 0x40 -#define SEM__CAMAC_GPIB 0x80 -#define SEM__CAMAC_3344 0xC0 -#define MAP__CAMAC_FIELD_0 0x0 -#define MAP__CAMAC_FIELD_1 0x1 -#define MAP__CAMAC_FIELD_2 0x2 -#define MAP__CAMAC_FIELD_CSR 0x3 -#define MAP__CAMAC_SEMAPHORE 0x4 -#define MAP__DELTAT_CB 0x5 -#define MAP__DELTAT_SCALERS 0x6 -#define CAMIF__JCC 0x1 -#define CAMIF__GEC0 0x3 -#define CAMIF__CES 0x4 -#define CAMIF__BIRA 0x5 -#define CAMIF__GEC1 0x6 -#define CAMIF__GEC2 0x7 -#define CAMIF__GEC3 0x8 -#define CAMIF__CCP 0x9 -#define CAMIF__OS9 0xA -#define CAMIF__KCBD 0xB -#define CAMIF__VAN 0xC -#define CAMIF__KVCC 0xD -#define CAMIF__M_XQ 0x3 -#define CAMIF__X_Q 0x0 -#define CAMIF__X_NOQ 0x1 -#define CAMIF__NOX_Q 0x2 -#define CAMIF__NOX_NOQ 0x3 -#define CAMIF__NO_CAMIF 0x4 -#define CAMIF__TMOUT 0x8 -#define CAMIF__ILLPAR 0xC -#define CAMIF__RPTFAIL 0x14 -#define CAMIF__SEMTMO 0x18 -#define MSR__BUSY 0x1 -#define MSR__OK 0x2 -#define MSR__REF_OK 0x4 -#define MSR__STOPPED 0x8 -#define MSR__LO_LIM 0x10 -#define MSR__HI_LIM 0x20 -#define MSR__HALT 0x40 -#define MSR__RUN_FAULT 0x80 -#define MSR__RUN_FAIL 0x100 -#define MSR__POS_FAULT 0x200 -#define MSR__POS_FAIL 0x400 -#define MSR__REF_FAIL 0x800 -#define MSR__AC_FAIL 0x1000 -#define MSR__LIM_ERR 0x2000 -#define SS__HALT 0x1 -#define SS__CCW 0x2 -#define SS__STP 0x4 -#define SS__LS1 0x8 -#define SS__LS2 0x10 -#define SS__LSX 0x20 -#define EL737_STATE_UNKNOWN 0xFFFFFFFE -#define EL737_STATE_OFFLINE 0xFFFFFFFF -#define EL737_STATE_MS 0x0 -#define EL737_STATE_PTS 0x1 -#define EL737_STATE_PCS 0x2 -#define EL737_STATE_LRTS 0x5 -#define EL737_STATE_LRCS 0x6 -#define EL737_STATE_PTSP 0x9 -#define EL737_STATE_PCSP 0xA -#define EL737_STATE_LRTSP 0xD -#define EL737_STATE_LRCSP 0xE -#define SINQHM_CNCT 0x1 -#define SINQHM_CONFIG 0x2 -#define SINQHM_DECONFIG 0x3 -#define SINQHM_EXIT 0x4 -#define SINQHM_STATUS 0x5 -#define SINQHM_DBG 0x6 -#define SINQHM_CLOSE 0x101 -#define SINQHM_INH 0x102 -#define SINQHM_IOREG 0x103 -#define SINQHM_READ 0x104 -#define SINQHM_SET_TDC 0x105 -#define SINQHM_SHOW 0x106 -#define SINQHM_WRITE 0x107 -#define SINQHM_ZERO 0x108 -#define INH_SET 0x1 -#define INH_CLR 0x2 -#define INH_TST 0x3 -#define IO_SET 0x1 -#define IO_CLR 0x2 -#define IO_PULSE 0x3 -#define TT_PORT__NO_RETRY 0x1 -#define TT_PORT__NO_SIG 0x2 diff --git a/hardsup/sinq_prototypes.h b/hardsup/sinq_prototypes.h deleted file mode 100644 index 2be3165f..00000000 --- a/hardsup/sinq_prototypes.h +++ /dev/null @@ -1,674 +0,0 @@ -#ifndef _sinq_prototypes_loaded_ -#define _sinq_prototypes_loaded_ -/*---------------------------------------------- SINQ_PROTOTYPES.H Ident V02T -** -** Prototype header file for entry points in SINQ.OLB -** -** Updates: -** V01A 21-Mar-1996 DM Initial version. -*/ -#ifdef VAXC -#include asynsrv_def -#include rs232c_def -#include el734_def -#include el737_def -#else -#include -#include -#include -#include -#endif -/* ---------------------------------------------------------------------*/ - int AsynSrv_ChanClose ( - struct AsynSrv__info *asyn_info); - int AsynSrv_Close ( - struct AsynSrv__info *asyn_info, - int force_flag); - int AsynSrv_Config ( - struct AsynSrv__info *asyn_info, - ...); - int AsynSrv_ConfigDflt ( - char *par_id, - ...); - void AsynSrv_ErrInfo ( - char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno); - int AsynSrv_Flush ( - struct AsynSrv__info *asyn_info); - int AsynSrv_GetLenTerm ( - struct AsynSrv__info *asyn_info, - struct RS__RespStruct *rcve_buff, - char *rply, - int *len, - char *term); - char *AsynSrv_GetReply ( - struct AsynSrv__info *asyn_info, - struct RS__RespStruct *rcve_buff, - char *last_rply); - int AsynSrv_Open ( - struct AsynSrv__info *asyn_info); - int AsynSrv_OpenNew ( - struct AsynSrv__info *asyn_info); - int AsynSrv_SendCmnds ( - struct AsynSrv__info *asyn_info, - struct RS__MsgStruct *send_buff, - struct RS__RespStruct *rcve_buff, - ...); - int AsynSrv_SendCmndsBig ( - struct AsynSrv__info *asyn_info, - struct RS__MsgStruct *send_buff, - int send_buff_size, - struct RS__RespStruct *rcve_buff, - int rcve_buff_size, - ...); - int AsynSrv_Trace ( - struct AsynSrv__info *asyn_info, - int state); - int AsynSrv_Trace_Write ( - struct AsynSrv__info *asyn_info); -/* ---------------------------------------------------------------------*/ - int C_log_arr_get ( - char *name, - int arr_size, - int *value, - int indx); - int C_log_flt_get ( - char *name, - float *value, - int indx); - int C_log_int_get ( - char *name, - long int *value, - int indx); - int C_log_str_get ( - char *name, - char *value, - int val_size, - int indx); -/* ---------------------------------------------------------------------*/ - int C_str_edit ( - char *out, - char *in, - char *ctrl, - int *length); -/* ---------------------------------------------------------------------*/ - int C_tt_port_config ( - int *hndl, - int mask); - int C_tt_port_connect ( - int *hndl, - int *chan, - char *lognam, - char *pwd); - int C_tt_port_disconnect ( - int *hndl); - int C_tt_port_io ( - int *hndl, - char *rqst, - char *term, - char *answ, - int *answ_len, - int flush, - int tmo); -/* ---------------------------------------------------------------------*/ - int EL734_Close ( - void **handle, - int force_flag); - int EL734_Config ( - void **handle, - ...); - char *EL734_EncodeMSR ( - char *text, - int text_len, - int msr, - int ored_msr, - int fp_cntr, - int fr_cntr); - char *EL734_EncodeSS ( - char *text, - int text_len, - int ss); - void EL734_ErrInfo ( - char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno); - int EL734_GetAirCush ( - void **handle, - int *present, - int *state); - int EL734_GetEncGearing ( - void **handle, - int *nominator, - int *denominator); - int EL734_GetId ( - void **handle, - char *id_txt, - int id_len); - int EL734_GetLimits ( - void **handle, - float *lo, - float *hi); - int EL734_GetMotorGearing ( - void **handle, - int *nominator, - int *denominator); - int EL734_GetNullPoint ( - void **handle, - int *null_pt); - int EL734_GetPosition ( - void **handle, - float *ist_posit); - int EL734_GetPrecision ( - void **handle, - int *n_dec); - int EL734_GetRefMode ( - void **handle, - int *mode); - int EL734_GetRefParam ( - void **handle, - float *param); - int EL734_GetSpeeds ( - void **handle, - int *lo, - int *hi, - int *ramp); - int EL734_GetStatus ( - void **handle, - int *msr, - int *ored_msr, - int *fp_cntr, - int *fr_cntr, - int *ss, - float *ist_posit); - int EL734_GetZeroPoint ( - void **handle, - float *zero_pt); - int EL734_MoveNoWait ( - void **handle, - float soll_posit); - int EL734_MoveWait ( - void **handle, - float soll_posit, - int *ored_msr, - int *fp_cntr, - int *fr_cntr, - float *ist_posit); - int EL734_Open ( - void **handle, - char *host, - int port, - int chan, - int motor, - char *id); - int EL734_PutOffline ( - void **handle); - int EL734_PutOnline ( - void **handle, - int echo); - int EL734_SendCmnd ( - void **handle, - char *cmnd, - char *rply, - int rply_size); - int EL734_SetAirCush ( - void **handle, - int state); - int EL734_SetErrcode ( - struct EL734info *info_ptr, - char *response, - char *cmnd); - int EL734_SetHighSpeed ( - void **handle, - int hi); - int EL734_SetLowSpeed ( - void **handle, - int lo); - int EL734_SetRamp ( - void **handle, - int ramp); - int EL734_Stop ( - void **handle); - int EL734_WaitIdle ( - void **handle, - int *ored_msr, - int *fp_cntr, - int *fr_cntr, - float *ist_posit); - void EL734_ZeroStatus ( - void **handle); -/* ---------------------------------------------------------------------*/ - int EL737_Close ( - void **handle, - int force_flag); - int EL737_Config ( - void **handle, - ...); - int EL737_Continue ( - void **handle, - int *status); - int EL737_EnableThresh ( - void **handle, - int indx); - void EL737_ErrInfo ( - char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno); - int EL737_GetMonIntegTime ( - void **handle, - int indx, - float *mon_integ_time); - int EL737_GetRateIntegTime ( - void **handle, - float *rate_integ_time); - void *EL737_GetReply ( - void **handle, - void *last_rply); - int EL737_GetStatus ( - void **handle, - int *c1, - int *c2, - int *c3, - int *c4, - float *timer, - int *rs); - int EL737_GetStatusExtra ( - void **handle, - int *c5, - int *c6, - int *c7, - int *c8); - int EL737_GetThresh ( - void **handle, - int *indx, - float *val); - int EL737_Open ( - void **handle, - char *host, - int port, - int chan); - int EL737_Pause ( - void **handle, - int *status); - int EL737_SendCmnd ( - void **handle, - char *cmnd, - char *rply, - int rply_size); - int EL737_SetErrcode ( - struct EL737info *info_ptr, - char *response, - char *cmnd); - int EL737_SetThresh ( - void **handle, - int indx, - float val); - int EL737_StartCnt ( - void **handle, - int preset_count, - int *status); - int EL737_StartTime ( - void **handle, - float preset_time, - int *status); - int EL737_Stop ( - void **handle, - int *c1, - int *c2, - int *c3, - int *c4, - float *timer, - int *status); - int EL737_StopFast ( - void **handle); - int EL737_WaitIdle ( - void **handle, - int *c1, - int *c2, - int *c3, - int *c4, - float *timer); -/* ---------------------------------------------------------------------*/ - int EL755_Close ( - void **handle, - int force_flag); - int EL755_Config ( - void **handle, - ...); - void EL755_ErrInfo ( - char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno); - int EL755_ErrorLog ( - char *routine_name, - char *text); - int EL755_GetConstant ( - void **handle, - float *value); - int EL755_GetCurrents ( - void **handle, - float *soll, - float *ist); - int EL755_GetId ( - void **handle, - char *id_txt, - int id_len); - int EL755_GetLimit ( - void **handle, - float *value); - int EL755_GetRamp ( - void **handle, - float *value); - int EL755_GetTimeConstant ( - void **handle, - float *value); - int EL755_GetVoltageRange ( - void **handle, - float *value); - int EL755_Open ( - void **handle, - char *host, - int port, - int chan, - int indx); - int EL755_PutOffline ( - void **handle); - int EL755_PutOnline ( - void **handle, - int echo); - int EL755_SendTillSameStr ( - void **handle, - char *cmnd, - char *rply, - int rply_len); - int EL755_SendTillSameVal ( - void **handle, - char *cmnd, - float *val); - int EL755_SendTillTwoVals ( - void **handle, - char *cmnd, - float *val0, - float *val1); - int EL755_SetConstant ( - void **handle, - float value); - int EL755_SetCurrent ( - void **handle, - float soll); - int EL755_SetLimit ( - void **handle, - float value); - int EL755_SetRamp ( - void **handle, - float value); - int EL755_SetTimeConstant ( - void **handle, - float value); - int EL755_SetVoltageRange ( - void **handle, - float value); -/* ---------------------------------------------------------------------*/ - int Fluke_Close ( - void **handle, - int force_flag); - int Fluke_Config ( - void **handle, - ...); - void Fluke_ErrInfo ( - char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno); - int Fluke_ErrorLog ( - char *routine_name, - char *text); - int Fluke_Open ( - void **handle, - char *host, - int port, - int chan); - int Fluke_Read ( - void **handle, - float *ist); - int Fluke_SendTillSame ( - void **handle, - char *cmnd, - char *rply, - int rply_len); - int Fluke_SendTillSameVal ( - void **handle, - char *cmnd, - float *val); -/* ---------------------------------------------------------------------*/ - int ITC_Close ( - void **handle, - int force_flag); - int ITC_Config ( - void **handle, - ...); - int ITC_Dump_RAM ( - void **handle, - int buff_size, - char *buff, - int *dump_len, - int *n_diffs); - void ITC_ErrInfo ( - char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno); - int ITC_GetConfig ( - void **handle, - ...); - int ITC_Load_RAM ( - void **handle, - int load_len, - char *buff); - int ITC_Load_Table ( - void **handle, - char *buff); - int ITC_Open ( - void **handle, - char *host, - int port, - int chan); - int ITC_Read_ITC_Sensor ( - void **handle, - int sensor, - float factor, - float *value); - int ITC_Read_LTC11_Sensor ( - void **handle, - int sensor, - float *value); - int ITC_Read_LTC11_SetPt ( - void **handle, - float *value); - int ITC_ReadAuxTemp ( - void **handle, - float *value); - int ITC_ReadControlTemp ( - void **handle, - float *value); - int ITC_ReadHeaterOp ( - void **handle, - float *op_level, - float *op_percent); - int ITC_ReadId ( - void **handle, - char *id_txt, - int id_txt_len, - int *id_len); - int ITC_ReadPID ( - void **handle, - float *p, - float *i, - float *d); - int ITC_ReadSampleTemp ( - void **handle, - float *s_temp); - int ITC_ReadSetPoint ( - void **handle, - float *sp_temp); - int ITC_ReadStatus ( - void **handle, - char *status_txt, - int status_txt_len, - int *status_len, - int *auto_state, - int *remote_state); - int ITC_SendTillAckOk ( - void **handle, - struct RS__MsgStruct *to_host, - struct RS__RespStruct *from_host, - char *cmnd); - int ITC_SendTillSame ( - void **handle, - struct RS__MsgStruct *to_host, - struct RS__RespStruct *from_host, - char *cmnd, - char *rply, - int rply_len); - int ITC_SendTillSameLen ( - void **handle, - struct RS__MsgStruct *to_host, - struct RS__RespStruct *from_host, - char *cmnd, - char *rply, - int rply_len); - int ITC_SendTillSameLenAckOK ( - void **handle, - struct RS__MsgStruct *to_host, - struct RS__RespStruct *from_host, - char *cmnd, - char *rply, - int rply_len); - int ITC_SetControlTemp ( - void **handle, - float s_temp); - int ITC_SetHeatLevel ( - void **handle, - float heat_percent); - int ITC_ErrorLog ( - char *routine_name, - char *text); -/* ---------------------------------------------------------------------*/ - int SPS_Close ( - void **handle, - int force_flag); - int SPS_Config ( - void **handle, - ...); - void SPS_ErrInfo ( - char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno); - int SPS_ErrorLog ( - char *routine_name, - char *text); - int SPS_GetStatus ( - void **handle, - unsigned char *status_vals, - int n_status_vals, - int *adc_vals, - int n_adc_vals); - int SPS_Open ( - void **handle, - char *host, - int port, - int chan); - int SPS_SendTillSame ( - void **handle, - struct RS__MsgStruct *to_host, - struct RS__RespStruct *from_host, - char *cmnd, - char *rply, - int rply_len); - int SPS_SendTillSameLen ( - void **handle, - struct RS__MsgStruct *to_host, - struct RS__RespStruct *from_host, - char *cmnd, - char *rply, - int rply_len); -/* ---------------------------------------------------------------------*/ - int VelSel_Close ( - void **handle, - int force_flag); - void VelSel_Config ( - void **handle, - int msec_tmo, - char *eot_str); - void VelSel_ErrInfo ( - char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno); - void *VelSel_GetReply ( - void **handle, - void *last_rply); - int VelSel_GetStatus ( - void **handle, - char *status_str, - int status_str_len); - int VelSel_Open ( - void **handle, - char *host, - int port, - int chan); - int VelSel_SendCmnd ( - void **handle, - char *cmnd, - char *rply, - int rply_size); -/* ---------------------------------------------------------------------*/ - void FailInet ( - char *text); - void GetErrno ( - int *his_errno, - int *his_vaxc_errno); - int MakeCharPrintable ( - char *out, - int out_size, - char in); - char *MakePrint ( - char *text); - char *MakePrintable ( - char *out, - int out_size, - char *in); - void *Map_to_ACS (); - char *StrEdit ( - char *out, - char *in, - char *ctrl, - int *ln); - char *StrJoin ( - char *result, - int result_size, - char *str_a, - char *str_b); - int StrMatch ( - char *str_a, - char *str_b, - int min_len); - int Get_TASMAD_Info ( - char *file_name, - int *nItems, - ...); - int Get_TASMAD_Info_Filename ( - char *file_name, - char *buf, - int *bufSize); - int Update_TASMAD_Info ( - char *file_name, - int *nItems, - ...); -/*--------------------------------------------- End of SINQ_PROTOTYPES.H --*/ -#endif /* _sinq_prototypes_loaded_ */ diff --git a/hardsup/sinqhm.c b/hardsup/sinqhm.c deleted file mode 100644 index 2130591e..00000000 --- a/hardsup/sinqhm.c +++ /dev/null @@ -1,1770 +0,0 @@ -/*------------------------------------------------------------------------- - S I N Q H M - - Implementation file for the SINQ histogram memory utility functions. - - David Maden, Mark Koennecke, April 1997 - - Updated for TOF support: Mark Koennecke, December 1998 - - Added Project for AMOR: Mark Koennecke, August 2001 - - Copyright: - - Labor fuer Neutronenstreuung - Paul Scherrer Institut - CH-5423 Villigen-PSI - - - The authors hereby grant permission to use, copy, modify, distribute, - and license this software and its documentation for any purpose, provided - that existing copyright notices are retained in all copies and that this - notice is included verbatim in any distributions. No written agreement, - license, or royalty fee is required for any of the authorized uses. - Modifications to this software may be copyrighted by their authors - and need not follow the licensing terms described here, provided that - the new terms are clearly indicated on the first page of each file where - they apply. - - IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY - FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY - DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - - THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE - IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE - NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR - MODIFICATIONS. -----------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#ifdef FORTIFY -#include "fortify.h" -#endif - -#include "sinqhm.h" -#include "sinqhm.i" - -/* missing in some network stuff?? */ - -#ifndef MSG_WAITALL -#define MSG_WAITALL 0 -#endif - -/* this may be a cludge for a missing prototype on Digital Unix */ -extern int close(int fp); - -/*-----------------------------------------------------------------------*/ - static int SendDAQCommand(pSINQHM self, int iCommand, int *iDaq) - { - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - int status, iRet; - - assert(self); - assert(self->iClientSocket); - - /* prepare a message */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_DAQ); - Req_buff.u.daq.sub_cmnd = htonl (iCommand); - - /* send the message */ - status = send (self->iClientSocket, (char *) &Req_buff, sizeof (Req_buff), 0); - if (status == -1) - { - return SEND_ERROR; - } - if (status != sizeof (Req_buff)) - { - return SEND_ERROR; - } - - /* get a response */ - status = recv (self->iClientSocket, (char *) &Rply_buff, - sizeof (Rply_buff), MSG_WAITALL); - - /* check various error conditions */ - if (status == -1) - { - return RECEIVE_ERROR; - } - if (status != sizeof (Rply_buff)) - { - return INSUFFICIENT_DATA; - } - if(ntohl (Rply_buff.bigend) != 0x12345678) - { - return BYTE_ORDER_CHAOS; - } - if((iRet = ntohl (Rply_buff.status)) != KER__SUCCESS) - { - return SOFTWARE_ERROR; - } - - *iDaq = ntohs (Rply_buff.u.daq.daq_now); - - /* success */ - return 1; - } -/*-----------------------------------------------------------------------*/ - static int SendDAQStatus(pSINQHM self, - struct rply_buff_struct *pReply) - { - struct req_buff_struct Req_buff; - int status, iRet; - - assert(self); - - if(!self->iClientSocket) - { - return 0; - } - - /* prepare a message */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_STATUS); - - /* send the message */ - status = send (self->iClientSocket, (char *) &Req_buff, sizeof (Req_buff), 0); - if (status == -1) - { - return SEND_ERROR; - } - if (status != sizeof (Req_buff)) - { - return SEND_ERROR; - } - - /* get a response */ - status = recv (self->iClientSocket, (char *) pReply, - sizeof (struct rply_buff_struct), MSG_WAITALL); - - /* check various error conditions */ - if (status == -1) - { - return RECEIVE_ERROR; - } - if (status != sizeof (struct rply_buff_struct)) - { - return INSUFFICIENT_DATA; - } - if(ntohl (pReply->bigend) != 0x12345678) - { - return BYTE_ORDER_CHAOS; - } - if((iRet = ntohl (pReply->status)) != KER__SUCCESS) - { - return SOFTWARE_ERROR; - } - - /* success */ - return 1; - } - -/*-------------------------------------------------------------------------*/ - pSINQHM CreateSINQHM(char *pHMComputer, int iMasterPort) - { - pSINQHM pNew = NULL; - - /* new memory */ - pNew = (pSINQHM)malloc(sizeof(SINQHM)); - if(!pNew) - { - return NULL; - } - memset(pNew,0,sizeof(SINQHM)); - - pNew->pHMComputer = strdup(pHMComputer); - pNew->iMasterPort = iMasterPort; - - return pNew; - } -/*-----------------------------------------------------------------------*/ - pSINQHM CopySINQHM(pSINQHM self) - { - pSINQHM pNew = NULL; - - assert(self); - - pNew = CreateSINQHM(self->pHMComputer,self->iMasterPort); - if(!pNew) - { - return NULL; - } - pNew->iBinWidth = self->iBinWidth; - pNew->iPacket = self->iPacket; - pNew->iRank = self->iRank; - pNew->iLength = self->iLength; - return pNew; - } -/*-------------------------------------------------------------------------*/ - void SINQHMSetPar(pSINQHM self, int iRank, int iLength, int iBin) - { - assert(self); - - self->iRank = iRank; - self->iLength = iLength; - self->iBinWidth = iBin; - } -/*-------------------------------------------------------------------------*/ - void DeleteSINQHM(pSINQHM self) - { - int i; - - assert(self); - - if(self->pHMComputer) - { - free(self->pHMComputer); - } - - for(i = 0; i < self->iBanks; i++) - { - if(self->pBank[i].iEdges) - { - free(self->pBank[i].iEdges); - } - } - - /* make sure a possible clients connection gets murdered */ - if(self->iClientSocket) - { - SINQHMCloseDAQ(self); - } - free(self); - } -/*------------------------------------------------------------------------*/ - int SINQHMConfigure(pSINQHM self, int iMode, int iRank, int iLength, - int iBinWidth, int iLowBin, int iCompress) - { - int status, iRet; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - - assert(self); - - /* branch specially for TOF flight mode */ - if( (iMode >= SQHM__TOF) && (iMode < SQHM__HM_PSD) ) - { - self->iBinWidth = iBinWidth; - return SINQHMTimeBin(self,iMode); - } - - /* fill in the request data structure */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_CONFIG); - Req_buff.u.cnfg.mode = htonl (iMode); - Req_buff.u.cnfg.u.hm_dig.n_hists = htonl (iRank); - printf("%d\n", ntohl(Req_buff.u.cnfg.u.hm_dig.n_hists)); - Req_buff.u.cnfg.u.hm_dig.lo_bin = htonl (iLowBin); - Req_buff.u.cnfg.u.hm_dig.num_bins = htonl (iLength); - Req_buff.u.cnfg.u.hm_dig.bytes_per_bin = htonl (iBinWidth); - Req_buff.u.cnfg.u.hm_dig.compress = htonl (iCompress); - - /* try, get a connection to master server */ - status = OpenMasterConnection(self); - if(status < 0) - { - return status; - } - - /* send request */ - status = send(self->iMasterSocket,(char *)&Req_buff, sizeof(Req_buff),0); - if(status == -1) - { - return SEND_ERROR; - } - - /* get a reply */ - iRet = GetMasterReply(self,&Rply_buff,sizeof(Rply_buff)); - if(iRet < 0) - { - /* try close the socket */ - close(self->iMasterSocket); - self->iMasterSocket = 0; - return iRet; - } - else - { - /* configure successful, keep the data */ - self->iBinWidth = iBinWidth; - self->iLength = iLength; - self->iRank = iRank; - - /* close the socket */ - status = close(self->iMasterSocket); - self->iMasterSocket = 0; - if((status != 0) && (errno != ECONNRESET)) - { - return CLOSE_ERROR; - } - } - return 1; /* success, finally */ - } -/*------------------------------------------------------------------------*/ - int SINQHMConfigurePSD(pSINQHM self, int iMode, - int xSize, int xOff, int xFac, - int ySize, int yOff, int yFac, - int iBinWidth, - float *iEdges, int iEdgeLength) - { - int status, iRet; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - int iLength, i, iDelay; - unsigned int iExtra; - char *pBuffer = NULL, *pPtr; - struct tof_edge_arr tea; - int iTeaLength; - struct tof_bank toba; - - assert(self); - - /* set up detector bank information. This code supports only - one detector bank as of now. Which is appropriate for the - detector at hand. - */ - self->iBinWidth = iBinWidth; - SINQHMDefineBank(self,0,0,xSize*ySize, - iEdges,iEdgeLength); - - /* figure out how long we are going to be*/ - iLength = 36 + self->iBanks*sizeof(struct tof_bank); - for(i = 0; i < self->iBanks; i++) - { - iLength += 8 + self->pBank[i].iEdgeLength*sizeof(SQint32); - } - if(iLength < 64) - iLength = 64; - /* allocate send buffer */ - pBuffer = (char *)malloc(iLength*sizeof(char)); - if(!pBuffer) - { - return HIST_BAD_ALLOC; - } - memset(pBuffer,0,iLength); - - /* do the message header */ - iExtra = iLength - sizeof(Req_buff); - if(iExtra < 0) - iExtra = 0; - iDelay = self->pBank[0].iEdges[0]; - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_CONFIG); - Req_buff.u.cnfg.mode = htonl (iMode); - Req_buff.u.cnfg.u.psd.n_extra_bytes = htonl (iExtra); - Req_buff.u.cnfg.u.psd.n_edges = htons (1); - Req_buff.u.cnfg.u.psd.n_banks = htons (1); - Req_buff.u.cnfg.u.psd.xOffset = htons (xOff); - Req_buff.u.cnfg.u.psd.yOffset = htons (yOff); - Req_buff.u.cnfg.u.psd.xFactor = htons (xFac); - Req_buff.u.cnfg.u.psd.yFactor = htons (yFac); - Req_buff.u.cnfg.u.psd.xSize = htons (xSize); - Req_buff.u.cnfg.u.psd.ySize = htons (ySize); - Req_buff.u.cnfg.u.psd.preset_delay = htonl((int)iEdges[0]); - memcpy(pBuffer,&Req_buff,36); - pPtr = pBuffer + 36; - - /* do the edge thingies */ - for(i = 0; i < self->iBanks; i++) - { - tea.n_bins = htonl(self->pBank[i].iEdgeLength-1); - if(self->pBank[i].iEdgeLength == 2) - { - tea.flag = htonl(0); - } - else - { - tea.flag = htonl(1); - } - tea.edges = self->pBank[i].iEdges; - memcpy(pPtr,&tea,8); - pPtr += 8; - iTeaLength = self->pBank[i].iEdgeLength*4; - memcpy(pPtr,self->pBank[i].iEdges,iTeaLength); - pPtr += iTeaLength; - } - - /* do the swiss bank structures */ - for(i = 0; i < self->iBanks; i++) - { - toba.first = htons(self->pBank[i].iStart); - toba.n_cntrs = htons(self->pBank[i].iEnd); - toba.edge_indx = htons(i); - toba.bytes_per_bin = htons(self->iBinWidth); - memcpy(pPtr,&toba,sizeof(struct tof_bank)); - pPtr += sizeof(struct tof_bank); - } - - /* all packed up neat and nicely, send it */ - /* try, get a connection to master server */ - status = OpenMasterConnection(self); - if(status < 0) - { - if(pBuffer) - free(pBuffer); - return status; - } - - /* send request */ - status = send(self->iMasterSocket,pBuffer,iLength ,0); - if(pBuffer) - { - free(pBuffer); - } - if(status == -1) - { - return SEND_ERROR; - } - - /* get a reply */ - iRet = GetMasterReply(self,&Rply_buff,sizeof(Rply_buff)); - if(iRet < 0) - { - /* try close the socket */ - close(self->iMasterSocket); - self->iMasterSocket = 0; - return iRet; - } - else - { - /* close the socket */ - status = close(self->iMasterSocket); - self->iMasterSocket = 0; - if((status != 0) && (errno != ECONNRESET)) - { - return CLOSE_ERROR; - } - } - return 1; /* success, finally */ - } -/*------------------------------------------------------------------------*/ - int SINQHMDeconfigure(pSINQHM self, int iHarsh) - { - int status, iRet; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - - assert(self); - if( (iHarsh != 0) && (iHarsh != 1) ) - { - return INVALID_HARSH; - } - - /* fill in the request data structure */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_DECONFIG); - Req_buff.u.decnfg.sub_code = htonl(iHarsh); - - /* try, get a connection to master server */ - status = OpenMasterConnection(self); - if(status < 0) - { - return status; - } - - /* send request */ - status = send(self->iMasterSocket,(char *)&Req_buff, sizeof(Req_buff),0); - if(status == -1) - { - return SEND_ERROR; - } - - /* get a reply */ - iRet = GetMasterReply(self,&Rply_buff,sizeof(Rply_buff)); - if(iRet < 0) - { - close(self->iMasterSocket); - self->iMasterSocket = 0; - return iRet; - } - else - { - status = close(self->iMasterSocket); - self->iMasterSocket = 0; - if((status != 0) && (errno != ECONNRESET)) - { - return CLOSE_ERROR; - } - } - return 1; /* success, finally */ - } -/*------------------------------------------------------------------------*/ - int SINQHMGetStatus(pSINQHM self, int *iMode,int *iDaq, - int *iRank, int *iBinWidth, - int *iLength, int *iClients) - { - int status, iRet; - short sDaq, sFill; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - - assert(self); - - - status = 0; - if(self->iClientSocket) - { - status = SendDAQStatus(self,&Rply_buff); - } - else - { - /* fill in the request data structure */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_STATUS); - - /* try, get a connection to master server */ - status = OpenMasterConnection(self); - if(status < 0) - { - return status; - } - - /* send request */ - status = send(self->iMasterSocket,(char *)&Req_buff, sizeof(Req_buff),0); - if(status == -1) - { - return SEND_ERROR; - } - - /* get a reply */ - iRet = GetMasterReply(self,&Rply_buff,sizeof(Rply_buff)); - if(iRet < 0) - { - close(self->iMasterSocket); - self->iMasterSocket = 0; - return iRet; - } - else - { - status = 1; - /* close the socket and go */ - iRet = close(self->iMasterSocket); - self->iMasterSocket = 0; - if((iRet != 0) && (errno != ECONNRESET)) - { - return CLOSE_ERROR; - } - } - } - - if(status) - { - /* transfer results */ - *iMode = ntohl(Rply_buff.u.status.cfg_state); - if((sDaq = ntohs(Rply_buff.u.status.daq_now)) == 0) /* DAQ active */ - { - *iDaq = 1; - } - else - { - sFill = ntohs(Rply_buff.u.status.filler_mask); - if(sFill & sDaq) - { - /* filler is not running */ - *iDaq = 0; - } - else - { - /* inhibited by some mean client */ - *iDaq = 2; - } - } - *iRank = ntohs(Rply_buff.u.status.n_hists); - *iLength = ntohl(Rply_buff.u.status.num_bins); - *iBinWidth = Rply_buff.u.status.bytes_per_bin; - *iClients = Rply_buff.u.status.act_srvrs; - } - return 1; /* success, finally */ - } -/*------------------------------------------------------------------------*/ - int SINQHMDebug(pSINQHM self, int iLevel) - { - int status, iRet; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - - assert(self); - - /* fill in the request data structure */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_DBG); - Req_buff.u.dbg.mask = htonl(iLevel); - - /* try, get a connection to master server */ - status = OpenMasterConnection(self); - if(status < 0) - { - return status; - } - - /* send request */ - status = send(self->iMasterSocket,(char *)&Req_buff, sizeof(Req_buff),0); - if(status == -1) - { - return SEND_ERROR; - } - - /* get a reply */ - iRet = GetMasterReply(self,&Rply_buff,sizeof(Rply_buff)); - if(iRet < 0) - { - close(self->iMasterSocket); - self->iMasterSocket = 0; - return iRet; - } - else - { - status = close(self->iMasterSocket); - self->iMasterSocket = 0; - if((status != 0) && (errno != ECONNRESET)) - { - return CLOSE_ERROR; - } - } - return 1; /* success, finally */ - } -/*------------------------------------------------------------------------*/ - int SINQHMKill(pSINQHM self) - { - int status, iRet; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - - assert(self); - - /* fill in the request data structure */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_EXIT); - - /* try, get a connection to master server */ - status = OpenMasterConnection(self); - if(status < 0) - { - return status; - } - - /* send request */ - status = send(self->iMasterSocket,(char *)&Req_buff, sizeof(Req_buff),0); - if(status == -1) - { - return SEND_ERROR; - } - - /* get a reply */ - iRet = GetMasterReply(self,&Rply_buff,sizeof(Rply_buff)); - if(iRet < 0) - { - close(self->iMasterSocket); - self->iMasterSocket = 0; - return iRet; - } - else - { - status = close(self->iMasterSocket); - self->iMasterSocket = 0; - if((status != 0) && (errno != ECONNRESET)) - { - return CLOSE_ERROR; - } - } - return 1; /* success, finally */ - } - -/*====================== DAQ functions ==================================*/ - int SINQHMOpenDAQ(pSINQHM self) - { - int status, iRet, iPacket; - struct sockaddr_in lcl_sockname; - struct sockaddr_in rmt_sockname; - struct hostent *rmt_hostent; - struct in_addr *rmt_inet_addr_pntr; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - - assert(self); - - /* fill in the request data structure */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_CNCT); - Req_buff.u.cnct.max_pkt = htonl (8192); - Req_buff.u.cnct.strt_mode = htonl (0); - - - /* try, get a connection to master server */ - status = OpenMasterConnection(self); - if(status < 0) - { - return status; - } - - /* send request */ - status = send(self->iMasterSocket,(char *)&Req_buff, sizeof(Req_buff),0); - if(status == -1) - { - return SEND_ERROR; - } - - /* get a reply */ - iRet = GetMasterReply(self,&Rply_buff,sizeof(Rply_buff)); - status = close(self->iMasterSocket); - self->iMasterSocket = 0; - if(iRet < 0) - { - return iRet; - } - if(status != 0) - { - return CLOSE_ERROR; - } - - /* read the port and packet size to use */ - self->iClientPort = ntohl (Rply_buff.u.cnct.port); - iPacket = ntohl (Rply_buff.u.cnct.pkt_size); - self->iPacket = iPacket; - - /* now we are ready to open the connection to our very own histogram - memory slave server - */ - - /* first a socket */ - self->iClientSocket = socket (AF_INET, SOCK_STREAM, 0); - if(self->iClientSocket == -1) - { - return SOCKET_ERROR; - } - - /* now try a bind */ - lcl_sockname.sin_family = AF_INET; - lcl_sockname.sin_port = htons (0); - lcl_sockname.sin_addr.s_addr = 0; - status = bind (self->iClientSocket, (struct sockaddr *) &lcl_sockname, - sizeof (lcl_sockname)); - if (status == -1) - { - self->iClientSocket = 0; - return BIND_ERROR; - } - - /* get hostname (again). This is double work (has happened in - OpenMasterConnection before) but I decided for this in order to - avoid carrying that extra adress pointer needed for connect around. - */ - rmt_hostent = gethostbyname (self->pHMComputer); - if (rmt_hostent == NULL) { - /* this should never happen, as we got it recently in - OpenMasterConnection - */ - return HMCOMPUTER_NOT_FOUND; - } - rmt_inet_addr_pntr = (struct in_addr *) rmt_hostent->h_addr_list[0]; - - /* and connect */ - rmt_sockname.sin_family = AF_INET; - rmt_sockname.sin_port = htons (self->iClientPort); - rmt_sockname.sin_addr.s_addr = rmt_inet_addr_pntr->s_addr; - status = connect (self->iClientSocket, (struct sockaddr *) &rmt_sockname, - sizeof (rmt_sockname)); - if (status == -1) - { - self->iClientSocket = 0; - return CONNECT_ERROR; - } - - /* done! Surprise! Everything worked! */ - return 1; - } -/*------------------------------------------------------------------------*/ - int SINQHMCloseDAQ(pSINQHM self) - { - struct req_buff_struct Req_buff; - int status, iRet; - - assert(self); - if(self->iClientSocket <= 0) - { - /* already colsed */ - return 1; - } - - iRet = 1; - - /* send close message, this helps the master to clean up */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_CLOSE); - status = send (self->iClientSocket, (char *) &Req_buff, sizeof (Req_buff), 0); - if (status == -1) - { - iRet = SEND_ERROR; - } - if (status != sizeof (Req_buff)) - { - iRet = SEND_ERROR; - } - status = close (self->iClientSocket); - if (status != 0) - { - iRet = CLOSE_ERROR; - } - self->iClientSocket = 0; - self->iClientPort = 0; - return iRet; - } -/*-----------------------------------------------------------------------*/ - int SINQHMStartDAQ(pSINQHM self) - { - int status, iDaq; - - assert(self); - - status = SendDAQCommand(self,DAQ__GO,&iDaq); - if(status < 0) /* error */ - { - return status; - } - if(iDaq != 0) - { - return DAQ_INHIBIT; - } - return 1; - } -/*-----------------------------------------------------------------------*/ - int SINQHMStopDAQ(pSINQHM self) - { - int status, iDaq; - - assert(self); - - status = SendDAQCommand(self,DAQ__STOP,&iDaq); - if(status < 0) /* error */ - { - return status; - } - if(iDaq == 0) - { - return DAQ_NOTSTOPPED; - } - return 1; - } - -/*-----------------------------------------------------------------------*/ - int SINQHMContinueDAQ(pSINQHM self) - { - int status, iDaq; - - assert(self); - - status = SendDAQCommand(self,DAQ__CLR,&iDaq); - if(status < 0) /* error */ - { - return status; - } - if(iDaq != 0) - { - return DAQ_INHIBIT; - } - return 1; - } -/*-----------------------------------------------------------------------*/ - int SINQHMInhibitDAQ(pSINQHM self) - { - int status, iDaq; - - assert(self); - - status = SendDAQCommand(self,DAQ__INH,&iDaq); - if(status < 0) /* error */ - { - return status; - } - if(iDaq == 0) - { - return DAQ_NOTSTOPPED; - } - return 1; - - } -/*-----------------------------------------------------------------------*/ - int SINQHMWrite(pSINQHM self, int iNum, int iStart, int iEnd, void *pData) - { - long lBytes2Go,lBins, i; - int status, iRet; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - SQint16 *p16; - SQint32 *p32; - char *pPtr; - - assert(self); - - /* calculate number of bins */ - lBins = iEnd; - - /* take care of byte order first */ - if (0x12345678 != ntohl (0x12345678)) - { - /* Swap bytes, if necessary */ - switch (self->iBinWidth) - { - case 1: - break; - case 2: - p16 = (SQint16 *) pData; - for (i=0; i < lBins; i++) - { - p16[i] = htons (p16[i]); - } - break; - case 4: - p32 = (SQint32 *) pData; - for (i=0; i < lBins; i++) - { - p32[i] = htonl (p32[i]); - } - break; - } - } - - /* initialize the Request data */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_WRITE); - Req_buff.u.write.n_bins = htonl (lBins); - Req_buff.u.write.first_bin = htonl (iStart); - Req_buff.u.write.bytes_per_bin = htonl (self->iBinWidth); - Req_buff.u.write.hist_no = htonl (iNum); - - /* send the message */ - status = send (self->iClientSocket, (char *) &Req_buff, sizeof (Req_buff), 0); - if (status == -1) - { - return SEND_ERROR; - } - if (status != sizeof (Req_buff)) - { - return SEND_ERROR; - } - - /* send data */ - lBytes2Go = lBins * self->iBinWidth; - pPtr = (char *)pData; - while (lBytes2Go > 0) - { - i = (lBytes2Go > self->iPacket) ? self->iPacket : lBytes2Go; - status = send (self->iClientSocket, (char *) pPtr, i, 0); - if (status <= 0) - { - return SEND_ERROR; - } - lBytes2Go -= status; - pPtr += status; - } - - /* get status */ - status = recv (self->iClientSocket, (char *) &Rply_buff, - sizeof (Rply_buff), MSG_WAITALL); - - /* check various error conditions */ - if (status == -1) - { - return RECEIVE_ERROR; - } - if (status != sizeof (Rply_buff)) - { - return INSUFFICIENT_DATA; - } - if(ntohl (Rply_buff.bigend) != 0x12345678) - { - return BYTE_ORDER_CHAOS; - } - if((iRet = ntohl (Rply_buff.status)) == KER__BAD_VALUE) - { - return HIST_BAD_VALUE; - } - if(iRet != KER__SUCCESS) - { - return HIST_BAD_CODE; - } - /* success */ - return 1; - } -/*-----------------------------------------------------------------------*/ - int SINQHMRead(pSINQHM self, int iNum, int iStart, int iEnd, - void *pData, int iDataLen) - { - long lBins2Get, lSpace,iNoBins, i; - int status, iRet; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - SQint16 *p16; - SQint32 *p32; - char *pPtr; - char pBuffer[8192]; - - assert(self); - - /* initialize the Request data */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_READ); - Req_buff.u.read.n_bins = htonl (iEnd-iStart); - Req_buff.u.read.first_bin = htonl (iStart); - Req_buff.u.read.hist_no = htonl (iNum); - - /* send the message */ - status = send (self->iClientSocket, (char *) &Req_buff, - sizeof (Req_buff), 0); - if (status == -1) - { - return SEND_ERROR; - } - if (status != sizeof (Req_buff)) - { - return SEND_ERROR; - } - - /* wait for an answer */ - status = recv (self->iClientSocket, (char *) &Rply_buff, - sizeof (Rply_buff), MSG_WAITALL); - - /* check various error conditions */ - if (status == -1) - { - return RECEIVE_ERROR; - } - if (status != sizeof (Rply_buff)) - { - return INSUFFICIENT_DATA; - } - if(ntohl (Rply_buff.bigend) != 0x12345678) - { - return BYTE_ORDER_CHAOS; - } - iRet = ntohl(Rply_buff.status); - if(iRet != KER__SUCCESS) - { - return HIST_BAD_CODE; - } - - /* calculate the size of things to come */ - lBins2Get = ntohl(Rply_buff.u.read.n_bins) * ntohl(Rply_buff.u.read.bytes_per_bin); - - /* read data */ - pPtr = (char *)pData; - lSpace = iDataLen; - iNoBins = ntohl(Rply_buff.u.read.n_bins); - while (lBins2Get > 0) - { - if(lBins2Get > self->iPacket) - { - i = self->iPacket; - } - else - { - i = lBins2Get; - } - status = recv (self->iClientSocket, pBuffer, - i, 0); - if (status == -1) - { - return SEND_ERROR; - } - lBins2Get -= status; - if((lSpace - status) > 0) - { - memcpy(pPtr,pBuffer,status); - lSpace -= status; - pPtr += status; - } - else - { - if(lSpace > 0) - { - memcpy(pPtr,pBuffer,lSpace); - lSpace = 0; - } - } - } - - /* swap bytes if necessary */ - if ((self->iBinWidth > 0) && (Rply_buff.bigend != 0x12345678)) - { - switch (self->iBinWidth) - { /* Byte swapping is necessary */ - case 2: - /* Not sure how to do this - this might be wrong! */ - p16 = (SQint16 *) pData; - for (i = 0; i < iNoBins; i++) - { - p16[i] = ntohs (p16[i]); - } - break; - case 4: - p32 = (SQint32 *) pData; - for (i = 0; i < iNoBins; i++) - { - p32[i] = ntohl(p32[i]); - } - break; - } - } - /* done */ - return 1; - } -/*-----------------------------------------------------------------------*/ - int SINQHMProject(pSINQHM self, int code, int xStart, int nx, - int yStart, int ny, - void *pData, int iDataLen) - { - long lBins2Get, lSpace,iNoBins, i; - int status, iRet; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - SQint16 *p16; - SQint32 *p32; - char *pPtr; - char pBuffer[8192]; - - assert(self); - - /* initialize the Request data */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_PROJECT); - Req_buff.u.project.sub_code = htonl (code); - - Req_buff.u.project.x_lo = htonl (xStart); - Req_buff.u.project.nx = htonl (nx); - Req_buff.u.project.y_lo = htonl (yStart); - Req_buff.u.project.ny = htonl (ny); - Req_buff.u.project.nhist = htonl (1); - - /* send the message */ - status = send (self->iClientSocket, (char *) &Req_buff, - sizeof (Req_buff), 0); - if (status == -1) - { - return SEND_ERROR; - } - if (status != sizeof (Req_buff)) - { - return SEND_ERROR; - } - - /* wait for an answer */ - status = recv (self->iClientSocket, (char *) &Rply_buff, - sizeof (Rply_buff), MSG_WAITALL); - - /* check various error conditions */ - if (status == -1) - { - return RECEIVE_ERROR; - } - if (status != sizeof (Rply_buff)) - { - return INSUFFICIENT_DATA; - } - if(ntohl (Rply_buff.bigend) != 0x12345678) - { - return BYTE_ORDER_CHAOS; - } - iRet = ntohl(Rply_buff.status); - if(iRet != KER__SUCCESS) - { - return HIST_BAD_CODE; - } - - /* calculate the size of things to come */ - lBins2Get = ntohl(Rply_buff.u.project.n_bins) * - ntohl(Rply_buff.u.project.bytes_per_bin); - - /* read data */ - pPtr = (char *)pData; - lSpace = iDataLen; - iNoBins = ntohl(Rply_buff.u.project.n_bins); - while (lBins2Get > 0) - { - if(lBins2Get > self->iPacket) - { - i = self->iPacket; - } - else - { - i = lBins2Get; - } - status = recv (self->iClientSocket, pBuffer, - i, 0); - if (status == -1) - { - return SEND_ERROR; - } - lBins2Get -= status; - if((lSpace - status) > 0) - { - memcpy(pPtr,pBuffer,status); - lSpace -= status; - pPtr += status; - } - else - { - if(lSpace > 0) - { - memcpy(pPtr,pBuffer,lSpace); - lSpace = 0; - } - } - } - - /* swap bytes if necessary */ - iNoBins = iDataLen/self->iBinWidth; - if ((self->iBinWidth > 0) && (Rply_buff.bigend != 0x12345678)) - { - switch (self->iBinWidth) - { /* Byte swapping is necessary */ - case 2: - /* Not sure how to do this - this might be wrong! */ - p16 = (SQint16 *) pData; - for (i = 0; i < iNoBins; i++) - { - p16[i] = ntohs (p16[i]); - } - break; - case 4: - p32 = (SQint32 *) pData; - for (i = 0; i < iNoBins; i++) - { - p32[i] = ntohl(p32[i]); - } - break; - } - } - /* done */ - return 1; - } -/*------------------------------------------------------------------------ - This is the old version, using a master socjet, delete if the other version - with client socket works alright. -*/ - int SINQHMZero2(pSINQHM self, int iNumber, int iStart, int iEnd) - { - int status, iRet; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - - assert(self); - - /* fill in the request data structure */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_ZERO); - Req_buff.u.zero.hist_no = htonl (iNumber); - Req_buff.u.zero.first_bin = htonl (iStart); - Req_buff.u.zero.n_bins = htonl (iEnd); - - /* try, get a connection to master server */ - status = OpenMasterConnection(self); - if(status < 0) - { - return status; - } - - /* send request */ - status = send(self->iMasterSocket,(char *)&Req_buff, sizeof(Req_buff),0); - if(status == -1) - { - return SEND_ERROR; - } - - /* get a reply */ - iRet = GetMasterReply(self,&Rply_buff,sizeof(Rply_buff)); - if(iRet < 0) - { - close(self->iMasterSocket); - self->iMasterSocket = 0; - return iRet; - } - else - { - status = close(self->iMasterSocket); - self->iMasterSocket = 0; - if((status != 0) && (errno != ECONNRESET)) - { - return CLOSE_ERROR; - } - } - return 1; /* success, finally */ - } -/*-----------------------------------------------------------------------*/ - int SINQHMZero(pSINQHM self, int iNumber, int iStart, int iEnd) - { - int status, iRet; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - - assert(self); - - /* fill in the request data structure */ - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_ZERO); - Req_buff.u.zero.hist_no = htonl (iNumber); - Req_buff.u.zero.first_bin = htonl (iStart); - Req_buff.u.zero.n_bins = htonl (iEnd); - - /* send request */ - status = send(self->iClientSocket,(char *)&Req_buff, sizeof(Req_buff),0); - if(status == -1) - { - return SEND_ERROR; - } - if(status != sizeof(Req_buff)) - { - return SEND_ERROR; - } - - /* get a reply */ - iRet = recv(self->iClientSocket,(char *)&Rply_buff,sizeof(Rply_buff), - MSG_WAITALL); - if(iRet < 0) - { - return RECEIVE_ERROR; - } - if(iRet != sizeof(Rply_buff)) - { - return INSUFFICIENT_DATA; - } - if(ntohl (Rply_buff.bigend) != 0x12345678) - { - return BYTE_ORDER_CHAOS; - } - iRet = ntohl(Rply_buff.status); - if(iRet != KER__SUCCESS) - { - return HIST_BAD_CODE; - } - return 1; /* success, finally */ - } - -/*------------------------------------------------------------------------*/ - static int OpenMasterConnection(pSINQHM self) - { - struct hostent *rmt_hostent; - struct sockaddr_in lcl_sockname; - int rmt_sockname_len; - struct sockaddr_in rmt_sockname; - struct in_addr *rmt_inet_addr_pntr; - int status; - - - /* get hostname */ - rmt_hostent = gethostbyname (self->pHMComputer); - if (rmt_hostent == NULL) { - return HMCOMPUTER_NOT_FOUND; - } - rmt_inet_addr_pntr = (struct in_addr *) rmt_hostent->h_addr_list[0]; - - - /* try, open socket */ - self->iMasterSocket = socket (AF_INET, SOCK_STREAM, 0); - if (self->iMasterSocket == -1) - { - return SOCKET_ERROR; - } - - /* bind it */ - lcl_sockname.sin_family = AF_INET; - lcl_sockname.sin_port = htons(0); - lcl_sockname.sin_addr.s_addr = 0; - status = bind (self->iMasterSocket, (struct sockaddr *) &lcl_sockname, - sizeof (lcl_sockname)); - if (status == -1) - { - return BIND_ERROR; - } - - /* try to connect */ - rmt_sockname_len = sizeof (rmt_sockname); - rmt_sockname.sin_family = AF_INET; - rmt_sockname.sin_port = htons (self->iMasterPort); - rmt_sockname.sin_addr.s_addr = rmt_inet_addr_pntr->s_addr; - status = connect (self->iMasterSocket, (struct sockaddr *) &rmt_sockname, - sizeof (rmt_sockname)); - if (status == -1) { - return CONNECT_ERROR; - } - - /* Success */ - return 1; - } -/*------------------------------------------------------------------------*/ - static int GetMasterReply(pSINQHM self, struct rply_buff_struct *reply, - int iBufLen) - { - - int status; - - assert(self->iMasterSocket); - - /* get reply structure */ - status = recv (self->iMasterSocket, (char *) reply, - iBufLen, MSG_WAITALL); - if (status == -1) { - return RECEIVE_ERROR; - } else if (status != iBufLen) { - return INSUFFICIENT_DATA; - } - - /* check endedness */ - if (ntohl (reply->bigend) != 0x12345678) { - return BYTE_ORDER_CHAOS; - } - - /* check histogram memory status codes */ - status = ntohl (reply->status); - if (status == KER__SUCCESS) { - return 1; - }else if (status == KER__BAD_CREATE) { - return HIST_BAD_CREATE; - }else if (status == KER__BAD_STATE) { - return HIST_BAD_STATE; - }else if (status == KER__BAD_VALUE) { - return HIST_BAD_VALUE; - }else if (status == KER__BAD_RECV) { - return HIST_BAD_RECV; - }else if (status == KER__BAD_ALLOC) { - return HIST_BAD_ALLOC; - }else { - return HIST_BAD_CODE; - } - /* not reached, usually */ - return HIST_BAD_CODE; - } -/*-------------------------------------------------------------------------*/ - int SINQHMError2Text(int iErr, char *pBuffer, int iBufLen) - { - /* the trivial case */ - if(iErr > 0) - { - strncpy(pBuffer,"No error ocurred",iBufLen); - return 0; - } - - switch(iErr) - { - case HMCOMPUTER_NOT_FOUND: - strncpy(pBuffer, - "No name server entry for histogram memory computer", - iBufLen); - break; - case SOCKET_ERROR: - strncpy(pBuffer, - "Insufficient system resources for socket creation", - iBufLen); - break; - case BIND_ERROR: - strncpy(pBuffer, - "Cannot bind", - iBufLen); - break; - case CONNECT_ERROR: - strncpy(pBuffer, - "Cannot connect, probably port number wrong", - iBufLen); - break; - case RECEIVE_ERROR: - strncpy(pBuffer, - "Error receiving data", iBufLen); - break; - case INSUFFICIENT_DATA: - strncpy(pBuffer, - "Not enough bytes received from host, network trouble", - iBufLen); - break; - case BYTE_ORDER_CHAOS: - strncpy(pBuffer, - "Reply not in network byte order", - iBufLen); - break; - case HIST_BAD_CREATE: - strncpy(pBuffer, - "Master histogram server failed to spawn child", - iBufLen); - break; - case HIST_BAD_VALUE: - strncpy(pBuffer, - "Invalid parameter detected", - iBufLen); - break; - case HIST_BAD_STATE: - strncpy(pBuffer, - "Histogram memory NOT configured", - iBufLen); - break; - case HIST_BAD_RECV: - strncpy(pBuffer, - "Histogram server failed to read command", - iBufLen); - break; - case HIST_BAD_ALLOC: - strncpy(pBuffer, - "Histogram memory out of memory!", - iBufLen); - break; - case HIST_BAD_CODE: - strncpy(pBuffer, - "Unknown or corrupted status code sent from master server", - iBufLen); - break; - case SEND_ERROR: - strncpy(pBuffer, - "Error sending data", - iBufLen); - break; - case CLOSE_ERROR: - strncpy(pBuffer, - "Error closing connection", - iBufLen); - break; - case INVALID_HARSH: - strncpy(pBuffer, - "Invalid parameter for harshness", - iBufLen); - break; - case SOFTWARE_ERROR: - strncpy(pBuffer, - "Internal error or software error at histogram memory computer, consult a hacker", - iBufLen); - break; - case DAQ_INHIBIT: - strncpy(pBuffer, - "Data aquisition inhibited by some client", - iBufLen); - break; - case DAQ_NOTSTOPPED: - strncpy(pBuffer, - "Data aquisition not stopped, suggests SW or network problem", - iBufLen); - break; - - default: - strncpy(pBuffer, - "Unknown error code",iBufLen); - } - return 1; - } -/*------------------------------------------------------------------------- - SINQHM needs an additional top bin defining the upper edge of the - histogram. So, for a 512 bin array, 513 bins are needed. The additional - bin is created in the code below. This explains the strange arithmetic with - EdgeLength and the code at the end of the for loop -*/ - int SINQHMDefineBank(pSINQHM self, int iBankNumber, int iStart, int iEnd, - float *iEdges, int iEdgeLength) - { - pSBank pWork = NULL; - int i, iDelay, iDiff; - - assert(self); - assert(iBankNumber >= 0); - assert(iBankNumber < MAXBANK); - assert(iEdgeLength >= 1); - assert(iStart >= 0); - assert(iEnd >= iStart); - - if(iBankNumber >= self->iBanks) - { - self->iBanks = iBankNumber +1; - } - pWork = &(self->pBank[iBankNumber]); - if(pWork->iEdges != NULL) - { - free(pWork->iEdges); - pWork->iEdges = NULL; - } - iDelay = (int)iEdges[0]; - pWork->iStart = iStart; - pWork->iEnd = iEnd; - pWork->iEdgeLength = iEdgeLength; - if(iEdgeLength == 2) - { /* - fixed binwidth: two values required: start stop in - edge[0], edge[1] - */ - pWork->iFlag = 0; - pWork->iDelay = iDelay; - pWork->iEdges = (unsigned int *)malloc(2*sizeof(unsigned int)); - if(!pWork->iEdges) - { - return HIST_BAD_ALLOC; - } - pWork->iEdges[0] = htonl((unsigned int)iEdges[0]); - pWork->iEdges[1] = htonl((unsigned int)(iEdges[1] - iDelay)); - return 1; - } - - /* - normal case: create the bin boundaries - */ - pWork->iFlag = 1; - pWork->iEdgeLength++; - iEdgeLength++; - pWork->iEdges = (unsigned int *)malloc(iEdgeLength * - sizeof(unsigned int)); - if(!pWork->iEdges) - { - return HIST_BAD_ALLOC; - } - pWork->iDelay = iDelay; - for(i = 0; i < iEdgeLength-1; i++) - { - pWork->iEdges[i] = htonl((unsigned int)(iEdges[i]-iDelay)); - } - iDiff = iEdges[1] - iEdges[0]; - pWork->iEdges[iEdgeLength-1] = htonl(iEdges[iEdgeLength-2] - + iDiff - iDelay); - return 1; - } -/*-----------------------------------------------------------------------*/ - struct tof { - uint n_extra_bytes; - usint n_edges; - usint n_banks; - uint preset_delay; - struct tof_edge_arr edge_0; - struct tof_bank bank_0; - }; - -/*------------------------------------------------------------------------*/ - int SINQHMTimeBin(pSINQHM self,int iMode) - { - int status, iRet; - struct req_buff_struct Req_buff; - struct rply_buff_struct Rply_buff; - int iLength, i, iDelay; - unsigned int iExtra; - char *pBuffer = NULL, *pPtr; - struct tof_edge_arr tea; - int iTeaLength; - struct tof_bank toba; - struct tof tofi; - - assert(self); - - /* figure out how long we are going to be*/ - iLength = 24 + self->iBanks*sizeof(struct tof_bank); - for(i = 0; i < self->iBanks; i++) - { - iLength += 8 + self->pBank[i].iEdgeLength*sizeof(SQint32); - } - if(iLength < 64) - iLength = 64; - /* allocate send buffer */ - pBuffer = (char *)malloc(iLength*sizeof(char)); - if(!pBuffer) - { - return HIST_BAD_ALLOC; - } - memset(pBuffer,0,iLength); - - /* do the message header */ - iExtra = iLength - 64; - if(iExtra < 0) - iExtra = 0; - iDelay = self->pBank[0].iEdges[0]; - Req_buff.bigend = htonl (0x12345678); - Req_buff.cmnd = htonl (SQHM_CONFIG); - Req_buff.u.cnfg.mode = htonl (iMode); - memcpy(pBuffer,&Req_buff,12); - pPtr = pBuffer + 12; - - tofi.n_extra_bytes = htonl(iExtra); - tofi.n_edges = htons(self->iBanks); - tofi.n_banks = htons(self->iBanks); - tofi.preset_delay = htonl(self->pBank[0].iDelay); - memcpy(pPtr,&tofi,12); - pPtr += 12; - - /* do the edge thingies */ - for(i = 0; i < self->iBanks; i++) - { - tea.n_bins = htonl(self->pBank[i].iEdgeLength-1); - if(self->pBank[i].iEdgeLength == 2) - { - tea.flag = htonl(0); - } - else - { - tea.flag = htonl(1); - } - tea.edges = self->pBank[i].iEdges; - memcpy(pPtr,&tea,8); - pPtr += 8; - iTeaLength = self->pBank[i].iEdgeLength*4; - memcpy(pPtr,self->pBank[i].iEdges,iTeaLength); - pPtr += iTeaLength; - } - - /* do the swiss bank structures */ - for(i = 0; i < self->iBanks; i++) - { - toba.first = htons(self->pBank[i].iStart); - toba.n_cntrs = htons(self->pBank[i].iEnd); - toba.edge_indx = htons(i); - toba.bytes_per_bin = htons(self->iBinWidth); - memcpy(pPtr,&toba,sizeof(struct tof_bank)); - pPtr += sizeof(struct tof_bank); - } - - /* all packed up neat and nicely, send it */ - /* try, get a connection to master server */ - status = OpenMasterConnection(self); - if(status < 0) - { - if(pBuffer) - free(pBuffer); - return status; - } - - /* send request */ - status = send(self->iMasterSocket,pBuffer,iLength ,0); - if(pBuffer) - { - free(pBuffer); - } - if(status == -1) - { - return SEND_ERROR; - } - - /* get a reply */ - iRet = GetMasterReply(self,&Rply_buff,sizeof(Rply_buff)); - if(iRet < 0) - { - /* try close the socket */ - close(self->iMasterSocket); - self->iMasterSocket = 0; - return iRet; - } - else - { - /* close the socket */ - status = close(self->iMasterSocket); - self->iMasterSocket = 0; - if((status != 0) && (errno != ECONNRESET)) - { - return CLOSE_ERROR; - } - } - return 1; /* success, finally */ - } diff --git a/hardsup/sinqhm.h b/hardsup/sinqhm.h deleted file mode 100644 index ad692a16..00000000 --- a/hardsup/sinqhm.h +++ /dev/null @@ -1,107 +0,0 @@ - -#line 363 "sinqhm.w" - -/*--------------------------------------------------------------------------- - S I N Q H M - Some utility functions for interfacing to the SINQ histogram memory - server. - - David Maden, Mark Koennecke, April 1997 - - copyright: see implementation file. ------------------------------------------------------------------------------*/ -#ifndef SINQHMUTILITY -#define SINQHMUTILITY -#include "sinqhm_def.h" - - typedef struct __SINQHM *pSINQHM; -/*------------------------------ Error codes -----------------------------*/ - -#line 341 "sinqhm.w" - -#define HMCOMPUTER_NOT_FOUND -2 -#define SOCKET_ERROR -3 -#define BIND_ERROR -4 -#define CONNECT_ERROR -5 -#define RECEIVE_ERROR -6 -#define INSUFFICIENT_DATA -7 -#define BYTE_ORDER_CHAOS -8 -#define HIST_BAD_CREATE -9 -#define HIST_BAD_STATE -10 -#define HIST_BAD_VALUE -11 -#define HIST_BAD_RECV -12 -#define HIST_BAD_ALLOC -13 -#define HIST_BAD_CODE -14 -#define SEND_ERROR -15 -#define CLOSE_ERROR -16 -#define INVALID_HARSH -17 -#define SOFTWARE_ERROR -18 -#define DAQ_INHIBIT -19 -#define DAQ_NOTSTOPPED -20 - -#line 379 "sinqhm.w" - - -/*------------------------------ Prototypes ------------------------------*/ - -#line 118 "sinqhm.w" - - pSINQHM CreateSINQHM(char *pHMComputer, int iMasterPort); - pSINQHM CopySINQHM(pSINQHM self); - void DeleteSINQHM(pSINQHM self); - void SINQHMSetPar(pSINQHM self, int iRank, int iLength, int iBinWidth); - void SINQHMSetPSD(pSINQHM self, int xSize, int xOff, int xFac, - int ySize, int yOff, int yFac); - -#line 142 "sinqhm.w" - - int SINQHMError2Text(int iErr, char *pBuffer, int iBufLen); - -#line 155 "sinqhm.w" - - int SINQHMConfigure(pSINQHM self, int iMode, int iRank, int iLength, - int iBinWidth, int iLowBin, int iCompress); - int SINQHMConfigurePSD(pSINQHM self, int iMode, - int xSize, int xOff, int xFac, - int ySize, int yOff, int yFac, - int iBinWidth, - float *iEdges, int iEdgeLength); - - int SINQHMDeconfigure(pSINQHM self, int iHarsh); - int SINQHMGetStatus(pSINQHM self,int *iMode, int *iDaq, - int *iRank, int *iBinWidth, - int *iLength, int *iClients); - int SINQHMDebug(pSINQHM self, int iLevel); - int SINQHMKill(pSINQHM self); - - -#line 261 "sinqhm.w" - - int SINQHMOpenDAQ(pSINQHM self); - int SINQHMCloseDAQ(pSINQHM self); - - int SINQHMStartDAQ(pSINQHM self); - int SINQHMStopDAQ(pSINQHM self); - int SINQHMInhibitDAQ(pSINQHM self); - int SINQHMContinueDAQ(pSINQHM self); - - int SINQHMWrite(pSINQHM self, int iNum, int iStart, int iEnd, - void *pData); - long SINQHMSize(pSINQHM self, int iNum, int iStart, int iEnd); - int SINQHMRead(pSINQHM self, int iNum, int iStart, int iEnd, - void *pData, int iDataLen); - int SINQHMProject(pSINQHM self, int code, int xStart, int nx, - int yStart, int ny, void *pData, int iDataLen); - int SINQHMZero(pSINQHM self, int iNum, int iStart, int iEnd); - -#line 382 "sinqhm.w" - - -#line 232 "sinqhm.w" - - int SINQHMDefineBank(pSINQHM self, int iBankNumber, int iStart, int iEnd, - float *iEdges, int iEdgeLength); - -#line 383 "sinqhm.w" - -#endif diff --git a/hardsup/sinqhm.i b/hardsup/sinqhm.i deleted file mode 100644 index 785f1d73..00000000 --- a/hardsup/sinqhm.i +++ /dev/null @@ -1,54 +0,0 @@ - -/*--------------------------------------------------------------------------- - - Internal header file for the SINQ histogram memory utility functions. - - David Maden, Mark Koennecke April 1997 -----------------------------------------------------------------------------*/ -#ifndef SINQHMINTERNAL -#define SINQHMINTERNAL -#define MAXBANK 1 - - typedef struct __SBANK { - int iStart; - int iEnd; - int iFlag; - int iEdgeLength; - int iDelay; - unsigned int *iEdges; - } SBank, *pSBank; - - - typedef struct __SINQHM { - char *pHMComputer; - int iMasterPort; - int iMasterSocket; - int iClientPort; - int iClientSocket; - int iBinWidth; - int iLength; - int iRank; - int iPacket; - int iBanks; - int xSize, ySize; - int xOff, xFac; - int yOff, yFac; - SBank pBank[MAXBANK]; - } SINQHM; - -/*---------------------------- Type definitions, machine dependent--------*/ - typedef short int SQint16; /* 16 bit integer */ - typedef int SQint32; /* 32 bit integer */ - - - - static int OpenMasterConnection(pSINQHM self); - static int GetMasterReply(pSINQHM self, struct rply_buff_struct *reply, - int iBufLen); - static int SendDAQCommand(pSINQHM self, int iCommand, int *iDaq); - - - static int SINQHMTimeBin(pSINQHM self, int iMode); - -#endif - diff --git a/hardsup/sinqhm.tex b/hardsup/sinqhm.tex deleted file mode 100644 index f0a95d54..00000000 --- a/hardsup/sinqhm.tex +++ /dev/null @@ -1,618 +0,0 @@ -\documentstyle{report} - -\setlength{\oddsidemargin}{0in} -\setlength{\evensidemargin}{0in} -\setlength{\topmargin}{0in} -\addtolength{\topmargin}{-\headheight} -\addtolength{\topmargin}{-\headsep} -\setlength{\textheight}{8.9in} -\setlength{\textwidth}{6.5in} -\setlength{\marginparwidth}{0.5in} - -\title{SINQHM-Utility\\ Utility functions for the \\ - SINQ Histogram memory} -\author{David Maden, Mark K\"onnecke, April 1997} - -\begin{document} -\maketitle -\clearpage - -\chapter{Introduction} -This file describes some Utility functions for interfacing with the SinQ -histogram memory server. This device is described in great detail elsewhere -(D. Maden: The SINQ Histogram Memory, Feb. 1997). -All the real time processing -for this HM is done by an on-board computer in a VME crate. This on board -computer also runs TCP/IP and a server program which allows for -configuration and communication with the HM. -For configuration an -connection to the main server is installed which handles the configuration -requests. For starting data collection and retrieval of information a second -connection is needed. This is obtained by sending a request to the main -server on the on board computer. This main server will than spawn a second -process on the on board computer which is dedicated to serving our requests. -The mainserver sends a packet containing the new port number our secondary -server is listening to. Than the driver can connect to this secondary server -in order to exchange data. According to this scheme the utility functions -divide into two groups: Master Server commands and data aquisition commands. - -\section{Code organisation} -The code dealing with the SINQ histogram memory is organised in four -files: sinqhm.w, the literate programming file which creates sinqhm.i and -sinqhm.h as well as the LateX documentation for the interface, sinqhm.i is -an internal header file and contains typedefs and function definitions for -relevant for the implementation of the utility functions only. sinqhm.h -defines the public interface functions. sinqhm.c finally is the source file -which implements the utilities. - -\section{The SINQHM data structure} -In order to transport the necessary status information around, each function -will take a pointer to the data structure defined below as first parameter. -For TOF mode it is necessary to store some imformation per detector bank. -This information is kept in a bank data structure: - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap1} -$\langle$SBank {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ typedef struct __SBANK {@\\ -\mbox{}\verb@ int iStart;@\\ -\mbox{}\verb@ int iEnd;@\\ -\mbox{}\verb@ int iFlag;@\\ -\mbox{}\verb@ int iEdgeLength;@\\ -\mbox{}\verb@ int iDelay;@\\ -\mbox{}\verb@ unsigned int *iEdges;@\\ -\mbox{}\verb@ } SBank, *pSBank;@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -The fields are: -\begin{description} -\item[iStart] The number of the detector with which this bank starts. -\item[iEnd] The number of the last detector for this bank. -\item[iFlag] A flag which indicates if the bank has a fixed bin widths. 0 -denotes fixed bin width, 1 variable time binning. -\item[iEdgeLength] is the length of the edge array. -\item[iEdges] is an array of integer values describing the lower edges of -the bins. Its content depends on the value of iFlag. With a equally spaced -time binning (iFlag = 0) is is sufficient to give values for the first two -bins. If the time binning varies, nBins+1 values are necessary describing -the lower edges of all time bins. -\end{description} - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap2} -$\langle$SType {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ typedef struct __SINQHM {@\\ -\mbox{}\verb@ char *pHMComputer;@\\ -\mbox{}\verb@ int iMasterPort;@\\ -\mbox{}\verb@ int iMasterSocket;@\\ -\mbox{}\verb@ int iClientPort;@\\ -\mbox{}\verb@ int iClientSocket;@\\ -\mbox{}\verb@ int iBinWidth;@\\ -\mbox{}\verb@ int iLength;@\\ -\mbox{}\verb@ int iRank;@\\ -\mbox{}\verb@ int iPacket;@\\ -\mbox{}\verb@ int iBanks;@\\ -\mbox{}\verb@ int xSize, ySize;@\\ -\mbox{}\verb@ int xOff, xFac;@\\ -\mbox{}\verb@ int yOff, yFac;@\\ -\mbox{}\verb@ SBank pBank[MAXBANK];@\\ -\mbox{}\verb@ } SINQHM;@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro defined by scraps ?, ?. -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -The first item in this structure is the name of the histogram memory -computer, the second the port number at which the master server is -listening. iClientPort defines a port for data communication. If no such -port is open, this value will be 0. iStatus is a status flag. iBanks is the -number of detector banks defined. pSBank is an array of bank data structures -describing the detector banks. -xOff, xFac and yOff and yFac are the offset and factor values needed for -the PSD calculation for TRICS and AMOR. In order to -maintain this data structure two functions are defined: - -\section{Byte swapping} -These utility functions preform byte swapping as needed. In order for this -to work please make sure that the following typedefs represent the correct -types for your compiler and computer. - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap3} -$\langle$SType {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@/*---------------------------- Type definitions, machine dependent--------*/@\\ -\mbox{}\verb@ typedef short int SQint16; /* 16 bit integer */@\\ -\mbox{}\verb@ typedef int SQint32; /* 32 bit integer */@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro defined by scraps ?, ?. -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap4} -$\langle$Protos {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ pSINQHM CreateSINQHM(char *pHMComputer, int iMasterPort);@\\ -\mbox{}\verb@ pSINQHM CopySINQHM(pSINQHM self);@\\ -\mbox{}\verb@ void DeleteSINQHM(pSINQHM self); @\\ -\mbox{}\verb@ void SINQHMSetPar(pSINQHM self, int iRank, int iLength, int iBinWidth);@\\ -\mbox{}\verb@ void SINQHMSetPSD(pSINQHM self, int xSize, int xOff, int xFac,@\\ -\mbox{}\verb@ int ySize, int yOff, int yFac);@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro defined by scraps ?, ?, ?, ?. -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -The first function creates a new SINQHM data structure and initialises the -fields with the parameters given. Their meanings correspond to those -mentioned above for the description of the data structure. DeleteSINQHM -frees all memory associated with a SINQHM structure given by self. The -pointer to self is invalid ever afterwards. -CopySINQHM creates a copy of the SINQHM structure passed in with self. -SINQHMSetPar sets time of flight parameters. -SINQHMSetPSD defines PSD parameters for TRICS/AMOR type detectors. - -\section{SINQHM error handling} -If not denoted otherwise all public SINQHM functions return an integer 1 on -success. In the more common case of failure, a negative error code is -returned. This error code can be transformed into a human readable form by a -call to: - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap5} -$\langle$Protos {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ int SINQHMError2Text(int iErr, char *pBuffer, int iBufLen);@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro defined by scraps ?, ?, ?, ?. -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -This function takes as first parameter the error code, as second a pointer -to a text buffer for the error message and as third parameter the length of -the buffer. Maximum iBufLen characters will be copied to pBuffer. - -\section{Master Server command functions} -These functions mainly serve to configure the histogram memory and to obtain -socket-id's for client data aquisition servers. The following functions are -needed: - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap6} -$\langle$Protos {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ int SINQHMConfigure(pSINQHM self, int iMode, int iRank, int iLength, @\\ -\mbox{}\verb@ int iBinWidth, int iLowBin, int iCompress);@\\ -\mbox{}\verb@ int SINQHMConfigurePSD(pSINQHM self, int iMode,@\\ -\mbox{}\verb@ int xSize, int xOff, int xFac,@\\ -\mbox{}\verb@ int ySize, int yOff, int yFac,@\\ -\mbox{}\verb@ int iBinWidth, @\\ -\mbox{}\verb@ float *iEdges, int iEdgeLength);@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ int SINQHMDeconfigure(pSINQHM self, int iHarsh);@\\ -\mbox{}\verb@ int SINQHMGetStatus(pSINQHM self,int *iMode, int *iDaq,@\\ -\mbox{}\verb@ int *iRank, int *iBinWidth,@\\ -\mbox{}\verb@ int *iLength, int *iClients);@\\ -\mbox{}\verb@ int SINQHMDebug(pSINQHM self, int iLevel);@\\ -\mbox{}\verb@ int SINQHMKill(pSINQHM self);@\\ -\mbox{}\verb@ @\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro defined by scraps ?, ?, ?, ?. -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap7} -$\langle$IProtos {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro defined by scraps ?, ?. -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -SINQHMConfigure configures the master server for data aquisition. Besides -the pointer to a SINQHM structure it takes the following parameters: - iMode is the combination of mode and submode bits as defined in -sinqhm_defs.h. iLength is the length of -the histograms. iBinWidth is the size of the histogram memory bins in bytes. -Currently the values 1,2 and 4 are allowed. iClients is the number of active -clients at the histogram memory computer. iRank is the number of histograms. -iLowBin is the start of the histogram memory. Usually this is 0, but someone -may choose to strat at a different memory location. iCompress is for -compression. All data will be right shifted by iCompress bits before -storage. To my knowledge this feature is currently not implemented. - -SINQHMConfigurePSD configures a TRICS/AMOR type detector. The parameters are: -\begin{description} -\item[self] The histogram memory data structure. -\item[iMode] The actual histogram mode with all submask bits. -\item[xSize] The x size of the detector. -\item[xOff] The offset in x for the detector position decoding. -\item[xFac] The factor used in decoding the x detector position. -\item[ySize] The y size of the detector. -\item[yOff] The offset in y for the detector position decoding. -\item[yFac] The factor used in decoding the y detector position. -\item[iBinWidth] The binwidth of the histograms. -\item[iEdges] An array holding the time binning edges. -\item[iEdgeLength] The length of iEdges. -\end{description} - -SINQHMDeconfigure deconfigures the histogram memory. This is necessary prior -to reconfiguration. The only parameter iHarsh defines how brutal the master -server is with this. There may still be clients active at the histogram -memory. If iHarsh is 0, SINQHMDeconfig returns an error in this case. If -iHarsh is 1, the clients will be killed and the master server returns to a -virgin state. - -SINQHMGetStatus allows to query the state of the master server. Parameters -have the same meaning as given with SINQHMConfigure. Except of course -iClients which is the number of currently active clients at the histogram -memory. iDaq show the status of data aquisition: 0 denotes stopped, 1 -denotes running and 2 denotes inhibited. - -SINQHMDebug sets the debug level of the histogram memory server. That server -may print messages to its Com 1 port. This command configures the amount of -information available at this channel. This function is of no use for normal -users. - -SINQHMKill stops the histogram memory master server and all its children. -WARNING: After this call a manual restart of the histogram memory master -server or a reboot of the histogram memory computer has to be performed. -Do not use this function unless you are a SINQ histogram memory guru. - -\section{TOF bin description functions} -Configuring the TOF binning of the histogram memory requires two steps. In -the first step you define the binning of all required banks. Then in a -second step, this data is packed up and forwarded to the histogram memory. -Thus the following functions are required: - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap8} -$\langle$TOFProto {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ int SINQHMDefineBank(pSINQHM self, int iBankNumber, int iStart, int iEnd,@\\ -\mbox{}\verb@ float *iEdges, int iEdgeLength);@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap9} -$\langle$TOFintern {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ static int SINQHMTimeBin(pSINQHM self, int iMode);@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -SINQHDefineBank defines the time binning for a single detector bank. -iBankNumber defines the number of the detector bank to define. iStart and -iEnd select the range of detectors beloning to this detector bank. iEdges -is the array of time binnings. iEdgeLength is the length of the edges array. - -SINQHMTimeBin actually sends the new time binning to the histogram memory. -SINQHMTimeBin is a static internal function. - - - -\section{Data aquisition functions} -These functions allow to do data aquisition and retrieve or set histograms. -Data aquisition is fairly involved. In order for data aquisition to happen -the histogram memory internal filler process must be running. This is -controlled by the StartDAQ/StopDAQ pair. However, any client can inhibit -data processing. This feature is targeted towards clients monitoring -environment devices. Such clients thus can pause data aquisition in order to -allow environment variables to get in the defined range again. This is -controlled by the InhibitDAQ/ContinueDAQ pair of functions. Please note, -that after starting a new data aquisition session the inhibit flag is -cleared by default. - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap10} -$\langle$Protos {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ int SINQHMOpenDAQ(pSINQHM self);@\\ -\mbox{}\verb@ int SINQHMCloseDAQ(pSINQHM self);@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ int SINQHMStartDAQ(pSINQHM self);@\\ -\mbox{}\verb@ int SINQHMStopDAQ(pSINQHM self);@\\ -\mbox{}\verb@ int SINQHMInhibitDAQ(pSINQHM self);@\\ -\mbox{}\verb@ int SINQHMContinueDAQ(pSINQHM self);@\\ -\mbox{}\verb@ @\\ -\mbox{}\verb@ int SINQHMWrite(pSINQHM self, int iNum, int iStart, int iEnd, @\\ -\mbox{}\verb@ void *pData);@\\ -\mbox{}\verb@ long SINQHMSize(pSINQHM self, int iNum, int iStart, int iEnd);@\\ -\mbox{}\verb@ int SINQHMRead(pSINQHM self, int iNum, int iStart, int iEnd, @\\ -\mbox{}\verb@ void *pData, int iDataLen); @\\ -\mbox{}\verb@ int SINQHMProject(pSINQHM self, int code, int xStart, int nx,@\\ -\mbox{}\verb@ int yStart, int ny, void *pData, int iDataLen);@\\ -\mbox{}\verb@ int SINQHMZero(pSINQHM self, int iNum, int iStart, int iEnd);@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro defined by scraps ?, ?, ?, ?. -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -SINQHMOpenDAQ must be the first call and will create the slave server in the -histogram memory server which is than responsible for answereing our further -requests. Without this call any other call will return an error! - -SINQHMCloseDAQ closes a data aquisition session. - -SINQHMStartDAQ starts data aquisition. - -SINQHMInhibitDAQ causes data aquisition to pause. - -SINQHMContinueDAQ causes a paused data aquisition to continue. - -SINQHMStopDAQ stops data aquisition. - -SINQHMWrite is used to initialise the histograms in the histogram memory to -a specific value. The histogram to write is selected by iNum. If iNum is -1 -the whole histogram memory area is written. iStart and iEnd define a subset -of the histogram to write. pData is a pointer to a data area which is going -to be copied to the histogram memory. - -SINQHMSize returns the necessary size in bytes for a buffer large enough to -hold all the data requested with the following read parameters. - -SINQHMRead reads histograms. The parameters iNum, iStart and iEnd have the -same meaning as with SINQHMWrite. Maximum iDataLen bytes of data are copied -to the memory area pointed to by pData. - -SINQHMProject requests a projection of the data from the histogram memory. This - is currently only implemented for AMOR because histograms can get so large - at this instrument that a transfer for processing would take to long. The - parameters are: -\begin{description} -\item[code] The operation code for project. Can be PROJECT__COLL for - collapsing all time channels onto a 2D array and PROJECT__SAMPLE for - summing a rectangular region of the histogram memory in time. -\item[xStart, nx] start value in x and number of detectors to sum in x direction -\item[yStart,ny]start value in y and number of detectors to sum in y direction -\item[pData] a pointer to a data array large enough for holding the projected - data. -\item[iDataLen] The length of pData. -\end{description} - -SINQHMZero clears the histogram iNum from iStart to iEnd to 0. -A recommended call prior -to any serious data aquisition. - -\section{Further internal routines} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap11} -$\langle$IProtos {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@ static int OpenMasterConnection(pSINQHM self);@\\ -\mbox{}\verb@ static int GetMasterReply(pSINQHM self, struct rply_buff_struct *reply,@\\ -\mbox{}\verb@ int iBufLen);@\\ -\mbox{}\verb@ static int SendDAQCommand(pSINQHM self, int iCommand, int *iDaq);@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro defined by scraps ?, ?. -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -OpenMasterCoonection tries to open a connection to the SINQ histogram memory -master server ready to send data. - -GetMasterReply collects the reply from the master server. - -SendDAQCommand sends iCommand to the client server. Returns the current -status of the data aquisition flag in iDaq for further analysis. - -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap12} -$\langle$ErrCode {\footnotesize ?}$\rangle\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@#define HMCOMPUTER_NOT_FOUND -2@\\ -\mbox{}\verb@#define SOCKET_ERROR -3@\\ -\mbox{}\verb@#define BIND_ERROR -4@\\ -\mbox{}\verb@#define CONNECT_ERROR -5@\\ -\mbox{}\verb@#define RECEIVE_ERROR -6@\\ -\mbox{}\verb@#define INSUFFICIENT_DATA -7@\\ -\mbox{}\verb@#define BYTE_ORDER_CHAOS -8@\\ -\mbox{}\verb@#define HIST_BAD_CREATE -9@\\ -\mbox{}\verb@#define HIST_BAD_STATE -10@\\ -\mbox{}\verb@#define HIST_BAD_VALUE -11@\\ -\mbox{}\verb@#define HIST_BAD_RECV -12@\\ -\mbox{}\verb@#define HIST_BAD_ALLOC -13@\\ -\mbox{}\verb@#define HIST_BAD_CODE -14@\\ -\mbox{}\verb@#define SEND_ERROR -15@\\ -\mbox{}\verb@#define CLOSE_ERROR -16@\\ -\mbox{}\verb@#define INVALID_HARSH -17@\\ -\mbox{}\verb@#define SOFTWARE_ERROR -18@\\ -\mbox{}\verb@#define DAQ_INHIBIT -19@\\ -\mbox{}\verb@#define DAQ_NOTSTOPPED -20@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-1ex} -\footnotesize\addtolength{\baselineskip}{-1ex} -\begin{list}{}{\setlength{\itemsep}{-\parsep}\setlength{\itemindent}{-\leftmargin}} -\item Macro referenced in scrap ?. -\end{list} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap13} -\verb@"sinqhm.h"@ {\footnotesize ? }$\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@/*---------------------------------------------------------------------------@\\ -\mbox{}\verb@ S I N Q H M@\\ -\mbox{}\verb@ Some utility functions for interfacing to the SINQ histogram memory@\\ -\mbox{}\verb@ server.@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ David Maden, Mark Koennecke, April 1997@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ copyright: see implementation file.@\\ -\mbox{}\verb@-----------------------------------------------------------------------------*/@\\ -\mbox{}\verb@#ifndef SINQHMUTILITY@\\ -\mbox{}\verb@#define SINQHMUTILITY@\\ -\mbox{}\verb@#include "sinqhm_def.h"@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ typedef struct __SINQHM *pSINQHM;@\\ -\mbox{}\verb@/*------------------------------ Error codes -----------------------------*/@\\ -\mbox{}\verb@@$\langle$ErrCode {\footnotesize ?}$\rangle$\verb@@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@/*------------------------------ Prototypes ------------------------------*/@\\ -\mbox{}\verb@@$\langle$Protos {\footnotesize ?, \ldots\ }$\rangle$\verb@@\\ -\mbox{}\verb@@$\langle$TOFProto {\footnotesize ?}$\rangle$\verb@@\\ -\mbox{}\verb@#endif@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-2ex} -\end{minipage}\\[4ex] -\end{flushleft} -\begin{flushleft} \small -\begin{minipage}{\linewidth} \label{scrap14} -\verb@"sinqhm.i"@ {\footnotesize ? }$\equiv$ -\vspace{-1ex} -\begin{list}{}{} \item -\mbox{}\verb@@\\ -\mbox{}\verb@/*---------------------------------------------------------------------------@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ Internal header file for the SINQ histogram memory utility functions.@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@ David Maden, Mark Koennecke April 1997@\\ -\mbox{}\verb@----------------------------------------------------------------------------*/@\\ -\mbox{}\verb@#ifndef SINQHMINTERNAL@\\ -\mbox{}\verb@#define SINQHMINTERNAL@\\ -\mbox{}\verb@#define MAXBANK 1@\\ -\mbox{}\verb@@$\langle$SBank {\footnotesize ?}$\rangle$\verb@@\\ -\mbox{}\verb@@$\langle$SType {\footnotesize ?, \ldots\ }$\rangle$\verb@@\\ -\mbox{}\verb@@$\langle$IProtos {\footnotesize ?, \ldots\ }$\rangle$\verb@@\\ -\mbox{}\verb@@$\langle$TOFintern {\footnotesize ?}$\rangle$\verb@@\\ -\mbox{}\verb@#endif@\\ -\mbox{}\verb@@\\ -\mbox{}\verb@@$\diamond$ -\end{list} -\vspace{-2ex} -\end{minipage}\\[4ex] -\end{flushleft} -\chapter{The SINQ histogram memory Tcl wrapper} -In order to allow for status displays via Tcl/TK, for debugging and general -availability a Tcl wrapper for the SINQ histogram memory functions has been -devised. It works similar to the widget commands as used for TK. On startup -the extra command SINQHM is available. The syntax is: \\ -\leftline{SINQHM name computer port }\\ -This command will create another command called name which symbolises a -connection to the histogram memory at computer listening to port. The new -object created is a control object. This control object understands the -commands listed below. Each command has to be prepended with the name you -specified in the call to SINQHM. -\begin{itemize} -\item {\bf config iMode iOver iRank iLength iBinWidth} configures a histogram -memory. -\item {\bf status} return a status message of the HM. -\item {\bf deconfig iHarsh} deconfigures the HM. -\item {\bf debug iLevel} sets internal debug level. -\item {\bf exit} do not use this! Kills the HM. -\item {\bf DAQ name } creates a data aquisition client named name. -\item {\bf delDAQ name} kills the data aquisition client named name. -\end{itemize} - -After the last call there exists a new command name which represents a data -aquisition client, capabale of reading and writing data. This DAQ client -understands the commands listed below. Again, each command has to prepended -with the name given in the DAQ command above. -\begin{itemize} -\item {\bf read iNum iStart iEnd arname} reads histogram iNum from -iStart to iEnd. The data will be stored in the array arname. -\item {\bf write iNum iStart iEnd data} writes data to the histogram iNum -from iStart iEnd bins. data must be an Tcl-array with indexes from 0 to -iEnd which contains the values to write. -\item {\bf zero} zeroes the histogram memory. -\item {\bf start} starts data aquisition. -\item {\bf stop} stops data aquisition. -\item {\bf inhibit} inhibits data aquisition. -\item {\bf continue} continues an inhibited data aquisition session. -\end{itemize} - - - -\end{document} \ No newline at end of file diff --git a/hardsup/sinqhm.w b/hardsup/sinqhm.w deleted file mode 100644 index 0d2cf067..00000000 --- a/hardsup/sinqhm.w +++ /dev/null @@ -1,446 +0,0 @@ -\documentstyle{report} - -\setlength{\oddsidemargin}{0in} -\setlength{\evensidemargin}{0in} -\setlength{\topmargin}{0in} -\addtolength{\topmargin}{-\headheight} -\addtolength{\topmargin}{-\headsep} -\setlength{\textheight}{8.9in} -\setlength{\textwidth}{6.5in} -\setlength{\marginparwidth}{0.5in} - -\title{SINQHM-Utility\\ Utility functions for the \\ - SINQ Histogram memory} -\author{David Maden, Mark K\"onnecke, April 1997} - -\begin{document} -\maketitle -\clearpage - -\chapter{Introduction} -This file describes some Utility functions for interfacing with the SinQ -histogram memory server. This device is described in great detail elsewhere -(D. Maden: The SINQ Histogram Memory, Feb. 1997). -All the real time processing -for this HM is done by an on-board computer in a VME crate. This on board -computer also runs TCP/IP and a server program which allows for -configuration and communication with the HM. -For configuration an -connection to the main server is installed which handles the configuration -requests. For starting data collection and retrieval of information a second -connection is needed. This is obtained by sending a request to the main -server on the on board computer. This main server will than spawn a second -process on the on board computer which is dedicated to serving our requests. -The mainserver sends a packet containing the new port number our secondary -server is listening to. Than the driver can connect to this secondary server -in order to exchange data. According to this scheme the utility functions -divide into two groups: Master Server commands and data aquisition commands. - -\section{Code organisation} -The code dealing with the SINQ histogram memory is organised in four -files: sinqhm.w, the literate programming file which creates sinqhm.i and -sinqhm.h as well as the LateX documentation for the interface, sinqhm.i is -an internal header file and contains typedefs and function definitions for -relevant for the implementation of the utility functions only. sinqhm.h -defines the public interface functions. sinqhm.c finally is the source file -which implements the utilities. - -\section{The SINQHM data structure} -In order to transport the necessary status information around, each function -will take a pointer to the data structure defined below as first parameter. -For TOF mode it is necessary to store some imformation per detector bank. -This information is kept in a bank data structure: - -@d SBank @{ - typedef struct __SBANK { - int iStart; - int iEnd; - int iFlag; - int iEdgeLength; - int iDelay; - unsigned int *iEdges; - } SBank, *pSBank; -@} -The fields are: -\begin{description} -\item[iStart] The number of the detector with which this bank starts. -\item[iEnd] The number of the last detector for this bank. -\item[iFlag] A flag which indicates if the bank has a fixed bin widths. 0 -denotes fixed bin width, 1 variable time binning. -\item[iEdgeLength] is the length of the edge array. -\item[iEdges] is an array of integer values describing the lower edges of -the bins. Its content depends on the value of iFlag. With a equally spaced -time binning (iFlag = 0) is is sufficient to give values for the first two -bins. If the time binning varies, nBins+1 values are necessary describing -the lower edges of all time bins. -\end{description} - -@d SType @{ - typedef struct __SINQHM { - char *pHMComputer; - int iMasterPort; - int iMasterSocket; - int iClientPort; - int iClientSocket; - int iBinWidth; - int iLength; - int iRank; - int iPacket; - int iBanks; - int xSize, ySize; - int xOff, xFac; - int yOff, yFac; - SBank pBank[MAXBANK]; - } SINQHM; -@} - -The first item in this structure is the name of the histogram memory -computer, the second the port number at which the master server is -listening. iClientPort defines a port for data communication. If no such -port is open, this value will be 0. iStatus is a status flag. iBanks is the -number of detector banks defined. pSBank is an array of bank data structures -describing the detector banks. -xOff, xFac and yOff and yFac are the offset and factor values needed for -the PSD calculation for TRICS and AMOR. In order to -maintain this data structure two functions are defined: - -\section{Byte swapping} -These utility functions preform byte swapping as needed. In order for this -to work please make sure that the following typedefs represent the correct -types for your compiler and computer. - -@d SType @{ -/*---------------------------- Type definitions, machine dependent--------*/ - typedef short int SQint16; /* 16 bit integer */ - typedef int SQint32; /* 32 bit integer */ -@} - -@d Protos @{ - pSINQHM CreateSINQHM(char *pHMComputer, int iMasterPort); - pSINQHM CopySINQHM(pSINQHM self); - void DeleteSINQHM(pSINQHM self); - void SINQHMSetPar(pSINQHM self, int iRank, int iLength, int iBinWidth); - void SINQHMSetPSD(pSINQHM self, int xSize, int xOff, int xFac, - int ySize, int yOff, int yFac); -@} - -The first function creates a new SINQHM data structure and initialises the -fields with the parameters given. Their meanings correspond to those -mentioned above for the description of the data structure. DeleteSINQHM -frees all memory associated with a SINQHM structure given by self. The -pointer to self is invalid ever afterwards. -CopySINQHM creates a copy of the SINQHM structure passed in with self. -SINQHMSetPar sets time of flight parameters. -SINQHMSetPSD defines PSD parameters for TRICS/AMOR type detectors. - -\section{SINQHM error handling} -If not denoted otherwise all public SINQHM functions return an integer 1 on -success. In the more common case of failure, a negative error code is -returned. This error code can be transformed into a human readable form by a -call to: - -@d Protos @{ - int SINQHMError2Text(int iErr, char *pBuffer, int iBufLen); -@} - -This function takes as first parameter the error code, as second a pointer -to a text buffer for the error message and as third parameter the length of -the buffer. Maximum iBufLen characters will be copied to pBuffer. - -\section{Master Server command functions} -These functions mainly serve to configure the histogram memory and to obtain -socket-id's for client data aquisition servers. The following functions are -needed: - -@d Protos @{ - int SINQHMConfigure(pSINQHM self, int iMode, int iRank, int iLength, - int iBinWidth, int iLowBin, int iCompress); - int SINQHMConfigurePSD(pSINQHM self, int iMode, - int xSize, int xOff, int xFac, - int ySize, int yOff, int yFac, - int iBinWidth, - float *iEdges, int iEdgeLength); - - int SINQHMDeconfigure(pSINQHM self, int iHarsh); - int SINQHMGetStatus(pSINQHM self,int *iMode, int *iDaq, - int *iRank, int *iBinWidth, - int *iLength, int *iClients); - int SINQHMDebug(pSINQHM self, int iLevel); - int SINQHMKill(pSINQHM self); - -@} - -@d IProtos @{ -@} - -SINQHMConfigure configures the master server for data aquisition. Besides -the pointer to a SINQHM structure it takes the following parameters: - iMode is the combination of mode and submode bits as defined in -sinqhm_defs.h. iLength is the length of -the histograms. iBinWidth is the size of the histogram memory bins in bytes. -Currently the values 1,2 and 4 are allowed. iClients is the number of active -clients at the histogram memory computer. iRank is the number of histograms. -iLowBin is the start of the histogram memory. Usually this is 0, but someone -may choose to strat at a different memory location. iCompress is for -compression. All data will be right shifted by iCompress bits before -storage. To my knowledge this feature is currently not implemented. - -SINQHMConfigurePSD configures a TRICS/AMOR type detector. The parameters are: -\begin{description} -\item[self] The histogram memory data structure. -\item[iMode] The actual histogram mode with all submask bits. -\item[xSize] The x size of the detector. -\item[xOff] The offset in x for the detector position decoding. -\item[xFac] The factor used in decoding the x detector position. -\item[ySize] The y size of the detector. -\item[yOff] The offset in y for the detector position decoding. -\item[yFac] The factor used in decoding the y detector position. -\item[iBinWidth] The binwidth of the histograms. -\item[iEdges] An array holding the time binning edges. -\item[iEdgeLength] The length of iEdges. -\end{description} - -SINQHMDeconfigure deconfigures the histogram memory. This is necessary prior -to reconfiguration. The only parameter iHarsh defines how brutal the master -server is with this. There may still be clients active at the histogram -memory. If iHarsh is 0, SINQHMDeconfig returns an error in this case. If -iHarsh is 1, the clients will be killed and the master server returns to a -virgin state. - -SINQHMGetStatus allows to query the state of the master server. Parameters -have the same meaning as given with SINQHMConfigure. Except of course -iClients which is the number of currently active clients at the histogram -memory. iDaq show the status of data aquisition: 0 denotes stopped, 1 -denotes running and 2 denotes inhibited. - -SINQHMDebug sets the debug level of the histogram memory server. That server -may print messages to its Com 1 port. This command configures the amount of -information available at this channel. This function is of no use for normal -users. - -SINQHMKill stops the histogram memory master server and all its children. -WARNING: After this call a manual restart of the histogram memory master -server or a reboot of the histogram memory computer has to be performed. -Do not use this function unless you are a SINQ histogram memory guru. - -\section{TOF bin description functions} -Configuring the TOF binning of the histogram memory requires two steps. In -the first step you define the binning of all required banks. Then in a -second step, this data is packed up and forwarded to the histogram memory. -Thus the following functions are required: - -@d TOFProto @{ - int SINQHMDefineBank(pSINQHM self, int iBankNumber, int iStart, int iEnd, - float *iEdges, int iEdgeLength); -@} -@d TOFintern @{ - static int SINQHMTimeBin(pSINQHM self, int iMode); -@} -SINQHDefineBank defines the time binning for a single detector bank. -iBankNumber defines the number of the detector bank to define. iStart and -iEnd select the range of detectors beloning to this detector bank. iEdges -is the array of time binnings. iEdgeLength is the length of the edges array. - -SINQHMTimeBin actually sends the new time binning to the histogram memory. -SINQHMTimeBin is a static internal function. - - - -\section{Data aquisition functions} -These functions allow to do data aquisition and retrieve or set histograms. -Data aquisition is fairly involved. In order for data aquisition to happen -the histogram memory internal filler process must be running. This is -controlled by the StartDAQ/StopDAQ pair. However, any client can inhibit -data processing. This feature is targeted towards clients monitoring -environment devices. Such clients thus can pause data aquisition in order to -allow environment variables to get in the defined range again. This is -controlled by the InhibitDAQ/ContinueDAQ pair of functions. Please note, -that after starting a new data aquisition session the inhibit flag is -cleared by default. - -@d Protos @{ - int SINQHMOpenDAQ(pSINQHM self); - int SINQHMCloseDAQ(pSINQHM self); - - int SINQHMStartDAQ(pSINQHM self); - int SINQHMStopDAQ(pSINQHM self); - int SINQHMInhibitDAQ(pSINQHM self); - int SINQHMContinueDAQ(pSINQHM self); - - int SINQHMWrite(pSINQHM self, int iNum, int iStart, int iEnd, - void *pData); - long SINQHMSize(pSINQHM self, int iNum, int iStart, int iEnd); - int SINQHMRead(pSINQHM self, int iNum, int iStart, int iEnd, - void *pData, int iDataLen); - int SINQHMProject(pSINQHM self, int code, int xStart, int nx, - int yStart, int ny, void *pData, int iDataLen); - int SINQHMZero(pSINQHM self, int iNum, int iStart, int iEnd); -@} - -SINQHMOpenDAQ must be the first call and will create the slave server in the -histogram memory server which is than responsible for answereing our further -requests. Without this call any other call will return an error! - -SINQHMCloseDAQ closes a data aquisition session. - -SINQHMStartDAQ starts data aquisition. - -SINQHMInhibitDAQ causes data aquisition to pause. - -SINQHMContinueDAQ causes a paused data aquisition to continue. - -SINQHMStopDAQ stops data aquisition. - -SINQHMWrite is used to initialise the histograms in the histogram memory to -a specific value. The histogram to write is selected by iNum. If iNum is -1 -the whole histogram memory area is written. iStart and iEnd define a subset -of the histogram to write. pData is a pointer to a data area which is going -to be copied to the histogram memory. - -SINQHMSize returns the necessary size in bytes for a buffer large enough to -hold all the data requested with the following read parameters. - -SINQHMRead reads histograms. The parameters iNum, iStart and iEnd have the -same meaning as with SINQHMWrite. Maximum iDataLen bytes of data are copied -to the memory area pointed to by pData. - -SINQHMProject requests a projection of the data from the histogram memory. This - is currently only implemented for AMOR because histograms can get so large - at this instrument that a transfer for processing would take to long. The - parameters are: -\begin{description} -\item[code] The operation code for project. Can be PROJECT__COLL for - collapsing all time channels onto a 2D array and PROJECT__SAMPLE for - summing a rectangular region of the histogram memory in time. -\item[xStart, nx] start value in x and number of detectors to sum in x direction -\item[yStart,ny]start value in y and number of detectors to sum in y direction -\item[pData] a pointer to a data array large enough for holding the projected - data. -\item[iDataLen] The length of pData. -\end{description} - -SINQHMZero clears the histogram iNum from iStart to iEnd to 0. -A recommended call prior -to any serious data aquisition. - -\section{Further internal routines} -@d IProtos @{ - static int OpenMasterConnection(pSINQHM self); - static int GetMasterReply(pSINQHM self, struct rply_buff_struct *reply, - int iBufLen); - static int SendDAQCommand(pSINQHM self, int iCommand, int *iDaq); -@} -OpenMasterCoonection tries to open a connection to the SINQ histogram memory -master server ready to send data. - -GetMasterReply collects the reply from the master server. - -SendDAQCommand sends iCommand to the client server. Returns the current -status of the data aquisition flag in iDaq for further analysis. - -@d ErrCode @{ -#define HMCOMPUTER_NOT_FOUND -2 -#define SOCKET_ERROR -3 -#define BIND_ERROR -4 -#define CONNECT_ERROR -5 -#define RECEIVE_ERROR -6 -#define INSUFFICIENT_DATA -7 -#define BYTE_ORDER_CHAOS -8 -#define HIST_BAD_CREATE -9 -#define HIST_BAD_STATE -10 -#define HIST_BAD_VALUE -11 -#define HIST_BAD_RECV -12 -#define HIST_BAD_ALLOC -13 -#define HIST_BAD_CODE -14 -#define SEND_ERROR -15 -#define CLOSE_ERROR -16 -#define INVALID_HARSH -17 -#define SOFTWARE_ERROR -18 -#define DAQ_INHIBIT -19 -#define DAQ_NOTSTOPPED -20 -@} - -@o sinqhm.h -d @{ -/*--------------------------------------------------------------------------- - S I N Q H M - Some utility functions for interfacing to the SINQ histogram memory - server. - - David Maden, Mark Koennecke, April 1997 - - copyright: see implementation file. ------------------------------------------------------------------------------*/ -#ifndef SINQHMUTILITY -#define SINQHMUTILITY -#include "sinqhm_def.h" - - typedef struct __SINQHM *pSINQHM; -/*------------------------------ Error codes -----------------------------*/ -@< ErrCode @> - -/*------------------------------ Prototypes ------------------------------*/ -@< Protos @> -@< TOFProto @> -#endif -@} - -@o sinqhm.i @{ -/*--------------------------------------------------------------------------- - - Internal header file for the SINQ histogram memory utility functions. - - David Maden, Mark Koennecke April 1997 -----------------------------------------------------------------------------*/ -#ifndef SINQHMINTERNAL -#define SINQHMINTERNAL -#define MAXBANK 1 -@< SBank @> -@< SType @> -@< IProtos @> -@< TOFintern @> -#endif - -@} - -\chapter{The SINQ histogram memory Tcl wrapper} -In order to allow for status displays via Tcl/TK, for debugging and general -availability a Tcl wrapper for the SINQ histogram memory functions has been -devised. It works similar to the widget commands as used for TK. On startup -the extra command SINQHM is available. The syntax is: \\ -\leftline{SINQHM name computer port }\\ -This command will create another command called name which symbolises a -connection to the histogram memory at computer listening to port. The new -object created is a control object. This control object understands the -commands listed below. Each command has to be prepended with the name you -specified in the call to SINQHM. -\begin{itemize} -\item {\bf config iMode iOver iRank iLength iBinWidth} configures a histogram -memory. -\item {\bf status} return a status message of the HM. -\item {\bf deconfig iHarsh} deconfigures the HM. -\item {\bf debug iLevel} sets internal debug level. -\item {\bf exit} do not use this! Kills the HM. -\item {\bf DAQ name } creates a data aquisition client named name. -\item {\bf delDAQ name} kills the data aquisition client named name. -\end{itemize} - -After the last call there exists a new command name which represents a data -aquisition client, capabale of reading and writing data. This DAQ client -understands the commands listed below. Again, each command has to prepended -with the name given in the DAQ command above. -\begin{itemize} -\item {\bf read iNum iStart iEnd arname} reads histogram iNum from -iStart to iEnd. The data will be stored in the array arname. -\item {\bf write iNum iStart iEnd data} writes data to the histogram iNum -from iStart iEnd bins. data must be an Tcl-array with indexes from 0 to -iEnd which contains the values to write. -\item {\bf zero} zeroes the histogram memory. -\item {\bf start} starts data aquisition. -\item {\bf stop} stops data aquisition. -\item {\bf inhibit} inhibits data aquisition. -\item {\bf continue} continues an inhibited data aquisition session. -\end{itemize} - - - -\end{document} \ No newline at end of file diff --git a/hardsup/sinqhm_def.h b/hardsup/sinqhm_def.h deleted file mode 100644 index 6b17b2ed..00000000 --- a/hardsup/sinqhm_def.h +++ /dev/null @@ -1,483 +0,0 @@ -/*=================================================== [...SinqHM]SinqHM_def.h -** -** Definition Include file for SinqHM_SRV and its clients. -** -**------------------------------------------------------------------------------ -*/ -#define SINQHM_DEF_ID "V03C" - -#ifdef __alpha -#ifndef __vms -#pragma pack 1 -#endif -#endif -/*------------------------------------------------------------------------------ -*/ -#ifndef OffsetOf -#define OffsetOf(type, identifier) ((size_t)(&((type*) NULL)->identifier)) -#endif -/*------------------------------------------------------------------------------ -** Define some defaults. -*/ -#define PORT_BASE 2400 /* The Internet Port for Server Requests */ -#define MAX_CLIENTS 8 /* The maximum number of active clients */ -#define MAX_TOF_CNTR 1024 /* The maximum number of individual counters .. - ** which can be handled in TOF mode */ -#define MAX_PSD_CNTR 1048576 /* maximum number of PSD elements */ -#define MAX_TOF_NBINS 32768 /* The maximum number of bins in a TOF histog */ -#define MAX_TOF_EDGE 16 /* The maximum number of TOF edge arrays */ -#define VMIO_BASE_ADDR 0x1900 /* VME address of a (possible) VMIO10 module */ -#define IDENT_MSGE_LEN 256 /* Length of Ident info for SQHM_IDENT */ - -#define uchar unsigned char -#define usint unsigned short int -#define uint unsigned int -/*------------------------------------------------------------------------------ -** Define some status values (similar to VAXeln). -*/ -#define KER__SUCCESS 1 -#define KER__BAD_CREATE -2 -#define KER__BAD_STATE -4 -#define KER__BAD_VALUE -6 -#define KER__EXIT_SIGNAL -10 -#define KER__BAD_RECV -14 -#define KER__BAD_ALLOC -16 - -#ifndef True -#define True 1 -#endif - -#ifndef False -#define False 0 -#endif - -#ifndef NIL -#define NIL '\0' -#endif -/*------------------------------------------------------------------------------ -** Define command verbs to SinqHM. -*/ -#define SQHM_CNCT 0x01 -#define SQHM_CLOSE 0x02 -#define SQHM_CONFIG 0x03 -#define SQHM_DAQ 0x04 -#define SQHM_DBG 0x05 -#define SQHM_DECONFIG 0x06 -#define SQHM_EXIT 0x07 -#define SQHM_IDENT 0x0e -#define SQHM_PROJECT 0x0d -#define SQHM_READ 0x08 -#define SQHM_SELECT 0x09 -#define SQHM_STATUS 0x0a -#define SQHM_WRITE 0x0b -#define SQHM_ZERO 0x0c - /* - ** Define the various operation modes - */ -#define SQHM__TRANS 0x1000 /* Transparent mode */ -#define SQHM__HM_DIG 0x2000 /* Hist mode (with digitised read-out) */ -#define SQHM__TOF 0x3000 /* Time-of-Flight mode */ -#define SQHM__HM_PSD 0x4000 /* Hist mode (with Pos-sens-detect read-out) */ -#define SQHM__HRPT 0x5000 /* Hist mode for HRPT */ - /* - ** Define the various sub-mode bits of the operation modes - */ -#define SQHM__SUB_MODE_MSK 0xff /* Mask for extracting "sub-mode" bits */ -#define SQHM__DEBUG 0x01 /* Debug flag - FILLER will suspend itself .. - ** .. after starting to allow debugging */ -#define SQHM__UD 0x02 /* Use Up/Down bit information */ - -#define SQHM__BO_MSK 0x18 /* Mask for extracting "bin-overflow" bits */ -#define SQHM__BO_IGN 0x00 /* Ignore bin-overflows (bin-contents wrap) */ -#define SQHM__BO_SMAX 0x08 /* On bin-overflow, stop at maximum */ -#define SQHM__BO_CNT 0x10 /* Keep counts of overflow bins */ - -#define SQHM__STROBO 0x20 /* Use strobo-bit information */ -#define SQHM__REFLECT 0x40 /* Reflect histograms */ -#define SQHM__NO_STAT 0x80 /* Suppress status info from "Filler" */ - /* - ** ---------------------------------------------------------- - ** SQHM_DAQ sub-function codes - */ -#define DAQ__EXIT 0xffffffff -#define DAQ__CLR 0x01 -#define DAQ__GO 0x02 -#define DAQ__INH 0x03 -#define DAQ__STOP 0x04 -#define DAQ__TST 0x05 - /* - ** ---------------------------------------------------------- - ** SQHM_PROJECT sub-codes - */ -#define PROJECT__ON_Y 0x0001 /* Project onto y-axis */ -#define PROJECT__1_DIM 0x0002 /* Make projection of a 1-dim histogram */ -#define PROJECT__COLL 0x0003 /* collapse PSD on one time channel */ -#define PROJECT__SAMPLE 0x0004 /* sum a rectangular part of the PSD - detector in time - */ - /* - ** ---------------------------------------------------------- - ** Definition of bits in of TOF edge-array - */ -#define FLAG__VAR_BIN 0x01 /* Bin span of histogram is variable */ - /* - ** ---------------------------------------------------------- - ** Definition of bits in of SQHM_STATUS response - */ -#define STATUS_FLAGS__PF 0x8000 /* PF - Power Fail */ -#define STATUS_FLAGS__SWC 0x4000 /* SWC - Status Word Changed */ -#define STATUS_FLAGS__NRL 0x2000 /* NRL - Neutron Rate Low */ -#define STATUS_FLAGS__DAQ 0x1000 /* DAQ on -- set if Hdr Mask Bits are - ** correct so that data acq is active */ -#define STATUS_FLAGS__SYNC3 0x0800 /* Ext Synch Bit #3 */ -#define STATUS_FLAGS__SYNC2 0x0400 /* Ext Synch Bit #2 */ -#define STATUS_FLAGS__SYNC1 0x0200 /* Ext Synch Bit #1 */ -#define STATUS_FLAGS__SYNC0 0x0100 /* Ext Synch Bit #0 */ -#define STATUS_FLAGS__UD 0x0080 /* UD - Up/Down */ -#define STATUS_FLAGS__GU 0x0040 /* GU - Gummi (i.e. Strobo) */ - /* - ** ---------------------------------------------------------- - */ -#define N_HISTS_MAX 64 /* Maximum number of histograms supported */ -#define N_BINS_MAX 0x00ffff /* Maximum histogram bin number permitted */ -#define N_TOTAL_BYTES 0x400000 /* Maximum total bytes of histogram */ -/* -**------------------------------------------------------------------------------ -** Definitions of Filler states in HRPT mode -*/ -#define HRPT__SRCH_FRAME 1 -#define HRPT__READ_FRAME 2 -/* -**------------------------------------------------------------------------------ -** Definitions for the LWL Datagrams -*/ -#define LWL_HDR_TYPE_MASK (0x1f000000) /* Mask for extracting main dgrm .. - ** .. hdr command-type bits */ -#define LWL_HDR_PF_MASK (0x80000000) /* Mask for extr Power Fail bit */ -#define LWL_HDR_SWC_MASK (0x40000000) /* Mask for extr Status Word Chng bit */ -#define LWL_HDR_NRL_MASK (0x20000000) /* Mask for extr Neutron Rate Low bit */ -#define LWL_HDR_SYNC3_MASK (0x00800000) /* Mask for one of ext synch bits */ -#define LWL_HDR_SYNC2_MASK (0x00400000) /* Mask for one of ext synch bits */ -#define LWL_HDR_SYNC1_MASK (0x00200000) /* Mask for one of ext synch bits */ -#define LWL_HDR_SYNC0_MASK (0x00100000) /* Mask for one of ext synch bits */ -#define LWL_HDR_UD_MASK LWL_HDR_SYNC1_MASK /* Mask for Up/Down bit */ -#define LWL_HDR_GU_MASK LWL_HDR_SYNC0_MASK /* Mask for GU bit */ -#define LWL_HDR_BA_MASK (0x00f00000) /* Mask for TSI Binning Addr */ -#define LWL_HDR_TS_MASK (0x000fffff) /* Mask for TSI Time Stamp */ - -#define LWL_FIFO_EMPTY (0x1e000000) /* FIFO Empty */ - -#define LWL_TSI_TR (0x1f000000) /* Time-Status-Info Transp-Mode */ -#define LWL_TSI_HM_NC (0x1f000000) /* Time-Status-Info Hist-Mode+No-Coinc */ -#define LWL_TSI_HM_C (0x0e000000) /* Time-Status-Info Hist-Mode+Coinc */ -#define LWL_TSI_TOF (0x1f000000) /* Time-Status-Info TOF-Mode */ -#define LWL_TSI_SM_NC (0x1f000000) /* Time-Status-Info Strobo-Mode+No-Coin */ -#define LWL_TSI_SM_C (0x0e000000) /* Time-Status-Info Strobo-Mode+Coinc */ -#define LWL_TSI_DT_MSK (0x000fffff) /* Mask for Dead-Time in TSI */ -#define LWL_TSI_DTS_MSK (0x000fffff) /* Mask for Delay-Time-to-Start in TSI */ - -#define LWL_TR_C1 (0x00000001) /* Transp. Mode Chan 1 */ -#define LWL_TR_C2 (0x00000002) /* Transp. Mode Chan 2 */ -#define LWL_TR_C3 (0x00000003) /* Transp. Mode Chan 3 */ -#define LWL_TR_C4 (0x00000004) /* Transp. Mode Chan 4 */ -#define LWL_TR_C5 (0x00000005) /* Transp. Mode Chan 5 */ -#define LWL_TR_C6 (0x00000006) /* Transp. Mode Chan 6 */ -#define LWL_TR_C7 (0x00000007) /* Transp. Mode Chan 7 */ -#define LWL_TR_C8 (0x00000008) /* Transp. Mode Chan 8 */ -#define LWL_TR_C9 (0x00000009) /* Transp. Mode Chan 9 */ - -#define LWL_HM_NC (0x10000000) /* Hist-Mode/No-Coinc 0 chan dgrm hdr */ -#define LWL_HM_NC_C1 (0x11000000) /* Hist-Mode/No-Coinc 1 chan dgrm hdr */ -#define LWL_HM_NC_C2 (0x12000000) /* Hist-Mode/No-Coinc 2 chan dgrm hdr */ -#define LWL_HM_NC_C3 (0x13000000) /* Hist-Mode/No-Coinc 3 chan dgrm hdr */ -#define LWL_HM_NC_C4 (0x14000000) /* Hist-Mode/No-Coinc 4 chan dgrm hdr */ -#define LWL_HM_NC_C5 (0x15000000) /* Hist-Mode/No-Coinc 5 chan dgrm hdr */ -#define LWL_HM_NC_C6 (0x16000000) /* Hist-Mode/No-Coinc 6 chan dgrm hdr */ -#define LWL_HM_NC_C7 (0x17000000) /* Hist-Mode/No-Coinc 7 chan dgrm hdr */ -#define LWL_HM_NC_C8 (0x18000000) /* Hist-Mode/No-Coinc 8 chan dgrm hdr */ -#define LWL_HM_NC_C9 (0x19000000) /* Hist-Mode/No-Coinc 9 chan dgrm hdr */ - -#define LWL_HM_CO (0x10000000) /* Hist-Mode+Coinc 0 chan dgrm hdr */ -#define LWL_HM_CO_C2 (0x12000000) /* Hist-Mode+Coinc 2 chan dgrm hdr */ -#define LWL_HM_CO_C3 (0x13000000) /* Hist-Mode+Coinc 3 chan dgrm hdr */ -#define LWL_HM_CO_C4 (0x14000000) /* Hist-Mode+Coinc 4 chan dgrm hdr */ -#define LWL_HM_CO_C5 (0x15000000) /* Hist-Mode+Coinc 5 chan dgrm hdr */ -#define LWL_HM_CO_C6 (0x16000000) /* Hist-Mode+Coinc 6 chan dgrm hdr */ -#define LWL_HM_CO_C7 (0x17000000) /* Hist-Mode+Coinc 7 chan dgrm hdr */ -#define LWL_HM_CO_C8 (0x18000000) /* Hist-Mode+Coinc 8 chan dgrm hdr */ -#define LWL_HM_CO_C9 (0x19000000) /* Hist-Mode+Coinc 9 chan dgrm hdr */ - -#define LWL_TOF_C1 (0x01000000) /* TOF-Mode 1 chan dgrm hdr */ -#define LWL_TOF_C2 (0x02000000) /* TOF-Mode 2 chan dgrm hdr */ -#define LWL_TOF_C3 (0x03000000) /* TOF-Mode 3 chan dgrm hdr */ -#define LWL_TOF_C4 (0x04000000) /* TOF-Mode 4 chan dgrm hdr */ -#define LWL_TOF_C5 (0x05000000) /* TOF-Mode 5 chan dgrm hdr */ -#define LWL_TOF_C6 (0x06000000) /* TOF-Mode 6 chan dgrm hdr */ -#define LWL_TOF_C7 (0x07000000) /* TOF-Mode 7 chan dgrm hdr */ -#define LWL_TOF_C8 (0x08000000) /* TOF-Mode 8 chan dgrm hdr */ -#define LWL_TOF_C9 (0x09000000) /* TOF-Mode 9 chan dgrm hdr */ - -#define LWL_PSD_TSI 0x0E000000 /* PSD-Mode TSI datagram */ -#define LWL_PSD_DATA 0x12000000 /* PSD-mode data datagram */ -#define LWL_PSD_PWF 0x20000000 /* PSD-mode Power Fail bit */ -#define LWL_PSD_TIME 0x000fffff /* PSD-mode time stamp extraction - mask */ -#define LWL_PSD_FLASH_MASK 0x00ff /* mask for flash count */ -#define LWL_PSD_XORF 0x2000 /* mask for TDC-XORF bit */ -#define LWL_PSD_CONF 0x0100 /* mask for TDC-CONF flag */ - -#define LWL_SM_NC (0x10000000) /* Strobo-Mode/No-Coinc 0 chan dgrm hdr */ -#define LWL_SM_NC_C1 (0x11000000) /* Strobo-Mode/No-Coinc 1 chan dgrm hdr */ -#define LWL_SM_NC_C2 (0x12000000) /* Strobo-Mode/No-Coinc 2 chan dgrm hdr */ -#define LWL_SM_NC_C3 (0x13000000) /* Strobo-Mode/No-Coinc 3 chan dgrm hdr */ -#define LWL_SM_NC_C4 (0x14000000) /* Strobo-Mode/No-Coinc 4 chan dgrm hdr */ -#define LWL_SM_NC_C5 (0x15000000) /* Strobo-Mode/No-Coinc 5 chan dgrm hdr */ -#define LWL_SM_NC_C6 (0x16000000) /* Strobo-Mode/No-Coinc 6 chan dgrm hdr */ -#define LWL_SM_NC_C7 (0x17000000) /* Strobo-Mode/No-Coinc 7 chan dgrm hdr */ -#define LWL_SM_NC_C8 (0x18000000) /* Strobo-Mode/No-Coinc 8 chan dgrm hdr */ -#define LWL_SM_NC_C9 (0x19000000) /* Strobo-Mode/No-Coinc 9 chan dgrm hdr */ - -#define LWL_SM_CO (0x10000000) /* Strobo-Mode + Coinc 0 chan dgrm hdr */ -#define LWL_SM_CO_C1 (0x11000000) /* Strobo-Mode + Coinc 1 chan dgrm hdr */ -#define LWL_SM_CO_C2 (0x12000000) /* Strobo-Mode + Coinc 2 chan dgrm hdr */ -#define LWL_SM_CO_C3 (0x13000000) /* Strobo-Mode + Coinc 3 chan dgrm hdr */ -#define LWL_SM_CO_C4 (0x14000000) /* Strobo-Mode + Coinc 4 chan dgrm hdr */ -#define LWL_SM_CO_C5 (0x15000000) /* Strobo-Mode + Coinc 5 chan dgrm hdr */ -#define LWL_SM_CO_C6 (0x16000000) /* Strobo-Mode + Coinc 6 chan dgrm hdr */ -#define LWL_SM_CO_C7 (0x17000000) /* Strobo-Mode + Coinc 7 chan dgrm hdr */ -#define LWL_SM_CO_C8 (0x18000000) /* Strobo-Mode + Coinc 8 chan dgrm hdr */ -#define LWL_SM_CO_C9 (0x19000000) /* Strobo-Mode + Coinc 9 chan dgrm hdr */ - -#define LWL_TSI_MODE_MASK (0x000e) /* Mask for mode in Time Status Info */ -#define LWL_TSI_MODE_TR (0x0000) /* TSI Transparent-Mode */ -#define LWL_TSI_MODE_HM (0x0002) /* TSI Hist-Mode */ -#define LWL_TSI_MODE_TOF (0x0004) /* TSI TOF-Mode */ -#define LWL_TSI_MODE_SM1 (0x0006) /* TSI Strobo-Mode 1 - time-stamp coded */ -#define LWL_TSI_MODE_TR_UD (0x0008) /* TSI Transparent-Mode Up-Down */ -#define LWL_TSI_MODE_HM_UD (0x000a) /* TSI Hist-Mode Up-Down */ -#define LWL_TSI_MODE_TOF_UD (0x000c) /* TSI TOF-Mode Up-Down */ -#define LWL_TSI_MODE_SM2 (0x000e) /* TSI Strobo-Mode 2 - h/w coded */ -/* -**------------------------------------------------------------------------------ -** Define structure of a TOF histogram data item. -*/ - struct tof_histog { - int cntr_nmbr; /* Counter number */ - uint lo_edge; /* Low edge of first bin (20-bit value) */ - uint hi_edge; /* Top edge of last bin (20-bit value) */ - usint flag; /* Bit mask giving info on histog -- may be - ** used to help optimise the code */ - usint bytes_per_bin; /* Number of bytes in each histogram bin */ - uint n_bins; /* Number of bins in histogram */ - uint cnt_early_up; /* Count of early events (pol'n up) */ - uint cnt_late_up; /* Count of late events (pol'n up) */ - uint cnt_early_down; /* Count of early events (pol'n down) */ - uint cnt_late_down; /* Count of late events (pol'n down) */ - uint *bin_edge; /* Pointer to array of bin edges */ - union { /* Pointer to histogram array */ - uchar *b_bin_data; /* .. pointer if it's 8-bit bins */ - usint *w_bin_data; /* .. pointer if it's 16-bit bins */ - uint *l_bin_data; /* .. pointer if it's 32-bit bins */ - } u; - }; - -/* Define a TOF 'edge-info' structure. This structure is created -** as a result of a TOF 'edge-array' in a SQHM__TOF config cmnd. -*/ - struct tof_edge_info { - uint n_bins; /* Number of bins in histogram */ - uint flag; /* Flag bits defining type of histo */ - uint bin_span; /* Time spanned by a histogram bin (20-bit - ** value) if bin width is constant. Otherwise - ** it is zero. */ - uint hi_edge; /* Top edge of last bin (20-bit value) */ - uint edges[2]; /* Array of edge data (20-bit values). There - ** are actually (n_bins+1) items in the array - ** and give the bottom edges of the bin */ - }; - -/* Define structure of a TOF 'edge-array' in SQHM__TOF config cmnd -*/ - struct tof_edge_arr { - uint n_bins; /* Number of bins in histogram */ - uint flag; /* Flag (0/1) for fixed/variable bin size */ - uint *edges; /* Array of bottom edges (20-bit values) */ - }; - -/* Define structure of a TOF 'bank' in SQHM__TOF config command -*/ - struct tof_bank { - usint first; /* Number of first counter in bank */ - usint n_cntrs; /* Number of counters in bank */ - usint edge_indx; /* Index of edge array */ - usint bytes_per_bin; /* Number of bytes per bin */ - }; -/* -**------------------------------------------------------------------------------ -** Define command structure. -*/ - struct req_buff_struct { /* For messages to SinqHM */ - uint bigend; - uint cmnd; - union { - char filler[56]; - - struct {uint max_pkt, - strt_mode;} cnct; - - struct {uint mode; - union { - struct { - uint n_buffs; - uint n_bytes; - } trans; - struct { - uint n_hists; - uint lo_bin; - uint num_bins; - uint bytes_per_bin; - uint compress; - } hm_dig; - struct { - uint n_extra_bytes; - usint n_edges; - usint n_banks; - uint preset_delay; - struct tof_edge_arr edge_0; - struct tof_bank bank_0; - } tof; - struct { - uint n_extra_bytes; - usint n_edges; - usint n_banks; - uint preset_delay; - usint xFactor; - usint yFactor; - usint xOffset; - usint yOffset; - usint xSize; - usint ySize; - struct tof_edge_arr edge_0; - struct tof_bank bank_0; - } psd; - } u; - } cnfg; - - struct {uint mask;} dbg; - - struct {uint sub_code;} decnfg; - - struct {uint sub_cmnd;} daq; - - struct {uint sub_code, - x_lo, - nx, - y_lo, - ny, - xdim, - nhist;} project; - - struct {uint hist_no, - first_bin, - n_bins;} read; - - struct {uint hist_no;} select; - - struct {uint hist_no, - first_bin, - n_bins, - bytes_per_bin;} write; - - struct {uint hist_no, - first_bin, - n_bins;} zero; - } u; - }; -/* -**------------------------------------------------------------------------------ -** Define status response structure. -*/ - struct rply_buff_struct { /* For messages from SinqHM */ - uint bigend; - uint status; - uint sub_status; - union { - char message[52]; - - struct {uint port; - uint pkt_size; - uint hm_mode; - uint n_hists; - uint num_bins; - uint bytes_per_bin; - uint curr_hist; - uint max_block; - uint total_bytes; - uint lo_cntr; - uint lo_bin; - uint compress; - uint up_time;} cnct; - - struct {usint daq_now; - usint daq_was; - usint filler_mask; - usint server_mask;} daq; - - struct {uint n_extra_bytes; - uint up_time; - usint offset_vxWorks_ident; - usint offset_vxWorks_date; - usint offset_instr; - usint offset_def_ident; - usint offset_sinqhm_main_ident; - usint offset_sinqhm_main_date; - usint offset_sinqhm_server_ident; - usint offset_sinqhm_server_date; - usint offset_sinqhm_filler_ident; - usint offset_sinqhm_filler_date; - usint offset_sinqhm_routines_ident; - usint offset_sinqhm_routines_date;} ident; - - struct {uint n_bins; - uint bytes_per_bin; - uint cnts_lo; - uint cnts_hi;} project; - - struct {uint first_bin; - uint n_bins; - uint bytes_per_bin; - uint cnts_lo; - uint cnts_hi;} read; - - struct {uint cfg_state; - usint n_hists, curr_hist; - uint num_bins; - uint max_n_hists; - uint max_num_bins; - uchar max_srvrs, act_srvrs, bytes_per_bin, compress; - usint daq_now, filler_mask; - uint max_block; - usint tsi_status, flags; - union { - uint dead_time; - uint dts; - uint both; - } dt_or_dts; - uint num_bad_events; - uint up_time;} status; - } u; - }; -/* -**------------------------------------------------------------------------------ -** Define structure of message to SinqHM-filler. -*/ - struct msg_to_filler_struct { /* For messages to SinqHM-filler */ - union { - char message[32]; /* Ensure buffer is 32 bytes total */ - struct { - uint cmnd; - uint index; - usint new_mask;} uu; - } u; - }; -/*======================================================= End of SinqHM_def.h */ diff --git a/hardsup/stredit.c b/hardsup/stredit.c deleted file mode 100644 index 27b61c4e..00000000 --- a/hardsup/stredit.c +++ /dev/null @@ -1,415 +0,0 @@ -#define ident "1B03" -#ifdef VAXC -#module StrEdit ident -#endif -#ifdef __DECC -#pragma module StrEdit ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Department ASQ | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]StrEdit.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Jan 1996 -** -** To compile this module, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]StrEdit - - tasmad_disk:[mad.lib.sinq]StrEdit + - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb StrEdit debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb StrEdit -** -** Updates: -** 1A01 19-Jan-1996 DM. Initial version. -** 1B01 21-Mar-1996 DM. Move from DELTAT.OLB to SINQ.OLB. -**============================================================================ -** The following entry points are included in this module: -** -**------------------------------------------------------------------------- -** #include -** -** char *StrEdit (char *out, char *in, char *ctrl, int *ln) -** ------- -** Input Args: -** in - the string to be edited. -** ctrl - the string specifying what is to be done. See Description -** below. -** Output Args: -** out - the edited string. The maximum size of this string must -** be specified as input parameter *ln. The string -** will be zero terminated on return. -** Modified Args: -** *ln - an integer specifying, on input, the length of "out" in -** bytes. This must include room for the zero termination. -** On return, ln will be set to the number of characters -** copied to "out" (not counting the zero termination byte). -** Return value: -** If an error is detected, the return value is a NULL pointer. Otherwise -** it is a pointer to the resulting string (i.e. "out"). -** Global variables: -** none -** Routines called: -** none -** Description: -** StrEdit (out, in, ctrl, ln) - This routine is intended to mimic the -** OpenVMS DCL lexical function F$EDIT. -** -** It first processes the string "in" to convert any C-style -** escape sequences introduced by a '\' character. Recognised -** escape sequences are: -** \a --> \007 BEL -** \b --> \010 BS (backspace) -** \f --> \014 FF (formfeed) -** \n --> \012 LF (linefeed) -** \r --> \015 CR (carriage return) -** \t --> \011 HT (horizontal tab) -** \v --> \013 VT (vertical tab) -** \\ --> \ -** \' --> ' -** \" --> " -** \? --> ? -** \xhh --> hh are an arbitrary number of hex digits. -** \nnn --> nnn are up to 3 octal digits. -** Any unrecognised escape sequence will be left unchanged. -** -** The resulting string is then edited according to the -** keywords specified in the control string "ctrl". The result -** will be written to string "out". The "out" argument may be -** the same as "in". -** -** On entry, "ln" specifies the size of "out" in bytes, including -** space for a null terminating byte. On return, it is set to the -** length of the result (not counting the zero-terminator). -** -** The following control strings are recognised: -** -** COLLAPSE - Removes all spaces and tabs from the string. -** COMPRESS - Replaces multiple spaces and tabs with a -** single space. -** LOWERCASE - Makes the string lower case. -** TRIM - Removes leading and trailing spaces and tabs -** from the string. -** UNCOMMENT - Removes comments from the string. -** UPCASE - Makes the string upper case. -** -** All keywords must be specified in full. They may be separated -** by white-space or commas and be in upper or lower case. -** -** If the input string contains non-escaped double quotes ("), -** then the editing functions are not applied to substrings within -** these quotes ("), there must be an even number of such quotes -** and the quotes are not copied to the resulting string. On the -** other hand, escaped double quotes (\") are treated as normal -** characters. -** -** Return Status: -** StrEdit returns a pointer to "out". If any errors are detected (e.g. an -** odd number of quotes), string editing is abandoned and a null pointer -** is returned. -** -** Example: -** strcpy (in, " asdfg \"hello there\" folks "); -** len = sizeof (in); -** printf ("\"%s\"\n", StrEdit (in, in, "trim upcase compress", &len)); -** will generate -** "ASDFG hello there FOLKS" -**------------------------------------------------------------------------- -** Global Definitions -*/ -#include -#include -#include -#include -#include - -#define NIL '\0' -#define True 1 -#define False 0 -#define QUOTE ((char) (('\"' ^ 0xff) & 0xff)) -/* -**==================================================================== -*/ -/* -**==================================================================== -*/ -/*-------------------------------------------------------------------------- -** Global Variables -*/ -/* -**--------------------------------------------------------------------------- -** StrEdit - edit a string. -** Note: strncat is used exclusively rather than -** strncpy to be sure result is always -** null terminated. -*/ - char *StrEdit ( -/* ======= -*/ char *out, - char *in, - char *ctrl, - int *ln) { - - int i, j, k, l, m, len, inxt, out_size; - char my_ctrl[80]; - char *tok_nxt, *my_in, *my_out, *my_tmp, *nxt; - int do_collapse, do_compress, do_lowercase, do_trim; - int do_uncomment, do_upcase; - - out_size = *ln; - if (out_size < 1) {*ln = 0; return NULL;} /* Can't do anything!! */ - - if (strlen (in) <= 0) { - *out = NIL; *ln = 0; return out; /* Nothing to do!! */ - } - /* - ** Scan ctrl looking to see what has to be done. Do this by first - ** taking a copy of it (in case it is declared "const" in the calling - ** routine, convert to lowercase and split into tokens at any space, - ** tab or comma. - */ - len = strlen (ctrl); - if (len >= sizeof (my_ctrl)) { - *out = NIL; *ln = 0; return NULL; - } - for (i = 0; i <= len; i++) my_ctrl[i] = tolower (ctrl[i]); - - do_collapse = do_compress = do_lowercase = do_trim = do_uncomment = - do_upcase = False; - tok_nxt = strtok (my_ctrl, ", \t\f\v\n"); - while (tok_nxt != NULL) { - if (strcmp (tok_nxt, "collapse") == 0) { - do_collapse = True; - }else if (strcmp (tok_nxt, "compress") == 0) { - do_compress = True; - }else if (strcmp (tok_nxt, "lowercase") == 0) { - do_lowercase = True; - }else if (strcmp (tok_nxt, "trim") == 0) { - do_trim = True; - }else if (strcmp (tok_nxt, "uncomment") == 0) { - do_uncomment = True; - }else if (strcmp (tok_nxt, "upcase") == 0) { - do_upcase = True; - }else { - *out = NIL; *ln = 0; return NULL; /* Illegal ctrl verb */ - } - tok_nxt = strtok (NULL, ", \t\f\v\n"); - } - - len = strlen (in) + 1; - my_in = malloc (len); /* Get some working space */ - if (my_in == NULL) { - *out = NIL; *ln = 0; return NULL; - } - /* - ** Copy "in" to the "my_in" working space, processing any '\' escape - ** sequences as we go. Note that, since "my_in" is big enough to hold - ** "in" and the escape sequence processing can only shorten the length - ** of "in", there's no need to check for an overflow of "my_in". Any - ** non-escaped double quotes are converted to something special so - ** that they can be recognised at the editing stage. - */ - nxt = my_in; - while (*in != '\0') { - if (*in == '\\') { /* Look for escape sequence */ - in++; - switch (*in) { - case 'a': case 'A': *nxt++ = '\007'; in++; break; - case 'b': case 'B': *nxt++ = '\010'; in++; break; - case 'f': case 'F': *nxt++ = '\014'; in++; break; - case 'n': case 'N': *nxt++ = '\012'; in++; break; - case 'r': case 'R': *nxt++ = '\015'; in++; break; - case 't': case 'T': *nxt++ = '\011'; in++; break; - case 'v': case 'V': *nxt++ = '\013'; in++; break; - case '\\': *nxt++ = '\\'; in++; break; - case '\'': *nxt++ = '\''; in++; break; - case '\"': *nxt++ = '\"'; in++; break; - case '\?': *nxt++ = '\?'; in++; break; - case 'x': case 'X': - in++; - i = strspn (in, "0123456789abcdefABCDEF"); - if (i > 0) { - *nxt++ = strtol (in, &in, 16); break; - }else { - *nxt++ = '\\'; break; - } - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - i = strspn (in, "01234567"); - if (i > 3) { - sscanf (in, "%3o", &j); - *nxt++ = j; - in += 3; - break; - }else if (i > 0) { - sscanf (in, "%o", &j); - *nxt++ = j; - in += i; - break; - }else { - *nxt++ = '\\'; - break; - } - default: - *nxt++ = '\\'; /* Invalid esc sequ - just copy it */ - } - }else if (*in == '\"') { /* Look for non-escaped double quotes */ - *nxt++ = QUOTE; *in++; /* Make it something unlikely */ - }else { - *nxt++ = *in++; - } - } - *nxt = '\0'; - - my_out = malloc (len); /* Get some working space */ - if (my_out == NULL) { - free (my_in); *out = NIL; *ln = 0; return NULL; - } - *my_out = NIL; - - my_tmp = malloc (len); /* Get some working space */ - if (my_tmp == NULL) { - free (my_out); free (my_in); - *out = NIL; *ln = 0; return NULL; - } - *my_tmp = NIL; - *out = NIL; - /* - ** Ensure "in" has an even number of non-escaped quotes. Return if not. - */ - i = 0; - for (j = 0; my_in[j] != NIL; j++) if (my_in[j] == QUOTE) i++; - if ((i & 1) == 1) { - free (my_tmp); - free (my_out); - free (my_in); - *ln = strlen (out); - return NULL; - } - /* - ** Scan through "in", substring by substring, to - ** handle quotation marks correctly. - */ - inxt = 0; - while (my_in[inxt] != NIL) { - if (my_in[inxt] == QUOTE) { /* Is there a quoted string next? */ - nxt = strchr (&my_in[inxt+1], QUOTE); /* Yes, find matching quote. */ - j = nxt - &my_in[inxt+1]; - memcpy (my_tmp, &my_in[inxt+1], j); /* Make copy of it */ - my_tmp[j] = NIL; - inxt = inxt + j + 2; - }else { - nxt = strchr (&my_in[inxt], QUOTE); /* Not a quoted string; .. - ** .. find next non-escaped .. - ** .. quote. - */ - if (nxt != NULL) { - j = nxt - my_in - inxt; - }else { - j = strlen (&my_in[inxt]); - } - memcpy (my_tmp, &my_in[inxt], j); /* Make copy for us to work on */ - my_tmp[j] = NIL; - inxt = inxt + j; - /* - ** For collapse and compress, start by turning all white space - ** chars to spaces. - */ - if (do_collapse || do_compress) { - for (k = 0; my_tmp[k] != NIL; k++) { - if (my_tmp[k] == '\t') my_tmp[k] = ' '; - if (my_tmp[k] == '\f') my_tmp[k] = ' '; - if (my_tmp[k] == '\v') my_tmp[k] = ' '; - if (my_tmp[k] == '\n') my_tmp[k] = ' '; - } - if (do_collapse) { - l = 0; - for (k = 0; my_tmp[k] != NIL; k++) { - if (my_tmp[k] != ' ') { - my_tmp[l] = my_tmp[k]; - l++; - } - } - my_tmp[l] = NIL; - }else if (do_compress) { - for (k = 0; my_tmp[k] != NIL; k++) { - if (my_tmp[k] == ' ') { - l = strspn (&my_tmp[k], " "); - if (l > 1) { - for (m = 0; my_tmp[k+l+m] != NIL; m++) { - my_tmp[k+m+1] = my_tmp[k+l+m]; - } - my_tmp[k+m+1] = NIL; - } - } - } - } - } - if (do_lowercase) { - for (k = 0; my_tmp[k] != NIL; k++) my_tmp[k] = _tolower (my_tmp[k]); - } - if (do_upcase) { - for (k = 0; my_tmp[k] != NIL; k++) my_tmp[k] = _toupper (my_tmp[k]); - } - if (do_uncomment) { - nxt = strchr (my_tmp, '!'); - if (nxt != NULL) { - *nxt = NIL; /* Truncate the string at the "!" */ - my_in[inxt] = NIL; /* Stop processing loop too */ - } - } - } - StrJoin (out, out_size, my_out, my_tmp); - strcpy (my_out, out); - } - - if (do_trim) { - i = strspn (my_out, " "); - if (i == strlen (my_out)) { /* If all spaces, result is a null string */ - *out = NIL; - }else { - for (j = strlen (my_out); my_out[j-1] == ' '; j--); - my_out[j] = NIL; - } - strcpy (out, &my_out[i]); - } - free (my_tmp); - free (my_out); - free (my_in); - *ln = strlen (out); - /* - ** Undo any encoded escape characters. - */ - for (i = 0; out[i] != NIL; i++) { - if (out[i] == ~'\"') out[i] = '\"'; - } - - return out; - } -/*-------------------------------------------------- End of StrEdit.C -------*/ diff --git a/hardsup/strjoin.c b/hardsup/strjoin.c deleted file mode 100644 index 88a8b721..00000000 --- a/hardsup/strjoin.c +++ /dev/null @@ -1,142 +0,0 @@ -#define ident "1B03" -#ifdef VAXC -#module StrJoin ident -#endif -#ifdef __DECC -#pragma module StrJoin ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Department ASQ | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]STRJOIN.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Nov 1995 -** -** To compile this module, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]StrEdit - - tasmad_disk:[mad.lib.sinq]StrEdit + - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb StrEdit debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb StrEdit -** -** Updates: -** 1A01 2-Nov-1995 DM. Initial version. -** 1B01 21-Mar-1996 DM. Move from DELTAT.OLB to SINQ.OLB. -** 1B03 28-May-1997 DM. Allow result string to be either of source -** strings. -**============================================================================ -** The following entry points are included in this module: -** -**------------------------------------------------------------------------- -** #include -** -** char *StrJoin (&result, result_size, &str_a, &str_b) -** ------- -** Input Args: -** int result_size - max size of "result". The resultant string will -** have a max length of (result_size - 1) to allow -** for the zero terminator -** char *str_a - Pointer to first string to be joined. -** char *str_b - Pointer to second string to be joined. -** Output Args: -** char *result - Pointer to resulting string. -** Modified Args: -** none -** Return value: -** Pointer to resulting string. -** Global variables modified: -** none -** Routines called: -** None -** Description: -** The routine joins 2 strings, checking for total string length and -** ensuring the result will be zero terminated. The "result" arg may be -** the same as "str_a" or "str_b". -**------------------------------------------------------------------------- -** Global Definitions -*/ -#include - -#define NIL '\0' -/* -**==================================================================== -*/ -/* -**==================================================================== -** StrJoin - join 2 strings. -** Note: strncat is used exclusively rather than -** strncpy to be sure result is always -** null terminated. -*/ - char *StrJoin ( -/* ======= -*/ char *result, - int result_size, - char *str_a, - char *str_b) { - - int i, size, size_a, size_b; - - size = result_size - 1; - - if (size < 0) return result; - - if (result == str_a) { /* Are the result and str_a the same? */ - size_a = strlen (str_a); /* Yes */ - if (size_a > size) { /* Check sizes anyway. */ - result[size] = NIL; /* Truncate str_a. No room for str_b! */ - }else { - size = size - strlen (result); /* And append str_b */ - if (size > 0) { - strncat (result, str_b, size); - } - } - }else if (result == str_b) { /* Are the result and str_b the same? */ - size_a = strlen (str_a); /* Yes, this is a bit complicated! */ - size_b = strlen (str_b); - if (size_a >= size) { /* If str_a completely fills result, .. */ - result[0] = NIL; /* .. then just copy in str_a */ - strncat (result, str_a, size); - }else { - /* - ** Otherwise, str_b must first be moved to - ** make room for str_a and then str_a must - ** be put at the front of the result. - */ - if ((size_a + size_b) > size) size_b = size - size_a; - result[size_a+size_b] = NIL; - for (i = (size_b-1); i >= 0; i--) { - result[size_a+i] = str_b[i]; - } - memcpy (result, str_a, size_a); - } - }else { /* Result is neither str_a nor str_b so .. */ - result[0] = NIL; /* .. str_a needs to be copied */ - strncat (result, str_a, size); - size = size - strlen (result); /* And str_a appended */ - if (size > 0) strncat (result, str_b, size); - } - return result; - } -/*-------------------------------------------------- End of STRJOIN.C =======*/ diff --git a/hardsup/table.c b/hardsup/table.c deleted file mode 100644 index 41e1b9c0..00000000 --- a/hardsup/table.c +++ /dev/null @@ -1,176 +0,0 @@ -/*------------------------------------------------------------------------- - Implementation file for translation table. - - Mark Koennecke, October 1997 - - copyright: see copyright.h ----------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include "table.h" - -/*-------------------------------------------------------------------------*/ - typedef struct __SicsTable { - float *fVal1; - float *fVal2; - int iLength; - } STable; -/*-------------------------------------------------------------------------*/ - pSTable CreateTable(FILE *fd) - { - pSTable pNew = NULL; - long lStart, lEnd, lData, i; - char *pBuffer = NULL, *pEnd = NULL, *pEndLine, *pPtr; - int iLength, iRet; - float fVal1, fVal2; - - assert(fd); - - /* find length of file, create a buffer and read it in */ - lStart = ftell(fd); - fseek(fd,0L,SEEK_END); - lEnd = ftell(fd); - lData = lEnd - lStart; - pBuffer = (char *)malloc(lData*sizeof(char)); - if(!pBuffer) - { - return NULL; - } - fseek(fd,lStart,SEEK_SET); - fread(pBuffer,sizeof(char),lData,fd); - - /* find number of lines */ - for(i = 0, iLength = 0; i < lData; i++) - { - if(pBuffer[i] == '\n') - { - iLength++; - } - } - - /* allocate the table structure */ - pNew = (pSTable)malloc(sizeof(STable)); - if(!pNew) - { - free(pBuffer); - return NULL; - } - pNew->iLength = iLength; - pNew->fVal1 = (float *)malloc(sizeof(float)*iLength); - pNew->fVal2 = (float *)malloc(sizeof(float)*iLength); - if( (!pNew->fVal1) || (!pNew->fVal2)) - { - free(pBuffer); - free(pNew); - return NULL; - } - memset(pNew->fVal1,0,iLength*sizeof(float)); - memset(pNew->fVal2,0,iLength*sizeof(float)); - - /* dodge through the file reading pairs until end */ - pPtr = pBuffer; - pEnd = pBuffer + lData; - pEndLine = pBuffer; - i = 0; - while(pEndLine < pEnd) - { - if(*pEndLine == '\n') - { - *pEndLine = '\0'; - iRet = sscanf(pPtr,"%f %f",&fVal1, &fVal2); - if(iRet == 2) - { - pNew->fVal1[i] = fVal1; - pNew->fVal2[i] = fVal2; - i++; - } - pEndLine++; - pPtr = pEndLine; - } - else - { - pEndLine++; - } - } - - free(pBuffer); - return pNew; - } -/*--------------------------------------------------------------------------*/ - void DeleteTable(pSTable self) - { - if(self->fVal1) - { - free(self->fVal1); - } - if(self->fVal2) - { - free(self->fVal2); - } - free(self); - } -/*--------------------------------------------------------------------------*/ - int InterpolateVal1(pSTable self, float fKey, float *fResult) - { - float fFrac; - int i1,i; - - assert(self); - assert(self->fVal1); - assert(self->fVal2); - - /* search the entry point */ - for(i = 0; i < self->iLength; i++) - { - if(self->fVal1[i] >= fKey) - { - i1 = i; - break; - } - } - if(i1 >= self->iLength) - { - return 0; - } - - /* interpolate */ - fFrac = (fKey - self->fVal1[i1 -1]) - / (self->fVal1[i1] - self->fVal1[i1 - 1]); - *fResult = self->fVal2[i1-1] - + fFrac*(self->fVal2[i1] - self->fVal2[i1 -1]); - return 1; - } -/*---------------------------------------------------------------------------*/ - int InterpolateVal2(pSTable self, float fKey, float *fResult) - { - float fFrac; - int i1,i; - - assert(self); - assert(self->fVal1); - assert(self->fVal2); - - /* search the entry point */ - for(i = 0; i < self->iLength; i++) - { - if(self->fVal2[i] <= fKey) - { - i1 = i; - break; - } - } - if(i1 >= self->iLength) - { - return 0; - } - - /* interpolate */ - fFrac = (fKey - self->fVal2[i1 -1]) - / (self->fVal2[i1] - self->fVal2[i1 - 1]); - *fResult = self->fVal1[i1-1] - + fFrac*(self->fVal1[i1] - self->fVal1[i1 -1]); - return 1; - } - diff --git a/hardsup/table.h b/hardsup/table.h deleted file mode 100644 index 7d98b299..00000000 --- a/hardsup/table.h +++ /dev/null @@ -1,35 +0,0 @@ -/*--------------------------------------------------------------------------- - A general purpose translation table and interpolation module. - Interpolation tables are read from a file, which is meant to - contain pairs of val1 val2 per line. - - - Mark Koennecke, October 1997 - - copyright: see copyright.h - ------------------------------------------------------------------------------*/ -#ifndef SICSTABLE -#define SICSTABLE - typedef struct __SicsTable *pSTable; - -/*------------------------- live & death ----------------------------------*/ - pSTable CreateTable(FILE *fd); - /* - creates a new table from a given file. The file is meant to have - been positioned to the first entry for the table in the file. - This leaves the caller free to examine a header, if any. - */ - void DeleteTable(pSTable self); -/*------------------------- Interpolation --------------------------------*/ - int InterpolateVal1(pSTable pTable, float fKey, float *fResult); - /* - Returns a result from the second column for a key from the - first column. - */ - int InterpolateVal2(pSTable pTable, float fKey, float *fResult); - /* - Returns a result from the first column for a key from the - second column. - */ -#endif diff --git a/hardsup/velsel_def.h b/hardsup/velsel_def.h deleted file mode 100644 index 276eb65b..00000000 --- a/hardsup/velsel_def.h +++ /dev/null @@ -1,58 +0,0 @@ -#ifndef _velsel_def_ -#define _velsel_def_ -/*------------------------------------------------ VelSel_DEF.H Ident V01B -*/ -#include -#include - -#ifndef OffsetOf -#define OffsetOf(type, identifier) ((size_t)(&((type*) NULL)->identifier)) -#endif - -enum VelSel_Errors {VELSEL__BAD_TMO = -1, - VELSEL__BAD_CMD = -3, - VELSEL__BAD_OFL = -4, - VELSEL__BAD_ILLG = -5, - VELSEL__BAD_HOST = -6, - VELSEL__BAD_SOCKET = -7, - VELSEL__BAD_BIND = -8, - VELSEL__BAD_CONNECT = -9, - VELSEL__BAD_DEV = -10, - VELSEL__BAD_MALLOC = -11, - VELSEL__BAD_SENDLEN = -12, - VELSEL__BAD_SEND = -13, - VELSEL__BAD_SEND_PIPE = -14, - VELSEL__BAD_SEND_NET = -15, - VELSEL__BAD_SEND_UNKN = -16, - VELSEL__BAD_RECV = -17, - VELSEL__BAD_RECV_PIPE = -18, - VELSEL__BAD_RECV_NET = -19, - VELSEL__BAD_RECV_UNKN = -20, - VELSEL__BAD_NOT_BCD = -21, - VELSEL__BAD_RECVLEN = -22, - VELSEL__BAD_FLUSH = -23, - VELSEL__BAD_RECV1 = -24, - VELSEL__BAD_RECV1_PIPE = -25, - VELSEL__BAD_RECV1_NET = -26, - VELSEL__BAD_PAR = -29, - VELSEL__BAD_BSY = -30, - VELSEL__BAD_OPEN = -31, - VELSEL__FORCED_CLOSED = -32, - VELSEL__BAD_STP = -33, - VELSEL__NOT_OPEN = -35, - VELSEL__BAD_ASYNSRV = -36, - VELSEL__BAD_REPLY = -34}; -/* -** Structure to which the VelSel_Open handle points. -*/ - struct VelSel_info { - struct AsynSrv__info asyn_info; /* Contains skt, host, port & chan */ - int tmo; - char eot[4]; - int msg_id; - int n_replies, max_replies; - struct RS__MsgStruct to_host; - struct RS__RespStruct from_host; - }; -/*------------------------------------------------ End of VelSel_DEF.H --*/ -#endif /* _velsel_def_ */ diff --git a/hardsup/velsel_utility.c b/hardsup/velsel_utility.c deleted file mode 100644 index 3b277b00..00000000 --- a/hardsup/velsel_utility.c +++ /dev/null @@ -1,928 +0,0 @@ -#define ident "1A01" -#ifdef VAXC -#module VelSel_Utility ident -#endif -#ifdef __DECC -#pragma module VelSel_Utility ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | Department ASQ | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Module Name . . . . . . . . : [...LIB.SINQ]VelSel_Utility.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : June 1997 -** -** To compile this module, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ cc /debug /noopt /obj=[]VelSel_Utility - - tasmad_disk:[mad.psi.lib.sinq]VelSel_Utility + - - sinq_c_tlb/lib - -** To include this module in SINQ.OLB, use: - - $ import tasmad - $ define/group sinq_c_tlb mad_lib:sinq_c.tlb - $ - $ define/group sinq_olb mad_lib:sinq_dbg.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb VelSel_Utility debug - $ - $ define/group sinq_olb mad_lib:sinq.olb - $ @tasmad_disk:[mad.lib.sinq]sinq_olb VelSel_Utility -** -** Updates: -** 1A01 13-Jun-1997 DM. Initial version. -**============================================================================ -** The entry points included in this module are described below. Prototypes -** can be defined via: -** -** #include -** -** VelSel_Close - Close a connection to a Velocity Selector. -** VelSel_Config - Configure a connection to a Velocity Selector. -** VelSel_ErrInfo - Return detailed status from last operation. -** VelSel_GetReply - Get next reply from a reply buffer. -** VelSel_GetStatus - Get "???" response. -** VelSel_Open - Open a connection to a Velocity Selector. -** VelSel_SendCmnds - Send commands to RS232C server. -**--------------------------------------------------------------------- -** int VelSel_Close (&handle, int force_flag) -** ------------ -** Input Args: -** int force_flag - if non-zero, all connections using the same socket -** will also be closed (this gets AsynSrv_Close to -** actually close the socket and is needed for error -** recovery operations). -** Output Args: -** none -** Modified Args: -** void **handle - The pointer to the structure returned by VelSel_Open. -** On return, the pointer is set to NULL. -** Return status: -** True always (error returns from close and free are not checked). -** Routines called: -** AsynSrv_Close -** Description: -** The routine calls AsynSrv_Close to close the connection to the RS232C -** server. If 'force_flag' is non-zero, all other connections to the -** RS232C server which use the same socket will also be closed. -** -** The 'force_flag' can be useful in error recovery situations. The AsynSrv -** utility operates by only opening a socket for each separate combination -** of host/port. Hence, if several connections are open to the server, -** then calling VelSel_Close doesn't actually close the socket until all -** connections have been closed. In the situation -** where an error has been detected, it is often desirable to -** close and re-open the socket as part of the recovery procedure. Calling -** VelSel_Close with 'force_flag' non-zero will force the socket to be -** closed and will mark all connections using this socket so that they -** will be informed of the event when they next call any AsynSrv -** dependent routine. -** -** Note: The force-close action is effected by the AsynSrv package. A -** force-close will thus also close any connections to other -** RS-232-C devices (e.g. EL737 neutron cntr) on the same server. -**------------------------------------------------------------------------- -** void VelSel_Config (&handle, msec_tmo, eot_str) -** ------------- -** Input Args: -** void **handle - The pointer to the structure returned by VelSel_Open. -** int msec_tmo - The time-out for responses. Dflt = 10000. -** char *eot_str - A string of up to 3 characters specifying terminating -** characters for input. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** none -** Routines called: -** none -** Description: -** The routine sets values in the VelSel_info data structure. -**------------------------------------------------------------------------- -** void VelSel_ErrInfo (&entry_txt_ptr, &errcode, &my_errno, &vaxc_errno) -** -------------- -** Input Args: -** None -** Output Args: -** char **entry_txt_ptr - Pointer to a text string giving the call stack -** at the time that the error was detected. -** int *errcode - An internal error code indicating the detected error. -** int *my_errno - Saved value of errno. -** int *vaxc_errno - Saved value of vaxc$errno (OpenVMS only). -** Modified Args: -** none -** Return status: -** none -** Routines called: -** none -** Description: -** Returns detailed status of the last operation. Once an error has been -** detected, the error status is frozen until this routine has been called. -**------------------------------------------------------------------------- -** void *VelSel_GetReply (&handle, last_rply) -** --------------- -** Input Args: -** void **handle - The pntr to the structure returned by VelSel_Open. -** void *last_rply - Address of last reply processed or NULL. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** Address of next reply structure in the buffer or NULL if no more. -** Routines called: -** none -** Description: -** VelSel_GetReply is a utility routine mainly intended for internal use -** by the VelSel_Utility package. It unpacks the replies in the response -** packet from the RS232C server. -** -** Having received a response from the server to a sequence of commands, -** VelSel_GetReply is called with last_rply = NULL. The return value is -** a pointer to the first reply sub-structure in the response. On calling -** VelSel_GetReply again with last_rply set to this address, one receives -** the address of the second reply sub-structure and so on, until NULL -** is returned when all responses have been exhausted. The structure of -** a reply sub-structure is RS__RplyStruct. -**------------------------------------------------------------------------- -** int VelSel_GetStatus (&handle, &status_str, status_str_len) -** ---------------- -** Input Args: -** void **handle - The pointer to the structure returned by VelSel_Open. -** int status_str_len - The length of status_str. -** Output Args: -** char *status_str - Pointer to a buffer to save the status. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and VelSel_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** VelSel_GetStatus are (other values may be set by the called routines): -** VELSEL__BAD_TMO, _LOC, _CMD, _OFL, _ADR --> see VelSel_Open. -** VELSEL__BAD_ILLG = -5 --> one of the responses could probably not be -** decoded. This could happen if there is noise -** on the RS232C connection to the Velocity -** Selector. -** If an error is detected, ist_posit is set to 0.0 and all other -** arguments to -1. -** Routines called: -** VelSel_SendCmnds -** Description: -** The routine issues a "???" command to the Velocity Selector and -** analyses the result. -**------------------------------------------------------------------------- -** int VelSel_Open (&handle, host, port, chan, id) -** ----------- -** Input Args: -** char *host - Name of host offering the TCP/IP service. -** int port - Number of TCP/IP port of TCP/IP server. -** int chan - RS-232-C Channel number on the TCP/IP server. -** char *id - The expected ID of the device, normally "????". -** If id is NULL, the device ID is not checked. -** Output Args: -** void *handle - A pointer to a structure of type VelSel_info needed -** for subsequent calls to VelSel_... routines. Buffer -** space for the structure is allocated dynamically. -** It gets released via a call to VelSel_Close. -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False. If False, VelSel_ErrInfo -** can be called to identify the problem. Values of Errcode set by -** VelSel_Open are (other values may be set by the called routines): -** VELSEL__BAD_TMO = -1 --> Time-out error ("?TMO" - this gets -** generated by the RS232C server). -** VELSEL__BAD_LOC = -2 --> Off-line ("?LOC"). This should not -** happen on calls to VelSel_Open since it -** sends an "RMT 1" cmnd. -** VELSEL__BAD_CMD = -3 --> Command error ("?CMD"). This could be -** caused by noise in the RS-232-C -** transmission. -** VELSEL__BAD_OFL = -4 --> Connection broken ("?OFL"). -** This can get generated by RS232C_SRV -** if, for example, the connection is via -** a terminal server and the terminal -** server loses power. -** VELSEL__BAD_ILLG = -5 --> Some other unrecognised response. This -** should never occur, of course! -** VELSEL__BAD_HOST = -6 --> Call to "gethostbyname" failed to get -** network addr of host. -** VELSEL__BAD_SOCKET = -7 --> Call to "socket" failed. -** VELSEL__BAD_BIND = -8 --> Call to "bind" failed. -** VELSEL__BAD_CONNECT = -9 --> Call to "connect" failed. -** VELSEL__BAD_DEV = -10 --> Bad cmnd response - is device a VelSel? -** VELSEL__BAD_MALLOC = -11 --> Call to "malloc" failed -** Routines called: -** AsynSrv_open, the memory alloc routine "malloc" and VelSel_SendCmnds. -** Description: -** The routine calls AsynSrv_open to open a TCP/IP connection to a server -** offering the "RS-232-C" service for a Velocity Selector. "RMT 1" -** and "ECHO 0" commands are sent to ensure the device is on-line. -**------------------------------------------------------------------------- -** int VelSel_SendCmnds (&handle, ...) -** ---------------- -** Input Args: -** void **handle - The pntr to the structure returned by VelSel_Open. -** char * ... - A list of commands, terminated by NULL, for -** sending to the Velocity Selector. The commands must -** have any necessary \r characters included. -** Output Args: -** none -** Modified Args: -** none -** Return status: -** True if no problems detected, otherwise False and errcode (see -** VelSel_ErrInfo) is set to indicate the nature of the problem. -** VelSel_errcode may be set as follows: -** VELSEL__BAD_SENDLEN = -12 --> Too much to send; either too many -** commands or too long. The buffer -** is 232 bytes long and each command -** has a 2-byte header. -** Errors -13 to -16 are related to network errors whilst sending the -** message buffer to the server: -** VELSEL__BAD_SEND = -13 --> Network problem - server has -** probably abended. -** VELSEL__BAD_SEND_PIPE = -14 --> Network pipe broken - probably same -** cause as VELSEL__BAD_SEND. -** VELSEL__BAD_SEND_NET = -15 --> Some other network problem. "errno" -** may be helpful. -** VELSEL__BAD_SEND_UNKN = -16 --> Some other network problem happened -** resulting in the message not -** getting sent completely. "errno" is -** probably not helpful in this case. -** Errors VELSEL__BAD_RECV, VELSEL__BAD_RECV_PIPE, VELSEL__BAD_RECV_NET -** and VELSEL__BAD_RECV_UNKN (-17 to -20) are related to network -** errors whilst receiving the 4-byte response header. They are -** analogous to VELSEL__BAD_SEND to VELSEL__BAD_SEND_UNKN. -** VELSEL__BAD_NOT_BCD = -21 --> The 4-byte response header is not an -** ASCII coded decimal integer. -** VELSEL__BAD_RECVLEN = -22 --> The body of the response would be too -** big to fit in the input buffer. The -** buffer is 244 bytes long and each -** response has a 3-byte header and a -** trailing zero-byte. The response -** is flushed. -** VELSEL__BAD_FLUSH = -23 --> Some network error was detected -** during flushing. This is an "or" -** of errors VELSEL__BAD_RECV to -** VELSEL__BAD_RECV_UNKN. -** VELSEL__FORCED_CLOSED = -32 --> The connection to the Velocity -** Selector has been forcefully -** closed. See below. -** VELSEL__BAD_REPLY = -34 --> The n_rply field of the response was -** either non-numeric or <0, indicating -** that the Terminal Server detected an -** error. The reply is added to the -** routine call stack for debug purposes. -** -** Errors VELSEL__BAD_RECV1, VELSEL__BAD_RECV1_PIPE and -** VELSEL__BAD_RECV1_NET (-24 to -26) are related to network -** errors whilst receiving the body of the response. They are -** equivalent to errors VELSEL__BAD_RECV, to VELSEL__BAD_RECV_NET. -** -** VELSEL__FORCED_CLOSED occurs if AsynSrv_Close has been called (e.g. -** via a call to VelSel_Close) for another device on the same -** server and the 'force_flag' was set (see VelSel_Close). The -** caller should call VelSel_Close and then VelSel_Open to -** re-establish a connection to the Velocity Selector. -** Routines called: -** Socket library routines send and recv. -** Description: -** The list of commands is assembled into a message buffer with appropriate -** header information and sent off to the server. The response is then -** awaited and read in when it arrives. -** -** For any of the following errors: -** VELSEL__BAD_SEND (Note: VELSEL__BAD_SENDLEN and -** VELSEL__BAD_SEND_PIPE VELSEL__BAD_RECVLEN do not cause a close -** VELSEL__BAD_SEND_NET -** VELSEL__BAD_SEND_UNKN -** VELSEL__BAD_RECV -** VELSEL__BAD_RECV_PIPE -** VELSEL__BAD_RECV_NET -** VELSEL__BAD_RECV_UNKN -** VELSEL__BAD_NOT_BCD -** VELSEL__BAD_FLUSH -** VELSEL__BAD_RECV1 -** VELSEL__BAD_RECV1_PIPE -** VELSEL__BAD_RECV1_NET -** the network link to the server is force-closed via a call to VelSel_Close. -** Once the error has been corrected, the link can be re-opened via a -** call to VelSel_Open. As a result of the force-close, other active handles -** will need to be released via a call to VelSel_Close before VelSel_Open is -** called. -** -** Note: neither of the errors VELSEL__BAD_SENDLEN, VELSEL__BAD_RECVLEN -** nor VELSEL__BAD_REPLY cause the link to be closed. -**============================================================================*/ -/* -**--------------------------------------------------------------------------- -** Global Definitions -*/ -#include -#include -#include -#include -#include -#include -#include -#include - -#include - -#ifdef __VMS -#include -#else -#include -#endif -/*-----------------------------------------------------------------*/ -#include -#include -#include -#include - -#define True 1 -#define False 0 -/*-------------------------------------------------------------------------- -** Global Variables -*/ - static int VelSel_call_depth = 0; - static char VelSel_routine[5][64]; - static int VelSel_errcode = 0; - static int VelSel_errno, VelSel_vaxc_errno; -/* -**--------------------------------------------------------------------------- -** VelSel_Close: Close a connection to a Velocity Selector. -*/ - int VelSel_Close ( -/* =========== -*/ void **handle, - int force_flag) { - - struct VelSel_info *info_ptr; - char buff[4]; - - info_ptr = (struct VelSel_info *) *handle; - if (info_ptr == NULL) return True; - - if (info_ptr->asyn_info.skt != 0) { - if (info_ptr->asyn_info.skt > 0) { - AsynSrv_Close (*handle, force_flag); - } - } - free (*handle); - *handle = NULL; - - return True; - } -/* -**--------------------------------------------------------------------------- -** VelSel_Config: Configure a connection to a Velocity Selector. -*/ - void VelSel_Config ( -/* ============ -*/ void **handle, - int msec_tmo, - char *eot_str) { - - int i; - struct VelSel_info *info_ptr; - - info_ptr = (struct VelSel_info *) *handle; - if (info_ptr == NULL) return; - /*------------------------- - ** Set up the time-out - */ - if (msec_tmo < 0) { - info_ptr->tmo = -1; - }else { - info_ptr->tmo = (msec_tmo + 99)/100; /* Convert to deci-secs */ - if (info_ptr->tmo > 9999) info_ptr->tmo = 9999; - } - /*--------------------------------- - ** Set up the end-of-text string - */ - if (eot_str != NULL) { - for (i = 0; i < sizeof (info_ptr->eot); i++) info_ptr->eot[i] = '\0'; - - for (i = 0; i < sizeof (info_ptr->eot); i++) { - if (eot_str[i] == '\0') break; - info_ptr->eot[i+1] = eot_str[i]; - } - info_ptr->eot[0] = '0' + i; - } - return; - } -/* -** ------------------------------------------------------------------------- -** VelSel_ErrInfo: Return detailed status from last operation. -*/ - void VelSel_ErrInfo ( -/* ============= -*/ char **entry_txt, - int *errcode, - int *my_errno, - int *vaxc_errno) { - - int i; - char buff[80]; - int asyn_errcode, asyn_errno, asyn_vaxerrno; - char* asyn_errtxt; - - if (VelSel_call_depth <= 0) { - strcpy (VelSel_routine[0], "VelSel_no_error_detected"); - *errcode = 0; - *my_errno = 0; - *vaxc_errno = 0; - }else { - if (VelSel_call_depth > 1) { /* Concatenate the names */ - for (i = 1; i < VelSel_call_depth; i++) { - strcat (VelSel_routine[0], "/"); - StrJoin (VelSel_routine[0], sizeof (VelSel_routine), - VelSel_routine[0], VelSel_routine[i]); - } - } - *errcode = VelSel_errcode; - *my_errno = VelSel_errno; - *vaxc_errno = VelSel_vaxc_errno; - switch (VelSel_errcode) { - case VELSEL__BAD_TMO: strcpy (buff, "/VELSEL__BAD_TMO"); break; - case VELSEL__BAD_CMD: strcpy (buff, "/VELSEL__BAD_CMD"); break; - case VELSEL__BAD_OFL: strcpy (buff, "/VELSEL__BAD_OFL"); break; - case VELSEL__BAD_ILLG: strcpy (buff, "/VELSEL__BAD_ILLG"); break; - case VELSEL__BAD_HOST: strcpy (buff, "/VELSEL__BAD_HOST"); break; - case VELSEL__BAD_SOCKET: strcpy (buff, "/VELSEL__BAD_SOCKET"); break; - case VELSEL__BAD_BIND: strcpy (buff, "/VELSEL__BAD_BIND"); break; - case VELSEL__BAD_CONNECT: strcpy (buff, "/VELSEL__BAD_CONNECT"); break; - case VELSEL__BAD_DEV: strcpy (buff, "/VELSEL__BAD_DEV"); break; - case VELSEL__BAD_MALLOC: strcpy (buff, "/VELSEL__BAD_MALLOC"); break; - case VELSEL__BAD_SENDLEN: strcpy (buff, "/VELSEL__BAD_SENDLEN"); break; - case VELSEL__BAD_SEND: strcpy (buff, "/VELSEL__BAD_SEND"); break; - case VELSEL__BAD_SEND_PIPE: strcpy (buff, "/VELSEL__BAD_SEND_PIPE"); break; - case VELSEL__BAD_SEND_NET: strcpy (buff, "/VELSEL__BAD_SEND_NET"); break; - case VELSEL__BAD_SEND_UNKN: strcpy (buff, "/VELSEL__BAD_SEND_UNKN"); break; - case VELSEL__BAD_RECV: strcpy (buff, "/VELSEL__BAD_RECV"); break; - case VELSEL__BAD_RECV_PIPE: strcpy (buff, "/VELSEL__BAD_RECV_PIPE"); break; - case VELSEL__BAD_RECV_NET: strcpy (buff, "/VELSEL__BAD_RECV_NET"); break; - case VELSEL__BAD_RECV_UNKN: strcpy (buff, "/VELSEL__BAD_RECV_UNKN"); break; - case VELSEL__BAD_NOT_BCD: strcpy (buff, "/VELSEL__BAD_NOT_BCD"); break; - case VELSEL__BAD_RECVLEN: strcpy (buff, "/VELSEL__BAD_RECVLEN"); break; - case VELSEL__BAD_FLUSH: strcpy (buff, "/VELSEL__BAD_FLUSH"); break; - case VELSEL__BAD_RECV1: strcpy (buff, "/VELSEL__BAD_RECV1"); break; - case VELSEL__BAD_RECV1_PIPE: strcpy (buff, "/VELSEL__BAD_RECV1_PIPE"); break; - case VELSEL__BAD_RECV1_NET: strcpy (buff, "/VELSEL__BAD_RECV1_NET"); break; - case VELSEL__BAD_PAR: strcpy (buff, "/VELSEL__BAD_PAR"); break; - case VELSEL__BAD_BSY: strcpy (buff, "/VELSEL__BAD_BSY"); break; - case VELSEL__BAD_OPEN: strcpy (buff, "/VELSEL__BAD_OPEN"); break; - case VELSEL__FORCED_CLOSED: strcpy (buff, "/VELSEL__FORCED_CLOSED"); break; - case VELSEL__BAD_STP: strcpy (buff, "/VELSEL__BAD_STP"); break; - case VELSEL__BAD_REPLY: strcpy (buff, "/VELSEL__BAD_REPLY"); break; - default: sprintf (buff, "/VELSEL__unknown_err_code: %d", VelSel_errcode); - } - StrJoin (VelSel_routine[0], sizeof(VelSel_routine), VelSel_routine[0], buff); - } - AsynSrv_ErrInfo (&asyn_errtxt, &asyn_errcode, &asyn_errno, &asyn_vaxerrno); - if (asyn_errcode != 0) { - strcat (VelSel_routine[0], "/"); - StrJoin (VelSel_routine[0], sizeof(VelSel_routine), - VelSel_routine[0], asyn_errtxt); - } - *entry_txt = VelSel_routine[0]; - VelSel_call_depth = 0; - VelSel_errcode = 0; - } -/* -**--------------------------------------------------------------------------- -** VelSel_GetReply - Get next reply from a reply buffer. -*/ - void *VelSel_GetReply ( -/* ============== -*/ void **handle, /* Pointer to structure containing - ** message to pull apart */ - void *last_rply) { /* Starting point */ - - int rply_len; - struct RS__RplyStruct *ptr; - struct VelSel_info *my_info_ptr; - struct RS__RplyStruct *my_last_rply; - - ptr = NULL; - my_info_ptr = (struct VelSel_info *) *handle; - my_last_rply = (struct RS__RplyStruct *) last_rply; - - if (my_last_rply == NULL) { /* Start with first reply? */ - /* Yes */ - if (sscanf (my_info_ptr->from_host.n_rply, "%4d", - &my_info_ptr->max_replies) != 1) my_info_ptr->max_replies = 0; - if (my_info_ptr->max_replies > 0) - ptr = (struct RS__RplyStruct *) my_info_ptr->from_host.u.rplys; - my_info_ptr->n_replies = 1; - }else { - my_info_ptr->n_replies++; - if (my_info_ptr->n_replies <= my_info_ptr->max_replies) { - if (sscanf (my_last_rply->rply_len, "%2d", &rply_len) == 1) { - ptr = - (struct RS__RplyStruct *) ((char *) my_last_rply + rply_len + 2); - } - } - } - return (void *) ptr; - } -/* -**--------------------------------------------------------------------------- -** VelSel_GetStatus: Get "???" response from Vel Selector -*/ - int VelSel_GetStatus ( -/* =============== -*/ void **handle, - char *status_str, - int status_str_len) { - - int status; - struct VelSel_info *info_ptr; - struct RS__RplyStruct *rply_ptr; - struct RS__RplyStruct *rply_ptr0; - /*---------------------------------------------- - */ - status_str[0] = '\0'; - /*---------------------------------------------- - ** Pre-set the routine name (in case of error) - */ - if (VelSel_errcode == 0 && VelSel_call_depth < 5) { - strcpy (VelSel_routine[VelSel_call_depth], "VelSel_GetStatus"); - VelSel_call_depth++; - } - /*---------------------------------------------- - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. - */ - info_ptr = (struct VelSel_info *) *handle; - if (info_ptr == NULL) { - return False; - } - if (info_ptr->asyn_info.skt <= 0) { - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - if ((VelSel_errcode == 0) && (info_ptr->asyn_info.skt < 0)) { - VelSel_errcode = VELSEL__FORCED_CLOSED; - } - return False; - } - /*---------------------------------------------- - ** Send "???" command to Velocity Selector - */ - status = VelSel_SendCmnds (handle, "???", NULL); - if (!status) { - /* Error in VelSel_SendCmnds */ - return False; - }else { - rply_ptr0 = VelSel_GetReply (handle, NULL); - if (rply_ptr0 == NULL) rply_ptr0 = (struct RS__RplyStruct *) "06\rNULL"; - StrJoin (status_str, status_str_len, rply_ptr0->rply, ""); - } - VelSel_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** VelSel_Open: Open a connection to a Velocity Selector. -*/ - int VelSel_Open ( -/* ========== -*/ void **handle, - char *host, - int port, - int chan) { - - int status; - struct VelSel_info *my_handle; - struct RS__RplyStruct *rply_ptr; - struct RS__RplyStruct *rply_ptr0; - struct RS__RplyStruct *rply_ptr1; - struct RS__RplyStruct *rply_ptr2; - struct RS__RplyStruct *rply_ptr3; -/*-------------------------------------------------------- -** Initialise the error info stack and pre-set the -** routine name (in case of error). -*/ - VelSel_errcode = VelSel_errno = VelSel_vaxc_errno = 0; - strcpy (VelSel_routine[0], "VelSel_Open"); - VelSel_call_depth = 1; -/*-------------------------------------------------------- -** Assume trouble -*/ - *handle = NULL; -/*-------------------------------------------------------- -** Reserve space for the data we need to store. -*/ - my_handle = (struct VelSel_info *) malloc (sizeof (*my_handle)); - if (my_handle == NULL) { - VelSel_errcode = VELSEL__BAD_MALLOC; /* malloc failed!! */ - return False; - } -/*-------------------------------------------------------- -** Set up the connection -*/ - StrJoin (my_handle->asyn_info.host, sizeof (my_handle->asyn_info.host), - host, ""); - my_handle->asyn_info.port = port; - my_handle->asyn_info.chan = chan; - status = AsynSrv_Open (&my_handle->asyn_info); - if (!status) { - VelSel_errcode = VELSEL__BAD_SOCKET; - GetErrno (&VelSel_errno, &VelSel_vaxc_errno); /* Save errno info */ - fprintf (stderr, "\nVelSel_Open/AsynSrv_Open: " - "Failed to make connection.\n"); - free (my_handle); - return False; - } - - my_handle->tmo = 25; /* Set a short time-out initially since - ** there should be no reason for the REM - ** command to take very long - */ - strcpy (my_handle->eot, "1\n\0\0"); - my_handle->msg_id = 0; - /* - ** Now ensure the VelSel is on-line. The first "REM" command can - ** fail due to pending characters in the VelSel input buffer causing - ** the "REM" to be corrupted. The response of the VelSel to this - ** command is ignored for this reason (but the VelSel_SendCmnds - ** status must be OK otherwise it indicates a network problem). - */ - status = VelSel_SendCmnds ((void *) &my_handle, "REM", NULL); - if (status) { - status = VelSel_SendCmnds ((void *) &my_handle, "REM", NULL); - } - if (!status) { - /* Some error occurred in VelSel_SendCmnds - Errcode will - ** have been set up there. - */ - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - return False; - } - /* - ** Check the responses carefully. - */ - rply_ptr0 = VelSel_GetReply ((void *) &my_handle, NULL); - - if (rply_ptr0 == NULL) rply_ptr0 = (struct RS__RplyStruct *) "06\rNULL"; - if (rply_ptr0->rply[0] == '?') { - VelSel_errcode = VELSEL__BAD_DEV; /* Error response - not a VelSel? */ - AsynSrv_Close (&my_handle->asyn_info, False); - free (my_handle); - return False; - } - /* - ** The connection is complete. Pass the data structure - ** back to the caller as a handle. - */ - my_handle->tmo = 100; /* Default time-out is 10 secs */ - *handle = my_handle; - VelSel_call_depth--; - return True; - } -/* -**--------------------------------------------------------------------------- -** VelSel_SendCmnds - Send commands to RS232C server. -*/ - int VelSel_SendCmnds ( -/* ================ -*/ void **handle, - ...) { /* Now we have list of commands - - ** char *txt = pntr to cmnd strng - ** Terminate list with *txt = NULL. - */ - struct VelSel_info *info_ptr; - int i, status, c_len, size, max_size, ncmnds; - int bytes_to_come, bytes_left; - char *nxt_byte_ptr; - char err_text[80]; - char text[20]; - va_list ap; /* Pointer to variable args */ - char *txt_ptr; - char *cmnd_lst_ptr; - /*---------------------------------------------- - ** Pre-set the routine name (in case of error) - */ - if (VelSel_errcode == 0 && VelSel_call_depth < 5) { - strcpy (VelSel_routine[VelSel_call_depth], "VelSel_SendCmnds"); - VelSel_call_depth++; - } - /*---------------------------------------------- - ** Do nothing if no connection - the connection gets - ** closed if an error is detected. The connection may - ** also be marked to have been forcefully closed. - */ - info_ptr = (struct VelSel_info *) *handle; - if (info_ptr == NULL) { - return False; - } - if (info_ptr->asyn_info.skt <= 0) { - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - if ((VelSel_errcode == 0) && (info_ptr->asyn_info.skt < 0)) { - VelSel_errcode = VELSEL__FORCED_CLOSED; - } - return False; - } - /*---------------------------------------------- - ** Build message for Vel Selector from the list of commands. - */ - info_ptr->n_replies = info_ptr->max_replies = 0; - - info_ptr->msg_id++; /* Set up an incrementing message id */ - if (info_ptr->msg_id > 9999) info_ptr->msg_id = 1; - sprintf (info_ptr->to_host.msg_id, "%04.4d", info_ptr->msg_id); - - memcpy (info_ptr->to_host.c_pcol_lvl, RS__PROTOCOL_ID, - sizeof (info_ptr->to_host.c_pcol_lvl)); - sprintf (info_ptr->to_host.serial_port, "%04.4d", info_ptr->asyn_info.chan); - sprintf (info_ptr->to_host.tmo, "%04.4d", info_ptr->tmo); - - memcpy (info_ptr->to_host.terms, info_ptr->eot, - sizeof (info_ptr->to_host.terms)); - memcpy (info_ptr->to_host.n_cmnds, "0000", - sizeof (info_ptr->to_host.n_cmnds)); - - va_start (ap, handle); /* Set up var arg machinery */ - - txt_ptr = va_arg (ap, char *); /* Get pntr to next cmnd string */ - ncmnds = 0; - cmnd_lst_ptr = &info_ptr->to_host.cmnds[0]; - bytes_left = sizeof (info_ptr->to_host) - - OffsetOf (struct RS__MsgStruct, cmnds[0]); - - while (txt_ptr != NULL) { - size = 2 + strlen (txt_ptr); - if (size > bytes_left) { - VelSel_errcode = VELSEL__BAD_SENDLEN; /* Too much to send */ - fprintf (stderr, "\nVelSel_SendCmnds/send: too much to send" - " - request ignored.\n"); - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return False; - }else { - strcpy (cmnd_lst_ptr+2, txt_ptr); - c_len = strlen (txt_ptr); - sprintf (text, "%02.2d", c_len); - memcpy (cmnd_lst_ptr, text, 2); - cmnd_lst_ptr = cmnd_lst_ptr + c_len + 2; - ncmnds++; - bytes_left = bytes_left - size; - txt_ptr = va_arg (ap, char *); - } - } - sprintf (text, "%04.4d", ncmnds); - memcpy (info_ptr->to_host.n_cmnds, - text, sizeof (info_ptr->to_host.n_cmnds)); - - size = cmnd_lst_ptr - info_ptr->to_host.msg_id; - size = (size + 3) & (~3); /* Round up to multiple of 4 */ - sprintf (text, "%04.4d", size); - memcpy (info_ptr->to_host.msg_size, text, 4); - - status = send (info_ptr->asyn_info.skt, - (char *) &info_ptr->to_host, size+4, 0); - if (status != (size+4)) { - GetErrno (&VelSel_errno, &VelSel_vaxc_errno); - if (status == 0) { - VelSel_errcode = VELSEL__BAD_SEND; /* Server exited (probably) */ - fprintf (stderr, "\nVelSel_SendCmnds/send: probable network problem"); - }else if (status == -1) { - if (VelSel_errno == EPIPE) { - VelSel_errcode = VELSEL__BAD_SEND_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nVelSel_SendCmnds/send: broken network pipe"); - }else { - VelSel_errcode = VELSEL__BAD_SEND_NET; /* It's some other net problem */ - perror ("VelSel_SendCmnds/send"); - } - }else { - VelSel_errcode = VELSEL__BAD_SEND_UNKN; /* TCP/IP problems */ - fprintf (stderr, "\nVelSel_SendCmnds/send: probable TCP/IP problem"); - } - VelSel_Close (handle, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - - size = sizeof (info_ptr->from_host.msg_size); - status = recv (info_ptr->asyn_info.skt, - info_ptr->from_host.msg_size, size, 0); - if (status != size) { - GetErrno (&VelSel_errno, &VelSel_vaxc_errno); - if (status == 0) { - VelSel_errcode = VELSEL__BAD_RECV; /* Server exited (probably) */ - fprintf (stderr, "\nVelSel_SendCmnds/recv: probable network problem"); - }else if (status == -1) { - if (VelSel_errno == EPIPE) { - VelSel_errcode = VELSEL__BAD_RECV_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nVelSel_SendCmnds/recv: broken network pipe"); - }else { - VelSel_errcode = VELSEL__BAD_RECV_NET; /* It's some other net problem */ - perror ("VelSel_SendCmnds/recv"); - } - }else { - VelSel_errcode = VELSEL__BAD_RECV_UNKN; /* TCP/IP problems */ - fprintf (stderr, "\nVelSel_SendCmnds/recv: probable TCP/IP problem"); - } - VelSel_Close (handle, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - if (sscanf (info_ptr->from_host.msg_size, "%4d", &bytes_to_come) != 1) { - VelSel_errcode = VELSEL__BAD_NOT_BCD; /* Header not an ASCII BCD integer */ - VelSel_Close (handle, True); /* Force close TCP/IP connection */ - fprintf (stderr, "\nVelSel_SendCmnds/recv: non-BCD byte count" - " - link to server force-closed.\n"); - return False; - } - max_size = sizeof (info_ptr->from_host) - - sizeof (info_ptr->from_host.msg_size); - if (bytes_to_come > max_size) { - VelSel_errcode = VELSEL__BAD_RECVLEN; - fprintf (stderr, "\nVelSel_SendCmnds/recv: pending message length too big" - " - flushing ...\n"); - nxt_byte_ptr = &info_ptr->from_host.msg_size[size]; - while (bytes_to_come > 0) { /* Flush out the incoming message */ - bytes_left = bytes_to_come; - if (bytes_left > max_size) bytes_left = max_size; - status = recv (info_ptr->asyn_info.skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - VelSel_errcode = VELSEL__BAD_FLUSH; /* TCP/IP problem whilst flushing */ - GetErrno (&VelSel_errno, &VelSel_vaxc_errno); - VelSel_Close (handle, True); /* Force close TCP/IP connection */ - fprintf (stderr, "\nVelSel_SendCmnds/recv: network problem during" - " flush.\nLink to server force-closed.\n"); - return False; - } - bytes_to_come = bytes_to_come - status; - } - fprintf (stderr, "\n flushed OK.\n"); - memset (info_ptr->from_host.msg_size, - '0', sizeof (info_ptr->from_host.msg_size)); - return False; - }else { - nxt_byte_ptr = &info_ptr->from_host.msg_size[size]; - bytes_left = bytes_to_come; - while (bytes_left > 0) { /* Read the rest of the response */ - status = recv (info_ptr->asyn_info.skt, nxt_byte_ptr, bytes_left, 0); - if (status <= 0) { - GetErrno (&VelSel_errno, &VelSel_vaxc_errno); - if (status == 0) { - VelSel_errcode = VELSEL__BAD_RECV1; /* Server exited (probably) */ - fprintf (stderr, "\nVelSel_SendCmnds/recv/1: probable network " - "problem"); - }else { - if (VelSel_errno == EPIPE) { - VelSel_errcode = VELSEL__BAD_RECV1_PIPE; /* Server exited (probably) */ - fprintf (stderr, "\nVelSel_SendCmnds/recv/1: broken network pipe"); - }else { - VelSel_errcode = VELSEL__BAD_RECV1_NET; /* It's some other net fault */ - perror ("VelSel_SendCmnds/recv/1"); - } - } - VelSel_Close (handle, True); /* Force close TCP/IP connection */ - fprintf (stderr, " - link to server force-closed.\n"); - return False; - } - bytes_left = bytes_left - status; - nxt_byte_ptr = nxt_byte_ptr + status; - } - if ((sscanf (info_ptr->from_host.n_rply, "%4d", - &info_ptr->max_replies) != 1) || - (info_ptr->max_replies < 0)) { - VelSel_errcode = VELSEL__BAD_REPLY; /* Reply is bad */ - if (VelSel_call_depth < 5) { /* Add reply to routine stack */ - bytes_to_come = bytes_to_come + 4; - if (bytes_to_come >= sizeof (VelSel_routine[0])) - bytes_to_come = sizeof (VelSel_routine[0]) - 1; - for (i=0; ifrom_host.msg_size[i] == '\0') - info_ptr->from_host.msg_size[i] = '.'; - } - info_ptr->from_host.msg_size[bytes_to_come] = '\0'; - strcpy (VelSel_routine[VelSel_call_depth], - info_ptr->from_host.msg_size); - VelSel_call_depth++; - } - return False; - } - } - VelSel_call_depth--; - return True; - } -/*-------------------------------------------- End of VelSel_Utility.C =======*/ diff --git a/histmem.c b/histmem.c index f94a316c..6f492749 100644 --- a/histmem.c +++ b/histmem.c @@ -60,12 +60,11 @@ #include "HistDriv.i" #include "HistMem.i" #include "histsim.h" -#include "hardsup/sinqhm.h" -#include "sinqhmdriv.i" +#include "psi/hardsup/sinqhm.h" #include "dynstring.h" #include "event.h" #include "status.h" -#include "tdchm.h" +#include "site.h" /* #define LOADDEBUG 1 */ @@ -385,7 +384,8 @@ pHistMem CreateHistMemory(char *driver) { pHistMem pNew = NULL; - + pSite site = NULL; + /* make memory */ pNew = (pHistMem)malloc(sizeof(HistMem)); if(!pNew) @@ -442,16 +442,18 @@ if(strcmp(driver,"sim") == 0) { pNew->pDriv = CreateSIMHM(pNew->pOption); - } - else if(strcmp(driver,"sinqhm") == 0) + } + else { - pNew->pDriv = CreateSINQDriver(pNew->pOption); + site = getSite(); + if(site != NULL) + { + pNew->pDriv = site->CreateHistogramMemoryDriver(driver, + pNew->pOption); + } } - else if(strcmp(driver,"tdc") == 0) - { - pNew->pDriv = MakeTDCHM(pNew->pOption); - } - else /* no driver found */ + + if(pNew->pDriv == NULL) { DeleteDescriptor(pNew->pDes); DeleteStringDict(pNew->pOption); diff --git a/histsim.c b/histsim.c index c2846244..c1b0703a 100644 --- a/histsim.c +++ b/histsim.c @@ -217,7 +217,7 @@ pCounterDriver pDriv; pDriv = (pCounterDriver)self->pPriv; - KillSIMCounter(pDriv); + DeleteCounterDriver(pDriv); return 1; } /*------------------------------------------------------------------------*/ diff --git a/hkl.c b/hkl.c index 1b889f99..3fce290e 100644 --- a/hkl.c +++ b/hkl.c @@ -30,7 +30,7 @@ #include "matrix/matrix.h" #include "hkl.h" #include "hkl.i" - +#include "splitter.h" /* the space we leave in omega in order to allow for a scan to be done */ @@ -1140,29 +1140,6 @@ ente: return 1; } /*--------------------------------------------------------------------------*/ - int isNumeric(char *pText) - { - int i, ii, iGood; - static char pNum[13] = {"1234567890.+-"}; - - for(i = 0; i < strlen(pText); i++) - { - for(ii = 0; ii < 13; ii++) - { - iGood = 0; - if(pText[i] == pNum[ii]) - { - iGood = 1; - break; - } - } - if(!iGood) - { - return 0; - } - } - return 1; - } /*--------------------------------------------------------------------------*/ static int GetCommandData(int argc, char *argv[], float fHKL[3], diff --git a/itc4.c b/itc4.c deleted file mode 100644 index 35dbfca0..00000000 --- a/itc4.c +++ /dev/null @@ -1,281 +0,0 @@ -/*--------------------------------------------------------------------------- - I T C 4 - - This is the implementation for a ITC4 object derived from an more general - environment controller. - - Mark Koennecke, August 1997 - - Copyright: - - Labor fuer Neutronenstreuung - Paul Scherrer Institut - CH-5423 Villigen-PSI - - - The authors hereby grant permission to use, copy, modify, distribute, - and license this software and its documentation for any purpose, provided - that existing copyright notices are retained in all copies and that this - notice is included verbatim in any distributions. No written agreement, - license, or royalty fee is required for any of the authorized uses. - Modifications to this software may be copyrighted by their authors - and need not follow the licensing terms described here, provided that - the new terms are clearly indicated on the first page of each file where - they apply. - - IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY - FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY - DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - - THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE - IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE - NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR - MODIFICATIONS. -----------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include "fortify.h" -#include "sics.h" -#include "splitter.h" -#include "obpar.h" -#include "devexec.h" -#include "nserver.h" -#include "interrupt.h" -#include "emon.h" -#include "evcontroller.h" -#include "evcontroller.i" -#include "itc4.h" - -/*---------------------------------------------------------------------------*/ - int ITC4SetPar(pEVControl self, char *name, float fNew, SConnection *pCon) - { - int iRet; - - /* check authorsisation */ - if(!SCMatchRights(pCon,usUser)) - { - SCWrite(pCon,"ERROR: you are not authorised to change this parameter", - eError); - return 0; - } - - /* just catch those three names which we understand */ - if(strcmp(name,"sensor") == 0) - { - iRet = SetSensorITC4(self->pDriv,(int)fNew); - if(!iRet) - { - SCWrite(pCon,"ERROR: value out of range",eError); - return 0; - } - iRet = ConfigITC4(self->pDriv); - if(iRet != 1) - { - SCWrite(pCon,"ERROR: ITC4 configuration failed! ",eError); - SCWrite(pCon,"INFO: Probably comm problem, Retry!",eError); - return 0; - } - SCSendOK(pCon); - return 1; - } - else if(strcmp(name,"control") == 0) - { - iRet = SetControlITC4(self->pDriv,(int)fNew); - if(!iRet) - { - SCWrite(pCon,"ERROR: value out of range",eError); - return 0; - } - iRet = ConfigITC4(self->pDriv); - if(iRet != 1) - { - SCWrite(pCon,"ERROR: ITC4 configuration failed! ",eError); - SCWrite(pCon,"INFO: Probably comm problem, Retry!",eError); - return 0; - } - SCSendOK(pCon); - return 1; - } - else if(strcmp(name,"timeout") == 0) - { - iRet = SetTMOITC4(self->pDriv,(int)fNew); - if(!iRet) - { - SCWrite(pCon,"ERROR: value out of range",eError); - return 0; - } - iRet = ConfigITC4(self->pDriv); - if(iRet != 1) - { - SCWrite(pCon,"ERROR: ITC4 configuration failed! ",eError); - SCWrite(pCon,"INFO: Probably comm problem, Retry!",eError); - return 0; - } - SCSendOK(pCon); - return 1; - } - else if(strcmp(name,"divisor") == 0) - { - iRet = SetDivisorITC4(self->pDriv,fNew); - if(!iRet) - { - SCWrite(pCon,"ERROR: value out of range",eError); - return 0; - } - iRet = ConfigITC4(self->pDriv); - if(iRet != 1) - { - SCWrite(pCon,"ERROR: ITC4 configuration failed! ",eError); - SCWrite(pCon,"INFO: Probably comm problem, Retry!",eError); - return 0; - } - SCSendOK(pCon); - return 1; - } - else if(strcmp(name,"multiplicator") == 0) - { - iRet = SetMultITC4(self->pDriv,fNew); - if(!iRet) - { - SCWrite(pCon,"ERROR: value out of range",eError); - return 0; - } - iRet = ConfigITC4(self->pDriv); - if(iRet != 1) - { - SCWrite(pCon,"ERROR: ITC4 configuration failed! ",eError); - SCWrite(pCon,"INFO: Probably comm problem, Retry!",eError); - return 0; - } - SCSendOK(pCon); - return 1; - } - else - return EVCSetPar(self,name,fNew,pCon); - } -/*--------------------------------------------------------------------------*/ - int ITC4GetPar(pEVControl self, char *name, float *fNew) - { - int iRet; - float fDiv; - - /* just catch those two names which we understand */ - if(strcmp(name,"sensor") == 0) - { - iRet = GetSensorITC4(self->pDriv); - *fNew = (float)iRet; - return 1; - } - else if(strcmp(name,"control") == 0) - { - iRet = GetControlITC4(self->pDriv); - *fNew = (float)iRet; - return 1; - } - else if(strcmp(name,"timeout") == 0) - { - iRet = GetTMOITC4(self->pDriv); - *fNew = (float)iRet; - return 1; - } - else if(strcmp(name,"divisor") == 0) - { - fDiv = GetDivisorITC4(self->pDriv); - *fNew = fDiv; - return 1; - } - else if(strcmp(name,"multiplicator") == 0) - { - fDiv = GetMultITC4(self->pDriv); - *fNew = fDiv; - return 1; - } - else - return EVCGetPar(self,name,fNew); - } -/*---------------------------------------------------------------------------*/ - int ITCList(pEVControl self, SConnection *pCon) - { - char pBueffel[132]; - int iRet; - - iRet = EVCList(self,pCon); - sprintf(pBueffel,"%s.sensor = %d\n",self->pName, - GetSensorITC4(self->pDriv)); - SCWrite(pCon,pBueffel,eValue); - sprintf(pBueffel,"%s.control = %d\n",self->pName, - GetControlITC4(self->pDriv)); - SCWrite(pCon,pBueffel,eValue); - sprintf(pBueffel,"%s.timeout = %d\n",self->pName, - GetTMOITC4(self->pDriv)); - SCWrite(pCon,pBueffel,eValue); - sprintf(pBueffel,"%s.divisor = %f\n",self->pName, - GetDivisorITC4(self->pDriv)); - SCWrite(pCon,pBueffel,eValue); - sprintf(pBueffel,"%s.multiplicator = %f\n",self->pName, - GetMultITC4(self->pDriv)); - SCWrite(pCon,pBueffel,eValue); - return iRet; - } -/*-------------------------------------------------------------------------*/ - int ITC4Wrapper(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - pEVControl self = NULL; - char pBueffel[256]; - int iRet; - double fNum; - float fVal; - - self = (pEVControl)pData; - assert(self); - assert(pCon); - assert(pSics); - - if(argc < 2) - { - return EVControlWrapper(pCon,pSics,pData,argc,argv); - } - - strtolower(argv[1]); - if((strcmp(argv[1],"sensor") == 0) || (strcmp(argv[1],"control") == 0) || - (strcmp(argv[1],"timeout") == 0) || (strcmp(argv[1],"divisor") == 0) || - (strcmp(argv[1],"multiplicator") == 0) ) - { - if(argc > 2) /* set case */ - { - iRet = Tcl_GetDouble(pSics->pTcl,argv[2],&fNum); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: expected number, got %s",argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - return ITC4SetPar(self,argv[1],(float)fNum,pCon); - } - else /* get case */ - { - iRet = ITC4GetPar(self,argv[1],&fVal); - sprintf(pBueffel,"%s.%s = %f\n",self->pName, - argv[1],fVal); - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } - else if(strcmp(argv[1],"list") == 0) - { - return ITCList(self,pCon); - } - else - { - return EVControlWrapper(pCon,pSics,pData,argc,argv); - } - /* not reached */ - return 0; - } diff --git a/itc4.h b/itc4.h deleted file mode 100644 index 1068ef3d..00000000 --- a/itc4.h +++ /dev/null @@ -1,43 +0,0 @@ - -/*------------------------------------------------------------------------- - ITC 4 - - Support for Oxford Instruments ITC4 Temperature controllers for SICS. - The meaning and working of the functions defined is as desribed for a - general environment controller. - - Mark Koennecke, Juli 1997 - - copyright: see implementation file. - ------------------------------------------------------------------------------*/ -#ifndef SICSITC4 -#define SICSITC4 -/*------------------------- The Driver ------------------------------------*/ - - pEVDriver CreateITC4Driver(int argc, char *argv[]); - int ConfigITC4(pEVDriver self); - int SetSensorITC4(pEVDriver self, int iSensor); - int SetControlITC4(pEVDriver self, int iSensor); - int GetSensorITC4(pEVDriver self); - int GetControlITC4(pEVDriver self); - int SetDivisorITC4(pEVDriver self, float iSensor); - float GetDivisorITC4(pEVDriver self); - int SetMultITC4(pEVDriver self, float iSensor); - float GetMultITC4(pEVDriver self); - int SetTMOITC4(pEVDriver self, int iSensor); - int GetTMOITC4(pEVDriver self); - - -/*------------------------- The ITC4 object ------------------------------*/ - - int ITC4Wrapper(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - int ITC4SetPar(pEVControl self, char *name, float fNew, - SConnection *pCon); - int ITC4GetPar(pEVControl self, char *name, float *fVal); - int ITCList(pEVControl self, SConnection *pCon); - - -#endif - diff --git a/itc4.w b/itc4.w deleted file mode 100644 index 98d83f9e..00000000 --- a/itc4.w +++ /dev/null @@ -1,74 +0,0 @@ -\subsubsection{Oxford Instruments ITC4 Temperature Controllers} -SINQ makes heavy use of Oxford Instruments ITC4 temperature controllers. In -order to support them the following software components had to be defined in -addition to the basic environmet controller interfaces: -\begin{itemize} -\item ITC4driver, naturally. -\item A ITC4-controller object as derivation of environment controller. ITC4 -'s allow you to select a sensor which you read as your standard sensor and a -sensor which is used for automatic control. The ITC4 controller object adds -just that additional functionality to the statndard environment controller. -\end{itemize} -The additional data, the selection of sensors, will be kept in the driver. -This serves also an example for implementing inheritance without C++. - -The driver interface: -@d itcd @{ - pEVDriver CreateITC4Driver(int argc, char *argv[]); - int ConfigITC4(pEVDriver self); - int SetSensorITC4(pEVDriver self, int iSensor); - int SetControlITC4(pEVDriver self, int iSensor); - int GetSensorITC4(pEVDriver self); - int GetControlITC4(pEVDriver self); - int SetDivisorITC4(pEVDriver self, float iSensor); - float GetDivisorITC4(pEVDriver self); - int SetMultITC4(pEVDriver self, float iSensor); - float GetMultITC4(pEVDriver self); - int SetTMOITC4(pEVDriver self, int iSensor); - int GetTMOITC4(pEVDriver self); - -@} - -The ConfigITC4 is special. It has to be called to commit changes to the -driver read and control parameters. - -The ITC4 object interface: -@d itco @{ - int ITC4Wrapper(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - int ITC4SetPar(pEVControl self, char *name, float fNew, - SConnection *pCon); - int ITC4GetPar(pEVControl self, char *name, float *fVal); - int ITCList(pEVControl self, SConnection *pCon); -@} - -The functions defined are: new parameter handling functions, with just -support for the two extra parameters added and a new Wrapper function for -SICS. The meaning of all these functions, their parameters and return values -are identical to those defined for an environment controller. Additionally, -the standard environment controller functions will work as described. The -functions described above are just needed to implement the extra parameters. - -@o itc4.h @{ -/*------------------------------------------------------------------------- - ITC 4 - - Support for Oxford Instruments ITC4 Temperature controllers for SICS. - The meaning and working of the functions defined is as desribed for a - general environment controller. - - Mark Koennecke, Juli 1997 - - copyright: see implementation file. - ------------------------------------------------------------------------------*/ -#ifndef SICSITC4 -#define SICSITC4 -/*------------------------- The Driver ------------------------------------*/ -@ -/*------------------------- The ITC4 object ------------------------------*/ -@ - -#endif - -@} diff --git a/itc4driv.c b/itc4driv.c deleted file mode 100644 index 37c654fe..00000000 --- a/itc4driv.c +++ /dev/null @@ -1,470 +0,0 @@ -/*-------------------------------------------------------------------------- - I T C 4 D R I V - - This file contains the implementation of a driver for the Oxford - Instruments ITC4 Temperature controller. - - - Mark Koennecke, Juli 1997 - - Copyright: - - Labor fuer Neutronenstreuung - Paul Scherrer Institut - CH-5423 Villigen-PSI - - - The authors hereby grant permission to use, copy, modify, distribute, - and license this software and its documentation for any purpose, provided - that existing copyright notices are retained in all copies and that this - notice is included verbatim in any distributions. No written agreement, - license, or royalty fee is required for any of the authorized uses. - Modifications to this software may be copyrighted by their authors - and need not follow the licensing terms described here, provided that - the new terms are clearly indicated on the first page of each file where - they apply. - - IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY - FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY - DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - - THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE - IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE - NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR - MODIFICATIONS. -----------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include -#include "fortify.h" -#include "conman.h" -#include "servlog.h" -#include "fortify.h" - - typedef struct __EVDriver *pEVDriver; - -#include "evdriver.i" -#include "hardsup/itc4util.h" -#include "hardsup/el734_def.h" -#include "hardsup/el734fix.h" -#define SHITTYVALUE -777 -/*------------------------- The Driver ------------------------------------*/ - - pEVDriver CreateITC4Driver(int argc, char *argv[]); - int ConfigITC4(pEVDriver self); - - -/*-----------------------------------------------------------------------*/ - typedef struct { - pITC4 pData; - char *pHost; - int iPort; - int iChannel; - int iControl; - float fDiv; - float fMult; - int iRead; - int iTmo; - int iLastError; - } ITC4Driv, *pITC4Driv; -/*----------------------------------------------------------------------------*/ - static int GetITC4Pos(pEVDriver self, float *fPos) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv)self->pPrivate; - assert(pMe); - - iRet = ITC4_Read(&pMe->pData,fPos); - if(iRet != 1 ) - { - pMe->iLastError = iRet; - return 0; - } - if( (*fPos < 0) || (*fPos > 10000) ) - { - *fPos = -999.; - pMe->iLastError = SHITTYVALUE; - return 0; - } - return 1; - } -/*----------------------------------------------------------------------------*/ - static int ITC4Run(pEVDriver self, float fVal) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - iRet = ITC4_Set(&pMe->pData,fVal); - if(iRet != 1) - { - pMe->iLastError = iRet; - return 0; - } - return 1; - } -/*--------------------------------------------------------------------------*/ - static int ITC4Error(pEVDriver self, int *iCode, char *error, int iErrLen) - { - pITC4Driv pMe = NULL; - - assert(self); - pMe = (pITC4Driv)self->pPrivate; - assert(pMe); - - *iCode = pMe->iLastError; - if(pMe->iLastError == SHITTYVALUE) - { - strncpy(error,"Invalid temperature returned form ITC4, check sensor",iErrLen); - } - else - { - ITC4_ErrorTxt(&pMe->pData,pMe->iLastError,error,iErrLen); - } - return 1; - } -/*--------------------------------------------------------------------------*/ - static int ITC4Send(pEVDriver self, char *pCommand, char *pReply, int iLen) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - iRet = ITC4_Send(&pMe->pData,pCommand, pReply,iLen); - if(iRet != 1) - { - pMe->iLastError = iRet; - return 0; - } - return 1; - - } -/*--------------------------------------------------------------------------*/ - static int ITC4Init(pEVDriver self) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - pMe->pData = NULL; - iRet = ITC4_Open(&pMe->pData, pMe->pHost, pMe->iPort, pMe->iChannel,0); - if(iRet != 1) - { - if(iRet == ITC4__NOITC) - { - return -1; - } - else - { - pMe->iLastError = iRet; - return 0; - } - } - return 1; - } -/*--------------------------------------------------------------------------*/ - static int ITC4Close(pEVDriver self) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - ITC4_Close(&pMe->pData); - return 1; - } -/*---------------------------------------------------------------------------*/ - static int ITC4Fix(pEVDriver self, int iError) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - switch(iError) - { - /* network errors */ - case EL734__BAD_FLUSH: - case EL734__BAD_RECV: - case EL734__BAD_RECV_NET: - case EL734__BAD_RECV_UNKN: - case EL734__BAD_RECVLEN: - case EL734__BAD_RECV1: - case EL734__BAD_RECV1_PIPE: - case EL734__BAD_RNG: - case EL734__BAD_SEND: - case EL734__BAD_SEND_PIPE: - case EL734__BAD_SEND_NET: - case EL734__BAD_SEND_UNKN: - case EL734__BAD_SENDLEN: - ITC4Close(self); - iRet = ITC4Init(self); - if(iRet) - { - return DEVREDO; - } - else - { - return DEVFAULT; - } - break; - /* handable protocoll errors */ - case EL734__BAD_TMO: - return DEVREDO; - break; - case -501: /* Bad_COM */ - return DEVREDO; - case -504: /* Badly formatted */ - return DEVREDO; - default: - return DEVFAULT; - break; - } - return DEVFAULT; - } - -/*--------------------------------------------------------------------------*/ - static int ITC4Halt(pEVDriver *self) - { - assert(self); - - return 1; - } -/*------------------------------------------------------------------------*/ - void KillITC4(void *pData) - { - pITC4Driv pMe = NULL; - - pMe = (pITC4Driv)pData; - assert(pMe); - - if(pMe->pHost) - { - free(pMe->pHost); - } - free(pMe); - } -/*------------------------------------------------------------------------*/ - pEVDriver CreateITC4Driver(int argc, char *argv[]) - { - pEVDriver pNew = NULL; - pITC4Driv pSim = NULL; - - /* check for arguments */ - if(argc < 3) - { - return NULL; - } - - pNew = CreateEVDriver(argc,argv); - pSim = (pITC4Driv)malloc(sizeof(ITC4Driv)); - memset(pSim,0,sizeof(ITC4Driv)); - if(!pNew || !pSim) - { - return NULL; - } - pNew->pPrivate = pSim; - pNew->KillPrivate = KillITC4; - - /* initalise pITC4Driver */ - pSim->iControl = 1; - pSim->iRead = 1; - pSim->iLastError = 0; - pSim->iTmo = 10; - pSim->fDiv = 10.; - pSim->fMult = 10; - pSim->pHost = strdup(argv[0]); - pSim->iPort = atoi(argv[1]); - pSim->iChannel = atoi(argv[2]); - - - /* initialise function pointers */ - pNew->SetValue = ITC4Run; - pNew->GetValue = GetITC4Pos; - pNew->Send = ITC4Send; - pNew->GetError = ITC4Error; - pNew->TryFixIt = ITC4Fix; - pNew->Init = ITC4Init; - pNew->Close = ITC4Close; - - return pNew; - } -/*--------------------------------------------------------------------------*/ - int ConfigITC4(pEVDriver self) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - iRet = ITC4_Config(&pMe->pData, pMe->iTmo, pMe->iRead, - pMe->iControl,pMe->fDiv,pMe->fMult); - if(iRet < 0) - { - pMe->iLastError = iRet; - return 0; - } - return 1; - } -/*-------------------------------------------------------------------------*/ - int SetSensorITC4(pEVDriver self, int iSensor) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - if( (iSensor < 1) || (iSensor > 4) ) - { - return 0; - } - pMe->iRead = iSensor; - return 1; - } -/*-------------------------------------------------------------------------*/ - int SetControlITC4(pEVDriver self, int iSensor) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - if( (iSensor < 1) || (iSensor > 4) ) - { - return 0; - } - pMe->iControl = iSensor; - return 1; - } -/*-------------------------------------------------------------------------*/ - int SetTMOITC4(pEVDriver self, int iSensor) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - if(iSensor < 10) - { - return 0; - } - pMe->iTmo = iSensor; - return 1; - } -/*-------------------------------------------------------------------------*/ - int GetControlITC4(pEVDriver self) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - return pMe->iControl; - } -/*-------------------------------------------------------------------------*/ - int GetSensorITC4(pEVDriver self) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - return pMe->iRead; - } -/*-------------------------------------------------------------------------*/ - int GetTMOITC4(pEVDriver self) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - return pMe->iTmo; - } -/*-------------------------------------------------------------------------*/ - float GetDivisorITC4(pEVDriver self) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - return pMe->fDiv; - } -/*--------------------------------------------------------------------------*/ - int SetDivisorITC4(pEVDriver self, float fDiv) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - pMe->fDiv = fDiv; - return 1; - } -/*-------------------------------------------------------------------------*/ - float GetMultITC4(pEVDriver self) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - return pMe->fMult; - } -/*--------------------------------------------------------------------------*/ - int SetMultITC4(pEVDriver self, float fDiv) - { - pITC4Driv pMe = NULL; - int iRet; - - assert(self); - pMe = (pITC4Driv )self->pPrivate; - assert(pMe); - - pMe->fMult = fDiv; - return 1; - } - \ No newline at end of file diff --git a/ltc11.c b/ltc11.c deleted file mode 100644 index 95929b54..00000000 --- a/ltc11.c +++ /dev/null @@ -1,828 +0,0 @@ -/*------------------------------------------------------------------------- - L T C 1 1 - an environment control device driver for a Neocera LTC-11 temperature - controller. - - copyright: see copyright.h - - Mark Koennecke, November 1998 ----------------------------------------------------------------------------*/ -#include -#include -#include -#include -#include -#include -#include "fortify.h" -#include "sics.h" -#include "obpar.h" -#include "evcontroller.h" -#include "evcontroller.i" -#include "evdriver.i" -#include "hardsup/serialsinq.h" -#include "hardsup/el734_errcodes.h" -#include "hardsup/el734fix.h" -#include "ltc11.h" - -/* -#define debug 1 -*/ -/*----------------------------------------------------------------------- - The LTC11 Data Structure -*/ - typedef struct { - void *pData; - char *pHost; - int iPort; - int iChannel; - int iMode; - int iSensor; - int iControlHeat; - int iControlAnalog; - int iLastError; - time_t lastRequest; - float fLast; - } LTC11Driv, *pLTC11Driv; -/*----------------------------------------------------------------------- - A couple of defines for LTC11 modes and special error conditions -*/ -#define ANALOG 2 -#define HEATER 1 -#define MISERABLE 3 - -/* errors */ -#define BADSTATE -920 -#define NOCONN -921 -#define BADANSWER -923 -#define BADCONFIRM -924 -/*-----------------------------------------------------------------------*/ - static void LTC11Unlock(pLTC11Driv self) - { - SerialNoReply(&(self->pData),"SLLOCK 0;"); - } - -/*------------------------------------------------------------------------- - The LTC11 can either control a heater or an analog output. It is a common - task to figure out which mode is active. If the value returned from QOUT - is 3, no sensor is defined, if it is 6 it is in monitor mode, in both cases - control is NOT there. -*/ - int LTC11GetMode(pEVDriver pEva, int *iMode) - { - pLTC11Driv self = NULL; - int iRet, iiMode; - char pBueffel[80]; - - self = (pLTC11Driv)pEva->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - /* query the state, it can be in an invalid mode */ - iRet = SerialWriteRead(&(self->pData),"QISTATE?;",pBueffel,79); - LTC11Unlock(self); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - if(strcmp(pBueffel,"?TMO") == 0) - { - self->iLastError = TIMEOUT; - return 0; - } - if(sscanf(pBueffel,"%d",&iiMode) != 1) - { - self->iLastError = EL734__BAD_ILLG; - return 0; - } - if( (iiMode != 1) && (iiMode != 2) ) - { - self->iLastError = BADSTATE; - *iMode = MISERABLE; - return 0; - } - - /* check the sensor in heater mode */ - iRet = SerialWriteRead(&(self->pData),"QOUT?1;",pBueffel,79); - LTC11Unlock(self); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - if(strcmp(pBueffel,"?TMO") == 0) - { - self->iLastError = TIMEOUT; - return 0; - } - if(sscanf(pBueffel,"%d",&iiMode) != 1) - { - self->iLastError = EL734__BAD_ILLG; - return 0; - } - if( (iiMode != 3) && (iiMode != 6 ) ) - { - *iMode = HEATER; - self->iControlHeat = iiMode; - return 1; - } - - /* check the sensor in analog mode */ - iRet = SerialWriteRead(&(self->pData),"QOUT?2;",pBueffel,79); - LTC11Unlock(self); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - if(strcmp(pBueffel,"?TMO") == 0) - { - self->iLastError = TIMEOUT; - return 0; - } - if(sscanf(pBueffel,"%d",&iiMode) != 1) - { - self->iLastError = EL734__BAD_ILLG; - return 0; - } - if( (iiMode != 3) && (iiMode != 6 ) ) - { - *iMode = ANALOG; - self->iControlAnalog = iiMode; - return 1; - } - /* if we are here something is very bad */ - self->iLastError = BADSTATE; - return 0; - } -/*----------------------------------------------------------------------- - iMode below 10 will be interpreted as heater control, above 10 as analog - control. -*/ - int LTC11SetMode(pEVDriver pEva, int iMode) - { - pLTC11Driv self = NULL; - int iRet, iiMode; - char pBueffel[80], pCommand[20]; - - self = (pLTC11Driv)pEva->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - if(iMode < 10) /* heater mode */ - { - sprintf(pCommand,"SHCONT%1.1d;",iMode); - iRet = SerialNoReply(&(self->pData),pCommand); - LTC11Unlock(self); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - return 1; - } - else - { - iMode -= 10; - sprintf(pCommand,"SACONT%1.1d;",iMode); - iRet = SerialNoReply(&(self->pData),pCommand); - LTC11Unlock(self); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - return 1; - } - /* should not get here */ - self->iLastError = BADSTATE; - return 0; - } -/*-------------------------------------------------------------------------*/ - static int LTC11Get(pEVDriver pEva, float *fValue) - { - pLTC11Driv self = NULL; - int iRet; - char pBueffel[80]; - char pCommand[46]; - char c; - float fVal; - - self = (pLTC11Driv)pEva->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - if(time(NULL) < self->lastRequest) - { - *fValue = self->fLast; - return 1; - } - else - { - self->lastRequest = time(NULL) + 5; /* buffer 5 seconds */ - } - sprintf(pCommand,"QSAMP?%1.1d;",self->iSensor); - iRet = SerialWriteRead(&(self->pData),pCommand,pBueffel,79); - LTC11Unlock(self); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - if(strcmp(pBueffel,"?TMO") == 0) - { - self->iLastError = TIMEOUT; - return 0; - } - iRet = sscanf(pBueffel,"%f%c",fValue,&c); - if(iRet != 2) - { - self->iLastError = BADANSWER; - return 0; - } - if( (c != 'K') && (c != 'C') && (c != 'F') && (c != 'N') - && (c != 'V') && (c != 'O') ) - { - self->iLastError = BADANSWER; - return 0; - } - self->fLast = *fValue; - return 1; - } -/*-------------------------------------------------------------------------*/ - static int LTC11Run(pEVDriver pEva, float fVal) - { - pLTC11Driv self = NULL; - int iRet, iMode; - char pBueffel[80]; - char pCommand[40]; - float fTest = 0.0, fDelta; - - self = (pLTC11Driv)pEva->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - /* find our operation mode */ - iRet = LTC11GetMode(pEva,&iMode); - if( (iRet < 1) || (iMode == MISERABLE) ) - { - return 0; - } - - /* format command */ - sprintf(pCommand,"SETP %d,%f;",iMode, fVal); - - /* send command */ - iRet = SerialNoReply(&(self->pData),pCommand); - if(iRet != 1) - { - self->iLastError = iRet; - LTC11Unlock(self); - return 0; - } - - /* read back */ - sprintf(pCommand,"QSETP?%d;", iMode); - iRet = SerialWriteRead(&(self->pData),pCommand,pBueffel,79); - LTC11Unlock(self); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - - /* check confirmation */ - if(strcmp(pBueffel,"?TMO") == 0) - { - self->iLastError = TIMEOUT; - return 0; - } - sscanf(pBueffel,"%f",&fTest); - fDelta = fVal - fTest; - if(fDelta < 0.0) - fDelta = -fDelta; - - if(fDelta > 0.1) - { - self->iLastError = BADCONFIRM; - return 0; - } - - return 1; - } -/*------------------------------------------------------------------------*/ - static int LTC11Error(pEVDriver pEva, int *iCode, char *pError, - int iErrLen) - { - pLTC11Driv self = NULL; - - self = (pLTC11Driv)pEva->pPrivate; - assert(self); - - *iCode = self->iLastError; - switch(*iCode) - { - case NOCONN: - strncpy(pError,"No Connection to Bruker Controller",iErrLen); - break; - case MISERABLE: - case BADSTATE: - strncpy(pError,"The LTC-11 is in a very bad state",iErrLen); - break; - case BADANSWER: - strncpy(pError,"The LTC-11 returned a bad reply",iErrLen); - break; - case BADCONFIRM: - strncpy(pError,"The LTC-11 did not accept the new set point",iErrLen); - break; - case TIMEOUT: - strncpy(pError,"Timeout receiving data from LTC-11",iErrLen); - break; - default: - SerialError(*iCode,pError,iErrLen); - break; - } - return 1; - } -/*---------------------------------------------------------------------------*/ - static int LTC11Send(pEVDriver pEva, char *pCommand, char *pReply, - int iReplyLen) - { - pLTC11Driv self = NULL; - int iRet; - - self = (pLTC11Driv)pEva->pPrivate; - assert(self); - - if(self->pData == NULL) - { - self->iLastError = NOCONN; - return 0; - } - - - iRet = SerialWriteRead(&(self->pData),pCommand, pReply, iReplyLen); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - return 1; - } -/*--------------------------------------------------------------------------*/ - static int LTC11Init(pEVDriver pEva) - { - pLTC11Driv self = NULL; - int iRet; - char pBueffel[80], pCommand[20]; - - self = (pLTC11Driv)pEva->pPrivate; - assert(self); - - /* open port connection */ - self->pData = NULL; - iRet = SerialOpen(&(self->pData),self->pHost, self->iPort, self->iChannel); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - /* configure serial port terminators */ - SerialSendTerm(&(self->pData),";"); - SerialATerm(&(self->pData),"1;"); - SerialConfig(&(self->pData),30000); - - self->iSensor = 1; - - /* initialize control sensors to unknown, then call GetMode - to get real values - */ - self->iControlHeat = 6; - self->iControlAnalog = 6; - LTC11GetMode(pEva,&iRet); - - return 1; - } -/*-------------------------------------------------------------------------*/ - static int LTC11Close(pEVDriver pEva) - { - pLTC11Driv self = NULL; - - self = (pLTC11Driv)pEva->pPrivate; - assert(self); - - SerialClose(&(self->pData)); - self->pData = 0; - - return 1; - } -/*---------------------------------------------------------------------------*/ - static int LTC11Fix(pEVDriver self, int iError) - { - pLTC11Driv pMe = NULL; - int iRet; - char pCommand[20], pBueffel[80]; - - assert(self); - pMe = (pLTC11Driv )self->pPrivate; - assert(pMe); - - switch(iError) - { - /* network errors */ - case EL734__BAD_FLUSH: - case EL734__BAD_RECV: - case EL734__BAD_RECV_NET: - case EL734__BAD_RECV_UNKN: - case EL734__BAD_RECVLEN: - case EL734__BAD_RECV1: - case EL734__BAD_RECV1_PIPE: - case EL734__BAD_RNG: - case EL734__BAD_SEND: - case EL734__BAD_SEND_PIPE: - case EL734__BAD_SEND_NET: - case EL734__BAD_SEND_UNKN: - case EL734__BAD_SENDLEN: - LTC11Close(self); - iRet = LTC11Init(self); - if(iRet) - { - return DEVREDO; - } - else - { - return DEVFAULT; - } - break; - case EL734__FORCED_CLOSED: - case NOCONN: - iRet = LTC11Init(self); - if(iRet) - { - return DEVREDO; - } - else - { - return DEVFAULT; - } - break; - /* fixable LTC11 Errors */ - case MISERABLE: - case BADSTATE: - iRet = SerialNoReply(&(pMe->pData),"SCONT;"); - LTC11Unlock(pMe); - return DEVREDO; - break; - case BADANSWER: - case BADCONFIRM: - case TIMEOUT: - return DEVREDO; - break; - default: - return DEVFAULT; - break; - } - return DEVFAULT; - } -/*------------------------------------------------------------------------*/ - void KillLTC11(void *pData) - { - pLTC11Driv pMe = NULL; - - pMe = (pLTC11Driv)pData; - assert(pMe); - - if(pMe->pHost) - { - free(pMe->pHost); - } - free(pMe); - } -/*------------------------------------------------------------------------*/ - pEVDriver CreateLTC11Driver(int argc, char *argv[]) - { - pEVDriver pNew = NULL; - pLTC11Driv pSim = NULL; - - /* check for arguments */ - if(argc < 3) - { - return NULL; - } - - pNew = CreateEVDriver(argc,argv); - pSim = (pLTC11Driv)malloc(sizeof(LTC11Driv)); - memset(pSim,0,sizeof(LTC11Driv)); - if(!pNew || !pSim) - { - return NULL; - } - pNew->pPrivate = pSim; - pNew->KillPrivate = KillLTC11; - - /* initalise LTC11Driver */ - pSim->iLastError = 0; - pSim->pHost = strdup(argv[0]); - pSim->iPort = atoi(argv[1]); - pSim->iChannel = atoi(argv[2]); - - - /* initialise function pointers */ - pNew->SetValue = LTC11Run; - pNew->GetValue = LTC11Get; - pNew->Send = LTC11Send; - pNew->GetError = LTC11Error; - pNew->TryFixIt = LTC11Fix; - pNew->Init = LTC11Init; - pNew->Close = LTC11Close; - - return pNew; - } -/*------------------------------------------------------------------------*/ - static int LTC11AssignControl(pEVDriver pEva, int iMode, int iSensor) - { - pLTC11Driv self = NULL; - int iRet, iRead = 0; - char pBueffel[80], pCommand[50]; - - self = (pLTC11Driv)pEva->pPrivate; - assert(self); - assert( (iMode == HEATER) || (iMode == ANALOG) ); - - if(!self->pData) - { - self->iLastError = NOCONN; - return 0; - } - sprintf(pCommand,"SOSEN %d,%d;",iMode,iSensor); - iRet = SerialNoReply(&(self->pData),pCommand); - if(iRet != 1) - { - self->iLastError = iRet; - return 0; - } - sprintf(pCommand,"QOUT?%d;",iMode); - iRet = SerialWriteRead(&(self->pData),pCommand,pBueffel,79); - LTC11Unlock(self); - if(strcmp(pBueffel,"?TMO") == 0) - { - self->iLastError = TIMEOUT; - return 0; - } - sscanf(pBueffel,"%d;",&iRead); - if(iRead != iSensor) - { - self->iLastError = BADCONFIRM; - return 0; - } - if(iMode == ANALOG) - { - self->iControlAnalog = iSensor; - } - else - { - self->iControlHeat = iSensor; - } - /* switch back to control mode */ - SerialNoReply(&(self->pData),"SCONT;"); - return 1; - } -/*-------------------------------------------------------------------------- - handle LTC11 specific commands: - - sensor requests or sets read sensor - - mode requests or sets operation mode - - controlheat requests or sets sensor for heater control - - controlanalog requests or sets sensor for analog control - in all other cases fall back and call EVControllerWrapper to handle it or - eventually throw an error. -*/ - int LTC11Action(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]) - { - - pEVControl self = NULL; - int iRet, iMode; - char pBueffel[256], pError[132]; - pLTC11Driv pMe = NULL; - float fVal; - - self = (pEVControl)pData; - assert(self); - pMe = (pLTC11Driv)self->pDriv->pPrivate; - assert(pMe); - - if(argc > 1) - { - strtolower(argv[1]); -/*------ sensor */ - if(strcmp(argv[1],"sensor") == 0) - { - if(argc > 2) /* set case */ - { - /* check permission */ - if(!SCMatchRights(pCon,usUser)) - { - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[2],&iMode); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: needed integer, got %s", - argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - pMe->iSensor = iMode; - SCSendOK(pCon); - return 1; - } - else /* get case */ - { - sprintf(pBueffel,"%s.sensor = %d", argv[0],pMe->iSensor); - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } -/*------ controlanalog */ - if(strcmp(argv[1],"controlanalog") == 0) - { - if(argc > 2) /* set case */ - { - /* check permission */ - if(!SCMatchRights(pCon,usUser)) - { - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[2],&iMode); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: needed integer, got %s", - argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = LTC11AssignControl(self->pDriv,ANALOG,iMode); - if(iRet != 1) - { - self->pDriv->GetError(self->pDriv,&iMode,pError,131); - sprintf(pBueffel,"ERROR: failed to set sensor: %s",pError); - SCWrite(pCon,pBueffel,eError); - return 0; - } - SCSendOK(pCon); - return 1; - } - else /* get case */ - { - sprintf(pBueffel,"%s.controlanalog = %d", argv[0],pMe->iControlAnalog); - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } -/*------ controlheat */ - if(strcmp(argv[1],"controlheat") == 0) - { - if(argc > 2) /* set case */ - { - /* check permission */ - if(!SCMatchRights(pCon,usUser)) - { - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[2],&iMode); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: needed integer, got %s", - argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = LTC11AssignControl(self->pDriv,HEATER,iMode); - if(iRet != 1) - { - self->pDriv->GetError(self->pDriv,&iMode,pError,131); - sprintf(pBueffel,"ERROR: failed to set sensor: %s",pError); - SCWrite(pCon,pBueffel,eError); - return 0; - } - SCSendOK(pCon); - return 1; - } - else /* get case */ - { - sprintf(pBueffel,"%s.controlheat = %d", argv[0],pMe->iControlHeat); - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } -/*-------- mode */ - else if(strcmp(argv[1],"mode") == 0) - { - if(argc > 2) /* set case */ - { - /* check permission */ - if(!SCMatchRights(pCon,usUser)) - { - return 0; - } - iRet = Tcl_GetInt(pSics->pTcl,argv[2],&iMode); - if(iRet != TCL_OK) - { - sprintf(pBueffel,"ERROR: needed integer, got %s", - argv[2]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - iRet = LTC11SetMode(self->pDriv,iMode); - if(iRet != 1) - { - self->pDriv->GetError(self->pDriv,&iMode,pError,131); - sprintf(pBueffel,"ERROR: failed to set mode %s",pError); - SCWrite(pCon,pBueffel,eError); - return 0; - } - else - { - SCSendOK(pCon); - return 1; - } - } - else /* get case */ - { - iRet = LTC11GetMode(self->pDriv,&iMode); - if(iRet != 1) - { - self->pDriv->GetError(self->pDriv,&iMode,pError,131); - sprintf(pBueffel,"ERROR: failed to get mode %s",pError); - SCWrite(pCon,pBueffel,eError); - return 0; - } - if(iMode == ANALOG) - { - sprintf(pBueffel,"%s.mode = Analog Control", argv[0]); - } - else - { - sprintf(pBueffel,"%s.mode = Heater Control", argv[0]); - } - SCWrite(pCon,pBueffel,eValue); - return 1; - } - } -/*--------- list */ - else if(strcmp(argv[1],"list") == 0) - { - /* print generals first */ - EVControlWrapper(pCon,pSics,pData,argc,argv); - /* print our add on stuff */ - sprintf(pBueffel,"%s.sensor = %d",argv[0],pMe->iSensor); - SCWrite(pCon,pBueffel,eValue); - sprintf(pBueffel,"%s.controlanalog = %d",argv[0],pMe->iControlAnalog); - SCWrite(pCon,pBueffel,eValue); - sprintf(pBueffel,"%s.controlheat = %d",argv[0],pMe->iControlHeat); - SCWrite(pCon,pBueffel,eValue); - iRet = LTC11GetMode(self->pDriv,&iMode); - if(iRet != 1) - { - self->pDriv->GetError(self->pDriv,&iMode,pError,131); - sprintf(pBueffel,"ERROR: failed to get mode %s",pError); - SCWrite(pCon,pBueffel,eError); - } - if(iMode == ANALOG) - { - sprintf(pBueffel,"%s.mode = Analog Control", argv[0]); - } - else - { - sprintf(pBueffel,"%s.mode = Heater Control", argv[0]); - } - SCWrite(pCon,pBueffel,eValue); - return 1; - } - else - { - return EVControlWrapper(pCon,pSics,pData,argc,argv); - } - } - return EVControlWrapper(pCon,pSics,pData,argc,argv); - } diff --git a/ltc11.h b/ltc11.h deleted file mode 100644 index 4b8ed779..00000000 --- a/ltc11.h +++ /dev/null @@ -1,24 +0,0 @@ -/*------------------------------------------------------------------------- - L T C 1 1 - - An environment control driver and an additonal wrapper function for - controlling a Neocera LTC-11 temperature controller. This controller can be - in two states: control via a heater channel or control via a analaog - channel. - - copyright: see copyright.h - - Mark Koennecke, November 1998 ----------------------------------------------------------------------------*/ -#ifndef LTC11 -#define LTC11 - - pEVDriver CreateLTC11Driver(int argc, char *argv[]); - - int LTC11GetMode(pEVDriver self, int *iMode); - int LTC11SetMode(pEVDriver self, int iMode); - - int LTC11Action(SConnection *pCon, SicsInterp *pSics, void *pData, - int argc, char *argv[]); - -#endif diff --git a/macro.c b/macro.c index 33460618..9641091c 100644 --- a/macro.c +++ b/macro.c @@ -873,3 +873,13 @@ SCWrite(pCon,"TRANSACTIONFINISHED",eError); return iRet; } + + + + + + + + + + diff --git a/make_gen b/make_gen index 2a22935b..8083f39c 100644 --- a/make_gen +++ b/make_gen @@ -11,30 +11,29 @@ SOBJ = network.o ifile.o conman.o SCinter.o splitter.o passwd.o \ sicsexit.o costa.o task.o $(FORTIFYOBJ)\ macro.o ofac.o obpar.o obdes.o drive.o status.o intserv.o \ devexec.o mumo.o mumoconf.o selector.o selvar.o fupa.o lld.o \ - lld_blob.o buffer.o strrepl.o ruli.o lin2ang.o fomerge.o\ + lld_blob.o strrepl.o lin2ang.o fomerge.o\ script.o o2t.o alias.o napi.o nxdata.o stringdict.o sdynar.o\ - histmem.o histdriv.o histsim.o sinqhmdriv.o interface.o callback.o \ + histmem.o histdriv.o histsim.o interface.o callback.o \ event.o emon.o evcontroller.o evdriver.o simev.o perfmon.o \ - danu.o itc4driv.o itc4.o nxdict.o nxsans.o varlog.o stptok.o nread.o \ - dilludriv.o scan.o fitcenter.o telnet.o token.o scontroller.o serial.o \ - tclev.o hkl.o integrate.o optimise.o dynstring.o nextrics.o nxutil.o \ - mesure.o uubuffer.o serialwait.o commandlog.o sps.o udpquieck.o \ - sanswave.o faverage.o bruker.o rmtrail.o fowrite.o ltc11.o \ - simchop.o choco.o chadapter.o docho.o trim.o eurodriv.o scaldate.o \ - hklscan.o xytable.o amor2t.o nxamor.o amorscan.o amorstat.o \ - circular.o el755driv.o maximize.o sicscron.o tecsdriv.o sanscook.o \ - tasinit.o tasutil.o t_rlp.o t_conv.o d_sign.o d_mod.o \ - tasdrive.o tasscan.o synchronize.o definealias.o swmotor.o t_update.o \ - hmcontrol.o userscan.o slsmagnet.o rs232controller.o lomax.o \ - polterwrite.o fourlib.o motreg.o motreglist.o anticollider.o \ - s_rnge.o sig_die.o gpibcontroller.o $(NIOBJ) ecb.o ecbdriv.o \ - ecbcounter.o hmdata.o tdchm.o nxscript.o A1931.o frame.o \ + danu.o nxdict.o varlog.o stptok.o nread.o \ + scan.o fitcenter.o telnet.o token.o \ + tclev.o hkl.o integrate.o optimise.o dynstring.o nxutil.o \ + mesure.o uubuffer.o commandlog.o udpquieck.o \ + rmtrail.o \ + simchop.o choco.o chadapter.o trim.o scaldate.o \ + hklscan.o xytable.o \ + circular.o maximize.o sicscron.o \ + t_rlp.o t_conv.o d_sign.o d_mod.o \ + synchronize.o definealias.o t_update.o \ + hmcontrol.o userscan.o rs232controller.o lomax.o \ + fourlib.o motreg.o motreglist.o anticollider.o \ + s_rnge.o sig_die.o gpibcontroller.o $(NIOBJ) \ + hmdata.o nxscript.o \ tclintimpl.o sicsdata.o -MOTOROBJ = motor.o el734driv.o simdriv.o el734dc.o pipiezo.o pimotor.o +MOTOROBJ = motor.o simdriv.o COUNTEROBJ = countdriv.o simcter.o counter.o -DMCOBJ = dmc.o -VELOOBJ = velo.o velosim.o velodorn.o velodornier.o +VELOOBJ = velo.o velosim.o .SUFFIXES: .SUFFIXES: .tcl .htm .c .o @@ -46,31 +45,34 @@ VELOOBJ = velo.o velosim.o velodorn.o velodornier.o all: $(BINTARGET)/SICServer -full: matrix/libmatrix.a hardsup/libhlib.a tecs/libtecsl.a \ - $(BINTARGET)/SICServer +full: matrix/libmatrix.a psi/hardsup/libhlib.a psi/tecs/libtecsl.a \ + psi/libpsi.a $(BINTARGET)/SICServer $(BINTARGET)/SICServer: $(SOBJ) $(MOTOROBJ) $(COUNTEROBJ) \ - $(DMCOBJ) $(VELOOBJ) $(DIFIL) $(EXTRA) \ + $(VELOOBJ) $(DIFIL) $(EXTRA) \ $(SUBLIBS) $(CC) -g -o SICServer \ - $(SOBJ) $(MOTOROBJ) $(COUNTEROBJ) $(DMCOBJ) \ + $(SOBJ) $(MOTOROBJ) $(COUNTEROBJ) \ $(VELOOBJ) $(DIFOBJ) $(EXTRA) $(LIBS) cp SICServer $(BINTARGET)/ matrix/libmatrix.a: cd matrix; make $(MFLAGS) libmatrix.a -hardsup/libhlib.a: - cd hardsup; make $(MFLAGS) libhlib.a +psi/hardsup/libhlib.a: + cd psi/hardsup; make $(MFLAGS) libhlib.a -tecs/libtecsl.a: - cd tecs; make $(MFLAGS) libtecsl.a +psi/tecs/libtecsl.a: + cd psi/tecs; make $(MFLAGS) libtecsl.a +psi/libpsi.a: + cd psi; make $(MFLAGS) libpsi.a clean: rm -f *.o SICServer $(BINTARGET)/SICServer - cd hardsup; make $(MFLAGS) clean + cd psi/hardsup; make $(MFLAGS) clean cd matrix; make $(MFLAGS) clean - cd tecs; make $(MFLAGS) clean + cd psi/tecs; make $(MFLAGS) clean + cd psi; make $(MFLAGS) clean Dbg.o: Dbg.c cc -g -I/data/koenneck/include -c Dbg.c diff --git a/make_gen_dummy b/make_gen_dummy new file mode 100644 index 00000000..4b6f3814 --- /dev/null +++ b/make_gen_dummy @@ -0,0 +1,77 @@ +#---------------------------------------------------------------------------- +# Makefile for SICS (machine-independent part) +# +# Mark Koennecke 1996-2001 +# Markus Zolliker March 2003 +#--------------------------------------------------------------------------- + +COBJ = Sclient.o network.o ifile.o intcli.o $(FORTIFYOBJ) +SOBJ = network.o ifile.o conman.o SCinter.o splitter.o passwd.o \ + servlog.o sicvar.o nserver.o SICSmain.o \ + sicsexit.o costa.o task.o $(FORTIFYOBJ)\ + macro.o ofac.o obpar.o obdes.o drive.o status.o intserv.o \ + devexec.o mumo.o mumoconf.o selector.o selvar.o fupa.o lld.o \ + lld_blob.o strrepl.o lin2ang.o fomerge.o\ + script.o o2t.o alias.o napi.o nxdata.o stringdict.o sdynar.o\ + histmem.o histdriv.o histsim.o interface.o callback.o \ + event.o emon.o evcontroller.o evdriver.o simev.o perfmon.o \ + danu.o nxdict.o varlog.o stptok.o nread.o \ + scan.o fitcenter.o telnet.o token.o \ + tclev.o hkl.o integrate.o optimise.o dynstring.o nxutil.o \ + mesure.o uubuffer.o commandlog.o udpquieck.o \ + rmtrail.o \ + simchop.o choco.o chadapter.o trim.o scaldate.o \ + hklscan.o xytable.o \ + circular.o maximize.o sicscron.o \ + t_rlp.o t_conv.o d_sign.o d_mod.o \ + synchronize.o definealias.o t_update.o \ + hmcontrol.o userscan.o rs232controller.o lomax.o \ + fourlib.o motreg.o motreglist.o anticollider.o \ + s_rnge.o sig_die.o gpibcontroller.o $(NIOBJ) \ + hmdata.o nxscript.o \ + tclintimpl.o sicsdata.o + +MOTOROBJ = motor.o simdriv.o +COUNTEROBJ = countdriv.o simcter.o counter.o +VELOOBJ = velo.o velosim.o + +.SUFFIXES: +.SUFFIXES: .tcl .htm .c .o + +# the following lines are not compatible with GNUmake using VPATH +# they are not needed, as they are defined by default +#.c.o: +# $(CC) $(CFLAGS) -c $*.c + +all: $(BINTARGET)/SICServer + +full: matrix/libmatrix.a dummy/libdummy.a $(BINTARGET)/SICServer + +$(BINTARGET)/SICServer: $(SOBJ) $(MOTOROBJ) $(COUNTEROBJ) \ + $(VELOOBJ) $(DIFIL) $(EXTRA) \ + $(SUBLIBS) + $(CC) -g -o SICServer \ + $(SOBJ) $(MOTOROBJ) $(COUNTEROBJ) \ + $(VELOOBJ) $(DIFOBJ) $(EXTRA) $(LIBS) + cp SICServer $(BINTARGET)/ + +matrix/libmatrix.a: + cd matrix; make $(MFLAGS) libmatrix.a + +dummy/libdummy.a: + cd dummy; make $(MFLAGS) +clean: + rm -f *.o SICServer $(BINTARGET)/SICServer + cd matrix; make $(MFLAGS) clean + cd dummy; make $(MFLAGS) clean + +Dbg.o: Dbg.c + cc -g -I/data/koenneck/include -c Dbg.c +Dbg_cmd.o: Dbg_cmd.c + + + + + + + diff --git a/makefile_alpha b/makefile_alpha index d8bf4302..46c25b57 100644 --- a/makefile_alpha +++ b/makefile_alpha @@ -28,12 +28,12 @@ MFLAGS= -f makefile_alpha HDFROOT=/data/lnslib CC = cc -CFLAGS = -I$(HDFROOT)/include $(DFORTIFY) -DHDF4 -DHDF5 -I$(SRC)hardsup -g \ - -std1 -warnprotos +CFLAGS = -I$(HDFROOT)/include -I. $(DFORTIFY) -DHDF4 -DHDF5 -Ipsi/hardsup \ + -g -std1 -warnprotos BINTARGET = bin EXTRA= -LIBS = -L$(HDFROOT)/lib -Lhardsup -lhlib -Lmatrix -lmatrix -Ltecs \ - -ltecsl -ltcl8.0 -lfor $(HDFROOT)/lib/libhdf5.a \ +LIBS = -L$(HDFROOT)/lib -Lpsi/hardsup -Lmatrix -lmatrix -Lpsi/tecs \ + -Lpsi -lpsi -lhlib -ltecsl -ltcl8.0 -lfor $(HDFROOT)/lib/libhdf5.a \ $(HDFROOT)/lib/libmfhdf.a $(HDFROOT)/lib/libdf.a \ $(HDFROOT)/lib/libjpeg.a -lz -lm -ll -lc diff --git a/makefile_alpha_dummy b/makefile_alpha_dummy new file mode 100644 index 00000000..13996a4e --- /dev/null +++ b/makefile_alpha_dummy @@ -0,0 +1,44 @@ +#--------------------------------------------------------------------------- +# Makefile for SICS +# machine-dependent part for Tru64 Unix +# +# Mark Koennecke 1996-2001 +# Markus Zolliker, March 2003 +#========================================================================== +# the following lines only for fortified version +#DFORTIFY=-DFORTIFY +#FORTIFYOBJ=strdup.o fortify.o +#========================================================================== +# assign if the National Instrument GPIB driver is available +#NI= -DHAVENI +#NIOBJ= nigpib.o +#NILIB=-lgpibenet +#========================================================================== +# comment or uncomment if a difrac version is required +# Do not forget to remove or add comments to ofac.c as well if changes +# were made here. + +#DIFOBJ=difrac.o -Ldifrac -ldif +#DIFIL= difrac.o +#--------------------------------------------------------------------------- + +#----------------select proper Makefile +MFLAGS= -f makefile_alpha_dummy + +HDFROOT=/data/lnslib + +CC = cc +CFLAGS = -I$(HDFROOT)/include -I. $(DFORTIFY) -DHDF4 -DHDF5 \ + -g -std1 -warnprotos +BINTARGET = bin +EXTRA= +LIBS = -L$(HDFROOT)/lib -Lmatrix -lmatrix \ + -Ldummy -ldummy -ltcl8.0 -lfor $(HDFROOT)/lib/libhdf5.a \ + $(HDFROOT)/lib/libmfhdf.a $(HDFROOT)/lib/libdf.a \ + $(HDFROOT)/lib/libjpeg.a -lz -lm -ll -lc + +include make_gen_dummy + + + + diff --git a/makefile_linux b/makefile_linux index 7f7d8bcf..298c4b65 100644 --- a/makefile_linux +++ b/makefile_linux @@ -22,6 +22,9 @@ FORTIFYOBJ=strdup.o fortify.o #DIFIL= difrac.o #========================================================================== +#----------------select proper Makefile +MFLAGS= -f makefile_linux + CC = gcc CFLAGS = -I$(HDFROOT)/include -DHDF4 -DHDF5 $(NI) -I$(SRC)hardsup \ -fwritable-strings -DCYGNUS -DNONINTF -g $(DFORTIFY) diff --git a/modriv.h b/modriv.h index cfd746c8..21006eb9 100644 --- a/modriv.h +++ b/modriv.h @@ -34,39 +34,11 @@ char *name, float newValue); void (*ListDriverPar)(void *self, char *motorName, SConnection *pCon); + void (*KillPrivate)(void *self); } MotorDriver; /* the first fields above HAVE to be IDENTICAL to those below */ - typedef struct __MoDriv { - /* general motor driver interface - fields. REQUIRED! - */ - float fUpper; /* upper limit */ - float fLower; /* lower limit */ - char *name; - int (*GetPosition)(void *self,float *fPos); - int (*RunTo)(void *self, float fNewVal); - int (*GetStatus)(void *self); - void (*GetError)(void *self, int *iCode, char *buffer, int iBufLen); - int (*TryAndFixIt)(void *self,int iError, float fNew); - int (*Halt)(void *self); - int (*GetDriverPar)(void *self, char *name, - float *value); - int (*SetDriverPar)(void *self,SConnection *pCon, - char *name, float newValue); - void (*ListDriverPar)(void *self, char *motorName, - SConnection *pCon); - - - /* EL-734 specific fields */ - int iPort; - char *hostname; - int iChannel; - int iMotor; - void *EL734struct; - int iMSR; - } EL734Driv; typedef struct ___MoSDriv { /* general motor driver interface @@ -87,6 +59,7 @@ char *name, float newValue); void (*ListDriverPar)(void *self, char *motorName, SConnection *pCon); + void (*KillPrivate)(void *self); /* Simulation specific fields */ float fFailure; /* percent random failures*/ @@ -96,11 +69,6 @@ } SIMDriv; -/*--------------------------- EL734 -----------------------------------*/ - MotorDriver *CreateEL734(SConnection *pCon, int argc, char *argv[]); - MotorDriver *CreateEL734DC(SConnection *pCon, int argc, char *argv[]); - void KillEL734(void *pData); - /* ----------------------- Simulation -----------------------------------*/ MotorDriver *CreateSIM(SConnection *pCon, int argc, char *argv[]); void KillSIM(void *pData); diff --git a/motor.c b/motor.c index 778b55fb..e1d47dac 100644 --- a/motor.c +++ b/motor.c @@ -10,9 +10,6 @@ endscript facility added: Mark Koennecke, August 2002 Modified to support driver parameters, Mark Koennecke, January 2003 - TODO: currently motor drivers have to be installed in MakeMotor - and remembered in KillMotor. Sort this some day! - Copyright: Labor fuer Neutronenstreuung @@ -55,8 +52,7 @@ #include "splitter.h" #include "status.h" #include "servlog.h" -#include "ecbdriv.h" - +#include "site.h" /*------------------------------------------------------------------------- some lokal defines */ @@ -449,26 +445,15 @@ extern void KillPiPiezo(void *pData); /* kill driver */ if(pM->drivername) - { /* edit here to include more drivers */ - if(strcmp(pM->drivername,"EL734") == 0) - { - KillEL734((void *)pM->pDriver); - } - else if(strcmp(pM->drivername,"EL734DC") == 0) - { - KillEL734((void *)pM->pDriver); - } - else if(strcmp(pM->drivername,"SIM") == 0) + { + if(pM->pDriver->KillPrivate != NULL) { - KillSIM((void *)pM->pDriver); - } - else if(strcmp(pM->drivername,"PIPIEZO") == 0) - { - KillPiPiezo((void *)pM->pDriver); - } - else if(strcmp(pM->drivername,"ECB") == 0) - { - KillECBMotor( (void *)pM->pDriver); + pM->pDriver->KillPrivate(pM->pDriver); + if(pM->pDriver->name != NULL) + { + free(pM->pDriver->name); + } + free(pM->pDriver); } free(pM->drivername); } @@ -888,7 +873,8 @@ extern MotorDriver *MakePiPiezo(Tcl_Interp *pTcl, char *pArray); char pBueffel[512]; int iD, iRet; Tcl_Interp *pTcl = (Tcl_Interp *)pSics->pTcl; - + pSite site = NULL; + assert(pCon); assert(pSics); @@ -902,58 +888,7 @@ extern MotorDriver *MakePiPiezo(Tcl_Interp *pTcl, char *pArray); /* create the driver */ strtolower(argv[2]); strtolower(argv[1]); - if(strcmp(argv[2],"el734") == 0) - { - iD = argc - 3; - pDriver = CreateEL734(pCon,iD,&argv[3]); - if(!pDriver) - { - return 0; - } - /* create the motor */ - pNew = MotorInit("EL734",argv[1],pDriver); - if(!pNew) - { - sprintf(pBueffel,"Failure to create motor %s",argv[1]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - } - else if(strcmp(argv[2],"ecb") == 0) - { - iD = argc - 3; - pDriver = CreateECBMotor(pCon,iD,&argv[3]); - if(!pDriver) - { - return 0; - } - /* create the motor */ - pNew = MotorInit("ECB",argv[1],pDriver); - if(!pNew) - { - sprintf(pBueffel,"Failure to create motor %s",argv[1]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - } - else if(strcmp(argv[2],"el734dc") == 0) - { - iD = argc - 3; - pDriver = CreateEL734DC(pCon,iD,&argv[3]); - if(!pDriver) - { - return 0; - } - /* create the motor */ - pNew = MotorInit("EL734DC",argv[1],pDriver); - if(!pNew) - { - sprintf(pBueffel,"Failure to create motor %s",argv[1]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - } - else if (strcmp(argv[2],"sim") == 0) + if (strcmp(argv[2],"sim") == 0) { iD = argc - 3; pDriver = CreateSIM(pCon,iD,&argv[3]); @@ -972,30 +907,20 @@ extern MotorDriver *MakePiPiezo(Tcl_Interp *pTcl, char *pArray); pNew->ParArray[HLOW].iCode = usUser; pNew->ParArray[HUPP].iCode = usUser; } - else if (strcmp(argv[2],"pipiezo") == 0) - { - pDriver = MakePiPiezo(pSics->pTcl,argv[3]); - if(!pDriver) - { - - SCWrite(pCon,pTcl->result,eError); - return 0; - } - /* create the motor */ - pNew = MotorInit("PIPIEZO",argv[1],pDriver); - if(!pNew) - { - sprintf(pBueffel,"Failure to create motor %s",argv[1]); - SCWrite(pCon,pBueffel,eError); - return 0; - } - } else { - sprintf(pBueffel,"Motor Type %s not recognized for motor %s", - argv[2],argv[1]); - SCWrite(pCon,pBueffel,eError); - return 0; + site = getSite(); + if(site != NULL) + { + pNew = site->CreateMotor(pCon,argc-1,&argv[1]); + } + if(pNew == NULL) + { + sprintf(pBueffel,"Motor Type %s not recognized for motor %s", + argv[2],argv[1]); + SCWrite(pCon,pBueffel,eError); + return 0; + } } /* create the interpreter command */ diff --git a/motor/Makefile b/motor/Makefile deleted file mode 100644 index 45253ce6..00000000 --- a/motor/Makefile +++ /dev/null @@ -1,21 +0,0 @@ -#-------------------------------------------------------------------------- -# Makefile for Davids motor test program. -# -# Mark Koennecke, October 1998 -#-------------------------------------------------------------------------- -BINTARGET=$(HOME)/bin/sics - -OBJ=el734_test.o makeprint.o -CFLAGS= -I../hardsup -c -LFLAGS= -L../hardsup -lhlib -lX11 -lm - -.c.o: - cc $(CFLAGS) $*.c - -all: $(OBJ) - cc -o el734_test $(OBJ) $(LFLAGS) - - cp el734_test $(BINTARGET) -clean: - - rm el734_test - - rm *.o - \ No newline at end of file diff --git a/motor/el734_test.c b/motor/el734_test.c deleted file mode 100644 index faf1d20d..00000000 --- a/motor/el734_test.c +++ /dev/null @@ -1,3900 +0,0 @@ -#define ident "1E07" -#define Active_Motor 1 - -#ifdef __DECC -#pragma module EL734_TEST ident -#endif -/* -** +--------------------------------------------------------------+ -** | Paul Scherrer Institute | -** | SINQ Project | -** | | -** | This software may be used freely by non-profit organizations.| -** | It may be copied provided that the name of P.S.I. and of the | -** | author is included. Neither P.S.I. nor the author assume any | -** | responsibility for the use of this software outside of P.S.I.| -** +--------------------------------------------------------------+ -** -** Link_options - Here is the Linker Option File -**!$! -**!$! To build on LNSA09 ... -**!$! $ build_cc_select :== decc -**!$! $ import tasmad -**!$! $ def/job deltat_c_tlb sinq_c_tlb -**!$! $ bui tas_src:[utils]el734_test debug -**!$! -**!$! To build on PSICLC ... -**!$! $ build_cc_select :== decc -**!$! $ set default usr_scroot:[maden] -**!$! $ copy lnsa09::ud0:[maden.motor]el734_test.c [] -**!$! $ copy lnsa09::tasmad_disk:[mad.lib]sinq_dbg.olb [] -**!$! $ copy lnsa09::tasmad_disk:[mad.lib]sinq_c.tlb [] -**!$! $ def/job sinq_olb usr_scroot:[maden]sinq_dbg.olb -**!$! $ def/job sinq_c_tlb usr_scroot:[maden]sinq_c.tlb -**!$! $ def/job deltat_c_tlb sinq_c_tlb -**!$! $ bui el734_test debug -**!$! -**!$ if p1 .eqs. "DEBUG" then dbg1 := /debug -**!$ if p1 .eqs. "DEBUG" then dbg2 := _dbg -**!$ link 'dbg1'/exe=el734_test'dbg2'.exe sys$input/options -**! el734_test -**! sinq_olb/lib -**! sys$share:decw$xmlibshr12/share -**! sys$share:decw$xtlibshrr5/share -**! sys$share:decw$xlibshr/share -**!$ purge/nolog el734_test'dbg2'.exe -**!$ set prot=w:re el734_test'dbg2'.exe -**!$ my_dir = f$element (0, "]", f$environment ("procedure")) + "]" -**!$ write sys$output "Exec file is ''my_dir'EL734_TEST''DBG2'.EXE -**!$ exit -**!$! -** Link_options_end -** -** Building on Alpha OSF/1: -** -** cc -std1 -g -o ~/motor/el734_test -I/public/lib/include \ -** -transitive_link -L/public/lib -ldeltat \ -** -lrt -lXm -lXt -lX11 -lXext -lm \ -** ~/motor/el734_test.c -** or -** alias makep /usr/opt/posix/usr/bin/make <-- Posix Vn of "make" -** makep -f ~/motor/motor.make ~/motor/el734_test -** -** To run the program, one might need to set the environment variable: -** -** setenv LD_LIBRARY_PATH /public/lib -** -** if the -soname option was not specified to ld when the deltat shared -** library was build. -** -** Resources and Flags File: decw$user_defaults:SinQ_rc.dat -** ------------------- or $HOME/SinQ_rc -** -** Resource Flag Default Description -** -------- ---- ------- ----------- -** - -name el734_test Name to use when looking up the -** resources. The default is the -** image file name. -** ... -** A value given via -name will be converted to lowercase before being used. -**+ -**--------------------------------------------------------------------------- -** Module Name . . . . . . . . : [...MOTOR]EL734_TEST.C -** -** Author . . . . . . . . . . : D. Maden -** Date of creation . . . . . . : Nov 1995 -** -** Purpose -** ======= -** EL734_TEST is a test program for the EL734 Motor Controller. -** Use: -** === -** 1) On VMS, define a foreign command, e.g. -** -** $ el734_test :== $psi_public:[exe_axp]el734_test.exe -** -** On Unix systems, ensure el734_test is in a suitable PATH directory. -** -** 2) Issue commands of the form: -** -** el734_test -host lnsp22 -chan 5 -m 6 -p 25.0 -** -** where -** -host specifies the name of the computer to which the EL734 is -** attached. This computer must be running the -** RS232C_SRV program or equivalent. -** -chan specifies the serial channel number to which the EL734 is -** attached. -** -m specifies the motor number to be driven and -** -p specifies that a positioning command is to be executed. -** -** For a full list of options, issue the command: -** -** el734_test -help -** -** Updates: -** 1A01 25-Nov-1994 DM. Initial version. -** 1C01 12-Sep-1996 DM. Use SINQ.OLB and SINQ_C.TLB on VMS. -** 1D01 6-Nov-1996 DM. Add EC command to SAVE command list. -** 1E01 8-May-1997 DM. Add RESTORE and NO_RESTORE to LOAD command list. -**- -**==================================================================== -*/ -#include -#include -#include -#include - -#include - -#ifdef __VMS -#include -#else -#include -#endif - -#include -/* -**==================================================================== -*/ - -#include -#include -/* - -**-------------------------------------------------------------------------- -** Define global structures and constants. -*/ -#define NIL '\0' -#ifndef True -#define True 1 -#define False 0 -#endif -/* -** Define the file idents for stdin, stdout and stderr -*/ -#define STDIN 0 -#define STDOUT 1 -#define STDERR 2 - -#define N_ELEMENTS(arg) (sizeof (arg)/sizeof (arg[0])) -/*------------------------------------------------------------- -** Global Variables -*/ - static int C_gbl_status; /* Return status from C_... routines */ - static int Ctrl_C_has_happened; - void *Hndl = NULL; - - static XrmOptionDescRec OpTable_0[] = { - {"-name", ".name", XrmoptionSepArg, (XPointer) NULL}, - {"-?", ".el734HelpItem", XrmoptionSepArg, (XPointer) NULL}, - {"-?cmd", ".el734HelpCmd", XrmoptionNoArg, (XPointer) "1"}, - {"-?msg", ".el734HelpMsg", XrmoptionNoArg, (XPointer) "1"}, - {"-?par", ".el734HelpPar", XrmoptionNoArg, (XPointer) "1"}, - {"-?res", ".el734HelpRes", XrmoptionNoArg, (XPointer) "1"}, - {"-chan", ".el734Chan", XrmoptionSepArg, (XPointer) NULL}, - {"-f", ".el734Frequency", XrmoptionSepArg, (XPointer) NULL}, - {"-fb", ".el734Fb", XrmoptionNoArg, (XPointer) "-1"}, - {"-ff", ".el734Ff", XrmoptionNoArg, (XPointer) "-1"}, - {"-frequency",".el734Frequency", XrmoptionSepArg, (XPointer) NULL}, - {"-help", ".el734Help", XrmoptionNoArg, (XPointer) "1"}, - {"-hi", ".el734High", XrmoptionSepArg, (XPointer) NULL}, - {"-high", ".el734High", XrmoptionSepArg, (XPointer) NULL}, - {"-host", ".el734Host", XrmoptionSepArg, (XPointer) NULL}, - {"-hunt", ".el734Hunt", XrmoptionNoArg, (XPointer) "1"}, - {"-id", ".el734Id", XrmoptionSepArg, (XPointer) NULL}, - {"-limits", ".el734Limits", XrmoptionSepArg, (XPointer) NULL}, - {"-lo", ".el734Low", XrmoptionSepArg, (XPointer) NULL}, - {"-load", ".el734Load", XrmoptionSepArg, (XPointer) NULL}, - {"-low", ".el734Low", XrmoptionSepArg, (XPointer) NULL}, - {"-m", ".el734Motor", XrmoptionSepArg, (XPointer) NULL}, - {"-motor", ".el734Motor", XrmoptionSepArg, (XPointer) NULL}, - {"-n", ".el734N", XrmoptionSepArg, (XPointer) NULL}, - {"-p", ".el734Position", XrmoptionSepArg, (XPointer) NULL}, - {"-port", ".el734Port", XrmoptionSepArg, (XPointer) NULL}, - {"-position", ".el734Position", XrmoptionSepArg, (XPointer) NULL}, - {"-random", ".el734Random", XrmoptionNoArg, (XPointer) "1"}, - {"-ref", ".el734Ref", XrmoptionNoArg, (XPointer) "1"}, - {"-rndm", ".el734Random", XrmoptionNoArg, (XPointer) "1"}, - {"-s", ".el734Stop", XrmoptionNoArg, (XPointer) "1"}, - {"-save", ".el734Save", XrmoptionSepArg, (XPointer) NULL}, - {"-saw", ".el734Saw", XrmoptionNoArg, (XPointer) "1"}, - {"-sb", ".el734Sb", XrmoptionNoArg, (XPointer) "-1"}, - {"-scan", ".el734Scan", XrmoptionNoArg, (XPointer) "-1"}, - {"-seed", ".el734Seed", XrmoptionSepArg, (XPointer) NULL}, - {"-sf", ".el734Sf", XrmoptionNoArg, (XPointer) "-1"}, - {"-step", ".el734Step", XrmoptionSepArg, (XPointer) NULL}, - {"-stop", ".el734Stop", XrmoptionNoArg, (XPointer) "1"}, - {"-tmo", ".el734Tmo", XrmoptionSepArg, (XPointer) NULL}, - {"-ur@", ".el734SetPos", XrmoptionSepArg, (XPointer) NULL}, - {"-verbose", ".el734Verbose", XrmoptionSepArg, (XPointer) NULL}, - {"-wait", ".el734Wait", XrmoptionSepArg, (XPointer) NULL}, - }; - char El734_host[20]; - int El734_port; /* TCP/IP Port number for socket */ - int El734_chan; /* Asynch channel number */ - char El734_id0[20]; /* The 1st EL734 identifier string */ - char El734_id1[20]; /* The 2nd EL734 identifier string */ - int Check_EL734_id; - int Motor; /* Motor number */ - int Enc_typ; - int Enc_num; - int Enc_par; - int N_moves; - float Lo_arg, Hi_arg; - int Lo_arg_present, Hi_arg_present; - int Do_help, Do_posit, Do_rndm, Do_saw, Do_scan, Do_step; - int Do_ref, Do_hunt, Do_ff, Do_fb, Do_sf, Do_sb, Do_stop; - int Do_save, Do_load; - int Do_limits, Do_setpos; - float Lim_arg_lo, Lim_arg_hi, Ist_arg; - float Tmo, Tmo_ref; - unsigned int Seed; - int Seed_present; - int Verbose; - int Wait_time, Frequency; - float Soll_posit; - float Step; - char Save_file[80]; - char Load_file[80]; - - int Dec_pt = 3; - int Enc_fact_0, Enc_fact_1; - int Mot_fact_0, Mot_fact_1; - float Inertia_tol; - int Ramp; - int Loop_mode; - int Slow_hz; - float Lo, Hi; - char Ctrl_id[32]; - int Fast_hz; - int Ref_mode; - int Backlash; - int Pos_tol; - char Mot_mem[16]; - char Mot_name[16]; - float Ref_param; - int Is_sided; - int Null_pt; - int Ac_par; - int Enc_circ; - int Stat_pos; - int Stat_pos_flt; - int Stat_pos_fail; - int Stat_cush_fail; - float Ist_pos; - int Prop; - int Integ; - int Deriv; - - char *Errstack; - int Errcode, Errno, Vaxc_errno; -/* -**-------------------------------------------------------------------------- -** PrintErrInfo: print out error information. -*/ - void PrintErrInfo (char *text) { -/* ============ -*/ - - EL734_ErrInfo (&Errstack, &Errcode, &Errno, &Vaxc_errno); - fprintf (stderr, "\n\007" - " Error return from %s\n" - " Errstack = \"%s\"\n" - " Errcode = %d Errno = %d Vaxc$errno = %d\n", - text, Errstack, Errcode, Errno, Vaxc_errno); - switch (Errcode) { - case EL734__BAD_ADR: - fprintf (stderr, " Address error\n"); break; - case EL734__BAD_CMD: - fprintf (stderr, " Command error\n"); break; - case EL734__BAD_ILLG: - fprintf (stderr, " Illegal response\n"); break; - case EL734__BAD_LOC: - fprintf (stderr, " EL734 is in manual mode.\n"); break; - case EL734__BAD_MALLOC: - fprintf (stderr, " Call to \"malloc\" failed\n"); perror (text); break; - case EL734__BAD_OFL: - fprintf (stderr, " Connection to asynch port lost\n"); break; - case EL734__BAD_OVFL: - fprintf (stderr, " Overflow: may be due to bad encoder gearing factor\n"); break; - case EL734__BAD_PAR: - fprintf (stderr, " Illegal parameter specified\n"); break; - case EL734__BAD_RNG: - fprintf (stderr, " Attempted to exceed lower or upper limit\n"); break; - case EL734__BAD_SOCKET: - fprintf (stderr, " Call to \"AsynSrv_Open\" failed\n"); perror (text); break; - case EL734__BAD_STP: - fprintf (stderr, " Motor is disabled: \"Stop\" signal is active!"); - break; - case EL734__BAD_TMO: - fprintf (stderr, " Time-out of EL734 response.\n"); - break; - default: if ((Errno != 0) || (Vaxc_errno != 0)) perror (text); - } - return; - } -/* -**-------------------------------------------------------------------------- -** GetKHVQZ: read the K, H, V, Q and Zero-point parameters -*/ - int GetKHVQZ ( -/* ======== -*/ int *k, - float *lo, - float *hi, - int *v, - float *q, - float *z) { - - int status; - - status = EL734_GetRefMode (&Hndl, k); - if (!status) { - printf ("\n\007"); - printf ("Bad status from EL734_GetRefMode.\n"); - return False; - } - - status = EL734_GetLimits (&Hndl, lo, hi); - if (!status) { - printf ("\n\007"); - printf ("Bad status from EL734_GetLimits.\n"); - return False; - } - - status = EL734_GetNullPoint (&Hndl, v); - if (!status) { - printf ("\n\007"); - printf ("Bad status from EL734_GetZeroPoint.\n"); - return False; - } - - status = EL734_GetRefParam (&Hndl, q); - if (!status) { - printf ("\n\007"); - printf ("Bad status from EL734_GetRefParam.\n"); - return False; - } - - status = EL734_GetZeroPoint (&Hndl, z); - if (!status) { - printf ("\n\007"); - printf ("Bad status from EL734_GetZeroPoint.\n"); - return False; - } - - return True; - } -/* -**--------------------------------------------------------------------------- -** My_WaitIdle: Wait till MSR goes to zero or -** This routine is similar to EL734_WaitIdle -** with the extra verbose argument and a test -** for . -*/ - int My_WaitIdle ( -/* =========== -*/ void **handle, - int verbose, /* Width of display field */ - int *ored_msr, - int *fp_cntr, - int *fr_cntr, - float *ist_posit) { -#ifdef __VMS -#include -#define hibernate lib$wait (0.25) -#else -#include -#include - struct timespec delay = {0, 250000000}; - struct timespec delay_left; -#define hibernate nanosleep_d9 (&delay, &delay_left) -#endif - int i, msr, ss, s_stat; - int my_verbose; - float last_posit; - char buff[64]; - - my_verbose = verbose; - if (my_verbose*2 > sizeof (buff)) my_verbose = sizeof (buff)/2; - if (my_verbose > 0) { - s_stat = EL734_GetStatus (handle, - &msr, ored_msr, fp_cntr, fr_cntr, &ss, ist_posit); - if (!s_stat) { - PrintErrInfo ("My_WaitIdle/EL734_GetStatus"); - return False; - } - last_posit = *ist_posit; - sprintf (buff, "%*.*f", my_verbose, Dec_pt, last_posit); - printf (buff); fflush (NULL); - for (i=0; i 0) && (*ist_posit != last_posit)) { - last_posit = *ist_posit; - sprintf (&buff[my_verbose], "%*.*f", my_verbose, Dec_pt, last_posit); - printf (buff); fflush (NULL); - } - if ((msr & MSR__BUSY) == 0) return True; - hibernate; - if (Ctrl_C_has_happened) return False; - } - PrintErrInfo ("My_WaitIdle/EL734_GetStatus"); /* Error detected in - ** EL734_GetStatus */ - return False; - } -/* -**-------------------------------------------------------------------------- -** LoadCheckTwoInteger: routine to check that a command specifying -** two integers set correctly. -*/ - int LoadCheckTwoInteger (char *cmnd) { -/* =================== -*/ - int status, len; - char my_cmnd[80], rd_cmnd[40], buff[40]; - char *cmnd_tok, *motor_tok, *par0_tok, *par1_tok, *rd0_tok, *rd1_tok; - - StrJoin (my_cmnd, sizeof (my_cmnd), cmnd, ""); /* Make a copy of cmnd */ - len = strlen (my_cmnd); - if (my_cmnd[len-1] == '\r') my_cmnd[len-1] = NIL; - - cmnd_tok = strtok (my_cmnd, " "); - motor_tok = strtok (NULL, " "); - par0_tok = strtok (NULL, " "); - par1_tok = strtok (NULL, " "); - if ((cmnd_tok == NULL) || (motor_tok == NULL) || - (par0_tok == NULL) || (par1_tok == NULL)) { - printf ("\007Software problem in LoadCheckTwoInteger\n"); - return False; - } - StrJoin (buff, sizeof (buff), cmnd_tok, " "); - StrJoin (rd_cmnd, sizeof (rd_cmnd), buff, motor_tok); - len = strlen (rd_cmnd); - rd_cmnd[len] = '\r'; - rd_cmnd[len+1] = NIL; - status = EL734_SendCmnd (&Hndl, rd_cmnd, buff, sizeof (buff)); - if (status) { - rd0_tok = strtok (buff, " "); - rd1_tok = strtok (NULL, " "); - if ((rd0_tok == NULL) || - (rd1_tok == NULL) || - (strcmp (par0_tok, rd0_tok) != 0) || - (strcmp (par1_tok, rd1_tok) != 0)) { - if (rd0_tok == NULL) rd0_tok = ""; - if (rd1_tok == NULL) rd1_tok = ""; - printf ("\007Verify error for command \"%s %s %s %s\"\n", - cmnd_tok, motor_tok, par0_tok, par1_tok); - printf ("Values set in EL734 controller are \"%s %s\"\n" - " They should be \"%s %s\"\n", - rd0_tok, rd1_tok, par0_tok, par1_tok); - return False; - }else { - return True; /* The parameter has been set correctly! */ - } - }else { - printf ("\007LoadCheckTwoInteger -- error from EL734_SendCmnd\n"); - printf ("Command being checked was \"%s %s %s %s\"\n", - cmnd_tok, motor_tok, par0_tok, par1_tok); - return False; - } - } -/* -**-------------------------------------------------------------------------- -** LoadCheckTwoFloat: routine to check that a command specifying -** two real values set correctly. -*/ - int LoadCheckTwoFloat (char *cmnd, int n_dec) { -/* ================= -*/ - int status, len; - char my_cmnd[80], rd_cmnd[40], buff[40], par0[40], par1[40]; - char *cmnd_tok, *motor_tok, *par0_tok, *par1_tok, *rd0_tok, *rd1_tok; - char *whole_tok, *frac_tok; - - StrJoin (my_cmnd, sizeof (my_cmnd), cmnd, ""); /* Make a copy of cmnd */ - len = strlen (my_cmnd); - if (my_cmnd[len-1] == '\r') my_cmnd[len-1] = NIL; - - cmnd_tok = strtok (my_cmnd, " "); - motor_tok = strtok (NULL, " "); - par0_tok = strtok (NULL, " "); - par1_tok = strtok (NULL, " "); - if ((cmnd_tok == NULL) || (motor_tok == NULL) || - (par0_tok == NULL) || (par1_tok == NULL)) { - printf ("\007Software problem in LoadCheckTwoFloat\n"); - return False; - } - /*--------------------------------------------------- - ** Check that the number of decimal places in the first set - ** parameter agrees with the setting of the EL734. - */ - StrJoin (par0, sizeof (par0), par0_tok, ""); - whole_tok = strtok (par0, "."); - frac_tok = strtok (NULL, "."); - if (frac_tok == NULL) { /* Check for a decimal point */ - len = strlen (whole_tok); /* None there, so put in a ".0" */ - frac_tok = whole_tok + len + 1; - frac_tok[0] = '0'; - frac_tok[1] = NIL; - } - len = strlen (frac_tok); - if (len > n_dec) { /* Param has too many decimal places */ - /* Try to remove trailing zeros */ - while ((len >= 0) && (frac_tok[len-1] == '0')) { - len = len - 1; - frac_tok[len] = NIL; - if (len == n_dec) break; - } - if (len != n_dec) { - printf ("Don't expect the parameter to verify correctly.\n" - "You have specified too many decimal places!\n"); - } - }else if (len < n_dec) { /* Param has too few decimal places */ - while (len < n_dec) { /* Pad with zeros */ - frac_tok[len] = '0'; - len = len + 1; - frac_tok[len] = NIL; - } - } - len = strlen (whole_tok); /* Re-join the parts of param again */ - whole_tok[len] = '.'; - /*--------------------------------------------------- - ** Check that the number of decimal places in the second set - ** parameter agrees with the setting of the EL734. - */ - StrJoin (par1, sizeof (par1), par1_tok, ""); - whole_tok = strtok (par1, "."); - frac_tok = strtok (NULL, "."); - if (frac_tok == NULL) { /* Check for a decimal point */ - len = strlen (whole_tok); /* None there, so put in a ".0" */ - frac_tok = whole_tok + len + 1; - frac_tok[0] = '0'; - frac_tok[1] = NIL; - } - len = strlen (frac_tok); - if (len > n_dec) { /* Param has too many decimal places */ - /* Try to remove trailing zeros */ - while ((len >= 0) && (frac_tok[len-1] == '0')) { - len = len - 1; - frac_tok[len] = NIL; - if (len == n_dec) break; - } - if (len != n_dec) { - printf ("Don't expect the parameter to verify correctly.\n" - "You have specified too many decimal places!\n"); - } - }else if (len < n_dec) { /* Param has too few decimal places */ - while (len < n_dec) { /* Pad with zeros */ - frac_tok[len] = '0'; - len = len + 1; - frac_tok[len] = NIL; - } - } - len = strlen (whole_tok); /* Re-join the parts of param again */ - whole_tok[len] = '.'; - /* End of checking number of decimal places - **--------------------------------------------------- - */ - StrJoin (buff, sizeof (buff), cmnd_tok, " "); - StrJoin (rd_cmnd, sizeof (rd_cmnd), buff, motor_tok); - len = strlen (rd_cmnd); - rd_cmnd[len] = '\r'; - rd_cmnd[len+1] = NIL; - status = EL734_SendCmnd (&Hndl, rd_cmnd, buff, sizeof (buff)); - if (status) { - rd0_tok = strtok (buff, " "); - rd1_tok = strtok (NULL, " "); - if ((rd0_tok == NULL) || - (rd1_tok == NULL) || - (strcmp (par0, rd0_tok) != 0) || - (strcmp (par1, rd1_tok) != 0)) { - if (rd0_tok == NULL) rd0_tok = ""; - if (rd1_tok == NULL) rd1_tok = ""; - printf ("\007Verify error for command \"%s %s %s %s\"\n", - cmnd_tok, motor_tok, par0, par1); - printf ("Value set in EL734 controller is \"%s %s\"\n" - " It should be \"%s %s\"\n", - rd0_tok, rd1_tok, par0, par1); - return False; - }else { - return True; /* The parameter has been set correctly! */ - } - }else { - printf ("\007LoadCheckTwoFloat -- error from EL734_SendCmnd\n"); - printf ("Command being checked was \"%s %s %s %s\"\n", - cmnd_tok, motor_tok, par0, par1); - return False; - } - } -/* -**-------------------------------------------------------------------------- -** LoadFloatJuggle: routine to try to get around an EL734 problem. -** -** The problem is that the EL734 does not at the moment -** handle binary <--> float conversion correctly. -*/ - int LoadFloatJuggle ( -/* =============== -*/ char *cmnd, /* The command to be issued */ - char *motor, /* The motor index being loaded */ - char *param, /* The desired parameter */ - int n_dec) { /* The number of decimal places */ -/* -** It is assumed that all parameters are consistent (especially -** param and n_dec) since this is an internal routine and that -** they are not terminated with . -*/ - int status, i, incr0, incr1, incr2; - char set_cmnd[80], read_cmnd[40], my_par[40], buff[40]; - char *rd_tok; - - printf ("Trying to juggle the \"%s\" parameter of Motor %s" - " to be %s ..\n .. ", cmnd, motor, param); - - sprintf (read_cmnd, "%s %s\r", cmnd, motor); /* Prepare the param rd cmnd */ - /* - ** Find indices of last 3 chars to be incremented - */ - incr0 = strlen (param); - incr0--; /* incr0 now indexes the last digit of param */ - - if (!isdigit (param[incr0])) incr0--; /* Be careful not to increment .. */ - /* .. a decimal point! */ - incr1 = incr0 - 1; - if (!isdigit (param[incr1])) incr1--; /* Be careful not to increment .. */ - /* .. a decimal point! */ - incr2 = incr1 - 1; - if (!isdigit (param[incr2])) incr2--; /* Be careful not to increment .. */ - /* .. a decimal point! */ - if ((!isdigit (param[incr0])) || - (!isdigit (param[incr1])) || - (!isdigit (param[incr2]))) { - printf ("LoadFloatJuggle: software problem with decimal point\n" - " The routine probably needs to be enhanced!\n"); - return False; - } - /*---------------------------------------------------------------- - ** First try incrementing the last digit of the set value of the - ** parameter 5 times. - */ - StrJoin (my_par, sizeof (my_par), param, ""); /* Make a copy of param */ - - for (i = 0; i < 5; i++) { - if (my_par[incr0] != '9') { /* Check for carry to next digit */ - my_par[incr0]++; - }else { - my_par[incr0] = '0'; - if (my_par[incr1] != '9') { - my_par[incr1]++; - }else { - my_par[incr1] = '0'; - if (my_par[incr2] != '9') { - my_par[incr2]++; - }else { - my_par[incr2] = '0'; - } - } - } - - printf ("%s .. ", my_par); - sprintf (set_cmnd, "%s %s %s\r", cmnd, motor, my_par); - - status = EL734_SendCmnd (&Hndl, set_cmnd, buff, sizeof (buff)); - if (status) status = EL734_SendCmnd (&Hndl, read_cmnd, buff, sizeof (buff)); - if (!status) { - printf ("\nError with \"%s %s %s\"\n" - "Abandoning parameter juggle!\n", cmnd, motor, my_par); - return False; - } - rd_tok = strtok (buff, " "); /* Skip leading spaces */ - if (strcmp (param, rd_tok) == 0) { - printf ("\n Success. Parameter as sent was %s\n" - " Parameter as read is %s\n", my_par, param); - return True; - } - } - /*---------------------------------------------------------------- - ** Now try decrementing the last digit of the set value of the - ** parameter 5 times. - */ - StrJoin (my_par, sizeof (my_par), param, ""); /* Make a copy of param */ - - for (i = 0; i < 5; i++) { - if (my_par[incr0] != '0') { /* Check for carry to next digit */ - my_par[incr0]--; - }else { - my_par[incr0] = '9'; - if (my_par[incr1] != '0') { - my_par[incr1]--; - }else { - my_par[incr1] = '9'; - if (my_par[incr2] != '0') { - my_par[incr2]--; - }else { - my_par[incr2] = '9'; - } - } - } - - printf ("%s .. ", my_par); - sprintf (set_cmnd, "%s %s %s\r", cmnd, motor, my_par); - - status = EL734_SendCmnd (&Hndl, set_cmnd, buff, sizeof (buff)); - if (status) status = EL734_SendCmnd (&Hndl, read_cmnd, buff, sizeof (buff)); - if (!status) { - printf ("\nError with \"%s %s %s\"\n" - "Abandoning parameter juggle!\n", cmnd, motor, my_par); - return False; - } - rd_tok = strtok (buff, " "); /* Skip leading spaces */ - if (strcmp (param, rd_tok) == 0) { - printf ("\n Success. Parameter as sent was %s\n" - " Parameter as read is %s\n", my_par, param); - return True; - } - } - /* - ** Failed - go back to original setting - */ - sprintf (set_cmnd, "%s %s %s\r", cmnd, motor, param); - status = EL734_SendCmnd (&Hndl, set_cmnd, buff, sizeof (buff)); - if (status) status = EL734_SendCmnd (&Hndl, read_cmnd, buff, sizeof (buff)); - if (status) { - rd_tok = strtok (buff, " "); - printf ("\n Failed. Parameter value is set to %s\n", rd_tok); - }else { - printf ("\n Failed. Parameter value is unknown due to error\n"); - } - return False; - } -/* -**-------------------------------------------------------------------------- -** LoadIntJuggle: routine to try to get around an EL734 problem. -** -** The problem is that some integer parameters (e.g. E) -** do not set correctly. -*/ - int LoadIntJuggle ( -/* ============= -*/ char *cmnd, /* The command to be issued */ - char *motor, /* The motor index being loaded */ - char *param) { /* The desired parameter */ -/* -** It is assumed that the parameters are trimmed (especially -** param) and are not terminated with . -*/ - int status, i, my_par; - char set_cmnd[80], read_cmnd[40], buff[40]; - char *rd_tok; - - printf ("Trying to juggle the \"%s\" parameter of Motor %s" - " to be %s ..\n .. ", cmnd, motor, param); - - sprintf (read_cmnd, "%s %s\r", cmnd, motor); /* Prepare the param rd cmnd */ - - /*---------------------------------------------------------------- - ** First try incrementing the parameter 5 times. - */ - sscanf (param, "%d", &my_par); /* Gen binary value of param */ - - for (i = 0; i < 5; i++) { - my_par++; - - printf ("%d .. ", my_par); - sprintf (set_cmnd, "%s %s %d\r", cmnd, motor, my_par); - - status = EL734_SendCmnd (&Hndl, set_cmnd, buff, sizeof (buff)); - if (status) status = EL734_SendCmnd (&Hndl, read_cmnd, buff, sizeof (buff)); - if (!status) { - printf ("\nError with \"%s %s %d\"\n" - "Abandoning parameter juggle!\n", cmnd, motor, my_par); - return False; - } - rd_tok = strtok (buff, " "); /* Skip leading spaces */ - if (strcmp (param, rd_tok) == 0) { - printf ("\n Success. Parameter as sent was %d\n" - " Parameter as read is %s\n", my_par, param); - return True; - } - } - /*---------------------------------------------------------------- - ** Now try decrementing the last digit of the set value of the - ** parameter 5 times. - */ - sscanf (param, "%d", &my_par); /* Gen binary value of param */ - - for (i = 0; i < 5; i++) { - my_par--; - - printf ("%d .. ", my_par); - sprintf (set_cmnd, "%s %s %d\r", cmnd, motor, my_par); - - status = EL734_SendCmnd (&Hndl, set_cmnd, buff, sizeof (buff)); - if (status) status = EL734_SendCmnd (&Hndl, read_cmnd, buff, sizeof (buff)); - if (!status) { - printf ("\nError with \"%s %s %d\"\n" - "Abandoning parameter juggle!\n", cmnd, motor, my_par); - return False; - } - rd_tok = strtok (buff, " "); /* Skip leading spaces */ - if (strcmp (param, rd_tok) == 0) { - printf ("\n Success. Parameter as sent was %d\n" - " Parameter as read is %s\n", my_par, param); - return True; - } - } - /* - ** Failed - go back to original setting - */ - sprintf (set_cmnd, "%s %s %s\r", cmnd, motor, param); - status = EL734_SendCmnd (&Hndl, set_cmnd, buff, sizeof (buff)); - if (status) status = EL734_SendCmnd (&Hndl, read_cmnd, buff, sizeof (buff)); - if (status) { - rd_tok = strtok (buff, " "); - printf ("\n Failed. Parameter value is set to %s\n", rd_tok); - }else { - printf ("\n Failed. Parameter value is unknown due to error\n"); - } - return False; - } -/* -**-------------------------------------------------------------------------- -** LoadCheckOneInteger: routine to check that a command specifying -** a single integer set correctly. -*/ - int LoadCheckOneInteger (char *cmnd) { -/* =================== -*/ - int status, len; - char my_cmnd[80], rd_cmnd[40], buff[40]; - char *cmnd_tok, *motor_tok, *param_tok, *rd_tok; - - StrJoin (my_cmnd, sizeof (my_cmnd), cmnd, ""); /* Make a copy of cmnd */ - len = strlen (my_cmnd); - if (my_cmnd[len-1] == '\r') my_cmnd[len-1] = NIL; - - cmnd_tok = strtok (my_cmnd, " "); - motor_tok = strtok (NULL, " "); - param_tok = strtok (NULL, " "); - if ((cmnd_tok == NULL) || (motor_tok == NULL) || (param_tok == NULL)) { - printf ("\007Software problem in LoadCheckOneInteger\n"); - return False; - } - StrJoin (buff, sizeof (buff), cmnd_tok, " "); - StrJoin (rd_cmnd, sizeof (rd_cmnd), buff, motor_tok); - len = strlen (rd_cmnd); - rd_cmnd[len] = '\r'; - rd_cmnd[len+1] = NIL; - status = EL734_SendCmnd (&Hndl, rd_cmnd, buff, sizeof (buff)); - if (status) { - rd_tok = strtok (buff, " "); - if ((rd_tok == NULL) || - (strcmp (param_tok, rd_tok) != 0)) { - if (rd_tok == NULL) rd_tok = ""; - printf ("\007Verify error for command \"%s %s %s\"\n", - cmnd_tok, motor_tok, param_tok); - printf ("Value set in EL734 controller is \"%s\"\n" - " It should be \"%s\"\n", - rd_tok, param_tok); - status = LoadIntJuggle (cmnd_tok, motor_tok, param_tok); - return status; - }else { - return True; /* The parameter has been set correctly! */ - } - }else { - printf ("\007LoadCheckOneInteger -- error from EL734_SendCmnd\n"); - printf ("Command being checked was \"%s %s %s\"\n", - cmnd_tok, motor_tok, param_tok); - return False; - } - } -/* -**-------------------------------------------------------------------------- -** LoadCheckOneFloat: routine to check that a command specifying -** a single real value set correctly. -*/ - int LoadCheckOneFloat (char *cmnd, int n_dec) { -/* ================= -*/ - int status, len, n_dec_ok; - char my_cmnd[80], rd_cmnd[40], buff[40], param[40]; - char *cmnd_tok, *motor_tok, *param_tok, *rd_tok; - char *whole_tok, *frac_tok; - - StrJoin (my_cmnd, sizeof (my_cmnd), cmnd, ""); /* Make a copy of cmnd */ - len = strlen (my_cmnd); - if (my_cmnd[len-1] == '\r') my_cmnd[len-1] = NIL; - - cmnd_tok = strtok (my_cmnd, " "); - motor_tok = strtok (NULL, " "); - param_tok = strtok (NULL, " "); - if ((cmnd_tok == NULL) || (motor_tok == NULL) || (param_tok == NULL)) { - printf ("\007Software problem in LoadCheckOneFloat\n"); - return False; - } - /* - ** Check that the number of decimal places in the set parameter - ** agrees with the setting of the EL734. - */ - n_dec_ok = True; /* Assume it will be OK */ - StrJoin (param, sizeof (param), param_tok, ""); - whole_tok = strtok (param, "."); - frac_tok = strtok (NULL, "."); - if (frac_tok == NULL) { /* Check for a decimal point */ - len = strlen (whole_tok); /* None there, so put in a ".0" */ - frac_tok = whole_tok + len + 1; - frac_tok[0] = '0'; - frac_tok[1] = NIL; - } - len = strlen (frac_tok); - if (len > n_dec) { /* Param has too many decimal places */ - /* Try to remove trailing zeros */ - while ((len >= 0) && (frac_tok[len-1] == '0')) { - len = len - 1; - frac_tok[len] = NIL; - if (len == n_dec) break; - } - if (len != n_dec) { - printf ("Don't expect the parameter to verify correctly.\n" - "You have specified too many decimal places!\n"); - n_dec_ok = False; /* Remember it (to suppress retries) */ - } - }else if (len < n_dec) { /* Param has too few decimal places */ - while (len < n_dec) { /* Pad with zeros */ - frac_tok[len] = '0'; - len = len + 1; - frac_tok[len] = NIL; - } - } - len = strlen (whole_tok); /* Re-join the parts of param again */ - whole_tok[len] = '.'; - - StrJoin (buff, sizeof (buff), cmnd_tok, " "); - StrJoin (rd_cmnd, sizeof (rd_cmnd), buff, motor_tok); - len = strlen (rd_cmnd); - rd_cmnd[len] = '\r'; - rd_cmnd[len+1] = NIL; - status = EL734_SendCmnd (&Hndl, rd_cmnd, buff, sizeof (buff)); - if (status) { - rd_tok = strtok (buff, " "); - if ((rd_tok == NULL) || - (strcmp (param, rd_tok) != 0)) { - if (rd_tok == NULL) rd_tok = ""; - printf ("\007Verify error for command \"%s %s %s\"\n", - cmnd_tok, motor_tok, param); - printf ("Value set in EL734 controller is \"%s\"\n" - " It should be \"%s\"\n", - rd_tok, param); - if (n_dec_ok) { - status = LoadFloatJuggle (cmnd_tok, motor_tok, param, n_dec); - } - return status; - }else { - return True; /* The parameter has been set correctly! */ - } - }else { - printf ("\007LoadCheckOneFloat -- error from EL734_SendCmnd\n"); - printf ("Command being checked was \"%s %s %s\"\n", - cmnd_tok, motor_tok, param); - return False; - } - } -/* -**-------------------------------------------------------------------------- -** DoStop: Send a STOP command to the motor. If has -** been detected, assume that this is an emergency -** stop and do fewer tests. -*/ - int DoStop () { -/* ====== -*/ - int status, no_errors, i, len, act_len; - int msr, ored_msr, fp_cntr, fr_cntr, ss; - char recd[132], buff[132], cmnd[80]; - float f_tmp; - - no_errors = True; - - if (!Ctrl_C_has_happened) { - EL734_ZeroStatus (&Hndl); - printf ("Sending STOP command to motor %d ...", Motor); - }else { - printf ("\n\007 detected: Sending STOP command to motor %d ...", - Motor); - } - - status = EL734_Stop (&Hndl); - if (!status) no_errors = False; - - if (no_errors) { - if (Ctrl_C_has_happened) { - printf (" OK.\n"); - return True; - }else { - printf ("\nWwaiting for motor to become idle ... "); - status = My_WaitIdle (&Hndl, Verbose, - &ored_msr, &fp_cntr, &fr_cntr, &Ist_pos); - if (!status) { - if (Ctrl_C_has_happened) { - printf ("\n\007 detected: Wait-for-idle abandoned!\n"); - }else { - printf ("\n\007 Error return status from My_WaitIdle!\n"); - } - return False; - } - if ((ored_msr & MSR__STOPPED) == 0) { - printf ("\n\007 Warning -- MSR STOP bit is not set!\n"); - return False; - } - if ((ored_msr & (~MSR__STOPPED)) != 0) { - printf ("\n\007 ... unexpected MSR obtained!\n"); - printf (" %s\n", EL734_EncodeMSR (buff, sizeof (buff), - 0, ored_msr, fp_cntr, fr_cntr)); - return False; - } - printf (" OK.\n"); - } - return True; - }else { - printf ("\n\007 STOP command not accepted!\n"); - return False; - } - } -/* -**-------------------------------------------------------------------------- -** DoLimits: Set the lower and upper software limits -*/ - int DoLimits ( -/* ======== -*/ float lo, - float hi) { - - int status, no_errors, i, len, act_len; - int msr, ored_msr, fp_cntr, fr_cntr, ss; - char recd[132], buff[132], cmnd[80]; - float f_tmp; - - no_errors = False; - - printf ("Sending command \"h %d %.*f %.*f\" ...", - Motor, Dec_pt, lo, Dec_pt, hi); - - sprintf (cmnd, "h %d %.*f %.*f\r", Motor, Dec_pt, lo, Dec_pt, hi); - status = EL734_SendCmnd (&Hndl, cmnd, buff, sizeof (buff)); - if (status && (buff[0] == NIL)) no_errors = True; - - if (no_errors) { - printf (" OK.\n"); - return True; - }else { - printf ("\n\007 Command not accepted!\n"); - return False; - } - } -/* -**-------------------------------------------------------------------------- -** DoSimpleMove: Send a simple move command to the motor and wait for idle -*/ - int DoSimpleMove ( -/* ============ -*/ char *a_cmnd, - int test_status) { - - int status, i, len, act_len; - int msr, ored_msr, fp_cntr, fr_cntr, ss; - char recd[132], buff[132], cmnd[80]; - float f_tmp; - char *etxt; - - EL734_ZeroStatus (&Hndl); - - sprintf (cmnd, a_cmnd, Motor); - printf ("Sending \"%s\" command ...", cmnd); - - i = strlen (cmnd); - cmnd[i] = '\r'; - cmnd[i+1] = NIL; - status = EL734_SendCmnd (&Hndl, cmnd, buff, sizeof (buff)); - if (!status) { - PrintErrInfo ("EL734_SendCmnd"); - return False; - } - - if (buff[0] != NIL) { - printf ("\007 response was \"%s\".\n", buff); - etxt = "Unrecognised response!"; - if (strcmp (buff, "?BSY") == 0) etxt = "Motor busy!"; - if (strcmp (buff, "?CMD") == 0) etxt = "Bad command!"; - if (strcmp (buff, "?LOC") == 0) etxt = "Controller is in manual mode!"; - if (strcmp (buff, "?ADR") == 0) etxt = "Bad motor number!"; - if (strcmp (buff, "?RNG") == 0) etxt = "Range error! Check low/high limits."; - if (strcmp (buff, "*MS") == 0) - etxt = "Motor is disabled: \"Stop\" signal is active!"; - if (strcmp (buff, "*ES") == 0) - etxt = "Motor is disabled: \"Emergency Stop\" signal is active!"; - if (strncmp (buff, "?TMO", 4) == 0) - etxt = "Time-out! You should check the cables, perhaps."; - printf ("%s\n", etxt); - return False; - } - - printf ("\nWaiting for motor to become idle ..."); fflush (NULL); - status = My_WaitIdle (&Hndl, Verbose, - &ored_msr, &fp_cntr, &fr_cntr, &Ist_pos); - if (!status) { - if (Ctrl_C_has_happened) DoStop (); - return False; - } - if (test_status && ((ored_msr & (~MSR__BUSY)) != MSR__OK)) { - printf ("\n\007 ... unexpected MSR obtained!\n"); - printf (" %s\n", EL734_EncodeMSR (buff, sizeof (buff), - 0, ored_msr, fp_cntr, fr_cntr)); - return False; - } - printf (" OK.\nPosition = %.*f\n", Dec_pt, Ist_pos); - return True; - } -/* -**-------------------------------------------------------------------------- -** DoSimpleSet: Send a parameter set command to the motor and -** check for null response. -*/ - int DoSimpleSet ( -/* =========== -*/ char *a_cmnd) { - - int status, i; - char cmnd[80], buff[40]; - - sprintf (cmnd, a_cmnd, Motor); - printf ("Sending \"%s\" command ...", cmnd); - i = strlen (cmnd); - cmnd[i] = '\r'; - cmnd[i+1] = NIL; - - status = EL734_SendCmnd (&Hndl, cmnd, buff, sizeof (buff)); - if (status && (buff[0] == NIL)) { - printf (" OK.\n"); - return True; - }else if (!status) { - printf ("\n\007"); - PrintErrInfo ("EL734_SendCmnd"); - return False; - }else { - printf ("\n\007Error response from the motor: \"%s\"!\n", buff); - return False; - } - } -/* -**-------------------------------------------------------------------------- -** DoSetPos: Set the current position -*/ - int DoSetPos (float ist) { -/* ======== -*/ - - int status; - char cmnd[80]; - - sprintf (cmnd, "UU %%d %.*f", Dec_pt, ist); - status = DoSimpleSet (cmnd); - if (status) printf ("Position set to %.*f\n", Dec_pt, ist); - return status; - } -/* -**-------------------------------------------------------------------------- -** DoRef: Perform a Reference Seek -*/ - int DoRef ( -/* ===== -*/ float *shift) { - - int status, no_restore, i, len, act_len; - int msr, ored_msr, fp_cntr, fr_cntr, ss; - char recd[132], buff[132], cmnd[80]; - int k, v; - float lo, hi, q, zero_pt, targ; - float f_tmp; -/*----------------------------------------------------------------- -** Absolute encoder? -*/ - status = GetKHVQZ (&k, &lo, &hi, &v, &q, &zero_pt); - if (!status) return status; - - if (k == 0) { - printf ("\n\007Absolute encoder, K = 0, " - "\"-ref\" option is not meaningful!\n"); - return False; - }else { - printf ("Performing reference point seek.\n"); - sprintf (recd, "%.*f", Dec_pt, zero_pt); - if (k == -1 || k == -11) { - printf ("Reference point = %s (lower limit switch) ...", recd); - }else if (k == 1 || k == 11) { - printf ("Reference point = %s (upper limit switch) ...", recd); - }else if (k == 2 || k == 12) { - printf ("Reference point = %s (separate limit switch) ...", recd); - }else { - printf ("Reference point = %s (reference mode = %d (unrecognised)) ...", - recd, k); - } - } -/*---------------------------------------------------------------*/ - *shift = 0.0; - - status = EL734_GetStatus (&Hndl, - &msr, &ored_msr, &fp_cntr, &fr_cntr, &ss, &Ist_pos); - if ((!status) || (msr == -1)) { - printf ("\n\007"); - printf ("Bad status from EL734_GetStatus.\n" - " ... failed to do reference seek.\n"); - return False; - } - EL734_ZeroStatus (&Hndl); - - sprintf (cmnd, "rf %d\r", Motor); /* Start reference seek */ - status = EL734_SendCmnd (&Hndl, cmnd, buff, sizeof (buff)); - if (!status) { - printf ("\n\007" - " ... failed to initiate reference seek.\n"); - PrintErrInfo ("EL734_SendCmnd"); - return False; - }else { - if (buff[0] != NIL) { - printf ("\n\007" - " ... error response when initiating reference seek:" - " \"%s\".\n" - " Operation abandoned.\n", buff); - return False; - } - } - status = My_WaitIdle (&Hndl, Verbose, - &ored_msr, &fp_cntr, &fr_cntr, &Ist_pos); - if (!status) { - if (Ctrl_C_has_happened) { - DoStop (); - }else { - PrintErrInfo ("My_WaitIdle"); - } - return False; - } - if ((ored_msr & MSR__REF_OK) != 0) { - printf (" OK.\n"); - }else { - if ((ored_msr & MSR__REF_FAIL) != 0) { - printf ("\007 failed!\n"); - }else { - printf ("\007 unexpected MSR obtained!\n"); - } - printf (" %s\n", EL734_EncodeMSR (recd, sizeof (recd), - 0, ored_msr, fp_cntr, fr_cntr)); - return False; - } - - *shift = Ist_pos - zero_pt; - sprintf (recd, "%.*f", Dec_pt, *shift); - printf ("Position = %.*f, Zero-point error = %s\n", Dec_pt, Ist_pos, recd); - sscanf (recd, "%f", &f_tmp); - if (f_tmp != 0.0) { - sprintf (recd, "%.*f", Dec_pt, zero_pt); - printf ("\007Setting current position to be %s\n", recd); - status = DoSetPos (zero_pt); - if (!status) return False; - } - if ((zero_pt < lo) || (zero_pt > hi)) { /* Move into range? */ - if (zero_pt < lo) targ = lo; /* Yes */ - if (zero_pt > lo) targ = hi; - printf ("Moving into low-high range ...\n"); - sprintf (cmnd, "P %%d %.*f", Dec_pt, targ); - status = DoSimpleMove (cmnd, True); - } - return True; - } -/* -**-------------------------------------------------------------------------- -** DoFF: Send a FF command to the motor -*/ - int DoFF () { -/* ==== -*/ - int status; - char cmnd[32]; - - if (Frequency > 0) { - sprintf (cmnd, "FF %%d %d", Frequency); - }else { - strcpy (cmnd, "FF %d"); - } - status = DoSimpleMove (cmnd, True); - return status; - } -/* -**-------------------------------------------------------------------------- -** DoFB: Send a FB command to the motor -*/ - int DoFB () { -/* ==== -*/ - int status; - char cmnd[32]; - - if (Frequency > 0) { - sprintf (cmnd, "FB %%d %d", Frequency); - }else { - strcpy (cmnd, "FB %d"); - } - status = DoSimpleMove (cmnd, True); - return status; - } -/* -**-------------------------------------------------------------------------- -** DoSF: Send a SF command to the motor -*/ - int DoSF () { -/* ==== -*/ - int status; - char cmnd[32]; - - if (Frequency > 0) { - sprintf (cmnd, "SF %%d %d", Frequency); - }else { - strcpy (cmnd, "SF %d"); - } - status = DoSimpleMove (cmnd, True); - return status; - } -/* -**-------------------------------------------------------------------------- -** DoSB: Send a SB command to the motor -*/ - int DoSB () { -/* ==== -*/ - int status; - char cmnd[32]; - - if (Frequency > 0) { - sprintf (cmnd, "SB %%d %d", Frequency); - }else { - strcpy (cmnd, "SB %d"); - } - status = DoSimpleMove (cmnd, True); - return status; - } -/* -**-------------------------------------------------------------------------- -** DoHunt: hunt for the motor's reference point. -*/ - int DoHunt () { -/* ====== -*/ - int status; - int k; - float lo, hi, q, shift, zero; - int v; - int msr, ored_msr, fp_cntr, fr_cntr, ss; - float step, targ, f_tmp; - char cmnd[20]; - - status = GetKHVQZ (&k, &lo, &hi, &v, &q, &zero); - if (!status) return status; -/*----------------------------------------------------------------- -** Absolute encoder */ - if (k == 0) { - printf ("\n\007Absolute encoder, K = 0, " - "-hunt option is not meaningful!\n"); - return False; -/*----------------------------------------------------------------- -** Lo-Lim is Ref Pt */ - }else if ((k == -1) || (k == -11)) { - printf ("Reference point = %.*f (low limit switch)\n", Dec_pt, zero); - if (q <= 0) { - printf ("\n\007Q = %.*f. This is inconsistent with K = %d!\n", - Dec_pt, q, k); - return False; - } - status = DoSimpleSet ("H %d -8000 8000"); - if (!status) return status; - - status = DoSetPos (0.0); - if (!status) return status; - - status = DoSimpleMove ("FB %d", False); /* Do FB but don't test MSR at end */ - if (!status) return status; - - DoLimits (lo, hi); /* Reset lo/hi limits */ - - status = EL734_GetStatus (&Hndl, - &msr, &ored_msr, &fp_cntr, &fr_cntr, &ss, &Ist_pos); - if (msr == -1) { - printf ("\n\007Bad status from EL734_GetStatus!"); - return False; - } - - if ((ored_msr & MSR__LO_LIM) == 0) { - printf ("\n\007Low-limit switch was not reached!"); - return False; - } - - status = DoSetPos (zero); - if (!status) return status; - - if ((ss & SS__LSX) != 0) { - printf ("\n\007Reference-point is still active!"); - return False; - } - - status = DoRef (&shift); - return status; -/*----------------------------------------------------------------- -** Hi-Lim is Ref Pt */ - }else if ((k == 1) || (k == 11)) { - printf ("Reference point = %.*f (high limit switch)\n", Dec_pt, zero); - if (q <= 0) { - printf ("\n\007Q = %.*f. This is inconsistent with K = %d!\n", - Dec_pt, q, k); - return False; - } - status = DoSimpleSet ("H %d -8000 8000"); - if (!status) return status; - - status = DoSetPos (0.0); - if (!status) return status; - - status = DoSimpleMove ("FF %d", False); /* Do FF but don't test MSR at end */ - if (!status) return status; - - DoLimits (lo, hi); /* Reset lo/hi limits */ - - status = EL734_GetStatus (&Hndl, - &msr, &ored_msr, &fp_cntr, &fr_cntr, &ss, &Ist_pos); - if (msr == -1) { - printf ("\n\007Bad status from EL734_GetStatus!"); - return False; - } - - if ((ored_msr & MSR__HI_LIM) == 0) { - printf ("\n\007High-limit switch was not reached!"); - return False; - } - - status = DoSetPos (zero); - if (!status) return status; - - if ((ss & SS__LSX) != 0) { - printf ("\n\007Reference-point is still active!"); - return False; - } - - status = DoRef (&shift); - return status; -/*----------------------------------------------------------------- -** Separate Ref Pt */ - }else if ((k == 2) || (k == 12)) { - printf ("Reference point = %.*f (separate switch)\n", Dec_pt, zero); - if (q == 0.0) { - printf ("\n\007Q = %.*f. This is inconsistent with K = %d!\n", - Dec_pt, q, k); - return False; - }else { - sprintf (cmnd, "%.*f", Dec_pt, q); /* Check Q param is not too small */ - sscanf (cmnd, "%f", &f_tmp); - if (f_tmp == 0.0) { - printf ("\n\007Q = %f. This is too small!\n", q); - return False; - } - } - status = DoSimpleSet ("H %d -8000 8000"); - if (!status) return status; - - sprintf (cmnd, "P %%d %.*f", Dec_pt, (zero - (q/2.0))); - printf ("Moving to start position.\n"); - status = DoSimpleMove (cmnd, False); - - status = DoSetPos (0.0); - if (!status) { - DoLimits (lo, hi); - return status; - } - - step = 0.95 * q; - targ = 0.0; - printf ("Low-to-High distance = %.*f\n", Dec_pt, (hi - lo)); - printf ("Step size = %.*f\n", Dec_pt, step); - if (step > 0) { - printf ("Stepping to low-limit switch looking for ref-point ...\n"); - }else { - printf ("Stepping to high-limit switch looking for ref-point ...\n"); - } - fflush (NULL); - status = EL734_GetStatus (&Hndl, - &msr, &ored_msr, &fp_cntr, &fr_cntr, &ss, &Ist_pos); - while (status && - ((ored_msr & MSR__LO_LIM) == 0) && - ((ored_msr & MSR__HI_LIM) == 0) && - ((ss & SS__LSX) == 0)) { - targ = targ - step; - sprintf (cmnd, "P %%d %.*f", Dec_pt, targ); - status = DoSimpleMove (cmnd, False); - if (!status) { - if (Ctrl_C_has_happened) { - DoStop (); - }else { - PrintErrInfo ("DoSimpleMove"); - } - DoLimits (lo, hi); - return False; - } - status = EL734_GetStatus (&Hndl, - &msr, &ored_msr, &fp_cntr, &fr_cntr, &ss, &Ist_pos); - } - if (!status) return False; - if ((ored_msr & (MSR__LO_LIM | MSR__HI_LIM)) != 0) { - printf ("Got to limit switch. Ref-point not found. " - "Returning to Start.\n"); fflush (NULL); - status = DoSimpleMove ("P %d 0.0", False); - if (!status) { - if (Ctrl_C_has_happened) { - DoStop (); - }else { - PrintErrInfo ("DoSimpleMove"); - } - DoLimits (lo, hi); - return False; - } - targ = 0.0; - if (step > 0) { - printf ("Stepping to high-limit switch looking for ref-point ...\n"); - }else { - printf ("Stepping to low-limit switch looking for ref-point ...\n"); - } - status = EL734_GetStatus (&Hndl, - &msr, &ored_msr, &fp_cntr, &fr_cntr, &ss, &Ist_pos); - while (status && - ((ored_msr & MSR__LO_LIM) == 0) && - ((ored_msr & MSR__HI_LIM) == 0) && - ((ss & SS__LSX) == 0)) { - targ = targ + step; - sprintf (cmnd, "P %%d %.*f", Dec_pt, targ); - status = DoSimpleMove (cmnd, False); - if (!status) { - if (Ctrl_C_has_happened) { - DoStop (); - }else { - PrintErrInfo ("DoSimpleMove"); - } - DoLimits (lo, hi); - return False; - } - status = EL734_GetStatus (&Hndl, - &msr, &ored_msr, &fp_cntr, &fr_cntr, &ss, &Ist_pos); - } - if (!status) return False; - if ((ored_msr & (MSR__LO_LIM | MSR__HI_LIM)) != 0) { - printf ("\n\007Got to limit switch. Ref-point not found!\n"); - printf ("Hunt operation abandoned.\n"); - DoLimits (lo, hi); - if (step > 0) DoSetPos (hi); else DoSetPos (lo); - return False; - } - } - DoLimits (lo, hi); /* Reset lo/hi limits */ - if ((ss & SS__LSX) == 0) { - printf ("\n\007Ref-point not found!\n"); - DoLimits (lo, hi); - return False; - } - status = DoRef (&shift); - return status; - }else { - printf ("\n\007Reference Mode, K = %d. Unrecognised value!\n", k); - return False; - } - } -/* -**-------------------------------------------------------------------------- -** DoSave: Get all parameter settings of motor. -*/ - int DoSave () { -/* ====== -*/ - int status, no_errors; - char buff[80]; - int msr, ored_msr, fp_cntr, fr_cntr, ss; - int air_cush, inp_state, act_mot; - FILE *lun; - time_t time_now; - struct EL734info *info_ptr; - - char cmnd00[10], cmnd01[10], cmnd02[10], cmnd03[10], cmnd04[10]; - char cmnd05[10], cmnd06[10], cmnd07[10], cmnd08[10], cmnd09[10]; - char cmnd10[10], cmnd11[10], cmnd12[10], cmnd13[10], cmnd14[10]; - char cmnd15[10], cmnd16[10], cmnd17[10], cmnd18[10], cmnd19[10]; - char cmnd20[10], cmnd21[10], cmnd22[10], cmnd23[10], cmnd24[10]; - char cmnd25[10], cmnd26[10], cmnd27[10], cmnd28[10], cmnd29[10]; - char cmnd30[10], cmnd31[10]; - - char *rptr00, *rptr01, *rptr02, *rptr03, *rptr04; - char *rptr05, *rptr06, *rptr07, *rptr08, *rptr09; - char *rptr10, *rptr11, *rptr12, *rptr13, *rptr14; - char *rptr15, *rptr16, *rptr17, *rptr18, *rptr19; - char *rptr20, *rptr21, *rptr22, *rptr23, *rptr24; - char *rptr25, *rptr26, *rptr27, *rptr28, *rptr29; - char *rptr30, *rptr31; - - int no_EC_cmnd = True; - int no_A_cmnd = True; - int no_FD_cmnd = True; - int no_FM_cmnd = True; - int no_D_cmnd = True; - int no_E_cmnd = True; - int no_F_cmnd = True; - int no_G_cmnd = True; - int no_H_cmnd = True; - int no_J_cmnd = True; - int no_K_cmnd = True; - int no_L_cmnd = True; - int no_M_cmnd = True; - int no_Q_cmnd = True; - int no_T_cmnd = True; - int no_V_cmnd = True; - int no_W_cmnd = True; - int no_Z_cmnd = True; - int no_SP_cmnd = True; - int no_ST_cmnd = True; - int no_SR_cmnd = True; - int no_SA_cmnd = True; - int no_AC_cmnd = True; - int no_RI_cmnd = True; - int no_AM_cmnd = True; - int no_EP_cmnd = True; - int no_KP_cmnd = True; - int no_KI_cmnd = True; - int no_KD_cmnd = True; - - if ((strcmp (Save_file, "-") == 0) || - (strcmp (Save_file, "=") == 0)) { /* Use standard output? */ - lun = stdout; /* Yes */ - }else { - lun = fopen (Save_file, "w"); - if (lun == NULL) return False; - printf ("Writing motor parameters to file %s ...", Save_file); - } - time_now = time (NULL); - fprintf (lun, "! EL734 Status at %s", asctime (localtime (&time_now))); - fprintf (lun, "! ============\n"); - - sprintf (cmnd00, "id\r"); - sprintf (cmnd01, "mn %d\r", Motor); - sprintf (cmnd02, "mem %d\r", Motor); - sprintf (cmnd03, "ec %d\r", Motor); - sprintf (cmnd04, "a %d\r", Motor); - sprintf (cmnd05, "fd %d\r", Motor); - sprintf (cmnd06, "fm %d\r", Motor); - sprintf (cmnd07, "d %d\r", Motor); - sprintf (cmnd08, "e %d\r", Motor); - sprintf (cmnd09, "f %d\r", Motor); - sprintf (cmnd10, "g %d\r", Motor); - sprintf (cmnd11, "h %d\r", Motor); - sprintf (cmnd12, "j %d\r", Motor); - sprintf (cmnd13, "k %d\r", Motor); - sprintf (cmnd14, "l %d\r", Motor); - sprintf (cmnd15, "m %d\r", Motor); - sprintf (cmnd16, "q %d\r", Motor); - sprintf (cmnd17, "t %d\r", Motor); - sprintf (cmnd18, "v %d\r", Motor); - sprintf (cmnd19, "w %d\r", Motor); - sprintf (cmnd20, "z %d\r", Motor); - sprintf (cmnd21, "sp %d\r", Motor); - sprintf (cmnd22, "st %d\r", Motor); - sprintf (cmnd23, "sr %d\r", Motor); - sprintf (cmnd24, "sa %d\r", Motor); - sprintf (cmnd25, "ac %d\r", Motor); - sprintf (cmnd26, "ri %d\r", Motor); - sprintf (cmnd27, "am\r"); - sprintf (cmnd28, "ep %d\r", Motor); - sprintf (cmnd29, "kp %d\r", Motor); - sprintf (cmnd30, "ki %d\r", Motor); - sprintf (cmnd31, "kd %d\r", Motor); - - no_errors = True; - - info_ptr = (struct EL734info *) Hndl; - status = AsynSrv_SendCmnds (&info_ptr->asyn_info, - &info_ptr->to_host, &info_ptr->from_host, - cmnd00, cmnd01, cmnd02, cmnd03, cmnd04, cmnd05, cmnd06, - cmnd07, cmnd08, cmnd09, cmnd10, cmnd11, cmnd12, cmnd13, - cmnd14, cmnd15, cmnd16, cmnd17, cmnd18, cmnd19, cmnd20, - cmnd21, cmnd22, cmnd23, cmnd24, cmnd25, cmnd26, cmnd27, - cmnd28, cmnd29, cmnd30, cmnd31, NULL); - if (status) { - rptr00 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, NULL); - rptr01 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr00); - rptr02 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr01); - rptr03 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr02); - rptr04 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr03); - rptr05 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr04); - rptr06 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr05); - rptr07 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr06); - rptr08 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr07); - rptr09 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr08); - rptr10 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr09); - rptr11 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr10); - rptr12 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr11); - rptr13 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr12); - rptr14 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr13); - rptr15 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr14); - rptr16 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr15); - rptr17 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr16); - rptr18 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr17); - rptr19 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr18); - rptr20 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr19); - rptr21 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr20); - rptr22 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr21); - rptr23 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr22); - rptr24 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr23); - rptr25 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr24); - rptr26 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr25); - rptr27 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr26); - rptr28 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr27); - rptr29 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr28); - rptr30 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr29); - rptr31 = AsynSrv_GetReply (&info_ptr->asyn_info, - &info_ptr->from_host, rptr30); - if ((rptr00 == NULL) || (rptr01 == NULL) || (rptr02 == NULL) || - (rptr03 == NULL) || (rptr04 == NULL) || (rptr05 == NULL) || - (rptr06 == NULL) || (rptr07 == NULL) || (rptr08 == NULL) || - (rptr09 == NULL) || (rptr10 == NULL) || (rptr11 == NULL) || - (rptr12 == NULL) || (rptr13 == NULL) || (rptr14 == NULL) || - (rptr15 == NULL) || (rptr16 == NULL) || (rptr17 == NULL) || - (rptr18 == NULL) || (rptr19 == NULL) || (rptr20 == NULL) || - (rptr21 == NULL) || (rptr22 == NULL) || (rptr23 == NULL) || - (rptr24 == NULL) || (rptr25 == NULL) || (rptr26 == NULL) || - (rptr27 == NULL) || (rptr28 == NULL) || (rptr29 == NULL) || - (rptr30 == NULL) || (rptr31 == NULL)) { - no_errors = False; - }else { - StrJoin (Ctrl_id, sizeof (Ctrl_id), rptr00, ""); - StrJoin (Mot_name, sizeof (Mot_name), rptr01, ""); - StrJoin (Mot_mem, sizeof (Mot_mem), rptr02, ""); - if (sscanf (rptr03, "%d %d", &Enc_typ, &Enc_num) == 2) - no_EC_cmnd = False; - if (sscanf (rptr04, "%d", &Dec_pt) == 1) no_A_cmnd = False; - if (sscanf (rptr05, "%d %d", &Enc_fact_0, &Enc_fact_1) == 2) - no_FD_cmnd = False; - if (sscanf (rptr06, "%d %d", &Mot_fact_0, &Mot_fact_1) == 2) - no_FM_cmnd = False; - if (sscanf (rptr07, "%f", &Inertia_tol) == 1) no_D_cmnd = False; - if (sscanf (rptr08, "%d", &Ramp) == 1) no_E_cmnd = False; - if (sscanf (rptr09, "%d", &Loop_mode) == 1) no_F_cmnd = False; - if (sscanf (rptr10, "%d", &Slow_hz) == 1) no_G_cmnd = False; - if (sscanf (rptr11, "%f %f", &Lo, &Hi) == 2) no_H_cmnd = False; - if (sscanf (rptr12, "%d", &Fast_hz) == 1) no_J_cmnd = False; - if (sscanf (rptr13, "%d", &Ref_mode) == 1) no_K_cmnd = False; - if (sscanf (rptr14, "%d", &Backlash) == 1) no_L_cmnd = False; - if (sscanf (rptr15, "%d", &Pos_tol) == 1) no_M_cmnd = False; - if (sscanf (rptr16, "%f", &Ref_param) == 1) no_Q_cmnd = False; - if (sscanf (rptr17, "%d", &Is_sided) == 1) no_T_cmnd = False; - if (sscanf (rptr18, "%d", &Null_pt) == 1) no_V_cmnd = False; - if (sscanf (rptr19, "%d", &Ac_par) == 1) no_W_cmnd = False; - if (sscanf (rptr20, "%d", &Enc_circ) == 1) no_Z_cmnd = False; - if (sscanf (rptr21, "%d", &Stat_pos) == 1) no_SP_cmnd = False; - if (sscanf (rptr22, "%d", &Stat_pos_flt) == 1) no_ST_cmnd = False; - if (sscanf (rptr23, "%d", &Stat_pos_fail) == 1) - no_SR_cmnd = False; - if (sscanf (rptr24, "%d", &Stat_cush_fail) == 1) - no_SA_cmnd = False; - if (sscanf (rptr25, "%d", &air_cush) == 1) no_AC_cmnd = False; - if (sscanf (rptr26, "%d", &inp_state) == 1) no_RI_cmnd = False; - if (sscanf (rptr27, "%x", &act_mot) == 1) no_AM_cmnd = False; - if (sscanf (rptr28, "%d", &Enc_par) == 1) no_EP_cmnd = False; - if (sscanf (rptr29, "%d", &Prop) == 1) no_KP_cmnd = False; - if (sscanf (rptr30, "%d", &Integ) == 1) no_KI_cmnd = False; - if (sscanf (rptr31, "%d", &Deriv) == 1) no_KD_cmnd = False; - } - }else { - no_errors = False; - } - if (no_errors) { - EL734_GetStatus (&Hndl, - &msr, &ored_msr, &fp_cntr, &fr_cntr, &ss, &Ist_pos); - if (msr == -1) no_errors = False; - } - if (no_errors) goto ds_do; - printf ("\007"); - fprintf (lun, "!\n"); - fprintf (lun, "! Failed to get status of motor\n"); - if (lun != stdout) { - fclose (lun); - printf ("\007error detected.\n"); - } - return False; -ds_do: - if (no_K_cmnd) { - fprintf (lun, "!\n" - "! EL734 ID = \"%s\"\n" - "! Server \"%s\"\n" - "! Port %5d\n" - "! Channel %5d\n" - "! Motor %5d\n", - Ctrl_id, El734_host, El734_port, El734_chan, Motor); - }else { - fprintf (lun, "!\n" - "! Reference mode information: EL734 ID = \"%s\"\n" - "! K = -11 = LoLim + Index is ref. pt. Server \"%s\"\n" - "! -1 = LoLim is ref. pt. Port %5d\n" - "! 0 = Abs encoder Channel %5d\n" - "! 1 = HiLim is ref. pt. Motor %5d\n" - "! 2 = Separate ref. pt.\n" - "! 11 = HiLim + Index is ref. pt.\n" - "! 12 = Separate + Index ref. pt.\n", - Ctrl_id, El734_host, El734_port, El734_chan, Motor); - } - fprintf (lun, "!\n"); - if (!no_SP_cmnd) fprintf (lun, "! # of positionings, SP = %d\n", - Stat_pos); - if (!no_ST_cmnd) fprintf (lun, "! # of positioning faults, ST = %d\n", - Stat_pos_flt); - if (!no_SR_cmnd) fprintf (lun, "! # of positioning failures, SR = %d\n", - Stat_pos_fail); - if (!no_SA_cmnd) fprintf (lun, "! # of air-cushion failures, SA = %d\n", - Stat_cush_fail); - fprintf (lun, "! %s", EL734_EncodeMSR (buff, sizeof (buff), - msr, ored_msr, fp_cntr, fr_cntr)); - fprintf (lun, " %s\n", EL734_EncodeSS (buff, sizeof (buff), ss)); - if (!no_W_cmnd) { - if (Ac_par == 0) { - switch (air_cush) { - case 0: break; /* Don't mention air cushions in this case! */ - case 1: fprintf (lun, "! Air-cushion status is \"on\".\n"); break; - default: fprintf (lun, "! Air-cushion status = %d.\n", air_cush); - } - }else { - switch (air_cush) { - case 0: fprintf (lun, "! Air-cushion is \"down\"\n"); break; - case 1: fprintf (lun, "! Air-cushion is \"up\"\n"); break; - default: fprintf (lun, "! Air-cushion status = %d.\n", air_cush); - } - } - } - if (!no_RI_cmnd) { - switch (inp_state) { - case 0: fprintf (lun, "! Input status is \"off\".\n"); break; - case 1: fprintf (lun, "! Input status is \"on.\"\n"); break; - default: fprintf (lun, "! Input status = %d.\n", inp_state); - } - } - if (!no_AM_cmnd) { - if (act_mot != 0) { - fprintf (lun, "! Active motor status = 0x%03X\n", act_mot); - }else { - fprintf (lun, "! No motors are active.\n"); - } - } - fprintf (lun, "!\n"); - if (Mot_name[0] == NIL) { - sprintf (buff, " mn %%d ..............."); - }else { - sprintf (buff, " mn %%d %s", Mot_name); - } - fprintf (lun, "%-32s! %s\n", buff, "Motor name"); - if (!no_EC_cmnd) { - sprintf (buff, " ec %%d 0 0"); - fprintf (lun, "%-32s! %s\n", buff, "Zero the encoder mapping"); - sprintf (buff, " ec %%d %s", rptr03); - fprintf (lun, "%-32s! %s\n", buff, "Encoder mapping (type/number)"); - } - if (!no_EP_cmnd) { - sprintf (buff, " ep %%d %s", rptr28); - fprintf (lun, "%-32s! %s\n", buff, "Encoder magic parameter"); - } - if (!no_A_cmnd) { - sprintf (buff, " a %%d %s", rptr04); - fprintf (lun, "%-32s! %s\n", buff, "Precision"); - } - if (!no_FD_cmnd) { - sprintf (buff, " fd %%d %s", rptr05); - fprintf (lun, "%-32s! %s\n", buff, "Encoder gearing (numer/denom)"); - } - if (!no_FM_cmnd) { - sprintf (buff, " fm %%d %s", rptr06); - fprintf (lun, "%-32s! %s\n", buff, "Motor gearing (numer/denom)"); - } - if (!no_D_cmnd) { - sprintf (buff, " d %%d %s", rptr07); - fprintf (lun, "%-32s! %s\n", buff, "Inertia tolerance"); - } - if (!no_E_cmnd) { - sprintf (buff, " e %%d %s", rptr08); - fprintf (lun, "%-32s! %s\n", buff, "Start/stop ramp (kHz/sec)"); - } - if (!no_F_cmnd) { - sprintf (buff, " f %%d %s", rptr09); - fprintf (lun, "%-32s! %s\n", buff, "Open loop/Closed loop (0/1)"); - } - if (!no_G_cmnd) { - sprintf (buff, " g %%d %s", rptr10); - fprintf (lun, "%-32s! %s\n", buff, "Start/stop frequency (Mot-S/sec)"); - } - if (!no_H_cmnd) { - sprintf (buff, " h %%d %s", rptr11); - fprintf (lun, "%-32s! %s\n", buff, "Low/High Software Limits"); - } - if (!no_J_cmnd) { - sprintf (buff, " j %%d %s", rptr12); - fprintf (lun, "%-32s! %s\n", buff, "Top speed (Mot-S/sec)"); - } - if (!no_K_cmnd) { - sprintf (buff, " k %%d %s", rptr13); - fprintf (lun, "%-32s! %s\n", buff, "Reference mode"); - } - if (!no_L_cmnd) { - sprintf (buff, " l %%d %s", rptr14); - fprintf (lun, "%-32s! %s\n", buff, "Backlash/Spielausgleich (Mot-S)"); - } - if (!no_M_cmnd) { - sprintf (buff, " m %%d %s", rptr15); - fprintf (lun, "%-32s! %s\n", buff, "Position tolerance (Enc-Steps)"); - } - if (!no_Q_cmnd) { - sprintf (buff, " q %%d %s", rptr16); - fprintf (lun, "%-32s! %s\n", buff, "Reference switch width"); - } - if (!no_T_cmnd) { - sprintf (buff, " t %%d %s", rptr17); - fprintf (lun, "%-32s! %s\n", buff, "One-sided operation flag (0 = no)"); - } - if (!no_V_cmnd) { - sprintf (buff, " v %%d %s", rptr18); - fprintf (lun, "%-32s! %s\n", buff, "Null point"); - } - if (!no_W_cmnd) { - sprintf (buff, " w %%d %s", rptr19); - fprintf (lun, "%-32s! %s\n", buff, "Air-cushion dependency"); - } - if (!no_Z_cmnd) { - sprintf (buff, " z %%d %s", rptr20); - fprintf (lun, "%-32s! %s\n", buff, "Circumf. of encoder (Enc-Steps)"); - } - if (!no_KP_cmnd) { - sprintf (buff, " kp %%d %s", rptr29); - fprintf (lun, "%-32s! %s\n", buff, "Proportional"); - } - if (!no_KI_cmnd) { - sprintf (buff, " ki %%d %s", rptr30); - fprintf (lun, "%-32s! %s\n", buff, "Integral"); - } - if (!no_KD_cmnd) { - sprintf (buff, " kd %%d %s", rptr31); - fprintf (lun, "%-32s! %s\n", buff, "Differential"); - } - if (Mot_mem[0] == NIL) { - sprintf (buff, " mem %%d ..............."); - }else { - sprintf (buff, " mem %%d %s", Mot_mem); - } - fprintf (lun, "%-32s! %s\n", buff, "User data register"); - - if (Ref_mode != 0) { - fprintf (lun, "%-32s! %s\n", " restore", "Incr. encoder" - " - specify position restore"); - } - - fprintf (lun, "!\n"); - fprintf (lun, "! Current position is %.*f\n", Dec_pt, Ist_pos); - fprintf (lun, "!\n"); - if (lun != stdout) { - fclose (lun); - chmod (Save_file, 0644); - printf (" OK.\n"); - } - return True; - } -/* -**-------------------------------------------------------------------------- -** DoLoad: Load parameter settings from a file. -*/ - int DoLoad () { -/* ====== -*/ - int status, go_on, no_errors, no_restore, i, len, act_len; - int msr, ored_msr, fp_cntr, fr_cntr, ss; - FILE *lun; - char recd[132], buff[132], cmnd[80], cmnd_prnt[80]; - /* - ** Setting motor parameters usually causes the current - ** position to get lost. Read it now so that it can be - ** restored at the end if required. - */ - printf ("The current position, "); - status = EL734_GetPrecision (&Hndl, &Dec_pt); - if (status) { - EL734_GetStatus (&Hndl, - &msr, &ored_msr, &fp_cntr, &fr_cntr, &ss, &Ist_pos); - if (msr == -1) status = False; - } - if (!status) { - printf ("\n ... failed to get current position.\n"); - return False; - }else { - printf ("%.*f, can be restored at end of load operation if\n" - "a \"RESTORE\" command is given. Executing a \"U\" or a \"UU\"" - " or any motion command\n" - "will cancel the effect of a \"RESTORE\" command.\n", - Dec_pt, Ist_pos); - no_restore = True; - } - - if ((strcmp (Load_file, "-") == 0) || - (strcmp (Load_file, "=") == 0)) { /* Use standard input? */ - lun = stdin; /* Yes */ - printf ("Getting motor parameters from standard input ...\n> "); - }else { - lun = fopen (Load_file, "r"); - if (lun == NULL) { - printf ("\007Error opening file %s ... load failed.\n", Load_file); - return False; - } - printf ("Getting motor parameters from file %s ...\n", Load_file); - } - - go_on = True; - no_errors = True; - - while (go_on && (fgets (recd, sizeof (recd), lun) != NULL)) { - len = strlen (recd); - if (len <= 1) { - if (lun == stdin) {printf ("> "); fflush (NULL);} - continue; - } - if (recd[len-1] != '\n') { - recd[20] = NIL; - printf ("\007 Record not terminated by \"\\n\". " - "It is probably too long!\n" - " The record starts thus: %s ...\n" - " It has been skipped.\n", recd); - if (lun == stdin) {printf ("> "); fflush (NULL);} - continue; - } - recd[len-1] = NIL; /* Remove the terminating "\n" */ - /* - ** Strip off any trailing stuff (but keep it around so that we - ** can print it out). "Trailing stuff" is anything after a "!". - */ - act_len = strcspn (recd, "!"); - len = sizeof (buff); - StrEdit (buff, recd, "trim compress uncomment", &len); - /* - ** If the remainder is just white-space, do nothing. - */ - if (len <= 0) { - if (lun == stdin) {printf ("> "); fflush (NULL);} - continue; - } - if (strlen (buff) >= sizeof (cmnd)) { - recd[20] = NIL; - printf ("\007 Record has a dubious format!!\n" - " The record starts thus: %s ...\n" - " It has been skipped.\n", recd); - if (lun == stdin) {printf ("> "); fflush (NULL);} - continue; - } - if (sprintf (cmnd, buff, Motor) >= sizeof (cmnd)) { - fprintf (stderr, - "\007 Record has generated a command which is too long.\n" - " This may have corrupted the program. To be safe,\n" - " we are now going to do an emergency exit. Bye.\n"); - exit (False); - } - if ((lun != stdin) && (len > 0)) { /* Show user what's going on */ - strcpy (cmnd_prnt, cmnd); - MakePrint (cmnd_prnt); - printf ("%-32s%s\n", cmnd_prnt, &recd[act_len]); - } - len = sizeof (cmnd); - StrEdit (cmnd, cmnd, "upcase compress", &len); - if (strncmp (cmnd, "EXIT", 4) == 0) { - go_on = False; - continue; - }else if (strncmp (cmnd, "QUIT", 4) == 0) { - go_on = False; - continue; - }else if (strncmp (cmnd, "NO_RESTORE", 10) == 0) { - no_restore = True; - printf ("The restore operation has been suppressed via " - "the \"NO_RESTORE\" command.\n"); - }else if (strncmp (cmnd, "RESTORE", 7) == 0) { - no_restore = False; - printf ("The restore operation has been requested via " - "the \"RESTORE\" command.\n"); - }else if (strncmp (cmnd, "WAIT", 4) == 0) { - status = My_WaitIdle (&Hndl, Verbose, - &ored_msr, &fp_cntr, &fr_cntr, &Ist_pos); - if (!status) { - go_on = no_errors = False; - if (Ctrl_C_has_happened) DoStop (); - continue; - }else { - if ((ored_msr & ~(MSR__BUSY | MSR__OK)) != 0) { - printf ("! %s\n", EL734_EncodeMSR (buff, sizeof (buff), - 0, ored_msr, fp_cntr, fr_cntr)); - } - } - }else { - len = strlen (cmnd); - if (len == 2 && cmnd[0] == '\\' && cmnd[1] == 'R') len = 0; - if (len == 2 && cmnd[0] == '\\' && cmnd[1] == '0') { - cmnd[0] = NIL; /* Null command */ - }else { - cmnd[len] = '\r'; /* Terminate command with a */ - cmnd[len+1] = NIL; - } - status = EL734_SendCmnd (&Hndl, cmnd, buff, sizeof (buff)); - if (!status) { - go_on = no_errors = False; - continue; - }else { - if (buff[0] == NIL) { - len = sizeof (cmnd); - if ((strncmp (cmnd, "U ", 2) == 0) || - (strncmp (cmnd, "UU ", 3) == 0) || - (strncmp (cmnd, "P ", 2) == 0) || - (strncmp (cmnd, "PD ", 3) == 0) || - (strncmp (cmnd, "PR ", 3) == 0) || - (strncmp (cmnd, "R ", 2) == 0) || - (strncmp (cmnd, "FF ", 3) == 0) || - (strncmp (cmnd, "FB ", 3) == 0) || - (strncmp (cmnd, "SF ", 3) == 0) || - (strncmp (cmnd, "SB ", 3) == 0)) { - no_restore = True; - }else if ((strncmp (cmnd, "A ", 2) == 0) || - (strncmp (cmnd, "E ", 2) == 0) || - (strncmp (cmnd, "EP ", 3) == 0) || - (strncmp (cmnd, "F ", 2) == 0) || - (strncmp (cmnd, "G ", 2) == 0) || - (strncmp (cmnd, "J ", 2) == 0) || - (strncmp (cmnd, "K ", 2) == 0) || - (strncmp (cmnd, "L ", 2) == 0) || - (strncmp (cmnd, "M ", 2) == 0) || - (strncmp (cmnd, "T ", 2) == 0) || - (strncmp (cmnd, "V ", 2) == 0) || - (strncmp (cmnd, "W ", 2) == 0) || - (strncmp (cmnd, "Z ", 2) == 0)) { - LoadCheckOneInteger (cmnd); - if (strncmp (cmnd, "A ", 2) == 0) { - status = EL734_GetPrecision (&Hndl, &i); - if (status) Dec_pt = i; - } - }else if ((strncmp (cmnd, "EC ", 3) == 0) || - (strncmp (cmnd, "FD ", 3) == 0) || - (strncmp (cmnd, "FM ", 3) == 0)) { - LoadCheckTwoInteger (cmnd); - }else if ((strncmp (cmnd, "D ", 2) == 0)) { - LoadCheckOneFloat (cmnd, 1); /* D cmnd only has 1 Dec Place */ - }else if ((strncmp (cmnd, "Q ", 2) == 0)) { - LoadCheckOneFloat (cmnd, Dec_pt); - }else if ((strncmp (cmnd, "H ", 2) == 0)) { - LoadCheckTwoFloat (cmnd, Dec_pt); - } - }else { - if (buff[0] == '?') { - printf ("%s\n", buff); - if (lun != stdin) { /* If input from file .. */ - go_on = no_errors = False; /* .. quit */ - continue; - } - }else { - if (strncmp (cmnd, "MSR ", 4) == 0) { - sscanf (buff, "%x", &ored_msr); - printf ("%s ! %s\n", buff, - EL734_EncodeMSR (buff, sizeof (buff), - ored_msr, ored_msr, 0, 0)); - }else if (strncmp (cmnd, "SS ", 3) == 0) { - sscanf (buff, "%x", &ss); - printf ("%s ! %s\n", buff, - EL734_EncodeSS (buff, sizeof (buff), ss)); - }else { - printf ("%s\n", buff); - } - } - } - } - } - if (lun == stdin) {printf ("> "); fflush (NULL);} - } - /* - ** Restore the current motor position. - */ - if (no_errors && !no_restore) { - EL734_GetPrecision (&Hndl, &Dec_pt); - printf ("Restoring %.*f as current motor position ...\n", - Dec_pt, Ist_pos); - sprintf (cmnd, "uu %d %.*f\r", Motor, Dec_pt, Ist_pos); - status = EL734_SendCmnd (&Hndl, cmnd, buff, sizeof(buff)); - if (status) { - if (buff[0] != NIL) { - no_errors = False; - } - }else { - no_errors = False; - } - } - if (lun != stdin) fclose (lun); - if (no_errors) { - printf ("\"load\" completed.\n"); - EL734_GetStatus (&Hndl, - &msr, &ored_msr, &fp_cntr, &fr_cntr, &ss, &Ist_pos); - printf ("The motor position is %.*f\n", Dec_pt, Ist_pos); - }else { - printf ("\007Failed to load motor parameters.\n"); - } - return no_errors; - } -/* -**--------------------------------------------------------------------------- -** DoWait - wait (if necessary) -*/ - void DoWait ( -/* ====== -*/ int print_flag) { - - int my_wait, irand; - float my_rand; - - if (Wait_time == 0) return; - - if (Wait_time > 0) { - if (print_flag) printf (" waiting %d secs ...", Wait_time); - sleep (Wait_time); - if (print_flag) printf ("\n"); - return; - } - - my_wait = -Wait_time; - - irand = rand () & 0x7FFF; - my_rand = ((float) irand)/32768.0; - - my_rand = my_rand * ((float) (my_wait)); - irand = (int) (my_rand + 1); - if (print_flag) printf (" waiting %d secs ...", irand); - sleep (irand); - if (print_flag) printf ("\n"); - } -/* -**-------------------------------------------------------------------------- -** PrintUsage: Auxilliary routine for ShowUsage and ShowItemUsage -*/ - int PrintUsage (char **txt, int n_recd) { -/* ========== -*/ - int i = 0; - int ans; - - printf ("\n"); - while (i < n_recd) { - printf ("%s\n", txt[i]); - i++; - if ((i % 24 == 0) && isatty (STDOUT)) { - printf ("More? "); - ans = getchar (); - if ((ans == EOF) || (toupper (ans) == 'Q')) return False; - } - } - printf ("\n"); - } -/* -**-------------------------------------------------------------------------- -** ShowUsage: A simple help routine. -*/ - void ShowUsage (int level) { -/* ========= -*/ - char *short_help_txt[] = { -"\007To get help on running the program issue the command:", -"", -" el734_test -help"}; - - char *help_txt[] = { -" Usage: el734_test [options ...]", -"", -" Valid options are:", -" -help Generates this help text.", -" -?