linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

- Updated Makefiles

Browse Source 
- Moved TAS code to psi
- Updated programmers documentation


SKIPPED:
	psi/make_gen
	psi/nextrics.c
	psi/t_conv.c
	psi/t_conv.f
	psi/t_rlp.c
	psi/t_rlp.f
	psi/t_update.c
	psi/t_update.f
	psi/hardsup/el734_utility.c
	psi/hardsup/makefile_alpha
This commit is contained in:
cvs
2003-06-30 11:51:35 +00:00
parent 007a2e2536
commit e52bd5d937
17 changed files with 1561 additions and 3655 deletions
Download Patch File Download Diff File Expand all files Collapse all files

131
Makefile
View File

@ -1,131 +0,0 @@
#----------------------------------------------------------------------------
# Makefile for SICS
#
# Mark Koennecke 1996-2001
# Markus Zolliker March 2000: add tecs
#---------------------------------------------------------------------------
#------- comment or uncomment this if a fortified version is required.
# Note: A -DFORTIFY needs to be added to the CFLAGS as well.
#
#FORTIFYOBJ = fortify.o strdup.o
#----
FORTIFYOBJ =
#---------------------------------------------------------------------------
#==========================================================================
# assign if the National Instrument GPIB driver is available
#NI= -DHAVENI
#NIOBJ= nigpib.o
#NILIB=-lgpibenet
NI=
NIOBJ=
NILIB=
#----- comment or uncomment if a difrac version is required
# Do not forget to remove or add comments to ofac.c as well if changes
# were made here.
DIFOBJ=
DIFIL=
#DIFOBJ=difrac.o -Ldifrac -ldif -lfor
#----
#DIFOBJ=difrac.o -Ldifrac -ldif
#DIFIL= difrac.o
#---------------------------------------------------------------------------
COBJ = Sclient.o network.o ifile.o intcli.o $(FORTIFYOBJ)
SOBJ = network.o ifile.o conman.o SCinter.o splitter.o passwd.o \
servlog.o sicvar.o nserver.o SICSmain.o \
sicsexit.o costa.o task.o $(FORTIFYOBJ)\
macro.o ofac.o obpar.o obdes.o drive.o status.o intserv.o \
devexec.o mumo.o mumoconf.o selector.o selvar.o fupa.o lld.o \
lld_blob.o buffer.o strrepl.o ruli.o lin2ang.o fomerge.o\
script.o o2t.o alias.o napi45.o nxdata.o stringdict.o sdynar.o\
histmem.o histdriv.o histsim.o sinqhmdriv.o interface.o callback.o \
event.o emon.o evcontroller.o evdriver.o simev.o perfmon.o \
danu.o itc4driv.o itc4.o nxdict.o nxsans.o varlog.o stptok.o nread.o \
dilludriv.o scan.o fitcenter.o telnet.o token.o scontroller.o serial.o \
tclev.o hkl.o integrate.o optimise.o dynstring.o nextrics.o nxutil.o \
mesure.o uubuffer.o serialwait.o commandlog.o sps.o udpquieck.o \
sanswave.o faverage.o bruker.o rmtrail.o fowrite.o ltc11.o \
simchop.o choco.o chadapter.o docho.o trim.o eurodriv.o scaldate.o \
hklscan.o xytable.o amor2t.o nxamor.o amorscan.o amorstat.o \
circular.o el755driv.o maximize.o sicscron.o tecsdriv.o sanscook.o \
tasinit.o tasutil.o t_rlp.o t_conv.o d_sign.o d_mod.o \
tasdrive.o tasscan.o synchronize.o definealias.o swmotor.o t_update.o \
hmcontrol.o userscan.o slsmagnet.o rs232controller.o lomax.o \
polterwrite.o fourlib.o motreg.o motreglist.o anticollider.o \
s_rnge.o sig_die.o gpibcontroller.o $(NIOBJ) ecb.o ecbdriv.o \
ecbcounter.o hmdata.o tdchm.o nxscript.o A1931.o frame.o
MOTOROBJ = motor.o el734driv.o simdriv.o el734dc.o pipiezo.o pimotor.o
COUNTEROBJ = countdriv.o simcter.o counter.o
DMCOBJ = dmc.o
VELOOBJ = velo.o velosim.o velodorn.o velodornier.o
.SUFFIXES:
.SUFFIXES: .tcl .htm .c .o
#----- comment or uncomment the following according to operating system
#------------- for Digital Unix
BINTARGET = bin
HDFROOT=/data/lnslib
CC=cc
EXTRA=
CFLAGS = -I$(HDFROOT)/include -Ihardsup -DHDF4 -DHDF5 -I. -std1 \
-check_bounds -g -warnprotos -c
#CFLAGS = -I$(HDFROOT)/include -DFORTIFY -DHDF4 -DHDF5 -Ihardsup -g \
# -std1 -warnprotos -c
LIBS = -L$(HDFROOT)/lib -Lhardsup -lhlib -Lmatrix -lmatrix -Ltecs \
-ltecsl -ltcl8.0 -lfor $(HDFROOT)/lib/libhdf5.a \
$(HDFROOT)/lib/libLNSmfhdf.a $(HDFROOT)/lib/libLNSdf.a \
$(HDFROOT)/lib/libLNSjpeg.a -lLNSz -lm -ll -lc
#------- for cygnus
#HDFROOT=../HDF411
#CC=gcc
#EXTRA=
#CFLAGS = -I$(HDFROOT)/include -Ihardsup -DFORTIFY -DCYGNUS -g -c
#LIBS= -L$(HDFROOT)/lib -Lhardsup -lhlib -ltcl80 \
# -lmfhdf -ldf -ljpeg -lz -lm
#---------- for linux
#BINTARGET=../../bin
#HDFROOT=$(SINQDIR)/linux
#CC=gcc
#CFLAGS = -I$(HDFROOT)/include -DHDF4 -DHDF5 $(NI) -Ihardsup \
# -fwritable-strings -DCYGNUS -DNONINTF -g -c
#CFLAGS = -I$(HDFROOT)/include -DFORTIFY -DHDF4 -DHDF5 $(NI) -Ihardsup \
# -fwritable-strings -DCYGNUS -DNONINTF -g -c
#LIBS= -L$(HDFROOT)/lib -Lhardsup -Ltecs -ltecsl -Lmatrix -lmatrix -lhlib \
# $(NILIB) -ltcl -lhdf5 -lmfhdf -ldf -ljpeg -lz -lm -lg2c -ldl
#EXTRA=nintf.o
#---------------------------------
.c.o:
$(CC) $(CFLAGS) $*.c
all: $(BINTARGET)/SICServer
$(BINTARGET)/SICServer: $(SOBJ) $(MOTOROBJ) \
$(COUNTEROBJ) $(DMCOBJ) $(VELOOBJ) $(DIFIL) \
$(EXTRA) tecs/libtecsl.a hardsup/libhlib.a \
matrix/libmatrix.a
$(CC) -g -o SICServer \
$(SOBJ) $(MOTOROBJ) $(COUNTEROBJ) $(DMCOBJ) \
$(VELOOBJ) $(DIFOBJ) $(EXTRA) $(LIBS)
cp SICServer $(BINTARGET)
clean:
- rm -f *.o
- rm -f $(BINTARGET)/SICServer
Dbg.o: Dbg.c
cc -g -I/data/koenneck/include -c Dbg.c
Dbg_cmd.o: Dbg_cmd.c

637
doc/programmer/command.tex Normal file
View File

