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

insert tecs_client into archive + little update

Browse Source
This commit is contained in:
cvs
2000-05-29 09:05:05 +00:00
parent 1a56fbc568
commit a89b3208d6
12 changed files with 1433 additions and 165 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
tecs/coc_client.c
View File

@ -92,6 +92,18 @@ int CocSendMagic(CocConn *conn, char *magic) {
/*-------------------------------------------------------------------------*/
int CocCheck(CocConn *conn) {
if (conn->fd<0) return(1);
ERR_SI(send(conn->fd, "quit", 5, 0));
ERR_I(CocRecv(conn->fd, conn->resbuf));
return(0);
OnError:
if (ErrCode==ECONNRESET || ErrCode==EPIPE) return(1);
return(-1);
}
/*-------------------------------------------------------------------------*/
int CocTryCmd(CocConn *conn)
{ if (conn->fd<0) {
ERR_I(CocOpen(conn));

7
tecs/coc_client.h
View File

@ -32,7 +32,12 @@ int CocCmd(CocConn *conn, const char *rwList);
see COC_UTIL.H for the definiton of variables
*/
int CocCheck(CocConn *conn);
/*
returns 1, if not yet open
returns 0, if connection o.k.
retruns -1 (error message), if connection died
*/
int CocSet(CocConn *conn, const char *name, const char *value);
/*
set one variable

7
tecs/coc_logfile.c
View File

@ -44,6 +44,7 @@ void logfileOpen(int first) {
if (logfileStd) {
fil=stdout;
str_copy(filnam, "<stdout>");
return;
}
assert(fil==NULL);
if (first) {
@ -76,6 +77,10 @@ void logfileOpen(int first) {
}
#endif
ErrSetOutFile(fil);
if (first) {
fprintf(fil, "%04d-%02d-%02d opened logfile\n"
, tim->tm_year+1900, tim->tm_mon+1, tim->tm_mday);
}
}
void logfileStatusBuffer(char *buffer, int bufsize) {
@ -182,7 +187,7 @@ void logfileWrite0(int mask) {
next++;
if (*next & logMask) {
if (*s=='@') { /* write out time */
lastStamp=-2;
lastStamp-=2; /* force output */
logfileStamp(s+1);
} else {
logfileStamp("\n"); /* write stamp before write something */

6
tecs/coc_util.c
View File

@ -171,6 +171,8 @@ void CocDefVarS(const char *name, const char *tname, void *var, int type) {
p->strucType=CocDefVar(tname, NULL, COC_TYPE, &CocRD);
}
char err_name[64];
int CocGetVar(CocVar *varList, Str_Buf *buf, const char *name, int secure) {
CocVar *var;
void *adr;
@ -199,7 +201,7 @@ int CocGetVar(CocVar *varList, Str_Buf *buf, const char *name, int secure) {
(*var->flag)++;
}
return(0);
OnError: return(-1);
OnError: str_copy(err_name, name); ErrTxt(err_name,0); return(-1);
}
int CocPutVar(CocVar *varList, Str_Buf *buf, const char *name, int secure) {
@ -231,7 +233,7 @@ int CocPutVar(CocVar *varList, Str_Buf *buf, const char *name, int secure) {
if (var->flag!=NULL) (*var->flag)++;
}
return(0);
OnError: return(-1);
OnError: str_copy(err_name, name); ErrTxt(err_name,0); return(-1);
}
void CocFreeVarList(CocVar **varList) {

245
tecs/sys_aunix.f Normal file
View File

@ -0,0 +1,245 @@
!!------------------------------------------------------------------------------
!! MODULE SYS
!!------------------------------------------------------------------------------
!! 10.9.97 M. Zolliker
!!
!! System dependent subroutines for ALPHA UNIX
!!------------------------------------------------------------------------------
!!
subroutine SYS_GETENV(NAME, VALUE) !!
!! ==================================
!!
!! Get logical name NAME
!! If the logical name is not in any table, VALUE will be blank
implicit none
!! Arguments:
character*(*) NAME !! logical name
character*(*) VALUE !! result
integer l
integer lnblnk
l=lnblnk(name)
call getenv(name(1:l), value)
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_DATE(YEAR, MONTH, DAY) !!
!! -------------------------------------
!!
!! get actual date
!!
integer YEAR, MONTH, DAY !! 4-Digits year, month and day
integer tarray(9)
external time
integer time
call ltime(time(), tarray)
day=tarray(4)
month=tarray(5)+1 ! tarray(5): months since january (0-11)!
year=tarray(6)+1900 ! tarray(6): years since 1900, no y2k problem
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_REMOTE_HOST(STR, TYPE) !!
!!
!! get remote host name/number
!!
!! type: TN telnet, RT: decnet, XW: X-window
!!
character STR*(*), TYPE*(*) !!
character host*128
integer i,j
integer lnblnk
call sys_getenv('HOST', host)
call sys_getenv('DISPLAY', str)
i=index(str,':')
if (i .gt. 1) then
str=str(1:i-1)
type='XW'
else
call sys_getenv('REMOTEHOST', str)
if (str .ne. ' ') then
type='TN'
else
str=host
type='LO'
endif
endif
! add domain to short host names
i=index(str, '.')
j=index(host, '.')
if (j .gt. 0 .and. i .eq. 0) then
i=lnblnk(str)
str(i+1:)=host(j:)
endif
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_GET_LUN(LUN) !!
!!
!! allocate logical unit number
integer LUN !! out
logical*1 act(50:100)/51*.false./
save act
integer l
l=50
do while (l .lt. 99 .and. act(l))
l=l+1
enddo
if (l .eq. 100) stop 'SYS_GET_LUN: no more luns available'
lun=l
act(l)=.true.
return
!!
entry SYS_FREE_LUN(LUN) !!
!!
!! deallocate logical unit number
if (act(lun)) then
act(lun)=.false.
else
stop 'SYS_FREE_LUN: lun already free'
endif
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_RENAME_FILE(OLD, NEW) !!
!! ====================================
!!
character OLD*(*), NEW*(*) !! (in) old, new filename
call rename(OLD, NEW)
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_DELETE_FILE(NAME) !!
!! ================================
!!
character NAME*(*) !! (in) filename
call unlink(NAME)
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_HOME(HOME) !!
!! =========================
!!
!! get home directory (+ dot)
character HOME*(*) !! (out) filename
integer l
integer lnblnk
call sys_getenv('HOME',home)
l=lnblnk(home)
if (l .lt. len(home)-1) then
if (home(l:l) .ne. '/') then
home(l+1:l+1)='/'
l=l+1
endif
home(l+1:l+1)='.'
l=l+1
endif
end
!!------------------------------------------------------------------------------
!!
subroutine SYS_CHECK_SYSTEM(CODE) !!
!! =================================
!!
character CODE*(*) !!
code='ALPHA_UNIX' !!
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_GET_CMDPAR(STR, L) !!
!! ---------------------------------
!!
character*(*) STR !!
integer L !!
integer i
integer lnblnk
l=0
str=' '
do i=1,iargc()
if (l .lt. len(str)) then
call getarg(i, str(l+1:))
l=lnblnk(str)
l=l+1
endif
enddo
if (l .gt. 0) then
if (str(1:l) .eq. ' ') l=0
endif
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_GET_KEY(KEY, TMO) !!
!!
!! read for keyboard with timeout, without echo
!!
character KEY*1 !!
integer TMO !! timeout in seconds (<100)
parameter esc=char(27), csi=char(155), ss3=char(143)
call sys_get_raw_key(key, tmo)
1 if (key .eq. esc) then
call sys_get_raw_key(key, tmo)
if (key .eq. 'O') then
key=ss3
goto 1
elseif (key .eq. '[') then
key=csi
goto 1
endif
elseif (key .eq. csi) then
call sys_get_raw_key(key, tmo)
do while (key .ge. '0' .and. key .le. '9')
call sys_get_raw_key(key, tmo)
enddo
key=' '
elseif (key .eq. ss3) then
call sys_get_raw_key(key, tmo)
if (key .eq. 'm') then
key='-'
elseif (key .eq. 'l') then
key='+'
elseif (key .eq. 'n') then
key='.'
elseif (key .eq. 'M') then
key=char(13)
elseif (key .eq. 'S') then
key='*'
elseif (key .eq. 'R') then
key='/'
elseif (key .eq. 'Q') then
key='='
else
key=' '
endif
endif
end

127
tecs/sys_aunix_c.c Normal file
View File

@ -0,0 +1,127 @@
#include <termios.h>
#include <time.h>
#include <assert.h>
#include <unistd.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <setjmp.h>
#include <signal.h>
#include <limits.h>
static char *last_line = NULL;
char *readline (char *prompt);
void sys_rd_line_(char *cmd, int *retlen, char *prompt, int clen, int plen)
{
char *line_read, *p;
int l;
l = lnblnk_(prompt, clen);
p = malloc((unsigned) l+2); if( p == NULL ) return;
strncpy(p+1,prompt,l); p[0]='\n'; p[l] = '\0';
if (last_line == NULL) { last_line =malloc(1); last_line[0] = '\0';};
line_read = readline(p);
free(p);
if (line_read)
{
if (*line_read && strcmp(last_line, line_read)!=0)
add_history (line_read);
free (last_line);
strncpy(cmd, line_read, clen);
*retlen=strlen(line_read);
last_line = line_read;
if (*retlen>clen) *retlen=clen;
} else {
*retlen=-1;
}
}
void intcatch(int sig)
{ printf("\nuse quit (normally ctrl-\) to interrupt\n");
}
int called=0; /* env is valid only if called==1 */
jmp_buf env;
void (*inthdl)(int sig);
void (*errhdl)();
void sighdl(int sig)
{ if (called) longjmp(env,sig);
}
void sys_err_hdl_(void errhdl0())
{ errhdl=errhdl0; };
void sys_int_hdl_(void inthdl0(int sig))
{ inthdl=inthdl0; };
void sys_try_(void proc())
{ int sig, status;
void (*sgh[32]) (int);
assert(!called); /* nested calls not allowed */
called=1;
sgh[SIGFPE] =signal(SIGFPE, sighdl);
sgh[SIGINT] =signal(SIGINT, *inthdl);
status=setjmp(env);
if (status==0) /* first return of setjmp */
{ proc(); }
else
{ (*errhdl)(); };
signal(SIGFPE, sgh[SIGFPE]);
signal(SIGINT, intcatch);
called=0;
}
void sys_abort_()
{ if (called) longjmp(env,-2);
}
void sys_exit_hdl_(void hdl())
{ int res;
res=atexit(hdl);
}
struct termios atts;
void sys_get_raw_key_(char *key, int *tmo, int k_len)
{
struct termios attr;
int ires, ntmo, chr;
ires=tcgetattr(STDIN_FILENO,&attr);
atts=attr; /* save term. attr. */
if (ires!=0) {perror("***\n");}
attr.c_lflag &= ~(ICANON) & ~(ECHO); /* canonical mode off, echo off */
attr.c_cc[VMIN]=0;
ires= tcsetattr(STDIN_FILENO,TCSANOW,&attr);
if (ires!=0) {perror("***\n");}
/*
ires=fflush(stdin);
ires=fflush(stderr);
*/
ntmo=*tmo*100;
chr=fgetc(stdin);
if (chr==EOF) {
while ((chr==EOF) & (ntmo>0)) {
usleep(10000); /* wait 10 ms */
chr=fgetc(stdin);
ntmo--;
}
}
if (chr==EOF) chr=0;
*key=chr;
ires=tcsetattr(STDIN_FILENO,TCSANOW,&atts); /* restore term. attributes */
if (ires!=0) {perror("***\n");};
}

5
tecs/tecs.bld Normal file
View File

@ -0,0 +1,5 @@
f90 -c -g strings.f90
f90 -c -g tecs_plot.f90
f77 -o tecs -g tecs_client.f tecs_for.f sys_aunix_c.c \
tecs_plot.o sys_aunix.f strings.o -L. -ltecsl -L/data/lnslib/lib -lpgplot \
-so_archive -lreadline -ltermcap -lX11 -lXm

353
tecs/tecs.c
View File

@ -25,24 +25,36 @@ static char *binDir=NULL;
static char *logDir=NULL;
typedef struct {
float temp, t1, t2; /* calc, high, low temperature */
float tMin, tMax, min1, max1, min2, max2; /* minimum and maximum temperatures since ... */
float t, min, max; /* temperatures */
int sMin, sMax; /* reading status summary */
int present; /* sensor is present */
int readStat; /* reading status */
char ch[2]; /* channels */
} SensorT;
SensorT
sens1, sens2, sens3, sens4,
*sensors[5]={NULL, &sens1, &sens2, &sens3, &sens4 },
*sensor=&sens1;
typedef struct {
SensorT *sensor1, *sensor2;
float temp; /* weighted temperature */
float tMin, tMax; /* minimum and maximum temperatures since ... */
int dirty; /* input config to be reloaded */
int try; /* trial count */
int manual; /* manual device */
int code, code1; /* device code, buffer for device code */
int nSens; /* number of sensors */
int codChanged; /* code has changed */
int codDefined; /* code is not yet confirmed */
float scale; /* scale for extreme ranges */
char ch1[2], ch2[2]; /* channels for high/low T */
char device[16]; /* device name */
char tname[16];
} Testpoint;
Testpoint /* C standard guarantees initialization to zero */
cryo, /* data for main sensors (on heat exchanger, or the only sensors) */
samp, /* data for extra sensors of sample stick */
cryo={&sens1, &sens2 }, /* data for main sensors (on heat exchanger, or the only sensors) */
samp={&sens3, &sens4 }, /* data for extra sensors of sample stick */
*tpoints[2]={&cryo, &samp},
*tpoint=&cryo;
@ -68,6 +80,7 @@ static int
noResp=2, /* no response */
quit, /* quit server */
controlMode=2, /* 0: control on heater, 1: control on sample, 3: 2nd loop for difference heater-sample */
int2=30, /* inegration time for controlMode 2 */
remoteMode, /* 1: local, 2: remote */
maxfld, /* last used display field */
busy, /* busy after CRVSAV */
@ -379,13 +392,15 @@ int configInput(void) {
t++;
n=1;
if (tpoint==&samp) {
samp.nSens=0;
sens3.present=0;
sens4.present=0;
i=sscanf(t, "%12s%d%d", nam, &nn, &n);
if (i<1) ERR_MSG("missing sensor name");
ext=".s";
dispFld=2;
} else {
cryo.nSens=0;
sens1.present=0;
sens2.present=0;
tLow=0; tHigh=0;
controlMode=0;
i=sscanf(t, "%12s%d%d%d%f%d%f%f%f", nam, &n, &nn, &controlMode, &tLimit, &resist, &power, &tLow, &tHigh);
@ -402,12 +417,13 @@ int configInput(void) {
}
str_append(nam, ext);
ERR_I(retstat=instCurve(nam, tpoint->ch1, dispFld));
ERR_I(retstat=instCurve(nam, tpoint->sensor1->ch, dispFld));
tpoint->sensor1->present=1;
if (n==2) {
str_append(nam, "l");
ERR_I(retstat=instCurve(nam, tpoint->ch2, dispFld+2));
ERR_I(retstat=instCurve(nam, tpoint->sensor2->ch, dispFld+2));
tpoint->sensor2->present=1;
}
tpoint->nSens=n;
return(0);
OnError: return(retstat);
}
@ -452,73 +468,84 @@ int loadCache(void) {
return(-1);
}
float WeightedAverage(int n, float tH, float tL) {
float WeightedAverage(int presentH, int presentL, float tH, float tL) {
float p,q;
if (n==0) {
return(0.0);
} else if (n<2) {
return(tH);
} else {
if (tL<tLow) {
return(tL);
} else if (tH<tHigh) {
p=tHigh-tH;
q=tL-tLow;
if (p==0.0 && q==0.0) { p=1; q=1; } /* should not be the case */
return((tL*p*p+tH*q*q)/(p*p+q*q));
} else {
return(tH);
if (presentH) {
if (presentL) {
if (tL<tLow) {
return(tL);
} else if (tH<tHigh) {
p=tHigh-tH;
q=tL-tLow;
if (p==0.0 && q==0.0) { p=1; q=1; } /* should not be the case */
return((tL*p*p+tH*q*q)/(p*p+q*q));
}
}
return(tH);
} else if (presentL) {
return(tL);
}
return(0.0);
}
int LogMinMax(int new) {
char buf[256];
int i, j, logIt;
char buf[256], bufs[256];
int i, j, l, ls, logIt, stat;
float tol, tmin[2], tmax[2];
SensorT *s1, *s2;
buf[0]='\0';
if (cryo.nSens>0) {
str_append(buf, "MDAT?[cryo.ch1]>cryo.min1,cryo.max1;");
if (cryo.nSens>1) {
str_append(buf, "MDAT?[cryo.ch2]>cryo.min2,cryo.max2;");
} else {
cryo.t2=0;
l=0;
ls=0;
for (i=1; i<=4; i++) {
sensor=sensors[i];
sensor->sMin=0;
sensor->sMax=0;
if (sensor->present) {
assert(l<128);
sprintf(buf+l, "MDAT?[sens%d.ch]>sens%d.min,sens%d.max;", i, i, i);
l=strlen(buf);
assert(ls<128);
sprintf(bufs+ls, "MDATST?[sens%d.ch]>sens%d.sMin,sens%d.sMax;", i, i, i);
ls=strlen(bufs);
}
} else {
cryo.t1=0;
cryo.t2=0;
}
if (samp.nSens>0) {
str_append(buf, "MDAT?[samp.ch1]>samp.min1,samp.max1;");
if (samp.nSens>1) {
str_append(buf, "MDAT?[samp.ch2]>samp.min2,samp.max2;");
} else {
samp.t2=0;
}
} else {
samp.t1=0;
samp.t2=0;
}
i=strlen(buf);
if (i>0) {
if (ls>0) {
bufs[ls-1]='\0'; /* strip off ';' */
ERR_P(LscCmd(ser, bufs));
str_append(buf, "MNMXRST");
ERR_P(LscCmd(ser, buf));
}
/* check for reading errors */
for (i=1; i<=4; i++) {
sensor=sensors[i];
stat=sensor->sMin | sensor->sMax;
if (stat != sensor->readStat) {
sensor->readStat=stat;
if (stat & 1) logfileOut(LOG_MAIN, "invalid reading %s\n", sensor->ch);
if (stat & 2) logfileOut(LOG_MAIN, "old reading %s\n", sensor->ch);
if (stat & 12) logfileOut(LOG_MAIN, "unknown reading status %s\n", sensor->ch);
if (stat & 16) logfileOut(LOG_MAIN, "temp underrange %s\n", sensor->ch);
if (stat & 32) logfileOut(LOG_MAIN, "temp overrange %s\n", sensor->ch);
if (stat & 64) logfileOut(LOG_MAIN, "units zero %s\n", sensor->ch);
if (stat &128) logfileOut(LOG_MAIN, "units overrange %s\n", sensor->ch);
if (stat==0) logfileOut(LOG_MAIN, "reading o.k. %s\n", sensor->ch);
}
}
logIt=0;
for (i=0; i<2; i++) {
tpoint=tpoints[i];
if (tpoint->nSens>0) {
tpoint->tMin = WeightedAverage(tpoint->nSens, tpoint->min1, tpoint->min2) * tpoint->scale;
tpoint->tMax = WeightedAverage(tpoint->nSens, tpoint->max1, tpoint->max2) * tpoint->scale;
}
s1=tpoint->sensor1;
s2=tpoint->sensor2;
tpoint->tMin = WeightedAverage(s1->present, s2->present, s1->min, s2->min) * tpoint->scale;
tpoint->tMax = WeightedAverage(s1->present, s2->present, s1->max, s2->max) * tpoint->scale;
}
sprintf(buf, "@%.3f < T < %.3f K", cryo.tMin, cryo.tMax);
if (samp.nSens>0) {
if (samp.tMax>0.0) {
sprintf(buf1, "(reg), %.3f < T < %.3f K (samp)", samp.tMin, samp.tMax);
str_append(buf, buf1);
}
@ -542,13 +569,13 @@ int SetTemp(int switchOn) {
logfileOut(LOG_MAIN, "set %.3f\n", tempC);
}
scale=cryo.scale;
ch=cryo.ch1;
if (cryo.nSens>1 && tempC<(tLow+tHigh)/2) ch=cryo.ch2;
if (samp.nSens>0) {
ch=sens1.ch;
if (sens2.present && tempC<(tLow+tHigh)/2) ch=sens2.ch;
if (sens3.present) {
if (controlMode==1) { /* control directly on sample sensor */
tShift=0;
ch=samp.ch1;
if (cryo.nSens>1 && tempC<(tLow+tHigh)/2) ch=samp.ch2;
ch=sens3.ch;
if (sens2.present && tempC<(tLow+tHigh)/2) ch=sens4.ch;
scale=samp.scale;
} else if (controlMode!=2) {
tShift=0;
@ -581,42 +608,29 @@ int SetTemp(int switchOn) {
int ReadTemp(void) {
char buf[256];
int i;
int i, l;
SensorT *sensor;
readTemp=0;
buf[0]='\0';
if (cryo.nSens>0) {
str_append(buf, "KRDG?[cryo.ch1]>cryo.t1;");
if (cryo.nSens>1) {
str_append(buf, "KRDG?[cryo.ch2]>cryo.t2;");
l=0;
for (i=1; i<=4; i++) {
sensor=sensors[i];
if (sensor->present) {
assert(l<128);
sprintf(buf+l, "KRDG?[sens%d.ch]>sens%d.t;", i, i);
l=strlen(buf);
} else {
cryo.t2=0;
sensor->t=0.0;
}
} else {
cryo.t1=0;
cryo.t2=0;
}
if (samp.nSens>0) {
str_append(buf, "KRDG?[samp.ch1]>samp.t1;");
if (samp.nSens>1) {
str_append(buf, "KRDG?[samp.ch2]>samp.t2;");
} else {
samp.t2=0;
}
} else {
samp.t1=0;
samp.t2=0;
}
i=strlen(buf);
if (i>0) {
buf[i-1]='\0'; /* strip off ';' */
if (l>0) {
buf[l-1]='\0'; /* strip off ';' */
ERR_P(LscCmd(ser, buf));
}
cryo.temp=WeightedAverage(cryo.nSens, cryo.t1, cryo.t2)*cryo.scale;
samp.temp=WeightedAverage(samp.nSens, samp.t1, samp.t2)*samp.scale;
cryo.temp=WeightedAverage(sens1.present, sens2.present, sens1.t, sens2.t)*cryo.scale;
samp.temp=WeightedAverage(sens3.present, sens4.present, sens3.t, sens4.t)*samp.scale;
if (samp.temp==0.0) samp.temp=cryo.temp;
if (!deviceFlag
&& !samp.dirty && samp.codDefined && !samp.codChanged
@ -635,7 +649,7 @@ int PeriodicTask(void) {
char *next;
int i, k;
time_t putTim;
float t3[3], p, d, w;
float t3[3], p, d, w, t;
ERR_P(LscCmd(ser, "DIOST?>cod1,out1;DOUT 3,29;HTR?>htr;HTRST?>htrst;BUSY?>busy"));
if (cryo.codDefined && samp.codDefined) {
@ -644,6 +658,7 @@ int PeriodicTask(void) {
}
if (htrst!=htrst0) {
ERR_I(LogMinMax(0));
if (htrst<0 || htrst>6) {
sprintf(buf, "heater status %d\n", htrst);
logfileOut(LOG_MAIN, buf);
@ -715,18 +730,18 @@ int PeriodicTask(void) {
if (tim>=logTime) {
i=0;
if (cryo.nSens>0) {
if (sens1.present) {
t3[0]=cryo.temp;
i=1;
} else {
t3[0]=undef;
}
if (samp.nSens>0) {
if (sens3.present) {
t3[1]=samp.temp;
i=2;
} else {
if (cryo.nSens>1) {
t3[1]=cryo.t2;
if (sens2.present) {
t3[1]=sens2.t;
i=2;
} else {
t3[1]=undef;
@ -743,11 +758,14 @@ int PeriodicTask(void) {
logTime=(putTim/logPeriod+1)*logPeriod;
if (tim>mmTime) ERR_I(LogMinMax(0));
}
if (samp.nSens>0 && cryo.nSens>0 && controlMode==2 && tempC!=0) {
d=(tempH-cryo.temp)/cryo.temp-1.0; /* relative difference */
if (sens1.present && sens3.present && controlMode==2 && tempC!=0) {
t=sens1.t;
if (sens2.present && tempC<(tLow+tHigh)/2) t=sens2.t;
d=(tempH-t)/t-1.0; /* relative difference */
w=exp(-d*d*230); /* gaussian */
if (w<0.1) tInt=0; /* reset when far from setpoint (more than 10 %) */
if (tInt<30000/per) tInt+=w; /* increase integral time until 30 sec. */
if (int2<1) int2=1;
if (tInt<int2*1000/per) tInt+=w; /* increase integral time until int2 sec. */
if (tInt>w) {
p=w/tInt;
} else {
@ -847,7 +865,8 @@ int inputSettings(Testpoint *this) {
}
}
if (tpoint->dirty>0) tpoint->try=0;
tpoint->nSens=0;
tpoint->sensor1->present=0;
tpoint->sensor2->present=0;
if (!tpoint->manual) { tpoint->device[0]='\0'; concatDevice(); }
tpoint->dirty=configInput();
if (tpoint->dirty<0) {
@ -896,52 +915,50 @@ int SetPower(void) {
}
int Display(void) {
char flds[5], fmt[5], disp[32], buf[256];
int i,j,k;
char flds[6], fmt[6], buf[256];
int i,k,l;
SensorT *s;
maxfld=0;
for (i=1; i<=4; i++) { flds[i]=' '; fmt[i]=' '; }
for (j=0; j<2; j++) { /* fill in kelvin display fields */
tpoint=tpoints[j];
if (tpoint->nSens>0) {
k=1+j;
flds[k]=tpoint->ch1[0]; fmt[k]='1'; if (k>maxfld) maxfld=k;
if (tpoint->nSens>1) {
k=3+j;
flds[k]=tpoint->ch2[0]; fmt[k]='1'; if (k>maxfld) maxfld=k;
k=1;
flds[0]='*';
flds[5]='\0';
for (i=1; i<=4; i++) { /* fill in kelvin fields */
s=sensors[i];
if (s->present) {
flds[k]=s->ch[0];
fmt[k]='1';
if (k>maxfld) maxfld=k;
} else {
flds[k]='\0';
}
k=k+2; if (k>4) k=2;
}
for (i=1; i<=4; i++) { /* fill in raw fields */
s=sensors[i];
if (s->present) {
k=strlen(flds); /* find next free field */
if (k<=4) {
if (k>maxfld) maxfld=k;
flds[k]=s->ch[0];
fmt[k]='3';
}
}
}
for (j=0; j<2; j++) { /* fill raw display fields */
tpoint=tpoints[j];
if (tpoint->nSens>0) {
k=2-j; /* try first right (or left) of the kelvin field */
if (flds[k]!=' ') k=3+j; /* then the field below */
if (flds[k]!=' ') k=4-j; /* then below right */
if (flds[k]==' ') {
if (k>maxfld) maxfld=k;
flds[k]=tpoint->ch1[0]; fmt[k]='3';
}
if (tpoint->nSens>1) {
k=4-j; /* try right (or left) of the kelvin field */
if (flds[k]==' ') {
if (k>maxfld) maxfld=k;
flds[k]=tpoint->ch2[0]; fmt[k]='3';
}
}
}
}
/* fields 5-8 standard raw data */
ERR_P(LscCmd(ser, "DISPFLD 5,A,3;DISPFLD 6,C,3;DISPFLD 7,B,3;DISPFLD 8,D,3"));
if (maxfld==0) { /* show raw data */
ERR_P(LscCmd(ser, "DISPFLD 1,A,3;DISPFLD 2,C,3;DISPFLD 3,B,3;DISPFLD 4,D,3;DISPLAY:4"));
} else {
buf[0]='\0';
for (i=1; i<=maxfld; i++) {
if (flds[i]!=' ') {
sprintf(disp, "DISPFLD %d,%c,%c;", i, flds[i], fmt[i]);
l=0;
for (k=1; k<=maxfld; k++) {
if (flds[k]!='\0') {
assert(l<128);
sprintf(buf+l, "DISPFLD %d,%c,%c;", k, flds[k], fmt[k]);
l=strlen(buf);
}
str_append(buf, disp);
}
str_append(buf, "DISPLAY:[maxfld]");
ERR_P(LscCmd(ser, buf));
@ -952,6 +969,7 @@ int Display(void) {
int Settings(void) {
char nbuf[256], buf[256], *cfg, *p;
char alarms[3];
cfg=NULL;
if (cryo.dirty && cryo.codDefined || samp.dirty && samp.codDefined) {
@ -959,17 +977,30 @@ int Settings(void) {
ERR_I(inputSettings(&cryo));
ERR_I(inputSettings(&samp));
if (cryo.nSens>0) {
ERR_P(LscCmd(ser, "ALARM A:0;ALARM B:0;ALARM C:0;ALARM D:0"));
alarms[0]='\0';
alarms[1]='\0';
alarms[2]='\0';
if (sens1.present) {
ERR_I(SetPower());
ERR_P(LscCmd(ser, "ALARM [cryo.ch1]:1,1,[tLimit],0,0,1;ALARM [cryo.ch2]:0;RELAY 1:1;BEEP:0"));
if (samp.nSens>0) {
ERR_P(LscCmd(ser, "ALARM [samp.ch1]:1,1,[tLimit],0,0,1;ALARM [samp.ch2]:0"));
} else {
ERR_P(LscCmd(ser, "ALARM [samp.ch1]:0;ALARM [samp.ch2]:0"));
str_copy(buf, "ALARM [sens1.ch]:1,1,[tLimit],0,0,1;RELAY 1:1;BEEP:0");
alarms[0]=sens1.ch[0];
if (sens3.present) {
str_append(buf, ";ALARM [sens3.ch]:1,1,[tLimit],0,0,1");
alarms[1]=sens3.ch[0];
}
} else {
ERR_P(LscCmd(ser, "ALARM [cryo.ch1]:0;ALARM [cryo.ch2]:0;ALARM [samp.ch1]:0;ALARM [samp.ch2]:0"));
ERR_P(LscCmd(ser, buf));
}
/* switch of unused channels */
buf[0]='\0';
if (NULL==strchr(alarms, 'A')) str_append(buf, ";ALARM A:0");
if (NULL==strchr(alarms, 'B')) str_append(buf, ";ALARM B:0");
if (NULL==strchr(alarms, 'C')) str_append(buf, ";ALARM C:0");
if (NULL==strchr(alarms, 'D')) str_append(buf, ";ALARM D:0");
if (buf[0]!='\0') ERR_P(LscCmd(ser, buf+1)); /* send without leading semicolon */
ERR_I(Display());
str_copy(nbuf, binDir);
@ -1012,7 +1043,7 @@ int ExecuteRequest(void) {
}
if (setFlag) {
setFlag=0;
if (cryo.nSens>0) {
if (sens1.present) {
tInt=0; /* reset integral time */
ERR_I(SetTemp(1));
}
@ -1123,11 +1154,11 @@ int main(int argc, char *argv[])
int port, msecTmo;
str_copy(cryo.tname,"main");
str_copy(cryo.ch1,"A");
str_copy(cryo.ch2,"B");
str_copy(sens1.ch,"A");
str_copy(sens2.ch,"B");
str_copy(samp.tname,"sample stick");
str_copy(samp.ch1,"C");
str_copy(samp.ch2,"D");
str_copy(sens3.ch,"C");
str_copy(sens4.ch,"D");
cryo.codChanged=1;
cryo.scale=1.0;
samp.codChanged=1;
@ -1203,18 +1234,23 @@ int main(int argc, char *argv[])
CocDefPtr(tpoint, Testpoint);
CocFltFld(Testpoint, temp, CocRD);
CocFltFld(Testpoint, t1, CocRD);
CocFltFld(Testpoint, t2, CocRD);
CocFltFld(Testpoint, scale, CocRD);
CocFltFld(Testpoint, min1, CocRD);
CocFltFld(Testpoint, min2, CocRD);
CocFltFld(Testpoint, max1, CocRD);
CocFltFld(Testpoint, max2, CocRD);
CocFltFld(Testpoint, tMin, CocRD);
CocFltFld(Testpoint, tMax, CocRD);
CocStrFld(Testpoint, ch1, CocRD);
CocStrFld(Testpoint, ch2, CocRD);
CocDefStruct(sens1, SensorT);
CocDefStruct(sens2, SensorT);
CocDefStruct(sens3, SensorT);
CocDefStruct(sens4, SensorT);
CocDefPtr(sensor, SensorT);
CocFltFld(SensorT, t, CocRD);
CocFltFld(SensorT, min, CocRD);
CocFltFld(SensorT, max, CocRD);
CocIntFld(SensorT, readStat, CocRD);
CocIntFld(SensorT, sMin, CocRD);
CocIntFld(SensorT, sMax, CocRD);
CocStrFld(SensorT, ch, CocRD);
CocDefFlt(htr, CocRD);
CocDefFlt(power, powerFlag);
@ -1256,6 +1292,7 @@ int main(int argc, char *argv[])
CocDefInt(logPeriod, CocWR);
CocDefInt(readTemp, CocWR);
CocDefInt(controlMode, CocWR);
CocDefInt(int2, CocWR);
CocDefInt(busy, CocRD);
CocDefInt(serialNo, CocRD);
CocDefInt(configuring, CocRD);
@ -1263,6 +1300,12 @@ int main(int argc, char *argv[])
CocAlias(tempX,cryo.temp);
CocAlias(tempP,samp.temp);
CocAlias(tX,cryo.temp);
CocAlias(tS,samp.temp);
CocAlias(t1,sens1.t);
CocAlias(t2,sens2.t);
CocAlias(t3,sens3.t);
CocAlias(t4,sens4.t);
CocAlias(set,tempC);
CocAlias(int,integ);

23
tecs/tecs_cli.c
View File

@ -6,7 +6,7 @@
#include "tecs_cli.h"
static char device[80], command[80];
static int quit, readTemp, configuring;
static int readTemp, configuring;
static float tempX, tempP, tempC;
pTecsClient TeccInit(char *startcmd, int port) {
@ -19,7 +19,6 @@ pTecsClient TeccInit(char *startcmd, int port) {
CocDefFlt(tempX, CocRD);
CocDefStr(device, CocWR);
CocDefInt(configuring, CocRD);
CocDefInt(quit, CocWR);
CocDefInt(readTemp, CocWR);
CocDefCmd(command);
@ -94,10 +93,22 @@ int TeccSend(pTecsClient conn, char *cmd, char *reply, int replyLen) {
}
int TeccQuitServer(pTecsClient conn) {
quit=1;
ERR_I(CocCmd(conn, "[quit]"));
return(0);
OnError: return(-1);
int iret, cnt;
ERR_I(iret=CocCheck(conn));
if (iret==0) {
ERR_I(CocSet(conn, "quit", "1"));
cnt=50;
while (iret==0 && cnt>0) {
CocDelay(100);
ERR_I(iret=CocCheck(conn));
cnt--;
}
}
if (iret==1) return(0);
ERR_MSG("Does not quit within 5 seconds");
OnError:
return(-1);
}
void TeccClose(pTecsClient conn) {

202
tecs/tecs_client.f Normal file
View File

@ -0,0 +1,202 @@
program tecs_client
real*4 temp(4)
character device*32, init*80, line*80, cmd*16, par*80, response*80
integer i,j,k,iret,l
character file*128, cmdpar*128
logical oneCommand
! functions
integer tecs_get_par, tecs_quit_server, tecs_send, tecs_set_par
call sys_getenv('TECS_INIT', init)
call sys_get_cmdpar(line, l)
if (l .ne. 0) then
if (line .eq. 'off' .or. line .eq. 'OFF') init=' '
oneCommand=.true.
else
oneCommand=.false.
endif
if (init .eq. ' ') then
call tecs_open(0, ' ', iret)
else
call tecs_open(1, init, iret)
endif
if (iret .lt. 0) goto 91
if (oneCommand) goto 11
print *
print *,'Tecs Client'
print *,'-----------'
print *
print *,'<empty line> show temperature and device'
print *,'set <temp> set temperature'
print *,'send <command> direct command to LSC340'
print *,'device <device> set cryo device'
print *,'<parameter> show parameter'
print *,'<parameter> <value> set parameter'
print *,'plot temperature and power chart'
print *,'kill close TecsServer and exit'
print *,'exit,quit exit, but do not close TecsServer'
print *,'help show list of parameters and cryo devices'
print *
l=0
1 if (oneCommand) goto 99
call sys_rd_line(line, l, 'tecs> ')
if (l .lt. 0) goto 99
11 l=l+1
line(l:l)=' '
cmd=' '
k=0
do j=1,l
if (line(j:j) .gt. ' ') then
k=k+1
cmd(k:k)=line(j:j)
if (cmd(k:k) .ge. 'A' .and. cmd(k:k) .le. 'Z') then ! set to lowercase
cmd(k:k)=char(ichar(cmd(k:k))+32)
endif
elseif (k .gt. 0) then ! end of command
goto 2
endif
enddo
if (k .eq. 0) then ! empty line
call tecs_get_t(6, temp, iret)
if (iret .ne. 0) goto 1
iret=tecs_get_par('device', device)
if (iret .lt. 0) goto 19
print '(x,3(a,f8.3),2a)','tempX=', temp(3),', tempP=',temp(2)
1 ,', set=',temp(1), ', device=',device
goto 1
endif
print *,'command too long'
goto 1
2 par=' '
do i=j,l
if (line(i:i) .gt. ' ') then
par=line(i:l)
goto 3
endif
enddo
! simple query
if (cmd .eq. 'kill' .or. cmd .eq. 'off') then
iret=tecs_quit_server()
elseif (cmd .eq. 'exit' .or. cmd .eq. 'quit') then
goto 99
elseif (cmd .eq. 'on') then
l=0
goto 11
elseif (cmd .eq. 'plot') then
iret=tecs_get_par('dlogfile', file)
if (iret .lt. 0) goto 19
call tecs_plot(file)
elseif (cmd .eq. 'help') then
print *
print *,'Writeable parameters:'
print *
print *,'set temperature set-point'
print *,'device temperature device'
print *,'controlMode control on: 0: heat exchanger, '
1 ,'1: sample, 2: second loop'
print *,'power heater max. power'
print *,'prop PID gain'
print *,'int PID integration time: 1000/int sec'
print *,'deriv PID derivation term'
print *,'maxShift maximum (set-tempH) for controlMode=2'
print *,'int2 integration time (sec) for controlMode=2'
print *
print *,'Read only parameters:'
print *
print *,'tX heat exchanger temperature'
print *,'tP sample temperature'
print *,'tempH set-point on regulation'
print *,'tLimit temperature limit'
print *,'htr heater current percentage'
print *,'resist heater resistance'
print *,'logfile name of the logfile'
print *,'remoteMode 1: local, 2: remote '
1 ,'(switch on with device command)'
print *
print *,'t1 regulation temperature (hi-T sensor)'
print *,'t2 regulation temperature (low-T sensor)'
print *,'t3 sample temperature (hi-T sensor)'
print *,'t4 sample temperature (low-T sensor)'
print *
print *,'Temperature devices:'
print *
print *,'ill1, ill2, ill3 (cryofurnace), ill4 (focus-cryo), '
1 ,'ill5 (maxi)'
print *,'cti1, cti2, cti3, cti4, cti5 (maxi), cti6 (focus), apd'
print *,'ccr4k (4K closed cycle), hef4c (TriCS 4circle cryo)'
print *,'sup4t (supra.magnet 4T)'
print *,'rdrn (LTF dilution, 20kOhm), rdrn2 (2kOhm)'
print *
elseif (cmd .eq. 'log') then
iret=tecs_get_par('logfile', file)
if (iret .lt. 0) goto 19
call show_log(50, file)
else
iret=tecs_get_par(cmd, response)
if (iret .lt. 0) goto 19
print '(7x,3a)',cmd(1:k),'=',response
endif
goto 1
3 if (cmd .eq. 'send') then
iret=tecs_send(par, response)
if (iret .lt. 0) goto 19
print '(7x,2a)','response: ',response
elseif (cmd .eq. 'log') then
i=50
read(par, *, err=31) i
31 iret=tecs_get_par('logfile', file)
if (iret .lt. 0) goto 19
call show_log(i, file)
else
iret=tecs_set_par(cmd, par)
if (iret .lt. 0) goto 19
print '(7x,3a)',cmd(1:k),':=',par
endif
goto 1
19 call tecs_write_error(6)
goto 1
91 if (iret .lt. 0) then
call tecs_write_error(6)
endif
99 end
subroutine show_log(lines, file)
integer lines
integer i,l
character str*132, file*(*)
print *
print *
open(1, name=file, status='old', readonly, shared, err=39)
i=0
31 read(1,'(a)',end=32)
i=i+1
goto 31
32 rewind(1)
do i=1,i-lines
read(1,*,end=39)
enddo
33 read(1,'(q,a)',end=39) l,str
print *,str(1:min(len(str),max(1,l)))
goto 33
39 continue
close(1)
end

208
tecs/tecs_for.f Normal file
View File

@ -0,0 +1,208 @@
SUBROUTINE TECS_FOR ! File TAS_SRC:[TECS]TECS_FOR.FOR
c ===================
c
cdec$ ident 'V01D'
c------------------------------------------------------------------------------
c Fortran-Interface to the TECS Client
c
c M. Zolliker, March 2000
c Updates:
c V01A 21-Mar-2000 DM. Integrate into TASMAD
c 05-Apr-2000 M.Z. modifed error handling/changed arguments in TeccGet3
c 01-May-2000 M.Z. renamed source, TECS_OPEN is now in a separate, system dependend file
c V01C 11-May-2000 DM. Split into modules.
c V01D 12-May-2000 M.Z. Changed error handling, no longer automatic call to TECS_OPEN
c------------------------------------------------------------------------------
c
c For a description of the public interface:
c on VMS: search tecs_for.for "!'''!" (''' may be omitted)
c on Unix: grep !"!" tecs_for.for
c
c Public routines in this Module:
c
c subroutine TECS_OPEN (LUN, INIT, IRET) - open connection to tecs, if not yet open
c subroutine TECS_GET_T (IOLUN, TEMP, IRET) - read the temperature, wait if tecs is configuring
c subroutine TECS_WRITE_ERROR (IOLUN) - write out last occured error in TECS_x routines
c
c For internal use only:
c
c subroutine TECS_FOR - dummy entry point to get module name
c in library to match the file name.
c subroutine TECS_ERR_ROUTINE (LUN, TEXT) - (for internal use only)
c
!!------------------------------------------------------------------------------
!! C Routines with Fortran interface (see TECS_CLI.C):
!!
!! integer function TECS_SET (TEMP) - set temperature target
!! integer function TECS_GET (TEMP) - get sample temperature
!! integer function TECS_QUIT_SERVER () - force server to quit
!! integer function TECS_GET_PAR (NAME, PAR) - get parameter
!! integer function TECS_SET_PAR (NAME, PAR) - set parameter
!! integer function TECS_SEND (CMND, REPLY) - send command to LakeShore
!! subroutine TECS_CLOSE - close connection to tecs
!!
!! real TEMP
!! character*(*) NAME, PAR, CMND, REPLY
!!
!! integer return values are error codes (negative means error, like in most C system routines)
!!
!
! C routines only for internal use in TECS_FOR.FOR:
!
! integer function TECS_INIT(STARTCMD, PORT) - open server connection
! logical function TECS_IS_OPEN () - check if tecs is open
! integer function TECS_GET3(SET_T, REG_T, SAM_T) - read 3 temperatures
! integer function TECS_WAIT() - wait for end of configuration
!
! character*(*) STARTCMD
! integer PORT
! real SET_T,REG_T,SAM_T
c------------------------------------------------------------------------------
implicit none
stop 'TECS_FOR: do not call module header'
end
!!------------------------------------------------------------------------------
!! Fortran routines in this file:
!!
SUBROUTINE TECS_OPEN(LUN, INIT, IRET) !!
!! =====================================
!!
!! Open connection to the Tecs Server, if not yet done.
!! (a) LUN==0: INIT is the start command which should contain "-p <portnumber>"
!! (b) LUN/=0: INIT is the file specification where to read port number and start command
!!
c------------------------------------------------------------------------------
implicit none
c--------------------------------------------------------------
c Define the dummy arguments
integer LUN !! logical number for reading init file
character*(*) INIT !! file specification or start command
integer IRET !! iret<0 means error
c--------------------------------------------------------------
integer ios, port, i
character*128 startcmd
! functions:
integer tecs_init
logical tecs_is_open
c--------------------------------------------------------------
if (tecs_is_open()) then
iret=1 ! already open
return
endif
port=0
if (lun .eq. 0) then
c extract the port number from the start command
i=index(init, '-p ')
if (i .eq. 0) i=index(init, '-P ')
if (i .ne. 0) then
read(init,*,iostat=ios) port
endif
if (port .eq. 0) port=9753
iret=tecs_init(init, port)
else
c if INIT exists, read it to get the port number and the start command
startcmd=' '
open (lun, file=init, status='old', readonly, iostat=ios)
if (ios .eq. 0) read (lun, *, iostat=ios) port
if (ios .eq. 0) read (lun, *, iostat=ios) ! skip options line
if (ios .eq. 0) read (lun, '(a)', iostat=ios) startcmd
close(lun)
if (ios .ne. 0) then
iret=-2
call err_msg('TECS_OPEN: init file not found')
return
endif
if (port .eq. 0) port=9753
iret=tecs_init(startcmd, port)
endif
end
SUBROUTINE TECS_GET_T (IOLUN, TEMP, IRET) !!
!! ============================================
!!
!! Get temperatures and wait if TECS is configuring
!!
implicit none
c Define the dummy arguments
integer IOLUN !! unit to write informational messages
real*4 TEMP(4) !! TASMAD temperature array: set-temp, regulation, sample, aux-temp
integer IRET !! IRET=0: o.k., IRET<0: error
c------------------------------------------------------------------------------
integer tecs_get3, tecs_wait
external tecs_get3, tecs_wait
c------------------------------------------------------------------------------
iret=tecs_get3(temp(1), temp(3), temp(2)) ! temp(2) and temp(3) are exchanged in MSHOWT
if (iret .lt. 0) then
call err_txt('tecs_get_3'//char(10)//'tecs_get_t')
return
endif
if (iret .gt. 0) then
write(iolun, *) 'configuring temperature controller ...'
iret=tecs_wait()
if (iret .lt. 0) then
call err_txt('tecs_wait'//char(10)//'tecs_get_t')
return
endif
write(iolun, *) '... done'
iret=tecs_get3(temp(1), temp(3), temp(2)) ! temp(2) and temp(3) are exchanged in MSHOWT
if (iret .lt. 0) then
call err_txt('tecs_get3(2)'//char(10)//'tecs_get_t')
return
endif
endif
temp(4)=0.0 ! no auxilliary sensor
end
subroutine TECS_WRITE_ERROR(IOLUN) !!
!! ==================================
!!
!! write out error message of last error and stack info
!!
implicit none
integer IOLUN !! logical unit for output
external tecs_err_routine
call ErrSetOutRtn(tecs_err_routine, iolun)
call err_show('Error in TECS')
end
SUBROUTINE TECS_ERR_ROUTINE (LUN, TEXT)
! =======================================
!
! routine called from C
!
implicit none
c--------------------------------------------------------------
c Define the dummy arguments
byte text(128)
integer lun
c--------------------------------------------------------------
integer i, j
c--------------------------------------------------------------
do i=1,128
if (text(i) .eq. 0) then
write(lun, '(x,128a1)') (text(j), j=1,i-1)
return
endif
enddo
! no terminating ASCII NUL found
write(lun, *) 'error in TECS_ERR_ROUTINE: illegal error text'
end

403
tecs/tecs_plot.f90 Normal file
View File

@ -0,0 +1,403 @@
subroutine tecs_plot(file)
character(len=*) file
integer, parameter :: dmax=500, nset=3, nmenu=9, chartfreq=2
real, parameter :: winmin=60., undef=-65535.0
real*4 x1,x2,xmin,xmax,ymin(2),ymax(2),window
real*4 xd(dmax),yd(dmax,nset)
real*4 ylast1,ylast2,y1,y2
real*4 ex,ey,fx,fy,hmenu,wmenu,ymenu,ticks
real*4 xbox(8), ybox(8)
integer l,j,i,t0,t1,ntot,i1,i2,rl,n,startday,thisday
integer first,last,tbase,lastj
integer color(3)/2,4,3/
character key*1
character text(nmenu)*12/ &
'live off','sel. zoom','zoom in','zoom out','show all','n days','n hours','n min','quit'/
character keys*(nmenu)/'LZ+-XDHMQ'/
character weekdays(7)*3/'Mon','Tue','Wed','Thu','Fri','Sat','Sun'/
character buf*8
external tplot_close
logical live, xwin, zoom, right
integer iret, numb
integer dlog_open_r, dlog_get, dlog_close_r
data window/1800./
zoom=.false.
right=.true.
call pgopen(" ")
call pgqinf('TYPE', buf, l)
xwin=(buf(1:1)=='X')
live=.not. xwin ! live switched off by default on X-Windows
call pgask(.false.)
l=0
iret=dlog_open_r(file, first, last, tbase)
if (iret<0) then
call err_txt('dlog_open_r')
goto 99
endif
xmax=0
1 if (right .or. window==0 .or. live) then
ntot=dlog_get(dmax, nset, tbase, -window*1.1, 0.0, undef, xd, yd)
if (ntot<=0) then
if (ntot<0) then
call err_txt('dlog_get')
goto 99
endif
x2=last-tbase
else
x2=maxval(xd(1:ntot))
endif
if (live) then
x1=max(x2-window,xd(1))
x2=max(x1+window,x2+min(window*0.2,max(window*0.01,300.)))
elseif (window==0) then
x1=minval(xd(1:ntot))
window=x2-x1
else
x1=x2-window
endif
else
if (.not. zoom) then
x1=x2-window
if (window==0) then ! maximal
x1=0
x2=1e20
endif
endif
ntot=dlog_get(dmax, nset, tbase, x1-window*0.1, x2+window*0.1, undef, xd, yd)
endif
if (ntot<0) then
call err_txt('dlog_get')
goto 99
endif
if (ntot>0) then
xmin=minval(xd(1:ntot))
xmax=maxval(xd(1:ntot))
else
xmin=x1
xmax=x2
endif
call pgsvp(0.07,0.93,0.1,0.9) ! define window size
if (xmax<=xmin) then
xmax=xmin+1
! l=0
! print *,'no points found'
! print *
! goto 9
endif
call pgsch(1.0)
i1=1
i2=2
do rl=1,2
if (zoom) then
ymin(1)=y1
ymax(1)=y2
else
ymin(rl)=1e30
ymax(rl)=-1e30
ylast1=ymin(rl)
ylast2=ymax(rl)
do i=i1,i2
do j=1,ntot
if (xd(j) >= x1 .and. xd(j) <= x2 .and. yd(j,i)/=undef) then
ymin(rl)=min(ymin(rl),yd(j,i))
ymax(rl)=max(ymax(rl),yd(j,i))
endif
enddo
do j=max(1,ntot-4),ntot
if (yd(j, i)/=undef) then
ylast1=min(ylast1,yd(j, i))
ylast2=max(ylast2,yd(j, i))
endif
enddo
enddo
ey=(ymax(rl)-ymin(rl))
if (rl==1) then
ymax(rl)=ymax(rl)+ey*0.25
ymin(rl)=ymin(rl)-ey*0.01
else
ymax(rl)=ymax(rl)+ey*0.01
ymin(rl)=ymin(rl)-ey*4
endif
if (live) then
ymin(rl)=min(ymin(rl),max(0.0,ylast1-ey*0.4))
ymax(rl)=max(ymax(rl),ylast2+ey*0.4)
endif
endif
if (ymax(rl) .lt. ymin(rl)) then
ymax(rl)=1
ymin(rl)=0
elseif (ymax(rl) .eq. ymin(rl)) then
ymax(rl)=ymin(rl)+1.0
ymin(rl)=0
endif
zoom=.false.
call pgswin(x1,x2,ymin(rl),ymax(rl))
do i=i1,i2
call pgsci(color(i))
n=0
lastj=1
do j=1,ntot
if (yd(j,i)==undef) then
if (j>lastj) call pgline(j-lastj, xd(lastj), yd(lastj,i))
lastj=j+1
endif
enddo
if (ntot .gt. lastj) call pgline(ntot+1-lastj, xd(lastj), yd(lastj,i))
enddo
i1=3
i2=3
enddo
rl=2
call pgsci(1)
! call pgtbox(' ', 0.0, 0, 'CIMST', 0.0, 0)
ey=ymax(rl)-(ymax(rl)-ymin(rl))*0.20
call pgsch(0.7)
call pgaxis('N', x1, ey, x1, ymax(rl), ey, ymax(rl), 0, 0, 0.5, 0.0, 0.0, -1.0, 0.0)
rl=1
call pgswin(x1,x2,ymin(rl),ymax(rl))
ey=ymax(rl)-(ymax(rl)-ymin(rl))*0.21
call pgsch(1.0)
call pgaxis('N', x1, ymin(rl), x1, ey, ymin(rl), ey, 0, 0, 0.5, 0.0, 0.5, -1.0, 0.0)
if (window>50*3600) then
ticks=8*3600
elseif (window>25*3600) then
ticks=4*3600
else
ticks=0.0 ! automatic
endif
call pgtbox('ZHXYBCINST', ticks, 0, 'CIMST', 0.0, 0)
call pgmtxt ('L', 2.5, 0.4, 0.5, 'T [K]')
call pgsci(color(1))
call pgmtxt ('L', 2.5, 0.2, 0.5, 'Main Sensor')
call pgsci(color(2))
call pgmtxt ('L', 2.5, 0.6, 0.5, 'Sample Sensor')
call pgsci(color(3))
call pgmtxt ('L', 2.5, 0.9, 0.5, 'Power [W]')
call pgsci(1)
call pgsclp(0)
hmenu=(ymax(rl)-ymin(rl))/15.
ymenu=ymax(rl)+hmenu*0.5
wmenu=(x2-x1)/(nmenu+2)
if (live) then
text(1)='live off'
else
text(1)='live on'
endif
call pgsch(0.7)
do i=1,nmenu
xbox(1)=x1+(i-0.7)*wmenu
ybox(1)=ymenu+hmenu
xbox(2)=xbox(1)
ybox(2)=ymenu+hmenu*0.5
xbox(3)=x1+(i-0.95)*wmenu
ybox(3)=ybox(2)
xbox(4)=xbox(3)
ybox(4)=ybox(1)
xbox(5)=xbox(1)
ybox(5)=ybox(1)
call pgline(5, xbox, ybox)
call pgptxt(x1+(i-0.9)*wmenu, ymenu+0.65*hmenu, 0.0, 0.0, keys(i:i))
call pgptxt(x1+(i-0.9)*wmenu, ymenu+0.15*hmenu, 0.0, 0.0, text(i))
enddo
call pgmtxt('T', 3.5, 1.0, 1.0, 'any digit to enter n')
call pgmtxt('T', 2.0, 0.9, 1.0, 'n=')
thisday=(x1+x2)/2/(24*3600)
ey=ymin(rl)-hmenu*1.5
i=max(0,int((x1+12*3600)/(24*3600)))
do
ex=(i+0.5)*24*3600
if (ex>x2) EXIT
thisday=0
call pgptxt(ex, ey, 0.0, 0.5, weekdays(mod(i,7)+1))
ex=ex-12*3600
if (ex .gt. x1) then
call pgmove(ex, ey)
call pgdraw(ex, ey+hmenu/2)
endif
ex=ex+24*3600
if (ex .lt. x2) then
call pgmove(ex, ey)
call pgdraw(ex, ey+hmenu/2)
endif
i=i+1
enddo
if (thisday>0) then
call pgptxt((x1+x2)/2, ey, 0.0, 0.5, weekdays(mod(thisday,7)+1))
endif
call pgsclp(1)
call get_key(key, 0, 0) ! purge buffer
numb=0
7 if (live) then
if (xwin) then
call pgmtxt('T', 1.0, 1.0, 1.0, 'LIVE MODE (click on text window before pressing any further key)')
endif
call get_key(key, 0, chartfreq)
do while (key .eq. char(0)) ! no key pressed
ntot=dlog_get(dmax, nset, tbase, xmax-0.5, 1e10, undef, xd, yd)
if (ntot<0) then
call err_txt('dlog_open_r 2')
goto 99
endif
if (ntot .gt. 1) then
i1=1
i2=2
do rl=1,2
call pgswin(x1,x2,ymin(rl),ymax(rl))
do i=i1,i2
call pgsci(color(i))
n=0
lastj=1
do j=1,ntot
if (yd(j,i)==undef) then
if (j>lastj) call pgline(j-lastj, xd(lastj), yd(lastj,i))
lastj=j+1
elseif (xd(j)>x2 .or. yd(j,i)<ymin(rl) .or. yd(j,i)>ymax(rl)) then
call pgpage
goto 1
endif
enddo
if (ntot .gt. lastj) call pgline(ntot+1-lastj, xd(lastj), yd(lastj,i))
enddo
i1=3
i2=3
enddo
xmax=max(xmax,xd(ntot))
endif
call get_key(key, 0, chartfreq)
enddo
else
call pgcurs(ex, ey, key)
call must_purge
endif
rl=1
call pgswin(x1,x2,ymin(rl),ymax(rl))
8 if (key>='a') key=char(ichar(key)-32)
if (ey>ymenu) then
i=max(0,min(nmenu,int((ex-x1)/wmenu+1)))
key=keys(i:i)
ex=(x1+x2)/2
endif
if (key=='-') then
window=min(window*2, 8*24*3600.)
elseif (key=='X') then
window=0
live=.false.
elseif (key=='+' .or. key==',') then
window=max(winmin,window/2)
elseif (key=='Z') then
call pgsci(1)
if (live) then
call pgmtxt('T', 1.0, 0.0, 0.0, 'click on two opposite corners of a selection rectangle')
call pgcurs(ex, ey, key)
else
call pgmtxt('T', 1.0, 0.3, 0.0, 'click on second corner of selection rectangle')
endif
call pgsci(5)
xmin=x1
xmax=x2
call pgmove(xmin, ey)
call pgdraw(xmax, ey)
call pgmove(ex, ymin(rl))
call pgdraw(ex, ymax(rl))
call pgcurs(fx, fy, key)
call must_purge
x1=max(xmin,min(ex,fx))
x2=min(xmax,max(ex,fx))
if (x1>=x2) then
x1=xmin
x2=xmax
endif
window=x2-x1
y1=max(ymin(1),min(ey,fy))
y2=min(ymax(1),max(ey,fy))
if (y1>=y2) then
y1=ymin(1)
y2=ymax(1)
endif
zoom=.true.
live=.false.
right=.false.
elseif (key .ge. '0' .and. key .le. '9') then
numb=numb*10+(ichar(key)-ichar('0'))
if (numb>0) then
write(buf, '(i8)') numb
l=1
do while (buf(l:l)==' ')
l=l+1
enddo
call pgsci(1)
call pgmtxt('T', 2.0, 0.9, 0.0, buf(l:))
endif
call get_key(key, 2, 10)
if (key/=char(0)) goto 8
goto 7
elseif (key .eq. 'D') then
window=min(7*24*3600,24*3600*max(1,numb))
right=.true.
elseif (key .eq. 'H') then
window=min(7*24*3600,3600*max(1,numb))
right=.true.
elseif (key .eq. 'M') then
window=min(7*24*3600,60*max(1,numb))
right=.true.
elseif (key .eq. 'L') then
live=.not. live
if (live) then
right=.true.
x2=xmax
endif
elseif (key=='Q' .or. key==char(13)) then
goto 9
elseif (live) then
goto 7
endif
numb=0
call pgpage
goto 1
99 call tecs_write_error(6)
9 continue
call tplot_close
call get_key(key, 0, 0) ! purge type-ahead-buffer
print *
end subroutine
subroutine get_key(key, tmo1, tmo2)
integer tmo1, tmo2
character key*1
logical purge/.false./
key=char(0)
if (purge) then
purge=.false.
call sys_get_key(key, tmo1)
if (key/=char(0) .and. key/=char(13)) return
endif
if (tmo2>0) call sys_get_key(key, tmo2)
return
entry must_purge
purge=.true.
end subroutine
subroutine tplot_close
call pgclos
call dlog_close_r
end subroutine