Works now under OSF1 and Linux
This commit is contained in:
cvs
@ -1,136 +0,0 @@
|
|||||||
#include <assert.h>
|
|
||||||
#include <string.h>
|
|
||||||
#include <stdlib.h>
|
|
||||||
|
|
||||||
#include "sys_util.h"
|
|
||||||
#include "str_util.h"
|
|
||||||
#include "err_handling.h"
|
|
||||||
|
|
||||||
#define SLEN 64
|
|
||||||
#define MLEN 64
|
|
||||||
|
|
||||||
static char *txt[SLEN];
|
|
||||||
static int sp=0;
|
|
||||||
|
|
||||||
int ErrCode;
|
|
||||||
char *ErrMessage=NULL;
|
|
||||||
void (*outrtn)()=NULL;
|
|
||||||
void *outarg;
|
|
||||||
|
|
||||||
void ErrTxt(char *text, int systemError)
|
|
||||||
{
|
|
||||||
if (systemError) { sp=0; ErrCode=errno; ErrMessage=strerror(errno); }
|
|
||||||
if (sp<SLEN) {
|
|
||||||
txt[sp++]=text;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void ErrMsg(char *msg)
|
|
||||||
{
|
|
||||||
ErrCode=-1;
|
|
||||||
ErrMessage=msg; sp=0;
|
|
||||||
}
|
|
||||||
|
|
||||||
void ErrCod(int code)
|
|
||||||
{
|
|
||||||
ErrCode=code;
|
|
||||||
ErrMessage=strerror(code); sp=0;
|
|
||||||
}
|
|
||||||
|
|
||||||
void ErrOutFil(void *arg, char *text) {
|
|
||||||
fprintf((FILE *)arg, "%s\n", text);
|
|
||||||
}
|
|
||||||
|
|
||||||
void ErrShow(char *text)
|
|
||||||
{
|
|
||||||
int i, l;
|
|
||||||
char buf[256];
|
|
||||||
|
|
||||||
if (outrtn==NULL) {
|
|
||||||
outrtn=ErrOutFil;
|
|
||||||
outarg=stdout;
|
|
||||||
}
|
|
||||||
l=strlen(text)+strlen(ErrMessage)+6;
|
|
||||||
assert(l<256);
|
|
||||||
sprintf(buf, "--- %s: %s", text, ErrMessage);
|
|
||||||
for (i=0;i<sp;i++) {
|
|
||||||
if (txt[i][0]==':') {
|
|
||||||
l+=strlen(txt[i]);
|
|
||||||
assert(l<256);
|
|
||||||
strcat(buf, &(txt[i][1]));
|
|
||||||
} else {
|
|
||||||
outrtn(outarg, buf);
|
|
||||||
l=strlen(txt[i]);
|
|
||||||
assert(l<256);
|
|
||||||
strcpy(buf, txt[i]);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
outrtn(outarg, buf);
|
|
||||||
outrtn(outarg, "");
|
|
||||||
}
|
|
||||||
|
|
||||||
void ErrShort(char *msg) {
|
|
||||||
if (outrtn==NULL) {
|
|
||||||
outrtn=ErrOutFil;
|
|
||||||
outarg=stdout;
|
|
||||||
}
|
|
||||||
outrtn(outarg, msg);
|
|
||||||
}
|
|
||||||
|
|
||||||
void ErrSetOutRtn(void (*rtn)(), void *arg) {
|
|
||||||
outrtn=rtn;
|
|
||||||
outarg=arg;
|
|
||||||
}
|
|
||||||
|
|
||||||
void ErrSetOutFile(FILE *arg) {
|
|
||||||
outrtn=ErrOutFil;
|
|
||||||
outarg=arg;
|
|
||||||
}
|
|
||||||
|
|
||||||
void ERR_EXIT(char *text) {
|
|
||||||
ErrShow(text); exit(1);
|
|
||||||
}
|
|
||||||
|
|
||||||
/* FORTRAN wrappers */
|
|
||||||
|
|
||||||
#ifdef F_CHAR
|
|
||||||
/* compile only when fortran c interface stuff is defined */
|
|
||||||
|
|
||||||
#ifdef __VMS
|
|
||||||
#define err_show_ err_show
|
|
||||||
#define err_txt_ err_txt
|
|
||||||
#define err_msg_ err_msg
|
|
||||||
#define err_set_outrtn_ err_set_outrtn
|
|
||||||
#define err_short_ err_short
|
|
||||||
#endif
|
|
||||||
|
|
||||||
void err_show_(F_CHAR(text), int text_len) {
|
|
||||||
char buf[256];
|
|
||||||
|
|
||||||
STR_TO_C(buf, text);
|
|
||||||
ErrShow(buf);
|
|
||||||
}
|
|
||||||
|
|
||||||
void err_txt_(F_CHAR(text), int text_len) {
|
|
||||||
char buf[256];
|
|
||||||
|
|
||||||
STR_TO_C(buf, text);
|
|
||||||
ErrTxt(buf,0);
|
|
||||||
}
|
|
||||||
|
|
||||||
void err_msg_(F_CHAR(text), int text_len) {
|
|
||||||
char buf[256];
|
|
||||||
|
|
||||||
STR_TO_C(buf, text);
|
|
||||||
ErrMsg(buf);
|
|
||||||
}
|
|
||||||
|
|
||||||
void err_set_outrtn_(void (*rtn)(), void *arg) {
|
|
||||||
ErrSetOutRtn(rtn, arg);
|
|
||||||
}
|
|
||||||
|
|
||||||
void err_short_(void) {
|
|
||||||
ErrShort(ErrMessage);
|
|
||||||
}
|
|
||||||
|
|
||||||
#endif
|
|
||||||
@ -1,85 +0,0 @@
|
|||||||
#ifndef _ERR_HANDLING_H_
|
|
||||||
#define _ERR_HANDLING_H_
|
|
||||||
|
|
||||||
#include <stdio.h>
|
|
||||||
#include <sys/errno.h>
|
|
||||||
|
|
||||||
/* ErrHDL Error handling utilities
|
|
||||||
-------------------------------
|
|
||||||
Makes code more readable by hiding annoying error condition checks.
|
|
||||||
|
|
||||||
Macros and routines:
|
|
||||||
|
|
||||||
Spelling in uppercase indicates, that it the program flow
|
|
||||||
may be modified (jump to OnError label or program exit).
|
|
||||||
|
|
||||||
|
|
||||||
ERR_x
|
|
||||||
|
|
||||||
Usage Error condition Error message taken from
|
|
||||||
-----------------------------------------------------------------------------------------
|
|
||||||
ERR_SI(res=routine1(...)) res<0 errno
|
|
||||||
ERR_SP(ptr=routine2(...)) ptr==NULL errno
|
|
||||||
ERR_I(res=routine3(...)) res<0 stored by routine3 using errhdl mechanism
|
|
||||||
ERR_P(ptr=routine4(...)) ptr==NULL stored by routine4 using errhdl mechanism
|
|
||||||
|
|
||||||
The result assignment "res=" or "ptr=" is optional.
|
|
||||||
|
|
||||||
Description:
|
|
||||||
The routine routineX is called.
|
|
||||||
If the result indicates an error, the source text is saved and the
|
|
||||||
program continues at the OnError label.
|
|
||||||
The error message and the source code of the calling instructions is
|
|
||||||
saved for a later call to ErrShow or ErrExit.
|
|
||||||
|
|
||||||
ERR_EXIT("program_name")
|
|
||||||
|
|
||||||
Show error and exit program.
|
|
||||||
|
|
||||||
ERR_MSG("message")
|
|
||||||
|
|
||||||
Signals an error condition. If "message" is replaced by a variable,
|
|
||||||
take care that it is not modified until ErrShow is called.
|
|
||||||
|
|
||||||
ERR_COD(cod)
|
|
||||||
|
|
||||||
Signals an error condition as code from errno.h
|
|
||||||
|
|
||||||
ErrShow("program_name")
|
|
||||||
|
|
||||||
Show actual error message with traceback information to stdout
|
|
||||||
or a file fil
|
|
||||||
|
|
||||||
Global Variables (read only)
|
|
||||||
|
|
||||||
int ErrCode
|
|
||||||
|
|
||||||
actual error message code
|
|
||||||
= errno for system errors or
|
|
||||||
= -1 for custom errors signaled by ERRMSG
|
|
||||||
|
|
||||||
char *ErrMessage
|
|
||||||
|
|
||||||
actual error message
|
|
||||||
*/
|
|
||||||
|
|
||||||
#define ERR_SI(R) { if(0>(R)) { ErrTxt(#R,1); goto OnError; }; }
|
|
||||||
#define ERR_SP(R) { if(NULL==(R)) { ErrTxt(#R,1); goto OnError; }; }
|
|
||||||
#define ERR_I(R) { if(0>(R)) { ErrTxt(#R,0); goto OnError; }; }
|
|
||||||
#define ERR_P(R) { if(NULL==(R)) { ErrTxt(#R,0); goto OnError; }; }
|
|
||||||
#define ERR_MSG(R) { ErrMsg(R); goto OnError; }
|
|
||||||
#define ERR_COD(R) { ErrCod(R); goto OnError; }
|
|
||||||
|
|
||||||
void ErrTxt(char *text, int systemError);
|
|
||||||
void ErrMsg(char *msg);
|
|
||||||
void ErrCod(int code);
|
|
||||||
void ErrShow(char *text); /* write out error message with stack info */
|
|
||||||
void ErrShort(char *msg); /* write out short error message */
|
|
||||||
void ERR_EXIT(char *text);
|
|
||||||
void ErrSetOutRtn(void (*rtn)(), void *arg);
|
|
||||||
void ErrSetOutFile(FILE *file);
|
|
||||||
|
|
||||||
extern int ErrCode;
|
|
||||||
extern char *ErrMessage;
|
|
||||||
|
|
||||||
#endif /* _ERR_HANDLING_H_ */
|
|
||||||
@ -68,6 +68,8 @@ int InstrHost(char *input, char *instr, char *host, char *user, char *pcod
|
|||||||
|
|
||||||
#ifdef __VMS
|
#ifdef __VMS
|
||||||
#define instr_host_ instr_host
|
#define instr_host_ instr_host
|
||||||
|
#elif defined __linux
|
||||||
|
#define instr_host_ instr_host__
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
int instr_host_(F_CHAR(input), F_CHAR(instr), F_CHAR(host), F_CHAR(user), F_CHAR(pcod)
|
int instr_host_(F_CHAR(input), F_CHAR(instr), F_CHAR(host), F_CHAR(user), F_CHAR(pcod)
|
||||||
|
|||||||
@ -110,6 +110,14 @@ void ERR_EXIT(char *text) {
|
|||||||
#define err_msg_ err_msg
|
#define err_msg_ err_msg
|
||||||
#define err_set_outrtn_ err_set_outrtn
|
#define err_set_outrtn_ err_set_outrtn
|
||||||
#define err_short_ err_short
|
#define err_short_ err_short
|
||||||
|
|
||||||
|
#elif defined __linux
|
||||||
|
#define err_show_ err_show__
|
||||||
|
#define err_txt_ err_txt__
|
||||||
|
#define err_msg_ err_msg__
|
||||||
|
#define err_set_outrtn_ err_set_outrtn__
|
||||||
|
#define err_short_ err_short__
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
void err_show_(F_CHAR(text), int text_len) {
|
void err_show_(F_CHAR(text), int text_len) {
|
||||||
|
|||||||
@ -171,7 +171,7 @@
|
|||||||
9 call sys_free_lun(lun)
|
9 call sys_free_lun(lun)
|
||||||
return
|
return
|
||||||
|
|
||||||
19 type *,'SYS_SAVE_ENV: can not open tmp. file'
|
19 print *,'SYS_SAVE_ENV: can not open tmp. file'
|
||||||
goto 9
|
goto 9
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|||||||
364
tecs/sys_linux.f
Normal file
364
tecs/sys_linux.f
Normal file
@ -0,0 +1,364 @@
|
|||||||
|
!!------------------------------------------------------------------------------
|
||||||
|
!! 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_TEMP_NAME(NAME, PATH) !!
|
||||||
|
!! ====================================
|
||||||
|
!! get a temporary file name
|
||||||
|
!!
|
||||||
|
character*(*) NAME !! (in) name
|
||||||
|
character*(*) PATH !! (out) path
|
||||||
|
|
||||||
|
character line*64, pid*5, nam*64
|
||||||
|
integer i, l
|
||||||
|
|
||||||
|
integer getppid
|
||||||
|
|
||||||
|
nam='/tmp/.'
|
||||||
|
nam(7:)=name
|
||||||
|
call sys_getenv('USER', line)
|
||||||
|
if (line .eq. ' ') then
|
||||||
|
call str_trim(line, nam, l)
|
||||||
|
else
|
||||||
|
call str_trim(nam, nam, l)
|
||||||
|
call str_trim(line, nam(1:l)//'_'//line, l)
|
||||||
|
endif
|
||||||
|
|
||||||
|
write(pid,'(i5)') getppid()
|
||||||
|
i=1
|
||||||
|
1 if (pid(i:i) .eq. ' ') then
|
||||||
|
i=i+1
|
||||||
|
goto 1
|
||||||
|
endif
|
||||||
|
path=line(1:l)//'.'//pid(i:5)
|
||||||
|
end
|
||||||
|
|
||||||
|
!!-----------------------------------------------------------------------------
|
||||||
|
!!
|
||||||
|
subroutine SYS_LOAD_ENV(FILE) !!
|
||||||
|
!! =============================
|
||||||
|
!! load environment from temporary file
|
||||||
|
!!
|
||||||
|
character*(*) FILE !! filename
|
||||||
|
|
||||||
|
character path*128, line*128
|
||||||
|
integer lun, i, l
|
||||||
|
|
||||||
|
integer getppid
|
||||||
|
|
||||||
|
call sys_temp_name(file, path)
|
||||||
|
call sys_get_lun(lun)
|
||||||
|
open(lun,file=path,status='old',err=9)
|
||||||
|
5 read(lun,'(q,a)',end=8) l, line
|
||||||
|
l=min(l,len(line))
|
||||||
|
i=index(line,'=')
|
||||||
|
if (i .eq. 0) then
|
||||||
|
if (l .gt. 0) call sys_setenv(line(1:l), ' ')
|
||||||
|
elseif (i .gt. 1 .and. i .lt. l) then
|
||||||
|
call sys_setenv(line(1:i-1),line(i+1:l))
|
||||||
|
endif
|
||||||
|
goto 5
|
||||||
|
8 close(lun)
|
||||||
|
9 call sys_free_lun(lun)
|
||||||
|
end
|
||||||
|
|
||||||
|
!!-----------------------------------------------------------------------------
|
||||||
|
!!
|
||||||
|
subroutine SYS_SAVE_ENV(FILE, NAMES, N_NAMES) !!
|
||||||
|
!! =============================================
|
||||||
|
!! save environment on temporary file
|
||||||
|
!!
|
||||||
|
character*(*) FILE !! filename
|
||||||
|
integer N_NAMES !! number of names
|
||||||
|
character*(*) NAMES(N_NAMES) !! names of variables to save
|
||||||
|
|
||||||
|
character path*128, line*128
|
||||||
|
integer lun, i, j, l
|
||||||
|
|
||||||
|
call sys_temp_name(file, path)
|
||||||
|
call sys_get_lun(lun)
|
||||||
|
|
||||||
|
open(lun,file=path,status='unknown',err=19)
|
||||||
|
|
||||||
|
do i=1,n_names
|
||||||
|
call sys_getenv(names(i), line)
|
||||||
|
call str_trim(names(i),names(i), j)
|
||||||
|
call str_trim(line,line, l)
|
||||||
|
write(lun,'(3a)') names(i)(1:j),'=',line(1:l)
|
||||||
|
enddo
|
||||||
|
|
||||||
|
close(lun)
|
||||||
|
9 call sys_free_lun(lun)
|
||||||
|
return
|
||||||
|
|
||||||
|
19 print *,'SYS_SAVE_ENV: can not open tmp. file'
|
||||||
|
goto 9
|
||||||
|
end
|
||||||
|
|
||||||
|
!!-----------------------------------------------------------------------------
|
||||||
|
!!
|
||||||
|
subroutine SYS_WAIT(SECONDS) !!
|
||||||
|
!! ============================
|
||||||
|
!! wait for SECONDS
|
||||||
|
real SECONDS !! resolution should be better than 0.1 sec.
|
||||||
|
|
||||||
|
real tim, del
|
||||||
|
|
||||||
|
tim=secnds(0.0)
|
||||||
|
1 del=seconds-secnds(tim)
|
||||||
|
if (del .ge. 0.999) then
|
||||||
|
call sleep(int(del))
|
||||||
|
goto 1
|
||||||
|
endif
|
||||||
|
if (del .gt. 0) then
|
||||||
|
call usleep(int(del*1E6))
|
||||||
|
goto 1
|
||||||
|
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, iargc
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
character esc*1, csi*1, ss3*1
|
||||||
|
|
||||||
|
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
|
||||||
200
tecs/sys_linux_c.c
Normal file
200
tecs/sys_linux_c.c
Normal file
@ -0,0 +1,200 @@
|
|||||||
|
#include <termios.h>
|
||||||
|
#include <sys/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;
|
||||||
|
|
||||||
|
int lnblnk_(char *c, int c_len);
|
||||||
|
char *readline(char *prompt);
|
||||||
|
void add_history(char *line_read);
|
||||||
|
|
||||||
|
void sys_rd_line__(char *cmd, int *retlen, char *prompt, int clen, int plen)
|
||||||
|
{
|
||||||
|
char *line_read, p[64];
|
||||||
|
|
||||||
|
assert(plen < sizeof(p));
|
||||||
|
strncpy(p,prompt,plen); p[plen] = '\0';
|
||||||
|
if (last_line == NULL) { last_line =malloc(1); last_line[0] = '\0';};
|
||||||
|
|
||||||
|
line_read = readline(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);
|
||||||
|
|
||||||
|
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");};
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
void usleep_(int *usec) { usleep(*usec); }
|
||||||
|
int getppid_(void) { return getppid(); }
|
||||||
|
|
||||||
|
int sys_setenv__(ename,evalue,ilen1,ilen2)
|
||||||
|
char *ename, *evalue;
|
||||||
|
int ilen1, ilen2;
|
||||||
|
{
|
||||||
|
int i1, i2, ow, rc;
|
||||||
|
char *p1, *p2;
|
||||||
|
|
||||||
|
i1 = lnblnk_(ename,ilen1);
|
||||||
|
i2 = lnblnk_(evalue,ilen2);
|
||||||
|
|
||||||
|
p1 = malloc((unsigned) i1+1); if( p1 == NULL ) return (-1);
|
||||||
|
p2 = malloc((unsigned) i2+1); if( p2 == NULL ) { free(p1); return (-1); }
|
||||||
|
|
||||||
|
strncpy(p1,ename,i1); p1[i1] = '\0';
|
||||||
|
strncpy(p2,evalue,i2); p2[i2] = '\0';
|
||||||
|
|
||||||
|
ow = 1;
|
||||||
|
|
||||||
|
rc = setenv(p1, p2, ow);
|
||||||
|
free(p1); free(p2);
|
||||||
|
return(rc);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
void sys_rd_tmo__(char *prompt, char *result, int *reslen, int p_len, int r_len)
|
||||||
|
{
|
||||||
|
struct termios atts;
|
||||||
|
struct termios attr;
|
||||||
|
int ires, i, 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");}
|
||||||
|
|
||||||
|
do { chr=fgetc(stdin); } while (chr!=EOF);
|
||||||
|
|
||||||
|
for (i=0; i<p_len; i++)
|
||||||
|
{ fputc(prompt[i], stderr);
|
||||||
|
};
|
||||||
|
|
||||||
|
ires=fflush(stdin);
|
||||||
|
ires=fflush(stderr);
|
||||||
|
|
||||||
|
*reslen=0;
|
||||||
|
if (prompt[0]=='\0') { ntmo=10; }
|
||||||
|
else { ntmo=200; }; /* wait 2 sec. for the first char */
|
||||||
|
while (*reslen<r_len)
|
||||||
|
{ chr=fgetc(stdin);
|
||||||
|
if (chr==EOF)
|
||||||
|
{ while ((chr==EOF) & (ntmo>0))
|
||||||
|
{ usleep(10000); /* wait 10 ms */
|
||||||
|
chr=fgetc(stdin);
|
||||||
|
ntmo--;
|
||||||
|
};
|
||||||
|
if (chr==EOF) break;
|
||||||
|
if (chr==10) {ntmo=10;} else {ntmo=100;}; /* wait 0.1 sec after LF, 1 sec else */
|
||||||
|
};
|
||||||
|
result[(*reslen)++]=(char)chr;
|
||||||
|
if (chr==24) {(*reslen)=0;}; /* ctrl-X purges buffer */
|
||||||
|
};
|
||||||
|
if (result[(*reslen)-1]=10) {(*reslen)--;}; /* strip trailing LF */
|
||||||
|
|
||||||
|
ires=tcsetattr(STDIN_FILENO,TCSANOW,&atts); /* restore term. attributes */
|
||||||
|
if (ires!=0) {perror("***\n");};
|
||||||
|
}
|
||||||
@ -123,6 +123,22 @@ void TeccClose(pTecsClient conn) {
|
|||||||
#define tecs_date_ tecs_date
|
#define tecs_date_ tecs_date
|
||||||
#define tecs_time_ tecs_time
|
#define tecs_time_ tecs_time
|
||||||
#define tecs_rights_ tecs_rights
|
#define tecs_rights_ tecs_rights
|
||||||
|
#elif defined __linux
|
||||||
|
#define tecs_get_par_ tecs_get_par__
|
||||||
|
#define tecs_get_mult_ tecs_get_mult__
|
||||||
|
#define tecs_set_par_ tecs_set_par__
|
||||||
|
#define tecs_init_ tecs_init__
|
||||||
|
#define tecs_get3_ tecs_get3__
|
||||||
|
#define tecs_get_ tecs_get__
|
||||||
|
#define tecs_set_ tecs_set__
|
||||||
|
#define tecs_is_open_ tecs_is_open__
|
||||||
|
#define tecs_close_ tecs_close__
|
||||||
|
#define tecs_quit_server_ tecs_quit_server__
|
||||||
|
#define tecs_watch_log_ tecs_watch_log__
|
||||||
|
#define tecs_get_data_ tecs_get_data__
|
||||||
|
#define tecs_date_ tecs_date__
|
||||||
|
#define tecs_time_ tecs_time__
|
||||||
|
#define tecs_rights_ tecs_rights__
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
static pTecsClient conn=NULL;
|
static pTecsClient conn=NULL;
|
||||||
|
|||||||
@ -121,7 +121,7 @@ c if INIT exists, read it to get the port number and the start command
|
|||||||
|
|
||||||
startcmd=' '
|
startcmd=' '
|
||||||
|
|
||||||
open (lun, file=init, status='old', readonly, iostat=ios)
|
open (lun, file=init, status='old', iostat=ios)
|
||||||
if (ios .eq. 0) read (lun, *, iostat=ios) port
|
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, *, iostat=ios) ! skip options line
|
||||||
if (ios .eq. 0) read (lun, '(a)', iostat=ios) startcmd
|
if (ios .eq. 0) read (lun, '(a)', iostat=ios) startcmd
|
||||||
@ -137,7 +137,8 @@ c if INIT exists, read it to get the port number and the start command
|
|||||||
endif
|
endif
|
||||||
end
|
end
|
||||||
|
|
||||||
SUBROUTINE TECS_GET_T (IOLUN, TEMP, IRET) !!
|
|
||||||
|
SUBROUTINE TECS_GET_T (IOLUN, TEMP, IRET) !!
|
||||||
!! =========================================
|
!! =========================================
|
||||||
!!
|
!!
|
||||||
!! Get temperatures and wait if TECS is configuring
|
!! Get temperatures and wait if TECS is configuring
|
||||||
@ -175,7 +176,8 @@ c------------------------------------------------------------------------------
|
|||||||
temp(4)=0.0 ! no auxilliary sensor
|
temp(4)=0.0 ! no auxilliary sensor
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine TECS_WRITE_ERROR(IOLUN) !!
|
|
||||||
|
subroutine TECS_WRITE_ERROR(IOLUN) !!
|
||||||
!! ==================================
|
!! ==================================
|
||||||
!!
|
!!
|
||||||
!! write out error message of last error and stack info
|
!! write out error message of last error and stack info
|
||||||
@ -191,7 +193,8 @@ c------------------------------------------------------------------------------
|
|||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
subroutine TECS_WRITE_MSG(IOLUN) !!
|
|
||||||
|
subroutine TECS_WRITE_MSG(IOLUN) !!
|
||||||
!! ================================
|
!! ================================
|
||||||
!!
|
!!
|
||||||
!! write out error message of last error without stack info
|
!! write out error message of last error without stack info
|
||||||
@ -207,7 +210,8 @@ c------------------------------------------------------------------------------
|
|||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
SUBROUTINE TECS_ERR_ROUTINE (LUN, TEXT)
|
|
||||||
|
SUBROUTINE TECS_ERR_ROUTINE (LUN, TEXT)
|
||||||
! =======================================
|
! =======================================
|
||||||
!
|
!
|
||||||
! routine called from C
|
! routine called from C
|
||||||
|
|||||||
6
tecs/tecs_plot.for
Normal file
6
tecs/tecs_plot.for
Normal file
@ -0,0 +1,6 @@
|
|||||||
|
subroutine tecs_plot(str)
|
||||||
|
character str*(*)
|
||||||
|
|
||||||
|
print *
|
||||||
|
& ,'give me Fortran 90 on this machine, I give you graphics'
|
||||||
|
end
|
||||||
Reference in New Issue
Block a user