@ -0,0 +1,637 @@
\chapter{Writing new SICS Commands}
If you wish to write a new command or add a completely new piece of hardware to
SICS, this is the chapter to study. There are two ways to implement
new commands into SICS: hrough the internal Tcl scripting language and
in ANSI--C. This section describes command writing in ANSI--C. You
should consider using Tcl when:
\begin{itemize}
\item The new command is very instrument specific. Rather extend a
SICS command in order to support your script.
\item The new command is a local syntax fudge.
\item The hardware device is an auxiliary, such a He level meter
etc.
\end{itemize}
On the other hand there are indications when to write in ANSI--C:
\begin{itemize}
\item Complex calculations need to be carried out.
\item Large amounts of data need to be handled.
\item The code requires extensive bit twiddling.
\item A new general SICS facility is provided.
\end{itemize}
\section{Mapping Object Oriented Concepts into ANSI--C}
SICS is in principle an object oriented system. However, it is implemented
in ANSI--C. Therefore object oriented concepts must be mapped into C. The
three object oriented concepts which need to be mapped are:
\begin{itemize}
\item Data Encapsulation.
\item Polymorphism.
\item Inheritance.
\end{itemize}
Of these, data encapsulation is by far the most important concept. Objects
in computer science can be understood as little boxes which contain some
data describing their state and which understand messages sent by other
objects. If such a message comes in, the object performs some action,
perhaps changes its internal state or sends new messages to other objects.
It is understood that changes to the internal data of the object can be
achieved only through messages to the object and not by directly manipulating
variables from the outside. In ANSI--C an object maps to a structure holding
the objects data and the messages map to functions which act upon the data
structure. In order to do this, the functions must take a pointer to the
objects data structure as first parameter. In order to prevent messing with
an objects data structure, only a pointer to a structure is declared in the
header file. The actual definition of the data structure happens only in
the implementation file. All functions belonging to an object are defined in that
implementation file and have full access to the data structure.
Users of the object see only the header file and thus only a pointer to the
objects data structure which prevents
them from messing with the objects data directly.
In order to illustrate the concepts lets look at
a primitive integer object defined in such a way.
\begin{verbatim}
/*-----------------------------------------------------------------------
ExampleInt.h
------------------------------------------------------------------------*/
typedef struct __ExampleInt *pExampleInt;
int GetInt(pExampleInt self);
void SetInt(pExampleInt self, int iNew);
/*------------------- EOF ExampleInt.h---------------------------------*/
/*----------------------------------------------------------------------
ExampleInt.c, Implementation file
-----------------------------------------------------------------------*/
typedef struct __ExampleInt {
int iExample;
} ExampleInt;
/*--------------------------------------------------------------------*/
int GetInt(pExampleInt self)
{
return self->iExample;
}
/*---------------------------------------------------------------------*/
void SetInt(pExampleInt self, int iNew)
{
self->iExample = iNew;
}
\end{verbatim}
Using this scheme all code changing the internal state of an object lives
in one file. Changes to the objects data structure affect only the
implementation file and no other files.
This scheme is used for almost all SICS objects. A few system objects and
older SICS objects define their data structures in header files. This is
either a relic or had to be done for performance reasons.
The next concept is polymorphism. This describes the situation when a group
of objects respond to the same message but doing different things. For
instance a whole set of objects would implement a write functionality
which writes the objects state to a file. Higher level would then not need
to know of which type the actual object is, it just can send the write message
and the rest is taken care of by the object. This concept is used for all
hardware drivers in SICS. Mapping this to C requires to expose the objects
data structure and let the data structure include a pointer to that polymorphic
function. As an example, the ExampleInteger with a write function:
\begin{verbatim}
/*-----------------------------------------------------------------------
ExampleInt.h
------------------------------------------------------------------------*/
typedef struct __ExampleInt{
int iExample;
void (*write)(struct __ExampleInt *self, FILE *fd);
} *pExampleInt, ExampleInt;
pExampleInt MakeInt(int iNew);
int GetInt(pExampleInt self);
void SetInt(pExampleInt self, int iNew);
/*------------------- EOF ExampleInt.h---------------------------------*/
/*----------------------------------------------------------------------
ExampleInt.c, Implementation file
-----------------------------------------------------------------------*/
static void ExampleWrite(struct _-ExampleInt *self, FILE *fd)
{
fprintf(fd,"INT = %d",self->iExample);
}
/*---------------------------------------------------------------------*/
pExampleInt MakeInt(int iNew)
{
pExampleInt pNew = NULL;
pNew = (pExampleInt)malloc(sizeof(ExampleInt));
pNew->iExample = iNew;
pNew->write = ExampleWrite;
return pNew;
}
.
.
.
\end{verbatim}
This can then be called:
\begin{verbatim}
void SomeFunc()
{
pExampleInt pTest;
pTest = MakeInt(25);
.
.
.
pTest->write(pTest,fd);
}
\end{verbatim}
This example also illustrates the concept of a special function which creates
a new object of the appropriate type and initializes its data structure
properly.
The last concept to discuss is inheritance. Inheritance can be used when
an object is a derivative of another object. For instance a truck is a
derivative of a motor car. Much of the behavior of a motor car will be the
same as for a truck. In order to prevent rewriting of code, the truck
should use the same data structures and code as the motor car. And add
or modify only what is special. Inheritance is not much used in SICS. It can
be implemented by overlaying data structures. This means the derived
classes data structure has the same fields in the same order as the parent
class and adds its specials at the end. For example:
\begin{verbatim}
typedef struct __MotorCar {
int iWheels;
float fSpeed;
} *pMotorCar, MotorCar;
typedef struct __Truck {
int iWheels;
float fSpeed; /* same as MotorCar */
double dPayLoad; /* special for Truck */
} *pTruck, Truck;
\end{verbatim}
Thus functions defined for motor car can operate on trucks as well.
For more details study the relationship between the ITC4 controller and
general environment controllers. This is the only place where SICS
currently uses inheritance.
\section{Command Writing Basics}
\subsubsection{The Object Wrapper Function}
The first thing needed in order to implement a new command in SICS is
the object wrapper function. This function has the following
signature:
\begin{verbatim}
int ObjectWrapper(SConnection *pCon, SicsInterp *pSics, void *pData,
int argc, char *argv[]);
\end{verbatim}
The parameters are:
\begin{description}
\item[pCon] A pointer to the connection object representing the client
invoking this command.
\item[pSics] A pointer to the SICS interpreter.
\item[pData] A pointer to a user data structure for this object. Can
be NULL if no such thing exists.
\item[argc] Number of arguments in argv to this function.
\item[argv] Arguments to this function. The argc, argv scheme is
the same as for a C--language main function. The first argument is
always the name of the object.
\end{description}
This object wrapper function must evaluate its arguments, do what it
is meant to do and write any results to the client connection. In the
case of an error this function must return 0, in case of success 1.
\subsubsection{The Object Data Structure}
Only the most primitive objects or commands get away without an own
data structure. Usually a data structure will be needed by SICS
objects in order to keep configuration parameters etc. A pointer to
such a datastructure is passed into the object wrapper function as the
pointer pData. This object data structure has to fulfill some
conditions in order to live happily within SICS. And actually, not
only the datastructure is needed but also a function which is able to
release any memory allocated by the datastructure. SICS needs this
function in order to clean things up properly.
A valid SICS object structure has to look like this:
\begin{verbatim}
typedef struct __MyObject {
pObjectDescriptor pDes;
int iMyExtremlyImportantInt;
.
.
.
} MyObject;
\end{verbatim}
Please note that the first item in the data structure MUST be a
pointer to an SICS object descriptor. Add your own stuff below
that. If you do not adhere to this requirement, SICS will dump core on
you rather sooner then later.
SICS needs this object descriptor for its own internal purposes. The
object descriptor is again a data structure with this signature:
\begin{verbatim}
typedef struct {
char *name;
int (*SaveStatus)(void *self, char *name,FILE *fd);
void *(*GetInterface)(void *self, int iInterfaceID);
} ObjectDescriptor, *pObjectDescriptor;
\end{verbatim}
\begin{description}
\item[name] This is a type identifier for the object. SICS uses this
identifier for run time type identification (RTTI). For example this
field says Motor for motors, Counter for counters etc.
\item[SaveStatus] is the function called by the SICS status backup
mechanism. The default implementation of this function does
nothing. But if your new object has to store configuration commands
into the status file you should create an own function with the same
signature and assign this function to the object descriptors
SaveStatus. A suitable function will print the necessary commands to
achieve the same configuration as the current state into the file
represented by fd.
\item[GetInterface] SICS objects can have various capabilities: a
motor can be driven or scanned, you may count on a counter etc. Such
capabilities are expressed as interfaces(see \ref{interface}) in SICS.
There is an integer ID for each of those interfaces. GetInterface now
returns a suitable
interface in return for a given interface ID or NULL if the object
does not implement the interface. The default version of this function
retuns NULL always. If your object implements an interface, this
function has to be overloaded to return this interface on demand.
\end{description}
A default object descriptor can be created with:
\begin{verbatim}
pObjectDescriptor CreateDescriptor(type);
\end{verbatim}
with type being the object type identifier. A descriptor can be
deleted with:
\begin{verbatim}
DeleteDescriptor(pDes);
\end{verbatim}
As already mentioned, a function to release any memory allocated for
the object data structure is also needed. Its signature is simple:
\begin{verbatim}
void KillObject(void *pdata);
\end{verbatim}
with pdata being the object to delete.
\subsection{Installing the new Command into the SICS Interpreter}
A new command can be installed into SICS with the function:
\begin{verbatim}
int AddCommand(SicsInterp *pSics,
char *name,
ObjectFunc ofunc,
KillFunc killo,
void *objectData);
\end{verbatim}
with pSics being the interpreter into which to install the command,
name the name of the command, ofunc its wrapper function, killo the
object data structure deletion function and objectData being a pointer
to the object data structure. If no data structure is defined for the
command, killo and objectData must be NULL.
Now the question arise where AddCommand has to be placed. Various
cases have to be distinguished: The first case is that the new command
is relevant to SICS users in all corners of the world. Then the new
command should be added to the function InitIniCommand in file
ofac.c.
The second case is that the command is specific to a certain
instrument or a special hardware or implements a local fashion of
dealing with things. Then the new command should be installed from the
function AddSiteCommand in the site data structure (see \ref{site}).
Another scheme becomes valid when multiple instances of the object
need to be created. \label{factory} For instance the object represents
a motor of which you may have many. Then it is useful to create a factory
command. This is a special SICS command which creates the desired
objects and installs them in the interpreter. This factory command
then has to be installed according to the logic given above. Usually
such objects are installed in the SICS initialization file. After
processing this initialization file the factory command is not useful
any longer. Then such factory commands should be removed from the
interpreter with:
\begin{verbatim}
RemoveCommand(SicsInterp *pSics, char *name);
\end{verbatim}
This has to be placed into the sites member function RemoveSiteCommand
or into KillIniCommand in ofac.c, depending where you installed the
command in the first place.
Be careful with commands for deleting objects though. SICS objects may
be aliased, used by other objects or connected through the callback
interface (see \ref{inter}). SICS does not implement proper
bookeeping on all these relationships and thus deleting a command from
SICS without taking this into account may cause SICS to dump core on
you.
\section{Interacting with the Client Connection}
A SICS command writer needs to interact with the client connection for
a variety of reasons:
\begin{itemize}
\item To write error messages and other output
\item To prompt for more data
\item To check if the user has appropriate privileges for the command
implemented.
\item To tell upper level code that something went very wrong.
\end{itemize}
As these tasks are so common you will find that the connection object
has to be passed frequently into lower level code as an argument.
\subsection{Writing and Reading to the Client}
All I/O to the client has to be processed through the I/O functions
for connections defined in conman.h and implemented in conman.c. The
most bable of these are SCWrite and SCPrompt.
These function will now be inspected in more detail:
\begin{verbatim}
int SCWrite(SConnection *pCon, char *pText, int eCode);
int SCPrompt(SConnection *pCon, char *pPrompt, char *pBuffer, int iBufLen);
\end{verbatim}
SCWrite writes the data pText to the connection specified by pCon. The
parameter eCode denotes the output code of the data in pText. SICS clients
can choose to suppress some I/O from the SICS server. For instance a
GUI--client might chooses not to receive scan status reports. For this
purpose it was necessary to stick an output code onto each message to the
client. Possible output codes are: eError, eWarning, eValue, eStatus and
some internal codes. The names are self explaining. eValue denotes a value
which has been explicitly asked for by the client. The rule specified above
becomes understandable and thus bearable when looking at all the things
SCWrite does with the message:
\begin{itemize}
\item It is written to the client connection socket, subject to the output
code specified.
\item The message is written to all log files configured for the client
connection.
\item If the client privilege is useer or manager, the data isw ritten
to the command log.
\item The message is written to the server log together with the socket
number of the connection.
\item SCWrite stores the message into the Tcl macro interpreter in order to
enable processing of data from SICS commands in Tcl scripts.
\item SCWrite suppresses all messages to the client while executing a macro.
This stops spurious output to appear at the client connection when running a
command defined in the macro language. The exception are messages of type
eError and eWarning. Such messages are always sent to the client.
\end{itemize}
SCPrompt prompts the user at the client connection for data. The prompt
string pPrompt is sent. Data entered by the user is returned in buffer
pBuffer. Maximum iBufLen character are returned. While waiting for client to
provide data, the SICS task switcher runs.
There is another convenience function SCSendOK(SConnection *pCon) which is
just a wrapper around SCWrite. SCSendOk sends an 'OK' to the client. It is good
practice to let the user know that the operation requested had been
performed.
There are some more conventions which are useful to adhere to:
\begin{itemize}
\item All error messages start with the string ERROR:
\item All warnings start with the string WARNING:
\item All requested values are returned in the format name = value.
\end{itemize}
There exist special functions to send mass data through a connection
in either uuencoded or zipped form. The latter works only through
plain socket connections, telnet will mess up binary data. Please
note, that numeric data sent by the SICS server needs to be in network
byte order in order to be understood by the Java clients. Further
functions allow to tailor writing behavious further by overloading the
operations performed by SCWrite. This is documented in conman.h
\subsection{Checking Client Privileges}
One task any SICS object has to perform is to check if a client,
represented through a connection object, is privileged to perform a
requested operation. The most useful function to do this is:
\begin{verbatim}
int SCMatchRights(SConnection *pCon, int rights);
\end{verbatim}
This function not only checks if the user has at least the user rights
given as parameter rights but also checks if the SICS server is
currently performing a scan or something. It is generally a bad idea
to change parameters while the instrument is taking a measurement. If
all is good 1 is returned, 0 in case of trouble. All troubles will
already have been reported to the client by this function. SICS knows
four levels of user rights:
\begin{description}
\item[usSpy] may look at things but change nothing.
\item[usUser] may do those things a normal user is supposed to do.
\item[usMugger] may perform configuration tasks.
\item[usInternal] absolutely no restrictions, used only internally.
\end{description}
There are further functions for requesting client and setting client
rights codes. These functions are all defined in conman.h.
\subsection{Interrupting}
On occasion a SICS object may come to the conclusion that an error is
so bad that the measurement needs to be stopped. Clearly a means is
needed to communicate this to upper level code. This means is setting
an interrupt on the connection.
The current interrupt active interrupt is located at the connection object
and can be retrieved with {\bf SCGetInterrupt} and set with {\bf
SCSetInterrupt}. Interrupt codes are defined in interrupt.h and are ordered
into a hierarchy:
\begin{description}
\item[eContinue] Everything is just fine.
\item[eAbortOperation] Stop the current scan point or whatever is done,
but do not stop altogether.
\item[eAbortScan] Abort the current scan, but continue processing of further
commands in R\"unbuffers or command files.
\item[eAbortBatch] Aborts everything, operations, scans and batch processing
and leaves the system ready to enter new commands.
\item[eHaltSystem] As eAbortBatch, but lock the system.
\item[eFreeSystem] Unlocks a system halted with eHaltSystem.
\item[eEndServer] Makes the SICS server run down and exit.
For internal usage only.
\end{description}
Higher level SICS objects may come to the conclusion that the error
reported by lower level code is actually not that critical and clear
any pending interrupts by setting the interrupt code to eContinue and
thus consume the interrupt.
\subsection{Communicating with all Clients}
Two facilities exist which allow one SICS command to reach out to all
connected clients.
\begin{itemize}
\item There is a function which writes a message to all clients. This
is ServerWriteGlobal(char *text, int outCode);
\item There exists a global status code which can be set with
SetStatus and retrieved with GetStatus. See status.h for more
details. Use this when your SICS command starts lengthy operations
such as driving or counting.
\end{itemize}
\section{Using other SICS Objects}
In most cases a new command needs to make use of other SICS
objects. Before another SICS object can be used, it must be found
within the SICS interpreter. In order do this the name of the object
is obviously needed. This must be a configuration parameter or passed
in as a argument to the command. In general it is also necessary to
check if this name points to the right type of object. All this can be
achieved with the function:
\begin{verbatim}
void *FindCommandData(SicsInterp *pSics, char *name, char *type);
\end{verbatim}
This function tries to find a command name in the interpreter and also
checks if the objects type descriptor (the name parameter in the
object descriptor structure) matches type. If this is so, a pointer to
the objects data structure is returned. If one of the test fails, NULL
is returned. Suitable parameters for type can be found by searching
for CreateDescriptor in the implementation file of the desired
object. After a cast to the proper pointer type, all the functions
defined for the object and documented in its header file can be used.
\subsection{Running Motors and Counters}
There are special rules which apply if a new command is written which
coordinates motors and counters. For instance a special scan or drive
command. It is important that such higher level code starts motors,
virtual motors and counters through the interfaces defined by the
device executor. The device executor guarantees proper monitoring of
the device. The relevant functions are:
\begin{verbatim}
int StartMotor(pExeList self, SicsInterp *pSics, SConnection *pCon,
char *name, float fNew);
int StartCounter(pExeList self, SicsInterp *pSics, SConnection
*pCon, char *name);
\end{verbatim}
StartMotor starts the motor name to run to the new value
fNew. StartCounter starts the counter name. The counter must have been
loaded with proper presets etc. with the appropriate function
calls. The device executor hides behind the pExeList pointer. This is
always accessible through the global pointer: pServ->pExecutor.
Once a counter or motor has been started, quite often the command can
only continue if the operation has finished. But during this time the
SICS server should be responsive to other clients. In order to do this
we have to wait for the device executor task to finish. A code
fragment implementing all this for a count operation is shown below:
\begin{verbatim}
/*-------------- count */
iRet = StartCounter(pServ->pExecutor, pSics,
pCon,
``ScanCounter'');
if(!iRet)
{
SCWrite(self->pCon,"ERROR: Cannot Count, Scan aborted",eError);
return 0;
}
/* get the ID of the device executor task */
lTask = GetDevexecID(pServ->pExecutor); /* get ID of device
executor task */
if(lTask > 0);
{
/* wait for the device executor to finish */
TaskWait(pServ->pTasker,lTask);
}
/* finished, check for interrupts. Whatever happened, user
interrupt or HW interrupt, it will be on our connection
*/
iInt = SCGetInterrupt(self->pCon);
switch(iInt)
{
case eContinue:
break;
case eAbortOperation:
continue;
break;
case eAbortScan:
SCWrite(self->pCon,"ERROR: Scan aborted",eError);
/* eat the interrupt, the requested op has been
done
*/
SCSetInterrupt(self->pCon,eContinue);
return 0;
break;
default: /* all others */
SCWrite(self->pCon,"ERROR: Scan aborted",eError);
return 0;
break;
}
\end{verbatim}
This code also shows the necessary error checking. It also shows how
to check for possible interrupts after such an operation. It is very
advisable to do this because the user may have interrupted the
process. And she might not be all to happy if the new command just
continues with the next step rather then aborting the process.
\section{SICS Interfaces}\label{interface}
The point about SICS interfaces can best be deduced from an example:
Everybody expects that a motor can be operated through a drive command
or scanned in a scan. But there are other things which should be
operated through a drive or scan commands too: environment controllers
(temperature), virtual motors, chopper speeds, chopper phases and
possibly other things. In order to make upper level scan or drive
commands independent of the implementation of the actual operation it
is useful to have an abstract interface for everything which can be
driven or scanned. This is the drivable interface. Any such object
which should be driven or scanned has to implement this interface.
Several of these interfaces exist in SICS:
\begin{description}
\item[Drivable] The drivable interface for everything which can be
moved and takes some time to complete its movement.
\item[Countable] Everything which counts: counters, histogram memories
etc.
\item[Environment] An interface which allows for monitoring of a
parameter through the environment monitor. Usually these are sample
environment things but it could also be chopper phases etc.
\item[Callback] This is an interface which allows object A to call a
special function, the callback function, in the context of object B
whenever a certain event in A occurs. This is a way to automatically
link object together in a component programming manner. This is also
used for automatic notification of status clients when instrument
parameters change.
\end{description}
There are several situations when the SICS interfaces have to be
considered:
\begin{itemize}
\item When hacking SICS kernel code or replacing parts of it.
\item The driveable interface should be implemented by virtual
motors. Virtual motors are objects which realize complex movements
possibly involving multiple motors. Examples include driving
wavelength (theta,two theta and possbly curvature motors have to be
moved) or omega two theta.
\item Any time objects are introduced into SICS which repesent
completely new hardware.
\item When automatical notifications between objects are needed, use
the callback interface.
\end{itemize}
Adding any such interface to your new SICS object involves the
following steps:
\begin{itemize}
\item Add a data structure representing the interface to your objects
data structure.
\item Write all the functions required by the interface.
\item Populate the interface data structure with the pointers to your
function implementations.
\item Write a new GetInterface function for the object descriptor
which returns your new interface when requested and assign it to your
object descriptors GetInterface field. SICS needs this in order to be
able to find the objects new interface.
\end{itemize}
The interfaces available are documented in the files interface.w,
interface.h and interface.tex in the main SICS directory and through
numerous examples in the source code.
A not overly complex example for the implementation of an interface is
the code in o2t.* which implements the coupled driving of two motors
where the second is always the double of the value of the first. This
is for omega two-theta scans.

