- 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

@@ -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
+BINTARGET=.
-#HDFROOT=/data/koenneck
+HDFROOT=/data/koenneck
-#CC=cc
+CC=cc
-#EXTRA=
+EXTRA=
-#CFLAGS = -I$(HDFROOT)/include -Ihardsup  -I. -std1 -g -warnprotos -c
+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 \
+LIBS = -L$(HDFROOT)/lib -Lhardsup -lhlib -Lmatrix -lmatrix -Ltecs \
-#       -ltecsl -ltcl8.0 -lfor -lmfhdf -ldf $(HDFROOT)/lib/libjpeg.a \
+       -ltecsl -ltcl8.0 -lfor -lmfhdf -ldf $(HDFROOT)/lib/libjpeg.a \
-#       -lz  -lm -ll -lc 
+       -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
+#BINTARGET=$(HOME)/bin/linux.i686
-HDFROOT=/usr/local
+#HDFROOT=/usr/local
-CC=gcc
+#CC=gcc
-CFLAGS = -I$(HDFROOT)/include -Ihardsup -fwritable-strings \
+#CFLAGS = -I$(HDFROOT)/include -Ihardsup -fwritable-strings \
-  -DCYGNUS -DNONINTF -g -c
+#  -DCYGNUS -DNONINTF -g -c
-LIBS= -L$(HDFROOT)/lib  -Lhardsup  -Ltecs -ltecsl -Lmatrix -lmatrix -lhlib \
+#LIBS= -L$(HDFROOT)/lib  -Lhardsup  -Ltecs -ltecsl -Lmatrix -lmatrix -lhlib \
-       -ltcl8.0 -lmfhdf -ldf -ljpeg -lz -lm  -lg2c -ldl
+#       -ltcl8.0 -lmfhdf -ldf -ljpeg -lz -lm  -lg2c -ldl
-EXTRA=nintf.o
+#EXTRA=nintf.o
 #---------------------------------------------------------------------------
 
 .c.o:

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 <stdio.h>
 #include <ctype.h>
 #include <string.h>
+#include <zlib.h>
 #include <tcl.h>
+#include <time.h>
 #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);
+          if(self->iLogin)
-          SCInvoke(self,self->pSics,pPtr);
+	  {
-          CostaUnlock(self->pStack);
+	    /* 
-      /*    SCWrite(self,"\b",eError); */
+              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)

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);

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

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

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

devexec.c

@@ -832,9 +832,14 @@
 /*--------------------------------------------------------------------------*/
   int isInRunMode(pExeList self)
   {
-    assert(self);
+    if(self == NULL)
-    
+    {
-    return self->iRun;
+         return 0;
+    }     
+    else
+    {
+         return self->iRun;
+    }     
   }
 /*--------------------------------------------------------------------------*/
   SConnection *GetExeOwner(pExeList self)

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");

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);
 
 

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
 

hardsup/el734_utility.c

@@ -804,12 +804,12 @@
 #include    <string.h>
 
 #ifdef	__VMS
-  #include    <unixio.h>
+#include    <unixio.h>
 #else
-  #include    <unistd.h>
+#include    <unistd.h>
-  #ifdef FORTIFY
+#ifdef FORTIFY
-    #include    <fortify/fortify.h>
+#include    <fortify/fortify.h>
-  #endif
+#endif
 #endif
 /*-----------------------------------------------------------------*/
 #include    <rs232c_def.h>
@@ -2581,7 +2581,7 @@
 #include    <time.h>
     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;

hardsup/el737_utility.c

@@ -1711,7 +1711,7 @@
 #include    <time.h>
     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;

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);

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 <flag> of TOF edge-array
 	    */
 #define FLAG__VAR_BIN	0x01	/* Bin span of histogram is variable */
