From e52bd5d9371466f2d18f932525ed3638cda766fe Mon Sep 17 00:00:00 2001 From: cvs Date: Mon, 30 Jun 2003 11:51:35 +0000 Subject: [PATCH] - Updated Makefiles - 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 --- Makefile | 131 ------ doc/programmer/command.tex | 637 +++++++++++++++++++++++++ doc/programmer/kernelguide.tex | 102 ++-- doc/programmer/oguide.tex | 3 +- doc/programmer/overview.tex | 84 ++-- doc/programmer/programmer.tex | 18 +- doc/programmer/proto.tex | 60 +-- doc/programmer/sicsdriver.tex | 620 ++++++++++++++++++++++++ doc/programmer/site.tex | 129 +++++ make_gen | 4 +- makefile_linux | 17 +- t_conv.c | 838 --------------------------------- t_conv.f | 690 --------------------------- t_rlp.c | 516 -------------------- t_rlp.f | 463 ------------------ t_update.c | 495 ------------------- t_update.f | 409 ---------------- 17 files changed, 1561 insertions(+), 3655 deletions(-) delete mode 100644 Makefile create mode 100644 doc/programmer/command.tex create mode 100644 doc/programmer/sicsdriver.tex create mode 100644 doc/programmer/site.tex delete mode 100644 t_conv.c delete mode 100755 t_conv.f delete mode 100644 t_rlp.c delete mode 100755 t_rlp.f delete mode 100644 t_update.c delete mode 100755 t_update.f diff --git a/Makefile b/Makefile deleted file mode 100644 index 566dff71..00000000 --- a/Makefile +++ /dev/null @@ -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 - - diff --git a/doc/programmer/command.tex b/doc/programmer/command.tex new file mode 100644 index 00000000..cfa00713 --- /dev/null +++ b/doc/programmer/command.tex @@ -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. diff --git a/doc/programmer/kernelguide.tex b/doc/programmer/kernelguide.tex index ce1ab7ea..bba0cc46 100644 --- a/doc/programmer/kernelguide.tex +++ b/doc/programmer/kernelguide.tex @@ -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. + diff --git a/doc/programmer/oguide.tex b/doc/programmer/oguide.tex index b57aafb3..dc940cc9 100644 --- a/doc/programmer/oguide.tex +++ b/doc/programmer/oguide.tex @@ -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 diff --git a/doc/programmer/overview.tex b/doc/programmer/overview.tex index 982664fd..587fd3b3 100644 --- a/doc/programmer/overview.tex +++ b/doc/programmer/overview.tex @@ -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. + + diff --git a/doc/programmer/programmer.tex b/doc/programmer/programmer.tex index fe4571fa..87fda588 100644 --- a/doc/programmer/programmer.tex +++ b/doc/programmer/programmer.tex @@ -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} + + + + + + + + + + diff --git a/doc/programmer/proto.tex b/doc/programmer/proto.tex index 0f17d7fb..4ab59ada 100644 --- a/doc/programmer/proto.tex +++ b/doc/programmer/proto.tex @@ -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. + + + diff --git a/doc/programmer/sicsdriver.tex b/doc/programmer/sicsdriver.tex new file mode 100644 index 00000000..1d386e70 --- /dev/null +++ b/doc/programmer/sicsdriver.tex @@ -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} \ No newline at end of file diff --git a/doc/programmer/site.tex b/doc/programmer/site.tex new file mode 100644 index 00000000..0fa56212 --- /dev/null +++ b/doc/programmer/site.tex @@ -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! + + + + diff --git a/make_gen b/make_gen index 8083f39c..b200136f 100644 --- a/make_gen +++ b/make_gen @@ -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) \ diff --git a/makefile_linux b/makefile_linux index 3bfe0620..f47921b2 100644 --- a/makefile_linux +++ b/makefile_linux @@ -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 + + + + + + + + + diff --git a/t_conv.c b/t_conv.c deleted file mode 100644 index 6e6c5802..00000000 --- a/t_conv.c +++ /dev/null @@ -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__ */ - diff --git a/t_conv.f b/t_conv.f deleted file mode 100755 index ba39ef37..00000000 --- a/t_conv.f +++ /dev/null @@ -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 diff --git a/t_rlp.c b/t_rlp.c deleted file mode 100644 index 8d66baa9..00000000 --- a/t_rlp.c +++ /dev/null @@ -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_ */ - diff --git a/t_rlp.f b/t_rlp.f deleted file mode 100755 index 26b7b69a..00000000 --- a/t_rlp.f +++ /dev/null @@ -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 diff --git a/t_update.c b/t_update.c deleted file mode 100644 index 99b96553..00000000 --- a/t_update.c +++ /dev/null @@ -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__ */ - diff --git a/t_update.f b/t_update.f deleted file mode 100755 index f5c63d81..00000000 --- a/t_update.f +++ /dev/null @@ -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