102
doc/programmer/kernelguide.tex
View File

@ -3,7 +3,7 @@ In this chapter the facilities of the SICS servers kernel will be examined
more closely. All the kernel modules and their function will be listed,
together with some explanatory information and an overview about the
application programmers interfaces (API) provided. This section should
answer the questions: WHat is available?, Where to find what?,
answer the questions: What is available?, Where to find what?,
Why did they do that? Details of
the API's mentioned are given in the reference section.
@ -124,7 +124,7 @@ The network reader currently supports four types of sockets:
\item User sockets.
\end{itemize}
The accept type of socket is the main server port where clients try to
The accept type of socket is the main server port to which clients try to
connect to. The network reader accepts the connection and tries to read a
username/password pair for a specified amount of time.
If the username/password is valid, the connection will be accepted,
@ -175,16 +175,18 @@ mechanism. For more details see John Ousterhout's book.
In an earlier stage it was considered to use the Tcl interpreter as the SICS
interpreter. This idea was discarded for some reasons: One was the
difficulty of transporting the client execution context (i.e. the connection
object) through the Tcl interpreter. There is no standard Tcl mechanism for
doing that. The second was security: the Tcl
interpreter is very powerful and can be abused. It was felt that the system
had to be protected against such problems. The third reasons was that the
set of user commands should not be cluttered with Tcl commands in order to
prevent confusion. Programming macros is anyway something which is done by
SICS managers or programmers. However, the SICS interpreter is still modeled
very much like the Tcl-interpreter. A Tcl interpreter is still included in
order to provide a full featured macro language. The SICS interpreter and the
Tcl macro interpreter are still tightly coupled.
object) through the Tcl interpreter. This reason has become invalid
now, with the advent of Tcl 8.+ which supports namespaces. The second
was security: the Tcl interpreter is very powerful and can be
abused. It was felt that the system had to be protected against such
problems. The third reasons was that the set of user commands should
not be cluttered with Tcl commands in order to prevent
confusion. Programming macros is anyway something which is done by
SICS managers or programmers. However, the SICS interpreter is still
modeled very much like the Tcl-interpreter. A Tcl interpreter is
still included in order to provide a full featured macro
language. The SICS interpreter and the Tcl macro interpreter are
still tightly coupled.
The SICS interpreter must forward commands to the SICS objects. For this the
interpreter needs some help from the objects themselves. Each SICS object
@ -290,26 +292,6 @@ important SICS components: the interpreter, the task switcher, the device
executor, the environment monitor and the network reader. This module also
contains the code for initializing, running and stopping the server.
\section{The ServerLog}
As part of the SICS kernel there exists a global server log file. This file
contains:
\begin{itemize}
\item All traffic on all client connections. Even messages suppressed by the
clients.
\item All internal error messages.
\item Notifications about important internal status changes.
\end{itemize}
This server log is meant as an aid in debugging the server. As the SICS
server may run for days, weeks and months uninterrupted this log file may
become very large. However, only the last thousand or so messages are really
of interest when tracking a problem. Therefore a scheme is implemented to
limit the disk space used by the server log. The server log writes
cyclically into a number of files. A count of the lines is kept which were
written to each file. Above a predefined count, a new file is started.
As an interface the server log provides a function which allows to write
a message to it. This can be used by any object in the system for
interesting messages. The number of files to cycle through and the length of
each file can be configured by defines at the top of servlog.c.
\section{The Performance Monitor}
This facility provides the data for the Performance (see user documentation)
@ -351,5 +333,57 @@ users. If this becomes a serious concern, this module has to be rewritten.
\section{The Server Main Function}
This does not do much, just initialize the server, run it, and stop it.
\section{Logging}
The SICS server offers multiple options for logging:
\begin{itemize}
\item There is a cyclical server log logging all traffic. This is
described below.
\item Per client connection log files can be configured. This is part
of the connection object interface.
\item A special module, the commandlog exists, which saves all traffic
issued on client connections with user or manager privilege. This is
the most useful log for finding problems. This facility can be
configured to create a log file per day. Or the user can demand to
have her very own log file.
\end{itemize}
\subsection{The ServerLog}
As part of the SICS kernel there exists a global server log file. This file
contains:
\begin{itemize}
\item All traffic on all client connections. Even messages suppressed by the
clients.
\item All internal error messages.
\item Notifications about important internal status changes.
\end{itemize}
This server log is meant as an aid in debugging the server. As the SICS
server may run for days, weeks and months uninterrupted this log file may
become very large. However, only the last thousand or so messages are really
of interest when tracking a problem. Therefore a scheme is implemented to
limit the disk space used by the server log. The server log writes
cyclically into a number of files. A count of the lines is kept which were
written to each file. Above a predefined count, a new file is started.
As an interface the server log provides a function which allows to write
a message to it. This can be used by any object in the system for
interesting messages. The number of files to cycle through and the length of
each file can be configured by defines at the top of servlog.c.
\section{Instrument Status Persistence}
Real programs do dump core (the SICS server is good, but is no
exception in this respect) and real computers fall over. In such cases
it would be useful if instrument configuration parameters such as
zero points , variable settings etc. are not lost. SICS achieves this
by writing a status file each time a parameter changes. This
status file is read back whenever the SICS server starts. The default
status file is configured in the instrument startup file as the SicsOption
statusfile. The user
can also request a status file to be written or recovered manually.
The status file is just a file with SICS commands which configure
relevant parameters. The actual writing of these commands is delegated
to each SICS object. Each SICS object which whishes to save data into
the status file has to implement a function which will
automatically be called when a status file is written. For details,
consult the chapter on SICS object implementation.

3
doc/programmer/oguide.tex
View File

@ -428,7 +428,8 @@ Sometimes error conditions arise in lower level code which should cause all
upper level code to finish execution. Such conditions may be the result of a
critical hardware fault or may even be requested by a user who wants to
abort an operation. A standard method for communicating such conditions
through the system is necessary. SICS uses interrupts for such conditions.
through the system is necessary.
SICS uses interrupts for such conditions.
The current interrupt active interrupt is located at the connection object
and can be retrieved with {\bf SCGetInterrupt} and set with {\bf
SCSetInterrupt}. Interrupt codes are defined in interrupt.h and are ordered

84
doc/programmer/overview.tex
View File

@ -28,14 +28,20 @@ matches the above criteria.
\section{The SINQ Hardware Setup}
SICS had to take in account the SINQ hardware setup which had been decided
upon earlier on. Most hardware such as motors and counters is controlled via
RS--232 interfaces. These devices connect to a Macintosh PC which has a
terminal server program running on it. This terminal server program collects
request to the hardware from a TCP/IP port and forwards them to the serial
device. The instrument control program runs on a workstation running
DigitalUnix. Communication with the hardware happens via TCP/IP through the
terminal server. Some hardware devices, such as the histogram memory, can handle
RS--232 interfaces. These RS--232 interfaces are connected to a
terminal server which allows to access such devices through the TCP/IP
network.
For historical reasons the instrument control software does not access
the terminal server directly but through another software layer, the
SerPortServer program. The SerPortServer program is another TCP/IP
server which allows multiple network clients to access the same
terminal server port through a home grown protocoll. In the long run
this additional software layer will be abolished.
Some hardware devices, such as the histogram memory, can handle
TCP/IP themselves. With such devices the instrument control program
communicates directly through TCP/IP, without a terminal server. All
communicates directly through TCP/IP. All
hardware devices take care of their real time needs themselves. Thus the
only task of the instrument control program is to orchestrate the hardware
devices. SICS is designed with this setup up in mind, but is not restricted
@ -90,15 +96,18 @@ client for a powder diffractometer is given in picture \ref{dmc}
The SICS server is the core component of the SICS system. The SICS server is
responsible for doing all the work in instrument control. Additionally the
server has to answer the requests of possibly multiple clients.
The SICS server can be subdivided into three subsystems: The kernel, a database
of SICS objects and an interpreter. The SICS server kernel takes care of
client multitasking and the preservation of the proper I/O and error context
for each client command executing.
SICS objects are software modules which represent all aspects
of an instrument: hardware devices, commands, measurement strategies
The SICS server can be subdivided into three subsystems:
\begin{description}
\item[The kernel] The SICS server kernel
takes care of client multitasking and the preservation of the proper
I/O and error context for each client command executing.
\item[SICS Object Database] SICS objects are software modules which
represent all aspects of an instrument: hardware devices, commands, measurement strategies
and data storage. This database of objects is initialized at server startup
time from an initialization script. The third SICS server component is an
interpreter which allows to issue commands to the objects in the objects database.
time from an initialization script.
\item[The Interpreter] The interpreter allows to issue commands to the
objects in the objects database.
\end{description}
The schematic drawing of the SICS server's structure is given in picture
\ref{newsics}.
\begin{figure}
@ -130,10 +139,12 @@ executing one after another. The servers main loop does nothing but
executing the tasks in this circular buffer in an endless loop.
There are several system tasks and one such
task for each living client connection. Thus only one task executes at any
given time and data access is efficiently serialized. One of the main system
given time and data access is efficiently serialized.
One of the main system
tasks (and the one which will be always there) is the network reader. The
network reader has a list of open network connections and checks each of
them for pending requests. What happens when a data is pending on an open
them for pending requests. What happens when data is pending on an open
network port depends on the type of port: If it is the servers main
connection port, the network reader will try to accept and verify a new
client connection and create the associated data structures. If the port
@ -190,9 +201,9 @@ Most experiments do not happen at ambient room conditions but
require some special environment for the sample. Mostly this is temperature
but it can also be magnetic of electric fields etc. Most of such devices
can regulate themselves but the data acquisition program needs to monitor
such devices. Within SICS this is done via a special system object, the
such devices. Within SICS, this is done via a special system object, the
environment monitor. A environment device, for example a temperature
controller, registers it's presence with this object. Then an special system
controller, registers it's presence with this object. Then a special system
task will control this device when it is executing, check for possible out
of range errors and initiates the proper error handling if such a problem is
encountered.
@ -241,15 +252,15 @@ to a system of protocols. There are protocols for:
\item For checking the authorisation of the client who wants to execute the
command.
\end{itemize}
SICS uses NeXus$^{2}$, the upcoming standard for data exchange for neutron
and x\_ray scattering as its raw data format.
SICS objects have the ability to notify clients and other objects of
internal state changes. For example when a motor is driven, the motor object
can be configured to tell SICS clients or other SICS objects about his new
position.
SICS uses NeXus$^{2}$, the upcoming standard for data exchange for neutron
and x\_ray scattering as its raw data format.
\section{SICS Working Examples}
In order to get a better feeling for the internal working of SICS the course
of a few different requests through the SICS system is traced in this
@ -284,7 +295,7 @@ pending commands.
\begin{itemize}
\item The network reader finds data pending at one of the client ports.
\item The network reader reads the command, splits it into single lines and
put those on the top of the client connections command stack. The network
put those on top of the client connections command stack. The network
reader passes control to the task switcher.
\item In due time the client connection task executes, inspects its command
stack, pops the command pending and forwards it together with a pointer to
@ -415,23 +426,18 @@ new commands.
driving whenever the task switcher allows it to execute.
\item In due time the device executor task will find that the motor finished
driving. The task will then die silently. The clients grab of the hardware driving
permission will be released. If errors occurred, however a they will be reported.
\item At this stage the drive command wrapper function will awake and
continue execution. This means inspecting errors and reporting to the client
how things worked out.
\item This done, control passes back through the interpreter and the connection
task to the task switcher. The client connection is free to execute
other commands.
\item The next task executes.
permission will be released. Any errors however, will be reported.
\end{itemize}
All this seems to be pretty complex and time consuming. But it is the complexity needed to
do so many things, especially the non blocking mode of operation requested
by users. Tests have shown that the task switcher manages +900 cycles per second
through
the task list on a DigitalUnix machine and 50 cycles per second on a pentium 133mhz
machine running linux. Both data were obtained with software simulation of
hardware devices. With real SINQ hardware these numbers drop 4 cycles per
second. This shows clearly that the communication with the hardware is the
systems bottleneck and not the task switching scheme.
by users. Tests have shown that the task switcher manages +900 cycles
per second through the task list on a DigitalUnix machine and 50
cycles per second on a pentium 133mhz machine running linux. Both data
were obtained with software simulation of hardware devices. With real
SINQ hardware these numbers drop 4 cycles per second. This shows
clearly that the communication with the hardware is the systems
bottleneck and not the task switching scheme.