+	    /*
+	    ** ----------------------------------------------------------
+	    **		  Definition of bits in <flags> 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_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_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_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_SYNC3_MASK (0x00800000)	/* Mask for one of ext synch bits */
-#define LWL_HDR_BA_MASK	 (0x00f00000)	/* Mask for extr Binning Addr */
+#define LWL_HDR_SYNC2_MASK (0x00400000)	/* Mask for one of ext synch bits */
-#define LWL_HDR_TS_MASK	 (0x000fffff)	/* Mask for extr Time Stamp */
+#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 ..
+#define	LWL_FIFO_EMPTY	(0x1e000000)	/* FIFO Empty */
-					** .. extracting dgrm type + NRL bit */
+
+#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_TSI_MODE_MASK   (0x000e)	/* Mask for mode in Time Status Info */
-#define	LWL_TS_HM_NC	 (0x1f000000)	/* Hist-Mode/No-Coinc Time Stat Info */
+#define LWL_TSI_MODE_TR     (0x0000)	/* TSI Transparent-Mode */
-#define	LWL_TS_HM_TOF	 (0x1f000000)	/* TOF-Mode Time Status Info */
+#define LWL_TSI_MODE_HM	    (0x0002)	/* TSI Hist-Mode */
-#define	LWL_TS_SM_NC_TOF (0x1f000000)	/* Strobo-Mode/No-Coin Time Stat Info */
+#define LWL_TSI_MODE_TOF    (0x0004)	/* TSI TOF-Mode */
-
+#define LWL_TSI_MODE_SM1    (0x0006)	/* TSI Strobo-Mode 1 - time-stamp coded */
-#define	LWL_ETS_TR	(0x0e000000)	/* Transp-Mode Ext Time Status Info */
+#define LWL_TSI_MODE_TR_UD  (0x0008)	/* TSI Transparent-Mode Up-Down */
-#define	LWL_ETS_HM_C	(0x0e000000)	/* Hist-Mode+Coinc Time Status Info */
+#define LWL_TSI_MODE_HM_UD  (0x000a)	/* TSI Hist-Mode Up-Down */
-#define	LWL_ETS_SM_C	(0x0e000000)	/* Strobo-Mode+Coinc Time Status Info */
+#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	LWL_FIFO_EMPTY	(0x1e000000)	/* FIFO Empty */
 /*
 **------------------------------------------------------------------------------
 **				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,
+      uint		status;
-			sub_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	    n_hists, curr_hist;
-		usint	    curr_hist;
 		uint	    num_bins;
 		uint	    max_n_hists;
 		uint	    max_num_bins;
-		uchar	    max_srvrs;
+		uchar	    max_srvrs, act_srvrs, bytes_per_bin, compress;
-		uchar	    act_srvrs;
+		usint	    daq_now, filler_mask;
-		uchar	    bytes_per_bin;
+		uint	    max_block;
-		uchar	    compress;
+		usint	    tsi_status, flags;
-		usint	    daq_now;
+		union {
-		usint	    filler_mask;
+		  uint	    dead_time;
-		uint	    max_block;}		status;
+		  uint	    dts;
+		  uint	    both;
+			}   dt_or_dts;
+		uint	    num_bad_events;
+		uint	    up_time;}		status;
       } u;
     };
 /*

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;          

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;
  }
 

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);

network.c

@@ -47,6 +47,7 @@
 #include <netdb.h>
 #include <arpa/inet.h>
 #include <assert.h>
+#include <errno.h>
 
 #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;
          }
       }

nextrics.c

@@ -12,6 +12,8 @@
    copyright: see copyright.h
    
    Mark Koennecke, April 1998
+
+   Revised: Mark Koennecke, October 2000
 ----------------------------------------------------------------------------*/
 #include <stdlib.h>
 #include <assert.h>
@@ -30,12 +32,17 @@
 #include "udpquieck.h"
 #include "nextrics.h"
 
-#define DET1X 128  /* x -length of detector 1 */ 
+#define DET1X 256  /* x -length of detector 1 */ 
-#define DET1Y 128  /* y-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 */
+    /* new object descriptor and callback interface */
-    pNew->pDes = CreateDescriptor("NexTrics");
+    pNew->pDes = CreateDescriptor(HM1);
-    if(!pNew->pDes)
+    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;
   }                                                                   
+

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 <stdlib.h>
 #include <assert.h>
@@ -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);
+        /* create connection object */
-        if(iRet <= 0)
+        pRes = SCreateConnection(self->pMain->pSics,pNew,iRet);
+        if(!pRes)
         {
-                strcpy(pBuffer,"Timeout waiting for username/password");
+           SICSLogWrite("Failure to allocate new Connection",eInternal);
-                SICSLogWrite(pBuffer,eInternal); 
+           NETClosePort(pNew);
-        	NETClosePort(pNew);
+           free(pNew);
-        	free(pNew);
+           return 0;
-        	return 0;
         }
         else
         {
-             pUser = strtok(pBuffer," \t");
+           /* register the connection and create a task for it here */
-             pPasswd = strtok(NULL," \t\r\n"); 
+           NetReadRegister(self,pNew,command, pRes);
-             iRet = IsValidUser(pUser,pPasswd);
+           TaskRegister(self->pMain->pTasker,
-             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,
                               SCTaskFunction,
                               SCSignalFunction,
                               SCDeleteConnection,
                               pRes,
                               1);
-                 SCSendOK(pRes);             
+            SCSendOK(pRes);             
-                 return 1;
+            return 1;
-               }
-             }
         }
      }
      else

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");
   }
   
    

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;        
         }      
   }      
