From e83d3e694655a3fad5b7d3f9ca8afebe6665cd56 Mon Sep 17 00:00:00 2001 From: cvs Date: Tue, 21 Nov 2000 08:16:46 +0000 Subject: [PATCH] - Fixed a few problems with hklscan - Added transfer of zipped data to conman.c, histogram memory software in order to support the TRICS status display. - Upgraded TRICS data file writing. - First installment of triple axis spectrometer support: initialization of data structures and an implementation of the MAD dr(ive) command. --- Makefile | 36 +- conman.c | 237 +++++++++++- conman.h | 7 + d_mod.c | 46 +++ d_sign.c | 18 + danu.dat | 2 +- devexec.c | 11 +- el734driv.c | 4 +- fowrite.c | 2 +- hardsup/Makefile | 4 + hardsup/el734_utility.c | 12 +- hardsup/el737_utility.c | 2 +- hardsup/sinqhm.c | 3 +- hardsup/sinqhm_def.h | 153 ++++++-- histmem.c | 82 ++++ histsim.c | 4 +- hklscan.c | 13 +- network.c | 5 +- nextrics.c | 215 ++++++++++- nread.c | 58 +-- ofac.c | 3 + scan.c | 72 +++- scan.h | 7 +- scan.i | 1 + scan.tex | 17 +- scan.w | 17 +- sicsstat.tcl | 681 ++++++++++++++------------------ sicsstatus.tcl | 36 +- t_conv.c | 830 ++++++++++++++++++++++++++++++++++++++++ t_conv.f | 682 +++++++++++++++++++++++++++++++++ t_rlp.c | 516 +++++++++++++++++++++++++ t_rlp.f | 463 ++++++++++++++++++++++ tas.h | 117 ++++++ tas.w | 168 ++++++++ tasdrive.c | 270 +++++++++++++ tasinit.c | 282 ++++++++++++++ tasutil.c | 470 +++++++++++++++++++++++ test.tcl | 303 ++++++++++++++- trics.dic | 15 +- 39 files changed, 5301 insertions(+), 563 deletions(-) create mode 100644 d_mod.c create mode 100644 d_sign.c create mode 100644 t_conv.c create mode 100755 t_conv.f create mode 100644 t_rlp.c create mode 100755 t_rlp.f create mode 100644 tas.h create mode 100644 tas.w create mode 100644 tasdrive.c create mode 100644 tasinit.c create mode 100644 tasutil.c diff --git a/Makefile b/Makefile index 2dafe31a..706daf48 100644 --- a/Makefile +++ b/Makefile @@ -42,7 +42,9 @@ SOBJ = network.o ifile.o conman.o SCinter.o splitter.o passwd.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 + 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 MOTOROBJ = motor.o el734driv.o simdriv.o el734dc.o pipiezo.o pimotor.o COUNTEROBJ = countdriv.o simcter.o counter.o @@ -55,15 +57,15 @@ VELOOBJ = velo.o velosim.o velodorn.o velodornier.o #----- comment or uncomment the following according to operating system #------------- for Digital Unix -#BINTARGET=$(HOME)/bin/osf.axp -#HDFROOT=/data/koenneck -#CC=cc -#EXTRA= -#CFLAGS = -I$(HDFROOT)/include -Ihardsup -I. -std1 -g -warnprotos -c +BINTARGET=. +HDFROOT=/data/koenneck +CC=cc +EXTRA= +CFLAGS = -I$(HDFROOT)/include -Ihardsup -I. -std1 -g -warnprotos -c #CFLAGS = -I$(HDFROOT)/include -DFORTIFY -Ihardsup -g -std1 -warnprotos -c -#LIBS = -L$(HDFROOT)/lib -Lhardsup -lhlib -Lmatrix -lmatrix -Ltecs \ -# -ltecsl -ltcl8.0 -lfor -lmfhdf -ldf $(HDFROOT)/lib/libjpeg.a \ -# -lz -lm -ll -lc +LIBS = -L$(HDFROOT)/lib -Lhardsup -lhlib -Lmatrix -lmatrix -Ltecs \ + -ltecsl -ltcl8.0 -lfor -lmfhdf -ldf $(HDFROOT)/lib/libjpeg.a \ + -lz -lm -ll -lc #------- for cygnus #HDFROOT=../HDF411 @@ -74,14 +76,14 @@ VELOOBJ = velo.o velosim.o velodorn.o velodornier.o # -lmfhdf -ldf -ljpeg -lz -lm #---------- for linux -BINTARGET=$(HOME)/bin/linux.i686 -HDFROOT=/usr/local -CC=gcc -CFLAGS = -I$(HDFROOT)/include -Ihardsup -fwritable-strings \ - -DCYGNUS -DNONINTF -g -c -LIBS= -L$(HDFROOT)/lib -Lhardsup -Ltecs -ltecsl -Lmatrix -lmatrix -lhlib \ - -ltcl8.0 -lmfhdf -ldf -ljpeg -lz -lm -lg2c -ldl -EXTRA=nintf.o +#BINTARGET=$(HOME)/bin/linux.i686 +#HDFROOT=/usr/local +#CC=gcc +#CFLAGS = -I$(HDFROOT)/include -Ihardsup -fwritable-strings \ +# -DCYGNUS -DNONINTF -g -c +#LIBS= -L$(HDFROOT)/lib -Lhardsup -Ltecs -ltecsl -Lmatrix -lmatrix -lhlib \ +# -ltcl8.0 -lmfhdf -ldf -ljpeg -lz -lm -lg2c -ldl +#EXTRA=nintf.o #--------------------------------------------------------------------------- .c.o: diff --git a/conman.c b/conman.c index a78126e4..e2cb1aa0 100644 --- a/conman.c +++ b/conman.c @@ -17,6 +17,10 @@ Mark Koennecke, January 1998 SCWriteBinary added. Mark Koennecke, April 1998 + + Revamped login to non telnet connection. + Added compressed writing method. + Mark Koennecke, October 2000 Copyright: see copyright.h -----------------------------------------------------------------------------*/ @@ -26,7 +30,9 @@ #include #include #include +#include #include +#include #include "lld.h" #include "conman.h" #include "passwd.h" @@ -129,6 +135,8 @@ extern pServer pServ; pRes->eInterrupt = eContinue; pRes->lMagic = CONMAGIC; pRes->iDummy = 0; + pRes->iLogin = 0; + pRes->conStart = time(NULL); pRes->write = SCNormalWrite; for(i = 0; i < 10; i++) { @@ -213,6 +221,8 @@ extern pServer pServ; pRes->lMagic = CONMAGIC; pRes->eInterrupt = eContinue; pRes->iDummy = 0; + pRes->iLogin = 0; + pRes->conStart = time(NULL); pRes->write = SCNormalWrite; for(i = 0; i < 10; i++) { @@ -812,6 +822,179 @@ extern pServer pServ; free(pPtr); return iRet; } +/*------------------------------------------------------------------------*/ +#define ZIPBUF 8192 + int SCWriteZipped(SConnection *self, char *pName, void *pData, int iDataLen) + { + char outBuf[65546], *pBuf = NULL, noutBuf[ZIPBUF]; + 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); + SCWrite(self,outBuf,eValue); + + /* 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)); + 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 && iRet != Z_OK) + { + sprintf(outBuf,"ERROR: zlib error: %d",iRet); + SCWrite(self,outBuf,eError); + return 0; + } + 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); + + + /* + 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) { @@ -1382,6 +1565,7 @@ extern pServer pServ; SConnection *self = NULL; char *pPtr = NULL; int iRet; + char *pUser = NULL, *pPassword = NULL; self = (SConnection *)pData; if(!VerifyConnection(self)) @@ -1401,6 +1585,14 @@ extern pServer pServ; } } + /* 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); @@ -1408,13 +1600,50 @@ extern pServer pServ; { if(pPtr) { - CostaLock(self->pStack); - SCInvoke(self,self->pSics,pPtr); - CostaUnlock(self->pStack); - /* SCWrite(self,"\b",eError); */ + 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) diff --git a/conman.h b/conman.h index 077265d7..faaa74fd 100644 --- a/conman.h +++ b/conman.h @@ -58,6 +58,12 @@ /* 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" @@ -81,6 +87,7 @@ 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); /************************* CallBack *********************************** */ int SCRegister(SConnection *pCon, SicsInterp *pSics, void *pInter, long lID); 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.dat b/danu.dat index bc903d7a..e0114da8 100644 --- a/danu.dat +++ b/danu.dat @@ -1,3 +1,3 @@ - 7292 + 7307 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/devexec.c b/devexec.c index 8b9fd467..a5bcc2f9 100644 --- a/devexec.c +++ b/devexec.c @@ -832,9 +832,14 @@ /*--------------------------------------------------------------------------*/ int isInRunMode(pExeList self) { - assert(self); - - return self->iRun; + if(self == NULL) + { + return 0; + } + else + { + return self->iRun; + } } /*--------------------------------------------------------------------------*/ SConnection *GetExeOwner(pExeList self) diff --git a/el734driv.c b/el734driv.c index 0ebd09ef..daba558e 100644 --- a/el734driv.c +++ b/el734driv.c @@ -124,7 +124,7 @@ EL734Error2Text converts between an EL734 error code to text -----------------------------------------------------------------------------*/ -extern char EL734_IllgText[256]; +/* extern char EL734_IllgText[256]; */ static void EL734Error2Text(char *pBuffer, int iErr) { @@ -154,7 +154,9 @@ extern char EL734_IllgText[256]; break; case EL734__BAD_ILLG: strcat(pBuffer,"EL734__BAD_ILLG "); + /* strcat(pBuffer,EL734_IllgText); + */ break; case EL734__BAD_LOC: strcat(pBuffer,"EL734__BAD_LOC"); diff --git a/fowrite.c b/fowrite.c index ca7e242d..a622f681 100644 --- a/fowrite.c +++ b/fowrite.c @@ -419,7 +419,7 @@ NXDputalias(pFile,pDict,"cntime",&fVal); lVal = GetHistMonitor(self->pHist,1,pCon); NXDputalias(pFile,pDict,"cnmon1",&lVal); - lVal = GetHistMonitor(self->pHist,2,pCon); + lVal = GetHistMonitor(self->pHist,0,pCon); NXDputalias(pFile,pDict,"cnmon2",&lVal); diff --git a/hardsup/Makefile b/hardsup/Makefile index 7bf0da83..13f19d5d 100644 --- a/hardsup/Makefile +++ b/hardsup/Makefile @@ -9,10 +9,14 @@ OBJ= el734_utility.o asynsrv_utility.o stredit.o \ makeprint.o StrMatch.o #---------- for Redhat linux +#CC= gcc +#CFLAGS= -I. -I../ -DLINUX -g -c ## CC= gcc ## CFLAGS= -I. -I../ -DLINUX -g -c #------------ for DigitalUnix +CC=cc +CFLAGS= -I. -I../ -std1 -g -c CC=cc CFLAGS= -I. -I../ -std1 -g -c diff --git a/hardsup/el734_utility.c b/hardsup/el734_utility.c index e8ef0b27..7a154aa1 100644 --- a/hardsup/el734_utility.c +++ b/hardsup/el734_utility.c @@ -804,12 +804,12 @@ #include #ifdef __VMS - #include +#include #else - #include - #ifdef FORTIFY - #include - #endif +#include +#ifdef FORTIFY +#include +#endif #endif /*-----------------------------------------------------------------*/ #include @@ -2581,7 +2581,7 @@ #include struct timespec delay = {0, 250000000}; struct timespec delay_left; -#define hibernate nanosleep (&delay, &delay_left) +#define hibernate nanosleep_d9 (&delay, &delay_left) #endif int msr, ss; struct EL734info *info_ptr; diff --git a/hardsup/el737_utility.c b/hardsup/el737_utility.c index 04b1a439..ddce8ab7 100644 --- a/hardsup/el737_utility.c +++ b/hardsup/el737_utility.c @@ -1711,7 +1711,7 @@ #include struct timespec delay = {0, 250000000}; struct timespec delay_left; -#define hibernate nanosleep (&delay, &delay_left) +#define hibernate nanosleep_d9 (&delay, &delay_left) #endif int my_rs; struct EL737info *info_ptr; diff --git a/hardsup/sinqhm.c b/hardsup/sinqhm.c index 1fd987ee..b34c25ff 100644 --- a/hardsup/sinqhm.c +++ b/hardsup/sinqhm.c @@ -269,6 +269,7 @@ extern int close(int fp); Req_buff.cmnd = htonl (SQHM_CONFIG); Req_buff.u.cnfg.mode = htonl (iMode); Req_buff.u.cnfg.u.hm_dig.n_hists = htonl (iRank); + printf("%d\n", ntohl(Req_buff.u.cnfg.u.hm_dig.n_hists)); Req_buff.u.cnfg.u.hm_dig.lo_bin = htonl (iLowBin); Req_buff.u.cnfg.u.hm_dig.num_bins = htonl (iLength); Req_buff.u.cnfg.u.hm_dig.bytes_per_bin = htonl (iBinWidth); @@ -465,7 +466,7 @@ extern int close(int fp); /* fill in the request data structure */ Req_buff.bigend = htonl (0x12345678); Req_buff.cmnd = htonl (SQHM_DBG); - Req_buff.u.dbg.level = htonl(iLevel); + Req_buff.u.dbg.mask = htonl(iLevel); /* try, get a connection to master server */ status = OpenMasterConnection(self); diff --git a/hardsup/sinqhm_def.h b/hardsup/sinqhm_def.h index 6b1cf46a..a2ca0d13 100644 --- a/hardsup/sinqhm_def.h +++ b/hardsup/sinqhm_def.h @@ -4,7 +4,13 @@ ** **------------------------------------------------------------------------------ */ -#define SINQHM_DEF_ID "V02G" +#define SINQHM_DEF_ID "V03C" + +#ifdef __alpha +#ifndef __vms +#pragma nomember_alignment +#endif +#endif /*------------------------------------------------------------------------------ */ #ifndef OffsetOf @@ -20,6 +26,7 @@ #define MAX_TOF_NBINS 32768 /* The maximum number of bins in a TOF histog */ #define MAX_TOF_EDGE 16 /* The maximum number of TOF edge arrays */ #define VMIO_BASE_ADDR 0x1900 /* VME address of a (possible) VMIO10 module */ +#define IDENT_MSGE_LEN 256 /* Length of Ident info for SQHM_IDENT */ #define uchar unsigned char #define usint unsigned short int @@ -56,6 +63,8 @@ #define SQHM_DBG 0x05 #define SQHM_DECONFIG 0x06 #define SQHM_EXIT 0x07 +#define SQHM_IDENT 0x0e +#define SQHM_PROJECT 0x0d #define SQHM_READ 0x08 #define SQHM_SELECT 0x09 #define SQHM_STATUS 0x0a @@ -68,7 +77,7 @@ #define SQHM__HM_DIG 0x2000 /* Hist mode (with digitised read-out) */ #define SQHM__TOF 0x3000 /* Time-of-Flight mode */ #define SQHM__HM_PSD 0x4000 /* Hist mode (with Pos-sens-detect read-out) */ -#define SQHM__HRPT 0x5000 /* Histogram mode for HRPT cerca detector */ +#define SQHM__HRPT 0x5000 /* Hist mode for HRPT */ /* ** Define the various sub-mode bits of the operation modes */ @@ -83,7 +92,8 @@ #define SQHM__BO_CNT 0x10 /* Keep counts of overflow bins */ #define SQHM__STROBO 0x20 /* Use strobo-bit information */ -#define SQHM__REFLECT 0x40 /* reflect histogram */ +#define SQHM__REFLECT 0x40 /* Reflect histograms */ +#define SQHM__NO_STAT 0x80 /* Suppress status info from "Filler" */ /* ** ---------------------------------------------------------- ** SQHM_DAQ sub-function codes @@ -94,11 +104,32 @@ #define DAQ__INH 0x03 #define DAQ__STOP 0x04 #define DAQ__TST 0x05 + /* + ** ---------------------------------------------------------- + ** SQHM_PROJECT sub-codes + */ +#define PROJECT__ON_Y 0x0001 /* Project onto y-axis */ +#define PROJECT__1_DIM 0x0002 /* Make projection of a 1-dim histogram */ /* ** ---------------------------------------------------------- ** Definition of bits in of TOF edge-array */ #define FLAG__VAR_BIN 0x01 /* Bin span of histogram is variable */ + /* + ** ---------------------------------------------------------- + ** Definition of bits in of SQHM_STATUS response + */ +#define STATUS_FLAGS__PF 0x8000 /* PF - Power Fail */ +#define STATUS_FLAGS__SWC 0x4000 /* SWC - Status Word Changed */ +#define STATUS_FLAGS__NRL 0x2000 /* NRL - Neutron Rate Low */ +#define STATUS_FLAGS__DAQ 0x1000 /* DAQ on -- set if Hdr Mask Bits are + ** correct so that data acq is active */ +#define STATUS_FLAGS__SYNC3 0x0800 /* Ext Synch Bit #3 */ +#define STATUS_FLAGS__SYNC2 0x0400 /* Ext Synch Bit #2 */ +#define STATUS_FLAGS__SYNC1 0x0200 /* Ext Synch Bit #1 */ +#define STATUS_FLAGS__SYNC0 0x0100 /* Ext Synch Bit #0 */ +#define STATUS_FLAGS__UD 0x0080 /* UD - Up/Down */ +#define STATUS_FLAGS__GU 0x0040 /* GU - Gummi (i.e. Strobo) */ /* ** ---------------------------------------------------------- */ @@ -107,19 +138,38 @@ #define N_TOTAL_BYTES 0x400000 /* Maximum total bytes of histogram */ /* **------------------------------------------------------------------------------ +** Definitions of Filler states in HRPT mode +*/ +#define HRPT__SRCH_FRAME 1 +#define HRPT__READ_FRAME 2 +/* +**------------------------------------------------------------------------------ ** Definitions for the LWL Datagrams */ #define LWL_HDR_TYPE_MASK (0x1f000000) /* Mask for extracting main dgrm .. ** .. hdr command-type bits */ -#define LWL_HDR_PF_MASK (0x80000000) /* Mask for extr Power Fail bit */ -#define LWL_HDR_SWC_MASK (0x40000000) /* Mask for extr Status Word Chng bit */ -#define LWL_HDR_NRL_MASK (0x20000000) /* Mask for extr Neutron Rate Low bit */ -#define LWL_HDR_UD_MASK (0x00200000) /* Mask for extr Up/Down bit */ -#define LWL_HDR_BA_MASK (0x00f00000) /* Mask for extr Binning Addr */ -#define LWL_HDR_TS_MASK (0x000fffff) /* Mask for extr Time Stamp */ +#define LWL_HDR_PF_MASK (0x80000000) /* Mask for extr Power Fail bit */ +#define LWL_HDR_SWC_MASK (0x40000000) /* Mask for extr Status Word Chng bit */ +#define LWL_HDR_NRL_MASK (0x20000000) /* Mask for extr Neutron Rate Low bit */ +#define LWL_HDR_SYNC3_MASK (0x00800000) /* Mask for one of ext synch bits */ +#define LWL_HDR_SYNC2_MASK (0x00400000) /* Mask for one of ext synch bits */ +#define LWL_HDR_SYNC1_MASK (0x00200000) /* Mask for one of ext synch bits */ +#define LWL_HDR_SYNC0_MASK (0x00100000) /* Mask for one of ext synch bits */ +#define LWL_HDR_UD_MASK LWL_HDR_SYNC1_MASK /* Mask for Up/Down bit */ +#define LWL_HDR_GU_MASK LWL_HDR_SYNC0_MASK /* Mask for GU bit */ +#define LWL_HDR_BA_MASK (0x00f00000) /* Mask for TSI Binning Addr */ +#define LWL_HDR_TS_MASK (0x000fffff) /* Mask for TSI Time Stamp */ -#define LWL_HDR_TYPE_NRL (LWL_HDR_TYPE_MASK | LWL_HDR_NRL_MASK) /* Mask for .. - ** .. extracting dgrm type + NRL bit */ +#define LWL_FIFO_EMPTY (0x1e000000) /* FIFO Empty */ + +#define LWL_TSI_TR (0x1f000000) /* Time-Status-Info Transp-Mode */ +#define LWL_TSI_HM_NC (0x1f000000) /* Time-Status-Info Hist-Mode+No-Coinc */ +#define LWL_TSI_HM_C (0x0e000000) /* Time-Status-Info Hist-Mode+Coinc */ +#define LWL_TSI_TOF (0x1f000000) /* Time-Status-Info TOF-Mode */ +#define LWL_TSI_SM_NC (0x1f000000) /* Time-Status-Info Strobo-Mode+No-Coin */ +#define LWL_TSI_SM_C (0x0e000000) /* Time-Status-Info Strobo-Mode+Coinc */ +#define LWL_TSI_DT_MSK (0x000fffff) /* Mask for Dead-Time in TSI */ +#define LWL_TSI_DTS_MSK (0x000fffff) /* Mask for Delay-Time-to-Start in TSI */ #define LWL_TR_C1 (0x00000001) /* Transp. Mode Chan 1 */ #define LWL_TR_C2 (0x00000002) /* Transp. Mode Chan 2 */ @@ -184,16 +234,15 @@ #define LWL_SM_CO_C8 (0x18000000) /* Strobo-Mode + Coinc 8 chan dgrm hdr */ #define LWL_SM_CO_C9 (0x19000000) /* Strobo-Mode + Coinc 9 chan dgrm hdr */ -#define LWL_TS_TR (0x1f000000) /* Transp-Mode Time Status Info */ -#define LWL_TS_HM_NC (0x1f000000) /* Hist-Mode/No-Coinc Time Stat Info */ -#define LWL_TS_HM_TOF (0x1f000000) /* TOF-Mode Time Status Info */ -#define LWL_TS_SM_NC_TOF (0x1f000000) /* Strobo-Mode/No-Coin Time Stat Info */ - -#define LWL_ETS_TR (0x0e000000) /* Transp-Mode Ext Time Status Info */ -#define LWL_ETS_HM_C (0x0e000000) /* Hist-Mode+Coinc Time Status Info */ -#define LWL_ETS_SM_C (0x0e000000) /* Strobo-Mode+Coinc Time Status Info */ - -#define LWL_FIFO_EMPTY (0x1e000000) /* FIFO Empty */ +#define LWL_TSI_MODE_MASK (0x000e) /* Mask for mode in Time Status Info */ +#define LWL_TSI_MODE_TR (0x0000) /* TSI Transparent-Mode */ +#define LWL_TSI_MODE_HM (0x0002) /* TSI Hist-Mode */ +#define LWL_TSI_MODE_TOF (0x0004) /* TSI TOF-Mode */ +#define LWL_TSI_MODE_SM1 (0x0006) /* TSI Strobo-Mode 1 - time-stamp coded */ +#define LWL_TSI_MODE_TR_UD (0x0008) /* TSI Transparent-Mode Up-Down */ +#define LWL_TSI_MODE_HM_UD (0x000a) /* TSI Hist-Mode Up-Down */ +#define LWL_TSI_MODE_TOF_UD (0x000c) /* TSI TOF-Mode Up-Down */ +#define LWL_TSI_MODE_SM2 (0x000e) /* TSI Strobo-Mode 2 - h/w coded */ /* **------------------------------------------------------------------------------ ** Define structure of a TOF histogram data item. @@ -228,7 +277,7 @@ ** value) if bin width is constant. Otherwise ** it is zero. */ uint hi_edge; /* Top edge of last bin (20-bit value) */ - uint edges[2]; /* Array of edge data (20-bit values). There + uint edges[2]; /* Array of edge data (20-bit values). There ** are actually (n_bins+1) items in the array ** and give the bottom edges of the bin */ }; @@ -238,7 +287,7 @@ struct tof_edge_arr { uint n_bins; /* Number of bins in histogram */ uint flag; /* Flag (0/1) for fixed/variable bin size */ - uint *edges ; /* Array of bottom edges (20-bit values) */ + uint *edges; /* Array of bottom edges (20-bit values) */ }; /* Define structure of a TOF 'bank' in SQHM__TOF config command @@ -286,12 +335,20 @@ } u; } cnfg; - struct {uint level;} dbg; + struct {uint mask;} dbg; struct {uint sub_code;} decnfg; struct {uint sub_cmnd;} daq; + struct {uint sub_code, + x_lo, + nx, + y_lo, + ny, + xdim, + nhist;} project; + struct {uint hist_no, first_bin, n_bins;} read; @@ -314,8 +371,8 @@ */ struct rply_buff_struct { /* For messages from SinqHM */ uint bigend; - uint status, - sub_status; + uint status; + uint sub_status; union { char message[52]; @@ -330,13 +387,34 @@ uint total_bytes; uint lo_cntr; uint lo_bin; - uint compress;} cnct; + uint compress; + uint up_time;} cnct; struct {usint daq_now; usint daq_was; usint filler_mask; usint server_mask;} daq; + struct {uint n_extra_bytes; + uint up_time; + usint offset_vxWorks_ident; + usint offset_vxWorks_date; + usint offset_instr; + usint offset_def_ident; + usint offset_sinqhm_main_ident; + usint offset_sinqhm_main_date; + usint offset_sinqhm_server_ident; + usint offset_sinqhm_server_date; + usint offset_sinqhm_filler_ident; + usint offset_sinqhm_filler_date; + usint offset_sinqhm_routines_ident; + usint offset_sinqhm_routines_date;} ident; + + struct {uint n_bins; + uint bytes_per_bin; + uint cnts_lo; + uint cnts_hi;} project; + struct {uint first_bin; uint n_bins; uint bytes_per_bin; @@ -344,18 +422,21 @@ uint cnts_hi;} read; struct {uint cfg_state; - usint n_hists; - usint curr_hist; + usint n_hists, curr_hist; uint num_bins; uint max_n_hists; uint max_num_bins; - uchar max_srvrs; - uchar act_srvrs; - uchar bytes_per_bin; - uchar compress; - usint daq_now; - usint filler_mask; - uint max_block;} status; + uchar max_srvrs, act_srvrs, bytes_per_bin, compress; + usint daq_now, filler_mask; + uint max_block; + usint tsi_status, flags; + union { + uint dead_time; + uint dts; + uint both; + } dt_or_dts; + uint num_bad_events; + uint up_time;} status; } u; }; /* diff --git a/histmem.c b/histmem.c index d33d1976..ea3bd9f5 100644 --- a/histmem.c +++ b/histmem.c @@ -8,6 +8,8 @@ revised: Mark Koennecke, June 1997 + added getzip: Mark Koennecke, October 2000 + Copyright: Labor fuer Neutronenstreuung @@ -1555,6 +1557,86 @@ /* Write it */ SCWriteUUencoded(pCon,"SicsHistogram",lData,(iEnd+1)*sizeof(HistInt)); + /* clean up and go */ + free(lData); + return 1; + } + else if(strcmp(argv[1],"zipget") == 0) /* get a histogram */ + { + /* check parameters, first required: no of Hist */ + if(argc < 3) + { + sprintf(pBueffel,"ERROR: insufficient number of arguments to %s %s", + argv[0], argv[1]); + SCWrite(pCon,pBueffel,eError); + return 0; + } + iNum = atoi(argv[2]); + + /* check iNum */ + if( (iNum < 0) || (iNum > self->pDriv->iRank)) + { + sprintf(pBueffel,"ERROR: requested histogram no %d out of range", + iNum); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + /* optional iStart, default 0 */ + iStart = 0; + if(argc > 3 ) + { + iStart = atoi(argv[3]); + } + + /* check iStart */ + if(iStart < 0) + { + SCWrite(pCon,"WARNING: Invalid start position defaulted to 0",eWarning); + iStart = 0; + } + + /* optional iEnd, default to maximum */ + iEnd = self->pDriv->iLength; + if(argc > 4) + { + iEnd = atoi(argv[4]); + } + + /* check iEnd */ + if(iEnd > self->pDriv->iLength) + { + iEnd = self->pDriv->iLength; + SCWrite(pCon, + "WARNING: invalid end parameter reset to max ",eWarning); + } + + /* allocate data storage and get it */ + lData = (HistInt *)malloc((iEnd+1)*sizeof(HistInt)); + if(!lData) + { + SCWrite(pCon,"ERROR: no memory in HistAction/get",eError); + return 0; + } + memset(lData,0,(iEnd+1)*sizeof(HistInt)); + iRet = GetHistogram(self,pCon,iNum,iStart,iEnd, + &lData[0],iEnd*sizeof(HistInt)); + if(!iRet) + { + sprintf(pBueffel,"ERROR: cannot retrieve histogram %d",iNum); + SCWrite(pCon,pBueffel,eError); + free(lData); + return 0; + } + + /* convert to network byte order */ + for(i = 0; i < iEnd; i++) + { + lData[i] = htonl(lData[i]); + } + /* Write it */ + SCWriteZipped(pCon,argv[0],lData,iEnd*sizeof(HistInt)); + /* clean up and go */ free(lData); return 1; diff --git a/histsim.c b/histsim.c index 50602bc8..15ebf433 100644 --- a/histsim.c +++ b/histsim.c @@ -51,9 +51,9 @@ #include "HistDriv.i" #include "histsim.h" +/* #define TESTVAL 128 -/* define TESTVAL to set the simulated histogram to a fixed value for testing @@ -188,6 +188,8 @@ static int SimSetHistogram(pHistDriver self, SConnection *pCon, int i, int iStart, int iEnd, HistInt *lData) { + iSet = 1; + iSetVal = lData[0]; return 1; } diff --git a/hklscan.c b/hklscan.c index 34d81c28..4a2c7c4b 100644 --- a/hklscan.c +++ b/hklscan.c @@ -156,7 +156,7 @@ /* make the data header */ sprintf(pLine,"%-5s","NP"); strcpy(pInfo,"Scanning Variables: H, K, L"); - strcat(pLine,"H K L "); + strcat(pLine,"H K L "); for(i = 0; i < self->iScanVar;i++) { DynarGet(self->pScanVar,i,&pPtr); @@ -168,7 +168,7 @@ } } strcat(pLine,"Counts "); - strcat(pLine,"Monitor1 "); + strcat(pLine," Monitor1 "); sprintf(pItem,"\n%d Points,",self->iNP); strcat(pInfo,pItem); if(self->iMode == eTimer) @@ -185,9 +185,9 @@ fprintf(self->fd,"%s\n",pLine); /* print an addon to the status line going to the screen */ - sprintf(pLine,"NP H K L "); + sprintf(pLine,"NP H K L "); SCWrite(self->pCon,pLine,eWarning); - sprintf(pLine,"%-5d%-6.2f%-6.2f%-6.2f ",iPoint,pHaSca->fPos[0], + sprintf(pLine,"%-5d%-8.4f%-8.4f%-8.4f ",iPoint,pHaSca->fPos[0], pHaSca->fPos[1], pHaSca->fPos[2]); SCWrite(self->pCon,pLine,eWarning); @@ -198,7 +198,7 @@ /* print HKL */ for(i2 = 0; i2 < 3; i2++) { - sprintf(pItem,"%-6.2f",pHaSca->fStart[i2] + i * pHaSca->fStep[i2]); + sprintf(pItem,"%-8.4f",pHaSca->fStart[i2] + i * pHaSca->fStep[i2]); strcat(pLine,pItem); } /* print chi, ph, om */ @@ -217,7 +217,7 @@ pData = (pCountEntry)pPtr; if(pData) { - sprintf(pItem,"%-12ld",pData->lCount); + sprintf(pItem,"%-13ld",pData->lCount); strcat(pLine,pItem); sprintf(pItem,"%-12ld",pData->Monitors[0]); strcat(pLine,pItem); @@ -261,6 +261,7 @@ self->pScan->WriteScanPoints = WriteHklscanPoint; self->pScan->ScanDrive = HklscanDrive; self->pScan->pSpecial = self; + self->pScan->PrepareScan = NonCheckPrepare; /* scan */ iRet = DoScan(self->pScan,iNP, iMode, fPreset, pServ->pSics,pCon); diff --git a/network.c b/network.c index f004ff71..0d87407e 100644 --- a/network.c +++ b/network.c @@ -47,6 +47,7 @@ #include #include #include +#include #define PORT 1 #define SOCKET 2 @@ -393,7 +394,9 @@ CreateSocketAdress( iRet = select( (self->sockid + 1),&lMask, NULL, NULL,&tmo); if( iRet <= 0) { - /* failure, or no data */ + /* failure, or no data + printf(" %d %d\n", iRet, errno); + */ return 0; } } diff --git a/nextrics.c b/nextrics.c index 7e1b1fcd..558894b2 100644 --- a/nextrics.c +++ b/nextrics.c @@ -12,6 +12,8 @@ copyright: see copyright.h Mark Koennecke, April 1998 + + Revised: Mark Koennecke, October 2000 ----------------------------------------------------------------------------*/ #include #include @@ -30,12 +32,17 @@ #include "udpquieck.h" #include "nextrics.h" -#define DET1X 128 /* x -length of detector 1 */ -#define DET1Y 128 /* y-length of detector 1 */ +#define DET1X 256 /* x -length of detector 1 */ +#define DET1Y 256 /* y-length of detector 1 */ #define DET1XS 2 /* pixel size in x of detector 1 */ #define DET1YS 2 /* pixel size in y of detector 1 */ #define DET1DESC "Non existent Detector" -#define DETAMAX 128 /* maximum length of pixelsize array */ +#define DETAMAX 256 /* maximum length of pixelsize array */ + +/* histogram memory names */ +#define HM1 "hm1" +#define HM2 "hm2" +#define HM3 "hm3" /*------------------------ the data structure ----------------------------*/ typedef struct __NexTrics { @@ -44,10 +51,14 @@ char *pFileRoot; pDataNumber pDanu; NXdict pDict; - pHistMem pHistogram; + pHistMem pHistogram1, pHistogram2, pHistogram3; int iFirst; + int iFrameNum; + pICallBack pCall; } NexTrics; - + +/* event type */ +#define NEWFRAME 1166 /*----------------------------------------------------------------------*/ pNexTrics CreateNexTrics(pDataNumber pNum, char *pRoot, char *pDict, SicsInterp *pSics) @@ -64,9 +75,10 @@ } memset(pNew,0,sizeof(NexTrics)); - /* new object descriptor */ - pNew->pDes = CreateDescriptor("NexTrics"); - if(!pNew->pDes) + /* new object descriptor and callback interface */ + pNew->pDes = CreateDescriptor(HM1); + pNew->pCall = CreateCallBackInterface(); + if(!pNew->pDes || !pNew->pCall) { free(pNew); return NULL; @@ -83,14 +95,33 @@ pNew->pDanu = pNum; /* find things in interpreter */ - pCom = FindCommand(pSics,"banana"); + pCom = FindCommand(pSics,HM1); if(!pCom) { DeleteNexTrics(pNew); return NULL; } - pNew->pHistogram = (pHistMem)pCom->pData; + pNew->pHistogram1 = (pHistMem)pCom->pData; + pCom = FindCommand(pSics,HM2); + if(pCom) + { + pNew->pHistogram2 = (pHistMem)pCom->pData; + } + else + { + pNew->pHistogram2 = NULL; + } + pCom = FindCommand(pSics,HM3); + if(pCom) + { + pNew->pHistogram3 = (pHistMem)pCom->pData; + } + else + { + pNew->pHistogram3 = NULL; + } pNew->iFirst = 1; + pNew->iFrameNum = 0; return pNew; } @@ -114,6 +145,9 @@ if(self->pDict) NXDclose(self->pDict,NULL); + + if(self->pCall) + DeleteCallBackInterface(self->pCall); free(self); } @@ -215,7 +249,7 @@ } /* write counting parameters */ - eMode = GetHistCountMode(self->pHistogram); + eMode = GetHistCountMode(self->pHistogram1); if(eMode == eTimer) { strcpy(pBueffel,"Timer"); @@ -225,14 +259,14 @@ strcpy(pBueffel,"Monitor"); } NXDputalias(hfil,self->pDict,"framemode",pBueffel); - fVal = GetHistPreset(self->pHistogram); + fVal = GetHistPreset(self->pHistogram1); NXDputalias(hfil,self->pDict,"framepreset",&fVal); - lVal = GetHistMonitor(self->pHistogram,1,pCon); + lVal = GetHistMonitor(self->pHistogram1,1,pCon); iVal = (int32)lVal; NXDputalias(hfil,self->pDict,"framemonitor",&iVal); /* write detector1 histogram */ - GetHistogram(self->pHistogram,pCon,0,0,DET1X*DET1Y,lData,DET1X*DET1Y*sizeof(HistInt)); + GetHistogram(self->pHistogram1,pCon,0,0,DET1X*DET1Y,lData,DET1X*DET1Y*sizeof(HistInt)); NXDputalias(hfil,self->pDict,"framecounts",lData); /* the NXdata links */ @@ -274,7 +308,8 @@ /* make sure: first frame */ NXDupdate(self->pDict,"framename","frame0000"); - + self->iFrameNum = 0; + /* title */ pVar = NULL; pVar = FindVariable(pServ->pSics,"title"); @@ -308,7 +343,7 @@ { SCWrite(pCon,"ERROR: failed to write source name",eError); } - strcpy(pBueffel,"Continous flux spallation source"); + strcpy(pBueffel,"Spallation Neutron Source"); iRet = NXDputalias(hfil,self->pDict,"stype",pBueffel); if(iRet != NX_OK) { @@ -510,6 +545,8 @@ { SCWrite(pCon,"ERROR: failed to write initial frame number",eError); } + self->iFrameNum = 1; + InvokeCallBack(self->pCall, NEWFRAME,&(self->iFrameNum)); self->iFirst = 0; @@ -552,6 +589,8 @@ sprintf(pBueffel,"frame%4.4d", iFrameNum); NXDupdate(self->pDict,"framename",pBueffel); iFrameNum++; + self->iFrameNum++; + InvokeCallBack(self->pCall, NEWFRAME,&(self->iFrameNum)); iRet = NXDputalias(hfil,self->pDict,"fnum",&iFrameNum); if(iRet != NX_OK) { @@ -675,6 +714,8 @@ pCon); self->iFirst = 1; + self->iFrameNum = 0; + InvokeCallBack(self->pCall, NEWFRAME,&(self->iFrameNum)); /* close the file and go */ NXclose(&hfil); @@ -692,7 +733,6 @@ /* concat with data root and check for existence */ sprintf(pBueffel,"%s/%s",self->pFileRoot,filename); iRet = NXopen(pBueffel,NXACC_RDWR,&hfil); - NXclose(&hfil); if(iRet != NX_OK) { return 0; @@ -714,6 +754,8 @@ { self->iFirst = 0; } + self->iFrameNum = iFrameNum; + InvokeCallBack(self->pCall, NEWFRAME,&(self->iFrameNum)); return 1; } /*--------------------------------------------------------------------------*/ @@ -735,13 +777,122 @@ return iRet; } +/*-------------------------------------------------------------------------*/ + static int FrameInterest(int iEvent, void *pEvent, void *pUser) + { + SConnection *pCon = NULL; + int *iFrame; + char pBueffel[512]; + + if(iEvent != NEWFRAME) + { + return 0; + } + + pCon = (SConnection *)pUser; + iFrame = (int *)pEvent; + assert(pCon); + sprintf(pBueffel,"framenumber = %d",*iFrame); + SCWrite(pCon,pBueffel,eWarning); + return 1; + } +/*------------------------------------------------------------------------- + NexusGetFrame opens a TRICS NeXus file and retrieves a frame for the + specified detector from it. This is a specila feature for the + status display. + ---------------------------------------------------------------------------*/ + static int NexusGetFrame(SConnection *pCon, pNexTrics self, + int iDetector, int iFrame) + { + char pBueffel[132]; + int iRet; + NXhandle hfil; + HistInt *lData = NULL; + + /* do a few range checks */ + if(iDetector < 1 || iDetector > 3) + { + sprintf(pBueffel,"ERROR: unknown detector %d requested",iDetector); + return 0; + } + if(iFrame < 0 || iFrame >= self->iFrameNum) + { + sprintf(pBueffel,"ERROR: farme %d not yet written",iDetector); + return 0; + } + + /* open file */ + iRet = NXopen(self->pCurrentFile,NXACC_READ,&hfil); + if(iRet != NX_OK) + { + sprintf(pBueffel,"ERROR: cannot open %s",self->pCurrentFile); + SCWrite(pCon,pBueffel,eError); + return 0; + } + + /* open groups */ + sprintf(pBueffel,"frame%4.4d",iFrame); + iRet = NXopengroup(hfil,pBueffel,"NXentry"); + if(iRet != NX_OK) + { + sprintf(pBueffel,"ERROR: frame %d not found in %s",iFrame, + self->pCurrentFile); + SCWrite(pCon,pBueffel,eError); + NXclose(&hfil); + return 0; + } + sprintf(pBueffel,"detector%1.1d",iDetector); + iRet = NXopengroup(hfil,pBueffel,"NXdata"); + if(iRet != NX_OK) + { + sprintf(pBueffel,"ERROR: detector %d not found in %s",iFrame, + self->pCurrentFile); + SCWrite(pCon,pBueffel,eError); + NXclose(&hfil); + return 0; + } + iRet = NXopendata(hfil,"counts"); + if(iRet != NX_OK) + { + SCWrite(pCon,"ERROR: no counts found, file corrupted",eError); + NXclose(&hfil); + return 0; + } + + /* read data */ + lData = (HistInt *)malloc(DET1X*DET1Y*sizeof(HistInt)); + if(!lData) + { + SCWrite(pCon,"ERROR: out of memory in NexusGetFrame",eError); + NXclose(&hfil); + return 0; + } + memset(lData,0,DET1X*DET1Y*sizeof(HistInt)); + iRet = NXgetdata(hfil,lData); + if(iRet != NX_OK) + { + SCWrite(pCon,"ERROR: failed to read data",eError); + NXclose(&hfil); + return 0; + } + + /* send it */ + sprintf(pBueffel,"detector%1.1d",iDetector); + SCWriteZipped(pCon,pBueffel,lData,DET1X*DET1Y*sizeof(HistInt)); + + /* clean up */ + NXclose(&hfil); + free(lData); + return 1; + } /*---------------------------------------------------------------------------*/ int NexTricsAction(SConnection *pCon, SicsInterp *pSics, void *pData, int argc, char *argv[]) { pNexTrics self; char pBueffel[1024]; - int iRet; + int iRet, iDet, iFrame; + long lID; self = (pNexTrics)pData; assert(self); @@ -778,6 +929,33 @@ SCWrite(pCon,pBueffel,eValue); return 1; } + else if(strcmp(argv[1],"oldframe") == 0) + { + if(argc < 4) + { + SCWrite(pCon,"ERROR: insufficient number of arguments to oldframe", + eError); + return 0; + } + iDet = atoi(argv[2]); + iFrame = atoi(argv[3]); + iRet = NexusGetFrame(pCon,self,iDet, iFrame); + return 1; + } + else if(strcmp(argv[1],"interest") == 0) + { + lID = RegisterCallback(self->pCall, NEWFRAME, FrameInterest, + pCon, NULL); + SCRegister(pCon,pSics, self->pCall,lID); + SCSendOK(pCon); + return 1; + } + else if(strcmp(argv[1],"framenum") == 0) + { + sprintf(pBueffel,"framenumber = %d",self->iFrameNum); + SCWrite(pCon,pBueffel,eValue); + return 1; + } else if(strcmp(argv[1],"dumpframe") == 0) { if(!SCMatchRights(pCon,usUser)) @@ -813,3 +991,4 @@ SCWrite(pCon,pBueffel,eError); return 0; } + diff --git a/nread.c b/nread.c index 14a1bb65..dde5671b 100644 --- a/nread.c +++ b/nread.c @@ -8,6 +8,10 @@ Mark Koennecke, September 1997 Telnet Functionality added: Mark Koennecke, January 1998 + + Revamped login to non telnet connection. + Mark Koennecke, October 20000 + -----------------------------------------------------------------------------*/ #include #include @@ -174,6 +178,7 @@ extern VerifyChannel(mkChannel *self); /* defined in network.c */ int iRet; SConnection *pRes = NULL; char *pUser = NULL, *pPasswd = NULL; + time_t target; if(!VerifyChannel(pSock)) { @@ -183,55 +188,28 @@ extern VerifyChannel(mkChannel *self); /* defined in network.c */ /* check for new connection */ pNew = NETAccept(pSock,0); if(pNew) - { /* new connection, read user/passwd, verify and work accordingly */ - iRet = NETRead(pNew,pBuffer,1063, self->iPasswdTimeout); - if(iRet <= 0) + { + /* create connection object */ + pRes = SCreateConnection(self->pMain->pSics,pNew,iRet); + if(!pRes) { - strcpy(pBuffer,"Timeout waiting for username/password"); - SICSLogWrite(pBuffer,eInternal); - NETClosePort(pNew); - free(pNew); - return 0; + SICSLogWrite("Failure to allocate new Connection",eInternal); + NETClosePort(pNew); + free(pNew); + return 0; } else { - pUser = strtok(pBuffer," \t"); - pPasswd = strtok(NULL," \t\r\n"); - iRet = IsValidUser(pUser,pPasswd); - if(iRet < 0) - { - sprintf(pBuffer,"SYSTEM ATTACK by %s / %s",pUser, - pPasswd); - SICSLogWrite(pBuffer,eInternal); - NETClosePort(pNew); - free(pNew); - return 0; - } - else - { - /* create connection object */ - pRes = SCreateConnection(self->pMain->pSics,pNew,iRet); - if(!pRes) - { - SICSLogWrite("Failure to allocate new Connection",eInternal); - NETClosePort(pNew); - free(pNew); - return 0; - } - else - { - /* register the connection and create a task for it here */ - NetReadRegister(self,pNew,command, pRes); - TaskRegister(self->pMain->pTasker, + /* register the connection and create a task for it here */ + NetReadRegister(self,pNew,command, pRes); + TaskRegister(self->pMain->pTasker, SCTaskFunction, SCSignalFunction, SCDeleteConnection, pRes, 1); - SCSendOK(pRes); - return 1; - } - } + SCSendOK(pRes); + return 1; } } else diff --git a/ofac.c b/ofac.c index 45fd402b..6cfa058e 100644 --- a/ofac.c +++ b/ofac.c @@ -102,6 +102,7 @@ #include "difrac.h" #include "sicscron.h" #include "lin2ang.h" +#include "tas.h" /*----------------------- Server options creation -------------------------*/ static int IFServerOption(SConnection *pCon, SicsInterp *pSics, void *pData, int argc, char *argv[]) @@ -273,6 +274,7 @@ AddCommand(pInter,"MakeMaximize",MaximizeFactory,NULL,NULL); AddCommand(pInter,"MakeDifrac",MakeDifrac,NULL,NULL); AddCommand(pInter,"MakeLin2Ang",MakeLin2Ang,NULL,NULL); + AddCommand(pInter,"MakeTAS",TASFactory,NULL,NULL); } /*---------------------------------------------------------------------------*/ static void KillIniCommands(SicsInterp *pSics) @@ -323,6 +325,7 @@ RemoveCommand(pSics,"MakeMaximize"); RemoveCommand(pSics,"MakeDifrac"); RemoveCommand(pSics,"MakeLin2Ang"); + RemoveCommand(pSics,"MakeTAS"); } diff --git a/scan.c b/scan.c index d11dfd67..8e463e1c 100644 --- a/scan.c +++ b/scan.c @@ -441,6 +441,7 @@ extern void SNXFormatTime(char *pBuffer, int iLen); static int ScanDrive(pScanData self, int iPoint); static int ScanCount(pScanData self, int iPoint); static int CollectScanData(pScanData self, int iPoint); + static int PrepareScan(pScanData self); /*--------------------------------------------------------------------------*/ pScanData CreateScanObject(char *pRecover, char *pHeader,pCounter pCount) { @@ -493,6 +494,7 @@ extern void SNXFormatTime(char *pBuffer, int iLen); pNew->fPreset = 10.; strcpy(pNew->pCounterName,pCount->name); pNew->pCounterData = pCount; + pNew->PrepareScan = PrepareScan; pNew->WriteHeader = WriteHeader; pNew->WriteScanPoints = WriteScanPoints; pNew->ScanDrive = ScanDrive; @@ -540,6 +542,7 @@ extern void SNXFormatTime(char *pBuffer, int iLen); { assert(self); + self->PrepareScan = PrepareScan; self->WriteHeader = WriteHeader; self->WriteScanPoints = WriteScanPoints; self->ScanDrive = ScanDrive; @@ -825,6 +828,60 @@ extern void SNXFormatTime(char *pBuffer, int iLen); return 1; } /*--------------------------------------------------------------------------*/ + int NonCheckPrepare(pScanData self) + { + pVarEntry pVar = NULL; + void *pDings; + int i, iRet; + float fVal; + char pBueffel[512]; + char pMessage[1024]; + + assert(self); + assert(self->iNP > 0); + assert(self->pCon); + + /* allocate storage for scan variables */ + for(i = 0; i < self->iScanVar; i++) + { + DynarGet(self->pScanVar,i,&pDings); + pVar = (pVarEntry)pDings; + if(pVar) + { + /* start value */ + fVal = pVar->fStart; + + /* allocate data space */ + if(pVar->fData) + { + free(pVar->fData); + pVar->fData = NULL; + } + pVar->fData = (float *)malloc(self->iNP * sizeof(float)); + if(!pVar->fData) + { + SCWrite(self->pCon,"ERROR: out of memory in scan, aborting",eError); + return 0; + } + memset(pVar->fData,0,self->iNP * sizeof(float)); + } + else + { + SCWrite(self->pCon, + "WARNING: Internal error, no scan variable, I try to continue", + eWarning); + } + pVar = NULL; + } /* end for */ + + /* configure counter */ + SetCounterMode((pCounter)self->pCounterData,self->iMode); + SetCounterPreset((pCounter)self->pCounterData, self->fPreset); + self->iCounts = 0; + + return 1; + } +/*--------------------------------------------------------------------------*/ static int StartToDrive(pScanData self, int iPoint) { pVarEntry pVar = NULL; @@ -1129,6 +1186,7 @@ extern void SNXFormatTime(char *pBuffer, int iLen); /*-------- scan post processing */ self->CollectScanData(self,i); InvokeCallBack(self->pCall,SCANPOINT,self); + self->WriteScanPoints(self,i); if(self->pRecover) { @@ -1178,7 +1236,14 @@ extern void SNXFormatTime(char *pBuffer, int iLen); self->fPreset = fPreset; /* do some preprocessing */ - iRet = PrepareScan(self); + if(self->PrepareScan != NULL) + { + iRet = self->PrepareScan(self); + } + else + { + iRet = 1; + } if(!iRet) { self->pCon = NULL; @@ -2381,3 +2446,8 @@ extern void SNXFormatTime(char *pBuffer, int iLen); return 0; } } + + + + + diff --git a/scan.h b/scan.h index 1892d426..eb2b26cb 100644 --- a/scan.h +++ b/scan.h @@ -52,7 +52,12 @@ /* resets the configurable scan functions to their default values. */ - + int NonCheckPrepare(pScanData self); + /* + a function for the PrepareScan field in the scan data structure + which does not check the boundaries of the scan as the default + PrepareScan does. + */ /*------------------------ Interpreter Interface --------------------------*/ int ScanFactory(SConnection *pCon, SicsInterp *pSics, void *pData, int argc, char *argv[]); diff --git a/scan.i b/scan.i index 0503d24d..03e752f1 100644 --- a/scan.i +++ b/scan.i @@ -38,6 +38,7 @@ SConnection *pCon; char pRecover[1024]; char pHeaderFile[1024]; + int (*PrepareScan)(pScanData self); int (*WriteHeader)(pScanData self); int (*WriteScanPoints) (pScanData self, diff --git a/scan.tex b/scan.tex index 48dc0600..27fb5393 100644 --- a/scan.tex +++ b/scan.tex @@ -66,6 +66,7 @@ $\langle$scandata {\footnotesize ?}$\rangle\equiv$ \mbox{}\verb@ SConnection *pCon;@\\ \mbox{}\verb@ char pRecover[1024];@\\ \mbox{}\verb@ char pHeaderFile[1024];@\\ +\mbox{}\verb@ int (*PrepareScan)(pScanData self);@\\ \mbox{}\verb@ int (*WriteHeader)(pScanData self);@\\ \mbox{}\verb@ int (*WriteScanPoints)@\\ \mbox{}\verb@ (pScanData self, @\\ @@ -140,6 +141,9 @@ line is permitted. finding data. \item[pCon] The connection object to use for error reporting during scan execution. +\item[PrepareScan] checks limits of scan variables and memorizes +important scan information. Sometimes this is not wanted, that is why +it is parametrized here. \item[WriteHeader] is a pointer to a function which writes the header part of the scan file. Replace this function if another data format is needed. \item[WriteScanPoints] is a pointer to a function which will be called after @@ -221,7 +225,12 @@ $\langle$scaninter {\footnotesize ?}$\rangle\equiv$ \mbox{}\verb@ /*@\\ \mbox{}\verb@ resets the configurable scan functions to their default values.@\\ \mbox{}\verb@ */@\\ -\mbox{}\verb@@\\ +\mbox{}\verb@ int NonCheckPrepare(pScanData self);@\\ +\mbox{}\verb@ /*@\\ +\mbox{}\verb@ a function for the PrepareScan field in the scan data structure@\\ +\mbox{}\verb@ which does not check the boundaries of the scan as the default@\\ +\mbox{}\verb@ PrepareScan does.@\\ +\mbox{}\verb@ */@\\ \mbox{}\verb@/*------------------------ Interpreter Interface --------------------------*/@\\ \mbox{}\verb@ int ScanFactory(SConnection *pCon, SicsInterp *pSics, void *pData,@\\ \mbox{}\verb@ int argc, char *argv[]);@\\ @@ -279,6 +288,12 @@ summed counts and the variance. See the section on integrate for more details. \item[ResetScanFunctions] reinstalls the default functions for scan processing into the ScanData structure. +\item[NonCheckPrepare] Before a scan is started, various data +structures in the scan object are initialized. Thereby the scan +boundaries are checked against the motor limits. For some scans this +is not feasible. This version omits this check and must be entered as +the PrepareScan function field in the scan data structure by code +using the scan module. \item[SimScan] creates a simulated gaussian peak with the given parameters. Used for debugging several things. \item[ScanFactory] is the SICS interpreter object creation function diff --git a/scan.w b/scan.w index b1534970..b41bff28 100644 --- a/scan.w +++ b/scan.w @@ -61,6 +61,7 @@ steps in scan processing which is already partly implemented. SConnection *pCon; char pRecover[1024]; char pHeaderFile[1024]; + int (*PrepareScan)(pScanData self); int (*WriteHeader)(pScanData self); int (*WriteScanPoints) (pScanData self, @@ -128,6 +129,9 @@ line is permitted. finding data. \item[pCon] The connection object to use for error reporting during scan execution. +\item[PrepareScan] checks limits of scan variables and memorizes +important scan information. Sometimes this is not wanted, that is why +it is parametrized here. \item[WriteHeader] is a pointer to a function which writes the header part of the scan file. Replace this function if another data format is needed. \item[WriteScanPoints] is a pointer to a function which will be called after @@ -204,7 +208,12 @@ functions: /* resets the configurable scan functions to their default values. */ - + int NonCheckPrepare(pScanData self); + /* + a function for the PrepareScan field in the scan data structure + which does not check the boundaries of the scan as the default + PrepareScan does. + */ /*------------------------ Interpreter Interface --------------------------*/ int ScanFactory(SConnection *pCon, SicsInterp *pSics, void *pData, int argc, char *argv[]); @@ -254,6 +263,12 @@ summed counts and the variance. See the section on integrate for more details. \item[ResetScanFunctions] reinstalls the default functions for scan processing into the ScanData structure. +\item[NonCheckPrepare] Before a scan is started, various data +structures in the scan object are initialized. Thereby the scan +boundaries are checked against the motor limits. For some scans this +is not feasible. This version omits this check and must be entered as +the PrepareScan function field in the scan data structure by code +using the scan module. \item[SimScan] creates a simulated gaussian peak with the given parameters. Used for debugging several things. \item[ScanFactory] is the SICS interpreter object creation function diff --git a/sicsstat.tcl b/sicsstat.tcl index d1fd1a55..9215d79d 100644 --- a/sicsstat.tcl +++ b/sicsstat.tcl @@ -1,406 +1,311 @@ -#Crystallographic Settings -hkl lambda 0.703790 -hkl setub -0.124702 0.001618 -0.041357 -0.104448 -0.001326 0.049388 0.000751 0.084094 0.001574 -lastscancommand UNKNOWN -lastscancommand setAccess 2 -sample_mur 0.000000 -sample_mur setAccess 2 -email UNKNOWN -email setAccess 2 -fax UNKNOWN -fax setAccess 2 -phone UNKNOWN -phone setAccess 2 -adress UNKNOWN -adress setAccess 2 +arx2 4.290000 +arx2 setAccess 1 +arx1 0.150000 +arx1 setAccess 1 +mrx2 10.420000 +mrx2 setAccess 1 +mrx1 0.280000 +mrx1 setAccess 1 +lpa 0 +lpa setAccess 2 +dt 0.000000 +dt setAccess 2 +dqm 0.000000 +dqm setAccess 2 +qm 0.000000 +qm setAccess 2 +etaa 0.000000 +etaa setAccess 2 +etas 0.000000 +etas setAccess 2 +etam 0.000000 +etam setAccess 2 +wav 0.000000 +wav setAccess 2 +den 0.000000 +den setAccess 2 +dql 0.000000 +dql setAccess 2 +dqk 0.000000 +dqk setAccess 2 +dqh 0.000000 +dqh setAccess 2 +dkf 0.000000 +dkf setAccess 2 +def 0.000000 +def setAccess 2 +dki 0.000000 +dki setAccess 2 +dei 0.000000 +dei setAccess 2 +dagl 0.000000 +dagl setAccess 2 +dsgu 0.000000 +dsgu setAccess 2 +dsgl 0.000000 +dsgl setAccess 2 +dmgl 0.000000 +dmgl setAccess 2 +datu 0.000000 +datu setAccess 2 +datl 0.000000 +datl setAccess 2 +dstu 0.000000 +dstu setAccess 2 +dstl 0.000000 +dstl setAccess 2 +dmtu 0.000000 +dmtu setAccess 2 +dmtl 0.000000 +dmtl setAccess 2 +dach 0.000000 +dach setAccess 2 +dsro 0.000000 +dsro setAccess 2 +dmcv 0.000000 +dmcv setAccess 2 +da6 0.000000 +da6 setAccess 2 +da5 0.000000 +da5 setAccess 2 +da4 0.000000 +da4 setAccess 2 +da3 0.000000 +da3 setAccess 2 +da2 0.000000 +da2 setAccess 2 +da1 0.000000 +da1 setAccess 2 +f2 0 +f2 setAccess 2 +f1 0 +f1 setAccess 2 +hz 0.000000 +hz setAccess 2 +hy 0.000000 +hy setAccess 2 +hx 0.000000 +hx setAccess 2 +helm 0.000000 +helm setAccess 2 +if2h 0.000000 +if2h setAccess 2 +if1h 0.000000 +if1h setAccess 2 +if2v 0.000000 +if2v setAccess 2 +if1v 0.000000 +if1v setAccess 2 +mn 0 +mn setAccess 2 +ti 0.000000 +ti setAccess 2 +np 9 +np setAccess 2 +fx 2 +fx setAccess 2 +sa -1 +sa setAccess 2 +ss 1 +ss setAccess 2 +sm 1 +sm setAccess 2 +da 3.354000 +da setAccess 1 +dm 3.354000 +dm setAccess 1 +en 2.800000 +en setAccess 2 +ql 0.000000 +ql setAccess 2 +qk 0.000000 +qk setAccess 2 +qh 2.000000 +qh setAccess 2 +kf 1.964944 +kf setAccess 2 +ef 8.000000 +ef setAccess 2 +ki 2.283058 +ki setAccess 2 +ei 10.800000 +ei setAccess 2 +bz 0.000000 +bz setAccess 2 +by 1.000000 +by setAccess 2 +bx 0.000000 +bx setAccess 2 +az 0.000000 +az setAccess 2 +ay 0.000000 +ay setAccess 2 +ax 1.000000 +ax setAccess 2 +cc 90.000000 +cc setAccess 2 +bb 90.000000 +bb setAccess 2 +aa 90.000000 +aa setAccess 2 +cs 5.000000 +cs setAccess 2 +bs 5.000000 +bs setAccess 2 +as 5.000000 +as setAccess 2 # Counter counter counter SetPreset 1000.000000 counter SetMode Timer -# Motor a33 -a33 SoftZero 0.000000 -a33 SoftLowerLim -10.000000 -a33 SoftUpperLim 39.500000 -a33 Fixed -1.000000 -a33 sign 1.000000 -a33 InterruptMode 0.000000 -a33 AccessCode 2.000000 -# Motor a32 -a32 SoftZero 0.000000 -a32 SoftLowerLim -10.000000 -a32 SoftUpperLim 39.500000 -a32 Fixed -1.000000 -a32 sign 1.000000 -a32 InterruptMode 0.000000 -a32 AccessCode 2.000000 -# Motor a31 -a31 SoftZero 0.000000 -a31 SoftLowerLim -10.000000 -a31 SoftUpperLim 39.500000 -a31 Fixed -1.000000 -a31 sign 1.000000 -a31 InterruptMode 0.000000 -a31 AccessCode 2.000000 -# Motor ph -ph SoftZero 0.000000 -ph SoftLowerLim 318.000000 -ph SoftUpperLim 0.000000 -ph Fixed -1.000000 -ph sign 1.000000 -ph InterruptMode 0.000000 -ph AccessCode 2.000000 -# Motor chi -chi SoftZero 0.000000 -chi SoftLowerLim 270.000000 -chi SoftUpperLim 70.000000 -chi Fixed -1.000000 -chi sign 1.000000 -chi InterruptMode 0.000000 -chi AccessCode 2.000000 -# Motor ch -ch SoftZero 0.000000 -ch SoftLowerLim 270.000000 -ch SoftUpperLim 70.000000 -ch Fixed -1.000000 -ch sign 1.000000 -ch InterruptMode 0.000000 -ch AccessCode 2.000000 -# Motor a20 -a20 SoftZero 0.000000 -a20 SoftLowerLim 318.000000 -a20 SoftUpperLim 0.000000 -a20 Fixed -1.000000 -a20 sign 1.000000 -a20 InterruptMode 0.000000 -a20 AccessCode 2.000000 -# Motor a10 -a10 SoftZero 0.000000 -a10 SoftLowerLim 270.000000 -a10 SoftUpperLim 70.000000 -a10 Fixed -1.000000 -a10 sign 1.000000 -a10 InterruptMode 0.000000 -a10 AccessCode 2.000000 -# Motor th -th SoftZero 0.000000 -th SoftLowerLim -17.000000 -th SoftUpperLim 69.000000 -th Fixed -1.000000 -th sign 1.000000 -th InterruptMode 0.000000 -th AccessCode 2.000000 +# Motor agl +agl SoftZero -0.490000 +agl SoftLowerLim -9.510000 +agl SoftUpperLim 10.490000 +agl Fixed -1.000000 +agl sign 1.000000 +agl InterruptMode 0.000000 +agl AccessCode 2.000000 +# Motor sgu +sgu SoftZero 0.000000 +sgu SoftLowerLim -16.000000 +sgu SoftUpperLim 16.000000 +sgu Fixed -1.000000 +sgu sign 1.000000 +sgu InterruptMode 0.000000 +sgu AccessCode 2.000000 +# Motor sgl +sgl SoftZero 1.550000 +sgl SoftLowerLim -17.549999 +sgl SoftUpperLim 14.450000 +sgl Fixed -1.000000 +sgl sign 1.000000 +sgl InterruptMode 0.000000 +sgl AccessCode 2.000000 +# Motor mgl +mgl SoftZero 1.300000 +mgl SoftLowerLim -11.300000 +mgl SoftUpperLim 8.700000 +mgl Fixed -1.000000 +mgl sign 1.000000 +mgl InterruptMode 0.000000 +mgl AccessCode 2.000000 +# Motor atu +atu SoftZero -0.880000 +atu SoftLowerLim -16.120001 +atu SoftUpperLim 17.879999 +atu Fixed -1.000000 +atu sign 1.000000 +atu InterruptMode 0.000000 +atu AccessCode 2.000000 +# Motor atl +atl SoftZero 0.000000 +atl SoftLowerLim -17.000000 +atl SoftUpperLim 17.000000 +atl Fixed -1.000000 +atl sign 1.000000 +atl InterruptMode 0.000000 +atl AccessCode 2.000000 +# Motor stu +stu SoftZero 0.000000 +stu SoftLowerLim -30.000000 +stu SoftUpperLim 30.000000 +stu Fixed -1.000000 +stu sign 1.000000 +stu InterruptMode 0.000000 +stu AccessCode 2.000000 +# Motor stl +stl SoftZero 0.000000 +stl SoftLowerLim -30.000000 +stl SoftUpperLim 30.000000 +stl Fixed -1.000000 +stl sign 1.000000 +stl InterruptMode 0.000000 +stl AccessCode 2.000000 +# Motor mtu +mtu SoftZero 2.850000 +mtu SoftLowerLim -19.850000 +mtu SoftUpperLim 14.150000 +mtu Fixed -1.000000 +mtu sign 1.000000 +mtu InterruptMode 0.000000 +mtu AccessCode 2.000000 +# Motor mtl +mtl SoftZero 0.000000 +mtl SoftLowerLim -17.000000 +mtl SoftUpperLim 17.000000 +mtl Fixed -1.000000 +mtl sign 1.000000 +mtl InterruptMode 0.000000 +mtl AccessCode 2.000000 +# Motor ach +ach SoftZero 0.000000 +ach SoftLowerLim -0.500000 +ach SoftUpperLim 11.500000 +ach Fixed -1.000000 +ach sign 1.000000 +ach InterruptMode 0.000000 +ach AccessCode 2.000000 +# Motor sro +sro SoftZero 0.000000 +sro SoftLowerLim 0.000000 +sro SoftUpperLim 351.000000 +sro Fixed -1.000000 +sro sign 1.000000 +sro InterruptMode 0.000000 +sro AccessCode 2.000000 +# Motor mcv +mcv SoftZero 0.000000 +mcv SoftLowerLim -9.000000 +mcv SoftUpperLim 124.000000 +mcv Fixed -1.000000 +mcv sign 1.000000 +mcv InterruptMode 0.000000 +mcv AccessCode 2.000000 +# Motor a6 +a6 SoftZero 0.040000 +a6 SoftLowerLim -116.040001 +a6 SoftUpperLim 165.960007 +a6 Fixed -1.000000 +a6 sign 1.000000 +a6 InterruptMode 0.000000 +a6 AccessCode 2.000000 +# Motor a5 +a5 SoftZero 176.479996 +a5 SoftLowerLim -376.479980 +a5 SoftUpperLim 23.520004 +a5 Fixed -1.000000 +a5 sign 1.000000 +a5 InterruptMode 0.000000 +a5 AccessCode 2.000000 # Motor a4 -a4 SoftZero 0.000000 -a4 SoftLowerLim -17.000000 -a4 SoftUpperLim 69.000000 +a4 SoftZero -0.710000 +a4 SoftLowerLim -134.389999 +a4 SoftUpperLim 124.110001 a4 Fixed -1.000000 a4 sign 1.000000 a4 InterruptMode 0.000000 a4 AccessCode 2.000000 -# Motor om -om SoftZero 0.000000 -om SoftLowerLim -9.000000 -om SoftUpperLim 33.000000 -om Fixed -1.000000 -om sign 1.000000 -om InterruptMode 0.000000 -om AccessCode 2.000000 # Motor a3 -a3 SoftZero 0.000000 -a3 SoftLowerLim -9.000000 -a3 SoftUpperLim 33.000000 +a3 SoftZero 11.540000 +a3 SoftLowerLim -188.839996 +a3 SoftUpperLim 165.760010 a3 Fixed -1.000000 a3 sign 1.000000 a3 InterruptMode 0.000000 a3 AccessCode 2.000000 -# Motor a37 -a37 SoftZero 0.000000 -a37 SoftLowerLim 0.000000 -a37 SoftUpperLim 555.000000 -a37 Fixed -1.000000 -a37 sign 1.000000 -a37 InterruptMode 0.000000 -a37 AccessCode 2.000000 -# Motor a26 -a26 SoftZero 0.000000 -a26 SoftLowerLim 0.000000 -a26 SoftUpperLim 10.000000 -a26 Fixed -1.000000 -a26 sign 1.000000 -a26 InterruptMode 0.000000 -a26 AccessCode 2.000000 -# Motor a25 -a25 SoftZero 0.000000 -a25 SoftLowerLim -3.000000 -a25 SoftUpperLim 5.500000 -a25 Fixed -1.000000 -a25 sign 1.000000 -a25 InterruptMode 0.000000 -a25 AccessCode 2.000000 -# Motor a24 -a24 SoftZero 0.000000 -a24 SoftLowerLim -6.000000 -a24 SoftUpperLim 3.000000 -a24 Fixed -1.000000 -a24 sign 1.000000 -a24 InterruptMode 0.000000 -a24 AccessCode 2.000000 -# Motor a23 -a23 SoftZero 0.000000 -a23 SoftLowerLim -10.000000 -a23 SoftUpperLim 10.000000 -a23 Fixed -1.000000 -a23 sign 1.000000 -a23 InterruptMode 0.000000 -a23 AccessCode 2.000000 -# Motor a22 -a22 SoftZero 0.000000 -a22 SoftLowerLim -9.500000 -a22 SoftUpperLim 10.000000 -a22 Fixed -1.000000 -a22 sign 1.000000 -a22 InterruptMode 0.000000 -a22 AccessCode 2.000000 -# Motor b1 -b1 SoftZero 0.000000 -b1 SoftLowerLim -160.000000 -b1 SoftUpperLim 160.000000 -b1 Fixed -1.000000 -b1 sign 1.000000 -b1 InterruptMode 0.000000 -b1 AccessCode 2.000000 -# Motor a16 -a16 SoftZero 0.000000 -a16 SoftLowerLim 0.000000 -a16 SoftUpperLim 10.000000 -a16 Fixed -1.000000 -a16 sign 1.000000 -a16 InterruptMode 0.000000 -a16 AccessCode 2.000000 -# Motor a15 -a15 SoftZero 0.000000 -a15 SoftLowerLim -3.000000 -a15 SoftUpperLim 6.000000 -a15 Fixed -1.000000 -a15 sign 1.000000 -a15 InterruptMode 0.000000 -a15 AccessCode 2.000000 -# Motor a14 -a14 SoftZero 0.000000 -a14 SoftLowerLim -5.500000 -a14 SoftUpperLim 3.000000 -a14 Fixed -1.000000 -a14 sign 1.000000 -a14 InterruptMode 0.000000 -a14 AccessCode 2.000000 -# Motor a13 -a13 SoftZero 0.000000 -a13 SoftLowerLim -10.000000 -a13 SoftUpperLim 9.500000 -a13 Fixed -1.000000 -a13 sign 1.000000 -a13 InterruptMode 0.000000 -a13 AccessCode 2.000000 -# Motor a12 -a12 SoftZero 0.000000 -a12 SoftLowerLim -10.000000 -a12 SoftUpperLim 10.000000 -a12 Fixed -1.000000 -a12 sign 1.000000 -a12 InterruptMode 0.000000 -a12 AccessCode 2.000000 +# Motor a2 +a2 SoftZero -0.010000 +a2 SoftLowerLim 33.109997 +a2 SoftUpperLim 120.010002 +a2 Fixed -1.000000 +a2 sign 1.000000 +a2 InterruptMode 0.000000 +a2 AccessCode 2.000000 # Motor a1 -a1 SoftZero 0.000000 -a1 SoftLowerLim 120.000000 -a1 SoftUpperLim 15.000000 +a1 SoftZero 0.590000 +a1 SoftLowerLim -0.590000 +a1 SoftUpperLim 110.410004 a1 Fixed -1.000000 a1 sign 1.000000 a1 InterruptMode 0.000000 a1 AccessCode 2.000000 -# Motor cex2 -cex2 SoftZero 0.000000 -cex2 SoftLowerLim -400.000000 -cex2 SoftUpperLim 400.000000 -cex2 Fixed -1.000000 -cex2 sign 1.000000 -cex2 InterruptMode 0.000000 -cex2 AccessCode 2.000000 -# Motor cex1 -cex1 SoftZero 0.000000 -cex1 SoftLowerLim -400.000000 -cex1 SoftUpperLim 400.000000 -cex1 Fixed -1.000000 -cex1 sign 1.000000 -cex1 InterruptMode 0.000000 -cex1 AccessCode 2.000000 -# Motor dg3 -dg3 SoftZero 0.000000 -dg3 SoftLowerLim -10.000000 -dg3 SoftUpperLim 39.500000 -dg3 Fixed -1.000000 -dg3 sign 1.000000 -dg3 InterruptMode 0.000000 -dg3 AccessCode 2.000000 -# Motor dg2 -dg2 SoftZero 0.000000 -dg2 SoftLowerLim -10.000000 -dg2 SoftUpperLim 39.500000 -dg2 Fixed -1.000000 -dg2 sign 1.000000 -dg2 InterruptMode 0.000000 -dg2 AccessCode 2.000000 -# Motor dg1 -dg1 SoftZero 0.000000 -dg1 SoftLowerLim -10.000000 -dg1 SoftUpperLim 39.500000 -dg1 Fixed -1.000000 -dg1 sign 1.000000 -dg1 InterruptMode 0.000000 -dg1 AccessCode 2.000000 -# Motor sph -sph SoftZero 0.000000 -sph SoftLowerLim 318.000000 -sph SoftUpperLim 0.000000 -sph Fixed -1.000000 -sph sign 1.000000 -sph InterruptMode 0.000000 -sph AccessCode 2.000000 -# Motor sch -sch SoftZero 0.000000 -sch SoftLowerLim 270.000000 -sch SoftUpperLim 70.000000 -sch Fixed -1.000000 -sch sign 1.000000 -sch InterruptMode 0.000000 -sch AccessCode 2.000000 -# Motor stt -stt SoftZero 0.000000 -stt SoftLowerLim -17.000000 -stt SoftUpperLim 69.000000 -stt Fixed -1.000000 -stt sign 1.000000 -stt InterruptMode 0.000000 -stt AccessCode 2.000000 -# Motor som -som SoftZero 0.000000 -som SoftLowerLim -9.000000 -som SoftUpperLim 33.000000 -som Fixed -1.000000 -som sign 1.000000 -som InterruptMode 0.000000 -som AccessCode 2.000000 -# Motor mexz -mexz SoftZero 0.000000 -mexz SoftLowerLim 0.000000 -mexz SoftUpperLim 555.000000 -mexz Fixed -1.000000 -mexz sign 1.000000 -mexz InterruptMode 0.000000 -mexz AccessCode 2.000000 -# Motor mcvl -mcvl SoftZero 0.000000 -mcvl SoftLowerLim 0.000000 -mcvl SoftUpperLim 10.000000 -mcvl Fixed -1.000000 -mcvl sign 1.000000 -mcvl InterruptMode 0.000000 -mcvl AccessCode 2.000000 -# Motor mgpl -mgpl SoftZero 0.000000 -mgpl SoftLowerLim -3.000000 -mgpl SoftUpperLim 5.500000 -mgpl Fixed -1.000000 -mgpl sign 1.000000 -mgpl InterruptMode 0.000000 -mgpl AccessCode 2.000000 -# Motor mgvl -mgvl SoftZero 0.000000 -mgvl SoftLowerLim -6.000000 -mgvl SoftUpperLim 3.000000 -mgvl Fixed -1.000000 -mgvl sign 1.000000 -mgvl InterruptMode 0.000000 -mgvl AccessCode 2.000000 -# Motor mtpl -mtpl SoftZero 0.000000 -mtpl SoftLowerLim -10.000000 -mtpl SoftUpperLim 10.000000 -mtpl Fixed -1.000000 -mtpl sign 1.000000 -mtpl InterruptMode 0.000000 -mtpl AccessCode 2.000000 -# Motor mtvl -mtvl SoftZero 0.000000 -mtvl SoftLowerLim -9.500000 -mtvl SoftUpperLim 10.000000 -mtvl Fixed -1.000000 -mtvl sign 1.000000 -mtvl InterruptMode 0.000000 -mtvl AccessCode 2.000000 -# Motor moml -moml SoftZero 0.000000 -moml SoftLowerLim -160.000000 -moml SoftUpperLim 160.000000 -moml Fixed -1.000000 -moml sign 1.000000 -moml InterruptMode 0.000000 -moml AccessCode 2.000000 -# Motor mcvu -mcvu SoftZero 0.000000 -mcvu SoftLowerLim 0.000000 -mcvu SoftUpperLim 10.000000 -mcvu Fixed -1.000000 -mcvu sign 1.000000 -mcvu InterruptMode 0.000000 -mcvu AccessCode 2.000000 -# Motor mgpu -mgpu SoftZero 0.000000 -mgpu SoftLowerLim -3.000000 -mgpu SoftUpperLim 6.000000 -mgpu Fixed -1.000000 -mgpu sign 1.000000 -mgpu InterruptMode 0.000000 -mgpu AccessCode 2.000000 -# Motor mgvu -mgvu SoftZero 0.000000 -mgvu SoftLowerLim -5.500000 -mgvu SoftUpperLim 3.000000 -mgvu Fixed -1.000000 -mgvu sign 1.000000 -mgvu InterruptMode 0.000000 -mgvu AccessCode 2.000000 -# Motor mtpu -mtpu SoftZero 0.000000 -mtpu SoftLowerLim -10.000000 -mtpu SoftUpperLim 9.500000 -mtpu Fixed -1.000000 -mtpu sign 1.000000 -mtpu InterruptMode 0.000000 -mtpu AccessCode 2.000000 -# Motor mtvu -mtvu SoftZero 0.000000 -mtvu SoftLowerLim -10.000000 -mtvu SoftUpperLim 10.000000 -mtvu Fixed -1.000000 -mtvu sign 1.000000 -mtvu InterruptMode 0.000000 -mtvu AccessCode 2.000000 -# Motor momu -momu SoftZero 0.000000 -momu SoftLowerLim 120.000000 -momu SoftUpperLim 15.000000 -momu Fixed -1.000000 -momu sign 1.000000 -momu InterruptMode 0.000000 -momu AccessCode 2.000000 -lambda 0.000000 -lambda setAccess 1 -monochromator UNKNOWN -monochromator setAccess 2 -distance 0.000000 -distance setAccess 2 -user Daniel_the_Clementine -user setAccess 2 -sample DanielOxid -sample setAccess 2 -title TopsiTupsiTapsi -title setAccess 2 diff --git a/sicsstatus.tcl b/sicsstatus.tcl index 74743b0c..ee55cf18 100644 --- a/sicsstatus.tcl +++ b/sicsstatus.tcl @@ -11,6 +11,12 @@ hm genbin 120.000000 35.000000 512 hm init datafile focus-1001848.hdf datafile setAccess 3 +hm3 CountMode timer +hm3 preset 100.000000 +hm2 CountMode timer +hm2 preset 100.000000 +hm1 CountMode timer +hm1 preset 100.000000 dbfile UNKNOWN dbfile setAccess 2 # Motor th @@ -23,7 +29,7 @@ th InterruptMode 0.000000 th AccessCode 2.000000 #Crystallographic Settings hkl lambda 1.179000 -hkl setub -0.019370 0.077484 -0.004944 0.077493 0.019386 0.002155 0.001034 -0.001344 -0.254040 +hkl setub 0.087418 -0.158308 0.006979 0.158247 0.087630 0.005560 -0.008243 0.003417 0.180755 det1dist 300. det1dist setAccess 1 det1zeroy 128. @@ -60,7 +66,7 @@ ch InterruptMode 0.000000 ch AccessCode 2.000000 # Motor ph ph SoftZero 0.000000 -ph SoftLowerLim 0.000000 +ph SoftLowerLim -360.000000 ph SoftUpperLim 360.000000 ph Fixed -1.000000 ph sign 1.000000 @@ -84,7 +90,7 @@ muca InterruptMode 0.000000 muca AccessCode 2.000000 # Motor phi phi SoftZero 0.000000 -phi SoftLowerLim 0.000000 +phi SoftLowerLim -360.000000 phi SoftUpperLim 360.000000 phi Fixed -1.000000 phi sign 1.000000 @@ -117,7 +123,7 @@ twotheta AccessCode 2.000000 lastscancommand UNKNOWN lastscancommand setAccess 2 banana CountMode timer -banana preset 10.000000 +banana preset 100.000000 sample_mur 0.000000 sample_mur setAccess 2 email UNKNOWN @@ -129,11 +135,11 @@ phone setAccess 2 adress UNKNOWN adress setAccess 2 # Counter counter -counter SetPreset 10.000000 +counter SetPreset 1.000000 counter SetMode Timer # Motor som som SoftZero 0.000000 -som SoftLowerLim 0.000000 +som SoftLowerLim -360.000000 som SoftUpperLim 360.000000 som Fixed -1.000000 som sign 1.000000 @@ -236,9 +242,9 @@ d1l sign 1.000000 d1l InterruptMode 0.000000 d1l AccessCode 2.000000 # Motor d1r -d1r SoftZero 2.000000 -d1r SoftLowerLim -22.000000 -d1r SoftUpperLim 18.000000 +d1r SoftZero 0.000000 +d1r SoftLowerLim -20.000000 +d1r SoftUpperLim 20.000000 d1r Fixed -1.000000 d1r sign 1.000000 d1r InterruptMode 0.000000 @@ -316,9 +322,9 @@ mgu sign 1.000000 mgu InterruptMode 0.000000 mgu AccessCode 2.000000 # Motor stu -stu SoftZero -10.000000 -stu SoftLowerLim -20.000000 -stu SoftUpperLim 40.000000 +stu SoftZero 0.000000 +stu SoftLowerLim -30.000000 +stu SoftUpperLim 30.000000 stu Fixed -1.000000 stu sign 1.000000 stu InterruptMode 0.000000 @@ -373,7 +379,7 @@ a4 InterruptMode 0.000000 a4 AccessCode 2.000000 # Motor a3 a3 SoftZero 0.000000 -a3 SoftLowerLim 0.000000 +a3 SoftLowerLim -360.000000 a3 SoftUpperLim 360.000000 a3 Fixed -1.000000 a3 sign 1.000000 @@ -397,9 +403,9 @@ a1 InterruptMode 0.000000 a1 AccessCode 2.000000 user Daniel_the_Clementine user setAccess 2 -sample shit at 10.000000 +sample DanielOxid sample setAccess 2 title TopsiTupsiTapsi title setAccess 2 -starttime 2000-08-22 15:23:15 +starttime UNKNOWN starttime setAccess 2 diff --git a/t_conv.c b/t_conv.c new file mode 100644 index 00000000..f68a636f --- /dev/null +++ b/t_conv.c @@ -0,0 +1,830 @@ +/* t_conv.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 { + integer icrm, icra, iclm; + real cm1rx, cm2rx, ca1rx, ca2rx, rmmin, rmmax, ramin, ramax; + integer inx; + logical at_sinq__; +} curve_; + +#define curve_1 curve_ + +/* Table of constant values */ + +static integer c__0 = 0; +static integer c__1 = 1; +static doublereal c_b10 = 1.; +static doublereal c_b12 = 360.; + +/* ------------------------------------------------------------------------ */ +/* slightly edited version for inclusion into SICS */ + +/* Mark Koennecke, November 2000 */ +/* ------------------------------------------------------------------------- */ +/* Subroutine */ int inicurve_(integer *midx, real *mrx1, real *mrx2, integer + *aidx, real *arx1, real *arx2, real *mmin, real *mmax, real *amin, + real *amax) +{ + +/* Initializes a common with the curvature parameters. */ +/* In: monochrmoator curvatuure motor index and parameters */ +/* In: analyzer curvature motor index + parameters */ + curve_1.icrm = *midx; + curve_1.icra = *aidx; + curve_1.cm1rx = *mrx1; + curve_1.cm2rx = *mrx2; + curve_1.ca1rx = *arx1; + curve_1.ca2rx = *arx2; + curve_1.rmmin = *mmin; + curve_1.rmmax = *mmax; + curve_1.ramin = *amin; + curve_1.ramax = *amax; + curve_1.inx = 0; + curve_1.at_sinq__ = TRUE_; + curve_1.iclm = 0; + return 0; +} /* inicurve_ */ + +/* -------------------------------------------------------------------------- */ +/* Subroutine */ int t_conv__(real *ei, real *aki, real *ef, real *akf, real * + qhkl, real *en, real *hx, real *hy, real *hz, integer *if1, integer * + if2, logical *ldk, logical *ldh, logical *ldf, logical *lpa, real *dm, + real *da, real *helm, real *f1h, real *f1v, real *f2h, real *f2v, + real *f, integer *ifx, integer *iss, integer *ism, integer *isa, real + *t_a__, real *t_rm__, real *t_alm__, real *t_ra__, real *qm, logical * + ldra, logical *ldr_rm__, logical *ldr_alm__, logical *ldr_ra__, real * + p_ih__, real *c_ih__, integer *ier) +{ + /* System generated locals */ + doublereal d__1; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static doublereal edef[2], dakf, daki; + static integer imod; + extern /* Subroutine */ int sam_case__(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *); + static integer i__; + static doublereal akdef[2]; + extern /* Subroutine */ int helm_case__(real *, real *, real *, real *, + real *, real *, real *, doublereal *, real *, real *, integer *); + static doublereal dqhkl[3]; + extern /* Subroutine */ int flip_case__(integer *, integer *, real *, + real *, real *, real *, real *, real *, real *, integer *); + static logical lmoan[2]; + static doublereal a1, a2, a3, a4, a5, a6; + static integer id; + static doublereal ra; + extern /* Subroutine */ int rl2spv_(doublereal *, doublereal *, + doublereal *, doublereal *, integer *); + static integer iq; + static doublereal rm; + static logical lqhkle; + extern /* Subroutine */ int erreso_(integer *, integer *); + static doublereal dda, ala, def, dei, ddm, alm, dqm, dqs, dqt[3]; + extern /* Subroutine */ int ex_case__(doublereal *, integer *, doublereal + *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, integer *); + +/* ================= */ + +/* dec$ ident 'V01D' */ +/* ----------------------------------------------------------------------- */ +/* Other routines in this file: */ + +/* SUBROUTINE EX_CASE (DX,ISX,AKX,AX1,AX2,RX,ALX,IER) */ +/* SUBROUTINE SAM_CASE (QT,QM,QS,AKI,AKF,AX3,AX4,ISS,IER) */ +/* SUBROUTINE HELM_CASE (HX,HY,HZ,P_IH,AKI,AKF,A4,QM,HELM,IER) */ +/* SUBROUTINE FLIP_CASE (IF1,IF2,P_IH,F1V,F1H,F2V,F2H,AKI,AKF,IER) */ +/* ----------------------------------------------------------------------- */ +/* INPUTS */ +/* EI,AKI,EF,AKF,QHKL,EN,HX,HY,HZ : POTENTIAL TARGETS */ +/* IF1,IF2 Status of flippers On (1) Off (0) */ +/* LDK(8) LOGICAL INDICATING IF (ENERGY,K OR Q) ARE DRIVEN */ +/* LDH,LDF LOGICAL INDICATING IF (HX,HY,HZ) OR (F1,F2) ARE DRIVEN */ + +/* configuration of the machine */ + +/* LPA LOGICAL TRUE IF MACHINE IN POLARIZATION MODE */ +/* DM,DA,HELM,F1H,F1V,F2H,F2V,F,IFX,ISS,ISM,ISA,QM (F ENERGY UNIT) */ + +/* OUTPUTs */ +/* T_A TARGETS OF ANGLES A1-A6 */ +/* T_RM,T_ALM TARGETS OF RM ,LM */ +/* T_RA TARGET OF RA */ +/* QM TARGETS OF QM */ +/* LDRA LOGICAL INDICATING WHICH ANGLES ARE TO BE DRIVEN */ +/* LDR_RM LOGICAL INDICATING IF RM (mono curve) IS TO BE DRIVEN */ +/* LDR_ALM LOGICAL INDICATING IF ALM (mono transl) IS TO BE DRIVEN */ +/* LDR_RA LOGICAL INDICATING IF RA (anal curve) IS TO BE DRIVEN */ +/* P_IH TARGETS OF CURRENTS FOR FLIPPERS AND HELMOTZ (8 CURRENTS) */ +/* C_IH CONVERSION FACTORS FOR HELMOTZ (4 CURRENTS) */ + +/* SPECIAL OUTPUTS */ +/* TARGET OF EI(EF) IS UPDATED IS KI(KF) IS DRIVEN */ +/* TARGET OF VARIABLE ENERGY IS UPDATED IF EN IS DRIVEN */ +/* ----------------------------------------------------------------------- */ +/* File [MAD.SRC]T_CONV.FOR */ + + +/* include 'curve.inc' */ +/* ----------------------------------------------------------------------- */ +/* Define the dummy arguments */ + +/* ----------------------------------------------------------------------- */ +/* LOCAL VARIABLES */ + + +/* ----------------------------------------------------------------------- */ +/* SET UP */ +/* IMOD INDEX FOR ERROR TREATMENAT BY ERRESO */ +/* LDQHKLE : LOGICAL INDICATING THAT WE ARE DEALING WITH A MOVE */ +/* IN RECIPROCICAL SPACE */ +/* WE REMAP THE ENERGY PB AS FIXED ENERGY IN EDEF(1) */ +/* AND VARIABLE ENERGY IN EDEF(2) */ +/* IF ISA IS NUL SET IFX TO 1 AND PUT EF,KF, EQUAL TO EI,KI */ + + /* Parameter adjustments */ + --c_ih__; + --p_ih__; + --ldra; + --t_a__; + --ldk; + --qhkl; + + /* Function Body */ + imod = 3; + ddm = *dm; + dda = *da; + for (i__ = 1; i__ <= 2; ++i__) { + lmoan[i__ - 1] = FALSE_; + } + lqhkle = FALSE_; + for (iq = 5; iq <= 8; ++iq) { + lqhkle = lqhkle || ldk[iq]; + } + daki = *aki; + dakf = *akf; + if (*isa == 0) { + *ifx = 1; + } + edef[*ifx - 1] = *ei; + akdef[*ifx - 1] = *aki; + edef[3 - *ifx - 1] = *ef; + akdef[3 - *ifx - 1] = *akf; + if (*isa == 0) { + edef[1] = edef[0]; + akdef[1] = akdef[0]; + ldk[3] = TRUE_; + ldk[4] = TRUE_; + t_a__[5] = 0.f; + t_a__[6] = 0.f; + ldra[5] = TRUE_; + ldra[6] = TRUE_; + } +/* ----------------------------------------------------------------------- */ +/* FIRST TAKE IN ACCOUNT THE FIXED ENERGY PB */ + + if (ldk[(*ifx << 1) - 1] || ldk[*ifx * 2]) { + lmoan[*ifx - 1] = TRUE_; + if (ldk[(*ifx << 1) - 1]) { + *ier = 1; + if (edef[0] < .1f) { + goto L999; + } + *ier = 0; + akdef[0] = sqrt(edef[0] / *f); + } else { + *ier = 1; + if (akdef[0] < .1f) { + goto L999; + } + *ier = 0; +/* Computing 2nd power */ + d__1 = akdef[0]; + edef[0] = *f * (d__1 * d__1); + } + } +/* ----------------------------------------------------------------------- */ +/* NOW TAKE IN ACCOUNT THE VARIABLE ENERGY PB */ +/* VARIABLE ENERGUY IS DRIVEN EITHER EXPLICITLY */ +/* E.G. BY DRIVING EI OR KI WITH IFX=2 */ +/* ( AND WE MUST CALCULATE EN FROM EVAR) */ +/* THE RULE IS : EI=EF+EN : EN IS THE ENERGY LOSS OF NEUTRONS */ +/* OR ENERGY GAIN OF SAMPLE */ +/* OR IMPLICITLY BY DRIVING THE TRANSFERED ENERGY EN */ +/* ( AND WE MUST CALCULATE EVAR FROM EN) */ +/* IF KI IS CONSTANT USE THE CURRENT VALUE CONTAINED IN POSN ARRAY */ +/* TO CALCULATE THE NON-"CONSTANT" K. */ +/* IF KF IS CONSTANT USE ALWAYS THE VALUE IN TARGET AND */ +/* DO A DRIVE OF KF TO KEEP A5/A6 IN RIGHT POSITION */ + + if (ldk[5 - (*ifx << 1)] || ldk[6 - (*ifx << 1)]) { + lmoan[3 - *ifx - 1] = TRUE_; + if (ldk[5 - (*ifx << 1)]) { + *ier = 1; + if (edef[1] < 1e-4f) { + goto L999; + } + *ier = 0; + akdef[1] = sqrt(edef[1] / *f); + } else { + *ier = 1; + if (akdef[1] < 1e-4f) { + goto L999; + } + *ier = 0; +/* Computing 2nd power */ + d__1 = akdef[1]; + edef[1] = *f * (d__1 * d__1); + } + *en = (3 - (*ifx << 1)) * (edef[0] - edef[1]); + } else if (lqhkle) { + lmoan[3 - *ifx - 1] = TRUE_; + edef[1] = edef[0] + ((*ifx << 1) - 3) * *en; + *ier = 1; + if (edef[1] < 1e-4f) { + goto L999; + } + *ier = 0; + akdef[1] = sqrt(edef[1] / *f); + } +/* ----------------------------------------------------------------------- */ +/* CALCULATE MONOCHROMATOR AND ANALYSER ANGLES */ + + if (lmoan[0]) { + dei = edef[*ifx - 1]; + daki = akdef[*ifx - 1]; + ex_case__(&ddm, ism, &daki, &a1, &a2, &rm, &alm, &c__0, ier); + if (*ier == 0) { + *aki = daki; + *ei = dei; + t_a__[1] = a1; + t_a__[2] = a2; + ldra[1] = TRUE_; + ldra[2] = TRUE_; + if (curve_1.icrm != 0) { + *t_rm__ = rm; + *ldr_rm__ = TRUE_; + } + if (curve_1.iclm != 0 && curve_1.inx != 0) { + *t_alm__ = alm; + *ldr_alm__ = TRUE_; + } + } else { + goto L999; + } + } + if (lmoan[1]) { + def = edef[3 - *ifx - 1]; + dakf = akdef[3 - *ifx - 1]; + ex_case__(&dda, isa, &dakf, &a5, &a6, &ra, &ala, &c__1, ier); + if (*ier == 0) { + *akf = dakf; + *ef = def; + t_a__[5] = a5; + t_a__[6] = a6; + ldra[5] = TRUE_; + ldra[6] = TRUE_; + if (curve_1.icra != 0) { + *t_ra__ = ra; + *ldr_ra__ = TRUE_; + } + } else { + goto L999; + } + } +/* ----------------------------------------------------------------------- */ +/* USE (QH,QK,QL) TO CALCULATE A3 AND A4 */ +/* CALCULATE Q1 AND Q2 IN SCATTERING PLANE */ + + imod = 2; + if (lqhkle) { + for (id = 1; id <= 3; ++id) { + dqhkl[id - 1] = qhkl[id]; + } + rl2spv_(dqhkl, dqt, &dqm, &dqs, ier); + if (*ier != 0) { + goto L999; + } + sam_case__(dqt, &dqm, &dqs, &daki, &dakf, &a3, &a4, iss, ier); + if (*ier == 0) { + t_a__[3] = a3; + t_a__[4] = a4; + ldra[3] = TRUE_; + ldra[4] = TRUE_; + *qm = dqm; + } else { + goto L999; + } + } +/* ----------------------------------------------------------------------- */ +/* DEAL WITH FLIPPERS AND HELMOTZ COILS IF LPA */ + + if (*lpa && (lmoan[0] || lmoan[1])) { + if (*ldf) { + flip_case__(if1, if2, &p_ih__[1], f1v, f1h, f2v, f2h, aki, akf, + ier); + } + if (*ldh) { + helm_case__(hx, hy, hz, &p_ih__[1], &c_ih__[1], aki, akf, &a4, qm, + helm, ier); + } + } +/* ----------------------------------------------------------------------- */ +L999: + if (*ier != 0) { + erreso_(&imod, ier); + } + return 0; +} /* t_conv__ */ + + +/* Subroutine */ int ex_case__(doublereal *dx, integer *isx, doublereal *akx, + doublereal *ax1, doublereal *ax2, doublereal *rx, doublereal *alx, + integer *mon_or_anal__, integer *ier) +{ + /* System generated locals */ + doublereal d__1; + + /* Builtin functions */ + double asin(doublereal), sin(doublereal), cos(doublereal), sqrt( + doublereal); + + /* Local variables */ + static integer indx; + static doublereal dcl1r, dc1rx, dc2rx, drmin, drmax, my_rx__, arg; + +/* ================== */ + +/* CALCULATE ANGLES ON MONO/ANALYSER */ +/* CALCULATE AX1 AX2 */ +/* CALCULATE RX = MONO OR ANAL CURVATURE AND LM = MONO POSIT FOR IN8 */ + +/* INPUTS */ +/* DX D-SPACINGS */ +/* ISX SENS OF SCATTERING ON CRYSTAL. If =0, this is probably */ +/* a 3-axis instr. in simulated 2-axis mode and the */ +/* calculation is for the scattering at the analyser. */ +/* In this case, we set AX1 = AX2 = 0 which gives a */ +/* "straight-through" setting of A5 & A6 (because of */ +/* a simultaneous 90 degree zero offset for A5 -- this */ +/* is a bit of a hack, if you ask me!). */ +/* AKX TARGET OF MOMENTUM */ +/* MON_OR_ANAL =0 if calculation is for mono. */ +/* =1 if calculation is for anal. */ +/* OUTPUTS */ +/* AX1 AX2 THETA 2*THETA ANGLES */ +/* RX MONO OR ANALYSER CURVATURE */ +/* ALX SPECIAL TRANSLATION FOR IN8 */ +/* IER */ +/* 1 'KI OR KF CANNOT BE OBTAINED CHECK D-SPACINGS', */ +/* 2 'KI OR KF TOO SMALL', */ +/* 3 'KI OR KF TOO BIG', */ +/* ----------------------------------------------------------------------- */ +/* Part of T_CONV.FOR */ + +/* ----------------------------------------------------------------------- */ +/* Define the dummy arguments */ +/* ----------------------------------------------------------------------- */ +/* include 'curve.inc' */ +/* include 'motdef.inc' */ +/* include 'iolsddef.inc' */ + +/* real*4 tbut(5,NBMOT) */ +/* equivalence (rbut, tbut) */ +/* ----------------------------------------------------------------------- */ +/* LOCAL VAR */ + +/* ----------------------------------------------------------------------- */ +/* INIT AND TEST */ + + *ier = 0; + *ax1 = 0.f; + *ax2 = 0.f; + *rx = 0.f; + *alx = 0.f; +/* ---------------------------------------------------------------------- */ +/* Check validity of inputs. */ + if (*dx < .1) { + *ier = 1; + } + if (*akx < .1) { + *ier = 2; + } + arg = 3.1415926535897932384626433832795 / (*dx * *akx); + if (abs(arg) > 1.f) { + *ier = 3; + } + if (*ier != 0) { + goto L999; + } +/* ---------------------------------------------------------------------- */ + if (*mon_or_anal__ == 0) { +/* Use monochr or anal params? */ + indx = curve_1.icrm; +/* Monochr, so set up params. */ + dc1rx = curve_1.cm1rx; + dc2rx = curve_1.cm2rx; + dcl1r = (doublereal) curve_1.iclm; + drmin = curve_1.rmmin; + drmax = curve_1.rmmax; + } else { + indx = curve_1.icra; +/* Analyser, so set up params. */ + dc1rx = curve_1.ca1rx; +/* There is no ALX in this case. */ + dc2rx = curve_1.ca2rx; + drmin = curve_1.ramin; + drmax = curve_1.ramax; + } + +/* if (indx .ne. 0) then ! Include zero-offset in min/max */ +/* drmin = drmin + tbut(3,indx) */ +/* drmax = drmax + tbut(3,indx) */ +/* if (drmin .lt. tbut(1,indx)) drmin = tbut(1,indx) */ +/* if (drmax .gt. tbut(2,indx)) drmax = tbut(2,indx) */ +/* endif */ +/* ----------------------------------------------------------------------- */ +/* Calculation of the two angles */ + + if (*isx == 0) { +/* "Straight-through" mode? */ + *ax1 = 0.f; +/* Yes. */ + *ax2 = 0.f; + *rx = drmin; + *alx = 0.f; + return 0; + } + + *ax1 = asin(arg) * *isx * 57.29577951308232087679815481410517; + *ax2 = *ax1 * 2.; +/* ----------------------------------------------------------------------- */ +/* Calculation of mono curvature RM or analyser curvature RA */ +/* Standard law is: */ + +/* For monochr: */ +/* CM1RX + CM2RX/SIN(abs(A1)/RD) */ + +/* For analyser: */ +/* CA1RX + CA2RX*SIN(abs(A5)/RD) */ + +/* CM1RX/CM2RX/CA1RX/CA2RX are parameters depending on monochr/analyser and */ +/* instrument. They are read from CURVE.INI in routine SETUP_MOT_CURVE. */ +/* e.g. cm1rx = .47 */ +/* cm2rx = .244 */ +/* rmmin = 0. */ +/* rmmax = 20. */ +/* ----------------------------------------------------------------------- */ + if (*mon_or_anal__ == 0) { +/* Monochr or analyser? */ + if (curve_1.inx != 0) { +/* Monochr. Is there a translation? */ + if (curve_1.iclm != 0) { +/* Yes, IN8 case. If there's a .. */ + *alx = dcl1r / sin(*ax2 / 57.29577951308232087679815481410517) + * cos(*ax2 / 57.29577951308232087679815481410517); +/* .. motor, do the .. */ + *rx = dc2rx * sqrt(sin(abs(*ax2) / + 57.29577951308232087679815481410517)) - dc1rx; +/* .. calculation. */ +/* Computing MIN */ + d__1 = max(*rx,drmin); + *rx = min(d__1,drmax); + return 0; + } + } else { +/* Not IN8 case so, .. */ + my_rx__ = dc1rx + dc2rx / sin(abs(*ax1) / + 57.29577951308232087679815481410517); +/* .. simply calculate. */ + } + } else { +/* Analyser. */ + my_rx__ = dc1rx + dc2rx * sin(abs(*ax1) / + 57.29577951308232087679815481410517); +/* Simply calculate. */ + } + + if (indx != 0) { +/* If there's a motor, return the curvature. */ +/* Computing MIN */ + d__1 = max(my_rx__,drmin); + *rx = min(d__1,drmax); +/* if (rx .ne. my_rx) then */ +/* write (iolun, 101, iostat=ios) motnam(indx), my_rx */ +/* 101 format (' Warning -- ', a8, 'curvature restricted by low ', */ +/* + 'or high limits!'/ */ +/* + ' Calculated curvature was', f9.2) */ +/* endif */ + } +/* ----------------------------------------------------------------------- */ +L999: + return 0; +} /* ex_case__ */ + + +/* Subroutine */ int sam_case__(doublereal *qt, doublereal *qm, doublereal * + qs, doublereal *aki, doublereal *akf, doublereal *ax3, doublereal * + ax4, integer *iss, integer *ier) +{ + /* System generated locals */ + doublereal d__1, d__2; + + /* Builtin functions */ + double acos(doublereal), atan2(doublereal, doublereal), d_sign(doublereal + *, doublereal *), d_mod(doublereal *, doublereal *); + + /* Local variables */ + static doublereal arg, sax3; + +/* =================== */ + +/* DEAL WITH SAMPLE ANGLES CALCULATION FROM Q VECTOR IN C-N PLANE */ +/* CALCULATE A3 AND A4 */ +/* INPUTS */ +/* QT Q-VECTOR IN SCATTERING PLANE */ +/* QM,QS Q MODULUS AND QMODULUS SQUARED */ +/* AKI,AKF MOMEMTA ON MONO AND ANYLSER */ +/* ISS SENS OF SCATTERING ON SAMPLE */ + +/* OUTPUTS */ +/* AX3 AX4 ANGLES ON SAMPLES */ +/* IER SAME ERROR AS RL2SPV */ +/* IER */ +/* 1 'MATRIX S NOT OK', */ +/* 2 'Q NOT IN SCATTERING PLANE', */ +/* 3 'Q MODULUS TOO SMALL', */ +/* 4 'Q MODULUS TOO BIG', */ +/* ----------------------------------------------------------------------- */ +/* Part of T_CONV.FOR */ + +/* ----------------------------------------------------------------------- */ +/* Define the dummy arguments */ +/* ----------------------------------------------------------------------- */ +/* Local variables */ +/* ----------------------------------------------------------------------- */ +/* INIT AND TEST */ + + /* Parameter adjustments */ + --qt; + + /* Function Body */ + *ier = 0; + if (abs(*qs) < 1e-6 || abs(*qm) < .001) { + *ier = 3; + goto L999; + } +/* ----------------------------------------------------------------------- */ +/* CALCULATE A3 AND MOVE IT INTHE -180 ,+180 INTERVAL */ + +/* Computing 2nd power */ + d__1 = *aki; +/* Computing 2nd power */ + d__2 = *akf; + arg = (d__1 * d__1 + d__2 * d__2 - *qs) / (*aki * 2. * *akf); + if (abs(arg) > 1.) { + *ier = 4; + goto L999; + } else { + *ax4 = acos(arg) * *iss * 57.29577951308232087679815481410517; + } +/* Computing 2nd power */ + d__1 = *akf; +/* Computing 2nd power */ + d__2 = *aki; + *ax3 = (-atan2(qt[2], qt[1]) - acos((d__1 * d__1 - *qs - d__2 * d__2) / (* + qm * -2. * *aki)) * d_sign(&c_b10, ax4)) * + 57.29577951308232087679815481410517; + sax3 = d_sign(&c_b10, ax3); + d__1 = *ax3 + sax3 * 180.; + *ax3 = d_mod(&d__1, &c_b12) - sax3 * 180.; + +/* IF(LPLATE) AX3 = -ATAN(SIN(AX4/RD)/(LSA*TAN(AX5/RD)/(ALMS*C */ +/* 1 TAN(AX1/RD))*(AKI/KF)**2-COS(AX4/RD)))*RD !PLATE FOCALIZATION OPTION */ +/* IF(AXX3 .GT. 180.D0) AX3 = AX3-360.D0 */ +/* IF( A3 .LT. -180.D0) AX3 = AX3+360.D0 */ +/* IF(LPLATE .AND. (A3 .GT. 0.0)) AX3 = AX3-180 */ +/* C----------------------------------------------------------------------- */ +L999: + return 0; +} /* sam_case__ */ + + +/* Subroutine */ int helm_case__(real *hx, real *hy, real *hz, real *t_ih__, + real *c_ih__, real *aki, real *akf, doublereal *a4, real *qm, real * + helm, integer *ier) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Builtin functions */ + double cos(doublereal), sin(doublereal), atan2(doublereal, doublereal), + sqrt(doublereal); + + /* Local variables */ + static doublereal hrad, hdir, qpar, hdir2; + static integer ncoef; + static doublereal qperp; + static integer ic; + static doublereal phi; + static logical at_sinq__; + +/* ==================== */ + +/* DEAL WITH HELMOTZ COIL FIELD CALCULATIONS */ +/* CALCULATE HX HY HZ */ +/* ----------------------------------------------------------------------- */ +/* At ILL: */ +/* There are 3 coils for Hx/Hy at 120 degrees to each other. */ + +/* There is a 4th coil for Hz. */ + +/* At SINQ: */ +/* There is an Hx coil and an Hy coil (actually each is 4 coils powered */ +/* in series). They are mounted on a ring (SRO). The value of HELM is */ +/* the angle between the Hx coil and ki. */ + +/* There is a 3rd coil for Hz. */ +/* ----------------------------------------------------------------------- */ +/* Part of T_CONV.FOR */ + +/* include 'common_sinq.inc' */ + +/* ----------------------------------------------------------------------- */ +/* Define the dummy arguments */ +/* ----------------------------------------------------------------------- */ +/* Local variables */ +/* ----------------------------------------------------------------------- */ +/* INIT AND TEST */ + + /* Parameter adjustments */ + --c_ih__; + --t_ih__; + + /* Function Body */ + at_sinq__ = TRUE_; + ncoef = 4; + if (at_sinq__) { + ncoef = 3; + } + + *ier = 1; + if (dabs(*qm) < 1e-4) { + goto L999; + } + *ier = 0; + i__1 = ncoef; + for (ic = 1; ic <= i__1; ++ic) { + if (c_ih__[ic] < 1e-4) { + *ier = 2; + } + } + if (*ier != 0) { + goto L999; + } +/* ----------------------------------------------------------------------- */ +/* CALCULATE MODULE AND ANGLES OF IN PLANE FIELD H */ +/* PHI ! Angle between Q and KI (in radians) */ +/* HRAD ! Radial comp. of H */ +/* HDIR ! Direction of H relative to PHI (in radians) */ +/* HDIR2 ! Angle between field and axis of Coil 1 (in radians) */ + + qpar = *aki - *akf * cos(*a4 / 57.29577951308232087679815481410517); + qperp = -(*akf) * sin(*a4 / 57.29577951308232087679815481410517); + if (abs(qpar) > .001 && abs(qperp) > .001) { + phi = atan2((abs(qperp)), (abs(qpar))); + if (qpar > 0. && qperp < 0.) { + phi = -phi; + } else if (qpar < 0. && qperp > 0.) { + phi = 3.1415926535897932384626433832795 - phi; + } else if (qpar < 0. && qperp < 0.) { + phi += -3.1415926535897932384626433832795; + } + } else if (abs(qpar) > .001) { + if (qpar >= 0.f) { + phi = 0.f; + } + if (qpar < 0.f) { + phi = 3.1415926535897932384626433832795; + } + } else if (abs(qperp) > .001) { + if (qperp >= 0.f) { + phi = 1.5707963267948966; + } + if (qperp < 0.f) { + phi = -1.5707963267948966; + } + } else { + phi = 0.f; + } + +/* Computing 2nd power */ + r__1 = *hx; +/* Computing 2nd power */ + r__2 = *hy; + hrad = sqrt(r__1 * r__1 + r__2 * r__2); + if (dabs(*hx) > .001 && dabs(*hy) > .001) { + hdir = atan2((dabs(*hy)), (dabs(*hx))); + if (*hx > 0.f && *hy < 0.f) { + hdir = -hdir; + } else if (*hx < 0.f && *hy > 0.f) { + hdir = 3.1415926535897932384626433832795 - hdir; + } else if (*hx < 0.f && *hy < 0.f) { + hdir += -3.1415926535897932384626433832795; + } + } else if (dabs(*hx) > .001) { + if (*hx >= 0.f) { + hdir = 0.f; + } + if (*hx < 0.f) { + hdir = 3.1415926535897932384626433832795; + } + } else if (dabs(*hy) > .001) { + if (*hy >= 0.f) { + hdir = 1.5707963267948966; + } + if (*hy < 0.f) { + hdir = -1.5707963267948966; + } + } else { + hdir = 0.f; + } + + hdir2 = hdir + phi - *helm / 57.29577951308232087679815481410517; +/* ----------------------------------------------------------------------- */ +/* !CALC CURRENTS */ +/* !POSITION OF PSP FOR COIL I */ + + if (! at_sinq__) { + hdir2 += 1.5707963267948966; +/* ??? */ + for (ic = 1; ic <= 3; ++ic) { + t_ih__[ic + 4] = cos(hdir2 + (ic - 1) * 2.f * + 3.1415926535897932384626433832795 / 3.f) * hrad / c_ih__[ + ic] / 1.5f; + } + t_ih__[8] = *hz / c_ih__[4]; + } else { + t_ih__[5] = cos(hdir2) * hrad / c_ih__[1]; + t_ih__[6] = sin(hdir2) * hrad / c_ih__[2]; + t_ih__[7] = *hz / c_ih__[3]; + } +/* ----------------------------------------------------------------------- */ +L999: + return 0; +} /* helm_case__ */ + + +/* Subroutine */ int flip_case__(integer *if1, integer *if2, real *t_ih__, + real *f1v, real *f1h, real *f2v, real *f2h, real *aki, real *akf, + integer *ier) +{ +/* ==================== */ + +/* DEAL WITH FLIPPER COIL CALCULATIONS */ +/* CALCULATE P_IF CURRENTS FOR THE TWO FLIPPERS */ +/* ----------------------------------------------------------------------- */ +/* Define the dummy arguments */ +/* Part of T_CONV.FOR */ +/* ----------------------------------------------------------------------- */ +/* INIT AND TEST */ + + /* Parameter adjustments */ + --t_ih__; + + /* Function Body */ + *ier = 0; +/* ----------------------------------------------------------------------- */ + + if (*if1 == 1) { + t_ih__[1] = *f1v; + t_ih__[2] = *aki * *f1h; + } else { + t_ih__[1] = 0.f; + t_ih__[2] = 0.f; + } + if (*if2 == 1) { + t_ih__[3] = *f2v; + t_ih__[4] = *akf * *f2h; + } else { + t_ih__[3] = 0.f; + t_ih__[4] = 0.f; + } +/* ----------------------------------------------------------------------- */ +/* L999: */ + return 0; +} /* flip_case__ */ + diff --git a/t_conv.f b/t_conv.f new file mode 100755 index 00000000..827a608e --- /dev/null +++ b/t_conv.f @@ -0,0 +1,682 @@ +C------------------------------------------------------------------------ +C slightly edited version for inclusion into SICS +C +C Mark Koennecke, November 2000 +C------------------------------------------------------------------------- + SUBROUTINE INICURVE(MIDX, MRX1, MRX2, AIDX, ARX1, ARX2, + + MMIN, MMAX, AMIN, AMAX) +C +C Initializes a common with the curvature parameters. +C In: monochrmoator curvatuure motor index and parameters +C In: analyzer curvature motor index + parameters + INTEGER MIDX, AIDX + REAL*4 MRX1, MRX2, ARX1, ARX2, MMIN, MMAX, AMIN, AMAX + REAL*4 CM1RX, CM2RX, CA1RX, CA2RX, RMMIN, RMMAX + REAL*4 RAMIN, RAMAX + INTEGER ICRM, ICRA, ICLM, INX + LOGICAL AT_SINQ + COMMON/CURVE/ICRM,ICRA, ICLM, CM1RX, CM2RX, CA1RX, CA2RX, + + RMMIN, RMMAX, RAMIN, RAMAX, INX, AT_SINQ + + ICRM = MIDX + ICRA = AIDX + CM1RX = MRX1 + CM2RX = MRX2 + CA1RX = ARX1 + CA2RX = ARX2 + RMMIN = MMIN + RMMAX = MMAX + RAMIN = AMIN + RAMAX = AMAX + INX = 0 + AT_SINQ = .TRUE. + ICLM = 0 + RETURN + END +C-------------------------------------------------------------------------- + SUBROUTINE T_CONV ( ! File [MAD.SRC]T_CONV.FOR +c ================= + + EI, AKI, EF, AKF, QHKL, EN, + + HX, HY, HZ, + + IF1, IF2, + + LDK, LDH, LDF, LPA, + + DM, DA, + + HELM, F1H, F1V, F2H, F2V, F, + + IFX, ISS, ISM, ISA, + + T_A, T_RM, T_ALM, T_RA, QM, + + LDRA, LDR_RM, LDR_ALM, LDR_RA, + + P_IH, C_IH, + + IER) +c +cdec$ ident 'V01D' +C----------------------------------------------------------------------- +C Other routines in this file: +c +C SUBROUTINE EX_CASE (DX,ISX,AKX,AX1,AX2,RX,ALX,IER) +C SUBROUTINE SAM_CASE (QT,QM,QS,AKI,AKF,AX3,AX4,ISS,IER) +C SUBROUTINE HELM_CASE (HX,HY,HZ,P_IH,AKI,AKF,A4,QM,HELM,IER) +C SUBROUTINE FLIP_CASE (IF1,IF2,P_IH,F1V,F1H,F2V,F2H,AKI,AKF,IER) +C----------------------------------------------------------------------- +C INPUTS +C EI,AKI,EF,AKF,QHKL,EN,HX,HY,HZ : POTENTIAL TARGETS +C IF1,IF2 Status of flippers On (1) Off (0) +C LDK(8) LOGICAL INDICATING IF (ENERGY,K OR Q) ARE DRIVEN +C LDH,LDF LOGICAL INDICATING IF (HX,HY,HZ) OR (F1,F2) ARE DRIVEN +C +C configuration of the machine +c +C LPA LOGICAL TRUE IF MACHINE IN POLARIZATION MODE +C DM,DA,HELM,F1H,F1V,F2H,F2V,F,IFX,ISS,ISM,ISA,QM (F ENERGY UNIT) +C +C OUTPUTs +C T_A TARGETS OF ANGLES A1-A6 +C T_RM,T_ALM TARGETS OF RM ,LM +C T_RA TARGET OF RA +C QM TARGETS OF QM +C LDRA LOGICAL INDICATING WHICH ANGLES ARE TO BE DRIVEN +C LDR_RM LOGICAL INDICATING IF RM (mono curve) IS TO BE DRIVEN +C LDR_ALM LOGICAL INDICATING IF ALM (mono transl) IS TO BE DRIVEN +C LDR_RA LOGICAL INDICATING IF RA (anal curve) IS TO BE DRIVEN +C P_IH TARGETS OF CURRENTS FOR FLIPPERS AND HELMOTZ (8 CURRENTS) +C C_IH CONVERSION FACTORS FOR HELMOTZ (4 CURRENTS) +C +C SPECIAL OUTPUTS +C TARGET OF EI(EF) IS UPDATED IS KI(KF) IS DRIVEN +C TARGET OF VARIABLE ENERGY IS UPDATED IF EN IS DRIVEN +C----------------------------------------------------------------------- + implicit none +c + REAL*4 EPS1, EPS4 + parameter (EPS1 = 1.D-1) + parameter (EPS4 = 1.D-4) + INTEGER ICRM, ICRA, ICLM, INX + LOGICAL AT_SINQ + REAL*4 CM1RX, CM2RX, CA1RX, CA2RX, RMMIN, RMMAX + REAL*4 RAMIN, RAMAX + COMMON/CURVE/ICRM,ICRA, ICLM, CM1RX, CM2RX, CA1RX, CA2RX, + + RMMIN, RMMAX, RAMIN, RAMAX, INX, AT_SINQ +c +C include 'curve.inc' +C----------------------------------------------------------------------- +C Define the dummy arguments +c + real*4 ei, aki, ef, akf, qhkl(3), en + real*4 hx, hy, hz + integer*4 if1, if2 + logical*4 ldk(8), ldh, ldf, lpa + real*4 dm, da + real*4 helm, f1h, f1v, f2h, f2v, f + integer*4 ifx, iss, ism, isa + real*4 t_a(6), t_rm, t_alm, t_ra, qm + logical*4 ldra(6), ldr_rm, ldr_alm, ldr_ra + real*4 p_ih(8), c_ih(4) + integer*4 ier +C----------------------------------------------------------------------- +C LOCAL VARIABLES +C + integer*4 i, id, imod, iq + logical*4 lmoan(2), lqhkle +c + double precision a1, a2, a3, a4, a5, a6 + double precision ala, alm, dakf, daki, dqm, dqs + double precision def, dei + double precision ra, rm + double precision edef(2), akdef(2), dqhkl(3), dqt(3) + double precision ddm, dda +C----------------------------------------------------------------------- +C SET UP +C IMOD INDEX FOR ERROR TREATMENAT BY ERRESO +C LDQHKLE : LOGICAL INDICATING THAT WE ARE DEALING WITH A MOVE +C IN RECIPROCICAL SPACE +C WE REMAP THE ENERGY PB AS FIXED ENERGY IN EDEF(1) +C AND VARIABLE ENERGY IN EDEF(2) +C IF ISA IS NUL SET IFX TO 1 AND PUT EF,KF, EQUAL TO EI,KI +C + IMOD = 3 + DDM = DM + DDA = DA + DO I = 1,2 + LMOAN(I) = .FALSE. + ENDDO + LQHKLE = .FALSE. + DO IQ = 5,8 + LQHKLE = (LQHKLE .OR. LDK(IQ)) + ENDDO + DAKI = AKI + DAKF = AKF + IF (ISA .EQ. 0) IFX = 1 + EDEF(IFX) = EI + AKDEF(IFX) = AKI + EDEF(3-IFX) = EF + AKDEF(3-IFX) = AKF + IF( ISA .EQ. 0) THEN + EDEF(2) = EDEF(1) + AKDEF(2) = AKDEF(1) + LDK(3) = .TRUE. + LDK(4) = .TRUE. + T_A(5) = 0. + T_A(6) = 0. + LDRA(5) = .TRUE. + LDRA(6) = .TRUE. + ENDIF +C----------------------------------------------------------------------- +C FIRST TAKE IN ACCOUNT THE FIXED ENERGY PB +C + IF (LDK(2*IFX-1) .OR. LDK(2*IFX)) THEN + LMOAN(IFX) = .TRUE. + IF (LDK(2*IFX-1)) THEN + IER = 1 + IF(EDEF(1) .LT. EPS1) GOTO 999 + IER = 0 + AKDEF(1) = SQRT(EDEF(1)/F) + ELSE + IER = 1 + IF(AKDEF(1) .LT. EPS1) GOTO 999 + IER = 0 + EDEF(1) = F*AKDEF(1)**2 + ENDIF + ENDIF +C----------------------------------------------------------------------- +C NOW TAKE IN ACCOUNT THE VARIABLE ENERGY PB +C VARIABLE ENERGUY IS DRIVEN EITHER EXPLICITLY +C E.G. BY DRIVING EI OR KI WITH IFX=2 +C ( AND WE MUST CALCULATE EN FROM EVAR) +C THE RULE IS : EI=EF+EN : EN IS THE ENERGY LOSS OF NEUTRONS +C OR ENERGY GAIN OF SAMPLE +C OR IMPLICITLY BY DRIVING THE TRANSFERED ENERGY EN +C ( AND WE MUST CALCULATE EVAR FROM EN) +C IF KI IS CONSTANT USE THE CURRENT VALUE CONTAINED IN POSN ARRAY +C TO CALCULATE THE NON-"CONSTANT" K. +C IF KF IS CONSTANT USE ALWAYS THE VALUE IN TARGET AND +C DO A DRIVE OF KF TO KEEP A5/A6 IN RIGHT POSITION +C + IF (LDK(5-2*IFX) .OR. LDK(6-2*IFX)) THEN + LMOAN(3-IFX) = .TRUE. + IF (LDK(5-2*IFX)) THEN + IER = 1 + IF(EDEF(2) .LT. EPS4) GOTO 999 + IER = 0 + AKDEF(2) = SQRT(EDEF(2)/F) + ELSE + IER = 1 + IF(AKDEF(2) .LT. EPS4) GOTO 999 + IER = 0 + EDEF(2) = F*AKDEF(2)**2 + ENDIF + EN = (3-2*IFX)*(EDEF(1)-EDEF(2)) + ELSEIF (LQHKLE) THEN + LMOAN(3-IFX) = .TRUE. + EDEF(2) = EDEF(1)+(2*IFX-3)*EN + IER = 1 + IF(EDEF(2) .LT. EPS4) GOTO 999 + IER = 0 + AKDEF(2) = SQRT(EDEF(2)/F) + ENDIF +C----------------------------------------------------------------------- +C CALCULATE MONOCHROMATOR AND ANALYSER ANGLES +C + IF(LMOAN(1)) THEN + DEI = EDEF(IFX) + DAKI = AKDEF(IFX) + CALL EX_CASE(DDM,ISM,DAKI,A1,A2,RM,ALM,0,IER) + IF (IER .EQ. 0) THEN + AKI = DAKI + EI = DEI + T_A(1) = A1 + T_A(2) = A2 + LDRA(1) = .TRUE. + LDRA(2) = .TRUE. + if (icrm .ne. 0) then + T_RM = RM + LDR_RM = .TRUE. + endif + if ((iclm .ne. 0) .and. (inx .ne. 0)) then + T_ALM = ALM + LDR_ALM = .TRUE. + endif + ELSE + GOTO 999 + ENDIF + ENDIF + IF(LMOAN(2)) THEN + DEF = EDEF(3-IFX) + DAKF = AKDEF(3-IFX) + CALL EX_CASE(DDA,ISA,DAKF,A5,A6,RA,ALA,1,IER) + IF (IER .EQ. 0) THEN + AKF = DAKF + EF = DEF + T_A(5) = A5 + T_A(6) = A6 + LDRA(5) = .TRUE. + LDRA(6) = .TRUE. + if (icra .ne. 0) then + T_RA = RA + LDR_RA = .TRUE. + endif + ELSE + GOTO 999 + ENDIF + ENDIF +C----------------------------------------------------------------------- +C USE (QH,QK,QL) TO CALCULATE A3 AND A4 +C CALCULATE Q1 AND Q2 IN SCATTERING PLANE +C + IMOD = 2 + IF (LQHKLE) THEN + DO ID = 1,3 + DQHKL(ID) = QHKL(ID) + ENDDO + CALL RL2SPV(DQHKL,DQT,DQM,DQS,IER) + IF (IER .NE. 0) GOTO 999 + CALL SAM_CASE(DQT,DQM,DQS,DAKI,DAKF,A3,A4,ISS,IER) + IF (IER .EQ. 0) THEN + T_A(3) = A3 + T_A(4) = A4 + LDRA(3) = .TRUE. + LDRA(4) = .TRUE. + QM = DQM + ELSE + GOTO 999 + ENDIF + ENDIF +C----------------------------------------------------------------------- +C DEAL WITH FLIPPERS AND HELMOTZ COILS IF LPA +C + IF (LPA .AND. (LMOAN(1) .OR. LMOAN(2))) THEN + IF (LDF) CALL FLIP_CASE(IF1,IF2,P_IH,F1V,F1H,F2V,F2H, + + AKI,AKF,IER) + IF (LDH) CALL HELM_CASE(HX,HY,HZ,P_IH,C_IH,AKI,AKF, + + A4,QM,HELM,IER) + endif +C----------------------------------------------------------------------- + 999 CONTINUE + IF (IER .NE. 0) CALL ERRESO(IMOD,IER) + RETURN + END +c + SUBROUTINE EX_CASE ( ! Part of T_CONV.FOR +c ================== + + DX,ISX,AKX,AX1,AX2,RX,ALX,MON_OR_ANAL,IER) +C +C CALCULATE ANGLES ON MONO/ANALYSER +C CALCULATE AX1 AX2 +C CALCULATE RX = MONO OR ANAL CURVATURE AND LM = MONO POSIT FOR IN8 +C +C INPUTS +C DX D-SPACINGS +C ISX SENS OF SCATTERING ON CRYSTAL. If =0, this is probably +c a 3-axis instr. in simulated 2-axis mode and the +c calculation is for the scattering at the analyser. +c In this case, we set AX1 = AX2 = 0 which gives a +c "straight-through" setting of A5 & A6 (because of +c a simultaneous 90 degree zero offset for A5 -- this +c is a bit of a hack, if you ask me!). +C AKX TARGET OF MOMENTUM +c MON_OR_ANAL =0 if calculation is for mono. +c =1 if calculation is for anal. +C OUTPUTS +C AX1 AX2 THETA 2*THETA ANGLES +C RX MONO OR ANALYSER CURVATURE +C ALX SPECIAL TRANSLATION FOR IN8 +C IER +C 1 'KI OR KF CANNOT BE OBTAINED CHECK D-SPACINGS', +C 2 'KI OR KF TOO SMALL', +C 3 'KI OR KF TOO BIG', +C----------------------------------------------------------------------- + implicit none +c + double precision PI, RD, EPS1 + PARAMETER (PI = 3.14159265358979323846264338327950D0) + PARAMETER (RD = 57.29577951308232087679815481410517D0) + PARAMETER (EPS1 = 1.D-1) +C----------------------------------------------------------------------- +C Define the dummy arguments + double precision dx + integer*4 isx + double precision akx, ax1, ax2, rx, alx + integer*4 mon_or_anal, ier +C----------------------------------------------------------------------- +C include 'curve.inc' +C include 'motdef.inc' +C include 'iolsddef.inc' +c + INTEGER ICRM, ICRA, ICLM, INX + LOGICAL AT_SINQ + REAL*4 CM1RX, CM2RX, CA1RX, CA2RX, RMMIN, RMMAX + REAL*4 RAMIN, RAMAX + COMMON/CURVE/ICRM,ICRA, ICLM, CM1RX, CM2RX, CA1RX, CA2RX, + + RMMIN, RMMAX, RAMIN, RAMAX, INX, AT_SINQ + +C real*4 tbut(5,NBMOT) +C equivalence (rbut, tbut) +C----------------------------------------------------------------------- +C LOCAL VAR +c + double precision arg, dc1rx, dc2rx, drmin, drmax, dcl1r, my_rx + integer*4 ios, indx +C----------------------------------------------------------------------- +C INIT AND TEST +C + ier = 0 + ax1 = 0.0 + ax2 = 0.0 + rx = 0.0 + alx = 0.0 +c---------------------------------------------------------------------- +c Check validity of inputs. + if (dx .lt. EPS1) ier = 1 + if (akx .lt. EPS1) ier = 2 + arg = PI/(dx * akx) + if (abs(arg) .gt. 1.0) ier = 3 + if (ier .ne. 0) goto 999 +c---------------------------------------------------------------------- + if (mon_or_anal .eq. 0) then ! Use monochr or anal params? + indx = icrm ! Monochr, so set up params. + dc1rx = cm1rx + dc2rx = cm2rx + dcl1r = ICLM + drmin = rmmin + drmax = rmmax + else + indx = icra ! Analyser, so set up params. + dc1rx = ca1rx ! There is no ALX in this case. + dc2rx = ca2rx + drmin = ramin + drmax = ramax + endif +c +C if (indx .ne. 0) then ! Include zero-offset in min/max +C drmin = drmin + tbut(3,indx) +C drmax = drmax + tbut(3,indx) +C if (drmin .lt. tbut(1,indx)) drmin = tbut(1,indx) +C if (drmax .gt. tbut(2,indx)) drmax = tbut(2,indx) +C endif +c----------------------------------------------------------------------- +c Calculation of the two angles +c + if (isx .eq. 0) then ! "Straight-through" mode? + ax1 = 0.0 ! Yes. + ax2 = 0.0 + rx = drmin + alx = 0.0 + return + endif +c + ax1 = asin (arg) * isx * rd + ax2 = 2.0d0 * ax1 +c----------------------------------------------------------------------- +c Calculation of mono curvature RM or analyser curvature RA +c Standard law is: +c +c For monochr: +c CM1RX + CM2RX/SIN(abs(A1)/RD) +c +c For analyser: +c CA1RX + CA2RX*SIN(abs(A5)/RD) +c +c CM1RX/CM2RX/CA1RX/CA2RX are parameters depending on monochr/analyser and +c instrument. They are read from CURVE.INI in routine SETUP_MOT_CURVE. +c e.g. cm1rx = .47 +c cm2rx = .244 +c rmmin = 0. +c rmmax = 20. +c----------------------------------------------------------------------- + if (mon_or_anal .eq. 0) then ! Monochr or analyser? + if (inx .ne. 0) then ! Monochr. Is there a translation? + if (iclm .ne. 0) then ! Yes, IN8 case. If there's a .. + alx = (dcl1r/sin(ax2/rd)) * cos(ax2/rd) ! .. motor, do the .. + rx = dc2rx * sqrt(sin(abs(ax2)/rd)) - dc1rx ! .. calculation. + rx = dmin1 (dmax1 (rx, drmin), drmax) + return + endif + else ! Not IN8 case so, .. + my_rx = dc1rx + dc2rx/sin(abs(ax1)/rd) ! .. simply calculate. + endif + else ! Analyser. + my_rx = dc1rx + dc2rx * sin(abs(ax1)/rd) ! Simply calculate. + endif +c + if (indx .ne. 0) then ! If there's a motor, return the curvature. + rx = dmin1 (dmax1 (my_rx, drmin), drmax) +C if (rx .ne. my_rx) then +C write (iolun, 101, iostat=ios) motnam(indx), my_rx +C 101 format (' Warning -- ', a8, 'curvature restricted by low ', +C + 'or high limits!'/ +C + ' Calculated curvature was', f9.2) +C endif + endif +c----------------------------------------------------------------------- +999 continue + return + end +c + SUBROUTINE SAM_CASE ( ! Part of T_CONV.FOR +c =================== + + QT,QM,QS,AKI,AKF,AX3,AX4,ISS,IER) +C +C DEAL WITH SAMPLE ANGLES CALCULATION FROM Q VECTOR IN C-N PLANE +C CALCULATE A3 AND A4 +C INPUTS +C QT Q-VECTOR IN SCATTERING PLANE +C QM,QS Q MODULUS AND QMODULUS SQUARED +C AKI,AKF MOMEMTA ON MONO AND ANYLSER +C ISS SENS OF SCATTERING ON SAMPLE +C +C OUTPUTS +C AX3 AX4 ANGLES ON SAMPLES +C IER SAME ERROR AS RL2SPV +C IER +C 1 'MATRIX S NOT OK', +C 2 'Q NOT IN SCATTERING PLANE', +C 3 'Q MODULUS TOO SMALL', +C 4 'Q MODULUS TOO BIG', +C----------------------------------------------------------------------- + implicit none +c + double precision RD, EPS3, EPS6 + PARAMETER (RD = 57.29577951308232087679815481410517D0) + PARAMETER (EPS3 = 1.D-3) + PARAMETER (EPS6 = 1.D-6) +C----------------------------------------------------------------------- +C Define the dummy arguments + double precision qt(3) + double precision qm, qs, aki, akf, ax3, ax4 + integer*4 iss, ier +C----------------------------------------------------------------------- +c Local variables + double precision arg, sax3 +C----------------------------------------------------------------------- +C INIT AND TEST +C + IER = 0 + IF ((ABS(QS) .LT. EPS6) .OR. (ABS(QM) .LT. EPS3)) THEN + IER = 3 + GOTO 999 + ENDIF +C----------------------------------------------------------------------- +C CALCULATE A3 AND MOVE IT INTHE -180 ,+180 INTERVAL +C + ARG = (AKI**2 + AKF**2 - QS)/(2.D0*AKI*AKF) + IF(ABS(ARG) .GT. 1.D0)THEN + IER = 4 + GOTO 999 + ELSE + AX4 = ACOS(ARG)*ISS*RD + ENDIF + AX3 = (-ATAN2(QT(2),QT(1))-ACOS((AKF**2-QS-AKI**2)/ + + (-2.D0*QM*AKI))*DSIGN(1.D0,AX4))*RD + sax3 = Dsign(1.D0,ax3) + AX3 = DMOD(AX3+sax3*180.D0,360.D0)-sax3*180.D0 +C +C IF(LPLATE) AX3 = -ATAN(SIN(AX4/RD)/(LSA*TAN(AX5/RD)/(ALMS*C +C 1 TAN(AX1/RD))*(AKI/KF)**2-COS(AX4/RD)))*RD !PLATE FOCALIZATION OPTION +C IF(AXX3 .GT. 180.D0) AX3 = AX3-360.D0 +C IF( A3 .LT. -180.D0) AX3 = AX3+360.D0 +C IF(LPLATE .AND. (A3 .GT. 0.0)) AX3 = AX3-180 +CC----------------------------------------------------------------------- +999 CONTINUE + RETURN + END +c + SUBROUTINE HELM_CASE ( ! Part of T_CONV.FOR +c ==================== + + HX,HY,HZ,T_IH,C_IH,AKI,AKF,A4,QM,HELM,IER) +C +C DEAL WITH HELMOTZ COIL FIELD CALCULATIONS +C CALCULATE HX HY HZ +C----------------------------------------------------------------------- +c At ILL: +c There are 3 coils for Hx/Hy at 120 degrees to each other. +c +c There is a 4th coil for Hz. +c +c At SINQ: +c There is an Hx coil and an Hy coil (actually each is 4 coils powered +c in series). They are mounted on a ring (SRO). The value of HELM is +c the angle between the Hx coil and ki. +c +c There is a 3rd coil for Hz. +C----------------------------------------------------------------------- + implicit none +c +C include 'common_sinq.inc' +c + double precision PI, RD, EPS3, EPS4 + PARAMETER (PI = 3.14159265358979323846264338327950D0) + PARAMETER (RD = 57.29577951308232087679815481410517D0) + PARAMETER (EPS3 = 1.0D-3) + PARAMETER (EPS4 = 1.0D-4) +C----------------------------------------------------------------------- +C Define the dummy arguments + real*4 hx, hy, hz + real*4 t_ih(8) + real*4 c_ih(4) + real*4 aki, akf + double precision a4 + real*4 qm, helm + integer*4 ier + LOGICAL AT_SINQ +C----------------------------------------------------------------------- +c Local variables + integer*4 ic, ncoef + double precision hdir, hdir2, hrad, phi, qpar, qperp +C----------------------------------------------------------------------- +C INIT AND TEST +C + AT_SINQ = .TRUE. + ncoef = 4 + if (at_sinq) ncoef = 3 +c + IER = 1 + IF (ABS(QM) .LT. EPS4) goto 999 + IER = 0 + DO IC = 1,ncoef + IF (C_IH(IC) .LT. EPS4) IER = 2 + ENDDO + IF (IER .NE. 0) GOTO 999 +C----------------------------------------------------------------------- +C CALCULATE MODULE AND ANGLES OF IN PLANE FIELD H +C PHI ! Angle between Q and KI (in radians) +C HRAD ! Radial comp. of H +C HDIR ! Direction of H relative to PHI (in radians) +C HDIR2 ! Angle between field and axis of Coil 1 (in radians) +C + qpar = aki - akf * cos(a4/RD) + qperp = -akf * sin(a4/RD) + if (abs(qpar) .gt. EPS3 .and. abs(qperp) .gt. EPS3) then + phi = atan2 (abs(qperp), abs(qpar)) + if (qpar .gt. 0 .and. qperp .lt. 0) then + phi = -phi + elseif (qpar .lt. 0 .and. qperp .gt. 0) then + phi = PI - phi + elseif (qpar .lt. 0 .and. qperp .lt. 0) then + phi = phi - PI + endif + elseif (abs(qpar) .gt. EPS3) then + if (qpar .ge. 0.0) phi = 0.0 + if (qpar .lt. 0.0) phi = PI + elseif (abs(qperp) .gt. EPS3) then + if (qperp .ge. 0.0) phi = 0.5 * PI + if (qperp .lt. 0.0) phi = -0.5 * PI + else + phi = 0.0 + endif +c + hrad = sqrt (hx**2 + hy**2) + if (abs(hx) .gt. EPS3 .and. abs(hy) .gt. EPS3) then + hdir = atan2 (abs(hy), abs(hx)) + if (hx .gt. 0 .and. hy .lt. 0) then + hdir = -hdir + elseif (hx .lt. 0 .and. hy .gt. 0) then + hdir = PI - hdir + elseif (hx .lt. 0 .and. hy .lt. 0) then + hdir = hdir - PI + endif + elseif (abs(hx) .gt. EPS3) then + if (hx .ge. 0.0) hdir = 0.0 + if (hx .lt. 0.0) hdir = PI + elseif (abs(hy) .gt. EPS3) then + if (hy .ge. 0.0) hdir = 0.5 * PI + if (hy .lt. 0.0) hdir = -0.5 * PI + else + hdir = 0.0 + endif +c + hdir2 = hdir + phi - (helm/RD) +C----------------------------------------------------------------------- +C !CALC CURRENTS +C !POSITION OF PSP FOR COIL I +C + if (.not. at_sinq) then + hdir2 = hdir2 + 0.5 * PI ! ??? + do ic = 1,3 + t_ih(ic+4) = cos(hdir2+(ic-1)*2.*PI/3.)*hrad/c_ih(ic)/1.5 + enddo + t_ih(8) = hz/c_ih(4) + else + t_ih(5) = cos(hdir2) * hrad/c_ih(1) + t_ih(6) = sin(hdir2) * hrad/c_ih(2) + t_ih(7) = hz/c_ih(3) + endif +C----------------------------------------------------------------------- + 999 CONTINUE + RETURN + END +c + SUBROUTINE FLIP_CASE ( ! Part of T_CONV.FOR +C ==================== + + IF1,IF2,T_IH,F1V,F1H,F2V,F2H,AKI,AKF,IER) +C +C DEAL WITH FLIPPER COIL CALCULATIONS +C CALCULATE P_IF CURRENTS FOR THE TWO FLIPPERS +C----------------------------------------------------------------------- +C Define the dummy arguments + integer*4 if1, if2 + real*4 t_ih(8) + real*4 f1v, f1h, f2v, f2h + real*4 aki, akf + integer*4 ier +C----------------------------------------------------------------------- +C INIT AND TEST +C + IER = 0 +C----------------------------------------------------------------------- +C + IF (IF1 .EQ. 1) THEN + T_IH(1) = F1V + T_IH(2) = AKI*F1H + ELSE + T_IH(1) = 0. + T_IH(2) = 0. + ENDIF + IF (IF2 .EQ. 1) THEN + T_IH(3) = F2V + T_IH(4) = AKF*F2H + ELSE + T_IH(3) = 0. + T_IH(4) = 0. + ENDIF +C----------------------------------------------------------------------- +999 CONTINUE + RETURN + END diff --git a/t_rlp.c b/t_rlp.c new file mode 100644 index 00000000..8d66baa9 --- /dev/null +++ b/t_rlp.c @@ -0,0 +1,516 @@ +/* t_rlp.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_ + +/* Subroutine */ int t_rlp__(void) +{ +/* ================ */ + +/* 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! */ +/* ------------------------------------------------------------------ */ +/* 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) */ +/* ------------------------------------------------------------------ */ +/* File [MAD.SRC]T_RLP.FOR */ + return 0; +} /* t_rlp__ */ + + +/* Subroutine */ int setrlp_(real *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 */ +/* ------------------------------------------------------------------ */ +/* Part of [MAD.SRC]T_RLP.FOR */ + +/* ------------------------------------------------------------------ */ +/* 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]; + } + + for (id = 1; id <= 3; ++id) { + *ier = 1; + if ((d__1 = a[id - 1], abs(d__1)) <= 1e-8) { + goto L999; + } + *ier = 0; + } + 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]); + } + 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; + } + 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; + } + *ier = 1; + if ((d__1 = rlb[id - 1], abs(d__1)) <= 1e-8) { + goto L999; + } + *ier = 0; + rlb[id - 1] = sqrt(rlb[id - 1]); + } +/* ----------------------------------------------------------------------- */ +/* 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]; + } + } + } + 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]; + } + } + + 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; + } + *ier = 3; + if ((d__1 = c__[id - 1], abs(d__1)) <= 1e-6) { + goto L999; + } + *ier = 0; + c__[id - 1] = sqrt(c__[id - 1]); + } + + for (id = 1; id <= 3; ++id) { + for (je = 1; je <= 3; ++je) { + vv[je + id * 3 - 4] /= c__[je - 1]; + } + } + 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]; + } + } + } + osolem_1.s[15] = 1.; + for (jd = 1; jd <= 3; ++jd) { + osolem_1.s[(jd << 2) - 1] = 0.; + osolem_1.s[jd + 11] = 0.; + } +/* ----------------------------------------------------------------------- */ +/* 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 */ +/* ------------------------------------------------------------------ */ +/* Part of [MAD.SRC]T_RLP.FOR */ + +/* ------------------------------------------------------------------ */ +/* 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]; + } + } + *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; + } + 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 */ +/* ------------------------------------------------------------------ */ +/* Part of [MAD.SRC]T_RLP.FOR */ + +/* ------------------------------------------------------------------ */ +/* 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; + } + 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]; + } + } +/* --------------------------------------------------------------------------- */ + +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 */ +/* ------------------------------------------------------------------ */ +/* Part of [MAD.SRC]T_RLP.FOR */ + +/* ------------------------------------------------------------------ */ +/* 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.; + } + } + 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)]; + } + det += s[id + 4] * sinv[(id << 2) + 1]; + } + 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; + } + } + } + sinv[20] = 1.; + return 0; +} /* invs_ */ + + +/* Subroutine */ int erreso_(integer *module, integer *ier) +{ + + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer lier, lmodule; + +/* ============================= */ + +/* ------------------------------------------------------------------ */ +/* SUBROUTINE TO TREAT ERRORS FROM RESOLUTION CALCULATIONS */ +/* MODULE = 1 -> SETRLP */ +/* MODULE = 2 -> RL2SPV */ +/* MODULE = 3 -> EX_CASE */ +/* ------------------------------------------------------------------ */ +/* Part of [MAD.SRC]T_RLP.FOR */ + + +/* include '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); + lmodule = min(i__1,3); +/* WRITE(iolun,501) MESER(LIER,LMODULE) */ +/* L501: */ + return 0; +} /* erreso_ */ + diff --git a/t_rlp.f b/t_rlp.f new file mode 100755 index 00000000..26b7b69a --- /dev/null +++ b/t_rlp.f @@ -0,0 +1,463 @@ + SUBROUTINE T_RLP ! File [MAD.SRC]T_RLP.FOR +c ================ +c +cdec$ Ident 'V01A' +c------------------------------------------------------------------ +c Updates: +c V01A 7-May-1996 DM. Put error output to IOLUN, use IMPLICIT NONE and +c get the code indented so that it is readable! +c------------------------------------------------------------------ +c Routines to deal with the reciprocical lattice PB +c------------------------------------------------------------------ +c Entry points in this file: +c +c SETRLP : CALCULATION OF S AND INVS , ORIENTATION MATRIX +C RL2SPV : TRANSFO FROM RECIP LAT TO SCAT PLANE +C SP2RLV : TRANSFO FROM SCAT PLANE TO RECIP LAT +C INVS : INVERT MATRIX S, GENERATED BY SETRLP. +C ERRESO : DEAL ITH ERROR MESSAGES FOR ALL MODULES +C +C SUBROUTINE SETRLP(SAM,IER) +C SUBROUTINE RL2SPV(QHKL,QT,QM,QS,IER) +C SUBROUTINE SP2RLV(QHKL,QT,QM,QS,IER) +C SUBROUTINE INVS(S,SINV,IER) +C SUBROUTINE ERRESO(MODULE,IER) +c------------------------------------------------------------------ + implicit none + end +c + SUBROUTINE SETRLP (SAM, IER) ! Part of [MAD.SRC]T_RLP.FOR +c ============================ +c +C SETRLP: Computation of matrix S which transforms (QH,QK,QL) to +C vector (Q1,Q2) in scattering plane (defined by vectors A1,A2) +C and SINV matrix for the inverse transformation +C +C INPUT SAM SAMPLE CHARACTERISTICS +C SAM(1)=AS LATTICE PARAMETERS +C SAM(2)=BS ------------------ +C SAM(3)=CS ------------------ +C SAM(4)=AA LATTICE ANGLES +C SAM(5)=BB -------------- +C SAM(6)=CC -------------- +C SAM(7)=AX VECTOR A IN SCATTERING PLANE +C SAM(8)=AY ---------------------------- +C SAM(9)=AZ ---------------------------- +C SAM(10)=BX VECTOR B IN SCATTERING PLANE +C SAM(11)=BY ---------------------------- +C SAM(12)=BZ ---------------------------- +C OUTPUT IER ERROR RETURN TO BE TREATED BY ERRESO +C IER=1 ERROR ON LATTICE PARAMETERS +C IER=2 ERROR ON LATTICE ANGLES +C IER=3 ERROR ON VECTORS A1, A2 +c------------------------------------------------------------------ + IMPLICIT NONE +c + DOUBLE PRECISION PI + PARAMETER (PI=3.14159265358979323846264338327950D0) + DOUBLE PRECISION RD + PARAMETER (RD=57.29577951308232087679815481410517D0) + DOUBLE PRECISION EPS + PARAMETER (EPS=1.D-1) + DOUBLE PRECISION EPS6 + PARAMETER (EPS6=1.D-6) + DOUBLE PRECISION EPS8 + PARAMETER (EPS8=1.D-8) +c------------------------------------------------------------------ +C Define the dummy arguments + real*4 sam(64) + integer*4 ier +c------------------------------------------------------------------ +C DO NOT EXPORT THE FOLLOWING COMMON ! +C IT IS JUST FOR PERMANENT STORAGE USE +C + DOUBLE PRECISION S, SINV + integer*4 iok + COMMON /OSOLEM/ S(4,4), SINV(4,4), iok +C----------------------------------------------------------------------- + double precision a(3), aspv(3,2), rlb(3,2) + double precision alfa(3), sina(3), sinb(3), cosa(3), cosb(3) + double precision b(3), c(3) + double precision vv(3,3), bb(3,3) +C + double precision zp, cc + integer*4 imod + integer*4 id, ie + integer*4 jd, je, jf + integer*4 kg + integer*4 lh, lf + integer*4 md, me + integer*4 ne +C----------------------------------------------------------------------- +C SOME TESTS AND INIT OF CALCUALTION +C + ier = 0 + IMOD = 1 + ZP = 2.D0*PI + IOK = 0 + DO ID = 1,3 + A(ID) = SAM(ID) + ALFA(ID) = SAM(ID+3) + ASPV(ID,1) = SAM(6+ID) + ASPV(ID,2) = SAM(9+ID) + ENDDO +C + DO ID = 1,3 + IER = 1 + IF(ABS(A(ID)).LE.EPS8) GOTO 999 + IER = 0 + ENDDO + DO ID = 1,3 + A(ID) = A(ID)/ZP + ALFA(ID) = ALFA(ID)/RD + COSA(ID) = COS(ALFA(ID)) + SINA(ID) = SIN(ALFA(ID)) + ENDDO + CC = COSA(1)*COSA(1)+COSA(2)*COSA(2)+COSA(3)*COSA(3) + CC = (1.D0+2.D0*COSA(1)*COSA(2)*COSA(3)-CC) + IER = 2 + IF(CC.LE.EPS) GOTO 999 + IER = 0 + CC = SQRT(CC) + JE = 2 + KG = 3 + DO ID = 1,3 + B(ID) = SINA(ID)/(A(ID)*CC) + COSB(ID) = (COSA(JE)*COSA(KG)-COSA(ID))/(SINA(JE)*SINA(KG)) + SINB(ID) = SQRT(1.D0-COSB(ID)*COSB(ID)) + RLB(ID,2) = ABS(ATAN(SINB(ID)/COSB(ID)))*RD + JE = KG + KG = ID + ENDDO + BB(1,1) = B(1) + BB(2,1) = 0.D0 + BB(3,1) = 0.D0 + BB(1,2) = B(2)*COSB(3) + BB(2,2) = B(2)*SINB(3) + BB(3,2) = 0.D0 + BB(1,3) = B(3)*COSB(2) + BB(2,3) = -B(3)*SINB(2)*COSA(1) + BB(3,3) = 1.D0/A(3) +C + DO ID = 1,3 + RLB(ID,1) = 0.D0 + DO JE = 1,3 + RLB(ID,1) = RLB(ID,1)+BB(JE,ID)**2 + ENDDO + IER = 1 + IF (ABS(RLB(ID,1)).LE.EPS8) GOTO 999 + IER = 0 + RLB(ID,1) = SQRT(RLB(ID,1)) + ENDDO +C----------------------------------------------------------------------- +C GENERATION OF S ORIENTATION MATRIX REC. LATTICE TO SCATTERING PLANE +C + DO KG = 1,2 + DO IE = 1,3 + VV(KG,IE) = 0.D0 + DO JF = 1,3 + VV(KG,IE) = VV(KG,IE)+BB(IE,JF)*ASPV(JF,KG) + ENDDO + ENDDO + ENDDO + DO MD = 3,2,-1 + DO NE = 1,3 + ID = MOD(MD,3)+1 + JE = MOD(MD+1,3)+1 + KG = MOD(NE,3)+1 + LH = MOD(NE+1,3)+1 + VV(MD,NE) = VV(ID,KG)*VV(JE,LH)-VV(ID,LH)*VV(JE,KG) + ENDDO + ENDDO +C + DO ID = 1,3 + C(ID) = 0.D0 + DO JE = 1,3 + C(ID) = C(ID)+VV(ID,JE)**2 + ENDDO + IER = 3 + IF (ABS(C(ID)).LE.EPS6) GOTO 999 + IER = 0 + C(ID) = SQRT(C(ID)) + ENDDO +C + DO ID = 1,3 + DO JE = 1,3 + VV(JE,ID) = VV(JE,ID)/C(JE) + ENDDO + ENDDO + DO KG = 1,3 + DO ME = 1,3 + S(KG,ME) = 0.D0 + DO LF = 1,3 + S(KG,ME) = S(KG,ME)+VV(KG,LF)*BB(LF,ME) + ENDDO + ENDDO + ENDDO + S(4,4) = 1.D0 + DO JD = 1,3 + S(4,JD) = 0.D0 + S(JD,4) = 0.D0 + ENDDO +C----------------------------------------------------------------------- +C INVERT TRANSFORMATION MATRIX S AND PU RESULT IN SINV +C + IER = 3 + CALL INVS(S,SINV,IER) + IER = 0 + IF (IER.NE.0)GOTO 999 + IOK = 123 +C--------------------------------------------------------------------------- +C SORTIE +C +999 CONTINUE + IF (IER.NE.0) CALL ERRESO(IMOD,IER) + RETURN + END +c + SUBROUTINE RL2SPV (QHKL, QT, QM, QS, IER) ! Part of [MAD.SRC]T_RLP.FOR +c ========================================= +c +c------------------------------------------------------------------ +C INPUT QHKL QHKL -> QT +C A Q-VECTOR TO BE TRANSFORM FROM RECIP LATTICE TO SCATTERING PLANE +C CHECK THAT Q-VECTOR IS IN THE PLANE +C +C INPUT Q-VECTOR QHKL(3) Q-VECTOR IN RECIPROCICAL LATTICVE +C +C OUTPUT Q-VECTOR QT(3) Q-VECTOR IN SCATTERING PLANE +C OUTPUT QM AND QS QMODULUS AND ITS SQUARE ( TO BE VERIFIED ) +C OUTPUT ERROR IER +C IER=1 MATRIX S NOT OK +C IER=2 Q NOT IN SCATTERING PLANE +C IER=3 Q MODULUS TOO SMALL +c------------------------------------------------------------------ + IMPLICIT NONE +c + DOUBLE PRECISION DEPS4 + PARAMETER (DEPS4=1.D-4) + DOUBLE PRECISION DEPS8 + PARAMETER (DEPS8=1.D-8) +c------------------------------------------------------------------ +c Define the dummy arguments + DOUBLE PRECISION QHKL(3) + DOUBLE PRECISION QT(3) + DOUBLE PRECISION QM + DOUBLE PRECISION QS + integer*4 IER +c------------------------------------------------------------------ +C DO NOT EXPORT THE FOLLWING COOMON ! +C IT IS JUST FOR PERMANENT STORAGE USE +C + DOUBLE PRECISION S, SINV + integer*4 iok + COMMON /OSOLEM/ S(4,4), SINV(4,4), iok +C--------------------------------------------------------------------------- + integer*4 id, je +C--------------------------------------------------------------------------- +C INIT AND TEST IF TRANSFO MATRICES ARE OK + IER = 1 + IF (IOK.NE.123) GOTO 999 + IER = 0 +C----------------------------------------------------------------------- +C + DO ID = 1,3 + QT(ID) = 0.D0 + DO JE = 1,3 + QT(ID) = QT(ID) + QHKL(JE)*S(ID,JE) + ENDDO + ENDDO + IER = 2 + IF(ABS(QT(3)).GT.DEPS4) GOTO 999 + IER = 0 + QS = 0.D0 + DO ID = 1,3 + QS = QS+QT(ID)**2 + ENDDO + IF(QS.LT.DEPS8) THEN + IER = 3 + ELSE + QM = SQRT(QS) + ENDIF +C--------------------------------------------------------------------------- +C +999 CONTINUE + RETURN + END +c + SUBROUTINE SP2RLV (QHKL, QT, QM, QS, IER) ! Part of [MAD.SRC]T_RLP.FOR +c ========================================= +c +c------------------------------------------------------------------ +C INPUT QT QHKL <- QT +C A Q-VECTOR TO BE TRANSFORM FROM SCATTERING PLANE TO RECIP LATTICE +C CHECK THAT Q, D & G VECTORS ARE IN THE SCATTERING PLANE +C +C INPUT Q-VECTOR QT(3) Q-VECTOR IN SCATTERING PLANE +C +C OUTPUT Q-VECTOR QHKL(3) Q-VECTOR IN RECIPROCICAL LATTICVE +C OUTPUT QM AND QS QMODULUS AND ITS SQUARE ( TO BE VERIFIED ) +C OUTPUT ERROR IER +C IER=1 MATRIX S NOT OK +C IER=2 Q NOT IN SCATTERING PLANE +C IER=3 Q MODULUS TOO SMALL +c------------------------------------------------------------------ + IMPLICIT NONE +C + DOUBLE PRECISION EPS4 + PARAMETER (EPS4=1.D-4) + DOUBLE PRECISION EPS8 + PARAMETER (EPS8=1.D-8) +c------------------------------------------------------------------ +c Define the dummy arguments + DOUBLE PRECISION QHKL(3) + DOUBLE PRECISION QT(3) + DOUBLE PRECISION QM + DOUBLE PRECISION QS + integer*4 IER +c------------------------------------------------------------------ +C DO NOT EXPORT THE FOLLWING COOMON ! +C IT IS JUST FOR PERMANENT STORAGE USE +C + DOUBLE PRECISION S, SINV + integer*4 iok + COMMON /OSOLEM/ S(4,4), SINV(4,4), iok +C--------------------------------------------------------------------------- + integer*4 id, je +C--------------------------------------------------------------------------- +C INIT AND TEST IF TRANSFO MATRICES ARE OK + IER = 1 + IF (IOK.NE.123) GOTO 999 + IER = 2 + IF(ABS(QT(3)).GT.EPS4) GOTO 999 + IER = 0 +C----------------------------------------------------------------------- + QS = 0.D0 + DO ID = 1,3 + QS = QS+QT(ID)**2 + ENDDO + IF(QS.LT.EPS8) THEN + IER = 3 + ELSE + QM = SQRT(QS) + ENDIF +C----------------------------------------------------------------------- +C + DO ID = 1,3 + QHKL(ID) = 0.D0 + DO JE = 1,3 + QHKL(ID) = QHKL(ID)+SINV(ID,JE)*QT(JE) + ENDDO + ENDDO +C--------------------------------------------------------------------------- +C +999 CONTINUE + RETURN + END +c + SUBROUTINE INVS (S, SINV, IER) ! Part of [MAD.SRC]T_RLP.FOR +c ============================== +c +c------------------------------------------------------------------ +C ROUTINE TO INVERT MATRIX S, GENERATED BY SETRLP, WHICH TRANSFORMS +C (QH,QK,QL) TO (Q1,Q2) IN THE SCATTERING PLANE +C INPUT MATRIX DOUBLE PRECISION S(4,4) +C OUTPUT MATRIX DOUBLE PRECISION SINV(4,4) +C OUTPUT ERROR IER +C IER=1 DETERMINANT OF MATRIX S TOO SMALL +c------------------------------------------------------------------ + IMPLICIT NONE +c + DOUBLE PRECISION EPS6 + PARAMETER (EPS6=1.D-6) +c------------------------------------------------------------------ +c Define the dummy arguments + DOUBLE PRECISION S(4,4) + DOUBLE PRECISION SINV(4,4) + integer*4 IER +c------------------------------------------------------------------ + integer*4 m(3) + integer*4 n(3) +c + integer*4 id, je + integer*4 mi, mj, ni, nj + double precision det +c------------------------------------------------------------------ + DATA M/2,3,1/ + DATA N/3,1,2/ + IER = 0 + DO ID = 1,4 + DO JE = 1,4 + SINV(ID,JE) = 0.D0 + ENDDO + ENDDO + DET = 0.D0 + DO ID = 1,3 + DO JE = 1,3 + MI = M(ID) + MJ = M(JE) + NI = N(ID) + NJ = N(JE) + SINV(JE,ID) = S(MI,MJ)*S(NI,NJ)-S(NI,MJ)*S(MI,NJ) + ENDDO + DET = DET+S(ID,1)*SINV(1,ID) + ENDDO + IF(ABS(DET).LT.EPS6) THEN + IER = 1 + ELSE + DO ID = 1,3 + DO JE = 1,3 + SINV(ID,JE) = SINV(ID,JE)/DET + ENDDO + ENDDO + ENDIF + SINV(4,4) = 1.D0 + RETURN + END +c + SUBROUTINE ERRESO(MODULE,IER) ! Part of [MAD.SRC]T_RLP.FOR +c ============================= +c +c------------------------------------------------------------------ +C SUBROUTINE TO TREAT ERRORS FROM RESOLUTION CALCULATIONS +C MODULE = 1 -> SETRLP +C MODULE = 2 -> RL2SPV +C MODULE = 3 -> EX_CASE +c------------------------------------------------------------------ + IMPLICIT NONE +c + integer*4 MXER + PARAMETER (MXER = 4) + integer*4 MXMOD + PARAMETER (MXMOD = 3) +c +C include 'iolsddef.inc' +c------------------------------------------------------------------ +c Define the dummy arguments + integer*4 module + integer*4 ier +c------------------------------------------------------------------ + integer*4 lmodule, lier + CHARACTER*64 MESER(MXER,MXMOD) + DATA MESER/ + + ' Check lattice spacings (AS,BS,CS)', + + ' Check cell angles (AA,BB,CC)', + + ' Check scattering plane (AX....BZ)', + + ' Check lattice and scattering plane', +C + + ' Check Lattice and Scattering Plane', + + ' Q not in scattering plane', + + ' Q modulus too small', + + ' KI,KF,Q triangle cannot close', +C + + ' Error in KI or KF. Check D-spacings & units', + + ' KI or KF cannot be obtained', + + ' KI or KF too small', + + ' KI,KF,Q triangle will not close'/ +C--------------------------------------------------------------------------- + LIER = MIN(MAX(IER,1),MXER) + LMODULE = MIN(MAX(MODULE,1),MXMOD) +C WRITE(iolun,501) MESER(LIER,LMODULE) + 501 FORMAT(A) + RETURN + END diff --git a/tas.h b/tas.h new file mode 100644 index 00000000..5d729650 --- /dev/null +++ b/tas.h @@ -0,0 +1,117 @@ + +/*---------------------------------------------------------------------- + Header file for the SICS triple axis module. Implements new drive + and scan commands for triple axis which use the old tasmad F77 + routine for calculating the spectrometer setting angles. + + Mark Koennecke, November 2000 +------------------------------------------------------------------------*/ +#ifndef SICSTAS +#define SICSTAS + +/*------------------------- parameter defines -------------------------*/ +#define WAV 0 +#define DM 1 +#define DA 2 +#define ETAM 3 +#define ETAA 4 +#define TI 5 +#define MN 6 +#define IF1V 7 +#define IF2V 8 +#define IF1H 9 +#define IF2H 10 +#define HELM 11 +#define AS 12 +#define BS 13 +#define CS 14 +#define AA 15 +#define BB 16 +#define CC 17 +#define ETAS 18 +#define AX 19 +#define AY 20 +#define AZ 21 +#define BX 22 +#define BY 23 +#define BZ 24 +#define EI 25 +#define KI 26 +#define EF 27 +#define KF 28 +#define QH 29 +#define QK 30 +#define QL 31 +#define EN 32 +#define QM 33 +#define HX 34 +#define HY 35 +#define HZ 36 + +#define DA1 37 +#define DA2 38 +#define DA3 39 +#define DA4 40 +#define DA5 41 +#define DA6 42 +#define DMCV 43 +#define DSRO 44 +#define DACH 45 +#define DMTL 46 +#define DMTU 47 +#define DSTL 48 +#define DSTU 49 +#define DATL 50 +#define DATU 51 +#define DMGL 52 +#define DSGL 53 +#define DSGU 54 +#define DAGL 55 +#define DEI 56 +#define DKI 57 +#define DEF 58 +#define DKF 59 +#define DQH 60 +#define DQK 62 +#define DQL 62 +#define DEN 63 +#define DQM 64 +#define DT 65 +#define SM 66 +#define SS 67 +#define SA 68 +#define FX 69 +#define NP 70 +#define F1 71 +#define F2 72 +#define LPA 73 + +#define MRX1 74 +#define MRX2 75 +#define ARX1 76 +#define ARX2 77 + +#define MAXPAR 78 + + +/* --------------------- data structure -------------------------------*/ + +typedef struct { + pObjectDescriptor pDes; + pSicsVariable tasPar[MAXPAR]; + pCounter counter; + }TASdata, *pTASdata; + + +/*---------------------- interface ----------------------------------*/ + + int TASFactory(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int TASDrive(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int TASScan(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int TASSet(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + +#endif diff --git a/tas.w b/tas.w new file mode 100644 index 00000000..5036ecf9 --- /dev/null +++ b/tas.w @@ -0,0 +1,168 @@ +\subsection{Triple Axis Spectrometer Software} +A triple axis spectrometer performs complicated scans in Q--energy space. +The triple axis spectrometers pose a couple of challenges to the SICS +software: \begin{itemize} +\item The command syntax should be as close as possible to the syntax +of the ancient tasmad program. +\item A relatively complicated algorithm is used for computing the +motor positions and magnet settings. It is a selling point when the +F77 routine used for this purpose in tasmad can be reused. +\item A ILL format scan file must be written after each scan in order +to provide compatability with existing data analysis software. +\item Provisions must be made to execute a batch file at each scan +point in order to allow for polarisation analysis. +\item The user interface of tasmad is largely based on parameters +which are used to store and manipulate state information. +\item There exists a special syntax for assigning variables which +requires the parameters to be in a special storage order. +\end{itemize} + +These requirements are implemented in the following way: tasmad +variables are matched to SICS variables. The scan and drive commands +are reimplemented in order to allow for both syntax parsing and the +reuse of the triple axis calculation routines. In order to support the +strange storage order assignment system the set command is also +implemented in this modules as it can share code with scan and drive. +All the remaining syntax adaptions will be implemented in the +scripting language. + + +\subsubsection{Data Structures} +It would be inconvenient to search all necessary parameters in the +interpreter anytime a scan or drive command is used. In order to avoid +this, the parameters are cached in a local data structure which is +initialized when installing the tas module. + +@d tasdata @{ +typedef struct { + pObjectDescriptor pDes; + pSicsVariable tasPar[MAXPAR]; + pCounter counter; + }TASdata, *pTASdata; +@} +\begin{description} +\item[pDes] The standard object descriptor required for any SICs +object. +\item[floatPar] An array of pointers to float parameters. +The parameters are indexed through defined constants. +\item[counter] A pointer to the neutron counter. +\end{description} +The constants for the parameters are defined in the header file. + +\subsubsection{Exported Functions} +These are mainly the interpreter inetrface functions: +@d tasfunc @{ + int TASFactory(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int TASDrive(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int TASScan(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); + int TASSet(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]); +@} + + +@o tas.h @{ +/*---------------------------------------------------------------------- + Header file for the SICS triple axis module. Implements new drive + and scan commands for triple axis which use the old tasmad F77 + routine for calculating the spectrometer setting angles. + + Mark Koennecke, November 2000 +------------------------------------------------------------------------*/ +#ifndef SICSTAS +#define SICSTAS + +/*------------------------- parameter defines -------------------------*/ +#define WAV 0 +#define DM 1 +#define DA 2 +#define ETAM 3 +#define ETAA 4 +#define TI 5 +#define MN 6 +#define IF1V 7 +#define IF2V 8 +#define IF1H 9 +#define IF2H 10 +#define HELM 11 +#define AS 12 +#define BS 13 +#define CS 14 +#define AA 15 +#define BB 16 +#define CC 17 +#define ETAS 18 +#define AX 19 +#define AY 20 +#define AZ 21 +#define BX 22 +#define BY 23 +#define BZ 24 +#define EI 25 +#define KI 26 +#define EF 27 +#define KF 28 +#define QH 29 +#define QK 30 +#define QL 31 +#define EN 32 +#define QM 33 +#define HX 34 +#define HY 35 +#define HZ 36 + +#define DA1 37 +#define DA2 38 +#define DA3 39 +#define DA4 40 +#define DA5 41 +#define DA6 42 +#define DMCV 43 +#define DSRO 44 +#define DACH 45 +#define DMTL 46 +#define DMTU 47 +#define DSTL 48 +#define DSTU 49 +#define DATL 50 +#define DATU 51 +#define DMGL 52 +#define DSGL 53 +#define DSGU 54 +#define DAGL 55 +#define DEI 56 +#define DKI 57 +#define DEF 58 +#define DKF 59 +#define DQH 60 +#define DQK 62 +#define DQL 62 +#define DEN 63 +#define DQM 64 +#define DT 65 +#define SM 66 +#define SS 67 +#define SA 68 +#define FX 69 +#define NP 70 +#define F1 71 +#define F2 72 +#define LPA 73 + +#define MRX1 74 +#define MRX2 75 +#define ARX1 76 +#define ARX2 77 + +#define MAXPAR 78 + + +/* --------------------- data structure -------------------------------*/ +@ + +/*---------------------- interface ----------------------------------*/ +@ +#endif +@} \ No newline at end of file diff --git a/tasdrive.c b/tasdrive.c new file mode 100644 index 00000000..ef9aa343 --- /dev/null +++ b/tasdrive.c @@ -0,0 +1,270 @@ +/*-------------------------------------------------------------------------- + This is one implementation file for the TASMAD simulation module for + SICS. The requirement is to make SICS look as much as TASMAD as + possible. This includes: + - TASMAD is variable driven + - Sometimes variables are accessed in storage order. + - A complicated calculation has to be done for getting the instruments + settings right. The appropriate F77 routine from TASMAD will be + reused. + - The scan logic is different. + - Output of ILL-formatted data files is required. + + This file implements the MAD dr command for driving. + + Mark Koennecke, November 2000 +---------------------------------------------------------------------------*/ +#include +#include +#include "fortify.h" +#include "sics.h" +#include "sicsvar.h" +#include "counter.h" +#include "motor.h" +#include "tas.h" +#include "tasu.h" +#include "splitter.h" + + +/* a token break function, implemented in stptok.c */ +extern char *stptok(const char *s, char *tok, size_t toklen, char *brk); + +#define VAR 1 +#define VALUE 2 + +/*---------------------------------------------------------------------- + TASDrive has to do an interesting parsing job: The normal syntax is + par=val. However, it is possible that the we get par = val, val, val + which means that the motors following par in storage order are + driven. Additionally we have to check for special energy or Q variables + which require a triple axis calculation. + + It helps if one understands some fundamental things used in the code + below: + - motorMask holds a value for each motor in the motor list. The + value can be either 0 for not to drive or 1 for drive. After + successfull parsing these motors will be started. The mask will be built + during parsing. + - newPositions holds the new positions for the normal motors. + - tasMask is a mask which indicates which triple axis special variable + (Energy or Q) is driven. + - tasTargetMask will be set by the TAS calculation and will indicate + which motors of the range A1-A6, curvature and currents need to be + driven. + - tasTargets holds after the TAS calculation the target values for the + A1-A6, curvature and currents motors. + + +-------------------------------------------------------------------------*/ +#define NUM 1 +#define TXT 2 + +int TASDrive(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) +{ + pTASdata self = NULL; + int iTAS = 0; + float tasTargets[20]; + unsigned char tasTargetMask[20], tasMask[10]; + char *pPtr, pToken[20], pLine[256]; + int varPointer, i, motorPointer, status, rStatus, lastToken; + char pBueffel[256]; + unsigned char motorMask[MAXMOT]; + float newPositions[MAXMOT]; + + + + assert(pCon); + assert(pSics); + self = (pTASdata)pData; + assert(self); + + /* Initialize */ + Arg2Text(argc, argv,pLine,255); + strtolower(pLine); + lastToken = NUM; + pPtr = pLine + strlen(argv[0]); /* step over command */ + for(i = 0; i < 10; i++) + { + tasMask[i] = 0; + motorMask[i] = 0; + motorMask[10+i] = 0; + tasTargets[i] = .0; + tasTargets[i+10] = .0; + } + for(i = 0; i < MAXMOT; i++) + { + motorMask[i] = 0; + } + varPointer = -1; + rStatus = 1; + + /* parse loop */ + while(pPtr != NULL) + { + pPtr = stptok(pPtr,pToken,20," ,="); + if(strlen(pToken) < 1 || pPtr == NULL ) + continue; + + if(tasNumeric(pToken)) /* numbers */ + { + if(lastToken == NUM) + { + /* handle storage order logic */ + if(motorPointer > -1) + { + motorPointer++; + } + else if(varPointer > -1) + { + varPointer++; + } + else + { + sprintf(pBueffel,"ERROR: parse error at %s, %s", + pToken,"need parameter to drive"); + SCWrite(pCon,pBueffel,eError); + return 0; + } + } + /* enter the parameter to drive into the appropriate mask */ + if(motorPointer >= 0) + { + motorMask[motorPointer] = 1; + newPositions[motorPointer] = atof(pToken); + } + else if(varPointer >= 0 ) + { + tasMask[varPointer] = 1; + self->tasPar[EMIN + varPointer]->fVal = atof(pToken); + } + else + { + sprintf(pBueffel,"ERROR: parse error at %s, %s", + pToken,"need parameter to drive"); + SCWrite(pCon,pBueffel,eError); + return 0; + } + lastToken = NUM; + } + else /* text tokens */ + { + lastToken = TXT; + if( (status = isTASEnergy(pToken)) > -1) /* Ei, KI, EF, KF, Q.... */ + { + iTAS = 1; + motorPointer = -1; + varPointer = status; + } + else if( (status = isTASMotor(pToken)) > -1) + { + motorPointer = status; + varPointer = -1; + } + else + { + sprintf(pBueffel,"ERROR: cannot drive %s", pToken); + SCWrite(pCon,pBueffel,eError); + rStatus = 0; + break; + } + } + }/* end of parse loop */ + if(rStatus != 1) + return rStatus; + + /* having done this, we can start the motors */ + for(i = 0; i < MAXMOT; i++) + { + if(motorMask[i] > 0) + { + sprintf(pBueffel,"Driving %s to %f", + tasMotorOrder[i],newPositions[i]); + SCWrite(pCon,pBueffel,eValue); + status = StartMotor(pServ->pExecutor,pSics,pCon, + tasMotorOrder[i],newPositions[i]); + if(status == 0) + { + /* error should already have been reported by StartMotor*/ + rStatus = 0; + } + } + } + + /* + if in TAS mode do the TAS calculation and start the appropriate + motors. + */ + if(iTAS > 0) + { + status = TASCalc(self,pCon,tasMask,tasTargets, tasTargetMask); + if(status) + { + /* + do output, first Q-E variables + */ + for(i = 0; i < 10; i++) + { + if(tasMask[i]) + { + sprintf(pBueffel,"Driving %s to %f", tasVariableOrder[EI+i], + self->tasPar[EI+i]->fVal); + SCWrite(pCon,pBueffel,eValue); + } + } + /* + more output: the motor positions + */ + for(i = 0; i < 9; i++) + { + if(tasTargetMask[i]) + { + sprintf(pBueffel,"Driving %s to %f",tasMotorOrder[i], + tasTargets[i]); + SCWrite(pCon,pBueffel,eValue); + } + } + /* + missing: output for helmholtz currents + */ + status = TASStart(self,pCon,pSics,tasTargets,tasTargetMask); + if(status == 0) + { + rStatus = 0; + } + } + else + { + rStatus = 0; + } + } + + /* + wait till we are finished + */ + status = Wait4Success(GetExecutor()); + if(status == DEVINT) + { + if(SCGetInterrupt(pCon) == eAbortOperation) + { + SCSetInterrupt(pCon,eContinue); + SCSetError(pCon,OKOK); + sprintf(pBueffel,"Driving %aborted"); + SCWrite(pCon,pBueffel,eStatus); + } + return 0; + } + else if(status == DEVDONE) + { + sprintf(pBueffel,"Driving done"); + SCWrite(pCon,pBueffel,eStatus); + } + else + { + sprintf(pBueffel, + "Driving finished"); + SCWrite(pCon,pBueffel,eStatus); + } + return rStatus; +} + diff --git a/tasinit.c b/tasinit.c new file mode 100644 index 00000000..9f1d5c29 --- /dev/null +++ b/tasinit.c @@ -0,0 +1,282 @@ +/*-------------------------------------------------------------------------- + This is one implementation file for the TASMAD simulation module for + SICS. The requirement is to make SICS look as much as TASMAD as + possible. This includes: + - TASMAD is variable driven + - Sometimes variables are accessed in storage order. + - A complicated calculation has to be done for getting the instruments + settings right. The appropriate F77 routine from TASMAD will be + reused. + - The scan logic is different. + - Output of ILL-formatted data files is required. + + This file implements the initialization part of the whole thing. + + Mark Koennecke, November 2000 +---------------------------------------------------------------------------*/ +#include +#include +#include "fortify.h" +#include "sics.h" +#include "sicsvar.h" +#include "counter.h" +#include "motor.h" +#include "tas.h" + +/* + As variables may be accessed in storage order, it is necessary to + know the order of the motors +*/ +extern char *tasMotorOrder[] = { "a1", + "a2", + "a3", + "a4", + "a5", + "a6", + "mcv", + "sro", + "ach", + "mtl", + "mtu", + "stl", + "stu", + "stl", + "atu", + "mgl", + "sgl", + "sgu", + "agl", + NULL }; +/* + In order to initialise the variable array in the TAS data structure we + need to know the names of the variables in the right order. This order + has to match the order defined in tas.h through the defines. Otherwise + quite weird things may happen at runtime. +*/ +extern char *tasVariableOrder[] = { + "wav", + "dm", + "da", + "etam", + "etaa", + "ti", + "mn", + "if1v", + "if1h", + "if2v", + "if2h", + "helm", + "as", + "bs", + "cs", + "aa", + "bb", + "cc", + "etas", + "ax", + "ay", + "az", + "bx", + "by", + "bz", + "ei", + "ki", + "ef", + "kf", + "qh", + "qk", + "ql", + "en", + "qm", + "hx", + "hy", + "hz", + "da1", + "da2", + "da3", + "da4", + "da5", + "da6", + "dmcv", + "dsro", + "dach", + "dmtl", + "dmtu", + "dstl", + "dstu", + "datl", + "datu", + "dmgl", + "dsgl", + "dsgu", + "dagl", + "dei", + "dki", + "def", + "dkf", + "dqh", + "dqk", + "dql", + "den", + "dqm", + "dt", + "sm", + "ss", + "sa", + "fx", + "np", + "f1", + "f2", + "lpa", + "mrx1", + "mrx2", + "arx1", + "arx2", + NULL}; +/*--------------------------------------------------------------------- + There is a special feauture in MAD where the count mode is determined + which variable, MN for monitor od TI for time has been set as the last + one. In order to implement this in SICS callback functions will be + used on the variables which switch the counter box into the appropriate + mode. +-----------------------------------------------------------------------*/ +static int MonitorCallback(int iEvent, void *pEvent, void *pUser) +{ + pTASdata self = (pTASdata)pUser; + assert(self); + + if(iEvent != VALUECHANGE) + return 0; + + SetCounterMode(self->counter,ePreset); + return 1; +} + +static int TimerCallback(int iEvent, void *pEvent, void *pUser) +{ + pTASdata self = (pTASdata)pUser; + assert(self); + + if(iEvent != VALUECHANGE) + return 0; + + SetCounterMode(self->counter,eTimer); + return 1; +} +/*----------------------------------------------------------------------- + A function for killing the TAS data structure is needed + -------------------------------------------------------------------------*/ +static void TASKill(void *pData) +{ + pTASdata self = (pTASdata)pData; + if(!self) + return; + + if(self->pDes) + DeleteDescriptor(self->pDes); + free(self); +} +/*-----------------------------------------------------------------------*/ +int TASFactory(SConnection *pCon, SicsInterp *pSics, void *pData, + int argc, char *argv[]) +{ + pTASdata pNew = NULL; + int iPtr, iError; + char pBueffel[132]; + pSicsVariable pVar = NULL; + CommandList *pCom = NULL; + + /* create a new data structure */ + pNew = (pTASdata)malloc(sizeof(TASdata)); + if(!pNew) + { + SCWrite(pCon,"ERROR: insufficient memory to allocate TAS data structure", + eError); + return 0; + } + memset(pNew,0,sizeof(TASdata)); + pNew->pDes = CreateDescriptor("TAS"); + if(!pNew->pDes) + { + SCWrite(pCon,"ERROR: insufficient memory to allocate TAS data structure", + eError); + free(pNew); + return 0; + } + + /* connect to all the variables */ + iPtr = 0; iError = 0; + while(tasVariableOrder[iPtr] != NULL) + { + pNew->tasPar[iPtr] = FindVariable(pSics,tasVariableOrder[iPtr]); + if(!pNew->tasPar[iPtr]) + { + sprintf(pBueffel,"ERROR: TAS variable %s not found", + tasVariableOrder[iPtr]); + SCWrite(pCon,pBueffel,eError); + iError++; + } + sprintf(pBueffel,"Initialised var %d", iPtr); + SCWrite(pCon,pBueffel,eError); + iPtr++; + } + if(iError != 0) + { + SCWrite(pCon,"ERROR: TAS bad initialisation, TAS not created",eError); + TASKill(pNew); + return 0; + } + + /* connect to the counter */ + pCom = FindCommand(pSics,"counter"); + if(!pCom) + { + SCWrite(pCon,"ERROR: no neutron counter for TAS found",eError); + TASKill(pNew); + return 0; + } + pNew->counter = pCom->pData; + + /* + Install the callbacks for TI and MN. Sloppy error checking because + the variables should have been accessed earlier on. + */ + pVar = FindVariable(pSics,"MN"); + if(pVar) + { + RegisterCallback(pVar->pCall,VALUECHANGE,MonitorCallback,pNew,NULL); + } + pVar = FindVariable(pSics,"TI"); + if(pVar) + { + RegisterCallback(pVar->pCall,VALUECHANGE,TimerCallback,pNew,NULL); + } + + /* install TAS commands */ + iError = AddCommand(pSics,"dr",TASDrive,TASKill,pNew); + if(!iError) + { + SCWrite(pCon,"ERROR: duplicate dr command not created",eError); + TASKill(pNew); + return 0; + } + /* + iError = AddCommand(pSics,"sc",TASScan,NULL,pNew); + if(!iError) + { + SCWrite(pCon,"ERROR: duplicate sc command not created",eError); + TASKill(pNew); + return 0; + } + iError = AddCommand(pSics,"set",TASSet,NULL,pNew); + if(!iError) + { + SCWrite(pCon,"ERROR: duplicate set command not created",eError); + TASKill(pNew); + return 0; + } + */ + return 1; +} + + diff --git a/tasutil.c b/tasutil.c new file mode 100644 index 00000000..e712cb1c --- /dev/null +++ b/tasutil.c @@ -0,0 +1,470 @@ +/*-------------------------------------------------------------------------- + This is one implementation file for the TASMAD simulation module for + SICS. The requirement is to make SICS look as much as TASMAD as + possible. This includes: + - TASMAD is variable driven + - Sometimes variables are accessed in storage order. + - A complicated calculation has to be done for getting the instruments + settings right. The appropriate F77 routine from TASMAD will be + reused. + - The scan logic is different. + - Output of ILL-formatted data files is required. + + This file implements a couple of utility functions mainly for parsing + and second for interfacing to the F77 routines for calculating the + TAS settings.. + + Mark Koennecke, November 2000 +---------------------------------------------------------------------------*/ +#include +#include +#include "fortify.h" +#include "sics.h" +#include "sicsvar.h" +#include "counter.h" +#include "motor.h" +#include "tas.h" +#include "tasu.h" + + +/*----------------------------------------------------------------------- + isTASMotor finds out if the given string is a TAS motor and returns its + index in the motor list if this the case. Else -1 is returned. + -------------------------------------------------------------------------*/ +int isTASMotor(char *val) +{ + int iPtr; + + iPtr = 0; + while(tasMotorOrder[iPtr] != NULL) + { + if(strcmp(val,tasMotorOrder[iPtr]) == 0) + { + return iPtr; + } + else + { + iPtr++; + } + } + return -1; +} +/*-------------------------------------------------------------------------- + isTASVar finds out if the given string is a TAS variable and returns its + index if this is the case. Else -1 will be returned. + --------------------------------------------------------------------------*/ +int isTASVar(char *val) +{ + int iPtr; + + iPtr = 0; + while(tasVariableOrder[iPtr] != NULL) + { + if(strcmp(val,tasVariableOrder[iPtr]) == 0) + { + return iPtr; + } + else + { + iPtr++; + } + } + return -1; +} +/*------------------------------------------------------------------------ +isTASEnergy finds out if a variable is a TAS energy variable. This would +require a TAS calculation to take place. If the test is positive then the +index of the Variable is returned, else -1 is returned. +-------------------------------------------------------------------------*/ +isTASEnergy(char *val) +{ + int iPtr; + + for(iPtr = EMIN; iPtr <= EMAX;iPtr++) + { + if(strcmp(val,tasVariableOrder[iPtr]) == 0) + { + return iPtr-EMIN; + } + else + { + iPtr++; + } + } + return -1; +} +/*----------------------------------------------------------------------- +prepare2Parse removes all unnecessary delimiters from the parse string. +These are: ' = +----------------------------------------------------------------------*/ +void prepare2Parse(char *line) +{ + int i, iLang; + + iLang = strlen(line); + for(i = 0; i < iLang; i++) + { + if(line[i] == ',' || line[i] == '=') + { + line[i] = ' '; + } + } +} +/*---------------------------------------------------------------------*/ + int tasNumeric(char *pText) + { + int i, ii, iGood; + static char pNum[13] = {"1234567890.+-"}; + + for(i = 0; i < strlen(pText); i++) + { + for(ii = 0; ii < 13; ii++) + { + iGood = 0; + if(pText[i] == pNum[ii]) + { + iGood = 1; + break; + } + } + if(!iGood) + { + return 0; + } + } + return 1; + } + +/*---------------------------------------------------------------------- +TASCalc does the triple axis spectrometer calculations. This function is +invoked whenever energy or Q needs to be driven. The parameters: + - self a pointer to a TASdata structure holding information about all + necessary parameters. + - pCon a SConnection object needed for reporting errors. + - tasMask a mask with 0,1 indicating which variable is driven. IT IS + ASSUMED THAT THE APPROPRIATE VARIABLE HAS ALREADY BEEN SET IN THE + INTERPRETER BEFORE TASCalc IS CALLED. This is because for convenience + this functions collects the values from the interpreter. + - motorTargets will hold the new targets for the relevant motors + (A1-A6 plus some magnet related) when the call finished happily. + - motorMask will hold 1's for each motor to drive, 0 for each motor + not affected. + +This version uses the TASMAD calculation routines. These have been +translated from F77 to C with f2c (f2c -A crysconv.f , tacov.f). The C is +not maintainable, always edit the F77 sources in case of need and +retranslate. This scheme requires the definitions going before TASCalc. The +advantage of using f2c is that we get less portability problems with +different calling conventions for C anf F77 on different platforms. +-----------------------------------------------------------------------*/ +#include "f2c.h" +extern int setrlp_(real *sam, integer *ier); + +extern int t_conv__(real *ei, real *aki, real *ef, real *akf, real * + qhkl, real *en, real *hx, real *hy, real *hz, integer *if1, integer * + if2, logical *ldk, logical *ldh, logical *ldf, logical *lpa, real *dm, + real *da, real *helm, real *f1h, real *f1v, real *f2h, real *f2v, + real *f, integer *ifx, integer *iss, integer *ism, integer *isa, real + *t_a__, real *t_rm__, real *t_alm__, real *t_ra__, real *qm, logical * + ldra, logical *ldr_rm__, logical *ldr_alm__, logical *ldr_ra__, real * + p_ih__, real *c_ih__, integer *ier); + +extern int inicurve_(integer *midx, real *mrx1, real *mrx2, integer + *aidx, real *arx1, real *arx2, real *mmin, real *mmax, real *amin, + real *amax); + +/*-------------------------------------------------------------------*/ +int TASCalc(pTASdata self, SConnection *pCon, + unsigned char tasMask[10], + float motorTargets[20], + unsigned char motorMask[20]) +{ + /* for setrlp */ + real sam[13]; + integer ier; + /* for t_conv */ + real ei, aki, ef, akf, qhkl[3], en, hx, hy, hz, dm, da, helm, f1h, f1v, + f2h, f2v, f, angles[6], tRM, tRA, tALM, qm, currents[8], helmconv[4]; + integer if1, if2, ifx, iss, ism, isa; + logical ldk[8], ldh, ldf, lpa, ldra[6], l_RM, l_RA, l_ALM; + /* for inicurve */ + real mrx1, mrx2, arx1, arx2, mmin, mmax, amin, amax; + integer im, ia; + pMotor pMot; + float fVal; + /* else */ + int i; + + assert(self); + assert(pCon); + /* + The first thing we need to do is to set up the orientation matrix + from the sample parameters. + */ + sam[0] = (real)self->tasPar[AS]->fVal; + sam[1] = (real)self->tasPar[BS]->fVal; + sam[2] = (real)self->tasPar[CS]->fVal; + sam[3] = (real)self->tasPar[AA]->fVal; + sam[4] = (real)self->tasPar[BB]->fVal; + sam[5] = (real)self->tasPar[CC]->fVal; + sam[6] = (real)self->tasPar[AX]->fVal; + sam[7] = (real)self->tasPar[AY]->fVal; + sam[8] = (real)self->tasPar[AZ]->fVal; + sam[9] = (real)self->tasPar[BX]->fVal; + sam[10] = (real)self->tasPar[BY]->fVal; + sam[11] = (real)self->tasPar[BZ]->fVal; + setrlp_(sam,&ier); + switch(ier) + { + case 1: + SCWrite(pCon,"ERROR: error on lattice parameters",eError); + return 0; + break; + case 2: + SCWrite(pCon,"ERROR: error on lattice angles",eError); + return 0; + break; + case 3: + SCWrite(pCon,"ERROR: error on vectors A1, A2",eError); + return 0; + break; + default: + break; + } + + /* + now we need to set the parameters for mono/analyzer + curvature calculations. + */ + mrx1 = (real)self->tasPar[MRX1]->fVal; + mrx2 = (real)self->tasPar[MRX2]->fVal; + arx1 = (real)self->tasPar[ARX1]->fVal; + arx2 = (real)self->tasPar[ARX2]->fVal; + im = 7; + ia = 9; + pMot = FindMotor(pServ->pSics,"MCV"); + if(!pMot) + { + SCWrite(pCon,"ERROR: cannot find monochromator curvature motor",eError); + return 0; + } + MotorGetPar(pMot,"softupperlim",&fVal); + mmax = (real)fVal; + MotorGetPar(pMot,"softlowerlim",&fVal); + mmin = (real)fVal; + pMot = FindMotor(pServ->pSics,"ACH"); + if(!pMot) + { + SCWrite(pCon,"ERROR: cannot find analyzer curvature motor",eError); + return 0; + } + MotorGetPar(pMot,"softupperlim",&fVal); + amax = (real)fVal; + MotorGetPar(pMot,"softlowerlim",&fVal); + amin = (real)fVal; + inicurve_(&im,&mrx1, &mrx2, &ia, &arx1, &arx2,&mmin, &mmax, + &amin, &amax); + + /* + This done, we painstackingly initialize the tons of parameters required + by the t_conv + */ + ei = (real)self->tasPar[EI]->fVal; + aki = (real)self->tasPar[KI]->fVal; + ef = (real)self->tasPar[EF]->fVal; + akf = (real)self->tasPar[KF]->fVal; + qhkl[0] = (real)self->tasPar[QH]->fVal; + qhkl[1] = (real)self->tasPar[QK]->fVal; + qhkl[2] = (real)self->tasPar[QL]->fVal; + en = (real)self->tasPar[EN]->fVal; + hx = (real)self->tasPar[HX]->fVal; + hy = (real)self->tasPar[HY]->fVal; + hz = (real)self->tasPar[HZ]->fVal; + f = (real)2.072; /* energy unit meV */ + if1 = (integer)self->tasPar[F1]->iVal; + if2 = (integer)self->tasPar[F2]->iVal; + for(i = 0; i < 8; i++) + { + ldk[i] = (logical)tasMask[i]; + } + ldh = (logical)tasMask[8]; + ldf = (logical)tasMask[9]; + if(self->tasPar[LPA]->iVal > 0) + lpa = (logical)1; + dm = (real)self->tasPar[DM]->fVal; + da = (real)self->tasPar[DM]->fVal; + qm = (real)self->tasPar[QM]->fVal; + helm = (real)self->tasPar[HELM]->fVal; + f1h = (real)self->tasPar[IF1H]->fVal; + f1v = (real)self->tasPar[IF1V]->fVal; + f2h = (real)self->tasPar[IF2H]->fVal; + f2v = (real)self->tasPar[IF2V]->fVal; + ifx = (integer)self->tasPar[FX]->iVal; + iss = (integer)self->tasPar[SS]->iVal; + ism = (integer)self->tasPar[SM]->iVal; + isa = (integer)self->tasPar[SA]->iVal; + + /* + initalise the motorMasks to 0. + */ + for(i = 0; i < 20; i++) + { + motorMask[i] = 0; + } + for(i = 0; i < 6; i++) + { + ldra[i] = 0; + } + l_RA = l_RM = l_ALM = 0; + + /* now we can call */ + t_conv__(&ei, &aki, &ef, &akf, + qhkl, &en, &hx, &hy, &hz, &if1, + &if2, ldk, &ldh, &ldf, &lpa, &dm, + &da, &helm, &f1h, &f1v, &f2h, &f2v, + &f, &ifx, &iss, &ism, &isa, + angles, &tRM, &tALM, &tRA, &qm, ldra, + &l_RM, &l_ALM,&l_RA, currents,helmconv, + &ier); + /* + error messages taken from erreso + */ + switch(ier) + { + case 1: + SCWrite(pCon,"ERROR: Bad lattice parameters",eError); + return 0; + break; + case 2: + SCWrite(pCon,"ERROR: Bad cell angles",eError); + return 0; + break; + case 3: + SCWrite(pCon,"ERROR: Bad scattering plane ",eError); + return 0; + break; + case 4: + SCWrite(pCon,"ERROR: Bad lattice or lattice plane",eError); + return 0; + break; + case 5: + SCWrite(pCon,"ERROR: Q not in scattering plane",eError); + return 0; + break; + case 6: + SCWrite(pCon,"ERROR: Q modulus to small",eError); + return 0; + break; + case 7: + case 12: + SCWrite(pCon,"ERROR: KI, KF, Q triangle cannot close ",eError); + return 0; + break; + case 8: + SCWrite(pCon,"ERROR: in KI, KF, check d-spacings",eError); + return 0; + break; + case 9: + SCWrite(pCon,"ERROR: KI or KF cannot be obtained",eError); + return 0; + break; + case 10: + SCWrite(pCon,"ERROR: KI or KF to small",eError); + return 0; + break; + case 11: + SCWrite(pCon,"ERROR: KI or KF cannot be obtained",eError); + return 0; + break; + default: + break; + } + + /* + now we have to put those things back which interest us, including + updating the variables which may have accidentally been set. + */ + for(i = 0; i < 6; i++) + { + motorTargets[i] = angles[i]; + motorMask[i] = ldra[i]; + } + motorMask[6] = l_RM; + motorTargets[6] = tRM; + motorMask[8] = l_RA; + motorTargets[8] = tRA; + for(i = 0; i < 8; i++) + { + motorTargets[9+i] = currents[i]; + } + for(i = 0; i < 4; i++) + { + motorTargets[17+i] = helmconv[i]; + } + self->tasPar[EI]->fVal = (float)ei; + self->tasPar[KI]->fVal = (float)aki; + self->tasPar[EF]->fVal = (float)ef; + self->tasPar[KF]->fVal = (float)akf; + self->tasPar[EN]->fVal = (float)en; + + + return 1; +} +/*------------------------------------------------------------------------- +TASStart starts the motors calculated by TASCalc +---------------------------------------------------------------------------*/ +int TASStart(pTASdata self, SConnection *pCon, SicsInterp *pSics, + float motorTargets[20], + unsigned char motorMask[20]) +{ + int status, i; + char pBueffel[80]; + + /* + do the A1-A6 motors first + */ + for(i = 0; i < 6; i++) + { + if(motorMask[i] != 0) + { + status = StartMotor(pServ->pExecutor,pSics,pCon, + tasMotorOrder[i], motorTargets[i]); + if(status == 0) + { + /* the error will have been reported */ + return 0; + } + } + } + /* + start the monochromator and analyzer curvature motors + */ + if(motorMask[6]) + { + status = StartMotor(pServ->pExecutor,pSics,pCon, + "MCV", motorTargets[6]); + if(status == 0) + { + /* the error will have been reported */ + return 0; + } + } + if(motorMask[9]) + { + status = StartMotor(pServ->pExecutor,pSics,pCon, + "ACH", motorTargets[8]); + if(status == 0) + { + /* the error will have been reported */ + return 0; + } + } + + /* + missing: set the magnet currents. In order to do this, I need more + info about the magnets involved and how to address them. + */ + + return 1; +} + diff --git a/test.tcl b/test.tcl index 9e347bb1..25533dec 100644 --- a/test.tcl +++ b/test.tcl @@ -27,7 +27,7 @@ ServerOption AcceptTimeOut 100 # timeout when checking for connection req. # Similar to above, but for connections -ServerOption ReadUserPasswdTimeout 7000 +ServerOption ReadUserPasswdTimeout 10 # 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\ @@ -114,7 +114,7 @@ sampledist lock #Motor D1V EL734 lnsp22.psi.ch 4000 3 3 Motor A1 SIM 15.0 120. .1 2. # Monochromator Theta Motor A2 SIM -73. 137. .1 1. # Monochromator 2Theta -Motor A3 SIM 0. 360. .1 3. # Sample Omega +Motor A3 SIM -360. 360. .1 3. # Sample Omega Motor A4 SIM -130. 130. .1 1. # Sample 2Theta Motor A5 SIM -30. 30. .1 3. # ? horiz. Translation Motor A6 SIM -30. 30. .1 3. # ? vert Translation @@ -223,8 +223,11 @@ MakePeakCenter xxxscan MakeHM banana SIM -banana configure HistMode HRPT -banana configure OverFlowMode reflect +#MakeHM banana SINQHM +#banana configure HistMode HRPT +banana configure HistMode Normal +#banana configure OverFlowMode reflect +banana configure OverFlowMode Ceil banana configure Rank 1 #banana configure Length 400 banana configure Length 16384 @@ -233,10 +236,11 @@ banana configure dim1 128 banana configure BinWidth 4 banana preset 100. banana CountMode Timer -#banana configure HMComputer lnse02.psi.ch -#banana configure HMPort 2400 -#banana configure Counter counter +banana configure HMComputer lnse02.psi.ch +banana configure HMPort 2400 +banana configure Counter counter banana init + ClientPut "HM initialized" source $shome/sics/tcl/scancom.tcl #source $shome/sics/countf.tcl @@ -259,7 +263,7 @@ ClientPut "Installed ev test stuff" Motor twotheta SIM -120.0 120. .1 2. # 2 theta arm Motor omega SIM -73. 134. .1 2. # omega Motor chi SIM 0. 360. .1 2. # chi circle -Motor phi SIM 0. 360. .1 2. # phi circle +Motor phi SIM -360. 360. .1 2. # phi circle Motor muca SIM 30. 36. .1 2. # phi circle Motor dg1 SIM -10. 40. .1 2. # phi circle SicsAlias phi ph @@ -305,12 +309,286 @@ fcircleinit MakeDifrac twotheta omega chi phi counter +#----------- histogram memory +# -------------------------------------------------------------------------- +# Initialization script for a simulated TOPSI instrument +# +# +# Dr. Mark Koennecke February, 1996 +#--------------------------------------------------------------------------- +# O P T I O N S +# --------------- Initialize Tcl internals -------------------------------- + +rename scan stscan + +#-------- a home for this, everything else is in relation to this +set shome /data/koenneck/src + + + +# first all the server options are set + +#ServerOption RedirectFile $shome/sics/stdout + +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 10 +# 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 $shome/log +#LogFileDir is the directory where the command log is going + +#ServerOption logstartfile $shome/sics/start.tcl + +ServerOption LogFileBaseName $shome/sics/tmp/server +# the path and base name of the internal server logfile to which all +# activity will be logged. + +ServerOption TecsStartCmd "tecs/bin/TecsServer -h lnsp26:4000/0" +# -h host:port/channel is for serial server +ServerOption TecsBinDir tecs/bin/ +ServerOption TecsLogDir /data/koenneck/tmp/ +ServerOption TecsPort 9753 + +ServerOption statusfile 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 $shome/sics/tcl +ServerOption DefaultCommandFile "" + +#------ a port for broadcasting UDP messages +#ServerOption QuieckPort 2108 + +TokenInit connan + +#--------------------------------------------------------------------------- +# 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 +SicsUser me me 1 + +#-------------------------------------------------------------------------- +# S I M P L E 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 "TOPSI" +Instrument lock + +VarMake starttime Text User + +VarMake Title Text User +VarMake sample Text User +sample "DanielOxid" +Title "TopsiTupsiTapsi" +VarMake User Text User +User "Daniel_the_Clementine" + +VarMake detectordist Float Mugger +detectordist 2500 +detectordist lock +VarMake sampledist Float Mugger +sampledist 496. +sampledist lock + +#-------------------------------------------------------------------------- +# 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 D1V EL734 lnsp22.psi.ch 4000 3 3 +Motor A1 SIM 15.0 120. .1 2. # Monochromator Theta +Motor A2 SIM -73. 137. .1 1. # Monochromator 2Theta +Motor A3 SIM -360. 360. .1 3. # Sample Omega +Motor A4 SIM -130. 130. .1 1. # Sample 2Theta +Motor A5 SIM -30. 30. .1 3. # ? horiz. Translation +Motor A6 SIM -30. 30. .1 3. # ? vert Translation +Motor MTL SIM -30. 30. .1 3. # mono lower translation +Motor MTU SIM -30. 30. .1 3. # mono upper translation +Motor STL SIM -30. 30. .1 3. # sample lower translation +Motor STU SIM -30. 30. .1 3. # sample upper translation +Motor MGU SIM -50. 50. .1 3. # mono upper goniometer +Motor SGL SIM -20. 20. .1 3. # sample lower goniometer +Motor SGU SIM -20. 20. .1 3. # sample upper goniometer +Motor SDM SIM -5 50. .1 3. # weird Motor +SicsAlias A4 Tasse +SicsAlias A5 MonoX +SicsAlias A5 MonoY +SicsAlias A5 MonoPhi +SicsAlias A5 MonoChi + +Motor D1R SIM -20. 20. .1 3. # Diaphragm 1 right +Motor D1L SIM -20. 20. .1 3. # Diaphragm 1 left +Motor D1T SIM -20. 20. .1 3. # Diaphragm 1 top & Bottom + +Motor D2R SIM -20. 20. .1 3. # Diaphragm 2 right +Motor D2L SIM -20. 20. .1 3. # Diaphragm 2 left +Motor D2T SIM -20. 20. .1 3. # Diaphragm 2 top & Bottom + +Motor BeamStopX SIM -20. 20. .1 3. # Diaphragm 2 right +Motor BeamStopY SIM -20. 20. .1 3. # Diaphragm 2 left + +Motor DetectorX SIM -20. 20. .1 3. # Diaphragm 2 right +Motor DetectorY SIM -20. 20. .1 3. # Diaphragm 2 left +Motor DetectorRotation SIM -20. 20. .1 3. # Diaphragm 2 top & Bottom + +ClientPut "Motors done" + +MakeMulti sampletable +sampletable alias D1r x +sampletable alias D1L y +sampletable alias D1T z +sampletable pos henry D1r 5. D1L -5. D1T 0. +sampletable endconfig +SicsAlias sampletable st +#------------------------------------------------------------------------ +# Velocity selector +#Motor tilt EL734 lnsp25.psi.ch 4000 2 2 +Motor tilt SIM -15 15 .1 3. +set dornen(Host) lnsp25.psi.ch +set dornen(Port) 4000 +set dornen(Channel) 6 +set dornen(Timeout) 5000 +#VelocitySelector nvs tilt DORNIER dornen +VelocitySelector nvs tilt SIM +nvs add -20 28800 +nvs add 3800 4500 +nvs add 5900 6700 +nvs add 8100 9600 +unset dornen +MakeSANSWave lumbda nvs +ClientPut "Velocity Selector done" +SicsAlias MTL sax +SicsAlias A3 som +#-------------------------------------------------------------------------- +# C O U N T E R S +MakeCounter counter SIM +#MakeCounter counter EL737 lnsp19.psi.ch 4000 4 + +#-------------------------------------------------------------------------- +# M U L T I D E V I C E V A R I A B L E S +MakeMono Mono "Ge-111" A1 A2 SDM +Mono dd 3.3537 +Mono vk1 -0.025942 +Mono vk2 5.35166 +MakeWaveLength lambda Mono +MakeO2T O2T A3 A4 +#-------------------------------------------------------------------------- +# P R O C E D U R E S + +source tcl/log.tcl + +MakeDrive +SicsAlias drive dr +Publish LogBook Spy +MakeRuenBuffer +#---------------- TestVariables for Storage +VarMake SicsDataPath Text Mugger +SicsDataPath "$shome/sics/" +SicsDataPath lock +VarMake SicsDataPrefix Text Mugger +SicsDataPrefix test +SicsDataPrefix lock +VarMake SicsDataPostFix Text Mugger +SicsDataPostFix ".hdf" +SicsDataPostFix lock + +VarMake Adress Text User +VarMake phone Text User +VarMake fax Text User +VarMake email Text User +VarMake sample_mur Float User + +MakeDataNumber SicsDataNumber "$shome/sics/danu.dat" +#InitSANS $shome/sics/sansdict.dic +InitDMC + +MakeScanCommand xxxscan counter topsi.hdd recover.bin +MakePeakCenter xxxscan + + +MakeHM hm1 SIM +hm1 configure HistMode HRPT +hm1 configure OverFlowMode reflect +hm1 configure Rank 1 +#hm1 configure Length 400 +hm1 configure Length 65536 +hm1 configure dim0 256 +hm1 configure dim1 256 +hm1 configure BinWidth 4 +hm1 preset 100. +hm1 CountMode Timer +#hm1 configure HMComputer lnse02.psi.ch +#hm1 configure HMPort 2400 +#hm1 configure Counter counter +hm1 init + +MakeHM hm2 SIM +hm2 configure HistMode HRPT +hm2 configure OverFlowMode reflect +hm2 configure Rank 1 +#hm2 configure Length 400 +hm2 configure Length 65536 +hm2 configure dim0 256 +hm2 configure dim1 256 +hm2 configure BinWidth 4 +hm2 preset 100. +hm2 CountMode Timer +#hm2 configure HMComputer lnse02.psi.ch +#hm2 configure HMPort 2400 +#hm2 configure Counter counter +hm2 init + +MakeHM hm3 SIM +hm3 configure HistMode HRPT +hm3 configure OverFlowMode reflect +hm3 configure Rank 1 +#hm3 configure Length 400 +hm3 configure Length 65536 +hm3 configure dim0 256 +hm3 configure dim1 256 +hm3 configure BinWidth 4 +hm3 preset 100. +hm3 CountMode Timer +#hm3 configure HMComputer lnse02.psi.ch +#hm3 configure HMPort 2400 +#hm3 configure Counter counter +hm3 init + + ClientPut "Installed 4-circle stuff" #source transact.tcl #Publish transact Spy -#MakeSPS suff lnsp26.psi.ch 4000 7 +MakeSPS sps lnsa12.psi.ch 4000 4 #source beamdt.tcl #------------- C804-DC motors @@ -365,9 +643,9 @@ ChopperAdapter phase choco phase 0 90. ChopperAdapter ratio choco ratio 0 6. #-------- SANS Cooker -MakeChopper cooker sanscook lnsa10 4000 11 -ChopperAdapter cookp cooker mp 0 400 -ChopperAdapter cookz cooker mz 0 400 +#MakeChopper cooker sanscook lnsa10 4000 11 +#ChopperAdapter cookp cooker mp 0 400 +#ChopperAdapter cookz cooker mz 0 400 source chosta.tcl @@ -400,3 +678,4 @@ MakeLin2Ang a5l a5 #source tmp/beam.tcl source tcl/wwwpar.tcl +source bef.tcl diff --git a/trics.dic b/trics.dic index 57d1328f..998fc329 100644 --- a/trics.dic +++ b/trics.dic @@ -35,7 +35,7 @@ source0 = /frame0000,NXentry/TRICS,NXinstrument/SINQ,NXsource/NXVGROUP monodes = /frame0000,NXentry/TRICS,NXinstrument/monochromator,NXcrystal/SDS \ description -type DFNT_UINT8 -rank 1 -dim {132} monolambda = /frame0000,NXentry/TRICS,NXinstrument/monochromator,NXcrystal/SDS \ - lambda -attr {units,Angstroem} + wavelength -attr {units,Angstroem} monotheta = \ /frame0000,NXentry/TRICS,NXinstrument/monochromator,NXcrystal/SDS theta \ -attr {units,degrees} @@ -46,15 +46,15 @@ mono0 = \ /frame0000,NXentry/TRICS,NXinstrument/monochromator,NXcrystal/NXVGROUP #------------------------- CountControl framepreset = \ - /$(framename),NXentry/TRICS,NXinstrument/count_control,NXcounter/SDS preset + /$(framename),NXentry/TRICS,NXinstrument/count_control,NXmonitor/SDS preset framemode = /$(framename),NXentry/TRICS,NXinstrument/count_control,NXcounter/SDS countmode \ -type DFNT_UINT8 -rank 1 -dim {132} framemonitor = /$(framename),NXentry/TRICS,NXinstrument/count_control,NXcounter/SDS monitor \ -type DFNT_INT32 #------------------------ Detector dnumber = detector1 -framedim1 = 128 -framedim2 = 128 +framedim1 = 256 +framedim2 = 256 ddescription = /frame0000,NXentry/TRICS,NXinstrument/$(dnumber),NXdetector/SDS \ name -type DFNT_UINT8 -rank 1 -dim {132} detectorx = /frame0000,NXentry/TRICS,NXinstrument/$(dnumber),NXdetector/SDS x \ @@ -72,7 +72,7 @@ frametilt = /$(framename),NXentry/TRICS,NXinstrument/$(dnumber),NXdetector/SDS -attr {units,degrees} framecounts = /$(framename),NXentry/TRICS,NXinstrument/$(dnumber),NXdetector/SDS counts \ -attr {signal,1} -attr {units,counts} -type DFNT_INT32 \ - -rank 2 -dim {$(framedim1),$(framedim2)} + -LZW -rank 2 -dim {$(framedim1),$(framedim2)} detzerox = \ /frame0000,NXentry/TRICS,NXinstrument/$(dnumber),NXdetector/SDS x_zero_point \ -attr {units,pixel} @@ -100,6 +100,7 @@ frametemp = /$(framename),NXentry/sample,NXsample/SDS sample_temperature \ framestdev = /$(framename),NXentry/sample,NXsample/SDS \ sample_temperature_stdev #-------------- data -frame = /$(framename),NXentry/framedata,NXdata/NXVGROUP +frame = /$(framename),NXentry/$(dnumber),NXdata/NXVGROUP + + - \ No newline at end of file