diff --git a/.log b/.log new file mode 100644 index 00000000..099b9f4f --- /dev/null +++ b/.log @@ -0,0 +1,2722 @@ +OK +SICS>> mess measure test.hkl +Starting at list test.hkl at 1998-09-04 09:49:39 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 15.216 12203 20780 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 15.266 25714 29999 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 15.316 26461 11613 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 15.366 8519 15331 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 15.416 23872 21620 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 15.466 898 27255 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 15.516 16092 10172 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +7 15.566 1236 26260 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 15.616 20731 1291 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 15.666 23840 1218 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +10 15.716 11416 606 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +11 15.766 15528 21586 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +12 15.816 5976 27427 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +13 15.866 3757 238 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +14 15.916 29453 26437 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +15 15.966 21035 32629 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +16 16.016 21088 25093 +status = Driving +WARNING: dca off position by 1.000000 +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +17 15.066 12230 17529 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +18 16.116 15232 436 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +19 16.166 16549 1410 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +20 16.216 16859 23718 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +21 16.266 6657 31261 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +22 16.316 5054 16281 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +23 16.366 5253 22182 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +24 16.416 19688 24210 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Interrupting Current Hardware Operation +WARNING: Operation interrupted!! +status = Eager to execute commands +ERROR: Scan aborted +SICS>> mess np +mess.np = 50.000000 +SICS>> mess np 10 +OK +SICS>> mess measure test.hkl +Starting at list test.hkl at 1998-09-04 09:51:35 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +0 17.216 15235 15277 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 17.266 24814 11967 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 17.316 16351 30856 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 17.366 13400 26940 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 17.416 28383 20559 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +5 17.466 32486 27476 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 17.516 26030 11527 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 17.566 6421 23291 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +8 17.616 143 6821 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 17.666 17984 19099 +1 14.0 1.0 -3.0 34.93 17.4662365.2f -120.3757635.2f 57.86 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 60.437 15677 5312 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 60.487 6913 8517 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 60.537 21785 32184 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 60.587 28982 20980 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 60.637 24384 22193 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 60.687 23530 238 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 60.737 10458 27390 +status = Driving +ERROR: HW: HahahahahahahHahahHahaha-Mmmpfff + +ERROR: cannot read motor dca +ERROR: ERROR: HW: HahahahahahahHahahHahaha-Mmmpfff on dca +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 60.787 27960 254 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +8 60.837 5473 8624 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 60.887 16566 7534 +2 25.0 20.0 3.0 121.37 60.6874285.2f -161.7680215.2f 151.81 0.00 0.00 +status = Driving +status = Eager to execute commands +Driving to done +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 14.789 6560 6607 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 14.839 25249 18631 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 14.889 31253 14048 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +3 14.939 16538 21661 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 14.989 27925 22811 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 15.039 765 22247 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 15.089 7869 9058 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 15.139 11604 22468 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 15.189 22169 28837 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 15.239 26427 32302 +3 14.0 1.0 -1.0 30.08 15.0386245.2f -105.8243565.2f 57.33 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 12.967 24246 8915 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 13.017 14764 17951 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 13.067 5322 10514 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 13.117 18771 23942 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 13.167 29973 12847 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 13.217 16630 25875 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 13.267 26559 15669 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +7 13.317 6270 1419 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 13.367 29682 4929 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 13.417 13489 32431 +4 13.0 1.0 0.0 26.43 13.2171475.2f -97.0895085.2f 62.61 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 14.833 15614 5569 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 14.883 12518 31591 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +2 14.933 10083 10768 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 14.983 31345 23555 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 15.033 8907 6931 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 15.083 14491 834 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 15.133 10918 515 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 15.183 19640 20086 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 15.233 27496 14926 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +9 15.283 5236 7111 +5 13.0 1.0 -2.0 30.17 15.0827995.2f -114.8090905.2f 59.43 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +0 18.800 13161 2298 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 18.850 8523 10290 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 18.900 15502 19168 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 18.950 19314 9033 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 19.000 5262 24271 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +5 19.050 10232 5749 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 19.100 19798 18108 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 19.150 23814 18527 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 19.200 339 25099 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 19.250 25028 1208 +6 0.0 7.0 1.0 38.10 19.0499325.2f 168.9476015.2f 154.39 0.00 0.00 +status = Driving +status = Eager to execute commands +Driving to done +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 19.248 13927 13716 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 19.298 20120 19281 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 19.348 31989 24050 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 19.398 16064 7078 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 19.448 25174 31610 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 19.498 12784 20791 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 19.548 17449 22549 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 19.598 8828 31054 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 19.648 6099 21153 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +9 19.698 14516 32324 +7 -1.0 7.0 1.0 39.00 19.4981695.2f 166.0153055.2f 154.70 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 18.407 26651 22503 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 18.457 5613 9279 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 18.507 13524 17751 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 18.557 30823 16228 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 18.607 16043 11313 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +5 18.657 32415 8777 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 18.707 18301 11926 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 18.757 1779 451 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 18.807 17469 30747 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 18.857 20221 3523 +8 1.0 7.0 1.0 37.31 18.6574575.2f 172.0074465.2f 154.08 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 6.467 31117 32478 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 6.517 24930 15032 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 6.567 23969 5078 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +3 6.617 15498 16166 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 6.667 22679 31382 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 6.717 6975 11793 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 6.767 5930 7753 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +7 6.817 14665 20919 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 6.867 8115 21268 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +9 6.917 11186 28343 +9 1.0 2.0 2.0 13.43 6.7168745.2f 176.1939855.2f -170.37 0.00 0.00 +ERROR: 4.0, 0.0, 0.0 violates two theta limits +ERROR: NOT started +Finishing list test.hkl at 1998-09-04 09:57:37 +OK +SICS>> mess close +ERROR: parameter close not known +SICS>> mess start +OK +SICS>> mess measure test.hkl +Starting at list test.hkl at 1998-09-04 11:11:11 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 16.216 23284 31414 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 16.266 8139 11466 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 16.316 17151 10162 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 16.366 19971 16678 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 16.416 19200 5490 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 16.466 28360 12563 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 16.516 27559 17845 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 16.566 20834 12440 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 16.616 10919 24927 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +9 16.666 21331 32593 +WARNING: integration failed -->no peak found: 14.000000 1.000000 -3.000000 +OK +SICS>> mess np 10 +OK +SICS>> mess measure test.hkl +Starting at list test.hkl at 1998-09-04 11:21:08 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +0 17.216 4751 13337 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 17.266 18895 26634 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 17.316 17988 20942 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +3 17.366 3856 24327 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 17.416 27222 28512 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 17.466 23110 25948 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 17.516 30393 9540 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 17.566 15287 5641 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 17.616 22077 21073 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 17.666 20070 1583 +WARNING: integration failed -->no peak found: 14.000000 1.000000 -3.000000 +1 14.0 1.0 -3.0 34.93 17.4662365.2f -120.3757635.2f 57.86 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 60.437 19188 25817 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 60.487 22640 22708 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 60.537 32176 21305 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 60.587 22481 1473 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 60.637 1150 1463 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +5 60.687 15999 15330 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 60.737 27177 1204 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 60.787 17972 27943 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 60.837 173 16769 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +9 60.887 7596 22450 +WARNING: integration failed -->no peak found: 25.000000 20.000000 3.000000 +2 25.0 20.0 3.0 121.37 60.6874285.2f -161.7680215.2f 151.81 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +0 14.789 6290 17102 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 14.839 9514 8599 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 14.889 12552 5998 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +3 14.939 6103 18158 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 14.989 5285 13713 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 15.039 23519 1693 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 15.089 22868 16634 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 15.139 25031 19817 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +8 15.189 9538 2897 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 15.239 20378 3148 +WARNING: integration failed -->no peak found: 14.000000 1.000000 -1.000000 +3 14.0 1.0 -1.0 30.08 15.0386245.2f -105.8243565.2f 57.33 0.00 0.00 +status = Driving +status = Eager to execute commands +Driving to done +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 12.967 4703 15088 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 13.017 28097 8323 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 13.067 5072 2757 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 13.117 31466 20426 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 13.167 9758 29779 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 13.217 3202 9760 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 13.267 19918 6364 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 13.317 28781 24088 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +8 13.367 13264 23153 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 13.417 26095 1332 +WARNING: integration failed -->no peak found: 13.000000 1.000000 0.000000 +4 13.0 1.0 0.0 26.43 13.2171475.2f -97.0895085.2f 62.61 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 14.833 29844 13682 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 14.883 8113 16258 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 14.933 627 7629 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 14.983 427 2576 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 15.033 4132 32147 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +5 15.083 30728 12397 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 15.133 4686 4249 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +7 15.183 86 26783 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 15.233 21417 2539 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 15.283 25470 16152 +WARNING: integration failed -->no peak found: 13.000000 1.000000 -2.000000 +5 13.0 1.0 -2.0 30.17 15.0827995.2f -114.8090905.2f 59.43 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 18.800 19978 9089 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 18.850 29186 19589 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 18.900 23896 6277 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 18.950 28645 29856 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 19.000 16948 29501 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +5 19.050 1071 5416 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 19.100 19164 851 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 19.150 22013 26102 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 19.200 8001 13123 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 19.250 32556 21422 +WARNING: integration failed -->no peak found: 0.000000 7.000000 1.000000 +6 0.0 7.0 1.0 38.10 19.0499325.2f 168.9476015.2f 154.39 0.00 0.00 +status = Driving +status = Eager to execute commands +Driving to done +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +0 19.248 26954 32575 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 19.298 27927 20785 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +2 19.348 3437 3462 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 19.398 29953 4451 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 19.448 12193 9863 +status = Driving +ERROR: HW: HahahahahahahHahahHahaha-Mmmpfff + +ERROR: cannot read motor dca +ERROR: ERROR: HW: HahahahahahahHahahHahaha-Mmmpfff on dca +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 19.498 24099 7172 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 19.548 5895 10303 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 19.598 30103 6770 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 19.648 22228 3277 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 19.698 13831 7470 +WARNING: integration failed -->no peak found: -1.000000 7.000000 1.000000 +7 -1.0 7.0 1.0 39.00 19.4981695.2f 166.0153055.2f 154.70 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +0 18.407 7189 4329 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 18.457 2058 24208 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 18.507 20742 19466 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 18.557 17797 7562 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 18.607 17560 4578 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 18.657 21087 30994 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 18.707 10430 10029 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 18.757 19569 3897 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 18.807 23948 1245 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 18.857 12611 3256 +WARNING: integration failed -->no peak found: 1.000000 7.000000 1.000000 +8 1.0 7.0 1.0 37.31 18.6574575.2f 172.0074465.2f 154.08 0.00 0.00 +status = Driving +status = Eager to execute commands +Driving to done +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 6.467 9058 28454 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 6.517 8485 8230 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +2 6.567 17476 20637 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 6.617 1425 325 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 6.667 8370 29621 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 6.717 4531 10273 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 6.767 1287 23144 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +7 6.817 18941 12875 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 6.867 27536 18085 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 6.917 18065 25386 +WARNING: integration failed -->no peak found: 1.000000 2.000000 2.000000 +9 1.0 2.0 2.0 13.43 6.7168745.2f 176.1939855.2f -170.37 0.00 0.00 +ERROR: 4.0, 0.0, 0.0 violates two theta limits +ERROR: NOT started +Finishing list test.hkl at 1998-09-04 11:28:41 +OK +SICS>> mess start +OK +SICS>> mess measure test.hkl +Starting at list test.hkl at 1998-09-04 11:43:13 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 17.166 3587 3600 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +1 17.216 5103 13972 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +2 17.266 20683 2296 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +3 17.316 17290 20006 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 17.366 20571 22260 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 17.416 20592 19650 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 17.466 10975 2240 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +7 17.516 20291 6327 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +8 17.566 28655 24741 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 17.616 21437 13515 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +10 17.666 6470 11213 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +11 17.716 2605 11561 +WARNING: integration failed -->no peak found: 14.000000 1.000000 -3.000000 +1 14.0 1.0 -3.0 34.93 17.47 -120.38 57.86 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 60.387 28490 16206 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +1 60.437 10244 23144 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 60.487 13400 20316 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 60.537 4174 6032 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 60.587 1038 21848 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +5 60.637 5036 32653 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 60.687 23288 29615 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 60.737 21447 16076 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 60.787 7058 6596 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +9 60.837 10152 6137 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +10 60.887 29789 17 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +11 60.937 4742 453 +WARNING: integration failed -->no peak found: 25.000000 20.000000 3.000000 +2 25.0 20.0 3.0 121.37 60.69 -161.77 151.81 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +0 13.739 14623 9298 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +1 13.789 30628 1917 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 13.839 8245 25825 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 13.889 11582 11348 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 13.939 4783 13709 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 13.989 31715 25433 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 14.039 25335 4231 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 14.089 6678 32354 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +8 14.139 5604 31927 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 14.189 21045 6243 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +10 14.239 25430 2712 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +11 14.289 23196 27657 +WARNING: integration failed -->no peak found: 14.000000 1.000000 -1.000000 +3 14.0 1.0 -1.0 30.08 15.04 -105.82 57.33 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 12.917 31764 31059 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 12.967 9926 31559 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 13.017 83 15776 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +3 13.067 8150 8894 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 13.117 16382 16896 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +5 13.167 11422 30036 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 13.217 4287 22167 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +7 13.267 21133 398 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 13.317 20818 5169 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +9 13.367 11186 16649 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +10 13.417 22629 27140 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +11 13.467 23572 2787 +WARNING: integration failed -->no peak found: 13.000000 1.000000 0.000000 +4 13.0 1.0 0.0 26.43 13.22 -97.09 62.61 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 14.783 25086 20986 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 14.833 1225 11792 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +2 14.883 27510 19297 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 14.933 32680 27582 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 14.983 7929 29984 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 15.033 8785 24970 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 15.083 12376 30175 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +7 15.133 10492 32148 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 15.183 7688 30637 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 15.233 31237 32144 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +10 15.283 14105 20849 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +11 15.333 31252 29297 +WARNING: integration failed -->no peak found: 13.000000 1.000000 -2.000000 +5 13.0 1.0 -2.0 30.17 15.08 -114.81 59.43 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +0 18.750 3669 1905 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 18.800 7604 9106 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 18.850 31811 17033 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 18.900 27360 5405 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 18.950 8024 27766 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 19.000 5225 20278 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 19.050 31504 17758 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 19.100 7558 23104 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 19.150 4559 579 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 19.200 31187 27115 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +10 19.250 15893 5339 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +11 19.300 18528 6239 +WARNING: integration failed -->no peak found: 0.000000 7.000000 1.000000 +6 0.0 7.0 1.0 38.10 19.05 168.95 154.39 0.00 0.00 +status = Driving +status = Eager to execute commands +Driving to done +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 19.198 20985 17242 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +1 19.248 13887 4553 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 19.298 336 23036 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 19.348 6203 31495 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 19.398 20807 31166 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 19.448 29826 490 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 19.498 30455 6593 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +7 19.548 23701 26617 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 19.598 10767 11291 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +9 19.648 21518 2558 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +10 19.698 19680 97 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +11 19.748 2401 31305 +WARNING: integration failed -->no peak found: -1.000000 7.000000 1.000000 +7 -1.0 7.0 1.0 39.00 19.50 166.02 154.70 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 18.357 32222 25298 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +1 18.407 8129 13125 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +2 18.457 6155 23375 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +3 18.507 5125 10217 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 18.557 19714 31488 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +5 18.607 17032 3719 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 18.657 6699 7228 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 18.707 27982 29940 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +8 18.757 12717 28461 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 18.807 26557 10761 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +10 18.857 32034 31808 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +11 18.907 21584 16320 +WARNING: integration failed -->no peak found: 1.000000 7.000000 1.000000 +8 1.0 7.0 1.0 37.31 18.66 172.01 154.08 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +0 6.417 19373 1967 +status = Driving +status = Eager to execute commands +ERROR: Randomly simulated counter error +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 6.467 24755 19896 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +2 6.517 12896 23153 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +ERROR: HW: HahahahahahahHahahHahaha-Mmmpfff + +ERROR: cannot read motor dca +NP dca Counts Monitor +3 -999.990 25906 30382 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +4 6.617 32267 29584 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +5 6.667 20504 1301 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 6.717 8172 8033 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +7 6.767 470 18037 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +8 6.817 12137 26496 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 6.867 23880 16604 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +10 6.917 30399 19443 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +11 6.967 7671 21262 +WARNING: integration failed -->no peak found: 1.000000 2.000000 2.000000 +9 1.0 2.0 2.0 13.43 6.72 176.19 -170.37 0.00 0.00 +ERROR: 4.0, 0.0, 0.0 violates two theta limits +ERROR: NOT started +Finishing list test.hkl at 1998-09-04 11:48:37 +OK +SICS>> mess file +Currently writing to: /data/koenneck/src/sics/tmp/trics05781998 +SICS>> mess start +OK +SICS>> mess measure test.hkl +Starting at list test.hkl at 1998-09-04 11:57:24 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +0 17.116 22849 32144 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +1 17.166 14364 4844 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 17.216 22379 5640 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +3 17.266 4299 28193 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 17.316 17315 11212 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +5 17.366 6537 23969 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +6 17.416 14773 5091 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +7 17.466 15071 8547 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +8 17.516 13280 290 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 17.566 17374 22944 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +10 17.616 25086 7114 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +11 17.666 9273 27311 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +12 17.716 9288 28616 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +13 17.766 29641 27052 +WARNING: integration failed --> no left side to: 14.000000 1.000000 -3.000000 + 1 14.0 1.0 -3.0 34.93 17.47 -120.38 57.86 0.00 0.00 +status = Driving +status = Eager to execute commands +WARNING: driving to HKL finished with problems +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +0 60.337 7517 19415 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +1 60.387 22644 3952 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +2 60.437 17804 31775 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +3 60.487 4919 11826 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +4 60.537 26914 29469 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +5 60.587 28536 20888 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +6 60.637 25668 32120 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +7 60.687 22378 13053 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +8 60.737 12919 1977 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +9 60.787 5626 25484 +status = Driving +status = Eager to execute commands +status = Counting +ERROR: Randomly simulated counter error +status = Eager to execute commands +NP dca Counts Monitor +10 60.837 25651 6772 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +11 60.887 26752 22417 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +12 60.937 20124 14066 +status = Driving +status = Eager to execute commands +status = Counting +status = Eager to execute commands +NP dca Counts Monitor +13 60.987 15038 20714 +WARNING: integration failed --> no left side to: 25.000000 20.000000 3.000000 + 2 25.0 20.0 3.0 121.37 60.69 -161.77 151.81 0.00 0.00 diff --git a/.rfl b/.rfl new file mode 100644 index 00000000..fc3de31d --- /dev/null +++ b/.rfl @@ -0,0 +1,27 @@ +1 14.0 1.0 -3.0 34.93 17.4662365.2f -120.3757635.2f 57.86 0.00 0.00 +2 25.0 20.0 3.0 121.37 60.6874285.2f -161.7680215.2f 151.81 0.00 0.00 +3 14.0 1.0 -1.0 30.08 15.0386245.2f -105.8243565.2f 57.33 0.00 0.00 +4 13.0 1.0 0.0 26.43 13.2171475.2f -97.0895085.2f 62.61 0.00 0.00 +5 13.0 1.0 -2.0 30.17 15.0827995.2f -114.8090905.2f 59.43 0.00 0.00 +6 0.0 7.0 1.0 38.10 19.0499325.2f 168.9476015.2f 154.39 0.00 0.00 +7 -1.0 7.0 1.0 39.00 19.4981695.2f 166.0153055.2f 154.70 0.00 0.00 +8 1.0 7.0 1.0 37.31 18.6574575.2f 172.0074465.2f 154.08 0.00 0.00 +9 1.0 2.0 2.0 13.43 6.7168745.2f 176.1939855.2f -170.37 0.00 0.00 +1 14.0 1.0 -3.0 34.93 17.47 -120.38 57.86 0.00 0.00 +2 25.0 20.0 3.0 121.37 60.69 -161.77 151.81 0.00 0.00 +3 14.0 1.0 -1.0 30.08 15.04 -105.82 57.33 0.00 0.00 +4 13.0 1.0 0.0 26.43 13.22 -97.09 62.61 0.00 0.00 +5 13.0 1.0 -2.0 30.17 15.08 -114.81 59.43 0.00 0.00 +6 0.0 7.0 1.0 38.10 19.05 168.95 154.39 0.00 0.00 +7 -1.0 7.0 1.0 39.00 19.50 166.02 154.70 0.00 0.00 +8 1.0 7.0 1.0 37.31 18.66 172.01 154.08 0.00 0.00 +9 1.0 2.0 2.0 13.43 6.72 176.19 -170.37 0.00 0.00 +1 14.0 1.0 -3.0 34.93 17.47 -120.38 57.86 0.00 0.00 +2 25.0 20.0 3.0 121.37 60.69 -161.77 151.81 0.00 0.00 +3 14.0 1.0 -1.0 30.08 15.04 -105.82 57.33 0.00 0.00 +4 13.0 1.0 0.0 26.43 13.22 -97.09 62.61 0.00 0.00 +5 13.0 1.0 -2.0 30.17 15.08 -114.81 59.43 0.00 0.00 +6 0.0 7.0 1.0 38.10 19.05 168.95 154.39 0.00 0.00 +7 -1.0 7.0 1.0 39.00 19.50 166.02 154.70 0.00 0.00 +8 1.0 7.0 1.0 37.31 18.66 172.01 154.08 0.00 0.00 +9 1.0 2.0 2.0 13.43 6.72 176.19 -170.37 0.00 0.00 diff --git a/A1931.c b/A1931.c new file mode 100644 index 00000000..b9585513 --- /dev/null +++ b/A1931.c @@ -0,0 +1,344 @@ +/*------------------------------------------------------------------------- + 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 new file mode 100644 index 00000000..954813f7 --- /dev/null +++ b/A1931.h @@ -0,0 +1,20 @@ +/*------------------------------------------------------------------------- + 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/Busy.c b/Busy.c new file mode 100644 index 00000000..55e7c817 --- /dev/null +++ b/Busy.c @@ -0,0 +1,115 @@ +/*------------------------------------------------------------------------ + A busy flag module for SICS. + + Mark Koennecke, July 2002 +-------------------------------------------------------------------------*/ +#include +#include +#include "fortify.h" +#include "sics.h" + +/*----------------------------------------------------------------------*/ +typedef struct BUSY__ { + pObjectDescriptor pDes; + int iBusy; + }Busy; +/*---------------------------------------------------------------------*/ +busyPtr makeBusy(void){ + busyPtr result = NULL; + + result = (busyPtr)malloc(sizeof(Busy)); + if(!result){ + return NULL; + } + result->pDes = CreateDescriptor("BusyFlag"); + if(!result->pDes){ + free(result); + return NULL; + } + result->iBusy = 0; + return result; +} +/*---------------------------------------------------------------------*/ +void killBusy(void *self){ + busyPtr busy; + if(self != NULL){ + busy = (busyPtr)self; + if(busy->pDes != NULL){ + DeleteDescriptor(busy->pDes); + } + free(busy); + } +} +/*---------------------------------------------------------------------*/ +void incrementBusy(busyPtr self){ + assert(self != NULL); + self->iBusy++; +} +/*--------------------------------------------------------------------*/ +void decrementBusy(busyPtr self){ + assert(self != NULL); + self->iBusy--; + if(self->iBusy < 0){ + self->iBusy = 0; + } +} +/*--------------------------------------------------------------------*/ +void clearBusy(busyPtr self){ + assert(self != NULL); + self->iBusy = 0; +} +/*--------------------------------------------------------------------*/ +void setBusy(busyPtr self, int val){ + assert(self != NULL); + self->iBusy = val; +} +/*--------------------------------------------------------------------*/ +int isBusy(busyPtr self){ + assert(self != NULL); + return self->iBusy; +} +/*--------------------------------------------------------------------*/ +int BusyAction(SConnection *pCon,SicsInterp *pSics, void *pData, + int argc, char *argv[]){ + busyPtr self = NULL; + char pBuffer[80]; + + self = (busyPtr)pData; + assert(self != NULL); + + if(argc > 1){ + strtolower(argv[1]); + if(usUser < SCGetRights(pCon)){ + SCWrite(pCon,"ERROR: no privilege to manipulate busy flag",eError); + return 0; + } + if(strcmp(argv[1],"incr") == 0){ + incrementBusy(self); + SCSendOK(pCon); + return 1; + } else if(strcmp(argv[1],"decr") == 0){ + decrementBusy(self); + SCSendOK(pCon); + return 1; + } else if(strcmp(argv[1],"clear") == 0){ + clearBusy(self); + SCSendOK(pCon); + return 1; + } + } + + sprintf(pBuffer,"Busy = %d", isBusy(self)); + SCWrite(pCon,pBuffer,eValue); + return 1; +} +/*---------------------------------------------------------------------*/ +busyPtr findBusy(SicsInterp *pInter){ + CommandList *pCom = NULL; + + pCom = FindCommand(pInter,"busy"); + if(pCom != NULL){ + return (busyPtr)pCom->pData; + } +} + + diff --git a/Busy.h b/Busy.h new file mode 100644 index 00000000..6718146d --- /dev/null +++ b/Busy.h @@ -0,0 +1,28 @@ + +/*------------------------------------------------------------------------ + A busy flag module for SICS. + + Mark Koennecke, July 2002 +-------------------------------------------------------------------------*/ +#ifndef SICSBUSY +#define SICSBUSY + + +typedef struct BUSY__ *busyPtr; + +busyPtr makeBusy(void); +void killBusy(void *self); + +void incrementBusy(busyPtr self); +void decrementBusy(busyPtr self); +void clearBusy(busyPtr self); +void setBusy(busyPtr self, int val); + +int isBusy(busyPtr self); + +int BusyAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + +busyPtr findBusy(SicsInterp *pInter); +#endif + diff --git a/Busy.w b/Busy.w new file mode 100644 index 00000000..083208ad --- /dev/null +++ b/Busy.w @@ -0,0 +1,41 @@ +\subsection{Busy} +This class implements a busy flag which should be set when the interpreter +is busy doing something, like scanning for instance. The primary use +is for AMOR where operations are possible while writing data. This is +not caught by the normal device executor logic. In the long run, this +should become the standard way to control access to the +interpreter. In order to ensure access control, a test for the busy +flag is included into the SCMatchRights procedure. The busy flag is + installed into the interpreter. + +@o Busy.h @{ +/*------------------------------------------------------------------------ + A busy flag module for SICS. + + Mark Koennecke, July 2002 +-------------------------------------------------------------------------*/ +#ifndef SICSBUSY +#define SICSBUSY + + +typedef struct BUSY__ *busyPtr; + +busyPtr makeBusy(void); +void killBusy(void *self); + +void incrementBusy(busyPtr self); +void decrementBusy(busyPtr self); +void clearBusy(busyPtr self); +void setBusy(busyPtr self, int val); + +int isBusy(busyPtr self); + +int BusyAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + +busyPtr findBusy(SicsInterp *pInter); +#endif + +@} + + diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 index 00000000..d60c31a9 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/Components.txt b/Components.txt new file mode 100644 index 00000000..3e94898a --- /dev/null +++ b/Components.txt @@ -0,0 +1,161 @@ + + SICS components in this directory + + + 1.) SICS core + + - SCinter.* SICS-Interpreter + - Scommon.h common definitions + - conman.* Connection object and management + - devexec.* Device executor + - ifile.* options database + - interrupt.h Interrupt system + intserv.c + intcli.* + - macro.* link between Sics and Tcl + initcl.c + - network.* network protocoll handling + - obdes.* Object descriptor + - ofac.* Object factory, creates objects at startup + - passwd.* password database + - script.* some commands to access SICS internals from + Tcl-scripts. + - nserver.* server startup and closing, main loop + - servlog.* manages the server log + - nserver.c server main program + - interface.* object interface descriptions + - event.* SICS event description + - callback.* The callback system + - costa.* Command stack used for queing commands. + - ecode.* Text version of error codes. + - task.* Cooperative multitasker. + + + 2.) SICS core Objects + + - buffer.* LNS-RuenBueffer + - ruli.* RuenBueffer stack management + - configfu.h Prototype for some configuration commands + - status.* Status handling object + - sicsexit.* Exit command + - commandlog.* The commandlog + - danu.c The data file number management + - emon.* Environment control monitoring + - evcontroller.* General environment controller class. + - evdriver.* General environement controller driver. + - perfmon.* Performance measure. + - token.* The token system for access control. + - udpquieck.* send a UDP message when a data file changed. + + + + 3.) SICS Objects + + - counter.* Single counter object + - drive.* Drive command + - motor.* logical motor + - mumo.* multiple motor object (SANS) + comentry.* + mumoconf.* + - o2t.* Omega2Theta variable for TOPSI + - selector.* Handles a crystal monochromator with energy + selvar.* and lambda variables + - sicsvar.* primitive text, float or integer variables + - histmem.* histogram memory object + - nxdata.c some general NeXus data storage utilities + and the DMC storage routine + - nxutil.* NeXus utility routines. + - velo.* The velocity selector + - amor2t.* The AMOR Reflectometer two-theta movement + - choco.* A generalized controller with driveable + - chadapter.* parameters realized in chadapter. + - dmc.c special command initialization for DMC + - faverage.* Special command to average FOCUS-TOF data + online for status display. + - fitcenter.* Rough fitting and driving to center of + peaks. + - fowrite.* FOCUS TOF NeXus file writing. + - hkl.* Four circle angle calculation and driving. + - hklscan.* Scanning in reciprocal space for 4-circle. + - integrate.* Gabe integrtaion of scanned peaks. + - itc4.* Special things for ITC4, ITC-503 temperature + controllers. + - mesure.* Measuring reflection list on a 4-circle. + - nextrics.* Writing NeXus files for TRICS in rotation + camera mode. + - optimse.* General automatic peak optimisation using + center-of-gravity. + - pimotor.* Physik Instrument DC-804 step motor controller, + a child of motor. + - sanswave.* wavelength calculation for SANS using a + velocity selector. + - scan.* General purpose scanning utility. + - scontroller.* Access a serial port directly using SICS + - serial.* ways. + - sps.* Dealing with Siemens Siematic SPS controllers. + Probably SINQ specific. + - varlog.* log an environment controller + - xytable.* A general purpose table of x-y values. + - a2t. * AMOR two theta movement + - amorstat.* AMOR status display support + - nxamor.* AMOR data file writing + - amorscan.* AMOR specific scan functions. + + + 4.) SICS Hardware driver + + - countdriv.* EL737 counter driver + - modriv.* EL734 motor driver + el734driv.c + el734dc.c + - bruker.c Driver for the Bruker Magnet + - simcter.c Simulated counter + - simdriv.c Simulated motor + - histsim.c Simualted histogram memory + - histdriv.c histogram driver general + - sinqhmdriv.c SinQ histogram memory driver + - velosim.c Simulated velocity selector + - velodornier.c Dornier velocity selector + - dilludriv.* Driver for the old dillution cryostat + - docho.* Dornier chopper control system + - itc4driv.* Driver for ITC-4 - ITC-503 temperature + controllers. + - ltc11.* Driver for the Kyocera LTC-11 temperature + controller. + - pipiezo.* Driver for a Physik Instrument Piezo motor + controller. + - simchop.* simulated chopper. + - simev.* simulated environment controller. + - tclev.v necessary code for defining a environment + controller driver in Tcl. + + + 5.) Utility + + some of these are freeware files from the net + + - Dbg.* Don Libbes Tcl-Debugger + - bit.h Bit-Array handling macros + - defines.h, lld*.* Linked list package + - fortify.* memory debugging package + ufortify.* + - fupa.* helps interpreting object commands + - obpar.* manages array of object parameters + - splitter.* command analysis code + - strdup.*, string duplication + - strrepl.c string replacement + - stringdict.* a String Dictionary + - dynstring.* Dynamic Strings. + - sdynar.* Dynmaic array. + - uubuffer.* uuencode something into a buffer. + + 6.) Subdirectorys + + - hardsup additional HW handling code + - tcl SICS commands implemented in Tcl + - user user documentation + - user/general general SICS commands + - user/DMC DMC specific commands + - status status display clients + - fourcircle four circle diffraction related stuff + - ninx The ILL program INX modified for NeXus diff --git a/Dbg.c b/Dbg.c new file mode 100644 index 00000000..eb0f6105 --- /dev/null +++ b/Dbg.c @@ -0,0 +1,1206 @@ +/* Dbg.c - Tcl Debugger - See cmdHelp() for commands + +Written by: Don Libes, NIST, 3/23/93 + +Design and implementation of this program was paid for by U.S. tax +dollars. Therefore it is public domain. However, the author and NIST +would appreciate credit if this program or parts of it are used. + +*/ + +#include +#include "tclInt.h" +/*#include tclInt.h drags in varargs.h. Since Pyramid */ +/* objects to including varargs.h twice, just */ +/* omit this one. */ +#include "string.h" +#include "Dbg.h" + +#ifndef TRUE +#define TRUE 1 +#define FALSE 0 +#endif + +static int simple_interactor(); +static int zero(); + +/* most of the static variables in this file may be */ +/* moved into Tcl_Interp */ + +static Dbg_InterProc *interactor = simple_interactor; +static Dbg_IgnoreFuncsProc *ignoreproc = zero; +static Dbg_OutputProc *printproc = 0; + +static void print(...); + +static int debugger_active = FALSE; + +/* this is not externally documented anywhere as of yet */ +char *Dbg_VarName = "dbg"; + +#define DEFAULT_COMPRESS 0 +static int compress = DEFAULT_COMPRESS; +#define DEFAULT_WIDTH 75 /* leave a little space for printing */ + /* stack level */ +static int buf_width = DEFAULT_WIDTH; + +static int main_argc = 1; +static char *default_argv = "application"; +static char **main_argv = &default_argv; + +static Tcl_Trace debug_handle; +static int step_count = 1; /* count next/step */ + +#define FRAMENAMELEN 10 /* enough to hold strings like "#4" */ +static char viewFrameName[FRAMENAMELEN];/* destination frame name for up/down */ + +static CallFrame *goalFramePtr; /* destination for next/return */ +static int goalNumLevel; /* destination for Next */ + +static enum debug_cmd { + none, step, next, ret, cont, up, down, where, Next +} debug_cmd; + +/* this acts as a strobe (while testing breakpoints). It is set to true */ +/* every time a new debugger command is issued that is an action */ +static debug_new_action; + +#define NO_LINE -1 /* if break point is not set by line number */ + +struct breakpoint { + int id; + char *file; /* file where breakpoint is */ + int line; /* line where breakpoint is */ + char *pat; /* pattern defining where breakpoint can be */ + regexp *re; /* regular expression to trigger breakpoint */ + char *expr; /* expr to trigger breakpoint */ + char *cmd; /* cmd to eval at breakpoint */ + struct breakpoint *next, *previous; +}; + +static struct breakpoint *break_base = 0; +static int breakpoint_max_id = 0; + +static struct breakpoint * +breakpoint_new() +{ + struct breakpoint *b = (struct breakpoint *)ckalloc(sizeof(struct breakpoint)); + if (break_base) break_base->previous = b; + b->next = break_base; + b->previous = 0; + b->id = breakpoint_max_id++; + b->file = 0; + b->line = NO_LINE; + b->pat = 0; + b->re = 0; + b->expr = 0; + b->cmd = 0; + break_base = b; + return(b); +} + +static +void +breakpoint_print(interp,b) +Tcl_Interp *interp; +struct breakpoint *b; +{ + print(interp,"breakpoint %d: ",b->id); + + if (b->re) { + print(interp,"-re \"%s\" ",b->pat); + } else if (b->pat) { + print(interp,"-glob \"%s\" ",b->pat); + } else if (b->line != NO_LINE) { + if (b->file) { + print(interp,"%s:",b->file); + } + print(interp,"%d ",b->line); + } + + if (b->expr) + print(interp,"if {%s} ",b->expr); + + if (b->cmd) + print(interp,"then {%s}",b->cmd); + + putchar('\n'); +} + +static void +save_re_matches(interp,re) +Tcl_Interp *interp; +regexp *re; +{ + int i; + char name[20]; + char match_char;/* place to hold char temporarily */ + /* uprooted by a NULL */ + + for (i=0;istartp[i] == 0) break; + + sprintf(name,"%d",i); + /* temporarily null-terminate in middle */ + match_char = *re->endp[i]; + *re->endp[i] = 0; + Tcl_SetVar2(interp,Dbg_VarName,name,re->startp[i],0); + + /* undo temporary null-terminator */ + *re->endp[i] = match_char; + } +} + +/* return 1 to break, 0 to continue */ +static int +breakpoint_test(interp,cmd,bp) +Tcl_Interp *interp; +char *cmd; /* command about to be executed */ +struct breakpoint *bp; /* breakpoint to test */ +{ + if (bp->re) { +#if TCL_MAJOR_VERSION == 6 + if (0 == regexec(bp->re,cmd)) return 0; +#else + if (0 == TclRegExec(bp->re,cmd,cmd)) return 0; +#endif + save_re_matches(interp,bp->re); + } else if (bp->pat) { + if (0 == Tcl_StringMatch(cmd,bp->pat)) return 0; + } else if (bp->line != NO_LINE) { + /* not yet implemented - awaiting support from Tcl */ + return 0; + } + + if (bp->expr) { + int value; + + /* ignore errors, since they are likely due to */ + /* simply being out of scope a lot */ + if (TCL_OK != Tcl_ExprBoolean(interp,bp->expr,&value)) return 0; + } + + if (bp->cmd) { +#if TCL_MAJOR_VERSION == 6 + Tcl_Eval(interp,bp->cmd,0,(char **)0); +#else + Tcl_Eval(interp,bp->cmd); +#endif + } else { + breakpoint_print(interp,bp); + } + + return 1; +} + +static char *already_at_top_level = "already at top level"; + +/* similar to TclGetFrame but takes two frame ptrs and a direction. +If direction is up, search up stack from curFrame +If direction is down, simulate searching down stack by + seaching up stack from origFrame +*/ +static +int +TclGetFrame2(interp, origFramePtr, string, framePtrPtr, dir) + Tcl_Interp *interp; + CallFrame *origFramePtr; /* frame that is true top-of-stack */ + char *string; /* String describing frame. */ + CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL + * if global frame indicated). */ + enum debug_cmd dir; /* look up or down the stack */ +{ + Interp *iPtr = (Interp *) interp; + int level, result; + CallFrame *framePtr; /* frame currently being searched */ + + CallFrame *curFramePtr = iPtr->varFramePtr; + + /* + * Parse string to figure out which level number to go to. + */ + + result = 1; + if (*string == '#') { + if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) { + return TCL_ERROR; + } + if (level < 0) { + levelError: + Tcl_AppendResult(interp, "bad level \"", string, "\"", + (char *) NULL); + return TCL_ERROR; + } + framePtr = origFramePtr; /* start search here */ + + } else if (isdigit(*string)) { + if (Tcl_GetInt(interp, string, &level) != TCL_OK) { + return TCL_ERROR; + } + if (dir == up) { + if (curFramePtr == 0) { + Tcl_SetResult(interp,already_at_top_level,TCL_STATIC); + return TCL_ERROR; + } + level = curFramePtr->level - level; + framePtr = curFramePtr; /* start search here */ + } else { + if (curFramePtr != 0) { + level = curFramePtr->level + level; + } + framePtr = origFramePtr; /* start search here */ + } + } else { + level = curFramePtr->level - 1; + result = 0; + } + + /* + * Figure out which frame to use. + */ + + if (level == 0) { + framePtr = NULL; + } else { + for (;framePtr != NULL; framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + } + *framePtrPtr = framePtr; + return result; +} + + +static char *printify(s) +char *s; +{ + static int destlen = 0; + char *d; /* ptr into dest */ + unsigned int need; + static char buf_basic[DEFAULT_WIDTH+1]; + static char *dest = buf_basic; + + if (s == 0) return(""); + + /* worst case is every character takes 4 to printify */ + need = strlen(s)*4; + if (need > destlen) { + if (dest && (dest != buf_basic)) free(dest); + dest = (char *)ckalloc(need+1); + destlen = need; + } + + for (d = dest;*s;s++) { + /* since we check at worst by every 4 bytes, play */ + /* conservative and subtract 4 from the limit */ + if (d-dest > destlen-4) break; + + if (*s == '\b') { + strcpy(d,"\\b"); d += 2; + } else if (*s == '\f') { + strcpy(d,"\\f"); d += 2; + } else if (*s == '\v') { + strcpy(d,"\\v"); d += 2; + } else if (*s == '\r') { + strcpy(d,"\\r"); d += 2; + } else if (*s == '\n') { + strcpy(d,"\\n"); d += 2; + } else if (*s == '\t') { + strcpy(d,"\\t"); d += 2; + } else if ((unsigned)*s < 0x20) { /* unsigned strips parity */ + sprintf(d,"\\%03o",*s); d += 4; + } else if (*s == 0177) { + strcpy(d,"\\177"); d += 4; + } else { + *d = *s; d += 1; + } + } + *d = '\0'; + return(dest); +} + +static +char * +print_argv(interp,argc,argv) +Tcl_Interp *interp; +int argc; +char *argv[]; +{ + static int buf_width_max = DEFAULT_WIDTH; + static char buf_basic[DEFAULT_WIDTH+1]; /* basic buffer */ + static char *buf = buf_basic; + int space; /* space remaining in buf */ + int len; + char *bufp; + int proc; /* if current command is "proc" */ + int arg_index; + + if (buf_width > buf_width_max) { + if (buf && (buf != buf_basic)) ckfree(buf); + buf = (char *)ckalloc(buf_width + 1); + buf_width_max = buf_width; + } + + proc = (0 == strcmp("proc",argv[0])); + sprintf(buf,"%.*s",buf_width,argv[0]); + len = strlen(buf); + space = buf_width - len; + bufp = buf + len; + argc--; argv++; + arg_index = 1; + + while (argc && (space > 0)) { + char *elementPtr; + char *nextPtr; + int wrap; + + /* braces/quotes have been stripped off arguments */ + /* so put them back. We wrap everything except lists */ + /* with one argument. One exception is to always wrap */ + /* proc's 2nd arg (the arg list), since people are */ + /* used to always seeing it this way. */ + + if (proc && (arg_index > 1)) wrap = TRUE; + else { + (void) TclFindElement(interp,*argv,&elementPtr, + &nextPtr,(int *)0,(int *)0); + if (*elementPtr == '\0') wrap = TRUE; + else if (*nextPtr == '\0') wrap = FALSE; + else wrap = TRUE; + } + + /* wrap lists (or null) in braces */ + if (wrap) { + sprintf(bufp," {%.*s}",space-3,*argv); + } else { + sprintf(bufp," %.*s",space-1,*argv); + } + len = strlen(buf); + space = buf_width - len; + bufp = buf + len; + argc--; argv++; + arg_index++; + } + + if (compress) { + /* this copies from our static buf to printify's static buf */ + /* and back to our static buf */ + strncpy(buf,printify(buf),buf_width); + } + + /* usually but not always right, but assume truncation if buffer is */ + /* full. this avoids tiny but odd-looking problem of appending "}" */ + /* to truncated lists during {}-wrapping earlier */ + if (strlen(buf) == buf_width) { + buf[buf_width-1] = buf[buf_width-2] = buf[buf_width-3] = '.'; + } + + return(buf); +} + +static +void +PrintStackBelow(interp,curf,viewf) +Tcl_Interp *interp; +CallFrame *curf; /* current FramePtr */ +CallFrame *viewf; /* view FramePtr */ +{ + char ptr; /* graphically indicate where we are in the stack */ + + /* indicate where we are in the stack */ + ptr = ((curf == viewf)?'*':' '); + + if (curf == 0) { + print(interp,"%c0: %s\n", + ptr,print_argv(interp,main_argc,main_argv)); + } else { + PrintStackBelow(interp,curf->callerVarPtr,viewf); + print(interp,"%c%d: %s\n",ptr,curf->level, + print_argv(interp,curf->argc,curf->argv)); + } +} + +static +void +PrintStack(interp,curf,viewf,argc,argv,level) +Tcl_Interp *interp; +CallFrame *curf; /* current FramePtr */ +CallFrame *viewf; /* view FramePtr */ +int argc; +char *argv[]; +char *level; +{ + PrintStackBelow(interp,curf,viewf); + + print(interp," %s: %s\n",level,print_argv(interp,argc,argv)); +} + +/* return 0 if goal matches current frame or goal can't be found */ +/* anywere in frame stack */ +/* else return 1 */ +/* This catches things like a proc called from a Tcl_Eval which in */ +/* turn was not called from a proc but some builtin such as source */ +/* or Tcl_Eval. These builtin calls to Tcl_Eval lose any knowledge */ +/* the FramePtr from the proc, so we have to search the entire */ +/* stack frame to see if it's still there. */ +static int +GoalFrame(goal,iptr) +CallFrame *goal; +Interp *iptr; +{ + CallFrame *cf = iptr->varFramePtr; + + /* if at current level, return success immediately */ + if (goal == cf) return 0; + + while (cf) { + cf = cf->callerVarPtr; + if (goal == cf) { + /* found, but since it's above us, fail */ + return 1; + } + } + return 0; +} + +/* debugger's trace handler */ +/*ARGSUSED*/ +static void +debugger_trap(clientData,interp,level,command,cmdProc,cmdClientData,argc,argv) +ClientData clientData; /* not used */ +Tcl_Interp *interp; +int level; /* positive number if called by Tcl, -1 if */ + /* called by Dbg_On in which case we don't */ + /* know the level */ +char *command; +int (*cmdProc)(); /* not used */ +ClientData cmdClientData; +int argc; +char *argv[]; +{ + char level_text[6]; /* textual representation of level */ + + int break_status; + Interp *iPtr = (Interp *)interp; + + CallFrame *trueFramePtr; /* where the pc is */ + CallFrame *viewFramePtr; /* where up/down are */ + + int print_command_first_time = TRUE; + static int debug_suspended = FALSE; + + struct breakpoint *b; + + /* skip commands that are invoked interactively */ + if (debug_suspended) return; + + /* skip debugger commands */ + if (argv[0][1] == '\0') { + switch (argv[0][0]) { + case 'n': + case 's': + case 'c': + case 'r': + case 'w': + case 'b': + case 'u': + case 'd': return; + } + } + + if ((*ignoreproc)(interp,argv[0])) return; + + /* if level is unknown, use "?" */ + sprintf(level_text,(level == -1)?"?":"%d",level); + + /* save so we can restore later */ + trueFramePtr = iPtr->varFramePtr; + + /* test all breakpoints to see if we should break */ + debug_suspended = TRUE; + + /* if any successful breakpoints, start interactor */ + debug_new_action = FALSE; /* reset strobe */ + break_status = FALSE; /* no successful breakpoints yet */ + for (b = break_base;b;b=b->next) { + break_status |= breakpoint_test(interp,command,b); + } + if (!debug_new_action && break_status) goto start_interp; + + /* if s or n triggered by breakpoint, make "s 1" (and so on) */ + /* refer to next command, not this one */ + if (debug_new_action) step_count++; + + switch (debug_cmd) { + case cont: + goto finish; + case step: + step_count--; + if (step_count > 0) goto finish; + goto start_interp; + case next: + /* check if we are back at the same level where the next */ + /* command was issued. Also test */ + /* against all FramePtrs and if no match, assume that */ + /* we've missed a return, and so we should break */ +/* if (goalFramePtr != iPtr->varFramePtr) goto finish;*/ + if (GoalFrame(goalFramePtr,iPtr)) goto finish; + step_count--; + if (step_count > 0) goto finish; + goto start_interp; + case Next: + /* check if we are back at the same level where the next */ + /* command was issued. */ + if (goalNumLevel < iPtr->numLevels) goto finish; + step_count--; + if (step_count > 0) goto finish; + goto start_interp; + case ret: + /* same comment as in "case next" */ + if (goalFramePtr != iPtr->varFramePtr) goto finish; + goto start_interp; + } + +start_interp: + if (print_command_first_time) { + print(interp,"%s: %s\n", + level_text,print_argv(interp,1,&command)); + print_command_first_time = FALSE; + } + /* since user is typing a command, don't interrupt it immediately */ + debug_cmd = cont; + debug_suspended = FALSE; + + /* interactor won't return until user gives a debugger cmd */ + (*interactor)(interp); + + /* save this so it can be restored after "w" command */ + viewFramePtr = iPtr->varFramePtr; + + if (debug_cmd == up || debug_cmd == down) { + /* calculate new frame */ + if (-1 == TclGetFrame2(interp,trueFramePtr,viewFrameName, + &iPtr->varFramePtr,debug_cmd)) { + print(interp,"%s\n",interp->result); + Tcl_ResetResult(interp); + } + goto start_interp; + } + + /* reset view back to normal */ + iPtr->varFramePtr = trueFramePtr; + + /* allow trapping */ + debug_suspended = FALSE; + + switch (debug_cmd) { + case cont: + case step: + goto finish; + case next: + goalFramePtr = iPtr->varFramePtr; + goto finish; + case Next: + goalNumLevel = iPtr->numLevels; + goto finish; + case ret: + goalFramePtr = iPtr->varFramePtr; + if (goalFramePtr == 0) { + print(interp,"nowhere to return to\n"); + break; + } + goalFramePtr = goalFramePtr->callerVarPtr; + goto finish; + case where: + PrintStack(interp,iPtr->varFramePtr,viewFramePtr,argc,argv,level_text); + break; + } + + /* restore view and restart interactor */ + iPtr->varFramePtr = viewFramePtr; + goto start_interp; + + finish: + debug_suspended = FALSE; +} + +/*ARGSUSED*/ +static +int +cmdNext(clientData, interp, argc, argv) +ClientData clientData; +Tcl_Interp *interp; +int argc; +char **argv; +{ + debug_cmd = *(enum debug_cmd *)clientData; + debug_new_action = TRUE; + + step_count = (argc == 1)?1:atoi(argv[1]); + return(TCL_RETURN); +} + +/*ARGSUSED*/ +static +int +cmdDir(clientData, interp, argc, argv) +ClientData clientData; +Tcl_Interp *interp; +int argc; +char **argv; +{ + debug_cmd = *(enum debug_cmd *)clientData; + + if (argc == 1) argv[1] = "1"; + strncpy(viewFrameName,argv[1],FRAMENAMELEN); + + return TCL_RETURN; +} + +/*ARGSUSED*/ +static +int +cmdSimple(clientData, interp, argc, argv) +ClientData clientData; +Tcl_Interp *interp; +int argc; +char **argv; +{ + debug_cmd = *(enum debug_cmd *)clientData; + debug_new_action = TRUE; + return TCL_RETURN; +} + +static +void +breakpoint_destroy(b) +struct breakpoint *b; +{ + if (b->file) ckfree(b->file); + if (b->pat) ckfree(b->pat); + if (b->re) ckfree((char *)b->re); + if (b->cmd) ckfree(b->cmd); + + /* unlink from chain */ + if ((b->previous == 0) && (b->next == 0)) { + break_base = 0; + } else if (b->previous == 0) { + break_base = b->next; + b->next->previous = 0; + } else if (b->next == 0) { + b->previous->next = 0; + } else { + b->previous->next = b->next; + b->next->previous = b->previous; + } + + ckfree((char *)b); +} + +static void +savestr(straddr,str) +char **straddr; +char *str; +{ + *straddr = ckalloc(strlen(str)+1); + strcpy(*straddr,str); +} + +/* return 1 if a string is substring of a flag */ +static int +flageq(flag,string,minlen) +char *flag; +char *string; +int minlen; /* at least this many chars must match */ +{ + for (;*flag;flag++,string++,minlen--) { + if (*string == '\0') break; + if (*string != *flag) return 0; + } + if (*string == '\0' && minlen <= 0) return 1; + return 0; +} + +/*ARGSUSED*/ +static +int +cmdWhere(clientData, interp, argc, argv) +ClientData clientData; +Tcl_Interp *interp; +int argc; +char **argv; +{ + if (argc == 1) { + debug_cmd = where; + return TCL_RETURN; + } + + argc--; argv++; + + while (argc) { + if (flageq("-width",*argv,2)) { + argc--; argv++; + if (*argv) { + buf_width = atoi(*argv); + argc--; argv++; + } else print(interp,"%d\n",buf_width); + } else if (flageq("-compress",*argv,2)) { + argc--; argv++; + if (*argv) { + compress = atoi(*argv); + argc--; argv++; + } else print(interp,"%d\n",compress); + } else { + print(interp,"usage: w [-width #] [-compress 0|1]\n"); + return TCL_ERROR; + } + } + return TCL_OK; +} + +#define breakpoint_fail(msg) {error_msg = msg; goto break_fail;} + +/*ARGSUSED*/ +static +int +cmdBreak(clientData, interp, argc, argv) +ClientData clientData; +Tcl_Interp *interp; +int argc; +char **argv; +{ + struct breakpoint *b; + char *error_msg; + + argc--; argv++; + + if (argc < 1) { + for (b = break_base;b;b=b->next) breakpoint_print(interp,b); + return(TCL_OK); + } + + if (argv[0][0] == '-') { + if (argv[0][1] == '\0') { + while (break_base) { + breakpoint_destroy(break_base); + } + breakpoint_max_id = 0; + return(TCL_OK); + } else if (isdigit(argv[0][1])) { + int id = atoi(argv[0]+1); + + for (b = break_base;b;b=b->next) { + if (b->id == id) { + breakpoint_destroy(b); + if (!break_base) breakpoint_max_id = 0; + return(TCL_OK); + } + } + Tcl_SetResult(interp,"no such breakpoint",TCL_STATIC); + return(TCL_ERROR); + } + } + + b = breakpoint_new(); + + if (flageq("-regexp",argv[0],2)) { + argc--; argv++; +#if TCL_MAJOR_VERSION == 6 + if ((argc > 0) && (b->re = regcomp(argv[0]))) { +#else + if ((argc > 0) && (b->re = TclRegComp(argv[0]))) { +#endif + savestr(&b->pat,argv[0]); + argc--; argv++; + } else { + breakpoint_fail("bad regular expression") + } + } else if (flageq("-glob",argv[0],2)) { + argc--; argv++; + if (argc > 0) { + savestr(&b->pat,argv[0]); + argc--; argv++; + } else { + breakpoint_fail("no pattern?"); + } + } else if ((!(flageq("if",*argv,1)) && (!(flageq("then",*argv,1))))) { + /* look for [file:]line */ + char *colon; + char *linep; /* pointer to beginning of line number */ + + colon = strchr(argv[0],':'); + if (colon) { + *colon = '\0'; + savestr(&b->file,argv[0]); + *colon = ':'; + linep = colon + 1; + } else { + linep = argv[0]; + /* get file from current scope */ + /* savestr(&b->file, ?); */ + } + + if (TCL_OK == Tcl_GetInt(interp,linep,&b->line)) { + argc--; argv++; + print(interp,"setting breakpoints by line number is currently unimplemented - use patterns or expressions\n"); + } else { + /* not an int? - unwind & assume it is an expression */ + + if (b->file) ckfree(b->file); + } + } + + if (argc > 0) { + int do_if = FALSE; + + if (flageq("if",argv[0],1)) { + argc--; argv++; + do_if = TRUE; + } else if (!flageq("then",argv[0],1)) { + do_if = TRUE; + } + + if (do_if) { + if (argc < 1) { + breakpoint_fail("if what"); + } + + savestr(&b->expr,argv[0]); + argc--; argv++; + } + } + + if (argc > 0) { + if (flageq("then",argv[0],1)) { + argc--; argv++; + } + + if (argc < 1) { + breakpoint_fail("then what?"); + } + + savestr(&b->cmd,argv[0]); + } + + sprintf(interp->result,"%d",b->id); + return(TCL_OK); + + break_fail: + breakpoint_destroy(b); + Tcl_SetResult(interp,error_msg,TCL_STATIC); + return(TCL_ERROR); +} + +static char *help[] = { +"s [#] step into procedure", +"n [#] step over procedure", +"N [#] step over procedures, commands, and arguments", +"c continue", +"r continue until return to caller", +"u [#] move scope up level", +"d [#] move scope down level", +" go to absolute frame if # is prefaced by \"#\"", +"w show stack (\"where\")", +"w -w [#] show/set width", +"w -c [0|1] show/set compress", +"b show breakpoints", +"b [-r regexp-pattern] [if expr] [then command]", +"b [-g glob-pattern] [if expr] [then command]", +"b [[file:]#] [if expr] [then command]", +" if pattern given, break if command resembles pattern", +" if # given, break on line #", +" if expr given, break if expr true", +" if command given, execute command at breakpoint", +"b -# delete breakpoint", +"b - delete all breakpoints", +0}; + +/*ARGSUSED*/ +static +int +cmdHelp(clientData, interp, argc, argv) +ClientData clientData; +Tcl_Interp *interp; +int argc; +char **argv; +{ + char **hp; + + for (hp=help;*hp;hp++) { + print(interp,"%s\n",*hp); + } + + return(TCL_OK); +} + +/* this may seem excessive, but this avoids the explicit test for non-zero */ +/* in the caller, and chances are that that test will always be pointless */ +/*ARGSUSED*/ +static int zero(interp,string) +Tcl_Interp *interp; +char *string; +{ + return 0; +} + +static int +simple_interactor(interp) +Tcl_Interp *interp; +{ + int rc; + char *ccmd; /* pointer to complete command */ + char line[BUFSIZ+1]; /* space for partial command */ + int newcmd = TRUE; + Interp *iPtr = (Interp *)interp; + +#if TCL_MAJOR_VERSION == 6 + Tcl_CmdBuf buffer; + + if (!(buffer = Tcl_CreateCmdBuf())) { + Tcl_AppendElement(interp,"no more space for cmd buffer",0); + return(TCL_ERROR); + } +#else + Tcl_DString dstring; + Tcl_DStringInit(&dstring); +#endif + + + newcmd = TRUE; + while (TRUE) { + if (newcmd) { + print(interp,"dbg%d.%d> ",iPtr->numLevels,iPtr->curEventNum+1); + } else { + print(interp,"dbg+> "); + } + fflush(stdout); + + if (0 >= (rc = read(0,line,BUFSIZ))) { + if (!newcmd) line[0] = 0; + else exit(0); + } else line[rc] = '\0'; + +#if TCL_MAJOR_VERSION == 6 + if (NULL == (ccmd = Tcl_AssembleCmd(buffer,line))) { +#else + ccmd = Tcl_DStringAppend(&dstring,line,rc); + if (!Tcl_CommandComplete(ccmd)) { +#endif + newcmd = FALSE; + continue; /* continue collecting command */ + } + newcmd = TRUE; + + rc = Tcl_RecordAndEval(interp,ccmd,0); +#if TCL_MAJOR_VERSION != 6 + Tcl_DStringFree(&dstring); +#endif + switch (rc) { + case TCL_OK: + if (*interp->result != 0) + print(interp,"%s\n",interp->result); + continue; + case TCL_ERROR: + print(interp,"%s\n",Tcl_GetVar(interp,"errorInfo",TCL_GLOBAL_ONLY)); + /* since user is typing by hand, we expect lots + of errors, and want to give another chance */ + continue; + case TCL_BREAK: + case TCL_CONTINUE: +#define finish(x) {rc = x; goto done;} + finish(rc); + case TCL_RETURN: + finish(TCL_OK); + default: + /* note that ccmd has trailing newline */ + print(interp,"error %d: %s\n",rc,ccmd); + continue; + } + } + /* cannot fall thru here, must jump to label */ + done: +#if TCL_MAJOR_VERSION == 6 + /* currently, code guarantees buffer is valid */ + Tcl_DeleteCmdBuf(buffer); +#else + Tcl_DStringFree(&dstring); +#endif + + return(rc); +} + +/* occasionally, we print things larger buf_max but not by much */ +/* see print statements in PrintStack routines for examples */ +#define PAD 80 + +static void +print(va_alist ) +va_dcl +{ + Tcl_Interp *interp; + char *fmt; + va_list args; + + va_start(args); + interp = va_arg(args,Tcl_Interp *); + fmt = va_arg(args,char *); + if (!printproc) vprintf(fmt,args); + else { + static int buf_width_max = DEFAULT_WIDTH+PAD; + static char buf_basic[DEFAULT_WIDTH+PAD+1]; + static char *buf = buf_basic; + + if (buf_width+PAD > buf_width_max) { + if (buf && (buf != buf_basic)) ckfree(buf); + buf = (char *)ckalloc(buf_width+PAD+1); + buf_width_max = buf_width+PAD; + } + + vsprintf(buf,fmt,args); + (*printproc)(interp,buf); + } + va_end(args); +} + +/*ARGSUSED*/ +Dbg_InterProc * +Dbg_Interactor(interp,inter_proc) +Tcl_Interp *interp; +Dbg_InterProc *inter_proc; +{ + Dbg_InterProc *tmp = interactor; + interactor = (inter_proc?inter_proc:simple_interactor); + return tmp; +} + +/*ARGSUSED*/ +Dbg_IgnoreFuncsProc * +Dbg_IgnoreFuncs(interp,proc) +Tcl_Interp *interp; +Dbg_IgnoreFuncsProc *proc; +{ + Dbg_IgnoreFuncsProc *tmp = ignoreproc; + ignoreproc = (proc?proc:zero); + return tmp; +} + +/*ARGSUSED*/ +Dbg_OutputProc * +Dbg_Output(interp,proc) +Tcl_Interp *interp; +Dbg_OutputProc *proc; +{ + Dbg_OutputProc *tmp = printproc; + printproc = (proc?proc:0); + return tmp; +} + + +/*ARGSUSED*/ +int +Dbg_Active(interp) +Tcl_Interp *interp; +{ + return debugger_active; +} + +char ** +Dbg_ArgcArgv(argc,argv,copy) +int argc; +char *argv[]; +int copy; +{ + char **alloc; + + if (!copy) { + main_argv = argv; + alloc = 0; + } else { + main_argv = alloc = (char **)ckalloc((argc+1)*sizeof(char *)); + while (argc-- >= 0) { + *main_argv++ = *argv++; + } + main_argv = alloc; + } + return alloc; +} + +static struct cmd_list { + char *cmdname; + Tcl_CmdProc *cmdproc; + enum debug_cmd cmdtype; +} cmd_list[] = {{"n", cmdNext, next}, + {"s", cmdNext, step}, + {"N", cmdNext, Next}, + {"c", cmdSimple, cont}, + {"r", cmdSimple, ret}, + {"w", cmdWhere, none}, + {"b", cmdBreak, none}, + {"u", cmdDir, up}, + {"d", cmdDir, down}, + {"h", cmdHelp, none}, + {0} +}; + +static void +init_debugger(interp) +Tcl_Interp *interp; +{ + struct cmd_list *c; + + for (c = cmd_list;c->cmdname;c++) { + Tcl_CreateCommand(interp,c->cmdname,c->cmdproc, + (ClientData)&c->cmdtype,(Tcl_CmdDeleteProc *)0); + } + + debug_handle = Tcl_CreateTrace(interp, + 10000,debugger_trap,(ClientData)0); + + debugger_active = TRUE; + Tcl_SetVar2(interp,Dbg_VarName,"active","1",0); +} + +/* allows any other part of the application to jump to the debugger */ +/*ARGSUSED*/ +void +Dbg_On(interp,immediate) +Tcl_Interp *interp; +int immediate; /* if true, stop immediately */ + /* should only be used in safe places */ + /* i.e., when Tcl_Eval can be called */ +{ + if (!debugger_active) init_debugger(interp); + + debug_cmd = step; + step_count = 1; + + if (immediate) { + static char *fake_cmd = "--interrupted-- (command_unknown)"; + + debugger_trap((ClientData)0,interp,-1,fake_cmd,(int (*)())0, + (ClientData)0,1,&fake_cmd); +/* (*interactor)(interp);*/ + } +} + +void +Dbg_Off(interp) +Tcl_Interp *interp; +{ + struct cmd_list *c; + + if (!debugger_active) return; + + for (c = cmd_list;c->cmdname;c++) { + Tcl_DeleteCommand(interp,c->cmdname); + } + + Tcl_DeleteTrace(interp,debug_handle); + debugger_active = FALSE; + Tcl_UnsetVar(interp,Dbg_VarName,TCL_GLOBAL_ONLY); +} diff --git a/Dbg.h b/Dbg.h new file mode 100644 index 00000000..29364f4d --- /dev/null +++ b/Dbg.h @@ -0,0 +1,46 @@ +/* Dbg.h - Tcl Debugger include file + +Written by: Don Libes, NIST, 3/23/93 + +Design and implementation of this program was paid for by U.S. tax +dollars. Therefore it is public domain. However, the author and NIST +would appreciate credit if this program or parts of it are used. + +*/ + +/* _DEBUG or _DBG is just too likely, use something more unique */ +#ifndef _NIST_DBG +#define _NIST_DBG + +#include "tcl.h" + +typedef int (Dbg_InterProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef int (Dbg_IgnoreFuncsProc) _ANSI_ARGS_(( + Tcl_Interp *interp, + char *funcname)); +typedef void (Dbg_OutputProc) _ANSI_ARGS_(( + Tcl_Interp *interp, + char *output)); + +EXTERN char *Dbg_VarName; +EXTERN char *Dbg_DefaultCmdName; + +/* trivial interface, creates a "debug" command in your interp */ +EXTERN int Dbg_Init _ANSI_ARGS_((Tcl_Interp *)); + +EXTERN void Dbg_On _ANSI_ARGS_((Tcl_Interp *interp, + int immediate)); +EXTERN void Dbg_Off _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN char **Dbg_ArgcArgv _ANSI_ARGS_((int argc,char *argv[], + int copy)); +EXTERN int Dbg_Active _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Dbg_InterProc *Dbg_Interactor _ANSI_ARGS_(( + Tcl_Interp *interp, + Dbg_InterProc *interactor)); +EXTERN Dbg_IgnoreFuncsProc *Dbg_IgnoreFuncs _ANSI_ARGS_(( + Tcl_Interp *interp, + Dbg_IgnoreFuncsProc *)); +EXTERN Dbg_OutputProc *Dbg_Output _ANSI_ARGS_(( + Tcl_Interp *interp, + Dbg_OutputProc *)); +#endif /* _NIST_DBG */ diff --git a/Dbg_cmd.c b/Dbg_cmd.c new file mode 100644 index 00000000..9ab2ceda --- /dev/null +++ b/Dbg_cmd.c @@ -0,0 +1,64 @@ +/* Dbg_cmd.c - Tcl Debugger default command, used if app writer wants a + quick and reasonable default. + +Written by: Don Libes, NIST, 3/23/93 + +Design and implementation of this program was paid for by U.S. tax +dollars. Therefore it is public domain. However, the author and NIST +would appreciate credit if this program or parts of it are used. + +*/ + +#include "tclInt.h" +#include "Dbg.h" + +char *Dbg_DefaultCmdName = "debug"; + +/*ARGSUSED*/ +static int +App_DebugCmd(clientData, interp, argc, argv) +ClientData clientData; +Tcl_Interp *interp; +int argc; +char **argv; +{ + int now = 0; /* soon if 0, now if 1 */ + + if (argc > 3) goto usage; + + argv++; + + while (*argv) { + if (0 == strcmp(*argv,"-now")) { + now = 1; + argv++; + } + else break; + } + + if (!*argv) { + if (now) { + Dbg_On(interp,1); + } else { + goto usage; + } + } else if (0 == strcmp(*argv,"0")) { + Dbg_Off(interp); + } else { + Dbg_On(interp,now); + } + return(TCL_OK); + usage: + interp->result = "usage: [[-now] 1|0]"; + return TCL_ERROR; +} + +int +Dbg_Init(interp) +Tcl_Interp *interp; +{ + Tcl_CreateCommand(interp,Dbg_DefaultCmdName,App_DebugCmd, + (ClientData)0,(void (*)())0); + return TCL_OK; +} + diff --git a/HistDriv.i b/HistDriv.i new file mode 100644 index 00000000..c24438b7 --- /dev/null +++ b/HistDriv.i @@ -0,0 +1,84 @@ + +#line 462 "histogram.w" + +/*--------------------------------------------------------------------------- + H I S T D R I V + internal header file which includes the definition of the Histogram memory + driver structure. + + Mark Koennecke, April 1997 +----------------------------------------------------------------------------*/ +#ifndef SICSHISTDRIV +#define SICSHISTDRIV +#include "hmdata.h" + + +#line 89 "histogram.w" + + typedef struct __HistDriver { + pHMdata data; + /* counting operations data */ + CounterMode eCount; + float fCountPreset; + /* status flags */ + int iReconfig; + int iUpdate; + /* interface functions */ + int (*Configure)(pHistDriver self, + SConnection *pCon, + pStringDict pOpt, + SicsInterp *pSics); + int (*Start)(pHistDriver self, + SConnection *pCon); + int (*Halt)(pHistDriver self); + int (*GetCountStatus)(pHistDriver self, + SConnection *pCon); + int (*GetError)(pHistDriver self, + int *iCode, + char *perror, + int iErrlen); + int (*TryAndFixIt)(pHistDriver self, + int iCode); + int (*GetData)(pHistDriver self, + SConnection *pCon); + int (*GetHistogram)(pHistDriver self, + SConnection *pCon, + int i, + int iStart, int iEnd, + HistInt *pData); + + int (*SetHistogram)(pHistDriver self, + SConnection *pCon, + int i, + int iStart, int iEnd, + HistInt *pData); + long (*GetMonitor)(pHistDriver self, + int i, + SConnection *pCon); + float (*GetTime)(pHistDriver self, + SConnection *pCon); + int (*Preset)(pHistDriver self, + SConnection *pCon, + HistInt iVal); + int (*Pause)(pHistDriver self, + SConnection *pCon); + int (*Continue)(pHistDriver self, + SConnection *pCon); + int (*FreePrivate)(pHistDriver self); + void *pPriv; + } HistDriver; + +#line 474 "histogram.w" + + +#line 228 "histogram.w" + + pHistDriver CreateHistDriver(pStringDict pDict); + void DeleteHistDriver(pHistDriver self); + int HistDriverConfig(pHistDriver self, pStringDict pOpt, + SConnection *pCon); + +#line 475 "histogram.w" + + +#endif diff --git a/HistMem.h b/HistMem.h new file mode 100644 index 00000000..a05cb32f --- /dev/null +++ b/HistMem.h @@ -0,0 +1,100 @@ + +#line 435 "histogram.w" + +/*-------------------------------------------------------------------------- + H I S T M E M + + header for the histogram memory object for SICS. + + copyright: see implementation file. + Mark Koennecke, April 1997 +-----------------------------------------------------------------------------*/ +#ifndef SICSHISTMEM +#define SICSHISTMEM +#define MAXDIM 3 + + typedef struct __HistDriver *pHistDriver; + typedef struct __HistMem *pHistMem; +/*-------------------------------------------------------------------------*/ + typedef int HistInt; +/* + 32 bit integer on a DigitalUnix +*/ + +#line 9 "histogram.w" + + typedef enum { + eHTransparent, + eHNormal, + eHTOF, + eHStrobo, + eHRPT, + ePSD, + eSANSTOF + } HistMode; + +#line 36 "histogram.w" + + typedef enum { + eOIgnore, + eOCeil, + eOCount, + eReflect + } OverFlowMode; + +#line 455 "histogram.w" + +/*--------------------------------------------------------------------------*/ + +#line 287 "histogram.w" + + pHistMem CreateHistMemory(char *drivername); + void DeleteHistMemory(void *self); + +#line 303 "histogram.w" + + int HistGetOption(pHistMem self, char *name, char *result, int iResultLen); + int HistSetOption(pHistMem self, char *name, char *value); + int HistConfigure(pHistMem self, SConnection *pCon, SicsInterp *pSics); + +#line 331 "histogram.w" + + float GetHistPreset(pHistMem self); + int SetHistPreset(pHistMem self, float fVal); + CounterMode GetHistCountMode(pHistMem self); + int SetHistCountMode(pHistMem self, CounterMode eNew); + long GetHistMonitor(pHistMem self, int i, SConnection *pCon); + const float *GetHistTimeBin(pHistMem self, int *iLength); + int GetHistLength(pHistMem self); + int GetHistDim(pHistMem self, int iDim[MAXDIM], int *nDim); + float GetHistCountTime(pHistMem self,SConnection *pCon); + int HistDoCount(pHistMem self, SConnection *pCon); + int HistBlockCount(pHistMem self, SConnection *pCon); + void HistDirty(pHistMem self); + + +#line 361 "histogram.w" + + int SetHistogram(pHistMem self, SConnection *pCon, + int i,int iStart, int iEnd, HistInt *lData); + int GetHistogram(pHistMem self, SConnection *pCon, + int i,int iStart, int iEnd, HistInt *lData, int iDataLen); + HistInt *GetHistogramPointer(pHistMem self,SConnection *pCon); + int GetHistogramDirect(pHistMem self, SConnection *pCon, + int i, int iStart, int iEnd, + HistInt *lData, int iDataLen); + int PresetHistogram(pHistMem self, SConnection *pCon, HistInt lVal); + +#line 404 "histogram.w" + + int MakeHistMemory(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + int HistAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + +#line 457 "histogram.w" + + +#endif diff --git a/HistMem.i b/HistMem.i new file mode 100644 index 00000000..74a106b1 --- /dev/null +++ b/HistMem.i @@ -0,0 +1,30 @@ + +#line 480 "histogram.w" + +/*--------------------------------------------------------------------------- + H I S T M E M -- Internal + internal header file which includes the definition of the Histogram memory + data structure. + + Mark Koennecke, April 1997 +----------------------------------------------------------------------------*/ +#ifndef SICSHISTMEMINT +#define SICSHISTMEMINT + +#line 250 "histogram.w" + + typedef struct __HistMem { + pObjectDescriptor pDes; + int iAccess; + int iExponent; + pHistDriver pDriv; + int iInit; + pICountable pCountInt; + pICallBack pCall; + pStringDict pOption; + } HistMem; + +#line 490 "histogram.w" + + +#endif diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..566dff71 --- /dev/null +++ b/Makefile @@ -0,0 +1,131 @@ +#---------------------------------------------------------------------------- +# Makefile for SICS +# +# Mark Koennecke 1996-2001 +# Markus Zolliker March 2000: add tecs +#--------------------------------------------------------------------------- + + +#------- comment or uncomment this if a fortified version is required. +# Note: A -DFORTIFY needs to be added to the CFLAGS as well. +# +#FORTIFYOBJ = fortify.o strdup.o +#---- +FORTIFYOBJ = +#--------------------------------------------------------------------------- + +#========================================================================== +# assign if the National Instrument GPIB driver is available +#NI= -DHAVENI +#NIOBJ= nigpib.o +#NILIB=-lgpibenet +NI= +NIOBJ= +NILIB= + +#----- 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= +DIFIL= +#DIFOBJ=difrac.o -Ldifrac -ldif -lfor +#---- +#DIFOBJ=difrac.o -Ldifrac -ldif +#DIFIL= difrac.o +#--------------------------------------------------------------------------- + + +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 buffer.o strrepl.o ruli.o lin2ang.o fomerge.o\ + script.o o2t.o alias.o napi45.o nxdata.o stringdict.o sdynar.o\ + histmem.o histdriv.o histsim.o sinqhmdriv.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 + +MOTOROBJ = motor.o el734driv.o simdriv.o el734dc.o pipiezo.o pimotor.o +COUNTEROBJ = countdriv.o simcter.o counter.o +DMCOBJ = dmc.o +VELOOBJ = velo.o velosim.o velodorn.o velodornier.o + +.SUFFIXES: +.SUFFIXES: .tcl .htm .c .o + +#----- comment or uncomment the following according to operating system + +#------------- for Digital Unix +BINTARGET = bin +HDFROOT=/data/lnslib +CC=cc +EXTRA= +CFLAGS = -I$(HDFROOT)/include -Ihardsup -DHDF4 -DHDF5 -I. -std1 \ + -check_bounds -g -warnprotos -c +#CFLAGS = -I$(HDFROOT)/include -DFORTIFY -DHDF4 -DHDF5 -Ihardsup -g \ +# -std1 -warnprotos -c +LIBS = -L$(HDFROOT)/lib -Lhardsup -lhlib -Lmatrix -lmatrix -Ltecs \ + -ltecsl -ltcl8.0 -lfor $(HDFROOT)/lib/libhdf5.a \ + $(HDFROOT)/lib/libLNSmfhdf.a $(HDFROOT)/lib/libLNSdf.a \ + $(HDFROOT)/lib/libLNSjpeg.a -lLNSz -lm -ll -lc + +#------- for cygnus +#HDFROOT=../HDF411 +#CC=gcc +#EXTRA= +#CFLAGS = -I$(HDFROOT)/include -Ihardsup -DFORTIFY -DCYGNUS -g -c +#LIBS= -L$(HDFROOT)/lib -Lhardsup -lhlib -ltcl80 \ +# -lmfhdf -ldf -ljpeg -lz -lm + +#---------- for linux +#BINTARGET=../../bin +#HDFROOT=$(SINQDIR)/linux +#CC=gcc +#CFLAGS = -I$(HDFROOT)/include -DHDF4 -DHDF5 $(NI) -Ihardsup \ +# -fwritable-strings -DCYGNUS -DNONINTF -g -c +#CFLAGS = -I$(HDFROOT)/include -DFORTIFY -DHDF4 -DHDF5 $(NI) -Ihardsup \ +# -fwritable-strings -DCYGNUS -DNONINTF -g -c +#LIBS= -L$(HDFROOT)/lib -Lhardsup -Ltecs -ltecsl -Lmatrix -lmatrix -lhlib \ +# $(NILIB) -ltcl -lhdf5 -lmfhdf -ldf -ljpeg -lz -lm -lg2c -ldl +#EXTRA=nintf.o +#--------------------------------- + +.c.o: + $(CC) $(CFLAGS) $*.c + +all: $(BINTARGET)/SICServer + +$(BINTARGET)/SICServer: $(SOBJ) $(MOTOROBJ) \ + $(COUNTEROBJ) $(DMCOBJ) $(VELOOBJ) $(DIFIL) \ + $(EXTRA) tecs/libtecsl.a hardsup/libhlib.a \ + matrix/libmatrix.a + $(CC) -g -o SICServer \ + $(SOBJ) $(MOTOROBJ) $(COUNTEROBJ) $(DMCOBJ) \ + $(VELOOBJ) $(DIFOBJ) $(EXTRA) $(LIBS) + cp SICServer $(BINTARGET) + +clean: + - rm -f *.o + - rm -f $(BINTARGET)/SICServer + +Dbg.o: Dbg.c + cc -g -I/data/koenneck/include -c Dbg.c +Dbg_cmd.o: Dbg_cmd.c + + diff --git a/SCinter.c b/SCinter.c new file mode 100644 index 00000000..a43f4079 --- /dev/null +++ b/SCinter.c @@ -0,0 +1,569 @@ +/*--------------------------------------------------------------------------- + + Implementation file for the SICS-interpreter. + + + + 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. + + M. Zolliker, Sept 2000, introduced formal aliases, modifications marked M.Z + Mark Koennecke, August 2001, modified SicsWriteStatus to write motor + positions on demand. +---------------------------------------------------------------------------*/ +#include +#include +#include +#include +#include +#include +#include "fortify.h" +#include "sics.h" +#include "splitter.h" +#include "servlog.h" +#include "macro.h" +#include "interface.h" +#include "motor.h" +#include "obdes.h" + +/* M.Z. */ +#include "definealias.h" + + +#define MAXLEN 256 +#define MAXPAR 100 + +/*--------------------------------------------------------------------------*/ + SicsInterp *InitInterp(void) + { + SicsInterp *pInter = NULL; + int i; + + pInter = (SicsInterp *)malloc(sizeof(SicsInterp)); + if(!pInter) + { + SICSLogWrite("Error allocating memory for Interpreter",eInternal); + return NULL; + } + pInter->pCList = NULL; + pInter->AList.pFirst = NULL; /* M.Z. */ + pInter->pTcl = (void *)MacroInit(pInter); + if(!pInter->pTcl) + { + free(pInter); + return NULL; + } + + pInter->iDeleting = 0; + return pInter; + } +/*------------------------------------------------------------------------*/ + int AddCommand(SicsInterp *pInterp, char *pName, ObjectFunc pFunc, + KillFunc pKFunc, void *pData) + { + CommandList *pNew = NULL; + char pBueffel[512]; + + assert(pName); + assert(pFunc); + assert(pInterp); + + strcpy(pBueffel,pName); + strtolower(pBueffel); + RemoveAlias(&pInterp->AList,pBueffel); /* M.Z. */ + if(FindCommand(pInterp,pBueffel) != NULL) + { + return 0; + } + + /* new memory */ + pNew = (CommandList *)malloc(sizeof(CommandList)); + if(!pNew) + { + sprintf(pBueffel, + "Out of memory creating command - %s -", pName); + SICSLogWrite(pBueffel,eInternal); + return 0; + } + + /* if no data given, initialise with Dummy struct */ + if(!pData) + { + pData = (void *)CreateDummy(pBueffel); + if(!pKFunc) + { + pKFunc = KillDummy; + } + } + + /* initialise datastructures */ + pNew->pName = strdup(pBueffel); + pNew->OFunc = pFunc; + pNew->KFunc = pKFunc; + pNew->pData = pData; + pNew->pNext = pInterp->pCList; + + + if(pInterp->pCList) + { + pInterp->pCList->pPrevious = pNew; + } + pNew->pPrevious = NULL; + + /* update headpointer */ + pInterp->pCList = pNew; + return 1; + } +/*------------------------------------------------------------------------*/ + int RemoveCommand(SicsInterp *pInterp, char *pName) + { + CommandList *pVictim = NULL; + char pBueffel[256]; + + assert(pInterp); + assert(pName); + + strcpy(pBueffel,pName); + strtolower(pBueffel); + + if(pInterp->iDeleting) + { + return 0; + } + + /* find our victim */ + pVictim = FindCommand(pInterp, pBueffel); + if(!pVictim) + return 0; + + /* found, remove it */ + /* kall KillFunction first */ + if(pVictim->KFunc) + { + pVictim->KFunc(pVictim->pData); + } + + /* delete and unlink data */ + if(pVictim->pName) + { + free(pVictim->pName); + } + if(pVictim->pPrevious) + { + pVictim->pPrevious->pNext = pVictim->pNext; + } + if(pVictim->pNext) + { + pVictim->pNext->pPrevious = pVictim->pPrevious; + } + /* adjust headpointer if necessary */ + if(pVictim == pInterp->pCList) + { + pInterp->pCList = pVictim->pNext; + } + free(pVictim); + return 1; + } + +#define MAXLEN 256 +#define MAXCOM 50 +extern char *stptok(char *s, char *tok, unsigned int toklen, char *brk); +extern char *SkipSpace(char *pPtr); +/*------------------------------------------------------------------------*/ + int InterpExecute(SicsInterp *self,SConnection *pCon, char *pText) + { + int iCount = 0; + int iRet; + int i, argc; + char pBueffel[1024]; + CommandList *pCommand = NULL; + char pBrk[] = {" \r\n\0"}; + char *pPtr; + char **argv = NULL; + + + assert(self); + assert(pCon); + + /* write info to Log */ + if(pCon->pSock) + { + sprintf(pBueffel,"Executing -> %s <- from socket %d",pText, + pCon->pSock->sockid); + SICSLogWrite(pBueffel,eCommand); + } + else + { + printf("Executing -> %s <- from dummy socket\n", pText); + SICSLogWrite(pBueffel,eCommand); + } + + /* convert to argc, argv */ + argc = 0; + Text2Arg(pText,&argc,&argv); + + /* the first one must be the target object. If not given an empty + command string was given which will be silently ignored */ + if(argc < 1) + { + return 1; + } + if(argv[0] == NULL) + { + SCWrite(pCon,"ERROR: failed to parse command",eError); + return -1; + } + + /* find it */ + pCommand = FindCommand(self,argv[0]); + if(!pCommand) + { + sprintf(pBueffel,"ERROR: Object -> %s <- NOT found", + argv[0]); + SCWrite(pCon,pBueffel,eError); + return -1; + + } + + + /* invoke the command */ + self->eOut = eStatus; + Tcl_ResetResult((Tcl_Interp *)self->pTcl); + MacroPush(pCon); + iRet = pCommand->OFunc(pCon, self, pCommand->pData, argc, argv); + MacroPop(); + + /* delete argv */ + for(i = 0; i < argc; i++) + { + if(argv[i] != NULL) + { + free(argv[i]); + } + } + free(argv); + + return iRet; + } +/*------------------------------------------------------------------------*/ + CommandList *FindCommand(SicsInterp *self, char *pName) + { + CommandList *pCurrent = NULL; + char pBueffel[256], *pCmd; + + assert(self); + + if(self->iDeleting) + { + return NULL; + } + + strcpy(pBueffel,pName); + strtolower(pBueffel); + + pCmd=TranslateAlias(&self->AList, pBueffel); /* M.Z. */ + + pCurrent = self->pCList; + while(pCurrent) + { + if(pCurrent->pName != NULL) + { + if(strcmp(pCurrent->pName, pCmd) == 0 ) /* M.Z. */ + { + return pCurrent; + } + } + pCurrent = pCurrent->pNext; + } + return NULL; + } +/*------------------------------------------------------------------------*/ + int WriteSicsStatus(SicsInterp *self, char *file, int iMot) + { + CommandList *pCurrent = NULL; + FILE *fd = NULL; + Dummy *pDum = NULL; + float fVal; + pIDrivable pDriv = NULL; + void *pTest = NULL; + + assert(self); + assert(file); + + /* open file */ + fd = fopen(file,"w"); + if(!fd) + { + return 0; + } + /* remove it, as I found garbage from previous runs in the + status file + */ + fclose(fd); + remove(file); + + fd = fopen(file,"w"); + if(!fd) + { + return 0; + } + + /* cycle through the list */ + pCurrent = self->pCList; + while(pCurrent) + { + pDum = (Dummy *)pCurrent->pData; + if(pDum) + { + pDum->pDescriptor->SaveStatus(pCurrent->pData,pCurrent->pName,fd); + if(iMot) + { + /* + save values of motors but not of environment devices as they + may not be present the next time round + */ + pDriv = pDum->pDescriptor->GetInterface(pDum,DRIVEID); + pTest = pDum->pDescriptor->GetInterface(pDum,ENVIRINTERFACE); + if(pDriv && !pTest) + { + if(strcmp(pDum->pDescriptor->name,"Motor") == 0) + { + MotorGetSoftPosition((pMotor)pDum,pServ->dummyCon,&fVal); + } + else + { + fVal = pDriv->GetValue(pDum,pServ->dummyCon); + } + if(fVal > -990.) + { + fprintf(fd,"run %s %f\n",pCurrent->pName, fVal); + } + } + } + } + pCurrent = pCurrent->pNext; + } + if(iMot) + { + fprintf(fd,"Success \n"); + } + fclose(fd); + return 1; + } +/*------------------------------------------------------------------------*/ + void DeleteInterp(SicsInterp *self) + { + CommandList *pCurrent = NULL; + CommandList *pTemp; + Tcl_Interp *pTcl = NULL; + int i; + + assert(self); + self->iDeleting = 1; + + /* delete Commandlist */ + pCurrent = self->pCList; + while(pCurrent) + { + if(pCurrent->KFunc) + { + pCurrent->KFunc(pCurrent->pData); + } + if(pCurrent->pName) + { + /* printf("Deleting %s\n",pCurrent->pName); */ + free(pCurrent->pName); + } + pTemp = pCurrent->pNext; + free(pCurrent); + pCurrent = pTemp; + } + + FreeAliasList(&self->AList); /* M.Z. */ + + /* clear Tcl_Interpreter. Must be AFTER deleting command list because + some devices may have Tcl drivers which need to be accessed for + proper closing of devices. + */ + pTcl = (Tcl_Interp *)self->pTcl; + if(pTcl) + { + Tcl_DeleteInterp(pTcl); + } + + free(self); + } + +/*--------------------------------------------------------------------------*/ + int ListObjects(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + CommandList *pCurrent; + char pBueffel[256]; + int iNum = 0; + + assert(pSics); + assert(pCon); + + pCurrent = pSics->pCList; + while(pCurrent) + { + if(iNum == 0) + { + strcpy(pBueffel,pCurrent->pName); + iNum++; + } + else if(iNum < 4) + { + strcat(pBueffel," "); + strcat(pBueffel,pCurrent->pName); + iNum++; + } + else + { + strcat(pBueffel," "); + strcat(pBueffel,pCurrent->pName); + strcat(pBueffel,"\r\n"); + SCWrite(pCon,pBueffel,eStatus); + iNum = 0; + } + pCurrent = pCurrent->pNext; + } + + /* write final entries */ + if(strlen(pBueffel) > 2) + { + strcat(pBueffel,"\r\n"); + SCWrite(pCon,pBueffel,eStatus); + } + return 1; + } +/*---------------------------------------------------------------------------*/ + int InterpWrite(SicsInterp *pSics, char *buffer) + { + Tcl_Interp *pTcl = NULL; + + assert(pSics); + pTcl = (Tcl_Interp *)pSics->pTcl; + Tcl_SetResult(pTcl,buffer,TCL_VOLATILE); + return 1; + } +/*---------------------------------------------------------------------------*/ + Tcl_Interp *InterpGetTcl(SicsInterp *pSics) + { + Tcl_Interp *pTcl = NULL; + + pTcl = (Tcl_Interp *)pSics->pTcl; + return pTcl; + } +/*---------------------------------------------------------------------------*/ + void strtolower(char *pText) + { + assert(pText); + + while(*pText != '\0') + { + *pText = tolower(*pText); + pText++; + } + } +/*---------------------------------------------------------------------------*/ + void argtolower(int argc, char *argv[]) + { + int i; + + for(i = 0; i < argc; i++) + { + strtolower(argv[i]); + } + } + +/*------------------------------------------------------------------------*/ + char *FindAlias(SicsInterp *self, void *pData) + { + CommandList *pCurrent = NULL; + + assert(self); + + if(self->iDeleting) + { + return NULL; + } + + pCurrent = self->pCList; + while(pCurrent) + { + if(pCurrent->pData == pData) + { + return pCurrent->pName; + } + pCurrent = pCurrent->pNext; + } + return NULL; + } +/*---------------------------------------------------------------------------*/ + void *FindCommandData(SicsInterp *pSics, char *name, char *cclass) + { + CommandList *pCom; + pDummy pDum = NULL; + + pCom = FindCommand(pSics,name); + if(!pCom) + { + return NULL; + } + if(!pCom->pData) + return NULL; + + pDum = (pDummy)pCom->pData; + if(strcmp(pDum->pDescriptor->name,cclass) == 0) + { + return pCom->pData; + } + return NULL; + } +/*------------------------------------------------------------------------*/ +void *FindDrivable(SicsInterp *pSics, char *name){ + pIDrivable pDriv; + pDummy pDum = NULL; + CommandList *pCom = NULL; + + pCom = FindCommand(pSics,name); + if(pCom != NULL){ + pDum = (pDummy)pCom->pData; + if(pDum != NULL){ + return pDum->pDescriptor->GetInterface(pDum,DRIVEID); + } + } + + return NULL; +} diff --git a/SCinter.h b/SCinter.h new file mode 100644 index 00000000..34e96501 --- /dev/null +++ b/SCinter.h @@ -0,0 +1,151 @@ +/*-------------------------------------------------------------------------- + + The SICS needs an interpreter. This is it. + + Mark Koennecke, November 1996 + + copyright: see implementation file + +---------------------------------------------------------------------------*/ +#ifndef SICSINTERPRETER +#define SICSINTERPRETER +#include "Scommon.h" +#include +/* M.Z. */ +#include "definealias.i" + +typedef struct __SConnection *pSConnection; +typedef struct __SINTER *pSicsInterp; + + +typedef int (*ObjectFunc)(pSConnection pCon, pSicsInterp pInter, void + *pData, int argc, char *argv[]); + +typedef void (*KillFunc)(void *pData); + +typedef struct __Clist { + char *pName; + ObjectFunc OFunc; + KillFunc KFunc; + void *pData; + struct __Clist *pNext; + struct __Clist *pPrevious; + } CommandList; + +typedef struct __SINTER + { + CommandList *pCList; + OutCode eOut; + void *pTcl; + int iDeleting; + AliasList AList; /* M.Z. */ + }SicsInterp; + +/*-------------------------------------------------------------------------*/ + SicsInterp *InitInterp(void); + /* makes a new interpreter. Returns him on success, else NULL + */ +/*------------------------------------------------------------------------*/ + int AddCommand(SicsInterp *pInterp, char *pName, ObjectFunc pFunc, + KillFunc pKFunc, void *pData); + /* adds a new command, Returns True or False, depending on success + Parameters: + pInterp : the interpreter to add the command to. + pName : the commands name + pFunc : the object function to call when this command is + invoked. Definition of type: see above + pKFunc : function to call in order to delete command data. + type definition: above + pData : pointer to the command's own datastructure. Will be + passed as pData with each call to Ofunc. + */ +/*-------------------------------------------------------------------------*/ + int RemoveCommand(SicsInterp *pInterp, char *pName); + /* kills the command name from the interpreter pInterp + */ +/*-------------------------------------------------------------------------*/ + int InterpExecute(SicsInterp *self,pSConnection pCon,char *pCommand); + + /* + executes a command in the interpreter self. Essentially converts + pCommand in an argc, argv[] pair, sets various status things and + invokes the object function. Takes care of status and error reporting + afterwards. + + Parameters: + self : interpreter to invoke command in. + The connection pCon will be used for I/O and status reporting. + The command to invoke is the string pCommand. + Returns -1 if the command can not be found. + If the command is found, 1 is returned on success, 0 on failure in + the command. +----------------------------------------------------------------------------*/ + + CommandList *FindCommand(SicsInterp *pInterp, char *name); + /* + Searches the Interpreters pInterp command list for a command + with name. Returns ist datastructure if found, NULL else + */ +/*-------------------------------------------------------------------------*/ + int WriteSicsStatus(SicsInterp *pSics,char *file, int iMot); + /* + SICS needs a way to save the status of each object into a file. + This is done by invoking for each object the object descriptor + function SaveStatus. This function does just that. + + Parameters: + pSics : the interpreter to use. + file : the file to write the information to. + iMot : flag if motor position shall be saved or not + Returns: 1 on success, 0 on failure. +---------------------------------------------------------------------------*/ + int InterpWrite(SicsInterp *pSics, char *buffer); + /* + writes result to Tcl, used for Macro mechanism. + This is an internal function and should not be used. +----------------------------------------------------------------------------*/ + + void DeleteInterp(SicsInterp *self); + /* + deletes the interpreter self aand clears all asoociated datastructures. + self will no longer be valid after this. +--------------------------------------------------------------------------- */ + void strtolower(char *pText); + /* + strtolower converts a string to lowercase +--------------------------------------------------------------------------- */ + void argtolower(int argc, char *argv[]); + /* + converts an argc, argv[] pair to lowercase + */ + +/*-------------------------------------------------------------------------- + FindAlias tries to find an alias to the datastructure given as second + parameter. Returns the command name on success, else NULL. Be warned, this + is very special + */ + + char *FindAlias(SicsInterp *pSics, void *pData); + +/*------------------------------------------------------------------------- + FindCommandData finds a command with the name given. It tests the name in the + ObjectDescriptor to be of name class. If all this succeeds a pointer + to the commands data structure is retuned. Else NULL +*/ + void *FindCommandData(SicsInterp *pSics, char *name, char *comclass); + +/*------------------------------------------------------------------------ + FindDrivable tries to find Drivable object by the name given. Returns a + pointer to the drivable interface in the case of success, NULL in + case of failure. In order to save me fixing header files the pointer must + be cast to the drivable interface pointer. + ------------------------------------------------------------------------*/ + +void *FindDrivable(SicsInterp *pics, char *name); + +/*----------------------------------------------------------------------- + Get a copy of the Tcl interpreter + ------------------------------------------------------------------------*/ +Tcl_Interp *InterpGetTcl(SicsInterp *pSics); +#endif + diff --git a/SICSmain.c b/SICSmain.c new file mode 100644 index 00000000..754e61af --- /dev/null +++ b/SICSmain.c @@ -0,0 +1,87 @@ +/*-------------------------------------------------------------------------- + + THE SICS SERVER + + + This file contains the main entry point into the world of SICS. + + + + Mark Koennecke, October 1996 + + Copyright: see copyright.h + + Labor fuer Neutronenstreuung + Paul Scherrer Institut + CH-5423 Villigen-PSI + + +----------------------------------------------------------------------------*/ +#include +#include +#include +#include "nserver.h" + +/***************************** Necessary Globals ****************************/ + + IPair *pSICSOptions = NULL; + pServer pServ = NULL; + +/* ========================= Less dreadful file statics =================== */ + +#define DEFAULTINIFILE "servo.tcl" + +/*--------------------------------------------------------------------------- + The Servers Main program. May take one argument: the name of an + initialisation file +*/ + + int main(int argc, char *argv[]) + { + int iRet; + + /* initialise, will die on you if problems */ + if(argc >= 2) + { + iRet = InitServer(argv[1],&pServ); + } + else + { + iRet = InitServer(NULL,&pServ); + } + if(!iRet) + { + printf("Unrecoverable error on server startup, exiting........."); + exit(1); + } + + + RunServer(pServ); + + StopServer(pServ); + pServ = NULL; + exit(0); + } +/*--------------------------------------------------------------------------*/ + SicsInterp *GetInterpreter(void) + { + return pServ->pSics; + } +/*--------------------------------------------------------------------------*/ + pExeList GetExecutor(void) + { + return pServ->pExecutor; + } +/*------------------------------------------------------------------------*/ + void StopExit(void) + { + if(pServ) + { + StopServer(pServ); + } + } +/*-------------------------------------------------------------------------*/ + pTaskMan GetTasker(void) + { + return pServ->pTasker; + } diff --git a/Scommon.h b/Scommon.h new file mode 100644 index 00000000..c5b25368 --- /dev/null +++ b/Scommon.h @@ -0,0 +1,82 @@ +/*------------------------------------------------------------------------- + + Some common types and functions for SICS + + + Mark Koennecke, October 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. +----------------------------------------------------------------------------*/ +#ifndef SICSCOMMON +#define SICSCOMMON + +/* this enum defines the output types in SICS */ +typedef enum { + eInternal, + eCommand, + eHWError, + eInError, + eStatus, + eValue, + eWarning, + eError + } OutCode; + +#include "interrupt.h" + +/* define some user rights codes */ +#define usInternal 0 +#define usMugger 1 +#define usUser 2 +#define usSpy 3 + +/* status and error codes */ +#define OKOK 1 +#define HWIdle 2 +#define HWBusy 3 +#define HWFault 4 +#define HWPosFault 5 +#define HWCrash 6 +#define NOMEMORY 7 +#define HWNoBeam 8 +#define HWPause 9 +#define HWWarn 10 +#define HWRedo 11 + +/* + Sics uses some server options for some server configuration parameters. + These options are held in the global variable pSICSOptions. + */ +#include "ifile.h" +extern IPair *pSICSOptions; + +#endif + diff --git a/access.c b/access.c new file mode 100644 index 00000000..860c962a --- /dev/null +++ b/access.c @@ -0,0 +1,16 @@ +/* ------------------------------------------------------------------------ + The Accesscode names for SICS + + Mark Koennecke, November 1996 +----------------------------------------------------------------------------*/ +#ifndef PCODE +#define PCODE + + static char *aCode[] = { + "internal", + "mugger", + "user", + "spy", + NULL }; + static int iCodes = 4; +#endif diff --git a/alias.c b/alias.c new file mode 100644 index 00000000..62bf3840 --- /dev/null +++ b/alias.c @@ -0,0 +1,214 @@ +/*----------------------------------------------------------------------- + + A L I A S + Copyright: + + Labor fuer Neutronenstreuung + Paul Scherrer Institut + CH-5423 Villigen-PSI + + First Version: 1998, Mark Koennecke + updated: November 1999, Mark Koennecke + + + 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 "alias.h" + +/* + Usage: SicsAlias object newname +*/ + + int SicsAlias(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + CommandList *pCom = NULL; + char pBueffel[256]; + int iRet; + + if(!SCMatchRights(pCon,usMugger)) + { + SCWrite(pCon,"ERROR: aliasing only allowed to Managers", + eError); + return 0; + } + + if(argc < 3) + { + SCWrite(pCon,"ERROR: insufficient number of arguments to SicsAlias", + eError); + return 0; + } + + argtolower(argc,argv); + /* first parameter should be an registered SICS object */ + pCom = FindCommand(pSics,argv[1]); + if(!pCom) + { + sprintf(pBueffel,"ERROR: cannot find %s, no alias created",argv[1]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + /* alright: create the alias */ + iRet = AddCommand(pSics,argv[2],pCom->OFunc,NULL,pCom->pData); + if(!iRet) + { + sprintf(pBueffel,"ERROR: duplicate command %s not created",argv[2]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + return 1; + } +/*-------------------------------------------------------------------- + Make Alias: a command which installs a general alias into SICS. +*/ + + typedef struct { + pObjectDescriptor pDes; + char *pCommand; + }Alias, *pAlias; +/*----------------------------------------------------------------------*/ + static void FreeAlias(void *pData) + { + pAlias self = (pAlias)pData; + if(!self) + return; + + if(self->pDes) + DeleteDescriptor(self->pDes); + + if(self->pCommand) + free(self->pCommand); + + free(self); + } +/*---------------------------------------------------------------------- + In order to make alias most general alias tries to find the interfaces + defined by the object corresponding to the first word in the command. + Note: does not work, the object pointer with which a interface function + will be called refers to the alias and not the proper thing: core dump! + Therefore disabled! +*/ + static void *AliasInterface(void *pData, int iID) + { + CommandList *pCom = NULL; + pDummy pDum = NULL; + char *pPtr = NULL; + pAlias self = (pAlias)pData; + + assert(self); + pPtr = strtok(self->pCommand," \t\n"); + pCom = FindCommand(pServ->pSics,pPtr); + if(!pCom) + return NULL; + + pDum = (pDummy)pCom->pData; + if(!pDum) + return NULL; + + return pDum->pDescriptor->GetInterface(pDum,iID); + } +/*-----------------------------------------------------------------------*/ + static int AliasAction(SConnection *pCon, SicsInterp *pSics, + void *pData, int argc, char *argv[]) + { + pAlias self = NULL; + int status; + char pLine[512]; + char *pPtr; + Tcl_DString command; + + self = (pAlias)pData; + assert(self); + + /* + build command by appending the alias command and any possible + arguments given. + */ + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, self->pCommand,-1); + Tcl_DStringAppend(&command," ",-1); + Arg2Text(argc-1,&argv[1],pLine,511); + Tcl_DStringAppend(&command,pLine,-1); + + /* execute the command on the current connection */ + status = SCInvoke(pCon,pSics,Tcl_DStringValue(&command)); + + /* finish */ + Tcl_DStringFree(&command); + return status; + } +/*-----------------------------------------------------------------------*/ + int MakeAlias(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + char pBueffel[512]; + int iRet; + pAlias pNew = NULL; + + if(argc < 3) + { + SCWrite(pCon,"ERROR: insufficient number of arguments to alias", + eError); + return 0; + } + + Arg2Text(argc-2,&argv[2],pBueffel,511); + + /* create data structure */ + pNew = (pAlias)malloc(sizeof(Alias)); + if(!pNew) + { + SCWrite(pCon,"ERROR: out of memory while creating alias",eError); + return 0; + } + pNew->pDes = CreateDescriptor("Alias"); + pNew->pCommand = strdup(pBueffel); + if( !pNew->pDes || !pNew->pCommand) + { + SCWrite(pCon,"ERROR: out of memory while creating alias",eError); + return 0; + } + + iRet = AddCommand(pSics, + argv[1], + AliasAction, + FreeAlias, + pNew); + if(!iRet) + { + FreeAlias(pNew); + SCWrite(pCon,"ERROR: duplicate object name NOT created",eError); + return 0; + } + return 1; + } diff --git a/alias.h b/alias.h new file mode 100644 index 00000000..88b327e4 --- /dev/null +++ b/alias.h @@ -0,0 +1,20 @@ +/*------------------------------------------------------------------------ + A L I A S + + Implementation of the alias command. This is a configuration command + which allows additional names "aliases" for an existing object. + + Mark Koennecke, March 1997 + + copyright: see implementation file + +-------------------------------------------------------------------------*/ +#ifndef SICSALIAS +#define SICSALIAS + + int SicsAlias(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int MakeAlias(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); +#endif + diff --git a/amor.dic b/amor.dic new file mode 100644 index 00000000..2867117f --- /dev/null +++ b/amor.dic @@ -0,0 +1,245 @@ +##NXDICT-1.0 +#---------------------------------------------------------------------------- +# NeXus dictionary file for the SINQ instrument AMOR +# +# DO NOT EDIT WHEN YOU DO NOT KNOW WHAT YOU ARE DOING! +# This file determines the placement of data items in the AMOR NeXus +# data file. Your data may not be readable if this file is messed up. +# +# Mark Koennecke, September 1999 +#---------------------------------------------------------------------------- +# AMOR may have variable time binning. In order +# to cope with that, we use NXDICT's text replacement feature and define +# these things +timebin=512 +detxsize=255 +detysize=128 +scanlength = 10 +chunk = +#---------- NXentry level +etitle=/entry1,NXentry/SDS title -type DFNT_CHAR -rank 1 -dim {132} +estart=/entry1,NXentry/SDS start_time -type DFNT_CHAR -rank 1 -dim {132} +eend=/entry1,NXentry/SDS end_time -type DFNT_CHAR -rank 1 -dim {132} +#----------------- NXinstrument +iname=/entry1,NXentry/reflectometer,NXinstrument/SDS name -type DFNT_CHAR \ + -rank 1 -dim {132} +#----------------- NXsource +sname=/entry1,NXentry/reflectometer,NXinstrument/SINQ,NXsource/SDS name \ + -type DFNT_CHAR -rank 1 -dim {132} +stype=/entry1,NXentry/reflectometer,NXinstrument/SINQ,NXsource/SDS type \ + -type DFNT_CHAR -rank 1 -dim {132} +#----------------- Chopper +cname=/entry1,NXentry/reflectometer,NXinstrument/chopper,NXchopper/SDS name \ + -type DFNT_CHAR -rank 1 -dim {132} +crot=/entry1,NXentry/reflectometer,NXinstrument/chopper,NXchopper/SDS \ + rotation_speed -attr {units,rpm} +#---------------- frame overlap mirror +fomname=/entry1,NXentry/reflectometer,NXinstrument/frame_overlap_mirror,NXfilter/SDS name \ + -type DFNT_CHAR -rank 1 -dim {132} +fomh=/entry1,NXentry/reflectometer,NXinstrument/frame_overlap_mirror,NXfilter/SDS \ + omega_height -attr {units,mm} +fomom=/entry1,NXentry/reflectometer,NXinstrument/frame_overlap_mirror,NXfilter/SDS \ + omega -attr {units,degree} +fodist=/entry1,NXentry/reflectometer,NXinstrument/frame_overlap_mirror,NXfilter/SDS \ + distance -attr {units,mm} +#-------------- first slit +d1l=/entry1,NXentry/reflectometer,NXinstrument/diaphragm1,NXfilter/SDS left \ + -attr {units,mm} +d1r=/entry1,NXentry/reflectometer,NXinstrument/diaphragm1,NXfilter/SDS right \ + -attr {units,mm} +d1t=/entry1,NXentry/reflectometer,NXinstrument/diaphragm1,NXfilter/SDS top \ + -attr {units,mm} +d1b=/entry1,NXentry/reflectometer,NXinstrument/diaphragm1,NXfilter/SDS bottom \ + -attr {units,mm} +d1dist=/entry1,NXentry/reflectometer,NXinstrument/diaphragm1,NXfilter/SDS distance \ + -attr {units,mm} +#---------- polarizing mirror +polname=/entry1,NXentry/reflectometer,NXinstrument/polarizer,NXfilter/SDS name \ + -type DFNT_CHAR -rank 1 -dim {132} +polz=/entry1,NXentry/reflectometer,NXinstrument/polarizer,NXfilter/SDS height \ + -attr {units,mm} +polzom=/entry1,NXentry/reflectometer,NXinstrument/polarizer,NXfilter/SDS omega_height \ + -attr {units,mm} +polom=/entry1,NXentry/reflectometer,NXinstrument/polarizer,NXfilter/SDS omega \ + -attr {units,degree} +poly=/entry1,NXentry/reflectometer,NXinstrument/polarizer,NXfilter/SDS y_position \ + -attr {units,mm} +poldist=/entry1,NXentry/reflectometer,NXinstrument/polarizer,NXfilter/SDS distance \ + -attr {units,mm} +#-------------- second slit +d2l=/entry1,NXentry/reflectometer,NXinstrument/diaphragm2,NXfilter/SDS left \ + -attr {units,mm} +d2r=/entry1,NXentry/reflectometer,NXinstrument/diaphragm2,NXfilter/SDS right \ + -attr {units,mm} +d2t=/entry1,NXentry/reflectometer,NXinstrument/diaphragm2,NXfilter/SDS top \ + -attr {units,mm} +d2b=/entry1,NXentry/reflectometer,NXinstrument/diaphragm2,NXfilter/SDS bottom \ + -attr {units,mm} +d2dist=/entry1,NXentry/reflectometer,NXinstrument/diaphragm2,NXfilter/SDS distance \ + -attr {units,mm} +#-------------- third slit +d3l=/entry1,NXentry/reflectometer,NXinstrument/diaphragm3,NXfilter/SDS left \ + -attr {units,mm} +d3r=/entry1,NXentry/reflectometer,NXinstrument/diaphragm3,NXfilter/SDS right \ + -attr {units,mm} +d3t=/entry1,NXentry/reflectometer,NXinstrument/diaphragm3,NXfilter/SDS top \ + -attr {units,mm} +d3b=/entry1,NXentry/reflectometer,NXinstrument/diaphragm3,NXfilter/SDS bottom \ + -attr {units,mm} +d3dist=/entry1,NXentry/reflectometer,NXinstrument/diaphragm3,NXfilter/SDS distance \ + -attr {units,mm} +#---------------- sample table +saname=/entry1,NXentry/sample,NXsample/SDS name \ + -type DFNT_CHAR -rank 1 -dim {132} +baseheight=/entry1,NXentry/sample,NXsample/SDS base_height \ + -attr {units,mm} +somheight=/entry1,NXentry/sample,NXsample/SDS omega_height \ + -attr {units,mm} +schi=/entry1,NXentry/sample,NXsample/SDS chi \ + -attr {units,degree} +somega=/entry1,NXentry/sample,NXsample/SDS omega \ + -attr {units,degree} +stheight=/entry1,NXentry/sample,NXsample/SDS table_height \ + -attr {units,mm} +stdist=/entry1,NXentry/sample,NXsample/SDS distance \ + -attr {units,mm} +#------------ fourth slit +d4l=/entry1,NXentry/reflectometer,NXinstrument/diaphragm4,NXfilter/SDS left \ + -attr {units,mm} +d4r=/entry1,NXentry/reflectometer,NXinstrument/diaphragm4,NXfilter/SDS right \ + -attr {units,mm} +d4t=/entry1,NXentry/reflectometer,NXinstrument/diaphragm4,NXfilter/SDS top \ + -attr {units,mm} +d4b=/entry1,NXentry/reflectometer,NXinstrument/diaphragm4,NXfilter/SDS bottom \ + -attr {units,mm} +d4dist=/entry1,NXentry/reflectometer,NXinstrument/diaphragm4,NXfilter/SDS \ + distance_to_sample -attr {units,mm} +d4base =/entry1,NXentry/reflectometer,NXinstrument/diaphragm4,NXfilter/SDS \ + base_height -attr {units,mm} +#------------ analyzer +anname=/entry1,NXentry/reflectometer,NXinstrument/polarizer,NXfilter/SDS name \ + -type DFNT_CHAR -rank 1 -dim {132} +anoz=/entry1,NXentry/reflectometer,NXinstrument/analyzer,NXfilter/SDS omega_height \ + -attr {units,mm} +abase=/entry1,NXentry/reflectometer,NXinstrument/analyzer,NXfilter/SDS base_height \ + -attr {units,mm} +adis=/entry1,NXentry/reflectometer,NXinstrument/analyzer,NXfilter/SDS \ + distance_to_sample -attr {units,mm} +anom=/entry1,NXentry/reflectometer,NXinstrument/analyzer,NXfilter/SDS omega \ + -attr {units,degree} +antz=/entry1,NXentry/reflectometer,NXinstrument/analyzer,NXfilter/SDS height \ + -attr {units,mm} +andist=/entry1,NXentry/reflectometer,NXinstrument/analyzer,NXfilter/SDS distance \ + -attr {units,mm} +#--------------- fifth slit!! +d5l=/entry1,NXentry/reflectometer,NXinstrument/diaphragm5,NXfilter/SDS left \ + -attr {units,mm} +d5r=/entry1,NXentry/reflectometer,NXinstrument/diaphragm5,NXfilter/SDS right \ + -attr {units,mm} +d5t=/entry1,NXentry/reflectometer,NXinstrument/diaphragm5,NXfilter/SDS top \ + -attr {units,mm} +d5b=/entry1,NXentry/reflectometer,NXinstrument/diaphragm5,NXfilter/SDS bottom \ + -attr {units,mm} +d5dist=/entry1,NXentry/reflectometer,NXinstrument/diaphragm5,NXfilter/SDS \ + distance_to_sample -attr {units,mm} +d5base =/entry1,NXentry/reflectometer,NXinstrument/diaphragm5,NXfilter/SDS \ + base_height -attr {units,mm} +#---------- count control +cnmode=/entry1,NXentry/reflectometer,NXinstrument/counter,NXmonitor/SDS count_mode \ + -type DFNT_CHAR -rank 1 -dim {30} +cnpreset=/entry1,NXentry/reflectometer,NXinstrument/counter,NXmonitor/SDS preset \ + -attr {units,countsOrseconds} +cntime=/entry1,NXentry/reflectometer,NXinstrument/counter,NXmonitor/SDS time \ + -attr {units,seconds} +cnmon1=/entry1,NXentry/reflectometer,NXinstrument/counter,NXmonitor/SDS monitor1 \ + -type DFNT_INT32 -attr {units,counts} +cnmon2=/entry1,NXentry/reflectometer,NXinstrument/counter,NXmonitor/SDS monitor2 \ + -type DFNT_INT32 -attr {units,counts} +#-------------- detector-TOF mode +dettype=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS type \ + -type DFNT_CHAR -rank 1 -dim {132} +dety=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS y_detector \ + -type DFNT_FLOAT32 -rank 1 -dim {$(detysize)} -attr {axis,1} \ + -attr {units,mm} +detxx=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS x_detector \ + -type DFNT_FLOAT32 -rank 1 -dim {$(detxsize)} -attr {axis,2} \ + -attr {units,mm} +detz=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS z \ + -type DFNT_FLOAT32 -rank 1 -dim {$(detxsize)} -attr {axis,2} \ + -attr {units,mm} +detx=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS x \ + -type DFNT_FLOAT32 -attr {units,mm} +detom=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS omega \ + -type DFNT_FLOAT32 -attr {units,degree} +detheight=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS height \ + -type DFNT_FLOAT32 -attr {units,mm} +detdist=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS \ + distance_to_sample -type DFNT_FLOAT32 -attr {units,mm} +detbase=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS \ + base_height -type DFNT_FLOAT32 -attr {units,mm} +dettime=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS time_binning \ + -type DFNT_FLOAT32 -rank 1 -dim {$(timebin)} -attr {axis,3} \ + -attr {units,ms} +spinup=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS spinup \ + -type DFNT_INT32 -rank 3 -dim {$(detxsize),$(detysize),$(timebin)} \ + -LZW $(chunk) -attr {signal,1} +#spinup=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS spinup \ +# -type DFNT_INT32 -rank 3 -dim {$(detxsize),$(detysize),$(timebin)} \ +# $(chunk) -attr {signal,1} +detchunk=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS \ + chunksize -type DFNT_INT32 -rank 1 -dim {3} +spinup2d=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS spinup \ + -type DFNT_INT32 -rank 2 -dim {$(detxsize),$(detysize)} \ + -LZW $(chunk) -attr {signal,1} +spindown=/entry1,NXentry/reflectometer,NXinstrument/TOF,NXdetector/SDS spindown \ + -type DFNT_INT32 -rank 3 -dim {$(detxsize),$(detysize),$(timebin)} \ + -LZW -attr {signal,1} +#------------ single detectors TOF ------------------------------------- +singleup=/entry1,NXentry/reflectometer,NXinstrument/single,NXdetector/SDS \ + spinup -type DFNT_INT32 -rank 2 -dim {2, $(timebin)} -LZW \ + -attr {signal,1} +singledown=/entry1,NXentry/reflectometer,NXinstrument/single,NXdetector/SDS \ + spinup -type DFNT_INT32 -rank 2 -dim {2, $(timebin)} -LZW \ + -attr {signal,1} +singletime=/entry1,NXentry/reflectometer,NXinstrument/single,NXdetector/SDS \ + time_binning -type DFNT_FLOAT32 -rank 1 -dim {$(timebin)} \ + -attr {axis,2} +singletofmon=/entry1,NXentry/reflectometer,NXinstrument/single,NXdetector/SDS \ + tof_monitor -type DFNT_INT32 -rank 1 -dim {$(timebin)} +#------------ detector: scan mode +scanroot=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS +sdetx=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS x \ + -type DFNT_FLOAT32 -attr {units,mm} +sdetom=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS omega \ + -type DFNT_FLOAT32 -attr {units,degree} +sdetheight=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS height \ + -type DFNT_FLOAT32 -attr {units,mm} +spinupup=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS spinup_upper \ + -type DFNT_INT32 -rank 1 -dim {$(scanlength)} -attr {signal,1} +spindownup=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS \ + spindown_upper \ + -type DFNT_INT32 -rank 1 -dim {$(scanlength)} -attr {signal,2} +spinuplo=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS spinup_lower \ + -type DFNT_INT32 -rank 1 -dim {$(scanlength)} -attr {signal,3} +spindownlo=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS \ + spindown_lower \ + -type DFNT_INT32 -rank 1 -dim {$(scanlength)} -attr {signal,4} +somega=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS \ + omega -attr {units,degree} \ + -type DFNT_FLOAT32 -rank 1 -dim {$(scanlength)} -attr {axis,1} +smonitor1=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS \ + monitor1 \ + -type DFNT_INT32 -rank 1 -dim {$(scanlength)} +smonitor2=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS \ + monitor2 \ + -type DFNT_INT32 -rank 1 -dim {$(scanlength)} +stime=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS \ + time \ + -type DFNT_FLOAT32 -rank 1 -dim {$(scanlength)} -attr {units,s} +sdetdist=/entry1,NXentry/reflectometer,NXinstrument/scan,NXdetector/SDS distance \ + -type DFNT_FLOAT32 -attr {units,mm} +#------------------- data vGroup +dana=/entry1,NXentry/TOF,NXdata/NXVGROUP +singledana=/entry1,NXentry/single,NXdata/NXVGROUP +sdana=/entry1,NXentry/scan,NXdata/NXVGROUP + diff --git a/amor2t.c b/amor2t.c new file mode 100644 index 00000000..96bf3b7f --- /dev/null +++ b/amor2t.c @@ -0,0 +1,996 @@ +/*--------------------------------------------------------------------------- + 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 new file mode 100644 index 00000000..6e243cb0 --- /dev/null +++ b/amor2t.h @@ -0,0 +1,22 @@ + +/*------------------------------------------------------------------------- + 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 new file mode 100644 index 00000000..2bcf2ae0 --- /dev/null +++ b/amor2t.i @@ -0,0 +1,55 @@ + +/*-------------------------------------------------------------------------- + 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 new file mode 100644 index 00000000..c458706b --- /dev/null +++ b/amor2t.tex @@ -0,0 +1,204 @@ +\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 new file mode 100644 index 00000000..9c28a7f5 --- /dev/null +++ b/amor2t.w @@ -0,0 +1,150 @@ +\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/amorpar.tcl b/amorpar.tcl new file mode 100644 index 00000000..bdd5af1e --- /dev/null +++ b/amorpar.tcl @@ -0,0 +1,23 @@ +#-------------------------------------------------------------------------- +# A SICS-tcl-macro script for formatting the parameters for the +# reflectometer AMOR's status display. +# +# Mark Koennecke, October 1999 +#------------------------------------------------------------------------- +proc amorpar {} { + lappend list "amorpar == " + lappend list [lastscancommand] ";" + catch {scan getvars} msg + lappend list $msg ";" + lappend list [xxxscan getfile] ";" + lappend list [sicstime] ";" + set ret [catch {temperature} msg] + if {$ret == 0} { + lappend list $msg + } + set ret [catch {magnet} msg] + if {$ret == 0} { + lappend list $msg + } + return [join $list] +} \ No newline at end of file diff --git a/amorscan.c b/amorscan.c new file mode 100644 index 00000000..7f556e46 --- /dev/null +++ b/amorscan.c @@ -0,0 +1,140 @@ +/*------------------------------------------------------------------------- + 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 new file mode 100644 index 00000000..d97195f4 --- /dev/null +++ b/amorscan.h @@ -0,0 +1,15 @@ + +/*----------------------------------------------------------------------- + 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.tex b/amorscan.tex new file mode 100644 index 00000000..6e25f20f --- /dev/null +++ b/amorscan.tex @@ -0,0 +1,71 @@ +\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: +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap1} +$\langle$amorscan {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ int ConfigureAmor(pScanData pScan);@\\ +\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} +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.*. + + +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap2} +\verb@"amorscan.h"@ {\footnotesize ? }$\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@/*-----------------------------------------------------------------------@\\ +\mbox{}\verb@ A M O R S C A N@\\ +\mbox{}\verb@ Adaption of the scan command to do things specific to the@\\ +\mbox{}\verb@ reflectometer AMOR at SINQ.@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ Mark Koennecke, September 1999@\\ +\mbox{}\verb@-----------------------------------------------------------------------*/@\\ +\mbox{}\verb@#ifndef AMORSCAN@\\ +\mbox{}\verb@#define AMORSCAN@\\ +\mbox{}\verb@@$\langle$amorscan {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@#endif@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@@$\diamond$ +\end{list} +\vspace{-2ex} +\end{minipage}\\[4ex] +\end{flushleft} diff --git a/amorscan.w b/amorscan.w new file mode 100644 index 00000000..b52be00d --- /dev/null +++ b/amorscan.w @@ -0,0 +1,57 @@ +\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 new file mode 100644 index 00000000..fb422b91 --- /dev/null +++ b/amorstat.c @@ -0,0 +1,919 @@ +/*-------------------------------------------------------------------------- + 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 new file mode 100644 index 00000000..6665cec2 --- /dev/null +++ b/amorstat.h @@ -0,0 +1,21 @@ + +/*------------------------------------------------------------------------ + 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 new file mode 100644 index 00000000..5a24a644 --- /dev/null +++ b/amorstat.i @@ -0,0 +1,29 @@ + +/*------------------------------------------------------------------------ + 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 new file mode 100644 index 00000000..8d295337 --- /dev/null +++ b/amorstat.tex @@ -0,0 +1,138 @@ +\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 new file mode 100644 index 00000000..a8653d7b --- /dev/null +++ b/amorstat.w @@ -0,0 +1,102 @@ +\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/amortest.tcl b/amortest.tcl new file mode 100644 index 00000000..b09fc1d2 --- /dev/null +++ b/amortest.tcl @@ -0,0 +1,358 @@ +# -------------------------------------------------------------------------- +# Initialization script for a simulated AMOR instrument +# +# +# Dr. Mark Koennecke September,1999 - ??, ???? +#--------------------------------------------------------------------------- + +#------------ our home +set home /data/koenneck/src/sics + +#----------- first all the server options are set + +ServerOption ReadTimeOut 100 +# timeout when checking for commands. In the main loop SICS checks for +# pending commands on each connection with the above timeout, has +# PERFORMANCE impact! + +ServerOption AcceptTimeOut 100 +# timeout when checking for connection req. +# Similar to above, but for connections + +ServerOption ReadUserPasswdTimeout 7000 +# time to wiat for a user/passwd to be sent from a client. Increase this +# if there is a problem connecting to a server due to network overload\ + +ServerOption LogFileDir $home/tmp +#LogFileDir is the directory where the command log is going + +ServerOption LogFileBaseName $home/tmp/server +# the path and base name of the internal server logfile to which all +# activity will be logged. + +ServerOption statusfile $home/tmp/sicsstatus.tcl + +ServerOption ServerPort 2911 +# the port number the server is going to listen at. The client MUST know +# this number in order to connect. It is in client.ini + +ServerOption InterruptPort 2914 +# The UDP port where the server will wait for Interrupts from clients. +# Obviously, clients wishing to interrupt need to know this number. + +# Telnet options +ServerOption TelnetPort 1301 +ServerOption TelWord sicslogin + +ServerOption DefaultTclDirectory $home/tcl +ServerOption DefaultCommandFile topsicom.tcl + +#------ a port for broadcasting UDP messages +ServerOption QuieckPort 2108 + +#--------------------------------------------------------------------------- +# U S E R S + +# than the SICS users are specified +# Syntax: SicsUser name password userRightsCode +SicsUser Mugger Diethelm 1 +SicsUser User Rosy 2 +SicsUser Spy 007 1 + +#-------------------------------------------------------------------------- +# G E N E R A L V A R I A B L E S +# now a few general variables are created +# Syntax: VarMake name type access +# type can be one of: Text, Int, Float +#access can be one of: Internal, Mugger, user, Spy + +VarMake Instrument Text Internal +Instrument AMOR +Instrument lock + + + +VarMake Title Text User +VarMake sample Text User +sample "DanielSulfid" +Title "Amore mio in SINQ" +VarMake User Text User +User The reflective looser + +VarMake lastscancommand Text User + +VarMake Adress Text User +VarMake phone Text User +VarMake fax Text User +VarMake email Text User +VarMake sample_mur Float User + +#-------------------------------------------------------------------------- +# B u i l d i n g B l o c k s +#-------------------------------------------------------------------------- +# +#=================== Chopper +VarMake chopperrotation Float User +chopperrotation 10000. + +ClientPut "Starting motor initialization ....." +#=================== frame overlap mirror +VarMake fomname Text Mugger +fomname Super Duper Mirror +fomname lock +VarMake fomdist Float Mugger +fomdist 120 +Motor FTZ SIM 0. 120. .1 2. # fom height +Motor FOM SIM -30. 30. .1 2. # fom omega + +#================== first diaphragm +VarMake d1dist Float Mugger +d1dist 200. +Motor D1L SIM 0. 120. .1 2. # left +Motor D1R SIM 0. 120. .1 2. # right +Motor D1T SIM 0. 120. .1 2. # top +Motor D1B SIM 0. 1000. .1 2. # bottom + +#================== polarizer +VarMake polname Text Mugger +polname Daniels Special Edition Polarizer +polname lock +VarMake poldist Float Mugger +fomdist 200 +Motor MOZ SIM 0. 1000. .1 2. # pol table height +Motor MTY SIM -60. 60. .1 2. # pol y movement +Motor MOM SIM -30. 30. .1 2. # pol omega +Motor MTZ SIM -30. 30. .1 2. # pol omega height + +#=================== diaphragm 2 +VarMake d2dist Float Mugger +d2dist 200. +Motor D2L SIM 0. 120. .1 2. # left +Motor D2R SIM 0. 120. .1 2. # right +Motor D2T SIM 0. 120. .1 2. # top +Motor D2B SIM 0. 1000. .1 2. # bottom + +#==================== diaphragm 3 +VarMake d3dist Float Mugger +d3dist 200. +Motor D3L SIM 0. 120. .1 2. # left +Motor D3R SIM 0. 120. .1 2. # right +Motor D3T SIM 0. 120. .1 2. # top +Motor D3B SIM 0. 1000. .1 2. # bottom + +#===================== sample table +VarMake sampledist Float Mugger +sampledist 200 +Motor STZ SIM -50. 50. .1 2. # sample height +Motor SOM SIM -30. 30. .1 2. # sample omega +Motor SCH SIM -30. 30. .1 2. # sample chi +Motor SOZ SIM 0. 1000. .1 2. # table height + +#====================== diaphragm 4 +VarMake d4dist Float Mugger +d4dist 200. +Motor D4L SIM 0. 120. .1 2. # left +Motor D4R SIM 0. 120. .1 2. # right +Motor D4T SIM 0. 120. .1 2. # top +Motor D4B SIM 0. 1000. .1 2. # bottom + +#======================= analyzer +VarMake ananame Text Mugger +ananame Daniels Special Edition Analyzer +ananame lock +VarMake anadist Float Mugger +anadist 200 +Motor AOZ SIM 0. 1000. .1 2. # analyzer table height +Motor AOM SIM -30. 30. .1 2. # analyzer omega +Motor ATZ SIM -30. 30. .1 2. # analyzer omega height + +#======================== diaphragm 5 +VarMake d5dist Float Mugger +d5dist 200. +Motor D5L SIM 0. 120. .1 2. # left +Motor D5R SIM 0. 120. .1 2. # right +Motor D5T SIM 0. 120. .1 2. # top +Motor D5B SIM 0. 1000. .1 2. # bottom + +#======================== counter +VarMake detectordist Float Mugger +detectordist 200. +MakeCounter counter SIM .0001 +Motor COZ SIM 0. 1000. .1 2. # counter table height +Motor C3Z SIM 0. 300. .1 2. # counter height +Motor COM SIM -30. 30. .1 2. # counter omega +Motor COX SIM -100. 100. .1 2. # counter x +ClientPut "Motors initialized" + +#======================== histogram memory +#MakeHM hm SinqHM +MakeHM hm SIM +hm configure OverFlowMode Ceil +hm configure HistMode PSD +hm configure Rank 2 +hm configure dim0 128 +hm configure dim1 256 +hm configure xfac 10 +hm configure yfac 10 +hm configure xoff 64 +hm configure yoff 128 +hm configure BinWidth 4 +hm preset 100. +hm CountMode Timer +hm configure HMComputer psds03.psi.ch +hm configure HMPort 2400 +hm configure Counter counter +hm configure init 0 +hm genbin 0. 33 5 +hm init + +ClientPut "Histogram Memory Initialized" +#-------------------------------------------------------------------------- +# D a t a S t o r a g e +#------------------------------------------------------------------------ +VarMake SicsDataPath Text Mugger +SicsDataPath $home/ +SicsDataPath lock +VarMake SicsDataPrefix Text Mugger +SicsDataPrefix amortest +SicsDataPrefix lock +VarMake SicsDataPostFix Text Mugger +SicsDataPostFix ".hdf" +SicsDataPostFix lock + +MakeDataNumber SicsDataNumber $home/danu.dat + + +#-------------------------------------------------------------------------- +# C o m m a n d I n i t i a l i z a t i o n +#------------------------------------------------------------------------- +#======== Drive +MakeDrive +#======== scan +source $home/object.tcl +source $home/tcl/scancom.tcl +MakeScanCommand xxxscan counter topsi.hdd recover.bin +xxxscan configure amor +#========== peak & center +MakePeakCenter xxxscan +source /data/koenneck/src/sics/countf.tcl +#========== serial port general purpose +SerialInit +Publish serialport User +Publish p1 User +#=========== the optimiser +MakeOptimise opti counter + +#=========== Amor2T +set a2t(mom) mom +set a2t(som) som +set a2t(coz) coz +set a2t(cox) cox +set a2t(stz) stz +set a2t(soz) soz +set a2t(d4b) d4b +set a2t(d5b) d5b +set a2t(com) com +set a2t(aom) aom +set a2t(aoz) aoz +set a2t(c3z) c3z +MakeAmor2T a2t a2t aom2t + +MakeStoreAmor hm a2t + +#=========== Status Display Support +MakeAmorStatus amorstatus xxxscan hm +source amorpar.tcl +Publish amorpar Spy +ClientPut "Done Initializing" + + +scriptcallback connect xxxscan SCANSTART scanmode +scriptcallback connect hm COUNTSTART tofmode +sicsdatafactory new wwwdata + +Publish getmode Spy +Publish wwwgetdata Spy +Publish wwwsics Spy +Publish wwwgetaxis Spy + +#----------------------------------------------------------------- +set mode 0 +proc tofmode {} { + global mode + set mode 1 +} +#--------------------------------------------------------------------- +proc scanmode {} { + global mode + set mode 0 +} +#------------------------------------------------------------------ +proc getmode {} { + global mode + return $mode +} +#-------------------------------------------------------------------- +proc wwwgetdata {} { + global mode + if {$mode == 1} { + wwwtofdata + } else { + wwwscandata + } + wwwdata writeuu wwwdata +} +#--------------------------------------------------------------------- +proc wwwscandata {} { + wwwdata clear + set np [string trim [SplitReply [xxxscan np]]] + wwwdata putint 0 $np + if {$np > 0} { + wwwdata copyscanvar 1 xxxscan 0 + wwwdata copyscancounts [expr $np + 1] xxxscan + wwwdata copyscanmon [expr $np*2 + 1] xxxscan 2 + } +} +#---------------------------------------------------------------------- +proc wwwtofdata {} { + wwwdata clear + set ntime [string trim [SplitReply [hm notimebin]]] + set dim0 [string trim [SplitReply [hm configure dim0]]] + set dim1 [string trim [SplitReply [hm configure dim1]]] + wwwdata putint 0 $ntime + wwwdata copytimebin 1 hm + set start [expr $dim0*$dim1*$ntime] + set end [expr $start + 2*$ntime] + wwwdata copyhm [expr $ntime + 1] hm $start $end +} +#--------------------------------------------------------------------------- +proc wwwsics {} { + global mode + append result "\n" + append result "\n" + append result "\n" + append result "\n" + append result "\n" + append result "
User " [SplitReply [user]] "
Title " + append result [SplitReply [title]] "
Status " + append result [SplitReply [status]] "
Mode" + if {$mode == 1} { + append result "time-of-flight" + } else { + append result "scan mode" + } + append result "
\n" +} +#------------------------------------------------------------------------- +proc wwwgetaxis {} { + global mode + if {$mode == 1} { + return time-of-flight + } else { + set res [scan info] + set l [split $res ,] + return [lindex $l 2] + } +} + + diff --git a/anticollider.c b/anticollider.c new file mode 100644 index 00000000..3ccc82a8 --- /dev/null +++ b/anticollider.c @@ -0,0 +1,374 @@ +/*---------------------------------------------------------------------- + This is the implementation file for the AntiCollider, a complex movements + control module for SICS. See anticollider.tex for more information. + + copyright: see file copyright + + Mark Koennecke, August 2002 +------------------------------------------------------------------------*/ +#include +#include +#include +#include "fortify.h" +#include "lld.h" +#include "motreglist.h" +#include "anticollider.i" +#include "anticollider.h" + +/*--------------------------------------------------------------------- + As there should be only one AntiCollider in a system, I use a static + pointer to the AntiCollider here in order to facilitate access. + Otherwise more complex mechanisms must be devised in order to pass this + pointer into ColliderSetValue and ColliderCheckStatus + ----------------------------------------------------------------------*/ +static pAntiCollider myCollider = NULL; + +/*-------------------------------------------------------------------- + the replacement function for the motor's drivable interface SetValue + function. It enters the new target into the motor list. + ---------------------------------------------------------------------*/ +static long ReplacementSetValue(void *pData, SConnection *pCon, float fTarget){ + pMotReg pMot = NULL; + + assert(myCollider != NULL); + + pMot = FindMotFromDataStructure(myCollider->motorList,pData); + if(pMot != NULL){ + SetRegMotTarget(pMot,fTarget); + myCollider->isDirty = 1; + } else { + return 0; + } + + return 1; +} +/*--------------------------------------------------------------------- + The replacement CheckStatus function for controlled motors. + Start AntiCollider if not running and finish. Rest of work done by + AntiCollider. + -----------------------------------------------------------------------*/ +static int ReplacementCheckStatus(void *pData, SConnection *pCon){ + pMotReg pMot = NULL; + + assert(myCollider != NULL); + + if(myCollider->isDirty == 1){ + myCollider->isDirty = 0; + StartDevice(pServ->pExecutor, + "anticollider", + myCollider->pDes, + myCollider, + pCon, + 77.77); + return HWIdle; + } else { + return HWIdle; + } +} +/*------------------------------------------------------------------------ + The collider SetValue function + -------------------------------------------------------------------------*/ +static long ColliderSetValue(void *pData, SConnection *pCon, float fTarget){ + pAntiCollider self = (pAntiCollider) pData; + int iRet; + pMotReg pMot = NULL; + char pBueffel[80]; + char *ruenBuffer = NULL; + + Tcl_DString command; + + /* + build command list + */ + if(self->colliderScript == NULL){ + SCWrite(pCon,"ERROR: no collider script defined",eError); + return 0; + } + + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command,self->colliderScript,-1); + iRet = LLDnodePtr2First(self->motorList); + while(iRet != 0){ + LLDnodeDataTo(self->motorList,&pMot); + if(pMot != NULL){ + if(pMot->iActive){ + CreateTargetString(pMot,pBueffel); + Tcl_DStringAppend(&command, pBueffel,-1); + pMot->iActive = 0; + } + } + iRet = LLDnodePtr2Next(self->motorList); + } + + /* + kill old collider sequence + */ + LLDdelete(self->sequenceList); + self->sequenceList = LLDcreate(sizeof(Sequence)); + self->level = -1; /* otherwise level 0 will not be started */ + + /* + evaluate colliderScript + */ + iRet = Tcl_Eval(pServ->pSics->pTcl,Tcl_DStringValue(&command)); + if(iRet != TCL_OK){ + SCWrite(pCon,"ERROR: Movement not possible or bad collider script",eError); + /* + SCWrite(pCon,pServ->pSics->pTcl->result,eError); + */ + SCSetInterrupt(pCon,eAbortOperation); + return 0; + } + + /* + we are set + */ + Tcl_DStringFree(&command); + return 1; +} +/*---------------------------------------------------------------------- + The Collider CheckStatus function + -----------------------------------------------------------------------*/ +static int ColliderCheckStatus(void *pData, SConnection *pCon){ + int count = 0; + pAntiCollider self = (pAntiCollider) pData; + + assert(self); + + if(SCGetInterrupt(pCon) != eContinue){ + return HWIdle; + } + + count = CheckAllMotors(self->motorList,pCon); + if(count == 0){ + self->level++; + count = StartLevel(self->level, + self->sequenceList, + self->motorList, + pCon); + if(count == 0){ + /* + no more levels. All done + */ + return HWIdle; + } else { + return HWBusy; + } + } else { + return HWBusy; + } +} +/*---------------------------------------------------------------------- + Most of these are dummies........ + -----------------------------------------------------------------------*/ +static int ColliderHalt(void *pData){ + StopExe(pServ->pExecutor,"all"); + return 1; +} +/*---------------------------------------------------------------------*/ +static int ColliderLimits(void *self, float fVal, char *error, + int iErren){ + return 1; +} +/*--------------------------------------------------------------------*/ +static float ColliderGetValue(void *self, SConnection *pCon){ + return 77.77; +} +/*--------------------------------------------------------------------*/ +int StartLevel(int level, int sequenceList, int motorList, SConnection *pCon){ + Sequence seq; + pMotReg pMot = NULL; + int iRet; + int count = 0; + char pBueffel[132]; + + iRet = LLDnodePtr2First(sequenceList); + while(iRet != 0){ + LLDnodeDataTo(sequenceList,&seq); + if(seq.level == level){ + pMot = FindMotEntry(motorList,seq.pMotor); + if(pMot){ + StartRegMot(pMot,pCon,seq.target); + count++; + } else { + sprintf(pBueffel,"ERROR: motor %s, requested from anticollider script", + seq.pMotor); + SCWrite(pCon,pBueffel,eError); + SCWrite(pCon,"ERROR: motor NOT found, fix script!",eError); + } + } + iRet = LLDnodePtr2Next(sequenceList); + } + return count; +} +/*--------------------------------------------------------------------*/ +static void ListSequence(int sequenceList, SConnection *pCon){ + Sequence seq; + int iRet; + char pBueffel[132]; + + SCWrite(pCon,"level motor target",eValue); + iRet = LLDnodePtr2First(sequenceList); + while(iRet != 0){ + LLDnodeDataTo(sequenceList,&seq); + sprintf(pBueffel,"%d %s %f",seq.level,seq.pMotor,seq.target); + SCWrite(pCon,pBueffel,eValue); + iRet = LLDnodePtr2Next(sequenceList); + } +} +/*-------------------------------------------------------------------------*/ +static void *ColliderGetInterface(void *pData, int iID) { + pAntiCollider self = NULL; + + self = (pAntiCollider)pData; + assert(self); + + if(iID == DRIVEID){ + return self->pDriv; + } + return NULL; +} +/*----------------------------------------------------------------------*/ +void KillCollider(void *pData){ + pAntiCollider self = (pAntiCollider)pData; + + if(self == NULL){ + return; + } + + if(self->pDes != NULL){ + DeleteDescriptor(self->pDes); + } + if(self->pDriv != NULL){ + free(self->pDriv); + } + if(self->colliderScript != NULL){ + free(self->colliderScript); + } + if(self->motorList > 0){ + KillMotList(self->motorList); + } + if(self->sequenceList > 0){ + LLDdelete(self->sequenceList); + } + free(self); + myCollider = NULL; +} +/*-----------------------------------------------------------------------*/ +int AntiColliderFactory(SConnection *pCon, SicsInterp *pSics, + void *pData, + int argc, char *argv[]){ + + myCollider = (pAntiCollider)malloc(sizeof(AntiCollider)); + if(myCollider == NULL){ + SCWrite(pCon,"ERROR: out of memory when generating AntiCollider",eError); + return 0; + } + memset(myCollider,0,sizeof(AntiCollider)); + + myCollider->pDes = CreateDescriptor("AntiCollider"); + myCollider->pDriv = CreateDrivableInterface(); + if(!myCollider->pDes || !myCollider->pDriv){ + KillCollider(myCollider); + SCWrite(pCon,"ERROR: out of memory when generating AntiCollider",eError); + return 0; + } + + myCollider->pDes->GetInterface = ColliderGetInterface; + myCollider->pDriv->Halt = ColliderHalt; + myCollider->pDriv->CheckLimits = ColliderLimits; + myCollider->pDriv->SetValue = ColliderSetValue; + myCollider->pDriv->CheckStatus = ColliderCheckStatus; + myCollider->pDriv->GetValue = ColliderGetValue; + + myCollider->motorList = LLDcreate(sizeof(void *)); + myCollider->sequenceList = LLDcreate(sizeof(Sequence)); + + AddCommand(pSics,"anticollision",AntiColliderAction, + KillCollider, + myCollider); + + return 1; +} +/*------------------------------------------------------------------------*/ +int AntiColliderAction(SConnection *pCon, SicsInterp *pSics, + void *pData, + int argc, char *argv[]){ + pAntiCollider self = (pAntiCollider)pData; + Sequence seq; + char pBueffel[256]; + pMotReg pMot = NULL; + + assert(self != NULL); + + if(argc > 1){ + if(strcmp(argv[1],"clear") == 0){ + if(!SCMatchRights(pCon,usUser)){ + return 0; + } + LLDdelete(self->sequenceList); + self->sequenceList = LLDcreate(sizeof(Sequence)); + SCSendOK(pCon); + return 1; + } else if(strcmp(argv[1],"list") == 0){ + ListSequence(self->sequenceList,pCon); + return 1; + } + } + + if(argc < 3){ + SCWrite(pCon,"ERROR : insufficient number of arguments to anticollision", + eError); + return 0; + } + + strtolower(argv[1]); + if(strcmp(argv[1],"script") == 0){ + if(!SCMatchRights(pCon,usMugger)){ + return 0; + } + if(self->colliderScript != NULL){ + free(self->colliderScript); + } + self->colliderScript = strdup(argv[2]); + SCSendOK(pCon); + return 1; + } else if(strcmp(argv[1],"register") == 0){ + if(!SCMatchRights(pCon,usMugger)){ + return 0; + } + if(FindDrivable(pSics,argv[2]) == NULL){ + sprintf(pBueffel,"ERROR: %s is NOT drivable, cannot register",argv[2]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + pMot = RegisterMotor(argv[2],pSics, + ReplacementSetValue, + ReplacementCheckStatus); + if(pMot){ + LLDnodeAppendFrom(self->motorList,&pMot); + SCSendOK(pCon); + return 1; + } else { + SCWrite(pCon,"ERROR: out of memory registering motor",eError); + return 0; + } + } else if(strcmp(argv[1],"add") == 0){ + if(argc < 5){ + SCWrite(pCon, + "ERROR: InsUfficient number of arguments to anticollicion add", + eError); + return 0; + } + seq.level = atoi(argv[2]); + strncpy(seq.pMotor,argv[3],79); + seq.target = atof(argv[4]); + LLDnodeAppendFrom(self->sequenceList,&seq); + SCSendOK(pCon); + return 1; + } + SCWrite(pCon,"ERROR: anticollider command not understood",eError); + return 0; +} + + diff --git a/anticollider.h b/anticollider.h new file mode 100644 index 00000000..f526789c --- /dev/null +++ b/anticollider.h @@ -0,0 +1,25 @@ + +/*---------------------------------------------------------------------- + This is the header file for the AntiCollider, a complex movements + control module for SICS. See anticoliider.tex for more information. + + copyright: see file copyright + + Mark Koennecke, August 2002 +------------------------------------------------------------------------*/ +#ifndef ANTICOLLIDER +#define ANTICOLLIDER + + + int AntiColliderFactory(SConnection *pCon, SicsInterp *pSics, + void *pData, + int argc, char *argv[]); + int AntiColliderAction(SConnection *pCon, SicsInterp *pSics, + void *pData, + int argc, char *argv[]); + + +#endif + + + diff --git a/anticollider.i b/anticollider.i new file mode 100644 index 00000000..74307cc5 --- /dev/null +++ b/anticollider.i @@ -0,0 +1,28 @@ + +/*------------------------------------------------------------------------- + Anticollider internal data structure definition. Generated from + anticollider.w. Do not edit. +-------------------------------------------------------------------------*/ + + typedef struct __ANTICOLLIDER{ + pObjectDescriptor pDes; + pIDrivable pDriv; + int motorList; + int sequenceList; + char *colliderScript; + int isDirty; + int level; + }AntiCollider, *pAntiCollider; + + + typedef struct { + int level; + char pMotor[80]; + float target; + }Sequence; + + int StartLevel(int level, int sequenceList, int motorList, + SConnection *pCon); + + + diff --git a/anticollider.w b/anticollider.w new file mode 100644 index 00000000..4790bf10 --- /dev/null +++ b/anticollider.w @@ -0,0 +1,275 @@ +\subsubsection{The Anti Collider} +In some cases certain instrument positions can only be reached through +special sequences of drive instructions. Usually because some concrete +blocks or unduly bulky sample environment devices are in the path of +the instrument. Such cases can not be handled through primitive motor +limits. Handling such cases is the objective of the Anti Collider. + +The first thing needed is that motors involved with such complex +movements are registered with the Anti Collider. In this stage the +Anti Collider will take over the SetValue and CheckStatus functions of +the drivable interface of the motor. SetValue will be replaced by a +function which will register the drive request with the Anti +Collider. CheckStatus will be replaced by a version which checks with +the Anti Collider if the complex movement has finished. + +It is expected that coordinated and complex movements are initiated +within a single command. The first checkpoint where the complex +movement can be analyzed and coordinated the is when the device +executor calls CheckStatus for the first time. CheckStatus will detect +this condition and proceeds to call a Tcl procedure which then has to +create a r\"unb\"uffer which holds the necessary commands to drive the +complex movement. Or returns an error if the movement is not +possible. This scheme allows the instrument scientist to adapt the +way how the instrument moves to new sample environment devices, new +ideas or the growth of experience. Moreover this scheme allows to +handle all instruments with just a single module. As the Anti Collider +has taken over the SetValue method of the drivable interface of the +motor a command is provided which allows to start the actual motor. + +The user supplied Tcl script receives as arguments a list of motor and +target values to be driven. The script then has to return either an +error if the movement is not possible or the name of a r\"unb\"uffer +which performs the movement. + +The first thing needed for all this is a data structure which holds +the registration information and status of the controlled motor. This +information will be kept in a list holding the data tsrucutre given +below: + +@d motreg @{ + +typedef struct __MOTREG { + void *motorData; + char *motorName; + float targetPosition; + long (*originalSetValue)(void *motorData, + SConnection *pCon, + float fTarget); + int (*originalCheckStatus)(void *motorData, + SConnection *pCon); + int iActive; + } MotReg, *pMotReg; +@} +The fields are: +\begin{description} +\item[motorData] The motor data structure. +\item[motorName] The name of the motor operating. +\item[targetPosition] The requested target position for this motor. +\item[originalSetValue] the original motor starting function. +\item[originalCheckStatus] The original status checking function. +\item[iActive] A flag denoting if the motor has been started by the +Anti Collider. This causes the motors status to be checked which +checking status. If the motor becomes idle, this is set to 0 again. +\end{description} + + +The following interface functions are defined for this datastructure: +@d motregint @{ + pMotReg RegisterMotor(char *name, SicsInterp *pSics, + long (*SetValue)(void *pData, SConnection *pCon, float + fTarget), + int (*CheckStatus)(void *pData, SConnection *pCon)); + void KillRegMot(void *self); + + void SetRegMotTarget(pMotReg self, float target); + void CreateTargetString(pMotReg self, char pBueffel[80]); + + int RegMotMatch(pMotReg self, char *name); + + int StartRegMot(pMotReg self, SConnection *pCon, float fValue); + + int CheckRegMot(pMotReg self, SConnection *pCon); + +@} + +The functions in detail: +\begin{description} +\item[RegisterMotor] tries to find the motor name in the interpreter +pSics. Then all necessary manipulations are performed in order to +register the motor. In ths case of success a pointer to a new RegMot +data structure is returned. In the event of failure, NULL is +returned. Of course this function has to take the function pointers to +the drivable interface functions to replace as parameters. +\item[KillRegMot] kills a RegMot structure. +\item[SetRegMotTarget] sets a new target for a complex movement. +\item[CreateTragetString] creates in pBueffel this motors contribution +to a complex movement. +\item[RegMotMatch] returns 1 (true) if the string name matches the name stored +for this motor. Else 0. This will be used when searching for a +registered motor in the list. +\item[StartRegMot] will actually cause a real motor to start driving +towards the target given in fValue. The return value is the result of +the original motors SetValue method. +\item[CheckRegMot] checks for error conditions on the motor. +\end{description} + +Moreover it is convenient to define a couple of convenience functions +for handling the list of registered motors. The actual list is +managed through the lld functions as everywhere within SICS. + +@d motlist @{ + int MakeMotList(); + pMotReg FindMotEntry(int iList,char *name); + pMotReg FindMotFromDataStructure(int iList, void *pData); + int CheckAllMotors(int iList, SConnection *pCon); + void KillMotList(int iList); +@} +The functions: +\begin{description} +\item[MakeMotList] creates a new list for MotReg structures and +returns the handle for it. +\item[FindMotEntry] locates a motor in the list by name. If a matching +motor can be found, this function returns a pointer to the motors +MotReg structure. In the case of failure NULL is returned. +\item[FindMotFromDataStructure] locates a motor in the list through + the pointer to its data structure. . If a matching +motor can be found, this function returns a pointer to the motors +MotReg structure. In the case of failure NULL is returned. +\item[CheckAllMotors] checks all the active motors for the finished +condition. The number of running motors is returned. 0 if none is running. +\item[KillMotList] kills the list and all entries in it. +\end{description} + +In order to know how the anticollider has to run the motors a means is +needed to hold the sequence of motors to drive. This information must +be configured from the anticollider script. The information is held in +another list in a special data structure. + +@d seqlist @{ + typedef struct { + int level; + char pMotor[80]; + float target; + }Sequence; + + int StartLevel(int level, int sequenceList, int motorList, + SConnection *pCon); + +@} +The fields and functions are: +\begin{description} +\item[level] The level at which this motor shall be started. +\item[pMotor] The name of the motor to start. +\item[target] The target value for the motor. +\item[StartLevel] starts all motors belonging to a the level +specified. Returns the number of motors started or ) if none is +started. This last condition is also the condition when levels are +exhausted and we need to finish running the anticollider. +\end{description} + + +The anticollider itself is characterized through the following data +structure: +@d antidat @{ + typedef struct __ANTICOLLIDER{ + pObjectDescriptor pDes; + pIDrivable pDriv; + int motorList; + int sequenceList; + char *colliderScript; + int isDirty; + int level; + }AntiCollider, *pAntiCollider; +@} +The fields are: +\begin{description} +\item[pDes] The object descriptor required by SICS. +\item[motorList] The list of registered motors. +\item[colliderScript] the Tcl script called to calculate the movement. +\item[iDirty] a flag which is set to 1 (true) when a new movement must + be calculated. +\end{description} + +Most of the anticolliders functionality is implemented in interface +functions. The interface to the outside world is purely defined +through the interpreter functions. + +@d antiint @{ + int AntiColliderFactory(SConnection *pCon, SicsInterp *pSics, + void *pData, + int argc, char *argv[]); + int AntiColliderAction(SConnection *pCon, SicsInterp *pSics, + void *pData, + int argc, char *argv[]); +@} + + +@o motreg.h @{ +/*------------------------------------------------------------------------- + R e g M o t + + This is a helper module for the Anti Collider. It handles all the + stuff necessary for dealing with a single motor. For more + information see the file anticollider.tex. + + copyright: see file copyright + + Mark Koennecke, August 2002 +-----------------------------------------------------------------------*/ +#ifndef REGMOT +#define REGMOT +#include "sics.h" + +@ + +/*----------------------------------------------------------------------*/ +@ + +#endif + +@} + +@o motreglist.h @{ +/*----------------------------------------------------------------------- + A couple of utility functions for handling a list of MotReg + structures . This is a helper module for the anticollider collision + control system. See anticollider.tex for more details. + + copyright: see file copyright + + Mark Koennecke, August 2002 +-------------------------------------------------------------------------*/ +#ifndef MOTREGLIST +#define MOTREGLIST + +#include "motreg.h" + +@ + + +#endif + + +@} + + +@o anticollider.i @{ +/*------------------------------------------------------------------------- + Anticollider internal data structure definition. Generated from + anticollider.w. Do not edit. +-------------------------------------------------------------------------*/ +@ +@ + +@} + +@o anticollider.h @{ +/*---------------------------------------------------------------------- + This is the header file for the AntiCollider, a complex movements + control module for SICS. See anticoliider.tex for more information. + + copyright: see file copyright + + Mark Koennecke, August 2002 +------------------------------------------------------------------------*/ +#ifndef ANTICOLLIDER +#define ANTICOLLIDER + +@ + +#endif + + + +@} \ No newline at end of file diff --git a/ati.tcl b/ati.tcl new file mode 100644 index 00000000..e274d886 --- /dev/null +++ b/ati.tcl @@ -0,0 +1,7 @@ +drive mom 3. +scan var a2t 0. .2 +scan var som 0. .1 +scan preset 1 +scan mode timer +scan np 20 +scan run diff --git a/author.txt b/author.txt new file mode 100644 index 00000000..d579a3c4 --- /dev/null +++ b/author.txt @@ -0,0 +1,46 @@ + 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 "lld.h" +#include "lld_blob.h" +#include "lld_str.h" +#include "conman.h" +#include "obdes.h" +#include "fupa.h" +#include "motor.h" +#include "datadmc.h" +#include "countdriv.h" +#include "counter.h" diff --git a/autofile.tcl b/autofile.tcl new file mode 100644 index 00000000..608adaa6 --- /dev/null +++ b/autofile.tcl @@ -0,0 +1,211 @@ +#---------------------------------------------------------------------------- +# This is part of the WWW-interface to SICS. This interface allows to +# create batch files to be run automatically by SICS. These files are +# stored in a special directory as files with the ending .sip by the +# CGI-scripts or servlets creating them. Now, a system is needed which +# checks this directory regularly for new files and executes them in SICS. +# This is the purpose of the SICS-Tcl macros defined in this file. +# +# First edition: Mark Koennecke, December 1999 +#---------------------------------------------------------------------------- + +#----------- !!!! the path where the automatic files reside +set autofpath "/data/koenneck/tmp/auto" + +#------- a variable which defines if we should operate and the current file. +set __autofile_run 0 +set __auto_exe_file "" + +#!!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +# There is a name command between the Tcl internal scan command and the +# SICS scan command. The Tcl internal has to be renamed. The following +# variable defines the name of the Tcl scan command +set tclscan stscan + +#---------- do initializing things when called first time +set ret [catch [catch {autofile} msg] +if {$ret != 0} { + VarMake autofilepath Text Mugger + autofilepath $autofpath + autofilepath lock + Publish autofileexecute User + Publish autofile Mugger + Publish autostart User + Publish autoadd User + Publish autoend User +#------- for automatic file name creation + catch {MakeDataNumber autonumber $autofpath/autonumber.dat} +#------- check any 30 seconds + sicscron 30 autofileexecute +} + +#-------------------------------------------------------------------------- +proc autofile { {action null} } { + upvar #0 __autofile_run ar + + if { [string compare $action start] == 0} { + set ar 1 + return OK + } elseif { [string compare $action stop] == 0 } { + set ar 0 + return OK + } else { + if {$ar == 1} { + return on + } else { + return off + } + } +} + +#-------------------------------------------------------------------------- +proc autofileexecute { } { + upvar #0 __autofile_run ar + upvar #0 __auto_exe_file aef + upvar #0 tclscan filescan +#--------- no operation if not activated + if {$ar != 1} { + return + } +#--------- aquire a list of candidate batch files + set tmp [autofilepath] + set ltmp [split $tmp =] + set tmp [lindex $ltmp 1] + set tmp2 [string trim $tmp]/*.inp + set ret [catch {set filelist [glob $tmp2]} msg] + if {$ret != 0} { + return "Nothing to do" + } + if { [llength $filelist] < 1 } { + return "Nothing to do" + } +#--------- now, in each file the second line contains the order number, +# find the lowest one which is the next one to execute + set minnum 999999 + set file2exe null + foreach fil $filelist { + set f [open $fil r] + gets $f + set numline [gets $f] + set ret [catch {$filescan $numline "# %d" numi} msg] + close $f + if { $ret == 0 } { + if { $numi < $minnum } { + set minnum $numi + set file2exe $fil + } + } else { + ClientPut $msg + } + } +#------------ having found an input file, execute it + if { [string compare $file2exe null] != 0 } { + set aef $file2exe + set ret [catch {interneval $file2exe} msg] +#------ after execution rename it with a different extension + set fil2 [file rootname $file2exe].old + file rename -force $file2exe $fil2 + if {$ret != 0 } { + error $msg + } else { + return $msg + } + } + return "Invalid autobatch files" +} + +#========================================================================= +# File management functions +# +# autostart creates a fresh file. The data is stored in a SICS runbuffer. +# autoadd adds a line to the runbuffer +# autoend writes the file to disk then. +#========================================================================= + +proc autostart {} { + catch {buf del autobuffer} + Buf new autobuffer +} + +proc autoadd args { + autobuffer append $args +} + +proc autoend {} { + upvar #0 autofpath ap + autonumber incr + set txt [autonumber] + set l [split $txt =] + set txt [string trim [lindex $l 1]] + set fil [format "$ap/auto%7.7d.inp" $txt] + set filnum [format "# %d" $txt] + autobuffer ins 1 $filnum + autobuffer save $fil + Buf del autobuffer +} + +#============================================================================ +# file list management +#============================================================================ + +proc buildsortedlist {filar} { + upvar #0 autofpath ap + upvar $filar list + set i 0 +#----------- build arrays of all relevant files + set ret [catch {set l1 [glob $ap/*.inp]}] + if { $ret == 0 } { + foreach fil $l1 { + set list($i) + incr i + set f [open $fil r] + set $fil(title) [gets $f] + set txt [gets $f] + close $f + set ret [catch {$filescan $txt "# %d" numi} msg] + if { $ret == 0} { + set fil(no) $numi + }else { + set fil(no) -10 + } + } + } + set ret [catch {set l1 [glob $ap/*.old]}] + if { $ret == 0 } { + foreach fil $l1 { + set list($i) + incr i + set f [open $fil r] + set $fil(title) [gets $f] + set txt [gets $f] + close $f + set ret [catch {$filescan $txt "# %d" numi} msg] + if { $ret == 0} { + set fil(no) $numi + }else { + set fil(no) -10 + } + } + } + set nfil i +#--------- now selection sort this list + for {set i 0} { i < $nfil} {incr i} { + set min $i + set ff $list($min) + for {set j [expr $i + 1]} {$j < $nfil} {incr j} { + set ff $list($j) + set fff $list($min) + if { $ff(no) < $fff(no)} { + set min $j + } + } + set t $list($min) + set list($min) $list($min) + set list($i) $t + } +} + +proc autolist {} { + +} + diff --git a/backup.tcl b/backup.tcl new file mode 100644 index 00000000..b5dc3e50 --- /dev/null +++ b/backup.tcl @@ -0,0 +1,137 @@ +# RuenBuffer Renate +Buf new Renate +Renate append Alle Fische sind schon da + +Renate append Alle Nixen auch + +Renate append Nur die dummen Neutronen kommen nicht + +Renate append Und die Schluempfe kriegen es auch nicht gebacken + +# RuenBuffer Kunigunde +Buf new Kunigunde +Kunigunde append Alle Fische sind schon da + +Kunigunde append Alle Nixen auch + +Kunigunde append Nur die dummen Neutronen kommen nicht + +Kunigunde append Und die Schluempfe kriegen es auch nicht gebacken + +# RuenBuffer Walter +Buf new Walter +Walter append Alle Fische sind schon da + +Walter append Alle Nixen auch + +Walter append Nur die dummen Neutronen kommen nicht + +Walter append Und die Schluempfe kriegen es auch nicht gebacken + +# RuenBuffer Willi +Buf new Willi +Willi append Alle Nixen auch +Willi append Und die Schluempfe kriegen es auch nicht gebacken +# RuenBuffer Heinz +Buf new Heinz +Heinz append GGG Fische sind schon da +Heinz append GGG Nixen auch +Heinz append Nur die dummen Neutronen kommen schon +Heinz append Und die Schluempfe kriegen es auch schon gebacken + +Curve SoftLowerLim 0.000000 +Curve SoftUpperLim 1000.000000 +Curve SoftZero 0.000000 +Curve Fixed -1.000000 +Curve InterruptMode 0.000000 +Curve AccessCode 2.000000 +TwoTheta SoftLowerLim -140.000000 +TwoTheta SoftUpperLim 140.000000 +TwoTheta SoftZero 0.000000 +TwoTheta Fixed -1.000000 +TwoTheta InterruptMode 0.000000 +TwoTheta AccessCode 2.000000 +Theta SoftLowerLim -70.000000 +Theta SoftUpperLim 70.000000 +Theta SoftZero 0.000000 +Theta Fixed -1.000000 +Theta InterruptMode 0.000000 +Theta AccessCode 2.000000 +bsy SoftLowerLim -50.000000 +bsy SoftUpperLim 50.000000 +bsy SoftZero 0.000000 +bsy Fixed -1.000000 +bsy InterruptMode 0.000000 +bsy AccessCode 2.000000 +bsx SoftLowerLim -50.000000 +bsx SoftUpperLim 50.000000 +bsx SoftZero 0.000000 +bsx Fixed -1.000000 +bsx InterruptMode 0.000000 +bsx AccessCode 2.000000 +dphi SoftLowerLim 0.000000 +dphi SoftUpperLim 360.000000 +dphi SoftZero 0.000000 +dphi Fixed -1.000000 +dphi InterruptMode 0.000000 +dphi AccessCode 2.000000 +dsy SoftLowerLim -50.000000 +dsy SoftUpperLim 50.000000 +dsy SoftZero 0.000000 +dsy Fixed -1.000000 +dsy InterruptMode 0.000000 +dsy AccessCode 2.000000 +dsd SoftLowerLim 0.000000 +dsd SoftUpperLim 18000.000000 +dsd SoftZero 0.000000 +dsd Fixed -1.000000 +dsd InterruptMode 0.000000 +dsd AccessCode 2.000000 +saz SoftLowerLim 0.000000 +saz SoftUpperLim 30.000000 +saz SoftZero 0.000000 +saz Fixed -1.000000 +saz InterruptMode 0.000000 +saz AccessCode 2.000000 +say SoftLowerLim -22.000000 +say SoftUpperLim 22.000000 +say SoftZero 0.000000 +say Fixed -1.000000 +say InterruptMode 0.000000 +say AccessCode 2.000000 +sax SoftLowerLim -30.000000 +sax SoftUpperLim 30.000000 +sax SoftZero 0.000000 +sax Fixed -1.000000 +sax InterruptMode 0.000000 +sax AccessCode 2.000000 +som SoftLowerLim -180.000000 +som SoftUpperLim 360.000000 +som SoftZero 0.000000 +som Fixed -1.000000 +som InterruptMode 0.000000 +som AccessCode 2.000000 +sphi SoftLowerLim -22.000000 +sphi SoftUpperLim 22.000000 +sphi SoftZero 0.000000 +sphi Fixed -1.000000 +sphi InterruptMode 0.000000 +sphi AccessCode 2.000000 +schi SoftLowerLim -22.000000 +schi SoftUpperLim 22.000000 +schi SoftZero 0.000000 +schi Fixed -1.000000 +schi InterruptMode 0.000000 +schi AccessCode 2.000000 +comment (null) +comment setAccess 2 +environment (null) +environment setAccess 2 +SubTitle (null) +SubTitle setAccess 2 +User set +User setAccess 2 +Title Alle meine Entchen sind schon da +Title setAccess 2 +Instrument set +Instrument setAccess 0 diff --git a/bare.tcl b/bare.tcl new file mode 100644 index 00000000..7c4fe26c --- /dev/null +++ b/bare.tcl @@ -0,0 +1,47 @@ +# -------------------------------------------------------------------------- +# Initialization script for a simulated TOPSI instrument +# +# +# Dr. Mark Koennecke February, 1996 +#--------------------------------------------------------------------------- +# O P T I O N S + +# --------------- Initialize Tcl internals -------------------------------- + +# first all the server options are set + +ServerOption ReadTimeOut 10 +# timeout when checking for commands. In the main loop SICS checks for +# pending commands on each connection with the above timeout, has +# PERFORMANCE impact! + +ServerOption AcceptTimeOut 10 +# timeout when checking for connection req. +# Similar to above, but for connections + +ServerOption ReadUserPasswdTimeout 500000 +# time to wiat for a user/passwd to be sent from a client. Increase this +# if there is a problem connecting to a server due to network overload\ + +ServerOption LogFileBaseName /data/koenneck/src/sics/tmp/server +# the path and base name of the internal server logfile to which all +# activity will be logged. + +ServerOption ServerPort 2910 +# the port number the server is going to listen at. The client MUST know +# this number in order to connect. It is in client.ini + +ServerOption InterruptPort 2913 +# The UDP port where the server will wait for Interrupts from clients. +# Obviously, clients wishing to interrupt need to know this number. + + +#--------------------------------------------------------------------------- +# U S E R S + +# than the SICS users are specified +# Syntax: SicsUser name password userRightsCode +SicsUser Mugger Diethelm 1 +SicsUser User Rosy 2 +SicsUser Spy 007 3 + diff --git a/beam.tcl b/beam.tcl new file mode 100644 index 00000000..fc2baf2c --- /dev/null +++ b/beam.tcl @@ -0,0 +1,20 @@ +#------------------------------------------------------------------------ +# install a SPS-Controller +MakeSPS sps1 lnsp25.psi.ch 4000 7 + +#----------------- the beam command +proc beam {} { +#---------- read the SPS + set ret [catch {SPS1 adc 3} msg] + if {$ret != 0} { + ClientPut $msg + ClientPut "ERROR: SPS reading failed" + return + } +#--------- convert the data + set l [split $msg "="] + set raw [lindex $l 1] + set val [expr $raw/13.96] + return [format "beam = %f" $val] +} +Publish beam Spy diff --git a/beamdt.tcl b/beamdt.tcl new file mode 100644 index 00000000..3f30ba3a --- /dev/null +++ b/beamdt.tcl @@ -0,0 +1,20 @@ +#------------------------------------------------------------------------ +# install a SPS-Controller +MakeSPS sps1 lnsp23.psi.ch 4000 6 + +#----------------- the beam command +proc beam {} { +#---------- read the SPS + set ret [catch {SPS1 adc 7} msg] + if {$ret != 0} { + ClientPut $msg + ClientPut "ERROR: SPS reading failed" + return + } +#--------- convert the data + set l [split $msg "="] + set raw [lindex $l 1] + set val [expr $raw/13.96] + return [format "beam = %f" $val] +} +Publish beam Spy diff --git a/bit.h b/bit.h new file mode 100644 index 00000000..45b3cbf3 --- /dev/null +++ b/bit.h @@ -0,0 +1,17 @@ +/*-------------------------------------------------------------------------- + + Macros for handling bits in a character array. Stolen somewhere on the + internet. Working! + + Dr. Mark Koennecke 15.6.1994 + +----------------------------------------------------------------------------*/ + + +#include /* for CHAR_BIT */ + +#define BITMASK(bit) (1 << ((bit) % CHAR_BIT)) +#define BITSLOT(bit) ((bit) / CHAR_BIT) +#define BITSET(ary, bit) ((ary)[BITSLOT(bit)] |= BITMASK(bit)) +#define BITTEST(ary, bit) ((ary)[BITSLOT(bit)] & BITMASK(bit)) +#define BITUNSET(ary, bit) ((ary)[BITSLOT(bit)] ^= BITMASK(bit)) diff --git a/bruker.c b/bruker.c new file mode 100644 index 00000000..0c413dbe --- /dev/null +++ b/bruker.c @@ -0,0 +1,999 @@ +/*------------------------------------------------------------------------- + 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 new file mode 100644 index 00000000..bfa26a29 --- /dev/null +++ b/bruker.h @@ -0,0 +1,25 @@ +/*------------------------------------------------------------------------- + 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.tex b/bruker.tex new file mode 100644 index 00000000..2a96bcb9 --- /dev/null +++ b/bruker.tex @@ -0,0 +1,64 @@ +\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/bruker.w b/bruker.w new file mode 100644 index 00000000..2a96bcb9 --- /dev/null +++ b/bruker.w @@ -0,0 +1,64 @@ +\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 new file mode 100644 index 00000000..998d1b39 --- /dev/null +++ b/buffer.c @@ -0,0 +1,584 @@ +/*-------------------------------------------------------------------------- + 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 new file mode 100644 index 00000000..785c487b --- /dev/null +++ b/buffer.h @@ -0,0 +1,94 @@ +/*--------------------------------------------------------------------------- + + 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/build b/build new file mode 100755 index 00000000..7acdcad0 --- /dev/null +++ b/build @@ -0,0 +1,29 @@ +#!/bin/sh +#--------------------------------------------------------------------------- +# build SICS from Scratch +# +# Mark Koennecke, September 2000 +#-------------------------------------------------------------------------- + +#----- build hardsup +cd hardsup +make +cd .. + +#------- build tecs +cd tecs +make +cd .. + +#----- build difrac +#cd difrac +#make +#cd .. +# +#---- build matrix +cd matrix +make +cd .. + +#------- finally build SICS +make diff --git a/callback.c b/callback.c new file mode 100644 index 00000000..e1c59d30 --- /dev/null +++ b/callback.c @@ -0,0 +1,370 @@ +/*-------------------------------------------------------------------------- + + S I C S C A L L B A C K + + Functions needed to deal with the SICSCallback interface. Description is + in file interface.h, interface.w and interface.w. + + Mark Koennecke, Juli 1997 + + Added ScriptCallback, Mark Koennecke, June 2003 + + 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 "sics.h" +#include "macro.h" + + +#define CALLBACK 17777 + + +/*--------------------- The interface datastructure ---------------------*/ + typedef struct __ICallBack { + int iID; + int iList; + } ICallBack; + +/*-------------- The data stored for a single callback ------------------*/ + typedef struct { + long iID; + SICSCallBack pFunc; + void *pUserData; + KillFuncIT pKill; + int iEvent; + } CallBackItem, *pCallBackItem; +/*------------------------------------------------------------------------*/ + static int CheckPointer(pICallBack self) + { + if(self == NULL) return 0; + if(self->iID != CALLBACK) + { + return 0; + } + return 1; + } +/*-------------------------------------------------------------------------*/ + + pICallBack CreateCallBackInterface(void) + { + pICallBack pNew = NULL; + + pNew = (pICallBack)malloc(sizeof(ICallBack)); + if(!pNew) + { + return 0; + } + + pNew->iID = CALLBACK; + pNew->iList = LLDcreate(sizeof(CallBackItem)); + if(pNew->iList < 0) + { + free(pNew); + return NULL; + } + return pNew; + } +/*--------------------------------------------------------------------------*/ + void DeleteCallBackInterface(pICallBack self) + { + int iRet; + CallBackItem sItem; + + if(!CheckPointer(self)) + { + return; + } + + /* kill all userdata associated with callbacks */ + iRet = LLDnodePtr2First(self->iList); + while(iRet != 0) + { + LLDnodeDataTo(self->iList,&sItem); + if(sItem.pKill != NULL) + { + sItem.pKill(sItem.pUserData); + } + iRet = LLDnodePtr2Next(self->iList); + } + + LLDdelete(self->iList); + free(self); + } +/*--------------------------------------------------------------------------*/ + int InvokeCallBack(pICallBack self, int iEvent, void *pEventData) + { + CallBackItem sItem; + int iCurrent, iRet; + int iResult = 1; + + if(!CheckPointer(self)) + { + return 0; + } + + iCurrent = LLDnodePtr2First(self->iList); + while(iCurrent != 0) + { + LLDnodeDataTo(self->iList,&sItem); + if(sItem.iEvent == iEvent) + { + iRet = sItem.pFunc(iEvent, pEventData,sItem.pUserData); + if(!iRet) + { + iResult = 0; + } + } + iCurrent = LLDnodePtr2Next(self->iList); + } + return iResult; + } +/*--------------------------------------------------------------------------*/ + static long lCount = 1L; + + long RegisterCallback(pICallBack self, int iEvent, + SICSCallBack pFunc, + void *pUserData, KillFunc pKFunc) + { + CallBackItem sItem; + + if(!CheckPointer(self)) + { + return 0; + } + + sItem.iID = lCount++; + assert(pFunc); + sItem.pFunc = pFunc; + sItem.iEvent = iEvent; + sItem.pUserData = pUserData; + sItem.pKill = pKFunc; + + LLDnodeAppendFrom(self->iList,&sItem); + return sItem.iID; + } +/*-------------------------------------------------------------------------*/ + int RemoveCallback(pICallBack self, long lID) + { + CallBackItem sItem; + int iCurrent; + + if(!CheckPointer(self)) + { + return 0; + } + + iCurrent = LLDnodePtr2First(self->iList); + while(iCurrent != 0) + { + LLDnodeDataTo(self->iList,&sItem); + if(sItem.iID == lID) + { + if(sItem.pKill != NULL) + { + sItem.pKill(sItem.pUserData); + } + LLDnodeDelete(self->iList); + return 1; + } + iCurrent = LLDnodePtr2Next(self->iList); + } + return 0; + } +/*--------------------------------------------------------------------------*/ + int RemoveCallback2(pICallBack self, void *pUserData) + { + CallBackItem sItem; + int iCurrent; + + if(!CheckPointer(self)) + { + return 0; + } + + iCurrent = LLDnodePtr2First(self->iList); + while(iCurrent != 0) + { + LLDnodeDataTo(self->iList,&sItem); + if(sItem.pUserData == pUserData) + { + if(sItem.pKill != NULL) + { + sItem.pKill(sItem.pUserData); + } + LLDnodeDelete(self->iList); + } + iCurrent = LLDnodePtr2Next(self->iList); + } + return 1; + } +/*------------------------------------------------------------------- + a write function for the connection which writes to stdout + -------------------------------------------------------------------*/ +static int CallbackWrite(SConnection *pCon,char *message, int outCode) +{ + if(outCode >= eWarning) + { + fputs(message,stdout); + fputs("\n",stdout); + } + return 1; +} +/*----------------------------------------------------------------------- + the actual callback function invoking the script + ------------------------------------------------------------------------*/ +static int ScriptCallback(int iEvent, void *pEventData, void *pUserData) +{ + SConnection *pCon = NULL; + Tcl_Interp *pTcl; + int status; + + pCon = SCCreateDummyConnection(pServ->pSics); + if(!pCon) + { + fprintf(stdout,"ERROR: failed to create dummy connection\n"); + return 0; + } + if(pUserData == NULL) + { + fprintf(stdout,"ERROR: ScriptCallback: no script to execute\n"); + return 0; + } + SCSetWriteFunc(pCon,CallbackWrite); + MacroPush(pCon); + pTcl = InterpGetTcl(pServ->pSics); + status = Tcl_GlobalEval(pTcl,(char *)pUserData); + if(status != TCL_OK) + { + fprintf(stdout,"ERROR: in CallbackScript: %s\n",(char *)pUserData); + fprintf(stdout,"Tcl-error: %s\n",pTcl->result); + } + MacroPop(); + SCDeleteConnection(pCon); + return 1; +} +/*------------------------------------------------------------------------*/ +int CallbackScript(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) +{ + long lID; + int iEvent, status; + pICallBack pCall = NULL; + CommandList *pCom = NULL; + char pBuffer[132]; + + if(argc < 2) + { + SCWrite(pCon,"ERROR: insufficient number of arguments to callbackScript", + eError); + return 0; + } + /* + only managers may do this + */ + if(!SCMatchRights(pCon,usMugger)) + { + return 0; + } + + strtolower(argv[1]); + if(strcmp(argv[1],"connect") == 0) + { + if(argc < 5) + { + SCWrite(pCon,"ERROR: not enough arguments to CallbackScript connect", + eError); + return 0; + } + strtolower(argv[2]); + pCom = FindCommand(pSics,argv[2]); + if(!pCom) + { + SCWrite(pCon,"ERROR: object to connect to not found",eError); + return 0; + } + pCall = GetCallbackInterface(pCom->pData); + if(!pCall) + { + SCWrite(pCon,"ERROR: object has no callback interface",eError); + return 0; + } + iEvent = Text2Event(argv[3]); + if(iEvent < 0) + { + SCWrite(pCon,"ERROR: event type not known",eError); + return 0; + } + lID = RegisterCallback(pCall,iEvent,ScriptCallback, + strdup(argv[4]),free); + sprintf(pBuffer,"callback = %ld", lID); + SCWrite(pCon,pBuffer,eValue); + return 1; + } + else if(strcmp(argv[1],"remove") == 0) + { + if(argc < 4) + { + SCWrite(pCon,"ERROR: not enough arguments to CallbackScript remove", + eError); + return 0; + } + strtolower(argv[2]); + pCom = FindCommand(pSics,argv[2]); + if(!pCom) + { + SCWrite(pCon,"ERROR: object to remove to not found",eError); + return 0; + } + pCall = GetCallbackInterface(pCom->pData); + if(!pCall) + { + SCWrite(pCon,"ERROR: object has no callback interface",eError); + return 0; + } + status = Tcl_GetInt(InterpGetTcl(pSics),argv[3],&iEvent); + if(status != TCL_OK) + { + SCWrite(pCon,"ERROR: failed to convert callback ID to int",eError); + return 0; + } + RemoveCallback(pCall,(long)iEvent); + SCSendOK(pCon); + return 1; + } + + SCWrite(pCon,"ERROR: subcommand to CallbackScript not known",eError); + return 0; +} diff --git a/center.tex b/center.tex new file mode 100644 index 00000000..b1e3ecae --- /dev/null +++ b/center.tex @@ -0,0 +1,79 @@ +\subsection{Fit and Center} +This is a fit routine for SICS. It takes a scan and tries to find a peak and +its position. Trials showed that fitting a gauss function is not robust +enough for this facility which has to cope with bizarre peak shapes, half +finished measurements and the like. The algorithm choosen tries to find the +center of gravity of the peak. It does this by searching for the maximum +point in the diagram first. Then the points where the peak is below +half maximum are searched for either side of the peak. Within these +limits the COG is calculated. When this is done fit will print some +info about the peak. + +Center will the drive the scan variable to the COG of the peak. + +The interface to this simple facility is simple: + +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap1} +$\langle$fitinter {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ typedef struct __FitCenter *pFit;@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@/*--------------------------------------------------------------------------*/@\\ +\mbox{}\verb@ pFit CreateFitCenter(pScanData pScan);@\\ +\mbox{}\verb@ void DeleteFitCenter(void *pData);@\\ +\mbox{}\verb@/*-------------------------------------------------------------------------*/@\\ +\mbox{}\verb@ int CalculateFit(pFit self);@\\ +\mbox{}\verb@ /* @\\ +\mbox{}\verb@ CalcluateFit returns: -1 when left FWHM could not be found@\\ +\mbox{}\verb@ -2 when right FWHM could not be found@\\ +\mbox{}\verb@ 1 on success@\\ +\mbox{}\verb@ */@\\ +\mbox{}\verb@ int CalculateFitFromData(pFit self, float fAxis[], long lSum[], @\\ +\mbox{}\verb@ int iLen);@\\ +\mbox{}\verb@ void GetFitResults(pFit self, float *fNewCenter, float *fStdDev,@\\ +\mbox{}\verb@ float *FWHM, float *fMax);@\\ +\mbox{}\verb@ int DriveCenter(pFit self, SConnection *pCon, SicsInterp *pSics);@\\ +\mbox{}\verb@/*-------------------------------------------------------------------------*/@\\ +\mbox{}\verb@ int FitFactory(SConnection *pCon,SicsInterp *pSics, void *pData,@\\ +\mbox{}\verb@ int argc, char *argv[]);@\\ +\mbox{}\verb@ int FitWrapper(SConnection *pCon,SicsInterp *pSics, void *pData,@\\ +\mbox{}\verb@ int argc, char *argv[]);@\\ +\mbox{}\verb@ int CenterWrapper(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@"fitcenter.h"@ {\footnotesize ? }$\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@/*---------------------------------------------------------------------------@\\ +\mbox{}\verb@ F I T C E N T E R@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ A simple peak finding and center of gravity determination facility for@\\ +\mbox{}\verb@ SICS.@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ copyright: see copyright.h@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ Mark Koennecke, October 1997@\\ +\mbox{}\verb@----------------------------------------------------------------------------*/@\\ +\mbox{}\verb@#ifndef SICSFITCENTER@\\ +\mbox{}\verb@#define SICSFITCENTER@\\ +\mbox{}\verb@@$\langle$fitinter {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@#endif@\\ +\mbox{}\verb@@$\diamond$ +\end{list} +\vspace{-2ex} +\end{minipage}\\[4ex] +\end{flushleft} diff --git a/center.w b/center.w new file mode 100644 index 00000000..dc0f2939 --- /dev/null +++ b/center.w @@ -0,0 +1,58 @@ +\subsection{Fit and Center} +This is a fit routine for SICS. It takes a scan and tries to find a peak and +its position. Trials showed that fitting a gauss function is not robust +enough for this facility which has to cope with bizarre peak shapes, half +finished measurements and the like. The algorithm choosen tries to find the +center of gravity of the peak. It does this by searching for the maximum +point in the diagram first. Then the points where the peak is below +half maximum are searched for either side of the peak. Within these +limits the COG is calculated. When this is done fit will print some +info about the peak. + +Center will the drive the scan variable to the COG of the peak. + +The interface to this simple facility is simple: + +@d fitinter @{ + typedef struct __FitCenter *pFit; + +/*--------------------------------------------------------------------------*/ + pFit CreateFitCenter(pScanData pScan); + void DeleteFitCenter(void *pData); +/*-------------------------------------------------------------------------*/ + int CalculateFit(pFit self); + /* + CalcluateFit returns: -1 when left FWHM could not be found + -2 when right FWHM could not be found + 1 on success + */ + int CalculateFitFromData(pFit self, float fAxis[], long lSum[], + int iLen); + void GetFitResults(pFit self, float *fNewCenter, float *fStdDev, + float *FWHM, float *fMax); + int DriveCenter(pFit self, SConnection *pCon, SicsInterp *pSics); +/*-------------------------------------------------------------------------*/ + int FitFactory(SConnection *pCon,SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int FitWrapper(SConnection *pCon,SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int CenterWrapper(SConnection *pCon,SicsInterp *pSics, void *pData, + int argc, char *argv[]); +@} + +@o fitcenter.h @{ +/*--------------------------------------------------------------------------- + F I T C E N T E R + + A simple peak finding and center of gravity determination facility for + SICS. + + copyright: see copyright.h + + Mark Koennecke, October 1997 +----------------------------------------------------------------------------*/ +#ifndef SICSFITCENTER +#define SICSFITCENTER +@ +#endif +@} diff --git a/chadapter.c b/chadapter.c new file mode 100644 index 00000000..3e5753d6 --- /dev/null +++ b/chadapter.c @@ -0,0 +1,511 @@ +/*------------------------------------------------------------------------- + C h o c o A d a p t e r + + This is a drivable adapter for the ChopperController object (or also generic + controller object). It allows to modify one of the variables supported by + the controller through the normal SICS drive command. For more information + see file choco.w or choco.tex. + + + Mark Koennecke, January 1998 +---------------------------------------------------------------------------*/ +#include +#include +#include +#include "fortify.h" +#include "sics.h" +#define CHOCOINTERNAL +#include "choco.h" +#include "evcontroller.h" +#include "evdriver.i" +#define CHADAINTERNAL +#include "chadapter.h" + +#define NOTIMPLEMENTED -11555 + +/*-------------------------------------------------------------------------*/ + static void *AdapterGetInterface(void *pData, int iID) + { + pCHAdapter self = NULL; + + self = (pCHAdapter)pData; + assert(self); + if(iID == DRIVEID) + { + return self->pInt; + } + return NULL; + } +/*-------------------------------------------------------------------------*/ + static int CHHalt(void *pData) + { + pCHAdapter self = NULL; + + self = (pCHAdapter)pData; + assert(self); + + self->pDriv->Halt(self->pDriv); + + return 1; + } +/*-------------------------------------------------------------------------*/ + static int CHLimits(void *pData, float fVal, char *error, int iErrlen) + { + pCHAdapter self = NULL; + + self = (pCHAdapter)pData; + assert(self); + + if(fVal < self->fLower) + { + strncpy(error,"Lower limit violated",iErrlen); + return 0; + } + if(fVal > self->fUpper) + { + strncpy(error,"Upper limit violated",iErrlen); + return 0; + } + return 1; + } +/*------------------------------------------------------------------------*/ + static float CHGetValue(void *pData, SConnection *pCon) + { + pCHAdapter self = NULL; + float fVal; + int iRet; + char pBueffel[80]; + + self = (pCHAdapter)pData; + assert(self); + + iRet = self->pDriv->GetPar(self->pDriv,self->pParName,pBueffel,79); + if(!iRet) + { + fVal = -9999999.99; + self->pDriv->GetError(self->pDriv,&iRet,pBueffel,79); + SCWrite(pCon,pBueffel,eError); + return fVal; + } + sscanf(pBueffel,"%f",&fVal); + return fVal; + } +/*-----------------------------------------------------------------------*/ + static int CHStatus(void *pData, SConnection *pCon) + { + pCHAdapter self = NULL; + int iRet, iCode; + static int iRetry = 0; + char pBueffel[80], pError[132]; + + self = (pCHAdapter)pData; + assert(self); + + iRet = self->pDriv->CheckPar(self->pDriv,self->pParName); + switch(iRet) + { + case OKOK: + case HWIdle: + iRetry = 0; + return HWIdle; + case HWFault: + self->pDriv->GetError(self->pDriv,&iCode,pBueffel,79); + iRet = self->pDriv->TryFixIt(self->pDriv,iCode); + sprintf(pError,"ERROR: %s",pBueffel); + SCWrite(pCon,pError,eError); + if(iRet == CHFAIL || iRetry >= 3) + { + iRetry = 0; + return HWFault; + } + else + { + iRetry++; + self->pDriv->SetPar(self->pDriv,self->pParName, + self->fTarget); + return HWBusy; + } + break; + case HWBusy: + return HWBusy; + } + return HWFault; + } +/*-------------------------------------------------------------------------*/ + static long CHSetValue(void *pData, SConnection *pCon, float fValue) + { + pCHAdapter self = NULL; + char pBueffel[80], pError[132]; + int iRet, iCode, i; + + self = (pCHAdapter)pData; + assert(self); + + /* check privilege */ + if(!SCMatchRights(pCon,usUser)) + { + SCWrite(pCon,"ERROR: Insufficient privilege for driving",eError); + return 0; + } + + for(i = 0; i < 3; i++) + { + iRet = self->pDriv->SetPar(self->pDriv,self->pParName,fValue); + if(iRet) + { + self->fTarget = fValue; + return 1; + } + self->pDriv->GetError(self->pDriv,&iCode,pBueffel,79); + sprintf(pError,"ERROR: %s",pBueffel); + SCWrite(pCon,pError,eError); + iRet = self->pDriv->TryFixIt(self->pDriv,iCode); + if(iRet == CHFAIL) + return 0; + } + return 0; + } +/*------------------------------------------------------------------------*/ + static void KillAdapter(void *pData) + { + pCHAdapter self = NULL; + + self = (pCHAdapter)pData; + if(!self) + return; + + if(self->pDes) + DeleteDescriptor(self->pDes); + + if(self->pInt) + free(self->pInt); + + if(self->pParName); + free(self->pParName); + + free(self); + } +/*----------------------------------------------------------------------- + Syntax: ChopperAdapter name choppercontroller parname upper lower +*/ + int CHAdapterFactory(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + char pBueffel[256]; + pCHAdapter pNew = NULL; + pChoco pChopper = NULL; + CommandList *pCom = NULL; + pDummy pDum = NULL; + double dUpper, dLower; + int iRet; + + /* do we have enough arguments? */ + if(argc < 6) + { + SCWrite(pCon, + "ERROR: Insufficient number of arguments to ChopperAdapter", + eError); + return 0; + } + + /* find the chopper first */ + pCom = FindCommand(pSics,argv[2]); + if(pCom) + { + pDum = (pDummy)pCom->pData; + if(pDum) + { + if(strcmp(pDum->pDescriptor->name,"Chopper") == 0) + { + pChopper = (pChoco)pCom->pData; + } + } + } + if(!pChopper) + { + sprintf(pBueffel,"ERROR: %s is NO chopper controller", + argv[3]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + /* interpret limits */ + iRet = Tcl_GetDouble(pSics->pTcl,argv[5],&dUpper); + if(iRet != TCL_OK) + { + sprintf(pBueffel, + "ERROR: expected numeric argument for upper limit, got %s", + argv[4]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + iRet = Tcl_GetDouble(pSics->pTcl,argv[4],&dLower); + if(iRet != TCL_OK) + { + sprintf(pBueffel, + "ERROR: expected numeric argument for lower limit, got %s", + argv[5]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + /* allocate new adapter data structure */ + pNew = (pCHAdapter)malloc(sizeof(CHAdapter)); + if(!pNew) + { + SCWrite(pCon,"ERROR: out of memory in ChopperAdapter",eError); + return 0; + } + memset(pNew,0,sizeof(CHAdapter)); + + pNew->pDes = CreateDescriptor("ChopperAdapter"); + pNew->pDriv = CHGetDriver(pChopper); + pNew->pInt = CreateDrivableInterface(); + pNew->pParName = strdup(argv[3]); + if( !pNew->pDes || !pNew->pDriv || !pNew->pInt || !pNew->pParName) + { + SCWrite(pCon,"ERROR: out of memory in ChopperAdapter",eError); + return 0; + } + + /* initialize other fields */ + pNew->fTarget = 0.; + pNew->fLower = (float)dLower; + pNew->fUpper = (float)dUpper; + pNew->pDes->GetInterface = AdapterGetInterface; + pNew->pInt->Halt = CHHalt; + pNew->pInt->CheckLimits = CHLimits; + pNew->pInt->SetValue = CHSetValue; + pNew->pInt->CheckStatus = CHStatus; + pNew->pInt->GetValue = CHGetValue; + + /* install command */ + iRet = AddCommand(pSics, argv[1],CHAdapterAction,KillAdapter,pNew); + if(!iRet) + { + sprintf(pBueffel, + "ERROR: duplicate ChopperAdapter command %s NOT created", + argv[1]); + SCWrite(pCon,pBueffel,eError); + KillAdapter(pNew); + return 0; + } + return 1; + } +/*------------------------------------------------------------------------*/ + int CHAdapterAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + pCHAdapter self = NULL; + int iRet; + char pBueffel[132]; + float fValue; + + self = (pCHAdapter)pData; + assert(self); + + /* only action: get value */ + fValue = CHGetValue(self,pCon); + if(fValue < -99000) + { + return 0; + } + else + { + sprintf(pBueffel,"%s = %f",argv[0],fValue); + SCWrite(pCon,pBueffel,eValue); + } + + return 1; + } +/*========================================================================= + An environment driver based on top of a controller object. + -------------------------------------------------------------------------*/ + static int AVEVSetValue(pEVDriver self, float fNew) + { + pCHev myData; + + assert(self); + myData = (pCHev)self->pPrivate; + assert(myData); + myData->iLastError = 0; + + return myData->pDriv->SetPar(myData->pDriv,myData->pParName,fNew); + } +/*-----------------------------------------------------------------------*/ + static int AVEVGetValue(pEVDriver self, float *fNew) + { + pCHev myData; + int iRet; + char pBueffel[80]; + + assert(self); + myData = (pCHev)self->pPrivate; + assert(myData); + + iRet = myData->pDriv->GetPar(myData->pDriv,myData->pParName, + pBueffel,79); + sscanf(pBueffel,"%f",fNew); + return iRet; + } +/*-----------------------------------------------------------------------*/ + static int AVEVSend(pEVDriver self, char *pCommand, + char *pReply, int iLen) + { + pCHev myData; + + assert(self); + myData = (pCHev)self->pPrivate; + assert(myData); + myData->iLastError = NOTIMPLEMENTED; + + return 0; + } +/*-----------------------------------------------------------------------*/ + static int AVEVGetError(pEVDriver self, int *iCode, + char *pReply, int iLen) + { + pCHev myData; + + assert(self); + myData = (pCHev)self->pPrivate; + assert(myData); + + if(myData->iLastError == NOTIMPLEMENTED) + { + strncpy(pReply,"ERROR: Not Implemented here!", iLen); + *iCode = NOTIMPLEMENTED; + myData->iLastError = 0; + return 1; + } + else + { + return myData->pDriv->GetError(myData->pDriv, iCode, + pReply, iLen); + } + } +/*------------------------------------------------------------------------*/ + static int AVEVTryFixIt(pEVDriver self, int iCode) + { + pCHev myData; + + assert(self); + myData = (pCHev)self->pPrivate; + assert(myData); + + if(iCode == NOTIMPLEMENTED) + { + return DEVFAULT; + } + else + { + return myData->pDriv->TryFixIt(myData->pDriv, iCode); + } + } +/*---------------------------------------------------------------------*/ + static int AVEVInit(pEVDriver self) + { + pCHev myData; + + assert(self); + myData = (pCHev)self->pPrivate; + assert(myData); + + return myData->pDriv->Init(myData->pDriv); + } +/*---------------------------------------------------------------------*/ + static int AVEVClose(pEVDriver self) + { + pCHev myData; + + assert(self); + myData = (pCHev)self->pPrivate; + assert(myData); + + return myData->pDriv->Close(myData->pDriv); + } +/*----------------------------------------------------------------------*/ + static void AVEVKillPrivate(void *pData) + { + pCHev myData; + + if(pData != NULL) + { + myData = (pCHev)pData; + if(myData != NULL) + { + if(myData->pParName) + free(myData->pParName); + free(myData); + } + } + } +/*---------------------------------------------------------------------*/ + pEVDriver MakeControllerEnvironmentDriver(int argc, char *argv[]) + { + pEVDriver pNew = NULL; + pCHev myData = NULL; + CommandList *pCom = NULL; + pDummy pDum = NULL; + pChoco pChop; + + /* + Two arguments are needed: the name of the controller and the + name of the parameter + */ + if(argc < 2) + { + return NULL; + } + pCom = FindCommand(pServ->pSics,argv[0]); + if(!pCom) + { + return NULL; + } + pDum = pCom->pData; + if(!pDum) + { + return NULL; + } + if(strcmp(pDum->pDescriptor->name,"Chopper") != 0) + { + return NULL; + } + + /* alright: I think we got a controller now, let us create our + act + */ + pNew = CreateEVDriver(argc,argv); + if(!pNew) + { + return NULL; + } + myData = (pCHev)malloc(sizeof(CHev)); + if(!myData) + { + return NULL; + } + + pChop = (pChoco)pCom->pData; + myData->iLastError = 0; + myData->pDriv = pChop->pDriv; + myData->pParName = strdup(argv[1]); + pNew->pPrivate = myData; + pNew->SetValue =AVEVSetValue; + pNew->GetValue =AVEVGetValue; + pNew->Send = AVEVSend; + pNew->GetError =AVEVGetError; + pNew->TryFixIt =AVEVTryFixIt; + pNew->Init =AVEVInit; + pNew->Close =AVEVClose; + pNew->KillPrivate =AVEVKillPrivate; + + return pNew; + } + + + + + + + diff --git a/chadapter.h b/chadapter.h new file mode 100644 index 00000000..ec3319f8 --- /dev/null +++ b/chadapter.h @@ -0,0 +1,47 @@ + +/*------------------------------------------------------------------------ + C H a d a p t e r + + This is the header file for a drive adapter for collaboration with a + general device controller as implemented in choco.* + + Mark Koennecke, January 1998 +--------------------------------------------------------------------------*/ +#ifndef SICSCHADA +#define SICSCHADA +#include "codri.h" + + typedef struct __CHADAPTER *pCHAdapter; +/*-----------------------------------------------------------------------*/ + int CHAdapterFactory(SConnection *pCon, SicsInterp *pSics, + void *pData, + int argc, char *argv[]); + + int CHAdapterAction(SConnection *pCon, SicsInterp *pSics, + void *pData, + int argc, char *argv[]); + + pEVDriver MakeControllerEnvironmentDriver(int argc, char *argv[]); + + +#ifdef CHADAINTERNAL + + typedef struct __CHADAPTER { + pObjectDescriptor pDes; + pCodri pDriv; + pIDrivable pInt; + float fUpper; + float fLower; + float fTarget; + char *pParName; + }CHAdapter; + + + typedef struct __CHEV { + char *pParName; + pCodri pDriv; + int iLastError; + }CHev, *pCHev; + +#endif +#endif diff --git a/choco.c b/choco.c new file mode 100644 index 00000000..f8902f00 --- /dev/null +++ b/choco.c @@ -0,0 +1,311 @@ +/*------------------------------------------------------------------------ + C h o p p e r C o n t r o l l e r + + Implementation file for the SICS chopper controller and general controller + device. For details about this object and its relation with the SICS system + see choco.w or choco.tex. + + Mark Koennecke, January 1998 +-------------------------------------------------------------------------*/ +#include +#include +#include +#include "fortify.h" +#include "sics.h" +#define CHOCOINTERNAL +#include "choco.h" + + + +/*------------------------------------------------------------------------*/ + int CHGetParameter(pChoco self, char *parname, char *pParValue, + int iBuflen) + { + int iRet, iCode; + + assert(self); + + iRet = self->pDriv->GetPar(self->pDriv, parname, pParValue, + iBuflen); + if(!iRet) + { + iRet = 0; + self->pDriv->GetError(self->pDriv,&iCode,pParValue, iBuflen); + } + return iRet; + } +/*------------------------------------------------------------------------*/ + pCodri CHGetDriver(pChoco self) + { + assert(self); + + return self->pDriv; + } +/*------------------------------------------------------------------------*/ + int CHList(pChoco self, SConnection *pCon, char *name) + { + char *pPar, *pCopy = NULL; + char pValue[80]; + char pMessage[256]; + int iRet, iLen; + Tcl_DString tlist; + + assert(self); + + /* copy pParList as it will be destroyed by strtok */ + iLen = strlen(self->pDriv->pParList); + pCopy = (char *)malloc((iLen+10)*sizeof(char)); + if(!pCopy) + { + SCWrite(pCon,"ERROR: out of memory in CHList",eError); + return 0; + } + memset(pCopy,0,iLen+10); + strcpy(pCopy,self->pDriv->pParList); + Tcl_DStringInit(&tlist); + + pPar = strtok(pCopy,","); + while(pPar != NULL) + { + iRet = CHGetParameter(self,pPar,pValue,79); + if(iRet) + { + sprintf(pMessage,"%s.%s = %s \n",name,pPar,pValue); + } + else + { + sprintf(pMessage,"ERROR: %s : while reading parameter %s \n", + pValue,pPar); + } + Tcl_DStringAppend(&tlist, pMessage,-1); + pPar = strtok(NULL,","); + } + SCWrite(pCon,Tcl_DStringValue(&tlist),eValue); + Tcl_DStringFree(&tlist); + free(pCopy); + return 1; + } +/*-----------------------------------------------------------------------*/ + int ChocoAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + pChoco self = NULL; + char pValue[80], pMessage[256]; + int iRet; + + self = (pChoco)pData; + assert(self); + + if(argc < 2) + { + sprintf(pMessage, "ERROR: Ragument required for %s",argv[0]); + SCWrite(pCon,pMessage,eError); + return 0; + } + + /* argument can either be list or parameter name */ + strtolower(argv[1]); + if(strcmp(argv[1],"list") == 0) + { + return CHList(self,pCon,argv[0]); + } + else + { + if(argc > 2) + { + /* set case */ + iRet = self->pDriv->SetPar2(self->pDriv,argv[1],argv[2]); + if(!iRet) + { + self->pDriv->GetError(self->pDriv,&iRet,pValue,79); + sprintf(pMessage,"ERROR: %s",pValue); + SCWrite(pCon,pMessage,eError); + return 0; + } + else + { + SCSendOK(pCon); + return 1; + } + } + else + { + /* get case */ + iRet = CHGetParameter(self,argv[1],pValue,79); + if(iRet) + { + sprintf(pMessage,"%s.%s = %s",argv[0],argv[1],pValue); + } + else + { + sprintf(pMessage,"ERROR: %s : while reading parameter %s", + pValue,argv[1]); + } + SCWrite(pCon,pMessage,eValue); + return iRet; + } + } + return 0; + } +/*----------------------------------------------------------------------*/ + static void KillChoco(void *pData) + { + pChoco self = NULL; + + self = (pChoco)pData; + if(!self) + return; + + if(self->pDriv) + { + self->pDriv->Close(self->pDriv); + self->pDriv->Delete(self->pDriv); + if(self->pDriv->pParList) + free(self->pDriv->pParList); + free(self->pDriv); + } + if(self->pDes) + DeleteDescriptor(self->pDes); + + free(self); + } +/*----------------------------------------------------------------------- + DRIVERS +*/ + +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[]) + { + pChoco pNew = NULL; + pCodri pDriv = NULL; + pObjectDescriptor pDes = NULL; + char pBueffel[132]; + int iRet, iPort, iChannel; + int iSingle = 0; + + if(argc < 3) + { + SCWrite(pCon, + "ERROR: Insufficient number of arguments to MakeController", + eError); + return 0; + } + + + /* first try to get everything done */ + pNew = (pChoco)malloc(sizeof(Choco)); + pDes = CreateDescriptor("Chopper"); + /* do driver */ + strtolower(argv[2]); + if(strcmp(argv[2],"sim") == 0) + { + 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", + argv[2]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + if( (pNew == NULL) || (pDes == NULL) || (pDriv == NULL) ) + { + SCWrite(pCon,"ERROR: No memory left to create controller",eError); + return 0; + } + pNew->pDes = pDes; + pNew->pDriv = pDriv; + + /* initialize driver */ + iRet = pDriv->Init(pDriv); + if(!iRet) + { + SCWrite(pCon,"ERROR: Failed to initialize driver",eError); + KillChoco(pNew); + return 0; + } + + /* install as command */ + iRet = AddCommand(pSics, argv[1],ChocoAction,KillChoco,pNew); + if(!iRet) + { + sprintf(pBueffel,"ERROR: duplicate command %s NOT created", + argv[1]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + return 1; + } + + diff --git a/choco.h b/choco.h new file mode 100644 index 00000000..08be2342 --- /dev/null +++ b/choco.h @@ -0,0 +1,36 @@ + +/*----------------------------------------------------------------------- + C h o p p e r C o n t r o l l e r + + This is both the header file for a general controller and a SICS + chopper controller. + + Mark Koennecke, January 1998 +--------------------------------------------------------------------------*/ +#ifndef CHOCOSICS +#define CHOCOSICS +#include "codri.h" + + typedef struct __CHOCO *pChoco; +/*------------------------------------------------------------------------*/ + int CHGetParameter(pChoco self, char *pParName, + char *pParValue, int iBuflen); + + pCodri CHGetDriver(pChoco self); + int CHList(pChoco self, SConnection *pCon, char *name); +/*------------------------------------------------------------------------*/ + int ChocoAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int ChocoFactory(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + +#ifdef CHOCOINTERNAL + + typedef struct __CHOCO { + pObjectDescriptor pDes; + pCodri pDriv; + } Choco; + +#endif +#endif diff --git a/choco.tex b/choco.tex new file mode 100644 index 00000000..af1f8bbe --- /dev/null +++ b/choco.tex @@ -0,0 +1,380 @@ +\subsection{Chopper Controller} +Yet another way to deal with a controller has been devised for +SICS. This uses the concept of a general controller which can have +parameters enquired and set. Furthermore it may have parameters which +may be driven like a motor or environment controller through special +adapters . This scheme is +used for the chopper controller for FOCUS. +\begin{itemize} +\item A driver for a particular controller which allows to set and get +parameters. +\item The general controller object which holds things together. +\item An adapter object which allows to drive special parameters in a general +controller. Such adapter objects can be configured for each drivable parameter + in a controller. +\item An adapter to an environment controller driver. +\end{itemize} +The test case for this way of doing things is a controller for running +choppers. This is why it gets the name. + +The chopper system in question is the FOCUS chopper system. There are two +choppers, a fermi chopper and a disk chopper. This system can be run in two + different modes: In synchronous mode both choppers run at a +predefined ratio of speeds. For instance the fermi chopper is two +times faster then the disk chopper. This means, that setting a new +value for one chopper also changes the speed of the other chopper. In +asynchronous mode both choppers operate independently. Also the ration +to use for synchronous mode can be changed. Another parameter which +frequently changes is the phase of the two choppers. In order to +compensate for the fligh path between the two choppers there is a +small angular displacement of the choppers against each other which +varies with wavelength. + +\subsubsection{The Controller Driver} +The controller driver is represented by the following data structure: +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap1} +$\langle$codri {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ typedef struct __CODRI *pCodri;@\\ +\mbox{}\verb@ typedef struct __CODRI {@\\ +\mbox{}\verb@ int (*Init)(pCodri self);@\\ +\mbox{}\verb@ int (*Close)(pCodri self);@\\ +\mbox{}\verb@ int (*Delete)(pCodri self);@\\ +\mbox{}\verb@ int (*SetPar)(pCodri self, @\\ +\mbox{}\verb@ char *parname,@\\ +\mbox{}\verb@ float fValue);@\\ +\mbox{}\verb@ int (*SetPar2)(pCodri self, @\\ +\mbox{}\verb@ char *parname,@\\ +\mbox{}\verb@ char *value);@\\ +\mbox{}\verb@ int (*GetPar)(pCodri self,@\\ +\mbox{}\verb@ char *parname,@\\ +\mbox{}\verb@ char *pBuffer,@\\ +\mbox{}\verb@ int iBufLen);@\\ +\mbox{}\verb@ int (*CheckPar)(pCodri self, @\\ +\mbox{}\verb@ char *parname);@\\ +\mbox{}\verb@ int (*GetError)(pCodri self, int *iCode,@\\ +\mbox{}\verb@ char *pError, @\\ +\mbox{}\verb@ int iErrLen);@\\ +\mbox{}\verb@ int (*TryFixIt)(pCodri self, int iCode);@\\ +\mbox{}\verb@ int (*Halt)(pCodri self);@\\ +\mbox{}\verb@ char *pParList;@\\ +\mbox{}\verb@ void *pPrivate;@\\ +\mbox{}\verb@ }Codri;@\\ +\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} +All functions take a pointer to the controller driver itself as a +parameter. All functions except TryFixIt and CheckPar + return 0 on failure and 1 for success. +\begin{description} +\item[Init] initializes the controller driver. The parameters argc, +argv are main() style parameters for the initialization of the +controller driver. +\item[Close] closes the connection to the controller but does not delete a thing. +\item[Delete] closes the connection to the controller and deletes private data structures. Called when deleting the controller. +\item[SetPar] tries to set the parameter parname to the value +fValue. The last is floating point which covers the frequent +occurence of numeric values. +\item[SetPar2] The same as SetPar but uses test string as input for +parameter setting. +\item[GetPar] retrieves the parameter parname formatted as text. The +value is put into the buffer pBuffer. iBufLen is the maximum number of +bytes permissable for pBuffer. +\item[CheckPar] When parameters are driven a means is needed to find +out about the progress of operations and errors during the +operation. This is done by CheckPar for the parameter parname. The +return value of this function must be one of the HWBusy, HWError, +HWDone family documented in the motor driver object description. +\item[GetError] retrieves the last error. An integer error code is +placed into iCode and a textual description of the problem is written +to pError. Maximum iErrLen bytes are copied to pError. +\item[TryFixIt] tries to fix the error condition specified by iCode in +software if this possible. TryFisIt returns HWRedo if the last command +needs to resent, HWFault if the problem could not be fixed and HWOK if +the error can be ignored or was fully resolved. +\item[pParList] is text string containing a comma separated list of +all parameters understood by this driver. +\item[pPrivate] Is a pointer to a driver specific specific data +structure. This data structure will not be messed with by upper level code. +\end{description} + +\subsubsection{The Controller Object} +This is the general controller object visible from the SICS +interpreter. This object allows to list all possible +parameters. Internal functions are provided for setting +parameters. But this is meant to be operated through a drive adapter +object (see below) in SICS. Thus the interface to this object +includes: +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap2} +$\langle$chocoint {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ typedef struct __CHOCO *pChoco;@\\ +\mbox{}\verb@/*------------------------------------------------------------------------*/@\\ +\mbox{}\verb@ int CHGetParameter(pChoco self, char *pParName, @\\ +\mbox{}\verb@ char *pParValue, int iBuflen); @\\ +\mbox{}\verb@ @\\ +\mbox{}\verb@ pCodri CHGetDriver(pChoco self);@\\ +\mbox{}\verb@ int CHList(pChoco self, SConnection *pCon, char *name);@\\ +\mbox{}\verb@/*------------------------------------------------------------------------*/@\\ +\mbox{}\verb@ int ChocoAction(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ +\mbox{}\verb@ int argc, char *argv[]);@\\ +\mbox{}\verb@ int ChocoFactory(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{description} +\item[CHGetParameter] retrieves the value of the parameter ParName +converted to text. Maximum iBufLen of result or error text are copied into the +buffer pParvalue. +\item[CHGetDriver] returns a pointer to the controller driver. This +function will be used by the drive adapters for interfacing with the +driver directly. +\item[CHList] prints a listing of all parameters to the client +described by pCon. name is the name of the controller. +\item[ChocoAction] is the SICS interpreter interface function for the +controller. +\item[ChocoFactory] is the SICS interpreter interface function which +installs a controller into SICS. +\end{description} + +Most of the actual work of the controller is left to the driver. Thus +the internal data structure for a controller object is very simple: +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap3} +$\langle$chocodata {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ typedef struct __CHOCO {@\\ +\mbox{}\verb@ pObjectDescriptor pDes;@\\ +\mbox{}\verb@ pCodri pDriv;@\\ +\mbox{}\verb@ } Choco;@\\ +\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} +It consists just of the standard SICS object descriptor and a pointer +to the driver. + +\subsubsection{The Drive And Environment Adapters} +Most of the work of the drive adaptor is hidden in the functions +implementing the drivable interface. Thus the interface to the +DriveAdapter is fairly simple: +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap4} +$\langle$adapter {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ typedef struct __CHADAPTER *pCHAdapter;@\\ +\mbox{}\verb@/*-----------------------------------------------------------------------*/@\\ +\mbox{}\verb@ int CHAdapterFactory(SConnection *pCon, SicsInterp *pSics, @\\ +\mbox{}\verb@ void *pData,@\\ +\mbox{}\verb@ int argc, char *argv[]);@\\ +\mbox{}\verb@ @\\ +\mbox{}\verb@ int CHAdapterAction(SConnection *pCon, SicsInterp *pSics, @\\ +\mbox{}\verb@ void *pData,@\\ +\mbox{}\verb@ int argc, char *argv[]);@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ pEVDriver MakeControllerEnvironmentDriver(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{description} +\item[CHAdapterFactory] is the SICS interpreter factory function for +creating a drive adapter. +\item[CHAdapterAction] is the SICS interpreter function for +representing the object in SICS. Just a single action is supported: +request the value of the parameter. +\item[MakeControllerEnvironmentDriver] creates an environment control +driver for a parameter in a general controller object. +\end{description} + +The data structure for the drive adapter is slightly more interesting: +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap5} +$\langle$adadata {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ typedef struct __CHADAPTER {@\\ +\mbox{}\verb@ pObjectDescriptor pDes;@\\ +\mbox{}\verb@ pCodri pDriv;@\\ +\mbox{}\verb@ pIDrivable pInt;@\\ +\mbox{}\verb@ float fUpper;@\\ +\mbox{}\verb@ float fLower;@\\ +\mbox{}\verb@ float fTarget;@\\ +\mbox{}\verb@ char *pParName;@\\ +\mbox{}\verb@ }CHAdapter;@\\ +\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] is the standard object descriptor. +\item[pDriv] is a pointer to the controller driver. +\item[pInt] is a pointer to the drivable interface implemented by the + adapter. +\item[fUpper] upper limit for the parameter. +\item[fLower] lower limit for the parameter. +\item[pParName] is the name of the parameter which is driven through +this adapter. +\end{description} + +This is the data structure for the private part of the environment +controller driver: +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap6} +$\langle$evada {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ typedef struct __CHEV {@\\ +\mbox{}\verb@ char *pParName;@\\ +\mbox{}\verb@ pCodri pDriv;@\\ +\mbox{}\verb@ int iLastError;@\\ +\mbox{}\verb@ }CHev, *pCHev;@\\ +\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{scrap7} +\verb@"codri.h"@ {\footnotesize ? }$\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@/*-------------------------------------------------------------------------@\\ +\mbox{}\verb@ C o n t r o l l e r D r i v e r@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ This file contains the description of the data structure for a@\\ +\mbox{}\verb@ general controller driver.@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ Mark Koennecke, January 1998@\\ +\mbox{}\verb@--------------------------------------------------------------------------*/@\\ +\mbox{}\verb@#ifndef CODRIV@\\ +\mbox{}\verb@#define CODRIV@\\ +\mbox{}\verb@#define CHFAIL -1@\\ +\mbox{}\verb@#define CHREDO -2@\\ +\mbox{}\verb@#define CHOK -3@\\ +\mbox{}\verb@@$\langle$codri {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@#endif@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@@$\diamond$ +\end{list} +\vspace{-2ex} +\end{minipage}\\[4ex] +\end{flushleft} +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap8} +\verb@"choco.h"@ {\footnotesize ? }$\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@/*-----------------------------------------------------------------------@\\ +\mbox{}\verb@ C h o p p e r C o n t r o l l e r@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ This is both the header file for a general controller and a SICS@\\ +\mbox{}\verb@ chopper controller.@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ Mark Koennecke, January 1998@\\ +\mbox{}\verb@--------------------------------------------------------------------------*/@\\ +\mbox{}\verb@#ifndef CHOCOSICS@\\ +\mbox{}\verb@#define CHOCOSICS@\\ +\mbox{}\verb@#include "codri.h"@\\ +\mbox{}\verb@@$\langle$chocoint {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@#ifdef CHOCOINTERNAL@\\ +\mbox{}\verb@@$\langle$chocodata {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@#endif@\\ +\mbox{}\verb@#endif @\\ +\mbox{}\verb@@$\diamond$ +\end{list} +\vspace{-2ex} +\end{minipage}\\[4ex] +\end{flushleft} +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap9} +\verb@"chadapter.h"@ {\footnotesize ? }$\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@/*------------------------------------------------------------------------@\\ +\mbox{}\verb@ C H a d a p t e r@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ This is the header file for a drive adapter for collaboration with a@\\ +\mbox{}\verb@ general device controller as implemented in choco.*@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ Mark Koennecke, January 1998@\\ +\mbox{}\verb@--------------------------------------------------------------------------*/@\\ +\mbox{}\verb@#ifndef SICSCHADA@\\ +\mbox{}\verb@#define SICSCHADA@\\ +\mbox{}\verb@#include "codri.h"@\\ +\mbox{}\verb@@$\langle$adapter {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@#ifdef CHADAINTERNAL@\\ +\mbox{}\verb@@$\langle$adadata {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@@$\langle$evada {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@#endif@\\ +\mbox{}\verb@#endif@\\ +\mbox{}\verb@@$\diamond$ +\end{list} +\vspace{-2ex} +\end{minipage}\\[4ex] +\end{flushleft} +\subsubsection{To Do} +This scheme seems to be quite promising for handling many SICS +objects. The following enhancements could be considered. Allow to set +certain primitive parameters without a drivable interface. And add an +adapter for an environment variable in the controller. + + + + + + + + + + diff --git a/choco.w b/choco.w new file mode 100644 index 00000000..10b6be55 --- /dev/null +++ b/choco.w @@ -0,0 +1,281 @@ +\subsection{Chopper Controller} +Yet another way to deal with a controller has been devised for +SICS. This uses the concept of a general controller which can have +parameters enquired and set. Furthermore it may have parameters which +may be driven like a motor or environment controller through special +adapters . This scheme is +used for the chopper controller for FOCUS. +\begin{itemize} +\item A driver for a particular controller which allows to set and get +parameters. +\item The general controller object which holds things together. +\item An adapter object which allows to drive special parameters in a general +controller. Such adapter objects can be configured for each drivable parameter + in a controller. +\item An adapter to an environment controller driver. +\end{itemize} +The test case for this way of doing things is a controller for running +choppers. This is why it gets the name. + +The chopper system in question is the FOCUS chopper system. There are two +choppers, a fermi chopper and a disk chopper. This system can be run in two + different modes: In synchronous mode both choppers run at a +predefined ratio of speeds. For instance the fermi chopper is two +times faster then the disk chopper. This means, that setting a new +value for one chopper also changes the speed of the other chopper. In +asynchronous mode both choppers operate independently. Also the ration +to use for synchronous mode can be changed. Another parameter which +frequently changes is the phase of the two choppers. In order to +compensate for the fligh path between the two choppers there is a +small angular displacement of the choppers against each other which +varies with wavelength. + +\subsubsection{The Controller Driver} +The controller driver is represented by the following data structure: +@d codri @{ + typedef struct __CODRI *pCodri; + typedef struct __CODRI { + int (*Init)(pCodri self); + int (*Close)(pCodri self); + int (*Delete)(pCodri self); + int (*SetPar)(pCodri self, + char *parname, + float fValue); + int (*SetPar2)(pCodri self, + char *parname, + char *value); + int (*GetPar)(pCodri self, + char *parname, + char *pBuffer, + int iBufLen); + int (*CheckPar)(pCodri self, + char *parname); + int (*GetError)(pCodri self, int *iCode, + char *pError, + int iErrLen); + int (*TryFixIt)(pCodri self, int iCode); + int (*Halt)(pCodri self); + char *pParList; + void *pPrivate; + }Codri; + +@} +All functions take a pointer to the controller driver itself as a +parameter. All functions except TryFixIt and CheckPar + return 0 on failure and 1 for success. +\begin{description} +\item[Init] initializes the controller driver. The parameters argc, +argv are main() style parameters for the initialization of the +controller driver. +\item[Close] closes the connection to the controller but does not delete a thing. +\item[Delete] closes the connection to the controller and deletes private data structures. Called when deleting the controller. +\item[SetPar] tries to set the parameter parname to the value +fValue. The last is floating point which covers the frequent +occurence of numeric values. +\item[SetPar2] The same as SetPar but uses test string as input for +parameter setting. +\item[GetPar] retrieves the parameter parname formatted as text. The +value is put into the buffer pBuffer. iBufLen is the maximum number of +bytes permissable for pBuffer. +\item[CheckPar] When parameters are driven a means is needed to find +out about the progress of operations and errors during the +operation. This is done by CheckPar for the parameter parname. The +return value of this function must be one of the HWBusy, HWError, +HWDone family documented in the motor driver object description. +\item[GetError] retrieves the last error. An integer error code is +placed into iCode and a textual description of the problem is written +to pError. Maximum iErrLen bytes are copied to pError. +\item[TryFixIt] tries to fix the error condition specified by iCode in +software if this possible. TryFisIt returns HWRedo if the last command +needs to resent, HWFault if the problem could not be fixed and HWOK if +the error can be ignored or was fully resolved. +\item[pParList] is text string containing a comma separated list of +all parameters understood by this driver. +\item[pPrivate] Is a pointer to a driver specific specific data +structure. This data structure shall not be messed with by upper level code. +\end{description} + +\subsubsection{The Controller Object} +This is the general controller object visible from the SICS +interpreter. This object allows to list all possible +parameters. Internal functions are provided for setting +parameters. But this is meant to be operated through a drive adapter +object (see below) in SICS. Thus the interface to this object +includes: +@d chocoint @{ + typedef struct __CHOCO *pChoco; +/*------------------------------------------------------------------------*/ + int CHGetParameter(pChoco self, char *pParName, + char *pParValue, int iBuflen); + + pCodri CHGetDriver(pChoco self); + int CHList(pChoco self, SConnection *pCon, char *name); +/*------------------------------------------------------------------------*/ + int ChocoAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int ChocoFactory(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + +@} +\begin{description} +\item[CHGetParameter] retrieves the value of the parameter ParName +converted to text. Maximum iBufLen of result or error text are copied into the +buffer pParvalue. +\item[CHGetDriver] returns a pointer to the controller driver. This +function will be used by the drive adapters for interfacing with the +driver directly. +\item[CHList] prints a listing of all parameters to the client +described by pCon. name is the name of the controller. +\item[ChocoAction] is the SICS interpreter interface function for the +controller. +\item[ChocoFactory] is the SICS interpreter interface function which +installs a controller into SICS. +\end{description} + +Most of the actual work of the controller is left to the driver. Thus +the internal data structure for a controller object is very simple: +@d chocodata @{ + typedef struct __CHOCO { + pObjectDescriptor pDes; + pCodri pDriv; + } Choco; +@} +It consists just of the standard SICS object descriptor and a pointer +to the driver. + +\subsubsection{The Drive And Environment Adapters} +Most of the work of the drive adaptor is hidden in the functions +implementing the drivable interface. Thus the interface to the +DriveAdapter is fairly simple: +@d adapter @{ + typedef struct __CHADAPTER *pCHAdapter; +/*-----------------------------------------------------------------------*/ + int CHAdapterFactory(SConnection *pCon, SicsInterp *pSics, + void *pData, + int argc, char *argv[]); + + int CHAdapterAction(SConnection *pCon, SicsInterp *pSics, + void *pData, + int argc, char *argv[]); + + pEVDriver MakeControllerEnvironmentDriver(int argc, char *argv[]); + +@} +\begin{description} +\item[CHAdapterFactory] is the SICS interpreter factory function for +creating a drive adapter. +\item[CHAdapterAction] is the SICS interpreter function for +representing the object in SICS. Just a single action is supported: +request the value of the parameter. +\item[MakeControllerEnvironmentDriver] creates an environment control +driver for a parameter in a general controller object. +\end{description} + +The data structure for the drive adapter is slightly more interesting: +@d adadata @{ + typedef struct __CHADAPTER { + pObjectDescriptor pDes; + pCodri pDriv; + pIDrivable pInt; + float fUpper; + float fLower; + float fTarget; + char *pParName; + }CHAdapter; +@} +\begin{description} +\item[pDes] is the standard object descriptor. +\item[pDriv] is a pointer to the controller driver. +\item[pInt] is a pointer to the drivable interface implemented by the + adapter. +\item[fUpper] upper limit for the parameter. +\item[fLower] lower limit for the parameter. +\item[pParName] is the name of the parameter which is driven through +this adapter. +\end{description} + +This is the data structure for the private part of the environment +controller driver: +@d evada @{ + typedef struct __CHEV { + char *pParName; + pCodri pDriv; + int iLastError; + }CHev, *pCHev; +@} + +@o codri.h @{ +/*------------------------------------------------------------------------- + C o n t r o l l e r D r i v e r + + This file contains the description of the data structure for a + general controller driver. + + Mark Koennecke, January 1998 +--------------------------------------------------------------------------*/ +#ifndef CODRIV +#define CODRIV +#define CHFAIL -1 +#define CHREDO -2 +#define CHOK -3 +@ +#endif + +@} + +@o choco.h @{ +/*----------------------------------------------------------------------- + C h o p p e r C o n t r o l l e r + + This is both the header file for a general controller and a SICS + chopper controller. + + Mark Koennecke, January 1998 +--------------------------------------------------------------------------*/ +#ifndef CHOCOSICS +#define CHOCOSICS +#include "codri.h" +@ +#ifdef CHOCOINTERNAL +@ +#endif +#endif +@} + + +@o chadapter.h @{ +/*------------------------------------------------------------------------ + C H a d a p t e r + + This is the header file for a drive adapter for collaboration with a + general device controller as implemented in choco.* + + Mark Koennecke, January 1998 +--------------------------------------------------------------------------*/ +#ifndef SICSCHADA +#define SICSCHADA +#include "codri.h" +@ +#ifdef CHADAINTERNAL +@ +@ +#endif +#endif +@} + + +\subsubsection{To Do} +This scheme seems to be quite promising for handling many SICS +objects. The following enhancements could be considered. Allow to set +certain primitive parameters without a drivable interface. And add an +adapter for an environment variable in the controller. + + + + + + + + + + diff --git a/circular.c b/circular.c new file mode 100644 index 00000000..5a855a66 --- /dev/null +++ b/circular.c @@ -0,0 +1,122 @@ +/*----------------------------------------------------------------------- + Implementation file for a circular buffer facility. + + Mark Koennecke, October 1999 +-------------------------------------------------------------------------*/ +#include +#include +#include "fortify.h" +#include "circular.h" + +/*======================================================================== + Definitions of Structures +*/ + + typedef struct __CircularItem { + void *pData; + struct __CircularItem *next; + struct __CircularItem *previous; + }CircularItem, *pCircularItem; + + + typedef struct __CIRCULAR { + pCircularItem pPointer; + CirKillFunc killer; + }Circular; + +/*========================================================================= + Functions for Birth and Death +*/ + pCircular createCircular(int iSize, CirKillFunc kf) + { + pCircular pNew = NULL; + pCircularItem pItem = NULL, pFirst = NULL; + int i; + + + assert(iSize > 0); + + /* create data structure */ + pNew = (pCircular)malloc(sizeof(Circular)); + if(!pNew) + return NULL; + memset(pNew,0,sizeof(Circular)); + + /* create all the members of the circular buffer */ + pItem = (pCircularItem)malloc(sizeof(CircularItem)); + if(!pItem) + return NULL; + memset(pItem,0,sizeof(CircularItem)); + pNew->pPointer = pItem; + pFirst = pItem; + for(i = 1; i < iSize; i++) + { + pItem = (pCircularItem)malloc(sizeof(CircularItem)); + if(!pItem) + return NULL; + memset(pItem,0,sizeof(CircularItem)); + pItem->previous = pNew->pPointer; + pNew->pPointer->next = pItem; + pNew->pPointer = pItem; + } + pItem->next = pFirst; + pFirst->previous = pItem; + pNew->killer = kf; + return pNew; + } +/*---------------------------------------------------------------------*/ + void deleteCircular(pCircular self) + { + pCircularItem pNext = NULL, pCurrent = NULL; + + assert(self); + + self->pPointer->previous->next = NULL; + pNext = self->pPointer; + while(pNext != NULL) + { + pCurrent = pNext; + pNext = pCurrent->next; + if(pCurrent->pData && self->killer) + { + self->killer(pCurrent->pData); + } + free(pCurrent); + } + free(self); + } +/*======================================================================== + Data Manipulation functions +*/ + void setCircular(pCircular self, void *pData) + { + assert(self); + + /* delete if present */ + if(self->pPointer->pData && self->killer) + { + self->killer(self->pPointer->pData); + } + self->pPointer->pData = pData; + } +/*----------------------------------------------------------------------*/ + void *getCircular(pCircular self) + { + assert(self); + return self->pPointer->pData; + } +/*======================================================================== + Pointer movement +*/ + void nextCircular(pCircular self) + { + assert(self); + self->pPointer = self->pPointer->next; + } +/*---------------------------------------------------------------------*/ + void previousCircular(pCircular self) + { + assert(self); + self->pPointer = self->pPointer->previous; + } + diff --git a/circular.h b/circular.h new file mode 100644 index 00000000..b4bdac3b --- /dev/null +++ b/circular.h @@ -0,0 +1,31 @@ +/*-------------------------------------------------------------------------- + C I R C U L A R + + This is the implementation of a general purpose circular buffer facility. + + Mark Koennecke, October 1999 + --------------------------------------------------------------------------*/ +#ifndef CIRCULAR +#define CIRCULAR + + typedef struct __CIRCULAR *pCircular; + typedef void (*CirKillFunc)(void *pData); + +/* ----------------- birth and death -----------------------------------*/ + pCircular createCircular(int iSize,CirKillFunc kf); + /* + iSize is the size of the circular Buffer. + KillFunc is a function which can safely delete the data item held + as content of the circular buffer. + */ + void deleteCircular(pCircular self); + +/*-------------- access and modify data item at current position ----------*/ + void setCircular(pCircular self, void *pData); + void *getCircular(pCircular self); + +/*---------------- pointer movement --------------------------------------*/ + void nextCircular(pCircular self); + void previousCircular(pCircular self); + +#endif diff --git a/codri.h b/codri.h new file mode 100644 index 00000000..a44f1e0e --- /dev/null +++ b/codri.h @@ -0,0 +1,44 @@ + +/*------------------------------------------------------------------------- + C o n t r o l l e r D r i v e r + + This file contains the description of the data structure for a + general controller driver. + + Mark Koennecke, January 1998 +--------------------------------------------------------------------------*/ +#ifndef CODRIV +#define CODRIV +#define CHFAIL -1 +#define CHREDO -2 +#define CHOK -3 + + typedef struct __CODRI *pCodri; + typedef struct __CODRI { + int (*Init)(pCodri self); + int (*Close)(pCodri self); + int (*Delete)(pCodri self); + int (*SetPar)(pCodri self, + char *parname, + float fValue); + int (*SetPar2)(pCodri self, + char *parname, + char *value); + int (*GetPar)(pCodri self, + char *parname, + char *pBuffer, + int iBufLen); + int (*CheckPar)(pCodri self, + char *parname); + int (*GetError)(pCodri self, int *iCode, + char *pError, + int iErrLen); + int (*TryFixIt)(pCodri self, int iCode); + int (*Halt)(pCodri self); + char *pParList; + void *pPrivate; + }Codri; + + +#endif + diff --git a/coll.tcl b/coll.tcl new file mode 100644 index 00000000..bd6b53bc --- /dev/null +++ b/coll.tcl @@ -0,0 +1,229 @@ +#---------------------------------------------------------------------------- +# This file implements the collimator commands for SANS. It requires an +# SPS named sps2 within SICS. +# +# Mark Koennecke, March 1999 +#---------------------------------------------------------------------------- +proc coll args { +#-------- set case + if { [llength $args] > 0 ] } { + set length [lindex $args 0] + switch $length { + 18 { + set command "sps2 push 200 0" + break + } + 15 { + set command "sps2 push 200 1" + break + } + 11 { + set command "sps2 push 200 2" + break + } + 8 { + set command "sps2 push 200 3" + break + } + 6 { + set command "sps2 push 200 4" + break + } + 4.5 { + set command "sps2 push 200 5" + break + } + 3 { + set command "sps2 push 200 6" + break + } + 2 { + set command "sps2 push 200 7" + break + } + 1.4 { + set command "sps2 push 201 0" + break + } + 1 { + set command "sps2 push 201 1" + break + } + default { + append text \ + [format "ERROR: collimation length %s invalid\n" $length] + append text "Possible length are: 18,15,11,8,6,4.5,3,2,1.4,1\n" + append text \ + "Extraneous . or other characters will yield this error too\n" + append text "SPS programming courtesy Enzo Manfrin\n" + return $text + } +#------- command has been built, execute it! + set ret [catch {$command} msg] + if {$ret != 0} { + error $msg + } + setstatus Driving +#------- wait till finish, check for interrupts on the way + set exe 1 + while {$exe} { + set ret [catch {sps2 colli} msg] + if {$ret != 0 } { + setstatus Eager + error $msg + } + set l [split $msg =] + set cval [lindex $l 1] + if { [expr $cval - $length] < 0.2 } { + set exe 0 + } + set rupt [getint] + if {[string compare $rupt continue] != 0 } { + setstatus Eager + error "ERROR: driving collimator interrupted" + } + } + setstatus Eager + return OK + } else { +#-------- get case + set ret [catch {sps2 colli} msg] + if {$ret != 0} { + error $msg + } + return $msg + } +} +#-------------------------------------------------------------------------- +# Another procedure for handling the attenuator. +# +# Mark Koennecke, March 1999 +#-------------------------------------------------------------------------- +proc findatt { } { +#----------- find the current attenuator + set ret [catch {sps2 stat2 9 5} msg] + if { $ret != 0 } { + error $msg + } + set l [split $msg =] + if { [lindex $l 1] == 1} { + return 0 + } + set ret [catch {sps2 stat2 9 6} msg] + if { $ret != 0 } { + error $msg + } + set l [split $msg =] + if { [lindex $l 1] == 1} { + return 1 + } + set ret [catch {sps2 stat2 9 7} msg] + if { $ret != 0 } { + error $msg + } + set l [split $msg =] + if { [lindex $l 1] == 1} { + return 2 + } + set ret [catch {sps2 stat2 10 0} msg] + if { $ret != 0 } { + error $msg + } + set l [split $msg =] + if { [lindex $l 1] == 1} { + return 3 + } + set ret [catch {sps2 stat2 10 1} msg] + if { $ret != 0 } { + error $msg + } + set l [split $msg =] + if { [lindex $l 1] == 1} { + return 4 + } + set ret [catch {sps2 stat2 10 2} msg] + if { $ret != 0 } { + error $msg + } + set l [split $msg =] + if { [lindex $l 1] == 1} { + return 5 + } +} +#-------------------------------------------------------------------------- +proc att args { + if [ llength $args] > 0} { +#------- set case + set aat [lindex $args 0] + switch $aat { + 0 { + set command "sps2 push 210 7" + break + } + 1 { + set command "sps2 push 220 0" + break + } + 2 { + set command "sps2 push 220 1" + break + } + 3 { + set command "sps2 push 230 0" + break + } + 4 { + set command "sps2 push 230 1" + break + } + 5 { + set command "sps2 push 230 2" + break + } + default { + error [format "ERROR: attenuator %s unknown" $aat] + } + } +#-----send command + set ret [catch {$command} msg] + if {$ret != 0} { + error $msg + } +#------ wait till done + setstatus Driving + set exe 1 + while {$exe} { + set ret [catch {findatt} msg] + if {$ret != 0 } { + setstatus Eager + error $msg + } + if { [expr $msg - $aat] < 0.2 } { + set exe 0 + } + set rupt [getint] + if {[string compare $rupt continue] != 0 } { + setstatus Eager + error "ERROR: driving attenuator interrupted" + } + } + setstatus Eager + return OK + } else { +#----------- get case + set ret [catch {findatt} msg] + if {$ret != 0 } { + error $msg + } else { + return [format "att = %s" $msg] + } + } +} + + + + + + + + diff --git a/collidertest.tcl b/collidertest.tcl new file mode 100644 index 00000000..8eaa0aec --- /dev/null +++ b/collidertest.tcl @@ -0,0 +1,79 @@ +#-------------------------------------------------------------------------- +# test and example script for the anticollider +# +# Mark Koennecke, August 2002 +#------------------------------------------------------------------------ + +proc testlimits tg { + upvar $tg targets + if { abs( $targets(om) - $targets(stt)) < 30 } { + error "!!!!! two theta - omega CRASH!!!!!!!" + } + if {$targets(chi) > 190.} { + error "chi upperlimit crashed" + } + if { $targets(om) > -90 && $targets(om) <= -81.5 && $targets(chi) < 152} { + error "!!!!!! chi - omega CRASH aborted !!!!!" + } + if { $targets(om) > -81.5 && $targets(om) <= -55 && $targets(chi) < 137} { + error "!!!!!! chi - omega CRASH aborted !!!!!" + } + if { $targets(om) > -55 && $targets(om) <= -52 && $targets(chi) < 132} { + error "!!!!!! chi - omega CRASH aborted !!!!!" + } + if { $targets(om) > -52 && $targets(om) <= -30 && $targets(chi) < 75} { + error "!!!!!! chi - omega CRASH aborted !!!!!" + } + return +} +#------------------------------------------------------------------------- +proc chiFirst? tg { + upvar $tg targets + set om [SplitReply [om]] + set chi [SplitReply [chi]] + if {$chi < $targets(chi) } { + return 1 + } else { + return 0 + } +} +#--------------------------------------------------------------------------- +proc collidertest args { +#----------- read command line targets + set entries [expr [llength $args] / 2] + for {set i 0} {$i < $entries} {incr i} { + set ind [expr $i * 2] + set targets([lindex $args $ind]) [lindex $args [expr $ind +1]] + } +#--------- check if all motors are there. If not get targets from +# current position + if { [info exists targets(om)] == 0} { + set targets(om) [SplitReply [om]] + } + if { [info exists targets(stt)] == 0} { + set targets(stt) [SplitReply [stt]] + } + if { [info exists targets(chi)] == 0} { + set targets(chi) [SplitReply [chi]] + } + if { [info exists targets(phi)] == 0} { + set targets(phi) [SplitReply [phi]] + } +#---------- proceed to real collision detection hydraulics +# first: test complex limits + set ret [catch {testlimits targets} msg] + if {$ret != 0} { + clientput [format "ERROR %s" $msg] + error $msg + } + anticollision add 1 stt $targets(stt) + + if { [chiFirst? targets] == 1} { + anticollision add 2 chi $targets(chi) + anticollision add 3 om $targets(om) + } else { + anticollision add 2 om $targets(om) + anticollision add 3 chi $targets(chi) + } + anticollision add 3 phi $targets(phi) +} diff --git a/comentry.h b/comentry.h new file mode 100644 index 00000000..1aebd28a --- /dev/null +++ b/comentry.h @@ -0,0 +1,54 @@ +/*--------------------------------------------------------------------------- + + C O M E N T R Y + + some helper stuff for implementing MultiMotors. Functions in mumo.c + + Mark Koennecke, February 1997 +---------------------------------------------------------------------------*/ +#ifndef COMENTRY +#define COMENTRY + +#define MAXDEV 10 + typedef struct { + void *pData; + char name[80]; + pObjectDescriptor pDescriptor; + float fVal; + int iCount; + } DevEntry; + +/* -------------------The Entry per registered command --------------------*/ + typedef struct __ComEntry { + char name[10]; + char *pCommand; + int iDevice; + DevEntry pDevice[MAXDEV]; + struct __ComEntry *pNext; + struct __ComEntry *pPrevious; + }ComEntry, *pComEntry; + + typedef struct __NAMPOS { + char *name; /* the name */ + pComEntry pCom; /* the positions */ + char *text; /* explanatory text */ + struct __NAMPOS *pNext; + struct __NAMPOS *pPrevious; + } NamPos, *pNamPos; + + typedef struct __NAMMAP { + char *alias; + char *motname; + pMotor pMot; + } NamMap, *pNamMap; + + int CheckComEntryBounds(pComEntry self, SConnection *pCon); + int AddExeEntry(pExeList self, pComEntry pNew, SConnection *pCon); + pComEntry CreateComEntry(void); + pComEntry CopyComEntry(pComEntry pOld); + int AddDevEntry(pComEntry pCom, char *name, void *pData, pObjectDescriptor pDes, + float fVal); + pNamPos LinkNamPos(pNamPos pHead, pNamPos pNew); + pNamPos UnlinkNamPos(pNamPos pHead, pNamPos pOld); +#endif + diff --git a/commandlog.c b/commandlog.c new file mode 100644 index 00000000..4135c737 --- /dev/null +++ b/commandlog.c @@ -0,0 +1,476 @@ +/*-------------------------------------------------------------------------- + C O M M A N D L O G + + A much requested facility for writing only user and manager level commands + in a transcript file. This is it. + + Mark Koennecke, June 1998 + + Extended to support Heinz Heers autolog-file + Mark Koennecke, April-May 1999 + + Added a tail facility + Mark Koennecke, October 1999 +--------------------------------------------------------------------------*/ +#include +#include +#include +#include +#include +#include "sics.h" +#include "ifile.h" +#include "sicsvar.h" +#include "scaldate.h" +#include "network.h" +#include "circular.h" + + +/* in conman.c */ + int TelnetWrite(mkChannel *pSock, char *pText); + + +/*-------------------- the command log file pointer ---------------------*/ + static FILE *fd = NULL; + static FILE *fauto = NULL; + static char pFile[256]; +/*-------------------- the tail buffer ---------------------------------*/ + static pCircular pTail = NULL; +#define MAXTAIL 1000 +/*----------------------------------------------------------------------*/ + void WriteToCommandLog(char *prompt,char *text) + { + int iNL = 0, iPos; + char *pPtr = NULL, *pCopy = NULL, *pText = NULL; + char myBuffer[1024]; + + /* + we change the text, so we need to make a local copy. A copy + is dynamically allocated only if it does not fit into + myBuffer. + */ + if(strlen(text) > 1023){ + pCopy = (char *)malloc((strlen(text)+2)*sizeof(char)); + if(pCopy == NULL){ + return; + } + memset(pCopy,0,(strlen(text)+2)*sizeof(char)); + strcpy(pCopy,text); + pText = pCopy; + } else { + strcpy(myBuffer,text); + pText = myBuffer; + } + + /* figure out if we have to do a newline with pText as well */ + pPtr = strrchr(pText,'\n'); + if(pPtr != NULL) + { + iPos = pPtr - pText; + if(iPos >= (strlen(pText) - 2) ) + { + iNL = 1; + } + } + + /* supress status messages */ + if(strstr(pText,"status =") != NULL) + { + if(pCopy != NULL){ + free(pCopy); + } + return; + } + + /* suppress TRANSACTIONFINISHED as well in order to make the WWW + commandlog work + */ + if(strstr(pText,"TRANSACTIONFINISHED") != NULL) + { + if(pCopy != NULL){ + free(pCopy); + } + return; + } + + /* create tail buffer as needed */ + if(!pTail) + { + pTail = createCircular(MAXTAIL,free); + } + + /* user file */ + if(fd != NULL) + { + if(iNL) + { + fprintf(fd,"%s %s",prompt, pText); + } + else + { + fprintf(fd,"%s %s\n",prompt, pText); + } + } + /* automatic file */ + if(fauto != NULL) + { + if(iNL) + { + fprintf(fauto,"%s %s",prompt, pText); + } + else + { + fprintf(fauto,"%s %s\n",prompt, pText); + } + } + /* tail buffer */ + if(pTail != NULL) + { + if(iNL) + { + pPtr = strrchr(pText,'\n'); + *pPtr = ' '; + } + setCircular(pTail,strdup(pText)); + nextCircular(pTail); + } + if(pCopy != NULL){ + free(pCopy); + } + } +/*------------------------------------------------------------------------*/ + static void PrintTail(int iNum, SConnection *pCon) + { + char *pPtr = NULL; + int i; + + if(pTail == NULL) + { + SCWrite(pCon,"Nothing to print",eError); + return; + } + + /* step back */ + for(i = 0; i < iNum; i++) + { + previousCircular(pTail); + } + + /* now step ahead and print. I have to use a trick here: I do not + want the tail stuff to show up in log files. Thus I write it + directly to the connection socket. + */ + for(i = 0; i < iNum; i++) + { + pPtr = (char *)getCircular(pTail); + if(pCon->pSock) + { + TelnetWrite(pCon->pSock, pPtr); + } + nextCircular(pTail); + } + } +/*------------------------------------------------------------------------*/ + void CLFormatTime(char *pBuffer, int iBufLen) + { + time_t iDate; + struct tm *psTime; + + /* make time string */ + iDate = time(NULL); + psTime = localtime(&iDate); + memset(pBuffer,0,iBufLen); + strftime(pBuffer,iBufLen,"%Y-%m-%d@%H-%M-%S",psTime); + } +/*---------------------------------------------------------------------- + Build an automatically generated log file name and open it. +*/ + static void AutoLog(void) + { + char pBueffel[1024]; + char pTime[80]; + pSicsVariable pInst = NULL; + char *pPtr = NULL; + SConnection *pIntern = NULL; + + if(fauto) + { + fclose(fauto); + fauto = NULL; + } + + /* find path */ + pPtr = IFindOption(pSICSOptions,"LogFileDir"); + if(!pPtr) + { + pPtr = strdup("~/log"); + printf("WARNING: Required SICS option LogFileDir not found"); + } + + /* get time */ + CLFormatTime(pTime,79); + + /* build file name */ + sprintf(pBueffel,"%s/auto%s.log",pPtr,pTime); + + /* open file */ + fauto = fopen(pBueffel,"w"); + if(!fauto) + { + ServerWriteGlobal("ERROR: failed to open autolog file",eError); + } + + /* write the instrument name to it for identification */ + pInst = FindVariable(pServ->pSics,"instrument"); + if(pInst) + { + sprintf(pBueffel,"Logfile started at instument %s at %s", + pInst->text,pTime); + WriteToCommandLog("SYS>> ", pBueffel); + } + + /* if a file to execute is configured, execute it */ + pPtr = NULL; + pPtr = IFindOption(pSICSOptions,"logstartfile"); + if(pPtr != NULL) + { + pIntern = SCCreateDummyConnection(pServ->pSics); + if(!pIntern) + { + return; + } + SCnoSock(pIntern); + SCSetRights(pIntern,usUser); + sprintf(pBueffel,"fileeval %s",pPtr); + InterpExecute(pServ->pSics,pIntern,pBueffel); + SCDeleteConnection(pIntern); + } + } +/*---------------------------------------------------------------------- + AutoTask puts a time stamp into the auto log file any hour and + creates a new log file any 24 hours +*/ + static time_t tLogfile = 0; + static time_t tStamp = 0; + static int iEnd = 1; + static int iAutoActive = 0; + static int iIntervall = 60; + + static int AutoTask(void *pData) + { + time_t tNow; + char pTime[80]; + struct tm *sTime; + long julian; + unsigned yr, mo, dd; + + tNow = time(NULL); + if(tNow > tLogfile) + { + AutoLog(); + sTime = localtime(&tNow); + /* find next day, do so by converting to julian Date, add one + and calculate back. The (stolen) julian calculations will + take care of all the leaps and month and year etc. + */ + julian = ymd_to_scalar(sTime->tm_year+1900, sTime->tm_mon+1, + sTime->tm_mday); + julian++; + scalar_to_ymd(julian, &yr, &mo, &dd); + sTime->tm_sec = 0; + sTime->tm_min = 1; + sTime->tm_hour = 0; + sTime->tm_mday = dd; + sTime->tm_mon = mo - 1; + sTime->tm_year = yr - 1900; + tLogfile = mktime(sTime); + if(tLogfile < 0) + tLogfile = tNow + 60*60*24; + } + if(tNow > tStamp) + { + CLFormatTime(pTime,79); + WriteToCommandLog("TIMESTAMP>> ",pTime); + sTime = localtime(&tNow); + sTime->tm_sec = 0; + sTime->tm_min += iIntervall; + if(sTime->tm_min >= 60) + { + sTime->tm_min = 0; + sTime->tm_hour++; + } + if(sTime->tm_hour >= 24) + sTime->tm_hour = 0; + tStamp = mktime(sTime); + if((tStamp < 0) || ( (tStamp-tNow) < 100) ) + { + tStamp = tNow + iIntervall*60; + } + if(fauto) + fflush(fauto); + } + + return iEnd; + } +/*----------- a command to configure the log --------------------------*/ + int CommandLog(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + char *pPtr = NULL; + char pBueffel[1024]; + int iVal, iRet; + + if(argc == 1) + { + if(fd) + { + sprintf(pBueffel,"Command log ACTIVE at %s",pFile); + SCWrite(pCon,pBueffel,eValue); + return 1; + } + else + { + SCWrite(pCon,"Command logging DISABLED",eValue); + return 1; + } + } + + /* handle tail */ + strtolower(argv[1]); + if(strcmp(argv[1],"tail") == 0) + { + /* check for optional number of lines argument */ + iVal = 20; + if(argc >= 3) + { + iRet = Tcl_GetInt(pSics->pTcl,argv[2],&iVal); + if(iRet != TCL_OK) + iVal = 20; + } + PrintTail(iVal,pCon); + return 1; + } + + /* check rights */ + if(!SCMatchRights(pCon,usMugger)) + { + SCWrite(pCon,"ERROR: only managers may configure the logfile", + eError); + SCWrite(pCon,"ERROR: Request refused",eError); + return 0; + } + + /* check no of args */ + if(argc < 2) + { + SCWrite(pCon, + "ERROR: Insufficient number or arguments to commandlog", + eError); + return 0; + } + + if(strcmp(argv[1],"new") == 0) /* new command */ + { + if(argc < 3) + { + SCWrite(pCon, + "ERROR: Insufficient number or arguments to commandlog new", + eError); + return 0; + } + if(fd) + { + fclose(fd); + fd = NULL; + } + /* make the filename */ + pPtr = IFindOption(pSICSOptions,"LogFileDir"); + if(!pPtr) + { + SCWrite(pCon,"WARNING: no log file directory specified",eWarning); + sprintf(pBueffel,"%s",argv[2]); + + } + else + { + sprintf(pBueffel,"%s/%s",pPtr,argv[2]); + } + fd = fopen(pBueffel,"w"); + if(!fd) + { + sprintf(pBueffel,"ERROR: cannot open %s/%s for writing",pPtr, + argv[2]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + strcpy(pFile,argv[2]); + SCSendOK(pCon); + return 1; + } + else if(strcmp(argv[1],"auto") == 0) + { + if(iAutoActive) + { + SCWrite(pCon,"ERROR: autologging is already active",eError); + return 0; + } + TaskRegister(pServ->pTasker, + AutoTask, + NULL, + NULL, + NULL, + 1); + SCSendOK(pCon); + iAutoActive = 1; + return 1; + } + else if(strcmp(argv[1],"intervall") == 0) + { + if(argc > 2) + { + iRet = Tcl_GetInt(pSics->pTcl,argv[2],&iVal); + if(iRet != TCL_OK) + { + SCWrite(pCon,"ERROR: failed to convert new intervall to number", + eError); + return 0; + } + iIntervall = iVal; + SCSendOK(pCon); + return 1; + } + else + { + sprintf(pBueffel,"autolog.intervall = %d", iIntervall); + SCWrite(pCon,pBueffel,eValue); + return 1; + } + } + else if(strcmp(argv[1],"close") == 0) /* close command */ + { + fclose(fd); + fd = NULL; + SCSendOK(pCon); + return 1; + } + sprintf(pBueffel,"ERROR: subcommand %s to commandlog unknown", + argv[1]); + SCWrite(pCon,pBueffel,eError); + return 0; + } +/*-------------------------------------------------------------------------*/ + void CommandLogClose(void *pData) + { + if(fd) + { + fclose(fd); + } + if(fauto) + fclose(fauto); + if(pData) + KillDummy(pData); + if(pTail) + deleteCircular(pTail); + } + + + diff --git a/commandlog.h b/commandlog.h new file mode 100644 index 00000000..b458a48d --- /dev/null +++ b/commandlog.h @@ -0,0 +1,19 @@ +/*-------------------------------------------------------------------------- + C O M M A N D L O G + + A much requested facility for writing only user an manager level commands + in a transcript file. This is it. + + Mark Koennecke, June 1998 + +--------------------------------------------------------------------------*/ +#ifndef COMMANDLOG +#define COMMANDLOG + void WriteToCommandLog(char *prompt,char *pText); + int CommandLog(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + void CommandLogClose(void *pData); +#endif + + \ No newline at end of file diff --git a/configfu.h b/configfu.h new file mode 100644 index 00000000..6b9e252b --- /dev/null +++ b/configfu.h @@ -0,0 +1,26 @@ +/*-------------------------------------------------------------------------- +` This is a common header for rarely used configuration + functions. Implementations are distributed across several + files. Therefor they are mentioned in a comment. + Mark Koennecke, December 1996 + + copyrights: see implementation files +--------------------------------------------------------------------------*/ +#ifndef SICSCONFIG +#define SICSCONFIG + + int AddHalt(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + /* configuration command: enters argv objects into Halt List of Interrupt. + This is the means how the server knows which hardware to halt in an + case of emergency. Implemented in intserv.c + */ + + + int ListObjects(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + /* + lists all avialable objects. Realised in Scinter.c + */ +#endif diff --git a/conman.c b/conman.c new file mode 100644 index 00000000..0017aa27 --- /dev/null +++ b/conman.c @@ -0,0 +1,1813 @@ +/*-------------------------------------------------------------------------- + + Connection management for SICS. This is one the core files for + SICS. Does a lot. See the descriptions with individual functions + below. + + + + Mark Koennecke, October 1996 + + SMInvoke added. Mark Koennecke, April 1997 + + Seriously revised and extended for new structure with Tasker: + Mark Koennecke, September 1997 + + Support for writing telnet compatible strings ins SCWrite added. + Mark Koennecke, January 1998 + + SCWriteBinary added. Mark Koennecke, April 1998 + + Revamped login to non telnet connection. + Added compressed writing method. + Mark Koennecke, October 2000 + + Added simulation mode + Mark Koennecke, March 2003 + + Copyright: see copyright.h +-----------------------------------------------------------------------------*/ +#include "fortify.h" +#include +#include +#include +#include +#include +#include +#include +#include +#include "lld.h" +#include "sics.h" +#include "passwd.h" +#include "splitter.h" +#include "macro.h" +#include "servlog.h" +#include "status.h" +#include "interrupt.h" +#include "ifile.h" +#include "token.h" +#include "uubuffer.h" +#include "commandlog.h" + +/* +#define UUDEB 1 + define UUDEB , for buffer writing for checking encoding */ + +extern pServer pServ; + +/*------ Max Size of Command Stack */ +#define MAXSTACK 100 +/*---------- Magic ID Header */ +#define CONMAGIC 26051958 +/*------------------------------------------------------------------------- + a structure for holding callback info + */ + typedef struct { + long lID; + pICallBack pInterface; + } Item; + +/*------------- a number for generating automatic names --------------------*/ + static int iName = 0; + static int SCNormalWrite(SConnection *self, char *buffer, int iOut); + +/*===========================================================================*/ + SConnection *SCreateConnection(SicsInterp *pSics,mkChannel *pSock, int iUser) + { + int i; + SConnection *pRes = NULL; + char pBueffel[253]; + char pHost[132]; + + pRes = (SConnection *)malloc(sizeof(SConnection)); + if(!pRes) + { + /* This is a serious, very serious error! */ + SICSLogWrite("ERROR: No memory to allocate connection!!",eInternal); + return NULL; + } + memset(pRes,0,sizeof(SConnection)); + + /* a descriptor */ + pRes->pDes = CreateDescriptor("Connection"); + if(!pRes->pDes) + { + /* This is a serious, very serious error! */ + SICSLogWrite("ERROR: No memory to allocate connection!!",eInternal); + free(pRes); + return NULL; + } + + /* new name */ + sprintf(pBueffel,"CON%4.4d",iName); + iName++; + if(iName > 9999) + { + iName = 0; + } + + /* the callback registry */ + pRes->iList = LLDcreate(sizeof(Item)); + + /* the command stack */ + pRes->pStack = CreateCommandStack(); + if( (pRes->iList <0) || (!pRes->pStack)) + { + /* This is a serious, very serious error! */ + SICSLogWrite("ERROR: No memory to allocate connection!!",eInternal); + DeleteDescriptor(pRes->pDes); + free(pRes); + return NULL; + } + SetCommandStackMaxSize(pRes->pStack,MAXSTACK); + + pRes->pName = strdup(pBueffel); + pRes->pSock = pSock; + pRes->iUserRights = iUser; + pRes->iOutput = eInError; /* gets everything except internal messages */ + pRes->iFiles = 0; /* default: no logfiles */ + pRes->inUse = 0; + pRes->iMacro = 0; + pRes->iGrab = TokenGrabActive(); + pRes->iTelnet = 0; + pRes->pSics = pSics; + pRes->eInterrupt = eContinue; + pRes->lMagic = CONMAGIC; + pRes->iLogin = 0; + pRes->conStart = time(NULL); + pRes->write = SCNormalWrite; + for(i = 0; i < 10; i++) + { + pRes->pFiles[i] = NULL; + } + if(pRes->pSock) + { + NETInfo(pRes->pSock,pHost,131); + sprintf(pBueffel,"Accepted connection on socket %d from %s", + pRes->pSock->sockid, pHost); + SICSLogWrite(pBueffel,eInternal); + WriteToCommandLog("SYS >", pBueffel); + } + else + { + SICSLogWrite("Accepted dummy connection ",eInternal); + } + + /* install command */ + AddCommand(pRes->pSics, pRes->pName, ConSicsAction, NULL,pRes); + return pRes; + + } +/*--------------------------------------------------------------------------*/ + SConnection *SCCreateDummyConnection(SicsInterp *pSics) + { + int i; + SConnection *pRes = NULL; + char pBueffel[132]; + + pRes = (SConnection *)malloc(sizeof(SConnection)); + if(!pRes) + { + /* This is a serious, very serious error! */ + SICSLogWrite("ERROR: No memory to allocate connection!!",eInternal); + return NULL; + } + memset(pRes,0,sizeof(SConnection)); + + /* a descriptor */ + pRes->pDes = CreateDescriptor("Connection"); + if(!pRes->pDes) + { + /* This is a serious, very serious error! */ + SICSLogWrite("ERROR: No memory to allocate connection!!",eInternal); + free(pRes); + return NULL; + } + + /* new name */ + sprintf(pBueffel,"CON%4.4d",iName); + iName++; + if(iName > 9999) + { + iName = 0; + } + + /* the callback registry */ + pRes->iList = LLDcreate(sizeof(Item)); + + /* the command stack */ + pRes->pStack = CreateCommandStack(); + if( (pRes->iList <0) || (!pRes->pStack)) + { + /* This is a serious, very serious error! */ + SICSLogWrite("ERROR: No memory to allocate connection!!",eInternal); + DeleteDescriptor(pRes->pDes); + free(pRes); + return NULL; + } + + pRes->pName = strdup(pBueffel); + pRes->pSock = NULL; + pRes->iUserRights = usInternal; + pRes->iOutput = eInError; /* gets everything except internal messages */ + pRes->iFiles = 0; /* default: no logfiles */ + pRes->inUse = 0; + pRes->iTelnet = 0; + pRes->iGrab = 0; + pRes->iMacro = 0; + pRes->pSics = pSics; + pRes->lMagic = CONMAGIC; + pRes->eInterrupt = eContinue; + pRes->iLogin = 0; + pRes->conStart = time(NULL); + pRes->write = SCNormalWrite; + for(i = 0; i < 10; i++) + { + pRes->pFiles[i] = NULL; + } + if(pRes->pSock) + { + sprintf(pBueffel,"Accepted connection on socket %d",pRes->pSock->sockid); + SICSLogWrite(pBueffel,eInternal); + } + else + { + SICSLogWrite("Accepted dummy connection ",eInternal); + } + + /* install command */ + AddCommand(pRes->pSics, pRes->pName, ConSicsAction, NULL,pRes); + return pRes; + } +/*--------------------------------------------------------------------------*/ + static int VerifyConnection(SConnection *self) + { + if(!self) + { + SICSLogWrite("MAGICERROR: Invalid call to NULL connection",eError); + return 0; + } + if(self->lMagic != CONMAGIC) + { + SICSLogWrite("MAGICERROR: corrupted connection object",eError); + return 0; + } + return 1; + } +/*----------------------------------------------------------------------------*/ + int SCAddLogFile(SConnection *self, char *name) + { + char pBueffel[256]; + int iNum, i; + + if(!VerifyConnection(self)) + { + return 0; + } + + + /* find an empty number */ + if(self->iFiles < MAXLOGFILES) + { + iNum = self->iFiles; + self->iFiles++; + } + else /* scan for an empty slot */ + { + iNum = -1; + for(i = 0; i < self->iFiles; i++) + { + if(self->pFiles[i] == NULL) + { + iNum = i; + break; + } + } + } + /* nothing found ? */ + if(iNum < 0) + { + SCWrite(self,"ERROR: maximum number of logfiles exhausted",eError); + return -1; + } + + /* do the job */ + self->pFiles[iNum] = fopen(name,"a+"); + if(self->pFiles[iNum] == NULL) + { + sprintf(pBueffel,"ERROR Could not open logfile - %s -",name); + SCWrite(self,pBueffel, 10); + return -1; /* false */ + } + else + { + return iNum; /* success */ + } + } +/*--------------------------------------------------------------------------*/ + int SCDelLogFile(SConnection *self, int iNum) + { + if(!VerifyConnection(self)) + { + return 0; + } + + if( (iNum >= 0) && (iNum < MAXLOGFILES) ) + { + if(self->pFiles[iNum]) + { + fclose(self->pFiles[iNum]); + self->pFiles[iNum] = NULL; + return 1; + } + } + return 0; + } +/*----------------------------------------------------------------------------*/ + void SCSetOutputClass(SConnection *self, int iClass) + { + if(!VerifyConnection(self)) + { + return; + } + self->iOutput = iClass; + } +/*---------------------------------------------------------------------------*/ + int SCinMacro(SConnection *self) + { + if(!VerifyConnection(self)) + { + return 0; + } + + if(self->iMacro) + { + return 1; + } + else + { + return 0; + } + } +/*---------------------------------------------------------------------------*/ + int SCsetMacro(SConnection *self, int iMode) + { + if(!VerifyConnection(self)) + { + return 0; + } + assert( (iMode == 0) || (iMode == 1)); + self->iMacro = iMode; + return 1; + } +/*---------------------------------------------------------------------------*/ + void SCDeleteConnection(void *pData) + { + int i, iRet; + char pBueffel[132]; + SConnection *pVictim = NULL; + Item sItem; + + pVictim = (SConnection *)pData; + if(!VerifyConnection(pVictim)) + { + return; + } + + if(pVictim->inUse > 0) + { + SCnoSock(pVictim); + if(pVictim->pSock) + { + NETClosePort(pVictim->pSock); + free(pVictim->pSock); + pVictim->pSock = NULL; + } + WriteToCommandLog("SYS> ", + "ERROR: Erraneous deletion of used Connection stopped"); + return; + } + + + /* remove the connection from the server log if it has captured + something + */ + KillCapture(pVictim); + + /* + If we have a grab, release it ! + */ + if(!pVictim->iGrab) + { + if(pServ->pTasker) + { + TaskSignal(pServ->pTasker,TOKENRELEASE,NULL); + TokenRelease(); + } + } + + /* log the kill */ + if(pVictim->pSock) + { + sprintf(pBueffel,"Deleting connection %d",pVictim->pSock->sockid); + WriteToCommandLog("SYS>",pBueffel); + SICSLogWrite(pBueffel,eInternal); + } + + /* close all open files and sockets */ + if(pVictim->pSock) + { + NETWrite(pVictim->pSock,"SICSCLOSE",sizeof("SICSCLOSE")); + NETClosePort(pVictim->pSock); + free(pVictim->pSock); + } + for(i = 0; i < pVictim->iFiles; i++) + { + fclose(pVictim->pFiles[i]); + } + + if(pVictim->pName) + { + RemoveCommand(pVictim->pSics,pVictim->pName); + free(pVictim->pName); + } + + if(pVictim->pDes) + { + DeleteDescriptor(pVictim->pDes); + } + + /* remove all callbacks on this connection */ + iRet = LLDnodePtr2First(pVictim->iList); + while(iRet != 0) + { + LLDnodeDataTo(pVictim->iList,&sItem); + RemoveCallback(sItem.pInterface, sItem.lID); + iRet = LLDnodePtr2Next(pVictim->iList); + } + LLDdelete(pVictim->iList); + + /* remove standing data connections */ + if(pVictim->pDataSock) + { + NETClosePort(pVictim->pDataSock); + free(pVictim->pDataSock); + free(pVictim->pDataComp); + } + + /* remove command stack */ + if(pVictim->pStack) + { + DeleteCommandStack(pVictim->pStack); + } + /* finally free pVictim*/ + free(pVictim); + } +/*---------------------------------------------------------------------------*/ + static int HasNL(char *buffer) + { + int i; + for(i = strlen(buffer); i > 0; i--) + { + if(isprint(buffer[i])) + { + break; + } + if(buffer[i] == '\n') + { + return 1; + } + } + return 0; + } +/*------------------------------------------------------------------------- + TelnetWrite makes sure, that all lines are properly terminated with a + as required by the telnet protocoll. + + There may be a problem here at long messages. 7.5.1998 MK +--------------------------------------------------------------------------*/ +#define TXT 0 +#define LF 1 + + int TelnetWrite(mkChannel *pSock, char *pBuffer) + { + char *pStart = NULL, *pPtr; + int iCount, iState; + int iRet = 1; + + pStart = pBuffer; + pPtr = pStart; + iState = TXT; + iCount = 0; + while(*pPtr != '\0') + { + switch(iState) + { + case TXT: + if( (*pPtr == '\r') || (*pPtr == '\n') ) + { + iState = LF; + iRet = NETWrite(pSock,pStart,iCount); + iRet = NETWrite(pSock,"\r\n",2); + iCount = 0; + } + else + { + iCount++; + } + break; + case LF: + if( (*pPtr != '\r') && (*pPtr != '\n') ) + { + pStart = pPtr; + iCount = 1; + iState = TXT; + } + else + { + /* do nothing */ + } + break; + } + pPtr++; + } + if(iCount > 0) + { + iRet = NETWrite(pSock,pStart,iCount); + iRet = NETWrite(pSock,"\r\n",2); + } + return iRet; + } +/*-------------------------------------------------------------------------*/ + int SCWrite(SConnection *self, char *pBuffer, int iOut) + { + if(!VerifyConnection(self)) + { + return 0; + } + return self->write(self,pBuffer,iOut); + } +/*-------------------------------------------------------------------------*/ +writeFunc SCGetWriteFunc(SConnection *self) +{ + if(!VerifyConnection(self)) + { + return 0; + } + return self->write; +} +/*-------------------------------------------------------------------------*/ +void SCSetWriteFunc(SConnection *self, writeFunc x) +{ + if(!VerifyConnection(self)) + { + return; + } + self->write = x; +} +/*--------------------------------------------------------------------------*/ + static int SCNormalWrite(SConnection *self, char *buffer, int iOut) + { + int i, iPtr, iRet; + char pBueffel[80]; + + if(!VerifyConnection(self)) + { + return 0; + } + + /* log it for any case */ + if(self->pSock) + { + iRet = self->pSock->sockid; + } + else + { + iRet = 0; + } + sprintf(pBueffel,"Next line intended for socket: %d",iRet); + SICSLogWrite(pBueffel,eInternal); + SICSLogWrite(buffer,iOut); + + /* write to commandlog if user or manager privilege */ + if(SCGetRights(self) <= usUser) + { + sprintf(pBueffel,"To sock %d :",iRet); + WriteToCommandLog(pBueffel,buffer); + } + + /* put it into the interpreter if present */ + if(SCinMacro(self)) + { + InterpWrite(self->pSics,buffer); + /* print it to client if error message */ + if((iOut== eError) || (iOut == eWarning) ) + { + if(self->pSock) + { + if(self->iTelnet) + { + iRet = TelnetWrite(self->pSock,buffer); + } + else + { + iRet = NETWrite(self->pSock,buffer,strlen(buffer)); + if(!HasNL(buffer)) + { + iRet = NETWrite(self->pSock,"\n",sizeof("\n")); + } + } + if(!iRet) + { + SCnoSock(self); + WriteToCommandLog("SYS> ","Connection broken on send"); + } + } + else + { + puts(buffer); + } + } + } + else /* not in interpreter, normal logic */ + { + /* is this really to be printed ? */ + if(iOut < self->iOutput) + return 0; + + /* first the socket */ + if(self->pSock) + { + if(self->iTelnet) + { + iRet = TelnetWrite(self->pSock,buffer); + } + else + { + iRet = NETWrite(self->pSock,buffer,strlen(buffer)); + if(!HasNL(buffer)) + { + iRet = NETWrite(self->pSock,"\n",sizeof("\n")); + } + } + if(!iRet) + { + SCnoSock(self); + WriteToCommandLog("SYS> ","Send broken to connection"); + } + } + else + { + printf("%s \n",buffer); + } + + /* now all the possible logfiles */ + for(i = 0; i < self->iFiles; i++) + { + if(self->pFiles[i]) + { + fputs(buffer,self->pFiles[i]); + if(! HasNL(buffer)) + { + fputs("\n",self->pFiles[i]); + fflush(self->pFiles[i]); + } + } + } + } + return 1; + } +/*--------------------------------------------------------------------------*/ + int SCOnlySockWrite(SConnection *self, char *buffer, int iOut) + { + int i, iPtr, iRet; + char pBueffel[80]; + + if(!VerifyConnection(self)) + { + return 0; + } + + /* log it for any case */ + if(self->pSock) + { + iRet = self->pSock->sockid; + } + else + { + iRet = 0; + } + sprintf(pBueffel,"Next line intended for socket: %d",iRet); + SICSLogWrite(pBueffel,eInternal); + SICSLogWrite(buffer,iOut); + + /* put it into the interpreter if present */ + if(SCinMacro(self)) + { + InterpWrite(self->pSics,buffer); + } + else /* not in interpreter, normal logic */ + { + /* is this really to be printed ? */ + if(iOut < self->iOutput) + return 0; + + /* the socket */ + if(self->pSock) + { + if(self->iTelnet) + { + iRet = TelnetWrite(self->pSock,buffer); + } + else + { + iRet = NETWrite(self->pSock,buffer,strlen(buffer)); + if(!HasNL(buffer)) + { + iRet = NETWrite(self->pSock,"\n",sizeof("\n")); + } + } + if(!iRet) + { + SCnoSock(self); + WriteToCommandLog("SYS> ","Send broken to connection"); + } + } + else + { + printf("%s \n",buffer); + } + } + return 1; + } +/*--------------------------------------------------------------------------*/ + int SCNotWrite(SConnection *self, char *buffer, int iOut) + { + int i, iPtr, iRet; + char pBueffel[80]; + + if(!VerifyConnection(self)) + { + return 0; + } + + /* log it for any case */ + if(self->pSock) + { + iRet = self->pSock->sockid; + } + else + { + iRet = 0; + } + sprintf(pBueffel,"Next line intended for socket: %d",iRet); + SICSLogWrite(pBueffel,eInternal); + SICSLogWrite(buffer,iOut); + + return 1; + } +/*-------------------------------------------------------------------------- + This version writes only to configured log files but not to sockets. + Used for automatic file execution for the WWW interface +*/ + static int SCFileWrite(SConnection *self, char *buffer, int iOut) + { + int i, iPtr, iRet; + char pBueffel[80]; + + if(!VerifyConnection(self)) + { + return 0; + } + + /* put into Serverlog */ + sprintf(pBueffel,"Next line intended for socket: %d",-10); + SICSLogWrite(pBueffel,eInternal); + SICSLogWrite(buffer,iOut); + + /* write to commandlog if user or manager privilege */ + if(SCGetRights(self) <= usUser) + { + sprintf(pBueffel,"To sock %d :",-10); + WriteToCommandLog(pBueffel,buffer); + } + + /* put it into the interpreter if present */ + if(SCinMacro(self)) + { + InterpWrite(self->pSics,buffer); + } + else /* not in interpreter, normal logic */ + { + /* is this really to be printed ? */ + if(iOut < self->iOutput) + return 0; + + /* now all the possible logfiles */ + for(i = 0; i < self->iFiles; i++) + { + if(self->pFiles[i]) + { + fputs(buffer,self->pFiles[i]); + if(! HasNL(buffer)) + { + fputs("\n",self->pFiles[i]); + fflush(self->pFiles[i]); + } + } + } + } + return 1; + } +/*-----------------------------------------------------------------------*/ + int SCnoSock(SConnection *self) + { + if(!VerifyConnection(self)) + { + return 0; + } + self->write = SCFileWrite; + } +/*-------------------------------------------------------------------------*/ + int SCWriteBinary(SConnection *pCon, char *pComputer, int iPort, + void *pData, int iDataLen) + { + int iRet; + char pBueffel[1024]; + mkChannel *pChan = NULL; + + assert(pCon); + + /* do we have an identical connection already */ + if(pCon->pDataSock) + { + if(strcmp(pComputer,pCon->pDataComp) == 0 && (pCon->iDataPort == iPort)) + { + pChan = pCon->pDataSock; + } + else /* rubbish, kill it */ + { + NETClosePort(pCon->pDataSock); + free(pCon->pDataSock); + free(pCon->pDataComp); + pCon->pDataSock = NULL; + pCon->pDataComp = NULL; + } + } + + /* we have none, open it! */ + if(!pChan) + { + pChan = NETConnect(pComputer, iPort); + if(!pChan) + { + sprintf(pBueffel,"ERROR: cannot connect to %s %d",pComputer, iPort); + SCWrite(pCon,pBueffel,eError); + SCWrite(pCon,"EOFBINARYERROR",eValue); + return 0; + } + pCon->pDataSock = pChan; + pCon->pDataComp = strdup(pComputer); + pCon->iDataPort = iPort; + } + + /* do the writing */ + iRet = NETWrite(pChan,pData,iDataLen); + if(iRet != 1) + { + sprintf(pBueffel,"ERROR: failed to write data to %s %d",pComputer, iPort); + SCWrite(pCon,pBueffel,eError); + SCWrite(pCon,"EOFBINARYERROR",eValue); + NETClosePort(pChan); + free(pCon->pDataSock); + free(pCon->pDataComp); + pCon->pDataSock = NULL; + pCon->pDataComp = NULL; + return 0; + } + + SCWrite(pCon,"EOFBINARYOK",eValue); + return 1; + } +/*------------------------------------------------------------------------*/ + int SCWriteUUencoded(SConnection *pCon, char *pName, void *pData, + int iDataLen) + { + void *pPtr = NULL; + int iLength = 0; + int iRet = 1; + FILE *fd; + char *pTest; + + iRet = UUencodeBuffer(pData,iDataLen,pName, &pPtr, &iLength); + if(iRet != 1) + { + SCWrite(pCon,"ERROR: no memory for uuencoder",eError); + return 0; + } + pTest = (char *)pPtr; + + /* the uuencoder ensures proper telnet */ + if(pCon->iTelnet) + { + NETWrite(pCon->pSock,pPtr,iLength); + } + else + { + NETWrite(pCon->pSock,pPtr,iLength); + } + +#ifdef UUDEB + fd = fopen("uubuffer.uu","w"); + fputs(pPtr,fd); + fclose(fd); +#endif + + free(pPtr); + return iRet; + } +/*------------------------------------------------------------------------*/ +#define ZIPBUF 8192 + int SCWriteZipped(SConnection *self, char *pName, void *pData, int iDataLen) + { + char outBuf[65546], *pBuf = NULL, noutBuf[ZIPBUF], *pHeader = NULL; + int compressedLength, iRet, iRet2, iCount; + z_stream compStream; + + /* check for a valid connection */ + if(!VerifyConnection(self)) + { + return 0; + } + + /* a telnet connection will corrupt the compressed stream, so + stop it! + */ + if(self->iTelnet) + { + SCWrite(self, + "ERROR: the telnet protocoll will currupt compressed data!", + eError); + return 0; + } + + /* initialize the compression stuff */ + compStream.zalloc = (alloc_func)NULL; + compStream.zfree = (free_func)NULL; + compStream.opaque = (voidpf)NULL; + + iRet = deflateInit(&compStream,Z_DEFAULT_COMPRESSION); + if(iRet != Z_OK) + { + sprintf(outBuf,"ERROR: zlib error: %d",iRet); + SCWrite(self,outBuf,eError); + return 0; + } + + /* first pass: find out how the long the compressed buffer will be */ + compressedLength = 0; + compStream.next_in = (Bytef *)pData; + compStream.next_out = (Bytef *)outBuf; + compStream.avail_in = iDataLen; + compStream.avail_out = 65536; + while(compStream.total_in < iDataLen) + { + iRet = deflate(&compStream,Z_NO_FLUSH); + if(iRet != Z_OK) + { + sprintf(outBuf,"ERROR: zlib error: %d",iRet); + SCWrite(self,outBuf,eError); + return 0; + } + compStream.next_out = (Bytef *)outBuf; + compStream.avail_out = 65536; + } + for(;;) + { + iRet = deflate(&compStream,Z_FINISH); + if(iRet == Z_STREAM_END) break; + if(iRet != Z_OK) + { + sprintf(outBuf,"ERROR: zlib error: %d",iRet); + SCWrite(self,outBuf,eError); + return 0; + } + } + compressedLength = compStream.total_out; + deflateEnd(&compStream); + + /* write header line */ + memset(outBuf,0,65536); + sprintf(outBuf,"SICSBIN ZIP %s %d\r\n",pName,compressedLength); + pHeader = strdup(outBuf); + if(pHeader == NULL) + { + SCWrite(self,"ERROR: out of memory in SCWriteZipped",eError); + return 0; + } + + /* now reset the deflater and do the same with writing data */ + compStream.zalloc = (alloc_func)NULL; + compStream.zfree = (free_func)NULL; + compStream.opaque = (voidpf)NULL; + + + /* + This is writing everything in one go as I found that writing in + several chunks did not ensure that all the data arrived at the + Java side. + */ + + iRet = deflateInit(&compStream,Z_DEFAULT_COMPRESSION); + if(iRet != Z_OK) + { + sprintf(outBuf,"ERROR: zlib error: %d",iRet); + SCWrite(self,outBuf,eError); + return 0; + } + + pBuf = (char *)malloc((iDataLen + iDataLen/10 + 50)*sizeof(char)); + memset(pBuf,0,(iDataLen + iDataLen/10 + 50)*sizeof(char) ); + compStream.next_in = (Bytef *)pData; + compStream.next_out = (Bytef *)pBuf; + compStream.avail_in = iDataLen; + compStream.avail_out = iDataLen + iDataLen/10 + 50; + iRet = deflate(&compStream,Z_FINISH); + if(iRet != Z_STREAM_END) + { + sprintf(outBuf,"ERROR: zlib error: %d",iRet); + SCWrite(self,outBuf,eError); + return 0; + } + iRet = NETWrite(self->pSock,pHeader,strlen(pHeader)); + iRet = NETWrite(self->pSock,pBuf,compStream.total_out); + if(iRet != 1) + { + sprintf(outBuf,"ERROR: network error %d on zipped send",iRet); + SCWrite(self,outBuf,eError); + return 0; + } + deflateEnd(&compStream); + free(pHeader); + free(pBuf); + + + /* + Writing smaller buffers. Seems not to be working properly + with Java. + */ + /* + compStream.next_in = (Bytef *)pData; + compStream.avail_in = iDataLen; + compStream.avail_out = ZIPBUF; + compStream.next_out = (Bytef *)noutBuf; + iCount = 0; + while(compStream.total_in < iDataLen) + { + iRet = deflate(&compStream,Z_NO_FLUSH); + if(iRet != Z_OK) + { + sprintf(outBuf,"ERROR: zlib error: %d",iRet); + SCWrite(self,outBuf,eError); + return 0; + } + iRet = NETWrite(self->pSock,noutBuf,ZIPBUF - compStream.avail_out); + if(iRet != 1) + { + sprintf(outBuf,"ERROR: network error %d on zipped send",iRet); + SCWrite(self,outBuf,eError); + return 0; + } + iCount += ZIPBUF - compStream.avail_out; + compStream.next_out = (Bytef *)noutBuf; + compStream.avail_out = ZIPBUF; + } + for(;;) + { + iRet = deflate(&compStream,Z_FINISH); + iRet2 = NETWrite(self->pSock,noutBuf,ZIPBUF - compStream.avail_out); + if(iRet2 != 1) + { + sprintf(outBuf,"ERROR: network error %d on zipped send",iRet); + SCWrite(self,outBuf,eError); + return 0; + } + iCount += ZIPBUF - compStream.avail_out; + if(iRet == Z_STREAM_END) break; + if(iRet != Z_OK) + { + sprintf(outBuf,"ERROR: zlib error: %d",iRet); + SCWrite(self,outBuf,eError); + return 0; + } + compStream.next_out = (Bytef *)noutBuf; + compStream.avail_out = ZIPBUF; + } + deflateEnd(&compStream); + */ + + return 1; + } +/*-------------------------------------------------------------------------*/ + int SCSendOK(SConnection *self) + { + return SCWrite(self,"OK",eStatus); + } +/*--------------------------------------------------------------------------*/ + int SCRead(SConnection *self, char *buffer, int iLen) + { + + int iRet; + + if(!VerifyConnection(self)) + { + return 0; + } + + if(self->pSock == NULL) + { + printf("SICS>> "); + fgets(buffer,iLen-1,stdin); + return 1; + } + + if(self->pSock) + { + iRet = NETRead(self->pSock,buffer,iLen,10); + if(iRet == 0) /* no data */ + { + return 0; + } + else if(iRet < 0) /* eof */ + { + return EOF; + } + else /* data */ + { + return 1; + } + } + else + { + return EOF; + /* fgets(buffer,iLen,stdin); */ + } + return 1; + } +/*----------------------------------------------------------------------------*/ + int SCMatchRights(SConnection *pCon, int iCode) + { + char pBueffel[132]; + + if(!VerifyConnection(pCon)) + { + return 0; + } + + if(iCode < SCGetRights(pCon)) + { + sprintf(pBueffel,"ERROR: you are not authorised for this operation"); + SCWrite(pCon, pBueffel, eError); + return 0; + } + if(pCon->iGrab) + { + sprintf(pBueffel, + "ERROR: Request refused, control has been grabbed by somebody else"); + SCWrite(pCon,pBueffel,eError); + return 0; + } + return 1; + } + +/*----------------------------------------------------------------------------*/ + int SCPrompt(SConnection *pCon, char *pPrompt, char *pResult, int iLen) + { + + int iRet, i; + char *pPtr = NULL; + char pFrom[50]; + Status eOld; + + if(!VerifyConnection(pCon)) + { + return 0; + } + + SCWrite(pCon,pPrompt,eWarning); + eOld = GetStatus(); + SetStatus(eInput); + CostaUnlock(pCon->pStack); + while(1) + { + /* wait a second */ + SicsWait(1); + /* is there an interrupt pending ? */ + if(SCGetInterrupt(pCon) != eContinue) + { + break; + } + /* do we have data ? */ + iRet = CostaPop(pCon->pStack,&pPtr); + if(iRet == 1) + { + SetStatus(eOld); + CostaLock(pCon->pStack); + strncpy(pResult,pPtr,iLen); + sprintf(pFrom,"Prompted from sock %2.2d: ", pCon->pSock->sockid); + WriteToCommandLog(pFrom,pPtr); + return 1; + } + } + SetStatus(eOld); + CostaLock(pCon->pStack); + return 0; + } +/*---------------------------------------------------------------------------*/ + int SCGetRights(SConnection *self) + { + if(!VerifyConnection(self)) + { + return 0; + } + + return self->iUserRights; + } +/*---------------------------------------------------------------------------*/ + int SCGetGrab(SConnection *self) + { + if(!VerifyConnection(self)) + { + return 0; + } + + return self->iGrab; + } +/*--------------------------------------------------------------------------*/ + int SCSetRights(SConnection *self, int iNew) + { + if(!VerifyConnection(self)) + { + return 0; + } + assert(iNew >= usInternal); + assert(iNew <= usSpy); + + self->iUserRights = iNew; + return 1; + } +/*---------------------------------------------------------------------------*/ + int SCGetOutClass(SConnection *self) + { + if(!VerifyConnection(self)) + { + return 0; + } + return self->iOutput; + } +/*--------------------------------------------------------------------------*/ + void SCSetInterrupt(SConnection *self, int eCode) + { + if(!VerifyConnection(self)) + { + return; + } + + self->eInterrupt = eCode; + } +/*---------------------------------------------------------------------------*/ + int SCGetInterrupt(SConnection *self) + { + if(!VerifyConnection(self)) + { + return 0; + } + + return self->eInterrupt; + } +/* --------------------------------------------------------------------------*/ + int SCInvoke(SConnection *self, SicsInterp *pInter, char *pCommand) + { + int iRet; + long lLen; + const char *pResult = NULL; + char *pBuffer = NULL, *pFile = NULL; + char pBueffel[80]; + int i, iSpace; + + if(!VerifyConnection(self)) + { + return 0; + } + assert(pInter); + + /* print command to log files */ + for( i = 0; i < self->iFiles; i++) + { + if(self->pFiles[i]) + { + fprintf(self->pFiles[i],"SICS>> %s\n",pCommand); + } + } + + /* print to command log if user or manager */ + if(SCGetRights(self) <= usUser) + { + if(self->pSock != NULL) + { + sprintf(pBueffel,"sock %d>>",self->pSock->sockid); + } + else + { + strcat(pBueffel,"CONT or CRON>> "); + } + WriteToCommandLog(pBueffel,pCommand); + } + + /* invoke */ + self->inUse++; + self->eInterrupt = eContinue; + self->parameterChange = 0; + iRet = InterpExecute(pInter,self,pCommand); + if(self->parameterChange == 1) + { + /* + automatically save changed parameters + */ + pFile = IFindOption(pSICSOptions,"statusfile"); + if(pFile != NULL) + { + WriteSicsStatus(pInter,pFile,0); + self->parameterChange = 0; + } + } + self->inUse--; + return iRet; + } +/*--------------------------------------------------------------------------- + For configuring connections. Syntax: + config OutCode val sets an new output code + config Rights User Password sets and verifies new user rights + config File Filename Logs to another file +*/ +#include "outcode.c" /* text for OutCode */ + + int ConfigCon(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + char pBueffel[512]; + int i, iRet; + int iNum; + + if(!VerifyConnection(pCon)) + { + return 0; + } + assert(pSics); + + /* check no of args */ + if(argc < 2) + { + sprintf(pBueffel,"Insufficient number of args to %s",argv[0]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + /* handle list*/ + strtolower(argv[1]); + if(strcmp(argv[1],"list") == 0) + { + sprintf(pBueffel,"OutCode = %s\nUserRights = %d", + pCode[pCon->iOutput], SCGetRights(pCon)); + SCWrite(pCon,pBueffel,eStatus); + return 1; + } + else if(strcmp(argv[1],"myname") == 0) + { + sprintf(pBueffel,"MyName = %s",pCon->pName); + SCWrite(pCon,pBueffel,eValue); + return 1; + } + else if(strcmp(argv[1],"myrights") == 0) + { + sprintf(pBueffel,"UserRights = %d",SCGetRights(pCon)); + SCWrite(pCon,pBueffel,eValue); + return 1; + } + + /* check no or args */ + if(argc < 3) + { + sprintf(pBueffel,"Insufficient number of args to %s",argv[0]); + SCWrite(pCon,pBueffel,eInError); + return 0; + } + + /* decide what to do */ + if(strcmp(argv[1],"file") == 0) + { + iRet = SCAddLogFile(pCon,argv[2]); + if(iRet >= 0 ) + { + sprintf(pBueffel,"File = %d",iRet); + SCWrite(pCon,pBueffel,eStatus); + return 1; + } + } + if(strcmp(argv[1],"close") == 0) /* close file */ + { + iNum = atoi(argv[2]); + if( (iNum >= 0) && (iNum < MAXLOGFILES)) + { + if(pCon->pFiles[iNum]) + { + fclose(pCon->pFiles[iNum]); + pCon->pFiles[iNum] = NULL; + SCSendOK(pCon); + return 1; + } + } + else + { + SCWrite(pCon, "Invalid file number specified ",eError); + return 0; + } + } + else if(strcmp(argv[1],"outcode") == 0) + { + i = 0; + strtolower(argv[2]); + while(pCode[i] != NULL) + { + if(strcmp(pCode[i],argv[2]) == 0) + { + break; + } + i++; + } + if( i > iNoCodes) + { + sprintf(pBueffel,"OutCode %s not recognized",argv[2]); + SCWrite(pCon,pBueffel,eInError); + return 0; + } + pCon->iOutput = i; + SCSendOK(pCon); + return 1; + } + else if(strcmp(argv[1],"rights") == 0) + { + if(argc < 4) + { + sprintf(pBueffel,"Insufficient number of args to %s",argv[0]); + SCWrite(pCon,pBueffel,eInError); + return 0; + } + i = IsValidUser(argv[2],argv[3]); + if(i < 0) + { + sprintf(pBueffel," %s with password ****** is NO valid User on SICS", + argv[2]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + pCon->iUserRights = i; + sprintf(pBueffel,"User %s socket %d switched to %d privilege", + argv[2],pCon->pSock->sockid,i); + WriteToCommandLog("SYS>",pBueffel); + SCWrite(pCon,"Change of Authorisation Acknowledged",eWarning); + return 1; + } + SCWrite(pCon,"Command not recognized",eError); + return 0; + } +/*----------------------------------------------------------------------*/ + int SCRegister(SConnection *pCon, SicsInterp *pSics, + void *pData, long lID) + { + pICallBack pInter = NULL; + Item sItem; + + pInter = (pICallBack)pData; + if(!VerifyConnection(pCon)) + { + return 0; + } + assert(pSics); + assert(pInter); + + sItem.lID = lID; + sItem.pInterface = pInter; + LLDnodeAppendFrom(pCon->iList,&sItem); + return 1; + } +/*----------------------------------------------------------------------*/ + int SCUnregister(SConnection *pCon, void *pData) + { + int iRet; + Item sItem; + pICallBack pInter; + + if(!VerifyConnection(pCon)) + { + return 0; + } + pInter = (pICallBack)pData; + iRet = LLDnodePtr2First(pCon->iList); + while(iRet != 0) + { + LLDnodeDataTo(pCon->iList,&sItem); + if(sItem.pInterface == pInter) + { + LLDnodeDelete(pCon->iList); + LLDnodePtr2Prev(pCon->iList); + } + iRet = LLDnodePtr2Next(pCon->iList); + } + return 1; + } +/*---------------------- The callback data structure --------------------*/ + typedef struct { + SConnection *pCon; + SicsInterp *pSics; + char *pAction; + } CBAction, *pCBAction; +/*---------------------- CBKill -----------------------------------------*/ + static void CBKill(void *pData) + { + pCBAction self = NULL; + self = (pCBAction)pData; + + if(self == NULL) + { + return; + } + + if(self->pAction) + { + free(self->pAction); + } + free(self); + } + +/*------------------------------------------------------------------------- + The callback function for connection callbacks. Invokes command + given at registration time. +*/ + static int ConCallBack(int iEvent, void *pEventData, void *pUserData) + { + pCBAction self = NULL; + + self = (pCBAction)pUserData; + assert(self); + + if(self->pAction) + { + InterpExecute(self->pSics,self->pCon,self->pAction); + } + return 1; + } +/*-------------------------------------------------------------------------- + The only command currently understood is: put args + writes the args to the client +*/ + + + int ConSicsAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + SConnection *self = NULL; + pICallBack pInterface = NULL; + char pBueffel[1024]; + pDummy pDum; + int iEvent; + Item sItem; + pCBAction pCB = NULL; + CommandList *pCom = NULL; + int iMacro; + + self = (SConnection *)pData; + if(!VerifyConnection(self)) + { + return 0; + } + + if(argc > 1) + { + /* put */ + if(strcmp(argv[1],"put") == 0) + { + Arg2Text(argc-2,&argv[2],pBueffel,1023); + iMacro = SCinMacro(pCon); + SCsetMacro(pCon,0); + SCWrite(self,pBueffel,eWarning); + SCsetMacro(pCon,iMacro); + return 1; + } + /* register object event action */ + if(strcmp(argv[1],"register") == 0) + { + if(argc < 5) + { + SCWrite(pCon,"ERROR: Insufficient arguments to register",eError); + return 0; + } + + /* get object */ + pCom = FindCommand(pSics,argv[2]); + if(!pCom) + { + sprintf(pBueffel,"ERROR: object %s NOT found",argv[2]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + /* get CallBack interface */ + pDum = (pDummy)pCom->pData; + assert(pDum); + pInterface = (pICallBack)pDum->pDescriptor->GetInterface(pDum,CALLBACKINTERFACE); + if(!pInterface) + { + sprintf(pBueffel,"ERROR: %s does not support CallBacks", + argv[2]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + /* get Event */ + iEvent = Text2Event(argv[3]); + if(iEvent < 0) + { + sprintf(pBueffel,"ERROR: Unknown event code %s",argv[3]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + /* now we can install the callback */ + pCB = (pCBAction)malloc(sizeof(CBAction)); + if(!pCB) + { + SCWrite(pCon,"ERROR: memory exhausted in SConnection",eError); + return 0; + } + Arg2Text(argc-4, &argv[4],pBueffel,1023); + pCB->pCon = pCon; + pCB->pSics = pSics; + pCB->pAction = strdup(pBueffel); + sItem.pInterface = pInterface; + sItem.lID = RegisterCallback(pInterface, iEvent, ConCallBack, + pCB, CBKill); + LLDnodeAppendFrom(self->iList,&sItem); + SCSendOK(pCon); + return 1; + } + } + return 0; + } +/*--------------------------------------------------------------------------*/ + int SCTaskFunction(void *pData) + { + SConnection *self = NULL; + char *pPtr = NULL; + int iRet; + char *pUser = NULL, *pPassword = NULL; + + self = (SConnection *)pData; + if(!VerifyConnection(self)) + { + return 0; + } + + if(self->iEnd) + { + if(self->inUse != 0) + { + return 1; + } + else + { + return 0; + } + } + + /* a timeout check on logins */ + if(!self->iLogin && time(NULL) > self->conStart + 120) + { + NetReadRemove(pServ->pReader,self->pSock); + SCWrite(self, "No valid login in two minutes, closing..",eError); + self->iEnd = 1; + return 1; + } + + /* pop and execute */ + iRet = CostaPop(self->pStack,&pPtr); + if(iRet) + { + if(pPtr) + { + if(self->iLogin) + { + /* + normal processing, logged in + but check for logoff + */ + if(strstr(pPtr,"logoff") != NULL) + { + NetReadRemove(pServ->pReader,self->pSock); + self->iEnd = 1; + free(pPtr); + return 1; + } + /* invoke command */ + CostaLock(self->pStack); + SCInvoke(self,self->pSics,pPtr); + CostaUnlock(self->pStack); + /* SCWrite(self,"\b",eError); */ + } + else + { + /* check for username and password */ + pUser = strtok(pPtr," \t"); + pPassword = strtok(NULL," \t\r\n"); + iRet = IsValidUser(pUser,pPassword); + if(iRet >= 0) + { + SCWrite(self,"Login OK",eError); + self->iLogin = 1; + SCSetRights(self,iRet); + free(pPtr); + return 1; + } + else + { + SCWrite(self,"ERROR: Bad login",eError); + + } + } + free(pPtr); + } + } + + + if(self->iEnd) + { + if(self->inUse != 0) + { + return 1; + } + else + { + return 0; + } + } + + return 1; + } +/*---------------------------------------------------------------------------*/ + void SCSignalFunction(void *pData, int iSignal, void *pSigData) + { + SConnection *self = NULL; + int *iInt; + char *pPtr; + + self = (SConnection *)pData; + if(!VerifyConnection(self)) + { + return; + } + + if(iSignal == SICSINT) + { + iInt = (int *)pSigData; + SCSetInterrupt(self,*iInt); + if(*iInt == eEndServer) + { + self->iEnd = 1; + } + } + else if(iSignal == SICSBROADCAST) + { + pPtr = (char *)pSigData; + if(pPtr) + { + SCWrite(self,pPtr,eWarning); + } + } + else if(iSignal == TOKENRELEASE) + { + self->iGrab = 0; + } + else if(iSignal == TOKENGRAB) + { + self->iGrab = 1; + } + } +/*-----------------------------------------------------------------------*/ +void SCparChange(SConnection *self) +{ + if(!VerifyConnection(self)) + { + return; + } + self->parameterChange = 1; +} diff --git a/conman.h b/conman.h new file mode 100644 index 00000000..9dae9d1e --- /dev/null +++ b/conman.h @@ -0,0 +1,130 @@ + +/*-------------------------------------------------------------------------- + C O N N E C T I O N O B J E C T + + This file defines the connection object data structure and the interface to + this data structure. This is one of the most important SICS components. + + + Substantially revised from a prior version. + + Mark Koennecke, September 1997 + + copyright: see copyright.h +----------------------------------------------------------------------------*/ +#ifndef SICSCONNECT +#define SICSCONNECT +#include +#include "costa.h" +#include "SCinter.h" +#include "network.h" +#include "obdes.h" + +#define MAXLOGFILES 10 + +typedef int (*writeFunc)(struct __SConnection *pCon, + char *pMessage, int iCode); + + typedef struct __SConnection { + /* object basics */ + pObjectDescriptor pDes; + char *pName; + long lMagic; + + /* I/O control */ + mkChannel *pSock; + FILE *pFiles[MAXLOGFILES]; + int iMacro; + int iTelnet; + int iOutput; + int iFiles; + writeFunc write; + mkChannel *pDataSock; + char *pDataComp; + int iDataPort; + + /* execution context */ + int eInterrupt; + int iUserRights; + int inUse; + int iGrab; + SicsInterp *pSics; + + /* flag for parameter change */ + int parameterChange; + + /* a FIFO */ + pCosta pStack; + + /* callback registry */ + int iList; + + /* Tasking Stuff */ + int iEnd; + /* for keeping track of the login + process on a non telnet connection. + Should only be used in SCTaskFunction + */ + int iLogin; + time_t conStart; + }SConnection; + +#include "nserver.h" + +/*------------------------------ live & death ----------------------------*/ + SConnection *SCreateConnection(SicsInterp *pSics, mkChannel *pSock, + int iUserRights); + SConnection *SCCreateDummyConnection(SicsInterp *pSics); + void SCDeleteConnection(void *pVictim); + +/*------------------------------- tasking --------------------------------*/ + int SCTaskFunction(void *pCon); + void SCSignalFunction(void *pCon, int iSignal, void *pSigData); +/* ***************************** I/O ************************************** */ + int SCAddLogFile(SConnection *self, char *name); + int SCDelLogFile(SConnection *pCon, int iFile); + void SCSetOutputClass(SConnection *self, int iClass); + int SCWrite(SConnection *self, char *pBuffer, int iOut); + int SCRead(SConnection *self, char *pBuffer, int iBufLen); + int SCPrompt(SConnection *pCon, char *pPrompt, char *pResult, int iLen); + int SCSendOK(SConnection *self); + int SCnoSock(SConnection *pCon); + int SCWriteUUencoded(SConnection *pCon, char *pName, void *iData, int iLen); + int SCWriteZipped(SConnection *pCon, char *pName, void *pData, int iDataLen); + writeFunc SCGetWriteFunc(SConnection *pCon); + void SCSetWriteFunc(SConnection *pCon, writeFunc x); + int SCOnlySockWrite(SConnection *self, char *buffer, int iOut); + int SCNotWrite(SConnection *self, char *buffer, int iOut); +/************************* CallBack *********************************** */ + int SCRegister(SConnection *pCon, SicsInterp *pSics, + void *pInter, long lID); + int SCUnregister(SConnection *pCon, void *pInter); +/******************************* Interrupt *********************************/ + void SCSetInterrupt(SConnection *self, int eCode); + int SCGetInterrupt(SConnection *self); +/****************************** Macro ***************************************/ + int SCinMacro(SConnection *pCon); + int SCsetMacro(SConnection *pCon, int iMode); +/************************** parameters changed ? **************************/ + void SCparChange(SConnection *pCon); +/* *************************** Info *************************************** */ + int SCGetRights(SConnection *self); + int SCSetRights(SConnection *pCon, int iNew); + int SCMatchRights(SConnection *pCon, int iCode); + int SCGetOutClass(SConnection *self); + int SCGetGrab(SConnection *pCon); +/********************* simulation mode ************************************/ + void SCSetSimMode(SConnection *pCon, int value); + int SCinSimMode(SConnection *pCon); +/* **************************** Invocation ******************************** */ + int SCInvoke(SConnection *self,SicsInterp *pInter,char *pCommand); + +/*************************** User Command **********************************/ + int ConfigCon(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int ConSicsAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + + +#endif diff --git a/copyright.h b/copyright.h new file mode 100644 index 00000000..7db4ceb0 --- /dev/null +++ b/copyright.h @@ -0,0 +1,31 @@ +/*---------------------------------------------------------------------------- + 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. + + Author: Mark Koennecke + Laboratory for Neutron Scattering + Paul Scherrer Institut + CH-5232 Villigen-PSI + Switzerland + Mark.Koennecke@psi.ch +-----------------------------------------------------------------------------*/ diff --git a/costa.c b/costa.c new file mode 100644 index 00000000..54b1d36b --- /dev/null +++ b/costa.c @@ -0,0 +1,198 @@ +/*---------------------------------------------------------------------------- + C O S T A + + Implementation of a command stack for use with connection objects in + SICS + + Mark Koennecke, Septemeber 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 "costa.h" +#include "costa.i" + + +/*-------------------------------------------------------------------------*/ + pCosta CreateCommandStack(void) + { + pCosta pNew = NULL; + + pNew = (pCosta)malloc(sizeof(Costa)); + if(!pNew) + { + return NULL; + } + memset(pNew,0,sizeof(Costa)); + pNew->iList = LLDcreate(sizeof(char *)); + if(pNew->iList < 0) + { + free(pNew); + return NULL; + } + pNew->iCount = 0; + pNew->iMaxSize = INT_MAX; + return pNew; + } +/*-------------------------------------------------------------------------*/ + void DeleteCommandStack(pCosta self) + { + int iRet; + char *pPtr; + + assert(self); + + iRet = LLDnodePtr2First(self->iList); + while(iRet != 0) + { + pPtr = NULL; + LLDnodeDataTo(self->iList,&pPtr); + if(pPtr) + { + free(pPtr); + } + iRet = LLDnodePtr2Next(self->iList); + } + LLDdelete(self->iList); + free(self); + } +/*--------------------------------------------------------------------------*/ + int SetCommandStackMaxSize(pCosta self, int iNew) + { + assert(self); + + if(iNew > 0) + { + self->iMaxSize = iNew; + return 1; + } + else + { + return 0; + } + } +/*--------------------------------------------------------------------------*/ + int CostaTop(pCosta self, char *pCommand) + { + char *pPtr = NULL; + int iRet, iRes = 1; + + assert(self); + + /* check for lock */ + if(self->iLock) + { + return 0; + } + /* check Size */ + if(self->iCount >= self->iMaxSize) + { + return 0; + } + + /* do not want 0 commands */ + if(strlen(pCommand) < 1) + { + return 1; + } + + pPtr = strdup(pCommand); + iRet = LLDnodeAppendFrom(self->iList,&pPtr); + if(iRet < 0) + { + iRes = 0; + } + self->iCount++; + return iRes; + } +/*--------------------------------------------------------------------------*/ + int CostaBottom(pCosta self, char *pCommand) + { + char *pPtr = NULL; + int iRet, iRes = 1; + assert(self); + + /* check for lock */ + if(self->iLock) + { + return 0; + } + + /* do not want 0 commands */ + if(strlen(pCommand) < 1) + { + return 1; + } + + pPtr = strdup(pCommand); + iRet = LLDnodePrependFrom(self->iList,&pPtr); + if(iRet < 0) + { + iRes = 0; + } + self->iCount++; + return iRes; + } +/*--------------------------------------------------------------------------*/ + int CostaPop(pCosta self, char **pBuf) + { + char *pPtr = NULL; + int iRet; + + assert(self); + iRet = LLDnodePtr2First(self->iList); + if(iRet != 0) + { + LLDnodeDataTo(self->iList,&pPtr); + *pBuf = pPtr; + LLDnodeDelete(self->iList); + self->iCount--; + return 1; + } + *pBuf = NULL; + return 0; + } +/*--------------------------------------------------------------------------*/ + void CostaLock(pCosta self) + { + self->iLock = 1; + } +/*--------------------------------------------------------------------------*/ + void CostaUnlock(pCosta self) + { + self->iLock = 0; + } + \ No newline at end of file diff --git a/costa.h b/costa.h new file mode 100644 index 00000000..47bf3329 --- /dev/null +++ b/costa.h @@ -0,0 +1,29 @@ + +/*------------------------------------------------------------------------- + C O S T A + + A command stack implementation for SICS. To be used by each connection. + + Mark Koennecke, September 1997 + + copyright: see implementation file. + +----------------------------------------------------------------------------*/ +#ifndef SICSCOSTA +#define SICSCOSTA + + typedef struct __costa *pCosta; + +/*----------------------------- live & death ----------------------------*/ + pCosta CreateCommandStack(void); + void DeleteCommandStack(pCosta self); + int SetCommandStackMaxSize(pCosta self, int iNewSize); +/*----------------------------------------------------------------------*/ + int CostaTop(pCosta self, char *pCommand); + int CostaBottom(pCosta self, char *pCommand); + int CostaPop(pCosta self,char **pPtr); +/*----------------------------------------------------------------------*/ + void CostaLock(pCosta self); + void CostaUnlock(pCosta self); + +#endif diff --git a/costa.i b/costa.i new file mode 100644 index 00000000..3e765cd6 --- /dev/null +++ b/costa.i @@ -0,0 +1,15 @@ + +/*--------------------------------------------------------------------------- + C O S T A + Internal data structures for the command stack. +--------------------------------------------------------------------------*/ + + +/*------------------------------------------------------------------------*/ + typedef struct __costa { + int iLock; + int iList; + int iMaxSize; + int iCount; + } Costa; + diff --git a/costa.tex b/costa.tex new file mode 100644 index 00000000..2ac47c62 --- /dev/null +++ b/costa.tex @@ -0,0 +1,108 @@ +\subsection{The Command Stack} +This is a helper class to the connection class. +Each connection to a client has a command stack associated with it. The +command stack is a stack of command strings as generated by the SICS +clients. Commands are added to the top of the command queue by the network + reader. Each time the task associated with a connection runs one command +is popped from the command stack and executed. During execution the command +stack must be locked in order to prevent commands being accepted by tasks +busy waiting for some other process to finish. + +Correspondingly, the interface to the command stack looks like this: + +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap1} +$\langle$costaint {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ typedef struct __costa *pCosta;@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@/*----------------------------- live & death ----------------------------*/@\\ +\mbox{}\verb@ pCosta CreateCommandStack(void);@\\ +\mbox{}\verb@ void DeleteCommandStack(pCosta self);@\\ +\mbox{}\verb@ int SetCommandStackMaxSize(pCosta self, int iNewSize);@\\ +\mbox{}\verb@/*----------------------------------------------------------------------*/@\\ +\mbox{}\verb@ int CostaTop(pCosta self, char *pCommand);@\\ +\mbox{}\verb@ int CostaBottom(pCosta self, char *pCommand);@\\ +\mbox{}\verb@ int CostaPop(pCosta self,char **pPtr);@\\ +\mbox{}\verb@/*----------------------------------------------------------------------*/@\\ +\mbox{}\verb@ void CostaLock(pCosta self);@\\ +\mbox{}\verb@ void CostaUnlock(pCosta self);@\\ +\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} +Internally, two data structure need to be defined, the first for the +list implementing the command stack, the second for the command stack +itself. + +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap2} +$\langle$costadat {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@/*------------------------------------------------------------------------*/@\\ +\mbox{}\verb@ typedef struct __costa {@\\ +\mbox{}\verb@ int iLock;@\\ +\mbox{}\verb@ int iList;@\\ +\mbox{}\verb@ int iMaxSize;@\\ +\mbox{}\verb@ int iCount;@\\ +\mbox{}\verb@ } Costa;@\\ +\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@"costa.h"@ {\footnotesize ? }$\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@/*-------------------------------------------------------------------------@\\ +\mbox{}\verb@ C O S T A@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ A command stack implementation for SICS. To be used by each connection.@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ Mark Koennecke, September 1997@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ copyright: see implementation file.@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@----------------------------------------------------------------------------*/@\\ +\mbox{}\verb@#ifndef SICSCOSTA@\\ +\mbox{}\verb@#define SICSCOSTA@\\ +\mbox{}\verb@@$\langle$costaint {\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{scrap4} +\verb@"costa.i"@ {\footnotesize ? }$\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@/*---------------------------------------------------------------------------@\\ +\mbox{}\verb@ C O S T A@\\ +\mbox{}\verb@ Internal data structures for the command stack.@\\ +\mbox{}\verb@--------------------------------------------------------------------------*/@\\ +\mbox{}\verb@@$\langle$costadat {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@@$\diamond$ +\end{list} +\vspace{-2ex} +\end{minipage}\\[4ex] +\end{flushleft} diff --git a/costa.w b/costa.w new file mode 100644 index 00000000..cf10e868 --- /dev/null +++ b/costa.w @@ -0,0 +1,68 @@ +\subsection{The Command Stack} +This is a helper class to the connection class. +Each connection to a client has a command stack associated with it. The +command stack is a stack of command strings as generated by the SICS +clients. Commands are added to the top of the command queue by the network + reader. Each time the task associated with a connection runs one command +is popped from the command stack and executed. During execution the command +stack must be locked in order to prevent commands being accepted by tasks +busy waiting for some other process to finish. + +Correspondingly, the interface to the command stack looks like this: + +@d costaint @{ + typedef struct __costa *pCosta; + +/*----------------------------- live & death ----------------------------*/ + pCosta CreateCommandStack(void); + void DeleteCommandStack(pCosta self); + int SetCommandStackMaxSize(pCosta self, int iNewSize); +/*----------------------------------------------------------------------*/ + int CostaTop(pCosta self, char *pCommand); + int CostaBottom(pCosta self, char *pCommand); + int CostaPop(pCosta self,char **pPtr); +/*----------------------------------------------------------------------*/ + void CostaLock(pCosta self); + void CostaUnlock(pCosta self); +@} + +Internally, two data structure need to be defined, the first for the +list implementing the command stack, the second for the command stack +itself. + +@d costadat @{ + +/*------------------------------------------------------------------------*/ + typedef struct __costa { + int iLock; + int iList; + int iMaxSize; + int iCount; + } Costa; +@} + + +@o costa.h @{ +/*------------------------------------------------------------------------- + C O S T A + + A command stack implementation for SICS. To be used by each connection. + + Mark Koennecke, September 1997 + + copyright: see implementation file. + +----------------------------------------------------------------------------*/ +#ifndef SICSCOSTA +#define SICSCOSTA +@ +#endif +@} + +@o costa.i @{ +/*--------------------------------------------------------------------------- + C O S T A + Internal data structures for the command stack. +--------------------------------------------------------------------------*/ +@ +@} diff --git a/cotop.tcl b/cotop.tcl new file mode 100644 index 00000000..3ab9294a --- /dev/null +++ b/cotop.tcl @@ -0,0 +1,37 @@ +#-------------------------------------------------------------------------- +# A MAD lookalike co command for TOPSI +# All arguments are optional. The current values will be used if not +# specified +# Dr. Mark Koennecke, November 1999 +#-------------------------------------------------------------------------- +proc SplitReply { text } { + set l [split $text =] + return [lindex $l 1] +} +#-------------------------------------------------------------------------- +proc co { {mode NULL } { preset NULL } } { + starttime [sicstime] +#----- deal with mode + set mode2 [string toupper $mode] + set mode3 [string trim $mode2] + set mc [string index $mode2 0] + if { [string compare $mc T] == 0 } { + counter setMode Timer + } elseif { [string compare $mc M] == 0 } { + counter setMode Monitor + } +#------ deal with preset + if { [string compare $preset NULL] != 0 } { + set pre $preset + } else { + set pre [SplitReply [counter getpreset]] + } +#------ count + set ret [catch {counter count $pre} msg] + if { $ret != 0 } { + error [format "Counting ended with error: %s" $msg] + } else { + set cts [SplitReply [counter getcounts]] + } + return $cts +} diff --git a/countdriv.c b/countdriv.c new file mode 100644 index 00000000..bf421fa0 --- /dev/null +++ b/countdriv.c @@ -0,0 +1,752 @@ +/*------------------------------------------------------------------------ + G E N C O U N T + + Some general stuff for handling a CounterDriver. + + + 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 "fortify.h" +#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) + { + pCounterDriver pRes = NULL; + + pRes = (pCounterDriver)malloc(sizeof(CounterDriver)); + if(!pRes) + { + return NULL; + } + memset(pRes,0,sizeof(CounterDriver)); + + pRes->name = strdup(name); + pRes->type = strdup(type); + pRes->eMode = eTimer; + pRes->fPreset = 1000.; + pRes->fTime = 0.; + pRes->iNoOfMonitors = 0; + pRes->iPause = 0; + pRes->Start = NULL; + pRes->GetStatus = NULL; + pRes->ReadValues = NULL; + pRes->GetError = NULL; + pRes->TryAndFixIt = NULL; + pRes->Halt = NULL; + pRes->pData = NULL; + pRes->Pause = NULL; + pRes->Continue = NULL; + + return pRes; + } +/*-------------------------------------------------------------------------*/ + void DeleteCounterDriver(pCounterDriver self) + { + assert(self); + if(self->name) + { + free(self->name); + } + if(self->type) + { + free(self->type); + } + if(self->pData) + { + 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 new file mode 100644 index 00000000..9b0a05e3 --- /dev/null +++ b/countdriv.h @@ -0,0 +1,84 @@ +/*--------------------------------------------------------------------------- + C O U N T E R D R I V E R + + + This is the interface to a Sics-Counter driver. This means a + single counter managing possibly several monitors in one go. + + A counter can run for a predefined time or until a predefined + monitor count has been reached. + + Mark Koennecke, January 1996 + + General parameter setting added: + Mark Koennecke, April 1999 + + copyright: see implementation file. + + ---------------------------------------------------------------------------*/ +#ifndef SICSCOUNTERDRIVER +#define SICSCOUNTERDRIVER + +#define COTERM 0 +#define COREDO 1 + +#define MAXCOUNT 9 /* No of monitors + actual counter */ + + +/* Parameter codes for the Set/Get pair of routines */ +/*-------- threshold */ +#define PARTHRESHOLD 1 + +/* counter driver additional error codes*/ +#define UNKNOWNPAR -5000 +#define BADCOUNTER -5001 + + typedef struct __COUNTER { + /* variables */ + char *name; + char *type; + CounterMode eMode; + float fPreset; + float fLastCurrent; + float fTime; + int iNoOfMonitors; + long lCounts[MAXCOUNT]; + int iPause; + int iErrorCode; + /* functions */ + int (*GetStatus)(struct __COUNTER *self, float *fControl); + int (*Start)(struct __COUNTER *self); + int (*Pause)(struct __COUNTER *self); + int (*Continue)(struct __COUNTER *self); + int (*Halt)(struct __COUNTER *self); + int (*ReadValues)(struct __COUNTER *self); + int (*GetError)(struct __COUNTER *self, int *iCode, + char *error, int iErrLen); + int (*TryAndFixIt)(struct __COUNTER *self, int iCode); + int (*Set)(struct __COUNTER *self,char *name, + int iCter, float fVal); + int (*Get)(struct __COUNTER *self,char *name, + int iCter, float *fVal); + int (*Send)(struct __COUNTER *self, char *pText, + char *pReply, int iReplyLen); + void *pData; /* counter specific data goes here, ONLY for + internal driver use! + */ + } CounterDriver, *pCounterDriver; + +/*------------------------------------------------------------------------*/ + +/* countdriv.c */ + pCounterDriver CreateCounterDriver(char *name, char *type); + void DeleteCounterDriver(pCounterDriver self); + + /* PSI EL737 Counter */ + pCounterDriver NewEL737Counter(char *name, char *host, int iPort, + int iChannel); + void KillEL737Counter(pCounterDriver self); + + /* PSI Simulation counter, if you have no hardware */ +/* simcter.c */ + pCounterDriver NewSIMCounter(char *name, float fVal); + void KillSIMCounter(pCounterDriver self); +#endif diff --git a/counter.c b/counter.c new file mode 100644 index 00000000..72e0e849 --- /dev/null +++ b/counter.c @@ -0,0 +1,1117 @@ +/*------------------------------------------------------------------------- + + C O U N T E R + + The SICS Interface to a single detector and his associated + monitors. + + + 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 +#include "sics.h" +#include "countdriv.h" +#include "counter.h" +#include "fupa.h" +#include "status.h" +#include "splitter.h" +#include "ecbcounter.h" +/*-------------------------------------------------------------------------*/ + /* + The monitor callback data structure + */ + typedef struct { + float fPreset; + float fCurrent; + char *pName; + } MonEvent, *pMonEvent; + +/*--------------------------------------------------------------------------*/ + static int Halt(void *pData) + { + pCounter self = NULL; + + assert(pData); + self = (pCounter)pData; + + return self->pDriv->Halt(self->pDriv); + } +/*--------------------------------------------------------------------------*/ + static void SetCountParameters(void *pData, float fPreset, CounterMode eMode) + { + pCounter self = NULL; + + assert(pData); + self = (pCounter)pData; + + self->pDriv->fPreset = fPreset; + self->pDriv->eMode = eMode; + } +/*-----------------------------------------------------------------------*/ + static int StartCount(void *pData, SConnection *pCon) + { + pCounter self; + char pBueffel[132]; + char pError[80]; + int iRet; + int i; + int iErr; + time_t tX; + + self = (pCounter)pData; + assert(self); + + /* try at least three times to do it */ + for(i = 0; i < 3; i++) + { + iRet = self->pDriv->Start(self->pDriv); + if(iRet == OKOK) + { + self->isUpToDate = 0; + self->tStart = time(&tX); + return iRet; + } + else + { + iRet = self->pDriv->GetError(self->pDriv,&iErr,pError,79); + sprintf(pBueffel,"WARNING: %s ",pError); + SCWrite(pCon,pBueffel,eError); + iRet = self->pDriv->TryAndFixIt(self->pDriv,iErr); + if(iRet == COTERM) + { + SCWrite(pCon,"ERROR: Cannot fix counter problem, aborting",eError); + SCSetInterrupt(pCon,eAbortBatch); + return HWFault; + } + } + } + SCWrite(pCon,"ERROR: Cannot fix counter problem, aborting",eError); + SCSetInterrupt(pCon,eAbortBatch); + return HWFault; + } +/*-----------------------------------------------------------------------*/ + static int PauseCount(void *pData, SConnection *pCon) + { + pCounter self; + char pBueffel[132]; + char pError[80]; + int iRet; + int i; + int iErr; + + self = (pCounter)pData; + assert(self); + + /* try at least three times to do it */ + for(i = 0; i < 3; i++) + { + iRet = self->pDriv->Pause(self->pDriv); + if(iRet == OKOK) + { + self->isUpToDate = 0; + return iRet; + } + else + { + iRet = self->pDriv->GetError(self->pDriv,&iErr,pError,79); + sprintf(pBueffel,"WARNING: %s ",pError); + SCWrite(pCon,pBueffel,eError); + iRet = self->pDriv->TryAndFixIt(self->pDriv,iErr); + if(iRet == COTERM) + { + SCWrite(pCon,"ERROR: Cannot fix counter problem, aborting",eError); + SCSetInterrupt(pCon,eAbortBatch); + return HWFault; + } + } + } + SCWrite(pCon,"ERROR: Cannot fix counter problem, aborting",eError); + SCSetInterrupt(pCon,eAbortBatch); + return HWFault; + } +/*-----------------------------------------------------------------------*/ + static int ContinueCount(void *pData, SConnection *pCon) + { + pCounter self; + char pBueffel[132]; + char pError[80]; + int iRet; + int i; + int iErr; + + self = (pCounter)pData; + assert(self); + + /* try at least three times to do it */ + for(i = 0; i < 3; i++) + { + iRet = self->pDriv->Continue(self->pDriv); + if(iRet == OKOK) + { + self->isUpToDate = 0; + return iRet; + } + else + { + iRet = self->pDriv->GetError(self->pDriv,&iErr,pError,79); + sprintf(pBueffel,"WARNING: %s ",pError); + SCWrite(pCon,pBueffel,eError); + iRet = self->pDriv->TryAndFixIt(self->pDriv,iErr); + if(iRet == COTERM) + { + SCWrite(pCon,"ERROR: Cannot fix counter problem, aborting",eError); + SCSetInterrupt(pCon,eAbortBatch); + return HWFault; + } + } + } + SCWrite(pCon,"ERROR: Cannot fix counter problem, aborting",eError); + SCSetInterrupt(pCon,eAbortBatch); + return HWFault; + } +/*--------------------------------------------------------------------------*/ + static int CheckCountStatus(void *pData, SConnection *pCon) + { + pCounter self = NULL; + int i, iRet; + int eCt; + char pError[80], pBueffel[132]; + int iErr; + float fControl; + MonEvent sMon; + + self = (pCounter)pData; + assert(self); + assert(pCon); + + eCt = self->pDriv->GetStatus(self->pDriv,&fControl); + if(eCt == HWFault) + { + iRet = self->pDriv->GetError(self->pDriv,&iErr,pError,79); + sprintf(pBueffel,"WARNING: %s ",pError); + SCWrite(pCon,pBueffel,eError); + iRet = self->pDriv->TryAndFixIt(self->pDriv,iErr); + if(iRet == COTERM) + { + SCWrite(pCon,"ERROR: Cannot fix counter problem, aborting",eError); + SCSetInterrupt(pCon,eAbortBatch); + return eCt; + } + else + { + return HWBusy; + } + } + sMon.fCurrent = fControl; + sMon.fPreset = self->pDriv->fPreset; + sMon.pName = self->name; + if(self->iCallbackCounter > 20) + { + InvokeCallBack(self->pCall,MONITOR,&sMon); + self->iCallbackCounter = 0; + } + else + { + self->iCallbackCounter++; + } + self->pDriv->fLastCurrent = fControl; + return eCt; + } +/*------------------------------------------------------------------------*/ + static int SaveCounterStatus(void *pData, char *name, FILE *fd) + { + pCounter self = NULL; + char pBueffel[512]; + + assert(pData); + assert(fd); + + self = (pCounter)pData; + + sprintf(pBueffel,"# Counter %s\n",name); + fputs(pBueffel,fd); + sprintf(pBueffel,"%s SetPreset %f\n",name, self->pDriv->fPreset); + fputs(pBueffel,fd); + if(self->pDriv->eMode == eTimer) + { + sprintf(pBueffel,"%s SetMode Timer\n",name); + } + else + { + sprintf(pBueffel,"%s SetMode Monitor\n",name); + } + fputs(pBueffel,fd); + + return 1; + } +/*------------------------------------------------------------------------*/ + static int TransferData(void *pData, SConnection *pCon) + { + pCounter self = NULL; + int i, iRet; + char pError[80]; + char pBueffel[132]; + int iCode; + + self = (pCounter)pData; + assert(self); + assert(pCon); + + /* try three times */ + for(i = 0; i < 3; i++) + { + iRet = self->pDriv->ReadValues(self->pDriv); + if(iRet) + { + self->isUpToDate = 1; + return OKOK; + } + else + { + self->pDriv->GetError(self->pDriv,&iCode,pError,79); + sprintf(pBueffel,"WARNING: %s",pError); + SCWrite(pCon,pBueffel,eError); + iRet = self->pDriv->TryAndFixIt(self->pDriv,iCode); + if(iRet == COTERM) + { + SCWrite(pCon,"ERROR: Cannot fix counter problem, aborting",eError); + SCSetInterrupt(pCon,eAbortBatch); + return HWFault; + } + } + } + SCWrite(pCon,"ERROR: Cannot fix counter problem, aborting",eError); + SCSetInterrupt(pCon,eAbortBatch); + return HWFault; + } +/*------------------------------------------------------------------------*/ + static void *CounterGetInterface(void *pData, int iID) + { + pCounter self = NULL; + + self = (pCounter)pData; + assert(self); + if(iID == COUNTID) + { + return self->pCountInt; + } + else if(iID == CALLBACKINTERFACE) + { + return self->pCall; + } + return NULL; + } +/*------------------------------------------------------------------------*/ + pCounter CreateCounter(char *name, pCounterDriver pDriv) + { + pCounter pRes = NULL; + + assert(pDriv); + + pRes = (pCounter)malloc(sizeof(Counter)); + if(!pRes) + { + return NULL; + } + pRes->pDes = CreateDescriptor("SingleCounter"); + if(!pRes->pDes) + { + free(pRes); + return NULL; + } + /* initialize Descriptor functions */ + pRes->pDes->GetInterface = CounterGetInterface; + pRes->pDes->SaveStatus = SaveCounterStatus; + + /* initialise countable interface */ + pRes->pCountInt = CreateCountableInterface(); + if(!pRes->pCountInt) + { + DeleteDescriptor(pRes->pDes); + free(pRes); + return NULL; + } + pRes->pCountInt->SetCountParameters = SetCountParameters; + pRes->pCountInt->StartCount = StartCount; + pRes->pCountInt->CheckCountStatus = CheckCountStatus; + pRes->pCountInt->TransferData = TransferData; + pRes->pCountInt->Halt = Halt; + pRes->pCountInt->Pause = PauseCount; + pRes->pCountInt->Continue = ContinueCount; + pRes->iCallbackCounter = 20; + + pRes->pCall = CreateCallBackInterface(); + + pRes->pDriv = pDriv; + pRes->isUpToDate = 1; + pRes->iExponent = 0; + pRes->name = strdup(name); + return pRes; + } +/*---------------------------------------------------------------------------*/ + void DeleteCounter(void *pData) + { + pCounter self = NULL; + + assert(pData); + self = (pCounter)pData; + + if(self->pDes) + { + DeleteDescriptor(self->pDes); + } + + if(self->pCountInt) + { + free(self->pCountInt); + } + if(self->pCall) + { + DeleteCallBackInterface(self->pCall); + } + + if(self->name) + { + free(self->name); + } + 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); + } + } + free(self); + } +/*-------------------------------------------------------------------------*/ + int DoCount(pCounter self, float fPreset, SConnection *pCon, + int iBlock) + { + int iRet; + char pBueffel[132]; + Status eOld; + + assert(self); + + /* check authorisation */ + if(!SCMatchRights(pCon,usUser)) + { + sprintf(pBueffel,"ERROR: you are not authorised to count"); + SCWrite(pCon, pBueffel, eError); + return 0; + } + + eOld = GetStatus(); + SetStatus(eCounting); + + /* set Preset */ + SetCounterPreset(self,fPreset); + + iRet = StartDevice(GetExecutor(),self->name,self->pDes,self,pCon, + self->pDriv->fPreset); + if(!iRet) + { + SetStatus(eOld); + SCWrite(pCon,"Counting aborted",eStatus); + return 0; + } + + /* continue only if in blocking mode */ + if(!iBlock) + { + return 1; + } + + /* wait forever until done or interrupted */ + iRet = Wait4Success(GetExecutor()); + if(iRet == DEVINT) + { + SCWrite(pCon,"Counting aborted due to Interrupt",eStatus); + } + else if(iRet == DEVERROR) + { + SCWrite(pCon,"Counting finished with Problems",eStatus); + iRet = 1; + } + else + { + SCWrite(pCon,"Counting finished",eStatus); + iRet = 1; + } + SetStatus(eOld); + return iRet; + } + +/*-------------------------------------------------------------------------*/ + + int MakeCounter(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + pCounter pNew = NULL; + pCounterDriver pDriv = NULL; + int iRet; + char pBueffel[256]; + char **argx; + FuPaResult pParse; + FuncTemplate MakeTemplate[] = { + {"el737",3,{FUPATEXT,FUPAINT,FUPAINT}}, + {"sim",1,{FUPAFLOAT}}, + {"ecb",1,{FUPATEXT}} + }; + + 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); + 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 */ + } + if(!pDriv) + { + sprintf(pBueffel,"ERROR: cannot create requested driver %s", + argv[2]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + /* create Counter and command */ + pNew = CreateCounter(argv[1],pDriv); + if(!pNew) + { + sprintf(pBueffel,"ERROR: cannot create counter %s", + argv[1]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + iRet = AddCommand(pSics,argv[1],CountAction,DeleteCounter,(void *)pNew); + if(!iRet) + { + sprintf(pBueffel,"ERROR: duplicate command %s not created",argv[1]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + return 1; + } +/* --------------------------------------------------------------------------*/ + int SetCounterMode(pCounter self, CounterMode eNew) + { + int i; + + assert(self); + if(eNew == self->pDriv->eMode) + { + return 1; + } + + if(eNew == eTimer) + { + for(i = 0; i < self->iExponent; i++) + { + self->pDriv->fPreset /= 10.; + } + } + if(eNew == ePreset) + { + for(i = 0; i < self->iExponent; i++) + { + self->pDriv->fPreset *= 10.; + } + } + self->pDriv->eMode = eNew; + return 1; + } +/*--------------------------------------------------------------------------*/ + CounterMode GetCounterMode(pCounter self) + { + assert(self); + return self->pDriv->eMode; + } +/*------------------------------------------------------------------------*/ + int GetNMonitor(pCounter self) + { + assert(self); + return self->pDriv->iNoOfMonitors; + } +#ifdef NONINTF + extern float nintf(float f); +#endif +/*------------------------------------------------------------------------*/ + int SetCounterPreset(pCounter self, float fVal) + { + int i; + + assert(self); + + if(fVal < .0) + { + return 0; + } + if(GetCounterMode(self) == ePreset) + { + for(i = 0; i < self->iExponent;i++) + { + fVal *= 10.; + } + fVal = nintf(fVal); + } + self->pDriv->fPreset = fVal; + return 1; + } +/*------------------------------------------------------------------------*/ + float GetCounterPreset(pCounter self) + { + int i; + float fVal; + + assert(self); + + fVal = self->pDriv->fPreset; + if(self->pDriv->eMode == ePreset) + { + for(i = 0; i < self->iExponent; i++) + { + fVal /= 10.; + } + } + return fVal; + } +/*-----------------------------------------------------------------------*/ + long GetCounts(pCounter self, SConnection *pCon) + { + assert(self); + if(!self->isUpToDate) + { + self->pCountInt->TransferData(self,pCon); + } + return self->pDriv->lCounts[0]; + } +/*------------------------------------------------------------------------*/ + long GetMonitor(pCounter self, int iNum, SConnection *pCon) + { + assert(self); + + if(!self->isUpToDate) + { + self->pCountInt->TransferData(self,pCon); + } + if( (iNum < 0) || (iNum > self->pDriv->iNoOfMonitors) ) + { + return -1L; + } + else + { + return self->pDriv->lCounts[iNum]; + } + } +/*------------------------------------------------------------------------*/ + float GetCountTime(pCounter self,SConnection *pCon) + { + assert(self); + + if(!self->isUpToDate) + { + self->pCountInt->TransferData(self,pCon); + } + return self->pDriv->fTime; + } +/*----------------------------------------------------------------------*/ + static int isAuthorised(SConnection *pCon, int iCode) + { + char pBueffel[132]; + + if(!SCMatchRights(pCon,iCode)) + { + sprintf(pBueffel,"ERROR: you are not authorised to count"); + SCWrite(pCon, pBueffel, eError); + return 0; + } + return 1; + } +/*-----------------------------------------------------------------------*/ + static int CounterInterest(int iEvent, void *pEvent, void *pUser) + { + SConnection *pCon = NULL; + pMonEvent pMon = NULL; + char pBueffel[512]; + + if(iEvent != MONITOR) + { + return 0; + } + + pCon = (SConnection *)pUser; + pMon = (pMonEvent)pEvent; + assert(pCon); + assert(pMon); + sprintf(pBueffel,"%s.CountStatus = %f %d",pMon->pName,pMon->fPreset, + (int)nintf(pMon->fCurrent)); + SCWrite(pCon,pBueffel,eWarning); + return 1; + } +/*-----------------------------------------------------------------------*/ + + int CountAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + pCounter self = NULL; + int iRet, iRet2; + FuPaResult PaRes; + char pBueffel[256], pError[80]; + char **argx; + float fVal; + long lVal; + long lID; + CounterMode eMode; + FuncTemplate ActionTemplate[] = { + {"count",1,{FUPAFLOAT} }, + {"getpreset",0,{0.0} }, + {"setpreset",1,{FUPAFLOAT}}, + {"getmode",0,{0,0}}, + {"setmode",1,{FUPATEXT}}, + {"getcounts",0,{0,0}}, + {"getmonitor",1,{FUPAINT,0}}, + {"setexponent",1,{FUPAINT,0}}, + {"getexponent",0,{0,0}}, + {"interest",0,{0,0}}, + {"uninterest",0,{0,0}}, + {"status",0,{0,0}}, + {"gettime",0,{0,0}}, + {"countnb",1,{FUPAFLOAT} }, + {"getthreshold",1,{FUPAINT}}, + {"setthreshold",2,{FUPAINT,FUPAFLOAT}}, + {"stop",0,{0,0}}, + {"mode",1,{FUPAOPT}}, + {"preset",1,{FUPAOPT}}, + {"send",0,{0,0}}, + {"setpar",3,{FUPATEXT,FUPAINT,FUPAFLOAT}}, + {"getpar",2,{FUPATEXT,FUPAOPT}} + }; + char *pMode[] = { + "timer", + "monitor", + NULL + }; + + self = (pCounter)pData; + assert(self); + assert(pCon); + assert(pSics); + + /* parse function args */ + argtolower(argc,argv); + argx = &argv[1]; + iRet = EvaluateFuPa((pFuncTemplate)&ActionTemplate,22,argc-1,argx,&PaRes); + if(iRet < 0) + { + sprintf(pBueffel,"%s",PaRes.pError); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + /* do something! */ + switch(iRet) + { + case 0: /* Count */ + return DoCount(self,PaRes.Arg[0].fVal,pCon,1); + break; + case 1: /* GetPreset */ + fVal = GetCounterPreset(self); + sprintf(pBueffel,"%s.Preset = %f",argv[0],fVal); + SCWrite(pCon,pBueffel,eValue); + return 1; + break; + case 2: /* Set Preset */ + if(isAuthorised(pCon,usUser)) + { + iRet2 = SetCounterPreset(self,PaRes.Arg[0].fVal); + SCparChange(pCon); + if(iRet2) + SCSendOK(pCon); + return iRet2; + } + else + { + return 0; + } + break; + case 3: /* GetMode */ + eMode = GetCounterMode(self); + if(eMode == eTimer) + { + sprintf(pBueffel,"%s.Mode = Timer",argv[0]); + } + else + { + sprintf(pBueffel,"%s.Mode = Monitor",argv[0]); + } + SCWrite(pCon,pBueffel,eValue); + return 1; + break; + case 4: /* Set Mode */ + if(isAuthorised(pCon,usUser)) + { + if(strcmp(PaRes.Arg[0].text,"timer") == 0) + { + SetCounterMode(self,eTimer); + SCparChange(pCon); + SCSendOK(pCon); + return 1; + } + else if(strcmp(PaRes.Arg[0].text,"monitor") == 0) + { + SetCounterMode(self,ePreset); + SCparChange(pCon); + SCSendOK(pCon); + return 1; + } + else + { + sprintf(pBueffel,"ERROR: %s not recognized as valid counter mode", + PaRes.Arg[0].text); + SCWrite(pCon,pBueffel,eError); + return 0; + } + } + else + { + return 0; + } + case 5: /* GetCounts */ + lVal = GetCounts(self,pCon); + sprintf(pBueffel,"%s.Counts = %ld",argv[0],lVal); + SCWrite(pCon,pBueffel,eValue); + return 1; + + case 6: /* GetMonitor */ + lVal = GetMonitor(self,PaRes.Arg[0].iVal,pCon); + if(lVal < 0) + { + sprintf(pBueffel,"ERROR: %d out of range for monitors", + PaRes.Arg[0].iVal); + SCWrite(pCon,pBueffel,eError); + return 0; + } + sprintf(pBueffel,"%s.Monitor %d = %ld",argv[0],PaRes.Arg[0].iVal, + lVal); + SCWrite(pCon,pBueffel,eValue); + return 1; + case 7: /* SetExponent */ + if(!SCMatchRights(pCon,usMugger)) + { + return 0; + } + self->iExponent = PaRes.Arg[0].iVal; + SCparChange(pCon); + SCSendOK(pCon); + return 1; + case 8: /* GetExponent */ + sprintf(pBueffel,"%s.Exponent = %d",argv[0], self->iExponent); + SCWrite(pCon,pBueffel,eValue); + return 1; + case 9: /* interest */ + lID = RegisterCallback(self->pCall, MONITOR, CounterInterest, + pCon, NULL); + SCRegister(pCon,pSics, self->pCall,lID); + SCSendOK(pCon); + return 1; + case 10: /* uninterest */ + RemoveCallback2(self->pCall,pCon); + SCSendOK(pCon); + return 1; + case 11: /* status */ + if(GetCounterMode(self) == ePreset) + { + sprintf(pBueffel,"%s.CountStatus = %d %d Beam: %ld E6", + argv[0], + (int)nintf(self->pDriv->fPreset), + (int)nintf(self->pDriv->fLastCurrent), + GetMonitor(self,4,pCon)/100000); + } + else + { + sprintf(pBueffel,"%s.CountStatus = %8.2f %8.2f Beam %ld E6", + argv[0], + self->pDriv->fPreset, + self->pDriv->fLastCurrent, + GetMonitor(self,4,pCon)/100000); + } + SCWrite(pCon,pBueffel,eValue); + return 1; + case 12: /* gettime */ + fVal = GetCountTime(self,pCon); + sprintf(pBueffel,"%s.CountTime = %f",argv[0],fVal); + SCWrite(pCon,pBueffel,eValue); + return 1; + case 13: + /* countnb, non blocking count */ + return DoCount(self,PaRes.Arg[0].fVal,pCon,0); + break; + case 14: + /* get threshold value */ + iRet = self->pDriv->Get(self->pDriv,"threshold", + PaRes.Arg[0].iVal,&fVal); + if(iRet <= 0) + { + self->pDriv->GetError(self->pDriv,&iRet, + pError,79); + sprintf(pBueffel,"ERROR: %s",pError); + SCWrite(pCon,pBueffel,eError); + return 0; + } + else + { + sprintf(pBueffel,"%s.threshold%1.1d = %f", + argv[0],PaRes.Arg[0].iVal,fVal); + SCWrite(pCon,pBueffel,eValue); + return 1; + } + break; + case 15: + if(!SCMatchRights(pCon,usMugger)) + { + SCWrite(pCon, + "ERROR: Insufficient privilege to set threshold",eError); + return 0; + } + if(isInRunMode(pServ->pExecutor)) + { + SCWrite(pCon, + "ERROR: cannot change threshold while instrument is active", + eError); + return 0; + } + /* set threshold value */ + iRet = self->pDriv->Set(self->pDriv,"threshold", + PaRes.Arg[0].iVal,PaRes.Arg[1].fVal); + if(iRet <= 0) + { + self->pDriv->GetError(self->pDriv,&iRet, + pError,79); + sprintf(pBueffel,"ERROR: %s",pError); + SCWrite(pCon,pBueffel,eError); + return 0; + } + else + { + SCparChange(pCon); + SCSendOK(pCon); + return 1; + } + break; + case 16: + /* stop */ + if(!SCMatchRights(pCon,usUser)) + { + return 0; + } + self->pCountInt->Halt(self); + SCSendOK(pCon); + return 1; + case 17: + /* mode */ + if(PaRes.Arg[0].iVal) /* set case */ + { + if(isAuthorised(pCon,usUser)) + { + if(strcmp(PaRes.Arg[0].text,"timer") == 0) + { + SetCounterMode(self,eTimer); + SCparChange(pCon); + SCSendOK(pCon); + return 1; + } + else if(strcmp(PaRes.Arg[0].text,"monitor") == 0) + { + SetCounterMode(self,ePreset); + SCparChange(pCon); + SCSendOK(pCon); + return 1; + } + else + { + sprintf(pBueffel, + "ERROR: %s not recognized as valid counter mode", + PaRes.Arg[0].text); + SCWrite(pCon,pBueffel,eError); + return 0; + } + } + } + else /* get case */ + { + eMode = GetCounterMode(self); + if(eMode == eTimer) + { + sprintf(pBueffel,"%s.Mode = Timer",argv[0]); + } + else + { + sprintf(pBueffel,"%s.Mode = Monitor",argv[0]); + } + SCWrite(pCon,pBueffel,eValue); + return 1; + break; + } + break; + case 18: /* preset */ + if(PaRes.Arg[0].iVal) /* set case */ + { + if(isAuthorised(pCon,usUser)) + { + iRet2 = SetCounterPreset(self,PaRes.Arg[0].fVal); + if(iRet2) + SCSendOK(pCon); + SCparChange(pCon); + return iRet2; + } + else + { + return 0; + } + } + else /* read case */ + { + fVal = GetCounterPreset(self); + sprintf(pBueffel,"%s.Preset = %f",argv[0],fVal); + SCWrite(pCon,pBueffel,eValue); + return 1; + } + break; + case 19: /* send */ + /* only manager may use this */ + if(!SCMatchRights(pCon,usMugger)) + { + return 0; + } + Arg2Text(argc-2,&argv[2],pError,79); + iRet = self->pDriv->Send(self->pDriv,pError,pBueffel,255); + if(iRet == 1) + { + SCWrite(pCon,pBueffel,eValue); + return 1; + } + else + { + self->pDriv->GetError(self->pDriv,&iRet,pError,79); + SCWrite(pCon,pError,eError); + return 0; + } + break; + case 20: /* setpar*/ + if(!SCMatchRights(pCon,usMugger)) + { + return 0; + } + iRet = self->pDriv->Set(self->pDriv,PaRes.Arg[0].text, + PaRes.Arg[1].iVal, PaRes.Arg[2].fVal); + if(iRet == 1) + { + SCparChange(pCon); + SCSendOK(pCon); + return 1; + } + else + { + self->pDriv->GetError(self->pDriv,&iRet,pError,79); + SCWrite(pCon,pError,eError); + return 0; + } + break; + case 21: /* getpar*/ + if(!SCMatchRights(pCon,usMugger)) + { + return 0; + } + iRet = self->pDriv->Get(self->pDriv,PaRes.Arg[0].text, + PaRes.Arg[1].iVal, &fVal); + if(iRet == 1) + { + sprintf(pBueffel,"%s.%s %d = %f",argv[0],PaRes.Arg[0].text, + PaRes.Arg[1].iVal, fVal); + SCWrite(pCon,pBueffel,eValue); + return 1; + } + else + { + self->pDriv->GetError(self->pDriv,&iRet,pError,79); + SCWrite(pCon,pError,eError); + return 0; + } + break; + default: + assert(0); /* internal error */ + } + return 0; + } + + diff --git a/counter.h b/counter.h new file mode 100644 index 00000000..bdefc49c --- /dev/null +++ b/counter.h @@ -0,0 +1,57 @@ +/*------------------------------------------------------------------------- + + C O U N T E R + + The SICS Interface to a single detector and his associated + monitors. + + Mark Koennecke, January 1996 + + copyright: see implementation file. +----------------------------------------------------------------------------*/ +#ifndef SICSCOUNTER +#define SICSCOUNTER +#include "countdriv.h" + + typedef struct { + pObjectDescriptor pDes; + char *name; + int isUpToDate; + int iExponent; + pICountable pCountInt; + pCounterDriver pDriv; + pICallBack pCall; + unsigned long tStart; + int iCallbackCounter; + } Counter, *pCounter; + +/*----------------------------- birth & death -----------------------------*/ + + pCounter CreateCounter(char *name, pCounterDriver pDriv); + void DeleteCounter(void *self); + int MakeCounter(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); +/*------------------------- set/get Parameters ----------------------------*/ + int SetCounterMode(pCounter self, CounterMode eNew); + CounterMode GetCounterMode(pCounter self); + + int SetCounterPreset(pCounter self, float fVal); + float GetCounterPreset(pCounter self); + + long GetCounts(pCounter self, SConnection *pCon); + long GetMonitor(pCounter self, int iNum, SConnection *pCon); + int GetNMonitor(pCounter self); + float GetCountTime(pCounter self, SConnection *pCon); + + int DoCount(pCounter self,float fPreset, SConnection *pCon, + int iBlock); + +/*------------------------------------------------------------------------- + the real action: starting and checking is packaged with the + ObjectDescriptor. +*/ + + int CountAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + +#endif diff --git a/countf.tcl b/countf.tcl new file mode 100644 index 00000000..a627ae0a --- /dev/null +++ b/countf.tcl @@ -0,0 +1,50 @@ +#-------------------------------------------------------------------------- +# A count command for FOCUS +# All arguments are optional. The current values will be used if not +# specified +# Dr. Mark Koennecke, Juli 1997 +#-------------------------------------------------------------------------- +proc SplitReply { text } { + set l [split $text =] + return [lindex $l 1] +} +#-------------------------------------------------------------------------- +proc count { {mode NULL } { preset NULL } } { + starttime [sicstime] +#----- deal with mode + set mode2 [string toupper $mode] + set mode3 [string trim $mode2] + set mc [string index $mode2 0] + if { [string compare $mc T] == 0 } { + hm CountMode Timer + } elseif { [string compare $mc M] == 0 } { + hm CountMode Monitor + } +#------ deal with preset + if { [string compare $preset NULL] != 0 } { + hm preset $preset + } +#------ prepare a count message + set a [hm preset] + set aa [SplitReply $a] + set b [hm CountMode] + set bb [SplitReply $b] + ClientPut [format " Starting counting in %s mode with a preset of %s" \ + $bb $aa] +#------- count +# hm InitVal 0 + wait 1 + set ret [catch {hm countblock} msg] +#------- StoreData + storefocus update +# wait 5 + if { $ret != 0 } { + error [format "Counting ended with error: %s" $msg] + } +} +#---------------- Repeat ----------------------------------------------- +proc repeat { num {mode NULL} {preset NULL} } { + for { set i 0 } { $i < $num } { incr i } { + count $mode $preset + } +} diff --git a/cron.tex b/cron.tex new file mode 100644 index 00000000..1607bcc8 --- /dev/null +++ b/cron.tex @@ -0,0 +1,16 @@ +\subsection{cron} +This module allows to install commands into SICS which will be repeated + periodically. The syntax is: sicscron intervall command. intervall is +the time intervall and command is the command to execute. A problem +is I/O becasue the original connection which installed the cron job +may be lost. Therefore cron commands are executed within the context +of special connection which does not do socket output. All I/O will be +logged into the command log though for control. As +this is a single system facility all data structure will be defined +in the implementation file. The public interface to this is just the +installation routine. This stuff is implemented in the files +sicscron.h and sicscron.c. + +The installation routine installs another task into the SICS system +which will invoke the command to be executed at the predefined +intervalls. diff --git a/cron.w b/cron.w new file mode 100644 index 00000000..1607bcc8 --- /dev/null +++ b/cron.w @@ -0,0 +1,16 @@ +\subsection{cron} +This module allows to install commands into SICS which will be repeated + periodically. The syntax is: sicscron intervall command. intervall is +the time intervall and command is the command to execute. A problem +is I/O becasue the original connection which installed the cron job +may be lost. Therefore cron commands are executed within the context +of special connection which does not do socket output. All I/O will be +logged into the command log though for control. As +this is a single system facility all data structure will be defined +in the implementation file. The public interface to this is just the +installation routine. This stuff is implemented in the files +sicscron.h and sicscron.c. + +The installation routine installs another task into the SICS system +which will invoke the command to be executed at the predefined +intervalls. diff --git a/crysconv.c b/crysconv.c new file mode 100644 index 00000000..64def425 --- /dev/null +++ b/crysconv.c @@ -0,0 +1,538 @@ +/* crysconv.f -- translated by f2c (version 20000817). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +#include "f2c.h" + +/* Common Block Declarations */ + +struct { + doublereal s[16] /* was [4][4] */, sinv[16] /* was [4][4] */; + integer iok; +} osolem_; + +#define osolem_1 osolem_ + +/* ================ */ + +/* dec$ Ident 'V01A' */ +/* ------------------------------------------------------------------ */ +/* Updates: */ +/* V01A 7-May-1996 DM. Put error output to IOLUN, use IMPLICIT NONE and */ +/* get the code indented so that it is readable! */ +/* made F77 compliant. Mark Koennecke July 1996 */ +/* ------------------------------------------------------------------ */ +/* Routines to deal with the reciprocical lattice PB */ +/* ------------------------------------------------------------------ */ +/* Entry points in this file: */ + +/* SETRLP : CALCULATION OF S AND INVS , ORIENTATION MATRIX */ +/* RL2SPV : TRANSFO FROM RECIP LAT TO SCAT PLANE */ +/* SP2RLV : TRANSFO FROM SCAT PLANE TO RECIP LAT */ +/* INVS : INVERT MATRIX S, GENERATED BY SETRLP. */ +/* ERRESO : DEAL ITH ERROR MESSAGES FOR ALL MODULES */ + +/* SUBROUTINE SETRLP(SAM,IER) */ +/* SUBROUTINE RL2SPV(QHKL,QT,QM,QS,IER) */ +/* SUBROUTINE SP2RLV(QHKL,QT,QM,QS,IER) */ +/* SUBROUTINE INVS(S,SINV,IER) */ +/* SUBROUTINE ERRESO(MODULE,IER) */ +/* ------------------------------------------------------------------ */ +/* Subroutine */ int setrlp_(doublereal *sam, integer *ier) +{ + /* System generated locals */ + doublereal d__1; + + /* Builtin functions */ + double cos(doublereal), sin(doublereal), sqrt(doublereal), atan( + doublereal); + + /* Local variables */ + static doublereal alfa[3], cosa[3], cosb[3]; + static integer imod; + static doublereal sina[3], sinb[3], aspv[6] /* was [3][2] */; + extern /* Subroutine */ int invs_(doublereal *, doublereal *, integer *); + static doublereal a[3], b[3], c__[3], bb[9] /* was [3][3] */, cc; + static integer id, ie, jd, je, jf, kg, lf, lh, md, me, ne; + static doublereal zp, vv[9] /* was [3][3] */; + extern /* Subroutine */ int erreso_(integer *, integer *); + static doublereal rlb[6] /* was [3][2] */; + +/* ============================ */ + +/* SETRLP: Computation of matrix S which transforms (QH,QK,QL) to */ +/* vector (Q1,Q2) in scattering plane (defined by vectors A1,A2) */ +/* and SINV matrix for the inverse transformation */ + +/* INPUT SAM SAMPLE CHARACTERISTICS */ +/* SAM(1)=AS LATTICE PARAMETERS */ +/* SAM(2)=BS ------------------ */ +/* SAM(3)=CS ------------------ */ +/* SAM(4)=AA LATTICE ANGLES */ +/* SAM(5)=BB -------------- */ +/* SAM(6)=CC -------------- */ +/* SAM(7)=AX VECTOR A IN SCATTERING PLANE */ +/* SAM(8)=AY ---------------------------- */ +/* SAM(9)=AZ ---------------------------- */ +/* SAM(10)=BX VECTOR B IN SCATTERING PLANE */ +/* SAM(11)=BY ---------------------------- */ +/* SAM(12)=BZ ---------------------------- */ +/* OUTPUT IER ERROR RETURN TO BE TREATED BY ERRESO */ +/* IER=1 ERROR ON LATTICE PARAMETERS */ +/* IER=2 ERROR ON LATTICE ANGLES */ +/* IER=3 ERROR ON VECTORS A1, A2 */ +/* ------------------------------------------------------------------ */ + +/* ------------------------------------------------------------------ */ +/* Define the dummy arguments */ +/* ------------------------------------------------------------------ */ +/* DO NOT EXPORT THE FOLLOWING COMMON ! */ +/* IT IS JUST FOR PERMANENT STORAGE USE */ + +/* ----------------------------------------------------------------------- */ + +/* ----------------------------------------------------------------------- */ +/* SOME TESTS AND INIT OF CALCUALTION */ + + /* Parameter adjustments */ + --sam; + + /* Function Body */ + *ier = 0; + imod = 1; + zp = 6.2831853071795862; + osolem_1.iok = 0; + for (id = 1; id <= 3; ++id) { + a[id - 1] = sam[id]; + alfa[id - 1] = sam[id + 3]; + aspv[id - 1] = sam[id + 6]; + aspv[id + 2] = sam[id + 9]; +/* L10: */ + } + + for (id = 1; id <= 3; ++id) { + *ier = 1; + if ((d__1 = a[id - 1], abs(d__1)) <= 1e-8) { + goto L999; + } + *ier = 0; +/* L20: */ + } + for (id = 1; id <= 3; ++id) { + a[id - 1] /= zp; + alfa[id - 1] /= 57.29577951308232087679815481410517; + cosa[id - 1] = cos(alfa[id - 1]); + sina[id - 1] = sin(alfa[id - 1]); +/* L30: */ + } + cc = cosa[0] * cosa[0] + cosa[1] * cosa[1] + cosa[2] * cosa[2]; + cc = cosa[0] * 2. * cosa[1] * cosa[2] + 1. - cc; + *ier = 2; + if (cc <= .1) { + goto L999; + } + *ier = 0; + cc = sqrt(cc); + je = 2; + kg = 3; + for (id = 1; id <= 3; ++id) { + b[id - 1] = sina[id - 1] / (a[id - 1] * cc); + cosb[id - 1] = (cosa[je - 1] * cosa[kg - 1] - cosa[id - 1]) / (sina[ + je - 1] * sina[kg - 1]); + sinb[id - 1] = sqrt(1. - cosb[id - 1] * cosb[id - 1]); + rlb[id + 2] = (d__1 = atan(sinb[id - 1] / cosb[id - 1]), abs(d__1)) * + 57.29577951308232087679815481410517; + je = kg; + kg = id; +/* L40: */ + } + bb[0] = b[0]; + bb[1] = 0.; + bb[2] = 0.; + bb[3] = b[1] * cosb[2]; + bb[4] = b[1] * sinb[2]; + bb[5] = 0.; + bb[6] = b[2] * cosb[1]; + bb[7] = -b[2] * sinb[1] * cosa[0]; + bb[8] = 1. / a[2]; + + for (id = 1; id <= 3; ++id) { + rlb[id - 1] = 0.; + for (je = 1; je <= 3; ++je) { +/* Computing 2nd power */ + d__1 = bb[je + id * 3 - 4]; + rlb[id - 1] += d__1 * d__1; +/* L60: */ + } + *ier = 1; + if ((d__1 = rlb[id - 1], abs(d__1)) <= 1e-8) { + goto L999; + } + *ier = 0; + rlb[id - 1] = sqrt(rlb[id - 1]); +/* L50: */ + } +/* ----------------------------------------------------------------------- */ +/* GENERATION OF S ORIENTATION MATRIX REC. LATTICE TO SCATTERING PLANE */ + + for (kg = 1; kg <= 2; ++kg) { + for (ie = 1; ie <= 3; ++ie) { + vv[kg + ie * 3 - 4] = 0.; + for (jf = 1; jf <= 3; ++jf) { + vv[kg + ie * 3 - 4] += bb[ie + jf * 3 - 4] * aspv[jf + kg * 3 + - 4]; +/* L90: */ + } +/* L80: */ + } +/* L70: */ + } + for (md = 3; md >= 2; --md) { + for (ne = 1; ne <= 3; ++ne) { + id = md % 3 + 1; + je = (md + 1) % 3 + 1; + kg = ne % 3 + 1; + lh = (ne + 1) % 3 + 1; + vv[md + ne * 3 - 4] = vv[id + kg * 3 - 4] * vv[je + lh * 3 - 4] - + vv[id + lh * 3 - 4] * vv[je + kg * 3 - 4]; +/* L110: */ + } +/* L100: */ + } + + for (id = 1; id <= 3; ++id) { + c__[id - 1] = 0.; + for (je = 1; je <= 3; ++je) { +/* Computing 2nd power */ + d__1 = vv[id + je * 3 - 4]; + c__[id - 1] += d__1 * d__1; +/* L130: */ + } + *ier = 3; + if ((d__1 = c__[id - 1], abs(d__1)) <= 1e-6) { + goto L999; + } + *ier = 0; + c__[id - 1] = sqrt(c__[id - 1]); +/* L120: */ + } + + for (id = 1; id <= 3; ++id) { + for (je = 1; je <= 3; ++je) { + vv[je + id * 3 - 4] /= c__[je - 1]; +/* L160: */ + } +/* L150: */ + } + for (kg = 1; kg <= 3; ++kg) { + for (me = 1; me <= 3; ++me) { + osolem_1.s[kg + (me << 2) - 5] = 0.; + for (lf = 1; lf <= 3; ++lf) { + osolem_1.s[kg + (me << 2) - 5] += vv[kg + lf * 3 - 4] * bb[lf + + me * 3 - 4]; +/* L190: */ + } +/* L180: */ + } +/* L170: */ + } + osolem_1.s[15] = 1.; + for (jd = 1; jd <= 3; ++jd) { + osolem_1.s[(jd << 2) - 1] = 0.; + osolem_1.s[jd + 11] = 0.; +/* L200: */ + } +/* ----------------------------------------------------------------------- */ +/* INVERT TRANSFORMATION MATRIX S AND PU RESULT IN SINV */ + + *ier = 3; + invs_(osolem_1.s, osolem_1.sinv, ier); + *ier = 0; + if (*ier != 0) { + goto L999; + } + osolem_1.iok = 123; +/* --------------------------------------------------------------------------- */ +/* SORTIE */ + +L999: + if (*ier != 0) { + erreso_(&imod, ier); + } + return 0; +} /* setrlp_ */ + +/* =========================================================================== */ +/* Subroutine */ int rl2spv_(doublereal *qhkl, doublereal *qt, doublereal *qm, + doublereal *qs, integer *ier) +{ + /* System generated locals */ + doublereal d__1; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static integer id, je; + +/* ========================================= */ + +/* ------------------------------------------------------------------ */ +/* INPUT QHKL QHKL -> QT */ +/* A Q-VECTOR TO BE TRANSFORM FROM RECIP LATTICE TO SCATTERING PLANE */ +/* CHECK THAT Q-VECTOR IS IN THE PLANE */ + +/* INPUT Q-VECTOR QHKL(3) Q-VECTOR IN RECIPROCICAL LATTICVE */ + +/* OUTPUT Q-VECTOR QT(3) Q-VECTOR IN SCATTERING PLANE */ +/* OUTPUT QM AND QS QMODULUS AND ITS SQUARE ( TO BE VERIFIED ) */ +/* OUTPUT ERROR IER */ +/* IER=1 MATRIX S NOT OK */ +/* IER=2 Q NOT IN SCATTERING PLANE */ +/* IER=3 Q MODULUS TOO SMALL */ +/* ------------------------------------------------------------------ */ + +/* ------------------------------------------------------------------ */ +/* Define the dummy arguments */ +/* ------------------------------------------------------------------ */ +/* DO NOT EXPORT THE FOLLWING COOMON ! */ +/* IT IS JUST FOR PERMANENT STORAGE USE */ + +/* --------------------------------------------------------------------------- */ +/* --------------------------------------------------------------------------- */ +/* INIT AND TEST IF TRANSFO MATRICES ARE OK */ + /* Parameter adjustments */ + --qt; + --qhkl; + + /* Function Body */ + *ier = 1; + if (osolem_1.iok != 123) { + goto L999; + } + *ier = 0; +/* ----------------------------------------------------------------------- */ + + for (id = 1; id <= 3; ++id) { + qt[id] = 0.; + for (je = 1; je <= 3; ++je) { + qt[id] += qhkl[je] * osolem_1.s[id + (je << 2) - 5]; +/* L20: */ + } +/* L10: */ + } + *ier = 2; + if (abs(qt[3]) > 1e-4) { + goto L999; + } + *ier = 0; + *qs = 0.; + for (id = 1; id <= 3; ++id) { +/* Computing 2nd power */ + d__1 = qt[id]; + *qs += d__1 * d__1; +/* L30: */ + } + if (*qs < 1e-8) { + *ier = 3; + } else { + *qm = sqrt(*qs); + } +/* --------------------------------------------------------------------------- */ + +L999: + return 0; +} /* rl2spv_ */ + +/* =========================================================================== */ +/* Subroutine */ int sp2rlv_(doublereal *qhkl, doublereal *qt, doublereal *qm, + doublereal *qs, integer *ier) +{ + /* System generated locals */ + doublereal d__1; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static integer id, je; + +/* ========================================= */ + +/* ------------------------------------------------------------------ */ +/* INPUT QT QHKL <- QT */ +/* A Q-VECTOR TO BE TRANSFORM FROM SCATTERING PLANE TO RECIP LATTICE */ +/* CHECK THAT Q, D & G VECTORS ARE IN THE SCATTERING PLANE */ + +/* INPUT Q-VECTOR QT(3) Q-VECTOR IN SCATTERING PLANE */ + +/* OUTPUT Q-VECTOR QHKL(3) Q-VECTOR IN RECIPROCICAL LATTICVE */ +/* OUTPUT QM AND QS QMODULUS AND ITS SQUARE ( TO BE VERIFIED ) */ +/* OUTPUT ERROR IER */ +/* IER=1 MATRIX S NOT OK */ +/* IER=2 Q NOT IN SCATTERING PLANE */ +/* IER=3 Q MODULUS TOO SMALL */ +/* ------------------------------------------------------------------ */ + +/* ------------------------------------------------------------------ */ +/* Define the dummy arguments */ +/* ------------------------------------------------------------------ */ +/* DO NOT EXPORT THE FOLLWING COOMON ! */ +/* IT IS JUST FOR PERMANENT STORAGE USE */ + +/* --------------------------------------------------------------------------- */ +/* --------------------------------------------------------------------------- */ +/* INIT AND TEST IF TRANSFO MATRICES ARE OK */ + /* Parameter adjustments */ + --qt; + --qhkl; + + /* Function Body */ + *ier = 1; + if (osolem_1.iok != 123) { + goto L999; + } + *ier = 2; + if (abs(qt[3]) > 1e-4) { + goto L999; + } + *ier = 0; +/* ----------------------------------------------------------------------- */ + *qs = 0.; + for (id = 1; id <= 3; ++id) { +/* Computing 2nd power */ + d__1 = qt[id]; + *qs += d__1 * d__1; +/* L10: */ + } + if (*qs < 1e-8) { + *ier = 3; + } else { + *qm = sqrt(*qs); + } +/* ----------------------------------------------------------------------- */ + + for (id = 1; id <= 3; ++id) { + qhkl[id] = 0.; + for (je = 1; je <= 3; ++je) { + qhkl[id] += osolem_1.sinv[id + (je << 2) - 5] * qt[je]; +/* L30: */ + } +/* L20: */ + } +/* --------------------------------------------------------------------------- */ + +L999: + return 0; +} /* sp2rlv_ */ + +/* ========================================================================== */ +/* Subroutine */ int invs_(doublereal *s, doublereal *sinv, integer *ier) +{ + /* Initialized data */ + + static integer m[3] = { 2,3,1 }; + static integer n[3] = { 3,1,2 }; + + static integer id, je, mi, mj, ni, nj; + static doublereal det; + +/* ============================== */ + +/* ------------------------------------------------------------------ */ +/* ROUTINE TO INVERT MATRIX S, GENERATED BY SETRLP, WHICH TRANSFORMS */ +/* (QH,QK,QL) TO (Q1,Q2) IN THE SCATTERING PLANE */ +/* INPUT MATRIX DOUBLE PRECISION S(4,4) */ +/* OUTPUT MATRIX DOUBLE PRECISION SINV(4,4) */ +/* OUTPUT ERROR IER */ +/* IER=1 DETERMINANT OF MATRIX S TOO SMALL */ +/* ------------------------------------------------------------------ */ + +/* ------------------------------------------------------------------ */ +/* Define the dummy arguments */ +/* ------------------------------------------------------------------ */ + + /* Parameter adjustments */ + sinv -= 5; + s -= 5; + + /* Function Body */ +/* ------------------------------------------------------------------ */ + *ier = 0; + for (id = 1; id <= 4; ++id) { + for (je = 1; je <= 4; ++je) { + sinv[id + (je << 2)] = 0.; +/* L20: */ + } +/* L10: */ + } + det = 0.; + for (id = 1; id <= 3; ++id) { + for (je = 1; je <= 3; ++je) { + mi = m[id - 1]; + mj = m[je - 1]; + ni = n[id - 1]; + nj = n[je - 1]; + sinv[je + (id << 2)] = s[mi + (mj << 2)] * s[ni + (nj << 2)] - s[ + ni + (mj << 2)] * s[mi + (nj << 2)]; +/* L40: */ + } + det += s[id + 4] * sinv[(id << 2) + 1]; +/* L30: */ + } + if (abs(det) < 1e-6) { + *ier = 1; + } else { + for (id = 1; id <= 3; ++id) { + for (je = 1; je <= 3; ++je) { + sinv[id + (je << 2)] /= det; +/* L70: */ + } +/* L60: */ + } + } + sinv[20] = 1.; + return 0; +} /* invs_ */ + +/* ========================================================================= */ +/* Subroutine */ int erreso_(integer *module, integer *ier) +{ + + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer lmod, lier; + +/* ============================= */ + +/* ------------------------------------------------------------------ */ +/* SUBROUTINE TO TREAT ERRORS FROM RESOLUTION CALCULATIONS */ +/* MODULE = 1 -> SETRLP */ +/* MODULE = 2 -> RL2SPV */ +/* MODULE = 3 -> EX_CASE */ +/* ------------------------------------------------------------------ */ + + +/* INCLUDE 'MAD_DEF:IOLSDDEF.INC' */ +/* ------------------------------------------------------------------ */ +/* Define the dummy arguments */ +/* ------------------------------------------------------------------ */ + + +/* --------------------------------------------------------------------------- */ +/* Computing MIN */ + i__1 = max(*ier,1); + lier = min(i__1,4); +/* Computing MIN */ + i__1 = max(*module,1); + lmod = min(i__1,3); +/* WRITE(6,501) MESER(LIER,LMOD) */ +/* 501 FORMAT(A) */ + return 0; +} /* erreso_ */ + + + diff --git a/cryst.c b/cryst.c new file mode 100644 index 00000000..5ae01f8b --- /dev/null +++ b/cryst.c @@ -0,0 +1,114 @@ +/*--------------------------------------------------------------------------- + C r y s t + + This is a library of crystallographic utility routines for four + circle diffractometers. It deals with all sorts of rotations and + stuff. This is based on code originally developed by John Allibon + at ILL and reimplemented in C using a matrix-library. + + Mark Koennecke, July 2000 +----------------------------------------------------------------------------*/ +#include +#include +#include +#include +#include "matrix/matrix.h" +#include "cryst.h" + +#define PIR 57.30 + +/*------------------------------------------------------------------------- + chimat, calculate chi rotation matrix. The input angle is in degrees. + The setting is Busing & Levy. +--------------------------------------------------------------------------*/ + +MATRIX chimat(double dAngle) +{ + MATRIX res; + double dChi; + + res = mat_creat(3,3,ZERO_MATRIX); + dChi = dAngle/PIR; + + res[0][0] = cos(dChi); + res[0][2] = sin(dChi); + res[1][1] = 1.; + res[2][0] = -res[0][2]; + res[2][2] = res[0][0]; + + return res; +} + + +/*------------------------------------------------------------------------- + phimat, calculate phi rotation matrix. The input angle is in degrees. + The setting is Busing & Levy. +--------------------------------------------------------------------------*/ + +MATRIX phimat(double dAngle) +{ + MATRIX res; + double dPhi; + + res = mat_creat(3,3,ZERO_MATRIX); + dPhi = dAngle/PIR; + + res[0][0] = cos(dPhi); + res[0][1] = sin(dChi); + res[2][2] = 1.; + res[1][0] = -res[0][1]; + res[1][1] = res[0][0]; + + return res; +} +/*------------------------------------------------------------------------- + psimat, calculate psi rotation matrix. The input angle is in degrees. + The setting is Busing & Levy. +--------------------------------------------------------------------------*/ + +MATRIX psimat(double dAngle) +{ + MATRIX res; + double dPsi; + + res = mat_creat(3,3,ZERO_MATRIX); + dPsi = dAngle/PIR; + + res[0][0] = 1.; + res[1][1] = cos(dPsi); + res[1][2] = -sin(dPsi); + res[2][1] = -res[1][2]; + res[2][2] = res[1][1]; + + return res; +} + +/*------------------------------------------------------------------------- + diffFromAngles calculates the diffraction vector from two theta, omega + chi and phi. The angled need not be bissecting but it is assumed that + the diffraction vector is in the equatorial plane. +--------------------------------------------------------------------------*/ + +MATRIX diffFromAngles(double wave, double tth, double om, + double chi, double phi) +{ + MATRIX res, rot, dum, z; + double dTh; + + dTh = (tth/2.)/PIR; + res = mat_creat(3,1,ZERO_MATRIX); + res[0][0] = (2.*sin(dTh)*cos(dTh))/wave; + res[1][0] = (-2. *sin(dTh)*sin(dTh))/wave; + + /* undo omega rotation */ + rot = phimat(om); + dum = mat_tran(rot); + mat_free(rot); + z = mat_mul(dum,res); + mat_free(dum); + mat_free(res); + + /* result is now z */ + +} + diff --git a/d_mod.c b/d_mod.c new file mode 100644 index 00000000..3766d9fa --- /dev/null +++ b/d_mod.c @@ -0,0 +1,46 @@ +#include "f2c.h" + +#ifdef KR_headers +#ifdef IEEE_drem +double drem(); +#else +double floor(); +#endif +double d_mod(x,y) doublereal *x, *y; +#else +#ifdef IEEE_drem +double drem(double, double); +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif +double d_mod(doublereal *x, doublereal *y) +#endif +{ +#ifdef IEEE_drem + double xa, ya, z; + if ((ya = *y) < 0.) + ya = -ya; + z = drem(xa = *x, ya); + if (xa > 0) { + if (z < 0) + z += ya; + } + else if (z > 0) + z -= ya; + return z; +#else + double quotient; + if( (quotient = *x / *y) >= 0) + quotient = floor(quotient); + else + quotient = -floor(-quotient); + return(*x - (*y) * quotient ); +#endif +} +#ifdef __cplusplus +} +#endif diff --git a/d_sign.c b/d_sign.c new file mode 100644 index 00000000..d06e0d19 --- /dev/null +++ b/d_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_sign(a,b) doublereal *a, *b; +#else +double d_sign(doublereal *a, doublereal *b) +#endif +{ +double x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/danu.c b/danu.c new file mode 100644 index 00000000..126109f1 --- /dev/null +++ b/danu.c @@ -0,0 +1,293 @@ +/*----------------------------------------------------------------------- + D A T A N U M B E R + + Implementation file for the data number module. + + 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 "obdes.h" +#include "danu.h" + +/* ------------------ the data structure ----------------------------------*/ + typedef struct __DataNumber { + pObjectDescriptor pDes; + char *pFileName; + } DataNumber; +/*-------------------------------------------------------------------------*/ + pDataNumber CreateDataNumber(char *pFileName) + { + pDataNumber pNew = NULL; + FILE *fd = NULL; + + pNew = (pDataNumber)malloc(sizeof(DataNumber)); + if(!pNew) + { + return NULL; + } + memset(pNew,0,sizeof(DataNumber)); + + pNew->pDes = CreateDescriptor("DataNumber"); + if(!pNew->pDes) + { + free(pNew); + return NULL; + } + + /* check filename */ + fd = fopen(pFileName,"r"); + if(!fd) + { + printf("Serious error: cannot open file for Data Number!!!!\n"); + printf("I continue, but you should not write data files!\n"); + pNew->pFileName = strdup("default.num"); + return pNew; + } + fclose(fd); + pNew->pFileName = strdup(pFileName); + return pNew; + } +/*--------------------------------------------------------------------------*/ + void DeleteDataNumber(void *pData) + { + pDataNumber self = NULL; + + self = (pDataNumber)pData; + assert(self); + + if(self->pDes) + { + DeleteDescriptor(self->pDes); + } + if(self->pFileName) + { + free(self->pFileName); + } + free(self); + } +/*-------------------------------------------------------------------------*/ + int IncrementDataNumber(pDataNumber self, int *iYear) + { + FILE *fd = NULL; + int iNum; + time_t iTime; + struct tm *psTime; + + /* open file */ + fd = fopen(self->pFileName,"r"); + if(!fd) + { + return -1; + } + + + /* get and increment number */ + fscanf(fd,"%d",&iNum); + iNum++; + fclose(fd); + + /* reopen for rewriting */ + fd = fopen(self->pFileName,"w"); + if(fd == NULL) + { + return -1; + } + + /* write file and leave */ + fprintf(fd," %d \n",iNum); + fprintf(fd,"NEVER, EVER modify or delete this file\n"); + fprintf(fd,"You'll risk eternal damnation and a reincarnation as a cockroach!|n"); + fclose(fd); + + /* get year */ + iTime = time(NULL); + psTime = localtime(&iTime); + *iYear = psTime->tm_year + 1900; + + return iNum; + } +/*-------------------------------------------------------------------------*/ + int DecrementDataNumber(pDataNumber self) + { + FILE *fd = NULL; + int iNum; + + /* open file */ + fd = fopen(self->pFileName,"r"); + if(!fd) + { + return -1; + } + + + /* get and decrement number */ + fscanf(fd,"%d",&iNum); + iNum--; + if(iNum < 0) + iNum = 0; + fclose(fd); + + /* reopen for rewriting */ + fd = fopen(self->pFileName,"w"); + + /* write file and leave */ + fprintf(fd," %d \n",iNum); + fprintf(fd,"NEVER, EVER modify or delete this file\n"); + fprintf(fd,"You'll risk eternal damnation and a reincarnation as a cockroach!|n"); + fclose(fd); + + return iNum; + } +/*-------------------------------------------------------------------------*/ + int DNWrapper(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + pDataNumber self = NULL; + FILE *fd = NULL; + int iNum, iYear; + char pBueffel[512]; + + self = (pDataNumber)pData; + assert(self); + assert(pCon); + + argtolower(argc,argv); + if(argc < 2) /* value request */ + { + fd = fopen(self->pFileName,"r"); + if(!fd) + { + sprintf(pBueffel,"ERROR: cannot open file %s",self->pFileName); + SCWrite(pCon,pBueffel,eError); + return 0; + } + fscanf(fd,"%d",&iNum); + fclose(fd); + sprintf(pBueffel,"%s = %d",argv[0],iNum); + SCWrite(pCon,pBueffel,eValue); + return 1; + } + + if(strcmp(argv[1],"incr") == 0) + { + iNum = IncrementDataNumber(self,&iYear); + if(iNum > 0) + { + SCSendOK(pCon); + return 1; + } + else + { + sprintf(pBueffel,"ERROR: cannot increment %s",argv[0]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + } + + sprintf(pBueffel,"ERROR: unknown command %s supplied to %s", + argv[1], argv[0]); + SCWrite(pCon,pBueffel,eError); + return 0; + } +/*------------------------------------------------------------------------*/ + int DEWrapper(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + pDataNumber self = NULL; + int iNum; + char pBueffel[512]; + + self = (pDataNumber)pData; + assert(self); + assert(pCon); + + if(SCMatchRights(pCon,usMugger)) + { + DecrementDataNumber(self); + SCWrite(pCon,"Data file killed",eWarning); + return 1; + } + else + { + SCWrite(pCon,"ERROR: you are not authorized to kill data files", + eError); + return 0; + } + } + +/*-------------------------------------------------------------------------*/ + int DNFactory(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + pDataNumber self = NULL; + char pBueffel[512]; + int iRet; + + if(argc < 3) + { + SCWrite(pCon, + "ERROR: not enough arguments provided to make DataNumber",eError); + return 0; + } + + self = CreateDataNumber(argv[2]); + if(!self) + { + SCWrite(pCon,"ERROR: no memory to create data number",eError); + return 0; + } + + iRet = AddCommand(pSics, argv[1],DNWrapper, DeleteDataNumber, self); + if(!iRet) + { + sprintf(pBueffel,"ERROR: duplicate command %s not created",argv[1]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + iRet = AddCommand(pSics,"killfile",DEWrapper,NULL, self); + if(!iRet) + { + sprintf(pBueffel,"ERROR: duplicate command %s not created",argv[1]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + return 1; + } + + diff --git a/danu.dat b/danu.dat new file mode 100644 index 00000000..a8179996 --- /dev/null +++ b/danu.dat @@ -0,0 +1,3 @@ + 286 +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/danu.h b/danu.h new file mode 100644 index 00000000..1e8c27d9 --- /dev/null +++ b/danu.h @@ -0,0 +1,41 @@ + +#line 53 "danu.w" + +/*----------------------------------------------------------------------- + D A T A N U M B E R + + A module to provide a unique data number for data file writing. + + Mark Koennecke, Juli 1997 + + copyright: see implementation file. + +---------------------------------------------------------------------------*/ +#ifndef SICSDATANUMBER +#define SICSDATANUMBER + + +#line 15 "danu.w" + + typedef struct __DataNumber *pDataNumber; + + pDataNumber CreateDataNumber(char *pFilename); + void DeleteDataNumber(void *pData); + + int IncrementDataNumber(pDataNumber self, int *iYear); + + int DecrementDataNumber(pDataNumber self); + + int DNWrapper(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + int DEWrapper(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + int DNFactory(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + +#line 67 "danu.w" + + +#endif diff --git a/danu.tex b/danu.tex new file mode 100644 index 00000000..2e1efc74 --- /dev/null +++ b/danu.tex @@ -0,0 +1,92 @@ +\subsection{Data Number} +In some points of its life SICS has to write data files. The file names +usually consist of a header, a serial number and an indicator for the +year. The serial number must be unique and steadliy increasing. In order to +achieve this, the serial number are written into a file after any change. +Incrementing the serial number thus involves the following steps: +\begin{itemize} +\item Open file and read current number. +\item Increment number +\item Write File and close +\end{itemize} +This little task is implemented in this module. + +The interface to this looks like: +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap1} +$\langle$dni {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ typedef struct __DataNumber *pDataNumber;@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ pDataNumber CreateDataNumber(char *pFilename);@\\ +\mbox{}\verb@ void DeleteDataNumber(void *pData);@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ int IncrementDataNumber(pDataNumber self, int *iYear);@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ int DecrementDataNumber(pDataNumber self);@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ int DNWrapper(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ +\mbox{}\verb@ int argc, char *argv[]);@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ int DEWrapper(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ +\mbox{}\verb@ int argc, char *argv[]);@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ int DNFactory(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{description} +\item [CreateDataNumber] creates a data number data structure. It checks if +the file requested as parameter exists and asserts if not. Returns a pointer +on success, NULL else. +\item [DeleteDataNumber] deletes a data number structure form memory. +\item [IncrementDataNumber] is the main working function of this module. +It performs the steps listed above. It returns a new id for the data number +in case of success, a negative value otherwise. iYear is filled with a value +for the year. +\item[DecrementDataNumber] decrements the data number and is used for + implementing the killdata function. Whis is the invalidation of a + data file by overwriting it. +\item[DNWrapper] is the wrapper function which makes DataNumber accessible +from within SICS. +\item[DEWrapper] is the wrapper for the killdata functionality. +\item [DNFactory] is the SICS factory function which creates a Data Number +object from the initialisation file. Only parameter is the filename. +\end{description} + +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap2} +\verb@"danu.h"@ {\footnotesize ? }$\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@/*-----------------------------------------------------------------------@\\ +\mbox{}\verb@ D A T A N U M B E R@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ A module to provide a unique data number for data file writing.@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ Mark Koennecke, Juli 1997@\\ +\mbox{}\verb@ @\\ +\mbox{}\verb@ copyright: see implementation file.@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@---------------------------------------------------------------------------*/@\\ +\mbox{}\verb@#ifndef SICSDATANUMBER@\\ +\mbox{}\verb@#define SICSDATANUMBER@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@@$\langle$dni {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@#endif@\\ +\mbox{}\verb@@$\diamond$ +\end{list} +\vspace{-2ex} +\end{minipage}\\[4ex] +\end{flushleft} diff --git a/danu.w b/danu.w new file mode 100644 index 00000000..0a5b0318 --- /dev/null +++ b/danu.w @@ -0,0 +1,77 @@ +\subsection{Data Number} +In some points of its life SICS has to write data files. The file names +usually consist of a header, a serial number and an indicator for the +year. The serial number must be unique and steadliy increasing. In order to +achieve this, the serial number are written into a file after any change. +Incrementing the serial number thus involves the following steps: +\begin{itemize} +\item Open file and read current number. +\item Increment number +\item Write File and close +\end{itemize} +This little task is implemented in this module. + +The interface to this looks like: +@d dni @{ + typedef struct __DataNumber *pDataNumber; + + pDataNumber CreateDataNumber(char *pFilename); + void DeleteDataNumber(void *pData); + + int IncrementDataNumber(pDataNumber self, int *iYear); + + int DecrementDataNumber(pDataNumber self); + + int DNWrapper(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + int DEWrapper(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + int DNFactory(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); +@} +\begin{description} +\item [CreateDataNumber] creates a data number data structure. It checks if +the file requested as parameter exists and asserts if not. Returns a pointer +on success, NULL else. +\item [DeleteDataNumber] deletes a data number structure form memory. +\item [IncrementDataNumber] is the main working function of this module. +It performs the steps listed above. It returns a new id for the data number +in case of success, a negative value otherwise. iYear is filled with a value +for the year. +\item[DecrementDataNumber] decrements the data number and is used for + implementing the killdata function. Whis is the invalidation of a + data file by overwriting it. +\item[DNWrapper] is the wrapper function which makes DataNumber accessible +from within SICS. +\item[DEWrapper] is the wrapper for the killdata functionality. +\item [DNFactory] is the SICS factory function which creates a Data Number +object from the initialisation file. Only parameter is the filename. +\end{description} + +@o danu.h -d @{ +/*----------------------------------------------------------------------- + D A T A N U M B E R + + A module to provide a unique data number for data file writing. + + Mark Koennecke, Juli 1997 + + copyright: see implementation file. + +---------------------------------------------------------------------------*/ +#ifndef SICSDATANUMBER +#define SICSDATANUMBER + +@ + +#endif +@} + + + + + + + diff --git a/definealias.c b/definealias.c new file mode 100644 index 00000000..5845cb9c --- /dev/null +++ b/definealias.c @@ -0,0 +1,217 @@ +/*--------------------------------------------------------------------------- + + One more approach for the implementation of Aliases + + + + Markus Zolliker, September 2000 + + 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 "definealias.h" + +typedef struct __Aitem { + struct __Aitem *pNext; + char *pName; + char *pCmd; + } AliasItem; + +/*------------------------------------------------------------------------*/ + char *TranslateAlias(AliasList *pAList, char *pCmd) + { + AliasItem *pAlias; + + assert(pAList!=NULL && pCmd!=NULL); + + pAlias=pAList->pFirst; + while (pAlias!=NULL) + { + if (0 == strcmp(pAlias->pName, pCmd)) + { + pCmd = pAlias->pCmd; /* note that there may be cascaded translations */ + } + pAlias = pAlias->pNext; + } + return(pCmd); + } +/*------------------------------------------------------------------------*/ + int RemoveAlias(AliasList *pAList, char *pCmd) + { + AliasItem *pAlias = NULL, *pPrev = NULL; + + assert(pAList!=NULL && pCmd!=NULL); + + pPrev=(AliasItem *)pAList; + pAlias=pAList->pFirst; + while (pAlias != NULL && 0 != strcmp(pAlias->pName, pCmd)) + { + pPrev = pAlias; + pAlias = pAlias->pNext; + } + if (pAlias==NULL) + { + return 0; /* not found */ + } + + /* remove it */ + pPrev->pNext = pAlias->pNext; + free(pAlias->pName); + free(pAlias->pCmd); + free(pAlias); + return(1); + } +/*------------------------------------------------------------------------*/ + void FreeAliasList(AliasList *pAList) + { + AliasItem *pAlias = NULL, *pNext = NULL; + + assert(pAList!=NULL); + + pAlias=pAList->pFirst; + while (pAlias != NULL) + { + pNext=pAlias->pNext; + free(pAlias->pName); + free(pAlias->pCmd); + free(pAlias); + pAlias = pNext; + } + } +/*------------------------------------------------------------------------*/ + char *CreateAlias(AliasList *pAList, char *pName, char *pTranslation) + { /* arguments must be lower case */ + AliasItem *pAlias = NULL, *pNew = NULL, *pTail = NULL; + char *pCmd; + + /* translate 2nd argument */ + pCmd=TranslateAlias(pAList, pTranslation); + if (0==strcmp(pName, pCmd)) /* translation matches */ + { + return "recursive alias not allowed"; + } + + /* find last element pTail and check that alias does not yet exist */ + pTail = (AliasItem *)pAList; + pAlias = pAList->pFirst; + while (pAlias!=NULL) + { + pTail=pAlias; + if (0 == strcmp(pAlias->pName, pName)) + { + return "alias already exists"; + } + pAlias = pAlias->pNext; + } + + /* allocate the list entry */ + pNew = malloc(sizeof(AliasItem)); + if (pNew!=NULL) + { + pNew->pNext = NULL; + pNew->pName = strdup(pName); + if (pNew->pName!=NULL) + { + pNew->pCmd = strdup(pCmd); + if (pNew->pCmd!=NULL) + { + /* insert at tail */ + pTail->pNext = pNew; + return NULL; /* o.k. */ + } + } + } + return "not enough memory to create an alias"; + + } + +/*------------------------------------------------------------------------*/ + int DefineAlias(pSConnection pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + char pBueffel[256]; + int iRet; + CommandList *pCom = NULL; + char *pErr; + + if(!SCMatchRights(pCon,usMugger)) + { + SCWrite(pCon,"ERROR: only managers may define aliases", + eError); + return 0; + } + + argtolower(argc,argv); + + if(argc == 2) /* remove case */ + { + iRet=RemoveAlias(&pSics->AList, argv[1]); + if (iRet==0) + { + SCWrite(pCon,"ERROR: alias not found", + eError); + return 0; + } + return 1; + } + if(argc != 3) + { + SCWrite(pCon,"ERROR: illegal number of arguments to DefineAlias", + eError); + return 0; + } + + pCom = FindCommand(pSics, argv[1]); + if (pCom!=NULL) + { + SCWrite(pCon,"ERROR: an alias must not overwrite a command", + eError); + return 0; + } + + /* remove the old alias, if any */ + RemoveAlias(&pSics->AList, argv[1]); + + pErr=CreateAlias(&pSics->AList, argv[1], argv[2]); + if (pErr!=NULL) + { + sprintf(pBueffel,"ERROR: %s", pErr); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + return 1; + } + diff --git a/definealias.h b/definealias.h new file mode 100644 index 00000000..9fbb5a55 --- /dev/null +++ b/definealias.h @@ -0,0 +1,93 @@ +/*-------------------------------------------------------------------------- + + D E F I N E A L I A S E S . C + + Markus Zolliker, September 2000 + + copyright: see implementation file + + More general and safe Aliases: + + - an alias may be defined even if the corresponding command + does not yet exist + + - SICS does not crash when the original command of an alias is + removed + +---------------------------------------------------------------------------*/ +#ifndef DEFINE_ALIAS +#define DEFINE_ALIAS +#include "conman.h" +#include "definealias.i" + +/*---------------------------------------------------------------------------*/ + char *TranslateAlias(AliasList *pAList, char *pCmd); + /* + translate the command *pCmd + - the translation may go through several steps + - if no translation is found, the return value is equal to pCmd + - no strings are copied + - the return value becomes invalid when the corresponding alias is removed + - *pCmd must be lowercase + */ + +/*---------------------------------------------------------------------------*/ + int RemoveAlias(AliasList *pAList, char *pCmd); + /* + remove the alias *pCmd + - returns 1 when the alias existed, 0 otherwise + - *pCmd must be lowercase + */ + +/*---------------------------------------------------------------------------*/ + void FreeAliasList(AliasList *pAList); + /* + dispose the alias list + */ + +/*---------------------------------------------------------------------------*/ + char *CreateAlias(AliasList *pAList, char *pName, char *pTranslation); + + /* + create a new alias *pName with the translation *pTranslation + + - the alias *pName must not yet exist + - *pTranslation is translated first + - recursive definitions are prohibited + - *pName and *pTranslation must be lowercase + + if the creation is successful, the return value is NULL, otherwise + it points to one of the following error messages: + + "recursive alias not allowed" + "alias already exists" + "not enough memory to create an alias" + + */ + +/*---------------------------------------------------------------------------*/ + int DefineAlias(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + /* this command requires manager privileges + + argv[1]: the alias to define + - must not be a proper SICS command + - if an alias with this name exists already, it is removed first + + argv[2]: the original command + - if omitted, the alias is removed + - if it is an alias the definiton refers to it's translation + - may be an unknown command (probably defined later) + + - AddCommand removes an eventual alias matching the command name + + - RemoveCommand does not remove it's aliases + Trying to use an alias of a removed command leads to the error message + "object > ... < NOT found" + + - trying to define a recursive alias leads the error message + "recursive alias not allowed" + */ + +#endif diff --git a/definealias.i b/definealias.i new file mode 100644 index 00000000..fa0b1741 --- /dev/null +++ b/definealias.i @@ -0,0 +1,20 @@ +/*-------------------------------------------------------------------------- + + AliasList datastructure + + Markus Zolliker, September 2000 + + copyright: see implementation file + +---------------------------------------------------------------------------*/ +#ifndef DEFINE_ALIAS_I +#define DEFINE_ALIAS_I + +typedef struct { + void *pFirst; + } AliasList; + + /* + initialize pFirst to NULL to create an empty list + */ +#endif diff --git a/defines.h b/defines.h new file mode 100644 index 00000000..064a4023 --- /dev/null +++ b/defines.h @@ -0,0 +1,19 @@ +/* ====================================================================== + DEFINES.h Standard definitions etc. + For simplification or for debugging substitution. + + v1.02 94-08-11 Stripped version. + + _____ This version is Public Domain. + /_|__| A.Reitsma, Delft, Nederland. +/ | \ --------------------------------------------------------------- */ + +#include /* for malloc() prototype */ +#include /* for memcpy() prototype */ +#include "fortify.h" + +#define MALLOC(size,type) (type *) malloc( (size) * sizeof( type )) +#define FREE(mem) free( mem ) +#define CALLOC(size,type) (type *) calloc( (size), sizeof( type)) + +/* === DEFINES.h end ================================================= */ diff --git a/devexec.c b/devexec.c new file mode 100644 index 00000000..c6016277 --- /dev/null +++ b/devexec.c @@ -0,0 +1,949 @@ +/*------------------------------------------------------------------------- + + D E V I C E E X E C U T E R + + + Mark Koennecke, December 1996 + Substantial rewrite: Mark Koennecke, February 1997 + revised: Mark Koennecke, June 1997 + revised for use with tasker: Mark Koennecke, September 1997 + Locking added: Mark Koennecke, August 2002 + + 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 "nserver.h" +#include "motor.h" +#include "countdriv.h" +#include "counter.h" +#include "devexec.h" +#include "status.h" +#include "lld.h" + +/* +#define DEBUG 1 +*/ + + typedef struct _DevEntry { + void *pData; + pObjectDescriptor pDescriptor; + float fVal; + char *name; + } DevEntry, *pDevEntry; +/*-------------------------------------------------------------------------*/ + static pDevEntry CreateDevEntry(pObjectDescriptor pDes, void *pData, + float fVal, char *name) + { + pDevEntry pNew = NULL; + + assert(pDes); + + pNew = (pDevEntry)malloc(sizeof(DevEntry)); + if(!pNew) + { + return NULL; + } + pNew->pDescriptor = pDes; + pNew->pData = pData; + pNew->name = strdup(name); + pNew->fVal = fVal; + return pNew; + } +/*-------------------------------------------------------------------------*/ + static void DeleteDevEntry(pDevEntry self) + { + assert(self); + + if(self->name) + { + free(self->name); + } + free(self); + } + +/* ----------------- The Executor himself ---------------------------------*/ + typedef struct __EXELIST{ + pObjectDescriptor pDes; + SConnection *pOwner; + int iList; + int iRun; + int iStop; + int iStatus; + int iEnd; + long lTask; + pTaskMan pTask; + int iLock; + } ExeList; + + static pExeList pExecutor = NULL; +/*--------------------------------------------------------------------------*/ + pExeList CreateExeList(pTaskMan pTask) + { + pExeList pRes = NULL; + + assert(pTask); + + pRes = (pExeList)malloc(sizeof(ExeList)); + if(!pRes) + { + return NULL; + } + + pRes->pOwner = NULL; + pRes->pDes = CreateDescriptor("DeviceExecutor"); + if(!pRes->pDes) + { + free(pRes); + return NULL; + } + pRes->iList = LLDcreate(sizeof(pDevEntry)); + if(pRes->iList == -1) + { + free(pRes); + return NULL; + } + pRes->iRun = 0; + pRes->iStatus = DEVDONE; + pRes->pTask = pTask; + pRes->lTask = -1; + pRes->iLock = 0; + return pRes; + } +/*-------------------------------------------------------------------------*/ + void DeleteExeList(void *pData) + { + pExeList self; + + assert(pData); + + self = (pExeList)pData; + if(self->pDes) + DeleteDescriptor(self->pDes); + ClearExecutor(self); + LLDdelete(self->iList); + + free(self); + } +/*------------------------------------------------------------------------*/ + int StartDevice(pExeList self, char *name, pObjectDescriptor pDes, + void *pData, SConnection *pCon, float fNew) + { + pDevEntry pNew = NULL; + int iRet; + char pBueffel[132], pError[80]; + pIDrivable pDrivInt = NULL; + pICountable pCountInt = NULL; + + assert(self); + assert(pDes); + assert(pCon); + + /* may we? */ + if(self->pOwner != NULL) + { + if(pCon != self->pOwner) + { + SCWrite(pCon, + "ERROR: somebody else is still driving, Request rejected",eError); + return 0; + } + } + else + { + self->pOwner = pCon; + } + if(self->iLock == 1) + { + SCWrite(pCon,"ERROR: instrument is locked",eError); + return 0; + } + + /* well create a new entry */ + self->iStop = 0; + pNew = CreateDevEntry(pDes,pData,fNew,name); + if(!pNew) + { + SCWrite(pCon,"ERROR: memory exhausted in Device Executor ",eError); + return 0; + } + + /* start it */ + pDrivInt = pDes->GetInterface(pData,DRIVEID); + pCountInt = pDes->GetInterface(pData,COUNTID); + if(pDrivInt) + { + iRet = pDrivInt->SetValue(pData,pCon,fNew); + } + else if(pCountInt) + { + iRet = pCountInt->StartCount(pData,pCon); + } + else + { /* this is a programmers error */ + SCWrite(pCon,"ERROR: Programmer error in StartDevice ",eError); + iRet = 0; + } + + /* check return status */ + if(iRet == OKOK) + { + LLDnodeAppendFrom(self->iList,&pNew); + self->iRun = 1; + self->iStatus = DEVDONE; + /* if no task: start it */ + if(self->lTask < 0) + { + self->lTask = TaskRegister(self->pTask, + DevExecTask, + DevExecSignal, + NULL, + self, + 1); + self->iEnd = 0; + } + return 1; + } + else + { + sprintf(pBueffel,"ERROR: cannot start device %s",name); + SCWrite(pCon,pBueffel,eError); + DeleteDevEntry(pNew); + if(LLDcheck(self->iList) >= LIST_EMPTY) + { + self->pOwner = NULL; + } + return 0; + } + return 0; + } +/*--------------------------------------------------------------------------*/ + int StartMotor(pExeList self, SicsInterp *pSics, SConnection *pCon, + char *name, float fVal) + { + pDummy pMot = NULL; + CommandList *pCom = NULL; + char pBueffel[256]; + + assert(self); + assert(pSics); + assert(name); + + pCom = FindCommand(pSics,name); + if(!pCom) + { + sprintf(pBueffel,"ERROR: cannot find motor %s",name); + SCWrite(pCon,pBueffel,eError); + return 0; + } + pMot = (pDummy)pCom->pData; + if(!pMot) + { + sprintf(pBueffel,"ERROR: %s is no motor ",name); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + + if(!pMot->pDescriptor) + { + sprintf(pBueffel,"ERROR: cannot find motor %s",name); + SCWrite(pCon,pBueffel,eError); + return 0; + } + if(!pMot->pDescriptor->GetInterface(pMot,DRIVEID)) + { + sprintf(pBueffel,"ERROR: %s is no motor",name); + SCWrite(pCon,pBueffel,eError); + return 0; + } + return StartDevice(self,name,pMot->pDescriptor,(void *)pMot,pCon,fVal); + } +/*---------------------------------------------------------------------------*/ + int StartCounter(pExeList self, SicsInterp *pSics,SConnection *pCon, + char *name) + { + pCounter pCter = NULL; + CommandList *pCom = NULL; + char pBueffel[256]; + + assert(self); + assert(pSics); + assert(name); + + pCom = FindCommand(pSics,name); + if(!pCom) + { + sprintf(pBueffel,"ERROR: cannot find counter %s",name); + SCWrite(pCon,pBueffel,eError); + return 0; + } + pCter = (pCounter)pCom->pData; + if(!pCter) + { + sprintf(pBueffel,"ERROR: %s is no counter ",name); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + + if(!pCter->pDes) + { + sprintf(pBueffel,"ERROR: cannot find counter %s",name); + SCWrite(pCon,pBueffel,eError); + return 0; + } + if(!pCter->pDes->GetInterface(pCter,COUNTID)) + { + sprintf(pBueffel,"ERROR: %s is no counter",name); + SCWrite(pCon,pBueffel,eError); + return 0; + } + return StartDevice(self,name,pCter->pDes,(void *)pCter, + pCon,pCter->pDriv->fPreset); + } +/*--------------------------------------------------------------------------*/ + int CheckExeList(pExeList self) + { + int iRet; + pDevEntry pDev = NULL; + pICountable pCountInt = NULL; + pIDrivable pDrivInt = NULL; + int eCode; + + assert(self); + + /* Sometimes this gets called, though nothing is running. There are + cases where this is feasible for maintainance, but in some cases it + is pure rubbish, because nothing runs. This will ne checkd here. + */ + if((self->pOwner == NULL) || (LLDcheck(self->iList) == LIST_EMPTY)) + { + self->iRun = 0; + self->iEnd = 1; + self->iStop = 0; + return 1; + } + + /* + check the status of all registered devices. Remove when finished + */ + iRet = LLDnodePtr2First(self->iList); + while(iRet != 0) + { + LLDnodeDataTo(self->iList,&pDev); + if(pDev) + { + pDrivInt = pDev->pDescriptor->GetInterface(pDev->pData,DRIVEID); + pCountInt = pDev->pDescriptor->GetInterface(pDev->pData,COUNTID); + + if(pDrivInt) + { + eCode = pDrivInt->CheckStatus(pDev->pData,self->pOwner); + } + else if(pCountInt) + { + eCode = pCountInt->CheckCountStatus(pDev->pData,self->pOwner); + } + switch(eCode) + { + case HWIdle: + case OKOK: + if(pCountInt) + { + pCountInt->TransferData(pDev->pData,self->pOwner); + } + else if(pDrivInt) + { + pDrivInt->iErrorCount = 0; + } + DeleteDevEntry(pDev); + LLDnodeDelete(self->iList); + iRet = LLDnodePtr2Prev(self->iList); + if(SCGetInterrupt(self->pOwner) != eContinue) + { + self->iStatus = DEVINT; + return -1; + } + self->iStatus = DEVDONE; + break; + case HWFault: /* real HW error: burning, no net etc.. */ + DeleteDevEntry(pDev); + LLDnodeDelete(self->iList); + self->iStatus = DEVERROR; + if(pDrivInt) + { + pDrivInt->iErrorCount++; + } + if(SCGetInterrupt(self->pOwner) != eContinue) + { + self->iStatus = DEVINT; + return -1; + } + break; + case HWNoBeam: + SetStatus(eOutOfBeam); + if(SCGetInterrupt(self->pOwner) != eContinue) + { + SetStatus(eEager); + self->iStatus = DEVINT; + return -1; + } + break; + case HWPause: + SetStatus(ePaused); + if(SCGetInterrupt(self->pOwner) != eContinue) + { + ContinueExecution(self); + self->iStatus = DEVINT; + return -1; + } + break; + case HWBusy: + if(pCountInt) + { + SetStatus(eCounting); + } + else if(pDrivInt) + { + SetStatus(eDriving); + } + self->iStatus = DEVBUSY; + break; + case HWPosFault: /* cannot get somewhere... */ + DeleteDevEntry(pDev); + LLDnodeDelete(self->iList); + self->iStatus = DEVERROR; + if(pDrivInt) + { + pDrivInt->iErrorCount++; + } + if(SCGetInterrupt(self->pOwner) != eContinue) + { + self->iStatus = DEVINT; + return -1; + } + break; + } + } + iRet = LLDnodePtr2Next(self->iList); + } + + iRet = LLDnodePtr2First(self->iList); + if(LLDcheck(self->iList) == LIST_EMPTY) + { + self->pOwner = NULL; + self->iEnd = 1; + self->iRun = 0; + self->lTask = -1; + return 1; + } + else + { + return 0; + } + } +/*---------------------------------------------------------------------------*/ + int Wait4Success(pExeList self) + { + int iRet; + assert(self); + + self->iRun = 0; + + /* do nothing if not running */ + if(self->lTask < 0) + { + printf("Nothing to wait for....\n"); + return self->iStatus; + } + + /* wait for Devexec task to finish */ + TaskWait(self->pTask,self->lTask); +#ifdef DEBUG + printf("Wait4Success finished\n"); +#endif + return self->iStatus; + } +/*--------------------------------------------------------------------------*/ + int ListPending(pExeList self, SConnection *pCon) + { + int iRet,i; + char pBueffel[512]; + pDevEntry pDev = NULL; + + assert(self); + assert(pCon); + + /* first make sure that the list is fully updated */ + iRet = CheckExeList(self); + if(iRet == 1) /* nothing to do! */ + { + SCWrite(pCon,"Machine idle",eStatus); + return 1; + } + else if(iRet == -1) + { + SCWrite(pCon,"Handling Interrupt",eStatus); + return 0; + } + + + /* search the list for entries */ + iRet = LLDnodePtr2First(self->iList); + while(iRet != 0) + { + LLDnodeDataTo(self->iList,&pDev); + if(pDev) + { + sprintf(pBueffel,"\t%s %f",pDev->name,pDev->fVal); + SCWrite(pCon,pBueffel,eStatus); + } + iRet = LLDnodePtr2Next(self->iList); + } + return 1; + } +/* -----------------------------------------------------------------------*/ + long GetDevexecID(pExeList self) + { + assert(self); + + return self->lTask; + } +/*--------------------------------------------------------------------------*/ + int StopExe(pExeList self, char *name) + { + int i, iRet; + pDevEntry pDev = NULL; + pIDrivable pDrivInt = NULL; + pICountable pCountInt = NULL; + assert(self); + + /* if not active, nothing to do */ + if((self->pOwner == NULL) || (LLDcheck(self->iList) == LIST_EMPTY)) + { + self->iRun = 0; + return 1; + } + + /* + check for stop flag. This is to stop unnecessary calls to StopExe. + There may be way to many, but each call is reasonable under certain + circumstances. + */ + if(self->iStop == 1) + { + return 0; + } + else + { + self->iStop = 1; + } + + /* first the ALL case */ + if(strcmp(name,"all") == 0) + { + iRet = LLDnodePtr2First(self->iList); + while(iRet != 0) + { + pDev = (pDevEntry)LLDnodePtr(self->iList); + if(pDev) + { + pDrivInt = pDev->pDescriptor->GetInterface(pDev->pData,DRIVEID); + pCountInt = pDev->pDescriptor->GetInterface(pDev->pData,COUNTID); + if(pDrivInt) + { + pDrivInt->Halt(pDev->pData); + } + else if(pCountInt) + { + pCountInt->Halt(pDev->pData); + } + } + iRet = LLDnodePtr2Next(self->iList); + } + SCWrite(self->pOwner,"ERROR: Full Stop called!!",eError); + if(SCGetInterrupt(self->pOwner) > eContinue) + { + self->iStatus = DEVINT; + } + return 1; + } + + /* now the special case: a well defined command */ + iRet = LLDnodePtr2First(self->iList); + while(iRet != 0) + { + pDev = (pDevEntry)LLDnodePtr(self->iList); + if(pDev) + { + if(strcmp(pDev->name,name) == 0) + { + pDrivInt = pDev->pDescriptor->GetInterface(pDev->pData,DRIVEID); + pCountInt = pDev->pDescriptor->GetInterface(pDev->pData,COUNTID); + if(pDrivInt) + { + pDrivInt->Halt(pDev->pData); + } + else if(pCountInt) + { + pDrivInt->Halt(pDev->pData); + } + return 1; + } + } + iRet = LLDnodePtr2Next(self->iList); + } + + return 0; + } +/*-------------------------------------------------------------------------*/ + int StopExeWait(pExeList self) + { + StopExe(self,"all"); + Wait4Success(self); + return 1; + } +/*--------------------------------------------------------------------------*/ + int PauseExecution(pExeList self) + { + int i, iRet, iRes; + pDevEntry pDev = NULL; + pICountable pCountInt = NULL; + assert(self); + + /* step through the list */ + iRes = 0; + iRet = LLDnodePtr2First(self->iList); + while(iRet != 0) + { + pDev = (pDevEntry)LLDnodePtr(self->iList); + if(pDev) + { + pCountInt = pDev->pDescriptor->GetInterface(pDev->pData,COUNTID); + if(pCountInt) + { + iRet = pCountInt->Pause(pDev->pData,self->pOwner); + if(!iRet) + { + iRes = 0; + } + } + + } + iRet = LLDnodePtr2Next(self->iList); + } + SetStatus(ePaused); + return iRes; + } +/*------------------------------------------------------------------------*/ + int IsCounting(pExeList self) + { + int iRet; + pDevEntry pDev = NULL; + pICountable pCountInt = NULL; + assert(self); + + /* step through the list */ + iRet = LLDnodePtr2First(self->iList); + while(iRet != 0) + { + pDev = (pDevEntry)LLDnodePtr(self->iList); + if(pDev) + { + pCountInt = pDev->pDescriptor->GetInterface(pDev->pData,COUNTID); + if(pCountInt) + { + return 1; + } + + } + iRet = LLDnodePtr2Next(self->iList); + } + return 0; + } +/*--------------------------------------------------------------------------*/ + int ContinueExecution(pExeList self) + { + int i, iRet, iRes; + pDevEntry pDev = NULL; + pICountable pCountInt = NULL; + assert(self); + + /* step through the list */ + iRes = 0; + iRet = LLDnodePtr2First(self->iList); + while(iRet != 0) + { + pDev = (pDevEntry)LLDnodePtr(self->iList); + if(pDev) + { + pCountInt = pDev->pDescriptor->GetInterface(pDev->pData,COUNTID); + if(pCountInt) + { + iRet = pCountInt->Continue(pDev->pData,self->pOwner); + if(!iRet) + { + iRes = 0; + } + } + + } + iRet = LLDnodePtr2Next(self->iList); + } + SetStatus(eCounting); + return iRes; + } +/*------------------------------------------------------------------------*/ + void ClearExecutor(pExeList self) + { + int iRet; + pDevEntry pDev = NULL; + + assert(self); + + iRet = LLDnodePtr2First(self->iList); + while(iRet != 0) + { + pDev = (pDevEntry)LLDnodePtr(self->iList); + if(pDev) + { + DeleteDevEntry(pDev); + } + LLDnodeDelete(self->iList); + iRet = LLDnodePtr2Prev(self->iList); + iRet = LLDnodePtr2Next(self->iList); + } + if(self->pOwner) + { + if(SCGetInterrupt(self->pOwner) > eContinue) + { + self->iStatus = DEVINT; + } + } + self->pOwner = NULL; + self->iEnd = 1; + self->lTask = -1; + self->iRun = 0; + self->iLock = 0; + } +/*-------------------------------------------------------------------------*/ + int StopCommand(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + pExeList self = NULL; + int iRet; + char pBueffel[132]; + + assert(pCon); + assert(pSics); + assert(pData); + + /* check Privilege: Muggers may do it */ + if(!SCMatchRights(pCon,usMugger)) + { + SCWrite(pCon,"ERROR: NO Privilege to Stop operation ",eError); + return 0; + } + + argtolower(argc,argv); + self = (pExeList)pData; + if(argc < 2) + { + ListPending(self,pCon); + return 1; + } + + iRet = StopExe(self,argv[1]); + if(!iRet) + { + sprintf(pBueffel,"ERROR: %s not found, so could not halt", argv[1]); + SCWrite(pCon,pBueffel,eError); + } + return iRet; + } +/*--------------------------------------------------------------------------*/ + int ListExe(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + return ListPending((pExeList)pData,pCon); + } +/*-------------------------------------------------------------------------- + Usage: + Success +*/ + + int Success(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + int iRet; + Status eOld; + + eOld = GetStatus(); + SetStatus(eRunning); + iRet = Wait4Success((pExeList)pData); + if(iRet == DEVINT) + { + if(SCGetInterrupt(pCon) == eAbortOperation) + { + SCSetInterrupt(pCon,eContinue); + iRet = 0; + } + } + else if(iRet == DEVDONE) + { + SCWrite(pCon,"All done",eStatus); + iRet = 1; + } + else if(iRet = DEVERROR) + { + SCWrite(pCon,"Finished with Problems",eStatus); + iRet = 1; + } + SetStatus(eEager); + return iRet; + } + +/*--------------------------------------------------------------------------*/ + int isInRunMode(pExeList self) + { + if(self == NULL) + { + return 0; + } + else + { + return self->iRun; + } + } +/*--------------------------------------------------------------------------*/ + SConnection *GetExeOwner(pExeList self) + { + if(self == NULL) + return NULL; + + return self->pOwner; + } +/*--------------------------------------------------------------------------*/ + int DevExecTask(void *pData) + { + pExeList self = NULL; + int iRet; + + self = (pExeList)pData; + + /* am I bound to end ? */ + if(self->iEnd) + { + self->lTask = -1; + SetStatus(eEager); + return 0; + } + + iRet = CheckExeList(self); + switch(iRet) + { + case -1: /* some problem */ + if(SCGetInterrupt(self->pOwner) != eContinue) + { + SCWrite(self->pOwner,"ERROR: aborting operation due to HW problem", + eError); + StopExe(self,"all"); +#ifdef DEBUG + printf("DevExecTask found an error\n"); +#endif + return 1; + } + else + { + return 1; + } + break; + case 1: /* Success */ + self->lTask = -1; + self->iEnd = 1; + SetStatus(eEager); +#ifdef DEBUG + printf("DevExecTask finishes on success\n"); +#endif + return 0; + break; + default: /* continue, still busy */ + return 1; + } + /* should not get here */ + return 1; + } +/*---------------------------------------------------------------------------*/ + void DevExecSignal(void *pEL, int iSignal, void *pSigData) + { + int *iInt; + pExeList self = NULL; + + self = (pExeList)pEL; + assert(self); + + if(iSignal == SICSINT) + { + iInt = (int *)pSigData; + if(*iInt != eContinue) + { + if(self->pOwner) + { + SCWrite(self->pOwner, + "ERROR: Interrupting Current Hardware Operation", + eError); + SCSetInterrupt(self->pOwner,*iInt); + } + StopExe(self,"all"); + } + } + } +/*--------------------------------------------------------------------*/ +void LockDeviceExecutor(pExeList self) +{ + assert(self); + self->iLock = 1; +} +/*--------------------------------------------------------------------*/ +void UnlockDeviceExecutor(pExeList self) +{ + assert(self); + self->iLock = 0; +} + + + + + diff --git a/devexec.h b/devexec.h new file mode 100644 index 00000000..b6ece632 --- /dev/null +++ b/devexec.h @@ -0,0 +1,155 @@ + +#line 195 "devexec.w" + +/*---------------------------------------------------------------------------- + + D E V I C E E X E C U T O R + + Joachim Kohlbrecher wants to give several commands to the server + and than wait for them to happen before proceeding. Actually a useful + thing. A command will map to one or several positioning commands for a + device. This scheme is also useful for implementing objects which + drive several motors simulataneously, such as Monochromators. etc. + However, the whole thing is rather complicated. + + It is forbidden, that several clients drive the instrument. In order + to ensure this the Executor remembers the connection which emitted the + first command. Subsequent AddExeEntries from different clients will + be rejected. The owner will be reset when the execution is found finished + in calls to CheckExe, Wait4Success or StopExe. + + + Mark Koennecke, December 1996 + + copyright: see implementation file +---------------------------------------------------------------------------*/ +#ifndef SICSDEVEXEC +#define SICSDEVEXEC +#include "obdes.h" +#include "task.h" + + typedef struct __EXELIST *pExeList; + +/* Returncodes */ + +#define DEVDONE 1 +#define DEVINT 0 +#define DEVERROR 2 +#define DEVBUSY 3 + +/*------------------------------------------------------------------------ + B I R T H & D E A T H +*/ + pExeList CreateExeList(pTaskMan pTask); + void DeleteExeList(void *self); + +/* ================= Functions to talk to the above ====================== */ + +#line 43 "devexec.w" + + int StartDevice(pExeList self, char *name, pObjectDescriptor pDes, + void *pData, SConnection *pCon, float fNew); + int StartMotor(pExeList self, SicsInterp *pSics, SConnection *pCon, + char *name, float fNew); + int StartCounter(pExeList self, SicsInterp *pSics, SConnection *pCon, + char *name); + +#line 239 "devexec.w" + +/*------------------------------------------------------------------------*/ + +#line 88 "devexec.w" + + int CheckExeList(pExeList self); + /* + checks the entries for success and deletes entries which have finished + operation. If there are none left, the pOwner will be set to NULL. + */ + int Wait4Success(pExeList self); + + long GetDevexecID(pExeList self); + + int DevExecTask(void *pEL); + void DevExecSignal(void *pEL, int iSignal, void *pSigData); + + +#line 241 "devexec.w" + + + /* + Waits for execution to finish. returns 1 on Success, 0 if problems + ocurred. Than the Interrupt code shall be checked and acted upon + accordingly. + */ + +/*-------------------------------------------------------------------------*/ + SConnection *GetExeOwner(pExeList self); +/*-------------------------------------------------------------------------*/ + int isInRunMode(pExeList self); +/*--------------------------------------------------------------------------*/ + int ListPending(pExeList self, SConnection *pCon); + /* + lists the Operations still pending on pCon. + */ +/*-------------------------------------------------------------------------*/ + +#line 137 "devexec.w" + + int StopExe(pExeList self, char *name); + int StopExeWait(pExeList self); + /* + will stop the entry name and its subentries from executing. + If ALL is specified as name, everything will be stopped and + the Executor cleared. + StopExeWait will stop all running things and wait for the stop + to complete. + */ +/*------------------------------------------------------------------------*/ + void ClearExecutor(pExeList self); + /* + clears the executor without sending commands to the devices. + */ +/*-----------------------------------------------------------------------*/ + int IsCounting(pExeList self); + int PauseExecution(pExeList self); + int ContinueExecution(pExeList self); + + +#line 259 "devexec.w" + +/*-------------------------- Commands ------------------------------------*/ + int StopCommand(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + /* + implements the stop command + */ + + int ListExe(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + /* + lists all currently executing objects + */ + int Success(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + /* + waits until completion of all pending operations. Used in + connection with non blocking operation such as motors started + with run. + */ +/*--------------------------- Locking ---------------------------------*/ + +#line 183 "devexec.w" + + void LockDeviceExecutor(pExeList self); + void UnlockDeviceExecutor(pExeList self); + + +#line 281 "devexec.w" + +/* -------------------------- Executor management -------------------------*/ + + pExeList GetExecutor(void); + void SetExecutor(pExeList pExe); + +#endif diff --git a/devexec.tex b/devexec.tex new file mode 100644 index 00000000..3fdef4fb --- /dev/null +++ b/devexec.tex @@ -0,0 +1,346 @@ +\subsection{The Device Executor} +The Device Executor (devexec) is a core component of the system. It has to +fulfill three main tasks: +\begin{itemize} +\item Permit non--blocking hardware operations. +\item Ensure regular monitoring of running devices. +\item Ensure that only one client controls the hardware. +\end{itemize} +The devexec in its current form monitors driving and counting +operations only. The emonitor implements another monitor for +environment controllers. + +Please note, that this module is quite crucial for the functioning of +SICS. Any changes here may have side effects throughout the whole +system. Be VERY careful with any changes. The current version does its job! + +Some users want to continue typing commands while some hardware device is +still running. This is sensible, because some hardware devices require a +lot of time before they run to completion. Some people also require to count +while driving motors for quick overview measurements. This requirement was +the main reason for the invention of the devexec. + +Of course, when devices are in operation it is needed to check on them +regularly in order to catch and report error conditions and in order to +find out when devices are finished with their job. + +In a client server system many clients might issue commands to the hardware. +This could quickly lead into an undesirable form of chaos (There are +desirable forms of chaos, but not here!). In order to prevent this a means +is needed to ensure that at any given time only one client controls the +hardware. This function is also performed by the devexec. + +The device executor also has to take care of special error conditions. + +\subsubsection{Starting Devices} +These are the most important SICS operations. Environment controllers are +monitored by the environment monitor. Then here is a convention: {\bf Any +SICS object which +initiates driving or counting operations has to do so by registering this +operation with the devexec}. For this purpose the following interface +functions are provided. + +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap1} +$\langle$devreg {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ int StartDevice(pExeList self, char *name, pObjectDescriptor pDes,@\\ +\mbox{}\verb@ void *pData, SConnection *pCon, float fNew);@\\ +\mbox{}\verb@ int StartMotor(pExeList self, SicsInterp *pSics, SConnection *pCon,@\\ +\mbox{}\verb@ char *name, float fNew);@\\ +\mbox{}\verb@ int StartCounter(pExeList self, SicsInterp *pSics, SConnection *pCon,@\\ +\mbox{}\verb@ char *name); @\\ +\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 main interface function is {\bf StartDevice}. The parameters are: +\begin{itemize} +\item {\bf self}. A pointer to the device executor in which SICS operates. +\item {\bf name}. The name of the object which operates. +\item {\bf pDes}. A pointer to the ObjectDescriptor of the object to drive or count. +\item {\bf pData}. A pointer to the data structure coming with the object. +\item {\bf pCon}. A pointer to the client connection on whose request the + operation was initiated. +\item {\bf fNew}. A floating point value which sets the target value for +drivable devices. +\end{itemize} +{\bf StartMotor, StartCounter} are just convenience wrappers around +StartDevice which retrieve objects from the SICS interpreter and calls +StartDevice thereafter. + +Once invoked StartDevice takes care of the following operations: +\begin{itemize} +\item It first checks on the connection object. If nobody else is running +hardware it enters the connection object specifed as owner of the devexec in +its data structure. If an owner was already specified by a prior drive or +count request StartDevice checks if the connection requesting the new +operation is the same. If this is not the case, an error message about this +situation will be issued. If it is the case, i. e. the client requesting the +new operation is the same as the one who has reserved the devexec, the +operation is performed. This scheme reserves the devexec to one client. +\item If the authorisation is OK, StartDevice then proceeds to start the +drive or counting operation. +\item StartDevice then enters all information regarding +the running device into an list for future monitoring. +\item If it not already running a DevExecTask is registered with the +task module in order to ensure the monitoring of the devices running. +\end{itemize} + +\subsubsection{Monitoring devices} + +From within the SICS main loops this special function is called: +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap2} +$\langle$devcheck {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ int CheckExeList(pExeList self);@\\ +\mbox{}\verb@ /*@\\ +\mbox{}\verb@ checks the entries for success and deletes entries which have finished@\\ +\mbox{}\verb@ operation. If there are none left, the pOwner will be set to NULL.@\\ +\mbox{}\verb@ */ @\\ +\mbox{}\verb@ int Wait4Success(pExeList self);@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ long GetDevexecID(pExeList self);@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ int DevExecTask(void *pEL);@\\ +\mbox{}\verb@ void DevExecSignal(void *pEL, int iSignal, void *pSigData);@\\ +\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} +CheckExeList then scan through its list of executing objects and request a +status from each of them. The next action depend on the status returned from +the device and any pending interrupts: +\begin{itemize} +\item If the device is still busy and no interrupts are pending, nothing +happens. +\item If there is a hardware error, this will be reported and apropriate +actions are intitiated depending on the type of problem and possible +interrupts being sets. +\item If a device is done, either naturally or due to an error or interrupt, +it is removed from devexec's list. +\item If the list is empty, the owner field of the devexec's datastructure +is reset to NULL. Then a new client is free to grab control over the +hardware. +\end{itemize} + +{\bf DevExecTask} is the task function for the device executor. Calls +CheckExeList in the end. If all devices registered with the devexec +are finished running this function returns 0 and thus stops. + +{\bf DevExecSignal} is the signal function for the device executor task. + +{\bf Wait4Success} This function waits for the DevExecTask to +end. This is the case when the current devices running are finished. +There are occasions in the program where it is needed to wait for +an operation to complete before other tasks can be tackled. Wait4Success is +the function to call in such cases. Wait4Success returns DEVDONE for a +properly finished operation, DEVERROR for an operation which finished +with an error code and DEVINT for an aoperation which was interrupted +by the user. + +\subsubsection{Influencing Execution} +In certain cases it is necessary to interact with running devices directly. +This is done via the following interface. + +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap3} +$\langle$devstop {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ int StopExe(pExeList self, char *name);@\\ +\mbox{}\verb@ int StopExeWait(pExeList self);@\\ +\mbox{}\verb@ /*@\\ +\mbox{}\verb@ will stop the entry name and its subentries from executing.@\\ +\mbox{}\verb@ If ALL is specified as name, everything will be stopped and@\\ +\mbox{}\verb@ the Executor cleared.@\\ +\mbox{}\verb@ StopExeWait will stop all running things and wait for the stop@\\ +\mbox{}\verb@ to complete.@\\ +\mbox{}\verb@ */@\\ +\mbox{}\verb@/*------------------------------------------------------------------------*/@\\ +\mbox{}\verb@ void ClearExecutor(pExeList self);@\\ +\mbox{}\verb@ /*@\\ +\mbox{}\verb@ clears the executor without sending commands to the devices.@\\ +\mbox{}\verb@ */@\\ +\mbox{}\verb@/*-----------------------------------------------------------------------*/@\\ +\mbox{}\verb@ int IsCounting(pExeList self);@\\ +\mbox{}\verb@ int PauseExecution(pExeList self);@\\ +\mbox{}\verb@ int ContinueExecution(pExeList self);@\\ +\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} +{\bf StopExe} tackles the interrupting of pending operations. This may +happen on a users request. StopExe then invokes a halt on that device. +As parameters, the name of a device to stop can be specified. If ALL is +given as name to StopExe all executing devices are stopped. Please note, that +this stop does not automatically finish the operation. Motors need some time +to stop, too. This function is usally called as consequence of an +interrupt. + + +{\bf ClearExecutor} clears the executor without invoking commands on the +devices. Is probably only used internally to clean out the executor. + +I some cases, for example if a environment controller gets out of range, an +error handling strategy may want to pause counting until the problem has +been rectified and continue afterwards. {\bf PauseExecution, ContinueExecution} +take care of invoking the apropriate commands on all registered counting +devices. + + +\subsubsection{Locking the Device Executor} +In some instances user code may wish to lock the device executor. An +example is a long running data saving operation. In order to do this +two functions are provided: + +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap4} +$\langle$devlock {\footnotesize ?}$\rangle\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@ void LockDeviceExecutor(pExeList self);@\\ +\mbox{}\verb@ void UnlockDeviceExecutor(pExeList self);@\\ +\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} +\subsubsection{The Rest} +The rest of the interface includes initialisation and deletion routines +and some access routines. With the devexec being such an important system +component a function {\bf GetExecutor} is provided which retrieves a pointer +to the global SICS device executor. + +\begin{flushleft} \small +\begin{minipage}{\linewidth} \label{scrap5} +\verb@"devexec.h"@ {\footnotesize ? }$\equiv$ +\vspace{-1ex} +\begin{list}{}{} \item +\mbox{}\verb@@\\ +\mbox{}\verb@/*----------------------------------------------------------------------------@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ D E V I C E E X E C U T O R@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ Joachim Kohlbrecher wants to give several commands to the server@\\ +\mbox{}\verb@ and than wait for them to happen before proceeding. Actually a useful@\\ +\mbox{}\verb@ thing. A command will map to one or several positioning commands for a@\\ +\mbox{}\verb@ device. This scheme is also useful for implementing objects which@\\ +\mbox{}\verb@ drive several motors simulataneously, such as Monochromators. etc.@\\ +\mbox{}\verb@ However, the whole thing is rather complicated.@\\ +\mbox{}\verb@ @\\ +\mbox{}\verb@ It is forbidden, that several clients drive the instrument. In order@\\ +\mbox{}\verb@ to ensure this the Executor remembers the connection which emitted the@\\ +\mbox{}\verb@ first command. Subsequent AddExeEntries from different clients will@\\ +\mbox{}\verb@ be rejected. The owner will be reset when the execution is found finished@\\ +\mbox{}\verb@ in calls to CheckExe, Wait4Success or StopExe.@\\ +\mbox{}\verb@ @\\ +\mbox{}\verb@ @\\ +\mbox{}\verb@ Mark Koennecke, December 1996@\\ +\mbox{}\verb@ @\\ +\mbox{}\verb@ copyright: see implementation file@\\ +\mbox{}\verb@---------------------------------------------------------------------------*/@\\ +\mbox{}\verb@#ifndef SICSDEVEXEC@\\ +\mbox{}\verb@#define SICSDEVEXEC@\\ +\mbox{}\verb@#include "obdes.h"@\\ +\mbox{}\verb@#include "task.h"@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ typedef struct __EXELIST *pExeList;@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@/* Returncodes */@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@#define DEVDONE 1@\\ +\mbox{}\verb@#define DEVINT 0@\\ +\mbox{}\verb@#define DEVERROR 2@\\ +\mbox{}\verb@#define DEVBUSY 3@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@/*------------------------------------------------------------------------@\\ +\mbox{}\verb@ B I R T H & D E A T H@\\ +\mbox{}\verb@*/@\\ +\mbox{}\verb@ pExeList CreateExeList(pTaskMan pTask);@\\ +\mbox{}\verb@ void DeleteExeList(void *self);@\\ +\mbox{}\verb@ @\\ +\mbox{}\verb@/* ================= Functions to talk to the above ====================== */@\\ +\mbox{}\verb@@$\langle$devreg {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@/*------------------------------------------------------------------------*/@\\ +\mbox{}\verb@@$\langle$devcheck {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ /*@\\ +\mbox{}\verb@ Waits for execution to finish. returns 1 on Success, 0 if problems@\\ +\mbox{}\verb@ ocurred. Than the Interrupt code shall be checked and acted upon@\\ +\mbox{}\verb@ accordingly.@\\ +\mbox{}\verb@ */@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@/*-------------------------------------------------------------------------*/@\\ +\mbox{}\verb@ SConnection *GetExeOwner(pExeList self);@\\ +\mbox{}\verb@/*-------------------------------------------------------------------------*/@\\ +\mbox{}\verb@ int isInRunMode(pExeList self);@\\ +\mbox{}\verb@/*--------------------------------------------------------------------------*/@\\ +\mbox{}\verb@ int ListPending(pExeList self, SConnection *pCon);@\\ +\mbox{}\verb@ /*@\\ +\mbox{}\verb@ lists the Operations still pending on pCon. @\\ +\mbox{}\verb@ */@\\ +\mbox{}\verb@/*-------------------------------------------------------------------------*/@\\ +\mbox{}\verb@@$\langle$devstop {\footnotesize ?}$\rangle$\verb@@\\ +\mbox{}\verb@/*-------------------------- Commands ------------------------------------*/@\\ +\mbox{}\verb@ int StopCommand(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ +\mbox{}\verb@ int argc, char *argv[]);@\\ +\mbox{}\verb@ /*@\\ +\mbox{}\verb@ implements the stop command@\\ +\mbox{}\verb@ */@\\ +\mbox{}\verb@ @\\ +\mbox{}\verb@ int ListExe(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ +\mbox{}\verb@ int argc, char *argv[]);@\\ +\mbox{}\verb@@\\ +\mbox{}\verb@ /*@\\ +\mbox{}\verb@ lists all currently executing objects@\\ +\mbox{}\verb@ */@\\ +\mbox{}\verb@ int Success(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ +\mbox{}\verb@ int argc, char *argv[]);@\\ +\mbox{}\verb@ /*@\\ +\mbox{}\verb@ waits until completion of all pending operations. Used in@\\ +\mbox{}\verb@ connection with non blocking operation such as motors started@\\ +\mbox{}\verb@ with run.@\\ +\mbox{}\verb@ */@\\ +\mbox{}\verb@/*--------------------------- Locking ---------------------------------*/@\\ +\mbox{}\verb@ @$\langle$devlock {\footnotesize ?}$\rangle$\verb@ @\\ +\mbox{}\verb@/* -------------------------- Executor management -------------------------*/@\\ +\mbox{}\verb@ @\\ +\mbox{}\verb@ pExeList GetExecutor(void);@\\ +\mbox{}\verb@ void SetExecutor(pExeList pExe);@\\ +\mbox{}\verb@ @\\ +\mbox{}\verb@#endif @\\ +\mbox{}\verb@@$\diamond$ +\end{list} +\vspace{-2ex} +\end{minipage}\\[4ex] +\end{flushleft} diff --git a/devexec.w b/devexec.w new file mode 100644 index 00000000..48320103 --- /dev/null +++ b/devexec.w @@ -0,0 +1,294 @@ +\subsection{The Device Executor} +The Device Executor (devexec) is a core component of the system. It has to +fulfill three main tasks: +\begin{itemize} +\item Permit non--blocking hardware operations. +\item Ensure regular monitoring of running devices. +\item Ensure that only one client controls the hardware. +\end{itemize} +The devexec in its current form monitors driving and counting +operations only. The emonitor implements another monitor for +environment controllers. + +Please note, that this module is quite crucial for the functioning of +SICS. Any changes here may have side effects throughout the whole +system. Be VERY careful with any changes. The current version does its job! + +Some users want to continue typing commands while some hardware device is +still running. This is sensible, because some hardware devices require a +lot of time before they run to completion. Some people also require to count +while driving motors for quick overview measurements. This requirement was +the main reason for the invention of the devexec. + +Of course, when devices are in operation it is needed to check on them +regularly in order to catch and report error conditions and in order to +find out when devices are finished with their job. + +In a client server system many clients might issue commands to the hardware. +This could quickly lead into an undesirable form of chaos (There are +desirable forms of chaos, but not here!). In order to prevent this a means +is needed to ensure that at any given time only one client controls the +hardware. This function is also performed by the devexec. + +The device executor also has to take care of special error conditions. + +\subsubsection{Starting Devices} +These are the most important SICS operations. Environment controllers are +monitored by the environment monitor. Then here is a convention: {\bf Any +SICS object which +initiates driving or counting operations has to do so by registering this +operation with the devexec}. For this purpose the following interface +functions are provided. + +@d devreg @{ + int StartDevice(pExeList self, char *name, pObjectDescriptor pDes, + void *pData, SConnection *pCon, float fNew); + int StartMotor(pExeList self, SicsInterp *pSics, SConnection *pCon, + char *name, float fNew); + int StartCounter(pExeList self, SicsInterp *pSics, SConnection *pCon, + char *name); +@} + +The main interface function is {\bf StartDevice}. The parameters are: +\begin{itemize} +\item {\bf self}. A pointer to the device executor in which SICS operates. +\item {\bf name}. The name of the object which operates. +\item {\bf pDes}. A pointer to the ObjectDescriptor of the object to drive or count. +\item {\bf pData}. A pointer to the data structure coming with the object. +\item {\bf pCon}. A pointer to the client connection on whose request the + operation was initiated. +\item {\bf fNew}. A floating point value which sets the target value for +drivable devices. +\end{itemize} +{\bf StartMotor, StartCounter} are just convenience wrappers around +StartDevice which retrieve objects from the SICS interpreter and calls +StartDevice thereafter. + +Once invoked StartDevice takes care of the following operations: +\begin{itemize} +\item It first checks on the connection object. If nobody else is running +hardware it enters the connection object specifed as owner of the devexec in +its data structure. If an owner was already specified by a prior drive or +count request StartDevice checks if the connection requesting the new +operation is the same. If this is not the case, an error message about this +situation will be issued. If it is the case, i. e. the client requesting the +new operation is the same as the one who has reserved the devexec, the +operation is performed. This scheme reserves the devexec to one client. +\item If the authorisation is OK, StartDevice then proceeds to start the +drive or counting operation. +\item StartDevice then enters all information regarding +the running device into an list for future monitoring. +\item If it not already running a DevExecTask is registered with the +task module in order to ensure the monitoring of the devices running. +\end{itemize} + +\subsubsection{Monitoring devices} + +From within the SICS main loops this special function is called: +@d devcheck @{ + int CheckExeList(pExeList self); + /* + checks the entries for success and deletes entries which have finished + operation. If there are none left, the pOwner will be set to NULL. + */ + int Wait4Success(pExeList self); + + long GetDevexecID(pExeList self); + + int DevExecTask(void *pEL); + void DevExecSignal(void *pEL, int iSignal, void *pSigData); + +@} +CheckExeList then scan through its list of executing objects and request a +status from each of them. The next action depend on the status returned from +the device and any pending interrupts: +\begin{itemize} +\item If the device is still busy and no interrupts are pending, nothing +happens. +\item If there is a hardware error, this will be reported and apropriate +actions are intitiated depending on the type of problem and possible +interrupts being sets. +\item If a device is done, either naturally or due to an error or interrupt, +it is removed from devexec's list. +\item If the list is empty, the owner field of the devexec's datastructure +is reset to NULL. Then a new client is free to grab control over the +hardware. +\end{itemize} + +{\bf DevExecTask} is the task function for the device executor. Calls +CheckExeList in the end. If all devices registered with the devexec +are finished running this function returns 0 and thus stops. + +{\bf DevExecSignal} is the signal function for the device executor task. + +{\bf Wait4Success} This function waits for the DevExecTask to +end. This is the case when the current devices running are finished. +There are occasions in the program where it is needed to wait for +an operation to complete before other tasks can be tackled. Wait4Success is +the function to call in such cases. Wait4Success returns DEVDONE for a +properly finished operation, DEVERROR for an operation which finished +with an error code and DEVINT for an aoperation which was interrupted +by the user. + +\subsubsection{Influencing Execution} +In certain cases it is necessary to interact with running devices directly. +This is done via the following interface. + +@d devstop @{ + int StopExe(pExeList self, char *name); + int StopExeWait(pExeList self); + /* + will stop the entry name and its subentries from executing. + If ALL is specified as name, everything will be stopped and + the Executor cleared. + StopExeWait will stop all running things and wait for the stop + to complete. + */ +/*------------------------------------------------------------------------*/ + void ClearExecutor(pExeList self); + /* + clears the executor without sending commands to the devices. + */ +/*-----------------------------------------------------------------------*/ + int IsCounting(pExeList self); + int PauseExecution(pExeList self); + int ContinueExecution(pExeList self); + +@} + +{\bf StopExe} tackles the interrupting of pending operations. This may +happen on a users request. StopExe then invokes a halt on that device. +As parameters, the name of a device to stop can be specified. If ALL is +given as name to StopExe all executing devices are stopped. Please note, that +this stop does not automatically finish the operation. Motors need some time +to stop, too. This function is usally called as consequence of an +interrupt. + + +{\bf ClearExecutor} clears the executor without invoking commands on the +devices. Is probably only used internally to clean out the executor. + +I some cases, for example if a environment controller gets out of range, an +error handling strategy may want to pause counting until the problem has +been rectified and continue afterwards. {\bf PauseExecution, ContinueExecution} +take care of invoking the apropriate commands on all registered counting +devices. + + +\subsubsection{Locking the Device Executor} +In some instances user code may wish to lock the device executor. An +example is a long running data saving operation. In order to do this +two functions are provided: + +@d devlock @{ + void LockDeviceExecutor(pExeList self); + void UnlockDeviceExecutor(pExeList self); + +@} + +\subsubsection{The Rest} +The rest of the interface includes initialisation and deletion routines +and some access routines. With the devexec being such an important system +component a function {\bf GetExecutor} is provided which retrieves a pointer +to the global SICS device executor. + +@o devexec.h -d @{ +/*---------------------------------------------------------------------------- + + D E V I C E E X E C U T O R + + Joachim Kohlbrecher wants to give several commands to the server + and than wait for them to happen before proceeding. Actually a useful + thing. A command will map to one or several positioning commands for a + device. This scheme is also useful for implementing objects which + drive several motors simulataneously, such as Monochromators. etc. + However, the whole thing is rather complicated. + + It is forbidden, that several clients drive the instrument. In order + to ensure this the Executor remembers the connection which emitted the + first command. Subsequent AddExeEntries from different clients will + be rejected. The owner will be reset when the execution is found finished + in calls to CheckExe, Wait4Success or StopExe. + + + Mark Koennecke, December 1996 + + copyright: see implementation file +---------------------------------------------------------------------------*/ +#ifndef SICSDEVEXEC +#define SICSDEVEXEC +#include "obdes.h" +#include "task.h" + + typedef struct __EXELIST *pExeList; + +/* Returncodes */ + +#define DEVDONE 1 +#define DEVINT 0 +#define DEVERROR 2 +#define DEVBUSY 3 + +/*------------------------------------------------------------------------ + B I R T H & D E A T H +*/ + pExeList CreateExeList(pTaskMan pTask); + void DeleteExeList(void *self); + +/* ================= Functions to talk to the above ====================== */ +@ +/*------------------------------------------------------------------------*/ +@ + + /* + Waits for execution to finish. returns 1 on Success, 0 if problems + ocurred. Than the Interrupt code shall be checked and acted upon + accordingly. + */ + +/*-------------------------------------------------------------------------*/ + SConnection *GetExeOwner(pExeList self); +/*-------------------------------------------------------------------------*/ + int isInRunMode(pExeList self); +/*--------------------------------------------------------------------------*/ + int ListPending(pExeList self, SConnection *pCon); + /* + lists the Operations still pending on pCon. + */ +/*-------------------------------------------------------------------------*/ +@ +/*-------------------------- Commands ------------------------------------*/ + int StopCommand(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + /* + implements the stop command + */ + + int ListExe(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + + /* + lists all currently executing objects + */ + int Success(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + /* + waits until completion of all pending operations. Used in + connection with non blocking operation such as motors started + with run. + */ +/*--------------------------- Locking ---------------------------------*/ + @ +/* -------------------------- Executor management -------------------------*/ + + pExeList GetExecutor(void); + void SetExecutor(pExeList pExe); + +#endif +@} + + + + + + diff --git a/dict.c b/dict.c new file mode 100644 index 00000000..d850c288 --- /dev/null +++ b/dict.c @@ -0,0 +1,81 @@ + +/*-------------------------------------------------------------------------- + D I C T + + This file exercises some of the NXDICT functionality for test purposes. + It can also serve as an example for the usage of the API. + + Mark Koennecke, August 1997 + + Upgraded to support file idetification and text replacement + + Mark Koennecke, April 1998 +----------------------------------------------------------------------------*/ +#include +#include +#include +#include +#include "dynstring.h" +#include "napi.h" +#include "nxdict.h" + + int main(int argc, char *argv[]) + { + NXdict pDict = NULL; + NXhandle hfil; + void *pData = NULL; + float fTina[3] = { 0.123, 0.234, 0.456}; + float fTest[3], fDelta; + float fTust[20*20]; + char pBuffer[132]; + int i; + + /* test nxdict */ + NXDinitfromfile("test.dict",&pDict); + NXopen("test.hdf",NXACC_CREATE,&hfil); + NXDadd(pDict,"Gundula", + "/entry1,NXentry/SphereOmeter,NXinstrument/SDS"); + NXDupdate(pDict,"Bea","/entry1,NXentry/SDS"); + NXDget(pDict,"Bea",pBuffer,131); + printf("Bea = %s\n",pBuffer); + NXDget(pDict,"Linda",pBuffer,131); + NXDopendef(hfil,pDict,pBuffer); + NXDputalias(hfil,pDict,"Tina",fTina); + NXDputalias(hfil,pDict,"Gina",fTina); + NXDgetalias(hfil,pDict,"Tina",fTest); + NXDgetalias(hfil,pDict,"Gina",fTest); + NXDputalias(hfil,pDict,"Linda",fTust); + NXDaliaslink(hfil,pDict,"Eva","Linda"); + NXDclose(pDict,"close.dict"); + NXclose(&hfil); + printf("NXDICT seemed to have worked \n"); + + /* test Utility functions */ + printf(" Proceeding to test of utility functions \n"); + NXopen("test2.hdf",NXACC_CREATE,&hfil); + NXUwriteglobals(hfil, + "test2.hdf", + "Willibald Wuergehals", + "Rue des Martyrs, 26505 Timbuktu, Legoland ", + "+41-56-3102512", + "Nobody@nowhere.edu", + " 755-898767", + "Dingsbums"); + NXUentergroup(hfil, "TestGroup", "NXtest"); + NXclosegroup(hfil); + NXUentergroup(hfil, "TestGroup", "NXtest"); + + i = 120; + NXUenterdata(hfil,"TestData",DFNT_INT8, 1,&i,"Testis"); + NXclosedata(hfil); + NXUenterdata(hfil,"TestData",DFNT_INT8, 1,&i,"Testis"); + + NXUallocSDS(hfil,&pData); + NXUfreeSDS(&pData); + NXclose(&hfil); + printf("All tests seem to have worked OK, %s %s\n", + "but the test is pathetic\n", + "Do not rely, in any circumstances, on this test alone"); + + + } diff --git a/difrac.c b/difrac.c new file mode 100644 index 00000000..4f09755a --- /dev/null +++ b/difrac.c @@ -0,0 +1,539 @@ +/*------------------------------------------------------------------------- + D I F R A C + + A four-circle diffractometer requires sophicticated procedures for + searching peaks, orienting crystals and for performing data collection. + Rather then invent all of this again the DIFRAC-F77 program written by + Peter White and Eric Gabe has been incoporated into SICS. This module + provides the C-language side of the interface between DIFRAC and SICS. + DIFRAC can only be included once into SICS, it is not possible to have + more then one copy of this. This is why there is file static global data + here. + + copyright: see copyright.h + + Mark Koennecke, November 1999 + --------------------------------------------------------------------------*/ +#include +#include +#include +#include "fortify.h" +#include "sics.h" +#include "motor.h" +#include "counter.h" +#include "status.h" +#include "splitter.h" +#include "difrac.h" + +/*-------------------------------------------------------------------------- + In order to deal with multiple request to the DIFRAC subsystem we need to + keep the connection objects on a stack. This stack is defined here. + ---------------------------------------------------------------------------*/ +#define MAXSTACK 50 + + static SConnection *ConStack[MAXSTACK]; + static int iConStackPtr = -1; + +/*-------------------------------------------------------------------------- + In order to do the four circle work we need to know the motors of the + eulerian cradle and access to the counter. Furthermore we need to know + about the omega2theta motor and the scanning routine. + These data structures are initialized by the installation routine. + ---------------------------------------------------------------------------*/ + + static pMotor pTTH, pOM, pCHI, pPHI; + static pCounter counter; +/*--------------------------------------------------------------------------- + The following routines will be called from F77. Their names take care of the + system dependent name mangling scheme for calling C from F77. This may + need adjustment when porting to another system + ---------------------------------------------------------------------------*/ +/*========= read angles */ + void sicsanget_(float *fTH, float *fOM, float *fCHI, float *fPHI) + { + int iRet; + + /* this is just security, may never happen */ + if(iConStackPtr < 0) + { + return; + } + if(ConStack[iConStackPtr] == NULL) + { + return; + } + + iRet = MotorGetSoftPosition(pTTH,ConStack[iConStackPtr],fTH); + if(iRet != 1) + { + SCWrite(ConStack[iConStackPtr], + "ERROR: failed to read two theta, DIFRAC may be confused now", + eError); + } + iRet = MotorGetSoftPosition(pOM,ConStack[iConStackPtr],fOM); + if(iRet != 1) + { + SCWrite(ConStack[iConStackPtr], + "ERROR: failed to read omega, DIFRAC may be confused now", + eError); + } + iRet = MotorGetSoftPosition(pCHI,ConStack[iConStackPtr],fCHI); + if(iRet != 1) + { + SCWrite(ConStack[iConStackPtr], + "ERROR: failed to read chi, DIFRAC may be confused now", + eError); + } + iRet = MotorGetSoftPosition(pPHI,ConStack[iConStackPtr],fPHI); + if(iRet != 1) + { + SCWrite(ConStack[iConStackPtr], + "ERROR: failed to read two theta, DIFRAC may be confused now", + eError); + } + } +#define ABS(x) (x < 0 ? -(x) : (x)) +/*=========== check angles */ + void sicsangcheck_(float *fTH, float *fOM, float *fCHI, float *fPHI, + int *iInvalid) + { + int iRet; + SConnection *pCon = NULL; + float fHard; + char pBueffel[256], pError[131]; + + /* this is just security, may never happen */ + if(iConStackPtr < 0) + { + return; + } + if(ConStack[iConStackPtr] == NULL) + { + return; + } + pCon = ConStack[iConStackPtr]; + + *iInvalid = 0; + iRet = MotorCheckBoundary(pTTH,*fTH,&fHard,pError,131); + if(iRet != 1) + { + sprintf(pBueffel, + "ERROR: %6.2f %6.2f %6.2f %6.2f violates twotheta limits", + *fTH, *fOM, *fCHI, *fPHI); + SCWrite(pCon,pBueffel,eError); + *iInvalid = 4; + return; + } + iRet = MotorCheckBoundary(pOM,*fOM,&fHard,pError,131); + if(iRet != 1) + { + sprintf(pBueffel, + "ERROR: %6.2f %6.2f %6.2f %6.2f violates omega limits", + *fTH, *fOM, *fCHI, *fPHI); + SCWrite(pCon,pBueffel,eError); + *iInvalid = 4; + return; + } + iRet = MotorCheckBoundary(pCHI,*fCHI,&fHard,pError,131); + if(iRet != 1) + { + sprintf(pBueffel, + "ERROR: %6.2f %6.2f %6.2f %6.2f violates chi limits", + *fTH, *fOM, *fCHI, *fPHI); + SCWrite(pCon,pBueffel,eError); + *iInvalid = 4; + return; + } + iRet = MotorCheckBoundary(pPHI,*fPHI,&fHard,pError,131); + if(iRet != 1) + { + sprintf(pBueffel, + "ERROR: %6.2f %6.2f %6.2f %6.2f violates phi limits", + *fTH, *fOM, *fCHI, *fPHI); + SCWrite(pCon,pBueffel,eError); + *iInvalid = 4; + return; + } + } +/*======== set angles */ + void sicsangset_(float *fTTH, float *fOM, float *fCHI, float *fPHI, + int *icol) + { + pDummy pDum; + int iRet; + SConnection *pCon = NULL; + float fT1, fT2, fT3, fT4; + + *icol = 0; + + /* this is just security, may never happen */ + if(iConStackPtr < 0) + { + return; + } + if(ConStack[iConStackPtr] == NULL) + { + return; + } + pCon = ConStack[iConStackPtr]; + + + /* check if this is possible, if not complain */ + sicsangcheck_(fTTH, fOM,fCHI,fPHI, &iRet); + if(iRet >= 4) + { + *icol = 1; + return; + } + + /* start */ + pDum = (pDummy)pTTH; + iRet = StartDevice(pServ->pExecutor, "TTH", + pDum->pDescriptor, pDum,pCon, *fTTH); + if(!iRet) + { + SCWrite(pCon,"ERROR: cannot start two theta motor",eError); + StopExe(pServ->pExecutor,"all"); + *icol = 10; + } + pDum = (pDummy)pOM; + iRet = StartDevice(pServ->pExecutor, "OM", + pDum->pDescriptor, pDum,pCon, *fOM); + if(!iRet) + { + SCWrite(pCon,"ERROR: cannot start omega motor",eError); + StopExe(pServ->pExecutor,"all"); + *icol = 10; + } + pDum = (pDummy)pCHI; + iRet = StartDevice(pServ->pExecutor, "CHI", + pDum->pDescriptor, pDum,pCon, *fCHI); + if(!iRet) + { + SCWrite(pCon,"ERROR: cannot start chi motor",eError); + StopExe(pServ->pExecutor,"all"); + *icol = 10; + } + pDum = (pDummy)pPHI; + iRet = StartDevice(pServ->pExecutor, "PHI", + pDum->pDescriptor, pDum,pCon, *fPHI); + if(!iRet) + { + SCWrite(pCon,"ERROR: cannot start two theta motor",eError); + StopExe(pServ->pExecutor,"all"); + *icol = 10; + } + + /* wait for end of it */ + iRet = Wait4Success(pServ->pExecutor); + switch(iRet) + { + case DEVINT: + if(SCGetInterrupt(pCon) == eAbortOperation) + { + SCSetInterrupt(pCon,eContinue); + SCSetError(pCon,OKOK); + } + break; + case DEVDONE: + break; + default: + break; + } + + /* + As TRICS has such a shitty cradle check angles and report error + if bad + */ + sicsanget_(&fT1, &fT2, &fT3, &fT4); + if(ABS(fT1 - *fTTH) > .2) + { + *icol = 10; + } + if(ABS(fT2 - *fOM) > .2) + { + *icol = 10; + } + if(ABS(fT3 - *fCHI) > .2) + { + *icol = 10; + } + if(ABS(fT4 - *fPHI) > .2) + { + *icol = 10; + } + } +/*=========== count */ + void sicscount_(float *fPreset, float *fCounts) + { + pDummy pDum; + int iRet; + SConnection *pCon = NULL; + long lTask; + + /* this is just security, may never happen */ + if(iConStackPtr < 0) + { + return; + } + if(ConStack[iConStackPtr] == NULL) + { + return; + } + pCon = ConStack[iConStackPtr]; + + pDum = (pDummy)counter; + SetCounterPreset(counter,*fPreset); + iRet = StartDevice(pServ->pExecutor, + "DifracCount", + pDum->pDescriptor, + counter, + pCon, + *fPreset); + if(!iRet) + { + SCWrite(pCon,"ERROR: Failed to start counting ",eError); + return; + } + SetStatus(eCounting); + /* wait for finish */ + lTask = GetDevexecID(pServ->pExecutor); + if(lTask > 0); + { + TaskWait(pServ->pTasker,lTask); + } + *fCounts = (float)GetCounts(counter,pCon); + } +/*========= sicswrite */ + void sicswrite_(int *iText, int *iLen) + { + SConnection *pCon = NULL; + char pBueffel[256]; + int i; + + if(*iLen > 255) + return; + + for(i = 0; i < *iLen; i++) + { + pBueffel[i] = (char)iText[i]; + } + pBueffel[i] = '\0'; + + /* this is just security, may never happen */ + if(iConStackPtr < 0) + { + puts(pBueffel); + return; + } + if(ConStack[iConStackPtr] == NULL) + { + puts(pBueffel); + return; + } + pCon = ConStack[iConStackPtr]; + + SCWrite(pCon,pBueffel,eValue); + } +/*========== sicsgetline */ + void sicsgetline_(int *iText, int *iLen) + { + SConnection *pCon = NULL; + char pBueffel[256]; + int i, iRet; + + /* this is just security, may never happen */ + if(iConStackPtr < 0) + { + return; + } + if(ConStack[iConStackPtr] == NULL) + { + return; + } + pCon = ConStack[iConStackPtr]; + + iRet = SCPrompt(pCon,"Enter data please >>" , pBueffel, 255); + /* difrac cannot handle an interrupted input operation */ + if(iRet == 0) + { + SCSetInterrupt(pCon,eContinue); + } + for(i = 0; i < strlen(pBueffel); i++) + { + iText[i] = (int)pBueffel[i]; + } + *iLen = strlen(pBueffel); + } +/*============= checkint */ + void checkint_(int *iK) + { + SConnection *pCon = NULL; + char pBueffel[256]; + int i; + + /* this is just security, may never happen */ + if(iConStackPtr < 0) + { + *iK = 0; + return; + } + if(ConStack[iConStackPtr] == NULL) + { + return; + } + pCon = ConStack[iConStackPtr]; + + if(SCGetInterrupt(pCon) >= eAbortScan) + { + *iK = 0; + } + else + { + *iK = 1; + } + } +/*-------------------------------------------------------------------------- + DifracAction is the interface routine between the SICS interpreter and + the DIFRAC subsystem. What it basically does is: pop the connection onto + the stack. Concatenate all pending command line data to a string. Then + call DIFRAC with this string as an parameter. On return, remove the + connection from the stack again and return. + -------------------------------------------------------------------------*/ +/* some protoypes for things defined in F77 */ + + extern void difini_(void); + extern void difint_(int *iText, int *iLen); + + int DifracAction(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + char pInput[256]; + int iInput[256]; + int iLen, i; + + + if(argc < 2) + { + SCWrite(pCon,"ERROR: dif expects at least one argument",eError); + return 0; + } + + /* user privilege required */ + if(!SCMatchRights(pCon,usUser)) + { + return 0; + } + + /* steal: redirect the I/O to me */ + strcpy(pInput,argv[1]); + strtolower(pInput); + if(strcmp(pInput,"steal") == 0) + { + if(iConStackPtr >= 0) + { + ConStack[iConStackPtr] = pCon; + } + SCSendOK(pCon); + return 1; + } + + iConStackPtr++; + ConStack[iConStackPtr] = pCon; + + Arg2Text(argc-1, &argv[1],pInput,255); + iLen = strlen(pInput); + for(i = 0; i < iLen; i++) + { + iInput[i] = toupper((int)pInput[i]); + } + + /* do difrac */ + difint_(iInput, &iLen); + SCWrite(pCon,"Difrac subsystem finished",eWarning); + + iConStackPtr--; + if(SCGetInterrupt(pCon) != eContinue) + { + return 0; + } + else + { + return 1; + } + } +/*-------------------- The initialization routine ----------------------*/ + int MakeDifrac(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) + { + CommandList *pCom = NULL; + pICountable pCts = NULL; + int iRet; + + if(argc < 6) + { + SCWrite(pCon, + "ERROR: Insufficient number of arguments to MakeDifrac",eError); + return 0; + } + + /* find motors */ + pTTH = FindMotor(pSics,argv[1]); + if(!pTTH) + { + SCWrite(pCon,"ERROR: cannot find two theta motor",eError); + return 0; + } + pOM = FindMotor(pSics,argv[2]); + if(!pOM) + { + SCWrite(pCon,"ERROR: cannot find omega motor",eError); + return 0; + } + pCHI = FindMotor(pSics,argv[3]); + if(!pTTH) + { + SCWrite(pCon,"ERROR: cannot find chi motor",eError); + return 0; + } + pPHI = FindMotor(pSics,argv[4]); + if(!pTTH) + { + SCWrite(pCon,"ERROR: cannot find phi motor",eError); + return 0; + } + + /* locate counter */ + pCom = FindCommand(pSics,argv[5]); + if(pCom == NULL) + { + SCWrite(pCon,"ERROR: counter not found in MakeDifrac", + eError); + return 0; + } + pCts = GetCountableInterface(pCom->pData); + if(!pCts) + { + SCWrite(pCon,"ERROR: argument to MakeDifrac is no counter", + eError); + return 0; + } + counter = (pCounter)pCom->pData; + + /* initialize difrac */ + difini_(); + + /* install command */ + iRet = AddCommand(pSics, + "dif", + DifracAction, + NULL, + NULL); + if(!iRet) + { + SCWrite(pCon,"ERROR: duplicate command dif NOT created", + eError); + } + return iRet; + } + diff --git a/difrac.h b/difrac.h new file mode 100644 index 00000000..b10a62f5 --- /dev/null +++ b/difrac.h @@ -0,0 +1,14 @@ +/*-------------------------------------------------------------------------- + D I F R A C + + Header file for the interface between SICS and the F77 package + DIFRAC. Only the factory routine is defined. + + Mark Koennecke, November 1999 + --------------------------------------------------------------------------*/ +#ifndef DIFRAC +#define DIFRAC + + int MakeDifrac(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); +#endif diff --git a/difrac/CAD4COMM b/difrac/CAD4COMM new file mode 100644 index 00000000..b0aa2585 --- /dev/null +++ b/difrac/CAD4COMM @@ -0,0 +1,728 @@ +*$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 new file mode 100644 index 00000000..038e02a6 --- /dev/null +++ b/difrac/COMDIF @@ -0,0 +1,54 @@ + 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 new file mode 100644 index 00000000..baad07ba --- /dev/null +++ b/difrac/IATSIZ @@ -0,0 +1,5 @@ +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 new file mode 100644 index 00000000..54cb1bed --- /dev/null +++ b/difrac/Makefile @@ -0,0 +1,53 @@ +#--------------------------------------------------------------------------- +# 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 new file mode 100644 index 00000000..ada4fed5 --- /dev/null +++ b/difrac/alfnum.f @@ -0,0 +1,50 @@ +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 new file mode 100644 index 00000000..79a6871d --- /dev/null +++ b/difrac/align.f @@ -0,0 +1,640 @@ +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 new file mode 100644 index 00000000..64335d47 --- /dev/null +++ b/difrac/ang180.f @@ -0,0 +1,8 @@ +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 new file mode 100644 index 00000000..2b683e63 --- /dev/null +++ b/difrac/ang360.f @@ -0,0 +1,13 @@ +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 new file mode 100644 index 00000000..1d635ab4 --- /dev/null +++ b/difrac/angcal.f @@ -0,0 +1,285 @@ +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 new file mode 100644 index 00000000..02af5bfc --- /dev/null +++ b/difrac/angl.f @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000..c69d3eef --- /dev/null +++ b/difrac/angrw.f @@ -0,0 +1,76 @@ +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 new file mode 100644 index 00000000..299e2c65 --- /dev/null +++ b/difrac/angval.f @@ -0,0 +1,20 @@ +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 new file mode 100644 index 00000000..5475b632 --- /dev/null +++ b/difrac/basinp.f @@ -0,0 +1,722 @@ +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 new file mode 100644 index 00000000..2818ab2a --- /dev/null +++ b/difrac/begin.f @@ -0,0 +1,436 @@ +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 new file mode 100644 index 00000000..cb1f1fed --- /dev/null +++ b/difrac/bigchi.f @@ -0,0 +1,146 @@ +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 new file mode 100644 index 00000000..78b60874 --- /dev/null +++ b/difrac/blind.f @@ -0,0 +1,727 @@ +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 new file mode 100644 index 00000000..e47da3b1 --- /dev/null +++ b/difrac/burger.f @@ -0,0 +1,174 @@ +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 new file mode 100644 index 00000000..f07cfde8 --- /dev/null +++ b/difrac/cad4io.f @@ -0,0 +1,517 @@ +! +! 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 new file mode 100644 index 00000000..196895a4 --- /dev/null +++ b/difrac/cad4l.f @@ -0,0 +1,454 @@ + 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 new file mode 100644 index 00000000..3e2c79a0 --- /dev/null +++ b/difrac/cad4l.mak @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000..7cd94fe5 --- /dev/null +++ b/difrac/cartc.f @@ -0,0 +1,18 @@ +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 new file mode 100644 index 00000000..ffd5ff6a --- /dev/null +++ b/difrac/cellls.f @@ -0,0 +1,628 @@ +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 new file mode 100644 index 00000000..e4f8a7a1 --- /dev/null +++ b/difrac/cellsd.f @@ -0,0 +1,123 @@ +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 new file mode 100644 index 00000000..03f34af7 --- /dev/null +++ b/difrac/cent8.f @@ -0,0 +1,405 @@ +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 new file mode 100644 index 00000000..893bcea8 --- /dev/null +++ b/difrac/centre.f @@ -0,0 +1,507 @@ +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 new file mode 100644 index 00000000..beed4b8d --- /dev/null +++ b/difrac/cfind.f @@ -0,0 +1,63 @@ +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 new file mode 100644 index 00000000..566fb7b6 --- /dev/null +++ b/difrac/cinput.f @@ -0,0 +1,56 @@ +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 new file mode 100644 index 00000000..40f1528f --- /dev/null +++ b/difrac/cntref.f @@ -0,0 +1,88 @@ +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 new file mode 100644 index 00000000..3084b82a --- /dev/null +++ b/difrac/comptn.f @@ -0,0 +1,69 @@ +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 new file mode 100644 index 00000000..6d0bfa67 --- /dev/null +++ b/difrac/creduc.f @@ -0,0 +1,340 @@ +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 new file mode 100644 index 00000000..e0024d64 --- /dev/null +++ b/difrac/demo1e.f @@ -0,0 +1,138 @@ +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 new file mode 100644 index 00000000..a11220a4 --- /dev/null +++ b/difrac/dhgen.f @@ -0,0 +1,215 @@ +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 new file mode 100644 index 00000000..5e3a9995 Binary files /dev/null and b/difrac/dif.asc differ diff --git a/difrac/dif.mak b/difrac/dif.mak new file mode 100644 index 00000000..a429f77c --- /dev/null +++ b/difrac/dif.mak @@ -0,0 +1,34 @@ +CFLAGS = -FPc -Od -c -Lr -Gs -Gt 512 -W2 +FL = c:\fortran\bin\fl $(CFLAGS) +ROOT = .. +LIBS = $(ROOT)\libs + +OBJECTS= difrac.obj \ + ang180.obj ang360.obj angval.obj begin.obj \ + cent8.obj cfind.obj demo1e.obj align.obj \ + centre.obj mod360.obj profil.obj range.obj sinmat.obj cellls.obj \ + wxw2t.obj angcal.obj basinp.obj comptn.obj orcel2.obj inchkl.obj \ + linprf.obj lsormt.obj mesint.obj goloop.obj ormat3.obj blind.obj \ + params.obj pltprf.obj pcount.obj prtang.obj prnbas.obj prnint.obj \ + grid.obj sammes.obj cellsd.obj stdmes.obj cntref.obj indmes.obj \ + wrbas.obj reindx.obj rcpcor.obj lotem.obj nexseg.obj lister.obj \ + oscil.obj pfind.obj pscan.obj peaksr.obj sgprnh.obj \ + setop.obj tcentr.obj tfind.obj fndsys.obj \ + dhgen.obj setrow.obj ralf.obj creduc.obj cinput.obj \ + pcdraw.obj burger.obj prompt.obj angrw.obj bigchi.obj \ + eulkap.obj cad4io.obj qio.obj + +GENS = yesno.obj freefm.obj alfnum.obj matrix.obj \ + sgroup.obj latmod.obj sgrmat.obj \ + sglatc.obj sglpak.obj sgerrs.obj sgmtml.obj \ + sgtrcf.obj \ + setiou.obj ibmfil.obj + +EXEC = difrac.exe + +$(EXEC): $(OBJECTS) $(GENS) + link @dif.ovl + + +.for.obj: + $(FL) $< diff --git a/difrac/dif.wpd b/difrac/dif.wpd new file mode 100644 index 00000000..b757dbeb Binary files /dev/null and b/difrac/dif.wpd differ diff --git a/difrac/difini.f b/difrac/difini.f new file mode 100644 index 00000000..055654e1 --- /dev/null +++ b/difrac/difini.f @@ -0,0 +1,248 @@ +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 new file mode 100644 index 00000000..3ea99cf8 --- /dev/null +++ b/difrac/difint.f @@ -0,0 +1,724 @@ +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 new file mode 100644 index 00000000..0da85ab6 --- /dev/null +++ b/difrac/difrac.f @@ -0,0 +1,245 @@ +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 new file mode 100644 index 00000000..f32a8047 --- /dev/null +++ b/difrac/eulkap.f @@ -0,0 +1,50 @@ +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 new file mode 100644 index 00000000..25dc4bc1 --- /dev/null +++ b/difrac/fndsys.f @@ -0,0 +1,399 @@ +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 new file mode 100644 index 00000000..4a9c89ab --- /dev/null +++ b/difrac/goniom.ini @@ -0,0 +1,39 @@ +/ 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 new file mode 100644 index 00000000..0ae9fab9 --- /dev/null +++ b/difrac/grid.f @@ -0,0 +1,195 @@ +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 new file mode 100644 index 00000000..594e0d1a --- /dev/null +++ b/difrac/gwrite.f @@ -0,0 +1,115 @@ +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 new file mode 100644 index 00000000..25b40479 --- /dev/null +++ b/difrac/ibmfil.f @@ -0,0 +1,184 @@ +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 new file mode 100644 index 00000000..2d71eaa7 --- /dev/null +++ b/difrac/iedevs.f @@ -0,0 +1,49 @@ +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 new file mode 100644 index 00000000..6d0df4be --- /dev/null +++ b/difrac/inchkl.f @@ -0,0 +1,81 @@ +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 new file mode 100644 index 00000000..3fe0027e --- /dev/null +++ b/difrac/indmes.f @@ -0,0 +1,466 @@ +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 new file mode 100644 index 00000000..d2c29fc3 --- /dev/null +++ b/difrac/keyget.f @@ -0,0 +1,28 @@ +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 new file mode 100644 index 00000000..c1d5663d --- /dev/null +++ b/difrac/latmod.f @@ -0,0 +1,37 @@ +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 new file mode 100644 index 00000000..add92b37 --- /dev/null +++ b/difrac/linprf.f @@ -0,0 +1,151 @@ +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 new file mode 100644 index 00000000..35361d30 --- /dev/null +++ b/difrac/list.dat @@ -0,0 +1,80 @@ +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 new file mode 100644 index 00000000..e8244bd7 --- /dev/null +++ b/difrac/lister.f @@ -0,0 +1,257 @@ +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 new file mode 100644 index 00000000..81dcfd1d --- /dev/null +++ b/difrac/lotem.f @@ -0,0 +1,24 @@ +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 new file mode 100644 index 00000000..2da60733 --- /dev/null +++ b/difrac/lsormt.f @@ -0,0 +1,547 @@ +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 new file mode 100644 index 00000000..dc300f1e --- /dev/null +++ b/difrac/matrix.f @@ -0,0 +1,234 @@ +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 new file mode 100644 index 00000000..5ddf9799 --- /dev/null +++ b/difrac/mesint.f @@ -0,0 +1,407 @@ +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 new file mode 100644 index 00000000..13cef5e3 --- /dev/null +++ b/difrac/mod360.f @@ -0,0 +1,8 @@ +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 new file mode 100644 index 00000000..690eeec6 --- /dev/null +++ b/difrac/nexseg.f @@ -0,0 +1,58 @@ +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 new file mode 100644 index 00000000..2761db93 --- /dev/null +++ b/difrac/orcel2.f @@ -0,0 +1,318 @@ +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 new file mode 100644 index 00000000..cba37e22 --- /dev/null +++ b/difrac/ormat3.f @@ -0,0 +1,211 @@ +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 new file mode 100644 index 00000000..ebe7be6d --- /dev/null +++ b/difrac/oscil.f @@ -0,0 +1,93 @@ +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 new file mode 100644 index 00000000..43360dd0 --- /dev/null +++ b/difrac/params.f @@ -0,0 +1,21 @@ +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 new file mode 100644 index 00000000..510a74ce --- /dev/null +++ b/difrac/pcdraw.f @@ -0,0 +1,330 @@ +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 new file mode 100644 index 00000000..73e9e943 --- /dev/null +++ b/difrac/pcount.f @@ -0,0 +1,149 @@ +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 new file mode 100644 index 00000000..cab7b200 --- /dev/null +++ b/difrac/peaksr.f @@ -0,0 +1,209 @@ +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 new file mode 100644 index 00000000..d7630ed9 --- /dev/null +++ b/difrac/pfind.f @@ -0,0 +1,55 @@ +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 new file mode 100644 index 00000000..4ebc1ad6 --- /dev/null +++ b/difrac/pltprf.f @@ -0,0 +1,144 @@ +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 new file mode 100644 index 00000000..dcb45401 --- /dev/null +++ b/difrac/prnbas.f @@ -0,0 +1,291 @@ +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 new file mode 100644 index 00000000..fc3a16f0 --- /dev/null +++ b/difrac/prnint.f @@ -0,0 +1,423 @@ +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 new file mode 100644 index 00000000..883d352d --- /dev/null +++ b/difrac/profil.f @@ -0,0 +1,475 @@ +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 new file mode 100644 index 00000000..1dcbeca1 --- /dev/null +++ b/difrac/prompt.f @@ -0,0 +1,157 @@ +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 new file mode 100644 index 00000000..3aeb71e4 --- /dev/null +++ b/difrac/prtang.f @@ -0,0 +1,12 @@ +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 new file mode 100644 index 00000000..fc514554 --- /dev/null +++ b/difrac/pscan.f @@ -0,0 +1,86 @@ +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 new file mode 100644 index 00000000..8618124a --- /dev/null +++ b/difrac/qio.f @@ -0,0 +1,204 @@ + 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 new file mode 100644 index 00000000..65c31e93 --- /dev/null +++ b/difrac/ralf.f @@ -0,0 +1,1121 @@ +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 new file mode 100644 index 00000000..37bdedbf --- /dev/null +++ b/difrac/range.f @@ -0,0 +1,13 @@ +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 new file mode 100644 index 00000000..50cf7957 --- /dev/null +++ b/difrac/rcpcor.f @@ -0,0 +1,125 @@ +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 new file mode 100644 index 00000000..78a0d90f --- /dev/null +++ b/difrac/readme.dif @@ -0,0 +1,128 @@ + + + + + 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 new file mode 100644 index 00000000..b20be589 --- /dev/null +++ b/difrac/reindx.f @@ -0,0 +1,105 @@ +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 new file mode 100644 index 00000000..9c6fcb1d --- /dev/null +++ b/difrac/sammes.f @@ -0,0 +1,116 @@ +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 new file mode 100644 index 00000000..0406ea3f --- /dev/null +++ b/difrac/setiou.f @@ -0,0 +1,87 @@ +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 new file mode 100644 index 00000000..be1dacfa --- /dev/null +++ b/difrac/setop.f @@ -0,0 +1,724 @@ +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 new file mode 100644 index 00000000..3130f1f9 --- /dev/null +++ b/difrac/setrow.f @@ -0,0 +1,184 @@ +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 new file mode 100644 index 00000000..65d88f5a --- /dev/null +++ b/difrac/sgerrs.f @@ -0,0 +1,40 @@ +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 new file mode 100644 index 00000000..f885f393 --- /dev/null +++ b/difrac/sglatc.f @@ -0,0 +1,656 @@ +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 new file mode 100644 index 00000000..8474cc34 --- /dev/null +++ b/difrac/sglpak.f @@ -0,0 +1,11 @@ +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 new file mode 100644 index 00000000..023b8905 --- /dev/null +++ b/difrac/sgmtml.f @@ -0,0 +1,23 @@ +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 new file mode 100644 index 00000000..a200a5d2 --- /dev/null +++ b/difrac/sgprnh.f @@ -0,0 +1,125 @@ +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 new file mode 100644 index 00000000..787909b4 --- /dev/null +++ b/difrac/sgrmat.f @@ -0,0 +1,30 @@ +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 new file mode 100644 index 00000000..85a0e4e6 --- /dev/null +++ b/difrac/sgroup.f @@ -0,0 +1,561 @@ +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 new file mode 100644 index 00000000..3a1ffdbc --- /dev/null +++ b/difrac/sgtrcf.f @@ -0,0 +1,68 @@ +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 new file mode 100644 index 00000000..e82f2a6b --- /dev/null +++ b/difrac/sinmat.f @@ -0,0 +1,87 @@ +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 new file mode 100644 index 00000000..eece02bc --- /dev/null +++ b/difrac/stdmes.f @@ -0,0 +1,168 @@ +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 new file mode 100644 index 00000000..a9727197 --- /dev/null +++ b/difrac/swrite.f @@ -0,0 +1,109 @@ +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 new file mode 100644 index 00000000..06ae6eec --- /dev/null +++ b/difrac/sysang.f @@ -0,0 +1,74 @@ +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 new file mode 100644 index 00000000..fb545541 --- /dev/null +++ b/difrac/tcentr.f @@ -0,0 +1,190 @@ +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 new file mode 100644 index 00000000..bf27a702 --- /dev/null +++ b/difrac/tfind.f @@ -0,0 +1,59 @@ +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 new file mode 100644 index 00000000..1112b67c --- /dev/null +++ b/difrac/trics.f @@ -0,0 +1,354 @@ +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 new file mode 100644 index 00000000..e54445cc --- /dev/null +++ b/difrac/wrbas.f @@ -0,0 +1,77 @@ +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 new file mode 100644 index 00000000..d392eb6c --- /dev/null +++ b/difrac/wxw2t.f @@ -0,0 +1,85 @@ +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 new file mode 100644 index 00000000..c764cf3e --- /dev/null +++ b/difrac/yesno.f @@ -0,0 +1,48 @@ +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 new file mode 100644 index 00000000..800f332e --- /dev/null +++ b/dilludriv.c @@ -0,0 +1,272 @@ +/*-------------------------------------------------------------------------- + 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 new file mode 100644 index 00000000..19e0b43c --- /dev/null +++ b/dilludriv.h @@ -0,0 +1,15 @@ +/*------------------------------------------------------------------------ + 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/dilu.tem b/dilu.tem new file mode 100644 index 00000000..307ff98c --- /dev/null +++ b/dilu.tem @@ -0,0 +1,41 @@ +DILLUTION CRYO., GERMANIUM RESISTANCE THERMOMETER, MODEL 5-HE3A SERIAL # 50466 + 0.0400 46900.0000 + 0.0500 33085.0000 + 0.0600 19270.0000 + 0.0700 12571.0000 + 0.0800 8900.0000 + 0.0900 6739.8999 + 0.1000 5260.0000 + 0.1500 2040.0000 + 0.2000 1125.0000 + 0.2500 740.1000 + 0.3000 542.3000 + 0.3500 426.9900 + 0.4000 350.9000 + 0.4500 297.8300 + 0.5000 258.5000 + 0.6000 204.6000 + 0.7000 170.4000 + 0.8000 146.7000 + 0.9000 129.7000 + 1.0000 116.3000 + 1.1000 105.2100 + 1.2000 96.4400 + 1.3000 89.3120 + 1.4000 83.5000 + 1.5000 78.7520 + 1.6000 74.6500 + 1.7000 71.0840 + 1.8000 67.9200 + 1.9000 65.0960 + 2.0000 62.5500 + 2.2000 58.1400 + 2.4000 54.5500 + 2.6000 51.4580 + 2.8000 48.7660 + 3.0000 46.3920 + 3.2000 44.2760 + 4.2000 36.9800 + 77.3500 5.1400 + 296.6500 2.5200 + diff --git a/dmc.c b/dmc.c new file mode 100644 index 00000000..31614cff --- /dev/null +++ b/dmc.c @@ -0,0 +1,54 @@ +/*------------------------------------------------------------------------- + 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 new file mode 100644 index 00000000..aee4fb39 --- /dev/null +++ b/dmc.h @@ -0,0 +1,19 @@ + +/*------------------------------------------------------------------------- + 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.tcl b/dmc.tcl new file mode 100644 index 00000000..84056e5c --- /dev/null +++ b/dmc.tcl @@ -0,0 +1,187 @@ +# -------------------------------------------------------------------------- +# Initialization script for DMC at SINQ, SICS server. +# +# Dr. Mark Koennecke Juli 1997 +#--------------------------------------------------------------------------- +# O P T I O N S + +set auto_path "/home/DMC/bin" + +# first all the server options are set + +ServerOption ReadTimeOut 100 +# timeout when checking for commands. In the main loop SICS checks for +# pending commands on each connection with the above timeout, has +# PERFORMANCE impact! + +ServerOption AcceptTimeOut 100 +# timeout when checking for connection req. +# Similar to above, but for connections + +ServerOption ReadUserPasswdTimeout 500000 +# time to wiat for a user/passwd to be sent from a client. Increase this +# if there is a problem connecting to a server due to network overload\ + +ServerOption LogFileBaseName "/home/DMC/log/dmclog" +# the path and base name of the internal server logfile to which all +# activity will be logged. + +ServerOption ServerPort 3006 +# the port number the server is going to listen at. The client MUST know +# this number in order to connect. It is in client.ini + +ServerOption StatusFile /home/DMC/log/status.tcl + +ServerOption InterruptPort 3007 +# The UDP port where the server will wait for Interrupts from clients. +# Obviously, clients wishing to interrupt need to know this number. + +# Telnet Options +ServerOption TelnetPort 1301 +ServerOption TelWord sicslogin + +#The UDP port for sending quieck messages, telling the world of new data +ServerOption QuieckPort 2108 + +#the token system + the token force grab password +TokenInit connan +#--------------------------------------------------------------------------- +# U S E R S + +# than the SICS users are specified +# Syntax: SicsUser name password userRightsCode +SicsUser Manager Lucas 1 +SicsUser lnsmanager lnsSICSlns 1 +SicsUser User DMC 2 +SicsUser lnsuser 98lns2 2 +SicsUser Spy 007 3 +#-------------------------------------------------------------------------- +# D E V I C E S : M O T O R S + +#Motor a4 EL734 LNSP22 4000 5 6 +# EL734 motor with parameters: hostname PortNumber Channel MotorID + +# Motor nam SIM -20. 20. 5. 1.0 +# Simulated motor with name nam, lower limit -20, upper limit +20, +# error ratio 5% and speed 1.0. Speed may be omitted + +# Monochromator motors +ClientPut "Installing Motors" +Motor OmegaM EL734 lnsp19.psi.ch 4000 2 1 +Motor TwoThetaM EL734 lnsp19.psi.ch 4000 2 2 +Motor MonoX EL734 lnsp19.psi.ch 4000 2 5 +Motor MonoY EL734 lnsp19.psi.ch 4000 2 6 +Motor CurveM EL734 lnsp19.psi.ch 4000 2 9 +Motor MonoPhi EL734 lnsp19.psi.ch 4000 2 7 +Motor MonoChi EL734 lnsp19.psi.ch 4000 2 8 + +# sample Table +Motor Table EL734 lnsp19.psi.ch 4000 2 3 +Motor TwoThetaD EL734 lnsp19.psi.ch 4000 2 4 +#-------------------------------------------------------------------------- +# Configure Detector +# needs a EL737 or simualation for count control +ClientPut "Installing counter" +MakeCounter counter EL737 lnsp19.psi.ch 4000 4 +counter SetExponent 6 + +MakeHM banana SINQHM +banana configure HistMode Normal +banana configure OverFlowMode Ceil +banana configure Rank 1 +banana configure Length 400 +banana configure BinWidth 4 +banana preset 100. +banana CountMode Timer +banana configure HMComputer lnse01.psi.ch +banana configure HMPort 2400 +banana configure Counter counter +banana init +banana exponent 6 + +#-------------------------------------------------------------------------- +# V A R I A B L E S + +# now a few general variables are created +# Syntax: VarMake name type access +# type can be one of: Text, Int, Float +#access can be one of: Internal, Mugger, User, Spy + + +VarMake SicsDataPath Text Internal +SicsDataPath "/home/DMC/data/" +VarMake DetStepWidth Float Internal +DetStepWidth 0.2 +DetStepWidth lock + + +VarMake Instrument Text Internal +Instrument "DMC" +Instrument lock +#initialisation + +VarMake Title Text User +VarMake User Text User +VarMake Collimation Text User +VarMake Sample Text User +Sample Kellerit +VarMake comment1 Text User +VarMake comment2 Text User +VarMake comment3 Text User + +VarMake SicsDataPrefix Text Internal +SicsDataPrefix dmc +#--------- make data number +MakeDataNumber SicsDataNumber /home/DMC/data/DataNumber + +VarMake SicsDataPostFix Text Internal +SicsDataPostFix ".hdf" +VarMake Adress Text User +VarMake phone Text User +VarMake fax Text User +VarMake email Text User +VarMake sample_mur Float User + + + +# Monochromator variables +# Syntax MakeMono name type OmegaMotor 2ThetaMotor CurveMotor1 CurveMotor2 +MakeMono Mono "Ge-111" OmegaM TwoThetaM +Mono DD 3.3537 +# Syntax MakeWaveLength name MonochromatorToUse +MakeWaveLength lambda Mono + + +#-------------------------------------------------------------------------- +# P R O C E D U R E S + +# create the drive command +MakeDrive +#start RuenBuffer system +MakeRuenBuffer + +# aliases +SicsAlias OmegaM A1 +SicsAlias TwoThetaM A2 +SicsAlias Table A3 +SicsAlias TwoThetaD A4 +SicsAlias MonoX A5 +SicsAlias MonoY A6 +SicsAlias MonoPhi A7 +SicsAlias MonoChi A8 +SicsAlias CurveM A9 +InitDMC + +#----- The Logbook stuff +source "/home/DMC/bin/log.tcl" +Publish LogBook Spy +#------ The count command +source "/home/DMC/bin/count.tcl" +Publish count User +Publish Repeat User +#------ The scan command for Managers +source "/home/DMC/bin/scan.tcl" +Publish scan Mugger + +#---------install beam command +source beamdt.tcl diff --git a/dmc.tex b/dmc.tex new file mode 100644 index 00000000..8e52573b --- /dev/null +++ b/dmc.tex @@ -0,0 +1,48 @@ +\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 new file mode 100644 index 00000000..347b6824 --- /dev/null +++ b/dmc.w @@ -0,0 +1,27 @@ +\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/dmca.tcl b/dmca.tcl new file mode 100644 index 00000000..c98fca3c --- /dev/null +++ b/dmca.tcl @@ -0,0 +1,174 @@ +# -------------------------------------------------------------------------- +# Initialization script for DMC at SINQ, SICS server. +# +# Dr. Mark Koennecke March 1997 +#--------------------------------------------------------------------------- +# O P T I O N S + +set auto_path "/data/koenneck/src/sics/tcl" +source $auto_path/dmccom.tcl + + +# first all the server options are set + +ServerOption ReadTimeOut 100 +# timeout when checking for commands. In the main loop SICS checks for +# pending commands on each connection with the above timeout, has +# PERFORMANCE impact! + +ServerOption AcceptTimeOut 100 +# timeout when checking for connection req. +# Similar to above, but for connections + +ServerOption ReadUserPasswdTimeout 500000 +# time to wiat for a user/passwd to be sent from a client. Increase this +# if there is a problem connecting to a server due to network overload\ + +ServerOption ServerLogBaseName /data/koenneck/src/sics/server +# the path and base name of the internal server logfile to which all +# activity will be logged. + +ServerOption ServerPort 2910 +# the port number the server is going to listen at. The client MUST know +# this number in order to connect. It is in client.ini + +ServerOption InterruptPort 2913 +# The UDP port where the server will wait for Interrupts from clients. +# Obviously, clients wishing to interrupt need to know this number. + +ServerOption DefaultCommandFile dmccom.tcl +# The path to the file containing common Tcl-commands and procedures. +# Every connection is initialized with this + +#--------------------------------------------------------------------------- +# U S E R S + +# than the SICS users are specified +# Syntax: SicsUser name password userRightsCode +SicsUser Mugger Diethelm 1 +SicsUser User Rosy 2 +SicsUser Spy 007 3 + + +#-------------------------------------------------------------------------- +# D E V I C E S : M O T O R S + +#Motor a4 EL734 LNSP22 4000 5 6 +# EL734 motor with parameters: hostname PortNumber Channel MotorID + +# Motor nam SIM -20. 20. 5. 1.0 +# Simulated motor with name nam, lower limit -20, upper limit +20, +# error ratio 5% and speed 1.0. Speed may be omitted + +# Monochromator motors +Motor OmegaM SIM 20. 120. 5. 2.0 +Motor TwoThetaM SIM 20. 120. 5. 0.5 +Motor MonoX SIM -20. 20. 5. 5.0 +Motor MonoY SIM -20. 20. 5. 5.0 +Motor CurveM SIM 0. 1000. 10. 5.0 +Motor MonoPhi SIM -20. 20. 5. 5.0 +Motor MonoChi SIM -20. 20. 5. 5.0 + +# sample Table +Motor Table SIM -180. 180. 5. 7.0 +Motor TwoThetaD SIM 10. 330. 5. 1.0 +#-------------------------------------------------------------------------- +# Configure Detector +# needs a EL737 or simualation for count control +MakeCounter xxxNo SIM + +#MakeHM banana SINQHM +MakeHM banana SIM +banana configure HistMode Normal +banana configure OverFlowMode Ceil +banana configure Rank 1 +banana configure Length 400 +banana configure BinWidth 4 +banana configure Time 10. 12. 14 16. 17. +banana preset 100. +banana CountMode Timer +#banana configure HMComputer psds02.psi.ch +#banana configure HMport 2400 +#banana configure Counter xxxNo +banana init +#-------------------------------------------------------------------------- +# C O N F I G U R E D E V I C E S T O H A L T I N +# I N T E R R U P T +AddHalt OmegaM TwoThetaM MonoX MonoY MonoChi MonoPhi CurveM Table TwoThetaD +#-------------------------------------------------------------------------- +# V A R I A B L E S + +# now a few general variables are created +# Syntax: VarMake name type access +# type can be one of: Text, Int, Float +#access can be one of: Internal, Mugger, User, Spy + +VarMake Instrument Text Internal +Instrument "DMC at SINQ,PSI" +#initialisation + +VarMake Title Text User +VarMake User Text User +VarMake Collimation Text User +VarMake Sample Text User +VarMake comment1 Text User +VarMake comment2 Text User +VarMake Comment3 Text User + +VarMake SicsDataPath Text Internal +SicsDataPath "/data/koenneck/src/sics/" +VarMake SicsDataPrefix Text Internal +SicsDataPrefix DMC +VarMake SicsDataNumber Int Internal +SicsDataNumber 0 +VarMake SicsDataPostFix Text Internal +SicsDataPostFix ".hdf" +VarMake Adress Text User +VarMake phone Text User +VarMake fax Text User +VarMake email Text User +VarMake sample_mur Float User +VarMake DetStepWidth Float Internal +DetStepWidth 0.02 + + + +# Monochromator variables +# Syntax MakeMono name type OmegaMotor 2ThetaMotor CurveMotor1 CurveMotor2 +MakeMono Mono "Ge-111" OmegaM TwoThetaM CurveM +# Syntax MakeWaveLength name MonochromatorToUse +MakeWaveLength lambda Mono + + +#-------------------------------------------------------------------------- +# P R O C E D U R E S + +# create the drive command +MakeDrive +#start RuenBuffer system +MakeRuenBuffer + +if { 0 } { + +DMCInit 5 2.0 1 +# end -------- of ------------- file ------------------------------------- +# test code for powder diagrams, merging etc. + +set id1 [DMCShot set 1 2 2 2 2 2 2] +set id2 [DMCShot set 2 3 3 3 3 3 3] +set id3 [DMCShot set 6 1 1 1 1 1 1] +set id4 [DMCShot set 7 5 5 5 5 5 5] +set p1 [DMCPowder merge $id1 $id2 $id3 $id4] +ClientPut [DMCPowder info $p1] +ClientPut [DMCPowder list $p1 0 17] +ClientPut [DMCPowder Start $p1] +ClientPut [DMCPowder Step $p1] +ClientPut [DMCPowder Stop $p1] +DMCReset +} +# test of alias +SicsAlias OmegaM A1 +SicsAlias TwoThetaM A2 +SicsAlias Table A3 +SicsAlias TwoThetaD A4 +InitDMC diff --git a/dmccom.tcl b/dmccom.tcl new file mode 100644 index 00000000..6d20d388 --- /dev/null +++ b/dmccom.tcl @@ -0,0 +1,13 @@ +#---------------------------------------------------------------------------- +# Common Tcl-command procedures for DMC +# Mark Koennecke February 1997 +#-------------------------------------------------------------------------- +proc Milch { n } { + for {set i 0 } { $i < $n } { incr i} { + ClientPut "Milch ist gesund" + } +} + +proc Kaba { text } { + return $text +} \ No newline at end of file diff --git a/dmcscan.tcl b/dmcscan.tcl new file mode 100644 index 00000000..c879e0e0 --- /dev/null +++ b/dmcscan.tcl @@ -0,0 +1,8 @@ +#---------------------------------------------------------------------------- +# Common Tcl-command procedures for DMC +# Mark Koennecke February 1997 +#-------------------------------------------------------------------------- +source "/data/koenneck/src/sics/obtcl.tcl +# define DMC scan class +class DMCScanClass + diff --git a/dmcsim.tcl b/dmcsim.tcl new file mode 100755 index 00000000..d692fd06 --- /dev/null +++ b/dmcsim.tcl @@ -0,0 +1,167 @@ +# -------------------------------------------------------------------------- +# Initialization script for DMC at SINQ, SICS server. +# +# Dr. Mark Koennecke Juli 1997 +#--------------------------------------------------------------------------- +# O P T I O N S + +set auto_path "/home/DMC/bin" + +# first all the server options are set + +ServerOption ReadTimeOut 100 +# timeout when checking for commands. In the main loop SICS checks for +# pending commands on each connection with the above timeout, has +# PERFORMANCE impact! + +ServerOption AcceptTimeOut 100 +# timeout when checking for connection req. +# Similar to above, but for connections + +ServerOption ReadUserPasswdTimeout 500000 +# time to wiat for a user/passwd to be sent from a client. Increase this +# if there is a problem connecting to a server due to network overload\ + +ServerOption LogFileBaseName "/home/DMC/log/dmclog" +# the path and base name of the internal server logfile to which all +# activity will be logged. + +ServerOption ServerPort 3009 +# the port number the server is going to listen at. The client MUST know +# this number in order to connect. It is in client.ini + +ServerOption StatusFile /home/DMC/log/simstatus.tcl + +ServerOption InterruptPort 3010 +# The UDP port where the server will wait for Interrupts from clients. +# Obviously, clients wishing to interrupt need to know this number. + +#--------------------------------------------------------------------------- +# U S E R S + +# than the SICS users are specified +# Syntax: SicsUser name password userRightsCode +SicsUser Manager Lucas 1 +SicsUser User DMC 2 +SicsUser Spy 007 3 +#-------------------------------------------------------------------------- +# D E V I C E S : M O T O R S + +#Motor a4 EL734 LNSP22 4000 5 6 +# EL734 motor with parameters: hostname PortNumber Channel MotorID + +# Motor nam SIM -20. 20. 5. 1.0 +# Simulated motor with name nam, lower limit -20, upper limit +20, +# error ratio 5% and speed 1.0. Speed may be omitted + +# Monochromator motors +Motor OmegaM SIM 0 120 1 2.0 +Motor TwoThetaM SIM 30 100 1 1.0 +Motor MonoX SIM -30 30 1 3.0 +Motor MonoY SIM -30 30 1 3.0 +Motor CurveM SIM 0 20 1 3.0 +Motor MonoPhi SIM -30 30 1 3.0 +Motor MonoChi SIM -30 30 1 3.0 + +# sample Table +Motor Table SIM -180 360 1 2. +Motor TwoThetaD SIM -10 120 1 1. +#-------------------------------------------------------------------------- +# Configure Detector +# needs a EL737 or simualation for count control +MakeCounter counter SIM + +MakeHM banana SIM +banana configure HistMode Normal +banana configure OverFlowMode Ceil +banana configure Rank 1 +banana configure Length 400 +banana configure BinWidth 4 +banana preset 100. +banana CountMode Timer +#banana configure HMComputer psds04.psi.ch +#banana configure HMPort 2400 +#banana configure Counter counter +banana init +#-------------------------------------------------------------------------- +# C O N F I G U R E D E V I C E S T O H A L T I N +# I N T E R R U P T +AddHalt OmegaM TwoThetaM MonoX MonoY MonoChi MonoPhi CurveM Table TwoThetaD +#-------------------------------------------------------------------------- +# V A R I A B L E S + +# now a few general variables are created +# Syntax: VarMake name type access +# type can be one of: Text, Int, Float +#access can be one of: Internal, Mugger, User, Spy + + +VarMake SicsDataPath Text Internal +SicsDataPath "/home/DMC/sim/" +VarMake DetStepWidth Float Internal +DetStepWidth 0.02 + + +VarMake Instrument Text Internal +Instrument "DMC at SINQ,PSI" +#initialisation + +VarMake Title Text User +VarMake User Text User +VarMake Collimation Text User +VarMake Sample Text User +Sample Kellerit +VarMake Temperature Float User +Temperature 21.3897 +VarMake comment1 Text User +VarMake comment2 Text User +VarMake comment3 Text User + +VarMake SicsDataPrefix Text Internal +SicsDataPrefix dmc +VarMake SicsDataNumber Int Mugger +SicsDataNumber 0 +VarMake SicsDataPostFix Text Internal +SicsDataPostFix "97.hdf" +VarMake Adress Text User +VarMake phone Text User +VarMake fax Text User +VarMake email Text User +VarMake sample_mur Float User + + + +# Monochromator variables +# Syntax MakeMono name type OmegaMotor 2ThetaMotor CurveMotor1 CurveMotor2 +MakeMono Mono "Ge-111" OmegaM TwoThetaM +Mono DD 3.3537 +# Syntax MakeWaveLength name MonochromatorToUse +MakeWaveLength lambda Mono + + +#-------------------------------------------------------------------------- +# P R O C E D U R E S + +# create the drive command +MakeDrive +#start RuenBuffer system +MakeRuenBuffer + +# aliases +SicsAlias OmegaM A1 +SicsAlias TwoThetaM A2 +SicsAlias Table A3 +SicsAlias TwoThetaD A4 +InitDMC + +#----- The Logbook stuff +source "/home/DMC/bin/log.tcl" +Publish LogBook User +#------ The count command +source "/home/DMC/bin/count.tcl" +Publish count User +Publish Repeat User +#------ The scan command for Managers +source "/home/DMC/bin/scan.tcl" +Publish scan Mugger + diff --git a/doc/el734_test.tex b/doc/el734_test.tex new file mode 100644 index 00000000..d4c18ff9 --- /dev/null +++ b/doc/el734_test.tex @@ -0,0 +1,723 @@ +% [...DOC.SINQ]EL734_TEST.TEX - Ident 1D02 +% =========================== +%% +%%==================================================================== +%% +%% +--------------------------------------------------------------+ +%% | Paul Scherrer Institute | +%% | SINQ Division | +%% | | +%% | 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.| +%% +--------------------------------------------------------------+ +%% +%% Project . . . . . . . . . . : SINQ +%% Brief Document Title . . . . : Description of EL734 Step Motor Test Prog +%% Author . . . . . . . . . . . : D.Maden +%% Date of creation . . . . . . : 29-Jan-1996 +%% +%% Updates: +%% 13-Nov-1996 DM. Vn 1D02 of program. +%%==================================================================== +%% +\documentclass[openbib,a4paper,twoside,11pt]{article} +\usepackage{array} +% +\addtolength{\textheight}{35mm} +\setlength{\textwidth}{160mm} +\setlength{\oddsidemargin}{8mm} +\setlength{\evensidemargin}{-10mm} +\setlength{\topmargin}{-20mm} +% +\setcounter{tocdepth}{2} +% +\newcommand{\pdp}{\protect\makebox[3.7em][l]{PDP-11}} +\newcommand{\uvax}{\protect\makebox[4.8em][l]{microVAX}} +% +\newcounter{two} \setcounter{two}{2} +\newcommand{\uvaxii}{\protect\makebox[5.8em][l]{microVAX~\Roman{two}}} +\newcounter{three} \setcounter{three}{3} +\newcommand{\uvaxiii}{\protect\makebox[6.2em][l]{microVAX~\Roman{three}}} +% +\newcommand{\PreserveBackslash}[1]{\let\temp=\\#1\let\\=\temp} +\let\PBS=\PreserveBackslash % shorthand +% +% Define "\usc" to get a proper underscore!! +\newcommand{\usc}{\protect\makebox[0.6em]{\protect\rule{0.5em}{0.1ex}}} +% +\newcommand{\camac}{\protect\makebox[4.1em][l]{CAMAC}} +% +% Define insertplot is insert a PostScript plot. +% Usage: +% \insertplot{}{}{} +% Example: +% \insertplot{dvipsdoc.pal}{70mm}{5.0mm} +% +\def\insertplot#1#2#3{\par + \hbox{% + \hskip #3 + \vbox to #2{ + \vfil + \special{ps: plotfile #1} + }% + } +} +% +\title{EL734 Stepping Motor Test Program} +\author{D. Maden} +\date{12th November, 1996} +% +\begin{document} +\maketitle + \section{Introduction} +% ====================== +% + This note describes the program {\bf el734{\usc}test}, which can be used to + test a stepping motor connected to an EL734 Stepping Motor Controller. + The current version of the program is {\em Ident 1D02}. + + The program runs under either the Unix\footnote{So far, the program has been + tested only under the DEC version of Unix, i.e. {\em Digital Unix}.} + operating system or + the OpenVMS operating system. The program is normally invoked via a + simple command line from the console prompt and then runs to completion. + + In the interests of simplicity, this note describes how to + run {\bf el734{\usc}test} on a Digital Unix workstation + when logged in as user ``lnsg''. It assumes that the shell being used + is {\em tcsh}. Once the correct environment has been defined, however, + the operation of the program is identical under both Unix and OpenVMS. + Notes specific to the OpenVMS implementation will be found in + Appendix~\ref{OpenVMS-Notes}. +% + \section{Hardware Configuration} +% ================================ +% + Although other configurations are possible, it is assumed in this + description that the EL734 is connected via an asynchronous serial + line to a Macintosh (or PC) running a LabVIEW ``terminal server'' program. + This program is referred to as {\em TS} in the following. See ??? for + details of {\em TS}. A Description of how to start {\em TS} is given in + Appendix~\ref{TS-Notes}. + + {\bf el734{\usc}test} accesses the EL734 via {\em TS} by + creating a TCP/IP network socket and opening a connection to it. + {\bf el734{\usc}test} is a so-called ``TCP/IP client'' and the LabVIEW + program + is a so-called ``TCP/IP server''. {\bf el734{\usc}test} buffers commands + for + the EL734 into packets which it sends to the terminal server via the socket. + The terminal server extracts the commands from each packet, executes them in + sequence and compiles the various responses from the EL734 into a response + packet which it then sends back to {\bf el734{\usc}test}. The details of + this + packet protocol are described elsewhere. + + In order for {\bf el734{\usc}test} to be able to establish a connection to + the + terminal server, it is necessary to know the Internet host name + of the Macintosh or PC on which the terminal server program is running, + the Internet port number on which this program accepts + connections from its clients and the channel number of the asynchronous + serial line which is connected to the EL734. + + The host name is usually indicated by a label on the Macintosh. The + following is the current list of LabVIEW host assignments: +% + \begin{center}\begin{tabular}{|c|c|c|c|} \hline + Host & Alias & Internet Address & Instrument \\ + \hline + pswm18.psi.ch & lnsw02 & 129.129.90.18 & ? \\ + ? & lnsp22 & 129.129.90.172 & TOPSI \\ + pswm60.psi.ch & lnsw15 & 129.129.90.60 & ? \\ + \hline + \end{tabular}\end{center} +% + The default port number is 4000. The channel number is a small integer. A + value of zero for the channel number usually refers to + to the Macintosh's ``modem port''. +% + \section{Running {\bf el734{\usc}test}} +% ======================================= +% + The startup files of the ``lnsg'' accounts are normally set up so that + {\bf el734{\usc}test} can be invoked merely by typing the command: \\[1.0ex] +% + \hspace*{20mm} \verb# el734_test [options ...]# \\[1.0ex] +% + A list of the options recognised by the program can be + obtained by issuing the command: \\[1.0ex] +% + \hspace*{20mm} \verb# el734_test -help# \\[1.0ex] +% + It generates the following information about the program:% +% + \begin{verbatim} + EL734 Motor Controller Test Program 1, Ident 1D02. + Started at Mon Nov 11 13:03:43 1996 + My name is "el734_test" + + Usage: el734_test [options ...] + + Valid options are: + -help Generates this help text. + -?