+
+
+
+
+

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[]);

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, 

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

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

sicsstat.tcl

@@ -1,406 +1,311 @@
-#Crystallographic Settings
+arx2 4.290000
-hkl lambda 0.703790
+arx2 setAccess 1
-hkl setub -0.124702 0.001618 -0.041357 -0.104448 -0.001326 0.049388 0.000751 0.084094 0.001574
+arx1 0.150000
-lastscancommand UNKNOWN
+arx1 setAccess 1
-lastscancommand setAccess 2
+mrx2 10.420000
-sample_mur 0.000000
+mrx2 setAccess 1
-sample_mur setAccess 2
+mrx1 0.280000
-email UNKNOWN
+mrx1 setAccess 1
-email setAccess 2
+lpa 0
-fax UNKNOWN
+lpa setAccess 2
-fax setAccess 2
+dt 0.000000
-phone UNKNOWN
+dt setAccess 2
-phone setAccess 2
+dqm 0.000000
-adress UNKNOWN
+dqm setAccess 2
-adress 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
+# Motor agl
-a33 SoftZero 0.000000
+agl SoftZero -0.490000
-a33 SoftLowerLim -10.000000
+agl SoftLowerLim -9.510000
-a33 SoftUpperLim 39.500000
+agl SoftUpperLim 10.490000
-a33 Fixed -1.000000
+agl Fixed -1.000000
-a33 sign 1.000000
+agl sign 1.000000
-a33 InterruptMode 0.000000
+agl InterruptMode 0.000000
-a33 AccessCode 2.000000
+agl AccessCode 2.000000
-# Motor a32
+# Motor sgu
-a32 SoftZero 0.000000
+sgu SoftZero 0.000000
-a32 SoftLowerLim -10.000000
+sgu SoftLowerLim -16.000000
-a32 SoftUpperLim 39.500000
+sgu SoftUpperLim 16.000000
-a32 Fixed -1.000000
+sgu Fixed -1.000000
-a32 sign 1.000000
+sgu sign 1.000000
-a32 InterruptMode 0.000000
+sgu InterruptMode 0.000000
-a32 AccessCode 2.000000
+sgu AccessCode 2.000000
-# Motor a31
+# Motor sgl
-a31 SoftZero 0.000000
+sgl SoftZero 1.550000
-a31 SoftLowerLim -10.000000
+sgl SoftLowerLim -17.549999
-a31 SoftUpperLim 39.500000
+sgl SoftUpperLim 14.450000
-a31 Fixed -1.000000
+sgl Fixed -1.000000
-a31 sign 1.000000
+sgl sign 1.000000
-a31 InterruptMode 0.000000
+sgl InterruptMode 0.000000
-a31 AccessCode 2.000000
+sgl AccessCode 2.000000
-# Motor ph
+# Motor mgl
-ph SoftZero 0.000000
+mgl SoftZero 1.300000
-ph SoftLowerLim 318.000000
+mgl SoftLowerLim -11.300000
-ph SoftUpperLim 0.000000
+mgl SoftUpperLim 8.700000
-ph Fixed -1.000000
+mgl Fixed -1.000000
-ph sign 1.000000
+mgl sign 1.000000
-ph InterruptMode 0.000000
+mgl InterruptMode 0.000000
-ph AccessCode 2.000000
+mgl AccessCode 2.000000
-# Motor chi
+# Motor atu
-chi SoftZero 0.000000
+atu SoftZero -0.880000
-chi SoftLowerLim 270.000000
+atu SoftLowerLim -16.120001
-chi SoftUpperLim 70.000000
+atu SoftUpperLim 17.879999
-chi Fixed -1.000000
+atu Fixed -1.000000
-chi sign 1.000000
+atu sign 1.000000
-chi InterruptMode 0.000000
+atu InterruptMode 0.000000
-chi AccessCode 2.000000
+atu AccessCode 2.000000
-# Motor ch
+# Motor atl
-ch SoftZero 0.000000
+atl SoftZero 0.000000
-ch SoftLowerLim 270.000000
+atl SoftLowerLim -17.000000
-ch SoftUpperLim 70.000000
+atl SoftUpperLim 17.000000
-ch Fixed -1.000000
+atl Fixed -1.000000
-ch sign 1.000000
+atl sign 1.000000
-ch InterruptMode 0.000000
+atl InterruptMode 0.000000
-ch AccessCode 2.000000
+atl AccessCode 2.000000
-# Motor a20
+# Motor stu
-a20 SoftZero 0.000000
+stu SoftZero 0.000000
-a20 SoftLowerLim 318.000000
+stu SoftLowerLim -30.000000
-a20 SoftUpperLim 0.000000
+stu SoftUpperLim 30.000000
-a20 Fixed -1.000000
+stu Fixed -1.000000
-a20 sign 1.000000
+stu sign 1.000000
-a20 InterruptMode 0.000000
+stu InterruptMode 0.000000
-a20 AccessCode 2.000000
+stu AccessCode 2.000000
-# Motor a10
+# Motor stl
-a10 SoftZero 0.000000
+stl SoftZero 0.000000
-a10 SoftLowerLim 270.000000
+stl SoftLowerLim -30.000000
-a10 SoftUpperLim 70.000000
+stl SoftUpperLim 30.000000
-a10 Fixed -1.000000
+stl Fixed -1.000000
-a10 sign 1.000000
+stl sign 1.000000
-a10 InterruptMode 0.000000
+stl InterruptMode 0.000000
-a10 AccessCode 2.000000
+stl AccessCode 2.000000
-# Motor th
+# Motor mtu
-th SoftZero 0.000000
+mtu SoftZero 2.850000
-th SoftLowerLim -17.000000
+mtu SoftLowerLim -19.850000
-th SoftUpperLim 69.000000
+mtu SoftUpperLim 14.150000
-th Fixed -1.000000
+mtu Fixed -1.000000
-th sign 1.000000
+mtu sign 1.000000
-th InterruptMode 0.000000
+mtu InterruptMode 0.000000
-th AccessCode 2.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 SoftZero -0.710000
-a4 SoftLowerLim -17.000000
+a4 SoftLowerLim -134.389999
-a4 SoftUpperLim 69.000000
+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 SoftZero 11.540000
-a3 SoftLowerLim -9.000000
+a3 SoftLowerLim -188.839996
-a3 SoftUpperLim 33.000000
+a3 SoftUpperLim 165.760010
 a3 Fixed -1.000000
 a3 sign 1.000000
 a3 InterruptMode 0.000000
 a3 AccessCode 2.000000