18
doc/programmer/programmer.tex
View File

@ -1,5 +1,6 @@
% Copyleft (c) 1997-2000 by Mark Koennecke at PSI, Switzerland.
%
% major upgrade: Mark Koennecke, July 2003
%
%
@ -31,7 +32,18 @@
\include{overview}
\include{proto}
\include{kernelguide}
\include{oguide}
\include{command}
%%\include{oguide}
\include{sicsdriver}
\include{site}
\end{document}

60
doc/programmer/proto.tex
View File

@ -1,36 +1,33 @@
\chapter{The SICS Server Client Protocol}
This short chapter describes the command protocol between the SICS server
and possible SICS clients. All this is very simple.
\section{Logging in to the SICS Server}
In order to log in to the SICS server it needs to be known on which
machine the server runs and at which port number the server listens for
connection requests. Also needed is a valid username/ password pair for the
SICS server in question. Given that the procedure for connecting to a SICS
server requires the following steps:
\begin{enumerate}
\item Open a TCP/IP connection to the SICS server port at the machine
where it is running.
\item Immediately after opening the connection send the username/password
pair. If everything is OK, a string OK is sent. Else the server will break
the connection again.
\end{enumerate}
\section{Sending Commands}
After login, two means of communications exist. The communication
protocoll is choosen through the server port the client connects too.
The recommended way is
to adhere to the telnet protocoll as described in RFC-854. Just a
basic NVT (Network Virtual Terminal) with no options is
implemented. Binary communication is not possible on a telnet port.
The older way of communication is to send commands directly on the
TCP/IP port. Commands are strings terminated by a \verb+\n+. Return
messages from the server have the same format. This scheme is
obsolete but it has been left in because the need for a binary
communication may arise and this would help implement such a thing.
The SICS server actually listens for connections on two sockets, each
implementing a different protocoll. The first type of connection
implements the telnet protocoll. The second type uses a plain socket
and has the advantage that binary data can be transferred.
\section{Connecting using Telnet}
The SICS server implements the most primitive telnet server possible
and does not support any of the fancy options possible with
telnet. Using the telnet protocoll involves:
\begin{itemize}
\item Open a scoket conenction to SICS telnet port
\item Send a login word followed by a username and a password. The
login word is set in SICS initialization file as the SicsOption
TelWord.
\item On success a welcome message is printed, otherwise SICS
terminates the connection.
\item Now commands can be sent, but watch for the telnet protocoll
specification in RFC-?????.
\end{itemize}
\section{Connection using a plain Connection}
This protocoll involves:
\begin{itemize}
\item Open a scoket conenction to SICS telnet port
\item Send a username and a password.
\item On success OK is printed, otherwise SICS
terminates the connection.
\item Now commands can be sent as strings terminated with a newline.
\end{itemize}
For a list of possible commands consult the
user documentation.
@ -59,3 +56,6 @@ ASCII string of the form: {\bf SICSINT num} must be sent. num must be
replaced by the number of the interrupt to issue. Again interrupt codes are
resolved in file interrupt.h.

620
doc/programmer/sicsdriver.tex Normal file
View File

