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

Initial commit

Browse Source
This commit is contained in:
zolliker
2022-08-19 15:22:33 +02:00
commit d682fae506
545 changed files with 48172 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
unix/CVS/Entries Normal file
View File

@ -0,0 +1,32 @@
/myc_tmp.c/1.2/Wed Nov 17 12:19:14 2004//
/myc_tmp.h/1.2/Wed Nov 17 12:19:15 2004//
/sys.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys1.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys3.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys_cmdpar.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys_file.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys_fun.c/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys_fvi.c/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys_getenv.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys_home.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys_lun.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys_parse.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys_rdline0.c/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sys_wait.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/sysc1.c/1.1.1.1/Tue Nov 2 15:54:57 2004//
/terinq.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/terinq_new.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/terinq_old.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/zm_fit/1.1.1.1/Tue Nov 2 15:54:57 2004//
D/cfg////
D/tru64////
/fitv/1.2/Mon Nov 22 10:37:10 2004//
/sys_date.f/1.2/Wed Aug 26 12:30:43 2009//
/sys_env.c/1.2/Wed Aug 26 12:14:03 2009//
/sys_open.f/1.2/Wed Aug 26 11:45:50 2009//
/sys_rdline.c/1.2/Mon Dec 11 13:45:32 2006//
/sys_remote_host.f/1.2/Wed Aug 26 12:31:06 2009//
/sysc.c/1.2/Tue Jan 29 15:07:43 2008//
/napif.f/1.1/Fri May 13 05:49:09 2016//
/sys_try.c/1.2/Wed Apr 5 05:45:06 2017//
/sys_unix.c/1.3/Fri Aug 7 10:05:18 2020//

1
unix/CVS/Repository Normal file
View File

@ -0,0 +1 @@
analysis/fit/unix

1
unix/CVS/Root Normal file
View File

@ -0,0 +1 @@
/afs/psi.ch/project/sinq/cvs

5
unix/cfg/CVS/Entries Normal file
View File

@ -0,0 +1,5 @@
/linux/1.1.1.1/Tue Nov 2 15:54:57 2004//
/macosx/1.1.1.1/Tue Nov 2 15:54:57 2004//
/tru64/1.1.1.1/Tue Nov 2 15:54:57 2004//
/zm_fit/1.1.1.1/Tue Nov 2 15:54:57 2004//
D

1
unix/cfg/CVS/Repository Normal file
View File

@ -0,0 +1 @@
analysis/fit/unix/cfg

1
unix/cfg/CVS/Root Normal file
View File

@ -0,0 +1 @@
/afs/psi.ch/project/sinq/cvs

46
unix/cfg/linux Normal file
View File

@ -0,0 +1,46 @@
# Linux with AFS at PSI
# type of library to be used (LIB_TYPE=a or LIB_TYPE=so)
LIB_TYPE=a
# c-compiler to be used, flags for different options
CC=gcc
C_FLAGS=-g -D__unix -MMD
C_STRICT=-Wall
C_RELAXED=
# fortran compiler to be used, flags for different options
FC=g77
F_FLAGS=-Wimplicit -fbounds-check -I.
F_STRICT=
F_RELAXED=-Wno-globals
F_OPT=-O
F_DEB=-g
# macros for prerequisites (for GNU make)
# Q=all, F/C=Fortran/C source with path
Q=$^
F=$<
C=$<
# linker flags for readline library
RDLIB=-lreadline -ltermcap
# linker flags for pgplot
SINQ=/afs/psi.ch/project/sinq/linux
PGLIB=$(SINQ)/pgplot/libpgplot.a -L/usr/X11R6/lib -lX11
# link NeXus file input routines ? (comment out if not needed)
NXFLAG=Y
# linker flags for NeXus
NXLIB=-L$(SINQ)/lib -lNeXus $(SINQ)/lib/libhdf5.a -lmfhdf -ldf -ljpeg -lz
# directory for the HDF include files
NXHDF=$(SINQ)/include
# directory for the NeXus include files
NXINC=$(SINQ)/include
-include make_deb
include src/unix/make_fit

46
unix/cfg/macosx Normal file
View File

@ -0,0 +1,46 @@
# Mac OS X with Fink
# type of library to be used (LIB_TYPE=a or LIB_TYPE=so)
LIB_TYPE=a
# c-compiler to be used, flags for different options
CC=gcc
C_FLAGS=-g -D__unix -MMD
C_STRICT=-Wall
C_RELAXED=
# fortran compiler to be used, flags for different options
FC=g77
F_FLAGS=-Wimplicit -fbounds-check -I.
F_STRICT=
F_RELAXED=-Wno-globals
F_OPT=-O
F_DEB=-g
# macros for prerequisites (for GNU make)
# Q=all, F/C=Fortran/C source with path
Q=$^
F=$<
C=$<
# linker flags for the readline library
RDLIB=-L/sw/lib -lreadline
# linker flags for pgplot
PGLIB=-L/sw/lib/pgplot -lpgplot -L/usr/X11R6/lib -lX11 -lpng -framework Foundation -framework AppKit
# link NeXus file input routines ? (comment out if not needed)
NXFLAG=Y
# linker flags for NeXus
NXLIB=-L../NeXus -lNeXus -L/sw/lib -lhdf5 -lmfhdf -ldf -ljpeg -lz
# directory for the HDF include files
NXHDF=/sw/include
# directory for the NeXus include files
NXINC=../NeXus
-include make_deb
include src/unix/make_fit

55
unix/cfg/tru64 Normal file
View File

@ -0,0 +1,55 @@
# Tru64 Unix with lnslib
# type of library to be used (LIB_TYPE=a or LIB_TYPE=so)
LIB_TYPE=so
# c-compiler to be used, flags for different options
CC=cc
C_FLAGS=-I. -I/data/lnslib/include -MD -g
C_STRICT=-std1 -warnprotos
C_RELAXED=
# fortran compiler to be used, flags for different options
FC=f77
F_FLAGS=-vms -u -check bounds -assume source_include
F_STRICT=-warn decl -warn arg
F_RELAXED=-warn decl
F_OPT=
F_DEB=-g
# macros for prerequisites (different make versions)
# Q=all, F/C=Fortran/C source with path
Q=$>
F=$*.f
C=$*.c
# C-dependencies are not automatic on this make version
CDEP=make_cdep
LNL=/data/lnslib/lib/lib
# linker flags for readline library
RDLIB=$(LNL)readline.a -ltermcap
# linker flags for pgplot
PGLIB=$(LNL)pgplot.so -lX11 -lXm -lm
# path for tru64 specific routines
SPECPATH=:src/unix/tru64/
# link NeXus file input routines ? (comment out if not needed)
NXFLAG=Y
# linker flags for NeXus
NXLIB=$(LNL)NeXus45.a $(LNL)hdf5.a $(LNL)mfhdf.a $(LNL)df.a $(LNL)jpeg.a $(LNL)z.a
# directory for the HDF include files
NXHDF=/data/lnslib/include
# directory for the NeXus include files
NXINC=/data/lnslib/include
# add to 'all' list
ADD_ALL=terinq trics_ccl tricslog mclamp
-include make_deb
include src/unix/make_fit

1
unix/cfg/zm_fit Normal file
View File

@ -0,0 +1 @@
this file is used by config

52
unix/fitv Executable file
View File

@ -0,0 +1,52 @@
set lib_path_=$LD_LIBRARY_PATH
if ($?lib_path_n) then
else
set lib_path_n=$LD_LIBRARY_PATH
endif
set lib_path_b=/afs/psi.ch/project/sinq/tru64/lib/fit_beta:$lib_path_n
set lib_path_o=/afs/psi.ch/project/sinq/tru64/lib/fit_old:$lib_path_n
echo " "
setenv LD_LIBRARY_PATH $lib_path_n
if ("$lib_path_" == "$lib_path_n") then
fitvers "* Normal version"
else
fitvers " Normal version"
endif
setenv LD_LIBRARY_PATH $lib_path_b
if ("$lib_path_" == "$lib_path_b") then
fitvers "* Beta version"
else
fitvers " Beta version"
endif
setenv LD_LIBRARY_PATH $lib_path_o
if ("$lib_path_" == "$lib_path_o") then
fitvers "* Old version"
else
fitvers " Old version"
endif
setenv LD_LIBRARY_PATH $lib_path_
echo " "
if ("$1" == "") then
echo "Select version (n,b,o)"
set v=$<
echo " "
else
set v="$1"
endif
if ($v == "n") then
setenv LD_LIBRARY_PATH $lib_path_n
echo "Normal version selected"
else
if ($v == "b") then
setenv LD_LIBRARY_PATH $lib_path_b
echo "Beta version selected"
else
if ($v == "o") then
setenv LD_LIBRARY_PATH $lib_path_o
echo "Old version selected"
else
echo "Version not changed"
endif
endif
endif

98
unix/myc_tmp.c Executable file
View File

@ -0,0 +1,98 @@
#include <unistd.h>
#include <stdio.h>
#include <stdlib.h>
#include <time.h>
#include "myc_fortran.h"
#include "myc_mem.h"
#include "myc_err.h"
#include "myc_str.h"
#include "myc_tmp.h"
int MycTmpName(char *result, const char *name, int reslen) {
char tmp[128];
char *u;
if (strlen(name)+64 > sizeof(tmp))
ERR_MSG("destination string too short"); /* do not accept too long names */
u=getenv("USER");
if (u==NULL)
ERR_MSG("USER undefined");
sprintf(tmp, "%s/%s_%s.%d",TEMP_PATH, name, u, getpid());
ERR_I(str_ncpy(result, tmp, reslen));
return 0;
OnError:
return -1;
}
int MycCleanTmp(void) {
time_t tim;
static time_t last=0;
char file[128], line[1024], fullid[16];
char *sess=NULL, *files=NULL;
char *list, *id, *nxt, *nextline;
int i;
time(&tim);
if (tim < last+3600) return 0; /* do not clean up before an hour after last time */
last=tim;
file[0]='\0';
ERR_I(MycTmpName(file, ".cleanup", sizeof(file)));
unlink(file);
/* make a list of used session and process id's */
sprintf(line, "ps -U $USER -o pid,sess > %s", file);
system(line);
ERR_P(sess=str_read_file(file));
unlink(file);
for (i=0; i<2; i++) {
if (i==0) {
sprintf(line,
"find /tmp/. ! -name . -prune -name \".*_$USER.*\" > %s", file);
} else {
sprintf(line,
"find /tmp/. ! -name . -prune -name \"*_$USER.*\" -mtime +7 > %s", file);
}
system(line);
ERR_P(files=str_read_file(file));
unlink(file);
str_replace_char(sess, '\n', ' ');
list=files;
while (*list != '\0') {
nextline=str_split1(list, '\n');
id=NULL;
nxt=list;
while (nxt != NULL) { /* find last dot */
id=nxt+1;
nxt=strchr(nxt+1, '.');
}
if (id!=NULL) { /* file contains a dot */
sprintf(fullid, " %.12s ", id);
if (strstr(sess, fullid)==NULL) {
unlink(list);
}
}
list=nextline;
}
FREE(files); files=NULL;
}
FREE(sess); sess=NULL;
return 0;
OnError:
if (file[0] != '\0') unlink(file);
if (sess!=NULL) FREE(sess);
if (files!=NULL) FREE(files);
return -1;
}
void F_FUN(sys_temp_name) ( F_CHAR(name), F_CHAR(path) F_CLEN(name) F_CLEN(path)) {
char nam[128];
char pat[1024];
STR_TO_C(nam, name);
MycTmpName(pat, nam, sizeof(pat));
STR_TO_F(path, pat);
}
void F_FUN(sys_clean_tmp) (void) {
MycCleanTmp();
}