-# Motor a37
+# Motor a2
-a37 SoftZero 0.000000
+a2 SoftZero -0.010000
-a37 SoftLowerLim 0.000000
+a2 SoftLowerLim 33.109997
-a37 SoftUpperLim 555.000000
+a2 SoftUpperLim 120.010002
-a37 Fixed -1.000000
+a2 Fixed -1.000000
-a37 sign 1.000000
+a2 sign 1.000000
-a37 InterruptMode 0.000000
+a2 InterruptMode 0.000000
-a37 AccessCode 2.000000
+a2 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 a1
-a1 SoftZero 0.000000
+a1 SoftZero 0.590000
-a1 SoftLowerLim 120.000000
+a1 SoftLowerLim -0.590000
-a1 SoftUpperLim 15.000000
+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

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 SoftZero 0.000000
-d1r SoftLowerLim -22.000000
+d1r SoftLowerLim -20.000000
-d1r SoftUpperLim 18.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 SoftZero 0.000000
-stu SoftLowerLim -20.000000
+stu SoftLowerLim -30.000000
-stu SoftUpperLim 40.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

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__ */
+

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

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_ */
+

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

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

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 -------------------------------*/
+@<tasdata@>
+
+/*---------------------- interface ----------------------------------*/
+@<tasfunc@>
+#endif
+@}

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 <stdlib.h>
+#include <assert.h>
+#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; 
+}
+

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 <stdlib.h>
+#include <assert.h>
+#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;
+}
+
+

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 <stdlib.h>
+#include <assert.h>
+#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;
+}             
+

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
+#MakeHM banana SINQHM
-banana configure OverFlowMode    reflect
+#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 HMComputer lnse02.psi.ch
-#banana configure HMPort 2400
+banana configure HMPort 2400
-#banana configure Counter counter
+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
+#MakeChopper cooker sanscook lnsa10 4000 11
-ChopperAdapter cookp   cooker mp 0 400
+#ChopperAdapter cookp   cooker mp 0 400
-ChopperAdapter cookz   cooker mz 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

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
+framedim1 = 256
-framedim2 = 128
+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
+
+ 
 
-