@ -0,0 +1,620 @@
\chapter{Writing SICS Device Drivers}
This chapter deals with writing new hardware drivers for SICS. SICS
hardware has a dual identity: Towards upper level code SICS hardware
is represented by the logical hardware object. All the low level
detail is handled in the hardware driver. The point of this is that
upper level code does not need to know which type of hardware device
is being accessed. Experience shows that this scheme covers most usage
cases for a given hardware device. However, there were always
exceptions mostly in order to realize special configurations. Such
exceptions can be dealt with through special macros which implement
commands which do
special configuration tasks. In order to be able to write such scripts
it is feasible to organize hardware access into three layers:
\begin{itemize}
\item A communication layer. This layer allows for sending commands
and reading data along a given bus.
\item A controller layer. If a device or several share a controller
make the controller visible within the system. Allow for sending
suitable commands to it.
\item The actual SICS driver.
\end{itemize}
This organisation allows scripts to directly talk to devices through
either the controller or the communication layer. If something is
missing in the general driver interface it is usually easier to add
some code at controller or communications level, rather then change
all drivers present in the system.
All drivers use a common pattern for error handling. Please read the
section on the motor driver where this pattern is explained in more
detail. The same pattern is applied in most drivers.
This section describes the actual drivers. How these drivers are
integrated into SICS is described in the chapter on the site data
structure (see \ref{site}).
\section{The Motor Driver}
A motor driver again is represented by an interface encapsulated in a
data structure. Polymorphy is achieved in two ways:
\begin{itemize}
\item Through the functions you have to define for your motor and to
assign to the function pointers in the motor driver data structure.
\item For the data structure, polymorphy is achieved through
overlay. This means, if you define your own motor driver data
structure the first fields up to KillPrivate MUST be the same as
defined in the MotorDriver structure defined below. You MUST append
your own fields below KillPrivate.
\end{itemize}
This is the motor driver data structure which has to be implemented:
\begin{verbatim}
typedef struct __AbstractMoDriv {
/* general motor driver interface
fields. REQUIRED!
*/
float fUpper; /* upper limit */
float fLower; /* lower limit */
char *name;
int (*GetPosition)(void *self, float *fPos);
int (*RunTo)(void *self,float fNewVal);
int (*GetStatus)(void *self);
void (*GetError)(void *self, int *iCode, char *buffer, int iBufLen);
int (*TryAndFixIt)(void *self, int iError,float fNew);
int (*Halt)(void *self);
int (*GetDriverPar)(void *self, char *name,
float *value);
int (*SetDriverPar)(void *self,SConnection *pCon,
char *name, float newValue);
void (*ListDriverPar)(void *self, char *motorName,
SConnection *pCon);
void (*KillPrivate)(void *self);
} MotorDriver;
\end{verbatim}
In order not to have to repeat trivial things all the time two general
things must be stated:
\begin{itemize}
\item The pointer self is always a pointer to the motor driver data
structure.
\item Functions return 1 on success or 0 on failure if not stated otherwise.
\end{itemize}
The elements of this data structure are:
\begin{description}
\item[fUpper,fLower] These are the motors hardware limits. These
values are supposed to be identical to the positions of the limit
switches on the real thing. Read them from the motor or initialize
them from parameters when initializing the motor driver.
\item[GetPosition] reads the position of the motor and puts the result
into fPos. This ought to be the position from the motor
controller. Software zeros are applied later by code in motor.c.
\item[RunTo] Starts the motor to run towards the new position
fNewVal. fNewVal must be a value valid for the controller. Software
zero points have already been taken account of by code in
motor.c. This function shall NOT wait for the completion of the
driving operation.
\item[GetStatus] This function is called repeatedly by upper level
code to poll for the progress of the driving operation. Possible
return values of this function are:
\begin{description}
\item[HWFault] If there is a fault in the hardware or the status
cannot be read.
\item[HWPosFault] The motor is still alive but the controller was
unable to position the motor.
\item[HWBusy] The motor is still driving.
\item[HWWarn] There is a warning from the controller.
\item[HWIdle] The motor has finished driving and is idle.
\end{description}
\item[GetError] retrieves information about an error which occurred on
the motor. An integer error code is returned in iCode. Up to iBufLen
characters of descriptive error information is copied into
buffer. This information is printed as error message by upper level
code.
\item[TryAndFixIt] Given an error code in iError, try to repair the
problem as far as this is possible in software. iError should be an
error code as returned by GetError in iCode. This function has the
following return codes:
\begin{description}
\item[MOTREDO] Problem fixed, try to redo the last the operation.
\item[MOTFAIL] The problem cannot be fixed in software.
\end{description}
The parameter fNew is the target position of the motor.
\item[Halt] stops the motor immediately.
\item[GetDriverPar] copies the value of the motor driver parameter
name into value, if such a parameter exists.
\item[SetDriverPar] sets the motor driver parameter name to
newValue. Report errors to pCon.
\item[ListDriverPar] write the names and values of all driver
parameters to the client connection pCon.
\item[KillPrivate] releases any memory possibly allocated for private
fields in the motor data structure.
\end{description}
In order to understand the relationship between GetError and
TryAndFixIt it helps to look at the way how errors are handled by
upper level code in motor.c: If an error in any function occurs,
GetError gets called. An error message is printed. Then TryAndFixIt is
called with the error code returned in iCode as a parameter. If
TryAndFixIt returns MOTFAIL, the code gives up. If TryAndFixIt
returns MOTREDO, the failed operation is retried. At max retries are
performed. If the operation does not succeed after three
retries, a motor failure is reported.
The GetDriverPar, SetDriverPar and ListDriverPar functions implement
some support for driver private configuration parameters. Such
parameters are meant to be configured from the instrument
initialization file. Currently there is no support to include these
parameters into the status file. If there are
no such parameters have these functions do nothing and return 1.
\section{The Counter Driver}
A counter driver is a driver for some box which allows to count for a
preset time or monitor and manages single counters and monitors. Such
a driver is reprsented by a data structure:
\begin{verbatim}
typedef struct __COUNTER {
/* variables */
char *name;
char *type;
CounterMode eMode;
float fPreset;
float fLastCurrent;
float fTime;
int iNoOfMonitors;
long lCounts[MAXCOUNT];
int iPause;
int iErrorCode;
/* functions */
int (*GetStatus)(struct __COUNTER *self, float *fControl);
int (*Start)(struct __COUNTER *self);
int (*Pause)(struct __COUNTER *self);
int (*Continue)(struct __COUNTER *self);
int (*Halt)(struct __COUNTER *self);
int (*ReadValues)(struct __COUNTER *self);
int (*GetError)(struct __COUNTER *self, int *iCode,
char *error, int iErrLen);
int (*TryAndFixIt)(struct __COUNTER *self, int iCode);
int (*Set)(struct __COUNTER *self,char *name,
int iCter, float fVal);
int (*Get)(struct __COUNTER *self,char *name,
int iCter, float *fVal);
int (*Send)(struct __COUNTER *self, char *pText,
char *pReply, int iReplyLen);
void (*KillPrivate)(struct __COUNTER *self);
void *pData; /* counter specific data goes here, ONLY for
internal driver use!
*/
} CounterDriver, *pCounterDriver;
\end{verbatim}
Polymorphy is achieved through the function pointers. Differences in
the data structure for different counter boxes are accounted for
through the pData pointer. This is meant to be initialized by the
actual counter driver to a private data structure which holds data
relevant to this particular counter. All functions take a pointer to
this counter driver structure as parameter self. If not stated
otherwise functions return 1 on success and 0 on failure. The fields:
\begin{description}
\item[name] The counter name in SICS
\item[type] The driver type.
\item[eMode] The counter mode. Possible values eTimer for preset timer
and eMonitor for preset monitor operation. This mode will be set by
upper level code.
\item[fPreset] The preset for either timer or monitor.
\item[fLastCurrent] the last known value for the control variable
during counting. Gets updated in GetStatus while counting and is used
for reporting count status.
\item[fTime] The time the last counting operation took. This is a time
read from the counter box. This could be different from elapsed time
because the count may have paused for instance because the beam was
low.
\item[iNoOfMonitors] is the number of monitors and counters this
counter box supports.
\item[lCounts] An array for storing the values of counters and
monitors after counting. The PSI EL7373 counter box allows to read
values only once after counting finished. This is why the values had to be
cached in lCounts.
\item[iPause] A flag which becomes true if the counter has been
paused.
\item[iErrorCode] A private variable holding error codes.
\item[GetStatus] This function is called while upper
elvel code polls for the counter to finish. It has to return the
status of the counting operation and update the current value of the
control variable in fControl. Possible return values are:
\begin{description}
\item[HWBusy] when counting.
\item[HWIdle] when finished counting or idle.
\item[HWNoBeam] when counting is interrupted due to lack of beam.
\item[HWPause] if counting is paused.
\item[HWFault] if the status cannot be obtained.
\end{description}
\item[Start] start counting in the count mode and with the preset
previously confugured. Do NOT wait for counting to finish!
\item[Pause] pause counting.
\item[Continue] continue a paused counting operation.
\item[Halt] stop counting.
\item[ReadValues] read all counters and monitors into lCounts.
\item[GetError] retrieves information about an error which occurred on
the counter. An integer error code is returned in iCode. Up to iBufLen
characters of descriptive error information is copied into
buffer. This information is printed as error message by upper level
code.
\item[TryAndFixIt] Given an error code in iError, try to repair the
problem as far as this is possible in software. iError should be an
error code as returned by GetError in iCode. This function has the
following return codes:
\begin{description}
\item[COREDO] Problem fixed, try to redo the last the operation.
\item[COTERM] The problem cannot be fixed in software.
\end{description}
\item[Set] set parameter name associated with counter iCter to fVal.
\item[Get] return in fVal the value of parameter name associated with
iCter. These two functions allow to set counter driver parameters.
\item[Send] send pText to the counter controller and return iReplylen
characters of repsonse from the counter controller in pReply. This is
a bypass to set controller parameters manually.
\item[KillPrivate] properly delete counter driver private data
pData. Also close any connections to the hardware.
\end{description}
\section{Environment Controller Driver}
This is the driver for all sample environment controllers, be it
temperature controllers, magnet controllers etc. An environment
controller driver is represented by the following data structure:
\begin{verbatim}
typedef struct __EVDriver {
int (*SetValue)(pEVDriver self, float fNew);
int (*GetValue)(pEVDriver self, float *fPos);
int (*GetValues)(pEVDriver self, float *fTarget,
float *fPos, float *fDelta);
int (*Send)(pEVDriver self, char *pCommand,
char *pReplyBuffer, int iReplBufLen);
int (*GetError)(pEVDriver self, int *iCode,
char *pError, int iErrLen);
int (*TryFixIt)(pEVDriver self, int iCode);
int (*Init)(pEVDriver self);
int (*Close)(pEVDriver self);
void *pPrivate;
void (*KillPrivate)(void *pData);
} EVDriver;
\end{verbatim}
All functions take a pointer to their own data structure as the first
argument (self). They return 1 on success or 0 on failure if not
stated otherwise.
The fields:
\begin{description}
\item[SetValue] set fNew as the new set value for the device. It
should start heating or cooling or whatever then.
\item[GetValue] reads the current value from the device into *fPos.
\item[GetValues] is used when the readout sensor and the control
sensor are very different. This function then reads the current set
value, the current position and calculates the difference between
these value into fDelta. This function does not need to be defined, it
is replaced by a standard one based on GetValue if not present.
\item[Send] send a command in pCommand to the controller and returns
at max iReplBuflen bytes of result in pReplyBuffer. This is breakout
which allows to send arbitray data to the controller.
\item[GetError] retrieves information about an error which occurred on
the device. An integer error code is returned in iCode. Up to iBufLen
characters of descriptive error information is copied into
buffer. This information is printed as error message by upper level
code.
\item[TryAndFixIt] Given an error code in iError, try to repair the
problem as far as this is possible in software. iError should be an
error code as returned by GetError in iCode. This function has the
following return codes:
\begin{description}
\item[DEVREDO] Problem fixed, try to redo the last the operation.
\item[DEVFAULT] The problem cannot be fixed in software.
\end{description}
\item[Init] initializes a connection to a controller and puts the
thing into the right mode (or mood?).
\item[Close] closes a connection to a controller.
\item[pPrivate] A pointer to a driver specific data structure which
can be filled with meaning by instances of drivers.
\item[KillPrivate] a function which has to release all memory associated
with pPrivate.
\end{description}
\section{Histogram Memory}
Histogram memories are devices in which neutron events for area
detector or time--of--flight detectors are assigned to their correct
bins. Then these usually large data sets have to be transferred to
SICS for further processing. In SICS, histogram memories are also able
to do count control, i.e. count until a preset monitor or time is
reached. This gives a slightly complicated driver interface. If this
assumption does not hold there are two options:
\begin{itemize}
\item Pass in a counter as a configuration parameter and chain count
control to this counter.
\item Make the count control functions dummies and let HMControl do
the rest. See hmcontrol.h and .c for details.
\end{itemize}
Though never used so far the histogram memory driver has support for
multiple banks of detectors being controlled by one histogram memory.
A histogram memory driver is implemented by filling in the data
structure given below:
\begin{verbatim}
typedef struct __HistDriver {
pHMdata data;
/* counting operations data */
CounterMode eCount;
float fCountPreset;
/* status flags */
int iReconfig;
int iUpdate;
/* interface functions */
int (*Configure)(pHistDriver self,
SConnection *pCon,
pStringDict pOpt,
SicsInterp *pSics);
int (*Start)(pHistDriver self,
SConnection *pCon);
int (*Halt)(pHistDriver self);
int (*GetCountStatus)(pHistDriver self,
SConnection *pCon);
int (*GetError)(pHistDriver self,
int *iCode,
char *perror,
int iErrlen);
int (*TryAndFixIt)(pHistDriver self,
int iCode);
int (*GetData)(pHistDriver self,
SConnection *pCon);
int (*GetHistogram)(pHistDriver self,
SConnection *pCon,
int i,
int iStart, int iEnd,
HistInt *pData);
int (*SetHistogram)(pHistDriver self,
SConnection *pCon,
int i,
int iStart, int iEnd,
HistInt *pData);
long (*GetMonitor)(pHistDriver self,
int i,
SConnection *pCon);
float (*GetTime)(pHistDriver self,
SConnection *pCon);
int (*Preset)(pHistDriver self,
SConnection *pCon,
HistInt iVal);
int (*Pause)(pHistDriver self,
SConnection *pCon);
int (*Continue)(pHistDriver self,
SConnection *pCon);
int (*FreePrivate)(pHistDriver self);
void *pPriv;
} HistDriver;
\end{verbatim}
All functions take a pointer to their driver data structure as an
argument. If not stated otherwise they retun 1 on success, 0 on failure.
\begin{description}
\item[data] Is a pointer to an HMdata object which does all the
dimension handling, buffers histogram memory content, deals with time
binnings etc.
\item[eCount] A counter mode, as defined above for counters.
\item[fCountPreset] A preset for either monitor or time.
\item[iReconfig] A flag which will be set by upper level code when a
reconfiguration is necessary.
\item[iUpdate] a flag which invalidates the buffered histogram. Should
be set 1 in each call to GetCountStatus.
\item[Configure] configures the histogram memory to the specifications
given in the fields of the HMdriver structure. Further driver specific
information can be read from the options dictionary passed
in. Configuration options are stored in the string dictionary
pOpt. This dictionary holds name value pairs which must be interpreted
by this routine. Then configure has to configure the histogram memory
according to the options passed in.
\item[Start] starts a counting operation according to the current
settings of the counter mode parameters.
\item[Halt] implements an emergency stop of a counting operation.
\item[GetCountStatus] serves to monitor the status of the counting
operation. Possible return values to this call are:
\begin{itemize}
\item HWBUSY when still counting.
\item HWNoBeam when the monitor is to low.
\item HWIDLE or OKOK when nothing is going on.
\item HWFault when there is an error on the device.
\end{itemize}
\item[GetError] will be called whenever an error has been detected on
the device. The task is to put an internal error code into the iCode
parameter. The string parameter error will be filled with a text description
of the error. But maximum iLen characters will be transferred to the error
string in order to protect against memory corruption. Therefore iLen must be
the maximum field length of error.
\item[TryAndFixIt] is the next function called in case of an error on
the device. Its second parameter is the internal code obtained in the ICode
parameter of the call to GetError. The task of this function is to examine
the error code and do whatever is possible in software to fix the problem.
TryAndFixIt returns one of the following values:
\begin{itemize}
\item COREDO when the error could be fixed, but the upper level code will
need to rerun the command which failed.
\item COFAIL when the software is unable to fix the problem and a real
mechanic with a hammer is needed (or somebody able to reboot!).
\item MOTOK when the error was fixed and nor further action is necessary.
\end{itemize}
\item[GetData] transfers all the data collected in the HM into the
host computers memory buffer.
\item[GetHistogram] copies data betwen iStart and iend from histogram
bank i into the data space pData. Please make sure that pData is big
enough to hold the data.
\item[SetHistogram] presets the histogram bank i i with the data
given in lData. A conversion from different binwidth
to long is performed as well. iStart and iStop define the start and end of
the stretch of histogram to replace.
\item[GetMonitor] returns the counts in the monitor i. Returns a
negative value on error. The error will have been printed to pCon.
\item[GetTime] returns the actual counting time.
\item[Preset] initializes the histogram memory to the value given by
iVal.
\item[Pause] pauses data collection.
\item[Continue] continues a paused data collection.
\item[FreePrivate] will be called automatically by DeleteHistDriver and
has the task to remove the private data installed by implementations of an
actual histogram memory driver.
\item[pPriv] is a pointer which a actual histogram memory driver may
use to hold a driver specific data structure.
\end{description}
\section{Velocity Selector Driver}
This is a driver for velocity selectors as used at SANS machines. A
velocity selector is a kind of turbine which selects wavelength
through rotation speed. Though it rotates fast it is not a chopper,
which are handled in SICS through the general controller driver
described below. The velocity selector driver data structure includes:
\begin{verbatim}
typedef struct __VelSelDriv {
void *pPrivate;
void (*DeletePrivate)(void *pData);
float fTolerance;
int (*Halt)(pVelSelDriv self);
int (*GetError)(pVelSelDriv self,
int *iCode, char *pError,
int iErrlen);
int (*TryAndFixIt)(pVelSelDriv self,
int iCode);
int (*GetRotation)(pVelSelDriv self,
float *fRot);
int (*SetRotation)(pVelSelDriv self,
float fRot);
int (*GetStatus)(pVelSelDriv self,
int *iCall, float *fCur);
int (*GetDriverText)(pVelSelDriv self,
char *pText,
int iTextLen);
int (*GetLossCurrent)(pVelSelDriv self,
float *fLoss);
int (*Init)(pVelSelDriv self,
SConnection *pCon);
}VelSelDriv;
\end{verbatim}
All functions take a pointer to their driver data structure as an
argument. If not stated otherwise they retun 1 on success, 0 on failure.
The fields:
\begin{description}
\item[pPrivate] a pointer to a driver private data structure.
\item[DeletePrivate] a function which releases any memory associated
with pPrivate. DeletePrivate is called with a pointer to the driver
private data pPrivate as argument.
\item[fTolerance] This driver assumes it has reached the target speed
if the speed difference target speed - read speed is less then this
tolerance value for four consecutive times.
\item[Halt] stops the velocity selector.
\item[GetError] returns an error code in *iCode and iErrlen
bytes of textual description of the last error on the velocity
selector in pError.
\item[TryAndFixIt] tries to fix the error defined through iCode. iCode
should be the value as returned in *iCode in GetError. This function
returns:
\begin{description}
\item[VELOREDO] redo last operation, error fixed.
\item[VELOFAIL] cannot fix the error from software.
\end{description}
\item[GetRotation] reads the rotation speed into *fRot.
\item[SetRotation] sets a new rotation speed fRot for the selector. Do
NOT wait until finished.
\item[GetStatus] is used to poll for the status of the last driving
operation. It returns:
\begin{description}
\item[VSACCEL] when the velocity selector is accelerating.
\item[VSFAIL] is the status cannot be read.
\item[VSOK] when the velocity seelctor has reached its target speed.
\end{description}
The current rotation speed is returned in *fCur. iCall is a value
which indicates in which state the selector is:
\begin{description}
\item[ROTMOVE] normal running.
\item[ROTSTART] starting the velocity selector. The Dornier velocity
selector have a certain minimum speed. If they are standing they have
to be started first.
\end{description}
\item[GetDriverText] returns iTextLen bytes of additional status
information in pText. This is a list name: value pairs separated by
komma. This is meant to hold additional selector readouts such as
vacuum states, temperatures etc.
\item[GetLossCurrent] initiates a measurement of the loss current of
the velocity seelctor. The result is returned in *fLoss.
\item[Init] initiates a connection to a velocity selector.
\end{description}
It may be possible that this driver is not very general. It was
developed for Dornier velocity seelctors because these were the only
one seen.
\section{General Controller Driver}
This is driver for a SICS general controller object. SICS sports a
general controller object which allows to read a selection of parameters and
to set some parameters. Adapters exists which implement the driveable
or environment interface for parameters in such a controller. The
parameters supported are part of the drivers interface. This
scheme is currently used to control choppers in SICS, but it is not
restricted to this usage. The driver:
\begin{verbatim}
typedef struct __CODRI {
int (*Init)(pCodri self);
int (*Close)(pCodri self);
int (*Delete)(pCodri self);
int (*SetPar)(pCodri self,
char *parname,
float fValue);
int (*SetPar2)(pCodri self,
char *parname,
char *value);
int (*GetPar)(pCodri self,
char *parname,
char *pBuffer,
int iBufLen);
int (*CheckPar)(pCodri self,
char *parname);
int (*GetError)(pCodri self, int *iCode,
char *pError,
int iErrLen);
int (*TryFixIt)(pCodri self, int iCode);
int (*Halt)(pCodri self);
char *pParList;
void *pPrivate;
}Codri;
\end{verbatim}
All functions take a pointer to their driver data structure as an
argument. If not stated otherwise they retun 1 on success, 0 on failure.
The fields:
\begin{description}
\item[Init] initializes a connection to the controller and the driver.
\item[Close] closes the connection to a controller.
\item[Delete] releases all memory associated with this drivers private
data structure pPrivate.
\item[SetPar] sets the parameter parname to a new value fValue.
\item[SetPar2] same as SetPar but with new value as text.
\item[GetPar] read the current value of parname into pBuffer. The
value is formatted as text. At max iBufLen bytes are copied into
pBuffer.
\item[CheckPar] checks the progress of setting parname. CheckPar
returns:
\begin{description}
\item[HWFault] If there is a fault in the hardware or the status
cannot be read.
\item[HWBusy] The parameter is still driving.
\item[HWIdle] The parameter has finished changing and is idle.
\end{description}
\item[GetError] returns an error code in *iCode and iErrlen
bytes of textual description of the last error on the velocity
selector in pError.
\item[TryAndFixIt] tries to fix the error defined through iCode. iCode
should be the value as returned in *iCode in GetError. This function
returns:
\begin{description}
\item[CHREDO] redo last operation, error fixed.
\item[CHFAIL] cannot fix the error from software.
\end{description}
\item[Halt] stop any driving parameters.
\item[pParList] a comma separated list of parameters supported by this
driver.
\item[pPrivate] a driver private data structure.
\end{description}

129
doc/programmer/site.tex Normal file
View File