16
unix/myc_tmp.h Executable file
View File

@ -0,0 +1,16 @@
int MycTmpName(char *result, const char *name, int reslen);
/* generate a temporary filename containing 'name'.
* the filename is stored in 'result' with less than 'reslen' characters.
*/
int MycCleanTmp(void);
/* deletes temporary files from closed sessions. files not beginning with a
* dot will be kept at least for 7 days (if the system does not delete then)
*/
#ifdef __CYGWIN__
#define TEMP_PATH getenv("TEMP")
#else
#define TEMP_PATH "/tmp"
#endif

477
unix/napif.f Normal file
View File

@ -0,0 +1,477 @@
C------------------------------------------------------------------------------
C NeXus - Neutron & X-ray Common Data Format
C
C Application Program Interface (Fortran 77)
C
C Copyright (C) 1997-2002 Freddie Akeroyd, Mark Koennecke
C
C This library is free software; you can redistribute it and/or
C modify it under the terms of the GNU Lesser General Public
C License as published by the Free Software Foundation; either
C version 2 of the License, or (at your option) any later version.
C
C This library is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
C Lesser General Public License for more details.
C
C You should have received a copy of the GNU Lesser General Public
C License along with this library; if not, write to the Free Software
C Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
C
C For further information, see <http://www.nexusformat.org>
C
C $Id: napif.f,v 1.1 2016/05/13 05:49:09 zolliker Exp $
C------------------------------------------------------------------------------
C------------------------------------------------------------------------------
C Doxygen comments follow
C for help, see: http://www.stack.nl/~dimitri/doxygen/docblocks.html#fortranblocks
C
C------------------------------------------------------------------------------
INTEGER FUNCTION truelen(STRING)
CHARACTER*(*) string
DO truelen=len(string),1,-1
IF (string(truelen:truelen) .NE. ' ' .AND.
& string(truelen:truelen) .NE. char(0) ) RETURN
ENDDO
truelen = 0
END
SUBROUTINE extract_string(ISTRING, LENMAX, STRING)
CHARACTER*(*) string
INTEGER i,ilen,truelen,lenmax
INTEGER*1 istring(lenmax)
EXTERNAL truelen
ilen = truelen(string)
IF (ilen .GE. lenmax) THEN
WRITE(6,9000) lenmax, ilen+1
RETURN
ENDIF
DO i=1,ilen
istring(i) = ichar(string(i:i))
ENDDO
istring(ilen+1) = 0
RETURN
9000 FORMAT('NeXus(NAPIF/EXTRACT_STRING): String too long -',
+ 'buffer needs increasing from ', i4,' to at least ',i4)
END
SUBROUTINE replace_string(STRING, ISTRING)
INTEGER*1 istring(*)
CHARACTER*(*) string
INTEGER i
string = ' '
DO i=1,len(string)
IF (istring(i) .EQ. 0) RETURN
string(i:i) = char(istring(i))
ENDDO
IF (istring(len(string)+1) .NE. 0) WRITE(6,9010) len(string)
RETURN
9010 FORMAT('NeXus(NAPIF/REPLACE_STRING): String truncated - ',
+ 'buffer needs to be > ', i4)
END
INTEGER FUNCTION nxopen(FILENAME, ACCESS_METHOD, FILEID)
CHARACTER*(*) filename
INTEGER*1 ifilename(256)
INTEGER access_method
INTEGER fileid(*),nxifopen
EXTERNAL nxifopen
CALL extract_string(ifilename, 256, filename)
nxopen = nxifopen(ifilename, access_method, fileid)
END
INTEGER FUNCTION nxclose(FILEID)
INTEGER fileid(*),nxifclose
EXTERNAL nxifclose
nxclose = nxifclose(fileid)
END
INTEGER FUNCTION nxflush(FILEID)
INTEGER fileid(*), nxifflush
EXTERNAL nxifflush
nxflush = nxifflush(fileid)
END
INTEGER FUNCTION nxmakegroup(FILEID, VGROUP, NXCLASS)
INTEGER fileid(*),nximakegroup
CHARACTER*(*) vgroup, nxclass
INTEGER*1 ivgroup(256), inxclass(256)
EXTERNAL nximakegroup
CALL extract_string(ivgroup, 256, vgroup)
CALL extract_string(inxclass, 256, nxclass)
nxmakegroup = nximakegroup(fileid, ivgroup, inxclass)
END
INTEGER FUNCTION nxopengroup(FILEID, VGROUP, NXCLASS)
INTEGER fileid(*),nxiopengroup
CHARACTER*(*) vgroup, nxclass
INTEGER*1 ivgroup(256), inxclass(256)
EXTERNAL nxiopengroup
CALL extract_string(ivgroup, 256, vgroup)
CALL extract_string(inxclass, 256, nxclass)
nxopengroup = nxiopengroup(fileid, ivgroup, inxclass)
END
INTEGER FUNCTION nxopenpath(FILEID, PATH)
INTEGER fileid(*),nxiopenpath
CHARACTER*(*) path
INTEGER*1 ipath(256)
EXTERNAL nxiopenpath
CALL extract_string(ipath, 256, path)
nxopenpath = nxiopenpath(fileid, ipath)
END
INTEGER FUNCTION nxgetpath(FILEID, PATH)
INTEGER fileid(*),nxigetpath, nxifgetpath
CHARACTER*(*) path
INTEGER*1 ipath(1024)
INTEGER plen
EXTERNAL nxifgetpath
plen = 1024
nxgetpath = nxifgetpath(fileid,ipath,plen)
CALL replace_string(path,ipath)
END
INTEGER FUNCTION nxopengrouppath(FILEID, PATH)
INTEGER fileid(*),nxiopengrouppath
CHARACTER*(*) path
INTEGER*1 ipath(256)
EXTERNAL nxiopengrouppath
CALL extract_string(ipath, 256, path)
nxopengrouppath = nxiopengrouppath(fileid, ipath)
END
INTEGER FUNCTION nxclosegroup(FILEID)
INTEGER fileid(*),nxiclosegroup
EXTERNAL nxiclosegroup
nxclosegroup = nxiclosegroup(fileid)
END
INTEGER FUNCTION nxmakedata(FILEID, LABEL, DATATYPE, RANK, DIM)
INTEGER fileid(*), datatype, rank, dim(*), nxifmakedata
CHARACTER*(*) label
INTEGER*1 ilabel(256)
EXTERNAL nxifmakedata
CALL extract_string(ilabel, 256, label)
nxmakedata = nxifmakedata(fileid, ilabel, datatype, rank, dim)
END
INTEGER FUNCTION nxcompmakedata(FILEID, LABEL, DATATYPE, RANK,
& dim, compression_type, chunk)
INTEGER fileid(*), datatype, rank, dim(*)
INTEGER compression_type, chunk(*)
INTEGER nxifcompmakedata
CHARACTER*(*) label
INTEGER*1 ilabel(256)
EXTERNAL nxifmakedata
CALL extract_string(ilabel, 256, label)
nxcompmakedata = nxifcompmakedata(fileid, ilabel, datatype,
& rank, dim, compression_type, chunk)
END
INTEGER FUNCTION nxopendata(FILEID, LABEL)
INTEGER fileid(*),nxiopendata
CHARACTER*(*) label
INTEGER*1 ilabel(256)
EXTERNAL nxiopendata
CALL extract_string(ilabel, 256, label)
nxopendata = nxiopendata(fileid, ilabel)
END
INTEGER FUNCTION nxsetnumberformat(FILEID, ITYPE, FORMAT)
INTEGER fileid(*),nxisetnumberformat,itype
CHARACTER*(*) format
INTEGER*1 ilabel(256)
EXTERNAL nxisetnumberformat
CALL extract_string(ilabel, 256, format)
nxsetnumberformat = nxisetnumberformat(fileid, itype, ilabel)
END
INTEGER FUNCTION nxcompress(FILEID, COMPR_TYPE)
INTEGER fileid(*),nxifcompress,compr_type
EXTERNAL nxifcompress
nxcompress = nxifcompress(fileid, compr_type)
END
INTEGER FUNCTION nxclosedata(FILEID)
INTEGER fileid(*),nxiclosedata
EXTERNAL nxiclosedata
nxclosedata = nxiclosedata(fileid)
END
INTEGER FUNCTION nxgetdata(FILEID, DATA)
INTEGER fileid(*), data(*), nxigetdata
EXTERNAL nxigetdata
nxgetdata = nxigetdata(fileid, data)
END
INTEGER FUNCTION nxgetchardata(FILEID, DATA)
INTEGER fileid(*), nxigetdata
CHARACTER*(*) data
INTEGER nx_error,nx_idatlen
parameter(nx_error=0,nx_idatlen=1024)
INTEGER*1 idata(nx_idatlen)
EXTERNAL nxigetdata
C *** We need to zero IDATA as GETDATA doesn't NULL terminate character data,
C *** and so we would get "buffer not big enough" messages from REPLACE_STRING
DO i=1,nx_idatlen
idata(i) = 0
ENDDO
nxgetchardata = nxigetdata(fileid, idata)
IF (nxgetchardata .NE. nx_error) THEN
CALL replace_string(DATA, idata)
ENDIF
END
INTEGER FUNCTION nxgetslab(FILEID, DATA, START, SIZE)
INTEGER fileid(*), data(*), start(*), size(*)
INTEGER nx_maxrank, nx_ok
parameter(nx_maxrank=32,nx_ok=1)
INTEGER rank, dim(nx_maxrank), datatype, i
INTEGER cstart(nx_maxrank), csize(nx_maxrank)
INTEGER nxigetslab, nxgetinfo
EXTERNAL nxigetslab
nxgetslab = nxgetinfo(fileid, rank, dim, datatype)
IF (nxgetslab .NE. nx_ok) RETURN
DO i = 1, rank
cstart(i) = start(rank-i+1) - 1
csize(i) = SIZE(rank-i+1)
ENDDO
nxgetslab = nxigetslab(fileid, DATA, cstart, csize)
END
INTEGER FUNCTION nxgetattr(FILEID, NAME, DATA, DATALEN, TYPE)
INTEGER fileid(*),data(*),datalen,type
CHARACTER*(*) name
INTEGER*1 iname(256)
INTEGER nxigetattr
EXTERNAL nxigetattr
CALL extract_string(iname, 256, name)
nxgetattr = nxigetattr(fileid, iname, DATA, datalen, type)
END
INTEGER FUNCTION nxgetcharattr(FILEID, NAME, DATA,
+ datalen, type)
INTEGER max_datalen,nx_error
INTEGER fileid(*), datalen, type
parameter(max_datalen=1024,nx_error=0)
CHARACTER*(*) name, data
INTEGER*1 idata(max_datalen)
INTEGER*1 iname(256)
INTEGER nxigetattr
EXTERNAL nxigetattr
CALL extract_string(iname, 256, name)
IF (datalen .GE. max_datalen) THEN
WRITE(6,9020) datalen, max_datalen
nxgetcharattr=nx_error
RETURN
ENDIF
nxgetcharattr = nxigetattr(fileid, iname, idata, datalen, type)
IF (nxgetcharattr .NE. nx_error) THEN
CALL replace_string(DATA, idata)
ENDIF
RETURN
9020 FORMAT('NXgetattr: asked for attribute size ', i4,
+ ' with buffer size only ', i4)
END
INTEGER FUNCTION nxputdata(FILEID, DATA)
INTEGER fileid(*), data(*), nxiputdata
EXTERNAL nxiputdata
nxputdata = nxiputdata(fileid, data)
END
INTEGER FUNCTION nxputchardata(FILEID, DATA)
INTEGER fileid(*), nxiputdata
CHARACTER*(*) data
INTEGER*1 idata(1024)
EXTERNAL nxiputdata
CALL extract_string(idata, 1024, data)
nxputchardata = nxiputdata(fileid, idata)
END
INTEGER FUNCTION nxputslab(FILEID, DATA, START, SIZE)
INTEGER fileid(*), data(*), start(*), size(*)
INTEGER nx_maxrank,nx_ok
parameter(nx_maxrank=32,nx_ok=1)
INTEGER rank, dim(nx_maxrank), datatype, i
INTEGER cstart(nx_maxrank), csize(nx_maxrank)
INTEGER nxiputslab, nxgetinfo
EXTERNAL nxiputslab
nxputslab = nxgetinfo(fileid, rank, dim, datatype)
IF (nxputslab .NE. nx_ok) RETURN
DO i = 1, rank
cstart(i) = start(rank-i+1) - 1
csize(i) = SIZE(rank-i+1)
ENDDO
nxputslab = nxiputslab(fileid, DATA, cstart, csize)
END
INTEGER FUNCTION nxputattr(FILEID, NAME, DATA, DATALEN, TYPE)
INTEGER fileid(*), data(*), datalen, type
CHARACTER*(*) name
INTEGER*1 iname(256)
INTEGER nxifputattr
EXTERNAL nxifputattr
CALL extract_string(iname, 256, name)
nxputattr = nxifputattr(fileid, iname, DATA, datalen, type)
END
INTEGER FUNCTION nxputcharattr(FILEID, NAME, DATA,
+ datalen, type)
INTEGER fileid(*), datalen, type
CHARACTER*(*) name, data
INTEGER*1 iname(256)
INTEGER*1 idata(1024)
INTEGER nxifputattr
EXTERNAL nxifputattr
CALL extract_string(iname, 256, name)
CALL extract_string(idata, 1024, data)
nxputcharattr = nxifputattr(fileid, iname, idata, datalen, type)
END
INTEGER FUNCTION nxgetinfo(FILEID, RANK, DIM, DATATYPE)
INTEGER fileid(*), rank, dim(*), datatype
INTEGER i, j, nxigetinfo, nx_char
EXTERNAL nxigetinfo
nxgetinfo = nxigetinfo(fileid, rank, dim, datatype)
C *** Reverse dimension array as C is ROW major, FORTRAN column major
DO i = 1, rank/2
j = dim(i)
dim(i) = dim(rank-i+1)
dim(rank-i+1) = j
ENDDO
END
INTEGER FUNCTION nxgetnextentry(FILEID, NAME, CLASS, DATATYPE)
INTEGER fileid(*), datatype
CHARACTER*(*) name, class
INTEGER*1 iname(256), iclass(256)
INTEGER nxigetnextentry
EXTERNAL nxigetnextentry
nxgetnextentry = nxigetnextentry(fileid, iname, iclass, datatype)
CALL replace_string(name, iname)
CALL replace_string(class, iclass)
END
INTEGER FUNCTION nxgetnextattr(FILEID, PNAME, ILENGTH, ITYPE)
INTEGER fileid(*), ilength, itype, nxigetnextattr
CHARACTER*(*) pname
INTEGER*1 ipname(1024)
EXTERNAL nxigetnextattr
nxgetnextattr = nxigetnextattr(fileid, ipname, ilength, itype)
CALL replace_string(pname, ipname)
END
INTEGER FUNCTION nxgetgroupid(FILEID, LINK)
INTEGER fileid(*), link(*), nxigetgroupid
EXTERNAL nxigetgroupid
nxgetgroupid = nxigetgroupid(fileid, link)
END
INTEGER FUNCTION nxgetdataid(FILEID, LINK)
INTEGER fileid(*), link(*), nxigetdataid
EXTERNAL nxigetdataid
nxgetdataid = nxigetdataid(fileid, link)
END
INTEGER FUNCTION nxmakelink(FILEID, LINK)
INTEGER fileid(*), link(*), nximakelink
EXTERNAL nximakelink
nxmakelink = nximakelink(fileid, link)
END
INTEGER FUNCTION nxmakenamedlink(FILEID, PNAME, LINK)
INTEGER fileid(*), link(*), nximakelink
CHARACTER*(*) pname
INTEGER*1 iname(256)
EXTERNAL nximakenamedlink
CALL extract_string(iname,256,pname)
nxmakenamedlink = nximakenamedlink(fileid, iname, link)
END
INTEGER FUNCTION nxopensourcegroup(FILEID)
INTEGER fileid(*),nxiopensourcegroup
EXTERNAL nxiopensourcegroup
nxopensourcegroup = nxiopensourcegroup(fileid)
END
LOGICAL FUNCTION nxsameid(FILEID, LINK1, LINK2)
INTEGER fileid(*), link1(*), link2(*), nxisameid, status
EXTERNAL nxisameid
status = nxisameid(fileid, link1, link2)
IF (status .EQ. 1) THEN
nxsameid = .true.
ELSE
nxsameid = .false.
ENDIF
END
INTEGER FUNCTION nxgetgroupinfo(FILEID, NUM, NAME, CLASS)
INTEGER fileid(*), num, nxigetgroupinfo
CHARACTER*(*) name, class
INTEGER*1 iname(256), iclass(256)
EXTERNAL nxigetgroupinfo
nxgetgroupinfo = nxigetgroupinfo(fileid, num, iname, iclass)
CALL replace_string(name, iname)
CALL replace_string(class, iclass)
END
INTEGER FUNCTION nxinitgroupdir(FILEID)
INTEGER fileid(*), nxiinitgroupdir
EXTERNAL nxiinitgroupdir
nxinitgroupdir = nxiinitgroupdir(fileid)
END
INTEGER FUNCTION nxgetattrinfo(FILEID, NUM)
INTEGER fileid(*), num, nxigetattrinfo
EXTERNAL nxigetattrinfo
nxgetattrinfo = nxigetattrinfo(fileid, num)
END
INTEGER FUNCTION nxinitattrdir(FILEID)
INTEGER fileid(*), nxiinitattrdir
EXTERNAL nxiinitattrdir
nxinitattrdir = nxiinitattrdir(fileid)
END
INTEGER FUNCTION nxisexternalgroup(FILEID, VGROUP, NXCLASS, NXURL)
INTEGER fileid(*),nxiisexternalgroup, length
CHARACTER*(*) vgroup, nxclass, nxurl
INTEGER*1 ivgroup(256), inxclass(256), inxurl(256)
EXTERNAL nxiisexternalgroup
length = 256
CALL extract_string(ivgroup, 256, vgroup)
CALL extract_string(inxclass, 256, nxclass)
nxisexternalgroup = nxiisexternalgroup(fileid, ivgroup, inxclass,
& inxurl,length)
CALL replace_string(nxurl, inxurl)
END
INTEGER FUNCTION nxinquirefile(FILEID, NXFILE)
INTEGER fileid(*),nxiinquirefile, length
CHARACTER*(*) nxfile
INTEGER*1 inxfile (1024)
EXTERNAL nxiinquirefile
length = 1023
nxinquirefile = nxiinquirefile(fileid,inxfile, 1023)
CALL replace_string(nxfile, inxfile)
END
INTEGER FUNCTION nxlinkexternal(FILEID, VGROUP, NXCLASS, NXURL)
INTEGER fileid(*),nxilinkexternal
CHARACTER*(*) vgroup, nxclass, nxurl
INTEGER*1 ivgroup(256), inxclass(256), inxurl(1024)
EXTERNAL nxilinkexternal
CALL extract_string(ivgroup, 256, vgroup)
CALL extract_string(inxclass, 256, nxclass)
CALL extract_string(inxurl, 1023, nxurl)
nxlinkexternal = nxilinkexternal(fileid, ivgroup,inxclass,
& inxurl)
END