@ -0,0 +1,129 @@
\chapter{Site Adaptions}\label{site}
Any new site adapting SICS will have different hardware and thus
require different drivers. Moreover additional commands may need to be
added in order to support special hardware, instrument specific
computations or status displays and local usage patterns. In order to
separate such site specific code from the SICS kernel, the site data
structure was conceived. Any new site is supposed to create a library
which provides site specific code and the site data structure which
allows SICS to locate the code. A site data structure can be retrieved
using:
\begin{verbatim}
pSite getSite(void);
\end{verbatim}
The site data structure is meant to be a singleton. It is a site's
programmers task to provide an implementation of getSite which returns
a nice site structure.
The site data structure is a structure which holds pointers to
functions. A user has to implement suitable functions along the
signatures given and assign them to this data structure.
\begin{verbatim}
typedef struct {
void (*AddSiteCommands)(SicsInterp *pSics);
void (*RemoveSiteCommands)(SicsInterp *pSics);
pMotor (*CreateMotor)(SConnection *pCon,
int argc, char *argv[]);
pCounterDriver (*CreateCounterDriver)(
SConnection *pCon,
int argc,
char *argv[]);
HistDriver *(*CreateHistogramMemoryDriver)(
char *name, pStringDict pOption);
pVelSelDriv (*CreateVelocitySelector)(char *name,
char *array, Tcl_Interp *pTcl);
pCodri (*CreateControllerDriver)(SConnection *pCon,
int argc,
char *argv[]);
pEVControl (*InstallEnvironmentController)(
SicsInterp *pSics,
SConnection *pCon,
int argc,
char *argv[]);
int (*ConfigureScan)(pScanData self,
char *option);
void (*KillSite)(void *pData);
}Site, *pSite;
\end{verbatim}
The members of this data structure:
\begin{description}
\item[AddSiteCommand] adds site specific commands coded in C to the
SICS interpreter pSics.
\item[RemoveSiteCommands] removes object creation commands after SICS
has processed the instrument initialization file. See \ref{factory}
for details on the scheme.
\item[CreateMotor] creates a motor object. \verb+argv[0]+ contains the
motors name, \verb+argv[1]+ the identifier for the motor driver and
the rest of argv, argc holds further driver initialisation
parameters. Any errors in processing the arguments can be reported to
pCon. If CreateMotor can create a suitable motor object, a pointer to
it is returned, if not NULL must be returned.
\item[CreateCounterDriver] creates a driver for a counter. argc, argv
is the full array of arguments given to the MakeCounter factory
function. Of interest are: \verb+argv[1]+ the counter name,
\verb+argv[2]+, the driver identifier and the rest of the
initialization arguments. On success a pointer to
new driver is returned, on failure NULL.
\item[CreateHistogramMemoryDriver] creates a driver for a histogram
memory. The driver is identified through name, the options database is
in pOptions. Histogram memory initialization follows the following
pattern:
\begin{itemize}
\item At first the raw driver is created. This code has to initializie
defaults in the options data base.
\item Then, with calls to {\em hmname configure opt val} the options
database is populated with the histogram memories configuration
options. The options database is pOptions a dictionary of name value
pairs.
\item In the last step, with {\bf hmname init} the options are parsed
and the driver is supposed to connect to the histogram memory. See
Configure in the histogram memory driver.
\end{itemize}
On success a pointer to
new driver is returned, on failure NULL.
\item[CreateVelSelDriv] creates a driver for a velocity selector. The
driver is identified by nname, array is the name of a Tcl array in
pTcl holding initialization parameters for name.
\item[MakeController] generates a driver for a SICS general controller
object. \verb+argv[0]+ is the driver identifier, the rest of argc,
\verb+argv[]+ are further initialization parameters. Any errors in
parsing argc, argv can be reported to pCon. On success a pointer to
new driver is returned, on failure NULL.
\item[InstallEnvironmentController] installs a sample environment
controller into pSics. \verb+argv[3]+ is the driver indentifier,
\verb+argv[2]+ is the SICS name of the environment device command, the
rest are initialization parameters. This function must also install
the command into pSics with AddCommand. This is because for many PSI
environment devices special interpreter wrapper functions are
provided. Any errors encountered while processing the arguments has to
be reported to pCon. On success a pointer to the environment
controller is returned, on failure NULL.
\item[ConfigureScan] configures the SICS general scan object self according
to the value of option. Returns 1 on success and 0 on failure. SICS
general scan object is a data structure holding function pointers for
various steps in the scan. These functions can be overloaded in order
to provide for special scans. See the documentation ins scan.tex,
scan.h and scan.c from more details.
\end{description}
All the simulation drivers for the hardware are part of the SICS
kernel and need not be initialized from these functions. SICS also
handles sample environment devices built in Tcl or on the general
controller object.
The site data structure suffers a little from inconsistencies
introduced through varying concepts for initializing SICS objects introduced
during the development of SICS. If you need to bypass the schemes
introduced here, consider implementing an own factory command and
install it through AddSiteCommand, RemoveSiteCommand.
Good luck!

4
make_gen
View File

@ -23,8 +23,8 @@ SOBJ = network.o ifile.o conman.o SCinter.o splitter.o passwd.o \
simchop.o choco.o chadapter.o trim.o scaldate.o \
hklscan.o xytable.o \
circular.o maximize.o sicscron.o \
t_rlp.o t_conv.o d_sign.o d_mod.o \
synchronize.o definealias.o t_update.o \
d_sign.o d_mod.o \
synchronize.o definealias.o \
hmcontrol.o userscan.o rs232controller.o lomax.o \
fourlib.o motreg.o motreglist.o anticollider.o \
s_rnge.o sig_die.o gpibcontroller.o $(NIOBJ) \

17
makefile_linux
View File

@ -6,8 +6,8 @@
# Markus Zolliker, March 2003
#==========================================================================
# the following lines only for fortified version
DFORTIFY=-DFORTIFY
FORTIFYOBJ=strdup.o fortify.o
#DFORTIFY=-DFORTIFY
#FORTIFYOBJ=strdup.o fortify.o
#==========================================================================
# assign if the National Instrument GPIB driver is available
#NI= -DHAVENI
@ -25,9 +25,18 @@ HDFROOT=/afs/psi.ch/project/sinq/linux
EXTRA=nintf.o
SUBLIBS = psi/libpsi.a psi/hardsup/libhlib.a matrix/libmatrix.a \
psi/tecs/libtecsl.a
LIBS = -L$(HDFROOT)/lib $(SUBLIBS) \
LIBS = -static -L$(HDFROOT)/lib $(SUBLIBS) \
-ltcl8.3 $(HDFROOT)/lib/libhdf5.a \
$(HDFROOT)/lib/libmfhdf.a $(HDFROOT)/lib/libdf.a \
$(HDFROOT)/lib/libjpeg.a -lz -lm -ll -lc
$(HDFROOT)/lib/libjpeg.a -ldl -lz -lm -ll -lc
include $(SRC)make_gen

838
t_conv.c
View File

@ -1,838 +0,0 @@
/* 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 */
/* Found that ERRESO looks error messages up in a 2D array. Modified IER */
/* values to refer to a 1D array. */
/* Mark Koennecke, January 2002 */
/* ------------------------------------------------------------------------- */
/* 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__, doublereal *a4, 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, 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 = 9;
if (edef[0] < .1f) {
goto L999;
}
*ier = 0;
akdef[0] = sqrt(edef[0] / *f);
} else {
*ier = 9;
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 = 9;
if (edef[1] < 1e-4f) {
goto L999;
}
*ier = 0;
akdef[1] = sqrt(edef[1] / *f);
} else {
*ier = 9;
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 = 9;
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 {
*ier += 8;
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 {
*ier += 8;
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 {
*ier += 4;
goto L999;
}
}
/* ----------------------------------------------------------------------- */
/* DEAL WITH FLIPPERS AND HELMOTZ COILS IF LPA */
if (*lpa) {
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__ */

690
t_conv.f
View File

@ -1,690 +0,0 @@
C------------------------------------------------------------------------
C slightly edited version for inclusion into SICS
C
C Mark Koennecke, November 2000
C
C Found that ERRESO looks error messages up in a 2D array. Modified IER
C values to refer to a 1D array.
C
C Mark Koennecke, January 2002
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, A4,
+ 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 + 8
IF(EDEF(1) .LT. EPS1) GOTO 999
IER = 0
AKDEF(1) = SQRT(EDEF(1)/F)
ELSE
IER = 1 + 8
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 + 8
IF(EDEF(2) .LT. EPS4) GOTO 999
IER = 0
AKDEF(2) = SQRT(EDEF(2)/F)
ELSE
IER = 1 + 8
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 + 8
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
IER = IER + 8
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
IER = IER + 8
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
IER = IER + 4
GOTO 999
ENDIF
ENDIF
C-----------------------------------------------------------------------
C DEAL WITH FLIPPERS AND HELMOTZ COILS IF LPA
C
IF (LPA) 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

516
t_rlp.c
View File

@ -1,516 +0,0 @@
/* 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_ */

463
t_rlp.f
View File

@ -1,463 +0,0 @@
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

495
t_update.c
View File

@ -1,495 +0,0 @@
/* t_update.f -- translated by f2c (version 20000817).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
#include "f2c.h"
/* Subroutine */ int t_update__(p_a__, p_ih__, c_ih__, lpa, dm, da, isa, helm,
f1h, f1v, f2h, f2v, f, ei, aki, ef, akf, qhkl, en, hx, hy, hz, if1,
if2, qm, ier)
real *p_a__, *p_ih__, *c_ih__;
logical *lpa;
real *dm, *da;
integer *isa;
real *helm, *f1h, *f1v, *f2h, *f2v, *f, *ei, *aki, *ef, *akf, *qhkl, *en, *hx,
*hy, *hz;
integer *if1, *if2;
real *qm;
integer *ier;
{
static doublereal dakf, daki, dphi;
static integer ieri, imod, ieru;
extern /* Subroutine */ int ex_up__();
static doublereal df;
static integer id;
static real qs;
static doublereal dbqhkl[3];
extern /* Subroutine */ int sam_up__();
static doublereal da2, da3, da4, da6;
extern /* Subroutine */ int erreso_();
static doublereal dda, def, dei, ddm, dqm, dhx, dhy, dhz, dqs;
extern /* Subroutine */ int helm_up__(), flip_up__();
/* =================== */
/* dec$ Ident 'V01C' */
/* ------------------------------------------------------------------ */
/* Note: */
/* IF1,If2 changed to Int*4. They were Real*4 in ILL version. */
/* ------------------------------------------------------------------ */
/* Updates: */
/* V01A 7-May-1996 DM. Put error output to IOLUN, use IMPLICIT NONE and */
/* get the code indented so that it is readable! */
/* V01C 12-Oct-1998 DM. Put in Mag Field calculation for SINQ Helmolz coils. */
/* ----------------------------------------------------------------------- */
/* Entry points in this file: */
/* T_UPDATE : USE THE MOTOR ANGLES TO CALCULATE VALUES OF */
/* EI,KI,EF,KF,QH,QK,QL,EN AND TO DETERMINE */
/* WHETHER FLIPPERS F1,F2 ARE 'ON' OR 'OFF'. */
/* EX_UP : CALCULATE EX AND AKX FORM AX2 VALUES. */
/* SAM_UP : CALCULATE THINGS IN RECIPROCICAL LATTICE. */
/* HELM_UP : CALCULATE HELMHOLTZ FIELDS. */
/* FLIP_UP : CHECK IF FLIPPERS ON OR OFF. */
/* ----------------------------------------------------------------------- */
/* T_UPDATE: */
/* ROUTINE TO USE THE MOTOR ANGLES TO */
/* CALCULATE VALUES OF EI,KI,EF,KF,QH,QK,QL,EN */
/* USE CURRENT-SUPPLY VALUES TO COMPUTE HELMHOLTZ FIELDS HX,HY,HZ */
/* AND TO DETERMINE WHETHER FLIPPERS F1,F2 ARE 'ON' OR 'OFF'. */
/* FLIPPERS ARE 'ON' ONLY IF CURRENTS ARE THOSE GIVEN BY */
/* F1V,F1H,F2V,F2H */
/* ----------------------------------------------------------------------- */
/* File [MAD.SRC]T_UPDATE.FOR */
/* cc IMPLICIT DOUBLE PRECISION (A-H,O-Z) */
/* include 'iolsddef.inc' */
/* ----------------------------------------------------------------------- */
/* Define the dummy arguments */
/* Input: */
/* Positions of angles A1-A6. */
/* .. helmotz (8 currents). */
/* Position of currents for flippers and .. */
/* Configuration of the machine ... */
/* Conversion factors for Helmotz (4 currents). */
/* True if machine in polarization mode. */
/* Monochr. d-spacing */
/* Analyser d-spacing */
/* .. +ve to the left. */
/* Scattering sense at analyser (probably) .. */
/* .. ki (probably). */
/* Angle between axis of Helmolz pair one and .. */
/* .. current is possibly ki*f1h ??) */
/* Flipper 1 hor and vert currents (hor .. */
/* .. current is possibly kf*f2h ??) */
/* Flipper 2 hor and vert currents (hor .. */
/* Output: */
/* Energy unit */
/* Incident neutron energy */
/* Incident neutron wave vector */
/* Final neutron energy */
/* Final neutron wave vector */
/* Components of q in reciprocal space */
/* Energy transfer */
/* Components of Helmolz field on sample */
/* Status of Flippers 1 and 2 */
/* Length of q */
/* ----------------------------------------------------------------------- */
/* Error status */
/* ----------------------------------------------------------------------- */
/* SET UP */
/* Parameter adjustments */
--qhkl;
--c_ih__;
--p_ih__;
--p_a__;
/* Function Body */
ddm = *dm;
dda = *da;
df = *f;
da2 = p_a__[2];
da3 = p_a__[3];
da4 = p_a__[4];
da6 = p_a__[6];
/* ----------------------------------------------------------------------- */
ieri = 0;
ieru = 9;
ex_up__(&ddm, &dei, &daki, &da2, &df, &ieri);
if (ieri == 0) {
*ei = dei;
*aki = daki;
ieru = 0;
} else {
imod = 3;
erreso_(&imod, &ieri);
ieru = ieri + 8;
}
ieri = 0;
ieru = 9;
ex_up__(&dda, &def, &dakf, &da6, &df, &ieri);
if (ieri == 0) {
*ef = def;
*akf = dakf;
ieru = 0;
} else {
if (*isa == 0) {
*ef = dei;
*akf = daki;
def = dei;
dakf = daki;
ieru = 0;
} else {
imod = 3;
erreso_(&imod, &ieri);
ieru = ieri + 8;
}
}
if (*isa == 0) {
*ef = dei;
*akf = daki;
def = dei;
dakf = daki;
ieru = 0;
}
if (ieru == 0) {
*en = dei - def;
}
ieri = 0;
ieru = 5;
sam_up__(dbqhkl, &dqm, &dqs, &dphi, &daki, &dakf, &da3, &da4, &ieri);
if (ieri == 0) {
for (id = 1; id <= 3; ++id) {
qhkl[id] = dbqhkl[id - 1];
}
*qm = dqm;
qs = dqs;
ieru = 0;
} else {
imod = 2;
erreso_(&imod, &ieri);
ieru = ieri + 4;
}
ieri = 0;
if (*lpa) {
ieru = 1;
helm_up__(&dphi, helm, &p_ih__[1], &c_ih__[1], &dhx, &dhy, &dhz, &
ieri);
if (ieri != 0) {
/* WRITE(6,*) 'ERROR IN HELM_UP CHECK COEFF' */
} else {
*hx = dhx;
*hy = dhy;
*hz = dhz;
ieru = 0;
}
flip_up__(if1, if2, &p_ih__[1], f1v, f1h, f2v, f2h, aki, akf, &ieri);
}
/* ----------------------------------------------------------------------- */
*ier = ieru;
return 0;
} /* t_update__ */
/* Subroutine */ int ex_up__(dx, ex, akx, ax2, f, ier)
doublereal *dx, *ex, *akx, *ax2, *f;
integer *ier;
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double sin();
/* Local variables */
static doublereal arg;
/* ================ */
/* ----------------------------------------------------------------------- */
/* CALCULATE EX AND AKX FORM AX2 VALUES */
/* ----------------------------------------------------------------------- */
/* Part of [MAD.SRC]T_UPDATE.FOR */
/* ----------------------------------------------------------------------- */
/* Define the dummy arguments */
/* Input: */
/* D-SPACING OF CRISTAL */
/* TAKE OFF ANGLE */
/* Output: */
/* ENERGY UNIT */
/* ENERGY */
/* MOMENTUM */
/* ----------------------------------------------------------------------- */
/* Error - IER=1 if DX OR AX TOO SMALL */
/* ----------------------------------------------------------------------- */
/* !!!!!!!!!! This has to be fixed manually after conversion by f2c. */
/* !!!!!!!!!! The reason is a different definition of the abs function. */
/* !!!!!!!!!! MK, May 2001 */
arg = (d__1 = *dx * sin(*ax2 / 114.59155902616465), abs(d__1));
if (arg <= 1e-4) {
*ier = 1;
} else {
*ier = 0;
*akx = 3.1415926535897932384626433832795 / arg;
/* Computing 2nd power */
d__1 = *akx;
*ex = *f * (d__1 * d__1);
}
/* ----------------------------------------------------------------------- */
return 0;
} /* ex_up__ */
/* Subroutine */ int sam_up__(qhkl, qm, qs, phi, aki, akf, a3, a4, ier)
doublereal *qhkl, *qm, *qs, *phi, *aki, *akf, *a3, *a4;
integer *ier;
{
/* Builtin functions */
double cos(), sin(), atan2();
/* Local variables */
static doublereal qpar, qperp;
extern /* Subroutine */ int sp2rlv_();
static doublereal qt[3];
/* ================= */
/* ----------------------------------------------------------------------- */
/* Part of [MAD.SRC]T_UPDATE.FOR */
/* ----------------------------------------------------------------------- */
/* Define the dummy arguments */
/* Input: */
/* Actual value of KI */
/* Actual value of KF */
/* Actual value of A3 */
/* Output: */
/* Actual value of A4 */
/* CALCULATED POSITIONS IN RECIP. LATTICE */
/* Q MODULUS */
/* Q MODULUS SQUARED */
/* ANGLE BETWEEN KI AND Q */
/* NOT CALCULATED) */
/* ----------------------------------------------------------------------- */
/* LOCAL PARAMETERS */
/* Error status. IER=1 if QM TOO SMALL (PHI */
/* ----------------------------------------------------------------------- */
/* QPAR AND QPERP ARE COMPONENTS OF Q PARALLEL AND PERP TO KI */
/* TRANSFORM FROM SCATTERING PLANE INTO RECIPROCAL LATTICE */
/* Parameter adjustments */
--qhkl;
/* Function Body */
qpar = *aki - *akf * cos(*a4 / 57.29577951308232087679815481410517);
qperp = -(*akf) * sin(*a4 / 57.29577951308232087679815481410517);
qt[0] = qpar * cos(*a3 / 57.29577951308232087679815481410517) + qperp *
sin(*a3 / 57.29577951308232087679815481410517);
qt[1] = -qpar * sin(*a3 / 57.29577951308232087679815481410517) + qperp *
cos(*a3 / 57.29577951308232087679815481410517);
qt[2] = 0.;
sp2rlv_(&qhkl[1], qt, qm, qs, ier);
*ier = 3;
if (*qm > .001) {
*ier = 0;
}
*phi = 0.;
if (abs(qperp) > .001 && abs(qpar) > .001) {
*phi = atan2(qperp, qpar);
} else if (abs(qpar) < .001) {
if (*a4 > (float)0.) {
*phi = -1.5707963267948966;
} else {
*phi = 1.5707963267948966;
}
}
/* ----------------------------------------------------------------------- */
return 0;
} /* sam_up__ */
/* Subroutine */ int helm_up__(phi, helm, p_ih__, c_ih__, dhx, dhy, dhz, ier)
doublereal *phi;
real *helm, *p_ih__, *c_ih__;
doublereal *dhx, *dhy, *dhz;
integer *ier;
{
/* System generated locals */
real r__1;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(), atan2(), cos(), sin();
/* Local variables */
static doublereal hdir, hmod, hpar, hdir2, h__[4], hperp;
static integer ic;
static logical at_sinq__;
/* ================== */
/* ---------------------------------------------------------------- */
/* HELMHOLTZ COILS UPDATE (ONLY IF LPA IS TRUE) */
/* ---------------------------------------------------------------- */
/* Part of [MAD.SRC]T_UPDATE.FOR */
/* include 'common_sinq.inc' */
/* ----------------------------------------------------------------------- */
/* 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. */
/* ----------------------------------------------------------------------- */
/* Define the dummy arguments */
/* Input: */
/* Angle between KI and Q in scatt'g plane (rad) */
/* Angle between first coil and KI (degrees) */
/* with Helmolz coils */
/* Current values of 4 currents associated .. */
/* Output: */
/* Conversion factor between Amperes and Gauss */
/* \ */
/* > The calculated fields */
/* / */
/* ---------------------------------------------------------------- */
/* LOCAL VARIABLES */
/* Error status. IER=1 if C_I HAS A ZERO COEF */
/* ---------------------------------------------------------------- */
/* H !FIELD OF 4 COILS AROUND SAMPLE */
/* HPAR !FIELD PAR COIL 1 */
/* HPERP !FIELD PERP. TO COIL 1 */
/* HDIR2 !ANGLE BETWEEN FIELD AND COIL 1 */
/* HDIR !ANGLE BETWEEN FIELD AND Q */
/* ---------------------------------------------------------------- */
/* Parameter adjustments */
--c_ih__;
--p_ih__;
/* Function Body */
*ier = 0;
at_sinq__ = TRUE_;
if (! at_sinq__) {
for (ic = 1; ic <= 4; ++ic) {
h__[ic - 1] = 0.;
if ((r__1 = c_ih__[ic], dabs(r__1)) > .001) {
h__[ic - 1] = p_ih__[ic + 4] * c_ih__[ic];
} else {
*ier = 1;
}
}
hpar = h__[0] - (h__[1] + h__[2]) * .5;
hperp = sqrt(3.) * .5 * (h__[1] - h__[2]);
*dhz = h__[3];
} else {
for (ic = 1; ic <= 3; ++ic) {
h__[ic - 1] = 0.;
if ((r__1 = c_ih__[ic], dabs(r__1)) > .001) {
h__[ic - 1] = p_ih__[ic + 4] * c_ih__[ic];
} else {
*ier = 1;
}
}
hpar = h__[0];
hperp = h__[1];
*dhz = h__[2];
}
/* Computing 2nd power */
d__1 = hpar;
/* Computing 2nd power */
d__2 = hperp;
hmod = sqrt(d__1 * d__1 + d__2 * d__2);
if (abs(hpar) > .001 && abs(hperp) > .001) {
hdir2 = atan2((abs(hperp)), (abs(hpar)));
if (hpar > 0. && hperp < 0.) {
hdir2 = -hdir2;
} else if (hpar < 0. && hperp > 0.) {
hdir2 = 3.1415926535897932384626433832795 - hdir2;
} else if (hpar < 0. && hperp < 0.) {
hdir2 += -3.1415926535897932384626433832795;
}
} else if (abs(hpar) > .001) {
if (hpar >= (float)0.) {
hdir2 = (float)0.;
}
if (hpar < (float)0.) {
hdir2 = 3.1415926535897932384626433832795;
}
} else if (abs(hperp) > .001) {
if (hperp >= (float)0.) {
hdir2 = 1.5707963267948966;
}
if (hperp < (float)0.) {
hdir2 = -1.5707963267948966;
}
} else {
hdir2 = (float)0.;
}
hdir = hdir2 + *helm / 57.29577951308232087679815481410517 - *phi;
*dhx = hmod * cos(hdir);
*dhy = hmod * sin(hdir);
return 0;
} /* helm_up__ */
/* Subroutine */ int flip_up__(if1, if2, p_ih__, f1v, f1h, f2v, f2h, aki, akf,
ier)
integer *if1, *if2;
real *p_ih__, *f1v, *f1h, *f2v, *f2h, *aki, *akf;
integer *ier;
{
/* System generated locals */
real r__1, r__2;
/* ================== */
/* ---------------------------------------------------------------- */
/* FLIPPERS; ONLY IF LPA */
/* ---------------------------------------------------------------- */
/* Part of [MAD.SRC]T_UPDATE.FOR */
/* ----------------------------------------------------------------------- */
/* Define the dummy arguments */
/* Input: */
/* with flipper coils */
/* Current values of 4 currents associated .. */
/* .. current is possibly aki*f1h ??) */
/* Flipper 1 vert and hor currents (hor .. */
/* .. current is possibly akf*f2h ??) */
/* Flipper 2 vert and hor currents (hor .. */
/* Incident neutron wave vector */
/* Output: */
/* Final neutron wave vector */
/* Status of Flipper 1 (=1 if on and set OK) */
/* Status of Flipper 2 (=1 if on and set OK) */
/* ---------------------------------------------------------------- */
/* Error status. 0 if no error. */
/* Parameter adjustments */
--p_ih__;
/* Function Body */
*ier = 0;
*if1 = 0;
*if2 = 0;
if ((r__1 = p_ih__[1] - *f1v, dabs(r__1)) < (float).05 && (r__2 = p_ih__[
2] - *aki * *f1h, dabs(r__2)) < (float).05) {
*if1 = 1;
}
if ((r__1 = p_ih__[3] - *f2v, dabs(r__1)) < (float).05 && (r__2 = p_ih__[
4] - *akf * *f2h, dabs(r__2)) < (float).05) {
*if2 = 1;
}
/* ----------------------------------------------------------------------- */
return 0;
} /* flip_up__ */

409
t_update.f
View File