382
unix/sys.f Executable file
View File

@ -0,0 +1,382 @@
!!------------------------------------------------------------------------------
!! MODULE SYS
!!------------------------------------------------------------------------------
!! 26.11.02 M. Zolliker
!!
!! System dependent subroutines for unix
!!------------------------------------------------------------------------------
!!
subroutine SYS_GETENV(NAME, VALUE) !!
!! ==================================
!!
!! Get environment variable NAME
!! try all uppercase also
implicit none
!! Arguments:
character*(*) NAME !! logical name
character*(*) VALUE !! result
integer l
character nam*128
call sys_loadenv
call str_trim(nam, name, l)
call getenv(nam(1:l), value)
if (value .ne. ' ') RETURN
if (nam(1:1) .ge. 'a') then
call str_upcase(nam(1:l), nam(1:l))
else
call str_lowcase(nam(1:l), nam(1:l))
endif
call getenv(nam(1:l), value)
end
!!------------------------------------------------------------------------------
!!
subroutine SYS_GETENV_IDX(NAME, VALUE, IDX) !!
!! ===========================================
!!
!! Get environment variable NAME, only list element IDX (start with 0)
!! (separated by comma)
implicit none
!! Arguments:
character*(*) NAME !! logical name
character*(*) VALUE !! result
integer IDX !! index
integer l,pos,j,i
character nam*128, list*1024
call str_trim(nam, name, l)
call getenv(nam(1:l), list)
if (list .eq. ' ') then
if (nam(1:1) .ge. 'a') then
call str_upcase(nam(1:l), nam(1:l))
else
call str_lowcase(nam(1:l), nam(1:l))
endif
call getenv(nam(1:l), list)
endif
pos=0
do i=1,idx
j=index(list(pos+1:), ',')
if (j .eq. 0) then
value=' '
RETURN
endif
pos=pos+j
enddo
j=index(list(pos+1:), ',')
if (j .eq. 1) then
value=' '
RETURN
endif
if (j .le. 0) then
value=list(pos+1:)
else
value=list(pos+1:pos+j-1)
endif
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_DATE(YEAR, MONTH, DAY) !!
!! -------------------------------------
!!
!! get actual date
!!
integer YEAR, MONTH, DAY !! 4-Digits year, month and day
integer darray(3)
external idate
call idate(darray)
day=darray(1)
month=darray(2)
year=darray(3)
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_GET_CMDPAR(STR, L) !!
!! ---------------------------------
!!
character*(*) STR !!
integer L !!
integer i,iargc
l=0
str=' '
do i=1,iargc()
if (l .lt. len(str)) then
call getarg(i, str(l+1:))
call str_trim(str, str, l)
l=l+1
endif
enddo
if (l .gt. 0) then
if (str(1:l) .eq. ' ') l=0
endif
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_REMOTE_HOST(STR, TYPE) !!
!!
!! get remote host name/number
!!
!! type: TN telnet, RT: decnet, LO: local, XW: X-window (ssh or telnet)
!!
character STR*(*), TYPE*(*) !!
character host*128, line*128, path*256, os*7
integer i,j,lun,iostat
integer system
external system
call sys_getenv('OS', os)
if (os .eq. 'Windows') then
str='local'
type='LO'
return
endif
call sys_getenv('HOST', host)
call sys_getenv('DISPLAY', str)
i=index(str,':')
type=' '
if (i .gt. 1) then
str=str(1:i-1)
type='XW'
if (str .ne. 'localhost') goto 80
endif
call sys_getenv('REMOTEHOST', str)
if (str .eq. ' ') then
call sys_temp_name('.whoami', path)
call sys_delete_file(path)
i=system('who -m > '//path)
call sys_get_lun(lun)
call sys_open(lun, path, 'r', iostat)
if (iostat .ne. 0) goto 9
read(lun,'(a)',end=9,err=9) line
9 close(lun)
call sys_delete_file(path)
i=index(line,'(')
if (i .ne. 0 .and. i .lt. len(line)) then
str=line(i+1:)
i=index(str, ')')
if (i .ne. 0) str(i:)=' '
endif
endif
i=index(str,':')
if (i .ne. 0) str(i:)=' '
if (str .ne. ' ') then
if (type .eq. ' ') type='TN'
else
str=host
type='LO'
endif
c add domain to short host names
80 i=index(str, '.')
j=index(host, '.')
if (j .gt. 0 .and. i .eq. 0) then
call str_trim(str, str, i)
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_TEMP_NAME0(NAME, PATH) !!
!! ====================================
!! get a temporary file name (disabled)
!!
character*(*) NAME !! (in) name
character*(*) PATH !! (out) path
character line*64, pid*12, user*64
integer i, l
integer getppid
call sys_getenv('USER', user)
line(1:6)='/tmp/.'
line(7:)=name
call str_trim(line, line, l)
if (user .ne. ' ') then
line(l+1:)='_'//user
call str_trim(line, line, l)
endif
write(pid,'(i12)') getppid()
i=1
1 if (pid(i:i) .eq. ' ') then
i=i+1
goto 1
endif
path=line(1:l)//'.'//pid(i:12)
end
!!-----------------------------------------------------------------------------
!!
! subroutine SYS_LOAD_ENV(FILE) !!
!! =============================
!! load environment from temporary file
!!
! character*(*) FILE !! filename
!
! character path*128, line*128
! integer lun, i, l, iostat
!
! integer getppid
!
! call sys_temp_name(file, path)
! call sys_get_lun(lun)
! call sys_open(lun, path, 'r', iostat)
! if (iostat .ne. 0) goto 9
!5 read(lun,'(a)',end=8) line
! call str_trim(line, line, l)
! 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, iostat
call sys_temp_name(file, path)
call sys_get_lun(lun)
call sys_open(lun, path, 'wo', iostat)
if (iostat .ne. 0) goto 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_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
call sys_getenv('HOME',home)
call str_trim(home, home, l)
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

126
unix/sys1.f Normal file
View File

@ -0,0 +1,126 @@
!!-----------------------------------------------------------------------------
!!
subroutine sys_parse(result, reslen, file, default, mode) !!
!! ---------------------------------------------------------
!!
!! parse file name
!! mode=0: skip default directory
!! mode=1: name only
!! mode=2: extension only
!! mode=3: name+extension only
implicit none
character*(*) result, file, default
integer reslen, mode
character*1024 dir1, dir2, res
integer l1,l2,d1,d2,n1,n2,e1,e2
call sys_split_path(file, d1, n1, e1)
call sys_split_path(default, d2, n2, e2)
reslen=0
if (mode .eq. 0) then
if (d1 .gt. 0) then
call sys_realpath(dir1, l1, file(1:max(1,d1-1)))
elseif (d2 .gt. 0) then
call sys_realpath(dir1, l1, default(1:max(1,d2-1)))
else
goto 19
endif
call getcwd(dir2)
call sys_realpath(dir2, l2, dir2)
if (dir1(1:l1) .ne. dir2(1:l2)) then
if (d1 .gt. 0) then
call str_append(res, reslen, file(1:max(1,d1-1)))
elseif (d2 .gt. 0) then
call str_append(res, reslen, default(1:max(1,d2-1)))
else
stop 'SYS_PARSE: fatal error'
endif
if (reslen .gt. 1) then
call str_append(res, reslen, '/')
endif
endif
19 continue
elseif (mode .lt. 0 .or. mode .gt. 3) then
stop 'SYS_PARSE: illegal mode'
endif
if (mode .ne. 2) then
if (n1 .gt. d1) then
call str_append(res, reslen, file(d1+1:n1))
elseif (n2 .gt. d2) then
call str_append(res, reslen, default(d2+1:n2))
endif
endif
if (mode .ne. 1) then
if (e1 .gt. n1) then
call str_append(res, reslen, file(n1+1:e1))
elseif (e2 .gt. n2) then
call str_append(res, reslen, default(n2+1:e2))
endif
endif
if (reslen .eq. 0) then
result=' '
else
result=res(1:reslen)
endif
end
subroutine sys_split_path(path, enddir, endnam, endext)
!
! examine a path and report the position of the end of the directory,
! of the filename, and the extension
! Example: call sys_split_path("/home/user/file.name.txt", ed, en, ee)
! ^ ^ ^
! ed=9 en=18 ee=22
character path*(*)
integer enddir, endnam, endext
integer i, mx
i=index(path, '/')
if (i .eq. 0) then
enddir=0
else
mx=i
do while (i .lt. len(path))
i=i+1
if (path(i:i) .eq. '/') mx=i
enddo
enddir=mx
i=mx
endif
mx=len(path)
endnam=mx
do while (i .lt. mx)
i=i+1
if (path(i:i) .eq. '.') endnam=i-1
if (path(i:i) .le. ' ') then
mx=i-1
endif
enddo
endext=mx
if (endnam .gt. mx) endnam=mx
end
!!-----------------------------------------------------------------------------
subroutine sys_find_file !!
!! not available on DEC Unix
end
!!-----------------------------------------------------------------------------
!!
subroutine get_tasmad_high(file, numor) !!
!!
character file*(*)
integer numor
call dat_get_datanumber(file, numor)
end

26
unix/sys3.f Normal file
View File

@ -0,0 +1,26 @@
!!-----------------------------------------------------------------------------
!!
subroutine SYS_DIR(PATH, ROUTINE, ARG) !!
!! --------------------------------------
!!
character*(*) PATH !! wildcard file specification
external ROUTINE !! routine to call with all matching files
integer ARG !! argument for ROUTINE
character file*128, user*32, line*128, line0*128
integer l, lun, cnt, pid, kill
call sys_temp_name('clnup', file)
call sys_delete_file(file)
call sys_cmd('ls -alt '//path//' > '//file)
call sys_get_lun(lun)
line0=' '
open(lun, file=file, status='old', readonly, err=9)
1 read(lun, '(a)', end=2) line
call str_trim(line,line,l)
call routine(line, arg)
goto 1
2 close(lun)
9 call sys_free_lun(lun)
call sys_delete_file(file)
end

23
unix/sys_cmdpar.f Normal file
View File

@ -0,0 +1,23 @@
!!-----------------------------------------------------------------------------
!!
subroutine SYS_GET_CMDPAR(STR, L) !!
!! ---------------------------------
!!
character*(*) STR !!
integer L !!
integer i,iargc
l=0
str=' '
do i=1,iargc()
if (l .lt. len(str)) then
call getarg(i, str(l+1:))
call str_trim(str, str, l)
l=l+1
endif
enddo
if (l .gt. 0) then
if (str(1:l) .eq. ' ') l=0
endif
end

21
unix/sys_date.f Normal file
View File

@ -0,0 +1,21 @@
!!-----------------------------------------------------------------------------
!!
subroutine SYS_DATE(YEAR, MONTH, DAY) !!
!! -------------------------------------
!!
!! get actual date
!!
integer YEAR, MONTH, DAY !! 4-Digits year, month and day
integer tarray(9)
external sys_time
integer sys_time
integer t
t=sys_time()
call ltime(t, 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

181
unix/sys_env.c Executable file
View File

@ -0,0 +1,181 @@
#include <sys/stat.h>
#include <sys/types.h>
#include <termios.h>
#include <unistd.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <time.h>
#include <utmp.h>
#include "myc_tmp.h"
#include "myc_str.h"
#include "myc_fortran.h"
#define ENAM_LEN 128
#define EVAL_LEN 1024
int sys_trim(const char *str, int len);
#ifdef __alpha
int setenv(char *p1, char *p2, int ow);
#endif
typedef struct _EnvList { struct _EnvList *next; char *name; char *value; } EnvList;
static EnvList *envlist;
static char tmpfil[128];
static char senv_id[16];
static char *empty="";
static int loaded=0;
static int dirty=0;
EnvList *sys_findenv(char *name) {
EnvList *p;
for (p=envlist; p!=NULL; p=p->next) {
if (0==strcmp(name, p->name)) {
return p;
}
}
return NULL;
}
int F_FUN(sys_loadenv)(void) {
FILE *fil;
char buf[ENAM_LEN+EVAL_LEN+10];
char old[EVAL_LEN], userid[32];
char *nam, *val, *pold, *u, *ret, *v;
int l;
EnvList *p;
if (!loaded) {
loaded=-1; /* assume failure */
/* u=cuserid(userid); */
u=getenv("USER");
if (u==NULL) {
strcpy(userid, "Anonymous");
} else {
strncpy(userid, u, sizeof(userid));
}
val=getenv("senv_id");
if (val==NULL) {
sprintf(senv_id, "%d", getppid());
} else {
strcpy(senv_id, val);
}
sprintf(tmpfil, "%s/.senv_%s.%s",TEMP_PATH, userid, senv_id);
fil=fopen(tmpfil, "r");
if (fil==NULL) {
loaded=1;
return 1;
}
while (1) {
ret=fgets(buf, sizeof(buf), fil);
if (!ret || buf[0]=='#') break;
l=strlen(buf);
if (l<10 || buf[l-1]!='\n') return -1;
buf[l-1]='\0';
buf[6]='\0';
if (0!=strcmp(buf, "setenv")) return -1;
nam=buf+7;
val=strchr(nam, ' ');
if (val==NULL) return -1;
*val='\0'; val++;
if (*val=='\'') {
if (buf[l-2]!='\'') return -1;
buf[l-2]='\0';
val++;
} else if (*val=='"') {
if (buf[l-2]!='"') return -1;
buf[l-2]='\0';
val++;
}
ret=fgets(old, sizeof(old), fil);
if (!ret) break;
l=strlen(old);
if (l==0 || old[0]!='#' || old[l-1]!='\n') return -1;
old[l-1]='\0';
pold=old+1;
v=getenv(nam);
if (v==NULL) v=empty;
if (0==strcmp(v,pold)) { /* take value from file only if env. variable not changed in the meantime */
p = malloc(sizeof(*p)); if (p == NULL) goto senv;
if (NULL==(p->name = strdup(nam))) goto senv;
if (NULL==(p->value = strdup(v))) goto senv;
p->next = envlist;
envlist=p;
senv:
setenv(nam, val, 1);
}
}
if (0>fclose(fil)) return -1;
loaded=1;
}
return loaded;
}
int F_FUN(sys_setenv)(char *enam, char *eval, int snam, int sval) {
int lnam, lval;
char *v, nam[ENAM_LEN], val[EVAL_LEN];
EnvList *p=NULL;
lnam = sys_trim(enam,snam);
if (lnam>=sizeof(nam)) lnam=sizeof(nam)-1;
strncpy(nam,enam,lnam); nam[lnam] = '\0';
lval = sys_trim(eval,sval);
if (lval>=sizeof(val)) lval=sizeof(val)-1;
strncpy(val,eval,lval); val[lval] = '\0';
if (loaded>0) {
v=getenv(nam);
if (v == NULL) v=empty;
if (!dirty) {
dirty = 0 != strcmp(val,v);
}
p=sys_findenv(nam);
if (p==NULL) {
p = malloc(sizeof(*p)); if (p == NULL) goto senv;
if (NULL==(p->name = strdup(nam))) goto senv;
if (NULL==(p->value = strdup(v))) goto senv;
p->next = envlist;
envlist=p;
}
}
senv:
return setenv(nam, val, 1);
}
int F_FUN(sys_saveenv)(void) {
FILE *fil;
char *v;
EnvList *p;
if (F_FUN(sys_loadenv)()<0 || !dirty) return loaded;
fil=fopen(tmpfil, "w");
if (fil==NULL) return -1;
for (p=envlist; p!=NULL; p=p->next) {
v=getenv(p->name);
if (0!=strcmp(v, p->value)
&& NULL==strchr(v,'\'') /* neither quote */
&& NULL==strchr(v,'!')) { /* nor exclamation allowed in value */
if (0>fputs("setenv ", fil)) return -1;
if (0>fputs(p->name, fil)) return -1;
if (0>fputs(" '", fil)) return -1;
if (0>fputs(v, fil)) return -1;
if (0>fputs("'\n#", fil)) return -1;
if (0>fputs(p->value, fil)) return -1;
if (0>fputs("\n", fil)) return -1;
}
}
if (0>fputs("#\ntest $$ = ", fil)) return -1;
if (0>fputs(senv_id, fil)) return -1;
if (0>fputs(" && rm -f ", fil)) return -1;
if (0>fputs(tmpfil, fil)) return -1;
if (0>fputs("\n", fil)) return -1;
if (0>fclose(fil)) return -1;
dirty=0;
return 0;
}

19
unix/sys_file.f Normal file
View File

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

5
unix/sys_fun.c Normal file
View File

@ -0,0 +1,5 @@
#include "myc_fortran.h"
void F_FUN(sys_funadr)(void (*f)(void), void (**a)(void)) {
*a=f;
}

17
unix/sys_fvi.c Normal file
View File

@ -0,0 +1,17 @@
// FORTRAN function variable interface for Mac OS X
// this file is created by fvi and should not be modified
void sys_call_c__(void (**rtn)(),char *a1,int a2)
{ if(*rtn){(*rtn)(a1,a2);};}
void sys_call_cc__(void (**rtn)(),char *a1,char *a2,int a3,int a4)
{ if(*rtn){(*rtn)(a1,a2,a3,a4);};}
void sys_call_i__(void (**rtn)(),int *a1)
{ if(*rtn){(*rtn)(a1);};}
void sys_call_ci__(void (**rtn)(),char *a1,int *a2,int a3)
{ if(*rtn){(*rtn)(a1,a2,a3);};}
void sys_call_iiieirrrr__(void (**rtn)(),int *a1,int *a2,int *a3,void (*a4)(),int *a5,float *a6,float *a7,float *a8
,float *a9)
{ if(*rtn){(*rtn)(a1,a2,a3,a4,a5,a6,a7,a8,a9);};}
float sys_rfun_rriii__(float (**rtn)(),float *a1,float *a2,int *a3,int *a4,int *a5)
{ return((*rtn)(a1,a2,a3,a4,a5));}
float sys_rfun_r__(float (**rtn)(),float *a1)
{ return((*rtn)(a1));}

75
unix/sys_getenv.f Normal file
View File

@ -0,0 +1,75 @@
!!------------------------------------------------------------------------------
!!
subroutine SYS_GETENV(NAME, VALUE) !!
!! ==================================
!!
!! Get environment variable NAME
!! try all uppercase also
implicit none
!! Arguments:
character*(*) NAME !! logical name
character*(*) VALUE !! result
integer l
character nam*128
call sys_loadenv
call str_trim(nam, name, l)
call getenv(nam(1:l), value)
if (value .ne. ' ') RETURN
if (nam(1:1) .ge. 'a') then
call str_upcase(nam(1:l), nam(1:l))
else
call str_lowcase(nam(1:l), nam(1:l))
endif
call getenv(nam(1:l), value)
end
!!------------------------------------------------------------------------------
!!
subroutine SYS_GETENV_IDX(NAME, VALUE, IDX) !!
!! ===========================================
!!
!! Get environment variable NAME, only list element IDX (start with 0)
!! (separated by comma)
implicit none
!! Arguments:
character*(*) NAME !! logical name
character*(*) VALUE !! result
integer IDX !! index
integer l,pos,j,i
character nam*128, list*1024
call str_trim(nam, name, l)
call getenv(nam(1:l), list)
if (list .eq. ' ') then
if (nam(1:1) .ge. 'a') then
call str_upcase(nam(1:l), nam(1:l))
else
call str_lowcase(nam(1:l), nam(1:l))
endif
call getenv(nam(1:l), list)
endif
pos=0
do i=1,idx
j=index(list(pos+1:), ',')
if (j .eq. 0) then
value=' '
RETURN
endif
pos=pos+j
enddo
j=index(list(pos+1:), ',')
if (j .eq. 1) then
value=' '
RETURN
endif
if (j .le. 0) then
value=list(pos+1:)
else
value=list(pos+1:pos+j-1)
endif
end

22
unix/sys_home.f Normal file
View File

@ -0,0 +1,22 @@
!!-----------------------------------------------------------------------------
!!
subroutine SYS_HOME(HOME) !!
!! =========================
!!
!! get home directory (+ dot) as prefix for preferences files
character HOME*(*) !! (out) filename
integer l
call sys_getenv('HOME',home)
call str_trim(home, home, l)
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

44
unix/sys_lun.f Normal file
View File

@ -0,0 +1,44 @@
!!-----------------------------------------------------------------------------
!!
subroutine SYS_GET_LUN(LUN) !!
!!
!! allocate logical unit number
!!
integer LUN !! out
logical*1 act(50:100)
common/syslun/act
data act/51*.false./
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.
end
!!-----------------------------------------------------------------------------
!!
subroutine SYS_FREE_LUN(LUN) !!
!!
!! deallocate logical unit number
!!
integer LUN !! in
logical*1 act(50:100)
common/syslun/act
if (lun .lt. 50 .or. lun .gt. 99) then
stop 'SYS_FREE_LUN: illegal lun'
endif
if (act(lun)) then
act(lun)=.false.
else
stop 'SYS_FREE_LUN: lun already free'
endif
end

54
unix/sys_open.f Normal file
View File

@ -0,0 +1,54 @@
!!-----------------------------------------------------------------------------
!!
subroutine SYS_OPEN(LUN, FILE, ACCESS, IOSTAT) !!
!! ==============================================
!!
!! ACCESS='r': open file for read
!! ACCESS='w': open or create file for write (on vms: new version, on unix: overwrite)
!! ACCESS='wo': overwrite existing file (do not make a new version)
!! ACCESS='wn': keep old file (on unix systems, a tilde '~' is appended to the name)
!! ACCESS='a': open or create file for append
integer LUN !! (in) logical unit number
character FILE*(*) !! (in) filename
character ACCESS*(*) !! (in) access mode
integer IOSTAT !! (out) status
character acc*2
character amnt*128
integer i,l,ios
call str_upcase(acc, access)
if (acc .eq. 'R') then
open(lun, file=file, iostat=iostat, status='old')
if (iostat .eq. 0) RETURN ! success
l=0
i=1
do while (i .ne. 0)
l=l+i
i=index(file(l+1:),'/')
enddo
if (l .eq. 1) RETURN ! no directory given
open(lun, file=file(1:l-1), iostat=ios, status='old')
if (ios .eq. 0) then
close(lun)
RETURN ! directory exists -> already mounted
endif
call sys_getenv('dat_automount', amnt)
if (amnt .eq. ' ') RETURN
call sys_cmd(amnt) !try to mount
open(lun, file=file, iostat=iostat, status='old')
else if (acc .eq. 'W' .or. acc .eq. 'WO') then
open(lun, file=file, iostat=iostat, status='unknown')
else if (acc .eq. 'WN') then
! rename to be done
open(lun, file=file, iostat=iostat, status='unknown')
else if (acc .eq. 'A') then
open(lun, file=file, iostat=iostat, status='unknown'
1, access='append')
else
print *,'unknown access mode: ',acc
stop 'error in SYS_OPEN'
endif
end

112
unix/sys_parse.f Normal file
View File

@ -0,0 +1,112 @@
!!-----------------------------------------------------------------------------
!!
subroutine sys_parse(result, reslen, file, default, mode) !!
!! ---------------------------------------------------------
!!
!! parse file name
!! mode=0: skip default directory
!! mode=1: name only
!! mode=2: extension only
!! mode=3: name+extension only
implicit none
character*(*) result, file, default
integer reslen, mode
character*1024 dir1, dir2, res
integer l1,l2,d1,d2,n1,n2,e1,e2
call sys_split_path(file, d1, n1, e1)
call sys_split_path(default, d2, n2, e2)
reslen=0
if (mode .eq. 0) then
if (d1 .gt. 0) then
call sys_realpath(dir1, l1, file(1:max(1,d1-1)))
elseif (d2 .gt. 0) then
call sys_realpath(dir1, l1, default(1:max(1,d2-1)))
else
goto 19
endif
call getcwd(dir2)
call sys_realpath(dir2, l2, dir2)
if (dir1(1:l1) .ne. dir2(1:l2)) then
if (d1 .gt. 0) then
call str_append(res, reslen, file(1:max(1,d1-1)))
elseif (d2 .gt. 0) then
call str_append(res, reslen, default(1:max(1,d2-1)))
else
stop 'SYS_PARSE: fatal error'
endif
if (reslen .gt. 1) then
call str_append(res, reslen, '/')
endif
endif
19 continue
elseif (mode .lt. 0 .or. mode .gt. 3) then
stop 'SYS_PARSE: illegal mode'
endif
if (mode .ne. 2) then
if (n1 .gt. d1) then
call str_append(res, reslen, file(d1+1:n1))
elseif (n2 .gt. d2) then
call str_append(res, reslen, default(d2+1:n2))
endif
endif
if (mode .ne. 1) then
if (e1 .gt. n1) then
call str_append(res, reslen, file(n1+1:e1))
elseif (e2 .gt. n2) then
call str_append(res, reslen, default(n2+1:e2))
endif
endif
if (reslen .eq. 0) then
result=' '
else
result=res(1:reslen)
endif
end
subroutine sys_split_path(path, enddir, endnam, endext)
!
! examine a path and report the position of the end of the directory,
! of the filename, and the extension
! Example: call sys_split_path("/home/user/file.name.txt", ed, en, ee)
! ^ ^ ^
! ed=9 en=18 ee=22
character path*(*)
integer enddir, endnam, endext
integer i, mx
i=index(path, '/')
if (i .eq. 0) then
enddir=0
else
mx=i
do while (i .lt. len(path))
i=i+1
if (path(i:i) .eq. '/') mx=i
enddo
enddir=mx
i=mx
endif
mx=len(path)
endnam=mx
do while (i .lt. mx)
i=i+1
if (path(i:i) .eq. '.') endnam=i-1
if (path(i:i) .le. ' ') then
mx=i-1
endif
enddo
endext=mx
if (endnam .gt. mx) endnam=mx
end

40
unix/sys_rdline.c Normal file
View File

@ -0,0 +1,40 @@
#include <assert.h>
#include <unistd.h>
#include <string.h>
#include <stdlib.h>
#include <stdio.h>
#include "myc_str.h"
#include "myc_fortran.h"
static char *last_line = NULL;
char *readline (char *prompt);
void add_history(const char *line);
void F_FUN(sys_rd_line)(F_CHAR(cmd), int *retlen, F_CHAR(prompt) F_CLEN(cmd) F_CLEN(prompt))
{
char *line_read;
char p0[64], p[64];
STR_TO_C(p0, prompt);
str_copy(p, "\n");
str_append(p, p0);
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);
STR_TO_F(cmd, line_read);
*retlen=strlen(line_read);
last_line = line_read;
if (*retlen>F_LEN(cmd)) *retlen=F_LEN(cmd);
} else {
*retlen=-1;
}
}

29
unix/sys_rdline0.c Normal file
View File

@ -0,0 +1,29 @@
#include <assert.h>
#include <unistd.h>
#include <string.h>
#include <stdlib.h>
#include <stdio.h>
#include "myc_str.h"
#include "myc_fortran.h"
void F_FUN(sys_rd_line)(F_CHAR(cmd), int *retlen, F_CHAR(prompt) F_CLEN(cmd) F_CLEN(prompt))
{
char *line_read;
char p0[64], p[64], buf[1024];
STR_TO_C(p0, prompt);
str_copy(p, "\n");
str_append(p, p0);
puts(p);
line_read = fgets(buf, sizeof(buf), stdin);
if (line_read)
{
STR_TO_F(cmd, line_read);
*retlen=strlen(line_read);
if (*retlen>F_LEN(cmd)) *retlen=F_LEN(cmd);
} else {
*retlen=-1;
}
}

80
unix/sys_remote_host.f Executable file
View File

@ -0,0 +1,80 @@
!!-----------------------------------------------------------------------------
!!
subroutine SYS_REMOTE_HOST(STR, TYPE) !!
!!
!! get remote host name/number
!!
!! type: TN telnet, RT: decnet, LO: local, XW: X-window (ssh or telnet)
!!
character STR*(*), TYPE*(*) !!
character host*128, line*128, path*256, os*7
integer i,j,lun,iostat
integer sys_cmd
external sys_cmd
call sys_getenv('OS', os)
call str_upcase(os, os)
if (os .eq. 'WINDOWS') then
str='local'
type='LO'
return
endif
call sys_getenv('HOST', host)
call sys_getenv('DISPLAY', str)
i=index(str,':')
type=' '
if (i .ge. 1) then
if (i .eq. 1) then
str='localhost'
else
str=str(1:i-1)
endif
type='XW'
if (str .ne. 'localhost') goto 80
endif
call sys_getenv('REMOTEHOST', str)
if (str .eq. ' ') then
call sys_temp_name('.whoami', path)
call sys_delete_file(path)
i=sys_cmd('who -m > '//path)
call sys_get_lun(lun)
call sys_open(lun, path, 'r', iostat)
if (iostat .ne. 0) goto 9
read(lun,'(a)',end=9,err=9) line
9 close(lun)
call sys_delete_file(path)
i=index(line,'(')
if (i .ne. 0 .and. i .lt. len(line)) then
str=line(i+1:)
i=index(str, ')')
if (i .ne. 0) str(i:)=' '
endif
endif
i=index(str,':')
if (i .ne. 0) str(i:)=' '
if (str .ne. ' ') then
if (type .eq. ' ') type='TN'
else
str=host
if (type .eq. ' ') type='LO'
endif
c add domain to short host names
80 i=index(str, '.')
j=index(host, '.')
if (j .gt. 0 .and. i .eq. 0) then
call str_trim(str, str, i)
str(i+1:)=host(j:)
endif
end

56
unix/sys_try.c Normal file
View File

@ -0,0 +1,56 @@
#include <assert.h>
#include <unistd.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <setjmp.h>
#include <signal.h>
#include <limits.h>
#include "myc_fortran.h"
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)=intcatch;
void (*errhdl)(void);
void sighdl(int sig)
{ if (called) longjmp(env,sig);
}
void F_FUN(sys_err_hdl)(void errhdl0(void))
{ errhdl=errhdl0; }
void F_FUN(sys_int_hdl)(void inthdl0(int sig))
{ inthdl=inthdl0; }
void F_FUN(sys_try)(void proc(void))
{ int 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 F_FUN(sys_abort)(void)
{ if (called) longjmp(env,-2);
}
void F_FUN(sys_exit_hdl)(void hdl(void))
{ atexit(hdl);
}

167
unix/sys_unix.c Normal file
View File

@ -0,0 +1,167 @@
#include <sys/stat.h>
#include <sys/types.h>
#include <termios.h>
#include <unistd.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <limits.h>
#include <time.h>
#include <utmp.h>
#include "myc_tmp.h"
#include "myc_str.h"
#include "myc_fortran.h"
void usleep_(int *usec) { usleep(*usec); }
int F_FUN(getppid)(void) { return getppid(); }
void F_FUN(sys_check_system)(F_CHAR(code) F_CLEN(code)) {
#if defined __alpha
STR_TO_F(code, "TRU64");
#elif defined __GNUC__
STR_TO_F(code, "GNU");
#else
#error unsupported machine
#endif
}
void F_FUN(sys_fortran_interface)(int *underscores, int *descriptor) {
*underscores = F_UNDERSCORE;
*descriptor = F_DESCRIPTOR;
}
void F_FUN(sys_realpath)(F_CHAR(rpath), int *reslen,
F_CHAR(path) F_CLEN(rpath) F_CLEN(path)) {
char p[PATH_MAX], rp[PATH_MAX], *pt;
STR_TO_C(p, path);
pt=realpath(p, rp);
if (pt==NULL) str_copy(rp, p);
*reslen=strlen(rp);
STR_TO_F(rpath, rp);
}
int sys_trim(char *str, int clen) {
while (clen>0) {
clen--;
if (str[clen] != ' ') return clen+1;
}
return 1;
}
long F_FUN(sys_time)(void) {
return time(NULL);
}
void F_FUN(sys_cmd)(char *command, int clen) {
int l;
char *p;
l = sys_trim(command, clen);
p = malloc((unsigned) l+1); if( p == NULL ) return;
strncpy(p,command,l); p[l] = '\0';
system(p);
free(p);
}
void F_FUN(sys_cmd_result)(F_CHAR(command), F_CHAR(result), int *reslen F_CLEN(command) F_CLEN(result)) {
int l;
char *p;
FILE *fp;
char *buffer[PATH_MAX];
STR_TO_C(buffer, command);
fp = popen(buffer, "r");
buffer[0] = '\0';
if (fp != NULL) {
fgets(buffer, sizeof(buffer), fp);
pclose(fp);
}
*reslen = strlen(buffer);
STR_TO_F(result, buffer);
}
static struct termios atts;
void F_FUN(sys_rd_tmo)(char *prompt, char *result, int *reslen, int p_len, int r_len) {
struct termios attr;
int ires, i, ntmo, chr;
ires=tcgetattr(STDIN_FILENO,&attr);
atts=attr; /* save term. attr. */
if (ires!=0) {
perror("error in terinq/tcgetattr ");
(*reslen)=0;
*result='\0';
return;
}
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("error in terinq/tcsetattr ");}
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 */
clearerr(stdin);
if (ires!=0) {
perror("error in terinq/tcsetattr ");
}
}
void F_FUN(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");}
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");};
}

22
unix/sys_wait.f Normal file
View File

@ -0,0 +1,22 @@
!!-----------------------------------------------------------------------------
!!
subroutine SYS_WAIT(SECONDS) !!
!! ============================
!! wait for SECONDS
real SECONDS !! resolution should be better than 0.1 sec.
real tim, del
real secnds
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

274
unix/sysc.c Executable file
View File

@ -0,0 +1,274 @@
#include <sys/stat.h>
#include <sys/types.h>
#include <termios.h>
#include <unistd.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <time.h>
#include <utmp.h>
#include "myc_tmp.h"
#include "myc_str.h"
#include "sys_util.h"
#define ENAM_LEN 128
#define EVAL_LEN 1024
void usleep_(int *usec) { usleep(*usec); }
int getppid_(void) { return getppid(); }
int lnblnk_(const char *str, int len);
#ifdef __alpha
int setenv(char *p1, char *p2, int ow);
#endif
typedef struct _EnvList { struct _EnvList *next; char *name; char *value; } EnvList;
static EnvList *envlist;
static char tmpfil[128];
static char senv_id[16];
static char *empty="";
static int loaded=0;
static int dirty=0;
EnvList *sys_findenv(char *name) {
EnvList *p;
for (p=envlist; p!=NULL; p=p->next) {
if (0==strcmp(name, p->name)) {
return p;
}
}
return NULL;
}
void F_FUN(sys_check_system)(F_CHAR(code) F_CLEN(code)) {
#if defined __alpha
STR_TO_F(code, "TRU64");
#elif defined __GNUC__
STR_TO_F(code, "GNU");
#elif defined __INTEL_COMPILER
STR_TO_F(code, "IFORT");
#else
"sys_check_system: unsupported machine"
#endif
}
int F_FUN(sys_loadenv)(void) {
FILE *fil;
char buf[ENAM_LEN+EVAL_LEN+10];
char old[EVAL_LEN], userid[32];
char *nam, *val, *pold, *u, *ret, *v;
int l;
EnvList *p;
if (!loaded) {
loaded=-1; /* assume failure */
/* u=cuserid(userid); */
u=getenv("USER");
if (u==NULL) {
strcpy(userid, "Anonymous");
} else {
strncpy(userid, u, sizeof(userid));
}
val=getenv("senv_id");
if (val==NULL) {
sprintf(senv_id, "%d", getppid());
} else {
strcpy(senv_id, val);
}
sprintf(tmpfil, "%s/.senv_%s.%s",TEMP_PATH, userid, senv_id);
fil=fopen(tmpfil, "r");
if (fil==NULL) {
loaded=1;
return 1;
}
while (1) {
ret=fgets(buf, sizeof(buf), fil);
if (!ret || buf[0]=='#') break;
l=strlen(buf);
if (l<10 || buf[l-1]!='\n') return -1;
buf[l-1]='\0';
buf[6]='\0';
if (0!=strcmp(buf, "setenv")) return -1;
nam=buf+7;
val=strchr(nam, ' ');
if (val==NULL) return -1;
*val='\0'; val++;
if (*val=='"') {
if (buf[l-2]!='"') return -1;
buf[l-2]='\0';
val++;
}
ret=fgets(old, sizeof(old), fil);
if (!ret) break;
l=strlen(old);
if (l==0 || old[0]!='#' || old[l-1]!='\n') return -1;
old[l-1]='\0';
pold=old+1;
v=getenv(nam);
if (v==NULL) v=empty;
if (0==strcmp(v,pold)) { /* take value from file only if env. variable not changed in the meantime */
p = malloc(sizeof(*p)); if (p == NULL) goto senv;
if (NULL==(p->name = strdup(nam))) goto senv;
if (NULL==(p->value = strdup(v))) goto senv;
p->next = envlist;
envlist=p;
senv:
setenv(nam, val, 1);
}
}
if (0>fclose(fil)) return -1;
loaded=1;
}
return loaded;
}
int F_FUN(sys_setenv)(char *enam, char *eval, int snam, int sval) {
int lnam, lval;
char *v, nam[ENAM_LEN], val[EVAL_LEN];
EnvList *p=NULL;
lnam = lnblnk_(enam,snam);
if (lnam>=sizeof(nam)) lnam=sizeof(nam)-1;
strncpy(nam,enam,lnam); nam[lnam] = '\0';
lval = lnblnk_(eval,sval);
if (lval>=sizeof(val)) lval=sizeof(val)-1;
strncpy(val,eval,lval); val[lval] = '\0';
if (loaded>0) {
v=getenv(nam);
if (v == NULL) v=empty;
if (!dirty) {
dirty = 0 != strcmp(val,v);
}
p=sys_findenv(nam);
if (p==NULL) {
p = malloc(sizeof(*p)); if (p == NULL) goto senv;
if (NULL==(p->name = strdup(nam))) goto senv;
if (NULL==(p->value = strdup(v))) goto senv;
p->next = envlist;
envlist=p;
}
}
senv:
return setenv(nam, val, 1);
}
int F_FUN(sys_saveenv)(void) {
FILE *fil;
char *v;
EnvList *p;
if (F_FUN(sys_loadenv)()<0 || !dirty) return loaded;
fil=fopen(tmpfil, "w");
if (fil==NULL) return -1;
for (p=envlist; p!=NULL; p=p->next) {
v=getenv(p->name);
if (0!=strcmp(v, p->value)) {
if (0>fputs("setenv ", fil)) return -1;
if (0>fputs(p->name, fil)) return -1;
if (0>fputs(" \"", fil)) return -1;
if (0>fputs(v, fil)) return -1;
if (0>fputs("\"\n#", fil)) return -1;
if (0>fputs(p->value, fil)) return -1;
if (0>fputs("\n", fil)) return -1;
}
}
if (0>fputs("#\nif ($$ == ", fil)) return -1;
if (0>fputs(senv_id, fil)) return -1;
if (0>fputs(") then\n /bin/rm ", fil)) return -1;
if (0>fputs(tmpfil, fil)) return -1;
/*
if (0>fputs("\n echo \"#\" > ", fil)) return -1;
if (0>fputs(tmpfil, fil)) return -1;
*/
if (0>fputs("\nendif\n", fil)) return -1;
if (0>fclose(fil)) return -1;
dirty=0;
return 0;
}
struct termios atts;
void F_FUN(sys_rd_tmo)(char *prompt, char *result, int *reslen, int p_len, int r_len) {
struct termios attr;
int ires, i, ntmo, chr;
ires=tcgetattr(STDIN_FILENO,&attr);
atts=attr; /* save term. attr. */
if (ires!=0) {
perror("error in terinq/tcgetattr ");
(*reslen)=0;
*result='\0';
return;
}
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("error in terinq/tcsetattr ");}
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 */
clearerr(stdin);
if (ires!=0) {
perror("error in terinq/tcsetattr ");
}
}
int mkdir_(const char *path, int p_len) {
int i;
char *p;
i = lnblnk_(path,p_len);
p = malloc((unsigned) i+1); if( p == NULL ) return (-1);
strncpy(p,path,i); p[i] = '\0';
i = mkdir(p, 0777);
free(p);
return(i);
}
void F_FUN(sys_cmd)(char *command, int clen) {
int rc, l;
char *p;
l = lnblnk_(command, clen);
p = malloc((unsigned) l+1); if( p == NULL ) return;
strncpy(p,command,l); p[l] = '\0';
rc = system(p);
free(p);
}