@ -1,409 +0,0 @@
SUBROUTINE T_UPDATE ( ! File [MAD.SRC]T_UPDATE.FOR
c ===================
+ P_A, P_IH, C_IH,
+ LPA ,DM, DA, ISA, HELM, F1H, F1V, F2H, F2V, F,
+ EI, AKI, EF, AKF, QHKL, EN,
+ HX, HY, HZ, IF1, IF2, QM, IER)
c
cdec$ Ident 'V01C'
c------------------------------------------------------------------
c Note:
c IF1,If2 changed to Int*4. They were Real*4 in ILL version.
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 V01C 12-Oct-1998 DM. Put in Mag Field calculation for SINQ Helmolz coils.
C-----------------------------------------------------------------------
c Entry points in this file:
C T_UPDATE : USE THE MOTOR ANGLES TO CALCULATE VALUES OF
c EI,KI,EF,KF,QH,QK,QL,EN AND TO DETERMINE
c WHETHER FLIPPERS F1,F2 ARE 'ON' OR 'OFF'.
c EX_UP : CALCULATE EX AND AKX FORM AX2 VALUES.
c SAM_UP : CALCULATE THINGS IN RECIPROCICAL LATTICE.
c HELM_UP : CALCULATE HELMHOLTZ FIELDS.
c FLIP_UP : CHECK IF FLIPPERS ON OR OFF.
C-----------------------------------------------------------------------
c T_UPDATE:
C ROUTINE TO USE THE MOTOR ANGLES TO
C CALCULATE VALUES OF EI,KI,EF,KF,QH,QK,QL,EN
C USE CURRENT-SUPPLY VALUES TO COMPUTE HELMHOLTZ FIELDS HX,HY,HZ
C AND TO DETERMINE WHETHER FLIPPERS F1,F2 ARE 'ON' OR 'OFF'.
C FLIPPERS ARE 'ON' ONLY IF CURRENTS ARE THOSE GIVEN BY
C F1V,F1H,F2V,F2H
C-----------------------------------------------------------------------
IMPLICIT NONE
ccc IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C include 'iolsddef.inc'
C-----------------------------------------------------------------------
c Define the dummy arguments
c Input:
real*4 p_a(6) ! Positions of angles A1-A6.
real*4 p_ih(8) ! Position of currents for flippers and ..
! .. helmotz (8 currents).
real*4 c_ih(4) ! Conversion factors for Helmotz (4 currents).
! Configuration of the machine ...
logical*4 lpa ! True if machine in polarization mode.
real*4 dm ! Monochr. d-spacing
real*4 da ! Analyser d-spacing
integer*4 isa ! Scattering sense at analyser (probably) ..
! .. +ve to the left.
real*4 helm ! Angle between axis of Helmolz pair one and ..
! .. ki (probably).
real*4 f1h, f1v ! Flipper 1 hor and vert currents (hor ..
! .. current is possibly ki*f1h ??)
real*4 f2h, f2v ! Flipper 2 hor and vert currents (hor ..
! .. current is possibly kf*f2h ??)
real*4 f ! Energy unit
c Output:
real*4 ei ! Incident neutron energy
real*4 aki ! Incident neutron wave vector
real*4 ef ! Final neutron energy
real*4 akf ! Final neutron wave vector
real*4 qhkl(3) ! Components of q in reciprocal space
real*4 en ! Energy transfer
real*4 hx, hy, hz ! Components of Helmolz field on sample
integer*4 if1, if2 ! Status of Flippers 1 and 2
real*4 qm ! Length of q
integer*4 ier ! Error status
C-----------------------------------------------------------------------
double precision dbqhkl(3), dhx, dhy, dhz
double precision ddm, dda, df
double precision da2, da3, da4, da6
double precision dei, daki, def, dakf
double precision dqm, dqs, dphi
real*4 qs
c
integer*4 ieri, ieru, imod, id
C-----------------------------------------------------------------------
C SET UP
C
DDM=DM
DDA=DA
DF=F
DA2=P_A(2)
DA3=P_A(3)
DA4=P_A(4)
DA6=P_A(6)
C-----------------------------------------------------------------------
C
IERI=0
IERU=1 + 8
CALL EX_UP(DDM,DEI,DAKI,DA2,DF,IERI)
IF (IERI.EQ.0) THEN
EI=DEI
AKI=DAKI
IERU=0
ELSE
IMOD=3
CALL ERRESO(IMOD,IERI)
IERU = IERI + 8
ENDIF
IERI=0
IERU=1 + 8
CALL EX_UP(DDA,DEF,DAKF,DA6,DF,IERI)
IF (IERI.EQ.0) THEN
EF=DEF
AKF=DAKF
IERU=0
ELSE
IF (ISA.EQ.0) THEN
EF=DEI
AKF=DAKI
DEF=DEI
DAKF=DAKI
IERU=0
ELSE
IMOD=3
CALL ERRESO(IMOD,IERI)
IERU = 8 + IERI
ENDIF
ENDIF
IF (ISA.EQ.0) THEN
EF=DEI
AKF=DAKI
DEF=DEI
DAKF=DAKI
IERU=0
ENDIF
IF (IERU.EQ.0) EN=DEI-DEF
IERI=0
IERU=1 + 4
CALL SAM_UP(DBQHKL,DQM,DQS,DPHI,DAKI,DAKF,DA3,DA4,IERI)
IF (IERI.EQ.0) THEN
DO ID=1,3
QHKL(ID)=DBQHKL(ID)
ENDDO
QM=DQM
QS=DQS
IERU=0
ELSE
IMOD=2
CALL ERRESO(IMOD,IERI)
IERU = IERI + 4
ENDIF
C
IERI=0
IF (LPA) THEN
IERU=1
CALL HELM_UP(DPHI,HELM,P_IH,C_IH,DHX,DHY,DHZ,IERI)
IF (IERI.NE.0) THEN
C WRITE(6,*) 'ERROR IN HELM_UP CHECK COEFF'
ELSE
HX=DHX
HY=DHY
HZ=DHZ
IERU=0
ENDIF
CALL FLIP_UP(IF1,IF2,P_IH,F1V,F1H,F2V,F2H,AKI,AKF,IERI)
ENDIF
C-----------------------------------------------------------------------
IER=IERU
RETURN
END
c
SUBROUTINE EX_UP(DX,EX,AKX,AX2,F,IER) ! Part of [MAD.SRC]T_UPDATE.FOR
c ================
c
C-----------------------------------------------------------------------
C CALCULATE EX AND AKX FORM AX2 VALUES
C-----------------------------------------------------------------------
implicit none
c
DOUBLE PRECISION PI
PARAMETER (PI=3.1415926535897932384626433832795E0)
DOUBLE PRECISION RD
PARAMETER (RD=57.29577951308232087679815481410517E0)
DOUBLE PRECISION EPS4
PARAMETER (EPS4=1.D-4)
C-----------------------------------------------------------------------
c Define the dummy arguments
c Input:
DOUBLE PRECISION DX ! D-SPACING OF CRISTAL
DOUBLE PRECISION AX2 ! TAKE OFF ANGLE
DOUBLE PRECISION F ! ENERGY UNIT
c Output:
DOUBLE PRECISION EX ! ENERGY
DOUBLE PRECISION AKX ! MOMENTUM
INTEGER*4 IER ! Error - IER=1 if DX OR AX TOO SMALL
C-----------------------------------------------------------------------
DOUBLE PRECISION ARG
C-----------------------------------------------------------------------
C!!!!!!!!!! This has to be fixed manually after conversion by f2c.
C!!!!!!!!!! The reason is a different definition of the abs function.
C!!!!!!!!!! MK, May 2001
ARG=ABS(DX*SIN(AX2/(2.D0*RD)))
IF(ARG.LE.EPS4) THEN
IER=1
ELSE
IER=0
AKX=PI/ARG
EX=F*AKX**2
ENDIF
C-----------------------------------------------------------------------
RETURN
END
c
SUBROUTINE SAM_UP ( ! Part of [MAD.SRC]T_UPDATE.FOR
c =================
+ QHKL, QM, QS, PHI,
+ AKI, AKF, A3, A4, IER)
C-----------------------------------------------------------------------
implicit none
c
double precision PI
PARAMETER (PI=3.1415926535897932384626433832795D0)
double precision RD
PARAMETER (RD=57.29577951308232087679815481410517D0)
double precision EPS3
PARAMETER (EPS3=1.D-3)
C-----------------------------------------------------------------------
c Define the dummy arguments
c Input:
double precision AKI ! Actual value of KI
double precision AKF ! Actual value of KF
double precision A3 ! Actual value of A3
double precision A4 ! Actual value of A4
c Output:
double precision QHKL(3) ! CALCULATED POSITIONS IN RECIP. LATTICE
double precision QM ! Q MODULUS
double precision QS ! Q MODULUS SQUARED
double precision PHI ! ANGLE BETWEEN KI AND Q
integer*4 IER ! Error status. IER=1 if QM TOO SMALL (PHI
! NOT CALCULATED)
C-----------------------------------------------------------------------
C LOCAL PARAMETERS
double precision QT(3)
double precision QPAR, QPERP
C-----------------------------------------------------------------------
C QPAR AND QPERP ARE COMPONENTS OF Q PARALLEL AND PERP TO KI
C TRANSFORM FROM SCATTERING PLANE INTO RECIPROCAL LATTICE
C
qpar = aki - akf * cos(a4/RD)
qperp = -akf * sin(a4/RD)
qt(1) = qpar * cos(a3/RD) + qperp * sin(a3/RD)
qt(2) = -qpar * sin(a3/RD) + qperp * cos(a3/RD)
qt(3) = 0.d0
call sp2rlv (qhkl, qt, qm, qs, ier)
ier = 3
if (qm .gt. EPS3) ier = 0
phi = 0.d0
if (abs(qperp) .gt. EPS3 .and. abs(qpar) .gt. EPS3) then
phi = atan2 (qperp, qpar)
elseif (abs(qpar) .lt. EPS3) then
if (a4 .gt. 0.0) then
phi = -0.5 * PI
else
phi = 0.5 * PI
endif
endif
c-----------------------------------------------------------------------
return
end
c
SUBROUTINE HELM_UP ( ! Part of [MAD.SRC]T_UPDATE.FOR
c ==================
+ PHI, HELM, P_IH, C_IH,
+ DHX, DHY, DHZ, IER)
c
C----------------------------------------------------------------
C HELMHOLTZ COILS UPDATE (ONLY IF LPA IS TRUE)
C----------------------------------------------------------------
implicit none
c
C include 'common_sinq.inc'
c
double precision PI
PARAMETER (PI = 3.1415926535897932384626433832795D0)
double precision RD
PARAMETER (RD = 57.29577951308232087679815481410517D0)
double precision EPS3
PARAMETER (EPS3 = 1.0D-3)
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-----------------------------------------------------------------------
c Define the dummy arguments
c Input:
double precision PHI ! Angle between KI and Q in scatt'g plane (rad)
real*4 HELM ! Angle between first coil and KI (degrees)
real*4 P_IH(8) ! Current values of 4 currents associated ..
! with Helmolz coils
real*4 C_IH(4) ! Conversion factor between Amperes and Gauss
c Output:
double precision DHX ! \
double precision DHY ! > The calculated fields
double precision DHZ ! /
integer*4 IER ! Error status. IER=1 if C_I HAS A ZERO COEF
C----------------------------------------------------------------
C LOCAL VARIABLES
integer*4 ic
double precision h(4), hpar, hperp, hmod, hdir, hdir2
LOGICAL AT_SINQ
C----------------------------------------------------------------
C H !FIELD OF 4 COILS AROUND SAMPLE
C HPAR !FIELD PAR COIL 1
C HPERP !FIELD PERP. TO COIL 1
C HDIR2 !ANGLE BETWEEN FIELD AND COIL 1
C HDIR !ANGLE BETWEEN FIELD AND Q
C----------------------------------------------------------------
ier = 0
AT_SINQ = .TRUE.
if (.not. at_sinq) then
do ic = 1, 4
h(ic) = 0.d0
if (abs(c_ih(ic)) .gt. EPS3) then
h(ic) = p_ih(ic+4) * c_ih(ic)
else
ier = 1
endif
enddo
hpar = h(1) - .5d0 * (h(2) + h(3))
hperp = .5d0 * sqrt(3.d0) * (h(2) - h(3))
dhz = h(4)
else
do ic = 1, 3
h(ic) = 0.d0
if (abs(c_ih(ic)) .gt. EPS3) then
h(ic) = p_ih(ic+4) * c_ih(ic)
else
ier = 1
endif
enddo
hpar = h(1)
hperp = h(2)
dhz = h(3)
endif
c
hmod = sqrt (hpar**2 + hperp**2)
if (abs(hpar) .gt. EPS3 .and. abs(hperp) .gt. EPS3) then
hdir2 = atan2 (abs(hperp), abs(hpar))
if (hpar .gt. 0 .and. hperp .lt. 0) then
hdir2 = -hdir2
elseif (hpar .lt. 0 .and. hperp .gt. 0) then
hdir2 = PI - hdir2
elseif (hpar .lt. 0 .and. hperp .lt. 0) then
hdir2 = hdir2 - PI
endif
elseif (abs(hpar) .gt. EPS3) then
if (hpar .ge. 0.0) hdir2 = 0.0
if (hpar .lt. 0.0) hdir2 = PI
elseif (abs(hperp) .gt. EPS3) then
if (hperp .ge. 0.0) hdir2 = 0.5 * PI
if (hperp .lt. 0.0) hdir2 = -0.5 * PI
else
hdir2 = 0.0
endif
hdir = hdir2 + (helm/RD) - phi
dhx = hmod * cos(hdir)
dhy = hmod * sin(hdir)
c
return
end
c
SUBROUTINE FLIP_UP ( ! Part of [MAD.SRC]T_UPDATE.FOR
c ==================
+ IF1, IF2,
+ P_IH, F1V, F1H, F2V, F2H,
+ AKI, AKF, IER)
C----------------------------------------------------------------
C FLIPPERS; ONLY IF LPA
C----------------------------------------------------------------
implicit none
C-----------------------------------------------------------------------
c Define the dummy arguments
c Input:
real*4 p_ih(8) ! Current values of 4 currents associated ..
! with flipper coils
real*4 f1v, f1h ! Flipper 1 vert and hor currents (hor ..
! .. current is possibly aki*f1h ??)
real*4 f2v, f2h ! Flipper 2 vert and hor currents (hor ..
! .. current is possibly akf*f2h ??)
real*4 aki ! Incident neutron wave vector
real*4 akf ! Final neutron wave vector
c Output:
integer*4 if1 ! Status of Flipper 1 (=1 if on and set OK)
integer*4 if2 ! Status of Flipper 2 (=1 if on and set OK)
integer*4 ier ! Error status. 0 if no error.
C----------------------------------------------------------------
IER = 0
IF1 = 0
IF2 = 0
IF ((ABS(P_IH(1) - F1V) .LT. 0.05) .AND.
+ (ABS(P_IH(2) - AKI*F1H) .LT. 0.05)) IF1 = 1
IF ((ABS(P_IH(3) - F2V) .LT. 0.05) .AND.
+ (ABS(P_IH(4) - AKF*F2H) .LT. 0.05)) IF2 = 1
C-----------------------------------------------------------------------
RETURN
END