100
unix/sysc1.c Normal file
View File

@ -0,0 +1,100 @@
#include <assert.h>
#include <unistd.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <setjmp.h>
#include <signal.h>
#include <limits.h>
#include "myc_str.h"
#include "sys_util.h"
void F_FUN(sys_realpath)(F_CHAR(rpath), int *reslen, F_CHAR(path) F_CLEN(rpath) F_CLEN(path)) {
char p[PATH_MAX], rp[PATH_MAX], *pt;
STR_TO_C(p, path);
pt=realpath(p, rp);
if (pt==NULL) str_copy(rp, p);
*reslen=strlen(rp);
STR_TO_F(rpath, rp);
}
static char *last_line = NULL;
char *readline (char *prompt);
void add_history(const char *line);
void F_FUN(sys_rd_line)(F_CHAR(cmd), int *retlen, F_CHAR(prompt) F_CLEN(cmd) F_CLEN(prompt))
{
char *line_read;
char p0[64], p[64];
STR_TO_C(p0, prompt);
str_copy(p, "\n");
str_append(p, p0);
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);
STR_TO_F(cmd, line_read);
*retlen=strlen(line_read);
last_line = line_read;
if (*retlen>F_LEN(cmd)) *retlen=F_LEN(cmd);
} 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)=intcatch;
void (*errhdl)(void);
void sighdl(int sig)
{ if (called) longjmp(env,sig);
}
void F_FUN(sys_err_hdl)(void errhdl0(void))
{ errhdl=errhdl0; }
void F_FUN(sys_int_hdl)(void inthdl0(int sig))
{ inthdl=inthdl0; }
void F_FUN(sys_try)(void proc(void))
{ int 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 F_FUN(sys_abort)(void)
{ if (called) longjmp(env,-2);
}
void F_FUN(sys_exit_hdl)(void hdl(void))
{ int res;
res=atexit(hdl);
}

83
unix/terinq.f Normal file
View File

@ -0,0 +1,83 @@
program terinq
implicit none
character gdev*32, pps*32, line*256
integer rows, i, ll, l, cols
logical debug
call sys_getenv('TERINQ_DEB', line)
debug=(line .ne. ' ')
line=' '
call sys_get_cmdpar(line, i)
if (i .eq. 0) i=1
call sys_loadenv
if (line(1:7) .eq. 'gethost') then ! host info on command line
i=index(line,'!')
if (i .ne. 0) then
call sys_setenv('REMOTEHOST', line(9:i-1))
endif
i=index(line,'(')
if (i .ne. 0) then
line=line(i+1:)
i=index(line, ')')
if (i .gt. 1) then
call sys_setenv('REMOTEHOST', line(1:i-1))
endif
endif
line=' '
i=1
endif
call sys_setenv('CHOOSER_TERINQ', '1')
call cho_inq(line(1:i), gdev, pps, cols, rows)
if (debug) print *,'cho_inq: rows=',rows
ll=0
if (gdev .ne. ' ') then
call sys_setenv('CHOOSER_GDEV',gdev)
call sys_setenv('PGPLOT_DEV','/'//gdev)
call str_trim(gdev, gdev, l)
line='Display type: '//gdev(1:l)
ll=l+14
endif
call cho_vpp_cups(pps)
if (pps .ne. ' ') then
if (ll .gt. 0) then
line(ll+1:)=', '
ll=ll+3
endif
call str_trim(pps, pps, l)
line(ll+1:)='Default Printer: '//pps(1:l)
ll=ll+l+17
call sys_setenv('CHOOSER_DEST',pps(1:l))
call sys_setenv('CHOOSER_PDEV','CPS')
endif
if (rows .ne. 0) then
if (debug) print *,'terinq: rows=',rows
if (ll .gt. 0) then
line(ll+1:)=', '
ll=ll+2
endif
write(line(ll+1:), '(i3,a)') rows, ' rows'
call sys_setenv('TERINQ_ROWS', line(ll+1:ll+3))
ll=ll+8
endif
if (cols .ne. 0) then
if (ll .gt. 0) then
line(ll+1:ll+1)=','
ll=ll+1
endif
write(line(ll+1:), '(i3,a)') cols, ' cols'
call sys_setenv('TERINQ_COLS', line(ll+1:ll+3))
ll=ll+8
endif
if (ll .gt. 0) then
print *
print *,line(1:ll)
print *
endif
90 continue
call sys_saveenv
call sys_clean_tmp
end

88
unix/terinq_new.f Normal file
View File

@ -0,0 +1,88 @@
program terinq
implicit none
character name*64, gdev*32, pps*32, line*78
integer rows, i, ll, l, cols, iostat
integer getppid
line=' '
call sys_get_cmdpar(line, i)
if (i .eq. 0) i=1
call sys_loadenv
call sys_temp_name('.terinq',name)
call sys_open(1, name, 'wo', iostat)
if (iostat .ne. 0) then
print *,'can not open ',name
stop 'CHO failed'
endif
if (line(1:i) .eq. 'gethost') then ! read host information from file
read (1,'(a)',end=3) line
rewind 1
i=index(line,'(')
if (i .ne. 0) then
line=line(i+1:)
i=index(line, ')')
if (i .gt. 1) then
call sys_setenv('REMOTEHOST', line(1:i-1))
endif
endif
3 line=' '
i=1
endif
call cho_inq(line(1:i), gdev, pps, cols, rows)
ll=0
if (gdev .ne. ' ') then
call sys_setenv('CHOOSER_GDEV',gdev)
call sys_setenv('PGPLOT_DEV','/'//gdev)
call str_trim(gdev, gdev, l)
line='Display type: '//gdev(1:l)
ll=l+14
endif
call cho_vpp_cups(pps)
if (pps .ne. ' ') then
if (ll .gt. 0) then
line(ll+1:)=', '
ll=ll+3
endif
call str_trim(pps, pps, l)
line(ll+1:)='Default Printer: '//pps(1:l)
ll=ll+l+17
call sys_setenv('CHOOSER_DEST',pps(1:l))
call sys_setenv('CHOOSER_PDEV','PS')
write(1,'(a)') 'alias lp lp -d '//pps(1:l)
write(1,'(a)') 'alias lpr lpr -P '//pps(1:l)
write(1,'(a)') 'alias lpl lp -o landscape -d '//pps(1:l)
endif
if (cols .ne. 0 .or. rows .ne. 0) then
if (ll .gt. 0) then
line(ll+1:)=', '
ll=ll+3
endif
if (rows .eq. 0) then
rows=24
else
write(1, '(a,i2)') 'stty rows ',rows
endif
if (cols .eq. 0) then
cols=80
else
write(1, '(a,i2)') 'stty columns ',cols
endif
write(line(ll+1:),'(a,i4,a,i3)') 'Window size:',cols,'x',rows
ll=ll+20
endif
if (ll .gt. 0) then
print *
print *,line(1:ll)
print *
endif
90 continue
write(1,'(2a)') '/usr/bin/rm ',name
close(1)
call sys_saveenv
call sys_clean_tmp
end

152
unix/terinq_old.f Normal file
View File

@ -0,0 +1,152 @@
program terinq
implicit none
character name*64, gdev*32, pps*32, line*78
integer rows, i, ll, l, cols
integer getppid
line=' '
call sys_get_cmdpar(line, i)
if (i .eq. 0) i=1
call sys_loadenv
call sys_temp_name('terinq',name)
open(1,file=name,status='unknown',carriagecontrol='list'
1,err=9)
goto 10
9 type *,'can not open ',name
stop 'CHO failed'
10 if (line(1:i) .eq. 'gethost') then ! read host information from file
read (1,'(a)',end=3) line
rewind 1
i=index(line,'(')
if (i .ne. 0) then
line=line(i+1:)
i=index(line, ')')
if (i .gt. 1) then
call sys_setenv('REMOTEHOST', line(1:i-1))
endif
endif
3 line=' '
i=1
endif
call cho_inq(line(1:i), gdev, pps, cols, rows)
ll=0
if (gdev .ne. ' ') then
call sys_setenv('CHOOSER_GDEV',gdev)
call sys_setenv('PGPLOT_DEV','/'//gdev)
call str_trim(gdev, gdev, l)
line='Display type: '//gdev(1:l)
ll=l+14
endif
call cho_vpp_cups(pps)
if (pps .ne. ' ') then
if (ll .gt. 0) then
line(ll+1:)=', '
ll=ll+3
endif
call str_trim(pps, pps, l)
line(ll+1:)='Default Printer: '//pps(1:l)
ll=ll+l+17
call sys_setenv('CHOOSER_DEST',pps(1:l))
call sys_setenv('CHOOSER_PDEV','PS')
write(1,'(a)') 'alias lp lp -d '//pps(1:l)
write(1,'(a)') 'alias lpr lpr -P '//pps(1:l)
write(1,'(a)') 'alias lpl lp -o landscape -d '//pps(1:l)
endif
if (cols .ne. 0 .or. rows .ne. 0) then
if (ll .gt. 0) then
line(ll+1:)=', '
ll=ll+3
endif
if (rows .eq. 0) then
rows=24
else
write(1, '(a,i2)') 'stty rows ',rows
endif
if (cols .eq. 0) then
cols=80
else
write(1, '(a,i2)') 'stty columns ',cols
endif
write(line(ll+1:),'(a,i4,a,i3)') 'Window size:',cols,'x',rows
ll=ll+20
endif
if (ll .gt. 0) then
type *
type *,line(1:ll)
type *
endif
90 continue
write(1,'(2a)') '/usr/bin/rm ',name
close(1)
call sys_saveenv
call sys_clean_tmp
end
subroutine sys_clean_tmp
implicit none
parameter fp=54, dp=41, dl=6
! these parameters depend on the formatting of the ls -l command
! <-dl->
!-rw-r--r-- 1 lnslib system 131 May 16 11:00 /tmp/.cho_lnslib.1603
! ^ dp ^ fp
character file*128, user*32, line*128, line0*128
integer i, j, np, l, lf, lun, cnt, pid, iret, pidlist(100)
call sys_temp_name('clnup', file)
call str_trim(file, file, lf)
call sys_delete_file(file)
call sys_getenv('USER', user)
call str_trim(user, user, l)
call sys_cmd('ps > '//file(1:lf)
1 //';ls -alt /tmp/.*_'//user(1:l)//'.* >> '//file(1:lf))
call sys_get_lun(lun)
line0=' '
open(lun, file=file, status='old', readonly, err=9)
read(lun, '(a)', end=2) line ! read title
j=0
5 read(lun, '(a)', end=2) line
read(line, *, err=7, end=7) pid
if (pid .ne. 0 .and. j .lt. 100) then
j=j+1
pidlist(j)=pid
goto 5
endif
7 np=j
cnt=0
10 read(lun, '(a)', end=2) line
if (line(fp+1:fp+5) .ne. '/tmp/') goto 9
call str_trim(line,line,l)
if (line(dp+1:dp+dl) .ne. line0(dp+1:dp+dl)) then
cnt=cnt+1
line0=line
endif
if (cnt .gt. 2 .and. l .gt. fp) then
do i=l,l-9,-1
if (line(i:i) .lt. '0' .or. line(i:i) .gt. '9') then
if (line(i:i) .ne. '.') goto 10
if (i .lt. l) then
read(line(i+1:l), *) pid
do j=1,np
if (pid .eq. pidlist(j)) goto 10
enddo
call sys_delete_file(line(fp+1:l))
goto 10
endif
endif
enddo
endif
goto 10
2 close(lun)
9 call sys_free_lun(lun)
call sys_delete_file(file)
end

3
unix/tru64/CVS/Entries Normal file
View File

@ -0,0 +1,3 @@
/sys_open.f/1.1.1.1/Tue Nov 2 15:54:57 2004//
/zm_fit/1.1.1.1/Tue Nov 2 15:54:57 2004//
D

1
unix/tru64/CVS/Repository Normal file
View File

@ -0,0 +1 @@
analysis/fit/unix/tru64

1
unix/tru64/CVS/Root Normal file
View File

@ -0,0 +1 @@
/afs/psi.ch/project/sinq/cvs

54
unix/tru64/sys_open.f Normal file
View File

@ -0,0 +1,54 @@
!!-----------------------------------------------------------------------------
!!
subroutine SYS_OPEN(LUN, FILE, ACCESS, IOSTAT) !!
!! ==============================================
!!
!! ACCESS='r': open file for read
!! ACCESS='w': open or create file for write (on vms: new version, on unix: overwrite)
!! ACCESS='wo': overwrite existing file (do not make a new version)
!! ACCESS='wn': keep old file (on unix systems, a tilde '~' is appended to the name)
!! ACCESS='a': open or create file for append
integer LUN !! (in) logical unit number
character FILE*(*) !! (in) filename
character ACCESS*(*) !! (in) access mode
integer IOSTAT !! (out) status
character acc*2
character amnt*128
integer i,j,l,ios
call str_upcase(acc, access)
if (acc .eq. 'R') then
open(lun, name=file, iostat=iostat, status='old', readonly)
if (iostat .eq. 0) RETURN
l=0
i=1
do while (i .ne. 0)
l=l+i
i=index(file(l+1:),'/')
enddo
if (l .eq. 1) RETURN ! no directory given
open(lun, name=file(1:l-1), iostat=ios, status='old')
if (ios .eq. 0) then
close(lun)
RETURN ! directory exists -> already mounted
endif
call sys_getenv('dat_automount', amnt)
if (amnt .eq. ' ') RETURN
call sys_cmd(amnt) !try to mount
open(lun, name=file, iostat=iostat, status='old', readonly)
else if (acc .eq. 'W' .or. acc .eq. 'WO') then
open(lun, name=file, iostat=iostat, status='unknown')
else if (acc .eq. 'WN') then
! rename to be done
open(lun, name=file, iostat=iostat, status='unknown')
else if (acc .eq. 'A') then
open(lun, name=file, iostat=iostat, status='unknown'
1, access='append')
else
print *,'unknown access mode: ',acc
stop 'error in SYS_OPEN'
endif
end

1
unix/tru64/zm_fit Normal file
View File

@ -0,0 +1 @@
this file is used by config

1
unix/zm_fit Normal file
View File

@ -0,0 +1 @@
this file is used by config